Imported Upstream snapshot 8.3~beta0+13298

1551 files changed, 112733 insertions, 90483 deletions

diff --git a/.gitignore b/.gitignore
index 965adf7a..16d011c3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,9 +3,11 @@
 *.d.raw
 *.vo
 *.cm*
+*.annot
+*.spit
+*.spot
 *.o
 *.a
-*.annot
 *.log
 *.aux
 *.dvi
@@ -13,31 +15,33 @@
 *.bbl
 *.idx
 *.ilg
-*.lof
 *.toc
 *.atoc
 *.comidx
 *.comind
-*.tacidx
-*.tacind
 *.erridx
 *.errind
-*.ind
+*.haux
 *.hcomind
-*.htacind
 *.herrind
 *.hind
-*.haux
+*.htacind
 *.htoc
+*.ind
+*.lof
+*.stamp
+*.tacidx
+*.tacind
 *.v.tex
-*.v.ps
 *.v.pdf
+*.v.ps
 *.v.html
-bin
+revision
+TAGS
+bin/
 config/Makefile
 config/coq_config.ml
-contrib/dp/dp_zenon.ml
-contrib/micromega/csdpcert
+plugins/dp/dp_zenon.ml
 dev/ocamldebug-coq
 dev/ocamlweb-doc/lex.ml
 dev/ocamlweb-doc/syntax.ml
@@ -45,46 +49,56 @@ dev/ocamlweb-doc/syntax.mli
 ide/config_lexer.ml
 ide/config_parser.ml
 ide/config_parser.mli
+ide/coq_lex.ml
+ide/extract_index.ml
+ide/find_phrase.ml
 ide/highlight.ml
-ide/index_urls.txt
 ide/undo.mli
 ide/utf8_convert.ml
-ide/extract_index.ml
-ide/find_phrase.ml
-kernel/copcodes.ml
 kernel/byterun/coq_jumptbl.h
+kernel/byterun/dllcoqrun.so
+kernel/copcodes.ml
 scripts/tolink.ml
 states/initial.coq
-theories/Numbers/Natural/BigN/NMake.v
+test-suite/lia.cache
+test-suite/trace
+theories/Numbers/Natural/BigN/NMake_gen.v
 tools/coqdep_lexer.ml
+tools/coqdoc/cpretty.ml
 tools/coqwc.ml
 tools/gallina_lexer.ml
-tools/coqdoc/pretty.ml
-tools/coqdoc/index.ml
-toplevel/mltop.byteml
 toplevel/mltop.optml
-doc/RecTutorial/RecTutorial.html
-doc/common/version.tex
-doc/faq/html
-doc/RecTutorial/RecTutorial.pdf
-doc/RecTutorial/RecTutorial.ps
+plugins/micromega/csdpcert
+toplevel/mltop.byteml
+coqdoc.sty
+ide/index_urls.txt
+doc/faq/html/
+doc/refman/Reference-Manual.pdf
+doc/refman/Reference-Manual.ps
+doc/refman/cover.html
+doc/refman/styles.hva
 doc/refman/Reference-Manual.html
+doc/common/version.tex
 doc/refman/Reference-Manual.sh
-doc/refman/Reference-Manual.ps
-doc/refman/Reference-Manual.pdf
 doc/refman/coqide-queries.eps
 doc/refman/coqide.eps
-doc/refman/cover.html
 doc/refman/euclid.ml
 doc/refman/euclid.mli
 doc/refman/heapsort.ml
 doc/refman/heapsort.mli
-doc/refman/html
-doc/refman/styles.hva
-doc/stdlib/Library.coqdoc.tex
+doc/refman/html/
 doc/stdlib/Library.out
 doc/stdlib/Library.pdf
 doc/stdlib/Library.ps
+doc/stdlib/Library.coqdoc.tex
 doc/stdlib/html/
+doc/stdlib/index-body.html
 doc/stdlib/index-list.html
-kernel/byterun/dllcoqrun.so
+doc/RecTutorial/RecTutorial.html
+doc/RecTutorial/RecTutorial.pdf
+doc/RecTutorial/RecTutorial.ps
+dev/doc/naming-conventions.pdf
+_build
+plugins/*/*_mod.ml
+myocamlbuild_config.ml
+.DS_Store
diff --git a/CHANGES b/CHANGES
index 4bc0bd82..ce151ee1 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,49 +1,317 @@
-Changes from V8.2 to forthcoming V8.2pl1
-========================================
+Changes from V8.2 to V8.3
+=========================
 
-Language and commands
+Rewriting tactics
+
+- Tactic "rewrite" now supports rewriting on ad hoc equalities such as eq_true.
+- "Hint Rewrite" now checks that the lemma looks like an equation.
+- New tactic "etransitivity".
+- Support for heterogeneous equality (JMeq) in "injection" and "discriminate".
+- Tactic "subst" now supports heterogeneous equality and equality
+  proofs that are dependent (use "simple subst" for preserving compatibility).
+- Added support for Leibniz-rewriting of dependent hypotheses.
+- Renamed "Morphism" into "Proper" and "respect" into "proper_prf"
+  (possible source of incompatibility).
+- New tactic variants "rewrite* by" and "autorewrite*" that rewrite
+  respectively the first and all matches whose side-conditions are
+  solved.
+- "Require Import Setoid" does not export all of "Morphisms" and
+  "RelationClasses" anymore (possible source of incompatibility, fixed
+  by importing "Morphisms" too).
+- Support added for using Chung-Kil Hur's Heq library for rewriting over
+  heterogeneous equality (courtesy of the library's author).
+- Tactic "replace" supports matching terms with holes.
+
+Automation tactics
+
+- Tactic "intuition" now preserves inner "iff" and "not" (exceptional
+  source of incompatibilities solvable by redefining "intuition" as
+  "unfold iff, not in *; intuition", or by using "Set Intuition Unfolding".)
+- Tactic "tauto" now proves classical tautologies as soon as classical logic
+  (i.e. library Classical_Prop or Classical) is loaded.
+- Tactic "gappa" has been removed from the Dp plugin.
+- Tactic "firstorder" now supports the combination of its "using" and
+  "with" options.
+- New "Hint Resolve ->" (or "<-") for declaring iff's as oriented
+  hints (wish #2104).
+- An inductive type as argument of the "using" option of "auto/eauto/firstorder"
+  is interpreted as using the collection of its constructors.
+- New decision tactic "nsatz" to prove polynomial equations 
+  by computation of Groebner bases.
+
+Other tactics
+
+- Tactic "discriminate" now performs intros before trying to discriminate an
+  hypothesis of the goal (previously it applied intro only if the goal
+  had the form t1<>t2) (exceptional source of incompatibilities - former
+  behavior can be obtained by "Unset Discriminate Introduction").
+- Tactic "quote" now supports quotation of arbitrary terms (not just the
+  goal).
+- Tactic "idtac" now displays its "list" arguments.
+- New introduction patterns "*" for introducing the next block of dependent 
+  variables and "**" for introducing all quantified variables and hypotheses.
+- Pattern Unification for existential variables activated in tactics and 
+  new option "Unset Tactic Evars Pattern Unification" to deactivate it.
+- Resolution of canonical structure is now part of the tactic's unification
+  algorithm.
+- New tactic "decide lemma with hyp" for rewriting decidability lemmas
+  when one knows which side is true.
+- Improved support of dependent goals over objects in dependent types for
+  "destruct" (rare source of incompatibility that can be avoided by unsetting
+  option "Dependent Propositions Elimination").
+- Tactic "exists", "eexists", "destruct" and "edestruct" supports iteration
+  using comma-separated arguments.
+- Tactic names "case" and "elim" now support clauses "as" and "in" and become
+  then synonymous of "destruct" and "induction" respectively.
+- A new tactic name "exfalso" for the use of 'ex-falso quodlibet' principle.
+  This tactic is simply a shortcut for "elimtype False".
+- Made quantified hypotheses get the name they would have if introduced in
+  the context (possible but rare source of incompatibilities).
+- When applying a component of a conjunctive lemma, "apply in" (and
+  sequences of "apply in") now leave the side conditions of the lemmas
+  uniformly after the main goal (possible source of rare incompatibilities).
+- In "simpl c" and "change c with d", c can be a pattern.
+- Tactic "revert" now preserves let-in's making it the exact inverse of
+  "intro".
+- New tactics "clear dependent H" and "revert dependent H" that
+  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.
 
-- Fixing Not_found bug in Theorem with.
-- Fixing pattern parsing bug #2087.
-- Fixing name aliases bug #2085 with modules.
-- Fixing checker bug #2065 with -impredicative-set option.
-- Complying with 8.1 heuristic when unification returns several solutions.
-- Add [Print Opaque Dependencies] command to print the assumptions and 
-  the opaque constants a definition uses.
-- Fixing performance issue in Program's type inference when there are
-  many existentials.
-- Fixing bug #2093, using Program does not require to import Program.Tactics
-  anymore, it will use [idtac] as the default obligation tactic.
-- Fix imports when requiring Setoid, to avoid cluttering the context with
-  internal names (possible source of incompatibility, import Morphisms to fix).
-- Fixing bug #2089, Combined Scheme was not treating parameters correctly.
-- Fixing Program to use hooks correctly, when called through [Program Coercion]
-  for example.
-- Fixing manual implicit arguments to always work and remove 
-  [Set Manual Implicit Arguments] option (possible source of incompatibility).
-- Fixing refine to work with typeclasses.
-- Fixing implementation of [Context] to discharge class instances only on definitions
-  using some of the parameters or the instance itself (possible source of 
-  incompatibility).
+Tactic definitions
 
-Tactics
+- Ltac definitions support Local option for non-export outside modules.
+- Support for parsing non-empty lists with separators in tactic notations.
+- New command "Locate Ltac" to get the full name of an Ltac definition.
+
+Notations
+
+- Record syntax "{|x=...; y=...|}" now works inside patterns too.
+- Abbreviations from non-imported module now invisible at printing time.
+- Abbreviations now use implicit arguments and arguments scopes for printing.
+- Abbreviations to pure names now strictly behave like the name they refer to
+  (make redirections of qualified names easier).
+- Abbreviations for applied constant now propagate the implicit arguments
+  and arguments scope of the underlying reference (possible source of
+  incompatibilities generally solvable by changing such abbreviations from
+  e.g. "Notation foo' := (foo x)" to "Notation foo' y := (foo x (y:=y))").
+- The "where" clause now supports multiple notations per defined object.
+- Recursive notations automatically expand one step on the left for better
+  factorization; recursion notations inner separators now ensured being tokens.
+- Added "Reserved Infix" as a specific shortcut of the corresponding
+  "Reserved Notation".
+- Open/Close Scope command supports Global option in sections.
+
+Specification language
+
+- New support for local binders in the syntax of Record/Structure fields.
+- Fixpoint/CoFixpoint now support building part or all of bodies using tactics.
+- Binders given before ":" in lemmas and in definitions built by tactics are
+  now automatically introduced (possible source of incompatibility that can
+  be resolved by invoking "Unset Automatic Introduction").
+
+Module system
+
+- Include Type is now deprecated since Include now accept both modules and
+  module types.
+- Declare ML Module supports Local option.
+- The sharing between non-logical object and the management of the
+  name-space has been improved by the new "Delta-equivalence" on
+  qualified name.
+- The include operator has been extended to high-order structures
+- Sequences of Include can be abbreviated via new syntax "<+".
+- A module (or module type) can be given several "<:" signatures.
+- Interactive proofs are now permitted in module type. Functors can hence
+  be declared as Module Type and be used later to type themselves.
+- A functor application can be prefixed by a "!" to make it ignore any
+  "Inline" annotation in the type of its argument(s) (for examples of
+  use of the new features, see libraries Structures and Numbers).
+
+Extraction
+
+- When using (Recursive) Extraction Library, the filenames are directly the
+  Coq ones with new appropriate extensions : we do not force anymore
+  uncapital first letters for Ocaml and capital ones for Haskell.
+- The extraction now tries harder to avoid code transformations that can be
+  dangerous for the complexity. In particular many eta-expansions at the top
+  of functions body are now avoided, clever partial applications will likely
+  be preserved, let-ins are almost always kept, etc.
+- Harsh support of module extraction to Haskell and Scheme: module hierarchy
+  is flattened, module abbreviations and functor applications are expanded,
+  module types and unapplied functors are discarded.
+- Less unsupported situations when extracting modules to Ocaml. In particular
+  module parameters might be alpha-renamed if a name clash is detected.  
+- Extract Inductive is now possible toward non-inductive types (e.g. nat => int)
+- Extraction Implicit: this new experimental command allows to mark
+  some arguments of a function or constructor for removed during
+  extraction, even if these arguments don't fit the usual elimination
+  principles of extraction, for instance the length n of a vector.
+- Files ExtrOcaml*.v in plugins/extraction try to provide a library of common
+  extraction commands: mapping of basics types toward Ocaml's counterparts,
+  conversions from/to int and big_int, or even complete mapping of nat,Z,N
+  to int or big_int, or mapping of ascii to char and string to char list
+  (in this case recognition of ascii constants is hard-wired in the extraction).
 
-- Fixing correct binding of quantified hypotheses for induction/destruction
-  when used in Ltac.
-- Fixing bad parentheses check in "pose (f binders := ...)" syntax.
-- Fixing unbalanced parenthesis in Ltac debug trace printer.
-- Fixing missing sort unification check in lemma application (bug #2084).
-- Fixing "as" clause of "apply in" that was not working in the general case.
-- Fixing eauto not using external hints with no pattern.
+Program
+
+- Streamlined definitions using well-founded recursion and measures so
+  that they can work on any subset of the arguments directly (uses currying).
+- Try to automatically clear structural fixpoint prototypes in
+  obligations to avoid issues with opacity.
+- Use return type clause inference in pattern-matching as in the standard 
+  typing algorithm.
+- Support [Local Obligation Tactic] and [Next Obligation with tactic].
+- Use [Show Obligation Tactic] to print the current default tactic.
+- [fst] and [snd] have maximal implicit arguments in Program now (possible 
+  source of incompatibility).
+
+Type classes
+
+- Declaring axiomatic type class instances in Module Type should be now
+  done via new command "Declare Instance", while the syntax "Instance"
+  now always provides a concrete instance, both in and out of Module Type.
+- Use [Existing Class foo] to declare foo as a class a posteriori.
+  [foo] can be an inductive type or a constant definition. No
+  projections or instances are defined.
+- Various bug fixes and improvements: support for defined fields, 
+  anonymous instances, declarations giving terms, better handling of
+  sections and [Context].
+
+Vernacular commands
 
-Tools and development
+- New command "Timeout <n> <command>." interprets a command and a timeout
+  interrupts the interpretation after <n> seconds.
+- New command "Compute <expr>." is a shortcut for "Eval vm_compute in <expr>".
+- New command "Fail <command>." interprets a command and is successful iff
+  the command fails on an error (but not an anomaly). Handy for tests and
+  illustration of wrong commands.
+- Most commands referring to constant (e.g. Print or About) now support
+  referring to the constant by a notation string.
+- Made generation of boolean equality automatic for datatypes (use
+  "Unset Boolean Equality Schemes" for deactivation).
+- Made support for automatic generation of case analysis schemes and
+  congruence schemes available to user (governed by options "Unset
+  Case Analysis Schemes" and "Unset Congruence Schemes").
+- New command "(Global?) Generalizable [All|No] Variable(s)? ident(s)?" to
+  declare which identifiers are generalizable in `{} and `() binders.
+- New command "Print Opaque Dependencies" to display opaque constants in
+  addition to all variables, parameters or axioms a theorem or
+  definition relies on.
+- New command "Declare Reduction <id> := <conv_expr>", allowing to write
+  later "Eval <id> in ...". This command accepts a Local variant.
+- Syntax of Implicit Type now supports more than one block of variables of
+  a given type.
+- Command "Canonical Structure" now warns when it has no effects.
 
-- Fixing missing -c option in coq_makefile.
-- Temporary hack for coqide.byte "double free or corruption" problem.
-- Added support for code development under Bazaar.
-- Added support for compilation under Solaris (thanks to Eric Le Lay, #2078).
-- Parsing fixes and support for parsing regular comments inline in coqdoc,
-  using option -parse-comments (suggestions by B. Pierce).
+Library
+
+- Use "standard" Coq names for the properties of eq and identity
+  (e.g. refl_equal is now eq_refl). Support for compatibility is provided.
+- The function Compare_dec.nat_compare is now defined directly,
+  instead of relying on lt_eq_lt_dec. The earlier version is still
+  available under the name nat_compare_alt.
+- Lemmas in library Relations and Reals have been homogenized a bit.
+- The implicit argument of Logic.eq is now maximally inserted, allowing
+  to simply write "eq" instead of "@eq _" in morphism signatures.
+- Wrongly named lemmas (Zlt_gt_succ and Zlt_succ_gt) fixed (potential source
+  of incompatibilities)
+- List library:
+  - Definitions of list, length and app are now in Init/Datatypes.
+    Support for compatibility is provided.
+  - Definition of Permutation is now in Sorting/Permtation.v
+  - Some other light revisions and extensions (possible source
+    of incompatibilities solvable by qualifying names accordingly).
+- In ListSet, set_map has been fixed (source of incompatibilities if used).
+- Sorting library:
+  - new mergesort of worst-case complexity O(n*ln(n)) made available in 
+    Mergesort.v;
+  - former notion of permutation up to setoid from Permutation.v is
+    deprecated and moved to PermutSetoid.v;
+  - heapsort from Heap.v of worst-case complexity O(n*n) is deprecated;
+  - new file Sorted.v for some definitions of being sorted.
+- Structure library. This new library is meant to contain generic
+  structures such as types with equalities or orders, either
+  in Module version (for now) or Type Classes (still to do):
+  - DecidableType.v and OrderedType.v: initial notions for FSets/FMaps,
+    left for compatibility but considered as deprecated.
+  - Equalities.v and Orders.v: evolutions of the previous files,
+    with fine-grain Module architecture, many variants, use of
+    Equivalence and other relevant Type Classes notions.
+  - OrdersTac.v: a generic tactic for solving chains of (in)equalities
+    over variables. See {Nat,N,Z,P}OrderedType.v for concrete instances.
+  - GenericMinMax.v: any ordered type can be equipped with min and max.
+    We derived here all the generic properties of these functions.
+- MSets library: an important evolution of the FSets library.
+  "MSets" stands for Modular (Finite) Sets, by contrast with a forthcoming
+  library of Class (Finite) Sets contributed by S. Lescuyer which will be
+  integrated with the next release of Coq. The main features of MSets are:
+  - The use of Equivalence, Proper and other Type Classes features
+    easing the handling of setoid equalities.
+  - The interfaces are now stated in iff-style. Old specifications
+    are now derived properties.
+  - The compare functions are now pure, and return a "comparison" value.
+    Thanks to the CompSpec inductive type, reasoning on them remains easy.
+  - Sets structures requiring invariants (i.e. sorted lists) are
+    built first as "Raw" sets (pure objects and separate proofs) and
+    attached with their proofs thanks to a generic functor. "Raw" sets
+    have now a proper interface and can be manipulated directly.
+  Note: No Maps yet in MSets. The FSets library is still provided
+  for compatibility, but will probably be considered as deprecated in the
+  next release of Coq.
+- Numbers library:
+  - The abstract layer (NatInt, Natural/Abstract, Integer/Abstract) has
+    been simplified and enhance thanks to new features of the module
+    system such as Include (see above). It has been extended to Euclidean
+    division (three flavors for integers: Trunc, Floor and Math).
+  - The arbitrary-large efficient numbers (BigN, BigZ, BigQ) has also
+    been reworked. They benefit from the abstract layer improvements
+    (especially for div and mod). Note that some specifications have
+    slightly changed (compare, div, mod, shift{r,l}). Ring/Field should
+    work better (true recognition of constants).
+
+Tools
+
+- Option -R now supports binding Coq root read-only.
+- New coqtop/coqc option -beautify to reformat .v files (usable
+  e.g. to globally update notations).
+- New tool beautify-archive to beautify a full archive of developments.
+- New coqtop/coqc option -compat X.Y to simulate the general behavior
+  of previous versions of Coq (provides e.g. support for 8.2 compatibility).
+
+Coqdoc
+
+- List have been revamped.  List depth and scope is now determined by
+  an "offside" whitespace rule.
+- Text may be italicized by placing it in _underscores_.
+- The "--index <string>" flag changes the filename of the index.
+- The "--toc-depth <int>" flag limits the depth of headers which are
+  included in the table of contents.
+- The "--lib-name <string>" flag prints "<string> Foo" instead of
+  "Library Foo" where library titles are called for.  The
+  "--no-lib-name" flag eliminates the extra title.
+- New option "--parse-comments" to allow parsing of regular "(* *)"
+  comments.
+- New option "--plain-comments" to disable interpretation inside comments.
+- New option "--interpolate" to try and typeset identifiers in Coq escapings
+  using the available globalization information.
+- New option "--external url root" to refer to external libraries.
+- Links to section variables and notations now supported.
+
+Internal infrastructure
+
+- To avoid confusion with the repository of user's contributions,
+  the subdirectory "contrib" has been renamed into "plugins".
+  On platforms supporting ocaml native dynlink, code located there
+  is built as loadable plugins for coqtop.
+- An experimental build mechanism via ocamlbuild is provided.
+  From the top of the archive, run ./configure as usual, and
+  then ./build. Feedback about this build mechanism is most welcome.
+  Compiling Coq on platforms such as Windows might be simpler
+  this way, but this remains to be tested.
+- The Makefile system has been simplified and factorized with
+  the ocamlbuild system. In particular "make" takes advantage
+  of .mllib files for building .cma/.cmxa. The .vo files to
+  compile are now listed in several vo.itarget files.
 
 Changes from V8.1 to V8.2
 =========================
@@ -60,7 +328,6 @@ Language
   arguments in terms.
 - Sort of Record/Structure, Inductive and CoInductive defaults to Type
   if omitted.
-- Support for optional "where" notation clauses for record fields.
 - (Co)Inductive types can be defined as records 
   (e.g. "CoInductive stream := { hd : nat; tl : stream }.")
 - New syntax "Theorem id1:t1 ... with idn:tn" for proving mutually dependent
@@ -75,10 +342,6 @@ Language
   As a consequence, Acc_rect has now a more direct proof [possible source
   of easily fixed incompatibility in case of manual definition of a recursor
   in a recursive singleton inductive type].
-- New syntax to do implicit generalization in binders and inside terms.
-- New tentative syntax for introduction of record objects without mentioning 
-  the constructor {| field := body; ... |}, turning missing fields into holes
-  (compatible with refine and Program).
 
 Vernacular commands
 
@@ -117,14 +380,6 @@ Vernacular commands
 - "Declare ML Module" now allows to import .cmxs files when Coq is
   compiled in native code with a version of OCaml that supports native
   Dynlink (>= 3.11).
-- New command "Create HintDb name [discriminated]" to explicitely declare
-  a new hint database and optionaly turn on a discrimination net 
-  implementation to index all the lemmas in the database.
-- New commands "Hint Transparent" and "Hint Opaque" to set the unfolding
-  status of definitions used by auto. This information is taken into account
-  by the discrimination net and the unification algorithm.
-- "Hint Extern" now takes an optional pattern and applies the given tactic
-  all the time if no pattern is given.
 - Specific sort constraints on Record now taken into account.
 - "Print LoadPath" supports a path argument to filter the display.
 
@@ -231,6 +486,7 @@ Libraries
   contribution repository (contribution CoC_History). New lemmas about 
   transitive closure added and some bound variables renamed (exceptional
   risk of incompatibilities).
+- Syntax for binders in terms (e.g. for "exists") supports anonymous names.
 
 Notations, coercions, implicit arguments and type inference
 
@@ -238,13 +494,13 @@ Notations, coercions, implicit arguments and type inference
   pattern-matching problems.
 - Experimental allowance for omission of the clauses easily detectable as
   impossible in pattern-matching problems.
-- Improved inference of implicit arguments, now working inside record
-  declarations.
+- Improved inference of implicit arguments.
 - New options "Set Maximal Implicit Insertion", "Set Reversible Pattern
   Implicit", "Set Strongly Strict Implicit" and "Set Printing Implicit
   Defensive" for controlling inference and use of implicit arguments.
 - New modifier in "Implicit Arguments" to force an implicit argument to
   be maximally inserted.
+- New modifier of "Implicit Arguments" to enrich the set of implicit arguments.
 - New options Global and Local to "Implicit Arguments" for section
   surviving or non export outside module.
 - Level "constr" moved from 9 to 8.
@@ -260,8 +516,6 @@ Tactic Language
   (syntax for second-order unification variable is "@?X").
 - Support for matching on let bindings in match context using syntax
   "H := body" or "H := body : type".
-- (?X ?Y) patterns now match any application instead of only unary 
-  applications (possible source of incompatibility).
 - Ltac accepts integer arguments (syntax is "ltac:nnn" for nnn an integer).
 - The general sequence tactical "expr_0 ; [ expr_1 | ... | expr_n ]"
   is extended so that at most one expr_i may have the form "expr .."
@@ -286,15 +540,11 @@ Tactic Language
   metavariable in "match" and it gets instantiated by an identifier
   (allow e.g. to extract the name of a statement like "exists x, P x").
 - New printing of Ltac call trace for better debugging.
-- The C-zar (formerly know as declarative) proof language is now properly
-  documented. 
 
 Tactics
 
 - New tactics "apply -> term", "apply <- term", "apply -> term in
   ident", "apply <- term in ident" for applying equivalences (iff).
-- "apply" and "rewrite" now take open terms (terms with undefined existentials) 
-  as input.
 - Slight improvement of the hnf and simpl tactics when applied on
   expressions with explicit occurrences of match or fix.
 - New tactics "eapply in", "erewrite", "erewrite in".
@@ -389,6 +639,9 @@ Program
   programming (id, apply, flip...)
 - More robust obligation handling, dependent pattern-matching and
   well-founded definitions.
+- New syntax " dest term as pat in term " for destructing objects using
+  an irrefutable pattern while keeping equalities (use this instead of 
+  "let" in Programs).
 - Program CoFixpoint is accepted, Program Fixpoint uses the new way to infer 
   which argument decreases structurally.
 - Program Lemma, Axiom etc... now permit to have obligations in the statement 
@@ -407,8 +660,8 @@ Type Classes
 
 - New "Class", "Instance" and "Program Instance" commands to define
   classes and instances documented in the reference manual.  
-- New binding construct "`{Class_1 param_1 .. param_n, Class_2 ...}" 
-  for binding type classes, usable everywhere.
+- New binding construct " [ Class_1 param_1 .. param_n, Class_2 ... ] " 
+  for binding type classes, usable everywhere.  
 - New command " Print Classes " and " Print Instances some_class " to
   print tables for typeclasses.  
 - New default eauto hint database "typeclass_instances" used by the default
@@ -432,9 +685,10 @@ Setoid rewriting
   Their introduction may break existing scripts that defined 
   them as notations with different levels.
   
-  - One can use [Typeclasses Opaque/Transparent [cst]] to indicate
-  that [cst] should not be unfolded during unification for morphism
-  resolution, by default all constants are transparent.
+  - One needs to use [Typeclasses unfold [cst]] if [cst] is used
+  as an abbreviation hiding products in types of morphisms,
+  e.g. if ones redefines [relation] and declares morphisms 
+  whose type mentions [relation].
 
   - The [setoid_rewrite]'s semantics change when rewriting with
   a lemma: it can rewrite two different instantiations of the lemma
@@ -454,12 +708,12 @@ Setoid rewriting
   new [Add Parametric] commands, documented in the manual.
 
   - Setoid_Theory is now an alias to Equivalence, scripts building objects
-  of type Setoid_Theory need to unfold (or [red]) the definitions
+  of type Setoid_Theory need to unfold (or "red") the definitions
   of Reflexive, Symmetric and Transitive in order to get the same goals 
   as before. Scripts which introduced variables explicitely will not break.
 
   - The order of subgoals when doing [setoid_rewrite] with side-conditions
-  is now always the same: first the new goal, then the conditions.
+  is always the same: first the new goal, then the conditions.
 
 - New standard library modules Classes.Morphisms declares
   standard morphisms on refl/sym/trans relations.
@@ -512,19 +766,11 @@ Tools
 - Extended -I coqtop/coqc option to specify a logical dir: "-I dir -as coqdir".
 - New coqtop/coqc option -exclude-dir to exclude subdirs for option -R.
 - The binary "parser" has been renamed to "coq-parser".
-
-coqdoc
 - Improved coqdoc and dump of globalization information to give more 
   meta-information on identifiers. All categories of Coq definitions are 
-  supported, which makes typesetting trivial in the generated documentation. 
-- A "--interpolate" option permits to use typesetting information from the 
-  typechecked part of the file to typeset identifiers appearing in Coq escapings
-  inside the documentation. 
-- Better handling of utf8 ("--utf8" option) and respect of spaces in the source.
-- Support for hyperlinking and indexing developments in the TeX output.
-- New option "color" of the coqdoc style file to render identifiers using colors.
-- Additional macros in the TeX ouput allowing to customize indentation and size of
-  empty lines. New environment "coqdoccode" for Coq code.
+  supported, which makes typesetting trivial in the generated documentation.
+  Support for hyperlinking and indexing developments in the tex output
+  has been implemented as well.
 
 Miscellaneous
 
@@ -1061,7 +1307,7 @@ Tactics
 - Clear now fails when trying to remove a local definition used by
   a constant appearing in the current goal
 
-Extraction (See details in contrib/extraction/CHANGES)
+Extraction (See details in plugins/extraction/CHANGES)
 
 - The old commands: 	(Recursive) Extraction Module M.
   are now:              (Recursive) Extraction Library M. 
@@ -1201,7 +1447,7 @@ Tactics
 - Unfold expects a correct evaluable argument
 - Clear expects existing hypotheses
 
-Extraction (See details in contrib/extraction/CHANGES and README):
+Extraction (See details in plugins/extraction/CHANGES and README):
 
 - An experimental Scheme extraction is provided.
 - Concerning Ocaml, extracted code is now ensured to always type-check, 
@@ -1316,7 +1562,7 @@ Bugs
 - Known bugs related to Inversion and let-in's fixed
 - Bug unexpected Delta with let-in now fixed
 
-Extraction (details in contrib/extraction/CHANGES or documentation)
+Extraction (details in plugins/extraction/CHANGES or documentation)
 
 - Signatures of extracted terms are now mostly expunged from dummy arguments.
 - Haskell extraction is now operational (tested & debugged).  
@@ -1324,7 +1570,7 @@ Extraction (details in contrib/extraction/CHANGES or documentation)
 Standard library
 
 - Some additions in [ZArith]: three files (Zcomplements.v, Zpower.v
-  and Zlogarithms.v) moved from contrib/omega in order to be more
+  and Zlogarithms.v) moved from plugins/omega in order to be more
   visible, one Zsgn function, more induction principles (Wf_Z.v and
   tail of Zcomplements.v), one more general Euclid theorem
 - Peano_dec.v and Compare_dec.v now part of Arith.v
@@ -1387,7 +1633,7 @@ Tactics
 - Slight improvement in naming strategy for NewInduction/NewDestruct
 - Intuition/Tauto do not perform useless unfolding and work up to conversion
 
-Extraction (details in contrib/extraction/CHANGES or documentation)
+Extraction (details in plugins/extraction/CHANGES or documentation)
 
 - Syntax changes: there are no more options inside the extraction commands. 
   New commands for customization and options have been introduced instead. 
diff --git a/COMPATIBILITY b/COMPATIBILITY
index 30f5daf8..09b72e92 100644
--- a/COMPATIBILITY
+++ b/COMPATIBILITY
@@ -1,72 +1,54 @@
-Potential sources of incompatibilities between Coq V8.1 and V8.2
+Potential sources of incompatibilities between Coq V8.2 and V8.3
 ----------------------------------------------------------------
 
 (see also file CHANGES)
 
+The main incompatibilities between 8.2 and 8.3 are the following
+
+- When defining objects using tactics as in "Definition f binders :
+  type.", the binders are automatically introduced in the context. The
+  former behavior can be restored by using "Unset Automatic
+  Introduction" (for local modification) or "Global Unset Automatic
+  Introduction" (for inheritance through Require).
+
+- For setoid rewriting, Morphism has been renamed into Proper.
+
+In general, most sources of incompatibilities can be avoided by
+calling coqtop or coqc with option "-compat 8.2". The sources of
+incompatibilities listed below must however be treated manually.
+
+Syntax
+
+- The word "by" is now a keyword and can no longer be used as an identifier.
+  [Semantics, IEEE754]
+
+Type inference
+
+- Many changes in using classes. [ATBR]
+
+Library
+
+- New identifiers of the library can hide identifiers. This can be
+  solved by changing the order of Require or by qualifying the
+  identifier with the name of its module.  [Stalmarck]
+
+- Reorganisation of library (esp. FSets, Sorting, Numbers) may have
+  moved or removed names around. [FundamentalArithmetics, CoLoR,
+  Icharate, AMM11262, FSets, FingerTree]
+
+- Infix notation "++" has now to be set at level 60. [LinAlg]
+
+- When using Program (refl_equal and Vnil have maximal implicit
+  arguments, lemmas about measure have a different form, ...).
+
 Tactics
 
-- The apply tactic now unfolds the constants if needed to succeed.  As
-  a consequence, use of "try apply" or "repeat apply" or "apply" in
-  other Ltac potentially backtracking code may behave differently. Use
-  "simple apply" instead.
-
-- Add Relation and Add Morphism on polymorphic relations should now be
-  declared with Add Parametric Relation and Add Parametric Morphism.
-
-- The constant [flip] is automatically unfolded in the goals generated by
-  Add Morphism (incompatibility with 8.2 beta versions).
-
-- The default relation chosen by setoid_replace may differ. The
-  workaround is to enforce the choice of the setoid relation with the
-  "using relation ..." option.
-
-- The ordering of subgoals generated by setoid_rewrite and
-  setoid_replace tactics has been changed. Some reordering in the
-  proof script may be necessary. You may also use the 'by ...' option
-  of setoid_replace and setoid_rewrite.
-  
-- The definition of Setoid_Theory has changed. When using the
-  constructors of the structure, you need to unfold the definitions
-  Reflexive, Symmetric, and Transitive.
- 
-- The names of bound variables of theorems generated by Add Morphism
-  differs, which may cause some problems with scripts that do not name
-  variable when perform introductions. Changing intros to the
-  appropriate intro x x0 ... xn should fix the problem.
-
-- Tactic firstorder "with" and "using" options have their meaning
-  swapped for consistency with auto/eauto. The solution is to swap
-  the use of these options in call to firstorder.
-
-- Introduction patterns are more strict. In "intros [ ... | ... | ... ] H",
-  the names in the brackets are synchronized so that H denotes the same
-  hypothesis in every subgoal.
-
-- Application patterns with a meta variable in function position (?X ?Y) now
-  match arbitrary applications as expected. Use a nested 
-  [match X with (_ _) => fail 1 | _ => ..] to recover the old semantics.
-
-- Some bug fixes may lead to incompatibilities (see CHANGES for a detailed
-  account).
-
-Language
-
-- Type Class syntax has completely since the 8.2beta versions. See the
-  documentation for the updated syntax.
-
-- Constants hidding polymorphic inductive types are now polymorphic
-  themselves. This may exceptionally affect the naming of
-  introduction hypotheses if such an inductive type in Type is used on
-  small types such as Prop or Set: the hypothesis names suffix will
-  default to H instead of X.
-
-Libraries
-
-- Some changes in the library (as mentioned in the CHANGES file) may
-  imply the need for local adaptations. This may particularly be the
-  case with the move from Set to Type in libraries FSets, SetoidList,
-  ListSet, Sorting and Zmisc. In case of trouble it may help to simply
-  declare Set as an alias for Type (see file SetIsType).
-
-For the main changes in the ML interfaces, see file
-dev/doc/changes.txt in the main archive.
+- The synchronization of introduction names and quantified hypotheses
+  names may exceptionally lead to different names in "induction"
+  (usually a name with lower index is required). [Automata]
+
+- More checks in some commands (e.g. in Hint) may lead to forbid some
+  meaningless part of them. [CoLoR]
+
+- When rewriting using setoid equality, the default equality found
+  might be different. [CoRN]
diff --git a/COPYRIGHT b/COPYRIGHT
index 8478bd4e..63d90573 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -1,6 +1,6 @@
-The Coq proof assistant V7 and V8 includes software developed by the
-Coq development team inside the TypiCal (formerly LogiCal) project, at
-INRIA, CNRS and University Paris Sud.
+The Coq proof assistant V7 and V8 includes software developed by the 
+Coq development team inside the LogiCal project, at INRIA, CNRS and
+University Paris Sud. 
 
 Copyright 1999-2004 The Coq development team, 
 INRIA-CNRS, University Paris Sud, All rights reserved.
@@ -13,15 +13,23 @@ work time rest with the employee. By analogy, it is Lionel's opinion
 that copyright on these changes rests with him.
 
 This product includes also software developed by
-	Yves Bertot, Lemme, INRIA Sophia-Antipolis (contrib/interface,
+	Yves Bertot, Lemme, INRIA Sophia-Antipolis (plugins/interface,
 parsing/search.ml)
-	Pierre Crégut, France Telecom R & D (contrib/omega and contrib/romega)
-	Pierre Courtieu, Lemme (contrib/funind)
-	Loïc Pottier, Lemme, INRIA Sophia-Antipolis (contrib/fourier)
-	Claudio Sacerdoti Coen, HELM, University of Bologna, (contrib/xml)
-	Lionel Mamane, Radbout University, Nijmegen (additions to contrib/interface)
-	Cezary Kalyczyc, Radbout University, Nijmegen (additions to contrib/xml)
+	Pierre Crégut, France Telecom R & D (plugins/omega and plugins/romega)
+	Pierre Courtieu, Lemme (plugins/funind)
+	Loïc Pottier, Lemme, INRIA Sophia-Antipolis (plugins/fourier)
+	Claudio Sacerdoti Coen, HELM, University of Bologna, (plugins/xml)
 
 The file CREDITS contains a list of past contributors
 The credits section in Reference Manual introduction details
 contributions.
+
+The Coq development Team (march 2004)
+	Bruno Barras (INRIA)
+	Pierre Corbineau (Université Paris Sud)
+	Jean-Christophe Filliâtre (CNRS)
+	Hugo Herbelin (INRIA)
+	Pierre Letouzey (Université Paris Sud)
+	Claude Marché (Université Paris Sud-INRIA)
+	Christine Paulin (Université Paris Sud)	
+	Clément Renard (INRIA)
diff --git a/CREDITS b/CREDITS
index 90dbd0b2..53bd9e93 100644
--- a/CREDITS
+++ b/CREDITS
@@ -1,12 +1,14 @@
 The "Coq proof assistant" was jointly developed by 
 	
-- INRIA Formel, Coq, LogiCal, ProVal, TypiCal projects (since 1985), 
+- INRIA Formel, Coq, LogiCal, ProVal, TypiCal, Marelle, pi.r2 projects
+  (starting 1985),
 - Laboratoire de l'Informatique du Parallelisme (LIP) 
   associated to CNRS and ENS Lyon (Sep. 1989 to Aug. 1997),
 - Laboratoire de Recherche en Informatique (LRI)
-  associated to CNRS and Paris Sud (since Sep. 1997),
-- Laboratoire d'Informatique de l'Ecole Polytechnique (since Jan. 2003)
-  associated to CNRS and Ecole Polytechnique.
+  associated to CNRS and university Paris Sud (since Sep. 1997),
+- Laboratoire d'Informatique de l'Ecole Polytechnique (LIX)
+  associated to CNRS and Ecole Polytechnique (since Jan. 2003).
+- Laboratoire PPS associated to CNRS and university Paris 7 (since Jan. 2009).
 
 All files of the "Coq proof assistant" in directories or sub-directories of
 
@@ -14,7 +16,7 @@ All files of the "Coq proof assistant" in directories or sub-directories of
   scripts states tactics test-suite theories tools toplevel
 
 are distributed under the terms of the GNU Lesser General Public License 
-Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2008,
+Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2010,
 The Coq development team, CNRS, INRIA and Université Paris Sud.
 
 Files from the directory doc are distributed as indicated in file doc/LICENCE.
@@ -23,51 +25,48 @@ The following directories contain independent contributions supported
 by the Coq development team. All of them are released under the terms of
 the GNU Lesser General Public License Version 2.1.
 
-contrib/cc
+plugins/cc
   developed by Pierre Corbineau (ENS Cachan, 2001, LRI, 2001-2005, Radboud
   University at Nijmegen, 2005-2008)
-contrib/correctness
+plugins/correctness
   developed by Jean-Christophe Filliâtre (LRI, 1999-2001)
-contrib/dp
+plugins/dp
   developed by Nicolas Ayache (LRI, 2005-2006) and Jean-Christophe Filliâtre
   (LRI, 2005-2008)
-contrib/extraction
-  developed by Pierre Letouzey (LRI, 2000-2004, PPS-Paris7, 2005-now)
-contrib/field
+plugins/extraction
+  developed by Pierre Letouzey (LRI, 2000-2004, PPS, 2005-now)
+plugins/field
   developed by David Delahaye and Micaela Mayero (INRIA-LogiCal, 2001)
-contrib/firstorder 
+plugins/firstorder 
   developed by Pierre Corbineau (LRI, 2003-2008)
-contrib/fourier
+plugins/fourier
   developed by Loïc Pottier (INRIA-Lemme, 2001)
-contrib/funind
+plugins/funind
   developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2004-2008),
   Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008) 
   and Yves Bertot (INRIA-Marelle, 2005-2006)
-contrib/interface
-  developed by Yves Bertot with contributions from Loïc Pottier and
-  Laurence Rideau as part of the Pcoq project (INRIA-Lemme, 1997-2006);
-  extended by Lionel Mamane as part of the TeXMacs project (Radboud university
-  at Nijmegen, 2007-2008)
-contrib/omega
+plugins/omega
   developed by Pierre Crégut (France Telecom R&D, 1996)
-contrib/ring
+plugins/nsatz
+  developed by Loïc Pottier (INRIA-Marelle, 2009)
+plugins/ring
   developed by Samuel Boutin (INRIA-Coq, 1996) and Patrick 
   Loiseleur (LRI, 1997-1999)
-contrib/romega
+plugins/romega
   developed by Pierre Crégut (France Telecom R&D, 2001-2004)
-contrib/rtauto
+plugins/rtauto
   developed by Pierre Corbineau (LRI, 2005)
-contrib/setoid_ring
+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),
-contrib/subtac
+plugins/subtac
   developed by Matthieu Sozeau (LRI, 2005-2008)
-contrib/xml
+plugins/xml
   developed by Claudio Sacerdoti (Univ. Bologna, 2000-2005) 
   as part of the HELM and MoWGLI projects; extension by Cezary Kaliszyk as
   part of the ProofWeb project (Radbout University at Nijmegen, 2008)
-contrib/micromega
+plugins/micromega
   developed by Frédéric Besson (IRISA/INRIA, 2006-2008), with some 
   extensions by Evgeny Makarov (INRIA, 2007); sum-of-squares solver and 
   interface to the csdp solver uses code from John Harrison (University
@@ -76,40 +75,40 @@ parsing/search.ml
   mainly developed by Yves Bertot (INRIA-Lemme, 2000-2004)
 theories/ZArith
   started by Pierre Crégut (France Telecom R&D, 1996)
-theories/IntMap
-  developed by Jean Goubault-Larrecq (Dyade, 1998)
-theories/Numbers/Cyclic
-  developed by Benjamin Grégoire (INRIA-Everest, 2007), Laurent Théry
-  (INRIA-Marelle, 2007-2008), Arnaud Spiwack (INRIA-LogiCal, 2007) and
-  Pierre Letouzey (PPS-Paris 7, 2008)
 theories/Strings
   developed by Laurent Théry (INRIA-Lemme, 2003)
+theories/Numbers/Cyclic
+  developed by Benjamin Grégoire (INRIA-Everest, 2007), Laurent Théry (INRIA-Marelle, 2007-2008), Arnaud Spiwack (INRIA-LogiCal, 2007) and Pierre Letouzey (PPS, 2008)
 ide/utils
   some files come from Maxence Guesdon's Cameleon tool 
 
-Many discussions within the Démons team at LRI, and the
-LogiCal/TypiCal projects influenced significantly the design of
-components of Coq, especially with
+Many discussions within the INRIA teams and labs taking part to the
+development influenced the design of Coq especially with
 
-  F. Blanqui, J. Courant, P. Courtieu, J. Duprat, S. Glondu, J. Goubault,
-  A. Mahboubi, C. Marché, A. Miquel, B. Monate, P.-Y. Strub, B. Werner.
+  C. Auger, Y. Bertot, F. Blanqui, J. Courant, P. Courtieu, J. Duprat,
+  S. Glondu, J. Goubault, J.-P. Jouannaud, S. Lescuyer, A. Mahboubi,
+  C. Marché, A. Miquel, B. Monate, L. Pottier, Y. Régis-Gianas,
+  P.-Y. Strub, L. Théry, B. Werner
 
-Intensive users suggested improvements of the system : 
+The development of Coq also significantly benefited from feedback,
+suggestions or short contributions from:
 
-  Y. Bertot, L. Pottier, L. Théry (INRIA-Lemme/Marelle projects),
   C. Alvarado, P. Crégut, J.-F. Monin (France Telecom R&D),
   P. Castéran (University Bordeaux 1),
-  The Foundations Group (Radboud University, Nijmegen, The Netherlands),
+  the Foundations Group (Radboud University, Nijmegen, The Netherlands),
   Laboratoire J.-A. Dieudonné (University of Nice-Sophia Antipolis),
-  G. Gonthier (INRIA-MSR joint lab), A. Charguéraud (INRIA-Gallium project).
+  F. Garillot, G. Gonthier (INRIA-MSR joint lab),
+  INRIA-Gallium project, 
+  the CS dept at Yale, the CIS dept at U. Penn, 
+  the CSE dept at Harvard, the CS dept at Princeton
 
 The following people have contributed to the development of different versions 
-of the Coq Proof assistant during the indicated time :
+of the Coq Proof assistant during the indicated time:
 
   Bruno Barras (INRIA, 1995-now)
   Jacek Chrzaszcz (LRI, 1998-2003)
   Thierry Coquand (INRIA, 1985-1989)
-  Pierre Corbineau (LRI, 2003-now)
+  Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now)
   Cristina Cornes (INRIA, 1993-1996)
   Yann Coscoy (INRIA Sophia-Antipolis, 1995-1996)
   David Delahaye (INRIA, 1997-2002)
@@ -122,15 +121,15 @@ of the Coq Proof assistant during the indicated time :
   Benjamin Grégoire (INRIA, 2003-now)
   Hugo Herbelin (INRIA, 1996-now)
   Gérard Huet (INRIA, 1985-1997)
-  Pierre Letouzey (LRI, 2000-2004 & PPS-Paris 7, 2005-now)
+  Pierre Letouzey (LRI, 2000-2004 & PPS, 2005-now)
   Evgeny Makarov (INRIA, 2007)
   Pascal Manoury (INRIA, 1993)
   Micaela Mayero (INRIA, 1997-2002)
-  Claude Marché (INRIA 2003-2004 & LRI, 2004-now)
+  Claude Marché (INRIA 2003-2004 & LRI, 2004)
   Benjamin Monate (LRI, 2003)
   César Muñoz (INRIA, 1994-1995)
   Chetan Murthy (INRIA, 1992-1994)
-  Julien Narboux (INRIA, 2005-2006)
+  Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now)
   Jean-Marc Notin (CNRS, 2006-now)
   Catherine Parent-Vigouroux (ENS Lyon, 1992-1995)
   Patrick Loiseleur (Paris Sud, 1997-1999)
@@ -146,12 +145,14 @@ of the Coq Proof assistant during the indicated time :
   Benjamin Werner (INRIA, 1989-1994)
 
 ***************************************************************************
-INRIA refers to :
+INRIA refers to:
   Institut National de la Recherche en Informatique et Automatique
-CNRS refers to :
+CNRS refers to:
   Centre National de la Recherche Scientifique
-LRI refers to : Laboratoire de Recherche en Informatique, UMR 8623 
+LRI refers to: Laboratoire de Recherche en Informatique, UMR 8623
   CNRS and Université Paris-Sud
-ENS Lyon refers to :
+ENS Lyon refers to:
   Ecole Normale Supérieure de Lyon
+PPS refers to: Laboratoire Preuve, Programmation, Système, UMR 7126,
+  CNRS and Université Paris 7
 ****************************************************************************
diff --git a/INSTALL b/INSTALL
index 47d2cb2e..903465de 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,5 +1,5 @@
 
-            INSTALLATION PROCEDURES FOR THE COQ V8.2 SYSTEM
+            INSTALLATION PROCEDURES FOR THE COQ V8.3 SYSTEM
             -----------------------------------------------
 
 
@@ -39,13 +39,13 @@ WHAT DO YOU NEED ?
 
      urpmi coq
 
-   Should you need or prefer to compile Coq V8.2 yourself, you need:
+   Should you need or prefer to compile Coq V8.3 yourself, you need:
 
-     - Objective Caml version 3.07 or later
+     - Objective Caml version 3.09.3 or later
        (available at http://caml.inria.fr/)
 
        For Ocaml version >= 3.10.0, you also need to install camlp5
-       (version <= 4.08, or >= 5.01 transitional)
+       (version <= 4.08, or 5.01 transitional)
   
 
      - GNU Make version 3.81 or later
@@ -71,12 +71,10 @@ WHAT DO YOU NEED ?
 
      - a C compiler
 
-     - for Coqide, the Lablgtk development files, and the GTK
-       libraries, see INSTALL.ide for more details
+     - for Coqide, the Lablgtk development files, and the GTK libraries, see INSTALL.ide for more details
 
-   Coq sources distribution comes as a single compressed tar-file. You
-   have probably already decompressed it if you are reading this
-   document.
+   By FTP, Coq comes as a single compressed tar-file. You have
+   probably already decompressed it if you are reading this document.
 
 
 QUICK INSTALLATION PROCEDURE.
@@ -91,7 +89,7 @@ QUICK INSTALLATION PROCEDURE.
 INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
 =================================================
 
-1- Check that you have the Objective Caml compiler version 3.07 (or later)
+1- Check that you have the Objective Caml compiler version 3.09.3 (or later)
    installed on your computer and that "ocamlmktop" and "ocamlc" (or
    its native code version "ocamlc.opt") lie in a directory which is present
    in your $PATH environment variable. 
@@ -101,18 +99,21 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
    bigger), you will also need the "ocamlopt" (or its native code version
    "ocamlopt.opt") command.
 
-2- If you are using OCaml version >= 3.10.0, check that you have
-   Camlp5 installed on your computer and that the command "camlp5"
-   lies in a directory which is present in your $PATH environment
-   variable path.  (You need Camlp5 in both bytecode and native
-   versions if your platform supports it).
+2- Check that you have Camlp4 installed on your 
+   computer and that the command "camlp4" lies in a directory which
+   is present in your $PATH environment variable path.
+   (You need Camlp4 in both bytecode and native versions if
+   your platform supports it).
+
+   Note: in the latest ocaml distributions, camlp4 comes with ocaml so
+   you do not have to check this point anymore.
 
 3- The uncompression and un-tarring of the distribution file gave birth 
    to a directory named "coq-8.xx". You can rename this directory and put 
    it wherever you want. Just keep in mind that you will need some spare
-   space during the compilation (reckon on about 250 Mb of disk space
+   space during the compilation (reckon on about 50 Mb of disk space
    for the whole system in native-code compilation). Once installed, the
-   binaries take about 65 Mb, and the library about 60 Mb.
+   binaries take about 14 Mb, and the library about 9 Mb.
 
 4- First you need to configure the system. It is done automatically with
    the command:
@@ -312,9 +313,12 @@ MOVING BINARIES OR LIBRARY.
 	Error: Can't find file initial.coq on loadpath
 
    If you really have (or want) to move the binaries or the library, then
-   you have to indicate where Coq will find the libraries:
+   you have to indicate their new places to Coq, using the options -bindir (for
+   the binaries directory) and -libdir (for the standard library directory) :
+
+	coqtop -bindir <new directory> -libdir <new directory>
 
-	coqtop -coqlib <directory>
+   See also next section.
 
 
 DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES.
diff --git a/INSTALL.ide b/INSTALL.ide
index fbb484fd..757d8354 100644
--- a/INSTALL.ide
+++ b/INSTALL.ide
@@ -23,7 +23,7 @@ On Gentoo GNU/Linux, do:
 Else, read the rest of this document to compile your own CoqIde.
 
 REQUIREMENT:
-	- OCaml >= 3.07 with native threads support.
+	- OCaml >= 3.09.3 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.8.x.
@@ -56,8 +56,7 @@ REQUIREMENT:
           One official releases of lablgtk2 is here:
           http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/dist/lablgtk-2.10.1.tar.gz
 
-          Note that even if its README requires ocaml > 3.07, it works
-          ok with 3.07. If you are in a hurry just run :
+          If you are in a hurry just run :
 
               cd /tmp && \
               wget \
diff --git a/INSTALL.macosx b/INSTALL.macosx
index fc33351a..cc1317b1 100644
--- a/INSTALL.macosx
+++ b/INSTALL.macosx
@@ -1,21 +1,20 @@
-INSTALLATION PROCEDURE FOR THE PRECOMPILED COQ V8.2 SYSTEM UNDER MACOS X
+INSTALLATION PROCEDURE FOR THE PRECOMPILED COQ V8.1 SYSTEM UNDER MACOS X
 ------------------------------------------------------------------------
 
 You can also use fink, or the MacOS X package prepared by the Coq
 team. To use the MacOS X package,:
 
-1) Download archive coq-8.2-macosx-ppc.dmg (for PowerPC-base computer)
-   or coq-8.2-macosx-i386.dmg (for Pentium-based computer).
+1) Download archive coq-8.1-macosx-ppc.dmg (for PowerPC-base computer)
+   or coq-8.1-macosx-i386.dmg (for Pentium-based computer).
 
-2) Double-click on its icon; it mounts a disk volume named "Coq V8.2".
+2) Double-click on its icon; it mounts a disk volume named "Coq V8.1".
 
-3) Open volume "Coq 8.2" and double-click on coq-8.2.pkg to launch the
+3) Open volume "Coq 8.1" and double-click on coq-8.1.pkg to launch the
    installer (you'll need administrator permissions).
 
 4) Coq installs in /usr/local/bin, which should be in your PATH, and
    can be used from a Terminal window: the interactive toplevel is
    named coqtop and the compiler is coqc.
 
-If you have any trouble with this installation, please consider using
-our bug tracking system to report bug (see
-http://logical.saclay.inria.fr/coq-bugs).
+If you have any trouble with this installation, please contact:
+coq-bugs@pauillac.inria.fr.
diff --git a/Makefile b/Makefile
index 6873d80c..01772c0b 100644
--- a/Makefile
+++ b/Makefile
@@ -1,12 +1,12 @@
 #######################################################################
 #  v      #   The Coq Proof Assistant  /  The Coq Development Team    #
-# <O___,, #        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              #
+# <O___,, #        INRIA-Rocquencourt  &  LRI-CNRS-osay              #
 #   \VV/  #############################################################
 #    //   #      This file is distributed under the terms of the      #
 #         #       GNU Lesser General Public License Version 2.1       #
 #######################################################################
 
-# $Id: Makefile 13182 2010-06-23 09:18:18Z notin $ 
+# $Id$ 
 
 
 # Makefile for Coq
@@ -16,7 +16,7 @@
 # This is the only Makefile. You won't find Makefiles in sub-directories
 # and this is done on purpose. If you are not yet convinced of the advantages
 # of a single Makefile, please read
-#    http://www.pcug.org.au/~millerp/rmch/recu-make-cons-harm.html
+#    http://miller.emu.id.au/pmiller/books/rmch/
 # before complaining.
 # 
 # When you are working in a subdir, you can compile without moving to the
@@ -24,6 +24,50 @@
 # by Emacs' next-error.
 ###########################################################################
 
+
+# Specific command-line options to this Makefile
+#
+# make GOTO_STAGE=N        # perform only stage N (with N=1,2)
+# make VERBOSE=1           # restore the raw echoing of commands
+# make NO_RECALC_DEPS=1    # avoid recomputing dependencies
+# make NO_RECOMPILE_LIB=1  # a coqtop rebuild does not trigger a stdlib rebuild
+#
+# Nota: the 1 above can be replaced by any non-empty value
+# More details in dev/doc/build-system*.txt
+
+
+# FAQ: special features used in this Makefile
+#
+# * Order-only dependencies: |
+#
+# Dependencies placed after a bar (|) should be built before
+# the current rule, but having one of them is out-of-date do not
+# trigger a rebuild of the current rule.
+# See http://www.gnu.org/software/make/manual/make.html#Prerequisite-Types
+#
+# * Annotation before commands: +/-/@
+#
+# a command starting by - is always successful (errors are ignored)
+# a command starting by + is runned even if option -n is given to make
+# a command starting by @ is not echoed before being runned
+#
+# * Custom functions
+#
+# Definition via "define foo" followed by commands (arg is $(1) etc)
+# Call via "$(call foo,arg1)"
+#
+# * Useful builtin functions
+#
+# $(subst ...), $(patsubst ...), $(shell ...), $(foreach ...)
+#
+# * Behavior of -include
+#
+# If the file given to -include doesn't exist, make tries to build it,
+# but doesn't care if this build fails. This can be quite surprising,
+# see in particular the -include in Makefile.stage*
+
+# !! Before using FIND_VCS_CLAUSE, please read how you should in the !!
+# !! FIND_VCS_CLAUSE section of dev/doc/build-system.dev.txt         !!
 export FIND_VCS_CLAUSE:='(' \
   -name '{arch}' -o \
   -name '.svn' -o \
@@ -31,9 +75,10 @@ export FIND_VCS_CLAUSE:='(' \
   -name '.git' -o \
   -name '.bzr' -o \
   -name 'debian' -o \
-  -name "$${GIT_DIR}" \
-')' -prune -type f -o
-export PRUNE_CHECKER := -wholename ./checker/\* -prune -or
+  -name "$${GIT_DIR}" -o \
+  -name '_build' \
+')' -prune -o
+export PRUNE_CHECKER := -wholename ./checker/\* -prune -o
 
 FIND_PRINTF_P:=-print | sed 's|^\./||'
 
@@ -43,20 +88,24 @@ export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) \
   scripts/tolink.ml kernel/copcodes.ml
 export GENMLIFILES:=$(YACCFILES:.mly=.mli)
 export GENHFILES:=kernel/byterun/coq_jumptbl.h
-export GENVFILES:=theories/Numbers/Natural/BigN/NMake.v
+export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v
 export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES)
 export MLFILES  := $(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.ml'  ')' $(FIND_PRINTF_P) | \
-  while read f; do if [ ! -e "$${f}4" ]; then echo "$$f"; fi; done) \
+  while read f; do if ! [ -e "$${f}4" ]; then echo "$$f"; fi; done) \
   $(GENMLFILES)
 export MLIFILES := $(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.mli' ')' $(FIND_PRINTF_P)) \
   $(GENMLIFILES)
+export MLLIBFILES := $(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.mllib' ')' $(FIND_PRINTF_P))
 export ML4FILES := $(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.ml4' ')' $(FIND_PRINTF_P))
 #export VFILES   := $(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.v'   ')' $(FIND_PRINTF_P)) \
 #  $(GENVFILES)
-export CFILES   := $(shell find kernel/byterun $(FIND_VCS_CLAUSE) -name '*.c')
+export CFILES   := $(shell find kernel/byterun $(FIND_VCS_CLAUSE) '(' -name '*.c' ')' -print)
 
 export ML4FILESML:= $(ML4FILES:.ml4=.ml)
 
+# Nota: do not use the name $(MAKEFLAGS), it has a particular behavior
+MAKEFLGS:=--warn-undefined-variable --no-builtin-rules
+
 include Makefile.common
 
 NOARG: world
@@ -82,7 +131,7 @@ define stage-template
 	@echo '****************** Entering stage$(1) ******************'
 	@echo '*****************************************************'
 	@echo '*****************************************************'
-	+$(MAKE) -f Makefile.stage$(1) "$@"
+	+$(MAKE) $(MAKEFLGS) -f Makefile.stage$(1) "$@"
 endef
 else
 define stage-template
@@ -106,39 +155,24 @@ config/Makefile Makefile.common Makefile.build Makefile: ;
 	$(call stage-template,$(GOTO_STAGE))
 else
 
-.PHONY: stage1 stage2 stage3 world revision
-
-# This is to remove the built-in rule "%: %.o"
-# Otherwise, "make foo" recurses into stage1, trying to build foo.o .
-%: %.o
-
-%.o: always
-	$(call stage-template,1)
+.PHONY: stage1 stage2 world revision
 
-#STAGE1_TARGETS includes all object files necessary for $(STAGE1)
-stage1 $(STAGE1_TARGETS): always
+stage1 $(STAGE1_TARGETS) : always
 	$(call stage-template,1)
 
-CAML_OBJECT_PATTERNS:=%.cmo %.cmx %.cmi %.cma %.cmxa %.dep.ps %.dot
-ifdef CM_STAGE1
-$(CAML_OBJECT_PATTERNS): always
-	$(call stage-template,1)
-
-%.ml4-preprocessed: stage1
-	$(call stage-template,2)
-else
-$(CAML_OBJECT_PATTERNS) %.ml4-preprocessed: stage1
+stage2 $(STAGE2_TARGETS) : stage1
 	$(call stage-template,2)
-endif
 
-stage2 $(STAGE2_TARGETS): stage1
-	$(call stage-template,2)
+# Nota:
+# - world is one of the targets in $(STAGE2_TARGETS), hence launching
+# "make" or "make world" leads to recursion into stage1 then stage2
+# - the aim of stage1 is to build grammar.cma and q_constr.cmo
+# More details in dev/doc/build-system*.txt
 
-%.vo %.glob states/% install-%: stage2
-	$(call stage-template,3)
 
-stage3 $(STAGE3_TARGETS): stage2
-	$(call stage-template,3)
+# This is to remove the built-in rule "%: %.o" :
+%: %.o
+# Otherwise, "make foo" recurses into stage1, trying to build foo.o .
 
 endif #GOTO_STAGE
 
@@ -159,15 +193,16 @@ cruftclean: ml4clean
 indepclean:
 	rm -f $(GENFILES)
 	rm -f $(COQTOPBYTE) $(COQMKTOPBYTE) $(COQCBYTE) $(CHICKENBYTE)
-	rm -f bin/coq-interface$(EXE) bin/coq-parser$(EXE)
 	find . -name '*~' -o -name '*.cm[ioa]' | xargs rm -f
-	find contrib test-suite -name '*.vo' -o -name '*.glob' | xargs rm -f
-	rm -f */*.pp[iox] contrib/*/*.pp[iox]
+	find . -name '*_mod.ml' | xargs rm -f
+	find plugins test-suite -name '*.vo' -o -name '*.glob' | xargs rm -f
+	rm -f */*.pp[iox] plugins/*/*.pp[iox]
 	rm -rf $(SOURCEDOCDIR)
 	rm -f toplevel/mltop.byteml toplevel/mltop.optml
 	rm -f test-suite/check.log
 	rm -f glob.dump
-	rm -f revision
+	rm -f config/revision.ml revision
+	$(MAKE) -C test-suite clean
 
 docclean:
 	rm -f doc/*/*.dvi doc/*/*.aux doc/*/*.log doc/*/*.bbl doc/*/*.blg doc/*/*.toc \
@@ -180,23 +215,22 @@ docclean:
 	  doc/stdlib/library.files.ls
 	rm -f doc/*/*.ps doc/*/*.pdf 
 	rm -rf doc/refman/html doc/stdlib/html doc/faq/html doc/tutorial/tutorial.v.html
-	rm -f doc/stdlib/html/*.html
 	rm -f doc/refman/euclid.ml doc/refman/euclid.mli
 	rm -f doc/refman/heapsort.ml doc/refman/heapsort.mli
 	rm -f doc/common/version.tex
 	rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/*.eps doc/refman/Reference-Manual.html
 	rm -f doc/coq.tex
-	rm -f doc/refman/styles.hva doc/refman/cover.html 
 
 archclean: clean-ide cleantheories
-	rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN)
+	rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN) $(COQDEPBOOT)
 	rm -f $(COQTOPOPT) $(COQMKTOPOPT) $(COQCOPT) $(CHICKENOPT)
-	rm -f bin/coq-parser.opt$(EXE) bin/coq-interface.opt$(EXE)
-	find . -name '*.cmx' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f
+	find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f
 	rm -f $(TOOLS) $(CSDPCERT)
+	rm -rf _build myocamlbuild_config.ml
 
 clean-ide:
 	rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
+	rm -f ide/input_method_lexer.ml
 	rm -f ide/extract_index.ml ide/find_phrase.ml ide/highlight.ml
 	rm -f ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml
 	rm -f ide/utf8_convert.ml
@@ -208,12 +242,13 @@ ml4depclean:
 	find . -name '*.ml4.d' | xargs rm -f
 
 depclean:
-	find . $(FIND_VCS_CLAUSE) -name '*.d' | xargs rm -f
+	find . $(FIND_VCS_CLAUSE) '(' -name '*.d' ')' -print | xargs rm -f
 
 cleanconfig:
 	rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli
 
 distclean: clean cleanconfig
+	$(MAKE) -C test-suite distclean
 
 cleantheories:
 	rm -f states/*.coq
diff --git a/Makefile.build b/Makefile.build
index 148bb620..a7ae1e22 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -6,7 +6,7 @@
 #         #       GNU Lesser General Public License Version 2.1       #
 #######################################################################
 
-# $Id: Makefile.build 12279 2009-08-14 14:54:56Z herbelin $ 
+# $Id$ 
 
 
 # Makefile for Coq
@@ -33,18 +33,16 @@ endif
 
 NOARG: world
 
-# build and install the three subsystems: coq, coqide, pcoq
-ifeq ($(WITHDOC),all)
-world: revision coq coqide pcoq doc
-
-install: install-coq install-coqide install-pcoq install-doc
-else
-world: revision coq coqide pcoq
+# build and install the three subsystems: coq, coqide
+world: revision coq coqide
+install: install-coq install-coqide
 
-install: install-coq install-coqide install-pcoq
+ifeq ($(WITHDOC),all)
+world: doc
+install: install-doc
 endif
 
-#install-manpages: install-coq-manpages install-pcoq-manpages
+#install-manpages: install-coq-manpages
 
 ###########################################################################
 # Compilation options
@@ -54,7 +52,7 @@ endif
 # or only abbreviated versions. 
 # Quiet mode is ON by default except if VERBOSE=1 option is given to make
 
-ifeq ($(VERBOSE),1)
+ifdef VERBOSE
  SHOW = @true ""
  HIDE = 
 else 
@@ -62,17 +60,7 @@ else
  HIDE = @
 endif
 
-LOCALINCLUDES=-I config -I tools -I tools/coqdoc \
-	      -I scripts -I lib -I kernel -I kernel/byterun -I library \
-              -I proofs -I tactics -I pretyping \
-              -I interp -I toplevel -I parsing -I ide/utils -I ide \
-              -I contrib/omega -I contrib/romega -I contrib/micromega \
-	      -I contrib/ring -I contrib/dp -I contrib/setoid_ring \
-              -I contrib/xml -I contrib/extraction \
-              -I contrib/interface -I contrib/fourier -I contrib/cc \
-	      -I contrib/funind -I contrib/firstorder \
-              -I contrib/field -I contrib/subtac -I contrib/rtauto 
-
+LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) )
 MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
 
 OCAMLC += $(CAMLFLAGS)
@@ -82,18 +70,21 @@ BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG) $(USERFLAGS)
 OPTFLAGS=$(MLINCLUDES) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
 DEPFLAGS= -slash $(LOCALINCLUDES)
 
-CAMLP4EXTENDFLAGS=-I . #grammar dependencies are now in camlp4use statements 
+CAMLP4EXTENDFLAGS=-I $(CAMLLIB) -I . #grammar dependencies are now in camlp4use statements
 CAMLP4DEPS=sed -n -e 's@^(\*.*camlp4deps: "\(.*\)".*\*)@\1@p'
 CAMLP4USE=sed -n -e 's/pa_macro.cmo/pa_macro.cmo -D$(CAMLVERSION)/' -e 's@^(\*.*camlp4use: "\(.*\)".*\*)@\1@p'
 
-COQINCLUDES=          # coqtop includes itself the needed paths
 COQ_XML=	# is "-xml" when building XML library
-VM=          # is "-no-vm" to not use the vm"
-UNBOXEDVALUES=  # is "-unboxed-values" to use unboxed values
+VM=		# is "-no-vm" to not use the vm"
+UNBOXEDVALUES=	# is "-unboxed-values" to use unboxed values
 COQOPTS=$(COQ_XML) $(VM) $(UNBOXEDVALUES)
-TIME=           # is "'time -p'" to get compilation time of .v 
+TIMECMD=	# is "'time -p'" to get compilation time of .v
+
+# NB: variable TIME, if set, is the formatting string for unix command 'time'.
+# For instance:
+# TIME="%C (%U user, %S sys, %e total, %M maxres)"
 
-BOOTCOQTOP:=$(TIME) $(BESTCOQTOP) -boot $(COQOPTS)
+BOOTCOQTOP:=$(TIMECMD) $(BESTCOQTOP) -boot $(COQOPTS)
 
 ###########################################################################
 # Infrastructure for the rest of the Makefile
@@ -120,7 +111,9 @@ ifdef VALIDATE
 endif
 ifdef NO_RECOMPILE_LIB
  VO_TOOLS_ORDER_ONLY:=$(VO_TOOLS_DEP)
+ VO_TOOLS_STRICT:=
 else
+ VO_TOOLS_ORDER_ONLY:=
  VO_TOOLS_STRICT:=$(VO_TOOLS_DEP)
 endif
 
@@ -167,7 +160,7 @@ coqbinaries:: ${COQBINARIES} ${CSDPCERT}
 
 coq: coqlib tools coqbinaries
 
-coqlib:: theories contrib
+coqlib:: theories plugins
 
 coqlight: theories-light tools coqbinaries
 
@@ -185,7 +178,7 @@ $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN)
 $(COQTOPEXE): $(ORDER_ONLY_SEP) $(BESTCOQTOP)
 	cd bin; ln -sf coqtop.$(BEST)$(EXE) coqtop$(EXE)
 
-LOCALCHKLIBS:=-I checker -I lib -I config -I kernel
+LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) )
 CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB)
 CHKBYTEFLAGS:=$(CHKLIBS) $(CAMLDEBUG) $(USERFLAGS)
 CHKOPTFLAGS:=$(CHKLIBS) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
@@ -222,8 +215,8 @@ scripts/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 = \""$(OBJSCMO)"\"" >> $@
-	$(HIDE)echo "let ide = \""$(COQIDECMO)"\"" >> $@
+	$(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@
+	$(HIDE)echo "let ide = \""$(IDEMOD)"\"" >> $@
 
 # coqc
 
@@ -239,140 +232,39 @@ $(COQCOPT): $(COQCCMX) $(COQTOPOPT) $(BESTCOQTOP)
 $(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC)
 	cd bin; ln -sf coqc.$(BEST)$(EXE) coqc$(EXE)
 
-# we provide targets for each subdirectory
-
-lib: $(LIBREP)
-kernel: $(KERNEL)
-byterun: $(BYTERUN)
-library: $(LIBRARY)
-proofs: $(PROOFS)
-tactics: $(TACTICS)
-interp: $(INTERP)
-parsing: $(PARSING)
-pretyping: $(PRETYPING)
-highparsing: $(HIGHPARSING)
-toplevel: $(TOPLEVEL)
-hightactics: $(HIGHTACTICS)
-
 # target for libraries
 
-lib/lib.cma: $(LIBREP)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(LIBREP)
-
-lib/lib.cmxa: $(LIBREP:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(LIBREP:.cmo=.cmx)
-
-kernel/kernel.cma: $(KERNEL)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(KERNEL)
-
-kernel/kernel.cmxa: $(KERNEL:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(KERNEL:.cmo=.cmx)
-
-checker/check.cma: $(MCHECKER)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) -a -o $@ $(MCHECKER)
-
-checker/check.cmxa: $(MCHECKER:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -a -o $@ $(MCHECKER:.cmo=.cmx)
-
-library/library.cma: $(LIBRARY)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(LIBRARY)
-
-library/library.cmxa: $(LIBRARY:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(LIBRARY:.cmo=.cmx)
-
-pretyping/pretyping.cma: $(PRETYPING)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(PRETYPING)
-
-pretyping/pretyping.cmxa: $(PRETYPING:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(PRETYPING:.cmo=.cmx)
-
-interp/interp.cma: $(INTERP)
+%.cma: | %.mllib.d
 	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(INTERP)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $^
 
-interp/interp.cmxa: $(INTERP:.cmo=.cmx)
+%.cmxa: | %.mllib.d
 	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(INTERP:.cmo=.cmx)
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $^
 
-parsing/parsing.cma: $(PARSING)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(PARSING)
-
-parsing/parsing.cmxa: $(PARSING:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(PARSING:.cmo=.cmx)
-
-proofs/proofs.cma: $(PROOFS)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(PROOFS)
-
-proofs/proofs.cmxa: $(PROOFS:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(PROOFS:.cmo=.cmx)
-
-tactics/tactics.cma: $(TACTICS)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(TACTICS)
-
-tactics/tactics.cmxa: $(TACTICS:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(TACTICS:.cmo=.cmx)
-
-toplevel/toplevel.cma: $(TOPLEVEL)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(TOPLEVEL)
-
-toplevel/toplevel.cmxa: $(TOPLEVEL:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(TOPLEVEL:.cmo=.cmx)
+# For the checker, different flags may be used
 
-parsing/highparsing.cma: $(HIGHPARSING)
+checker/check.cma: | checker/check.mllib.d
 	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(HIGHPARSING)
+	$(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) -a -o $@ $^
 
-parsing/highparsing.cmxa: $(HIGHPARSING:.cmo=.cmx)
+checker/check.cmxa: | checker/check.mllib.d
 	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(HIGHPARSING:.cmo=.cmx)
-
-tactics/hightactics.cma: $(HIGHTACTICS)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(HIGHTACTICS)
-
-tactics/hightactics.cmxa: $(HIGHTACTICS:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(HIGHTACTICS:.cmo=.cmx)
-
-contrib/contrib.cma: $(CONTRIB)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(CONTRIB)
-
-contrib/contrib.cmxa: $(CONTRIB:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(CONTRIB:.cmo=.cmx)
+	$(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -a -o $@ $^
 
 ###########################################################################
 # Csdp to micromega special targets
 ###########################################################################
 
 ifeq ($(BEST),opt)
-contrib/micromega/csdpcert$(EXE): $(CSDPCERTCMX)
+plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMX)
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) nums.cmxa -o $@ $(CSDPCERTCMX)
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) nums.cmxa unix.cmxa -o $@ $^
 	$(STRIP) $@
 else
-contrib/micromega/csdpcert$(EXE): $(CSDPCERTCMO)
+plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) nums.cma -o $@ $(CSDPCERTCMO)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) nums.cma unix.cma -o $@ $^
 endif
 
 ###########################################################################
@@ -418,14 +310,6 @@ ide/%.cmx: ide/%.ml | ide/%.ml.d
 	$(SHOW)'OCAMLOPT  $<'	
 	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $<
 
-ide/ide.cma: $(COQIDECMO)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(COQIDECMO)
-
-ide/ide.cmxa: $(COQIDECMO:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(COQIDECMO:.cmo=.cmx)
-
 # install targets
 
 FULLIDELIB=$(FULLCOQLIB)/ide
@@ -437,66 +321,32 @@ install-ide-no:
 install-ide-byte: 
 	$(MKDIR) $(FULLBINDIR)
 	$(INSTALLBIN) $(COQIDEBYTE) $(FULLBINDIR)
+	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \
+	  `cat $(IDECMA:.cma=.mllib.d) | tr ' ' '\n' | sed -n -e "/\.cmo/s/\.cmo/\.cmi/p"`
 	cd $(FULLBINDIR); ln -sf coqide.byte$(EXE) coqide$(EXE)
 
 install-ide-opt:
 	$(MKDIR) $(FULLBINDIR)
 	$(INSTALLBIN) $(COQIDEBYTE) $(COQIDEOPT) $(FULLBINDIR)
+	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a) \
+	  `cat $(IDECMA:.cma=.mllib.d) | tr ' ' '\n' | sed -n -e "/\.cmo/s/\.cmo/\.cmi/p"`
 	cd $(FULLBINDIR); ln -sf coqide.opt$(EXE) coqide$(EXE)
 
 install-ide-files:
 	$(MKDIR) $(FULLIDELIB)
 	$(INSTALLLIB) $(IDEFILES) $(FULLIDELIB)
-	if (test -f ide/index_urls.txt); then $(INSTALLLIB) ide/index_urls.txt $(FULLIDELIB); fi
 
 install-ide-info:
 	$(MKDIR) $(FULLIDELIB)
 	$(INSTALLLIB) ide/FAQ $(FULLIDELIB)
 
-###########################################################################
-# Pcoq: special binaries for debugging (coq-interface, coq-parser)
-###########################################################################
+# IM files
 
-# target to build Pcoq
-pcoq: pcoq-binaries pcoq-files
+IMFILES=$(addprefix ide/uim/, coqide.scm coqide-rules.scm coqide-custom.scm)
 
-pcoq-binaries:: $(COQINTERFACE) 
-
-bin/coq-interface$(EXE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(INTERFACE)
-	$(SHOW)'COQMKTOP -o $@'
-	$(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ $(INTERFACE)
-
-bin/coq-interface.opt$(EXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(INTERFACECMX)
-	$(SHOW)'COQMKTOP -o $@'
-	$(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) -o $@ $(INTERFACECMX)
-
-bin/coq-parser$(EXE):$(LIBCOQRUN) $(PARSERCMO)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(COQRUNBYTEFLAGS) -linkall $(BYTEFLAGS) -o $@ \
-	  dynlink.cma str.cma nums.cma $(LIBCOQRUN) $(CMA) $(PARSERCMO)
-
-bin/coq-parser.opt$(EXE): $(LIBCOQRUN) $(PARSERCMX)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) -linkall $(OPTFLAGS) -o $@ \
-	  $(LIBCOQRUN) $(DYNLINKCMXA) str.cmxa nums.cmxa $(CMXA) $(PARSERCMX)
-
-pcoq-files:: $(INTERFACEVO) $(INTERFACERC)
-
-
-# install targets
-install-pcoq:: install-pcoq-binaries install-pcoq-files install-pcoq-manpages
-
-install-pcoq-binaries::
-	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQINTERFACE) $(FULLBINDIR)
-
-install-pcoq-files::
-	$(MKDIR) $(FULLCOQLIB)/contrib/interface
-	$(INSTALLLIB) $(INTERFACERC) $(FULLCOQLIB)/contrib/interface
-
-install-pcoq-manpages:
-	$(MKDIR) $(FULLMANDIR)/man1
-	$(INSTALLLIB) $(PCOQMANPAGES) $(FULLMANDIR)/man1
+install-im:
+	$(INSTALLLIB) $(IMFILES) $(UIMSCRIPTDIR)
+	uim-module-manager --register coqide
 
 ###########################################################################
 # tests
@@ -505,16 +355,37 @@ install-pcoq-manpages:
 VALIDOPTS=-silent -o -m
 
 validate:: $(BESTCHICKEN) $(ALLVO)
-	$(SHOW)'COQCHK <theories & contrib>'
+	$(SHOW)'COQCHK <theories & plugins>'
 	$(HIDE)$(BESTCHICKEN) -boot $(VALIDOPTS) $(ALLMODS)
 
-check:: world validate
-	cd test-suite; \
-	env COQBIN=../bin COQLIB=.. ./check -$(BEST) | tee check.log
-	if grep -F 'Error!' test-suite/check.log ; then false; fi
+MAKE_TSOPTS=-C test-suite -s BEST=$(BEST) VERBOSE=$(VERBOSE)
+
+check:: validate test-suite
+
+test-suite: world
+	$(MAKE) $(MAKE_TSOPTS) clean
+	$(MAKE) $(MAKE_TSOPTS) all
+	$(HIDE)if grep -F 'Error!' test-suite/summary.log ; then false; fi
+
+##################################################################
+# partial targets: 1) core ML parts
+##################################################################
+
+lib: 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
+toplevel: toplevel/toplevel.cma
+hightactics: tactics/hightactics.cma
 
 ###########################################################################
-# theories and contrib files
+# 2) theories and plugins files
 ###########################################################################
 
 init: $(INITVO)
@@ -532,45 +403,38 @@ lists: $(LISTSVO)
 strings: $(STRINGSVO)
 sets: $(SETSVO)
 fsets: $(FSETSVO)
-allfsets: $(ALLFSETS)
 relations: $(RELATIONSVO)
 wellfounded: $(WELLFOUNDEDVO)
-# reals
 reals: $(REALSVO)
-allreals: $(ALLREALS)
 setoids: $(SETOIDSVO)
 sorting: $(SORTINGVO)
-# numbers
-natural: $(NATURALVO)
-integer: $(INTEGERVO)
-rational: $(RATIONALVO)
 numbers: $(NUMBERSVO)
 
 noreal: logic arith bool zarith qarith lists sets fsets relations \
 	wellfounded setoids sorting
 
 ###########################################################################
-# contribs (interface not included)
+# 3) plugins
 ###########################################################################
 
-contrib: $(CONTRIBVO) $(CONTRIBCMO)
-omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO)
-micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT)
-ring: $(RINGVO) $(RINGCMO)
-setoid_ring: $(NEWRINGVO) $(NEWRINGCMO)
-dp: $(DPCMO)
-xml: $(XMLVO) $(XMLCMO)
-extraction: $(EXTRACTIONCMO)
-field: $(FIELDVO) $(FIELDCMO)
-fourier: $(FOURIERVO) $(FOURIERCMO)
-funind: $(FUNINDCMO) $(FUNINDVO)
-cc: $(CCVO) $(CCCMO)
-programs: $(PROGRAMSVO)
-subtac: $(SUBTACVO) $(SUBTACCMO)
-rtauto: $(RTAUTOVO) $(RTAUTOCMO)
+plugins: $(PLUGINSVO)
+omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA)
+micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT)
+ring: $(RINGVO) $(RINGCMA)
+setoid_ring: $(NEWRINGVO) $(NEWRINGCMA)
+nsatz: $(NSATZVO) $(NSATZCMA)
+dp: $(DPCMA)
+xml: $(XMLVO) $(XMLCMA)
+extraction: $(EXTRACTIONCMA)
+field: $(FIELDVO) $(FIELDCMA)
+fourier: $(FOURIERVO) $(FOURIERCMA)
+funind: $(FUNINDCMA) $(FUNINDVO)
+cc: $(CCVO) $(CCCMA)
+subtac: $(SUBTACCMA)
+rtauto: $(RTAUTOVO) $(RTAUTOCMA)
 
 ###########################################################################
-# rules to make theories, contrib and states
+# rules to make theories, plugins and states
 ###########################################################################
 
 states/initial.coq: states/MakeInitial.v $(INITVO) $(VO_TOOLS_STRICT) | states/MakeInitial.v.d $(VO_TOOLS_ORDER_ONLY)
@@ -580,9 +444,9 @@ states/initial.coq: states/MakeInitial.v $(INITVO) $(VO_TOOLS_STRICT) | states/M
 theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_STRICT) | theories/Init/%.v.d $(VO_TOOLS_ORDER_ONLY)
 	$(SHOW)'COQC -nois $<'
 	$(HIDE)rm -f theories/Init/$*.glob
-	$(HIDE)$(BOOTCOQTOP) -dump-glob theories/Init/$*.glob -nois -compile theories/Init/$*
+	$(HIDE)$(BOOTCOQTOP) -nois -compile theories/Init/$*
 
-theories/Numbers/Natural/BigN/NMake.v: theories/Numbers/Natural/BigN/NMake_gen.ml
+theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml
 	$(OCAML) $< > $@
 
 ###########################################################################
@@ -591,7 +455,21 @@ theories/Numbers/Natural/BigN/NMake.v: theories/Numbers/Natural/BigN/NMake_gen.m
 
 printers: $(DEBUGPRINTERS)
 
-tools:: $(TOOLS) $(DEBUGPRINTERS)
+tools:: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
+
+# coqdep_boot : a basic version of coqdep, with almost no dependencies
+
+$(COQDEPBOOT): $(COQDEPBOOTML)
+ifeq ($(BEST),opt)
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ -I tools unix.cmxa $^
+	$(STRIP) $@
+else
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ -I tools unix.cma $^
+endif
+
+# the full coqdep
 
 ifeq ($(BEST),opt)
 $(COQDEP): $(COQDEPCMX)
@@ -612,7 +490,7 @@ $(GALLINA): $(GALLINACMX)
 else
 $(GALLINA): $(GALLINACMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $(GALLINACMO)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $^
 endif
 
 ifeq ($(BEST),opt)
@@ -621,20 +499,20 @@ $(COQMAKEFILE): tools/coq_makefile.cmx config/coq_config.cmx
 	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa config/coq_config.cmx tools/coq_makefile.cmx
 	$(STRIP) $@
 else
-$(COQMAKEFILE): tools/coq_makefile.cmo config/coq_config.cmo
+$(COQMAKEFILE): config/coq_config.cmo tools/coq_makefile.cmo
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma config/coq_config.cmo tools/coq_makefile.cmo
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma $^
 endif
 
 ifeq ($(BEST),opt)
-$(COQTEX): tools/coq-tex.cmx
+$(COQTEX): tools/coq_tex.cmx
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa tools/coq-tex.cmx
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa $^
 	$(STRIP) $@
 else
-$(COQTEX): tools/coq-tex.cmo
+$(COQTEX): tools/coq_tex.cmo
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma tools/coq-tex.cmo
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma $^
 endif
 
 ifeq ($(BEST),opt)
@@ -645,7 +523,7 @@ $(COQWC): tools/coqwc.cmx
 else
 $(COQWC): tools/coqwc.cmo
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ tools/coqwc.cmo
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $^
 endif
 
 ifeq ($(BEST),opt)
@@ -656,7 +534,7 @@ $(COQDOC): $(COQDOCCMX)
 else
 $(COQDOC): $(COQDOCCMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma unix.cma $(COQDOCCMO)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ str.cma unix.cma $^
 endif
 
 ###########################################################################
@@ -670,17 +548,26 @@ endif
   # 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)%)
 FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
 FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%)
+else
+FULLBINDIR=$(BINDIR)
+FULLCOQLIB=$(COQLIBINSTALL)
+FULLMANDIR=$(MANDIR)
+FULLEMACSLIB=$(EMACSLIB)
+FULLCOQDOCDIR=$(COQDOCDIR)
+FULLDOCDIR=$(DOCDIR)
+endif
 
 install-coq: install-binaries install-library install-coq-info
 install-coqlight: install-binaries install-library-light
 
-install-binaries:: install-$(BEST) install-tools
+install-binaries:: install-$(BEST)  install-tools
 
 install-byte::
 	$(MKDIR) $(FULLBINDIR)
@@ -702,42 +589,32 @@ install-tools::
 
 install-library:
 	$(MKDIR) $(FULLCOQLIB)
-	for f in $(LIBFILES); do \
-	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
-	  $(INSTALLLIB) $$f $(FULLCOQLIB)/`dirname $$f`; \
-        done
+	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(PLUGINSOPT)
 	$(MKDIR) $(FULLCOQLIB)/states
 	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
 	$(MKDIR) $(FULLCOQLIB)/user-contrib
 	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
 	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG) $(LINKCMO) $(GRAMMARCMA)
-	$(INSTALLSH)  $(FULLCOQLIB) $(OBJSCMO:.cmo=.cmi)
+	# reconstitute the list of core .cmi
+	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG:.cmo=.cmi) \
+          `cat $(CORECMA:.cma=.mllib.d) $(PLUGINSCMA:.cma=.mllib.d) | tr ' ' '\n' | sed -n -e "/\.cmo/s/\.cmo/\.cmi/p"`
 ifeq ($(BEST),opt)
 	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
 	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a)
 endif
 # csdpcert is not meant to be directly called by the user; we install
 # it with libraries
-	-$(MKDIR) $(FULLCOQLIB)/contrib/micromega
-	$(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/contrib/micromega
+	-$(MKDIR) $(FULLCOQLIB)/plugins/micromega
+	$(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
 
 install-library-light:
 	$(MKDIR) $(FULLCOQLIB)
-	for f in $(LIBFILESLIGHT); do \
-	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
-	  $(INSTALLLIB) $$f $(FULLCOQLIB)/`dirname $$f`; \
-        done
+	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT)
 	$(MKDIR) $(FULLCOQLIB)/states
 	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
 
-install-allreals::
-	for f in $(ALLREALS); do \
-	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
-	  $(INSTALLLIB) $$f $(FULLCOQLIB)/`dirname $$f`; \
-        done
-
 install-coq-info: install-coq-manpages install-emacs install-latex
 
 install-coq-manpages:
@@ -764,28 +641,27 @@ install-latex:
 
 source-doc:
 	if !(test -d $(SOURCEDOCDIR)); then mkdir $(SOURCEDOCDIR); fi
-	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) \
-	  `find . $(FIND_VCS_CLAUSE) -name "*.ml"`
+	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) $(MLFILES)
 
 
 ###########################################################################
 ### Special rules
 ###########################################################################
 
-dev/printers.cma: $(PRINTERSCMO)
+dev/printers.cma: | dev/printers.mllib.d
 	$(SHOW)'Testing $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) unix.cma gramlib.cma $(PRINTERSCMO) -o test-printer
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) unix.cma gramlib.cma $^ -o test-printer
 	@rm -f test-printer
 	$(SHOW)'OCAMLC -a $@'   
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(PRINTERSCMO) -linkall -a -o $@
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@
 
-parsing/grammar.cma: $(GRAMMARCMO)
+parsing/grammar.cma: | parsing/grammar.mllib.d
 	$(SHOW)'Testing $@'
 	@touch test.ml4
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) -I $(CAMLLIB) unix.cma $(GRAMMARCMO) -impl" -impl test.ml4 -o test-grammar
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) $^ -impl" -impl test.ml4 -o test-grammar
 	@rm -f test-grammar test.*
 	$(SHOW)'OCAMLC -a $@'   
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) unix.cma $(GRAMMARCMO) -linkall -a -o $@
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@
 
 # toplevel/mltop.ml4 (ifdef Byte)
 
@@ -812,21 +688,6 @@ toplevel/mltop.optml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here
 	  $(NATDYNLINKDEF) -impl $< > $@ \
 	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 
-# files compiled with -rectypes
-
-define rectypes-rules-template
-$(1:.ml=.cmo): $(1) | $(1).d
-	$(SHOW)'OCAMLC   -rectypes $$<' 
-	$(HIDE)$(OCAMLC) -rectypes $(BYTEFLAGS) -c $$<
-
-$(1:.ml=.cmx): $(1) | $(1).d
-	$(SHOW)'OCAMLOPT -rectypes $$<'
-	$(HIDE)$(OCAMLOPT) -rectypes $(OPTFLAGS) -c $$<
-
-endef
-
-$(foreach f,$(RECTYPESML),$(eval $(call rectypes-rules-template,$(f))))
-
 # pretty printing of the revision number when compiling a checked out
 # source tree
 .PHONY: revision
@@ -858,7 +719,7 @@ ifeq ($(CHECKEDOUT),git)
 	  GIT_HOST=$$(hostname --fqdn); \
 	  GIT_PATH=$$(pwd); \
 	  (echo "$${GIT_HOST}:$${GIT_PATH},$${GIT_BRANCH}") > revision.new; \
-	  git log -1 | sed -ne '/^commit /s/^commit[[:space:]]\+\(.*\)/\1/p'  >> revision.new; \
+	  (echo "$$(git log -1 --pretty='format:%H')") >> revision.new; \
 	fi
 endif
 	$(HIDE)set -e; \
@@ -925,6 +786,18 @@ endif
 	$(SHOW)'OCAMLOPT  $<'
 	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c $<
 
+%.cmxs: %.cmxa
+	$(SHOW)'OCAMLOPT -shared -o $@'
+ifeq ($(HASNATDYNLINK),os5fixme)
+	$(HIDE)dev/ocamlopt_shared_os5fix.sh "$(OCAMLOPT)" $@
+else
+	$(HIDE)$(OCAMLOPT) -linkall -shared -o $@ $<
+endif
+
+%.cmxs: %.cmx
+	$(SHOW)'OCAMLOPT -shared -o $@'
+	$(HIDE)$(OCAMLOPT) -shared -o $@ $<
+
 %.ml: %.mll
 	$(SHOW)'OCAMLLEX  $<'
 	$(HIDE)$(OCAMLLEX) -o $@ "$*.mll"
@@ -933,15 +806,22 @@ endif
 	$(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 $*)\"" >> $@
+
+.SECONDARY: $(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml))
+
 %.ml4-preprocessed: %.ml4 | %.ml4.d
 	$(SHOW)'CAMLP4O   $<'
 	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl $< > $@ \
 	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 
-%.vo %.glob: %.v states/initial.coq $(VO_TOOLS_STRICT) | %.v.d  $(VO_TOOLS_ORDER_ONLY)
+%.vo %.glob: %.v states/initial.coq $(INITPLUGINSBEST) $(VO_TOOLS_STRICT) | %.v.d  $(VO_TOOLS_ORDER_ONLY)
 	$(SHOW)'COQC      $<'
 	$(HIDE)rm -f $*.glob 
-	$(HIDE)$(BOOTCOQTOP) -dump-glob $*.glob -compile $*
+	$(HIDE)$(BOOTCOQTOP) -compile $*
 ifdef VALIDATE
 	$(SHOW)'COQCHK    $(call vo_to_mod,$@)'
 	$(HIDE)$(BESTCHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \
@@ -964,7 +844,7 @@ endif
 	$(HIDE)( printf "%s" '$*.cmo $*.cmx $*.ml4.ml.d $*.ml4-preprocessed: $(SEP)' && $(CAMLP4DEPS) "$<" ) > "$@" \
 	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 
-%.ml4.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml4 $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILES:.ml4=.ml) %.ml4.d
+%.ml4.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml4 $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILESML) %.ml4.d
 #Critical section:
 # Nobody (in a make -j) should touch the .ml file here.
 	$(SHOW)'OCAMLDEP4 $<'
@@ -982,23 +862,33 @@ checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC)
 	$(SHOW)'OCAMLDEP  $<'
 	$(HIDE)$(OCAMLDEP) -slash $(LOCALCHKLIBS) "$<" | sed '' > "$@"
 
-%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILES:.ml4=.ml)
+%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILESML)
 	$(SHOW)'OCAMLDEP  $<'
 	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" | sed '' > "$@"
 
-%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILES:.ml4=.ml)
+%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) $(ML4FILESML)
 	$(SHOW)'OCAMLDEP  $<'
 	$(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" | sed '' > "$@"
 
+checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT)
+	$(SHOW)'COQDEP  $<'
+	$(HIDE)$(COQDEPBOOT) -slash -boot -I checker -c "$<" > "$@" \
+	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+
+%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT)
+	$(SHOW)'COQDEP  $<'
+	$(HIDE)$(COQDEPBOOT) -slash -boot -I kernel -I tools/coqdoc -c "$<" > "$@" \
+	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
+
 ## Veerry nasty hack to keep ocamldep happy
 %.ml: | %.ml4
 	$(SHOW)'TOUCH     $@'
 	$(HIDE)echo "let keep_ocamldep_happy Do_not_compile_me = assert false" > $@ \
 	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 
-%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEP) $(GENVFILES)
+%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES)
 	$(SHOW)'COQDEP    $<'
-	$(HIDE)$(COQDEP) -glob -slash -boot $(COQINCLUDES) "$<" > "$@" \
+	$(HIDE)$(COQDEPBOOT) $(DEPNATDYN) -slash -boot "$<" > "$@" \
 	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 
 %.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES)
@@ -1018,41 +908,26 @@ devel: $(DEBUGPRINTERS)
 ###########################################################################
 
 
-%.dot: %.mli
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< 
-
 %.types.dot: %.mli
 	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< 
 
 %.dep.ps: %.dot
 	$(DOT) $(DOTOPTS) -o $@ $<
 
-kernel/kernel.dot: $(KERNELMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(KERNELMLI)
-
-interp/interp.dot: $(INTERPMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(INTERPMLI)
-
-pretyping/pretyping.dot: $(PRETYPINGMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(PRETYPINGMLI)
-
-library/library.dot: $(LIBRARYMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(LIBRARYMLI)
+OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
+  `cat $| | tr ' ' '\n' | sed -n -e "/\.cmo/s/\.cmo/\.ml/p"`
 
-parsing/parsing.dot: $(PARSINGMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(PARSINGMLI)
+%.dot: | %.mllib.d
+	$(OCAMLDOC_MLLIBD)
 
-tactics/tactics.dot: $(TACTICSMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(TACTICSMLI)
+parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d
+	$(OCAMLDOC_MLLIBD)
 
-proofs/proofs.dot: $(PROOFSMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(PROOFSMLI)
+tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d
+	$(OCAMLDOC_MLLIBD)
 
-toplevel/toplevel.dot: $(TOPLEVELMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(TOPLEVELMLI)
-
-coq.dot: $(COQMLI:.mli=.cmi)
-	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $(COQMLI)
+%.dot: %.mli
+	$(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< 
 
 
 # For emacs: 
diff --git a/Makefile.common b/Makefile.common
index 4d76e9e5..cc38980c 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -30,9 +30,14 @@ CHICKENOPT:=bin/coqchk.opt$(EXE)
 BESTCHICKEN:=bin/coqchk.$(BEST)$(EXE)
 CHICKEN:=bin/coqchk$(EXE)
 
-ifeq ($(HASNATDYNLINK),true)
+ifneq ($(HASNATDYNLINK),false)
   DYNLINKCMXA:=dynlink.cmxa
   NATDYNLINKDEF:=-DHasDynlink
+  DEPNATDYN:=
+else
+  DYNLINKCMXA:=
+  NATDYNLINKDEF:=
+  DEPNATDYN:=-natdynlink no
 endif
 
 INSTALLBIN:=install
@@ -53,13 +58,29 @@ COQBINARIES:= $(COQMKTOP) $(COQC) \
 endif
 OTHERBINARIES:=$(COQMKTOPBYTE) $(COQCBYTE)
 
-CSDPCERT:=contrib/micromega/csdpcert$(EXE)
+CSDPCERT:=plugins/micromega/csdpcert$(EXE)
+
+SRCDIRS:=\
+  config 	tools 		tools/coqdoc 	scripts		lib \
+  kernel	kernel/byterun	library 	proofs 		tactics \
+  pretyping	interp		toplevel 	parsing 	ide/utils \
+  ide		\
+  $(addprefix plugins/, \
+    omega	romega 		micromega 	quote		ring	dp \
+    setoid_ring xml 		extraction 	fourier \
+    cc 		funind 		firstorder 	field 		subtac \
+    rtauto 	nsatz           syntax)
+
+# Order is relevent here because kernel and checker contain files
+# with the same name
+CHKSRCDIRS:= checker lib config kernel
 
 ###########################################################################
 # tools
 ###########################################################################
 
 COQDEP:=bin/coqdep$(EXE)
+COQDEPBOOT:=bin/coqdep_boot$(EXE)
 COQMAKEFILE:=bin/coq_makefile$(EXE)
 GALLINA:=bin/gallina$(EXE)
 COQTEX:=bin/coq-tex$(EXE)
@@ -85,30 +106,26 @@ COQTEXOPTS:=-n 72 -image "$(COQSRC)/$(COQTOPEXE) -boot" -sl -small
 
 DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex 
 
-REFMANCOQTEXFILES:=\
-  doc/refman/RefMan-gal.v.tex doc/refman/RefMan-ext.v.tex \
-  doc/refman/RefMan-mod.v.tex doc/refman/RefMan-tac.v.tex \
-  doc/refman/RefMan-cic.v.tex doc/refman/RefMan-lib.v.tex \
-  doc/refman/RefMan-tacex.v.tex doc/refman/RefMan-syn.v.tex \
-  doc/refman/RefMan-oth.v.tex doc/refman/RefMan-ltac.v.tex \
-  doc/refman/RefMan-decl.v.tex \
-  doc/refman/Cases.v.tex doc/refman/Coercion.v.tex doc/refman/Extraction.v.tex \
-  doc/refman/Program.v.tex doc/refman/Omega.v.tex doc/refman/Micromega.v.tex doc/refman/Polynom.v.tex \
-  doc/refman/Setoid.v.tex doc/refman/Helm.tex doc/refman/Classes.v.tex
-
-REFMANTEXFILES:=\
-  doc/refman/headers.sty \
-  doc/refman/Reference-Manual.tex doc/refman/RefMan-pre.tex \
-  doc/refman/RefMan-int.tex doc/refman/RefMan-pro.tex \
-  doc/refman/RefMan-com.tex \
-  doc/refman/RefMan-uti.tex doc/refman/RefMan-ide.tex \
-  doc/refman/RefMan-add.tex doc/refman/RefMan-modr.tex \
-  doc/refman/ExternalProvers.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 \
+  Cases.v.tex Coercion.v.tex Extraction.v.tex \
+  Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \
+  Setoid.v.tex Helm.tex Classes.v.tex )
+
+REFMANTEXFILES:=$(addprefix doc/refman/, \
+  headers.sty Reference-Manual.tex \
+  RefMan-pre.tex RefMan-int.tex RefMan-pro.tex RefMan-com.tex \
+  RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex ) \
   $(REFMANCOQTEXFILES) \
 
 REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps
 
-REFMANFILES:=$(REFMANTEXFILES) $(COMMON) $(REFMANEPSFILES) doc/refman/biblio.bib
+REFMANFILES:=$(REFMANTEXFILES) $(DOCCOMMON) $(REFMANEPSFILES) doc/refman/biblio.bib
 
 REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png)
 
@@ -126,351 +143,126 @@ CLIBS:=unix.cma
 
 CAMLP4OBJS:=gramlib.cma
 
-CONFIG:=\
-  config/coq_config.cmo
-
-LIBREP:=\
-  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/flags.cmo \
-  lib/util.cmo lib/bigint.cmo lib/hashcons.cmo lib/dyn.cmo lib/system.cmo \
-  lib/envars.cmo lib/bstack.cmo lib/edit.cmo lib/gset.cmo lib/gmap.cmo \
-  lib/tlm.cmo lib/gmapl.cmo lib/profile.cmo lib/explore.cmo \
-  lib/predicate.cmo lib/rtree.cmo lib/heap.cmo lib/option.cmo
-# Rem: Cygwin already uses variable LIB 
-
-BYTERUN:=\
-  kernel/byterun/coq_fix_code.o kernel/byterun/coq_memory.o \
-  kernel/byterun/coq_values.o kernel/byterun/coq_interp.o 
-
-KERNEL:=\
-  kernel/names.cmo kernel/univ.cmo \
-  kernel/esubst.cmo kernel/term.cmo \
-  kernel/mod_subst.cmo kernel/sign.cmo \
-  kernel/cbytecodes.cmo kernel/copcodes.cmo \
-  kernel/cemitcodes.cmo kernel/vm.cmo \
-  kernel/declarations.cmo \
-  kernel/retroknowledge.cmo kernel/pre_env.cmo \
-  kernel/cbytegen.cmo  kernel/environ.cmo  \
-  kernel/csymtable.cmo kernel/conv_oracle.cmo \
-  kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo \
-  kernel/entries.cmo kernel/modops.cmo \
-  kernel/inductive.cmo kernel/vconv.cmo kernel/typeops.cmo \
-  kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \
-  kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo
-
-LIBRARY:=\
-  library/nameops.cmo library/libnames.cmo library/libobject.cmo \
-  library/summary.cmo library/nametab.cmo library/global.cmo library/lib.cmo \
-  library/declaremods.cmo library/library.cmo library/states.cmo \
-  library/decl_kinds.cmo library/dischargedhypsmap.cmo library/goptions.cmo \
-  library/decls.cmo library/heads.cmo
-
-PRETYPING:=\
-  pretyping/termops.cmo pretyping/evd.cmo \
-  pretyping/reductionops.cmo pretyping/vnorm.cmo pretyping/inductiveops.cmo \
-  pretyping/retyping.cmo pretyping/cbv.cmo \
-  pretyping/pretype_errors.cmo pretyping/recordops.cmo pretyping/typing.cmo \
-  pretyping/tacred.cmo pretyping/evarutil.cmo pretyping/evarconv.cmo \
-  pretyping/typeclasses_errors.cmo pretyping/typeclasses.cmo \
-  pretyping/classops.cmo pretyping/coercion.cmo \
-  pretyping/unification.cmo pretyping/clenv.cmo \
-  pretyping/rawterm.cmo pretyping/pattern.cmo \
-  pretyping/detyping.cmo  pretyping/indrec.cmo\
-  pretyping/cases.cmo pretyping/pretyping.cmo pretyping/matching.cmo
-
-INTERP:=\
-  parsing/lexer.cmo interp/topconstr.cmo interp/ppextend.cmo \
-  interp/notation.cmo interp/dumpglob.cmo \
-  interp/genarg.cmo interp/syntax_def.cmo interp/reserve.cmo \
-  library/impargs.cmo interp/implicit_quantifiers.cmo interp/constrintern.cmo \
-  interp/modintern.cmo interp/constrextern.cmo interp/coqlib.cmo \
-  toplevel/discharge.cmo library/declare.cmo
-
-PROOFS:=\
-  proofs/tacexpr.cmo proofs/proof_type.cmo proofs/redexpr.cmo \
-  proofs/proof_trees.cmo proofs/logic.cmo \
-  proofs/refiner.cmo proofs/evar_refiner.cmo proofs/tacmach.cmo \
-  proofs/pfedit.cmo proofs/tactic_debug.cmo \
-  proofs/clenvtac.cmo proofs/decl_mode.cmo
-
-PARSING:=\
-  parsing/extend.cmo \
-  parsing/pcoq.cmo parsing/egrammar.cmo parsing/g_xml.cmo \
-  parsing/ppconstr.cmo parsing/printer.cmo \
-  parsing/pptactic.cmo parsing/ppdecl_proof.cmo parsing/tactic_printer.cmo \
-  parsing/printmod.cmo parsing/prettyp.cmo parsing/search.cmo 
-
-HIGHPARSING:=\
-  parsing/g_constr.cmo parsing/g_vernac.cmo parsing/g_prim.cmo \
-  parsing/g_proofs.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo \
-  parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo \
-  parsing/g_ascii_syntax.cmo parsing/g_string_syntax.cmo \
-  parsing/g_decl_mode.cmo parsing/g_intsyntax.cmo 
-
-TACTICS:=\
-  tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \
-  tactics/nbtermdn.cmo tactics/tacticals.cmo \
-  tactics/hipattern.cmo tactics/tactics.cmo \
-  tactics/hiddentac.cmo tactics/elim.cmo \
-  tactics/dhyp.cmo tactics/auto.cmo \
-  toplevel/ind_tables.cmo tactics/equality.cmo \
-  tactics/contradiction.cmo tactics/inv.cmo tactics/leminv.cmo \
-  tactics/tacinterp.cmo tactics/autorewrite.cmo tactics/evar_tactics.cmo \
-  tactics/decl_interp.cmo tactics/decl_proof_instr.cmo
-
-TOPLEVEL:=\
-  toplevel/himsg.cmo toplevel/cerrors.cmo \
-  toplevel/class.cmo toplevel/vernacexpr.cmo toplevel/metasyntax.cmo \
-  toplevel/auto_ind_decl.cmo \
-  toplevel/command.cmo toplevel/record.cmo \
-  parsing/ppvernac.cmo toplevel/classes.cmo \
-  toplevel/vernacinterp.cmo toplevel/mltop.cmo \
-  toplevel/vernacentries.cmo toplevel/whelp.cmo toplevel/vernac.cmo \
-  toplevel/line_oriented_parser.cmo toplevel/protectedtoplevel.cmo \
-  toplevel/toplevel.cmo $(REVISIONCMO) toplevel/usage.cmo \
-  toplevel/coqinit.cmo toplevel/coqtop.cmo
-
-HIGHTACTICS:=\
-  tactics/refine.cmo tactics/extraargs.cmo \
-  tactics/extratactics.cmo tactics/eauto.cmo tactics/class_tactics.cmo \
-  tactics/tauto.cmo tactics/eqdecide.cmo
-
-OMEGACMO:=\
-  contrib/omega/omega.cmo contrib/omega/coq_omega.cmo \
-  contrib/omega/g_omega.cmo 
-
-ROMEGACMO:=\
-  contrib/romega/const_omega.cmo \
-  contrib/romega/refl_omega.cmo contrib/romega/g_romega.cmo
-
-MICROMEGACMO:=\
-  contrib/micromega/mutils.cmo contrib/micromega/vector.cmo \
-  contrib/micromega/micromega.cmo contrib/micromega/mfourier.cmo \
-  contrib/micromega/certificate.cmo \
-  contrib/micromega/coq_micromega.cmo contrib/micromega/g_micromega.cmo
-
-RINGCMO:=\
-  contrib/ring/quote.cmo contrib/ring/g_quote.cmo \
-  contrib/ring/ring.cmo contrib/ring/g_ring.cmo 
-
-NEWRINGCMO:=\
-  contrib/setoid_ring/newring.cmo
-
-DPCMO:=contrib/dp/dp_why.cmo contrib/dp/dp_zenon.cmo \
-      contrib/dp/dp.cmo contrib/dp/dp_gappa.cmo contrib/dp/g_dp.cmo
-
-FIELDCMO:=\
-  contrib/field/field.cmo 
-
-XMLCMO:=\
-  contrib/xml/unshare.cmo contrib/xml/xml.cmo contrib/xml/acic.cmo \
-  contrib/xml/doubleTypeInference.cmo \
-  contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
-  contrib/xml/proof2aproof.cmo \
-  contrib/xml/xmlcommand.cmo contrib/xml/proofTree2Xml.cmo \
-  contrib/xml/xmlentries.cmo 	contrib/xml/cic2Xml.cmo \
-  contrib/xml/dumptree.cmo
-
-FOURIERCMO:=\
-  contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo \
-  contrib/fourier/g_fourier.cmo
-
-EXTRACTIONCMO:=\
-  contrib/extraction/table.cmo\
-  contrib/extraction/mlutil.cmo\
-  contrib/extraction/modutil.cmo \
-  contrib/extraction/extraction.cmo \
-  contrib/extraction/common.cmo \
-  contrib/extraction/ocaml.cmo \
-  contrib/extraction/haskell.cmo \
-  contrib/extraction/scheme.cmo \
-  contrib/extraction/extract_env.cmo \
-  contrib/extraction/g_extraction.cmo
-
-FUNINDCMO:=\
-  contrib/funind/indfun_common.cmo contrib/funind/rawtermops.cmo \
-  contrib/funind/recdef.cmo \
-  contrib/funind/rawterm_to_relation.cmo \
-  contrib/funind/functional_principles_proofs.cmo \
-  contrib/funind/functional_principles_types.cmo \
-  contrib/funind/invfun.cmo contrib/funind/indfun.cmo \
-  contrib/funind/merge.cmo contrib/funind/g_indfun.cmo
-
-FOCMO:=\
-  contrib/firstorder/formula.cmo contrib/firstorder/unify.cmo \
-  contrib/firstorder/sequent.cmo contrib/firstorder/rules.cmo \
-  contrib/firstorder/instances.cmo contrib/firstorder/ground.cmo \
-  contrib/firstorder/g_ground.cmo
-
-CCCMO:=contrib/cc/ccalgo.cmo contrib/cc/ccproof.cmo contrib/cc/cctac.cmo \
-  contrib/cc/g_congruence.cmo 
-
-SUBTACCMO:=contrib/subtac/subtac_utils.cmo contrib/subtac/eterm.cmo \
-  contrib/subtac/g_eterm.cmo \
-  contrib/subtac/subtac_errors.cmo contrib/subtac/subtac_coercion.cmo \
-  contrib/subtac/subtac_obligations.cmo contrib/subtac/subtac_cases.cmo \
-  contrib/subtac/subtac_pretyping_F.cmo contrib/subtac/subtac_pretyping.cmo \
-  contrib/subtac/subtac_command.cmo contrib/subtac/subtac_classes.cmo \
-  contrib/subtac/subtac.cmo contrib/subtac/g_subtac.cmo \
-  contrib/subtac/equations.cmo
-
-RTAUTOCMO:=contrib/rtauto/proof_search.cmo contrib/rtauto/refl_tauto.cmo \
-	contrib/rtauto/g_rtauto.cmo
-
-CONTRIB:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) \
-        $(RINGCMO) $(NEWRINGCMO) $(DPCMO) $(FIELDCMO) \
-	$(FOURIERCMO) $(EXTRACTIONCMO) $(XMLCMO) \
-	$(CCCMO)  $(FOCMO) $(SUBTACCMO) $(RTAUTOCMO) \
-	$(FUNINDCMO)
+CONFIG:=config/coq_config.cmo
 
-CMA:=$(CLIBS) $(CAMLP4OBJS)
-CMXA:=$(CMA:.cma=.cmxa)
+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
 # respecting this order is useful for developers that want to load or link
 # the libraries directly
 
-LINKCMO:=$(CONFIG) lib/lib.cma kernel/kernel.cma library/library.cma \
+CORECMA:=lib/lib.cma kernel/kernel.cma library/library.cma \
         pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
         parsing/parsing.cma tactics/tactics.cma toplevel/toplevel.cma \
-        parsing/highparsing.cma tactics/hightactics.cma contrib/contrib.cma
-LINKCMOCMXA:=$(LINKCMO:.cma=.cmxa)
-LINKCMX:=$(LINKCMOCMXA:.cmo=.cmx)
-
-# objects known by the toplevel of Coq
-OBJSCMO:=$(CONFIG) $(LIBREP) $(KERNEL) $(LIBRARY) $(PRETYPING) $(INTERP) \
-        $(PROOFS) $(PARSING) $(TACTICS) $(TOPLEVEL) $(HIGHPARSING) \
-        $(HIGHTACTICS) $(CONTRIB)
-
-COQIDECMO:=ide/utils/okey.cmo ide/utils/config_file.cmo \
-	  ide/utils/configwin_keys.cmo ide/utils/configwin_types.cmo \
-	  ide/utils/configwin_messages.cmo ide/utils/configwin_ihm.cmo \
-	  ide/utils/configwin.cmo \
-	  ide/utils/editable_cells.cmo ide/config_parser.cmo \
-	  ide/config_lexer.cmo ide/utf8_convert.cmo ide/preferences.cmo \
-	  ide/ideutils.cmo ide/blaster_window.cmo ide/undo.cmo \
-	  ide/find_phrase.cmo \
-          ide/highlight.cmo ide/coq.cmo ide/coq_commands.cmo \
-	  ide/coq_tactics.cmo  ide/command_windows.cmo ide/coqide.cmo
-
-COQIDECMX:=$(COQIDECMO:.cmo=.cmx)
-
-COQENVCMO:=$(CONFIG) lib/pp_control.cmo lib/pp.cmo  lib/compat.cmo lib/flags.cmo \
-	lib/util.cmo lib/system.cmo lib/envars.cmo
+        parsing/highparsing.cma tactics/hightactics.cma 
+
+OMEGACMA:=plugins/omega/omega_plugin.cma
+ROMEGACMA:=plugins/romega/romega_plugin.cma
+MICROMEGACMA:=plugins/micromega/micromega_plugin.cma
+QUOTECMA:=plugins/quote/quote_plugin.cma
+RINGCMA:=plugins/ring/ring_plugin.cma
+NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma
+NSATZCMA:=plugins/nsatz/nsatz_plugin.cma
+DPCMA:=plugins/dp/dp_plugin.cma
+FIELDCMA:=plugins/field/field_plugin.cma
+XMLCMA:=plugins/xml/xml_plugin.cma
+FOURIERCMA:=plugins/fourier/fourier_plugin.cma
+EXTRACTIONCMA:=plugins/extraction/extraction_plugin.cma
+FUNINDCMA:=plugins/funind/recdef_plugin.cma
+FOCMA:=plugins/firstorder/ground_plugin.cma
+CCCMA:=plugins/cc/cc_plugin.cma
+SUBTACCMA:=plugins/subtac/subtac_plugin.cma
+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 )
+
+PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) \
+        $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \
+        $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \
+        $(CCCMA)  $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \
+        $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA)
+
+ifneq ($(HASNATDYNLINK),false)
+ STATICPLUGINS:=
+ INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) $(DPCMA) \
+	$(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA)
+ INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs)
+ PLUGINS:=$(PLUGINSCMA)
+ PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs)
+else
+ STATICPLUGINS:=$(PLUGINSCMA)
+ INITPLUGINS:=
+ INITPLUGINSOPT:=
+ PLUGINS:=
+ PLUGINSOPT:=
+endif
 
-COQMKTOPCMO:=$(COQENVCMO) scripts/tolink.cmo scripts/coqmktop.cmo 
-COQMKTOPCMX:=$(COQMKTOPCMO:.cmo=.cmx)
+ifeq ($(BEST),opt)
+  INITPLUGINSBEST:=$(INITPLUGINSOPT)
+else
+  INITPLUGINSBEST:=$(INITPLUGINS)
+endif
 
-COQCCMO:=$(COQENVCMO) $(REVISIONCMO) toplevel/usage.cmo scripts/coqc.cmo
-COQCCMX:=$(COQCCMO:.cmo=.cmx)
+CMA:=$(CLIBS) $(CAMLP4OBJS)
+CMXA:=$(CMA:.cma=.cmxa)
 
-INTERFACE:=\
-  contrib/interface/vtp.cmo contrib/interface/xlate.cmo \
-  contrib/interface/paths.cmo contrib/interface/translate.cmo \
-  contrib/interface/pbp.cmo \
-  contrib/interface/dad.cmo \
-  contrib/interface/history.cmo \
-  contrib/interface/name_to_ast.cmo contrib/interface/debug_tac.cmo \
-  contrib/interface/showproof_ct.cmo contrib/interface/showproof.cmo \
-  contrib/interface/blast.cmo contrib/interface/depends.cmo \
-  contrib/interface/centaur.cmo
+LINKCMO:=$(CONFIG) $(CORECMA) $(STATICPLUGINS)
+LINKCMX:=$(CONFIG:.cmo=.cmx) $(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa)
 
-INTERFACECMX:=$(INTERFACE:.cmo=.cmx)
+IDECMA:=ide/ide.cma
 
-PARSERREQUIRES:=$(LINKCMO) $(LIBCOQRUN) # Solution de facilité...
-PARSERREQUIRESCMX:=$(LINKCMX)
+# modules known by the toplevel of Coq
 
-ifeq ($(BEST),opt)
-  COQINTERFACE:=bin/coq-interface$(EXE) bin/coq-interface.opt$(EXE) bin/coq-parser$(EXE) bin/coq-parser.opt$(EXE)
-else
-  COQINTERFACE:=bin/coq-interface$(EXE) bin/coq-parser$(EXE)
-endif
+OBJSMOD:=Coq_config \
+ $(foreach lib,$(CORECMA),$(shell cat $(lib:.cma=.mllib)))
 
-PARSERCODE:=contrib/interface/line_parser.cmo contrib/interface/vtp.cmo \
-           contrib/interface/xlate.cmo contrib/interface/parse.cmo
-PARSERCMO:=$(PARSERREQUIRES) $(PARSERCODE)
-PARSERCMX:= $(PARSERREQUIRESCMX) $(PARSERCODE:.cmo=.cmx)
+IDEMOD:=$(shell cat ide/ide.mllib)
 
-INTERFACERC:= contrib/interface/vernacrc
+# coqmktop, coqc
+
+COQENVCMO:=$(CONFIG) \
+  lib/pp_control.cmo lib/pp.cmo  lib/compat.cmo lib/flags.cmo \
+  lib/segmenttree.cmo lib/unicodetable.cmo lib/util.cmo lib/system.cmo \
+  lib/envars.cmo
+
+COQMKTOPCMO:=$(COQENVCMO) scripts/tolink.cmo scripts/coqmktop.cmo 
+COQMKTOPCMX:=$(COQMKTOPCMO:.cmo=.cmx)
+
+COQCCMO:=$(COQENVCMO) toplevel/usage.cmo scripts/coqc.cmo
+COQCCMX:=$(COQCCMO:.cmo=.cmx)
+
+## Misc
+
+CSDPCERTCMO:=$(addprefix plugins/micromega/, \
+  mutils.cmo 	micromega.cmo 	mfourier.cmo 	certificate.cmo \
+  sos_types.cmo sos_lib.cmo sos.cmo 	csdpcert.cmo )
 
-CSDPCERTCMO:= contrib/micromega/mutils.cmo contrib/micromega/micromega.cmo \
-              contrib/micromega/vector.cmo contrib/micromega/mfourier.cmo \
-              contrib/micromega/certificate.cmo \
-              contrib/micromega/sos.cmo contrib/micromega/csdpcert.cmo
 CSDPCERTCMX:= $(CSDPCERTCMO:.cmo=.cmx)
 
 DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma
 
-COQDEPCMO:=$(COQENVCMO) tools/coqdep_lexer.cmo tools/coqdep.cmo
+COQDEPBOOTML:=tools/coqdep_lexer.ml tools/coqdep_common.ml tools/coqdep_boot.ml
+COQDEPML:=tools/coqdep_lexer.ml tools/coqdep_common.ml tools/coqdep.ml
+
+COQDEPCMO:=$(COQENVCMO) $(COQDEPML:.ml=.cmo)
 COQDEPCMX:=$(COQDEPCMO:.cmo=.cmx)
 
 GALLINACMO:=tools/gallina_lexer.cmo tools/gallina.cmo
 GALLINACMX:=$(GALLINACMO:.cmo=.cmx)
 
-COQDOCCMO:=$(CONFIG) tools/coqdoc/cdglobals.cmo tools/coqdoc/alpha.cmo \
-	tools/coqdoc/index.cmo tools/coqdoc/output.cmo \
-	tools/coqdoc/pretty.cmo tools/coqdoc/main.cmo
+COQDOCCMO:=$(CONFIG) $(addprefix tools/coqdoc/, \
+  cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo )
 COQDOCCMX:=$(COQDOCCMO:.cmo=.cmx)
 
-# checker
-
-MCHECKER:=\
-  config/coq_config.cmo \
-  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo \
-  lib/flags.cmo lib/util.cmo lib/option.cmo lib/hashcons.cmo \
-  lib/system.cmo lib/envars.cmo \
-  lib/predicate.cmo lib/rtree.cmo \
-  kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo \
-  checker/validate.cmo \
-  checker/term.cmo \
-  checker/declarations.cmo checker/environ.cmo \
-  checker/closure.cmo checker/reduction.cmo \
-  checker/type_errors.cmo \
-  checker/modops.cmo \
-  checker/inductive.cmo checker/typeops.cmo \
-  checker/indtypes.cmo checker/subtyping.cmo checker/mod_checking.cmo \
-  checker/safe_typing.cmo checker/check.cmo \
-  checker/check_stat.cmo checker/checker.cmo
-
 # grammar modules with camlp4
 
-GRAMMARNEEDEDCMO:=\
-  lib/profile.cmo lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/flags.cmo \
-  lib/util.cmo lib/bigint.cmo lib/dyn.cmo lib/hashcons.cmo lib/predicate.cmo \
-  lib/rtree.cmo lib/option.cmo \
-  kernel/names.cmo kernel/univ.cmo \
-  kernel/esubst.cmo kernel/term.cmo kernel/mod_subst.cmo kernel/sign.cmo \
-  kernel/cbytecodes.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo \
-  kernel/declarations.cmo \
-  kernel/retroknowledge.cmo kernel/pre_env.cmo \
-  kernel/cbytegen.cmo kernel/conv_oracle.cmo kernel/environ.cmo \
-  kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo\
-  kernel/entries.cmo \
-  kernel/modops.cmo \
-  kernel/inductive.cmo kernel/typeops.cmo \
-  kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \
-  kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo \
-  library/nameops.cmo library/libnames.cmo library/summary.cmo \
-  library/nametab.cmo library/libobject.cmo library/lib.cmo \
-  library/goptions.cmo library/decl_kinds.cmo library/global.cmo \
-  pretyping/termops.cmo pretyping/evd.cmo pretyping/reductionops.cmo \
-  pretyping/inductiveops.cmo pretyping/rawterm.cmo pretyping/detyping.cmo \
-  pretyping/pattern.cmo \
-  interp/topconstr.cmo interp/genarg.cmo interp/ppextend.cmo \
-  proofs/tacexpr.cmo \
-  parsing/lexer.cmo parsing/extend.cmo \
-  toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_util.cmo \
-  parsing/q_coqast.cmo 
-
-CAMLP4EXTENSIONSCMO:=\
-  parsing/argextend.cmo parsing/tacextend.cmo parsing/vernacextend.cmo 
-
-GRAMMARSCMO:=\
-  parsing/g_prim.cmo parsing/g_tactic.cmo \
-  parsing/g_ltac.cmo parsing/g_constr.cmo
-
-GRAMMARCMO:=config/coq_config.cmo $(GRAMMARNEEDEDCMO) $(CAMLP4EXTENSIONSCMO) $(GRAMMARSCMO)
-
 GRAMMARCMA:=parsing/grammar.cma
 
 GRAMMARML4:=lib/compat.ml4 lib/pp.ml4 parsing/q_util.ml4 parsing/pcoq.ml4 \
@@ -480,412 +272,143 @@ GRAMMARML4:=lib/compat.ml4 lib/pp.ml4 parsing/q_util.ml4 parsing/pcoq.ml4 \
   parsing/lexer.ml4 parsing/q_coqast.ml4
 
 STAGE1_ML4:=$(GRAMMARML4) parsing/q_constr.ml4
-STAGE1_CMO:=$(GRAMMARCMO) parsing/q_constr.cmo
 STAGE1:=parsing/grammar.cma parsing/q_constr.cmo
 
-PRINTERSCMO:=\
-  config/coq_config.cmo lib/lib.cma \
-  kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo kernel/term.cmo	\
-  kernel/mod_subst.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo	\
-  kernel/sign.cmo kernel/declarations.cmo kernel/retroknowledge.cmo \
-  kernel/pre_env.cmo \
-  kernel/retroknowledge.cmo kernel/pre_env.cmo \
-  kernel/cbytecodes.cmo kernel/cbytegen.cmo kernel/environ.cmo \
-  kernel/conv_oracle.cmo kernel/closure.cmo kernel/reduction.cmo	\
-  kernel/modops.cmo kernel/type_errors.cmo kernel/inductive.cmo		\
-  kernel/typeops.cmo kernel/subtyping.cmo kernel/indtypes.cmo		\
-  kernel/cooking.cmo 		\
-  kernel/term_typing.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo	\
-  library/summary.cmo library/global.cmo library/nameops.cmo		\
-  library/libnames.cmo library/nametab.cmo library/libobject.cmo	\
-  library/lib.cmo library/goptions.cmo library/decls.cmo library/heads.cmo \
-  pretyping/termops.cmo pretyping/evd.cmo pretyping/rawterm.cmo \
-  pretyping/reductionops.cmo pretyping/inductiveops.cmo			    \
-  pretyping/retyping.cmo pretyping/cbv.cmo				    \
-  pretyping/pretype_errors.cmo pretyping/recordops.cmo pretyping/typing.cmo \
-  pretyping/evarutil.cmo pretyping/evarconv.cmo pretyping/tacred.cmo \
-  pretyping/classops.cmo pretyping/typeclasses_errors.cmo pretyping/typeclasses.cmo \
-  pretyping/detyping.cmo pretyping/indrec.cmo pretyping/coercion.cmo \
-  pretyping/unification.cmo pretyping/cases.cmo \
-  pretyping/pretyping.cmo pretyping/clenv.cmo pretyping/pattern.cmo \
-  parsing/lexer.cmo interp/ppextend.cmo interp/genarg.cmo \
-  interp/topconstr.cmo interp/notation.cmo  interp/dumpglob.cmo interp/reserve.cmo		\
-  library/impargs.cmo interp/constrextern.cmo \
-  interp/syntax_def.cmo interp/implicit_quantifiers.cmo \
-  interp/constrintern.cmo proofs/proof_trees.cmo proofs/tacexpr.cmo \
-  proofs/proof_type.cmo proofs/logic.cmo proofs/refiner.cmo \
-  proofs/evar_refiner.cmo proofs/pfedit.cmo proofs/tactic_debug.cmo \
-  proofs/decl_mode.cmo \
-  parsing/ppconstr.cmo parsing/extend.cmo parsing/pcoq.cmo \
-  parsing/printer.cmo parsing/pptactic.cmo \
-  parsing/ppdecl_proof.cmo \
-  parsing/tactic_printer.cmo \
-  parsing/egrammar.cmo toplevel/himsg.cmo toplevel/cerrors.cmo \
-  toplevel/vernacexpr.cmo toplevel/vernacinterp.cmo \
-  dev/top_printers.cmo
 
 ###########################################################################
 # vo files
 ###########################################################################
 
-## Theories
-
-INITVO:=$(addprefix theories/Init/, \
- Notations.vo	Datatypes.vo	Peano.vo	Logic.vo	\
- Specif.vo	Logic_Type.vo  	Wf.vo		Tactics.vo	\
- Prelude.vo )
-
-LOGICVO:=$(addprefix theories/Logic/, \
- Hurkens.vo               ProofIrrelevance.vo      Classical.vo 	\
- Classical_Type.vo        Classical_Pred_Set.vo    Eqdep.vo     	\
- Classical_Prop.vo        Classical_Pred_Type.vo   ClassicalFacts.vo 	\
- ChoiceFacts.vo           Berardi.vo               Eqdep_dec.vo 	\
- Decidable.vo             JMeq.vo                  ClassicalChoice.vo 	\
- ClassicalDescription.vo  RelationalChoice.vo      Diaconescu.vo 	\
- EqdepFacts.vo            ProofIrrelevanceFacts.vo ClassicalEpsilon.vo 	\
- ClassicalUniqueChoice.vo DecidableType.vo         DecidableTypeEx.vo 	\
- Epsilon.vo               ConstructiveEpsilon.vo   Description.vo 	\
- IndefiniteDescription.vo SetIsType.vo             FunctionalExtensionality.vo )
-
-ARITHVO:=$(addprefix theories/Arith/, \
- Arith.vo	Gt.vo          	Between.vo	Le.vo         	\
- Compare.vo	Lt.vo          	Compare_dec.vo	Min.vo        	\
- Div2.vo	Minus.vo       	Mult.vo		Even.vo       	\
- EqNat.vo	Peano_dec.vo   	Euclid.vo	Plus.vo		\
- Wf_nat.vo  	Max.vo		Bool_nat.vo	Factorial.vo	\
- Arith_base.vo )
-
-SORTINGVO:=$(addprefix theories/Sorting/, \
- Heap.vo 	Permutation.vo	Sorting.vo 	PermutSetoid.vo \
- PermutEq.vo )
-
-BOOLVO:=$(addprefix theories/Bool/, \
- Bool.vo  	IfProp.vo    	Zerob.vo 	DecBool.vo 	\
- Sumbool.vo 	BoolEq.vo    	Bvector.vo )
-
-NARITHVO:=$(addprefix theories/NArith/, \
- BinPos.vo	Pnat.vo      	BinNat.vo   	NArith.vo 	\
- Nnat.vo	Ndigits.vo   	Ndec.vo	 	Ndist.vo 	)
-
-ZARITHVO:=$(addprefix theories/ZArith/, \
- BinInt.vo      Wf_Z.vo 	ZArith.vo      	ZArith_dec.vo 	\
- auxiliary.vo   Zmisc.vo 	Zcompare.vo    	Znat.vo 	\
- Zorder.vo      Zabs.vo 	Zmin.vo        	Zmax.vo 	\
- Zminmax.vo     Zeven.vo 	Zhints.vo	Zlogarithm.vo 	\
- Zpower.vo 	Zcomplements.vo Zdiv.vo		Zsqrt.vo 	\
- Zwf.vo		ZArith_base.vo 	Zbool.vo	Zbinary.vo 	\
- Znumtheory.vo  Int.vo 		Zpow_def.vo	Zpow_facts.vo 	\
- ZOdiv_def.vo   ZOdiv.vo 	Zgcd_alt.vo )
-
-QARITHVO:=$(addprefix theories/QArith/, \
- QArith_base.vo Qreduction.vo 	Qring.vo	Qreals.vo 	\
- QArith.vo	Qcanon.vo 	Qfield.vo	Qpower.vo 	\
- Qabs.vo        Qround.vo )
-
-LISTSVO:=$(addprefix theories/Lists/, \
- MonoList.vo  	ListSet.vo   	Streams.vo 	StreamMemo.vo  \
- TheoryList.vo	List.vo 	SetoidList.vo   ListTactics.vo )
-
-STRINGSVO:=$(addprefix theories/Strings/, \
- Ascii.vo      	String.vo )
-
-SETSVO:=$(addprefix theories/Sets/, \
- Classical_sets.vo    	Permut.vo \
- Constructive_sets.vo 	Powerset.vo \
- Cpo.vo               	Powerset_Classical_facts.vo \
- Ensembles.vo         	Powerset_facts.vo \
- Finite_sets.vo       	Relations_1.vo \
- Finite_sets_facts.vo 	Relations_1_facts.vo \
- Image.vo             	Relations_2.vo \
- Infinite_sets.vo     	Relations_2_facts.vo \
- Integers.vo          	Relations_3.vo \
- Multiset.vo          	Relations_3_facts.vo \
- Partial_Order.vo     	Uniset.vo )
-
-FSETSBASEVO:=$(addprefix theories/FSets/, \
- OrderedType.vo		OrderedTypeEx.vo	OrderedTypeAlt.vo	\
- FSetInterface.vo	FSetList.vo 		FSetBridge.vo        	\
- FSetFacts.vo 		FSetProperties.vo	FSetEqProperties.vo 	\
- FSetWeakList.vo 	FSetAVL.vo           	FSetDecide.vo 		\
- FSets.vo \
- FMapInterface.vo       FMapList.vo		FMapFacts.vo 		\
- FMapWeakList.vo      	FMapPositive.vo		FSetToFiniteSet.vo   	\
- FMaps.vo )            
-
-FSETS_basic:=
-
-FSETS_all:=$(addprefix theories/FSets/, \
- FSetFullAVL.vo 	FMapAVL.vo 		FMapFullAVL.vo )
-
-FSETSVO:=$(FSETSBASEVO) $(FSETS_$(FSETS))
-
-ALLFSETS:=$(FSETSBASEVO) $(FSETS_all)
-
-RELATIONSVO:=$(addprefix theories/Relations/, \
- Operators_Properties.vo	Relation_Definitions.vo \
- Relation_Operators.vo 		Relations.vo )
-
-WELLFOUNDEDVO:=$(addprefix theories/Wellfounded/, \
- Disjoint_Union.vo 	Inclusion.vo 	Inverse_Image.vo \
- Transitive_Closure.vo  Union.vo 	Wellfounded.vo 	 \
- Well_Ordering.vo 	Lexicographic_Product.vo         \
- Lexicographic_Exponentiation.vo )
-
-REALSBASEVO:=$(addprefix theories/Reals/, \
- Rdefinitions.vo Raxioms.vo      RIneq.vo	DiscrR.vo \
- Rbase.vo 	 LegacyRfield.vo Rpow_def.vo )
-
-REALS_basic:= 
-
-REALS_all:=$(addprefix theories/Reals/, \
- R_Ifp.vo 	Rbasic_fun.vo	R_sqr.vo	SplitAbsolu.vo	\
- SplitRmult.vo	ArithProp.vo    Rfunctions.vo	Rseries.vo      \
- SeqProp.vo 	Rcomplete.vo    PartSum.vo	AltSeries.vo    \
- Binomial.vo	Rsigma.vo       Rprod.vo	Cauchy_prod.vo  \
- Alembert.vo	SeqSeries.vo    Rtrigo_fun.vo	Rtrigo_def.vo   \
- Rtrigo_alt.vo  Cos_rel.vo      Cos_plus.vo	Rtrigo.vo       \
- Rlimit.vo	Rderiv.vo       RList.vo	Ranalysis1.vo   \
- Ranalysis2.vo	Ranalysis3.vo   Rtopology.vo	MVT.vo          \
- PSeries_reg.vo Exp_prop.vo     Rtrigo_reg.vo	Rsqrt_def.vo    \
- R_sqrt.vo	Rtrigo_calc.vo  Rgeom.vo	Sqrt_reg.vo     \
- Ranalysis4.vo	Rpower.vo       Ranalysis.vo	NewtonInt.vo    \
- RiemannInt_SF.vo		RiemannInt.vo   Integration.vo 	\
- Rlogic.vo	Reals.vo )
-
-REALSVO:=$(REALSBASEVO) $(REALS_$(REALS))
-
-ALLREALS:=$(REALSBASEVO) $(REALS_all)
-
-NUMBERSCOMMONVO:=$(addprefix theories/Numbers/, \
- NaryFunctions.vo NumPrelude.vo BigNumPrelude.vo )
-
-CYCLICABSTRACTVO:=$(addprefix theories/Numbers/Cyclic/Abstract/, \
- CyclicAxioms.vo NZCyclic.vo )
-
-CYCLICINT31VO:=$(addprefix theories/Numbers/Cyclic/Int31/, \
- Int31.vo Cyclic31.vo )
-
-CYCLICDOUBLECYCLICVO:=$(addprefix theories/Numbers/Cyclic/DoubleCyclic/, \
- DoubleType.vo	DoubleBase.vo	DoubleAdd.vo	DoubleSub.vo	\
- DoubleMul.vo	DoubleDivn1.vo 	DoubleDiv.vo	DoubleSqrt.vo	\
- DoubleLift.vo 	DoubleCyclic.vo )
-
-CYCLICZMODULOVO := $(addprefix theories/Numbers/Cyclic/ZModulo/, \
- ZModulo.vo )
-
-CYCLICVO:=$(CYCLICABSTRACTVO) $(CYCLICINT31VO) $(CYCLICDOUBLECYCLICVO) \
- $(CYCLICZMODULOVO)
-
-NATINTVO:=$(addprefix theories/Numbers/NatInt/, \
- NZAxioms.vo	NZBase.vo	NZAdd.vo	NZMul.vo	\
- NZOrder.vo 	NZAddOrder.vo	NZMulOrder.vo )
-
-NATURALABSTRACTVO:=$(addprefix theories/Numbers/Natural/Abstract/, \
- NAxioms.vo 	NBase.vo 	NAdd.vo 	NMul.vo 	\
- NOrder.vo 	NAddOrder.vo	NMulOrder.vo 	NSub.vo	\
- NIso.vo )
-
-NATURALPEANOVO:=$(addprefix theories/Numbers/Natural/Peano/, \
- NPeano.vo )
-
-NATURALBINARYVO:=$(addprefix theories/Numbers/Natural/Binary/, \
- NBinDefs.vo 	NBinary.vo )
-
-NATURALSPECVIAZVO:=$(addprefix theories/Numbers/Natural/SpecViaZ/, \
- NSig.vo	NSigNAxioms.vo )
-
-NATURALBIGNVO:=$(addprefix theories/Numbers/Natural/BigN/, \
- Nbasic.vo 	NMake.vo 	BigN.vo )
-
-NATURALVO:=$(NATURALABSTRACTVO) $(NATURALPEANOVO) $(NATURALBINARYVO) \
- $(NATURALSPECVIAZVO) $(NATURALBIGNVO)
-
-INTEGERABSTRACTVO:=$(addprefix theories/Numbers/Integer/Abstract/, \
- ZAxioms.vo 	ZBase.vo 	ZAdd.vo 	ZMul.vo 	\
- ZLt.vo 	ZAddOrder.vo 	ZMulOrder.vo )
+## we now retrieve the names of .vo file to compile in */vo.itarget files
 
-INTEGERBINARYVO:=$(addprefix theories/Numbers/Integer/Binary/, \
- ZBinary.vo )
+cat_vo_itarget = $(addprefix $(1)/,$(shell cat $(1)/vo.itarget))
 
-INTEGERNATPAIRSVO:=$(addprefix theories/Numbers/Integer/NatPairs/, \
- ZNatPairs.vo )
-
-INTEGERSPECVIAZVO:=$(addprefix theories/Numbers/Integer/SpecViaZ/, \
- ZSig.vo	ZSigZAxioms.vo )
-
-INTEGERBIGZVO:=$(addprefix theories/Numbers/Integer/BigZ/, \
- ZMake.vo 	BigZ.vo )
-
-INTEGERVO:=$(INTEGERABSTRACTVO) $(INTEGERBINARYVO) $(INTEGERNATPAIRSVO) \
- $(INTEGERSPECVIAZVO) $(INTEGERBIGZVO)
-
-RATIONALSPECVIAQVO:=$(addprefix theories/Numbers/Rational/SpecViaQ/, \
- QSig.vo )
-
-RATIONALBIGQVO:=$(addprefix theories/Numbers/Rational/BigQ/, \
- QMake.vo	BigQ.vo )
-
-RATIONALVO:=$(RATIONALSPECVIAQVO) $(RATIONALBIGQVO)
-
-NUMBERSVO:= $(NUMBERSCOMMONVO) $(NATURALVO) $(INTEGERVO) $(NATINTVO) $(CYCLICVO) $(RATIONALVO)
-
-SETOIDSVO:=$(addprefix theories/Setoids/, \
- Setoid.vo ) 
-
-UNICODEVO:=$(addprefix theories/Unicode/, \
- Utf8.vo )
-
-CLASSESVO:=$(addprefix theories/Classes/, \
- Init.vo	RelationClasses.vo	Morphisms.vo	Morphisms_Prop.vo \
- Morphisms_Relations.vo	Functions.vo 	Equivalence.vo  SetoidTactics.vo  \
- SetoidClass.vo 	SetoidAxioms.vo EquivDec.vo 	SetoidDec.vo )
+## Theories
 
-PROGRAMVO:=$(addprefix theories/Program/, \
- Tactics.vo 	Equality.vo 	Subset.vo	Utils.vo 	\
- Wf.vo 		Basics.vo	Combinators.vo	Syntax.vo 	Program.vo )
+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)
+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)
+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)
 
 THEORIESVO:=\
   $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(NARITHVO) $(ZARITHVO) \
-  $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) \
+  $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(MSETSVO) \
   $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO)  $(SORTINGVO) $(QARITHVO) \
-  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO)
+  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) $(STRUCTURESVO)
 
 THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(ARITHVO)
 
-## Contribs
-
-OMEGAVO:=$(addprefix contrib/omega/, \
- PreOmega.vo	OmegaLemmas.vo 	Omega.vo )
-
-ROMEGAVO:=$(addprefix contrib/romega/, \
- ReflOmegaCore.vo 	ROmega.vo )
-
-MICROMEGAVO:=$(addprefix contrib/micromega/, \
-  CheckerMaker.vo       Refl.vo \
-  Env.vo                RingMicromega.vo \
-  EnvRing.vo            VarMap.vo \
-  OrderedRing.vo        ZCoeff.vo \
-  Psatz.vo	       ZMicromega.vo \
-  QMicromega.vo         RMicromega.vo \
-  Tauto.vo )
-
-RINGVO:=$(addprefix contrib/ring/, \
- LegacyArithRing.vo	Ring_normalize.vo \
- LegacyRing_theory.vo	LegacyRing.vo \
- LegacyNArithRing.vo    \
- LegacyZArithRing.vo	Ring_abstract.vo \
- Quote.vo		Setoid_ring_normalize.vo \
- Setoid_ring.vo		Setoid_ring_theory.vo )
-
-FIELDVO:=$(addprefix contrib/field/, \
- LegacyField_Compl.vo   LegacyField_Theory.vo \
- LegacyField_Tactic.vo  LegacyField.vo )
-
-NEWRINGVO:=$(addprefix contrib/setoid_ring/, \
- BinList.vo   		Ring_theory.vo \
- Ring_polynom.vo	Ring_tac.vo \
- Ring_base.vo 		InitialRing.vo \
- Ring_equiv.vo 		Ring.vo \
- ArithRing.vo		NArithRing.vo \
- ZArithRing.vo		\
- Field_theory.vo	Field_tac.vo \
- Field.vo		RealField.vo )
-
-XMLVO:= 
-
-FOURIERVO:=$(addprefix contrib/fourier/, \
- Fourier_util.vo    	Fourier.vo )
-
-FUNINDVO:= 
-
-RECDEFVO:=$(addprefix contrib/funind/, \
- Recdef.vo )
-
+## 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/ring)
+FIELDVO:=$(call cat_vo_itarget, plugins/field)
+NEWRINGVO:=$(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)
+DPVO:=$(call cat_vo_itarget, plugins/dp)
+RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto)
+EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction)
+XMLVO:=
 CCVO:=
 
-DPVO:=$(addprefix contrib/dp/, \
- Dp.vo )
-
-RTAUTOVO:=$(addprefix contrib/rtauto/, \
- Bintree.vo	Rtauto.vo )
-
-CONTRIBVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \
+PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \
 	    $(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \
-	    $(RTAUTOVO) $(RECDEFVO) $(NEWRINGVO) $(DPVO)
+	    $(RTAUTOVO) $(NEWRINGVO) $(DPVO) $(QUOTEVO) \
+            $(NSATZVO) $(EXTRACTIONVO)
 
-ALLVO:= $(INITVO) $(THEORIESVO) $(CONTRIBVO)
+ALLVO:= $(THEORIESVO) $(PLUGINSVO)
 VFILES:= $(ALLVO:.vo=.v)
 
 # convert a (stdlib) filename into a module name:
-# remove .vo, replace theories and contrib by Coq, and replace slashes by dots
-vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst contrib/%,Coq.%,$(1:.vo=))))
+# 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))
 
-LIBFILES:=$(THEORIESVO) $(CONTRIBVO)
+LIBFILES:=$(THEORIESVO) $(PLUGINSVO)
 LIBFILESLIGHT:=$(THEORIESLIGHTVO)
 
-## Specials
-
-INTERFACEVO:=
 
+###########################################################################
+# 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/coq_makefile.1 man/coqmktop.1 man/coqchk.1
 
-PCOQMANPAGES:=man/coq-interface.1 man/coq-parser.1
+DATE=$(shell LANG=C date +"%B %Y")
 
-RECTYPESML:=kernel/term.ml library/nametab.ml proofs/tacexpr.ml \
-  parsing/pptactic.ml 
+SOURCEDOCDIR=dev/source-doc
 
+CAML_OBJECT_PATTERNS:=%.cmo %.cmx %.cmi %.cma %.cmxa %.cmxs %.dep.ps %.dot
 
-#########################################################
-# .mli files by directory (used for dependencies graphs #
-#########################################################
+### Targets forwarded by Makefile to a specific stage:
 
-# We use wildcard to get rid of .cmo that do not have a .mli 
-KERNELMLI:=$(wildcard $(KERNEL:.cmo=.mli))
-INTERPMLI:=$(wildcard $(INTERP:.cmo=.mli))
-PRETYPINGMLI:=$(wildcard $(PRETYPING:.cmo=.mli))
-TOPLEVELMLI:=$(wildcard $(TOPLEVEL:.cmo=.mli))
-PROOFSMLI:=$(wildcard $(PROOFS:.cmo=.mli))
-LIBRARYMLI:=$(wildcard $(LIBRARY:.cmo=.mli))
-PARSINGMLI:=$(wildcard $(PARSING:.cmo=.mli) $(HIGHPARSING:.cmo=.mli))
-TACTICSMLI:=$(wildcard $(TACTICS:.cmo=.mli) $(HIGHTACTICS:.cmo=.mli))
-COQMLI:=$(KERNELMLI) $(INTERPMLI) $(PRETYPINGMLI) $(TOPLEVELMLI) $(PROOFSMLI) \
-	$(LIBRARYMLI) $(PARSINGMLI) $(TACTICSMLI)
+## Enumeration of targets that require being done at stage1
 
+STAGE1_TARGETS:= $(STAGE1) $(COQDEPBOOT) \
+  $(GENFILES) \
+  source-doc revision toplevel/mltop.byteml toplevel/mltop.optml \
+  $(STAGE1_ML4:.ml4=.ml4-preprocessed) %.o
 
-###########################################################################
-# Miscellaneous
-###########################################################################
+ifdef CM_STAGE1
+ STAGE1_TARGETS+=$(CAML_OBJECT_PATTERNS)
+endif
 
-DATE=$(shell LANG=C date +"%B %Y")
+## Enumeration of targets that require being done at stage2
 
-SOURCEDOCDIR=dev/source-doc
+VO_TARGETS:=logic arith bool narith zarith qarith lists strings sets \
+  fsets relations wellfounded ints reals \
+  setoids sorting natural integer rational numbers noreal \
+  omega micromega ring setoid_ring dp xml extraction field fourier \
+  funind cc subtac rtauto
+
+DOC_TARGETS:=doc doc-html doc-ps doc-pdf stdlib refman tutorial faq \
+  rectutorial refman-quick refman-nodep stdlib-nodep \
+  install-doc install-doc-meta install-doc-html install-doc-printable install-doc-index-url \
+  ide/index_urls.txt
+
+DOC_TARGET_PATTERNS:=%.dvi %.ps %.eps %.pdf %.html %.v.tex %.hva
 
-## Targets forwarded by Makefile to a specific stage
-STAGE1_TARGETS:= $(STAGE1) \
-  $(filter-out parsing/q_constr.cmo,$(STAGE1_CMO)) \
-  $(STAGE1_CMO:.cmo=.cmi) $(STAGE1_CMO:.cmo=.cmx) $(GENFILES) \
-  source-doc revision toplevel/mltop.byteml toplevel/mltop.optml \
-  $(STAGE1_ML4:.ml4=.ml4-preprocessed)
 STAGE2_TARGETS:=$(COQBINARIES) lib kernel byterun library proofs tactics \
   interp parsing pretyping highparsing toplevel hightactics \
   coqide-binaries coqide-byte coqide-opt $(COQIDEOPT) $(COQIDEBYTE) $(COQIDE) \
-  pcoq-binaries $(COQINTERFACE) $(CSDPCERT) coqbinaries pcoq $(TOOLS) tools \
-  printers debug initplugins
-VO_TARGETS:=logic arith bool narith zarith qarith lists strings sets \
-  fsets allfsets relations wellfounded ints reals allreals \
-  setoids sorting natural integer rational numbers noreal \
-  omega micromega ring setoid_ring dp xml extraction field fourier \
-  funind cc programs subtac rtauto
-DOC_TARGETS:=doc doc-html doc-ps doc-pdf stdlib refman tutorial faq rectutorial refman-quick refman-nodep stdlib-nodep
-STAGE3_TARGETS:=world install coqide coqide-files coq coqlib \
-  coqlight states pcoq-files check init theories theories-light contrib \
-  $(DOC_TARGETS) $(VO_TARGETS) validate
+  $(CSDPCERT) coqbinaries $(TOOLS) tools \
+  printers debug initplugins plugins \
+  world install coqide coqide-files coq coqlib \
+  coqlight states check init theories theories-light \
+  $(DOC_TARGETS) $(VO_TARGETS) validate \
+  %.vo %.glob states/% install-% %.ml4-preprocessed \
+  $(DOC_TARGET_PATTERNS)
+
+ifndef CM_STAGE1
+ STAGE2_TARGETS+=$(CAML_OBJECT_PATTERNS)
+endif
 
 
 # For emacs: 
diff --git a/Makefile.doc b/Makefile.doc
index f481d681..56daaa85 100644
--- a/Makefile.doc
+++ b/Makefile.doc
@@ -36,22 +36,20 @@ tutorial: \
 stdlib: \
   doc/stdlib/html/index.html doc/stdlib/Library.ps doc/stdlib/Library.pdf
 
-faq:\
-  doc/faq/html/index.html doc/faq/FAQ.v.ps doc/faq/FAQ.v.pdf
+faq: doc/faq/html/index.html doc/faq/FAQ.v.ps doc/faq/FAQ.v.pdf
 
-rectutorial:\
-  doc/RecTutorial/RecTutorial.html \
+rectutorial: doc/RecTutorial/RecTutorial.html \
   doc/RecTutorial/RecTutorial.ps doc/RecTutorial/RecTutorial.pdf
 
 ######################################################################
 ### Implicit rules
 ######################################################################
 
-ifeq ($(QUICK),1)
+ifdef QUICK
 %.v.tex: %.tex
 	(cd `dirname $<`; $(COQSRC)/$(COQTEX) $(COQTEXOPTS) `basename $<`)
 else
-%.v.tex: %.tex | $(COQTEX) $(COQTOPEXE) $(CONTRIBVO) $(CONTRIBCMO) $(THEORIESVO)
+%.v.tex: %.tex $(COQTEX) $(COQTOPEXE) $(PLUGINSVO) $(THEORIESVO)
 	(cd `dirname $<`; $(COQSRC)/$(COQTEX) $(COQTEXOPTS) `basename $<`)
 endif
 
@@ -68,6 +66,9 @@ endif
 HIDEBIBTEXINFO=| grep -v "^A level-1 auxiliary file"
 SHOWMAKEINDEXERROR=egrep '^!! Input index error|^\*\* Input style error|^   --'
 
+# Empty subsection levels in faq are on purpose
+HEVEAFAQFILTER=2>&1 | grep -v "^Warning: List with no item"
+
 ######################################################################
 # Common
 ######################################################################
@@ -81,11 +82,12 @@ doc/common/version.tex: config/Makefile
 # Reference Manual
 ######################################################################
 
+
 ### Reference Manual (printable format)
 
 # The second LATEX compilation is necessary otherwise the pages of the index
 # are not correct (don't know why...) - BB
-doc/refman/Reference-Manual.dvi: $(DOCCOMMON) $(REFMANFILES) doc/refman/Reference-Manual.tex
+doc/refman/Reference-Manual.dvi: $(REFMANFILES) doc/refman/Reference-Manual.tex
 	@(cd doc/refman;\
 	$(LATEX) -interaction=batchmode Reference-Manual;\
 	$(BIBTEX) -terse Reference-Manual $(HIDEBIBTEXINFO);\
@@ -102,7 +104,7 @@ doc/refman/Reference-Manual.dvi: $(DOCCOMMON) $(REFMANFILES) doc/refman/Referenc
 	$(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\
 	../tools/show_latex_messages -no-overfull Reference-Manual.log)
 
-doc/refman/Reference-Manual.pdf: $(DOCCOMMON) $(REFMANFILES) doc/refman/Reference-Manual.tex
+doc/refman/Reference-Manual.pdf: $(REFMANFILES) doc/refman/Reference-Manual.tex
 	(cd doc/refman;\
 	$(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\
 	../tools/show_latex_messages -no-overfull Reference-Manual.log)
@@ -125,7 +127,7 @@ doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
 	$(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html
 	(cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html)
 	$(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html
-	-$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html
+	$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html
 
 refman-quick:
 	(cd doc/refman;\
@@ -169,7 +171,7 @@ doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi
 	../tools/show_latex_messages FAQ.v.log)
 
 doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi # to ensure FAQ.v.bbl
-	(cd doc/faq; $(HEVEA) $(HEVEAOPTS) FAQ.v.tex)
+	(cd doc/faq; ($(HEVEA) $(HEVEAOPTS) FAQ.v.tex $(HEVEAFAQFILTER)))
 
 doc/faq/html/index.html: doc/faq/FAQ.v.html
 	- rm -rf doc/faq/html
@@ -183,44 +185,52 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html
 
 ### Standard library (browsable html format)
 
-ifeq ($(QUICK),1)
-doc/stdlib/html/genindex.html:
+ifdef QUICK
+doc/stdlib/index-body.html:
+	- rm -rf doc/stdlib/html
+	$(MKDIR) doc/stdlib/html
+	$(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \
+	  -R theories Coq $(THEORIESVO:.vo=.v)
+	mv doc/stdlib/html/index.html doc/stdlib/index-body.html
 else
-doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO)
-endif
+doc/stdlib/index-body.html: $(COQDOC) $(THEORIESVO)
 	- rm -rf doc/stdlib/html
 	$(MKDIR) doc/stdlib/html
-	$(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \
+	$(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \
 	  -R theories Coq $(THEORIESVO:.vo=.v)
-	mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html
+	mv doc/stdlib/html/index.html doc/stdlib/index-body.html
+endif
 
 doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index
 	./doc/stdlib/make-library-index doc/stdlib/index-list.html
 
-doc/stdlib/html/index.html: doc/stdlib/html/genindex.html doc/stdlib/index-list.html
-	cat doc/common/styles/html/$(HTMLSTYLE)/header.html doc/stdlib/index-list.html > $@
-	cat doc/common/styles/html/$(HTMLSTYLE)/footer.html >> $@
+doc/stdlib/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.html doc/stdlib/index-trailer.html
+	cat doc/stdlib/index-list.html > $@
+	sed -n -e '/<table>/,/<\/table>/p' doc/stdlib/index-body.html >> $@
+	cat doc/stdlib/index-trailer.html >> $@
 
 ### Standard library (light version, full version is definitely too big)
 
-ifeq ($(QUICK),1)
+ifdef QUICK
 doc/stdlib/Library.coqdoc.tex:
+	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
+            -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@
 else
-doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO)
-endif
-	$(COQDOC) -q -boot --gallina --body-only --latex --stdout \
+doc/stdlib/Library.coqdoc.tex: $(COQDOC) $(THEORIESLIGHTVO)
+	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
             -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@
+endif
 
 doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex
 	(cd doc/stdlib;\
 	$(LATEX) -interaction=batchmode Library;\
 	$(LATEX) -interaction=batchmode Library > /dev/null;\
-	../tools/show_latex_messages Library.log)
+	../tools/show_latex_messages -no-overfull Library.log)
 
 doc/stdlib/Library.pdf: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.dvi
 	(cd doc/stdlib;\
 	$(PDFLATEX) -interaction=batchmode Library;\
-	../tools/show_latex_messages Library.log)
+	../tools/show_latex_messages -no-overfull Library.log)
 
 ######################################################################
 # Tutorial on inductive types
@@ -248,21 +258,23 @@ doc/RecTutorial/RecTutorial.html: doc/RecTutorial/RecTutorial.tex
 
 # Not robust, improve...
 ide/index_urls.txt: doc/refman/html/index.html
-	@ rm -f ide/index_urls.txt
-	cat doc/refman/html/command-index.html doc/refman/html/tactic-index.html | grep li-indexenv | grep HREF | sed -e 's@.*<TT>\(.*\)</TT>.*, <A HREF="\(.*\)">.*@\1,\2@' > ide/index_urls.txt
+	@ rm -f doc/refman/html/index_urls.txt
+	cat doc/refman/html/command-index.html doc/refman/html/tactic-index.html | grep li-indexenv | grep HREF | sed -e 's@.*<TT>\(.*\)</TT>.*, <A HREF="\(.*\)">.*@\1,\2@' > doc/refman/html/index_urls.txt
 
 
 ######################################################################
 # Install all documentation files
 ######################################################################
 
-install-doc: install-doc-meta install-doc-html install-doc-printable
+.PHONY: install-doc install-doc-meta install-doc-html install-doc-printable install-doc-index-url
+
+install-doc: install-doc-meta install-doc-html install-doc-printable install-doc-index-url
 
 install-doc-meta:
 	$(MKDIR) $(FULLDOCDIR)
 	$(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc
 
-install-doc-html:
+install-doc-html: 
 	$(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib faq)
 	$(INSTALLLIB) doc/refman/html/* $(FULLDOCDIR)/html/refman 
 	$(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib 
@@ -270,7 +282,7 @@ install-doc-html:
 	$(INSTALLLIB) doc/faq/html/* $(FULLDOCDIR)/html/faq
 	$(INSTALLLIB) doc/tutorial/Tutorial.v.html $(FULLDOCDIR)/html/Tutorial.html
 
-install-doc-printable:
+install-doc-printable: 
 	$(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf
 	$(INSTALLLIB) doc/refman/Reference-Manual.pdf \
 		doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf
@@ -282,3 +294,13 @@ install-doc-printable:
 	$(INSTALLLIB) doc/tutorial/Tutorial.v.ps $(FULLDOCDIR)/ps/Tutorial.ps
 	$(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps
 	$(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps
+
+install-doc-index-url:
+	$(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf
+	$(INSTALLLIB) doc/refman/html/index_urls.txt \
+		$(FULLDOCDIR)/html/refman 
+
+# For emacs:
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/Makefile.stage2 b/Makefile.stage2
index 6fe020be..8f3d4e8b 100644
--- a/Makefile.stage2
+++ b/Makefile.stage2
@@ -7,12 +7,19 @@
 #######################################################################
 
 include Makefile.stage1
+include Makefile.doc
 
+-include $(MLLIBFILES:.mllib=.mllib.d)
+.SECONDARY: $(MLLIBFILES:.mllib=.mllib.d)
+-include $(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml.d))
+.SECONDARY: $(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml.d))
 -include $(ML4FILES:.ml4=.ml4.ml.d)
 .SECONDARY: $(ML4FILES:.ml4=.ml4.ml.d)
+-include $(VFILES:.v=.v.d)
+.SECONDARY: $(VFILES:.v=.v.d)
 
 .PHONY: stage2
-stage2: $(COQDEP)
+stage2: world
 
 # For emacs: 
 # Local Variables: 
diff --git a/Makefile.stage3 b/Makefile.stage3
deleted file mode 100644
index 1bd336d2..00000000
--- a/Makefile.stage3
+++ /dev/null
@@ -1,21 +0,0 @@
-#######################################################################
-#  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       #
-#######################################################################
-
-include Makefile.stage2
-include Makefile.doc
-
--include $(VFILES:.v=.v.d)
-.SECONDARY: $(VFILES:.v=.v.d)
-
-.PHONY: stage3
-stage3: world
-
-# For emacs: 
-# Local Variables: 
-# mode: makefile 
-# End:
diff --git a/README b/README
index 5cf88c1d..4f4afa5b 100644
--- a/README
+++ b/README
@@ -1,6 +1,6 @@
 
-            		THE COQ V8.2 SYSTEM
-            		===================
+               	         THE COQ V8 SYSTEM
+            	         =================
 
 INSTALLATION.
 =============
@@ -11,8 +11,9 @@ INSTALLATION.
 DOCUMENTATION.
 ==============
 
-   The documentation of Coq V8.2 is available online from the Coq web
-   site (see http://coq.inria.fr)
+   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.
@@ -26,9 +27,8 @@ CHANGES.
 AVAILABILITY.
 =============
 
-   Coq is available as a precompiled package from the major linux
-   distributions. It is also available for Windows and Mac OS systems
-   from the Coq web site (see http://coq.inria.fr).
+   Coq is available at http://coq.inria.fr, or, for older versions at
+   ftp://ftp.inria.fr/INRIA/LogiCal/coq.
 
 
 THE COQ CLUB.
diff --git a/README.win b/README.win
index da1a456c..7e0d2110 100644
--- a/README.win
+++ b/README.win
@@ -1,7 +1,7 @@
-THE COQ V8.2 SYSTEM
-===================
+THE COQ V8 SYSTEM
+=================
 
-    This file contains remarks specific to the Windows port of Coq.
+    This file contains remarks specific to the windows port of Coq.
 
 INSTALLATION.
 =============
@@ -16,19 +16,12 @@ default).
 COMPILATION.
 ============
 
-    If you want to install Coq, you had better transfer the precompiled
+    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 OCaml for Windows (MinGW port), preferably version 3.11.0.
+    1- Install ocaml for Windows (MinGW port), preferably version 3.09.3.
        See: http://caml.inria.fr
-     
-       If you choose OCaml 3.11.0, you also need to install FlexDLL.
-       See: http://alain.frisch.fr/flexdll.html    
-  
-       As shell script really dislikes space character within file
-       names, we strongly advise you to install OCaml to a path not
-       containing spaces, like 'C:\OCaml'
 
     2- Install a shell environment with at least:
          - a C compiler (gcc),
@@ -38,22 +31,19 @@ COMPILATION.
        (official packages are made using Cygwin) See:
        http://www.cygwin.com
 
-    3- If using OCaml version >= 3.10.0, you have to install Camlp5.
-       See http://pauillac.inria.fr/~ddr/camlp5/
-
-    4- In order to compile Coqide, you will need the LablGTK library
+    3- In order to compile Coqide, you will need the LablGTK library
        See: http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html
 
        You also need to install the GTK libraries for Windows (see the
        installation instruction for LablGTK)
 
-    5- In a shell window, type successively
+    4- In a shell window, type successively
 
         ./configure
         make world
         make install
 
-    6- Though not nescessary, you can find useful:
+    5- Though not nescessary, you can find useful:
          - Windows version of (X)Emacs: it is a powerful environment for
            developpers with coloured syntax, modes for compilation and debug,
            and many more. It is free. See: http://www.gnu.org/software.
diff --git a/TODO b/TODO
new file mode 100644
index 00000000..d6891e5f
--- /dev/null
+++ b/TODO
@@ -0,0 +1,53 @@
+Langage:
+
+Distribution:
+
+Environnement:
+
+- Porter SearchIsos
+
+Noyau:
+
+Tactic:
+
+- Que contradiction raisonne a isomorphisme pres de False
+
+Vernac:
+
+- Print / Print Proof en fait identiques ; Print ne devrait pas afficher
+  les constantes opaques (devrait afficher qqchose comme <opaque>)
+
+Theories:
+
+- Rendre transparent tous les theoremes prouvant {A}+{B}
+- Faire demarrer PolyList.nth a` l'indice 0 
+  Renommer l'actuel nth en nth1 ??
+
+Doc:
+
+- Mettre à jour les messages d'erreurs de Discriminate/Simplify_eq/Injection
+- Documenter le filtrage sur les types inductifs avec let-ins (dont la
+  compatibilite V6)
+
+- Ajouter let dans les règles du CIC
+  -> FAIT, mais reste a documenter le let dans les inductifs
+  et les champs manifestes dans les Record   
+- revoir le chapitre sur les tactiques utilisateur 
+- faut-il mieux spécifier la sémantique de Simpl (??)
+
+- Préciser la clarification syntaxique de IntroPattern
+- preciser que Goal vient en dernier dans une clause pattern list et
+  qu'il doit apparaitre si il y a un "in"
+
+- Omega Time debranche mais Omega System et Omega Action remarchent ?
+- Ajout "Replace in" (mais TODO)
+- Syntaxe Conditional tac Rewrite marche, à documenter
+- Documenter Dependent Rewrite et CutRewrite ?
+- Ajouter les motifs sous-termes de ltac
+
+- ajouter doc de GenFixpoint (mais avant: changer syntaxe) (J. Forest ou Pierre C.)
+- mettre à jour la doc de induction (arguments multiples) (Pierre C.)
+- mettre à jour la doc de functional induction/scheme (J. Forest ou Pierre C.)
+--> mettre à jour le CHANGES (vers la ligne 72)
+
+
diff --git a/_tags b/_tags
new file mode 100644
index 00000000..d236caee
--- /dev/null
+++ b/_tags
@@ -0,0 +1,84 @@
+
+## tags for binaries
+
+<scripts/coqmktop.{native,byte}> : use_str, use_unix, use_gramlib
+<scripts/coqc.{native,byte}> : use_unix, use_gramlib
+<tools/coqdep_boot.{native,byte}> : use_unix
+<tools/coqdep.{native,byte}> : use_unix, use_gramlib
+<tools/coq_tex.{native,byte}> : use_str
+<tools/coq_makefile.{native,byte}> : use_str
+<tools/coqdoc/main.{native,byte}> : use_str
+<checker/main.{native,byte}> : use_str, use_unix, use_gramlib
+<plugins/micromega/csdpcert.{native,byte}> : use_nums, use_unix
+
+## tags for ide
+
+<ide/**/*.{ml,mli}>: thread, ide
+
+## tags for grammar.cm*
+
+<parsing/grammar.{cma,cmxa}> : use_unix
+
+## tags for camlp4 files 
+
+<**/*.ml4>: is_ml4
+
+"toplevel/mltop.ml4": is_mltop, use_macro
+
+"parsing/lexer.ml4": use_macro
+"lib/compat.ml4": use_macro
+"lib/refutpat.ml4": use_extend, use_MLast
+"parsing/g_xml.ml4": use_extend
+"parsing/q_constr.ml4": use_extend, use_MLast
+"parsing/argextend.ml4": use_extend, use_MLast
+"parsing/tacextend.ml4": use_extend, use_MLast
+"parsing/g_prim.ml4": use_extend
+"parsing/g_ltac.ml4": use_extend
+"parsing/pcoq.ml4": use_extend, use_macro
+"parsing/q_util.ml4": use_MLast
+"parsing/vernacextend.ml4": use_extend, use_MLast
+"parsing/g_constr.ml4": use_extend
+"parsing/g_tactic.ml4": use_extend
+"parsing/g_proofs.ml4": use_extend
+"parsing/q_coqast.ml4": use_MLast, use_macro
+
+"toplevel/whelp.ml4": use_grammar
+"parsing/g_vernac.ml4": use_grammar, use_extend
+"parsing/g_decl_mode.ml4": use_grammar, use_extend, use_MLast
+"tactics/extraargs.ml4": use_grammar
+"tactics/extratactics.ml4": use_grammar
+"tactics/class_tactics.ml4": use_grammar
+"tactics/eauto.ml4": use_grammar
+"tactics/tauto.ml4": use_grammar
+"tactics/eqdecide.ml4": use_grammar
+"tactics/hipattern.ml4": use_grammar, use_constr
+"tactics/rewrite.ml4": use_grammar
+
+<plugins/**/*.ml4>: use_grammar
+
+## 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
+"kernel": include
+"kernel/byterun": include
+"lib": include
+"library": include
+"parsing": include
+"plugins": include
+"pretyping": include
+"proofs": include
+"scripts": include
+"states": include
+"tactics": include
+"theories": include
+"tools": include
+"tools/coqdoc": include
+"toplevel": include
+
+<plugins/**>: include
\ No newline at end of file
diff --git a/build b/build
new file mode 100755
index 00000000..69b47239
--- /dev/null
+++ b/build
@@ -0,0 +1,32 @@
+#!/bin/sh
+
+FLAGS=
+OCAMLBUILD=ocamlbuild
+CFG=config/coq_config.ml
+MYCFG=myocamlbuild_config.ml
+
+check_config() {
+ [ -f $CFG ] || (echo "please run ./configure first"; exit 1)
+ [ -L $MYCFG ] || ln -sf $CFG $MYCFG
+}
+
+ocb() { $OCAMLBUILD $FLAGS $*; }
+
+rule() {
+  check_config
+  case $1 in
+    clean)  ocb -clean && rm -rf bin/* && rm -f $MYCFG;;
+    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 82df62b4..b2aa6555 100644
--- a/checker/check.ml
+++ b/checker/check.ml
@@ -24,10 +24,10 @@ type section_path = {
   basename : string }
 let dir_of_path p =
   make_dirpath (List.map id_of_string p.dirpath)
-let path_of_dirpath dir = 
+let path_of_dirpath dir =
   match repr_dirpath dir with
       [] -> failwith "path_of_dirpath"
-    | l::dir -> 
+    | l::dir ->
         {dirpath=List.map string_of_id dir;basename=string_of_id l}
 let pr_dirlist dp =
   prlist_with_sep (fun _ -> str".") str (List.rev dp)
@@ -40,7 +40,7 @@ type library_objects
 
 type compilation_unit_name = dir_path
 
-type library_disk = { 
+type library_disk = {
   md_name : compilation_unit_name;
   md_compiled : Safe_typing.compiled_library;
   md_objects : library_objects;
@@ -48,7 +48,7 @@ type library_disk = {
   md_imports : compilation_unit_name list }
 
 (************************************************************************)
-(*s Modules on disk contain the following informations (after the magic 
+(*s Modules on disk contain the following informations (after the magic
     number, and before the digest). *)
 
 (*s Modules loaded in memory contain the following informations. They are
@@ -61,7 +61,7 @@ type library_t = {
   library_deps : (compilation_unit_name * Digest.t) list;
   library_digest : Digest.t }
 
-module LibraryOrdered = 
+module LibraryOrdered =
   struct
     type t = dir_path
     let compare d1 d2 =
@@ -121,7 +121,7 @@ let load_paths = ref ([],[] : System.physical_path list * logical_path list)
 let get_load_paths () = fst !load_paths
 
 (* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p = 
+let rec remove_path_dot p =
   let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
   let n = String.length curdir in
   if String.length p > n && String.sub p 0 n = curdir then
@@ -139,7 +139,7 @@ let strip_path p =
 
 let canonical_path_name p =
   let current = Sys.getcwd () in
-  try 
+  try
     Sys.chdir p;
     let p' = Sys.getcwd () in
     Sys.chdir current;
@@ -148,7 +148,7 @@ let canonical_path_name p =
     (* We give up to find a canonical name and just simplify it... *)
     strip_path p
 
-let find_logical_path phys_dir = 
+let find_logical_path phys_dir =
   let phys_dir = canonical_path_name phys_dir in
   match list_filter2 (fun p d -> p = phys_dir) !load_paths with
   | _,[dir] -> dir
@@ -159,7 +159,7 @@ let is_in_load_paths phys_dir =
   let dir = canonical_path_name phys_dir in
   let lp = get_load_paths () in
   let check_p = fun p -> (String.compare dir p) == 0 in
-    List.exists check_p lp 
+    List.exists check_p lp
 
 let remove_load_path dir =
   load_paths := list_filter2 (fun p d -> p <> dir) !load_paths
@@ -171,7 +171,7 @@ let add_load_path (phys_path,coq_path) =
   let phys_path = canonical_path_name phys_path in
     match list_filter2 (fun p d -> p = phys_path) !load_paths with
       | _,[dir] ->
-	  if coq_path <> dir 
+	  if coq_path <> dir
             (* If this is not the default -I . to coqtop *)
             && not
             (phys_path = canonical_path_name Filename.current_dir_name
@@ -195,7 +195,7 @@ let physical_paths (dp,lp) = dp
 
 let load_paths_of_dir_path dir =
   fst (list_filter2 (fun p d -> d = dir) !load_paths)
-    
+
 let get_full_load_paths () = List.combine (fst !load_paths) (snd !load_paths)
 
 (************************************************************************)
@@ -235,8 +235,8 @@ let locate_qualified_library qid =
     let dir =
       extend_dirpath (find_logical_path path) (id_of_string qid.basename) in
     (* Look if loaded *)
-    try 
-      (dir, library_full_filename dir)      
+    try
+      (dir, library_full_filename dir)
     with Not_found ->
       (dir, file)
   with Not_found -> raise LibNotFound
@@ -245,7 +245,7 @@ let explain_locate_library_error qid = function
   | LibUnmappedDir ->
       let prefix = qid.dirpath in
       errorlabstrm "load_absolute_library_from"
-      (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ 
+      (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++
       str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ())
   | LibNotFound ->
       errorlabstrm "load_absolute_library_from"
@@ -261,7 +261,7 @@ let try_locate_absolute_library dir =
 let try_locate_qualified_library qid =
   try
     locate_qualified_library qid
-  with e -> 
+  with e ->
     explain_locate_library_error qid e
 
 (************************************************************************)
@@ -300,7 +300,7 @@ let depgraph = ref LibraryMap.empty
 
 let intern_from_file (dir, f) =
   Flags.if_verbose msg (str"[intern "++str f++str" ...");
-  let (md,digest) = 
+  let (md,digest) =
     try
       let ch = with_magic_number_check raw_intern_library f in
       let (md:library_disk) = System.marshal_in ch in
@@ -312,7 +312,7 @@ let intern_from_file (dir, f) =
       Flags.if_verbose msgnl(str" done]");
       md,digest
     with e -> Flags.if_verbose msgnl(str" failed!]"); raise e in
-  depgraph := LibraryMap.add md.md_name md.md_deps !depgraph; 
+  depgraph := LibraryMap.add md.md_name md.md_deps !depgraph;
   mk_library md f digest
 
 let get_deps (dir, f) =
@@ -366,7 +366,7 @@ let recheck_library ~norec ~admit ~check =
   let nochk = fold_deps_list LibrarySet.add nrl LibrarySet.empty in
   let nochk = fold_deps_list LibrarySet.remove ml nochk in
   let nochk = fold_deps_list LibrarySet.add al nochk in
-  (* explicitely required modules cannot be skipped... *)
+  (* explicitly required modules cannot be skipped... *)
   let nochk =
     List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in
   (* *)
diff --git a/checker/check.mllib b/checker/check.mllib
new file mode 100644
index 00000000..08dd78bc
--- /dev/null
+++ b/checker/check.mllib
@@ -0,0 +1,34 @@
+Coq_config
+Pp_control
+Pp
+Compat
+Flags
+Segmenttree
+Unicodetable
+Util
+Option
+Hashcons
+System
+Envars
+Predicate
+Rtree
+Names
+Univ
+Esubst
+Validate
+Term
+Declarations
+Environ
+Closure
+Reduction
+Type_errors
+Modops
+Inductive
+Typeops
+Indtypes
+Subtyping
+Mod_checking
+Safe_typing
+Check
+Check_stat
+Checker
diff --git a/checker/check_stat.ml b/checker/check_stat.ml
index 6ea153a3..170ac638 100644
--- a/checker/check_stat.ml
+++ b/checker/check_stat.ml
@@ -17,7 +17,7 @@ open Environ
 
 let memory_stat = ref false
 
-let print_memory_stat () = 
+let print_memory_stat () =
   if !memory_stat then begin
     Format.printf "total heap size = %d kbytes\n" (heap_size_kb ());
     Format.print_newline();
@@ -33,11 +33,11 @@ let pr_engt = function
       str "Theory: Set is predicative"
 
 let cst_filter f csts =
-  Cmap.fold
+  Cmap_env.fold
     (fun c ce acc -> if f c ce then c::acc else acc)
     csts []
 
-let is_ax _ cb = cb.const_body = None 
+let is_ax _ cb = cb.const_body = None
 
 let pr_ax csts =
   let axs = cst_filter is_ax csts in
diff --git a/checker/checker.ml b/checker/checker.ml
index 70e2eb97..e15c37e6 100644
--- a/checker/checker.ml
+++ b/checker/checker.ml
@@ -23,14 +23,14 @@ let parse_dir s =
     if n>=len then dirs else
     let pos =
       try
-	String.index_from s n '.' 
+	String.index_from s n '.'
       with Not_found -> len
     in
     let dir = String.sub s n (pos-n) in
-      decoupe_dirs (dir::dirs) (pos+1)	  
+      decoupe_dirs (dir::dirs) (pos+1)
   in
     decoupe_dirs [] 0
-let dirpath_of_string s = 
+let dirpath_of_string s =
   match parse_dir s with
       [] -> invalid_arg "dirpath_of_string"
     | dir -> make_dirpath (List.map id_of_string dir)
@@ -43,7 +43,7 @@ let (/) = Filename.concat
 
 let get_version_date () =
   try
-    let coqlib = Envars.coqlib () in 
+    let coqlib = Envars.coqlib () in
     let ch = open_in (Filename.concat coqlib "revision") in
     let ver = input_line ch in
     let rev = input_line ch in
@@ -67,8 +67,8 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath =
 
 let convert_string d =
   try id_of_string d
-  with _ -> 
-    if_verbose warning 
+  with _ ->
+    if_verbose warning
       ("Directory "^d^" cannot be used as a Coq identifier (skipped)");
     flush_all ();
     failwith "caught"
@@ -90,45 +90,38 @@ let includes = ref []
 let push_include (s, alias) = includes := (s,alias,false) :: !includes
 let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
 
-let check_coq_overwriting p = 
-  if string_of_id (list_last (repr_dirpath p)) = "Coq" then
-    error "The \"Coq\" logical root directory is reserved for the Coq library"
-
 let set_default_include d =
   push_include (d, Check.default_root_prefix)
 let set_default_rec_include d =
   let p = Check.default_root_prefix in
-  check_coq_overwriting p; 
   push_rec_include (d, p)
 let set_include d p =
   let p = dirpath_of_string p in
-  check_coq_overwriting p;
   push_include (d,p)
 let set_rec_include d p =
   let p = dirpath_of_string p in
-  check_coq_overwriting p;
   push_rec_include(d,p)
 
 (* Initializes the LoadPath *)
 let init_load_path () =
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
-  let contrib = coqlib/"contrib" in
+  let plugins = coqlib/"plugins" in
   (* first user-contrib *)
-  if Sys.file_exists user_contrib then 
+  if Sys.file_exists user_contrib then
     add_rec_path user_contrib Check.default_root_prefix;
-  (* then contrib *)
-  add_rec_path contrib (Names.make_dirpath [coq_root]);
+  (* then plugins *)
+  add_rec_path plugins (Names.make_dirpath [coq_root]);
   (* then standard library *)
-(*  List.iter 
+(*  List.iter
     (fun (s,alias) ->
-      add_rec_path (coqlib/s) ([alias; coq_root])) 
+      add_rec_path (coqlib/s) ([alias; coq_root]))
     theories_dirs_map;*)
   add_rec_path (coqlib/"theories") (Names.make_dirpath[coq_root]);
   (* then current directory *)
   add_path "." Check.default_root_prefix;
   (* additional loadpath, given with -I -include -R options *)
-  List.iter 
+  List.iter
     (fun (s,alias,reci) ->
       if reci then add_rec_path s alias else add_path s alias)
     (List.rev !includes);
@@ -163,7 +156,7 @@ let compile_files () =
   Check.recheck_library
     ~norec:(List.rev !norec_list)
     ~admit:(List.rev !admit_list)
-    ~check:(List.rev !compile_list) 
+    ~check:(List.rev !compile_list)
 
 let version () =
   Printf.printf "The Coq Proof Checker, version %s (%s)\n"
@@ -180,7 +173,7 @@ let print_usage_channel co command =
 "  -I dir -as coqdir      map physical dir to logical coqdir
   -I dir                 map directory dir to the empty logical path
   -include dir           (idem)
-  -R dir -as coqdir      recursively map physical dir to logical coqdir 
+  -R dir -as coqdir      recursively map physical dir to logical coqdir
   -R dir coqdir          (idem)
 
   -admit module          load module and dependencies without checking
@@ -189,9 +182,10 @@ let print_usage_channel co command =
   -where                 print Coq's standard library location and exit
   -v                     print Coq version and exit
   -boot                  boot mode
-  -o                     print the list of assumptions
-  -m                     print the maximum heap size
- 
+  -o, --output-context   print the list of assumptions
+  -m, --memoty           print the maximum heap size
+  -silent                disable trace of constants being checked
+
   -impredicative-set     set sort Set impredicative
 
   -h, --help             print this list of options
@@ -217,9 +211,9 @@ let anomaly_string () = str "Anomaly: "
 let report () = (str "." ++ spc () ++ str "Please report.")
 
 let print_loc loc =
-  if loc = dummy_loc then 
+  if loc = dummy_loc then
     (str"<unknown>")
-  else 
+  else
     let loc = unloc loc in
     (int (fst loc) ++ str"-" ++ int (snd loc))
 let guill s = "\""^s^"\""
@@ -228,41 +222,41 @@ let where s =
   if !Flags.debug then  (str"in " ++ str s ++ str":" ++ spc ()) else (mt ())
 
 let rec explain_exn = function
-  | Stream.Failure -> 
+  | Stream.Failure ->
       hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.")
-  | Stream.Error txt -> 
+  | Stream.Error txt ->
       hov 0 (str "Syntax error: " ++ str txt)
-  | Token.Error txt -> 
+  | Token.Error txt ->
       hov 0 (str "Syntax error: " ++ str txt)
-  | Sys_error msg -> 
+  | Sys_error msg ->
       hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report() )
-  | UserError(s,pps) -> 
+  | UserError(s,pps) ->
       hov 1 (str "User error: " ++ where s ++ pps)
-  | Out_of_memory -> 
+  | Out_of_memory ->
       hov 0 (str "Out of memory")
-  | Stack_overflow -> 
+  | Stack_overflow ->
       hov 0 (str "Stack overflow")
-  | Anomaly (s,pps) -> 
+  | Anomaly (s,pps) ->
       hov 1 (anomaly_string () ++ where s ++ pps ++ report ())
   | Match_failure(filename,pos1,pos2) ->
-      hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ 
+      hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++
       if Sys.ocaml_version = "3.06" then
-		   (str " from character " ++ int pos1 ++ 
+		   (str " from character " ++ int pos1 ++
                     str " to " ++ int pos2)
 		 else
 		   (str " at line " ++ int pos1 ++
 		    str " character " ++ int pos2)
 	           ++ report ())
-  | Not_found -> 
+  | Not_found ->
       hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ())
-  | Failure s -> 
+  | Failure s ->
       hov 0 (str "Failure: " ++ str s ++ report ())
-  | Invalid_argument s -> 
+  | Invalid_argument s ->
       hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report ())
-  | Sys.Break -> 
+  | Sys.Break ->
       hov 0 (fnl () ++ str "User interrupt.")
   | Univ.UniverseInconsistency (o,u,v) ->
-      let msg = 
+      let msg =
 	if !Flags.debug (*!Constrextern.print_universes*) then
 	  spc() ++ str "(cannot enforce" ++ spc() ++ (*Univ.pr_uni u ++*) spc() ++
           str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=")
@@ -270,12 +264,12 @@ let rec explain_exn = function
 	else
 	  mt() in
       hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".")
-  | TypeError(ctx,te) -> 
+  | TypeError(ctx,te) ->
 (*      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx *)
       (*      te)*)
       hov 0 (str "Type error")
 
-  | Indtypes.InductiveError e -> 
+  | Indtypes.InductiveError e ->
       hov 0 (str "Error related to inductive types")
 (*      let ctx = Check.get_env() in
       hov 0
@@ -286,9 +280,9 @@ let rec explain_exn = function
                ++ explain_exn exc)
   | Assert_failure (s,b,e) ->
       hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++
-	       (if s <> "" then 
+	       (if s <> "" then
 		 if Sys.ocaml_version = "3.06" then
-		   (str ("(file \"" ^ s ^ "\", characters ") ++ 
+		   (str ("(file \"" ^ s ^ "\", characters ") ++
 		    int b ++ str "-" ++ int e ++ str ")")
 		 else
 		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
@@ -298,13 +292,13 @@ let rec explain_exn = function
 		 (mt ())) ++
 	       report ())
   | reraise ->
-      hov 0 (anomaly_string () ++ str "Uncaught exception " ++ 
+      hov 0 (anomaly_string () ++ str "Uncaught exception " ++
 	       str (Printexc.to_string reraise)++report())
 
-let parse_args() =
+let parse_args argv =
   let rec parse = function
     | [] -> ()
-   | "-impredicative-set" :: rem -> 
+   | "-impredicative-set" :: rem ->
        set_engagement Declarations.ImpredicativeSet; parse rem
 
     | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem
@@ -325,7 +319,7 @@ let parse_args() =
     | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
 
     | ("-v"|"--version") :: _ -> version ()
-    | "-boot" :: rem -> boot := true; parse rem	
+    | "-boot" :: rem -> boot := true; parse rem
     | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem
     | ("-o" | "--output-context") :: rem ->
         Check_stat.output_context := true; parse rem
@@ -346,8 +340,8 @@ let parse_args() =
     | s :: rem ->  add_compile s; parse rem
   in
   try
-    parse (List.tl (Array.to_list Sys.argv))
-  with 
+    parse (List.tl (Array.to_list argv))
+  with
     | UserError(_,s) as e -> begin
 	try
 	  Stream.empty s; exit 1
@@ -360,12 +354,12 @@ let parse_args() =
 (* To prevent from doing the initialization twice *)
 let initialized = ref false
 
-let init() =
+let init_with_argv argv =
   if not !initialized then begin
     initialized := true;
     Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
     try
-      parse_args();
+      parse_args argv;
       if_verbose print_header ();
       init_load_path ();
       engage ();
@@ -376,13 +370,15 @@ let init() =
       exit 1
   end
 
+let init() = init_with_argv Sys.argv
+
 let run () =
-  try 
+  try
     compile_files ();
     flush_all()
   with e ->
     (Pp.ppnl(explain_exn e);
-    flush_all(); 
+    flush_all();
     exit 1)
 
 let start () = init(); run(); Check_stat.stats(); exit 0
diff --git a/checker/closure.ml b/checker/closure.ml
index ccbfbc4c..7ccf06b9 100644
--- a/checker/closure.ml
+++ b/checker/closure.ml
@@ -38,7 +38,7 @@ let incr_cnt red cnt =
   if red then begin
     if !stats then incr cnt;
     true
-  end else 
+  end else
     false
 
 let with_stats c =
@@ -127,13 +127,13 @@ module RedFlags = (struct
 	{ red with r_const = Idpred.remove id l1, l2 }
 
   let red_add_transparent red tr =
-    { red with r_const = tr } 
+    { red with r_const = tr }
 
   let mkflags = List.fold_left red_add no_red
 
   let red_set red = function
     | BETA -> incr_cnt red.r_beta beta
-    | CONST kn -> 
+    | CONST kn ->
 	let (_,l) = red.r_const in
 	let c = Cpred.mem kn l in
 	incr_cnt c delta
@@ -165,7 +165,7 @@ let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
 let betaiota = mkflags [fBETA;fIOTA]
 let beta = mkflags [fBETA]
 let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
-let unfold_red kn = 
+let unfold_red kn =
   let flag = match kn with
     | EvalVarRef id -> fVAR id
     | EvalConstRef kn -> fCONST kn
@@ -187,7 +187,7 @@ let betadeltaiota_red = {
   r_const = true,[],[];
   r_zeta = true;
   r_evar = true;
-  r_iota = true } 
+  r_iota = true }
 
 let betaiota_red = {
   r_beta = true;
@@ -195,7 +195,7 @@ let betaiota_red = {
   r_zeta = false;
   r_evar = false;
   r_iota = true }
-		     
+
 let beta_red = {
   r_beta = true;
   r_const = false,[],[];
@@ -231,7 +231,7 @@ let unfold_red kn =
 (* Sets of reduction kinds.
    Main rule: delta implies all consts (both global (= by
    kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's).
-   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
    a LetIn expression is Letin reduction *)
 
 type red_kind =
@@ -278,7 +278,7 @@ let red_local_const = red_delta_set
 (* to know if a redex is allowed, only a subset of red_kind is used ... *)
 let red_set red = function
   | BETA -> incr_cnt red.r_beta beta
-  | CONST [kn] -> 
+  | CONST [kn] ->
       let (b,l,_) = red.r_const in
       let c = List.mem kn l in
       incr_cnt ((b & not c) or (c & not b)) delta
@@ -339,7 +339,7 @@ type 'a infos = {
 let info_flags info = info.i_flags
 
 let ref_value_cache info ref =
-  try  
+  try
     Some (Hashtbl.find info.i_tab ref)
   with Not_found ->
   try
@@ -360,7 +360,7 @@ let ref_value_cache info ref =
 
 let defined_vars flags env =
 (*  if red_local_const (snd flags) then*)
-    fold_named_context 
+    fold_named_context
       (fun (id,b,_) e ->
 	 match b with
 	   | None -> e
@@ -370,7 +370,7 @@ let defined_vars flags env =
 
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
-  fold_rel_context 
+  fold_rel_context
       (fun (id,b,t) (i,subs) ->
 	 match b with
 	   | None -> (i+1, subs)
@@ -380,6 +380,11 @@ let defined_rels flags env =
 
 let mind_equiv_infos info = mind_equiv info.i_env
 
+let eq_table_key k1 k2 = 
+ match k1,k2 with
+   | ConstKey con1 ,ConstKey con2 -> eq_con_chk con1 con2
+   | _,_  -> k1=k2
+
 let create mk_cl flgs env =
   { i_flags = flgs;
     i_repr = mk_cl;
@@ -417,8 +422,8 @@ let neutr = function
   | (Whnf|Norm) -> Whnf
   | (Red|Cstr) -> Red
 
-type fconstr = { 
-  mutable norm: red_state; 
+type fconstr = {
+  mutable norm: red_state;
   mutable term: fterm }
 
 and fterm =
@@ -456,7 +461,7 @@ let update v1 (no,t) =
   else {norm=no;term=t}
 
 (**********************************************************************)
-(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *)
 
 type stack_member =
   | Zapp of fconstr array
@@ -496,9 +501,6 @@ let rec decomp_stack = function
         | _ ->
             Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s)))
   | _ -> None
-let rec decomp_stackn = function
-  | Zapp v :: s -> if Array.length v = 0 then decomp_stackn s else (v, s)
-  | _ -> assert false
 let array_of_stack s =
   let rec stackrec = function
   | [] -> []
@@ -507,7 +509,7 @@ let array_of_stack s =
   in Array.concat (stackrec s)
 let rec stack_assign s p c = match s with
   | Zapp args :: s ->
-      let q = Array.length args in 
+      let q = Array.length args in
       if p >= q then
 	Zapp args :: stack_assign s (p-q) c
       else
@@ -515,7 +517,7 @@ let rec stack_assign s p c = match s with
          nargs.(p) <- c;
          Zapp nargs :: s)
   | _ -> s
-let rec stack_tail p s = 
+let rec stack_tail p s =
   if p = 0 then s else
     match s with
       | Zapp args :: s ->
@@ -547,8 +549,6 @@ let lift_fconstr k f =
   if k=0 then f else lft_fconstr k f
 let lift_fconstr_vect k v =
   if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
-let lift_fconstr_list k l =
-  if k=0 then l else List.map (fun f -> lft_fconstr k f) l
 
 let clos_rel e i =
   match expand_rel i e with
@@ -780,7 +780,7 @@ let term_of_fconstr =
 
 (* fstrong applies unfreeze_fun recursively on the (freeze) term and
  * yields a term.  Assumes that the unfreeze_fun never returns a
- * FCLOS term. 
+ * FCLOS term.
 let rec fstrong unfreeze_fun lfts v =
   to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
 *)
@@ -857,12 +857,6 @@ let get_nth_arg head n stk =
 
 (* Beta reduction: look for an applied argument in the stack.
    Since the encountered update marks are removed, h must be a whnf *)
-let get_arg h stk =
-  let (depth,stk') = strip_update_shift h stk in
-  match  decomp_stack stk' with
-      Some (v, s') -> (Some (depth,v), s')
-    | None -> (None, zshift depth stk')
-
 let rec get_args n tys f e stk =
   match stk with
       Zupdate r :: s ->
@@ -979,7 +973,7 @@ let rec knr info m stk =
   | FLambda(n,tys,f,e) when red_set info.i_flags fBETA ->
       (match get_args n tys f e stk with
           Inl e', s -> knit info e' f s
-        | Inr lam, s -> (lam,s)) 
+        | Inr lam, s -> (lam,s))
   | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) ->
       (match ref_value_cache info (ConstKey kn) with
           Some v -> kni info v stk
diff --git a/checker/closure.mli b/checker/closure.mli
index fa302de6..4d302add 100644
--- a/checker/closure.mli
+++ b/checker/closure.mli
@@ -24,7 +24,7 @@ val with_stats: 'a Lazy.t -> 'a
 
 (*s Delta implies all consts (both global (= by
   [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
-  Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+  Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
   a LetIn expression is Letin reduction *)
 
 type transparent_state = Idpred.t * Cpred.t
@@ -102,7 +102,7 @@ type fconstr
 type fterm =
   | FRel of int
   | FAtom of constr (* Metas and Sorts *)
-  | FCast of fconstr * cast_kind * fconstr 
+  | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
   | FInd of inductive
   | FConstruct of constructor
@@ -177,6 +177,7 @@ val unfold_reference : clos_infos -> table_key -> fconstr option
 (* [mind_equiv] checks whether two inductive types are intentionally equal *)
 val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool
 
+val eq_table_key : table_key -> table_key -> bool
 (************************************************************************)
 (*i This is for lazy debug *)
 
diff --git a/checker/declarations.ml b/checker/declarations.ml
index c6a7b4b4..699f6c90 100644
--- a/checker/declarations.ml
+++ b/checker/declarations.ml
@@ -30,356 +30,623 @@ let val_cst_type =
   val_sum "constant_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|]
 
 
-type substitution_domain = 
-    MSI of mod_self_id 
+type substitution_domain =
   | MBI of mod_bound_id
   | MPI of module_path
 
 let val_subst_dom =
-  val_sum "substitution_domain" 0 [|[|val_uid|];[|val_uid|];[|val_mp|]|]
+  val_sum "substitution_domain" 0 [|[|val_uid|];[|val_mp|]|]
 
-module Umap = Map.Make(struct 
+module Umap = Map.Make(struct
 			 type t = substitution_domain
 			 let compare = Pervasives.compare
 		       end)
 
-type resolver
 
-type substitution = (module_path * resolver option) Umap.t
+type delta_hint =
+    Inline of constr option
+  | Equiv of kernel_name
+  | Prefix_equiv of module_path
+
+type delta_key = 
+    KN of kernel_name
+  | MP of module_path
+
+module Deltamap =  Map.Make(struct 
+			      type t = delta_key
+			      let compare = Pervasives.compare
+			    end)
+
+type delta_resolver = delta_hint Deltamap.t
+
+let empty_delta_resolver = Deltamap.empty
+
+type substitution = (module_path * delta_resolver) Umap.t
 type 'a subst_fun = substitution -> 'a -> 'a
 
-let val_res = val_opt no_val
+let val_res_dom =
+  val_sum "delta_key" 0 [|[|val_kn|];[|val_mp|]|]
+
+let val_res =
+  val_map ~name:"delta_resolver"
+    val_res_dom  
+    (val_sum "delta_hint" 0 [|[|val_opt val_constr|];[|val_kn|];[|val_mp|]|])
 
 let val_subst =
   val_map ~name:"substitution"
     val_subst_dom (val_tuple "substition range" [|val_mp;val_res|])
 
 
-let fold_subst fs fb fp =
+let fold_subst fb fp =
   Umap.fold
     (fun k (mp,_) acc ->
       match k with
-          MSI msid -> fs msid mp acc
         | MBI mbid -> fb mbid mp acc
         | MPI mp1 -> fp mp1 mp acc)
 
 let empty_subst = Umap.empty
 
-let add_msid msid mp =
-  Umap.add (MSI msid) (mp,None)
 let add_mbid mbid mp =
-  Umap.add (MBI mbid) (mp,None)
+  Umap.add (MBI mbid) (mp,empty_delta_resolver)
 let add_mp mp1 mp2  =
-  Umap.add (MPI mp1) (mp2,None)
+  Umap.add (MPI mp1) (mp2,empty_delta_resolver)
 
-let map_msid msid mp = add_msid msid mp empty_subst
 let map_mbid mbid mp = add_mbid mbid mp empty_subst
 let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst
 
+let add_inline_delta_resolver con =
+  Deltamap.add (KN(user_con con)) (Inline None)
+    
+let add_inline_constr_delta_resolver con cstr =
+  Deltamap.add (KN(user_con con)) (Inline (Some cstr))
+
+let add_constant_delta_resolver con =
+  Deltamap.add (KN(user_con con)) (Equiv (canonical_con con))
+
+let add_mind_delta_resolver mind =
+  Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind))
+
+let add_mp_delta_resolver mp1 mp2 = 
+  Deltamap.add (MP mp1) (Prefix_equiv mp2)
+
+let mp_in_delta mp = 
+  Deltamap.mem (MP mp) 
+
+let con_in_delta con resolver = 
+try 
+  match Deltamap.find (KN(user_con con)) resolver with
+  | Inline _  | Prefix_equiv _ -> false
+  | Equiv _ -> true
+with
+ Not_found -> false
+
+let mind_in_delta mind resolver = 
+try 
+  match Deltamap.find (KN(user_mind mind)) resolver with
+  | Inline _  | Prefix_equiv _ -> false
+  | Equiv _ -> true
+with
+ Not_found -> false
+
+let delta_of_mp resolve mp =
+  try 
+    match Deltamap.find (MP mp) resolve with
+      | Prefix_equiv mp1 -> mp1
+      | _ -> anomaly "mod_subst: bad association in delta_resolver"
+  with
+      Not_found -> mp
+	
+let delta_of_kn resolve kn =
+  try 
+    match Deltamap.find (KN kn) resolve with
+      | Equiv kn1 -> kn1
+      | Inline _ -> kn
+      | _ -> anomaly 
+	  "mod_subst: bad association in delta_resolver"
+  with
+      Not_found -> kn
+
+let remove_mp_delta_resolver resolver mp =
+    Deltamap.remove (MP mp) resolver
+
+exception Inline_kn
+
+let rec find_prefix resolve mp = 
+  let rec sub_mp = function
+    | MPdot(mp,l) as mp_sup -> 
+	(try 
+	   match Deltamap.find (MP mp_sup) resolve with
+	     | Prefix_equiv mp1 -> mp1
+	     | _ -> anomaly 
+		 "mod_subst: bad association in delta_resolver"
+	 with
+	     Not_found -> MPdot(sub_mp mp,l))
+    | p -> 
+	match Deltamap.find (MP p) resolve with
+	  | Prefix_equiv mp1 -> mp1
+	  | _ -> anomaly 
+		 "mod_subst: bad association in delta_resolver"	
+  in
+    try 
+      sub_mp mp
+    with
+	Not_found -> mp
+	  
+let solve_delta_kn resolve kn =
+  try 
+      match Deltamap.find (KN kn) resolve with
+	| Equiv kn1 -> kn1
+	| Inline _ -> raise Inline_kn
+	| _ -> anomaly 
+	    "mod_subst: bad association in delta_resolver"
+  with
+      Not_found | Inline_kn -> 
+	let mp,dir,l = repr_kn kn in
+	let new_mp = find_prefix resolve mp in
+	  if mp == new_mp then 
+	    kn
+	  else
+	    make_kn new_mp dir l
+	      
+
+let constant_of_delta resolve con =
+  let kn = user_con con in
+  let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then
+      con
+    else
+      constant_of_kn_equiv kn new_kn
+	
+let constant_of_delta2 resolve con =
+  let kn = canonical_con con in
+  let kn1 = user_con con in
+  let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then
+      con
+    else
+      constant_of_kn_equiv kn1 new_kn
+
+let mind_of_delta resolve mind =
+  let kn = user_mind mind in
+  let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then
+      mind
+    else
+      mind_of_kn_equiv kn new_kn
+	
+let mind_of_delta2 resolve mind =
+  let kn = canonical_mind mind in
+  let kn1 = user_mind mind in
+  let new_kn = solve_delta_kn resolve kn in
+    if kn == new_kn then
+      mind
+    else
+      mind_of_kn_equiv kn1 new_kn
+
+
+
+let inline_of_delta resolver = 
+  let extract key hint l =
+    match key,hint with 
+      |KN kn, Inline _ -> kn::l
+      | _,_ -> l
+  in
+    Deltamap.fold extract resolver []
+
+exception Not_inline
+  
+let constant_of_delta_with_inline resolve con =
+  let kn1,kn2 = canonical_con con,user_con con in
+    try
+      match Deltamap.find (KN kn2) resolve with 
+	| Inline None -> None
+	| Inline (Some const) -> Some const
+	| _ -> raise Not_inline
+    with
+	Not_found | Not_inline -> 
+	  try match Deltamap.find (KN kn1) resolve with 
+	    | Inline None -> None
+	    | Inline (Some const) -> Some const
+	    | _ -> raise Not_inline
+	  with
+	      Not_found | Not_inline -> None
+
 let subst_mp0 sub mp = (* 's like subst *)
  let rec aux mp =
   match mp with
-    | MPself sid -> 
-        let mp',resolve = Umap.find (MSI sid) sub in
+    | MPfile sid -> 
+        let mp',resolve = Umap.find (MPI (MPfile sid)) sub in
          mp',resolve
     | MPbound bid ->
-        let mp',resolve = Umap.find (MBI bid) sub in
-          mp',resolve
+	begin
+	  try
+            let mp',resolve = Umap.find (MBI bid) sub in
+              mp',resolve
+	  with Not_found ->
+	    let mp',resolve = Umap.find (MPI mp) sub in
+              mp',resolve
+	end
     | MPdot (mp1,l) as mp2 ->
 	begin
-	  try  
+	  try
 	    let mp',resolve = Umap.find (MPI mp2) sub in
               mp',resolve
-	  with Not_found ->    
+	  with Not_found ->
 	    let mp1',resolve = aux mp1 in
 	      MPdot (mp1',l),resolve
 	end
-    | _ -> raise Not_found
  in
   try
-    Some (aux mp) 
+    Some (aux mp)
   with Not_found -> None
 
-
-
-let subst_mp0 sub mp = (* 's like subst *)
- let rec aux mp =
-  match mp with
-    | MPself sid -> fst (Umap.find (MSI sid) sub)
-    | MPbound bid -> fst (Umap.find (MBI bid) sub)
-    | MPdot (mp1,l) as mp2 ->
-	begin
-	  try fst (Umap.find (MPI mp2) sub)
-	  with Not_found -> MPdot (aux mp1,l)
-	end
-
-    | _ -> raise Not_found
- in
-  try Some (aux mp) with Not_found -> None
-
 let subst_mp sub mp =
  match subst_mp0 sub mp with
     None -> mp
-  | Some mp' -> mp'
+  | Some (mp',_) -> mp'
 
-let subst_kn0 sub kn =
+let subst_kn_delta sub kn =
  let mp,dir,l = repr_kn kn in
   match subst_mp0 sub mp with
-     Some mp' ->
-      Some (make_kn mp' dir l)
-   | None -> None
+     Some (mp',resolve) ->
+      solve_delta_kn resolve (make_kn mp' dir l)
+   | None -> kn
 
 let subst_kn sub kn =
- match subst_kn0 sub kn with
-    None -> kn
-  | Some kn' -> kn'
+ let mp,dir,l = repr_kn kn in
+  match subst_mp0 sub mp with
+     Some (mp',_) ->
+      make_kn mp' dir l
+   | None -> kn
+
+exception No_subst
+
+type sideconstantsubst =
+  | User
+  | Canonical
+
+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
+    try 
+      let side,mind',resolve =   
+        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_mind_equiv mp1' mp2' dir l), resolve2 
+      in
+	match side with
+	  |User ->
+	     let mind = mind_of_delta resolve mind' in
+	       mind
+	  |Canonical ->
+	     let mind = mind_of_delta2 resolve mind' in
+	       mind
+    with 
+	No_subst -> mind
+
+let subst_mind0 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
+    try 
+      let side,mind',resolve =   
+        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_mind_equiv mp1' mp2' dir l), resolve2
+      in
+	match side with
+	  |User ->
+	     let mind = mind_of_delta resolve mind' in
+	       Some mind
+	  |Canonical ->
+	     let mind = mind_of_delta2 resolve mind' in
+	       Some mind
+    with 
+	No_subst -> Some mind
 
 let subst_con sub con =
- let mp,dir,l = repr_con con in
-  match subst_mp0 sub mp with
-     None -> con
-   | Some mp' -> make_con mp' dir l
+  let kn1,kn2 = user_con con,canonical_con con in
+  let mp1,dir,l = repr_kn kn1 in
+  let mp2,_,_ = repr_kn kn2 in
+    try 
+      let side,con',resolve =   
+        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_con_equiv mp1' mp2' dir l), resolve2 
+      in
+	match constant_of_delta_with_inline resolve con' with
+            None -> begin
+	      match side with
+	      |User ->
+	      let con = constant_of_delta resolve con' in
+		con,Const con
+	      |Canonical ->
+		  let con = constant_of_delta2 resolve con' in
+		con,Const con
+	    end
+	  | Some t -> con',t
+    with No_subst -> con , Const con 
+ 
 
 let subst_con0 sub con =
- let mp,dir,l = repr_con con in
-  match subst_mp0 sub mp with
-      None -> None
-    | Some mp' ->
-	let con' = make_con mp' dir l in
-        Some (Const con')
+  let kn1,kn2 = user_con con,canonical_con con in
+  let mp1,dir,l = repr_kn kn1 in
+  let mp2,_,_ = repr_kn kn2 in
+    try  
+      let side,con',resolve =   
+	match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_con_equiv mp1' mp2' dir l), resolve2 
+      in
+	match constant_of_delta_with_inline resolve con' with
+	    None ->begin
+	      match side with
+	      |User ->
+	      let con = constant_of_delta resolve con' in
+		Some (Const con)
+	      |Canonical ->
+		  let con = constant_of_delta2 resolve con' in
+		Some (Const con)
+	    end
+	  | t ->  t
+    with No_subst -> Some (Const con)
 
-let rec map_kn f f' c = 
+
+let rec map_kn f f' c =
   let func = map_kn f f' in
     match c with
-      | Const kn -> 
+      | Const kn ->
 	  (match f' kn with
 	       None -> c
 	     | Some const ->const)
-      | Ind (kn,i) -> 
+      | Ind (kn,i) ->
          (match f kn with
              None -> c
            | Some kn' ->
 	      Ind (kn',i))
-      | Construct ((kn,i),j) -> 
+      | Construct ((kn,i),j) ->
          (match f kn with
              None -> c
            | Some kn' ->
 	       Construct ((kn',i),j))
-      | Case (ci,p,ct,l) -> 
+      | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
               (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
 	  let p' = func p in
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
-	    if (ci.ci_ind==ci_ind && p'==p 
+	    if (ci.ci_ind==ci_ind && p'==p
 		&& l'==l && ct'==ct)then c
-	    else 
+	    else
 	      Case ({ci with ci_ind = ci_ind},
-		     p',ct', l')  
-      | Cast (ct,k,t) -> 
+		     p',ct', l')
+      | Cast (ct,k,t) ->
 	  let ct' = func ct in
 	  let t'= func t in
-	    if (t'==t && ct'==ct) then c 
+	    if (t'==t && ct'==ct) then c
 	    else Cast (ct', k, t')
-      | Prod (na,t,ct) -> 
+      | Prod (na,t,ct) ->
 	  let ct' = func ct in
 	  let t'= func t in
-	    if (t'==t && ct'==ct) then c 
+	    if (t'==t && ct'==ct) then c
 	    else Prod (na, t', ct')
-      | Lambda (na,t,ct) -> 
+      | Lambda (na,t,ct) ->
 	  let ct' = func ct in
 	  let t'= func t in
-	    if (t'==t && ct'==ct) then c 
+	    if (t'==t && ct'==ct) then c
 	    else Lambda (na, t', ct')
-      | LetIn (na,b,t,ct) -> 
+      | LetIn (na,b,t,ct) ->
 	  let ct' = func ct in
 	  let t'= func t in
 	  let b'= func b in
-	    if (t'==t && ct'==ct && b==b') then c 
+	    if (t'==t && ct'==ct && b==b') then c
 	    else LetIn (na, b', t', ct')
-      | App (ct,l) -> 
+      | App (ct,l) ->
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
 	    if (ct'== ct && l'==l) then c
 	    else App (ct',l')
-      | Evar (e,l) -> 
+      | Evar (e,l) ->
 	  let l' = array_smartmap func l in
 	    if (l'==l) then c
 	    else Evar (e,l')
       | Fix (ln,(lna,tl,bl)) ->
 	  let tl' = array_smartmap func tl in
 	  let bl' = array_smartmap func bl in
-	    if (bl == bl'&& tl == tl') then c  
+	    if (bl == bl'&& tl == tl') then c
 	    else Fix (ln,(lna,tl',bl'))
       | CoFix(ln,(lna,tl,bl)) ->
 	  let tl' = array_smartmap func tl in
 	  let bl' = array_smartmap func bl in
-	    if (bl == bl'&& tl == tl') then c  
+	    if (bl == bl'&& tl == tl') then c
 	    else CoFix (ln,(lna,tl',bl'))
       | _ -> c
 
-let subst_mps sub = 
-  map_kn (subst_kn0 sub) (subst_con0 sub)
+let subst_mps sub =
+  map_kn (subst_mind0 sub) (subst_con0 sub)
+
+
+type 'a lazy_subst =
+  | LSval of 'a
+  | LSlazy of substitution list * 'a
+
+type 'a substituted = 'a lazy_subst ref
+
+let val_substituted val_a =
+  val_ref
+    (val_sum "constr_substituted" 0
+      [|[|val_a|];[|val_list val_subst;val_a|]|])
 
+let from_val a = ref (LSval a)
+ 
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
     | _ when mp = mpfrom -> mpto
-    | MPdot (mp1,l) -> 
+    | MPdot (mp1,l) ->
 	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
 	  if mp1==mp1' then mp
 	  else MPdot (mp1',l)
     | _ -> mp
 
-let replace_mp_in_con mpfrom mpto kn =
- let mp,dir,l = kn in
-  let mp'' = replace_mp_in_mp mpfrom mpto mp in
-    if mp==mp'' then kn
-    else (mp'', dir, l)
-
-type 'a lazy_subst =
-  | LSval of 'a
-  | LSlazy of substitution * 'a
+let rec mp_in_mp mp mp1 =
+  match mp1 with
+    | _ when mp1 = mp -> true
+    | MPdot (mp2,l) -> mp_in_mp mp mp2
+    | _ -> false
 	
-type 'a substituted = 'a lazy_subst ref
-      
-let from_val a = ref (LSval a)
-    
-let force fsubst r = 
-  match !r with
-  | LSval a -> a
-  | LSlazy(s,a) -> 
-      let a' = fsubst s a in
-      r := LSval a';
-      a' 
-
-
-
-let join (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst (sub : substitution) key (mp,_) =
-      match subst_mp0 sub mp with
-	  None -> mp,None
-	| Some mp' -> mp',None in
-  let subst = Umap.mapi (apply_subst subst2) subst1 in
-    (Umap.fold Umap.add subst2 subst)
-
-let subst_key subst1 subst2 =
-  let replace_in_key key mp sub=
-    let newkey = 
-      match key with
-	| MPI mp1 -> 
-	    begin
-	      match subst_mp0 subst1 mp1 with
-		| None -> None
-		| Some mp2 -> Some (MPI mp2)
-	    end
-	| _ -> None
-    in
-      match newkey with
-	| None -> Umap.add key mp sub
-	| Some mpi -> Umap.add mpi mp sub
+let mp_in_key mp key = 
+  match key with
+    | MP mp1 -> 
+	mp_in_mp mp mp1
+    | KN kn -> 
+	let mp1,dir,l = repr_kn kn in
+	  mp_in_mp mp mp1
+  
+let subset_prefixed_by mp resolver =
+  let prefixmp key hint resolv =
+    if mp_in_key mp key then
+      Deltamap.add key hint resolv
+    else 
+      resolv
   in
-    Umap.fold replace_in_key subst2 empty_subst
-
-let update_subst_alias subst1 subst2 =
- let subst_inv key (mp,_) sub =
-    let newmp = 
-      match key with 
-	| MBI msid -> Some (MPbound msid)
-	| MSI msid -> Some (MPself msid)
-	| _ -> None
-    in
-      match newmp with
-	| None -> sub
-	| Some mpi -> match mp with 
-	    | MPbound mbid -> Umap.add (MBI mbid) (mpi,None) sub
-	    | MPself msid -> Umap.add (MSI msid) (mpi,None) sub
-	    | _ ->  Umap.add (MPI mp) (mpi,None) sub
-  in 
-  let subst_mbi = Umap.fold subst_inv subst2 empty_subst in
-  let alias_subst key (mp,_) sub=
-    let newkey = 
-      match key with
-	| MPI mp1 -> 
-	    begin
-	      match subst_mp0 subst_mbi mp1 with
-		| None -> None
-		| Some mp2 -> Some (MPI mp2)
-	    end
-	| _ -> None
-    in
-      match newkey with
-	| None -> Umap.add key (mp,None) sub
-	| Some mpi -> Umap.add mpi (mp,None) sub
+    Deltamap.fold prefixmp resolver empty_delta_resolver
+
+let subst_dom_delta_resolver subst resolver =
+  let apply_subst key hint resolver =
+    match key with
+	(MP mp) ->
+	  Deltamap.add (MP (subst_mp subst mp)) hint resolver
+      | (KN kn) ->
+	  Deltamap.add (KN (subst_kn subst kn)) hint resolver
   in
-    Umap.fold alias_subst subst1 empty_subst
-
-let join_alias (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst (sub : substitution) key (mp,_) =
-      match subst_mp0 sub mp with
-	  None -> mp,None
-	| Some mp' -> mp',None in
-  Umap.mapi (apply_subst subst2) subst1 
-
-
-let update_subst subst1 subst2 =
- let subst_inv key (mp,_) l =
-    let newmp = 
-      match key with 
-	| MBI msid -> MPbound msid
-	| MSI msid -> MPself msid
-	| MPI mp -> mp
-    in
-   match mp with 
-     | MPbound mbid ->  ((MBI mbid),newmp)::l
-     | MPself msid ->  ((MSI msid),newmp)::l
-     | _ ->   ((MPI mp),newmp)::l
-  in 
-  let subst_mbi = Umap.fold subst_inv subst2 [] in
-  let alias_subst key (mp,_) sub=
-    let newsetkey = 
-      match key with
-	| MPI mp1 -> 
-	    let compute_set_newkey l (k,mp') = 
-	      let mp_from_key = match k with
-		  	| MBI msid -> MPbound msid
-			| MSI msid -> MPself msid
-			| MPI mp -> mp
-	      in
-	      let new_mp1 = replace_mp_in_mp mp_from_key mp' mp1 in
-		if new_mp1 == mp1 then l else (MPI new_mp1)::l
-	    in
-	    begin
-	      match List.fold_left compute_set_newkey [] subst_mbi with
-		| [] -> None
-		| l -> Some (l)
-	    end
-	| _ -> None
+    Deltamap.fold apply_subst resolver empty_delta_resolver
+
+let subst_mp_delta sub mp key=
+ match subst_mp0 sub mp with
+    None -> empty_delta_resolver,mp
+  | Some (mp',resolve) -> 
+      let mp1 = find_prefix resolve mp' in
+      let resolve1 = subset_prefixed_by mp1 resolve in
+	match key with
+	    MP mpk ->
+	      (subst_dom_delta_resolver 
+		 (map_mp mp1 mpk) resolve1),mp1
+	  | _ -> anomaly "Mod_subst: Bad association in resolver" 
+
+let subst_codom_delta_resolver subst resolver =
+  let apply_subst key hint resolver =
+    match hint with
+	Prefix_equiv mp ->
+	  let derived_resolve,mpnew = subst_mp_delta subst mp key in
+	    Deltamap.fold Deltamap.add derived_resolve
+	      (Deltamap.add key (Prefix_equiv mpnew) resolver)
+      | (Equiv kn) ->
+	  Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
+      | Inline None ->
+	  Deltamap.add key hint resolver
+      | Inline (Some t) ->
+	  Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
+  in
+    Deltamap.fold apply_subst resolver empty_delta_resolver
+
+let subst_dom_codom_delta_resolver subst resolver =
+  subst_dom_delta_resolver subst
+    (subst_codom_delta_resolver subst resolver)
+    
+let update_delta_resolver resolver1 resolver2 =
+ let apply_res key hint res = 
+      try
+	match hint with
+	    Prefix_equiv mp ->
+	      let new_hint =
+		Prefix_equiv (find_prefix resolver2 mp)
+	      in Deltamap.add key new_hint res
+	  | Equiv kn ->
+	      let new_hint =
+		Equiv (solve_delta_kn resolver2 kn)
+	      in Deltamap.add key new_hint res
+	  | _ -> Deltamap.add key hint res
+      with not_found -> 
+	Deltamap.add key hint res
     in
-      match newsetkey with
-	| None -> sub
-	| Some l -> 
-	    List.fold_left (fun s k -> Umap.add k (mp,None) s)
-	      sub l
+      Deltamap.fold apply_res resolver1 empty_delta_resolver
+
+let add_delta_resolver resolver1 resolver2 =
+  if resolver1 == resolver2 then
+    resolver2
+  else
+    Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2)
+      resolver2
+
+let substition_prefixed_by k mp subst =
+  let prefixmp key (mp_to,reso) sub =
+    match key with 
+      | MPI mpk ->
+	  if mp_in_mp mp mpk && mp <> mpk then
+	    let new_key = replace_mp_in_mp mp k mpk in
+	      Umap.add (MPI new_key) (mp_to,reso) sub
+	  else 
+	    sub
+      |  _ -> sub
   in
-    Umap.fold alias_subst subst1 empty_subst
+    Umap.fold prefixmp subst empty_subst
 
+let join (subst1 : substitution) (subst2 : substitution) =
+  let apply_subst key (mp,resolve) res =
+    let mp',resolve' =
+      match subst_mp0 subst2 mp with
+	  None -> mp, None
+	| Some (mp',resolve') ->  mp'
+	    ,Some resolve' in
+    let resolve'' : delta_resolver =
+      match resolve' with
+          Some res -> 
+	    add_delta_resolver 
+	      (subst_dom_codom_delta_resolver subst2 resolve) res
+	| None -> 
+	    subst_codom_delta_resolver subst2 resolve
+    in
+    let k = match key with MBI mp -> MPbound mp | MPI mp -> mp in
+    let prefixed_subst = substition_prefixed_by k mp subst2 in
+      Umap.fold Umap.add prefixed_subst 
+	(Umap.add key (mp',resolve'') res) in
+  let subst = Umap.fold apply_subst subst1 empty_subst in
+    (Umap.fold Umap.add subst2 subst) 
+
+let force fsubst r =
+  match !r with
+  | LSval a -> a
+  | LSlazy(s,a) ->
+      let subst = List.fold_left join empty_subst (List.rev s) in
+      let a' = fsubst subst a in
+      r := LSval a';
+      a'
 
 let subst_substituted s r =
   match !r with
-    | LSval a -> ref (LSlazy(s,a))
+    | LSval a -> ref (LSlazy([s],a))
     | LSlazy(s',a) ->
-	let s'' = join s' s in
-	  ref (LSlazy(s'',a))
+	  ref (LSlazy(s::s',a))
 
-let force_constr = force subst_mps 
+let force_constr = force subst_mps
 
 type constr_substituted = constr substituted
 
-let val_cstr_subst =
-  val_ref
-    (val_sum "constr_substituted" 0
-      [|[|val_constr|];[|val_subst;val_constr|]|])
+let val_cstr_subst = val_substituted val_constr
 
 let subst_constr_subst = subst_substituted
 
@@ -390,12 +657,17 @@ type constant_body = {
     const_body_code : to_patch_substituted;
    (* const_type_code : Cemitcodes.to_patch; *)
     const_constraints : Univ.constraints;
-    const_opaque : bool; 
+    const_opaque : bool;
     const_inline : bool}
 
 let val_cb = val_tuple "constant_body"
-  [|val_nctxt;val_opt val_cstr_subst; val_cst_type;no_val;val_cstrs;
-    val_bool; val_bool |]
+  [|val_nctxt;
+    val_opt val_cstr_subst;
+    val_cst_type;
+    no_val;
+    val_cstrs;
+    val_bool;
+    val_bool |]
 
 
 let subst_rel_declaration sub (id,copt,t as x) =
@@ -405,21 +677,21 @@ let subst_rel_declaration sub (id,copt,t as x) =
 
 let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
 
-type recarg = 
-  | Norec 
-  | Mrec of int 
+type recarg =
+  | Norec
+  | Mrec of int
   | Imbr of inductive
 let val_recarg = val_sum "recarg" 1 (* Norec *)
   [|[|val_int|] (* Mrec *);[|val_ind|] (* Imbr *)|]
 
 let subst_recarg sub r = match r with
   | Norec | Mrec _  -> r
-  | Imbr (kn,i) -> let kn' = subst_kn sub kn in
+  | Imbr (kn,i) -> let kn' = subst_ind sub kn in
       if kn==kn' then r else Imbr (kn',i)
 
 type wf_paths = recarg Rtree.t
 let val_wfp = val_rec_sum "wf_paths" 0
-  (fun val_wfp -> 
+  (fun val_wfp ->
     [|[|val_int;val_int|]; (* Rtree.Param *)
       [|val_recarg;val_array val_wfp|]; (* Rtree.Node *)
       [|val_int;val_array val_wfp|] (* Rtree.Rec *)
@@ -454,7 +726,7 @@ type monomorphic_inductive_arity = {
 let val_mono_ind_arity =
   val_tuple"monomorphic_inductive_arity"[|val_constr;val_sort|]
 
-type inductive_arity = 
+type inductive_arity =
 | Monomorphic of monomorphic_inductive_arity
 | Polymorphic of polymorphic_arity
 let val_ind_arity = val_sum "inductive_arity" 0
@@ -486,6 +758,9 @@ type one_inductive_body = {
  (* Number of expected real arguments of the type (no let, no params) *)
     mind_nrealargs : int;
 
+ (* Length of realargs context (with let, no params) *)
+    mind_nrealargs_ctxt : int;
+
  (* List of allowed elimination sorts *)
     mind_kelim : sorts_family list;
 
@@ -506,13 +781,13 @@ type one_inductive_body = {
  (* number of no constant constructor *)
     mind_nb_args : int;
 
-    mind_reloc_tbl :  reloc_table; 
+    mind_reloc_tbl :  reloc_table;
   }
 
 let val_one_ind = val_tuple "one_inductive_body"
   [|val_id;val_rctxt;val_ind_arity;val_array val_id;val_array val_constr;
-    val_int; val_list val_sortfam;val_array val_constr;val_array val_int;
-    val_wfp; val_int; val_int; no_val|]
+    val_int;val_int;val_list val_sortfam;val_array val_constr;val_array val_int;
+    val_wfp;val_int;val_int;no_val|]
 
 
 type mutual_inductive_body = {
@@ -544,12 +819,10 @@ type mutual_inductive_body = {
   (* Universes constraints enforced by the inductive declaration *)
     mind_constraints : Univ.constraints;
 
-  (* Source of the inductive block when aliased in a module *)
-    mind_equiv : kernel_name option
   }
 let val_ind_pack = val_tuple "mutual_inductive_body"
   [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt;
-    val_int; val_int; val_rctxt;val_cstrs;val_opt val_kn|]
+    val_int; val_int; val_rctxt;val_cstrs|]
 
 
 let subst_arity sub = function
@@ -565,7 +838,7 @@ let subst_const_body sub cb = {
     (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
     const_constraints = cb.const_constraints;
     const_opaque = cb.const_opaque;
-    const_inline = cb.const_inline} 
+    const_inline = cb.const_inline}
 
 let subst_arity sub = function
 | Monomorphic s ->
@@ -575,152 +848,158 @@ let subst_arity sub = function
     }
 | Polymorphic s as x -> x
 
-let subst_mind_packet sub mbp = 
+let subst_mind_packet sub mbp =
   { mind_consnames = mbp.mind_consnames;
     mind_consnrealdecls = mbp.mind_consnrealdecls;
     mind_typename = mbp.mind_typename;
-    mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
+   mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
     mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
     mind_arity = subst_arity sub mbp.mind_arity;
     mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
+    mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
     mind_kelim = mbp.mind_kelim;
-    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); 
+    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
     mind_nb_constant = mbp.mind_nb_constant;
     mind_nb_args = mbp.mind_nb_args;
     mind_reloc_tbl = mbp.mind_reloc_tbl }
 
 
-let subst_mind sub mib = 
-  { mind_record = mib.mind_record ; 
+let subst_mind sub mib =
+  { mind_record = mib.mind_record ;
     mind_finite = mib.mind_finite ;
     mind_ntypes = mib.mind_ntypes ;
     mind_hyps = (assert (mib.mind_hyps=[]); []) ;
     mind_nparams = mib.mind_nparams;
     mind_nparams_rec = mib.mind_nparams_rec;
-    mind_params_ctxt = 
+    mind_params_ctxt =
       map_rel_context (subst_mps sub) mib.mind_params_ctxt;
     mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
-    mind_constraints = mib.mind_constraints ;
-    mind_equiv = Option.map (subst_kn sub) mib.mind_equiv }
+    mind_constraints = mib.mind_constraints  }
 
 (* Modules *)
 
 (* Whenever you change these types, please do update the validation
    functions below *)
-type structure_field_body = 
+type structure_field_body =
   | SFBconst of constant_body
   | SFBmind of mutual_inductive_body
   | SFBmodule of module_body
-  | SFBalias of module_path * struct_expr_body option * Univ.constraints option
   | SFBmodtype of module_type_body
 
 and structure_body = (label * structure_field_body) list
 
 and struct_expr_body =
   | SEBident of module_path
-  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
-  | SEBstruct of mod_self_id * structure_body
-  | SEBapply of struct_expr_body * struct_expr_body
-      * Univ.constraints
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body
+  | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints
+  | SEBstruct of structure_body
   | SEBwith of struct_expr_body * with_declaration_body
 
 and with_declaration_body =
-    With_module_body of identifier list * module_path *
-      struct_expr_body option * Univ.constraints
+    With_module_body of identifier list * module_path
   | With_definition_body of  identifier list * constant_body
-        
-and module_body = 
-    { mod_expr : struct_expr_body option;
-      mod_type : struct_expr_body option;
+
+and module_body =
+    { mod_mp : module_path;
+      mod_expr : struct_expr_body option; 
+      mod_type : struct_expr_body;
+      mod_type_alg : struct_expr_body option;
       mod_constraints : Univ.constraints;
-      mod_alias : substitution;
+      mod_delta : delta_resolver;
       mod_retroknowledge : action list}
 
-and module_type_body = 
-    { typ_expr : struct_expr_body;
-      typ_strength : module_path option;
-      typ_alias : substitution}
+and module_type_body =
+    { typ_mp : module_path;
+      typ_expr : struct_expr_body;
+      typ_expr_alg : struct_expr_body option ;
+      typ_constraints : Univ.constraints;
+      typ_delta :delta_resolver}
 
 (* the validation functions: *)
 let rec val_sfb o = val_sum "struct_field_body" 0
   [|[|val_cb|];       (* SFBconst *)
     [|val_ind_pack|]; (* SFBmind *)
     [|val_module|];   (* SFBmodule *)
-    [|val_mp;val_opt val_seb;val_opt val_cstrs|]; (* SFBalias *)
     [|val_modtype|]   (* SFBmodtype *)
   |] o
 and val_sb o = val_list (val_tuple"label*sfb"[|val_id;val_sfb|]) o
 and val_seb o = val_sum "struct_expr_body" 0
   [|[|val_mp|];                      (* SEBident *)
     [|val_uid;val_modtype;val_seb|]; (* SEBfunctor *)
-    [|val_uid;val_sb|];              (* SEBstruct *)
     [|val_seb;val_seb;val_cstrs|];   (* SEBapply *)
+    [|val_sb|];              (* SEBstruct *)
     [|val_seb;val_with|]             (* SEBwith *)
   |] o
 and val_with o = val_sum "with_declaration_body" 0
-  [|[|val_list val_id;val_mp;val_cstrs|];
+  [|[|val_list val_id;val_mp|];
     [|val_list val_id;val_cb|]|] o
 and val_module o = val_tuple "module_body"
-  [|val_opt val_seb;val_opt val_seb;val_cstrs;val_subst;no_val|] o
+  [|val_mp;val_opt val_seb;val_seb;
+    val_opt val_seb;val_cstrs;val_res;no_val|] o
 and val_modtype o = val_tuple "module_type_body"
-  [|val_seb;val_opt val_mp;val_subst|] o
+  [|val_mp;val_seb;val_opt val_seb;val_cstrs;val_res|] o
+
 
-	
 let rec subst_with_body sub = function
-  | With_module_body(id,mp,typ_opt,cst) ->
-      With_module_body(id,subst_mp sub mp,
-		       Option.smartmap (subst_struct_expr sub) typ_opt,cst)
+  | With_module_body(id,mp) ->
+      With_module_body(id,subst_mp sub mp)
   | With_definition_body(id,cb) ->
       With_definition_body( id,subst_const_body sub cb)
 
-and subst_modtype sub mtb =
+and subst_modtype sub mtb=
   let typ_expr' = subst_struct_expr sub mtb.typ_expr in
-    if typ_expr'==mtb.typ_expr then
-      mtb
+  let typ_alg' = 
+    Option.smartmap 
+      (subst_struct_expr sub) mtb.typ_expr_alg in
+  let mp = subst_mp sub mtb.typ_mp
+  in
+    if typ_expr'==mtb.typ_expr && 
+      typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then
+	mtb
     else
-      { mtb with 
-	  typ_expr = typ_expr'}
-	
+      {mtb with 
+	 typ_mp = mp;
+	 typ_expr = typ_expr';
+	 typ_expr_alg = typ_alg'}
+
 and subst_structure sub sign = 
-  let subst_body  = function
+  let subst_body = function
       SFBconst cb -> 
 	SFBconst (subst_const_body sub cb)
     | SFBmind mib -> 
 	SFBmind (subst_mind sub mib)
     | SFBmodule mb -> 
-	SFBmodule (subst_module sub mb)
+	SFBmodule (subst_module sub  mb)
     | SFBmodtype mtb -> 
 	SFBmodtype (subst_modtype sub mtb)
-    | SFBalias (mp,typ_opt ,cst) ->
-	SFBalias (subst_mp sub mp,Option.smartmap (subst_struct_expr sub) typ_opt,cst)
   in
     List.map (fun (l,b) -> (l,subst_body b)) sign
 
-and subst_module  sub mb =
-  let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in
-  (* This is similar to the previous case. In this case we have
-     a module M in a signature that is knows to be equivalent to a module M'
-     (because the signature is "K with Module M := M'") and we are substituting
-     M' with some M''. *)
-  let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in
-  let mb_alias = join_alias mb.mod_alias sub in
-    if mtb'==mb.mod_type && mb.mod_expr == me' 
-      && mb_alias == mb.mod_alias
-    then mb else
-      { mod_expr = me';
-	mod_type=mtb'; 
-	mod_constraints=mb.mod_constraints;
-	mod_alias = mb_alias;
-	mod_retroknowledge=mb.mod_retroknowledge}
 
+and subst_module sub mb =
+  let mtb' = subst_struct_expr sub mb.mod_type in
+  let typ_alg' = Option.smartmap 
+    (subst_struct_expr sub ) mb.mod_type_alg in
+  let me' = Option.smartmap 
+    (subst_struct_expr sub) mb.mod_expr in
+  let mp = subst_mp sub mb.mod_mp in
+     if mtb'==mb.mod_type && mb.mod_expr == me' 
+       && mp == mb.mod_mp
+    then mb else
+      { mb with
+	  mod_mp = mp;
+	  mod_expr = me';
+	  mod_type_alg = typ_alg';
+	  mod_type=mtb'}
 
 and subst_struct_expr sub = function
-    | SEBident mp -> SEBident (subst_mp sub  mp)
-    | SEBfunctor (msid, mtb, meb') -> 
-	SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb')
-    | SEBstruct (msid,str)->
-	SEBstruct(msid, subst_structure sub str)
+    | SEBident mp -> SEBident (subst_mp sub mp)
+    | SEBfunctor (mbid, mtb, meb') -> 
+	SEBfunctor(mbid,subst_modtype sub mtb
+		     ,subst_struct_expr sub meb')
+    | SEBstruct (str)->
+	SEBstruct( subst_structure sub  str)
     | SEBapply (meb1,meb2,cst)->
 	SEBapply(subst_struct_expr sub meb1,
 		 subst_struct_expr sub meb2,
@@ -728,7 +1007,5 @@ and subst_struct_expr sub = function
     | SEBwith (meb,wdb)-> 
 	SEBwith(subst_struct_expr sub meb,
 		subst_with_body sub wdb)
- 
 
-let subst_signature_msid msid mp = 
-  subst_structure (map_msid msid mp)
+
diff --git a/checker/declarations.mli b/checker/declarations.mli
index d71e625f..b39fd6f2 100644
--- a/checker/declarations.mli
+++ b/checker/declarations.mli
@@ -25,7 +25,7 @@ type constant_type =
   | NonPolymorphicType of constr
   | PolymorphicArity of rel_context * polymorphic_arity
 
-type constr_substituted 
+type constr_substituted
 val force_constr : constr_substituted -> constr
 val from_val : constr -> constr_substituted
 
@@ -35,14 +35,14 @@ type constant_body = {
     const_type : constant_type;
     const_body_code : to_patch_substituted;
     const_constraints : Univ.constraints;
-    const_opaque : bool; 
+    const_opaque : bool;
     const_inline : bool}
 
 (* Mutual inductives *)
 
-type recarg = 
-  | Norec 
-  | Mrec of int 
+type recarg =
+  | Norec
+  | Mrec of int
   | Imbr of inductive
 
 type wf_paths = recarg Rtree.t
@@ -56,7 +56,7 @@ type monomorphic_inductive_arity = {
   mind_sort : sorts;
 }
 
-type inductive_arity = 
+type inductive_arity =
 | Monomorphic of monomorphic_inductive_arity
 | Polymorphic of polymorphic_arity
 
@@ -86,6 +86,9 @@ type one_inductive_body = {
  (* Number of expected real arguments of the type (no let, no params) *)
     mind_nrealargs : int;
 
+ (* Length of realargs context (with let, no params) *)
+    mind_nrealargs_ctxt : int;
+
  (* List of allowed elimination sorts *)
     mind_kelim : sorts_family list;
 
@@ -106,7 +109,7 @@ type one_inductive_body = {
  (* number of no constant constructor *)
     mind_nb_args : int;
 
-    mind_reloc_tbl :  reloc_table; 
+    mind_reloc_tbl :  reloc_table;
   }
 
 type mutual_inductive_body = {
@@ -138,53 +141,52 @@ type mutual_inductive_body = {
   (* Universes constraints enforced by the inductive declaration *)
     mind_constraints : Univ.constraints;
 
-  (* Source of the inductive block when aliased in a module *)
-    mind_equiv : kernel_name option
   }
 
 (* Modules *)
 
 type substitution
+type delta_resolver
+val empty_delta_resolver : delta_resolver
 
-type structure_field_body = 
+type structure_field_body =
   | SFBconst of constant_body
   | SFBmind of mutual_inductive_body
   | SFBmodule of module_body
-  | SFBalias of module_path * struct_expr_body option 
-      * Univ.constraints option
   | SFBmodtype of module_type_body
 
 and structure_body = (label * structure_field_body) list
 
 and struct_expr_body =
   | SEBident of module_path
-  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
-  | SEBstruct of mod_self_id * structure_body
-  | SEBapply of struct_expr_body * struct_expr_body
-      * Univ.constraints
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body
+  | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints
+  | SEBstruct of structure_body
   | SEBwith of struct_expr_body * with_declaration_body
 
 and with_declaration_body =
-    With_module_body of identifier list * module_path *
-      struct_expr_body option * Univ.constraints
+    With_module_body of identifier list * module_path
   | With_definition_body of  identifier list * constant_body
-        
-and module_body = 
-    { mod_expr : struct_expr_body option;
-      mod_type : struct_expr_body option;
+
+and module_body =
+    { mod_mp : module_path;
+      mod_expr : struct_expr_body option; 
+      mod_type : struct_expr_body;
+      mod_type_alg : struct_expr_body option;
       mod_constraints : Univ.constraints;
-      mod_alias : substitution;
+      mod_delta : delta_resolver;
       mod_retroknowledge : action list}
 
-and module_type_body = 
-    { typ_expr : struct_expr_body;
-      typ_strength : module_path option;
-      typ_alias : substitution}
+and module_type_body =
+    { typ_mp : module_path;
+      typ_expr : struct_expr_body;
+      typ_expr_alg : struct_expr_body option ;
+      typ_constraints : Univ.constraints;
+      typ_delta :delta_resolver}
 
 (* Substitutions *)
 
 val fold_subst :
-  (mod_self_id -> module_path -> 'a -> 'a) ->
   (mod_bound_id -> module_path -> 'a -> 'a) ->
   (module_path -> module_path -> 'a -> 'a) ->
   substitution -> 'a -> 'a
@@ -192,26 +194,21 @@ val fold_subst :
 type 'a subst_fun = substitution -> 'a -> 'a
 
 val empty_subst : substitution
-val add_msid : mod_self_id -> module_path -> substitution -> substitution
 val add_mbid : mod_bound_id -> module_path -> substitution -> substitution
 val add_mp   : module_path -> module_path -> substitution -> substitution
-val map_msid : mod_self_id -> module_path -> substitution
 val map_mbid : mod_bound_id -> module_path -> substitution
 val map_mp   : module_path -> module_path -> substitution
+val mp_in_delta : module_path -> delta_resolver -> bool
+val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
 
 val subst_const_body : constant_body subst_fun
 val subst_mind : mutual_inductive_body subst_fun
 val subst_modtype : substitution -> module_type_body -> module_type_body
 val subst_struct_expr :  substitution -> struct_expr_body -> struct_expr_body
 val subst_structure : substitution -> structure_body -> structure_body
-val subst_signature_msid :
-  mod_self_id -> module_path -> structure_body -> structure_body
+val subst_module : substitution -> module_body -> module_body
 
 val join : substitution -> substitution -> substitution
-val join_alias : substitution -> substitution -> substitution
-val update_subst_alias : substitution -> substitution -> substitution
-val update_subst : substitution -> substitution -> substitution
-val subst_key : substitution -> substitution -> substitution
 
 (* Validation *)
 val val_eng : Obj.t -> unit
diff --git a/checker/environ.ml b/checker/environ.ml
index 4bdbeee6..a72aae91 100644
--- a/checker/environ.ml
+++ b/checker/environ.ml
@@ -5,11 +5,11 @@ open Term
 open Declarations
 
 type globals = {
-  env_constants : constant_body Cmap.t;
-  env_inductives : mutual_inductive_body KNmap.t;
+  env_constants : constant_body Cmap_env.t;
+  env_inductives : mutual_inductive_body Mindmap_env.t;
+  env_inductives_eq : kernel_name  KNmap.t;
   env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body MPmap.t;
-  env_alias : module_path MPmap.t }
+  env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
@@ -25,11 +25,11 @@ type env = {
 
 let empty_env = {
   env_globals =
-  { env_constants = Cmap.empty;
-    env_inductives = KNmap.empty;
+  { env_constants = Cmap_env.empty;
+    env_inductives = Mindmap_env.empty;
+    env_inductives_eq = KNmap.empty;
     env_modules = MPmap.empty;
-    env_modtypes = MPmap.empty;
-    env_alias = MPmap.empty };
+    env_modtypes = MPmap.empty};
   env_named_context = [];
   env_rel_context = [];
   env_stratification =
@@ -71,17 +71,17 @@ let push_rel d env =
       env_rel_context = d :: env.env_rel_context }
 
 let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x
-    
+
 let push_rec_types (lna,typarray,_) env =
   let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
 
 (* Named context *)
 
-let push_named d env = 
+let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
-    { env with  
+    { env with
       env_named_context = d :: env.env_named_context }
 
 let lookup_named id env =
@@ -98,30 +98,30 @@ let named_type id env =
 
 (* Universe constraints *)
 let add_constraints c env =
-  if c == Constraint.empty then 
-    env 
+  if c == Constraint.empty then
+    env
   else
     let s = env.env_stratification in
-    { env with env_stratification = 
+    { env with env_stratification =
       { s with env_universes = merge_constraints c s.env_universes } }
 
 (* Global constants *)
 
 let lookup_constant kn env =
-  Cmap.find kn env.env_globals.env_constants
+  Cmap_env.find kn env.env_globals.env_constants
 
 let add_constant kn cs env =
-  let new_constants = 
-    Cmap.add kn cs env.env_globals.env_constants in
-  let new_globals = 
-    { env.env_globals with 
-	env_constants = new_constants } in 
+  let new_constants =
+    Cmap_env.add kn cs env.env_globals.env_constants in
+  let new_globals =
+    { env.env_globals with
+	env_constants = new_constants } in
   { env with env_globals = new_globals }
 
 (* constant_type gives the type of a constant *)
 let constant_type env kn =
   let cb = lookup_constant kn env in
-  cb.const_type  
+  cb.const_type
 
 type const_evaluation_result = NoBody | Opaque
 
@@ -144,60 +144,53 @@ let evaluable_constant cst env =
   with Not_found | NotEvaluableConst _ -> false
 
 (* Mutual Inductives *)
-let lookup_mind kn env =
-  KNmap.find kn env.env_globals.env_inductives
+let scrape_mind env kn=
+  try
+    KNmap.find kn env.env_globals.env_inductives_eq
+  with 
+      Not_found -> kn
+
+let mind_equiv env (kn1,i1) (kn2,i2) =
+  i1 = i2 && 
+  scrape_mind env (user_mind kn1) = scrape_mind env (user_mind kn2)
 
-let rec scrape_mind env kn = 
-  match (lookup_mind kn env).mind_equiv with
-    | None -> kn
-    | Some kn' -> scrape_mind env kn'
+
+let lookup_mind kn env =
+  Mindmap_env.find kn env.env_globals.env_inductives
 
 let add_mind kn mib env =
-  let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
-  let new_globals = 
-    { env.env_globals with 
-	env_inductives = new_inds } in
+  let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in
+  let kn1,kn2 =  user_mind kn,canonical_mind kn in
+  let new_inds_eq = if kn1=kn2 then 
+    env.env_globals.env_inductives_eq
+  else
+    KNmap.add kn1 kn2  env.env_globals.env_inductives_eq in
+  let new_globals =
+    { env.env_globals with
+	env_inductives = new_inds;
+	env_inductives_eq = new_inds_eq} in
   { env with env_globals = new_globals }
 
-let rec mind_equiv env (kn1,i1) (kn2,i2) =
-  let rec equiv kn1 kn2 =
-    kn1 = kn2 ||
-    scrape_mind env kn1 = scrape_mind env kn2 in
-  i1 = i2 && equiv kn1 kn2
-
 
 (* Modules *)
 
-let add_modtype ln mtb env = 
+let add_modtype ln mtb env =
   let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
-  let new_globals = 
-    { env.env_globals with 
+  let new_globals =
+    { env.env_globals with
 	env_modtypes = new_modtypes } in
   { env with env_globals = new_globals }
 
-let shallow_add_module mp mb env = 
+let shallow_add_module mp mb env =
   let new_mods = MPmap.add mp mb env.env_globals.env_modules in
-  let new_globals = 
-    { env.env_globals with 
+  let new_globals =
+    { env.env_globals with
 	env_modules = new_mods } in
   { env with env_globals = new_globals }
 
-let register_alias mp1 mp2 env =
-  let new_alias =  MPmap.add mp1 mp2 env.env_globals.env_alias in
-  let new_globals = 
-    { env.env_globals with 
-	env_alias = new_alias } in
-    { env with env_globals = new_globals }
-
-let rec scrape_alias mp env = 
-  try
-    let mp1 = MPmap.find mp env.env_globals.env_alias in
-      scrape_alias mp1 env
-  with
-      Not_found -> mp
 
-let lookup_module mp env = 
+let lookup_module mp env =
   MPmap.find mp env.env_globals.env_modules
 
-let lookup_modtype ln env = 
+let lookup_modtype ln env =
   MPmap.find ln env.env_globals.env_modtypes
diff --git a/checker/environ.mli b/checker/environ.mli
index 1541bf0d..023acd0b 100644
--- a/checker/environ.mli
+++ b/checker/environ.mli
@@ -4,12 +4,11 @@ open Term
 (* Environments *)
 
 type globals = {
-  env_constants : Declarations.constant_body Cmap.t;
-  env_inductives : Declarations.mutual_inductive_body KNmap.t;
+  env_constants : Declarations.constant_body Cmap_env.t;
+  env_inductives : Declarations.mutual_inductive_body Mindmap_env.t;
+  env_inductives_eq : kernel_name KNmap.t;
   env_modules : Declarations.module_body MPmap.t;
-  env_modtypes : Declarations.module_type_body MPmap.t;
-  env_alias : module_path MPmap.t;
-}
+  env_modtypes : Declarations.module_type_body MPmap.t}
 type stratification = {
   env_universes : Univ.universes;
   env_engagement : Declarations.engagement option;
@@ -59,19 +58,18 @@ val constant_opt_value : env -> constant -> constr option
 val evaluable_constant : constant -> env -> bool
 
 (* Inductives *)
+val mind_equiv : env -> inductive -> inductive -> bool
+
 val lookup_mind :
   mutual_inductive -> env -> Declarations.mutual_inductive_body
-val scrape_mind : env -> mutual_inductive -> mutual_inductive
+
 val add_mind :
   mutual_inductive -> Declarations.mutual_inductive_body -> env -> env
-val mind_equiv : env -> inductive -> inductive -> bool
 
 (* Modules *)
 val add_modtype :
   module_path -> Declarations.module_type_body -> env -> env
 val shallow_add_module :
   module_path -> Declarations.module_body -> env -> env
-val register_alias : module_path -> module_path -> env -> env
-val scrape_alias : module_path -> env -> module_path
 val lookup_module : module_path -> env -> Declarations.module_body
 val lookup_modtype : module_path -> env -> Declarations.module_type_body
diff --git a/checker/include b/checker/include
index 331eb45c..b7d46d4b 100644
--- a/checker/include
+++ b/checker/include
@@ -8,20 +8,26 @@
    (mainly run_l and norec).
  *)
 
-#cd ".."
+#cd "..";;
 #directory "lib";;
 #directory "kernel";;
 #directory "checker";;
+#directory "+camlp4";;
+#directory "+camlp5";;
 
 #load "unix.cma";;
 #load "str.cma";;
 #load "gramlib.cma";;
+(*#load "toplevellib.cma";;
+
+#directory "/usr/lib/ocaml/compiler-libs/utils";;
+let _ = Clflags.recursive_types:=true;;
+*)
 #load "check.cma";;
 
 open Typeops;;
 open Check;;
 
-
 open Pp;;
 open Util;;
 open Names;;
@@ -70,10 +76,11 @@ let prenv e =
   pp pe;;
 *)
 
+(*
 let prsub s =
   let string_of_mp mp =
     let s = string_of_mp mp in
-    (match mp with MPself _ -> "#self."|MPbound _ -> "#bound."|_->"")^s in 
+    (match mp with MPbound _ -> "#bound."|_->"")^s in 
   pp (hv 0 
   (fold_subst
     (fun msid mp strm ->
@@ -86,6 +93,7 @@ let prsub s =
       str"P " ++ str (string_of_mp mp1) ++ str " |-> " ++
       str (string_of_mp mp) ++ fnl() ++ strm) s (mt())))
 ;;
+*)
 
 #install_printer prid;;
 #install_printer prcon;;
@@ -100,10 +108,10 @@ let prsub s =
 #install_printer prcstrs;;
 (*#install_printer prus;;*)
 (*#install_printer prenv;;*)
-(*#install_printer prenvu;;*)
-#install_printer prsub;;
+(*#install_printer prenvu;;
+#install_printer prsub;;*)
 
-Checker.init();;
+Checker.init_with_argv [|""|];;
 Flags.make_silent false;;
 Flags.debug := true;;
 Sys.catch_break true;;
@@ -114,7 +122,7 @@ let module_of_file f =
 ;;
 let mod_access m fld =
   match m.mod_expr with
-      Some(SEBstruct(msid,l)) -> List.assoc fld l
+      Some(SEBstruct l) -> List.assoc fld l
     | _ -> failwith "bad structure type"
 ;;
 
@@ -153,7 +161,7 @@ let read_mod s f =
     engagement option);;
 
 let deref_mod md s =
-  let (Some (SEBstruct(msid,l))) = md.mod_expr in
+  let (Some (SEBstruct l)) = md.mod_expr in
   List.assoc (label_of_id(id_of_string s)) l
 ;;
 
diff --git a/checker/indtypes.ml b/checker/indtypes.ml
index 4c9b3d61..de57c50a 100644
--- a/checker/indtypes.ml
+++ b/checker/indtypes.ml
@@ -22,13 +22,11 @@ open Environ
 let rec debug_string_of_mp = function
   | MPfile sl -> string_of_dirpath sl
   | MPbound uid -> "bound("^string_of_mbid uid^")"
-  | MPself uid -> "self("^string_of_msid uid^")"
-  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
+  | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ string_of_label l
 
 let rec string_of_mp = function
   | MPfile sl -> string_of_dirpath sl
   | MPbound uid -> string_of_mbid uid
-  | MPself uid -> string_of_msid uid
   | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
 
 let string_of_mp mp =
@@ -38,8 +36,9 @@ let prkn kn =
   let (mp,_,l) = repr_kn kn in
   str(string_of_mp mp ^ "." ^ string_of_label l)
 let prcon c =
-  let (mp,_,l) = repr_con c in
-  str(string_of_mp mp ^ "." ^ string_of_label l)
+  let ck = canonical_con c in
+  let uk = user_con c in
+  if ck=uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")")
 
 (* Same as noccur_between but may perform reductions.
    Could be refined more...  *)
@@ -119,23 +118,24 @@ let is_small_constr infos = List.for_all (fun s -> is_small_sort s) infos
 let is_logic_constr infos = List.for_all (fun s -> is_logic_sort s) infos
 
 (* An inductive definition is a "unit" if it has only one constructor
-   and that all arguments expected by this constructor are 
-   logical, this is the case for equality, conjunction of logical properties 
+   and that all arguments expected by this constructor are
+   logical, this is the case for equality, conjunction of logical properties
 *)
 let is_unit constrsinfos =
   match constrsinfos with  (* One info = One constructor *)
-   | [|constrinfos|] -> is_logic_constr constrinfos 
+   | [|constrinfos|] -> is_logic_constr constrinfos
    | [||] -> (* type without constructors *) true
    | _ -> false
 
 let small_unit constrsinfos =
-  let issmall = array_for_all is_small_constr constrsinfos 
+  let issmall = array_for_all is_small_constr constrsinfos
   and isunit = is_unit constrsinfos in
   issmall, isunit
 
 (* check information related to inductive arity *)
 let typecheck_arity env params inds =
   let nparamargs = rel_context_nhyps params in
+  let nparamdecls = rel_context_length params in
   let check_arity arctxt = function
       Monomorphic mar ->
         let ar = mar.mind_user_arity in
@@ -154,8 +154,12 @@ let typecheck_arity env params inds =
         (* Arities (with params) are typed-checked here *)
         let arity = check_arity ar_ctxt ind.mind_arity in
         (* mind_nrealargs *)
-        if ind.mind_nrealargs <> rel_context_nhyps ar_ctxt - nparamargs then
+	let nrealargs = rel_context_nhyps ar_ctxt - nparamargs in
+        if ind.mind_nrealargs <> nrealargs then
              failwith "bad number of real inductive arguments";
+	let nrealargs_ctxt = rel_context_length ar_ctxt - nparamdecls in
+        if ind.mind_nrealargs_ctxt <> nrealargs_ctxt then
+             failwith "bad length of real inductive arguments signature";
 	(* We do not need to generate the universe of full_arity; if
 	   later, after the validation of the inductive definition,
 	   full_arity is used as argument or subject to cast, an
@@ -273,20 +277,20 @@ exception IllFormedInd of ill_formed_ind
 
 let mind_extract_params = decompose_prod_n_assum
 
-let explain_ind_err ntyp env0 nbpar c err = 
+let explain_ind_err ntyp env0 nbpar c err =
   let (lpar,c') = mind_extract_params nbpar c in
   let env = push_rel_context lpar env0 in
   match err with
-    | LocalNonPos kt -> 
+    | LocalNonPos kt ->
 	raise (InductiveError (NonPos (env,c',Rel (kt+nbpar))))
-    | LocalNotEnoughArgs kt -> 
-	raise (InductiveError 
+    | LocalNotEnoughArgs kt ->
+	raise (InductiveError
 		 (NotEnoughArgs (env,c',Rel (kt+nbpar))))
     | LocalNotConstructor ->
-	raise (InductiveError 
+	raise (InductiveError
 		 (NotConstructor (env,c',Rel (ntyp+nbpar))))
     | LocalNonPar (n,l) ->
-	raise (InductiveError 
+	raise (InductiveError
 		 (NonPar (env,c',n,Rel (nbpar-n+1), Rel (l+nbpar))))
 
 let failwith_non_pos n ntypes c =
@@ -307,7 +311,7 @@ let failwith_non_pos_list n ntypes l =
 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 
+  if Array.length largs < nparams then
     raise (IllFormedInd (LocalNotEnoughArgs l));
   let (lpar,largs') = array_chop nparams largs in
   let nhyps = List.length hyps in
@@ -319,18 +323,18 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
 	  | Rel w when w = index -> check (k-1) (index+1) hyps
 	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
   in check (nparams-1) (n-nhyps) hyps;
-  if not (array_for_all (noccur_between n ntypes) largs') then 
+  if not (array_for_all (noccur_between n ntypes) largs') then
     failwith_non_pos_vect n ntypes largs'
 
 (* Arguments of constructor: check the number of recursive parameters nrecp.
-    the first parameters which are constant in recursive arguments 
-    n is the current depth, nmr is the maximum number of possible 
+    the first parameters which are constant in recursive arguments
+    n is the current depth, nmr is the maximum number of possible
     recursive parameters *)
 
-let check_rec_par (env,n,_,_) hyps nrecp largs = 
+let check_rec_par (env,n,_,_) hyps nrecp largs =
   let (lpar,_) = list_chop nrecp largs in
-  let rec find index = 
-    function 
+  let rec find index =
+    function
       | ([],_) -> ()
       | (_,[]) ->
           failwith "number of recursive parameters cannot be greater than the number of parameters."
@@ -347,14 +351,14 @@ let lambda_implicit_lift n a =
 
 (* This removes global parameters of the inductive types in lc (for
    nested inductive types only ) *)
-let abstract_mind_lc env ntyps npars lc = 
-  if npars = 0 then 
+let abstract_mind_lc env ntyps npars lc =
+  if npars = 0 then
     lc
-  else 
-    let make_abs = 
+  else
+    let make_abs =
       list_tabulate
-	(function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps 
-    in 
+	(function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps
+    in
     Array.map (substl make_abs) lc
 
 (* [env] is the typing environment
@@ -362,7 +366,7 @@ let abstract_mind_lc env ntyps npars lc =
    [ntypes] is the number of inductive types in the definition
      (i.e. range of inductives is [n; n+ntypes-1])
    [lra] is the list of recursive tree of each variable
- *) 
+ *)
 let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
  (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
 
@@ -372,7 +376,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   let env' =
     push_rel (Anonymous,None,
               hnf_prod_applist env (type_of_inductive env specif) lpar) env in
-  let ra_env' = 
+  let ra_env' =
     (Imbr mi,(Rtree.mk_rec_calls 1).(0)) ::
     List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
   (* New index of the inductive types *)
@@ -384,7 +388,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
 let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
   let lparams = rel_context_length hyps in
   (* check the inductive types occur positively in [c] *)
-  let rec check_pos (env, n, ntypes, ra_env as ienv) c = 
+  let rec check_pos (env, n, ntypes, ra_env as ienv) c =
     let x,largs = decompose_app (whd_betadeltaiota env c) in
       match x with
 	| Prod (na,b,d) ->
@@ -395,7 +399,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
 	          check_pos (ienv_push_var ienv (na, b, mk_norec)) d)
 	| Rel k ->
             (try
-              let (ra,rarg) = List.nth ra_env (k-1) in 
+              let (ra,rarg) = List.nth ra_env (k-1) in
 	      (match ra with
                   Mrec _ -> check_rec_par ienv hyps nrecp largs
 		|  _ -> ());
@@ -408,9 +412,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
                parameter, then we have an imbricated type *)
             if List.for_all (noccur_between n ntypes) largs then mk_norec
             else check_positive_imbr ienv (ind_kn, largs)
-	| err -> 
+	| err ->
 	    if noccur_between n ntypes x &&
-              List.for_all (noccur_between n ntypes) largs 
+              List.for_all (noccur_between n ntypes) largs
 	    then mk_norec
 	    else failwith_non_pos_list n ntypes (x::largs)
 
@@ -419,14 +423,14 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
     let (mib,mip) = lookup_mind_specif env mi in
     let auxnpar = mib.mind_nparams_rec in
     let (lpar,auxlargs) =
-      try list_chop auxnpar largs 
-      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
+      try list_chop auxnpar largs
+      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
       (* If the inductive appears in the args (non params) then the
 	 definition is not positive. *)
       if not (List.for_all (noccur_between n ntypes) auxlargs) then
 	raise (IllFormedInd (LocalNonPos n));
       (* We do not deal with imbricated mutual inductive types *)
-      let auxntyp = mib.mind_ntypes in 
+      let auxntyp = mib.mind_ntypes in
 	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
 	(* The nested inductive type with parameters removed *)
 	let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
@@ -435,30 +439,30 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
 	let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
 	  (* Parameters expressed in env' *)
 	let lpar' = List.map (lift auxntyp) lpar in
-	let irecargs = 
+	let irecargs =
 	  (* fails if the inductive type occurs non positively *)
-	  (* when substituted *) 
-	  Array.map 
-	    (function c -> 
-	      let c' = hnf_prod_applist env' c lpar' in 
-		check_constructors ienv' false c') 
-	    auxlcvect in 
+	  (* when substituted *)
+	  Array.map
+	    (function c ->
+	      let c' = hnf_prod_applist env' c lpar' in
+		check_constructors ienv' false c')
+	    auxlcvect in
 	(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)
-	    
+
   (* check the inductive types occur positively in the products of C, if
      check_head=true, also check the head corresponds to a constructor of
-     the ith type *) 
-	    
-  and check_constructors ienv check_head c = 
-    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = 
+     the ith type *)
+
+  and check_constructors ienv check_head c =
+    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c =
       let x,largs = decompose_app (whd_betadeltaiota env c) in
 	match x with
-          | Prod (na,b,d) -> 
+          | Prod (na,b,d) ->
 	      assert (largs = []);
-              let recarg = check_pos ienv b in 
+              let recarg = check_pos ienv b in
               let ienv' = ienv_push_var ienv (na,b,mk_norec) in
 		check_constr_rec ienv' (recarg::lrec) d
-		  
+
 	  | hd ->
 	      if check_head then
 		if hd = Rel (n+ntypes-i-1) then
@@ -477,7 +481,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc =
         let _,rawc = mind_extract_params lparams c in
           try
 	    check_constructors ienv true rawc
-          with IllFormedInd err -> 
+          with IllFormedInd err ->
             explain_ind_err (ntypes-i) env lparams c err)
       indlc
   in mk_paths (Mrec i) irecargs
@@ -500,9 +504,9 @@ let check_positivity env_ar params nrecp inds =
     let ra_env =
       list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
     let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
-      check_positivity_one ienv params nrecp i mip.mind_nf_lc 
+      check_positivity_one ienv params nrecp i mip.mind_nf_lc
   in
-  let irecargs = Array.mapi check_one inds in 
+  let irecargs = Array.mapi check_one inds in
   let wfp = Rtree.mk_rec irecargs in
   array_iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp
 
@@ -510,7 +514,7 @@ let check_positivity env_ar params nrecp inds =
 (************************************************************************)
 
 let check_inductive env kn mib =
-  Flags.if_verbose msgnl (str "  checking ind: " ++ prkn kn);
+  Flags.if_verbose msgnl (str "  checking ind: " ++ pr_mind kn);
   (* check mind_constraints: should be consistent with env *)
   let env = add_constraints mib.mind_constraints env in
   (* check mind_record : TODO ? check #constructor = 1 ? *)
@@ -535,8 +539,6 @@ let check_inductive env kn mib =
   (* check mind_nparams_rec: positivity condition *)
   check_positivity env_ar params mib.mind_nparams_rec mib.mind_packets;
   (* check mind_equiv... *)
-  if mib.mind_equiv <> None then
-    msg_warning (str"TODO: mind_equiv not checked");
   (* Now we can add the inductive *)
   add_mind kn mib env
 
diff --git a/checker/inductive.ml b/checker/inductive.ml
index 05ab5a84..19c7a6cf 100644
--- a/checker/inductive.ml
+++ b/checker/inductive.ml
@@ -58,7 +58,7 @@ let inductive_params (mib,_) = mib.mind_nparams
 (* inductives *)
 let ind_subst mind mib =
   let ntypes = mib.mind_ntypes in
-  let make_Ik k = Ind (mind,ntypes-k-1) in 
+  let make_Ik k = Ind (mind,ntypes-k-1) in
   list_tabulate make_Ik ntypes
 
 (* Instantiate inductives in constructor type *)
@@ -67,7 +67,7 @@ let constructor_instantiate mind mib c =
   substl s c
 
 let instantiate_params full t args sign =
-  let fail () = 
+  let fail () =
     anomaly "instantiate_params: type, ctxt and args mismatch" in
   let (rem_args, subs, ty) =
     fold_rel_context
@@ -78,7 +78,7 @@ let instantiate_params full t args sign =
 	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
 	  | _                       -> fail ())
       sign
-      ~init:(args,[],t) 
+      ~init:(args,[],t)
   in
   if rem_args <> [] then fail();
   substl subs ty
@@ -104,11 +104,11 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) =
 let number_of_inductives mib = Array.length mib.mind_packets
 let number_of_constructors mip = Array.length mip.mind_consnames
 
-(* 
+(*
 Computing the actual sort of an applied or partially applied inductive type:
 
 I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a)
-uniformargs : utyps 
+uniformargs : utyps
 otherargs : otyps
 I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj
 s'_k = max(..s_kj..)
@@ -221,7 +221,7 @@ let type_of_constructor cstr (mib,mip) =
   if i > nconstr then error "Not enough constructors in the type";
   constructor_instantiate (fst ind) mib specif.(i-1)
 
-let arities_of_specif kn (mib,mip) = 
+let arities_of_specif kn (mib,mip) =
   let specif = mip.mind_nf_lc in
   Array.map (constructor_instantiate kn mib) specif
 
@@ -241,7 +241,7 @@ let error_elim_expln kp ki =
 
 let inductive_sort_family mip =
   match mip.mind_arity with
-   | Monomorphic s -> family_of_sort s.mind_sort 
+   | Monomorphic s -> family_of_sort s.mind_sort
    | Polymorphic _ -> InType
 
 let mind_arity mip =
@@ -253,26 +253,30 @@ let get_instantiated_arity (mib,mip) params =
 
 let elim_sorts (_,mip) = mip.mind_kelim
 
-let rel_list n m = 
-  let rec reln l p = 
-    if p>m then l else reln (Rel(n+p)::l) (p+1)
-  in 
-  reln [] 1
+let extended_rel_list n hyps =
+  let rec reln l p = function
+    | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
+    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
+    | [] -> l
+  in
+  reln [] 1 hyps
 
 let build_dependent_inductive ind (_,mip) params =
-  let nrealargs = mip.mind_nrealargs in
-  applist 
-    (Ind ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs))
+  let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  applist
+    (Ind ind,
+       List.map (lift mip.mind_nrealargs_ctxt) params
+       @ extended_rel_list 0 realargs)
 
 (* This exception is local *)
 exception LocalArity of (sorts_family * sorts_family * arity_error) option
 
 let check_allowed_sort ksort specif =
-  if not (List.exists ((=) ksort) (elim_sorts specif)) then 
+  if not (List.exists ((=) ksort) (elim_sorts specif)) then
     let s = inductive_sort_family (snd specif) in
     raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
 
-let is_correct_arity env c (p,pj) ind specif params = 
+let is_correct_arity env c (p,pj) ind specif params =
   let arsign,_ = get_instantiated_arity specif params in
   let rec srec env pt ar =
     let pt' = whd_betadeltaiota env pt in
@@ -283,9 +287,9 @@ let is_correct_arity env c (p,pj) ind specif params =
           srec (push_rel (na1,None,a1) env) t ar'
       | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *)
           let ksort = match (whd_betadeltaiota env a2) with
-            | Sort s -> family_of_sort s 
+            | Sort s -> family_of_sort s
 	    | _ -> raise (LocalArity None) in
-	  let dep_ind = build_dependent_inductive ind specif params in 
+	  let dep_ind = build_dependent_inductive ind specif params in
           (try conv env a1 dep_ind
           with NotConvertible -> raise (LocalArity None));
 	  check_allowed_sort ksort specif;
@@ -295,7 +299,7 @@ let is_correct_arity env c (p,pj) ind specif params =
 	  false
       | _ ->
 	  raise (LocalArity None)
-  in 
+  in
   try srec env pj (List.rev arsign)
   with LocalArity kinds ->
     error_elim_arity env ind (elim_sorts specif) c (p,pj) kinds
@@ -332,7 +336,7 @@ let build_case_type dep p c realargs =
   beta_appvect p (Array.of_list args)
 
 let type_case_branches env (ind,largs) (p,pj) c =
-  let specif = lookup_mind_specif env ind in 
+  let specif = lookup_mind_specif env ind in
   let nparams = inductive_params specif in
   let (params,realargs) = list_chop nparams largs in
   let dep = is_correct_arity env c (p,pj) ind specif params in
@@ -347,7 +351,7 @@ let type_case_branches env (ind,largs) (p,pj) c =
 let check_case_info env indsp ci =
   let (mib,mip) = lookup_mind_specif env indsp in
   if
-    not (mind_equiv env indsp ci.ci_ind) or
+    not (eq_ind indsp ci.ci_ind) or
     (mib.mind_nparams <> ci.ci_npar) or
     (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
@@ -357,7 +361,7 @@ let check_case_info env indsp ci =
 
 (* Guard conditions for fix and cofix-points *)
 
-(* Check if t is a subterm of Rel n, and gives its specification, 
+(* Check if t is a subterm of Rel n, and gives its specification,
    assuming lst already gives index of
    subterms with corresponding specifications of recursive arguments *)
 
@@ -415,7 +419,7 @@ let subterm_spec_glb =
           (* branches do not return objects with same spec *)
           else Not_subterm in
   Array.fold_left glb2 Dead_code
-          
+
 type guard_env =
   { env     : env;
     (* dB of last fixpoint *)
@@ -439,7 +443,7 @@ let make_renv env minds recarg (kn,tyi) =
     genv = [Subterm(Large,mind_recvec.(tyi))] }
 
 let push_var renv (x,ty,spec) =
-  { renv with 
+  { renv with
     env = push_rel (x,None,ty) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
@@ -451,7 +455,7 @@ let push_var_renv renv (x,ty) =
   push_var renv (x,ty,Not_subterm)
 
 (* Fetch recursive information about a variable p *)
-let subterm_var p renv = 
+let subterm_var p renv =
   try List.nth renv.genv (p-1)
   with Failure _ | Invalid_argument _ -> Not_subterm
 
@@ -461,7 +465,7 @@ let add_subterm renv (x,a,spec) =
 
 let push_ctxt_renv renv ctxt =
   let n = rel_context_length ctxt in
-  { renv with 
+  { renv with
     env = push_rel_context ctxt renv.env;
     rel_min = renv.rel_min+n;
     genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
@@ -500,8 +504,8 @@ let lookup_subterms env ind =
    associated to its own subterms.
    Rq: if branch is not eta-long, then the recursive information
    is not propagated to the missing abstractions *)
-let case_branches_specif renv c_spec ind lbr = 
-  let rec push_branch_args renv lrec c = 
+let case_branches_specif renv c_spec ind lbr =
+  let rec push_branch_args renv lrec c =
     match lrec with
         ra::lr ->
           let c' = whd_betadeltaiota renv.env c in
@@ -517,7 +521,7 @@ let case_branches_specif renv c_spec ind lbr =
         let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
         assert (Array.length sub_spec = Array.length lbr);
         array_map2 (push_branch_args renv) sub_spec lbr
-    | Dead_code -> 
+    | Dead_code ->
         let t = dest_subterms (lookup_subterms renv.env ind) in
         let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
         assert (Array.length sub_spec = Array.length lbr);
@@ -530,10 +534,10 @@ let case_branches_specif renv c_spec ind lbr =
    about variables.
 *)
 
-let rec subterm_specif renv t = 
+let rec subterm_specif renv t =
   (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
-  match f with 
+  match f with
     | Rel k -> subterm_var k renv
 
     | Case (ci,_,c,lbr) ->
@@ -545,7 +549,7 @@ let rec subterm_specif renv t =
             Array.map (fun (renv',br') -> subterm_specif renv' br')
               lbr_spec in
           subterm_spec_glb stl
-	       
+
     | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
 (* when proving that the fixpoint f(x)=e is less than n, it is enough
    to prove that e is less than n assuming f is less than n
@@ -568,7 +572,7 @@ let rec subterm_specif renv t =
                 (* Why Strict here ? To be general, it could also be
                    Large... *)
                 assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
-              let decrArg = recindxs.(i) in 
+              let decrArg = recindxs.(i) in
               let theBody = bodies.(i)   in
               let nbOfAbst = decrArg+1 in
               let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
@@ -582,7 +586,7 @@ let rec subterm_specif renv t =
                   assign_var_spec renv'' (1, arg_spec) in
 	      subterm_specif renv'' strippedBody)
 
-    | Lambda (x,a,b) -> 
+    | Lambda (x,a,b) ->
         assert (l=[]);
         subterm_specif (push_var_renv renv (x,a)) b
 
@@ -594,7 +598,7 @@ let rec subterm_specif renv t =
 
 
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm renv c = 
+let check_is_subterm renv c =
   match subterm_specif renv c with
     Subterm (Strict,_) | Dead_code -> true
   |  _ -> false
@@ -622,21 +626,21 @@ let error_partial_apply renv fx =
    given [recpos], the decreasing arguments of each mutually defined
    fixpoint. *)
 let check_one_fix renv recpos def =
-  let nfi = Array.length recpos in 
+  let nfi = Array.length recpos in
 
   (* Checks if [t] only make valid recursive calls *)
-  let rec check_rec_call renv t = 
+  let rec check_rec_call renv t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
       let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
       match f with
-        | Rel p -> 
-            (* Test if [p] is a fixpoint (recursive call) *) 
+        | Rel p ->
+            (* Test if [p] is a fixpoint (recursive call) *)
 	    if renv.rel_min <= p & p < renv.rel_min+nfi then
               begin
                 List.iter (check_rec_call renv) l;
-                (* the position of the invoked fixpoint: *) 
+                (* the position of the invoked fixpoint: *)
 	        let glob = renv.rel_min+nfi-1-p in
                 (* the decreasing arg of the rec call: *)
 	        let np = recpos.(glob) in
@@ -668,9 +672,9 @@ let check_one_fix renv recpos def =
         (* Enables to traverse Fixpoint definitions in a more intelligent
            way, ie, the rule :
            if - g = Fix g/p := [y1:T1]...[yp:Tp]e &
-              - f is guarded with respect to the set of pattern variables S 
+              - f is guarded with respect to the set of pattern variables S
                 in a1 ... am        &
-              - f is guarded with respect to the set of pattern variables S 
+              - f is guarded with respect to the set of pattern variables S
                 in T1 ... Tp        &
               - ap is a sub-term of the formal argument of f &
               - f is guarded with respect to the set of pattern variables
@@ -682,10 +686,10 @@ let check_one_fix renv recpos def =
             List.iter (check_rec_call renv) l;
             Array.iter (check_rec_call renv) typarray;
             let decrArg = recindxs.(i) in
-            let renv' = push_fix_renv renv recdef in 
+            let renv' = push_fix_renv renv recdef in
             if (List.length l < (decrArg+1)) then
 	      Array.iter (check_rec_call renv') bodies
-            else 
+            else
               Array.iteri
                 (fun j body ->
                   if i=j then
@@ -695,8 +699,8 @@ let check_one_fix renv recpos def =
                   else check_rec_call renv' body)
                 bodies
 
-        | Const kn -> 
-            if evaluable_constant kn renv.env then 
+        | Const kn ->
+            if evaluable_constant kn renv.env then
               try List.iter (check_rec_call renv) l
               with (FixGuardError _ ) ->
 	        check_rec_call renv(applist(constant_value renv.env kn, l))
@@ -704,14 +708,14 @@ let check_one_fix renv recpos def =
 
         (* The cases below simply check recursively the condition on the
            subterms *)
-        | Cast (a,_, b) -> 
+        | Cast (a,_, b) ->
             List.iter (check_rec_call renv) (a::b::l)
 
         | Lambda (x,a,b) ->
             List.iter (check_rec_call renv) (a::l);
             check_rec_call (push_var_renv renv (x,a)) b
 
-        | Prod (x,a,b) -> 
+        | Prod (x,a,b) ->
             List.iter (check_rec_call renv) (a::l);
             check_rec_call (push_var_renv renv (x,a)) b
 
@@ -755,9 +759,9 @@ let check_one_fix renv recpos def =
 
 
 let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
-  let nbfix = Array.length bodies in 
+  let nbfix = Array.length bodies in
   if nbfix = 0
-    or Array.length nvect <> nbfix 
+    or Array.length nvect <> nbfix
     or Array.length types <> nbfix
     or Array.length names <> nbfix
     or bodynum < 0
@@ -767,18 +771,18 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
   let raise_err env i err =
     error_ill_formed_rec_body env err names i in
   (* Check the i-th definition with recarg k *)
-  let find_ind i k def = 
-    (* check fi does not appear in the k+1 first abstractions, 
+  let find_ind i k def =
+    (* check fi does not appear in the k+1 first abstractions,
        gives the type of the k+1-eme abstraction (must be an inductive)  *)
-    let rec check_occur env n def = 
+    let rec check_occur env n def =
       match (whd_betadeltaiota env def) with
-        | Lambda (x,a,b) -> 
+        | Lambda (x,a,b) ->
 	    if noccur_with_meta n nbfix a then
 	      let env' = push_rel (x, None, a) env in
               if n = k+1 then
                 (* get the inductive type of the fixpoint *)
-                let (mind, _) = 
-                  try find_inductive env a 
+                let (mind, _) =
+                  try find_inductive env a
                   with Not_found ->
 		    raise_err env i (RecursionNotOnInductiveType a) in
                 (mind, (env', b))
@@ -818,17 +822,17 @@ let rec codomain_is_coind env c =
   let b = whd_betadeltaiota env c in
   match b with
     | Prod (x,a,b) ->
-	codomain_is_coind (push_rel (x, None, a) env) b 
-    | _ -> 
+	codomain_is_coind (push_rel (x, None, a) env) b
+    | _ ->
 	(try find_coinductive env b
         with Not_found ->
 	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
 
-let check_one_cofix env nbfix def deftype = 
+let check_one_cofix env nbfix def deftype =
   let rec check_rec_call env alreadygrd n vlra  t =
     if not (noccur_with_meta n nbfix t) then
       let c,args = decompose_app (whd_betadeltaiota env t) in
-      match c with 
+      match c with
 	| Rel p when  n <= p && p < n+nbfix ->
 	    (* recursive call: must be guarded and no nested recursive
                call allowed *)
@@ -836,14 +840,14 @@ let check_one_cofix env nbfix def deftype =
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
             else if not(List.for_all (noccur_with_meta n nbfix) args) then
 	      raise (CoFixGuardError (env,NestedRecursiveOccurrences))
-		 
+
 	| Construct (_,i as cstr_kn)  ->
-            let lra = vlra.(i-1) in 
+            let lra = vlra.(i-1) in
             let mI = inductive_of_constructor cstr_kn in
 	    let (mib,mip) = lookup_mind_specif env mI in
             let realargs = list_skipn mib.mind_nparams args in
             let rec process_args_of_constr = function
-              | (t::lr), (rar::lrar) -> 
+              | (t::lr), (rar::lrar) ->
                   if rar = mk_norec then
                     if noccur_with_meta n nbfix t
                     then process_args_of_constr (lr, lrar)
@@ -854,26 +858,26 @@ let check_one_cofix env nbfix def deftype =
                     check_rec_call env true n spec t;
                     process_args_of_constr (lr, lrar)
               | [],_ -> ()
-              | _ -> anomaly_ill_typed () 
+              | _ -> anomaly_ill_typed ()
             in process_args_of_constr (realargs, lra)
-		 
+
 	| Lambda (x,a,b) ->
 	     assert (args = []);
             if noccur_with_meta n nbfix a then
               let env' = push_rel (x, None, a) env in
               check_rec_call env' alreadygrd (n+1)  vlra b
-            else 
+            else
 	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
-	      
+
 	| CoFix (j,(_,varit,vdefs as recdef)) ->
             if (List.for_all (noccur_with_meta n nbfix) args)
-            then 
+            then
               let nbfix = Array.length vdefs in
 	      if (array_for_all (noccur_with_meta n nbfix) varit) then
 		let env' = push_rec_types recdef env in
 		(Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs;
 		 List.iter (check_rec_call env alreadygrd n vlra) args)
-              else 
+              else
 		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
 	    else
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall c))
@@ -883,31 +887,31 @@ let check_one_cofix env nbfix def deftype =
               if (noccur_with_meta n nbfix tm) then
 		if (List.for_all (noccur_with_meta n nbfix) args) then
 		  Array.iter (check_rec_call env alreadygrd n vlra) vrest
-		else 
+		else
 		  raise (CoFixGuardError (env,RecCallInCaseFun c))
-              else 
+              else
 		raise (CoFixGuardError (env,RecCallInCaseArg c))
-            else 
+            else
 	      raise (CoFixGuardError (env,RecCallInCasePred c))
-              
+
 	| Meta _ -> ()
         | Evar _ ->
 	    List.iter (check_rec_call env alreadygrd n vlra) args
-	      
-	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in 
+
+	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in
 
   let (mind, _) = codomain_is_coind env deftype in
   let vlra = lookup_subterms env mind in
   check_rec_call env false 1 (dest_subterms vlra) def
 
-(* The  function which checks that the whole block of definitions 
+(* The  function which checks that the whole block of definitions
    satisfies the guarded condition *)
 
-let check_cofix env (bodynum,(names,types,bodies as recdef)) = 
-  let nbfix = Array.length bodies in 
+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) -> 
+    with CoFixGuardError (errenv,err) ->
       error_ill_formed_rec_body errenv err names i
   done
diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml
index 24000591..23ba4893 100644
--- a/checker/mod_checking.ml
+++ b/checker/mod_checking.ml
@@ -31,7 +31,7 @@ let check_constant_declaration env kn cb =
   (match cb.const_type with
       NonPolymorphicType ty ->
         let ty, cu = refresh_arity ty in
-        let envty = add_constraints cu env' in 
+        let envty = add_constraints cu env' in
         let _ = infer_type envty ty in
         (match cb.const_body with
           | Some bd ->
@@ -58,19 +58,15 @@ let rec list_split_assoc k rev_before = function
   | (k',b)::after when k=k' -> rev_before,b,after
   | h::tail -> list_split_assoc k (h::rev_before) tail
 
-let rec list_fold_map2 f e = function 
+let rec list_fold_map2 f e = function
   |  []  -> (e,[],[])
-  |  h::t -> 
+  |  h::t ->
        let e',h1',h2' = f e h in
        let e'',t1',t2' = list_fold_map2 f e' t in
 	 e'',h1'::t1',h2'::t2'
 
-
-let check_alias (s1:substitution) s2 =
-  if s1 <> s2 then failwith "Incorrect alias"
-
 let check_definition_sub env cb1 cb2 =
-  let check_type env t1 t2 = 
+  let check_type env t1 t2 =
 
     (* If the type of a constant is generated, it may mention
        non-variable algebraic universes that the general conversion
@@ -81,7 +77,7 @@ let check_definition_sub env cb1 cb2 =
        Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
        Hence they don't have to be checked again *)
 
-    let t1,t2 = 
+    let t1,t2 =
       if isArity t2 then
         let (ctx2,s2) = destArity t2 in
         match s2 with
@@ -135,38 +131,38 @@ let lookup_modtype mp env =
   with Not_found ->
     failwith ("Unknown module type: "^string_of_mp mp)
 
-
-let rec check_with env mtb with_decl = 
+let rec check_with env mtb with_decl mp=
   match with_decl with
-    | With_definition_body _ -> 
-	check_with_aux_def env mtb with_decl;
-	empty_subst
-    | With_module_body _ -> 
-	check_with_aux_mod env mtb with_decl
+    | With_definition_body _ ->
+	check_with_aux_def env mtb with_decl mp;
+	mtb
+    | With_module_body _ ->
+	check_with_aux_mod env mtb with_decl mp;
+	mtb
 
-and check_with_aux_def env mtb with_decl = 
-  let msid,sig_b = match (eval_struct env mtb) with 
-    | SEBstruct(msid,sig_b) ->
-	msid,sig_b
+and check_with_aux_def env mtb with_decl mp =
+  let sig_b = match mtb with
+    | SEBstruct(sig_b) ->
+	sig_b
     | _ -> error_signature_expected mtb
   in
-  let id,idl = match with_decl with 
-    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) ->
+  let id,idl = match with_decl with
+    | With_definition_body (id::idl,_) | With_module_body (id::idl,_) ->
                                            id,idl
-    | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false
+    | With_definition_body ([],_) | With_module_body ([],_) -> assert false
   in
   let l = label_of_id id in
     try
       let rev_before,spec,after = list_split_assoc l [] sig_b in
       let before = List.rev rev_before in
-      let env' = Modops.add_signature (MPself msid) before env in
+      let env' = Modops.add_signature mp before empty_delta_resolver env in
 	match with_decl with
           | With_definition_body ([],_) -> assert false
-	  | With_definition_body ([id],c) -> 
+	  | With_definition_body ([id],c) ->
 	      let cb = match spec with
 		  SFBconst cb -> cb
 		| _ -> error_not_a_constant l
-	      in 
+	      in
               check_definition_sub env' c cb
 	  | With_definition_body (_::_,_) ->
 	      let old = match spec with
@@ -179,9 +175,9 @@ and check_with_aux_def env mtb with_decl =
 			let new_with_decl = match with_decl with
 			    With_definition_body (_,c) ->
                               With_definition_body (idl,c)
-			  | With_module_body (_,c,t,cst) ->
-                              With_module_body (idl,c,t,cst) in 
-			  check_with_aux_def env' (type_of_mb env old) new_with_decl
+			  | With_module_body (_,c) ->
+                              With_module_body (idl,c) in
+			  check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l))
                     | Some msb ->
 			error_a_generative_module_expected l
 		end
@@ -190,46 +186,35 @@ and check_with_aux_def env mtb with_decl =
 	Not_found -> error_no_such_label l
       | Reduction.NotConvertible -> error_with_incorrect l
 
-and check_with_aux_mod env mtb with_decl = 
-  let initmsid,msid,sig_b =
-    match eval_struct env mtb with 
-    | SEBstruct(msid,sig_b) ->
-        let msid'=(refresh_msid msid) in
-	msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b)
+and check_with_aux_mod env mtb with_decl mp =
+  let sig_b =
+    match mtb with
+    | SEBstruct(sig_b) ->
+	sig_b
     | _ -> error_signature_expected mtb in
-  let id,idl = match with_decl with 
-    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) ->
+  let id,idl = match with_decl with
+    | With_definition_body (id::idl,_) | With_module_body (id::idl,_) ->
         id,idl
-    | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false
+    | With_definition_body ([],_) | With_module_body ([],_) -> assert false
   in
   let l = label_of_id id in
     try
       let rev_before,spec,after = list_split_assoc l [] sig_b in
       let before = List.rev rev_before in
       let rec mp_rec = function
-	| [] -> MPself initmsid
+	| [] -> mp
 	| i::r -> MPdot(mp_rec r,label_of_id i)
-      in 
-      let env' = Modops.add_signature (MPself msid) before env in
+      in
+      let env' = Modops.add_signature mp before empty_delta_resolver env in
 	match with_decl with
-          | With_module_body ([],_,_,_) -> assert false
-	  | With_module_body ([id], mp,_,_) ->
-	      let old,alias = match spec with
-		  SFBmodule msb -> Some msb,None
-		| SFBalias (mp',_,_) -> None,Some mp'
+          | With_module_body ([],_) -> assert false
+	  | With_module_body ([id], mp1) ->
+	      let _ = match spec with
+		  SFBmodule msb -> msb
 		| _ -> error_not_a_module l
 	      in
-	      let mtb' = lookup_modtype mp env' in
-	      let _ =
-		match old,alias with
-		    Some msb,None -> ()
-		  | None,Some mp' ->
-		      check_modpath_equiv env' mp mp'
-		  | _,_ ->
-		      anomaly "Mod_typing:no implementation and no alias"
-	      in
-		join (map_mp (mp_rec [id]) mp) mtb'.typ_alias
-        | With_module_body (_::_,mp,_,_) -> 
+	      let _ = (lookup_module mp1 env) in ()
+        | With_module_body (_::_,mp) ->
 	    let old = match spec with
 		SFBmodule msb -> msb
 	      | _ -> error_not_a_module l
@@ -238,14 +223,12 @@ and check_with_aux_mod env mtb with_decl =
 		match old.mod_expr with
                     None ->
                       let new_with_decl = match with_decl with
-			  With_definition_body (_,c) -> 
+			  With_definition_body (_,c) ->
 			    With_definition_body (idl,c)
-			| With_module_body (_,c,t,cst) ->
-                            With_module_body (idl,c,t,cst) in
-		      let sub =
-			check_with_aux_mod env' 
-			  (type_of_mb env old) new_with_decl in
-		      join (map_mp (mp_rec idl) mp) sub
+			| With_module_body (_,c) ->
+                            With_module_body (idl,c) in
+		 	check_with_aux_mod env'
+			  old.mod_type new_with_decl (MPdot(mp,l))
                   | Some msb ->
                       error_a_generative_module_expected l
               end
@@ -255,113 +238,111 @@ and check_with_aux_mod env mtb with_decl =
       | Reduction.NotConvertible -> error_with_incorrect l
 
 and check_module_type env mty =
-  if mty.typ_strength <> None then
-    failwith "strengthening of module types not supported";
-  let sub = check_modexpr env mty.typ_expr in
-  check_alias mty.typ_alias sub
+  let _ = check_modtype env mty.typ_expr mty.typ_mp in ()
 
-and check_module env mb =
-  let sub =
-    match mb.mod_expr, mb.mod_type with
-      | None, None -> 
-	  anomaly "Mod_typing.translate_module: empty type and expr in module entry"
-      | None, Some mtb -> check_modexpr env mtb
-
-      | Some mexpr, _ -> 
-	  let sub1 = check_modexpr env mexpr in
-	  (match mb.mod_type with
-	    | None ->  sub1
-	    | Some mte -> 
-		let sub2 = check_modexpr env mte in
-                check_subtypes env
-		  {typ_expr = mexpr;
-		   typ_strength = None;
-		   typ_alias = sub1;}
-		  {typ_expr = mte;
-		   typ_strength = None;
-		   typ_alias = sub2;};
-		sub2) in
-  check_alias mb.mod_alias sub
-
-and check_structure_field (s,env) mp lab = function
+							 
+and check_module env mp mb =
+  match mb.mod_expr, mb.mod_type with
+    | None,mtb -> 
+	let _ = check_modtype env mtb mb.mod_mp in ()
+    | Some mexpr, mtb when mtb==mexpr ->
+	let _ = check_modtype env mtb mb.mod_mp in ()
+    | Some mexpr, _ ->
+	let sign = check_modexpr env mexpr mb.mod_mp mb.mod_delta in
+	let _ = check_modtype env mb.mod_type mb.mod_mp mb.mod_delta in
+          check_subtypes env 
+	    {typ_mp=mp;
+	     typ_expr=sign;
+	     typ_expr_alg=None;
+	     typ_constraints=Univ.Constraint.empty;
+	     typ_delta = mb.mod_delta;}
+	    {typ_mp=mp;
+	     typ_expr=mb.mod_type;
+	     typ_expr_alg=None;
+	     typ_constraints=Univ.Constraint.empty;
+	     typ_delta = mb.mod_delta;};
+	  
+and check_structure_field env mp lab res = function
   | SFBconst cb ->
       let c = make_con mp empty_dirpath lab in
-      (s,check_constant_declaration env c cb)
+	check_constant_declaration env c cb
   | SFBmind mib ->
-      let kn = make_kn mp empty_dirpath lab in
-      (s,Indtypes.check_inductive env kn mib)
+      let kn = make_mind mp empty_dirpath lab in
+      let kn = mind_of_delta res kn in
+	Indtypes.check_inductive env kn mib
   | SFBmodule msb ->
-      check_module env msb;
-      let mp1 = MPdot(mp,lab) in
-      let is_fun, sub = Modops.update_subst env msb mp1 in
-      ((if is_fun then s else join s sub),
-       Modops.add_module (MPdot(mp,lab)) msb env)
-  | SFBalias(mp2,_,cst) ->
-      (* cf Safe_typing.add_alias *)
-      (try
-        let mp' = MPdot(mp,lab) in
-        let mp2' = scrape_alias mp2 env in
-        let _,sub = Modops.update_subst env (lookup_module mp2' env) mp2' in
-        let sub = update_subst sub (map_mp mp' mp2') in
-        let sub = join_alias sub (map_mp mp' mp2') in
-        let sub = add_mp mp' mp2' sub in
-        (join s sub, register_alias mp' mp2 env)
-      with Not_found -> failwith "unknown aliased module")
+      let _= check_module env (MPdot(mp,lab)) msb in
+	Modops.add_module msb env
   | SFBmodtype mty ->
-      let kn = MPdot(mp, lab) in
       check_module_type env mty;
-      (join s mty.typ_alias, add_modtype kn mty env)
-
-and check_modexpr env mse = match mse with
+      add_modtype (MPdot(mp,lab)) mty env
+	
+and check_modexpr env mse mp_mse res = match mse with
+  | SEBident mp ->
+      let mb = lookup_module mp env in
+      	(subst_and_strengthen mb mp_mse env).mod_type
+  | SEBfunctor (arg_id, mtb, body) ->
+      check_module_type env mtb ;
+      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
+      let sign = check_modexpr env' body mp_mse res in
+	SEBfunctor (arg_id, mtb, sign)
+  | SEBapply (f,m,cst) ->
+      let sign = check_modexpr env f mp_mse res in
+      let farg_id, farg_b, fbody_b = destr_functor env sign in
+      let mp =
+	try (path_of_mexpr m)
+	with Not_path -> error_application_to_not_path m
+	  (* place for nondep_supertype *) in
+      let mtb = module_type_of_module env (Some mp) (lookup_module mp env) in
+	check_subtypes env mtb farg_b;
+	(subst_struct_expr (map_mbid farg_id mp) fbody_b)
+  | SEBwith(mte, with_decl) ->
+      let sign = check_modexpr env mte mp_mse res in
+      let sign = check_with env sign with_decl mp_mse in 
+	sign
+  | SEBstruct(msb) ->
+      let _ = List.fold_left (fun env (lab,mb) ->
+		   check_structure_field env mp_mse lab res mb) env msb in
+	SEBstruct(msb)
+	
+and check_modtype env mse mp_mse res = match mse with
   | SEBident mp ->
-      let mp = scrape_alias mp env in
       let mtb = lookup_modtype mp env in
-      mtb.typ_alias
+	mtb.typ_expr
   | SEBfunctor (arg_id, mtb, body) ->
       check_module_type env mtb;
-      let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in
-      let sub = check_modexpr env' body in
-      sub
+      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
+      let body = check_modtype env' body mp_mse res in
+	SEBfunctor(arg_id,mtb,body)
   | SEBapply (f,m,cst) ->
-      let sub1 = check_modexpr env f in
-      let f'= eval_struct env f in
-      let farg_id, farg_b, fbody_b = destr_functor env f' in
+      let sign = check_modtype env f mp_mse res in
+      let farg_id, farg_b, fbody_b = destr_functor env sign in
       let mp =
-	try scrape_alias (path_of_mexpr m) env
+	try (path_of_mexpr m)
 	with Not_path -> error_application_to_not_path m
-	      (* place for nondep_supertype *) in
-      let mtb = lookup_modtype mp env in
-      check_subtypes env mtb farg_b;
-      let sub2 = match eval_struct env m with
-	| SEBstruct (msid,sign) -> 
-	    join_alias 
-	      (subst_key (map_msid msid mp) mtb.typ_alias)
-	      (map_msid msid mp)
-	| _ -> mtb.typ_alias in
-      let sub3 = join_alias sub1 (map_mbid farg_id mp) in
-      let sub4 = update_subst sub2 sub3 in
-      join sub3 sub4
+	  (* place for nondep_supertype *) in
+      let mtb = module_type_of_module env (Some mp) (lookup_module mp env) in
+	check_subtypes env mtb farg_b;
+	subst_struct_expr (map_mbid farg_id mp) fbody_b
   | SEBwith(mte, with_decl) ->
-	let sub1 = check_modexpr env mte in
-	let sub2 = check_with env mte with_decl in
-	join sub1 sub2
-  | SEBstruct(msid,msb) ->
-      let mp = MPself msid in
-      let (sub,_) =
-        List.fold_left (fun env (lab,mb) ->
-          check_structure_field env mp lab mb) (empty_subst,env) msb in
-      sub
-
+      let sign = check_modtype env mte mp_mse res in
+      let sign = check_with env sign with_decl mp_mse in
+	sign
+  | SEBstruct(msb) ->
+      let _ = List.fold_left (fun env (lab,mb) ->
+		   check_structure_field env mp_mse lab res mb) env msb in
+      SEBstruct(msb)
+	
 (*
-let rec add_struct_expr_constraints env = function
+  let rec add_struct_expr_constraints env = function
   | SEBident _ -> env
-
-  | SEBfunctor (_,mtb,meb) -> 
-      add_struct_expr_constraints 
-	(add_modtype_constraints env mtb) meb
+  
+  | SEBfunctor (_,mtb,meb) ->
+  add_struct_expr_constraints
+  (add_modtype_constraints env mtb) meb
 
   | SEBstruct (_,structure_body) ->
-      List.fold_left 
+      List.fold_left
         (fun env (l,item) -> add_struct_elem_constraints env item)
         env
         structure_body
@@ -369,20 +350,20 @@ let rec add_struct_expr_constraints env = function
   | SEBapply (meb1,meb2,cst) ->
 (*  let g = Univ.merge_constraints cst Univ.initial_universes in
 msgnl(str"ADDING FUNCTOR APPLICATION CONSTRAINTS:"++fnl()++
-      Univ.pr_universes g++str"============="++fnl());      
+      Univ.pr_universes g++str"============="++fnl());
 *)
-      Environ.add_constraints cst 
-        (add_struct_expr_constraints 
-	  (add_struct_expr_constraints env meb1) 
+      Environ.add_constraints cst
+        (add_struct_expr_constraints
+	  (add_struct_expr_constraints env meb1)
 	  meb2)
   | SEBwith(meb,With_definition_body(_,cb))->
       Environ.add_constraints cb.const_constraints
 	(add_struct_expr_constraints env meb)
   | SEBwith(meb,With_module_body(_,_,cst))->
       Environ.add_constraints cst
-	(add_struct_expr_constraints env meb)	
-		
-and add_struct_elem_constraints env = function 
+	(add_struct_expr_constraints env meb)
+
+and add_struct_elem_constraints env = function
   | SFBconst cb -> Environ.add_constraints cb.const_constraints env
   | SFBmind mib -> Environ.add_constraints mib.mind_constraints env
   | SFBmodule mb -> add_module_constraints env mb
@@ -390,18 +371,18 @@ and add_struct_elem_constraints env = function
   | SFBalias (mp,None) -> env
   | SFBmodtype mtb -> add_modtype_constraints env mtb
 
-and add_module_constraints env mb = 
+and add_module_constraints env mb =
   let env = match mb.mod_expr with
     | None -> env
     | Some meb -> add_struct_expr_constraints env meb
   in
   let env = match mb.mod_type with
     | None -> env
-    | Some mtb -> 
+    | Some mtb ->
 	add_struct_expr_constraints env mtb
   in
     Environ.add_constraints mb.mod_constraints env
 
-and add_modtype_constraints env mtb = 
+and add_modtype_constraints env mtb =
   add_struct_expr_constraints env mtb.typ_expr
 *)
diff --git a/checker/modops.ml b/checker/modops.ml
index 498bd775..458c84d8 100644
--- a/checker/modops.ml
+++ b/checker/modops.ml
@@ -18,7 +18,7 @@ open Declarations
 open Environ
 (*i*)
 
-let error_not_a_constant l = 
+let error_not_a_constant l =
   error ("\""^(string_of_label l)^"\" is not a constant")
 
 let error_not_a_functor _ = error "Application of not a functor"
@@ -32,13 +32,12 @@ let error_not_match l _ =
 
 let error_no_such_label l = error ("No such label "^string_of_label l)
 
-let error_no_such_label_sub l l1 l2 =
-  let l1 = string_of_msid l1 in
-  let l2 = string_of_msid l2 in
-  error (l1^" is not a subtype of "^l2^".\nThe field "^
-         string_of_label l^" is missing (or invisible) in "^l1^".")
+let error_no_such_label_sub l l1 =
+  let l1 = string_of_mp l1 in
+  error ("The field "^
+         string_of_label l^" is missing in "^l1^".")
 
-let error_not_a_module_loc loc s = 
+let error_not_a_module_loc loc s =
   user_err_loc (loc,"",str ("\""^string_of_label s^"\" is not a module"))
 
 let error_not_a_module s = error_not_a_module_loc dummy_loc s
@@ -56,38 +55,6 @@ let error_signature_expected mtb =
 
 let error_application_to_not_path _ = error "Application to not path"
 
-
-let module_body_of_type mtb = 
-  { mod_type = Some mtb.typ_expr;
-    mod_expr = None;
-    mod_constraints = Constraint.empty;
-    mod_alias = mtb.typ_alias;
-    mod_retroknowledge = []}
-
-let module_type_of_module mp mb =
-  {typ_expr = 
-      (match mb.mod_type with
-	| Some expr -> expr
-	| None -> (match mb.mod_expr with
-		     | Some expr -> expr
-		     | None -> 
-			 anomaly "Modops: empty expr and type"));
-   typ_alias = mb.mod_alias;
-   typ_strength = mp
-  }
-
-
-
-let rec list_split_assoc k rev_before = function
-  | [] -> raise Not_found
-  | (k',b)::after when k=k' -> rev_before,b,after
-  | h::tail -> list_split_assoc k (h::rev_before) tail
-
-let path_of_seb = function
-  | SEBident mp -> mp
-  | _ -> anomaly "Modops: evaluation failed."
-
-
 let destr_functor env mtb =
   match mtb with
   | SEBfunctor (arg_id,arg_t,body_t) ->
@@ -95,254 +62,152 @@ let destr_functor env mtb =
   | _ -> error_not_a_functor mtb
 
 
-let rec check_modpath_equiv env mp1 mp2 = 
-  if mp1=mp2 then () else
-  let mp1 = scrape_alias mp1 env in
-  let mp2 = scrape_alias mp2 env in
-    if mp1=mp2 then ()
-    else 
-      error_not_equal mp1 mp2
-
-
-
-let strengthen_const env mp l cb = 
-  match cb.const_opaque, cb.const_body with
-  | false, Some _ -> cb
-  | true, Some _ 
-  | _, None -> 
-      let const = Const (make_con mp empty_dirpath l) in 
-      let const_subs = Some (Declarations.from_val const) in
-	{cb with 
-      	   const_body = const_subs;
-	   const_opaque = false
-	}
-
-let strengthen_mind env mp l mib = match mib.mind_equiv with
-  | Some _ -> mib
-  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
+let is_functor = function
+ | SEBfunctor (arg_id,arg_t,body_t) -> true
+ | _ -> false
 
+let module_body_of_type mp mtb = 
+  { mod_mp = mp;
+    mod_type = mtb.typ_expr;
+    mod_type_alg = mtb.typ_expr_alg;
+    mod_expr = None;
+    mod_constraints = mtb.typ_constraints;
+    mod_delta = mtb.typ_delta;
+    mod_retroknowledge = []}
 
-let rec eval_struct env = function 
-  | SEBident mp -> 
-      begin
-        let mp = scrape_alias mp env in
-	let mtb =lookup_modtype mp env in
-	match mtb.typ_expr,mtb.typ_strength with
-	    mtb,None -> eval_struct env mtb
-	  | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb)
-      end
-  | SEBapply (seb1,seb2,_) -> 
-      let svb1 = eval_struct env seb1 in
-      let farg_id, farg_b, fbody_b = destr_functor env svb1 in
-      let mp = path_of_seb seb2 in
-      let mp = scrape_alias mp env in
-      let sub_alias = (lookup_modtype mp env).typ_alias in
-      let sub_alias = match eval_struct env (SEBident mp) with
-	  | SEBstruct (msid,sign) -> subst_key (map_msid msid mp) sub_alias
-	  | _ -> sub_alias in
-      let sub_alias = update_subst_alias sub_alias 
-	(map_mbid farg_id mp) in
-	eval_struct env (subst_struct_expr 
-			   (join sub_alias (map_mbid farg_id mp)) fbody_b)
-  | SEBwith (mtb,(With_definition_body _ as wdb)) ->
-      merge_with env mtb wdb empty_subst
-  | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) ->
-      let alias_in_mp =
-	(lookup_modtype mp env).typ_alias in
-	merge_with env mtb wdb alias_in_mp
-(*  | SEBfunctor(mbid,mtb,body) -> 
-      let env = add_module (MPbound mbid) (module_body_of_type mtb) env in
-	SEBfunctor(mbid,mtb,eval_struct env body) *)
-  | mtb -> mtb
-      
-and type_of_mb env mb =
-  match mb.mod_type,mb.mod_expr with
-      None,Some b -> eval_struct env b
-    | Some t, _ -> eval_struct env t
-    | _,_ -> anomaly 
-	"Modops:  empty type and empty expr" 
-	  
-and merge_with env mtb with_decl alias= 
-  let msid,sig_b = match (eval_struct env mtb) with 
-    | SEBstruct(msid,sig_b) -> msid,sig_b
-    | _ -> error_signature_expected mtb
-  in
-  let id,idl = match with_decl with 
-    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl
-    | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false
-  in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc l [] sig_b in
-      let before = List.rev rev_before in
-      let rec mp_rec = function
-	| [] -> MPself msid
-	| i::r -> MPdot(mp_rec r,label_of_id i)
-      in 
-      let new_spec,subst = match with_decl with
-        | With_definition_body ([],_)
-        | With_module_body ([],_,_,_) -> assert false
-	| With_definition_body ([id],c) -> 
-	    SFBconst c,None
-	| With_module_body ([id], mp,typ_opt,cst) ->
-	    let mp' = scrape_alias mp env in
-	      SFBalias (mp,typ_opt,Some cst),
-	    Some(join (map_mp (mp_rec [id]) mp') alias)
-	| With_definition_body (_::_,_) 
-        | With_module_body (_::_,_,_,_) -> 
-	    let old = match spec with
-		SFBmodule msb -> msb
-	      | _ -> error_not_a_module l
-	    in
-            let new_with_decl,subst1 = 
-	      match with_decl with
-                  With_definition_body (_,c) -> With_definition_body (idl,c),None
-		| With_module_body (idc,mp,t,cst) -> 
-		    With_module_body (idl,mp,t,cst),
-		      Some(map_mp (mp_rec idc) mp) 
-	    in
-	    let subst = Option.fold_right join subst1 alias in
-            let modtype = 
-              merge_with env (type_of_mb env old) new_with_decl alias in
-            let msb =
-	      { mod_expr = None;
-		mod_type = Some modtype; 
-		mod_constraints = old.mod_constraints;
-		mod_alias = subst;
-		mod_retroknowledge = old.mod_retroknowledge}
-	    in
-	      (SFBmodule msb),Some subst
-      in
-	SEBstruct(msid,  before@(l,new_spec)::
-		    (Option.fold_right subst_structure subst after))
-    with
-	Not_found -> error_no_such_label l
+let check_modpath_equiv env mp1 mp2 = 
+  if mp1=mp2 then () else
+ (*   let mb1=lookup_module  mp1 env in
+    let mb2=lookup_module mp2 env in
+      if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2)
+      then ()
+      else*) error_not_equal mp1 mp2
 
-and add_signature mp sign env = 
+let rec add_signature mp sign resolver env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
-    let con = make_con mp empty_dirpath l in
+    let con = constant_of_kn kn in
+    let mind = mind_of_delta resolver (mind_of_kn kn) in
       match elem with
-	| SFBconst cb -> Environ.add_constant con cb env
-	| SFBmind mib -> Environ.add_mind kn mib env
-	| SFBmodule mb -> 
-	    add_module (MPdot (mp,l)) mb env 
+	| SFBconst cb -> 
+	   (* let con =  constant_of_delta resolver con in*)
+	      Environ.add_constant con cb env
+	| SFBmind mib -> 
+	   (* let mind =  mind_of_delta resolver mind in*)
+	    Environ.add_mind mind mib env
+	| SFBmodule mb -> add_module mb env
 	      (* adds components as well *)
-	| SFBalias (mp1,_,cst) -> 
-	    Environ.register_alias (MPdot(mp,l)) mp1 env
-	| SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) 
-	    mtb env
+	| SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
   in
     List.fold_left add_one env sign
 
-and add_module mp mb env = 
+and add_module mb env = 
+  let mp = mb.mod_mp in
   let env = Environ.shallow_add_module mp mb env in
-  let env =
-    Environ.add_modtype mp (module_type_of_module (Some mp) mb) env
-  in
-  let mod_typ = type_of_mb env mb in
-    match mod_typ with
-      | SEBstruct (msid,sign) -> 
-	  add_signature mp (subst_signature_msid msid mp sign) env
+    match mb.mod_type with
+      | SEBstruct (sign) -> 
+	    add_signature mp sign mb.mod_delta env
       | SEBfunctor _ -> env
       | _ -> anomaly "Modops:the evaluation of the structure failed "
-	  
 
 
-and  constants_of_specification env mp sign =
- let aux (env,res) (l,elem) =
-  match elem with
-   | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
-   | SFBmind _ -> env,res
-   | SFBmodule mb ->
-       let new_env =  add_module (MPdot (mp,l)) mb env in 
-       new_env,(constants_of_modtype env (MPdot (mp,l))
-		   (type_of_mb env mb)) @ res
-   | SFBalias (mp1,_,cst) ->
-       let new_env =  register_alias (MPdot (mp,l)) mp1 env in 
-       new_env,(constants_of_modtype env (MPdot (mp,l))
-		   (eval_struct env (SEBident mp1))) @ res
-   | SFBmodtype mtb -> 
-       (* module type dans un module type. 
-	  Il faut au moins mettre mtb dans l'environnement (avec le bon 
-	  kn pour pouvoir continuer aller deplier les modules utilisant ce 
-	  mtb
-	  ex: 
-	  Module Type T1. 
-	  Module Type T2.
-	     ....
-    	    End T2.
-	  .....
-            Declare Module M : T2.
-         End T2 
-	  si on ne rajoute pas T2 dans l'environement de typage 
-	  on va exploser au moment du Declare Module
-       *)
-       let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in 
-       new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res
- in
- snd (List.fold_left aux (env,[]) sign)
+let strengthen_const env mp_from l cb resolver = 
+  match cb.const_opaque, cb.const_body with
+  | false, Some _ -> cb
+  | true, Some _ 
+  | _, None ->
+      let con = make_con mp_from empty_dirpath l in
+     (* let con =  constant_of_delta resolver con in*)
+      let const = Const con in 
+      let const_subs = Some (Declarations.from_val const) in
+	{cb with 
+	   const_body = const_subs;
+	   const_opaque = false;
+	}
+	  
 
-and constants_of_modtype env mp modtype =
-  match (eval_struct env modtype) with
-      SEBstruct (msid,sign) ->
-	constants_of_specification env mp
-	  (subst_signature_msid msid mp sign)
-    | SEBfunctor _ -> []
-    | _ -> anomaly "Modops:the evaluation of the structure failed "
+let rec strengthen_mod env mp_from mp_to mb = 
+  if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then
+    mb 
+  else
+    match mb.mod_type with
+     | SEBstruct (sign) -> 
+	 let resolve_out,sign_out = 
+	   strengthen_sig env mp_from sign mp_to mb.mod_delta in
+	   { mb with
+	       mod_expr = Some (SEBident mp_to);
+	       mod_type = SEBstruct(sign_out);
+	       mod_type_alg = mb.mod_type_alg;
+	       mod_constraints = mb.mod_constraints;
+	       mod_delta = resolve_out(*add_mp_delta_resolver mp_from mp_to 
+	       (add_delta_resolver mb.mod_delta resolve_out)*);
+	       mod_retroknowledge = mb.mod_retroknowledge}
+     | SEBfunctor _ -> mb
+     | _ -> anomaly "Modops:the evaluation of the structure failed "
+	 
+and strengthen_sig env mp_from sign mp_to resolver =
+  match sign with
+    | [] -> empty_delta_resolver,[]
+    | (l,SFBconst cb) :: rest ->
+	let item' = 
+	  l,SFBconst (strengthen_const env mp_from l cb resolver) in
+	let resolve_out,rest' =
+	  strengthen_sig env mp_from rest mp_to resolver in
+	  resolve_out,item'::rest'
+    | (_,SFBmind _ as item):: rest ->
+	let resolve_out,rest' = 
+	  strengthen_sig env mp_from rest mp_to resolver in
+	  resolve_out,item::rest'
+    | (l,SFBmodule mb) :: rest ->
+	let mp_from' = MPdot (mp_from,l) in
+	let mp_to' = MPdot(mp_to,l) in 
+	let mb_out = 
+	  strengthen_mod env mp_from' mp_to' mb in
+	let item' = l,SFBmodule (mb_out) in
+	let env' = add_module mb_out env in
+	let resolve_out,rest' = 
+	  strengthen_sig env' mp_from rest mp_to resolver in
+	  resolve_out
+	  (*add_delta_resolver resolve_out mb.mod_delta*),
+	item':: rest'
+    | (l,SFBmodtype mty as item) :: rest -> 
+	let env' = add_modtype 
+	  (MPdot(mp_from,l)) mty env
+	in
+	let resolve_out,rest' = 
+	  strengthen_sig env' mp_from rest mp_to resolver in
+	  resolve_out,item::rest'
     
-and strengthen_mtb env mp mtb =
-  let mtb1 = eval_struct env mtb in 
-  match  mtb1 with
-  | SEBfunctor _ -> mtb1
-  | SEBstruct (msid,sign) -> 
-      SEBstruct (msid,strengthen_sig env msid sign mp)
-  | _ -> anomaly "Modops:the evaluation of the structure failed "
+let strengthen env mtb mp = 
+    match mtb.typ_expr with
+      | SEBstruct (sign) -> 
+	  let resolve_out,sign_out =
+	    strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in
+	    {mtb with
+	       typ_expr = SEBstruct(sign_out);
+	       typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta
+		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)*)}
+      | SEBfunctor _ -> mtb
+      | _ -> anomaly "Modops:the evaluation of the structure failed "
 
-and strengthen_mod env mp mb = 
-  let mod_typ = type_of_mb env mb in
-    { mod_expr = mb.mod_expr;
-      mod_type = Some (strengthen_mtb env mp mod_typ);
-      mod_constraints = mb.mod_constraints;
-      mod_alias = mb.mod_alias;
-      mod_retroknowledge = mb.mod_retroknowledge}
-      
-and strengthen_sig env msid sign mp = match sign with
-  | [] -> []
-  | (l,SFBconst cb) :: rest ->
-      let item' = l,SFBconst (strengthen_const env mp l cb) in
-      let rest' = strengthen_sig env msid rest mp in
-	item'::rest'
-  | (l,SFBmind mib) :: rest ->
-      let item' = l,SFBmind (strengthen_mind env mp l mib) in
-      let rest' = strengthen_sig env msid rest mp in
-	item'::rest'
-  | (l,SFBmodule mb) :: rest ->
-      let mp' = MPdot (mp,l) in
-	let item' = l,SFBmodule (strengthen_mod env mp' mb) in
-	let env' = add_module 
-	  (MPdot (MPself msid,l)) mb env in
-        let rest' = strengthen_sig env' msid rest mp in
-	item':: rest'
-  | ((l,SFBalias (mp1,_,cst)) as item) :: rest ->
-      let env' = register_alias (MPdot(MPself msid,l)) mp1 env in
-      let rest' = strengthen_sig env' msid rest mp in
-	item::rest'
-  | (l,SFBmodtype mty as item) :: rest -> 
-      let env' = add_modtype 
-		   (MPdot((MPself msid),l)) 
-		   mty
-		   env
-      in
-      let rest' = strengthen_sig env' msid rest mp in
-	item::rest'
+let subst_and_strengthen mb mp env =
+  strengthen_mod env mb.mod_mp mp 
+    (subst_module (map_mp mb.mod_mp mp) mb)
 
-    
-let strengthen env mtb mp = strengthen_mtb env mp mtb
 
-let update_subst env mb mp =
-  match type_of_mb env mb with
-    | SEBstruct(msid,str) -> false, join_alias 
-	(subst_key (map_msid msid mp) mb.mod_alias)
-	(map_msid msid mp)
-    | _ -> true, mb.mod_alias
+let module_type_of_module env mp mb =
+  match mp with
+      Some mp ->
+	strengthen env {
+	  typ_mp = mp;
+	  typ_expr = mb.mod_type;
+	  typ_expr_alg = None;
+	  typ_constraints = mb.mod_constraints;
+	  typ_delta = mb.mod_delta} mp
+	  
+    | None ->
+	{typ_mp = mb.mod_mp;
+	 typ_expr = mb.mod_type;
+	 typ_expr_alg = None;
+	 typ_constraints = mb.mod_constraints;
+	 typ_delta = mb.mod_delta}
diff --git a/checker/modops.mli b/checker/modops.mli
index 17b063e2..4476013c 100644
--- a/checker/modops.mli
+++ b/checker/modops.mli
@@ -19,35 +19,27 @@ open Environ
 
 (* Various operations on modules and module types *)
 
-(* make the environment entry out of type *)
-val module_body_of_type : module_type_body -> module_body
+(* make the envirconment entry out of type *)
+val module_body_of_type : module_path -> module_type_body -> module_body
 
-val module_type_of_module : module_path option -> module_body -> 
-  module_type_body 
+val module_type_of_module : env -> module_path option -> module_body ->
+  module_type_body
 
-val destr_functor : 
+val destr_functor :
   env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
 
-(* Evaluation functions *)
-val eval_struct : env -> struct_expr_body -> struct_expr_body
-
-val type_of_mb : env -> module_body -> struct_expr_body
-
-(* [add_signature mp sign env] assumes that the substitution [msid]
-   $\mapsto$ [mp] has already been performed (or is not necessary, like
-   when [mp = MPself msid]) *)
-val add_signature : module_path -> structure_body -> env -> env
+val add_signature : module_path -> structure_body -> delta_resolver -> env -> env
 
 (* adds a module and its components, but not the constraints *)
-val add_module : module_path -> module_body ->  env -> env
+val add_module : module_body ->  env -> env
 
 val check_modpath_equiv : env -> module_path -> module_path -> unit
 
-val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body
+val strengthen : env -> module_type_body -> module_path -> module_type_body
 
-val update_subst : env -> module_body -> module_path -> bool * substitution
+val subst_and_strengthen : module_body -> module_path -> env -> module_body 
 
-val error_incompatible_modtypes : 
+val error_incompatible_modtypes :
   module_type_body -> module_type_body -> 'a
 
 val error_not_match : label -> structure_field_body -> 'a
@@ -57,13 +49,13 @@ val error_with_incorrect : label -> 'a
 val error_no_such_label : label -> 'a
 
 val error_no_such_label_sub :
-  label -> mod_self_id -> mod_self_id -> 'a
+  label -> module_path -> 'a
 
 val error_signature_expected : struct_expr_body -> 'a
 
 val error_not_a_constant : label -> 'a
 
-val error_not_a_module : label -> 'a 
+val error_not_a_module : label -> 'a
 
 val error_a_generative_module_expected : label -> 'a
 
diff --git a/checker/reduction.ml b/checker/reduction.ml
index c398f0a4..54b8fd48 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -86,13 +86,13 @@ 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_betadeltaiota env t =
   match t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> t
     | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t)
 
-let whd_betadeltaiota_nolet env t = 
+let whd_betadeltaiota_nolet env t =
   match t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
@@ -107,6 +107,15 @@ let beta_appvect c v =
       | _ -> applist (substl env t, stack) in
   stacklam [] c (Array.to_list v)
 
+let betazeta_appvect n c v =
+  let rec stacklam n env t stack =
+    if n = 0 then applist (substl env t, stack) else
+    match t, stack with
+        Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl
+      | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack
+      | _ -> anomaly "Not enough lambda/let's" in
+  stacklam n [] c (Array.to_list v)
+
 (********************************************************************)
 (*                         Conversion                               *)
 (********************************************************************)
@@ -139,8 +148,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 =
 
 (* Convertibility of sorts *)
 
-type conv_pb = 
-  | CONV 
+type conv_pb =
+  | CONV
   | CUMUL
 
 let sort_cmp univ pb s0 s1 =
@@ -202,7 +211,7 @@ let oracle_order fl1 fl2 =
     | _ -> false
 
 (* Conversion between  [lft1]term1 and [lft2]term2 *)
-let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = 
+let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 =
   eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[]))
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
@@ -224,7 +233,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
     (* case of leaves *)
     | (FAtom a1, FAtom a2) ->
 	(match a1, a2 with
-	   | (Sort s1, Sort s2) -> 
+	   | (Sort s1, Sort s2) ->
 	       assert (is_empty_stack v1 && is_empty_stack v2);
 	       sort_cmp univ cv_pb s1 s2
 	   | (Meta n, Meta m) ->
@@ -247,7 +256,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
     (* 2 constants, 2 local defined vars or 2 defined rels *)
     | (FFlex fl1, FFlex fl2) ->
 	(try (* try first intensional equality *)
-	  if fl1 = fl2
+	  if  eq_table_key fl1 fl2
           then convert_stacks univ infos lft1 lft2 v1 v2
           else raise NotConvertible
         with NotConvertible ->
@@ -272,15 +281,15 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
     (* only one constant, defined var or defined rel *)
     | (FFlex fl1, _)      ->
         (match unfold_reference infos fl1 with
-           | Some def1 -> 
+           | Some def1 ->
 	       eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2
            | None -> raise NotConvertible)
     | (_, FFlex fl2)      ->
         (match unfold_reference infos fl2 with
-           | Some def2 -> 
+           | Some def2 ->
 	       eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2)
            | None -> raise NotConvertible)
-	
+
     (* other constructors *)
     | (FLambda _, FLambda _) ->
         assert (is_empty_stack v1 && is_empty_stack v2);
@@ -318,7 +327,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
            let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
            let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
            convert_vect univ infos el1 el2 fty1 fty2;
-           convert_vect univ infos 
+           convert_vect univ infos
 	     (el_liftn n el1) (el_liftn n el2) fcl1 fcl2;
            convert_stacks univ infos lft1 lft2 v1 v2
          else raise NotConvertible
@@ -341,7 +350,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) =
      | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
        | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
        | (FLOCKED,_) | (_,FLOCKED) ) -> assert false
-    
+
      (* In all other cases, terms are not convertible *)
      | _ -> raise NotConvertible
 
@@ -368,9 +377,9 @@ let conv = fconv CONV
 let conv_leq = fconv CUMUL
 
 let conv_leq_vecti env v1 v2 =
-  array_fold_left2_i 
+  array_fold_left2_i
     (fun i _ t1 t2 ->
-      (try conv_leq env t1 t2 
+      (try conv_leq env t1 t2
       with (NotConvertible|Invalid_argument _) ->
         raise (NotConvertibleVect i));
       ())
@@ -382,13 +391,13 @@ let conv_leq_vecti env v1 v2 =
 
 let vm_conv = ref fconv
 let set_vm_conv f = vm_conv := f
-let vm_conv cv_pb env t1 t2 = 
-  try 
+let vm_conv cv_pb env t1 t2 =
+  try
     !vm_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
       clos_fconv cv_pb env t1 t2
-  
+
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
@@ -404,12 +413,12 @@ let hnf_prod_app env t n =
     | Prod (_,_,b) -> subst1 n b
     | _ -> anomaly "hnf_prod_app: Need a product"
 
-let hnf_prod_applist env t nl = 
+let hnf_prod_applist env t nl =
   List.fold_left (hnf_prod_app env) t nl
 
 (* Dealing with arities *)
 
-let dest_prod env = 
+let dest_prod env =
   let rec decrec env m c =
     let t = whd_betadeltaiota env c in
     match t with
@@ -417,11 +426,11 @@ let dest_prod env =
           let d = (n,None,a) in
 	  decrec (push_rel d env) (d::m) c0
       | _ -> m,t
-  in 
+  in
   decrec env empty_rel_context
 
 (* The same but preserving lets *)
-let dest_prod_assum env = 
+let dest_prod_assum env =
   let rec prodec_rec env l ty =
     let rty = whd_betadeltaiota_nolet env ty in
     match rty with
diff --git a/checker/reduction.mli b/checker/reduction.mli
index eb50ae32..81c93ee5 100644
--- a/checker/reduction.mli
+++ b/checker/reduction.mli
@@ -37,9 +37,12 @@ val vm_conv : conv_pb -> constr conversion_function
 
 (************************************************************************)
 
-(* Builds an application node, reducing beta redexes it may produce. *) 
+(* 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
+
 (* Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
 val hnf_prod_applist : env -> constr -> constr list -> constr
 
diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml
index f4ffb302..8f5d4573 100644
--- a/checker/safe_typing.ml
+++ b/checker/safe_typing.ml
@@ -30,9 +30,8 @@ let set_engagement c =
 (* full_add_module adds module with universes and constraints *)
 let full_add_module dp mb digest =
   let env = !genv in
-  let mp = MPfile dp in
   let env = add_constraints mb.mod_constraints env in
-  let env = Modops.add_module mp mb env in
+  let env = Modops.add_module mb env in
   genv := add_digest env dp digest
 
 (* Check that the engagement expected by a library matches the initial one *)
@@ -58,7 +57,7 @@ let check_imports f caller env needed =
     try
       let actual_stamp = lookup_digest env dp in
       if stamp <> actual_stamp then report_clash f caller dp
-    with Not_found -> 
+    with Not_found ->
       error ("Reference to unknown module " ^ (string_of_dirpath dp))
   in
   List.iter check needed
@@ -66,46 +65,46 @@ let check_imports f caller env needed =
 
 
 (* Remove the body of opaque constants in modules *)
-(* also remove mod_expr ? *)
+(* also remove mod_expr ? Good idea!*)
 let rec lighten_module mb =
   { mb with
     mod_expr = Option.map lighten_modexpr mb.mod_expr;
-    mod_type = Option.map lighten_modexpr mb.mod_type }
+    mod_type = lighten_modexpr mb.mod_type }
 
-and lighten_struct struc = 
+and lighten_struct struc =
   let lighten_body (l,body) = (l,match body with
     | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
-    | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x
+    | (SFBconst _ | SFBmind _ ) as x -> x
     | SFBmodule m -> SFBmodule (lighten_module m)
-    | SFBmodtype m -> SFBmodtype 
-	({m with 
+    | SFBmodtype m -> SFBmodtype
+	({m with
 	    typ_expr = lighten_modexpr m.typ_expr}))
   in
     List.map lighten_body struc
 
 and lighten_modexpr = function
   | SEBfunctor (mbid,mty,mexpr) ->
-      SEBfunctor (mbid, 
-		    ({mty with 
+      SEBfunctor (mbid,
+		    ({mty with
 			typ_expr = lighten_modexpr mty.typ_expr}),
 		  lighten_modexpr mexpr)
   | SEBident mp as x -> x
-  | SEBstruct (msid, struc) ->
-      SEBstruct (msid, lighten_struct struc)
+  | SEBstruct ( struc) ->
+      SEBstruct ( lighten_struct struc)
   | SEBapply (mexpr,marg,u) ->
       SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
   | SEBwith (seb,wdcl) ->
-      SEBwith (lighten_modexpr seb,wdcl) 
- 
+      SEBwith (lighten_modexpr seb,wdcl)
+
 let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
 
 
-type compiled_library = 
+type compiled_library =
     dir_path *
     module_body *
     (dir_path * Digest.t) list *
     engagement option
- 
+
 open Validate
 let val_deps = val_list (val_tuple"dep"[|val_dp;no_val|])
 let val_vo = val_tuple "vo" [|val_dp;val_module;val_deps;val_opt val_eng|]
@@ -119,20 +118,21 @@ let stamp_library file digest = ()
 
 (* When the module is checked, digests do not need to match, but a
    warning is issued in case of mismatch *)
-let import file (dp,mb,depends,engmt as vo) digest = 
+let import file (dp,mb,depends,engmt as vo) digest =
   Validate.apply !Flags.debug val_vo vo;
   Flags.if_verbose msgnl (str "*** vo structure validated ***");
   let env = !genv in
   check_imports msg_warning dp env depends;
   check_engagement env engmt;
-  check_module (add_constraints mb.mod_constraints env) mb;
+  check_module (add_constraints mb.mod_constraints env) mb.mod_mp mb;
   stamp_library file digest;
   (* We drop proofs once checked *)
 (*  let mb = lighten_module mb in*)
   full_add_module dp mb digest
 
 (* When the module is admitted, digests *must* match *)
-let unsafe_import file (dp,mb,depends,engmt) digest = 
+let unsafe_import file (dp,mb,depends,engmt as vo) digest =
+(*  if !Flags.debug then Validate.apply !Flags.debug val_vo vo;*)
   let env = !genv in
   check_imports (errorlabstrm"unsafe_import") dp env depends;
   check_engagement env engmt;
diff --git a/checker/subtyping.ml b/checker/subtyping.ml
index 7a6868fe..3a100c01 100644
--- a/checker/subtyping.ml
+++ b/checker/subtyping.ml
@@ -19,29 +19,28 @@ open Reduction
 open Inductive
 open Modops
 (*i*)
-open Pp      
+open Pp
 
 
 
 (* This local type is used to subtype a constant with a constructor or
    an inductive type. It can also be useful to allow reorderings in
    inductive types *)
-type namedobject = 
+type namedobject =
   | Constant of constant_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
   | Module of module_body
   | Modtype of module_type_body
-  | Alias of module_path * struct_expr_body option
 
 (* adds above information about one mutual inductive: all types and
    constructors *)
 
-let add_nameobjects_of_mib ln mib map = 
+let add_nameobjects_of_mib ln mib map =
   let add_nameobjects_of_one j oib map =
     let ip = (ln,j) in
-    let map = 
-      array_fold_right_i 
+    let map =
+      array_fold_right_i
       (fun i id map ->
         Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
       oib.mind_consnames
@@ -54,19 +53,19 @@ let add_nameobjects_of_mib ln mib map =
 
 (* creates namedobject map for the whole signature *)
 
-let make_label_map mp list = 
-  let add_one (l,e) map = 
+let make_label_map mp list =
+  let add_one (l,e) map =
    let add_map obj = Labmap.add l obj map in
    match e with
     | SFBconst cb -> add_map (Constant cb)
     | SFBmind mib ->
-       add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map
+       add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map
     | SFBmodule mb -> add_map (Module mb)
     | SFBmodtype mtb -> add_map (Modtype mtb)
-    | SFBalias (mp,t,cst) -> add_map (Alias (mp,t))
   in
     List.fold_right add_one list Labmap.empty
 
+
 let check_conv_error error f env a1 a2 =
   try
     f env a1 a2
@@ -74,20 +73,21 @@ let check_conv_error error f env a1 a2 =
       NotConvertible -> error ()
 
 (* for now we do not allow reorderings *)
-let check_inductive env msid1 l info1 mib2 spec2 = 
-  let kn = make_kn (MPself msid1) empty_dirpath l in
+let check_inductive  env mp1 l info1 mib2 spec2 subst1 subst2= 
+  let kn = make_mind  mp1 empty_dirpath l in
   let error () = error_not_match l spec2 in
   let check_conv f = check_conv_error error f in
-  let mib1 = 
+  let mib1 =
     match info1 with
       | IndType ((_,0), mib) -> mib
       | _ -> error ()
   in
+  let mib2 =  subst_mind subst2 mib2 in
   let check_inductive_type env t1 t2 =
 
     (* Due to sort-polymorphism in inductive types, the conclusions of
        t1 and t2, if in Type, are generated as the least upper bounds
-       of the types of the constructors. 
+       of the types of the constructors.
 
        By monotonicity of the infered l.u.b.  wrt subtyping (i.e.  if X:U
        |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each
@@ -114,7 +114,7 @@ let check_inductive env msid1 l info1 mib2 spec2 =
       | Type _, Type _ -> (* shortcut here *) Prop Null, Prop Null
       | (Prop _, Type _) | (Type _,Prop _) -> error ()
       | _ -> (s1, s2) in
-    check_conv conv_leq env 
+    check_conv conv_leq env
       (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
   in
 
@@ -145,7 +145,7 @@ let check_inductive env msid1 l info1 mib2 spec2 =
   check (fun mib -> mib.mind_finite);
   check (fun mib -> mib.mind_ntypes);
   assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
-  assert (Array.length mib1.mind_packets >= 1 
+  assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
 
   (* Check that the expected numbers of uniform parameters are the same *)
@@ -155,30 +155,30 @@ let check_inductive env msid1 l info1 mib2 spec2 =
   (* the inductive types and constructors types have to be convertible *)
   check (fun mib -> mib.mind_nparams);
 
-  begin 
+  (*begin
     match mib2.mind_equiv with
       | None -> ()
-      | Some kn2' -> 
+      | Some kn2' ->
 	  let kn2 = scrape_mind env kn2' in
 	  let kn1 = match mib1.mind_equiv with
 	      None -> kn
 	    | Some kn1' -> scrape_mind env kn1'
 	  in
 	    if kn1 <> kn2 then error ()
-  end;
+  end;*)
   (* we check that records and their field names are preserved. *)
   check (fun mib -> mib.mind_record);
-  if mib1.mind_record then begin 
-    let rec names_prod_letin t = match t with 
+  if mib1.mind_record then begin
+    let rec names_prod_letin t = match t with
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
       | Cast(t,_,_) -> names_prod_letin t
       | _ -> []
-    in 
+    in
     assert (Array.length mib1.mind_packets = 1);
     assert (Array.length mib2.mind_packets = 1);
-    assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); 
-    assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); 
+    assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
+    assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
     check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
   end;
   (* we first check simple things *)
@@ -187,10 +187,10 @@ let check_inductive env msid1 l info1 mib2 spec2 =
   let _ = array_map2_i check_cons_types mib1.mind_packets mib2.mind_packets
   in ()
 
-let check_constant env msid1 l info1 cb2 spec2 = 
+let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
   let error () = error_not_match l spec2 in
   let check_conv f = check_conv_error error f in
-  let check_type env t1 t2 = 
+  let check_type env t1 t2 =
 
     (* If the type of a constant is generated, it may mention
        non-variable algebraic universes that the general conversion
@@ -201,7 +201,7 @@ let check_constant env msid1 l info1 cb2 spec2 =
        Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
        Hence they don't have to be checked again *)
 
-    let t1,t2 = 
+    let t1,t2 =
       if isArity t2 then
         let (ctx2,s2) = destArity t2 in
         match s2 with
@@ -236,30 +236,31 @@ let check_constant env msid1 l info1 cb2 spec2 =
         (t1,t2) in
     check_conv conv_leq env t1 t2
   in
-
-  match info1 with
-   | Constant cb1 ->
-      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
-      (*Start by checking types*)
-      let typ1 = Typeops.type_of_constant_type env cb1.const_type in
-      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
-      check_type env typ1 typ2;
-      let con = make_con (MPself msid1) empty_dirpath l in
-      (match cb2 with
-        | {const_body=Some lc2;const_opaque=false} ->
-	    let c2 = force_constr lc2 in
-	    let c1 = match cb1.const_body with
-	      | Some lc1 -> force_constr lc1
-	      | None -> Const con
-	    in
-	       check_conv conv env c1 c2
-        | _ -> ())
-   | IndType ((kn,i),mind1) ->
-      ignore (Util.error (
-       "The kernel does not recognize yet that a parameter can be " ^
-       "instantiated by an inductive type. Hint: you can rename the " ^
-       "inductive type and give a definition to map the old name to the new " ^
-       "name."));
+    match info1 with
+      | Constant cb1 ->
+	assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+	  (*Start by checking types*)
+	  let cb1 = subst_const_body subst1 cb1 in
+	  let cb2 = subst_const_body subst2 cb2 in
+	  let typ1 = Typeops.type_of_constant_type env cb1.const_type in
+	  let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+	    check_type env typ1 typ2;
+	  let con = make_con mp1 empty_dirpath l in
+	    (match cb2 with
+               | {const_body=Some lc2;const_opaque=false} ->
+		   let c2 = force_constr lc2 in
+		   let c1 = match cb1.const_body with
+		     | Some lc1 -> force_constr lc1
+		     | None -> Const con
+		   in
+		     check_conv conv env c1 c2
+               | _ -> ())
+      | IndType ((kn,i),mind1) ->
+	  ignore (Util.error (
+		    "The kernel does not recognize yet that a parameter can be " ^
+		      "instantiated by an inductive type. Hint: you can rename the " ^
+		      "inductive type and give a definition to map the old name to the new " ^
+		      "name."));
       assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
       if cb2.const_body <> None then error () ;
       let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
@@ -278,111 +279,96 @@ let check_constant env msid1 l info1 cb2 spec2 =
        check_conv conv env ty1 ty2
    | _ -> error ()
 
-let rec check_modules env msid1 l msb1 msb2 =
-  let mp = (MPdot(MPself msid1,l)) in
-  let mty1 = module_type_of_module (Some mp) msb1 in
-  let mty2 =  module_type_of_module None msb2 in
-  check_modtypes env mty1 mty2 false
-	
+let rec check_modules  env msb1 msb2 subst1 subst2 =
+  let mty1 = module_type_of_module env None msb1 in
+  let mty2 =  module_type_of_module env None msb2 in
+    check_modtypes env mty1 mty2 subst1 subst2 false;
+ 
 
-and check_signatures env (msid1,sig1) alias (msid2,sig2') = 
-  let mp1 = MPself msid1 in
-  let env = add_signature mp1 sig1 env in 
-  let alias = update_subst_alias alias (map_msid msid2 mp1) in
-  let sig2 = subst_structure alias sig2' in
-  let sig2 = subst_signature_msid msid2 mp1 sig2 in
+and check_signatures env mp1 sig1 sig2 subst1 subst2 = 
   let map1 = make_label_map mp1 sig1 in
-  let check_one_body (l,spec2) = 
-    let info1 = 
-      try 
-	Labmap.find l map1 
-      with 
-	  Not_found -> error_no_such_label_sub l msid1 msid2
+  let check_one_body  (l,spec2) =
+    let info1 =
+      try
+	Labmap.find l map1
+      with
+	  Not_found -> error_no_such_label_sub l mp1
     in
       match spec2 with
 	| SFBconst cb2 ->
-	    check_constant env msid1 l info1 cb2 spec2
-	| SFBmind mib2 -> 
-	    check_inductive env msid1 l info1 mib2 spec2
-	| SFBmodule msb2 ->  
+	    check_constant  env mp1 l info1 cb2 spec2 subst1 subst2
+	| SFBmind mib2 ->
+	    check_inductive env mp1 l info1 mib2 spec2 subst1 subst2
+	| SFBmodule msb2 ->
 	    begin
 	      match info1 with
-		| Module msb -> check_modules env msid1 l msb msb2
-		| Alias (mp,typ_opt) ->let msb = 
-		    {mod_expr = Some (SEBident mp);
-		     mod_type = typ_opt;
-		     mod_constraints = Constraint.empty;
-		     mod_alias = (lookup_modtype mp env).typ_alias;
-		     mod_retroknowledge = []} in
-		    check_modules env msid1 l msb msb2
-		| _ -> error_not_match l spec2
-	    end
-	| SFBalias (mp,typ_opt,_) ->
-	    begin	
-	      match info1 with
-		| Alias (mp1,_) -> check_modpath_equiv env mp mp1
-		| Module msb -> 
-		    let msb1 = 
-		      {mod_expr = Some (SEBident mp);
-		       mod_type = typ_opt;
-		       mod_constraints = Constraint.empty;
-		       mod_alias = (lookup_modtype mp env).typ_alias;
-		       mod_retroknowledge = []} in
-			check_modules env msid1 l msb msb1
+		| Module msb -> check_modules env msb msb2 
+		    subst1 subst2
 		| _ -> error_not_match l spec2
 	    end
 	| SFBmodtype mtb2 ->
-	    let mtb1 = 
+	    let mtb1 =
 	      match info1 with
 		| Modtype mtb -> mtb
 		| _ -> error_not_match l spec2
 	    in
-	      check_modtypes env mtb1 mtb2 true
+	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
+	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
+	      check_modtypes  env mtb1 mtb2 subst1 subst2 true
   in
     List.iter check_one_body sig2
 
-and check_modtypes env mtb1 mtb2 equiv = 
-  if mtb1==mtb2 then () else (* just in case  :) *)
-  let mtb1',mtb2'=
-    (match mtb1.typ_strength with
-	 None -> eval_struct env mtb1.typ_expr,
-	   eval_struct env mtb2.typ_expr
-       | Some mp -> strengthen  env mtb1.typ_expr mp,
-	   eval_struct env mtb2.typ_expr) in
-      let rec check_structure env str1 str2 equiv = 
-	match str1, str2 with
-	  | SEBstruct (msid1,list1), 
-	    SEBstruct (msid2,list2) -> 
-	      check_signatures env
-		(msid1,list1) mtb1.typ_alias (msid2,list2);
-	      if equiv then
-		check_signatures env 
-		  (msid2,list2) mtb2.typ_alias  (msid1,list1) 
-	  | SEBfunctor (arg_id1,arg_t1,body_t1), 
+and check_modtypes  env mtb1 mtb2 subst1 subst2 equiv = 
+  if mtb1==mtb2 then () else 
+  let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in
+  let rec check_structure  env str1 str2 equiv subst1 subst2 = 
+	match str1,str2 with
+	  | SEBstruct (list1), 
+	    SEBstruct (list2) -> 
+	       check_signatures env
+		mtb1.typ_mp list1 list2 subst1 subst2;
+		if equiv then
+		  check_signatures  env 
+		     mtb2.typ_mp list2 list1 subst1 subst2
+		else
+		  ()
+	  | SEBfunctor (arg_id1,arg_t1,body_t1),
 	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
-	      check_modtypes env arg_t2 arg_t1 equiv;
+	       check_modtypes env 
+		arg_t2 arg_t1
+		(map_mp arg_t1.typ_mp arg_t2.typ_mp) subst2
+		equiv ;
 		(* contravariant *)
-	      let env = 
-		add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
+	      let env = add_module 
+		(module_body_of_type (MPbound arg_id2) arg_t2) env 
 	      in
-	      let body_t1' = 
-		(* since we are just checking well-typedness we do not need
-		   to expand any constant. Hence the identity resolver. *)
-		subst_struct_expr
-		  (map_mbid arg_id1 (MPbound arg_id2))
-		  body_t1
+	      let env = match body_t1 with
+		  SEBstruct str -> 
+		    add_module {mod_mp = mtb1.typ_mp;
+				mod_expr = None;
+				mod_type = body_t1;
+				mod_type_alg= None;
+				mod_constraints=mtb1.typ_constraints;
+				mod_retroknowledge = [];
+				mod_delta = mtb1.typ_delta} env
+		| _ -> env
 	      in
-		check_structure env (eval_struct env body_t1')
-		  (eval_struct env body_t2) equiv
+		check_structure env body_t1 body_t2 equiv 
+		  (join (map_mbid arg_id1 (MPbound arg_id2)) subst1)
+		  subst2
 	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
-      in 
+      in
      if mtb1'== mtb2' then ()
-     else check_structure env mtb1' mtb2' equiv
+     else check_structure  env mtb1' mtb2' equiv subst1 subst2
 
-let check_subtypes env sup super = 
+let check_subtypes env sup super =
   (*if sup<>super then*)
-  check_modtypes env sup super false
-	  
-let check_equal env sup super = 
+  let env = add_module 
+    (module_body_of_type sup.typ_mp sup) env in
+    check_modtypes env (strengthen env sup sup.typ_mp) super empty_subst 
+      (map_mp super.typ_mp sup.typ_mp) false 
+
+let check_equal env sup super =
   (*if sup<>super then*)
-  check_modtypes env sup super true
+  check_modtypes env sup super empty_subst 
+    (map_mp super.typ_mp sup.typ_mp) true
diff --git a/checker/term.ml b/checker/term.ml
index f245d155..be70b864 100644
--- a/checker/term.ml
+++ b/checker/term.ml
@@ -28,7 +28,7 @@ type metavariable = int
 type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle |
   RegularStyle
 type case_printing =
-  { ind_nargs : int; (* number of real args of the inductive type *)
+  { ind_nargs : int; (* length of the arity of the inductive type *)
     style     : case_style }
 type case_info =
   { ci_ind        : inductive;
@@ -81,7 +81,7 @@ let val_fix f =
     [|val_tuple"fix2"[|val_array val_int;val_int|];val_prec f|]
 let val_cofix f = val_tuple"pcofixpoint"[|val_int;val_prec f|]
 
-type cast_kind = VMcast | DEFAULTcast 
+type cast_kind = VMcast | DEFAULTcast
 let val_cast = val_enum "cast_kind" 2
 
 (*s*******************************************************************)
@@ -116,7 +116,7 @@ let val_constr = val_rec_sum "constr" 0 (fun val_constr -> [|
   [|val_name;val_constr;val_constr|]; (* Lambda *)
   [|val_name;val_constr;val_constr;val_constr|]; (* LetIn *)
   [|val_constr;val_array val_constr|]; (* App *)
-  [|val_kn|]; (* Const *)
+  [|val_con|]; (* Const *)
   [|val_ind|]; (* Ind *)
   [|val_cstr|]; (* Construct *)
   [|val_ci;val_constr;val_constr;val_array val_constr|]; (* Case *)
@@ -135,7 +135,7 @@ let rec strip_outer_cast c = match c with
   | _ -> c
 
 let rec collapse_appl c = match c with
-  | App (f,cl) -> 
+  | App (f,cl) ->
       let rec collapse_rec f cl2 =
         match (strip_outer_cast f) with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
@@ -171,7 +171,7 @@ let iter_constr_with_binders g f n c = match c with
   | App (c,l) -> f n c; Array.iter (f n) l
   | Evar (_,l) -> Array.iter (f n) l
   | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
-  | Fix (_,(_,tl,bl)) -> 
+  | Fix (_,(_,tl,bl)) ->
       Array.iter (f n) tl;
       Array.iter (f (iterate g (Array.length tl) n)) bl
   | CoFix (_,(_,tl,bl)) ->
@@ -183,11 +183,11 @@ exception LocalOccur
 (* (closedn n M) raises FreeVar if a variable of height greater than n
    occurs in M, returns () otherwise *)
 
-let closedn n c = 
+let closedn n c =
   let rec closed_rec n c = match c with
     | Rel m -> if m>n then raise LocalOccur
     | _ -> iter_constr_with_binders succ closed_rec n c
-  in 
+  in
   try closed_rec n c; true with LocalOccur -> false
 
 (* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
@@ -196,21 +196,21 @@ let closed0 = closedn 0
 
 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
 
-let noccurn n term = 
+let noccurn n term =
   let rec occur_rec n c = match c with
     | Rel m -> if m = n then raise LocalOccur
     | _ -> iter_constr_with_binders succ occur_rec n c
-  in 
+  in
   try occur_rec n term; true with LocalOccur -> false
 
-(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M 
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M
   for n <= p < n+m *)
 
-let noccur_between n m term = 
+let noccur_between n m term =
   let rec occur_rec n c = match c with
     | Rel(p) -> if n<=p && p<n+m then raise LocalOccur
     | _        -> iter_constr_with_binders succ occur_rec n c
-  in 
+  in
   try occur_rec n term; true with LocalOccur -> false
 
 (* Checking function for terms containing existential variables.
@@ -220,7 +220,7 @@ let noccur_between n m term =
  which may contain the CoFix variables. These occurrences of CoFix variables
  are not considered *)
 
-let noccur_with_meta n m term = 
+let noccur_with_meta n m term =
   let rec occur_rec n c = match c with
     | Rel p -> if n<=p & p<n+m then raise LocalOccur
     | App(f,cl) ->
@@ -261,18 +261,18 @@ let rec exliftn el c = match c with
 
 (* Lifting the binding depth across k bindings *)
 
-let liftn k n = 
+let liftn k n =
   match el_liftn (pred n) (el_shft k ELID) with
     | ELID -> (fun c -> c)
     | el -> exliftn el
- 
+
 let lift k = liftn k 1
 
 (*********************)
 (*   Substituting    *)
 (*********************)
 
-(* (subst1 M c) substitutes M for Rel(1) in c 
+(* (subst1 M c) substitutes M for Rel(1) in c
    we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
    M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
 
@@ -291,15 +291,15 @@ let rec lift_substituend depth s =
 let make_substituend c = { sinfo=Unknown; sit=c }
 
 let substn_many lamv n c =
-  let lv = Array.length lamv in 
+  let lv = Array.length lamv in
   if lv = 0 then c
-  else 
+  else
     let rec substrec depth c = match c with
       | Rel k     ->
           if k<=depth then c
           else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1)
           else Rel (k-lv)
-      | _ -> map_constr_with_binders succ substrec depth c in 
+      | _ -> map_constr_with_binders succ substrec depth c in
     substrec n c
 
 let substnl laml n =
@@ -362,7 +362,7 @@ let extended_rel_list n hyps =
     | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps
     | (_,Some _,_) :: hyps -> reln l (p+1) hyps
     | [] -> l
-  in 
+  in
   reln [] 1 hyps
 
 (* Iterate lambda abstractions *)
@@ -372,17 +372,17 @@ let compose_lam l b =
   let rec lamrec = function
     | ([], b)       -> b
     | ((v,t)::l, b) -> lamrec (l, Lambda (v,t,b))
-  in 
+  in
   lamrec (l,b)
 
 (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
    ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
-let decompose_lam = 
+let decompose_lam =
   let rec lamdec_rec l c = match c with
     | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
     | Cast (c,_,_)     -> lamdec_rec l c
     | _                -> l,c
-  in 
+  in
   lamdec_rec []
 
 (* Decompose lambda abstractions and lets, until finding n
@@ -390,15 +390,15 @@ let decompose_lam =
 let decompose_lam_n_assum n =
   if n < 0 then
     error "decompose_lam_n_assum: integer parameter must be positive";
-  let rec lamdec_rec l n c = 
-    if n=0 then l,c 
-    else match c with 
+  let rec lamdec_rec l n c =
+    if n=0 then l,c
+    else match c with
     | Lambda (x,t,c)  -> lamdec_rec ((x,None,t) :: l) (n-1) c
     | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: l) n c
     | Cast (c,_,_)      -> lamdec_rec l n c
     | c -> error "decompose_lam_n_assum: not enough abstractions"
-  in 
-  lamdec_rec empty_rel_context n 
+  in
+  lamdec_rec empty_rel_context n
 
 (* Iterate products, with or without lets *)
 
@@ -410,27 +410,27 @@ let mkProd_or_LetIn (na,body,t) c =
 
 let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
 
-let decompose_prod_assum = 
+let decompose_prod_assum =
   let rec prodec_rec l c =
     match c with
     | Prod (x,t,c)    -> prodec_rec ((x,None,t) :: l) c
     | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) c
     | Cast (c,_,_)    -> prodec_rec l c
     | _               -> l,c
-  in 
+  in
   prodec_rec empty_rel_context
 
 let decompose_prod_n_assum n =
   if n < 0 then
     error "decompose_prod_n_assum: integer parameter must be positive";
-  let rec prodec_rec l n c = 
+  let rec prodec_rec l n c =
     if n=0 then l,c
-    else match c with 
+    else match c with
     | Prod (x,t,c)    -> prodec_rec ((x,None,t) :: l) (n-1) c
     | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c
     | Cast (c,_,_)    -> prodec_rec l n c
     | c -> error "decompose_prod_n_assum: not enough assumptions"
-  in 
+  in
   prodec_rec empty_rel_context n
 
 
@@ -443,7 +443,7 @@ let val_arity = val_tuple"arity"[|val_rctxt;val_constr|]
 
 let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign
 
-let destArity = 
+let destArity =
   let rec prodec_rec l c =
     match c with
     | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
@@ -451,7 +451,7 @@ let destArity =
     | Cast (c,_,_)    -> prodec_rec l c
     | Sort s          -> l,s
     | _               -> anomaly "destArity: not an arity"
-  in 
+  in
   prodec_rec []
 
 let rec isArity c =
@@ -463,7 +463,7 @@ let rec isArity c =
   | _               -> false
 
 (*******************************)
-(*  alpha conversion functions *)                         
+(*  alpha conversion functions *)
 (*******************************)
 
 (* alpha conversion : ignore print names and casts *)
@@ -483,15 +483,15 @@ let compare_constr f t1 t2 =
       if Array.length l1 = Array.length l2 then
         f c1 c2 & array_for_all2 f l1 l2
       else
-        let (h1,l1) = decompose_app t1 in        
+        let (h1,l1) = decompose_app t1 in
         let (h2,l2) = decompose_app t2 in
         if List.length l1 = List.length l2 then
           f h1 h2 & List.for_all2 f l1 l2
         else false
   | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
-  | Const c1, Const c2 -> c1 = c2
-  | Ind c1, Ind c2 -> c1 = c2
-  | Construct c1, Construct c2 -> c1 = c2
+  | Const c1, Const c2 -> eq_con_chk c1 c2
+  | Ind c1, Ind c2 -> eq_ind_chk c1 c2
+  | Construct (c1,i1), Construct (c2,i2) -> i1=i2 && eq_ind_chk c1 c2
   | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
       f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
   | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
@@ -500,7 +500,7 @@ let compare_constr f t1 t2 =
       ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
   | _ -> false
 
-let rec eq_constr m n = 
+let rec eq_constr m n =
   (m==n) or
   compare_constr eq_constr m n
 
diff --git a/checker/type_errors.ml b/checker/type_errors.ml
index a96bba6a..7c014105 100644
--- a/checker/type_errors.ml
+++ b/checker/type_errors.ml
@@ -81,10 +81,10 @@ let error_assumption env j =
 let error_reference_variables env id =
   raise (TypeError (env, ReferenceVariables id))
 
-let error_elim_arity env ind aritylst c pj okinds = 
+let error_elim_arity env ind aritylst c pj okinds =
   raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
 
-let error_case_not_inductive env j = 
+let error_case_not_inductive env j =
   raise (TypeError (env, CaseNotInductive j))
 
 let error_number_branches env cj expn =
diff --git a/checker/type_errors.mli b/checker/type_errors.mli
index 2d8f8ff2..0482f2f2 100644
--- a/checker/type_errors.mli
+++ b/checker/type_errors.mli
@@ -73,11 +73,11 @@ val error_unbound_var : env -> variable -> 'a
 val error_not_type : env -> unsafe_judgment -> 'a
 
 val error_assumption : env -> unsafe_judgment -> 'a
- 
+
 val error_reference_variables : env -> constr -> 'a
 
-val error_elim_arity : 
-  env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> 
+val error_elim_arity :
+  env -> inductive -> sorts_family list -> constr -> unsafe_judgment ->
       (sorts_family * sorts_family * arity_error) option -> 'a
 
 val error_case_not_inductive : env -> unsafe_judgment -> 'a
@@ -90,11 +90,11 @@ val error_generalization : env -> name * constr -> unsafe_judgment -> 'a
 
 val error_actual_type : env -> unsafe_judgment -> constr -> 'a
 
-val error_cant_apply_not_functional : 
+val error_cant_apply_not_functional :
   env -> unsafe_judgment -> unsafe_judgment array -> 'a
 
-val error_cant_apply_bad_type : 
-  env -> int * constr * constr -> 
+val error_cant_apply_bad_type :
+  env -> int * constr * constr ->
       unsafe_judgment -> unsafe_judgment array -> 'a
 
 val error_ill_formed_rec_body :
diff --git a/checker/typeops.ml b/checker/typeops.ml
index 1832ebec..e5cf6a6d 100644
--- a/checker/typeops.ml
+++ b/checker/typeops.ml
@@ -21,9 +21,9 @@ open Environ
 let inductive_of_constructor = fst
 
 let conv_leq_vecti env v1 v2 =
-  array_fold_left2_i 
+  array_fold_left2_i
     (fun i _ t1 t2 ->
-      (try conv_leq env t1 t2 
+      (try conv_leq env t1 t2
       with NotConvertible -> raise (NotConvertibleVect i)); ())
     ()
     v1
@@ -57,18 +57,18 @@ let judge_of_prop = Sort (Type type1_univ)
 let judge_of_type u = Sort (Type (super u))
 
 (*s Type of a de Bruijn index. *)
-	  
-let judge_of_relative env n = 
+
+let judge_of_relative env n =
   try
     let (_,_,typ) = lookup_rel n env in
     lift n typ
-  with Not_found -> 
+  with Not_found ->
     error_unbound_rel env n
 
 (* Type of variables *)
 let judge_of_variable env id =
   try named_type id env
-  with Not_found -> 
+  with Not_found ->
     error_unbound_var env id
 
 (* Management of context of variables. *)
@@ -115,7 +115,7 @@ let extract_context_levels env =
 let make_polymorphic_if_arity env t =
   let params, ccl = dest_prod_assum env t in
   match ccl with
-  | Sort (Type u) -> 
+  | Sort (Type u) ->
       let param_ccls = extract_context_levels env params in
       let s = { poly_param_levels = param_ccls; poly_level = u} in
       PolymorphicArity (params,s)
@@ -141,10 +141,10 @@ let type_of_constant env cst =
 let judge_of_constant_knowing_parameters env cst paramstyp =
   let c = Const cst in
   let cb =
-    try lookup_constant cst env 
+    try lookup_constant cst env
     with Not_found ->
       failwith ("Cannot find constant: "^string_of_con cst) in
-  let _ = check_args env c cb.const_hyps in 
+  let _ = check_args env c cb.const_hyps in
   type_of_constant_knowing_parameters env cb.const_type paramstyp
 
 let judge_of_constant env cst =
@@ -159,19 +159,19 @@ let judge_of_apply env (f,funj) argjv =
         (match whd_betadeltaiota env typ with
           | Prod (_,c1,c2) ->
 	      (try conv_leq env hj c1
-	      with NotConvertible -> 
+	      with NotConvertible ->
 		error_cant_apply_bad_type env (n,c1, hj) (f,funj) argjv);
 	      apply_rec (n+1) (subst1 h c2) restjl
           | _ ->
 	      error_cant_apply_not_functional env (f,funj) argjv)
-  in 
+  in
   apply_rec 1 funj (Array.to_list argjv)
 
 (* Type of product *)
 
 let sort_of_product env domsort rangsort =
   match (domsort, rangsort) with
-    (* Product rule (s,Prop,Prop) *) 
+    (* Product rule (s,Prop,Prop) *)
     | (_,       Prop Null)  -> rangsort
     (* Product rule (Prop/Set,Set,Set) *)
     | (Prop _,  Prop Pos) -> rangsort
@@ -187,7 +187,7 @@ let sort_of_product env domsort rangsort =
     | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
     (* Product rule (Prop,Type_i,Type_i) *)
     | (Prop Null, Type _)  -> rangsort
-    (* Product rule (Type_i,Type_i,Type_i) *) 
+    (* Product rule (Type_i,Type_i,Type_i) *)
     | (Type u1, Type u2) -> Type (sup u1 u2)
 
 (* Type of a type cast *)
@@ -204,7 +204,7 @@ let judge_of_cast env (c,cj) k tj =
     match k with
     | VMcast -> vm_conv CUMUL
     | DEFAULTcast -> conv_leq in
-  try 
+  try
     conversion env cj tj
   with NotConvertible ->
     error_actual_type env (c,cj) tj
@@ -228,7 +228,7 @@ let judge_of_inductive_knowing_parameters env ind (paramstyp:constr array) =
   let (mib,mip) =
     try lookup_mind_specif env ind
     with Not_found ->
-      failwith ("Cannot find inductive: "^string_of_kn (fst ind)) in
+      failwith ("Cannot find inductive: "^string_of_mind (fst ind)) in
   check_args env c mib.mind_hyps;
   type_of_inductive_knowing_parameters env mip paramstyp
 
@@ -241,17 +241,17 @@ let judge_of_constructor env c =
   let constr = Construct c in
   let _ =
     let ((kn,_),_) = c in
-    let mib = 
+    let mib =
       try lookup_mind kn env
       with Not_found ->
-        failwith ("Cannot find inductive: "^string_of_kn (fst (fst c))) in
-    check_args env constr mib.mind_hyps in 
+        failwith ("Cannot find inductive: "^string_of_mind (fst (fst c))) in
+    check_args env constr mib.mind_hyps in
   let specif = lookup_mind_specif env (inductive_of_constructor c) in
   type_of_constructor c specif
 
 (* Case. *)
 
-let check_branch_types env (c,cj) (lfj,explft) = 
+let check_branch_types env (c,cj) (lfj,explft) =
   try conv_leq_vecti env lfj explft
   with
       NotConvertibleVect i ->
@@ -321,22 +321,22 @@ let rec execute env cstr =
 	    | Ind ind ->
 		(* Sort-polymorphism of inductive types *)
 		judge_of_inductive_knowing_parameters env ind jl
-	    | Const cst -> 
+	    | Const cst ->
 		(* Sort-polymorphism of constant *)
 		judge_of_constant_knowing_parameters env cst jl
-	    | _ -> 
+	    | _ ->
 		(* No sort-polymorphism *)
 		execute env f
 	in
         let jl = array_map2 (fun c ty -> c,ty) args jl in
 	judge_of_apply env (f,j) jl
-	    
-    | Lambda (name,c1,c2) -> 
+
+    | Lambda (name,c1,c2) ->
         let _ = execute_type env c1 in
 	let env1 = push_rel (name,None,c1) env in
-        let j' = execute env1 c2 in 
+        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
@@ -354,7 +354,7 @@ let rec execute env cstr =
         let env1 = push_rel (name,Some c1,c2) env in
         let j' = execute env1 c3 in
         subst1 c1 j'
-	  
+
     | Cast (c,k,t) ->
         let cj = execute env c in
         let _ = execute_type env t in
@@ -371,13 +371,13 @@ let rec execute env cstr =
         let pj = execute env p in
         let lfj = execute_array env lf in
         judge_of_case env ci (p,pj) (c,cj) lfj
-  
+
     | Fix ((_,i as vni),recdef) ->
         let fix_ty = execute_recdef env recdef i in
         let fix = (vni,recdef) in
         check_fix env fix;
 	fix_ty
-	  
+
     | CoFix (i,recdef) ->
         let fix_ty = execute_recdef env recdef i in
         let cofix = (i,recdef) in
@@ -391,10 +391,10 @@ let rec execute env cstr =
     | Evar _ ->
 	anomaly "the kernel does not support existential variables"
 
-and execute_type env constr = 
+and execute_type env constr =
   let j = execute env constr in
   snd (type_judgment env (constr,j))
-	  
+
 and execute_recdef env (names,lar,vdef) i =
   let larj = execute_array env lar in
   let larj = array_map2 (fun c ty -> c,ty) lar larj in
@@ -406,7 +406,7 @@ and execute_recdef env (names,lar,vdef) i =
 
 and execute_array env = Array.map (execute env)
 
-and execute_list env = List.map (execute env) 
+and execute_list env = List.map (execute env)
 
 (* Derived functions *)
 let infer env constr = execute env constr
@@ -418,7 +418,7 @@ let infer_v env cv = execute_array env cv
 let check_ctxt env rels =
   fold_rel_context (fun d env ->
     match d with
-        (_,None,ty) -> 
+        (_,None,ty) ->
           let _ = infer_type env ty in
           push_rel d env
       | (_,Some bd,ty) ->
@@ -436,7 +436,7 @@ let check_named_ctxt env ctxt =
         failwith ("variable "^string_of_id id^" defined twice")
       with Not_found -> () in
     match d with
-        (_,None,ty) -> 
+        (_,None,ty) ->
           let _ = infer_type env ty in
           push_named d env
       | (_,Some bd,ty) ->
diff --git a/checker/validate.ml b/checker/validate.ml
index 804bf7df..ab17aa7f 100644
--- a/checker/validate.ml
+++ b/checker/validate.ml
@@ -41,6 +41,8 @@ let pr_obj o = pr_obj_rec o; Format.print_newline()
 exception ValidObjError of string * Obj.t
 let fail o s = raise (ValidObjError(s,o))
 
+let ep s1 f s2 = f (s1^"/"^s2) 
+
 let apply debug f x =
   let o = Obj.repr x in
   try f o
@@ -49,7 +51,7 @@ let apply debug f x =
       print_endline ("Validation failed: "^msg);
       pr_obj obj
     end;
-    failwith "validation failed"
+    failwith "vo structure validation failed"
 
 (* data not validated *)
 let no_val (o:Obj.t) = ()
@@ -71,8 +73,7 @@ let val_block s o =
 let val_tuple s v o =
   let n = Array.length v in
   val_block ("tuple: "^s) o;
-  if Obj.size o = n then
-    Array.iteri (fun i f -> f (Obj.field o i)) v
+  if Obj.size o = n then Array.iteri (fun i f -> f (Obj.field o i)) v
   else
     fail o ("tuple:" ^s^" size found:"^string_of_int (Obj.size o))
 
@@ -88,7 +89,7 @@ let val_sum s cc vv o =
     let n = Array.length vv in
     let i = Obj.tag o in
     if i < n then val_tuple (s^"(tag "^string_of_int i^")") vv.(i) o
-    else fail o ("bad tag in (sum type) "^s^": max is "^string_of_int i))
+    else fail o ("bad tag in (sum type) "^s^": found "^string_of_int i))
   else if Obj.is_int o then
     let (n:int) = Obj.magic o in
     (if n<0 || n>=cc then
@@ -161,11 +162,14 @@ let val_uid = val_tuple "uniq_ident" [|val_int;val_str;val_dp|]
 
 let val_mp =
   val_rec_sum "module_path" 0
-    (fun vmp -> [|[|val_dp|];[|val_uid|];[|val_uid|];[|vmp;val_id|]|])
+    (fun vmp -> [|[|val_dp|];[|val_uid|];[|vmp;val_id|]|])
 
 let val_kn = val_tuple "kernel_name" [|val_mp;val_dp;val_id|]
 
-let val_ind = val_tuple "inductive"[|val_kn;val_int|]
+let val_con =
+  val_tuple "constant/mutind" [|val_kn;val_kn|]
+
+let val_ind = val_tuple "inductive"[|val_con;val_int|]
 let val_cstr = val_tuple "constructor"[|val_ind;val_int|]
 
 (* univ *)
diff --git a/config/Makefile.template b/config/Makefile.template
index 4d45f1b4..74ec9580 100644
--- a/config/Makefile.template
+++ b/config/Makefile.template
@@ -135,15 +135,12 @@ COQDOCDIR="COQDOCDIRECTORY"
 # Win32 systems: true (actually strip is bogus)
 STRIP=STRIPCOMMAND
 
-# Options for fsets (all/basic)
-FSETS=FSETSOPT
-
-# Options for reals (all/basic)
-REALS=REALSOPT
-
 # CoqIde (no/byte/opt)
 HASCOQIDE=COQIDEOPT
 
+# IM files
+UIMSCRIPTDIR=UIMSCRIPTPATH
+
 # Defining REVISION
 CHECKEDOUT=CHECKEDOUTSOURCETREE
 
diff --git a/config/coq_config.mli b/config/coq_config.mli
index 0dc4a6a8..2cd1e454 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.mli
@@ -6,19 +6,33 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq_config.mli 12104 2009-04-24 18:10:10Z notin $ i*)
+(*i $Id$ i*)
 
 val local : bool        (* local use (no installation) *)
 
 val coqlib : string     (* where the std library is installed *)
 val coqsrc : string     (* where are the sources *)
 
+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 ocamllex : string
+
 val camlbin : string    (* base directory of OCaml binaries *)
 val camllib : string    (* for Dynlink *)
 
 val camlp4 : string     (* exact name of camlp4: either "camlp4" ou "camlp5" *)
+val camlp4o : string    (* name of the camlp4o/camlp5o executable *)
 val camlp4bin : string  (* base directory for Camlp4/5 binaries *)
 val camlp4lib : string  (* where is the library of Camlp4 *)
+val camlp4compat : string (* compatibility argument to camlp4/5 *)
+
+val coqideincl : string (* arguments for building coqide (e.g. lablgtk) *)
+val cflags : string     (* arguments passed to gcc *)
 
 val best : string       (* byte/opt *)
 val arch : string       (* architecture *)
@@ -36,7 +50,7 @@ val vo_magic_number : int
 val state_magic_number : int
 
 val theories_dirs : string list
-val contrib_dirs : string list
+val plugins_dirs : string list
 
 val exec_extension : string (* "" under Unix, ".exe" under MS-windows *)
 val with_geoproof : bool ref (* to (de)activate functions specific to Geoproof with Coqide *)
@@ -45,8 +59,13 @@ val browser : string
 (** default web browser to use, may be overriden by environment
     variable COQREMOTEBROWSER *)
 
+val has_coqide : string
+
+val has_natdynlink : bool
+val natdynlinkflag : string (* special cases of natdynlink (e.g. MacOS 10.5) *)
+
 val wwwcoq : string
 val wwwrefman : string
 val wwwstdlib : string
+val localwwwrefman : string
 
-val has_natdynlink : bool
diff --git a/config/giveostype.ml b/config/giveostype.ml
deleted file mode 100644
index e657bc79..00000000
--- a/config/giveostype.ml
+++ /dev/null
@@ -1 +0,0 @@
-print_string Sys.os_type;;
diff --git a/configure b/configure
index db7a55a0..fb6dac1e 100755
--- a/configure
+++ b/configure
@@ -6,9 +6,9 @@
 # 
 ##################################
 
-VERSION=8.2pl2
-VOMAGIC=08200
-STATEMAGIC=58200
+VERSION=8.3-bugfix
+VOMAGIC=08300
+STATEMAGIC=58300
 DATE=`LANG=C date +"%B %Y"`
 
 # Create the bin/ directory if non-existent
@@ -63,11 +63,12 @@ usage () {
     printf "\tSpecifies the architecture\n"
     echo "-opt"
     printf "\tSpecifies whether or not to use OCaml *.opt optimized compilers\n"
-    echo "-fsets (all|basic)"
-    echo "-reals (all|basic)"
-    printf "\tSpecifies whether or not to compile full FSets/Reals library\n"
+    echo "-natdynlink (yes|no)"
+    printf "\tSpecifies whether or not to use dynamic loading of native code\n"
     echo "-coqide (opt|byte|no)"
     printf "\tSpecifies whether or not to compile Coqide\n"
+    echo "-uim-script-path"
+    printf "\tSpecifies where uim's .scm files are installed\n"
     echo "-browser <command>"
     printf "\tUse <command> to open URL %%s\n"
     echo "-with-doc (yes|no)"
@@ -108,6 +109,7 @@ coq_profile_flag=
 coq_annotate_flag=
 best_compiler=opt
 cflags="-fno-defer-pop -Wall -Wno-unused"
+natdynlink=yes
 
 gcc_exec=gcc
 ar_exec=ar
@@ -128,8 +130,6 @@ emacs_spec=no
 camldir_spec=no
 lablgtkdir_spec=no
 coqdocdir_spec=no
-fsets=all
-reals=all
 arch_spec=no
 coqide_spec=no
 browser_spec=no
@@ -137,6 +137,8 @@ wwwcoq_spec=no
 with_geoproof=false
 with_doc=all
 with_doc_spec=no
+force_caml_version=no
+force_caml_version_spec=no
 
 COQSRC=`pwd`
 
@@ -198,16 +200,11 @@ while : ; do
     -opt|--opt) bytecamlc=ocamlc.opt
                 camlp4oexec=camlp4o  # can't add .opt since dyn load'll be required
                 nativecamlc=ocamlopt.opt;;
-    -fsets|--fsets) case "$2" in
-			yes|all) fsets=all;;
-			*) fsets=basic
-		    esac
-		    shift;;
-    -reals|--reals) case "$2" in
-			yes|all) reals=all;;
-			*) reals=basic
-		    esac
-		    shift;;
+    -natdynlink|--natdynlink) case "$2" in
+	                  yes) natdynlink=yes;;
+                          *) natdynlink=no
+                        esac
+                        shift;;
     -coqide|--coqide) coqide_spec=yes
 		      case "$2" in
 			  byte|opt) COQIDE=$2;;
@@ -227,7 +224,7 @@ while : ; do
 		      esac
 		      shift;;
     -with-geoproof|--with-geoproof) 
-	  case $2 in
+	  case "$2" in
 	      yes) with_geoproof=true;;
 	      no) with_geoproof=false;;
 	  esac
@@ -248,13 +245,19 @@ while : ; do
     -debug|--debug) coq_debug_flag=-g;;
     -profile|--profile) coq_profile_flag=-p;;
     -annotate|--annotate) coq_annotate_flag=-dtypes;;
+    -force-caml-version|--force-caml-version|-force-ocaml-version|--force-ocaml-version) 
+          force_caml_version_spec=yes
+	  force_caml_version=yes;;
+    -uim-script-path)
+          uim_script_path=$2
+          shift;;
     *) echo "Unknown option \"$1\"." 1>&2; usage; exit 2;;
   esac
   shift
 done
 
 if [ $prefix_spec = yes -a $local = true ] ; then
-  echo "Options -prefix and -local are incompatible"
+  echo "Options -prefix and -local are incompatible."
   echo "Configure script failed!"
   exit 1
 fi
@@ -288,7 +291,7 @@ case $arch_spec in
  	elif test -x /usr/bin/uname ; then
  	    ARCH=`/usr/bin/uname -s`
 	else
-	    echo "I can not automatically find the name of your architecture"
+	    echo "I can not automatically find the name of your architecture."
 	    printf "%s"\
 		"Give me a name, please [win32 for Win95, Win98 or WinNT]: "
 	    read ARCH
@@ -334,7 +337,7 @@ if [ "$MAKE" != "" ]; then
 	  if [ "$MAKEVERSION" = "GNU Make 3.81" ]; then OK="yes"; fi
       fi
       if [ $OK = "no" ]; then
-	  echo "GNU Make >= 3.81 is needed"
+	  echo "GNU Make >= 3.81 is needed."
 	  echo "Make 3.81 can be downloaded from ftp://ftp.gnu.org/gnu/make/make-3.81.tar.gz"
 	  echo "then locally installed on a Unix-style system by issuing:"
 	  echo "  tar xzvf make-3.81.tar.gz"
@@ -343,14 +346,14 @@ if [ "$MAKE" != "" ]; then
           echo "  make"
           echo "  mv make .."
 	  echo "  cd .."
-	  echo "Restart then the configure script and later use ./make instead of make"
+	  echo "Restart then the configure script and later use ./make instead of make."
 	  exit 1
       else
 	  echo "You have locally installed GNU Make 3.81. Good!"
       fi
   esac
 else
-  echo "Cannot find GNU Make 3.81"
+  echo "Cannot find GNU Make 3.81."
 fi
 
 # Browser command
@@ -400,7 +403,7 @@ case $camldir_spec in
 esac
 
 if test ! -f "$CAMLC" ; then
-    echo "I can not find the executable '$CAMLC'! (Have you installed it?)"
+    echo "I can not find the executable '$CAMLC'. Have you installed it?"
     echo "Configuration script failed!"
     exit 1
 fi
@@ -410,24 +413,18 @@ case $ARCH in
     win32) CAMLBIN=`cygpath -m ${CAMLBIN}`;;
 esac
 
-# this fixes a camlp4 bug under FreeBSD
-# ("native-code program cannot do a dynamic load")
-if [ `uname -s` = "FreeBSD" ]; then camlp4oexec=$camlp4oexec.byte; fi
-
 CAMLVERSION=`"$bytecamlc" -version`
 
 case $CAMLVERSION in
-    1.*|2.*|3.00|3.01|3.02|3.03|3.03alpha|3.04|3.05beta|3.05|3.06|3.08.0)
+    1.*|2.*|3.00|3.01|3.02|3.03|3.03alpha|3.04|3.05beta|3.05|3.06|3.07*|3.08*|3.09.[012])
 	echo "Your version of Objective-Caml is $CAMLVERSION."
-	if [ "$CAMLVERSION" = "3.08.0" ] ; then
-	    echo "You need Objective-Caml 3.07 or later (to the exception of 3.08.0)!"
+	if [ "$force_caml_version" = "yes" ]; then
+	    echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml."
 	else
-	    echo "You need Objective-Caml 3.07 or later!"
-	fi
-	echo "Configuration script failed!"
-	exit 1;;
-    3.07*|3.08*)
-	echo "You have Objective-Caml $CAMLVERSION. Good!";;
+	    echo "          You need Objective-Caml 3.09.3 or later."
+	    echo "          Configuration script failed!"
+	    exit 1
+	fi;;
     ?*)
 	CAMLP4COMPAT="-loc loc" 
 	echo "You have Objective-Caml $CAMLVERSION. Good!";;
@@ -449,7 +446,7 @@ case $ARCH in
       CAMLLIB=`"$CAMLC" -where`
 esac
 
-# We need to set va special flag for OCaml 3.07
+# We need to set a special flag for OCaml 3.07
 case  $CAMLVERSION in 
 	3.07*)
 	  cflags="$cflags -DOCAML_307";;
@@ -465,19 +462,42 @@ if [ "$coq_debug_flag" = "-g" ]; then
 fi
 
 # Native dynlink
-if test -f `"$CAMLC" -where`/dynlink.cmxa; then
+if [ "$natdynlink" = "yes" -a -f `"$CAMLC" -where`/dynlink.cmxa ]; then
     HASNATDYNLINK=true
 else
     HASNATDYNLINK=false
 fi
 
+case $HASNATDYNLINK,`uname -s`,`uname -r`,$CAMLVERSION in
+    true,Darwin,9.*,3.11.*)  # ocaml 3.11.0 dynlink on MacOS 10.5 is buggy
+        NATDYNLINKFLAG=os5fixme;;
+    #Possibly a problem on 10.6.0/10.6.1/10.6.2
+    #May just be a 32 vs 64 problem for all 10.6.*
+    true,Darwin,10.0.*,3.11.*) # Possibly a problem on 10.6.0
+        NATDYNLINKFLAG=os5fixme;;
+    true,Darwin,10.1.*,3.11.*) # Possibly a problem on 10.6.1
+        NATDYNLINKFLAG=os5fixme;;
+    true,Darwin,10.2.*,3.11.*) # Possibly a problem on 10.6.2
+        NATDYNLINKFLAG=os5fixme;;
+    true,Darwin,10.*,3.11.*)
+        if [ `getconf LONG_BIT` = "32" ]; then
+	    # Still a problem for x86_32
+            NATDYNLINKFLAG=os5fixme
+        else
+	    # Not a problem for x86_64
+            NATDYNLINKFLAG=$HASNATDYNLINK
+        fi;;
+    *)
+        NATDYNLINKFLAG=$HASNATDYNLINK;;
+esac
+
 # Camlp4 / Camlp5 configuration
 
 if [ "$camlp5dir" != "" ]; then
     CAMLP4=camlp5
     CAMLP4LIB=$camlp5dir
     if [ ! -f $camlp5dir/camlp5.cma ]; then
-	echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)"
+	echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)."
 	echo "Configuration script failed!"
 	exit 1
     fi
@@ -632,11 +652,14 @@ case $COQIDE in
     no) LABLGTKINCLUDES="";;
 esac
 
-# Tell on windows if ocaml understands cygwin or windows path formats
-
-#"$CAMLC" -o config/giveostype config/giveostype.ml
-#CAMLOSTYPE=`config/giveostype`
-#rm config/giveostype
+if which uim-fep; then
+    for cand in i"$uim_script_path" /usr/local/share/uim/ /usr/share/uim/; do
+        if [ -f "$cand/loader.scm" ]; then
+            UIMSCRIPTDIR=$cand
+            break
+        fi
+    done
+fi
 
 # strip command
 
@@ -747,13 +770,13 @@ case $mandir_spec/$prefix_spec/$local in
 esac
 
 case $docdir_spec/$prefix_spec/$local in
-    yes/*/*) DOCDIR=$docdir;;
-    */yes/*) DOCDIR=$prefix/share/doc/coq ;;
-    */*/true) DOCDIR=$COQTOP/man ;;
+    yes/*/*) DOCDIR=$docdir; HTMLREFMANDIR=$DOCDIR/html/refman;;
+    */yes/*) DOCDIR=$prefix/share/doc/coq; HTMLREFMANDIR=$DOCDIR/html/refman;;
+    */*/true) DOCDIR=$COQTOP/doc; HTMLREFMANDIR=$DOCDIR/refman/html;;
     *)  printf "Where should I install the Coq documentation [$docdir_def]? "
         read DOCDIR
 	case $DOCDIR in
-	    "") DOCDIR=$docdir_def;;
+	    "") DOCDIR=$docdir_def; HTMLREFMANDIR=$DOCDIR/html/refman;;
 	    *) true;;
 	esac;;
 esac
@@ -822,6 +845,8 @@ esac
 #     yes) EMACS=$emacs;;
 # esac
 
+
+
 ###########################################
 # Summary of the configuration
 
@@ -838,19 +863,12 @@ echo "  Objective-Caml/Camlp4 version     : $CAMLVERSION"
 echo "  Objective-Caml/Camlp4 binaries in : $CAMLBIN"
 echo "  Objective-Caml library in         : $CAMLLIB"
 echo "  Camlp4 library in                 : $CAMLP4LIB"
+if test "$best_compiler" = opt ; then
+echo "  Native dynamic link support       : $HASNATDYNLINK"
+fi
 if test "$COQIDE" != "no"; then
 echo "  Lablgtk2 library in               : $LABLGTKLIB"
 fi
-if test "$fsets" = "all"; then
-echo "  FSets theory                      : All"
-else
-echo "  FSets theory                      : Basic"
-fi
-if test "$reals" = "all"; then
-echo "  Reals theory                      : All"
-else
-echo "  Reals theory                      : Basic"
-fi
 if test "$with_doc" = "all"; then
 echo "  Documentation                     : All"
 else
@@ -869,9 +887,51 @@ echo "    documentation will be copied in $DOCDIR"
 echo "    emacs mode    will be copied in $EMACSLIB"
 echo ""
 
-#####################################################
-# Building the $COQTOP/config/coq_config.ml file
-#####################################################
+##################################################
+# Building the $COQTOP/dev/ocamldebug-coq file
+##################################################
+
+OCAMLDEBUGCOQ=$COQSRC/dev/ocamldebug-coq
+
+if test "$coq_debug_flag" = "-g" ; then
+  rm -f $OCAMLDEBUGCOQ
+  sed -e "s|COQTOPDIRECTORY|$COQTOP|" \
+      -e "s|COQLIBDIRECTORY|$LIBDIR|" \
+      -e "s|CAMLBINDIRECTORY|$CAMLBIN|" \
+      -e "s|CAMLP4LIBDIRECTORY|$FULLCAMLP4LIB|"\
+      $OCAMLDEBUGCOQ.template > $OCAMLDEBUGCOQ
+  chmod a-w,a+x $OCAMLDEBUGCOQ
+fi
+
+####################################################
+# Fixing lablgtk types (before/after 2.6.0) 
+####################################################
+
+if [ ! "$COQIDE" = "no" ]; then 
+    if grep "class view " "$lablgtkdir/gText.mli" | grep -q "\[>" ; then
+       if grep -q "?accepts_tab:bool" "$lablgtkdir/gText.mli" ; then
+        cp -f ide/undo_lablgtk_ge212.mli ide/undo.mli
+       else
+	cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli
+       fi
+    else
+	cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli
+    fi
+fi  
+
+##############################################
+# Creation of configuration files
+##############################################
+
+mlconfig_file="$COQSRC/config/coq_config.ml"
+config_file="$COQSRC/config/Makefile"
+config_template="$COQSRC/config/Makefile.template"
+
+
+### Warning !!
+### After this line, be careful when using variables,
+### since some of them (e.g. $COQSRC) will be escaped
+
 
 # An escaped version of a variable
 escape_var () {
@@ -882,64 +942,73 @@ EOF
 
 # Escaped version of browser command
 export BROWSER
-ESCBROWSER=`VAR=BROWSER escape_var`
+BROWSER=`VAR=BROWSER escape_var`
 
 # damned backslashes under M$Windows
 case $ARCH in
     win32)
-	ESCCOQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'`
-	ESCBINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
-	ESCSRCDIR=`cygpath -m $COQSRC |sed -e 's|\\\|\\\\\\\|g'`
-	ESCLIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
-	ESCCAMLDIR=`echo $CAMLBIN |sed -e 's|\\\|\\\\\\\|g'`
-	ESCCAMLLIB=`echo $CAMLLIB |sed -e 's|\\\|\\\\\\\|g'`
-  	ESCMANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
-  	ESCDOCDIR=`echo $DOCDIR |sed -e 's|\\\|\\\\\\\|g'`
-   	ESCEMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
-   	ESCCOQDOCDIR=`echo $COQDOCDIR |sed -e 's|\\\|\\\\\\\|g'`
-   	ESCCAMLP4BIN=`echo $CAMLP4BIN |sed -e 's|\\\|\\\\\\\|g'`
-	ESCCAMLP4LIB=`echo $CAMLP4LIB |sed -e 's|\\\|\\\\\\\|g'`
-	ESCLABLGTKINCLUDES=`echo $LABLGTKINCLUDES |sed -e 's|\\\|\\\\\\\|g'`
-	ESCCOQRUNBYTEFLAGS=`echo $COQRUNBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'`
-	ESCCOQTOOLSBYTEFLAGS=`echo $COQTOOLSBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'`
-	ESCBUILDLDPATH=`echo $BUILDLDPATH |sed -e 's|\\\|\\\\\\\|g'`
-;;
-    *)
-        ESCCOQTOP="$COQTOP"
-	ESCBINDIR="$BINDIR"
-	ESCSRCDIR="$COQSRC"
-	ESCLIBDIR="$LIBDIR"
-	ESCCAMLDIR="$CAMLBIN"
-	ESCCAMLLIB="$CAMLLIB"
-  	ESCMANDIR="$MANDIR"
-  	ESCDOCDIR="$DOCDIR"
-   	ESCEMACSLIB="$EMACSLIB"
-   	ESCCOQDOCDIR="$COQDOCDIR"
-   	ESCCAMLP4BIN="$CAMLP4BIN"
-   	ESCCAMLP4LIB="$CAMLP4LIB"
-	ESCLABLGTKINCLUDES="$LABLGTKINCLUDES"
-	ESCCOQRUNBYTEFLAGS="$COQRUNBYTEFLAGS"
-	ESCCOQTOOLSBYTEFLAGS="$COQTOOLSBYTEFLAGS"
-	;;
+	COQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'`
+	BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
+	COQSRC=`cygpath -m $COQSRC |sed -e 's|\\\|\\\\\\\|g'`
+	LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
+	CAMLBIN=`echo $CAMLBIN |sed -e 's|\\\|\\\\\\\|g'`
+	CAMLLIB=`echo $CAMLLIB |sed -e 's|\\\|\\\\\\\|g'`
+	MANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
+	DOCDIR=`echo $DOCDIR |sed -e 's|\\\|\\\\\\\|g'`
+	EMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
+	COQDOCDIR=`echo $COQDOCDIR |sed -e 's|\\\|\\\\\\\|g'`
+	CAMLP4BIN=`echo $CAMLP4BIN |sed -e 's|\\\|\\\\\\\|g'`
+	CAMLP4LIB=`echo $CAMLP4LIB |sed -e 's|\\\|\\\\\\\|g'`
+	LABLGTKINCLUDES=`echo $LABLGTKINCLUDES |sed -e 's|\\\|\\\\\\\|g'`
+	COQRUNBYTEFLAGS=`echo $COQRUNBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'`
+	COQTOOLSBYTEFLAGS=`echo $COQTOOLSBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'`
+	BUILDLDPATH=`echo $BUILDLDPATH |sed -e 's|\\\|\\\\\\\|g'`
+	ocamlexec=`echo $ocamlexec |sed -e 's|\\\|\\\\\\\|g'`
+	bytecamlc=`echo $bytecamlc |sed -e 's|\\\|\\\\\\\|g'`
+	nativecamlc=`echo $nativecamlc |sed -e 's|\\\|\\\\\\\|g'`
+	ocamlmklibexec=`echo $ocamlmklibexec |sed -e 's|\\\|\\\\\\\|g'`
+	ocamldepexec=`echo $ocamldepexec |sed -e 's|\\\|\\\\\\\|g'`
+	ocamldocexec=`echo $ocamldocexec |sed -e 's|\\\|\\\\\\\|g'`
+	ocamllexexec=`echo $ocamllexexec |sed -e 's|\\\|\\\\\\\|g'`
+	ocamlyaccexec=`echo $ocamlyaccexec |sed -e 's|\\\|\\\\\\\|g'`
+	camlp4oexec=`echo $camlp4oexec |sed -e 's|\\\|\\\\\\\|g'`
+    ;;
 esac
 
-mlconfig_file="$COQSRC/config/coq_config.ml"
+#####################################################
+# Building the $COQTOP/config/coq_config.ml file
+#####################################################
+
 rm -f "$mlconfig_file"
 cat << END_OF_COQ_CONFIG > $mlconfig_file
 (* DO NOT EDIT THIS FILE: automatically generated by ../configure *)
 
 let local = $local
-let coqrunbyteflags = "$ESCCOQRUNBYTEFLAGS"
-let coqlib = "$ESCLIBDIR"
-let coqsrc = "$ESCSRCDIR"
-let camlbin = "$ESCCAMLDIR"
-let camllib = "$ESCCAMLLIB"
+let coqrunbyteflags = "$COQRUNBYTEFLAGS"
+let coqlib = "$LIBDIR"
+let coqsrc = "$COQSRC"
+let ocaml = "$ocamlexec"
+let ocamlc = "$bytecamlc"
+let ocamlopt = "$nativecamlc"
+let ocamlmklib = "$ocamlmklibexec"
+let ocamldep = "$ocamldepexec"
+let ocamldoc = "$ocamldocexec"
+let ocamlyacc = "$ocamlyaccexec"
+let ocamllex = "$ocamllexexec"
+let camlbin = "$CAMLBIN"
+let camllib = "$CAMLLIB"
 let camlp4 = "$CAMLP4"
-let camlp4bin = "$ESCCAMLP4BIN"
-let camlp4lib = "$ESCCAMLP4LIB"
+let camlp4o = "$camlp4oexec"
+let camlp4bin = "$CAMLP4BIN"
+let camlp4lib = "$CAMLP4LIB"
+let camlp4compat = "$CAMLP4COMPAT"
+let coqideincl = "$LABLGTKINCLUDES"
+let cflags = "$cflags"
 let best = "$best_compiler"
 let arch = "$ARCH"
+let has_coqide = "$COQIDE"
 let has_natdynlink = $HASNATDYNLINK
+let natdynlinkflag = "$NATDYNLINKFLAG"
 let osdeplibs = "$OSDEPLIBS"
 let version = "$VERSION"
 let caml_version = "$CAMLVERSION"
@@ -949,10 +1018,11 @@ let vo_magic_number = $VOMAGIC
 let state_magic_number = $STATEMAGIC
 let exec_extension = "$EXE"
 let with_geoproof = ref $with_geoproof
-let browser = "$ESCBROWSER"
+let browser = "$BROWSER"
 let wwwcoq = "$WWWCOQ"
 let wwwrefman = wwwcoq ^ "distrib/" ^ version ^ "/refman/"
 let wwwstdlib = wwwcoq ^ "distrib/" ^ version ^ "/stdlib/"
+let localwwwrefman = "file://$HTMLREFMANDIR/"
 
 END_OF_COQ_CONFIG
 
@@ -961,15 +1031,15 @@ PRINTF=`which printf`
 
 # Subdirectories of theories/ added in coq_config.ml
 subdirs () {
-    (cd $1; find * \( -name .svn -prune \) -o \( -type d -exec $PRINTF "\"%s\";\n" {} \; \) | grep -v correctness >> "$mlconfig_file")
+    (cd $1; find * \( -name .svn -prune \) -o \( -type d -exec $PRINTF "\"%s\";\n" {} \; \) >> "$mlconfig_file")
 }
 
 echo "let theories_dirs = [" >> "$mlconfig_file"
 subdirs theories
 echo "]" >> "$mlconfig_file"
 
-echo "let contrib_dirs = [" >> "$mlconfig_file"
-subdirs contrib
+echo "let plugins_dirs = [" >> "$mlconfig_file"
+subdirs plugins
 echo "]" >> "$mlconfig_file"
 
 chmod a-w "$mlconfig_file"
@@ -979,32 +1049,32 @@ chmod a-w "$mlconfig_file"
 # Building the $COQTOP/config/Makefile file
 ###############################################
 
-rm -f "$COQSRC/config/Makefile"
+rm -f "$config_file"
 
 sed -e "s|LOCALINSTALLATION|$local|" \
-    -e "s|XCOQRUNBYTEFLAGS|$ESCCOQRUNBYTEFLAGS|" \
-    -e "s|XCOQTOOLSBYTEFLAGS|$ESCCOQTOOLSBYTEFLAGS|" \
+    -e "s|XCOQRUNBYTEFLAGS|$COQRUNBYTEFLAGS|" \
+    -e "s|XCOQTOOLSBYTEFLAGS|$COQTOOLSBYTEFLAGS|" \
     -e "s|COQSRCDIRECTORY|$COQSRC|" \
     -e "s|COQVERSION|$VERSION|" \
-    -e "s|BINDIRDIRECTORY|$ESCBINDIR|" \
-    -e "s|COQLIBDIRECTORY|$ESCLIBDIR|" \
-    -e "s|BUILDLDPATH=|$ESCBUILDLDPATH|" \
-    -e "s|MANDIRDIRECTORY|$ESCMANDIR|" \
-    -e "s|DOCDIRDIRECTORY|$ESCDOCDIR|" \
-    -e "s|EMACSLIBDIRECTORY|$ESCEMACSLIB|" \
+    -e "s|BINDIRDIRECTORY|$BINDIR|" \
+    -e "s|COQLIBDIRECTORY|$LIBDIR|" \
+    -e "s|BUILDLDPATH=|$BUILDLDPATH|" \
+    -e "s|MANDIRDIRECTORY|$MANDIR|" \
+    -e "s|DOCDIRDIRECTORY|$DOCDIR|" \
+    -e "s|EMACSLIBDIRECTORY|$EMACSLIB|" \
     -e "s|EMACSCOMMAND|$EMACS|" \
-    -e "s|COQDOCDIRECTORY|$ESCCOQDOCDIR|" \
+    -e "s|COQDOCDIRECTORY|$COQDOCDIR|" \
     -e "s|MKTEXLSRCOMMAND|$MKTEXLSR|" \
     -e "s|ARCHITECTURE|$ARCH|" \
     -e "s|OSDEPENDENTLIBS|$OSDEPLIBS|" \
     -e "s|OSDEPENDENTP4OPTFLAGS|$OSDEPP4OPTFLAGS|" \
-    -e "s|CAMLLIBDIRECTORY|$ESCCAMLLIB|" \
+    -e "s|CAMLLIBDIRECTORY|$CAMLLIB|" \
     -e "s|CAMLTAG|$CAMLTAG|" \
-    -e "s|CAMLP4BINDIRECTORY|$ESCCAMLP4BIN|" \
+    -e "s|CAMLP4BINDIRECTORY|$CAMLP4BIN|" \
     -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \
     -e "s|CAMLP4TOOL|$camlp4oexec|" \
     -e "s|CAMLP4COMPATFLAGS|$CAMLP4COMPAT|" \
-    -e "s|LABLGTKINCLUDES|$ESCLABLGTKINCLUDES|" \
+    -e "s|LABLGTKINCLUDES|$LABLGTKINCLUDES|" \
     -e "s|COQDEBUGFLAGOPT|$coq_debug_flag_opt|" \
     -e "s|COQDEBUGFLAG|$coq_debug_flag|" \
     -e "s|COQPROFILEFLAG|$coq_profile_flag|" \
@@ -1026,55 +1096,22 @@ sed -e "s|LOCALINSTALLATION|$local|" \
     -e "s|AREXEC|$ar_exec|" \
     -e "s|RANLIBEXEC|$ranlib_exec|" \
     -e "s|STRIPCOMMAND|$STRIPCOMMAND|" \
-    -e "s|FSETSOPT|$fsets|" \
-    -e "s|REALSOPT|$reals|" \
     -e "s|COQIDEOPT|$COQIDE|" \
     -e "s|CHECKEDOUTSOURCETREE|$checkedout|" \
     -e "s|WITHDOCOPT|$with_doc|" \
-    -e "s|HASNATIVEDYNLINK|$HASNATDYNLINK|" \
-      "$COQSRC/config/Makefile.template" > "$COQSRC/config/Makefile"
-
-chmod a-w "$COQSRC/config/Makefile"
-
-##################################################
-# Building the $COQTOP/dev/ocamldebug-coq file
-##################################################
-
-OCAMLDEBUGCOQ=$COQSRC/dev/ocamldebug-coq
-
-if test "$coq_debug_flag" = "-g" ; then
-  rm -f $OCAMLDEBUGCOQ
-  sed -e "s|COQTOPDIRECTORY|$COQTOP|" \
-      -e "s|COQLIBDIRECTORY|$LIBDIR|" \
-      -e "s|CAMLBINDIRECTORY|$CAMLBIN|" \
-      -e "s|CAMLP4LIBDIRECTORY|$FULLCAMLP4LIB|"\
-      $OCAMLDEBUGCOQ.template > $OCAMLDEBUGCOQ
-  chmod a-w,a+x $OCAMLDEBUGCOQ
-fi
-
-####################################################
-# Fixing lablgtk types (before/after 2.6.0) 
-####################################################
+    -e "s|HASNATIVEDYNLINK|$NATDYNLINKFLAG|" \
+    -e "s|UIMSCRIPTPATH|$UIMSCRIPTDIR|" \
+      "$config_template" > "$config_file"
 
-if [ ! "$COQIDE" = "no" ]; then 
-    if grep "class view " "$lablgtkdir/gText.mli" | grep -q "\[>" ; then
-       if grep -q "?accepts_tab:bool" "$lablgtkdir/gText.mli" ; then
-        cp -f ide/undo_lablgtk_ge212.mli ide/undo.mli
-       else
-	cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli
-       fi
-    else
-	cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli
-    fi
-fi  
+chmod a-w "$config_file"
 
 ##################################################
 # The end
 ####################################################
 
-echo "If anything in the above is wrong, please restart './configure'"
+echo "If anything in the above is wrong, please restart './configure'."
 echo
 echo "*Warning* To compile the system for a new architecture"
 echo "          don't forget to do a 'make archclean' before './configure'."
 
-# $Id: configure 13223 2010-06-29 18:28:35Z notin $
+# $Id: configure 12689 2010-01-26 13:41:56Z glondu $
diff --git a/contrib/correctness/ArrayPermut.v b/contrib/correctness/ArrayPermut.v
deleted file mode 100644
index 30f5ac8f..00000000
--- a/contrib/correctness/ArrayPermut.v
+++ /dev/null
@@ -1,175 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ArrayPermut.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(****************************************************************************)
-(*                    Permutations of elements in arrays                    *)
-(*                        Definition and properties                         *)
-(****************************************************************************)
-
-Require Import ProgInt.
-Require Import Arrays.
-Require Export Exchange.
-
-Require Import Omega.
-
-Set Implicit Arguments.
-
-(* We define "permut" as the smallest equivalence relation which contains
- * transpositions i.e. exchange of two elements.
- *)
-
-Inductive permut (n:Z) (A:Set) : array n A -> array n A -> Prop :=
-  | exchange_is_permut :
-      forall (t t':array n A) (i j:Z), exchange t t' i j -> permut t t'
-  | permut_refl : forall t:array n A, permut t t
-  | permut_sym : forall t t':array n A, permut t t' -> permut t' t
-  | permut_trans :
-      forall t t' t'':array n A, permut t t' -> permut t' t'' -> permut t t''.
-
-Hint Resolve exchange_is_permut permut_refl permut_sym permut_trans: v62
-  datatypes.
-
-(* We also define the permutation on a segment of an array, "sub_permut",
- * the other parts of the array being unchanged
- *
- * One again we define it as the smallest equivalence relation containing
- * transpositions on the given segment.
- *)
-
-Inductive sub_permut (n:Z) (A:Set) (g d:Z) :
-array n A -> array n A -> Prop :=
-  | exchange_is_sub_permut :
-      forall (t t':array n A) (i j:Z),
-        (g <= i <= d)%Z ->
-        (g <= j <= d)%Z -> exchange t t' i j -> sub_permut g d t t'
-  | sub_permut_refl : forall t:array n A, sub_permut g d t t
-  | sub_permut_sym :
-      forall t t':array n A, sub_permut g d t t' -> sub_permut g d t' t
-  | sub_permut_trans :
-      forall t t' t'':array n A,
-        sub_permut g d t t' -> sub_permut g d t' t'' -> sub_permut g d t t''.
-
-Hint Resolve exchange_is_sub_permut sub_permut_refl sub_permut_sym
-  sub_permut_trans: v62 datatypes.
-
-(* To express that some parts of arrays are equal we introduce the
- * property "array_id" which says that a segment is the same on two
- * arrays.
- *)
-
-Definition array_id (n:Z) (A:Set) (t t':array n A) 
-  (g d:Z) := forall i:Z, (g <= i <= d)%Z -> #t [i] = #t' [i].
-
-(* array_id is an equivalence relation *)
-
-Lemma array_id_refl :
- forall (n:Z) (A:Set) (t:array n A) (g d:Z), array_id t t g d.
-Proof.
-unfold array_id in |- *.
-auto with datatypes.
-Qed.
-
-Hint Resolve array_id_refl: v62 datatypes.
-
-Lemma array_id_sym :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   array_id t t' g d -> array_id t' t g d.
-Proof.
-unfold array_id in |- *. intros.
-symmetry  in |- *; auto with datatypes.
-Qed.
-
-Hint Resolve array_id_sym: v62 datatypes.
-
-Lemma array_id_trans :
- forall (n:Z) (A:Set) (t t' t'':array n A) (g d:Z),
-   array_id t t' g d -> array_id t' t'' g d -> array_id t t'' g d.
-Proof.
-unfold array_id in |- *. intros.
-apply trans_eq with (y := #t' [i]); auto with datatypes.
-Qed.
-
-Hint Resolve array_id_trans: v62 datatypes.
-
-(* Outside the segment [g,d] the elements are equal *)
-
-Lemma sub_permut_id :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   sub_permut g d t t' ->
-   array_id t t' 0 (g - 1) /\ array_id t t' (d + 1) (n - 1).
-Proof.
-intros n A t t' g d. simple induction 1; intros.
-elim H2; intros.
-unfold array_id in |- *; split; intros.
-apply H7; omega.
-apply H7; omega.
-auto with datatypes.
-decompose [and] H1; auto with datatypes.
-decompose [and] H1; decompose [and] H3; eauto with datatypes.
-Qed.
-
-Hint Resolve sub_permut_id.
-
-Lemma sub_permut_eq :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   sub_permut g d t t' ->
-   forall i:Z, (0 <= i < g)%Z \/ (d < i < n)%Z -> #t [i] = #t' [i].
-Proof.
-intros n A t t' g d Htt' i Hi.
-elim (sub_permut_id Htt'). unfold array_id in |- *. 
-intros.
-elim Hi; [ intro; apply H; omega | intro; apply H0; omega ].
-Qed.
-
-(* sub_permut is a particular case of permutation *)
-
-Lemma sub_permut_is_permut :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   sub_permut g d t t' -> permut t t'.
-Proof.
-intros n A t t' g d. simple induction 1; intros; eauto with datatypes.
-Qed.
-
-Hint Resolve sub_permut_is_permut.
-
-(* If we have a sub-permutation on an empty segment, then we have a 
- * sub-permutation on any segment.
- *)
-
-Lemma sub_permut_void :
- forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z),
-   (d < g)%Z -> sub_permut g d t t' -> sub_permut g' d' t t'.
-Proof.
-intros N A t t' g g' d d' Hdg.
-simple induction 1; intros.
-absurd (g <= d)%Z; omega.
-auto with datatypes.
-auto with datatypes.
-eauto with datatypes.
-Qed.
-
-(* A sub-permutation on a segment may be extended to any segment that
- * contains the first one.
- *)
-
-Lemma sub_permut_extension :
- forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z),
-   (g' <= g)%Z -> (d <= d')%Z -> sub_permut g d t t' -> sub_permut g' d' t t'.
-Proof.
-intros N A t t' g g' d d' Hgg' Hdd'.
-simple induction 1; intros.
-apply exchange_is_sub_permut with (i := i) (j := j);
- [ omega | omega | assumption ].
-auto with datatypes.
-auto with datatypes.
-eauto with datatypes.
-Qed.
\ No newline at end of file
diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v
deleted file mode 100644
index 3a6aaaf8..00000000
--- a/contrib/correctness/Arrays.v
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Arrays.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(**********************************************)
-(* Functional arrays, for use in Correctness. *)
-(**********************************************)
-
-(* This is an axiomatization of arrays.
- *
- * The type (array N T) is the type of arrays ranging from 0 to N-1 
- * which elements are of type T.
- *
- * Arrays are created with new, accessed with access and modified with store. 
- *
- * Operations of accessing and storing are not guarded, but axioms are.
- * So these arrays can be viewed as arrays where accessing and storing
- * out of the bounds has no effect.
- *)
-
-
-Require Export ProgInt.
-
-Set Implicit Arguments.
-
-
-(* The type of arrays *)
-
-Parameter array : Z -> Set -> Set.
-
-
-(* Functions to create, access and modify arrays *)
-
-Parameter new : forall (n:Z) (T:Set), T -> array n T.
-
-Parameter access : forall (n:Z) (T:Set), array n T -> Z -> T.
-
-Parameter store : forall (n:Z) (T:Set), array n T -> Z -> T -> array n T.
-
-
-(* Axioms *)
-
-Axiom
-  new_def :
-    forall (n:Z) (T:Set) (v0:T) (i:Z),
-      (0 <= i < n)%Z -> access (new n v0) i = v0.
-
-Axiom
-  store_def_1 :
-    forall (n:Z) (T:Set) (t:array n T) (v:T) (i:Z),
-      (0 <= i < n)%Z -> access (store t i v) i = v.
-
-Axiom
-  store_def_2 :
-    forall (n:Z) (T:Set) (t:array n T) (v:T) (i j:Z),
-      (0 <= i < n)%Z ->
-      (0 <= j < n)%Z -> i <> j -> access (store t i v) j = access t j.
-
-Hint Resolve new_def store_def_1 store_def_2: datatypes v62.
-
-(* A tactic to simplify access in arrays *)
-
-Ltac array_access i j H :=
-  elim (Z_eq_dec i j);
-   [ intro H; rewrite H; rewrite store_def_1
-   | intro H; rewrite store_def_2; [ idtac | idtac | idtac | exact H ] ].
-
-(* Symbolic notation for access *)
-
-Notation "# t [ c ]" := (access t c) (at level 0, t at level 0).
\ No newline at end of file
diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v
deleted file mode 100644
index 035a98f2..00000000
--- a/contrib/correctness/Exchange.v
+++ /dev/null
@@ -1,95 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Exchange.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(****************************************************************************)
-(*                   Exchange of two elements in an array                   *)
-(*                        Definition and properties                         *)
-(****************************************************************************)
-
-Require Import ProgInt.
-Require Import Arrays.
-
-Set Implicit Arguments.
-
-(* Definition *)
-
-Inductive exchange (n:Z) (A:Set) (t t':array n A) (i j:Z) : Prop :=
-    exchange_c :
-      (0 <= i < n)%Z ->
-      (0 <= j < n)%Z ->
-      #t [i] = #t' [j] ->
-      #t [j] = #t' [i] ->
-      (forall k:Z, (0 <= k < n)%Z -> k <> i -> k <> j -> #t [k] = #t' [k]) ->
-      exchange t t' i j.
-    
-(* Properties about exchanges *)
-
-Lemma exchange_1 :
- forall (n:Z) (A:Set) (t:array n A) (i j:Z),
-   (0 <= i < n)%Z ->
-   (0 <= j < n)%Z -> #(store (store t i #t [j]) j #t [i]) [i] = #t [j].
-Proof.
-intros n A t i j H_i H_j.
-case (dec_eq j i).
-intro eq_i_j. rewrite eq_i_j.
-auto with datatypes.
-intro not_j_i.
-rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_i not_j_i).
-auto with datatypes.
-Qed.
-
-Hint Resolve exchange_1: v62 datatypes.
-
-
-Lemma exchange_proof :
- forall (n:Z) (A:Set) (t:array n A) (i j:Z),
-   (0 <= i < n)%Z ->
-   (0 <= j < n)%Z -> exchange (store (store t i #t [j]) j #t [i]) t i j.
-Proof.
-intros n A t i j H_i H_j.
-apply exchange_c; auto with datatypes.
-intros k H_k not_k_i not_k_j.
-cut (j <> k); auto with datatypes. intro not_j_k.
-rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_k not_j_k).
-auto with datatypes.
-Qed.
-
-Hint Resolve exchange_proof: v62 datatypes.
-
-
-Lemma exchange_sym :
- forall (n:Z) (A:Set) (t t':array n A) (i j:Z),
-   exchange t t' i j -> exchange t' t i j.
-Proof.
-intros n A t t' i j H1.
-elim H1. clear H1. intros.
-constructor 1; auto with datatypes.
-intros. rewrite (H3 k); auto with datatypes.
-Qed.
-
-Hint Resolve exchange_sym: v62 datatypes.
-
-
-Lemma exchange_id :
- forall (n:Z) (A:Set) (t t':array n A) (i j:Z),
-   exchange t t' i j ->
-   i = j -> forall k:Z, (0 <= k < n)%Z -> #t [k] = #t' [k].
-Proof.
-intros n A t t' i j Hex Heq k Hk.
-elim Hex. clear Hex. intros.
-rewrite Heq in H1. rewrite Heq in H2.
-case (Z_eq_dec k j). 
-  intro Heq'. rewrite Heq'. assumption.
-  intro Hnoteq. apply (H3 k); auto with datatypes. rewrite Heq. assumption.
-Qed.
-
-Hint Resolve exchange_id: v62 datatypes.
\ No newline at end of file
diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v
deleted file mode 100644
index 38448efc..00000000
--- a/contrib/correctness/ProgBool.v
+++ /dev/null
@@ -1,66 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ProgBool.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Import ZArith.
-Require Export Bool_nat.
-Require Export Sumbool.
-
-Definition annot_bool :
-  forall b:bool, {b' : bool | if b' then b = true else b = false}.
-Proof.
-intro b.
-exists b. case b; trivial.
-Qed.
-
-
-(* Logical connectives *)
-
-Definition spec_and (A B C D:Prop) (b:bool) := if b then A /\ C else B \/ D.
-
-Definition prog_bool_and :
-  forall Q1 Q2:bool -> Prop,
-    sig Q1 ->
-    sig Q2 ->
-    {b : bool | if b then Q1 true /\ Q2 true else Q1 false \/ Q2 false}.
-Proof.
-intros Q1 Q2 H1 H2.
-elim H1. intro b1. elim H2. intro b2. 
-case b1; case b2; intros.
-exists true; auto.
-exists false; auto. exists false; auto. exists false; auto.
-Qed.
-
-Definition spec_or (A B C D:Prop) (b:bool) := if b then A \/ C else B /\ D.
-
-Definition prog_bool_or :
-  forall Q1 Q2:bool -> Prop,
-    sig Q1 ->
-    sig Q2 ->
-    {b : bool | if b then Q1 true \/ Q2 true else Q1 false /\ Q2 false}.
-Proof.
-intros Q1 Q2 H1 H2.
-elim H1. intro b1. elim H2. intro b2. 
-case b1; case b2; intros.
-exists true; auto. exists true; auto. exists true; auto.
-exists false; auto.
-Qed.
-
-Definition spec_not (A B:Prop) (b:bool) := if b then B else A.
-
-Definition prog_bool_not :
-  forall Q:bool -> Prop, sig Q -> {b : bool | if b then Q false else Q true}.
-Proof.
-intros Q H.
-elim H. intro b.
-case b; intro.
-exists false; auto. exists true; auto.
-Qed.
diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v
deleted file mode 100644
index b1eaaea7..00000000
--- a/contrib/correctness/ProgInt.v
+++ /dev/null
@@ -1,19 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ProgInt.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export ZArith.
-Require Export ZArith_dec.
-
-Theorem Znotzero : forall x:Z, {x <> 0%Z} + {x = 0%Z}.
-Proof.
-intro x. elim (Z_eq_dec x 0); auto.
-Qed.
\ No newline at end of file
diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v
deleted file mode 100644
index 70f4b730..00000000
--- a/contrib/correctness/ProgramsExtraction.v
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ProgramsExtraction.v 10290 2007-11-06 01:27:17Z letouzey $ *)
-
-Extract Inductive unit => unit [ "()" ].
-Extract Inductive bool => bool [ true false ].
-Extract Inductive sumbool => bool [ true false ].
-
-Require Export Correctness.
-
-Declare ML Module "pextract".
-
-Grammar vernac vernac : ast :=
-  imperative_ocaml [ "Write" "Caml" "File" stringarg($file) 
-    "[" ne_identarg_list($idl) "]" "." ]
-     -> [ (IMPERATIVEEXTRACTION $file (VERNACARGLIST ($LIST $idl))) ]
-
-| initialize [ "Initialize" identarg($id) "with" comarg($c) "." ]
-     -> [ (INITIALIZE $id $c) ]
-.
diff --git a/contrib/correctness/Sorted.v b/contrib/correctness/Sorted.v
deleted file mode 100644
index ca4ed880..00000000
--- a/contrib/correctness/Sorted.v
+++ /dev/null
@@ -1,202 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*  Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *)
-
-(* $Id: Sorted.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Arrays.
-Require Import ArrayPermut.
-
-Require Import ZArithRing.
-Require Import Omega.
-Open Local Scope Z_scope.
-
-Set Implicit Arguments.
-
-(* Definition *)
-
-Definition sorted_array (N:Z) (A:array N Z) (deb fin:Z) :=
-  deb <= fin -> forall x:Z, x >= deb -> x < fin -> #A [x] <= #A [x + 1].
-
-(* Elements of a sorted sub-array are in increasing order *)
-
-(* one element and the next one *)
-
-Lemma sorted_elements_1 :
- forall (N:Z) (A:array N Z) (n m:Z),
-   sorted_array A n m ->
-   forall k:Z,
-     k >= n -> forall i:Z, 0 <= i -> k + i <= m -> #A [k] <= #A [k + i].
-Proof.
-intros N A n m H_sorted k H_k i H_i.
-pattern i in |- *. apply natlike_ind.
-intro.
-replace (k + 0) with k; omega. (*** Ring `k+0` => BUG ***)
-
-intros.
-apply Zle_trans with (m := #A [k + x]).
-apply H0; omega.
-
-unfold Zsucc in |- *.
-replace (k + (x + 1)) with (k + x + 1).
-unfold sorted_array in H_sorted.
-apply H_sorted; omega.
-
-omega.
-
-assumption.
-Qed.
-
-(* one element and any of the following *)
-
-Lemma sorted_elements :
- forall (N:Z) (A:array N Z) (n m k l:Z),
-   sorted_array A n m ->
-   k >= n -> l < N -> k <= l -> l <= m -> #A [k] <= #A [l].
-Proof.
-intros.
-replace l with (k + (l - k)).
-apply sorted_elements_1 with (n := n) (m := m);
- [ assumption | omega | omega | omega ].
-omega.
-Qed.
-
-Hint Resolve sorted_elements: datatypes v62.
-
-(* A sub-array of a sorted array is sorted *)
-
-Lemma sub_sorted_array :
- forall (N:Z) (A:array N Z) (deb fin i j:Z),
-   sorted_array A deb fin ->
-   i >= deb -> j <= fin -> i <= j -> sorted_array A i j.
-Proof.
-unfold sorted_array in |- *.
-intros.
-apply H; omega.
-Qed.
-
-Hint Resolve sub_sorted_array: datatypes v62.
-
-(* Extension on the left of the property of being sorted *)
-
-Lemma left_extension :
- forall (N:Z) (A:array N Z) (i j:Z),
-   i > 0 ->
-   j < N ->
-   sorted_array A i j -> #A [i - 1] <= #A [i] -> sorted_array A (i - 1) j.
-Proof.
-intros; unfold sorted_array in |- *; intros.
-elim (Z_ge_lt_dec x i).   (* (`x >= i`) + (`x < i`) *)
-intro Hcut.
-apply H1; omega.
-
-intro Hcut.
-replace x with (i - 1).
-replace (i - 1 + 1) with i; [ assumption | omega ].
-
-omega.
-Qed.
-
-(* Extension on the right *)
-
-Lemma right_extension :
- forall (N:Z) (A:array N Z) (i j:Z),
-   i >= 0 ->
-   j < N - 1 ->
-   sorted_array A i j -> #A [j] <= #A [j + 1] -> sorted_array A i (j + 1).
-Proof.
-intros; unfold sorted_array in |- *; intros.
-elim (Z_lt_ge_dec x j).
-intro Hcut. 
-apply H1; omega.
-
-intro HCut.
-replace x with j; [ assumption | omega ].
-Qed.
-
-(* Substitution of the leftmost value by a smaller value *) 
-
-Lemma left_substitution :
- forall (N:Z) (A:array N Z) (i j v:Z),
-   i >= 0 ->
-   j < N ->
-   sorted_array A i j -> v <= #A [i] -> sorted_array (store A i v) i j.
-Proof.
-intros N A i j v H_i H_j H_sorted H_v.
-unfold sorted_array in |- *; intros.
-
-cut (x = i \/ x > i).
-intro Hcut; elim Hcut; clear Hcut; intro.
-rewrite H2.
-rewrite store_def_1; try omega.
-rewrite store_def_2; try omega.
-apply Zle_trans with (m := #A [i]); [ assumption | apply H_sorted; omega ].
-
-rewrite store_def_2; try omega.
-rewrite store_def_2; try omega.
-apply H_sorted; omega.
-omega.
-Qed.
-
-(* Substitution of the rightmost value by a larger value *)
-
-Lemma right_substitution :
- forall (N:Z) (A:array N Z) (i j v:Z),
-   i >= 0 ->
-   j < N ->
-   sorted_array A i j -> #A [j] <= v -> sorted_array (store A j v) i j.
-Proof.
-intros N A i j v H_i H_j H_sorted H_v.
-unfold sorted_array in |- *; intros.
-
-cut (x = j - 1 \/ x < j - 1).
-intro Hcut; elim Hcut; clear Hcut; intro.
-rewrite H2.
-replace (j - 1 + 1) with j; [ idtac | omega ]. (*** Ring `j-1+1`. => BUG ***)
-rewrite store_def_2; try omega.
-rewrite store_def_1; try omega.
-apply Zle_trans with (m := #A [j]). 
-apply sorted_elements with (n := i) (m := j); try omega; assumption.
-assumption.
-
-rewrite store_def_2; try omega.
-rewrite store_def_2; try omega.
-apply H_sorted; omega.
-
-omega.
-Qed.
-
-(* Affectation outside of the sorted region *)
-
-Lemma no_effect :
- forall (N:Z) (A:array N Z) (i j k v:Z),
-   i >= 0 ->
-   j < N ->
-   sorted_array A i j ->
-   0 <= k < i \/ j < k < N -> sorted_array (store A k v) i j.
-Proof.
-intros.
-unfold sorted_array in |- *; intros. 
-rewrite store_def_2; try omega.
-rewrite store_def_2; try omega.
-apply H1; assumption.
-Qed.
-
-Lemma sorted_array_id :
- forall (N:Z) (t1 t2:array N Z) (g d:Z),
-   sorted_array t1 g d -> array_id t1 t2 g d -> sorted_array t2 g d.
-Proof.
-intros N t1 t2 g d Hsorted Hid.
-unfold array_id in Hid.
-unfold sorted_array in Hsorted. unfold sorted_array in |- *.
-intros Hgd x H1x H2x.
-rewrite <- (Hid x); [ idtac | omega ].
-rewrite <- (Hid (x + 1)); [ idtac | omega ].
-apply Hsorted; assumption.
-Qed.
\ No newline at end of file
diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v
deleted file mode 100644
index c7071f32..00000000
--- a/contrib/correctness/Tuples.v
+++ /dev/null
@@ -1,98 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Tuples.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(* Tuples *)
-
-Definition tuple_1 (X:Set) := X.
-Definition tuple_2 := prod.
-Definition Build_tuple_2 := pair.
-Definition proj_2_1 := fst.
-Definition proj_2_2 := snd.
-
-Record tuple_3 (T1 T2 T3:Set) : Set := 
-  {proj_3_1 : T1; proj_3_2 : T2; proj_3_3 : T3}.
-
-Record tuple_4 (T1 T2 T3 T4:Set) : Set := 
-  {proj_4_1 : T1; proj_4_2 : T2; proj_4_3 : T3; proj_4_4 : T4}.
-
-Record tuple_5 (T1 T2 T3 T4 T5:Set) : Set := 
-  {proj_5_1 : T1; proj_5_2 : T2; proj_5_3 : T3; proj_5_4 : T4; proj_5_5 : T5}.
-
-Record tuple_6 (T1 T2 T3 T4 T5 T6:Set) : Set := 
-  {proj_6_1 : T1;
-   proj_6_2 : T2;
-   proj_6_3 : T3;
-   proj_6_4 : T4;
-   proj_6_5 : T5;
-   proj_6_6 : T6}.
-
-Record tuple_7 (T1 T2 T3 T4 T5 T6 T7:Set) : Set := 
-  {proj_7_1 : T1;
-   proj_7_2 : T2;
-   proj_7_3 : T3;
-   proj_7_4 : T4;
-   proj_7_5 : T5;
-   proj_7_6 : T6;
-   proj_7_7 : T7}.
-
-
-(* Existentials *)
-
-Definition sig_1 := sig.
-Definition exist_1 := exist.
-
-Inductive sig_2 (T1 T2:Set) (P:T1 -> T2 -> Prop) : Set :=
-    exist_2 : forall (x1:T1) (x2:T2), P x1 x2 -> sig_2 T1 T2 P.
-
-Inductive sig_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Prop) : Set :=
-    exist_3 : forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> sig_3 T1 T2 T3 P.
-
-
-Inductive sig_4 (T1 T2 T3 T4:Set) (P:T1 -> T2 -> T3 -> T4 -> Prop) : Set :=
-    exist_4 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4),
-        P x1 x2 x3 x4 -> sig_4 T1 T2 T3 T4 P.
-
-Inductive sig_5 (T1 T2 T3 T4 T5:Set) (P:T1 -> T2 -> T3 -> T4 -> T5 -> Prop) :
-Set :=
-    exist_5 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5),
-        P x1 x2 x3 x4 x5 -> sig_5 T1 T2 T3 T4 T5 P.
-
-Inductive sig_6 (T1 T2 T3 T4 T5 T6:Set)
-(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> Prop) : Set :=
-    exist_6 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) 
-        (x6:T6), P x1 x2 x3 x4 x5 x6 -> sig_6 T1 T2 T3 T4 T5 T6 P.
-
-Inductive sig_7 (T1 T2 T3 T4 T5 T6 T7:Set)
-(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> Prop) : Set :=
-    exist_7 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) 
-        (x6:T6) (x7:T7),
-        P x1 x2 x3 x4 x5 x6 x7 -> sig_7 T1 T2 T3 T4 T5 T6 T7 P.
-
-Inductive sig_8 (T1 T2 T3 T4 T5 T6 T7 T8:Set)
-(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> T8 -> Prop) : Set :=
-    exist_8 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) 
-        (x6:T6) (x7:T7) (x8:T8),
-        P x1 x2 x3 x4 x5 x6 x7 x8 -> sig_8 T1 T2 T3 T4 T5 T6 T7 T8 P.      
-
-Inductive dep_tuple_2 (T1 T2:Set) (P:T1 -> T2 -> Set) : Set :=
-    Build_dep_tuple_2 :
-      forall (x1:T1) (x2:T2), P x1 x2 -> dep_tuple_2 T1 T2 P.
-
-Inductive dep_tuple_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Set) : Set :=
-    Build_dep_tuple_3 :
-      forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> dep_tuple_3 T1 T2 T3 P.
-
diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v
deleted file mode 100644
index abb1cc76..00000000
--- a/contrib/correctness/examples/Handbook.v
+++ /dev/null
@@ -1,232 +0,0 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Handbook.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* This file contains proofs of programs taken from the
- * "Handbook of Theoretical Computer Science", volume B,
- * chapter "Methods and Logics for Proving Programs", by P. Cousot,
- * pp 841--993, Edited by J. van Leeuwen (c) Elsevier Science Publishers B.V.
- * 1990.
- * 
- * Programs are refered to by numbers and pages.
- *)
-
-Require Correctness.
-
-Require Sumbool.
-Require Omega.
-Require Zcomplements.
-Require Zpower.
-
-(****************************************************************************)
-
-(* program (2) page 853 to compute x^y (annotated version is (25) page 860) *)
-
-(* en attendant... *)
-Parameter Zdiv2  : Z->Z.
-
-Parameter Zeven_odd_dec : (x:Z){`x=2*(Zdiv2 x)`}+{`x=2*(Zdiv2 x)+1`}.
-Definition Zodd_dec := [z:Z](sumbool_not ? ? (Zeven_odd_dec z)).
-Definition Zodd_bool := [z:Z](bool_of_sumbool ? ? (Zodd_dec z)).
-
-Axiom axiom1 : (x,y:Z) `y>0` -> `x*(Zpower x (Zpred y)) = (Zpower x y)`.
-Axiom axiom2 : (x:Z)`x>0` -> `(Zdiv2 x)<x`.
-Axiom axiom3 : (x,y:Z) `y>=0` -> `(Zpower (x*x) (Zdiv2 y)) = (Zpower x y)`.
-
-Global Variable X : Z ref.
-Global Variable Y : Z ref.
-Global Variable Z_ : Z ref.
-
-Correctness pgm25
-  { `Y >= 0` }
-  begin
-    Z_ := 1;
-    while !Y <> 0 do
-      { invariant `Y >= 0` /\ `Z_ * (Zpower X Y) = (Zpower X@0 Y@0)`
-        variant Y }
-      if (Zodd_bool !Y) then begin
-      	Y := (Zpred !Y);
-	Z_ := (Zmult !Z_ !X)
-      end else begin
-      	Y := (Zdiv2 !Y);	
-	X := (Zmult !X !X)
-      end
-    done
-  end
-  { Z_ = (Zpower X@ Y@) }.
-Proof.
-Split.
-Unfold Zpred; Unfold Zwf; Omega.
-Split.
-Unfold Zpred; Omega.
-Decompose [and] Pre2.
-Rewrite <- H0.
-Replace `Z_1*X0*(Zpower X0 (Zpred Y0))` with `Z_1*(X0*(Zpower X0 (Zpred Y0)))`.
-Apply f_equal with f := (Zmult Z_1).
-Apply axiom1.
-Omega.
-
-Auto.
-Symmetry.
-Apply Zmult_assoc_r.
-
-Split.
-Unfold Zwf.
-Repeat (Apply conj).
-Omega.
-
-Omega.
-
-Apply axiom2. Omega.
-
-Split.
-Omega.
-
-Decompose [and] Pre2.
-Rewrite <- H0.
-Apply f_equal with f:=(Zmult Z_1).
-Apply axiom3. Omega.
-
-Omega.
-
-Decompose [and] Post6.
-Rewrite <- H2.
-Rewrite H0.
-Simpl.
-Omega.
-
-Save.
-
-
-(****************************************************************************)
-
-(* program (178) page 934 to compute the factorial using global variables
- * annotated version is (185) page 939
- *)
-
-Parameter Zfact : Z -> Z.
-
-Axiom axiom4 : `(Zfact 0) = 1`.
-Axiom axiom5 : (x:Z) `x>0` -> `(Zfact (x-1))*x=(Zfact x)`.
-
-Correctness pgm178
-let rec F (u:unit) : unit { variant X } =
-  { `X>=0` }
-  (if !X = 0 then
-    Y := 1
-  else begin
-    label L;
-    X := (Zpred !X);
-    (F tt);
-    X := (Zs !X);
-    Y := (Zmult !Y !X)
-  end)
-  { `X=X@` /\ `Y=(Zfact X@)` }.
-Proof.
-Rewrite Test1. Rewrite axiom4. Auto.
-Unfold Zwf. Unfold Zpred. Omega.
-Unfold Zpred. Omega.
-Unfold Zs. Unfold Zpred in Post3. Split.
-Omega.
-Decompose [and] Post3.
-Rewrite H.
-Replace `X0+(-1)+1` with X0.
-Rewrite H0.
-Replace `X0+(-1)` with `X0-1`.
-Apply axiom5.
-Omega.
-Omega.
-Omega.
-Save.
-
-
-(****************************************************************************)
-
-(* program (186) page 939 "showing the usefulness of auxiliary variables" ! *)
-
-Global Variable N : Z ref.
-Global Variable S : Z ref.
-
-Correctness pgm186
-let rec F (u:unit) : unit { variant N } =
-  { `N>=0` }
-  (if !N > 0 then begin
-    label L;
-    N := (Zpred !N);
-    (F tt);
-    S := (Zs !S);
-    (F tt);
-    N := (Zs !N)
-  end)
-  { `N=N@` /\ `S=S@+(Zpower 2 N@)-1` }.
-Proof.
-Unfold Zwf. Unfold Zpred. Omega.
-Unfold Zpred. Omega.
-Decompose [and] Post5. Rewrite H. Unfold Zwf. Unfold Zpred. Omega.
-Decompose [and] Post5. Rewrite H. Unfold Zpred. Omega.
-Split.
-Unfold Zpred in Post5. Omega.
-Decompose [and] Post4. Rewrite H0. 
-Decompose [and] Post5. Rewrite H2. Rewrite H1. 
-Replace `(Zpower 2 N0)` with `2*(Zpower 2 (Zpred N0))`. Omega.
-Symmetry.
-Replace `(Zpower 2 N0)` with `(Zpower 2 (1+(Zpred N0)))`.
-Replace `2*(Zpower 2 (Zpred N0))` with `(Zpower 2 1)*(Zpower 2 (Zpred N0))`.
-Apply Zpower_exp.
-Omega.
-Unfold Zpred. Omega.
-Auto.
-Replace `(1+(Zpred N0))` with N0; [ Auto | Unfold Zpred; Omega ].
-Split.
-Auto.
-Replace N0 with `0`; Simpl; Omega.
-Save.
-
-
-(****************************************************************************)
-
-(* program (196) page 944 (recursive factorial procedure with value-result
- * parameters)
- *)
-
-Correctness pgm196
-let rec F (U:Z) (V:Z ref) : unit { variant U } =
-  { `U >= 0` }
-  (if U = 0 then
-    V := 1
-  else begin
-    (F (Zpred U) V);	
-    V := (Zmult !V U)
-  end)
-  { `V = (Zfact U)` }.
-Proof.
-Symmetry. Rewrite Test1. Apply axiom4.
-Unfold Zwf. Unfold Zpred. Omega.
-Unfold Zpred. Omega.
-Rewrite Post3. 
-Unfold Zpred. Replace `U0+(-1)` with `U0-1`. Apply axiom5.
-Omega.
-Omega.
-Save.
-
-(****************************************************************************)
-
-(* program (197) page 945 (L_4 subset of Pascal) *)
-
-(*
-procedure P(X:Z; procedure Q(Z:Z));
-  procedure L(X:Z); begin Q(X-1) end;
-  begin if X>0 then P(X-1,L) else Q(X) end;
-
-procedure M(N:Z);
-  procedure R(X:Z); begin writeln(X) (* => RES := !X *) end;
-  begin P(N,R) end.
-*)
diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v
deleted file mode 100644
index 3142e906..00000000
--- a/contrib/correctness/examples/exp.v
+++ /dev/null
@@ -1,204 +0,0 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(*i $Id: exp.v 1577 2001-04-11 07:56:19Z filliatr $ i*)
-
-(* Efficient computation of X^n using
- * 
- *    X^(2n)   =     (X^n) ^ 2
- *    X^(2n+1) = X . (X^n) ^ 2
- *
- * Proofs of both fonctional and imperative programs.
- *)
-
-Require Even.
-Require Div2.
-Require Correctness.
-Require ArithRing.
-Require ZArithRing.
-
-(* The specification uses the traditional definition of X^n *)
-
-Fixpoint power [x,n:nat] : nat :=
-  Cases n of
-    O      => (S O)
-  | (S n') => (mult x (power x n'))
-  end.
-
-Definition square := [n:nat](mult n n).
-
-
-(* Three lemmas are necessary to establish the forthcoming proof obligations *)
-
-(* n = 2*(n/2) => (x^(n/2))^2 = x^n *)
-
-Lemma exp_div2_0 : (x,n:nat)
-     n=(double (div2 n)) 
-  -> (square (power x (div2 n)))=(power x n).
-Proof.
-Unfold square.
-Intros x n. Pattern n. Apply ind_0_1_SS.
-Auto.
-
-Intro. (Absurd (1)=(double (0)); Auto).
-
-Intros. Simpl.
-Cut n0=(double (div2 n0)).
-Intro. Rewrite <- (H H1).
-Ring.
-
-Simpl in H0.
-Unfold double in H0.
-Simpl in H0.
-Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0.
-(Injection H0; Auto).
-Save.
-
-(* n = 2*(n/2)+1 => x*(x^(n/2))^2 = x^n *)
-
-Lemma exp_div2_1 : (x,n:nat) 
-     n=(S (double (div2 n)))
-  -> (mult x (square (power x (div2 n))))=(power x n).
-Proof.
-Unfold square.
-Intros x n. Pattern n. Apply ind_0_1_SS.
-
-Intro. (Absurd (0)=(S (double (0))); Auto).
-
-Auto.
-
-Intros. Simpl.
-Cut n0=(S (double (div2 n0))).
-Intro. Rewrite <- (H H1).
-Ring.
-
-Simpl in H0.
-Unfold double in H0.
-Simpl in H0.
-Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0.
-(Injection H0; Auto).
-Save.
-
-(* x^(2*n) = (x^2)^n *)
-
-Lemma power_2n : (x,n:nat)(power x (double n))=(power (square x) n).
-Proof.
-Unfold double. Unfold square.
-Induction n.
-Auto.
-
-Intros.
-Simpl.
-Rewrite <- H.
-Rewrite <- (plus_n_Sm n0 n0).
-Simpl.
-Auto with arith.
-Save.
-
-Hints Resolve exp_div2_0 exp_div2_1.
-
-
-(* Functional version.
- * 
- * Here we give the functional program as an incomplete CIC term,
- * using the tactic Refine.
- *
- * On this example, it really behaves as the tactic Program.
- *)
-
-(*
-Lemma f_exp : (x,n:nat) { y:nat | y=(power x n) }.
-Proof.
-Refine [x:nat]
-  (well_founded_induction nat lt lt_wf
-    [n:nat]{y:nat | y=(power x n) }
-    [n:nat]
-    [f:(p:nat)(lt p n)->{y:nat | y=(power x p) }]
-      	     Cases (zerop n) of 
-               (left _) => (exist ? ? (S O) ?)
-      	     | (right _) => 
-      	       	  let (y,H) = (f (div2 n) ?) in 
-      	       	  Cases (even_odd_dec n) of
-      	       	    (left _) => (exist ? ? (mult y y) ?)
-                  | (right _) => (exist ? ? (mult x (mult y y)) ?)
-		  end
-	     end).
-Proof.
-Rewrite a. Auto.
-Exact (lt_div2 n a).
-Change (square y)=(power x n). Rewrite H. Auto with arith.
-Change (mult x (square y))=(power x n). Rewrite H. Auto with arith.
-Save.
-*)
-
-(* Imperative version. *)
-
-Definition even_odd_bool := [x:nat](bool_of_sumbool ? ? (even_odd_dec x)).
-
-Correctness i_exp
-  fun (x:nat)(n:nat) ->
-    let y = ref (S O) in
-    let m = ref x in
-    let e = ref n in
-    begin
-      while (notzerop_bool !e) do
-        { invariant (power x n)=(mult y (power m e)) as Inv
-          variant e for lt }
-        (if not (even_odd_bool !e) then y := (mult !y !m))
-          { (power x n) = (mult y (power m (double (div2 e)))) as Q };
-        m := (square !m);
-        e := (div2 !e)
-      done;
-      !y
-    end
-    { result=(power x n) }
-.
-Proof.
-Rewrite (odd_double e0 Test1) in Inv. Rewrite Inv. Simpl. Auto with arith.
-
-Rewrite (even_double e0 Test1) in Inv. Rewrite Inv. Reflexivity.
-
-Split.
-Exact (lt_div2 e0 Test2).
-
-Rewrite Q. Unfold double. Unfold square.
-Simpl. 
-Change (mult y1 (power m0 (double (div2 e0))))
-     = (mult y1 (power (square m0) (div2 e0))).
-Rewrite (power_2n m0 (div2 e0)). Reflexivity.
-
-Auto with arith.
-
-Decompose [and] Inv.
-Rewrite H. Rewrite H0.
-Auto with arith.
-Save.
-
-
-(* Recursive version. *)
-
-Correctness r_exp
-  let rec exp (x:nat) (n:nat) : nat { variant n for lt} =
-    (if (zerop_bool n) then
-       (S O)
-     else
-       let y = (exp x (div2 n)) in
-       if (even_odd_bool n) then
-         (mult y y)
-       else
-         (mult x (mult y y))
-    ) { result=(power x n) }
-.
-Proof.
-Rewrite Test2. Auto.
-Exact (lt_div2 n0 Test2).
-Change (square y)=(power x0 n0). Rewrite Post7. Auto with arith.
-Change (mult x0 (square y))=(power x0 n0). Rewrite Post7. Auto with arith.
-Save.
diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v
deleted file mode 100644
index 044263ca..00000000
--- a/contrib/correctness/examples/exp_int.v
+++ /dev/null
@@ -1,218 +0,0 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: exp_int.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* Efficient computation of X^n using
- * 
- *    X^(2n)   =     (X^n) ^ 2
- *    X^(2n+1) = X . (X^n) ^ 2
- *
- * Proofs of both fonctional and imperative programs.
- *)
-
-Require Zpower.
-Require Zcomplements.
-
-Require Correctness.
-Require ZArithRing.
-Require Omega.
-
-Definition Zdouble := [n:Z]`2*n`.
-
-Definition Zsquare := [n:Z](Zmult n n).
-
-(* Some auxiliary lemmas about Zdiv2 are necessary *)
-
-Lemma Zdiv2_ge_0 : (x:Z) `x >= 0` -> `(Zdiv2 x) >= 0`.
-Proof.
-Destruct x; Auto with zarith.
-Destruct p; Auto with zarith.
-Simpl. Omega.
-Intros. (Absurd `(NEG p) >= 0`; Red; Auto with zarith).
-Save.
-
-Lemma Zdiv2_lt : (x:Z) `x > 0` -> `(Zdiv2 x) < x`.
-Proof.
-Destruct x.
-Intro. Absurd `0 > 0`; [ Omega | Assumption ].
-Destruct p; Auto with zarith.
-
-Simpl.
-Intro p0.
-Replace (POS (xI p0)) with `2*(POS p0)+1`.
-Omega.
-Simpl. Auto with zarith.
-
-Intro p0.
-Simpl.
-Replace (POS (xO p0)) with `2*(POS p0)`.
-Omega.
-Simpl. Auto with zarith.
-
-Simpl. Omega.
-
-Intros. 
-Absurd `(NEG p) > 0`; Red; Auto with zarith.
-Elim p; Auto with zarith.
-Omega.
-Save.
-
-(* A property of Zpower:  x^(2*n) = (x^2)^n *)
-
-Lemma Zpower_2n : 
-  (x,n:Z)`n >= 0` -> (Zpower x (Zdouble n))=(Zpower (Zsquare x) n).
-Proof.
-Unfold Zdouble.
-Intros x n Hn.
-Replace `2*n` with `n+n`.
-Rewrite Zpower_exp.
-Pattern n.
-Apply natlike_ind.
-
-Simpl. Auto with zarith.
-
-Intros.
-Unfold Zs.
-Rewrite Zpower_exp.
-Rewrite Zpower_exp.
-Replace (Zpower x `1`) with x.
-Replace (Zpower (Zsquare x) `1`) with (Zsquare x).
-Rewrite <- H0.
-Unfold Zsquare.
-Ring.
-
-Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
-
-Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
-
-Omega.
-Omega.
-Omega.
-Omega.
-Omega.
-Assumption.
-Assumption.
-Omega.
-Save.
-
-
-(* The program *)
-
-Correctness i_exp
-  fun (x:Z)(n:Z) ->
-    { `n >= 0` }
-   (let y = ref 1 in
-    let m = ref x in
-    let e = ref n in
-    begin
-      while !e > 0 do
-        { invariant (Zpower x n)=(Zmult y (Zpower m e)) /\ `e>=0` as Inv
-          variant e }
-        (if not (Zeven_odd_bool !e) then y := (Zmult !y !m))
-          { (Zpower x n) = (Zmult y (Zpower m (Zdouble (Zdiv2 e)))) as Q };
-        m := (Zsquare !m);
-        e := (Zdiv2 !e)
-      done;
-      !y
-    end)
-    { result=(Zpower x n) }
-.
-Proof.
-(* Zodd *)
-Decompose [and] Inv.
-Rewrite (Zodd_div2 e0 H0 Test1) in H. Rewrite H.
-Rewrite Zpower_exp.
-Unfold Zdouble.
-Replace (Zpower m0 `1`) with m0.
-Ring.
-Unfold Zpower; Unfold Zpower_pos; Simpl; Ring.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Omega.
-(* Zeven *)
-Decompose [and] Inv.
-Rewrite (Zeven_div2 e0 Test1) in H. Rewrite H.
-Auto with zarith.
-Split.
-(* Zwf *)
-Unfold Zwf.
-Repeat Split.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Omega.
-Exact (Zdiv2_lt e0 Test2).
-(* invariant *)
-Split.
-Rewrite Q. Unfold Zdouble. Unfold Zsquare.
-Rewrite (Zpower_2n).
-Trivial.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Split; [ Ring | Assumption ].
-(* exit fo loop *)
-Decompose [and] Inv.
-Cut `e0 = 0`. Intro.
-Rewrite H1. Rewrite H.
-Simpl; Ring.
-Omega.
-Save.
-
-
-(* Recursive version. *)
-
-Correctness r_exp
-  let rec exp (x:Z) (n:Z) : Z { variant n } =
-    { `n >= 0` }
-    (if n = 0 then
-       1
-     else
-       let y = (exp x (Zdiv2 n)) in
-       (if (Zeven_odd_bool n) then
-       	  (Zmult y y)
-        else
-          (Zmult x (Zmult y y))) { result=(Zpower x n) as Q }
-    ) 
-    { result=(Zpower x n) }
-.
-Proof.
-Rewrite Test2. Auto with zarith.
-(* w.f. *)
-Unfold Zwf.
-Repeat Split.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-Generalize (Zdiv2_lt n0) ; Omega.
-(* rec. call *)
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-(* invariant: case even *)
-Generalize (Zeven_div2 n0 Test1).
-Intro Heq. Rewrite Heq.
-Rewrite Post4.
-Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`.
-Rewrite Zpower_exp.
-Auto with zarith.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-(* invariant: cas odd *)
-Generalize (Zodd_div2 n0 Pre1 Test1).
-Intro Heq. Rewrite Heq.
-Rewrite Post4.
-Rewrite Zpower_exp.
-Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`.
-Rewrite Zpower_exp.
-Replace `(Zpower x0 1)` with x0.
-Ring.
-Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-Save.
diff --git a/contrib/correctness/examples/extract.v b/contrib/correctness/examples/extract.v
deleted file mode 100644
index e225ba18..00000000
--- a/contrib/correctness/examples/extract.v
+++ /dev/null
@@ -1,43 +0,0 @@
-
-(* Tests d'extraction *)
-
-Require ProgramsExtraction.
-Save State Ici "test extraction".
-
-(* exp *)
-
-Require exp.
-Write Caml File "exp" [ i_exp r_exp ].
-
-(* exp_int *)
-
-Restore State Ici.
-Require exp_int.
-Write Caml File "exp_int" [ i_exp r_exp ].
-
-(* fact *)
-
-Restore State Ici.
-Require fact.
-Initialize x with (S (S (S O))).
-Initialize y with O.
-Write Caml File "fact" [ factorielle ].
-
-(* fact_int *)
-
-Restore State Ici.
-Require fact_int.
-Initialize x with `3`.
-Initialize y with `0`.
-Write Caml File "fact_int" [ factorielle ].
-
-(* Handbook *)
-
-Restore State Ici.
-Require Handbook.
-Initialize X with `3`.
-Initialize Y with `3`.
-Initialize Z with `3`.
-Initialize N with `3`.
-Initialize S with `3`.
-Write Caml File "Handbook" [ pgm178 pgm186 pgm196 ].
diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v
deleted file mode 100644
index 07e77140..00000000
--- a/contrib/correctness/examples/fact.v
+++ /dev/null
@@ -1,69 +0,0 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: fact.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* Proof of an imperative program computing the factorial (over type nat) *)
-
-Require Correctness.
-Require Omega.
-Require Arith.
-
-Fixpoint fact [n:nat] : nat :=
-  Cases n of
-    O     => (S O)
-  | (S p) => (mult n (fact p))
-  end.
-
-(* (x * y) * (x-1)! = y * x!  *)
-
-Lemma fact_rec : (x,y:nat)(lt O x) ->
-  (mult (mult x y) (fact (pred x))) = (mult y (fact x)).
-Proof.
-Intros x y H.
-Generalize (mult_sym x y). Intro H1. Rewrite H1.
-Generalize (mult_assoc_r y x (fact (pred x))). Intro H2. Rewrite H2.
-Apply (f_equal nat nat [x:nat](mult y x)).
-Generalize H. Elim x; Auto with arith.
-Save.
-
-
-(* we declare two variables x and y *)
-
-Global Variable x : nat ref.
-Global Variable y : nat ref.
-
-(* we give the annotated program *)
-
-Correctness factorielle 
-  begin
-    y := (S O);
-    while (notzerop_bool !x) do
-      { invariant (mult y (fact x)) = (fact x@0) as I
-        variant x for lt }
-      y := (mult !x !y);
-      x := (pred !x)
-    done
-  end
-  { y = (fact x@0) }.
-Proof.
-Split.
-(* decreasing of the variant *)
-Omega.
-(* preservation of the invariant *)
-Rewrite <- I. Exact (fact_rec x0 y1 Test1).
-(* entrance of loop *)
-Auto with arith.
-(* exit of loop *)
-Elim I. Intros H1 H2.
-Rewrite H2 in H1.
-Rewrite <- H1.
-Auto with arith.
-Save.
diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v
deleted file mode 100644
index f463ca80..00000000
--- a/contrib/correctness/examples/fact_int.v
+++ /dev/null
@@ -1,195 +0,0 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: fact_int.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* Proof of an imperative program computing the factorial (over type Z) *)
-
-Require Correctness.
-Require Omega.
-Require ZArithRing.
-
-(* We define the factorial as a relation... *)
-
-Inductive fact : Z -> Z -> Prop :=
-    fact_0 : (fact `0` `1`)
-  | fact_S : (z,f:Z) (fact z f) -> (fact (Zs z) (Zmult (Zs z) f)).
-
-(* ...and then we prove that it contains a function *)
-
-Lemma fact_function : (z:Z) `0 <= z` -> (EX f:Z | (fact z f)).
-Proof.
-Intros.
-Apply natlike_ind with P:=[z:Z](EX f:Z | (fact z f)).
-Split with `1`.
-Exact fact_0.
-
-Intros.
-Elim H1.
-Intros.
-Split with `(Zs x)*x0`.
-Exact (fact_S x x0 H2).
-
-Assumption.
-Save.
-
-(* This lemma should belong to the ZArith library *)
-
-Lemma Z_mult_1 : (x,y:Z)`x>=1`->`y>=1`->`x*y>=1`.
-Proof.
-Intros.
-Generalize H.
-Apply natlike_ind with P:=[x:Z]`x >= 1`->`x*y >= 1`.
-Omega.
-
-Intros.
-Simpl.
-Elim (Z_le_lt_eq_dec `0` x0 H1).
-Simpl.
-Unfold Zs.
-Replace `(x0+1)*y` with `x0*y+y`.
-Generalize H2.
-Generalize `x0*y`.
-Intro.
-Intros.
-Omega.
-
-Ring.
-
-Intros.
-Rewrite <- b.
-Omega.
-
-Omega.
-Save.
-
-(* (fact x f) implies x>=0 and f>=1 *)
-
-Lemma fact_pos : (x,f:Z)(fact x f)-> `x>=0` /\ `f>=1`.
-Proof.
-Intros.
-(Elim H; Auto).
-Omega.
-
-Intros.
-(Split; Try Omega).
-(Apply Z_mult_1; Try Omega).
-Save.
-
-(* (fact 0 x) implies x=1 *)
-
-Lemma fact_0_1 : (x:Z)(fact `0` x) -> `x=1`.
-Proof.
-Intros.
-Inversion H.
-Reflexivity.
-
-Elim (fact_pos z f H1).
-Intros.
-(Absurd `z >= 0`; Omega).
-Save.
-
-
-(* We define the loop invariant : y * x! = x0! *)
-
-Inductive invariant [y,x,x0:Z] : Prop :=
-  c_inv : (f,f0:Z)(fact x f)->(fact x0 f0)->(Zmult y f)=f0
-       -> (invariant y x x0).
-
-(* The following lemma is used to prove the preservation of the invariant *)
-
-Lemma fact_rec : (x0,x,y:Z)`0 < x` ->
-    (invariant y x x0) 
- -> (invariant `x*y` (Zpred x) x0).
-Proof.
-Intros x0 x y H H0.
-Elim H0.
-Intros.
-Generalize H H0 H3.
-Elim H1.
-Intros.
-Absurd `0 < 0`; Omega.
-
-Intros.
-Apply c_inv with f:=f1 f0:=f0.
-Cut `z+1+-1 = z`. Intro eq_z. Rewrite <- eq_z in H4.
-Assumption.
-
-Omega.
-
-Assumption.
-
-Rewrite (Zmult_sym (Zs z) y).                     
-Rewrite (Zmult_assoc_r y (Zs z) f1).
-Auto.
-Save.
-
-
-(* This one is used to prove the proof obligation at the exit of the loop *)
-
-Lemma invariant_0 : (x,y:Z)(invariant y `0` x)->(fact x y).
-Proof.
-Intros.
-Elim H.
-Intros.
-Generalize (fact_0_1 f H0).
-Intro.
-Rewrite H3 in H2.
-Simpl in H2.
-Replace y with `y*1`.
-Rewrite H2.
-Assumption.
-
-Omega.
-Save.
-
-
-(* At last we come to the proof itself *************************************)
-
-(* we declare two variable x and y *)
-
-Global Variable x : Z ref.
-Global Variable y : Z ref.
-
-(* and we give the annotated program *)
-
-Correctness factorielle 
-  { `0 <= x` }
-  begin
-    y := 1;
-    while !x <> 0 do
-      { invariant `0 <= x` /\ (invariant y x x@0) as Inv
-        variant x for (Zwf ZERO) }
-      y := (Zmult !x !y);
-      x := (Zpred !x)
-    done
-  end
-  { (fact x@0 y) }.
-Proof.
-Split.
-(* decreasing *)
-Unfold Zwf. Unfold Zpred. Omega.
-(* preservation of the invariant *)
-Split.
-  Unfold Zpred; Omega.
-  Cut `0 < x0`. Intro Hx0.
-  Decompose [and] Inv.
-  Exact (fact_rec x x0 y1 Hx0 H0).
-  Omega.
-(* entrance of the loop *)
-Split; Auto.
-Elim (fact_function x Pre1). Intros.
-Apply c_inv with f:=x0 f0:=x0; Auto.
-Omega.
-(* exit of the loop *)
-Decompose [and] Inv.
-Rewrite H0 in H2.
-Exact (invariant_0 x y1 H2).
-Save.
diff --git a/contrib/correctness/preuves.v b/contrib/correctness/preuves.v
deleted file mode 100644
index 33659b43..00000000
--- a/contrib/correctness/preuves.v
+++ /dev/null
@@ -1,128 +0,0 @@
-
-(* Quelques preuves sur des programmes simples,
- * juste histoire d'avoir un petit bench.
- *)
-
-Require Correctness.
-Require Omega.
-
-Global Variable x : Z ref.
-Global Variable y : Z ref.
-Global Variable z : Z ref.
-Global Variable i : Z ref.
-Global Variable j : Z ref.
-Global Variable n : Z ref.
-Global Variable m : Z ref.
-Variable r : Z.
-Variable N : Z.
-Global Variable t : array N of Z.
-
-(**********************************************************************)
-
-Require Exchange.
-Require ArrayPermut.
-
-Correctness swap
-  fun (N:Z)(t:array N of Z)(i,j:Z) ->
-    { `0 <= i < N` /\ `0 <= j < N` }
-    (let v = t[i] in
-     begin
-       t[i] := t[j];
-       t[j] := v
-     end)
-    { (exchange t t@ i j) }.
-Proof.
-Auto with datatypes.
-Save.
-
-Correctness downheap
-  let rec downheap (N:Z)(t:array N of Z) : unit { variant `0` } =
-    (swap N t 0 0) { True }
-.
-
-(**********************************************************************)
-
-Global Variable x : Z ref.
-Debug on.
-Correctness assign0 (x := 0) { `x=0` }.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness assign1 { `0 <= i` } (i := !i + 1) { `0 < i` }.
-Omega.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness if0 { `0 <= i` } (if !i>0 then i:=!i-1 else tt) { `0 <= i` }.
-Omega.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness assert0 { `0 <= i` } begin assert { `i=2` }; i:=!i-1 end { `i=1` }.
-
-(**********************************************************************)
-
-Correctness echange
-  { `0 <= i < N` /\ `0 <= j < N` }
-  begin
-    label B;
-    x := t[!i]; t[!i] := t[!j]; t[!j] := !x;
-    assert { #t[i] = #t@B[j] /\ #t[j] = #t@B[i] }
-  end.
-Proof.
-Auto with datatypes.
-Save.
-
-  
-(**********************************************************************)
-
-(*
- *   while x <= y do x := x+1 done { y < x }
- *)
-
-Correctness incrementation
-  while !x < !y do
-    { invariant True variant `(Zs y)-x` }
-    x := !x + 1
-  done
-  { `y < x` }.
-Proof.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Omega.
-Exact I.
-Save.
-
-
-(************************************************************************)
-
-Correctness pivot1
-  begin
-    while (Z_lt_ge_dec !i r) do
-      { invariant True variant (Zminus (Zs r) i) } i := (Zs !i)
-    done;
-    while (Z_lt_ge_dec r !j) do
-      { invariant True variant (Zminus (Zs j) r) } j := (Zpred !j)
-    done
-  end
-  { `j <= r` /\ `r <= i` }.
-Proof.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Omega.
-Exact I.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Unfold Zpred. Omega.
-Exact I.
-Omega.
-Save.
-
-
-
diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml
deleted file mode 100644
index 9c035aa8..00000000
--- a/contrib/dp/dp_gappa.ml
+++ /dev/null
@@ -1,445 +0,0 @@
-
-open Format
-open Util
-open Pp
-open Term
-open Tacmach
-open Tactics
-open Tacticals
-open Names
-open Nameops
-open Termops
-open Coqlib
-open Hipattern
-open Libnames
-open Declarations
-open Evarutil
-
-let debug = ref false
-
-(* 1. gappa syntax trees and output *)
-
-module Constant = struct
-
-  open Bigint
-
-  type t = { mantissa : bigint; base : int; exp : bigint }
-
-  let create (b, m, e) =
-    { mantissa = m; base = b; exp = e }
-
-  let of_int x = 
-    { mantissa = x; base = 1; exp = zero }
-
-  let print fmt x = match x.base with
-    | 1 -> fprintf fmt "%s" (to_string x.mantissa)
-    | 2 -> fprintf fmt "%sb%s" (to_string x.mantissa) (to_string x.exp)
-    | 10 -> fprintf fmt "%se%s" (to_string x.mantissa) (to_string x.exp)
-    | _ -> assert false
-
-end
-
-type binop = Bminus | Bplus | Bmult | Bdiv
-
-type unop = Usqrt | Uabs | Uopp
-
-type rounding_mode = string
-
-type term =
-  | Tconst of Constant.t
-  | Tvar of string
-  | Tbinop of binop * term * term
-  | Tunop of unop * term
-  | Tround of rounding_mode * term
-
-type pred =
-  | Pin of term * Constant.t * Constant.t
-
-let rec print_term fmt = function
-  | Tconst c -> Constant.print fmt c
-  | Tvar s -> pp_print_string fmt s
-  | Tbinop (op, t1, t2) -> 
-      let op = match op with 
-	| Bplus -> "+" | Bminus -> "-" | Bmult -> "*" | Bdiv -> "/"
-      in
-      fprintf fmt "(%a %s %a)" print_term t1 op print_term t2
-  | Tunop (Uabs, t) ->
-      fprintf fmt "|%a|" print_term t
-  | Tunop (Uopp | Usqrt as op, t) ->
-      let s = match op with 
-	| Uopp -> "-" | Usqrt -> "sqrt" | _ -> assert false 
-      in
-      fprintf fmt "(%s(%a))" s print_term t
-  | Tround (m, t) ->
-      fprintf fmt "(%s(%a))" m print_term t
-
-let print_pred fmt = function
-  | Pin (t, c1, c2) -> 
-      fprintf fmt "%a in [%a, %a]" 
-	print_term t Constant.print c1 Constant.print c2
-
-let temp_file f = if !debug then f else Filename.temp_file f ".v"
-let remove_file f = if not !debug then try Sys.remove f with _ -> ()
-
-let read_gappa_proof f =
-  let buf = Buffer.create 1024 in
-  Buffer.add_char buf '(';
-  let cin = open_in f in
-  let rec skip_space () =
-    let c = input_char cin in if c = ' ' then skip_space () else c
-  in
-  while input_char cin <> '=' do () done;
-  try
-    while true do
-      let c = skip_space () in
-      if c = ':' then raise Exit;
-      Buffer.add_char buf c;
-      let s = input_line cin in
-      Buffer.add_string buf s; 
-      Buffer.add_char buf '\n';
-    done;
-    assert false
-  with Exit ->
-    close_in cin;
-    remove_file f;
-    Buffer.add_char buf ')';
-    Buffer.contents buf
-
-exception GappaFailed
-exception GappaProofFailed
-
-let patch_gappa_proof fin fout =
-  let cin = open_in fin in
-  let cout = open_out fout in
-  let fmt = formatter_of_out_channel cout in
-  let last = ref "" in
-  let defs = ref "" in
-  try
-    while true do
-      let s = input_line cin in
-      if s = "Qed." then
-	fprintf fmt "Defined.@\n"
-      else begin
-	begin 
-	  try Scanf.sscanf s "Lemma %s " 
-	    (fun n -> defs := n ^ " " ^ !defs; last := n)
-	  with Scanf.Scan_failure _ ->
-	    try Scanf.sscanf s "Definition %s " 
-	      (fun n -> defs := n ^ " " ^ !defs)
-	    with Scanf.Scan_failure _ ->
-	      ()
-	end;
-	fprintf fmt "%s@\n" s
-      end
-    done
-  with End_of_file ->
-    close_in cin;
-    fprintf fmt "Definition proof := Eval cbv delta [%s] in %s.@." !defs !last;
-    close_out cout
-    
-let call_gappa hl p =
-  let gappa_in = temp_file "gappa_input" in
-  let c = open_out gappa_in in
-  let fmt = formatter_of_out_channel c in
-  fprintf fmt "@[{ "; 
-  List.iter (fun h -> fprintf fmt "%a ->@ " print_pred h) hl;
-  fprintf fmt "%a }@]@." print_pred p;
-  close_out c;
-  let gappa_out = temp_file "gappa_output" in
-  let cmd = sprintf "gappa -Bcoq < %s > %s 2> /dev/null" gappa_in gappa_out in
-  let out = Sys.command cmd in
-  if out <> 0 then raise GappaFailed;
-  remove_file gappa_in;
-  let gappa_out2 = temp_file "gappa2" in
-  patch_gappa_proof gappa_out gappa_out2;
-  remove_file gappa_out;
-  let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out2 in
-  let out = Sys.command cmd in
-  if out <> 0 then raise GappaProofFailed;
-  let gappa_out3 = temp_file "gappa3" in
-  let c = open_out gappa_out3 in
-  let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in
-  Printf.fprintf c 
-    "Require \"%s\". Set Printing Depth 999999. Print %s.proof." 
-    (Filename.chop_suffix gappa_out2 ".v") gappa2;
-  close_out c;
-  let lambda = temp_file "gappa_lambda" in
-  let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out3 ^ " > " ^ lambda in
-  let out = Sys.command cmd in
-  if out <> 0 then raise GappaProofFailed;
-  remove_file gappa_out2; remove_file gappa_out3;
-  remove_file (gappa_out2 ^ "o"); remove_file (gappa_out3 ^ "o");
-  read_gappa_proof lambda
-
-(* 2. coq -> gappa translation *)
-
-exception NotGappa
-
-let logic_dir = ["Coq";"Logic";"Decidable"]
-let coq_modules =
-  init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
-    @ [["Coq"; "ZArith"; "BinInt"];
-       ["Coq"; "Reals"; "Rdefinitions"]; 
-       ["Coq"; "Reals"; "Raxioms";];
-       ["Coq"; "Reals"; "Rbasic_fun";];
-       ["Coq"; "Reals"; "R_sqrt";];
-       ["Coq"; "Reals"; "Rfunctions";];
-       ["Gappa"; "Gappa_tactic";];
-       ["Gappa"; "Gappa_fixed";];
-       ["Gappa"; "Gappa_float";];
-       ["Gappa"; "Gappa_round_def";];
-       ["Gappa"; "Gappa_pred_bnd";];  
-       ["Gappa"; "Gappa_definitions";];
-  ]
-
-let constant = gen_constant_in_modules "gappa" coq_modules
-
-let coq_refl_equal = lazy (constant "refl_equal")
-let coq_Rle = lazy (constant "Rle")
-let coq_R = lazy (constant "R")
-(*
-let coq_Rplus = lazy (constant "Rplus")
-let coq_Rminus = lazy (constant "Rminus")
-let coq_Rmult = lazy (constant "Rmult")
-let coq_Rdiv = lazy (constant "Rdiv")
-let coq_powerRZ = lazy (constant "powerRZ")
-let coq_R1 = lazy (constant "R1")
-let coq_Ropp = lazy (constant "Ropp")
-let coq_Rabs = lazy (constant "Rabs")
-let coq_sqrt = lazy (constant "sqrt")
-*)
-
-let coq_convert = lazy (constant "convert")
-let coq_reUnknown = lazy (constant "reUnknown")
-let coq_reFloat2 = lazy (constant "reFloat2")
-let coq_reFloat10 = lazy (constant "reFloat10")
-let coq_reInteger = lazy (constant "reInteger")
-let coq_reBinary = lazy (constant "reBinary")
-let coq_reUnary = lazy (constant "reUnary")
-let coq_reRound = lazy (constant "reRound")
-let coq_roundDN = lazy (constant "roundDN")
-let coq_roundUP = lazy (constant "roundUP")
-let coq_roundNE = lazy (constant "roundNE")
-let coq_roundZR = lazy (constant "roundZR")
-let coq_rounding_fixed = lazy (constant "rounding_fixed")
-let coq_rounding_float = lazy (constant "rounding_float")
-let coq_boAdd = lazy (constant "boAdd")
-let coq_boSub = lazy (constant "boSub")
-let coq_boMul = lazy (constant "boMul")
-let coq_boDiv = lazy (constant "boDiv")
-let coq_uoAbs = lazy (constant "uoAbs")
-let coq_uoNeg = lazy (constant "uoNeg")
-let coq_uoSqrt = lazy (constant "uoSqrt")
-let coq_subset = lazy (constant "subset")
-let coq_makepairF = lazy (constant "makepairF")
-
-let coq_true = lazy (constant "true")
-let coq_false = lazy (constant "false")
-
-let coq_Z0 = lazy (constant "Z0")
-let coq_Zpos = lazy (constant "Zpos")
-let coq_Zneg = lazy (constant "Zneg")
-let coq_xH = lazy (constant "xH")
-let coq_xI = lazy (constant "xI")
-let coq_xO = lazy (constant "xO")
-let coq_IZR = lazy (constant "IZR")
-
-(* translates a closed Coq term p:positive into a FOL term of type int *)
-let rec tr_positive p = match kind_of_term p with
-  | Term.Construct _ when p = Lazy.force coq_xH ->
-      1
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
-      2 * (tr_positive a) + 1
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
-      2 * (tr_positive a)
-  | Term.Cast (p, _, _) ->
-      tr_positive p
-  | _ ->
-      raise NotGappa
-
-(* translates a closed Coq term t:Z into a term of type int *)
-let rec tr_arith_constant t = match kind_of_term t with
-  | Term.Construct _ when t = Lazy.force coq_Z0 -> 0
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_positive a
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - (tr_positive a)
-  | Term.Cast (t, _, _) -> tr_arith_constant t
-  | _ -> raise NotGappa
-
-(* translates a closed Coq term p:positive into a FOL term of type bigint *)
-let rec tr_bigpositive p = match kind_of_term p with
-  | Term.Construct _ when p = Lazy.force coq_xH -> 
-      Bigint.one
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
-      Bigint.add_1 (Bigint.mult_2 (tr_bigpositive a))
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
-      (Bigint.mult_2 (tr_bigpositive a))
-  | Term.Cast (p, _, _) ->
-      tr_bigpositive p
-  | _ ->
-      raise NotGappa
-
-(* translates a closed Coq term t:Z into a term of type bigint *)
-let rec tr_arith_bigconstant t = match kind_of_term t with
-  | Term.Construct _ when t = Lazy.force coq_Z0 -> Bigint.zero
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_bigpositive a
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> 
-      Bigint.neg (tr_bigpositive a)
-  | Term.Cast (t, _, _) -> tr_arith_bigconstant t
-  | _ -> raise NotGappa
-
-let decomp c = 
-  let c, args = decompose_app c in
-  kind_of_term c, args
-
-let tr_bool c = match decompose_app c with
-  | c, [] when c = Lazy.force coq_true -> true
-  | c, [] when c = Lazy.force coq_false -> false
-  | _ -> raise NotGappa
-
-let tr_float b m e =
-  (b, tr_arith_bigconstant m, tr_arith_bigconstant e)
-
-let tr_binop c = match decompose_app c with
-  | c, [] when c = Lazy.force coq_boAdd -> Bplus
-  | c, [] when c = Lazy.force coq_boSub -> Bminus
-  | c, [] when c = Lazy.force coq_boMul -> Bmult
-  | c, [] when c = Lazy.force coq_boDiv -> Bdiv
-  | _ -> assert false
-
-let tr_unop c = match decompose_app c with
-  | c, [] when c = Lazy.force coq_uoNeg -> Uopp
-  | c, [] when c = Lazy.force coq_uoSqrt -> Usqrt
-  | c, [] when c = Lazy.force coq_uoAbs -> Uabs
-  | _ -> raise NotGappa
-
-let tr_var c = match decomp c with
-  | Var x, [] -> string_of_id x
-  | _ -> assert false
-
-let tr_mode c = match decompose_app c with
-  | c, [] when c = Lazy.force coq_roundDN -> "dn"
-  | c, [] when c = Lazy.force coq_roundNE -> "ne"
-  | c, [] when c = Lazy.force coq_roundUP -> "up"
-  | c, [] when c = Lazy.force coq_roundZR -> "zr"
-  | _ -> raise NotGappa
-
-let tr_rounding_mode c = match decompose_app c with
-  | c, [a;b] when c = Lazy.force coq_rounding_fixed ->
-      let a = tr_mode a in
-      let b = tr_arith_constant b in
-      sprintf "fixed<%d,%s>" b a
-  | c, [a;p;e] when c = Lazy.force coq_rounding_float ->
-      let a = tr_mode a in
-      let p = tr_positive p in
-      let e = tr_arith_constant e in
-      sprintf "float<%d,%d,%s>" p (-e) a
-  | _ ->
-      raise NotGappa
-
-(* REexpr -> term *)
-let rec tr_term c0 = 
-  let c, args = decompose_app c0 in
-  match kind_of_term c, args with
-    | _, [a] when c = Lazy.force coq_reUnknown ->
-	Tvar (tr_var a)
-    | _, [a; b] when c = Lazy.force coq_reFloat2 ->
-	Tconst (Constant.create (tr_float 2 a b))
-    | _, [a; b] when c = Lazy.force coq_reFloat10 ->
-	Tconst (Constant.create (tr_float 10 a b))
-    | _, [a] when c = Lazy.force coq_reInteger ->
-	Tconst (Constant.create (1, tr_arith_bigconstant a, Bigint.zero))
-    | _, [op;a;b] when c = Lazy.force coq_reBinary ->
-	Tbinop (tr_binop op, tr_term a, tr_term b)
-    | _, [op;a] when c = Lazy.force coq_reUnary ->
-	Tunop (tr_unop op, tr_term a)
-    | _, [op;a] when c = Lazy.force coq_reRound ->
-	Tround (tr_rounding_mode op, tr_term a)
-    | _ -> 
-	msgnl (str "tr_term: " ++ Printer.pr_constr c0); 
-	assert false
-
-let tr_rle c = 
-  let c, args = decompose_app c in
-  match kind_of_term c, args with
-    | _, [a;b] when c = Lazy.force coq_Rle ->  
-	begin match decompose_app a, decompose_app b with
-	  | (ac, [at]), (bc, [bt]) 
-	    when ac = Lazy.force coq_convert && bc = Lazy.force coq_convert ->
-	      at, bt
-	  | _ ->
-	      raise NotGappa
-	end
-    | _ -> 
-	raise NotGappa
-
-let tr_pred c =
-  let c, args = decompose_app c in
-  match kind_of_term c, args with
-    | _, [a;b] when c = build_coq_and () ->
-	begin match tr_rle a, tr_rle b with
-	  | (c1, t1), (t2, c2) when t1 = t2 -> 
-	      begin match tr_term c1, tr_term c2 with
-		| Tconst c1, Tconst c2 ->
-		    Pin (tr_term t1, c1, c2)
-		| _ -> 
-		    raise NotGappa
-	      end
-	  | _ -> 
-	      raise NotGappa
-	end
-    | _ -> 
-	raise NotGappa
-
-let is_R c = match decompose_app c with
-  | c, [] when c = Lazy.force coq_R -> true
-  | _ -> false
-
-let tr_hyps =
-  List.fold_left 
-    (fun acc (_,h) -> try tr_pred h :: acc with NotGappa -> acc) []
-
-let constr_of_string gl s = 
-  let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
-  Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
-
-let var_name = function
-  | Name id -> 
-      let s = string_of_id id in
-      let s = String.sub s 1 (String.length s - 1) in
-      mkVar (id_of_string s)
-  | Anonymous -> 
-       assert false
-
-let build_proof_term c0 =
-  let bl,c = decompose_lam c0 in
-  List.fold_right 
-    (fun (x,t) pf -> 
-      mkApp (pf, [| if is_R t then var_name x else mk_new_meta () |]))
-    bl c0
-
-let gappa_internal gl =
-  try
-    let c = tr_pred (pf_concl gl) in
-    let s = call_gappa (tr_hyps (pf_hyps_types gl)) c in
-    let pf = constr_of_string gl s in
-    let pf = build_proof_term pf in
-    Tacticals.tclTHEN (Tacmach.refine_no_check pf) Tactics.assumption gl
-  with 
-    | NotGappa -> error "not a gappa goal"
-    | GappaFailed -> error "gappa failed"
-    | GappaProofFailed -> error "incorrect gappa proof term"
-
-let gappa_prepare =
-  let id = Ident (dummy_loc, id_of_string "gappa_prepare") in
-  lazy (Tacinterp.interp (Tacexpr.TacArg (Tacexpr.Reference id)))
-
-let gappa gl =
-  Coqlib.check_required_library ["Gappa"; "Gappa_tactic"];
-  Tacticals.tclTHEN (Lazy.force gappa_prepare) gappa_internal gl
-
-(*
-Local Variables: 
-compile-command: "make -C ../.. bin/coqc.opt bin/coqide.opt"
-End: 
-*)
-
diff --git a/contrib/dp/test_gappa.v b/contrib/dp/test_gappa.v
deleted file mode 100644
index eb65a59d..00000000
--- a/contrib/dp/test_gappa.v
+++ /dev/null
@@ -1,91 +0,0 @@
-Require Export Gappa_tactic.
-Require Export Reals.
-
-Open Scope Z_scope.
-Open Scope R_scope.
-
-Lemma test_base10 : 
-  forall x y:R,
-  0 <= x <= 4 -> 
-  0 <= x * (24 * powerRZ 10 (-1)) <= 10.
-Proof.
-  gappa.
-Qed.
-
-(*
-@rnd = float< ieee_32, zr >;
-a = rnd(a_); b = rnd(b_);
-{ a in [3.2,3.3] /\ b in [1.4,1.9] ->
-  rnd(a - b) - (a - b) in [0,0] }
-*)
-
-Definition rnd := gappa_rounding (rounding_float roundZR 43 (120)).
-
-Lemma test_float3 :
-  forall a_ b_ a b : R,
-  a = rnd a_ ->
-  b = rnd b_ ->
-  52 / 16 <= a <= 53 / 16 ->
-  22 / 16 <= b <= 30 / 16 ->
-  0 <= rnd (a - b) - (a - b) <= 0.
-Proof.
-  unfold rnd.
-  gappa.
-Qed.
-
-Lemma test_float2 :
-  forall x y:R,
-  0 <= x <= 1 ->
-  0 <= y <= 1 ->
-  0 <= gappa_rounding (rounding_float roundNE 53 (1074)) (x+y) <= 2. 
-Proof.
-  gappa.
-Qed.
-
-Lemma test_float1 :
-  forall x y:R,
-  0 <= gappa_rounding (rounding_fixed roundDN (0)) x -
-           gappa_rounding (rounding_fixed roundDN (0)) y <= 0 ->
-  Rabs (x - y) <= 1.
-Proof.
-  gappa.
-Qed.
-
-Lemma test1 : 
-  forall x y:R,
-  0 <= x <= 1 -> 
-  0 <= -y <= 1 ->  
-  0 <= x  * (-y) <= 1.
-Proof.
-  gappa.
-Qed.
-
-Lemma test2 : 
-  forall x y:R,
-  3/4 <= x <= 3 -> 
-  0 <= sqrt x <= 1775 * (powerRZ 2 (-10)).
-Proof.
-  gappa.
-Qed.
-
-Lemma test3 : 
-  forall x y z:R,
-  0 <= x - y <= 3 -> 
-  -2 <= y - z <= 4 ->
-  -2 <= x - z <= 7.
-Proof.
-  gappa.
-Qed.
-
-Lemma test4 : 
-  forall x1 x2 y1 y2 : R,
-  1 <= Rabs y1 <= 1000 ->
-  1 <= Rabs y2 <= 1000 ->
-  - powerRZ 2 (-53) <= (x1 - y1) / y1 <= powerRZ 2 (-53) ->
-  - powerRZ 2 (-53) <= (x2 - y2) / y2 <= powerRZ 2 (-53) ->
-  - powerRZ 2 (-51) <= (x1 * x2 - y1 * y2) / (y1 * y2) <= powerRZ 2 (-51).
-Proof.
-  gappa.
-Qed.
-
-
diff --git a/contrib/extraction/BUGS b/contrib/extraction/BUGS
deleted file mode 100644
index 7f3f59c1..00000000
--- a/contrib/extraction/BUGS
+++ /dev/null
@@ -1,2 +0,0 @@
-It's not a bug, it's a lack of feature !!
-Cf TODO.
diff --git a/contrib/extraction/TODO b/contrib/extraction/TODO
deleted file mode 100644
index 174be06e..00000000
--- a/contrib/extraction/TODO
+++ /dev/null
@@ -1,31 +0,0 @@
-
- 16. Haskell : 
-     - equivalent of Obj.magic (unsafeCoerce ?) 
-     - look again at the syntax (make it independant of layout ...)  
-     - producing .hi files
-     - modules/modules types/functors in Haskell ?
-
- 17. Scheme : 
-     - modular Scheme ? 
-
- 18. Improve speed (profiling)
-
- 19. Look again at those hugly renamings functions. 
-     Especially get rid of ML clashes like 
-   
-    let t = 0
-    module M = struct 
-       let t = 1 
-       let u = The.External.t (* ?? *)
-    end
-
- 20. Support the .v-as-internal-module, like in 
-    
-    <file A.v>
-    Definition foo :=O.
-    <End file A.v>
-
-    <at toplevel>
-    Require A.
-    Module M:=A
-    Extraction M.
\ No newline at end of file
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT
deleted file mode 100644
index 23aeb6bb..00000000
--- a/contrib/interface/COPYRIGHT
+++ /dev/null
@@ -1,23 +0,0 @@
-(*****************************************************************************)
-(*                                                                           *)
-(*      Coq support for the Pcoq and tmEgg Graphical Interfaces of Coq       *)
-(*                                                                           *)
-(*        Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team)        *)
-(*        Copyright (C) 2006,2007 Lionel Elie Mamane                         *)
-(*                                                                           *)
-(*****************************************************************************)
-
-The current directory contrib/interface implements Coq support for the
-Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot
-with contributions from Loïc Pottier and Laurence Rideau.
-
-Modifications by Lionel Elie Mamane <lionel@mamane.lu> for
-generalising the protocol to suit other Coq interfaces.
-
-The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq)
-is developed by the Lemme team at INRIA Sophia-Antipolis (see
-http://www-sop.inria.fr/lemme)
-
-The files of the current directory are distributed under the terms of
-the GNU Lesser General Public License Version 2.1.
-
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
deleted file mode 100644
index 2eb2c381..00000000
--- a/contrib/interface/ascent.mli
+++ /dev/null
@@ -1,795 +0,0 @@
-type ct_AST =
-    CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT
-  | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING
-  | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE
-  | CT_astnode of ct_ID * ct_AST_LIST
-  | CT_astpath of ct_ID_LIST
-  | CT_astslam of ct_ID_OPT * ct_AST
-and ct_AST_LIST =
-    CT_ast_list of ct_AST list
-and ct_BINARY =
-    CT_binary of int
-and ct_BINDER =
-    CT_coerce_DEF_to_BINDER of ct_DEF
-  | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA
-  | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA
-and ct_BINDER_LIST =
-    CT_binder_list of ct_BINDER list
-and ct_BINDER_NE_LIST =
-    CT_binder_ne_list of ct_BINDER * ct_BINDER list
-and ct_BINDING =
-    CT_binding of ct_ID_OR_INT * ct_FORMULA
-and ct_BINDING_LIST =
-    CT_binding_list of ct_BINDING list
-and t_BOOL =
-    CT_false
-  | CT_true
-and ct_CASE =
-    CT_case of string
-and ct_CLAUSE =
-    CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT
-and ct_COERCION_OPT =
-    CT_coerce_NONE_to_COERCION_OPT of ct_NONE
-  | CT_coercion_atm
-and ct_COFIXTAC =
-    CT_cofixtac of ct_ID * ct_FORMULA
-and ct_COFIX_REC =
-    CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA
-and ct_COFIX_REC_LIST =
-    CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list
-and ct_COFIX_TAC_LIST =
-    CT_cofix_tac_list of ct_COFIXTAC list
-and ct_COMMAND =
-    CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST
-  | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD
-  | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN
-  | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL
-  | CT_abort of ct_ID_OPT_OR_ALL
-  | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST
-  | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT
-  | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID
-  | CT_addpath of ct_STRING * ct_ID_OPT
-  | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST
-  | CT_bind_scope of ct_ID * ct_ID_NE_LIST
-  | CT_cd of ct_STRING_OPT
-  | CT_check of ct_FORMULA
-  | CT_class of ct_ID
-  | CT_close_scope of ct_ID
-  | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID
-  | CT_cofix_decl of ct_COFIX_REC_LIST
-  | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT
-  | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR
-  | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT
-  | CT_delim_scope of ct_ID * ct_ID
-  | CT_delpath of ct_STRING
-  | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE
-  | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID
-  | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE
-  | CT_explain_proof of ct_INT_LIST
-  | CT_explain_prooftree of ct_INT_LIST
-  | CT_export_id of ct_ID_NE_LIST
-  | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST
-  | CT_extraction of ct_ID_OPT
-  | CT_fix_decl of ct_FIX_REC_LIST
-  | CT_focus of ct_INT_OPT
-  | CT_go of ct_INT_OR_LOCN
-  | CT_guarded
-  | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
-  | CT_hint_extern of ct_INT * ct_FORMULA_OPT * ct_TACTIC_COM * ct_ID_LIST
-  | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM
-  | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST
-  | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES
-  | CT_implicits of ct_ID * ct_ID_LIST_OPT
-  | CT_import_id of ct_ID_NE_LIST
-  | CT_ind_scheme of ct_SCHEME_SPEC_LIST
-  | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_inline of ct_ID_NE_LIST
-  | CT_inspect of ct_INT
-  | CT_kill_node of ct_INT
-  | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING
-  | CT_local_close_scope of ct_ID
-  | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
-  | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
-  | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST
-  | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_local_open_scope of ct_ID
-  | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST
-  | CT_locate of ct_ID
-  | CT_locate_file of ct_STRING
-  | CT_locate_lib of ct_ID
-  | CT_locate_notation of ct_STRING
-  | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST
-  | CT_ml_add_path of ct_STRING
-  | CT_ml_declare_modules of ct_STRING_NE_LIST
-  | CT_ml_print_modules
-  | CT_ml_print_path
-  | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR
-  | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT
-  | CT_no_inline of ct_ID_NE_LIST
-  | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE
-  | CT_open_scope of ct_ID
-  | CT_print
-  | CT_print_about of ct_ID
-  | CT_print_all
-  | CT_print_classes
-  | CT_print_ltac of ct_ID
-  | CT_print_coercions
-  | CT_print_grammar of ct_GRAMMAR
-  | CT_print_graph
-  | CT_print_hint of ct_ID_OPT
-  | CT_print_hintdb of ct_ID_OR_STAR
-  | CT_print_rewrite_hintdb of ct_ID
-  | CT_print_id of ct_ID
-  | CT_print_implicit of ct_ID
-  | CT_print_loadpath
-  | CT_print_module of ct_ID
-  | CT_print_module_type of ct_ID
-  | CT_print_modules
-  | CT_print_natural of ct_ID
-  | CT_print_natural_feature of ct_NATURAL_FEATURE
-  | CT_print_opaqueid of ct_ID
-  | CT_print_path of ct_ID * ct_ID
-  | CT_print_proof of ct_ID
-  | CT_print_setoids
-  | CT_print_scope of ct_ID
-  | CT_print_scopes
-  | CT_print_section of ct_ID
-  | CT_print_states
-  | CT_print_tables
-  | CT_print_universes of ct_STRING_OPT
-  | CT_print_visibility of ct_ID_OPT
-  | CT_proof of ct_FORMULA
-  | CT_proof_no_op
-  | CT_proof_with of ct_TACTIC_COM
-  | CT_pwd
-  | CT_quit
-  | CT_read_module of ct_ID
-  | CT_rec_ml_add_path of ct_STRING
-  | CT_recaddpath of ct_STRING * ct_ID_OPT
-  | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST
-  | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID
-  | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING
-  | CT_reserve of ct_ID_NE_LIST * ct_FORMULA
-  | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST
-  | CT_reset of ct_ID
-  | CT_reset_section of ct_ID
-  | CT_restart
-  | CT_restore_state of ct_ID
-  | CT_resume of ct_ID_OPT
-  | CT_save of ct_THM_OPT * ct_ID_OPT
-  | CT_scomments of ct_SCOMMENT_CONTENT_LIST
-  | CT_search of ct_ID * ct_IN_OR_OUT_MODULES
-  | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES
-  | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES
-  | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES
-  | CT_section_end of ct_ID
-  | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND
-  | CT_set_natural of ct_ID
-  | CT_set_natural_default
-  | CT_set_option of ct_TABLE
-  | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE
-  | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST
-  | CT_sethyp of ct_INT
-  | CT_setundo of ct_INT
-  | CT_show_existentials
-  | CT_show_goal of ct_INT_OPT
-  | CT_show_implicit of ct_INT
-  | CT_show_intro
-  | CT_show_intros
-  | CT_show_node
-  | CT_show_proof
-  | CT_show_proofs
-  | CT_show_script
-  | CT_show_tree
-  | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT
-  | CT_strategy of ct_LEVEL_LIST
-  | CT_suspend
-  | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT
-  | CT_tactic_definition of ct_TAC_DEF_NE_LIST
-  | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID
-  | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT
-  | CT_time of ct_COMMAND
-  | CT_undo of ct_INT_OPT
-  | CT_unfocus
-  | CT_unset_option of ct_TABLE
-  | CT_unsethyp
-  | CT_unsetundo
-  | CT_user_vernac of ct_ID * ct_VARG_LIST
-  | CT_variable of ct_VAR * ct_BINDER_NE_LIST
-  | CT_write_module of ct_ID * ct_STRING_OPT
-and ct_LEVEL_LIST =
-    CT_level_list of (ct_LEVEL * ct_ID_LIST) list
-and ct_LEVEL =
-    CT_Opaque
-  | CT_Level of ct_INT
-  | CT_Expand
-and ct_COMMAND_LIST =
-    CT_command_list of ct_COMMAND * ct_COMMAND list
-and ct_COMMENT =
-    CT_comment of string
-and ct_COMMENT_S =
-    CT_comment_s of ct_COMMENT list
-and ct_CONSTR =
-    CT_constr of ct_ID * ct_FORMULA
-  | CT_constr_coercion of ct_ID * ct_FORMULA
-and ct_CONSTR_LIST =
-    CT_constr_list of ct_CONSTR list
-and ct_CONTEXT_HYP_LIST =
-    CT_context_hyp_list of ct_PREMISE_PATTERN list
-and ct_CONTEXT_PATTERN =
-    CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA
-  | CT_context of ct_ID_OPT * ct_FORMULA
-and ct_CONTEXT_RULE =
-    CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM
-  | CT_def_context_rule of ct_TACTIC_COM
-and ct_CONVERSION_FLAG =
-    CT_beta
-  | CT_delta
-  | CT_evar
-  | CT_iota
-  | CT_zeta
-and ct_CONVERSION_FLAG_LIST =
-    CT_conversion_flag_list of ct_CONVERSION_FLAG list
-and ct_CONV_SET =
-    CT_unf of ct_ID list
-  | CT_unfbut of ct_ID list
-and ct_CO_IND =
-    CT_co_ind of string
-and ct_DECL_NOTATION_OPT =
-    CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE
-  | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT
-and ct_DEF =
-    CT_def of ct_ID_OPT * ct_FORMULA
-and ct_DEFN =
-    CT_defn of string
-and ct_DEFN_OR_THM =
-    CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN
-  | CT_coerce_THM_to_DEFN_OR_THM of ct_THM
-and ct_DEF_BODY =
-    CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN
-  | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD
-  | CT_type_of of ct_FORMULA
-and ct_DEF_BODY_OPT =
-    CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY
-  | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT
-and ct_DEP =
-    CT_dep of string
-and ct_DESTRUCTING =
-    CT_coerce_NONE_to_DESTRUCTING of ct_NONE
-  | CT_destructing
-and ct_DESTRUCT_LOCATION =
-    CT_conclusion_location
-  | CT_discardable_hypothesis
-  | CT_hypothesis_location
-and ct_DOTDOT_OPT =
-    CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE
-  | CT_dotdot
-and ct_EQN =
-    CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA
-and ct_EQN_LIST =
-    CT_eqn_list of ct_EQN list
-and ct_EVAL_CMD =
-    CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA
-and ct_FIXTAC =
-    CT_fixtac of ct_ID * ct_INT * ct_FORMULA
-and ct_FIX_BINDER =
-    CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC
-  | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA
-and ct_FIX_BINDER_LIST =
-    CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list
-and ct_FIX_REC =
-    CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT *
-      ct_FORMULA * ct_FORMULA
-and ct_FIX_REC_LIST =
-    CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list
-and ct_FIX_TAC_LIST =
-    CT_fix_tac_list of ct_FIXTAC list
-and ct_FORMULA =
-    CT_coerce_BINARY_to_FORMULA of ct_BINARY
-  | CT_coerce_ID_to_FORMULA of ct_ID
-  | CT_coerce_NUM_to_FORMULA of ct_NUM
-  | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE
-  | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA
-  | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST
-  | CT_arrowc of ct_FORMULA * ct_FORMULA
-  | CT_bang of ct_FORMULA
-  | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST
-  | CT_cofixc of ct_ID * ct_COFIX_REC_LIST
-  | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST
-  | CT_existvarc
-  | CT_fixc of ct_ID * ct_FIX_BINDER_LIST
-  | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA
-  | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA
-  | CT_labelled_arg of ct_ID * ct_FORMULA
-  | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA
-  | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA
-  | CT_letin of ct_DEF * ct_FORMULA
-  | CT_notation of ct_STRING * ct_FORMULA_LIST
-  | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA
-  | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA
-  | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST
-and ct_FORMULA_LIST =
-    CT_formula_list of ct_FORMULA list
-and ct_FORMULA_NE_LIST =
-    CT_formula_ne_list of ct_FORMULA * ct_FORMULA list
-and ct_FORMULA_OPT =
-    CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA
-  | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT
-and ct_FORMULA_OR_INT =
-    CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA
-  | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT
-and ct_GRAMMAR =
-    CT_grammar_none
-and ct_HYP_LOCATION =
-    CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD
-  | CT_intype of ct_ID * ct_INT_LIST
-  | CT_invalue of ct_ID * ct_INT_LIST
-and ct_HYP_LOCATION_LIST_OR_STAR =
-    CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR
-  | CT_hyp_location_list of ct_HYP_LOCATION list
-and ct_ID =
-    CT_ident of string
-  | CT_metac of ct_INT
-  | CT_metaid of string
-and ct_IDENTITY_OPT =
-    CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE
-  | CT_identity
-and ct_ID_LIST =
-    CT_id_list of ct_ID list
-and ct_ID_LIST_LIST =
-    CT_id_list_list of ct_ID_LIST list
-and ct_ID_LIST_OPT =
-    CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST
-  | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE
-and ct_ID_NE_LIST =
-    CT_id_ne_list of ct_ID * ct_ID list
-and ct_ID_NE_LIST_OR_STAR =
-    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST
-  | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR
-and ct_ID_NE_LIST_OR_STRING =
-    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST
-  | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING
-and ct_ID_OPT =
-    CT_coerce_ID_to_ID_OPT of ct_ID
-  | CT_coerce_NONE_to_ID_OPT of ct_NONE
-and ct_ID_OPT_LIST =
-    CT_id_opt_list of ct_ID_OPT list
-and ct_ID_OPT_NE_LIST =
-    CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list
-and ct_ID_OPT_OR_ALL =
-    CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT
-  | CT_all
-and ct_ID_OR_INT =
-    CT_coerce_ID_to_ID_OR_INT of ct_ID
-  | CT_coerce_INT_to_ID_OR_INT of ct_INT
-and ct_ID_OR_INT_OPT =
-    CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT
-  | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT
-  | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT
-and ct_ID_OR_STAR =
-    CT_coerce_ID_to_ID_OR_STAR of ct_ID
-  | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR
-and ct_ID_OR_STRING =
-    CT_coerce_ID_to_ID_OR_STRING of ct_ID
-  | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING
-and ct_ID_OR_STRING_NE_LIST =
-    CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list
-and ct_IMPEXP =
-    CT_coerce_NONE_to_IMPEXP of ct_NONE
-  | CT_export
-  | CT_import
-and ct_IND_SPEC =
-    CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT
-and ct_IND_SPEC_LIST =
-    CT_ind_spec_list of ct_IND_SPEC list
-and ct_INT =
-    CT_int of int
-and ct_INTRO_PATT =
-    CT_coerce_ID_to_INTRO_PATT of ct_ID
-  | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list
-and ct_INTRO_PATT_LIST =
-    CT_intro_patt_list of ct_INTRO_PATT list
-and ct_INTRO_PATT_OPT =
-    CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT
-  | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT
-and ct_INT_LIST =
-    CT_int_list of ct_INT list
-and ct_INT_NE_LIST =
-    CT_int_ne_list of ct_INT * ct_INT list
-and ct_INT_OPT =
-    CT_coerce_INT_to_INT_OPT of ct_INT
-  | CT_coerce_NONE_to_INT_OPT of ct_NONE
-and ct_INT_OR_LOCN =
-    CT_coerce_INT_to_INT_OR_LOCN of ct_INT
-  | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN
-and ct_INT_OR_NEXT =
-    CT_coerce_INT_to_INT_OR_NEXT of ct_INT
-  | CT_next_level
-and ct_INV_TYPE =
-    CT_inv_clear
-  | CT_inv_regular
-  | CT_inv_simple
-and ct_IN_OR_OUT_MODULES =
-    CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE
-  | CT_in_modules of ct_ID_NE_LIST
-  | CT_out_modules of ct_ID_NE_LIST
-and ct_LET_CLAUSE =
-    CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE
-and ct_LET_CLAUSES =
-    CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list
-and ct_LET_VALUE =
-    CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY
-  | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM
-and ct_LOCAL_OPT =
-    CT_coerce_NONE_to_LOCAL_OPT of ct_NONE
-  | CT_local
-and ct_LOCN =
-    CT_locn of string
-and ct_MATCHED_FORMULA =
-    CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA
-  | CT_formula_as of ct_FORMULA * ct_ID_OPT
-  | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA
-  | CT_formula_in of ct_FORMULA * ct_FORMULA
-and ct_MATCHED_FORMULA_NE_LIST =
-    CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list
-and ct_MATCH_PATTERN =
-    CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT
-  | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM
-  | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST
-  | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT
-  | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN
-  | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST
-and ct_MATCH_PATTERN_LIST =
-    CT_match_pattern_list of ct_MATCH_PATTERN list
-and ct_MATCH_PATTERN_NE_LIST =
-    CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list
-and ct_MATCH_TAC_RULE =
-    CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE
-and ct_MATCH_TAC_RULES =
-    CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list
-and ct_MODIFIER =
-    CT_entry_type of ct_ID * ct_ID
-  | CT_format of ct_STRING
-  | CT_lefta
-  | CT_nona
-  | CT_only_parsing
-  | CT_righta
-  | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT
-  | CT_set_level of ct_INT
-and ct_MODIFIER_LIST =
-    CT_modifier_list of ct_MODIFIER list
-and ct_MODULE_BINDER =
-    CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE
-and ct_MODULE_BINDER_LIST =
-    CT_module_binder_list of ct_MODULE_BINDER list
-and ct_MODULE_EXPR =
-    CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT
-  | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR
-and ct_MODULE_TYPE =
-    CT_coerce_ID_to_MODULE_TYPE of ct_ID
-  | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID_LIST * ct_FORMULA
-  | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID_LIST * ct_ID
-and ct_MODULE_TYPE_CHECK =
-    CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT
-  | CT_only_check of ct_MODULE_TYPE
-and ct_MODULE_TYPE_OPT =
-    CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT
-  | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE
-and ct_NATURAL_FEATURE =
-    CT_contractible
-  | CT_implicit
-  | CT_nat_transparent
-and ct_NONE =
-    CT_none
-and ct_NUM =
-    CT_int_encapsulator of string
-and ct_NUM_TYPE =
-    CT_num_type of string
-and ct_OMEGA_FEATURE =
-    CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING
-  | CT_flag_action
-  | CT_flag_system
-  | CT_flag_time
-and ct_OMEGA_MODE =
-    CT_set
-  | CT_switch
-  | CT_unset
-and ct_ORIENTATION =
-    CT_lr
-  | CT_rl
-and ct_PATTERN =
-    CT_pattern_occ of ct_INT_LIST * ct_FORMULA
-and ct_PATTERN_NE_LIST =
-    CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list
-and ct_PATTERN_OPT =
-    CT_coerce_NONE_to_PATTERN_OPT of ct_NONE
-  | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN
-and ct_PREMISE =
-    CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA
-  | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA
-  | CT_premise of ct_ID * ct_FORMULA
-and ct_PREMISES_LIST =
-    CT_premises_list of ct_PREMISE list
-and ct_PREMISE_PATTERN =
-    CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN
-and ct_PROOF_SCRIPT =
-    CT_proof_script of ct_COMMAND list
-and ct_RECCONSTR =
-    CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT
-  | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT
-  | CT_recconstr of ct_ID_OPT * ct_FORMULA
-  | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA
-and ct_RECCONSTR_LIST =
-    CT_recconstr_list of ct_RECCONSTR list
-and ct_REC_TACTIC_FUN =
-    CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM
-and ct_REC_TACTIC_FUN_LIST =
-    CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list
-and ct_RED_COM =
-    CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
-  | CT_fold of ct_FORMULA_LIST
-  | CT_hnf
-  | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
-  | CT_pattern of ct_PATTERN_NE_LIST
-  | CT_red
-  | CT_cbvvm
-  | CT_simpl of ct_PATTERN_OPT
-  | CT_unfold of ct_UNFOLD_NE_LIST
-and ct_RETURN_INFO =
-    CT_coerce_NONE_to_RETURN_INFO of ct_NONE
-  | CT_as_and_return of ct_ID_OPT * ct_FORMULA
-  | CT_return of ct_FORMULA
-and ct_RULE =
-    CT_rule of ct_PREMISES_LIST * ct_FORMULA
-and ct_RULE_LIST =
-    CT_rule_list of ct_RULE list
-and ct_SCHEME_SPEC =
-    CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE
-and ct_SCHEME_SPEC_LIST =
-    CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list
-and ct_SCOMMENT_CONTENT =
-    CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA
-  | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING
-and ct_SCOMMENT_CONTENT_LIST =
-    CT_scomment_content_list of ct_SCOMMENT_CONTENT list
-and ct_SECTION_BEGIN =
-    CT_section of ct_ID
-and ct_SECTION_BODY =
-    CT_section_body of ct_COMMAND list
-and ct_SIGNED_INT =
-    CT_coerce_INT_to_SIGNED_INT of ct_INT
-  | CT_minus of ct_INT
-and ct_SIGNED_INT_LIST =
-    CT_signed_int_list of ct_SIGNED_INT list
-and ct_SINGLE_OPTION_VALUE =
-    CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT
-  | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING
-and ct_SORT_TYPE =
-    CT_sortc of string
-and ct_SPEC_LIST =
-    CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST
-  | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST
-and ct_SPEC_OPT =
-    CT_coerce_NONE_to_SPEC_OPT of ct_NONE
-  | CT_spec
-and ct_STAR =
-    CT_star
-and ct_STAR_OPT =
-    CT_coerce_NONE_to_STAR_OPT of ct_NONE
-  | CT_coerce_STAR_to_STAR_OPT of ct_STAR
-and ct_STRING =
-    CT_string of string
-and ct_STRING_NE_LIST =
-    CT_string_ne_list of ct_STRING * ct_STRING list
-and ct_STRING_OPT =
-    CT_coerce_NONE_to_STRING_OPT of ct_NONE
-  | CT_coerce_STRING_to_STRING_OPT of ct_STRING
-and ct_TABLE =
-    CT_coerce_ID_to_TABLE of ct_ID
-  | CT_table of ct_ID * ct_ID
-and ct_TACTIC_ARG =
-    CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD
-  | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT
-  | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM
-  | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE
-  | CT_void
-and ct_TACTIC_ARG_LIST =
-    CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list
-and ct_TACTIC_COM =
-    CT_abstract of ct_ID_OPT * ct_TACTIC_COM
-  | CT_absurd of ct_FORMULA
-  | CT_any_constructor of ct_TACTIC_OPT
-  | CT_apply of ct_FORMULA * ct_SPEC_LIST
-  | CT_assert of ct_ID_OPT * ct_FORMULA
-  | CT_assumption
-  | CT_auto of ct_INT_OPT
-  | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR
-  | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT
-  | CT_autotdb of ct_INT_OPT
-  | CT_case_type of ct_FORMULA
-  | CT_casetac of ct_FORMULA * ct_SPEC_LIST
-  | CT_cdhyp of ct_ID
-  | CT_change of ct_FORMULA * ct_CLAUSE
-  | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE
-  | CT_clear of ct_ID_NE_LIST
-  | CT_clear_body of ct_ID_NE_LIST
-  | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST
-  | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
-  | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
-  | CT_constructor of ct_INT * ct_SPEC_LIST
-  | CT_contradiction
-  | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST
-  | CT_cut of ct_FORMULA
-  | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT
-  | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT
-  | CT_dauto of ct_INT_OPT * ct_INT_OPT
-  | CT_dconcl
-  | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA
-  | CT_decompose_record of ct_FORMULA
-  | CT_decompose_sum of ct_FORMULA
-  | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT
-  | CT_deprewrite_lr of ct_ID
-  | CT_deprewrite_rl of ct_ID
-  | CT_destruct of ct_ID_OR_INT
-  | CT_dhyp of ct_ID
-  | CT_discriminate_eq of ct_ID_OR_INT_OPT
-  | CT_do of ct_ID_OR_INT * ct_TACTIC_COM
-  | CT_eapply of ct_FORMULA * ct_SPEC_LIST
-  | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT
-  | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR
-  | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING
-  | CT_elim_type of ct_FORMULA
-  | CT_exact of ct_FORMULA
-  | CT_exact_no_check of ct_FORMULA
-  | CT_vm_cast_no_check of ct_FORMULA
-  | CT_exists of ct_SPEC_LIST
-  | CT_fail of ct_ID_OR_INT * ct_STRING_OPT
-  | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_firstorder of ct_TACTIC_OPT
-  | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST
-  | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST
-  | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST
-  | CT_formula_marker of ct_FORMULA
-  | CT_fresh of ct_STRING_OPT
-  | CT_generalize of ct_FORMULA_NE_LIST
-  | CT_generalize_dependent of ct_FORMULA
-  | CT_idtac of ct_STRING_OPT
-  | CT_induction of ct_ID_OR_INT
-  | CT_info of ct_TACTIC_COM
-  | CT_injection_eq of ct_ID_OR_INT_OPT
-  | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE
-  | CT_intro of ct_ID_OPT
-  | CT_intro_after of ct_ID_OPT * ct_ID
-  | CT_intros of ct_INTRO_PATT_LIST
-  | CT_intros_until of ct_ID_OR_INT
-  | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST
-  | CT_left of ct_SPEC_LIST
-  | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE
-  | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE
-  | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list
-  | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list
-  | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES
-  | CT_move_after of ct_ID * ct_ID
-  | CT_new_destruct of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT
-  | CT_new_induction of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT
-  | CT_omega
-  | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM
-  | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_pose of ct_ID_OPT * ct_FORMULA
-  | CT_progress of ct_TACTIC_COM
-  | CT_prolog of ct_FORMULA_LIST * ct_INT
-  | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM
-  | CT_reduce of ct_RED_COM * ct_CLAUSE
-  | CT_refine of ct_FORMULA
-  | CT_reflexivity
-  | CT_rename of ct_ID * ct_ID
-  | CT_repeat of ct_TACTIC_COM
-  | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT
-  | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
-  | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
-  | CT_right of ct_SPEC_LIST
-  | CT_ring of ct_FORMULA_LIST
-  | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST
-  | CT_simplify_eq of ct_ID_OR_INT_OPT
-  | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST
-  | CT_split of ct_SPEC_LIST
-  | CT_subst of ct_ID_LIST
-  | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB
-  | CT_symmetry of ct_CLAUSE
-  | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT
-  | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM
-  | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_transitivity of ct_FORMULA
-  | CT_trivial
-  | CT_trivial_with of ct_ID_NE_LIST_OR_STAR
-  | CT_truecut of ct_ID_OPT * ct_FORMULA
-  | CT_try of ct_TACTIC_COM
-  | CT_use of ct_FORMULA
-  | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST
-  | CT_user_tac of ct_ID * ct_TARG_LIST
-and ct_TACTIC_OPT =
-    CT_coerce_NONE_to_TACTIC_OPT of ct_NONE
-  | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM
-and ct_TAC_DEF =
-    CT_tac_def of ct_ID * ct_TACTIC_COM
-and ct_TAC_DEF_NE_LIST =
-    CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list
-and ct_TARG =
-    CT_coerce_BINDING_to_TARG of ct_BINDING
-  | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC
-  | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC
-  | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT
-  | CT_coerce_PATTERN_to_TARG of ct_PATTERN
-  | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT
-  | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST
-  | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE
-  | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST
-  | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM
-  | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST
-  | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD
-  | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST
-and ct_TARG_LIST =
-    CT_targ_list of ct_TARG list
-and ct_TERM_CHANGE =
-    CT_check_term of ct_FORMULA
-  | CT_inst_term of ct_ID * ct_FORMULA
-and ct_TEXT =
-    CT_coerce_ID_to_TEXT of ct_ID
-  | CT_text_formula of ct_FORMULA
-  | CT_text_h of ct_TEXT list
-  | CT_text_hv of ct_TEXT list
-  | CT_text_op of ct_TEXT list
-  | CT_text_path of ct_SIGNED_INT_LIST
-  | CT_text_v of ct_TEXT list
-and ct_THEOREM_GOAL =
-    CT_goal of ct_FORMULA
-  | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA
-and ct_THM =
-    CT_thm of string
-and ct_THM_OPT =
-    CT_coerce_NONE_to_THM_OPT of ct_NONE
-  | CT_coerce_THM_to_THM_OPT of ct_THM
-and ct_TYPED_FORMULA =
-    CT_typed_formula of ct_FORMULA * ct_FORMULA
-and ct_UNFOLD =
-    CT_coerce_ID_to_UNFOLD of ct_ID
-  | CT_unfold_occ of ct_ID * ct_INT_NE_LIST
-and ct_UNFOLD_NE_LIST =
-    CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list
-and ct_USING =
-    CT_coerce_NONE_to_USING of ct_NONE
-  | CT_using of ct_FORMULA * ct_SPEC_LIST
-and ct_USINGTDB =
-    CT_coerce_NONE_to_USINGTDB of ct_NONE
-  | CT_usingtdb
-and ct_VAR =
-    CT_var of string
-and ct_VARG =
-    CT_coerce_AST_to_VARG of ct_AST
-  | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST
-  | CT_coerce_BINDER_to_VARG of ct_BINDER
-  | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST
-  | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST
-  | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST
-  | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT
-  | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT
-  | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL
-  | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT
-  | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST
-  | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT
-  | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT
-  | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT
-  | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST
-and ct_VARG_LIST =
-    CT_varg_list of ct_VARG list
-and ct_VERBOSE_OPT =
-    CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE
-  | CT_verbose
-;;
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
deleted file mode 100644
index 483453cb..00000000
--- a/contrib/interface/blast.ml
+++ /dev/null
@@ -1,627 +0,0 @@
-(* Une tactique qui tente de démontrer toute seule le but courant,
-   interruptible par pcoq (si dans le fichier C:\WINDOWS\free il y a un A)
-*)
-open Termops;;
-open Nameops;;
-open Auto;;
-open Clenv;;
-open Command;;
-open Declarations;;
-open Declare;;
-open Eauto;;
-open Environ;;
-open Equality;;
-open Evd;;
-open Hipattern;;
-open Inductive;;
-open Names;;
-open Pattern;;
-open Pbp;;
-open Pfedit;;
-open Pp;;
-open Printer
-open Proof_trees;;
-open Proof_type;;
-open Rawterm;;
-open Reduction;;
-open Refiner;;
-open Sign;;
-open String;;
-open Tacmach;;
-open Tacred;;
-open Tacticals;;
-open Tactics;;
-open Term;;
-open Typing;;
-open Util;;
-open Vernacentries;;
-open Vernacinterp;;
-
-
-let parse_com   = Pcoq.parse_string Pcoq.Constr.constr;;
-let parse_tac  t =
-    try (Pcoq.parse_string Pcoq.Tactic.tactic t)
-    with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t));
-	       failwith "tactic")
-;;
-
-let is_free () =
-   let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in
-   let c=input_char st in
-   close_in st;
-   c = 'A'
-;;
-
-(* marche pas *)
-(*
-let is_free () =
-   msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]);
-   let s = Stream.of_channel stdin in
-   msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]);
-   try (Stream.empty s;
-        msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]);
-        true)
-   with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]);
-              false)
-;;
-*)
-let free_try tac g =
-    if is_free()
-    then (tac g)
-    else (failwith "not free")
-;;
-let adrel (x,t) e =
-    match x with 
-      Name(xid) -> Environ.push_rel (x,None,t) e
-    | Anonymous -> Environ.push_rel (x,None,t) e
-(* les constantes ayant une définition apparaissant dans x *)
-let rec def_const_in_term_rec vl x = 
-     match (kind_of_term x) with
-     Prod(n,t,c)->
-        let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c
-   | Lambda(n,t,c) ->
-        let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c
-   | App(f,args) -> def_const_in_term_rec vl f
-   | Sort(Prop(Null)) -> Prop(Null)
-   | Sort(c) -> c
-   | Ind(ind) ->
-          let (mib, mip) = Global.lookup_inductive ind in
-	  new_sort_in_family (inductive_sort_family mip)
-   | Construct(c) ->
-          def_const_in_term_rec vl (mkInd (inductive_of_constructor c))
-   | Case(_,x,t,a) 
-        -> def_const_in_term_rec vl x
-   | Cast(x,_,t)-> def_const_in_term_rec vl t
-   | Const(c)  -> def_const_in_term_rec vl (Typeops.type_of_constant vl c)
-   | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x)
-;;
-let def_const_in_term_ x =
-    def_const_in_term_rec  (Global.env()) (strip_outer_cast x)
-;;
-(*************************************************************************
- recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli 
- modif de print_info_script avec pr_bar
-*)
-
-let pr_bar () = str "|"
-
-let rec print_info_script sigma osign pf =
-  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
-  match pf.ref with
-    | None -> (mt ())
-    | Some(r,spfl) ->
-        Tactic_printer.pr_rule r ++
-           match spfl with
-             | [] ->
-		   (str " " ++ fnl())
-             | [pf1] ->
-                 if pf1.ref = None then 
-		   (str " " ++ fnl())
-                 else 
-		   (str";" ++ brk(1,3) ++
-		      print_info_script sigma sign pf1)
-             | _ -> ( str";[" ++ fnl() ++
-                       prlist_with_sep pr_bar
-                         (print_info_script sigma sign) spfl ++
-                       str"]")
-
-let format_print_info_script sigma osign pf = 
-  hov 0 (print_info_script sigma osign pf)
-    
-let print_subscript sigma sign pf = 
- (* if is_tactic_proof pf then 
-    format_print_info_script sigma sign (subproof_of_proof pf)
-  else *)
-    format_print_info_script sigma sign pf
-(****************)
-
-let pp_string x =
-   msgnl_with Format.str_formatter x;
-   Format.flush_str_formatter ()
-;;
-
-(***********************************************************************
-   copié de tactics/eauto.ml
-*)
-
-(***************************************************************************)
-(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
-(***************************************************************************)
-
-let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
-
-let unify_e_resolve  (c,clenv) gls = 
-  let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver false clenv' gls in
-    Hiddentac.h_simplest_eapply c gls
-
-let rec e_trivial_fail_db db_list local_db goal =
-  let tacl = 
-    registered_e_assumption ::
-    (tclTHEN Tactics.intro 
-       (function g'->
-	  let d = pf_last_hyp g' in
-	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
-          (e_trivial_fail_db db_list
-	     (Hint_db.add_list hintl local_db) g'))) ::
-    (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
-  in 
-  tclFIRST (List.map tclCOMPLETE tacl) goal 
-
-and e_my_find_search db_list local_db hdc concl = 
-  let hdc = head_of_constr_reference hdc in
-  let hintl =
-    if occur_existential concl then 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
-    else 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
-  in 
-  let tac_of_hint = 
-    fun (st, ({pri=b; pat = p; code=t} as _patac)) -> 
-      (b, 
-       let tac =
-	 match t with
-	   | Res_pf (term,cl) -> unify_resolve st (term,cl)
-	   | ERes_pf (term,cl) -> unify_e_resolve (term,cl)
-	   | Give_exact (c) -> e_give_exact_constr c
-	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve (term,cl)) 
-		 (e_trivial_fail_db db_list local_db)
-	   | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
-	   | Extern tacast -> Auto.conclPattern concl p tacast
-       in 
-       (free_try tac,pr_autotactic t))
-       (*i
-	 fun gls -> pPNL (pr_autotactic t); Format.print_flush (); 
-                     try tac gls
-		     with e when Logic.catchable_exception(e) -> 
-                            (Format.print_string "Fail\n"; 
-			     Format.print_flush (); 
-			     raise e)
-       i*)
-  in 
-  List.map tac_of_hint hintl
-    
-and e_trivial_resolve db_list local_db gl = 
-  try 
-    priority 
-      (e_my_find_search db_list local_db 
-	 (fst (head_constr_bound gl)) gl)
-  with Bound | Not_found -> []
-
-let e_possible_resolve db_list local_db gl =
-  try List.map snd (e_my_find_search db_list local_db 
-		      (fst (head_constr_bound gl)) gl)
-  with Bound | Not_found -> []
-
-let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
-
-let find_first_goal gls = 
-  try first_goal gls with UserError _ -> assert false
-
-(*s The following module [SearchProblem] is used to instantiate the generic
-    exploration functor [Explore.Make]. *)
-      
-module MySearchProblem = struct
-
-  type state = { 
-    depth : int; (*r depth of search before failing *)
-    tacres : goal list sigma * validation;
-    last_tactic : std_ppcmds;
-    dblist : Auto.hint_db list;
-    localdb :  Auto.hint_db list }
-		 
-  let success s = (sig_it (fst s.tacres)) = []
-
-  let rec filter_tactics (glls,v) = function
-    | [] -> []
-    | (tac,pptac) :: tacl -> 
-	try 
-	  let (lgls,ptl) = apply_tac_list tac glls in 
-	  let v' p = v (ptl p) in
-	  ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl
-	with e when Logic.catchable_exception e ->
-	  filter_tactics (glls,v) tacl
-
-  (* Ordering of states is lexicographic on depth (greatest first) then
-     number of remaining goals. *)
-  let compare s s' =
-    let d = s'.depth - s.depth in
-    let nbgoals s = List.length (sig_it (fst s.tacres)) in
-    if d <> 0 then d else nbgoals s - nbgoals s'
-
-  let branching s = 
-    if s.depth = 0 then 
-      []
-    else      
-      let lg = fst s.tacres in
-      let nbgl = List.length (sig_it lg) in
-      assert (nbgl > 0);
-      let g = find_first_goal lg in
-      let assumption_tacs = 
-	let l = 
-	  filter_tactics s.tacres
-	    (List.map 
-	       (fun id -> (e_give_exact_constr (mkVar id),
-			   (str "Exact" ++ spc()++ pr_id id)))
-	       (pf_ids_of_hyps g))
-	in
-	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
-				    last_tactic = pp; dblist = s.dblist;
-				    localdb = List.tl s.localdb }) l
-      in
-      let intro_tac = 
-	List.map 
-	  (fun ((lgls,_) as res,pp) -> 
-	     let g' = first_goal lgls in 
-	     let hintl = 
-	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	     in
-             let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
-	     { depth = s.depth; tacres = res; 
-	       last_tactic = pp; dblist = s.dblist;
-	       localdb = ldb :: List.tl s.localdb })
-	  (filter_tactics s.tacres [Tactics.intro,(str "Intro" )])
-      in
-      let rec_tacs = 
-	let l = 
-	  filter_tactics s.tacres
-	    (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
-	in
-	List.map 
-	  (fun ((lgls,_) as res, pp) -> 
-	     let nbgl' = List.length (sig_it lgls) in
-	     if nbgl' < nbgl then
-	       { depth = s.depth; tacres = res; last_tactic = pp;
-		 dblist = s.dblist; localdb = List.tl s.localdb }
-	     else 
-	       { depth = pred s.depth; tacres = res; 
-		 dblist = s.dblist; last_tactic = pp;
-		 localdb = 
-		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
-	  l
-      in
-      List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
-
-  let pp s = 
-    msg (hov 0 (str " depth="++ int s.depth ++ spc() ++
-		  s.last_tactic ++ str "\n"))
-
-end
-
-module MySearch = Explore.Make(MySearchProblem)
-
-let make_initial_state n gl dblist localdb =
-  { MySearchProblem.depth = n;
-    MySearchProblem.tacres = tclIDTAC gl;
-    MySearchProblem.last_tactic = (mt ());
-    MySearchProblem.dblist = dblist;
-    MySearchProblem.localdb = [localdb] }
-
-let e_depth_search debug p db_list local_db gl =
-  try
-    let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in
-    let s = tac (make_initial_state p gl db_list local_db) in
-    s.MySearchProblem.tacres
-  with Not_found -> error "EAuto: depth first search failed"
-
-let e_breadth_search debug n db_list local_db gl =
-  try
-    let tac = 
-      if debug then MySearch.debug_breadth_first else MySearch.breadth_first 
-    in
-    let s = tac (make_initial_state n gl db_list local_db) in
-    s.MySearchProblem.tacres
-  with Not_found -> error "EAuto: breadth first search failed"
-
-let e_search_auto debug (n,p) db_list gl = 
-  let local_db = make_local_hint_db true [] gl in 
-  if n = 0 then 
-    e_depth_search debug p db_list local_db gl
-  else 
-    e_breadth_search debug n db_list local_db gl
-
-let eauto debug np dbnames = 
-  let db_list =
-    List.map
-      (fun x -> 
-	 try searchtable_map x
-	 with Not_found -> error ("EAuto: "^x^": No such Hint database"))
-      ("core"::dbnames) 
-  in
-  tclTRY (e_search_auto debug np db_list)
-
-let full_eauto debug n gl = 
-  let dbnames = current_db_names () in
-  let dbnames =  list_subtract dbnames ["v62"] in
-  let db_list = List.map searchtable_map dbnames in
-  let _local_db = make_local_hint_db true [] gl in
-  tclTRY (e_search_auto debug n db_list) gl
-
-let my_full_eauto n gl = full_eauto false (n,0) gl
-
-(**********************************************************************
-   copié de tactics/auto.ml on a juste modifié search_gen
-*)
-
-(* local_db is a Hint database containing the hypotheses of current goal *)
-(* 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 rec trivial_fail_db db_list local_db gl =
-  let intro_tac = 
-    tclTHEN intro 
-      (fun g'->
-	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	 in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
-  in
-  tclFIRST 
-    (assumption::intro_tac::
-     (List.map tclCOMPLETE 
-	(trivial_resolve db_list local_db (pf_concl gl)))) gl
-
-and my_find_search db_list local_db hdc concl =
-  let tacl = 
-    if occur_existential concl then 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
-    else 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
-  in
-  List.map 
-    (fun (st, {pri=b; pat=p; code=t} as _patac) -> 
-       (b,
-	match t with
-	  | Res_pf (term,cl)  -> unify_resolve st (term,cl)
-	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
-	  | Give_exact c  -> exact_check c
-	  | Res_pf_THEN_trivial_fail (term,cl) -> 
-	      tclTHEN 
-		(unify_resolve st (term,cl)) 
-		(trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
-	  | Extern tacast -> conclPattern concl p tacast))
-    tacl
-
-and trivial_resolve db_list local_db cl = 
-  try 
-    let hdconstr = fst (head_constr_bound cl) in
-    priority 
-      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
-  with Bound | Not_found -> 
-    []
-
-(**************************************************************************)
-(*                       The classical Auto tactic                        *)
-(**************************************************************************)
-
-let possible_resolve db_list local_db cl =
-  try 
-    let hdconstr = fst (head_constr_bound cl) in
-    List.map snd 
-      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
-  with Bound | Not_found -> 
-    []
-
-let decomp_unary_term c gls = 
-  let typc = pf_type_of gls c in 
-  let t = head_constr typc in 
-  if Hipattern.is_conjunction (applist t) then 
-    simplest_case c gls 
-  else 
-    errorlabstrm "Auto.decomp_unary_term" (str "not a unary type")
-
-let decomp_empty_term c gls = 
-  let typc = pf_type_of gls c in 
-  let (hd,_) = decompose_app typc in 
-  if Hipattern.is_empty_type hd then 
-    simplest_case c gls 
-  else 
-    errorlabstrm "Auto.decomp_empty_term" (str "not an empty type")
-
-
-(* decomp is an natural number giving an indication on decomposition 
-   of conjunction in hypotheses, 0 corresponds to no decomposition *)
-(* n is the max depth of search *)
-(* local_db contains the local Hypotheses *)
-
-let rec search_gen decomp n db_list local_db extra_sign goal =
-  if n=0 then error "BOUND 2";
-  let decomp_tacs = match decomp with 
-    | 0 -> [] 
-    | p -> 
-	(tclTRY_sign decomp_empty_term extra_sign)
-	::
-	(List.map 
-	   (fun id -> tclTHEN (decomp_unary_term (mkVar id)) 
-		(tclTHEN 
-		   (clear [id])
-		   (free_try (search_gen decomp p db_list local_db []))))
-	   (pf_ids_of_hyps goal)) 
-  in
-  let intro_tac = 
-    tclTHEN intro 
-      (fun g' -> 
-	 let (hid,_,htyp as d) = pf_last_hyp g' in
-	 let hintl = 
-	   try 
-	     [make_apply_entry (pf_env g') (project g')
-		(true,true,false) 
-		None
-		(mkVar hid,htyp)]
-	   with Failure _ -> [] 
-	 in
-         (free_try
-	  (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d])
-	  g'))
-  in
-  let rec_tacs = 
-    List.map 
-      (fun ntac -> 
-	 tclTHEN ntac
-	   (free_try
-	    (search_gen decomp (n-1) db_list local_db empty_named_context)))
-      (possible_resolve db_list local_db (pf_concl goal))
-  in 
-  tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
-
-
-let search = search_gen 0
-
-let default_search_depth = ref 5
-			     
-let full_auto n gl = 
-  let dbnames = current_db_names () in
-  let dbnames = list_subtract dbnames ["v62"] in
-  let db_list = List.map searchtable_map dbnames in
-  let hyps = pf_hyps gl in
-  tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl
-  
-let default_full_auto gl = full_auto !default_search_depth gl
-(************************************************************************)
-
-let blast_tactic = ref (free_try default_full_auto)
-;;
-
-let blast_auto = (free_try default_full_auto)
-(*                  (tclTHEN (free_try default_full_auto)
-			  (free_try (my_full_eauto 2)))
-*)
-;;
-let blast_simpl = (free_try (reduce (Simpl None) onConcl))
-;;
-let blast_induction1 = 
-    (free_try (tclTHEN (tclTRY intro)
-		       (tclTRY (tclLAST_HYP simplest_elim))))
-;;
-let blast_induction2 = 
-    (free_try (tclTHEN (tclTRY (tclTHEN intro intro))
-		       (tclTRY (tclLAST_HYP simplest_elim))))
-;;
-let blast_induction3 = 
-    (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro)))
-		       (tclTRY (tclLAST_HYP simplest_elim))))
-;;
-
-blast_tactic :=
-  (tclORELSE (tclCOMPLETE blast_auto)
-  (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto))
-  (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1
-                          (tclTHEN blast_simpl blast_auto)))
-  (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2
-                          (tclTHEN blast_simpl blast_auto)))
-             (tclCOMPLETE (tclTHEN blast_induction3
-                          (tclTHEN blast_simpl blast_auto)))))))
-;;
-(*
-blast_tactic := (tclTHEN (free_try default_full_auto)
-			 (free_try (my_full_eauto 4)))
-;;
-*)
-
-let vire_extvar s =
-   let interro = ref false in
-   let interro_pos = ref 0 in
-   for i=0 to (length s)-1 do
-     if get s i = '?'
-     then (interro := true;
-           interro_pos := i)
-     else if (!interro && 
-              (List.mem (get s i)
-			['0';'1';'2';'3';'4';'5';'6';'7';'8';'9']))
-     then set s i ' '
-     else interro:=false
-   done;
-   s
-;;
-
-let blast gls =
-   let leaf g = {
-      open_subgoals = 1;
-      goal = g;
-      ref = None } in
-     try (let (sgl,v) as _res = !blast_tactic gls in
-	  let {it=lg} = sgl in
-          if lg = [] 
-          then (let pf = v (List.map leaf (sig_it sgl)) in
-                let sign = (sig_it gls).evar_hyps in
-                let x = print_subscript 
-                     (sig_sig gls) sign pf in
-		msgnl (hov 0 (str"Blast ==> " ++ x));
-                let x = print_subscript 
-                     (sig_sig gls) sign pf in
-                let tac_string =
-                pp_string  (hov 0 x ) in
-    (* on remplace les ?1 ?2 ... de refine par ? *)
-		parse_tac ((vire_extvar tac_string)
-			   ^ ".")
-	  )
-	  else (msgnl (hov 0 (str"Blast failed to prove the goal..."));
-		failwith "echec de blast"))
-     with _ -> failwith "echec de blast"
-;;
-
-let blast_tac display_function = function 
-          | (n::_) as _l -> 
-                 (function g ->
-                    let exp_ast = (blast g) in
-                     (display_function exp_ast;
-                       tclIDTAC g))
-          |  _ -> failwith "expecting other arguments";;
-
-let blast_tac_txt = 
-  blast_tac
-    (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));;
-
-(* Obsolète ?
-overwriting_add_tactic "Blast1" blast_tac_txt;;
-*)
-
-(*
-Grammar tactic ne_numarg_list : list :=
-  ne_numarg_single [numarg($n)] ->[$n]
-| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ].
-Grammar tactic simple_tactic : ast :=
-  blast1 [ "Blast1" ne_numarg_list($ns) ] ->
-         [ (Blast1 ($LIST $ns)) ].
-
-
-
-PATH=/usr/local/bin:/usr/bin:$PATH
-COQTOP=d:/Tools/coq-7.0-3mai
-CAMLLIB=/usr/local/lib/ocaml
-CAMLP4LIB=/usr/local/lib/camlp4
-export CAMLLIB
-export COQTOP
-export CAMLP4LIB 
-d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe 
-Drop.
-#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";;
-*)
diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli
deleted file mode 100644
index f6701943..00000000
--- a/contrib/interface/blast.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) ->
-    int list -> Proof_type.tactic
-
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
deleted file mode 100644
index 51dce4f7..00000000
--- a/contrib/interface/centaur.ml4
+++ /dev/null
@@ -1,885 +0,0 @@
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(*
- * This file has been modified by Lionel Elie Mamane <lionel@mamane.lu>
- * to implement the following features
- * - Terms (optionally) as pretty-printed string and not trees
- * - (Optionally) give most commands their usual Coq semantics
- * - Add the backtracking information to the status message.
- * in the following time period
- * - May-November 2006
- * and
- * - Make use of new Command.save_hook to generate dependencies at
- *   save-time.
- * in
- *  - June 2007
- *)
-
-(*Toplevel loop for the communication between Coq and Centaur *)
-open Names;;
-open Nameops;;
-open Util;;
-open Term;;
-open Pp;;
-open Ppconstr;;
-open Prettyp;;
-open Libnames;;
-open Libobject;;
-open Library;;
-open Vernacinterp;;
-open Evd;;
-open Proof_trees;;
-open Tacmach;;
-open Pfedit;;
-open Proof_type;;
-open Parsing;;
-open Environ;;
-open Declare;;
-open Declarations;;
-open Rawterm;;
-open Reduction;;
-open Classops;;
-open Vernacinterp;;
-open Vernac;;
-open Command;;
-open Protectedtoplevel;;
-open Line_oriented_parser;;
-open Xlate;;
-open Vtp;;
-open Ascent;;
-open Translate;;
-open Name_to_ast;;
-open Pbp;;
-open Blast;;
-(* open Dad;; *)
-open Debug_tac;;
-open Search;;
-open Constrintern;;
-open Nametab;;
-open Showproof;;
-open Showproof_ct;;
-open Tacexpr;;
-open Vernacexpr;;
-open Printer;;
-
-let pcoq_started = ref None;;
-
-let if_pcoq f a =
-  if !pcoq_started <> None then f a else error "Pcoq is not started";;
-
-let text_proof_flag = ref "en";;
-
-let pcoq_history = ref true;;
-
-let assert_pcoq_history f a =
-  if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";;
-
-let current_proof_name () = 
-  try 
-    string_of_id (get_current_proof_name ())
-  with
-      UserError("Pfedit.get_proof", _) -> "";;
-
-let current_goal_index = ref 0;;
-
-let guarded_force_eval_stream (s : std_ppcmds) = 
-  let l = ref [] in
-  let f elt = l:= elt :: !l in 
-  (try  Stream.iter f s with
-  | _ -> f (Stream.next (str "error guarded_force_eval_stream")));
-  Stream.of_list (List.rev !l);;
-
-
-let rec string_of_path p =
-    match p with [] -> "\n"
-              | i::p -> (string_of_int i)^" "^ (string_of_path p)
-;;
-let print_path p =
-    output_results_nl (str "Path:" ++ str  (string_of_path p))
-;;
-
-let kill_proof_node index =
- let paths = History.historical_undo (current_proof_name()) index in
- let _ =  List.iter
-            (fun path -> (traverse_to path;
-                          Pfedit.mutate weak_undo_pftreestate;
-			  traverse_to []))
-          paths in
- History.border_length (current_proof_name());;
-
-
-type vtp_tree =
-  | P_rl of ct_RULE_LIST
-  | P_r of ct_RULE
-  | P_s_int of ct_SIGNED_INT_LIST
-  | P_pl of ct_PREMISES_LIST
-  | P_cl of ct_COMMAND_LIST
-  | P_t of ct_TACTIC_COM
-  | P_text of ct_TEXT
-  | P_ids of ct_ID_LIST;;
-
-let print_tree t = 
-  (match t with
-  | P_rl x -> fRULE_LIST x
-  | P_r x -> fRULE x
-  | P_s_int x -> fSIGNED_INT_LIST x
-  | P_pl x -> fPREMISES_LIST x
-  | P_cl x -> fCOMMAND_LIST x
-  | P_t x -> fTACTIC_COM x
-  | P_text x -> fTEXT x
-  | P_ids x -> fID_LIST x)
-  ++ (str "e\nblabla\n");;
-
-
-(*Message functions, the text of these messages is recognized by the protocols *)
-(*of CtCoq                                                                     *)
-let ctf_header message_name request_id =
- str "message" ++ fnl() ++ str message_name ++ fnl() ++
- int request_id ++ fnl();;
-
-let ctf_acknowledge_command request_id command_count opt_exn =
-  let goal_count, goal_index = 
-    if refining() then
-      let g_count =
-        List.length 
-          (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in
-        g_count, !current_goal_index
-    else
-      (0, 0)
-  and statnum = Lib.current_command_label ()
-  and dpth = let d = Pfedit.current_proof_depth() in if d >= 0 then d else 0
-  and pending = CT_id_list (List.map xlate_ident (Pfedit.get_all_proof_names())) in
-   (ctf_header "acknowledge" request_id ++
-    int command_count ++ fnl() ++
-    int goal_count ++ fnl () ++
-    int goal_index ++ fnl () ++
-    str (current_proof_name()) ++ fnl() ++
-    int statnum ++ fnl() ++
-    print_tree (P_ids pending) ++
-    int dpth ++ fnl() ++
-    (match opt_exn with
-      Some e -> Cerrors.explain_exn e
-    | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());;
-
-let ctf_undoResults = ctf_header "undo_results";;
-
-let ctf_TextMessage = ctf_header "text_proof";;
-
-let ctf_SearchResults = ctf_header "search_results";;
-
-let ctf_OtherGoal = ctf_header "other_goal";;
-
-let ctf_Location = ctf_header "location";;
-
-let ctf_StateMessage = ctf_header "state";;
-
-let ctf_PathGoalMessage () =
- fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();;
-
-let ctf_GoalReqIdMessage = ctf_header "single_goal_state";;
-
-let ctf_GoalsReqIdMessage = ctf_header "goals_state";;
-
-let ctf_NewStateMessage = ctf_header "fresh_state";;
-
-let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++
-			  str "saved" ++ fnl();;
-
-let ctf_KilledMessage req_id ngoals =
- ctf_header "killed" req_id ++ int ngoals ++ fnl ();;
-
-let ctf_AbortedAllMessage () =
-  fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();;
-
-let ctf_AbortedMessage request_id na =
-  ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ 
-  str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();;
-
-let ctf_UserErrorMessage request_id stream =
- let stream = guarded_force_eval_stream stream in
- ctf_header "user_error" request_id ++ stream ++ fnl() ++
- str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
-
-let ctf_ResetInitialMessage () =
- fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();;
-
-let ctf_ResetIdentMessage request_id s =
- ctf_header "reset_ident" request_id ++ str s ++ fnl () ++
-  str  "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
-
-
-let break_happened = ref false;;
-
-let output_results stream vtp_tree =
-    let _ = Sys.signal Sys.sigint
-       (Sys.Signal_handle(fun i -> (break_happened := true;()))) in
-    msg (stream ++
-    (match vtp_tree with
-       Some t -> print_tree t
-     | None -> mt()));;
-
-let output_results_nl stream =
-    let _ = Sys.signal Sys.sigint
-       (Sys.Signal_handle(fun i -> break_happened := true;()))
-    in
-    msgnl stream;;
-
-
-let rearm_break () =
-    let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break))
-    in ();;
-
-let check_break () =
-   if (!break_happened) then
-    begin
-      break_happened := false;
-      raise Sys.Break
-    end
-   else ();;
-
-let print_past_goal index =
- let path = History.get_path_for_rank (current_proof_name()) index in
- try traverse_to path;
-     let pf = proof_of_pftreestate (get_pftreestate ()) in
-     output_results  (ctf_PathGoalMessage ())
-       (Some (P_r (translate_goal pf.goal)))
- with
-   | Invalid_argument s ->
-      ((try traverse_to [] with _ -> ());
-       error "No focused proof (No proof-editing in progress)")
-   | e -> (try traverse_to [] with _ -> ()); raise e
-;;
-
-let show_nth n =
-  try
-    output_results (ctf_GoalReqIdMessage !global_request_id
-		    ++ pr_nth_open_subgoal n)
-      None
-  with
-  | Invalid_argument s -> 
-       error "No focused proof (No proof-editing in progress)";;
-
-let show_subgoals () =
-  try
-    output_results (ctf_GoalReqIdMessage !global_request_id
-		    ++ pr_open_subgoals ())
-      None
-  with
-  | Invalid_argument s -> 
-       error "No focused proof (No proof-editing in progress)";;
-
-(* The rest of the file contains commands that are changed from the plain
-   Coq distribution *)
-
-let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);;
-
-(*
-let filter_by_module_from_varg_list l =
-  let dir_list, b = Vernacentries.interp_search_restriction l in
-    Search.filter_by_module_from_list (dir_list, b);;
-*)
-
-let add_search (global_reference:global_reference) assumptions cstr =
-  try 
-  let id_string =
-    string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty
-			global_reference) in
-  let ast = 
-    try
-      CT_premise (CT_ident id_string, translate_constr false assumptions cstr)
-    with Not_found ->
-      CT_premise (CT_ident id_string,
-                  CT_coerce_ID_to_FORMULA(
-                    CT_ident ("Error printing" ^ id_string))) in
-    ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST
-  with e -> msgnl (str "add_search raised an exception"); raise e;;
-
-(*
-let make_error_stream node_string =
-  str "The syntax of " ++ str node_string ++
-  str " is inconsistent with the vernac interpreter entry";;
-*)
-
-let ctf_EmptyGoalMessage id =
-  fnl () ++ str "Empty Goal is a no-op.  Fun oh fun." ++ fnl ();;
-
-
-let print_check env judg =
- ((ctf_SearchResults !global_request_id) ++
-    print_judgment env judg,
-  None);;
-
-let ct_print_eval red_fun env evmap ast judg =
-  (if refining() then traverse_to []);
-  let {uj_val=value; uj_type=typ} = judg in
-  let nvalue = (red_fun env evmap) value
-    (* // Attention , ici il faut peut être utiliser des environnemenst locaux *)
-  and ntyp = nf_betaiota typ in
-    print_tree
-      (P_pl
-	 (CT_premises_list
-	    [CT_eval_result
-	       (xlate_formula ast,
-		translate_constr false env nvalue,
-		translate_constr false env ntyp)]));;
-
-let pbp_tac_pcoq =
-    pbp_tac (function (x:raw_tactic_expr) -> 
-      output_results
-        (ctf_header "pbp_results" !global_request_id)
-       (Some (P_t(xlate_tactic x))));;
-
-let blast_tac_pcoq =
-    blast_tac (function (x:raw_tactic_expr) -> 
-      output_results
-	(ctf_header "pbp_results" !global_request_id)
-       (Some (P_t(xlate_tactic x))));;
-
-(* <\cpa> 
-let dad_tac_pcoq =
-  dad_tac(function x -> 
-    output_results
-    (ctf_header "pbp_results" !global_request_id)
-    (Some (P_t(xlate_tactic x))));;
-</cpa> *)
-
-let search_output_results () =
-  (* LEM: See comments for pcoq_search *)
-  output_results
-       (ctf_SearchResults !global_request_id)
-       (Some (P_pl (CT_premises_list
-                      (List.rev !ctv_SEARCH_LIST))));;
-
-
-let debug_tac2_pcoq tac =
-      (fun g ->
-	let the_goal = ref (None : goal sigma option) in
-	let the_ast = ref tac in
-	let the_path = ref ([] : int list) in
-	try
-	  let _result = report_error tac the_goal the_ast the_path [] g in
-	  (errorlabstrm "DEBUG TACTIC"
-	     (str "no error here " ++ fnl () ++ Printer.pr_goal (sig_it g) ++
-	      fnl () ++ str "the tactic is" ++ fnl () ++
-	      Pptactic.pr_glob_tactic (Global.env()) tac) (*
-Caution, this is in the middle of what looks like dead code. ;
-	   result *))
-	with
-	  e ->
-	    match !the_goal with
-	      None -> raise e
-	    | Some g -> 
-                (output_results
-		   (ctf_Location !global_request_id)
-		   (Some (P_s_int
-			    (CT_signed_int_list
-                               (List.map
-                                  (fun n -> CT_coerce_INT_to_SIGNED_INT
-                                                 (CT_int n))
-                                  (clean_path tac 
-					       (List.rev !the_path)))))));
-	    	(output_results
-		   (ctf_OtherGoal !global_request_id)
-		   (Some (P_r (translate_goal (sig_it g)))));
-	    raise e);;
-
-let rec selectinspect n env =
-    match env with
-      [] -> []
-    | a::tl ->
-      if n = 0 then
-         []
-      else
-         match a with
-           (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl)
-         | _ -> (selectinspect n tl);;
-
-open Term;;
-
-let inspect n =
-  let env = Global.env() in
-  let add_search2 x y = add_search x env y in
-  let l = selectinspect n (Lib.contents_after None) in
-    ctv_SEARCH_LIST := [];
-    List.iter
-      (fun a ->
-	 try
-           (match a with
-             	oname, Lib.Leaf lobj ->
-		  (match oname, object_tag lobj with
-                       (sp,_), "VARIABLE" ->
-			 let (_, _, v) = Global.lookup_named (basename sp) in
-			   add_search2 (Nametab.locate (qualid_of_sp sp)) v
-		     | (sp,kn), "CONSTANT" ->
-			 let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in
-			   add_search2 (Nametab.locate (qualid_of_sp sp)) typ
-		     | (sp,kn), "MUTUALINDUCTIVE" ->
-			 add_search2 (Nametab.locate (qualid_of_sp sp))
-			   (Pretyping.Default.understand Evd.empty (Global.env())
-			      (RRef(dummy_loc, IndRef(kn,0))))
-		     | _ -> failwith ("unexpected value 1 for "^ 
-				      (string_of_id (basename (fst oname)))))
-              | _ -> failwith "unexpected value")
-	 with e -> ())
-      l;
-    output_results
-      (ctf_SearchResults !global_request_id)
-      (Some
-         (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
-
-let ct_int_to_TARG n = 
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)));;
-
-let pair_list_to_ct l =
-    CT_user_tac(CT_ident "pair_int_list",
-		CT_targ_list
-		  (List.map (fun (a,b) ->
-			       CT_coerce_TACTIC_COM_to_TARG
-				 (CT_user_tac
-				    (CT_ident "pair_int",
-				     CT_targ_list
-				       [ct_int_to_TARG a; ct_int_to_TARG b])))
-		     l));;
-
-(* Annule toutes les commandes qui s'appliquent sur les sous-buts du
-   but auquel a été appliquée la n-ième tactique *)
-let logical_kill n =
-  let path = History.get_path_for_rank (current_proof_name()) n in
-  begin
-    traverse_to path;
-    Pfedit.mutate weak_undo_pftreestate;
-    (let kept_cmds, undone_cmds, remaining_goals, current_goal =
-      History.logical_undo (current_proof_name()) n in
-       output_results (ctf_undoResults !global_request_id)
-	 (Some
-	    (P_t
-	       (CT_user_tac
-		  (CT_ident "log_undo_result",
-		   CT_targ_list
-		     [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds);
-		      CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds);
-		      ct_int_to_TARG remaining_goals;
-		      ct_int_to_TARG current_goal])))));
-    traverse_to []
-  end;;
-
-let simulate_solve n tac =
-  let path = History.get_nth_open_path (current_proof_name()) n in
-  solve_nth n (Tacinterp.hide_interp tac (get_end_tac()));
-  traverse_to path;
-  Pfedit.mutate weak_undo_pftreestate;
-  traverse_to []
-
-let kill_node_verbose n =
-  let ngoals = kill_proof_node n in
-  output_results_nl (ctf_KilledMessage !global_request_id ngoals)
-
-let set_text_mode s = text_proof_flag := s
-
-let pcoq_reset_initial() =
-  output_results(ctf_AbortedAllMessage()) None;
-  Vernacentries.abort_refine Lib.reset_initial ();
-  output_results(ctf_ResetInitialMessage()) None;;
-
-let pcoq_reset x =
-  if refining() then
-    output_results (ctf_AbortedAllMessage ()) None;
-    Vernacentries.abort_refine Lib.reset_name (dummy_loc,x);
-    output_results
-      (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;;
-
-
-VERNAC ARGUMENT EXTEND text_mode
-| [ "fr" ] -> [ "fr" ]
-| [ "en" ] -> [ "en" ]
-| [ "Off" ] -> [ "off" ]
-END
-
-VERNAC COMMAND EXTEND TextMode
-| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ]
-END
-
-VERNAC COMMAND EXTEND OutputGoal
-  [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ]
-END
-
-VERNAC COMMAND EXTEND OutputGoal
-  [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ]
-END
-
-VERNAC COMMAND EXTEND KillProofAfter
-| [ "Kill" "Proof" "after"  natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
-END
-
-VERNAC COMMAND EXTEND KillProofAt
-| [ "Kill" "Proof" "at"  natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
-END
-
-VERNAC COMMAND EXTEND KillSubProof
-  [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ]
-END
-
-VERNAC COMMAND EXTEND PcoqReset
-  [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ]
-END
-
-VERNAC COMMAND EXTEND PcoqResetInitial
-  [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ]
-END
-
-let start_proof_hook () =
-  if !pcoq_history then History.start_proof (current_proof_name());
-  current_goal_index := 1
-
-let solve_hook n =
-  current_goal_index := n;
-  if !pcoq_history then
-    let name = current_proof_name () in
-    let old_n_count = History.border_length name in
-    let pf = proof_of_pftreestate (get_pftreestate ()) in
-    let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in
-      History.push_command name n n_goals
-
-let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s)
-
-let interp_search_about_item = function
-  | SearchSubPattern pat ->
-      let _,pat = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in
-      GlobSearchSubPattern pat
-  | SearchString (s,_) ->
-      warning "Notation case not taken into account";
-      GlobSearchString s
-
-let pcoq_search s l =
-  (* LEM: I don't understand why this is done in this way (redoing the
-   *      match on s here) instead of making the code in
-   *      parsing/search.ml call the right function instead of
-   *      "plain_display". Investigates this later.
-   * TODO
-   *)
-  ctv_SEARCH_LIST:=[];
-  begin match s with
-  | SearchAbout sl -> 
-      raw_search_about (filter_by_module_from_list l) add_search
-	(List.map (on_snd interp_search_about_item) sl)
-  | SearchPattern c ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in
-      raw_pattern_search (filter_by_module_from_list l) add_search pat
-  | SearchRewrite c ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in
-      raw_search_rewrite (filter_by_module_from_list l) add_search pat;
-  | SearchHead locqid ->
-      filtered_search
-	(filter_by_module_from_list l) add_search (Nametab.global locqid)
-  end;
-  search_output_results()
-
-(* Check sequentially whether the pattern is one of the premises *)
-let rec hyp_pattern_filter pat name a c =
-  let _c1 = strip_outer_cast c in
-    match kind_of_term c with
-      | Prod(_, hyp, c2) -> 
-	  (try
-(*	     let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in
-             let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *)
-             if Matching.is_matching pat hyp then
-	       (msgnl (str "ok"); true)
-	     else
-	       false
-           with UserError _ -> false) or
-	  hyp_pattern_filter pat name a c2
-      | _ -> false;;
-
-let hyp_search_pattern c l =
-  let _, pat = intern_constr_pattern Evd.empty (Global.env()) c in
-    ctv_SEARCH_LIST := [];
-    gen_filtered_search
-      (fun s a c -> (filter_by_module_from_list l s a c &&
-		     (if hyp_pattern_filter pat s a c then
-		   	(msgnl (str "ok2"); true) else false)))
-      (fun s a c -> (msgnl (str "ok3"); add_search s a c));
-    output_results
-      (ctf_SearchResults !global_request_id)
-      (Some
-	 (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
-let pcoq_print_name ref =
-  output_results 
-    (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref )
-    None
-
-let pcoq_print_check env j =
-  let a,b = print_check env j in output_results a b
-
-let pcoq_print_eval redfun env evmap c j =
-  output_results
-    (ctf_SearchResults !global_request_id
-     ++ Prettyp.print_eval redfun env evmap c j)
-    None;;
-
-open Vernacentries
-
-let pcoq_show_goal = function
-  | Some n -> show_nth n
-  | None -> show_subgoals ()
-;;
-
-let pcoq_hook = {
-  start_proof = start_proof_hook;
-  solve = solve_hook;
-  abort = abort_hook;
-  search = pcoq_search;
-  print_name = pcoq_print_name;
-  print_check = pcoq_print_check;
-  print_eval = pcoq_print_eval;
-  show_goal = pcoq_show_goal
-}
-
-let pcoq_term_pr = {
-  pr_constr_expr   = (fun c -> str "pcoq_constr_expr\n"  ++ (default_term_pr.pr_constr_expr   c));
-  (* In future translate_constr false (Global.env())
-   * Except with right bool/env which I'll get :)
-   *)
-  pr_lconstr_expr  = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr  c) ++ str ")");
-  pr_constr_pattern_expr  = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_constr_pattern_expr  c));
-  pr_lconstr_pattern_expr = (fun c -> str "pcoq_constr_expr\n"  ++ (default_term_pr.pr_lconstr_pattern_expr c))
-}
-
-let start_pcoq_trees () =
-  set_term_pr pcoq_term_pr
-
-(* BEGIN functions for object_pr *)
-
-(* These functions in general mirror what name_to_ast does in a subcase,
-   and then print the corresponding object as a PCoq tree. *)
-
-let object_to_ast_template object_to_ast_list sp =
-  let l = object_to_ast_list sp in
-    VernacList (List.map (fun x -> (dummy_loc, x)) l)
-
-let pcoq_print_object_template object_to_ast_list sp =
-  let results = xlate_vernac_list (object_to_ast_template object_to_ast_list sp) in
-    print_tree (P_cl results)
-
-(* This function mirror what print_check does *)
-
-let pcoq_print_typed_value_in_env env (value, typ) =
- let value_ct_ast = 
-     (try translate_constr false (Global.env()) value 
-      with UserError(f,str) ->
-           raise(UserError(f,Printer.pr_lconstr value ++
-			      fnl () ++ str ))) in
- let type_ct_ast =
-     (try translate_constr false (Global.env()) typ
-      with UserError(f,str) ->
-           raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in
-   print_tree
-     (P_pl
-	(CT_premises_list
-	   [CT_coerce_TYPED_FORMULA_to_PREMISE
-	      (CT_typed_formula(value_ct_ast,type_ct_ast)
-	      )]))
-;;
-
-(* This function mirrors what show_nth does *)
-
-let pcoq_pr_subgoal n gl =
-  try
-    print_tree
-      (if (!text_proof_flag<>"off") then
-	   (* This is a horrendeous hack; it ignores the "gl" argument
-              and just takes the currently focused proof. This will bite
-	      us back one day.
-	      TODO: Fix this.
-	   *)
-	   (
-	    if not !pcoq_history then error "Text mode requires Pcoq history tracking.";
-	    if n=0
-	    then (P_text (show_proof !text_proof_flag []))
-	    else
-		let path = History.get_nth_open_path (current_proof_name()) n in
-		  (P_text (show_proof !text_proof_flag path)))
-       else
-	   (let goal = List.nth gl (n - 1) in
-	      (P_r (translate_goal goal))))
-  with
-  | Invalid_argument _
-  | Failure "nth"
-  | Not_found           -> error "No such goal";;
-
-let pcoq_pr_subgoals close_cmd evar gl =
-  (*LEM: TODO: we should check for evar emptiness or not, and do something *)
-  try
-    print_tree
-      (if (!text_proof_flag<>"off") then
-	   raise (Anomaly ("centaur.ml4:pcoq_pr_subgoals", str "Text mode show all subgoals not implemented"))
-       else
-	   (P_rl (translate_goals gl)))
-  with
-  | Invalid_argument _
-  | Failure "nth"
-  | Not_found           -> error "No such goal";;
-
-
-(*  END functions for object_pr  *)
-
-let pcoq_object_pr = {
-  print_inductive           = pcoq_print_object_template inductive_to_ast_list;
-  (* TODO: Check what that with_infos means, and adapt accordingly *)
-  print_constant_with_infos = pcoq_print_object_template constant_to_ast_list;
-  print_section_variable    = pcoq_print_object_template variable_to_ast_list;
-  print_syntactic_def       = pcoq_print_object_template (fun x -> errorlabstrm "print"
-      (str "printing of syntax definitions not implemented in PCoq syntax"));
-  (* TODO: These are placeholders only; write them *)
-  print_module              = (fun x y -> str "pcoq_print_module not implemented");
-  print_modtype             = (fun x   -> str "pcoq_print_modtype not implemented");
-  print_named_decl          = (fun x   -> str "pcoq_print_named_decl not implemented");
-  (* TODO: Find out what the first argument x (a bool) is about and react accordingly *)
-  print_leaf_entry          = (fun x -> pcoq_print_object_template leaf_entry_to_ast_list);
-  print_library_entry       = (fun x y -> Some (str "pcoq_print_library_entry not implemented"));
-  print_context             = (fun x y z -> str "pcoq_print_context not implemented");
-  print_typed_value_in_env  = pcoq_print_typed_value_in_env;
-  Prettyp.print_eval        = ct_print_eval;
-};;
-
-let pcoq_printer_pr = {
- pr_subgoals = pcoq_pr_subgoals;
- pr_subgoal  = pcoq_pr_subgoal;
- pr_goal     = (fun x   -> str "pcoq_pr_goal not implemented");
-};;
-
-
-let start_pcoq_objects () =
-  set_object_pr pcoq_object_pr;
-  set_printer_pr pcoq_printer_pr
-
-let start_default_objects () =
-  set_object_pr default_object_pr;
-  set_printer_pr default_printer_pr
-
-let full_name_of_ref r =
-  (match r with
-     | VarRef _ -> str "VAR"
-     | ConstRef _ -> str "CST"
-     | IndRef _ -> str "IND"
-     | ConstructRef _ -> str "CSR")
-  ++ str " " ++ (pr_sp (Nametab.sp_of_global r))
-    (* LEM TODO: Cleanly separate path from id (see Libnames.string_of_path) *)
-
-let string_of_ref =
-  (*LEM TODO: Will I need the Var/Const/Ind/Construct info?*)
-  Depends.o Libnames.string_of_path Nametab.sp_of_global
-
-let print_depends compute_depends ptree =
-  output_results (List.fold_left (fun x y -> x ++ (full_name_of_ref y) ++ fnl())
-		    (str "This object depends on:" ++ fnl())
-		    (compute_depends ptree))
-                 None
-
-let output_depends compute_depends ptree =
-  (* Using an ident list for that is arguably stretching it, but less effort than touching the vtp types *)
-  output_results (ctf_header "depends" !global_request_id ++
-		    print_tree (P_ids (CT_id_list (List.map
-						     (fun x -> CT_ident (string_of_ref x))
-						     (compute_depends ptree)))))
-                 None
-
-let gen_start_depends_dumps print_depends print_depends' print_depends'' print_depends''' =
-  Command.set_declare_definition_hook (print_depends' (Depends.depends_of_definition_entry ~acc:[]));
-  Command.set_declare_assumption_hook (print_depends  (fun (c:types) -> Depends.depends_of_constr c []));
-  Command.set_start_hook (print_depends    (fun c -> Depends.depends_of_constr c []));
-  Command.set_save_hook  (print_depends''  (Depends.depends_of_pftreestate Depends.depends_of_pftree));
-  Refiner.set_solve_hook (print_depends''' (fun pt -> Depends.depends_of_pftree_head pt []))
-
-let start_depends_dumps () = gen_start_depends_dumps output_depends output_depends output_depends output_depends
-
-let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends
-
-TACTIC EXTEND pbp
-| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> 
-    [ if_pcoq pbp_tac_pcoq idopt nl ]
-END
-
-TACTIC EXTEND ct_debugtac
-| [ "debugtac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
-END
-
-TACTIC EXTEND ct_debugtac2
-| [ "debugtac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
-END
-
-
-let start_pcoq_mode debug = 
-  begin
-    pcoq_started := Some debug;
-(* <\cpa> 
-    start_dad();
-</cpa> *)
-(* The following ones are added to enable rich comments in pcoq *)
-(* TODO ...
-    add_tactic "Image" (fun _ -> tclIDTAC);
-*)
-(* "Comments" moved to Vernacentries, other obsolete ?
-    List.iter (fun (a,b) -> vinterp_add a b) command_creations;
-*)
-(* Now hooks in Vernacentries
-    List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes;
-    if not debug then
-      List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes;
-*)
-    set_pcoq_hook pcoq_hook;
-    start_pcoq_objects();
-    Flags.print_emacs := false; Pp.make_pp_nonemacs(); 
-  end;;
-
-
-let start_pcoq () =
-  start_pcoq_mode false;
-  set_acknowledge_command ctf_acknowledge_command;
-  set_start_marker "CENTAUR_RESERVED_TOKEN_start_command";
-  set_end_marker "CENTAUR_RESERVED_TOKEN_end_command";
-  raise Vernacexpr.ProtectedLoop;;
-
-let start_pcoq_debug () =
-  start_pcoq_mode true;
-  set_acknowledge_command ctf_acknowledge_command;
-  set_start_marker "--->";
-  set_end_marker "<---";
-  raise Vernacexpr.ProtectedLoop;;
-
-VERNAC COMMAND EXTEND HypSearchPattern
-  [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ]
-END
-
-VERNAC COMMAND EXTEND StartPcoq
-  [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ]
-END
-
-VERNAC COMMAND EXTEND Pcoq_inspect
-  [ "Pcoq_inspect" ] -> [ inspect 15 ]
-END
-
-VERNAC COMMAND EXTEND StartPcoqDebug
-| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ]
-END
-
-VERNAC COMMAND EXTEND StartPcoqTerms
-| [ "Start" "Pcoq" "Trees" ] -> [ start_pcoq_trees () ]
-END
-
-VERNAC COMMAND EXTEND StartPcoqObjects
-| [ "Start" "Pcoq" "Objects" ] -> [ start_pcoq_objects () ]
-END
-
-VERNAC COMMAND EXTEND StartDefaultObjects
-| [ "Start" "Default" "Objects" ] -> [ start_default_objects () ]
-END
-
-VERNAC COMMAND EXTEND StartDependencyDumps
-| [ "Start" "Dependency" "Dumps" ] -> [ start_depends_dumps () ]
-END
-
-VERNAC COMMAND EXTEND StopPcoqHistory
-| [ "Stop" "Pcoq" "History" ] -> [ pcoq_history := false ]
-END
diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml
deleted file mode 100644
index c2ab2dc8..00000000
--- a/contrib/interface/dad.ml
+++ /dev/null
@@ -1,382 +0,0 @@
-(* This file contains an ml version of drag-and-drop. *)
-
-(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *)
-
-open Names;;
-open Term;;
-open Rawterm;;
-open Util;;
-open Environ;;
-open Tactics;;
-open Tacticals;;
-open Pattern;;
-open Matching;;
-open Reduction;;
-open Constrextern;;
-open Constrintern;;
-open Vernacinterp;;
-open Libnames;;
-open Nametab
-
-open Proof_type;;
-open Proof_trees;;
-open Tacmach;;
-open Typing;;
-open Pp;;
-
-open Paths;;
-
-open Topconstr;;
-open Genarg;;
-open Tacexpr;;
-open Rawterm;;
-
-(* In a first approximation, drag-and-drop rules are like in CtCoq
-   1/ a pattern,
-   2,3/ Two paths: start and end positions,
-   4/ the degree: the number of steps the algorithm should go up from the
-      longest common prefix,
-   5/ the tail path: the suffix of the longest common prefix of length the
-      degree,
-   6/ the command pattern, where meta variables are represented by objects
-      of the form Node(_,"META"; [Num(_,i)])
-*)
-
-
-type dad_rule =
-    constr_expr * int list * int list * int * int list
-    * raw_atomic_tactic_expr;;
-
-(* This value will be used systematically when constructing objects *)
-
-let zz = Util.dummy_loc;;
-
-(* This function receives a length n, a path p, and a term and returns a
-   couple whose first component is the subterm designated by the prefix
-   of p of length n, and the second component is the rest of the path *)
-
-let rec get_subterm  (depth:int) (path: int list) (constr:constr) =
-  match depth, path, kind_of_term constr with
-    0, l, c -> (constr,l)
-  | n, 2::a::tl, App(func,arr) -> 
-      get_subterm (n - 2) tl arr.(a-1)
-  | _,l,_ -> failwith (int_list_to_string 
-                        "wrong path or wrong form of term"
-                        l);;
-
-(* This function maps a substitution on an abstract syntax tree.  The
-   first argument, an object of type env, is necessary to
-   transform constr terms into abstract syntax trees.  The second argument is
-   the substitution, a list of pairs linking an integer and a constr term. *)
-
-let rec map_subst (env :env) (subst:patvar_map) = function
-  | CPatVar (_,(_,i)) ->
-      let constr = List.assoc i subst in
-      extern_constr false env constr
-  | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;;
-
-let map_subst_tactic env subst = function
-  | TacExtend (loc,("Rewrite" as x),[b;cbl]) ->
-      let c,bl = out_gen rawwit_constr_with_bindings cbl in
-      assert (bl = NoBindings);
-      let c = (map_subst env subst c,NoBindings) in
-      TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c])
-  | _ -> failwith "map_subst_tactic: unsupported tactic"
-
-(* This function is really the one that is important. *)
-let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 =
-  match l with
-    [] -> failwith "nothing happens"
-  | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl ->
-     let length = List.length p in
-     try
-       if deg > length then
-         failwith "internal"
-       else
-         let term_to_match, p_r = 
-             try 
-                get_subterm (length - deg) p constr
-             with
-                Failure s -> failwith "internal" in
-         let _, constr_pat = 
-            intern_constr_pattern Evd.empty (Global.env())
-               ((*ct_to_ast*) pat) in
-         let subst = matches constr_pat term_to_match in
-         if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then
-           TacAtom (zz, map_subst_tactic env subst cmd)
-         else
-	   failwith "internal"
-     with
-       Failure "internal" -> find_cmd tl env constr p p1 p2
-     | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;;
-
-
-let dad_rule_list = ref ([]: (string * dad_rule) list);;
-
-(*
-(* \\ This function is also used in pbp. *)
-let rec tactic_args_to_ints = function
-    [] -> []
-  | (Integer n)::l -> n::(tactic_args_to_ints l)
-  | _ -> failwith "expecting only numbers";;
-
-(* We assume that the two lists of integers for the tactic are simply
-   given in one list, separated by a dummy tactic. *)
-let rec part_tac_args l = function
-    [] -> l,[]
-  | (Tacexp a)::tl -> l, (tactic_args_to_ints tl)
-  | (Integer n)::tl -> part_tac_args (n::l) tl
-  | _ -> failwith "expecting only numbers and the word \"to\"";;
-
-
-(* The dad_tac tactic takes a display_function as argument.  This makes
-   it possible to use it in pcoq, but also in other contexts, just by
-   changing the output routine. *)
-let dad_tac display_function = function
-   l -> let p1, p2 = part_tac_args [] l in
-        (function g ->
-           let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in
-           (display_function 
-            (find_cmd (!dad_rule_list) (pf_env g)
-	       (pf_concl g) p_a p1prime p2prime));
-            tclIDTAC g);;
-*)
-let dad_tac display_function p1 p2 g =
-  let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in
-  (display_function 
-    (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime));
-  tclIDTAC g;;
-
-(* Now we enter dad rule list management. *)
-
-let add_dad_rule name patt p1 p2 depth pr command =
-  dad_rule_list := (name, 
-		    (patt, p1, p2, depth, pr, command))::!dad_rule_list;;
-
-let rec remove_if_exists name = function
-    [] -> false, []
-  | ((a,b) as rule1)::tl -> if a = name then 
-               let result1, l = (remove_if_exists name tl) in
-               true, l
-             else
-               let result1, l = remove_if_exists name tl in
-               result1, (rule1::l);;
-
-let remove_dad_rule name =
-  let result1, result2 = remove_if_exists name !dad_rule_list in
-  if result1 then
-    failwith("No such name among the drag and drop rules " ^ name)
-  else
-     dad_rule_list := result2;;
-
-let dad_rule_names () =
-    List.map (function (s,_) -> s) !dad_rule_list;;
-
-(* this function is inspired from matches_core in pattern.ml *)
-let constrain ((n : patvar),(pat : constr_pattern)) sigma =
-  if List.mem_assoc n sigma then
-    if pat = (List.assoc n sigma) then sigma
-    else failwith "internal"
-  else 
-    (n,pat)::sigma
-    
-(* This function is inspired from matches_core in pattern.ml *)
-let more_general_pat pat1 pat2 = 
-  let rec match_rec sigma p1 p2 =
-    match p1, p2 with
-      | PMeta (Some n), m -> constrain (n,m) sigma
-
-      | PMeta None, m -> sigma
-
-      | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma
-
-      | PVar v1, PVar v2 when v1 = v2 -> sigma
-
-      | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma
-
-      | PRel n1, PRel n2 when n1 = n2 -> sigma
-
-      | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma
-
-      | PSort (RType _), PSort (RType _) -> sigma
-
-      | PApp (c1,arg1), PApp (c2,arg2) ->
-        (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2
-         with Invalid_argument _ -> failwith "internal")
-      | _ -> failwith "unexpected case in more_general_pat" in 
-  try let _ = match_rec [] pat1 pat2 in true
-  with Failure "internal" -> false;;
-
-let more_general r1 r2 =
-  match r1,r2 with
-    (_,(patt1,p11,p12,_,_,_)),
-    (_,(patt2,p21,p22,_,_,_)) ->
-	(more_general_pat patt1 patt2) &
-      (is_prefix p11 p21) & (is_prefix p12 p22);;
-
-let not_less_general r1 r2 = 
-  not (match r1,r2 with
-    (_,(patt1,p11,p12,_,_,_)),
-    (_,(patt2,p21,p22,_,_,_)) ->
-	(more_general_pat patt1 patt2) &
-      (is_prefix p21 p11) & (is_prefix p22 p12));;
-
-let rec add_in_list_sorting rule1 = function
-    [] -> [rule1]
-  | (b::tl) as this_list ->
-      if more_general rule1 b  then
-	b::(add_in_list_sorting rule1 tl)
-      else if not_less_general rule1 b then
-	let tl2 = add_in_list_sorting_aux rule1 tl in
-	(match tl2 with
-	  [] -> rule1::this_list
-	| _ -> b::tl2)
-      else
-	rule1::this_list
-and add_in_list_sorting_aux rule1 = function
-    [] -> []
-  | b::tl -> 
-      if more_general rule1 b then
-      	b::(add_in_list_sorting rule1 tl)
-      else
-	let tl2 = add_in_list_sorting_aux rule1 tl in
-	(match tl2 with
-	  [] -> []
-	| _ -> rule1::tl2);;
-
-let rec sort_list = function
-    [] -> [] 
-  | a::l -> add_in_list_sorting a (sort_list l);;
-
-let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));;
-let mk_rewrite lr ast =
-  let b = in_gen rawwit_bool lr in
-  let cb = in_gen rawwit_constr_with_bindings (ast,NoBindings) in
-  TacExtend (zz,"Rewrite",[b;cb])
-
-open Vernacexpr
-
-let dad_status = ref false;;
-
-let start_dad () = dad_status := true;;
-
-let add_dad_rule_fn name pat p1 p2 tac =
-  let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in
-  add_dad_rule name pat p1 p2 (List.length pr) pr tac;;
-
-(* To be parsed by camlp4
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-VERNAC COMMAND EXTEND AddDadRule
-  [ "Add" "Dad" "Rule" string(name) constr(pat)
-    "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] ->
-  [ add_dad_rule_fn name pat p1 p2 tac ]
-END
-
-*)
-
-let mk_id s = mkIdentC (id_of_string s);;
-let mkMetaC = mk_dad_meta;;
-
-add_dad_rule "distributivity-inv"
-(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)]))
-[2; 2]
-[2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "distributivity1-r"
-(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 2; 2; 2]
-[]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "distributivity1-l"
-(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 1; 2; 2]
-[]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "associativity"
-(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)]))
-[2; 1]
-[]
-0
-[]
-(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "minus-identity-lr"
-(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)]))
-[2; 1]
-[2; 2]
-1
-[2]
-(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "minus-identity-rl"
-(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)]))
-[2; 2]
-[2; 1]
-1
-[2]
-(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-sym-rl"
-(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)]))
-[2; 2]
-[2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-sym-lr"
-(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)]))
-[2; 1]
-[2; 2]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "absorb-0-r-rl"
-(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")]))
-[2; 2]
-[1]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "absorb-0-r-lr"
-(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")]))
-[1]
-[2; 2]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-permute-lr"
-(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 1]
-[2; 2; 2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-permute-rl"
-(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 2; 2; 1]
-[2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));;
-
-vinterp_add "StartDad"
-   (function
-     | [] ->
-       (function () -> start_dad())
-     | _ -> errorlabstrm "StartDad" (mt()));;
diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli
deleted file mode 100644
index f556c192..00000000
--- a/contrib/interface/dad.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-open Proof_type;;
-open Tacmach;;
-open Topconstr;;
-
-val dad_rule_names : unit -> string list;;
-val start_dad : unit -> unit;;
-val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma ->
-                  goal list sigma * validation;;
-val add_dad_rule : string -> constr_expr -> (int list) -> (int list) ->
-                   int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;;
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
deleted file mode 100644
index aad3a765..00000000
--- a/contrib/interface/debug_tac.ml4
+++ /dev/null
@@ -1,458 +0,0 @@
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Tacmach;;
-open Tacticals;;
-open Proof_trees;;
-open Pp;;
-open Pptactic;;
-open Util;;
-open Proof_type;;
-open Tacexpr;;
-open Genarg;;
-
-let pr_glob_tactic = Pptactic.pr_glob_tactic (Global.env())
-
-(* Compacting and uncompacting proof commands *)
-
-type report_tree =
-    Report_node of bool *int * report_tree list
-  | Mismatch of int * int
-  | Tree_fail of report_tree
-  | Failed of int;;
-
-type report_card =
-    Ngoals of int
-  | Goals_mismatch of int
-  | Recursive_fail of report_tree
-  | Fail;;
-
-type card_holder = report_card ref;;
-type report_holder = report_tree list ref;;
-
-(* This tactical receives an integer and a tactic and checks that the
-   tactic produces that number of goals.  It never fails but signals failure
-   by updating the boolean reference given as third argument to false.
-   It is especially suited for use in checked_thens below. *)
-
-let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic =
-  fun card_holder count flag t g ->
-    try
-      let (gls, v) as result = t g in
-      let len = List.length (sig_it gls) in
-      card_holder :=
-      (if len = count then
-	  (flag := true;
-	  Ngoals count)
-       else
-          (flag := false;
-          Goals_mismatch len));
-      result
-    with
-      e -> card_holder := Fail;
-           flag := false;
-           tclIDTAC g;;
-
-let no_failure = function
-    [Report_node(true,_,_)] -> true
-  | _ -> false;;
-
-let check_subgoals_count2 
-    : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic =
-  fun card_holder count flag t g ->
-    let new_report_holder = ref ([] : report_tree list) in
-    let (gls, v) as result = t new_report_holder g in
-    let succeeded = no_failure !new_report_holder in
-    let len = List.length (sig_it gls) in
-    card_holder :=
-      (if (len = count) & succeeded then
-	(flag := true;
-	 Ngoals count)
-      else
-	(flag := false;
-	 Recursive_fail (List.hd !new_report_holder)));
-    result;;
-
-let traceable = function
-  | TacThen _ | TacThens _ -> true
-  | _ -> false;;
-
-let rec collect_status = function
-    Report_node(true,_,_)::tl -> collect_status tl
-  | [] -> true
-  | _ -> false;;
-
-(* This tactical receives a tactic and executes it, reporting information
-   about success in the report holder and a boolean reference. *)
-
-let count_subgoals : card_holder -> bool ref -> tactic -> tactic =
-  fun card_holder flag t g ->
-    try
-      let (gls, _) as result = t g in
-      card_holder := (Ngoals(List.length (sig_it gls)));
-      flag := true;
-      result
-    with
-      e -> card_holder := Fail;
-           flag := false;
-           tclIDTAC g;;
-   
-let count_subgoals2
-    : card_holder -> bool ref -> (report_holder -> tactic) -> tactic =
-  fun card_holder flag t g ->
-    let new_report_holder = ref([] : report_tree list) in
-    let (gls, v) as result = t new_report_holder g in
-    let succeeded = no_failure !new_report_holder in
-    if succeeded then
-      (flag := true;
-       card_holder := Ngoals (List.length (sig_it gls)))
-    else
-      (flag := false;
-       card_holder := Recursive_fail(List.hd !new_report_holder));
-    result;;
-
-let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function
-    TacThens (a,l) ->
-      (fun report_holder -> checked_thens report_holder a l)
-  | TacThen (a,[||],b,[||]) ->
-      (fun report_holder -> checked_then report_holder a b)
-  | t ->
-      (fun report_holder g ->
-	try
-	  let (gls, _) as result = Tacinterp.eval_tactic t g in
-	  report_holder := (Report_node(true, List.length (sig_it gls), []))
-			    ::!report_holder;
-	  result
-	with e -> (report_holder := (Failed 1)::!report_holder;
-		   tclIDTAC g))
-
-
-(* This tactical receives a tactic and a list of tactics as argument.
-   It applies the first tactic and then maps the list of tactics to
-   various produced sub-goals.  This tactic will never fail, but reports
-   are added in the report_holder in the following way:
-   - In case of partial success, a new report_tree is added to the report_holder
-   - In case of failure of the first tactic, with no more indications
-     then Failed 0 is added to the report_holder,
-   - In case of partial failure of the first tactic then (Failed n) is added to
-     the report holder.
-   - In case of success of the first tactic, but count mismatch, then
-     Mismatch n is added to the report holder. *)
-
-and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = 
-  (fun report_holder t1 l g ->
-    let flag = ref true in
-    let traceable_t1 = traceable t1 in
-    let card_holder = ref Fail in
-    let new_holder = ref ([]:report_tree list) in
-    let tac_t1 = 
-      if traceable_t1 then
-	(check_subgoals_count2 card_holder (List.length l)
-           flag (local_interp t1))
-      else
-	(check_subgoals_count card_holder (List.length l)
-           flag (Tacinterp.eval_tactic t1)) in
-    let (gls, _) as result = 
-      tclTHEN_i tac_t1
-	(fun i ->
-	  if !flag then
-	    (fun g -> 
-              let tac_i = (List.nth l i) in
-	      if traceable tac_i then
-                 local_interp tac_i new_holder g
-              else
-		 try
-		   let (gls,_) as result = Tacinterp.eval_tactic tac_i g in
-		   let len = List.length (sig_it gls) in
-				   new_holder :=
-		     (Report_node(true, len, []))::!new_holder;
-		   result
-		 with
-			       e -> (new_holder := (Failed 1)::!new_holder;
-			 tclIDTAC g))
-	  else
-	    tclIDTAC) g in
-      let new_goal_list = sig_it gls in
-      (if !flag then
-	report_holder := 
-	  (Report_node(collect_status !new_holder,
-		    (List.length new_goal_list),
-		    List.rev !new_holder))::!report_holder
-      else
-	report_holder :=
-	  (match !card_holder with
-	    Goals_mismatch(n) -> Mismatch(n, List.length l)
-	  | Recursive_fail tr -> Tree_fail tr
-	  | Fail -> Failed 1
-	  | _ -> errorlabstrm "check_thens"
-                  (str "this case should not happen in check_thens"))::
-	  !report_holder);
-      result)
-
-(* This tactical receives two tactics as argument, it executes the
-   first tactic and applies the second one to all the produced goals,
-   reporting information about the success of all tactics in the report
-   holder. It never fails. *)
-
-and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic =
-  (fun report_holder t1 t2 g ->
-    let flag = ref true in
-    let card_holder = ref Fail in
-    let tac_t1 =
-      if traceable t1 then
-	(count_subgoals2 card_holder flag (local_interp t1))
-      else
-	(count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in
-    let new_tree_holder = ref ([] : report_tree list) in
-    let (gls, _) as result =
-      tclTHEN tac_t1
-	(fun (g:goal sigma) -> 
-	  if !flag then
-	    if traceable t2 then
-	      local_interp t2 new_tree_holder g
-	    else
-	      try
-		let (gls, _) as result = Tacinterp.eval_tactic t2 g in
-	      	new_tree_holder :=
-		  (Report_node(true, List.length (sig_it gls),[]))::
-		  !new_tree_holder;
-		result
-	      with
-		e ->
-		  (new_tree_holder := ((Failed 1)::!new_tree_holder);
-		   tclIDTAC g)
-	  else
-	    tclIDTAC g) g in
-    (if !flag then
-      report_holder :=
-	(Report_node(collect_status !new_tree_holder,
-		     List.length (sig_it gls),
-		     List.rev !new_tree_holder))::!report_holder
-    else
-      report_holder :=
-	(match !card_holder with
-	  Recursive_fail tr -> Tree_fail tr
-	| Fail -> Failed 1
-	| _ -> error "this case should not happen in check_then")::!report_holder);
-    result);;
-
-(* This tactic applies the given tactic only to those subgoals designated
-   by the list of integers given as extra arguments.
- *)
-
-let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level
-let globwit_main_tactic = Pcoq.globwit_tactic Pcoq.tactic_main_level
-let wit_main_tactic = Pcoq.wit_tactic Pcoq.tactic_main_level
-
-
-let on_then = function [t1;t2;l] ->
-  let t1 = out_gen wit_main_tactic t1 in
-  let t2 = out_gen wit_main_tactic t2 in
-  let l = out_gen (wit_list0 wit_int) l in
-  tclTHEN_i (Tacinterp.eval_tactic t1)
-    (fun i ->
-      if List.mem (i + 1) l then
-      	(Tacinterp.eval_tactic t2)
-      else
-	tclIDTAC)
-  | _ -> anomaly "bad arguments for on_then";;
-
-let mkOnThen t1 t2 selected_indices =
-  let a = in_gen rawwit_main_tactic t1 in
-  let b = in_gen rawwit_main_tactic t2 in
-  let l = in_gen (wit_list0 rawwit_int) selected_indices in
-  TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));;
-
-(* Analyzing error reports *)
-
-let rec select_success n = function
-    [] -> []
-  | Report_node(true,_,_)::tl -> n::select_success (n+1) tl
-  | _::tl -> select_success (n+1) tl;;
-
-let rec reconstruct_success_tac (tac:glob_tactic_expr) =
-  match tac with
-    TacThens (a,l) ->
-      (function 
-	  Report_node(true, n, l) -> tac
-      	| Report_node(false, n, rl) ->
-	    TacThens (a,List.map2 reconstruct_success_tac l rl)
-      	| Failed n -> TacId []
-      	| Tree_fail r -> reconstruct_success_tac a r
-      	| Mismatch (n,p) -> a)
-  | TacThen (a,[||],b,[||]) ->
-      (function
-	  Report_node(true, n, l) -> tac
-	| Report_node(false, n, rl) ->
-	    let selected_indices = select_success 1 rl in
-	    TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen",
-	      [in_gen globwit_main_tactic a;
-	       in_gen globwit_main_tactic b;
-	       in_gen (wit_list0 globwit_int) selected_indices]))
-	| Failed n -> TacId []
-	| Tree_fail r -> reconstruct_success_tac a r
-	| _ -> error "this error case should not happen in a THEN tactic")
-  | _ -> 
-      (function
-	  Report_node(true, n, l) -> tac
-	| Failed n -> TacId []
-	| _ ->
-	    errorlabstrm
-	      "this error case should not happen on an unknown tactic"
-              (str "error in reconstruction with " ++ fnl () ++
-	       (pr_glob_tactic tac)));;
-	  
-
-let rec path_to_first_error = function
-| Report_node(true, _, l) ->
-  let rec find_first_error n = function
-  | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl
-  | it::tl -> n, it
-  | [] -> error "no error detected" in
-  let p, t = find_first_error 1 l in
-    p::(path_to_first_error t)
-| _ -> [];;
-
-let debug_tac = function
-    [(Tacexp ast)] ->
-      (fun g -> 
-      	let report = ref ([] : report_tree list) in
-      	let result = local_interp ast report g in
-      	let clean_ast = (* expand_tactic *) ast in
-      	let report_tree =
-          try List.hd !report with
-	    Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in
-      	let success_tac = 
-	  reconstruct_success_tac clean_ast report_tree in
-        let compact_success_tac = (* flatten_then *) success_tac in
-      	msgnl (fnl () ++
-	       str "=========    Successful tactic    =============" ++
-               fnl () ++
-	       pr_glob_tactic compact_success_tac ++ fnl () ++
-	       str "========= End of successful tactic ============");
-      	result)
-  | _ -> error "wrong arguments for debug_tac";;
-
-(* TODO ... used ?
-add_tactic "DebugTac" debug_tac;;
-*)
-
-Tacinterp.add_tactic "OnThen" on_then;;
-
-let rec clean_path tac l = 
-  match tac, l with
-  | TacThen (a,[||],b,[||]), fst::tl ->
-      fst::(clean_path (if fst = 1 then a else b) tl)
-  | TacThens (a,l), 1::tl ->
-      1::(clean_path a tl)
-  | TacThens (a,tacs), 2::fst::tl ->
-      2::fst::(clean_path (List.nth tacs (fst - 1)) tl)
-  | _, [] -> []
-  | _, _ -> failwith "this case should not happen in clean_path";;
-
-let rec report_error
-    : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> 
-      int list -> tactic =
-  fun tac the_goal the_ast returned_path path -> 
-    match tac with
-      TacThens (a,l) ->
-      let the_card_holder = ref Fail in
-      let the_flag = ref false in
-      let the_exn = ref (Failure "") in
-      tclTHENS
-	(fun g ->
-	  let result =
-	    check_subgoals_count 
-	      the_card_holder
-	      (List.length l) 
-	      the_flag
-	      (fun g2 -> 
-		try 
-		  (report_error a the_goal the_ast returned_path (1::path) g2)
-	  	with
-		  e -> (the_exn := e; raise e))
-	      g in
-	  if !the_flag then
-	    result
-	  else
-	    (match !the_card_holder with
-			Fail -> 
-			  the_ast := TacThens (!the_ast, l);
-			  raise !the_exn
-	    | Goals_mismatch p -> 
-		the_ast := tac;
-		returned_path := path;
-		error ("Wrong number of tactics: expected " ^
-		       (string_of_int (List.length l)) ^ " received " ^
-		       (string_of_int p))
-	    | _ -> error "this should not happen"))
-        (let rec fold_num n = function
-	    [] -> []
-	  | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path))::
-	      (fold_num (n + 1) tl) in
-	fold_num 1 l)
-    | TacThen (a,[||],b,[||]) ->
-	let the_count = ref 1 in
-	tclTHEN
-	  (fun g ->
-	    try
-	      report_error a the_goal the_ast returned_path (1::path) g
-	    with
-	      e ->
-		(the_ast := TacThen (!the_ast,[||], b,[||]);
-		 raise e))
-	  (fun g ->
-	    try
-	      let result = 
-		report_error b the_goal the_ast returned_path (2::path) g in
-	      the_count := !the_count + 1;
-	      result
-	    with
-	      e ->
-		if !the_count > 1 then
-		  msgnl
-		    (str "in branch no " ++ int !the_count ++
-		     str " after tactic " ++ pr_glob_tactic a);
-		raise e)
-    | tac ->
-	(fun g ->
-	  try
-	   Tacinterp.eval_tactic tac g
-	  with
-	    e ->
-	      (the_ast := tac;
-	       the_goal := Some g;
-	       returned_path := path;
-	       raise e));;
-
-let strip_some = function
-    Some n -> n
-  | None -> failwith "No optional value";;
-
-let descr_first_error tac =
-      (fun g ->
-	let the_goal = ref (None : goal sigma option) in
-	let the_ast = ref tac in
-	let the_path = ref ([] : int list) in
-	try
-	  let result = report_error tac the_goal the_ast the_path [] g in
-	  msgnl (str "no Error here");
-	  result
-	with
-	  e ->
-	    (msgnl (str "Execution of this tactic raised message " ++ fnl () ++
-		    fnl () ++ Cerrors.explain_exn e ++ fnl () ++
-		    fnl () ++ str "on goal"  ++ fnl () ++
-		    Printer.pr_goal (sig_it (strip_some !the_goal)) ++
-                    fnl () ++ str "faulty tactic is" ++ fnl () ++ fnl () ++
-		    pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ());
-	     tclIDTAC g))
-
-(* TODO ... used ??
-add_tactic "DebugTac2" descr_first_error;;
-*)
-
-(*
-TACTIC EXTEND DebugTac2
-  [ ??? ] -> [ descr_first_error tac ]
-END
-*)
diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli
deleted file mode 100644
index da4bbaa0..00000000
--- a/contrib/interface/debug_tac.mli
+++ /dev/null
@@ -1,6 +0,0 @@
-
-val report_error : Tacexpr.glob_tactic_expr ->
-    Proof_type.goal Evd.sigma option ref ->
-    Tacexpr.glob_tactic_expr ref -> int list ref -> int list -> Tacmach.tactic;;
-
-val clean_path : Tacexpr.glob_tactic_expr -> int list -> int list;;
diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml
deleted file mode 100644
index e0f43193..00000000
--- a/contrib/interface/depends.ml
+++ /dev/null
@@ -1,454 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant                                  *)
-(* <O___,, *                                                            *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *      GNU Lesser General Public License Version 2.1,        *)
-(*         *      or (at your option) any later version.                *)
-(************************************************************************)
-
-(* Copyright © 2007, Lionel Elie Mamane <lionel@mamane.lu> *)
-
-(* This is distributed in the hope that it will be useful,           *)
-(* but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
-(* Lesser General Public License for more details.                   *)
-
-(* You should have received a copy of the GNU Lesser General Public    *)
-(* License along with this library; if not, write to the Free Software *)
-(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,          *)
-(* MA  02110-1301, USA                                                 *)
-
-
-(* LEM TODO: a .mli file *)
-
-open Refiner
-open Proof_type
-open Rawterm
-open Term
-open Libnames
-open Util
-open Tacexpr
-open Entries
-
-(* DBG utilities, to be removed *)
-let print_bool b = print_string (string_of_bool b)
-let string_of_ppcmds p = Pp.pp_with Format.str_formatter p; Format.flush_str_formatter()
-let acc_str f = List.fold_left (fun a b -> a ^ (f b) ^ "+") "O"
-(* End utilities, to be removed *)
-
-let explore_tree pfs =
-  print_string "explore_tree called\n";
-  print_string "pfs is a top: ";
-  (* We expect yes. *)
-  print_string (if (is_top_pftreestate pfs) then "yes" else "no");
-  print_newline();
-  let rec explain_tree (pt:proof_tree) =
-    match pt.ref with
-      | None -> "none"
-      | Some (Prim p, l) -> "<Prim (" ^ (explain_prim p) ^ ") | " ^ (acc_str explain_tree l) ^ ">"
-      | Some (Nested (t,p), l) -> "<Nested (" ^ explain_compound t ^ ", " ^ (explain_tree p) ^ ") | " ^ (acc_str explain_tree l) ^ ">"
-      | Some (Decl_proof _, _) -> "Decl_proof"
-      | Some (Daimon, _) -> "Daimon"
-  and explain_compound cr =
-    match cr with
-      | Tactic (texp, b) -> "Tactic (" ^ (string_of_ppcmds (Tactic_printer.pr_tactic texp)) ^ ", " ^ (string_of_bool b) ^ ")"
-      | Proof_instr (b, instr) -> "Proof_instr (" ^ (string_of_bool b) ^ (string_of_ppcmds (Tactic_printer.pr_proof_instr instr)) ^ ")"
-  and explain_prim = function
-    | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c))
-    | Intro identifier -> "Intro"
-    | Cut (bool, _, identifier, types) -> "Cut"
-    | FixRule (identifier, int, l, _) -> "FixRule"
-    | Cofix (identifier, l, _) -> "Cofix"
-    | Convert_concl (types, cast_kind) -> "Convert_concl"
-    | Convert_hyp named_declaration -> "Convert_hyp"
-    | Thin identifier_list -> "Thin"
-    | ThinBody identifier_list -> "ThinBody"
-    | Move (bool, identifier, identifier') -> "Move"
-    | Rename (identifier, identifier') -> "Rename"
-    | Change_evars -> "Change_evars"
-    | Order _ -> "Order"
-  in
-  let pt = proof_of_pftreestate pfs in
-    (* We expect 0 *)
-    print_string "Number of open subgoals: ";
-    print_int pt.open_subgoals;
-    print_newline();
-    print_string "First rule is a ";
-    print_string (explain_tree pt);
-    print_newline()
-
-
-let o f g x = f (g x)
-let fst_of_3 (x, _, _) = x
-let snd_of_3 (_, x, _) = x
-let trd_of_3 (_, _, x) = x
-
-(* TODO: These for now return a Libnames.global_reference, but a
-   prooftree will also depend on things like tactic declarations, etc
-   so we may need a new type for that. *)
-let rec depends_of_hole_kind hk acc = match hk with
-  | Evd.ImplicitArg (gr,_)            -> gr::acc
-  | Evd.TomatchTypeParameter (ind, _) -> (IndRef ind)::acc
-  | Evd.BinderType _
-  | Evd.QuestionMark _
-  | Evd.CasesType
-  | Evd.InternalHole
-  | Evd.GoalEvar
-  | Evd.ImpossibleCase  -> acc
-
-let depends_of_'a_cast_type depends_of_'a act acc = match act with
-  | CastConv (ck, a) -> depends_of_'a a acc
-  | CastCoerce       -> acc
-
-let depends_of_'a_bindings depends_of_'a ab acc = match ab with
-  | ImplicitBindings al  -> list_union_map depends_of_'a al acc
-  | ExplicitBindings apl -> list_union_map (fun x y -> depends_of_'a (trd_of_3 x) y) apl acc
-  | NoBindings -> acc
-
-let depends_of_'a_with_bindings depends_of_'a (a, ab) acc =
-  depends_of_'a a (depends_of_'a_bindings depends_of_'a ab acc)
-
-(* let depends_of_constr_with_bindings = depends_of_'a_with_bindings depends_of_constr *)
-(* and depends_of_open_constr_with_bindings = depends_of_'a_with_bindings depends_of_open_let *)
-
-let depends_of_'a_induction_arg depends_of_'a aia acc = match aia with
-  | ElimOnConstr a -> depends_of_'a a acc
-  | ElimOnIdent _ ->
-      (* TODO: Check that this really refers only to an hypothesis (not a section variable, etc.)
-       * It *seems* thaat section variables are seen as hypotheses, so we have a problem :-(
-
-       * Plan: Load all section variables before anything in that
-       * section and call the user's proof script "brittle" and refuse
-       * to handle if it breaks because of that
-       *)
-      acc
-  | ElimOnAnonHyp _ -> acc
-
-let depends_of_'a_or_var depends_of_'a aov acc = match aov with
-  | ArgArg a -> depends_of_'a a acc
-  | ArgVar _ -> acc
-
-let depends_of_'a_with_occurences depends_of_'a (_,a) acc =
-  depends_of_'a a acc
-
-let depends_of_'a_'b_red_expr_gen depends_of_'a reg acc = match reg with
-  (* TODO: dirty assumption that the 'b doesn't make any dependency *)
-  | Red _
-  | Hnf
-  | Cbv _
-  | Lazy _
-  | Unfold _
-  | ExtraRedExpr _
-  | CbvVm           -> acc
-  | Simpl awoo ->
-      Option.fold_right
-	(depends_of_'a_with_occurences depends_of_'a)
-	awoo
-	acc
-  | Fold al -> list_union_map depends_of_'a al acc
-  | Pattern awol ->
-      list_union_map
-	(depends_of_'a_with_occurences depends_of_'a)
-	awol
-	acc
-
-let depends_of_'a_'b_inversion_strength depends_of_'a is acc = match is with
-  (* TODO: dirty assumption that the 'b doesn't make any dependency *)
-  | NonDepInversion _       -> acc
-  | DepInversion (_, ao, _) -> Option.fold_right depends_of_'a ao acc
-  | InversionUsing (a, _)   -> depends_of_'a a acc
-
-let depends_of_'a_pexistential depends_of_'a (_, aa) acc = array_union_map depends_of_'a aa acc
-
-let depends_of_named_vals nvs acc =
-  (* TODO: I'm stopping here because I have noooo idea what to do with values... *)
-  acc
-
-let depends_of_inductive ind acc = (IndRef ind)::acc
-
-let rec depends_of_constr c acc = match kind_of_term c with
-  | Rel       _                -> acc
-  | Var       id               -> (VarRef id)::acc
-  | Meta      _                -> acc
-  | Evar      ev               -> depends_of_'a_pexistential depends_of_constr ev acc
-  | Sort      _                -> acc
-  | Cast      (c, _, t)        -> depends_of_constr c (depends_of_constr t acc)
-  | Prod      (_, t, t')       -> depends_of_constr t (depends_of_constr t' acc)
-  | Lambda    (_, t, c)        -> depends_of_constr t (depends_of_constr c acc)
-  | LetIn     (_, c, t, c')    -> depends_of_constr c (depends_of_constr t (depends_of_constr c' acc))
-  | App       (c, ca)          -> depends_of_constr c (array_union_map depends_of_constr ca acc)
-  | Const     cnst             -> (ConstRef cnst)::acc
-  | Ind       ind              -> (IndRef ind)::acc
-  | Construct cons             -> (ConstructRef cons)::acc
-  | Case      (_, c, c', ca)   -> depends_of_constr c (depends_of_constr c' (array_union_map depends_of_constr ca acc))
-  | Fix       (_, (_, ta, ca))
-  | CoFix     (_, (_, ta, ca)) -> array_union_map depends_of_constr ca (array_union_map depends_of_constr ta acc)
-and depends_of_evar_map evm acc =
-  Evd.fold (fun ev evi -> depends_of_evar_info evi) evm acc
-and depends_of_evar_info evi acc =
-  (* TODO: evi.evar_extra contains a dynamic... Figure out what to do with it. *)
-  depends_of_constr evi.Evd.evar_concl (depends_of_evar_body evi.Evd.evar_body (depends_of_named_context_val evi.Evd.evar_hyps acc))
-and depends_of_evar_body evb acc = match evb with
-  | Evd.Evar_empty -> acc
-  | Evd.Evar_defined c -> depends_of_constr c acc
-and depends_of_named_context nc acc = list_union_map depends_of_named_declaration nc acc
-and depends_of_named_context_val ncv acc =
-  depends_of_named_context (Environ.named_context_of_val ncv) (depends_of_named_vals (Environ.named_vals_of_val ncv) acc)
-and depends_of_named_declaration (_,co,t) acc = depends_of_constr t (Option.fold_right depends_of_constr co acc)
-
-
-
-let depends_of_open_constr (evm,c) acc =
-  depends_of_constr c (depends_of_evar_map evm acc)
-
-let rec depends_of_rawconstr rc acc = match rc with
-  | RRef (_,r)         -> r::acc
-  | RVar (_, id)       -> (VarRef id)::acc
-  | REvar (_, _, rclo) -> Option.fold_right depends_of_rawconstr_list rclo acc
-  | RPatVar _          -> acc
-  | RApp (_, rc, rcl)  -> depends_of_rawconstr rc (depends_of_rawconstr_list rcl acc)
-  | RLambda (_, _, _, rct, rcb)
-  | RProd   (_, _, _, rct, rcb)
-  | RLetIn  (_, _, rct, rcb) -> depends_of_rawconstr rcb (depends_of_rawconstr rct acc)
-  | RCases  (_, _, rco, tmt, cc) ->
-      (* LEM TODO: handle the cc *)
-      (Option.fold_right depends_of_rawconstr rco
-         (list_union_map
-	    (fun (rc, pp) acc ->
-	       Option.fold_right (fun (_,ind,_,_) acc -> (IndRef ind)::acc) (snd pp)
-	       (depends_of_rawconstr rc acc))
-	    tmt
-	    acc))
-  | RLetTuple (_,_,(_,rco),rc0,rc1) ->
-     depends_of_rawconstr rc1 (depends_of_rawconstr rc0 (Option.fold_right depends_of_rawconstr rco acc))
-  | RIf (_, rcC, (_, rco), rcT, rcF) -> let dorc = depends_of_rawconstr in
-      dorc rcF (dorc rcT (dorc rcF (dorc rcC (Option.fold_right dorc rco acc))))
-  | RRec (_, _, _, rdla, rca0, rca1) -> let dorca = array_union_map depends_of_rawconstr in
-      dorca rca0 (dorca rca1 (array_union_map
-				(list_union_map (fun (_,_,rco,rc) acc -> depends_of_rawconstr rc (Option.fold_right depends_of_rawconstr rco acc)))
-				rdla
-				acc))
-  | RSort _ -> acc
-  | RHole (_, hk) -> depends_of_hole_kind hk acc
-  | RCast (_, rc, rcct) -> depends_of_rawconstr rc (depends_of_'a_cast_type depends_of_rawconstr rcct acc)
-  | RDynamic (_, dyn) -> failwith "Depends of a dyn not implemented yet" (* TODO: figure out how these dyns are used*)
-and depends_of_rawconstr_list l = list_union_map depends_of_rawconstr l
-
-let depends_of_rawconstr_and_expr (rc, _) acc =
-  (* TODO Le constr_expr représente le même terme que le rawconstr. Vérifier ça. *)
-  depends_of_rawconstr rc acc
-
-let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of_'tac =
-  (* TODO:
-   * Dirty assumptions that the 'id, 'cst, 'ref don't generate dependencies
-   *)
-  let rec depends_of_tacexpr texp acc = match texp with
-    | TacAtom (_, atexpr) -> depends_of_atomic_tacexpr atexpr acc
-    | TacThen (tac0, taca0, tac1, taca1) ->
-	depends_of_tacexpr tac0 (array_union_map depends_of_tacexpr taca0 (depends_of_tacexpr tac1 (array_union_map depends_of_tacexpr taca1 acc)))
-    | TacThens (tac, tacl) ->
-	depends_of_tacexpr tac (list_union_map depends_of_tacexpr tacl acc)
-    | TacFirst tacl -> list_union_map depends_of_tacexpr tacl acc
-    | TacComplete tac -> depends_of_tacexpr tac acc
-    | TacSolve tacl -> list_union_map depends_of_tacexpr tacl acc
-    | TacTry tac -> depends_of_tacexpr tac acc
-    | TacOrelse (tac0, tac1) -> depends_of_tacexpr tac0 (depends_of_tacexpr tac1 acc)
-    | TacDo (_, tac) -> depends_of_tacexpr tac acc
-    | TacRepeat tac -> depends_of_tacexpr tac acc
-    | TacProgress tac -> depends_of_tacexpr tac acc
-    | TacAbstract (tac, _) -> depends_of_tacexpr tac acc
-    | TacId _
-    | TacFail _ -> acc
-    | TacInfo tac -> depends_of_tacexpr tac acc
-    | TacLetIn (_, igtal, tac) ->
-	depends_of_tacexpr
-	  tac
-	  (list_union_map
-	     (fun x y -> depends_of_tac_arg (snd x) y)
-	     igtal
-	     acc)
-    | TacMatch (_, tac, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match not implemented yet"
-    | TacMatchGoal (_, _, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match Context not implemented yet"
-    | TacFun tacfa -> depends_of_tac_fun_ast tacfa acc
-    | TacArg tacarg -> depends_of_tac_arg tacarg acc
-  and depends_of_atomic_tacexpr atexpr acc = let depends_of_'constr_with_bindings = depends_of_'a_with_bindings depends_of_'constr in match atexpr with
-      (* Basic tactics *)
-    | TacIntroPattern _
-    | TacIntrosUntil _
-    | TacIntroMove _
-    | TacAssumption  -> acc
-    | TacExact          c
-    | TacExactNoCheck   c
-    | TacVmCastNoCheck  c  -> depends_of_'constr c acc
-    | TacApply (_, _, [cb], None) -> depends_of_'constr_with_bindings cb acc
-    | TacApply (_, _, _, _) -> failwith "TODO"
-    | TacElim (_, cwb, cwbo) ->
-	depends_of_'constr_with_bindings cwb
-	  (Option.fold_right depends_of_'constr_with_bindings cwbo acc)
-    | TacElimType c -> depends_of_'constr c acc
-    | TacCase (_, cb) -> depends_of_'constr_with_bindings cb acc
-    | TacCaseType c -> depends_of_'constr c acc
-    | TacFix _
-    | TacMutualFix _
-    | TacCofix _
-    | TacMutualCofix _ -> failwith "depends_of_atomic_tacexpr of a Tac(Mutual)(Co)Fix not implemented yet"
-    | TacCut c -> depends_of_'constr c acc
-    | TacAssert (taco, _, c) ->
-	Option.fold_right depends_of_'tac taco (depends_of_'constr c acc)
-    | TacGeneralize cl ->
-	list_union_map depends_of_'constr (List.map (fun ((_,c),_) -> c) cl)
-	acc
-    | TacGeneralizeDep c -> depends_of_'constr c acc
-    | TacLetTac (_,c,_,_) -> depends_of_'constr c acc
-
-    (* Derived basic tactics *)
-    | TacSimpleInductionDestruct _
-    | TacDoubleInduction _ -> acc
-    | TacInductionDestruct (_, _, [cwbial, cwbo, _, _]) ->
-	list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings)
-	  cwbial
-	  (Option.fold_right depends_of_'constr_with_bindings cwbo acc)
-    | TacInductionDestruct (_, _, _) -> failwith "TODO"
-    | TacDecomposeAnd c
-    | TacDecomposeOr  c -> depends_of_'constr c acc
-    | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc)
-    | TacSpecialize (_,cwb) -> depends_of_'constr_with_bindings cwb acc
-    | TacLApply c -> depends_of_'constr c acc
-
-    (* Automation tactics *)
-    | TacTrivial (cl, bs) -> 
-	(* TODO: Maybe make use of bs: list of hint bases to be used. *)
-	list_union_map depends_of_'constr cl acc
-    | TacAuto (_, cs, bs) ->
-	(* TODO: Maybe make use of bs: list of hint bases to be used.
-           None -> all ("with *")
-           Some list -> a list, "core" added implicitly *)
-	list_union_map depends_of_'constr cs acc
-    | TacAutoTDB _     -> acc
-    | TacDestructHyp _ -> acc
-    | TacDestructConcl -> acc
-    | TacSuperAuto _ -> (* TODO: this reference thing is scary*)
-	acc
-    | TacDAuto     _ -> acc
-
-    (* Context management *)
-    | TacClear     _
-    | TacClearBody _
-    | TacMove      _
-    | TacRename    _ 
-    | TacRevert    _ -> acc
-
-    (* Constructors *)
-    | TacLeft        (_,cb)
-    | TacRight       (_,cb)
-    | TacSplit       (_, _, cb)
-    | TacConstructor (_, _, cb) -> depends_of_'a_bindings depends_of_'constr cb acc
-    | TacAnyConstructor (_,taco) -> Option.fold_right depends_of_'tac taco acc
-
-    (* Conversion *)
-    | TacReduce  (reg,_) ->
-	depends_of_'a_'b_red_expr_gen depends_of_'constr reg acc
-    | TacChange (cwoo, c, _) ->
-	depends_of_'constr
-	  c
-	  (Option.fold_right (depends_of_'a_with_occurences depends_of_'constr) cwoo acc)
-
-    (* Equivalence relations *)
-    | TacReflexivity
-    | TacSymmetry     _ -> acc
-    | TacTransitivity c -> depends_of_'constr c acc
-
-    (* Equality and inversion *)
-    | TacRewrite (_,cbl,_,_) -> list_union_map (o depends_of_'constr_with_bindings (fun (_,_,x)->x)) cbl acc
-    | TacInversion (is, _)  -> depends_of_'a_'b_inversion_strength depends_of_'constr is acc
-
-    (* For ML extensions *)
-    | TacExtend (_, _, cgal) -> failwith "depends of TacExtend not implemented because depends of a generic_argument not implemented"
-
-    (* For syntax extensions *)
-    | TacAlias (_,_,gal,(_,gte)) -> failwith "depends of a TacAlias not implemented because depends of a generic_argument not implemented"
-  and depends_of_tac_fun_ast tfa acc = failwith "depend_of_tac_fun_ast not implemented yet"
-  and depends_of_tac_arg ta acc = match ta with
-    | TacDynamic (_,d)  -> failwith "Don't know what to do with a Dyn in tac_arg"
-    | TacVoid           -> acc
-    | MetaIdArg  _      -> failwith "Don't know what to do with a MetaIdArg in tac_arg"
-    | ConstrMayEval  me -> failwith "TODO: depends_of_tac_arg of a ConstrMayEval"
-    | IntroPattern   _  -> acc
-    | Reference     ltc -> acc (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *)
-    | Integer       _   -> acc
-    | TacCall (_,ltc,l) -> (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *)
-	list_union_map depends_of_tac_arg l acc
-    | TacExternal (_,_,_,l) -> list_union_map depends_of_tac_arg l acc
-    | TacFreshId     _  -> acc
-    | Tacexp       tac  ->
-	depends_of_'tac tac acc
-  in
-    depends_of_tacexpr
-
-let rec depends_of_glob_tactic_expr (gte:glob_tactic_expr) acc =
-  depends_of_gen_tactic_expr
-    depends_of_rawconstr_and_expr
-    (depends_of_'a_or_var depends_of_inductive)
-    depends_of_glob_tactic_expr
-    gte
-    acc
-
-let rec depends_of_tacexpr te acc =
-  depends_of_gen_tactic_expr
-    depends_of_open_constr
-    depends_of_inductive
-    depends_of_glob_tactic_expr
-    te
-    acc
-
-let depends_of_compound_rule cr acc = match cr with
-  | Tactic (texp, _) -> depends_of_tacexpr texp acc
-  | Proof_instr (b, instr) ->
-      (* TODO: What is the boolean b? Should check. *)
-      failwith "Dependency calculation of Proof_instr not implemented yet"
-and depends_of_prim_rule pr acc = match pr with
-  | Refine c                     -> depends_of_constr c acc
-  | Intro id                     -> acc
-  | Cut (_, _, _, t)             -> depends_of_constr t acc (* TODO: check what 3nd argument contains *)
-  | FixRule (_, _, l, _)         -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *)
-  | Cofix (_, l, _)              -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *)
-  | Convert_concl (t, _)         -> depends_of_constr t acc
-  | Convert_hyp (_, None, t)     -> depends_of_constr t acc
-  | Convert_hyp (_, (Some c), t) -> depends_of_constr c (depends_of_constr t acc)
-  | Thin _                       -> acc
-  | ThinBody _                   -> acc
-  | Move _                       -> acc
-  | Rename _                     -> acc
-  | Change_evars                 -> acc
-  | Order _                      -> acc
-
-let rec depends_of_pftree pt acc =
-  match pt.ref with
-    | None -> acc
-    | Some (Prim   pr    , l) -> depends_of_prim_rule pr (list_union_map depends_of_pftree l  acc)
-    | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p (list_union_map depends_of_pftree l acc))
-    | Some (Decl_proof _ , l) -> list_union_map depends_of_pftree l acc
-    | Some (Daimon,        l) -> list_union_map depends_of_pftree l acc
-
-let rec depends_of_pftree_head pt acc =
-  match pt.ref with
-    | None -> acc
-    | Some (Prim   pr    , l) -> depends_of_prim_rule pr acc
-    | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p acc)
-    | Some (Decl_proof _ , l) -> acc
-    | Some (Daimon,        l) -> acc
-
-let depends_of_pftreestate depends_of_pftree pfs =
-(*   print_string "depends_of_pftreestate called\n"; *)
-(*   explore_tree pfs; *)
-  let pt = proof_of_pftreestate pfs in
-    assert (is_top_pftreestate pfs);
-    assert (pt.open_subgoals = 0);
-    depends_of_pftree pt []
-
-let depends_of_definition_entry de ~acc =
-  Option.fold_right
-    depends_of_constr
-    de.const_entry_type
-    (depends_of_constr de.const_entry_body acc)
diff --git a/contrib/interface/history.ml b/contrib/interface/history.ml
deleted file mode 100644
index f73c2084..00000000
--- a/contrib/interface/history.ml
+++ /dev/null
@@ -1,373 +0,0 @@
-open Paths;;
-
-type tree = {mutable index : int;
-             parent : tree option;
-             path_to_root : int list;
-             mutable is_open : bool;
-             mutable sub_proofs : tree list};;
-
-type prf_info = {
-    mutable prf_length : int;
-    mutable ranks_and_goals : (int * int * tree) list;
-    mutable border : tree list;
-    prf_struct : tree};;
-
-let theorem_proofs = ((Hashtbl.create 17): 
-			(string, prf_info) Hashtbl.t);;
-
-
-let rec mk_trees_for_goals path tree rank k n =
-  if k = (n + 1) then
-    []
-  else
-    { index = rank;
-      parent = tree;
-      path_to_root = k::path;
-      is_open = true;
-      sub_proofs = [] } ::(mk_trees_for_goals  path tree rank (k+1) n);;
-
-
-let push_command s rank ngoals =
-  let ({prf_length = this_length;
- 	ranks_and_goals = these_ranks;
-	border = this_border} as proof_info) =
-         Hashtbl.find theorem_proofs s in
-  let rec push_command_aux n = function
-      [] -> failwith "the given rank was too large"
-    | a::l ->
-	if n = 1 then
-	 let {path_to_root = p} = a in
-	 let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in
-	 new_trees,(new_trees@l),a
-	else
-	  let new_trees, res, this_tree = push_command_aux (n-1) l in
-	  new_trees,(a::res),this_tree in
-  let new_trees, new_border, this_tree =
-      push_command_aux rank this_border in
-  let new_length = this_length + 1 in
-  begin
-    proof_info.border <- new_border;
-    proof_info.prf_length <- new_length;
-    proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks;
-    this_tree.index <- new_length;
-    this_tree.is_open <- false;
-    this_tree.sub_proofs <- new_trees
-  end;;
-
-let get_tree_for_rank thm_name rank = 
-  let {ranks_and_goals=l;prf_length=n} = 
-         Hashtbl.find theorem_proofs thm_name in
-  let rec get_tree_aux = function
-      [] ->
- 	failwith 
-         "inconsistent values for thm_name and rank in get_tree_for_rank"
-    | (_,_,({index=i} as tree))::tl ->
-	if i = rank then
-	  tree
-	else
-	  get_tree_aux tl in
-  get_tree_aux l;;
-
-let get_path_for_rank thm_name rank =
-  let {path_to_root=l}=get_tree_for_rank thm_name rank in
-  l;;
-
-let rec list_descendants_aux l tree =
-  let {index = i; is_open = open_status; sub_proofs = tl} = tree in
-  let res = (List.fold_left list_descendants_aux  l tl) in
-  if open_status then i::res else res;;
-
-let list_descendants thm_name rank =
-  list_descendants_aux [] (get_tree_for_rank thm_name rank);;
-
-let parent_from_rank thm_name rank =
-  let {parent=mommy} = get_tree_for_rank thm_name rank in
-  match mommy with
-   Some x -> Some x.index
-  | None -> None;;
-
-let first_child_command thm_name rank =
-  let {sub_proofs = l} = get_tree_for_rank thm_name rank in
-  let rec first_child_rec = function 
-      [] -> None
-    | {index=i;is_open=b}::l -> 
-	if b then
-	  (first_child_rec l)
-	else
- 	  Some i in
-  first_child_rec l;;
-
-type index_or_rank = Is_index of int | Is_rank of int;;
-
-let first_child_command_or_goal thm_name rank =
-  let proof_info = Hashtbl.find theorem_proofs thm_name in
-  let {sub_proofs=l}=get_tree_for_rank thm_name rank in
-  match l with
-    [] -> None
-  | ({index=i;is_open=b} as t)::_ -> 
-      if b then
-	let rec get_rank n = function
-	    [] -> failwith "A goal is lost in first_child_command_or_goal"
-	  | a::l ->
-	      if a==t then
-		n
-	      else
-		get_rank (n + 1) l in
-	Some(Is_rank(get_rank 1 proof_info.border))
-      else
-	Some(Is_index i);;
-
-let next_sibling thm_name rank =
-  let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in
-  match mommy with
-    None -> None
-  |  Some real_mommy ->
-  let {sub_proofs=l}=real_mommy in
-  let rec next_sibling_aux b = function
-      (opt_first, []) -> 
-	if b then
-	  opt_first
-	else
-	  failwith "inconsistency detected in next_sibling"
-    | (opt_first, {is_open=true}::l) -> 
-	next_sibling_aux b (opt_first, l)
-    | (Some(first),({index=i; is_open=false} as t')::l) ->
-	if b then
-	  Some i
-	else
-	  next_sibling_aux (t == t') (Some first,l)
-    | None,({index=i;is_open=false} as t')::l ->
-  	next_sibling_aux (t == t') ((Some i), l)
-  in
-  Some (next_sibling_aux false (None, l));;
-
-
-let prefix l1 l2 =
-  let l1rev = List.rev l1 in
-  let l2rev = List.rev l2 in
-  is_prefix l1rev l2rev;;
-
-let rec remove_all_prefixes p = function
-    [] -> []
-  | a::l -> 
-      if is_prefix p a then
- 	(remove_all_prefixes p l)
-      else
-	a::(remove_all_prefixes p l);;
-
-let recompute_border tree =
-  let rec recompute_border_aux tree acc =
-    let {is_open=b;sub_proofs=l}=tree in
-    if b then
-      tree::acc
-    else
-      List.fold_right recompute_border_aux l acc in
-  recompute_border_aux tree [];;
- 
-   
-let historical_undo thm_name rank =
-  let ({ranks_and_goals=l} as proof_info)=
-       Hashtbl.find theorem_proofs thm_name in
-  let rec undo_aux acc = function
-      [] ->  failwith "bad rank provided for undoing in historical_undo"
-    | (r, n, ({index=i} as tree))::tl  ->
-	let this_path_reversed = List.rev tree.path_to_root in
-	let res = remove_all_prefixes this_path_reversed acc in
-	if i = rank then
-	  begin
-	    proof_info.prf_length <- i-1;
-	    proof_info.ranks_and_goals <- tl;
-	    tree.is_open <- true;
-	    tree.sub_proofs <- [];
-	    proof_info.border <- recompute_border proof_info.prf_struct;
-            this_path_reversed::res 
-	  end
-	else
-	  begin
-	    tree.is_open <- true;
-	    tree.sub_proofs <- [];
-	    undo_aux (this_path_reversed::res) tl
-	  end
-  in
-  List.map List.rev (undo_aux [] l);;
-
-(* The following function takes a list of trees and compute the
-   number of elements whose path is lexically smaller or a suffixe of
-   the path given as a first argument.  This works under the precondition that
-   the list is lexicographically order. *)
-
-let rec logical_undo_on_border the_tree rev_path = function
-    [] -> (0,[the_tree])
-  | ({path_to_root=p}as tree)::tl ->
-    let p_rev = List.rev p in
-    if is_prefix rev_path p_rev then
-      let (k,res) = (logical_undo_on_border the_tree rev_path tl) in
-          (k+1,res)
-    else if lex_smaller p_rev rev_path then
-      let (k,res) = (logical_undo_on_border the_tree rev_path tl) in
-          (k,tree::res)
-    else
-          (0, the_tree::tree::tl);;
-   
-
-let logical_undo thm_name rank =
-  let ({ranks_and_goals=l; border=last_border} as proof_info)=
-           Hashtbl.find theorem_proofs thm_name in
-  let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in
-  let rev_ref_path = List.rev ref_path in
-  let rec logical_aux lex_smaller_offset family_width = function
-      [] -> failwith "this case should never happen in logical_undo"
-    | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree))::
-        tl ->
-        let this_path_rev = List.rev this_path in
-        let new_rank, new_offset, new_width, kept =
-	  if is_prefix rev_ref_path this_path_rev then
-	    (r + lex_smaller_offset), lex_smaller_offset,
-              (family_width + 1 - n), false 
-	  else if lex_smaller this_path_rev rev_ref_path then
-            r, (lex_smaller_offset -  1 + n), family_width, true
-          else
-            (r + 1 - family_width+ lex_smaller_offset),
-	    lex_smaller_offset, family_width, true in
-        if i=rank then
-	  [i,new_rank],[], tl, rank
-        else
-          let ranks_undone, ranks_kept, ranks_and_goals, current_rank =
-	    (logical_aux new_offset new_width tl) in
-          begin
-	    if kept then
-	      begin
-	      	tree.index <- current_rank;
-	    	ranks_undone, ((i,new_rank)::ranks_kept),
-	    	((new_rank, n, tree)::ranks_and_goals), 
-                (current_rank + 1)
-	      end
-	    else
-	      ((i,new_rank)::ranks_undone), ranks_kept,
-	      ranks_and_goals, current_rank
-	  end in
-  let number_suffix, new_border = 
-     logical_undo_on_border ref_tree rev_ref_path last_border in
-  let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals,
-    new_length_plus_one = logical_aux 0 number_suffix l in
-  let the_goal_index =
-    let rec compute_goal_index n = function
-	[] -> failwith "this case should never happen in logical undo (2)"
-      |	{path_to_root=path}::tl ->
-	  if List.rev path = (rev_ref_path) then
-	    n
-	  else
-	    compute_goal_index (n+1) tl in
-    compute_goal_index 1 new_border in
-  begin
-    ref_tree.is_open <- true;
-    ref_tree.sub_proofs <- [];
-    proof_info.border <- new_border;
-    proof_info.ranks_and_goals <- new_ranks_and_goals;
-    proof_info.prf_length <- new_length_plus_one - 1;
-    changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, 
-    the_goal_index
-  end;;
-	
-let start_proof thm_name =
-   let the_tree = 
-      {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in
-   Hashtbl.add theorem_proofs thm_name
-     {prf_length=0;
-      ranks_and_goals=[];
-      border=[the_tree];
-      prf_struct=the_tree};;
-      
-let dump_sequence chan s =
-    match (Hashtbl.find theorem_proofs s) with
-    {ranks_and_goals=l}->
-      let rec dump_rec = function
-	  [] -> ()
-  	| (r,n,_)::tl ->
-	    dump_rec tl;
-	    output_string chan (string_of_int r);
-	    output_string chan ",";
-	    output_string chan (string_of_int n);
-	    output_string chan "\n" in
-      begin
-      	dump_rec l;
-	output_string chan "end\n"
-      end;;
-
-      
-let proof_info_as_string s =
-  let res = ref "" in
-  match (Hashtbl.find theorem_proofs s) with
-  {prf_struct=tree} ->
-  let open_goal_counter = ref 0 in
-  let rec dump_rec = function
-    {index=i;sub_proofs=trees;parent=the_parent;is_open=op} ->
-    begin
-      (match the_parent with
-         None ->
-	   if op then
-	     res := !res ^  "\"open goal\"\n"
-       | Some {index=j} -> 
-           begin
-             res := !res ^  (string_of_int j);
-             res := !res ^  " -> ";
-	     if op then
-	       begin
-		 res := !res ^  "\"open goal ";
-		 open_goal_counter := !open_goal_counter + 1;
-		 res := !res ^  (string_of_int !open_goal_counter);
-		 res := !res ^  "\"\n";
-	       end
-	     else
-	       begin
-		 res := !res ^  (string_of_int i);
-		 res := !res ^  "\n"
-	       end
-           end);
-      	List.iter dump_rec trees
-     end in
-  dump_rec tree;
-  !res;;
-
-
-let dump_proof_info chan s = 
-  match (Hashtbl.find theorem_proofs s) with
-  {prf_struct=tree} ->
-  let open_goal_counter = ref 0 in
-  let rec dump_rec = function
-    {index=i;sub_proofs=trees;parent=the_parent;is_open=op} ->
-    begin
-      (match the_parent with
-         None ->
-	   if op then
-	     output_string chan "\"open goal\"\n"
-       | Some {index=j} -> 
-           begin
-             output_string chan (string_of_int j);
-             output_string chan " -> ";
-	     if op then
-	       begin
-		 output_string chan "\"open goal ";
-		 open_goal_counter := !open_goal_counter + 1;
-		 output_string chan (string_of_int !open_goal_counter);
-		 output_string chan "\"\n";
-	       end
-	     else
-	       begin
-		 output_string chan (string_of_int i);
-		 output_string chan "\n"
-	       end
-           end);
-      	List.iter dump_rec trees
-     end in
-  dump_rec tree;;
-
-let get_nth_open_path s n =
-  match Hashtbl.find theorem_proofs s with
-    {border=l} ->
-    let {path_to_root=p}=List.nth l (n - 1) in
-    p;;
-
-let border_length s =
-  match Hashtbl.find theorem_proofs s with
-    {border=l} -> List.length l;;
diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli
deleted file mode 100644
index 053883f0..00000000
--- a/contrib/interface/history.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-type prf_info;;
-
-val start_proof : string -> unit;;
-val historical_undo : string -> int -> int list list
-val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int
-val dump_sequence : out_channel -> string -> unit
-val proof_info_as_string : string -> string
-val dump_proof_info : out_channel -> string -> unit
-val push_command : string -> int -> int -> unit
-val get_path_for_rank : string -> int -> int list
-val get_nth_open_path : string -> int -> int list
-val border_length : string -> int
diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4
deleted file mode 100755
index 0b13a092..00000000
--- a/contrib/interface/line_parser.ml4
+++ /dev/null
@@ -1,241 +0,0 @@
-(* line-oriented Syntactic analyser for a Coq parser *)
-(* This parser expects a very small number of commands, each given on a complete
-line.  Some of these commands are then followed by a text fragment terminated
-by a precise keyword, which is also expected to appear alone on a line. *)
-
-(* The main parsing loop procedure is "parser_loop", given at the end of this
-file.  It read lines one by one and checks whether they can be parsed using
-a very simple parser.  This very simple parser uses a lexer, which is also given
-in this file.  
-
-The lexical analyser:
- There are only 5 sorts of tokens *)
-type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string |
-      Tlbracket | Trbracket;;
-
-(* When recognizing identifiers or strings, the lexical analyser accumulates
-   the characters in a buffer, using the command add_in_buff.  To recuperate
-   the characters, one can use get_buff (this code was inspired by the
-   code in src/meta/lexer.ml of Coq revision 6.1) *)
-let add_in_buff,get_buff =
-  let buff = ref (String.create 80) in
-    (fun i x -> 
-       let len = String.length !buff in
-        if i >= len then (buff := !buff ^ (String.create len);());
-         String.set !buff i x;
-         succ i),
-     (fun len -> String.sub !buff 0 len);;
-
-(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*.  When arriving here the first
-   character has already been recognized. *)
-let rec ident len = parser
-  [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] ->
-    ident (add_in_buff len c) s
-| [< >] -> let str = get_buff len in Tid(str);;
-
-(* While recognizing integers, one constructs directly the integer value.
-   The ascii code of '0' is important for this. *)
-let code0 = Char.code '0';;
-
-let get_digit c =  Char.code c - code0;;
-
-(* Integers are [0-9]*
-   The variable intval is the integer value of the text that has already
-   been recognized.  As for identifiers, the first character has already been
-   recognized. *)
-
-let rec parse_int intval = parser
-  [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i
-| [< >] -> Tint intval;;
-      
-(* The string lexer is borrowed from the string parser of Coq V6.1 
-   This may be a problem if convention have changed in Coq,
-   However this parser is only used to recognize file names which should
-   not contain too many special characters *)
-
-let rec spec_char = parser
-  [< ''n' >] -> '\n' 
-| [< ''t' >] -> '\t'
-| [< ''b' >] -> '\008' 
-| [< ''r' >] -> '\013'
-| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] ->
-    Char.chr v
-| [< 'x >] -> x
-
-and spec1 v = parser
-  [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s
-| [< >] -> v
-;;
-
-(* This is the actual string lexical analyser.  Strings are
-   QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used
-   to represents double quotation characters, that cannot be used
-   freely, even inside comments. *)
-
-let rec string len = parser
-  [< ''"' >] -> len
-| [<''\\' ;
-      len = (parser [< ''\n' >] -> len
-             | [< c=spec_char >] -> add_in_buff len c);
-      s >] -> string len s
-| [< 'x; s >] -> string (add_in_buff len x) s;;
-
-(* The lexical analyser repeats the recognized given by next_token:
-   spaces and tabulations are ignored, identifiers, integers,
-   strings, opening and closing square brackets.  Lexical errors are
-   ignored ! *)
-let rec next_token = parser _count
-  [< '' ' | '\t'; tok = next_token >] -> tok
-| [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i
-| [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i
-| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len)
-| [< ''[' >] -> Tlbracket
-| [< '']' >] -> Trbracket
-| [< '_ ; x = next_token >] -> x;;
-
-(* A very simple lexical analyser to recognize a integer value behind 
-   blank characters *)
-
-let rec next_int = parser _count
-  [< '' ' | '\t'; v = next_int >] -> v
-| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] ->
-     (match i with
-        Tint n -> n
-     |  _ -> failwith "unexpected branch in next_int");;
-
-(* This is the actual lexical analyser, implemented as a function on a stream.
-   It will be used with the Stream.from primitive to construct a function
-   of type char Stream.t -> simple_token option Stream.t *)
-let token_stream cs _ =
- try  let tok = next_token cs in
-      Some tok
- with Stream.Failure -> None;;
-
-(* Two of the actions of the parser request that one reads the rest of
-   the input up to a specific string stop_string.  This is done
-   with a function that transform the input_channel into a pair of
-   char Stream.t, reading from the input_channel all the lines to
-   the stop_string first. *)
-
-
-let rec gather_strings stop_string input_channel =
-   let buff = input_line input_channel in
-   if buff = stop_string then
-     []
-   else
-     (buff::(gather_strings stop_string input_channel));;
-
-
-(* the result of this function is supposed to be used in a Stream.from
-   construction. *)
-
-let line_list_to_stream string_list =
-   let count = ref 0 in
-   let buff = ref "" in
-   let reserve = ref string_list in
-   let current_length = ref 0 in
-   (fun i -> if (i - !count) >= !current_length then
-               begin
-                  count := !count + !current_length + 1;
-                  match !reserve with
-		  | [] -> None
-                  | s1::rest -> 
-                    begin
-                      buff := s1;
-                      current_length := String.length !buff;
-		      reserve := rest;
-                      Some '\n'
-                    end
-               end
-             else
-               Some(String.get !buff (i - !count)));;
- 
-
-(* In older revisions of this file you would find a function that
-   does line oriented breakdown of the input channel without resorting to
-   a list of lines.  However, the need for the list of line appeared when
-   we wanted to have  a channel and a list of strings describing the same
-   data, one for regular parsing and the other for error recovery. *)
-
-let channel_to_stream_and_string_list stop_string input_channel =
-   let string_list = gather_strings stop_string input_channel in
-   (line_list_to_stream string_list, string_list);;
-
-let flush_until_end_of_stream char_stream =
- Stream.iter (function _ -> ()) char_stream;;
-
-(* There are only 5 kinds of lines recognized by our little parser.
-   Unrecognized lines are ignored. *)
-type parser_request =
-  | PRINT_VERSION
-  | PARSE_STRING of string
-      (* parse_string <int> [<ident>] then text and && END--OF--DATA *)
-  | QUIET_PARSE_STRING
-      (* quiet_parse_string then text and && END--OF--DATA *)
-  | PARSE_FILE of string
-      (* parse_file <int> <string> *)
-  | ADD_PATH of string
-      (* add_path <int> <string> *)
-  | ADD_REC_PATH of string * string
-      (* add_rec_path <int> <string> <ident> *)
-  | LOAD_SYNTAX of string
-      (* load_syntax_file <int> <ident> *)
-  | GARBAGE
-;;
-
-(* The procedure parser_loop should never terminate while the input_channel is
-   not closed. This procedure receives the functions called for each sentence
-   as arguments.  Thus the code is completely independent from the Coq sources. *)
-let parser_loop functions input_channel =
-  let print_version_action,
-      parse_string_action,
-      quiet_parse_string_action,
-      parse_file_action,
-      add_path_action,
-      add_rec_path_action,
-      load_syntax_action = functions in
-  let rec parser_loop_rec input_channel =
-  (let line = input_line input_channel in
-  let reqid, parser_request = 
-      try 
-      (match Stream.from (token_stream (Stream.of_string line)) with
-        parser
-        | [< 'Tid "print_version" >] ->
-                     0, PRINT_VERSION
-        | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ;
-             'Tid phylum ; 'Trbracket >] 
-                  -> reqid,PARSE_STRING phylum
-        | [< 'Tid "quiet_parse_string" >] ->
-                     0,QUIET_PARSE_STRING
-        | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] ->
-                     reqid, PARSE_FILE fname
-        | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ;  'Tid alias >]
-            -> reqid, ADD_REC_PATH(directory, alias)
-        | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >]
-            -> reqid, ADD_PATH directory
-        | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] ->
-               reqid, LOAD_SYNTAX module_name
-	| [< 'Tid "quit_parser" >] -> raise End_of_file
-        | [< >] -> 0, GARBAGE)
-       with
-         Stream.Failure | Stream.Error _ -> 0,GARBAGE in
-   match parser_request with
-     PRINT_VERSION -> print_version_action ()
-   | PARSE_STRING phylum ->
-     let regular_stream, string_list =
-        channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in
-      parse_string_action reqid phylum (Stream.from regular_stream)
-        string_list;()
-   | QUIET_PARSE_STRING ->
-     let regular_stream, string_list =
-        channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in
-       quiet_parse_string_action
-        (Stream.from regular_stream);()
-   | PARSE_FILE file_name ->
-        parse_file_action reqid file_name
-   | ADD_PATH path -> add_path_action reqid path
-   | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias
-   | LOAD_SYNTAX syn -> load_syntax_action reqid syn
-   | GARBAGE -> ());
-   parser_loop_rec input_channel in
-   parser_loop_rec input_channel;;
diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli
deleted file mode 100644
index b0b043c7..00000000
--- a/contrib/interface/line_parser.mli
+++ /dev/null
@@ -1,5 +0,0 @@
-val parser_loop :
-  (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) *
-  (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) *
-  (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c
-val flush_until_end_of_stream : 'a Stream.t -> unit
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
deleted file mode 100644
index 0dc8f024..00000000
--- a/contrib/interface/name_to_ast.ml
+++ /dev/null
@@ -1,232 +0,0 @@
-open Sign;;
-open Classops;;
-open Names;;
-open Nameops
-open Term;;
-open Impargs;;
-open Reduction;;
-open Libnames;;
-open Libobject;;
-open Environ;;
-open Declarations;;
-open Prettyp;;
-open Inductive;;
-open Util;;
-open Pp;;
-open Declare;;
-open Nametab
-open Vernacexpr;;
-open Decl_kinds;;
-open Constrextern;;
-open Topconstr;;
-
-(* This function converts the parameter binders of an inductive definition,
-   in particular you have to be careful to handle each element in the
-   context containing all previously defined variables.  This squeleton
-   of this procedure is taken from the function print_env in pretty.ml *)
-let convert_env =
-    let convert_binder env (na, b, c) =
-      match b with 
-       | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b)
-       | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in
-    let rec cvrec env = function
-       [] -> []
-     | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in
-    cvrec (Global.env());;
-
-(* let mib string = 
-     let sp = Nametab.sp_of_id CCI (id_of_string string) in
-     let lobj = Lib.map_leaf (objsp_of sp) in
-     let (cmap, _) = outMutualInductive lobj in
-     Listmap.map cmap CCI;; *)
-
-(* This function is directly inspired by print_impl_args in pretty.ml *)
-
-let impl_args_to_string_by_pos = function
-    [] -> None
-  | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.")
-  | l -> Some (" positions " ^
-                (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s)
-                     l
-                     " are implicit."));;
-
-(* This function is directly inspired by implicit_args_id in pretty.ml *)
-
-let impl_args_to_string l = 
-  impl_args_to_string_by_pos (positions_of_implicits l)
-
-let implicit_args_id_to_ast_list id l ast_list = 
-    (match impl_args_to_string l with
-           None -> ast_list
-         | Some(s) -> CommentString s::
-                      CommentString ("For " ^ (string_of_id id))::
-                      ast_list);;
-
-(* This function construct an ast to enumerate the implicit positions for an
-   inductive type and its constructors. It is obtained directly from
-   implicit_args_msg in pretty.ml.  *)
-
-let implicit_args_to_ast_list sp mipv =
-    let implicit_args_descriptions = 
-      let ast_list = ref [] in
-       	(Array.iteri
-           (fun i mip  ->
-	      let imps = implicits_of_global (IndRef (sp, i)) in
-		      (ast_list :=
-	      	implicit_args_id_to_ast_list mip.mind_typename imps !ast_list;
-	      	Array.iteri
-		  (fun j idc ->
-		     let impls = implicits_of_global
-		       (ConstructRef ((sp,i),j+1)) in
-		       ast_list := 
-		       implicit_args_id_to_ast_list idc impls !ast_list)
-		  mip.mind_consnames))
-	  mipv;
-	 !ast_list) in
-      match implicit_args_descriptions with
-	  [] -> []
-	| _ -> [VernacComments (List.rev implicit_args_descriptions)];;
-	      
-(* This function converts constructors for an inductive definition to a
-   Coqast.t.  It is obtained directly from print_constructors in pretty.ml *)
-
-let convert_constructors envpar names types =
-  let array_idC = 
-    array_map2 
-      (fun n t -> 
-	let coercion_flag = false (* arbitrary *) in
-	(coercion_flag, ((dummy_loc,n), extern_constr true envpar t)))
-      names types in
-  Array.to_list array_idC;;
-  
-(* this function converts one inductive type in a possibly multiple inductive
-   definition *)
-
-let convert_one_inductive sp tyi =
-  let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in
-  let env = Global.env () in
-  let envpar = push_rel_context params env in
-  let sp = sp_of_global (IndRef (sp, tyi)) in
-  (((false,(dummy_loc,basename sp)),
-   convert_env(List.rev params),
-   Some (extern_constr true envpar arity), Vernacexpr.Inductive_kw ,
-   Constructors (convert_constructors envpar cstrnames cstrtypes)), None);;
-
-(* This function converts a Mutual inductive definition to a Coqast.t.
-   It is obtained directly from print_mutual in pretty.ml.  However, all
-   references to kinds have been removed and it treats only CCI stuff. *)
-
-let mutual_to_ast_list sp mib =
-  let mipv = (Global.lookup_mind sp).mind_packets in
-  let _, l =
-    Array.fold_right
-      (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in
-  VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), l)
-  :: (implicit_args_to_ast_list sp mipv);;
-
-let constr_to_ast v = 
-  extern_constr true (Global.env()) v;;
-
-let implicits_to_ast_list implicits =
-  match (impl_args_to_string implicits) with
-    | None -> []
-    | Some s -> [VernacComments [CommentString s]];;
-
-let make_variable_ast name typ implicits =
-  (VernacAssumption
-    ((Local,Definitional),false,(*inline flag*)
-     [false,([dummy_loc,name], constr_to_ast typ)]))
-  ::(implicits_to_ast_list implicits);;
-    
-
-let make_definition_ast name c typ implicits =
-  VernacDefinition ((Global,false,Definition), (dummy_loc,name), 
-		   DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)),
-    (fun _ _ -> ()))
-  ::(implicits_to_ast_list implicits);;
-
-(* This function is inspired by print_constant *)
-let constant_to_ast_list kn =
-  let cb = Global.lookup_constant kn in
-  let c = cb.const_body in
-  let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in
-  let l = implicits_of_global (ConstRef kn) in
-  (match c with
-      None -> 
-	make_variable_ast (id_of_label (con_label kn)) typ l
-    | Some c1 ->
-	make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l)
-
-let variable_to_ast_list sp =
-  let (id, c, v) = Global.lookup_named sp in
-  let l = implicits_of_global (VarRef sp) in
-    (match c with
-	 None -> 
-	   make_variable_ast id v l
-       | Some c1 ->
-	   make_definition_ast id c1 v l);;
-
-(* this function is taken from print_inductive in file pretty.ml *)
-
-let inductive_to_ast_list sp =
-  let mib = Global.lookup_mind sp in
-  mutual_to_ast_list sp mib
-
-(* this function is inspired by print_leaf_entry from pretty.ml *)
-
-let leaf_entry_to_ast_list ((sp,kn),lobj) =
-  let tag = object_tag lobj in
-  match tag with
-  | "VARIABLE" -> variable_to_ast_list (basename sp)
-  | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn)
-  | "INDUCTIVE" -> inductive_to_ast_list kn
-  | s -> 
-      errorlabstrm 
-      	"print" (str ("printing of unrecognized object " ^
-		      s ^ " has been required"));;
-
-
-
-
-(* this function is inspired by print_name *)
-let name_to_ast ref =
-  let (loc,qid) = qualid_of_reference ref in
-  let l = 
-    try
-      let sp = Nametab.locate_obj qid in
-      let (sp,lobj) = 
-      	let (sp,entry) =
-          List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None)
-      	in
-	  match entry with
-            | Lib.Leaf obj -> (sp,obj)
-            | _ -> raise Not_found
-      in
-    	leaf_entry_to_ast_list (sp,lobj)
-    with Not_found -> 
-      try 
-    	match Nametab.locate qid with
-	  | ConstRef sp -> constant_to_ast_list sp
-	  | IndRef (sp,_) -> inductive_to_ast_list sp
-	  | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp
-	  | VarRef sp -> variable_to_ast_list sp
-  	with Not_found -> 
-	  try  (* Var locale de but, pas var de section... donc pas d'implicits *)
-	    let dir,name = repr_qualid qid in 
-	      if (repr_dirpath dir) <> [] then raise Not_found;
-	      let (_,c,typ) = Global.lookup_named name in 
-		(match c with
-		     None -> make_variable_ast name typ []
-		   | Some c1 -> make_definition_ast name c1 typ [])
-	  with Not_found ->
-	    try
-	      let _sp = Nametab.locate_syntactic_definition qid in
-		errorlabstrm "print"
-      		  (str "printing of syntax definitions not implemented")
-	    with Not_found ->
-	      errorlabstrm "print"
-		(pr_qualid qid ++
-		 spc () ++ str "not a defined object")
-  in
-  VernacList (List.map (fun x -> (dummy_loc,x)) l)
-
diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli
deleted file mode 100644
index f9e83b5e..00000000
--- a/contrib/interface/name_to_ast.mli
+++ /dev/null
@@ -1,5 +0,0 @@
-val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;;
-val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;;
-val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;;
-val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;;
-val leaf_entry_to_ast_list : (Libnames.section_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;;
diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml
deleted file mode 100644
index 1bbab5fe..00000000
--- a/contrib/interface/parse.ml
+++ /dev/null
@@ -1,422 +0,0 @@
-open Util;;
-open System;;
-open Pp;;
-open Libnames;;
-open Library;;
-open Ascent;;
-open Vtp;;
-open Xlate;;
-open Line_parser;;
-open Pcoq;;
-open Vernacexpr;;
-open Mltop;;
-
-type parsed_tree =
-  | P_cl of ct_COMMAND_LIST
-  | P_c of ct_COMMAND
-  | P_t of ct_TACTIC_COM
-  | P_f of ct_FORMULA
-  | P_id of ct_ID
-  | P_s of ct_STRING
-  | P_i of ct_INT;;
-
-let print_parse_results n msg =
-  Pp.msg
-  ( str "message\nparsed\n" ++
-    int n ++
-    str "\n" ++
-    (match msg with
-     | P_cl x -> fCOMMAND_LIST x
-     | P_c x -> fCOMMAND x
-     | P_t x -> fTACTIC_COM x
-     | P_f x -> fFORMULA x
-     | P_id x -> fID x
-     | P_s x -> fSTRING x
-     | P_i x -> fINT x) ++
-    str "e\nblabla\n");
-  flush stdout;;
-
-let ctf_SyntaxErrorMessage reqid pps =
- fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++
-   int reqid ++ fnl () ++
-   pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();;
-let ctf_SyntaxWarningMessage reqid pps =
-  fnl () ++  str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++
-  int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
-
-let ctf_FileErrorMessage reqid pps =
-  fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++
-  int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++
-  fnl ();;
-
-let execute_when_necessary v =
- (match v with
-  | VernacOpenCloseScope sc -> Vernacentries.interp v
-  | VernacRequire (_,_,l) ->
-      (try 
-	Vernacentries.interp v
-       with _ ->
-	 let l=prlist_with_sep spc pr_reference l in
-	 msgnl (str "Reinterning of " ++ l ++ str " failed"))
-  | VernacRequireFrom (_,_,f) ->
-      (try 
-	Vernacentries.interp v
-       with _ ->
-	 msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed"))
-  | _ -> ()); v;;
-
-let parse_to_dot =
-  let rec dot st = match Stream.next st with
-    | ("", ".") -> ()
-    | ("EOI", "") -> raise End_of_file
-    | _ -> dot st in
-    Gram.Entry.of_parser "Coqtoplevel.dot" dot;;
-
-let rec discard_to_dot stream =
-  try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with
-  | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;;
-
-let rec decompose_string_aux s n =
-    try let index = String.index_from s n '\n' in
-            (String.sub s n (index - n))::
-            (decompose_string_aux s (index + 1))
-    with Not_found -> [String.sub s n ((String.length s) - n)];;
-
-let decompose_string s n =
-  match decompose_string_aux s n with
-      ""::tl -> tl
-    | a -> a;;
-
-let make_string_list file_chan fst_pos snd_pos =
-    let len = (snd_pos - fst_pos) in
-    let s = String.create len in
-    begin
-      seek_in file_chan fst_pos;
-      really_input file_chan s 0 len;
-      decompose_string s 0;
-    end;;
-
-let rec get_sub_aux string_list snd_pos =
-    match string_list with
-      [] -> []
-    | s::l ->
-      let len = String.length s in
-        if len >= snd_pos then
-          if snd_pos < 0 then
-            []
-          else
-            [String.sub s 0 snd_pos]
-        else
-          s::(get_sub_aux l (snd_pos - len - 1));;
-
-let rec get_substring_list string_list fst_pos snd_pos =
-  match string_list with
-    [] -> []
-  | s::l -> 
-    let len = String.length s in
-    if fst_pos > len then
-       get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1)
-    else
-       (* take into account the fact that carriage returns are not in the *)
-       (* strings. *)
-       let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in
-       if snd_pos > len then
-         String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2)::
-         (get_sub_aux l (snd_pos - len - 2))
-       else
-         let gap = (snd_pos - fst_pos2) in
-         if gap < 0 then
-            []
-         else
-            [String.sub s (fst_pos2 - 1) gap];;
-
-(* When parsing a list of commands, we try to recover error messages for
-   each individual command. *)
-
-type parse_result =
-  | ParseOK of Vernacexpr.vernac_expr located option
-  | ParseError of string * string list
-
-let embed_string s =
-  CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s))
-
-let make_parse_error_item s l =
-  CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l))
-
-let parse_command_list reqid stream string_list =
-    let rec parse_whole_stream () =
-    let this_pos = Stream.count stream in
-    let first_ast = 
-        try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream))
-        with
-        | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> 
-          begin
-             msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e));
-             try
-                discard_to_dot stream;
-                msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++
-		       int (Stream.count stream));
-		ParseError ("PARSING_ERROR",
-                  get_substring_list string_list this_pos
-		    (Stream.count stream))
-             with End_of_file -> ParseOK None
-           end
-        | e-> 
-          begin
-            discard_to_dot stream;
-	    ParseError ("PARSING_ERROR2",
-	      get_substring_list string_list this_pos (Stream.count stream))
-          end in
-    match first_ast with
-    | ParseOK (Some (loc,ast)) ->
-        let _ast0 = (execute_when_necessary ast) in
-          (try xlate_vernac ast
-	  with e ->
-	    make_parse_error_item "PARSING_ERROR2" 
-		     (get_substring_list string_list this_pos
-		       (Stream.count stream)))::parse_whole_stream()
-    | ParseOK None -> []
-    | ParseError (s,l) -> 
-	(make_parse_error_item s l)::parse_whole_stream()
- in
-    match parse_whole_stream () with
-    | first_one::tail -> (P_cl (CT_command_list(first_one, tail)))
-    | [] -> raise (UserError ("parse_string", (str "empty text.")));;
-
-(*When parsing a string using a phylum, the string is first transformed
-  into a Coq Ast using the regular Coq parser, then it is transformed into
-  the right ascent term using xlate functions, then it is transformed into
-  a stream, using the right vtp function. There is a special case for commands,
-  since some of these must be executed!*)
-let parse_string_action reqid phylum char_stream string_list =
- try let msg =
-      match phylum with
-      | "COMMAND_LIST" ->
-        parse_command_list reqid char_stream string_list
-      | "COMMAND" ->
-       P_c
-        (xlate_vernac
-        (execute_when_necessary
-        (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream))))
-      | "TACTIC_COM" ->
-       P_t
-        (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi 
-                         (Gram.parsable char_stream)))
-      | "FORMULA" ->
-       P_f
-        (xlate_formula
-	   (Gram.Entry.parse 
-              (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream)))
-      | "ID" -> P_id (CT_ident
-                        (Libnames.string_of_qualid 
-			 (snd 
-			       (Gram.Entry.parse  (Pcoq.eoi_entry Pcoq.Prim.qualid)
-						 (Gram.parsable char_stream)))))
-      | "STRING" ->
-	  P_s
-         (CT_string (Gram.Entry.parse Pcoq.Prim.string 
-                  (Gram.parsable char_stream)))
-      | "INT" ->
-	  P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural
-                              (Gram.parsable char_stream)))
-      | _ -> error "parse_string_action : bad phylum" in
-      print_parse_results reqid msg
- with
- | Stdpp.Exc_located(l,Match_failure(_,_,_)) ->
-    flush_until_end_of_stream char_stream;
-    msgnl (ctf_SyntaxErrorMessage reqid
-              (Cerrors.explain_exn 
-                 (Stdpp.Exc_located(l,Stream.Error "match failure"))))
- | e ->
-    flush_until_end_of_stream char_stream;
-    msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));;
-
-
-let quiet_parse_string_action char_stream =
- try let _ = 
-         Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in
-     ()
- with
- | _ -> flush_until_end_of_stream char_stream; ();;
-
-
-let parse_file_action reqid file_name =
- try let file_chan = open_in file_name in
-     (* file_chan_err, stream_err are the channel and stream  used to 
-        get the text when a syntax error occurs *)
-     let file_chan_err = open_in file_name in 
-     let stream = Stream.of_channel file_chan in
-     let _stream_err = Stream.of_channel file_chan_err in
-     let rec discard_to_dot () =
-       try Gram.Entry.parse parse_to_dot (Gram.parsable stream)
-       with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in
-       match let rec parse_whole_file () =
-	 let this_pos = Stream.count stream in
-           match 
-             try
-	       ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream))
-             with
-               | Stdpp.Exc_located(l,Stream.Error txt) -> 
-                   msgnl (ctf_SyntaxWarningMessage reqid
-			    (str "Error with file" ++ spc () ++
-			     str file_name ++ fnl () ++
-			     Cerrors.explain_exn 
-				 (Stdpp.Exc_located(l,Stream.Error txt))));
-		   (try 
-		      begin
-                      	discard_to_dot ();
-                    	ParseError ("PARSING_ERROR",
-				   (make_string_list file_chan_err this_pos 
-			       	      (Stream.count stream)))
-		      end
-                    with End_of_file -> ParseOK None)
-               | e ->
-                   begin
-                     Gram.Entry.parse parse_to_dot (Gram.parsable stream);
-                     ParseError ("PARSING_ERROR2",
-			       (make_string_list file_chan this_pos
-				  (Stream.count stream)))
-                   end
-		   
-             with
-               | ParseOK (Some (_,ast)) ->
-		   let _ast0=(execute_when_necessary ast) in 
-		   let term =
-                     (try xlate_vernac ast
-		      with e ->
-                    	print_string ("translation error between " ^
-				      (string_of_int this_pos) ^
-				      " " ^
-				      (string_of_int (Stream.count stream)) ^
-				      "\n");
-			make_parse_error_item "PARSING_ERROR2"
-			  (make_string_list file_chan_err this_pos
-			    (Stream.count stream))) in 
-		     term::parse_whole_file ()
-               | ParseOK None -> []
-	       | ParseError (s,l) -> 
-		   (make_parse_error_item s l)::parse_whole_file () in
-         parse_whole_file () with
-	   | first_one :: tail ->
-	       print_parse_results reqid
-		 (P_cl (CT_command_list (first_one, tail)))
-	   | [] -> raise (UserError ("parse_file_action", str "empty file."))
-       with
-	 | Stdpp.Exc_located(l,Match_failure(_,_,_)) ->
-	     msgnl
-	       (ctf_SyntaxErrorMessage reqid
-		  (str "Error with file" ++ spc () ++ str file_name ++ 
-		   fnl () ++
-		     Cerrors.explain_exn
-		       (Stdpp.Exc_located(l,Stream.Error "match failure"))))
-	 | e ->
-	     msgnl
-	       (ctf_SyntaxErrorMessage reqid
-		  (str "Error with file" ++ spc () ++ str file_name ++
-		   fnl () ++ Cerrors.explain_exn e));;
-
-let add_rec_path_action reqid string_arg ident_arg =
-  let directory_name = expand_path_macros string_arg in
-    begin
-      add_rec_path directory_name (Libnames.dirpath_of_string ident_arg)
-    end;;
-	
-
-let add_path_action reqid string_arg =
-  let directory_name = expand_path_macros string_arg in
-    begin
-      add_path directory_name Names.empty_dirpath
-    end;;
-
-let print_version_action () =
-  msgnl (mt ());
-  msgnl (str "$Id: parse.ml 11749 2009-01-05 14:01:04Z notin $");;
-
-let load_syntax_action reqid module_name =
- msg (str "loading " ++ str module_name ++ str "... ");
- try
-      (let qid = Libnames.make_short_qualid (Names.id_of_string module_name) in
-      require_library [dummy_loc,qid] None;
-      msg (str "opening... ");
-      Declaremods.import_module false (Nametab.locate_module qid); 
-      msgnl (str "done" ++ fnl ());
-      ())
- with
- | UserError (label, pp_stream) ->
- (*This one may be necessary to make sure that the message won't be indented *)
- msgnl (mt ());
- msgnl
-  (fnl () ++ str "error while loading syntax module " ++ str module_name ++
-   str ": " ++ str label ++ fnl () ++ pp_stream)
- | e ->
-  msgnl (mt ());
-  msgnl
-   (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++
-    int reqid ++ fnl ());
-  ();;
-
-let coqparser_loop inchan =
- (parser_loop : (unit -> unit) *
-                (int -> string -> char Stream.t -> string list -> unit) *
-                (char Stream.t -> unit) * (int -> string -> unit) *
-                (int -> string -> unit) * (int -> string -> string -> unit) *
-                (int -> string -> unit) -> in_channel -> unit)
- (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action,
- add_path_action, add_rec_path_action, load_syntax_action) inchan;;
-
-if !Sys.interactive then ()
- else 
-Libobject.relax true;
-(let coqdir = 
-   try Sys.getenv "COQDIR"
-   with Not_found -> 
-     let coqdir = Envars.coqlib () in
-       if Sys.file_exists coqdir then
-	 coqdir
-       else
-	 (msgnl (str "could not find the value of COQDIR"); exit 1) in
-     begin
-       add_rec_path (Filename.concat coqdir "theories")
-	 (Names.make_dirpath [Nameops.coq_root]);
-       add_rec_path (Filename.concat coqdir "contrib")
-	 (Names.make_dirpath [Nameops.coq_root])
-     end;
-(let vernacrc =
-   try
-     Sys.getenv "VERNACRC"
-   with
-       Not_found -> 
-	 List.fold_left 
-	   (fun s1 s2 -> (Filename.concat s1 s2))
-	   coqdir [ "contrib"; "interface"; "vernacrc"] in
-   try
-     (Gramext.warning_verbose := false;
-      coqparser_loop (open_in vernacrc))
-   with
-     | End_of_file -> ()
-     | e ->
-	 (msgnl (Cerrors.explain_exn e);
-	  msgnl (str "could not load the VERNACRC file"));
-	 try
-	   msgnl (str vernacrc)
-	 with
-	     e -> ());
-(try let user_vernacrc =
-   try Some(Sys.getenv "USERVERNACRC")
-   with
-     | Not_found ->
-	 msgnl (str "no .vernacrc file"); None in
-   (match user_vernacrc with
-      	Some f -> coqparser_loop (open_in f)
-      | None -> ())
- with
-   | End_of_file -> ()
-   | e ->
-       msgnl (Cerrors.explain_exn e);
-       msgnl (str "error in your .vernacrc file"));
-msgnl (str "Starting Centaur Specialized Parser Loop");
-try
-  coqparser_loop stdin
-with 
-  | End_of_file -> ()
-  | e -> msgnl(Cerrors.explain_exn e))
diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml
deleted file mode 100644
index a157ca92..00000000
--- a/contrib/interface/paths.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-let int_list_to_string s l =
-    List.fold_left 
-       (fun s -> (fun v -> s ^ " " ^ (string_of_int v)))
-       s
-       l;;
-
-(* Given two paths, this function returns the longest common prefix and the
-   two suffixes. *)
-let rec decompose_path
-     : (int list * int list) -> (int list * int list * int list) =
-   function
-       (a::l,b::m) when a = b ->
-         let (c,p1,p2) = decompose_path (l,m) in
-         (a::c,p1,p2)
-     |  p1,p2 -> [], p1, p2;;
-
-let rec is_prefix p1 p2 = match p1,p2 with
-  [], _ -> true
-| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2
-| _ -> false;;
-
-let rec lex_smaller p1 p2 = match p1,p2 with
-  [], _ -> true
-| a::tl1, b::tl2 when a < b -> true
-| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2
-| _ -> false;;
diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli
deleted file mode 100644
index 26620723..00000000
--- a/contrib/interface/paths.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-val decompose_path : (int list * int list) -> (int list * int list * int list);;
-val int_list_to_string : string -> int list -> string;;
-val is_prefix : int list -> int list -> bool;;
-val lex_smaller : int list -> int list -> bool;;
diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml
deleted file mode 100644
index 01747aa5..00000000
--- a/contrib/interface/pbp.ml
+++ /dev/null
@@ -1,758 +0,0 @@
-(* A proof by pointing algorithm. *)
-open Util;;
-open Names;;
-open Term;;
-open Tactics;;
-open Tacticals;;
-open Hipattern;;
-open Pattern;;
-open Matching;;
-open Reduction;;
-open Rawterm;;
-open Environ;;
-
-open Proof_trees;;
-open Proof_type;;
-open Tacmach;;
-open Tacexpr;;
-open Typing;;
-open Pp;;
-open Libnames;;
-open Genarg;;
-open Topconstr;;
-open Termops;;
-
-let zz = Util.dummy_loc;;
-
-let hyp_radix = id_of_string "H";;
-
-let next_global_ident = next_global_ident_away true
-
-(* get_hyp_by_name : goal sigma -> string -> constr,
-   looks up for an hypothesis (or a global constant), from its name *)
-let get_hyp_by_name g name =
-  let evd = project g in
-  let env = pf_env g in
-  try (let judgment = 
-         Pretyping.Default.understand_judgment 
-          evd env (RVar(zz, name)) in
-       ("hyp",judgment.uj_type))
-(* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up...
-   Loïc *)
-  with _ -> (let c = Nametab.global (Ident (zz,name)) in
-             ("cste",type_of (Global.env()) Evd.empty (constr_of_global c)))
-;;
-
-type pbp_atom =
-  | PbpTryAssumption of identifier option
-  | PbpTryClear of identifier list
-  | PbpGeneralize of identifier * identifier list
-  | PbpLApply of identifier (* = CutAndApply *)
-  | PbpIntros of intro_pattern_expr located list
-  | PbpSplit
-  (* Existential *)
-  | PbpExists of identifier
-  (* Or *)
-  | PbpLeft
-  | PbpRight
-  (* Head *)
-  | PbpApply of identifier
-  | PbpElim of identifier * identifier list;;
-
-(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics
-   [a1]..[an-1] are atomic (or try of an atomic) tactic and produce
-   exactly one goal, and [an] produces exactly p subgoals
-
-   In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and
-   produces exactly one subgoal, except the last one which may complete the
-   goal
-
-   Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion
-   from atomic to composed tactic
-*)
-
-type pbp_sequence =
-  | PbpThens of pbp_atom list * pbp_sequence list
-  | PbpThen of pbp_atom list
-
-(* This flattens sequences of tactics producing just one subgoal *)
-let chain_tactics tl1 = function
-  | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3)
-  | PbpThen tl2 -> PbpThen (tl1@tl2)
-
-type pbp_rule = (identifier list *
-                    identifier list *
-                    bool *
-                    identifier option *
-                    (types, constr) kind_of_term *
-                    int list *
-                    (identifier list ->
-                     identifier list ->
-                     bool ->
-                       identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) ->
-                    pbp_sequence option;;
-
-
-let make_named_intro id = PbpIntros [zz,IntroIdentifier id];;
-
-let make_clears str_list = PbpThen [PbpTryClear str_list]
-
-let add_clear_names_if_necessary tactic clear_names =
-    match clear_names with
-      [] -> tactic
-    | l -> chain_tactics [PbpTryClear l] tactic;;
-
-let make_final_cmd f optname clear_names constr path =
-    add_clear_names_if_necessary (f optname constr path) clear_names;;
-
-let (rem_cast:pbp_rule) = function
-    (a,c,cf,o, Cast(f,_,_), p, func) ->
-      Some(func a c cf o (kind_of_term f) p)
-  | _ -> None;;
-
-let (forall_intro: pbp_rule) = function
-  (avoid,
-   clear_names,
-   clear_flag,
-   None,
-   Prod(Name x, _, body),
-   (2::path),
-   f) ->
-     let x' = next_global_ident x avoid in
-      Some(chain_tactics [make_named_intro x']
-	      (f (x'::avoid)
-		clear_names clear_flag None (kind_of_term body) path))
-| _ -> None;;
-
-let (imply_intro2: pbp_rule) = function
-  avoid, clear_names,
-  clear_flag, None, Prod(Anonymous, _, body), 2::path, f ->
-   let h' = next_global_ident hyp_radix avoid in
-     Some(chain_tactics [make_named_intro h']
-          (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path))
-  | _ -> None;;
-
-      
-(*
-let (imply_intro1: pbp_rule) = function
-  avoid, clear_names,
-  clear_flag, None, Prod(Anonymous, prem, body), 1::path, f ->
-   let h' = next_global_ident hyp_radix avoid in
-   let str_h' = h' in
-     Some(chain_tactics [make_named_intro str_h']
-            (f (h'::avoid) clear_names clear_flag (Some str_h') 
-		(kind_of_term prem) path))
-  | _ -> None;;
-*)
-
-let make_var id = CRef (Ident(zz, id))
-
-let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l)
-
-let make_pbp_pattern x =
-  make_app (make_var (id_of_string "PBP_META"))
-     [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))]
-
-let rec make_then = function
-  | [] -> TacId []
-  | [t] -> t
-  | t1::t2::l -> make_then (TacThen (t1,[||],t2,[||])::l)
-
-let make_pbp_atomic_tactic = function
-  | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption))
-  | PbpTryAssumption (Some a) ->
-      TacTry (TacAtom (zz, TacExact (make_var a)))
-  | PbpExists x -> 
-      TacAtom (zz, TacSplit (false,true,ImplicitBindings [make_pbp_pattern x]))
-  | PbpGeneralize (h,args) ->
-      let l = List.map make_pbp_pattern args in
-      TacAtom (zz, TacGeneralize [((true,[]),make_app (make_var h) l),Anonymous])
-  | PbpLeft -> TacAtom (zz, TacLeft (false,NoBindings))
-  | PbpRight -> TacAtom (zz, TacRight (false,NoBindings))
-  | PbpIntros l -> TacAtom (zz, TacIntroPattern l)
-  | PbpLApply h -> TacAtom (zz, TacLApply (make_var h))
-  | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings],None))
-  | PbpElim (hyp_name, names) ->
-      let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in
-      TacAtom
-	(zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None))
-  | PbpTryClear l -> 
-      TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l)))
-  | PbpSplit -> TacAtom (zz, TacSplit (false,false,NoBindings));;
-
-let rec make_pbp_tactic = function
-  | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl)
-  | PbpThens (l,tl) ->
-      TacThens
-        (make_then (List.map make_pbp_atomic_tactic l),
-	 List.map make_pbp_tactic tl)
-
-let (forall_elim: pbp_rule) = function
-  avoid, clear_names, clear_flag, 
-  Some h, Prod(Name x, _, body), 2::path, f ->
-  let h' = next_global_ident hyp_radix avoid in
-  let clear_names' = if clear_flag then h::clear_names else clear_names in
-    Some
-     (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h']
-        (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path))
-  | _ -> None;;
-
-
-let (imply_elim1: pbp_rule) = function
-  avoid, clear_names, clear_flag,
-  Some h, Prod(Anonymous, prem, body), 1::path, f ->
-  let clear_names' = if clear_flag then h::clear_names else clear_names in
-  let h' = next_global_ident hyp_radix avoid in
-  let _str_h' = (string_of_id h') in
-  Some(PbpThens
-	  ([PbpLApply h],
-	   [chain_tactics [make_named_intro h'] (make_clears (h::clear_names));
-	    f avoid clear_names' false None (kind_of_term prem) path]))
-  | _ -> None;;
-
-
-let (imply_elim2: pbp_rule) = function
-  avoid, clear_names, clear_flag,
-  Some h, Prod(Anonymous, prem, body), 2::path, f ->
-  let clear_names' = if clear_flag then h::clear_names else clear_names in
-  let h' = next_global_ident hyp_radix avoid in
-  Some(PbpThens
-	 ([PbpLApply h],
-          [chain_tactics [make_named_intro h']
-              (f (h'::avoid) clear_names' false (Some h') 
-		      (kind_of_term body) path);
-           make_clears clear_names]))
-  | _ -> None;;
-
-let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s
-
-let constant dir s =  Coqlib.gen_constant "Pbp" ("Init"::dir) s
-
-let andconstr: unit -> constr = Coqlib.build_coq_and;;
-let prodconstr () = constant ["Datatypes"] "prod";;
-let exconstr = Coqlib.build_coq_ex;;
-let sigconstr () = constant ["Specif"] "sig";;
-let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;;
-let orconstr = Coqlib.build_coq_or;;
-let sumboolconstr = Coqlib.build_coq_sumbool;;
-let sumconstr() = constant ["Datatypes"] "sum";;
-let notconstr = Coqlib.build_coq_not;;
-let notTconstr () = constant ["Logic_Type"] "notT";;
-
-let is_matching_local a b = is_matching (pattern_of_constr a) b;;
-
-let rec (or_and_tree_to_intro_pattern: identifier list -> 
-	   constr -> int list -> 
-	     intro_pattern_expr * identifier list * identifier *constr
-	     * int list * int * int) =
-fun avoid c path -> match kind_of_term c, path with
-  | (App(oper, [|c1; c2|]), 2::a::path)
-    when ((is_matching_local (andconstr()) oper) or
-	  (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) ->
-      let id2 = next_global_ident hyp_radix avoid in
-      let cont_expr = if a = 1 then c1 else c2 in
-      let cont_patt, avoid_names, id, c, path, rank, total_branches = 
-	or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in
-      let patt_list = 
-	if a = 1 then
-	  [zz,cont_patt; zz,IntroIdentifier id2]
-	else
-	  [zz,IntroIdentifier id2; zz,cont_patt] in
-      	(IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, 
-	 total_branches)
-  | (App(oper, [|c1; c2|]), 2::3::path)
-    when ((is_matching_local (exconstr()) oper) or
-	  (is_matching_local (sigconstr()) oper)) ->
-      (match (kind_of_term c2) with 
-	   Lambda (Name x, _, body) ->
-	     let id1 = next_global_ident x avoid in
-	     let cont_patt, avoid_names, id, c, path, rank, total_branches =
-	       or_and_tree_to_intro_pattern (id1::avoid) body path in
-	     (IntroOrAndPattern[[zz,IntroIdentifier id1; zz,cont_patt]],
-	      avoid_names, id, c, path, rank, total_branches)
-	 | _ -> assert false)
-  | (App(oper, [|c1; c2|]), 2::a::path)
-      when ((is_matching_local (orconstr ()) oper) or
-            (is_matching_local (sumboolconstr ()) oper) or
-	    (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) ->
-      let id2 = next_global_ident hyp_radix avoid in
-      let cont_expr = if a = 1 then c1 else c2 in
-      let cont_patt, avoid_names, id, c, path, rank, total_branches =
- 	or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in
-      let new_rank = if a = 1 then rank else rank+1 in
-      let patt_list =
-	if a = 1 then
-	  [[zz,cont_patt];[zz,IntroIdentifier id2]]
-	else
-	  [[zz,IntroIdentifier id2];[zz,cont_patt]] in
-	(IntroOrAndPattern patt_list, 
-	 avoid_names, id, c, path, new_rank, total_branches+1)
-  | (_, path) -> let id = next_global_ident hyp_radix avoid in
-      (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);;
-
-let auxiliary_goals clear_names clear_flag this_name n_aux others =
-  let clear_cmd = 
-    make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in
-  let rec clear_list = function
-      0 -> others
-    | n -> clear_cmd::(clear_list (n - 1)) in
-  clear_list n_aux;;
-
-
-let (imply_intro3: pbp_rule) = function
-    avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body),
-    1::path, f ->
-      let intro_patt, avoid_names, id, c, p, rank, total_branches =
-	or_and_tree_to_intro_pattern avoid prem path in
-	if total_branches = 1 then
-	  Some(chain_tactics [PbpIntros [zz,intro_patt]]
-		 (f avoid_names clear_names clear_flag (Some id)
-		    (kind_of_term c) path))
-	else
-	  Some
-	    (PbpThens
-	       ([PbpIntros [zz,intro_patt]],
-	    	auxiliary_goals clear_names clear_flag id
-		  (rank - 1)
-		  ((f avoid_names clear_names clear_flag (Some id)
-		      (kind_of_term c) path)::
-		     auxiliary_goals clear_names clear_flag id 
-		     (total_branches - rank) [])))
-  | _ -> None;;
-		 
-
-
-let (and_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag,
-    None, App(and_oper, [|c1; c2|]), 2::a::path, f 
-      ->
-      if ((is_matching_local (andconstr()) and_oper) or
-          (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then
-      	let cont_term = if a = 1 then c1 else c2 in
-      	let cont_cmd = f avoid clear_names false None 
-			 (kind_of_term cont_term) path in
-      	let clear_cmd = make_clears clear_names in
-      	let cmds =
-            (if a = 1 
-	    then [cont_cmd;clear_cmd] 
-	    else [clear_cmd;cont_cmd]) in
-      	Some (PbpThens ([PbpSplit],cmds))
-      else None
-  | _ -> None;;
-
-let exists_from_lambda avoid clear_names clear_flag c2 path f =
-  match kind_of_term c2 with
-    Lambda(Name x, _, body) -> 
-      Some (PbpThens ([PbpExists x],
-		      [f avoid clear_names false None (kind_of_term body) path]))
-  | _ -> None;;
-
-
-let (ex_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(oper, [| c1; c2|]), 2::3::path, f
-      when (is_matching_local (exconstr ()) oper)
- 	or (is_matching_local (sigconstr ()) oper) ->
-	  exists_from_lambda avoid clear_names clear_flag c2 path f
-  | _ -> None;;
-
-let (exT_intro : pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(oper, [| c1; c2|]), 2::2::2::path, f
-      when (is_matching_local (sigTconstr ()) oper) ->
-	exists_from_lambda avoid clear_names clear_flag c2 path f
-  | _ -> None;;
-
-let (or_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(or_oper, [|c1; c2 |]), 2::a::path, f ->
-      if ((is_matching_local (orconstr ()) or_oper) or
-        (is_matching_local (sumboolconstr ()) or_oper) or 
-	(is_matching_local (sumconstr ()) or_oper))
-	  & (a = 1 or a = 2) then
-	let cont_term = if a = 1 then c1 else c2 in
-	let fst_cmd = if a = 1 then PbpLeft else PbpRight in
-	let cont_cmd = f avoid clear_names false None 
-			 (kind_of_term cont_term) path in
-	Some(chain_tactics [fst_cmd] cont_cmd)
-      else
-	None
-  | _ -> None;;
-	
-let dummy_id = id_of_string "Dummy";;
-
-let (not_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(not_oper, [|c1|]), 2::1::path, f ->
-      if(is_matching_local (notconstr ()) not_oper) or 
-	(is_matching_local (notTconstr ()) not_oper) then
-	let h' = next_global_ident hyp_radix avoid in
-	Some(chain_tactics [make_named_intro h']
-	       (f (h'::avoid) clear_names false (Some h') 
-		  (kind_of_term c1) path))
-      else
- 	None
-  | _ -> None;;
-
-
-
-
-let elim_with_bindings hyp_name names =
-  PbpElim (hyp_name, names);;
-
-(* This function is used to follow down a path, while staying on the spine of
-   successive products (universal quantifications or implications).
-   Arguments are the current observed constr object and the path that remains
-   to be followed, and an integer indicating how many products have already been
-   crossed.
-   Result is:
-     - a list of string indicating the names of universally quantified variables.
-     - a list of integers indicating the positions of the successive 
-       universally quantified variables.
-     - an integer indicating the number of non-dependent products.
-     - the last constr object encountered during the walk down, and
-     - the remaining path.
-
-   For instance the following session should happen:
-  let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign()))
-     (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in
-     down_prods (tt, [2;2;2], 0)
-  ---> ["P","x"],[0;1], 1, <<(P x)>>, []
-*)
-
-
-let rec down_prods: (types, constr) kind_of_term * (int list) * int -> 
-           identifier list * (int list) * int * (types, constr) kind_of_term *
-  (int list) = 
-   function
-     Prod(Name x, _, body), 2::path, k ->
-	let res_sl, res_il, res_i, res_cstr, res_p 
-	    = down_prods (kind_of_term body, path, k+1) in
-	x::res_sl, (k::res_il), res_i, res_cstr, res_p
-   | Prod(Anonymous, _, body), 2::path, k ->
-        let res_sl, res_il, res_i, res_cstr, res_p 
-	    = down_prods (kind_of_term body, path, k+1) in
-	res_sl, res_il, res_i+1, res_cstr, res_p
-   | cstr, path, _ -> [], [], 0, cstr, path;;
-
-exception Pbp_internal of int list;;
-
-(* This function should be usable to check that a type can be used by the
-   Apply command.  Basically, c is supposed to be the head of some
-   type, where l gives the ranks of all universally quantified variables.
-   It check that these universally quantified variables occur in the head.
-
-   The knowledge I have on constr structures is incomplete.
-*)
-let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = 
-   function c -> function l ->
-   let rec delete n = function
-     | [] -> []
-     | p::tl -> if n = p then tl else p::(delete n tl) in
-   let rec check_rec l = function
-   | App(f, array) ->
-       Array.fold_left (fun l c -> check_rec l (kind_of_term c))
-	 (check_rec l (kind_of_term f)) array
-   | Const _ -> l
-   | Ind _ -> l
-   | Construct _ -> l
-   | Var _ -> l
-   | Rel p ->
-       let result = delete p l in
-       if result = [] then
-	 raise (Pbp_internal [])
-       else
-	 result
-   | _ -> raise (Pbp_internal l) in
-   try 
-     (check_rec l c) = []
-   with Pbp_internal l -> l = [];;
-
-let (mk_db_indices: int list -> int -> int list) =
-  function int_list -> function nprems ->
-   let total = (List.length int_list) + nprems  in
-   let rec mk_db_aux = function
-     [] -> []
-   | a::l -> (total - a)::(mk_db_aux l) in
-   mk_db_aux int_list;;
-     
-
-(* This proof-by-pointing rule is quite complicated, as it attempts to foresee
-   usages of head tactics.  A first operation is to follow the path as far
-   as possible while staying on the spine of products (function down_prods)
-   and then to check whether the next step will be an elim step.  If the 
-   answer is true, then the built command takes advantage of the power of
-   head tactics.  *)
-
-let (head_tactic_patt: pbp_rule) = function
-    avoid, clear_names, clear_flag, Some h, cstr, path, f ->
-    (match down_prods (cstr, path, 0) with
-    | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path)
-      when (((is_matching_local (exconstr ()) oper) (* or
-	      (is_matching_local (sigconstr ()) oper) *))  && a = 3) ->
-		   (match (kind_of_term c2) with
-		     Lambda(Name x, _,body) ->
-		       Some(PbpThens
-		    		 ([elim_with_bindings h str_list],
-				   let x' = next_global_ident x avoid in
-				   let cont_body =
-				     Prod(Name x', c1,
-					    mkProd(Anonymous, body, 
-						   mkVar(dummy_id))) in
-				   let cont_tac 
-				       = f avoid (h::clear_names) false None
-				       cont_body (2::1::path) in
-				   cont_tac::(auxiliary_goals
-						       clear_names clear_flag
-						       h nprems [])))
-		     | _ -> None)
-    | (str_list, _, nprems, 
-       App(oper,[|c1|]), 2::1::path) 
-      	when
- 	  (is_matching_local (notconstr ()) oper) or
- 	  (is_matching_local (notTconstr ()) oper) ->
-	 Some(chain_tactics [elim_with_bindings h str_list]
-		 (f avoid clear_names false None (kind_of_term c1) path))
-    | (str_list, _, nprems, 
-       App(oper, [|c1; c2|]), 2::a::path) 
-      when ((is_matching_local (andconstr()) oper) or
-	    (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) ->
-	let h1 = next_global_ident hyp_radix avoid in
-	let h2 = next_global_ident hyp_radix (h1::avoid) in
-	Some(PbpThens
-                  ([elim_with_bindings h str_list],
-		    let cont_body = 
-		      if a = 1 then c1 else c2 in
-		    let cont_tac = 
-		      f (h2::h1::avoid) (h::clear_names) 
-                        false (Some (if 1 = a then h1 else h2))
-                        (kind_of_term cont_body) path in
-		      (chain_tactics 
-			 [make_named_intro h1; make_named_intro h2]
-			 cont_tac)::
-	       (auxiliary_goals clear_names clear_flag h nprems [])))
-    | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path)
-      when ((is_matching_local (sigTconstr()) oper)) & a = 2 ->
-		   (match (kind_of_term c2),path with
-		     Lambda(Name x, _,body), (2::path) ->
-		       Some(PbpThens
-		    		 ([elim_with_bindings h str_list],
-				   let x' = next_global_ident x avoid in
-				   let cont_body =
-				     Prod(Name x', c1,
-					    mkProd(Anonymous, body, 
-						   mkVar(dummy_id))) in
-				   let cont_tac 
-				       = f avoid (h::clear_names) false None
-				       cont_body (2::1::path) in
-				   cont_tac::(auxiliary_goals
-						       clear_names clear_flag
-						       h nprems [])))
-		     | _ -> None)
-    | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path)
-	when ((is_matching_local (orconstr ()) oper) or
-              (is_matching_local (sumboolconstr ()) oper) or
-	      (is_matching_local (sumconstr ()) oper)) &
-                (a = 1 or a = 2) ->
-	  Some(PbpThens
-		    ([elim_with_bindings h str_list],
-		      let cont_body =
-			if a = 1 then c1 else c2 in
-                      (* h' is the name for the new intro *)
-		      let h' = next_global_ident hyp_radix avoid in
-		      let cont_tac =
-                        chain_tactics 
-			  [make_named_intro h']
-			  (f 
-			     (* h' should not be used again *)
-			     (h'::avoid)
-			     (* the disjunct itself can be discarded *)
-			     (h::clear_names) false (Some h')
-                             (kind_of_term cont_body) path) in
-		      let snd_tac = 
-			chain_tactics
-			   [make_named_intro h']
-			   (make_clears (h::clear_names)) in
-		      let tacs1 = 
-			if a = 1 then
-			  [cont_tac; snd_tac]
-		      	else
-			  [snd_tac; cont_tac] in
-		      tacs1@(auxiliary_goals (h::clear_names)
-				   false dummy_id nprems [])))
-    | (str_list, int_list, nprems, c, []) 
-        when  (check_apply c (mk_db_indices int_list nprems)) &
-              (match c with Prod(_,_,_) -> false
-              |  _ -> true) &
-              (List.length int_list) + nprems > 0 ->
-          Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names)
-    | _ -> None)
-  | _ -> None;;
-      
-
-let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2;
-                      forall_elim; imply_intro3; imply_elim1; imply_elim2;
-		      and_intro; or_intro; not_intro; ex_intro; exT_intro];;
-
-
-let try_trace = ref true;;
-
-let traced_try (f1:tactic) g =
-    try (try_trace := true; tclPROGRESS f1 g)
-    with e when Logic.catchable_exception e ->
-      (try_trace := false; tclIDTAC g);;
-
-let traced_try_entry = function
-     [Tacexp t] ->
-           traced_try (Tacinterp.interp t)
-  |  _ -> failwith "traced_try_entry received wrong arguments";;
-
-
-(* When the recursive descent along the path is over, one includes the
-   command requested by the point-and-shoot strategy.  Default is
-   Try Assumption--Try Exact.  *)
-
-
-let default_ast optname constr path = PbpThen [PbpTryAssumption optname]
-
-(* This is the main proof by pointing function. *)
-(* avoid: les noms a ne pas utiliser *)
-(* final_cmd: la fonction appelee par defaut *)
-(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *)
-
-let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path =
-  let rec try_all_rules rl =
-      match rl with 
-         f::tl ->
-           (match f (avoid, clear_names, clear_flag,
-                     opt_name, constr, path, pbpt final_cmd) with
-              Some(ast) -> ast
-            | None -> try_all_rules tl)
-      |	 [] -> make_final_cmd final_cmd opt_name clear_names constr path
-  in try_all_rules (!pbp_rules);;
-
-(* these are the optimisation functions. *)
-(* This function takes care of flattening successive then commands. *)
-
-
-(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy
-    that t is some [PbpAtom t] *)
-
-(* This optimization function takes care of compacting successive Intro commands
-   together. *)
-
-let rec group_intros names = function
-    [] -> (match names with
-        [] -> []
-      | l -> [PbpIntros l])
-  | (PbpIntros ids)::others -> group_intros (names@ids) others
-  | t1::others ->
-      (match names with
-	  [] -> t1::(group_intros [] others)
-	| l -> (PbpIntros l)::t1::(group_intros [] others))
-
-let rec optim2 = function
-  | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2)
-  | PbpThen tl -> PbpThen (group_intros [] tl)
-
-
-let rec cleanup_clears str_list = function
-    [] -> []
-  | x::tail ->
-      if List.mem x str_list then cleanup_clears str_list tail
-      else x::(cleanup_clears str_list tail);;
-
-(* This function takes care of compacting instanciations of universal
-   quantifications. *)
-
-let rec optim3_aux str_list = function
-    (PbpGeneralize (h,l1))::
-    (PbpIntros [zz,IntroIdentifier s])::(PbpGeneralize (h',l2))::others
-      when s=h' ->
-      optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others)
-  | (PbpTryClear names)::other ->
-      (match cleanup_clears str_list names with
-	  [] -> other
-	| l -> (PbpTryClear l)::other)
-  | a::l -> a::(optim3_aux str_list l) 
-  | [] -> [];;
-
-let rec optim3 str_list = function
-    PbpThens (tl1, tl2) ->
-      PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2)
-  | PbpThen tl -> PbpThen (optim3_aux str_list tl)
-
-let optim x = make_pbp_tactic (optim3 [] (optim2 x));;
-
-(* TODO
-add_tactic "Traced_Try" traced_try_entry;;
-*)
-
-let rec tactic_args_to_ints = function
-    [] -> []
-  | (Integer n)::l -> n::(tactic_args_to_ints l)
-  | _ -> failwith "expecting only numbers";;
-
-(*
-let pbp_tac display_function = function 
-            (Identifier a)::l -> 
-                 (function g ->
-                    let str = (string_of_id a) in
-		    let (ou,tstr) = (get_hyp_by_name g str) in
-		    let exp_ast =
-		      pbpt default_ast
-		        (match ou with
-			       "hyp" ->(pf_ids_of_hyps g)
-			       |_ -> (a::(pf_ids_of_hyps g)))
-                        []
-			false
-			(Some str)
-			(kind_of_term tstr)
-                        (tactic_args_to_ints l) in
-                    (display_function (optim exp_ast);
-                        tclIDTAC g))
-          | ((Integer n)::_) as l -> 
-                 (function g ->
-                    let exp_ast =
-                       (pbpt default_ast (pf_ids_of_hyps g) [] false
-                          None (kind_of_term (pf_concl g))
-			  (tactic_args_to_ints l)) in
-                     (display_function (optim exp_ast);
-                       tclIDTAC g))
-          | [] -> (function g ->
-                     (display_function (default_ast None (pf_concl g) []);
-                      tclIDTAC g))
-          |  _ -> failwith "expecting other arguments";;
-
-
-*)
-let pbp_tac display_function idopt nl =
-  match idopt with
-    | Some str ->
-        (function g ->
-	  let (ou,tstr) = (get_hyp_by_name g str) in
-	  let exp_ast =
-	    pbpt default_ast
-	      (match ou with
-		  "hyp" ->(pf_ids_of_hyps g)
-		|_ -> (str::(pf_ids_of_hyps g)))
-              []
-	      false
-	      (Some str)
-	      (kind_of_term tstr)
-              nl in
-              (display_function (optim exp_ast); tclIDTAC g))
-    | None ->
-	if nl <> [] then
-          (function g ->
-            let exp_ast =
-              (pbpt default_ast (pf_ids_of_hyps g) [] false
-		None (kind_of_term (pf_concl g)) nl) in
-            (display_function (optim exp_ast); tclIDTAC g))
-	else
-          (function g ->
-            (display_function
-	       (make_pbp_tactic (default_ast None (pf_concl g) []));
-            tclIDTAC g));;
-
-
diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli
deleted file mode 100644
index 9daba184..00000000
--- a/contrib/interface/pbp.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) ->
-    Names.identifier option -> int list -> Proof_type.tactic
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
deleted file mode 100644
index 2ab62763..00000000
--- a/contrib/interface/showproof.ml
+++ /dev/null
@@ -1,1813 +0,0 @@
-(*
-#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";;
-open Coqast;;
-*)
-open Environ
-open Evd
-open Names
-open Nameops
-open Libnames
-open Term
-open Termops
-open Util
-open Proof_type
-open Pfedit
-open Translate
-open Term
-open Reductionops
-open Clenv
-open Typing
-open Inductive
-open Inductiveops
-open Vernacinterp
-open Declarations
-open Showproof_ct
-open Proof_trees
-open Sign
-open Pp
-open Printer
-open Rawterm
-open Tacexpr
-open Genarg
-(*****************************************************************************)
-(*
-   Arbre de preuve maison:
-   
-*)
-
-(* hypotheses *)
-
-type nhyp = {hyp_name : identifier;
-             hyp_type : Term.constr;
-             hyp_full_type: Term.constr}
-;;
-
-type ntactic = tactic_expr
-;;
-
-type nproof =
-    Notproved
-  | Proof of ntactic * (ntree list)
-
-and ngoal=
-     {newhyp : nhyp list;
-      t_concl : Term.constr;
-      t_full_concl: Term.constr;
-      t_full_env: Environ.named_context_val}
-and ntree=
-      {t_info:string;
-	t_goal:ngoal;
-       	t_proof : nproof}
-;;
-
-
-let hyps {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = lh
-;;
-
-let concl {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = g
-;;
-
-let proof {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = p
-;;
-let g_env {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = ge
-;;
-let sub_ntrees t =
-  match (proof t) with
-    Notproved -> []
-  | Proof (_,l) -> l
-;;
-
-let tactic t =
-  match (proof t) with
-    Notproved -> failwith "no tactic applied"
-  | Proof (t,_) -> t
-;;
-
-
-(* 
-un arbre est clos s'il ne contient pas de sous-but non prouves,
-ou bien s'il a un cousin gauche qui n'est pas clos 
-ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but.
-*)
-let update_closed nt =
-  let found_not_closed=ref false in
-  let rec update {t_info=b; t_goal=g; t_proof =p} =
-    if !found_not_closed
-    then  {t_info="to_prove"; t_goal=g; t_proof =p}
-    else
-      match p with
-      	Notproved -> found_not_closed:=true;
-	  {t_info="not_proved"; t_goal=g; t_proof =p}
-      | Proof(tac,lt) ->
-	  let lt1=List.map update lt in
-	  let b=ref "proved" in
-	  (List.iter
-	     (fun x ->
-	       if x.t_info ="not_proved" then b:="not_proved") lt1;
-	   {t_info=(!b);
-	     t_goal=g;
-             t_proof=Proof(tac,lt1)})
-  in update nt
-    ;;
-    
-      
-(*
-    type complet avec les hypotheses.
-*)
-
-let long_type_hyp lh t=
-   let t=ref t in
-   List.iter (fun (n,th) ->
-         let ni = match n with Name ni -> ni | _ -> assert false in
-         t:= mkProd(n,th,subst_term (mkVar ni) !t))
-       (List.rev lh);
-   !t
-;;
-
-(* let long_type_hyp x y = y;; *)
-
-(* Expansion des tactikelles *)
-
-let seq_to_lnhyp sign sign' cl =
-      let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in
-      let nh=List.map (fun (id,c,ty) -> 
-             {hyp_name=id;
-              hyp_type=ty;
-              hyp_full_type=
-                let res= long_type_hyp !lh ty in
-                lh:=(!lh)@[(Name id,ty)];
-                res})
-              sign'
-      in
-      {newhyp=nh;
-       t_concl=cl;
-       t_full_concl=long_type_hyp !lh cl;
-       t_full_env = Environ.val_of_named_context (sign@sign')}
-;;
-
-
-let rule_is_complex r =
-   match r with
-       Nested (Tactic 
-		 ((TacArg (Tacexp _)
-		 |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true
-   |_ -> false
-;;
-
-let rule_to_ntactic r =
-   let rt =
-     (match r with
-       Nested(Tactic (t,_),_) -> t
-     | Prim (Refine h) -> TacAtom (dummy_loc,TacExact (Tactics.inj_open h))
-     | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in
-   if rule_is_complex r
-   then (match rt with
-           TacArg (Tacexp _) as t -> t
-          | _ -> assert false)
-
-   else rt
-;;
-
-(* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt  *)
-
-
-let fill_unproved nt l =
-  let lnt = ref l in
-  let rec fill nt =
-    let {t_goal=g;t_proof=p}=nt in
-       match p with
-        Notproved -> let p=List.hd (!lnt) in
-                     lnt:=List.tl (!lnt);
-                     {t_info="to_prove";t_goal=g;t_proof=p}
-       |Proof(tac,lt) ->
-          {t_info="to_prove";t_goal=g;
-           t_proof=Proof(tac,List.map fill lt)}
-  in fill nt
-;;
-(* Differences entre signatures *)
-
-let new_sign osign sign =
-    let res=ref [] in
-    List.iter (fun (id,c,ty) ->
-		   try (let  (_,_,_ty1)= (lookup_named id osign) in
-			())
-		   with Not_found -> res:=(id,c,ty)::(!res))
-              sign;
-    !res
-;;
-
-let old_sign osign sign =
-    let res=ref [] in
-    List.iter (fun (id,c,ty) ->
-		   try (let (_,_,ty1) = (lookup_named id osign) in
-			if ty1 = ty then res:=(id,c,ty)::(!res))
-		   with Not_found -> ())
-              sign;
-    !res
-;;
-
-(* convertit l'arbre de preuve courant en ntree *)
-let  to_nproof sigma osign pf =
-  let rec to_nproof_rec sigma osign pf =
-    let {evar_hyps=sign;evar_concl=cl} = pf.goal in
-    let sign = Environ.named_context_of_val sign in
-    let nsign = new_sign osign sign in 
-    let oldsign = old_sign osign sign in 
-    match pf.ref with
-      
-      None -> {t_info="to_prove";
-	      	t_goal=(seq_to_lnhyp oldsign nsign cl);
-              	t_proof=Notproved}
-    | Some(r,spfl) ->
-      	if rule_is_complex r
-      	then (
-	  let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in
-          let ntree= fill_unproved p1 
-              (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof)
-		 spfl) in
-	  (match r with
-	       Nested(Tactic (TacAtom (_, TacAuto _),_),_) ->
-		 if spfl=[]
-		 then
-	      	   {t_info="to_prove";
-	    	    t_goal= {newhyp=[];
-			     t_concl=concl ntree;
-			     t_full_concl=ntree.t_goal.t_full_concl;
-			     t_full_env=ntree.t_goal.t_full_env};
-		    t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])}
-		 else ntree
-	     | _ -> ntree))
-      	else
-	  {t_info="to_prove";
-	    t_goal=(seq_to_lnhyp oldsign nsign cl);
-       	    t_proof=(Proof (rule_to_ntactic r,
-			      List.map (fun x -> to_nproof_rec sigma sign x) spfl))}
-  in update_closed (to_nproof_rec sigma osign pf)
-    ;;
-
-(* 
-  recupere l'arbre de preuve courant.
-*)
-
-let get_nproof () =
-  to_nproof (Global.env()) []
-            (Tacmach.proof_of_pftreestate (get_pftreestate()))
-;;
-
-    
-(*****************************************************************************)
-(*
-   Pprinter
-*)
-
-let pr_void () = sphs "";;
-
-let list_rem l = match l with [] -> [] |x::l1->l1;;
-
-(* liste de chaines *)
-let prls l = 
-   let res = ref (sps (List.hd l)) in
-   List.iter (fun s -> 
-     res:= sphv [ !res; spb; sps s]) (list_rem l);
-   !res
-;;
-
-let prphrases f l = 
-   spv (List.map (fun s -> sphv [f s; sps ","]) l)
-;;
-
-(* indentation *)
-let spi = spnb 3;;
-
-(* en colonne *)
-let prl f l = 
-   if l=[] then spe else spv (List.map f l);;
-(*en colonne,  avec indentation *)
-let prli f l =  
-   if l=[] then spe else sph [spi; spv (List.map f l)];;
-
-(* 
-  Langues.
-*)
-
-let rand l =
-  List.nth l (Random.int (List.length l))
-;;
-
-type natural_languages = French | English;;
-let natural_language = ref French;;
-
-(*****************************************************************************)
-(*
-   Les liens html pour proof-by-pointing
-*)
-
-(* le path du but en cours. *)
-
-let path=ref[1];;
-
-let ftag_apply =ref (fun (n:string) t -> spt t);;
-
-let ftag_case =ref (fun n -> sps n);;
-
-let ftag_elim =ref (fun n ->  sps n);;
-
-let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);;
-
-let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);;
-
-let ftag_uselemma =ref (fun h t ->
-  let intro = match !natural_language with
-    French -> "par"
-  | English -> "by"
-  in
-  spuselemma intro h t);;
-
-let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);;
-
-let tag_apply = !ftag_apply;;
-
-let tag_case = !ftag_case;;
-
-let tag_elim = !ftag_elim;;
-
-let tag_uselemma = !ftag_uselemma;;
-
-let tag_hyp = !ftag_hyp;;
-
-let tag_hypt = !ftag_hypt;;
-
-let tag_toprove = !ftag_toprove;;
-
-(*****************************************************************************)
-
-(* pluriel *)
-let txtn n s =
-  if n=1 then s
-  else match s with
-    |"un" -> "des"
-    |"a" -> ""
-    |"an" -> ""
-    |"une" -> "des"
-    |"Soit" -> "Soient"
-    |"Let" -> "Let"
-    | s -> s^"s"
-;;
-
-let _et () =  match !natural_language with
-    French -> sps "et"
-| English -> sps "and"
-;;
-
-let name_count = ref 0;;
-let new_name () =
-  name_count:=(!name_count)+1;
-  string_of_int !name_count
-;;
-
-let enumerate f ln =
-  match ln with
-    [] -> []
-  | [x] -> [f x]
-  |ln -> 
-  let rec enum_rec f ln = 
-     (match ln with 
-       [x;y] -> [f x; spb; sph [_et ();spb;f y]]
-      |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l)
-      | _ -> assert false)
-  in enum_rec f ln
-;;
-
-
-let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());;
-
-let sp_tac tac = failwith "TODO"
-
-let soit_A_une_proposition nh ln t=  match !natural_language with
-    French ->
-      sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-            @[spb; prls [txtn nh "une";txtn nh "proposition"]])
-| English ->
-      sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln)
-            @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]])
-;;
-
-let on_a ()=  match !natural_language with
-  French -> rand ["on a "]
-| English ->rand ["we have "]
-;;
-
-let bon_a ()=  match !natural_language with
-  French -> rand ["On a "]
-| English ->rand ["We have "]
-;;
-
-let soit_X_un_element_de_T nh ln t =  match !natural_language with
-  French ->
-    sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls [txtn nh "un";txtn nh "élément";"de"]]
-          @[spb; spt t])
-| English ->
-    sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]]
-          @[spb; spt t])
-;;
-
-let soit_F_une_fonction_de_type_T nh ln t =  match !natural_language with
-  French ->
-    sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]]
-          @[spb; spt t])
-| English ->
-    sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]]
-          @[spb; spt t])
-;;
-
-
-let telle_que nh =  match !natural_language with
-    French -> [prls [" ";txtn nh "telle";"que";" "]]
-| English -> [prls [" "; "such";"that";" "]]
-;;
-
-let tel_que nh =  match !natural_language with
-    French -> [prls [" ";txtn nh "tel";"que";" "]]
-| English -> [prls [" ";"such";"that";" "]]
-;;
-
-let supposons () =  match !natural_language with
-    French -> "Supposons "
-|  English -> "Suppose "
-;;
-
-let cas () =  match !natural_language with
-    French -> "Cas"
-|  English -> "Case"
-;;
-
-let donnons_une_proposition () =  match !natural_language with
-    French -> sph[ (prls ["Donnons";"une";"proposition"])]
-|  English -> sph[ (prls ["Let us give";"a";"proposition"])]
-;;
-
-let montrons g =  match !natural_language with
-    French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]);
-		   spb; spt g; sps ". "]
-|  English -> sph[ sps (rand ["Let us";"Now"]);spb;
-		   sps (rand ["prove";"show"]);
-		   spb; spt g; sps ". "]
-;;
-
-let calculons_un_element_de g =  match !natural_language with
-    French -> sph[ (prls ["Calculons";"un";"élément";"de"]);
-		   spb; spt g; sps ". "]
-|  English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]);
-		   spb; spt g; sps ". "]
-;;
-
-let calculons_une_fonction_de_type g =  match !natural_language with
-    French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]);
-                spb; spt g; sps ". "]
-|  English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]);
-                spb; spt g; sps ". "];;
-
-let en_simplifiant_on_obtient g =  match !natural_language with
-    French ->
-      sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"];
-		     rand ["on doit";"il reste à"];
-		     rand ["prouver";"montrer";"démontrer"]]);
-		     spb; spt g; sps ". "]
-|  English ->
-      sphv [ (prls [rand ["After simplification,"; "Simplifying,"];
-		     rand ["we must";"it remains to"];
-		     rand ["prove";"show"]]);
-		     spb; spt g; sps ". "] ;;
-
-let on_obtient g =  match !natural_language with
-  French -> sph[ (prls [rand ["on doit";"il reste à"];
-			 rand ["prouver";"montrer";"démontrer"]]);
-                 spb; spt g; sps ". "]
-|  English ->sph[ (prls [rand ["we must";"it remains to"];
-		     rand ["prove";"show"]]);
-                  spb; spt g; sps ". "]
-;;
-
-let reste_a_montrer g =  match !natural_language with
-    French -> sph[ (prls ["Reste";"à";
-			   rand ["prouver";"montrer";"démontrer"]]);
-                spb; spt g; sps ". "]
-|  English -> sph[ (prls ["It remains";"to";
-			   rand ["prove";"show"]]);
-                spb; spt g; sps ". "] 
-;;
-
-let discutons_avec_A type_arg  =  match !natural_language with
-    French -> sphv [sps "Discutons"; spb; sps "avec"; spb;
-				   spt type_arg; sps ":"] 
-|  English -> sphv [sps "Let us discuss"; spb; sps "with"; spb;
-				   spt type_arg; sps ":"] 
-;;
-
-let utilisons_A arg1  =  match !natural_language with
-    French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]);
-		     spb; spt arg1; sps ":"] 
-|  English -> sphv [sps (rand ["Let us use";"With";"With the help of"]);
-		     spb; spt arg1; sps ":"] 
-;;
-
-let selon_les_valeurs_de_A arg1  =  match !natural_language with
-    French -> sphv [  (prls ["Selon";"les";"valeurs";"de"]);
-                      spb; spt arg1; sps ":"] 
-|  English -> sphv [  (prls ["According";"values";"of"]);
-                      spb; spt arg1; sps ":"] 
-;;
-
-let de_A_on_a arg1  =  match !natural_language with
-    French -> sphv [  sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb;
-		      sps (rand ["on a:";"on déduit:";"on obtient:"])]
-|  English -> sphv [  sps (rand ["From";"With";"Thanks to"]); spb;
-		     spt arg1; spb;
-		      sps (rand ["we have:";"we deduce:";"we obtain:"])]
-;;
-
-
-let procedons_par_recurrence_sur_A arg1  =  match !natural_language with
-    French ->  sphv [  (prls ["Procédons";"par";"récurrence";"sur"]);
-			  spb; spt arg1; sps ":"]
-|  English -> sphv [  (prls ["By";"induction";"on"]);
-			  spb; spt arg1; sps ":"]
-;;
-
-
-let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A 
-  nfun tfun narg =  match !natural_language with
-    French ->  sphv [  
-                    sphv [ prls ["Calculons";"la";"fonction"];
-                     spb; sps (string_of_id nfun);spb;
-                     prls ["de";"type"];
-                     spb; spt tfun;spb;
-                     prls ["par";"récurrence";"sur";"son";"argument"];
-                     spb; sps (string_of_int narg); sps ":"]
-                 ]
-|  English ->  sphv [  
-                    sphv [ prls ["Let us compute";"the";"function"];
-                     spb; sps (string_of_id nfun);spb;
-                     prls ["of";"type"];
-                     spb; spt tfun;spb;
-                     prls ["by";"induction";"on";"its";"argument"];
-                     spb; sps (string_of_int narg); sps ":"]
-                 ]
-
-;;
-let pour_montrer_G_la_valeur_recherchee_est_A g arg1  =
-  match !natural_language with
-    French ->  sph [sps "Pour";spb;sps "montrer"; spt g; spb;
-		     sps ","; spb; sps "choisissons";spb;
-		     spt arg1;sps ". " ]
-|  English ->  sph [sps "In order to";spb;sps "show"; spt g; spb;
-		     sps ","; spb; sps "let us choose";spb;
-		     spt arg1;sps ". " ]
-;;
-
-let on_se_sert_de_A   arg1  =  match !natural_language with
-    French ->  sph [sps "On se sert de";spb ;spt arg1;sps ":" ]
-|  English ->  sph [sps "We use";spb ;spt arg1;sps ":" ]
-;;
-
-
-let d_ou_A g  =  match !natural_language with
-    French ->  sph [spi; sps "d'où";spb ;spt g;sps ". " ]
-|  English -> sph [spi; sps "then";spb ;spt g;sps ". " ]
-;;
-
-
-let coq_le_demontre_seul ()  =  match !natural_language with
-    French ->   rand [prls ["Coq";"le";"démontre"; "seul."];
-		       sps "Fastoche.";
-		     sps "Trop cool"]
-|  English -> 	rand [prls ["Coq";"shows";"it"; "alone."];
-		       sps "Fingers in the nose."]	      
-;;
-
-let de_A_on_deduit_donc_B arg g  =  match !natural_language with
-    French -> sph
-             [  sps "De"; spb; spt arg; spb; sps "on";spb;
-                sps "déduit";spb; sps "donc";spb;  spt g ]
-|  English -> sph
-             [  sps "From"; spb; spt arg; spb; sps "we";spb;
-                sps "deduce";spb; sps "then";spb;  spt g ]
-;;
-
-let _A_est_immediat_par_B g arg  =  match !natural_language with
-    French -> sph [  spt g;  spb; (prls ["est";"immédiat";"par"]);
-                     spb;  spt arg ] 
-|  English -> sph [  spt g;  spb; (prls ["is";"immediate";"from"]);
-                     spb;  spt arg ] 
-;;
-
-let le_resultat_est arg  =  match !natural_language with
-    French -> sph [  (prls ["le";"résultat";"est"]);
-                    spb; spt arg ] 
-|  English -> sph [  (prls ["the";"result";"is"]);
-                    spb; spt arg ];;
-
-let on_applique_la_tactique tactic tac =  match !natural_language with
-  French -> sphv 
-      [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac]
-|  English -> sphv 
-      [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac]
-;;
-
-let de_A_il_vient_B arg g  =  match !natural_language with
-    French -> sph
-             [  sps "De"; spb; spt arg; spb; 
-               sps "il";spb; sps "vient";spb; spt g; sps ". " ] 
-|  English -> sph
-             [  sps "From"; spb; spt arg; spb; 
-               sps "it";spb; sps "comes";spb; spt g; sps ". " ] 
-;;
-
-let ce_qui_est_trivial ()  =  match !natural_language with
-    French -> sps "Trivial."
-|  English -> sps "Trivial."
-;;
-
-let en_utilisant_l_egalite_A arg  =  match !natural_language with
-    French -> sphv [  sps "En"; spb;sps "utilisant"; spb;
-                   sps "l'egalite"; spb; spt arg; sps ","
-                  ]
-|  English -> sphv [  sps "Using"; spb;
-                   sps "the equality"; spb; spt arg; sps ","
-                  ]
-;;
-
-let simplifions_H_T hyp thyp =  match !natural_language with
-    French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:";
-		     spb;spt thyp;sps "."]
-|  English ->  sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:";
-		     spb;spt thyp;sps "."]
-;;
-
-let grace_a_A_il_suffit_de_montrer_LA arg lg=
-  match !natural_language with
-    French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb;
-		      spt arg;sps ",";spb;
-		     sps "il suffit";spb; sps "de"; spb;
-		      sps (rand["prouver";"montrer";"démontrer"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-|  English -> sphv ([sps (rand ["Thanks to";"With"]);spb;
-		      spt arg;sps ",";spb;
-		     sps "it suffices";spb; sps "to"; spb;
-		      sps (rand["prove";"show"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-;;
-let reste_a_montrer_LA lg=
-  match !natural_language with
-    French -> sphv ([ sps "Il reste";spb; sps "à"; spb;
-		      sps (rand["prouver";"montrer";"démontrer"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-|  English -> sphv ([ sps "It remains";spb; sps "to"; spb;
-		      sps (rand["prove";"show"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-;;
-(*****************************************************************************)
-(*
-  Traduction des hypothèses.
-*)
-
-type n_sort=
-      Nprop
-    | Nformula
-    | Ntype
-    | Nfunction
-;;
-
-   
-let sort_of_type t ts =
-   let t=(strip_outer_cast t) in
-   if is_Prop t
-   then Nprop
-   else 
-       match ts with
-         Prop(Null) -> Nformula
-        |_ -> (match (kind_of_term t) with
-                Prod(_,_,_) -> Nfunction
-               |_ -> Ntype)
-;;
-
-let adrel (x,t) e =
-    match x with 
-      Name(xid) -> Environ.push_rel (x,None,t) e
-    | Anonymous -> Environ.push_rel (x,None,t) e
-
-let rec nsortrec vl x = 
-     match (kind_of_term x) with
-     Prod(n,t,c)->
-        let vl = (adrel (n,t) vl) in nsortrec vl c
-   | Lambda(n,t,c) ->
-        let vl = (adrel (n,t) vl) in nsortrec vl c
-   | App(f,args) -> nsortrec vl f
-   | Sort(Prop(Null)) -> Prop(Null)
-   | Sort(c) -> c
-   | Ind(ind) ->
-          let (mib,mip) = lookup_mind_specif vl ind in
-	  new_sort_in_family (inductive_sort_family mip)
-   | Construct(c) ->
-          nsortrec vl (mkInd (inductive_of_constructor c))
-   | Case(_,x,t,a) 
-        -> nsortrec vl x
-   | Cast(x,_, t)-> nsortrec vl t
-   | Const c  -> nsortrec vl (Typeops.type_of_constant vl c)
-   | _ -> nsortrec vl (type_of vl Evd.empty x)
-;;
-let nsort x =
-    nsortrec  (Global.env()) (strip_outer_cast x)
-;;
-
-let sort_of_hyp h = 
-  (sort_of_type h.hyp_type (nsort h.hyp_full_type))
-;;
-
-(* grouper les hypotheses successives de meme type, ou logiques.
-   donne une liste de liste *)
-let rec group_lhyp lh =
-    match lh with
-     [] -> []
-    |[h] -> [[h]]
-    |h::lh ->
-      match group_lhyp lh with
-       (h1::lh1)::lh2 -> 
-        if h.hyp_type=h1.hyp_type
-          || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula)
-        then (h::(h1::lh1))::lh2
-        else [h]::((h1::lh1)::lh2)
-     |_-> assert false
-;;
-	
-(* ln noms des hypotheses, lt leurs types *)
-let natural_ghyp (sort,ln,lt) intro =
-  let t=List.hd lt in
-  let nh=List.length ln in
-  let _ns=List.hd ln in
-  match sort with
-    Nprop -> soit_A_une_proposition nh ln t
-  | Ntype -> soit_X_un_element_de_T nh ln t
-  | Nfunction -> soit_F_une_fonction_de_type_T nh ln t
-  | Nformula -> 
-      sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t)
-			    (List.combine ln lt)))
-;;
-
-(* Cas d'une hypothese *)
-let natural_hyp h = 
-   let ns= string_of_id h.hyp_name in
-   let t=h.hyp_type in
-   let ts= (nsort h.hyp_full_type) in
-   natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ())
-;;
-
-let rec pr_ghyp lh intro=
-     match lh with
-       [] -> []
-     | [(sort,ln,t)]->
-         (match sort with
-           Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "]
-         | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "])
-     | (sort,ln,t)::lh  ->
-       let hp= 
-        ([natural_ghyp(sort,ln,t) intro]
-         @(match lh with
-           [] -> [sps ". "]
-          |(sort1,ln1,t1)::lh1  ->
-             match sort1 with
-               Nformula -> 
-                 (let nh=List.length ln in
-                     match sort with
-                   Nprop -> telle_que nh 
-                  |Nfunction -> telle_que nh 
-                  |Ntype -> tel_que nh 
-                  |Nformula -> [sps ". "])
-             | _ -> [sps ". "])) in
-        (sphv hp)::(pr_ghyp lh "")
-;;
-
-(* traduction d'une liste d'hypotheses groupees. *)
-let prnatural_ghyp llh intro=
-  if llh=[]
-  then spe
-  else
-    sphv (pr_ghyp (List.map
-		     (fun lh ->
-		       let h=(List.hd lh) in
-		       let sh = sort_of_hyp h in
-		       let lhname = (List.map (fun h ->
-			 string_of_id h.hyp_name) lh) in
-		       let lhtype = (List.map (fun h -> h.hyp_type) lh) in
-		       (sh,lhname,lhtype))
-		     llh) intro)
-;;
-
-
-(*****************************************************************************)
-(*
-    Liste des hypotheses.
-*)
-type type_info_subgoals_hyp=
-    All_subgoals_hyp
-  | Reduce_hyp
-  | No_subgoals_hyp
-  | Case_subgoals_hyp of string (* word for introduction *)
-	* Term.constr (* variable *)
-        * string (* constructor *)
-        * int (* arity *)
-        * int (* number of constructors *)
-  | Case_prop_subgoals_hyp of string (* word for introduction *)
-	* Term.constr (* variable *)
-        * int (* index of constructor *)
-        * int (* arity *)
-        * int (* number of constructors *)
-  | Elim_subgoals_hyp of Term.constr (* variable *)
-        * string (* constructor *)
-        * int (* arity *)
-        * (string list) (* rec hyp *)
-        * int (* number of constructors *)
-  | Elim_prop_subgoals_hyp of Term.constr (* variable *)
-        * int (* index of constructor *)
-        * int (* arity *)
-        * (string list) (* rec hyp *)
-        * int (* number of constructors *)
-;;
-let rec nrem l n =
-  if n<=0 then l else nrem (list_rem l) (n-1)
-;;
-
-let rec nhd l n =
-  if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1))
-;;
-
-let par_hypothese_de_recurrence () =  match !natural_language with
-    French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])]
-| English -> sphv [(prls ["by";"induction";"hypothesis";","])]
-;;
-
-let  natural_lhyp lh hi =
-  match hi with
-    All_subgoals_hyp -> 
-        ( match lh with
-          [] -> spe
-        |_-> prnatural_ghyp (group_lhyp lh) (supposons ()))
-  | Reduce_hyp ->
-      (match lh with
-	[h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type
-      |	_-> spe)
-  | No_subgoals_hyp -> spe
-  |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *)
-      let s=ref c in
-      for i=1 to a do
-        let nh=(List.nth lh (i-1)) in
-        s:=(!s)^" "^(string_of_id nh.hyp_name);
-      done;
-      if a>0 then s:="("^(!s)^")";
-      sphv [  (if ncase>1
-                     then sph[ sps ("-"^(cas ()));spb]
-                     else spe);
-                    (* spt var;sps "="; *) sps !s; sps ":";
-           (prphrases (natural_hyp) (nrem lh a))]
-  |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) ->
-      prnatural_ghyp (group_lhyp lh) sintro
-  |Elim_subgoals_hyp (var,c,a,lhci,ncase) ->
-      let nlh = List.length lh in
-      let nlhci = List.length lhci in
-      let lh0 = ref [] in
-      for i=1 to (nlh-nlhci) do
-         lh0:=(!lh0)@[List.nth lh (i-1)];
-      done;
-      let lh=nrem lh (nlh-nlhci) in
-      let s=ref c in
-      let lh1=ref [] in
-      for i=1 to nlhci do
-        let targ=(List.nth lhci (i-1))in
-        let nh=(List.nth lh (i-1)) in
-        if targ="arg" || targ="argrec" 
-        then
-            (s:=(!s)^" "^(string_of_id nh.hyp_name);
-	     lh0:=(!lh0)@[nh])
-        else lh1:=(!lh1)@[nh];
-      done;
-      let introhyprec=
-          (if (!lh1)=[] then spe 
-           else   par_hypothese_de_recurrence () )
-      in          
-      if a>0 then s:="("^(!s)^")";
-      spv [sphv [(if ncase>1
-                     then sph[ sps ("-"^(cas ()));spb]
-                     else spe);
-                     sps !s; sps ":"]; 
-           prnatural_ghyp (group_lhyp !lh0) (supposons ());
-           introhyprec;
-           prl (natural_hyp) !lh1]
-  |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) ->
-      sphv [  (if ncase>1
-                     then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c);
-                             sps ":";spb]
-                     else spe);
-           (prphrases (natural_hyp) lh )]
-
-;;
-
-(*****************************************************************************)
-(*
-    Analyse des tactiques.
-*)
-
-let name_tactic = function
-  | TacIntroPattern _ -> "Intro"
-  | TacAssumption -> "Assumption"
-  | _ -> failwith "TODO"
-;;
-
-(*
-let arg1_tactic tac =
-  match tac with
-    (Node(_,"Interp",
-		(Node(_,_,
-		      (Node(_,_,x::_))::_))::_))::_ ->x
-  | (Node(_,_,x::_))::_ -> x
-  | x::_ -> x
-  | _ -> assert false
-;;
-*)
-
-let arg1_tactic tac = failwith "TODO";;
-
-type type_info_subgoals =
-    {ihsg: type_info_subgoals_hyp;
-     isgintro : string}
-;;
-
-let rec show_goal lh ig g gs =
-  match ig with
-    "intros" ->
-      if lh = []
-      then spe
-      else show_goal lh "standard" g gs 
-  |"standard" ->
-      (match (sort_of_type g gs) with
-        Nprop -> donnons_une_proposition ()
-      | Nformula -> montrons g
-      | Ntype -> calculons_un_element_de g
-      | Nfunction ->calculons_une_fonction_de_type g)
-  | "apply" -> show_goal lh "" g gs
-  | "simpl" ->en_simplifiant_on_obtient g
-  | "rewrite" -> on_obtient g 
-  | "equality" -> reste_a_montrer g
-  | "trivial_equality" -> reste_a_montrer g
-  | "" -> spe
-  |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ]
-;;
-
-let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s =
-  if ig="" && lh = []
-  then spe
-  else sphv [  show_goal lh ig g gs; sps s]
-;;
-
-let imaginez_une_preuve_de () =  match !natural_language with
-    French -> "Imaginez une preuve de"
-| English -> "Imagine a proof of"
-;;
-
-let donnez_un_element_de () =  match !natural_language with
-    French -> "Donnez un element de"
-| English -> "Give an element of";;
-
-let intro_not_proved_goal gs =
-   match gs with
-     Prop(Null) -> imaginez_une_preuve_de ()
-    |_ -> donnez_un_element_de ()
-;;
-
-let first_name_hyp_of_ntree {t_goal={newhyp=lh}}=
-  match lh with
-   {hyp_name=n}::_ -> n
-  | _ -> assert false
-;;
-
-let rec find_type x t=
-    match (kind_of_term (strip_outer_cast t)) with 
-      Prod(y,ty,t) ->
-	(match y with
-	  Name y -> 
-            if x=(string_of_id y) then ty
-            else find_type x t
-	| _ -> find_type x t)
-     |_-> assert false 
-;;
-
-(***********************************************************************
-Traitement des égalités
-*)
-(*
-let is_equality e =
-   match  (kind_of_term e) with
-     AppL args ->
-       (match (kind_of_term args.(0)) with
-	 Const (c,_) ->
-	   (match (string_of_sp c) with
-	     "Equal" -> true
-           | "eq" -> true
-	   | "eqT" -> true
-	   | "identityT" -> true
-	   | _ -> false)
-       | _ -> false)
-   | _ -> false
-;;
-*)
-
-let is_equality e =
-  let e= (strip_outer_cast e) in
-   match  (kind_of_term e) with
-     App (f,args) -> (Array.length args) >= 3
-   | _ -> false
-;;
-
-let terms_of_equality e =
-  let e= (strip_outer_cast e) in
-  match  (kind_of_term e) with
-     App (f,args) -> (args.(1) , args.(2))
-    | _ -> assert false
-;;
-
-let eq_term = eq_constr;;
-
-let is_equality_tac = function
-  | TacAtom (_,
-      (TacExtend
-	(_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc"
-	 |"ERewriteParallel"|"ERewriteNormal"
-	 |"RewriteLR"|"RewriteRL"|"Replace"),_)
-      | TacReduce _
-      | TacSymmetry _ | TacReflexivity
-      | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true
-  | _ -> false
-
-let equalities_ntree ig ntree =
-  let rec equalities_ntree ig ntree =
-  if not (is_equality (concl ntree)) 
-  then []
-  else
-    match (proof ntree) with
-      Notproved ->  [(ig,ntree)]
-    | Proof (tac,ltree) ->
-	if is_equality_tac tac
-      	then (match ltree with
-          [] ->  [(ig,ntree)]
-	| t::_ -> let res=(equalities_ntree ig t) in
-	          if eq_term (concl ntree) (concl t)
-		  then res
-		  else (ig,ntree)::res)
-	else  [(ig,ntree)]
-  in 
-  equalities_ntree ig ntree 
-;;
-
-let remove_seq_of_terms l =
-  let rec remove_seq_of_terms l =    match l with
-    a::b::l -> if (eq_term (fst a) (fst b))
-    then remove_seq_of_terms (b::l)
-    else a::(remove_seq_of_terms (b::l))
-  | _ -> l
-  in remove_seq_of_terms l
-;;
-
-let  list_to_eq l o=
-  let switch = fun h h' -> (if o then h else h') in
-   match l with
-      [a] -> spt (fst a) 
-   |  (a,h)::(b,h')::l ->
-       let rec list_to_eq h l =
-	 match l with
-	   [] -> []
-	 |  (b,h')::l ->
-	     (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe])
-             :: (list_to_eq (switch h' h) l)
-       in sph [spt a;  spb;
-		 spv ((sph [sps "="; spb; spt b; spb; 
-			     tag_uselemma (switch h h') spe])
-		      ::(list_to_eq (switch h' h) l))]
-  | _ -> assert false
-;;
-
-let stde = Global.env;;
-
-let dbize env = Constrintern.interp_constr Evd.empty env;;
-
-(**********************************************************************)
-let rec natural_ntree ig ntree =
-  let  {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = ntree in
-    let leq = List.rev (equalities_ntree ig ntree)  in
-    if List.length leq > 1
-    then (* Several equalities to treate ... *)
-      (
-       print_string("Several equalities to treate ...\n");
-      let l1 = ref [] in
-      let l2 = ref [] in
-      List.iter
-	(fun (_,ntree) ->
-	 let lemma =  match (proof ntree) with
-	   Proof (tac,ltree) ->
-	     (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *)
-			  (match ltree with
-			    [] ->spe
-			  | [_] -> spe
-			  | _::l -> sphv[sps ": ";
-					  prli (natural_ntree 
-					    {ihsg=All_subgoals_hyp;
-					      isgintro="standard"})
-                            		    l])])
-	      with _ -> sps "simplification"  )
-	 | Notproved -> spe
-	 in
- 	  let (t1,t2)= terms_of_equality (concl ntree) in
-	  l2:=(t2,lemma)::(!l2);
-	  l1:=(t1,lemma)::(!l1))
-	leq;
-      l1:=remove_seq_of_terms !l1;
-      l2:=remove_seq_of_terms !l2;
-      l2:=List.rev !l2;
-      let ltext=ref [] in
-      if List.length !l1 > 1
-      then (ltext:=(!ltext)@[list_to_eq !l1 true];
-	    if List.length !l2 > 1 then
-	      (ltext:=(!ltext)@[_et()];
-	       ltext:=(!ltext)@[list_to_eq !l2 false]))
-      else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false];
-      if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext];
-      let (ig,ntree)=(List.hd leq) in
-      spv [(natural_lhyp lh ig.ihsg);
-	    (show_goal2 lh ig g (nsort gf) "");
-	    sph !ltext;
-	    
-	    natural_ntree {ihsg=All_subgoals_hyp;
-                            isgintro=
-			    let  (t1,t2)= terms_of_equality (concl ntree) in
-			    if eq_term t1 t2
-			    then "trivial_equality"
-			    else "equality"}
-	      ntree]
-      	)
-    else
-    let ntext =
-      let gs=nsort gf in
-      match p with
-   	Notproved ->  spv [ (natural_lhyp lh ig.ihsg);
-                            sph [spi; sps (intro_not_proved_goal gs); spb; 
-                                  tag_toprove g  ]
-			  ]
-
-      | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree)
-      | Proof (TacAtom (_,tac),ltree) -> 
-	 (let ntext = 
-	  match tac with
-(* Pas besoin de l'argument éventuel de la tactique *)
-	    TacIntroPattern _ -> natural_intros ig lh g gs ltree
-	  | TacIntroMove _ -> natural_intros ig lh g gs ltree
-	  | TacFix (_,n) -> natural_fix ig lh g gs n ltree
-	  | TacSplit (_,_,NoBindings) -> natural_split ig lh g gs ge [] ltree
-	  | TacSplit(_,_,ImplicitBindings l) -> natural_split ig lh g gs ge (List.map snd l) ltree
-	  | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree
-	  | TacRight _ -> natural_right ig lh g gs ltree
-	  | TacLeft _ -> natural_left ig lh g gs ltree
-	  | (* "Simpl" *)TacReduce (r,cl)  ->
-	      natural_reduce ig lh g gs ge r cl ltree
-	  | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree
-	  | TacAuto _ -> natural_auto ig lh g gs ltree
-	  | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree
-	  | TacTrivial _ -> natural_trivial ig lh g gs ltree
-	  | TacAssumption -> natural_trivial ig lh g gs ltree
-	  | TacClear _ -> natural_clear ig lh g gs ltree
-(* Besoin de l'argument de la tactique *)
-	  | TacSimpleInductionDestruct (true,NamedHyp id) -> 
-              natural_induction ig lh g gs ge id ltree false
-	  | TacExtend (_,"InductionIntro",[a]) -> 
-              let id=(out_gen wit_ident a) in
-              natural_induction ig lh g gs ge id ltree true
-	  | TacApply (_,false,[c,_],None) ->
-              natural_apply ig lh g gs (snd c) ltree
-	  | TacExact c -> natural_exact ig lh g gs (snd c) ltree
-	  | TacCut c -> natural_cut ig lh g gs (snd c) ltree
-	  | TacExtend (_,"CutIntro",[a]) ->
-	      let _c = out_gen wit_constr a in
-	      natural_cutintro ig lh g gs a ltree
-	  | TacCase (_,(c,_)) -> natural_case ig lh g gs ge (snd c) ltree false
-	  | TacExtend (_,"CaseIntro",[a]) ->
-	      let c = out_gen wit_constr a in
-	      natural_case ig lh g gs ge c ltree true
-	  | TacElim (_,(c,_),_) ->
-	      natural_elim ig lh g gs ge (snd c) ltree false
-	  | TacExtend (_,"ElimIntro",[a]) ->
-	      let c = out_gen wit_constr a in
-	      natural_elim ig lh g gs ge c ltree true
-	  | TacExtend (_,"Rewrite",[_;a]) ->
-	      let (c,_) = out_gen wit_constr_with_bindings a in
-	      natural_rewrite ig lh g gs c ltree
-	  | TacExtend (_,"ERewriteRL",[a]) ->
-	      let c = out_gen wit_constr a in (* TODO *)
-	      natural_rewrite ig lh g gs c ltree
-	  | TacExtend (_,"ERewriteLR",[a]) ->
-	      let c = out_gen wit_constr a in (* TODO *)
-	      natural_rewrite ig lh g gs c ltree
-	  |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree
-         in
-          ntext (* spwithtac ntext tactic*)
-          )
-      | Proof _ -> failwith "Don't know what to do with that"
-    in   
-         if info<>"not_proved"
-         then spshrink info ntext
-         else ntext
-and  natural_generic  ig lh g gs tactic tac ltree =
-  spv
-    [ (natural_lhyp lh ig.ihsg);
-      (show_goal2 lh ig g gs "");
-      on_applique_la_tactique tactic tac ;
-      (prli(natural_ntree  
-	      {ihsg=All_subgoals_hyp;
-		isgintro="standard"})
-         ltree)
-    ]
-and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree)
-(*
-    spv
-    [ (natural_lhyp lh ig.ihsg);
-      (show_goal2 lh ig g gs "");
-      (prl (natural_ntree ig) ltree)
-    ]
-*)
-and natural_intros ig lh g gs ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-            (show_goal2 lh ig g gs "");
-            (prl (natural_ntree  
-                {ihsg=All_subgoals_hyp;
-                 isgintro="intros"})
-                            ltree)
-        ]
-and natural_apply ig lh g gs arg ltree =
-  let lg = List.map concl ltree in
-  match lg with
-    [] ->
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-	  de_A_il_vient_B arg g  
-        ]
-  | [sg]->
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh
-	     {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply"
-	                              then "standard"
-	                              else ""}
-	     g gs "");
-          grace_a_A_il_suffit_de_montrer_LA arg [spt sg];
-	  sph [spi ; natural_ntree 
-		  {ihsg=All_subgoals_hyp;
-		    isgintro="apply"} (List.hd ltree)]
-	]       
-  | _ ->
-      let ln = List.map (fun _ -> new_name()) lg in
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh
-	     {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply"
-	                              then "standard"
-			              else ""}
-	     g gs "");
-          grace_a_A_il_suffit_de_montrer_LA arg
-	    (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g])
-	       lg ln);
-	  sph [spi; spv (List.map2
-			   (fun x n -> sph [sps ("("^n^"):"); spb;
-					     natural_ntree 
-					       {ihsg=All_subgoals_hyp;
-						 isgintro="apply"} x])
-			   ltree ln)]
-        ]
-and natural_rem_goals ltree =
-  let lg = List.map concl ltree in
-  match lg with
-    [] -> spe
-  | [sg]->
-      spv
-        [ reste_a_montrer_LA [spt sg];
-	  sph [spi ; natural_ntree 
-		  {ihsg=All_subgoals_hyp;
-		    isgintro="apply"} (List.hd ltree)]
-	]       
-  | _ ->
-      let ln = List.map (fun _ -> new_name()) lg in
-      spv
-        [   reste_a_montrer_LA 
-	    (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g])
-	       lg ln);
-	  sph [spi; spv (List.map2
-			   (fun x n -> sph [sps ("("^n^"):"); spb;
-					     natural_ntree 
-					       {ihsg=All_subgoals_hyp;
-						 isgintro="apply"} x])
-			   ltree ln)]
-        ]
-and natural_exact ig lh g gs arg ltree =
-spv
-         [  
-             (natural_lhyp lh ig.ihsg);
-             (let {ihsg=pi;isgintro=ig}= ig in
-               (show_goal2 lh {ihsg=pi;isgintro=""}
-                   g gs ""));
-             (match gs with
-               Prop(Null) -> _A_est_immediat_par_B g arg
-              |_ -> le_resultat_est arg)
-
-        ]
-and natural_cut ig lh g gs arg ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             (prli(natural_ntree  
-                    {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            (List.rev ltree));
-             de_A_on_deduit_donc_B arg g
-        ]
-and natural_cutintro ig lh g gs arg ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             sph [spi;
-                    (natural_ntree  
-                       {ihsg=All_subgoals_hyp;isgintro=""}
-                       (List.nth ltree 1))];
-             sph [spi;
-                    (natural_ntree  
-                       {ihsg=No_subgoals_hyp;isgintro=""}
-                       (List.nth ltree 0))]
-        ]
-and whd_betadeltaiota x = whd_betaiota Evd.empty x
-and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c)
-and prod_head t =
-  match (kind_of_term (strip_outer_cast t)) with 
-     Prod(_,_,c) -> prod_head c
-(*    |App(f,a) -> f *)
-    | _ -> t
-and string_of_sp sp = string_of_id (basename sp)
-and constr_of_mind mip i =
-  (string_of_id mip.mind_consnames.(i-1))
-and arity_of_constr_of_mind env indf i =
-     (get_constructors env indf).(i-1).cs_nargs
-and gLOB ge = Global.env_of_context ge  (* (Global.env()) *)
-
-and natural_case ig lh g gs ge arg1 ltree with_intros =
- let env= (gLOB ge) in
- let targ1 = prod_head (type_of env Evd.empty arg1) in
- let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let ncti= Array.length(get_constructors env indf) in
- let (ind,_) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let ti =(string_of_id mip.mind_typename) in
- let type_arg= targ1 (* List.nth targ (mis_index dmi)*)  in
- if  ncti<>1
-(* Zéro ou Plusieurs constructeurs *)
- then (   
-   spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             (match (nsort targ1) with
-               Prop(Null) ->
-		 (match ti with
-		   "or" ->  discutons_avec_A type_arg
-                 | _ -> utilisons_A arg1)
-             |_ -> selon_les_valeurs_de_A arg1);
-            (let ci=ref 0 in
-             (prli
-                 (fun treearg -> ci:=!ci+1;
-                      let nci=(constr_of_mind mip !ci) in
-                      let aci=if with_intros
-			      then (arity_of_constr_of_mind env indf !ci)
-		              else 0 in
-                      let ici= (!ci) in
-                    sph[ (natural_ntree  
-                          {ihsg=
-                             (match (nsort targ1) with
-                                Prop(Null) ->
-                                   Case_prop_subgoals_hyp (supposons (),arg1,ici,aci,
-                                     (List.length ltree))
-                               |_-> Case_subgoals_hyp ("",arg1,nci,aci,
-                                                (List.length ltree)));
-                           isgintro= if with_intros then "" else "standard"}
-                          treearg)
-                    ])
-                  (nrem ltree ((List.length ltree)- ncti))));
-	    (sph [spi; (natural_rem_goals
-			  (nhd ltree ((List.length ltree)- ncti)))])
-         ] )
-(* Cas d'un seul constructeur *)
-     else (  
-
-     spv
-     [ (natural_lhyp lh ig.ihsg);
-       (show_goal2 lh ig g gs "");
-       de_A_on_a arg1;
-       (let treearg=List.hd ltree in
-       let nci=(constr_of_mind mip 1) in
-       let aci=
-	 if with_intros
-         then (arity_of_constr_of_mind env indf 1)
-	 else 0 in
-       let _ici= 1 in
-       sph[ (natural_ntree  
-               {ihsg=
-                 (match (nsort targ1) with
-                   Prop(Null) ->
-                     Case_prop_subgoals_hyp ("",arg1,1,aci,
-					     (List.length ltree))
-                 |_-> Case_subgoals_hyp ("",arg1,nci,aci,
-                                         (List.length ltree)));
-                 isgintro=""}
-               treearg)
-          ]);
-       (sph [spi; (natural_rem_goals
-		     (nhd ltree ((List.length ltree)- 1)))])
-     ] 
-     )
-(*    with _ ->natural_generic ig lh g gs (sps "Case")  (spt arg1) ltree *)
-
-(*****************************************************************************)
-(*
-   Elim
-*)
-and prod_list_var t =
-   match (kind_of_term (strip_outer_cast t)) with 
-      Prod(_,t,c) -> t::(prod_list_var c)
-     |_ -> []
-and  hd_is_mind t ti =
-    try (let env = Global.env() in
-         let IndType (indf,targ) = find_rectype env Evd.empty t in
-	 let _ncti= Array.length(get_constructors env indf) in
-	 let (ind,_) = dest_ind_family indf in
-         let (mib,mip) = lookup_mind_specif env ind in
-	 (string_of_id mip.mind_typename) = ti)
-    with _ -> false
-and mind_ind_info_hyp_constr indf c =
-  let env = Global.env() in
-  let (ind,_) = dest_ind_family indf in
-  let (mib,mip) = lookup_mind_specif env ind in
-  let _p = mib.mind_nparams in
-  let a = arity_of_constr_of_mind env indf c in
-  let lp=ref (get_constructors env indf).(c).cs_args in
-  let lr=ref [] in
-  let ti = (string_of_id mip.mind_typename) in
-  for i=1 to a do
-     match !lp with
-     ((_,_,t)::lp1)->
-       if hd_is_mind t ti
-       then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1)
-       else (lr:=(!lr)@["arg"];lp:=lp1)
-     |  _ -> raise (Failure "mind_ind_info_hyp_constr")
-  done;
-  !lr
-(*
- mind_ind_info_hyp_constr "le" 2;;
-donne  ["arg"; "argrec"] 
-mind_ind_info_hyp_constr "le" 1;;
-donne []
- mind_ind_info_hyp_constr "nat" 2;;
-donne ["argrec"]
-*)
-
-and natural_elim ig lh g gs ge arg1 ltree with_intros=
- let env= (gLOB ge) in
- let targ1 = prod_head (type_of env Evd.empty arg1) in
- let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let ncti= Array.length(get_constructors env indf) in
- let (ind,_) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let _ti =(string_of_id mip.mind_typename) in
- let _type_arg=targ1 (* List.nth targ (mis_index dmi) *) in
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             (match (nsort targ1) with
-               Prop(Null) -> utilisons_A arg1
-	     |_ ->procedons_par_recurrence_sur_A arg1);
-            (let ci=ref 0 in
-             (prli
-                 (fun treearg -> ci:=!ci+1;
-                      let nci=(constr_of_mind mip !ci) in
-                      let aci=(arity_of_constr_of_mind env indf !ci) in
-                      let hci=
-			if with_intros
-			then mind_ind_info_hyp_constr indf  !ci
-		      	else [] in
-                      let ici= (!ci) in
-                    sph[ (natural_ntree  
-                          {ihsg=
-                             (match (nsort targ1) with
-                                Prop(Null) ->
-                                   Elim_prop_subgoals_hyp (arg1,ici,aci,hci,
-                                     (List.length ltree))
-                               |_-> Elim_subgoals_hyp (arg1,nci,aci,hci,
-                                                (List.length ltree)));
-                           isgintro= ""}
-                          treearg)
-                    ])
-                  (nhd ltree ncti)));
-	    (sph [spi; (natural_rem_goals (nrem ltree ncti))])
-        ]
-(* )
-  with _ ->natural_generic ig lh g gs (sps "Elim")  (spt arg1) ltree *)
-
-(*****************************************************************************)
-(*
-   InductionIntro n
-*) 
-and natural_induction ig lh g gs ge arg2 ltree with_intros=
- let env = (gLOB (g_env (List.hd ltree))) in
- let arg1= mkVar arg2 in
- let targ1 = prod_head (type_of env Evd.empty arg1) in
- let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let _ncti= Array.length(get_constructors env indf) in
- let (ind,_) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let _ti =(string_of_id mip.mind_typename) in
- let _type_arg= targ1(*List.nth targ (mis_index dmi)*) in
-
- let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *)
- (* on les enleve des hypotheses des sous-buts *)
- let ltree = List.map
-     (fun {t_info=info;
-	    t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	    t_proof=p} ->
-	  {t_info=info;
-	    t_goal={newhyp=(nrem lh (List.length lh1));
-		     t_concl=g;t_full_concl=gf;t_full_env=ge};
-	    t_proof=p}) ltree in
- spv
-   [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-	   (natural_lhyp lh1 All_subgoals_hyp);
-             (match (print_string "targ1------------\n";(nsort targ1)) with
-               Prop(Null) -> utilisons_A arg1
-	     |_ -> procedons_par_recurrence_sur_A arg1);
-            (let ci=ref 0 in
-             (prli
-                 (fun treearg -> ci:=!ci+1;
-                      let nci=(constr_of_mind mip !ci) in
-                      let aci=(arity_of_constr_of_mind env indf !ci) in
-                      let hci= 
-			if with_intros
-			then mind_ind_info_hyp_constr indf  !ci
-		      	else [] in
-                      let ici= (!ci) in
-                    sph[ (natural_ntree  
-                          {ihsg=
-                             (match (nsort targ1) with
-                                Prop(Null) ->
-                                   Elim_prop_subgoals_hyp (arg1,ici,aci,hci,
-                                     (List.length ltree))
-                               |_-> Elim_subgoals_hyp (arg1,nci,aci,hci,
-                                                (List.length ltree)));
-                           isgintro= "standard"}
-                          treearg)
-                    ])
-                  ltree))
-        ]
-(************************************************************************)
-(* Points fixes *)
-
-and natural_fix ig lh g gs narg ltree =
-  let {t_info=info;
-	t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1;
-                   t_full_env=ge1};t_proof=p1}=(List.hd ltree) in
-  match lh1 with
-     {hyp_name=nfun;hyp_type=tfun}::lh2 ->
-  let ltree=[{t_info=info;
-	       t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1;
-                          t_full_env=ge1};
-	       t_proof=p1}] in
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A  nfun tfun narg;
-             (prli(natural_ntree  
-                   {ihsg=All_subgoals_hyp;isgintro=""})
-                            ltree)
-        ]
-   | _ -> assert false
-and natural_reduce ig lh g gs ge mode la ltree =
-  match la with
-    {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> 
-      spv
-        [  (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-          (prl (natural_ntree 
-		  {ihsg=All_subgoals_hyp;isgintro="simpl"})
-             ltree)
-        ]
-  | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr ->
-      spv
-        [  (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-          (prl (natural_ntree 
-		  {ihsg=Reduce_hyp;isgintro=""})
-             ltree)
-        ]
-  | _ -> assert false
-and natural_split ig lh g gs ge la ltree =
-  match la with
-    [arg] -> 
-      let _env= (gLOB ge) in
-      let arg1= (*dbize _env*) arg in
-      spv
-      	[ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-	  pour_montrer_G_la_valeur_recherchee_est_A  g arg1;
-          (prl (natural_ntree 
-		  {ihsg=All_subgoals_hyp;isgintro="standard"})
-             ltree)
-        ]
-  | [] ->
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-          (prli(natural_ntree  
-                  {ihsg=All_subgoals_hyp;isgintro="standard"})
-             ltree)
-        ]
-  | _ -> assert false
-and natural_generalize ig lh g gs ge la ltree =
-  match la with
-    [(_,(_,arg)),_] ->
-      let _env= (gLOB ge) in
-      let arg1= (*dbize env*) arg in
-      let _type_arg=type_of (Global.env()) Evd.empty arg in
-(*      let type_arg=type_of_ast ge arg in*)
-      spv
-      	[ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-	  on_se_sert_de_A   arg1;
-          (prl (natural_ntree 
-		  {ihsg=All_subgoals_hyp;isgintro=""})
-             ltree)
-        ]
-    | _ -> assert false
-and natural_right ig lh g gs ltree =
-  spv
-         [ (natural_lhyp lh ig.ihsg);
-            (prli(natural_ntree  
-                {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            ltree); 
-            d_ou_A g  
-        ]
-and natural_left ig lh g gs ltree =
-  spv
-         [ (natural_lhyp lh ig.ihsg);
-            (prli(natural_ntree  
-                {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            ltree); 
-             d_ou_A g  
-        ]
-and natural_auto ig lh g gs ltree =
-  match ig.isgintro with
-   "trivial_equality" -> spe
-  | _ -> 
-      if ltree=[]
-      then sphv [(natural_lhyp lh ig.ihsg);
-		  (show_goal2 lh ig g gs "");
-		  coq_le_demontre_seul ()]
-      else spv [(natural_lhyp lh ig.ihsg);
-		 (show_goal2 lh ig g gs "");
-		 (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}
-			  )
-                    ltree)]
-and natural_infoauto ig lh g gs ltree =
- match ig.isgintro with
-   "trivial_equality" ->
-     spshrink "trivial_equality"
-       (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}
-		 (List.hd ltree))
-  | _ ->   sphv [(natural_lhyp lh ig.ihsg);
-	 (show_goal2 lh ig g gs "");
-	 coq_le_demontre_seul ();
-       spshrink "auto"
-		    (sph [spi;
-		       (natural_ntree
-			  {ihsg=All_subgoals_hyp;isgintro=""}
-			  (List.hd ltree))])]
-and natural_trivial ig lh g gs ltree =
-  if ltree=[]
-  then sphv [(natural_lhyp lh ig.ihsg);
-	      (show_goal2 lh ig g gs "");
-	      ce_qui_est_trivial () ]
-  else spv [(natural_lhyp lh ig.ihsg);
-	     (show_goal2 lh ig g gs ". ");
-            (prli(natural_ntree  
-                      {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            ltree)]
-and natural_rewrite ig lh g gs arg ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             en_utilisant_l_egalite_A arg;
-            (prli(natural_ntree  
-                 {ihsg=All_subgoals_hyp;isgintro="rewrite"})
-                            ltree)
-        ]
-;;
-
-let natural_ntree_path ig g =
-  Random.init(0);
-        natural_ntree ig g
-;;
-
-let show_proof lang gpath =
-  (match lang with
-     "fr" -> natural_language:=French
-    |"en" -> natural_language:=English
-    | _ -> natural_language:=English);
-  path:=List.rev gpath;
-  name_count:=0;
-  let ntree=(get_nproof ()) in
-  let {t_info=i;t_goal=g;t_proof=p} =ntree in
-  root_of_text_proof
-    (sph [(natural_ntree_path {ihsg=All_subgoals_hyp;
-				isgintro="standard"}
-	                      {t_info="not_proved";t_goal=g;t_proof=p});
-           spr])
-    ;;
-
-let show_nproof path =
-  pp (sp_print (sph [spi; show_proof "fr" path]));;
-
-vinterp_add "ShowNaturalProof"
-	    (fun _ ->
-		 (fun () ->show_nproof[];()));;
-
-(***********************************************************************
-debug sous cygwin:
-
-PATH=/usr/local/bin:/usr/bin:$PATH
-COQTOP=d:/Tools/coq-7avril
-CAMLLIB=/usr/local/lib/ocaml
-CAMLP4LIB=/usr/local/lib/camlp4
-export CAMLLIB
-export COQTOP
-export CAMLP4LIB 
-cd d:/Tools/pcoq/src/text
-d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax  -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history
-
- 
- 
-Lemma l1: (A, B : Prop) A \/ B -> B ->  A.
-Intros.
-Elim H.
-Auto.
-Qed.
- 
-
-Drop.
-
-#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";;
-#load "xlate.cmo";;
-#load "translate.cmo";;
-#load "showproof_ct.cmo";;
-#load "showproof.cmo";;
-#load "pbp.cmo";;
-#load "debug_tac.cmo";;
-#load "name_to_ast.cmo";;
-#load "paths.cmo";;
-#load "dad.cmo";;
-#load "vtp.cmo";;
-#load "history.cmo";;
-#load "centaur.cmo";;
-Xlate.set_xlate_mut_stuff Centaur.globcv;;
-Xlate.declare_in_coq();;
-
-#use "showproof.ml";;
-
-let pproof x = pP (sp_print x);;
-Pp_control.set_depth_boxes 100;;
-#install_printer  pproof;;
-
-ep();;
-let bidon = ref (constr_of_string "O");; 
-
-#trace to_nproof;;
-***********************************************************************)
-let ep()=show_proof "fr" [];;
diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli
deleted file mode 100755
index 9b6787b7..00000000
--- a/contrib/interface/showproof.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-open Environ
-open Evd
-open Names
-open Term
-open Util
-open Proof_type
-open Pfedit
-open Term
-open Reduction
-open Clenv
-open Typing
-open Inductive
-open Vernacinterp
-open Declarations
-open Showproof_ct
-open Proof_trees
-open Sign
-open Pp
-open Printer
-
-val show_proof : string -> int list -> Ascent.ct_TEXT;;
diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml
deleted file mode 100644
index dd7f455d..00000000
--- a/contrib/interface/showproof_ct.ml
+++ /dev/null
@@ -1,184 +0,0 @@
-(*****************************************************************************)
-(*
-   Vers Ctcoq
-*)
-
-open Metasyntax
-open Printer
-open Pp
-open Translate
-open Ascent
-open Vtp
-open Xlate
-
-let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);;
-
-let sps s =
-  ct_text s
-    ;;
-
-
-let sphs s =
-  ct_text s
-    ;;
-
-let spe = sphs "";;
-let spb = sps " ";;
-let spr = sps "Retour chariot pour Show proof";;
-
-let spnb n = 
-   let s = ref "" in
-   for i=1 to n do s:=(!s)^" "; done; sps !s
-;;
-
-
-let rec spclean l =
-  match l with 
-    [] -> []
-   |x::l -> if x=spe then (spclean l) else x::(spclean l)
-;;
-
-
-let spnb n = 
-   let s = ref "" in
-   for i=1 to n do s:=(!s)^" "; done; sps !s
-;;
-
-let ct_FORMULA_constr = Hashtbl.create 50;;
-
-let stde()  = (Global.env())
-
-;;
-
-let spt t =
-   let f = (translate_constr true (stde()) t) in
-   Hashtbl.add ct_FORMULA_constr f t;
-   CT_text_formula f
-;;
-
-
-
-let root_of_text_proof t=
-  CT_text_op [ct_text "root_of_text_proof";
-              t]
-    ;;
-    
-let spshrink info t =
-  CT_text_op [ct_text "shrink";
-	      CT_text_op [ct_text info;
-                          t]]
-;;
-			 
-let spuselemma intro x y =
-  CT_text_op [ct_text "uselemma";
-              ct_text intro;
-	      x;y]
-;;
-
-let sptoprove p t =
-  CT_text_op [ct_text "to_prove";
-	      CT_text_path p;
-              ct_text "goal";
-	      (spt t)]
-;;
-let sphyp p h t =
-  CT_text_op [ct_text "hyp";
-	      CT_text_path p;
-	      ct_text h;
-              (spt t)]
-;;
-let sphypt p h t =
-  CT_text_op [ct_text "hyp_with_type";
-	      CT_text_path p;
-	      ct_text h;
-              (spt t)]
-;;
-
-let spwithtac x t =
-    CT_text_op [ct_text "with_tactic";
-                ct_text t;
-                x]
-;;
-
-
-let spv l =
-   let l= spclean l in
-   CT_text_v l
-;;
-     
-let sph l =
-   let l= spclean l in
-   CT_text_h l
-;;
-
-
-let sphv l =
-   let l= spclean l in
-   CT_text_hv l
-;;
-
-let rec prlist_with_sep f g l =
-    match l with 
-      [] -> hov 0 (mt ())
-     |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1))
-;;
-   
-let rec sp_print x = 
-   match x with
-     | CT_coerce_ID_to_TEXT (CT_ident s)
-       -> (match s with
-	     | "\n" -> fnl ()
-	     | "Retour chariot pour Show proof" -> fnl ()
-	     |_ -> str s)
-     | CT_text_formula  f -> pr_lconstr (Hashtbl.find ct_FORMULA_constr f)
-     | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove");
-		   CT_text_path (CT_signed_int_list p);
-		   CT_coerce_ID_to_TEXT (CT_ident "goal");
-		   g] ->
-      let _p=(List.map (fun y -> match y with
-	                 (CT_coerce_INT_to_SIGNED_INT
-			      (CT_int x)) -> x
-		       | _ -> raise (Failure "sp_print")) p) in
-      h 0 (str "<b>" ++ sp_print g ++ str "</b>")
- |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma");
-              CT_coerce_ID_to_TEXT (CT_ident intro);
-	      l;g] ->
-      h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g)
- |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp");
-	      CT_text_path (CT_signed_int_list p);
-	      CT_coerce_ID_to_TEXT (CT_ident hyp);
-              g]  ->
-      let _p=(List.map (fun y -> match y with
-	                  (CT_coerce_INT_to_SIGNED_INT
-			      (CT_int x)) -> x
-		       | _ -> raise (Failure "sp_print")) p) in
-            h 0 (str hyp)
-
-  |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type");
-	      CT_text_path (CT_signed_int_list p);
-	      CT_coerce_ID_to_TEXT (CT_ident hyp);
-              g]  ->
-      let _p=(List.map (fun y -> match y with
-                         (CT_coerce_INT_to_SIGNED_INT
-			      (CT_int x)) -> x
-		       | _ -> raise (Failure "sp_print")) p) in
-      h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>")   
-
-  | CT_text_h l ->
-      h 0 (prlist_with_sep (fun () -> mt ())
-	     (fun y -> sp_print y) l)
-  | CT_text_v l ->
-      v 0 (prlist_with_sep (fun () -> mt ())
-		(fun y -> sp_print y) l)
-  | CT_text_hv l ->
-      h 0 (prlist_with_sep (fun () -> mt ())
-	     (fun y -> sp_print y) l)
-  | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink");
-	      CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]]  ->
-                   h 0 (str ("("^info^": ") ++ sp_print t ++ str ")")
-  | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof");
-              t]->
-                    sp_print t 
-  | _ -> str "..."
-;;
-  
diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml
deleted file mode 100644
index 559860b2..00000000
--- a/contrib/interface/translate.ml
+++ /dev/null
@@ -1,80 +0,0 @@
-open Names;;
-open Sign;;
-open Util;;
-open Term;;
-open Pp;;
-open Libobject;;
-open Library;;
-open Vernacinterp;;
-open Tacmach;;
-open Pfedit;;
-open Parsing;;
-open Evd;;
-open Evarutil;;
-
-open Xlate;;
-open Vtp;;
-open Ascent;;
-open Environ;;
-open Proof_type;;
-
-(*translates a formula into a centaur-tree --> FORMULA *)
-let translate_constr at_top env c =
-  xlate_formula (Constrextern.extern_constr at_top env c);;
-
-(*translates a named_context into a centaur-tree --> PREMISES_LIST *)
-(* this code is inspired from printer.ml (function pr_named_context_of) *)
-let translate_sign env =
-  let l = 
-    Environ.fold_named_context
-      (fun env (id,v,c) l -> 
-	 (match v with
-	      None ->
-	       	CT_premise(CT_ident(string_of_id id), translate_constr false env c)
-	    | Some v1 ->
-		CT_eval_result
-		  (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)),
-		   translate_constr false env v1,
-		   translate_constr false env c))::l)
-      env ~init:[] 
-  in
-  CT_premises_list l;;
-       
-(* the function rev_and_compact performs two operations:
-   1- it reverses the list of integers given as argument
-   2- it replaces sequences of "1" by a negative number that is
-      the length of the sequence. *)
-let rec rev_and_compact l = function
-    [] -> l
-  | 1::tl -> 
-      (match l with
-              n::tl' -> 
-        if n < 0 then
-          rev_and_compact ((n - 1)::tl') tl
-        else
-          rev_and_compact ((-1)::l) tl
-      |       [] -> rev_and_compact [-1] tl)
-  | a::tl ->
-      if a < 0 then
-      (match l with
-        n::tl' ->
-          if n < 0 then
-            rev_and_compact ((n + a)::tl') tl
-          else
-            rev_and_compact (a::l) tl
-      | [] -> rev_and_compact (a::l) tl)
-      else
-      rev_and_compact (a::l) tl;;
-
-(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *)
-let translate_path l =
- CT_signed_int_list
- (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n))
-    (rev_and_compact [] l));;
-
-(*translates a path and a goal into a centaur-tree --> RULE *)
-let translate_goal (g:goal) =
- CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);;
-
-let translate_goals (gl: goal list) =
- CT_rule_list (List.map translate_goal gl);;
diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli
deleted file mode 100644
index 34841fc4..00000000
--- a/contrib/interface/translate.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-open Ascent;;
-open Evd;;
-open Proof_type;;
-open Environ;;
-open Term;;
-
-val translate_goal : goal -> ct_RULE;;
-val translate_goals : goal list -> ct_RULE_LIST;;
-(* The boolean argument indicates whether names from the environment should *)
-(*  be avoided (same interpretation as for prterm_env and ast_of_constr)    *)
-val translate_constr : bool -> env -> constr -> ct_FORMULA;;
-val translate_path : int list -> ct_SIGNED_INT_LIST;;
diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc
deleted file mode 100644
index 4d3dc558..00000000
--- a/contrib/interface/vernacrc
+++ /dev/null
@@ -1,12 +0,0 @@
-# $Id: vernacrc 5202 2004-01-14 14:52:59Z bertot $
-
-# This file is loaded initially by ./vernacparser.
-
-load_syntax_file 1 Notations
-load_syntax_file 2 Logic
-load_syntax_file 34 Omega
-load_syntax_file 27 Ring
-quiet_parse_string
-Goal a.
-&& END--OF--DATA
-print_version
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
deleted file mode 100644
index 94609009..00000000
--- a/contrib/interface/vtp.ml
+++ /dev/null
@@ -1,1945 +0,0 @@
-open Ascent;;
-open Pp;;
-
-(* LEM: This is actually generated automatically *)
-
-let fNODE s n =
-    (str "n\n") ++
-    (str ("vernac$" ^ s)) ++
-    (str "\n") ++
-    (int n) ++
-    (str "\n");;
-
-let fATOM s1 =
-    (str "a\n") ++
-    (str ("vernac$" ^ s1)) ++
-    (str "\n");;
-
-let f_atom_string = str;;
-let f_atom_int = int;;
-let rec fAST = function
-| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x
-| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x
-| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x
-| CT_astnode(x1, x2) ->
-   fID x1 ++
-   fAST_LIST x2 ++
-   fNODE "astnode" 2
-| CT_astpath(x1) ->
-   fID_LIST x1 ++
-   fNODE "astpath" 1
-| CT_astslam(x1, x2) ->
-   fID_OPT x1 ++
-   fAST x2 ++
-   fNODE "astslam" 2
-and fAST_LIST = function
-| CT_ast_list l ->
-   (List.fold_left (++) (mt()) (List.map fAST l)) ++
-   fNODE "ast_list" (List.length l)
-and fBINARY = function
-| CT_binary x -> fATOM "binary" ++
-   (f_atom_int x) ++
-   str "\n"
-and fBINDER = function
-| CT_coerce_DEF_to_BINDER x -> fDEF x
-| CT_binder(x1, x2) ->
-   fID_OPT_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "binder" 2
-| CT_binder_coercion(x1, x2) ->
-   fID_OPT_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "binder_coercion" 2
-and fBINDER_LIST = function
-| CT_binder_list l ->
-   (List.fold_left (++) (mt()) (List.map fBINDER l)) ++
-   fNODE "binder_list" (List.length l)
-and fBINDER_NE_LIST = function
-| CT_binder_ne_list(x,l) ->
-   fBINDER x ++
-   (List.fold_left (++) (mt()) (List.map fBINDER l)) ++
-   fNODE "binder_ne_list" (1 + (List.length l))
-and fBINDING = function
-| CT_binding(x1, x2) ->
-   fID_OR_INT x1 ++
-   fFORMULA x2 ++
-   fNODE "binding" 2
-and fBINDING_LIST = function
-| CT_binding_list l ->
-   (List.fold_left (++) (mt()) (List.map fBINDING l)) ++
-   fNODE "binding_list" (List.length l)
-and fBOOL = function
-| CT_false -> fNODE "false" 0
-| CT_true -> fNODE "true" 0
-and fCASE = function
-| CT_case x -> fATOM "case" ++
-   (f_atom_string x) ++
-   str "\n"
-and fCLAUSE = function
-| CT_clause(x1, x2) ->
-   fHYP_LOCATION_LIST_OR_STAR x1 ++
-   fSTAR_OPT x2 ++
-   fNODE "clause" 2
-and fCOERCION_OPT = function
-| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x
-| CT_coercion_atm -> fNODE "coercion_atm" 0
-and fCOFIXTAC = function
-| CT_cofixtac(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "cofixtac" 2
-and fCOFIX_REC = function
-| CT_cofix_rec(x1, x2, x3, x4) ->
-   fID x1 ++
-   fBINDER_LIST x2 ++
-   fFORMULA x3 ++
-   fFORMULA x4 ++
-   fNODE "cofix_rec" 4
-and fCOFIX_REC_LIST = function
-| CT_cofix_rec_list(x,l) ->
-   fCOFIX_REC x ++
-   (List.fold_left (++) (mt()) (List.map fCOFIX_REC l)) ++
-   fNODE "cofix_rec_list" (1 + (List.length l))
-and fCOFIX_TAC_LIST = function
-| CT_cofix_tac_list l ->
-   (List.fold_left (++) (mt()) (List.map fCOFIXTAC l)) ++
-   fNODE "cofix_tac_list" (List.length l)
-and fCOMMAND = function
-| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x
-| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x
-| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x
-| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x
-| CT_abort(x1) ->
-   fID_OPT_OR_ALL x1 ++
-   fNODE "abort" 1
-| CT_abstraction(x1, x2, x3) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fINT_LIST x3 ++
-   fNODE "abstraction" 3
-| CT_add_field(x1, x2, x3, x4) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fFORMULA x3 ++
-   fFORMULA_OPT x4 ++
-   fNODE "add_field" 4
-| CT_add_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1 ++
-   fID x2 ++
-   fNODE "add_natural_feature" 2
-| CT_addpath(x1, x2) ->
-   fSTRING x1 ++
-   fID_OPT x2 ++
-   fNODE "addpath" 2
-| CT_arguments_scope(x1, x2) ->
-   fID x1 ++
-   fID_OPT_LIST x2 ++
-   fNODE "arguments_scope" 2
-| CT_bind_scope(x1, x2) ->
-   fID x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "bind_scope" 2
-| CT_cd(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "cd" 1
-| CT_check(x1) ->
-   fFORMULA x1 ++
-   fNODE "check" 1
-| CT_class(x1) ->
-   fID x1 ++
-   fNODE "class" 1
-| CT_close_scope(x1) ->
-   fID x1 ++
-   fNODE "close_scope" 1
-| CT_coercion(x1, x2, x3, x4, x5) ->
-   fLOCAL_OPT x1 ++
-   fIDENTITY_OPT x2 ++
-   fID x3 ++
-   fID x4 ++
-   fID x5 ++
-   fNODE "coercion" 5
-| CT_cofix_decl(x1) ->
-   fCOFIX_REC_LIST x1 ++
-   fNODE "cofix_decl" 1
-| CT_compile_module(x1, x2, x3) ->
-   fVERBOSE_OPT x1 ++
-   fID x2 ++
-   fSTRING_OPT x3 ++
-   fNODE "compile_module" 3
-| CT_declare_module(x1, x2, x3, x4) ->
-   fID x1 ++
-   fMODULE_BINDER_LIST x2 ++
-   fMODULE_TYPE_CHECK x3 ++
-   fMODULE_EXPR x4 ++
-   fNODE "declare_module" 4
-| CT_define_notation(x1, x2, x3, x4) ->
-   fSTRING x1 ++
-   fFORMULA x2 ++
-   fMODIFIER_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "define_notation" 4
-| CT_definition(x1, x2, x3, x4, x5) ->
-   fDEFN x1 ++
-   fID x2 ++
-   fBINDER_LIST x3 ++
-   fDEF_BODY x4 ++
-   fFORMULA_OPT x5 ++
-   fNODE "definition" 5
-| CT_delim_scope(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "delim_scope" 2
-| CT_delpath(x1) ->
-   fSTRING x1 ++
-   fNODE "delpath" 1
-| CT_derive_depinversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1 ++
-   fID x2 ++
-   fFORMULA x3 ++
-   fSORT_TYPE x4 ++
-   fNODE "derive_depinversion" 4
-| CT_derive_inversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1 ++
-   fINT_OPT x2 ++
-   fID x3 ++
-   fID x4 ++
-   fNODE "derive_inversion" 4
-| CT_derive_inversion_with(x1, x2, x3, x4) ->
-   fINV_TYPE x1 ++
-   fID x2 ++
-   fFORMULA x3 ++
-   fSORT_TYPE x4 ++
-   fNODE "derive_inversion_with" 4
-| CT_explain_proof(x1) ->
-   fINT_LIST x1 ++
-   fNODE "explain_proof" 1
-| CT_explain_prooftree(x1) ->
-   fINT_LIST x1 ++
-   fNODE "explain_prooftree" 1
-| CT_export_id(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "export_id" 1
-| CT_extract_to_file(x1, x2) ->
-   fSTRING x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "extract_to_file" 2
-| CT_extraction(x1) ->
-   fID_OPT x1 ++
-   fNODE "extraction" 1
-| CT_fix_decl(x1) ->
-   fFIX_REC_LIST x1 ++
-   fNODE "fix_decl" 1
-| CT_focus(x1) ->
-   fINT_OPT x1 ++
-   fNODE "focus" 1
-| CT_go(x1) ->
-   fINT_OR_LOCN x1 ++
-   fNODE "go" 1
-| CT_guarded -> fNODE "guarded" 0
-| CT_hint_destruct(x1, x2, x3, x4, x5, x6) ->
-   fID x1 ++
-   fINT x2 ++
-   fDESTRUCT_LOCATION x3 ++
-   fFORMULA x4 ++
-   fTACTIC_COM x5 ++
-   fID_LIST x6 ++
-   fNODE "hint_destruct" 6
-| CT_hint_extern(x1, x2, x3, x4) ->
-   fINT x1 ++
-   fFORMULA_OPT x2 ++
-   fTACTIC_COM x3 ++
-   fID_LIST x4 ++
-   fNODE "hint_extern" 4
-| CT_hintrewrite(x1, x2, x3, x4) ->
-   fORIENTATION x1 ++
-   fFORMULA_NE_LIST x2 ++
-   fID x3 ++
-   fTACTIC_COM x4 ++
-   fNODE "hintrewrite" 4
-| CT_hints(x1, x2, x3) ->
-   fID x1 ++
-   fID_NE_LIST x2 ++
-   fID_LIST x3 ++
-   fNODE "hints" 3
-| CT_hints_immediate(x1, x2) ->
-   fFORMULA_NE_LIST x1 ++
-   fID_LIST x2 ++
-   fNODE "hints_immediate" 2
-| CT_hints_resolve(x1, x2) ->
-   fFORMULA_NE_LIST x1 ++
-   fID_LIST x2 ++
-   fNODE "hints_resolve" 2
-| CT_hyp_search_pattern(x1, x2) ->
-   fFORMULA x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "hyp_search_pattern" 2
-| CT_implicits(x1, x2) ->
-   fID x1 ++
-   fID_LIST_OPT x2 ++
-   fNODE "implicits" 2
-| CT_import_id(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "import_id" 1
-| CT_ind_scheme(x1) ->
-   fSCHEME_SPEC_LIST x1 ++
-   fNODE "ind_scheme" 1
-| CT_infix(x1, x2, x3, x4) ->
-   fSTRING x1 ++
-   fID x2 ++
-   fMODIFIER_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "infix" 4
-| CT_inline(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "inline" 1
-| CT_inspect(x1) ->
-   fINT x1 ++
-   fNODE "inspect" 1
-| CT_kill_node(x1) ->
-   fINT x1 ++
-   fNODE "kill_node" 1
-| CT_load(x1, x2) ->
-   fVERBOSE_OPT x1 ++
-   fID_OR_STRING x2 ++
-   fNODE "load" 2
-| CT_local_close_scope(x1) ->
-   fID x1 ++
-   fNODE "local_close_scope" 1
-| CT_local_define_notation(x1, x2, x3, x4) ->
-   fSTRING x1 ++
-   fFORMULA x2 ++
-   fMODIFIER_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "local_define_notation" 4
-| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) ->
-   fID x1 ++
-   fINT x2 ++
-   fDESTRUCT_LOCATION x3 ++
-   fFORMULA x4 ++
-   fTACTIC_COM x5 ++
-   fID_LIST x6 ++
-   fNODE "local_hint_destruct" 6
-| CT_local_hint_extern(x1, x2, x3, x4) ->
-   fINT x1 ++
-   fFORMULA x2 ++
-   fTACTIC_COM x3 ++
-   fID_LIST x4 ++
-   fNODE "local_hint_extern" 4
-| CT_local_hints(x1, x2, x3) ->
-   fID x1 ++
-   fID_NE_LIST x2 ++
-   fID_LIST x3 ++
-   fNODE "local_hints" 3
-| CT_local_hints_immediate(x1, x2) ->
-   fFORMULA_NE_LIST x1 ++
-   fID_LIST x2 ++
-   fNODE "local_hints_immediate" 2
-| CT_local_hints_resolve(x1, x2) ->
-   fFORMULA_NE_LIST x1 ++
-   fID_LIST x2 ++
-   fNODE "local_hints_resolve" 2
-| CT_local_infix(x1, x2, x3, x4) ->
-   fSTRING x1 ++
-   fID x2 ++
-   fMODIFIER_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "local_infix" 4
-| CT_local_open_scope(x1) ->
-   fID x1 ++
-   fNODE "local_open_scope" 1
-| CT_local_reserve_notation(x1, x2) ->
-   fSTRING x1 ++
-   fMODIFIER_LIST x2 ++
-   fNODE "local_reserve_notation" 2
-| CT_locate(x1) ->
-   fID x1 ++
-   fNODE "locate" 1
-| CT_locate_file(x1) ->
-   fSTRING x1 ++
-   fNODE "locate_file" 1
-| CT_locate_lib(x1) ->
-   fID x1 ++
-   fNODE "locate_lib" 1
-| CT_locate_notation(x1) ->
-   fSTRING x1 ++
-   fNODE "locate_notation" 1
-| CT_mind_decl(x1, x2) ->
-   fCO_IND x1 ++
-   fIND_SPEC_LIST x2 ++
-   fNODE "mind_decl" 2
-| CT_ml_add_path(x1) ->
-   fSTRING x1 ++
-   fNODE "ml_add_path" 1
-| CT_ml_declare_modules(x1) ->
-   fSTRING_NE_LIST x1 ++
-   fNODE "ml_declare_modules" 1
-| CT_ml_print_modules -> fNODE "ml_print_modules" 0
-| CT_ml_print_path -> fNODE "ml_print_path" 0
-| CT_module(x1, x2, x3, x4) ->
-   fID x1 ++
-   fMODULE_BINDER_LIST x2 ++
-   fMODULE_TYPE_CHECK x3 ++
-   fMODULE_EXPR x4 ++
-   fNODE "module" 4
-| CT_module_type_decl(x1, x2, x3) ->
-   fID x1 ++
-   fMODULE_BINDER_LIST x2 ++
-   fMODULE_TYPE_OPT x3 ++
-   fNODE "module_type_decl" 3
-| CT_no_inline(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "no_inline" 1
-| CT_omega_flag(x1, x2) ->
-   fOMEGA_MODE x1 ++
-   fOMEGA_FEATURE x2 ++
-   fNODE "omega_flag" 2
-| CT_open_scope(x1) ->
-   fID x1 ++
-   fNODE "open_scope" 1
-| CT_print -> fNODE "print" 0
-| CT_print_about(x1) ->
-   fID x1 ++
-   fNODE "print_about" 1
-| CT_print_all -> fNODE "print_all" 0
-| CT_print_classes -> fNODE "print_classes" 0
-| CT_print_ltac id ->
-   fID id ++
-   fNODE "print_ltac" 1
-| CT_print_coercions -> fNODE "print_coercions" 0
-| CT_print_grammar(x1) ->
-   fGRAMMAR x1 ++
-   fNODE "print_grammar" 1
-| CT_print_graph -> fNODE "print_graph" 0
-| CT_print_hint(x1) ->
-   fID_OPT x1 ++
-   fNODE "print_hint" 1
-| CT_print_hintdb(x1) ->
-   fID_OR_STAR x1 ++
-   fNODE "print_hintdb" 1
-| CT_print_rewrite_hintdb(x1) ->
-   fID x1 ++
-   fNODE "print_rewrite_hintdb" 1
-| CT_print_id(x1) ->
-   fID x1 ++
-   fNODE "print_id" 1
-| CT_print_implicit(x1) ->
-   fID x1 ++
-   fNODE "print_implicit" 1
-| CT_print_loadpath -> fNODE "print_loadpath" 0
-| CT_print_module(x1) ->
-   fID x1 ++
-   fNODE "print_module" 1
-| CT_print_module_type(x1) ->
-   fID x1 ++
-   fNODE "print_module_type" 1
-| CT_print_modules -> fNODE "print_modules" 0
-| CT_print_natural(x1) ->
-   fID x1 ++
-   fNODE "print_natural" 1
-| CT_print_natural_feature(x1) ->
-   fNATURAL_FEATURE x1 ++
-   fNODE "print_natural_feature" 1
-| CT_print_opaqueid(x1) ->
-   fID x1 ++
-   fNODE "print_opaqueid" 1
-| CT_print_path(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "print_path" 2
-| CT_print_proof(x1) ->
-   fID x1 ++
-   fNODE "print_proof" 1
-| CT_print_scope(x1) ->
-   fID x1 ++
-   fNODE "print_scope" 1
-| CT_print_setoids -> fNODE "print_setoids" 0
-| CT_print_scopes -> fNODE "print_scopes" 0
-| CT_print_section(x1) ->
-   fID x1 ++
-   fNODE "print_section" 1
-| CT_print_states -> fNODE "print_states" 0
-| CT_print_tables -> fNODE "print_tables" 0
-| CT_print_universes(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "print_universes" 1
-| CT_print_visibility(x1) ->
-   fID_OPT x1 ++
-   fNODE "print_visibility" 1
-| CT_proof(x1) ->
-   fFORMULA x1 ++
-   fNODE "proof" 1
-| CT_proof_no_op -> fNODE "proof_no_op" 0
-| CT_proof_with(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "proof_with" 1
-| CT_pwd -> fNODE "pwd" 0
-| CT_quit -> fNODE "quit" 0
-| CT_read_module(x1) ->
-   fID x1 ++
-   fNODE "read_module" 1
-| CT_rec_ml_add_path(x1) ->
-   fSTRING x1 ++
-   fNODE "rec_ml_add_path" 1
-| CT_recaddpath(x1, x2) ->
-   fSTRING x1 ++
-   fID_OPT x2 ++
-   fNODE "recaddpath" 2
-| CT_record(x1, x2, x3, x4, x5, x6) ->
-   fCOERCION_OPT x1 ++
-   fID x2 ++
-   fBINDER_LIST x3 ++
-   fFORMULA x4 ++
-   fID_OPT x5 ++
-   fRECCONSTR_LIST x6 ++
-   fNODE "record" 6
-| CT_remove_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1 ++
-   fID x2 ++
-   fNODE "remove_natural_feature" 2
-| CT_require(x1, x2, x3) ->
-   fIMPEXP x1 ++
-   fSPEC_OPT x2 ++
-   fID_NE_LIST_OR_STRING x3 ++
-   fNODE "require" 3
-| CT_reserve(x1, x2) ->
-   fID_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "reserve" 2
-| CT_reserve_notation(x1, x2) ->
-   fSTRING x1 ++
-   fMODIFIER_LIST x2 ++
-   fNODE "reserve_notation" 2
-| CT_reset(x1) ->
-   fID x1 ++
-   fNODE "reset" 1
-| CT_reset_section(x1) ->
-   fID x1 ++
-   fNODE "reset_section" 1
-| CT_restart -> fNODE "restart" 0
-| CT_restore_state(x1) ->
-   fID x1 ++
-   fNODE "restore_state" 1
-| CT_resume(x1) ->
-   fID_OPT x1 ++
-   fNODE "resume" 1
-| CT_save(x1, x2) ->
-   fTHM_OPT x1 ++
-   fID_OPT x2 ++
-   fNODE "save" 2
-| CT_scomments(x1) ->
-   fSCOMMENT_CONTENT_LIST x1 ++
-   fNODE "scomments" 1
-| CT_search(x1, x2) ->
-   fID x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "search" 2
-| CT_search_about(x1, x2) ->
-   fID_OR_STRING_NE_LIST x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "search_about" 2
-| CT_search_pattern(x1, x2) ->
-   fFORMULA x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "search_pattern" 2
-| CT_search_rewrite(x1, x2) ->
-   fFORMULA x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "search_rewrite" 2
-| CT_section_end(x1) ->
-   fID x1 ++
-   fNODE "section_end" 1
-| CT_section_struct(x1, x2, x3) ->
-   fSECTION_BEGIN x1 ++
-   fSECTION_BODY x2 ++
-   fCOMMAND x3 ++
-   fNODE "section_struct" 3
-| CT_set_natural(x1) ->
-   fID x1 ++
-   fNODE "set_natural" 1
-| CT_set_natural_default -> fNODE "set_natural_default" 0
-| CT_set_option(x1) ->
-   fTABLE x1 ++
-   fNODE "set_option" 1
-| CT_set_option_value(x1, x2) ->
-   fTABLE x1 ++
-   fSINGLE_OPTION_VALUE x2 ++
-   fNODE "set_option_value" 2
-| CT_set_option_value2(x1, x2) ->
-   fTABLE x1 ++
-   fID_OR_STRING_NE_LIST x2 ++
-   fNODE "set_option_value2" 2
-| CT_sethyp(x1) ->
-   fINT x1 ++
-   fNODE "sethyp" 1
-| CT_setundo(x1) ->
-   fINT x1 ++
-   fNODE "setundo" 1
-| CT_show_existentials -> fNODE "show_existentials" 0
-| CT_show_goal(x1) ->
-   fINT_OPT x1 ++
-   fNODE "show_goal" 1
-| CT_show_implicit(x1) ->
-   fINT x1 ++
-   fNODE "show_implicit" 1
-| CT_show_intro -> fNODE "show_intro" 0
-| CT_show_intros -> fNODE "show_intros" 0
-| CT_show_node -> fNODE "show_node" 0
-| CT_show_proof -> fNODE "show_proof" 0
-| CT_show_proofs -> fNODE "show_proofs" 0
-| CT_show_script -> fNODE "show_script" 0
-| CT_show_tree -> fNODE "show_tree" 0
-| CT_solve(x1, x2, x3) ->
-   fINT x1 ++
-   fTACTIC_COM x2 ++
-   fDOTDOT_OPT x3 ++
-   fNODE "solve" 3
-| CT_strategy(CT_level_list x1) ->
-   List.fold_left (++) (mt())
-     (List.map (fun(l,q) -> fLEVEL l ++ fID_LIST q ++ fNODE "pair"2) x1) ++
-   fNODE "strategy" (List.length x1)
-| CT_suspend -> fNODE "suspend" 0
-| CT_syntax_macro(x1, x2, x3) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fINT_OPT x3 ++
-   fNODE "syntax_macro" 3
-| CT_tactic_definition(x1) ->
-   fTAC_DEF_NE_LIST x1 ++
-   fNODE "tactic_definition" 1
-| CT_test_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1 ++
-   fID x2 ++
-   fNODE "test_natural_feature" 2
-| CT_theorem_struct(x1, x2) ->
-   fTHEOREM_GOAL x1 ++
-   fPROOF_SCRIPT x2 ++
-   fNODE "theorem_struct" 2
-| CT_time(x1) ->
-   fCOMMAND x1 ++
-   fNODE "time" 1
-| CT_undo(x1) ->
-   fINT_OPT x1 ++
-   fNODE "undo" 1
-| CT_unfocus -> fNODE "unfocus" 0
-| CT_unset_option(x1) ->
-   fTABLE x1 ++
-   fNODE "unset_option" 1
-| CT_unsethyp -> fNODE "unsethyp" 0
-| CT_unsetundo -> fNODE "unsetundo" 0
-| CT_user_vernac(x1, x2) ->
-   fID x1 ++
-   fVARG_LIST x2 ++
-   fNODE "user_vernac" 2
-| CT_variable(x1, x2) ->
-   fVAR x1 ++
-   fBINDER_NE_LIST x2 ++
-   fNODE "variable" 2
-| CT_write_module(x1, x2) ->
-   fID x1 ++
-   fSTRING_OPT x2 ++
-   fNODE "write_module" 2
-and fLEVEL = function
-| CT_Opaque -> fNODE "opaque" 0
-| CT_Level n -> fINT n ++ fNODE "level" 1
-| CT_Expand -> fNODE "expand" 0
-and fCOMMAND_LIST = function
-| CT_command_list(x,l) ->
-   fCOMMAND x ++
-   (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
-   fNODE "command_list" (1 + (List.length l))
-and fCOMMENT = function
-| CT_comment x -> fATOM "comment" ++
-   (f_atom_string x) ++
-   str "\n"
-and fCOMMENT_S = function
-| CT_comment_s l ->
-   (List.fold_left (++) (mt()) (List.map fCOMMENT l)) ++
-   fNODE "comment_s" (List.length l)
-and fCONSTR = function
-| CT_constr(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "constr" 2
-| CT_constr_coercion(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "constr_coercion" 2
-and fCONSTR_LIST = function
-| CT_constr_list l ->
-   (List.fold_left (++) (mt()) (List.map fCONSTR l)) ++
-   fNODE "constr_list" (List.length l)
-and fCONTEXT_HYP_LIST = function
-| CT_context_hyp_list l ->
-   (List.fold_left (++) (mt()) (List.map fPREMISE_PATTERN l)) ++
-   fNODE "context_hyp_list" (List.length l)
-and fCONTEXT_PATTERN = function
-| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x
-| CT_context(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "context" 2
-and fCONTEXT_RULE = function
-| CT_context_rule(x1, x2, x3) ->
-   fCONTEXT_HYP_LIST x1 ++
-   fCONTEXT_PATTERN x2 ++
-   fTACTIC_COM x3 ++
-   fNODE "context_rule" 3
-| CT_def_context_rule(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "def_context_rule" 1
-and fCONVERSION_FLAG = function
-| CT_beta -> fNODE "beta" 0
-| CT_delta -> fNODE "delta" 0
-| CT_evar -> fNODE "evar" 0
-| CT_iota -> fNODE "iota" 0
-| CT_zeta -> fNODE "zeta" 0
-and fCONVERSION_FLAG_LIST = function
-| CT_conversion_flag_list l ->
-   (List.fold_left (++) (mt()) (List.map fCONVERSION_FLAG l)) ++
-   fNODE "conversion_flag_list" (List.length l)
-and fCONV_SET = function
-| CT_unf l ->
-   (List.fold_left (++) (mt()) (List.map fID l)) ++
-   fNODE "unf" (List.length l)
-| CT_unfbut l ->
-   (List.fold_left (++) (mt()) (List.map fID l)) ++
-   fNODE "unfbut" (List.length l)
-and fCO_IND = function
-| CT_co_ind x -> fATOM "co_ind" ++
-   (f_atom_string x) ++
-   str "\n"
-and fDECL_NOTATION_OPT = function
-| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x
-| CT_decl_notation(x1, x2, x3) ->
-   fSTRING x1 ++
-   fFORMULA x2 ++
-   fID_OPT x3 ++
-   fNODE "decl_notation" 3
-and fDEF = function
-| CT_def(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "def" 2
-and fDEFN = function
-| CT_defn x -> fATOM "defn" ++
-   (f_atom_string x) ++
-   str "\n"
-and fDEFN_OR_THM = function
-| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x
-| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x
-and fDEF_BODY = function
-| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x
-| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x
-| CT_type_of(x1) ->
-   fFORMULA x1 ++
-   fNODE "type_of" 1
-and fDEF_BODY_OPT = function
-| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x
-| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x
-and fDEP = function
-| CT_dep x -> fATOM "dep" ++
-   (f_atom_string x) ++
-   str "\n"
-and fDESTRUCTING = function
-| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x
-| CT_destructing -> fNODE "destructing" 0
-and fDESTRUCT_LOCATION = function
-| CT_conclusion_location -> fNODE "conclusion_location" 0
-| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0
-| CT_hypothesis_location -> fNODE "hypothesis_location" 0
-and fDOTDOT_OPT = function
-| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x
-| CT_dotdot -> fNODE "dotdot" 0
-and fEQN = function
-| CT_eqn(x1, x2) ->
-   fMATCH_PATTERN_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "eqn" 2
-and fEQN_LIST = function
-| CT_eqn_list l ->
-   (List.fold_left (++) (mt()) (List.map fEQN l)) ++
-   fNODE "eqn_list" (List.length l)
-and fEVAL_CMD = function
-| CT_eval(x1, x2, x3) ->
-   fINT_OPT x1 ++
-   fRED_COM x2 ++
-   fFORMULA x3 ++
-   fNODE "eval" 3
-and fFIXTAC = function
-| CT_fixtac(x1, x2, x3) ->
-   fID x1 ++
-   fINT x2 ++
-   fFORMULA x3 ++
-   fNODE "fixtac" 3
-and fFIX_BINDER = function
-| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x
-| CT_fix_binder(x1, x2, x3, x4) ->
-   fID x1 ++
-   fINT x2 ++
-   fFORMULA x3 ++
-   fFORMULA x4 ++
-   fNODE "fix_binder" 4
-and fFIX_BINDER_LIST = function
-| CT_fix_binder_list(x,l) ->
-   fFIX_BINDER x ++
-   (List.fold_left (++) (mt()) (List.map fFIX_BINDER l)) ++
-   fNODE "fix_binder_list" (1 + (List.length l))
-and fFIX_REC = function
-| CT_fix_rec(x1, x2, x3, x4, x5) ->
-   fID x1 ++
-   fBINDER_NE_LIST x2 ++
-   fID_OPT x3 ++
-   fFORMULA x4 ++
-   fFORMULA x5 ++
-   fNODE "fix_rec" 5
-and fFIX_REC_LIST = function
-| CT_fix_rec_list(x,l) ->
-   fFIX_REC x ++
-   (List.fold_left (++) (mt()) (List.map fFIX_REC l)) ++
-   fNODE "fix_rec_list" (1 + (List.length l))
-and fFIX_TAC_LIST = function
-| CT_fix_tac_list l ->
-   (List.fold_left (++) (mt()) (List.map fFIXTAC l)) ++
-   fNODE "fix_tac_list" (List.length l)
-and fFORMULA = function
-| CT_coerce_BINARY_to_FORMULA x -> fBINARY x
-| CT_coerce_ID_to_FORMULA x -> fID x
-| CT_coerce_NUM_to_FORMULA x -> fNUM x
-| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x
-| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x
-| CT_appc(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA_NE_LIST x2 ++
-   fNODE "appc" 2
-| CT_arrowc(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fNODE "arrowc" 2
-| CT_bang(x1) ->
-   fFORMULA x1 ++
-   fNODE "bang" 1
-| CT_cases(x1, x2, x3) ->
-   fMATCHED_FORMULA_NE_LIST x1 ++
-   fFORMULA_OPT x2 ++
-   fEQN_LIST x3 ++
-   fNODE "cases" 3
-| CT_cofixc(x1, x2) ->
-   fID x1 ++
-   fCOFIX_REC_LIST x2 ++
-   fNODE "cofixc" 2
-| CT_elimc(x1, x2, x3, x4) ->
-   fCASE x1 ++
-   fFORMULA_OPT x2 ++
-   fFORMULA x3 ++
-   fFORMULA_LIST x4 ++
-   fNODE "elimc" 4
-| CT_existvarc -> fNODE "existvarc" 0
-| CT_fixc(x1, x2) ->
-   fID x1 ++
-   fFIX_BINDER_LIST x2 ++
-   fNODE "fixc" 2
-| CT_if(x1, x2, x3, x4) ->
-   fFORMULA x1 ++
-   fRETURN_INFO x2 ++
-   fFORMULA x3 ++
-   fFORMULA x4 ++
-   fNODE "if" 4
-| CT_inductive_let(x1, x2, x3, x4) ->
-   fFORMULA_OPT x1 ++
-   fID_OPT_NE_LIST x2 ++
-   fFORMULA x3 ++
-   fFORMULA x4 ++
-   fNODE "inductive_let" 4
-| CT_labelled_arg(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "labelled_arg" 2
-| CT_lambdac(x1, x2) ->
-   fBINDER_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "lambdac" 2
-| CT_let_tuple(x1, x2, x3, x4) ->
-   fID_OPT_NE_LIST x1 ++
-   fRETURN_INFO x2 ++
-   fFORMULA x3 ++
-   fFORMULA x4 ++
-   fNODE "let_tuple" 4
-| CT_letin(x1, x2) ->
-   fDEF x1 ++
-   fFORMULA x2 ++
-   fNODE "letin" 2
-| CT_notation(x1, x2) ->
-   fSTRING x1 ++
-   fFORMULA_LIST x2 ++
-   fNODE "notation" 2
-| CT_num_encapsulator(x1, x2) ->
-   fNUM_TYPE x1 ++
-   fFORMULA x2 ++
-   fNODE "num_encapsulator" 2
-| CT_prodc(x1, x2) ->
-   fBINDER_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "prodc" 2
-| CT_proj(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA_NE_LIST x2 ++
-   fNODE "proj" 2
-and fFORMULA_LIST = function
-| CT_formula_list l ->
-   (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++
-   fNODE "formula_list" (List.length l)
-and fFORMULA_NE_LIST = function
-| CT_formula_ne_list(x,l) ->
-   fFORMULA x ++
-   (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++
-   fNODE "formula_ne_list" (1 + (List.length l))
-and fFORMULA_OPT = function
-| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x
-| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x
-and fFORMULA_OR_INT = function
-| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x
-| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x
-and fGRAMMAR = function
-| CT_grammar_none -> fNODE "grammar_none" 0
-and fHYP_LOCATION = function
-| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x
-| CT_intype(x1, x2) ->
-   fID x1 ++
-   fINT_LIST x2 ++
-   fNODE "intype" 2
-| CT_invalue(x1, x2) ->
-   fID x1 ++
-   fINT_LIST x2 ++
-   fNODE "invalue" 2
-and fHYP_LOCATION_LIST_OR_STAR = function
-| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x
-| CT_hyp_location_list l ->
-   (List.fold_left (++) (mt()) (List.map fHYP_LOCATION l)) ++
-   fNODE "hyp_location_list" (List.length l)
-and fID = function
-| CT_ident x -> fATOM "ident" ++
-   (f_atom_string x) ++
-   str "\n"
-| CT_metac(x1) ->
-   fINT x1 ++
-   fNODE "metac" 1
-| CT_metaid x -> fATOM "metaid" ++
-   (f_atom_string x) ++
-   str "\n"
-and fIDENTITY_OPT = function
-| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x
-| CT_identity -> fNODE "identity" 0
-and fID_LIST = function
-| CT_id_list l ->
-   (List.fold_left (++) (mt()) (List.map fID l)) ++
-   fNODE "id_list" (List.length l)
-and fID_LIST_LIST = function
-| CT_id_list_list l ->
-   (List.fold_left (++) (mt()) (List.map fID_LIST l)) ++
-   fNODE "id_list_list" (List.length l)
-and fID_LIST_OPT = function
-| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x
-| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x
-and fID_NE_LIST = function
-| CT_id_ne_list(x,l) ->
-   fID x ++
-   (List.fold_left (++) (mt()) (List.map fID l)) ++
-   fNODE "id_ne_list" (1 + (List.length l))
-and fID_NE_LIST_OR_STAR = function
-| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x
-| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x
-and fID_NE_LIST_OR_STRING = function
-| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x
-| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x
-and fID_OPT = function
-| CT_coerce_ID_to_ID_OPT x -> fID x
-| CT_coerce_NONE_to_ID_OPT x -> fNONE x
-and fID_OPT_LIST = function
-| CT_id_opt_list l ->
-   (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++
-   fNODE "id_opt_list" (List.length l)
-and fID_OPT_NE_LIST = function
-| CT_id_opt_ne_list(x,l) ->
-   fID_OPT x ++
-   (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++
-   fNODE "id_opt_ne_list" (1 + (List.length l))
-and fID_OPT_OR_ALL = function
-| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x
-| CT_all -> fNODE "all" 0
-and fID_OR_INT = function
-| CT_coerce_ID_to_ID_OR_INT x -> fID x
-| CT_coerce_INT_to_ID_OR_INT x -> fINT x
-and fID_OR_INT_OPT = function
-| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x
-| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x
-| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x
-and fID_OR_STAR = function
-| CT_coerce_ID_to_ID_OR_STAR x -> fID x
-| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x
-and fID_OR_STRING = function
-| CT_coerce_ID_to_ID_OR_STRING x -> fID x
-| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x
-and fID_OR_STRING_NE_LIST = function
-| CT_id_or_string_ne_list(x,l) ->
-   fID_OR_STRING x ++
-   (List.fold_left (++) (mt()) (List.map fID_OR_STRING l)) ++
-   fNODE "id_or_string_ne_list" (1 + (List.length l))
-and fIMPEXP = function
-| CT_coerce_NONE_to_IMPEXP x -> fNONE x
-| CT_export -> fNODE "export" 0
-| CT_import -> fNODE "import" 0
-and fIND_SPEC = function
-| CT_ind_spec(x1, x2, x3, x4, x5) ->
-   fID x1 ++
-   fBINDER_LIST x2 ++
-   fFORMULA x3 ++
-   fCONSTR_LIST x4 ++
-   fDECL_NOTATION_OPT x5 ++
-   fNODE "ind_spec" 5
-and fIND_SPEC_LIST = function
-| CT_ind_spec_list l ->
-   (List.fold_left (++) (mt()) (List.map fIND_SPEC l)) ++
-   fNODE "ind_spec_list" (List.length l)
-and fINT = function
-| CT_int x -> fATOM "int" ++
-   (f_atom_int x) ++
-   str "\n"
-and fINTRO_PATT = function
-| CT_coerce_ID_to_INTRO_PATT x -> fID x
-| CT_disj_pattern(x,l) ->
-   fINTRO_PATT_LIST x ++
-   (List.fold_left (++) (mt()) (List.map fINTRO_PATT_LIST l)) ++
-   fNODE "disj_pattern" (1 + (List.length l))
-and fINTRO_PATT_LIST = function
-| CT_intro_patt_list l ->
-   (List.fold_left (++) (mt()) (List.map fINTRO_PATT l)) ++
-   fNODE "intro_patt_list" (List.length l)
-and fINTRO_PATT_OPT = function
-| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x
-| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x
-and fINT_LIST = function
-| CT_int_list l ->
-   (List.fold_left (++) (mt()) (List.map fINT l)) ++
-   fNODE "int_list" (List.length l)
-and fINT_NE_LIST = function
-| CT_int_ne_list(x,l) ->
-   fINT x ++
-   (List.fold_left (++) (mt()) (List.map fINT l)) ++
-   fNODE "int_ne_list" (1 + (List.length l))
-and fINT_OPT = function
-| CT_coerce_INT_to_INT_OPT x -> fINT x
-| CT_coerce_NONE_to_INT_OPT x -> fNONE x
-and fINT_OR_LOCN = function
-| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x
-| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x
-and fINT_OR_NEXT = function
-| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x
-| CT_next_level -> fNODE "next_level" 0
-and fINV_TYPE = function
-| CT_inv_clear -> fNODE "inv_clear" 0
-| CT_inv_regular -> fNODE "inv_regular" 0
-| CT_inv_simple -> fNODE "inv_simple" 0
-and fIN_OR_OUT_MODULES = function
-| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x
-| CT_in_modules(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "in_modules" 1
-| CT_out_modules(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "out_modules" 1
-and fLET_CLAUSE = function
-| CT_let_clause(x1, x2, x3) ->
-   fID x1 ++
-   fTACTIC_OPT x2 ++
-   fLET_VALUE x3 ++
-   fNODE "let_clause" 3
-and fLET_CLAUSES = function
-| CT_let_clauses(x,l) ->
-   fLET_CLAUSE x ++
-   (List.fold_left (++) (mt()) (List.map fLET_CLAUSE l)) ++
-   fNODE "let_clauses" (1 + (List.length l))
-and fLET_VALUE = function
-| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x
-| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x
-and fLOCAL_OPT = function
-| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x
-| CT_local -> fNODE "local" 0
-and fLOCN = function
-| CT_locn x -> fATOM "locn" ++
-   (f_atom_string x) ++
-   str "\n"
-and fMATCHED_FORMULA = function
-| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x
-| CT_formula_as(x1, x2) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fNODE "formula_as" 2
-| CT_formula_as_in(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fFORMULA x3 ++
-   fNODE "formula_as_in" 3
-| CT_formula_in(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fNODE "formula_in" 2
-and fMATCHED_FORMULA_NE_LIST = function
-| CT_matched_formula_ne_list(x,l) ->
-   fMATCHED_FORMULA x ++
-   (List.fold_left (++) (mt()) (List.map fMATCHED_FORMULA l)) ++
-   fNODE "matched_formula_ne_list" (1 + (List.length l))
-and fMATCH_PATTERN = function
-| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x
-| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x
-| CT_pattern_app(x1, x2) ->
-   fMATCH_PATTERN x1 ++
-   fMATCH_PATTERN_NE_LIST x2 ++
-   fNODE "pattern_app" 2
-| CT_pattern_as(x1, x2) ->
-   fMATCH_PATTERN x1 ++
-   fID_OPT x2 ++
-   fNODE "pattern_as" 2
-| CT_pattern_delimitors(x1, x2) ->
-   fNUM_TYPE x1 ++
-   fMATCH_PATTERN x2 ++
-   fNODE "pattern_delimitors" 2
-| CT_pattern_notation(x1, x2) ->
-   fSTRING x1 ++
-   fMATCH_PATTERN_LIST x2 ++
-   fNODE "pattern_notation" 2
-and fMATCH_PATTERN_LIST = function
-| CT_match_pattern_list l ->
-   (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++
-   fNODE "match_pattern_list" (List.length l)
-and fMATCH_PATTERN_NE_LIST = function
-| CT_match_pattern_ne_list(x,l) ->
-   fMATCH_PATTERN x ++
-   (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++
-   fNODE "match_pattern_ne_list" (1 + (List.length l))
-and fMATCH_TAC_RULE = function
-| CT_match_tac_rule(x1, x2) ->
-   fCONTEXT_PATTERN x1 ++
-   fLET_VALUE x2 ++
-   fNODE "match_tac_rule" 2
-and fMATCH_TAC_RULES = function
-| CT_match_tac_rules(x,l) ->
-   fMATCH_TAC_RULE x ++
-   (List.fold_left (++) (mt()) (List.map fMATCH_TAC_RULE l)) ++
-   fNODE "match_tac_rules" (1 + (List.length l))
-and fMODIFIER = function
-| CT_entry_type(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "entry_type" 2
-| CT_format(x1) ->
-   fSTRING x1 ++
-   fNODE "format" 1
-| CT_lefta -> fNODE "lefta" 0
-| CT_nona -> fNODE "nona" 0
-| CT_only_parsing -> fNODE "only_parsing" 0
-| CT_righta -> fNODE "righta" 0
-| CT_set_item_level(x1, x2) ->
-   fID_NE_LIST x1 ++
-   fINT_OR_NEXT x2 ++
-   fNODE "set_item_level" 2
-| CT_set_level(x1) ->
-   fINT x1 ++
-   fNODE "set_level" 1
-and fMODIFIER_LIST = function
-| CT_modifier_list l ->
-   (List.fold_left (++) (mt()) (List.map fMODIFIER l)) ++
-   fNODE "modifier_list" (List.length l)
-and fMODULE_BINDER = function
-| CT_module_binder(x1, x2) ->
-   fID_NE_LIST x1 ++
-   fMODULE_TYPE x2 ++
-   fNODE "module_binder" 2
-and fMODULE_BINDER_LIST = function
-| CT_module_binder_list l ->
-   (List.fold_left (++) (mt()) (List.map fMODULE_BINDER l)) ++
-   fNODE "module_binder_list" (List.length l)
-and fMODULE_EXPR = function
-| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x
-| CT_module_app(x1, x2) ->
-   fMODULE_EXPR x1 ++
-   fMODULE_EXPR x2 ++
-   fNODE "module_app" 2
-and fMODULE_TYPE = function
-| CT_coerce_ID_to_MODULE_TYPE x -> fID x
-| CT_module_type_with_def(x1, x2, x3) ->
-   fMODULE_TYPE x1 ++
-   fID_LIST x2 ++
-   fFORMULA x3 ++
-   fNODE "module_type_with_def" 3
-| CT_module_type_with_mod(x1, x2, x3) ->
-   fMODULE_TYPE x1 ++
-   fID_LIST x2 ++
-   fID x3 ++
-   fNODE "module_type_with_mod" 3
-and fMODULE_TYPE_CHECK = function
-| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x
-| CT_only_check(x1) ->
-   fMODULE_TYPE x1 ++
-   fNODE "only_check" 1
-and fMODULE_TYPE_OPT = function
-| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x
-| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x
-and fNATURAL_FEATURE = function
-| CT_contractible -> fNODE "contractible" 0
-| CT_implicit -> fNODE "implicit" 0
-| CT_nat_transparent -> fNODE "nat_transparent" 0
-and fNONE = function
-| CT_none -> fNODE "none" 0
-and fNUM = function
-| CT_int_encapsulator x -> fATOM "int_encapsulator" ++
-   (f_atom_string x) ++
-   str "\n"
-and fNUM_TYPE = function
-| CT_num_type x -> fATOM "num_type" ++
-   (f_atom_string x) ++
-   str "\n"
-and fOMEGA_FEATURE = function
-| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x
-| CT_flag_action -> fNODE "flag_action" 0
-| CT_flag_system -> fNODE "flag_system" 0
-| CT_flag_time -> fNODE "flag_time" 0
-and fOMEGA_MODE = function
-| CT_set -> fNODE "set" 0
-| CT_switch -> fNODE "switch" 0
-| CT_unset -> fNODE "unset" 0
-and fORIENTATION = function
-| CT_lr -> fNODE "lr" 0
-| CT_rl -> fNODE "rl" 0
-and fPATTERN = function
-| CT_pattern_occ(x1, x2) ->
-   fINT_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "pattern_occ" 2
-and fPATTERN_NE_LIST = function
-| CT_pattern_ne_list(x,l) ->
-   fPATTERN x ++
-   (List.fold_left (++) (mt()) (List.map fPATTERN l)) ++
-   fNODE "pattern_ne_list" (1 + (List.length l))
-and fPATTERN_OPT = function
-| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x
-| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x
-and fPREMISE = function
-| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x
-| CT_eval_result(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fFORMULA x3 ++
-   fNODE "eval_result" 3
-| CT_premise(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "premise" 2
-and fPREMISES_LIST = function
-| CT_premises_list l ->
-   (List.fold_left (++) (mt()) (List.map fPREMISE l)) ++
-   fNODE "premises_list" (List.length l)
-and fPREMISE_PATTERN = function
-| CT_premise_pattern(x1, x2) ->
-   fID_OPT x1 ++
-   fCONTEXT_PATTERN x2 ++
-   fNODE "premise_pattern" 2
-and fPROOF_SCRIPT = function
-| CT_proof_script l ->
-   (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
-   fNODE "proof_script" (List.length l)
-and fRECCONSTR = function
-| CT_defrecconstr(x1, x2, x3) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fFORMULA_OPT x3 ++
-   fNODE "defrecconstr" 3
-| CT_defrecconstr_coercion(x1, x2, x3) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fFORMULA_OPT x3 ++
-   fNODE "defrecconstr_coercion" 3
-| CT_recconstr(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "recconstr" 2
-| CT_recconstr_coercion(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "recconstr_coercion" 2
-and fRECCONSTR_LIST = function
-| CT_recconstr_list l ->
-   (List.fold_left (++) (mt()) (List.map fRECCONSTR l)) ++
-   fNODE "recconstr_list" (List.length l)
-and fREC_TACTIC_FUN = function
-| CT_rec_tactic_fun(x1, x2, x3) ->
-   fID x1 ++
-   fID_OPT_NE_LIST x2 ++
-   fTACTIC_COM x3 ++
-   fNODE "rec_tactic_fun" 3
-and fREC_TACTIC_FUN_LIST = function
-| CT_rec_tactic_fun_list(x,l) ->
-   fREC_TACTIC_FUN x ++
-   (List.fold_left (++) (mt()) (List.map fREC_TACTIC_FUN l)) ++
-   fNODE "rec_tactic_fun_list" (1 + (List.length l))
-and fRED_COM = function
-| CT_cbv(x1, x2) ->
-   fCONVERSION_FLAG_LIST x1 ++
-   fCONV_SET x2 ++
-   fNODE "cbv" 2
-| CT_fold(x1) ->
-   fFORMULA_LIST x1 ++
-   fNODE "fold" 1
-| CT_hnf -> fNODE "hnf" 0
-| CT_lazy(x1, x2) ->
-   fCONVERSION_FLAG_LIST x1 ++
-   fCONV_SET x2 ++
-   fNODE "lazy" 2
-| CT_pattern(x1) ->
-   fPATTERN_NE_LIST x1 ++
-   fNODE "pattern" 1
-| CT_red -> fNODE "red" 0
-| CT_cbvvm -> fNODE "vm_compute" 0
-| CT_simpl(x1) ->
-   fPATTERN_OPT x1 ++
-   fNODE "simpl" 1
-| CT_unfold(x1) ->
-   fUNFOLD_NE_LIST x1 ++
-   fNODE "unfold" 1
-and fRETURN_INFO = function
-| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x
-| CT_as_and_return(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "as_and_return" 2
-| CT_return(x1) ->
-   fFORMULA x1 ++
-   fNODE "return" 1
-and fRULE = function
-| CT_rule(x1, x2) ->
-   fPREMISES_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "rule" 2
-and fRULE_LIST = function
-| CT_rule_list l ->
-   (List.fold_left (++) (mt()) (List.map fRULE l)) ++
-   fNODE "rule_list" (List.length l)
-and fSCHEME_SPEC = function
-| CT_scheme_spec(x1, x2, x3, x4) ->
-   fID x1 ++
-   fDEP x2 ++
-   fFORMULA x3 ++
-   fSORT_TYPE x4 ++
-   fNODE "scheme_spec" 4
-and fSCHEME_SPEC_LIST = function
-| CT_scheme_spec_list(x,l) ->
-   fSCHEME_SPEC x ++
-   (List.fold_left (++) (mt()) (List.map fSCHEME_SPEC l)) ++
-   fNODE "scheme_spec_list" (1 + (List.length l))
-and fSCOMMENT_CONTENT = function
-| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x
-| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x
-and fSCOMMENT_CONTENT_LIST = function
-| CT_scomment_content_list l ->
-   (List.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++
-   fNODE "scomment_content_list" (List.length l)
-and fSECTION_BEGIN = function
-| CT_section(x1) ->
-   fID x1 ++
-   fNODE "section" 1
-and fSECTION_BODY = function
-| CT_section_body l ->
-   (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
-   fNODE "section_body" (List.length l)
-and fSIGNED_INT = function
-| CT_coerce_INT_to_SIGNED_INT x -> fINT x
-| CT_minus(x1) ->
-   fINT x1 ++
-   fNODE "minus" 1
-and fSIGNED_INT_LIST = function
-| CT_signed_int_list l ->
-   (List.fold_left (++) (mt()) (List.map fSIGNED_INT l)) ++
-   fNODE "signed_int_list" (List.length l)
-and fSINGLE_OPTION_VALUE = function
-| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x
-| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x
-and fSORT_TYPE = function
-| CT_sortc x -> fATOM "sortc" ++
-   (f_atom_string x) ++
-   str "\n"
-and fSPEC_LIST = function
-| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x
-| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x
-and fSPEC_OPT = function
-| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x
-| CT_spec -> fNODE "spec" 0
-and fSTAR = function
-| CT_star -> fNODE "star" 0
-and fSTAR_OPT = function
-| CT_coerce_NONE_to_STAR_OPT x -> fNONE x
-| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x
-and fSTRING = function
-| CT_string x -> fATOM "string" ++
-   (f_atom_string x) ++
-   str "\n"
-and fSTRING_NE_LIST = function
-| CT_string_ne_list(x,l) ->
-   fSTRING x ++
-   (List.fold_left (++) (mt()) (List.map fSTRING l)) ++
-   fNODE "string_ne_list" (1 + (List.length l))
-and fSTRING_OPT = function
-| CT_coerce_NONE_to_STRING_OPT x -> fNONE x
-| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x
-and fTABLE = function
-| CT_coerce_ID_to_TABLE x -> fID x
-| CT_table(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "table" 2
-and fTACTIC_ARG = function
-| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x
-| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x
-| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x
-| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x
-| CT_void -> fNODE "void" 0
-and fTACTIC_ARG_LIST = function
-| CT_tactic_arg_list(x,l) ->
-   fTACTIC_ARG x ++
-   (List.fold_left (++) (mt()) (List.map fTACTIC_ARG l)) ++
-   fNODE "tactic_arg_list" (1 + (List.length l))
-and fTACTIC_COM = function
-| CT_abstract(x1, x2) ->
-   fID_OPT x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "abstract" 2
-| CT_absurd(x1) ->
-   fFORMULA x1 ++
-   fNODE "absurd" 1
-| CT_any_constructor(x1) ->
-   fTACTIC_OPT x1 ++
-   fNODE "any_constructor" 1
-| CT_apply(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "apply" 2
-| CT_assert(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "assert" 2
-| CT_assumption -> fNODE "assumption" 0
-| CT_auto(x1) ->
-   fINT_OPT x1 ++
-   fNODE "auto" 1
-| CT_auto_with(x1, x2) ->
-   fINT_OPT x1 ++
-   fID_NE_LIST_OR_STAR x2 ++
-   fNODE "auto_with" 2
-| CT_autorewrite(x1, x2) ->
-   fID_NE_LIST x1 ++
-   fTACTIC_OPT x2 ++
-   fNODE "autorewrite" 2
-| CT_autotdb(x1) ->
-   fINT_OPT x1 ++
-   fNODE "autotdb" 1
-| CT_case_type(x1) ->
-   fFORMULA x1 ++
-   fNODE "case_type" 1
-| CT_casetac(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "casetac" 2
-| CT_cdhyp(x1) ->
-   fID x1 ++
-   fNODE "cdhyp" 1
-| CT_change(x1, x2) ->
-   fFORMULA x1 ++
-   fCLAUSE x2 ++
-   fNODE "change" 2
-| CT_change_local(x1, x2, x3) ->
-   fPATTERN x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fNODE "change_local" 3
-| CT_clear(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "clear" 1
-| CT_clear_body(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "clear_body" 1
-| CT_cofixtactic(x1, x2) ->
-   fID_OPT x1 ++
-   fCOFIX_TAC_LIST x2 ++
-   fNODE "cofixtactic" 2
-| CT_condrewrite_lr(x1, x2, x3, x4) ->
-   fTACTIC_COM x1 ++
-   fFORMULA x2 ++
-   fSPEC_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "condrewrite_lr" 4
-| CT_condrewrite_rl(x1, x2, x3, x4) ->
-   fTACTIC_COM x1 ++
-   fFORMULA x2 ++
-   fSPEC_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "condrewrite_rl" 4
-| CT_constructor(x1, x2) ->
-   fINT x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "constructor" 2
-| CT_contradiction -> fNODE "contradiction" 0
-| CT_contradiction_thm(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "contradiction_thm" 2
-| CT_cut(x1) ->
-   fFORMULA x1 ++
-   fNODE "cut" 1
-| CT_cutrewrite_lr(x1, x2) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fNODE "cutrewrite_lr" 2
-| CT_cutrewrite_rl(x1, x2) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fNODE "cutrewrite_rl" 2
-| CT_dauto(x1, x2) ->
-   fINT_OPT x1 ++
-   fINT_OPT x2 ++
-   fNODE "dauto" 2
-| CT_dconcl -> fNODE "dconcl" 0
-| CT_decompose_list(x1, x2) ->
-   fID_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "decompose_list" 2
-| CT_decompose_record(x1) ->
-   fFORMULA x1 ++
-   fNODE "decompose_record" 1
-| CT_decompose_sum(x1) ->
-   fFORMULA x1 ++
-   fNODE "decompose_sum" 1
-| CT_depinversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1 ++
-   fID_OR_INT x2 ++
-   fINTRO_PATT_OPT x3 ++
-   fFORMULA_OPT x4 ++
-   fNODE "depinversion" 4
-| CT_deprewrite_lr(x1) ->
-   fID x1 ++
-   fNODE "deprewrite_lr" 1
-| CT_deprewrite_rl(x1) ->
-   fID x1 ++
-   fNODE "deprewrite_rl" 1
-| CT_destruct(x1) ->
-   fID_OR_INT x1 ++
-   fNODE "destruct" 1
-| CT_dhyp(x1) ->
-   fID x1 ++
-   fNODE "dhyp" 1
-| CT_discriminate_eq(x1) ->
-   fID_OR_INT_OPT x1 ++
-   fNODE "discriminate_eq" 1
-| CT_do(x1, x2) ->
-   fID_OR_INT x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "do" 2
-| CT_eapply(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "eapply" 2
-| CT_eauto(x1, x2) ->
-   fID_OR_INT_OPT x1 ++
-   fID_OR_INT_OPT x2 ++
-   fNODE "eauto" 2
-| CT_eauto_with(x1, x2, x3) ->
-   fID_OR_INT_OPT x1 ++
-   fID_OR_INT_OPT x2 ++
-   fID_NE_LIST_OR_STAR x3 ++
-   fNODE "eauto_with" 3
-| CT_elim(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fUSING x3 ++
-   fNODE "elim" 3
-| CT_elim_type(x1) ->
-   fFORMULA x1 ++
-   fNODE "elim_type" 1
-| CT_exact(x1) ->
-   fFORMULA x1 ++
-   fNODE "exact" 1
-| CT_exact_no_check(x1) ->
-   fFORMULA x1 ++
-   fNODE "exact_no_check" 1
-| CT_vm_cast_no_check(x1) ->
-   fFORMULA x1 ++
-   fNODE "vm_cast_no_check" 1
-| CT_exists(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "exists" 1
-| CT_fail(x1, x2) ->
-   fID_OR_INT x1 ++
-   fSTRING_OPT x2 ++
-   fNODE "fail" 2
-| CT_first(x,l) ->
-   fTACTIC_COM x ++
-   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
-   fNODE "first" (1 + (List.length l))
-| CT_firstorder(x1) ->
-   fTACTIC_OPT x1 ++
-   fNODE "firstorder" 1
-| CT_firstorder_using(x1, x2) ->
-   fTACTIC_OPT x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "firstorder_using" 2
-| CT_firstorder_with(x1, x2) ->
-   fTACTIC_OPT x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "firstorder_with" 2
-| CT_fixtactic(x1, x2, x3) ->
-   fID_OPT x1 ++
-   fINT x2 ++
-   fFIX_TAC_LIST x3 ++
-   fNODE "fixtactic" 3
-| CT_formula_marker(x1) ->
-   fFORMULA x1 ++
-   fNODE "formula_marker" 1
-| CT_fresh(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "fresh" 1
-| CT_generalize(x1) ->
-   fFORMULA_NE_LIST x1 ++
-   fNODE "generalize" 1
-| CT_generalize_dependent(x1) ->
-   fFORMULA x1 ++
-   fNODE "generalize_dependent" 1
-| CT_idtac(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "idtac" 1
-| CT_induction(x1) ->
-   fID_OR_INT x1 ++
-   fNODE "induction" 1
-| CT_info(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "info" 1
-| CT_injection_eq(x1) ->
-   fID_OR_INT_OPT x1 ++
-   fNODE "injection_eq" 1
-| CT_instantiate(x1, x2, x3) ->
-   fINT x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fNODE "instantiate" 3
-| CT_intro(x1) ->
-   fID_OPT x1 ++
-   fNODE "intro" 1
-| CT_intro_after(x1, x2) ->
-   fID_OPT x1 ++
-   fID x2 ++
-   fNODE "intro_after" 2
-| CT_intros(x1) ->
-   fINTRO_PATT_LIST x1 ++
-   fNODE "intros" 1
-| CT_intros_until(x1) ->
-   fID_OR_INT x1 ++
-   fNODE "intros_until" 1
-| CT_inversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1 ++
-   fID_OR_INT x2 ++
-   fINTRO_PATT_OPT x3 ++
-   fID_LIST x4 ++
-   fNODE "inversion" 4
-| CT_left(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "left" 1
-| CT_let_ltac(x1, x2) ->
-   fLET_CLAUSES x1 ++
-   fLET_VALUE x2 ++
-   fNODE "let_ltac" 2
-| CT_lettac(x1, x2, x3) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fNODE "lettac" 3
-| CT_match_context(x,l) ->
-   fCONTEXT_RULE x ++
-   (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++
-   fNODE "match_context" (1 + (List.length l))
-| CT_match_context_reverse(x,l) ->
-   fCONTEXT_RULE x ++
-   (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++
-   fNODE "match_context_reverse" (1 + (List.length l))
-| CT_match_tac(x1, x2) ->
-   fTACTIC_COM x1 ++
-   fMATCH_TAC_RULES x2 ++
-   fNODE "match_tac" 2
-| CT_move_after(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "move_after" 2
-| CT_new_destruct(x1, x2, x3) ->
-   (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Julien F. Est-ce correct? *)
-   fUSING x2 ++
-   fINTRO_PATT_OPT x3 ++
-   fNODE "new_destruct" 3
-| CT_new_induction(x1, x2, x3) ->
-   (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Pierre C. Est-ce correct? *)
-   fUSING x2 ++
-   fINTRO_PATT_OPT x3 ++
-   fNODE "new_induction" 3
-| CT_omega -> fNODE "omega" 0
-| CT_orelse(x1, x2) ->
-   fTACTIC_COM x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "orelse" 2
-| CT_parallel(x,l) ->
-   fTACTIC_COM x ++
-   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
-   fNODE "parallel" (1 + (List.length l))
-| CT_pose(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "pose" 2
-| CT_progress(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "progress" 1
-| CT_prolog(x1, x2) ->
-   fFORMULA_LIST x1 ++
-   fINT x2 ++
-   fNODE "prolog" 2
-| CT_rec_tactic_in(x1, x2) ->
-   fREC_TACTIC_FUN_LIST x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "rec_tactic_in" 2
-| CT_reduce(x1, x2) ->
-   fRED_COM x1 ++
-   fCLAUSE x2 ++
-   fNODE "reduce" 2
-| CT_refine(x1) ->
-   fFORMULA x1 ++
-   fNODE "refine" 1
-| CT_reflexivity -> fNODE "reflexivity" 0
-| CT_rename(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "rename" 2
-| CT_repeat(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "repeat" 1
-| CT_replace_with(x1, x2,x3,x4) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fTACTIC_OPT x4 ++
-   fNODE "replace_with" 4
-| CT_rewrite_lr(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fCLAUSE x3 ++
-   fNODE "rewrite_lr" 3
-| CT_rewrite_rl(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fCLAUSE x3 ++
-   fNODE "rewrite_rl" 3
-| CT_right(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "right" 1
-| CT_ring(x1) ->
-   fFORMULA_LIST x1 ++
-   fNODE "ring" 1
-| CT_simple_user_tac(x1, x2) ->
-   fID x1 ++
-   fTACTIC_ARG_LIST x2 ++
-   fNODE "simple_user_tac" 2
-| CT_simplify_eq(x1) ->
-   fID_OR_INT_OPT x1 ++
-   fNODE "simplify_eq" 1
-| CT_specialize(x1, x2, x3) ->
-   fINT_OPT x1 ++
-   fFORMULA x2 ++
-   fSPEC_LIST x3 ++
-   fNODE "specialize" 3
-| CT_split(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "split" 1
-| CT_subst(x1) ->
-   fID_LIST x1 ++
-   fNODE "subst" 1
-| CT_superauto(x1, x2, x3, x4) ->
-   fINT_OPT x1 ++
-   fID_LIST x2 ++
-   fDESTRUCTING x3 ++
-   fUSINGTDB x4 ++
-   fNODE "superauto" 4
-| CT_symmetry(x1) ->
-   fCLAUSE x1 ++
-   fNODE "symmetry" 1
-| CT_tac_double(x1, x2) ->
-   fID_OR_INT x1 ++
-   fID_OR_INT x2 ++
-   fNODE "tac_double" 2
-| CT_tacsolve(x,l) ->
-   fTACTIC_COM x ++
-   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
-   fNODE "tacsolve" (1 + (List.length l))
-| CT_tactic_fun(x1, x2) ->
-   fID_OPT_NE_LIST x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "tactic_fun" 2
-| CT_then(x,l) ->
-   fTACTIC_COM x ++
-   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
-   fNODE "then" (1 + (List.length l))
-| CT_transitivity(x1) ->
-   fFORMULA x1 ++
-   fNODE "transitivity" 1
-| CT_trivial -> fNODE "trivial" 0
-| CT_trivial_with(x1) ->
-   fID_NE_LIST_OR_STAR x1 ++
-   fNODE "trivial_with" 1
-| CT_truecut(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "truecut" 2
-| CT_try(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "try" 1
-| CT_use(x1) ->
-   fFORMULA x1 ++
-   fNODE "use" 1
-| CT_use_inversion(x1, x2, x3) ->
-   fID_OR_INT x1 ++
-   fFORMULA x2 ++
-   fID_LIST x3 ++
-   fNODE "use_inversion" 3
-| CT_user_tac(x1, x2) ->
-   fID x1 ++
-   fTARG_LIST x2 ++
-   fNODE "user_tac" 2
-and fTACTIC_OPT = function
-| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x
-| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x
-and fTAC_DEF = function
-| CT_tac_def(x1, x2) ->
-   fID x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "tac_def" 2
-and fTAC_DEF_NE_LIST = function
-| CT_tac_def_ne_list(x,l) ->
-   fTAC_DEF x ++
-   (List.fold_left (++) (mt()) (List.map fTAC_DEF l)) ++
-   fNODE "tac_def_ne_list" (1 + (List.length l))
-and fTARG = function
-| CT_coerce_BINDING_to_TARG x -> fBINDING x
-| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x
-| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x
-| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x
-| CT_coerce_PATTERN_to_TARG x -> fPATTERN x
-| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x
-| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x
-| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x
-| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x
-| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x
-| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x
-| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x
-| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x
-and fTARG_LIST = function
-| CT_targ_list l ->
-   (List.fold_left (++) (mt()) (List.map fTARG l)) ++
-   fNODE "targ_list" (List.length l)
-and fTERM_CHANGE = function
-| CT_check_term(x1) ->
-   fFORMULA x1 ++
-   fNODE "check_term" 1
-| CT_inst_term(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "inst_term" 2
-and fTEXT = function
-| CT_coerce_ID_to_TEXT x -> fID x
-| CT_text_formula(x1) ->
-   fFORMULA x1 ++
-   fNODE "text_formula" 1
-| CT_text_h l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_h" (List.length l)
-| CT_text_hv l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_hv" (List.length l)
-| CT_text_op l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_op" (List.length l)
-| CT_text_path(x1) ->
-   fSIGNED_INT_LIST x1 ++
-   fNODE "text_path" 1
-| CT_text_v l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_v" (List.length l)
-and fTHEOREM_GOAL = function
-| CT_goal(x1) ->
-   fFORMULA x1 ++
-   fNODE "goal" 1
-| CT_theorem_goal(x1, x2, x3, x4) ->
-   fDEFN_OR_THM x1 ++
-   fID x2 ++
-   fBINDER_LIST x3 ++
-   fFORMULA x4 ++
-   fNODE "theorem_goal" 4
-and fTHM = function
-| CT_thm x -> fATOM "thm" ++
-   (f_atom_string x) ++
-   str "\n"
-and fTHM_OPT = function
-| CT_coerce_NONE_to_THM_OPT x -> fNONE x
-| CT_coerce_THM_to_THM_OPT x -> fTHM x
-and fTYPED_FORMULA = function
-| CT_typed_formula(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fNODE "typed_formula" 2
-and fUNFOLD = function
-| CT_coerce_ID_to_UNFOLD x -> fID x
-| CT_unfold_occ(x1, x2) ->
-   fID x1 ++
-   fINT_NE_LIST x2 ++
-   fNODE "unfold_occ" 2
-and fUNFOLD_NE_LIST = function
-| CT_unfold_ne_list(x,l) ->
-   fUNFOLD x ++
-   (List.fold_left (++) (mt()) (List.map fUNFOLD l)) ++
-   fNODE "unfold_ne_list" (1 + (List.length l))
-and fUSING = function
-| CT_coerce_NONE_to_USING x -> fNONE x
-| CT_using(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "using" 2
-and fUSINGTDB = function
-| CT_coerce_NONE_to_USINGTDB x -> fNONE x
-| CT_usingtdb -> fNODE "usingtdb" 0
-and fVAR = function
-| CT_var x -> fATOM "var" ++
-   (f_atom_string x) ++
-   str "\n"
-and fVARG = function
-| CT_coerce_AST_to_VARG x -> fAST x
-| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x
-| CT_coerce_BINDER_to_VARG x -> fBINDER x
-| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x
-| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x
-| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x
-| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x
-| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x
-| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x
-| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x
-| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x
-| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x
-| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x
-| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x
-| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x
-and fVARG_LIST = function
-| CT_varg_list l ->
-   (List.fold_left (++) (mt()) (List.map fVARG l)) ++
-   fNODE "varg_list" (List.length l)
-and fVERBOSE_OPT = function
-| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x
-| CT_verbose -> fNODE "verbose" 0
-;;
diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli
deleted file mode 100644
index d7bd8db5..00000000
--- a/contrib/interface/vtp.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-open Ascent;;
-open Pp;;
-
-val fCOMMAND_LIST : ct_COMMAND_LIST -> std_ppcmds;;
-val fCOMMAND : ct_COMMAND -> std_ppcmds;;
-val fTACTIC_COM : ct_TACTIC_COM -> std_ppcmds;;
-val fFORMULA : ct_FORMULA -> std_ppcmds;;
-val fID : ct_ID -> std_ppcmds;;
-val fSTRING : ct_STRING -> std_ppcmds;;
-val fINT : ct_INT -> std_ppcmds;;
-val fRULE_LIST : ct_RULE_LIST -> std_ppcmds;;
-val fRULE : ct_RULE -> std_ppcmds;;
-val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> std_ppcmds;;
-val fPREMISES_LIST : ct_PREMISES_LIST -> std_ppcmds;;
-val fID_LIST : ct_ID_LIST -> std_ppcmds;;
-val fTEXT : ct_TEXT -> std_ppcmds;;
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
deleted file mode 100644
index e3cd56a0..00000000
--- a/contrib/interface/xlate.ml
+++ /dev/null
@@ -1,2267 +0,0 @@
-(** Translation from coq abstract syntax trees to centaur vernac
-   *)
-open String;;
-open Char;;
-open Util;;
-open Names;;
-open Ascent;;
-open Genarg;;
-open Rawterm;;
-open Termops;;
-open Tacexpr;;
-open Vernacexpr;;
-open Decl_kinds;;
-open Topconstr;;
-open Libnames;;
-open Goptions;;
-
-
-(* // Verify whether this is dead code, as of coq version 7 *)
-(* The following three sentences have been added to cope with a change 
-of strategy from the Coq team in the way rules construct ast's.  The
-problem is that now grammar rules will refer to identifiers by giving
-their absolute name, using the mutconstruct when needed.  Unfortunately,
-when you have a mutconstruct structure, you don't have a way to guess
-the corresponding identifier without an environment, and the parser
-does not have an environment.  We add one, only for the constructs
-that are always loaded. *)
-let type_table = ((Hashtbl.create 17) :
-      (string, ((string array) array)) Hashtbl.t);;
-
-Hashtbl.add type_table "Coq.Init.Logic.and"
-  [|[|"dummy";"conj"|]|];;
-
-Hashtbl.add type_table "Coq.Init.Datatypes.prod"
-  [|[|"dummy";"pair"|]|];;
-
-Hashtbl.add type_table "Coq.Init.Datatypes.nat"
-  [|[|"";"O"; "S"|]|];;
-
-Hashtbl.add type_table "Coq.ZArith.fast_integer.Z"
-[|[|"";"ZERO";"POS";"NEG"|]|];;
-
-
-Hashtbl.add type_table "Coq.ZArith.fast_integer.positive"
-[|[|"";"xI";"xO";"xH"|]|];;
-
-(*The following two codes are added to cope with the distinction
-  between ocaml and caml-light syntax while using ctcaml to
-  manipulate the program *)
-let code_plus = code (get "+" 0);;
-
-let code_minus = code (get "-" 0);;
-
-let coercion_description_holder = ref (function _ -> None : t -> int option);;
-
-let coercion_description t = !coercion_description_holder t;;
-
-let set_coercion_description f =
- coercion_description_holder:=f; ();;
-
-let xlate_error s = print_endline ("xlate_error : "^s);failwith ("Translation error: " ^ s);;
-
-let ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;;
-
-let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;;
-
-let ctf_STRING_OPT = function
-  | None -> ctf_STRING_OPT_NONE
-  | Some s -> ctf_STRING_OPT_SOME (CT_string s)
-
-let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;;
-
-let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;;
-
-let ctv_ID_OPT_OR_ALL_NONE =
- CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);;
-
-let ctv_FORMULA_OPT_NONE =
-  CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);;
-
-let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;;
-
-let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT 
-			      ctv_FORMULA_OPT_NONE;;
-
-let ctf_ID_OPT_OR_ALL_SOME s =
- CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);;
-
-let ctv_ID_OPT_OR_ALL_ALL = CT_all;;
-
-let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;;
-
-let ct_coerce_FORMULA_to_DEF_BODY x =
-    CT_coerce_CONTEXT_PATTERN_to_DEF_BODY
-    (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);;
-
-let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;;
-
-let varc x = CT_coerce_ID_to_FORMULA x;;
-
-let xlate_ident id = CT_ident (string_of_id id)
-
-let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);;
-
-let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);;
-
-let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;;
-
-let nums_to_int_list l =  CT_int_list(nums_to_int_list_aux l);;
-
-let num_or_var_to_int = function
-  | ArgArg x -> CT_int x
-  | _ -> xlate_error "TODO: nums_to_int_list_aux ArgVar";;
-
-let nums_or_var_to_int_list_aux l = List.map num_or_var_to_int l;;
-
-let nums_or_var_to_int_list l = CT_int_list(nums_or_var_to_int_list_aux l);;
-
-let nums_or_var_to_int_ne_list n l =
-  CT_int_ne_list(num_or_var_to_int n, nums_or_var_to_int_list_aux l);;
-
-type iTARG =   Targ_command of ct_FORMULA
-             | Targ_intropatt of ct_INTRO_PATT_LIST
-             | Targ_id_list of ct_ID_LIST
-             | Targ_spec_list of ct_SPEC_LIST
-             | Targ_binding_com of ct_FORMULA
-             | Targ_ident of ct_ID
-             | Targ_int of ct_INT
-             | Targ_binding of ct_BINDING
-             | Targ_pattern of ct_PATTERN
-             | Targ_unfold of ct_UNFOLD
-	     | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST
-             | Targ_string of ct_STRING
-             | Targ_fixtac of ct_FIXTAC
-             | Targ_cofixtac of ct_COFIXTAC
-             | Targ_tacexp of ct_TACTIC_COM
-             | Targ_redexp of ct_RED_COM;;
-
-type iVARG =   Varg_binder of ct_BINDER
-             | Varg_binderlist of ct_BINDER_LIST
-             | Varg_bindernelist of ct_BINDER_NE_LIST
-             | Varg_call of ct_ID * iVARG list
-             | Varg_constr of ct_FORMULA
-             | Varg_sorttype of ct_SORT_TYPE
-             | Varg_constrlist of ct_FORMULA list
-             | Varg_ident of ct_ID
-             | Varg_int of ct_INT
-             | Varg_intlist of ct_INT_LIST
-             | Varg_none
-             | Varg_string of ct_STRING
-             | Varg_tactic of ct_TACTIC_COM
-             | Varg_ast of ct_AST
-             | Varg_astlist of ct_AST_LIST
-             | Varg_tactic_arg of iTARG
-             | Varg_varglist of iVARG list;;
-
-
-let coerce_iVARG_to_FORMULA =
- function
-    | Varg_constr x -> x
-    | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x
-    | Varg_ident id -> CT_coerce_ID_to_FORMULA id
-    | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";;
-
-let coerce_iVARG_to_ID =
- function Varg_ident id -> id
-    | _ -> xlate_error "coerce_iVARG_to_ID";;
-
-let coerce_VARG_to_ID =
- function
-    | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) ->
-     x
-    | _ -> xlate_error "coerce_VARG_to_ID";;
-
-let xlate_ident_opt =
-  function
-    | None -> ctv_ID_OPT_NONE
-    | Some id -> ctf_ID_OPT_SOME (xlate_ident id)
-
-let xlate_id_to_id_or_int_opt s =
-   CT_coerce_ID_OPT_to_ID_OR_INT_OPT
-     (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));;
-
-let xlate_int_to_id_or_int_opt n =
-   CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT
-     (CT_coerce_INT_to_ID_OR_INT (CT_int n));;
-
-let none_in_id_or_int_opt =
-  CT_coerce_ID_OPT_to_ID_OR_INT_OPT
-    (CT_coerce_NONE_to_ID_OPT(CT_none));;
-
-let xlate_int_opt = function
-  | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n)
-  | None ->  CT_coerce_NONE_to_INT_OPT CT_none
-
-let xlate_int_or_var_opt_to_int_opt = function
-  | Some (ArgArg n) -> CT_coerce_INT_to_INT_OPT (CT_int n)
-  | Some (ArgVar _) -> xlate_error "int_or_var: TODO"
-  | None ->  CT_coerce_NONE_to_INT_OPT CT_none
-
-let apply_or_by_notation f = function
-  | AN x -> f x
-  | ByNotation _ -> xlate_error "TODO: ByNotation"
-
-let tac_qualid_to_ct_ID ref = 
-  CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
-
-let loc_qualid_to_ct_ID ref =
-  CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
-
-let int_of_meta n = int_of_string (string_of_id n)
-let is_int_meta n = try let _ = int_of_meta n in true with _ -> false
-
-let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l)
-
-let reference_to_ct_ID = function
-  | Ident (_,id) -> CT_ident (Names.string_of_id id)
-  | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid)
-
-let xlate_class = function
-  | FunClass -> CT_ident "FUNCLASS"
-  | SortClass -> CT_ident "SORTCLASS"
-  | RefClass qid -> loc_qualid_to_ct_ID qid
-
-let id_to_pattern_var ctid =
- match ctid with
- | CT_metaid _ -> xlate_error "metaid not expected in pattern_var"
- | CT_ident "_" -> 
-     CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none)
- | CT_ident id_string ->
-     CT_coerce_ID_OPT_to_MATCH_PATTERN 
-       (CT_coerce_ID_to_ID_OPT (CT_ident id_string))
- | CT_metac _ -> assert false;;
-
-exception Not_natural;;
-
-let xlate_sort =
-  function
-    | RProp Term.Pos -> CT_sortc "Set"
-    | RProp Term.Null -> CT_sortc "Prop"
-    | RType None -> CT_sortc "Type"
-    | RType (Some u) -> xlate_error "xlate_sort";;
-
-
-let xlate_qualid a =
-  let d,i = Libnames.repr_qualid a in
-  let l = Names.repr_dirpath d in
-  List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;;
-   
-(* // The next two functions should be modified to make direct reference
-  to a notation operator *)
-let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);;
-
-let xlate_reference = function
-    Ident(_,i) -> CT_ident (string_of_id i)
-  | Qualid(_, q) -> CT_ident (xlate_qualid q);;
-let rec xlate_match_pattern =
- function
-   | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference  s)
-   | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_")
-   | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f)
-   | CPatCstr (_, f1 , (arg1 :: args)) ->
-     CT_pattern_app
-      (id_to_pattern_var (xlate_reference  f1),
-      CT_match_pattern_ne_list
-       (xlate_match_pattern arg1, 
-	List.map xlate_match_pattern args))
-    | CPatAlias  (_,  pattern, id) ->
-     CT_pattern_as
-      (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id))
-    | CPatOr (_,l) -> xlate_error "CPatOr: TODO"
-    | CPatDelimiters(_, key, p) -> 
-	CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p)
-    | CPatPrim (_,Numeral n) ->
- 	CT_coerce_NUM_to_MATCH_PATTERN
-	  (CT_int_encapsulator(Bigint.to_string n))
-    | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO"
-    | CPatNotation(_, s, (l,[])) -> 
-	CT_pattern_notation(CT_string s,
-			    CT_match_pattern_list(List.map xlate_match_pattern l))
-    | CPatNotation(_, s, (l,_)) ->
-	 xlate_error "CPatNotation (recursive notation): TODO"
-;;
-
-
-let xlate_id_opt_aux = function
-    Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id))
-  | Anonymous -> ctv_ID_OPT_NONE;;
-
-let xlate_id_opt (_, v) = xlate_id_opt_aux v;;
-
-let xlate_id_opt_ne_list = function
-    [] -> assert false
-  | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);;
-
-
-let rec last = function
-    [] -> assert false
-  | [a] -> a
-  | a::tl -> last tl;;
-
-let rec decompose_last = function
-    [] -> assert false
-  | [a] -> [], a
-  | a::tl -> let rl, b = decompose_last tl in (a::rl), b;;
-
-let make_fix_struct (n,bl) =
-  let names = names_of_local_assums bl in
-  let nn = List.length names in
-  if nn = 1 || n = None then ctv_ID_OPT_NONE
-  else ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));;
-
-let rec xlate_binder = function
-    (l,k,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
-and xlate_return_info = function
-| (Some Anonymous, None) | (None, None) ->
-   CT_coerce_NONE_to_RETURN_INFO CT_none
-| (None, Some t) -> CT_return(xlate_formula t)
-| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t)
-| (Some _, None) -> assert false
-and xlate_formula_opt =
-  function
-    | None -> ctv_FORMULA_OPT_NONE
-    | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e)
-
-and  xlate_binder_l = function
-    LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
-  | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n,
-						       xlate_formula v))
-and 
-  xlate_match_pattern_ne_list = function
-    [] -> assert false
-  | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, 
-                                     List.map xlate_match_pattern l)
-and  translate_one_equation = function
-    (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
-  | _ -> xlate_error "TODO: disjunctive multiple patterns"
-and 
-  xlate_binder_ne_list = function
-    [] -> assert false
-  | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l)
-and 
-  xlate_binder_list = function
-  l -> CT_binder_list( List.map xlate_binder_l l)
-and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
-
-     CRef r -> varc (xlate_reference r)
-   | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b)
-   | CProdN(_,ll,b) as whole_term -> 
-       let rec gather_binders = function
-	   CProdN(_, ll, b) ->
-	     ll@(gather_binders b)
-	 | _ -> [] in
-       let rec fetch_ultimate_body = function
-	   CProdN(_, _, b) -> fetch_ultimate_body b
-	 | a -> a in
-	 CT_prodc(xlate_binder_ne_list (gather_binders whole_term), 
-		  xlate_formula (fetch_ultimate_body b))
-   | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b)
-   | CLetIn(_, v, a, b) -> 
-       CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b)
-   | CAppExpl(_, (Some n, r), l) -> 
-       let l', last = decompose_last l in
-	 CT_proj(xlate_formula last,
-		 CT_formula_ne_list
-		   (CT_bang(varc (xlate_reference r)),
-		    List.map xlate_formula l'))
-   | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r))
-   | CAppExpl(_, (None, r), l) -> 
-       CT_appc(CT_bang(varc (xlate_reference r)),
-	       xlate_formula_ne_list l)
-   | CApp(_, (Some n,f), l) -> 
-       let l', last = decompose_last l in
-       CT_proj(xlate_formula_expl last, 
-	       CT_formula_ne_list
-		 (xlate_formula f, List.map xlate_formula_expl l'))
-   | CApp(_, (_,f), l) -> 
-       CT_appc(xlate_formula f, xlate_formula_expl_ne_list l)
-   | CRecord (_,_,_) -> xlate_error "CRecord: TODO"
-   | CCases (_, _, _, [], _) -> assert false
-   | CCases (_, _, ret_type, tm::tml, eqns)->
-       CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm,
-					   List.map xlate_matched_formula tml),
-		xlate_formula_opt ret_type,
-                CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns))
-   | CLetTuple (_,a::l, ret_info, c, b) -> 
-      CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a,
-				     List.map xlate_id_opt_aux l),
-		   xlate_return_info ret_info,
-		   xlate_formula c,
-		   xlate_formula b)
-   | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()"
-   | CIf (_,c, ret_info, b1, b2) -> 
-       CT_if
-	 (xlate_formula c, xlate_return_info ret_info,
-	  xlate_formula b1, xlate_formula b2)
-
-   | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s)
-   | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l)
-   | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO"
-   | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO"
-   | CPrim (_, Numeral i) -> 
-       CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i))
-   | CPrim (_, String _) -> xlate_error "CPrim (String): TODO"
-   | CHole _ -> CT_existvarc 
-(* I assume CDynamic has been inserted to make free form extension of
-   the language possible, but this would go agains the logic of pcoq anyway. *)
-   | CDynamic (_, _) -> assert false
-   | CDelimiters (_, key, num) -> 
-	 CT_num_encapsulator(CT_num_type key , xlate_formula  num)
-   | CCast (_, e, CastConv (_, t)) -> 
-       CT_coerce_TYPED_FORMULA_to_FORMULA
-	 (CT_typed_formula(xlate_formula e, xlate_formula t))
-   | CCast (_, e, CastCoerce) -> assert false
-   | CPatVar (_, (_,i)) when is_int_meta i ->
-       CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i)))
-   | CPatVar (_, (false, s)) ->
-       CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s))
-   | CPatVar (_, (true, s)) ->
-       xlate_error "Second order variable not supported"
-   | CEvar _ -> xlate_error "CEvar not supported"
-   | CCoFix (_, (_, id), lm::lmi) -> 
-     let strip_mutcorec ((_, fid), bl,arf, ardef) =
-	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
-                      xlate_formula arf, xlate_formula ardef) in
-        CT_cofixc(xlate_ident id,
-	  (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)))
-   | CFix (_, (_, id), lm::lmi) ->       
-     let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) =
-        let struct_arg = make_fix_struct (n, bl) in
-        let arf = xlate_formula arf in
-        let ardef = xlate_formula ardef in
-	match xlate_binder_list bl with
-	  | CT_binder_list (b :: bl) ->
-	      CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl),
-			  struct_arg, arf, ardef)
-          | _ -> xlate_error "mutual recursive" in
-       CT_fixc (xlate_ident id, 
-         	CT_fix_binder_list
-		  (CT_coerce_FIX_REC_to_FIX_BINDER 
-		     (strip_mutrec lm), List.map 
-		       (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x))
-		       lmi)) 
-   | CCoFix _ -> assert false
-   | CFix _ -> assert false
-and xlate_matched_formula = function
-    (f, (Some x, Some y)) ->
-      CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y)
-  | (f, (None, Some y)) ->
-      CT_formula_in(xlate_formula f, xlate_formula y)
-  | (f, (Some x, None)) ->
-      CT_formula_as(xlate_formula f, xlate_id_opt_aux x)
-  | (f, (None, None)) -> 
-      CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f)
-and xlate_formula_expl = function
-    (a, None) -> xlate_formula a
-  | (a, Some (_,ExplByPos (i, _))) -> 
-      xlate_error "explicitation of implicit by rank not supported"
-  | (a, Some (_,ExplByName i)) ->
-      CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a)
-and xlate_formula_expl_ne_list = function
-    [] -> assert false
-  | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l)
-and xlate_formula_ne_list = function 
-    [] -> assert false
-  | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);;
-
-let (xlate_ident_or_metaid:
-      Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function
-    AI (_, x) -> xlate_ident x
-  | MetaId(_, x) -> CT_metaid x;;
-
-let nums_of_occs (b,nums) =
-  if b then nums
-  else List.map (function ArgArg x -> ArgArg (-x) | y -> y) nums
-
-let xlate_hyp = function
-  | AI (_,id) -> xlate_ident id
-  | MetaId _ -> xlate_error "MetaId should occur only in quotations"
-
-let xlate_hyp_location =
- function
-  | (occs, AI (_,id)), InHypTypeOnly ->
-      CT_intype(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs))
-  | (occs, AI (_,id)), InHypValueOnly ->
-      CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs))
-  | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr ->
-      CT_coerce_UNFOLD_to_HYP_LOCATION 
-	(CT_coerce_ID_to_UNFOLD (xlate_ident id))
-  | ((_,a::l as occs), AI (_,id)), InHyp ->
-      let nums = nums_of_occs occs in
-      let a = List.hd nums and l = List.tl nums in
-      CT_coerce_UNFOLD_to_HYP_LOCATION 
-	(CT_unfold_occ (xlate_ident id, 
-			CT_int_ne_list(num_or_var_to_int a, 
-                                       nums_or_var_to_int_list_aux l)))
-  | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *)
-  | (_, MetaId _),_ -> 
-      xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)"
-
-
-
-let xlate_clause cls =
-  let hyps_info =
-    match cls.onhyps with
-    	None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star
-      | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in
-  CT_clause
-    (hyps_info, 
-     if cls.concl_occs <> no_occurrences_expr then 
-       CT_coerce_STAR_to_STAR_OPT CT_star
-     else
-       CT_coerce_NONE_to_STAR_OPT CT_none)
-
-(** Tactics
-   *)
-let strip_targ_spec_list =
- function
-    | Targ_spec_list x -> x
-    | _ -> xlate_error "strip tactic: non binding-list argument";;
-
-let strip_targ_binding =
- function
-    | Targ_binding x -> x
-    | _ -> xlate_error "strip tactic: non-binding argument";;
-
-let strip_targ_command =
- function
-    | Targ_command x -> x
-    | Targ_binding_com x -> x
-    | _ -> xlate_error "strip tactic: non-command argument";;
-
-let strip_targ_ident =
- function
-    | Targ_ident x -> x
-    | _ -> xlate_error "strip tactic: non-ident argument";;
-
-let strip_targ_int =
- function
-    | Targ_int x -> x
-    | _ -> xlate_error "strip tactic: non-int argument";;
-
-let strip_targ_pattern =
- function
-    | Targ_pattern x -> x
-    | _ -> xlate_error "strip tactic: non-pattern argument";;
-
-let strip_targ_unfold =
- function
-    | Targ_unfold x -> x
-    | _ -> xlate_error "strip tactic: non-unfold argument";;
-
-let strip_targ_fixtac =
- function
-    | Targ_fixtac x -> x
-    | _ -> xlate_error "strip tactic: non-fixtac argument";;
-
-let strip_targ_cofixtac =
- function
-    | Targ_cofixtac x -> x
-    | _ -> xlate_error "strip tactic: non-cofixtac argument";;
-
-(*Need to transform formula to id for "Prolog" tactic problem *)
-let make_ID_from_FORMULA =
- function
-    | CT_coerce_ID_to_FORMULA id -> id
-    | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";;
-
-let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);;
-
-let xlate_quantified_hypothesis = function
-  | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n)
-  | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id)
-
-let xlate_quantified_hypothesis_opt = function
-  | None -> 
-      CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE
-  | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n
-  | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;;
-
-let xlate_id_or_int = function
-    ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n)
-  | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);;
-
-let xlate_explicit_binding (loc,h,c) = 
-  CT_binding (xlate_quantified_hypothesis h, xlate_formula c)
-
-let xlate_bindings = function
-  | ImplicitBindings l ->
-      CT_coerce_FORMULA_LIST_to_SPEC_LIST
-        (CT_formula_list (List.map xlate_formula l))
-  | ExplicitBindings l ->
-      CT_coerce_BINDING_LIST_to_SPEC_LIST
-        (CT_binding_list (List.map xlate_explicit_binding l))
-  | NoBindings ->
-      CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list [])
-
-let strip_targ_spec_list =
- function
-    | Targ_spec_list x -> x
-    | _ -> xlate_error "strip_tar_spec_list";;
-
-let strip_targ_intropatt =
- function
-    | Targ_intropatt x -> x
-    | _ -> xlate_error "strip_targ_intropatt";;
-
-let get_flag r =
-  let conv_flags, red_ids =
-    let csts = List.map (apply_or_by_notation tac_qualid_to_ct_ID) r.rConst in
-    if r.rDelta then
-      [CT_delta], CT_unfbut csts
-    else
-      (if r.rConst = []
-      then (* probably useless: just for compatibility *) []
-      else [CT_delta]),
-      CT_unf csts in
-  let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in
-  let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in
-  let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in
-  (* Rem: EVAR flag obsolète *)
-  conv_flags, red_ids
-
-let rec xlate_intro_pattern (loc,pat) = match pat with
-  | IntroOrAndPattern [] -> assert false
-  | IntroOrAndPattern (fp::ll) ->
-      CT_disj_pattern
-      	(CT_intro_patt_list(List.map xlate_intro_pattern fp),
-	 List.map 
-	   (fun l ->
-	      CT_intro_patt_list(List.map xlate_intro_pattern l))
-	   ll)
-  | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" )
-  | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c)
-  | IntroAnonymous -> xlate_error "TODO: IntroAnonymous"
-  | IntroFresh _ -> xlate_error "TODO: IntroFresh"
-  | IntroRewrite _ -> xlate_error "TODO: IntroRewrite"
-
-let compute_INV_TYPE = function
-   FullInversionClear -> CT_inv_clear
- | SimpleInversion -> CT_inv_simple
- | FullInversion -> CT_inv_regular
-
-let is_tactic_special_case = function
-    "AutoRewrite" -> true
-  | _ -> false;;
-
-let xlate_context_pattern = function
-  | Term v -> 
-      CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v)
-  | Subterm (b, idopt, v) -> (* TODO: application pattern *)
-      CT_context(xlate_ident_opt idopt, xlate_formula v)
-
-
-let xlate_match_context_hyps = function
-  | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b)
-  | Def (na,b,t) -> xlate_error "TODO: Let hyps"
-      (* CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b, xlate_context_pattern t);; *)
-
-let xlate_arg_to_id_opt = function
-    Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id))
-  | None -> ctv_ID_OPT_NONE;;
-
-let xlate_largs_to_id_opt largs =
-  match List.map xlate_arg_to_id_opt largs with
-      fst::rest -> fst, rest
-    | _ -> assert false;;
-
-let xlate_int_or_constr = function
-    ElimOnConstr (a,NoBindings) -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a)
-  | ElimOnConstr _ -> xlate_error "TODO: ElimOnConstr with bindings"
-  | ElimOnIdent(_,i) ->
-      CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-      	(CT_coerce_ID_to_ID_OR_INT(xlate_ident i))
-  | ElimOnAnonHyp i -> 
-      CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	(CT_coerce_INT_to_ID_OR_INT(CT_int i));;
-
-let xlate_using = function
-    None -> CT_coerce_NONE_to_USING(CT_none)
-  | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);;
-
-let xlate_one_unfold_block = function
-    ((true,[]),qid) -> 
-      CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid)
-  | (((_,_::_) as occs), qid) ->
-      let l = nums_of_occs occs in
-      CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, 
-                    nums_or_var_to_int_ne_list (List.hd l) (List.tl l))
-  | ((false,[]), qid) -> xlate_error "Unused"
-;;
-
-let xlate_with_names = function
-    None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE
-  | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp)
-
-let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level
-
-let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) =
-  function
-    | TacVoid ->
-	CT_void
-    | Tacexp t -> 
-	CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t)
-    | Integer n ->
-	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)))
-    | Reference r ->
-	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r)))
-    | TacDynamic _ ->
-	failwith "Dynamics not treated in xlate_ast"
-    | ConstrMayEval (ConstrTerm c) ->
-	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
-	  (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c))
-    | ConstrMayEval(ConstrEval(r,c)) ->
-	CT_coerce_EVAL_CMD_to_TACTIC_ARG
-	  (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r,
-		   xlate_formula c))
-    | ConstrMayEval(ConstrTypeOf(c)) -> 
-	CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c))
-    | MetaIdArg _ ->
-	xlate_error "MetaIdArg should only be used in quotations"
-    | t ->
-	CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t)
-
-and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) =
- function
-   (* Moved from xlate_tactic *)
-    | TacCall (_, r, a::l) ->
-	CT_simple_user_tac
-	  (reference_to_ct_ID r,
-	    CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l))
-    | Reference (Ident (_,s)) -> ident_tac s
-    | ConstrMayEval(ConstrTerm a) ->
-	CT_formula_marker(xlate_formula a)
-    | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None)
-    | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s))
-    | TacFreshId _ -> xlate_error "TODO: fresh with many args"
-    | t -> xlate_error "TODO LATER: result other than tactic or constr"
-
-and xlate_red_tactic =
- function
-  | Red true -> xlate_error ""
-  | Red false -> CT_red
-  | CbvVm -> CT_cbvvm
-  | Hnf -> CT_hnf
-  | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE
-  | Simpl (Some (occs,c)) -> 
-      let l = nums_of_occs occs in
-      CT_simpl 
-	(CT_coerce_PATTERN_to_PATTERN_OPT
-	   (CT_pattern_occ
-	      (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c)))
-  | Cbv flag_list ->
-     let conv_flags, red_ids = get_flag flag_list in
-     CT_cbv (CT_conversion_flag_list conv_flags, red_ids)
-  | Lazy flag_list ->
-     let conv_flags, red_ids = get_flag flag_list in
-     CT_lazy (CT_conversion_flag_list conv_flags, red_ids)
-  | Unfold unf_list ->
-     let ct_unf_list = List.map xlate_one_unfold_block unf_list in
-     (match ct_unf_list with
-      | first :: others -> CT_unfold (CT_unfold_ne_list (first, others))
-      | [] -> error "there should be at least one thing to unfold")
-  | Fold formula_list -> 
-      CT_fold(CT_formula_list(List.map xlate_formula formula_list))
-  | Pattern l ->
-     let pat_list = List.map (fun (occs,c) ->
-          CT_pattern_occ
-           (CT_int_list (nums_or_var_to_int_list_aux (nums_of_occs occs)),
-            xlate_formula c)) l in
-     (match pat_list with
-      | first :: others -> CT_pattern (CT_pattern_ne_list (first, others))
-      | [] -> error "Expecting at least one pattern in a Pattern command")
-  | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)"
-
-and xlate_local_rec_tac = function 
- (* TODO LATER: local recursive tactics and global ones should be handled in
-    the same manner *)
-  | ((_,x),Tacexp (TacFun (argl,tac))) ->
-      let fst, rest = xlate_largs_to_id_opt argl in
-	CT_rec_tactic_fun(xlate_ident x,
-			  CT_id_opt_ne_list(fst, rest),
-			  xlate_tactic tac)
-  | _ -> xlate_error "TODO: more general argument of 'let rec in'"
-
-and xlate_tactic =
- function
-   | TacFun (largs, t) ->
-       let fst, rest =  xlate_largs_to_id_opt largs in
-       CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t)
-   | TacThen (t1,[||],t2,[||]) -> 
-       (match xlate_tactic t1 with
-            CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2])
-	  | t -> CT_then (t,[xlate_tactic t2]))
-   | TacThen _ -> xlate_error "TacThen generalization TODO"
-   | TacThens(t1,[]) -> assert false
-   | TacThens(t1,t::l) ->
-       let ct = xlate_tactic t in
-       let cl = List.map xlate_tactic l in
-       (match xlate_tactic t1 with
-	    CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)])
-	  | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)]))
-   | TacFirst([]) -> assert false
-   | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l)
-   | TacSolve([]) -> assert false
-   | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l)
-   | TacComplete _ -> xlate_error "TODO: tactical complete"
-   | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t)
-   | TacTry t -> CT_try (xlate_tactic t)
-   | TacRepeat t -> CT_repeat(xlate_tactic t)
-   | TacAbstract(t,id_opt) -> 
-       CT_abstract((match id_opt with
-		       	None -> ctv_ID_OPT_NONE
-		      | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))),
-		   xlate_tactic t)
-   | TacProgress t -> CT_progress(xlate_tactic t)
-   | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2)
-   | TacMatch (true,_,_) -> failwith "TODO: lazy match"
-   | TacMatch (false, exp, rules) ->
-        CT_match_tac(xlate_tactic exp,
-                     match List.map 
-                       (function 
-                          | Pat ([],p,tac) ->
-                              CT_match_tac_rule(xlate_context_pattern p,
-                                                mk_let_value tac)
-                          | Pat (_,p,tac) -> xlate_error"No hyps in pure Match"
-                          | All tac ->
-                              CT_match_tac_rule
-                                (CT_coerce_FORMULA_to_CONTEXT_PATTERN
-                                   CT_existvarc, 
-                                   mk_let_value tac)) rules with
-                         | [] -> assert false
-                         | fst::others ->
-                             CT_match_tac_rules(fst, others))
-   | TacMatchGoal (_,_,[]) | TacMatchGoal (true,_,_) -> failwith ""
-   | TacMatchGoal (false,false,rule1::rules) ->
-         CT_match_context(xlate_context_rule rule1,
-                          List.map xlate_context_rule rules)
-   | TacMatchGoal (false,true,rule1::rules) ->
-         CT_match_context_reverse(xlate_context_rule rule1,
-                          List.map xlate_context_rule rules)
-   | TacLetIn (false, l, t) ->
-       let cvt_clause =
-         function
-             ((_,s),ConstrMayEval v) ->
-                 CT_let_clause(xlate_ident s,
-			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
-                               CT_coerce_DEF_BODY_to_LET_VALUE
-                               (formula_to_def_body v))
-           | ((_,s),Tacexp t) -> 
-                 CT_let_clause(xlate_ident s,
-			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
-                               CT_coerce_TACTIC_COM_to_LET_VALUE
-                               (xlate_tactic t))
-           | ((_,s),t) -> 
-                 CT_let_clause(xlate_ident s,
-			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
-                               CT_coerce_TACTIC_COM_to_LET_VALUE
-                               (xlate_call_or_tacarg t)) in
-         let cl_l = List.map cvt_clause l in
-         (match cl_l with
-            | [] -> assert false 
-            | fst::others ->
-                CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t))
-   | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition"
-   | TacLetIn(true, f1::l, t) -> 
-       let tl =  CT_rec_tactic_fun_list
-		   (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in
-       CT_rec_tactic_in(tl, xlate_tactic t)
-   | TacAtom (_, t) -> xlate_tac t 
-   | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE)
-   | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count,
-				   ctf_STRING_OPT_SOME (CT_string s))
-   | TacFail (count, _) -> xlate_error "TODO: generic fail message"
-   | TacId [] -> CT_idtac ctf_STRING_OPT_NONE
-   | TacId [MsgString s] -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s))
-   | TacId _ -> xlate_error "TODO: generic idtac message"
-   | TacInfo t -> CT_info(xlate_tactic t)
-   | TacArg a -> xlate_call_or_tacarg a
-
-and xlate_tac =
-  function
-    | TacExtend (_, "firstorder", tac_opt::l) ->
-       let t1 =
-	 match
-	   out_gen (wit_opt rawwit_main_tactic) tac_opt
-	 with
-	 | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none
-	 | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in
-	 (match l with
-	      [] -> CT_firstorder t1
-	    | [l1] -> 
-		(match genarg_tag l1 with
-		     List1ArgType PreIdentArgType -> 
-		       let l2 = List.map 
-				  (fun x -> CT_ident x)
-				  (out_gen (wit_list1 rawwit_pre_ident) l1) in
-		       let fst,l3 = 
-			 match l2 with fst::l3 -> fst,l3 | [] -> assert false in
-		      	 CT_firstorder_using(t1, CT_id_ne_list(fst, l3))
-		   | List1ArgType RefArgType ->
-		       let l2 = List.map reference_to_ct_ID 
-				  (out_gen (wit_list1 rawwit_ref) l1) in
-		       let fst,l3 =
-			 match  l2 with fst::l3 -> fst, l3 | [] -> assert false in
-			 CT_firstorder_with(t1, CT_id_ne_list(fst, l3))
-		   | _ -> assert false)
-	    | _ -> assert false)
-    | TacExtend (_, "refine", [c]) ->
-       CT_refine (xlate_formula (snd (out_gen rawwit_casted_open_constr c)))
-    | TacExtend (_,"absurd",[c]) ->
-       CT_absurd (xlate_formula (out_gen rawwit_constr c))
-    | TacExtend (_,"contradiction",[opt_c]) ->
-	(match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with
-	     None -> CT_contradiction
-	   | Some(c, b) ->
-	       let c1 = xlate_formula c in
-	       let bindings = xlate_bindings b in
-		 CT_contradiction_thm(c1, bindings))
-    | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b)
-    | TacChange (Some(l,c), f, b) -> 
-	(* TODO LATER: combine with other constructions of pattern_occ *)
-	let l = nums_of_occs l in
-	CT_change_local(
-	  CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), 
-			 xlate_formula c),
-	  xlate_formula f,
-	  xlate_clause b)
-    | TacExtend (_,"contradiction",[]) -> CT_contradiction
-    | TacDoubleInduction (n1, n2) ->
-	CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2)
-    | TacExtend (_,"discriminate", []) ->
-     CT_discriminate_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE)
-    | TacExtend (_,"discriminate", [id]) ->
-     CT_discriminate_eq
-         (xlate_quantified_hypothesis_opt
-	    (Some (out_gen rawwit_quant_hyp id)))
-    | TacExtend (_,"simplify_eq", []) ->
-	  CT_simplify_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT
-		(CT_coerce_NONE_to_ID_OPT CT_none))
-    | TacExtend (_,"simplify_eq", [id]) ->
-	let id1 = out_gen rawwit_quant_hyp id in
-	let id2 = CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT
-	      	(xlate_quantified_hypothesis id1) in
-	  CT_simplify_eq id2
-    | TacExtend (_,"injection", []) ->
-     CT_injection_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE)
-    | TacExtend (_,"injection", [id]) ->
-     CT_injection_eq
-         (xlate_quantified_hypothesis_opt
-	    (Some (out_gen rawwit_quant_hyp id)))
-    | TacExtend (_,"injection_as", [idopt;ipat]) ->
-	xlate_error "TODO: injection as"
-    | TacFix (idopt, n) ->
-     CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
-    | TacMutualFix (false, id, n, fixtac_list) ->
-     let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in
-     CT_fixtactic
-      (ctf_ID_OPT_SOME (xlate_ident id), CT_int n,
-      CT_fix_tac_list (List.map f fixtac_list))
-    | TacMutualFix (true, id, n, fixtac_list) ->
-        xlate_error "TODO: non user-visible fix"
-    | TacCofix idopt ->
-       CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list [])
-    | TacMutualCofix (false, id, cofixtac_list) ->
-     let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in
-     CT_cofixtactic
-      (CT_coerce_ID_to_ID_OPT (xlate_ident id),
-      CT_cofix_tac_list (List.map f cofixtac_list))
-    | TacMutualCofix (true, id, cofixtac_list) ->
-        xlate_error "TODO: non user-visible cofix"
-    | TacIntrosUntil (NamedHyp id) -> 
-	CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id))
-    | TacIntrosUntil (AnonHyp n) -> 
-	CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n))
-    | TacIntroMove (Some id1, MoveAfter id2) ->
-     CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2)
-    | TacIntroMove (None, MoveAfter id2) ->
-	CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_hyp id2)
-    | TacMove (true, id1, MoveAfter id2) ->
-	CT_move_after(xlate_hyp id1, xlate_hyp id2)
-    | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal"
-    | TacMove _ -> xlate_error "TODO: move before, at top, at bottom"
-    | TacIntroPattern patt_list ->
-	CT_intros
-	  (CT_intro_patt_list (List.map xlate_intro_pattern patt_list))
-    | TacIntroMove (Some id, MoveToEnd true) ->
-     CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)])
-    | TacIntroMove (None, MoveToEnd true) ->
-	CT_intro (CT_coerce_NONE_to_ID_OPT CT_none)
-    | TacIntroMove _ -> xlate_error "TODO"
-    | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl)
-    | TacRight (false,bindl) -> CT_right (xlate_bindings bindl)
-    | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl)
-    | TacSplit (false,true,bindl) -> CT_exists (xlate_bindings bindl)
-    | TacSplit _ | TacRight _ | TacLeft _ -> 
-	xlate_error "TODO: esplit, eright, etc"
-    | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) ->
-	let c1 = xlate_formula (out_gen rawwit_constr c1) in
-	let c2 = xlate_formula (out_gen rawwit_constr c2) in
-	let cl = 
-	  (* J.F. : 18/08/2006 
-	     Hack to coerce the "clause" argument of replace to a real clause 
-	     To be remove if we can reuse the clause grammar entrie defined in g_tactic
-	  *)
-	  let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in 
-	  let cl_as_xlate_arg = 
-	    {cl_as_clause with 
-	       Tacexpr.onhyps = 
-		Option.map 
-		  (fun l -> 
-		     List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l
-		  )
-		  cl_as_clause.Tacexpr.onhyps
-	    }
-	  in
-	  cl_as_xlate_arg
-	in 
-	let cl = xlate_clause cl in 
-	let tac_opt = 
-	  match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with
-	    | None -> CT_coerce_NONE_to_TACTIC_OPT  CT_none
-	    | Some tac ->
-		let tac =  xlate_tactic tac in
-		CT_coerce_TACTIC_COM_to_TACTIC_OPT tac
-	in 
-	CT_replace_with (c1, c2,cl,tac_opt)
-    | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> 
-     let cl = xlate_clause cl 
-     and c = xlate_formula (fst cbindl) 
-     and bindl = xlate_bindings (snd cbindl) in
-     if b then CT_rewrite_lr (c, bindl, cl)
-     else CT_rewrite_rl (c, bindl, cl)
-    | TacRewrite(_,_,_,Some _) -> xlate_error "TODO: rewrite by"
-    | TacRewrite(false,_,cl,_) -> xlate_error "TODO: rewrite of several hyps at once"
-    | TacRewrite(true,_,cl,_) -> xlate_error "TODO: erewrite"
-    | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) ->
-     let t = out_gen rawwit_main_tactic t in
-     let b = out_gen Extraargs.rawwit_orient b in
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE)
-     else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE)
-    | TacExtend (_,"conditional_rewrite", [t; b; cbindl; id]) ->
-     let t = out_gen rawwit_main_tactic t in
-     let b = out_gen Extraargs.rawwit_orient b in
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var id))) in
-     if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id)
-     else CT_condrewrite_rl (xlate_tactic t, c, bindl, id)
-    | TacExtend (_,"dependent_rewrite", [b; c]) ->
-      let b = out_gen Extraargs.rawwit_orient b in
-      let c = xlate_formula (out_gen rawwit_constr c) in
-      (match c with
-	| CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> 
-	    if b then CT_deprewrite_lr id else CT_deprewrite_rl id
-	| _ -> xlate_error "dependent rewrite on term: not supported")
-    | TacExtend (_,"dependent_rewrite", [b; c; id]) ->
-	xlate_error "dependent rewrite on terms in hypothesis: not supported"
-    | TacExtend (_,"cut_rewrite", [b; c]) ->
-      let b = out_gen Extraargs.rawwit_orient b in
-      let c = xlate_formula (out_gen rawwit_constr c) in
-      if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
-      else CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
-    | TacExtend (_,"cut_rewrite", [b; c; id]) ->
-      let b = out_gen Extraargs.rawwit_orient b in
-      let c = xlate_formula (out_gen rawwit_constr c) in
-      let id = xlate_ident (snd (out_gen rawwit_var id)) in
-      if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id)
-      else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id)
-    | TacExtend(_, "subst", [l]) ->
-	CT_subst
-	  (CT_id_list
-	     (List.map (fun x -> CT_ident (string_of_id x))
-		(out_gen (wit_list1 rawwit_ident) l)))
-    | TacReflexivity -> CT_reflexivity
-    | TacSymmetry cls -> CT_symmetry(xlate_clause cls)
-    | TacTransitivity c -> CT_transitivity (xlate_formula c)
-    | TacAssumption -> CT_assumption
-    | TacExact c -> CT_exact (xlate_formula c)
-    | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c)
-    | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c)
-    | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id)
-    | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id)
-    | TacDestructConcl -> CT_dconcl
-    | TacSuperAuto (nopt,l,a3,a4) ->
-      CT_superauto(
-        xlate_int_opt nopt,
-        xlate_qualid_list l,
-        (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none),
-        (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none))
-    | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt)
-    | TacAuto (nopt, [], Some []) -> CT_auto (xlate_int_or_var_opt_to_int_opt nopt)
-    | TacAuto (nopt, [], None) ->
- 	CT_auto_with (xlate_int_or_var_opt_to_int_opt nopt,
-		      CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-    | TacAuto (nopt, [], Some (id1::idl)) ->
-	CT_auto_with(xlate_int_or_var_opt_to_int_opt nopt,
-             CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR(
-             CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl)))
-    | TacAuto (nopt, _::_, _) ->
-	xlate_error "TODO: auto using"
-    |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) ->
-       let (id_list:ct_ID list) =
-	 List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in
-       let fst, (id_list1: ct_ID list) =
-	 match id_list with [] -> assert false | a::tl -> a,tl in
-       let t1 =
-	 match t with
-	     [t0] -> 
-	       CT_coerce_TACTIC_COM_to_TACTIC_OPT
-	       (xlate_tactic(out_gen rawwit_main_tactic t0))
-	   | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none
-	   | _ -> assert false in
-	 CT_autorewrite (CT_id_ne_list(fst, id_list1), t1)
-    | TacExtend (_,"eauto", [nopt; popt; lems; idl]) ->
-	let first_n =
-	  match out_gen (wit_opt rawwit_int_or_var) nopt with
-	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
-	    | None -> none_in_id_or_int_opt in
-	let second_n =
-	  match out_gen (wit_opt rawwit_int_or_var) popt with
-	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
-	    | None -> none_in_id_or_int_opt in
-	let _lems =
-	  match out_gen Eauto.rawwit_auto_using lems with
-	    | [] -> []
-	    | _ -> xlate_error "TODO: eauto using" in
-	let idl = out_gen Eauto.rawwit_hintbases idl in
-          (match idl with
-	    None -> CT_eauto_with(first_n,
-				  second_n,
-				  CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-	  | Some [] -> CT_eauto(first_n, second_n)
-	  | Some (a::l) -> 
-	      CT_eauto_with(first_n, second_n,
-			    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR
-			      (CT_id_ne_list
-				 (CT_ident a,
-				  List.map (fun x -> CT_ident x) l))))
-    | TacExtend (_,"prolog", [cl; n]) ->
-      let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in
-      (match out_gen rawwit_int_or_var n with
-	| ArgVar _ -> xlate_error ""
-	| ArgArg n -> CT_prolog (CT_formula_list cl, CT_int  n))
-    (* eapply now represented by TacApply (true,cbindl) 
-    | TacExtend (_,"eapply", [cbindl]) -> 
-*)
-    | TacTrivial ([],Some []) -> CT_trivial
-    | TacTrivial ([],None) -> 
-	CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-    | TacTrivial ([],Some (id1::idl)) ->
-	 CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR(
-            (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl))))
-    | TacTrivial (_::_,_) ->
-	xlate_error "TODO: trivial using"
-    | TacReduce (red, l) ->
-     CT_reduce (xlate_red_tactic red, xlate_clause l)
-    | TacApply (true,false,[c,bindl],None) ->
-     CT_apply (xlate_formula c, xlate_bindings bindl)
-    | TacApply (true,true,[c,bindl],None) ->
-     CT_eapply (xlate_formula c, xlate_bindings bindl)
-    | TacApply (_,_,_,_) ->
-	xlate_error "TODO: simple (e)apply and iterated apply and apply in"
-    | TacConstructor (false,n_or_meta, bindl) ->
-	let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error ""
-	in CT_constructor (CT_int n, xlate_bindings bindl)
-    | TacConstructor _ -> xlate_error "TODO: econstructor"
-    | TacSpecialize (nopt, (c,sl)) ->
-     CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl)
-    | TacGeneralize [] -> xlate_error ""
-    | TacGeneralize ((((true,[]),first),Anonymous) :: cl)
-	when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr
-	  & na = Anonymous) cl ->
-     CT_generalize
-      (CT_formula_ne_list (xlate_formula first, 
-                           List.map (fun ((_,c),_) -> xlate_formula c) cl))
-    | TacGeneralize _ -> xlate_error "TODO: Generalize at and as"
-    | TacGeneralizeDep c ->
-	CT_generalize_dependent (xlate_formula c)
-    | TacElimType c -> CT_elim_type (xlate_formula c)
-    | TacCaseType c -> CT_case_type (xlate_formula c)
-    | TacElim (false,(c1,sl), u) ->
-     CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u)
-    | TacCase (false,(c1,sl)) ->
-     CT_casetac (xlate_formula c1, xlate_bindings sl)
-    | TacElim (true,_,_) | TacCase (true,_)
-    | TacInductionDestruct (_,true,_) ->
-	xlate_error "TODO: eelim, ecase, edestruct, einduction"
-    | TacSimpleInductionDestruct (true,h) ->
-	CT_induction (xlate_quantified_hypothesis h)
-    | TacSimpleInductionDestruct (false,h) ->
-	CT_destruct (xlate_quantified_hypothesis h)
-    | TacCut c -> CT_cut (xlate_formula c)
-    | TacLApply c -> CT_use (xlate_formula c)
-    | TacDecompose ([],c) ->
-	xlate_error "Decompose : empty list of identifiers?"
-    | TacDecompose (id::l,c) ->
-	let id' = apply_or_by_notation tac_qualid_to_ct_ID id in
-	let l' = List.map (apply_or_by_notation tac_qualid_to_ct_ID) l in
-        CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c)
-    | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c)
-    | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c)
-    | TacClear (false,[]) ->
-	xlate_error "Clear expects a non empty list of identifiers"
-    | TacClear (false,id::idl) ->
-       let idl' = List.map xlate_hyp idl in
-       CT_clear (CT_id_ne_list (xlate_hyp id, idl'))
-    | TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'"
-    | TacRevert _ -> xlate_error "TODO: revert"
-    | (*For translating tactics/Inv.v *)
-      TacInversion (NonDepInversion (k,idl,l),quant_hyp) ->
-	CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp,
-		     xlate_with_names l,
-	             CT_id_list (List.map xlate_hyp idl))
-    | TacInversion (DepInversion (k,copt,l),quant_hyp) ->
-	let id = xlate_quantified_hypothesis quant_hyp in
-	CT_depinversion (compute_INV_TYPE k, id, 
-			 xlate_with_names l, xlate_formula_opt copt)
-    | TacInversion (InversionUsing (c,idlist), id) ->
-	let id = xlate_quantified_hypothesis id in
-	  CT_use_inversion (id, xlate_formula c,
-	    CT_id_list (List.map xlate_hyp idlist))
-    | TacExtend (_,"omega", []) -> CT_omega
-    | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2)
-    | TacRename _ -> xlate_error "TODO: add support for n-ary rename"
-    | TacClearBody([]) -> assert false
-    | TacClearBody(a::l) -> 
-	CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l))
-    | TacDAuto (a, b, []) ->
-	CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b)
-    | TacDAuto (a, b, _) ->
-	xlate_error "TODO: dauto using"
-    | TacInductionDestruct(true,false,[a,b,(None,c),None]) ->
-	CT_new_destruct
-	  (List.map  xlate_int_or_constr a, xlate_using b, 
-	   xlate_with_names c)
-    | TacInductionDestruct(false,false,[a,b,(None,c),None]) ->
-	CT_new_induction
-	  (List.map xlate_int_or_constr a, xlate_using b,
-	   xlate_with_names c)
-    | TacInductionDestruct(_,false,_) -> 
-	xlate_error "TODO: clause 'in' and full 'as' of destruct/induction"
-    | TacLetTac (na, c, cl, true) when cl = nowhere -> 
-        CT_pose(xlate_id_opt_aux na, xlate_formula c)
-    | TacLetTac (na, c, cl, true) ->
-        CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, 
-		  (* TODO LATER: This should be shared with Unfold,
-		     but the structures are different *)
-		  xlate_clause cl)
-    | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember"
-    | TacAssert (None, Some (_,IntroIdentifier id), c) -> 
-        CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c)
-    | TacAssert (None, None, c) -> 
-        CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
-    | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> 
-        CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c)
-    | TacAssert (Some (TacId []), None, c) -> 
-        CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
-    | TacAssert _ ->
-	xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'"
-    | TacAnyConstructor(false,Some tac) -> 
-	CT_any_constructor
-	(CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac))
-    | TacAnyConstructor(false,None) -> 
-	CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none)
-    | TacAnyConstructor _ -> xlate_error "TODO: econstructor"
-    | TacExtend(_, "ring", [args]) -> 
-	CT_ring
-	  (CT_formula_list
-	     (List.map xlate_formula
-		(out_gen (wit_list0 rawwit_constr) args)))
-    | TacExtend (_, "f_equal", _) -> xlate_error "TODO: f_equal"
-    | TacExtend (_,id, l) ->
-	print_endline ("Extratactics : "^ id);
-     CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l))
-    | TacAlias _ -> xlate_error "Alias not supported"
-
-and coerce_genarg_to_TARG x =
- match Genarg.genarg_tag x with
-  (* Basic types *)
-  | BoolArgType -> xlate_error "TODO: generic boolean argument"
-  | IntArgType ->
-      let n = out_gen rawwit_int x in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)))
-  | IntOrVarArgType ->
-      let x = match out_gen rawwit_int_or_var x with
-	| ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n)
-	| ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x)
-  | StringArgType ->
-     let s = CT_string (out_gen rawwit_string x) in
-       CT_coerce_SCOMMENT_CONTENT_to_TARG
-	 (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT
-	    (CT_coerce_STRING_to_ID_OR_STRING s))
-  | PreIdentArgType ->
-      let id = CT_ident (out_gen rawwit_pre_ident x) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  | IntroPatternArgType ->
-      xlate_error "TODO"
-  | IdentArgType true ->
-      let id = xlate_ident (out_gen rawwit_ident x) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  | IdentArgType false ->
-      xlate_error "TODO"
-  | VarArgType ->
-      let id = xlate_ident (snd (out_gen rawwit_var x)) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  | RefArgType ->
-      let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  (* Specific types *)
-  | SortArgType ->
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      (CT_coerce_FORMULA_to_SCOMMENT_CONTENT
-        (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))))
-  | ConstrArgType ->
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x)))
-  | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
-  | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
-  | OpenConstrArgType b -> 
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      	(CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula
-					 (snd (out_gen
-					    (rawwit_open_constr_gen b) x))))
-  | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
-      let n = Option.get (Pcoq.tactic_genarg_level s) in
-      let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
-      CT_coerce_TACTIC_COM_to_TARG t
-  | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
-  | BindingsArgType -> xlate_error "TODO: generic with bindings"
-  | RedExprArgType -> xlate_error "TODO: generic red expr"
-  | List0ArgType l -> xlate_error "TODO: lists of generic arguments"
-  | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments"
-  | OptArgType x -> xlate_error "TODO: optional generic arguments"
-  | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments"
-  | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments"
-and xlate_context_rule =
-  function
-    | Pat (hyps, concl_pat, tactic) ->
-	CT_context_rule
-	  (CT_context_hyp_list (List.map xlate_match_context_hyps hyps),
-	   xlate_context_pattern concl_pat, xlate_tactic tactic)
-    | All tactic ->
-        CT_def_context_rule (xlate_tactic tactic)
-and formula_to_def_body =
-  function
-    | ConstrEval (red, f) ->
-        CT_coerce_EVAL_CMD_to_DEF_BODY(
-	CT_eval(CT_coerce_NONE_to_INT_OPT CT_none,
-                xlate_red_tactic red, xlate_formula f))
-    | ConstrContext((_, id), f) ->
-       	CT_coerce_CONTEXT_PATTERN_to_DEF_BODY
-	  (CT_context
-	     (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)),
-	      xlate_formula f))
-    | ConstrTypeOf f -> CT_type_of (xlate_formula f)
-    | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c)
-
-and mk_let_value = function 
-    TacArg (ConstrMayEval v) ->
-      CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v)
-  | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);;
-
-let coerce_genarg_to_VARG x =
- match Genarg.genarg_tag x with
-  (* Basic types *)
-  | BoolArgType -> xlate_error "TODO: generic boolean argument"
-  | IntArgType ->
-      let n = out_gen rawwit_int x in
-      CT_coerce_ID_OR_INT_OPT_to_VARG
-	(CT_coerce_INT_OPT_to_ID_OR_INT_OPT
-	   (CT_coerce_INT_to_INT_OPT (CT_int n)))
-  | IntOrVarArgType ->
-      (match out_gen rawwit_int_or_var x with
-	| ArgArg n -> 
-      CT_coerce_ID_OR_INT_OPT_to_VARG
-	(CT_coerce_INT_OPT_to_ID_OR_INT_OPT
-	   (CT_coerce_INT_to_INT_OPT (CT_int n)))
-	| ArgVar (_,id) ->
-	    CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT (xlate_ident id))))
-  | StringArgType ->
-     let s = CT_string (out_gen rawwit_string x) in
-     CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s)
-  | PreIdentArgType ->
-      let id = CT_ident (out_gen rawwit_pre_ident x) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  | IntroPatternArgType ->
-      xlate_error "TODO"
-  | IdentArgType true ->
-      let id = xlate_ident (out_gen rawwit_ident x) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  | IdentArgType false ->
-      xlate_error "TODO"
-  | VarArgType ->
-      let id = xlate_ident (snd (out_gen rawwit_var x)) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  | RefArgType ->
-      let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  (* Specific types *)
-  | SortArgType ->
-     CT_coerce_FORMULA_OPT_to_VARG 
-      (CT_coerce_FORMULA_to_FORMULA_OPT
-	(CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))))
-  | ConstrArgType ->
-     CT_coerce_FORMULA_OPT_to_VARG 
-      (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x)))
-  | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
-  | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
-  | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
-      let n = Option.get (Pcoq.tactic_genarg_level s) in
-      let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
-      CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t)
-  | OpenConstrArgType _ -> xlate_error "TODO: generic open constr"
-  | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
-  | BindingsArgType -> xlate_error "TODO: generic with bindings"
-  | RedExprArgType -> xlate_error "TODO: red expr as generic argument"
-  | List0ArgType l -> xlate_error "TODO: lists of generic arguments"
-  | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments"
-  | OptArgType x -> xlate_error "TODO: optional generic arguments"
-  | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments"
-  | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments"
-
-
-let xlate_thm x = CT_thm (string_of_theorem_kind x)
-
-let xlate_defn k = CT_defn (string_of_definition_kind k)
-
-let xlate_var x = CT_var (match x with
- | (Global,Definitional) -> "Parameter"
- | (Global,Logical) -> "Axiom"
- | (Local,Definitional) -> "Variable"
- | (Local,Logical) -> "Hypothesis"
- | (Global,Conjectural) -> "Conjecture"
- | (Local,Conjectural) -> xlate_error "No local conjecture");;
-
-
-let xlate_dep =
- function
-    | true -> CT_dep "Induction for"
-    | false -> CT_dep "Minimality for";;
-
-let xlate_locn =
- function
-    | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n)
-    | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top")
-    | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev")
-    | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next")
-
-let xlate_search_restr =
-  function
-    | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none
-    | SearchInside (m1::l1) ->
-	CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1,
-	List.map loc_qualid_to_ct_ID l1))
-    | SearchOutside (m1::l1) ->
-	CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1,
-	List.map loc_qualid_to_ct_ID l1))
-    | SearchInside [] -> xlate_error "bad extra argument for Search"
-
-let xlate_check =
- function
-    | "CHECK" -> "Check"
-    | "PRINTTYPE" -> "Type"
-    | _ -> xlate_error "xlate_check";;
-
-let build_constructors l =
- let f (coe,((_,id),c)) =
-   if coe then CT_constr_coercion (xlate_ident id, xlate_formula c)
-   else CT_constr (xlate_ident id, xlate_formula c) in
- CT_constr_list (List.map f l)
-
-let build_record_field_list l =
- let build_record_field ((coe,d),not) = match d with
-  | AssumExpr (id,c) ->
-      if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c)
-      else
-	CT_recconstr(xlate_id_opt id, xlate_formula c)
-  | DefExpr (id,c,topt) ->
-      if coe then
- 	CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c,
-			      xlate_formula_opt topt)
-      else
- 	CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in
- CT_recconstr_list (List.map build_record_field l);;
-
-let get_require_flags impexp spec =
- let ct_impexp =
-  match impexp with
-  | None -> CT_coerce_NONE_to_IMPEXP CT_none
-  | Some false -> CT_import
-  | Some true -> CT_export in
- let ct_spec =
-  match spec with
-  | None -> ctv_SPEC_OPT_NONE
-  | Some true -> CT_spec
-  | Some false -> ctv_SPEC_OPT_NONE in
- ct_impexp, ct_spec;;
-
-let cvt_optional_eval_for_definition c1 optional_eval =
-  match optional_eval with
-    None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1)
-  | Some red ->
-      CT_coerce_EVAL_CMD_to_DEF_BODY(
-      CT_eval(CT_coerce_NONE_to_INT_OPT CT_none,
-	      xlate_red_tactic red,
-	      xlate_formula c1))
-
-let cvt_vernac_binder = function
-  | b,(id::idl,c) ->
-      let l,t = 
-	CT_id_opt_ne_list 
-          (xlate_ident_opt (Some (snd id)),
-           List.map (fun id -> xlate_ident_opt (Some (snd id))) idl),
-          xlate_formula c in
-	if b then
-	  CT_binder_coercion(l,t)
-	else
-	  CT_binder(l,t)
-  | _, _ -> xlate_error "binder with no left part, rejected";;
-
-let cvt_vernac_binders = function
-    a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args)
-  | [] -> assert false;;
-
-
-let xlate_comment = function
-    CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c)
-  | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT
-      (CT_coerce_STRING_to_ID_OR_STRING(CT_string s))
-  | CommentInt n ->
-      CT_coerce_FORMULA_to_SCOMMENT_CONTENT
-	(CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));;
-
-let translate_opt_notation_decl = function
-    None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none)
-  |  Some(s, f, sc) ->
-       let tr_sc = 
-	 match sc with 
-	     None -> ctv_ID_OPT_NONE
-	   | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in
-       CT_decl_notation(CT_string s, xlate_formula f, tr_sc);;
-
-let xlate_level = function
-    Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n)
-  | Extend.NextLevel -> CT_next_level;;
-
-let xlate_syntax_modifier = function
-    Extend.SetItemLevel((s::sl), level) ->
-      CT_set_item_level
-	(CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl),
-	 xlate_level level)
-  | Extend.SetItemLevel([], _) -> assert false
-  | Extend.SetLevel level -> CT_set_level (CT_int level)
-  | Extend.SetAssoc Gramext.LeftA -> CT_lefta
-  | Extend.SetAssoc Gramext.RightA -> CT_righta
-  | Extend.SetAssoc Gramext.NonA -> CT_nona
-  | Extend.SetEntryType(x,typ) ->
-      CT_entry_type(CT_ident x,
-		 match typ with
-		     Extend.ETIdent -> CT_ident "ident"
-		   | Extend.ETReference -> CT_ident "global"
-		   | Extend.ETBigint -> CT_ident "bigint"
-		   | _ -> xlate_error "syntax_type not parsed")
-  | Extend.SetOnlyParsing -> CT_only_parsing
-  | Extend.SetFormat(_,s) -> CT_format(CT_string s);;
-
-
-let rec xlate_module_type = function
-  | CMTEident(_, qid) -> 
-      CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid))
-  | CMTEwith(mty, decl) ->
-      let mty1 = xlate_module_type mty in
-	(match decl with
-	     CWith_Definition((_, idl), c) ->
-	       CT_module_type_with_def(mty1, 
-				       CT_id_list (List.map xlate_ident idl),
-                                       xlate_formula c)
-	   | CWith_Module((_, idl), (_, qid)) ->
-	       CT_module_type_with_mod(mty1,
-				       CT_id_list (List.map xlate_ident idl), 
-				       CT_ident (xlate_qualid qid)))
-  | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";;
-
-
-let xlate_module_binder_list (l:module_binder list) =
-  CT_module_binder_list
-    (List.map (fun (_, idl, mty) ->
-		 let idl1 = 
-		   List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in
-		 let fst,idl2 = match idl1 with
-		     [] -> assert false
-		   | fst::idl2 -> fst,idl2 in
-		 CT_module_binder
-		   (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);;
-
-let xlate_module_type_check_opt = function
-    None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK
- 	(CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE)
-  | Some(mty, true) -> CT_only_check(xlate_module_type mty)
-  | Some(mty, false) -> 
-      CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK
-	(CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
-	   (xlate_module_type mty));;
-
-let rec xlate_module_expr = function
-    CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR
-	(CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid)))
-  | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1,
-					 xlate_module_expr me2)
-
-let rec xlate_vernac =
- function
-   | VernacDeclareTacticDefinition (true, tacs) ->
-       (match List.map 
-	 (function
-	      (id, _, body) ->
-		CT_tac_def(reference_to_ct_ID id, xlate_tactic body))
-	 tacs with
-	     [] -> assert false
-	   | fst::tacs1 ->
-	       CT_tactic_definition
-		 (CT_tac_def_ne_list(fst, tacs1)))
-   | VernacDeclareTacticDefinition(false, _) -> 
-       xlate_error "obsolete tactic definition not handled"
-    | VernacLoad (verbose,s) ->
-      CT_load (
-       (match verbose with
-        | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none
-        | true -> CT_verbose),
-       CT_coerce_STRING_to_ID_OR_STRING (CT_string s))
-    | VernacCheckMayEval (Some red, numopt, f) ->
-      let red = xlate_red_tactic red in
-      CT_coerce_EVAL_CMD_to_COMMAND
-       (CT_eval (xlate_int_opt numopt, red, xlate_formula f))
-    |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s)
-    | VernacAddLoadPath (false,str,None) ->
- 	CT_addpath (CT_string str, ctv_ID_OPT_NONE)
-    | VernacAddLoadPath (false,str,Some x) ->
- 	CT_addpath (CT_string str,
-		    CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x)))
-    | VernacAddLoadPath (true,str,None) ->
- 	CT_recaddpath (CT_string str, ctv_ID_OPT_NONE)
-    | VernacAddLoadPath (_,str, Some x) ->
-	CT_recaddpath (CT_string str,
-		       CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x)))
-    | VernacRemoveLoadPath str -> CT_delpath (CT_string str)
-    | VernacToplevelControl Quit -> CT_quit
-    | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported"
-      (*ML commands *)
-    | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str)
-    | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str)
-    | VernacDeclareMLModule [] -> failwith ""
-    | VernacDeclareMLModule (str :: l) ->
-      CT_ml_declare_modules
-       (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l))
-    | VernacGoal c ->
-	CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c))
-    | VernacAbort (Some (_,id)) ->
-	CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id))
-    | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE
-    | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL
-    | VernacRestart -> CT_restart
-    | VernacSolve (n, tac, b) -> 
-	CT_solve (CT_int n, xlate_tactic tac,
-		  if b then CT_dotdot
-                  else CT_coerce_NONE_to_DOTDOT_OPT CT_none)
-
-(* MMode *)
-
-    | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> 
-	anomaly "No MMode in CTcoq"
-
-
-(* /MMode *)
-
-    | VernacFocus nopt -> CT_focus (xlate_int_opt nopt)
-    | VernacUnfocus -> CT_unfocus
-    |VernacExtend("Extraction", [f;l]) ->
-       let file = out_gen rawwit_string f in
-       let l1 = out_gen (wit_list1 rawwit_ref) l in
-       let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in
-	 CT_extract_to_file(CT_string file, 
-		       CT_id_ne_list(loc_qualid_to_ct_ID fst,
-				     List.map loc_qualid_to_ct_ID l2))
-    | VernacExtend("ExtractionInline", [l]) ->
-	let l1 = out_gen (wit_list1 rawwit_ref) l in
-	let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in
-	CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
-				List.map loc_qualid_to_ct_ID l2))
-    | VernacExtend("ExtractionNoInline", [l]) ->
-	let l1 = out_gen (wit_list1 rawwit_ref) l in
-	let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in
-	CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
-				List.map loc_qualid_to_ct_ID l2))
-    | VernacExtend("Field", 
-		   [fth;ainv;ainvl;div]) ->
-	(match List.map (fun v -> xlate_formula(out_gen rawwit_constr v))
-                   [fth;ainv;ainvl]
- 	 with
-             [fth1;ainv1;ainvl1] ->
-	       let adiv1 =
-                 xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in
-	       CT_add_field(fth1, ainv1, ainvl1, adiv1)
-	   |_ -> assert false)
-  | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) ->
-      let orient = out_gen Extraargs.rawwit_orient o in
-      let formula_list = out_gen (wit_list1 rawwit_constr) f in
-      let base = out_gen rawwit_pre_ident b in
-      let t = 
-	match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId []
-      in
-      let ct_orient = match orient with
-	| true  -> CT_lr
-	| false -> CT_rl in
-      let f_ne_list = match List.map xlate_formula formula_list with
-	  (fst::rest) -> CT_formula_ne_list(fst,rest)
-	| _ -> assert false in
-      CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t)
-  | VernacCreateHintDb (local,dbname,b) ->
-      xlate_error "TODO: VernacCreateHintDb"
-  | VernacHints (local,dbnames,h) ->
-      let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in
-      (match h with
-	| HintsConstructors l ->
-	 let n1, names = match List.map tac_qualid_to_ct_ID l with
-	     n1 :: names -> n1, names
-	   | _  -> failwith "" in
-	   if local then
-	     CT_local_hints(CT_ident "Constructors",
-			    CT_id_ne_list(n1, names), dblist)
-	   else
-	     CT_hints(CT_ident "Constructors",
-		      CT_id_ne_list(n1, names), dblist)
-	| HintsExtern (n, c, t) ->
-	    let pat = match c with 
-	      | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none)
-	      | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) 
-	    in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist)
-        | HintsImmediate l -> 
-	 let f1, formulas = match List.map xlate_formula l with
-	     a :: tl -> a, tl
-	   | _  -> failwith "" in
-	 let l' = CT_formula_ne_list(f1, formulas) in
-	   if local then
-             (match h with 
-		  HintsResolve _ ->
-		    CT_local_hints_resolve(l', dblist)
-	       	| HintsImmediate _ ->
-		    CT_local_hints_immediate(l', dblist)
-	       	| _ -> assert false)
-	   else
-	     (match h with
-		  HintsResolve _ -> CT_hints_resolve(l', dblist)
-		| HintsImmediate _ -> CT_hints_immediate(l', dblist)
-		| _ -> assert false)
-        | HintsResolve l -> 
-	 let f1, formulas = match List.map xlate_formula (List.map pi3 l) with
-	     a :: tl -> a, tl
-	   | _  -> failwith "" in
-	 let l' = CT_formula_ne_list(f1, formulas) in
-	   if local then
-             (match h with 
-		  HintsResolve _ ->
-		    CT_local_hints_resolve(l', dblist)
-	       	| HintsImmediate _ ->
-		    CT_local_hints_immediate(l', dblist)
-	       	| _ -> assert false)
-	   else
-	     (match h with
-		  HintsResolve _ -> CT_hints_resolve(l', dblist)
-		| HintsImmediate _ -> CT_hints_immediate(l', dblist)
-		| _ -> assert false)
-        | HintsUnfold l -> 
-	 let n1, names = match List.map loc_qualid_to_ct_ID l with
-	     n1 :: names -> n1, names
-	   | _  -> failwith "" in
-	   if local then
-             CT_local_hints(CT_ident "Unfold",
-			    CT_id_ne_list(n1, names), dblist)
-	   else	     
-             CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist)
-        | HintsTransparency (l,b) -> 
-	 let n1, names = match List.map loc_qualid_to_ct_ID l with
-	     n1 :: names -> n1, names
-	   | _  -> failwith "" in
-	 let ty = if b then "Transparent" else "Opaque" in
-	   if local then
-             CT_local_hints(CT_ident ty,
-			    CT_id_ne_list(n1, names), dblist)
-	   else	     
-             CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist)
-       	| HintsDestruct(id, n, loc, f, t) ->
-	    let dl = match loc with
-		ConclLocation() -> CT_conclusion_location
-	      | HypLocation true -> CT_discardable_hypothesis
-	      | HypLocation false -> CT_hypothesis_location in
-	     if local then
-               CT_local_hint_destruct
-		 (xlate_ident id, CT_int n,
-		  dl, xlate_formula f, xlate_tactic t, dblist)
-	     else
-	       CT_hint_destruct
-		 (xlate_ident id, CT_int n, dl, xlate_formula f,
-		  xlate_tactic t, dblist)
-)
-  | VernacEndProof (Proved (true,None)) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE)
-  | VernacEndProof (Proved (false,None)) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE)
-  | VernacEndProof (Proved (b,Some ((_,s), Some kind))) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind),
-       ctf_ID_OPT_SOME (xlate_ident s))
-  | VernacEndProof (Proved (b,Some ((_,s),None))) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"),
-       ctf_ID_OPT_SOME (xlate_ident s))
-  | VernacEndProof Admitted ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE)
-  | VernacSetOpacity (_,l) ->
-      CT_strategy(CT_level_list
-        (List.map (fun (l,q) ->
-          (level_to_ct_LEVEL l,
-           CT_id_list(List.map loc_qualid_to_ct_ID q))) l))
-  | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n))
-  | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt)
-  | VernacShow ShowNode -> CT_show_node
-  | VernacShow ShowProof -> CT_show_proof
-  | VernacShow ShowTree -> CT_show_tree
-  | VernacShow ShowProofNames -> CT_show_proofs
-  | VernacShow (ShowIntros true) -> CT_show_intros
-  | VernacShow (ShowIntros false) -> CT_show_intro
-  | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1)
-  | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n)
-  | VernacShow ShowExistentials -> CT_show_existentials
-  | VernacShow ShowScript -> CT_show_script
-  | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)"
-  | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)"
-  | VernacGo arg -> CT_go (xlate_locn arg)
-  | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l)
-  | VernacShow (ExplainTree l) ->
-      CT_explain_prooftree (nums_to_int_list l)
-  | VernacCheckGuard -> CT_guarded
-  | VernacPrint p ->
-      (match p with
-	  PrintFullContext -> CT_print_all
-	| PrintName id -> CT_print_id (loc_qualid_to_ct_ID id)
-	| PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id)
-	| PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id)
-	| PrintModules -> CT_print_modules
-	| PrintGrammar name -> CT_print_grammar CT_grammar_none
-	| PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star)
-	| PrintHintDbName id -> 
-	    CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id))
-	| PrintRewriteHintDbName id -> 
-	    CT_print_rewrite_hintdb (CT_ident id)
-	| PrintHint id ->
-	    CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id))
-	| PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE
-	| PrintLoadPath None -> CT_print_loadpath
-	| PrintLoadPath _ -> xlate_error "TODO: Print LoadPath dir"
-	| PrintMLLoadPath -> CT_ml_print_path
-	| PrintMLModules -> CT_ml_print_modules
-	| PrintGraph -> CT_print_graph
-	| PrintClasses -> CT_print_classes
-	| PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid)
-	| PrintCoercions -> CT_print_coercions
-	| PrintCoercionPaths (id1, id2) -> 
-	    CT_print_path (xlate_class id1, xlate_class id2)
-	| PrintCanonicalConversions ->
-	    xlate_error "TODO: Print Canonical Structures"
-	| PrintAssumptions _ -> 
-	    xlate_error "TODO: Print Needed Assumptions"
-	| PrintInstances _ -> 
-	    xlate_error "TODO: Print Instances"
-	| PrintTypeClasses -> 
-	    xlate_error "TODO: Print TypeClasses"
-	| PrintInspect n -> CT_inspect (CT_int n)
-	| PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s)
-	| PrintTables -> CT_print_tables
-        | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a)
-        | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a)
-        | PrintScopes -> CT_print_scopes
-        | PrintScope id -> CT_print_scope (CT_ident id)
-	| PrintVisibility id_opt ->
-	    CT_print_visibility 
-	      (match id_opt with
-		   Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id)
-		 | None -> ctv_ID_OPT_NONE)
-        | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid)
-	| PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid))
-  | VernacBeginSection (_,id) ->
-      CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id))
-  | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id)
-  | VernacStartTheoremProof (k, [Some (_,s), (bl,c)], _, _) ->
-      CT_coerce_THEOREM_GOAL_to_COMMAND(
-	CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s,
-           xlate_binder_list bl, xlate_formula c))
-  | VernacStartTheoremProof _ ->
-      xlate_error "TODO: Mutually dependent theorems"
-  | VernacSuspend -> CT_suspend
-  | VernacResume idopt -> CT_resume (xlate_ident_opt (Option.map snd idopt))
-  | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) ->
-      CT_coerce_THEOREM_GOAL_to_COMMAND
-	(CT_theorem_goal
-	   (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k),
-	    xlate_ident s, xlate_binder_list bl, xlate_formula typ))
-  | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) ->
-      CT_definition
-	(xlate_defn kind, xlate_ident s, xlate_binder_list bl,
-	   cvt_optional_eval_for_definition c red_option,
-           xlate_formula_opt typ_opt)
-  | VernacAssumption (kind,inline ,b) ->xlate_error "TODO: Parameter Inline"
-      (*inline : bool -> automatic delta reduction at fonctor application*)
-     (* CT_variable (xlate_var kind, cvt_vernac_binders b)*)
-  | VernacCheckMayEval (None, numopt, c) ->
-      CT_check (xlate_formula c)
-  | VernacSearch (s,x) ->
-      let translated_restriction = xlate_search_restr x in
-      (match s with
-	| SearchPattern c ->
-	    CT_search_pattern(xlate_formula c, translated_restriction)
-	| SearchHead id ->
-	    CT_search(loc_qualid_to_ct_ID id, translated_restriction)
-	| SearchRewrite c ->
-	    CT_search_rewrite(xlate_formula c, translated_restriction)
-	| SearchAbout (a::l) ->
-	    let xlate_search_about_item (b,it) =
-              if not b then xlate_error "TODO: negative searchabout constraint";
-	      match it with
-		  SearchSubPattern (CRef x) -> 
-		    CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x)
-		| SearchString (s,None) -> 
-		    CT_coerce_STRING_to_ID_OR_STRING(CT_string s)
-		| SearchString _ | SearchSubPattern _ ->
-                    xlate_error
-		    "TODO: search subpatterns or notation with explicit scope"
-	    in
-	    CT_search_about
-	      (CT_id_or_string_ne_list(xlate_search_about_item a,
-				       List.map xlate_search_about_item l),
-	       translated_restriction)
-  	| SearchAbout [] -> assert false)
-
-(*   | (\*Record from tactics/Record.v *\) *)
-(*     VernacRecord  *)
-(*       (_, (add_coercion, (_,s)), binders, c1, *)
-(*        rec_constructor_or_none, field_list) -> *)
-(*       let record_constructor = *)
-(*         xlate_ident_opt (Option.map snd rec_constructor_or_none) in *)
-(*       CT_record *)
-(*        ((if add_coercion then CT_coercion_atm else *)
-(*           CT_coerce_NONE_to_COERCION_OPT(CT_none)), *)
-(*         xlate_ident s, xlate_binder_list binders,  *)
-(* 	xlate_formula (Option.get c1), record_constructor, *)
-(*          build_record_field_list field_list) *)
-   | VernacInductive (isind, lmi) ->
-      let co_or_ind = if Decl_kinds.recursivity_flag_of_kind isind then "Inductive" else "CoInductive" in
-      let strip_mutind = function
-          (((_, (_,s)), parameters, c, _, Constructors constructors), notopt) ->
-          CT_ind_spec
-            (xlate_ident s, xlate_binder_list parameters, xlate_formula (Option.get c),
-             build_constructors constructors,
-	     translate_opt_notation_decl notopt) 
-	| _ -> xlate_error "TODO: Record notation in (Co)Inductive" in
-        CT_mind_decl
-	  (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi))
-   | VernacFixpoint ([],_) -> xlate_error "mutual recursive"
-   | VernacFixpoint ((lm :: lmi),boxed) ->
-      let strip_mutrec (((_,fid), (n, ro), bl, arf, ardef), _ntn) =
-        let struct_arg = make_fix_struct (n, bl) in
-        let arf = xlate_formula arf in
-        let ardef = xlate_formula ardef in
-	match xlate_binder_list bl with
-	  | CT_binder_list (b :: bl) ->
-	      CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), 
-			  struct_arg, arf, ardef)
-          | _ -> xlate_error "mutual recursive" in
-        CT_fix_decl
-	  (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi))
-   | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive"
-   | VernacCoFixpoint ((lm :: lmi),boxed) ->
-      let strip_mutcorec (((_,fid), bl, arf, ardef), _ntn) =
-	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
-                      xlate_formula arf, xlate_formula ardef) in
-        CT_cofix_decl
-	  (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))
-   | VernacScheme [] -> xlate_error "induction scheme"
-   | VernacScheme (lm :: lmi) ->
-      let strip_ind = function
-      | (Some (_,id), InductionScheme (depstr, inde, sort)) ->
-           CT_scheme_spec
-            (xlate_ident id, xlate_dep depstr, 
-	    CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
-	     xlate_sort sort)
-      | (None, InductionScheme (depstr, inde, sort)) ->
-           CT_scheme_spec
-            (xlate_ident (id_of_string ""), xlate_dep depstr,
-            CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
-             xlate_sort sort)
-      | (_, EqualityScheme _) -> xlate_error "TODO: Scheme Equality" in
-        CT_ind_scheme
-	  (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi))
-   | VernacCombinedScheme _ -> xlate_error "TODO: Combined Scheme"
-   | VernacSyntacticDefinition ((_,id), ([],c), false, _) ->
-       CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None)
-   | VernacSyntacticDefinition ((_,id), _, _, _) ->
-       xlate_error"TODO: Local abbreviations and abbreviations with parameters"
-  (* Modules and Module Types *)
-   | VernacInclude (_) -> xlate_error "TODO : Include "
-   | VernacDeclareModuleType((_, id), bl, mty_o)  -> 
-      CT_module_type_decl(xlate_ident id,
-			  xlate_module_binder_list bl,
-			  match mty_o with
-			      None ->
-				CT_coerce_ID_OPT_to_MODULE_TYPE_OPT
-				  ctv_ID_OPT_NONE
-			    | Some mty1 ->
-				CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
-				  (xlate_module_type mty1))
-   | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) ->
-       CT_module(xlate_ident id, 
-		 xlate_module_binder_list bl,
-		 xlate_module_type_check_opt mty_o,
-		 match mexpr_o with
-		     None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE
-		   | Some m -> xlate_module_expr m)
-  | VernacDeclareModule(_,(_, id), bl, mty_o) -> 
-       CT_declare_module(xlate_ident id, 
-		 xlate_module_binder_list bl,
-		 xlate_module_type_check_opt (Some mty_o),
-		 CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE)
-   | VernacRequire (impexp, spec, id::idl) ->
-      let ct_impexp, ct_spec = get_require_flags impexp spec in
-      CT_require (ct_impexp, ct_spec, 
-		  CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING(
-		  CT_id_ne_list(loc_qualid_to_ct_ID id,
-				List.map loc_qualid_to_ct_ID idl)))
-   | VernacRequire (_,_,[]) ->
-       xlate_error "Require should have at least one id argument"
-   | VernacRequireFrom (impexp, spec, filename) ->
-      let ct_impexp, ct_spec = get_require_flags impexp spec in
-      CT_require(ct_impexp, ct_spec, 
-		 CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename))
-
-   | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s)
-   | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s)
-   | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s)
-   | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s)
-   | VernacArgumentsScope(true, qid, l) -> 
-       CT_arguments_scope(loc_qualid_to_ct_ID qid,
-		       CT_id_opt_list
-		       (List.map
-			  (fun x ->
-				  match x with
-				      None -> ctv_ID_OPT_NONE
-				    | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l))
-   | VernacArgumentsScope(false, qid, l) -> 
-       xlate_error "TODO: Arguments Scope Global"
-   | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2)
-   | VernacBindScope(id, a::l) -> 
-       let xlate_class_rawexpr = function
-	   FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass"
-	 | RefClass qid -> loc_qualid_to_ct_ID qid in
-       CT_bind_scope(CT_ident id,
-		     CT_id_ne_list(xlate_class_rawexpr a,
-				   List.map xlate_class_rawexpr l))
-   | VernacBindScope(id, []) -> assert false
-   | VernacNotation(b, c, (s,modif_list), opt_scope) -> 
-       let translated_s = CT_string s in
-       let formula = xlate_formula c in
-       let translated_modif_list = 
-	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
-       let translated_scope = match opt_scope with
-	   None -> ctv_ID_OPT_NONE
-	 | Some x -> ctf_ID_OPT_SOME(CT_ident x) in
-       if b then
-       CT_local_define_notation
-	 (translated_s, formula, translated_modif_list, translated_scope)
-       else
-	 CT_define_notation(translated_s, formula, 
-			    translated_modif_list, translated_scope)
-   | VernacSyntaxExtension(b,(s,modif_list)) -> 
-       let translated_s = CT_string s in
-       let translated_modif_list = 
-	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
-       if b then
-	 CT_local_reserve_notation(translated_s, translated_modif_list)
-       else
-	 CT_reserve_notation(translated_s, translated_modif_list)
-   | VernacInfix (b,(str,modl),id, opt_scope) ->
-       let id1 = loc_qualid_to_ct_ID id in
-       let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in
-       let s = CT_string str in
-       let translated_scope = match opt_scope with
-	   None -> ctv_ID_OPT_NONE
-	 | Some x -> ctf_ID_OPT_SOME(CT_ident x) in
-	 if b then
-	   CT_local_infix(s, id1,modl1, translated_scope)
-	 else
-	   CT_infix(s, id1,modl1, translated_scope)
-   | VernacCoercion (s, id1, id2, id3) ->
-      let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in
-      let local_opt =
-       match s with
-       (* Cannot decide whether it is a global or a Local but at toplevel *)
-       | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none
-       | Local -> CT_local in
-      CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1,
-        xlate_class id2, xlate_class id3)
-
-   | VernacIdentityCoercion (s, (_,id1), id2, id3) ->
-      let id_opt = CT_identity in
-      let local_opt =
-       match s with
-       (* Cannot decide whether it is a global or a Local but at toplevel *)
-       | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none
-       | Local -> CT_local in
-      CT_coercion (local_opt, id_opt, xlate_ident id1,
-        xlate_class id2, xlate_class id3)
-
-    (* Type Classes *) 
-   | VernacDeclareInstance _|VernacContext _|
-	 VernacInstance (_, _, _, _, _) ->
-	   xlate_error "TODO: Type Classes commands"
-
-  | VernacResetName id -> CT_reset (xlate_ident (snd id))
-  | VernacResetInitial -> CT_restore_state (CT_ident "Initial")
-  | VernacExtend (s, l) ->
-      CT_user_vernac
-       (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l))
-  | VernacList((_, a)::l) -> 
-      CT_coerce_COMMAND_LIST_to_COMMAND
-	(CT_command_list(xlate_vernac a, 
-			 List.map (fun (_, x) -> xlate_vernac x) l))
-  | VernacList([]) -> assert false
-  | VernacNop -> CT_proof_no_op
-  | VernacComments l -> 
-      CT_scomments(CT_scomment_content_list (List.map xlate_comment l))
-  | VernacDeclareImplicits(true, id, opt_positions) ->
-      CT_implicits
-	(reference_to_ct_ID id,
-	 match opt_positions with
-	     None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none
-	   | Some l -> 
-	       CT_coerce_ID_LIST_to_ID_LIST_OPT
-	       (CT_id_list
-	       (List.map
-		  (function ExplByPos (x,_), _, _
-		       -> xlate_error
-			   "explication argument by rank is obsolete"
-		     | ExplByName id, _, _ -> CT_ident (string_of_id id)) l)))
-  | VernacDeclareImplicits(false, id, opt_positions) ->
-      xlate_error "TODO: Implicit Arguments Global"
-  | VernacReserve((_,a)::l, f) ->
-      CT_reserve(CT_id_ne_list(xlate_ident a, 
-			       List.map (fun (_,x) -> xlate_ident x) l),
-		 xlate_formula f)
-  | VernacReserve([], _) -> assert false
-  | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id)
-  | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id)
-  | VernacLocate(LocateModule _) -> xlate_error "TODO: Locate Module"
-  | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s)
-  | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s)
-  | VernacTime(v) -> CT_time(xlate_vernac v)
-  | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[])
-  |VernacExactProof f -> CT_proof(xlate_formula f)
-  | VernacSetOption (table, BoolValue true) -> 
-      let table1 = 
-	match table with
-	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
-	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
-	CT_set_option(table1)
-  | VernacSetOption (table, v) -> 
-      let table1 = 
-	match table with
-	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
-	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
-      let value =
-	match v with
-	  | BoolValue _ -> assert false
-	  | StringValue s ->
-	      CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s)
-	  | IntValue n ->
-	      CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in
-	CT_set_option_value(table1, value)
-  | VernacUnsetOption(table) ->
-      let table1 = 
-	match table with
-	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
-	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
-	CT_unset_option(table1)
-  | VernacAddOption (table, l) ->
-      let values =
-	List.map
-	  (function
-	     | QualidRefValue x -> 
-		 CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x)
-	     | StringRefValue x -> 
-		 CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in
-      let fst, values1 = 
-	match values with [] -> assert false | a::b -> (a,b) in
-      let table1 = 
-	match table with
-	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
-	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
-	CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1))
-  | VernacImport(true, a::l) ->
-      CT_export_id(CT_id_ne_list(reference_to_ct_ID a,
-				 List.map reference_to_ct_ID l))
-  | VernacImport(false, a::l) ->
-      CT_import_id(CT_id_ne_list(reference_to_ct_ID a,
-				 List.map reference_to_ct_ID l))
-  | VernacImport(_, []) -> assert false
-  | VernacProof t -> CT_proof_with(xlate_tactic t)
-  | (VernacGlobalCheck _|VernacPrintOption _|
-     VernacMemOption (_, _)|VernacRemoveOption (_, _)
-  | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _|
-    VernacSolveExistential (_, _)|VernacCanonical _ |
-     VernacTacticNotation _ | VernacUndoTo _ | VernacRemoveName _)
-    -> xlate_error "TODO: vernac"
-and level_to_ct_LEVEL = function
-    Conv_oracle.Opaque -> CT_Opaque
-  | Conv_oracle.Level n -> CT_Level (CT_int n)
-  | Conv_oracle.Expand -> CT_Expand;;
-
-
-let rec xlate_vernac_list =
- function
-   | VernacList (v::l) ->
-       CT_command_list
-         (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l)
-   | VernacList [] -> xlate_error "xlate_command_list"
-   | _ -> xlate_error "Not a list of commands";;
diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli
deleted file mode 100644
index 2e2b95fe..00000000
--- a/contrib/interface/xlate.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-open Ascent;;
-
-val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;;
-val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;;
-val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;;
-val xlate_ident : Names.identifier -> ct_ID;;
-val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;;
-
diff --git a/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v
deleted file mode 100644
index 6885b82c..00000000
--- a/contrib/micromega/RingMicromega.v
+++ /dev/null
@@ -1,779 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                      Evgeny Makarov, INRIA, 2007                     *)
-(************************************************************************)
-
-Require Import NArith.
-Require Import Relation_Definitions.
-Require Import Setoid.
-(*****)
-Require Import Env.
-Require Import EnvRing.
-(*****)
-Require Import List.
-Require Import Bool.
-Require Import OrderedRing.
-Require Import Refl.
-
-
-Set Implicit Arguments.
-
-Import OrderedRingSyntax.
-
-Section Micromega.
-
-(* Assume we have a strict(ly?) ordered ring *)
-
-Variable R : Type.
-Variables rO rI : R.
-Variables rplus rtimes rminus: R -> R -> R.
-Variable ropp : R -> R.
-Variables req rle rlt : R -> R -> Prop.
-
-Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
-
-Notation "0" := rO.
-Notation "1" := rI.
-Notation "x + y" := (rplus x y).
-Notation "x * y " := (rtimes x y).
-Notation "x - y " := (rminus x y).
-Notation "- x" := (ropp x).
-Notation "x == y" := (req x y).
-Notation "x ~= y" := (~ req x y).
-Notation "x <= y" := (rle x y).
-Notation "x < y" := (rlt x y).
-
-(* Assume we have a type of coefficients C and a morphism from C to R *)
-
-Variable C : Type.
-Variables cO cI : C.
-Variables cplus ctimes cminus: C -> C -> C.
-Variable copp : C -> C.
-Variables ceqb cleb : C -> C -> bool.
-Variable phi : C -> R.
-
-(* Power coefficients *)
-Variable E : Set. (* the type of exponents *)
-Variable pow_phi : N -> E.
-Variable rpow : R -> E -> R.
-
-Notation "[ x ]" := (phi x).
-Notation "x [=] y" := (ceqb x y).
-Notation "x [<=] y" := (cleb x y).
-
-(* Let's collect all hypotheses in addition to the ordered ring axioms into
-one structure *)
-
-Record SORaddon := mk_SOR_addon {
-  SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
-  SORpower : power_theory rI rtimes req pow_phi rpow;
-  SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
-  SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
-}.
-
-Variable addon : SORaddon.
-
-Add Relation R req
-  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
-  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
-  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
-as micomega_sor_setoid.
-
-Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
-Proof.
-exact sor.(SORplus_wd).
-Qed.
-Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
-Proof.
-exact sor.(SORtimes_wd).
-Qed.
-Add Morphism ropp with signature req ==> req as ropp_morph.
-Proof.
-exact sor.(SORopp_wd).
-Qed.
-Add Morphism rle with signature req ==> req ==> iff as rle_morph.
-Proof.
-  exact sor.(SORle_wd).
-Qed.
-Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
-Proof.
-  exact sor.(SORlt_wd).
-Qed.
-
-Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
-Proof.
-  exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
-Qed.
-
-Definition cneqb (x y : C) := negb (ceqb x y).
-Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
-
-Notation "x [~=] y" := (cneqb x y).
-Notation "x [<] y" := (cltb x y).
-
-Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
-Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
-Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
-
-Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
-Proof.
-  exact addon.(SORcleb_morph).
-Qed.
-
-Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
-Proof.
-intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
-destruct (ceqb x y); now try discriminate.
-Qed.
-
-Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
-Proof.
-intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
-apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
-Qed.
-
-(* Begin Micromega *)
-
-Definition PExprC := PExpr C. (* arbitrary expressions built from +, *, - *)
-Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
-(*****)
-(*Definition Env := Env R. (* For interpreting PExprC *)*)
-Definition PolEnv := Env R. (* For interpreting PolC *)
-(*****)
-(*Definition Env := list R.
-Definition PolEnv := list R.*)
-(*****)
-
-(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr
-explicitely below and not through PEeval, as the following lemma says? The
-function eval_pexpr seems to be a straightforward special case of PEeval
-when the environment (i.e., the second last argument of PEeval) of type
-off_map (which is (option positive * t)) is (None, env). *)
-
-(*****)
-Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R :=
-match pe with
-| PEc c => phi c
-| PEX j =>  l j
-| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
-| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
-| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
-| PEopp pe1 => - (eval_pexpr l pe1)
-| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
-end.
-
-
-Lemma eval_pexpr_simpl : forall  (l : PolEnv) (pe : PExprC),
-  eval_pexpr l pe = 
-  match pe with
-    | PEc c => phi c
-    | PEX j => l j
-    | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
-    | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
-    | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
-    | PEopp pe1 => - (eval_pexpr l pe1)
-    | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
-  end.
-Proof.
-  intros ; destruct pe ; reflexivity.
-Qed.
-
-
-
-Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC),
-  eval_pexpr env pe =
-  PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe.
-Proof.
-induction pe; simpl; intros.
-reflexivity.
-reflexivity.
-rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
-rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
-rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
-rewrite <- IHpe; reflexivity.
-rewrite <- IHpe; reflexivity.
-Qed.
-(*****)
-(*Definition eval_pexpr : Env -> PExprC -> R :=
-  PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*)
-(*****)
-
-Inductive Op1 : Set := (* relations with 0 *)
-| Equal (* == 0 *)
-| NonEqual (* ~= 0 *)
-| Strict (* > 0 *)
-| NonStrict (* >= 0 *).
-
-Definition NFormula := (PExprC * Op1)%type. (* normalized formula *)
-
-Definition eval_op1 (o : Op1) : R -> Prop :=
-match o with
-| Equal => fun x => x == 0
-| NonEqual => fun x : R => x ~= 0
-| Strict => fun x : R => 0 < x
-| NonStrict => fun x : R => 0 <= x
-end.
-
-Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
-let (p, op) := f in eval_op1 op (eval_pexpr env p).
-
-
-Definition OpMult (o o' : Op1) : Op1 :=
-match o with
-| Equal => Equal
-| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *)
-| Strict => o'
-| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *)
-end.
-
-Definition OpAdd (o o': Op1) : Op1 :=
-match o with
-| Equal => o'
-| NonStrict =>
-  match o' with
-  | Strict => Strict
-  | _ => NonStrict
-  end
-| Strict => Strict
-| NonEqual => NonEqual (* does not matter what we return here *)
-end.
-
-Lemma OpMultNonEqual :
-  forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual.
-Proof.
-intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
-try (intro H; apply H1; reflexivity);
-try (intro H; apply H2; reflexivity).
-Qed.
-
-Lemma OpAdd_NonEqual :
-  forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual.
-Proof.
-intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
-try (intro H; apply H1; reflexivity);
-try (intro H; apply H2; reflexivity).
-Qed.
-
-Lemma OpMult_sound :
-  forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual ->
-    eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y).
-Proof.
-unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4.
-rewrite H3; now rewrite (Rtimes_0_l sor).
-elimtype False; now apply H1.
-destruct o'.
-rewrite H4; now rewrite (Rtimes_0_r sor).
-elimtype False; now apply H2.
-now apply (Rtimes_pos_pos sor).
-apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
-destruct o'.
-rewrite H4, (Rtimes_0_r sor); le_equal.
-elimtype False; now apply H2.
-apply (Rtimes_nonneg_nonneg sor); [assumption | le_less].
-now apply (Rtimes_nonneg_nonneg sor).
-Qed.
-
-Lemma OpAdd_sound :
-  forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual ->
-    eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e').
-Proof.
-unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4.
-destruct o'.
-now rewrite H3, H4, (Rplus_0_l sor).
-elimtype False; now apply H2.
-now rewrite H3, (Rplus_0_l sor).
-now rewrite H3, (Rplus_0_l sor).
-elimtype False; now apply H1.
-destruct o'.
-now rewrite H4, (Rplus_0_r sor).
-elimtype False; now apply H2.
-now apply (Rplus_pos_pos sor).
-now apply (Rplus_pos_nonneg sor).
-destruct o'.
-now rewrite H4, (Rplus_0_r sor).
-elimtype False; now apply H2.
-now apply (Rplus_nonneg_pos sor).
-now apply (Rplus_nonneg_nonneg sor).
-Qed.
-
-(* We consider a monoid whose generators are polynomials from the
-hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that
-every element of the monoid (i.e., arbitrary product of generators) is ~=
-0. Therefore, the square of every element is > 0. *)
-
-Inductive Monoid (l : list NFormula) : PExprC -> Prop :=
-| M_One : Monoid l (PEc cI)
-| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p
-| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2).
-
-(* Do we really need to rely on the intermediate definition of monoid ?
-   InC why the restriction NonEqual ?
-   Could not we consider the IsIdeal as a IsMult ?
-   The same for IsSquare ?
-*)
-
-Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop :=
-| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op
-| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal
-| IsSquare : forall p, Cone l (PEmul p p) NonStrict
-| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict
-| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq)
-| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq)
-| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict
-| IsZ : Cone l (PEc cO) Equal.
-
-(* As promised, if all hypotheses are true in some environment, then every
-member of the monoid is nonzero in this environment *)
-
-Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv),
-  (forall f : NFormula, In f l -> eval_nformula env f) ->
-    forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0.
-Proof.
-intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl.
-rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor).
-apply H1 in H. now simpl in H.
-simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split.
-Qed.
-
-(* If all members of a cone base are true in some environment, then every
-member of the cone is true as well *)
-
-Lemma cone_true :
-  forall (l : list NFormula) (env : PolEnv),
-    (forall (f : NFormula), In f l -> eval_nformula env f) ->
-      forall (p : PExprC) (op : Op1), Cone l p op ->
-        op <> NonEqual /\ eval_nformula env (p, op).
-Proof.
-intros l env H1 p op H2. induction H2; simpl in *.
-split. assumption. apply H1 in H. now unfold eval_nformula in H.
-split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor).
-split. discriminate. apply (Rtimes_square_nonneg sor).
-split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor).
-apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l.
-destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
-split. now apply OpMultNonEqual. now apply OpMult_sound.
-destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
-split. now apply OpAdd_NonEqual. now apply OpAdd_sound.
-split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
-split. discriminate. apply addon.(SORrm).(morph0).
-Qed.
-
-(* Every element of a monoid is a product of some generators; therefore,
-to determine an element we can give a list of generators' indices *)
-
-Definition MonoidMember : Set := list nat.
-
-Inductive ConeMember : Type :=
-| S_In : nat -> ConeMember
-| S_Ideal : PExprC -> ConeMember -> ConeMember
-| S_Square : PExprC -> ConeMember
-| S_Monoid : MonoidMember -> ConeMember
-| S_Mult : ConeMember -> ConeMember -> ConeMember
-| S_Add : ConeMember -> ConeMember -> ConeMember
-| S_Pos : C -> ConeMember 
-| S_Z : ConeMember.
-
-Definition nformula_times (f f' : NFormula) : NFormula :=
-let (p, op) := f in
-  let (p', op') := f' in
-    (PEmul p p', OpMult op op').
-
-Definition nformula_plus (f f' : NFormula) : NFormula :=
-let (p, op) := f in
-  let (p', op') := f' in
-    (PEadd p p', OpAdd op op').
-
-Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula :=
-let (q, op) := f in
-  match op with
-  | Equal => (PEmul q p, Equal)
-  | _ => f
-  end.
-
-Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC :=
-match ns with
-| nil => PEc cI
-| n :: ns =>
-  let p := match nth n l (PEc cI, NonEqual) with
-           | (q, NonEqual) => q
-           | _ => PEc cI
-           end in
-    PEmul p (eval_monoid l ns)
-end.
-
-Theorem eval_monoid_in_monoid :
-  forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns).
-Proof.
-intro l; induction ns; simpl in *.
-constructor.
-apply M_Mult; [| assumption].
-destruct (nth_in_or_default a l (PEc cI, NonEqual)).
-destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption.
-rewrite e; simpl. constructor.
-Qed.
-
-(* Provides the cone member from the witness, i.e., ConeMember *)
-Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula :=
-match cm with
-| S_In n => match nth n l (PEc cO, Equal) with
-            | (_, NonEqual) => (PEc cO, Equal)
-            | f => f
-            end
-| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm')
-| S_Square p => (PEmul p p, NonStrict)
-| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict)
-| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q)
-| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q)
-| S_Pos c  => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal)
-| S_Z => (PEc cO, Equal)
-end.
-
-Theorem eval_cone_in_cone :
-  forall (l : list NFormula) (cm : ConeMember),
-    let (p, op) := eval_cone l cm in Cone l p op.
-Proof.
-intros l cm; induction cm; simpl.
-destruct (nth_in_or_default n l (PEc cO, Equal)).
-destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ.
-rewrite e. apply IsZ.
-destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal.
-apply IsSquare.
-apply IsMonoid. apply eval_monoid_in_monoid.
-destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult.
-destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd.
-case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ].
-apply IsZ.
-Qed.
-
-(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op
-(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact
-implies that l is inconsistent, as shown by the next lemma. Inconsistency
-of a formula (p, op) can be established by normalizing p and showing that
-it is a constant c for which (c, op) is false. (This is only a sufficient,
-not necessary, condition, of course.) Membership in the cone can be
-verified if we have a certificate. *)
-
-Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) :=
-  exists op : Op1, Cone l p op /\
-    forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p).
-
-(* If some element of a cone is inconsistent, then the base of the cone
-is also inconsistent *)
-
-Lemma prove_inconsistent :
-  forall (l : list NFormula) (p : PExprC),
-    inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False.
-Proof.
-intros l p H env.
-destruct H as [o [wit H]].
-apply -> make_conj_impl.
-intro H1. apply H with env.
-pose proof (@cone_true l env) as H2.
-cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3.
-apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in.
-Qed.
-
-Definition normalise_pexpr : PExprC -> PolC :=
-  norm_aux cO cI cplus ctimes cminus copp ceqb.
-
-(* The following definition we don't really need, hence it is commented *)
-(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*)
-
-(* roughly speaking, normalise_pexpr_correct is a proof of
-  forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
-
-(*****)
-Definition normalise_pexpr_correct :=
-let Rops_wd := mk_reqe rplus rtimes ropp req
-                       sor.(SORplus_wd)
-                       sor.(SORtimes_wd)
-                       sor.(SORopp_wd) in
-  norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
-                addon.(SORrm) addon.(SORpower).
-(*****)
-(*Definition normalise_pexpr_correct :=
-let Rops_wd := mk_reqe rplus rtimes ropp req
-                       sor.(SORplus_wd)
-                       sor.(SORtimes_wd)
-                       sor.(SORopp_wd) in
-  norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt))
-                addon.(SORrm) addon.(SORpower) nil.*)
-(*****)
-
-(* Check that a formula f is inconsistent by normalizing and comparing the
-resulting constant with 0 *)
-
-Definition check_inconsistent (f : NFormula) : bool :=
-let (e, op) := f in
-  match normalise_pexpr e with
-  | Pc c =>
-    match op with
-    | Equal => cneqb c cO
-    | NonStrict => c [<] cO
-    | Strict => c [<=] cO
-    | NonEqual => false (* eval_cone never returns (p, NonEqual) *)
-    end
-  | _ => false (* not a constant *)
-  end.
-
-Lemma check_inconsistent_sound :
-  forall (p : PExprC) (op : Op1),
-    check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p).
-Proof.
-intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1.
-destruct op; simpl;
-(*****)
-rewrite eval_pexpr_PEeval;
-(*****)
-(*unfold eval_pexpr;*)
-(*****)
-rewrite normalise_pexpr_correct;
-destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1;
-try rewrite <- addon.(SORrm).(morph0); trivial.
-now apply cneqb_sound.
-apply cleb_sound in H1. now apply -> (Rle_ngt sor).
-apply cltb_sound in H1. now apply -> (Rlt_nge sor).
-Qed.
-
-Definition check_normalised_formulas : list NFormula -> ConeMember -> bool :=
-  fun l cm => check_inconsistent (eval_cone l cm).
-
-Lemma checker_nf_sound :
-  forall (l : list NFormula) (cm : ConeMember),
-    check_normalised_formulas l cm = true ->
-      forall env : PolEnv, make_impl (eval_nformula env) l False.
-Proof.
-intros l cm H env.
-unfold check_normalised_formulas in H.
-case_eq (eval_cone l cm). intros p op H1.
-apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split.
-pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2.
-apply check_inconsistent_sound. now rewrite <- H1.
-Qed.
-
-(** Normalisation of formulae **)
-
-Inductive Op2 : Set := (* binary relations *)
-| OpEq
-| OpNEq
-| OpLe
-| OpGe
-| OpLt
-| OpGt.
-
-Definition eval_op2 (o : Op2) : R -> R -> Prop :=
-match o with
-| OpEq => req
-| OpNEq => fun x y : R => x ~= y
-| OpLe => rle
-| OpGe => fun x y : R => y <= x
-| OpLt => fun x y : R => x < y
-| OpGt => fun x y : R => y < x
-end.
-
-Record Formula : Type := {
-  Flhs : PExprC;
-  Fop : Op2;
-  Frhs : PExprC
-}.
-
-Definition eval_formula (env : PolEnv) (f : Formula) : Prop :=
-  let (lhs, op, rhs) := f in
-    (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).
-
-(* We normalize Formulas by moving terms to one side *)
-
-Definition normalise (f : Formula) : NFormula :=
-let (lhs, op, rhs) := f in
-  match op with
-  | OpEq => (PEsub lhs rhs, Equal)
-  | OpNEq => (PEsub lhs rhs, NonEqual)
-  | OpLe => (PEsub rhs lhs, NonStrict)
-  | OpGe => (PEsub lhs rhs, NonStrict)
-  | OpGt => (PEsub lhs rhs, Strict)
-  | OpLt => (PEsub rhs lhs, Strict)
-  end.
-
-Definition negate (f : Formula) : NFormula :=
-let (lhs, op, rhs) := f in
-  match op with
-  | OpEq => (PEsub rhs lhs, NonEqual)
-  | OpNEq => (PEsub rhs lhs, Equal)
-  | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
-  | OpGe => (PEsub rhs lhs, Strict)
-  | OpGt => (PEsub rhs lhs, NonStrict)
-  | OpLt => (PEsub lhs rhs, NonStrict)
-end.
-
-Theorem normalise_sound :
-  forall (env : PolEnv) (f : Formula),
-    eval_formula env f -> eval_nformula env (normalise f).
-Proof.
-intros env f H; destruct f as [lhs op rhs]; simpl in *.
-destruct op; simpl in *.
-now apply <- (Rminus_eq_0 sor).
-intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
-now apply -> (Rle_le_minus sor).
-now apply -> (Rle_le_minus sor).
-now apply -> (Rlt_lt_minus sor).
-now apply -> (Rlt_lt_minus sor).
-Qed.
-
-Theorem negate_correct :
-  forall (env : PolEnv) (f : Formula),
-    eval_formula env f <-> ~ (eval_nformula env (negate f)).
-Proof.
-intros env f; destruct f as [lhs op rhs]; simpl.
-destruct op; simpl.
-symmetry. rewrite (Rminus_eq_0 sor).
-split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
-rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
-rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
-rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
-rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
-rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
-Qed.
-
-(** Another normalistion - this is used for cnf conversion **)
-
-Definition xnormalise (t:Formula) : list (NFormula)  :=
-  let (lhs,o,rhs) := t in
-    match o with
-      | OpEq => 
-        (PEsub lhs  rhs, Strict)::(PEsub rhs lhs , Strict)::nil
-      | OpNEq => (PEsub lhs rhs,Equal) :: nil
-      | OpGt   => (PEsub rhs lhs,NonStrict) :: nil
-      | OpLt => (PEsub lhs rhs,NonStrict) :: nil
-      | OpGe => (PEsub rhs lhs , Strict) :: nil
-      | OpLe => (PEsub lhs rhs ,Strict) :: nil
-    end.
-
-Require Import Tauto.
-
-Definition cnf_normalise (t:Formula) : cnf (NFormula) :=
-  List.map  (fun x => x::nil) (xnormalise t).
-
-
-Add Ring SORRing : sor.(SORrt).
-
-Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t.
-Proof.
-  unfold cnf_normalise, xnormalise ; simpl ; intros env t.
-  unfold eval_cnf.
-  destruct t as [lhs o rhs]; case_eq o ; simpl;    
-    generalize (eval_pexpr  env lhs);
-      generalize (eval_pexpr  env rhs) ; intros z1 z2 ; intros.
-  (**)
-  apply sor.(SORle_antisymm).
-  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
-  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
-  now rewrite <- (Rminus_eq_0 sor).
-  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
-  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
-  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
-  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
-Qed.
-
-Definition xnegate (t:Formula) : list (NFormula)  :=
-  let (lhs,o,rhs) := t in
-    match o with
-      | OpEq  => (PEsub lhs rhs,Equal) :: nil
-      | OpNEq => (PEsub lhs  rhs ,Strict)::(PEsub rhs lhs,Strict)::nil
-      | OpGt  => (PEsub lhs  rhs,Strict) :: nil
-      | OpLt  => (PEsub rhs lhs,Strict) :: nil
-      | OpGe  => (PEsub lhs rhs,NonStrict) :: nil
-      | OpLe  => (PEsub rhs lhs,NonStrict) :: nil
-    end.
-
-Definition cnf_negate (t:Formula) : cnf (NFormula) :=
-  List.map  (fun x => x::nil) (xnegate t).
-
-Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t.
-Proof.
-  unfold cnf_negate, xnegate ; simpl ; intros env t.
-  unfold eval_cnf.
-  destruct t as [lhs o rhs]; case_eq o ; simpl ;
-    generalize (eval_pexpr env lhs);
-    generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; 
-    intuition.
-  (**)
-  apply H0.
-  rewrite H1 ; ring.
-  (**)
-  apply H1.
-  apply sor.(SORle_antisymm).
-  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
-  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
-  (**)
-  apply H0. now rewrite  (Rle_le_minus sor) in H1.
-  apply H0. now rewrite (Rle_le_minus sor) in H1.
-  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
-  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
-Qed.
-
-
-Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
-Proof.
-  intros.
-  destruct d ; simpl.
-  generalize (eval_pexpr env p); intros.
-  destruct o ; simpl. 
-  apply (Req_em sor r 0).
-  destruct (Req_em sor r 0) ; tauto.
-  rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
-  rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
-Qed.
-
-(** Some syntactic simplifications of expressions and cone elements *)
-
-
-Fixpoint simpl_expr (e:PExprC) : PExprC :=
-  match e with
-    | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in
-      match y' , z' with
-        | PEc c , z' => if ceqb c cI then z' else PEmul y' z'
-        |     _     , _   => PEmul y' z'
-      end
-    | PEadd x  y => PEadd (simpl_expr x) (simpl_expr y)
-    |   _    => e
-  end.
-
-
-Definition simpl_cone (e:ConeMember) : ConeMember :=
-  match e with
-    | S_Square t => match simpl_expr t with
-                      | PEc c   => if ceqb cO c then S_Z else S_Pos (ctimes c c)
-                      |       x     => S_Square x
-                    end
-    | S_Mult t1 t2 => 
-      match t1 , t2 with
-        | S_Z      , x        => S_Z 
-        |    x     , S_Z      => S_Z 
-        | S_Pos c ,  S_Pos c' => S_Pos (ctimes c c')
-        | S_Pos p1 , S_Mult (S_Pos p2)  x => S_Mult (S_Pos (ctimes p1 p2)) x
-        | S_Pos p1 , S_Mult x (S_Pos p2)  => S_Mult (S_Pos (ctimes p1 p2)) x
-        | S_Mult (S_Pos p2)  x  , S_Pos p1   => S_Mult (S_Pos (ctimes p1 p2)) x
-        | S_Mult x (S_Pos p2)   , S_Pos p1   => S_Mult (S_Pos (ctimes p1 p2)) x
-        | S_Pos x   , S_Add y z   => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z)
-        | S_Pos c ,  _        => if ceqb cI c then t2 else S_Mult t1 t2
-        | _ ,  S_Pos c        => if ceqb cI c then t1 else S_Mult t1 t2
-        |     _     , _   => e
-      end
-    | S_Add t1 t2 => 
-      match t1 ,  t2 with
-        | S_Z     , x => x
-        |   x     , S_Z => x
-        |   x     , y   => S_Add x y
-      end
-    |   _     => e
-  end.
-
-
-
-End Micromega.
-
diff --git a/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v
deleted file mode 100644
index 0855925a..00000000
--- a/contrib/micromega/ZMicromega.v
+++ /dev/null
@@ -1,705 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                                                                      *)
-(* Micromega: A reflexive tactic using the Positivstellensatz           *)
-(*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
-(*                                                                      *)
-(************************************************************************)
-
-Require Import OrderedRing.
-Require Import RingMicromega.
-Require Import ZCoeff.
-Require Import Refl.
-Require Import ZArith.
-Require Import List.
-Require Import Bool.
-
-Ltac flatten_bool :=
-  repeat match goal with
-           [ id : (_ && _)%bool = true |- _ ] =>  destruct (andb_prop _ _ id); clear id
-           |  [ id : (_ || _)%bool = true |- _ ] =>  destruct (orb_prop _ _ id); clear id
-         end.
-
-Require Import EnvRing.
-
-Open Scope Z_scope.
-  
-Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
-Proof.
-  constructor ; intros ; subst ; try (intuition (auto  with zarith)).
-  apply Zsth.
-  apply Zth.
-  destruct (Ztrichotomy n m) ; intuition (auto with zarith).
-  apply Zmult_lt_0_compat ; auto.
-Qed.
-
-Lemma ZSORaddon :
-  SORaddon 0 1 Zplus Zmult Zminus Zopp  (@eq Z) Zle (* ring elements *)
-  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
-  Zeq_bool Zle_bool
-  (fun x => x) (fun x => x) (pow_N 1 Zmult).
-Proof.
-  constructor.
-  constructor ; intros ; try reflexivity.
-  apply Zeq_bool_eq ; auto.
-  constructor.
-  reflexivity.
-  intros x y.
-  apply Zeq_bool_neq ; auto.
-  apply Zle_bool_imp_le.
-Qed.
-
-
-(*Definition Zeval_expr :=  eval_pexpr 0 Zplus Zmult Zminus Zopp  (fun x => x) (fun x => Z_of_N x) (Zpower).*)
-
-Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z :=
-  match e with
-    | PEc c =>  c
-    | PEX j =>  env j
-    | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
-    | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
-    | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
-    | PEopp pe1 => - (Zeval_expr env pe1)
-    | PEpow pe1 n => Zpower (Zeval_expr env pe1)  (Z_of_N n)
-  end.
-
-Lemma Zeval_expr_simpl : forall env e,
-  Zeval_expr env e = 
-  match e with
-    | PEc c =>  c
-    | PEX j =>  env j
-    | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
-    | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
-    | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
-    | PEopp pe1 => - (Zeval_expr env pe1)
-    | PEpow pe1 n => Zpower (Zeval_expr env pe1)  (Z_of_N n)
-  end.
-Proof.
-  destruct e ; reflexivity.
-Qed.
-
-
-Definition Zeval_expr' := eval_pexpr  Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
-
-Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
-Proof.
-  destruct n.
-  reflexivity.
-  simpl.
-  unfold Zpower_pos.
-  replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
-  generalize 1.
-  induction p; simpl ; intros ; repeat rewrite IHp ; ring.
-Qed.
-
-
-
-Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = Zeval_expr' env e.
-Proof.
-  induction e ; simpl ; subst ; try congruence.
-  rewrite IHe.
-  apply ZNpower.
-Qed.
-
-Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
-match o with
-| OpEq =>  @eq Z
-| OpNEq => fun x y  => ~ x = y
-| OpLe => Zle
-| OpGe => Zge
-| OpLt => Zlt
-| OpGt => Zgt
-end.
-
-Definition Zeval_formula (e: PolEnv Z) (ff : Formula Z) :=
-  let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e rhs).
-
-Definition Zeval_formula' :=
-  eval_formula  Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
-
-Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
-Proof.
-  intros.
-  unfold Zeval_formula.
-  destruct f.
-  repeat rewrite Zeval_expr_compat.
-  unfold Zeval_formula'.
-  unfold Zeval_expr'.
-  split ; destruct Fop ; simpl; auto with zarith.
-Qed.
-
-
-
-Definition Zeval_nformula :=
-  eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
-
-Definition Zeval_op1 (o : Op1) : Z -> Prop :=
-match o with
-| Equal => fun x : Z => x = 0
-| NonEqual => fun x : Z => x <> 0
-| Strict => fun x : Z => 0 < x
-| NonStrict => fun x : Z => 0 <= x
-end.
-
-Lemma Zeval_nformula_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)).
-Proof.
-  intros.
-  destruct f.
-  rewrite Zeval_expr_compat.
-  reflexivity.
-Qed.
-  
-Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d).
-Proof.
-  exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d).
-Qed.
-
-Definition ZWitness := ConeMember Z.
-
-Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
-
-Lemma ZWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : ZWitness),
-  ZWeakChecker l cm = true ->
-  forall env, make_impl (Zeval_nformula env) l False.
-Proof.
-  intros l cm H.
-  intro.
-  unfold Zeval_nformula.
-  apply (checker_nf_sound Zsor ZSORaddon l cm).
-  unfold ZWeakChecker in H.
-  exact H.
-Qed.
-
-Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
-  let (lhs,o,rhs) := t in
-    match o with
-      | OpEq => 
-        ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
-      | OpNEq => (PEsub lhs rhs,Equal) :: nil
-      | OpGt   => (PEsub rhs lhs,NonStrict) :: nil
-      | OpLt => (PEsub lhs rhs,NonStrict) :: nil
-      | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
-      | OpLe => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
-    end.
-
-Require Import Tauto.
-
-Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
-  List.map  (fun x => x::nil) (xnormalise t).
-
-
-Lemma normalise_correct : forall env t, eval_cnf (Zeval_nformula env) (normalise t) <-> Zeval_formula env t.
-Proof.
-  unfold normalise, xnormalise ; simpl ; intros env t.
-  rewrite Zeval_formula_compat.
-  unfold eval_cnf.
-  destruct t as [lhs o rhs]; case_eq o ; simpl;
-    generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
-      (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
-    generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
-      (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
-    intuition (auto with zarith).
-Qed.
-  
-Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
-  let (lhs,o,rhs) := t in
-    match o with
-      | OpEq  => (PEsub lhs rhs,Equal) :: nil
-      | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
-      | OpGt  => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
-      | OpLt  => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
-      | OpGe  => (PEsub lhs rhs,NonStrict) :: nil
-      | OpLe  => (PEsub rhs lhs,NonStrict) :: nil
-    end.
-
-Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) :=
-  List.map  (fun x => x::nil) (xnegate t).
-
-Lemma negate_correct : forall env t, eval_cnf (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t.
-Proof.
-  unfold negate, xnegate ; simpl ; intros env t.
-  rewrite Zeval_formula_compat.
-  unfold eval_cnf.
-  destruct t as [lhs o rhs]; case_eq o ; simpl ;
-    generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
-      (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
-    generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
-      (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; 
-    intuition (auto with zarith).
-Qed.
-
-
-Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
-  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZWitness ZWeakChecker f w.
-
-(* To get a complete checker, the proof format has to be enriched *)
-
-Require Import Zdiv.
-Open Scope Z_scope.
-
-Definition ceiling (a b:Z) : Z :=
-  let (q,r) := Zdiv_eucl a b in
-    match r with
-      | Z0 => q
-      | _  => q + 1
-    end.
-
-Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x  >= b -> x >= ceiling b a.
-Proof.
-  unfold ceiling.
-  intros.
-  generalize (Z_div_mod b a H).
-  destruct (Zdiv_eucl b a).
-  intros.
-  destruct H1.
-  destruct H2.
-  subst.
-  destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
-  assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
-  destruct HH ;auto.
-  generalize (Zmult_lt_compat_l _ _ _ H3 H1).
-  auto with zarith.
-  clear H2.
-  assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
-  destruct HH ;auto.
-  assert (0 < a) by auto with zarith.
-  generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
-  intros.
-  rewrite Zmult_comm  in H4.
-  rewrite (Zmult_comm z)  in H4.
-  auto with zarith.
-Qed.
-
-Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x  <= b -> x <= Zdiv b a.
-Proof.
-  unfold Zdiv.
-  intros.
-  generalize (Z_div_mod b a H).
-  destruct (Zdiv_eucl b a).
-  intros.
-  destruct H1.
-  destruct H2.
-  subst.
-  assert (HH :x <= z \/ z <= x -1) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
-  destruct HH ;auto.
-  assert (0 < a) by auto with zarith.
-  generalize (Zmult_lt_0_le_compat_r _ _ _ H4 H1).
-  intros.
-  ring_simplify in H5.
-  rewrite Zmult_comm in H5.
-  auto with zarith.
-Qed.
-
-
-(* In this case, a certificate is made of a pair of inequations, in 1 variable,
-   that do not have an integer solution.
-   => modify the fourier elimination
-   *)
-Require Import QArith.
-
-
-Inductive ProofTerm : Type :=
-| RatProof : ZWitness -> ProofTerm
-| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm
-| EnumProof : Q ->  PExprC Z ->  Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm.
-
-(* n/d <= x  -> d*x - n >= 0 *)
-
-Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
-  let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc  n),NonStrict).
-
-(* x <= n/d  -> d * x <= d  *)
-Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
-  let (n,d) := q in
-    (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).
-
-Definition qceiling (q:Q) : Z :=
-  let (n,d) := q in ceiling n (Zpos d).
-
-Definition qfloor (q:Q) : Z :=
-  let (n,d) := q in Zdiv n (Zpos d).
-
-Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z :=
-  (PEsub v  (PEc (qceiling  q)), NonStrict).
-
-Definition neg_nformula (f : NFormula Z) :=
-  let (e,o) := f in
-    (PEopp (PEadd e (PEc 1%Z)), o).
-    
-Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f).
-Proof.
-  unfold neg_nformula.
-  destruct f. 
-  simpl.
-  intros ; subst ; simpl in *.
-  split;  auto with zarith.
-Qed.
- 
-
-Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) :=
-    let (lb,lc) :=  (makeLb e lb,makeLbCut e lb) in
-      if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None.
-
-
-Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm)  {struct pf} : bool :=
-  match pf with
-    | RatProof pf => ZWeakChecker l pf
-    | CutProof e q pf rst => 
-      match cutChecker l e q pf with
-        | None => false
-        | Some c => ZChecker  (c::l) rst
-      end
-    | EnumProof lb e ub  pf1 pf2 rst => 
-      match cutChecker l e lb  pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
-        | None ,  _  | _ , None => false
-        | Some _  , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
-          (fix label (pfs:list ProofTerm) :=
-            fun lb ub => 
-              match pfs with
-                | nil => if Z_gt_dec lb ub then true else false
-                | pf::rsr => andb (ZChecker  ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) 
-              end)
-               rst lb' ub'
-      end
-  end.
-
-
-Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)),
-  ZChecker  l pf = 
-  match pf with
-    | RatProof pf => ZWeakChecker l pf
-    | CutProof e q pf rst => 
-      match cutChecker l e q pf with
-        | None => false
-        | Some c => ZChecker  (c::l) rst
-      end
-    | EnumProof lb e ub  pf1 pf2 rst => 
-      match cutChecker l e lb  pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
-        | None ,  _  | _ , None => false
-        | Some _  , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
-          (fix label (pfs:list ProofTerm) :=
-            fun lb ub => 
-              match pfs with
-                | nil => if Z_gt_dec lb ub then true else false
-                | pf::rsr => andb (ZChecker  ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) 
-              end)
-               rst lb' ub'
-      end
-  end.
-Proof.
-  destruct pf ; reflexivity.
-Qed.
-
-(*
-Fixpoint depth (n:nat) : ProofTerm -> option nat :=
-  match n with
-    | O => fun pf => None
-    | S n => 
-      fun pf => 
-        match pf with
-          | RatProof _ => Some O
-          | CutProof _ _ _ p =>  option_map S  (depth n p)
-          | EnumProof  _ _ _ _ _ l => 
-            let f := fun pf x => 
-              match x , depth n pf with
-                | None ,  _ | _ , None => None
-                | Some n1 , Some n2 => Some (Max.max n1 n2)
-              end in
-            List.fold_right f  (Some O) l
-        end
-  end.
-*)
-Fixpoint bdepth (pf : ProofTerm) : nat :=
-  match pf with
-    | RatProof _ =>  O
-    | CutProof _ _ _ p =>   S  (bdepth p)
-    | EnumProof _ _ _ _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x)   O l)
-  end.
-
-Require Import Wf_nat.
-
-Lemma in_bdepth : forall l a b p c c0  y, In y l ->  ltof ProofTerm bdepth y (EnumProof a b p c c0 l).
-Proof.
-  induction l.
-  simpl.
-  tauto.
-  simpl.
-  intros.
-  destruct H.
-  subst.
-  unfold ltof.
-  simpl.
-  generalize (         (fold_right
-            (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
-  intros.
-  generalize (bdepth y) ; intros.
-  generalize (Max.max_l n0 n) (Max.max_r n0 n).
-  omega.
-  generalize (IHl a0 b p c c0 y  H).
-  unfold ltof.
-  simpl.
-  generalize (      (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat
-         l)).
-  intros.
-  generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
-  omega.
-Qed.
-
-Lemma lb_lbcut : forall env e q,  Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q).
-Proof.
-  unfold makeLb, makeLbCut.
-  destruct q.
-  rewrite Zeval_nformula_simpl.
-  rewrite Zeval_nformula_simpl.
-  unfold Zeval_op1.
-  rewrite Zeval_expr_simpl.
-  rewrite Zeval_expr_simpl.
-  rewrite Zeval_expr_simpl.
-  intro.
-  rewrite Zeval_expr_simpl.
-  revert H.
-  generalize (Zeval_expr env e).
-  rewrite Zeval_expr_simpl.
-  rewrite Zeval_expr_simpl.
-  unfold qceiling.
-  intros.
-  assert ( z >= ceiling Qnum (' Qden))%Z.
-  apply narrow_interval_lower_bound.
-  compute.
-  reflexivity.
-  destruct z ; auto with zarith.
-  auto with zarith.
-Qed.
-
-Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res -> 
-  forall env, make_impl  (Zeval_nformula env) l (Zeval_nformula env res).
-Proof.
-  unfold cutChecker.
-  intros.
-  revert H.
-  case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate].
-  generalize (ZWeakChecker_sound _ _  H env).
-  intros.
-  inversion H0 ; subst ; clear H0.
-  apply -> make_conj_impl.
-  simpl in H1.
-  rewrite <- make_conj_impl in H1.
-  intros.
-  apply -> neg_nformula_sound ; auto.
-  red ; intros.
-  apply H1 ; auto.
-  clear H H1 H0.
-  generalize (lb_lbcut env e lb).
-  intros.
-  destruct (Zeval_nformula_dec  env ((neg_nformula (makeLb e lb)))).
-  auto.
-  rewrite -> neg_nformula_sound in H0.
-  assert (HH := H H0).
-  rewrite <- neg_nformula_sound in HH.
-  tauto.
-  reflexivity.
-  unfold makeLb.
-  destruct lb.
-  reflexivity.
-Qed.
-
-
-Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res -> 
-  forall env,  make_conj  (Zeval_nformula env) l  -> (Zeval_expr env e >= qceiling lb)%Z.
-Proof.
-  intros.
-  generalize (cutChecker_sound _ _ _ _ _ H env).
-  intros.
-  rewrite  <- (make_conj_impl) in H1. 
-  generalize (H1 H0).
-  unfold cutChecker in H.
-  destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf).
-  unfold makeLbCut in H.
-  inversion H ; subst.
-  clear H.
-  simpl.
-  rewrite Zeval_expr_compat.
-  unfold Zeval_expr'.
-  auto with zarith.
-  discriminate.
-Qed.
-
-
-Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl  (Zeval_nformula env)  l False.
-Proof.
-  induction w    using (well_founded_ind (well_founded_ltof _ bdepth)).
-  destruct w.
-  (* RatProof *)
-  simpl.
-  intros.
-  eapply ZWeakChecker_sound.
-  apply H0.
-  (* CutProof *)
-  simpl.
-  intro.
-  case_eq (cutChecker l p q z) ; intros.
-  generalize (cutChecker_sound _ _ _ _ _ H0 env).
-  intro.
-  assert (make_impl  (Zeval_nformula env) (n::l) False).
-  eapply (H w) ; auto.
-  unfold ltof.
-  simpl.
-  auto with arith.
-  simpl in H3.
-  rewrite <- make_conj_impl in H2.
-  rewrite <- make_conj_impl in H3.
-  rewrite <- make_conj_impl.
-  tauto.
-  discriminate.
-  (* EnumProof *)
-  intro.
-  rewrite ZChecker_simpl.
-  case_eq (cutChecker l0 p q z).
-  rename q into llb.
-  case_eq (cutChecker l0 (PEopp p) (- q0) z0).
-  intros.
-  rename q0 into uub.
-  (* get the bounds of the enum *)
-  rewrite <- make_conj_impl.
-  intro.
-  assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z.
-  generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3).
-  generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3).
-  intros.
-  rewrite Zeval_expr_simpl in H5.
-  auto with zarith.
-  clear H0 H1.
-  revert H2 H3 H4.
-  generalize (qceiling llb) (- qceiling (- uub))%Z.
-  set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool :=
-    match pfs with
-      | nil => if Z_gt_dec lb ub then true else false
-      | pf :: rsr =>
-        (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf &&
-          label rsr (lb + 1)%Z ub)%bool
-    end)).
-  intros z1 z2.
-  intros.
-  assert (forall x, z1 <= x <= z2 -> exists pr, 
-    (In pr l /\
-      ZChecker  ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z.
-  clear H.
-  revert H2.
-  clear H4.
-  revert z1 z2.
-  induction l;simpl ;intros.
-  destruct (Z_gt_dec z1 z2).
-  intros.
-  apply False_ind ; omega.
-  discriminate.
-  intros.
-  simpl in H2.
-  flatten_bool.
-  assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
-  destruct HH.
-  subst.
-  exists a ; auto.
-  assert (z1 + 1 <= x <= z2)%Z by omega.
-  destruct (IHl _ _ H1 _ H4).
-  destruct H5.
-  exists x0 ; split;auto.
-  (*/asser *)
-  destruct (H0 _ H4) as [pr [Hin Hcheker]].
-  assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False).
-  apply (H pr);auto.
-  apply in_bdepth ; auto.
-  rewrite <- make_conj_impl in H1.
-  apply H1.
-  rewrite  make_conj_cons.
-  split ;auto.
-  rewrite Zeval_nformula_simpl;
-    unfold Zeval_op1;
-      rewrite Zeval_expr_simpl.
-  generalize (Zeval_expr env p).
-  intros.
-  rewrite Zeval_expr_simpl.
-  auto with zarith.
-  intros ; discriminate.
-  intros ; discriminate.
-Qed.
-
-Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ProofTerm): bool :=
-  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ProofTerm ZChecker f w.
-
-Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f  (Zeval_formula env)  f.
-Proof.
-  intros f w.
-  unfold ZTautoChecker.
-  apply (tauto_checker_sound  Zeval_formula Zeval_nformula).
-  apply Zeval_nformula_dec.
-  intros env t.
-  rewrite normalise_correct ; auto.
-  intros env t.
-  rewrite negate_correct ; auto.
-  intros t w0.
-  apply ZChecker_sound.
-Qed.
-
-
-Open Scope Z_scope.
-
-
-Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness :=
-  match e with
-    | S_In n         => S_In _ (f n)
-    | S_Ideal e cm   => S_Ideal e (map_cone f cm)
-    | S_Square _     => e
-    | S_Monoid l     => S_Monoid _ (List.map f l)
-    | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2)
-    | S_Add cm1 cm2  => S_Add (map_cone f cm1) (map_cone f cm2)
-    |  _             => e
-  end.
-
-Fixpoint indexes (e:ZWitness) : list nat :=
-  match e with
-    | S_In n         => n::nil
-    | S_Ideal e cm   => indexes cm
-    | S_Square e     => nil
-    | S_Monoid l     => l
-    | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2)
-    | S_Add cm1 cm2  => (indexes cm1)++ (indexes cm2)
-    |  _             => nil
-  end.
-  
-(** To ease bindings from ml code **)
-(*Definition varmap := Quote.varmap.*)
-Definition make_impl := Refl.make_impl.
-Definition make_conj := Refl.make_conj.
-
-Require VarMap.
-
-(*Definition varmap_type := VarMap.t Z. *)
-Definition env := PolEnv Z.
-Definition node := @VarMap.Node Z.
-Definition empty := @VarMap.Empty Z.
-Definition leaf := @VarMap.Leaf Z.
-
-Definition coneMember := ZWitness.
-
-Definition eval := Zeval_formula.
-
-Definition prod_pos_nat := prod positive nat.
-
-Require Import Int.
-
-
-Definition n_of_Z (z:Z) : BinNat.N :=
-  match z with
-    | Z0 => N0
-    | Zpos p => Npos p
-    | Zneg p => N0
-  end.
-
-
-
diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml
deleted file mode 100644
index b4863ffc..00000000
--- a/contrib/micromega/coq_micromega.ml
+++ /dev/null
@@ -1,1286 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                                                                      *)
-(* Micromega: A reflexive tactic using the Positivstellensatz           *)
-(*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
-(*                                                                      *)
-(************************************************************************)
-
-open Mutils
-let debug = false
-
-let time str f x = 
- let t0 = (Unix.times()).Unix.tms_utime in
- let res = f x in 
- let t1 = (Unix.times()).Unix.tms_utime in 
-  (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; 
-		     flush stdout); 
-  res
-
-type ('a,'b) formula =
-  | TT 
-  | FF 
-  | X of 'b 
-  | A of 'a * Names.name
-  | C of ('a,'b) formula * ('a,'b) formula * Names.name
-  | D of ('a,'b) formula * ('a,'b) formula * Names.name
-  | N of ('a,'b) formula * Names.name
-  | I of ('a,'b) formula * ('a,'b) formula * Names.name
-
-let none = Names.Anonymous
-
-let tag_formula t f = 
- match f with
-  | A(x,_) -> A(x,t)
-  | C(x,y,_) -> C(x,y,t)
-  | D(x,y,_) -> D(x,y,t)
-  | N(x,_) -> N(x,t)
-  | I(x,y,_) -> I(x,y,t)
-  |   _      -> f
-
-let tt = []
-let ff = [ [] ]
-
-
-type ('constant,'contr) sentence =  
-  ('constant Micromega.formula, 'contr) formula
-
-let cnf negate normalise f = 
- let negate a = 
-  CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in
-
- let normalise a = 
-  CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (normalise a) in
-
- let and_cnf x y = x @ y in
- let or_clause_cnf t f =  List.map (fun x -> t@x ) f in
-  
- let rec or_cnf f f'  =
-  match f with
-   | [] -> tt
-   | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
-  
- let rec xcnf  (pol : bool) f    =
-  match f with
-   | TT -> if pol then tt else ff (* ?? *)
-   | FF  -> if pol then ff else tt (* ?? *)
-   | X p -> if pol then ff else ff (* ?? *)
-   | A(x,t) -> if pol then normalise  x else negate x
-   | N(e,t)  -> xcnf  (not pol) e
-   | C(e1,e2,t) -> 
-      (if pol then and_cnf else or_cnf) (xcnf  pol e1) (xcnf  pol e2)
-   | D(e1,e2,t)  -> 
-      (if pol then or_cnf else and_cnf) (xcnf  pol e1) (xcnf  pol e2)
-   | I(e1,e2,t) -> 
-      (if pol then or_cnf else and_cnf) (xcnf  (not pol) e1) (xcnf  pol e2) in
-
-  xcnf  true f
-
-
-
-module M =
-struct
- open Coqlib
- open Term
-  (*    let constant = gen_constant_in_modules "Omicron" coq_modules*)
-  
-  
- let logic_dir = ["Coq";"Logic";"Decidable"]
- let coq_modules =
-  init_modules @ 
-   [logic_dir] @ arith_modules @ zarith_base_modules @ 
-   [ ["Coq";"Lists";"List"];
-     ["ZMicromega"];
-     ["Tauto"];
-     ["RingMicromega"];
-     ["EnvRing"];
-     ["Coq"; "micromega"; "ZMicromega"];
-     ["Coq" ; "micromega" ; "Tauto"];
-     ["Coq" ; "micromega" ; "RingMicromega"];
-     ["Coq" ; "micromega" ; "EnvRing"];
-     ["Coq";"QArith"; "QArith_base"];
-     ["Coq";"Reals" ; "Rdefinitions"];
-     ["Coq";"Reals" ; "Rpow_def"];
-     ["LRing_normalise"]]
-   
- let constant = gen_constant_in_modules "ZMicromega" coq_modules
-
- let coq_and = lazy (constant "and")
- let coq_or = lazy (constant "or")
- let coq_not = lazy (constant "not")
- let coq_iff = lazy (constant "iff")
- let coq_True = lazy (constant "True")
- let coq_False = lazy (constant "False")
-  
- let coq_cons = lazy (constant "cons")
- let coq_nil = lazy (constant "nil")
- let coq_list = lazy (constant "list")
-
- let coq_O = lazy (constant "O")
- let coq_S = lazy (constant "S")
- let coq_nat = lazy (constant "nat")
-
- let coq_NO = lazy 
-  (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]]  "N0")
- let coq_Npos = lazy 
-  (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]]  "Npos")
-  (* let coq_n = lazy (constant "N")*)
-
- let coq_pair = lazy (constant "pair")
- let coq_None = lazy (constant "None")
- let coq_option = lazy (constant "option")
- let coq_positive = lazy (constant "positive")
- let coq_xH = lazy (constant "xH")
- let coq_xO = lazy (constant "xO")
- let coq_xI = lazy (constant "xI")
-  
- let coq_N0 = lazy (constant "N0")
- let coq_N0 = lazy (constant "Npos")
-
-
- let coq_Z = lazy (constant "Z")
- let coq_Q = lazy (constant "Q")
- let coq_R = lazy (constant "R")
-
- let coq_ZERO = lazy (constant  "Z0")
- let coq_POS = lazy (constant  "Zpos")
- let coq_NEG = lazy (constant  "Zneg")
-
- let coq_QWitness = lazy 
-  (gen_constant_in_modules "QMicromega" 
-    [["Coq"; "micromega"; "QMicromega"]] "QWitness")
- let coq_ZWitness = lazy 
-  (gen_constant_in_modules "QMicromega" 
-    [["Coq"; "micromega"; "ZMicromega"]] "ZWitness")
-
-
- let coq_Build_Witness = lazy (constant "Build_Witness")
-
-
- let coq_Qmake = lazy (constant "Qmake")
- let coq_R0    = lazy (constant "R0")
- let coq_R1    = lazy (constant "R1")
-
-
- let coq_proofTerm = lazy (constant "ProofTerm")
- let coq_ratProof = lazy (constant "RatProof")
- let coq_cutProof = lazy (constant "CutProof")
- let coq_enumProof = lazy (constant "EnumProof")
-
- let coq_Zgt = lazy (constant "Zgt")
- let coq_Zge = lazy (constant "Zge")
- let coq_Zle = lazy (constant "Zle")
- let coq_Zlt = lazy (constant "Zlt")
- let coq_Eq  = lazy (constant "eq")
-
- let coq_Zplus = lazy (constant "Zplus")
- let coq_Zminus = lazy (constant "Zminus")
- let coq_Zopp = lazy (constant "Zopp")
- let coq_Zmult = lazy (constant "Zmult")
- let coq_Zpower = lazy (constant "Zpower")
- let coq_N_of_Z = lazy 
-  (gen_constant_in_modules "ZArithRing" 
-    [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
-
- let coq_Qgt = lazy (constant "Qgt")
- let coq_Qge = lazy (constant "Qge")
- let coq_Qle = lazy (constant "Qle")
- let coq_Qlt = lazy (constant "Qlt")
- let coq_Qeq = lazy (constant "Qeq")
-
-
- let coq_Qplus = lazy (constant "Qplus")
- let coq_Qminus = lazy (constant "Qminus")
- let coq_Qopp = lazy (constant "Qopp")
- let coq_Qmult = lazy (constant "Qmult")
- let coq_Qpower = lazy (constant "Qpower")
-
-
- let coq_Rgt = lazy (constant "Rgt")
- let coq_Rge = lazy (constant "Rge")
- let coq_Rle = lazy (constant "Rle")
- let coq_Rlt = lazy (constant "Rlt")
-
- let coq_Rplus = lazy (constant "Rplus")
- let coq_Rminus = lazy (constant "Rminus")
- let coq_Ropp = lazy (constant "Ropp")
- let coq_Rmult = lazy (constant "Rmult")
- let coq_Rpower = lazy (constant "pow")
-
-
- let coq_PEX = lazy (constant "PEX" )
- let coq_PEc = lazy (constant"PEc")
- let coq_PEadd = lazy (constant "PEadd")
- let coq_PEopp = lazy (constant "PEopp")
- let coq_PEmul = lazy (constant "PEmul")
- let coq_PEsub = lazy (constant "PEsub")
- let coq_PEpow = lazy (constant "PEpow")
-
-
- let coq_OpEq = lazy (constant "OpEq")
- let coq_OpNEq = lazy (constant "OpNEq")
- let coq_OpLe = lazy (constant "OpLe")
- let coq_OpLt = lazy (constant  "OpLt")
- let coq_OpGe = lazy (constant "OpGe")
- let coq_OpGt = lazy (constant  "OpGt")
-
-
- let coq_S_In = lazy (constant "S_In")
- let coq_S_Square = lazy (constant "S_Square")
- let coq_S_Monoid = lazy (constant "S_Monoid")
- let coq_S_Ideal = lazy (constant "S_Ideal")
- let coq_S_Mult = lazy (constant "S_Mult")
- let coq_S_Add  = lazy (constant "S_Add")
- let coq_S_Pos  = lazy (constant "S_Pos")
- let coq_S_Z    = lazy (constant "S_Z")
- let coq_coneMember    = lazy (constant "coneMember")
-  
-
- let coq_make_impl = lazy 
-  (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl")
- let coq_make_conj = lazy 
-  (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj")
-
- let coq_Build = lazy 
-  (gen_constant_in_modules "RingMicromega" 
-    [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] 
-    "Build_Formula")
- let coq_Cstr = lazy 
-  (gen_constant_in_modules "RingMicromega" 
-    [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
-
-
- type parse_error  = 
-   | Ukn 
-   | BadStr of string 
-   | BadNum of int 
-   | BadTerm of Term.constr 
-   | Msg   of string
-   | Goal of (Term.constr list ) * Term.constr * parse_error
-
- let string_of_error = function
-  | Ukn -> "ukn"
-  | BadStr s -> s
-  | BadNum i -> string_of_int i
-  | BadTerm _ -> "BadTerm"
-  | Msg  s    -> s
-  | Goal _    -> "Goal"
-
-
- exception ParseError 
-
-
-
-
- let get_left_construct term = 
-  match Term.kind_of_term term with
-   | Term.Construct(_,i) -> (i,[| |])
-   | Term.App(l,rst) -> 
-      (match Term.kind_of_term l with
-       | Term.Construct(_,i) -> (i,rst)
-       |   _     -> raise ParseError
-      )
-   | _ ->   raise ParseError
-      
- module Mc = Micromega
-      
- let rec parse_nat term = 
-  let (i,c) = get_left_construct term in
-   match i with
-    | 1 -> Mc.O
-    | 2 -> Mc.S (parse_nat (c.(0)))
-    | i -> raise ParseError
-       
-
- let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
-
-
- let rec dump_nat x = 
-  match x with
-   | Mc.O -> Lazy.force coq_O
-   | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |])
-
-
- let rec parse_positive term = 
-  let (i,c) = get_left_construct term in
-   match i with
-    | 1 -> Mc.XI (parse_positive c.(0))
-    | 2 -> Mc.XO (parse_positive c.(0))
-    | 3 -> Mc.XH
-    | i -> raise ParseError
-       
-
- let rec dump_positive x = 
-  match x with
-   | Mc.XH -> Lazy.force coq_xH
-   | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |])
-   | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |])
-
- let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)	  
-
-
- let rec dump_n x = 
-  match x with 
-   | Mc.N0 -> Lazy.force coq_N0
-   | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
-
- let rec dump_index x = 
-  match x with
-   | Mc.XH -> Lazy.force coq_xH
-   | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |])
-   | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |])
-
-
- let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)	  
-
- let rec dump_n x = 
-  match x with
-   | Mc.N0 -> Lazy.force coq_NO
-   | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |])
-
- let rec pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
-
- let dump_pair t1 t2 dump_t1 dump_t2 (Mc.Pair (x,y)) =
-  Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
-
-
- let rec parse_z term =
-  let (i,c) = get_left_construct term in
-   match i with
-    | 1 -> Mc.Z0
-    | 2 -> Mc.Zpos (parse_positive c.(0))
-    | 3 -> Mc.Zneg (parse_positive c.(0))
-    | i -> raise ParseError
-
- let dump_z x =
-  match x with
-   | Mc.Z0 ->Lazy.force coq_ZERO
-   | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) 
-   | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|])  
-
- let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x)
-
-let dump_num bd1 = 
- Term.mkApp(Lazy.force coq_Qmake,
-	   [|dump_z (CamlToCoq.bigint (numerator bd1)) ; 
-	     dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |])
-
-
-let dump_q q = 
- Term.mkApp(Lazy.force coq_Qmake, 
-	   [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|])
-
-let parse_q term =  
- match Term.kind_of_term term with
-  | Term.App(c, args) -> if c = Lazy.force coq_Qmake then
-	{Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
-      else raise ParseError
-  |  _ -> raise ParseError
-
-  
- let rec parse_list parse_elt term = 
-  let (i,c) = get_left_construct term in
-   match i with
-    | 1 -> Mc.Nil
-    | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2))
-    | i -> raise ParseError
-
-
- let rec dump_list typ dump_elt l =
-  match l with
-   | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |])
-   | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons, 
-			       [| typ; dump_elt e;dump_list typ dump_elt l|])
-      
- let rec dump_ml_list typ dump_elt l =
-  match l with
-   | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |])
-   | e::l -> Term.mkApp(Lazy.force coq_cons, 
-		       [| typ; dump_elt e;dump_ml_list typ dump_elt l|])
-
-
-
- let pp_list op cl elt o l = 
-  let rec _pp  o l = 
-   match l with
-    | Mc.Nil -> ()
-    | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e
-    | Mc.Cons(e,l) -> Printf.fprintf o "%a ,%a" elt e  _pp l in
-   Printf.fprintf o "%s%a%s" op _pp l cl 
-
-
-
- let pp_var  = pp_positive
- let dump_var = dump_positive
-
- let rec pp_expr o e = 
-  match e with
-   | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n
-   | Mc.PEc z -> pp_z o z
-   | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2
-   | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2
-   | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e
-   | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2
-   | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n  n
-
-
- let  dump_expr typ dump_z e =
-  let rec dump_expr  e =
-  match e with
-   | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |])
-   | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |])
-   | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd,
-			     [| typ; dump_expr e1;dump_expr e2|])
-   | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub,
-			     [| typ; dump_expr  e1;dump_expr  e2|])
-   | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp,
-			[| typ; dump_expr  e|])
-   | Mc.PEmul(e1,e2) ->  mkApp(Lazy.force coq_PEmul,
-			      [| typ; dump_expr  e1;dump_expr e2|])
-   | Mc.PEpow(e,n) ->  mkApp(Lazy.force coq_PEpow,
-			    [| typ; dump_expr  e; dump_n  n|])
-     in
-   dump_expr e
-
- let rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l
-
- let rec dump_cone typ dump_z e = 
-  let z = Lazy.force typ in 
- let rec dump_cone e =
-  match e with
-   | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |])
-   | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal, 
-			     [| z; dump_expr z dump_z e ; dump_cone c |])
-   | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square, 
-			   [| z;dump_expr z dump_z e|])
-   | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid, 
-			    [|z; dump_monoid l|])
-   | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add,
-			     [| z; dump_cone e1; dump_cone e2|])
-   | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult,
-			      [| z; dump_cone e1; dump_cone e2|])
-   | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|])
-   | Mc.S_Z    -> mkApp( Lazy.force coq_S_Z,[| z|]) in 
-  dump_cone e
-
-
- let  pp_cone pp_z o e = 
-  let rec pp_cone o e = 
-   match e with 
-    | Mc.S_In n -> 
-       Printf.fprintf o "(S_In %a)%%nat" pp_nat n
-    | Mc.S_Ideal(e,c) -> 
-       Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c
-    | Mc.S_Square e -> 
-       Printf.fprintf o "(S_Square %a)" pp_expr e
-    | Mc.S_Monoid l -> 
-       Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l
-    | Mc.S_Add(e1,e2) -> 
-       Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2
-    | Mc.S_Mult(e1,e2) -> 
-       Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2
-    | Mc.S_Pos p -> 
-       Printf.fprintf o "(S_Pos %a)%%positive" pp_z p
-    | Mc.S_Z    -> 
-       Printf.fprintf o "S_Z" in
-   pp_cone o e
-
-
- let rec dump_op = function
-  | Mc.OpEq-> Lazy.force coq_OpEq
-  | Mc.OpNEq-> Lazy.force coq_OpNEq
-  | Mc.OpLe -> Lazy.force coq_OpLe
-  | Mc.OpGe -> Lazy.force coq_OpGe
-  | Mc.OpGt-> Lazy.force coq_OpGt
-  | Mc.OpLt-> Lazy.force coq_OpLt
-
-
-
- let pp_op o e= 
-  match e with 
-   | Mc.OpEq-> Printf.fprintf o "="
-   | Mc.OpNEq-> Printf.fprintf o "<>"
-   | Mc.OpLe -> Printf.fprintf o "=<"
-   | Mc.OpGe -> Printf.fprintf o ">="
-   | Mc.OpGt-> Printf.fprintf o ">"
-   | Mc.OpLt-> Printf.fprintf o "<"
-
-
-
-
- let pp_cstr o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
-  Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr r
-
- let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
-   Term.mkApp(Lazy.force coq_Build,
-	     [| typ; dump_expr typ dump_constant e1 ; 
-		dump_op o ; 
-		dump_expr typ dump_constant e2|])
-
- let assoc_const x l = 
-  try 
-  snd (List.find (fun (x',y) -> x = Lazy.force x') l)
-  with
-    Not_found -> raise ParseError
-
- let zop_table = [ 
-  coq_Zgt, Mc.OpGt ; 
-  coq_Zge, Mc.OpGe ;
-  coq_Zlt, Mc.OpLt ;
-  coq_Zle, Mc.OpLe ]
-
- let rop_table = [ 
-  coq_Rgt, Mc.OpGt ; 
-  coq_Rge, Mc.OpGe ;
-  coq_Rlt, Mc.OpLt ;
-  coq_Rle, Mc.OpLe ]
-
- let qop_table = [ 
-  coq_Qlt, Mc.OpLt ;
-  coq_Qle, Mc.OpLe ;
-  coq_Qeq, Mc.OpEq
- ]
-
-
- let parse_zop (op,args) =
-  match kind_of_term op with
-   | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
-   |  Ind(n,0) -> 
-       if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_Z
-       then (Mc.OpEq, args.(1), args.(2))
-       else raise ParseError
-   |   _ -> failwith "parse_zop"
-
-
- let parse_rop (op,args) =
-   match kind_of_term op with
-    | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
-    |  Ind(n,0) -> 
-       if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_R
-       then (Mc.OpEq, args.(1), args.(2))
-       else raise ParseError
-   |   _ -> failwith "parse_zop"
-
- let parse_qop (op,args) =
-   (assoc_const op qop_table, args.(0) , args.(1))
-
-
- module Env =
- struct 
-  type t = constr list
-    
-  let compute_rank_add env v =
-   let rec _add env n v =
-    match env with
-     | [] -> ([v],n)
-     | e::l -> 
-	if eq_constr e v 
-	then (env,n)
-	else 
-	 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)
-
-     
-  let empty = []
-   
-  let elements env = env
-
- end
-
-
- let is_constant t = (* This is an approx *)
-  match kind_of_term t with
-   | Construct(i,_) -> true 
-   |   _ -> false
-
-
- type 'a op = 
-   | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) 
-   | Opp 
-   | Power 
-   | Ukn of string
-
-
- let assoc_ops x l = 
-  try 
-    snd (List.find (fun (x',y) -> x = Lazy.force x') l)
-  with
-    Not_found -> Ukn "Oups"
-
-
-
- let parse_expr parse_constant parse_exp ops_spec env term = 
- if debug 
- then (Pp.pp (Pp.str "parse_expr: ");   
-       Pp.pp_flush ();Pp.pp (Printer.prterm  term); Pp.pp_flush ());
-
-  let constant_or_variable env term = 
-   try 
-    ( Mc.PEc (parse_constant term) , env)
-   with ParseError -> 
-    let (env,n) = Env.compute_rank_add env term in
-     (Mc.PEX  n , env) in
-
-  let rec parse_expr env term = 
-   let combine env op (t1,t2) =
-    let (expr1,env) = parse_expr env t1 in
-    let (expr2,env) = parse_expr env t2 in
-    (op expr1 expr2,env) in
-    match kind_of_term term with
-     | App(t,args) -> 
-	(
-	 match kind_of_term t with
-	  | Const c -> 
-	     ( match assoc_ops t ops_spec  with
-	      | Binop f -> combine env f (args.(0),args.(1))
-	      | Opp     -> let (expr,env) = parse_expr env args.(0) in
-			    (Mc.PEopp expr, env)
-	      | Power   -> 
-		 let (expr,env) = parse_expr env args.(0) in
-		 let exp = (parse_exp args.(1)) in 
-		  (Mc.PEpow(expr, exp)  , env) 
-	      | Ukn  s -> 
-		 if debug 
-		 then (Printf.printf "unknown op: %s\n" s; flush stdout;);
-		 let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
-	     )
-	  |   _ -> constant_or_variable env term
-	)
-     | _ -> constant_or_variable env term in
-   parse_expr env term
-    
-
- let zop_spec = 
-   [ 
-     coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
-     coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
-     coq_Zmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ; 
-     coq_Zopp   , Opp ; 
-     coq_Zpower , Power]
-
-let qop_spec = 
-  [
-     coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
-     coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
-     coq_Qmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ; 
-     coq_Qopp   , Opp ; 
-     coq_Qpower , Power]
-
-let rop_spec = 
-  [
-     coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
-     coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
-     coq_Rmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ; 
-     coq_Ropp   , Opp ; 
-     coq_Rpower , Power]
-
-
-
-
-      
-let zconstant = parse_z
-let qconstant = parse_q
-
-
-let rconstant term = 
- if debug 
- then (Pp.pp_flush ();
-       Pp.pp (Pp.str "rconstant: ");
-       Pp.pp (Printer.prterm  term); Pp.pp_flush ());
- match Term.kind_of_term term with
-  | Const x ->  
-      if term = Lazy.force coq_R0
-      then Mc.Z0
-      else if term = Lazy.force coq_R1
-      then Mc.Zpos Mc.XH
-      else raise ParseError
-  |  _ -> raise ParseError
-
-
-let parse_zexpr = 
- parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x))  zop_spec 
-let parse_qexpr  = 
- parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec 
-let parse_rexpr = 
- parse_expr rconstant  (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec
-
-
- let  parse_arith parse_op parse_expr env cstr = 
-  if debug 
-  then (Pp.pp_flush ();
-	Pp.pp (Pp.str "parse_arith: ");
-	Pp.pp (Printer.prterm  cstr); 
-	Pp.pp_flush ());
-  match kind_of_term cstr with
-   | App(op,args) -> 
-      let (op,lhs,rhs) = parse_op (op,args) in
-      let (e1,env) = parse_expr env lhs in
-      let (e2,env) = parse_expr env rhs in
-       ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
-   |  _ -> failwith "error : parse_arith(2)"
-
- let parse_zarith = parse_arith  parse_zop parse_zexpr 
-  
- let parse_qarith = parse_arith  parse_qop parse_qexpr
-  
- let parse_rarith = parse_arith  parse_rop parse_rexpr
-  
-  
- (* generic parsing of arithmetic expressions *)
-  
-
-
-
- let rec f2f = function
-  | TT  -> Mc.TT
-  | FF  -> Mc.FF
-  | X _  -> Mc.X
-  | A (x,_) -> Mc.A x
-  | C (a,b,_)  -> Mc.Cj(f2f a,f2f b)
-  | D (a,b,_)  -> Mc.D(f2f a,f2f b)
-  | 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,none)
- let mkD f1 f2 = D(f1,f2,none)
- let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none)
- let mkI f1 f2 = I(f1,f2,none)
-
- let mkformula_binary g term f1 f2 =
-   match f1 , f2 with
-   |  X _  , X _ -> X(term)
-   |   _         -> g f1 f2
-
- let parse_formula parse_atom env term =
-  let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in
-
-  let rec xparse_formula env term =
-   match kind_of_term term with
-    | App(l,rst) ->
-        (match rst with
-         | [|a;b|] when l = Lazy.force coq_and ->
-	     let f,env = xparse_formula env a in
-	     let g,env = xparse_formula env b in
-             mkformula_binary mkC term f g,env
-         | [|a;b|] when l = Lazy.force coq_or ->
-	     let f,env = xparse_formula env a in
-	     let g,env = xparse_formula env b in
-             mkformula_binary mkD term f g,env
-         | [|a|] when l = Lazy.force coq_not ->
-             let (f,env) = xparse_formula env a in (N(f,none), env)
-         | [|a;b|] when l = Lazy.force coq_iff ->
-	     let f,env = xparse_formula env a in
-	     let g,env = xparse_formula env b in
-             mkformula_binary mkIff term f g,env
-         | _ -> parse_atom env term)
-    | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
-	let f,env = xparse_formula env a in
-	let g,env = xparse_formula env b in
-        mkformula_binary mkI term f g,env
-    | _ when term = Lazy.force coq_True -> (TT,env)
-    | _ when term = Lazy.force coq_False -> (FF,env)
-    | _  -> X(term),env in
-  xparse_formula env term
-
- let coq_TT = lazy 
-  (gen_constant_in_modules "ZMicromega" 
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "TT")
- let coq_FF = lazy 
-  (gen_constant_in_modules "ZMicromega" 
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "FF")
- let coq_And = lazy 
-  (gen_constant_in_modules "ZMicromega"    
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "Cj")
- let coq_Or = lazy 
-  (gen_constant_in_modules "ZMicromega"  
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]    "D")
- let coq_Neg = lazy 
-  (gen_constant_in_modules "ZMicromega" 
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "N")
- let coq_Atom = lazy 
-  (gen_constant_in_modules "ZMicromega" 
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "A")
- let coq_X = lazy 
-  (gen_constant_in_modules "ZMicromega"  
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "X")
- let coq_Impl = lazy 
-  (gen_constant_in_modules "ZMicromega" 
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "I")
- let coq_Formula = lazy 
-  (gen_constant_in_modules "ZMicromega" 
-    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "BFormula")
-
- let dump_formula typ dump_atom f = 
-  let rec xdump f = 
-   match f with
-    | TT  -> mkApp(Lazy.force coq_TT,[| typ|])
-    | FF  -> mkApp(Lazy.force coq_FF,[| typ|])
-    | C(x,y,_) -> mkApp(Lazy.force coq_And,[| typ ; xdump x ; xdump y|])
-    | D(x,y,_) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|])
-    | I(x,y,_) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|])
-    | N(x,_) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|])
-    | A(x,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) 
-    | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|])  in
-
-   xdump f
-    
-
-
-
- (* ! reverse the list of bindings *)
- let set l concl =
-  let rec _set acc = function
-   | [] -> acc
-   | (e::l) ->  
-      let (name,expr,typ) = e in
-       _set (Term.mkNamedLetIn
-	      (Names.id_of_string name)
-	      expr typ acc) l in
-   _set concl l
-
-
-end            
-
-open M
-
-
-let rec sig_of_cone = function
- | Mc.S_In n -> [CoqToCaml.nat n]
- | Mc.S_Ideal(e,w) -> sig_of_cone w
- | Mc.S_Mult(w1,w2) ->
-    (sig_of_cone w1)@(sig_of_cone w2)
- | Mc.S_Add(w1,w2) -> 	(sig_of_cone w1)@(sig_of_cone w2)
- | _  -> []
-
-let same_proof sg cl1 cl2 =
- let cl1 = CoqToCaml.list (fun x -> x) cl1 in
- let cl2 = CoqToCaml.list (fun x -> x) cl2 in
- let rec xsame_proof sg = 
-  match sg with
-   | [] -> true
-   | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) 
-      && (xsame_proof sg ) in
-  xsame_proof sg
-
-
-
-
-let tags_of_clause tgs wit clause = 
- let rec xtags tgs = function
-  | Mc.S_In n -> Names.Idset.union tgs  
-     (snd (List.nth clause (CoqToCaml.nat n) ))
-  | Mc.S_Ideal(e,w) -> xtags tgs w
-  | Mc.S_Mult (w1,w2) | Mc.S_Add(w1,w2) -> xtags (xtags tgs w1) w2
-  |   _   -> tgs in
-  xtags tgs wit
-
-let tags_of_cnf wits cnf = 
- List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) 
-  Names.Idset.empty wits cnf
-
-
-let find_witness prover  polys1 =
- let l = CoqToCaml.list (fun x -> x) polys1 in
-  try_any prover l
-
-let rec witness prover   l1 l2 = 
- match l2 with
-  | Micromega.Nil -> Some (Micromega.Nil)
-  | Micromega.Cons(e,l2) -> 
-     match find_witness prover   (Micromega.Cons( e,l1)) with
-      | None -> None
-      | Some w -> 
-	 (match witness prover   l1 l2 with
-	  | None -> None
-	  | Some l -> Some (Micromega.Cons (w,l))
-	 )
-
-
-let rec apply_ids t ids = 
- match ids with
-  | [] -> t
-  | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids
-
-     
-let coq_Node = lazy 
- (Coqlib.gen_constant_in_modules "VarMap" 
-   [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")
-let coq_Leaf = lazy 
- (Coqlib.gen_constant_in_modules "VarMap" 
-   [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")
-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 -> 
-  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 rec pp_varmap o vm = 
- match vm with
-  | Mc.Empty -> output_string o "[]"
-  | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z  z
-  | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l  pp_z z pp_varmap r
-
-
-
-let rec dump_proof_term = function 
- | Micromega.RatProof cone -> 
-    Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|])
- | Micromega.CutProof(e,q,cone,prf) ->
-    Term.mkApp(Lazy.force coq_cutProof, 
-	      [| dump_expr (Lazy.force coq_Z) dump_z e ; 
-		 dump_q q ; 
-		 dump_cone coq_Z dump_z cone ; 
-		 dump_proof_term prf|])
- | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) -> 
-    Term.mkApp (Lazy.force coq_enumProof,
-	       [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2;
-		  dump_cone coq_Z dump_z c1 ; dump_cone coq_Z dump_z c2 ; 
-		  dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |])
-
-let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
- 
- 
-let rec pp_proof_term o = function
- | Micromega.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone
- | Micromega.CutProof(e,q,_,p) -> failwith "not implemented"
- | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) -> 
-    Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]" 
-     pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2 
-     (pp_list "[" "]" pp_proof_term) rst
-
-let rec parse_hyps parse_arith env hyps =
- match hyps with
-  | [] -> ([],env)
-  | (i,t)::l -> 
-     let (lhyps,env) = parse_hyps parse_arith env l in
-      try 
-       let (c,env) = parse_formula parse_arith env  t in
-	((i,c)::lhyps, env)
-      with _ -> 		(lhyps,env)
-       (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
-
-
-exception ParseError
-
-let parse_goal parse_arith env hyps term = 
- (*  try*)
- let (f,env) = parse_formula parse_arith env term in
- let (lhyps,env) = parse_hyps parse_arith env hyps in
-  (lhyps,f,env)
-   (*  with Failure x -> raise ParseError*)
-
-
-type ('a, 'b) domain_spec = { 
- typ : Term.constr; (* Z, Q , R *)
- coeff : Term.constr ; (* Z, Q *)
- dump_coeff : 'a -> Term.constr ; 
- proof_typ : Term.constr ; 
- dump_proof : 'b -> Term.constr
-}
-
-let zz_domain_spec  = lazy {
- typ = Lazy.force coq_Z;
- coeff = Lazy.force coq_Z;
- dump_coeff = dump_z ;
- proof_typ = Lazy.force coq_proofTerm ;
- dump_proof = dump_proof_term
-}
-
-let qq_domain_spec  = lazy {
- typ = Lazy.force coq_Q;
- coeff = Lazy.force coq_Q;
- dump_coeff = dump_q ;
- proof_typ = Lazy.force coq_QWitness ;
- dump_proof = dump_cone coq_Q dump_q
-}
-
-let rz_domain_spec = lazy {
- typ = Lazy.force coq_R;
- coeff = Lazy.force coq_Z;
- dump_coeff = dump_z;
- proof_typ = Lazy.force coq_ZWitness ;
- dump_proof = dump_cone coq_Z dump_z
-}
-
-
-
-
-let micromega_order_change spec cert cert_typ env  ff gl = 
- 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
-  Tactics.change_in_concl None
-   (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 
-   
-
-let detect_duplicates cnf wit = 
- let cnf = CoqToCaml.list (fun x -> x) cnf in
- let wit = CoqToCaml.list (fun x -> x) wit in
-
- let rec xdup cnf wit = 
-  match wit with
-   | [] -> []
-   | w :: wit -> 
-      let sg = sig_of_cone w in
-       match cnf with
-	| [] -> []
-	| e::cnf -> 
-	   let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in
-	    dups@(xdup cnf wit) in
-  xdup cnf wit
-
-let find_witness prover    polys1 =
- try_any prover polys1
-
-
-let witness_list_with_tags prover l = 
- 
- let rec xwitness_list l = 
-  match l with
-   | [] -> Some([])
-   | e::l -> 
-      match find_witness prover  (List.map fst e)  with
-       | None -> None
-       | Some w -> 
-	  (match xwitness_list l with
-	   | None -> None
-	   | Some l -> Some (w::l)
-	  ) in
-  xwitness_list l
-
-let witness_list_without_tags prover l = 
- 
- let rec xwitness_list l = 
-  match l with
-   | [] -> Some([])
-   | e::l -> 
-      match find_witness prover e  with
-       | None -> None
-       | Some w -> 
-	  (match xwitness_list l with
-	   | None -> None
-	   | Some l -> Some (w::l)
-	  ) in
-  xwitness_list l
-
-let witness_list prover l = 
- let rec xwitness_list l = 
-  match l with
-   | Micromega.Nil -> Some(Micromega.Nil)
-   | Micromega.Cons(e,l) -> 
-      match find_witness prover e  with
-       | None -> None
-       | Some w -> 
-	  (match xwitness_list l with
-	   | None -> None
-	   | Some l -> Some (Micromega.Cons(w,l))
-	  ) in
-  xwitness_list l
-
-
-
-
-let is_singleton = function [] -> true | [e] -> true | _ -> false
- 
-
-let micromega_tauto negate normalise spec prover env polys1 polys2  gl = 
- let spec = Lazy.force spec in 
- let (ff,ids) = 
-  List.fold_right 
-   (fun (id,f)  (cc,ids) -> 
-    match f with 
-      X _ -> (cc,ids) 
-     | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids)) 
-   polys1 (polys2,[]) in
-
- let cnf_ff = cnf negate normalise ff in
-
-  if debug then 
-   (Pp.pp (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 ()) ;
-
-   match witness_list_without_tags prover  cnf_ff with
-    | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl
-    | Some res -> (*Printf.printf "\nList %i" (List.length res); *)
-       let (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in
-       let res' = dump_ml_list (spec.proof_typ) spec.dump_proof  res in
-	(Tacticals.tclTHENSEQ
-	  [
-	   Tactics.generalize ids;
-	   micromega_order_change spec res' 
-	    (Term.mkApp(Lazy.force coq_list,[|  spec.proof_typ|]))  env  ff ;
-	   ]) gl
-
-
-let micromega_gen parse_arith negate normalise 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 parse_arith Env.empty hyps concl in
-   let env = Env.elements env in
-    micromega_tauto negate normalise spec prover env hyps concl gl
-  with 
-   | Failure x -> flush stdout ; Pp.pp_flush () ; 
-      Tacticals.tclFAIL 0 (Pp.str x) gl
-   | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
-
-
-let lift_ratproof prover l =
- match prover l with
-  | None -> None
-  | Some c -> Some (Mc.RatProof c)
-
-
-type csdpcert = Sos.positivstellensatz option
-type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list
-type provername = string * int option
-
-let call_csdpcert provername poly =
-  let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in
-  let tmp_from = Filename.temp_file "csdpcert" ".out" in
-  output_value ch_to (provername,poly : provername * micromega_polys);
-  close_out ch_to;
-  let cmdname =
-    List.fold_left Filename.concat (Envars.coqlib ())
-      ["contrib"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in
-  let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in
-  (try Sys.remove tmp_to with _ -> ());
-  if c <> 0 then Util.error ("Failed to call csdp certificate generator");
-  let ch_from = open_in tmp_from in
-  let cert = (input_value ch_from : csdpcert) in
-  close_in ch_from; Sys.remove tmp_from;
-  cert
-
-let rec z_to_q_expr e = 
- match e with
-  | Mc.PEc z   -> Mc.PEc {Mc.qnum = z ; Mc.qden = Mc.XH}
-  | Mc.PEX x   -> Mc.PEX x
-  | Mc.PEadd(e1,e2) -> Mc.PEadd(z_to_q_expr e1, z_to_q_expr e2)
-  | Mc.PEsub(e1,e2) -> Mc.PEsub(z_to_q_expr e1, z_to_q_expr e2)
-  | Mc.PEmul(e1,e2) -> Mc.PEmul(z_to_q_expr e1, z_to_q_expr e2)
-  | Mc.PEopp(e) -> Mc.PEopp(z_to_q_expr e)
-  | Mc.PEpow(e,n) -> Mc.PEpow(z_to_q_expr e,n)
-
-
-let call_csdpcert_q provername poly = 
- match call_csdpcert provername poly with
-  | None -> None
-  | Some cert -> 
-     let cert = Certificate.q_cert_of_pos cert in
-      match Mc.qWeakChecker (CamlToCoq.list (fun x -> x) poly)  cert with
-       | Mc.True -> Some cert
-       | Mc.False ->  (print_string "buggy certificate" ; flush stdout) ;None
-
-
-let call_csdpcert_z provername poly = 
- let l = List.map (fun (Mc.Pair(e,o)) -> (Mc.Pair(z_to_q_expr e,o))) poly in
-  match call_csdpcert provername l with
-   | None -> None
-   | Some cert -> 
-      let cert = Certificate.z_cert_of_pos cert in
-       match Mc.zWeakChecker (CamlToCoq.list (fun x -> x) poly)  cert with
-	| Mc.True -> Some cert
-	| Mc.False ->  (print_string "buggy certificate" ; flush stdout) ;None
-
-
-
-
-let psatzl_Z gl = 
- micromega_gen parse_zarith  Mc.negate Mc.normalise zz_domain_spec
-  [lift_ratproof 
-    (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl
-
-
-let psatzl_Q gl = 
- micromega_gen  parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec 
-  [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ]   gl
-
-let psatz_Q i gl = 
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
-  [ call_csdpcert_q ("real_nonlinear_prover", Some i), "fourier refutation" ]  gl
-
-let psatzl_R gl = 
- micromega_gen  parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec 
-  [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ]   gl
-
-
-let psatz_R i gl = 
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
-  [ call_csdpcert_z  ("real_nonlinear_prover", Some i), "fourier refutation" ]  gl
-
-  
-let psatz_Z i gl = 
- micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec 
- [lift_ratproof (call_csdpcert_z ("real_nonlinear_prover",Some i)), 
-  "fourier refutation" ] gl
-
-
-let sos_Z gl = 
- micromega_gen parse_zarith Mc.negate Mc.normalise  zz_domain_spec 
-  [lift_ratproof (call_csdpcert_z ("pure_sos", None)), "pure sos refutation"]  gl
-
-let sos_Q gl = 
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise  qq_domain_spec 
-  [call_csdpcert_q ("pure_sos", None), "pure sos refutation"]  gl
-
-let sos_R gl = 
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise  rz_domain_spec 
-  [call_csdpcert_z ("pure_sos", None), "pure sos refutation"]  gl
-
-
-
-let xlia gl = 
- micromega_gen parse_zarith Mc.negate Mc.normalise   zz_domain_spec 
-  [Certificate.zlinear_prover, "zprover"] gl
diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml
deleted file mode 100644
index 415d3a3e..00000000
--- a/contrib/micromega/mfourier.ml
+++ /dev/null
@@ -1,667 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                                                                      *)
-(* Micromega: A reflexive tactic using the Positivstellensatz           *)
-(*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
-(*                                                                      *)
-(************************************************************************)
-
-(* Yet another implementation of Fourier *)
-open Num
-
-module Cmp =
- (* How to compare pairs, lists ... *)
-struct
- let rec compare_lexical l = 
-  match l with
-   | [] -> 0 (* Equal *)
-   | f::l -> 
-      let cmp = f () in
-       if cmp = 0 	then  compare_lexical l else cmp
-	
- let rec compare_list cmp l1 l2 = 
-  match l1 , l2 with
-   | []  , [] -> 0
-   | []  , _  -> -1
-   | _   , [] -> 1
-   | e1::l1 , e2::l2 -> 
-      let c = cmp e1 e2 in
-       if c = 0 then compare_list cmp l1 l2 else c
-	
- let hash_list hash l = 
-  let rec xhash res l = 
-   match l with
-    | []  -> res 
-    | e::l -> xhash ((hash e)  lxor res) l in
-   xhash  (Hashtbl.hash []) l
-
-end
- 
-module Interval = 
-struct
- (** The type of intervals.  **)
- type intrvl = Empty | Point of num | Itv  of  num option * num option
-  
- (**
-    Different intervals can denote the same set of variables e.g., 
-    Point n && Itv (Some n, Some n)
-    Itv (Some x) (Some y) && Empty if x > y
-    see the 'belongs_to' function.
- **)
-
- (* The set of numerics that belong to an interval *)
- let belongs_to n = function
-  | Empty -> false
-  | Point x -> n =/ x
-  | Itv(Some x, Some y) -> x <=/ n && n <=/ y
-  | Itv(None,Some y) -> n <=/ y
-  | Itv(Some x,None) -> x <=/ n
-  | Itv(None,None) -> true
-
- let string_of_bound = function
-  | None -> "oo"
-  | Some n -> Printf.sprintf "Bd(%s)"  (string_of_num n)
-
- let string_of_intrvl = function
-  | Empty -> "[]"
-  | Point n -> Printf.sprintf "[%s]" (string_of_num n)
-  | Itv(bd1,bd2) -> 
-     Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2)
-
- let pick_closed_to_zero = function
-  | Empty -> None
-  | Point n -> Some n
-  | Itv(None,None) -> Some (Int 0)
-  | Itv(None,Some i) -> 
-     Some (if  (Int 0) <=/ (floor_num  i) then Int 0 else floor_num i)
-  | Itv(Some i,None) -> 
-     Some (if i <=/ (Int 0) then Int 0 else ceiling_num i)
-  | Itv(Some i,Some j) -> 
-     Some (
-      if i <=/ Int 0 && Int 0 <=/ j 
-      then Int 0
-      else if ceiling_num i <=/ floor_num j 
-      then ceiling_num i (* why not *) else i)
-
- type status = 
-   | O | Qonly | Z | Q 
-       
- let interval_kind = function
-  | Empty -> O
-  | Point n -> if ceiling_num n =/ n then Z else Qonly
-  | Itv(None,None) -> Z
-  | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z
-  | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z
-  | Itv(Some i,Some j) -> 
-     if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z
-
- let empty_z = function
-  | Empty -> true
-  | Point n ->  ceiling_num n <>/ n 
-  | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false
-  | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j
-
-
- let normalise b1 b2 =
-  match b1 , b2 with
-   | Some i , Some j -> 
-      (match compare_num i j with
-       | 1 -> Empty
-       | 0 -> Point i
-       | _ -> Itv(b1,b2)
-      )
-   |  _ -> Itv(b1,b2)
-
-       
-
- let min x y = 
-  match x , y with
-   | None , x | x , None -> x
-   | Some i , Some j -> Some (min_num i j)
-      
- let max x y = 
-  match x , y with
-   | None , x | x , None -> x
-   | Some i , Some j -> Some (max_num i j)
-
- let inter i1 i2 = 
-  match i1,i2 with
-   | Empty , _ -> Empty
-   |  _   , Empty -> Empty
-   |  Point n , Point m -> if n =/ m then i1 else Empty
-   | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n-> 
-      if (match mn with 
-       | None -> true
-       | Some mn ->  mn <=/ n) && 
-       (match mx with 
-	| None -> true
-	| Some mx ->  n <=/ mx) then Point n else Empty
-   | Itv (min1,max1) , Itv (min2,max2) -> 
-      let bmin = max min1 min2
-      and bmax = min max1 max2 in
-       normalise bmin bmax
-
- (* a.x >= b*)
- let bound_of_constraint (a,b) =
-  match compare_num a (Int 0) with
-   | 0 -> 
-      if compare_num b (Int 0) = 1
-      then Empty  
-       (*actually this is a contradiction  failwith "bound_of_constraint" *)
-      else Itv (None,None)
-   | 1 -> Itv (Some (div_num  b a),None)
-   | -1 -> Itv (None, Some (div_num  b a))
-   | x -> failwith "bound_of_constraint(2)"
-
-
- let bounded x = 
-  match x with
-   | Itv(None,_) | Itv(_,None) -> false
-   |   _   -> true
-
-
- let range = function
-  | Empty -> Some (Int 0)
-  | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0))
-  | Itv(None,_) | Itv(_,None)-> None
-  | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1))
-
- (* Returns the interval of smallest range *)
- let smaller_itv i1 i2 = 
-  match range i1 , range i2  with
-   | None , _ -> false
-   |  _   , None -> true
-   | Some i , Some j -> i <=/ j
-
-end
-open Interval
-
-(* A set of constraints *)
-module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) = 
-struct
- 
- module Vect = V
-  
- module Cstr = Vector.Cstr(V)
- open Cstr
- 
- 
- module CMap = Map.Make(
-  struct
-   type t = Vect.t
-   let compare = Vect.compare
-  end)
-  
- module CstrBag = 
- struct 
-
-  type mut_itv = { mutable itv : intrvl} 
-
-  type t = mut_itv CMap.t
-    
-  exception Contradiction
-
-  let cstr_to_itv cstr = 
-   let (n,l) = V.normalise cstr.coeffs in 
-    if n =/ (Int 0)
-    then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *)
-    else
-     match cstr.op with
-      | Eq -> let n = cstr.cst // n in (l, Point n)
-      | Ge -> 
-	 match  compare_num n (Int 0) with
-	  | 0 -> failwith "intrvl_of_constraint"
-	  | 1 -> (l,Itv (Some (cstr.cst // n), None))
-	  | -1 -> (l, Itv(None,Some (cstr.cst // n)))
-	  |  _ -> failwith "cstr_to_itv"
-
-	      
-  let empty = CMap.empty
-
-
-
-
-  let is_empty = CMap.is_empty
-
-  let find_vect v bag = 
-   try
-    (bag,CMap.find v bag) 
-   with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x)
-
-
-  let add (v,b) bag = 
-   match b with
-    | Empty -> raise Contradiction
-    | Itv(None,None) -> bag
-    | _    -> 
-       let (bag,intrl) = find_vect v bag in
-	match inter b intrl.itv with
-	 | Empty -> raise Contradiction
-	 |  itv  -> intrl.itv <- itv ; bag
-
-  exception Found of cstr
-
-  let find_equation bag = 
-   try 
-    CMap.fold (fun v i () -> 
-     match i.itv with
-      | Point n -> let e = {coeffs = v ; op = Eq ; cst = n} 
-	in 	raise	(Found e)
-      |    _    -> () ) bag () ; None
-   with Found c -> Some c
-
-    
-  let fold f bag acc = 
-   CMap.fold (fun v itv acc -> 
-    match itv.itv with
-     | Empty | Itv(None,None)  -> failwith "fold Empty"
-     | Itv(None ,Some i) -> 
-	f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
-     | Point n           ->   f {coeffs =  v ; op = Eq ; cst = n} acc
-     | Itv(x,y) -> 	
-	(match x with 
-	 | None -> (fun x -> x)
-	 | Some i -> f {coeffs = v ; op = Ge ; cst = i})
-	 (match y with
-	  | None -> acc
-	  | Some i -> 
-	     f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
-	 ) ) bag acc
-
-
-  let remove l _ = failwith "remove:Not implemented"
-   
-  module Map = 
-   Map.Make(
-    struct 
-     type t = int 
-     let compare : int -> int -> int = Pervasives.compare 
-    end)
-
-  let split f (t:t) =
-   let res = 
-    fold (fun e m -> let i = f e in
-                      Map.add i (add (cstr_to_itv e) 
-				  (try Map.find i m with 
-				    Not_found -> empty)) m) t Map.empty in
-    (fun i -> try Map.find i res with Not_found -> empty)
-     
-  type map = (int list * int list) Map.t
-    
-    
-  let status (b:t) = 
-   let _ , map = fold (fun c ( (idx:int),(res: map)) ->
-    ( idx + 1,
-    List.fold_left (fun (res:map) (pos,s) -> 
-     let (lp,ln) = try  Map.find pos res with Not_found -> ([],[]) in
-      match s with
-       | Vect.Pos -> Map.add pos (idx::lp,ln) res
-       | Vect.Neg -> 
-	  Map.add pos (lp, idx::ln) res) res 
-     (Vect.status c.coeffs))) b (0,Map.empty) in
-    Map.fold (fun k e res -> (k,e)::res)  map []
-     
-
-  type it = num CMap.t
-    
-  let iterator x = x
-   
-  let element it = failwith "element:Not implemented"
-
- end
-end
-
-module Fourier(Vect : Vector.S)  =
-struct
- module Vect = Vect
- module Sys = Sys( Vect)
- module Cstr = Sys.Cstr
- module Bag = Sys.CstrBag
-
- open Cstr
- open Sys
-
- let debug = false
-
- let print_bag msg b =
-  print_endline msg;
-  CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b () 
-
- let print_bag_file file msg b =
-  let f = open_out file in
-   output_string f msg;
-   CstrBag.fold (fun e () -> 
-    Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b () 
-
-    
- (* A system with only inequations --
- *)
- let partition i m =
-  let splitter cstr =  compare_num (Vect.get i cstr.coeffs ) (Int 0) in
-  let split = CstrBag.split splitter m in
-   (split (-1) , split 0, split 1)
-
-    
- (* op of the result is arbitrary Ge *) 
- let lin_comb n1 c1 n2 c2 =
-  { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ; 
-    op = Ge ; 
-    cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)}
-
- (* BUG? : operator of the result ? *)
-
- let combine_project i c1 c2 =
-  let p = Vect.get  i c1.coeffs  
-  and n = Vect.get i c2.coeffs  in 
-   assert (n </ Int 0 && p >/ Int 0) ;
-   let nopp = minus_num n in 
-   let c =lin_comb nopp c1 p c2  in
-   let op = if c1.op = Ge ||  c2.op = Ge then Ge else Eq in
-    CstrBag.cstr_to_itv {coeffs =  c.coeffs ; op = op ; cst= c.cst }
-
-
- let project i m =
-  let (neg,zero,pos) = partition i m in
-  let project1 cpos acc = 
-   CstrBag.fold (fun cneg res ->
-    CstrBag.add (combine_project i cpos cneg) res) neg acc in
-   (CstrBag.fold project1 pos zero)
-
- (* Given a vector [x1 -> v1; ... ; xn -> vn]
-    and a constraint {x1 ; .... xn >= c }
- *)
- let evaluate_constraint i map cstr =
-  let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in
-  let vi = Vect.get  i _coeffs  in
-  let v = Vect.set i (Int 0) _coeffs in
-   (vi, _cst -/ Vect.dotp map v)
-
-
- let rec bounds m itv =
-  match m with
-   | [] -> itv
-   | e::m -> bounds m (inter itv (bound_of_constraint e))
-
-
-
- let compare_status (i,(lp,ln)) (i',(lp',ln')) = 
-  let cmp = Pervasives.compare 
-   ((List.length lp) * (List.length ln))  
-   ((List.length lp') * (List.length ln')) in
-   if cmp = 0
-   then Pervasives.compare i i'
-   else cmp
-
- let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0
-
- let lightest_projection  l c m  =
-  let bound = c in 
-   if debug then (Printf.printf "l%i" bound; flush stdout) ; 
-   let rec xlight best l =
-    match l with
-     | [] -> best
-     | i::l -> 
-	let proj = (project i m) in
-	let cproj = cardinal proj in
-	 (*Printf.printf " p %i " cproj; flush stdout;*)
-	 match best with
-	  | None -> 
-	     if cproj < bound 
-	     then Some(cproj,proj,i) 
-	     else xlight (Some(cproj,proj,i)) l
-	  | Some (cbest,_,_) -> 		
-	     if cproj < cbest 
-	     then 
-	      if cproj < bound then Some(cproj,proj,i)
-	      else xlight (Some(cproj,proj,i)) l 
-	     else xlight best l in
-    match xlight None l with
-     | None -> None
-     | Some(_,p,i) -> Some (p,i)
-	
-
-
- exception Equality of cstr
-
- let find_equality m = Bag.find_equation m
-
-  
-
- let pivot (n,v) eq ge =
-  assert (eq.op = Eq) ;
-  let res = 
-   match 
-    compare_num v (Int 0), 
-    compare_num (Vect.get n ge.coeffs) (Int 0) 
-   with
-    | 0 , _ -> failwith "Buggy"
-    | _ ,0  -> (CstrBag.cstr_to_itv ge)
-    | 1 , -1 -> combine_project n eq ge
-    | -1 , 1 -> combine_project n ge eq
-    | 1  , 1 -> 
-       combine_project n ge 
-	{coeffs = Vect.mul (Int (-1)) eq.coeffs; 
-	 op = eq.op ; 
-	 cst = minus_num eq.cst}
-    | -1 , -1 -> 
-       combine_project n 
-	{coeffs = Vect.mul (Int (-1)) eq.coeffs; 
-	 op = eq.op ; cst = minus_num eq.cst} ge
-    | _ -> failwith "pivot" in
-   res
-
- let check_cstr v c = 
-  let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
-  let vl = Vect.dotp v _coeffs in
-   match _op with
-    | Eq -> vl =/ _cst
-    | Ge -> vl >= _cst
-
-
- let forall p  sys = 
-  try 
-   CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true
-  with Not_found -> false
-
-
- let check_sys v sys = forall (check_cstr v) sys
-
- let check_null_cstr c = 
-  let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
-   match _op with
-    | Eq -> (Int 0) =/ _cst
-    | Ge -> (Int 0) >= _cst
-       
- let check_null sys = forall check_null_cstr sys
-
-
- let optimise_ge 
-   quick_check choose choose_idx return_empty return_ge return_eq  m =
-  let c = cardinal m in
-  let bound =  2 * c  in
-   if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout);
-
-   let rec xoptimise  m =
-    if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout);
-    if debug then (print_bag "xoptimise" m ; flush stdout);
-    if quick_check m
-    then return_empty m
-    else 
-     match find_equality m with
-      | None -> xoptimise_ge m
-      | Some eq -> xoptimise_eq eq m
-	 
-   and xoptimise_ge m =
-    begin
-     let c = cardinal m in
-     let l = List.map fst (List.sort compare_status (CstrBag.status m)) in
-     let  idx = choose bound l c m in
-      match idx with
-       | None -> return_empty m
-       | Some (proj,i) -> 
-	  match xoptimise proj with
-	   | None -> None
-	   | Some mapping -> return_ge m i mapping
-    end
-   and xoptimise_eq eq m = 
-    let l = List.map fst (Vect.status eq.coeffs) in
-     match choose_idx l with
-      | None -> (*if l = [] then None else*) return_empty m
-      | Some i -> 
-	 let p  = (i,Vect.get i eq.coeffs) in
-	 let m' = CstrBag.fold 
-	  (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in
-	  match xoptimise ( m') with
-	   | None -> None
-	   | Some mapp -> return_eq m eq i mapp in
-    try 
-     let res = xoptimise   m  in res
-    with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None
-
-
-
- let minimise m = 
-  let opt_zero_choose bound l c m = 
-   if c > bound 
-   then lightest_projection l c m
-   else match l with
-    | [] -> None
-    | i::_ -> Some (project i m, i) in
-   
-  let choose_idx = function [] -> None | x::l -> Some x in
-
-  let opt_zero_return_empty m = Some Vect.null in
-
-   
-  let opt_zero_return_ge m i mapping = 
-   let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter 
-    (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m 
-    (Itv (None, None)) in
-    match pick_closed_to_zero it with
-     | None -> print_endline "Cannot pick" ; None
-     | Some v -> 
-	let res =  (Vect.set i v mapping) in
-	 if debug 
-	 then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ;
-	 Some res in
-
-  let opt_zero_return_eq m eq i mapp = 
-   let (a,b) = evaluate_constraint i mapp eq in
-    Some (Vect.set i (div_num b a) mapp) in
-   
-   optimise_ge check_null opt_zero_choose 
-    choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq   m
-
- let normalise cstr = [CstrBag.cstr_to_itv cstr]
-
- let find_point l = 
-  (*  List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*)
-  try 
-   let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys) 
-    CstrBag.empty l in
-    match minimise m with
-     | None -> None
-     | Some res -> 
-	if debug then Printf.printf "[%s]"  (Vect.string res); 
-	Some res
-  with CstrBag.Contradiction -> None
-
-
- let find_q_interval_for x m = 
-  if debug then Printf.printf "find_q_interval_for %i\n" x ;
-
-  let choose bound l c m =
-   let rec xchoose l = 
-    match l with
-     | [] -> None
-     | i::l -> if i = x then xchoose l else Some (project i m,i) in
-    xchoose l in
-
-  let rec choose_idx = function 
-    [] -> None 
-   | e::l -> if e = x then choose_idx l else Some e in
-
-  let return_empty m = (* Beurk *)
-   (* returns the interval of x *)
-   Some (CstrBag.fold (fun cstr itv -> 
-    let i = if cstr.op = Eq 
-    then Point (cstr.cst // Vect.get x cstr.coeffs)  
-     else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs) 
-     then  bound_of_constraint (Vect.get x cstr.coeffs  , cstr.cst) 
-     else itv
-   in
-		       Interval.inter i itv) m (Itv (None, None)))  in
-   
-  let return_ge m i res = Some res in
-
-  let return_eq m eq i res = Some res in
-
-   try 
-    optimise_ge 
-     (fun x -> false) choose choose_idx return_empty return_ge return_eq m
-   with CstrBag.Contradiction -> None
-
-
- let find_q_intervals sys =
-  let variables =  
-   List.map fst (List.sort compare_status (CstrBag.status sys)) in
-   List.map (fun x -> (x,find_q_interval_for x sys)) variables
-
- let pp_option f o = function 
-   None -> Printf.fprintf o "None" 
-  | Some x -> Printf.fprintf o "Some %a" f x
-
- let optimise vect sys = 
-  (* we have to modify the system with a dummy variable *)
-  let fresh = 
-   List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in
-   assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys);
-   let cstr = {
-    coeffs = Vect.set fresh (Int (-1)) vect ; 
-    op = Eq ; 
-    cst = (Int 0)} in
-    try 
-     find_q_interval_for fresh 
-      (List.fold_left 
-	(fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)  
-	CstrBag.empty (cstr::sys))
-    with CstrBag.Contradiction -> None
-
-
- let optimise vect sys = 
-  let res = optimise vect sys in 
-   if debug 
-   then Printf.printf "optimise %s -> %a\n" 
-    (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res  
-   ; res
-
- let find_Q_interval sys = 
-  try 
-   let sys = 
-    (List.fold_left 
-      (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)  CstrBag.empty sys) in
-   let candidates = 
-    List.fold_left 
-     (fun l (x,i) -> match i with 
-       None -> (x,Empty)::l 
-      | Some i ->  (x,i)::l) [] (find_q_intervals sys) in
-    match List.fold_left 
-     (fun (x1,i1) (x2,i2) -> 
-      if smaller_itv i1 i2 
-      then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates 
-    with
-     | (i,Empty) -> None
-     | (x,Itv(Some i, Some j))  -> Some(i,x,j)
-     | (x,Point n) -> Some(n,x,n)
-     |   _        -> None
-  with CstrBag.Contradiction -> None
-
-
-end
-
diff --git a/contrib/micromega/vector.ml b/contrib/micromega/vector.ml
deleted file mode 100644
index fee4ebfc..00000000
--- a/contrib/micromega/vector.ml
+++ /dev/null
@@ -1,674 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                                                                      *)
-(* Micromega: A reflexive tactic using the Positivstellensatz           *)
-(*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
-(*                                                                      *)
-(************************************************************************)
-
-open Num
-
-module type S =
-sig
- type t 
-
- val fresh : t -> int
-
- val null : t
-
- val is_null : t -> bool
-
- val get : int -> t -> num
-
- val update : int -> (num -> num) -> t -> t
-  (* behaviour is undef if index < 0 -- might loop*)
-
- val set : int -> num -> t -> t
-
- (* 
-    For efficiency...
-
-    val get_update : int -> (num -> num) -> t -> num * t  
- *)
-
- val mul : num -> t -> t
-
- val uminus : t -> t
-
- val add : t -> t -> t
-
- val dotp : t -> t -> num
-
- val lin_comb : num -> t -> num -> t -> t
-  (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *)
-
- val gcd : t -> Big_int.big_int
-
- val normalise : t -> num * t 
-
- val hash : t -> int
-
- val compare : t -> t -> int 
-
- type it 
-
- val iterator : t -> it
- val element : it -> (num*it) option
-
- val string : t -> string
-
- type status = Pos | Neg
-
- (* the result list is ordered by fst *)
- val status : t -> (int * status) list 
-
- val from_list : num list -> t
- val to_list : t -> num list
-
-end
-
-
-module type SystemS = 
-sig
- 
- module Vect : S
-
- module  Cstr :
- sig
-  type kind = Eq | Ge
-  val string_of_kind : kind -> string
-  type cstr = {coeffs : Vect.t ; op : kind ; cst : num} 
-  val  string_of_cstr : cstr -> string
-  val compare : cstr -> cstr -> int
- end
- open Cstr
-
-
- module CstrBag : 
- sig 
-  type t
-  exception Contradiction
-
-  val empty : t
-
-  val is_empty : t -> bool
-
-  val add : cstr -> t -> t
-   (* c can be deduced from add c t *)
-
-  val find : (cstr -> bool) -> t  ->  cstr option
-
-  val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a
-
-  val status : t ->  (int * (int list * int list)) list
-   (* aggregate of vector statuses *)
-
-  val remove : cstr -> t -> t
-
-  (* remove_list the ith element -- it is the ith element visited by 'fold' *)
-
-  val split : (cstr -> int) -> t -> (int ->  t)
-
-  type it 
-  val iterator : t -> it
-  val element : it -> (cstr*it) option
-
- end
-
-end
-
-let zero_num = Int 0
-let unit_num = Int 1
-
-
-
-
-module Cstr(V:S) = 
-struct 
- type kind = Eq | Ge
- let string_of_kind = function Eq -> "Eq" | Ge -> "Ge"
-
- type cstr = {coeffs : V.t ; op : kind ; cst : num} 
-
- let string_of_cstr  {coeffs =a  ; op = b ; cst =c} =
-  Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c)
-
- type t = cstr
- let compare 
-   {coeffs = v1 ; op = op1 ; cst = c1}
-   {coeffs = v2 ; op = op2 ; cst = c2} =
-  Mutils.Cmp.compare_lexical [
-   (fun () -> V.compare v1 v2);
-   (fun () -> Pervasives.compare op1 op2);
-   (fun () -> compare_num c1 c2)
-  ]
-
-
-end
-
-
-
-module VList : S with type t = num list =
-struct
- type t =  num list
-
- let fresh l = failwith "not implemented"
-
- let null = []
-
- let is_null  = List.for_all ((=/) zero_num) 
-
- let normalise l = failwith "Not implemented"
-  (*match l with (* Buggy : What if the first num is zero! *)
-    | [] -> (Int 0,[])
-    | [n] -> (n,[Int 1])
-    | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l)
-  *)
-
-
- let get i l = try List.nth l i with _ -> zero_num
-
- (* This is not tail-recursive *)
- let rec update i f t =
-  match t with
-   | []   -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f [])
-   | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t)
-
- let rec set i n t =
-  match t with
-   | []   -> if i = 0 then [n] else (zero_num)::(set (i-1) n [])
-   | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t)
-
-
-
-
- let rec mul z t = 
-  match z with
-   | Int 0 -> null
-   | Int 1 -> t
-   |  _    -> List.map (mult_num z) t
-
- let uminus t = mul (Int (-1)) t
-
- let rec add t1 t2 =
-  match t1,t2 with
-   | [], _  -> t2
-   | _ , [] -> t1
-   | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2)
-
- let dotp t1 t2 =
-  let rec _dotp t1 t2 acc = 
-   match t1, t2 with
-    | [] , _  -> acc
-    | _  , [] -> acc
-    | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in
-   _dotp t1 t2 zero_num
-
- let add_mul n t1 t2 =
-  match n with
-   | Int 0 -> t2
-   | Int 1  -> add t1 t2
-   |  _     -> 
-       let rec _add_mul t1 t2 = 
-	match t1,t2 with
-	 | [], _  -> t2
-	 | _ , [] -> mul n t1
-	 | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in
-	_add_mul t1 t2
-
- let lin_comb n1 t1 n2 t2 = 
-  match n1,n2 with
-   | Int 0 , _  -> mul n2 t2
-   | Int 1 , _ -> add_mul n2 t2 t1
-   |   _   , Int 0 ->  mul n1 t1
-   |   _   , Int 1 -> add_mul n1 t1 t2  
-   |       _       -> 
-	    let rec _lin_comb t1 t2 = 
-	     match t1,t2 with
-	      | [], _  -> mul n2 t2
-	      | _ , [] -> mul n1 t1
-	      | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in
-	     _lin_comb t1 t2
-	      
- (* could be computed on the fly *)
- let gcd  t =Mutils.gcd_list t
-
-
-
-
- let hash = Mutils.Cmp.hash_list int_of_num 
-
- let compare = Mutils.Cmp.compare_list compare_num
-
- type it = t
- let iterator (x:t) : it = x
- let element it = 
-  match it with
-   | [] -> None
-   | e::l -> Some (e,l)
-
- (* TODO: Buffer! *)
- let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l ""
-
- type status = Pos | Neg
-
- let status l =
-  let rec xstatus i l = 
-   match l with 
-    | [] -> []
-    | e::l -> 
-       begin
-	match compare_num e (Int 0) with
-	 | 1 -> (i,Pos):: (xstatus (i+1) l)
-	 | 0 -> xstatus (i+1) l
-	 | -1 -> (i,Neg) :: (xstatus (i+1) l)
-	 | _  -> assert false
-       end in
-   xstatus 0 l
-
- let from_list l = l
- let to_list l = l
-  
-end
-
-module VMap : S =
-struct
- module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end)
-
- type t =  num Map.t
-
- let null = Map.empty
-
- let fresh m = failwith "not implemented"
-
- let is_null  = Map.is_empty
-
- let normalise m = failwith "Not implemented"
-
-
-
- let get i l = try Map.find i l with _ -> zero_num
-
- let  update i f t =
-  try
-   let res = f (Map.find i t) in
-    if res =/ zero_num
-    then Map.remove i t
-    else Map.add i res t
-  with
-    Not_found -> 
-     let res = f zero_num in
-      if res =/ zero_num then t else Map.add i res t
-
- let set i n t =
-  if n =/ zero_num then Map.remove i t
-  else Map.add i n t
-
-
- let rec mul z t = 
-  match z with
-   | Int 0 -> null
-   | Int 1 -> t
-   |  _    -> Map.map (mult_num z) t
-
- let uminus t = mul (Int (-1)) t
-  
-
- let map2 f m1 m2 = 
-  let res,m2' = 
-   Map.fold (fun k e (res,m2) -> 
-    let v = f e (get k m2) in
-     if v =/ zero_num
-     then (res,Map.remove k m2)
-     else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in
-   Map.fold (fun k e res -> 
-    let v = f zero_num e in
-     if v =/ zero_num
-     then res else Map.add k v res) m2' res
-    
- let  add t1 t2 = map2 (+/) t1 t2
-  
-
- let dotp t1 t2 =
-  Map.fold (fun k e res -> 
-   res +/ (e */ get k t2)) t1 zero_num
-
-
-
- let add_mul n t1 t2 =
-  match n with
-   | Int 0 -> t2
-   | Int 1  -> add t1 t2
-   |  _     -> map2 (fun x y -> (n */ x) +/ y) t1 t2
-
- let lin_comb n1 t1 n2 t2 = 
-  match n1,n2 with
-   | Int 0 , _  -> mul n2 t2
-   | Int 1 , _ -> add_mul n2 t2 t1
-   |   _   , Int 0 ->  mul n1 t1
-   |   _   , Int 1 -> add_mul n1 t1 t2  
-   |       _       -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2
-
-
- let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0
-
- let compare = Map.compare compare_num
-
- type it = t * int
-
- let iterator (x:t) : it = (x,0)
-  
- let element (mp,id) = 
-  try 
-   Some (Map.find id mp, (mp, id+1))
-  with
-    Not_found -> None
-
- (* TODO: Buffer! *)
- type status = Pos | Neg
-
- let status l = Map.fold (fun k e l -> 
-  match compare_num e (Int 0) with
-   | 1 -> (k,Pos)::l
-   | 0 ->  l
-   | -1 -> (k,Neg) :: l
-   | _  -> assert false) l []
- let from_list l = 
-  let rec from_list i l map = 
-   match l with
-    | [] -> map
-    | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in
-   from_list 0 l Map.empty
-
- let gcd m = 
-  let res = Map.fold (fun _ e x -> Big_int.gcd_big_int  x (Mutils.numerator e)) m Big_int.zero_big_int in
-   if Big_int.compare_big_int res Big_int.zero_big_int = 0 
-   then Big_int.unit_big_int else res
-
-
- let to_list m = 
-  let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in
-  let rec xto_list i l =
-   match l with
-    | [] -> []
-    |	(x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
-   xto_list 0 l
-
- let string l = VList.string (to_list l)
-
-  
-end
-
-
-module VSparse : S =
-struct
-
- type t = (int*num) list
-
- let null = []
-  
- let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc)  0 l
-
- let is_null l = l = []
-  
- let rec is_sorted l =
-  match l with
-   |	[] -> true
-   | [e] -> true
-   | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l)
-      
-      
- let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l)
-  
- (*	let get i t = 
-	assert (check t);
-	try List.assoc i t with Not_found -> zero_num *)
-
- let rec get (i:int) t = 
-  match t with
-   | [] -> zero_num
-   | (j,n)::t -> 
-      match compare i j with
-       | 0 -> n
-       | 1 -> get i t
-       |  _ -> zero_num
-
- let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
-   
- let rec update i f t = 
-  match t with
-   | [] -> cons i (f zero_num) []
-   | (k,v)::l -> 
-      match Pervasives.compare i k with
-       | 0 -> cons k (f v) l
-       | -1 -> cons i (f zero_num) t
-       |  1 -> (k,v) ::(update i f l)
-       |  _  -> failwith "compare_num"
-	   
- let update i f t =
-  assert (check t); 
-  let res = update i f t in
-   assert (check t) ; res
-    
-    
- let rec set i n t =
-  match t with
-   | [] -> cons i n []
-   | (k,v)::l -> 
-      match Pervasives.compare i k with
-       | 0 -> cons k n l
-       | -1 -> cons i n t
-       |  1 -> (k,v) :: (set i n l)
-       |  _  -> failwith "compare_num"
-	   
-
- let rec map f l = 
-  match l with
-   | [] -> []
-   | (i,e)::l -> cons i (f e) (map f l)
-      
- let rec mul z t = 
-  match z with
-   | Int 0 -> null
-   | Int 1 -> t
-   |  _    -> List.map (fun (i,n) -> (i, mult_num z n)) t
-       
- let mul z t = 
-  assert (check t) ;
-  let res = mul z t in
-   assert (check res) ; 
-   res
-
- let uminus t = mul (Int (-1)) t
-
-
- let normalise l = 
-  match l with
-   | []   -> (Int 0,[])
-   | (i,n)::_ -> (n, mul ((Int 1) // n) l)
-      
-
- let rec map2 f m1 m2 = 
-  match m1, m2 with
-   | [] , [] -> []
-   | l  , [] -> map (fun x -> f x zero_num) l
-   | [] ,l   -> map (f zero_num) l
-   | (i,e)::l1,(i',e')::l2 -> 
-      match Pervasives.compare i i' with
-       | 0 -> cons i (f e e') (map2 f l1 l2)
-       | -1 -> cons i (f e zero_num) (map2 f l1 m2)
-       |  1 -> cons i' (f zero_num e') (map2 f m1 l2)
-       | _  -> assert false
-	  
- (* let  add t1 t2 = map2 (+/) t1 t2*)
-
- let rec add (m1:t) (m2:t) = 
-  match m1, m2 with
-   | [] , [] -> []
-   | l  , [] -> l
-   | [] ,l   -> l
-   | (i,e)::l1,(i',e')::l2 -> 
-      match Pervasives.compare i i' with
-       | 0 -> cons i ( e +/ e') (add  l1 l2)
-       | -1 -> (i,e) :: (add l1 m2)
-       |  1 -> (i', e') :: (add m1 l2)
-       | _  -> assert false
-
-
-
-
- let add t1 t2 = 
-  assert (check t1 && check t2);
-  let res = add t1 t2 in
-   assert (check res);
-   res
-
-
- let rec dotp (t1:t) (t2:t) =
-  match t1, t2 with
-   | [] , _ -> zero_num
-   | _  , [] -> zero_num
-   | (i,e)::l1 , (i',e')::l2 -> 
-      match Pervasives.compare i i' with
-       | 0 -> (e */ e') +/ (dotp l1 l2)
-       | -1 -> dotp l1 t2
-       |  1 -> dotp t1 l2
-       |  _ -> assert false
-	   
- let dotp t1 t2 = 
-  assert (check t1 && check t2) ; dotp t1 t2
-
- let add_mul n t1 t2 =
-  match n with
-   | Int 0 -> t2
-   | Int 1  -> add t1 t2
-   |  _     -> map2 (fun x y -> (n */ x) +/ y) t1 t2
-
- let add_mul n (t1:t) (t2:t) =
-  match n with
-   | Int 0 -> t2
-   | Int 1  -> add t1 t2
-   |   _    -> 
-	let rec xadd_mul m1 m2 = 
-	 match m1, m2 with
-	  | [] , [] -> []
-	  | _  , [] -> mul n m1
-	  | [] , _   -> m2
-	  | (i,e)::l1,(i',e')::l2 -> 
-	     match Pervasives.compare i i' with
-	      | 0 -> cons i ( n */ e +/ e') (xadd_mul  l1 l2)
-	      | -1 -> (i,n */ e) :: (xadd_mul l1 m2)
-	      |  1 -> (i', e') :: (xadd_mul m1 l2)
-	      | _  -> assert false in
-	 xadd_mul t1 t2
-	  
-
-
-
- let lin_comb n1 t1 n2 t2 = 
-  match n1,n2 with
-   | Int 0 , _  -> mul n2 t2
-   | Int 1 , _ -> add_mul n2 t2 t1
-   |   _   , Int 0 ->  mul n1 t1
-   |   _   , Int 1 -> add_mul n1 t1 t2  
-   |       _       -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*)
-	    let rec xlin_comb m1 m2 = 
-	     match m1, m2 with
-	      | [] , [] -> []
-	      | _  , [] -> mul n1 m1
-	      | [] , _   -> mul n2 m2
-	      | (i,e)::l1,(i',e')::l2 -> 
-		 match Pervasives.compare i i' with
-		  | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb  l1 l2)
-		  | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2)
-		  |  1 -> (i', n2 */ e') :: (xlin_comb m1 l2)
-		  | _  -> assert false in
-	     xlin_comb t1 t2
-
-
-
-
-
- let lin_comb n1 t1 n2 t2 = 
-  assert (check t1 && check t2);
-  let res = lin_comb n1 t1 n2 t2 in
-   assert (check res); res
-
- let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y))
-
-
- let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical 
-  [
-   (fun () -> Pervasives.compare (fst x) (fst y));
-   (fun () -> compare_num (snd x) (snd y))]) 
-
- (* 
-    let compare (x:t) (y:t) = 
-    let rec xcompare acc1 acc2 x y = 
-    match x , y with
-    | [] , [] -> xcomp acc1 acc2
-    | [] , _  -> -1
-    |  _ , [] -> 1
-    | (i,n1)::l1 , (j,n2)::l2 -> 
-    match Pervasives.compare i j with
-    | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2
-    | c -> c
-    and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in
-    xcompare [] [] x y
- *)
-
- type it = t
-
- let iterator (x:t) : it =  x
-  
- let element l = failwith "Not_implemented"
-
- (* TODO: Buffer! *)
- type status = Pos | Neg
-
- let status l = List.map (fun (i,e) -> 
-  match compare_num e (Int 0) with
-   | 1 -> i,Pos
-   | -1 -> i,Neg
-   | _  -> assert false) l
-
- let from_list (l: num list) = 
-  let rec xfrom_list i l = 
-   match l with
-    | [] -> []
-    | e::l ->  
-       if e <>/ Int 0 
-       then (i,e)::(xfrom_list (i+1) l)
-       else xfrom_list (i+1) l in
-   
-  let res = xfrom_list 0 l in
-   assert (check res) ; res
-
-
- let gcd m = 
-  let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int  x (Mutils.numerator e))  Big_int.zero_big_int m in
-   if Big_int.compare_big_int res Big_int.zero_big_int = 0 
-   then Big_int.unit_big_int else res
-
- let to_list m = 
-  let rec xto_list i l =
-   match l with
-    | [] -> []
-    |	(x,v)::l' -> 
-	 if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
-   xto_list 0 m
-
- let to_list l =
-  assert (check l); 
-  to_list l
-
-
- let string l = VList.string (to_list l)
-  
-end
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
deleted file mode 100644
index cccee604..00000000
--- a/contrib/setoid_ring/Field_tac.v
+++ /dev/null
@@ -1,406 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Ring_tac BinList Ring_polynom InitialRing.
-Require Export Field_theory.
-
- (* syntaxification *)
- Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := 
- let rec mkP t :=
-    match Cst t with
-    | InitialRing.NotConstant =>
-        match t with 
-        | (radd ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEadd e1 e2)
-        | (rmul ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEmul e1 e2)
-        | (rsub ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEsub e1 e2)
-        | (ropp ?t1) =>
-          let e1 := mkP t1 in constr:(FEopp e1)
-        | (rdiv ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEdiv e1 e2)
-        | (rinv ?t1) =>
-          let e1 := mkP t1 in constr:(FEinv e1)
-        | (rpow ?t1 ?n) =>
-          match CstPow n with
-          | InitialRing.NotConstant => 
-            let p := Find_at t fv in constr:(@FEX C p)
-          | ?c => let e1 := mkP t1 in constr:(FEpow e1 c)
-          end
-  
-        | _ =>
-          let p := Find_at t fv in constr:(@FEX C p)
-        end
-    | ?c => constr:(FEc c)
-    end
- in mkP t.
-
-Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
- let rec TFV t fv :=
-  match Cst t with
-  | InitialRing.NotConstant =>
-      match t with
-      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (opp ?t1) => TFV t1 fv
-      | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (inv ?t1) => TFV t1 fv
-      | (pow ?t1 ?n) =>
-        match CstPow n with
-        | InitialRing.NotConstant => AddFvTail t fv
-        | _ => TFV t1 fv
-        end
-      | _ => AddFvTail t fv
-      end
-  | _ => fv
-  end 
- in TFV t fv.
-
-Ltac ParseFieldComponents lemma req :=
-  match type of lemma with
-  | context [
-     (*   PCond _ _ _  _ _ _ _  _ _  _ _ -> *)
-        req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv 
-                          ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
-      (fun f => f radd rmul rsub ropp rdiv rinv rpow C)
-  | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
-  end.
-
-(* simplifying the non-zero condition... *)
-
-Ltac fold_field_cond req :=
-  let rec fold_concl t :=
-    match t with
-      ?x /\ ?y =>
-        let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
-    | req ?x ?y -> False => constr:(~ req x y)
-    | _ => t
-    end in
-  match goal with
-    |- ?t => let ft := fold_concl t in change ft
-  end.
-
-Ltac simpl_PCond req :=
-  protect_fv "field_cond";
-  (try exact I);
-  fold_field_cond req.
-
-Ltac simpl_PCond_BEURK req :=
-  protect_fv "field_cond";
-  fold_field_cond req.
-
-(* Rewriting (field_simplify) *)
-Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl :=
-  let Main radd rmul rsub ropp rdiv rinv rpow C :=
-    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let mkFE := 
-       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let fv := FV_hypo_tac mkFV req lH in
-    let simpl_field H := (protect_fv "field" in H;f H) in
-    let lemma_tac fv RW_tac :=
-      let rr_lemma := fresh "f_rw_lemma" in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let vlpe := fresh "list_hyp" in
-      let vlmp := fresh "list_hyp_norm" in
-      let vlmp_eq := fresh "list_hyp_norm_eq" in
-      let prh := proofHyp_tac lH in
-      pose (vlpe := lpe);
-      match type of lemma with
-      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] =>
-        compute_assertion vlmp_eq vlmp 
-            (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
-         (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq)
-          || fail 1 "type error when build the rewriting lemma");
-         RW_tac rr_lemma;
-        try clear rr_lemma vlmp_eq vlmp vlpe
-      | _ => fail 1 "field_simplify anomaly: bad correctness lemma"
-      end in
-    ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl;
-    try (apply Cond_lemma; simpl_PCond req) in
-  ParseFieldComponents lemma req Main.
-
-Ltac Field_simplify_gen f := 
-     fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl =>
-       pre(); 
-       Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req 
-                  ring_subst_niter lH rl; 
-      post().
-
-Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H).
-
-Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
-  let G := Get_goal in
-  field_lookup Field_simplify [] rl G.
-
-Tactic Notation (at level 0) 
-  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
-  let G := Get_goal in
-  field_lookup Field_simplify [lH] rl G.
-
-Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=   
-  let G := Get_goal in
-  let t := type of H in   
-  let g := fresh "goal" in
-  set (g:= G);
-  generalize H;clear H;
-  field_lookup Field_simplify [] rl t;
-  intro H;
-  unfold g;clear g.
-
-Tactic Notation "field_simplify" 
-    "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):=   
-  let G := Get_goal in
-  let t := type of H in   
-  let g := fresh "goal" in
-  set (g:= G);
-  generalize H;clear H;
-  field_lookup Field_simplify [lH] rl t;
-  intro H;
-  unfold g;clear g.
-
-(*
-Ltac Field_simplify_in hyp:= 
-   Field_simplify_gen ltac:(fun H => rewrite H in hyp).
-
-Tactic Notation (at level 0) 
-  "field_simplify" constr_list(rl) "in" hyp(h) :=
-  let t := type of h in
-  field_lookup (Field_simplify_in h) [] rl t.
-
-Tactic Notation (at level 0) 
-  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
-  let t := type of h in
-  field_lookup (Field_simplify_in h) [lH] rl t.
-*)
-
-(** Generic tactic for solving equations *)
-
-Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH :=
-  let Main radd rmul rsub ropp rdiv rinv rpow C :=
-    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let mkFE := 
-       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let rec ParseExpr ilemma :=
-      match type of ilemma with
-        forall nfe, ?fe = nfe -> _ =>
-          (fun t => 
-            let x := fresh "fld_expr" in 
-            let H := fresh "norm_fld_expr" in
-            compute_assertion H x fe;
-            ParseExpr (ilemma x H) t;
-            try clear x H)
-      | _ => (fun t => t ilemma)
-      end in
-    let Main_eq t1 t2 :=
-      let fv := FV_hypo_tac mkFV req lH in
-      let fv := mkFFV t1 fv in
-      let fv := mkFFV t2 fv in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let prh := proofHyp_tac lH in
-      let vlpe := fresh "list_hyp" in
-      let fe1 := mkFE t1 fv in
-      let fe2 := mkFE t2 fv in
-      pose (vlpe := lpe);
-      let nlemma := fresh "field_lemma" in
-      (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
-       || fail "field anomaly:failed to build lemma"); 
-      ParseExpr nlemma
-         ltac:(fun ilemma =>
-                  apply ilemma 
-                  || fail "field anomaly: failed in applying lemma";
-                  [ Simpl_tac | apply Cond_lemma; simpl_PCond req]);
-      clear vlpe nlemma in
-    OnEquation req Main_eq in
-  ParseFieldComponents lemma req Main.
-
-(* solve completely a field equation, leaving non-zero conditions to be
-   proved (field) *)
-
-Ltac FIELD :=
-   let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
-   fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl =>
-       pre(); 
-       Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req 
-         Ring_tac.ring_subst_niter lH;
-       try exact I;
-       post().
- 
-Tactic Notation (at level 0) "field" :=
-  let G := Get_goal in
-  field_lookup FIELD [] G.
-
-Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
-  let G := Get_goal in
-  field_lookup FIELD [lH] G.
-
-(* transforms a field equation to an equivalent (simplified) ring equation,
-   and leaves non-zero conditions to be proved (field_simplify_eq) *)
-Ltac FIELD_SIMPL  :=
-  let Simpl := (protect_fv "field") in
-  fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl =>
-       pre(); 
-       Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok 
-          req Ring_tac.ring_subst_niter lH;
-       post().
-
-Tactic Notation (at level 0) "field_simplify_eq" :=  
-  let G := Get_goal in
-  field_lookup FIELD_SIMPL [] G.
-
-Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=  
-  let G := Get_goal in
-  field_lookup FIELD_SIMPL [lH] G.
-
-(* Same as FIELD_SIMPL but in hypothesis *)
-
-Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH :=
-   let Main radd rmul rsub ropp rdiv rinv rpow C :=
-    let hyp := fresh "hyp" in
-    intro hyp;   
-    match type of hyp with
-    | req ?t1 ?t2 =>
-      let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
-      let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
-      let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-      let mkFE := 
-        mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-      let rec ParseExpr ilemma :=
-        match type of ilemma with
-        |  forall nfe, ?fe = nfe -> _ =>
-          (fun t => 
-            let x := fresh "fld_expr" in 
-            let H := fresh "norm_fld_expr" in
-            compute_assertion H x fe;
-            ParseExpr (ilemma x H) t;
-            try clear H x)
-        | _ => (fun t => t ilemma)
-        end in
-      let fv := FV_hypo_tac mkFV req lH in
-      let fv := mkFFV t1 fv in
-      let fv := mkFFV t2 fv in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let prh := proofHyp_tac lH in
-      let fe1 := mkFE t1 fv in
-      let fe2 := mkFE t2 fv in
-      let vlpe := fresh "vlpe" in
-      ParseExpr (lemma n fv lpe fe1 fe2 prh)
-         ltac:(fun ilemma =>
-             match type of ilemma with
-             | req _ _ ->  _ -> ?EQ => 
-               let tmp := fresh "tmp" in
-               assert (tmp : EQ);
-               [ apply ilemma; 
-                 [ exact hyp | apply Cond_lemma; simpl_PCond_BEURK req]
-               | protect_fv "field" in tmp;
-                 generalize tmp;clear tmp ];
-               clear hyp  
-             end)
-     end in
-  ParseFieldComponents lemma req Main.
-
-Ltac FIELD_SIMPL_EQ :=
- fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl =>
-       pre(); 
-       Field_simplify_eq cst_tac pow_tac lemma cond_ok req
-         Ring_tac.ring_subst_niter lH;
-       post().
-
-Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
-  let t := type of H in
-  generalize H;
-  field_lookup FIELD_SIMPL_EQ [] t;
-  [ try exact I
-  | clear H;intro H].
-
-
-Tactic Notation (at level 0) 
-  "field_simplify_eq" "[" constr_list(lH) "]"  "in" hyp(H) :=  
-  let t := type of H in
-  generalize H;
-  field_lookup FIELD_SIMPL_EQ [lH] t;
-  [ try exact I
-  |clear H;intro H].
- 
-(* Adding a new field *)
-
-Ltac ring_of_field f :=
-  match type of f with
-  | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
-  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
-  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
-  end.
-
-Ltac coerce_to_almost_field set ext f :=
-  match type of f with
-  | almost_field_theory _ _ _ _ _ _ _ _ _ => f
-  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
-  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
-  end.
-
-Ltac field_elements set ext fspec pspec sspec dspec rk :=
-  let afth := coerce_to_almost_field set ext fspec in
-  let rspec := ring_of_field fspec in
-  ring_elements set ext rspec pspec sspec dspec rk
-  ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec).
-
-Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
-  let get_lemma :=
-    match pspec with None => fun x y => x | _ => fun x y => y end in
-  let simpl_eq_lemma := get_lemma 
-       Field_simplify_eq_correct       Field_simplify_eq_pow_correct in
-  let simpl_eq_in_lemma := get_lemma
-       Field_simplify_eq_in_correct   Field_simplify_eq_pow_in_correct in
-  let rw_lemma := get_lemma
-       Field_rw_correct                    Field_rw_pow_correct in
-  field_elements set ext fspec pspec sspec dspec rk
-   ltac:(fun afth ext_r morph p_spec s_spec d_spec =>
-     match morph with
-     | _ =>
-       let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in
-       match p_spec with
-       | mkhypo ?pp_spec =>  
-         let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
-         match s_spec with
-         | mkhypo ?ss_spec => 
-           let field_ok3 := constr:(field_ok2 _ ss_spec) in
-           match d_spec with
-           | mkhypo ?dd_spec => 
-             let field_ok := constr:(field_ok3 _ dd_spec) in
-             let mk_lemma lemma :=     
-              constr:(lemma _ _ _  _ _ _  _ _ _ _ 
-                   set ext_r inv_m afth 
-                   _ _ _  _ _ _  _ _ _ morph 
-                   _ _ _ pp_spec _ ss_spec _ dd_spec) in 
-             let field_simpl_eq_ok := mk_lemma simpl_eq_lemma  in
-             let field_simpl_ok := mk_lemma rw_lemma in
-             let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in
-             let cond1_ok := 
-                constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in
-             let cond2_ok := 
-               constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in
-             (fun f => 
-               f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
-                  cond1_ok cond2_ok)
-           | _ => fail 4 "field: bad coefficiant division specification"
-           end
-         | _ => fail 3 "field: bad sign specification"
-         end
-       | _ => fail 2 "field: bad power specification"
-       end  
-     | _ => fail 1 "field internal error : field_lemmas, please report"
-     end).
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
deleted file mode 100644
index ad20fa08..00000000
--- a/contrib/setoid_ring/Ring_tac.v
+++ /dev/null
@@ -1,386 +0,0 @@
-Set Implicit Arguments.
-Require Import Setoid.
-Require Import BinPos.
-Require Import Ring_polynom.
-Require Import BinList.
-Require Import InitialRing.
-  
-
-(* adds a definition id' on the normal form of t and an hypothesis id
-   stating that t = id' (tries to produces a proof as small as possible) *)
-Ltac compute_assertion id  id' t :=
-  let t' := eval vm_compute in t in
-  pose (id' := t');
-  assert (id : t = id');
-  [vm_cast_no_check (refl_equal id')|idtac].
-(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *)
-
-(********************************************************************)
-(* Tacticals to build reflexive tactics *)
-
-Ltac OnEquation req :=
-  match goal with
-  | |- req ?lhs ?rhs => (fun f => f lhs rhs)
-  | _ => fail 1 "Goal is not an equation (of expected equality)"
-  end.
-
-Ltac OnMainSubgoal H ty :=
-  match ty with
-  | _ -> ?ty' =>
-     let subtac := OnMainSubgoal H ty' in
-     fun tac => lapply H; [clear H; intro H; subtac tac | idtac]
-  | _ => (fun tac => tac)
-  end.
-
-Ltac ApplyLemmaThen lemma expr tac :=
-  let nexpr := fresh "expr_nf" in
-  let H := fresh "eq_nf" in
-  let Heq := fresh "thm" in
-  let nf_spec :=
-    match type of (lemma expr) with
-      forall x, ?nf_spec = x -> _ => nf_spec
-    | _ => fail 1 "ApplyLemmaThen: cannot find norm expression"
-    end in
-  compute_assertion H nexpr nf_spec;
-  assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma";
-  clear H;
-  OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr).
-
-Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
-  let npe := fresh "expr_nf" in
-  let H := fresh "eq_nf" in
-  let Heq := fresh "thm" in
-  let npe_spec :=
-    match type of (lemma expr) with
-      forall npe, ?npe_spec = npe -> _ => npe_spec
-    | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression"
-    end in
-  (compute_assertion H npe npe_spec;
-   (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
-   clear H;
-   OnMainSubgoal Heq ltac:(type of Heq)
-     ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)).
-
-(* General scheme of reflexive tactics using of correctness lemma
-   that involves normalisation of one expression *)
-
-Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_tac fv terms :=
-  (* extend the atom list *)
-  let fv := list_fold_left FV_tac fv terms in
-  let RW_tac lemma := 
-     let fcons term CONT_tac cont_arg := 
-      let expr := SYN_tac term fv in
-      (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in
-     (* rewrite steps *)
-     lazy_list_fold_right fcons ltac:(idtac) terms in
-  LEMMA_tac fv RW_tac.
-
-(********************************************************)
-
-
-(* Building the atom list of a ring expression *)
-Ltac FV Cst CstPow add mul sub opp pow t fv :=
- let rec TFV t fv :=
-  match Cst t with
-  | NotConstant =>
-      match t with
-      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (opp ?t1) => TFV t1 fv
-      | (pow ?t1 ?n) =>
-        match CstPow n with
-        | InitialRing.NotConstant => AddFvTail t fv
-        | _ => TFV t1 fv
-        end
-      | _ => AddFvTail t fv
-      end
-  | _ => fv
-  end
- in TFV t fv.
-
- (* syntaxification of ring expressions *)
-Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := 
- let rec mkP t :=
-    let f :=
-    match Cst t with
-    | InitialRing.NotConstant =>
-        match t with 
-        | (radd ?t1 ?t2) => 
-          fun _ =>
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEadd e1 e2)
-        | (rmul ?t1 ?t2) => 
-          fun _ =>
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEmul e1 e2)
-        | (rsub ?t1 ?t2) => 
-          fun _ => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEsub e1 e2)
-        | (ropp ?t1) =>
-          fun _ =>
-          let e1 := mkP t1 in constr:(PEopp e1)
-        | (rpow ?t1 ?n) =>
-          match CstPow n with
-          | InitialRing.NotConstant => 
-            fun _ => let p := Find_at t fv in constr:(PEX C p)
-          | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c)
-          end
-        | _ =>
-          fun _ => let p := Find_at t fv in constr:(PEX C p)
-        end
-    | ?c => fun _ => constr:(@PEc C c)
-    end in
-    f ()
- in mkP t.
-
-Ltac ParseRingComponents lemma :=
-  match type of lemma with
-  | context [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
-      (fun f => f R add mul sub opp pow C)
-  | _ => fail 1 "ring anomaly: bad correctness lemma (parse)"
-  end.
-
-(* ring tactics *)
-
-Ltac relation_carrier req :=
-  let ty := type of req in
-  match eval hnf in ty with
-   ?R -> _ => R
-  | _ => fail 1000 "Equality has no relation type"
-  end.
-
-Ltac FV_hypo_tac mkFV req lH :=
-  let R := relation_carrier req in
-  let FV_hypo_l_tac h :=
-    match h with @mkhypo (req ?pe _) _ => mkFV pe end in
-  let FV_hypo_r_tac h :=
-    match h with @mkhypo (req _ ?pe) _ => mkFV pe end in
-  let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in
-  list_fold_right FV_hypo_r_tac fv lH.
-
-Ltac mkHyp_tac C req mkPE lH :=
-  let mkHyp h res := 
-   match h with 
-   | @mkhypo (req ?r1 ?r2) _ =>
-     let pe1 := mkPE r1 in
-     let pe2 := mkPE r2 in
-     constr:(cons (pe1,pe2) res)
-   | _ => fail 1 "hypothesis is not a ring equality"
-   end in
-  list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
-     
-Ltac proofHyp_tac lH :=
-  let get_proof h :=
-    match h with
-    | @mkhypo _ ?p => p
-    end in
-  let rec bh l :=
-    match l with
-    | nil => constr:(I)
-    | cons ?h nil => get_proof h
-    | cons ?h ?tl => 
-      let l := get_proof h in
-      let r := bh tl in  
-      constr:(conj l r)
-    end in
-  bh lH.
-
-Definition ring_subst_niter := (10*10*10)%nat.
- 
-Ltac Ring Cst_tac CstPow_tac lemma1 req n lH :=
-  let Main lhs rhs R radd rmul rsub ropp rpow C :=
-    let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in
-    let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in
-    let fv := FV_hypo_tac mkFV req lH in
-    let fv := mkFV lhs fv in
-    let fv := mkFV rhs fv in
-    check_fv fv;
-    let pe1 := mkPol lhs fv in
-    let pe2 := mkPol rhs fv in
-    let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-    let vlpe := fresh "hyp_list" in
-    let vfv := fresh "fv_list" in
-    pose (vlpe := lpe);
-    pose (vfv := fv);
-    (apply (lemma1 n vfv vlpe pe1 pe2)
-      || fail "typing error while applying ring");
-    [ ((let prh := proofHyp_tac lH in exact prh)
-        || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") 
-    | vm_compute;
-      (exact (refl_equal true) || fail "not a valid ring equation")] in
-  ParseRingComponents lemma1 ltac:(OnEquation req Main).
-
-Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
-  let Main R add mul sub opp pow C :=
-    let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in
-    let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in
-    let fv := FV_hypo_tac mkFV req lH in
-    let simpl_ring H := (protect_fv "ring" in H; f H) in
-    let lemma_tac fv RW_tac := 
-      let rr_lemma := fresh "r_rw_lemma" in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let vlpe := fresh "list_hyp" in
-      let vlmp := fresh "list_hyp_norm" in
-      let vlmp_eq := fresh "list_hyp_norm_eq" in
-      let prh := proofHyp_tac lH in
-      pose (vlpe := lpe);
-      match type of lemma2 with
-      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _]
-            =>
-        compute_assertion vlmp_eq vlmp 
-            (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
-         (assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq)
-          || fail 1 "type error when build the rewriting lemma");   
-         RW_tac rr_lemma;
-         try clear rr_lemma vlmp_eq vlmp vlpe
-      | _ => fail 1 "ring_simplify anomaly: bad correctness lemma"
-      end in
-    ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in
-  ParseRingComponents lemma2 Main.
-
-
-Ltac Ring_gen
-  req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl :=
-  pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH.
-
-Ltac Get_goal := match goal with [|- ?G] => G end.
-
-Tactic Notation (at level 0) "ring" :=
-  let G := Get_goal in
-  ring_lookup Ring_gen [] G.
-
-Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
-  let G := Get_goal in
-  ring_lookup Ring_gen [lH] G.
-
-(* Simplification *)
-
-Ltac Ring_simplify_gen f :=
-  fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     let l := fresh "to_rewrite" in
-     pose (l:= rl);
-     generalize (refl_equal l);
-     unfold l at 2;
-     pre(); 
-     let Tac RL :=
-       let Heq := fresh "Heq" in
-       intros Heq;clear Heq l;
-       Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL; 
-       post() in
-     let Main :=
-       match goal with
-       | [|- l = ?RL -> _ ] => (fun f => f RL)
-       | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
-       end in
-     Main Tac.
-
-Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H).
-
-Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := 
-  let G := Get_goal in
-  ring_lookup Ring_simplify [] rl G.
-
-Tactic Notation (at level 0) 
-  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
-  let G := Get_goal in
-  ring_lookup 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   
-  let g := fresh "goal" in
-  set (g:= G);
-  generalize H;clear H;
-  ring_lookup Ring_simplify [] rl t;
-  intro H;
-  unfold g;clear g.
-
-Tactic Notation 
-  "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):=   
-  let G := Get_goal in
-  let t := type of H in   
-  let g := fresh "goal" in
-  set (g:= G);
-  generalize H;clear H;
-  ring_lookup Ring_simplify [lH] rl t;
-  intro H;
-  unfold g;clear g.
-
-
-
-(*     LE RESTE MARCHE PAS DOMMAGE  .....  *)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-(*
-
-
-
-
-
-
-
-
-Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp).
-
-
-Tactic Notation (at level 0) 
-  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := 
-  match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl G end.
-
-Tactic Notation (at level 0) 
-  "ring_simplify" constr_list(rl) := 
-  match goal with [|- ?G] => ring_lookup Ring_simplify [] rl G end.
-
-Tactic Notation (at level 0) 
-  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= 
-  let t := type of h in
-  ring_lookup 
-   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     pre(); 
-     Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
-     post()) 
-  [lH] rl t. 
-(*  ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *)
-
-Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp).
-
-Tactic Notation (at level 0) 
-  "ring_simplify" constr_list(rl) "in" constr(h):= 
-  let t := type of h in
-  ring_lookup   
-   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     pre(); 
-     Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
-     post())
- [] rl t.
-
-Ltac rw_in H Heq := rewrite Heq in H.
-
-Ltac simpl_in H := 
-  let t := type of H in
-   ring_lookup 
-   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     pre(); 
-     Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
-     post()) 
-   [] t.
-
-
-*)
diff --git a/contrib/subtac/equations.ml4 b/contrib/subtac/equations.ml4
deleted file mode 100644
index 9d120019..00000000
--- a/contrib/subtac/equations.ml4
+++ /dev/null
@@ -1,1149 +0,0 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i camlp4use: "pa_extend.cmo" i*) 
-
-(* $Id: subtac_cases.ml 11198 2008-07-01 17:03:43Z msozeau $ *)
-
-open Cases
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Declarations
-open Inductiveops
-open Environ
-open Sign
-open Reductionops
-open Typeops
-open Type_errors
-
-open Rawterm
-open Retyping
-open Pretype_errors
-open Evarutil
-open Evarconv
-open List
-open Libnames
-
-type pat =
-  | PRel of int
-  | PCstr of constructor * pat list
-  | PInac of constr
-
-let coq_inacc = lazy (Coqlib.gen_constant "equations" ["Program";"Equality"] "inaccessible_pattern")
-  
-let mkInac env c =
-  mkApp (Lazy.force coq_inacc, [| Typing.type_of env Evd.empty c ; c |])
-    
-let rec constr_of_pat ?(inacc=true) env = function
-  | PRel i -> mkRel i
-  | PCstr (c, p) -> 
-      let c' = mkConstruct c in
-	mkApp (c', Array.of_list (constrs_of_pats ~inacc env p))
-  | PInac r -> 
-      if inacc then try mkInac env r with _ -> r else r
-      
-and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l
-
-let rec pat_vars = function
-  | PRel i -> Intset.singleton i
-  | PCstr (c, p) -> pats_vars p
-  | PInac _ -> Intset.empty
-
-and pats_vars l = 
-  fold_left (fun vars p -> 
-    let pvars = pat_vars p in
-    let inter = Intset.inter pvars vars in
-      if inter = Intset.empty then
-	Intset.union pvars vars
-      else error ("Non-linear pattern: variable " ^
-		     string_of_int (Intset.choose inter) ^ " appears twice"))
-    Intset.empty l
-
-let rec pats_of_constrs l = map pat_of_constr l
-and pat_of_constr c = 
-  match kind_of_term c with
-  | Rel i -> PRel i
-  | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) ->
-      PInac c
-  | App (f, args) when isConstruct f ->
-      PCstr (destConstruct f, pats_of_constrs (Array.to_list args))
-  | Construct f -> PCstr (f, [])
-  | _ -> PInac c
-
-let inaccs_of_constrs l = map (fun x -> PInac x) l
-
-exception Conflict
-
-let rec pmatch p c =
-  match p, c with
-  | PRel i, t -> [i, t]
-  | PCstr (c, pl), PCstr (c', pl') when c = c' -> pmatches pl pl'
-  | PInac _, _ -> []
-  | _, PInac _ -> []
-  | _, _ -> raise Conflict
-
-and pmatches pl l =
-  match pl, l with
-  | [], [] -> []
-  | hd :: tl, hd' :: tl' -> 
-      pmatch hd hd' @ pmatches tl tl'
-  | _ -> raise Conflict
-      
-let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None
-
-let rec pinclude p c =
-  match p, c with
-  | PRel i, t -> true
-  | PCstr (c, pl), PCstr (c', pl') when c = c' -> pincludes pl pl'
-  | PInac _, _ -> true
-  | _, PInac _ -> true
-  | _, _ -> false
-      
-and pincludes pl l =
-  match pl, l with
-  | [], [] -> true
-  | hd :: tl, hd' :: tl' -> 
-      pinclude hd hd' && pincludes tl tl'
-  | _ -> false
-      
-let pattern_includes pl l = pincludes pl l
-
-(** Specialize by a substitution. *)
-
-let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s)
-
-let subst_rel_subst k s c = 
-  let rec aux depth c =
-    match kind_of_term c with
-    | Rel n -> 
-	let k = n - depth in 
-	  if k >= 0 then 
-	    try lift depth (snd (assoc k s))
-	    with Not_found -> c
-	  else c
-    | _ -> map_constr_with_binders succ aux depth c
-  in aux k c
-    
-let subst_context s ctx =
-  let (_, ctx') = fold_right 
-    (fun (id, b, t) (k, ctx') ->
-      (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx'))
-    ctx (0, [])
-  in ctx'
-
-let subst_rel_context k cstr ctx = 
-  let (_, ctx') = fold_right 
-    (fun (id, b, t) (k, ctx') ->
-      (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx'))
-    ctx (k, [])
-  in ctx'
-
-let rec lift_pat n k p = 
-  match p with
-  | PRel i ->
-      if i >= k then PRel (i + n)
-      else p
-  | PCstr(c, pl) -> PCstr (c, lift_pats n k pl)
-  | PInac r -> PInac (liftn n k r)
-      
-and lift_pats n k = map (lift_pat n k)
-
-let rec subst_pat env k t p = 
-  match p with
-  | PRel i -> 
-      if i = k then t
-      else if i > k then PRel (pred i)
-      else p
-  | PCstr(c, pl) ->
-      PCstr (c, subst_pats env k t pl)
-  | PInac r -> PInac (substnl [constr_of_pat ~inacc:false env t] (pred k) r)
-
-and subst_pats env k t = map (subst_pat env k t)
-
-let rec specialize s p = 
-  match p with
-  | PRel i -> 
-      if mem_assoc i s then
-	let b, t = assoc i s in
-	  if b then PInac t
-	  else PRel (destRel t)
-      else p
-  | PCstr(c, pl) ->
-      PCstr (c, specialize_pats s pl)
-  | PInac r -> PInac (specialize_constr s r)
-
-and specialize_constr s c = subst_rel_subst 0 s c
-and specialize_pats s = map (specialize s)
-
-let specialize_patterns = function
-  | [] -> fun p -> p
-  | s -> specialize_pats s
-
-let specialize_rel_context s ctx =
-  snd (fold_right (fun (n, b, t) (k, ctx) -> 
-    (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx))
-	  ctx (0, []))
-    
-let lift_contextn n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-  liftrec (rel_context_length sign + k) sign
-
-type program = 
-  signature * clause list
-
-and signature = identifier * rel_context * constr
-
-and clause = lhs * (constr, int) rhs
-
-and lhs = rel_context * identifier * pat list
-
-and ('a, 'b) rhs = 
-  | Program of 'a
-  | Empty of 'b
-
-type splitting = 
-  | Compute of clause
-  | Split of lhs * int * inductive_family *
-      unification_result array * splitting option array
-      
-and unification_result = 
-  rel_context * int * constr * pat * substitution option
-
-and substitution = (int * (bool * constr)) list
-
-type problem = identifier * lhs
-
-let rels_of_tele tele = rel_list 0 (List.length tele)
-
-let patvars_of_tele tele = map (fun c -> PRel (destRel c)) (rels_of_tele tele)
-
-let split_solves split prob =
-  match split with
-  | Compute (lhs, rhs) -> lhs = prob
-  | Split (lhs, id, indf, us, ls) -> lhs = prob
-
-let ids_of_constr c = 
-  let rec aux vars c = 
-    match kind_of_term c with
-    | Var id -> Idset.add id vars
-    | _ -> fold_constr aux vars c
-  in aux Idset.empty c
-
-let ids_of_constrs = 
-  fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty
-
-let idset_of_list =
-  fold_left (fun s x -> Idset.add x s) Idset.empty
-
-let intset_of_list =
-  fold_left (fun s x -> Intset.add x s) Intset.empty
-
-let solves split (delta, id, pats as prob) = 
-  split_solves split prob && 
-  Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta)))
-
-let check_judgment ctx c t =
-  ignore(Typing.check (push_rel_context ctx (Global.env ())) Evd.empty c t); true
-
-let check_context env ctx =
-  fold_right
-    (fun (_, _, t as decl) env -> 
-      ignore(Typing.sort_of env Evd.empty t); push_rel decl env)
-    ctx env
-
-let split_context n c =
-  let after, before = list_chop n c in
-    match before with
-    | hd :: tl -> after, hd, tl
-    | [] -> raise (Invalid_argument "split_context")
-	
-let split_tele n (ctx : rel_context) =
-  let rec aux after n l =
-    match n, l with
-    | 0, decl :: before -> before, decl, List.rev after
-    | n, decl :: before -> aux (decl :: after) (pred n) before
-    | _ -> raise (Invalid_argument "split_tele")
-  in aux [] n ctx
-
-let rec add_var_subst env subst n c =
-  if mem_assoc n subst then
-    let t = assoc n subst in
-      if eq_constr t c then subst
-      else unify env subst t c
-  else 
-    let rel = mkRel n in
-      if rel = c then subst
-      else if dependent rel c then raise Conflict
-      else (n, c) :: subst
-    
-and unify env subst x y =
-  match kind_of_term x, kind_of_term y with
-  | Rel n, _ -> add_var_subst env subst n y
-  | _, Rel n -> add_var_subst env subst n x
-  | App (c, l), App (c', l') when eq_constr c c' ->
-      unify_constrs env subst (Array.to_list l) (Array.to_list l')
-  | _, _ -> if eq_constr x y then subst else raise Conflict
-
-and unify_constrs (env : env) subst l l' = 
-  if List.length l = List.length l' then
-    fold_left2 (unify env) subst l l'
-  else raise Conflict
-
-let fold_rel_context_with_binders f ctx init =
-  snd (List.fold_right (fun decl (depth, acc) ->
-    (succ depth, f depth decl acc)) ctx (0, init))
-    
-let dependent_rel_context (ctx : rel_context) k =
-  fold_rel_context_with_binders
-    (fun depth (n,b,t) acc -> 
-      let r = mkRel (depth + k) in
-	acc || dependent r t ||
-	  (match b with
-	  | Some b -> dependent r b
-	  | None -> false))
-    ctx false
-
-let liftn_between n k p c =
-  let rec aux depth c = match kind_of_term c with
-    | Rel i -> 
-	if i <= depth then c
-	else if i-depth > p then c
-	else mkRel (i - n)
-    | _ -> map_constr_with_binders succ aux depth c
-  in aux k c
-    
-let liftn_rel_context n k sign =  
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-    liftrec (k + rel_context_length sign) sign
-
-let substnl_rel_context n l =
-  map_rel_context_with_binders (fun k -> substnl l (n+k-1))
-
-let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list) =
-  let _, s, ctx' =
-    fold_left (fun (k, s, ctx') (n, b, t as decl) ->
-      match b with
-      | None -> (succ k, mkRel k :: s, ctx' @ [decl])
-      | Some t -> (k, lift (pred k) t :: map (substnl [t] (pred k)) s, subst_rel_context 0 t ctx'))
-      (1, [], []) ctx
-  in
-  let s = rev s in
-  let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in
-    s', ctx'
-      
-(* Compute the transitive closure of the dependency relation for a term in a context *)
-
-let rec dependencies_of_rel ctx k =
-  let (n,b,t) = nth ctx (pred k) in
-  let b = Option.map (lift k) b and t = lift k t in
-  let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in
-    Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t))
-      
-and dependencies_of_term ctx t =
-  let rels = free_rels t in
-    Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty
-
-let subst_telescope k cstr ctx = 
-  let (_, ctx') = fold_left
-    (fun (k, ctx') (id, b, t) ->
-      (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx'))
-    (k, []) ctx
-  in rev ctx'
-
-let lift_telescope n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign)
-    | [] -> []
-  in liftrec k sign
-    
-type ('a,'b) either = Inl of 'a | Inr of 'b
-  
-let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list =
-  let rels = dependencies_of_term ctx t in
-  let len = length ctx in
-  let nbdeps = Intset.cardinal rels in
-  let lifting = len - nbdeps in (* Number of variables not linked to t *)
-  let rec aux k n acc m rest s = function
-    | decl :: ctx' ->
-	if Intset.mem k rels then
-	  let rest' = subst_telescope 0 (mkRel (nbdeps + lifting - pred m)) rest in
-	    aux (succ k) (succ n) (decl :: acc) m rest' ((k, Inl n) :: s) ctx'
-	else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx'
-    | [] -> rev acc, rev rest, s
-  in aux 1 1 [] 1 [] [] ctx
-    
-let merge_subst (ctx', rest, s) =
-  let lenrest = length rest in
-    map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s
-
-(* let simplify_subst s =  *)
-(*   fold_left (fun s (k, t) ->  *)
-(*     match kind_of_term t with *)
-(*     | Rel n when n = k -> s *)
-(*     | _ -> (k, t) :: s) *)
-(*     [] s *)
-
-let compose_subst s' s =
-  map (fun (k, (b, t)) -> (k, (b, specialize_constr s' t))) s
-
-let substitute_in_ctx n c ctx =
-  let rec aux k after = function
-    | [] -> []
-    | (name, b, t as decl) :: before ->
-	if k = n then rev after @ (name, Some c, t) :: before
-	else aux (succ k) (decl :: after) before
-  in aux 1 [] ctx
-    
-let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) =
-  match cursubst with
-  | [] -> ctx, substacc
-  | (k, (b, t)) :: rest ->
-      if t = mkRel k then reduce_subst ctx substacc rest
-      else if noccur_between 1 k t then
-	(* The term to substitute refers only to previous variables. *)
-	let t' = lift (-k) t in
-	let ctx' = substitute_in_ctx k t' ctx in
-	  reduce_subst ctx' substacc rest
-      else (* The term refers to variables declared after [k], so we have 
-	      to move these dependencies before [k]. *)
-	let (minctx, ctxrest, subst as str) = strengthen ctx t in
-	  match assoc k subst with
-	  | Inl _ -> error "Occurs check in substituted_context"
-	  | Inr k' ->
-	      let s = merge_subst str in
-	      let ctx' = ctxrest @ minctx in
-	      let rest' =
-		let substsubst (k', (b, t')) =
-		  match kind_of_term (snd (assoc k' s)) with
-		  | Rel k'' -> (k'', (b, specialize_constr s t'))
-		  | _ -> error "Non-variable substituted for variable by strenghtening"
-		in map substsubst ((k, (b, t)) :: rest)
-	      in
-		reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *)
-		  
-		  
-let substituted_context (subst : (int * constr) list) (ctx : rel_context) =
-  let _, subst =
-    fold_left (fun (k, s) _ ->
-      try let t = assoc k subst in
-	    (succ k, (k, (true, t)) :: s)
-      with Not_found ->
-	(succ k, ((k, (false, mkRel k)) :: s)))
-      (1, []) ctx
-  in
-  let ctx', subst' = reduce_subst ctx subst subst in
-    reduce_rel_context ctx' subst'
-    
-let unify_type before ty =
-  try
-    let envb = push_rel_context before (Global.env()) in
-    let IndType (indf, args) = find_rectype envb Evd.empty ty in
-    let ind, params = dest_ind_family indf in
-    let vs = map (Reduction.whd_betadeltaiota envb) args in
-    let cstrs = Inductiveops.arities_of_constructors envb ind in
-    let cstrs = 
-      Array.mapi (fun i ty ->
-	let ty = prod_applist ty params in
-	let ctx, ty = decompose_prod_assum ty in
-	let ctx, ids = 
-	  let ids = ids_of_rel_context ctx in
-	    fold_right (fun (n, b, t as decl) (acc, ids) ->
-	      match n with Name _ -> (decl :: acc), ids
-	      | Anonymous -> let id = next_name_away Anonymous ids in
-			       ((Name id, b, t) :: acc), (id :: ids))
-	      ctx ([], ids)
-	in
-	let env' = push_rel_context ctx (Global.env ()) in
-	let IndType (indf, args) = find_rectype env' Evd.empty ty in
-	let ind, params = dest_ind_family indf in
-	let constr = applist (mkConstruct (ind, succ i), params @ rels_of_tele ctx) in
-	let constrpat = PCstr ((ind, succ i), inaccs_of_constrs params @ patvars_of_tele ctx) in
-	  env', ctx, constr, constrpat, (* params @  *)args)
-	cstrs
-    in
-    let res = 
-      Array.map (fun (env', ctxc, c, cpat, us) -> 
-	let _beforelen = length before and ctxclen = length ctxc in
-	let fullctx = ctxc @ before in
-	  try
-	    let fullenv = push_rel_context fullctx (Global.env ()) in
-	    let vs' = map (lift ctxclen) vs in
-	    let subst = unify_constrs fullenv [] vs' us in
-	    let subst', ctx' = substituted_context subst fullctx in
-	      (ctx', ctxclen, c, cpat, Some subst')
-	  with Conflict -> 
-	    (fullctx, ctxclen, c, cpat, None)) cstrs
-    in Some (res, indf)
-  with Not_found -> (* not an inductive type *)
-    None
-
-let rec id_of_rel n l =
-  match n, l with
-  | 0, (Name id, _, _) :: tl -> id
-  | n, _ :: tl -> id_of_rel (pred n) tl
-  | _, _ -> raise (Invalid_argument "id_of_rel")
-
-let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = 
-  constrs_of_pats ~inacc (push_rel_context ctx env) pats
-      
-let rec valid_splitting (f, delta, t, pats) tree = 
-  split_solves tree (delta, f, pats) && 
-    valid_splitting_tree (f, delta, t) tree
-    
-and valid_splitting_tree (f, delta, t) = function
-  | Compute (lhs, Program rhs) -> 
-      let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in 
-	ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true
-
-  | Compute ((ctx, id, lhs), Empty split) -> 
-      let before, (x, _, ty), after = split_context split ctx in
-      let unify = 
-	match unify_type before ty with
-	| Some (unify, _) -> unify 
-	| None -> assert false
-      in
-	array_for_all (fun (_, _, _, _, x) -> x = None) unify
-	  
-  | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> 
-      let before, (id, _, ty), after = split_tele (pred rel) ctx in
-      let unify, indf' = Option.get (unify_type before ty) in
-	assert(indf = indf');
-	if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false
-	else
-	  let ok, splits = 
-	    Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> 
-	      match subst with
-	      | None -> acc
-	      | Some subst ->
-(* 		  let env' = push_rel_context ctx' (Global.env ()) in *)
-(* 		  let ctx_correct =  *)
-(* 		    ignore(check_context env' (subst_context subst ctxc)); *)
-(* 		    ignore(check_context env' (subst_context subst before)); *)
-(* 		    true *)
-(* 		  in  *)
-		  let newdelta = 
-		    subst_context subst (subst_rel_context 0 cstr 
-					    (lift_contextn ctxlen 0 after)) @ before in
-		  let liftpats = lift_pats ctxlen rel lhs in
-		  let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in
-		    (ok, (f, newdelta, newpats) :: splits))
-	      (true, []) unify
-	  in
-	  let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta 
-	    (constrs_of_pats ~inacc:false (Global.env ()) lhs) 
-	  in
-	  let t' = replace_vars subst t in
-	    ok && for_all 
-	      (fun (f, delta', pats') -> 
-		array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits
-	      
-let valid_tree (f, delta, t) tree = 
-  valid_splitting (f, delta, t, patvars_of_tele delta) tree
-
-let is_constructor c =
-  match kind_of_term (fst (decompose_app c)) with
-  | Construct _ -> true
-  | _ -> false
-
-let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) =
-  let rec find_split_pat curpat patc =
-    match patc with
-    | PRel _ -> None
-    | PCstr (f, args) ->
-	(match curpat with
-	| PCstr (f', args') when f = f' -> (* Already split at this level, continue *)
-	    find_split_pats args' args
-	| PRel i -> (* Split on i *) Some i
-	| PInac c when isRel c -> Some (destRel c)
-	| _ -> None)
-    | PInac _ -> None
-
-  and find_split_pats curpats patcs =
-    assert(List.length curpats = List.length patcs);
-    fold_left2 (fun acc -> 
-      match acc with
-      | None -> find_split_pat | _ -> fun _ _ -> acc)
-      None curpats patcs
-  in find_split_pats curpats patcs
-      
-open Pp
-open Termops
-
-let pr_constr_pat env c =
-  let pr = print_constr_env env c in
-    match kind_of_term c with
-    | App _ -> str "(" ++ pr ++ str ")"
-    | _ -> pr
-
-let pr_pat env c =
-  try 
-    let patc = constr_of_pat env c in
-      try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception"
-  with _ -> str"constr_of_pat raised an exception"
-    
-let pr_context env c =
-  let pr_decl (id,b,_) = 
-    let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in
-    let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in
-      idstr ++ bstr
-  in
-    prlist_with_sep pr_spc pr_decl (List.rev c)
-(*   Printer.pr_rel_context env c *)
-
-let pr_lhs env (delta, f, patcs) =
-  let env = push_rel_context delta env in
-  let ctx = pr_context env delta in
-    (if delta = [] then ctx else str "[" ++ ctx ++ str "]" ++ spc ())
-    ++ pr_id f ++ spc () ++ prlist_with_sep spc (pr_pat env) patcs
-
-let pr_rhs env = function
-  | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var)
-  | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs
-      
-let pr_clause env (lhs, rhs) =
-  pr_lhs env lhs ++ 
-    (let env' = push_rel_context (pi1 lhs) env in
-       pr_rhs env' rhs)
-    
-(* let pr_splitting env = function *)
-(*   | Compute cl -> str "Compute " ++ pr_clause env cl *)
-(*   | Split (lhs, n, indf, results, splits) -> *)
-
-(* let pr_unification_result (ctx, n, c, pat, subst) = *)
-  
-(*       unification_result array * splitting option array *)
-
-let pr_clauses env =
-  prlist_with_sep fnl (pr_clause env)
-
-let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) =
-  pattern_includes patcs patcs'
-    
-let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) =
-  pattern_matches patcs patcs'
-
-let rec split_on env var (delta, f, curpats as lhs) clauses =
-  let before, (id, _, ty), after = split_tele (pred var) delta in
-  let unify, indf = 
-    match unify_type before ty with 
-    | Some r -> r
-    | None -> assert false (* We decided... so it better be inductive *)
-  in
-  let clauses = ref clauses in
-  let splits = 
-    Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) ->
-      match s with
-      | None -> None
-      | Some s -> 
-	  (* ctx' |- s cstr, s cstrpat *)
-	  let newdelta =
-	    subst_context s (subst_rel_context 0 cstr 
-				(lift_contextn ctxlen 1 after)) @ ctx' in
-	  let liftpats = 
-	    (* delta |- curpats -> before; ctxc; id; after |- liftpats *)
-	    lift_pats ctxlen (succ var) curpats 
-	  in
-	  let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *)
-	    lift_pat (pred var) 1 cstrpat
-	  in
-	  let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *)
-	    subst_pats env var liftpat liftpats 
-	  in
-	  let lifts = (* before; ctxc |- s : newdelta ->
-			 before; ctxc; after |- lifts : newdelta ; after *)
-	    map (fun (k,(b,x)) -> (pred var + k, (b, lift (pred var) x))) s
-	  in
-	  let newpats = specialize_patterns lifts substpat in
-	  let newlhs = (newdelta, f, newpats) in
-	  let matching, rest = 
-	    fold_right (fun (lhs, rhs as clause) (matching, rest) -> 
-	      if lhs_includes newlhs lhs then
-		(clause :: matching, rest)
-	      else (matching, clause :: rest))
-	      !clauses ([], [])
-	  in
-	    clauses := rest;
-	    if matching = [] then (
-	      (* Try finding a splittable variable *)
-	      let (id, _) = 
-		fold_right (fun (id, _, ty as decl) (accid, ctx) -> 
-		  match accid with 
-		  | Some _ -> (accid, ctx)
-		  | None -> 
-		      match unify_type ctx ty with
-		      | Some (unify, indf) ->
-			  if array_for_all (fun (_, _, _, _, x) -> x = None) unify then
-			    (Some id, ctx)
-			  else (None, decl :: ctx)
-		      | None -> (None, decl :: ctx))
-		  newdelta (None, [])
-	      in 
-		match id with
-		| None ->
-		    errorlabstrm "deppat"
-	      	      (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++
-	      		  pr_lhs env newlhs)
-		| Some id -> 
-		    Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta))))
-	    ) else (
-	      let splitting = make_split_aux env newlhs matching in
-		Some splitting))
-      unify
-  in
-(*     if !clauses <> [] then *)
-(*       errorlabstrm "deppat" *)
-(* 	(str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *)
-    Split (lhs, var, indf, unify, splits)
-      
-and make_split_aux env lhs clauses =
-  let split = 
-    fold_left (fun acc (lhs', rhs) -> 
-      match acc with 
-      | None -> find_split lhs lhs'
-      | _ -> acc) None clauses
-  in 
-    match split with
-    | Some var -> split_on env var lhs clauses
-    | None ->
-	(match clauses with
-	| [] -> error "No clauses left"
-	| [(lhs', rhs)] ->
-	    (* No need to split anymore, fix the environments so that they are correctly aligned. *)
-	    (match lhs_matches lhs' lhs with
-	    | Some s ->
-		let s = map (fun (x, p) -> x, (true, constr_of_pat ~inacc:false env p)) s in
-		let rhs' = match rhs with
-		  | Program c -> Program (specialize_constr s c)
-		  | Empty i -> Empty (destRel (snd (assoc i s)))
-		in Compute ((pi1 lhs, pi2 lhs, specialize_patterns s (pi3 lhs')), rhs')
-	    | None -> anomaly "Non-matching clauses at a leaf of the splitting tree")
-	| _ ->
-	    errorlabstrm "make_split_aux"
-	      (str "Overlapping clauses:" ++ fnl () ++ pr_clauses env clauses))
-
-let make_split env (f, delta, t) clauses =
-  make_split_aux env (delta, f, patvars_of_tele delta) clauses
-    
-open Evd
-open Evarutil
-
-let lift_substitution n s = map (fun (k, x) -> (k + n, x)) s
-let map_substitution s t = map (subst_rel_subst 0 s) t
-
-let term_of_tree status isevar env (i, delta, ty) ann tree =
-(*   let envrec = match ann with *)
-(*     | None -> [] *)
-(*     | Some (loc, i) ->  *)
-(* 	let (n, t) = lookup_rel_id i delta in *)
-(* 	let t' = lift n t in *)
-	  
-	  
-(*   in *)
-  let rec aux = function
-    | Compute ((ctx, _, pats as lhs), Program rhs) -> 
-	let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in
-	let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in
-	  mkCast(body, DEFAULTcast, typ), typ
-
-    | Compute ((ctx, _, pats as lhs), Empty split) ->
-	let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in
-	let split = (Name (id_of_string "split"), 
-		    Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))),
-		    Lazy.force Class_tactics.coq_nat)
-	in
-	let ty' = it_mkProd_or_LetIn ty' ctx in
-	let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in
-	let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in
-	  term, ty'
-	    
-    | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> 
-	let before, decl, after = split_tele (pred rel) ctx in
-	let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in
-	let branches = 
-	  array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> 
-	    match split with
-	    | Some s -> aux s
-	    | None -> 
-		(* dead code, inversion will find a proof of False by splitting on the rel'th hyp *)
-		Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat)
-	    unif sp 
-	in
-	let branches_ctx =
-	  Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt))
-	    branches
-	in
-	let n, branches_lets = 
-	  Array.fold_left (fun (n, lets) (id, b, t) -> 
-	    (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets))
-	    (0, []) branches_ctx
-	in
-	let liftctx = lift_contextn (Array.length branches) 0 ctx in
-	let case =
-	  let ty = it_mkProd_or_LetIn ty' liftctx in
-	  let ty = it_mkLambda_or_LetIn ty branches_lets in
-	  let nbbranches = (Name (id_of_string "branches"), 
-			   Some (Class_tactics.coq_nat_of_int (length branches_lets)),
-			   Lazy.force Class_tactics.coq_nat)
-	  in
-	  let nbdiscr = (Name (id_of_string "target"), 
-			Some (Class_tactics.coq_nat_of_int (length before)),
-			Lazy.force Class_tactics.coq_nat)
-	  in
-	  let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in
-	  let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in
-	    term
-	in       
-	let casetyp = it_mkProd_or_LetIn ty' ctx in
-	  mkCast(case, DEFAULTcast, casetyp), casetyp
-
-  in aux tree
-
-open Topconstr
-open Constrintern
-open Decl_kinds
-
-type equation = constr_expr * (constr_expr, identifier located) rhs
-
-let locate_reference qid =
-  match Nametab.extended_locate qid with
-    | TrueGlobal ref -> true
-    | SyntacticDef kn -> true
-
-let is_global id =
-  try 
-    locate_reference (make_short_qualid id)
-  with Not_found -> 
-    false
-
-let is_freevar ids env x =
-  try
-    if Idset.mem x ids then false
-    else
-      try ignore(Environ.lookup_named x env) ; false
-      with _ -> not (is_global x)
-  with _ -> true
-  
-let ids_of_patc c ?(bound=Idset.empty) l = 
-  let found id bdvars l =
-    if not (is_freevar bdvars (Global.env ()) (snd id)) then l
-    else if List.exists (fun (_, id') -> id' = snd id) l then l 
-    else id :: l 
-  in
-  let rec aux bdvars l c = match c with
-    | CRef (Ident lid) -> found lid bdvars l
-    | CNotation (_, "{ _ : _ | _ }", ((CRef (Ident (_, id))) :: _, _)) when not (Idset.mem id bdvars) ->
-	fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c
-    | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c
-  in aux bound l c
-
-let interp_pats i isevar env impls pat sign recu =
-  let bound = Idset.singleton i in
-  let vars = ids_of_patc pat ~bound [] in
-  let varsctx, env' = 
-    fold_right (fun (loc, id) (ctx, env) ->
-      let decl =
-	let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in
-	  (Name id, None, ty) 
-      in
-	decl::ctx, push_rel decl env)
-      vars ([], env)
-  in
-  let pats =
-    let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in
-    let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in
-      match kind_of_term patt with
-      | App (m, args) -> 
-	  if not (eq_constr m (mkRel (succ (length varsctx)))) then
-	    user_err_loc (constr_loc pat, "interp_pats",
-			 str "Expecting a pattern for " ++ pr_id i)
-	  else Array.to_list args
-      | _ -> user_err_loc (constr_loc pat, "interp_pats",
-			  str "Error parsing pattern: unnexpected left-hand side")
-  in
-    isevar := nf_evar_defs !isevar;
-    (nf_rel_context_evar (Evd.evars_of !isevar) varsctx, 
-    nf_env_evar (Evd.evars_of !isevar) env',
-    rev_map (nf_evar (Evd.evars_of !isevar)) pats)
-      
-let interp_eqn i isevar env impls sign arity recu (pats, rhs) =
-  let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in
-  let rhs' = match rhs with
-    | Program p -> 
-	let ty = nf_isevar !isevar (substl patcs arity) in
-	  Program (interp_casted_constr_evars isevar env' ~impls p ty)
-    | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx))
-  in ((ctx, i, pats_of_constrs (rev patcs)), rhs')	
-
-open Entries
-
-open Tacmach
-open Tacexpr
-open Tactics
-open Tacticals
-
-let contrib_tactics_path =
-  make_dirpath (List.map id_of_string ["Equality";"Program";"Coq"])
-
-let tactics_tac s =
-  make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)
-    
-let equations_tac = lazy 
-  (Tacinterp.eval_tactic 
-      (TacArg(TacCall(dummy_loc, 
-		     ArgArg(dummy_loc, tactics_tac "equations"), []))))
-
-let define_by_eqs with_comp i (l,ann) t nt eqs =
-  let env = Global.env () in
-  let isevar = ref (create_evar_defs Evd.empty) in
-  let (env', sign), impls = interp_context_evars isevar env l in
-  let arity = interp_type_evars isevar env' t in
-  let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in
-  let arity = nf_evar (Evd.evars_of !isevar) arity in
-  let arity = 
-    if with_comp then
-      let compid = add_suffix i "_comp" in
-      let ce =
-	{ const_entry_body = it_mkLambda_or_LetIn arity sign;
-	  const_entry_type = None;
-	  const_entry_opaque = false;
-	  const_entry_boxed = false} 
-      in
-      let c =
-	Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition)
-      in mkApp (mkConst c, rel_vect 0 (length sign))
-    else arity
-  in
-  let env = Global.env () in
-  let ty = it_mkProd_or_LetIn arity sign in
-  let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in
-  let fixdecls = [(Name i, None, ty)] in
-  let fixenv = push_rel_context fixdecls env in
-  let equations = 
-    States.with_heavy_rollback (fun () -> 
-      Option.iter (Command.declare_interning_data data) nt;
-      map (interp_eqn i isevar fixenv data sign arity None) eqs) ()
-  in
-  let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in
-  let arity = nf_evar (Evd.evars_of !isevar) arity in
-  let prob = (i, sign, arity) in
-  let fixenv = nf_env_evar (Evd.evars_of !isevar) fixenv in
-  let fixdecls = nf_rel_context_evar (Evd.evars_of !isevar) fixdecls in
-    (*   let ce = check_evars fixenv Evd.empty !isevar in *)
-    (*   List.iter (function (_, _, Program rhs) -> ce rhs | _ -> ()) equations; *)
-  let is_recursive, env' =
-    let occur_eqn ((ctx, _, _), rhs) =
-      match rhs with
-      | Program c -> dependent (mkRel (succ (length ctx))) c
-      | _ -> false
-    in if exists occur_eqn equations then true, fixenv else false, env
-  in
-  let split = make_split env' prob equations in
-    (* if valid_tree prob split then *)
-  let status = (* if is_recursive then Expand else *) Define false in
-  let t, ty = term_of_tree status isevar env' prob ann split in
-  let undef = undefined_evars !isevar in
-  let t, ty = if is_recursive then 
-    (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls)
-    else t, ty
-  in
-  let obls, t', ty' = 
-    Eterm.eterm_obligations env i !isevar (Evd.evars_of undef) 0 ~status t ty
-  in
-    if is_recursive then
-      ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] 
-		~tactic:(Lazy.force equations_tac)
-		(Command.IsFixpoint [None, CStructRec]))
-    else
-      ignore(Subtac_obligations.add_definition
-		~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls)
-      
-module Gram = Pcoq.Gram
-module Vernac = Pcoq.Vernac_
-module Tactic = Pcoq.Tactic
-
-module DeppatGram =
-struct
-  let gec s = Gram.Entry.create ("Deppat."^s)
-
-  let deppat_equations : equation list Gram.Entry.e = gec "deppat_equations"
-
-  let binders_let2 : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e = gec "binders_let2"
-
-(*   let where_decl : decl_notation Gram.Entry.e = gec "where_decl" *)
-
-end
-
-open Rawterm
-open DeppatGram 
-open Util
-open Pcoq
-open Prim
-open Constr
-open G_vernac
-
-GEXTEND Gram
-  GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2;
- 
-  deppat_equations:
-    [ [ l = LIST1 equation SEP ";" -> l ] ]
-  ;
-
-  binders_let2:
-    [ [ l = binders_let_fixannot -> l ] ]
-  ;
-
-  equation:
-    [ [ c = Constr.lconstr; r=rhs -> (c, r) ] ]
-  ;
-
-  rhs:
-    [ [ ":=!"; id = identref -> Empty id
-      |":="; c = Constr.lconstr -> Program c
-    ] ]
-  ;
-  
-  END
-
-type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type
-
-let (wit_deppat_equations : Genarg.tlevel deppat_equations_argtype),
-  (globwit_deppat_equations : Genarg.glevel deppat_equations_argtype),
-  (rawwit_deppat_equations : Genarg.rlevel deppat_equations_argtype) =
-  Genarg.create_arg "deppat_equations"
-
-type 'a binders_let2_argtype = (local_binder list * (identifier located option * recursion_order_expr), 'a) Genarg.abstract_argument_type
-
-let (wit_binders_let2 : Genarg.tlevel binders_let2_argtype),
-  (globwit_binders_let2 : Genarg.glevel binders_let2_argtype),
-  (rawwit_binders_let2 : Genarg.rlevel binders_let2_argtype) =
-  Genarg.create_arg "binders_let2"
-
-type 'a decl_notation_argtype = (Vernacexpr.decl_notation, 'a) Genarg.abstract_argument_type
-
-let (wit_decl_notation : Genarg.tlevel decl_notation_argtype),
-  (globwit_decl_notation : Genarg.glevel decl_notation_argtype),
-  (rawwit_decl_notation : Genarg.rlevel decl_notation_argtype) =
-  Genarg.create_arg "decl_notation"
-
-let equations wc i l t nt eqs =
-  try define_by_eqs wc i l t nt eqs
-  with e -> msg (Cerrors.explain_exn e)
-
-VERNAC COMMAND EXTEND Define_equations
-| [ "Equations" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs)
-      decl_notation(nt) ] ->
-    [ equations true i l t nt eqs ]
-      END
-
-VERNAC COMMAND EXTEND Define_equations2
-| [ "Equations_nocomp" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs)
-      decl_notation(nt) ] ->
-    [ equations false i l t nt eqs ]
-END
-    
-let rec int_of_coq_nat c = 
-  match kind_of_term c with
-  | App (f, [| arg |]) -> succ (int_of_coq_nat arg)
-  | _ -> 0
-
-let solve_equations_goal destruct_tac tac gl =
-  let concl = pf_concl gl in
-  let targetn, branchesn, targ, brs, b =
-    match kind_of_term concl with
-    | LetIn (Name target, targ, _, b) ->
-	(match kind_of_term b with
-	| LetIn (Name branches, brs, _, b) ->
-	    target, branches, int_of_coq_nat targ, int_of_coq_nat brs, b
-	| _ -> error "Unnexpected goal")
-    | _ -> error "Unnexpected goal"
-  in
-  let branches, b = 
-    let rec aux n c =
-      if n = 0 then [], c
-      else match kind_of_term c with
-      | LetIn (Name id, br, brt, b) -> 
-	  let rest, b = aux (pred n) b in
-	    (id, br, brt) :: rest, b
-      | _ -> error "Unnexpected goal"
-    in aux brs b
-  in 
-  let ids = targetn :: branchesn :: map pi1 branches in
-  let cleantac = tclTHEN (intros_using ids) (thin ids) in
-  let dotac = tclDO (succ targ) intro in
-  let subtacs = 
-    tclTHENS destruct_tac
-      (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches)
-  in tclTHENLIST [cleantac ; dotac ; subtacs] gl
-    
-TACTIC EXTEND solve_equations
-  [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ]
-    END
-
-let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq
-let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
-
-let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
-let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
-
-let specialize_hyp id gl =
-  let env = pf_env gl in
-  let ty = pf_get_hyp_typ gl id in
-  let evars = ref (create_evar_defs (project gl)) in
-  let rec aux in_eqs acc ty =
-    match kind_of_term ty with
-    | Prod (_, t, b) -> 
-	(match kind_of_term t with
-	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
-	    let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in
-	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; x |]) in
-	      if e_conv env evars pt t then
-		aux true (mkApp (acc, [| p |])) (subst1 p b)
-	      else error "Unconvertible members of an homogeneous equality"
-	| App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) ->
-	    let pt = mkApp (Lazy.force coq_heq, [| eqty; x; eqty; x |]) in
-	    let p = mkApp (Lazy.force coq_heq_refl, [| eqty; x |]) in
-	      if e_conv env evars pt t then
-		aux true (mkApp (acc, [| p |])) (subst1 p b)
-	      else error "Unconvertible members of an heterogeneous equality"
-	| _ -> 
-	    if in_eqs then acc, in_eqs, ty
-	    else 
-	      let e = e_new_evar evars env t in
-		aux false (mkApp (acc, [| e |])) (subst1 e b))
-    | t -> acc, in_eqs, ty
-  in 
-  try 
-    let acc, worked, ty = aux false (mkVar id) ty in
-    let ty = Evarutil.nf_isevar !evars ty in
-      if worked then
-	tclTHENFIRST
-	  (fun g -> Tacmach.internal_cut true id ty g)
-	  (exact_no_check (Evarutil.nf_isevar !evars acc)) gl
-      else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl
-  with e -> tclFAIL 0 (Cerrors.explain_exn e) gl
-      
-TACTIC EXTEND specialize_hyp
-[ "specialize_hypothesis" constr(c) ] -> [ 
-  match kind_of_term c with
-  | Var id -> specialize_hyp id
-  | _ -> tclFAIL 0 (str "Not an hypothesis") ]
-END
diff --git a/contrib/subtac/g_eterm.ml4 b/contrib/subtac/g_eterm.ml4
deleted file mode 100644
index d9dd42cd..00000000
--- a/contrib/subtac/g_eterm.ml4
+++ /dev/null
@@ -1,27 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_eterm.ml4 8654 2006-03-22 15:36:58Z msozeau $ *)
-
-open Eterm
-
-TACTIC EXTEND eterm
-  [ "eterm" ] -> [ 
-    (fun gl ->
-       let evm = Tacmach.project gl and t = Tacmach.pf_concl gl in
-         Eterm.etermtac (evm, t) gl) ]
-END
diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml
deleted file mode 100644
index 9b692d85..00000000
--- a/contrib/subtac/subtac_classes.ml
+++ /dev/null
@@ -1,194 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: subtac_classes.ml 12187 2009-06-13 19:36:59Z msozeau $ i*)
-
-open Pretyping
-open Evd
-open Environ
-open Term
-open Rawterm
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-open Subtac_command
-open Typeclasses
-open Typeclasses_errors
-open Termops
-open Decl_kinds
-open Entries
-open Util
-
-module SPretyping = Subtac_pretyping.Pretyping
-
-let interp_binder_evars evdref env na t =
-  let t = Constrintern.intern_gen true (Evd.evars_of !evdref) env t in
-    SPretyping.understand_tcc_evars evdref env IsType t
-
-let interp_binders_evars isevars env avoid l =
-  List.fold_left
-    (fun (env, ids, params) ((loc, i), t) -> 
-      let n = Name i in
-      let t' = interp_binder_evars isevars env n t in
-      let d = (i,None,t') in
-	(push_named d env, i :: ids, d::params))
-    (env, avoid, []) l
-
-let interp_typeclass_context_evars isevars env avoid l =
-  List.fold_left
-    (fun (env, ids, params) (iid, bk, cl) -> 
-      let t' = interp_binder_evars isevars env (snd iid) cl in
-      let i = match snd iid with
-	| Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids
-	| Name id -> id
-      in
-      let d = (i,None,t') in
-	(push_named d env, i :: ids, d::params))
-    (env, avoid, []) l
-
-let interp_constrs_evars isevars env avoid l =
-  List.fold_left
-    (fun (env, ids, params) t -> 
-      let t' = interp_binder_evars isevars env Anonymous t in
-      let id = Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids in
-      let d = (id,None,t') in
-	(push_named d env, id :: ids, d::params))
-    (env, avoid, []) l
-    
-let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
-  SPretyping.understand_tcc_evars evdref env kind
-    (intern_gen (kind=IsType) ~impls (Evd.evars_of !evdref) env c)
-
-let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
-  interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
-
-let type_ctx_instance isevars env ctx inst subst =
-  List.fold_left2
-    (fun (subst, instctx) (na, _, t) ce ->
-      let t' = substl subst t in
-      let c = interp_casted_constr_evars isevars env ce t' in
-      isevars := resolve_typeclasses ~onlyargs:true ~fail:true env !isevars;
-      let d = na, Some c, t' in
-	c :: subst, d :: instctx)
-    (subst, []) (List.rev ctx) inst
-
-let type_class_instance_params isevars env id n ctx inst subst =
-  List.fold_left2
-    (fun (subst, instctx) (na, _, t) ce ->
-      let t' = replace_vars subst t in
-      let c = interp_casted_constr_evars isevars env ce t' in
-      let d = na, Some c, t' in
-	(na, c) :: subst, d :: instctx)
-    (subst, []) (List.rev ctx) inst
-
-let substitution_of_constrs ctx cstrs =
-  List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx []
-
-let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri =
-  let env = Global.env() in
-  let isevars = ref (Evd.create_evar_defs Evd.empty) in
-  let tclass =
-    match bk with
-    | Implicit ->
-	Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *)
-	  ~allow_partial:false (fun avoid (clname, (id, _, t)) -> 
-	    match clname with 
-	    | Some (cl, b) -> 
-		let t = 
-		  if b then 
-		    let _k = class_info cl in
-		      CHole (Util.dummy_loc, Some Evd.InternalHole)
-		  else CHole (Util.dummy_loc, None)
-		in t, avoid
-	    | None -> failwith ("new instance: under-applied typeclass"))
-	  cl
-      | Explicit -> cl
-  in
-  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
-  let k, ctx', imps, subst = 
-    let c = Command.generalize_constr_expr tclass ctx in
-    let c', imps = interp_type_evars_impls ~evdref:isevars env c in
-    let ctx, c = Sign.decompose_prod_assum c' in
-    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in
-      cl, ctx, imps, (List.rev args)
-  in
-  let id = 
-    match snd instid with
-    | Name id -> 
-	let sp = Lib.make_path id in
-	  if Nametab.exists_cci sp then
-	    errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists");
-	  id
-    | Anonymous -> 
-	let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
-	  Termops.next_global_ident_away false i (Termops.ids_of_context env)
-  in
-  let env' = push_rel_context ctx' env in
-  isevars := Evarutil.nf_evar_defs !isevars;
-  isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars;
-  let sigma = Evd.evars_of !isevars in
-  let subst = List.map (Evarutil.nf_evar sigma) subst in
-  let subst = 
-    let props = 
-      match props with
-      | CRecord (loc, _, fs) -> 
-	  if List.length fs > List.length k.cl_props then 
-	    Classes.mismatched_props env' (List.map snd fs) k.cl_props;
-	  fs
-      | _ -> 
-	  if List.length k.cl_props <> 1 then 
-	    errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body")
-	  else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props]
-    in
-      match k.cl_props with 
-      | [(na,b,ty)] -> 
-	  let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in
-	  let ty' = substl subst ty in
-	  let c = interp_casted_constr_evars isevars env' term ty' in
-	    c :: subst
-      | _ ->
-	  let props, rest = 
-	    List.fold_left
-	      (fun (props, rest) (id,_,_) -> 
-		try 
-		  let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in
-		  let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in
-		    Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs);
-		    c :: props, rest'
-		with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest)
-	      ([], props) k.cl_props
-	  in
-	    if rest <> [] then 
-	      unbound_method env' k.cl_impl (fst (List.hd rest))
-	    else
-	      fst (type_ctx_instance isevars env' k.cl_props props subst)
-  in
-  let subst = List.fold_left2 
-    (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
-    [] subst (k.cl_props @ snd k.cl_context)
-  in
-  let inst_constr, ty_constr = instance_constructor k subst in
-  isevars := Evarutil.nf_evar_defs !isevars;
-  let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx')
-  and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') 
-  in
-    isevars := undefined_evars !isevars;
-    Evarutil.check_evars env Evd.empty !isevars termtype;
-    let hook vis gr = 
-      let cst = match gr with ConstRef kn -> kn | _ -> assert false in
-      let inst = Typeclasses.new_instance k pri global cst in
-	Impargs.declare_manual_implicits false gr ~enriching:false imps;
-	Typeclasses.add_instance inst
-    in
-    let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in
-    let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in
-      id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls
-	
diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml
deleted file mode 100644
index c8c7ff72..00000000
--- a/contrib/subtac/subtac_command.ml
+++ /dev/null
@@ -1,466 +0,0 @@
-open Closure
-open RedFlags
-open Declarations
-open Entries
-open Dyn
-open Libobject
-open Pattern
-open Matching
-open Pp
-open Rawterm
-open Sign
-open Tacred
-open Util
-open Names
-open Nameops
-open Libnames
-open Nametab
-open Pfedit
-open Proof_type
-open Refiner
-open Tacmach
-open Tactic_debug
-open Topconstr
-open Term
-open Termops
-open Tacexpr
-open Safe_typing
-open Typing
-open Hiddentac
-open Genarg
-open Decl_kinds
-open Mod_subst
-open Printer
-open Inductiveops
-open Syntax_def
-open Environ
-open Tactics
-open Tacticals
-open Tacinterp
-open Vernacexpr
-open Notation
-open Evd
-open Evarutil
-
-module SPretyping = Subtac_pretyping.Pretyping
-open Subtac_utils
-open Pretyping
-open Subtac_obligations
-
-(*********************************************************************)
-(* Functions to parse and interpret constructions *)
-
-let evar_nf isevars c =
-  isevars := Evarutil.nf_evar_defs !isevars;
-  Evarutil.nf_isevar !isevars c
-
-let interp_gen kind isevars env 
-               ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
-               c =
-  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars (Evd.evars_of !isevars) env c in
-  let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in
-    evar_nf isevars c'
-
-let interp_constr isevars env c =
-  interp_gen (OfType None) isevars env c 
-
-let interp_type_evars isevars env ?(impls=([],[])) c =
-  interp_gen IsType isevars env ~impls c
-
-let interp_casted_constr isevars env ?(impls=([],[])) c typ =
-  interp_gen (OfType (Some typ)) isevars env ~impls c 
-
-let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ =
-  interp_gen (OfType (Some typ)) isevars env ~impls c 
-
-let interp_open_constr isevars env c =
-    msgnl (str "Pretyping " ++ my_print_constr_expr c);
-  let c = Constrintern.intern_constr (Evd.evars_of !isevars) env c in
-  let c' = SPretyping.pretype_gen isevars env ([], []) (OfType None) c in
-    evar_nf isevars c'
-
-let interp_constr_judgment isevars env c =
-  let j = 
-    SPretyping.understand_judgment_tcc isevars env
-      (Constrintern.intern_constr (Evd.evars_of !isevars) env c) 
-  in
-    { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
-
-let locate_if_isevar loc na = function
-  | RHole _ -> 
-      (try match na with
-	| Name id ->  Reserve.find_reserved_type id
-	| Anonymous -> raise Not_found 
-      with Not_found -> RHole (loc, Evd.BinderType na))
-  | x -> x
-
-let interp_binder sigma env na t =
-  let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in
-    SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t)
-
-let interp_context_evars evdref env params = 
-  let bl = Constrintern.intern_context false (Evd.evars_of !evdref) env params in
-  let (env, par, _, impls) =
-    List.fold_left
-      (fun (env,params,n,impls) (na, k, b, t) ->
-	match b with
-	    None ->
-	      let t' = locate_if_isevar (loc_of_rawconstr t) na t in
-	      let t = SPretyping.understand_tcc_evars evdref env IsType t' in
-	      let d = (na,None,t) in
-	      let impls = 
-		if k = Implicit then
-		  let na = match na with Name n -> Some n | Anonymous -> None in
-		    (ExplByPos (n, na), (true, true)) :: impls
-		else impls
-	      in
-		(push_rel d env, d::params, succ n, impls)
-	  | Some b ->
-	      let c = SPretyping.understand_judgment_tcc evdref env b in
-	      let d = (na, Some c.uj_val, c.uj_type) in
-		(push_rel d env,d::params, succ n, impls))
-      (env,[],1,[]) (List.rev bl)
-  in (env, par), impls
-
-(* try to find non recursive definitions *)
-
-let list_chop_hd i l = match list_chop i l with
-  | (l1,x::l2) -> (l1,x,l2)
-  | (x :: [], l2) -> ([], x, [])
-  | _ -> assert(false)
-
-let collect_non_rec env = 
-  let rec searchrec lnonrec lnamerec ldefrec larrec nrec = 
-    try
-      let i = 
-        list_try_find_i
-          (fun i f ->
-             if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
-             then i else failwith "try_find_i")
-          0 lnamerec 
-      in
-      let (lf1,f,lf2) = list_chop_hd i lnamerec in
-      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
-      let (lar1,ar,lar2) = list_chop_hd i larrec in
-      let newlnv = 
-	try 
-	  match list_chop i nrec with 
-            | (lnv1,_::lnv2) -> (lnv1@lnv2)
-	    | _ -> [] (* nrec=[] for cofixpoints *)
-        with Failure "list_chop" -> []
-      in 
-      searchrec ((f,def,ar)::lnonrec) 
-	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
-    with Failure "try_find_i" -> 
-      (List.rev lnonrec,
-       (Array.of_list lnamerec, Array.of_list ldefrec,
-        Array.of_list larrec, Array.of_list nrec))
-  in 
-  searchrec [] 
-
-let list_of_local_binders l = 
-  let rec aux acc = function
-      Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
-    | Topconstr.LocalRawAssum (nl, k, c) :: tl -> 
-	aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
-    | [] -> List.rev acc
-  in aux [] l
-
-let lift_binders k n l =
-  let rec aux n = function
-    | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
-    | [] -> []
-  in aux n l
-
-let rec gen_rels = function
-    0 -> []
-  | n -> mkRel n :: gen_rels (pred n)
-
-let split_args n rel = match list_chop ((List.length rel) - n) rel with
-    (l1, x :: l2) -> l1, x, l2
-  | _ -> assert(false)
-
-let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
-  Coqlib.check_required_library ["Coq";"Program";"Wf"];
-  let sigma = Evd.empty in
-  let isevars = ref (Evd.create_evar_defs sigma) in
-  let env = Global.env() in 
-  let pr c = my_print_constr env c in
-  let prr = Printer.pr_rel_context env in
-  let _prn = Printer.pr_named_context env in
-  let _pr_rel env = Printer.pr_rel_context env in
-(*   let _ =  *)
-(*     try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++  *)
-(* 		 Ppconstr.pr_binders bl ++ str " : " ++  *)
-(* 		 Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ *)
-(* 		 Ppconstr.pr_constr_expr body) *)
-(*     with _ -> () *)
-    (*   in *)
-  let (env', binders_rel), impls = interp_context_evars isevars env bl in
-  let after, ((argname, _, argtyp) as arg), before = 
-    let idx = list_index (Name (snd n)) (List.rev_map (fun (na, _, _) -> na) binders_rel) in
-      split_args idx binders_rel in
-  let before_length, after_length = List.length before, List.length after in
-  let argid = match argname with Name n -> n | _ -> assert(false) in
-  let liftafter = lift_binders 1 after_length after in
-  let envwf = push_rel_context before env in
-  let wf_rel, wf_rel_fun, measure_fn = 
-    let rconstr_body, rconstr = 
-      let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in
-       let env = push_rel_context [arg] envwf in
-       let capp = interp_constr isevars env app in
- 	 capp, mkLambda (argname, argtyp, capp)
-     in
-      trace (str"rconstr_body: " ++ pr rconstr_body);
-       if measure then
- 	let lt_rel = constr_of_global (Lazy.force lt_ref) in
- 	let name s = Name (id_of_string s) in
- 	let wf_rel_fun lift x y = (* lift to before_env *)
-	  trace (str"lifter rconstr_body:" ++ pr (liftn lift 2 rconstr_body));
- 	  mkApp (lt_rel, [| subst1 x (liftn lift 2 rconstr_body); 
- 			    subst1 y (liftn lift 2 rconstr_body) |])
-	in
- 	let wf_rel = 
- 	  mkLambda (name "x", argtyp,
- 		    mkLambda (name "y", lift 1 argtyp,
- 			      wf_rel_fun 0 (mkRel 2) (mkRel 1)))
- 	in
- 	  wf_rel, wf_rel_fun , Some rconstr
-       else rconstr, (fun lift x y -> mkApp (rconstr, [|x; y|])), None
-  in
-  let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |])
-  in
-  let argid' = id_of_string (string_of_id argid ^ "'") in
-  let wfarg len = (Name argid', None,
-  		   mkSubset (Name argid') (lift len argtyp) 
-		     (wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1))))
-  in
-  let top_bl = after @ (arg :: before) in
-  let top_env = push_rel_context top_bl env in
-  let top_arity = interp_type_evars isevars top_env arityc in
-  let intern_bl = wfarg 1 :: arg :: before in
-  let _intern_env = push_rel_context intern_bl env in
-  let proj = (Lazy.force sig_).Coqlib.proj1 in
-  let projection = 
-    mkApp (proj, [| argtyp ;
-		    (mkLambda (Name argid', argtyp,
-			       (wf_rel_fun 1 (mkRel 1) (mkRel 3)))) ;
-		    mkRel 1
-		 |])
-  in
-  let intern_arity = it_mkProd_or_LetIn top_arity after in
-  (* Intern arity is in top_env = arg :: before *)
-  let intern_arity = liftn 2 2 intern_arity in
-(*     trace (str "After lifting arity: " ++  *)
-(* 	      my_print_constr (push_rel (Name argid', None, lift 2 argtyp) intern_env) *)
-(* 	      intern_arity); *)
-  (* arity is now in something :: wfarg :: arg :: before 
-     where what refered to arg now refers to something *)
-  let intern_arity = substl [projection] intern_arity in
-  (* substitute the projection of wfarg for something *)
-  let intern_before_env = push_rel_context before env in
-  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
-  let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
-  let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in
-  let fun_env = push_rel_context fun_bl intern_before_env in
-  let fun_arity = interp_type_evars isevars fun_env arityc in
-  let intern_body = interp_casted_constr isevars fun_env body fun_arity in
-  let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in
-  let _ =
-    try trace ((* str "Fun bl: " ++ prr fun_bl ++ spc () ++ *)
-		 str "Intern bl" ++ prr intern_bl ++ spc ())
-(* 		 str "Top bl" ++ prr top_bl ++ spc () ++ *)
-(* 		 str "Intern arity: " ++ pr intern_arity ++ *)
-(* 		 str "Top arity: " ++ pr top_arity ++ spc () ++ *)
-(* 		   str "Intern body " ++ pr intern_body_lam) *)
-    with _ -> ()
-  in
-  let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in
-    (* Lift to get to constant arguments *)
-  let lift_cst = List.length after + 1 in
-  let fix_def =
-    match measure_fn with
-	None ->
-	  mkApp (constr_of_global (Lazy.force fix_sub_ref), 
-		 [| argtyp ;
-		    wf_rel ;
-		    make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
-		    lift lift_cst prop ;
-		    lift lift_cst intern_body_lam |])
-      | Some f ->
-	  mkApp (constr_of_global (Lazy.force fix_measure_sub_ref), 
-		[| lift lift_cst argtyp ; 
-		   lift lift_cst f ;
-		   lift lift_cst prop ;
-		   lift lift_cst intern_body_lam |])
-  in
-  let def_appl = applist (fix_def, gen_rels (after_length + 1)) in
-  let def = it_mkLambda_or_LetIn def_appl binders_rel in
-  let typ = it_mkProd_or_LetIn top_arity binders_rel in
-  let fullcoqc = Evarutil.nf_isevar !isevars def in
-  let fullctyp = Evarutil.nf_isevar !isevars typ in
-  let evm = evars_of_term (Evd.evars_of !isevars) Evd.empty fullctyp in
-  let evm = evars_of_term (Evd.evars_of !isevars) evm fullcoqc in
-  let evm = non_instanciated_map env isevars evm in
-  let evars, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in
-    Subtac_obligations.add_definition recname evars_def evars_typ ~implicits:impls evars
-
-let nf_evar_context isevars ctx = 
-  List.map (fun (n, b, t) -> 
-    (n, Option.map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx
-    
-let interp_fix_context evdref env fix =
-  interp_context_evars evdref env fix.Command.fix_binders
-
-let interp_fix_ccl evdref (env,_) fix =
-  interp_type_evars evdref env fix.Command.fix_type
-
-let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
-  let env = push_rel_context ctx env_rec in
-  let body = interp_casted_constr_evars evdref env ~impls fix.Command.fix_body ccl in
-  it_mkLambda_or_LetIn body ctx
-
-let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
-
-let prepare_recursive_declaration fixnames fixtypes fixdefs =
-  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
-  let names = List.map (fun id -> Name id) fixnames in
-  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
-
-let rel_index n ctx = 
-  list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
-
-let rec unfold f b =
-  match f b with
-    | Some (x, b') -> x :: unfold f b'
-    | None -> []
-
-let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
-  match n with 
-  | Some (loc, n) -> [rel_index n fixctx]
-  | None -> 
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally 
-         doesn't seem to worth the effort (except for huge mutual 
-	 fixpoints ?) *)
-      let len = List.length fixctx in
-	unfold (function x when x = len -> None 
-	  | n -> Some (n, succ n)) 0
-
-let push_named_context = List.fold_right push_named
-
-let check_evars env initial_sigma evd c =
-  let sigma = evars_of evd in
-  let c = nf_evar sigma c in
-  let rec proc_rec c =
-    match kind_of_term c with
-      | Evar (evk,args) ->
-          assert (Evd.mem sigma evk);
-	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk evd in
-	      (match k with
-	      | QuestionMark _ -> ()
-	      | _ ->
-		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
-		    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None)
-      | _ -> iter_constr proc_rec c
-  in proc_rec c
-
-let interp_recursive fixkind l boxed =
-  let env = Global.env() in
-  let fixl, ntnl = List.split l in
-  let kind = if fixkind <> Command.IsCoFixpoint then Fixpoint else CoFixpoint in
-  let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
-
-  (* Interp arities allowing for unresolved types *)
-  let evdref = ref (Evd.create_evar_defs Evd.empty) in
-  let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in
-  let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
-  let fixtypes = List.map2 build_fix_type fixctxs fixccls in
-  let rec_sign = 
-    List.fold_left2 (fun env id t -> (id,None,t) :: env)
-      [] fixnames fixtypes
-  in
-  let env_rec = push_named_context rec_sign env in
-
-  (* Get interpretation metadatas *)
-  let impls = Command.compute_interning_datas env Constrintern.Recursive [] fixnames fixtypes fiximps in
-  let notations = List.fold_right Option.List.cons ntnl [] in
-
-  (* Interp bodies with rollback because temp use of notations/implicit *)
-  let fixdefs = 
-    States.with_state_protection (fun () -> 
-      List.iter (Command.declare_interning_data impls) notations;
-      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
-      () in
-
-  (* Instantiate evars and check all are resolved *)
-  let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
-  let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in
-  let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in
-  let rec_sign = nf_named_context_evar (evars_of evd) rec_sign in
-    
-  let recdefs = List.length rec_sign in
-  List.iter (check_evars env_rec Evd.empty evd) fixdefs;
-  List.iter (check_evars env Evd.empty evd) fixtypes;
-  Command.check_mutuality env kind (List.combine fixnames fixdefs);
-
-  (* Russell-specific code *)
-
-  (* Get the interesting evars, those that were not instanciated *)
-  let isevars = Evd.undefined_evars evd in
-  let evm = Evd.evars_of isevars in
-  (* Solve remaining evars *)
-  let rec collect_evars id def typ imps = 
-      (* Generalize by the recursive prototypes  *)
-    let def = 
-      Termops.it_mkNamedLambda_or_LetIn def rec_sign
-    and typ =
-      Termops.it_mkNamedProd_or_LetIn typ rec_sign
-    in
-    let evm' = Subtac_utils.evars_of_term evm Evd.empty def in
-    let evm' = Subtac_utils.evars_of_term evm evm' typ in
-    let evars, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in
-      (id, def, typ, imps, evars)
-  in 
-  let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
-    (match fixkind with
-      | Command.IsFixpoint wfl ->
-	  let possible_indexes =
-	    list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
-	  let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), 
-	    Array.of_list fixtypes, 
-	    Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
-	  in
-	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
-	    list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l
-      | Command.IsCoFixpoint -> ());
-    Subtac_obligations.add_mutual_definitions defs notations fixkind
-
-let out_n = function
-    Some n -> n
-  | None -> raise Not_found
-
-let build_recursive l b =
-  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
-    match g, l with
-	[(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
-	  ignore(build_wellfounded (id, out_n n, bl, typ, def) r false ntn false)
-
-      | [(n, CMeasureRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
-	  ignore(build_wellfounded (id, out_n n, bl, typ, def) r true ntn false)
-
-      | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
-	  let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> 
-	    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l 
-	  in interp_recursive (Command.IsFixpoint g) fixl b
-      | _, _ -> 
-	  errorlabstrm "Subtac_command.build_recursive"
-	    (str "Well-founded fixpoints not allowed in mutually recursive blocks")
-
-let build_corecursive l b =
-  let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> 
-    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn))
-    l in
-  interp_recursive Command.IsCoFixpoint fixl b
diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli
deleted file mode 100644
index 3a6a351b..00000000
--- a/contrib/subtac/subtac_command.mli
+++ /dev/null
@@ -1,50 +0,0 @@
-open Pretyping
-open Evd
-open Environ
-open Term
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-
-val interp_gen :
-  typing_constraint ->
-  evar_defs ref ->
-  env ->
-  ?impls:full_implicits_env ->
-  ?allow_patvar:bool ->
-  ?ltacvars:ltac_sign ->
-  constr_expr -> constr
-val interp_constr :
-  evar_defs ref ->
-  env -> constr_expr -> constr
-val interp_type_evars :
-  evar_defs ref ->
-  env ->
-  ?impls:full_implicits_env ->
-  constr_expr -> constr
-val interp_casted_constr_evars :
-  evar_defs ref ->
-  env ->
-  ?impls:full_implicits_env ->
-  constr_expr -> types -> constr
-val interp_open_constr :
-  evar_defs ref -> env -> constr_expr -> constr
-val interp_constr_judgment :
-  evar_defs ref ->
-  env ->
-  constr_expr -> unsafe_judgment
-val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
-
-val interp_binder :     Evd.evar_defs ref ->
-    Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
-
-
-
-val build_recursive :
-  (fixpoint_expr * decl_notation) list -> bool -> unit
-
-val build_corecursive :
-  (cofixpoint_expr * decl_notation) list -> bool -> unit
diff --git a/coq-win32.itarget b/coq-win32.itarget
new file mode 100644
index 00000000..9e2c7a2b
--- /dev/null
+++ b/coq-win32.itarget
@@ -0,0 +1,2 @@
+binariesopt
+plugins/pluginsdyn.otarget
diff --git a/coq.itarget b/coq.itarget
new file mode 100644
index 00000000..7488f421
--- /dev/null
+++ b/coq.itarget
@@ -0,0 +1,3 @@
+binaries
+plugins/plugins.otarget
+theories/theories.otarget
diff --git a/dev/base_include b/dev/base_include
index 711dcb2a..3a31230f 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -53,6 +53,7 @@
 open Names
 open Term
 open Typeops
+open Term_typing
 open Univ
 open Inductive
 open Indtypes
@@ -89,6 +90,7 @@ open Evarutil
 open Tacred
 open Evd
 open Termops
+open Namegen
 open Indrec
 open Typing
 open Inductiveops
@@ -105,6 +107,8 @@ open Ppextend
 open Reserve
 open Syntax_def
 open Topconstr
+open Prettyp
+open Search
 
 open Clenvtac
 open Evar_refiner
@@ -137,10 +141,15 @@ open Refine
 open Tacinterp
 open Tacticals
 open Tactics
+open Eqschemes
 
 open Cerrors
 open Class
 open Command
+open Indschemes
+open Ind_tables
+open Auto_ind_decl
+open Lemmas
 open Coqinit
 open Coqtop
 open Discharge
@@ -180,7 +189,7 @@ let constr_of_string s =
 open Declarations;;
 
 let constbody_of_string s =
-  let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_sp (path_of_string s))) in
+  let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in
   Option.get b.const_body;;
 
 (* Get the current goal *)
diff --git a/dev/db b/dev/db
index 81878570..22b76605 100644
--- a/dev/db
+++ b/dev/db
@@ -3,14 +3,15 @@ load_printer "printers.cma"
 
 install_printer Top_printers.ppid
 install_printer Top_printers.ppidset
+install_printer Top_printers.ppevarsubst
 install_printer Top_printers.ppintset
 install_printer Top_printers.pplab
-install_printer Top_printers.ppmsid
 install_printer Top_printers.ppmbid
 install_printer Top_printers.ppdir
 install_printer Top_printers.ppmp
 install_printer Top_printers.ppkn
 install_printer Top_printers.ppcon
+install_printer Top_printers.ppmind
 install_printer Top_printers.ppsp
 install_printer Top_printers.ppqualid
 install_printer Top_printers.ppclindex
@@ -31,7 +32,6 @@ install_printer Top_printers.ppgoal
 install_printer Top_printers.ppsigmagoal
 install_printer Top_printers.pproof
 install_printer Top_printers.ppmetas
-install_printer Top_printers.ppevd
 install_printer Top_printers.ppevm
 install_printer Top_printers.ppclenv
 
@@ -39,5 +39,5 @@ install_printer Top_printers.pptac
 install_printer Top_printers.ppobj
 install_printer Top_printers.pploc
 install_printer Top_printers.prsubst
-                                                  
-
+install_printer Top_printers.prdelta
+install_printer Top_printers.ppconstr
diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt
index c825f088..d4014303 100644
--- a/dev/doc/build-system.dev.txt
+++ b/dev/doc/build-system.dev.txt
@@ -12,6 +12,7 @@ see build-system.txt .
 happy only. To ensure they are not used for compilation, they contain
 invalid OCaml.
 
+
 multi-stage build
 -----------------
 
@@ -37,6 +38,7 @@ Le Makefile a été séparé en plusieurs fichiers :
 The build needs to be cut in stages because make will not take into
 account one include when making another include.
 
+
 Parallélisation
 ---------------
 
@@ -68,3 +70,62 @@ d'étape pour chaque fichier:
 
 Mais seule la première est gérée explicitement, la seconde est
 implicite.
+
+
+FIND_VCS_CLAUSE
+---------------
+
+The recommended style of using FIND_VCS_CLAUSE is for example
+
+ find . $(FIND_VCS_CLAUSE) '(' -name '*.example' ')' -print
+ find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -or -name '*.foo' ')' -print
+
+1)
+The parentheses even in the one-criteria case is so that if one adds
+other conditions, e.g. change the first example to the second
+
+ find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -and -not -name '*.bak.example' ')' -print
+
+one is not tempted to write
+
+ find . $(FIND_VCS_CLAUSE) -name '*.example' -and -not -name '*.bak.example' -print
+
+because this will not necessarily work as expected; $(FIND_VCS_CLAUSE)
+ends with an -or, and how it combines with what comes later depends on
+operator precedence and all that. Much safer to override it with
+parentheses.
+
+In short, it protects against the -or one doesn't see.
+
+2)
+As to the -print at the end, yes it is necessary. Here's why.
+
+You are used to write:
+ find . -name '*.example'
+and it works fine. But the following will not:
+ find . $(FIND_VCS_CLAUSE) -name '*.example'
+it will also list things directly matched by FIND_VCS_CLAUSE
+(directories we want to prune, in which we don't want to find
+anything). C'est subtil... Il y a effectivement un -print implicite à
+la fin, qui fait que la commande habituelle sans print fonctionne
+bien, mais dès que l'on introduit d'autres commandes dans le lot (le
+-prune de FIND_VCS_CLAUSE), ça se corse à cause d'histoires de
+parenthèses du -print implicite par rapport au parenthésage dans la
+forme recommandée d'utilisation:
+
+Si on explicite le -print et les parenthèses implicites, cela devient:
+
+find . '(' '(' '(' -name .git -or -name debian ')' -prune ')' -or \
+           '(' -name '*.example' ')'
+       ')'
+       -print
+
+Le print agit TOUT ce qui précède, soit sur ce qui matche "'(' -name
+.git -or -name debian ')'" ET sur ce qui matche "'(' -name '*.example' ')'".
+
+alors qu'ajouter le print explicite change cela en
+
+find . '(' '(' -name .git -or -name debian ')' -prune ')' -or \
+       '(' '(' -name '*.example' ')' -print ')'
+
+Le print n'agit plus que sur ce qui matche "'(' -name '*.example' ')'"
diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt
index cae948a0..91255202 100644
--- a/dev/doc/changes.txt
+++ b/dev/doc/changes.txt
@@ -1,4 +1,114 @@
 =========================================
+= CHANGES BETWEEN COQ V8.2 AND COQ V8.3 =
+=========================================
+
+** Light cleaning in evarutil.ml **
+
+whd_castappevar is now whd_head_evar
+obsolete whd_ise disappears
+
+** Semantical change of h_induction_destruct **
+
+Warning, the order of the isrec and evar_flag was inconsistent and has
+been permuted. Tactic induction_destruct in tactics.ml is unchanged.
+
+** Internal tactics renamed
+
+There is no more difference between bindings and ebindings. The
+following tactics are therefore renamed
+
+apply_with_ebindings_gen -> apply_with_bindings_gen
+left_with_ebindings -> left_with_bindings
+right_with_ebindings -> right_with_bindings
+split_with_ebindings -> split_with_bindings
+
+and the following tactics are removed
+
+apply_with_ebindings (use instead apply_with_bindings)
+eapply_with_ebindings (use instead eapply_with_bindings)
+
+** Obsolete functions in typing.ml
+
+For mtype_of, msort_of, mcheck, now use type_of, sort_of, check
+
+** Renaming functions renamed
+
+concrete_name -> compute_displayed_name_in
+concrete_let_name -> compute_displayed_let_name_in
+rename_rename_bound_var -> rename_bound_vars_as_displayed
+lookup_name_as_renamed -> lookup_name_as_displayed
+next_global_ident_away true -> next_ident_away_in_goal
+next_global_ident_away false -> next_global_ident_away
+
+** Cleaning in commmand.ml
+
+Functions about starting/ending a lemma are in lemmas.ml
+Functions about inductive schemes are in indschemes.ml
+
+Functions renamed:
+
+declare_one_assumption -> declare_assumption
+declare_assumption -> declare_assumptions
+Command.syntax_definition -> Metasyntax.add_syntactic_definition
+declare_interning_data merged with add_notation_interpretation
+compute_interning_datas -> compute_full_internalization_env
+implicits_env -> internalization_env
+full_implicits_env -> full_internalization_env
+build_mutual -> do_mutual_inductive
+build_recursive -> do_fixpoint
+build_corecursive -> do_cofixpoint
+build_induction_scheme -> build_mutual_induction_scheme
+build_indrec -> build_induction_scheme
+instantiate_type_indrec_scheme -> weaken_sort_scheme
+instantiate_indrec_scheme -> modify_sort_scheme
+make_case_dep, make_case_nodep -> build_case_analysis_scheme
+make_case_gen -> build_case_analysis_scheme_default
+
+Types:
+
+decl_notation -> decl_notation option
+
+** Cleaning in libnames/nametab interfaces
+
+Functions:
+
+dirpath_prefix -> pop_dirpath
+extract_dirpath_prefix pop_dirpath_n
+extend_dirpath -> add_dirpath_suffix
+qualid_of_sp -> qualid_of_path
+pr_sp -> pr_path
+make_short_qualid -> qualid_of_ident
+sp_of_syntactic_definition -> path_of_syntactic_definition 
+sp_of_global -> path_of_global
+id_of_global -> basename_of_global
+absolute_reference -> global_of_path
+locate_syntactic_definition -> locate_syndef
+path_of_syntactic_definition -> path_of_syndef
+push_syntactic_definition -> push_syndef
+
+Types:
+
+section_path -> full_path
+
+** Cleaning in parsing extensions (commit 12108)
+
+Many moves and renamings, one new file (Extrawit, that contains wit_tactic).
+
+** Cleaning in tactical.mli
+
+tclLAST_HYP -> onLastHyp
+tclLAST_DECL -> onLastDecl
+tclLAST_NHYPS -> onNLastHypsId
+tclNTH_DECL -> onNthDecl
+tclNTH_HYP -> onNthHyp
+onLastHyp -> onLastHypId
+onNLastHyps -> onNLastDecls
+onClauses -> onClause
+allClauses -> allHypsAndConcl
+
++ removal of various unused combinators on type "clause"
+
+=========================================
 = CHANGES BETWEEN COQ V8.1 AND COQ V8.2 =
 =========================================
 
@@ -8,7 +118,8 @@ A few differences in Coq ML interfaces between Coq V8.1 and V8.2
 ** Datatypes
 
 List of occurrences moved from "int list" to "Termops.occurrences" (an
-alias to "bool * int list").
+  alias to "bool * int list")
+ETIdent renamed to ETName
 
 ** Functions
 
@@ -325,7 +436,7 @@ Proof_type: subproof field in type proof_tree glued with the ref field
 
 Tacmach: no more echo from functions of module Refiner
 
-Files contrib/*/g_*.ml4 take the place of files contrib/*/*.v.
+Files plugins/*/g_*.ml4 take the place of files plugins/*/*.v.
 Files parsing/{vernac,tac}extend.ml{4,i} implements TACTIC EXTEND andd
   VERNAC COMMAND EXTEND macros
 File syntax/PPTactic.v moved to parsing/pptactic.ml
diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.txt
index e5c83139..50b3b45c 100644
--- a/dev/doc/debugging.txt
+++ b/dev/doc/debugging.txt
@@ -4,8 +4,8 @@ Debugging from Coq toplevel using Caml trace mechanism
   1. Launch bytecode version of Coq (coqtop.byte or coqtop -byte)
   2. Access Ocaml toplevel using vernacular command 'Drop.'
   3. Install load paths and pretty printers for terms, idents, ... using
-     Ocaml command '#use "base_include";;' (use '#use "include";;' for a rawer
-     term pretty printer)
+     Ocaml command '#use "base_include";;' (use '#use "include";;' for 
+     installing the advanced term pretty printers)
   4. Use #trace to tell which function(s) to trace
   5. Go back to Coq toplevel with 'go();;'
   6. Test your Coq command and observe the result of tracing your functions
@@ -15,6 +15,15 @@ Debugging from Coq toplevel using Caml trace mechanism
   notations, ...), use "Set Printing All". It will affect the #trace
   printers too.
 
+Note for Ocaml 3.10.x: Ocaml 3.10.x requires that modules compiled
+with -rectypes are loaded in an environment with -rectypes set but
+there is no way to tell the toplevel to support -rectypes. To make it
+works, use "patch -p0 < dev/doc/patch.ocaml-3.10.drop.rectypes" to
+hack script/coqmktop.ml, then recompile coqtop.byte. The procedure
+above then works as soon as coqtop.byte is called with at least one
+argument (add neutral option -byte to ensure at least one argument).
+
+
 Debugging from Caml debugger
 ============================
 
diff --git a/dev/doc/naming-conventions.tex b/dev/doc/naming-conventions.tex
new file mode 100644
index 00000000..e7c8975b
--- /dev/null
+++ b/dev/doc/naming-conventions.tex
@@ -0,0 +1,606 @@
+\documentclass[a4paper]{article}
+\usepackage{fullpage}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{amsfonts}
+
+\parindent=0pt
+\parskip=10pt
+
+%%%%%%%%%%%%%
+% Macros
+\newcommand\itemrule[3]{
+\subsubsection{#1}
+\begin{quote}
+\begin{tt}
+#3
+\end{tt}
+\end{quote}
+\begin{quote}
+Name: \texttt{#2}
+\end{quote}}
+
+\newcommand\formula[1]{\begin{tt}#1\end{tt}}
+\newcommand\tactic[1]{\begin{tt}#1\end{tt}}
+\newcommand\command[1]{\begin{tt}#1\end{tt}}
+\newcommand\term[1]{\begin{tt}#1\end{tt}}
+\newcommand\library[1]{\texttt{#1}}
+\newcommand\name[1]{\texttt{#1}}
+
+\newcommand\zero{\texttt{zero}}
+\newcommand\op{\texttt{op}}
+\newcommand\opPrime{\texttt{op'}}
+\newcommand\opSecond{\texttt{op''}}
+\newcommand\phimapping{\texttt{phi}}
+\newcommand\D{\texttt{D}}
+\newcommand\elt{\texttt{elt}}
+\newcommand\rel{\texttt{rel}}
+\newcommand\relp{\texttt{rel'}}
+
+%%%%%%%%%%%%%
+
+\begin{document}
+
+\begin{center}
+\begin{huge}
+Proposed naming conventions for the Coq standard library
+\end{huge}
+\end{center}
+\bigskip
+
+The following document describes a proposition of canonical naming
+schemes for the Coq standard library. Obviously and unfortunately, the
+current state of the library is not as homogeneous as it would be if
+it would systematically follow such a scheme. To tend in this
+direction, we however recommend to follow the following suggestions.
+
+\tableofcontents
+
+\section{General conventions}
+
+\subsection{Variable names}
+
+\begin{itemize}
+
+\item Variables are preferably quantified at the head of the
+  statement, even if some premisses do not depend of one of them. For
+  instance, one would state
+\begin{quote}
+\begin{tt}
+  {forall x y z:D, x <= y -> x+z <= y+z}
+\end{tt}
+\end{quote}
+and not
+\begin{quote}
+\begin{tt}
+  {forall x y:D, x <= y -> forall z:D, x+z <= y+z}
+\end{tt}
+\end{quote}
+
+\item Variables are preferably quantified (and named) in the order of
+  ``importance'', then of appearance, from left to right, even if
+  for the purpose of some tactics it would have been more convenient
+  to have, say, the variables not occurring in the conclusion
+  first. For instance, one would state
+\begin{quote}
+\begin{tt}
+  {forall x y z:D, x+z <= y+z -> x <= y}
+\end{tt}
+\end{quote}
+and not
+\begin{quote}
+\begin{tt}
+  {forall z x y:D, x+z <= y+z -> x <= y}
+\end{tt}
+\end{quote}
+nor
+\begin{quote}
+\begin{tt}
+  {forall x y z:D, y+x <= z+x -> y <= z}
+\end{tt}
+\end{quote}
+
+\item Choice of effective names is domain-dependent. For instance, on
+  natural numbers, the convention is to use the variables $n$, $m$,
+  $p$, $q$, $r$, $s$ in this order.
+
+  On generic domains, the convention is to use the letters $x$, $y$,
+  $z$, $t$. When more than three variables are needed, indexing variables
+
+  It is conventional to use specific names for variables having a
+  special meaning. For instance, $eps$ or $\epsilon$ can be used to
+  denote a number intended to be as small as possible. Also, $q$ and
+  $r$ can be used to denote a quotient and a rest. This is good
+  practice.
+
+\end{itemize}
+
+\subsection{Disjunctive statements}
+
+A disjunctive statement with a computational content will be suffixed
+by \name{\_inf}. For instance, if
+
+\begin{quote}
+\begin{tt}
+{forall x y, op x y = zero -> x = zero \/ y = zero}
+\end{tt}
+\end{quote}
+has name \texttt{D\_integral}, then
+\begin{quote}
+\begin{tt}
+{forall x y, op x y = zero -> \{x = zero\} + \{y = zero\}}
+\end{tt}
+\end{quote}
+will have name \texttt{D\_integral\_inf}.
+
+As an exception, decidability statements, such as 
+\begin{quote}
+\begin{tt}
+{forall x y, \{x = y\} + \{x <> y\}}
+\end{tt}
+\end{quote}
+will have a named ended in \texttt{\_dec}. Idem for cotransitivity
+lemmas which are inherently computational that are ended in
+\texttt{\_cotrans}.
+
+\subsection{Inductive types constructor names}
+
+As a general rule, constructor names start with the name of the
+inductive type being defined as in \texttt{Inductive Z := Z0 : Z |
+  Zpos : Z -> Z | Zneg : Z -> Z} to the exception of very standard
+types like \texttt{bool}, \texttt{nat}, \texttt{list}...
+
+For inductive predicates, constructor names also start with the name
+of the notion being defined with one or more suffixes separated with
+\texttt{\_} for discriminating the different cases as e.g. in
+
+\begin{verbatim}
+Inductive even : nat -> Prop :=
+  | even_O : even 0
+  | even_S n : odd n -> even (S n)
+with odd : nat -> Prop :=
+  | odd_S n : even n -> odd (S n).
+\end{verbatim}
+
+As a general rule, inductive predicate names should be lowercase (to
+the exception of notions referring to a proper name, e.g. \texttt{Bezout})
+and multiple words must be separated by ``{\_}''.
+
+As an exception, when extending libraries whose general rule is that
+predicates names start with a capital letter, the convention of this
+library should be kept and the separation between multiple words is
+done by making the initial of each work a capital letter (if one of
+these words is a proper name, then a ``{\_}'' is added to emphasize
+that the capital letter is proper and not an application of the rule
+for marking the change of word).
+
+Inductive predicates that characterize the specification of a function
+should be named after the function it specifies followed by
+\texttt{\_spec} as in:
+
+\begin{verbatim}
+Inductive nth_spec : list A -> nat -> A -> Prop :=
+  | nth_spec_O a l : nth_spec (a :: l) 0 a
+  | nth_spec_S n a b l : nth_spec l n a -> nth_spec (b :: l) (S n) a.
+\end{verbatim}
+
+\section{Equational properties of operations}
+
+\subsection{General conventions}
+
+If the conclusion is in the other way than listed below, add suffix
+\name{\_reverse} to the lemma name.
+
+\subsection{Specific conventions}
+
+\itemrule{Associativity of binary operator {\op} on domain {\D}}{Dop\_assoc}
+{forall x y z:D, op x (op y z) = op (op x y) z}
+
+  Remark: Symmetric form: \name{Dop\_assoc\_reverse}:
+  \formula{forall x y z:D, op (op x y) z = op x (op y z)}
+
+\itemrule{Commutativity of binary operator {\op} on domain {\D}}{Dop\_comm}
+{forall x y:D, op x y = op y x}
+
+  Remark: Avoid \formula{forall x y:D, op y x = op x y}, or at worst, call it
+  \name{Dop\_comm\_reverse}
+
+\itemrule{Left neutrality of element elt for binary operator {\op}}{Dop\_elt\_l}
+{forall x:D, op elt x = x}
+
+  Remark: In English, ``{\elt} is an identity for {\op}'' seems to be
+  a more common terminology.
+
+\itemrule{Right neutrality of element elt for binary operator {\op}}{Dop\_elt\_r}
+{forall x:D, op x elt = x}
+
+  Remark: By convention, if the identities are reminiscent to zero or one, they
+  are written 1 and 0 in the name of the property.
+
+\itemrule{Left absorption of element elt for binary operator {\op}}{Dop\_elt\_l}
+{forall x:D, op elt x = elt}
+
+  Remarks:
+  \begin{itemize}
+  \item In French school, this property is named "elt est absorbant pour op"
+  \item English, the property seems generally named "elt is a zero of op"
+  \item In the context of lattices, this a boundedness property, it may
+     be called "elt is a bound on D", or referring to a (possibly
+     arbitrarily oriented) order "elt is a least element of D" or "elt
+     is a greatest element of D"
+  \end{itemize}
+
+\itemrule{Right absorption of element {\elt} for binary operator {\op}}{Dop\_elt\_l  [BAD ??]}
+{forall x:D, op x elt = elt}
+
+\itemrule{Left distributivity of binary operator {\op} over {\opPrime} on domain {\D}}{Dop\_op'\_distr\_l}
+{forall x y z:D, op (op' x y) z = op' (op x z) (op y z)}
+
+  Remark: Some authors say ``distribution''.
+
+\itemrule{Right distributivity of binary operator {\op} over {\opPrime} on domain {\D}}{Dop\_op'\_distr\_r}
+{forall x y z:D, op z (op' x y) = op' (op z x) (op z y)}
+
+  Remark: Note the order of arguments.
+
+\itemrule{Distributivity of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr}
+{forall x y:D, op (op' x y) = op' (op x) (op y)}
+
+\itemrule{Distributivity of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr}
+{forall x y:D, op (op' x y) = op' (op x) (op y)}
+
+  Remark: For a non commutative operation with inversion of arguments, as in
+  \formula{forall x y z:D, op (op' x y) = op' (op y) (op y z)},
+  we may probably still call the property distributivity since there
+  is no ambiguity.
+
+  Example: \formula{forall n m : Z, -(n+m) = (-n)+(-m)}.
+
+  Example: \formula{forall l l' : list A, rev (l++l') = (rev l)++(rev l')}.
+
+\itemrule{Left extrusion of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr\_l}
+{forall x y:D, op (op' x y) = op' (op x) y}
+
+  Question: Call it left commutativity ?? left swap ?
+
+\itemrule{Right extrusion of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr\_r}
+{forall x y:D, op (op' x y) = op' x (op y)}
+
+\itemrule{Idempotency of binary operator {\op} on domain {\D}}{Dop\_idempotent}
+{forall x:D, op x n = x}
+
+\itemrule{Idempotency of unary operator {\op} on domain {\D}}{Dop\_idempotent}
+{forall x:D, op (op x) = op x}
+
+  Remark: This is actually idempotency of {\op} wrt to composition and
+  identity.
+
+\itemrule{Idempotency of element elt for binary operator {\op} on domain {\D}}{Dop\_elt\_idempotent}
+{op elt elt = elt}
+
+  Remark: Generally useless in CIC for concrete, computable operators
+
+  Remark: The general definition is ``exists n, iter n op x = x''.
+
+\itemrule{Nilpotency of element elt wrt a ring D with additive neutral
+element {\zero} and multiplicative binary operator
+{\op}}{Delt\_nilpotent} 
+{op elt elt = zero}
+
+  Remark: We leave the ring structure of D implicit; the general definition is ``exists n, iter n op elt = zero''.
+
+\itemrule{Zero-product property in a ring D with additive neutral
+element {\zero} and multiplicative binary operator
+{\op}}{D\_integral}
+{forall x y, op x y = zero -> x = zero \/ y = zero}
+
+  Remark: We leave the ring structure of D implicit; the Coq library
+  uses either \texttt{\_is\_O} (for \texttt{nat}), \texttt{\_integral}
+    (for \texttt{Z}, \texttt{Q} and \texttt{R}), \texttt{eq\_mul\_0} (for
+    \texttt{NZ}).
+
+  Remark: The French school says ``integrité''.
+
+\itemrule{Nilpotency of binary operator {\op} wrt to its absorbing element
+zero in D}{Dop\_nilpotent} {forall x, op x x = zero}
+
+  Remark: Did not find this definition on the web, but it used in
+  the Coq library (to characterize \name{xor}).
+
+\itemrule{Involutivity of unary op on D}{Dop\_involutive}
+{forall x:D, op (op x) = x}
+
+\itemrule{Absorption law on the left for binary operator {\op} over binary operator {\op}' on the left}{Dop\_op'\_absorption\_l\_l}
+{forall x y:D, op x (op' x y) = x}
+
+\itemrule{Absorption law on the left for binary operator {\op} over binary operator {\op}' on the right}{Dop\_op'\_absorption\_l\_r}
+{forall x y:D, op x (op' y x) = x}
+
+  Remark: Similarly for \name{Dop\_op'\_absorption\_r\_l} and \name{Dop\_op'\_absorption\_r\_r}.
+
+\itemrule{De Morgan law's for binary operators {\opPrime} and {\opSecond} wrt
+to unary op on domain {\D}}{Dop'\_op''\_de\_morgan,
+Dop''\_op'\_de\_morgan ?? \mbox{leaving the complementing operation
+implicit})}
+{forall x y:D, op (op' x y) = op'' (op x) (op y)\\
+forall x y:D, op (op'' x y) = op' (op x) (op y)}
+
+\itemrule{Left complementation of binary operator {\op} by means of unary {\opPrime} wrt neutral element {\elt} of {\op} on domain {\D}}{Dop\_op'\_opp\_l}
+{forall x:D, op (op' x) x = elt}
+
+Remark: If the name of the opposite function is reminiscent of the
+notion of complement (e.g. if it is called \texttt{opp}), one can
+simply say {Dop\_opp\_l}.
+
+\itemrule{Right complementation of binary operator {\op} by means of unary {\op'} wrt neutral element {\elt} of {\op} on domain {\D}}{Dop\_opp\_r}
+{forall x:D, op x (op' x) = elt}
+
+Example: \formula{Radd\_opp\_l: forall r : R, - r + r = 0}
+
+\itemrule{Associativity of binary operators {\op} and {\op'}}{Dop\_op'\_assoc}
+{forall x y z, op x (op' y z) = op (op' x y) z}
+
+Example: \formula{forall x y z, x + (y - z) = (x + y) - z}
+
+\itemrule{Right extrusion of binary operator {\opPrime} over binary operator {\op}}{Dop\_op'\_extrusion\_r}
+{forall x y z, op x (op' y z) = op' (op x y) z}
+
+Remark: This requires {\op} and {\opPrime} to have their right and left
+argument respectively and their return types identical.
+
+Example: \formula{forall x y z, x + (y - z) = (x + y) - z}
+
+Remark: Other less natural combinations are possible, such
+as \formula{forall x y z, op x (op' y z) = op' y (op x z)}.
+
+\itemrule{Left extrusion of binary operator {\opPrime} over binary operator {\op}}{Dop\_op'\_extrusion\_l}
+{forall x y z, op (op' x y) z = op' x (op y z)}
+
+Remark: Operations are not necessarily internal composition laws.  It
+is only required that {\op} and {\opPrime} have their right and left
+argument respectively and their return type identical.
+
+Remark: When the type are heterogeneous, only one extrusion law is possible and it can simply be named {Dop\_op'\_extrusion}.
+
+Example: \formula{app\_cons\_extrusion : forall a l l', (a :: l) ++ l' = a :: (l ++ l')}.
+
+%======================================================================
+%\section{Properties of elements}
+
+%Remark: Not used in current library
+
+
+
+%======================================================================
+\section{Preservation and compatibility properties of operations}
+
+\subsection{With respect to equality}
+
+\itemrule{Injectivity of unary operator {\op}}{Dop\_inj}
+{forall x y:D, op x = op y -> x = y}
+
+\itemrule{Left regularity of binary operator {\op}}{Dop\_reg\_l, Dop\_inj\_l, or Dop\_cancel\_l}
+{forall x y z:D, op z x = op z y -> x = y}
+
+  Remark: Note the order of arguments.
+
+  Remark: The Coq usage is to called it regularity but the English
+  standard seems to be cancellation. The recommended form is not
+  decided yet.
+
+  Remark: Shall a property like $n^p \leq n^q \rightarrow p \leq q$
+  (for $n\geq 1$) be called cancellation or should it be reserved for
+  operators that have an inverse?
+
+\itemrule{Right regularity of binary operator {\op}}{Dop\_reg\_r, Dop\_inj\_r, Dop\_cancel\_r}
+{forall x y z:D, op x z = op y z -> x = y}
+
+\subsection{With respect to a relation {\rel}}
+
+\itemrule{Compatibility of unary operator {\op}}{Dop\_rel\_compat}
+{forall x y:D, rel x y -> rel (op x) (op y)}
+
+\itemrule{Left compatibility of binary operator {\op}}{Dop\_rel\_compat\_l}
+{forall x y z:D, rel x y -> rel (op z x) (op z y)}
+
+\itemrule{Right compatibility of binary operator {\op}}{Dop\_rel\_compat\_r}
+{forall x y z:D, rel x y -> rel (op x z) (op y z)}
+
+  Remark: For equality, use names of the form \name{Dop\_eq\_compat\_l} or
+  \name{Dop\_eq\_compat\_r}
+(\formula{forall x y z:D, y = x -> op y z = op x z} and
+\formula{forall x y z:D, y = x -> op y z = op x z})
+
+  Remark: Should we admit (or even prefer) the name
+  \name{Dop\_rel\_monotone}, \name{Dop\_rel\_monotone\_l},
+  \name{Dop\_rel\_monotone\_r} when {\rel} is an order ?
+
+\itemrule{Left regularity of binary operator {\op}}{Dop\_rel\_reg\_l}
+{forall x y z:D, rel (op z x) (op z y) -> rel x y}
+
+\itemrule{Right regularity of binary operator {\op}}{Dop\_rel\_reg\_r}
+{forall x y z:D, rel (op x z) (op y z) -> rel x y}
+
+  Question: Would it be better to have \name{z} as first argument, since it
+  is missing in the conclusion ?? (or admit we shall use the options
+  ``\texttt{with p}''?)
+
+\itemrule{Left distributivity of binary operator {\op} over {\opPrime} along relation {\rel} on domain {\D}}{Dop\_op'\_rel\_distr\_l}
+{forall x y z:D, rel (op (op' x y) z) (op' (op x z) (op y z))}
+
+  Example: standard property of (not necessarily distributive) lattices
+
+  Remark: In a (non distributive) lattice, by swapping join and meet,
+  one would like also,
+\formula{forall x y z:D, rel (op' (op x z) (op y z)) (op (op' x y) z)}.
+  How to name it with a symmetric name (use
+ \name{Dop\_op'\_rel\_distr\_mon\_l} and
+ \name{Dop\_op'\_rel\_distr\_anti\_l})?
+
+\itemrule{Commutativity of binary operator {\op} along (equivalence) relation {\rel} on domain {\D}}{Dop\_op'\_rel\_comm}
+{forall x y z:D, rel (op x y) (op y x)}
+
+  Example:
+\formula{forall l l':list A, Permutation (l++l') (l'++l)}
+
+\itemrule{Irreducibility of binary operator {\op} on domain {\D}}{Dop\_irreducible}
+{forall x y z:D, z = op x y -> z = x $\backslash/$ z = y}
+
+  Question: What about the constructive version ? Call it \name{Dop\_irreducible\_inf} ?
+\formula{forall x y z:D, z = op x y -> \{z = x\} + \{z = y\}}
+
+\itemrule{Primality of binary operator {\op} along relation {\rel} on domain {\D}}{Dop\_rel\_prime}
+{forall x y z:D, rel z (op x y) -> rel z x $\backslash/$ rel  z y}
+
+
+%======================================================================
+\section{Morphisms}
+
+\itemrule{Morphism between structures {\D} and {\D'}}{\name{D'\_of\_D}}{D -> D'}
+
+Remark: If the domains are one-letter long, one can used \texttt{IDD'} as for
+\name{INR} or \name{INZ}.
+
+\itemrule{Morphism {\phimapping} mapping unary operators {\op} to {\op'}}{phi\_op\_op', phi\_op\_op'\_morphism}
+{forall x:D, phi (op x) = op' (phi x)}
+
+Remark: If the operators have the same name in both domains, one use
+\texttt{D'\_of\_D\_op} or \texttt{IDD'\_op}.
+
+Example: \formula{Z\_of\_nat\_mult: forall n m : nat, Z\_of\_nat (n * m) = (Z\_of\_nat n * Z\_of\_nat m)\%Z}.
+
+Remark: If the operators have different names on distinct domains, one
+can use \texttt{op\_op'}.
+
+\itemrule{Morphism {\phimapping} mapping binary operators {\op} to
+{\op'}}{phi\_op\_op', phi\_op\_op'\_morphism}  {forall
+x y:D, phi (op x y) = op' (phi x) (phi y)}
+
+Remark: If the operators have the same name in both domains, one use
+\texttt{D'\_of\_D\_op} or \texttt{IDD'\_op}.
+
+Remark: If the operators have different names on distinct domains, one
+can use \texttt{op\_op'}.
+
+\itemrule{Morphism {\phimapping} mapping binary operator {\op} to
+binary relation {\rel}}{phi\_op\_rel, phi\_op\_rel\_morphism}
+{forall x y:D, phi (op x y) <-> rel (phi x) (phi y)}
+
+Remark: If the operator and the relation have similar name, one uses
+\texttt{phi\_op}. 
+
+Question: How to name each direction? (add \_elim for -> and \_intro
+for <- ?? -- as done in Bool.v ??)
+
+Example: \formula{eq\_true\_neg: \~{} eq\_true b <-> eq\_true (negb b)}.
+
+%======================================================================
+\section{Preservation and compatibility properties of operations wrt order}
+
+\itemrule{Compatibility of binary operator {\op} wrt (strict order) {\rel} and (large order) {\rel'}}{Dop\_rel\_rel'\_compat}
+{forall x y z t:D, rel x y -> rel' z t -> rel (op x z) (op y t)}
+
+\itemrule{Compatibility of binary operator {\op} wrt (large order) {\relp} and (strict order) {\rel}}{Dop\_rel'\_rel\_compat}
+{forall x y z t:D, rel' x y -> rel z t -> rel (op x z) (op y t)}
+
+
+%======================================================================
+\section{Properties of relations}
+
+\itemrule{Reflexivity of relation {\rel} on domain {\D}}{Drel\_refl}
+{forall x:D, rel x x}
+
+\itemrule{Symmetry of relation {\rel} on domain {\D}}{Drel\_sym}
+{forall x y:D, rel x y -> rel y x}
+
+\itemrule{Transitivity of relation {\rel} on domain {\D}}{Drel\_trans}
+{forall x y z:D, rel x y -> rel y z -> rel x z}
+
+\itemrule{Antisymmetry of relation {\rel} on domain {\D}}{Drel\_antisym}
+{forall x y:D, rel x y -> rel y x -> x = y}
+
+\itemrule{Irreflexivity of relation {\rel} on domain {\D}}{Drel\_irrefl}
+{forall x:D, \~{} rel x x}
+
+\itemrule{Asymmetry of relation {\rel} on domain {\D}}{Drel\_asym}
+{forall x y:D, rel x y -> \~{} rel y x}
+
+\itemrule{Cotransitivity of relation {\rel} on domain {\D}}{Drel\_cotrans}
+{forall x y z:D, rel x y -> \{rel z y\} + \{rel x z\}}
+
+\itemrule{Linearity of relation {\rel} on domain {\D}}{Drel\_trichotomy}
+{forall x y:D, \{rel x y\} + \{x = y\} + \{rel y x\}}
+
+  Questions: Or call it \name{Drel\_total}, or \name{Drel\_linear}, or
+  \name{Drel\_connected}? Use
+  $\backslash/$ ? or use a ternary sumbool, or a ternary disjunction,
+  for nicer elimination.
+
+\itemrule{Informative decidability of relation {\rel} on domain {\D}}{Drel\_dec (or Drel\_dect, Drel\_dec\_inf ?)}
+{forall x y:D, \{rel x y\} + \{\~{} rel x y\}}
+
+  Remark: If equality: \name{D\_eq\_dec} or \name{D\_dec} (not like
+  \name{eq\_nat\_dec})
+
+\itemrule{Non informative decidability of relation {\rel} on domain {\D}}{Drel\_dec\_prop (or Drel\_dec)}
+{forall x y:D, rel x y $\backslash/$ \~{} rel x y}
+
+\itemrule{Inclusion of relation {\rel} in relation {\rel}' on domain {\D}}{Drel\_rel'\_incl (or Drel\_incl\_rel')}
+{forall x y:D, rel x y -> rel' x y}
+
+  Remark: Use \name{Drel\_rel'\_weak} for a strict inclusion ??
+
+%======================================================================
+\section{Relations between properties}
+
+\itemrule{Equivalence of properties \texttt{P} and \texttt{Q}}{P\_Q\_iff}
+{forall x1 .. xn, P <-> Q}
+
+  Remark: Alternatively use \name{P\_iff\_Q} if it is too difficult to
+  recover what pertains to \texttt{P} and what pertains to \texttt{Q}
+  in their concatenation (as e.g. in
+  \texttt{Godel\_Dummett\_iff\_right\_distr\_implication\_over\_disjunction}).
+
+%======================================================================
+\section{Arithmetical conventions}
+
+\begin{minipage}{6in}
+\renewcommand{\thefootnote}{\thempfootnote}  % For footnotes...
+\begin{tabular}{lll}
+Zero on domain {\D} & D0 & (notation \verb=0=)\\
+One on domain {\D} & D1 (if explicitly defined) & (notation \verb=1=)\\
+Successor on domain {\D} & Dsucc\\
+Predessor on domain {\D} & Dpred\\
+Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existng libraries that already use \texttt{plus} and \texttt{mult}}
+ & (infix notation \verb=+= [50,L])\\
+Multiplication on domain {\D} & Dmul/Dmult\footnotemark[\value{footnote}] & (infix notation \verb=*= [40,L]))\\
+Soustraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\
+Opposite on domain {\D} & Dopp (if any) & (prefix notation \verb=-= [35,R]))\\
+Inverse on domain {\D} & Dinv (if any) & (prefix notation \verb=/= [35,R]))\\
+Power on domain {\D} & Dpower & (infix notation \verb=^= [30,R])\\
+Minimal element on domain {\D} & Dmin\\
+Maximal element on domain {\D} & Dmax\\
+Large less than order on {\D} & Dle & (infix notations \verb!<=! and \verb!>=! [70,N]))\\
+Strict less than order on {\D} & Dlt & (infix notations \verb=<= and \verb=>= [70,N]))\\
+\end{tabular}
+\bigskip
+\end{minipage}
+
+\bigskip
+
+The status of \verb!>=! and \verb!>! is undecided yet. It will eithet
+be accepted only as parsing notations or may also accepted as a {\em
+  definition} for the \verb!<=! and \verb!<! (like in \texttt{nat}) or
+even as a different definition (like it is the case in \texttt{Z}).
+
+\bigskip
+
+Exception: Peano Arithmetic which is used for pedagogical purpose:
+
+\begin{itemize}
+\item domain name is implicit
+\item \term{0} (digit $0$) is \term{O} (the 15th letter of the alphabet)
+\item \term{succ} is \verb!S! (but \term{succ} can be used in theorems)
+\end{itemize}
+
+\end{document}
diff --git a/dev/doc/patch.ocaml-3.10.drop.rectypes b/dev/doc/patch.ocaml-3.10.drop.rectypes
new file mode 100644
index 00000000..ba7a3e95
--- /dev/null
+++ b/dev/doc/patch.ocaml-3.10.drop.rectypes
@@ -0,0 +1,31 @@
+Index: scripts/coqmktop.ml
+===================================================================
+--- scripts/coqmktop.ml	(révision 12084)
++++ scripts/coqmktop.ml	(copie de travail)
+@@ -231,12 +231,25 @@
+      end;;
+ 
+      let ppf = Format.std_formatter;;
++     let set_rectypes_hack () =
++       if String.length (Sys.ocaml_version) >= 4 &
++          String.sub (Sys.ocaml_version) 0 4 = \"3.10\"
++       then
++         (* ocaml 3.10 does not have #rectypes but needs it *)
++         (* simulate a call with option -rectypes before *)
++         (* jumping to the ocaml toplevel *)
++         for i = 1 to Array.length Sys.argv - 1 do
++           Sys.argv.(i) <- \"-rectypes\"
++         done
++       else
++         () in
++
+      Mltop.set_top
+        {Mltop.load_obj=
+          (fun f -> if not (Topdirs.load_file ppf f) then failwith \"error\");
+         Mltop.use_file=Topdirs.dir_use ppf;
+         Mltop.add_dir=Topdirs.dir_directory;
+-        Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\n"
++        Mltop.ml_loop=(fun () -> set_rectypes_hack(); Topmain.main()) };;\n"
+ 
+ (* create a temporary main file to link *)
+ let create_tmp_main_file modules =
diff --git a/dev/doc/perf-analysis b/dev/doc/perf-analysis
index 8e481544..d23bf835 100644
--- a/dev/doc/perf-analysis
+++ b/dev/doc/perf-analysis
@@ -1,6 +1,14 @@
 Performance analysis (trunk repository)
 ---------------------------------------
 
+Dec 1, 2009 - Dec 19, 2009: Temporary addition of [forall x, P x] hints to
+  exact (generally not significative but, e.g., +25% on Subst, +8% on
+  ZFC, +5% on AreaMethod)
+
+Oct 19, 2009: Change in modules (CoLoR +35%)
+
+Aug 9, 2009: new files added in AreaMethod 
+
 May 21, 2008: New version of CoRN
   (needs +84% more time to compile)
 
diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex
new file mode 100644
index 00000000..175297f9
--- /dev/null
+++ b/dev/doc/versions-history.tex
@@ -0,0 +1,351 @@
+\documentclass[a4paper]{book}
+\usepackage{fullpage}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{amsfonts}
+
+\newcommand{\feature}[1]{{\em #1}}
+
+\begin{document}
+
+\begin{center}
+\begin{huge}
+An history of Coq versions
+\end{huge}
+\end{center}
+\bigskip
+
+\centerline{\large 1984-1989: The Calculus of Constructions}
+\mbox{}\\
+\mbox{}\\
+\begin{tabular}{l|l|l}
+version & date & comments \\
+\hline
+CoC V1.10& mention of dates from 6 December & implementation language is Caml\\
+         & 1984 to 13 February 1985 \\
+
+CoC V1.11& mention of dates from 6 December\\
+         & 1984 to 19 February 1985\\
+
+CoC V2.13& dated 16 December 1985\\
+
+CoC V2.13& dated 25 June 1986\\
+
+CoC V3.1& dated 20 November 1986 & \feature{auto}\\
+
+CoC V3.2& dated 27 November 1986\\
+
+CoC V3.3 and V3.4& dated 1 January 1987 & creation of a directory for examples\\
+
+CoC V4.1& dated 24 July 1987\\
+
+CoC V4.2& dated 10 September 1987\\
+
+CoC V4.3& dated 15 September 1987\\
+
+CoC V4.4& dated 27 January 1988\\
+
+CoC V4.5 and V4.5.5& dated 15 March 1988\\
+
+CoC V4.6 and V4.7& dated 1 September 1988\\
+
+CoC V4.8& dated 1 December 1988\\
+
+CoC V4.8.5& dated 1 February 1989\\
+
+CoC V4.9& dated 1 March 1989\\
+
+CoC V4.10 and 4.10.1& dated 1 May 1989 & first public release - in English\\
+\end{tabular}
+
+\bigskip
+\bigskip
+
+\newpage
+
+\centerline{\large 1989-now: The Calculus of Inductive Constructions}
+\mbox{}\\
+\centerline{I- RCS archives in Caml and Caml-Light}
+\mbox{}\\
+\mbox{}\\
+\begin{tabular}{l|l|l}
+version & date & comments \\
+\hline
+Coq V5.0 & headers dated 1 January 1990 & internal use \\
+  & & \feature{inductive types with primitive recursor}\\
+
+Coq V5.1 & ended 12 July 1990 & internal use \\
+
+Coq V5.2 & log dated 4 October 1990 & internal use \\
+
+Coq V5.3 & log dated 12 October 1990 & internal use \\
+
+Coq V5.4 & headers dated 24 October 1990 & internal use, \feature{extraction} (version 1) [3-12-90]\\
+
+Coq V5.5 & started 6 December 1990 & internal use \\
+
+Coq V5.6 beta & 1991 & first announce of the new Coq based on CIC \\
+ & & (in May at TYPES?)\\
+ & & \feature{rewrite tactic}\\
+ & & use of RCS at least from February 1991\\
+
+Coq V5.6& 7 August 1991 & \\
+
+Coq V5.6 patch 1& 13 November 1991 & \\
+
+Coq V5.6 (last) & mention of 27 November 1992\\
+
+Coq V5.7.0& 1992 & translation to Caml-Light \footnotemark\\
+
+Coq V5.8& 12 February 1993 & \feature{Program} (version 1), \feature{simpl}\\
+
+& & has the xcoq graphical interface\\
+
+& & first explicit notion of standard library\\
+
+& & includes a MacOS 7-9 version\\
+
+Coq V5.8.1& released 28 April 1993 & with xcoq graphical interface and MacOS 7-9 support\\
+
+Coq V5.8.2& released 9 July 1993 & with xcoq graphical interface and MacOS 7-9 support\\
+
+Coq V5.8.3& released 6 December 1993 % Announce on coq-club
+          & with xcoq graphical interface and MacOS 7-9 support\\
+
+ & & 3 branches: Lyon (V5.8.x), Ulm (V5.10.x) and Rocq (V5.9)\\
+
+Coq V5.9 alpha& 7 July 1993 & 
+experimental version based on evars refinement \\
+              & & (merge from experimental ``V6.0'' and some pre-V5.8.3 \\
+              & & version), not released\\
+
+& March 1994 & \feature{tauto} tactic in V5.9 branch\\
+
+Coq V5.9 & 27 January 1993 & experimental version based on evars refinement\\
+         & & not released\\
+\end{tabular}
+
+\bigskip
+\bigskip
+
+\footnotetext{archive lost?}
+
+\newpage
+
+\centerline{II- Starting with CVS archives in Caml-Light}
+\mbox{}\\
+\mbox{}\\
+\begin{tabular}{l|l|l}
+version & date & comments \\
+\hline
+Coq V5.10 ``Murthy'' & 22 January 1994 & 
+introduction of the ``DOPN'' structure\\
+ & & \feature{eapply/prolog} tactics\\
+ & & private use of cvs on madiran.inria.fr\\
+
+Coq V5.10.1 ``Murthy''& 15 April 1994 \\
+
+Coq V5.10.2 ``Murthy''& 19 April 1994 & \feature{mutual inductive types, fixpoint} (from Lyon's branch)\\
+
+Coq V5.10.3& 28 April 1994 \\
+
+Coq V5.10.5& dated 13 May 1994 & \feature{inversion}, \feature{discriminate}, \feature{injection} \\
+  & & \feature{type synthesis of hidden arguments}\\
+  & & \feature{separate compilation}, \feature{reset mechanism} \\
+
+Coq V5.10.6& dated 30 May 1994\\
+Coq Lyon's archive & in 1994 & cvs server set up on woodstock.ens-lyon.fr\\
+
+Coq V5.10.9& announced on 17 August 1994 &
+ % Announced by Catherine Parent on coqdev
+ % Version avec une copie de THEORIES pour les inductifs mutuels 
+ \\
+
+Coq V5.10.11& announced on 2 February 1995 & \feature{compute}\\
+Coq Rocq's archive & on 16 February 1995 & set up of ``V5.10'' cvs archive on pauillac.inria.fr \\
+ & & with first dispatch of files over src/* directories\\
+
+Coq V5.10.12& dated 30 January 1995 & on Lyon's cvs\\
+
+Coq V5.10.13& dated 9 June 1995 & on Lyon's cvs\\
+
+Coq V5.10.14.OO& dated 30 June 1995 & on Lyon's cvs\\
+
+Coq V5.10.14.a& announced 5 September 1995 & bug-fix release \\ % Announce on coq-club by BW 
+
+Coq V5.10.14.b& released 2 October 1995 & bug-fix release\\
+  & & MS-DOS version released on 30 October 1995\\
+ % still available at ftp://ftp.ens-lyon.fr/pub/LIP/COQ/V5.10.14.old/ in May 2009
+ % also known in /net/pauillac/constr archive as ``V5.11 old'' \\
+ % A copy of Coq V5.10.15 dated 1 January 1996 coming from Lyon's CVS is
+ % known in /net/pauillac/constr archive as ``V5.11 new old'' \\
+
+Coq V5.10.15 & released 20 February 1996 & \feature{Logic, Sorting, new Sets and Relations libraries} \\
+  % Announce on coq-club by BW
+  % dated 15 February 1996 and bound to pauillac's cvs in /net/pauillac/constr archive 
+  & & MacOS 7-9 version released on 1 March 1996 \\ % Announce on coq-club by BW
+
+Coq V5.11 & dated 1 March 1996 & not released, not in pauillac's CVS, \feature{eauto} \\
+\end{tabular}
+
+\bigskip
+\bigskip
+
+\newpage
+
+\centerline{III- A CVS archive in Caml Special Light}
+\mbox{}\\
+\mbox{}\\
+\begin{tabular}{l|l|l}
+version & date & comments \\
+\hline
+Coq ``V6'' archive & 20 March 1996 & new cvs repository on pauillac.inria.fr with code ported \\
+ & & to Caml Special Light (to later become Objective Caml)\\
+ & & has implicit arguments and coercions\\
+
+Coq V6.1beta& released 18 November 1996 & \feature{coercions} [23-5-1996], \feature{user-level implicit arguments} [23-5-1996]\\
+ & & \feature{omega} [10-9-1996] \\
+ & & \feature{natural language proof printing} (stopped from Coq V7) [6-9-1996]\\
+ & & \feature{pattern-matching compilation} [7-10-1996]\\
+ & & \feature{ring} (version 1, ACSimpl) [11-12-1996]\\
+
+Coq V6.1& released December 1996 & \\
+
+Coq V6.2beta& released 30 January 1998 & % Announced on coq-club 2-2-1998 by CP
+      \feature{SearchIsos} (stopped from Coq V7) [9-11-1997]\\
+  & & grammar extension mechanism moved to Camlp4 [12-6-1997]\\
+  & & \feature{refine tactic}\\
+  & & includes a Windows version\\
+
+Coq V6.2& released 4 May 1998 & % Announced on coq-club 5-5-1998 by CP
+  \feature{ring} (version 2) [7-4-1998] \\
+
+Coq V6.2.1& released 23 July 1998\\
+
+Coq V6.2.2 beta& released 30 January 1998\\
+
+Coq V6.2.2& released 23 September 1998\\
+
+Coq V6.2.3& released 22 December 1998 & \feature{Real numbers library} [from 13-11-1998] \\
+
+Coq V6.2.4& released 8 February 1999\\
+
+Coq V6.3& released 27 July 1999 & \feature{autorewrite} [25-3-1999]\\
+ & & \feature{Correctness} (deprecated in V8, led to Why) [28-10-1997]\\
+
+Coq V6.3.1& released 7 December 1999\\
+\end{tabular}
+\medskip
+\bigskip
+
+\newpage
+\centerline{IV- New CVS, back to a kernel-centric implementation}
+\mbox{}\\
+\mbox{}\\
+\begin{tabular}{l|l|l}
+version & date & comments \\
+\hline
+Coq ``V7'' archive & August 1999 & new cvs archive based on J.-C. Filliâtre's \\
+   & & \feature{kernel-centric} architecture \\
+   & & more care for outside readers\\
+   & & (indentation, ocaml warning protection)\\
+Coq V7.0beta& released 27 December 2000 & \feature{${\cal L}_{\mathit{tac}}$} \\
+Coq V7.0beta2& released 2 February 2001\\
+
+Coq V7.0& released 25 April 2001 & \feature{extraction} (version 2) [6-2-2001] \\
+  & & \feature{field} (version 1) [19-4-2001], \feature{fourier} [20-4-2001] \\
+
+Coq V7.1& released 25 September 2001 & \feature{setoid rewriting} (version 1) [10-7-2001]\\
+
+Coq V7.2& released 10 January 2002\\
+
+Coq V7.3& released 16 May 2002\\
+
+Coq V7.3.1& released 5 October 2002 & \feature{module system} [2-8-2002]\\
+  & & \feature{pattern-matching compilation} (version 2) [13-6-2002]\\
+
+Coq V7.4& released 6 February 2003 & \feature{notation}, \feature{scopes} [13-10-2002]\\
+
+Coq V8.0& released 21 April 2004 & \feature{new concrete syntax}, \feature{Set predicative}, \feature{CoqIDE} [from 4-2-2003]\\
+
+Coq V8.0pl1& released 18 July 2004\\
+
+Coq V8.0pl2& released 22 January 2005\\
+
+Coq V8.0pl3& released 13 January 2006\\
+
+Coq V8.0pl4& released 26 January 2007\\
+
+Coq ``svn'' archive & 6 March 2006 & cvs archive moved to subversion control management\\
+
+Coq V8.1beta& released 12 July 2006 & \feature{bytecode compiler} [20-10-2004] \\
+  & & \feature{setoid rewriting} (version 2) [3-9-2004]\\
+  & & \feature{functional induction} [1-2-2006]\\
+  & & \feature{Strings library} [8-2-2006], \feature{FSets/FMaps library} [15-3-2006] \\
+  & & \feature{Program} (version 2, Russell) [5-3-2006] \\
+  & & \feature{declarative language} [20-9-2006]\\
+  & & \feature{ring} (version 3) [18-11-2005]\\
+
+Coq V8.1gamma& released 7 November 2006 & \feature{field} (version 2) [29-9-2006]\\
+
+Coq V8.1& released 10 February 2007 & \\
+
+Coq V8.1pl1& released 27 July 2007 & \\
+Coq V8.1pl2& released 13 October 2007 & \\
+Coq V8.1pl3& released 13 December 2007 & \\
+Coq V8.1pl4& released 9 October 2008 & \\
+
+Coq V8.2 beta1& released 13 June 2008 & \\
+Coq V8.2 beta2& released 19 June 2008 & \\
+Coq V8.2 beta3& released 27 June 2008 & \\
+Coq V8.2 beta4& released 8 August 2008 & \\
+
+Coq V8.2 & released 17 February 2009 & \feature{type classes} [10-12-2007], \feature{machine words} [11-5-2007]\\
+  & & \feature{big integers} [11-5-2007], \feature{abstract arithmetics} [9-2007]\\
+  & & \feature{setoid rewriting} (version 3) [18-12-2007] \\
+  & & \feature{micromega solving platform} [19-5-2008]\\
+
+& & a first package released on
+February 11 was incomplete\\
+\end{tabular}
+
+\medskip
+\bigskip
+\newpage
+
+\centerline{\large Other important dates}
+\mbox{}\\
+\mbox{}\\
+\begin{tabular}{l|l|l}
+version & date & comments \\
+\hline
+Lechenadec's version in C& mention of \\
+ & 13 January 1985 on \\
+ & some vernacular files\\
+Set up of the coq-club mailing list & 28 July 1993\\
+
+Coq V6.0 ``evars'' & & experimentation based on evars
+refinement started \\
+  & & in 1991 by Gilles from V5.6 beta,\\
+  & & with work by Hugo in July 1992\\
+
+Coq V6.0 ``evars'' ``light'' & July 1993 & Hugo's port of the first
+evars-based experimentation \\
+ & & to Coq V5.7, version from October/November
+1992\\
+
+CtCoq & released 25 October 1995 & first beta-version  \\ % Announce on coq-club by Janet  
+
+Proto with explicit substitutions & 1997 &\\
+
+Coq web site & 15 April 1998 & new site designed by David Delahaye \\
+
+Coq web site & January 2004 & web site new style \\
+  & & designed by Julien Narboux and Florent Kirchner \\
+
+Coq web site & April 2009 & new Drupal-based site \\
+  & & designed by Jean-Marc Notin and Denis Cousineau \\
+
+\end{tabular}
+
+\end{document}
diff --git a/dev/include b/dev/include
index ccb75edd..251a969b 100644
--- a/dev/include
+++ b/dev/include
@@ -1,12 +1,13 @@
 
 (* File to include to install the pretty-printers in the ocaml toplevel *)
 
-(* clflags.cmi (a ocaml compilation by-product) must be in the library path.
+(* For OCaml 3.10.x:
+   clflags.cmi (a ocaml compilation by-product) must be in the library path.
    On Debian, install ocaml-compiler-libs, and uncomment the following:
    #directory "+compiler-libs/utils";;
+   Clflags.recursive_types := true;;
 *)
 
-(* Clflags.recursive_types := true;;*)
 #cd ".";;
 #use "base_include";;
 
@@ -22,12 +23,13 @@
 #install_printer  (* type_judgement *) pptype;;
 #install_printer  (* judgement *) ppj;;
 
+#install_printer  (* hint_db *)  print_hint_db;;
 #install_printer  (* goal *)  ppgoal;;
 #install_printer  (* sigma goal *)  ppsigmagoal;;
 #install_printer  (* proof *)  pproof;;
+#install_printer  (* pftreestate *)  pppftreestate;;
 #install_printer  (* metaset.t *) ppmetas;;
 #install_printer  (* evar_map *)  ppevm;;
-#install_printer  (* evar_defs *)  ppevd;;
 #install_printer  (* clenv *) ppclenv;;
 #install_printer  (* env *) ppenv;;
 
@@ -37,4 +39,3 @@
 #install_printer  (* generic_argument *) pp_generic_argument;;
 
 #install_printer  (* fconstr *) ppfconstr;;
-
diff --git a/dev/ocamldebug-coq.template b/dev/ocamldebug-coq.template
index 5f49561b..74320588 100644
--- a/dev/ocamldebug-coq.template
+++ b/dev/ocamldebug-coq.template
@@ -17,13 +17,15 @@ exec $OCAMLDEBUG \
 	-I $COQTOP/library -I $COQTOP/pretyping -I $COQTOP/parsing \
         -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics \
 	-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \
-        -I $COQTOP/contrib/extraction -I $COQTOP/contrib/field \
-        -I $COQTOP/contrib/fourier    -I $COQTOP/contrib/firstorder \
-        -I $COQTOP/contrib/interface  -I $COQTOP/contrib/cc \
-        -I $COQTOP/contrib/omega      -I $COQTOP/contrib/romega \
-        -I $COQTOP/contrib/ring       -I $COQTOP/contrib/xml \
-	-I $COQTOP/contrib/subtac     -I $COQTOP/contrib/funind \
-        -I $COQTOP/contrib/rtauto     -I $COQTOP/contrib/setoid_ring \
-        -I $COQTOP/contrib/recdef     -I $COQTOP/contrib/dp \
+        -I $COQTOP/plugins/cc         -I $COQTOP/plugins/dp \
+        -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \
+        -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \
+        -I $COQTOP/plugins/funind     -I $COQTOP/plugins/groebner \
+        -I $COQTOP/plugins/interface  -I $COQTOP/plugins/micromega \
+        -I $COQTOP/plugins/omega      -I $COQTOP/plugins/quote \
+        -I $COQTOP/plugins/ring       -I $COQTOP/plugins/romega \
+	-I $COQTOP/plugins/rtauto     -I $COQTOP/plugins/setoid_ring \
+        -I $COQTOP/plugins/subtac     -I $COQTOP/plugins/syntax \
+        -I $COQTOP/plugins/xml \
         -I $COQTOP/ide \
 	$*
diff --git a/dev/ocamlopt_shared_os5fix.sh b/dev/ocamlopt_shared_os5fix.sh
new file mode 100755
index 00000000..f7d31ad8
--- /dev/null
+++ b/dev/ocamlopt_shared_os5fix.sh
@@ -0,0 +1,29 @@
+#/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/ocamlweb-doc/Makefile b/dev/ocamlweb-doc/Makefile
index f2c625ed..3189d7c5 100644
--- a/dev/ocamlweb-doc/Makefile
+++ b/dev/ocamlweb-doc/Makefile
@@ -4,14 +4,14 @@ LOCALINCLUDES=-I ../../config -I ../../tools -I ../../tools/coqdoc \
 	      -I ../../scripts -I ../../lib -I ../../kernel -I ../../kernel/byterun -I ../../library \
               -I ../../proofs -I ../../tactics -I ../../pretyping \
               -I ../../interp -I ../../toplevel -I ../../parsing -I ../../ide/utils -I ../../ide \
-              -I ../../contrib/omega -I ../../contrib/romega \
-	      -I ../../contrib/ring -I ../../contrib/dp -I ../../contrib/setoid_ring \
-              -I ../../contrib/xml -I ../../contrib/extraction \
-              -I ../../contrib/interface -I ../../contrib/fourier \
-	      -I ../../contrib/cc \
-	      -I ../../contrib/funind -I ../../contrib/firstorder \
-              -I ../../contrib/field -I ../../contrib/subtac -I ../../contrib/rtauto \
-              -I ../../contrib/recdef
+              -I ../../plugins/omega -I ../../plugins/romega \
+	      -I ../../plugins/ring -I ../../plugins/dp -I ../../plugins/setoid_ring \
+              -I ../../plugins/xml -I ../../plugins/extraction \
+              -I ../../plugins/fourier \
+	      -I ../../plugins/cc \
+	      -I ../../plugins/funind -I ../../plugins/firstorder \
+              -I ../../plugins/field -I ../../plugins/subtac -I ../../plugins/rtauto \
+              -I ../../plugins/recdef
 
 MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
 
diff --git a/dev/ocamlweb-doc/ast.ml b/dev/ocamlweb-doc/ast.ml
index 2153ef47..4eb135d8 100644
--- a/dev/ocamlweb-doc/ast.ml
+++ b/dev/ocamlweb-doc/ast.ml
@@ -22,7 +22,7 @@ type constr_ast =
       (string * binder list * constr_ast * string option * constr_ast) list *
       string
 | Match of case_item list * constr_ast option *
-           (pattern list * constr_ast) list 
+           (pattern list * constr_ast) list
 
 and red_fun = Simpl
 
@@ -34,7 +34,7 @@ and fix_kind = Fix | CoFix
 
 and case_item = constr_ast * (string option * constr_ast option)
 
-and pattern = 
+and pattern =
   PatAs of pattern * string
 | PatType of pattern * constr_ast
 | PatConstr of string * pattern list
diff --git a/dev/ocamlweb-doc/lex.mll b/dev/ocamlweb-doc/lex.mll
index 617163e7..059526d9 100644
--- a/dev/ocamlweb-doc/lex.mll
+++ b/dev/ocamlweb-doc/lex.mll
@@ -7,7 +7,7 @@
 
  let comment_depth = ref 0
  let print s = output_string !chan_out s
- 
+
  exception Fin_fichier
 
 }
@@ -77,5 +77,5 @@ and comment = parse
   | "(*" (*"*)"*)  { incr comment_depth; comment lexbuf }
   | (*"(*"*) "*)"
       { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
-  | eof   { raise Fin_fichier } 
+  | eof   { raise Fin_fichier }
   | _     { comment lexbuf }
diff --git a/dev/ocamlweb-doc/parse.ml b/dev/ocamlweb-doc/parse.ml
index e537b1f2..b145fffd 100644
--- a/dev/ocamlweb-doc/parse.ml
+++ b/dev/ocamlweb-doc/parse.ml
@@ -82,7 +82,7 @@ let rec str_stack = function
   | Term (t,s) -> str_stack s ^ " (" ^ str_ast t ^ ")"
   | Oper(ops,lop,t,s) ->
       str_stack (Term(t,s)) ^ " " ^ lop ^ " " ^
-      String.concat " " (List.rev ops) 
+      String.concat " " (List.rev ops)
 
 let pps s = prerr_endline (str_stack s)
 let err s stk = failwith (s^": "^str_stack stk)
diff --git a/dev/printers.mllib b/dev/printers.mllib
new file mode 100644
index 00000000..e8ec10c5
--- /dev/null
+++ b/dev/printers.mllib
@@ -0,0 +1,133 @@
+Coq_config
+
+Pp_control
+Pp
+Compat
+Flags
+Segmenttree
+Unicodetable
+Util
+Bigint
+Hashcons
+Dyn
+System
+Envars
+Bstack
+Edit
+Gset
+Gmap
+Fset
+Fmap
+Tlm
+Gmapl
+Profile
+Explore
+Predicate
+Rtree
+Heap
+Option
+Dnet
+
+Names
+Univ
+Esubst
+Term
+Mod_subst
+Sign
+Cbytecodes
+Copcodes
+Cemitcodes
+Declarations
+Retroknowledge
+Pre_env
+Cbytegen
+Environ
+Conv_oracle
+Closure
+Reduction
+Type_errors
+Entries
+Modops
+Inductive
+Typeops
+Indtypes
+Cooking
+Term_typing
+Subtyping
+Mod_typing
+Safe_typing
+
+Summary
+Nameops
+Libnames
+Global
+Nametab
+Libobject
+Lib
+Goptions
+Decls
+Heads
+Termops
+Namegen
+Evd
+Rawterm
+Reductionops
+Inductiveops
+Retyping
+Cbv
+Pretype_errors
+Evarutil
+Term_dnet
+Recordops
+Evarconv
+Typing
+Pattern
+Matching
+Tacred
+Classops
+Typeclasses_errors
+Typeclasses
+Detyping
+Indrec
+Coercion
+Unification
+Cases
+Pretyping
+Clenv
+
+Lexer
+Ppextend
+Genarg
+Topconstr
+Notation
+Dumpglob
+Reserve
+Impargs
+Constrextern
+Syntax_def
+Implicit_quantifiers
+Smartlocate
+Constrintern
+Proof_trees
+Tacexpr
+Proof_type
+Logic
+Refiner
+Evar_refiner
+Pfedit
+Tactic_debug
+Decl_mode
+Ppconstr
+Extend
+Extrawit
+Pcoq
+Printer
+Pptactic
+Ppdecl_proof
+Tactic_printer
+Egrammar
+Himsg
+Cerrors
+Vernacexpr
+Vernacinterp
+Top_printers
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index d7d2f6d8..23701c23 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -28,10 +28,11 @@ open Cerrors
 open Evd
 open Goptions
 open Genarg
+open Mod_subst
 
 
 let _ = Constrextern.print_evar_arguments := true
-let _ = set_bool_option_value (SecondaryTable ("Printing","Matching")) false
+let _ = set_bool_option_value ["Printing";"Matching"] false
 let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found)
 
 (* std_ppcmds *)
@@ -40,13 +41,13 @@ let pppp x = pp x
 (* name printers *)
 let ppid id = pp (pr_id id)
 let pplab l = pp (pr_lab l)
-let ppmsid msid = pp (str (debug_string_of_msid msid))
 let ppmbid mbid = pp (str (debug_string_of_mbid mbid))
 let ppdir dir = pp (pr_dirpath dir)
 let ppmp mp = pp(str (string_of_mp mp))
-let ppcon con = pp(pr_con con)
+let ppcon con = pp(debug_pr_con con)
 let ppkn kn = pp(pr_kn kn)
-let ppsp sp = pp(pr_sp sp)
+let ppmind kn = pp(debug_pr_mind kn)
+let ppsp sp = pp(pr_path sp)
 let ppqualid qid = pp(pr_qualid qid)
 let ppclindex cl = pp(Classops.pr_cl_index cl)
 
@@ -65,17 +66,30 @@ let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
 
 let ppbigint n = pp (Bigint.pr_bigint n);;
 
-let prset pr l = str "[" ++ prlist_with_sep spc pr l ++ str "]"
+let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]"
 let ppintset l = pp (prset int (Intset.elements l))
 let ppidset l = pp (prset pr_id (Idset.elements l))
 
+let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]"
+let ppidmap pr l =
+  let pr (id,b) = pr_id id ++ str "=>" ++ pr id b in
+  pp (prset' pr (Idmap.fold (fun a b l -> (a,b)::l) l []))
+
+let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) ->
+  hov 0
+  (Termops.print_constr c ++
+   (match copt with None -> mt () | Some c -> spc () ++ str "<expanded: " ++
+    Termops.print_constr c ++ str">") ++
+   (if id = id0 then mt ()
+    else spc () ++ str "<canonical: " ++ pr_id id ++ str ">"))))
+
 let pP s = pp (hov 0 s)
 
-let safe_pr_global = function 
-  | ConstRef kn -> pp (str "CONSTREF(" ++ pr_con kn ++ str ")")
-  | IndRef (kn,i) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ 
+let safe_pr_global = function
+  | ConstRef kn -> pp (str "CONSTREF(" ++ debug_pr_con kn ++ str ")")
+  | IndRef (kn,i) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++
 			  int i ++ str ")")
-  | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ 
+  | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++
 				      int i ++ str "," ++ int j ++ str ")")
   | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")")
 
@@ -92,6 +106,7 @@ let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t)
 let ppj j = pp (genppj pr_ljudge j)
 
 let prsubst s = pp (Mod_subst.debug_pr_subst s)
+let prdelta s = pp (Mod_subst.debug_pr_delta s)
 
 let pp_idpred s = pp (pr_idpred s)
 let pp_cpred s = pp (pr_cpred s)
@@ -100,9 +115,9 @@ let pp_transparent_state s = pp (pr_transparent_state s)
 (* proof printers *)
 let ppmetas metas = pp(pr_metaset metas)
 let ppevm evd = pp(pr_evar_map evd)
-let ppevd evd = pp(pr_evar_defs evd)
 let ppclenv clenv = pp(pr_clenv clenv)
 let ppgoal g = pp(db_pr_goal g)
+let pppftreestate p = pp(print_pftreestate p)
 
 let pr_gls gls =
   hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls))
@@ -134,7 +149,7 @@ let ppobj obj = Format.print_string (Libobject.object_tag obj)
 
 let cnt = ref 0
 
-let cast_kind_display k = 
+let cast_kind_display k =
   match k with
   | VMcast -> "VMcast"
   | DEFAULTcast -> "DEFAULTcast"
@@ -145,7 +160,7 @@ let constr_display csr =
   | Meta n -> "Meta("^(string_of_int n)^")"
   | Var id -> "Var("^(string_of_id id)^")"
   | Sort s -> "Sort("^(sort_display s)^")"
-  | Cast (c,k, t) -> 
+  | Cast (c,k, t) ->
       "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")"
   | Prod (na,t,c) ->
       "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n"
@@ -158,9 +173,9 @@ let constr_display csr =
   | Evar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")"
   | Const c -> "Const("^(string_of_con c)^")"
   | Ind (sp,i) ->
-      "MutInd("^(string_of_kn sp)^","^(string_of_int i)^")"
+      "MutInd("^(string_of_mind sp)^","^(string_of_int i)^")"
   | Construct ((sp,i),j) ->
-      "MutConstruct(("^(string_of_kn sp)^","^(string_of_int i)^"),"
+      "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^"),"
       ^(string_of_int j)^")"
   | Case (ci,p,c,bl) ->
       "MutCase(<abs>,"^(term_display p)^","^(term_display c)^","
@@ -212,25 +227,25 @@ let print_pure_constr csr =
       print_string "::"; (term_display t); print_string ")"; close_box()
   | Prod (Name(id),t,c) ->
       open_hovbox 1;
-      print_string"("; print_string (string_of_id id); 
-      print_string ":"; box_display t; 
-      print_string ")"; print_cut(); 
+      print_string"("; print_string (string_of_id id);
+      print_string ":"; box_display t;
+      print_string ")"; print_cut();
       box_display c; close_box()
   | Prod (Anonymous,t,c) ->
       print_string"("; box_display t; print_cut(); print_string "->";
-      box_display c; print_string ")"; 
+      box_display c; print_string ")";
   | Lambda (na,t,c) ->
       print_string "["; name_display na;
       print_string ":"; box_display t; print_string "]";
-      print_cut(); box_display c; 
+      print_cut(); box_display c;
   | LetIn (na,b,t,c) ->
-      print_string "["; name_display na; print_string "="; 
+      print_string "["; name_display na; print_string "=";
       box_display b; print_cut();
       print_string ":"; box_display t; print_string "]";
-      print_cut(); box_display c; 
-  | App (c,l) -> 
-      print_string "("; 
-      box_display c; 
+      print_cut(); box_display c;
+  | App (c,l) ->
+      print_string "(";
+      box_display c;
       Array.iter (fun x -> print_space (); box_display x) l;
       print_string ")"
   | Evar (e,l) -> print_string "Evar#"; print_int e; print_string "{";
@@ -257,25 +272,25 @@ let print_pure_constr csr =
       open_vbox 0;
       Array.iter (fun x ->  print_cut();  box_display x) bl;
       close_box();
-      print_cut(); 
-      print_string "end"; 
+      print_cut();
+      print_string "end";
       close_box()
   | Fix ((t,i),(lna,tl,bl)) ->
-      print_string "Fix("; print_int i; print_string ")"; 
+      print_string "Fix("; print_int i; print_string ")";
       print_cut();
       open_vbox 0;
       let rec print_fix () =
         for k = 0 to (Array.length tl) - 1 do
 	  open_vbox 0;
-	  name_display lna.(k); print_string "/"; 
+	  name_display lna.(k); print_string "/";
 	  print_int t.(k); print_cut(); print_string ":";
 	  box_display tl.(k) ; print_cut(); print_string ":=";
 	  box_display bl.(k); close_box ();
 	  print_cut()
         done
-      in print_string"{"; print_fix(); print_string"}" 
+      in print_string"{"; print_fix(); print_string"}"
   | CoFix(i,(lna,tl,bl)) ->
-      print_string "CoFix("; print_int i; print_string ")"; 
+      print_string "CoFix("; print_int i; print_string ")";
       print_cut();
       open_vbox 0;
       let rec print_fix () =
@@ -300,27 +315,27 @@ let print_pure_constr csr =
     | Name id -> print_string (string_of_id id)
     | Anonymous -> print_string "_"
 (* Remove the top names for library and Scratch to avoid long names *)
-  and sp_display sp = 
+  and sp_display sp =
 (*    let dir,l = decode_kn sp in
-    let ls = 
-      match List.rev (List.map string_of_id (repr_dirpath dir)) with 
+    let ls =
+      match List.rev (List.map string_of_id (repr_dirpath dir)) with
           ("Top"::l)-> l
-	| ("Coq"::_::l) -> l 
+	| ("Coq"::_::l) -> l
 	| l             -> l
     in  List.iter (fun x -> print_string x; print_string ".") ls;*)
-      print_string (string_of_kn sp)
-  and sp_con_display sp = 
+      print_string (debug_string_of_mind sp)
+  and sp_con_display sp =
 (*    let dir,l = decode_kn sp in
-    let ls = 
-      match List.rev (List.map string_of_id (repr_dirpath dir)) with 
+    let ls =
+      match List.rev (List.map string_of_id (repr_dirpath dir)) with
           ("Top"::l)-> l
-	| ("Coq"::_::l) -> l 
+	| ("Coq"::_::l) -> l
 	| l             -> l
     in  List.iter (fun x -> print_string x; print_string ".") ls;*)
-      print_string (string_of_con sp)
+      print_string (debug_string_of_con sp)
 
   in
-    try 
+    try
      box_display csr; print_flush()
     with e ->
 	print_string (Printexc.to_string e);print_flush ();
@@ -369,7 +384,7 @@ let pp_generic_argument arg =
 (* Vernac-level debugging commands                                    *)
 
 let in_current_context f c =
-  let (evmap,sign) = 
+  let (evmap,sign) =
     try Pfedit.get_current_goal_context ()
     with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in
   f (Constrintern.interp_constr evmap sign c)
@@ -400,12 +415,10 @@ let _ =
     e -> Pp.pp (Cerrors.explain_exn e)
 let _ =
   extend_vernac_command_grammar "PrintConstr"
-    [[TacTerm "PrintConstr";
-      TacNonTerm
-        (dummy_loc,
-         (Gramext.Snterm (Pcoq.Gram.Entry.obj Constr.constr),
-          ConstrArgType),
-         Some "c")]]
+    [[GramTerminal "PrintConstr";
+      GramNonTerminal
+        (dummy_loc,ConstrArgType,Extend.Aentry ("constr","constr"),
+	 Some (Names.id_of_string "c"))]]
 
 let _ =
   try
@@ -419,12 +432,10 @@ let _ =
     e -> Pp.pp (Cerrors.explain_exn e)
 let _ =
   extend_vernac_command_grammar "PrintPureConstr"
-    [[TacTerm "PrintPureConstr";
-      TacNonTerm
-        (dummy_loc,
-         (Gramext.Snterm (Pcoq.Gram.Entry.obj Constr.constr),
-          ConstrArgType),
-         Some "c")]]
+    [[GramTerminal "PrintPureConstr";
+      GramNonTerminal
+        (dummy_loc,ConstrArgType,Extend.Aentry ("constr","constr"),
+	 Some (Names.id_of_string "c"))]]
 
 (* Setting printer of unbound global reference *)
 open Names
@@ -434,38 +445,38 @@ open Libnames
 let encode_path loc prefix mpdir suffix id =
   let dir = match mpdir with
     | None -> []
-    | Some (mp,dir) -> 
+    | Some (mp,dir) ->
 	(repr_dirpath (dirpath_of_string (string_of_mp mp))@
 	repr_dirpath dir) in
-  Qualid (loc, make_qualid 
+  Qualid (loc, make_qualid
     (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id)
 
 let raw_string_of_ref loc = function
-  | ConstRef cst -> 
+  | ConstRef cst ->
       let (mp,dir,id) = repr_con cst in
       encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id)
   | IndRef (kn,i) ->
-      let (mp,dir,id) = repr_kn kn in
-      encode_path loc "IND" (Some (mp,dir)) [id_of_label id] 
+      let (mp,dir,id) = repr_mind kn in
+      encode_path loc "IND" (Some (mp,dir)) [id_of_label id]
 	(id_of_string ("_"^string_of_int i))
-  | ConstructRef ((kn,i),j) -> 
-      let (mp,dir,id) = repr_kn kn in
+  | ConstructRef ((kn,i),j) ->
+      let (mp,dir,id) = repr_mind kn in
       encode_path loc "CSTR" (Some (mp,dir))
-	[id_of_label id;id_of_string ("_"^string_of_int i)] 
+	[id_of_label id;id_of_string ("_"^string_of_int i)]
 	(id_of_string ("_"^string_of_int j))
-  | VarRef id -> 
+  | VarRef id ->
       encode_path loc "SECVAR" None [] id
 
 let short_string_of_ref loc = function
   | VarRef id -> Ident (loc,id)
   | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst)))
-  | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_kn kn)))
+  | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn)))
   | IndRef (kn,i) ->
-      encode_path loc "IND" None [id_of_label (pi3 (repr_kn kn))]
+      encode_path loc "IND" None [id_of_label (pi3 (repr_mind kn))]
         (id_of_string ("_"^string_of_int i))
-  | ConstructRef ((kn,i),j) -> 
-      encode_path loc "CSTR" None 
-        [id_of_label (pi3 (repr_kn kn));id_of_string ("_"^string_of_int i)]
+  | ConstructRef ((kn,i),j) ->
+      encode_path loc "CSTR" None
+        [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)]
         (id_of_string ("_"^string_of_int j))
 
 let _ = Constrextern.set_debug_global_reference_printer
diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex
index de68ce1e..46ba24da 100644
--- a/dev/v8-syntax/syntax-v8.tex
+++ b/dev/v8-syntax/syntax-v8.tex
@@ -744,28 +744,28 @@ Conflicts exists between integers and constrs.
 \nlsep \TERM{simplif}
 \nlsep \TERM{intuition}~\OPT{\NTL{tactic}{0}}
 \nlsep \TERM{linearintuition}~\OPT{\NT{num}}
-%% contrib/cc
+%% plugins/cc
 \nlsep \TERM{cc}
-%% contrib/field
+%% plugins/field
 \nlsep \TERM{field}~\STAR{\tacconstr}
-%% contrib/firstorder
+%% plugins/firstorder
 \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}
 \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{with}~\PLUS{\NT{reference}}
 \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{using}~\PLUS{\NT{ident}}
 %%\nlsep \TERM{gtauto}
 \nlsep \TERM{gintuition}~\OPT{\NTL{tactic}{0}}
-%% contrib/fourier
+%% plugins/fourier
 \nlsep \TERM{fourierZ}
-%% contrib/funind
+%% plugins/funind
 \nlsep \TERM{functional}~\TERM{induction}~\tacconstr~\PLUS{\tacconstr}
-%% contrib/jprover
+%% plugins/jprover
 \nlsep \TERM{jp}~\OPT{\NT{num}}
-%% contrib/omega
+%% plugins/omega
 \nlsep \TERM{omega}
-%% contrib/ring
+%% plugins/ring
 \nlsep \TERM{quote}~\NT{ident}~\OPTGR{\KWD{[}~\PLUS{\NT{ident}}~\KWD{]}}
 \nlsep \TERM{ring}~\STAR{\tacconstr}
-%% contrib/romega
+%% plugins/romega
 \nlsep \TERM{romega}
 \SEPDEF
 \DEFNT{orient}
diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml
index 1e114489..59545d8a 100644
--- a/dev/vm_printers.ml
+++ b/dev/vm_printers.ml
@@ -7,10 +7,10 @@ open Vm
 
 let ppripos (ri,pos) =
   (match ri with
-  | Reloc_annot a -> 
+  | Reloc_annot a ->
       let sp,i = a.ci.ci_ind in
-      print_string 
-	("annot : MutInd("^(string_of_kn sp)^","^(string_of_int i)^")\n")
+      print_string
+	("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n")
   | Reloc_const _ ->
       print_string "structured constant\n"
   | Reloc_getglobal kn ->
@@ -29,8 +29,8 @@ let ppsort = function
 
 
 let print_idkey idk =
-  match idk with 
-  | ConstKey sp -> 
+  match idk with
+  | ConstKey sp ->
       print_string "Cons(";
       print_string (string_of_con sp);
       print_string ")"
@@ -38,8 +38,8 @@ let print_idkey idk =
   | RelKey i -> print_string "~";print_int i
 
 let rec ppzipper z =
-  match z with 
-  | Zapp args -> 
+  match z with
+  | Zapp args ->
       let n = nargs args in
       open_hbox ();
       for i = 0 to n-2 do
@@ -50,7 +50,7 @@ let rec ppzipper z =
   | Zfix _ -> print_string "Zfix"
   | Zswitch _ -> print_string "Zswitch"
 
-and ppstack s = 
+and ppstack s =
   open_hovbox 0;
   print_string "[";
   List.iter (fun z -> ppzipper z;print_string " | ") s;
@@ -62,19 +62,19 @@ and ppatom a =
   | Aid idk -> print_idkey idk
   | Aiddef(idk,_) -> print_string "&";print_idkey idk
   | Aind(sp,i) ->  print_string "Ind(";
-      print_string (string_of_kn sp);
+      print_string (string_of_mind sp);
       print_string ","; print_int i;
       print_string ")"
 
 and ppwhd whd =
-  match whd with 
+  match whd with
   | Vsort s -> ppsort s
   | Vprod _ -> print_string "product"
   | Vfun _ -> print_string "function"
   | Vfix _ -> print_vfix()
   | Vcofix _ -> print_string "cofix"
   | Vconstr_const i -> print_string "C(";print_int i;print_string")"
-  | Vconstr_block b -> ppvblock b      
+  | Vconstr_block b -> ppvblock b
   | Vatom_stk(a,s) ->
       open_hbox();ppatom a;close_box();
       print_string"@";ppstack s
diff --git a/doc/common/styles/html/simple/header.html b/doc/common/styles/html/simple/header.html
deleted file mode 100644
index 14d2f988..00000000
--- a/doc/common/styles/html/simple/header.html
+++ /dev/null
@@ -1,13 +0,0 @@
-<!DOCTYPE html 
-     PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
-    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
-<head>
-<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/>
-<link rel="stylesheet" href="coqdoc.css" type="text/css"/>
-<title>The Coq Standard Library</title>
-</head>
-
-<body>
-
diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex
index 61fa253c..f5509c3a 100755
--- a/doc/stdlib/Library.tex
+++ b/doc/stdlib/Library.tex
@@ -1,6 +1,6 @@
 \documentclass[11pt]{report}
 
-\usepackage[latin1]{inputenc}
+\usepackage[utf8x]{inputenc}
 \usepackage[T1]{fontenc}
 \usepackage{fullpage}
 \usepackage[color]{../../coqdoc}
@@ -61,4 +61,4 @@ you can access from the \Coq\ home page at
 
 \end{document}
 
-% $Id: Library.tex 11576 2008-11-10 19:13:15Z msozeau $ 
+% $Id$ 
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index 484002c3..7a24846b 100644
--- a/doc/stdlib/index-list.html.template
+++ b/doc/stdlib/index-list.html.template
@@ -1,5 +1,17 @@
+<!DOCTYPE html 
+     PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 
-<h1>The Coq Standard Library</h1>
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/>
+<link rel="stylesheet" href="css/context.css" type="text/css"/>
+<title>The Coq Standard Library</title>
+</head>
+
+<body>
+
+<H1>The Coq Standard Library</H1>
 
 <p>Here is a short description of the Coq standard library, which is
 distributed with the system.
@@ -36,8 +48,6 @@ through the <tt>Require Import</tt> command.</p>
     (theories/Logic/Classical.v)
     theories/Logic/ClassicalFacts.v
     theories/Logic/Decidable.v
-    theories/Logic/DecidableType.v
-    theories/Logic/DecidableTypeEx.v
     theories/Logic/Eqdep_dec.v
     theories/Logic/EqdepFacts.v
     theories/Logic/Eqdep.v
@@ -60,6 +70,27 @@ through the <tt>Require Import</tt> command.</p>
     theories/Logic/FunctionalExtensionality.v
   </dd>
     
+  <dt> <b>Structures</b>:
+       Algebraic structures (types with equality, with order, ...).
+       DecidableType* and OrderedType* are there only for compatibility.
+  </dt>
+  <dd>
+    theories/Structures/Equalities.v
+    theories/Structures/EqualitiesFacts.v
+    theories/Structures/Orders.v
+    theories/Structures/OrdersTac.v
+    theories/Structures/OrdersAlt.v
+    theories/Structures/OrdersEx.v
+    theories/Structures/OrdersFacts.v
+    theories/Structures/OrdersLists.v
+    theories/Structures/GenericMinMax.v
+    theories/Structures/DecidableType.v
+    theories/Structures/DecidableTypeEx.v
+    theories/Structures/OrderedType.v
+    theories/Structures/OrderedTypeAlt.v
+    theories/Structures/OrderedTypeEx.v
+  </dd>
+
   <dt> <b>Bool</b>:
        Booleans (basic functions and results)
   </dt>
@@ -90,6 +121,7 @@ through the <tt>Require Import</tt> command.</p>
     (theories/Arith/Arith.v)
     theories/Arith/Min.v
     theories/Arith/Max.v
+    theories/Arith/MinMax.v
     theories/Arith/Compare.v
     theories/Arith/Div2.v
     theories/Arith/EqNat.v
@@ -98,6 +130,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Arith/Bool_nat.v
     theories/Arith/Factorial.v
     theories/Arith/Wf_nat.v
+    theories/Arith/NatOrderedType.v
   </dd>
     
   <dt> <b>NArith</b>:
@@ -112,6 +145,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/NArith/Ndigits.v
     theories/NArith/Ndist.v
     theories/NArith/Ndec.v
+    theories/NArith/NOrderedType.v
+    theories/NArith/Nminmax.v
+    theories/NArith/POrderedType.v
+    theories/NArith/Pminmax.v
   </dd>
 
   <dt> <b>ZArith</b>:
@@ -143,12 +180,13 @@ through the <tt>Require Import</tt> command.</p>
     (theories/ZArith/ZArith.v)
     theories/ZArith/Zgcd_alt.v
     theories/ZArith/Zwf.v
-    theories/ZArith/Zbinary.v
     theories/ZArith/Znumtheory.v
     theories/ZArith/Int.v
     theories/ZArith/ZOdiv_def.v
     theories/ZArith/ZOdiv.v
     theories/ZArith/Zpow_facts.v
+    theories/ZArith/ZOrderedType.v
+    theories/ZArith/Zdigits.v
   </dd>
 
   <dt> <b>QArith</b>:
@@ -165,89 +203,117 @@ through the <tt>Require Import</tt> command.</p>
     theories/QArith/Qreals.v
     theories/QArith/Qcanon.v
     theories/QArith/Qround.v
+    theories/QArith/QOrderedType.v
+    theories/QArith/Qminmax.v
   </dd>
 
   <dt> <b>Numbers</b>: 
-    A modular axiomatic construction for numbers
+    An experimental modular architecture for arithmetic
   </dt>
-  <dd>
-  theories/Numbers/NumPrelude.v
-  theories/Numbers/BigNumPrelude.v
-  theories/Numbers/NaryFunctions.v
-  </dd>
-  
-  <dd>
-theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
-theories/Numbers/Cyclic/Abstract/NZCyclic.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
-theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
-theories/Numbers/Cyclic/Int31/Cyclic31.v
-theories/Numbers/Cyclic/Int31/Int31.v
-theories/Numbers/Cyclic/ZModulo/ZModulo.v
-  </dd>
+    <dt> <b>&nbsp;&nbsp;Prelude</b>: 
+    <dd>
+    theories/Numbers/NumPrelude.v
+    theories/Numbers/BigNumPrelude.v
+    theories/Numbers/NaryFunctions.v
+    </dd>
 
-  <dd>
-    theories/Numbers/Integer/Abstract/ZAdd.v
-theories/Numbers/Integer/Abstract/ZAddOrder.v
-theories/Numbers/Integer/Abstract/ZAxioms.v
-theories/Numbers/Integer/Abstract/ZBase.v
-theories/Numbers/Integer/Abstract/ZDomain.v
-theories/Numbers/Integer/Abstract/ZLt.v
-theories/Numbers/Integer/Abstract/ZMul.v
-theories/Numbers/Integer/Abstract/ZMulOrder.v
-theories/Numbers/Integer/BigZ/BigZ.v
-theories/Numbers/Integer/BigZ/ZMake.v
-theories/Numbers/Integer/Binary/ZBinary.v
-theories/Numbers/Integer/NatPairs/ZNatPairs.v
-theories/Numbers/Integer/SpecViaZ/ZSig.v
-theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
-  </dd>
+    <dt> <b>&nbsp;&nbsp;NatInt</b>:
+       Abstract mixed natural/integer/cyclic arithmetic
+    <dd>
+    theories/Numbers/NatInt/NZAdd.v
+    theories/Numbers/NatInt/NZAddOrder.v
+    theories/Numbers/NatInt/NZAxioms.v
+    theories/Numbers/NatInt/NZBase.v
+    theories/Numbers/NatInt/NZMul.v
+    theories/Numbers/NatInt/NZDiv.v
+    theories/Numbers/NatInt/NZMulOrder.v
+    theories/Numbers/NatInt/NZOrder.v
+    theories/Numbers/NatInt/NZDomain.v
+    theories/Numbers/NatInt/NZProperties.v
+    </dd>
+    </dt>
 
-  <dd>
-theories/Numbers/NatInt/NZAdd.v
-theories/Numbers/NatInt/NZAddOrder.v
-theories/Numbers/NatInt/NZAxioms.v
-theories/Numbers/NatInt/NZBase.v
-theories/Numbers/NatInt/NZMul.v
-theories/Numbers/NatInt/NZMulOrder.v
-theories/Numbers/NatInt/NZOrder.v
-  </dd>
+    <dt> <b>&nbsp;&nbsp;Cyclic</b>: 
+       Abstract and 31-bits-based cyclic arithmetic
+    <dd>
+    theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
+    theories/Numbers/Cyclic/Abstract/NZCyclic.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
+    theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
+    theories/Numbers/Cyclic/Int31/Cyclic31.v
+    theories/Numbers/Cyclic/Int31/Ring31.v
+    theories/Numbers/Cyclic/Int31/Int31.v
+    theories/Numbers/Cyclic/ZModulo/ZModulo.v
+    </dd>
+    </dt>
 
-  <dd>
-theories/Numbers/Natural/Abstract/NAdd.v
-theories/Numbers/Natural/Abstract/NAddOrder.v
-theories/Numbers/Natural/Abstract/NAxioms.v
-theories/Numbers/Natural/Abstract/NBase.v
-theories/Numbers/Natural/Abstract/NDefOps.v
-theories/Numbers/Natural/Abstract/NIso.v
-theories/Numbers/Natural/Abstract/NMul.v
-theories/Numbers/Natural/Abstract/NMulOrder.v
-theories/Numbers/Natural/Abstract/NOrder.v
-theories/Numbers/Natural/Abstract/NStrongRec.v
-theories/Numbers/Natural/Abstract/NSub.v
-theories/Numbers/Natural/BigN/BigN.v
-theories/Numbers/Natural/BigN/Nbasic.v
-theories/Numbers/Natural/BigN/NMake.v
-theories/Numbers/Natural/Binary/NBinary.v
-theories/Numbers/Natural/Binary/NBinDefs.v
-theories/Numbers/Natural/Peano/NPeano.v
-theories/Numbers/Natural/SpecViaZ/NSig.v
-theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
-  </dd>
+    <dt> <b>&nbsp;&nbsp;Natural</b>: 
+       Abstract and 31-bits-words-based natural arithmetic
+    <dd>
+    theories/Numbers/Natural/Abstract/NAdd.v
+    theories/Numbers/Natural/Abstract/NAddOrder.v
+    theories/Numbers/Natural/Abstract/NAxioms.v
+    theories/Numbers/Natural/Abstract/NBase.v
+    theories/Numbers/Natural/Abstract/NDefOps.v
+    theories/Numbers/Natural/Abstract/NIso.v
+    theories/Numbers/Natural/Abstract/NMulOrder.v
+    theories/Numbers/Natural/Abstract/NOrder.v
+    theories/Numbers/Natural/Abstract/NStrongRec.v
+    theories/Numbers/Natural/Abstract/NSub.v
+    theories/Numbers/Natural/Abstract/NDiv.v
+    theories/Numbers/Natural/Abstract/NProperties.v
+    theories/Numbers/Natural/Binary/NBinary.v
+    theories/Numbers/Natural/Peano/NPeano.v
+    theories/Numbers/Natural/SpecViaZ/NSig.v
+    theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
+    theories/Numbers/Natural/BigN/BigN.v
+    theories/Numbers/Natural/BigN/Nbasic.v
+    theories/Numbers/Natural/BigN/NMake.v
+    theories/Numbers/Natural/BigN/NMake_gen.v
+    </dd>
+    </dt>
 
-  <dd>
+    <dt> <b>&nbsp;&nbsp;Integer</b>: 
+       Abstract and concrete (especially 31-bits-words-based) integer arithmetic
+    <dd>
+    theories/Numbers/Integer/Abstract/ZAdd.v
+    theories/Numbers/Integer/Abstract/ZAddOrder.v
+    theories/Numbers/Integer/Abstract/ZAxioms.v
+    theories/Numbers/Integer/Abstract/ZBase.v
+    theories/Numbers/Integer/Abstract/ZLt.v
+    theories/Numbers/Integer/Abstract/ZMul.v
+    theories/Numbers/Integer/Abstract/ZMulOrder.v
+    theories/Numbers/Integer/Abstract/ZDivEucl.v
+    theories/Numbers/Integer/Abstract/ZDivFloor.v
+    theories/Numbers/Integer/Abstract/ZDivTrunc.v
+    theories/Numbers/Integer/Abstract/ZProperties.v
+    theories/Numbers/Integer/Abstract/ZSgnAbs.v
+    theories/Numbers/Integer/Binary/ZBinary.v
+    theories/Numbers/Integer/NatPairs/ZNatPairs.v
+    theories/Numbers/Integer/SpecViaZ/ZSig.v
+    theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
+    theories/Numbers/Integer/BigZ/BigZ.v
+    theories/Numbers/Integer/BigZ/ZMake.v
+    </dd>
+    </dt>
+
+    <dt><b>&nbsp;&nbsp;Rational</b>:
+       Abstract and 31-bits-words-based rational arithmetic
+    <dd>
+    theories/Numbers/Rational/SpecViaQ/QSig.v
     theories/Numbers/Rational/BigQ/BigQ.v
     theories/Numbers/Rational/BigQ/QMake.v
-    theories/Numbers/Rational/SpecViaQ/QSig.v
-  </dd>
+    </dd>
+    </dt>
+  </dt>
   
   <dt> <b>Relations</b>:
        Relations (definitions and basic results)
@@ -257,10 +323,6 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/Relations/Relation_Operators.v
     theories/Relations/Relations.v
     theories/Relations/Operators_Properties.v
-<!-- Deprecated 
-    theories/Relations/Rstar.v
-    theories/Relations/Newman.v
--->
   </dd>
     
   <dt> <b>Sets</b>:
@@ -300,15 +362,13 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/Classes/Morphisms_Relations.v
     theories/Classes/Equivalence.v
     theories/Classes/EquivDec.v
-    theories/Classes/Functions.v
     theories/Classes/SetoidTactics.v
     theories/Classes/SetoidClass.v
     theories/Classes/SetoidDec.v
-    theories/Classes/SetoidAxioms.v
+    theories/Classes/RelationPairs.v
   </dd>
 
   <dt> <b>Setoids</b>:
-
   <dd> 
     theories/Setoids/Setoid.v
   </dd>
@@ -319,7 +379,6 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
   <dd> 
     theories/Lists/List.v
     theories/Lists/ListSet.v
-    theories/Lists/MonoList.v
     theories/Lists/SetoidList.v
     theories/Lists/Streams.v
     theories/Lists/StreamMemo.v
@@ -336,6 +395,8 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/Sorting/Sorting.v
     theories/Sorting/PermutEq.v
     theories/Sorting/PermutSetoid.v
+    theories/Sorting/Mergesort.v
+    theories/Sorting/Sorted.v
   </dd>
 
   <dt> <b>Wellfounded</b>:
@@ -352,15 +413,31 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/Wellfounded/Wellfounded.v
     theories/Wellfounded/Well_Ordering.v
   </dd>
-    
+
+  <dt> <b>MSets</b>:
+    Modular implementation of finite sets using lists or
+    efficient trees. This is a modernization of FSets.
+  </dt>
+  <dd>
+    theories/MSets/MSetInterface.v
+    theories/MSets/MSetFacts.v
+    theories/MSets/MSetDecide.v
+    theories/MSets/MSetProperties.v
+    theories/MSets/MSetEqProperties.v
+    theories/MSets/MSetWeakList.v
+    theories/MSets/MSetList.v
+    theories/MSets/MSetAVL.v
+    theories/MSets/MSetPositive.v
+    theories/MSets/MSetToFiniteSet.v
+    (theories/MSets/MSets.v)
+  </dd>
+
   <dt> <b>FSets</b>:
     Modular implementation of finite sets/maps using lists or
-    efficient trees
+    efficient trees. For sets, please consider the more
+    modern MSets.
   </dt>
   <dd>
-    theories/FSets/OrderedType.v
-    theories/FSets/OrderedTypeAlt.v
-    theories/FSets/OrderedTypeEx.v
     theories/FSets/FSetInterface.v
     theories/FSets/FSetBridge.v
     theories/FSets/FSetFacts.v
@@ -369,8 +446,10 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/FSets/FSetEqProperties.v
     theories/FSets/FSetList.v
     theories/FSets/FSetWeakList.v
-    (theories/FSets/FSets.v)
+    theories/FSets/FSetCompat.v
     theories/FSets/FSetAVL.v
+    theories/FSets/FSetPositive.v
+    (theories/FSets/FSets.v)
     theories/FSets/FSetToFiniteSet.v
     theories/FSets/FMapInterface.v
     theories/FSets/FMapWeakList.v
@@ -379,7 +458,6 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/FSets/FMapFacts.v
     (theories/FSets/FMaps.v)
     theories/FSets/FMapAVL.v
-    theories/FSets/FSetFullAVL.v
     theories/FSets/FMapFullAVL.v
   </dd>
 
@@ -399,6 +477,8 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
     theories/Reals/Raxioms.v
     theories/Reals/RIneq.v
     theories/Reals/DiscrR.v
+    theories/Reals/ROrderedType.v
+    theories/Reals/Rminmax.v
     (theories/Reals/Rbase.v)
     theories/Reals/RList.v
     theories/Reals/Ranalysis.v
diff --git a/doc/common/styles/html/simple/footer.html b/doc/stdlib/index-trailer.html
index 308b1d01..308b1d01 100644
--- a/doc/common/styles/html/simple/footer.html
+++ b/doc/stdlib/index-trailer.html
diff --git a/doc/stdlib/make-library-files b/doc/stdlib/make-library-files
index 9516a19f..39cedbec 100755
--- a/doc/stdlib/make-library-files
+++ b/doc/stdlib/make-library-files
@@ -10,7 +10,7 @@
 # En supposant que make fait son boulot, ca fait un tri topologique du
 # graphe des dépendances
 
-LIBDIRS="Arith NArith ZArith Reals Logic Bool Lists Relations Sets Sorting Wellfounded Setoids Program Classes"
+LIBDIRS="Arith NArith ZArith Reals Logic Bool Lists Relations Sets Sorting Wellfounded Setoids Program Classes Numbers"
 
 rm -f library.files.ls.tmp
 (cd $COQSRC/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp
diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index
index 04bcff91..c8782e93 100755
--- a/doc/stdlib/make-library-index
+++ b/doc/stdlib/make-library-index
@@ -7,7 +7,7 @@ FILE=$1
 cp -f $FILE.template tmp
 echo -n Building file index-list.prehtml ...
 
-LIBDIRS="Init Logic Bool Arith NArith ZArith QArith Relations Sets Classes Setoids Lists Sorting Wellfounded FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" 
+LIBDIRS="Init Logic Structures Bool Arith NArith ZArith QArith Relations Sets Classes Setoids Lists Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" 
 
 for k in $LIBDIRS; do
     i=theories/$k
diff --git a/ide/blaster_window.ml b/ide/blaster_window.ml
deleted file mode 100644
index f3cb1e60..00000000
--- a/ide/blaster_window.ml
+++ /dev/null
@@ -1,178 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: blaster_window.ml 8912 2006-06-07 11:20:58Z notin $ *)
-
-open Gobject.Data
-open Ideutils
-
-exception Stop
-exception Done
-
-module MyMap = Map.Make (struct type t = string let compare = compare end)
-
-class blaster_window (n:int) = 
-  let window = GWindow.window 
-		 ~allow_grow:true ~allow_shrink:true 
-		 ~width:320 ~height:200
-		 ~title:"Blaster Window" ~show:false ()
-  in
-  let box1 = GPack.vbox ~packing:window#add () in
-  let sw = GBin.scrolled_window ~packing:(box1#pack ~expand:true ~fill:true) () in
-
-  let cols = new GTree.column_list in
-  let argument = cols#add string in
-  let tactic = cols#add string in
-  let status = cols#add boolean in
-  let nb_goals = cols#add string in
-  
-  let model = GTree.tree_store cols in
-  let new_arg s =
-    let row = model#append () in
-    model#set ~row ~column:argument s;
-    row
-  in
-  let new_tac arg s =  
-    let row = model#append ~parent:arg () in
-    model#set ~row ~column:tactic s;
-    model#set ~row ~column:status false;
-    model#set ~row ~column:nb_goals "?";
-    row
-  in
-  let view = GTree.view ~model ~packing:sw#add () in
-  let _ = view#selection#set_mode `SINGLE in
-  let _ = view#set_rules_hint true in
-
-  let col = GTree.view_column ~title:"Argument" ()
-	      ~renderer:(GTree.cell_renderer_text [], ["text",argument]) in
-  let _ = view#append_column col in
-  let col = GTree.view_column ~title:"Tactics" ()
-	      ~renderer:(GTree.cell_renderer_text [], ["text",tactic]) in
-  let _ = view#append_column col in
-  let col = GTree.view_column ~title:"Status" ()
-	      ~renderer:(GTree.cell_renderer_toggle [], ["active",status]) in
-  let _ = view#append_column col in
-  let col = GTree.view_column ~title:"Delta Goal" ()
-	      ~renderer:(GTree.cell_renderer_text [], ["text",nb_goals]) in
-  let _ = view#append_column col in 
-
-  let _ = GMisc.separator `HORIZONTAL ~packing:box1#pack () in
-  
-  let box2 = GPack.vbox ~spacing: 10 ~border_width: 10 ~packing: box1#pack () 
-  in
-  let button_stop = GButton.button ~label: "Stop" ~packing: box2#add () in
-  let _ = button_stop#connect#clicked ~callback: window#misc#hide in
-
-object(self)
-  val window = window
-  val roots = Hashtbl.create 17
-  val mutable tbl = MyMap.empty 
-  val blaster_lock = Mutex.create () 
-  method lock = blaster_lock 
-  val blaster_killed = Condition.create () 
-  method blaster_killed = blaster_killed
-  method window = window
-  method set root name (compute:unit -> Coq.tried_tactic) (on_click:unit -> unit) = 
-    let root_iter = 
-      try Hashtbl.find roots root 
-      with Not_found -> 
-	let nr = new_arg root in
-	  Hashtbl.add roots root nr;
-	  nr
-    in
-    let nt = new_tac root_iter name in
-    let old_val = try MyMap.find root tbl with Not_found -> MyMap.empty in
-      tbl <- MyMap.add root (MyMap.add name (nt,compute,on_click) old_val) tbl
-
-  method clear () = 
-    model#clear ();      
-    tbl <- MyMap.empty;
-    Hashtbl.clear roots;
-    
-  method blaster () = 
-    view#expand_all ();
-    try MyMap.iter 
-      (fun root_name l ->
-	 try 
-	   MyMap.iter 
-	     (fun name (nt,compute,on_click) ->  
-		match compute () with 
-		  | Coq.Interrupted -> 
-		      prerr_endline "Interrupted";
-		      raise Stop
-		  | Coq.Failed -> 
-		      prerr_endline "Failed";
-		      ignore (model#remove nt)
-			(*	       model#set ~row:nt ~column:status false;
-				       model#set ~row:nt ~column:nb_goals "N/A"
-			*)
-		  | Coq.Success n -> 
-		      prerr_endline "Success";
-		      model#set ~row:nt ~column:status true;
-		      model#set ~row:nt ~column:nb_goals (string_of_int n);
-		      if n= -1 then raise Done 
-	     )
-	     l
-	 with Done -> ())
-      tbl;
-      Condition.signal blaster_killed;
-      prerr_endline "End of blaster";
-    with Stop ->
-      Condition.signal blaster_killed;
-      prerr_endline "End of blaster (stopped !)";
-
-  initializer 
-    ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));
-    ignore (view#selection#connect#after#changed ~callback:
-	      begin fun () ->
-		prerr_endline "selection changed";
-		List.iter 
-		  (fun path ->let pt = GtkTree.TreePath.to_string path in
-		     let it = model#get_iter path in
-		     prerr_endline (string_of_bool (model#iter_is_valid it));
-		     let name = model#get 
-				  ~row:(if String.length pt >1 then begin
-					  ignore (GtkTree.TreePath.up path);
-					  model#get_iter path
-					end else it
-				       ) 
-				  ~column:argument in
-		     let tactic = model#get ~row:it ~column:tactic in
-		     prerr_endline ("Got name: "^name);
-		     let success = model#get ~row:it ~column:status in
-		     if success then try 
-		       prerr_endline "Got success";
-		       let _,_,f = MyMap.find tactic (MyMap.find name tbl) in
-		       f ();
-		       (* window#misc#hide () *)
-		     with _ -> ()
-		  )
-		  view#selection#get_selected_rows
-	      end);
-
-(* needs lablgtk2 update    ignore (view#connect#after#row_activated
-   (fun path vcol ->
-   prerr_endline "Activated";
-   );
-*)
-end
-
-let blaster_window = ref None
-
-let main n = blaster_window := Some (new blaster_window n)
-
-let present_blaster_window () = match !blaster_window with 
-  | None -> failwith "No blaster window."
-  | Some c -> c#window#misc#show (* present*) (); c
-
-
-let blaster_window () = match !blaster_window with 
-  | None -> failwith "No blaster window."
-  | Some c -> c
-
-
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
index b84b0943..ee07b3fb 100644
--- a/ide/command_windows.ml
+++ b/ide/command_windows.ml
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: command_windows.ml 11042 2008-06-03 12:45:38Z jnarboux $ *)
+(* $Id$ *)
 
-class command_window () = 
-(*  let window = GWindow.window 
-		 ~allow_grow:true ~allow_shrink:true 
+class command_window () =
+(*  let window = GWindow.window
+		 ~allow_grow:true ~allow_shrink:true
 		 ~width:500 ~height:250
 		 ~position:`CENTER
 		 ~title:"CoqIde queries" ~show:false ()
@@ -19,23 +19,23 @@ class command_window () =
   let _ = frame#misc#hide () in
   let _ = GtkData.AccelGroup.create () in
   let hbox = GPack.hbox ~homogeneous:false ~packing:frame#add () in
-  let toolbar = GButton.toolbar 
-		  ~orientation:`VERTICAL 
+  let toolbar = GButton.toolbar
+		  ~orientation:`VERTICAL
 		  ~style:`ICONS
-		  ~tooltips:true 
-		  ~packing:(hbox#pack 
+		  ~tooltips:true
+		  ~packing:(hbox#pack
 			       ~expand:false
 			       ~fill:false)
 		  ()
   in
-  let notebook = GPack.notebook ~scrollable:true 
-		   ~packing:(hbox#pack 
+  let notebook = GPack.notebook ~scrollable:true
+		   ~packing:(hbox#pack
 			       ~expand:true
 			       ~fill:true
-			    ) 
+			    )
 		   ()
   in
-  let _ = 
+  let _ =
     toolbar#insert_button
       ~tooltip:"Hide Commands Pane"
       ~text:"Hide Pane"
@@ -43,7 +43,7 @@ class command_window () =
       ~callback:frame#misc#hide
       ()
   in
-  let new_page_menu = 
+  let new_page_menu =
     toolbar#insert_button
       ~tooltip:"New Page"
       ~text:"New Page"
@@ -51,7 +51,7 @@ class command_window () =
       ()
   in
 
-  let _ = 
+  let _ =
     toolbar#insert_button
       ~tooltip:"Delete Page"
       ~text:"Delete Page"
@@ -65,10 +65,10 @@ object(self)
 
   val new_page_menu = new_page_menu
   val notebook = notebook
-  method frame = frame 
+  method frame = frame
   method new_command ?command ?term () =
     let appendp x = ignore (notebook#append_page x) in
-    let frame = GBin.frame 
+    let frame = GBin.frame
 		  ~shadow_type:`ETCHED_OUT
 		  ~packing:appendp
 		  ()
@@ -84,15 +84,15 @@ object(self)
 		  ()
     in
     combo#disable_activate ();
-    let on_activate c () = 
-      if List.mem combo#entry#text Coq_commands.state_preserving then c () 
-      else prerr_endline "Not a state preserving command" 
+    let on_activate c () =
+      if List.mem combo#entry#text Coq_commands.state_preserving then c ()
+      else prerr_endline "Not a state preserving command"
     in
     let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) () in
     entry#misc#set_can_default true;
     let r_bin =
-      GBin.scrolled_window 
-	~vpolicy:`AUTOMATIC 
+      GBin.scrolled_window
+	~vpolicy:`AUTOMATIC
 	~hpolicy:`AUTOMATIC
 	~packing:(vbox#pack ~fill:true ~expand:true) () in
     let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in
@@ -101,13 +101,13 @@ object(self)
     result#set_editable false;
     let callback () =
       let com = combo#entry#text in
-      let phrase = 
+      let phrase =
 	if String.get com (String.length com - 1) = '.'
-	then com ^ " " else com ^ " " ^ entry#text ^" . " 
+	then com ^ " " else com ^ " " ^ entry#text ^" . "
       in
       try
 	ignore(Coq.interp false phrase);
-	result#buffer#set_text 
+	result#buffer#set_text
 	  ("Result for command " ^ phrase ^ ":\n" ^ Ideutils.read_stdout ())
       with e ->
 	let (s,loc) = Coq.process_exn e in
@@ -117,16 +117,16 @@ object(self)
     ignore (combo#entry#connect#activate ~callback:(on_activate callback));
     ignore (ok_b#connect#clicked ~callback:(on_activate callback));
 
-    begin match command,term with 
+    begin match command,term with
       | None,None -> ()
-      | Some c, None -> 
+      | Some c, None ->
 	  combo#entry#set_text c;
-	  
-      | Some c, Some t -> 
+
+      | Some c, Some t ->
 	  combo#entry#set_text c;
 	  entry#set_text t
-	 
-      | None , Some t -> 
+
+      | None , Some t ->
 	  entry#set_text t
     end;
     on_activate callback ();
@@ -134,9 +134,9 @@ object(self)
     entry#misc#grab_default ();
     ignore (entry#connect#activate ~callback);
     ignore (combo#entry#connect#activate ~callback);
-    self#frame#misc#show () 
+    self#frame#misc#show ()
 
-  initializer 
+  initializer
     ignore (new_page_menu#connect#clicked self#new_command);
    (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*)
 end
@@ -145,6 +145,6 @@ let command_window = ref None
 
 let main () = command_window := Some (new command_window ())
 
-let command_window () = match !command_window with 
+let command_window () = match !command_window with
   | None -> failwith "No command window."
   | Some c -> c
diff --git a/ide/command_windows.mli b/ide/command_windows.mli
index 212e5692..4104f086 100644
--- a/ide/command_windows.mli
+++ b/ide/command_windows.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: command_windows.mli 11011 2008-05-28 16:22:11Z jnarboux $ i*)
+(*i $Id$ i*)
 
 class command_window :
   unit ->
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
index 7722e99a..97aeb2f5 100644
--- a/ide/config_lexer.mll
+++ b/ide/config_lexer.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: config_lexer.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 {
 
@@ -28,19 +28,19 @@ rule token = parse
   | '#' [^ '\n']* { token lexbuf }
   | ident { IDENT (lexeme lexbuf) }
   | '='   { EQUAL }
-  | '"'   { Buffer.reset string_buffer; 
+  | '"'   { Buffer.reset string_buffer;
 	    Buffer.add_char string_buffer '"';
 	    string lexbuf;
 	    let s = Buffer.contents string_buffer in
 	    STRING (Scanf.sscanf s "%S" (fun s -> s)) }
   | _     { let c = lexeme_start lexbuf in
-	    eprintf ".coqiderc: invalid character (%d)\n@." c; 
+	    eprintf ".coqiderc: invalid character (%d)\n@." c;
 	    token lexbuf }
   | eof   { EOF }
 
 and string = parse
   | '"'  { Buffer.add_char string_buffer '"' }
-  | '\\' '"' | _ 
+  | '\\' '"' | _
          { Buffer.add_string string_buffer (lexeme lexbuf); string lexbuf }
   | eof  { eprintf ".coqiderc: unterminated string\n@." }
 
@@ -60,7 +60,7 @@ and string = parse
       | [] -> ()
       | s :: sl -> fprintf fmt "%S@ %a" s print_list sl
     in
-    Stringmap.iter 
+    Stringmap.iter
       (fun k s -> fprintf fmt "@[<hov 2>%s = %a@]@\n" k print_list s) m;
     fprintf fmt "@.";
     close_out c
diff --git a/ide/config_parser.mly b/ide/config_parser.mly
index 80cba27b..bd5577db 100644
--- a/ide/config_parser.mly
+++ b/ide/config_parser.mly
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (***********************************************************************/
 
-/* $Id: config_parser.mly 5920 2004-07-16 20:01:26Z herbelin $ */
+/* $Id$ */
 
 %{
 
diff --git a/ide/coq.ml b/ide/coq.ml
index a44428c7..bd441cf1 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq.ml 11948 2009-02-27 16:01:53Z glondu $ *)
+(* $Id$ *)
 
 open Vernac
 open Vernacexpr
@@ -24,22 +24,23 @@ open Hipattern
 open Tacmach
 open Reductionops
 open Termops
+open Namegen
 open Ideutils
 
 let prerr_endline s = if !debug then prerr_endline s else ()
 
 let output = ref (Format.formatter_of_out_channel stdout)
 
-let msg m = 
+let msg m =
   let b =  Buffer.create 103 in
   Pp.msg_with (Format.formatter_of_buffer b) m;
   Buffer.contents b
 
-let msgnl m = 
+let msgnl m =
   (msg m)^"\n"
 
-let init () = 
-  (* To hide goal in lower window. 
+let init () =
+  (* To hide goal in lower window.
      Problem: should not hide "xx is assumed"
      messages *)
 (**)
@@ -70,7 +71,7 @@ let short_version () =
 
 let version () =
   let (ver,date) = get_version_date () in
-    Printf.sprintf 
+    Printf.sprintf
       "The Coq Proof Assistant, version %s (%s)\
        \nArchitecture %s running %s operating system\
        \nGtk version is %s\
@@ -79,14 +80,14 @@ let version () =
       ver date
       Coq_config.arch Sys.os_type
       (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z)
-    (if Mltop.is_native then "native" else "bytecode") 
-    (if Coq_config.best="opt" then "native" else "bytecode") 
+    (if Mltop.is_native then "native" else "bytecode")
+    (if Coq_config.best="opt" then "native" else "bytecode")
 
-let is_in_coq_lib dir = 
+let is_in_coq_lib dir =
   prerr_endline ("Is it a coq theory ? : "^dir);
   let is_same_file = same_file dir in
-  List.exists 
-    (fun s -> 
+  List.exists
+    (fun s ->
       let fdir =
         Filename.concat (Envars.coqlib ()) (Filename.concat "theories" s) in
       prerr_endline (" Comparing to: "^fdir);
@@ -97,19 +98,19 @@ let is_in_coq_lib dir =
 let is_in_loadpath dir =
   Library.is_in_load_paths (System.physical_path_of_string dir)
 
-let is_in_coq_path f = 
-  try 
+let is_in_coq_path f =
+  try
   let base = Filename.chop_extension (Filename.basename f) in
   let _ = Library.locate_qualified_library false
-	    (Libnames.make_qualid Names.empty_dirpath 
+	    (Libnames.make_qualid Names.empty_dirpath
 	       (Names.id_of_string base)) in
   prerr_endline (f ^ " is in coq path");
   true
-  with _ ->  
+  with _ ->
     prerr_endline (f ^ " is NOT in coq path");
-    false  
+    false
 
-let is_in_proof_mode () = 
+let is_in_proof_mode () =
   match Decl_mode.get_current_mode () with
       Decl_mode.Mode_none -> false
     | _ -> true
@@ -156,10 +157,7 @@ let prepare_option (l,dft) =
   let unset = (String.concat " " ("Unset"::l)) ^ "." in
   if dft then unset,set else set,unset
 
-let coqide_known_option = function
-  | Goptions.TertiaryTable (a,b,c) -> List.mem [a;b;c] !known_options
-  | Goptions.SecondaryTable (a,b) -> List.mem [a;b] !known_options
-  | Goptions.PrimaryTable a -> List.mem [a] !known_options
+let coqide_known_option table = List.mem table !known_options
 
 let with_printing_implicit = prepare_option printing_implicit_data
 let with_printing_coercions = prepare_option printing_coercions_data
@@ -194,6 +192,8 @@ type command_attribute =
 let rec attribute_of_vernac_command = function
   (* Control *)
   | VernacTime com -> attribute_of_vernac_command com
+  | VernacTimeout(_,com) -> attribute_of_vernac_command com
+  | VernacFail com -> attribute_of_vernac_command com
   | VernacList _ -> [] (* unsupported *)
   | VernacLoad _ -> []
 
@@ -240,6 +240,7 @@ let rec attribute_of_vernac_command = function
   | VernacInstance _ -> []
   | VernacContext _ -> []
   | VernacDeclareInstance _ -> []
+  | VernacDeclareClass _ -> []
 
   (* Solving *)
   | VernacSolve _ -> [SolveCommand]
@@ -275,11 +276,12 @@ let rec attribute_of_vernac_command = function
   | VernacHints _ -> []
   | VernacSyntacticDefinition _ -> []
   | VernacDeclareImplicits _ -> []
+  | VernacDeclareReduction _ -> []
   | VernacReserve _ -> []
+  | VernacGeneralizable _ -> []
   | VernacSetOpacity _ -> []
-  | VernacSetOption (Goptions.SecondaryTable ("Ltac","Debug"), _) -> 
-      [DebugCommand]
-  | VernacSetOption (o,BoolValue true) | VernacUnsetOption o ->
+  | VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand]
+  | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) ->
       if coqide_known_option o then [KnownOptionCommand] else []
   | VernacSetOption _ -> []
   | VernacRemoveOption _ -> []
@@ -358,75 +360,60 @@ type undo_info = identifier list
 
 let undo_info () = Pfedit.get_all_proof_names ()
 
-type reset_mark =
-  | ResetToId of Names.identifier     (* Relying on identifiers only *)
-  | ResetToState of Libnames.object_name (* Relying on states if any *)
+type reset_mark = Libnames.object_name
 
 type reset_status =
   | NoReset
   | ResetAtSegmentStart of Names.identifier
   | ResetAtRegisteredObject of reset_mark
 
-type reset_info = reset_status * undo_info * bool ref
-
-
-let reset_mark id = match Lib.has_top_frozen_state () with
-  | Some sp -> 
-      prerr_endline ("On top of state "^Libnames.string_of_path (fst sp));
-      ResetToState sp
-  | None -> ResetToId id
-
-let compute_reset_info = function 
-  | VernacBeginSection id 
-  | VernacDefineModule (_,id, _, _, _) 
-  | VernacDeclareModule (_,id, _, _)
-  | VernacDeclareModuleType (id, _, _) ->
-      ResetAtSegmentStart (snd id), undo_info(), ref true
-
-  | VernacDefinition (_, (_,id), DefineBody _, _)
-  | VernacAssumption (_,_ ,(_,((_,id)::_,_))::_)
-  | VernacInductive (_, (((_,(_,id)),_,_,_,_),_) :: _) ->
-      ResetAtRegisteredObject (reset_mark id), undo_info(), ref true
-
-  | com when is_vernac_proof_ending_command com -> NoReset, undo_info(), ref true
-  | VernacEndSegment _ -> NoReset, undo_info(), ref true
+type reset_info = {
+  status : reset_status;
+  proofs : identifier list;
+  cur_prf : (identifier * int) option;
+  loc_ast : Util.loc * Vernacexpr.vernac_expr;
+}
 
-  | com when is_vernac_tactic_command com -> NoReset, undo_info(), ref true
-  | _ ->
-      (match Lib.has_top_frozen_state () with
-      | Some sp -> 
-	  prerr_endline ("On top of state "^Libnames.string_of_path (fst sp));
-	  ResetAtRegisteredObject (ResetToState sp)
-      | None -> NoReset), undo_info(), ref true
+let compute_reset_info loc_ast = 
+  let status,cur_prf = match snd loc_ast with
+    | com when is_vernac_proof_ending_command com -> NoReset,None
+    | VernacEndSegment _ -> NoReset,None
+    | com when is_vernac_tactic_command com ->
+        NoReset,Some (Pfedit.get_current_proof_name (), Pfedit.current_proof_depth ())
+    | _ ->
+        (match Lib.has_top_frozen_state () with
+           | Some sp -> 
+               prerr_endline ("On top of state "^Libnames.string_of_path (fst sp));
+               ResetAtRegisteredObject sp,None
+           | None -> NoReset,None)
+  in
+  { status = status;
+    proofs = Pfedit.get_all_proof_names ();
+    cur_prf = cur_prf;
+    loc_ast = loc_ast; 
+  }
 
-let reset_initial () = 
+let reset_initial () =
   prerr_endline "Reset initial called"; flush stderr;
   Vernacentries.abort_refine Lib.reset_initial ()
 
-let reset_to = function
-  | ResetToId id ->
-      prerr_endline ("Reset called with "^(string_of_id id));
-      Lib.reset_name (Util.dummy_loc,id)
-  | ResetToState sp ->
+let reset_to sp =
       prerr_endline
         ("Reset called with state "^(Libnames.string_of_path (fst sp)));
       Lib.reset_to_state sp
 
-let reset_to_mod id = 
-  prerr_endline ("Reset called to Mod/Sect with "^(string_of_id id)); 
-  Lib.reset_mod (Util.dummy_loc,id)
-
 let raw_interp s =
   Vernac.raw_do_vernac (Pcoq.Gram.parsable (Stream.of_string s))
 
-let interp_with_options verbosely options s = 
+let interp_with_options verbosely options s =
   prerr_endline "Starting interp...";
   prerr_endline s;
   let pa = Pcoq.Gram.parsable (Stream.of_string s) in
   let pe = Pcoq.Gram.Entry.parse Pcoq.main_entry pa in
-  (* Temporary hack to make coqide.byte work (WTF???) *)
-  Pervasives.prerr_endline "";
-  match pe with 
+  (* Temporary hack to make coqide.byte work (WTF???) - now with less screen
+  * pollution *)
+  Pervasives.prerr_string " \r"; Pervasives.flush stderr;
+  match pe with
     | None -> assert false
     | Some((loc,vernac) as last) ->
 	if is_vernac_debug_command vernac then
@@ -435,58 +422,28 @@ let interp_with_options verbosely options s =
 	  user_error_loc loc (str "Use CoqIDE navigation instead");
 	if is_vernac_known_option_command vernac then
 	  user_error_loc loc (str "Use CoqIDE display menu instead");
-	if is_vernac_query_command vernac then 
-	  !flash_info
+	if is_vernac_query_command vernac then
+	  flash_info
 	    "Warning: query commands should not be inserted in scripts";
 	if not (is_vernac_goal_printing_command vernac) then
 	  (* Verbose if in small step forward and not a tactic *)
 	  Flags.make_silent (not verbosely);
-	let reset_info = compute_reset_info vernac in
+	let reset_info = compute_reset_info last in
 	List.iter (fun (set_option,_) -> raw_interp set_option) options;
 	raw_interp s;
 	Flags.make_silent true;
 	List.iter (fun (_,unset_option) -> raw_interp unset_option) options;
 	prerr_endline ("...Done with interp of : "^s);
-	reset_info,last
+	reset_info
 
 let interp verbosely phrase =
   interp_with_options verbosely (make_option_commands ()) phrase
 
-let interp_and_replace s = 
+let interp_and_replace s =
   let result = interp false s in
   let msg = read_stdout () in
   result,msg
 
-let nb_subgoals pf =
-  List.length (fst (Refiner.frontier (Tacmach.proof_of_pftreestate pf)))
-
-type tried_tactic = 
-  | Interrupted
-  | Success of int (* nb of goals after *)
-  | Failed
-
-let try_interptac s = 
-  try
-    prerr_endline ("Starting try_interptac: "^s);
-    let pf = get_pftreestate () in
-    let pe = Pcoq.Gram.Entry.parse 
-	       Pcoq.main_entry 
-	       (Pcoq.Gram.parsable (Stream.of_string s)) 
-    in match pe with 
-    | Some (loc,(VernacSolve (n, tac, _))) ->
-	let tac = Tacinterp.interp tac in
-	let pf' = solve_nth_pftreestate n tac pf in
-	prerr_endline "Success";
-	let nb_goals = nb_subgoals pf' - nb_subgoals pf in
-	Success nb_goals
-    | _ ->
-	prerr_endline "try_interptac: not a tactic"; Failed
-  with 
-  | Sys.Break | Stdpp.Exc_located (_,Sys.Break)
-      -> prerr_endline "try_interp: interrupted"; Interrupted
-  | Stdpp.Exc_located (_,e) -> prerr_endline ("try_interp: failed ("^(Printexc.to_string e)); Failed
-  | e -> Failed	  
-
 let rec is_pervasive_exn = function
   | Out_of_memory | Stack_overflow | Sys.Break -> true
   | Error_in_file (_,_,e) -> is_pervasive_exn e
@@ -499,7 +456,7 @@ let print_toplevel_error exc =
     match exc with
       | DuringCommandInterp (loc,ie) ->
           if loc = dummy_loc then (None,ie) else (Some loc, ie)
-      | _ -> (None, exc) 
+      | _ -> (None, exc)
   in
   let (loc,exc) =
     match exc with
@@ -509,19 +466,17 @@ let print_toplevel_error exc =
   in
   match exc with
     | End_of_input  -> 	str "Please report: End of input",None
-    | Vernacexpr.ProtectedLoop -> 
-	str "ProtectedLoop  not allowed by coqide!",None
     | Vernacexpr.Drop ->  str "Drop is not allowed by coqide!",None
     | Vernacexpr.Quit -> str "Quit is not allowed by coqide! Use menus.",None
-    | _ -> 
-	(try Cerrors.explain_exn exc with e -> 
+    | _ ->
+	(try Cerrors.explain_exn exc with e ->
 	   str "Failed to explain error. This is an internal Coq error. Please report.\n"
 	   ++ str (Printexc.to_string  e)),
 	(if is_pervasive_exn exc then None else loc)
 
 let process_exn e = let s,loc= print_toplevel_error e in (msgnl s,loc)
 
-let interp_last last = 
+let interp_last last =
   prerr_string "*";
   try
     vernac_com (States.with_heavy_rollback Vernacentries.interp) last;
@@ -530,9 +485,89 @@ let interp_last last =
     let s,_ = process_exn e in prerr_endline ("Replay during undo failed because: "^s);
     raise e
 
+let push_phrase cmd_stk reset_info ide_payload =
+  Stack.push (ide_payload,reset_info) cmd_stk
+
+type backtrack =
+  | BacktrackToNextActiveMark
+  | BacktrackToMark of reset_mark
+  | NoBacktrack
+
+let apply_reset = function
+  | BacktrackToMark mark -> reset_to mark
+  | NoBacktrack -> ()
+  | BacktrackToNextActiveMark -> assert false
+
+let rewind sequence cmd_stk =
+  let undo_ops = Hashtbl.create 31 in
+  let current_proofs = undo_info () in
+  let pop_state cont seq coq reset_op prev_proofs curprf =
+    prerr_endline "pop";
+    let curprf =
+      Option.map
+        (fun (curprf,depth) ->
+           (if Hashtbl.mem undo_ops curprf then Hashtbl.replace else Hashtbl.add)
+             undo_ops curprf depth;
+           curprf)
+        coq.cur_prf in
+    let reset_op =
+      match coq.status with
+        | ResetAtRegisteredObject mark ->
+            BacktrackToMark mark
+        | _ when is_vernac_state_preserving_command (snd coq.loc_ast) ->
+            reset_op
+        | _ when is_vernac_tactic_command (snd coq.loc_ast) ->
+            reset_op
+        | _ ->
+            BacktrackToNextActiveMark in
+    cont seq reset_op coq.proofs curprf
+  in
+  let rec do_rewind seq reset_op prev_proofs curprf =
+    match seq with
+      | [] when ((reset_op <> BacktrackToNextActiveMark) &&
+                 (Util.list_subset prev_proofs current_proofs)) ->
+          begin
+            Hashtbl.iter
+              (fun id depth ->
+                 if List.mem id prev_proofs then begin
+                   Pfedit.resume_proof (Util.dummy_loc,id);
+                   Pfedit.undo_todepth depth
+                 end)
+              undo_ops;
+            prerr_endline "OK for undos";
+            Option.iter (fun id -> if List.mem id prev_proofs then
+                           Pfedit.resume_proof (Util.dummy_loc,id)) curprf;
+            prerr_endline "OK for focusing";
+            List.iter
+              (fun id -> Pfedit.delete_proof (Util.dummy_loc,id))
+              (Util.list_subtract current_proofs prev_proofs);
+            prerr_endline "OK for aborts";
+            apply_reset reset_op;
+            prerr_endline "OK for reset"
+          end
+      | [] ->
+          begin
+            try 
+              let ide,coq = Stack.pop cmd_stk in
+              pop_state do_rewind [] coq reset_op prev_proofs curprf;
+              prerr_endline "push";
+              let reset_info = compute_reset_info coq.loc_ast in
+              interp_last coq.loc_ast;
+              push_phrase cmd_stk reset_info ide
+            with Stack.Empty -> reset_initial ()
+          end
+      | coq::rem ->
+          pop_state do_rewind rem coq reset_op prev_proofs curprf
+  in
+  do_rewind sequence NoBacktrack current_proofs None
+
+type  tried_tactic =
+  | Interrupted
+  | Success of int (* nb of goals after *)
+  | Failed
 
 type hyp = env * evar_map *
-           ((identifier * string) * constr option * constr) * 
+           ((identifier * string) * constr option * constr) *
            (string * string)
 type concl = env * evar_map * constr * string
 type meta = env * evar_map * string
@@ -540,7 +575,7 @@ type goal = hyp list * concl
 
 let prepare_hyp sigma env ((i,c,d) as a) =
   env, sigma,
-  ((i,string_of_id i),c,d), 
+  ((i,string_of_id i),c,d),
   (msg (pr_var_decl env a), msg (pr_ltype_env env d))
 
 let prepare_hyps sigma env =
@@ -548,7 +583,7 @@ let prepare_hyps sigma env =
   let hyps =
     fold_named_context
       (fun env d acc -> let hyp = prepare_hyp sigma env d in hyp :: acc)
-      env ~init:[] 
+      env ~init:[]
   in
   List.rev hyps
 
@@ -571,74 +606,66 @@ let get_current_pm_goal () =
   let gl = sig_it gls in
     prepare_goal sigma gl
 
-
-let get_current_goals () = 
+let get_current_goals () =
     let pfts = get_pftreestate () in
-    let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in 
+    let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in
     let sigma = Tacmach.evc_of_pftreestate pfts in
     List.map (prepare_goal sigma) gls
 
-let get_current_goals_nb () = 
-  try List.length (get_current_goals ()) with _ -> 0
-  
 let print_no_goal () =
-    let pfts = get_pftreestate () in
-    let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in 
-    assert (gls = []);
-    let sigma = Tacmach.project (Tacmach.top_goal_of_pftreestate pfts) in
-    msg (Printer.pr_subgoals (Decl_mode.get_end_command pfts) sigma gls)
-
+  (* Fall back on standard coq goal printer for completed goal printing *)
+  msg (pr_open_subgoals ())
 
 let hyp_menu (env, sigma, ((coqident,ident),_,ast),(s,pr_ast)) =
   [("clear "^ident),("clear "^ident^".");
-   
+
    ("apply "^ident),
    ("apply "^ident^".");
-   
+
    ("exact "^ident),
    ("exact "^ident^".");
 
    ("generalize "^ident),
    ("generalize "^ident^".");
-   
+
    ("absurd <"^ident^">"),
    ("absurd "^
     pr_ast
     ^".") ] @
 
-   (if is_equation ast then
+   (if is_equality_type ast then
       [ "discriminate "^ident, "discriminate "^ident^".";
 	"injection "^ident, "injection "^ident^"." ]
     else
       []) @
-   
+
    (let _,t = splay_prod env sigma ast in
-    if is_equation t then 
+    if is_equality_type t then
       [ "rewrite "^ident, "rewrite "^ident^".";
 	"rewrite <- "^ident, "rewrite <- "^ident^"." ]
     else
       []) @
-   
+
   [("elim "^ident),
    ("elim "^ident^".");
-   
+
    ("inversion "^ident),
    ("inversion "^ident^".");
-   
+
    ("inversion clear "^ident),
-   ("inversion_clear "^ident^".")] 
+   ("inversion_clear "^ident^".")]
 
-let concl_menu (_,_,concl,_) = 
-  let is_eq = is_equation concl in
+let concl_menu (_,_,concl,_) =
+  let is_eq = is_equality_type concl in
   ["intro", "intro.";
    "intros", "intros.";
    "intuition","intuition." ] @
-   
-   (if is_eq then 
+
+   (if is_eq then
       ["reflexivity", "reflexivity.";
        "discriminate", "discriminate.";
        "symmetry", "symmetry." ]
-    else 
+    else
       []) @
 
   ["assumption" ,"assumption.";
@@ -660,43 +687,44 @@ let concl_menu (_,_,concl,_) =
   ]
 
 
-let id_of_name = function 
-  | Names.Anonymous -> id_of_string "x" 
+let id_of_name = function
+  | Names.Anonymous -> id_of_string "x"
   | Names.Name x -> x
 
-let make_cases s = 
+let make_cases s =
   let qualified_name = Libnames.qualid_of_string s in
   let glob_ref = Nametab.locate qualified_name in
   match glob_ref with
-    | Libnames.IndRef i -> 
+    | Libnames.IndRef i ->
 	let {Declarations.mind_nparams = np},
 	{Declarations.mind_consnames = carr ;
-	 Declarations.mind_nf_lc = tarr } 
-	= Global.lookup_inductive i 
+	 Declarations.mind_nf_lc = tarr }
+	= Global.lookup_inductive i
 	in
-	Util.array_fold_right2 
-	  (fun n t l ->  
+	Util.array_fold_right2
+	  (fun n t l ->
 	     let (al,_) = Term.decompose_prod t in
 	     let al,_ = Util.list_chop (List.length al - np) al in
-	     let rec rename avoid = function 
+	     let rec rename avoid = function
 	       | [] -> []
-	       | (n,_)::l -> 
-		   let n' = next_global_ident_away true
-			      (id_of_name n) 
+	       | (n,_)::l ->
+		   let n' = next_ident_away_in_goal
+			      (id_of_name n)
 			      avoid
 		   in (string_of_id n')::(rename (n'::avoid) l)
 	     in
 	     let al' = rename [] (List.rev al) in
 	     (string_of_id n :: al') :: l
 	  )
-	  carr 
+	  carr
 	  tarr
 	  []
     | _ -> raise Not_found
 
-let current_status () = 
+let current_status () =
   let path = msg (Libnames.pr_dirpath (Lib.cwd ())) in
   let path = if path = "Top" then "Ready" else "Ready in " ^ String.sub path 4 (String.length path - 4) in
   try
     path ^ ", proving " ^ (Names.string_of_id (Pfedit.get_current_proof_name ()))
   with _ -> path
+
diff --git a/ide/coq.mli b/ide/coq.mli
index a1bea931..5cf66d36 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq.mli 11126 2008-06-13 18:45:04Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Names
 open Term
@@ -29,31 +29,19 @@ type printing_state = {
 
 val printing_state : printing_state
 
-type reset_mark =
-  | ResetToId of Names.identifier
-  | ResetToState of Libnames.object_name
+type reset_info
 
-type reset_status =
-  | NoReset
-  | ResetAtSegmentStart of Names.identifier
-  | ResetAtRegisteredObject of reset_mark
-
-type undo_info = identifier list
-
-val undo_info : unit -> undo_info
-
-type reset_info = reset_status * undo_info * bool ref
-
-val compute_reset_info : Vernacexpr.vernac_expr -> reset_info
 val reset_initial : unit -> unit
-val reset_to : reset_mark -> unit
-val reset_to_mod : identifier -> unit
 
-val init : unit -> string list 
-val interp : bool -> string -> reset_info * (Util.loc * Vernacexpr.vernac_expr)
+val init : unit -> string list
+val interp : bool -> string -> reset_info
 val interp_last : Util.loc * Vernacexpr.vernac_expr -> unit
-val interp_and_replace : string -> 
-      (reset_info * (Util.loc * Vernacexpr.vernac_expr)) * string
+val interp_and_replace : string ->
+      reset_info * string
+
+val push_phrase : ('a * reset_info) Stack.t -> reset_info -> 'a -> unit
+
+val rewind : reset_info list -> ('a * reset_info) Stack.t -> unit
 
 val is_vernac_tactic_command : Vernacexpr.vernac_expr -> bool
 val is_vernac_state_preserving_command : Vernacexpr.vernac_expr -> bool
@@ -62,7 +50,7 @@ val is_vernac_proof_ending_command : Vernacexpr.vernac_expr -> bool
 
 (* type hyp = (identifier * constr option * constr) * string *)
 
-type hyp = env * evar_map * 
+type hyp = env * evar_map *
            ((identifier*string) * constr option * constr) * (string * string)
 type meta = env * evar_map * string
 type concl = env * evar_map * constr * string
@@ -72,8 +60,6 @@ val get_current_goals : unit -> goal list
 
 val get_current_pm_goal : unit -> goal
 
-val get_current_goals_nb : unit -> int
-
 val print_no_goal : unit -> string
 
 val process_exn : exn -> string*(Util.loc option)
@@ -88,13 +74,11 @@ val is_in_loadpath : string -> bool
 val make_cases : string -> string list list
 
 
-type tried_tactic = 
+type tried_tactic =
   | Interrupted
   | Success of int (* nb of goals after *)
   | Failed
 
-val try_interptac: string -> tried_tactic
-
 (* Message to display in lower status bar. *)
 
 val current_status : unit -> string
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
index 3a48fc7d..e4a3ae56 100644
--- a/ide/coq_commands.ml
+++ b/ide/coq_commands.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_commands.ml 10994 2008-05-26 16:21:31Z jnarboux $ *)
+(* $Id$ *)
 
 let commands = [
   [(* "Abort"; *)
@@ -43,7 +43,7 @@ let commands = [
   ];
   ["End";
    "End Silent.";
-   "Eval"; 
+   "Eval";
    "Extract Constant";
    "Extract Inductive";
    "Extraction Inline";
@@ -84,7 +84,7 @@ let commands = [
   ["Parameter";
    "Proof.";
    "Program Definition";
-   "Program Fixpoint";     
+   "Program Fixpoint";
    "Program Lemma";
    "Program Theorem";
   ];
@@ -100,7 +100,7 @@ let commands = [
    "Require Export";
    "Require Import";
    "Reset Extraction Inline";
-   "Restore State"; 
+   "Restore State";
    ];
   [  "Save.";
      "Scheme";
@@ -155,6 +155,7 @@ let commands = [
 ]
 
 let state_preserving = [
+  "About";
   "Check";
   "Eval";
   "Eval lazy in";
@@ -165,7 +166,7 @@ let state_preserving = [
   "Extraction Module";
   "Inspect";
   "Locate";
-  
+
   "Obligations";
   "Print";
   "Print All.";
@@ -191,7 +192,7 @@ let state_preserving = [
   "Print Scope";
   "Print Scopes.";
   "Print Section";
-  
+
   "Print Table Printing If.";
   "Print Table Printing Let.";
   "Print Tables.";
@@ -229,7 +230,7 @@ let state_preserving = [
 ]
 
 
-let tactics = 
+let tactics =
   [
     [
       "abstract";
@@ -316,7 +317,7 @@ let tactics =
      "generalize";
      "generalize dependent";
    ];
-   
+
    [
      "hnf";
    ];
@@ -415,7 +416,7 @@ let tactics =
      "trivial";
      "try";
    ];
-   
+
    [
      "unfold";
      "unfold __ in";
diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll
new file mode 100644
index 00000000..03ce950f
--- /dev/null
+++ b/ide/coq_lex.mll
@@ -0,0 +1,194 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+{
+  open Lexing
+
+  type token =
+    | Comment
+    | Keyword
+    | Declaration
+    | ProofDeclaration
+    | Qed
+    | String
+
+  (* Without this table, the automaton would be too big and
+     ocamllex would fail *)
+  let is_one_word_command =
+    let h = Hashtbl.create 97 in
+    List.iter (fun s -> Hashtbl.add h s ())
+      [  "Add" ; "Check"; "Eval"; "Extraction" ;
+	 "Load" ; "Undo"; "Goal";
+	 "Proof" ; "Print";"Save" ;
+	 "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments"
+      ];
+    Hashtbl.mem h
+
+  let is_constr_kw =
+    let h = Hashtbl.create 97 in
+      List.iter (fun s -> Hashtbl.add h s ())
+	[ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for";
+	  "end"; "as"; "let"; "in"; "if"; "then"; "else"; "return";
+	  "Prop"; "Set"; "Type" ];
+      Hashtbl.mem h
+
+  (* Without this table, the automaton would be too big and
+     ocamllex would fail *)
+  let is_one_word_declaration =
+    let h = Hashtbl.create 97 in
+      List.iter (fun s -> Hashtbl.add h s ())
+	[ (* Definitions *)
+	  "Definition" ; "Let" ; "Example" ; "SubClass" ;
+          "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ;
+          (* Assumptions *)
+	  "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
+	  "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters";
+          (* Inductive *)
+          "Inductive" ; "CoInductive" ; "Record" ; "Structure" ;
+          (* Other *)
+	  "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class"
+	];
+      Hashtbl.mem h
+
+  let is_proof_declaration =
+    let h = Hashtbl.create 97 in
+    List.iter (fun s -> Hashtbl.add h s ())
+      [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ;
+        "Proposition" ; "Property" ];
+    Hashtbl.mem h
+
+  let is_proof_end =
+    let h = Hashtbl.create 97 in
+    List.iter (fun s -> Hashtbl.add h s ())
+      [ "Qed" ; "Defined" ; "Admitted" ];
+    Hashtbl.mem h
+
+  let start = ref true
+}
+
+let space =
+  [' ' '\010' '\013' '\009' '\012']
+
+let firstchar =
+  ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
+let identchar =
+  ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let ident = firstchar identchar*
+
+let sentence_sep = '.' [ ' ' '\n' '\t' ]
+
+let multiword_declaration =
+  "Module" (space+ "Type")?
+| "Program" space+ ident
+| "Existing" space+ "Instance"
+| "Canonical" space+ "Structure"
+
+let locality = ("Local" space+)?
+
+let multiword_command =
+  "Set" (space+ ident)*
+| "Unset" (space+ ident)*
+| "Open" space+ locality "Scope"
+| "Close" space+ locality "Scope"
+| "Bind" space+ "Scope"
+| "Arguments" space+ "Scope"
+| "Reserved" space+ "Notation" space+ locality
+| "Delimit" space+ "Scope"
+| "Next" space+ "Obligation"
+| "Solve" space+ "Obligations"
+| "Require" space+ ("Import"|"Export")?
+| "Infix" space+ locality
+| "Notation" space+ locality
+| "Hint" space+ locality ident
+| "Reset" (space+ "Initial")?
+| "Tactic" space+ "Notation"
+| "Implicit" space+ "Arguments"
+| "Implicit" space+ ("Type"|"Types")
+| "Combined" space+ "Scheme"
+| "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))|
+    ("Library"|"Inline"|"NoInline"|"Blacklist"))
+| "Recursive" space+ "Extraction" (space+ "Library")?
+| ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist")
+| "Extract" space+ (("Inlined" space+) "Constant"| "Inductive")
+
+(* At least still missing: "Inline" + decl, variants of "Identity
+  Coercion", variants of Print, Add, ... *)
+
+rule coq_string = parse
+  | "\"\"" { coq_string lexbuf }
+  | "\"" { Lexing.lexeme_end lexbuf }
+  | eof { Lexing.lexeme_end lexbuf }
+  | _ { coq_string lexbuf }
+
+and comment = parse
+  | "(*" { ignore (comment lexbuf); comment lexbuf }
+  | "\"" { ignore (coq_string lexbuf); comment lexbuf }
+  | "*)" { Lexing.lexeme_end lexbuf }
+  | eof { Lexing.lexeme_end lexbuf }
+  | _ { comment lexbuf }
+
+and sentence stamp = parse
+  | space+ { sentence stamp lexbuf }
+  | "(*" {
+      let comm_start = Lexing.lexeme_start lexbuf in
+      let comm_end = comment lexbuf in
+      stamp comm_start comm_end Comment;
+      sentence stamp lexbuf
+    }
+  | "\"" {
+      let str_start = Lexing.lexeme_start lexbuf in
+      let str_end = coq_string lexbuf in
+      stamp str_start str_end String;
+      start := false;
+      sentence stamp lexbuf
+    }
+  | multiword_declaration {
+      if !start then begin
+        start := false;
+        stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Declaration
+      end;
+      sentence stamp lexbuf
+    }
+  | multiword_command {
+      if !start then begin
+        start := false;
+        stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword
+      end;
+      sentence stamp lexbuf }
+  | ident as id {
+      if !start then begin
+        start := false;
+        if id <> "Time" then begin
+            if is_proof_end id then
+              stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Qed
+            else if is_one_word_command id then
+              stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword
+            else if is_one_word_declaration id then
+              stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Declaration
+            else if is_proof_declaration id then
+              stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) ProofDeclaration
+        end
+      end else begin
+        if is_constr_kw id then
+	  stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword
+      end;
+      sentence stamp lexbuf }
+  | ".."
+  | _    { sentence stamp lexbuf}
+  | sentence_sep { }
+  | eof { raise Not_found }
+
+{
+  let find_end_offset stamp slice =
+    let lb = Lexing.from_string slice in
+    start := true;
+    sentence stamp lb;
+    Lexing.lexeme_end lb
+}
diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml
index 92d2de78..c6e1f1a4 100644
--- a/ide/coq_tactics.ml
+++ b/ide/coq_tactics.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_tactics.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 let tactics = [
   "Abstract";
diff --git a/ide/coq_tactics.mli b/ide/coq_tactics.mli
index 05e233eb..c31933ba 100644
--- a/ide/coq_tactics.mli
+++ b/ide/coq_tactics.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq_tactics.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 val tactics : string list
 
diff --git a/ide/coqide.ml b/ide/coqide.ml
index cc147d5e..201fbe47 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -7,123 +7,23 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqide.ml 12104 2009-04-24 18:10:10Z notin $ *)
+(* $Id$ *)
 
 open Preferences
 open Vernacexpr
 open Coq
+open Gtk_parsing
 open Ideutils
-  
-let cb_ = ref None
-let cb () = ((Option.get !cb_):GData.clipboard)
-let last_cb_content = ref ""
 
-let (message_view:GText.view option ref) = ref None
-let (proof_view:GText.view option ref) = ref None
-  
-let (_notebook:GPack.notebook option ref) = ref None
-let notebook () = Option.get !_notebook
+type ide_info = {
+  start : GText.mark;
+  stop : GText.mark;
+}
 
-let update_notebook_pos () =
-  let pos =
-    match !current.vertical_tabs, !current.opposite_tabs with
-      | false, false -> `TOP
-      | false, true  -> `BOTTOM
-      | true , false -> `LEFT
-      | true , true  -> `RIGHT
-  in
-  (notebook ())#set_tab_pos pos
-  
-(* Tabs contain the name of the edited file and 2 status informations: 
-   Saved state + Focused proof buffer *)
-let decompose_tab w = 
-  let vbox = new GPack.box ((Gobject.try_cast w "GtkBox"):Gtk.box Gtk.obj) in
-  let l = vbox#children in
-    match l with 
-      | [img;lbl] -> 
-	  let img = new GMisc.image 
-	    ((Gobject.try_cast img#as_widget "GtkImage"):
-	       Gtk.image Gtk.obj) 
-	  in
-	  let lbl = GMisc.label_cast lbl in
-	    vbox,img,lbl
-      | _ -> assert false
-	  
-let set_tab_label i n =
-  let nb = notebook () in
-  let _,_,lbl = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget 
-  in
-    lbl#set_use_markup true;
-    (* lbl#set_text n *) lbl#set_label n
-    
-    
-let set_tab_image ~icon i = 
-  let nb = notebook () in
-  let _,img,_ = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget
-  in
-    img#set_icon_size `SMALL_TOOLBAR;
-    img#set_stock icon
-      
-let set_current_tab_image ~icon = set_tab_image ~icon (notebook())#current_page
-  
-let set_current_tab_label n = set_tab_label (notebook())#current_page n 
-  
-let get_tab_label i =
-  let nb = notebook () in
-  let _,_,lbl = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget 
-  in
-    lbl#text
-      
-let get_full_tab_label i = 
-  let nb = notebook () in
-  let _,_,lbl = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget 
-  in
-    lbl
-      
-let get_current_tab_label () = get_tab_label (notebook())#current_page
-  
-let get_current_page () = 
-  let i = (notebook())#current_page in
-    (notebook())#get_nth_page i
-      
-(* This function must remove "focused proof" decoration *)				      
-let reset_tab_label i = 
-  set_tab_label i (get_tab_label i)
-    
-let to_do_on_page_switch = ref []
-  
-module Vector = struct 
-  exception Found of int
-  type 'a t = ('a option) array ref
-  let create () = ref [||]
-  let length t = Array.length !t
-  let get t i = Option.get (Array.get !t i)
-  let set t i v = Array.set !t i (Some v)
-  let remove t i = Array.set !t i None
-  let append t e = t := Array.append !t [|Some e|]; (Array.length !t)-1
-  let iter f t =  Array.iter (function | None -> () | Some x -> f x) !t
-  let find_or_fail f t = 
-    let test i = function | None -> () | Some e -> if f e then raise (Found i) in 
-      Array.iteri test t
-	
-  let exists f t =
-    let l = Array.length !t in
-    let rec test i = 
-      (i < l) && (((!t.(i) <> None) && f (Option.get !t.(i))) || test (i+1)) 
-    in 
-      test 0
-end
 
-type 'a viewable_script =
-    {view : Undo.undoable_view;
-     mutable analyzed_view : 'a option;
-    }
-
-
-class type analyzed_views= 
+class type analyzed_views=
 object('self)
   val mutable act_id : GtkSignal.id option
-  val current_all : 'self viewable_script
   val mutable deact_id : GtkSignal.id option
   val input_buffer : GText.buffer
   val input_view : Undo.undoable_view
@@ -133,6 +33,7 @@ object('self)
   val message_view : GText.view
   val proof_buffer : GText.buffer
   val proof_view : GText.view
+  val cmd_stack : (ide_info * Coq.reset_info) Stack.t
   val mutable is_active : bool
   val mutable read_only : bool
   val mutable filename : string option
@@ -145,7 +46,6 @@ object('self)
   method add_detached_view : GWindow.window -> unit
   method remove_detached_view : GWindow.window -> unit
 
-  method view : Undo.undoable_view
   method filename : string option
   method stats :  Unix.stats option
   method set_filename : string option -> unit
@@ -184,7 +84,7 @@ object('self)
   method send_to_coq :
     bool -> bool -> string ->
     bool -> bool -> bool ->
-    (bool*(reset_info*(Util.loc * Vernacexpr.vernac_expr))) option
+    (bool*reset_info) option
   method set_message : string -> unit
   method show_pm_goal : unit
   method show_goals : unit
@@ -192,37 +92,132 @@ object('self)
   method undo_last_step : unit
   method help_for_keyword : unit -> unit
   method complete_at_offset : int -> bool
-
-  method blaster : unit -> unit
 end
 
-let (input_views:analyzed_views viewable_script Vector.t) = Vector.create ()
+
+type viewable_script =
+    {script : Undo.undoable_view;
+     tab_label : GMisc.label;
+     mutable filename : string;
+     mutable encoding : string;
+     proof_view : GText.view;
+     message_view : GText.view;
+     analyzed_view : analyzed_views;
+     command_stack : (ide_info * Coq.reset_info) Stack.t;
+    }
+
+
+let notebook_page_of_session {script=script;tab_label=bname;proof_view=proof;message_view=message} =
+  let session_paned =
+    GPack.paned `HORIZONTAL ~border_width:5 () in
+  let script_frame =
+    GBin.frame ~shadow_type:`IN ~packing:session_paned#add1 () in
+  let script_scroll =
+    GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in
+  let state_paned =
+    GPack.paned `VERTICAL ~packing:session_paned#add2 () in
+  let proof_frame =
+    GBin.frame ~shadow_type:`IN ~packing:state_paned#add1 () in
+  let proof_scroll =
+    GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_frame#add () in
+  let message_frame =
+    GBin.frame ~shadow_type:`IN ~packing:state_paned#add2 () in
+  let message_scroll =
+    GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:message_frame#add () in
+  let session_tab =
+    GPack.hbox ~homogeneous:false () in
+  let img =
+    GMisc.image ~packing:session_tab#pack ~icon_size:`SMALL_TOOLBAR () in
+  let _ =
+    script#buffer#connect#modified_changed
+      ~callback:(fun () -> if script#buffer#modified
+                 then img#set_stock `SAVE
+                 else img#set_stock `YES) in
+  let _ =
+    session_paned#misc#connect#size_allocate
+      (let old_paned_width = ref 2 in
+       let old_paned_height = ref 2 in
+         (fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
+            if !old_paned_width <> paned_width || !old_paned_height <> paned_height then (
+              session_paned#set_position (session_paned#position * paned_width / !old_paned_width);
+              state_paned#set_position (state_paned#position * paned_height / !old_paned_height);
+              old_paned_width := paned_width;
+              old_paned_height := paned_height;
+            ))) in
+    script_scroll#add script#coerce;
+    proof_scroll#add proof#coerce;
+    message_scroll#add message#coerce;
+    session_tab#pack bname#coerce;
+    img#set_stock `YES;
+    session_paned#set_position 1;
+    state_paned#set_position 1;
+    (Some session_tab#coerce,None,session_paned#coerce)
+
+let session_notebook =
+  Typed_notebook.create notebook_page_of_session ~border_width:2 ~show_border:false ~scrollable:true ()
+
+let active_view = ref (~-1)
+
+let on_active_view f =
+  if !active_view < 0
+  then failwith "no active view !"
+  else f (session_notebook#get_nth_term !active_view)
+
+let cb = GData.clipboard Gdk.Atom.primary
+
+
+let last_cb_content = ref ""
 
 
-let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; 
-			Sys.sigill; Sys.sigpipe; Sys.sigquit; 
+let update_notebook_pos () =
+  let pos =
+    match !current.vertical_tabs, !current.opposite_tabs with
+      | false, false -> `TOP
+      | false, true  -> `BOTTOM
+      | true , false -> `LEFT
+      | true , true  -> `RIGHT
+  in
+  session_notebook#set_tab_pos pos
+
+
+let set_active_view i =
+  prerr_endline "entering set_active_view";
+  (try on_active_view (fun {tab_label=lbl} -> lbl#set_text lbl#text) with _ -> ());
+  session_notebook#goto_page i;
+  let s = session_notebook#current_term in
+    s.tab_label#set_use_markup true;
+    s.tab_label#set_label ("<span background=\"light green\">"^s.tab_label#text^"</span>");
+    active_view := i;
+    prerr_endline "exiting set_active_view"
+
+
+
+let to_do_on_page_switch = ref []
+
+
+let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
+			Sys.sigill; Sys.sigpipe; Sys.sigquit;
 			(* Sys.sigsegv; Sys.sigterm;*) Sys.sigusr2]
 
 let crash_save i =
   (*  ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*)
   Pervasives.prerr_endline "Trying to save all buffers in .crashcoqide files";
-  let count = ref 0 in 
-    Vector.iter 
-      (function {view=view; analyzed_view = Some av } -> 
-	 (let filename = match av#filename with 
-	    | None -> 
-		incr count; 
+  let count = ref 0 in
+    List.iter
+      (function {script=view; analyzed_view = av } ->
+	 (let filename = match av#filename with
+	    | None ->
+		incr count;
 		"Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
 	    | Some f -> f^".crashcoqide"
 	  in
-	    try 
+	    try
 	      if try_export filename (view#buffer#get_text ()) then
 		Pervasives.prerr_endline ("Saved "^filename)
 	      else Pervasives.prerr_endline ("Could not save "^filename)
 	    with _ -> Pervasives.prerr_endline ("Could not save "^filename))
-	 | _ -> Pervasives.prerr_endline "Unanalyzed view found. Please report."
       )
-      input_views;
+      session_notebook#pages;
     Pervasives.prerr_endline "Done. Please report.";
     if i <> 127 then exit i
 
@@ -240,9 +235,9 @@ let coq_computing = Mutex.create ()
 (* To prevent Coq from interrupting during undoing...*)
 let coq_may_stop = Mutex.create ()
 
-let break () = 
+let break () =
   prerr_endline "User break received:";
-  if not (Mutex.try_lock coq_computing) then 
+  if not (Mutex.try_lock coq_computing) then
     begin
       prerr_endline " trying to stop computation:";
       if Mutex.try_lock coq_may_stop then begin
@@ -256,225 +251,110 @@ let break () =
       prerr_endline " ignored (not computing)"
     end
 
-let do_if_not_computing text f x = 
-  let threaded_task () =
-    if Mutex.try_lock coq_computing 
-    then 
-      begin
-	let w = Blaster_window.blaster_window () in
-	  if not (Mutex.try_lock w#lock) then 
-	    begin 
-	      break ();
-	      let lck = Mutex.create () in
-		Mutex.lock lck;
-		prerr_endline "Waiting on blaster...";
-		Condition.wait w#blaster_killed lck;
-		prerr_endline "Waiting on blaster ok";
-		Mutex.unlock lck
-	    end 
-	  else 
-	    Mutex.unlock w#lock;
-	  let idle = 
-	    Glib.Timeout.add ~ms:300
-	      ~callback:(fun () -> async !pulse ();true) in
-	    begin
-	      prerr_endline "Getting lock";
-	      try
-		f x;
-		Glib.Timeout.remove idle;
-		prerr_endline "Releasing lock";
-		Mutex.unlock coq_computing;
-	      with e ->
-		Glib.Timeout.remove idle;
-		prerr_endline "Releasing lock (on error)";
-		Mutex.unlock coq_computing;
-		raise e
-	    end
-      end 
-    else 
-      prerr_endline 
-	"Discarded order (computations are ongoing)" 
-  in
-    prerr_endline ("Launching thread " ^ text);
-    ignore (Thread.create threaded_task ())
-
-let add_input_view tv = 
-  Vector.append input_views tv
-
-let get_input_view i = 
-  if 0 <= i && i < Vector.length input_views
-  then
-    Vector.get input_views i
-  else raise Not_found 
-
-let active_view = ref None
-
-let get_active_view () = Vector.get input_views (Option.get !active_view)
-
-let set_active_view i = 
-  (match !active_view with  None -> () | Some i -> 
-     reset_tab_label i);
-  (notebook ())#goto_page i; 
-  let txt = get_current_tab_label () in
-    set_current_tab_label ("<span background=\"light green\">"^txt^"</span>");
-    active_view := Some i
-
-let set_current_view i = (notebook ())#goto_page i
-
-let kill_input_view i = 
-  let v = Vector.get input_views i in
-    (match v.analyzed_view with 
-       | Some v -> v#kill_detached_views ()
-       | None -> ());
-    v.view#destroy ();
-    v.analyzed_view <- None;
-    Vector.remove input_views i
-
-let get_current_view_page () = (notebook ())#current_page
-let get_current_view () = Vector.get input_views (notebook ())#current_page
-let remove_current_view_page () = 
-  let c =  (notebook ())#current_page in
-    kill_input_view c;
-    ((notebook ())#get_nth_page c)#misc#hide ()
-
-let is_word_char c =
-  (* TODO: avoid num and prime at the head of a word *)
-  Glib.Unichar.isalnum c || c = underscore || c = prime
-
-let starts_word it = 
-  prerr_endline ("Starts word ? '"^(Glib.Utf8.from_unichar it#char)^"'");
-  (not it#copy#nocopy#backward_char ||
-     (let c = it#backward_char#char in
-	not (is_word_char c)))
-
-let ends_word it = 
-  (not it#copy#nocopy#forward_char ||
-     let c = it#forward_char#char in
-       not (is_word_char c)
-  )
-
-let inside_word it = 
-  let c = it#char in
-    not (starts_word it) &&
-      not (ends_word it) &&
-      is_word_char c
-
-let is_on_word_limit it = inside_word it || ends_word it 
-
-let rec find_word_start it =
-  prerr_endline "Find word start";
-  if not it#nocopy#backward_char then 
-    (prerr_endline "find_word_start: cannot backward"; it)
-  else if is_word_char it#char
-  then find_word_start it
-  else (it#nocopy#forward_char; 
-	prerr_endline ("Word start at: "^(string_of_int it#offset));it)
-let find_word_start (it:GText.iter) = find_word_start it#copy
-
-let rec find_word_end it =
-  prerr_endline "Find word end";
-  if let c = it#char in c<>0 && is_word_char c
-  then begin 
-      ignore (it#nocopy#forward_char);
-      find_word_end it
-    end else (prerr_endline ("Word end at: "^(string_of_int it#offset));it)
-let find_word_end it = find_word_end it#copy
-
-
-let get_word_around it = 
-  let start = find_word_start it in
-  let stop =  find_word_end it in
-    start,stop
-
-
-let rec complete_backward w (it:GText.iter) = 
-  prerr_endline "Complete backward...";
-  match it#backward_search w with 
-    | None -> (prerr_endline "backward_search failed";None)
-    | Some (start,stop) -> 
-	prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
-	if starts_word start then 
-	  let ne = find_word_end stop in
-	    if ne#compare stop = 0
-	    then complete_backward w start
-	    else Some (start,stop,ne)
-	else complete_backward w start
-	  
-let rec complete_forward w (it:GText.iter) = 
-  prerr_endline "Complete forward...";
-  match it#forward_search w with 
-    | None -> None
-    | Some (start,stop) -> 
-	if starts_word start then 	
-	  let ne = find_word_end stop in
-	    if ne#compare stop = 0 then 
-	      complete_forward w stop
-	    else Some (stop,stop,ne)
-	else complete_forward w stop
+let do_if_not_computing text f x =
+  if Mutex.try_lock coq_computing then
+    let threaded_task () =
+      prerr_endline "Getting lock";
+      try
+        f x;
+        prerr_endline "Releasing lock";
+        Mutex.unlock coq_computing;
+      with e ->
+        prerr_endline "Releasing lock (on error)";
+        Mutex.unlock coq_computing;
+        raise e
+    in
+      prerr_endline ("Launching thread " ^ text);
+      ignore (Glib.Timeout.add ~ms:300 ~callback:
+                  (fun () -> if Mutex.try_lock coq_computing
+                             then (Mutex.unlock coq_computing; false)
+                             else (pbar#pulse (); true)));
+      ignore (Thread.create threaded_task ())
+  else
+    prerr_endline
+      "Discarded order (computations are ongoing)"
+
+(* XXX - 1 appel *)
+let kill_input_view i =
+  let v = session_notebook#get_nth_term i in
+    v.analyzed_view#kill_detached_views ();
+    v.script#destroy ();
+    v.tab_label#destroy ();
+    v.proof_view#destroy ();
+    v.message_view#destroy ();
+    session_notebook#remove_page i
+(*
+(* XXX - beaucoups d'appels, a garder *)
+let get_current_view =
+  focused_session
+ *)
+let remove_current_view_page () =
+  let c = session_notebook#current_page in
+    kill_input_view c
+
 
 (* Reset this to None on page change ! *)
 let (last_completion:(string*int*int*bool) option ref) = ref None
 
-let () = to_do_on_page_switch := 
+let () = to_do_on_page_switch :=
   (fun i -> last_completion := None)::!to_do_on_page_switch
 
 let rec complete input_buffer w (offset:int) =
-  match !last_completion with 
+  match !last_completion with
     | Some (lw,loffset,lpos,backward)
 	when lw=w && loffset=offset ->
 	begin
 	  let iter = input_buffer#get_iter (`OFFSET lpos) in
-	    if backward then 
+	    if backward then
 	      match complete_backward w iter with
-		| None -> 
-		    last_completion := 
+		| None ->
+		    last_completion :=
 		      Some (lw,loffset,
-			    (find_word_end 
+			    (find_word_end
 			       (input_buffer#get_iter (`OFFSET loffset)))#offset ,
-			    false); 
+			    false);
 		    None
-		| Some (ss,start,stop) as result -> 
-		    last_completion := 
+		| Some (ss,start,stop) as result ->
+		    last_completion :=
 		      Some (w,offset,ss#offset,true);
 		    result
 	    else
 	      match complete_forward w iter with
-		| None -> 
+		| None ->
 		    last_completion := None;
 		    None
-		| Some (ss,start,stop) as result -> 
-		    last_completion := 
+		| Some (ss,start,stop) as result ->
+		    last_completion :=
 		      Some (w,offset,ss#offset,false);
 		    result
 	end
     | _ -> begin
 	  match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
-	    | None -> 
-		last_completion := 
+	    | None ->
+		last_completion :=
 		  Some (w,offset,(find_word_end (input_buffer#get_iter
 						   (`OFFSET offset)))#offset,false);
 		complete input_buffer w offset
-	    | Some (ss,start,stop) as result -> 
+	    | Some (ss,start,stop) as result ->
 		last_completion := Some (w,offset,ss#offset,true);
 		result
       end
-	
+
 let get_current_word () =
-  let av = Option.get ((get_current_view ()).analyzed_view) in 
-    match (cb ())#text with
-      | None -> 
+  match session_notebook#current_term,cb#text with
+    | {script=script; analyzed_view=av;},None ->
 	  prerr_endline "None selected";
 	  let it = av#get_insert in
 	  let start = find_word_start it in
 	  let stop = find_word_end start in
-	    av#view#buffer#move_mark `SEL_BOUND start;
-	    av#view#buffer#move_mark `INSERT stop;
-	    av#view#buffer#get_text ~slice:true ~start ~stop ()
-      | Some t ->
+	    script#buffer#move_mark `SEL_BOUND start;
+	    script#buffer#move_mark `INSERT stop;
+	    script#buffer#get_text ~slice:true ~start ~stop ()
+      | _,Some t ->
  	  prerr_endline "Some selected";
 	  prerr_endline t;
 	  t
-	    
+
 
 let input_channel b ic =
   let buf = String.create 1024 and len = ref 0 in
@@ -488,142 +368,6 @@ let with_file handler name ~f =
     try f ic; close_in ic with e -> close_in ic; raise e
   with Sys_error s -> handler s
 
-type info =  {start:GText.mark;
-	      stop:GText.mark;
-	      ast:Util.loc * Vernacexpr.vernac_expr;
-	      reset_info:Coq.reset_info
-	     }
-
-exception Size of int
-let (processed_stack:info Stack.t) = Stack.create ()
-let push x = Stack.push x processed_stack
-let pop () = try Stack.pop processed_stack with Stack.Empty -> raise (Size 0)
-let top () = try Stack.top processed_stack with Stack.Empty -> raise (Size 0)
-let is_empty () = Stack.is_empty processed_stack
-
-(* push a new Coq phrase *)
-
-let update_on_end_of_segment id =
-  let lookup_section = function 
-    | { reset_info = ResetAtSegmentStart id',_,_ } when id = id' -> raise Exit
-    | { reset_info = _,_,r } -> r := false
-  in
-    try Stack.iter lookup_section processed_stack with Exit -> ()
-
-let push_phrase reset_info start_of_phrase_mark end_of_phrase_mark ast = 
-  let x = {start = start_of_phrase_mark;
-	   stop = end_of_phrase_mark;
-	   ast = ast;
-	   reset_info = reset_info
-	  } in
-  begin
-    match snd ast with
-    | VernacEndSegment (_,id) -> 
-        prerr_endline "Updating on end of segment 1";
-        update_on_end_of_segment id
-    | _ -> ()
-  end;
-  push x
-
-
-let repush_phrase reset_info x =
-  let x = { x with reset_info = reset_info } in
-  begin
-    match snd x.ast with
-      | VernacEndSegment (_,id) ->
-          prerr_endline "Updating on end of segment 2";
-          update_on_end_of_segment id
-      | _ -> ()
-  end;
-  push x
-
-type backtrack =
-| BacktrackToNextActiveMark
-| BacktrackToMark of reset_mark
-| BacktrackToModSec of Names.identifier
-| NoBacktrack
-
-let add_undo = function (n,a,b,p,l as x) -> if p = 0 then (n+1,a,b,p,l) else x
-let add_abort = function
-  | (n,a,b,0,l) -> (0,a+1,b,0,l)
-  | (n,a,b,p,l) -> (n,a,b,p-1,l)
-let add_qed q (n,a,b,p,l as x) =
-  if q = 0 then x else (n,a,BacktrackToNextActiveMark,p+q,l)
-let add_backtrack (n,a,b,p,l) b' = (n,a,b',p,l)
-
-let update_proofs (n,a,b,p,cur_lems) prev_lems =
-  let ncommon = List.length (Util.list_intersect cur_lems prev_lems) in
-  let openproofs = List.length cur_lems - ncommon in
-  let closedproofs = List.length prev_lems - ncommon in
-  let undos = (n,a,b,p,prev_lems) in
-  add_qed closedproofs (Util.iterate add_abort openproofs undos)
-
-let pop_command undos t =
-  let (state_info,undo_info,section_info) = t.reset_info in
-  let undos =
-    if !section_info then
-      let undos = update_proofs undos undo_info in
-      match state_info with
-      | _ when is_vernac_tactic_command (snd t.ast) ->
-	  (* A tactic, active if not below a Qed *)
-          add_undo undos
-      | ResetAtRegisteredObject mark ->
-          add_backtrack undos (BacktrackToMark mark)
-      | ResetAtSegmentStart id ->
-          add_backtrack undos (BacktrackToModSec id)
-      | _ when is_vernac_state_preserving_command (snd t.ast) ->
-	  undos
-      | _ ->
-          add_backtrack undos BacktrackToNextActiveMark
-    else
-      begin 
-        prerr_endline "In section";
-      (* An object inside a closed section *)
-      add_backtrack undos BacktrackToNextActiveMark
-      end in
-  ignore (pop ());
-  undos
-
-let apply_aborts a =
-  if a <> 0 then prerr_endline ("Applying "^string_of_int a^" aborts");
-  try Util.repeat a Pfedit.delete_current_proof ()
-  with e -> prerr_endline "WARNING : found a closed environment"; raise e
-
-exception UndoStackExhausted
-
-let apply_tactic_undo n =
-  if n<>0 then
-    (prerr_endline ("Applying "^string_of_int n^" undos");
-     try Pfedit.undo n with _ -> raise UndoStackExhausted)
-
-let apply_reset = function
-  | BacktrackToMark mark -> reset_to mark
-  | BacktrackToModSec id -> reset_to_mod id
-  | NoBacktrack -> ()
-  | BacktrackToNextActiveMark -> assert false
-
-let rec apply_undos (n,a,b,p,l as undos) =
-  if p = 0 & b <> BacktrackToNextActiveMark then
-    begin
-      apply_aborts a;
-      try
-	apply_tactic_undo n;
-	apply_reset b
-      with UndoStackExhausted ->
-	apply_undos (n,0,BacktrackToNextActiveMark,p,l)
-    end
-  else
-    (* re-synchronize Coq to the current state of the stack *)
-    if is_empty () then
-      Coq.reset_initial ()
-    else
-      begin
-        let t = top () in
-        apply_undos (pop_command undos t);
-        let reset_info = Coq.compute_reset_info (snd t.ast) in
-        interp_last t.ast;
-        repush_phrase reset_info t
-      end
 
 (* For electric handlers *)
 exception Found
@@ -631,19 +375,16 @@ exception Found
 (* For find_phrase_starting_at *)
 exception Stop of int
 
-let activate_input i = 
-  (match !active_view with
-     | None -> () 
-     | Some n ->
-	 let a_v = Option.get (Vector.get input_views n).analyzed_view in
-	   a_v#deactivate ();
-	   a_v#reset_initial
-  );
-  let activate_function = (Option.get (Vector.get input_views i).analyzed_view)#activate in
-    activate_function ();
-    set_active_view i
-
-let warning msg = 
+(* XXX *)
+let activate_input i =
+  prerr_endline "entering activate_input";
+  (try on_active_view (fun {analyzed_view=a_v} -> a_v#reset_initial; a_v#deactivate ())
+   with _ -> ());
+  (session_notebook#get_nth_term i).analyzed_view#activate ();
+  set_active_view i;
+  prerr_endline "exiting activate_input"
+
+let warning msg =
   GToolbox.message_box ~title:"Warning"
     ~icon:(let img = GMisc.image () in
 	     img#set_stock `DIALOG_WARNING;
@@ -651,30 +392,142 @@ let warning msg =
 	     img#coerce)
     msg
 
-
-class analyzed_view index =
-  let {view = input_view_} as current_all_ =  get_input_view index in
-  let proof_view_ = Option.get !proof_view in
-  let message_view_ = Option.get !message_view in
+let apply_tag (buffer:GText.buffer) orig off_conv from upto sort =
+  let conv_and_apply start stop tag =
+    let start = orig#forward_chars (off_conv from) in
+    let stop = orig#forward_chars (off_conv upto) in
+    buffer#apply_tag ~start ~stop tag
+  in match sort with
+    | Coq_lex.Comment ->
+        conv_and_apply from upto Tags.Script.comment
+    | Coq_lex.Keyword ->
+        conv_and_apply from upto Tags.Script.kwd
+    | Coq_lex.Declaration ->
+        conv_and_apply from upto Tags.Script.decl
+    | Coq_lex.ProofDeclaration ->
+        conv_and_apply from upto Tags.Script.proof_decl
+    | Coq_lex.Qed ->
+        conv_and_apply from upto Tags.Script.qed
+    | Coq_lex.String -> ()
+
+let remove_tags (buffer:GText.buffer) from upto =
+  List.iter (buffer#remove_tag ~start:from ~stop:upto)
+    [ Tags.Script.comment; Tags.Script.kwd; Tags.Script.decl;
+      Tags.Script.proof_decl; Tags.Script.qed ]
+
+let split_slice_lax (buffer:GText.buffer) from upto =
+  remove_tags buffer from upto;
+  buffer#remove_tag ~start:from ~stop:upto Tags.Script.lax_end;
+  let slice = buffer#get_text ~start:from ~stop:upto () in
+  let slice = slice ^ " " in
+  let rec split_substring str =
+    let off_conv = byte_offset_to_char_offset str in
+    let slice_len = String.length str in
+    let sentence_len = Coq_lex.find_end_offset (apply_tag buffer from off_conv) str in
+
+    let stop = from#forward_chars (pred (off_conv sentence_len)) in
+    let start = stop#backward_char in
+    buffer#apply_tag ~start ~stop Tags.Script.lax_end;
+
+    if 1 < slice_len - sentence_len then begin (* remember that we added a trailing space *)
+      ignore (from#nocopy#forward_chars (off_conv sentence_len));
+      split_substring (String.sub str sentence_len (slice_len - sentence_len))
+    end
+  in
+  split_substring slice
+
+let rec grab_safe_sentence_start (iter:GText.iter) soi =
+  let lax_back = iter#backward_char#has_tag Tags.Script.lax_end in
+  let on_space = List.mem iter#char [0x09;0x0A;0x20] in
+  let full_ending = iter#is_start || (lax_back & on_space) in
+  if full_ending then iter
+  else if iter#compare soi <= 0 then raise Not_found
+  else
+    let prev = iter#backward_to_tag_toggle (Some Tags.Script.lax_end) in
+    (if prev#has_tag Tags.Script.lax_end then
+       ignore (prev#nocopy#backward_to_tag_toggle (Some Tags.Script.lax_end)));
+    grab_safe_sentence_start prev soi
+
+let grab_sentence_end_from (start:GText.iter) =
+  let stop = start#forward_to_tag_toggle (Some Tags.Script.lax_end) in
+  stop#forward_char
+
+let get_sentence_bounds (iter:GText.iter) =
+  let start = iter#backward_to_tag_toggle (Some Tags.Script.lax_end) in
+  (if start#has_tag Tags.Script.lax_end then ignore (
+    start#nocopy#backward_to_tag_toggle (Some Tags.Script.lax_end)));
+  let stop = start#forward_to_tag_toggle (Some Tags.Script.lax_end) in
+  let stop = stop#forward_char in
+  start,stop
+
+let end_tag_present end_iter =
+  end_iter#backward_char#has_tag Tags.Script.lax_end
+
+let tag_on_insert =
+  let skip_last = ref (ref true) in (* ref to the mutable flag created on last call *)
+  fun buffer ->
+    try 
+      let insert = buffer#get_iter_at_mark `INSERT in
+      let start = grab_safe_sentence_start insert
+                    (buffer#get_iter_at_mark (`NAME "start_of_input")) in 
+      let stop = grab_sentence_end_from insert in
+      let skip_curr = ref true in (* shall the callback be skipped ? by default yes*)
+      (!skip_last) := true; (* skip the previously created callback *)
+      skip_last := skip_curr;
+      try split_slice_lax buffer start stop
+      with Not_found ->
+        skip_curr := false;
+        ignore (Glib.Timeout.add ~ms:1500
+                  ~callback:(fun () -> if not !skip_curr then (
+                    try split_slice_lax buffer start buffer#end_iter with _ -> ()); false))
+    with Not_found ->
+      let err_pos = buffer#get_iter_at_mark (`NAME "start_of_input") in
+      buffer#apply_tag Tags.Script.error ~start:err_pos ~stop:err_pos#forward_char
+
+let force_retag buffer =
+  try split_slice_lax buffer buffer#start_iter buffer#end_iter with _ -> ()
+
+let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) =
+  (* move back twice if not into proof_decl,
+   * once if into proof_decl and back_char into_proof_decl,
+   * don't move if into proof_decl and back_char not into proof_decl *)
+  if not (cursor#has_tag Tags.Script.proof_decl) then
+    ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl));
+  if cursor#backward_char#has_tag Tags.Script.proof_decl then
+    ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl));
+  let decl_start = cursor in
+  let prf_end = decl_start#forward_to_tag_toggle (Some Tags.Script.qed) in
+  let decl_end = grab_sentence_end_from decl_start in
+  let prf_end = grab_sentence_end_from prf_end in
+  let prf_end = prf_end#forward_char in
+  if decl_start#has_tag Tags.Script.folded then (
+    buffer#remove_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
+    buffer#remove_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden)
+  else (
+    buffer#apply_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
+    buffer#apply_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden)
+
+class analyzed_view (_script:Undo.undoable_view) (_pv:GText.view) (_mv:GText.view) _cs =
 object(self)
-  val current_all =  current_all_
-  val input_view = current_all_.view
-  val proof_view = Option.get !proof_view
-  val message_view = Option.get !message_view
-  val input_buffer = input_view_#buffer
-  val proof_buffer = proof_view_#buffer
-  val message_buffer = message_view_#buffer 
+  val input_view = _script
+  val input_buffer = _script#buffer
+  val proof_view = _pv
+  val proof_buffer = _pv#buffer
+  val message_view = _mv
+  val message_buffer = _mv#buffer
+  val cmd_stack = _cs
   val mutable is_active = false
   val mutable read_only = false
-  val mutable filename = None 
+  val mutable filename = None
   val mutable stats = None
   val mutable last_modification_time = 0.
   val mutable last_auto_save_time = 0.
   val mutable detached_views = []
 
   val mutable auto_complete_on = !current.auto_complete
+  val hidden_proofs = Hashtbl.create 32
 
-  method private toggle_auto_complete = 
+  method private toggle_auto_complete =
     auto_complete_on <- not auto_complete_on
   method set_auto_complete t = auto_complete_on <- t
   method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x ->
@@ -683,131 +536,130 @@ object(self)
       let y = f x in
 	self#set_auto_complete old;
 	y
-  method add_detached_view (w:GWindow.window) = 
+  method add_detached_view (w:GWindow.window) =
     detached_views <- w::detached_views
-  method remove_detached_view (w:GWindow.window) = 
+  method remove_detached_view (w:GWindow.window) =
     detached_views <- List.filter (fun e -> w#misc#get_oid<>e#misc#get_oid) detached_views
 
-  method kill_detached_views () = 
+  method kill_detached_views () =
     List.iter (fun w -> w#destroy ()) detached_views;
     detached_views <- []
 
-  method view = input_view
   method filename = filename
   method stats = stats
-  method set_filename f = 
+  method set_filename f =
     filename <- f;
-    match f with 
+    match f with
       | Some f -> stats <- my_stat f
       | None -> ()
 
-  method update_stats = 
-    match filename with 
-      | Some f -> stats <- my_stat f 
+  method update_stats =
+    match filename with
+      | Some f -> stats <- my_stat f
       | _ -> ()
 
-  method revert = 
-    match filename with 
+  method revert =
+    match filename with
       | Some f -> begin
-	    let do_revert () = begin
-		!push_info "Reverting buffer";
-		try
-		  if is_active then self#reset_initial;
-		  let b = Buffer.create 1024 in
-		    with_file !flash_info f ~f:(input_channel b);
-		    let s = try_convert (Buffer.contents b) in
-		      input_buffer#set_text s;
-		      self#update_stats;
-		      input_buffer#place_cursor input_buffer#start_iter;
-		      input_buffer#set_modified false;
-		      !pop_info ();
-		      !flash_info "Buffer reverted";
-		      Highlight.highlight_all input_buffer;
-		with _  -> 
-		  !pop_info ();
-		  !flash_info "Warning: could not revert buffer";
-	      end
-	    in
-	      if input_buffer#modified then 
-		match (GToolbox.question_box 
-			 ~title:"Modified buffer changed on disk"
-			 ~buttons:["Revert from File";
-				   "Overwrite File";
-				   "Disable Auto Revert"] 
-			 ~default:0
-			 ~icon:(stock_to_widget `DIALOG_WARNING)
-			 "Some unsaved buffers changed on disk"
-		      )
-		with 1 -> do_revert ()
-		  | 2 -> if self#save f then !flash_info "Overwritten" else
-			!flash_info "Could not overwrite file"
-		  | _ -> 
-		      prerr_endline "Auto revert set to false";
-		      !current.global_auto_revert <- false;
-		      disconnect_revert_timer ()
-	      else do_revert () 
-	end
+          let do_revert () = begin
+            push_info "Reverting buffer";
+            try
+              if is_active then self#reset_initial;
+              let b = Buffer.create 1024 in
+                with_file flash_info f ~f:(input_channel b);
+                let s = try_convert (Buffer.contents b) in
+                  input_buffer#set_text s;
+                  self#update_stats;
+                  input_buffer#place_cursor input_buffer#start_iter;
+                  input_buffer#set_modified false;
+                  pop_info ();
+                  flash_info "Buffer reverted";
+                  force_retag input_buffer;
+            with _  ->
+              pop_info ();
+              flash_info "Warning: could not revert buffer";
+          end
+          in
+            if input_buffer#modified then
+              match (GToolbox.question_box
+                       ~title:"Modified buffer changed on disk"
+                       ~buttons:["Revert from File";
+                                 "Overwrite File";
+                                 "Disable Auto Revert"]
+                       ~default:0
+                                   ~icon:(stock_to_widget `DIALOG_WARNING)
+                                   "Some unsaved buffers changed on disk"
+              )
+              with 1 -> do_revert ()
+                | 2 -> if self#save f then flash_info "Overwritten" else
+                    flash_info "Could not overwrite file"
+                | _ ->
+                    prerr_endline "Auto revert set to false";
+                    !current.global_auto_revert <- false;
+                    disconnect_revert_timer ()
+                    else do_revert ()
+        end
       | None -> ()
-	  
-  method save f = 
+
+  method save f =
     if try_export f (input_buffer#get_text ()) then begin
-	filename <- Some f;
-	input_buffer#set_modified false;
-	stats <- my_stat f;
-	(match self#auto_save_name with 
-	   | None -> ()
-	   | Some fn -> try Sys.remove fn with _ -> ());
-	true
-      end
+      filename <- Some f;
+      input_buffer#set_modified false;
+      stats <- my_stat f;
+      (match self#auto_save_name with
+         | None -> ()
+         | Some fn -> try Sys.remove fn with _ -> ());
+      true
+    end
     else false
 
-  method private auto_save_name = 
-    match filename with 
+  method private auto_save_name =
+    match filename with
       | None -> None
-      | Some f -> 
-	  let dir = Filename.dirname f in
-	  let base = (fst !current.auto_save_name) ^ 
-	    (Filename.basename f) ^ 
-	    (snd !current.auto_save_name) 
-	  in Some (Filename.concat dir base)
-	    
-  method private need_auto_save = 
+      | Some f ->
+          let dir = Filename.dirname f in
+          let base = (fst !current.auto_save_name) ^
+                     (Filename.basename f) ^
+                     (snd !current.auto_save_name)
+          in Some (Filename.concat dir base)
+
+  method private need_auto_save =
     input_buffer#modified &&
-      last_modification_time > last_auto_save_time
-      
+    last_modification_time > last_auto_save_time
+
   method auto_save =
     if self#need_auto_save then begin
-	match self#auto_save_name with 
-	  | None -> () 
-	  | Some fn -> 
-	      try 
-		last_auto_save_time <- Unix.time();
-		prerr_endline ("Autosave time : "^(string_of_float (Unix.time())));
-		if try_export fn (input_buffer#get_text ()) then begin
-		    !flash_info ~delay:1000 "Autosaved"
-		  end
-		else warning 
-		  ("Autosave failed (check if " ^ fn ^ " is writable)")
-	      with _ -> 
-		warning ("Autosave: unexpected error while writing "^fn)
-      end	      
-      
+      match self#auto_save_name with
+        | None -> ()
+        | Some fn ->
+            try
+              last_auto_save_time <- Unix.time();
+              prerr_endline ("Autosave time : "^(string_of_float (Unix.time())));
+              if try_export fn (input_buffer#get_text ()) then begin
+                flash_info ~delay:1000 "Autosaved"
+              end
+              else warning
+                     ("Autosave failed (check if " ^ fn ^ " is writable)")
+            with _ ->
+              warning ("Autosave: unexpected error while writing "^fn)
+    end
+
   method save_as f =
-    if Sys.file_exists f then 
+    if Sys.file_exists f then
       match (GToolbox.question_box ~title:"File exists on disk"
-	       ~buttons:["Overwrite";
-			 "Cancel";] 
-	       ~default:1
-	       ~icon:
-	       (let img = GMisc.image () in
-		  img#set_stock `DIALOG_WARNING;
-		  img#set_icon_size `DIALOG;
-		  img#coerce)
-	       ("File "^f^"already exists")
-	    )
+               ~buttons:["Overwrite";
+                         "Cancel";]
+               ~default:1
+                           ~icon:
+                           (let img = GMisc.image () in
+                              img#set_stock `DIALOG_WARNING;
+                              img#set_icon_size `DIALOG;
+                              img#coerce)
+                           ("File "^f^"already exists")
+      )
       with 1 -> self#save f
-	| _ -> false
-    else self#save f
+        | _ -> false
+          else self#save f
 
   method set_read_only b = read_only<-b
   method read_only = read_only
@@ -823,585 +675,494 @@ object(self)
   method clear_message = message_buffer#set_text ""
   val mutable last_index = true
   val last_array = [|"";""|]
-  method get_start_of_input =  input_buffer#get_iter_at_mark (`NAME "start_of_input") 
+  method get_start_of_input =  input_buffer#get_iter_at_mark (`NAME "start_of_input")
 
   method get_insert = get_insert input_buffer
 
-  method recenter_insert = 
-    (* BUG : to investigate further: 
-       FIXED : Never call  GMain.* in thread !
-       PLUS : GTK BUG ??? Cannot be called from a thread...
-       ADDITION: using sync instead of async causes deadlock...*)
+  method recenter_insert =
+    (* BUG : to investigate further:
+     FIXED : Never call  GMain.* in thread !
+     PLUS : GTK BUG ??? Cannot be called from a thread...
+     ADDITION: using sync instead of async causes deadlock...*)
     ignore (GtkThread.async (
-			      input_view#scroll_to_mark 
-				~use_align:false
-				~yalign:0.75
-				~within_margin:0.25)
-	      `INSERT)
+      input_view#scroll_to_mark
+        ~use_align:false
+        ~yalign:0.75
+        ~within_margin:0.25)
+              `INSERT)
 
 
-  method indent_current_line = 
+  method indent_current_line =
     let get_nb_space it =
       let it = it#copy in
       let nb_sep = ref 0 in
       let continue = ref true in
-	while !continue do 
-	  if it#char = space then begin 
-	      incr nb_sep;
-	      if not it#nocopy#forward_char then continue := false;
-	    end else continue := false
-	done;
-	!nb_sep
+        while !continue do
+          if it#char = space then begin
+            incr nb_sep;
+            if not it#nocopy#forward_char then continue := false;
+          end else continue := false
+        done;
+        !nb_sep
     in
     let previous_line = self#get_insert in
       if previous_line#nocopy#backward_line then begin
-	  let previous_line_spaces = get_nb_space previous_line in
-	  let current_line_start = self#get_insert#set_line_offset 0 in
-	  let current_line_spaces = get_nb_space current_line_start in
-	    if input_buffer#delete_interactive 
-	      ~start:current_line_start 
-	      ~stop:(current_line_start#forward_chars current_line_spaces)
-	      ()
-	    then 
-	      let current_line_start = self#get_insert#set_line_offset 0 in
-		input_buffer#insert 
-		  ~iter:current_line_start
-		  (String.make previous_line_spaces ' ')
-	end
+        let previous_line_spaces = get_nb_space previous_line in
+        let current_line_start = self#get_insert#set_line_offset 0 in
+        let current_line_spaces = get_nb_space current_line_start in
+          if input_buffer#delete_interactive
+               ~start:current_line_start
+               ~stop:(current_line_start#forward_chars current_line_spaces)
+               ()
+          then
+            let current_line_start = self#get_insert#set_line_offset 0 in
+              input_buffer#insert
+                ~iter:current_line_start
+                (String.make previous_line_spaces ' ')
+      end
 
-  method show_pm_goal = 
-      proof_buffer#insert 
-	(Printf.sprintf "    *** Declarative Mode ***\n");
-      try 
-	let (hyps,concl) = get_current_pm_goal () in
-	List.iter
-	  (fun ((_,_,_,(s,_)) as _hyp) -> 
-	     proof_buffer#insert (s^"\n"))
-	  hyps;
-	proof_buffer#insert 
-	  (String.make 38 '_' ^ "\n");
-	let (_,_,_,s) = concl in 
-	  proof_buffer#insert ("thesis := \n "^s^"\n");
-	let my_mark = `NAME "end_of_conclusion" in
-	  proof_buffer#move_mark
-	    ~where:((proof_buffer#get_iter_at_mark `INSERT)) 
-	    my_mark;
-	  ignore (proof_view#scroll_to_mark my_mark) 
-    with Not_found ->  
+  method show_pm_goal =
+    proof_buffer#insert
+      (Printf.sprintf "    *** Declarative Mode ***\n");
+    try
+      let (hyps,concl) = get_current_pm_goal () in
+        List.iter
+          (fun ((_,_,_,(s,_)) as _hyp) ->
+             proof_buffer#insert (s^"\n"))
+          hyps;
+        proof_buffer#insert
+          (String.make 38 '_' ^ "\n");
+        let (_,_,_,s) = concl in
+          proof_buffer#insert ("thesis := \n "^s^"\n");
+          let my_mark = `NAME "end_of_conclusion" in
+            proof_buffer#move_mark
+              ~where:((proof_buffer#get_iter_at_mark `INSERT))
+              my_mark;
+            ignore (proof_view#scroll_to_mark my_mark)
+    with Not_found ->
       match Decl_mode.get_end_command (Pfedit.get_pftreestate ()) with
-	  Some endc ->
-	    proof_buffer#insert 
-	      ("Subproof completed, now type "^endc^".") 
-	| None ->
-	    proof_buffer#insert "Proof completed."
+          Some endc ->
+            proof_buffer#insert
+              ("Subproof completed, now type "^endc^".")
+        | None ->
+            proof_buffer#insert "Proof completed."
+
 
-  method show_goals = 
-    try
-      proof_view#buffer#set_text "";
-      match Decl_mode.get_current_mode () with
-	  Decl_mode.Mode_none ->  proof_buffer#insert (Coq.print_no_goal ())
-	| Decl_mode.Mode_tactic ->   
-	    begin
-	      let s = Coq.get_current_goals () in
-		match s with 
-		  | [] -> proof_buffer#insert (Coq.print_no_goal ())
-		  | (hyps,concl)::r -> 
-		      let goal_nb = List.length s in
-			proof_buffer#insert 
-			  (Printf.sprintf "%d subgoal%s\n" 
-			     goal_nb
-			     (if goal_nb<=1 then "" else "s"));
-			List.iter
-			  (fun ((_,_,_,(s,_)) as _hyp) -> 
-			     proof_buffer#insert (s^"\n"))
-			  hyps;
-			proof_buffer#insert 
-			  (String.make 38 '_' ^ "(1/"^
-			     (string_of_int goal_nb)^
-			     ")\n") ;
-			let _,_,_,sconcl = concl in
-			  proof_buffer#insert sconcl;
-			  proof_buffer#insert "\n";
-			  let my_mark = `NAME "end_of_conclusion" in
-			    proof_buffer#move_mark
-			      ~where:((proof_buffer#get_iter_at_mark `INSERT)) 
-			      my_mark;
-			    proof_buffer#insert "\n\n";
-			    let i = ref 1 in
-			      List.iter 
-				(function (_,(_,_,_,concl)) -> 
-				   incr i;
-				   proof_buffer#insert 
-				     (String.make 38 '_' ^"("^
-					(string_of_int !i)^
-					"/"^
-					(string_of_int goal_nb)^
-					")\n");
-				   proof_buffer#insert concl;
-				   proof_buffer#insert "\n\n";
-				)
-				r;
-			      ignore (proof_view#scroll_to_mark my_mark) 
-	    end
-	| Decl_mode.Mode_proof -> 
-	    self#show_pm_goal
-    with e -> 
-      prerr_endline ("Don't worry be happy despite: "^Printexc.to_string e)
-	
-	      
   val mutable full_goal_done = true
 
-  method show_goals_full = 
+  method show_goals_full =
     if not full_goal_done then
       begin
-	try
-	  proof_view#buffer#set_text "";
-	  match Decl_mode.get_current_mode () with
-	      Decl_mode.Mode_none ->  
-		proof_buffer#insert (Coq.print_no_goal ())
-	    | Decl_mode.Mode_tactic ->   
-		begin
-		  match Coq.get_current_goals () with 
-		      [] -> Util.anomaly "show_goals_full"
-		  | ((hyps,concl)::r) as s ->
-		      let last_shown_area = 
-			proof_buffer#create_tag [`BACKGROUND "light green"]
-		      in
-		      let goal_nb = List.length s in
-			proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" 
-					 goal_nb
-					 (if goal_nb<=1 then "" else "s"));
-		  let coq_menu commands = 
-		    let tag = proof_buffer#create_tag []
-		    in 
-		      ignore
-			(tag#connect#event ~callback:
-			   (fun ~origin ev it ->
-			      begin match GdkEvent.get_type ev with 
-				| `BUTTON_PRESS -> 
-				    let ev = (GdkEvent.Button.cast ev) in
-				      if (GdkEvent.Button.button ev) = 3
-				      then begin 
-					let loc_menu = GMenu.menu () in
-					let factory = 
-					  new GMenu.factory loc_menu in
-					let add_coq_command (cp,ip) = 
-					  ignore 
-					    (factory#add_item cp 
-					       ~callback:
-				     (fun () -> ignore
-					(self#insert_this_phrase_on_success 
-					   true
-					   true 
-					   false 
-					   ("progress "^ip^"\n") 
-					   (ip^"\n"))
-				     )
-				  )
-			      in
-			      List.iter add_coq_command commands;
-			      loc_menu#popup 
-				~button:3
-				~time:(GdkEvent.Button.time ev);
-			    end
-			| `MOTION_NOTIFY -> 
-			    proof_buffer#remove_tag
-			    ~start:proof_buffer#start_iter
-			    ~stop:proof_buffer#end_iter
-			    last_shown_area;
-			    prerr_endline "Before find_tag_limits";
-			    
-			    let s,e = find_tag_limits tag 
-					(new GText.iter it) 
-			    in
-			    prerr_endline "After find_tag_limits";
-			    proof_buffer#apply_tag 
-			      ~start:s 
-			      ~stop:e 
-			      last_shown_area;
-			    
-			    prerr_endline "Applied tag";
-			    ()
-			| _ -> ()
-			end;false
-		     )
-		  );
-		tag
-	      in
-	      List.iter
-		(fun ((_,_,_,(s,_)) as hyp) -> 
-		   let tag = coq_menu (hyp_menu hyp) in
-		   proof_buffer#insert ~tags:[tag] (s^"\n"))
-		hyps;
-	      proof_buffer#insert 
-		(String.make 38 '_' ^"(1/"^
-		 (string_of_int goal_nb)^
-		 ")\n") 
-	      ;
-	      let tag = coq_menu (concl_menu concl) in
-	      let _,_,_,sconcl = concl in
-	      proof_buffer#insert ~tags:[tag] sconcl;
-	      proof_buffer#insert "\n";
-	      let my_mark = `NAME "end_of_conclusion" in
-	      proof_buffer#move_mark
-		~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark;
-	      proof_buffer#insert "\n\n";
-	      let i = ref 1 in
-	      List.iter 
-		(function (_,(_,_,_,concl)) -> 
-		   incr i;
-		   proof_buffer#insert 
-		     (String.make 38 '_' ^"("^
-		      (string_of_int !i)^
-		      "/"^
-		      (string_of_int goal_nb)^
-		      ")\n");
-		   proof_buffer#insert concl;
-		   proof_buffer#insert "\n\n";
-		)
-		r;
-		ignore (proof_view#scroll_to_mark my_mark) ;
-		full_goal_done <- true
-		end
-	    | Decl_mode.Mode_proof ->
-		self#show_pm_goal
-	  with e -> prerr_endline (Printexc.to_string e)
+        try
+          proof_buffer#set_text "";
+          match Decl_mode.get_current_mode () with
+              Decl_mode.Mode_none -> ()
+            | Decl_mode.Mode_tactic ->
+                begin
+                  match Coq.get_current_goals () with
+                      [] -> proof_buffer#insert (Coq.print_no_goal())
+                    | ((hyps,concl)::r) as s ->
+                        let last_shown_area = Tags.Proof.highlight
+                        in
+                        let goal_nb = List.length s in
+                          proof_buffer#insert (Printf.sprintf "%d subgoal%s\n"
+                                                 goal_nb
+                                                 (if goal_nb<=1 then "" else "s"));
+                          let coq_menu commands =
+                            let tag = proof_buffer#create_tag []
+                            in
+                              ignore
+                                (tag#connect#event ~callback:
+                                   (fun ~origin ev it ->
+                                      match GdkEvent.get_type ev with
+                                        | `BUTTON_PRESS ->
+                                            let ev = (GdkEvent.Button.cast ev) in
+                                              if (GdkEvent.Button.button ev) = 3
+                                              then (
+                                                let loc_menu = GMenu.menu () in
+                                                let factory =
+                                                  new GMenu.factory loc_menu in
+                                                let add_coq_command (cp,ip) =
+                                                  ignore
+                                                    (factory#add_item cp
+                                                       ~callback:
+                                                       (fun () -> ignore
+                                                                    (self#insert_this_phrase_on_success
+                                                                       true
+                                                                       true
+                                                                       false
+                                                                       ("progress "^ip^"\n")
+                                                                       (ip^"\n"))
+                                                       )
+                                                    )
+                                                in
+                                                  List.iter add_coq_command commands;
+                                                  loc_menu#popup
+                                                    ~button:3
+                                                    ~time:(GdkEvent.Button.time ev);
+                                                  true)
+                                              else false
+                                        | `MOTION_NOTIFY ->
+                                            proof_buffer#remove_tag
+                                              ~start:proof_buffer#start_iter
+                                              ~stop:proof_buffer#end_iter
+                                              last_shown_area;
+                                            prerr_endline "Before find_tag_limits";
+
+                                            let s,e = find_tag_limits tag
+                                                        (new GText.iter it)
+                                            in
+                                              prerr_endline "After find_tag_limits";
+                                              proof_buffer#apply_tag
+                                                ~start:s
+                                                ~stop:e
+                                                last_shown_area;
+
+                                              prerr_endline "Applied tag";
+                                              false
+                                        | _ ->
+                                            false
+                                   )
+                                );
+                              tag
+                          in
+                            List.iter
+                              (fun ((_,_,_,(s,_)) as hyp) ->
+                                 let tag = coq_menu (hyp_menu hyp) in
+                                   proof_buffer#insert ~tags:[tag] (s^"\n"))
+                              hyps;
+                            proof_buffer#insert
+                              (String.make 38 '_' ^"(1/"^
+                               (string_of_int goal_nb)^
+                               ")\n")
+                              ;
+                            let tag = coq_menu (concl_menu concl) in
+                            let _,_,_,sconcl = concl in
+                              proof_buffer#insert ~tags:[tag] sconcl;
+                              proof_buffer#insert "\n";
+                              let my_mark = `NAME "end_of_conclusion" in
+                                proof_buffer#move_mark
+                                  ~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark;
+                                proof_buffer#insert "\n\n";
+                                let i = ref 1 in
+                                  List.iter
+                                    (function (_,(_,_,_,concl)) ->
+                                      incr i;
+                                      proof_buffer#insert
+                                        (String.make 38 '_' ^"("^
+                                         (string_of_int !i)^
+                                         "/"^
+                                         (string_of_int goal_nb)^
+                                         ")\n");
+                                      proof_buffer#insert concl;
+                                      proof_buffer#insert "\n\n";
+                                    )
+                                    r;
+                                  ignore (proof_view#scroll_to_mark my_mark) ;
+                                  full_goal_done <- true
+                end
+            | Decl_mode.Mode_proof ->
+                self#show_pm_goal
+        with e -> prerr_endline (Printexc.to_string e)
       end
-      
+
+  method show_goals = self#show_goals_full
+
+
   method send_to_coq verbosely replace phrase show_output show_error localize =
     let display_output msg =
       self#insert_message (if show_output then msg else "") in
     let display_error e =
       let (s,loc) = Coq.process_exn e in
-      assert (Glib.Utf8.validate s);
-      self#insert_message s;
-      message_view#misc#draw None;
-      if localize then 
-	(match Option.map Util.unloc loc with 
-	  | None -> ()
-	  | Some (start,stop) ->
-	      let convert_pos = byte_offset_to_char_offset phrase in
-	      let start = convert_pos start in
-	      let stop = convert_pos stop in
-	      let i = self#get_start_of_input in 
-	      let starti = i#forward_chars start in
-	      let stopi = i#forward_chars stop in
-	      input_buffer#apply_tag_by_name "error"
-   		~start:starti
-		~stop:stopi;
-	      input_buffer#place_cursor starti) in
-    try 
-      full_goal_done <- false;
-      prerr_endline "Send_to_coq starting now";
-      Decl_mode.clear_daimon_flag ();
-      if replace then begin
-	let r,info = Coq.interp_and_replace ("info " ^ phrase) in
-	let complete = not (Decl_mode.get_daimon_flag ()) in 
-	let msg = read_stdout () in
-        sync display_output msg;
-	Some (complete,r)	
-      end else begin
-	let r = Coq.interp verbosely phrase in
-	let complete = not (Decl_mode.get_daimon_flag ()) in 
-	let msg = read_stdout () in
-        sync display_output msg;
-        Some (complete,r)
-      end
-    with e ->
-      if show_error then sync display_error e;
-      None
-
-  method find_phrase_starting_at (start:GText.iter) = 
-    prerr_endline "find_phrase_starting_at starting now";
-    let trash_bytes = ref "" in
-    let end_iter = start#copy in
-    let lexbuf_function s count =
-      let i = ref 0 in
-      let n_trash = String.length !trash_bytes in
-	String.blit !trash_bytes 0 s 0 n_trash;
-	i := n_trash;
-	try
-	  while !i <= count - 1 do
-	    let c = end_iter#char in
-	      if c = 0 then raise (Stop !i);
-	      let c' = Glib.Utf8.from_unichar c in
-	      let n = String.length c' in
-		if (n<=0) then exit (-2);
-		if n > count - !i  then 
-		  begin
-		    let ri = count - !i in
-		      String.blit c' 0 s !i ri;
-		      trash_bytes := String.sub c' ri (n-ri);
-		      i := count ;
-		  end else begin
-		      String.blit c' 0 s !i n;
-		      i:= !i + n
-		    end;
-		if not end_iter#nocopy#forward_char then 
-		  raise (Stop !i)
-	  done;
-	  count
-	with Stop x ->
-	  x
-    in
+        assert (Glib.Utf8.validate s);
+        self#insert_message s;
+        message_view#misc#draw None;
+        if localize then
+          (match Option.map Util.unloc loc with
+             | None -> ()
+             | Some (start,stop) ->
+                 let convert_pos = byte_offset_to_char_offset phrase in
+                 let start = convert_pos start in
+                 let stop = convert_pos stop in
+                 let i = self#get_start_of_input in
+                 let starti = i#forward_chars start in
+                 let stopi = i#forward_chars stop in
+                   input_buffer#apply_tag Tags.Script.error
+                     ~start:starti
+                     ~stop:stopi;
+                   input_buffer#place_cursor starti) in
       try
-	trash_bytes := "";
-	let _ = Find_phrase.get (Lexing.from_function lexbuf_function) 
-	in
-	  end_iter#nocopy#set_offset (start#offset + !Find_phrase.length);
-	  Some (start,end_iter)
-      with
-	  (*
-	    | Find_phrase.EOF s -> 
-	  (* Phrase is at the end of the buffer*)
-	    let si = start#offset in
-	    let ei = si + !Find_phrase.length in
-	    end_iter#nocopy#set_offset (ei - 1);
-	    input_buffer#insert ~iter:end_iter "\n";
-	    Some (input_buffer#get_iter (`OFFSET si),
-	    input_buffer#get_iter (`OFFSET ei))
-	  *)
-	| _ -> None
-
-  method complete_at_offset (offset:int) = 
+        full_goal_done <- false;
+        prerr_endline "Send_to_coq starting now";
+        Decl_mode.clear_daimon_flag ();
+        if replace then begin
+          let r,info = Coq.interp_and_replace ("info " ^ phrase) in
+          let is_complete = not (Decl_mode.get_daimon_flag ()) in
+          let msg = read_stdout () in
+            sync display_output msg;
+            Some (is_complete,r)
+        end else begin
+          let r = Coq.interp verbosely phrase in
+          let is_complete = not (Decl_mode.get_daimon_flag ()) in
+          let msg = read_stdout () in
+            sync display_output msg;
+            Some (is_complete,r)
+        end
+      with e ->
+        if show_error then sync display_error e;
+        None
+
+  method find_phrase_starting_at (start:GText.iter) =
+    try
+      let start = grab_safe_sentence_start start self#get_start_of_input in
+      let stop = grab_sentence_end_from start in
+      if stop#backward_char#has_tag Tags.Script.lax_end then
+        Some (start,stop)
+      else
+        None
+    with Not_found -> None
+
+  method complete_at_offset (offset:int) =
     prerr_endline ("Completion at offset : " ^ string_of_int offset);
     let it () = input_buffer#get_iter (`OFFSET offset) in
     let iit = it () in
     let start = find_word_start iit in
-      if ends_word iit then 
-	let w = input_buffer#get_text 
-	  ~start
-	  ~stop:iit
-	  ()
-	in
-	  if String.length w <> 0 then begin
-	      prerr_endline ("Completion of prefix : '" ^ w^"'");
-	      match complete input_buffer w start#offset with 
-		| None -> false
-		| Some (ss,start,stop) -> 
-		    let completion = input_buffer#get_text ~start ~stop () in
-		      ignore (input_buffer#delete_selection ());
-		      ignore (input_buffer#insert_interactive completion);
-		      input_buffer#move_mark `SEL_BOUND (it())#backward_char;
-		      true
-	    end else false
-      else false
-
-	
-  method process_next_phrase verbosely display_goals do_highlight = 
+      if ends_word iit then
+        let w = input_buffer#get_text
+                  ~start
+                  ~stop:iit
+                  ()
+        in
+          if String.length w <> 0 then begin
+            prerr_endline ("Completion of prefix : '" ^ w^"'");
+            match complete input_buffer w start#offset with
+              | None -> false
+              | Some (ss,start,stop) ->
+                  let completion = input_buffer#get_text ~start ~stop () in
+                    ignore (input_buffer#delete_selection ());
+                    ignore (input_buffer#insert_interactive completion);
+                    input_buffer#move_mark `SEL_BOUND (it())#backward_char;
+                    true
+          end else false
+          else false
+
+  method process_next_phrase verbosely display_goals do_highlight =
     let get_next_phrase () =
       self#clear_message;
       prerr_endline "process_next_phrase starting now";
       if do_highlight then begin
-	  !push_info "Coq is computing";
-	  input_view#set_editable false;
-	end;
-      match self#find_phrase_starting_at self#get_start_of_input with 
-	| None ->
-	    if do_highlight then begin
-		input_view#set_editable true;
-		!pop_info ();
-	      end;
+        push_info "Coq is computing";
+        input_view#set_editable false;
+      end;
+      match self#find_phrase_starting_at self#get_start_of_input with
+        | None ->
+            if do_highlight then begin
+              input_view#set_editable true;
+              pop_info ();
+            end;
             None
-	| Some(start,stop) ->
-	    prerr_endline "process_next_phrase : to_process highlight";
-	    if do_highlight then begin
-		input_buffer#apply_tag_by_name ~start ~stop "to_process";
-		prerr_endline "process_next_phrase : to_process applied";
-	      end;
-	    prerr_endline "process_next_phrase : getting phrase";
+        | Some(start,stop) ->
+            prerr_endline "process_next_phrase : to_process highlight";
+            if do_highlight then begin
+              input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
+              prerr_endline "process_next_phrase : to_process applied";
+            end;
+            prerr_endline "process_next_phrase : getting phrase";
             Some((start,stop),start#get_slice ~stop) in
     let remove_tag (start,stop) =
       if do_highlight then begin
-	  input_buffer#remove_tag_by_name ~start ~stop "to_process" ;
-	  input_view#set_editable true;
-	  !pop_info ();
-	end in
-      let mark_processed reset_info complete (start,stop) ast =
-        let b = input_buffer in
-	b#move_mark ~where:stop (`NAME "start_of_input");
-	b#apply_tag_by_name 
-	  (if complete then "processed" else "unjustified") ~start ~stop;
-	if (self#get_insert#compare) stop <= 0 then 
-	  begin
-	    b#place_cursor stop;
-	    self#recenter_insert
-	  end;
-	let start_of_phrase_mark = `MARK (b#create_mark start) in
-	let end_of_phrase_mark = `MARK (b#create_mark stop) in
-	push_phrase
-          reset_info 
-	  start_of_phrase_mark 
-	  end_of_phrase_mark ast;
-	if display_goals then self#show_goals;
-        remove_tag (start,stop) in
-      begin
-        match sync get_next_phrase () with
-            None -> false
-          | Some (loc,phrase) ->
+        input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
+        input_view#set_editable true;
+        pop_info ();
+      end in
+    let mark_processed reset_info is_complete (start,stop) =
+      let b = input_buffer in
+      b#move_mark ~where:stop (`NAME "start_of_input");
+      b#apply_tag
+        (if is_complete then Tags.Script.processed else Tags.Script.unjustified) ~start ~stop;
+         if (self#get_insert#compare) stop <= 0 then
+           begin
+             b#place_cursor stop;
+             self#recenter_insert
+           end;
+         let ide_payload = { start = `MARK (b#create_mark start);
+                             stop = `MARK (b#create_mark stop); } in
+         push_phrase
+           cmd_stack
+           reset_info
+           ide_payload;
+         if display_goals then self#show_goals;
+         remove_tag (start,stop) in
+    begin
+      match sync get_next_phrase () with
+          None -> false
+        | Some (loc,phrase) ->
             (match self#send_to_coq verbosely false phrase true true true with
-	      | Some (complete,(reset_info,ast)) -> 
-		  sync (mark_processed reset_info complete) loc ast; true
-	      | None -> sync remove_tag loc; false)
-      end
-    
-  method insert_this_phrase_on_success 
-    show_output show_msg localize coqphrase insertphrase = 
-    let mark_processed reset_info complete ast =
+               | Some (is_complete,reset_info) ->
+                   sync (mark_processed reset_info is_complete) loc; true
+               | None -> sync remove_tag loc; false)
+    end
+
+  method insert_this_phrase_on_success
+        show_output show_msg localize coqphrase insertphrase =
+    let mark_processed reset_info is_complete =
       let stop = self#get_start_of_input in
-      if stop#starts_line then
-	input_buffer#insert ~iter:stop insertphrase
-      else input_buffer#insert ~iter:stop ("\n"^insertphrase); 
-      let start = self#get_start_of_input in
-      input_buffer#move_mark ~where:stop (`NAME "start_of_input");
-      input_buffer#apply_tag_by_name 
-	(if complete then "processed" else "unjustified") ~start ~stop;
-      if (self#get_insert#compare) stop <= 0 then 
-	input_buffer#place_cursor stop;
-      let start_of_phrase_mark = `MARK (input_buffer#create_mark start) in
-      let end_of_phrase_mark = `MARK (input_buffer#create_mark stop) in
-      push_phrase reset_info start_of_phrase_mark end_of_phrase_mark ast;
-      self#show_goals;
-      (*Auto insert save on success... 
-      try (match Coq.get_current_goals () with 
-	| [] ->  
-	    (match self#send_to_coq "Save.\n" true true true with
-	      | Some ast -> 
-	          begin
-                    let stop = self#get_start_of_input in
-	            if stop#starts_line then
-	              input_buffer#insert ~iter:stop "Save.\n"
-	            else input_buffer#insert ~iter:stop "\nSave.\n"; 
-	            let start = self#get_start_of_input in
-	            input_buffer#move_mark ~where:stop (`NAME"start_of_input");
-	            input_buffer#apply_tag_by_name "processed" ~start ~stop;
-	            if (self#get_insert#compare) stop <= 0 then 
-	              input_buffer#place_cursor stop;
-	            let start_of_phrase_mark =
-                      `MARK (input_buffer#create_mark start) in
-	            let end_of_phrase_mark =
-                      `MARK (input_buffer#create_mark stop) in
-	            push_phrase
-	              reset_info start_of_phrase_mark end_of_phrase_mark ast
-	          end
-	      | None -> ())
-	| _ -> ())
-      with _ -> ()*) in
-    match self#send_to_coq false false coqphrase show_output show_msg localize with
-      | Some (complete,(reset_info,ast)) ->
-	  sync (mark_processed reset_info complete) ast; true
-      | None ->
-          sync
-            (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
-            ();
-	  false
+        if stop#starts_line then
+          input_buffer#insert ~iter:stop insertphrase
+        else input_buffer#insert ~iter:stop ("\n"^insertphrase);
+        let start = self#get_start_of_input in
+          input_buffer#move_mark ~where:stop (`NAME "start_of_input");
+          input_buffer#apply_tag
+            (if is_complete then Tags.Script.processed else Tags.Script.unjustified) ~start ~stop;
+             if (self#get_insert#compare) stop <= 0 then
+               input_buffer#place_cursor stop;
+             let ide_payload = { start = `MARK (input_buffer#create_mark start);
+                                 stop = `MARK (input_buffer#create_mark stop); } in
+               push_phrase cmd_stack reset_info ide_payload;
+               self#show_goals;
+      (*Auto insert save on success...
+       try (match Coq.get_current_goals () with
+       | [] ->
+       (match self#send_to_coq "Save.\n" true true true with
+       | Some ast ->
+       begin
+       let stop = self#get_start_of_input in
+       if stop#starts_line then
+       input_buffer#insert ~iter:stop "Save.\n"
+       else input_buffer#insert ~iter:stop "\nSave.\n";
+       let start = self#get_start_of_input in
+       input_buffer#move_mark ~where:stop (`NAME"start_of_input");
+       input_buffer#apply_tag_by_name "processed" ~start ~stop;
+       if (self#get_insert#compare) stop <= 0 then
+       input_buffer#place_cursor stop;
+       let start_of_phrase_mark =
+       `MARK (input_buffer#create_mark start) in
+       let end_of_phrase_mark =
+       `MARK (input_buffer#create_mark stop) in
+       push_phrase
+       reset_info start_of_phrase_mark end_of_phrase_mark ast
+       end
+       | None -> ())
+       | _ -> ())
+       with _ -> ()*) in
+      match self#send_to_coq false false coqphrase show_output show_msg localize with
+        | Some (is_complete,reset_info) ->
+            sync (mark_processed reset_info) is_complete; true
+        | None ->
+            sync
+              (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
+              ();
+            false
 
   method process_until_iter_or_error stop =
     let stop' = `OFFSET stop#offset in
     let start = self#get_start_of_input#copy in
     let start' = `OFFSET start#offset in
       sync (fun _ ->
-	      input_buffer#apply_tag_by_name ~start ~stop "to_process";
-	      input_view#set_editable false) ();
-      !push_info "Coq is computing";
+              input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
+              input_view#set_editable false) ();
+      push_info "Coq is computing";
       let get_current () =
-	if !current.stop_before then
+        if !current.stop_before then
           match self#find_phrase_starting_at self#get_start_of_input with
             | None -> self#get_start_of_input
             | Some (_, stop2) -> stop2
-	else begin
-            self#get_start_of_input
-	  end
-      in   
-	(try 
-	    while ((stop#compare (get_current())>=0) 
-		    && (self#process_next_phrase false false false))
-	    do Util.check_for_interrupt () done
-	  with Sys.Break -> 
-	    prerr_endline "Interrupted during process_until_iter_or_error");
-	sync (fun _ ->
-	  self#show_goals;
-	  (* Start and stop might be invalid if an eol was added at eof *)
-	  let start = input_buffer#get_iter start' in
-	  let stop =  input_buffer#get_iter stop' in
-	    input_buffer#remove_tag_by_name ~start ~stop "to_process" ;
-	    input_view#set_editable true) ();
-	!pop_info()
-
-  method process_until_end_or_error = 
+              else begin
+                self#get_start_of_input
+              end
+      in
+        (try
+           while ((stop#compare (get_current())>=0)
+           && (self#process_next_phrase false false false))
+           do Util.check_for_interrupt () done
+         with Sys.Break ->
+           prerr_endline "Interrupted during process_until_iter_or_error");
+        sync (fun _ ->
+                self#show_goals;
+                (* Start and stop might be invalid if an eol was added at eof *)
+                let start = input_buffer#get_iter start' in
+                let stop =  input_buffer#get_iter stop' in
+                  input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
+                  input_view#set_editable true) ();
+        pop_info()
+
+  method process_until_end_or_error =
     self#process_until_iter_or_error input_buffer#end_iter
 
   method reset_initial =
     sync (fun _ ->
-	    Stack.iter 
-              (function inf -> 
-		 let start = input_buffer#get_iter_at_mark inf.start in
-		 let stop = input_buffer#get_iter_at_mark inf.stop in
-		   input_buffer#move_mark ~where:start (`NAME "start_of_input");
-		   input_buffer#remove_tag_by_name "processed" ~start ~stop;
-		   input_buffer#remove_tag_by_name "unjustified" ~start ~stop;
-		   input_buffer#delete_mark inf.start;
-		   input_buffer#delete_mark inf.stop;
-              ) 
-              processed_stack;
-	    Stack.clear processed_stack;
-	    self#clear_message)();
+            Stack.iter
+              (function (inf,_) ->
+                 let start = input_buffer#get_iter_at_mark inf.start in
+                 let stop = input_buffer#get_iter_at_mark inf.stop in
+                   input_buffer#move_mark ~where:start (`NAME "start_of_input");
+                   input_buffer#remove_tag Tags.Script.processed ~start ~stop;
+                   input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+                   input_buffer#delete_mark inf.start;
+                   input_buffer#delete_mark inf.stop;
+              )
+              cmd_stack;
+            Stack.clear cmd_stack;
+            self#clear_message)();
     Coq.reset_initial ()
 
   (* backtrack Coq to the phrase preceding iterator [i] *)
   method backtrack_to_no_lock i =
     prerr_endline "Backtracking_to iter starts now.";
     (* pop Coq commands until we reach iterator [i] *)
-    let  rec pop_commands done_smthg undos =
-      if is_empty () then 
-	done_smthg, undos
+    let rec pop_cmds popped =
+      if Stack.is_empty cmd_stack then
+        popped
       else
-	let t = top () in 
-	if i#compare (input_buffer#get_iter_at_mark t.stop) < 0 then
+        let (ide,coq) = Stack.pop cmd_stack in
+        if i#compare (input_buffer#get_iter_at_mark ide.stop) < 0 then
           begin
-	    prerr_endline "Popped top command";
-	    pop_commands true (pop_command undos t)
-	  end
+            prerr_endline "popped command";
+            pop_cmds (coq::popped)
+          end
         else
-	  done_smthg, undos
+          begin
+            Stack.push (ide,coq) cmd_stack;
+            popped
+          end
     in
-    let undos = (0,0,NoBacktrack,0,undo_info()) in
-    let done_smthg, undos = pop_commands false undos in
+    let seq = List.rev (pop_cmds []) in
       prerr_endline "Popped commands";
-      if done_smthg then
-        begin 
-          try 
-            apply_undos undos;
+      if 0 < List.length seq then
+        begin
+          try
+            rewind seq cmd_stack;
             sync (fun _ ->
-		    let start =
-		      if is_empty () then input_buffer#start_iter 
-		      else input_buffer#get_iter_at_mark (top ()).stop in
-		      prerr_endline "Removing (long) processed tag...";
-		      input_buffer#remove_tag_by_name 
-			~start 
-			~stop:self#get_start_of_input
-			"processed";
-		      input_buffer#remove_tag_by_name 
-			~start 
-			~stop:self#get_start_of_input
-			"unjustified";
-		      prerr_endline "Moving (long) start_of_input...";
-		      input_buffer#move_mark ~where:start (`NAME "start_of_input");
-		      self#show_goals;
-		      clear_stdout ();
-		      self#clear_message)
+                    let start =
+                      if Stack.is_empty cmd_stack then input_buffer#start_iter
+                      else input_buffer#get_iter_at_mark (fst (Stack.top cmd_stack)).stop in
+                      prerr_endline "Removing (long) processed tag...";
+                      input_buffer#remove_tag
+                        Tags.Script.processed
+                        ~start
+                        ~stop:self#get_start_of_input;
+                      input_buffer#remove_tag
+                        Tags.Script.unjustified
+                        ~start
+                        ~stop:self#get_start_of_input;
+                      prerr_endline "Moving (long) start_of_input...";
+                      input_buffer#move_mark ~where:start (`NAME "start_of_input");
+                      full_goal_done <- false;
+                      self#show_goals;
+                      clear_stdout ();
+                      self#clear_message)
               ();
-	  with _ -> 
-	    !push_info "WARNING: undo failed badly -> Coq might be in an inconsistent state.
-Please restart and report NOW.";
-      end
-    else prerr_endline "backtrack_to : discarded (...)"
-      
-  method backtrack_to i = 
-    if Mutex.try_lock coq_may_stop then 
-      (!push_info "Undoing...";
+          with _ ->
+            push_info "WARNING: undo failed badly -> Coq might be in an inconsistent state.
+                                                                     Please restart and report NOW.";
+        end
+      else prerr_endline "backtrack_to : discarded (...)"
+
+  method backtrack_to i =
+    if Mutex.try_lock coq_may_stop then
+      (push_info "Undoing...";
        self#backtrack_to_no_lock i; Mutex.unlock coq_may_stop;
-       !pop_info ())
+       pop_info ())
     else prerr_endline "backtrack_to : discarded (lock is busy)"
 
   method go_to_insert =
@@ -1411,405 +1172,278 @@ Please restart and report NOW.";
       else self#backtrack_to point
 
   method undo_last_step =
-    if Mutex.try_lock coq_may_stop then  
-      (!push_info "Undoing last step...";
+    if Mutex.try_lock coq_may_stop then
+      (push_info "Undoing last step...";
        (try
-	    let last_command = top () in
-	    let start = input_buffer#get_iter_at_mark last_command.start in
-	    let update_input () =
-	      prerr_endline "Removing processed tag...";
-	      input_buffer#remove_tag_by_name 
-		~start
-		~stop:(input_buffer#get_iter_at_mark last_command.stop) 
-		"processed";
-	      input_buffer#remove_tag_by_name 
-	        ~start
-	        ~stop:(input_buffer#get_iter_at_mark last_command.stop) 
-	      "unjustified";
-	      prerr_endline "Moving start_of_input";
-	      input_buffer#move_mark
-		~where:start
-		(`NAME "start_of_input");
-	      input_buffer#place_cursor start;
-	      self#recenter_insert;
-	      self#show_goals;
-	      self#clear_message
-	    in
-              let undo = pop_command (0,0,NoBacktrack,0,undo_info()) last_command in
-              apply_undos undo;
-              sync update_input ()
-	with
-	  | Size 0 -> (* !flash_info "Nothing to Undo"*)()
+          let (ide_ri,_) = Stack.top cmd_stack in
+          let start = input_buffer#get_iter_at_mark ide_ri.start in
+          let update_input () =
+            prerr_endline "Removing processed tag...";
+            input_buffer#remove_tag
+              Tags.Script.processed
+              ~start
+              ~stop:(input_buffer#get_iter_at_mark ide_ri.stop);
+            input_buffer#remove_tag
+              Tags.Script.unjustified
+              ~start
+              ~stop:(input_buffer#get_iter_at_mark ide_ri.stop);
+            prerr_endline "Moving start_of_input";
+            input_buffer#move_mark
+              ~where:start
+              (`NAME "start_of_input");
+            input_buffer#place_cursor start;
+            self#recenter_insert;
+            full_goal_done <- false;
+            self#show_goals;
+            self#clear_message
+          in
+          let _,coq = Stack.pop cmd_stack in
+          rewind [coq] cmd_stack;
+          sync update_input ()
+        with
+          | Stack.Empty -> (* flash_info "Nothing to Undo"*)()
        );
-       !pop_info ();
+       pop_info ();
        Mutex.unlock coq_may_stop)
     else prerr_endline "undo_last_step discarded"
 
-      
-  method blaster () = 
-    
-    ignore (Thread.create 
-	      (fun () ->  
-		 prerr_endline "Blaster called";
-		 let c = Blaster_window.present_blaster_window () in
-		   if Mutex.try_lock c#lock then begin
-		       c#clear ();
-                      Decl_mode.check_not_proof_mode "No blaster in Proof mode";
-		       let current_gls = try get_current_goals () with _ -> [] in
-			 
-		       let set_goal i (s,t) = 
-			 let gnb = string_of_int i in
-			 let s = gnb ^":"^s in
-			 let t' = gnb ^": progress "^t in
-			 let t'' = gnb ^": "^t in
-			   c#set
-			     ("Goal "^gnb)
-			     s 
-			     (fun () -> try_interptac t')
-			     (sync(fun () -> self#insert_command t'' t''))
-		       in
-		       let set_current_goal (s,t) = 
-			 c#set
-			   "Goal 1"
-			   s 
-			   (fun () -> try_interptac ("progress "^t))
-			   (sync(fun () -> self#insert_command t t))
-		       in
-			 begin match current_gls with 
-			   | [] -> ()
-			   | (hyp_l,current_gl)::r ->
-			       List.iter set_current_goal (concl_menu current_gl);
-			       List.iter 
-				 (fun hyp -> 
-				    List.iter set_current_goal (hyp_menu hyp))
-				 hyp_l;
-			       let i = ref 2 in
-				 List.iter 
-				   (fun (hyp_l,gl) -> 
-				      List.iter (set_goal !i) (concl_menu gl);
-				      incr i)
-				   r
-			 end;
-			 let _ =  c#blaster () in
-			   Mutex.unlock c#lock
-		     end else prerr_endline "Blaster discarded")
-	      ())
-      
-  method insert_command cp ip = 
+
+  method insert_command cp ip =
     async(fun _ -> self#clear_message)();
     ignore (self#insert_this_phrase_on_success true false false cp ip)
 
   method tactic_wizard l =
     async(fun _ -> self#clear_message)();
-    ignore 
-      (List.exists 
-	 (fun p -> 
-	    self#insert_this_phrase_on_success true false false 
-	      ("progress "^p^".\n") (p^".\n")) l)
-      
-  method active_keypress_handler k = 
+    ignore
+      (List.exists
+         (fun p ->
+            self#insert_this_phrase_on_success true false false
+              ("progress "^p^".\n") (p^".\n")) l)
+
+  method active_keypress_handler k =
     let state = GdkEvent.Key.state k in
       begin
-	match  state with
-	  | l when List.mem `MOD1 l ->
-	      let k = GdkEvent.Key.keyval k in
-		if GdkKeysyms._Return=k
-		then ignore(
-			     if (input_buffer#insert_interactive "\n") then
-			       begin
-				 let i= self#get_insert#backward_word_start in
-				   prerr_endline "active_kp_hf: Placing cursor";
-				   self#process_until_iter_or_error i
-			       end);
-		true
-	  | l when List.mem `CONTROL l -> 
-	      let k = GdkEvent.Key.keyval k in
-		if GdkKeysyms._Break=k
-		then break ();
-		false
-	  | l -> 
-	      if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
-		  prerr_endline "active_kp_handler for Tab";
-		  self#indent_current_line;
-		  true
-		end else false
+        match  state with
+          | l when List.mem `MOD1 l ->
+              let k = GdkEvent.Key.keyval k in
+                if GdkKeysyms._Return=k
+                then ignore(
+                  if (input_buffer#insert_interactive "\n") then
+                    begin
+                      let i= self#get_insert#backward_word_start in
+                        prerr_endline "active_kp_hf: Placing cursor";
+                        self#process_until_iter_or_error i
+                    end);
+                true
+          | l when List.mem `CONTROL l ->
+              let k = GdkEvent.Key.keyval k in
+                if GdkKeysyms._Break=k
+                then break ();
+                false
+          | l ->
+              if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
+                prerr_endline "active_kp_handler for Tab";
+                self#indent_current_line;
+                true
+              end else false
       end
-  method disconnected_keypress_handler k = 
+
+
+  method disconnected_keypress_handler k =
     match GdkEvent.Key.state k with
-      | l when List.mem `CONTROL l -> 
-	  let k = GdkEvent.Key.keyval k in
-	    if GdkKeysyms._c=k
-	    then break ();
-	    false
+      | l when List.mem `CONTROL l ->
+          let k = GdkEvent.Key.keyval k in
+            if GdkKeysyms._c=k
+            then break ();
+            false
       | l -> false
-	  
+
 
   val mutable deact_id = None
   val mutable act_id = None
 
-  method deactivate () = 
+  method deactivate () =
     is_active <- false;
-    (match act_id with None -> () 
+    (match act_id with None -> ()
        | Some id ->
-	   reset_initial ();
-	   input_view#misc#disconnect id;
-	   prerr_endline "DISCONNECTED old active : ";
-	   print_id id;
-    );
-    deact_id <- Some 
-      (input_view#event#connect#key_press self#disconnected_keypress_handler);
+           reset_initial ();
+           input_view#misc#disconnect id;
+           prerr_endline "DISCONNECTED old active : ";
+           print_id id;
+    )(*;
+    deact_id <- Some
+                  (input_view#event#connect#key_press self#disconnected_keypress_handler);
     prerr_endline "CONNECTED  inactive : ";
-    print_id (Option.get deact_id)
+    print_id (Option.get deact_id)*)
 
+  (* XXX *)
   method activate () =
-    is_active <- true;
-    (match deact_id with None -> () 
+    is_active <- true;(*
+    (match deact_id with None -> ()
        | Some id -> input_view#misc#disconnect id;
-	   prerr_endline "DISCONNECTED old inactive : ";
-	   print_id id
-    );
-    act_id <- Some 
-      (input_view#event#connect#key_press self#active_keypress_handler);
+                    prerr_endline "DISCONNECTED old inactive : ";
+                    print_id id
+    );*)
+    act_id <- Some
+                (input_view#event#connect#key_press self#active_keypress_handler);
     prerr_endline "CONNECTED active : ";
     print_id (Option.get act_id);
-    match 
-      (Option.get ((Vector.get input_views index).analyzed_view)) #filename 
+    match
+      filename
     with
       | None -> ()
       | Some f -> let dir = Filename.dirname f in
-		    if not (is_in_loadpath dir) then
-		      begin
-			ignore (Coq.interp false
-				  (Printf.sprintf "Add LoadPath \"%s\". "  dir))
-		      end
-			
-  method electric_handler = 
+          if not (is_in_loadpath dir) then
+            begin
+              ignore (Coq.interp false
+                        (Printf.sprintf "Add LoadPath \"%s\". "  dir))
+            end
+
+  method electric_handler =
     input_buffer#connect#insert_text ~callback:
-      (fun it x -> 
-	 begin try
-	     if last_index then begin
-		 last_array.(0)<-x;
-		 if (last_array.(1) ^ last_array.(0) = ".\n") then raise Found
-	       end else begin
-		   last_array.(1)<-x;
-		   if (last_array.(0) ^ last_array.(1) = ".\n") then raise Found
-		 end
-	   with Found -> 
-	     begin
-	       ignore (self#process_next_phrase false true true)
-	     end;
-	 end;
-	 last_index <- not last_index;)
+      (fun it x ->
+         begin try
+           if last_index then begin
+             last_array.(0)<-x;
+             if (last_array.(1) ^ last_array.(0) = ".\n") then raise Found
+           end else begin
+             last_array.(1)<-x;
+             if (last_array.(0) ^ last_array.(1) = ".\n") then raise Found
+           end
+         with Found ->
+           begin
+             ignore (self#process_next_phrase false true true)
+           end;
+         end;
+         last_index <- not last_index;)
 
   method private electric_paren tag =
     let oparen_code = Glib.Utf8.to_unichar "("  (ref 0) in
     let cparen_code = Glib.Utf8.to_unichar ")"  (ref 0) in
       ignore (input_buffer#connect#insert_text ~callback:
-		(fun it x ->
-		   input_buffer#remove_tag
-		     ~start:input_buffer#start_iter
-		     ~stop:input_buffer#end_iter
-		     tag;
-		   if x = "" then () else
-		     match x.[String.length x - 1] with 
-		       | ')' -> 
-			   let hit = self#get_insert in
-			   let count = ref 0 in
-			     if hit#nocopy#backward_find_char 
-			       (fun c -> 
-				  if c = oparen_code && !count = 0 then true 
-				  else if c = cparen_code then 
-				    (incr count;false)
-				  else if c = oparen_code then 
-				    (decr count;false)
-				  else false
-			       )
-			     then
-			       begin
-				 prerr_endline "Found matching parenthesis";
-				 input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
-			       end
-			     else ()
-		       | _ -> ())
-	     )
+                (fun it x ->
+                   input_buffer#remove_tag
+                     ~start:input_buffer#start_iter
+                     ~stop:input_buffer#end_iter
+                     tag;
+                   if x = "" then () else
+                     match x.[String.length x - 1] with
+                       | ')' ->
+                           let hit = self#get_insert in
+                           let count = ref 0 in
+                             if hit#nocopy#backward_find_char
+                                  (fun c ->
+                                     if c = oparen_code && !count = 0 then true
+                                     else if c = cparen_code then
+                                       (incr count;false)
+                                     else if c = oparen_code then
+                                       (decr count;false)
+                                     else false
+                                  )
+                             then
+                               begin
+                                 prerr_endline "Found matching parenthesis";
+                                 input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
+                               end
+                             else ()
+                       | _ -> ())
+     )
+
+  method help_for_keyword () =
 
-  method help_for_keyword () = 
-    
     browse_keyword (self#insert_message) (get_current_word ())
 
-  initializer 
+  initializer
     ignore (message_buffer#connect#insert_text
-	      ~callback:(fun it s -> ignore 
-			   (message_view#scroll_to_mark
-			      ~use_align:false
-			      ~within_margin:0.49
-			      `INSERT)));
+              ~callback:(fun it s -> ignore
+                                       (message_view#scroll_to_mark
+                                          ~use_align:false
+                                          ~within_margin:0.49
+                                          `INSERT)));
     ignore (input_buffer#connect#insert_text
-	      ~callback:(fun it s ->
-			   if (it#compare self#get_start_of_input)<0
-			   then GtkSignal.stop_emit ();
-			   if String.length s > 1 then 
-			     (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor it)));
+              ~callback:(fun it s ->
+                           if (it#compare self#get_start_of_input)<0
+                           then GtkSignal.stop_emit ();
+                           if String.length s > 1 then
+                             (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor it)));
     ignore (input_buffer#connect#after#apply_tag
-	      ~callback:(fun tag ~start ~stop ->
-			   if (start#compare self#get_start_of_input)>=0
-			   then 
-			     begin
-			       input_buffer#remove_tag_by_name 
-				 ~start
-				 ~stop
-				 "processed";
-			       input_buffer#remove_tag_by_name 
-				 ~start
-				 ~stop
-				 "unjustified"
-			     end
-			)
-	   );
+              ~callback:(fun tag ~start ~stop ->
+                           if (start#compare self#get_start_of_input)>=0
+                           then
+                             begin
+                               input_buffer#remove_tag
+                                 Tags.Script.processed
+                                 ~start
+                                 ~stop;
+                               input_buffer#remove_tag
+                                 Tags.Script.unjustified
+                                 ~start
+                                 ~stop
+                             end
+              )
+    );
     ignore (input_buffer#connect#after#insert_text
-	      ~callback:(fun it s ->
-			   if auto_complete_on && 
-			     String.length s = 1 && s <> " " && s <> "\n" 
-			   then 
-			     let v = Option.get (get_current_view ()).analyzed_view 
-			     in 
-			     let has_completed = 
-			       v#complete_at_offset 
-				 ((v#view#buffer#get_iter `SEL_BOUND)#offset)
-			     in
-			       if has_completed then 
-				 input_buffer#move_mark `SEL_BOUND (input_buffer#get_iter `SEL_BOUND)#forward_char;
-			       
-			       
-			)
-	   );
-    ignore (input_buffer#connect#modified_changed
-	      ~callback:
-	      (fun () ->
-		 if input_buffer#modified then 
-		   set_tab_image index 
-		     ~icon:(match (Option.get (current_all.analyzed_view))#filename with 
-			      | None -> `SAVE_AS
-			      | Some _ -> `SAVE
-			   )
-		 else set_tab_image index ~icon:`YES;
-	      ));
+              ~callback:(fun it s ->
+                           if auto_complete_on &&
+                              String.length s = 1 && s <> " " && s <> "\n"
+                           then
+                             let v = session_notebook#current_term.analyzed_view
+                             in
+                             let has_completed =
+                               v#complete_at_offset
+                                 ((input_view#buffer#get_iter `SEL_BOUND)#offset)
+                             in
+                               if has_completed then
+                                 input_buffer#move_mark `SEL_BOUND (input_buffer#get_iter `SEL_BOUND)#forward_char;
+
+
+              )
+    );
     ignore (input_buffer#connect#changed
-	      ~callback:(fun () -> 
-			   last_modification_time <- Unix.time ();
-			   let r = input_view#visible_rect in
-			   let stop = 
-			     input_view#get_iter_at_location 
-			       ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r)
-			       ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r)
-			   in
-			     input_buffer#remove_tag_by_name 
-			       ~start:self#get_start_of_input
-			       ~stop
-			       "error";
-			     Highlight.highlight_around_current_line
-			       input_buffer 
-			)
-	   );
-    ignore (input_buffer#add_selection_clipboard (cb()));
-    let paren_highlight_tag = input_buffer#create_tag ~name:"paren" [`BACKGROUND "purple"]  in
-      self#electric_paren paren_highlight_tag;
-      ignore (input_buffer#connect#after#mark_set 
-		~callback:(fun it (m:Gtk.text_mark) ->
-			     !set_location 
-			       (Printf.sprintf 
-				  "Line: %5d Char: %3d" (self#get_insert#line + 1)
-				  (self#get_insert#line_offset + 1));
-			     match GtkText.Mark.get_name m  with
-			       | Some "insert" ->		 
-				   input_buffer#remove_tag
-				     ~start:input_buffer#start_iter
-				     ~stop:input_buffer#end_iter
-				     paren_highlight_tag;
-			       | Some s -> 
-				   prerr_endline (s^" moved")
-			       | None -> () )
-	     );
+              ~callback:(fun () ->
+                           last_modification_time <- Unix.time ();
+                           let r = input_view#visible_rect in
+                           let stop =
+                             input_view#get_iter_at_location
+                               ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r)
+                               ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r)
+                           in
+                             input_buffer#remove_tag
+                               Tags.Script.error
+                               ~start:self#get_start_of_input
+                               ~stop;
+                             tag_on_insert input_buffer
+              )
+    );
+    ignore (input_buffer#add_selection_clipboard cb);
+    ignore (proof_buffer#add_selection_clipboard cb);
+    ignore (message_buffer#add_selection_clipboard cb);
+      self#electric_paren Tags.Script.paren;
+      ignore (input_buffer#connect#after#mark_set
+                ~callback:(fun it (m:Gtk.text_mark) ->
+                             !set_location
+                               (Printf.sprintf
+                                  "Line: %5d Char: %3d" (self#get_insert#line + 1)
+                                  (self#get_insert#line_offset + 1));
+                             match GtkText.Mark.get_name m  with
+                               | Some "insert" ->
+                                   input_buffer#remove_tag
+                                     ~start:input_buffer#start_iter
+                                     ~stop:input_buffer#end_iter
+                                     Tags.Script.paren;
+                               | Some s ->
+                                   prerr_endline (s^" moved")
+                               | None -> () )
+      );
       ignore (input_buffer#connect#insert_text
-		(fun it s -> 
-		   prerr_endline "Should recenter ?";
-		   if String.contains s '\n' then begin
-		       prerr_endline "Should recenter : yes";
-		       self#recenter_insert
-		     end))
+                (fun it s ->
+                   prerr_endline "Should recenter ?";
+                   if String.contains s '\n' then begin
+                                            prerr_endline "Should recenter : yes";
+                                            self#recenter_insert
+                                          end));
 end
 
-let create_input_tab filename =
-  let b = GText.buffer () in 
-  let _ = GMisc.label () in 
-  let v_box = GPack.hbox ~homogeneous:false () in
-  let _ = GMisc.image ~packing:v_box#pack () in
-  let _ = GMisc.label ~text:filename ~packing:v_box#pack () in
-  let appendp x = ignore ((notebook ())#append_page
-		~tab_label:v_box#coerce x) in  
-  let fr1 = GBin.frame ~shadow_type:`ETCHED_OUT
-    ~packing:appendp () 
-  in 
-  let sw1 = GBin.scrolled_window
-    ~vpolicy:`AUTOMATIC 
-    ~hpolicy:`AUTOMATIC
-    ~packing:fr1#add () 
-  in
-  let tv1 = Undo.undoable_view ~buffer:b ~packing:(sw1#add) () in
-    prerr_endline ("Language: "^ b#start_iter#language);
-    tv1#misc#set_name "ScriptWindow";
-    let _ = tv1#set_editable true in
-    let _ = tv1#set_wrap_mode `NONE in
-      b#place_cursor ~where:(b#start_iter);
-      ignore (tv1#event#connect#button_press ~callback:
-		(fun ev -> GdkEvent.Button.button ev = 3));
-      (*  ignore (tv1#event#connect#button_press ~callback:
-	  (fun ev -> 
-	  if (GdkEvent.Button.button ev=2) then
-	  (try 
-	  prerr_endline "Paste invoked";
-	  GtkSignal.emit_unit 
-	  (get_current_view()).view#as_view 
-	  GtkText.View.Signals.paste_clipboard;
-	  true
-	  with _ -> false)
-	  else false
-	  ));*)
-      tv1#misc#grab_focus ();
-      ignore (tv1#buffer#create_mark 
-		~name:"start_of_input" 
-		tv1#buffer#start_iter);
-      ignore (tv1#buffer#create_tag 
-		~name:"kwd" 
-		[`FOREGROUND "blue"]);
-      ignore (tv1#buffer#create_tag 
-		~name:"decl" 
-		[`FOREGROUND "orange red"]);
-      ignore (tv1#buffer#create_tag 
-		~name:"comment" 
-		[`FOREGROUND "brown"]);
-      ignore (tv1#buffer#create_tag 
-		~name:"reserved" 
-		[`FOREGROUND "dark red"]);
-      ignore (tv1#buffer#create_tag 
-		~name:"error" 
-		[`UNDERLINE `DOUBLE ; `FOREGROUND "red"]);
-      ignore (tv1#buffer#create_tag 
-		~name:"to_process" 
-		[`BACKGROUND "light blue" ;`EDITABLE false]);
-      ignore (tv1#buffer#create_tag 
-		~name:"processed" 
-		[`BACKGROUND "light green" ;`EDITABLE false]);
-      ignore (tv1#buffer#create_tag (* Proof mode *)
-	        ~name:"unjustified" 
-               [`UNDERLINE `SINGLE ; `FOREGROUND "red";
-	         `BACKGROUND "gold" ;`EDITABLE false]);
-      ignore (tv1#buffer#create_tag 
-		~name:"found" 
-		[`BACKGROUND "blue"; `FOREGROUND "white"]);
-      tv1
-
-
 let last_make = ref "";;
 let last_make_index = ref 0;;
 let search_compile_error_regexp =
@@ -1823,20 +1457,228 @@ let search_next_error () =
   and b = int_of_string (Str.matched_group 3 !last_make)
   and e = int_of_string (Str.matched_group 4 !last_make)
   and msg_index = Str.match_beginning ()
-  in 
-    last_make_index := Str.group_end 4; 
+  in
+    last_make_index := Str.group_end 4;
     (f,l,b,e,
      String.sub !last_make msg_index (String.length !last_make - msg_index))
 
-let main files = 
+
+
+(**********************************************************************)
+(* session creation and primitive handling                            *)
+(**********************************************************************)
+
+let create_session () =
+  let script =
+    Undo.undoable_view
+      ~buffer:(GText.buffer ~tag_table:Tags.Script.table ())
+      ~wrap_mode:`NONE () in
+  let proof =
+    GText.view
+      ~buffer:(GText.buffer ~tag_table:Tags.Proof.table ())
+      ~editable:false ~wrap_mode:`CHAR () in
+  let message =
+    GText.view
+      ~buffer:(GText.buffer ~tag_table:Tags.Message.table ())
+      ~editable:false ~wrap_mode:`WORD () in
+  let basename =
+    GMisc.label ~text:"*scratch*" () in
+  let stack =
+    Stack.create () in
+  let legacy_av =
+    new analyzed_view script proof message stack in
+  let _ =
+    script#buffer#create_mark ~name:"start_of_input" script#buffer#start_iter in
+  let _ =
+    proof#buffer#create_mark ~name:"end_of_conclusion" proof#buffer#start_iter in
+  let _ =
+    GtkBase.Widget.add_events proof#as_widget [`ENTER_NOTIFY;`POINTER_MOTION] in
+  let _ =
+    proof#event#connect#motion_notify ~callback:
+      (fun e ->
+         let win = match proof#get_window `WIDGET with
+           | None -> assert false
+           | Some w -> w in
+         let x,y = Gdk.Window.get_pointer_location win in
+         let b_x,b_y = proof#window_to_buffer_coords ~tag:`WIDGET ~x ~y in
+         let it = proof#get_iter_at_location ~x:b_x ~y:b_y in
+         let tags = it#tags in
+           List.iter
+             (fun t ->
+                ignore (GtkText.Tag.event t#as_tag proof#as_widget e it#as_iter))
+             tags;
+           false) in
+    script#misc#set_name "ScriptWindow";
+    script#buffer#place_cursor ~where:(script#buffer#start_iter);
+    proof#misc#set_can_focus true;
+    message#misc#set_can_focus true;
+    script#misc#modify_font !current.text_font;
+    proof#misc#modify_font !current.text_font;
+    message#misc#modify_font !current.text_font;
+    { tab_label=basename;
+      filename="";
+      script=script;
+      proof_view=proof;
+      message_view=message;
+      analyzed_view=legacy_av;
+      command_stack=stack;
+      encoding=""
+    }
+
+(* XXX - to be used later
+let load_session session filename encs =
+  session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs;
+  session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
+  session.filename <- filename;
+  session.script#buffer#set_modified false
+
+
+let save_session session filename encs =
+  session.encoding <- List.find (IdeIO.save session.script#buffer filename) encs;
+  session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
+  session.filename <- filename;
+  session.script#buffer#set_modified false
+
+
+let init_session session =
+  session.script#buffer#set_modified false;
+  session.script#clear_undo;
+  session.script#buffer#place_cursor session.script#buffer#start_iter
+ *)
+
+
+
+
+(*********************************************************************)
+(* functions called by the user interface                            *)
+(*********************************************************************)
+(* XXX - to be used later
+let do_open session filename =
+  try
+    load_session session filename ["UTF-8";"ISO-8859-1";"ISO-8859-15"];
+    init_session session;
+    ignore (session_notebook#append_term session)
+  with _ -> ()
+
+
+let do_save session =
+  try
+    if session.script#buffer#modified then
+    save_session session session.filename [session.encoding]
+  with _ -> ()
+
+
+let choose_open =
+  let last_filename = ref "" in fun session ->
+    let open_dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Open file" ~modal:true () in
+    let enc_frame = GBin.frame ~label:"File encoding" ~packing:(open_dialog#vbox#pack ~fill:false) () in
+    let enc_entry = GEdit.entry ~text:(String.concat " " ["UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in
+    let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok
+                         ~message:"Invalid encoding, please indicate the encoding to use." () in
+    let open_response = function
+      | `OPEN -> begin
+          match open_dialog#filename with
+            | Some fn -> begin
+                try
+                  load_session session fn (Util.split_string_at ' ' enc_entry#text);
+                  session.analyzed_view <- Some (new analyzed_view session);
+                  init_session session;
+                  session_notebook#goto_page (session_notebook#append_term session);
+                  last_filename := fn
+                with
+                  | Not_found -> open_dialog#misc#hide (); error_dialog#show ()
+                  | _ ->
+                      error_dialog#set_markup "Unknown error while loading file, aborting.";
+                      open_dialog#destroy (); error_dialog#destroy ()
+              end
+            | None -> ()
+        end
+      | `DELETE_EVENT -> open_dialog#destroy (); error_dialog#destroy ()
+    in
+    let _ = open_dialog#connect#response open_response in
+    let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); open_dialog#show ()) in
+    let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in
+    let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in
+      open_dialog#add_select_button_stock `OPEN `OPEN;
+      open_dialog#add_button_stock `CANCEL `DELETE_EVENT;
+      open_dialog#add_filter filter_any;
+      open_dialog#add_filter filter_coq;
+      ignore(open_dialog#set_filename !last_filename);
+      open_dialog#show ()
+
+
+let choose_save session =
+  let save_dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save file" ~modal:true () in
+  let enc_frame = GBin.frame ~label:"File encoding" ~packing:(save_dialog#vbox#pack ~fill:false) () in
+  let enc_entry = GEdit.entry ~text:(String.concat " " [session.encoding;"UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in
+  let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok
+                       ~message:"Invalid encoding, please indicate the encoding to use." () in
+  let save_response = function
+    | `SAVE -> begin
+          match save_dialog#filename with
+            | Some fn -> begin
+                try
+                  save_session session fn (Util.split_string_at ' ' enc_entry#text)
+                with
+                  | Not_found -> save_dialog#misc#hide (); error_dialog#show ()
+                  | _ ->
+                      error_dialog#set_markup "Unknown error while saving file, aborting.";
+                      save_dialog#destroy (); error_dialog#destroy ()
+              end
+            | None -> ()
+        end
+    | `DELETE_EVENT -> save_dialog#destroy (); error_dialog#destroy ()
+  in
+  let _ = save_dialog#connect#response save_response in
+  let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); save_dialog#show ()) in
+  let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in
+  let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in
+    save_dialog#add_select_button_stock `SAVE `SAVE;
+    save_dialog#add_button_stock `CANCEL `DELETE_EVENT;
+    save_dialog#add_filter filter_any;
+    save_dialog#add_filter filter_coq;
+    ignore(save_dialog#set_filename session.filename);
+    save_dialog#show ()
+ *)
+
+let do_print session =
+  let av = session.analyzed_view in
+    if session.filename = ""
+    then flash_info "Cannot print: this buffer has no name"
+    else begin
+      let cmd =
+        "cd " ^ Filename.quote (Filename.dirname session.filename) ^ "; " ^
+        !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename session.filename) ^
+        " | " ^ !current.cmd_print
+      in
+      let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE"  () in
+      let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in
+      let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in
+      let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in
+      let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in
+      let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in
+      let print_button  = GButton.button ~stock:`PRINT  ~label:"Print"  ~packing:hbox_print#add () in
+      let callback_print () =
+        let cmd = print_entry#text in
+        let s,_ = run_command av#insert_message cmd in
+          flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed");
+          print_window#destroy ()
+      in
+        ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ;
+        ignore (print_button#connect#clicked ~callback:callback_print);
+        print_window#misc#show ()
+    end
+
+
+let main files =
   (* Statup preferences *)
   load_pref ();
 
   (* Main window *)
-  let w = GWindow.window 
+  let w = GWindow.window
     ~wm_class:"CoqIde" ~wm_name:"CoqIde"
-    ~allow_grow:true ~allow_shrink:true 
-    ~width:!current.window_width ~height:!current.window_height 
+    ~allow_grow:true ~allow_shrink:true
+    ~width:!current.window_width ~height:!current.window_height
     ~title:"CoqIde" ()
   in
     (try
@@ -1852,15 +1694,15 @@ let main files =
     let menubar = GMenu.menu_bar ~packing:vbox#pack () in
 
     (* Toolbar *)
-    let toolbar = GButton.toolbar 
-      ~orientation:`HORIZONTAL 
+    let toolbar = GButton.toolbar
+      ~orientation:`HORIZONTAL
       ~style:`ICONS
-      ~tooltips:true 
+      ~tooltips:true
       ~packing:(* handle#add *)
       (vbox#pack ~expand:false ~fill:false)
       ()
     in
-      show_toolbar := 
+      show_toolbar :=
 	(fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ());
 
       let factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/" menubar in
@@ -1873,17 +1715,20 @@ let main files =
 
       (* File/Load Menu *)
       let load_file handler f =
-	let f = absolute_filename f in		
+	let f = absolute_filename f in
 	  try
 	    prerr_endline "Loading file starts";
-	    Vector.find_or_fail 
-	      (function 
-		 | {analyzed_view=Some av} -> 
-		     (match av#filename with 
-			| None -> false 
-			| Some fn -> same_file f fn)
-		 | _ -> false) 
-	      !input_views;
+	    if not (Util.list_fold_left_i
+                (fun i found x -> if found then found else
+                     let {analyzed_view=av} = x in
+                         (match av#filename with
+                           | None -> false
+                           | Some fn ->
+                               if same_file f fn
+                               then (session_notebook#goto_page i; true)
+                               else false))
+                0 false session_notebook#pages)
+            then begin
 	    prerr_endline "Loading: must open";
 	    let b = Buffer.create 1024 in
 	      prerr_endline "Loading: get raw content";
@@ -1891,290 +1736,231 @@ let main files =
 	      prerr_endline "Loading: convert content";
 	      let s = do_convert (Buffer.contents b) in
 		prerr_endline "Loading: create view";
-		let view = create_input_tab (Glib.Convert.filename_to_utf8 
-					       (Filename.basename f)) 
-		in
-		  prerr_endline "Loading: change font";
-		  view#misc#modify_font !current.text_font;
+                let session = create_session () in
+                  session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename f));
 		  prerr_endline "Loading: adding view";
-		  let index = add_input_view {view = view;
-					      analyzed_view = None;
-					     }
-		  in
-		  let av = (new analyzed_view index) in 
-		    prerr_endline "Loading: register view";
-		    (get_input_view index).analyzed_view <- Some av;
+                  let index = session_notebook#append_term session in
+		  let av = session.analyzed_view in
 		    prerr_endline "Loading: set filename";
 		    av#set_filename (Some f);
 		    prerr_endline "Loading: stats";
 		    av#update_stats;
-		    let input_buffer = view#buffer in
+		    let input_buffer = session.script#buffer in
 		      prerr_endline "Loading: fill buffer";
 		      input_buffer#set_text s;
 		      input_buffer#place_cursor input_buffer#start_iter;
 		      prerr_endline ("Loading: switch to view "^ string_of_int index);
-		      set_current_view index;
-		      set_tab_image index ~icon:`YES;
+		      session_notebook#goto_page index;
 		      prerr_endline "Loading: highlight";
-		      Highlight.highlight_all input_buffer;
 		      input_buffer#set_modified false;
 		      prerr_endline "Loading: clear undo";
-		      av#view#clear_undo;
+		      session.script#clear_undo;
 		      prerr_endline "Loading: success"
-	  with       
-	    | Vector.Found i -> set_current_view i
+            end
+	  with
 	    | e -> handler ("Load failed: "^(Printexc.to_string e))
       in
-      let load f = load_file !flash_info f in
-      let load_m = file_factory#add_item "_New" 
+      let load f = load_file flash_info f in
+      let load_m = file_factory#add_item "_New"
 	~key:GdkKeysyms._N in
-      let load_f () = 	  
-	match select_file_for_save ~title:"Create file" () with 
+      let load_f () =
+	match select_file_for_save ~title:"Create file" () with
 	  | None -> ()
 	  | Some f -> load f
       in
 	ignore (load_m#connect#activate (load_f));
 
-      let load_m = file_factory#add_item "_Open" 
+      let load_m = file_factory#add_item "_Open"
 	~key:GdkKeysyms._O in
-      let load_f () = 	  
-	match select_file_for_open ~title:"Load file" () with 
+      let load_f () =
+	match select_file_for_open ~title:"Load file" () with
 	  | None -> ()
 	  | Some f -> load f
       in
 	ignore (load_m#connect#activate (load_f));
 
 	(* File/Save Menu *)
-	let save_m = file_factory#add_item "_Save" 
+	let save_m = file_factory#add_item "_Save"
 	  ~key:GdkKeysyms._S in
-
-	  
-	let save_f () = 
-	  let current = get_current_view () in
+	let save_f () =
+	  let current = session_notebook#current_term in
 	    try
-	      (match (Option.get current.analyzed_view)#filename with 
+	      (match current.analyzed_view#filename with
 		 | None ->
 		     begin match select_file_for_save ~title:"Save file" ()
 		       with
 			 | None -> ()
-			 | Some f -> 
-			     if (Option.get current.analyzed_view)#save_as f then begin
-				 set_current_tab_label (Filename.basename f);
-				 !flash_info ("File " ^ f ^ " saved")
+			 | Some f ->
+			     if current.analyzed_view#save_as f then begin
+                                 current.tab_label#set_text (Filename.basename f);
+				 flash_info ("File " ^ f ^ " saved")
 			       end
 			     else warning ("Save Failed (check if " ^ f ^ " is writable)")
 		     end
-		 | Some f -> 
-		     if (Option.get current.analyzed_view)#save f then 
-		       !flash_info ("File " ^ f ^ " saved")
+		 | Some f ->
+		     if current.analyzed_view#save f then
+		       flash_info ("File " ^ f ^ " saved")
 		     else warning  ("Save Failed (check if " ^ f ^ " is writable)")
-		       
+
 	      )
-	    with 
+	    with
 	      | e -> warning "Save: unexpected error"
-	in   
+	in
 	  ignore (save_m#connect#activate save_f);
 
 	  (* File/Save As Menu *)
-	  let saveas_m = file_factory#add_item "S_ave as" 
+	  let saveas_m = file_factory#add_item "S_ave as"
 	  in
-	  let saveas_f () = 
-	    let current = get_current_view () in
-	      try (match (Option.get current.analyzed_view)#filename with 
-		     | None -> 
+	  let saveas_f () =
+	    let current = session_notebook#current_term in
+	      try (match current.analyzed_view#filename with
+		     | None ->
 			 begin match select_file_for_save ~title:"Save file as" ()
 			   with
 			     | None -> ()
-			     | Some f -> 
-				 if (Option.get current.analyzed_view)#save_as f then begin
-				     set_current_tab_label (Filename.basename f);
-				     !flash_info "Saved"
+			     | Some f ->
+				 if current.analyzed_view#save_as f then begin
+                                   current.tab_label#set_text (Filename.basename f);
+				     flash_info "Saved"
 				   end
-				 else !flash_info "Save Failed"
+				 else flash_info "Save Failed"
 			 end
-		     | Some f -> 
-			 begin match select_file_for_save 
-			     ~dir:(ref (Filename.dirname f)) 
+		     | Some f ->
+			 begin match select_file_for_save
+			     ~dir:(ref (Filename.dirname f))
 			     ~filename:(Filename.basename f)
 			     ~title:"Save file as" ()
 			   with
 			     | None -> ()
-			     | Some f -> 
-				 if (Option.get current.analyzed_view)#save_as f then begin
-				     set_current_tab_label (Filename.basename f);
-				     !flash_info "Saved"
-				   end else !flash_info "Save Failed"
+			     | Some f ->
+				 if current.analyzed_view#save_as f then begin
+                                   current.tab_label#set_text (Filename.basename f);
+				     flash_info "Saved"
+				   end else flash_info "Save Failed"
 			 end);
-	      with e -> !flash_info "Save Failed"
-	  in   
+	      with e -> flash_info "Save Failed"
+	  in
 	    ignore (saveas_m#connect#activate saveas_f);
-	    
+	    (* XXX *)
 	    (* File/Save All Menu *)
 	    let saveall_m = file_factory#add_item "Sa_ve all" in
-	    let saveall_f () = 
-	      Vector.iter
-		(function 
-		   | {view = view ; analyzed_view = Some av} -> 
-		       begin match av#filename with 
+	    let saveall_f () =
+	      List.iter
+		(function
+		   | {script = view ; analyzed_view = av} ->
+		       begin match av#filename with
 			 | None -> ()
 			 | Some f ->
 			     ignore (av#save f)
 		       end
-		   | _ -> ()
-		)  input_views
+		)  session_notebook#pages
 	    in
-	    let has_something_to_save () = 
-	      Vector.exists
-		(function 
-		   | {view=view} -> view#buffer#modified        
+            (* XXX *)
+	    let has_something_to_save () =
+	      List.exists
+		(function
+		   | {script=view} -> view#buffer#modified
 		)
-		input_views
+		session_notebook#pages
 	    in
 	      ignore (saveall_m#connect#activate saveall_f);
-	      
+	     (* XXX *)
 	      (* File/Revert Menu *)
 	      let revert_m = file_factory#add_item "_Revert all buffers" in
-	      let revert_f () = 
-		Vector.iter 
-		  (function 
-		       {view = view ; analyzed_view = Some av} -> 
-			 (try 
-			      match av#filename,av#stats with 
-				| Some f,Some stats -> 
+	      let revert_f () =
+		List.iter
+		  (function
+		       {analyzed_view = av} ->
+			 (try
+			      match av#filename,av#stats with
+				| Some f,Some stats ->
 				    let new_stats = Unix.stat f in
-				      if new_stats.Unix.st_mtime > stats.Unix.st_mtime 
+				      if new_stats.Unix.st_mtime > stats.Unix.st_mtime
 				      then av#revert
 				| Some _, None -> av#revert
 				| _ -> ()
 			  with _ -> av#revert)
-		     | _ -> ()
-		  )  input_views
+		  ) session_notebook#pages
 	      in
 		ignore (revert_m#connect#activate revert_f);
-		
+
 		(* File/Close Menu *)
 		let close_m =
                   file_factory#add_item "_Close buffer" ~key:GdkKeysyms._W in
-		let close_f () = 
-		  let v = Option.get !active_view in
-		  let act = get_current_view_page () in
-		    if v = act then !flash_info "Cannot close an active view"
+		let close_f () =
+		  let v = !active_view in
+		  let act = session_notebook#current_page in
+		    if v = act then flash_info "Cannot close an active view"
 		    else remove_current_view_page ()
 		in
 		  ignore (close_m#connect#activate close_f);
-		  
+
 		  (* File/Print Menu *)
-		  let print_f () =
-		    let v = get_current_view () in
-		    let av = Option.get v.analyzed_view in
-		      match av#filename with
-			| None -> 
-			    !flash_info "Cannot print: this buffer has no name"
-			| Some f ->
-			    let cmd = 
-			      "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^
-				!current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename f) ^ 
-				" | " ^ !current.cmd_print
-			    in
-			    let print_window = GWindow.window
-			      ~title:"Print" 
-			      ~modal:true 
-			      ~position:`CENTER
-			      ~wm_class:"CodIDE" 
-			      ~wm_name: "CodIDE"  () in
-			    let vbox_print = GPack.vbox  
-			      ~spacing:10 
-			      ~border_width:10 
-			      ~packing:print_window#add () in
-			    let _ = GMisc.label 
-			      ~justify:`LEFT
-			      ~text:"Print using the following command:" 
-			      ~packing:vbox_print#add () in
-			    let print_entry = GEdit.entry 
-			      ~text:cmd
-			      ~editable:true
-			      ~width_chars:80
-			      ~packing:vbox_print#add () in 
-			    let hbox_print = GPack.hbox 
-			      ~spacing:10 
-			      ~packing:vbox_print#add () in 
-			    let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in
-			    let print_button  = GButton.button ~stock:`PRINT  ~label:"Print"  ~packing:hbox_print#add () in
-			    let callback_print () = 
-			      let cmd = print_entry#text in
-			      let s,_ = run_command av#insert_message cmd in
-				!flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed");
-				print_window#destroy ()
-			    in
-			      ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ;
-			      ignore (print_button#connect#clicked ~callback:callback_print);
-			      print_window#misc#show();
-		  in
 		  let _ = file_factory#add_item "_Print..."
 	            ~key:GdkKeysyms._P
-                    ~callback:print_f in
+                    ~callback:(fun () -> do_print session_notebook#current_term) in
 
 		  (* File/Export to Menu *)
 		  let export_f kind () =
-		    let v = get_current_view () in
-		    let av = Option.get v.analyzed_view in
+		    let v = session_notebook#current_term in
+		    let av = v.analyzed_view in
 		      match av#filename with
-			| None -> 
-			    !flash_info "Cannot print: this buffer has no name"
+			| None ->
+			    flash_info "Cannot print: this buffer has no name"
 			| Some f ->
 			    let basef = Filename.basename f in
-			    let output = 
+			    let output =
 			      let basef_we = try Filename.chop_extension basef with _ -> basef in
 				match kind with
 				  | "latex" -> basef_we ^ ".tex"
 				  | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
 				  | _ -> assert false
 			    in
-			    let cmd = 
+			    let cmd =
 			      "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^
 				!current.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef)
 			    in
 			    let s,_ = run_command av#insert_message cmd in
-			      !flash_info (cmd ^ 
-					     if s = Unix.WEXITED 0 
-					     then " succeeded" 
+			      flash_info (cmd ^
+					     if s = Unix.WEXITED 0
+					     then " succeeded"
 					     else " failed")
 		  in
 		  let file_export_m =  file_factory#add_submenu "E_xport to" in
 
 		  let file_export_factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/Export/" file_export_m ~accel_group in
-		  let _ = 
-		    file_export_factory#add_item "_Html" ~callback:(export_f "html") 
+		  let _ =
+		    file_export_factory#add_item "_Html" ~callback:(export_f "html")
 		  in
-		  let _ = 
+		  let _ =
 		    file_export_factory#add_item "_LaTeX" ~callback:(export_f "latex")
 		  in
-		  let _ = 
-		    file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi") 
+		  let _ =
+		    file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi")
 		  in
-		  let _ = 
-		    file_export_factory#add_item "_Pdf" ~callback:(export_f "pdf") 
+		  let _ =
+		    file_export_factory#add_item "_Pdf" ~callback:(export_f "pdf")
 		  in
-		  let _ = 
-		    file_export_factory#add_item "_Ps" ~callback:(export_f "ps") 
+		  let _ =
+		    file_export_factory#add_item "_Ps" ~callback:(export_f "ps")
 		  in
 
 		  (* File/Rehighlight Menu *)
 		  let rehighlight_m = file_factory#add_item "Reh_ighlight" ~key:GdkKeysyms._L in
-		    ignore (rehighlight_m#connect#activate 
-			      (fun () -> 
-				 Highlight.highlight_all 
-				   (get_current_view()).view#buffer;
-				 (Option.get (get_current_view()).analyzed_view)#recenter_insert));
+		    ignore (rehighlight_m#connect#activate
+			      (fun () ->
+				 force_retag
+				   session_notebook#current_term.script#buffer;
+				 session_notebook#current_term.analyzed_view#recenter_insert));
 
 		    (* File/Quit Menu *)
 		    let quit_f () =
 		      save_pref();
-		      if has_something_to_save () then 
+		      if has_something_to_save () then
 			match (GToolbox.question_box ~title:"Quit"
 				 ~buttons:["Save Named Buffers and Quit";
 					   "Quit without Saving";
-					   "Don't Quit"] 
+					   "Don't Quit"]
 				 ~default:0
 				 ~icon:
 				 (let img = GMisc.image () in
@@ -2188,7 +1974,7 @@ let main files =
 			  | _ -> ()
 		      else exit 0
 		    in
-		    let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q 
+		    let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q
 		      ~callback:quit_f
 		    in
 		      ignore (w#event#connect#delete (fun _ -> quit_f (); true));
@@ -2198,50 +1984,60 @@ let main files =
 		      let edit_f = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/Edit/" edit_menu ~accel_group in
 			ignore(edit_f#add_item "_Undo" ~key:GdkKeysyms._u ~callback:
 				 (do_if_not_computing "undo"
-				    (fun () -> 
-				       ignore ((Option.get ((get_current_view()).analyzed_view))#
-						 without_auto_complete 
-						 (fun () -> (get_current_view()).view#undo) ()))));
-			ignore(edit_f#add_item "_Clear Undo Stack" 
+				    (fun () ->
+				       ignore (session_notebook#current_term.analyzed_view#
+						 without_auto_complete
+						 (fun () -> session_notebook#current_term.script#undo) ()))));
+			ignore(edit_f#add_item "_Clear Undo Stack"
 				 (* ~key:GdkKeysyms._exclam *)
 				 ~callback:
-				 (fun () -> 
-				    ignore (get_current_view()).view#clear_undo));
+				 (fun () ->
+				    ignore session_notebook#current_term.script#clear_undo));
 			ignore(edit_f#add_separator ());
+                        let get_active_view_for_cp () =
+                          let has_sel (i0,i1) = i0#compare i1 <> 0 in
+                          let current = session_notebook#current_term in
+                            if has_sel current.script#buffer#selection_bounds
+                            then current.script#as_view
+                            else if has_sel current.proof_view#buffer#selection_bounds
+                            then current.proof_view#as_view
+                            else current.message_view#as_view
+                        in
 			ignore(edit_f#add_item "Cut" ~key:GdkKeysyms._X ~callback:
 				 (fun () -> GtkSignal.emit_unit
-				    (get_current_view()).view#as_view 
-				    GtkText.View.S.cut_clipboard));
+				    (get_active_view_for_cp ())
+				    GtkText.View.S.cut_clipboard
+                                 ));
 			ignore(edit_f#add_item "Copy" ~key:GdkKeysyms._C ~callback:
 				 (fun () -> GtkSignal.emit_unit
-				    (get_current_view()).view#as_view 
+				    (get_active_view_for_cp ())
 				    GtkText.View.S.copy_clipboard));
 			ignore(edit_f#add_item "Paste" ~key:GdkKeysyms._V ~callback:
-				 (fun () -> 
+				 (fun () ->
 				    try GtkSignal.emit_unit
-				      (get_current_view()).view#as_view 
+				      session_notebook#current_term.script#as_view
 				      GtkText.View.S.paste_clipboard
 				    with _ -> prerr_endline "EMIT PASTE FAILED"));
 			ignore (edit_f#add_separator ());
 
 
 			(*
-			  let toggle_auto_complete_i = 
-			  edit_f#add_check_item "_Auto Completion" 
+			  let toggle_auto_complete_i =
+			  edit_f#add_check_item "_Auto Completion"
 			  ~active:!current.auto_complete
 			  ~callback:
 			  in
 			*)
 			(*
-			  auto_complete := 
-			  (fun b -> match (get_current_view()).analyzed_view with
+			  auto_complete :=
+			  (fun b -> match session_notebook#current_term.analyzed_view with
 			  | Some av -> av#set_auto_complete b
 			  | None -> ());
 			*)
 
 			let last_found = ref None in
 			let search_backward = ref false in
-			let find_w = GWindow.window 
+			let find_w = GWindow.window
 			  (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
 			  (* ~allow_grow:true ~allow_shrink:true *)
 			  (* ~width:!current.window_width ~height:!current.window_height *)
@@ -2252,38 +2048,38 @@ let main files =
 			  ~columns:3 ~rows:5
 			  ~col_spacings:10 ~row_spacings:10 ~border_width:10
 			  ~homogeneous:false ~packing:find_w#add () in
-			  
-			let _ = 
+
+			let _ =
 			  GMisc.label ~text:"Find:"
 			    ~xalign:1.0
-			    ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () 
+			    ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) ()
 			in
 			let find_entry = GEdit.entry
 			  ~editable: true
 			  ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X)
 			  ()
 			in
-			let _ = 
+			let _ =
 			  GMisc.label ~text:"Replace with:"
 			    ~xalign:1.0
-			    ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () 
+			    ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) ()
 			in
 			let replace_entry = GEdit.entry
 			  ~editable: true
 			  ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
 			  ()
 			in
-			(* let _ = 
+			(* let _ =
 			  GButton.check_button
 			    ~label:"case sensitive"
 			    ~active:true
 			    ~packing: (find_box#attach ~left:1 ~top:2)
 			    ()
-			
+
                         in
 			*)
 			  (*
-			    let find_backwards_check = 
+			    let find_backwards_check =
 			    GButton.check_button
 			    ~label:"search backwards"
 			    ~active:false
@@ -2322,25 +2118,25 @@ let main files =
 			    ()
 			in
 			let last_find () =
-			  let v = (get_current_view()).view in
+			  let v = session_notebook#current_term.script in
 			  let b = v#buffer in
 			  let start,stop =
-			    match !last_found with 
+			    match !last_found with
 			      | None -> let i = b#get_iter_at_mark `INSERT in (i,i)
 			      | Some(start,stop) ->
 				  let start = b#get_iter_at_mark start
 				  and stop = b#get_iter_at_mark stop
 				  in
-				    b#remove_tag_by_name ~start ~stop "found";
+				    b#remove_tag Tags.Script.found ~start ~stop;
 				    last_found:=None;
 				    start,stop
 			  in
 			    (v,b,start,stop)
 			in
 			let do_replace () =
-			  let v = (get_current_view()).view in
+			  let v = session_notebook#current_term.script in
 			  let b = v#buffer in
-			    match !last_found with 
+			    match !last_found with
 			      | None -> ()
 			      | Some(start,stop) ->
 				  let start = b#get_iter_at_mark start
@@ -2358,7 +2154,7 @@ let main files =
 			  with
 			    | None -> ()
 			    | Some(start,stop) ->
-				b#apply_tag_by_name "found" ~start ~stop;
+				b#apply_tag Tags.Script.found ~start ~stop;
 				let start = `MARK (b#create_mark start)
 				and stop = `MARK (b#create_mark stop)
 				in
@@ -2368,7 +2164,7 @@ let main files =
 			in
 			let do_find () =
 			  let (v,b,starti,_) = last_find () in
-			    find_from v b starti find_entry#text 
+			    find_from v b starti find_entry#text
 			in
 			let do_replace_find () =
 			  do_replace();
@@ -2380,8 +2176,8 @@ let main files =
 			    find_w#misc#hide();
 			    v#coerce#misc#grab_focus()
 			in
-			  to_do_on_page_switch := 
-			    (fun i -> if find_w#misc#visible then close_find()):: 
+			  to_do_on_page_switch :=
+			    (fun i -> if find_w#misc#visible then close_find())::
 			      !to_do_on_page_switch;
 			  let find_again_forward () =
 			    search_backward := false;
@@ -2403,12 +2199,12 @@ let main files =
 				    find_w#misc#hide();
 				    v#coerce#misc#grab_focus();
 				    true
-				end 
+				end
 			      else if k = GdkKeysyms._Return then
 				begin
 				  close_find();
 				  true
-				end 
+				end
 			      else if List.mem `CONTROL s && k = GdkKeysyms._f then
 				begin
 				  find_again_forward ();
@@ -2421,7 +2217,7 @@ let main files =
 				end
 			      else false (* to let default callback execute *)
 			  in
-			  let find_f ~backward () = 
+			  let find_f ~backward () =
 			    search_backward := backward;
 			    find_w#show ();
 			    find_w#present ();
@@ -2455,30 +2251,30 @@ let main files =
 			      let complete_i = edit_f#add_item "_Complete"
 			      ~key:GdkKeysyms._comma
 			      ~callback:
-			      (do_if_not_computing 
-			      (fun b -> 
-			      let v = Option.get (get_current_view ()).analyzed_view 
-			      
-			      in v#complete_at_offset 
+			      (do_if_not_computing
+			      (fun b ->
+			      let v = session_notebook#current_term.analyzed_view
+
+			      in v#complete_at_offset
 			      ((v#view#buffer#get_iter `SEL_BOUND)#offset)
 			      ))
 			      in
 			      complete_i#misc#set_state `INSENSITIVE;
 			    *)
-			    
+
 			    ignore(edit_f#add_item "Complete Word" ~key:GdkKeysyms._slash ~callback:
-				     (fun () -> 
+				     (fun () ->
 					ignore (
-						 let av = Option.get ((get_current_view()).analyzed_view) in 
+						 let av = session_notebook#current_term.analyzed_view in
 						   av#complete_at_offset (av#get_insert)#offset
 					       )));
 
 			    ignore(edit_f#add_separator ());
 			    (* external editor *)
-			    let _ = 
+			    let _ =
 			      edit_f#add_item "External editor" ~callback:
-				(fun () -> 	 
-				   let av = Option.get ((get_current_view()).analyzed_view) in 
+				(fun () ->
+				   let av = session_notebook#current_term.analyzed_view in
 				     match av#filename with
 				       | None -> warning "Call to external editor available only on named files"
 				       | Some f ->
@@ -2491,34 +2287,33 @@ let main files =
 			      (* Preferences *)
 			    let reset_revert_timer () =
 			      disconnect_revert_timer ();
-			      if !current.global_auto_revert then 
+			      if !current.global_auto_revert then
 				revert_timer := Some
-				  (GMain.Timeout.add ~ms:!current.global_auto_revert_delay 
+				  (GMain.Timeout.add ~ms:!current.global_auto_revert_delay
 				     ~callback:
-				     (fun () -> 
+				     (fun () ->
 					do_if_not_computing "revert" (sync revert_f) ();
 					true))
 			    in reset_revert_timer (); (* to enable statup preferences timer *)
-
-			      let auto_save_f () = 
-				Vector.iter 
-				  (function 
-				       {view = view ; analyzed_view = Some av} -> 
-					 (try 
+                              (* XXX *)
+			      let auto_save_f () =
+				List.iter
+				  (function
+				       {script = view ; analyzed_view = av} ->
+					 (try
 					      av#auto_save
 					  with _ -> ())
-				     | _ -> ()
-				  )  
-				  input_views
+				  )
+				  session_notebook#pages
 			      in
 
 			      let reset_auto_save_timer () =
 				disconnect_auto_save_timer ();
-				if !current.auto_save then 
+				if !current.auto_save then
 				  auto_save_timer := Some
-				    (GMain.Timeout.add ~ms:!current.auto_save_delay 
+				    (GMain.Timeout.add ~ms:!current.auto_save_delay
 				       ~callback:
-				       (fun () -> 
+				       (fun () ->
 					  do_if_not_computing "autosave" (sync auto_save_f) ();
 					  true))
 			      in reset_auto_save_timer (); (* to enable statup preferences timer *)
@@ -2536,34 +2331,40 @@ let main files =
 				  *)
 				  (* Navigation Menu *)
 				let navigation_menu =  factory#add_submenu "_Navigation" in
-				let navigation_factory = 
-				  new GMenu.factory navigation_menu 
+				let navigation_factory =
+				  new GMenu.factory navigation_menu
 				    ~accel_path:"<CoqIde MenuBar>/Navigation/"
-				    ~accel_group 
-				    ~accel_modi:!current.modifier_for_navigation 
+				    ~accel_group
+				    ~accel_modi:!current.modifier_for_navigation
 				in
-				let do_or_activate f () = 
-				  let current = get_current_view () in
-				  let analyzed_view = Option.get current.analyzed_view in
-				    if analyzed_view#is_active then 
+				let _do_or_activate f () =
+				  let current = session_notebook#current_term in
+				  let analyzed_view = current.analyzed_view in
+				    if analyzed_view#is_active then begin
+                                      prerr_endline ("view "^current.tab_label#text^"already active");
 				      ignore (f analyzed_view)
-				    else
+                                    end else
 				      begin
-					!flash_info "New proof started";
-					activate_input (notebook ())#current_page;
+					flash_info "New proof started";
+                                        prerr_endline ("activating view "^current.tab_label#text);
+					activate_input session_notebook#current_page;
 					ignore (f analyzed_view)
 				      end
 				in
 
-				let do_or_activate f = 
+				let do_or_activate f =
 				  do_if_not_computing "do_or_activate"
-				    (do_or_activate
-				       (fun av -> f av ; !pop_info();!push_info (Coq.current_status())))
+				    (_do_or_activate
+				       (fun av -> f av;
+                                          pop_info ();
+                                          push_info (Coq.current_status())
+                                       )
+                                    )
 				in
 
-				let add_to_menu_toolbar text ~tooltip ?key ~callback icon = 
+				let add_to_menu_toolbar text ~tooltip ?key ~callback icon =
 				  begin
-				    match key with None -> () 
+				    match key with None -> ()
 				      | Some key -> ignore (navigation_factory#add_item text ~key ~callback)
 				  end;
 				  ignore (toolbar#insert_button
@@ -2573,107 +2374,106 @@ let main files =
 					    ~callback
 					    ())
 				in
-				  add_to_menu_toolbar 
-				    "_Save" 
-				    ~tooltip:"Save current buffer" 
+				  add_to_menu_toolbar
+				    "_Save"
+				    ~tooltip:"Save current buffer"
 				    ~callback:save_f
 				    `SAVE;
-				  add_to_menu_toolbar 
-				    "_Close" 
-				    ~tooltip:"Close current buffer" 
+				  add_to_menu_toolbar
+				    "_Close"
+				    ~tooltip:"Close current buffer"
 				    ~callback:close_f
 				    `CLOSE;
-				  add_to_menu_toolbar 
-				    "_Forward" 
-				    ~tooltip:"Forward one command" 
-				    ~key:GdkKeysyms._Down 
-				    ~callback:(do_or_activate (fun a -> a#process_next_phrase true true true))
+				  add_to_menu_toolbar
+				    "_Forward"
+				    ~tooltip:"Forward one command"
+				    ~key:GdkKeysyms._Down
+				    ~callback:(do_or_activate (fun a -> a#process_next_phrase true true true ))
+
 				    `GO_DOWN;
 				  add_to_menu_toolbar "_Backward"
-				    ~tooltip:"Backward one command" 
+				    ~tooltip:"Backward one command"
 				    ~key:GdkKeysyms._Up
 				    ~callback:(do_or_activate (fun a -> a#undo_last_step))
 				    `GO_UP;
-				  add_to_menu_toolbar 
-				    "_Go to" 
-				    ~tooltip:"Go to cursor" 
+				  add_to_menu_toolbar
+				    "_Go to"
+				    ~tooltip:"Go to cursor"
 				    ~key:GdkKeysyms._Right
 				    ~callback:(do_or_activate (fun a-> a#go_to_insert))
 				    `JUMP_TO;
-				  add_to_menu_toolbar 
-				    "_Start" 
-				    ~tooltip:"Go to start" 
+				  add_to_menu_toolbar
+				    "_Start"
+				    ~tooltip:"Go to start"
 				    ~key:GdkKeysyms._Home
 				    ~callback:(do_or_activate (fun a -> a#reset_initial))
 				    `GOTO_TOP;
-				  add_to_menu_toolbar 
-				    "_End" 
-				    ~tooltip:"Go to end" 
+				  add_to_menu_toolbar
+				    "_End"
+				    ~tooltip:"Go to end"
 				    ~key:GdkKeysyms._End
 				    ~callback:(do_or_activate (fun a -> a#process_until_end_or_error))
 				    `GOTO_BOTTOM;
 				  add_to_menu_toolbar "_Interrupt"
-				    ~tooltip:"Interrupt computations"    
-				    ~key:GdkKeysyms._Break 
+				    ~tooltip:"Interrupt computations"
+				    ~key:GdkKeysyms._Break
 				    ~callback:break
 				    `STOP;
+                                  add_to_menu_toolbar "_Hide"
+                                    ~tooltip:"Hide proof"
+                                    ~key:GdkKeysyms._h
+                                    ~callback:(fun x ->
+                                                 let sess = session_notebook#current_term in
+                                                 toggle_proof_visibility sess.script#buffer
+                                                   sess.analyzed_view#get_insert)
+                                    `MISSING_IMAGE;
 
 				  (* Tactics Menu *)
 				  let tactics_menu =  factory#add_submenu "_Try Tactics" in
-				  let tactics_factory = 
-				    new GMenu.factory tactics_menu 
+				  let tactics_factory =
+				    new GMenu.factory tactics_menu
 				      ~accel_path:"<CoqIde MenuBar>/Tactics/"
-				      ~accel_group 
+				      ~accel_group
 				      ~accel_modi:!current.modifier_for_tactics
 				  in
-				  let do_if_active_raw f () = 
-				    let current = get_current_view () in
-				    let analyzed_view = Option.get current.analyzed_view in
+				  let do_if_active_raw f () =
+				    let current = session_notebook#current_term in
+				    let analyzed_view = current.analyzed_view in
 				      if analyzed_view#is_active then ignore (f analyzed_view)
 				  in
 				  let do_if_active f =
 				    do_if_not_computing "do_if_active" (do_if_active_raw f) in
 
-				    (*
-				      let blaster_i = 
-				      tactics_factory#add_item "_Blaster"
-				      ~key:GdkKeysyms._b
-				      ~callback: (do_if_active_raw (fun a -> a#blaster ()))
-				    (* Custom locking mechanism! *)
-				      in
-				      blaster_i#misc#set_state `INSENSITIVE;
-				    *)
-				    
-				    ignore (tactics_factory#add_item "_auto" 
+				    ignore (tactics_factory#add_item "_auto"
 					      ~key:GdkKeysyms._a
 					      ~callback:(do_if_active (fun a -> a#insert_command "progress auto.\n" "auto.\n"))
 					   );
 				    ignore (tactics_factory#add_item "_auto with *"
 					      ~key:GdkKeysyms._asterisk
-					      ~callback:(do_if_active (fun a -> a#insert_command 
+					      ~callback:(do_if_active (fun a -> a#insert_command
 									 "progress auto with *.\n"
 									 "auto with *.\n")));
 				    ignore (tactics_factory#add_item "_eauto"
 					      ~key:GdkKeysyms._e
-					      ~callback:(do_if_active (fun a -> a#insert_command 
+					      ~callback:(do_if_active (fun a -> a#insert_command
 									 "progress eauto.\n"
 									 "eauto.\n"))
 					   );
 				    ignore (tactics_factory#add_item "_eauto with *"
 					      ~key:GdkKeysyms._ampersand
-					      ~callback:(do_if_active (fun a -> a#insert_command 
-									 "progress eauto with *.\n" 
+					      ~callback:(do_if_active (fun a -> a#insert_command
+									 "progress eauto with *.\n"
 									 "eauto with *.\n"))
 					   );
 				    ignore (tactics_factory#add_item "_intuition"
 					      ~key:GdkKeysyms._i
-					      ~callback:(do_if_active (fun a -> a#insert_command 
-									 "progress intuition.\n" 
+					      ~callback:(do_if_active (fun a -> a#insert_command
+									 "progress intuition.\n"
 									 "intuition.\n"))
 					   );
 				    ignore (tactics_factory#add_item "_omega"
 					      ~key:GdkKeysyms._o
-					      ~callback:(do_if_active (fun a -> a#insert_command 
+					      ~callback:(do_if_active (fun a -> a#insert_command
 									 "omega.\n" "omega.\n"))
 					   );
 				    ignore (tactics_factory#add_item "_simpl"
@@ -2703,15 +2503,15 @@ let main files =
 
 				    ignore (tactics_factory#add_item "<Proof _Wizard>"
 					      ~key:GdkKeysyms._dollar
-					      ~callback:(do_if_active (fun a -> a#tactic_wizard 
+					      ~callback:(do_if_active (fun a -> a#tactic_wizard
 									 !current.automatic_tactics
 								      ))
 					   );
-				    
+
 				    ignore (tactics_factory#add_separator ());
-				    let add_simple_template (factory: GMenu.menu GMenu.factory) 
+				    let add_simple_template (factory: GMenu.menu GMenu.factory)
 					(menu_text, text) =
-				      let text = 
+				      let text =
 					let l = String.length text - 1 in
 					  if String.get text l = '.'
 					  then text ^"\n"
@@ -2719,42 +2519,42 @@ let main files =
 				      in
 					ignore (factory#add_item menu_text
 						  ~callback:
-						  (fun () -> let {view = view } = get_current_view () in
+						  (fun () -> let {script = view } = session_notebook#current_term in
 							       ignore (view#buffer#insert_interactive text)))
 				    in
-				      List.iter 
-					(fun l -> 
-					   match l with 
+				      List.iter
+					(fun l ->
+					   match l with
 					     | [] -> ()
-					     | [s] -> add_simple_template tactics_factory ("_"^s, s) 
-					     | s::_ -> 
+					     | [s] -> add_simple_template tactics_factory ("_"^s, s)
+					     | s::_ ->
 						 let a = "_@..." in
 						   a.[1] <- s.[0];
-						   let f = tactics_factory#add_submenu a in 
+						   let f = tactics_factory#add_submenu a in
 						   let ff = new GMenu.factory f ~accel_group in
-						     List.iter 
-						       (fun x -> 
+						     List.iter
+						       (fun x ->
 							  add_simple_template
-							    ff 
+							    ff
 							    ((String.sub x 0 1)^
 							       "_"^
 							       (String.sub x 1 (String.length x - 1)),
 							     x))
 						       l
-					) 
+					)
 					Coq_commands.tactics;
-				      
+
 				      (* Templates Menu *)
 				      let templates_menu =  factory#add_submenu "Te_mplates" in
-				      let templates_factory = new GMenu.factory templates_menu 
+				      let templates_factory = new GMenu.factory templates_menu
 					~accel_path:"<CoqIde MenuBar>/Templates/"
-					~accel_group 
+					~accel_group
 					~accel_modi:!current.modifier_for_templates
 				      in
 				      let add_complex_template (menu_text, text, offset, len, key) =
 					(* Templates/Lemma *)
 					let callback () =
-					  let {view = view } = get_current_view () in
+					  let {script = view } = session_notebook#current_term in
 					    if view#buffer#insert_interactive text then begin
 						let iter = view#buffer#get_iter_at_mark `INSERT in
 						  ignore (iter#nocopy#backward_chars offset);
@@ -2764,19 +2564,19 @@ let main files =
 					      end in
 					  ignore (templates_factory#add_item menu_text ~callback ?key)
 				      in
-					add_complex_template 
-					  ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n", 
+					add_complex_template
+					  ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n",
 					   19, 9, Some GdkKeysyms._L);
-					add_complex_template 
-					  ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n", 
+					add_complex_template
+					  ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n",
 					   19, 11, Some GdkKeysyms._T);
-					add_complex_template 
+					add_complex_template
 					  ("_Definition __", "Definition ident := .\n",
 					   6, 5, Some GdkKeysyms._D);
-					add_complex_template 
+					add_complex_template
 					  ("_Inductive __", "Inductive ident : :=\n  | : .\n",
 					   14, 5, Some GdkKeysyms._I);
-					add_complex_template 
+					add_complex_template
 					  ("_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
 					   29, 5, Some GdkKeysyms._F);
 					add_complex_template("_Scheme __",
@@ -2784,14 +2584,14 @@ let main files =
 with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 
 					(* Template for match *)
-					let callback () = 
+					let callback () =
 					  let w = get_current_word () in
-					    try 
+					    try
 					      let cases = Coq.make_cases w
 					      in
 					      let print c = function
 						| [x] -> Format.fprintf c "  | %s => _@\n" x
-						| x::l -> Format.fprintf c "  | (%s%a) => _@\n" x 
+						| x::l -> Format.fprintf c "  | (%s%a) => _@\n" x
 						    (print_list (fun c s -> Format.fprintf c " %s" s)) l
 						| [] -> assert false
 					      in
@@ -2801,28 +2601,28 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 						  (print_list print) cases;
 						let s = Buffer.contents b in
 						  prerr_endline s;
-						  let {view = view } = get_current_view () in
+						  let {script = view } = session_notebook#current_term in
 						    ignore (view#buffer#delete_selection ());
-						    let m = view#buffer#create_mark 
+						    let m = view#buffer#create_mark
 						      (view#buffer#get_iter `INSERT)
 						    in
-						      if view#buffer#insert_interactive s then 
+						      if view#buffer#insert_interactive s then
 							let i = view#buffer#get_iter (`MARK m) in
 							let _ = i#nocopy#forward_chars 9 in
 							  view#buffer#place_cursor i;
 							  view#buffer#move_mark ~where:(i#backward_chars 3)
-							    `SEL_BOUND 
-					    with Not_found -> !flash_info "Not an inductive type"
+							    `SEL_BOUND
+					    with Not_found -> flash_info "Not an inductive type"
 					in
 					  ignore (templates_factory#add_item "match ..."
 						    ~key:GdkKeysyms._C
 						    ~callback
 						 );
-					  
+
 					  (*
-					    let add_simple_template (factory: GMenu.menu GMenu.factory) 
+					    let add_simple_template (factory: GMenu.menu GMenu.factory)
 					    (menu_text, text) =
-					    let text = 
+					    let text =
 					    let l = String.length text - 1 in
 					    if String.get text l = '.'
 					    then text ^"\n"
@@ -2830,7 +2630,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 					    in
 					    ignore (factory#add_item menu_text
 					    ~callback:
-					    (fun () -> let {view = view } = get_current_view () in
+					    (fun () -> let {view = view } = session_notebook#current_term in
 					    ignore (view#buffer#insert_interactive text)))
 					    in
 					  *)
@@ -2849,92 +2649,100 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 					    ];
 					    ignore (templates_factory#add_separator ());
 					  *)
-					  List.iter 
-					    (fun l -> 
-					       match l with 
+					  List.iter
+					    (fun l ->
+					       match l with
 						 | [] -> ()
-						 | [s] -> add_simple_template templates_factory ("_"^s, s) 
-						 | s::_ -> 
+						 | [s] -> add_simple_template templates_factory ("_"^s, s)
+						 | s::_ ->
 						     let a = "_@..." in
 						       a.[1] <- s.[0];
-						       let f = templates_factory#add_submenu a in 
+						       let f = templates_factory#add_submenu a in
 						       let ff = new GMenu.factory f ~accel_group in
-							 List.iter 
-							   (fun x -> 
-							      add_simple_template 
-								ff 
+							 List.iter
+							   (fun x ->
+							      add_simple_template
+								ff
 								((String.sub x 0 1)^
 								   "_"^
 								   (String.sub x 1 (String.length x - 1)),
 								 x))
 							   l
-					    ) 
+					    )
 					    Coq_commands.commands;
-					  
+
 					  (* Queries Menu *)
 					  let queries_menu =  factory#add_submenu "_Queries" in
 					  let queries_factory = new GMenu.factory queries_menu ~accel_group
 					    ~accel_path:"<CoqIde MenuBar>/Queries"
 					    ~accel_modi:[]
 					  in
-					    
+
 					  (* Command/Show commands *)
-					  let _ = 
+					  let _ =
 					    queries_factory#add_item "_SearchAbout " ~key:GdkKeysyms._F2
 					      ~callback:(fun () -> let term = get_current_word () in
 								     (Command_windows.command_window ())#new_command
 								       ~command:"SearchAbout"
-								       ~term 
+								       ~term
 								       ())
 					  in
-					  let _ = 
+					  let _ =
 					    queries_factory#add_item "_Check " ~key:GdkKeysyms._F3
 					      ~callback:(fun () -> let term = get_current_word () in
 								     (Command_windows.command_window ())#new_command
 								       ~command:"Check"
-								       ~term 
+								       ~term
 								       ())
 					  in
-					  let _ = 
+					  let _ =
 					    queries_factory#add_item "_Print " ~key:GdkKeysyms._F4
 					      ~callback:(fun () -> let term = get_current_word () in
 								     (Command_windows.command_window ())#new_command
 								       ~command:"Print"
-								       ~term 
+								       ~term
+								       ())
+					  in
+					  let _ =
+					    queries_factory#add_item "_About " ~key:GdkKeysyms._F5
+					      ~callback:(fun () -> let term = get_current_word () in
+								     (Command_windows.command_window ())#new_command
+								       ~command:"About"
+								       ~term
 								       ())
 					  in
-					  let _ = 
-					    queries_factory#add_item "_Locate" 
+					  let _ =
+					    queries_factory#add_item "_Locate"
 					      ~callback:(fun () -> let term = get_current_word () in
 								     (Command_windows.command_window ())#new_command
 								       ~command:"Locate"
-								       ~term 
+								       ~term
 								       ())
 					  in
-					  let _ = 
-					    queries_factory#add_item "_Whelp Locate" 
+					  let _ =
+					    queries_factory#add_item "_Whelp Locate"
 					      ~callback:(fun () -> let term = get_current_word () in
 								     (Command_windows.command_window ())#new_command
 								       ~command:"Whelp Locate"
-								       ~term 
+								       ~term
 								       ())
 					  in
 
 					  (* Display menu *)
-					    
+
 					  let display_menu =  factory#add_submenu "_Display" in
 					  let view_factory =  new GMenu.factory display_menu
 					    ~accel_path:"<CoqIde MenuBar>/Display/"
-					    ~accel_group 
+					    ~accel_group
 					    ~accel_modi:!current.modifier_for_display
 					  in
 
-					  let _ = ignore (view_factory#add_check_item 
-							    "Display _implicit arguments" 
+					  let _ = ignore (view_factory#add_check_item
+							    "Display _implicit arguments"
 							    ~key:GdkKeysyms._i
 							    ~callback:(fun _ -> printing_state.printing_implicit <- not printing_state.printing_implicit; do_or_activate (fun a -> a#show_goals) ())) in
 
-					  let _ = ignore (view_factory#add_check_item 
+					  let _ = ignore (view_factory#add_check_item
 							    "Display _coercions"
 							    ~key:GdkKeysyms._c
 							    ~callback:(fun _ -> printing_state.printing_coercions <- not printing_state.printing_coercions; do_or_activate (fun a -> a#show_goals) ())) in
@@ -2944,104 +2752,77 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 							    ~key:GdkKeysyms._m
 							    ~callback:(fun _ -> printing_state.printing_raw_matching <- not printing_state.printing_raw_matching; do_or_activate (fun a -> a#show_goals) ())) in
 
-					  let _ = ignore (view_factory#add_check_item  
+					  let _ = ignore (view_factory#add_check_item
 							    "Deactivate _notations display"
 							    ~key:GdkKeysyms._n
 							    ~callback:(fun _ -> printing_state.printing_no_notation <- not printing_state.printing_no_notation; do_or_activate (fun a -> a#show_goals) ())) in
 
-					  let _ = ignore (view_factory#add_check_item  
+					  let _ = ignore (view_factory#add_check_item
 							    "Display _all basic low-level contents"
 							    ~key:GdkKeysyms._a
-							    ~callback:(fun _ -> printing_state.printing_all <- not printing_state.printing_all; do_or_activate (fun a -> a#show_goals) ())) in 
+							    ~callback:(fun _ -> printing_state.printing_all <- not printing_state.printing_all; do_or_activate (fun a -> a#show_goals) ())) in
 
-					  let _ = ignore (view_factory#add_check_item     
+					  let _ = ignore (view_factory#add_check_item
 							    "Display _existential variable instances"
 							    ~key:GdkKeysyms._e
 					    		    ~callback:(fun _ -> printing_state.printing_evar_instances <- not printing_state.printing_evar_instances; do_or_activate (fun a -> a#show_goals) ())) in
 
-					  let _ = ignore (view_factory#add_check_item  
+					  let _ = ignore (view_factory#add_check_item
 							    "Display _universe levels"
 							    ~key:GdkKeysyms._u
 					    		    ~callback:(fun _ -> printing_state.printing_universes <- not printing_state.printing_universes; do_or_activate (fun a -> a#show_goals) ())) in
 
-					  let _ = ignore (view_factory#add_check_item  
+					  let _ = ignore (view_factory#add_check_item
 							    "Display all _low-level contents"
 							    ~key:GdkKeysyms._l
-							    ~callback:(fun _ -> printing_state.printing_full_all <- not printing_state.printing_full_all; do_or_activate (fun a -> a#show_goals) ())) in 
+							    ~callback:(fun _ -> printing_state.printing_full_all <- not printing_state.printing_full_all; do_or_activate (fun a -> a#show_goals) ())) in
+
+
 
-					  (* Unicode *)
-(*
-					  let unicode_menu =  factory#add_submenu "_Unicode" in
-					  let unicode_factory =  new GMenu.factory unicode_menu
-					    ~accel_path:"<CoqIde MenuBar>/Unicode/"
-					    ~accel_group 
-					    ~accel_modi:[]
-					  in
-					  let logic_symbols_menu = unicode_factory#add_submenu "Math operators" in
-					  let logic_factory = new GMenu.factory logic_symbols_menu
-					    ~accel_path:"<CoqIde MenuBar>/Unicode/Math operators"
-					    ~accel_group 
-					    ~accel_modi:[]
-					  in
-					  let new_unicode_item s = ignore (
-					    logic_factory#add_item s 
-					      ~callback:(fun () ->  
-							   let v = get_current_view () in
-							     ignore (v.view#buffer#insert_interactive s)))
-					  in
-					  
-					  for i = 0x2200 to 0x22FF do
-					 	List.iter new_unicode_item [Glib.Utf8.from_unichar i];
-					 	 
-					  done;			
-					  		  			
-*)				  
-		  			
-		  			
 					  (* Externals *)
 					  let externals_menu =  factory#add_submenu "_Compile" in
-					  let externals_factory = new GMenu.factory externals_menu 
+					  let externals_factory = new GMenu.factory externals_menu
 					    ~accel_path:"<CoqIde MenuBar>/Compile/"
-					    ~accel_group 
+					    ~accel_group
 					    ~accel_modi:[]
 					  in
-					    
+
 					  (* Command/Compile Menu *)
 					  let compile_f () =
-					    let v = get_current_view () in
-					    let av = Option.get v.analyzed_view in
+					    let v = session_notebook#current_term in
+					    let av = v.analyzed_view in
 					      save_f ();
 					      match av#filename with
-						| None -> 
-						    !flash_info "Active buffer has no name"
+						| None ->
+						    flash_info "Active buffer has no name"
 						| Some f ->
-						    let cmd = !current.cmd_coqc ^ " -I " 
+						    let cmd = !current.cmd_coqc ^ " -I "
 						      ^ (Filename.quote (Filename.dirname f))
 						      ^ " " ^ (Filename.quote f) in
 						    let s,res = run_command av#insert_message cmd in
 						      if s = Unix.WEXITED 0 then
-							!flash_info (f ^ " successfully compiled")
+							flash_info (f ^ " successfully compiled")
 						      else begin
-							  !flash_info (f ^ " failed to compile");
-							  activate_input (notebook ())#current_page;
+							  flash_info (f ^ " failed to compile");
+							  activate_input session_notebook#current_page;
 							  av#process_until_end_or_error;
 							  av#insert_message "Compilation output:\n";
 							  av#insert_message res
 							end
 					  in
-					  let _ = 
-					    externals_factory#add_item "_Compile Buffer" ~callback:compile_f 
+					  let _ =
+					    externals_factory#add_item "_Compile Buffer" ~callback:compile_f
 					  in
 
 					  (* Command/Make Menu *)
 					  let make_f () =
-					    let v = get_current_view () in
-					    let av = Option.get v.analyzed_view in
+					    let v = session_notebook#current_term in
+					    let av = v.analyzed_view in
 					      match av#filename with
-						| None -> 
-						    !flash_info "Cannot make: this buffer has no name"
+						| None ->
+						    flash_info "Cannot make: this buffer has no name"
 						| Some f ->
-						    let cmd = 
+						    let cmd =
 						      "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^ !current.cmd_make in
 
 						      (*
@@ -3051,22 +2832,22 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 						      let s,res = run_command av#insert_message cmd in
 							last_make := res;
 							last_make_index := 0;
-							!flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+							flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
 					  in
-					  let _ = externals_factory#add_item "_Make" 
+					  let _ = externals_factory#add_item "_Make"
 					    ~key:GdkKeysyms._F6
-					    ~callback:make_f 
+					    ~callback:make_f
 					  in
-					    
+
 
 					  (* Compile/Next Error *)
-					  let next_error () = 
+					  let next_error () =
 					    try
 					      let file,line,start,stop,error_msg = search_next_error () in
-						load file;
-						let v = get_current_view () in
-						let av = Option.get v.analyzed_view in
-						let input_buffer = v.view#buffer in
+                                              load file;
+                                              let v = session_notebook#current_term in
+						let av = v.analyzed_view in
+						let input_buffer = v.script#buffer in
 						  (*
 						    let init = input_buffer#start_iter in
 						    let i = init#forward_lines (line-1) in
@@ -3082,215 +2863,143 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 						  *)
 						let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
 						let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
-						  input_buffer#apply_tag_by_name "error"
+						  input_buffer#apply_tag Tags.Script.error
    						    ~start:starti
 						    ~stop:stopi;
 						  input_buffer#place_cursor starti;
 						  av#set_message error_msg;
-						  v.view#misc#grab_focus ()
+						  v.script#misc#grab_focus ()
 					    with Not_found ->
 					      last_make_index := 0;
-					      let v = get_current_view () in
-					      let av = Option.get v.analyzed_view in
+					      let v = session_notebook#current_term in
+					      let av = v.analyzed_view in
 						av#set_message "No more errors.\n"
 					  in
-					  let _ = 
-					    externals_factory#add_item "_Next error" 
+					  let _ =
+					    externals_factory#add_item "_Next error"
 					      ~key:GdkKeysyms._F7
 					      ~callback:next_error in
-					    
+
 
 					  (* Command/CoqMakefile Menu*)
 					  let coq_makefile_f () =
-					    let v = get_current_view () in
-					    let av = Option.get v.analyzed_view in
+					    let v = session_notebook#current_term in
+					    let av = v.analyzed_view in
 					      match av#filename with
-						| None -> 
-						    !flash_info "Cannot make makefile: this buffer has no name"
+						| None ->
+						    flash_info "Cannot make makefile: this buffer has no name"
 						| Some f ->
-						    let cmd = 
+						    let cmd =
 						      "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^ !current.cmd_coqmakefile in
 						    let s,res = run_command av#insert_message cmd in
-						      !flash_info 
+						      flash_info
 							(!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
 					  in
-					  let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f 
+					  let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f
 					  in
 					    (* Windows Menu *)
 					  let configuration_menu = factory#add_submenu "_Windows" in
-					  let configuration_factory = new GMenu.factory configuration_menu 
+					  let configuration_factory = new GMenu.factory configuration_menu
 					    ~accel_path:"<CoqIde MenuBar>/Windows"
 					    ~accel_modi:[]
 					    ~accel_group
 					  in
 					  let _ =
-					    configuration_factory#add_item 
+					    configuration_factory#add_item
 					      "Show/Hide _Query Pane"
 					      ~key:GdkKeysyms._Escape
-					      ~callback:(fun () -> if (Command_windows.command_window ())#frame#misc#visible then 
+					      ~callback:(fun () -> if (Command_windows.command_window ())#frame#misc#visible then
 							   (Command_windows.command_window ())#frame#misc#hide ()
 							 else
 							   (Command_windows.command_window ())#frame#misc#show ())
-					  in  
-					  let _ = 
-					    configuration_factory#add_check_item 
-					      "Show/Hide _Toolbar"	       
-					      ~callback:(fun _ ->  
-							   !current.show_toolbar <- not !current.show_toolbar; 
-							   !show_toolbar !current.show_toolbar) 
-					  in
-					  let _ = configuration_factory#add_item 
-					    "Detach _Script Window"
-					    ~callback:
-					    (do_if_not_computing "detach script window" (sync
-											   (fun () -> 
-											      let nb = notebook () in
-												if nb#misc#toplevel#get_oid=w#coerce#get_oid then
-												  begin  
-												    let nw = GWindow.window 
-												      ~width:(!current.window_width*2/3)
-												      ~height:(!current.window_height*2/3)
-												      ~position:`CENTER
-												      ~wm_name:"CoqIde"
-												      ~wm_class:"CoqIde"
-												      ~title:"Script" 
-												      ~show:true () in
-												    let parent = Option.get nb#misc#parent in
-												      ignore (nw#connect#destroy 
-														~callback:
-														(fun () -> nb#misc#reparent parent));
-												      nw#add_accel_group accel_group;
-												      nb#misc#reparent nw#coerce
-												  end	      
-											   )))
 					  in
-(*					  let _ = configuration_factory#add_item 
-					    "Detach _Command Pane"
-					    ~callback:
-					    (do_if_not_computing "detach command pane" (sync
-											   (fun () -> 
-											      let command_object = Command_windows.command_window() in
-											      let queries_frame = command_object#frame in
-												if queries_frame#misc#toplevel#get_oid=w#coerce#get_oid then
-												  begin  
-												    let nw = GWindow.window 
-												      ~width:(!current.window_width*2/3)
-												      ~height:(!current.window_height*2/3)
-												      ~wm_name:"CoqIde"
-												      ~wm_class:"CoqIde"
-												      ~position:`CENTER 
-												      ~title:"Queries" 
-												      ~show:true () in
-												    let parent = Option.get queries_frame#misc#parent in
-												      ignore (nw#connect#destroy 
-														~callback:
-														(fun () -> queries_frame#misc#reparent parent));
-												      queries_frame#misc#show();
-												      queries_frame#misc#reparent nw#coerce
-												  end	      
-											   )))
+					  let _ =
+					    configuration_factory#add_check_item
+					      "Show/Hide _Toolbar"
+					      ~callback:(fun _ ->
+							   !current.show_toolbar <- not !current.show_toolbar;
+							   !show_toolbar !current.show_toolbar)
 					  in
-*)
-					  let _ = 
-					    configuration_factory#add_item 
+					  let _ =
+					    configuration_factory#add_item
 					      "Detach _View"
 					      ~callback:
 					      (do_if_not_computing "detach view"
-						 (fun () -> 
-						    match get_current_view () with  
-						      | {view=v;analyzed_view=Some av} -> 
-							  let w = GWindow.window ~show:true 
+						 (fun () ->
+						    match session_notebook#current_term with
+						      | {script=v;analyzed_view=av} ->
+							  let w = GWindow.window ~show:true
 							    ~width:(!current.window_width*2/3)
 							    ~height:(!current.window_height*2/3)
 							    ~position:`CENTER
 							    ~title:(match av#filename with
 								      | None -> "*Unnamed*"
-								      | Some f -> f) 
-							    () 
+								      | Some f -> f)
+							    ()
 							  in
-							  let sb = GBin.scrolled_window 
-							    ~packing:w#add () 
+							  let sb = GBin.scrolled_window
+							    ~packing:w#add ()
 							  in
-							  let nv = GText.view 
-							    ~buffer:v#buffer 
-							    ~packing:sb#add 
+							  let nv = GText.view
+							    ~buffer:v#buffer
+							    ~packing:sb#add
 							    ()
 							  in
-							    nv#misc#modify_font 
-							      !current.text_font; 
-							    ignore (w#connect#destroy 
+							    nv#misc#modify_font
+							      !current.text_font;
+							    ignore (w#connect#destroy
 								      ~callback:
 								      (fun () -> av#remove_detached_view w));
 							    av#add_detached_view w
-						      | _ -> ()
-							  
+
 						 ))
 					  in
 					    (* Help Menu *)
 
 					  let help_menu = factory#add_submenu "_Help" in
-					  let help_factory = new GMenu.factory help_menu  
+					  let help_factory = new GMenu.factory help_menu
 					    ~accel_path:"<CoqIde MenuBar>/Help/"
 					    ~accel_modi:[]
 					    ~accel_group in
-					  let _ = help_factory#add_item "Browse Coq _Manual" 
+					  let _ = help_factory#add_item "Browse Coq _Manual"
 					    ~callback:
-					    (fun () -> 
-					       let av = Option.get ((get_current_view ()).analyzed_view) in 
-						 browse av#insert_message (!current.doc_url)) in
-					  let _ = help_factory#add_item "Browse Coq _Library" 
+					    (fun () ->
+					       let av = session_notebook#current_term.analyzed_view in
+						 browse av#insert_message (doc_url ())) in
+					  let _ = help_factory#add_item "Browse Coq _Library"
 					    ~callback:
-					    (fun () -> 
-					       let av = Option.get ((get_current_view ()).analyzed_view) in 
+					    (fun () ->
+					       let av = session_notebook#current_term.analyzed_view in
 						 browse av#insert_message !current.library_url) in
-					  let _ = 
+					  let _ =
 					    help_factory#add_item "Help for _keyword" ~key:GdkKeysyms._F1
-					      ~callback:(fun () -> 
-							   let av = Option.get ((get_current_view ()).analyzed_view) in 
+					      ~callback:(fun () ->
+							   let av = session_notebook#current_term.analyzed_view in
 							     av#help_for_keyword ())
 					  in
 					  let _ = help_factory#add_separator () in
-					    (*
-					      let faq_m = help_factory#add_item "_FAQ" in
-					    *)
 					  let about_m = help_factory#add_item "_About" in
 					  (* End of menu *)
 
 					  (* The vertical Separator between Scripts and Goals *)
 					  let queries_pane = GPack.paned `VERTICAL ~packing:(vbox#pack ~expand:true ) () in
-					  let hb = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(queries_pane#pack1 ~shrink:false ~resize:true) () in
-					  let fr_notebook = GBin.frame ~shadow_type:`IN ~packing:hb#add1 () in
-					    _notebook := Some (GPack.notebook ~border_width:2 ~show_border:false ~scrollable:true 
-								 ~packing:fr_notebook#add
-								 ());
+					    queries_pane#pack1 ~shrink:false ~resize:true session_notebook#coerce;
                                             update_notebook_pos ();
-					    let nb = notebook () in
-					    let hb2 = GPack.paned `VERTICAL ~packing:hb#add2 () in
-					    let fr_a = GBin.frame ~shadow_type:`IN ~packing:hb2#add () in
-                                            let fr_b = GBin.frame ~shadow_type:`IN ~packing:hb2#add () in
-					    let sw2 = GBin.scrolled_window 
-					      ~vpolicy:`AUTOMATIC 
-					      ~hpolicy:`AUTOMATIC
-					      ~packing:(fr_a#add) () in
-					    let sw3 = GBin.scrolled_window 
-					      ~vpolicy:`AUTOMATIC 
-					      ~hpolicy:`AUTOMATIC
-					      ~packing:(fr_b#add) () in
+					    let nb = session_notebook in
 					    let command_object = Command_windows.command_window() in
 					    let queries_frame = command_object#frame in
 					      queries_pane#pack2 ~shrink:false ~resize:false (queries_frame#coerce);
 					    let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
-					    let status_bar = GMisc.statusbar ~packing:(lower_hbox#pack ~expand:true) () 
-					    in
+					    lower_hbox#pack ~expand:true status#coerce;
 					    let search_lbl = GMisc.label ~text:"Search:"
 					      ~show:false
-					      ~packing:(lower_hbox#pack ~expand:false) () 
+					      ~packing:(lower_hbox#pack ~expand:false) ()
 					    in
 					    let search_history = ref [] in
 					    let search_input = GEdit.combo ~popdown_strings:!search_history
 					      ~enable_arrow_keys:true
 					      ~show:false
-					      ~packing:(lower_hbox#pack ~expand:false) () 
+					      ~packing:(lower_hbox#pack ~expand:false) ()
 					    in
 					      search_input#disable_activate ();
 					      let ready_to_wrap_search = ref false in
@@ -3301,108 +3010,99 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 					      let search_forward = ref true in
 					      let matched_word = ref None in
 
-					      let memo_search () = 
+					      let memo_search () =
 						matched_word := Some search_input#entry#text
-
-					      (*     if not (List.mem search_input#entry#text !search_history) then
-						     (search_history := 
-						     search_input#entry#text::!search_history;
-						     search_input#set_popdown_strings !search_history);
-						     start_of_search := None;
-						     ready_to_wrap_search := false
-					      *)
-
 					      in
-					      let end_search () = 
+					      let end_search () =
 						prerr_endline "End Search";
 						memo_search ();
-						let v = (get_current_view ()).view in
+						let v = session_notebook#current_term.script in
 						  v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT);
 						  v#coerce#misc#grab_focus ();
 						  search_input#entry#set_text "";
 						  search_lbl#misc#hide ();
 						  search_input#misc#hide ()
 					      in
-					      let end_search_focus_out () = 
+					      let end_search_focus_out () =
 						prerr_endline "End Search(focus out)";
 						memo_search ();
-						let v = (get_current_view ()).view in
+						let v = session_notebook#current_term.script in
 						  v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT);
 						  search_input#entry#set_text "";
 						  search_lbl#misc#hide ();
 						  search_input#misc#hide ()
 					      in
 						ignore (search_input#entry#connect#activate ~callback:end_search);
-						ignore (search_input#entry#event#connect#key_press 
+						ignore (search_input#entry#event#connect#key_press
 							  ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
-										if 
+										if
 										  kv = GdkKeysyms._Right
-										  || kv = GdkKeysyms._Up 
+										  || kv = GdkKeysyms._Up
 										  || kv = GdkKeysyms._Left
-										  || (kv = GdkKeysyms._g 
+										  || (kv = GdkKeysyms._g
 										      && (List.mem `CONTROL (GdkEvent.Key.state k)))
-										then end_search (); 
+										then end_search ();
 								       false));
 						ignore (search_input#entry#event#connect#focus_out
 							  ~callback:(fun _ -> end_search_focus_out (); false));
-						to_do_on_page_switch := 
-						  (fun i -> 
+						to_do_on_page_switch :=
+						  (fun i ->
 						     start_of_search := None;
 						     ready_to_wrap_search:=false)::!to_do_on_page_switch;
 
 						(* TODO : make it work !!! *)
-						let rec search_f () = 
+						let rec search_f () =
 						  search_lbl#misc#show ();
 						  search_input#misc#show ();
 
 						  prerr_endline "search_f called";
 						  if !start_of_search = None then begin
 						      (* A full new search is starting *)
-						      start_of_search := 
-							Some ((get_current_view ()).view#buffer#create_mark 
-								((get_current_view ()).view#buffer#get_iter_at_mark `INSERT));
+						      start_of_search :=
+							Some (session_notebook#current_term.script#buffer#create_mark
+								(session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT));
 						      start_of_found := !start_of_search;
 						      end_of_found := !start_of_search;
 						      matched_word := Some "";
 						    end;
-						  let txt = search_input#entry#text in 
-						  let v = (get_current_view ()).view in
-						  let iit = v#buffer#get_iter_at_mark `SEL_BOUND 
+						  let txt = search_input#entry#text in
+						  let v = session_notebook#current_term.script in
+						  let iit = v#buffer#get_iter_at_mark `SEL_BOUND
 						  and insert_iter = v#buffer#get_iter_at_mark `INSERT
 						  in
 						    prerr_endline ("SELBOUND="^(string_of_int iit#offset));
 						    prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
-						    
+
 						    (match
-							 if !search_forward then iit#forward_search txt 
+							 if !search_forward then iit#forward_search txt
 							 else let npi = iit#forward_chars (Glib.Utf8.length txt) in
-								match 
+								match
 								  (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
-								  (let t = iit#get_text ~stop:npi in 
-								     !flash_info (t^"\n"^txt);
+								  (let t = iit#get_text ~stop:npi in
+								     flash_info (t^"\n"^txt);
 								     t = txt)
-								with 
-								  | true,true -> 
-								      (!flash_info "T,T";iit#backward_search txt)
-								  | false,true -> !flash_info "F,T";Some (iit,npi)
+								with
+								  | true,true ->
+								      (flash_info "T,T";iit#backward_search txt)
+								  | false,true -> flash_info "F,T";Some (iit,npi)
 								  | _,false ->
 								      (iit#backward_search txt)
 
-						     with 
-						       | None -> 
+						     with
+						       | None ->
 							   if !ready_to_wrap_search then begin
 							       ready_to_wrap_search := false;
-							       !flash_info "Search wrapped";
-							       v#buffer#place_cursor 
+							       flash_info "Search wrapped";
+							       v#buffer#place_cursor
 								 (if !search_forward then v#buffer#start_iter else
 								      v#buffer#end_iter);
 							       search_f ()
 							     end else begin
-								 if !search_forward then !flash_info "Search at end"
-								 else !flash_info "Search at start";
+								 if !search_forward then flash_info "Search at end"
+								 else flash_info "Search at start";
 								 ready_to_wrap_search := true
 							       end
-						       | Some (start,stop) -> 
+						       | Some (start,stop) ->
 							   prerr_endline "search: before moving marks";
 							   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
 							   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
@@ -3415,105 +3115,49 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 							   v#scroll_to_mark `SEL_BOUND
 						    )
 						in
-						  ignore (search_input#entry#event#connect#key_release 
+						  ignore (search_input#entry#event#connect#key_release
 							    ~callback:
 							    (fun ev ->
 							       if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
-								   let v = (get_current_view ()).view in
-								     (match !start_of_search with 
-									| None -> 
+								   let v = session_notebook#current_term.script in
+								     (match !start_of_search with
+									| None ->
 									    prerr_endline "search_key_rel: Placing sel_bound";
-									    v#buffer#move_mark 
-									      `SEL_BOUND 
+									    v#buffer#move_mark
+									      `SEL_BOUND
 									      (v#buffer#get_iter_at_mark `INSERT)
-									| Some mk -> let it = v#buffer#get_iter_at_mark 
+									| Some mk -> let it = v#buffer#get_iter_at_mark
 									    (`MARK mk) in
 										       prerr_endline "search_key_rel: Placing cursor";
 									    v#buffer#place_cursor it;
 									    start_of_search := None
 								     );
-								     search_input#entry#set_text ""; 
+								     search_input#entry#set_text "";
 								     v#coerce#misc#grab_focus ();
-								 end; 
+								 end;
 							       false
 							    ));
 						  ignore (search_input#entry#connect#changed search_f);
-						  
-						  (*
-						    ignore (search_if#connect#activate
-						    ~callback:(fun b -> 
-						    search_forward:= true;
-						    search_input#entry#coerce#misc#grab_focus ();
-						    search_f ();
-						    )
-						    );
-						    ignore (search_ib#connect#activate
-						    ~callback:(fun b ->
-						    search_forward:= false;
-
-						  (* Must restore the SEL_BOUND mark after 
-						    grab_focus ! *)
-						    let v = (get_current_view ()).view in
-						    let old_sel = v#buffer#get_iter_at_mark `SEL_BOUND 
-						    in
-						    search_input#entry#coerce#misc#grab_focus ();
-						    v#buffer#move_mark `SEL_BOUND old_sel;
-						    search_f ();
-						    ));
-						  *)
-						  let status_context = status_bar#new_context "Messages" in
-						  let flash_context = status_bar#new_context "Flash" in
-						    ignore (status_context#push "Ready");
-						    status := Some status_bar;
-						    push_info := (fun s -> ignore (status_context#push s));
-						    pop_info := (fun () -> status_context#pop ());
-						    flash_info := (fun ?(delay=5000) s -> flash_context#flash ~delay s);
-
-						    (* Location display *)
+						    push_info "Ready";
+                                                                 (* Location display *)
 						    let l = GMisc.label
-						      ~text:"Line:     1 Char:   1" 
-						      ~packing:lower_hbox#pack () in 
+						      ~text:"Line:     1 Char:   1"
+						      ~packing:lower_hbox#pack () in
 						      l#coerce#misc#set_name "location";
 						      set_location := l#set_text;
-
 						      (* Progress Bar *)
-						      pulse := 
-							(let pb = GRange.progress_bar ~pulse_step:0.2 ~packing:lower_hbox#pack ()
-							 in pb#set_text "CoqIde started";pb)#pulse;
-						      let tv2 = GText.view ~packing:(sw2#add) () in
-							tv2#misc#set_name "GoalWindow";
-							let _ = tv2#set_editable false in
-							let _ = tv2#buffer in
-							let tv3 = GText.view ~packing:(sw3#add) () in
-							  tv2#misc#set_name "MessageWindow";
-							  let _ = tv2#set_wrap_mode `CHAR in
-							  let _ = tv3#set_wrap_mode `WORD in
-							  let _ = tv3#set_editable false in
-							  let _ = GtkBase.Widget.add_events tv2#as_widget
-							    [`ENTER_NOTIFY;`POINTER_MOTION] in
-							  let _ =
-							    tv2#event#connect#motion_notify
-							      ~callback:
-							      (fun e -> 
-								 let win = match tv2#get_window `WIDGET with
-								   | None -> assert false
-								   | Some w -> w in
-								 let x,y = Gdk.Window.get_pointer_location win in
-								 let b_x,b_y = tv2#window_to_buffer_coords ~tag:`WIDGET ~x ~y in
-								 let it = tv2#get_iter_at_location ~x:b_x ~y:b_y in
-								 let tags = it#tags in
-								   List.iter 
-								     (fun t ->
-									ignore(GtkText.Tag.event t#as_tag tv2#as_widget e it#as_iter))
-								     tags;
-								   false) in
-							    change_font := 
-							      (fun fd -> 
-								 tv2#misc#modify_font fd;
-								 tv3#misc#modify_font fd;
-								 Vector.iter 
-								   (fun {view=view} -> view#misc#modify_font fd)
-								   input_views;
+            lower_hbox#pack pbar#coerce;
+							 pbar#set_text "CoqIde started";
+                                                    (* XXX *)
+							    change_font :=
+							      (fun fd ->
+								 List.iter
+								   (fun {script=view; proof_view=prf_v; message_view=msg_v} ->
+                                                                           view#misc#modify_font fd;
+                                                                           prf_v#misc#modify_font fd;
+                                                                           msg_v#misc#modify_font fd
+                                                                   )
+								   session_notebook#pages;
 							      );
 							    let about_full_string =
 							      "\nCoq is developed by the Coq Development Team\
@@ -3539,7 +3183,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 								b#insert ~iter:b#start_iter "\n\n";
 								if Glib.Utf8.validate ("You are running " ^ coq_version) then b#insert ~iter:b#start_iter ("You are running " ^ coq_version);
 								if Glib.Utf8.validate initial_string then b#insert ~iter:b#start_iter initial_string;
-								(try 
+								(try
 								    let image = lib_ide_file "coq.png" in
 								    let startup_image = GdkPixbuf.from_file image in
 								      b#insert ~iter:b#start_iter "\n\n";
@@ -3549,7 +3193,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 							    in
 
 							    let about (b:GText.buffer) =
-							      (try 
+							      (try
 								  let image = lib_ide_file "coq.png" in
 								  let startup_image = GdkPixbuf.from_file image in
 								    b#insert ~iter:b#start_iter "\n\n";
@@ -3563,77 +3207,30 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 								  then b#insert coq_version
 
 							    in
-							      initial_about tv2#buffer;
 							      w#add_accel_group accel_group;
 							      (* Remove default pango menu for textviews *)
-							      ignore (tv2#event#connect#button_press ~callback:
-									(fun ev -> GdkEvent.Button.button ev = 3));
-							      ignore (tv3#event#connect#button_press ~callback:
-									(fun ev -> GdkEvent.Button.button ev = 3));
-							      tv2#misc#set_can_focus true;
-							      tv3#misc#set_can_focus true;
-							      ignore (tv2#buffer#create_mark 
-									~name:"end_of_conclusion" 
-									tv2#buffer#start_iter);
-							      ignore (tv3#buffer#create_tag 
-									~name:"error" 
-									[`FOREGROUND "red"]);
 							      w#show ();
-							      message_view := Some tv3;
-							      proof_view := Some tv2;
-							      tv2#misc#modify_font !current.text_font; 
-							      tv3#misc#modify_font !current.text_font;
-							      ignore (about_m#connect#activate 
-									~callback:(fun () -> tv2#buffer#set_text ""; about tv2#buffer));
+							      ignore (about_m#connect#activate
+									~callback:(fun () -> let prf_v = session_notebook#current_term.proof_view in
+                                                                           prf_v#buffer#set_text ""; about prf_v#buffer));
 							      (*
-								ignore (faq_m#connect#activate 
-								~callback:(fun () -> 
-								load (lib_ide_file "FAQ")));
-								
+
 							      *)
-							      resize_window := (fun () -> 
-										  w#resize 
+							      resize_window := (fun () ->
+										  w#resize
 										    ~width:!current.window_width
 										    ~height:!current.window_height);
-
-							      ignore (w#misc#connect#size_allocate 
-									(let old_w = ref 0 
-									 and old_h = ref 0 in
-									   fun {Gtk.width=w;Gtk.height=h} -> 
-									     if !old_w <> w or !old_h <> h then
-									       begin
-										 old_h := h;
-										 old_w := w;
-										 hb#set_position (w/2);
-										 hb2#set_position (h/2);
-										 !current.window_height <- h;
-										 !current.window_width <- w;
-									       end
-									));
-							      ignore(nb#connect#switch_page
+ 						              ignore(nb#connect#switch_page
 								       ~callback:
-								       (fun i -> 
+								       (fun i ->
 									  prerr_endline ("switch_page: starts " ^ string_of_int i);
 									  List.iter (function f -> f i) !to_do_on_page_switch;
 									  prerr_endline "switch_page: success")
 								    );
-							      ignore(tv2#event#connect#enter_notify
-								       (fun _ -> 
-									  if !current.contextual_menus_on_goal then
-									    begin
-									      let w = (Option.get (get_active_view ()).analyzed_view) in
-										!push_info "Computing advanced goal's menus";
-										prerr_endline "Entering Goal Window. Computing Menus....";
-										w#show_goals_full;
-										prerr_endline "....Done with Goal menu";
-										!pop_info();
-									    end;
-									  false;
-								       ));
-							      if List.length files >=1 then
+ 							      if List.length files >=1 then
 								begin
-								  List.iter (fun f -> 
-									       if Sys.file_exists f then load f else 
+								  List.iter (fun f ->
+									       if Sys.file_exists f then load f else
                                                                                  let f = if Filename.check_suffix f ".v" then f else f^".v" in
 										 load_file (fun s -> print_endline s; exit 1) f)
                                                                     files;
@@ -3641,69 +3238,66 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
 								end
 							      else
 								begin
-								  let view = create_input_tab "*Unnamed Buffer*" in
-								  let index = add_input_view {view = view;
-											      analyzed_view = None;
-											     }
-								  in
-								    (get_input_view index).analyzed_view <- Some (new analyzed_view index);
+								  let session = create_session () in
+								  let index = session_notebook#append_term session in
 								    activate_input index;
-								    set_tab_image index ~icon:`YES;
-								    view#misc#modify_font !current.text_font
 								end;
+                                  initial_about session_notebook#current_term.proof_view#buffer;
+                                  !show_toolbar !current.show_toolbar;
+                                  session_notebook#current_term.script#misc#grab_focus ()
 
 ;;
 
-(* This function check every half of second if GeoProof has send 
+(* This function check every half of second if GeoProof has send
    something on his private clipboard *)
 
-let rec check_for_geoproof_input () = 
+let rec check_for_geoproof_input () =
   let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in
     while true do
       Thread.delay 0.1;
       let s = cb_Dr#text in
-	(match s with 
-	     Some s -> 
+	(match s with
+	     Some s ->
 	       if s <> "Ack" then
-		 (get_current_view()).view#buffer#insert (s^"\n");
+		 session_notebook#current_term.script#buffer#insert (s^"\n");
 	       cb_Dr#set_text "Ack"
 	   | None -> ()
 	);
 	(* cb_Dr#clear does not work so i use : *)
-	(* cb_Dr#set_text "Ack" *) 
+	(* cb_Dr#set_text "Ack" *)
     done
-      
-      
-let start () = 
+
+
+let start () =
   let files = Coq.init () in
     ignore_break ();
     GtkMain.Rc.add_default_file (lib_ide_file ".coqide-gtk2rc");
-    (try 
+    (try
 	 GtkMain.Rc.add_default_file (Filename.concat System.home ".coqide-gtk2rc");
      with Not_found -> ());
     ignore (GtkMain.Main.init ());
-    GtkData.AccelGroup.set_default_mod_mask 
+    GtkData.AccelGroup.set_default_mod_mask
       (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);
-    cb_ := Some (GData.clipboard Gdk.Atom.primary);
     ignore (
 	     Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL;
 								 `WARNING;`CRITICAL]
-	       (fun ~level msg -> 
+	       (fun ~level msg ->
 		  if level land Glib.Message.log_level `WARNING <> 0
 		  then Pp.warning msg
 		  else failwith ("Coqide internal error: " ^ msg)));
     Command_windows.main ();
-    Blaster_window.main 9;
     init_stdout ();
     main files;
-    if !Coq_config.with_geoproof then ignore (Thread.create check_for_geoproof_input ()); 
-    while true do 
-      try 
-	GtkThread.main ()	
+    if !Coq_config.with_geoproof then ignore (Thread.create check_for_geoproof_input ());
+    while true do
+      try
+	GtkThread.main ()
       with
 	| Sys.Break -> prerr_endline "Interrupted." ; flush stderr
-	| e -> 
+	| e ->
 	    Pervasives.prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e));
 	    flush stderr;
 	    crash_save 127
     done
+
+
diff --git a/ide/coqide.mli b/ide/coqide.mli
index f904c730..4c01e747 100644
--- a/ide/coqide.mli
+++ b/ide/coqide.mli
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqide.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* The CoqIde main module. The following function [start] will parse the
-   command line, initialize the load path, load the input 
+   command line, initialize the load path, load the input
    state, load the files given on the command line, load the ressource file,
    produce the output state if any, and finally will launch the interface. *)
 
diff --git a/ide/extract_index.mll b/ide/extract_index.mll
deleted file mode 100644
index 152ad715..00000000
--- a/ide/extract_index.mll
+++ /dev/null
@@ -1,31 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: extract_index.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-{
-  open Lexing 
-}
-
-(* additional lexer to extract URL from Coq manual's index *)
-
-rule entry = parse
-  | "<LI><TT>" [^ ',']* "</TT>, "
-      { let s = lexeme lexbuf in
-	let n = String.length s in
-	String.sub s 8 (n - 15), extract_index_url lexbuf }
-  | "<LI>" [^ ',']* ", " 
-      { let s = lexeme lexbuf in
-	let n = String.length s in
-	String.sub s 4 (n - 6), extract_index_url lexbuf }
-
-and extract_index_url = parse
-  | "<A HREF=\"" [^ '"']* '"'
-      { let s = lexeme lexbuf in
-	let n = String.length s in
-	String.sub s 9 (n - 10) }
diff --git a/ide/find_phrase.mll b/ide/find_phrase.mll
deleted file mode 100644
index 23019185..00000000
--- a/ide/find_phrase.mll
+++ /dev/null
@@ -1,74 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: find_phrase.mll 9240 2006-10-13 17:51:11Z notin $ *)
-
-{
-  exception Lex_error of string
-  let length = ref 0
-  let buff = Buffer.create 513
-
-}
-
-let phrase_sep = '.'
-
-rule next_phrase = parse
-  | "(*" { incr length; incr length; 
-	   skip_comment lexbuf;
-	   next_phrase lexbuf}
-  | '"'[^'"']*'"' { let lexeme = Lexing.lexeme lexbuf in 
-		 let ulen = Glib.Utf8.length lexeme in
-		 length := !length + ulen;
-		 Buffer.add_string buff lexeme;
-		 next_phrase lexbuf
-	       }
-  | phrase_sep[' ''\n''\t''\r'] {
-	begin 
-	  if !Preferences.current.Preferences.lax_syntax 
-	  then length := !length + 1
-	  else length := !length + 2
-	end;
-      Buffer.add_string buff (Lexing.lexeme lexbuf);
-      Buffer.contents buff}
-
-  | phrase_sep eof{
-      length := !length + 1; 
-      Buffer.add_string buff (Lexing.lexeme lexbuf);
-      Buffer.contents buff}
-  | phrase_sep phrase_sep
-      { 
-	length := !length + 2; 
-	Buffer.add_string buff (Lexing.lexeme lexbuf);
-	next_phrase lexbuf
-      }
-  | _ 
-      { 
-	let c = Lexing.lexeme_char lexbuf 0 in 
-	if Ideutils.is_char_start c then incr length; 
-	Buffer.add_char buff c ;
-	next_phrase lexbuf
-      }
-  | eof  { raise (Lex_error "Phrase should end with . followed by a separator") }
-and skip_comment = parse
-  | "*)" {incr length; incr length; ()}
-  | "(*" {incr length; incr length; 
-	  skip_comment lexbuf;
-	  skip_comment lexbuf}
-  | _  { if Ideutils.is_char_start (Lexing.lexeme_char lexbuf 0) then 
-	   incr length; 
-	 skip_comment lexbuf}
-  | eof  { raise (Lex_error "No closing *)") }
-
-
-{
-  let get lb = 
-    Buffer.reset buff;
-    length := 0;
-    next_phrase lb
-
-}
diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml
new file mode 100644
index 00000000..e92a345e
--- /dev/null
+++ b/ide/gtk_parsing.ml
@@ -0,0 +1,176 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: coqide.ml 11952 2009-03-02 15:29:08Z vgross $ *)
+
+open Ideutils
+
+
+let underscore = Glib.Utf8.to_unichar "_" (ref 0)
+let arobase = Glib.Utf8.to_unichar "@" (ref 0)
+let prime = Glib.Utf8.to_unichar "'" (ref 0)
+let bn = Glib.Utf8.to_unichar "\n" (ref 0)
+let space = Glib.Utf8.to_unichar " " (ref 0)
+let tab = Glib.Utf8.to_unichar "\t" (ref 0)
+
+
+(* TODO: avoid num and prime at the head of a word *)
+let is_word_char c =
+  Glib.Unichar.isalnum c || c = underscore || c = prime
+
+
+let starts_word (it:GText.iter) =
+  prerr_endline ("Starts word ? '"^(Glib.Utf8.from_unichar it#char)^"'");
+  (not it#copy#nocopy#backward_char ||
+     (let c = it#backward_char#char in
+	not (is_word_char c)))
+
+
+let ends_word (it:GText.iter) =
+  (not it#copy#nocopy#forward_char ||
+     let c = it#forward_char#char in
+       not (is_word_char c)
+  )
+
+
+let inside_word (it:GText.iter) =
+  let c = it#char in
+    not (starts_word it) &&
+      not (ends_word it) &&
+      is_word_char c
+
+
+let is_on_word_limit (it:GText.iter) = inside_word it || ends_word it
+
+
+let find_word_start (it:GText.iter) =
+  let rec step_to_start it =
+    prerr_endline "Find word start";
+    if not it#nocopy#backward_char then
+      (prerr_endline "find_word_start: cannot backward"; it)
+    else if is_word_char it#char
+    then step_to_start it
+    else (it#nocopy#forward_char;
+	prerr_endline ("Word start at: "^(string_of_int it#offset));it)
+  in
+    step_to_start it#copy
+
+
+let find_word_end (it:GText.iter) =
+  let rec step_to_end (it:GText.iter) =
+    prerr_endline "Find word end";
+    let c = it#char in
+    if c<>0 && is_word_char c then (
+      ignore (it#nocopy#forward_char);
+      step_to_end it
+    ) else (
+      prerr_endline ("Word end at: "^(string_of_int it#offset));
+      it)
+  in
+    step_to_end it#copy
+
+
+let get_word_around (it:GText.iter) =
+  let start = find_word_start it in
+  let stop =  find_word_end it in
+    start,stop
+
+
+let rec complete_backward w (it:GText.iter) =
+  prerr_endline "Complete backward...";
+  match it#backward_search w with
+    | None -> (prerr_endline "backward_search failed";None)
+    | Some (start,stop) ->
+	prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
+	if starts_word start then
+	  let ne = find_word_end stop in
+	    if ne#compare stop = 0
+	    then complete_backward w start
+	    else Some (start,stop,ne)
+	else complete_backward w start
+
+
+let rec complete_forward w (it:GText.iter) =
+  prerr_endline "Complete forward...";
+  match it#forward_search w with
+    | None -> None
+    | Some (start,stop) ->
+	if starts_word start then
+	  let ne = find_word_end stop in
+	    if ne#compare stop = 0 then
+	      complete_forward w stop
+	    else Some (stop,stop,ne)
+	else complete_forward w stop
+
+
+let find_comment_end (start:GText.iter) =
+  let rec find_nested_comment (search_start:GText.iter) (search_end:GText.iter) (comment_end:GText.iter) =
+    match (search_start#forward_search ~limit:search_end "(*"),(comment_end#forward_search "*)") with
+      | None,_ -> comment_end
+      | Some _, None -> raise Not_found
+      | Some (_,next_search_start),Some (next_search_end,next_comment_end) ->
+          find_nested_comment next_search_start next_search_end next_comment_end
+  in
+    match start#forward_search "*)" with
+      | None -> raise Not_found
+      | Some (search_end,comment_end) -> find_nested_comment start search_end comment_end
+
+
+let rec find_string_end (start:GText.iter) =
+  let dblquote = int_of_char '"' in
+  let rec escaped_dblquote c =
+    (c#char = dblquote) && not (escaped_dblquote c#backward_char)
+  in
+    match start#forward_search "\"" with
+      | None -> raise Not_found
+      | Some (stop,next_start) ->
+          if escaped_dblquote stop#backward_char
+          then find_string_end next_start
+          else next_start
+
+
+let rec find_next_sentence (from:GText.iter) =
+  match (from#forward_search ".") with
+    | None -> raise Not_found
+    | Some (non_vernac_search_end,next_sentence) ->
+        match from#forward_search ~limit:non_vernac_search_end "(*",from#forward_search ~limit:non_vernac_search_end "\"" with
+          | None,None ->
+              if Glib.Unichar.isspace next_sentence#char || next_sentence#compare next_sentence#forward_char == 0
+              then next_sentence else find_next_sentence next_sentence
+          | None,Some (_,string_search_start) -> find_next_sentence (find_string_end string_search_start)
+          | Some (_,comment_search_start),None -> find_next_sentence (find_comment_end comment_search_start)
+          | Some (_,comment_search_start),Some (_,string_search_start) ->
+              find_next_sentence (
+                if comment_search_start#compare string_search_start < 0
+                then find_comment_end comment_search_start
+                else find_string_end string_search_start)
+
+
+let find_nearest_forward (cursor:GText.iter) targets =
+  let fold_targets acc target =
+    match cursor#forward_search target,acc with
+      | Some (t_start,_),Some nearest when (t_start#compare nearest < 0) -> Some t_start
+      | Some (t_start,_),None -> Some t_start
+      | _ -> acc
+  in
+    match List.fold_left fold_targets None targets with
+      | None -> raise Not_found
+      | Some nearest -> nearest
+
+
+let find_nearest_backward (cursor:GText.iter) targets =
+  let fold_targets acc target =
+    match cursor#backward_search target,acc with
+      | Some (t_start,_),Some nearest when (t_start#compare nearest > 0) -> Some t_start
+      | Some (t_start,_),None -> Some t_start
+      | _ -> acc
+  in
+    match List.fold_left fold_targets None targets with
+      | None -> raise Not_found
+      | Some nearest -> nearest
+
diff --git a/ide/highlight.mll b/ide/highlight.mll
index f2ecaa9c..3acdd4f0 100644
--- a/ide/highlight.mll
+++ b/ide/highlight.mll
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: highlight.mll 11481 2008-10-20 19:23:51Z herbelin $ *)
+(* $Id$ *)
 
 {
 
   open Lexing
 
-  type color = string
+  type color = GText.tag
 
   type highlight_order = int * int * color
 
@@ -24,7 +24,7 @@
     let h = Hashtbl.create 97 in
     List.iter (fun s -> Hashtbl.add h s ())
       [  "Add" ; "Check"; "Eval"; "Extraction" ;
-	 "Load" ; "Undo"; "Goal"; 
+	 "Load" ; "Undo"; "Goal";
 	 "Proof" ; "Print"; "Qed" ; "Defined" ; "Save" ;
 	 "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments"
       ];
@@ -33,9 +33,9 @@
   let is_constr_kw =
     let h = Hashtbl.create 97 in
       List.iter (fun s -> Hashtbl.add h s ())
-	[ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; 
-	  "end"; "as"; "let"; "in"; "dest"; "if"; "then"; "else"; "return";
-	  "Prop"; "Set"; "Type" ]; 
+	[ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for";
+	  "end"; "as"; "let"; "in"; "if"; "then"; "else"; "return";
+	  "Prop"; "Set"; "Type" ];
       Hashtbl.mem h
 
   (* Without this table, the automaton would be too big and
@@ -48,7 +48,7 @@
 	  "Proposition" ; "Property" ;
           (* Definitions *)
 	  "Definition" ; "Let" ; "Example" ; "SubClass" ;
-          "Fixpoint" ; "CoFixpoint" ; "Scheme" ;
+          "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ;
           (* Assumptions *)
 	  "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
 	  "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters";
@@ -62,11 +62,11 @@
   let starting = ref true
 }
 
-let space = 
+let space =
   [' ' '\010' '\013' '\009' '\012']
-let firstchar = 
+let firstchar =
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
-let identchar = 
+let identchar =
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let ident = firstchar identchar*
 
@@ -79,8 +79,8 @@ let multiword_declaration =
 let locality = ("Local" space+)?
 
 let multiword_command =
-  "Set" (space+ ident)* 
-| "Unset" (space+ ident)* 
+  "Set" (space+ ident)*
+| "Unset" (space+ ident)*
 | "Open" space+ locality "Scope"
 | "Close" space+ locality "Scope"
 | "Bind" space+ "Scope"
@@ -98,6 +98,11 @@ let multiword_command =
 | "Implicit" space+ "Arguments"
 | "Implicit" space+ ("Type"|"Types")
 | "Combined" space+ "Scheme"
+| "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"))|
+    ("Library"|"Inline"|"NoInline"|"Blacklist"))
+| "Recursive" space+ "Extraction" (space+ "Library")?
+| ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist")
+| "Extract" space+ (("Inlined" space+) "Constant"| "Inductive")
 
 (* At least still missing: "Inline" + decl, variants of "Identity
   Coercion", variants of Print, Add, ... *)
@@ -106,17 +111,17 @@ rule next_starting_order = parse
   | "(*" { comment_start := lexeme_start lexbuf; comment lexbuf }
   | space+ { next_starting_order lexbuf }
   | multiword_declaration
-      { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, "decl" }
+      { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl }
   | multiword_command
-      { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, "kwd" }
-  | ident as id 
+      { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd }
+  | ident as id
       { if id = "Time" then next_starting_order lexbuf else
 	begin
-	  starting:=false; 
-          if is_one_word_command id then 
-	    lexeme_start lexbuf, lexeme_end lexbuf, "kwd" 
+	  starting:=false;
+          if is_one_word_command id then
+	    lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd
 	  else if is_one_word_declaration id then
-	    lexeme_start lexbuf, lexeme_end lexbuf, "decl"
+	    lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl
 	  else
 	    next_interior_order lexbuf
 	end
@@ -125,11 +130,11 @@ rule next_starting_order = parse
   | eof  { raise End_of_file }
 
 and next_interior_order = parse
-  | "(*" 
+  | "(*"
       { comment_start := lexeme_start lexbuf; comment lexbuf }
-  | ident as id 
+  | ident as id
       { if is_constr_kw id then
-	  lexeme_start lexbuf, lexeme_end lexbuf, "kwd"
+	  lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd
         else
 	  next_interior_order lexbuf }
   | "." (" "|"\n"|"\t") { starting := true; next_starting_order lexbuf }
@@ -137,42 +142,49 @@ and next_interior_order = parse
   | eof  { raise End_of_file }
 
 and comment = parse
-  | "*)" { !comment_start,lexeme_end lexbuf,"comment" }
+  | "*)" { !comment_start,lexeme_end lexbuf,Tags.Script.comment }
   | "(*" { ignore (comment lexbuf); comment lexbuf }
+  | "\"" { string_in_comment lexbuf }
   | _    { comment lexbuf }
   | eof  { raise End_of_file }
 
+and string_in_comment = parse
+  | "\"\"" { string_in_comment lexbuf }
+  | "\"" { comment lexbuf }
+  | _ { string_in_comment lexbuf }
+  | eof  { raise End_of_file }
+
 {
   open Ideutils
 
   let highlighting = ref false
 
-  let highlight_slice (input_buffer:GText.buffer) (start:GText.iter) stop = 
+  let highlight_slice (input_buffer:GText.buffer) (start:GText.iter) stop =
     starting := true; (* approximation: assume the beginning of a sentence *)
-    if !highlighting then prerr_endline "Rejected highlight" 
+    if !highlighting then prerr_endline "Rejected highlight"
     else begin
       highlighting := true;
       prerr_endline "Highlighting slice now";
-      input_buffer#remove_tag_by_name ~start ~stop "error";
-      input_buffer#remove_tag_by_name ~start ~stop "kwd";
-      input_buffer#remove_tag_by_name ~start ~stop "decl";
-      input_buffer#remove_tag_by_name ~start ~stop "comment";
+      input_buffer#remove_tag ~start ~stop Tags.Script.error;
+      input_buffer#remove_tag ~start ~stop Tags.Script.kwd;
+      input_buffer#remove_tag ~start ~stop Tags.Script.decl;
+      input_buffer#remove_tag ~start ~stop Tags.Script.comment;
 
       (try begin
 	let offset = start#offset in
 	let s = start#get_slice ~stop in
 	let convert_pos = byte_offset_to_char_offset s in
 	let lb = Lexing.from_string s in
-	try 
+	try
 	  while true do
 	    let b,e,o =
 	      if !starting then next_starting_order lb
 	      else next_interior_order lb in
-	    
+
 	    let b,e = convert_pos b,convert_pos e in
 	    let start = input_buffer#get_iter_at_char (offset + b) in
 	    let stop = input_buffer#get_iter_at_char (offset + e) in
-	    input_buffer#apply_tag_by_name ~start ~stop o 
+	    input_buffer#apply_tag ~start ~stop o
 	  done
 	with End_of_file -> ()
       end
@@ -181,22 +193,22 @@ and comment = parse
     end
 
   let highlight_current_line input_buffer =
-    try 
+    try
       let i = get_insert input_buffer in
       highlight_slice input_buffer (i#set_line_offset 0) i
     with _ -> ()
 
-  let highlight_around_current_line input_buffer = 
-    try 
+  let highlight_around_current_line input_buffer =
+    try
       let i = get_insert input_buffer in
-      highlight_slice input_buffer 
-	(i#backward_lines 10) 
+      highlight_slice input_buffer
+	(i#backward_lines 10)
 	(ignore (i#nocopy#forward_lines 10);i)
 
     with _ -> ()
-      
-  let highlight_all input_buffer = 
-  try 
+
+  let highlight_all input_buffer =
+  try
     highlight_slice input_buffer input_buffer#start_iter input_buffer#end_iter
   with _ -> ()
 
diff --git a/ide/ide.mllib b/ide/ide.mllib
new file mode 100644
index 00000000..63935db3
--- /dev/null
+++ b/ide/ide.mllib
@@ -0,0 +1,23 @@
+Okey
+Config_file
+Configwin_keys
+Configwin_types
+Configwin_messages
+Configwin_ihm
+Configwin
+Editable_cells
+Config_parser
+Tags
+Typed_notebook
+Config_lexer
+Utf8_convert
+Preferences
+Ideutils
+Coq_lex
+Gtk_parsing
+Undo
+Coq
+Coq_commands
+Coq_tactics
+Command_windows
+Coqide
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index d9b5e572..14e80389 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ideutils.ml 11749 2009-01-05 14:01:04Z notin $ *)
+(* $Id$ *)
 
 
 open Preferences
@@ -15,15 +15,21 @@ exception Forbidden
 
 (* status bar and locations *)
 
-let status = ref None
-let push_info = ref (function s -> failwith "not ready")
-let pop_info = ref (function s -> failwith "not ready")
-let flash_info = ref  (fun ?delay s -> failwith "not ready")
+let status = GMisc.statusbar ()
+
+let push_info,pop_info =
+  let status_context = status#new_context "Messages" in
+    (fun s -> ignore (status_context#push s)),status_context#pop
+
+let flash_info =
+  let flash_context = status#new_context "Flash" in
+    (fun ?(delay=5000) s -> flash_context#flash ~delay s)
 
-let set_location = ref  (function s -> failwith "not ready")
 
-let pulse = ref (function () -> failwith "not ready")
 
+let set_location = ref  (function s -> failwith "not ready")
+
+let pbar = GRange.progress_bar ~pulse_step:0.2 ()
 
 let debug = Flags.debug
 
@@ -35,12 +41,12 @@ let prerr_string s =
 let lib_ide_file f =
   let coqlib = Envars.coqlib () in
   Filename.concat (Filename.concat coqlib "ide") f
-  
+
 let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT
 
 let is_char_start c = let code = Char.code c in code < 0x80 || code >= 0xc0
 
-let byte_offset_to_char_offset s byte_offset = 
+let byte_offset_to_char_offset s byte_offset =
   if (byte_offset < String.length s) then begin
     let count_delta = ref 0 in
     for i = 0 to byte_offset do
@@ -62,19 +68,19 @@ let print_id id =
   prerr_endline ("GOT sig id :"^(string_of_int (Obj.magic id)))
 
 
-let do_convert s = 
+let do_convert s =
   Utf8_convert.f
     (if Glib.Utf8.validate s then begin
        prerr_endline "Input is UTF-8";s
      end else
-       let from_loc () = 
+       let from_loc () =
 	 let _,char_set = Glib.Convert.get_charset () in
-	 !flash_info
+	 flash_info
 	   ("Converting from locale ("^char_set^")");
 	 Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
        in
-       let from_manual () = 
-	 !flash_info 
+       let from_manual () =
+	 flash_info
 	   ("Converting from "^ !current.encoding_manual);
 	 Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual
        in
@@ -84,30 +90,30 @@ let do_convert s =
 	 with _ -> from_manual ()
        end else begin
 	 try
-	   from_manual () 
+	   from_manual ()
 	 with _ -> from_loc ()
        end)
 
-let try_convert s = 
+let try_convert s =
   try
     do_convert s
-  with _ -> 
+  with _ ->
     "(* Fatal error: wrong encoding in input.
 Please choose a correct encoding in the preference panel.*)";;
 
 
-let try_export file_name s = 
-  try let s = 
+let try_export file_name s =
+  try let s =
     try if !current.encoding_use_utf8 then begin
       (prerr_endline "UTF-8 is enforced" ;s)
     end else if !current.encoding_use_locale then begin
       let is_unicode,char_set = Glib.Convert.get_charset () in
-      if is_unicode then 
-	(prerr_endline "Locale is UTF-8" ;s)	
+      if is_unicode then
+	(prerr_endline "Locale is UTF-8" ;s)
       else
 	(prerr_endline ("Locale is "^char_set);
 	 Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
-    end else 	
+    end else
       (prerr_endline ("Manual charset is "^ !current.encoding_manual);
        Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s)
     with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s)
@@ -131,16 +137,16 @@ let disconnect_auto_save_timer () = match !auto_save_timer with
   | Some id -> GMain.Timeout.remove id; auto_save_timer := None
 
 let highlight_timer = ref None
-let set_highlight_timer f = 
-  match !highlight_timer with 
-    | None -> 
-	revert_timer := 
-      Some (GMain.Timeout.add ~ms:2000 
+let set_highlight_timer f =
+  match !highlight_timer with
+    | None ->
+	revert_timer :=
+      Some (GMain.Timeout.add ~ms:2000
 	      ~callback:(fun () -> f (); highlight_timer := None; true))
-    | Some id -> 
+    | Some id ->
 	GMain.Timeout.remove id;
-	revert_timer := 
-	Some (GMain.Timeout.add ~ms:2000 
+	revert_timer :=
+	Some (GMain.Timeout.add ~ms:2000
 		~callback:(fun () -> f (); highlight_timer := None; true))
 
 
@@ -150,31 +156,31 @@ let init_stdout,read_stdout,clear_stdout =
   let out_ft = Format.formatter_of_buffer out_buff in
   let deep_out_ft = Format.formatter_of_buffer out_buff in
   let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
-  (fun () -> 
+  (fun () ->
     Pp_control.std_ft := out_ft;
     Pp_control.err_ft := out_ft;
     Pp_control.deep_ft := deep_out_ft;
 ),
-  (fun () -> Format.pp_print_flush out_ft (); 
+  (fun () -> Format.pp_print_flush out_ft ();
      let r = Buffer.contents out_buff in
      prerr_endline "Output from Coq is: "; prerr_endline r;
      Buffer.clear out_buff; r),
-  (fun () -> 
+  (fun () ->
      Format.pp_print_flush out_ft (); Buffer.clear out_buff)
 
 
 let last_dir = ref ""
 
-let filter_all_files () = GFile.filter 
-  ~name:"All" 
-  ~patterns:["*"] () 
-  
-let filter_coq_files () =  GFile.filter 
-  ~name:"Coq source code" 
+let filter_all_files () = GFile.filter
+  ~name:"All"
+  ~patterns:["*"] ()
+
+let filter_coq_files () =  GFile.filter
+  ~name:"Coq source code"
   ~patterns:[ "*.v"] ()
 
 let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () =
-  let file = ref None in 
+  let file = ref None in
   let file_chooser = GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () in
     file_chooser#add_button_stock `CANCEL `CANCEL ;
     file_chooser#add_select_button_stock `OPEN `OPEN ;
@@ -183,8 +189,8 @@ let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () =
     file_chooser#set_default_response `OPEN;
     ignore (file_chooser#set_current_folder !dir);
     begin match file_chooser#run () with
-      | `OPEN -> 
-	  begin 
+      | `OPEN ->
+	  begin
 	    file := file_chooser#filename;
 	    match !file with
 		None -> ()
@@ -192,27 +198,27 @@ let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () =
 	  end
       | `DELETE_EVENT | `CANCEL -> ()
     end ;
-    file_chooser#destroy ();	    
+    file_chooser#destroy ();
     !file
 
 
 let select_file_for_save ~title ?(dir = last_dir) ?(filename="") () =
-  let file = ref None in 
+  let file = ref None in
   let file_chooser = GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () in
     file_chooser#add_button_stock `CANCEL `CANCEL ;
     file_chooser#add_select_button_stock `SAVE `SAVE ;
     file_chooser#add_filter (filter_coq_files ());
     file_chooser#add_filter (filter_all_files ());
-  (* this line will be used when a lablgtk >= 2.10.0 is the default on most distributions  
+  (* this line will be used when a lablgtk >= 2.10.0 is the default on most distributions
        file_chooser#set_do_overwrite_confirmation true;
      *)
     file_chooser#set_default_response `SAVE;
     ignore (file_chooser#set_current_folder !dir);
     ignore (file_chooser#set_current_name filename);
-    
+
     begin match file_chooser#run () with
-      | `SAVE -> 
-	  begin 
+      | `SAVE ->
+	  begin
 	    file := file_chooser#filename;
 	    match !file with
 		None -> ()
@@ -220,7 +226,7 @@ let select_file_for_save ~title ?(dir = last_dir) ?(filename="") () =
 	  end
       | `DELETE_EVENT | `CANCEL -> ()
     end ;
-    file_chooser#destroy ();	    
+    file_chooser#destroy ();
     !file
 
 let find_tag_start (tag :GText.tag) (it:GText.iter) =
@@ -237,7 +243,7 @@ let find_tag_stop (tag :GText.tag) (it:GText.iter) =
     ()
   done;
   it
-let find_tag_limits (tag :GText.tag) (it:GText.iter) = 
+let find_tag_limits (tag :GText.tag) (it:GText.iter) =
  (find_tag_start tag it , find_tag_stop tag it)
 
 (* explanations: Win32 threads won't work if events are produced
@@ -245,16 +251,16 @@ let find_tag_limits (tag :GText.tag) (it:GText.iter) =
    case we must use GtkThread.async to push a callback in the
    main thread. Beware that the synchronus version may produce
    deadlocks. *)
-let async = 
+let async =
   if Sys.os_type = "Win32" then GtkThread.async else (fun x -> x)
-let sync = 
+let sync =
   if Sys.os_type = "Win32" then GtkThread.sync else (fun x -> x)
 
 let mutex text f =
   let m = Mutex.create() in
   fun x ->
     if Mutex.try_lock m
-    then 
+    then
       (try
         prerr_endline ("Got lock on "^text);
         f x;
@@ -269,8 +275,8 @@ let mutex text f =
         ("Discarded call for "^text^": computations ongoing")
 
 
-let stock_to_widget ?(size=`DIALOG) s = 
-  let img = GMisc.image () 
+let stock_to_widget ?(size=`DIALOG) s =
+  let img = GMisc.image ()
   in img#set_stock s;
   img#coerce
 
@@ -290,12 +296,12 @@ let run_command f c =
   let ne = ref 0 in
   while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0
   do
-    let r = try_convert (String.sub buff 0 !n) in 
+    let r = try_convert (String.sub buff 0 !n) in
     f r;
     Buffer.add_string result r;
-    let r = try_convert (String.sub buffe 0 !ne) in 
+    let r = try_convert (String.sub buffe 0 !ne) in
     f r;
-    Buffer.add_string result r 
+    Buffer.add_string result r
   done;
   (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
 
@@ -306,46 +312,60 @@ let browse f url =
     f ("Could not execute\n\""^com^
        "\"\ncheck your preferences for setting a valid browser command\n")
 
+let doc_url () =
+  if !current.doc_url = use_default_doc_url || !current.doc_url = "" then
+    if Sys.file_exists
+      (String.sub Coq_config.localwwwrefman 7
+	(String.length Coq_config.localwwwrefman - 7))
+    then
+      Coq_config.localwwwrefman
+    else
+      Coq_config.wwwrefman
+  else !current.doc_url
+
 let url_for_keyword =
   let ht = Hashtbl.create 97 in
+  lazy (
   begin try
-    let cin = open_in (lib_ide_file "index_urls.txt") in
+    let cin =
+      try open_in (lib_ide_file "index_urls.txt")
+      with _ ->
+	let doc_url = doc_url () in
+	let n = String.length doc_url in
+	if n > 8 && String.sub doc_url 0 7 = "file://" then
+	  open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt")
+	else
+	  raise Exit
+    in
     try while true do
       let s = input_line cin in
-      try 
+      try
 	let i = String.index s ',' in
 	let k = String.sub s 0 i in
 	let u = String.sub s (i + 1) (String.length s - i - 1) in
 	Hashtbl.add ht k u
       with _ ->
-	()
+	Printf.eprintf "Warning: Cannot parse documentation index file.\n";
+	flush stderr
     done with End_of_file ->
       close_in cin
   with _ ->
-    ()
+    Printf.eprintf "Warning: Cannot find documentation index file.\n";
+    flush stderr
   end;
-  (Hashtbl.find ht : string -> string)
+  Hashtbl.find ht : string -> string)
 
 
-let browse_keyword f text = 
-  try let u = url_for_keyword text in browse f (!current.doc_url ^ u) 
-  with Not_found -> f ("No documentation found for "^text)
-
-
-let underscore = Glib.Utf8.to_unichar "_" (ref 0)
-
-let arobase = Glib.Utf8.to_unichar "@" (ref 0)
-let prime = Glib.Utf8.to_unichar "'" (ref 0)
-let bn = Glib.Utf8.to_unichar "\n" (ref 0)
-let space = Glib.Utf8.to_unichar " " (ref 0)
-let tab = Glib.Utf8.to_unichar "\t" (ref 0)
+let browse_keyword f text =
+  try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u)
+  with Not_found -> f ("No documentation found for \""^text^"\".\n")
 
 
 (*
   checks if two file names refer to the same (existing) file by
-  comparing their device and inode. 
+  comparing their device and inode.
   It seems that under Windows, inode is always 0, so we cannot
-  accurately check if 
+  accurately check if
 
 *)
 (* Optimised for partial application (in case many candidates must be
@@ -357,7 +377,7 @@ let same_file f1 =
       try
         let s2 = Unix.stat f2 in
         s1.Unix.st_dev = s2.Unix.st_dev &&
-          if Sys.os_type = "Win32" then f1 = f2 
+          if Sys.os_type = "Win32" then f1 = f2
           else s1.Unix.st_ino = s2.Unix.st_ino
       with
           Unix.Unix_error _ -> false)
@@ -365,7 +385,7 @@ let same_file f1 =
       Unix.Unix_error _ -> (fun _ -> false)
 
 let absolute_filename f =
-  if Filename.is_relative f then 
+  if Filename.is_relative f then
     Filename.concat (Sys.getcwd ()) f
   else f
-	      
+
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index 48ff0fca..fbd5af44 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ideutils.mli 11006 2008-05-28 10:42:45Z jnarboux $ i*)
+(*i $Id$ i*)
 
 val async : ('a -> unit) -> 'a -> unit
 val sync  : ('a -> 'b) -> 'a -> 'b
@@ -14,6 +14,7 @@ val sync  : ('a -> 'b) -> 'a -> 'b
 (* avoid running two instances of a function concurrently *)
 val mutex : string -> ('a -> unit) -> 'a -> unit
 
+val doc_url : unit -> string
 val browse : (string -> unit) -> string -> unit
 val browse_keyword : (string -> unit) -> string -> unit
 val byte_offset_to_char_offset : string -> int -> int
@@ -57,22 +58,15 @@ val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
 val run_command : (string -> unit) -> string -> Unix.process_status*string
 
 
-val prime : Glib.unichar
-val underscore : Glib.unichar
-val arobase : Glib.unichar
-val bn : Glib.unichar
-val space : Glib.unichar
-val tab : Glib.unichar
 
-
-val status : GMisc.statusbar option ref 
-val push_info : (string -> unit) ref
-val pop_info : (unit -> unit) ref
-val flash_info : (?delay:int -> string -> unit) ref
+val status : GMisc.statusbar
+val push_info : string -> unit
+val pop_info : unit -> unit
+val flash_info : ?delay:int -> string -> unit
 
 val set_location : (string -> unit) ref
 
-val pulse : (unit -> unit) ref
+val pbar : GRange.progress_bar
 
 
 (*
diff --git a/ide/preferences.ml b/ide/preferences.ml
index ffb346d9..4e87d1df 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: preferences.ml 12104 2009-04-24 18:10:10Z notin $ *)
+(* $Id$ *)
 
 open Configwin
 open Printf
@@ -16,7 +16,7 @@ let pref_file = Filename.concat System.home ".coqiderc"
 
 let accel_file = Filename.concat System.home ".coqide.keys"
 
-let mod_to_str (m:Gdk.Tags.modifier) = 
+let mod_to_str (m:Gdk.Tags.modifier) =
   match m with
     | `MOD1 -> "MOD1"
     | `MOD2 -> "MOD2"
@@ -34,19 +34,19 @@ let mod_to_str (m:Gdk.Tags.modifier) =
 
 let (str_to_mod:string -> Gdk.Tags.modifier) =
   function
-    | "MOD1" -> `MOD1 
-    | "MOD2" -> `MOD2 
-    | "MOD3" -> `MOD3 
-    | "MOD4" -> `MOD4 
-    | "MOD5" -> `MOD5 
-    | "BUTTON1" -> `BUTTON1 
-    | "BUTTON2" -> `BUTTON2 
-    | "BUTTON3" -> `BUTTON3 
-    | "BUTTON4" -> `BUTTON4 
-    | "BUTTON5" -> `BUTTON5 
-    | "CONTROL" -> `CONTROL 
-    | "LOCK" -> `LOCK 
-    | "SHIFT" -> `SHIFT 
+    | "MOD1" -> `MOD1
+    | "MOD2" -> `MOD2
+    | "MOD3" -> `MOD3
+    | "MOD4" -> `MOD4
+    | "MOD5" -> `MOD5
+    | "BUTTON1" -> `BUTTON1
+    | "BUTTON2" -> `BUTTON2
+    | "BUTTON3" -> `BUTTON3
+    | "BUTTON4" -> `BUTTON4
+    | "BUTTON5" -> `BUTTON5
+    | "CONTROL" -> `CONTROL
+    | "LOCK" -> `LOCK
+    | "SHIFT" -> `SHIFT
     | s -> `MOD1
 
 type pref =
@@ -100,7 +100,9 @@ type pref =
       mutable opposite_tabs : bool;
 }
 
-let (current:pref ref) = 
+let use_default_doc_url = "(automatic)"
+
+let (current:pref ref) =
   ref {
     cmd_coqc = "coqc";
     cmd_make = "make";
@@ -110,38 +112,38 @@ let (current:pref ref) =
 
     global_auto_revert = false;
     global_auto_revert_delay = 10000;
-    
+
     auto_save = true;
     auto_save_delay = 10000;
     auto_save_name = "#","#";
-    
+
     encoding_use_locale = true;
     encoding_use_utf8 = false;
     encoding_manual = "ISO_8859-1";
 
     automatic_tactics = ["trivial"; "tauto"; "auto"; "omega";
 			 "auto with *"; "intuition" ];
-    
+
     modifier_for_navigation = [`CONTROL; `MOD1];
     modifier_for_templates = [`CONTROL; `SHIFT];
     modifier_for_tactics = [`CONTROL; `MOD1];
     modifier_for_display = [`MOD1;`SHIFT];
     modifiers_valid = [`SHIFT; `CONTROL; `MOD1];
 
-    
+
     cmd_browse = Flags.browser_cmd_fmt;
     cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s";
-    
+
 (*    text_font = Pango.Font.from_string "sans 12";*)
     text_font = Pango.Font.from_string "Monospace 10";
 
     doc_url = Coq_config.wwwrefman;
     library_url = Coq_config.wwwstdlib;
-    
+
     show_toolbar = true;
     contextual_menus_on_goal = true;
     window_width = 800;
-    window_height = 600; 
+    window_height = 600;
     query_window_width = 600;
     query_window_height = 400;
 (*
@@ -166,10 +168,10 @@ let contextual_menus_on_goal = ref (fun x -> ())
 let resize_window = ref (fun () -> ())
 
 let save_pref () =
-  (try GtkData.AccelMap.save accel_file 
+  (try GtkData.AccelMap.save accel_file
   with _ -> ());
   let p = !current in
-  try 
+  try
     let add = Stringmap.add in
     let (++) x f = f x in
     Stringmap.empty ++
@@ -178,7 +180,7 @@ let save_pref () =
     add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
     add "cmd_coqdoc" [p.cmd_coqdoc] ++
     add "global_auto_revert" [string_of_bool p.global_auto_revert] ++
-    add "global_auto_revert_delay" 
+    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] ++
@@ -190,15 +192,15 @@ let save_pref () =
 
     add "automatic_tactics" p.automatic_tactics ++
     add "cmd_print" [p.cmd_print] ++
-    add "modifier_for_navigation" 
+    add "modifier_for_navigation"
       (List.map mod_to_str p.modifier_for_navigation) ++
-    add "modifier_for_templates" 
+    add "modifier_for_templates"
       (List.map mod_to_str p.modifier_for_templates) ++
-    add "modifier_for_tactics" 
+    add "modifier_for_tactics"
       (List.map mod_to_str p.modifier_for_tactics) ++
-    add "modifier_for_display" 
+    add "modifier_for_display"
       (List.map mod_to_str p.modifier_for_display) ++
-    add "modifiers_valid" 
+    add "modifiers_valid"
       (List.map mod_to_str p.modifiers_valid) ++
     add "cmd_browse" [p.cmd_browse] ++
     add "cmd_editor" [p.cmd_editor] ++
@@ -208,7 +210,7 @@ let save_pref () =
     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" 
+    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] ++
@@ -221,12 +223,11 @@ let save_pref () =
     add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
     Config_lexer.print_file pref_file
   with _ -> prerr_endline "Could not save preferences."
- 
 
 let load_pref () =
   (try GtkData.AccelMap.load accel_file with _ -> ());
-  let p = !current in 
-  try 
+  let p = !current in
+  try
     let m = Config_lexer.load_file pref_file in
     let np = { p with cmd_coqc = p.cmd_coqc } in
     let set k f = try let v = Stringmap.find k m in f v with _ -> () in
@@ -234,7 +235,7 @@ let load_pref () =
     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 = 
+    let set_command_with_pair_compat k f =
       set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit)
     in
     set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
@@ -242,7 +243,7 @@ let load_pref () =
     set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
     set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v);
     set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v);
-    set_int "global_auto_revert_delay" 
+    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);
@@ -253,23 +254,26 @@ let load_pref () =
     set "automatic_tactics"
       (fun v -> np.automatic_tactics <- v);
     set_hd "cmd_print" (fun v -> np.cmd_print <- v);
-    set "modifier_for_navigation" 
+    set "modifier_for_navigation"
       (fun v -> np.modifier_for_navigation <- List.map str_to_mod v);
-    set "modifier_for_templates" 
+    set "modifier_for_templates"
       (fun v -> np.modifier_for_templates <- List.map str_to_mod v);
-    set "modifier_for_tactics" 
+    set "modifier_for_tactics"
       (fun v -> np.modifier_for_tactics <- List.map str_to_mod v);
-    set "modifier_for_display" 
+    set "modifier_for_display"
       (fun v -> np.modifier_for_display <- List.map str_to_mod v);
-    set "modifiers_valid" 
+    set "modifiers_valid"
       (fun v -> np.modifiers_valid <- List.map str_to_mod 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 -> np.doc_url <- v);
+    set_hd "doc_url" (fun v ->
+      if not (Flags.is_standard_doc_url v) && v <> use_default_doc_url then
+	prerr_endline ("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" 
+    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);
@@ -284,38 +288,38 @@ let load_pref () =
 (*
     Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
-  with e -> 
+  with e ->
     prerr_endline ("Could not load preferences ("^
 		   (Printexc.to_string e)^").")
-    
+
 let split_string_format s =
-  try 
+  try
     let i = Util.string_index_from s 0 "%s" in
     let pre = (String.sub s 0 i) in
     let post = String.sub s (i+2) (String.length s - i - 2) in
     pre,post
   with Not_found -> s,""
 
-let configure ?(apply=(fun () -> ())) () = 
-  let cmd_coqc = 
+let configure ?(apply=(fun () -> ())) () =
+  let cmd_coqc =
     string
-      ~f:(fun s -> !current.cmd_coqc <- s) 
+      ~f:(fun s -> !current.cmd_coqc <- s)
       "       coqc"  !current.cmd_coqc in
-  let cmd_make = 
-    string 
+  let cmd_make =
+    string
       ~f:(fun s -> !current.cmd_make <- s)
       "       make" !current.cmd_make in
-  let cmd_coqmakefile = 
-    string 
+  let cmd_coqmakefile =
+    string
       ~f:(fun s -> !current.cmd_coqmakefile <- s)
       "coqmakefile" !current.cmd_coqmakefile in
-  let cmd_coqdoc = 
-    string 
+  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) 
+  let cmd_print =
+    string
+      ~f:(fun s -> !current.cmd_print <- s)
       "   Print ps" !current.cmd_print in
 
   let config_font =
@@ -324,15 +328,15 @@ let configure ?(apply=(fun () -> ())) () =
     w#set_preview_text
       "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
     box#pack w#coerce;
-    ignore (w#misc#connect#realize 
-	      ~callback:(fun () -> w#set_font_name 
+    ignore (w#misc#connect#realize
+	      ~callback:(fun () -> w#set_font_name
 			   (Pango.Font.to_string !current.text_font)));
     custom
       ~label:"Fonts for text"
       box
-      (fun () -> 
+      (fun () ->
 	 let fd =  w#font_name in
-	 !current.text_font <- (Pango.Font.from_string fd) ; 
+	 !current.text_font <- (Pango.Font.from_string fd) ;
 (*
 	 Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
@@ -340,80 +344,80 @@ let configure ?(apply=(fun () -> ())) () =
       true
   in
 (*
-  let show_toolbar = 
-    bool 
-      ~f:(fun s -> 
-	    !current.show_toolbar <- s; 
-	    !show_toolbar s) 
+  let show_toolbar =
+    bool
+      ~f:(fun s ->
+	    !current.show_toolbar <- s;
+	    !show_toolbar s)
       "Show toolbar" !current.show_toolbar
   in
   let window_height =
     string
     ~f:(fun s -> !current.window_height <- (try int_of_string s with _ -> 600);
 	  !resize_window ();
-       ) 
-      "Window height" 
+       )
+      "Window height"
       (string_of_int !current.window_height)
-  in  
+  in
   let window_width =
     string
-    ~f:(fun s -> !current.window_width <- 
-	  (try int_of_string s with _ -> 800)) 
-      "Window width" 
+    ~f:(fun s -> !current.window_width <-
+	  (try int_of_string s with _ -> 800))
+      "Window width"
       (string_of_int !current.window_width)
-  in  
+  in
 *)
-  let auto_complete = 
-    bool 
-      ~f:(fun s -> 
-	    !current.auto_complete <- s; 
-	    !auto_complete s) 
+  let auto_complete =
+    bool
+      ~f:(fun s ->
+	    !current.auto_complete <- s;
+	    !auto_complete s)
       "Auto Complete" !current.auto_complete
   in
 
-(*  let use_utf8_notation = 
-    bool 
-      ~f:(fun b -> 
+(*  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) 
+  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_delay =
     string
-    ~f:(fun s -> !current.global_auto_revert_delay <- 
-	  (try int_of_string s with _ -> 10000)) 
-      "Global auto revert delay (ms)" 
+    ~f:(fun s -> !current.global_auto_revert_delay <-
+	  (try int_of_string s with _ -> 10000))
+      "Global auto revert delay (ms)"
       (string_of_int !current.global_auto_revert_delay)
-  in  
+  in
 
-  let auto_save = 
-    bool 
-      ~f:(fun s -> !current.auto_save <- s) 
+  let auto_save =
+    bool
+      ~f:(fun s -> !current.auto_save <- s)
       "Enable auto save" !current.auto_save
   in
   let auto_save_delay =
     string
-    ~f:(fun s -> !current.auto_save_delay <- 
-	  (try int_of_string s with _ -> 10000)) 
-      "Auto save delay (ms)" 
+    ~f:(fun s -> !current.auto_save_delay <-
+	  (try int_of_string s with _ -> 10000))
+      "Auto save delay (ms)"
       (string_of_int !current.auto_save_delay)
-  in  
+  in
 
   let stop_before =
     bool
       ~f:(fun s -> !current.stop_before <- s)
       "Stop interpreting before the current point" !current.stop_before
   in
-    
+
   let lax_syntax =
     bool
       ~f:(fun s -> !current.lax_syntax <- s)
@@ -432,31 +436,31 @@ let configure ?(apply=(fun () -> ())) () =
       "Tabs on opposite side" !current.opposite_tabs
   in
 
-  let encodings = 
-    combo 
+  let encodings =
+    combo
       "File charset encoding "
-      ~f:(fun s -> 
+      ~f:(fun s ->
 	    match s with
-	    | "UTF-8" -> 
+	    | "UTF-8" ->
 		!current.encoding_use_utf8 <- true;
 		!current.encoding_use_locale <- false
 	    | "LOCALE" ->
 		!current.encoding_use_utf8 <- false;
 		!current.encoding_use_locale <- true
-	    | _ -> 		
+	    | _ ->
 		!current.encoding_use_utf8 <- false;
 		!current.encoding_use_locale <- false;
 		!current.encoding_manual <- s;
 	 )
       ~new_allowed: true
       ["UTF-8";"LOCALE";!current.encoding_manual]
-      (if !current.encoding_use_utf8 then "UTF-8" 
+      (if !current.encoding_use_utf8 then "UTF-8"
        else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual)
   in
-  let help_string = 
-    "Press a set of modifiers and an extra key together (needs then a restart to apply!)"
+  let help_string =
+    "restart to apply"
   in
-  let modifier_for_tactics = 
+  let modifier_for_tactics =
     modifiers
       ~allow:!current.modifiers_valid
       ~f:(fun l -> !current.modifier_for_tactics <- l)
@@ -464,7 +468,7 @@ let configure ?(apply=(fun () -> ())) () =
       "Modifiers for Tactics Menu"
       !current.modifier_for_tactics
   in
-  let modifier_for_templates = 
+  let modifier_for_templates =
     modifiers
       ~allow:!current.modifiers_valid
       ~f:(fun l -> !current.modifier_for_templates <- l)
@@ -472,7 +476,7 @@ let configure ?(apply=(fun () -> ())) () =
       "Modifiers for Templates Menu"
       !current.modifier_for_templates
   in
-  let modifier_for_navigation = 
+  let modifier_for_navigation =
     modifiers
       ~allow:!current.modifiers_valid
       ~f:(fun l -> !current.modifier_for_navigation <- l)
@@ -480,7 +484,7 @@ let configure ?(apply=(fun () -> ())) () =
       "Modifiers for Navigation Menu"
       !current.modifier_for_navigation
   in
-  let modifier_for_display = 
+  let modifier_for_display =
     modifiers
       ~allow:!current.modifiers_valid
       ~f:(fun l -> !current.modifier_for_display <- l)
@@ -488,23 +492,23 @@ let configure ?(apply=(fun () -> ())) () =
       "Modifiers for Display Menu"
       !current.modifier_for_display
   in
-  let modifiers_valid = 
+  let modifiers_valid =
     modifiers
       ~f:(fun l -> !current.modifiers_valid <- l)
       "Allowed modifiers"
       !current.modifiers_valid
   in
-  let cmd_editor = 
+  let cmd_editor =
     let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in
     combo
-      ~help:"(%s for file name)" 
+      ~help:"(%s for file name)"
       "External editor"
       ~f:(fun s -> !current.cmd_editor <- s)
       ~new_allowed: true
       (predefined@[if List.mem !current.cmd_editor predefined then ""
                    else !current.cmd_editor])
       !current.cmd_editor
-  in    
+  in
   let cmd_browse =
     let predefined = [
       Coq_config.browser;
@@ -514,40 +518,57 @@ let configure ?(apply=(fun () -> ())) () =
       "seamonkey -remote \"openURL(%s)\" || seamonkey %s &";
       "open -a Safari %s &"
     ] in
-    combo 
-      ~help:"(%s for url)" 
+    combo
+      ~help:"(%s for url)"
       "Browser"
       ~f:(fun s -> !current.cmd_browse <- s)
       ~new_allowed: true
       (predefined@[if List.mem !current.cmd_browse predefined then ""
                    else !current.cmd_browse])
       !current.cmd_browse
-  in    
-  let doc_url = 
-    string ~f:(fun s -> !current.doc_url <- s) " Manual URL"  !current.doc_url in
-  let library_url = 
-    string ~f:(fun s -> !current.library_url <- s) "Library URL"  !current.library_url in
-
-  let automatic_tactics = 
+  in
+  let doc_url =
+    let predefined = [
+      use_default_doc_url
+    ] in
+    combo
+      "Manual URL"
+      ~f:(fun s -> !current.doc_url <- s)
+      ~new_allowed: true
+      (predefined@[if List.mem !current.doc_url predefined then ""
+                   else !current.doc_url])
+      !current.doc_url in
+  let library_url =
+    let predefined = [
+      Coq_config.wwwstdlib
+    ] in
+    combo
+      "Library URL"
+      ~f:(fun s -> !current.library_url <- s)
+      (predefined@[if List.mem !current.library_url predefined then ""
+                   else !current.library_url])
+      !current.library_url
+  in
+  let automatic_tactics =
     strings
-      ~f:(fun l -> !current.automatic_tactics <- l) 
+      ~f:(fun l -> !current.automatic_tactics <- l)
       ~add:(fun () -> ["<edit me>"])
-      "Wizard tactics to try in order" 
+      "Wizard tactics to try in order"
       !current.automatic_tactics
 
   in
 
   let contextual_menus_on_goal =
-    bool 
-      ~f:(fun s -> 
-	    !current.contextual_menus_on_goal <- s; 
-	    !contextual_menus_on_goal s) 
+    bool
+      ~f:(fun s ->
+	    !current.contextual_menus_on_goal <- s;
+	    !contextual_menus_on_goal s)
       "Contextual menus on goal" !current.contextual_menus_on_goal
-  in 
+  in
 
   let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax;
               vertical_tabs;opposite_tabs] in
-   
+
 (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
    (shame on Benjamin) *)
   let cmds =
@@ -557,7 +578,7 @@ let configure ?(apply=(fun () -> ())) () =
 	     [global_auto_revert;global_auto_revert_delay;
 	      auto_save; auto_save_delay; (* auto_save_name*)
 	      encodings;
-	     ]);     
+	     ]);
 (*
      Section("Appearance",
 	     config_appearance);
@@ -581,6 +602,6 @@ let configure ?(apply=(fun () -> ())) () =
 (*
   Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
-  match x with 
+  match x with
     | Return_apply | Return_ok -> save_pref ()
     | Return_cancel -> ()
diff --git a/ide/preferences.mli b/ide/preferences.mli
index d7f32380..6ee7918f 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: preferences.mli 11009 2008-05-28 13:58:33Z jnarboux $ i*)
+(*i $Id$ i*)
 
 type pref =
     {
@@ -70,3 +70,5 @@ val change_font : ( Pango.font_description -> unit) ref
 val show_toolbar : (bool -> unit) ref
 val auto_complete : (bool -> unit) ref
 val resize_window : (unit -> unit) ref
+
+val use_default_doc_url : string
diff --git a/ide/tags.ml b/ide/tags.ml
new file mode 100644
index 00000000..e78f5c82
--- /dev/null
+++ b/ide/tags.ml
@@ -0,0 +1,50 @@
+
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+
+let make_tag (tt:GText.tag_table) ~name prop =
+  let new_tag = GText.tag ~name () in
+  new_tag#set_properties prop;
+  tt#add new_tag#as_tag;
+  new_tag
+
+module Script =
+struct
+  let table = GText.tag_table ()
+  let kwd = make_tag table ~name:"kwd" [`FOREGROUND "blue"]
+  let qed = make_tag table ~name:"qed" [`FOREGROUND "blue"]
+  let decl = make_tag table ~name:"decl" [`FOREGROUND "orange red"]
+  let proof_decl = make_tag table ~name:"proof_decl" [`FOREGROUND "orange red"]
+  let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"]
+  let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"]
+  let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"]
+  let to_process = make_tag table ~name:"to_process" [`BACKGROUND "light blue" ;`EDITABLE false]
+  let processed = make_tag table ~name:"processed" [`BACKGROUND "light green" ;`EDITABLE false]
+  let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false]
+  let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"]
+  let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false]
+  let folded = make_tag table ~name:"locked" [`EDITABLE false; `BACKGROUND "light grey"]
+  let paren = make_tag table ~name:"paren" [`BACKGROUND "purple"]
+  let lax_end = make_tag table ~name:"sentence_end" []
+end
+module Proof =
+struct
+  let table = GText.tag_table ()
+  let highlight = make_tag table ~name:"highlight" [`BACKGROUND "light green"]
+  let hypothesis = make_tag table ~name:"hypothesis" []
+  let goal = make_tag table ~name:"goal" []
+end
+module Message =
+struct
+  let table = GText.tag_table ()
+  let error = make_tag table ~name:"error" [`FOREGROUND "red"]
+end
+
diff --git a/ide/typed_notebook.ml b/ide/typed_notebook.ml
new file mode 100644
index 00000000..39e8155d
--- /dev/null
+++ b/ide/typed_notebook.ml
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: coqide.ml 11952 2009-03-02 15:29:08Z vgross $ *)
+
+class ['a] typed_notebook default_build nb =
+object(self)
+  inherit GPack.notebook nb as super
+  val mutable term_list = []
+
+  method append_term ?(build=default_build) (term:'a) =
+    let tab_label,menu_label,page = build term in
+      (* XXX - Temporary hack to compile with archaic lablgtk *)
+    ignore (super#append_page ?tab_label ?menu_label page);
+    let real_pos = super#page_num page in
+    let lower,higher = Util.list_split_at real_pos term_list in
+      term_list <- lower@[term]@higher;
+      real_pos
+(* XXX - Temporary hack to compile with archaic lablgtk
+  method insert_term ?(build=default_build) ?pos (term:'a) =
+    let tab_label,menu_label,page = build term in
+    let real_pos = super#insert_page ?tab_label ?menu_label ?pos page in
+    let lower,higher = Util.list_split_at real_pos term_list in
+      term_list <- lower@[term]@higher;
+      real_pos
+ *)
+  method prepend_term ?(build=default_build) (term:'a) =
+    let tab_label,menu_label,page = build term in
+      (* XXX - Temporary hack to compile with archaic lablgtk *)
+    ignore (super#prepend_page ?tab_label ?menu_label page);
+    let real_pos = super#page_num page in
+    let lower,higher = Util.list_split_at real_pos term_list in
+      term_list <- lower@[term]@higher;
+      real_pos
+
+  method set_term ?(build=default_build) (term:'a) =
+    let tab_label,menu_label,page = build term in
+    let real_pos = super#current_page in
+      term_list <- Util.list_map_i (fun i x -> if i = real_pos then term else x) 0 term_list;
+      super#set_page ?tab_label ?menu_label page
+
+  method remove_page index =
+    term_list <- Util.list_filter_i (fun i x -> i <> index) term_list;
+    super#remove_page index
+
+  method get_nth_term i =
+    List.nth term_list i
+
+  method term_num p =
+    Util.list_index0 p term_list
+
+  method pages = term_list
+
+  method current_term = List.nth term_list super#current_page
+end
+
+let create build =
+  GtkPack.Notebook.make_params []
+    ~cont:(GContainer.pack_container
+             ~create:(fun pl ->
+                        let nb = GtkPack.Notebook.create pl in
+                         (new typed_notebook build nb)))
+
diff --git a/ide/uim/coqide-custom.scm b/ide/uim/coqide-custom.scm
new file mode 100644
index 00000000..132bae7d
--- /dev/null
+++ b/ide/uim/coqide-custom.scm
@@ -0,0 +1,105 @@
+;;; coqide-custom.scm -- customization variables for coqide.scm
+;;;
+;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;;    may be used to endorse or promote products derived from this software
+;;;    without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+(require "i18n.scm")
+
+(define coqide-im-name-label (N_ "CoqIDE"))
+(define coqide-im-short-desc (N_ "Emacs-style Latin characters input"))
+(define coqide-im-long-desc (N_ "An input method for entering Latin letters used in European languages with the key translations adopted in Emacs."))
+
+(define-custom-group 'coqide
+  coqide-im-name-label
+  coqide-im-short-desc)
+
+(define-custom-group 'coqide-properties
+  (N_ "Properties")
+  (N_ "long description will be here."))
+
+(define-custom 'coqide-rules 'coqide-rules-latin-ltx
+  '(coqide coqide-properties)
+  (list 'choice
+	(list 'coqide-rules-british
+	      (N_ "British")
+	      (N_ "long description will be here."))
+	(list 'coqide-rules-english-dvorak
+	      (N_ "English Dvorak")
+	      (N_ "long description will be here."))
+	(list 'coqide-rules-latin-ltx
+	      (N_ "LaTeX style")
+	      (N_ "long description will be here.")))
+  (N_ "Latin characters keyboard layout")
+  (N_ "long description will be here."))
+
+(custom-add-hook 'coqide-rules
+		 'custom-set-hooks
+		 (lambda ()
+		   (map (lambda (lc)
+			  (let ((new-rkc (rk-context-new
+					  (symbol-value coqide-rules) #f #f)))
+			    (coqide-context-flush lc)
+			    (coqide-update-preedit lc)
+			    (coqide-context-set-rkc! lc new-rkc)))
+			coqide-context-list)))
+
+;; For VI users.
+(define-custom 'coqide-esc-turns-off? #f
+  '(coqide coqide-properties)
+  '(boolean)
+  (N_ "ESC turns off composition mode (for vi users)")
+  (N_ "long description will be here."))
+
+
+(define-custom-group 'coqide-keys
+  (N_ "CoqIDE key bindings")
+  (N_ "long description will be here."))
+
+(define-custom 'coqide-on-key '("<Control>\\")
+  '(coqide coqide-keys)
+  '(key)
+  (N_ "CoqIDE on")
+  (N_ "long description will be here"))
+
+(define-custom 'coqide-off-key '("<Control>\\")
+  '(coqide coqide-keys)
+  '(key)
+  (N_ "CoqIDE off")
+  (N_ "long description will be here"))
+
+(define-custom 'coqide-backspace-key '(generic-backspace-key)
+  '(coqide coqide-keys)
+  '(key)
+  (N_ "CoqIDE backspace")
+  (N_ "long description will be here"))
+
+;; Local Variables:
+;; mode: scheme
+;; coding: utf-8
+;; End:
diff --git a/ide/uim/coqide-rules.scm b/ide/uim/coqide-rules.scm
new file mode 100644
index 00000000..e41889c1
--- /dev/null
+++ b/ide/uim/coqide-rules.scm
@@ -0,0 +1,1223 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  v      ;   The Coq Proof Assistant  /  The Coq Development Team     ;;
+;; <O___,, ; CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud ;;
+;;   \VV/  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;    //   ;      This file is distributed under the terms of the       ;;
+;;         ;       GNU Lesser General Public License Version 2.1        ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; coqide-rules.scm -- key sequence tables for coqide.scm
+
+;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
+;;
+;; All rights reserved.
+
+;; The translation tables in this file were derived from
+;; the emacs-lisp source files latin-pre.el, latin-post.el, latin-alt.el
+;; included in GNU Emacs.  The following is the original copyright notice
+;; therein, with the name GNU Emacs replaced by "this program".
+
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;;   2006, 2007
+;;   Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;;   2006, 2007
+;;   National Institute of Advanced Industrial Science and Technology (AIST)
+;;   Registration Number H14PRO021
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Key translation maps were originally copied from iso-acc.el.
+;; latin-1-prefix: extra special characters added, adapted from the vim
+;;                 digraphs (from J.H.M.Dassen <jdassen@wi.leidenuniv.nl>)
+;;                 by R.F. Smith <rsmith@xs4all.nl>
+;;
+;; polish-slash:
+;; Author: WÅ‚odek Bzyl <matwb@univ.gda.pl>
+;; Maintainer: WÅ‚odek Bzyl <matwb@univ.gda.pl>
+;;
+;; latin-[89]-prefix: Dave Love <fx@gnu.org>
+
+(define coqide-rules-british '(
+((("#")) ("£" "#"))
+))
+
+(define coqide-rules-english-dvorak '(
+((("-")) ("["))
+((("=")) ("]"))
+((("`")) ("`"))
+((("q")) ("'"))
+((("w")) (","))
+((("e")) ("."))
+((("r")) ("p"))
+((("t")) ("y"))
+((("y")) ("f"))
+((("u")) ("g"))
+((("i")) ("c"))
+((("o")) ("r"))
+((("p")) ("l"))
+((("[")) ("/"))
+((("]")) ("="))
+((("a")) ("a"))
+((("s")) ("o"))
+((("d")) ("e"))
+((("f")) ("u"))
+((("g")) ("i"))
+((("h")) ("d"))
+((("j")) ("h"))
+((("k")) ("t"))
+((("l")) ("n"))
+(((";")) ("s"))
+((("'")) ("-"))
+((("\\")) ("\\"))
+((("z")) (";"))
+((("x")) ("q"))
+((("c")) ("j"))
+((("v")) ("k"))
+((("b")) ("x"))
+((("n")) ("b"))
+((("m")) ("m"))
+(((",")) ("w"))
+(((".")) ("v"))
+((("/")) ("z"))
+((("_")) ("{"))
+((("+")) ("}"))
+((("~")) ("~"))
+((("Q")) ("\""))
+((("W")) ("<"))
+((("E")) (">"))
+((("R")) ("P"))
+((("T")) ("Y"))
+((("Y")) ("F"))
+((("U")) ("G"))
+((("I")) ("C"))
+((("O")) ("R"))
+((("P")) ("L"))
+((("{")) ("?"))
+((("}")) ("+"))
+((("A")) ("A"))
+((("S")) ("O"))
+((("D")) ("E"))
+((("F")) ("U"))
+((("G")) ("I"))
+((("H")) ("D"))
+((("J")) ("H"))
+((("K")) ("T"))
+((("L")) ("N"))
+(((":")) ("S"))
+((("\"")) ("_"))
+((("|")) ("|"))
+((("Z")) (":"))
+((("X")) ("Q"))
+((("C")) ("J"))
+((("V")) ("K"))
+((("B")) ("X"))
+((("N")) ("B"))
+((("M")) ("M"))
+((("<")) ("W"))
+(((">")) ("V"))
+((("?")) ("Z"))
+))
+
+(define coqide-rules-latin-ltx '(
+((("!" "`")) ("¡"))
+((("\\" "p" "o" "u" "n" "d" "s")) ("£"))
+((("\\" "S")) ("§"))
+((("\\" "\"" "{" "}")) ("¨"))
+((("\\" "c" "o" "p" "y" "r" "i" "g" "h" "t")) ("©"))
+((("$" "^" "a" "$")) ("ª"))
+((("\\" "=" "{" "}")) ("¯"))
+((("$" "\\" "p" "m" "$")) ("±"))
+((("\\" "p" "m")) ("±"))
+((("$" "^" "2" "$")) ("²"))
+((("$" "^" "3" "$")) ("³"))
+((("\\" "'" "{" "}")) ("´"))
+((("\\" "P")) ("¶"))
+((("$" "\\" "c" "d" "o" "t" "$")) ("·"))
+((("\\" "c" "d" "o" "t")) ("·"))
+((("\\" "c" "{" "}")) ("¸"))
+((("$" "^" "1" "$")) ("¹"))
+((("$" "^" "o" "$")) ("º"))
+((("?" "`")) ("¿"))
+((("\\" "`" "{" "A" "}")) ("À"))
+((("\\" "`" "A")) ("À"))
+((("\\" "'" "{" "A" "}")) ("�"))
+((("\\" "'" "A")) ("�"))
+((("\\" "^" "{" "A" "}")) ("Â"))
+((("\\" "^" "A")) ("Â"))
+((("\\" "~" "{" "A" "}")) ("Ã"))
+((("\\" "~" "A")) ("Ã"))
+((("\\" "\"" "{" "A" "}")) ("Ä"))
+((("\\" "\"" "A")) ("Ä"))
+((("\\" "k" "{" "A" "}")) ("Ä„"))
+((("\\" "A" "A")) ("Ã…"))
+((("\\" "A" "E")) ("Æ"))
+((("\\" "c" "{" "C" "}")) ("Ç"))
+((("\\" "c" "C")) ("Ç"))
+((("\\" "`" "{" "E" "}")) ("È"))
+((("\\" "`" "E")) ("È"))
+((("\\" "'" "{" "E" "}")) ("É"))
+((("\\" "'" "E")) ("É"))
+((("\\" "^" "{" "E" "}")) ("Ê"))
+((("\\" "^" "E")) ("Ê"))
+((("\\" "\"" "{" "E" "}")) ("Ë"))
+((("\\" "\"" "E")) ("Ë"))
+((("\\" "k" "{" "E" "}")) ("Ę"))
+((("\\" "`" "{" "I" "}")) ("Ì"))
+((("\\" "`" "I")) ("Ì"))
+((("\\" "'" "{" "I" "}")) ("�"))
+((("\\" "'" "I")) ("�"))
+((("\\" "^" "{" "I" "}")) ("ÃŽ"))
+((("\\" "^" "I")) ("ÃŽ"))
+((("\\" "\"" "{" "I" "}")) ("�"))
+((("\\" "\"" "I")) ("�"))
+((("\\" "k" "{" "I" "}")) ("Ä®"))
+((("\\" "~" "{" "N" "}")) ("Ñ"))
+((("\\" "~" "N")) ("Ñ"))
+((("\\" "`" "{" "O" "}")) ("Ã’"))
+((("\\" "`" "O")) ("Ã’"))
+((("\\" "'" "{" "O" "}")) ("Ó"))
+((("\\" "'" "O")) ("Ó"))
+((("\\" "^" "{" "O" "}")) ("Ô"))
+((("\\" "^" "O")) ("Ô"))
+((("\\" "~" "{" "O" "}")) ("Õ"))
+((("\\" "~" "O")) ("Õ"))
+((("\\" "\"" "{" "O" "}")) ("Ö"))
+((("\\" "\"" "O")) ("Ö"))
+((("\\" "k" "{" "O" "}")) ("Ǫ"))
+((("$" "\\" "t" "i" "m" "e" "s" "$")) ("×"))
+((("\\" "t" "i" "m" "e" "s")) ("×"))
+((("\\" "O")) ("Ø"))
+((("\\" "`" "{" "U" "}")) ("Ù"))
+((("\\" "`" "U")) ("Ù"))
+((("\\" "'" "{" "U" "}")) ("Ú"))
+((("\\" "'" "U")) ("Ú"))
+((("\\" "^" "{" "U" "}")) ("Û"))
+((("\\" "^" "U")) ("Û"))
+((("\\" "\"" "{" "U" "}")) ("Ü"))
+((("\\" "\"" "U")) ("Ü"))
+((("\\" "k" "{" "U" "}")) ("Ų"))
+((("\\" "'" "{" "Y" "}")) ("�"))
+((("\\" "'" "Y")) ("�"))
+((("\\" "s" "s")) ("ß"))
+((("\\" "`" "{" "a" "}")) ("à"))
+((("\\" "`" "a")) ("à"))
+((("\\" "'" "{" "a" "}")) ("á"))
+((("\\" "'" "a")) ("á"))
+((("\\" "^" "{" "a" "}")) ("â"))
+((("\\" "^" "a")) ("â"))
+((("\\" "~" "{" "a" "}")) ("ã"))
+((("\\" "~" "a")) ("ã"))
+((("\\" "\"" "{" "a" "}")) ("ä"))
+((("\\" "\"" "a")) ("ä"))
+((("\\" "k" "{" "a" "}")) ("Ä…"))
+((("\\" "a" "a")) ("Ã¥"))
+((("\\" "a" "e")) ("æ"))
+((("\\" "c" "{" "c" "}")) ("ç"))
+((("\\" "c" "c")) ("ç"))
+((("\\" "`" "{" "e" "}")) ("è"))
+((("\\" "`" "e")) ("è"))
+((("\\" "'" "{" "e" "}")) ("é"))
+((("\\" "'" "e")) ("é"))
+((("\\" "^" "{" "e" "}")) ("ê"))
+((("\\" "^" "e")) ("ê"))
+((("\\" "\"" "{" "e" "}")) ("ë"))
+((("\\" "\"" "e")) ("ë"))
+((("\\" "k" "{" "e" "}")) ("Ä™"))
+((("\\" "`" "{" "\\" "i" "}")) ("ì"))
+((("\\" "`" "i")) ("ì"))
+((("\\" "'" "{" "\\" "i" "}")) ("í"))
+((("\\" "'" "i")) ("í"))
+((("\\" "^" "{" "\\" "i" "}")) ("î"))
+((("\\" "^" "i")) ("î"))
+((("\\" "\"" "{" "\\" "i" "}")) ("ï"))
+((("\\" "\"" "i")) ("ï"))
+((("\\" "k" "{" "i" "}")) ("į"))
+((("\\" "~" "{" "n" "}")) ("ñ"))
+((("\\" "~" "n")) ("ñ"))
+((("\\" "`" "{" "o" "}")) ("ò"))
+((("\\" "`" "o")) ("ò"))
+((("\\" "'" "{" "o" "}")) ("ó"))
+((("\\" "'" "o")) ("ó"))
+((("\\" "^" "{" "o" "}")) ("ô"))
+((("\\" "^" "o")) ("ô"))
+((("\\" "~" "{" "o" "}")) ("õ"))
+((("\\" "~" "o")) ("õ"))
+((("\\" "\"" "{" "o" "}")) ("ö"))
+((("\\" "\"" "o")) ("ö"))
+((("\\" "k" "{" "o" "}")) ("Ç«"))
+((("$" "\\" "d" "i" "v" "$")) ("÷"))
+((("\\" "d" "i" "v")) ("÷"))
+((("\\" "o")) ("ø"))
+((("\\" "`" "{" "u" "}")) ("ù"))
+((("\\" "`" "u")) ("ù"))
+((("\\" "'" "{" "u" "}")) ("ú"))
+((("\\" "'" "u")) ("ú"))
+((("\\" "^" "{" "u" "}")) ("û"))
+((("\\" "^" "u")) ("û"))
+((("\\" "\"" "{" "u" "}")) ("ü"))
+((("\\" "\"" "u")) ("ü"))
+((("\\" "k" "{" "u" "}")) ("ų"))
+((("\\" "'" "{" "y" "}")) ("ý"))
+((("\\" "'" "y")) ("ý"))
+((("\\" "\"" "{" "y" "}")) ("ÿ"))
+((("\\" "\"" "y")) ("ÿ"))
+((("\\" "=" "{" "A" "}")) ("Ä€"))
+((("\\" "=" "A")) ("Ä€"))
+((("\\" "=" "{" "a" "}")) ("�"))
+((("\\" "=" "a")) ("�"))
+((("\\" "u" "{" "A" "}")) ("Ä‚"))
+((("\\" "u" "A")) ("Ä‚"))
+((("\\" "u" "{" "a" "}")) ("ă"))
+((("\\" "u" "a")) ("ă"))
+((("\\" "'" "{" "C" "}")) ("Ć"))
+((("\\" "'" "C")) ("Ć"))
+((("\\" "'" "{" "c" "}")) ("ć"))
+((("\\" "'" "c")) ("ć"))
+((("\\" "^" "{" "C" "}")) ("Ĉ"))
+((("\\" "^" "C")) ("Ĉ"))
+((("\\" "^" "{" "c" "}")) ("ĉ"))
+((("\\" "^" "c")) ("ĉ"))
+((("\\" "." "{" "C" "}")) ("ÄŠ"))
+((("\\" "." "C")) ("ÄŠ"))
+((("\\" "." "{" "c" "}")) ("Ä‹"))
+((("\\" "." "c")) ("Ä‹"))
+((("\\" "v" "{" "C" "}")) ("Č"))
+((("\\" "v" "C")) ("Č"))
+((("\\" "v" "{" "c" "}")) ("�"))
+((("\\" "v" "c")) ("�"))
+((("\\" "v" "{" "D" "}")) ("ÄŽ"))
+((("\\" "v" "D")) ("ÄŽ"))
+((("\\" "v" "{" "d" "}")) ("�"))
+((("\\" "v" "d")) ("�"))
+((("\\" "=" "{" "E" "}")) ("Ä’"))
+((("\\" "=" "E")) ("Ä’"))
+((("\\" "=" "{" "e" "}")) ("Ä“"))
+((("\\" "=" "e")) ("Ä“"))
+((("\\" "u" "{" "E" "}")) ("Ä”"))
+((("\\" "u" "E")) ("Ä”"))
+((("\\" "u" "{" "e" "}")) ("Ä•"))
+((("\\" "u" "e")) ("Ä•"))
+((("\\" "." "{" "E" "}")) ("Ä–"))
+((("\\" "." "E")) ("Ä–"))
+((("\\" "e" "{" "e" "}")) ("Ä—"))
+((("\\" "e" "e")) ("Ä—"))
+((("\\" "v" "{" "E" "}")) ("Äš"))
+((("\\" "v" "E")) ("Äš"))
+((("\\" "v" "{" "e" "}")) ("Ä›"))
+((("\\" "v" "e")) ("Ä›"))
+((("\\" "^" "{" "G" "}")) ("Ĝ"))
+((("\\" "^" "G")) ("Ĝ"))
+((("\\" "^" "{" "g" "}")) ("�"))
+((("\\" "^" "g")) ("�"))
+((("\\" "u" "{" "G" "}")) ("Äž"))
+((("\\" "u" "G")) ("Äž"))
+((("\\" "u" "{" "g" "}")) ("ÄŸ"))
+((("\\" "u" "g")) ("ÄŸ"))
+((("\\" "." "{" "G" "}")) ("Ä "))
+((("\\" "." "G")) ("Ä "))
+((("\\" "." "{" "g" "}")) ("Ä¡"))
+((("\\" "." "g")) ("Ä¡"))
+((("\\" "c" "{" "G" "}")) ("Ä¢"))
+((("\\" "c" "G")) ("Ä¢"))
+((("\\" "c" "{" "g" "}")) ("Ä£"))
+((("\\" "c" "g")) ("Ä£"))
+((("\\" "^" "{" "H" "}")) ("Ĥ"))
+((("\\" "^" "H")) ("Ĥ"))
+((("\\" "^" "{" "h" "}")) ("Ä¥"))
+((("\\" "^" "h")) ("Ä¥"))
+((("\\" "~" "{" "I" "}")) ("Ĩ"))
+((("\\" "~" "I")) ("Ĩ"))
+((("\\" "~" "{" "\\" "i" "}")) ("Ä©"))
+((("\\" "~" "i")) ("Ä©"))
+((("\\" "=" "{" "I" "}")) ("Ī"))
+((("\\" "=" "I")) ("Ī"))
+((("\\" "=" "{" "\\" "i" "}")) ("Ä«"))
+((("\\" "=" "i")) ("Ä«"))
+((("\\" "u" "{" "I" "}")) ("Ĭ"))
+((("\\" "u" "I")) ("Ĭ"))
+((("\\" "u" "{" "\\" "i" "}")) ("Ä­"))
+((("\\" "u" "i")) ("Ä­"))
+((("\\" "." "{" "I" "}")) ("Ä°"))
+((("\\" "." "I")) ("Ä°"))
+((("\\" "i")) ("ı"))
+((("\\" "^" "{" "J" "}")) ("Ä´"))
+((("\\" "^" "J")) ("Ä´"))
+((("\\" "^" "{" "\\" "j" "}")) ("ĵ"))
+((("\\" "^" "j")) ("ĵ"))
+((("\\" "c" "{" "K" "}")) ("Ķ"))
+((("\\" "c" "K")) ("Ķ"))
+((("\\" "c" "{" "k" "}")) ("Ä·"))
+((("\\" "c" "k")) ("Ä·"))
+((("\\" "'" "{" "L" "}")) ("Ĺ"))
+((("\\" "'" "L")) ("Ĺ"))
+((("\\" "'" "{" "l" "}")) ("ĺ"))
+((("\\" "'" "l")) ("ĺ"))
+((("\\" "c" "{" "L" "}")) ("Ä»"))
+((("\\" "c" "L")) ("Ä»"))
+((("\\" "c" "{" "l" "}")) ("ļ"))
+((("\\" "c" "l")) ("ļ"))
+((("\\" "L")) ("�"))
+((("\\" "l")) ("Å‚"))
+((("\\" "'" "{" "N" "}")) ("Ń"))
+((("\\" "'" "N")) ("Ń"))
+((("\\" "'" "{" "n" "}")) ("Å„"))
+((("\\" "'" "n")) ("Å„"))
+((("\\" "c" "{" "N" "}")) ("Å…"))
+((("\\" "c" "N")) ("Å…"))
+((("\\" "c" "{" "n" "}")) ("ņ"))
+((("\\" "c" "n")) ("ņ"))
+((("\\" "v" "{" "N" "}")) ("Ň"))
+((("\\" "v" "N")) ("Ň"))
+((("\\" "v" "{" "n" "}")) ("ň"))
+((("\\" "v" "n")) ("ň"))
+((("\\" "=" "{" "O" "}")) ("Ō"))
+((("\\" "=" "O")) ("Ō"))
+((("\\" "=" "{" "o" "}")) ("�"))
+((("\\" "=" "o")) ("�"))
+((("\\" "u" "{" "O" "}")) ("ÅŽ"))
+((("\\" "u" "O")) ("ÅŽ"))
+((("\\" "u" "{" "o" "}")) ("�"))
+((("\\" "u" "o")) ("�"))
+((("\\" "H" "{" "O" "}")) ("�"))
+((("\\" "H" "O")) ("�"))
+((("\\" "U" "{" "o" "}")) ("Å‘"))
+((("\\" "U" "o")) ("Å‘"))
+((("\\" "O" "E")) ("Å’"))
+((("\\" "o" "e")) ("Å“"))
+((("\\" "'" "{" "R" "}")) ("Å”"))
+((("\\" "'" "R")) ("Å”"))
+((("\\" "'" "{" "r" "}")) ("Å•"))
+((("\\" "'" "r")) ("Å•"))
+((("\\" "c" "{" "R" "}")) ("Å–"))
+((("\\" "c" "R")) ("Å–"))
+((("\\" "c" "{" "r" "}")) ("Å—"))
+((("\\" "c" "r")) ("Å—"))
+((("\\" "v" "{" "R" "}")) ("Ř"))
+((("\\" "v" "R")) ("Ř"))
+((("\\" "v" "{" "r" "}")) ("Å™"))
+((("\\" "v" "r")) ("Å™"))
+((("\\" "'" "{" "S" "}")) ("Åš"))
+((("\\" "'" "S")) ("Åš"))
+((("\\" "'" "{" "s" "}")) ("Å›"))
+((("\\" "'" "s")) ("Å›"))
+((("\\" "^" "{" "S" "}")) ("Ŝ"))
+((("\\" "^" "S")) ("Ŝ"))
+((("\\" "^" "{" "s" "}")) ("�"))
+((("\\" "^" "s")) ("�"))
+((("\\" "c" "{" "S" "}")) ("Åž"))
+((("\\" "c" "S")) ("Åž"))
+((("\\" "c" "{" "s" "}")) ("ÅŸ"))
+((("\\" "c" "s")) ("ÅŸ"))
+((("\\" "v" "{" "S" "}")) ("Å "))
+((("\\" "v" "S")) ("Å "))
+((("\\" "v" "{" "s" "}")) ("Å¡"))
+((("\\" "v" "s")) ("Å¡"))
+((("\\" "c" "{" "T" "}")) ("Å¢"))
+((("\\" "c" "T")) ("Å¢"))
+((("\\" "c" "{" "t" "}")) ("Å£"))
+((("\\" "c" "t")) ("Å£"))
+((("\\" "v" "{" "T" "}")) ("Ť"))
+((("\\" "v" "T")) ("Ť"))
+((("\\" "v" "{" "t" "}")) ("Å¥"))
+((("\\" "v" "t")) ("Å¥"))
+((("\\" "~" "{" "U" "}")) ("Ũ"))
+((("\\" "~" "U")) ("Ũ"))
+((("\\" "~" "{" "u" "}")) ("Å©"))
+((("\\" "~" "u")) ("Å©"))
+((("\\" "=" "{" "U" "}")) ("Ū"))
+((("\\" "=" "U")) ("Ū"))
+((("\\" "=" "{" "u" "}")) ("Å«"))
+((("\\" "=" "u")) ("Å«"))
+((("\\" "u" "{" "U" "}")) ("Ŭ"))
+((("\\" "u" "U")) ("Ŭ"))
+((("\\" "u" "{" "u" "}")) ("Å­"))
+((("\\" "u" "u")) ("Å­"))
+((("\\" "H" "{" "U" "}")) ("Å°"))
+((("\\" "H" "U")) ("Å°"))
+((("\\" "H" "{" "u" "}")) ("ű"))
+((("\\" "H" "u")) ("ű"))
+((("\\" "^" "{" "W" "}")) ("Å´"))
+((("\\" "^" "W")) ("Å´"))
+((("\\" "^" "{" "w" "}")) ("ŵ"))
+((("\\" "^" "w")) ("ŵ"))
+((("\\" "^" "{" "Y" "}")) ("Ŷ"))
+((("\\" "^" "Y")) ("Ŷ"))
+((("\\" "^" "{" "y" "}")) ("Å·"))
+((("\\" "^" "y")) ("Å·"))
+((("\\" "\"" "{" "Y" "}")) ("Ÿ"))
+((("\\" "\"" "Y")) ("Ÿ"))
+((("\\" "'" "{" "Z" "}")) ("Ź"))
+((("\\" "'" "Z")) ("Ź"))
+((("\\" "'" "{" "z" "}")) ("ź"))
+((("\\" "'" "z")) ("ź"))
+((("\\" "." "{" "Z" "}")) ("Å»"))
+((("\\" "." "Z")) ("Å»"))
+((("\\" "." "{" "z" "}")) ("ż"))
+((("\\" "." "z")) ("ż"))
+((("\\" "v" "{" "Z" "}")) ("Ž"))
+((("\\" "v" "Z")) ("Ž"))
+((("\\" "v" "{" "z" "}")) ("ž"))
+((("\\" "v" "z")) ("ž"))
+((("\\" "v" "{" "A" "}")) ("�"))
+((("\\" "v" "A")) ("�"))
+((("\\" "v" "{" "a" "}")) ("ÇŽ"))
+((("\\" "v" "a")) ("ÇŽ"))
+((("\\" "v" "{" "I" "}")) ("�"))
+((("\\" "v" "I")) ("�"))
+((("\\" "v" "{" "\\" "i" "}")) ("�"))
+((("\\" "v" "i")) ("�"))
+((("\\" "v" "{" "O" "}")) ("Ç‘"))
+((("\\" "v" "O")) ("Ç‘"))
+((("\\" "v" "{" "o" "}")) ("Ç’"))
+((("\\" "v" "o")) ("Ç’"))
+((("\\" "v" "{" "U" "}")) ("Ç“"))
+((("\\" "v" "U")) ("Ç“"))
+((("\\" "v" "{" "u" "}")) ("Ç”"))
+((("\\" "v" "u")) ("Ç”"))
+((("\\" "=" "{" "\\" "A" "E" "}")) ("Ç¢"))
+((("\\" "=" "\\" "A" "E")) ("Ç¢"))
+((("\\" "=" "{" "\\" "a" "e" "}")) ("Ç£"))
+((("\\" "=" "\\" "a" "e")) ("Ç£"))
+((("\\" "v" "{" "G" "}")) ("Ǧ"))
+((("\\" "v" "G")) ("Ǧ"))
+((("\\" "v" "{" "g" "}")) ("ǧ"))
+((("\\" "v" "g")) ("ǧ"))
+((("\\" "v" "{" "K" "}")) ("Ǩ"))
+((("\\" "v" "K")) ("Ǩ"))
+((("\\" "v" "{" "k" "}")) ("Ç©"))
+((("\\" "v" "k")) ("Ç©"))
+((("\\" "v" "{" "\\" "j" "}")) ("Ç°"))
+((("\\" "v" "j")) ("Ç°"))
+((("\\" "'" "{" "G" "}")) ("Ç´"))
+((("\\" "'" "G")) ("Ç´"))
+((("\\" "'" "{" "g" "}")) ("ǵ"))
+((("\\" "'" "g")) ("ǵ"))
+((("\\" "`" "{" "N" "}")) ("Ǹ"))
+((("\\" "`" "N")) ("Ǹ"))
+((("\\" "`" "{" "n" "}")) ("ǹ"))
+((("\\" "`" "n")) ("ǹ"))
+((("\\" "'" "{" "\\" "A" "E" "}")) ("Ǽ"))
+((("\\" "'" "\\" "A" "E")) ("Ǽ"))
+((("\\" "'" "{" "\\" "a" "e" "}")) ("ǽ"))
+((("\\" "'" "\\" "a" "e")) ("ǽ"))
+((("\\" "'" "{" "\\" "O" "}")) ("Ǿ"))
+((("\\" "'" "\\" "O")) ("Ǿ"))
+((("\\" "'" "{" "\\" "o" "}")) ("Ç¿"))
+((("\\" "'" "\\" "o")) ("Ç¿"))
+((("\\" "v" "{" "H" "}")) ("Èž"))
+((("\\" "v" "H")) ("Èž"))
+((("\\" "v" "{" "h" "}")) ("ÈŸ"))
+((("\\" "v" "h")) ("ÈŸ"))
+((("\\" "." "{" "A" "}")) ("Ȧ"))
+((("\\" "." "A")) ("Ȧ"))
+((("\\" "." "{" "a" "}")) ("ȧ"))
+((("\\" "." "a")) ("ȧ"))
+((("\\" "c" "{" "E" "}")) ("Ȩ"))
+((("\\" "c" "E")) ("Ȩ"))
+((("\\" "c" "{" "e" "}")) ("È©"))
+((("\\" "c" "e")) ("È©"))
+((("\\" "." "{" "O" "}")) ("È®"))
+((("\\" "." "O")) ("È®"))
+((("\\" "." "{" "o" "}")) ("ȯ"))
+((("\\" "." "o")) ("ȯ"))
+((("\\" "=" "{" "Y" "}")) ("Ȳ"))
+((("\\" "=" "Y")) ("Ȳ"))
+((("\\" "=" "{" "y" "}")) ("ȳ"))
+((("\\" "=" "y")) ("ȳ"))
+((("\\" "v" "{" "}")) ("ˇ"))
+((("\\" "u" "{" "}")) ("˘"))
+((("\\" "." "{" "}")) ("Ë™"))
+((("\\" "~" "{" "}")) ("˜"))
+((("\\" "H" "{" "}")) ("�"))
+((("\\" "'")) ("�"))
+((("\\" "'" "K")) ("Ḱ"))
+((("\\" "'" "M")) ("Ḿ"))
+((("\\" "'" "P")) ("á¹”"))
+((("\\" "'" "W")) ("Ẃ"))
+((("\\" "'" "k")) ("ḱ"))
+((("\\" "'" "m")) ("ḿ"))
+((("\\" "'" "p")) ("ṕ"))
+((("\\" "'" "w")) ("ẃ"))
+((("\\" ",")) (" "))
+((("\\" ".")) ("̇"))
+((("\\" "." "B")) ("Ḃ"))
+((("\\" "." "D")) ("Ḋ"))
+((("\\" "." "F")) ("Ḟ"))
+((("\\" "." "H")) ("Ḣ"))
+((("\\" "." "M")) ("á¹€"))
+((("\\" "." "N")) ("Ṅ"))
+((("\\" "." "P")) ("á¹–"))
+((("\\" "." "R")) ("Ṙ"))
+((("\\" "." "S")) ("á¹ "))
+((("\\" "." "T")) ("Ṫ"))
+((("\\" "." "W")) ("Ẇ"))
+((("\\" "." "X")) ("Ẋ"))
+((("\\" "." "Y")) ("Ẏ"))
+((("\\" "." "b")) ("ḃ"))
+((("\\" "." "d")) ("ḋ"))
+((("\\" "." "e")) ("Ä—"))
+((("\\" "." "f")) ("ḟ"))
+((("\\" "." "h")) ("ḣ"))
+((("\\" "." "m")) ("�"))
+((("\\" "." "n")) ("á¹…"))
+((("\\" "." "p")) ("á¹—"))
+((("\\" "." "r")) ("á¹™"))
+((("\\" "." "s")) ("ṡ"))
+((("\\" "." "t")) ("ṫ"))
+((("\\" "." "w")) ("ẇ"))
+((("\\" "." "x")) ("ẋ"))
+((("\\" "." "y")) ("�"))
+((("\\" "/")) ("‌"))
+((("\\" ":")) (" "))
+((("\\" ";")) (" "))
+((("\\" "=")) ("Ì„"))
+((("\\" "=" "G")) ("Ḡ"))
+((("\\" "=" "g")) ("ḡ"))
+((("^" "(")) ("�"))
+((("^" ")")) ("�"))
+((("^" "+")) ("�"))
+((("^" "-")) ("�"))
+((("^" "0")) ("�"))
+((("^" "1")) ("¹"))
+((("^" "2")) ("²"))
+((("^" "3")) ("³"))
+((("^" "4")) ("�"))
+((("^" "5")) ("�"))
+((("^" "6")) ("�"))
+((("^" "7")) ("�"))
+((("^" "8")) ("�"))
+((("^" "9")) ("�"))
+((("^" "=")) ("�"))
+((("^" "\\" "g" "a" "m" "m" "a")) ("Ë "))
+((("^" "h")) ("Ê°"))
+((("^" "j")) ("ʲ"))
+((("^" "l")) ("Ë¡"))
+((("^" "n")) ("�"))
+((("^" "o")) ("º"))
+((("^" "r")) ("ʳ"))
+((("^" "s")) ("Ë¢"))
+((("^" "w")) ("Ê·"))
+((("^" "x")) ("Ë£"))
+((("^" "y")) ("ʸ"))
+((("^" "{" "S" "M" "}")) ("â„ "))
+((("^" "{" "T" "E" "L" "}")) ("â„¡"))
+((("^" "{" "T" "M" "}")) ("â„¢"))
+((("_" "(")) ("�"))
+((("_" ")")) ("â‚Ž"))
+((("_" "+")) ("â‚Š"))
+((("_" "-")) ("â‚‹"))
+((("_" "0")) ("â‚€"))
+((("_" "1")) ("�"))
+((("_" "2")) ("â‚‚"))
+((("_" "3")) ("₃"))
+((("_" "4")) ("â‚„"))
+((("_" "5")) ("â‚…"))
+((("_" "6")) ("₆"))
+((("_" "7")) ("₇"))
+((("_" "8")) ("₈"))
+((("_" "9")) ("₉"))
+((("_" "=")) ("₌"))
+((("\\" "~")) ("̃"))
+((("\\" "~" "E")) ("Ẽ"))
+((("\\" "~" "V")) ("á¹¼"))
+((("\\" "~" "Y")) ("Ỹ"))
+((("\\" "~" "e")) ("ẽ"))
+((("\\" "~" "v")) ("á¹½"))
+((("\\" "~" "y")) ("ỹ"))
+((("\\" "\"")) ("̈"))
+((("\\" "\"" "H")) ("Ḧ"))
+((("\\" "\"" "W")) ("Ẅ"))
+((("\\" "\"" "X")) ("Ẍ"))
+((("\\" "\"" "h")) ("ḧ"))
+((("\\" "\"" "t")) ("ẗ"))
+((("\\" "\"" "w")) ("ẅ"))
+((("\\" "\"" "x")) ("�"))
+((("\\" "^")) ("Ì‚"))
+((("\\" "^" "Z")) ("�"))
+((("\\" "^" "z")) ("ẑ"))
+((("\\" "`")) ("Ì€"))
+((("\\" "`" "W")) ("Ẁ"))
+((("\\" "`" "Y")) ("Ỳ"))
+((("\\" "`" "w")) ("�"))
+((("\\" "`" "y")) ("ỳ"))
+((("\\" "b")) ("̱"))
+((("\\" "c")) ("̧"))
+((("\\" "c" "{" "D" "}")) ("�"))
+((("\\" "c" "{" "H" "}")) ("Ḩ"))
+((("\\" "c" "{" "d" "}")) ("ḑ"))
+((("\\" "c" "{" "h" "}")) ("ḩ"))
+((("\\" "d")) ("Ì£"))
+((("\\" "d" "{" "A" "}")) ("Ạ"))
+((("\\" "d" "{" "B" "}")) ("Ḅ"))
+((("\\" "d" "{" "D" "}")) ("Ḍ"))
+((("\\" "d" "{" "E" "}")) ("Ẹ"))
+((("\\" "d" "{" "H" "}")) ("Ḥ"))
+((("\\" "d" "{" "I" "}")) ("Ị"))
+((("\\" "d" "{" "K" "}")) ("Ḳ"))
+((("\\" "d" "{" "L" "}")) ("Ḷ"))
+((("\\" "d" "{" "M" "}")) ("Ṃ"))
+((("\\" "d" "{" "N" "}")) ("Ṇ"))
+((("\\" "d" "{" "O" "}")) ("Ọ"))
+((("\\" "d" "{" "R" "}")) ("Ṛ"))
+((("\\" "d" "{" "S" "}")) ("á¹¢"))
+((("\\" "d" "{" "T" "}")) ("Ṭ"))
+((("\\" "d" "{" "U" "}")) ("Ụ"))
+((("\\" "d" "{" "V" "}")) ("á¹¾"))
+((("\\" "d" "{" "W" "}")) ("Ẉ"))
+((("\\" "d" "{" "Y" "}")) ("á»´"))
+((("\\" "d" "{" "Z" "}")) ("Ẓ"))
+((("\\" "d" "{" "a" "}")) ("ạ"))
+((("\\" "d" "{" "b" "}")) ("ḅ"))
+((("\\" "d" "{" "d" "}")) ("�"))
+((("\\" "d" "{" "e" "}")) ("ẹ"))
+((("\\" "d" "{" "h" "}")) ("ḥ"))
+((("\\" "d" "{" "i" "}")) ("ị"))
+((("\\" "d" "{" "k" "}")) ("ḳ"))
+((("\\" "d" "{" "l" "}")) ("ḷ"))
+((("\\" "d" "{" "m" "}")) ("ṃ"))
+((("\\" "d" "{" "n" "}")) ("ṇ"))
+((("\\" "d" "{" "o" "}")) ("�"))
+((("\\" "d" "{" "r" "}")) ("á¹›"))
+((("\\" "d" "{" "s" "}")) ("á¹£"))
+((("\\" "d" "{" "t" "}")) ("á¹­"))
+((("\\" "d" "{" "u" "}")) ("ụ"))
+((("\\" "d" "{" "v" "}")) ("ṿ"))
+((("\\" "d" "{" "w" "}")) ("ẉ"))
+((("\\" "d" "{" "y" "}")) ("ỵ"))
+((("\\" "d" "{" "z" "}")) ("ẓ"))
+((("\\" "r" "q")) ("’"))
+((("\\" "u")) ("̆"))
+((("\\" "v")) ("̌"))
+((("\\" "v" "{" "L" "}")) ("Ľ"))
+((("\\" "v" "{" "i" "}")) ("�"))
+((("\\" "v" "{" "j" "}")) ("Ç°"))
+((("\\" "v" "{" "l" "}")) ("ľ"))
+((("\\" "y" "e" "n")) ("Â¥"))
+((("\\" "B" "o" "x")) ("â–¡"))
+((("\\" "B" "u" "m" "p" "e" "q")) ("≎"))
+((("\\" "C" "a" "p")) ("â‹’"))
+((("\\" "C" "u" "p")) ("â‹“"))
+((("\\" "D" "e" "l" "t" "a")) ("Δ"))
+((("\\" "D" "i" "a" "m" "o" "n" "d")) ("â—‡"))
+((("\\" "D" "o" "w" "n" "a" "r" "r" "o" "w")) ("⇓"))
+((("\\" "G" "a" "m" "m" "a")) ("Γ"))
+((("\\" "H")) ("Ì‹"))
+((("\\" "H" "{" "o" "}")) ("Å‘"))
+((("\\" "I" "m")) ("â„‘"))
+((("\\" "J" "o" "i" "n")) ("⋈"))
+((("\\" "L" "a" "m" "b" "d" "a")) ("Λ"))
+((("\\" "L" "e" "f" "t" "a" "r" "r" "o" "w")) ("�"))
+((("\\" "L" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("⇔"))
+((("\\" "L" "l")) ("⋘"))
+((("\\" "L" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("⇚"))
+((("\\" "L" "o" "n" "g" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("�"))
+((("\\" "L" "o" "n" "g" "l" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("⇔"))
+((("\\" "L" "o" "n" "g" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("⇒"))
+((("\\" "L" "s" "h")) ("↰"))
+((("\\" "O" "m" "e" "g" "a")) ("Ω"))
+((("\\" "P" "h" "i")) ("Φ"))
+((("\\" "P" "i")) ("Π"))
+((("\\" "P" "s" "i")) ("Ψ"))
+((("\\" "R" "e")) ("ℜ"))
+((("\\" "R" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("⇒"))
+((("\\" "R" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("⇛"))
+((("\\" "R" "s" "h")) ("↱"))
+((("\\" "S" "i" "g" "m" "a")) ("Σ"))
+((("\\" "S" "u" "b" "s" "e" "t")) ("�"))
+((("\\" "S" "u" "p" "s" "e" "t")) ("â‹‘"))
+((("\\" "T" "h" "e" "t" "a")) ("Θ"))
+((("\\" "U" "p" "a" "r" "r" "o" "w")) ("⇑"))
+((("\\" "U" "p" "d" "o" "w" "n" "a" "r" "r" "o" "w")) ("⇕"))
+((("\\" "U" "p" "s" "i" "l" "o" "n")) ("Î¥"))
+((("\\" "V" "d" "a" "s" "h")) ("⊩"))
+((("\\" "V" "e" "r" "t")) ("‖"))
+((("\\" "V" "v" "d" "a" "s" "h")) ("⊪"))
+((("\\" "X" "i")) ("Ξ"))
+((("\\" "a" "l" "e" "p" "h")) ("�"))
+((("\\" "a" "l" "p" "h" "a")) ("α"))
+((("\\" "a" "m" "a" "l" "g")) ("�"))
+((("\\" "a" "n" "g" "l" "e")) ("∠"))
+((("\\" "a" "p" "p" "r" "o" "x")) ("≈"))
+((("\\" "a" "p" "p" "r" "o" "x" "e" "q")) ("≊"))
+((("\\" "a" "s" "t")) ("∗"))
+((("\\" "a" "s" "y" "m" "p")) ("�"))
+((("\\" "b" "a" "c" "k" "c" "o" "n" "g")) ("≌"))
+((("\\" "b" "a" "c" "k" "e" "p" "s" "i" "l" "o" "n")) ("�"))
+((("\\" "b" "a" "c" "k" "p" "r" "i" "m" "e")) ("‵"))
+((("\\" "b" "a" "c" "k" "s" "i" "m")) ("∽"))
+((("\\" "b" "a" "c" "k" "s" "i" "m" "e" "q")) ("�"))
+((("\\" "b" "a" "c" "k" "s" "l" "a" "s" "h")) ("\\"))
+((("\\" "b" "a" "r" "w" "e" "d" "g" "e")) ("⊼"))
+((("\\" "b" "e" "c" "a" "u" "s" "e")) ("∵"))
+((("\\" "b" "e" "t" "a")) ("β"))
+((("\\" "b" "e" "t" "h")) ("ב"))
+((("\\" "b" "e" "t" "w" "e" "e" "n")) ("≬"))
+((("\\" "b" "i" "g" "c" "a" "p")) ("â‹‚"))
+((("\\" "b" "i" "g" "c" "i" "r" "c")) ("â—¯"))
+((("\\" "b" "i" "g" "c" "u" "p")) ("⋃"))
+((("\\" "b" "i" "g" "s" "t" "a" "r")) ("★"))
+((("\\" "b" "i" "g" "t" "r" "i" "a" "n" "g" "l" "e" "d" "o" "w" "n")) ("â–½"))
+((("\\" "b" "i" "g" "t" "r" "i" "a" "n" "g" "l" "e" "u" "p")) ("â–³"))
+((("\\" "b" "i" "g" "v" "e" "e")) ("�"))
+((("\\" "b" "i" "g" "w" "e" "d" "g" "e")) ("â‹€"))
+((("\\" "b" "l" "a" "c" "k" "l" "o" "z" "e" "n" "g" "e")) ("✦"))
+((("\\" "b" "l" "a" "c" "k" "s" "q" "u" "a" "r" "e")) ("â–ª"))
+((("\\" "b" "l" "a" "c" "k" "t" "r" "i" "a" "n" "g" "l" "e")) ("â–´"))
+((("\\" "b" "l" "a" "c" "k" "t" "r" "i" "a" "n" "g" "l" "e" "d" "o" "w" "n")) ("â–¾"))
+((("\\" "b" "l" "a" "c" "k" "t" "r" "i" "a" "n" "g" "l" "e" "l" "e" "f" "t")) ("â—‚"))
+((("\\" "b" "l" "a" "c" "k" "t" "r" "i" "a" "n" "g" "l" "e" "r" "i" "g" "h" "t")) ("â–¸"))
+((("\\" "b" "o" "t")) ("⊥"))
+((("\\" "b" "o" "w" "t" "i" "e")) ("⋈"))
+((("\\" "b" "o" "x" "m" "i" "n" "u" "s")) ("⊟"))
+((("\\" "b" "o" "x" "p" "l" "u" "s")) ("⊞"))
+((("\\" "b" "o" "x" "t" "i" "m" "e" "s")) ("⊠"))
+((("\\" "b" "u" "l" "l" "e" "t")) ("•"))
+((("\\" "b" "u" "m" "p" "e" "q")) ("�"))
+((("\\" "c" "a" "p")) ("∩"))
+((("\\" "c" "d" "o" "t" "s")) ("⋯"))
+((("\\" "c" "e" "n" "t" "e" "r" "d" "o" "t")) ("·"))
+((("\\" "c" "h" "e" "c" "k" "m" "a" "r" "k")) ("✓"))
+((("\\" "c" "h" "i")) ("χ"))
+((("\\" "c" "i" "r" "c")) ("â—‹"))
+((("\\" "c" "i" "r" "c" "e" "q")) ("≗"))
+((("\\" "c" "i" "r" "c" "l" "e" "a" "r" "r" "o" "w" "l" "e" "f" "t")) ("↺"))
+((("\\" "c" "i" "r" "c" "l" "e" "a" "r" "r" "o" "w" "r" "i" "g" "h" "t")) ("↻"))
+((("\\" "c" "i" "r" "c" "l" "e" "d" "R")) ("®"))
+((("\\" "c" "i" "r" "c" "l" "e" "d" "S")) ("Ⓢ"))
+((("\\" "c" "i" "r" "c" "l" "e" "d" "a" "s" "t")) ("⊛"))
+((("\\" "c" "i" "r" "c" "l" "e" "d" "c" "i" "r" "c")) ("⊚"))
+((("\\" "c" "i" "r" "c" "l" "e" "d" "d" "a" "s" "h")) ("�"))
+((("\\" "c" "l" "u" "b" "s" "u" "i" "t")) ("♣"))
+((("\\" "c" "o" "l" "o" "n")) (":"))
+((("\\" "c" "o" "l" "o" "n" "e" "q")) ("≔"))
+((("\\" "c" "o" "m" "p" "l" "e" "m" "e" "n" "t")) ("�"))
+((("\\" "c" "o" "n" "g")) ("≅"))
+((("\\" "c" "o" "p" "r" "o" "d")) ("�"))
+((("\\" "c" "u" "p")) ("∪"))
+((("\\" "c" "u" "r" "l" "y" "e" "q" "p" "r" "e" "c")) ("â‹ž"))
+((("\\" "c" "u" "r" "l" "y" "e" "q" "s" "u" "c" "c")) ("â‹Ÿ"))
+((("\\" "c" "u" "r" "l" "y" "p" "r" "e" "c" "e" "q")) ("≼"))
+((("\\" "c" "u" "r" "l" "y" "v" "e" "e")) ("â‹Ž"))
+((("\\" "c" "u" "r" "l" "y" "w" "e" "d" "g" "e")) ("�"))
+((("\\" "c" "u" "r" "v" "e" "a" "r" "r" "o" "w" "l" "e" "f" "t")) ("↶"))
+((("\\" "c" "u" "r" "v" "e" "a" "r" "r" "o" "w" "r" "i" "g" "h" "t")) ("↷"))
+((("\\" "d" "a" "g")) ("†"))
+((("\\" "d" "a" "g" "g" "e" "r")) ("†"))
+((("\\" "d" "a" "l" "e" "t" "h")) ("ד"))
+((("\\" "d" "a" "s" "h" "v")) ("⊣"))
+((("\\" "d" "d" "a" "g")) ("‡"))
+((("\\" "d" "d" "a" "g" "g" "e" "r")) ("‡"))
+((("\\" "d" "d" "o" "t" "s")) ("⋱"))
+((("\\" "d" "e" "l" "t" "a")) ("δ"))
+((("\\" "d" "i" "a" "m" "o" "n" "d")) ("â‹„"))
+((("\\" "d" "i" "a" "m" "o" "n" "d" "s" "u" "i" "t")) ("♢"))
+((("\\" "d" "i" "g" "a" "m" "m" "a")) ("Ϝ"))
+((("\\" "d" "i" "v" "i" "d" "e" "o" "n" "t" "i" "m" "e" "s")) ("⋇"))
+((("\\" "d" "o" "t" "e" "q")) ("�"))
+((("\\" "d" "o" "t" "e" "q" "d" "o" "t")) ("≑"))
+((("\\" "d" "o" "t" "p" "l" "u" "s")) ("∔"))
+((("\\" "d" "o" "t" "s" "q" "u" "a" "r" "e")) ("⊡"))
+((("\\" "d" "o" "w" "n" "a" "r" "r" "o" "w")) ("↓"))
+((("\\" "d" "o" "w" "n" "d" "o" "w" "n" "a" "r" "r" "o" "w" "s")) ("⇊"))
+((("\\" "d" "o" "w" "n" "l" "e" "f" "t" "h" "a" "r" "p" "o" "o" "n")) ("⇃"))
+((("\\" "d" "o" "w" "n" "r" "i" "g" "h" "t" "h" "a" "r" "p" "o" "o" "n")) ("⇂"))
+((("\\" "e" "l" "l")) ("â„“"))
+((("\\" "e" "m" "p" "t" "y" "s" "e" "t")) ("∅"))
+((("\\" "e" "p" "s" "i" "l" "o" "n")) ("ε"))
+((("\\" "e" "q" "c" "i" "r" "c")) ("≖"))
+((("\\" "e" "q" "c" "o" "l" "o" "n")) ("≕"))
+((("\\" "e" "q" "s" "l" "a" "n" "t" "g" "t" "r")) ("�"))
+((("\\" "e" "q" "s" "l" "a" "n" "t" "l" "e" "s" "s")) ("⋜"))
+((("\\" "e" "q" "u" "i" "v")) ("≡"))
+((("\\" "e" "t" "a")) ("η"))
+((("\\" "e" "u" "r" "o")) ("€"))
+((("\\" "e" "x" "i" "s" "t" "s")) ("∃"))
+((("\\" "f" "a" "l" "l" "i" "n" "g" "d" "o" "t" "s" "e" "q")) ("≒"))
+((("\\" "f" "l" "a" "t")) ("â™­"))
+((("\\" "f" "o" "r" "a" "l" "l")) ("∀"))
+((("\\" "f" "r" "a" "c" "1")) ("â…Ÿ"))
+((("\\" "f" "r" "a" "c" "1" "2")) ("½"))
+((("\\" "f" "r" "a" "c" "1" "3")) ("â…“"))
+((("\\" "f" "r" "a" "c" "1" "4")) ("¼"))
+((("\\" "f" "r" "a" "c" "1" "5")) ("â…•"))
+((("\\" "f" "r" "a" "c" "1" "6")) ("â…™"))
+((("\\" "f" "r" "a" "c" "1" "8")) ("â…›"))
+((("\\" "f" "r" "a" "c" "2" "3")) ("â…”"))
+((("\\" "f" "r" "a" "c" "2" "5")) ("â…–"))
+((("\\" "f" "r" "a" "c" "3" "4")) ("¾"))
+((("\\" "f" "r" "a" "c" "3" "5")) ("â…—"))
+((("\\" "f" "r" "a" "c" "3" "8")) ("⅜"))
+((("\\" "f" "r" "a" "c" "4" "5")) ("â…˜"))
+((("\\" "f" "r" "a" "c" "5" "6")) ("â…š"))
+((("\\" "f" "r" "a" "c" "5" "8")) ("â…�"))
+((("\\" "f" "r" "a" "c" "7" "8")) ("â…ž"))
+((("\\" "f" "r" "o" "w" "n")) ("⌢"))
+((("\\" "g" "a" "m" "m" "a")) ("γ"))
+((("\\" "g" "e")) ("≥"))
+((("\\" "g" "e" "q")) ("≥"))
+((("\\" "g" "e" "q" "q")) ("≧"))
+((("\\" "g" "e" "q" "s" "l" "a" "n" "t")) ("≥"))
+((("\\" "g" "e" "t" "s")) ("�"))
+((("\\" "g" "g")) ("≫"))
+((("\\" "g" "g" "g")) ("â‹™"))
+((("\\" "g" "i" "m" "e" "l")) ("×’"))
+((("\\" "g" "n" "a" "p" "p" "r" "o" "x")) ("⋧"))
+((("\\" "g" "n" "e" "q")) ("≩"))
+((("\\" "g" "n" "e" "q" "q")) ("≩"))
+((("\\" "g" "n" "s" "i" "m")) ("⋧"))
+((("\\" "g" "t" "r" "a" "p" "p" "r" "o" "x")) ("≳"))
+((("\\" "g" "t" "r" "d" "o" "t")) ("â‹—"))
+((("\\" "g" "t" "r" "e" "q" "l" "e" "s" "s")) ("â‹›"))
+((("\\" "g" "t" "r" "e" "q" "q" "l" "e" "s" "s")) ("â‹›"))
+((("\\" "g" "t" "r" "l" "e" "s" "s")) ("≷"))
+((("\\" "g" "t" "r" "s" "i" "m")) ("≳"))
+((("\\" "g" "v" "e" "r" "t" "n" "e" "q" "q")) ("≩"))
+((("\\" "h" "b" "a" "r")) ("�"))
+((("\\" "h" "e" "a" "r" "t" "s" "u" "i" "t")) ("♥"))
+((("\\" "h" "o" "o" "k" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("↩"))
+((("\\" "h" "o" "o" "k" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("↪"))
+((("\\" "i" "f" "f")) ("⇔"))
+((("\\" "i" "m" "a" "t" "h")) ("ı"))
+((("\\" "i" "n")) ("∈"))
+((("\\" "i" "n" "f" "t" "y")) ("∞"))
+((("\\" "i" "n" "t")) ("∫"))
+((("\\" "i" "n" "t" "e" "r" "c" "a" "l")) ("⊺"))
+((("\\" "i" "o" "t" "a")) ("ι"))
+((("\\" "k" "a" "p" "p" "a")) ("κ"))
+((("\\" "l" "a" "m" "b" "d" "a")) ("λ"))
+((("\\" "l" "a" "n" "g" "l" "e")) ("〈"))
+((("\\" "l" "b" "r" "a" "c" "e")) ("{"))
+((("\\" "l" "b" "r" "a" "c" "k")) ("["))
+((("\\" "l" "c" "e" "i" "l")) ("⌈"))
+((("\\" "l" "d" "o" "t" "s")) ("…"))
+((("\\" "l" "e")) ("≤"))
+((("\\" "l" "e" "a" "d" "s" "t" "o")) ("�"))
+((("\\" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("�"))
+((("\\" "l" "e" "f" "t" "a" "r" "r" "o" "w" "t" "a" "i" "l")) ("↢"))
+((("\\" "l" "e" "f" "t" "h" "a" "r" "p" "o" "o" "n" "d" "o" "w" "n")) ("↽"))
+((("\\" "l" "e" "f" "t" "h" "a" "r" "p" "o" "o" "n" "u" "p")) ("↼"))
+((("\\" "l" "e" "f" "t" "l" "e" "f" "t" "a" "r" "r" "o" "w" "s")) ("⇇"))
+((("\\" "l" "e" "f" "t" "p" "a" "r" "e" "n" "g" "t" "r")) ("〈"))
+((("\\" "l" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("↔"))
+((("\\" "l" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w" "s")) ("⇆"))
+((("\\" "l" "e" "f" "t" "r" "i" "g" "h" "t" "h" "a" "r" "p" "o" "o" "n" "s")) ("⇋"))
+((("\\" "l" "e" "f" "t" "r" "i" "g" "h" "t" "s" "q" "u" "i" "g" "a" "r" "r" "o" "w")) ("↭"))
+((("\\" "l" "e" "f" "t" "t" "h" "r" "e" "e" "t" "i" "m" "e" "s")) ("â‹‹"))
+((("\\" "l" "e" "q")) ("≤"))
+((("\\" "l" "e" "q" "q")) ("≦"))
+((("\\" "l" "e" "q" "s" "l" "a" "n" "t")) ("≤"))
+((("\\" "l" "e" "s" "s" "a" "p" "p" "r" "o" "x")) ("≲"))
+((("\\" "l" "e" "s" "s" "d" "o" "t")) ("â‹–"))
+((("\\" "l" "e" "s" "s" "e" "q" "g" "t" "r")) ("â‹š"))
+((("\\" "l" "e" "s" "s" "e" "q" "q" "g" "t" "r")) ("â‹š"))
+((("\\" "l" "e" "s" "s" "g" "t" "r")) ("≶"))
+((("\\" "l" "e" "s" "s" "s" "i" "m")) ("≲"))
+((("\\" "l" "f" "l" "o" "o" "r")) ("⌊"))
+((("\\" "l" "h" "d")) ("â—�"))
+((("\\" "r" "h" "d")) ("â–·"))
+((("\\" "l" "l")) ("≪"))
+((("\\" "l" "l" "c" "o" "r" "n" "e" "r")) ("⌞"))
+((("\\" "l" "n" "a" "p" "p" "r" "o" "x")) ("⋦"))
+((("\\" "l" "n" "e" "q")) ("≨"))
+((("\\" "l" "n" "e" "q" "q")) ("≨"))
+((("\\" "l" "n" "s" "i" "m")) ("⋦"))
+((("\\" "l" "o" "n" "g" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("�"))
+((("\\" "l" "o" "n" "g" "l" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("↔"))
+((("\\" "l" "o" "n" "g" "m" "a" "p" "s" "t" "o")) ("↦"))
+((("\\" "l" "o" "n" "g" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("→"))
+((("\\" "l" "o" "o" "p" "a" "r" "r" "o" "w" "l" "e" "f" "t")) ("↫"))
+((("\\" "l" "o" "o" "p" "a" "r" "r" "o" "w" "r" "i" "g" "h" "t")) ("↬"))
+((("\\" "l" "o" "z" "e" "n" "g" "e")) ("✧"))
+((("\\" "l" "q")) ("‘"))
+((("\\" "l" "r" "c" "o" "r" "n" "e" "r")) ("⌟"))
+((("\\" "l" "t" "i" "m" "e" "s")) ("⋉"))
+((("\\" "l" "v" "e" "r" "t" "n" "e" "q" "q")) ("≨"))
+((("\\" "m" "a" "l" "t" "e" "s" "e")) ("✠"))
+((("\\" "m" "a" "p" "s" "t" "o")) ("↦"))
+((("\\" "m" "e" "a" "s" "u" "r" "e" "d" "a" "n" "g" "l" "e")) ("∡"))
+((("\\" "m" "h" "o")) ("℧"))
+((("\\" "m" "i" "d")) ("∣"))
+((("\\" "m" "o" "d" "e" "l" "s")) ("⊧"))
+((("\\" "m" "p")) ("∓"))
+((("\\" "m" "u" "l" "t" "i" "m" "a" "p")) ("⊸"))
+((("\\" "n" "L" "e" "f" "t" "a" "r" "r" "o" "w")) ("�"))
+((("\\" "n" "L" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("⇎"))
+((("\\" "n" "R" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("�"))
+((("\\" "n" "V" "D" "a" "s" "h")) ("⊯"))
+((("\\" "n" "V" "d" "a" "s" "h")) ("⊮"))
+((("\\" "n" "a" "b" "l" "a")) ("∇"))
+((("\\" "n" "a" "p" "p" "r" "o" "x")) ("≉"))
+((("\\" "n" "a" "t" "u" "r" "a" "l")) ("â™®"))
+((("\\" "n" "c" "o" "n" "g")) ("≇"))
+((("\\" "n" "e")) ("≠"))
+((("\\" "n" "e" "a" "r" "r" "o" "w")) ("↗"))
+((("\\" "n" "e" "g")) ("¬"))
+((("\\" "n" "e" "q")) ("≠"))
+((("\\" "n" "e" "q" "u" "i" "v")) ("≢"))
+((("\\" "n" "e" "w" "l" "i" "n" "e")) ("
"))
+((("\\" "n" "e" "x" "i" "s" "t" "s")) ("∄"))
+((("\\" "n" "g" "e" "q")) ("≱"))
+((("\\" "n" "g" "e" "q" "q")) ("≱"))
+((("\\" "n" "g" "e" "q" "s" "l" "a" "n" "t")) ("≱"))
+((("\\" "n" "g" "t" "r")) ("≯"))
+((("\\" "n" "i")) ("∋"))
+((("\\" "n" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("↚"))
+((("\\" "n" "l" "e" "f" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("↮"))
+((("\\" "n" "l" "e" "q")) ("≰"))
+((("\\" "n" "l" "e" "q" "q")) ("≰"))
+((("\\" "n" "l" "e" "q" "s" "l" "a" "n" "t")) ("≰"))
+((("\\" "n" "l" "e" "s" "s")) ("≮"))
+((("\\" "n" "m" "i" "d")) ("∤"))
+((("\\" "n" "o" "t")) ("̸"))
+((("\\" "n" "o" "t" "i" "n")) ("∉"))
+((("\\" "n" "p" "a" "r" "a" "l" "l" "e" "l")) ("∦"))
+((("\\" "n" "p" "r" "e" "c")) ("⊀"))
+((("\\" "n" "p" "r" "e" "c" "e" "q")) ("â‹ "))
+((("\\" "n" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("↛"))
+((("\\" "n" "s" "h" "o" "r" "t" "m" "i" "d")) ("∤"))
+((("\\" "n" "s" "h" "o" "r" "t" "p" "a" "r" "a" "l" "l" "e" "l")) ("∦"))
+((("\\" "n" "s" "i" "m")) ("�"))
+((("\\" "n" "s" "i" "m" "e" "q")) ("≄"))
+((("\\" "n" "s" "u" "b" "s" "e" "t")) ("⊄"))
+((("\\" "n" "s" "u" "b" "s" "e" "t" "e" "q")) ("⊈"))
+((("\\" "n" "s" "u" "b" "s" "e" "t" "e" "q" "q")) ("⊈"))
+((("\\" "n" "s" "u" "c" "c")) ("�"))
+((("\\" "n" "s" "u" "c" "c" "e" "q")) ("â‹¡"))
+((("\\" "n" "s" "u" "p" "s" "e" "t")) ("⊅"))
+((("\\" "n" "s" "u" "p" "s" "e" "t" "e" "q")) ("⊉"))
+((("\\" "n" "s" "u" "p" "s" "e" "t" "e" "q" "q")) ("⊉"))
+((("\\" "n" "t" "r" "i" "a" "n" "g" "l" "e" "l" "e" "f" "t")) ("⋪"))
+((("\\" "n" "t" "r" "i" "a" "n" "g" "l" "e" "l" "e" "f" "t" "e" "q")) ("⋬"))
+((("\\" "n" "t" "r" "i" "a" "n" "g" "l" "e" "r" "i" "g" "h" "t")) ("â‹«"))
+((("\\" "n" "t" "r" "i" "a" "n" "g" "l" "e" "r" "i" "g" "h" "t" "e" "q")) ("â‹­"))
+((("\\" "n" "u")) ("ν"))
+((("\\" "n" "v" "D" "a" "s" "h")) ("⊭"))
+((("\\" "n" "v" "d" "a" "s" "h")) ("⊬"))
+((("\\" "n" "w" "a" "r" "r" "o" "w")) ("↖"))
+((("\\" "o" "d" "o" "t")) ("⊙"))
+((("\\" "o" "i" "n" "t")) ("∮"))
+((("\\" "o" "m" "e" "g" "a")) ("ω"))
+((("\\" "o" "m" "i" "n" "u" "s")) ("⊖"))
+((("\\" "o" "p" "l" "u" "s")) ("⊕"))
+((("\\" "o" "s" "l" "a" "s" "h")) ("⊘"))
+((("\\" "o" "t" "i" "m" "e" "s")) ("⊗"))
+((("\\" "p" "a" "r")) ("
"))
+((("\\" "p" "a" "r" "a" "l" "l" "e" "l")) ("∥"))
+((("\\" "p" "a" "r" "t" "i" "a" "l")) ("∂"))
+((("\\" "p" "e" "r" "p")) ("⊥"))
+((("\\" "p" "h" "i")) ("φ"))
+((("\\" "p" "i")) ("Ï€"))
+((("\\" "p" "i" "t" "c" "h" "f" "o" "r" "k")) ("â‹”"))
+((("\\" "p" "r" "e" "c")) ("≺"))
+((("\\" "p" "r" "e" "c" "a" "p" "p" "r" "o" "x")) ("≾"))
+((("\\" "p" "r" "e" "c" "e" "q")) ("≼"))
+((("\\" "p" "r" "e" "c" "n" "a" "p" "p" "r" "o" "x")) ("⋨"))
+((("\\" "p" "r" "e" "c" "n" "s" "i" "m")) ("⋨"))
+((("\\" "p" "r" "e" "c" "s" "i" "m")) ("≾"))
+((("\\" "p" "r" "i" "m" "e")) ("′"))
+((("\\" "p" "r" "o" "d")) ("�"))
+((("\\" "p" "r" "o" "p" "t" "o")) ("�"))
+((("\\" "p" "s" "i")) ("ψ"))
+((("\\" "q" "e" "d")) ("∎"))
+((("\\" "q" "u" "a" "d")) ("�"))
+((("\\" "r" "a" "n" "g" "l" "e")) ("〉"))
+((("\\" "r" "b" "r" "a" "c" "e")) ("}"))
+((("\\" "r" "b" "r" "a" "c" "k")) ("]"))
+((("\\" "r" "c" "e" "i" "l")) ("⌉"))
+((("\\" "r" "f" "l" "o" "o" "r")) ("⌋"))
+((("\\" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("→"))
+((("\\" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w" "t" "a" "i" "l")) ("↣"))
+((("\\" "r" "i" "g" "h" "t" "h" "a" "r" "p" "o" "o" "n" "d" "o" "w" "n")) ("�"))
+((("\\" "r" "i" "g" "h" "t" "h" "a" "r" "p" "o" "o" "n" "u" "p")) ("⇀"))
+((("\\" "r" "i" "g" "h" "t" "l" "e" "f" "t" "a" "r" "r" "o" "w" "s")) ("⇄"))
+((("\\" "r" "i" "g" "h" "t" "l" "e" "f" "t" "h" "a" "r" "p" "o" "o" "n" "s")) ("⇌"))
+((("\\" "r" "i" "g" "h" "t" "p" "a" "r" "e" "n" "g" "t" "r")) ("〉"))
+((("\\" "r" "i" "g" "h" "t" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w" "s")) ("⇉"))
+((("\\" "r" "i" "g" "h" "t" "t" "h" "r" "e" "e" "t" "i" "m" "e" "s")) ("⋌"))
+((("\\" "r" "i" "s" "i" "n" "g" "d" "o" "t" "s" "e" "q")) ("≓"))
+((("\\" "r" "t" "i" "m" "e" "s")) ("â‹Š"))
+((("\\" "s" "b" "s")) ("﹨"))
+((("\\" "s" "e" "a" "r" "r" "o" "w")) ("↘"))
+((("\\" "s" "e" "t" "m" "i" "n" "u" "s")) ("∖"))
+((("\\" "s" "h" "a" "r" "p")) ("♯"))
+((("\\" "s" "h" "o" "r" "t" "m" "i" "d")) ("∣"))
+((("\\" "s" "h" "o" "r" "t" "p" "a" "r" "a" "l" "l" "e" "l")) ("∥"))
+((("\\" "s" "i" "g" "m" "a")) ("σ"))
+((("\\" "s" "i" "m")) ("∼"))
+((("\\" "s" "i" "m" "e" "q")) ("≃"))
+((("\\" "s" "m" "a" "l" "l" "a" "m" "a" "l" "g")) ("�"))
+((("\\" "s" "m" "a" "l" "l" "s" "e" "t" "m" "i" "n" "u" "s")) ("∖"))
+((("\\" "s" "m" "a" "l" "l" "s" "m" "i" "l" "e")) ("⌣"))
+((("\\" "s" "m" "i" "l" "e")) ("⌣"))
+((("\\" "s" "p" "a" "d" "e" "s" "u" "i" "t")) ("â™ "))
+((("\\" "s" "p" "h" "e" "r" "i" "c" "a" "l" "a" "n" "g" "l" "e")) ("∢"))
+((("\\" "s" "q" "c" "a" "p")) ("⊓"))
+((("\\" "s" "q" "c" "u" "p")) ("⊔"))
+((("\\" "s" "q" "s" "u" "b" "s" "e" "t")) ("�"))
+((("\\" "s" "q" "s" "u" "b" "s" "e" "t" "e" "q")) ("⊑"))
+((("\\" "s" "q" "s" "u" "p" "s" "e" "t")) ("�"))
+((("\\" "s" "q" "s" "u" "p" "s" "e" "t" "e" "q")) ("⊒"))
+((("\\" "s" "q" "u" "a" "r" "e")) ("â–¡"))
+((("\\" "s" "q" "u" "i" "g" "a" "r" "r" "o" "w" "r" "i" "g" "h" "t")) ("�"))
+((("\\" "s" "t" "a" "r")) ("⋆"))
+((("\\" "s" "t" "r" "a" "i" "g" "h" "t" "p" "h" "i")) ("φ"))
+((("\\" "s" "u" "b" "s" "e" "t")) ("⊂"))
+((("\\" "s" "u" "b" "s" "e" "t" "e" "q")) ("⊆"))
+((("\\" "s" "u" "b" "s" "e" "t" "e" "q" "q")) ("⊆"))
+((("\\" "s" "u" "b" "s" "e" "t" "n" "e" "q")) ("⊊"))
+((("\\" "s" "u" "b" "s" "e" "t" "n" "e" "q" "q")) ("⊊"))
+((("\\" "s" "u" "c" "c")) ("≻"))
+((("\\" "s" "u" "c" "c" "a" "p" "p" "r" "o" "x")) ("≿"))
+((("\\" "s" "u" "c" "c" "c" "u" "r" "l" "y" "e" "q")) ("≽"))
+((("\\" "s" "u" "c" "c" "e" "q")) ("≽"))
+((("\\" "s" "u" "c" "c" "n" "a" "p" "p" "r" "o" "x")) ("â‹©"))
+((("\\" "s" "u" "c" "c" "n" "s" "i" "m")) ("â‹©"))
+((("\\" "s" "u" "c" "c" "s" "i" "m")) ("≿"))
+((("\\" "s" "u" "m")) ("∑"))
+((("\\" "s" "u" "p" "s" "e" "t")) ("⊃"))
+((("\\" "s" "u" "p" "s" "e" "t" "e" "q")) ("⊇"))
+((("\\" "s" "u" "p" "s" "e" "t" "e" "q" "q")) ("⊇"))
+((("\\" "s" "u" "p" "s" "e" "t" "n" "e" "q")) ("⊋"))
+((("\\" "s" "u" "p" "s" "e" "t" "n" "e" "q" "q")) ("⊋"))
+((("\\" "s" "u" "r" "d")) ("√"))
+((("\\" "s" "w" "a" "r" "r" "o" "w")) ("↙"))
+((("\\" "t" "a" "u")) ("Ï„"))
+((("\\" "t" "h" "e" "r" "e" "f" "o" "r" "e")) ("∴"))
+((("\\" "t" "h" "e" "t" "a")) ("θ"))
+((("\\" "t" "h" "i" "c" "k" "a" "p" "p" "r" "o" "x")) ("≈"))
+((("\\" "t" "h" "i" "c" "k" "s" "i" "m")) ("∼"))
+((("\\" "t" "o")) ("→"))
+((("\\" "t" "o" "p")) ("⊤"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e")) ("â–µ"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e" "d" "o" "w" "n")) ("â–¿"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e" "l" "e" "f" "t")) ("â—ƒ"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e" "l" "e" "f" "t" "e" "q")) ("⊴"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e" "q")) ("≜"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e" "r" "i" "g" "h" "t")) ("â–¹"))
+((("\\" "t" "r" "i" "a" "n" "g" "l" "e" "r" "i" "g" "h" "t" "e" "q")) ("⊵"))
+((("\\" "t" "w" "o" "h" "e" "a" "d" "l" "e" "f" "t" "a" "r" "r" "o" "w")) ("↞"))
+((("\\" "t" "w" "o" "h" "e" "a" "d" "r" "i" "g" "h" "t" "a" "r" "r" "o" "w")) ("↠"))
+((("\\" "u" "l" "c" "o" "r" "n" "e" "r")) ("⌜"))
+((("\\" "u" "p" "a" "r" "r" "o" "w")) ("↑"))
+((("\\" "u" "p" "d" "o" "w" "n" "a" "r" "r" "o" "w")) ("↕"))
+((("\\" "u" "p" "l" "e" "f" "t" "h" "a" "r" "p" "o" "o" "n")) ("↿"))
+((("\\" "u" "p" "l" "u" "s")) ("⊎"))
+((("\\" "u" "p" "r" "i" "g" "h" "t" "h" "a" "r" "p" "o" "o" "n")) ("↾"))
+((("\\" "u" "p" "s" "i" "l" "o" "n")) ("Ï…"))
+((("\\" "u" "p" "u" "p" "a" "r" "r" "o" "w" "s")) ("⇈"))
+((("\\" "u" "r" "c" "o" "r" "n" "e" "r")) ("�"))
+((("\\" "u" "{" "i" "}")) ("Ä­"))
+((("\\" "v" "D" "a" "s" "h")) ("⊨"))
+((("\\" "v" "a" "r" "k" "a" "p" "p" "a")) ("Ï°"))
+((("\\" "v" "a" "r" "p" "h" "i")) ("Ï•"))
+((("\\" "v" "a" "r" "p" "i")) ("Ï–"))
+((("\\" "v" "a" "r" "p" "r" "i" "m" "e")) ("′"))
+((("\\" "v" "a" "r" "p" "r" "o" "p" "t" "o")) ("�"))
+((("\\" "v" "a" "r" "r" "h" "o")) ("ϱ"))
+((("\\" "v" "a" "r" "s" "i" "g" "m" "a")) ("Ï‚"))
+((("\\" "v" "a" "r" "t" "h" "e" "t" "a")) ("Ï‘"))
+((("\\" "v" "a" "r" "t" "r" "i" "a" "n" "g" "l" "e" "l" "e" "f" "t")) ("⊲"))
+((("\\" "v" "a" "r" "t" "r" "i" "a" "n" "g" "l" "e" "r" "i" "g" "h" "t")) ("⊳"))
+((("\\" "v" "d" "a" "s" "h")) ("⊢"))
+((("\\" "v" "d" "o" "t" "s")) ("â‹®"))
+((("\\" "v" "e" "e")) ("∨"))
+((("\\" "v" "e" "e" "b" "a" "r")) ("⊻"))
+((("\\" "v" "e" "r" "t")) ("|"))
+((("\\" "w" "e" "d" "g" "e")) ("∧"))
+((("\\" "w" "p")) ("℘"))
+((("\\" "w" "r")) ("≀"))
+((("\\" "x" "i")) ("ξ"))
+((("\\" "z" "e" "t" "a")) ("ζ"))
+((("\\" "B" "b" "b" "{" "N" "}")) ("â„•"))
+((("\\" "B" "b" "b" "{" "P" "}")) ("â„™"))
+((("\\" "B" "b" "b" "{" "R" "}")) ("�"))
+((("\\" "B" "b" "b" "{" "Z" "}")) ("ℤ"))
+((("-" "-")) ("–"))
+((("-" "-" "-")) ("—"))
+((("\\" " ")) (" "))
+((("\\" "\\")) ("\\"))
+((("\\" "m" "u")) ("μ"))
+((("\\" "r" "h" "o")) ("�"))
+((("\\" "m" "a" "t" "h" "s" "c" "r" "{" "I" "}")) ("�"))
+((("\\" "S" "m" "i" "l" "e" "y")) ("☺"))
+((("\\" "b" "l" "a" "c" "k" "s" "m" "i" "l" "e" "y")) ("☻"))
+((("\\" "F" "r" "o" "w" "n" "y")) ("☹"))
+((("\\" "L" "e" "t" "t" "e" "r")) ("✉"))
+((("\\" "p" "e" "r" "m" "i" "l")) ("‰"))
+((("\\" "r" "e" "g" "i" "s" "t" "e" "r" "e" "d")) ("®"))
+((("\\" "c" "u" "r" "r" "e" "n" "c" "y")) ("¤"))
+((("\\" "d" "h")) ("ð"))
+((("\\" "D" "H")) ("�"))
+((("\\" "t" "h")) ("þ"))
+((("\\" "T" "H")) ("Þ"))
+((("\\" "m" "i" "c" "r" "o")) ("µ"))
+((("\\" "l" "n" "o" "t")) ("¬"))
+((("\\" "o" "r" "d" "f" "e" "m" "i" "n" "i" "n" "e")) ("ª"))
+((("\\" "o" "r" "d" "m" "a" "s" "c" "u" "l" "i" "n" "e")) ("º"))
+((("\\" "l" "a" "m" "b" "d" "a" "b" "a" "r")) ("Æ›"))
+((("\\" "c" "e" "l" "s" "i" "u" "s")) ("℃"))
+((("\\" "l" "d" "q")) ("“"))
+((("\\" "r" "d" "q")) ("�"))
+((("\\" "m" "i" "n" "u" "s")) ("−"))
+((("\\" "d" "e" "f" "s")) ("≙"))
+((("\\" "l" "l" "b" "r" "a" "c" "k" "e" "t")) ("〚"))
+((("\\" "r" "r" "b" "r" "a" "c" "k" "e" "t")) ("〛"))
+((("\\" "l" "d" "a" "t" "a")) ("《"))
+((("\\" "r" "d" "a" "t" "a")) ("》"))
+((("\\" "g" "l" "q")) ("‚"))
+((("\\" "g" "r" "q")) ("‘"))
+((("\\" "g" "l" "q" "q")) ("„"))
+((("\\" "\"" "`")) ("„"))
+((("\\" "g" "r" "q" "q")) ("“"))
+((("\\" "\"" "'")) ("“"))
+((("\\" "f" "l" "q")) ("‹"))
+((("\\" "f" "r" "q")) ("›"))
+((("\\" "f" "l" "q" "q")) ("«"))
+((("\\" "\"" "<")) ("«"))
+((("\\" "f" "r" "q" "q")) ("»"))
+((("\\" "\"" ">")) ("»"))
+((("\\" "-")) ("­"))
+((("\\" "t" "e" "x" "t" "m" "u")) ("µ"))
+((("\\" "t" "e" "x" "t" "f" "r" "a" "c" "t" "i" "o" "n" "s" "o" "l" "i" "d" "u" "s")) ("�"))
+((("\\" "t" "e" "x" "t" "b" "i" "g" "c" "i" "r" "c" "l" "e")) ("�"))
+((("\\" "t" "e" "x" "t" "m" "u" "s" "i" "c" "a" "l" "n" "o" "t" "e")) ("♪"))
+((("\\" "t" "e" "x" "t" "d" "i" "e" "d")) ("�"))
+((("\\" "t" "e" "x" "t" "c" "o" "l" "o" "n" "m" "o" "n" "e" "t" "a" "r" "y")) ("â‚¡"))
+((("\\" "t" "e" "x" "t" "w" "o" "n")) ("â‚©"))
+((("\\" "t" "e" "x" "t" "n" "a" "i" "r" "a")) ("₦"))
+((("\\" "t" "e" "x" "t" "p" "e" "s" "o")) ("₱"))
+((("\\" "t" "e" "x" "t" "l" "i" "r" "a")) ("₤"))
+((("\\" "t" "e" "x" "t" "r" "e" "c" "i" "p" "e")) ("â„ž"))
+((("\\" "t" "e" "x" "t" "i" "n" "t" "e" "r" "r" "o" "b" "a" "n" "g")) ("‽"))
+((("\\" "t" "e" "x" "t" "p" "e" "r" "t" "e" "n" "t" "h" "o" "u" "s" "a" "n" "d")) ("‱"))
+((("\\" "t" "e" "x" "t" "b" "a" "h" "t")) ("฿"))
+((("\\" "t" "e" "x" "t" "n" "u" "m" "e" "r" "o")) ("â„–"))
+((("\\" "t" "e" "x" "t" "d" "i" "s" "c" "o" "u" "n" "t")) ("�"))
+((("\\" "t" "e" "x" "t" "e" "s" "t" "i" "m" "a" "t" "e" "d")) ("â„®"))
+((("\\" "t" "e" "x" "t" "o" "p" "e" "n" "b" "u" "l" "l" "e" "t")) ("â—¦"))
+((("\\" "t" "e" "x" "t" "l" "q" "u" "i" "l" "l")) ("�"))
+((("\\" "t" "e" "x" "t" "r" "q" "u" "i" "l" "l")) ("�"))
+((("\\" "t" "e" "x" "t" "c" "i" "r" "c" "l" "e" "d" "P")) ("â„—"))
+((("\\" "t" "e" "x" "t" "r" "e" "f" "e" "r" "e" "n" "c" "e" "m" "a" "r" "k")) ("※"))
+))
+
+;; Local Variables:
+;; mode: scheme
+;; coding: utf-8
+;; End:
diff --git a/ide/uim/coqide.scm b/ide/uim/coqide.scm
new file mode 100644
index 00000000..62355ac2
--- /dev/null
+++ b/ide/uim/coqide.scm
@@ -0,0 +1,277 @@
+;;; coqide.scm -- Emacs-style Latin characters translation
+;;;
+;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;;    may be used to endorse or promote products derived from this software
+;;;    without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+;; This input method implements character composition rules for the
+;; Latin letters used in European languages.  The rules, defined in
+;; the file coqide-rules.scm, have been adapted from GNU Emacs 22.
+
+(require "util.scm")
+(require "rk.scm")
+(require "coqide-rules.scm")
+(require-custom "generic-key-custom.scm")
+(require-custom "coqide-custom.scm")
+
+(define coqide-context-rec-spec
+  (append
+   context-rec-spec
+   '((on	 #f)
+     (rkc	 #f)
+     (show-cands #f))))
+(define-record 'coqide-context coqide-context-rec-spec)
+(define coqide-context-new-internal coqide-context-new)
+
+(define (coqide-context-new id im)
+  (let ((lc (coqide-context-new-internal id im))
+	(rkc (rk-context-new (symbol-value coqide-rules) #f #f)))
+    (coqide-context-set-widgets! lc coqide-widgets)
+    (coqide-context-set-rkc! lc rkc)
+    lc))
+
+(define (coqide-current-translation lc)
+  (let ((rkc (coqide-context-rkc lc)))
+    (or (rk-peek-terminal-match rkc)
+	(and (not (null? (rk-context-seq rkc)))
+	     (list (rk-pending rkc))))))
+
+(define (coqide-current-string lc)
+  (let ((trans (coqide-current-translation lc)))
+    (if trans (car trans) "")))
+
+(define (coqide-context-clear lc)
+  (rk-flush (coqide-context-rkc lc)))
+
+(define (coqide-context-flush lc)
+  (let ((str (coqide-current-string lc)))
+    (if (not (equal? str "")) (im-commit lc str))
+    (coqide-context-clear lc)))
+
+(define (coqide-open-candidates-window lc height)
+  (if (coqide-context-show-cands lc)
+      (im-deactivate-candidate-selector lc))
+  (im-activate-candidate-selector lc height height)
+  (im-select-candidate lc 0)
+  (coqide-context-set-show-cands! lc #t))
+
+(define (coqide-close-candidates-window lc)
+  (if (coqide-context-show-cands lc)
+      (im-deactivate-candidate-selector lc))
+  (coqide-context-set-show-cands! lc #f))
+
+(define (coqide-update-preedit lc)
+  (if (coqide-context-on lc)
+      (let ((trans (coqide-current-translation lc))
+	    (ltrans 0))
+	(im-clear-preedit lc)
+	(if trans
+	    (begin (im-pushback-preedit lc
+					preedit-underline
+					(car trans))
+		   (set! ltrans (length trans))))
+	(im-pushback-preedit lc
+			     preedit-cursor
+			     "")
+	(im-update-preedit lc)
+	(if (> ltrans 1)
+	    (coqide-open-candidates-window lc ltrans)
+	    (coqide-close-candidates-window lc)))))
+
+(define (coqide-prepare-activation lc)
+  (coqide-context-flush lc)
+  (coqide-update-preedit lc))
+
+(register-action 'action_coqide_off
+		 (lambda (lc)
+		   (list
+		    'off
+		    "a"
+		    (N_ "CoqIDE mode off")
+		    (N_ "CoqIDE composition off")))
+		 (lambda (lc)
+		   (not (coqide-context-on lc)))
+		 (lambda (lc)
+		   (coqide-prepare-activation lc)
+		   (coqide-context-set-on! lc #f)))
+
+(register-action 'action_coqide_on
+		 (lambda (lc)
+		   (list
+		    'on
+		    "à"
+		    (N_ "CoqIDE mode on")
+		    (N_ "CoqIDE composition on")))
+		 (lambda (lc)
+		   (coqide-context-on lc))
+		 (lambda (lc)
+		   (coqide-prepare-activation lc)
+		   (coqide-context-set-on! lc #t)))
+
+(define coqide-input-mode-actions
+  '(action_coqide_off action_coqide_on))
+
+(define coqide-widgets '(widget_coqide_input_mode))
+
+(define default-widget_coqide_input_mode 'action_coqide_on)
+
+(register-widget 'widget_coqide_input_mode
+		 (activity-indicator-new coqide-input-mode-actions)
+		 (actions-new coqide-input-mode-actions))
+
+(define coqide-context-list '())
+
+(define (coqide-init-handler id im arg)
+  (let ((lc (coqide-context-new id im)))
+    (set! coqide-context-list (cons lc coqide-context-list))
+    lc))
+
+(define (coqide-release-handler lc)
+  (let ((rkc (coqide-context-rkc lc)))
+    (set! coqide-context-list
+	  ;; (delete lc coqide-context-list eq?) does not work
+	  (remove (lambda (c) (eq? (coqide-context-rkc c) rkc))
+		  coqide-context-list))))
+
+(define coqide-control-key?
+  (let ((shift-or-no-modifier? (make-key-predicate '("<Shift>" ""))))
+    (lambda (key key-state)
+      (not (shift-or-no-modifier? -1 key-state)))))
+
+(define (coqide-proc-on-state lc key key-state)
+  (let ((rkc (coqide-context-rkc lc))
+	(cur-trans (coqide-current-translation lc)))
+    (cond
+
+     ((or (coqide-off-key? key key-state)
+	  (and coqide-esc-turns-off? (eq? key 'escape)))
+      (coqide-context-flush lc)
+      (if (eq? key 'escape)
+	  (im-commit-raw lc))
+      (coqide-context-set-on! lc #f)
+      (coqide-close-candidates-window lc)
+      (im-clear-preedit lc)
+      (im-update-preedit lc))
+
+     ((coqide-backspace-key? key key-state)
+      (if (not (rk-backspace rkc))
+	  (im-commit-raw lc)))
+
+     ((coqide-control-key? key key-state)
+      (coqide-context-flush lc)
+      (im-commit-raw lc))
+
+     ((and (ichar-numeric? key)
+	   (coqide-context-show-cands lc)
+	   (let ((idx (- (numeric-ichar->integer key) 1)))
+	     (if (= idx -1) (set! idx 9))
+	     (and (>= idx 0) (< idx (length cur-trans))
+		  (begin
+		    (im-commit lc (nth idx cur-trans))
+		    (coqide-context-clear lc)
+		    #t)))))
+
+     (else
+      (let* ((key-str (if (symbol? key)
+			  (symbol->string key)
+			  (charcode->string key)))
+	     (cur-seq (rk-context-seq rkc))
+	     (res (rk-push-key! rkc key-str))
+	     (new-seq (rk-context-seq rkc))
+	     (new-trans (coqide-current-translation lc)))
+	(if (equal? new-seq (cons key-str cur-seq))
+	    (if (not (or (rk-partial? rkc) (> (length new-trans) 1)))
+		(begin (im-commit lc (car (rk-peek-terminal-match rkc)))
+		       (coqide-context-clear lc)))
+	    (begin (if (not (null? cur-seq)) (im-commit lc (car cur-trans)))
+		   (if (null? new-seq) (im-commit-raw lc)))))))))
+
+(define (coqide-proc-off-state lc key key-state)
+  (if (coqide-on-key? key key-state)
+      (coqide-context-set-on! lc #t)
+      (im-commit-raw lc)))
+
+(define (coqide-key-press-handler lc key key-state)
+  (if (coqide-context-on lc)
+      (coqide-proc-on-state lc key key-state)
+      (coqide-proc-off-state lc key key-state))
+  (coqide-update-preedit lc))
+
+(define (coqide-key-release-handler lc key key-state)
+  (if (or (ichar-control? key)
+	  (not (coqide-context-on lc)))
+      ;; don't discard key release event for apps
+      (im-commit-raw lc)))
+
+(define (coqide-reset-handler lc)
+  (coqide-context-clear lc))
+
+(define (coqide-get-candidate-handler lc idx accel-enum-hint)
+  (let* ((candidates (coqide-current-translation lc))
+	 (candidate (nth idx candidates)))
+    (list candidate (digit->string (+ idx 1)) "")))
+
+;; Emacs does nothing on focus-out
+;; TODO: this should be configurable
+(define (coqide-focus-out-handler lc)
+  #f)
+
+(define (coqide-place-handler lc)
+  (coqide-update-preedit lc))
+
+(define (coqide-displace-handler lc)
+  (coqide-context-flush lc)
+  (coqide-update-preedit lc))
+
+(register-im
+ 'coqide
+ ""
+ "UTF-8"
+ coqide-im-name-label
+ coqide-im-short-desc
+ #f
+ coqide-init-handler
+ coqide-release-handler
+ context-mode-handler
+ coqide-key-press-handler
+ coqide-key-release-handler
+ coqide-reset-handler
+ coqide-get-candidate-handler
+ #f
+ context-prop-activate-handler
+ #f
+ #f
+ coqide-focus-out-handler
+ coqide-place-handler
+ coqide-displace-handler
+)
+
+;; Local Variables:
+;; mode: scheme
+;; coding: utf-8
+;; End:
diff --git a/ide/undo.ml b/ide/undo.ml
index f617d289..18c2f7a4 100644
--- a/ide/undo.ml
+++ b/ide/undo.ml
@@ -6,20 +6,20 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: undo.ml 7603 2005-11-23 17:21:53Z barras $ *)
+(* $Id$ *)
 
 open GText
 open Ideutils
-type action = 
-  | Insert of string * int * int (* content*pos*length *) 
-  | Delete of string * int * int (* content*pos*length *) 
+type action =
+  | Insert of string * int * int (* content*pos*length *)
+  | Delete of string * int * int (* content*pos*length *)
 
 let neg act = match act with
   | Insert (s,i,l) -> Delete (s,i,l)
   | Delete (s,i,l) -> Insert (s,i,l)
 
 class undoable_view (tv:[>Gtk.text_view] Gtk.obj) =
-  let undo_lock = ref true in 
+  let undo_lock = ref true in
 object(self)
   inherit GText.view tv as super
   val history = (Stack.create () : action Stack.t)
@@ -29,25 +29,25 @@ object(self)
   method private dump_debug =
     if false (* !debug *) then begin
       prerr_endline "==========Stack top=============";
-      Stack.iter 
+      Stack.iter
 	(fun e -> match e with
 	   | Insert(s,p,l) ->
  	       Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
-	   | Delete(s,p,l) -> 			   
+	   | Delete(s,p,l) ->
 	       Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
 	history;
       Printf.eprintf "Stack size %d\n" (Stack.length history);
       prerr_endline "==========Stack Bottom==========";
       prerr_endline "==========Queue start=============";
-      Queue.iter 
+      Queue.iter
 	(fun e -> match e with
 	   | Insert(s,p,l) ->
  	       Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
-	   | Delete(s,p,l) -> 			   
+	   | Delete(s,p,l) ->
 	       Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
 	redo;
       Printf.eprintf "Stack size %d\n" (Queue.length redo);
-      prerr_endline "==========Queue End==========" 
+      prerr_endline "==========Queue End=========="
 
     end
 
@@ -57,16 +57,16 @@ object(self)
     undo_lock := false;
     prerr_endline "UNDO";
     try begin
-      let r = 
+      let r =
 	match Stack.pop history with
-	  | Insert(s,p,l) as act -> 
+	  | Insert(s,p,l) as act ->
 	      let start = self#buffer#get_iter_at_char p in
-	      (self#buffer#delete_interactive 
+	      (self#buffer#delete_interactive
 		 ~start
 		 ~stop:(start#forward_chars l)
 		 ()) or
 	      (Stack.push act history; false)
-	  | Delete(s,p,l) as act -> 
+	  | Delete(s,p,l) as act ->
 	      let iter = self#buffer#get_iter_at_char p in
 	      (self#buffer#insert_interactive ~iter s) or
 	      (Stack.push act history; false)
@@ -75,11 +75,11 @@ object(self)
 	Queue.push act redo;
 	Stack.push act nredo
       end;
-      undo_lock := true; 
+      undo_lock := true;
       r
     end
-    with Stack.Empty -> 
-      undo_lock := true; 
+    with Stack.Empty ->
+      undo_lock := true;
       false
   end else
     (prerr_endline "UNDO DISCARDED"; true)
@@ -97,7 +97,7 @@ object(self)
 	       end)
 	   );
 *)
-    ignore (self#buffer#connect#insert_text 
+    ignore (self#buffer#connect#insert_text
 	      ~callback:
 	      (fun it s ->
 		 if !undo_lock && not (Queue.is_empty redo) then begin
@@ -107,18 +107,18 @@ object(self)
 		   Queue.clear redo;
 		 end;
 (*		 let pos = it#offset in
-		 if Stack.is_empty history or 
+		 if Stack.is_empty history or
 		   s=" " or s="\t" or s="\n" or
-					(match Stack.top history with 
-					   | Insert(old,opos,olen) -> 
+					(match Stack.top history with
+					   | Insert(old,opos,olen) ->
 					       opos + olen <> pos
 					   | _ -> true)
 		 then *)
 		 Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history
 		 (*else begin
 		   match Stack.pop history with
-		     | Insert(olds,offset,len) -> 
-			 Stack.push 
+		     | Insert(olds,offset,len) ->
+			 Stack.push
 			 (Insert(olds^s,
 				 offset,
 				 len+(Glib.Utf8.length s)))
@@ -129,7 +129,7 @@ object(self)
 	      ));
     ignore (self#buffer#connect#delete_range
 	      ~callback:
-	      (fun ~start ~stop -> 
+	      (fun ~start ~stop ->
 		 if !undo_lock && not (Queue.is_empty redo) then begin
 		   Queue.iter (fun e -> Stack.push e history) redo;
 		   Queue.clear redo;
@@ -138,12 +138,12 @@ object(self)
 		 let stop_offset = stop#offset in
 		 let s = self#buffer#get_text ~start ~stop () in
 (*		 if Stack.is_empty history or (match Stack.top history with
-						 | Delete(old,opos,olen) -> 
+						 | Delete(old,opos,olen) ->
 						     olen=1 or opos <> start_offset
 						 | _ -> true
 					      )
 		 then
-*)		   Stack.push 
+*)		   Stack.push
 		     (Delete(s,
 			     start_offset,
 			     stop_offset - start_offset
@@ -151,27 +151,27 @@ object(self)
 		     history
 	(*	 else begin
 		   match Stack.pop history with
-		     | Delete(olds,offset,len) -> 
-			 Stack.push 
+		     | Delete(olds,offset,len) ->
+			 Stack.push
 			 (Delete(olds^s,
 				 offset,
 				 len+(Glib.Utf8.length s)))
 			 history
 		     | _ -> assert false
-			 
+
 		 end*);
 		 self#dump_debug
 	      ))
 end
 
 let undoable_view ?(buffer:GText.buffer option) =
-  GtkText.View.make_params [] 
-    ~cont:(GContainer.pack_container 
+  GtkText.View.make_params []
+    ~cont:(GContainer.pack_container
 	     ~create:
-	     (fun pl -> let w = match buffer with 
+	     (fun pl -> let w = match buffer with
 	      | None -> GtkText.View.create []
 	      | Some b -> GtkText.View.create_with_buffer b#as_buffer
 	      in
 	      Gobject.set_params w pl; ((new undoable_view w):undoable_view)))
-    
-    
+
+
diff --git a/ide/undo_lablgtk_ge212.mli b/ide/undo_lablgtk_ge212.mli
index 4488b5e9..7b7026bd 100644
--- a/ide/undo_lablgtk_ge212.mli
+++ b/ide/undo_lablgtk_ge212.mli
@@ -19,7 +19,7 @@ object
   method clear_undo : unit
 end
 
-val undoable_view : 
+val undoable_view :
     ?buffer:GText.buffer ->
     ?editable:bool ->
     ?cursor_visible:bool ->
diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli
index b87f6559..52bd6721 100644
--- a/ide/undo_lablgtk_ge26.mli
+++ b/ide/undo_lablgtk_ge26.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_ge26.mli 7580 2005-11-18 17:09:10Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* An undoable view class *)
 
@@ -18,7 +18,7 @@ object
   method clear_undo : unit
 end
 
-val undoable_view : 
+val undoable_view :
     ?buffer:GText.buffer ->
     ?editable:bool ->
     ?cursor_visible:bool ->
diff --git a/ide/undo_lablgtk_lt26.mli b/ide/undo_lablgtk_lt26.mli
index ddee31d2..46ecfb1d 100644
--- a/ide/undo_lablgtk_lt26.mli
+++ b/ide/undo_lablgtk_lt26.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_lt26.mli 7580 2005-11-18 17:09:10Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* An undoable view class *)
 
@@ -18,7 +18,7 @@ object
   method clear_undo : unit
 end
 
-val undoable_view : 
+val undoable_view :
     ?buffer:GText.buffer ->
     ?editable:bool ->
     ?cursor_visible:bool ->
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
index 7e6484e1..82b30534 100644
--- a/ide/utf8_convert.mll
+++ b/ide/utf8_convert.mll
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: utf8_convert.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 {
-  open Lexing 
+  open Lexing
   let b = Buffer.create 127
 
 }
@@ -24,16 +24,16 @@ rule entry = parse
   | "\\x{" (short | long ) '}'
       { let s = lexeme lexbuf in
 	let n = String.length s in
-	let code = 
-	  try Glib.Utf8.from_unichar 
-	    (int_of_string ("0x"^(String.sub s 3 (n - 4)))) 
+	let code =
+	  try Glib.Utf8.from_unichar
+	    (int_of_string ("0x"^(String.sub s 3 (n - 4))))
 	  with _ -> s
 	in
 	let c = if Glib.Utf8.validate code then code else s in
 	Buffer.add_string b c;
 	entry lexbuf
       }
-  | _ 
+  | _
       { let s = lexeme lexbuf in
 	Buffer.add_string b s;
 	entry lexbuf}
diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml
index d972639f..37f2e9a4 100644
--- a/ide/utils/config_file.ml
+++ b/ide/utils/config_file.ml
@@ -23,7 +23,7 @@
 (*                                                                               *)
 (*********************************************************************************)
 
-(* $Id: config_file.ml 10348 2007-12-06 17:36:14Z aspiwack $ *)
+(* $Id$ *)
 
 (* TODO *)
 (* section comments *)
diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml
index 275d8616..05bf54eb 100644
--- a/ide/utils/configwin.ml
+++ b/ide/utils/configwin.ml
@@ -43,9 +43,7 @@ class key_cp = Configwin_types.key_cp
 
 
 let string = Configwin_ihm.string
-let custom_string = Configwin_ihm.custom_string
 let text = Configwin_ihm.text
-let custom_text = Configwin_ihm.custom_text
 let strings = Configwin_ihm.strings
 let list = Configwin_ihm.list
 let bool = Configwin_ihm.bool
diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli
index 2d4dd4a7..bbfb7a04 100644
--- a/ide/utils/configwin.mli
+++ b/ide/utils/configwin.mli
@@ -77,13 +77,6 @@ class key_cp :
 val string : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
-(** Same as {!Configwin.string} but for values which are not strings. *)
-val custom_string : ?editable: bool -> ?expand: bool -> ?help: string ->
-  ?f: ('a -> unit) ->
-    to_string: ('a -> string) ->
-      of_string: (string -> 'a) ->
-	string -> 'a -> parameter_kind
-
 (** [bool label value] creates a boolean parameter.
    @param editable indicate if the value is editable (default is [true]).
    @param help an optional help message.
@@ -185,13 +178,6 @@ val combo : ?editable: bool -> ?expand: bool -> ?help: string ->
 val text : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
-(** Same as {!Configwin.text} but for values which are not strings. *)
-val custom_text : ?editable: bool -> ?expand: bool -> ?help: string ->
-  ?f: ('a -> unit) ->
-    to_string: ('a -> string) ->
-      of_string: (string -> 'a) ->
-	string -> 'a -> parameter_kind
-
 (** Same as {!Configwin.text} but html bindings are available
    in the text widget. Use the [configwin_html_config] utility
    to edit your bindings.
@@ -248,7 +234,7 @@ val hotkey : ?editable: bool -> ?expand: bool -> ?help: string ->
 
 val modifiers : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?allow:(Gdk.Tags.modifier list) ->
-  ?f: (Gdk.Tags.modifier list -> unit) -> 
+  ?f: (Gdk.Tags.modifier list -> unit) ->
     string -> Gdk.Tags.modifier list -> parameter_kind
 
 (** [custom box f expand] creates a custom parameter, with
diff --git a/ide/utils/configwin_html_config.ml b/ide/utils/configwin_html_config.ml
deleted file mode 100644
index fe39de0a..00000000
--- a/ide/utils/configwin_html_config.ml
+++ /dev/null
@@ -1,84 +0,0 @@
-(*********************************************************************************)
-(*                Cameleon                                                       *)
-(*                                                                               *)
-(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
-(*    en Automatique. All rights reserved.                                       *)
-(*                                                                               *)
-(*    This program is free software; you can redistribute it and/or modify       *)
-(*    it under the terms of the GNU Library General Public License as            *)
-(*    published by the Free Software Foundation; either version 2 of the         *)
-(*    License, or  any later version.                                            *)
-(*                                                                               *)
-(*    This program is distributed in the hope that it will be useful,            *)
-(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
-(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
-(*    GNU Library General Public License for more details.                       *)
-(*                                                                               *)
-(*    You should have received a copy of the GNU Library General Public          *)
-(*    License along with this program; if not, write to the Free Software        *)
-(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
-(*    02111-1307  USA                                                            *)
-(*                                                                               *)
-(*    Contact: Maxence.Guesdon@inria.fr                                          *)
-(*                                                                               *)
-(*********************************************************************************)
-
-(** The HTML editor bindings configurator. *)
-
-module C = Configwin_ihm
-open Configwin_types
-open Config_file
-
-let simple_get = C.simple_edit
-    ~with_apply: false ~apply: (fun () -> ())
-
-let params_hb hb =
-  let p_key = C.hotkey
-      ~f: (fun k -> hb.html_key <- k) Configwin_messages.mKey
-      hb.html_key
-  in
-  let p_begin = C.string
-      ~f: (fun s -> hb.html_begin <- s)
-      Configwin_messages.html_begin
-      hb.html_begin
-  in
-  let p_end = C.string
-      ~f: (fun s -> hb.html_end <- s)
-      Configwin_messages.html_end
-      hb.html_end
-  in
-  [ p_key ; p_begin ; p_end ]
-
-let edit_hb hb =
-  ignore (simple_get Configwin_messages.mEdit (params_hb hb));
-  hb
-
-let add () =
-  let hb = { html_key = Configwin_types.string_to_key "C-a" ;
-	     html_begin = "" ;
-	     html_end = "" ;
-	   }
-  in
-  match simple_get Configwin_messages.mAdd (params_hb hb) with
-    Return_ok -> [hb]
-  | _ -> []
-
-let main () =
-  ignore (GMain.Main.init ());
-  let (ini, bindings) = C.html_config_file_and_option () in
-  let param = C.list
-      ~f: (fun l -> bindings#set l ; ini#write Configwin_ihm.file_html_config )
-      ~eq: (fun hb1 hb2 -> hb1.html_key = hb2.html_key)
-      ~edit: edit_hb
-      ~add: add
-      ~titles: [ Configwin_messages.mKey ; Configwin_messages.html_begin ;
-		 Configwin_messages.html_end ]
-      Configwin_messages.shortcuts
-      (fun hb -> [ Configwin_types.key_to_string hb.html_key ;
-		   hb.html_begin ; hb.html_end ])
-      bindings#get
-  in
-  ignore (simple_get ~width: 300 ~height: 400
-	    Configwin_messages.html_config [param])
-
-let _ = main ()
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml
index 3ab3823d..3833acfa 100644
--- a/ide/utils/configwin_ihm.ml
+++ b/ide/utils/configwin_ihm.ml
@@ -802,41 +802,27 @@ class hotkey_param_box param (tt:GData.tooltips) =
 
 class modifiers_param_box param =
   let hbox = GPack.hbox () in
-  let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
+  let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in
   let _wl = GMisc.label ~text: param.md_label ~packing: wev#add () in
-  let we = GEdit.entry
-      ~editable: false
-      ~packing: (hbox#pack ~expand: param.md_expand ~padding: 2)
-      ()
-  in
   let value = ref param.md_value in
-  let _ = 
+  let _ = List.map (fun modifier ->
+                      let but = GButton.toggle_button
+                                  ~label:(Configwin_types.modifiers_to_string [modifier])
+                                  ~active:(List.mem modifier param.md_value)
+                                  ~packing:(hbox#pack ~expand:false) () in
+                      ignore (but#connect#toggled
+                                (fun _ -> if but#active then value := modifier::!value
+                                 else value := List.filter ((<>) modifier) !value)))
+            param.md_allow
+  in
+  let _ =
     match param.md_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wev#coerce ~text: help ~privat: help 
-  in
-  let _ = we#set_text (Configwin_types.modifiers_to_string param.md_value) in
-  let mods_we_care = param.md_allow in
-  let capture ev =
-    let modifiers = GdkEvent.Key.state ev in
-    let mods = List.filter
-	(fun m -> (List.mem m mods_we_care))
-	modifiers
-    in
-    value := mods;
-    we#set_text (Configwin_types.modifiers_to_string !value);
-    false
-  in
-  let _ = 
-    if param.md_editable then
-      ignore (we#event#connect#key_press capture)
-    else
-      ()
+       let tooltips = GData.tooltips () in
+       ignore (hbox#connect#destroy ~callback: tooltips#destroy);
+       tooltips#set_tip wev#coerce ~text: help ~privat: help
   in
-
   object (self)
     (** This method returns the main box ready to be packed. *)
     method box = hbox#coerce
@@ -1093,13 +1079,13 @@ let edit ?(with_apply=true)
       (fun conf_struct -> new configuration_box tooltips conf_struct wnote)
       conf_struct_list
   in
-    
+
     if with_apply then
       dialog#add_button Configwin_messages.mApply `APPLY;
-    
+
     dialog#add_button Configwin_messages.mOk `OK;
     dialog#add_button Configwin_messages.mCancel `CANCEL;
-    
+
     let f_apply () =
       List.iter (fun param_box -> param_box#apply) list_param_box  ;
       apply ()
@@ -1245,22 +1231,6 @@ let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       string_of_string = (fun x -> x) ;
     }
 
-(** Create a custom string param. *)
-let custom_string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ~to_string ~of_string label v =
-  String_param
-    (Configwin_types.mk_custom_text_string_param
-       {
-	 string_label = label ;
-	 string_help = help ;
-	 string_value = v ;
-	 string_editable = editable ;
-	 string_f_apply = f ;
-	 string_expand = expand ;
-	 string_to_string = to_string;
-	 string_of_string = of_string ;
-       }
-    )
-
 (** Create a bool param. *)
 let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v =
   Bool_param
@@ -1282,23 +1252,21 @@ let list ?(editable=true) ?help
     label (f_strings : 'a -> string list) v =
   List_param
     (fun tt ->
-      Obj.magic
-	(new list_param_box
-	   {
-	     list_label = label ;
-	     list_help = help ;
-	     list_value = v ;
-	     list_editable = editable ;
-	     list_titles = titles;
-	     list_eq = eq ;
-	     list_strings = f_strings ;
-	     list_color = color ;
-	     list_f_edit = edit ;
-	     list_f_add = add ;
-	     list_f_apply = f ;
-	   }
-	   tt
-	)
+	new list_param_box
+	  {
+	    list_label = label ;
+	    list_help = help ;
+	    list_value = v ;
+	    list_editable = editable ;
+	    list_titles = titles;
+	    list_eq = eq ;
+	    list_strings = f_strings ;
+	    list_color = color ;
+	    list_f_edit = edit ;
+	    list_f_add = add ;
+	    list_f_apply = f ;
+	  }
+	  tt
     )
 
 (** Create a strings param. *)
@@ -1363,22 +1331,6 @@ let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       string_of_string = (fun x -> x) ;
     }
 
-(** Create a custom text param. *)
-let custom_text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ~to_string ~of_string label v =
-  Text_param
-    (Configwin_types.mk_custom_text_string_param
-       {
-	 string_label = label ;
-	 string_help = help ;
-	 string_value = v ;
-	 string_editable = editable ;
-	 string_f_apply = f ;
-	 string_expand = expand ;
-	 string_to_string = to_string;
-	 string_of_string = of_string ;
-       }
-    )
-
 (** Create a html param. *)
 let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
   Html_param
@@ -1441,11 +1393,11 @@ let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       hk_expand = expand ;
     }
 
-let modifiers 
-  ?(editable=true) 
-  ?(expand=true) 
-  ?help 
-  ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) 
+let modifiers
+  ?(editable=true)
+  ?(expand=true)
+  ?help
+  ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5])
   ?(f=(fun _ -> ())) label v =
   Modifiers_param
     {
@@ -1456,7 +1408,7 @@ let modifiers
       md_f_apply = f ;
       md_expand = expand ;
       md_allow = allow ;
-    } 
+    }
 
 (** Create a custom param.*)
 let custom ?label box f expand =
diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml
index e1d7f33b..9f44e5c6 100644
--- a/ide/utils/configwin_keys.ml
+++ b/ide/utils/configwin_keys.ml
@@ -25,7 +25,7 @@
 
 (** Key codes
 
-   Ce fichier provient de X11/keysymdef.h 
+   Ce fichier provient de X11/keysymdef.h
    les noms des symboles deviennent : XK_ -> xk_
 
    Thanks to Fabrice Le Fessant.
@@ -1334,11 +1334,11 @@ let xk_Thai_khokhai					= 0xda2
 let xk_Thai_khokhuat				= 0xda3
 let xk_Thai_khokhwai				= 0xda4
 let xk_Thai_khokhon					= 0xda5
-let xk_Thai_khorakhang			        = 0xda6  
-let xk_Thai_ngongu					= 0xda7  
-let xk_Thai_chochan					= 0xda8  
-let xk_Thai_choching				= 0xda9   
-let xk_Thai_chochang				= 0xdaa  
+let xk_Thai_khorakhang			        = 0xda6
+let xk_Thai_ngongu					= 0xda7
+let xk_Thai_chochan					= 0xda8
+let xk_Thai_choching				= 0xda9
+let xk_Thai_chochang				= 0xdaa
 let xk_Thai_soso					= 0xdab
 let xk_Thai_chochoe					= 0xdac
 let xk_Thai_yoying					= 0xdad
@@ -1380,39 +1380,39 @@ let xk_Thai_saraa					= 0xdd0
 let xk_Thai_maihanakat				= 0xdd1
 let xk_Thai_saraaa					= 0xdd2
 let xk_Thai_saraam					= 0xdd3
-let xk_Thai_sarai					= 0xdd4   
-let xk_Thai_saraii					= 0xdd5   
-let xk_Thai_saraue					= 0xdd6    
-let xk_Thai_sarauee					= 0xdd7    
-let xk_Thai_sarau					= 0xdd8    
-let xk_Thai_sarauu					= 0xdd9   
+let xk_Thai_sarai					= 0xdd4
+let xk_Thai_saraii					= 0xdd5
+let xk_Thai_saraue					= 0xdd6
+let xk_Thai_sarauee					= 0xdd7
+let xk_Thai_sarau					= 0xdd8
+let xk_Thai_sarauu					= 0xdd9
 let xk_Thai_phinthu					= 0xdda
 let xk_Thai_maihanakat_maitho   			= 0xdde
 let xk_Thai_baht					= 0xddf
-let xk_Thai_sarae					= 0xde0    
+let xk_Thai_sarae					= 0xde0
 let xk_Thai_saraae					= 0xde1
 let xk_Thai_sarao					= 0xde2
-let xk_Thai_saraaimaimuan				= 0xde3   
-let xk_Thai_saraaimaimalai				= 0xde4  
+let xk_Thai_saraaimaimuan				= 0xde3
+let xk_Thai_saraaimaimalai				= 0xde4
 let xk_Thai_lakkhangyao				= 0xde5
 let xk_Thai_maiyamok				= 0xde6
 let xk_Thai_maitaikhu				= 0xde7
-let xk_Thai_maiek					= 0xde8   
+let xk_Thai_maiek					= 0xde8
 let xk_Thai_maitho					= 0xde9
 let xk_Thai_maitri					= 0xdea
 let xk_Thai_maichattawa				= 0xdeb
 let xk_Thai_thanthakhat				= 0xdec
 let xk_Thai_nikhahit				= 0xded
-let xk_Thai_leksun					= 0xdf0 
-let xk_Thai_leknung					= 0xdf1  
-let xk_Thai_leksong					= 0xdf2 
+let xk_Thai_leksun					= 0xdf0
+let xk_Thai_leknung					= 0xdf1
+let xk_Thai_leksong					= 0xdf2
 let xk_Thai_leksam					= 0xdf3
-let xk_Thai_leksi					= 0xdf4  
-let xk_Thai_lekha					= 0xdf5  
-let xk_Thai_lekhok					= 0xdf6  
-let xk_Thai_lekchet					= 0xdf7  
-let xk_Thai_lekpaet					= 0xdf8  
-let xk_Thai_lekkao					= 0xdf9 
+let xk_Thai_leksi					= 0xdf4
+let xk_Thai_lekha					= 0xdf5
+let xk_Thai_lekhok					= 0xdf6
+let xk_Thai_lekchet					= 0xdf7
+let xk_Thai_lekpaet					= 0xdf8
+let xk_Thai_lekkao					= 0xdf9
 
 
 (*
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml
index 0def0b25..90d5756b 100644
--- a/ide/utils/configwin_types.ml
+++ b/ide/utils/configwin_types.ml
@@ -111,7 +111,7 @@ let modifiers_to_string m =
                   ) ^ s)
   in
     iter m ""
-      
+
 let value_to_key v =
   match v with
     Raw.String s -> string_to_key s
@@ -233,7 +233,7 @@ type hotkey_param = {
 
 type modifiers_param = {
     md_label : string ; (** the label of the parameter *)
-    mutable md_value : Gdk.Tags.modifier list ; 
+    mutable md_value : Gdk.Tags.modifier list ;
              (** The value, as a list of modifiers and a key code *)
     md_editable : bool ; (** indicates if the value can be changed *)
     md_f_apply : Gdk.Tags.modifier list -> unit ;
@@ -241,11 +241,7 @@ type modifiers_param = {
     md_help : string option ; (** optional help string *)
     md_expand : bool ; (** expand or not *)
     md_allow : Gdk.Tags.modifier list
-  } 
-
-
-let mk_custom_text_string_param (a : 'a string_param) : string string_param =
-  Obj.magic a
+  }
 
 
 (** This type represents the different kinds of parameters. *)
diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml
index 5441f4ab..1ab107c7 100644
--- a/ide/utils/editable_cells.ml
+++ b/ide/utils/editable_cells.ml
@@ -1,21 +1,21 @@
 open GTree
 open Gobject
 
-let create l = 
+let create l =
   let hbox = GPack.hbox () in
-  let scw = GBin.scrolled_window 
-	      ~hpolicy:`AUTOMATIC 
-	      ~vpolicy:`AUTOMATIC 
+  let scw = GBin.scrolled_window
+	      ~hpolicy:`AUTOMATIC
+	      ~vpolicy:`AUTOMATIC
 	      ~packing:(hbox#pack ~expand:true) () in
 
   let columns = new GTree.column_list in
   let command_col =  columns#add Data.string in
   let coq_col = columns#add Data.string in
   let store = GTree.list_store columns
-  in 
+  in
 
 (* populate the store *)
-  let _ = List.iter (fun (x,y) -> 
+  let _ = List.iter (fun (x,y) ->
 		       let row = store#append () in
 		       store#set ~row ~column:command_col x;
 		       store#set ~row ~column:coq_col y)
@@ -27,61 +27,61 @@ let create l =
   view#set_rules_hint true;
 
   let renderer_comm = GTree.cell_renderer_text [`EDITABLE true]  in
-  ignore (renderer_comm#connect#edited 
-    ~callback:(fun (path:Gtk.tree_path) (s:string) -> 
-		 store#set 
-		 ~row:(store#get_iter path) 
+  ignore (renderer_comm#connect#edited
+    ~callback:(fun (path:Gtk.tree_path) (s:string) ->
+		 store#set
+		 ~row:(store#get_iter path)
 		 ~column:command_col s));
-  let first = 
-    GTree.view_column ~title:"Coq Command to try" 
-      ~renderer:(renderer_comm,["text",command_col]) 
-      () 
+  let first =
+    GTree.view_column ~title:"Coq Command to try"
+      ~renderer:(renderer_comm,["text",command_col])
+      ()
   in ignore (view#append_column first);
 
   let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in
   ignore(renderer_coq#connect#edited
-	   ~callback:(fun (path:Gtk.tree_path) (s:string) -> 
-			store#set 
-			~row:(store#get_iter path) 
+	   ~callback:(fun (path:Gtk.tree_path) (s:string) ->
+			store#set
+			~row:(store#get_iter path)
 			~column:coq_col s));
-  let second = 
-    GTree.view_column ~title:"Coq Command to insert" 
-      ~renderer:(renderer_coq,["text",coq_col]) 
-      () 
+  let second =
+    GTree.view_column ~title:"Coq Command to insert"
+      ~renderer:(renderer_coq,["text",coq_col])
+      ()
   in ignore (view#append_column second);
 
-  let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () 
+  let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD ()
   in
   let up = GButton.button  ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in
-  let down = GButton.button 
-	       ~stock:`GO_DOWN 
-	       ~label:"Down" 
-	       ~packing:(vbox#pack ~expand:true ~fill:false) () 
+  let down = GButton.button
+	       ~stock:`GO_DOWN
+	       ~label:"Down"
+	       ~packing:(vbox#pack ~expand:true ~fill:false) ()
   in
-  let add = GButton.button ~stock:`ADD 
-	      ~label:"Add" 
-	      ~packing:(vbox#pack ~expand:true ~fill:false) 
-	      () 
+  let add = GButton.button ~stock:`ADD
+	      ~label:"Add"
+	      ~packing:(vbox#pack ~expand:true ~fill:false)
+	      ()
   in
-  let remove = GButton.button ~stock:`REMOVE 
-		 ~label:"Remove" 
-		 ~packing:(vbox#pack ~expand:true ~fill:false) () 
+  let remove = GButton.button ~stock:`REMOVE
+		 ~label:"Remove"
+		 ~packing:(vbox#pack ~expand:true ~fill:false) ()
   in
 
-  ignore (add#connect#clicked 
-	    ~callback:(fun b ->  
+  ignore (add#connect#clicked
+	    ~callback:(fun b ->
 			 let n = store#append () in
 			 view#selection#select_iter n));
-  ignore (remove#connect#clicked 
-	    ~callback:(fun b -> match view#selection#get_selected_rows with 
+  ignore (remove#connect#clicked
+	    ~callback:(fun b -> match view#selection#get_selected_rows with
 			 | [] -> ()
 			 | path::_ ->
 			     let iter = store#get_iter path in
 		       	     ignore (store#remove iter);
 		      ));
-  ignore (up#connect#clicked 
-	    ~callback:(fun b ->  
-			 match view#selection#get_selected_rows with 
+  ignore (up#connect#clicked
+	    ~callback:(fun b ->
+			 match view#selection#get_selected_rows with
 			   | [] -> ()
 			   | path::_ ->
 			       let iter = store#get_iter path in
@@ -89,9 +89,9 @@ let create l =
 			       let upiter = store#get_iter path in
 			       ignore (store#swap iter upiter);
 		      ));
-  ignore (down#connect#clicked 
-	    ~callback:(fun b ->  
-			 match view#selection#get_selected_rows with 
+  ignore (down#connect#clicked
+	    ~callback:(fun b ->
+			 match view#selection#get_selected_rows with
 			   | [] -> ()
 			   | path::_ ->
 			       let iter = store#get_iter path in
@@ -100,13 +100,13 @@ let create l =
 			       ignore (store#swap iter upiter)
 			       with _ -> ()
 		      ));
-  let get_data () = 
+  let get_data () =
     let start_path = GtkTree.TreePath.from_string "0" in
     let start_iter = store#get_iter start_path in
-    let rec all acc = 
+    let rec all acc =
       let new_acc = (store#get ~row:start_iter ~column:command_col,
 		     store#get ~row:start_iter ~column:coq_col)::acc
-      in      
+      in
       if store#iter_next start_iter then all new_acc else List.rev new_acc
     in all []
   in
diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli
index c8d48389..84ea4df4 100644
--- a/ide/utils/okey.mli
+++ b/ide/utils/okey.mli
@@ -23,7 +23,7 @@
 (*                                                                               *)
 (*********************************************************************************)
 
-(** Okey interface. 
+(** Okey interface.
 
    Once the lib is compiled and installed, you can use it by referencing
    it with the [Okey] module. You must add [okey.cmo] or [okey.cmx]
@@ -35,7 +35,7 @@ type modifier = Gdk.Tags.modifier
 (** Set the default modifier list. The first default value is [[]].*)
 val set_default_modifiers : modifier list -> unit
 
-(** Set the default modifier mask. The first default value is 
+(** Set the default modifier mask. The first default value is
    [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]].
    The mask defines the modifiers not taken into account
    when looking for the handler of a key press event.
@@ -48,67 +48,67 @@ val set_default_mask : modifier list -> unit
    @param remove when true, the previous handlers for the given key and modifier
    list are not kept.
    @param cond this function is a guard: the [callback] function is not called
-   if the [cond] function returns [false]. 
+   if the [cond] function returns [false].
    The default [cond] function always returns [true].
 
    @param mods the list of modifiers. If not given, the default modifiers
-   are used. 
+   are used.
    You can set the default modifiers with function {!Okey.set_default_modifiers}.
 
    @param mask the list of modifiers which must not be taken
    into account to trigger the given handler. [mods]
    and [mask] must not have common modifiers. If not given, the default mask
-   is used. 
+   is used.
    You can set the default modifiers mask with function {!Okey.set_default_mask}.
 *)
 val add :
     < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
-      event : GObj.event_ops; get_oid : int; .. > -> 
-	?cond: (unit -> bool) -> 
-	  ?mods: modifier list -> 
-	    ?mask: modifier list -> 
-	      Gdk.keysym -> 
-		(unit -> unit) -> 
+      event : GObj.event_ops; get_oid : int; .. > ->
+	?cond: (unit -> bool) ->
+	  ?mods: modifier list ->
+	    ?mask: modifier list ->
+	      Gdk.keysym ->
+		(unit -> unit) ->
 		  unit
 
 (** It calls {!Okey.add} for each given key.*)
-val add_list : 
+val add_list :
     < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
-      event : GObj.event_ops; get_oid : int; .. > -> 
-	?cond: (unit -> bool) -> 
-	  ?mods: modifier list -> 
-	    ?mask: modifier list -> 
-	      Gdk.keysym list -> 
-		(unit -> unit) -> 
+      event : GObj.event_ops; get_oid : int; .. > ->
+	?cond: (unit -> bool) ->
+	  ?mods: modifier list ->
+	    ?mask: modifier list ->
+	      Gdk.keysym list ->
+		(unit -> unit) ->
 		  unit
-	      
+
 (** Like {!Okey.add} but the previous handlers for the
    given modifiers and key are not kept.*)
 val set :
     < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
-      event : GObj.event_ops; get_oid : int; .. > -> 
-	?cond: (unit -> bool) -> 
-	  ?mods: modifier list -> 
-	    ?mask: modifier list -> 
-	      Gdk.keysym -> 
-		(unit -> unit) -> 
+      event : GObj.event_ops; get_oid : int; .. > ->
+	?cond: (unit -> bool) ->
+	  ?mods: modifier list ->
+	    ?mask: modifier list ->
+	      Gdk.keysym ->
+		(unit -> unit) ->
 		  unit
 
 (** It calls {!Okey.set} for each given key.*)
-val set_list : 
+val set_list :
     < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
       event : GObj.event_ops; get_oid : int; .. > ->
-	?cond: (unit -> bool) -> 
-	  ?mods: modifier list -> 
-	    ?mask: modifier list -> 
-	      Gdk.keysym list -> 
-		(unit -> unit) -> 
+	?cond: (unit -> bool) ->
+	  ?mods: modifier list ->
+	    ?mask: modifier list ->
+	      Gdk.keysym list ->
+		(unit -> unit) ->
 		  unit
 
 (** Remove the handlers associated to the given widget.
    This is automatically done when a widget is destroyed but
    you can do it yourself. *)
-val remove_widget : 
+val remove_widget :
     < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
       event : GObj.event_ops; get_oid : int; .. > ->
 	unit ->
diff --git a/ide/utils/uoptions.ml b/ide/utils/uoptions.ml
deleted file mode 100644
index aa3b42cd..00000000
--- a/ide/utils/uoptions.ml
+++ /dev/null
@@ -1,772 +0,0 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
-
-(** Simple options:
-  This will enable very simple configuration, by a mouse-based configurator.
-  Flags.will be defined by a special function, which will also check
-  if a value has been provided  by the user in its .gwmlrc file.
-  The .gwmlrc will be created by a dedicated tool, which could be used
-  to generate both .gwmlrc and .efunsrc files.
-
-Note: this is redundant, since such options could also be better set
-in the .Xdefaults file (using Xrm to load them). Maybe we should merge
-both approaches in a latter release.
-  
-   Code from Fabrice Le Fessant.
-
-    *)
-  
-type option_value =
-    Module of option_module
-  | StringValue of string
-  | IntValue of int
-  | FloatValue of float
-  | List of option_value list
-  | SmallList of option_value list
-and option_module = (string * option_value) list
-;;
-
-
-
-type 'a option_class =
-  { class_name : string;
-    from_value : option_value -> 'a;
-    to_value : 'a -> option_value;
-    mutable class_hooks : ('a option_record -> unit) list }
-  
-and 'a option_record =
-  { option_name : string list;
-    option_class : 'a option_class;
-    mutable option_value : 'a;
-    option_help : string;
-    mutable option_hooks : (unit -> unit) list;
-    mutable string_wrappers : (('a -> string) * (string -> 'a)) option;
-    option_file : options_file;
-  }
-  
-and options_file = {
-    mutable file_name : string; 
-    mutable file_options : Obj.t option_record list;
-    mutable file_rc : option_module;
-    mutable file_pruned : bool;
-  }
-;;
-
-let create_options_file name =
-  ignore
-    (
-     if not (Sys.file_exists name) then
-       let oc = open_out name in 
-       close_out oc
-    );
-  {
-    file_name = name;
-    file_options =[];
-    file_rc = [];
-    file_pruned = false;
-  }
-  
-let set_options_file opfile name = opfile.file_name <- name
-
-let
-  define_option_class
-    (class_name : string)
-    (from_value : option_value -> 'a)
-    (to_value : 'a -> option_value) =
-  let c =
-    {class_name = class_name; 
-      from_value = from_value; 
-      to_value = to_value;
-     class_hooks = []}
-  in
-  c
-;;  
-
-(*
-let filename =
-  ref
-    (Filename.concat Sysenv.home
-       ("." ^ Filename.basename Sys.argv.(0) ^ "rc"))
-;;
-let gwmlrc = ref [];;
-
-let options = ref [];;
-*)
-
-let rec find_value list m =
-  match list with
-    [] -> raise Not_found
-  | name :: tail ->
-      let m = List.assoc name m in
-      match m, tail with
-        _, [] -> m
-      | Module m, _ :: _ -> find_value tail m
-      | _ -> raise Not_found
-;;
-
-let prune_file file =
-  file.file_pruned <- true
-
-let
-  define_option
-    (opfile : options_file)
-    (option_name : string list)
-    (option_help : string)
-    (option_class : 'a option_class)
-    (default_value : 'a) =
-  let o =
-    {option_name = option_name; 
-      option_help = option_help;
-      option_class = option_class; 
-      option_value = default_value;
-      string_wrappers = None;
-      option_hooks = []; 
-      option_file = opfile; }
-  in
-  opfile.file_options <- (Obj.magic o : Obj.t option_record) ::
-    opfile.file_options;
-  o.option_value <-
-    begin try o.option_class.from_value (find_value option_name 
-        opfile.file_rc) with
-      Not_found -> default_value
-    | e ->
-        Printf.printf "Flags.define_option, for option %s: "
-          (match option_name with
-             [] -> "???"
-           | name :: _ -> name);
-        Printf.printf "%s" (Printexc.to_string e);
-        print_newline ();
-        default_value
-    end;
-  o
-;;
-
-  
-open Genlex;;
-  
-let lexer = make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","; "."];;
-  
-let rec parse_gwmlrc (strm__ : _ Stream.t) =
-  match
-    try Some (parse_id strm__) with
-      Stream.Failure -> None
-  with
-    Some id ->
-      begin match Stream.peek strm__ with
-        Some (Kwd "=") ->
-          Stream.junk strm__;
-          let v =
-            try parse_option strm__ with
-              Stream.Failure -> raise (Stream.Error "")
-          in
-          let eof =
-            try parse_gwmlrc strm__ with
-              Stream.Failure -> raise (Stream.Error "")
-          in
-          (id, v) :: eof
-      | _ -> raise (Stream.Error "")
-      end
-  | _ -> []
-and parse_option (strm__ : _ Stream.t) =
-  match Stream.peek strm__ with
-    Some (Kwd "{") ->
-      Stream.junk strm__;
-      let v =
-        try parse_gwmlrc strm__ with
-          Stream.Failure -> raise (Stream.Error "")
-      in
-      begin match Stream.peek strm__ with
-        Some (Kwd "}") -> Stream.junk strm__; Module v
-      | _ -> raise (Stream.Error "")
-      end
-  | Some (Ident s) -> Stream.junk strm__; StringValue s
-  | Some (String s) -> Stream.junk strm__; StringValue s
-  | Some (Int i) -> Stream.junk strm__; IntValue i
-  | Some (Float f) -> Stream.junk strm__; FloatValue f
-  | Some (Char c) ->
-      Stream.junk strm__;
-      StringValue (let s = String.create 1 in s.[0] <- c; s)
-  | Some (Kwd "[") ->
-      Stream.junk strm__;
-      let v =
-        try parse_list strm__ with
-          Stream.Failure -> raise (Stream.Error "")
-      in
-      List v
-  | Some (Kwd "(") ->
-      Stream.junk strm__;
-      let v =
-        try parse_list strm__ with
-          Stream.Failure -> raise (Stream.Error "")
-      in
-      List v
-  | _ -> raise Stream.Failure
-and parse_id (strm__ : _ Stream.t) =
-  match Stream.peek strm__ with
-    Some (Ident s) -> Stream.junk strm__; s
-  | Some (String s) -> Stream.junk strm__; s
-  | _ -> raise Stream.Failure
-and parse_list (strm__ : _ Stream.t) =
-  match Stream.peek strm__ with
-    Some (Kwd ";") ->
-      Stream.junk strm__;
-      begin try parse_list strm__ with
-        Stream.Failure -> raise (Stream.Error "")
-      end
-  | Some (Kwd ",") ->
-      Stream.junk strm__;
-      begin try parse_list strm__ with
-        Stream.Failure -> raise (Stream.Error "")
-      end
-  | Some (Kwd ".") ->
-      Stream.junk strm__;
-      begin try parse_list strm__ with
-        Stream.Failure -> raise (Stream.Error "")
-      end
-  | _ ->
-      match
-        try Some (parse_option strm__) with
-          Stream.Failure -> None
-      with
-        Some v ->
-          let t =
-            try parse_list strm__ with
-              Stream.Failure -> raise (Stream.Error "")
-          in
-          v :: t
-      | _ ->
-          match Stream.peek strm__ with
-            Some (Kwd "]") -> Stream.junk strm__; []
-          | Some (Kwd ")") -> Stream.junk strm__; []
-          | _ -> raise Stream.Failure
-;;
-
-let exec_hooks o =
-  List.iter
-    (fun f ->
-       try f () with
-         _ -> ())
-    o.option_hooks
-;;  
-
-let exec_chooks o =
-  List.iter
-    (fun f ->
-       try f o with
-         _ -> ())
-    o.option_class.class_hooks
-;;  
-  
-let really_load filename options =
-  let temp_file = filename ^ ".tmp" in
-  if Sys.file_exists temp_file then begin
-      Printf.printf 
-        "File %s exists\n" temp_file;
-      Printf.printf 
-        "An error may have occurred during previous configuration save.\n";
-      Printf.printf 
-        "Please, check your configurations files, and rename/remove this file\n";
-      Printf.printf "before restarting";
-      print_newline ();
-      exit 1
-    end 
-  else
-    let ic = open_in filename in
-    let s = Stream.of_channel ic in
-    try
-      let stream = lexer s in
-      let list =
-	try parse_gwmlrc stream with
-          e ->
-            Printf.printf "At pos %d/%d" (Stream.count s) (Stream.count stream);
-            print_newline ();
-            raise e
-      in
-      List.iter
-	(fun o ->
-          try
-            o.option_value <-
-              o.option_class.from_value (find_value o.option_name list);
-            exec_chooks o;
-            exec_hooks o
-          with
-            e ->
-             ()
-	)
-	options;
-      list
-    with
-      e ->
-	Printf.printf "Error %s in %s" (Printexc.to_string e) filename;
-	print_newline ();
-	[]
-;;
-      
-let load opfile =
-  try opfile.file_rc <- really_load opfile.file_name opfile.file_options with
-    Not_found -> 
-      Printf.printf "No %s found" opfile.file_name; print_newline ()
-;;
-
-let append opfile filename =
-  try opfile.file_rc <-
-    really_load filename opfile.file_options @ opfile.file_rc with
-    Not_found -> 
-      Printf.printf "No %s found" filename; print_newline ()
-;;
-      
-let ( !! ) o = o.option_value;;
-let ( =:= ) o v = o.option_value <- v; exec_chooks o; exec_hooks o;;
-    
-let value_to_string v =
-  match v with
-    StringValue s -> s
-  | IntValue i -> string_of_int i
-  | FloatValue f -> string_of_float f
-  | _ -> failwith "Flags. not a string option"
-;;
-      
-let string_to_value s = StringValue s;;
-  
-let value_to_int v =
-  match v with
-    StringValue s -> int_of_string s
-  | IntValue i -> i
-  | _ -> failwith "Flags. not an int option"
-;;
-
-let int_to_value i = IntValue i;;
-
-(* The Pervasives version is too restrictive *)
-let bool_of_string s =
-  match String.lowercase s with
-    "true" -> true
-  | "false" -> false
-  | "yes" -> true
-  | "no" -> false
-  | "y" -> true
-  | "n" -> false
-  | _ -> invalid_arg "bool_of_string"
-;;
-
-let value_to_bool v =
-  match v with
-    StringValue s -> bool_of_string s
-  | IntValue v when v = 0 -> false
-  | IntValue v when v = 1 -> true
-  | _ -> failwith "Flags. not a bool option"
-;;
-let bool_to_value i = StringValue (string_of_bool i);;
-
-let value_to_float v =
-  match v with
-    StringValue s -> float_of_string s
-  | FloatValue f -> f
-  | _ -> failwith "Flags. not a float option"
-;; 
-
-let float_to_value i = FloatValue i;;
-
-let value_to_string2 v =
-  match v with
-    List [s1; s2] | SmallList [s1;s2] -> 
-      value_to_string s1, value_to_string s2
-  | _ -> failwith "Flags. not a string2 option"
-;;
-
-let string2_to_value (s1, s2) = SmallList [StringValue s1; StringValue s2];;
-
-let value_to_list v2c v =
-  match v with
-    List l | SmallList l -> List.rev (List.rev_map v2c l)
-  | StringValue s -> failwith (Printf.sprintf 
-        "Flags. not a list option (StringValue [%s])" s)
-  | FloatValue _ -> failwith "Flags. not a list option (FloatValue)"
-  | IntValue _ -> failwith "Flags. not a list option (IntValue)"
-  | Module _ -> failwith "Flags. not a list option (Module)"
-;;
-
-let list_to_value c2v l =
-  List
-    (List.fold_right
-      (fun v list ->
-          try c2v v :: list with
-            _ -> list)
-       l [])
-;;
-  
-let smalllist_to_value c2v l =
-  SmallList
-    (List.fold_right
-       (fun v list ->
-          try c2v v :: list with
-            _ -> list)
-       l [])
-;;
-
-let string_option =
-  define_option_class "String" value_to_string string_to_value
-;;
-let color_option =
-  define_option_class "Color" value_to_string string_to_value
-;;
-let font_option = define_option_class "Font" value_to_string string_to_value;;
-
-let int_option = define_option_class "Int" value_to_int int_to_value;;
-
-let bool_option = define_option_class "Bool" value_to_bool bool_to_value;;
-let float_option = define_option_class "Float" value_to_float float_to_value;;
-
-let string2_option =
-  define_option_class "String2" value_to_string2 string2_to_value
-;;
-
-let list_option cl =
-  define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
-    (list_to_value cl.to_value)
-;;
-
-let smalllist_option cl =
-  define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
-    (smalllist_to_value cl.to_value)
-;;
-
-let to_value cl = cl.to_value;;
-let from_value cl = cl.from_value;;
-  
-let value_to_sum l v =
-  match v with
-    StringValue s -> List.assoc s l
-  | _ -> failwith "Flags. not a sum option"
-;;
-  
-let sum_to_value l v = StringValue (List.assq v l);;
-  
-let sum_option l =
-  let ll = List.map (fun (a1, a2) -> a2, a1) l in
-  define_option_class "Sum" (value_to_sum l) (sum_to_value ll)
-;;
-
-let exit_exn = Exit;;
-let safe_string s =
-  if s = "" then "\"\""
-  else
-    try
-      match s.[0] with
-        'a'..'z' | 'A'..'Z' ->
-          for i = 1 to String.length s - 1 do
-            match s.[i] with
-              'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> ()
-            | _ -> raise exit_exn
-          done;
-          s
-      | _ ->
-          if string_of_int (int_of_string s) = s ||
-             string_of_float (float_of_string s) = s then
-            s
-          else raise exit_exn
-    with
-      _ -> Printf.sprintf "\"%s\"" (String.escaped s)
-;;
-
-let with_help = ref false;;
-      
-let rec save_module indent oc list =
-  let subm = ref [] in
-  List.iter
-    (fun (name, help, value) ->
-       match name with
-         [] -> assert false
-       | [name] ->
-           if !with_help && help <> "" then
-             Printf.fprintf oc "(* %s *)\n" help;
-           Printf.fprintf oc "%s %s = " indent (safe_string name);
-           save_value indent oc value;
-           Printf.fprintf oc "\n"
-       | m :: tail ->
-           let p =
-             try List.assoc m !subm with
-               _ -> let p = ref [] in subm := (m, p) :: !subm; p
-           in
-           p := (tail, help, value) :: !p)
-    list;
-  List.iter
-    (fun (m, p) ->
-       Printf.fprintf oc "%s %s = {\n" indent (safe_string m);
-       save_module (indent ^ "  ") oc !p;
-       Printf.fprintf oc "%s}\n" indent)
-    !subm
-and save_list indent oc list =
-  match list with
-    [] -> ()
-  | [v] -> save_value indent oc v
-  | v :: tail ->
-      save_value indent oc v; Printf.fprintf oc ", "; save_list indent oc tail
-and save_list_nl indent oc list =
-  match list with
-    [] -> ()
-  | [v] -> Printf.fprintf oc "\n%s" indent; save_value indent oc v
-  | v :: tail ->
-      Printf.fprintf oc "\n%s" indent;
-      save_value indent oc v;
-      Printf.fprintf oc ";";
-      save_list_nl indent oc tail
-and save_value indent oc v =
-  match v with
-    StringValue s -> Printf.fprintf oc "%s" (safe_string s)
-  | IntValue i -> Printf.fprintf oc "%d" i
-  | FloatValue f -> Printf.fprintf oc "%f" f
-  | List l ->
-      Printf.fprintf oc "[";
-      save_list_nl (indent ^ "  ") oc l;
-      Printf.fprintf oc "]"
-  | SmallList l ->
-      Printf.fprintf oc "(";
-      save_list (indent ^ "  ") oc l;
-      Printf.fprintf oc ")"
-  | Module m -> 
-      Printf.fprintf oc "{";
-      save_module_fields (indent ^ "  ") oc m;
-      Printf.fprintf oc "}"
-      
-and save_module_fields indent oc m =
-  match m with
-    [] -> ()
-  | (name, v) :: tail ->
-      Printf.fprintf oc "%s %s = " indent (safe_string name);
-      save_value indent oc v;
-      Printf.fprintf oc "\n";
-      save_module_fields indent oc tail
-;;
-    
-let save opfile =
-  let filename = opfile.file_name in
-  let temp_file = filename ^ ".tmp" in
-  let old_file = filename ^ ".old" in
-  let oc = open_out temp_file in
-  save_module "" oc
-    (List.map
-      (fun o ->
-        o.option_name, o.option_help,
-        (try 
-            o.option_class.to_value o.option_value 
-          with
-            e ->
-              Printf.printf "Error while saving option \"%s\": %s"
-                (try List.hd o.option_name with
-                  _ -> "???")
-              (Printexc.to_string e);
-              print_newline ();
-              StringValue ""))
-    (List.rev opfile.file_options));
-  if not opfile.file_pruned then begin
-      Printf.fprintf oc
-        "\n(*\n The following options are not used (errors, obsolete, ...) \n*)\n";
-      List.iter
-        (fun (name, value) ->
-          try
-            List.iter
-              (fun o ->
-                match o.option_name with
-                  n :: _ -> if n = name then raise Exit
-                | _ -> ())
-            opfile.file_options;
-            Printf.fprintf oc "%s = " (safe_string name);
-            save_value "  " oc value;
-            Printf.fprintf oc "\n"
-          with
-            _ -> ())
-      opfile.file_rc;
-    end;
-  close_out oc;
-  (try Sys.rename filename old_file with _ -> ());
-  (try Sys.rename temp_file filename with _ -> ())
-;;
-
-let save_with_help opfile =
-  with_help := true;
-  begin try save opfile with
-    _ -> ()
-  end;
-  with_help := false
-;;
-  
-let option_hook option f = option.option_hooks <- f :: option.option_hooks;;
-  
-let class_hook option_class f =
-  option_class.class_hooks <- f :: option_class.class_hooks
-;;
-
-let rec iter_order f list =
-  match list with
-    [] -> ()
-  | v :: tail -> f v; iter_order f tail
-;;
-  
-let help oc opfile =
-  List.iter
-    (fun o ->
-       Printf.fprintf oc "OPTION \"";
-       begin match o.option_name with
-         [] -> Printf.fprintf oc "???"
-       | [name] -> Printf.fprintf oc "%s" name
-       | name :: tail ->
-           Printf.fprintf oc "%s" name;
-           iter_order (fun name -> Printf.fprintf oc ":%s" name) o.option_name
-       end;
-       Printf.fprintf oc "\" (TYPE \"%s\"): %s\n   CURRENT: \n"
-         o.option_class.class_name o.option_help;
-       begin try
-         save_value "" oc (o.option_class.to_value o.option_value)
-       with
-         _ -> ()
-       end;
-       Printf.fprintf oc "\n")
-    opfile.file_options;
-  flush oc
-;;
-  
-    
-let tuple2_to_value (c1, c2) (a1, a2) =
-  SmallList [to_value c1 a1; to_value c2 a2]
-;;
-  
-let value_to_tuple2 (c1, c2) v =
-  match v with
-    List [v1; v2] -> from_value c1 v1, from_value c2 v2
-  | SmallList [v1; v2] -> from_value c1 v1, from_value c2 v2
-  | List l | SmallList l ->
-      Printf.printf "list of %d" (List.length l);
-      print_newline ();
-      failwith "Flags. not a tuple2 list option"
-  | _ -> failwith "Flags. not a tuple2 option"
-;;
-  
-let tuple2_option p =
-  define_option_class "tuple2_option" (value_to_tuple2 p) (tuple2_to_value p)
-;;
-  
-let tuple3_to_value (c1, c2, c3) (a1, a2, a3) =
-  SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3]
-;;
-let value_to_tuple3 (c1, c2, c3) v =
-  match v with
-    List [v1; v2; v3] -> from_value c1 v1, from_value c2 v2, from_value c3 v3
-  | SmallList [v1; v2; v3] ->
-      from_value c1 v1, from_value c2 v2, from_value c3 v3
-  | _ -> failwith "Flags. not a tuple3 option"
-;;
-      
-let tuple3_option p =
-  define_option_class "tuple3_option" (value_to_tuple3 p) (tuple3_to_value p)
-;;
-
-let tuple4_to_value (c1, c2, c3, c4) (a1, a2, a3, a4) =
-  SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3; to_value c4 a4]
-;;
-let value_to_tuple4 (c1, c2, c3, c4) v =
-  match v with
-    List [v1; v2; v3; v4] -> 
-      (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4)
-  | SmallList [v1; v2; v3; v4] ->
-      (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4)
-  | _ -> failwith "Flags. not a tuple4 option"
-;;
-      
-let tuple4_option p =
-  define_option_class "tuple4_option" (value_to_tuple4 p) (tuple4_to_value p)
-;;
-
-
-let shortname o = String.concat ":" o.option_name;;
-let get_class o = o.option_class;;
-let get_help o =
-  let help = o.option_help in if help = "" then "No Help Available" else help
-;;
-
-
-let simple_options opfile =
-  let list = ref [] in
-  List.iter (fun o ->
-      match o.option_name with
-        [] | _ :: _ :: _ -> ()
-      | [name] ->
-          match o.option_class.to_value o.option_value with
-            Module _ | SmallList _ | List _ -> 
-              begin
-                match o.string_wrappers with
-                  None -> ()
-                | Some (to_string, from_string) ->
-                    list := (name, to_string o.option_value) :: !list   
-              end
-          | v -> 
-              list := (name, value_to_string v) :: !list
-  ) opfile.file_options;
-  !list
-
-let get_option opfile name =
-  let rec iter name list = 
-    match list with 
-      [] -> raise Not_found
-    | o :: list ->
-        if o.option_name = name then o
-        else iter name list
-  in
-  iter [name] opfile.file_options
-  
-  
-let set_simple_option opfile name v =
-  let o = get_option opfile name in
-  begin
-    match o.string_wrappers with
-      None ->
-        o.option_value <- o.option_class.from_value (string_to_value v);
-    | Some (_, from_string) -> 
-        o.option_value <- from_string v
-  end;
-  exec_chooks o; exec_hooks o;;
-    
-let get_simple_option opfile name =
-  let o = get_option opfile name in
-  match o.string_wrappers with
-    None ->
-      value_to_string (o.option_class.to_value o.option_value)
-  | Some (to_string, _) -> 
-      to_string o.option_value
-  
-let set_option_hook opfile name hook =
-  let o = get_option opfile name in
-  o.option_hooks <- hook :: o.option_hooks
-  
-let set_string_wrappers o to_string from_string =
-  o.string_wrappers <- Some (to_string, from_string)
-
-let simple_args opfile =
-  List.map (fun (name, v) ->
-      ("-" ^ name), 
-      Arg.String (set_simple_option opfile name), 
-      (Printf.sprintf "<string> : \t%s (current: %s)"
-          (get_option opfile name).option_help
-          v)
-  ) (simple_options opfile)
diff --git a/ide/utils/uoptions.mli b/ide/utils/uoptions.mli
deleted file mode 100644
index a323ac60..00000000
--- a/ide/utils/uoptions.mli
+++ /dev/null
@@ -1,148 +0,0 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
-
-(**
- This module implements a simple mechanism to handle program options files.
-  An options file is defined as a set of [variable = value] lines,
-  where value can be a simple string, a list of values (between brackets
-or parentheses) or a set of [variable = value] lines between braces.
-The option file is automatically loaded and saved, and options are
-manipulated inside the program as easily as references. 
-
-   Code from Fabrice Le Fessant.
-*)
-
-type 'a option_class
-(** The abstract type for a class of options. A class is a set of options
-which use the same conversion functions from loading and saving.*)
-  
-type 'a option_record
-(** The abstract type for an option *)
-
-type options_file
-
-val create_options_file : string -> options_file
-val set_options_file : options_file -> string -> unit
-val prune_file : options_file -> unit  
-
-(** {2 Operations on option files} *)
-  
-val load : options_file -> unit
-(** [load file] loads the option file. All options whose value is specified
-   in the option file are updated. *)
-  
-val append : options_file -> string -> unit
-(** [append filename] loads the specified option file. All options whose 
-value is specified in this file are updated. *)
-  
-val save : options_file -> unit
-(** [save file] saves all the options values to the option file. *)
-
-val save_with_help : options_file -> unit
-(** [save_with_help ()] saves all the options values to the option file,
-   with the help provided for each option. *)
-  
-(** {2  Creating options} *)  
-
-val define_option : options_file ->
-  string list ->  string -> 'a option_class -> 'a -> 'a option_record
-val option_hook : 'a option_record -> (unit -> unit) -> unit
-    
-val string_option : string option_class
-val color_option : string option_class
-val font_option : string option_class
-val int_option : int option_class
-val bool_option : bool option_class
-val float_option : float option_class
-val string2_option : (string * string) option_class
-  
-  (* parameterized options *)
-val list_option : 'a option_class -> 'a list option_class
-val smalllist_option : 'a option_class -> 'a list option_class
-val sum_option : (string * 'a) list -> 'a option_class
-val tuple2_option :  
-  'a option_class * 'b option_class -> ('a * 'b) option_class
-val tuple3_option : 'a option_class * 'b option_class * 'c option_class ->
-  ('a * 'b * 'c) option_class
-val tuple4_option : 
-    'a option_class * 'b option_class * 'c option_class * 'd option_class ->
-  ('a * 'b * 'c * 'd) option_class
-
-(** {2  Using options} *)
-  
-val ( !! ) : 'a option_record -> 'a
-val ( =:= ) : 'a option_record -> 'a -> unit
-
-val shortname : 'a option_record -> string
-val get_help : 'a option_record -> string  
-  
-(** {2 Creating new option classes} *)
-
-val get_class : 'a option_record -> 'a option_class
-
-val class_hook : 'a option_class -> ('a option_record -> unit) -> unit
-
-type option_value =
-  Module of option_module
-| StringValue of  string
-| IntValue of int
-| FloatValue of float
-| List of option_value list
-| SmallList of option_value list
-  
-and option_module =
-  (string * option_value) list
-
-val define_option_class :
-  string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class
-
-val to_value : 'a option_class -> 'a -> option_value
-val from_value : 'a option_class -> option_value -> 'a
-  
-val value_to_string : option_value -> string
-val string_to_value : string -> option_value
-val value_to_int : option_value -> int
-val int_to_value : int -> option_value
-val bool_of_string : string -> bool
-val value_to_bool : option_value -> bool
-val bool_to_value : bool -> option_value
-val value_to_float : option_value -> float
-val float_to_value : float -> option_value
-val value_to_string2 : option_value -> string * string
-val string2_to_value : string * string -> option_value
-val value_to_list : (option_value -> 'a) -> option_value -> 'a list
-val list_to_value : ('a -> option_value) -> 'a list -> option_value
-val smalllist_to_value : ('a -> option_value) -> 'a list -> option_value
-
-val set_simple_option : options_file -> string -> string -> unit
-val simple_options : options_file -> (string * string) list
-val get_simple_option : options_file -> string -> string
-val set_option_hook : options_file -> string -> (unit -> unit) -> unit
-  
-val set_string_wrappers : 'a option_record -> 
-  ('a -> string) -> (string -> 'a) -> unit
-
-(** {2 Other functions} *)
-
-val simple_args : options_file -> (string * Arg.spec * string) list
diff --git a/install.sh b/install.sh
index 277222f5..4b3abe5c 100755
--- a/install.sh
+++ b/install.sh
@@ -9,5 +9,3 @@ for f; do
   install -d "$dest/$dn"
   install -m 644 $f "$dest/$dn/$bn"
 done
-
-
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 99bcf159..e61dffeb 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrextern.ml 12495 2009-11-11 12:10:44Z herbelin $ *)
+(* $Id$ *)
 
 (*i*)
 open Pp
@@ -16,6 +16,7 @@ open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Inductive
 open Sign
 open Environ
@@ -92,19 +93,6 @@ let insert_pat_alias loc p = function
 (**********************************************************************)
 (* conversion of references                                           *)
 
-let ids_of_ctxt ctxt =
-  Array.to_list
-    (Array.map
-       (function c -> match kind_of_term c with
-	  | Var id -> id
-	  | _ ->
-       error "Arbitrary substitution of references not implemented.")
-     ctxt)
-
-let idopt_of_name = function 
-  | Name id -> Some id
-  | Anonymous -> None
-
 let extern_evar loc n l =
   if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None)
 
@@ -279,8 +267,8 @@ let rec same_raw c d =
   | r1, RCast(_,c2,_) -> same_raw r1 c2
   | RDynamic(_,d1), RDynamic(_,d2) -> if d1<>d2 then failwith"RDynamic"
   | _ -> failwith "same_raw"
-     
-let same_rawconstr c d = 
+
+let same_rawconstr c d =
   try same_raw c d; true
   with Failure _ | Invalid_argument _ -> false
 
@@ -305,12 +293,12 @@ let expand_curly_brackets loc mknot ntn (l,ll) =
     function
     | [] -> []
     | a::l ->
-        let a' = 
+        let a' =
           let p = List.nth (wildcards !ntn' 0) i - 2 in
           if p>=0 & p+5 <= String.length !ntn' & String.sub !ntn' p 5 = "{ _ }"
           then begin
-            ntn' := 
-              String.sub !ntn' 0 p ^ "_" ^ 
+            ntn' :=
+              String.sub !ntn' 0 p ^ "_" ^
               String.sub !ntn' (p+5) (String.length !ntn' -p-5);
             mknot (loc,"{ _ }",([a],[])) end
           else a in
@@ -329,7 +317,7 @@ let make_notation_gen loc ntn mknot mkprim destprim l =
     (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *)
     | "- _", [Some (Numeral p)],[] when Bigint.is_strictly_pos p ->
         mknot (loc,ntn,([mknot (loc,"( _ )",l)],[]))
-    | _ -> 
+    | _ ->
 	match decompose_notation_key ntn, l with
 	| [Terminal "-"; Terminal x], ([],[]) ->
 	    (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x)))
@@ -352,80 +340,72 @@ let make_pat_notation loc ntn l =
     (fun (loc,p) -> CPatPrim (loc,p))
     destPatPrim l
 
-let bind_env (sigma,sigmalist as fullsigma) var v =
-  try
-    let vvar = List.assoc var sigma in
-    if v=vvar then fullsigma else raise No_match
-  with Not_found ->
-    (* TODO: handle the case of multiple occs in different scopes *)
-    (var,v)::sigma,sigmalist
-
-let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with
-  | r1, AVar id2 when List.mem id2 metas -> bind_env sigma id2 r1
-  | PatVar (_,Anonymous), AHole _ -> sigma
-  | PatCstr (loc,(ind,_ as r1),args1,_), _ ->
-      let nparams =
-	(fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
-      let l2 =
-        match a2 with
-	  | ARef (ConstructRef r2) when r1 = r2 -> []
-	  | AApp (ARef (ConstructRef r2),l2)  when r1 = r2 -> l2
-          | _ -> raise No_match in
-      if List.length l2 <> nparams + List.length args1
-      then raise No_match
-      else
-        let (p2,args2) = list_chop nparams l2 in
-        (* All parameters must be _ *)
-        List.iter (function AHole _ -> () | _ -> raise No_match) p2;
-	List.fold_left2 (match_cases_pattern metas) sigma args1 args2
-  (* TODO: use recursive notations *)
-  | _ -> raise No_match
-
-let match_aconstr_cases_pattern c ((metas_scl,metaslist_scl),pat) =
-  let vars = List.map fst metas_scl @ List.map fst metaslist_scl in
-  let subst,substlist = match_cases_pattern vars ([],[]) c pat in
-  (* Reorder canonically the substitution *)
-  let find x subst =
-    try List.assoc x subst 
-    with Not_found -> anomaly "match_aconstr_cases_pattern" in
-  List.map (fun (x,scl) -> (find x subst,scl)) metas_scl,
-  List.map (fun (x,scl) -> (find x substlist,scl)) metaslist_scl
-
  (* Better to use extern_rawconstr composed with injection/retraction ?? *)
 let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
-  try 
+  try
     if !Flags.raw_print or !print_no_symbol then raise No_match;
     let (na,sc,p) = uninterp_prim_token_cases_pattern pat in
-    match availability_of_prim_token sc scopes with
+    match availability_of_prim_token p sc scopes with
     | None -> raise No_match
     | Some key ->
       let loc = cases_pattern_loc pat in
       insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na
   with No_match ->
-  try 
+  try
     if !Flags.raw_print or !print_no_symbol then raise No_match;
     extern_symbol_pattern scopes vars pat
       (uninterp_cases_pattern_notations pat)
   with No_match ->
   match pat with
   | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id)))
-  | PatVar (loc,Anonymous) -> CPatAtom (loc, None) 
+  | PatVar (loc,Anonymous) -> CPatAtom (loc, None)
   | PatCstr(loc,cstrsp,args,na) ->
       let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
-      let p = CPatCstr
-        (loc,extern_reference loc vars (ConstructRef cstrsp),args) in
+      let p =
+	try
+	  if !Flags.raw_print then raise Exit;
+	  let projs = Recordops.lookup_projections (fst cstrsp) in
+	  let rec ip projs args acc =
+	    match projs with
+	      | [] -> acc
+	      | None :: q -> ip q args acc
+	      | Some c :: q ->
+		  match args with
+		    | [] -> raise No_match
+		    | CPatAtom(_, None) :: tail -> ip q tail acc
+			(* we don't want to have 'x = _' in our patterns *)
+		    | head :: tail -> ip q tail
+		        ((extern_reference loc Idset.empty (ConstRef c), head) :: acc)
+	    in
+	  CPatRecord(loc, List.rev (ip projs args []))
+	with
+	  Not_found | No_match | Exit ->
+	    CPatCstr (loc, extern_reference loc vars (ConstructRef cstrsp), args) in
       insert_pat_alias loc p na
-	
+
 and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
-      try
-	(* Check the number of arguments expected by the notation *)
-	let loc,na = match t,n with
-	  | PatCstr (_,f,l,_), Some n when List.length l > n ->
-	      raise No_match
-	  | PatCstr (loc,_,_,na),_ -> loc,na
-	  | PatVar (loc,na),_ -> loc,na in
+    try
+      match t,n with
+      | PatCstr (loc,(ind,_),l,na), n when n = Some 0 or n = None or 
+	 n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams ->
+        (* Abbreviation for the constructor name only *)
+	(match keyrule with
+        | NotationRule (sc,ntn) -> raise No_match
+        | SynDefRule kn ->
+	    let p =
+	      let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in
+	      if l = [] then
+		CPatAtom (loc,Some qid)
+	      else
+		let l =
+		  List.map (extern_cases_pattern_in_scope allscopes vars) l in
+		CPatCstr (loc,qid,l) in
+	    insert_pat_alias loc p na)
+      | PatCstr (_,f,l,_), Some n when List.length l > n ->
+	  raise No_match
+      | PatCstr (loc,_,_,na),_ ->
 	(* Try matching ... *)
 	let subst,substlist = match_aconstr_cases_pattern t pat in
 	(* Try availability of interpretation ... *)
@@ -446,16 +426,18 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
 		      let subscope = (scopt,scl@scopes') in
 		      List.map (extern_cases_pattern_in_scope subscope vars) c)
                       substlist in
-		  insert_pat_delimiters loc 
+		  insert_pat_delimiters loc
 		    (make_pat_notation loc ntn (l,ll)) key)
           | SynDefRule kn ->
 	      let qid = shortest_qualid_of_syndef vars kn in
               CPatAtom (loc,Some (Qualid (loc, qid))) in
 	insert_pat_alias loc p na
-      with
-	  No_match -> extern_symbol_pattern allscopes vars t rules
+      | PatVar (loc,Anonymous),_ -> CPatAtom (loc, None)
+      | PatVar (loc,Name id),_ -> CPatAtom (loc, Some (Ident (loc,id)))
+    with
+	No_match -> extern_symbol_pattern allscopes vars t rules
 
-let extern_cases_pattern vars p = 
+let extern_cases_pattern vars p =
   extern_cases_pattern_in_scope (None,[]) vars p
 
 (**********************************************************************)
@@ -468,7 +450,7 @@ let occur_name na aty =
 
 let is_projection nargs = function
   | Some r when not !Flags.raw_print & !print_projections ->
-      (try 
+      (try
 	let n = Recordops.find_projection_nparams r + 1 in
 	if n <= nargs then Some n else None
       with Not_found -> None)
@@ -488,13 +470,13 @@ let explicitize loc inctx impl (cf,f) args =
         let tail = exprec (q+1) (args,impl) in
         let visible =
           !Flags.raw_print or
-          (!print_implicits & !print_implicits_explicit_args) or 
+          (!print_implicits & !print_implicits_explicit_args) or
 	  (!print_implicits_defensive &
 	   is_significant_implicit a impl tail &
 	   not (is_inferable_implicit inctx n imp))
 	in
-        if visible then 
-	  (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail 
+        if visible then
+	  (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail
 	else
 	  tail
     | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl)
@@ -511,7 +493,7 @@ let explicitize loc inctx impl (cf,f) args =
 	  let args1 = exprec 1 (args1,impl1) in
 	  let args2 = exprec (i+1) (args2,impl2) in
 	  CApp (loc,(Some (List.length args1),f),args1@args2)
-    | None -> 
+    | None ->
 	let args = exprec 1 (args,impl) in
 	if args = [] then f else CApp (loc, (None, f), args)
 
@@ -525,11 +507,11 @@ let extern_app loc inctx impl (cf,f) args =
   if args = [] (* maybe caused by a hidden coercion *) then
     extern_global loc impl f
   else
-  if 
+  if
     ((!Flags.raw_print or
       (!print_implicits & not !print_implicits_explicit_args)) &
      List.exists is_status_implicit impl)
-  then 
+  then
     CAppExpl (loc, (is_projection (List.length args) cf, f), args)
   else
     explicitize loc inctx impl (cf,CRef f) args
@@ -550,49 +532,33 @@ let rec remove_coercions inctx = function
       let nargs = List.length args in
       (try match Classops.hide_coercion r with
 	  | Some n when n < nargs && (inctx or n+1 < nargs) ->
-	      (* We skip a coercion *) 
+	      (* We skip a coercion *)
 	      let l = list_skipn n args in
 	      let (a,l) = match l with a::l -> (a,l) | [] -> assert false in
               (* Recursively remove the head coercions *)
-              (match remove_coercions true a with
-              | RApp (_,a,l') -> RApp (loc,a,l'@l)
-              | a -> RApp (loc,a,l))
+	      let a' = remove_coercions true a in
+	      (* Don't flatten App's in case of funclass so that
+		 (atomic) notations on [a] work; should be compatible
+		 since printer does not care whether App's are
+		 collapsed or not and notations with an implicit
+		 coercion using funclass either would have already
+		 been confused with ordinary application or would have need
+                 a surrounding context and the coercion to funclass would
+                 have been made explicit to match *)
+	      if l = [] then a' else RApp (loc,a',l)
 	  | _ -> c
       with Not_found -> c)
   | c -> c
 
+let rec flatten_application = function
+  | RApp (loc,RApp(_,a,l'),l) -> flatten_application (RApp (loc,a,l'@l))
+  | a -> a
+
 let rec rename_rawconstr_var id0 id1 = function
     RRef(loc,VarRef id) when id=id0 -> RRef(loc,VarRef id1)
   | RVar(loc,id) when id=id0 -> RVar(loc,id1)
   | c -> map_rawconstr (rename_rawconstr_var id0 id1) c
 
-let rec share_fix_binders n rbl ty def =
-  match ty,def with
-      RProd(_,na0,bk0,t0,b), RLambda(_,na1,bk1,t1,m) ->
-        if not(same_rawconstr t0 t1) then List.rev rbl, ty, def
-        else
-          let (na,b,m) =
-            match na0, na1 with
-                Name id0, Name id1 ->
-                  if id0=id1 then (na0,b,m)
-                  else if not (occur_rawconstr id1 b) then
-                    (na1,rename_rawconstr_var id0 id1 b,m)
-                  else if not (occur_rawconstr id0 m) then
-                    (na1,b,rename_rawconstr_var id1 id0 m)
-                  else (* vraiment pas de chance! *)
-                    failwith "share_fix_binders: capture"
-              | Name id, Anonymous ->
-                  if not (occur_rawconstr id m) then (na0,b,m)
-                  else
-                    failwith "share_fix_binders: capture"
-              | Anonymous, Name id -> 
-                  if not (occur_rawconstr id b) then (na1,b,m)
-                  else
-                    failwith "share_fix_binders: capture"
-              | _ -> (na1,b,m) in
-          share_fix_binders (n-1) ((na,None,t0)::rbl) b m
-    | _ -> List.rev rbl, ty, def
-
 (**********************************************************************)
 (* mapping rawterms to numerals (in presence of coercions, choose the *)
 (* one with no delimiter if possible)                                 *)
@@ -600,7 +566,7 @@ let rec share_fix_binders n rbl ty def =
 let extern_possible_prim_token scopes r =
   try
     let (sc,n) = uninterp_prim_token r in
-    match availability_of_prim_token sc scopes with
+    match availability_of_prim_token n sc scopes with
     | None -> None
     | Some key -> Some (insert_delimiters (CPrim (loc_of_rawconstr r,n)) key)
   with No_match ->
@@ -623,13 +589,14 @@ let extern_rawsort = function
 
 let rec extern inctx scopes vars r =
   let r' = remove_coercions inctx r in
-  try 
+  try
     if !Flags.raw_print or !print_no_symbol then raise No_match;
     extern_optimal_prim_token scopes r r'
   with No_match ->
-  try 
+  try
+    let r'' = flatten_application r' in
     if !Flags.raw_print or !print_no_symbol then raise No_match;
-    extern_symbol scopes vars r' (uninterp_notations r')
+    extern_symbol scopes vars r'' (uninterp_notations r'')
   with No_match -> match r' with
   | RRef (loc,ref) ->
       extern_global loc (implicits_of_global ref)
@@ -651,10 +618,44 @@ let rec extern inctx scopes vars r =
 	     let subscopes = find_arguments_scope ref in
 	     let args =
 	       extern_args (extern true) (snd scopes) vars args subscopes in
-	     extern_app loc inctx (implicits_of_global ref)
-               (Some ref,extern_reference rloc vars ref)
-	       args
-	 | _       -> 
+	     begin
+	       try
+		 if !Flags.raw_print then raise Exit;
+		 let cstrsp = match ref with ConstructRef c -> c | _ -> raise Not_found in
+		 let struc = Recordops.lookup_structure (fst cstrsp) in
+		 let projs = struc.Recordops.s_PROJ in
+		 let locals = struc.Recordops.s_PROJKIND in
+		 let rec cut args n =
+		   if n = 0 then args
+		   else
+		     match args with
+		     | [] -> raise No_match
+		     | _ :: t -> cut t (n - 1) in
+		 let args = cut args struc.Recordops.s_EXPECTEDPARAM in
+		 let rec ip projs locs args acc =
+		   match projs with
+		     | [] -> acc
+		     | None :: q -> raise No_match
+		     | Some c :: q ->
+		         match locs with
+			   | [] -> anomaly "projections corruption [Constrextern.extern]"
+			   | (_, false) :: locs' ->
+			       (* we don't want to print locals *)
+			       ip q locs' args acc
+			   | (_, true) :: locs' ->
+			       match args with
+				 | [] -> raise No_match
+				     (* we give up since the constructor is not complete *)
+				 | head :: tail -> ip q locs' tail
+				     ((extern_reference loc Idset.empty (ConstRef c), head) :: acc)
+		   in
+		 CRecord (loc, None, List.rev (ip projs locals args []))
+	       with
+		 | Not_found | No_match | Exit ->
+		     extern_app loc inctx (implicits_of_global ref)
+		       (Some ref,extern_reference rloc vars ref) args
+	     end
+	 | _       ->
 	     explicitize loc inctx [] (None,sub_extern false scopes vars f)
                (List.map (sub_extern true scopes vars) args))
 
@@ -675,15 +676,15 @@ let rec extern inctx scopes vars r =
       let t = extern_typ scopes vars (anonymize_if_reserved na t) in
       let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) t c in
       CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c)
-	
+
   | RCases (loc,sty,rtntypopt,tml,eqns) ->
-      let vars' = 
+      let vars' =
 	List.fold_right (name_fold Idset.add)
 	  (cases_predicate_names tml) vars in
       let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in
       let tml = List.map (fun (tm,(na,x)) ->
         let na' = match na,tm with
-            Anonymous, RVar (_,id) when 
+            Anonymous, RVar (_,id) when
               rtntypopt<>None & occur_rawconstr id (Option.get rtntypopt)
               -> Some Anonymous
           | Anonymous, _ -> None
@@ -694,11 +695,11 @@ let rec extern inctx scopes vars r =
 	  let params = list_tabulate
 	    (fun _ -> RHole (dummy_loc,Evd.InternalHole)) n in
 	  let args = List.map (function
-	    | Anonymous -> RHole (dummy_loc,Evd.InternalHole) 
+	    | Anonymous -> RHole (dummy_loc,Evd.InternalHole)
 	    | Name id -> RVar (dummy_loc,id)) nal in
 	  let t = RApp (dummy_loc,RRef (dummy_loc,IndRef ind),params@args) in
 	  (extern_typ scopes vars t)) x))) tml in
-      let eqns = List.map (extern_eqn inctx scopes vars) eqns in 
+      let eqns = List.map (extern_eqn inctx scopes vars) eqns in
       CCases (loc,sty,rtntypopt',tml,eqns)
 
   | RLetTuple (loc,nal,(na,typopt),tm,b) ->
@@ -718,23 +719,23 @@ let rec extern inctx scopes vars r =
       let vars' = Array.fold_right Idset.add idv vars in
       (match fk with
 	 | RFix (nv,n) ->
-	     let listdecl = 
+	     let listdecl =
 	       Array.mapi (fun i fi ->
                  let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in
                  let (ids,bl) = extern_local_binder scopes vars bl in
                  let vars0 = List.fold_right (name_fold Idset.add) ids vars in
                  let vars1 = List.fold_right (name_fold Idset.add) ids vars' in
-		 let n = 
+		 let n =
 		   match fst nv.(i) with
 		     | None -> None
 		     | Some x -> Some (dummy_loc, out_name (List.nth ids x))
-		 in 
+		 in
 		 let ro = extern_recursion_order scopes vars (snd nv.(i)) in
 		 ((dummy_loc, fi), (n, ro), bl, extern_typ scopes vars0 ty,
                   extern false scopes vars1 def)) idv
-	     in 
+	     in
 	     CFix (loc,(loc,idv.(n)),Array.to_list listdecl)
-	 | RCoFix n -> 
+	 | RCoFix n ->
 	     let listdecl =
                Array.mapi (fun i fi ->
                  let (ids,bl) = extern_local_binder scopes vars blv.(i) in
@@ -756,13 +757,13 @@ let rec extern inctx scopes vars r =
 
   | RDynamic (loc,d) -> CDynamic (loc,d)
 
-and extern_typ (_,scopes) = 
+and extern_typ (_,scopes) =
   extern true (Some Notation.type_scope,scopes)
 
 and sub_extern inctx (_,scopes) = extern inctx (None,scopes)
 
 and factorize_prod scopes vars aty c =
-  try 
+  try
     if !Flags.raw_print or !print_no_symbol then raise No_match;
     ([],extern_symbol scopes vars c (uninterp_notations c))
   with No_match -> match c with
@@ -774,7 +775,7 @@ and factorize_prod scopes vars aty c =
   | c -> ([],extern_typ scopes vars c)
 
 and factorize_lambda inctx scopes vars aty c =
-  try 
+  try
     if !Flags.raw_print or !print_no_symbol then raise No_match;
     ([],extern_symbol scopes vars c (uninterp_notations c))
   with No_match -> match c with
@@ -793,7 +794,7 @@ and extern_local_binder scopes vars = function
         extern_local_binder scopes (name_fold Idset.add na vars) l in
       (na::ids,
        LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l)
-      
+
   | (na,bk,None,ty)::l ->
       let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in
       (match extern_local_binder scopes (name_fold Idset.add na vars) l with
@@ -817,13 +818,22 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
       let loc = Rawterm.loc_of_rawconstr t in
       try
 	(* Adjusts to the number of arguments expected by the notation *)
-	let (t,args) = match t,n with
-	  | RApp (_,(RRef _ as f),args), Some n when List.length args >= n ->
+	let (t,args,argsscopes,argsimpls) = match t,n with
+	  | RApp (_,(RRef (_,ref) as f),args), Some n
+	      when List.length args >= n ->
 	      let args1, args2 = list_chop n args in
-	      (if n = 0 then f else RApp (dummy_loc,f,args1)), args2
-	  | RApp (_,(RRef _ as f),args), None -> f, args
-	  | RRef _, Some 0 -> RApp (dummy_loc,t,[]), []
-          | _, None -> t,[]
+	      let subscopes =
+		try list_skipn n (find_arguments_scope ref) with _ -> [] in
+	      let impls =
+		try list_skipn n (implicits_of_global ref) with _ -> [] in
+	      (if n = 0 then f else RApp (dummy_loc,f,args1)),
+	      args2, subscopes, impls
+	  | RApp (_,(RRef (_,ref) as f),args), None ->
+	      let subscopes = find_arguments_scope ref in
+	      let impls = implicits_of_global ref in
+	      f, args, subscopes, impls
+	  | RRef _, Some 0 -> RApp (dummy_loc,t,[]), [], [], []
+          | _, None -> t, [], [], []
           | _ -> raise No_match in
 	(* Try matching ... *)
 	let subst,substlist = match_aconstr t pat in
@@ -854,18 +864,18 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
 		  subst in
               let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in
 	      if l = [] then a else CApp (loc,(None,a),l) in
- 	if args = [] then e 
+ 	if args = [] then e
 	else
-	  (* TODO: compute scopt for the extra args, in case, head is a ref *)
-	  explicitize loc false [] (None,e)
-	  (List.map (extern true allscopes vars) args)
+	  let args = extern_args (extern true) scopes vars args argsscopes in
+	  explicitize loc false argsimpls (None,e) args
       with
 	  No_match -> extern_symbol allscopes vars t rules
 
 and extern_recursion_order scopes vars = function
     RStructRec -> CStructRec
   | RWfRec c -> CWfRec (extern true scopes vars c)
-  | RMeasureRec c -> CMeasureRec (extern true scopes vars c)
+  | RMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m,
+				     Option.map (extern true scopes vars) r)
 
 
 let extern_rawconstr vars c =
@@ -901,13 +911,6 @@ let extern_sort s = extern_rawsort (detype_sort s)
 (******************************************************************)
 (* Main translation function from pattern -> constr_expr *)
 
-let it_destPLambda n c =
-  let rec aux n nal c =
-    if n=0 then (nal,c) else match c with
-      | PLambda (na,_,c) -> aux (n-1) (na::nal) c
-      | _ -> anomaly "it_destPLambda" in
-  aux n [] c
-
 let rec raw_of_pat env = function
   | PRef ref -> RRef (loc,ref)
   | PVar id -> RVar (loc,id)
@@ -933,7 +936,7 @@ let rec raw_of_pat env = function
   | PLambda (na,t,c) ->
       RLambda (loc,na,Explicit,raw_of_pat env t, raw_of_pat (na::env) c)
   | PIf (c,b1,b2) ->
-      RIf (loc, raw_of_pat env c, (Anonymous,None), 
+      RIf (loc, raw_of_pat env c, (Anonymous,None),
            raw_of_pat env b1, raw_of_pat env b2)
   | PCase ((LetStyle,[|n|],ind,None),PMeta None,tm,[|b|]) ->
       let nal,b = it_destRLambda_or_LetIn_names n (raw_of_pat env b) in
@@ -948,7 +951,7 @@ let rec raw_of_pat env = function
       let mat = simple_cases_matrix_of_branches ind brns brs in
       let indnames,rtn =
 	if p = PMeta None then (Anonymous,None),None
-	else 
+	else
 	  let nparams,n = Option.get ind_nargs in
 	  return_type_of_predicate ind nparams n (raw_of_pat env p) in
       RCases (loc,RegularStyle,rtn,[raw_of_pat env tm,indnames],mat)
@@ -956,9 +959,6 @@ let rec raw_of_pat env = function
   | PCoFix c -> Detyping.detype false [] env (mkCoFix c)
   | PSort s -> RSort (loc,s)
 
-and raw_of_eqns env constructs consnargsl bl =
-  Array.to_list (array_map3 (raw_of_eqn env) constructs consnargsl bl)
-
 and raw_of_eqn env constr construct_nargs branch =
   let make_pat x env b ids =
     let avoid = List.fold_right (name_fold (fun x l -> x::l)) env [] in
@@ -967,22 +967,22 @@ and raw_of_eqn env constr construct_nargs branch =
   in
   let rec buildrec ids patlist env n b =
     if n=0 then
-      (dummy_loc, ids, 
+      (dummy_loc, ids,
        [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
        raw_of_pat env b)
     else
       match b with
-	| PLambda (x,_,b) -> 
+	| PLambda (x,_,b) ->
 	    let pat,new_env,new_ids = make_pat x env b ids in
             buildrec new_ids (pat::patlist) new_env (n-1) b
 
-	| PLetIn (x,_,b) -> 
+	| PLetIn (x,_,b) ->
 	    let pat,new_env,new_ids = make_pat x env b ids in
             buildrec new_ids (pat::patlist) new_env (n-1) b
 
 	| _ ->
 	    error "Unsupported branch in case-analysis while printing pattern."
-  in 
+  in
   buildrec [] [] env construct_nargs branch
 
 let extern_constr_pattern env pat =
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
index ec0a262b..08a74e61 100644
--- a/interp/constrextern.mli
+++ b/interp/constrextern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: constrextern.mli 10790 2008-04-14 22:34:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -34,7 +34,7 @@ val extern_rawconstr : Idset.t -> rawconstr -> constr_expr
 val extern_rawtype : Idset.t -> rawconstr -> constr_expr
 val extern_constr_pattern : names_context -> constr_pattern -> constr_expr
 
-(* If [b=true] in [extern_constr b env c] then the variables in the first 
+(* If [b=true] in [extern_constr b env c] then the variables in the first
    level of quantification clashing with the variables in [env] are renamed *)
 
 val extern_constr : bool -> env -> constr -> constr_expr
@@ -42,7 +42,7 @@ val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr
 val extern_reference : loc -> Idset.t -> global_reference -> reference
 val extern_type : bool -> env -> types -> constr_expr
 val extern_sort : sorts -> rawsort
-val extern_rel_context : constr option -> env -> 
+val extern_rel_context : constr option -> env ->
   rel_context -> local_binder list
 
 (* Printing options *)
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index c8faf911..b5604cf7 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrintern.ml 13131 2010-06-13 18:45:17Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Flags
 open Names
 open Nameops
+open Namegen
 open Libnames
 open Impargs
 open Rawterm
@@ -24,66 +25,32 @@ open Nametab
 open Notation
 open Inductiveops
 
-open Decl_kinds
-
-let type_of_logical_kind = 
-  function
-  | IsDefinition def -> 
-      (match def with
-      | Definition -> "def"
-      | Coercion -> "coe"
-      | SubClass -> "subclass"
-      | CanonicalStructure -> "canonstruc"
-      | Example -> "ex"
-      | Fixpoint -> "def"
-      | CoFixpoint -> "def"
-      | Scheme -> "scheme"
-      | StructureComponent -> "proj"
-      | IdentityCoercion -> "coe"
-      | Instance -> "inst"
-      | Method -> "meth")
-  | IsAssumption a ->
-      (match a with
-      | Definitional -> "defax"
-      | Logical -> "prfax"
-      | Conjectural -> "prfax")
-  | IsProof th ->
-      (match th with
-      | Theorem
-      | Lemma
-      | Fact
-      | Remark
-      | Property
-      | Proposition
-      | Corollary -> "thm")
-
-let type_of_global_ref gr =
-  if Typeclasses.is_class gr then
-    "class"
-  else
-    match gr with
-    | ConstRef cst -> 
-	type_of_logical_kind (Decls.constant_kind cst)
-    | VarRef v ->
-	"var" ^ type_of_logical_kind (Decls.variable_kind v)
-    | IndRef ind ->
-	let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in
-	  if mib.Declarations.mind_record then
-	    if mib.Declarations.mind_finite then "rec"
-	    else "corec"
-	  else if mib.Declarations.mind_finite then "ind"
-	  else "coind"
-    | ConstructRef _ -> "constr"
-
-(* To interpret implicits and arg scopes of recursive variables in
-   inductive types and recursive definitions *)
-type var_internalisation_type = Inductive | Recursive | Method
-
-type var_internalisation_data =
-  var_internalisation_type * identifier list * Impargs.implicits_list * scope_name option list
-
-type implicits_env = (identifier * var_internalisation_data) list
-type full_implicits_env = identifier list * implicits_env
+(* To interpret implicits and arg scopes of variables in inductive
+   types and recursive definitions and of projection names in records *)
+
+type var_internalization_type = Inductive | Recursive | Method
+
+type var_internalization_data =
+    (* type of the "free" variable, for coqdoc, e.g. while typing the
+       constructor of JMeq, "JMeq" behaves as a variable of type Inductive *)
+    var_internalization_type *
+    (* impargs to automatically add to the variable, e.g. for "JMeq A a B b"
+       in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *)
+    identifier list *
+    (* signature of impargs of the variable *)
+    Impargs.implicits_list *
+    (* subscopes of the args of the variable *)
+    scope_name option list
+
+type internalization_env =
+    (identifier * var_internalization_data) list
+
+type full_internalization_env =
+    (* a superset of the list of variables that may be automatically
+       inserted and that must not occur as binders *)
+    identifier list *
+    (* mapping of the variables to their internalization data *)
+    internalization_env
 
 type raw_binder = (name * binding_kind * rawconstr option * rawconstr)
 
@@ -98,6 +65,33 @@ let for_grammar f x =
     a
 
 (**********************************************************************)
+(* Locating reference, possibly via an abbreviation *)
+
+let locate_reference qid =
+  Smartlocate.global_of_extended_global (Nametab.locate_extended qid)
+
+let is_global id =
+  try
+    let _ = locate_reference (qualid_of_ident id) in true
+  with Not_found ->
+    false
+
+let global_reference_of_reference ref =
+  locate_reference (snd (qualid_of_reference ref))
+
+let global_reference id =
+  constr_of_global (locate_reference (qualid_of_ident id))
+
+let construct_reference ctx id =
+  try
+    Term.mkVar (let _ = Sign.lookup_named id ctx in id)
+  with Not_found ->
+    global_reference id
+
+let global_reference_in_absolute_module dir id =
+  constr_of_global (Nametab.global_of_path (Libnames.make_path dir id))
+
+(**********************************************************************)
 (* Internalisation errors                                             *)
 
 type internalisation_error =
@@ -126,7 +120,7 @@ let explain_not_a_constructor ref =
   str "Unknown constructor: " ++ pr_reference ref
 
 let explain_unbound_fix_name is_cofix id =
-  str "The name" ++ spc () ++ pr_id id ++ 
+  str "The name" ++ spc () ++ pr_id id ++
   spc () ++ str "is not bound in the corresponding" ++ spc () ++
   str (if is_cofix then "co" else "") ++ str "fixpoint definition"
 
@@ -143,13 +137,13 @@ let explain_bad_explicitation_number n po =
       let s = match po with
 	| None -> str "a regular argument"
 	| Some p -> int p in
-      str "Bad explicitation number: found " ++ int n ++ 
+      str "Bad explicitation number: found " ++ int n ++
       str" but was expecting " ++ s
   | ExplByName id ->
       let s = match po with
 	| None -> str "a regular argument"
 	| Some p -> (*pr_id (name_of_position p) in*) failwith "" in
-      str "Bad explicitation name: found " ++ pr_id id ++ 
+      str "Bad explicitation name: found " ++ pr_id id ++
       str" but was expecting " ++ s
 
 let explain_internalisation_error e =
@@ -164,13 +158,8 @@ let explain_internalisation_error e =
   | BadExplicitationNumber (n,po) -> explain_bad_explicitation_number n po in
   pp ++ str "."
 
-let error_unbound_patvar loc n =
-  user_err_loc
-    (loc,"glob_qualid_or_patvar", str "?" ++ pr_patvar n ++ 
-      str " is unbound.")
-
 let error_bad_inductive_type loc =
-  user_err_loc (loc,"",str 
+  user_err_loc (loc,"",str
     "This should be an inductive type applied to names or \"_\".")
 
 let error_inductive_parameter_not_implicit loc =
@@ -179,6 +168,35 @@ let error_inductive_parameter_not_implicit loc =
     "the 'return' clauses; they must be replaced by '_' in the 'in' clauses."))
 
 (**********************************************************************)
+(* Pre-computing the implicit arguments and arguments scopes needed   *)
+(* for interpretation *)
+
+let empty_internalization_env = ([],[])
+
+let set_internalization_env_params ienv params =
+  let nparams = List.length params in
+  if nparams = 0 then
+    ([],ienv)
+  else
+    let ienv_with_implicit_params =
+      List.map (fun (id,(ty,_,impl,scopes)) ->
+	let sub_impl,_ = list_chop nparams impl in
+	let sub_impl' = List.filter is_status_implicit sub_impl in
+	(id,(ty,List.map name_of_implicit sub_impl',impl,scopes))) ienv in
+    (params, ienv_with_implicit_params)
+
+let compute_internalization_data env ty typ impls =
+  let impl = compute_implicits_with_manual env typ (is_implicit_args()) impls in
+  (ty, [], impl, compute_arguments_scope typ)
+
+let compute_full_internalization_env env ty params idl typl impll =
+  set_internalization_env_params
+    (list_map3
+      (fun id typ impl -> (id,compute_internalization_data env ty typ impl))
+      idl typl impll)
+    params
+
+(**********************************************************************)
 (* Contracting "{ _ }" in notations *)
 
 let rec wildcards ntn n =
@@ -191,8 +209,8 @@ and spaces ntn n =
 let expand_notation_string ntn n =
   let pos = List.nth (wildcards ntn 0) n in
   let hd = if pos = 0 then "" else String.sub ntn 0 pos in
-  let tl = 
-    if pos = String.length ntn then "" 
+  let tl =
+    if pos = String.length ntn then ""
     else String.sub ntn (pos+1) (String.length ntn - pos -1) in
   hd ^ "{ _ }" ^ tl
 
@@ -202,7 +220,7 @@ let contract_notation ntn (l,ll) =
   let ntn' = ref ntn in
   let rec contract_squash n = function
     | [] -> []
-    | CNotation (_,"{ _ }",([a],[])) :: l -> 
+    | CNotation (_,"{ _ }",([a],[])) :: l ->
         ntn' := expand_notation_string !ntn' n;
         contract_squash n (a::l)
     | a :: l ->
@@ -215,7 +233,7 @@ let contract_pat_notation ntn (l,ll) =
   let ntn' = ref ntn in
   let rec contract_squash n = function
     | [] -> []
-    | CPatNotation (_,"{ _ }",([a],[])) :: l -> 
+    | CPatNotation (_,"{ _ }",([a],[])) :: l ->
         ntn' := expand_notation_string !ntn' n;
         contract_squash n (a::l)
     | a :: l ->
@@ -227,26 +245,40 @@ let contract_pat_notation ntn (l,ll) =
 (**********************************************************************)
 (* Remembering the parsing scope of variables in notations            *)
 
-let make_current_scope (tmp_scope,scopes) = Option.List.cons tmp_scope scopes
+let make_current_scope = function
+  | (Some tmp_scope,(sc::_ as scopes)) when sc = tmp_scope -> scopes
+  | (Some tmp_scope,scopes) -> tmp_scope::scopes
+  | None,scopes -> scopes
 
 let set_var_scope loc id (_,_,scopt,scopes) varscopes =
   let idscopes = List.assoc id varscopes in
-  if !idscopes <> None & 
+  if !idscopes <> None &
     make_current_scope (Option.get !idscopes)
     <> make_current_scope (scopt,scopes) then
+      let pr_scope_stack = function
+	| [] -> str "the empty scope stack"
+	| [a] -> str "scope " ++ str a
+	| l -> str "scope stack " ++
+	    str "[" ++ prlist_with_sep pr_comma str l ++ str "]" in
       user_err_loc (loc,"set_var_scope",
-      pr_id id ++ str " already occurs in a different scope.")
+      pr_id id ++ str " is used both in " ++ 
+	pr_scope_stack (make_current_scope (Option.get !idscopes)) ++
+	strbrk " and in " ++
+	pr_scope_stack (make_current_scope (scopt,scopes)))
   else
     idscopes := Some (scopt,scopes)
 
 (**********************************************************************)
 (* Syntax extensions                                                  *)
 
-let traverse_binder (subst,substlist) (renaming,(ids,unb,tmpsc,scopes as env)) id =
+let traverse_binder (subst,substlist) (renaming,(ids,unb,tmpsc,scopes as env))=
+ function
+ | Anonymous -> (renaming,env),Anonymous
+ | Name id ->
   try
     (* Binders bound in the notation are considered first-order objects *)
-    let _,id' = coerce_to_id (fst (List.assoc id subst)) in
-    (renaming,(Idset.add id' ids,unb,tmpsc,scopes)), id'
+    let _,na = coerce_to_name (fst (List.assoc id subst)) in
+    (renaming,(name_fold Idset.add na ids,unb,tmpsc,scopes)), na
   with Not_found ->
     (* Binders not bound in the notation do not capture variables *)
     (* outside the notation (i.e. in the substitution) *)
@@ -256,7 +288,7 @@ let traverse_binder (subst,substlist) (renaming,(ids,unb,tmpsc,scopes as env)) i
     let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in
     let id' = next_ident_away id fvs in
     let renaming' = if id=id' then renaming else (id,id')::renaming in
-    (renaming',env), id'
+    (renaming',env), Name id'
 
 let rec subst_iterator y t = function
   | RVar (_,id) as x -> if id = y then t else x
@@ -270,40 +302,45 @@ let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c =
       begin
 	(* subst remembers the delimiters stack in the interpretation *)
 	(* of the notations *)
-	try 
+	try
 	  let (a,(scopt,subscopes)) = List.assoc id subst in
 	  interp (ids,unb,scopt,subscopes@scopes) a
-	with Not_found -> 
-	try 
+	with Not_found ->
+	try
 	  RVar (loc,List.assoc id renaming)
-	with Not_found -> 
+	with Not_found ->
 	  (* Happens for local notation joint with inductive/fixpoint defs *)
 	  RVar (loc,id)
       end
   | AList (x,_,iter,terminator,lassoc) ->
-      (try 
+      (try
         (* All elements of the list are in scopes (scopt,subscopes) *)
 	let (l,(scopt,subscopes)) = List.assoc x substlist in
-        let termin = 
+        let termin =
           subst_aconstr_in_rawconstr loc interp sub subinfos terminator in
-	List.fold_right (fun a t -> 
+	List.fold_right (fun a t ->
           subst_iterator ldots_var t
-            (subst_aconstr_in_rawconstr loc interp 
+            (subst_aconstr_in_rawconstr loc interp
               ((x,(a,(scopt,subscopes)))::subst,substlist) subinfos iter))
             (if lassoc then List.rev l else l) termin
-      with Not_found -> 
+      with Not_found ->
           anomaly "Inconsistent substitution of recursive notation")
+  | AHole (Evd.BinderType (Name id as na)) ->
+      let na =
+        try snd (coerce_to_name (fst (List.assoc id subst)))
+        with Not_found -> na in
+      RHole (loc,Evd.BinderType na)
   | t ->
       rawconstr_of_aconstr_with_binders loc (traverse_binder sub)
       (subst_aconstr_in_rawconstr loc interp sub) subinfos t
 
 let intern_notation intern (_,_,tmp_scope,scopes as env) loc ntn fullargs =
-  let ntn,(args,argslist) = contract_notation ntn fullargs in
+  let ntn,(args,argslist as fullargs) = contract_notation ntn fullargs in
   let (((ids,idsl),c),df) = interp_notation loc ntn (tmp_scope,scopes) in
-    Dumpglob.dump_notation_location (Topconstr.ntn_loc loc args ntn) df;
-    let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in
-    let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl argslist in
-      subst_aconstr_in_rawconstr loc intern (subst,substlist) ([],env) c
+  Dumpglob.dump_notation_location (ntn_loc loc fullargs ntn) ntn df;
+  let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in
+  let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl argslist in
+  subst_aconstr_in_rawconstr loc intern (subst,substlist) ([],env) c
 
 let set_type_scope (ids,unb,tmp_scope,scopes) =
   (ids,unb,Some Notation.type_scope,scopes)
@@ -337,8 +374,8 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l
   let (vars1,unbndltacvars) = ltacvars in
   (* Is [id] an inductive type potentially with implicit *)
   try
-    let ty, l,impl,argsc = List.assoc id impls in
-    let l = List.map 
+    let ty,l,impl,argsc = List.assoc id impls in
+    let l = List.map
       (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in
     let tys = string_of_ty ty in
       Dumpglob.dump_reference loc "<>" (string_of_id id) tys;
@@ -353,7 +390,6 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l
   then
     (set_var_scope loc id genv vars3; RVar (loc,id), [], [], [])
   else
-
   (* Is [id] bound to a free name in ltac (this is an ltac error message) *)
   try
     match List.assoc id unbndltacvars with
@@ -367,13 +403,21 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l
 	(* [id] a section variable *)
 	(* Redundant: could be done in intern_qualid *)
 	let ref = VarRef id in
-	  RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref, []
+	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";
+	RRef (loc, ref), impls, scopes, []
       with _ ->
 	(* [id] a goal variable *)
 	RVar (loc,id), [], [], []
-	    
-let find_appl_head_data (_,_,_,(_,impls)) = function
+
+let find_appl_head_data = function
   | RRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[]
+  | RApp (_,RRef (_,ref),l) as x
+      when l <> [] & Flags.version_strictly_greater Flags.V8_2 ->
+      let n = List.length l in
+      x,list_skipn_at_least n (implicits_of_global ref),
+      list_skipn_at_least n (find_arguments_scope ref),[]
   | x -> x,[],[],[]
 
 let error_not_enough_arguments loc =
@@ -386,23 +430,31 @@ let check_no_explicitation l =
     user_err_loc
      (loc,"",str"Unexpected explicitation of the argument of an abbreviation.")
 
+let dump_extended_global loc = function
+  | TrueGlobal ref -> Dumpglob.add_glob loc ref
+  | SynDef sp -> Dumpglob.add_glob_kn loc sp
+
+let intern_extended_global_of_qualid (loc,qid) =
+  try let r = Nametab.locate_extended qid in dump_extended_global loc r; r
+  with Not_found -> error_global_not_found_loc loc qid
+
+let intern_reference ref =
+  Smartlocate.global_of_extended_global
+    (intern_extended_global_of_qualid (qualid_of_reference ref))
+
 (* Is it a global reference or a syntactic definition? *)
 let intern_qualid loc qid intern env args =
-  try match Nametab.extended_locate qid with
+  match intern_extended_global_of_qualid (loc,qid) with
   | TrueGlobal ref ->
-      Dumpglob.add_glob loc ref;
       RRef (loc, ref), args
-  | SyntacticDef sp ->
-      Dumpglob.add_glob_kn loc sp;
-      let (ids,c) = Syntax_def.search_syntactic_definition loc sp in
+  | SynDef sp ->
+      let (ids,c) = Syntax_def.search_syntactic_definition sp in
       let nids = List.length ids in
       if List.length args < nids then error_not_enough_arguments loc;
       let args1,args2 = list_chop nids args in
       check_no_explicitation args1;
       let subst = List.map2 (fun (id,scl) a -> (id,(fst a,scl))) ids args1 in
       subst_aconstr_in_rawconstr loc intern (subst,[]) ([],env) c, args2
-  with Not_found ->
-    error_global_not_found_loc loc qid
 
 (* Rule out section vars since these should have been found by intern_var *)
 let intern_non_secvar_qualid loc qid intern env args =
@@ -413,20 +465,20 @@ let intern_non_secvar_qualid loc qid intern env args =
 let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function
   | Qualid (loc, qid) ->
       let r,args2 = intern_qualid loc qid intern env args in
-	find_appl_head_data lvar r, args2
+      find_appl_head_data r, args2
   | Ident (loc, id) ->
       try intern_var env lvar loc id, args
-      with Not_found -> 
-      let qid = make_short_qualid id in
+      with Not_found ->
+      let qid = qualid_of_ident id in
       try
 	let r,args2 = intern_non_secvar_qualid loc qid intern env args in
-	find_appl_head_data lvar r, args2
+	find_appl_head_data r, args2
       with e ->
 	(* Extra allowance for non globalizing functions *)
 	if !interning_grammar || unb then
 	  (RVar (loc,id), [], [], []),args
 	else raise e
-	  
+
 let interp_reference vars r =
   let (r,_,_,_),_ =
     intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc)
@@ -437,12 +489,6 @@ let apply_scope_env (ids,unb,_,scopes) = function
   | [] -> (ids,unb,None,scopes), []
   | sc::scl -> (ids,unb,sc,scopes), scl
 
-let rec adjust_scopes env scopes = function
-  | [] -> []
-  | a::args ->
-      let (enva,scopes) = apply_scope_env env scopes in
-      enva :: adjust_scopes env scopes args
-
 let rec simple_adjust_scopes n = function
   | [] -> if n=0 then [] else None :: simple_adjust_scopes (n-1) []
   | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes
@@ -473,11 +519,11 @@ let simple_product_of_cases_patterns pl =
     pl [[],[]]
 
 (* Check linearity of pattern-matching *)
-let rec has_duplicate = function 
+let rec has_duplicate = function
   | [] -> None
   | x::l -> if List.mem x l then (Some x) else has_duplicate l
 
-let loc_of_lhs lhs = 
+let loc_of_lhs lhs =
  join_loc (fst (List.hd lhs)) (fst (list_last lhs))
 
 let check_linearity lhs ids =
@@ -494,7 +540,7 @@ let check_number_of_pattern loc n l =
 
 let check_or_pat_variables loc ids idsl =
   if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then
-    user_err_loc (loc, "", str 
+    user_err_loc (loc, "", str
     "The components of this disjunctive pattern must bind the same variables.")
 
 let check_constructor_length env loc cstr pl pl0 =
@@ -516,7 +562,7 @@ let alias_of = function
   | (id::_,_) -> Name id
 
 let message_redundant_alias (id1,id2) =
-  if_verbose warning 
+  if_verbose warning
    ("Alias variable "^(string_of_id id1)^" is merged with "^(string_of_id id2))
 
 (* Expanding notations *)
@@ -525,12 +571,16 @@ let error_invalid_pattern_notation loc =
   user_err_loc (loc,"",str "Invalid notation for pattern.")
 
 let chop_aconstr_constructor loc (ind,k) args =
-  let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
-  if nparams > List.length args then error_invalid_pattern_notation loc;
-  let params,args = list_chop nparams args in
-  List.iter (function AHole _ -> ()
-    | _ -> error_invalid_pattern_notation loc) params;
-  args
+  if List.length args = 0 then (* Tolerance for a @id notation *) args else
+    begin
+      let mib,_ = Global.lookup_inductive ind in
+      let nparams = mib.Declarations.mind_nparams in
+      if nparams > List.length args then error_invalid_pattern_notation loc;
+      let params,args = list_chop nparams args in
+      List.iter (function AHole _ -> ()
+	| _ -> error_invalid_pattern_notation loc) params;
+      args
+    end
 
 let rec subst_pat_iterator y t (subst,p) = match p with
   | PatVar (_,id) as x ->
@@ -546,10 +596,10 @@ let subst_cases_pattern loc alias intern fullsubst scopes a =
       begin
 	(* subst remembers the delimiters stack in the interpretation *)
 	(* of the notations *)
-	try 
+	try
 	  let (a,(scopt,subscopes)) = List.assoc id subst in
 	    intern (subscopes@scopes) ([],[]) scopt a
-	with Not_found -> 
+	with Not_found ->
 	  if id = ldots_var then [], [[], PatVar (loc,Name id)] else
 	  anomaly ("Unbound pattern notation variable: "^(string_of_id id))
 	  (*
@@ -565,41 +615,41 @@ let subst_cases_pattern loc alias intern fullsubst scopes a =
       let args = chop_aconstr_constructor loc cstr args in
       let idslpll = List.map (aux Anonymous fullsubst) args in
       let ids',pll = product_of_cases_patterns [] idslpll in
-      let pl' = List.map (fun (asubst,pl) -> 
+      let pl' = List.map (fun (asubst,pl) ->
         asubst,PatCstr (loc,cstr,pl,alias)) pll in
 	ids', pl'
   | AList (x,_,iter,terminator,lassoc) ->
-      (try 
+      (try
         (* All elements of the list are in scopes (scopt,subscopes) *)
 	let (l,(scopt,subscopes)) = List.assoc x substlist in
         let termin = aux Anonymous fullsubst terminator in
         let idsl,v =
-	  List.fold_right (fun a (tids,t) -> 
+	  List.fold_right (fun a (tids,t) ->
             let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst,substlist) iter in
             let pll = List.map (subst_pat_iterator ldots_var t) u in
             tids@uids, List.flatten pll)
             (if lassoc then List.rev l else l) termin in
         idsl, List.map (fun ((asubst, pl) as x) ->
 	  match pl with PatCstr (loc, c, pl, Anonymous) -> (asubst, PatCstr (loc, c, pl, alias)) | _ -> x) v
-      with Not_found -> 
+      with Not_found ->
           anomaly "Inconsistent substitution of recursive notation")
   | t -> error_invalid_pattern_notation loc
   in aux alias fullsubst a
 
 (* Differentiating between constructors and matching variables *)
 type pattern_qualid_kind =
-  | ConstrPat of constructor * (identifier list * 
+  | ConstrPat of constructor * (identifier list *
       ((identifier * identifier) list * cases_pattern) list) list
   | VarPat of identifier
 
 let find_constructor ref f aliases pats scopes =
   let (loc,qid) = qualid_of_reference ref in
   let gref =
-    try extended_locate qid
+    try locate_extended qid
     with Not_found -> raise (InternalisationError (loc,NotAConstructor ref)) in
   match gref with
-  | SyntacticDef sp ->
-      let (vars,a) = Syntax_def.search_syntactic_definition loc sp in
+  | SynDef sp ->
+      let (vars,a) = Syntax_def.search_syntactic_definition sp in
       (match a with
        | ARef (ConstructRef cstr) ->
 	   assert (vars=[]);
@@ -613,14 +663,14 @@ let find_constructor ref f aliases pats scopes =
 	   let idspl1 = List.map (subst_cases_pattern loc (alias_of aliases) f (subst,[]) scopes) args in
 	   cstr, idspl1, pats2
        | _ -> raise Not_found)
-      
+
   | TrueGlobal r ->
       let rec unf = function
         | ConstRef cst ->
 	    let v = Environ.constant_value (Global.env()) cst in
 	    unf (global_of_constr v)
-        | ConstructRef cstr -> 
-	    Dumpglob.add_glob loc r; 
+        | ConstructRef cstr ->
+	    Dumpglob.add_glob loc r;
 	    cstr, [], pats
         | _ -> raise Not_found
       in unf r
@@ -643,17 +693,110 @@ let maybe_constructor ref f aliases scopes =
               str " is understood as a pattern variable");
         VarPat (find_pattern_variable ref)
 
-let mustbe_constructor loc ref f aliases patl scopes = 
+let mustbe_constructor loc ref f aliases patl scopes =
   try find_constructor ref f aliases patl scopes
   with (Environ.NotEvaluableConst _ | Not_found) ->
     raise (InternalisationError (loc,NotAConstructor ref))
 
+let sort_fields mode loc l completer =
+(*mode=false if pattern and true if constructor*)
+  match l 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, "intern", 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 "Number of projections mismatch"
+		    | (_, regular)::tm ->
+		       let boolean = not regular in
+		       if ConstRef name = global_reference_of_reference refer
+		       then
+			 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 *)
+		       else
+			  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))
+	      | 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 Idset.empty (ConstructRef ind)),
+	     build_patt record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 (0,[]))
+	  with Not_found -> anomaly "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 rec add_patt l acc =
+		 match l with
+		   | [] ->
+		       user_err_loc
+			 (loc, "",
+			  str "This record contains fields of different records.")
+		   | (i, a) :: b->
+		       if global_reference_of_reference 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 []))
+
 let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
-  let intern_pat = intern_cases_pattern genv in 
+  let intern_pat = intern_cases_pattern genv in
   match pat with
   | CPatAlias (loc, p, id) ->
       let aliases' = merge_aliases aliases id in
       intern_pat scopes aliases' tmp_scope p
+    | CPatRecord (loc, l) ->
+	let sorted_fields = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in
+	let self_patt =
+	  match sorted_fields with
+	    | None -> CPatAtom (loc, None)
+	    | Some (_, head, pl) -> CPatCstr(loc, head, pl)
+	  in
+	intern_pat scopes aliases tmp_scope self_patt
   | CPatCstr (loc, head, pl) ->
       let c,idslpl1,pl2 = mustbe_constructor loc head intern_pat aliases pl scopes in
       check_constructor_length genv loc c idslpl1 pl2;
@@ -669,9 +812,9 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
   | CPatNotation (_,"( _ )",([a],[])) ->
       intern_pat scopes aliases tmp_scope a
   | CPatNotation (loc, ntn, fullargs) ->
-      let ntn,(args,argsl) = contract_pat_notation ntn fullargs in
+      let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in
       let (((ids',idsl'),c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in
-      Dumpglob.dump_notation_location (Topconstr.patntn_loc loc args ntn) df;
+      Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df;
       let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in
       let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in
       let ids'',pl =
@@ -680,9 +823,8 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
       in ids@ids'', pl
   | CPatPrim (loc, p) ->
       let a = alias_of aliases in
-      let (c,df) = Notation.interp_prim_token_cases_pattern loc p a 
+      let (c,_) = Notation.interp_prim_token_cases_pattern loc p a
 	(tmp_scope,scopes) in
-      Dumpglob.dump_notation_location (fst (unloc loc)) df;
       (ids,[asubst,c])
   | CPatDelimiters (loc, key, e) ->
       intern_pat (find_delimiters_scope loc key::scopes) aliases None e
@@ -719,10 +861,10 @@ let check_capture loc ty = function
       ()
 
 let locate_if_isevar loc na = function
-  | RHole _ -> 
+  | RHole _ ->
       (try match na with
 	| Name id ->  Reserve.find_reserved_type id
-	| Anonymous -> raise Not_found 
+	| Anonymous -> raise Not_found
       with Not_found -> RHole (loc, Evd.BinderType na))
   | x -> x
 
@@ -732,43 +874,44 @@ let check_hidden_implicit_parameters id (_,_,_,(indnames,_)) =
     pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.")
 
 let push_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) = function
-  | Anonymous -> 
+  | Anonymous ->
       if fail_anonymous then errorlabstrm "" (str "Anonymous variables not allowed");
       env
-  | Name id -> 
+  | Name id ->
       check_hidden_implicit_parameters id lvar;
       (Idset.add id ids, unb,tmpsc,scopes)
 
 let push_loc_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) loc = function
-  | Anonymous -> 
+  | Anonymous ->
       if fail_anonymous then user_err_loc (loc,"", str "Anonymous variables not allowed");
       env
-  | Name id -> 
+  | Name id ->
       check_hidden_implicit_parameters id lvar;
       Dumpglob.dump_binding loc id;
       (Idset.add id ids,unb,tmpsc,scopes)
 
 let intern_generalized_binder ?(fail_anonymous=false) intern_type lvar
     (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty =
-  let ty = 
-    if t then ty else
+  let ids = match na with Anonymous -> ids | Name na -> Idset.add na ids in
+  let ty, ids' =
+    if t then ty, ids else
       Implicit_quantifiers.implicit_application ids
 	Implicit_quantifiers.combine_params_freevar ty
   in
   let ty' = intern_type (ids,true,tmpsc,sc) ty in
-  let fvs = Implicit_quantifiers.free_vars_of_rawconstr ~bound:ids ty' in
+  let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids ~allowed:ids' ty' in
   let env' = List.fold_left (fun env (x, l) -> push_loc_name_env ~fail_anonymous lvar env l (Name x)) env fvs in
   let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in
   let na = match na with
-    | Anonymous -> 
-	if fail_anonymous then na 
+    | Anonymous ->
+	if fail_anonymous then na
 	else
-	  let name = 
-	    let id = 
+	  let name =
+	    let id =
 	      match ty with
 	      | CApp (_, (_, CRef (Ident (loc,id))), _) -> id
 	      | _ -> id_of_string "H"
-	    in Implicit_quantifiers.make_fresh ids (Global.env ()) id
+	    in Implicit_quantifiers.make_fresh ids' (Global.env ()) id
 	  in Name name
     | _ -> na
   in (push_loc_name_env ~fail_anonymous lvar env' loc na), (na,b',None,ty') :: List.rev bl
@@ -793,26 +936,26 @@ let intern_local_binder_aux ?(fail_anonymous=false) intern intern_type lvar ((id
 
 let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c =
   let c = intern (ids,true,tmp_scope,scopes) c in
-  let fvs = Implicit_quantifiers.free_vars_of_rawconstr ~bound:ids c in
-  let env', c' = 
-    let abs = 
-      let pi = 
+  let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids c in
+  let env', c' =
+    let abs =
+      let pi =
 	match ak with
 	| Some AbsPi -> true
-	| None when tmp_scope = Some Notation.type_scope 
+	| None when tmp_scope = Some Notation.type_scope
 	    || List.mem Notation.type_scope scopes -> true
 	| _ -> false
-      in 
+      in
 	if pi then
 	  (fun (id, loc') acc ->
 	    RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
 	else
-	  (fun (id, loc') acc -> 
+	  (fun (id, loc') acc ->
 	    RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
     in
-      List.fold_right (fun (id, loc as lid) (env, acc) -> 
+      List.fold_right (fun (id, loc as lid) (env, acc) ->
 	let env' = push_loc_name_env lvar env loc (Name id) in
-	  (env', abs lid acc)) fvs (env,c) 
+	  (env', abs lid acc)) fvs (env,c)
   in c'
 
 (**********************************************************************)
@@ -820,20 +963,20 @@ let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk a
 
 let merge_impargs l args =
   List.fold_right (fun a l ->
-    match a with 
-      | (_,Some (_,(ExplByName id as x))) when 
+    match a with
+      | (_,Some (_,(ExplByName id as x))) when
 	  List.exists (function (_,Some (_,y)) -> x=y | _ -> false) args -> l
       | _ -> a::l)
-    l args 
+    l args
 
-let check_projection isproj nargs r = 
+let check_projection isproj nargs r =
   match (r,isproj) with
   | RRef (loc, ref), Some _ ->
       (try
 	let n = Recordops.find_projection_nparams ref + 1 in
 	if nargs <> n then
 	  user_err_loc (loc,"",str "Projection has not the right number of explicit parameters.");
-      with Not_found -> 
+      with Not_found ->
 	user_err_loc
 	(loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection."))
   | _, Some _ -> user_err_loc (loc_of_rawconstr r, "", str "Not a projection.")
@@ -842,9 +985,9 @@ let check_projection isproj nargs r =
 let get_implicit_name n imps =
   Some (Impargs.name_of_implicit (List.nth imps (n-1)))
 
-let set_hole_implicit i = function
-  | RRef (loc,r) -> (loc,Evd.ImplicitArg (r,i))
-  | RVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i))
+let set_hole_implicit i b = function
+  | RRef (loc,r) | RApp (_,RRef (loc,r),_) -> (loc,Evd.ImplicitArg (r,i,b))
+  | RVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i,b))
   | _ -> anomaly "Only refs have implicits"
 
 let exists_implicit_name id =
@@ -869,7 +1012,7 @@ let extract_explicit_arg imps args =
 	      id
 	  | ExplByPos (p,_id) ->
 	      let id =
-		try 
+		try
 		  let imp = List.nth imps (p-1) in
 		  if not (is_status_implicit imp) then failwith "imp";
 		  name_of_implicit imp
@@ -905,37 +1048,29 @@ let internalise sigma globalenv env allow_patvar lvar c =
 	in
         let idl = Array.map
           (fun (id,(n,order),bl,ty,bd) ->
-	     let intern_ro_arg c f =
-	       let idx = 
-		 match n with
-		     Some (loc, n) -> list_index0 (Name n) (List.map snd (names_of_local_assums bl))
-		   | None -> 0
-	       in
+	     let intern_ro_arg f =
+               let idx = Option.default 0 (index_of_annot bl n) in
 	       let before, after = list_chop idx bl in
 	       let ((ids',_,_,_) as env',rbefore) =
 		 List.fold_left intern_local_binder (env,[]) before in
-	       let ro =
-		 match c with 
-		   | None -> RStructRec 
-		   | Some c' -> f (intern (ids', unb, tmp_scope, scopes) c') 
-	       in 
+	       let ro = f (intern (ids', unb, tmp_scope, scopes)) in
 	       let n' = Option.map (fun _ -> List.length before) n in
 		 n', ro, List.fold_left intern_local_binder (env',rbefore) after
 	     in
 	     let n, ro, ((ids',_,_,_),rbl) =
-	       (match order with
-		 | CStructRec -> 
-		     intern_ro_arg None (fun _ -> RStructRec)
-		 | CWfRec c ->
-		     intern_ro_arg (Some c) (fun r -> RWfRec r)
-		 | CMeasureRec c ->
-		     intern_ro_arg (Some c) (fun r -> RMeasureRec r))
+	       match order with
+	       | CStructRec ->
+		   intern_ro_arg (fun _ -> RStructRec)
+	       | CWfRec c ->
+		   intern_ro_arg (fun f -> RWfRec (f c))
+	       | CMeasureRec (m,r) ->
+		   intern_ro_arg (fun f -> RMeasureRec (f m, Option.map f r))
 	     in
 	     let ids'' = List.fold_right Idset.add lf ids' in
-	     ((n, ro), List.rev rbl, 
+	     ((n, ro), List.rev rbl,
              intern_type (ids',unb,tmp_scope,scopes) ty,
              intern (ids'',unb,None,scopes) bd)) dl in
-	RRec (loc,RFix 
+	RRec (loc,RFix
 	      (Array.map (fun (ro,_,_,_) -> ro) idl,n),
               Array.of_list lf,
               Array.map (fun (_,bl,_,_) -> bl) idl,
@@ -976,7 +1111,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
 	RLetIn (loc, na, intern (reset_tmp_scope env) c1,
           intern (push_loc_name_env lvar env loc1 na) c2)
     | CNotation (loc,"- _",([CPrim (_,Numeral p)],[]))
-	when Bigint.is_strictly_pos p -> 
+	when Bigint.is_strictly_pos p ->
 	intern env (CPrim (loc,Numeral (Bigint.neg p)))
     | CNotation (_,"( _ )",([a],[])) -> intern env a
     | CNotation (loc,ntn,args) ->
@@ -984,9 +1119,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
     | CGeneralization (loc,b,a,c) ->
         intern_generalization intern env lvar loc b a c
     | CPrim (loc, p) ->
-	let c,df = Notation.interp_prim_token loc p (tmp_scope,scopes) in
-	Dumpglob.dump_notation_location (fst (unloc loc)) df;
-	c
+	fst (Notation.interp_prim_token loc p (tmp_scope,scopes))
     | CDelimiters (loc, key, e) ->
 	intern (ids,unb,None,find_delimiters_scope loc key::scopes) e
     | CAppExpl (loc, (isproj,ref), args) ->
@@ -994,6 +1127,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
 	  let args = List.map (fun a -> (a,None)) args in
 	  intern_applied_reference intern env lvar args ref in
 	check_projection isproj (List.length args) f;
+	(* Rem: RApp(_,f,[]) stands for @f *)
 	RApp (loc, f, intern_args env args_scopes (List.map fst args))
     | CApp (loc, (isproj,f), args) ->
         let isproj,f,args = match f with
@@ -1006,48 +1140,28 @@ let internalise sigma globalenv env allow_patvar lvar c =
             | CRef ref -> intern_applied_reference intern env lvar args ref
             | CNotation (loc,ntn,([],[])) ->
                 let c = intern_notation intern env loc ntn ([],[]) in
-                find_appl_head_data lvar c, args
+                find_appl_head_data c, args
             | x -> (intern env f,[],[],[]), args in
-	let args = 
+	let args =
 	  intern_impargs c env impargs args_scopes (merge_impargs l args) in
 	check_projection isproj (List.length args) c;
-	(match c with 
+	(match c with
           (* Now compact "(f args') args" *)
 	  | RApp (loc', f', args') -> RApp (join_loc loc' loc, f',args'@args)
 	  | _ -> RApp (loc, c, args))
-    | CRecord (loc, w, fs) ->
-	let id, _ = List.hd fs in
-	let record = 
-	  let (id,_,_,_),_ = intern_applied_reference intern env lvar [] (Ident id) in
-	    match id with
-	    | RRef (loc, ref) -> 
-		(try Recordops.find_projection ref
-		  with Not_found -> user_err_loc (loc, "intern", str"Not a projection"))
-	    | c -> user_err_loc (loc_of_rawconstr id, "intern", str"Not a projection")
-	in
-	let args =
-	  let pars = list_make record.Recordops.s_EXPECTEDPARAM (CHole (loc, None)) in	    
-	  let fields, rest = 
-	    List.fold_left (fun (args, rest as acc) (na, b) ->
-	      if b then 
-		try 
-		  let id = out_name na in
-		  let _, t = List.assoc id rest in
-		    t :: args, List.remove_assoc id rest
-		with _ -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: args, rest
-	      else acc) ([], List.map (fun ((loc, id), t) -> id, (loc, t)) fs) record.Recordops.s_PROJKIND
-	  in 
-	    if rest <> [] then 
-	      let id, (loc, t) = List.hd rest in
-		user_err_loc (loc,"intern",(str "Unknown field name " ++ pr_id id))
-	    else pars @ List.rev fields
-	in
-	let constrname = 
-	  Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef record.Recordops.s_CONST)) 
-	in
-	let app = CAppExpl (loc, (None, constrname), args) in
+    | CRecord (loc, _, fs) ->
+	let cargs =
+	  sort_fields true loc fs
+	    (fun k l -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: l)
+	  in
+	begin
+	  match cargs with
+	    | None -> user_err_loc (loc, "intern", str"No constructor inference.")
+	    | Some (n, constrname, args) ->
+		let pars = list_make n (CHole (loc, None)) in
+		let app = CAppExpl (loc, (None, constrname), List.rev_append pars args) in
 	  intern env app
-
+	end
     | CCases (loc, sty, rtnpo, tms, eqns) ->
         let tms,env' = List.fold_right
           (fun citm (inds,env) ->
@@ -1072,7 +1186,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
           let env'' = List.fold_left (push_name_env lvar) env ids in
 	  intern_type env'' p) po in
         RIf (loc, c', (na', p'), intern env b1, intern env b2)
-    | CHole (loc, k) -> 
+    | CHole (loc, k) ->
 	RHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true))
     | CPatVar (loc, n) when allow_patvar ->
 	RPatVar (loc, n)
@@ -1091,12 +1205,12 @@ let internalise sigma globalenv env allow_patvar lvar c =
 
   and intern_type env = intern (set_type_scope env)
 
-  and intern_local_binder env bind = 
+  and intern_local_binder env bind =
     intern_local_binder_aux intern intern_type lvar env bind
 
   (* Expands a multiple pattern into a disjunction of multiple patterns *)
   and intern_multiple_pattern scopes n (loc,pl) =
-    let idsl_pll = 
+    let idsl_pll =
       List.map (intern_cases_pattern globalenv scopes ([],[]) None) pl in
     check_number_of_pattern loc n pl;
     product_of_cases_patterns [] idsl_pll
@@ -1125,7 +1239,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
   and intern_case_item (vars,unb,_,scopes as env) (tm,(na,t)) =
     let tm' = intern env tm in
     let ids,typ = match t with
-    | Some t -> 
+    | Some t ->
 	let tids = ids_of_cases_indtype t in
 	let tids = List.fold_right Idset.add tids Idset.empty in
 	let t = intern_type (tids,unb,None,scopes) t in
@@ -1145,7 +1259,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
 	if List.exists ((<>) Anonymous) parnal then
 	  error_inductive_parameter_not_implicit loc;
 	realnal, Some (loc,ind,nparams,realnal)
-    | None -> 
+    | None ->
 	[], None in
     let na = match tm', na with
       | RVar (_,id), None when Idset.mem id vars -> Name id
@@ -1153,7 +1267,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
       | _, None -> Anonymous
       | _, Some na -> na in
     (tm',(na,typ)), na::ids
-      
+
   and iterate_prod loc2 env bk ty body nal =
     let rec default env bk = function
     | (loc1,na)::nal ->
@@ -1165,14 +1279,14 @@ let internalise sigma globalenv env allow_patvar lvar c =
     in
       match bk with
 	| Default b -> default env b nal
-	| Generalized (b,b',t) -> 
+	| Generalized (b,b',t) ->
 	    let env, ibind = intern_generalized_binder intern_type lvar
 	      env [] (List.hd nal) b b' t ty in
 	    let body = intern_type env body in
 	      it_mkRProd ibind body
-					   
-  and iterate_lam loc2 env bk ty body nal = 
-    let rec default env bk = function 
+
+  and iterate_lam loc2 env bk ty body nal =
+    let rec default env bk = function
       | (loc1,na)::nal ->
 	  if nal <> [] then check_capture loc1 ty na;
 	  let body = default (push_loc_name_env lvar env loc1 na) bk nal in
@@ -1181,19 +1295,19 @@ let internalise sigma globalenv env allow_patvar lvar c =
       | [] -> intern env body
     in match bk with
       | Default b -> default env b nal
-      | Generalized (b, b', t) ->	  
+      | Generalized (b, b', t) ->
 	  let env, ibind = intern_generalized_binder intern_type lvar
 	    env [] (List.hd nal) b b' t ty in
 	  let body = intern env body in
 	    it_mkRLambda ibind body
-	      
+
   and intern_impargs c env l subscopes args =
     let eargs, rargs = extract_explicit_arg l args in
     let rec aux n impl subscopes eargs rargs =
       let (enva,subscopes') = apply_scope_env env subscopes in
       match (impl,rargs) with
       | (imp::impl', rargs) when is_status_implicit imp ->
-	  begin try 
+	  begin try
 	    let id = name_of_implicit imp in
 	    let (_,a) = List.assoc id eargs in
 	    let eargs' = List.remove_assoc id eargs in
@@ -1204,16 +1318,16 @@ let internalise sigma globalenv env allow_patvar lvar c =
             (* with implicit arguments if maximal insertion is set *)
 	    []
 	  else
-	    RHole (set_hole_implicit (n,get_implicit_name n l) c) :: 
+	    RHole (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) ::
 	      aux (n+1) impl' subscopes' eargs rargs
 	  end
       | (imp::impl', a::rargs') ->
 	  intern enva a :: aux (n+1) impl' subscopes' eargs rargs'
-      | (imp::impl', []) -> 
-	  if eargs <> [] then 
+      | (imp::impl', []) ->
+	  if eargs <> [] then
 	    (let (id,(loc,_)) = List.hd eargs in
 	       user_err_loc (loc,"",str "Not enough non implicit
-	    arguments to accept the argument bound to " ++ 
+	    arguments to accept the argument bound to " ++
 		 pr_id id ++ str"."));
 	  []
       | ([], rargs) ->
@@ -1227,51 +1341,49 @@ let internalise sigma globalenv env allow_patvar lvar c =
         let (enva,subscopes) = apply_scope_env env subscopes in
         (intern enva a) :: (intern_args env subscopes args)
 
-  in 
-  try 
+  in
+  try
     intern env c
   with
       InternalisationError (loc,e) ->
-	user_err_loc (loc,"internalize",explain_internalisation_error e)
+	user_err_loc (loc,"internalize",
+	  explain_internalisation_error e)
 
 (**************************************************************************)
 (* Functions to translate constr_expr into rawconstr                       *)
 (**************************************************************************)
 
 let extract_ids env =
-  List.fold_right Idset.add 
+  List.fold_right Idset.add
     (Termops.ids_of_rel_context (Environ.rel_context env))
     Idset.empty
 
 let intern_gen isarity sigma env
                ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
                c =
-  let tmp_scope = 
+  let tmp_scope =
     if isarity then Some Notation.type_scope else None in
     internalise sigma env (extract_ids env, false, tmp_scope,[])
       allow_patvar (ltacvars,Environ.named_context env, [], impls) c
-      
-let intern_constr sigma env c = intern_gen false sigma env c 
 
-let intern_type sigma env c = intern_gen true sigma env c 
+let intern_constr sigma env c = intern_gen false sigma env c
+
+let intern_type sigma env c = intern_gen true sigma env c
 
 let intern_pattern env patt =
   try
-    intern_cases_pattern env [] ([],[]) None patt 
-  with 
+    intern_cases_pattern env [] ([],[]) None patt
+  with
       InternalisationError (loc,e) ->
 	user_err_loc (loc,"internalize",explain_internalisation_error e)
 
 
-let intern_ltac isarity ltacvars sigma env c =
-  intern_gen isarity sigma env ~ltacvars:ltacvars c
-
-type manual_implicits = (explicitation * (bool * bool)) list
+type manual_implicits = (explicitation * (bool * bool * bool)) list
 
 (*********************************************************************)
 (* Functions to parse and interpret constructions *)
 
-let interp_gen kind sigma env 
+let interp_gen kind sigma env
                ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
                c =
   let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in
@@ -1284,39 +1396,56 @@ let interp_type sigma env ?(impls=([],[])) c =
   interp_gen IsType sigma env ~impls c
 
 let interp_casted_constr sigma env ?(impls=([],[])) c typ =
-  interp_gen (OfType (Some typ)) sigma env ~impls c 
+  interp_gen (OfType (Some typ)) sigma env ~impls c
 
 let interp_open_constr sigma env c =
   Default.understand_tcc sigma env (intern_constr sigma env c)
 
+let interp_open_constr_patvar sigma env c =
+  let raw = intern_gen false sigma env c ~allow_patvar:true in
+  let sigma = ref (Evd.create_evar_defs sigma) in
+  let evars = ref (Gmap.empty : (identifier,rawconstr) Gmap.t) in
+  let rec patvar_to_evar r = match r with
+    | RPatVar (loc,(_,id)) ->
+	( try Gmap.find id !evars
+	  with Not_found ->
+	    let ev = Evarutil.e_new_evar sigma env (Termops.new_Type()) in
+	    let ev = Evarutil.e_new_evar sigma env ev in
+	    let rev = REvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in
+	    evars := Gmap.add id rev !evars;
+	    rev
+	)
+    | _ -> map_rawconstr patvar_to_evar r in
+  let raw = patvar_to_evar raw in
+  Default.understand_tcc !sigma env raw
+
 let interp_constr_judgment sigma env c =
   Default.understand_judgment sigma env (intern_constr sigma env c)
 
-let interp_constr_evars_gen_impls ?evdref
+let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true)
     env ?(impls=([],[])) kind c =
-  match evdref with 
-    | None -> 
-	let c = intern_gen (kind=IsType) ~impls Evd.empty env c in
-	let imps = Implicit_quantifiers.implicits_of_rawterm c in
-	  Default.understand_gen kind Evd.empty env c, imps
-    | Some evdref ->
-	let c = intern_gen (kind=IsType) ~impls (Evd.evars_of !evdref) env c in
-	let imps = Implicit_quantifiers.implicits_of_rawterm c in
-	  Default.understand_tcc_evars evdref env kind c, imps
+  let evdref =
+    match evdref with
+    | None -> ref Evd.empty
+    | Some evdref -> evdref
+  in
+  let c = intern_gen (kind=IsType) ~impls !evdref env c in
+  let imps = Implicit_quantifiers.implicits_of_rawterm c in
+    Default.understand_tcc_evars ~fail_evar evdref env kind c, imps
 
-let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
-  let c = intern_gen (kind=IsType) ~impls (Evd.evars_of !evdref) env c in
-    Default.understand_tcc_evars evdref env kind c
-      
-let interp_casted_constr_evars_impls ?evdref
+let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true)
     env ?(impls=([],[])) c typ =
-  interp_constr_evars_gen_impls ?evdref env ~impls (OfType (Some typ)) c
+  interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c
 
-let interp_type_evars_impls ?evdref env ?(impls=([],[])) c =
-  interp_constr_evars_gen_impls ?evdref env IsType ~impls c
+let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c =
+  interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c
 
-let interp_constr_evars_impls ?evdref env ?(impls=([],[])) c =
-  interp_constr_evars_gen_impls ?evdref env (OfType None) ~impls c
+let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c =
+  interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c
+
+let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+  let c = intern_gen (kind=IsType) ~impls ( !evdref) env c in
+    Default.understand_tcc_evars evdref env kind c
 
 let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
   interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
@@ -1324,27 +1453,23 @@ let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
 let interp_type_evars evdref env ?(impls=([],[])) c =
   interp_constr_evars_gen evdref env IsType ~impls c
 
-let interp_constr_judgment_evars evdref env c =
-  Default.understand_judgment_tcc evdref env
-    (intern_constr (Evd.evars_of !evdref) env c)
-
 type ltac_sign = identifier list * unbound_ltac_var_map
 
 let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c =
   let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in
   pattern_of_rawconstr c
 
-let interp_aconstr impls (vars,varslist) a =
+let interp_aconstr ?(impls=([],[])) (vars,varslist) a =
   let env = Global.env () in
   (* [vl] is intended to remember the scope of the free variables of [a] *)
   let vl = List.map (fun id -> (id,ref None)) (vars@varslist) in
   let c = internalise Evd.empty (Global.env()) (extract_ids env, false, None, [])
-    false (([],[]),Environ.named_context env,vl,([],impls)) a in
+    false (([],[]),Environ.named_context env,vl,impls) a in
   (* Translate and check that [c] has all its free variables bound in [vars] *)
   let a = aconstr_of_rawconstr vars c in
   (* Returns [a] and the ordered list of variables with their scopes *)
   (* Variables occurring in binders have no relevant scope since bound *)
-  let vl = List.map (fun (id,r) -> 
+  let vl = List.map (fun (id,r) ->
     (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl in
   list_chop (List.length vars) vl, a
 
@@ -1356,7 +1481,7 @@ let interp_binder sigma env na t =
   Default.understand_type sigma env t'
 
 let interp_binder_evars evdref env na t =
-  let t = intern_gen true (Evd.evars_of !evdref) env t in
+  let t = intern_gen true !evdref env t in
   let t' = locate_if_isevar (loc_of_rawconstr t) na t in
   Default.understand_tcc_evars evdref env IsType t'
 
@@ -1374,7 +1499,7 @@ let intern_context fail_anonymous sigma env params =
 	    (intern_local_binder_aux ~fail_anonymous (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar)
 	    ((extract_ids env,false,None,[]), []) params)
 
-let interp_context_gen understand_type understand_judgment env bl = 
+let interp_rawcontext_gen understand_type understand_judgment env bl =
   let (env, par, _, impls) =
     List.fold_left
       (fun (env,params,n,impls) (na, k, b, t) ->
@@ -1383,10 +1508,10 @@ let interp_context_gen understand_type understand_judgment env bl =
 	      let t' = locate_if_isevar (loc_of_rawconstr t) na t in
 	      let t = understand_type env t' in
 	      let d = (na,None,t) in
-	      let impls = 
+	      let impls =
 		if k = Implicit then
 		  let na = match na with Name n -> Some n | Anonymous -> None in
-		    (ExplByPos (n, na), (true, true)) :: impls
+		    (ExplByPos (n, na), (true, true, true)) :: impls
 		else impls
 	      in
 		(push_rel d env, d::params, succ n, impls)
@@ -1397,42 +1522,15 @@ let interp_context_gen understand_type understand_judgment env bl =
       (env,[],1,[]) (List.rev bl)
   in (env, par), impls
 
-let interp_context ?(fail_anonymous=false) sigma env params = 
+let interp_context_gen understand_type understand_judgment ?(fail_anonymous=false) sigma env params =
   let bl = intern_context fail_anonymous sigma env params in
-    interp_context_gen (Default.understand_type sigma) 
-      (Default.understand_judgment sigma) env bl
-    
-let interp_context_evars ?(fail_anonymous=false) evdref env params =
-  let bl = intern_context fail_anonymous (Evd.evars_of !evdref) env params in
-    interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t)
-      (Default.understand_judgment_tcc evdref) env bl
-    
-(**********************************************************************)
-(* Locating reference, possibly via an abbreviation *)
-
-let locate_reference qid =
-  match Nametab.extended_locate qid with
-    | TrueGlobal ref -> ref
-    | SyntacticDef kn -> 
-	match Syntax_def.search_syntactic_definition dummy_loc kn with
-	  | [],ARef ref -> ref
-	  | _ -> raise Not_found
+    interp_rawcontext_gen understand_type understand_judgment env bl
 
-let is_global id =
-  try 
-    let _ = locate_reference (make_short_qualid id) in true
-  with Not_found -> 
-    false
-
-let global_reference id = 
-  constr_of_global (locate_reference (make_short_qualid id))
-
-let construct_reference ctx id =
-  try
-    Term.mkVar (let _ = Sign.lookup_named id ctx in id)
-  with Not_found ->
-    global_reference id
-
-let global_reference_in_absolute_module dir id = 
-  constr_of_global (Nametab.absolute_reference (Libnames.make_path dir id))
+let interp_context ?(fail_anonymous=false) sigma env params =
+  interp_context_gen (Default.understand_type sigma) 
+    (Default.understand_judgment sigma) ~fail_anonymous sigma env params
 
+let interp_context_evars ?(fail_anonymous=false) evdref env params =
+  interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t)
+    (Default.understand_judgment_tcc evdref) ~fail_anonymous !evdref env params
+    
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index c5371255..5a62541d 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: constrintern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -33,21 +33,44 @@ open Pretyping
    - insert existential variables for implicit arguments
 *)
 
-(* To interpret implicits and arg scopes of recursive variables in
-   inductive types and recursive definitions; mention of a list of
-   implicits arguments in the ``rel'' part of [env]; the second
-   argument associates a list of implicit positions and scopes to
-   identifiers declared in the [rel_context] of [env] *)
+(* To interpret implicits and arg scopes of recursive variables while
+   internalizing inductive types and recursive definitions, and also
+   projection while typing records.
 
-type var_internalisation_type = Inductive | Recursive | Method 
-    
-type var_internalisation_data =
-  var_internalisation_type * identifier list * Impargs.implicits_list * scope_name option list
+   the third and fourth arguments associate a list of implicit
+   positions and scopes to identifiers declared in the [rel_context]
+   of [env] *)
 
-type implicits_env = (identifier * var_internalisation_data) list
-type full_implicits_env = identifier list * implicits_env
+type var_internalization_type = Inductive | Recursive | Method
 
-type manual_implicits = (explicitation * (bool * bool)) list
+type var_internalization_data =
+    var_internalization_type *
+    identifier list *
+    Impargs.implicits_list *
+    scope_name option list
+
+(* A map of free variables to their implicit arguments and scopes *)
+type internalization_env =
+    (identifier * var_internalization_data) list
+
+(* Contains also a list of identifiers to automatically apply to the variables*)
+type full_internalization_env =
+    identifier list * internalization_env
+
+val empty_internalization_env : full_internalization_env
+
+val compute_internalization_data : env -> var_internalization_type ->
+  types -> Impargs.manual_explicitation list -> var_internalization_data
+
+val set_internalization_env_params :
+  internalization_env -> identifier list -> full_internalization_env
+
+val compute_full_internalization_env : env ->
+  var_internalization_type ->
+  identifier list -> identifier list -> types list ->
+  Impargs.manual_explicitation list list -> full_internalization_env
+
+type manual_implicits = (explicitation * (bool * bool * bool)) list
 
 type ltac_sign = identifier list * unbound_ltac_var_map
 
@@ -60,7 +83,7 @@ val intern_constr : evar_map -> env -> constr_expr -> rawconstr
 val intern_type : evar_map -> env -> constr_expr -> rawconstr
 
 val intern_gen : bool -> evar_map -> env ->
-  ?impls:full_implicits_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
+  ?impls:full_internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
   constr_expr -> rawconstr
 
 val intern_pattern : env -> cases_pattern_expr ->
@@ -69,42 +92,46 @@ val intern_pattern : env -> cases_pattern_expr ->
 
 val intern_context : bool -> evar_map -> env -> local_binder list -> raw_binder list
 
-(*s Composing internalisation with pretyping *)
+(*s Composing internalization with pretyping *)
 
 (* Main interpretation function *)
 
 val interp_gen : typing_constraint -> evar_map -> env ->
-  ?impls:full_implicits_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
+  ?impls:full_internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
   constr_expr -> constr
 
 (* Particular instances *)
 
-val interp_constr : evar_map -> env -> 
+val interp_constr : evar_map -> env ->
   constr_expr -> constr
 
-val interp_type : evar_map -> env -> ?impls:full_implicits_env -> 
+val interp_type : evar_map -> env -> ?impls:full_internalization_env ->
   constr_expr -> types
 
 val interp_open_constr   : evar_map -> env -> constr_expr -> evar_map * constr
 
-val interp_casted_constr : evar_map -> env -> ?impls:full_implicits_env -> 
+val interp_open_constr_patvar   : evar_map -> env -> constr_expr -> evar_map * constr
+
+val interp_casted_constr : evar_map -> env -> ?impls:full_internalization_env ->
   constr_expr -> types -> constr
 
 (* Accepting evars and giving back the manual implicits in addition. *)
 
-val interp_casted_constr_evars_impls : ?evdref:(evar_defs ref) -> env -> 
-  ?impls:full_implicits_env -> constr_expr -> types -> constr * manual_implicits
+val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env ->
+  ?impls:full_internalization_env -> constr_expr -> types -> constr * manual_implicits
 
-val interp_type_evars_impls : ?evdref:(evar_defs ref) -> env -> ?impls:full_implicits_env ->
+val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
+  env -> ?impls:full_internalization_env ->
   constr_expr -> types * manual_implicits
 
-val interp_constr_evars_impls : ?evdref:(evar_defs ref) -> env -> ?impls:full_implicits_env ->
+val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
+  env -> ?impls:full_internalization_env ->
   constr_expr -> constr * manual_implicits
 
-val interp_casted_constr_evars : evar_defs ref -> env -> 
-  ?impls:full_implicits_env -> constr_expr -> types -> constr
+val interp_casted_constr_evars : evar_map ref -> env ->
+  ?impls:full_internalization_env -> constr_expr -> types -> constr
 
-val interp_type_evars : evar_defs ref -> env -> ?impls:full_implicits_env ->
+val interp_type_evars : evar_map ref -> env -> ?impls:full_internalization_env ->
   constr_expr -> types
 
 (*s Build a judgment  *)
@@ -113,29 +140,38 @@ val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment
 
 (* Interprets constr patterns *)
 
-val intern_constr_pattern : 
-  evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign -> 
+val intern_constr_pattern :
+  evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign ->
     constr_pattern_expr -> patvar list * constr_pattern
 
+(* Raise Not_found if syndef not bound to a name and error if unexisting ref *)
+val intern_reference : reference -> global_reference
+
+(* Expands abbreviations (syndef); raise an error if not existing *)
 val interp_reference : ltac_sign -> reference -> rawconstr
 
 (* Interpret binders *)
 
 val interp_binder  : evar_map -> env -> name -> constr_expr -> types
 
-val interp_binder_evars : evar_defs ref -> env -> name -> constr_expr -> types
+val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types
 
 (* Interpret contexts: returns extended env and context *)
 
-val interp_context : ?fail_anonymous:bool -> 
+val interp_context_gen : (env -> rawconstr -> types) ->
+  (env -> rawconstr -> unsafe_judgment) ->
+  ?fail_anonymous:bool ->
+  evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits
+  
+val interp_context : ?fail_anonymous:bool ->
   evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits
 
-val interp_context_evars : ?fail_anonymous:bool -> 
-  evar_defs ref -> env -> local_binder list -> (env * rel_context) * manual_implicits
+val interp_context_evars : ?fail_anonymous:bool ->
+  evar_map ref -> env -> local_binder list -> (env * rel_context) * manual_implicits
 
 (* Locating references of constructions, possibly via a syntactic definition *)
+(* (these functions do not modify the glob file) *)
 
-val locate_reference : qualid -> global_reference
 val is_global : identifier -> bool
 val construct_reference : named_context -> identifier -> constr
 val global_reference : identifier -> constr
@@ -143,8 +179,8 @@ val global_reference_in_absolute_module : dir_path -> identifier -> constr
 
 (* Interprets into a abbreviatable constr *)
 
-val interp_aconstr : implicits_env -> identifier list * identifier list 
-  -> constr_expr -> interpretation
+val interp_aconstr : ?impls:full_internalization_env ->
+  identifier list * identifier list -> constr_expr -> interpretation
 
 (* Globalization leak for Grammar *)
 val for_grammar : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index ca758458..898369be 100644
--- a/interp/coqlib.ml
+++ b/interp/coqlib.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqlib.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -15,6 +15,7 @@ open Term
 open Libnames
 open Pattern
 open Nametab
+open Smartlocate
 
 (************************************************************************)
 (* Generic functions to find Coq objects *)
@@ -25,10 +26,8 @@ let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 
 let find_reference locstr dir s =
   let sp = Libnames.make_path (make_dir dir) (id_of_string s) in
-  try
-    Nametab.absolute_reference sp
-  with Not_found ->
-    anomaly (locstr^": cannot find "^(string_of_path sp))
+  try global_of_extended_global (Nametab.extended_global_of_path sp)
+  with Not_found -> anomaly (locstr^": cannot find "^(string_of_path sp))
 
 let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s
 let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s)
@@ -37,25 +36,29 @@ let gen_reference = coq_reference
 let gen_constant = coq_constant
 
 let has_suffix_in_dirs dirs ref =
-  let dir = dirpath (sp_of_global ref) in
+  let dir = dirpath (path_of_global ref) in
   List.exists (fun d -> is_dirpath_prefix_of d dir) dirs
 
+let global_of_extended q =
+  try Some (global_of_extended_global q) with Not_found -> None
+
 let gen_constant_in_modules locstr dirs s =
   let dirs = List.map make_dir dirs in
   let id = id_of_string s in
-  let all = Nametab.locate_all (make_short_qualid id) in
+  let all = Nametab.locate_extended_all (qualid_of_ident id) in
+  let all = list_uniquize (list_map_filter global_of_extended all) in
   let these = List.filter (has_suffix_in_dirs dirs) all in
   match these with
     | [x] -> constr_of_global x
     | [] ->
 	anomalylabstrm "" (str (locstr^": cannot find "^s^
 	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
-	prlist_with_sep pr_coma pr_dirpath dirs)
+	prlist_with_sep pr_comma pr_dirpath dirs)
     | l ->
-	anomalylabstrm "" 
+	anomalylabstrm ""
 	(str (locstr^": found more than once object of name "^s^
 	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
-	prlist_with_sep pr_coma pr_dirpath dirs)
+	prlist_with_sep pr_comma pr_dirpath dirs)
 
 
 (* For tactics/commands requiring vernacular libraries *)
@@ -63,21 +66,29 @@ let gen_constant_in_modules locstr dirs s =
 let check_required_library d =
   let d' = List.map id_of_string d in
   let dir = make_dirpath (List.rev d') in
+  let mp = (fst(Lib.current_prefix())) in
+  let current_dir = match mp with
+    | MPfile dp -> (dir=dp)
+    | _ -> false
+  in
   if not (Library.library_is_loaded dir) then
+    if not current_dir then
 (* Loading silently ...
     let m, prefix = list_sep_last d' in
-    read_library 
+    read_library
      (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m)
 *)
 (* or failing ...*)
-    error ("Library "^(string_of_dirpath dir)^" has to be required first.")
+      error ("Library "^(string_of_dirpath dir)^" has to be required first.")
 
 (************************************************************************)
 (* Specific Coq objects *)
 
 let init_reference dir s = gen_reference "Coqlib" ("Init"::dir) s
 
-let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s  
+let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s
+
+let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s
 
 let arith_dir = ["Coq";"Arith"]
 let arith_modules = [arith_dir]
@@ -96,7 +107,7 @@ let init_modules = [
   init_dir@["Peano"];
   init_dir@["Wf"]
 ]
-  
+
 let coq_id = id_of_string "Coq"
 let init_id = id_of_string "Init"
 let arith_id = id_of_string "Arith"
@@ -104,12 +115,21 @@ let datatypes_id = id_of_string "Datatypes"
 
 let logic_module_name = ["Coq";"Init";"Logic"]
 let logic_module = make_dir logic_module_name
-let logic_type_module = make_dir ["Coq";"Init";"Logic_Type"]
-let datatypes_module = make_dir ["Coq";"Init";"Datatypes"]
-let arith_module = make_dir ["Coq";"Arith";"Arith"]
+
+let logic_type_module_name = ["Coq";"Init";"Logic_Type"]
+let logic_type_module = make_dir logic_type_module_name
+
+let datatypes_module_name = ["Coq";"Init";"Datatypes"]
+let datatypes_module = make_dir datatypes_module_name
+
+let arith_module_name = ["Coq";"Arith";"Arith"]
+let arith_module = make_dir arith_module_name
+
+let jmeq_module_name = ["Coq";"Logic";"JMeq"]
+let jmeq_module = make_dir jmeq_module_name
 
 (* TODO: temporary hack *)
-let make_kn dir id = Libnames.encode_kn dir id
+let make_kn dir id = Libnames.encode_mind dir id
 let make_con dir id = Libnames.encode_con dir id
 
 (** Identity *)
@@ -142,9 +162,14 @@ let glob_false  = ConstructRef path_of_false
 
 (** Equality *)
 let eq_kn = make_kn logic_module (id_of_string "eq")
-
 let glob_eq = IndRef (eq_kn,0)
 
+let identity_kn = make_kn datatypes_module (id_of_string "identity")
+let glob_identity = IndRef (identity_kn,0)
+
+let jmeq_kn = make_kn jmeq_module (id_of_string "JMeq")
+let glob_jmeq = IndRef (jmeq_kn,0)
+
 type coq_sigma_data = {
   proj1 : constr;
   proj2 : constr;
@@ -159,7 +184,7 @@ type coq_bool_data  = {
 
 type 'a delayed = unit -> 'a
 
-let build_bool_type () = 
+let build_bool_type () =
   { andb =  init_constant ["Datatypes"] "andb";
     andb_prop =  init_constant ["Datatypes"] "andb_prop";
     andb_true_intro =  init_constant ["Datatypes"] "andb_true_intro" }
@@ -182,41 +207,93 @@ let build_prod () =
     typ = init_constant ["Datatypes"] "prod" }
 
 (* Equalities *)
-type coq_leibniz_eq_data = {
+type coq_eq_data = {
   eq   : constr;
-  refl : constr;
   ind  : constr;
-  rrec : constr option;
-  rect : constr option;
-  congr: constr;
-  sym  : constr }
+  refl : constr;
+  sym  : constr;
+  trans: constr;
+  congr: constr }
+
+(* Data needed for discriminate and injection *)
+type coq_inversion_data = {
+  inv_eq   : constr; (* : forall params, t -> Prop *)
+  inv_ind  : constr; (* : forall params P y, eq params y -> P y *)
+  inv_congr: constr  (* : forall params B (f:t->B) y, eq params y -> f c=f y *)
+}
 
 let lazy_init_constant dir id = lazy (init_constant dir id)
+let lazy_logic_constant dir id = lazy (logic_constant dir id)
+
+(* Leibniz equality on Type *)
 
-(* Equality on Set *)
 let coq_eq_eq = lazy_init_constant ["Logic"] "eq"
-let coq_eq_refl = lazy_init_constant ["Logic"] "refl_equal"
+let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl"
 let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind"
 let coq_eq_rec = lazy_init_constant ["Logic"] "eq_rec"
 let coq_eq_rect = lazy_init_constant ["Logic"] "eq_rect"
 let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal"
-let coq_eq_sym  = lazy_init_constant ["Logic"] "sym_eq"
+let coq_eq_sym  = lazy_init_constant ["Logic"] "eq_sym"
+let coq_eq_trans  = lazy_init_constant ["Logic"] "eq_trans"
 let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2"
+let coq_eq_congr_canonical =
+  lazy_init_constant ["Logic"] "f_equal_canonical_form"
 
 let build_coq_eq_data () =
   let _ = check_required_library logic_module_name in {
   eq = Lazy.force coq_eq_eq;
-  refl = Lazy.force coq_eq_refl;
   ind = Lazy.force coq_eq_ind;
-  rrec = Some (Lazy.force coq_eq_rec);
-  rect = Some (Lazy.force coq_eq_rect);
-  congr = Lazy.force coq_eq_congr;
-  sym = Lazy.force coq_eq_sym }
+  refl = Lazy.force coq_eq_refl;
+  sym = Lazy.force coq_eq_sym;
+  trans = Lazy.force coq_eq_trans;
+  congr = Lazy.force coq_eq_congr }
 
 let build_coq_eq () = Lazy.force coq_eq_eq
-let build_coq_sym_eq () = Lazy.force coq_eq_sym
+let build_coq_eq_refl () = Lazy.force coq_eq_refl
+let build_coq_eq_sym () = Lazy.force coq_eq_sym
 let build_coq_f_equal2 () = Lazy.force coq_f_equal2
 
+let build_coq_sym_eq = build_coq_eq_sym (* compatibility *)
+
+let build_coq_inversion_eq_data () =
+  let _ = check_required_library logic_module_name in {
+  inv_eq = Lazy.force coq_eq_eq;
+  inv_ind = Lazy.force coq_eq_ind;
+  inv_congr = Lazy.force coq_eq_congr_canonical }
+
+(* Heterogenous equality on Type *)
+
+let coq_jmeq_eq = lazy_logic_constant ["JMeq"] "JMeq"
+let coq_jmeq_refl = lazy_logic_constant ["JMeq"] "JMeq_refl"
+let coq_jmeq_ind = lazy_logic_constant ["JMeq"] "JMeq_ind"
+let coq_jmeq_rec = lazy_logic_constant ["JMeq"] "JMeq_rec"
+let coq_jmeq_rect = lazy_logic_constant ["JMeq"] "JMeq_rect"
+let coq_jmeq_sym  = lazy_logic_constant ["JMeq"] "JMeq_sym"
+let coq_jmeq_congr  = lazy_logic_constant ["JMeq"] "JMeq_congr"
+let coq_jmeq_trans  = lazy_logic_constant ["JMeq"] "JMeq_trans"
+let coq_jmeq_congr_canonical =
+  lazy_logic_constant ["JMeq"] "JMeq_congr_canonical_form"
+
+let build_coq_jmeq_data () =
+  let _ = check_required_library jmeq_module_name in {
+  eq = Lazy.force coq_jmeq_eq;
+  ind = Lazy.force coq_jmeq_ind;
+  refl = Lazy.force coq_jmeq_refl;
+  sym = Lazy.force coq_jmeq_sym;
+  trans = Lazy.force coq_jmeq_trans;
+  congr = Lazy.force coq_jmeq_congr }
+
+let join_jmeq_types eq =
+  mkLambda(Name (id_of_string "A"),Termops.new_Type(),
+  mkLambda(Name (id_of_string "x"),mkRel 1,
+  mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|])))
+
+let build_coq_inversion_jmeq_data () =
+  let _ = check_required_library logic_module_name in {
+  inv_eq = join_jmeq_types (Lazy.force coq_jmeq_eq);
+  inv_ind = Lazy.force coq_jmeq_ind;
+  inv_congr = Lazy.force coq_jmeq_congr_canonical }
+
 (* Specif *)
 let coq_sumbool  = lazy_init_constant ["Specif"] "sumbool"
 
@@ -228,17 +305,38 @@ let coq_identity_refl = lazy_init_constant ["Datatypes"] "refl_identity"
 let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind"
 let coq_identity_rec = lazy_init_constant ["Datatypes"] "identity_rec"
 let coq_identity_rect = lazy_init_constant ["Datatypes"] "identity_rect"
-let coq_identity_congr = lazy_init_constant ["Logic_Type"] "congr_id"
-let coq_identity_sym = lazy_init_constant ["Logic_Type"] "sym_id"
+let coq_identity_congr = lazy_init_constant ["Logic_Type"] "identity_congr"
+let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym"
+let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans"
+let coq_identity_congr_canonical = lazy_init_constant ["Logic_Type"] "identity_congr_canonical_form"
 
-let build_coq_identity_data () = {
+let build_coq_identity_data () =
+  let _ = check_required_library datatypes_module_name in {
   eq = Lazy.force coq_identity_eq;
-  refl = Lazy.force coq_identity_refl;
   ind = Lazy.force coq_identity_ind;
-  rrec = Some (Lazy.force coq_identity_rec);
-  rect = Some (Lazy.force coq_identity_rect);
-  congr = Lazy.force coq_identity_congr;
-  sym = Lazy.force coq_identity_sym }
+  refl = Lazy.force coq_identity_refl;
+  sym = Lazy.force coq_identity_sym;
+  trans = Lazy.force coq_identity_trans;
+  congr = Lazy.force coq_identity_congr }
+
+let build_coq_inversion_identity_data () =
+  let _ = check_required_library datatypes_module_name in
+  let _ = check_required_library logic_type_module_name in {
+  inv_eq = Lazy.force coq_identity_eq;
+  inv_ind = Lazy.force coq_identity_ind;
+  inv_congr = Lazy.force coq_identity_congr_canonical }
+
+(* Equality to true *)
+let coq_eq_true_eq = lazy_init_constant ["Datatypes"] "eq_true"
+let coq_eq_true_ind = lazy_init_constant ["Datatypes"] "eq_true_ind"
+let coq_eq_true_congr = lazy_init_constant ["Logic"] "eq_true_congr"
+
+let build_coq_inversion_eq_true_data () =
+  let _ = check_required_library datatypes_module_name in
+  let _ = check_required_library logic_module_name in {
+  inv_eq = Lazy.force coq_eq_true_eq;
+  inv_ind = Lazy.force coq_eq_true_ind;
+  inv_congr = Lazy.force coq_eq_true_congr }
 
 (* The False proposition *)
 let coq_False  = lazy_init_constant ["Logic"] "False"
@@ -253,6 +351,10 @@ let coq_and = lazy_init_constant ["Logic"] "and"
 let coq_conj = lazy_init_constant ["Logic"] "conj"
 let coq_or = lazy_init_constant ["Logic"] "or"
 let coq_ex = lazy_init_constant ["Logic"] "ex"
+let coq_iff = lazy_init_constant ["Logic"] "iff"
+
+let coq_iff_left_proj  = lazy_init_constant ["Logic"] "proj1"
+let coq_iff_right_proj = lazy_init_constant ["Logic"] "proj2"
 
 (* Runtime part *)
 let build_coq_True ()  = Lazy.force coq_True
@@ -262,12 +364,19 @@ let build_coq_False () = Lazy.force coq_False
 let build_coq_not ()   = Lazy.force coq_not
 let build_coq_and ()   = Lazy.force coq_and
 let build_coq_conj ()  = Lazy.force coq_conj
-let build_coq_or ()   = Lazy.force coq_or
-let build_coq_ex ()   = Lazy.force coq_ex
+let build_coq_or ()    = Lazy.force coq_or
+let build_coq_ex ()    = Lazy.force coq_ex
+let build_coq_iff ()   = Lazy.force coq_iff
+
+let build_coq_iff_left_proj ()  = Lazy.force coq_iff_left_proj
+let build_coq_iff_right_proj () = Lazy.force coq_iff_right_proj
+
 
 (* The following is less readable but does not depend on parsing *)
 let coq_eq_ref      = lazy (init_reference ["Logic"] "eq")
-let coq_identity_ref     = lazy (init_reference ["Datatypes"] "identity")
+let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity")
+let coq_jmeq_ref     = lazy (gen_reference "Coqlib" ["Logic";"JMeq"] "JMeq")
+let coq_eq_true_ref = lazy (gen_reference "Coqlib" ["Init";"Datatypes"] "eq_true")
 let coq_existS_ref  = lazy (anomaly "use coq_existT_ref")
 let coq_existT_ref  = lazy (init_reference ["Specif"] "existT")
 let coq_not_ref     = lazy (init_reference ["Logic"] "not")
@@ -275,4 +384,5 @@ let coq_False_ref   = lazy (init_reference ["Logic"] "False")
 let coq_sumbool_ref = lazy (init_reference ["Specif"] "sumbool")
 let coq_sig_ref = lazy (init_reference ["Specif"] "sig")
 let coq_or_ref     = lazy (init_reference ["Logic"] "or")
+let coq_iff_ref    = lazy (init_reference ["Logic"] "iff")
 
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
index a85b6a8e..6bb79c8b 100644
--- a/interp/coqlib.mli
+++ b/interp/coqlib.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqlib.mli 10180 2007-10-05 13:02:23Z vsiles $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -58,8 +58,11 @@ val check_required_library : string list -> unit
 val logic_module : dir_path
 val logic_type_module : dir_path
 
+val datatypes_module_name : string list
+val logic_module_name : string list
+
 (* Natural numbers *)
-val nat_path : section_path
+val nat_path : full_path
 val glob_nat : global_reference
 val path_of_O : constructor
 val path_of_S : constructor
@@ -76,6 +79,8 @@ val glob_false : global_reference
 
 (* Equality *)
 val glob_eq : global_reference
+val glob_identity : global_reference
+val glob_jmeq : global_reference
 
 (*s Constructions and patterns related to Coq initial state are unknown
    at compile time. Therefore, we can only provide methods to build
@@ -104,22 +109,36 @@ val build_sigma_type : coq_sigma_data delayed
 (* Non-dependent pairs in Set from Datatypes *)
 val build_prod : coq_sigma_data delayed
 
-type coq_leibniz_eq_data = {
+type coq_eq_data = {
   eq   : constr;
-  refl : constr;
   ind  : constr;
-  rrec : constr option;
-  rect : constr option;
-  congr: constr;
-  sym  : constr }
+  refl : constr;
+  sym  : constr;
+  trans: constr;
+  congr: constr }
 
-val build_coq_eq_data : coq_leibniz_eq_data delayed
-val build_coq_identity_data : coq_leibniz_eq_data delayed
+val build_coq_eq_data : coq_eq_data delayed
+val build_coq_identity_data : coq_eq_data delayed
+val build_coq_jmeq_data : coq_eq_data delayed
 
 val build_coq_eq       : constr delayed (* = [(build_coq_eq_data()).eq] *)
-val build_coq_sym_eq   : constr delayed (* = [(build_coq_eq_data()).sym] *)
+val build_coq_eq_refl  : constr delayed (* = [(build_coq_eq_data()).refl] *)
+val build_coq_eq_sym   : constr delayed (* = [(build_coq_eq_data()).sym] *)
 val build_coq_f_equal2 : constr delayed
 
+(* Data needed for discriminate and injection *)
+
+type coq_inversion_data = {
+  inv_eq   : constr; (* : forall params, t -> Prop *)
+  inv_ind  : constr; (* : forall params P y, eq params y -> P y *)
+  inv_congr: constr  (* : forall params B (f:t->B) y, eq params y -> f c=f y *)
+}
+
+val build_coq_inversion_eq_data : coq_inversion_data delayed
+val build_coq_inversion_identity_data : coq_inversion_data delayed
+val build_coq_inversion_jmeq_data : coq_inversion_data delayed
+val build_coq_inversion_eq_true_data : coq_inversion_data delayed
+
 (* Specif *)
 val build_coq_sumbool : constr delayed
 
@@ -137,6 +156,10 @@ val build_coq_not : constr delayed
 (* Conjunction *)
 val build_coq_and : constr delayed
 val build_coq_conj : constr delayed
+val build_coq_iff : constr delayed
+
+val build_coq_iff_left_proj : constr delayed
+val build_coq_iff_right_proj : constr delayed
 
 (* Disjunction *)
 val build_coq_or : constr delayed
@@ -146,6 +169,8 @@ val build_coq_ex : constr delayed
 
 val coq_eq_ref : global_reference lazy_t
 val coq_identity_ref : global_reference lazy_t
+val coq_jmeq_ref : global_reference lazy_t
+val coq_eq_true_ref : global_reference lazy_t
 val coq_existS_ref : global_reference lazy_t
 val coq_existT_ref : global_reference lazy_t
 val coq_not_ref : global_reference lazy_t
@@ -154,3 +179,4 @@ val coq_sumbool_ref : global_reference lazy_t
 val coq_sig_ref : global_reference lazy_t
 
 val coq_or_ref : global_reference lazy_t
+val coq_iff_ref : global_reference lazy_t
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml
index 5ac584a7..702c509d 100644
--- a/interp/dumpglob.ml
+++ b/interp/dumpglob.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dumpglob.ml 11582 2008-11-12 19:49:57Z notin $ *)
+(* $Id$ *)
 
 
 (* Dump of globalization (to be used by coqdoc) *)
@@ -15,11 +15,11 @@ let glob_file = ref Pervasives.stdout
 
 let open_glob_file f =
   glob_file := Pervasives.open_out f
-  
+
 let close_glob_file () =
   Pervasives.close_out !glob_file
 
-type glob_output_t = 
+type glob_output_t =
     | NoGlob
     | StdOut
     | MultFiles
@@ -39,7 +39,7 @@ let dump_to_dotglob f = glob_output := MultFiles
 
 let dump_into_file f = glob_output := File f; open_glob_file f
 
-let dump_string s = 
+let dump_string s =
   if dump () then Pervasives.output_string !glob_file s
 
 
@@ -47,28 +47,15 @@ let previous_state = ref MultFiles
 let pause () = previous_state := !glob_output; glob_output := NoGlob
 let continue () = glob_output := !previous_state
 
+type coqdoc_state = Lexer.location_table
 
-let token_number = ref 0
-let last_pos = ref 0
-
-type coqdoc_state = Lexer.location_table * int * int
-
-let coqdoc_freeze () =
-  let lt = Lexer.location_table() in
-  let state = (lt,!token_number,!last_pos) in
-    token_number := 0;
-    last_pos := 0;
-    state
-
-let coqdoc_unfreeze (lt,tn,lp) =
-  Lexer.restore_location_table lt;
-  token_number := tn;
-  last_pos := lp
+let coqdoc_freeze = Lexer.location_table
+let coqdoc_unfreeze = Lexer.restore_location_table
 
 open Decl_kinds
 
 let type_of_logical_kind = function
-  | IsDefinition def -> 
+  | IsDefinition def ->
       (match def with
       | Definition -> "def"
       | Coercion -> "coe"
@@ -102,7 +89,7 @@ let type_of_global_ref gr =
     "class"
   else
     match gr with
-    | Libnames.ConstRef cst -> 
+    | Libnames.ConstRef cst ->
 	type_of_logical_kind (Decls.constant_kind cst)
     | Libnames.VarRef v ->
 	"var" ^ type_of_logical_kind (Decls.variable_kind v)
@@ -118,13 +105,13 @@ let type_of_global_ref gr =
 let remove_sections dir =
   if Libnames.is_dirpath_prefix_of dir (Lib.cwd ()) then
     (* Not yet (fully) discharged *)
-    Libnames.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ())
+    Libnames.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ())
   else
     (* Theorem/Lemma outside its outer section of definition *)
     dir
 
 let dump_ref loc filepath modpath ident ty =
-  dump_string (Printf.sprintf "R%d %s %s %s %s\n" 
+  dump_string (Printf.sprintf "R%d %s %s %s %s\n"
 		  (fst (Util.unloc loc)) filepath modpath ident ty)
 
 let add_glob_gen loc sp lib_dp ty =
@@ -137,41 +124,31 @@ let add_glob_gen loc sp lib_dp ty =
     let ident = Names.string_of_id id in
       dump_ref loc filepath modpath ident ty
 
-let add_glob loc ref = 
+let add_glob loc ref =
   if dump () && loc <> Util.dummy_loc then
-    let sp = Nametab.sp_of_global ref in
+    let sp = Nametab.path_of_global ref in
     let lib_dp = Lib.library_part ref in
     let ty = type_of_global_ref ref in
       add_glob_gen loc sp lib_dp ty
-      
-let mp_of_kn kn = 
-  let mp,sec,l = Names.repr_kn kn in 
-    Names.MPdot (mp,l) 
+
+let mp_of_kn kn =
+  let mp,sec,l = Names.repr_kn kn in
+    Names.MPdot (mp,l)
 
 let add_glob_kn loc kn =
   if dump () && loc <> Util.dummy_loc then
-    let sp = Nametab.sp_of_syntactic_definition kn in
+    let sp = Nametab.path_of_syndef kn in
     let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in
       add_glob_gen loc sp lib_dp "syndef"
 
-let add_local loc id = ()
-(*   let mod_dp,id = repr_path sp in *)
-(*   let mod_dp = remove_sections mod_dp in *)
-(*   let mod_dp_trunc = drop_dirpath_prefix lib_dp mod_dp in *)
-(*   let filepath = string_of_dirpath lib_dp in *)
-(*   let modpath = string_of_dirpath mod_dp_trunc in *)
-(*   let ident = string_of_id id in *)
-(*     dump_string (Printf.sprintf "R%d %s %s %s %s\n"  *)
-(* 		    (fst (unloc loc)) filepath modpath ident ty) *)
-
 let dump_binding loc id = ()
-      
+
 let dump_definition (loc, id) sec s =
-  dump_string (Printf.sprintf "%s %d %s %s\n" s (fst (Util.unloc loc)) 
+  dump_string (Printf.sprintf "%s %d %s %s\n" s (fst (Util.unloc loc))
 			(Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id))
-    
+
 let dump_reference loc modpath ident ty =
-  dump_string (Printf.sprintf "R%d %s %s %s %s\n" 
+  dump_string (Printf.sprintf "R%d %s %s %s %s\n"
 		  (fst (Util.unloc loc)) (Names.string_of_dirpath (Lib.library_dp ())) modpath ident ty)
 
 let dump_constraint ((loc, n), _, _) sec ty =
@@ -187,7 +164,7 @@ let dump_name (loc, n) sec ty =
 let dump_local_binder b sec ty =
   if dump () then
     match b with
-      | Topconstr.LocalRawAssum (nl, _, _) -> 
+      | Topconstr.LocalRawAssum (nl, _, _) ->
 	  List.iter (fun x -> dump_name x sec ty) nl
       | Topconstr.LocalRawDef _ -> ()
 
@@ -197,7 +174,7 @@ let dump_modref loc mp ty =
     let l = if l = [] then l else Util.list_drop_last l in
     let fp = Names.string_of_dirpath dp in
     let mp = Names.string_of_dirpath (Names.make_dirpath l) in
-      dump_string (Printf.sprintf "R%d %s %s %s %s\n" 
+      dump_string (Printf.sprintf "R%d %s %s %s %s\n"
 		      (fst (Util.unloc loc)) fp mp "<>" ty)
 
 let dump_moddef loc mp ty =
@@ -207,22 +184,33 @@ let dump_moddef loc mp ty =
       dump_string (Printf.sprintf "%s %d %s %s\n" ty (fst (Util.unloc loc)) "<>" mp)
 
 let dump_libref loc dp ty =
-  dump_string (Printf.sprintf "R%d %s <> <> %s\n" 
+  dump_string (Printf.sprintf "R%d %s <> <> %s\n"
 		  (fst (Util.unloc loc)) (Names.string_of_dirpath dp) ty)
 
-let dump_notation_location pos ((path,df),sc) =
+let cook_notation df sc =
+  let ntn = String.make (String.length df * 3) '_' in
+  let j = ref 0 in
+  let quoted = ref false in
+  for i = 0 to String.length df - 1 do
+    if df.[i] = '\'' then quoted := not !quoted;
+    if df.[i] = ' ' then (ntn.[!j] <- '_'; incr j) else
+    if df.[i] = '_' && not !quoted then (ntn.[!j] <- 'x'; incr j) else
+    if df.[i] = 'x' && not !quoted then (String.blit "'x'" 0 ntn !j 3; j := !j + 3) else
+    (ntn.[!j] <- df.[i]; incr j)
+  done;
+  let df = String.sub ntn 0 !j in
+  match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df
+
+let dump_notation (loc,(df,_)) sc sec =
+  (* We dump the location of the opening '"' *)
+  dump_string (Printf.sprintf "not %d %s %s\n" (fst (Util.unloc loc))
+    (Names.string_of_dirpath (Lib.current_dirpath sec)) (cook_notation df sc))
+
+let dump_notation_location posl df (((path,secpath),_),sc) =
   if dump () then
-    let rec next growing =
-      let loc = Lexer.location_function !token_number in
-      let (bp,_) = Util.unloc loc in
-	if growing then if bp >= pos then loc else (incr token_number; next true)
-	else if bp = pos then loc
-	else if bp > pos then (decr token_number;next false)
-	else (incr token_number;next true) in
-    let loc = next (pos >= !last_pos) in
-      last_pos := pos;
-      let path = Names.string_of_dirpath path in
-      let _sc = match sc with Some sc -> " "^sc | _ -> "" in
-	dump_string (Printf.sprintf "R%d %s \"%s\" not\n" (fst (Util.unloc loc)) path df)
-
-
+    let path = Names.string_of_dirpath path in
+    let secpath = Names.string_of_dirpath secpath in
+    let df = cook_notation df sc in
+    List.iter (fun (bl,el) ->
+      dump_string(Printf.sprintf "R%d:%d %s %s %s not\n" bl el path secpath df))
+      posl
diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli
index a0666c81..f6d7baef 100644
--- a/interp/dumpglob.mli
+++ b/interp/dumpglob.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dumpglob.mli 11582 2008-11-12 19:49:57Z notin $ *)
+(* $Id$ *)
 
 
 val open_glob_file : string -> unit
@@ -23,8 +23,9 @@ val dump_to_dotglob : unit -> unit
 val pause : unit -> unit
 val continue : unit -> unit
 
-val coqdoc_freeze : unit -> Lexer.location_table * int * int
-val coqdoc_unfreeze : Lexer.location_table * int * int -> unit
+type coqdoc_state = Lexer.location_table
+val coqdoc_freeze : unit -> coqdoc_state
+val coqdoc_unfreeze : coqdoc_state -> unit
 
 val add_glob : Util.loc -> Libnames.global_reference -> unit
 val add_glob_kn : Util.loc -> Names.kernel_name -> unit
@@ -34,8 +35,9 @@ val dump_moddef : Util.loc -> Names.module_path -> string -> unit
 val dump_modref  : Util.loc -> Names.module_path -> string -> unit
 val dump_reference  : Util.loc -> string -> string -> string -> unit
 val dump_libref : Util.loc -> Names.dir_path -> string -> unit
-val dump_notation_location : int -> (Notation.notation_location * Topconstr.scope_name option) -> unit
+val dump_notation_location : (int * int) list -> Topconstr.notation -> (Notation.notation_location * Topconstr.scope_name option) -> unit
 val dump_binding : Util.loc -> Names.Idset.elt -> unit
+val dump_notation : Util.loc * (Topconstr.notation * Notation.notation_location) -> Topconstr.scope_name option -> bool -> unit
 val dump_constraint :  Topconstr.typeclass_constraint -> bool -> string -> unit
 val dump_local_binder : Topconstr.local_binder -> bool -> string -> unit
 
diff --git a/interp/genarg.ml b/interp/genarg.ml
index 1da428be..c9ba20e6 100644
--- a/interp/genarg.ml
+++ b/interp/genarg.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: genarg.ml 11481 2008-10-20 19:23:51Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -47,12 +47,18 @@ type argument_type =
 type 'a and_short_name = 'a * identifier located option
 type 'a or_by_notation =
   | AN of 'a
-  | ByNotation of loc * string * Notation.delimiters option
+  | ByNotation of (loc * string * Notation.delimiters option)
+
+let loc_of_or_by_notation f = function
+  | AN c -> f c
+  | ByNotation (loc,s,_) -> loc
 
 type rawconstr_and_expr = rawconstr * constr_expr option
 type open_constr_expr = unit * constr_expr
 type open_rawconstr = unit * rawconstr_and_expr
 
+type rawconstr_pattern_and_expr = rawconstr_and_expr * Pattern.constr_pattern
+
 type 'a with_ebindings = 'a * open_constr bindings
 
 (* Dynamics but tagged by a type expression *)
@@ -61,9 +67,9 @@ type 'a generic_argument = argument_type * Obj.t
 
 let dyntab = ref ([] : string list)
 
-type rlevel = constr_expr
-type glevel = rawconstr_and_expr
-type tlevel = open_constr
+type rlevel
+type glevel
+type tlevel
 
 type ('a,'b) abstract_argument_type = argument_type
 
@@ -82,6 +88,7 @@ type intro_pattern_expr =
   | IntroRewrite of bool
   | IntroIdentifier of identifier
   | IntroFresh of identifier
+  | IntroForthcoming of bool
   | IntroAnonymous
 and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list
 
@@ -92,11 +99,13 @@ let rec pr_intro_pattern (_,pat) = match pat with
   | IntroRewrite false -> str "<-"
   | IntroIdentifier id -> pr_id id
   | IntroFresh id -> str "?" ++ pr_id id
+  | IntroForthcoming true -> str "*"
+  | IntroForthcoming false -> str "**"
   | IntroAnonymous -> str "?"
 
 and pr_or_and_intro_pattern = function
   | [pl] ->
-      str "(" ++ hv 0 (prlist_with_sep pr_coma pr_intro_pattern pl) ++ str ")"
+      str "(" ++ hv 0 (prlist_with_sep pr_comma pr_intro_pattern pl) ++ str ")"
   | pll ->
       str "[" ++
       hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc pr_intro_pattern) pll)
@@ -163,7 +172,7 @@ let globwit_constr_may_eval = ConstrMayEvalArgType
 let wit_constr_may_eval = ConstrMayEvalArgType
 
 let rawwit_open_constr_gen b = OpenConstrArgType b
-let globwit_open_constr_gen b = OpenConstrArgType b 
+let globwit_open_constr_gen b = OpenConstrArgType b
 let wit_open_constr_gen b = OpenConstrArgType b
 
 let rawwit_open_constr = rawwit_open_constr_gen false
diff --git a/interp/genarg.mli b/interp/genarg.mli
index 86b19de7..fab5ff33 100644
--- a/interp/genarg.mli
+++ b/interp/genarg.mli
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: genarg.mli 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
 open Term
 open Libnames
 open Rawterm
+open Pattern
 open Topconstr
 open Term
 open Evd
@@ -21,7 +22,9 @@ type 'a and_short_name = 'a * identifier located option
 
 type 'a or_by_notation =
   | AN of 'a
-  | ByNotation of loc * string * Notation.delimiters option
+  | ByNotation of (loc * string * Notation.delimiters option)
+
+val loc_of_or_by_notation : ('a -> loc) -> 'a or_by_notation -> loc
 
 (* In globalize tactics, we need to keep the initial [constr_expr] to recompute*)
 (* in the environment by the effective calls to Intro, Inversion, etc *)
@@ -31,6 +34,8 @@ type rawconstr_and_expr = rawconstr * constr_expr option
 type open_constr_expr = unit * constr_expr
 type open_rawconstr = unit * rawconstr_and_expr
 
+type rawconstr_pattern_and_expr = rawconstr_and_expr * constr_pattern
+
 type 'a with_ebindings = 'a * open_constr bindings
 
 type intro_pattern_expr =
@@ -39,6 +44,7 @@ type intro_pattern_expr =
   | IntroRewrite of bool
   | IntroIdentifier of identifier
   | IntroFresh of identifier
+  | IntroForthcoming of bool
   | IntroAnonymous
 and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list
 
@@ -72,7 +78,7 @@ val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds
 effective use
 \end{verbatim}
 
-To distinguish between the uninterpreted (raw), globalized and 
+To distinguish between the uninterpreted (raw), globalized and
 interpreted worlds, we annotate the type [generic_argument] by a
 phantom argument which is either [constr_expr], [rawconstr] or
 [constr].
@@ -104,16 +110,16 @@ ExtraArgType of string         '_a                      '_b
 \end{verbatim}
 *)
 
-(* All of [rlevel], [glevel] and [tlevel] must be non convertible 
+(* 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 
+   out_gen is monomorphic over 'a, hence type-safe
 *)
 
-type rlevel = constr_expr
-type glevel = rawconstr_and_expr
-type tlevel = open_constr
+type rlevel
+type glevel
+type tlevel
 
 type ('a,'co) abstract_argument_type
 
@@ -174,8 +180,8 @@ val rawwit_constr : (constr_expr,rlevel) abstract_argument_type
 val globwit_constr : (rawconstr_and_expr,glevel) abstract_argument_type
 val wit_constr : (constr,tlevel) abstract_argument_type
 
-val rawwit_constr_may_eval : ((constr_expr,reference or_by_notation) may_eval,rlevel) abstract_argument_type
-val globwit_constr_may_eval : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var) may_eval,glevel) abstract_argument_type
+val rawwit_constr_may_eval : ((constr_expr,reference or_by_notation,constr_expr) may_eval,rlevel) abstract_argument_type
+val globwit_constr_may_eval : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var,rawconstr_pattern_and_expr) may_eval,glevel) abstract_argument_type
 val wit_constr_may_eval : (constr,tlevel) abstract_argument_type
 
 val rawwit_open_constr_gen : bool -> (open_constr_expr,rlevel) abstract_argument_type
@@ -192,15 +198,15 @@ val wit_casted_open_constr : (open_constr,tlevel) abstract_argument_type
 
 val rawwit_constr_with_bindings : (constr_expr with_bindings,rlevel) abstract_argument_type
 val globwit_constr_with_bindings : (rawconstr_and_expr with_bindings,glevel) abstract_argument_type
-val wit_constr_with_bindings : (constr with_ebindings,tlevel) abstract_argument_type
+val wit_constr_with_bindings : (constr with_bindings sigma,tlevel) abstract_argument_type
 
 val rawwit_bindings : (constr_expr bindings,rlevel) abstract_argument_type
 val globwit_bindings : (rawconstr_and_expr bindings,glevel) abstract_argument_type
-val wit_bindings : (open_constr bindings,tlevel) abstract_argument_type
+val wit_bindings : (constr bindings sigma,tlevel) abstract_argument_type
 
-val rawwit_red_expr : ((constr_expr,reference or_by_notation) red_expr_gen,rlevel) abstract_argument_type
-val globwit_red_expr : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var) red_expr_gen,glevel) abstract_argument_type
-val wit_red_expr : ((constr,evaluable_global_reference) red_expr_gen,tlevel) abstract_argument_type
+val rawwit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen,rlevel) abstract_argument_type
+val globwit_red_expr : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var,rawconstr_pattern_and_expr) red_expr_gen,glevel) abstract_argument_type
+val wit_red_expr : ((constr,evaluable_global_reference,constr_pattern) red_expr_gen,tlevel) abstract_argument_type
 
 val wit_list0 :
   ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type
@@ -219,29 +225,29 @@ val wit_pair :
 (* ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *)
 type 'a generic_argument
 
-val fold_list0 : 
+val fold_list0 :
  ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c
 
-val fold_list1 : 
+val fold_list1 :
  ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c
 
 val fold_opt :
  ('a generic_argument -> 'c) -> 'c -> 'a generic_argument -> 'c
 
 val fold_pair :
- ('a generic_argument -> 'a generic_argument -> 'c) -> 
+ ('a generic_argument -> 'a generic_argument -> 'c) ->
       'a generic_argument -> 'c
 
 (* [app_list0] fails if applied to an argument not of tag [List0 t]
     for some [t]; it's the responsability of the caller to ensure it *)
 
-val app_list0 : ('a generic_argument -> 'b generic_argument) -> 
+val app_list0 : ('a generic_argument -> 'b generic_argument) ->
 'a generic_argument -> 'b generic_argument
 
-val app_list1 : ('a generic_argument -> 'b generic_argument) -> 
+val app_list1 : ('a generic_argument -> 'b generic_argument) ->
 'a generic_argument -> 'b generic_argument
 
-val app_opt : ('a generic_argument -> 'b generic_argument) -> 
+val app_opt : ('a generic_argument -> 'b generic_argument) ->
 'a generic_argument -> 'b generic_argument
 
 val app_pair :
@@ -291,7 +297,7 @@ val unquote : ('a,'co) abstract_argument_type -> argument_type
 val in_gen :
   ('a,'co) abstract_argument_type -> 'a -> 'co generic_argument
 val out_gen :
-  ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a 
+  ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a
 
 
 (* [in_generic] is used in combination with camlp4 [Gramext.action] magic
@@ -305,5 +311,5 @@ val out_gen :
 *)
 type an_arg_of_this_type
 
-val in_generic : 
+val in_generic :
   argument_type -> an_arg_of_this_type -> 'co generic_argument
diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index d6e207f3..d5894b20 100644
--- a/interp/implicit_quantifiers.ml
+++ b/interp/implicit_quantifiers.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: implicit_quantifiers.ml 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,20 +24,65 @@ open Libnames
 open Typeclasses
 open Typeclasses_errors
 open Pp
+open Libobject
+open Nameops
 (*i*)
 
-let ids_of_list l = 
+let generalizable_table = ref Idpred.empty
+
+let _ =
+  Summary.declare_summary "generalizable-ident"
+    { Summary.freeze_function = (fun () -> !generalizable_table);
+      Summary.unfreeze_function = (fun r -> generalizable_table := r);
+      Summary.init_function = (fun () -> generalizable_table := Idpred.empty) }
+
+let declare_generalizable_ident table (loc,id) =
+  if id <> root_of_id id then
+    user_err_loc(loc,"declare_generalizable_ident",
+    (pr_id id ++ str
+      " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _"));
+  if Idpred.mem id table then
+    user_err_loc(loc,"declare_generalizable_ident",
+		(pr_id id++str" is already declared as a generalizable identifier"))
+  else Idpred.add id table
+
+let add_generalizable gen table =
+  match gen with
+  | None -> Idpred.empty
+  | Some [] -> Idpred.full
+  | Some l -> List.fold_left (fun table lid -> declare_generalizable_ident table lid)
+      table l
+
+let cache_generalizable_type (_,(local,cmd)) =
+  generalizable_table := add_generalizable cmd !generalizable_table
+
+let load_generalizable_type _ (_,(local,cmd)) =
+  generalizable_table := add_generalizable cmd !generalizable_table
+    
+let (in_generalizable, _) =
+  declare_object {(default_object "GENERALIZED-IDENT") with
+    load_function = load_generalizable_type;
+    cache_function = cache_generalizable_type;
+    classify_function = (fun (local, _ as obj) -> if local then Dispose else Keep obj)
+  }
+    
+let declare_generalizable local gen =
+ Lib.add_anonymous_leaf (in_generalizable (local, gen))
+
+let find_generalizable_ident id = Idpred.mem (root_of_id id) !generalizable_table
+
+let ids_of_list l =
   List.fold_right Idset.add l Idset.empty
 
 let locate_reference qid =
-  match Nametab.extended_locate qid with
+  match Nametab.locate_extended qid with
     | TrueGlobal ref -> true
-    | SyntacticDef kn -> true
+    | SynDef kn -> true
 
 let is_global id =
-  try 
-    locate_reference (make_short_qualid id)
-  with Not_found -> 
+  try
+    locate_reference (qualid_of_ident id)
+  with Not_found ->
     false
 
 let is_freevar ids env x =
@@ -48,122 +93,130 @@ let is_freevar ids env x =
       with _ -> not (is_global x)
   with _ -> true
 
-(* Auxilliary functions for the inference of implicitly quantified variables. *)    
+(* Auxilliary functions for the inference of implicitly quantified variables. *)
 
-let free_vars_of_constr_expr c ?(bound=Idset.empty) l = 
-  let found id bdvars l = 
-    if List.mem id l then l 
-    else if not (is_freevar bdvars (Global.env ()) id)
-    then l else id :: l 
+let ungeneralizable loc id =
+  user_err_loc (loc, "Generalization", 
+	       str "Unbound and ungeneralizable variable " ++ pr_id id)
+
+let free_vars_of_constr_expr c ?(bound=Idset.empty) l =
+  let found loc id bdvars l =
+    if List.mem id l then l
+    else if is_freevar bdvars (Global.env ()) id
+    then
+      if find_generalizable_ident id then id :: l
+      else ungeneralizable loc id
+    else l
   in
   let rec aux bdvars l c = match c with
-    | CRef (Ident (_,id)) -> found id bdvars l
+    | CRef (Ident (loc,id)) -> found loc id bdvars l
     | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [])) when not (Idset.mem id bdvars) ->
 	fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c
     | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c
   in aux bound l c
 
-let ids_of_names l = 
+let ids_of_names l =
   List.fold_left (fun acc x -> match snd x with Name na -> na :: acc | Anonymous -> acc) [] l
 
-let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = 
+let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) =
   let rec aux bdvars l c = match c with
       ((LocalRawAssum (n, _, c)) :: tl) ->
 	let bound = ids_of_names n in
 	let l' = free_vars_of_constr_expr c ~bound:bdvars l in
 	  aux (Idset.union (ids_of_list bound) bdvars) l' tl
 
-    | ((LocalRawDef (n, c)) :: tl) -> 
+    | ((LocalRawDef (n, c)) :: tl) ->
 	let bound = match snd n with Anonymous -> [] | Name n -> [n] in
 	let l' = free_vars_of_constr_expr c ~bound:bdvars l in
 	  aux (Idset.union (ids_of_list bound) bdvars) l' tl
-	
+
     | [] -> bdvars, l
   in aux bound l binders
 
-let add_name_to_ids set na = 
-  match na with 
-  | Anonymous -> set 
-  | Name id -> Idset.add id set 
-	
-let free_vars_of_rawconstr ?(bound=Idset.empty) =
+let add_name_to_ids set na =
+  match na with
+  | Anonymous -> set
+  | Name id -> Idset.add id set
+
+let generalizable_vars_of_rawconstr ?(bound=Idset.empty) ?(allowed=Idset.empty) =
   let rec vars bound vs = function
-    | RVar (loc,id) -> 
+    | RVar (loc,id) ->
 	if is_freevar bound (Global.env ()) id then
-	  if List.mem_assoc id vs then vs 
+	  if List.mem_assoc id vs then vs
 	  else (id, loc) :: vs
 	else vs
     | RApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args)
-    | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> 
-	let vs' = vars bound vs ty in 
-	let bound' = add_name_to_ids bound na in 
+    | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) ->
+	let vs' = vars bound vs ty in
+	let bound' = add_name_to_ids bound na in
 	vars bound' vs' c
     | RCases (loc,sty,rtntypopt,tml,pl) ->
-	let vs1 = vars_option bound vs rtntypopt in 
-	let vs2 = List.fold_left (fun vs (tm,_) -> vars bound vs tm) vs1 tml in 
+	let vs1 = vars_option bound vs rtntypopt in
+	let vs2 = List.fold_left (fun vs (tm,_) -> vars bound vs tm) vs1 tml in
 	List.fold_left (vars_pattern bound) vs2 pl
     | RLetTuple (loc,nal,rtntyp,b,c) ->
-	let vs1 = vars_return_type bound vs rtntyp in 
-	let vs2 = vars bound vs1 b in 
+	let vs1 = vars_return_type bound vs rtntyp in
+	let vs2 = vars bound vs1 b in
 	let bound' = List.fold_left add_name_to_ids bound nal in
 	vars bound' vs2 c
-    | RIf (loc,c,rtntyp,b1,b2) -> 
-	let vs1 = vars_return_type bound vs rtntyp in 
-	let vs2 = vars bound vs1 c in 
-	let vs3 = vars bound vs2 b1 in 
+    | RIf (loc,c,rtntyp,b1,b2) ->
+	let vs1 = vars_return_type bound vs rtntyp in
+	let vs2 = vars bound vs1 c in
+	let vs3 = vars bound vs2 b1 in
 	vars bound vs3 b2
     | RRec (loc,fk,idl,bl,tyl,bv) ->
-	let bound' = Array.fold_right Idset.add idl bound in 
-	let vars_fix i vs fid = 
-	  let vs1,bound1 = 
-	    List.fold_left 
-	      (fun (vs,bound) (na,k,bbd,bty) -> 
-		 let vs' = vars_option bound vs bbd in 
+	let bound' = Array.fold_right Idset.add idl bound in
+	let vars_fix i vs fid =
+	  let vs1,bound1 =
+	    List.fold_left
+	      (fun (vs,bound) (na,k,bbd,bty) ->
+		 let vs' = vars_option bound vs bbd in
 		 let vs'' = vars bound vs' bty in
-		 let bound' = add_name_to_ids bound na in 
+		 let bound' = add_name_to_ids bound na in
 		 (vs'',bound')
 	      )
 	      (vs,bound')
 	      bl.(i)
 	  in
-	  let vs2 = vars bound1 vs1 tyl.(i) in 
+	  let vs2 = vars bound1 vs1 tyl.(i) in
 	  vars bound1 vs2 bv.(i)
 	in
 	array_fold_left_i vars_fix vs idl
-    | RCast (loc,c,k) -> let v = vars bound vs c in 
+    | RCast (loc,c,k) -> let v = vars bound vs c in
 	(match k with CastConv (_,t) -> vars bound v t | _ -> v)
     | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs
 
-  and vars_pattern bound vs (loc,idl,p,c) = 
-    let bound' = List.fold_right Idset.add idl bound  in 
+  and vars_pattern bound vs (loc,idl,p,c) =
+    let bound' = List.fold_right Idset.add idl bound  in
     vars bound' vs c
 
   and vars_option bound vs = function None -> vs | Some p -> vars bound vs p
 
-  and vars_return_type bound vs (na,tyopt) = 
-    let bound' = add_name_to_ids bound na in 
+  and vars_return_type bound vs (na,tyopt) =
+    let bound' = add_name_to_ids bound na in
     vars_option bound' vs tyopt
-  in 
-  fun rt -> List.rev (vars bound [] rt)
-      
+  in fun rt -> 
+    let vars = List.rev (vars bound [] rt) in
+      List.iter (fun (id, loc) ->
+	if not (Idset.mem id allowed || find_generalizable_ident id) then 
+	  ungeneralizable loc id) vars;
+      vars
+
 let rec make_fresh ids env x =
-  if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_ident x)
+  if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_subscript x)
 
-let freevars_of_ids env ids = 
-  List.filter (is_freevar env (Global.env())) ids
-      
 let next_ident_away_from id avoid = make_fresh avoid (Global.env ()) id
 
-let next_name_away_from na avoid = 
+let next_name_away_from na avoid =
   match na with
   | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon")
   | Name id -> make_fresh avoid (Global.env ()) id
 
 let combine_params avoid fn applied needed =
-  let named, applied = 
-    List.partition 
+  let named, applied =
+    List.partition
       (function
-	  (t, Some (loc, ExplByName id)) -> 
+	  (t, Some (loc, ExplByName id)) ->
 	    if not (List.exists (fun (_, (id', _, _)) -> Name id = id') needed) then
 	      user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id);
 	    true
@@ -173,49 +226,50 @@ let combine_params avoid fn applied needed =
     (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false)
     named
   in
+  let needed = List.filter (fun (_, (_, b, _)) -> b = None) needed in
   let rec aux ids avoid app need =
     match app, need with
 	[], [] -> List.rev ids, avoid
 
       | app, (_, (Name id, _, _)) :: need when List.mem_assoc id named ->
 	  aux (List.assoc id named :: ids) avoid app need
-	    
+
       | (x, None) :: app, (None, (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
 
       | x :: app, (None, _) :: need -> aux (fst x :: ids) avoid app need
 
-      | [], (None, _ as decl) :: need -> 
+      | [], (None, _ as decl) :: need ->
 	  let t', avoid' = fn avoid decl in
 	    aux (t' :: ids) avoid' app need
 
-      | (x,_) :: _, [] -> 
+      | (x,_) :: _, [] ->
 	  user_err_loc (constr_loc x,"",str "Typeclass does not expect more arguments")
   in aux [] avoid applied needed
 
 let combine_params_freevar =
-  fun avoid (_, (na, _, _)) -> 
+  fun avoid (_, (na, _, _)) ->
     let id' = next_name_away_from na avoid in
       (CRef (Ident (dummy_loc, id')), Idset.add id' avoid)
-	
+
 let destClassApp cl =
   match cl with
-    | CApp (loc, (None,CRef ref), l) -> loc, ref, List.map fst l
+    | CApp (loc, (None, CRef ref), l) -> loc, ref, List.map fst l
     | CAppExpl (loc, (None, ref), l) -> loc, ref, l
     | CRef ref -> loc_of_reference ref, ref, []
     | _ -> raise Not_found
-      
+
 let destClassAppExpl cl =
   match cl with
-    | CApp (loc, (None,CRef ref), l) -> loc, ref, l
+    | CApp (loc, (None, CRef ref), l) -> loc, ref, l
     | CRef ref -> loc_of_reference ref, ref, []
     | _ -> raise Not_found
 
-let implicit_application env ?(allow_partial=true) f ty = 
+let implicit_application env ?(allow_partial=true) f ty =
   let is_class =
     try
       let (loc, r, _ as clapp) = destClassAppExpl ty in
@@ -223,30 +277,30 @@ let implicit_application env ?(allow_partial=true) f ty =
       let gr = Nametab.locate qid in
 	if Typeclasses.is_class gr then Some (clapp, gr) else None
     with Not_found -> None
-  in 
+  in
     match is_class with
-    | None -> ty
-    | Some ((loc, id, par), gr) -> 
+    | None -> ty, env
+    | Some ((loc, id, par), gr) ->
 	let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in
 	let c, avoid =
 	  let c = class_info gr in
 	  let (ci, rd) = c.cl_context in
 	  if not allow_partial then
-	    begin 
+	    begin
 	      let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in
 	      let needlen = List.fold_left (fun acc x -> if x = None then succ acc else acc) 0 ci in
-		if needlen <> applen then 
+		if needlen <> applen then
 		  Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd
 	    end;
 	  let pars = List.rev (List.combine ci rd) in
 	  let args, avoid = combine_params avoid f par pars in
 	    CAppExpl (loc, (None, id), args), avoid
-	in c
-	  
-let implicits_of_rawterm l = 
-  let rec aux i c = 
+	in c, avoid
+
+let implicits_of_rawterm l =
+  let rec aux i c =
     match c with
-	RProd (loc, na, bk, t, b) | RLambda (loc, na, bk, t, b) -> 
+	RProd (loc, na, bk, t, b) | RLambda (loc, na, bk, t, b) ->
 	  let rest = aux (succ i) b in
 	    if bk = Implicit then
 	      let name =
@@ -254,7 +308,7 @@ let implicits_of_rawterm l =
 		    Name id -> Some id
 		  | Anonymous -> None
 	      in
-		(ExplByPos (i, name), (true, true)) :: rest
+		(ExplByPos (i, name), (true, true, true)) :: rest
 	    else rest
       | RLetIn (loc, na, t, b) -> aux i b
       | _ -> []
diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli
index 8dd12f72..1feae81f 100644
--- a/interp/implicit_quantifiers.mli
+++ b/interp/implicit_quantifiers.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: implicit_quantifiers.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,6 +24,8 @@ open Libnames
 open Typeclasses
 (*i*)
 
+val declare_generalizable : Vernacexpr.locality_flag -> (identifier located) list option -> unit
+
 val ids_of_list : identifier list -> Idset.t
 val destClassApp : constr_expr -> loc * reference * constr_expr list
 val destClassAppExpl : constr_expr -> loc * reference * (constr_expr * explicitation located option) list
@@ -36,13 +38,15 @@ val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t ->
 val free_vars_of_binders :
   ?bound:Idset.t -> Names.identifier list -> local_binder list -> Idset.t * Names.identifier list
 
-(* Returns the free ids in left-to-right order with the location of their first occurence *)
+(* Returns the generalizable free ids in left-to-right
+   order with the location of their first occurence *)
 
-val free_vars_of_rawconstr : ?bound:Idset.t -> rawconstr -> (Names.identifier * loc) list
+val generalizable_vars_of_rawconstr : ?bound:Idset.t -> ?allowed:Idset.t ->
+  rawconstr -> (Names.identifier * loc) list
 
 val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier
 
-val implicits_of_rawterm : Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool)) list
+val implicits_of_rawterm : Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool * bool)) list
 
 val combine_params_freevar :
   Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) ->
@@ -51,4 +55,4 @@ val combine_params_freevar :
 val implicit_application : Idset.t -> ?allow_partial:bool ->
   (Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) ->
     Topconstr.constr_expr * Names.Idset.t) ->
-  constr_expr -> constr_expr
+  constr_expr -> constr_expr * Idset.t
diff --git a/interp/interp.mllib b/interp/interp.mllib
new file mode 100644
index 00000000..3825f3d8
--- /dev/null
+++ b/interp/interp.mllib
@@ -0,0 +1,18 @@
+Lexer
+Topconstr
+Ppextend
+Notation
+Dumpglob
+Genarg
+Syntax_def
+Smartlocate
+Reserve
+Impargs
+Implicit_quantifiers
+Constrintern
+Modintern
+Constrextern
+Coqlib
+Discharge
+Declare
+
diff --git a/interp/modintern.ml b/interp/modintern.ml
index d40205ce..049745ca 100644
--- a/interp/modintern.ml
+++ b/interp/modintern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: modintern.ml 11582 2008-11-12 19:49:57Z notin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,7 +15,7 @@ open Entries
 open Libnames
 open Topconstr
 open Constrintern
- 
+
 let rec make_mp mp = function
     [] -> mp
   | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
@@ -25,7 +25,7 @@ let rec make_mp mp = function
 the module prefix *)
 exception BadRef
 
-let lookup_qualid (modtype:bool) qid = 
+let lookup_qualid (modtype:bool) qid =
   let rec make_mp mp = function
       [] -> mp
     | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
@@ -33,13 +33,13 @@ let lookup_qualid (modtype:bool) qid =
   let rec find_module_prefix dir n =
     if n<0 then raise Not_found;
     let dir',dir'' = list_chop n dir in
-    let id',dir''' = 
-      match dir'' with 
-	| hd::tl -> hd,tl 
+    let id',dir''' =
+      match dir'' with
+	| hd::tl -> hd,tl
 	| _ -> anomaly "This list should not be empty!"
     in
     let qid' = make_qualid dir' id' in
-      try 
+      try
 	match Nametab.locate qid' with
 	  | ModRef mp -> mp,dir'''
 	  | _ -> raise BadRef
@@ -47,11 +47,11 @@ let lookup_qualid (modtype:bool) qid =
 	  Not_found -> find_module_prefix dir (pred n)
   in
     try Nametab.locate qid
-    with Not_found -> 
+    with Not_found ->
       let (dir,id) = repr_qualid qid in
       let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in
-      let mp = 
-	List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' 
+      let mp =
+	List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir'
       in
 	if modtype then
 	  ModTypeRef (make_ln mp (label_of_id id))
@@ -61,7 +61,7 @@ let lookup_qualid (modtype:bool) qid =
 *)
 
 
-(* Search for the head of [qid] in [binders]. 
+(* Search for the head of [qid] in [binders].
    If found, returns the module_path/kernel_name created from the dirpath
    and the basename. Searches Nametab otherwise.
 *)
@@ -71,38 +71,64 @@ let lookup_module (loc,qid) =
       Dumpglob.dump_modref loc mp "modtype"; mp
   with
     | Not_found -> Modops.error_not_a_module_loc loc (string_of_qualid qid)
-	
+
 let lookup_modtype (loc,qid) =
   try
     let mp = Nametab.locate_modtype qid in
       Dumpglob.dump_modref loc mp "mod"; mp
   with
-    | Not_found -> 
+    | Not_found ->
 	Modops.error_not_a_modtype_loc loc (string_of_qualid qid)
 
-let transl_with_decl env = function 
+let lookup_module_or_modtype (loc,qid) =
+  try
+    let mp = Nametab.locate_module qid in
+    Dumpglob.dump_modref loc mp "modtype"; (mp,true)
+  with Not_found -> try
+    let mp = Nametab.locate_modtype qid in
+    Dumpglob.dump_modref loc mp "mod"; (mp,false)
+  with Not_found ->
+    Modops.error_not_a_module_or_modtype_loc loc (string_of_qualid qid)
+
+let transl_with_decl env = function
   | CWith_Module ((_,fqid),qid) ->
       With_Module (fqid,lookup_module qid)
   | CWith_Definition ((_,fqid),c) ->
       With_Definition (fqid,interp_constr Evd.empty env c)
 
-let rec interp_modexpr env = function 
-  | CMEident qid ->
+let rec interp_modexpr env = function
+  | CMident qid ->
       MSEident (lookup_module qid)
-  | CMEapply (me1,me2) ->
+  | CMapply (me1,me2) ->
       let me1 = interp_modexpr env me1 in
       let me2 = interp_modexpr env me2 in
 	MSEapply(me1,me2)
+  | CMwith _ -> Modops.error_with_in_module ()
 
-let rec interp_modtype env = function 
-  | CMTEident qid ->
+
+let rec interp_modtype env = function
+  | CMident qid ->
       MSEident (lookup_modtype qid)
-  | CMTEapply (mty1,me) -> 
+  | CMapply (mty1,me) ->
       let mty' = interp_modtype env mty1 in
       let me' = interp_modexpr env me in
 	MSEapply(mty',me')
-  | CMTEwith (mty,decl) ->
+  | CMwith (mty,decl) ->
       let mty = interp_modtype env mty in
       let decl = transl_with_decl env decl in
 	MSEwith(mty,decl)
 
+let rec interp_modexpr_or_modtype env = function
+  | CMident qid ->
+      let (mp,ismod) = lookup_module_or_modtype qid in
+      (MSEident mp, ismod)
+  | CMapply (me1,me2) ->
+      let me1,ismod1 = interp_modexpr_or_modtype env me1 in
+      let me2,ismod2 = interp_modexpr_or_modtype env me2 in
+      if not ismod2 then Modops.error_application_to_module_type ();
+      (MSEapply (me1,me2), ismod1)
+  | CMwith (me,decl) ->
+      let me,ismod = interp_modexpr_or_modtype env me in
+      let decl = transl_with_decl env decl in
+      if ismod then Modops.error_with_in_module ();
+      (MSEwith(me,decl), ismod)
diff --git a/interp/modintern.mli b/interp/modintern.mli
index 36971599..e528b7af 100644
--- a/interp/modintern.mli
+++ b/interp/modintern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modintern.mli 11582 2008-11-12 19:49:57Z notin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Declarations
@@ -18,11 +18,18 @@ open Names
 open Topconstr
 (*i*)
 
-(* Module expressions and module types are interpreted relatively to 
+(* Module expressions and module types are interpreted relatively to
    eventual functor or funsig arguments. *)
 
-val interp_modtype : env -> module_type_ast -> module_struct_entry
+val interp_modtype : env -> module_ast -> module_struct_entry
 
 val interp_modexpr : env -> module_ast -> module_struct_entry
 
+(* The following function tries to interprete an ast as a module,
+   and in case of failure, interpretes this ast as a module type.
+   The boolean is true for a module, false for a module type *)
+
+val interp_modexpr_or_modtype : env -> module_ast ->
+ module_struct_entry * bool
+
 val lookup_module : qualid located -> module_path
diff --git a/interp/notation.ml b/interp/notation.ml
index 776fff79..a72a6b6f 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: notation.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 (*i*)
 open Util
@@ -30,7 +30,7 @@ open Ppextend
     no interpretation for negative numbers in [nat]); interpreters both for
     terms and patterns can be set; these interpreters are in permanent table
     [numeral_interpreter_tab]
-  - a set of ML printers for expressions denoting numbers parsable in 
+  - a set of ML printers for expressions denoting numbers parsable in
     this scope
   - a set of interpretations for infix (more generally distfix) notations
   - an optional pair of delimiters which, when occurring in a syntactic
@@ -42,7 +42,7 @@ open Ppextend
 
 type level = precedence * tolerability list
 type delimiters = string
-type notation_location = dir_path * string
+type notation_location = (dir_path * dir_path) * string
 
 type scope = {
   notations: (string, interpretation * notation_location) Gmap.t;
@@ -92,6 +92,11 @@ let scope_stack = ref []
 
 let current_scopes () = !scope_stack
 
+let scope_is_open_in_scopes sc l =
+  List.mem (Scope sc) l
+
+let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack)
+
 (* TODO: push nat_scope, z_scope, ... in scopes summary *)
 
 (* Exportation of scopes *)
@@ -104,22 +109,22 @@ let open_scope i (_,(local,op,sc)) =
 let cache_scope o =
   open_scope 1 o
 
-let subst_scope (_,subst,sc) = sc
+let subst_scope (subst,sc) = sc
 
 open Libobject
 
-let classify_scope (_,(local,_,_ as o)) =
-  if local then Dispose else Substitute o
+let discharge_scope (local,_,_ as o) =
+  if local then None else Some o
 
-let export_scope (local,_,_ as x) = if local then None else Some x
+let classify_scope (local,_,_ as o) =
+  if local then Dispose else Substitute o
 
-let (inScope,outScope) = 
+let (inScope,outScope) =
   declare_object {(default_object "SCOPE") with
       cache_function = cache_scope;
       open_function = open_scope;
       subst_function = subst_scope;
-      classify_function = classify_scope;
-      export_function = export_scope }
+      classify_function = classify_scope }
 
 let open_close_scope (local,opening,sc) =
   Lib.add_anonymous_leaf (inScope (local,opening,Scope sc))
@@ -142,23 +147,28 @@ let delimiters_map = ref Gmap.empty
 
 let declare_delimiters scope key =
   let sc = find_scope scope in
-  if sc.delimiters <> None && Flags.is_verbose () then begin
-    let old = Option.get sc.delimiters in
-    Flags.if_verbose 
-      warning ("Overwritting previous delimiting key "^old^" in scope "^scope)
-  end;
-  let sc = { sc with delimiters = Some key } in
-  scope_map := Gmap.add scope sc !scope_map;
-  if Gmap.mem key !delimiters_map then begin
-    let oldsc = Gmap.find key !delimiters_map in
-    Flags.if_verbose warning ("Hiding binding of key "^key^" to "^oldsc)
+  let newsc = { sc with delimiters = Some key } in
+  begin match sc.delimiters with
+    | None -> scope_map := Gmap.add scope newsc !scope_map
+    | Some oldkey when oldkey = key -> ()
+    | Some oldkey ->
+	Flags.if_verbose warning
+	  ("overwriting previous delimiting key "^oldkey^" in scope "^scope);
+	scope_map := Gmap.add scope newsc !scope_map
   end;
-  delimiters_map := Gmap.add key scope !delimiters_map
-
-let find_delimiters_scope loc key = 
+  try
+    let oldscope = Gmap.find key !delimiters_map in
+    if oldscope = scope then ()
+    else begin
+      Flags.if_verbose warning ("Hiding binding of key "^key^" to "^oldscope);
+      delimiters_map := Gmap.add key scope !delimiters_map
+    end
+  with Not_found -> delimiters_map := Gmap.add key scope !delimiters_map
+
+let find_delimiters_scope loc key =
   try Gmap.find key !delimiters_map
-  with Not_found -> 
-    user_err_loc 
+  with Not_found ->
+    user_err_loc
     (loc, "find_delimiters", str ("Unknown scope delimiting key "^key^"."))
 
 (* Uninterpretation tables *)
@@ -178,25 +188,35 @@ type key =
 let notations_key_table = ref Gmapl.empty
 let prim_token_key_table = Hashtbl.create 7
 
+
+let make_gr = function
+  | ConstRef con ->
+      ConstRef(constant_of_kn(canonical_con con))
+  | IndRef (kn,i) ->
+      IndRef(mind_of_kn(canonical_mind kn),i)
+  | ConstructRef ((kn,i),j )->
+      ConstructRef((mind_of_kn(canonical_mind kn),i),j)
+  | VarRef id ->  VarRef id
+
 let rawconstr_key = function
-  | RApp (_,RRef (_,ref),_) -> RefKey ref
-  | RRef (_,ref) -> RefKey ref
+  | RApp (_,RRef (_,ref),_) -> RefKey (make_gr ref)
+  | RRef (_,ref) -> RefKey (make_gr ref)
   | _ -> Oth
 
 let cases_pattern_key = function
-  | PatCstr (_,ref,_,_) -> RefKey (ConstructRef ref)
+  | PatCstr (_,ref,_,_) -> RefKey (make_gr (ConstructRef ref))
   | _ -> Oth
 
 let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
-  | AApp (ARef ref,args) -> RefKey ref, Some (List.length args)
-  | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey ref, Some (List.length args)
-  | ARef ref -> RefKey ref, None
+  | AApp (ARef ref,args) -> RefKey(make_gr ref), Some (List.length args)
+  | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey (make_gr ref), Some (List.length args)
+  | ARef ref -> RefKey(make_gr ref), None
   | _ -> Oth, None
 
 (**********************************************************************)
 (* Interpreting numbers (not in summary because functional objects)   *)
 
-type required_module = section_path * string list 
+type required_module = full_path * string list
 
 type 'a prim_token_interpreter =
     loc -> 'a -> rawconstr
@@ -213,7 +233,7 @@ let prim_token_interpreter_tab =
   (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t)
 
 let add_prim_token_interpreter sc interp =
-  try 
+  try
     let cont = Hashtbl.find prim_token_interpreter_tab sc in
     Hashtbl.replace prim_token_interpreter_tab sc (interp cont)
   with Not_found ->
@@ -223,7 +243,7 @@ let add_prim_token_interpreter sc interp =
 let declare_prim_token_interpreter sc interp (patl,uninterp,b) =
   declare_scope sc;
   add_prim_token_interpreter sc interp;
-  List.iter (fun pat -> 
+  List.iter (fun pat ->
       Hashtbl.add prim_token_key_table (rawconstr_key pat) (sc,uninterp,b))
     patl
 
@@ -243,7 +263,7 @@ let declare_string_interpreter sc dir interp (patl,uninterp,inpat) =
     (patl, (fun r -> Option.map mkString (uninterp r)), inpat)
 
 let check_required_module loc sc (sp,d) =
-  try let _ = Nametab.absolute_reference sp in ()
+  try let _ = Nametab.global_of_path sp in ()
   with Not_found ->
     user_err_loc (loc,"prim_token_interpreter",
     str ("Cannot interpret in "^sc^" without requiring first module "
@@ -260,7 +280,7 @@ let find_with_delimiters = function
 	| None -> None
 
 let rec find_without_delimiters find (ntn_scope,ntn) = function
-  | Scope scope :: scopes -> 
+  | Scope scope :: scopes ->
       (* Is the expected ntn/numpr attached to the most recently open scope? *)
       if Some scope = ntn_scope then
 	Some (None,None)
@@ -272,7 +292,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function
 	else
 	  find_without_delimiters find (ntn_scope,ntn) scopes
   | SingleNotation ntn' :: scopes ->
-      if ntn_scope = None & ntn = Some ntn' then 
+      if ntn_scope = None & ntn = Some ntn' then
 	Some (None,None)
       else
 	find_without_delimiters find (ntn_scope,ntn) scopes
@@ -335,7 +355,7 @@ let find_prim_token g loc p sc =
   (* Try for a primitive numerical notation *)
   let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in
   check_required_module loc sc spdir;
-  g (interp ()), (dirpath (fst spdir),"")
+  g (interp ()), ((dirpath (fst spdir),empty_dirpath),"")
 
 let interp_prim_token_gen g loc p local_scopes =
   let scopes = make_current_scopes local_scopes in
@@ -371,7 +391,7 @@ let availability_of_notation (ntn_scope,ntn) scopes =
   find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes)
 
 let uninterp_prim_token c =
-  try 
+  try
     let (sc,numpr,_) = Hashtbl.find prim_token_key_table (rawconstr_key c) in
     match numpr c with
       | None -> raise No_match
@@ -379,7 +399,7 @@ let uninterp_prim_token c =
   with Not_found -> raise No_match
 
 let uninterp_prim_token_cases_pattern c =
-  try 
+  try
     let k = cases_pattern_key c in
     let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in
     if not b then raise No_match;
@@ -389,8 +409,10 @@ let uninterp_prim_token_cases_pattern c =
       | Some n -> (na,sc,n)
   with Not_found -> raise No_match
 
-let availability_of_prim_token printer_scope local_scopes =
-  let f scope = Hashtbl.mem prim_token_interpreter_tab scope in
+let availability_of_prim_token n printer_scope local_scopes =
+  let f scope =
+    try ignore (Hashtbl.find prim_token_interpreter_tab scope dummy_loc n); true
+    with Not_found -> false in
   let scopes = make_current_scopes local_scopes in
   Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes)
 
@@ -456,13 +478,16 @@ let load_arguments_scope _ (_,(_,r,scl)) =
 let cache_arguments_scope o =
   load_arguments_scope 1 o
 
-let subst_arguments_scope (_,subst,(req,r,scl)) =
+let subst_arguments_scope (subst,(req,r,scl)) =
   (ArgsScopeNoDischarge,fst (subst_global subst r),scl)
 
 let discharge_arguments_scope (_,(req,r,l)) =
   if req = ArgsScopeNoDischarge or (isVarRef r & Lib.is_in_section r) then None
   else Some (req,Lib.discharge_global r,l)
 
+let classify_arguments_scope (req,_,_ as obj) =
+  if req = ArgsScopeNoDischarge then Dispose else Substitute obj
+
 let rebuild_arguments_scope (req,r,l) =
   match req with
     | ArgsScopeNoDischarge -> assert false
@@ -475,21 +500,23 @@ let rebuild_arguments_scope (req,r,l) =
 	let l1,_ = list_chop (List.length l' - List.length l) l' in
 	(req,r,l1@l)
 
-let (inArgumentsScope,outArgumentsScope) = 
+let (inArgumentsScope,outArgumentsScope) =
   declare_object {(default_object "ARGUMENTS-SCOPE") with
       cache_function = cache_arguments_scope;
       load_function = load_arguments_scope;
       subst_function = subst_arguments_scope;
-      classify_function = (fun (_,o) -> Substitute o);
+      classify_function = classify_arguments_scope;
       discharge_function = discharge_arguments_scope;
-      rebuild_function = rebuild_arguments_scope;
-      export_function = (fun x -> Some x) }
+      rebuild_function = rebuild_arguments_scope }
+
+let is_local local ref = local || isVarRef ref && Lib.is_in_section ref
 
 let declare_arguments_scope_gen req r scl =
   Lib.add_anonymous_leaf (inArgumentsScope (req,r,scl))
 
 let declare_arguments_scope local ref scl =
-  let req = if local then ArgsScopeNoDischarge else ArgsScopeManual in
+  let req =
+    if is_local local ref then ArgsScopeNoDischarge else ArgsScopeManual in
   declare_arguments_scope_gen req ref scl
 
 let find_arguments_scope r =
@@ -511,8 +538,9 @@ type symbol =
 
 let rec string_of_symbol = function
   | NonTerminal _ -> ["_"]
+  | Terminal "_" -> ["'_'"]
   | Terminal s -> [s]
-  | SProdList (_,l) -> 
+  | SProdList (_,l) ->
      let l = List.flatten (List.map string_of_symbol l) in "_"::l@".."::l@["_"]
   | Break _ -> []
 
@@ -525,14 +553,14 @@ let decompose_notation_key s =
     if n>=len then List.rev dirs else
     let pos =
       try
-	String.index_from s n ' ' 
+	String.index_from s n ' '
       with Not_found -> len
     in
     let tok =
       match String.sub s n (pos-n) with
       | "_" -> NonTerminal (id_of_string "_")
-      | s -> Terminal s in
-    decomp_ntn (tok::dirs) (pos+1)	  
+      | s -> Terminal (drop_simple_quotes s) in
+    decomp_ntn (tok::dirs) (pos+1)
   in
     decomp_ntn [] 0
 
@@ -549,12 +577,12 @@ let classes_of_scope sc =
 let pr_scope_classes sc =
   let l = classes_of_scope sc in
   if l = [] then mt()
-  else 
+  else
     hov 0 (str ("Bound to class"^(if List.tl l=[] then "" else "es")) ++
       spc() ++ prlist_with_sep spc pr_class l) ++ fnl()
 
 let pr_notation_info prraw ntn c =
-  str "\"" ++ str ntn ++ str "\" := " ++ 
+  str "\"" ++ str ntn ++ str "\" := " ++
   prraw (rawconstr_of_aconstr dummy_loc c)
 
 let pr_named_scope prraw scope sc =
@@ -562,7 +590,7 @@ let pr_named_scope prraw scope sc =
    match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with
      | 0 -> str "No lonely notation"
      | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s")
-  else 
+  else
     str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters)
   ++ fnl ()
   ++ pr_scope_classes scope
@@ -574,7 +602,7 @@ let pr_named_scope prraw scope sc =
 let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope)
 
 let pr_scopes prraw =
- Gmap.fold 
+ Gmap.fold
    (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm)
    !scope_map (mt ())
 
@@ -606,7 +634,7 @@ let browse_notation strict ntn map =
       let trms = List.filter (function Terminal _ -> true | _ -> false) toks in
       if strict then [Terminal ntn] = trms else List.mem (Terminal ntn) trms in
   let l =
-    Gmap.fold 
+    Gmap.fold
       (fun scope_name sc ->
 	Gmap.fold (fun ntn ((_,r),df) l ->
 	  if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations)
@@ -616,7 +644,7 @@ let browse_notation strict ntn map =
 let global_reference_of_notation test (ntn,(sc,c,_)) =
   match c with
   | ARef ref when test ref -> Some (ntn,sc,ref)
-  | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref -> 
+  | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref ->
       Some (ntn,sc,ref)
   | _ -> None
 
@@ -638,27 +666,28 @@ let interp_notation_as_global_reference loc test ntn sc =
   match Option.List.flatten refs with
   | [_,_,ref] -> ref
   | [] -> error_notation_not_reference loc ntn
-  | refs -> 
+  | refs ->
       let f (ntn,sc,ref) = find_default ntn !scope_stack = Some sc in
       match List.filter f refs with
       | [_,_,ref] -> ref
       | [] -> error_notation_not_reference loc ntn
       | _ -> error_ambiguous_notation loc ntn
 
-let locate_notation prraw ntn =
+let locate_notation prraw ntn scope =
   let ntns = factorize_entries (browse_notation false ntn !scope_map) in
+  let scopes = Option.fold_right push_scope scope !scope_stack in
   if ntns = [] then
     str "Unknown notation"
   else
     t (str "Notation            " ++
-    tab () ++ str "Scope     " ++ tab () ++ fnl () ++ 
+    tab () ++ str "Scope     " ++ tab () ++ fnl () ++
     prlist (fun (ntn,l) ->
-      let scope = find_default ntn !scope_stack in
-      prlist 
+      let scope = find_default ntn scopes in
+      prlist
 	(fun (sc,r,(_,df)) ->
 	  hov 0 (
 	    pr_notation_info prraw df r ++ tbrk (1,2) ++
-	    (if sc = default_scope then mt () else (str ": " ++ str sc)) ++ 
+	    (if sc = default_scope then mt () else (str ": " ++ str sc)) ++
 	    tbrk (1,2) ++
 	    (if Some sc = scope then str "(default interpretation)" else mt ())
 	    ++ fnl ()))
@@ -688,7 +717,7 @@ let collect_notations stack =
 	    let all' = match all with
 	      | (s,lonelyntn)::rest when s = default_scope ->
 		  (s,(df,r)::lonelyntn)::rest
-	      | _ -> 
+	      | _ ->
 		  (default_scope,[df,r])::all in
 	    (all',ntn::knownntn))
     ([],[]) stack)
@@ -700,11 +729,11 @@ let pr_visible_in_scope prraw (scope,ntns) =
       ntns (mt ()) in
   (if scope = default_scope then
      str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt())
-   else 
+   else
      str "Visible in scope " ++ str scope)
   ++ fnl () ++ strm
 
-let pr_scope_stack prraw stack = 
+let pr_scope_stack prraw stack =
   List.fold_left
     (fun strm scntns -> strm ++ pr_visible_in_scope prraw scntns ++ fnl ())
     (mt ()) (collect_notations stack)
@@ -719,7 +748,7 @@ let pr_visibility prraw = function
 type unparsing_rule = unparsing list * precedence
 
 (* Concrete syntax for symbolic-extension table *)
-let printing_rules = 
+let printing_rules =
   ref (Gmap.empty : (string,unparsing_rule) Gmap.t)
 
 let declare_notation_printing_rule ntn unpl =
@@ -759,10 +788,8 @@ let init () =
   printing_rules := Gmap.empty;
   class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
 
-let _ = 
+let _ =
   declare_summary "symbols"
     { freeze_function = freeze;
       unfreeze_function = unfreeze;
-      init_function = init;
-      survive_module = false;
-      survive_section = false }
+      init_function = init }
diff --git a/interp/notation.mli b/interp/notation.mli
index 4d7289c2..f52e17cc 100644
--- a/interp/notation.mli
+++ b/interp/notation.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: notation.mli 11445 2008-10-11 16:42:46Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -39,9 +39,14 @@ val declare_scope : scope_name -> unit
 
 val current_scopes : unit -> scopes
 
+(* Check where a scope is opened or not in a scope list, or in
+ * the current opened scopes *)
+val scope_is_open_in_scopes : scope_name -> scopes -> bool
+val scope_is_open : scope_name -> bool
+
 (* Open scope *)
 
-val open_close_scope : 
+val open_close_scope :
   (* locality *) bool * (* open *) bool * scope_name -> unit
 
 (* Extend a list of scopes *)
@@ -60,8 +65,8 @@ val find_delimiters_scope : loc -> delimiters -> scope_name
    negative numbers are not supported, the interpreter must fail with
    an appropriate error message *)
 
-type notation_location = dir_path * string
-type required_module = section_path * string list 
+type notation_location = (dir_path * dir_path) * string
+type required_module = full_path * string list
 type cases_pattern_status = bool (* true = use prim token in patterns *)
 
 type 'a prim_token_interpreter =
@@ -81,19 +86,19 @@ val declare_string_interpreter : scope_name -> required_module ->
 
 val interp_prim_token : loc -> prim_token -> local_scopes ->
   rawconstr * (notation_location * scope_name option)
-val interp_prim_token_cases_pattern : loc -> prim_token -> name -> 
+val interp_prim_token_cases_pattern : loc -> prim_token -> name ->
   local_scopes -> cases_pattern * (notation_location * scope_name option)
 
 (* Return the primitive token associated to a [term]/[cases_pattern];
    raise [No_match] if no such token *)
 
-val uninterp_prim_token : 
+val uninterp_prim_token :
   rawconstr -> scope_name * prim_token
-val uninterp_prim_token_cases_pattern : 
+val uninterp_prim_token_cases_pattern :
   cases_pattern -> name * scope_name * prim_token
 
-val availability_of_prim_token : 
-  scope_name -> local_scopes -> delimiters option option
+val availability_of_prim_token :
+  prim_token -> scope_name -> local_scopes -> delimiters option option
 
 (*s Declare and interpret back and forth a notation *)
 
@@ -120,7 +125,7 @@ val uninterp_cases_pattern_notations : cases_pattern ->
 (* Test if a notation is available in the scopes *)
 (* context [scopes]; if available, the result is not None; the first *)
 (* argument is itself not None if a delimiters is needed *)
-val availability_of_notation : scope_name option * notation -> local_scopes -> 
+val availability_of_notation : scope_name option * notation -> local_scopes ->
   (scope_name option * delimiters option) option
 
 (*s Declare and test the level of a (possibly uninterpreted) notation *)
@@ -130,7 +135,7 @@ val level_of_notation : notation -> level (* raise [Not_found] if no level *)
 
 (*s** Miscellaneous *)
 
-val interp_notation_as_global_reference : loc -> (global_reference -> bool) -> 
+val interp_notation_as_global_reference : loc -> (global_reference -> bool) ->
       notation -> delimiters option -> global_reference
 
 (* Checks for already existing notations *)
@@ -138,7 +143,7 @@ val exists_notation_in_scope : scope_name option -> notation ->
       interpretation -> bool
 
 (* Declares and looks for scopes associated to arguments of a global ref *)
-val declare_arguments_scope : 
+val declare_arguments_scope :
   bool (* true=local *) -> global_reference -> scope_name option list -> unit
 
 val find_arguments_scope : global_reference -> scope_name option list
@@ -159,10 +164,11 @@ type symbol =
 val make_notation_key : symbol list -> notation
 val decompose_notation_key : notation -> symbol list
 
-(* Prints scopes (expect a pure aconstr printer *)
+(* Prints scopes (expects a pure aconstr printer) *)
 val pr_scope : (rawconstr -> std_ppcmds) -> scope_name -> std_ppcmds
 val pr_scopes : (rawconstr -> std_ppcmds) -> std_ppcmds
-val locate_notation : (rawconstr -> std_ppcmds) -> notation -> std_ppcmds
+val locate_notation : (rawconstr -> std_ppcmds) -> notation ->
+      scope_name option -> std_ppcmds
 
 val pr_visibility: (rawconstr -> std_ppcmds) -> scope_name option -> std_ppcmds
 
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index 34e93624..a4142d69 100644
--- a/interp/ppextend.ml
+++ b/interp/ppextend.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppextend.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(*i $Id$ *)
 
 (*i*)
 open Pp
@@ -50,7 +50,7 @@ let ppcmd_of_cut = function
   | PpBrk(n1,n2) -> brk(n1,n2)
   | PpTbrk(n1,n2) -> tbrk(n1,n2)
 
-type unparsing = 
+type unparsing =
   | UnpMetaVar of int * parenRelation
   | UnpListMetaVar of int * parenRelation * unparsing list
   | UnpTerminal of string
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
index 3d49c210..3d09587d 100644
--- a/interp/ppextend.mli
+++ b/interp/ppextend.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppextend.mli 6616 2005-01-21 17:18:23Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -40,7 +40,7 @@ val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds
 
 val ppcmd_of_cut : ppcut -> std_ppcmds
 
-type unparsing = 
+type unparsing =
   | UnpMetaVar of int * parenRelation
   | UnpListMetaVar of int * parenRelation * unparsing list
   | UnpTerminal of string
diff --git a/interp/reserve.ml b/interp/reserve.ml
index f7496832..9d841282 100644
--- a/interp/reserve.ml
+++ b/interp/reserve.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reserve.ml 10727 2008-03-28 20:22:43Z msozeau $ i*)
+(*i $Id$ i*)
 
 (* Reserved names *)
 
@@ -24,24 +24,22 @@ let cache_reserved_type (_,(id,t)) =
   reserve_table := Idmap.add id t !reserve_table
 
 let (in_reserved, _) =
-  declare_object {(default_object "RESERVED-TYPE") with 
+  declare_object {(default_object "RESERVED-TYPE") with
     cache_function = cache_reserved_type }
 
-let _ = 
+let _ =
   Summary.declare_summary "reserved-type"
     { Summary.freeze_function = (fun () -> !reserve_table);
       Summary.unfreeze_function = (fun r -> reserve_table := r);
-      Summary.init_function = (fun () -> reserve_table := Idmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = (fun () -> reserve_table := Idmap.empty) }
 
-let declare_reserved_type (loc,id) t = 
+let declare_reserved_type (loc,id) t =
   if id <> root_of_id id then
     user_err_loc(loc,"declare_reserved_type",
     (pr_id id ++ str
       " is not reservable: it must have no trailing digits, quote, or _"));
   begin try
-    let _ = Idmap.find id !reserve_table in 
+    let _ = Idmap.find id !reserve_table in
     user_err_loc(loc,"declare_reserved_type",
     (pr_id id++str" is already bound to a type"))
   with Not_found -> () end;
@@ -68,7 +66,7 @@ let rec unloc = function
       RIf (dummy_loc,unloc c,(na,Option.map unloc po),unloc b1,unloc b2)
   | RRec (_,fk,idl,bl,tyl,bv) ->
       RRec (dummy_loc,fk,idl,
-            Array.map (List.map 
+            Array.map (List.map
               (fun (na,k,obd,ty) -> (na,k,Option.map unloc obd, unloc ty)))
               bl,
             Array.map unloc tyl,
@@ -84,7 +82,7 @@ let rec unloc = function
 
 let anonymize_if_reserved na t = match na with
   | Name id as na ->
-      (try 
+      (try
 	if not !Flags.raw_print & unloc t = find_reserved_type id
 	then RHole (dummy_loc,Evd.BinderType na)
 	else t
diff --git a/interp/reserve.mli b/interp/reserve.mli
index 13349ee9..a83e66c4 100644
--- a/interp/reserve.mli
+++ b/interp/reserve.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reserve.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml
new file mode 100644
index 00000000..faad3c50
--- /dev/null
+++ b/interp/smartlocate.ml
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created by Hugo Herbelin from code formerly dispatched in
+   syntax_def.ml or tacinterp.ml, Sep 2009 *)
+
+(* This file provides high-level name globalization functions *)
+
+(* $Id:$ *)
+
+(* *)
+open Pp
+open Util
+open Names
+open Libnames
+open Genarg
+open Syntax_def
+open Topconstr
+
+let global_of_extended_global = function
+  | TrueGlobal ref -> ref
+  | SynDef kn ->
+  match search_syntactic_definition kn with
+  | [],ARef ref -> ref
+  | _ -> raise Not_found
+
+let locate_global_with_alias (loc,qid) =
+  let ref = Nametab.locate_extended qid in
+  try global_of_extended_global ref
+  with Not_found ->
+    user_err_loc (loc,"",pr_qualid qid ++
+      str " is bound to a notation that does not denote a reference.")
+
+let global_inductive_with_alias r =
+  let (loc,qid as lqid) = qualid_of_reference r in
+  try match locate_global_with_alias lqid with
+  | IndRef ind -> ind
+  | ref ->
+      user_err_loc (loc_of_reference r,"global_inductive",
+        pr_reference r ++ spc () ++ str "is not an inductive type.")
+  with Not_found -> Nametab.error_global_not_found_loc loc qid
+
+let global_with_alias r =
+  let (loc,qid as lqid) = qualid_of_reference r in
+  try locate_global_with_alias lqid
+  with Not_found -> Nametab.error_global_not_found_loc loc qid
+
+let smart_global = function
+  | AN r ->
+      global_with_alias r
+  | ByNotation (loc,ntn,sc) ->
+      Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc
+
+let smart_global_inductive = function
+  | AN r ->
+      global_inductive_with_alias r
+  | ByNotation (loc,ntn,sc) ->
+      destIndRef
+        (Notation.interp_notation_as_global_reference loc isIndRef ntn sc)
diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli
new file mode 100644
index 00000000..682484f5
--- /dev/null
+++ b/interp/smartlocate.mli
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+open Util
+open Names
+open Libnames
+open Genarg
+
+(* [locate_global_with_alias] locates global reference possibly following
+   a notation if this notation has a role of aliasing; raise Not_found
+   if not bound in the global env; raise an error if bound to a
+   syntactic def that does not denote a reference *)
+
+val locate_global_with_alias : qualid located -> global_reference
+
+(* Extract a global_reference from a reference that can be an "alias" *)
+val global_of_extended_global : extended_global_reference -> global_reference
+
+(* Locate a reference taking into account possible "alias" notations *)
+val global_with_alias : reference -> global_reference
+
+(* The same for inductive types *)
+val global_inductive_with_alias : reference -> inductive
+
+(* Locate a reference taking into account notations and "aliases" *)
+val smart_global : reference or_by_notation -> global_reference
+
+(* The same for inductive types *)
+val smart_global_inductive : reference or_by_notation -> inductive
+
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index fe998cba..245ed0f5 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: syntax_def.ml 11512 2008-10-27 12:28:36Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -16,6 +16,7 @@ open Topconstr
 open Libobject
 open Lib
 open Nameops
+open Nametab
 
 (* Syntactic definitions. *)
 
@@ -25,9 +26,7 @@ let _ = Summary.declare_summary
 	  "SYNTAXCONSTANT"
 	  { Summary.freeze_function = (fun () -> !syntax_table);
 	    Summary.unfreeze_function = (fun ft -> syntax_table := ft);
-	    Summary.init_function = (fun () -> syntax_table := KNmap.empty);
-	    Summary.survive_module = false;
-	    Summary.survive_section = false }
+	    Summary.init_function = (fun () -> syntax_table := KNmap.empty) }
 
 let add_syntax_constant kn c =
   syntax_table := KNmap.add kn c !syntax_table
@@ -37,38 +36,41 @@ let load_syntax_constant i ((sp,kn),(local,pat,onlyparse)) =
     errorlabstrm "cache_syntax_constant"
       (pr_id (basename sp) ++ str " already exists");
   add_syntax_constant kn pat;
-  Nametab.push_syntactic_definition (Nametab.Until i) sp kn;
-  if not onlyparse then
-    (* Declare it to be used as long name *)
-    Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
+  Nametab.push_syndef (Nametab.Until i) sp kn
+
+let is_alias_of_already_visible_name sp = function
+  | _,ARef ref ->
+      let (dir,id) = repr_qualid (shortest_qualid_of_global Idset.empty ref) in
+      dir = empty_dirpath && id = basename sp
+  | _ ->
+      false
 
 let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
-  Nametab.push_syntactic_definition (Nametab.Exactly i) sp kn;
-  if not onlyparse then
-    (* Redeclare it to be used as (short) name in case an other (distfix)
-       notation was declared inbetween *)
-    Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
+  if not (is_alias_of_already_visible_name sp pat) then begin
+    Nametab.push_syndef (Nametab.Exactly i) sp kn;
+    if not onlyparse then
+      (* Redeclare it to be used as (short) name in case an other (distfix)
+	 notation was declared inbetween *)
+      Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
+  end
 
 let cache_syntax_constant d =
-  load_syntax_constant 1 d
+  load_syntax_constant 1 d;
+  open_syntax_constant 1 d
 
-let subst_syntax_constant ((sp,kn),subst,(local,pat,onlyparse)) =
+let subst_syntax_constant (subst,(local,pat,onlyparse)) =
   (local,subst_interpretation subst pat,onlyparse)
 
-let classify_syntax_constant (_,(local,_,_ as o)) =
+let classify_syntax_constant (local,_,_ as o) =
   if local then Dispose else Substitute o
 
-let export_syntax_constant (local,_,_ as o) =
-  if local then None else Some o
-
 let (in_syntax_constant, out_syntax_constant) =
   declare_object {(default_object "SYNTAXCONSTANT") with
     cache_function = cache_syntax_constant;
     load_function = load_syntax_constant;
     open_function = open_syntax_constant;
     subst_function = subst_syntax_constant;
-    classify_function = classify_syntax_constant;
-    export_function = export_syntax_constant } 
+    classify_function = classify_syntax_constant }
 
 type syndef_interpretation = (identifier * subscopes) list * aconstr
 
@@ -80,27 +82,5 @@ let out_pat ((ids,idsl),ac) = assert (idsl=[]); (ids,ac)
 let declare_syntactic_definition local id onlyparse pat =
   let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in ()
 
-let search_syntactic_definition loc kn =
+let search_syntactic_definition kn =
   out_pat (KNmap.find kn !syntax_table)
-
-let locate_global_with_alias (loc,qid) =
-  match Nametab.extended_locate qid with
-  | TrueGlobal ref -> ref
-  | SyntacticDef kn -> 
-  match search_syntactic_definition dummy_loc kn with
-  | [],ARef ref -> ref
-  | _ -> 
-      user_err_loc (loc,"",pr_qualid qid ++ 
-        str " is bound to a notation that does not denote a reference")
-
-let inductive_of_reference_with_alias r =
-  match locate_global_with_alias (qualid_of_reference r) with
-  | IndRef ind -> ind
-  | ref ->
-      user_err_loc (loc_of_reference r,"global_inductive",
-        pr_reference r ++ spc () ++ str "is not an inductive type")
-
-let global_with_alias r =
-  let (loc,qid as lqid) = qualid_of_reference r in
-  try locate_global_with_alias lqid
-  with Not_found -> Nametab.error_global_not_found_loc loc qid
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index 0f5e0be7..b4da6dd7 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: syntax_def.mli 11512 2008-10-27 12:28:36Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
 open Names
 open Topconstr
 open Rawterm
+open Nametab
 open Libnames
 (*i*)
 
@@ -20,21 +21,7 @@ open Libnames
 
 type syndef_interpretation = (identifier * subscopes) list * aconstr
 
-val declare_syntactic_definition : bool -> identifier -> bool -> 
+val declare_syntactic_definition : bool -> identifier -> bool ->
   syndef_interpretation -> unit
 
-val search_syntactic_definition : loc -> kernel_name -> syndef_interpretation
-
-(* [locate_global_with_alias] locates global reference possibly following
-   a notation if this notation has a role of aliasing; raise Not_found
-   if not bound in the global env; raise an error if bound to a
-   syntactic def that does not denote a reference *)
-
-val locate_global_with_alias : qualid located -> global_reference
-
-(* Locate a reference taking into account possible "alias" notations *)
-val global_with_alias : reference -> global_reference
-
-(* The same for inductive types *)
-val inductive_of_reference_with_alias : reference -> inductive
-
+val search_syntactic_definition : kernel_name -> syndef_interpretation
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index 89ddd001..d7528fad 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: topconstr.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 (*i*)
 open Pp
@@ -23,7 +23,7 @@ open Mod_subst
 (* This is the subtype of rawconstr allowed in syntactic extensions *)
 
 (* For AList: first constr is iterator, second is terminator;
-   first id is where each argument of the list has to be substituted 
+   first id is where each argument of the list has to be substituted
    in iterator and snd id is alternative name just for printing;
    boolean is associativity *)
 
@@ -43,7 +43,7 @@ type aconstr =
   | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
   | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
   | ARec of fix_kind * identifier array *
-      (name * aconstr option * aconstr) list array * aconstr array * 
+      (name * aconstr option * aconstr) list array * aconstr array *
       aconstr array
   | ASort of rawsort
   | AHole of Evd.hole_kind
@@ -53,11 +53,17 @@ type aconstr =
 (**********************************************************************)
 (* Re-interpret a notation as a rawconstr, taking care of binders     *)
 
+let name_to_ident = function
+  | Anonymous -> error "This expression should be a simple identifier."
+  | Name id -> id
+
+let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na
+
 let rec cases_pattern_fold_map loc g e = function
   | PatVar (_,na) ->
-      let e',na' = name_fold_map g e na in e', PatVar (loc,na')
+      let e',na' = g e na in e', PatVar (loc,na')
   | PatCstr (_,cstr,patl,na) ->
-      let e',na' = name_fold_map g e na in
+      let e',na' = g e na in
       let e',patl' = list_fold_map (cases_pattern_fold_map loc g) e patl in
       e', PatCstr (loc,cstr,patl',na')
 
@@ -77,42 +83,42 @@ let rawconstr_of_aconstr_with_binders loc g f e = function
       let outerl = (ldots_var,inner)::(if swap then [x,RVar(loc,y)] else []) in
       subst_rawvars outerl it
   | ALambda (na,ty,c) ->
-      let e,na = name_fold_map g e na in RLambda (loc,na,Explicit,f e ty,f e c)
+      let e,na = g e na in RLambda (loc,na,Explicit,f e ty,f e c)
   | AProd (na,ty,c) ->
-      let e,na = name_fold_map g e na in RProd (loc,na,Explicit,f e ty,f e c)
+      let e,na = g e na in RProd (loc,na,Explicit,f e ty,f e c)
   | ALetIn (na,b,c) ->
-      let e,na = name_fold_map g e na in RLetIn (loc,na,f e b,f e c)
+      let e,na = g e na in RLetIn (loc,na,f e b,f e c)
   | ACases (sty,rtntypopt,tml,eqnl) ->
       let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') ->
 	let e',t' = match t with
 	| None -> e',None
-	| Some (ind,npar,nal) -> 
-	  let e',nal' = List.fold_right (fun na (e',nal) -> 
-	      let e',na' = name_fold_map g e' na in e',na'::nal) nal (e',[]) in
+	| Some (ind,npar,nal) ->
+	  let e',nal' = List.fold_right (fun na (e',nal) ->
+	      let e',na' = g e' na in e',na'::nal) nal (e',[]) in
 	  e',Some (loc,ind,npar,nal') in
-	let e',na' = name_fold_map g e' na in
+	let e',na' = g e' na in
 	(e',(f e tm,(na',t'))::tml')) tml (e,[]) in
-      let fold (idl,e) id = let (e,id) = g e id in ((id::idl,e),id) in
+      let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in
       let eqnl' = List.map (fun (patl,rhs) ->
 	let ((idl,e),patl) =
 	  list_fold_map (cases_pattern_fold_map loc fold) ([],e) patl in
 	(loc,idl,patl,f e rhs)) eqnl in
       RCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl')
   | ALetTuple (nal,(na,po),b,c) ->
-      let e,nal = list_fold_map (name_fold_map g) e nal in 
-      let e,na = name_fold_map g e na in
+      let e,nal = list_fold_map g e nal in
+      let e,na = g e na in
       RLetTuple (loc,nal,(na,Option.map (f e) po),f e b,f e c)
   | AIf (c,(na,po),b1,b2) ->
-      let e,na = name_fold_map g e na in
+      let e,na = g e na in
       RIf (loc,f e c,(na,Option.map (f e) po),f e b1,f e b2)
   | ARec (fk,idl,dll,tl,bl) ->
-      let e,idl = array_fold_map g e idl in
+      let e,idl = array_fold_map (to_id g) e idl in
       let e,dll = array_fold_map (list_fold_map (fun e (na,oc,b) ->
-	  let e,na = name_fold_map g e na in
+	  let e,na = g e na in
 	  (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in
       RRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e) bl)
-  | ACast (c,k) -> RCast (loc,f e c, 
-			  match k with 
+  | ACast (c,k) -> RCast (loc,f e c,
+			  match k with
 			    | CastConv (k,t) -> CastConv (k,f e t)
 			    | CastCoerce -> CastCoerce)
   | ASort x -> RSort (loc,x)
@@ -121,7 +127,7 @@ let rawconstr_of_aconstr_with_binders loc g f e = function
   | ARef x -> RRef (loc,x)
 
 let rec rawconstr_of_aconstr loc x =
-  let rec aux () x = 
+  let rec aux () x =
     rawconstr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x
   in aux () x
 
@@ -137,7 +143,7 @@ let has_ldots =
     (function RApp (_,RVar(_,v),_) when v = ldots_var -> true | _ -> false)
 
 let compare_rawconstr f t1 t2 = match t1,t2 with
-  | RRef (_,r1), RRef (_,r2) -> r1 = r2
+  | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2 
   | RVar (_,v1), RVar (_,v2) -> v1 = v2
   | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & List.for_all2 f l1 l2
   | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 ->
@@ -161,7 +167,7 @@ let discriminate_patterns foundvars nl l1 l2 =
   let rec aux n c1 c2 = match c1,c2 with
   | RVar (_,v1), RVar (_,v2) when v1<>v2 ->
       if !diff = None then (diff := Some (v1,v2,(n>=nl)); true)
-      else 
+      else
         !diff = Some (v1,v2,(n>=nl)) or !diff = Some (v2,v1,(n<nl))
         or (error
           "Both ends of the recursive pattern differ in more than one place")
@@ -182,7 +188,7 @@ let aconstr_and_vars_of_rawconstr a =
   let found = ref [] in
   let rec aux = function
   | RVar (_,id) -> found := id::!found; AVar id
-  | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args 
+  | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args
   | RApp (_,RVar (_,f),[RApp (_,t,[c]);d]) when f = ldots_var ->
       (* Special case for alternative (recursive) notation of application *)
       let x,y,lassoc = discriminate_patterns found 0 [c] [d] in
@@ -210,13 +216,13 @@ let aconstr_and_vars_of_rawconstr a =
       AIf (aux c,(na,Option.map aux po),aux b1,aux b2)
   | RRec (_,fk,idl,dll,tl,bl) ->
       Array.iter (fun id -> found := id::!found) idl;
-      let dll = Array.map (List.map (fun (na,bk,oc,b) -> 
-	 if bk <> Explicit then 
+      let dll = Array.map (List.map (fun (na,bk,oc,b) ->
+	 if bk <> Explicit then
 	   error "Binders marked as implicit not allowed in notations.";
 	 add_name found na; (na,Option.map aux oc,aux b))) dll in
       ARec (fk,idl,dll,Array.map aux tl,Array.map aux bl)
-  | RCast (_,c,k) -> ACast (aux c, 
-			    match k with CastConv (k,t) -> CastConv (k,aux t) 
+  | RCast (_,c,k) -> ACast (aux c,
+			    match k with CastConv (k,t) -> CastConv (k,aux t)
 			      | CastCoerce -> CastCoerce)
   | RSort (_,s) -> ASort s
   | RHole (_,w) -> AHole w
@@ -271,65 +277,65 @@ let aconstr_of_rawconstr vars a =
 let aconstr_of_constr avoiding t =
  aconstr_of_rawconstr [] (Detyping.detype false avoiding [] t)
 
-let rec subst_pat subst pat = 
+let rec subst_pat subst pat =
   match pat with
   | PatVar _ -> pat
-  | PatCstr (loc,((kn,i),j),cpl,n) -> 
-      let kn' = subst_kn subst kn 
+  | PatCstr (loc,((kn,i),j),cpl,n) ->
+      let kn' = subst_ind subst kn
       and cpl' = list_smartmap (subst_pat subst) cpl in
         if kn' == kn && cpl' == cpl then pat else
           PatCstr (loc,((kn',i),j),cpl',n)
 
 let rec subst_aconstr subst bound raw =
   match raw with
-  | ARef ref -> 
-      let ref',t = subst_global subst ref in 
+  | ARef ref ->
+      let ref',t = subst_global subst ref in
 	if ref' == ref then raw else
 	  aconstr_of_constr bound t
 
   | AVar _ -> raw
 
-  | AApp (r,rl) -> 
-      let r' = subst_aconstr subst bound r 
+  | AApp (r,rl) ->
+      let r' = subst_aconstr subst bound r
       and rl' = list_smartmap (subst_aconstr subst bound) rl in
 	if r' == r && rl' == rl then raw else
 	  AApp(r',rl')
 
-  | AList (id1,id2,r1,r2,b) -> 
+  | AList (id1,id2,r1,r2,b) ->
       let r1' = subst_aconstr subst bound r1
       and r2' = subst_aconstr subst bound r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  AList (id1,id2,r1',r2',b)
 
-  | ALambda (n,r1,r2) -> 
+  | ALambda (n,r1,r2) ->
       let r1' = subst_aconstr subst bound r1
       and r2' = subst_aconstr subst bound r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  ALambda (n,r1',r2')
 
-  | AProd (n,r1,r2) -> 
+  | AProd (n,r1,r2) ->
       let r1' = subst_aconstr subst bound r1
       and r2' = subst_aconstr subst bound r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  AProd (n,r1',r2')
 
-  | ALetIn (n,r1,r2) -> 
-      let r1' = subst_aconstr subst bound r1 
+  | ALetIn (n,r1,r2) ->
+      let r1' = subst_aconstr subst bound r1
       and r2' = subst_aconstr subst bound r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  ALetIn (n,r1',r2')
 
-  | ACases (sty,rtntypopt,rl,branches) -> 
+  | ACases (sty,rtntypopt,rl,branches) ->
       let rtntypopt' = Option.smartmap (subst_aconstr subst bound) rtntypopt
       and rl' = list_smartmap
-        (fun (a,(n,signopt) as x) -> 
+        (fun (a,(n,signopt) as x) ->
 	  let a' = subst_aconstr subst bound a in
 	  let signopt' = Option.map (fun ((indkn,i),n,nal as z) ->
-	    let indkn' = subst_kn subst indkn in
+	    let indkn' = subst_ind subst indkn in
 	    if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in
 	  if a' == a && signopt' == signopt then x else (a',(n,signopt')))
         rl
-      and branches' = list_smartmap 
+      and branches' = list_smartmap
                         (fun (cpl,r as branch) ->
                            let cpl' = list_smartmap (subst_pat subst) cpl
                            and r' = subst_aconstr subst bound r in
@@ -343,7 +349,7 @@ let rec subst_aconstr subst bound raw =
 
   | ALetTuple (nal,(na,po),b,c) ->
       let po' = Option.smartmap (subst_aconstr subst bound) po
-      and b' = subst_aconstr subst bound b 
+      and b' = subst_aconstr subst bound b
       and c' = subst_aconstr subst bound c in
 	if po' == po && b' == b && c' == c then raw else
 	  ALetTuple (nal,(na,po'),b',c')
@@ -351,13 +357,13 @@ let rec subst_aconstr subst bound raw =
   | AIf (c,(na,po),b1,b2) ->
       let po' = Option.smartmap (subst_aconstr subst bound) po
       and b1' = subst_aconstr subst bound b1
-      and b2' = subst_aconstr subst bound b2 
+      and b2' = subst_aconstr subst bound b2
       and c' = subst_aconstr subst bound c in
 	if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else
 	  AIf (c',(na,po'),b1',b2')
 
   | ARec (fk,idl,dll,tl,bl) ->
-      let dll' = 
+      let dll' =
 	array_smartmap (list_smartmap (fun (na,oc,b as x) ->
 	  let oc' =  Option.smartmap (subst_aconstr subst bound) oc in
 	  let b' =  subst_aconstr subst bound b in
@@ -369,18 +375,18 @@ let rec subst_aconstr subst bound raw =
 
   | APatVar _ | ASort _ -> raw
 
-  | AHole (Evd.ImplicitArg (ref,i)) ->
-      let ref',t = subst_global subst ref in 
+  | AHole (Evd.ImplicitArg (ref,i,b)) ->
+      let ref',t = subst_global subst ref in
 	if ref' == ref then raw else
 	  AHole (Evd.InternalHole)
-  | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType 
+  | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType
     | Evd.InternalHole | Evd.TomatchTypeParameter _ | Evd.GoalEvar
-    | Evd.ImpossibleCase) -> raw
+    | Evd.ImpossibleCase | Evd.MatchingVar _) -> raw
 
-  | ACast (r1,k) -> 
+  | ACast (r1,k) ->
       match k with
 	  CastConv (k, r2) ->
-	    let r1' = subst_aconstr subst bound r1 
+	    let r1' = subst_aconstr subst bound r1
 	    and r2' = subst_aconstr subst bound r2 in
 	      if r1' == r1 && r2' == r2 then raw else
 		ACast (r1',CastConv (k,r2'))
@@ -388,7 +394,7 @@ let rec subst_aconstr subst bound raw =
 	    let r1' = subst_aconstr subst bound r1 in
 	      if r1' == r1 then raw else
 		ACast (r1',CastCoerce)
-		  
+
 let subst_interpretation subst (metas,pat) =
   let bound = List.map fst (fst metas @ snd metas) in
   (metas,subst_aconstr subst bound pat)
@@ -443,7 +449,7 @@ let match_fix_kind fk1 fk2 =
   match (fk1,fk2) with
   | RCoFix n1, RCoFix n2 -> n1 = n2
   | RFix (nl1,n1), RFix (nl2,n2) ->
-      n1 = n2 && 
+      n1 = n2 &&
       array_for_all2 (fun (n1,_) (n2,_) -> n2 = None || n1 = n2) nl1 nl2
   | _ -> false
 
@@ -452,19 +458,23 @@ let match_opt f sigma t1 t2 = match (t1,t2) with
   | Some t1, Some t2 -> f sigma t1 t2
   | _ -> raise No_match
 
+let rawconstr_of_name = function
+  | Anonymous -> RHole (dummy_loc,Evd.InternalHole)
+  | Name id -> RVar (dummy_loc,id)
+
 let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
-  | (Name id1,Name id2) when List.mem id2 metas ->
-      alp, bind_env alp sigma id2 (RVar (dummy_loc,id1))
+  | (na,Name id2) when List.mem id2 metas ->
+      alp, bind_env alp sigma id2 (rawconstr_of_name na)
   | (Name id1,Name id2) -> (id1,id2)::alp,sigma
   | (Anonymous,Anonymous) -> alp,sigma
   | _ -> raise No_match
 
-let rec match_cases_pattern metas acc pat1 pat2 =
+let rec match_cases_pattern_binders metas acc pat1 pat2 =
   match (pat1,pat2) with
   | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2
   | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2)
       when c1 = c2 & List.length patl1 = List.length patl2 ->
-      List.fold_left2 (match_cases_pattern metas)
+      List.fold_left2 (match_cases_pattern_binders metas)
 	(match_names metas acc na1 na2) patl1 patl2
   | _ -> raise No_match
 
@@ -472,10 +482,33 @@ let adjust_application_n n loc f l =
   let l1,l2 = list_chop (List.length l - n) l in
   if l1 = [] then f,l else RApp (loc,f,l1), l2
 
+let match_alist match_fun metas sigma l1 l2 x iter termin lassoc =
+  (* match the iterator at least once *)
+  let sigmavar,sigmalist =
+    List.fold_left2 (match_fun (ldots_var::metas)) sigma l1 l2 in
+  (* Recover the recursive position *)
+  let rest = List.assoc ldots_var sigmavar in
+  (* Recover the first element *)
+  let t1 = List.assoc x sigmavar in
+  let sigmavar = List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in
+  (* try to find the remaining elements or the terminator *)
+  let rec match_alist_tail metas sigma acc rest =
+    try
+      let sigmavar,sigmalist = match_fun (ldots_var::metas) sigma rest iter in
+      let rest = List.assoc ldots_var sigmavar in
+      let t = List.assoc x sigmavar in
+      let sigmavar =
+	List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in
+      match_alist_tail metas (sigmavar,sigmalist) (t::acc) rest
+    with No_match ->
+      List.rev acc, match_fun metas (sigmavar,sigmalist) rest termin in
+  let tl,(sigmavar,sigmalist) = match_alist_tail metas sigma [t1] rest in
+  (sigmavar, (x,if lassoc then List.rev tl else tl)::sigmalist)
+
 let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
   | r1, AVar id2 when List.mem id2 metas -> bind_env alp sigma id2 r1
   | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma
-  | RRef (_,r1), ARef r2 when r1 = r2 -> sigma
+  | RRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma 
   | RPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma
   | RApp (loc,f1,l1), AApp (f2,l2) ->
       let n1 = List.length l1 and n2 = List.length l2 in
@@ -486,30 +519,31 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
 	  let l11,l12 = list_chop (n1-n2) l1 in RApp (loc,f1,l11),l12, f2,l2
 	else f1,l1, f2, l2 in
       List.fold_left2 (match_ alp metas) (match_ alp metas sigma f1 f2) l1 l2
-  | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) 
+  | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc)
       when List.length l1 >= List.length l2 ->
       let f1,l1 = adjust_application_n (List.length l2) loc f1 l1 in
-      match_alist alp metas sigma (f1::l1) (f2::l2) x iter termin lassoc
+      match_alist (match_ alp)
+	metas sigma (f1::l1) (f2::l2) x iter termin lassoc
   | RLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) ->
      match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
   | RProd (_,na1,_,t1,b1), AProd (na2,t2,b2) ->
      match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
   | RLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) ->
      match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
-  | RCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2) 
+  | RCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2)
       when sty1 = sty2
 	 & List.length tml1 = List.length tml2
 	 & List.length eqnl1 = List.length eqnl2 ->
       let rtno1' = abstract_return_type_context_rawconstr tml1 rtno1 in
       let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in
-      let sigma = 
-	try Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2' 
+      let sigma =
+	try Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2'
 	with Option.Heterogeneous -> raise No_match
       in
-      let sigma = List.fold_left2 
+      let sigma = List.fold_left2
       (fun s (tm1,_) (tm2,_) -> match_ alp metas s tm1 tm2) sigma tml1 tml2 in
       List.fold_left2 (match_equations alp metas) sigma eqnl1 eqnl2
-  | RLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) 
+  | RLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2)
       when List.length nal1 = List.length nal2 ->
       let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in
       let sigma = match_ alp metas sigma b1 b2 in
@@ -519,7 +553,7 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
   | RIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) ->
       let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in
       List.fold_left2 (match_ alp metas) sigma [a1;b1;c1] [a2;b2;c2]
-  | RRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2) 
+  | RRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2)
       when match_fix_kind fk1 fk2 & Array.length idl1 =  Array.length idl2 &
 	array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) dll1 dll2
 	->
@@ -529,7 +563,7 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
 	    match_ alp metas (match_opt (match_ alp metas) sigma oc1 oc2) b1 b2
 	  in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in
       let sigma = array_fold_left2 (match_ alp metas) sigma tl1 tl2 in
-      let alp,sigma = array_fold_right2 (fun id1 id2 alsig -> 
+      let alp,sigma = array_fold_right2 (fun id1 id2 alsig ->
 	match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in
       array_fold_left2 (match_ alp metas) sigma bl1 bl2
   | RCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) ->
@@ -539,32 +573,9 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
   | RSort (_,s1), ASort s2 when s1 = s2 -> sigma
   | RPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match
   | a, AHole _ -> sigma
-  | (RDynamic _ | RRec _ | REvar _), _ 
+  | (RDynamic _ | RRec _ | REvar _), _
   | _,_ -> raise No_match
 
-and match_alist alp metas sigma l1 l2 x iter termin lassoc =
-  (* match the iterator at least once *)
-  let sigmavar,sigmalist =
-    List.fold_left2 (match_ alp (ldots_var::metas)) sigma l1 l2 in
-  (* Recover the recursive position *)
-  let rest = List.assoc ldots_var sigmavar in
-  (* Recover the first element *)
-  let t1 = List.assoc x sigmavar in
-  let sigmavar = List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in
-  (* try to find the remaining elements or the terminator *)
-  let rec match_alist_tail alp metas sigma acc rest =
-    try 
-      let sigmavar,sigmalist = match_ alp (ldots_var::metas) sigma rest iter in
-      let rest = List.assoc ldots_var sigmavar in
-      let t = List.assoc x sigmavar in
-      let sigmavar =
-	List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in
-      match_alist_tail alp metas (sigmavar,sigmalist) (t::acc) rest
-    with No_match ->
-      List.rev acc, match_ alp metas (sigmavar,sigmalist) rest termin in
-  let tl,(sigmavar,sigmalist) = match_alist_tail alp metas sigma [t1] rest in
-  (sigmavar, (x,if lassoc then List.rev tl else tl)::sigmalist)
-
 and match_binders alp metas na1 na2 sigma b1 b2 =
   let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in
   match_ alp metas sigma b1 b2
@@ -572,8 +583,9 @@ and match_binders alp metas na1 na2 sigma b1 b2 =
 and match_equations alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
   (* patl1 and patl2 have the same length because they respectively
      correspond to some tml1 and tml2 that have the same length *)
-  let (alp,sigma) = 
-    List.fold_left2 (match_cases_pattern metas) (alp,sigma) patl1 patl2 in
+  let (alp,sigma) =
+    List.fold_left2 (match_cases_pattern_binders metas)
+      (alp,sigma) patl1 patl2 in
   match_ alp metas sigma rhs1 rhs2
 
 type scope_name = string
@@ -599,6 +611,55 @@ let match_aconstr c ((metas_scl,metaslist_scl),pat) =
   List.map (fun (x,scl) -> (find x,scl)) metas_scl,
   List.map (fun (x,scl) -> (List.assoc x substlist,scl)) metaslist_scl
 
+(* Matching cases pattern *)
+
+let bind_env_cases_pattern (sigma,sigmalist as fullsigma) var v =
+  try
+    let vvar = List.assoc var sigma in
+    if v=vvar then fullsigma else raise No_match
+  with Not_found ->
+    (* TODO: handle the case of multiple occs in different scopes *)
+    (var,v)::sigma,sigmalist
+
+let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with
+  | r1, AVar id2 when List.mem id2 metas -> bind_env_cases_pattern sigma id2 r1
+  | PatVar (_,Anonymous), AHole _ -> sigma
+  | PatCstr (loc,(ind,_ as r1),[],_), ARef (ConstructRef r2) when r1 = r2 ->
+      sigma
+  | PatCstr (loc,(ind,_ as r1),args1,_), AApp (ARef (ConstructRef r2),l2)
+      when r1 = r2 ->
+      let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in
+      if List.length l2 <> nparams + List.length args1
+      then
+	(* TODO: revert partially applied notations of the form
+           "Notation P := (@pair)." *)
+	raise No_match
+      else
+        let (p2,args2) = list_chop nparams l2 in
+        (* All parameters must be _ *)
+        List.iter (function AHole _ -> () | _ -> raise No_match) p2;
+	List.fold_left2 (match_cases_pattern metas) sigma args1 args2
+  | PatCstr (loc,(ind,_ as r1),args1,_),
+    AList (x,_,(AApp (ARef (ConstructRef r2),l2) as iter),termin,lassoc)
+      when r1 = r2 ->
+      let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in
+      assert (List.length args1 + nparams = List.length l2);
+      let (p2,args2) = list_chop nparams l2 in
+      List.iter (function AHole _ -> () | _ -> raise No_match) p2;
+      match_alist match_cases_pattern
+	metas sigma args1 args2 x iter termin lassoc
+  | _ -> raise No_match
+
+let match_aconstr_cases_pattern c ((metas_scl,metaslist_scl),pat) =
+  let vars = List.map fst metas_scl @ List.map fst metaslist_scl in
+  let subst,substlist = match_cases_pattern vars ([],[]) c pat in
+  (* Reorder canonically the substitution *)
+  let find x subst =
+    try List.assoc x subst
+    with Not_found -> anomaly "match_aconstr_cases_pattern" in
+  List.map (fun (x,scl) -> (find x subst,scl)) metas_scl,
+  List.map (fun (x,scl) -> (find x substlist,scl)) metaslist_scl
+
 (**********************************************************************)
 (*s Concrete syntax for terms *)
 
@@ -624,20 +685,21 @@ type cases_pattern_expr =
   | CPatOr of loc * cases_pattern_expr list
   | CPatNotation of loc * notation * cases_pattern_expr notation_substitution
   | CPatPrim of loc * prim_token
+  | CPatRecord of loc * (reference * cases_pattern_expr) list
   | CPatDelimiters of loc * string * cases_pattern_expr
 
 type constr_expr =
   | CRef of reference
-  | CFix of loc * identifier located * fixpoint_expr list
-  | CCoFix of loc * identifier located * cofixpoint_expr list
+  | CFix of loc * identifier located * fix_expr list
+  | CCoFix of loc * identifier located * cofix_expr list
   | CArrow of loc * constr_expr * constr_expr
   | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
   | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
   | CLetIn of loc * name located * constr_expr * constr_expr
   | CAppExpl of loc * (proj_flag * reference) * constr_expr list
-  | CApp of loc * (proj_flag * constr_expr) * 
+  | CApp of loc * (proj_flag * constr_expr) *
       (constr_expr * explicitation located option) list
-  | CRecord of loc * constr_expr option * (identifier located * constr_expr) list
+  | CRecord of loc * constr_expr option * (reference * constr_expr) list
   | CCases of loc * case_style * constr_expr option *
       (constr_expr * (name option * constr_expr option)) list *
       (loc * cases_pattern_expr list located list * constr_expr) list
@@ -656,24 +718,24 @@ type constr_expr =
   | CDelimiters of loc * string * constr_expr
   | CDynamic of loc * Dyn.t
 
-and fixpoint_expr =
+and fix_expr =
     identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
 
 and local_binder =
   | LocalRawDef of name located * constr_expr
   | LocalRawAssum of name located list * binder_kind * constr_expr
-      
+
 and typeclass_constraint = name located * binding_kind * constr_expr
 
 and typeclass_context = typeclass_constraint list
 
-and cofixpoint_expr =
+and cofix_expr =
     identifier located * local_binder list * constr_expr * constr_expr
 
-and recursion_order_expr = 
+and recursion_order_expr =
   | CStructRec
   | CWfRec of constr_expr
-  | CMeasureRec of constr_expr
+  | CMeasureRec of constr_expr * constr_expr option (* measure, relation *)
 
 type constr_pattern_expr = constr_expr
 
@@ -682,16 +744,6 @@ type constr_pattern_expr = constr_expr
 
 let default_binder_kind = Default Explicit
 
-let rec local_binders_length = function
-  | [] -> 0
-  | LocalRawDef _::bl -> 1 + local_binders_length bl
-  | LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
-
-let rec local_assums_length = function
-  | [] -> 0
-  | LocalRawDef _::bl -> local_binders_length bl
-  | LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
-
 let names_of_local_assums bl =
   List.flatten (List.map (function LocalRawAssum(l,_,_)->l|_->[]) bl)
 
@@ -733,6 +785,7 @@ let cases_pattern_expr_loc = function
   | CPatAtom (loc,_) -> loc
   | CPatOr (loc,_) -> loc
   | CPatNotation (loc,_,_) -> loc
+  | CPatRecord (loc, _) -> loc
   | CPatPrim (loc,_) -> loc
   | CPatDelimiters (loc,_,_) -> loc
 
@@ -745,7 +798,7 @@ let ids_of_cases_indtype =
   let rec vars_of = function
     (* We deal only with the regular cases *)
     | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l)
-    | CNotation (_,_,(l,[])) 
+    | CNotation (_,_,(l,[]))
     (* assume the ntn is applicative and does not instantiate the head !! *)
     | CAppExpl (_,_,l) -> List.fold_left add_var [] l
     | CDelimiters(_,_,c) -> vars_of c
@@ -760,10 +813,12 @@ let ids_of_cases_tomatch tms =
     tms []
 
 let is_constructor id =
-  try ignore (Nametab.extended_locate (make_short_qualid id)); true
+  try ignore (Nametab.locate_extended (qualid_of_ident id)); true
   with Not_found -> true
- 
+
 let rec cases_pattern_fold_names f a = function
+  | CPatRecord (_, l) ->
+      List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l
   | CPatAlias (_,pat,id) -> f id a
   | CPatCstr (_,_,patl) | CPatOr (_,patl) ->
       List.fold_left (cases_pattern_fold_names f) a patl
@@ -775,7 +830,7 @@ let rec cases_pattern_fold_names f a = function
 
 let ids_of_pattern_list =
   List.fold_left
-    (located_fold_left 
+    (located_fold_left
       (List.fold_left (cases_pattern_fold_names Idset.add)))
     Idset.empty
 
@@ -827,12 +882,12 @@ let fold_constr_expr_with_binders g f n acc = function
   | CFix (loc,_,l) ->
       let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in
       List.fold_right (fun (_,(_,o),lb,t,c) acc ->
-	fold_local_binders g f n' 
+	fold_local_binders g f n'
 	  (fold_local_binders g f n acc t lb) c lb) l acc
-  | CCoFix (loc,_,_) -> 
+  | CCoFix (loc,_,_) ->
       Pp.warning "Capture check in multiple binders not done"; acc
 
-let free_vars_of_constr_expr c = 
+let free_vars_of_constr_expr c =
   let rec aux bdvars l = function
   | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l
   | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c
@@ -842,26 +897,31 @@ let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c)
 
 let mkIdentC id  = CRef (Ident (dummy_loc, id))
 let mkRefC r     = CRef r
-let mkAppC (f,l) = CApp (dummy_loc, (None,f), List.map (fun x -> (x,None)) l)
 let mkCastC (a,k)  = CCast (dummy_loc,a,k)
 let mkLambdaC (idl,bk,a,b) = CLambdaN (dummy_loc,[idl,bk,a],b)
 let mkLetInC (id,a,b)   = CLetIn (dummy_loc,id,a,b)
 let mkProdC (idl,bk,a,b)   = CProdN (dummy_loc,[idl,bk,a],b)
 
+let mkAppC (f,l) =
+  let l = List.map (fun x -> (x,None)) l in
+  match f with
+  | CApp (_,g,l') -> CApp (dummy_loc, g, l' @ l)
+  | _ -> CApp (dummy_loc, (None, f), l)
+
 let rec mkCProdN loc bll c =
   match bll with
-  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> 
+  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
       CProdN (loc,[idl,bk,t],mkCProdN (join_loc loc1 loc) bll c)
-  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
+  | LocalRawDef ((loc1,_) as id,b) :: bll ->
       CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c)
   | [] -> c
   | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c
 
 let rec mkCLambdaN loc bll c =
   match bll with
-  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> 
+  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
       CLambdaN (loc,[idl,bk,t],mkCLambdaN (join_loc loc1 loc) bll c)
-  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
+  | LocalRawDef ((loc1,_) as id,b) :: bll ->
       CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c)
   | [] -> c
   | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c
@@ -872,7 +932,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)
-      
+
 let rec prod_constr_expr c = function
   | [] -> c
   | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl)
@@ -880,12 +940,39 @@ let rec prod_constr_expr c = function
       List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl
       (prod_constr_expr c bl)
 
+let coerce_reference_to_id = function
+  | Ident (_,id) -> id
+  | Qualid (loc,_) ->
+      user_err_loc (loc, "coerce_reference_to_id",
+        str "This expression should be a simple identifier.")
+
 let coerce_to_id = function
   | CRef (Ident (loc,id)) -> (loc,id)
   | a -> user_err_loc
         (constr_loc a,"coerce_to_id",
          str "This expression should be a simple identifier.")
 
+let coerce_to_name = function
+  | CRef (Ident (loc,id)) -> (loc,Name id)
+  | CHole (loc,_) -> (loc,Anonymous)
+  | a -> user_err_loc
+        (constr_loc a,"coerce_to_name",
+         str "This expression should be a name.")
+
+(* Interpret the index of a recursion order annotation *)
+
+let index_of_annot bl na =
+  let names = List.map snd (names_of_local_assums bl) in
+  match na with
+  | None ->
+      if names = [] then error "A fixpoint needs at least one parameter." 
+      else None
+  | Some (loc, id) ->
+      try Some (list_index0 (Name id) names)
+      with Not_found ->
+        user_err_loc(loc,"",
+        str "No parameter named " ++ Nameops.pr_id id ++ str".")
+
 (* Used in correctness and interface *)
 
 let map_binder g e nal = List.fold_right (fun (_,na) -> name_fold g na) nal e
@@ -908,8 +995,8 @@ let map_local_binders f g e bl =
 
 let map_constr_expr_with_binders g f e = function
   | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b)
-  | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) 
-  | CApp (loc,(p,a),l) -> 
+  | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l)
+  | CApp (loc,(p,a),l) ->
       CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l)
   | CProdN (loc,bl,b) ->
       let (e,bl) = map_binders f g e bl in CProdN (loc,bl,f e b)
@@ -922,7 +1009,7 @@ let map_constr_expr_with_binders g f e = function
       CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll))
   | CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c)
   | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a)
-  | CHole _ | CEvar _ | CPatVar _ | CSort _ 
+  | CHole _ | CEvar _ | CPatVar _ | CSort _
   | CPrim _ | CDynamic _ | CRef _ as x -> x
   | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l)
   | CCases (loc,sty,rtnpo,a,bl) ->
@@ -939,7 +1026,7 @@ let map_constr_expr_with_binders g f e = function
       let e' = Option.fold_right (name_fold g) ona e in
       CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2)
   | CFix (loc,id,dl) ->
-      CFix (loc,id,List.map (fun (id,n,bl,t,d) -> 
+      CFix (loc,id,List.map (fun (id,n,bl,t,d) ->
         let (e',bl') = map_local_binders f g e bl in
         let t' = f e' t in
         (* Note: fix names should be inserted before the arguments... *)
@@ -958,33 +1045,38 @@ let map_constr_expr_with_binders g f e = function
 let rec replace_vars_constr_expr l = function
   | CRef (Ident (loc,id)) as x ->
       (try CRef (Ident (loc,List.assoc id l)) with Not_found -> x)
-  | c -> map_constr_expr_with_binders List.remove_assoc 
+  | c -> map_constr_expr_with_binders List.remove_assoc
            replace_vars_constr_expr l c
 
 (**********************************************************************)
 (* Concrete syntax for modules and modules types *)
 
-type with_declaration_ast = 
+type with_declaration_ast =
   | CWith_Module of identifier list located * qualid located
   | CWith_Definition of identifier list located * constr_expr
 
+type module_ast =
+  | CMident of qualid located
+  | CMapply of module_ast * module_ast
+  | CMwith of module_ast * with_declaration_ast
 
-type module_ast = 
-  | CMEident of qualid located
-  | CMEapply of module_ast * module_ast
+type module_ast_inl = module_ast * bool (* honor the inline annotations or not *)
 
-type module_type_ast = 
-  | CMTEident of qualid located
-  | CMTEapply of module_type_ast * module_ast
-  | CMTEwith of module_type_ast * with_declaration_ast
+type 'a module_signature =
+  | Enforce of 'a (* ... : T *)
+  | Check of 'a list (* ... <: T1 <: T2, possibly empty *)
 
-type include_ast =
-  | CIMTE of module_type_ast
-  | CIME of module_ast
+(* Returns the ranges of locs of the notation that are not occupied by args  *)
+(* and which are them occupied by proper symbols of the notation (or spaces) *)
 
-let loc_of_notation f loc args ntn =
-  if args=[] or ntn.[0] <> '_' then fst (Util.unloc loc)
-  else snd (Util.unloc (f (List.hd args)))
+let locs_of_notation f loc (args,argslist) ntn =
+  let (bl,el) = Util.unloc loc in
+  let rec aux pos = function
+    | [] -> if pos = el then [] else [(pos,el-1)]
+    | a::l ->
+	let ba,ea = Util.unloc (f a) in
+	if pos = ba then aux ea l else (pos,ba-1)::aux ea l
+  in aux bl (args@List.flatten argslist)
 
-let ntn_loc = loc_of_notation constr_loc
-let patntn_loc = loc_of_notation cases_pattern_expr_loc
+let ntn_loc = locs_of_notation constr_loc
+let patntn_loc = locs_of_notation cases_pattern_expr_loc
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
index 1dd5ec97..f67edfb9 100644
--- a/interp/topconstr.mli
+++ b/interp/topconstr.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: topconstr.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -39,7 +39,7 @@ type aconstr =
   | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
   | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
   | ARec of fix_kind * identifier array *
-      (name * aconstr option * aconstr) list array * aconstr array * 
+      (name * aconstr option * aconstr) list array * aconstr array *
       aconstr array
   | ASort of rawsort
   | AHole of Evd.hole_kind
@@ -48,7 +48,7 @@ type aconstr =
 
 (**********************************************************************)
 (* Translate a rawconstr into a notation given the list of variables  *)
-(* bound by the notation; also interpret recursive patterns           *) 
+(* bound by the notation; also interpret recursive patterns           *)
 
 val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr
 
@@ -61,8 +61,8 @@ val eq_rawconstr : rawconstr -> rawconstr -> bool
 (**********************************************************************)
 (* Re-interpret a notation as a rawconstr, taking care of binders     *)
 
-val rawconstr_of_aconstr_with_binders : loc -> 
-  ('a -> identifier -> 'a * identifier) ->
+val rawconstr_of_aconstr_with_binders : loc ->
+  ('a -> name -> 'a * name) ->
   ('a -> aconstr -> rawconstr) -> 'a -> aconstr -> rawconstr
 
 val rawconstr_of_aconstr : loc -> aconstr -> rawconstr
@@ -86,6 +86,9 @@ type interpretation =
 val match_aconstr : rawconstr -> interpretation ->
       (rawconstr * subscopes) list * (rawconstr list * subscopes) list
 
+val match_aconstr_cases_pattern :  cases_pattern -> interpretation ->
+      (cases_pattern * subscopes) list * (cases_pattern list * subscopes) list
+
 (**********************************************************************)
 (* Substitution of kernel names in interpretation data                *)
 
@@ -97,9 +100,9 @@ val subst_interpretation : substitution -> interpretation -> interpretation
 type notation = string
 
 type explicitation = ExplByPos of int * identifier option | ExplByName of identifier
-  
-type binder_kind = 
-  | Default of binding_kind 
+
+type binder_kind =
+  | Default of binding_kind
   | Generalized of binding_kind * binding_kind * bool
       (* Inner binding, outer bindings, typeclass-specific flag
 	 for implicit generalization of superclasses *)
@@ -120,20 +123,21 @@ type cases_pattern_expr =
   | CPatOr of loc * cases_pattern_expr list
   | CPatNotation of loc * notation * cases_pattern_expr notation_substitution
   | CPatPrim of loc * prim_token
+  | CPatRecord of Util.loc * (reference * cases_pattern_expr) list
   | CPatDelimiters of loc * string * cases_pattern_expr
 
 type constr_expr =
   | CRef of reference
-  | CFix of loc * identifier located * fixpoint_expr list
-  | CCoFix of loc * identifier located * cofixpoint_expr list
+  | CFix of loc * identifier located * fix_expr list
+  | CCoFix of loc * identifier located * cofix_expr list
   | CArrow of loc * constr_expr * constr_expr
   | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
   | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
   | CLetIn of loc * name located * constr_expr * constr_expr
   | CAppExpl of loc * (proj_flag * reference) * constr_expr list
-  | CApp of loc * (proj_flag * constr_expr) * 
+  | CApp of loc * (proj_flag * constr_expr) *
       (constr_expr * explicitation located option) list
-  | CRecord of loc * constr_expr option * (identifier located * constr_expr) list
+  | CRecord of loc * constr_expr option * (reference * constr_expr) list
   | CCases of loc * case_style * constr_expr option *
       (constr_expr * (name option * constr_expr option)) list *
       (loc * cases_pattern_expr list located list * constr_expr) list
@@ -152,22 +156,22 @@ type constr_expr =
   | CDelimiters of loc * string * constr_expr
   | CDynamic of loc * Dyn.t
 
-and fixpoint_expr =
+and fix_expr =
     identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
 
-and cofixpoint_expr =
+and cofix_expr =
     identifier located * local_binder list * constr_expr * constr_expr
 
-and recursion_order_expr = 
+and recursion_order_expr =
   | CStructRec
   | CWfRec of constr_expr
-  | CMeasureRec of constr_expr
+  | CMeasureRec of constr_expr * constr_expr option (* measure, relation *)
 
 (** Anonymous defs allowed ?? *)
 and local_binder =
   | LocalRawDef of name located * constr_expr
   | LocalRawAssum of name located list * binder_kind * constr_expr
-      
+
 type typeclass_constraint = name located * binding_kind * constr_expr
 
 and typeclass_context = typeclass_constraint list
@@ -200,7 +204,11 @@ val mkLambdaC : name located list * binder_kind * constr_expr * constr_expr -> c
 val mkLetInC : name located * constr_expr * constr_expr -> constr_expr
 val mkProdC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr
 
+val coerce_reference_to_id : reference -> identifier
 val coerce_to_id : constr_expr -> identifier located
+val coerce_to_name : constr_expr -> name located
+
+val index_of_annot : local_binder list -> identifier located option -> int option
 
 val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
 val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
@@ -211,18 +219,12 @@ val mkCProdN : loc -> local_binder list -> constr_expr -> constr_expr
 
 (* For binders parsing *)
 
-(* Includes let binders *)
-val local_binders_length : local_binder list -> int
-
-(* Excludes let binders *)
-val local_assums_length : local_binder list -> int
+(* With let binders *)
+val names_of_local_binders : local_binder list -> name located list
 
 (* Does not take let binders into account *)
 val names_of_local_assums : local_binder list -> name located list
 
-(* With let binders *)
-val names_of_local_binders : local_binder list -> name located list
-
 (* Used in typeclasses *)
 
 val fold_constr_expr_with_binders : (identifier -> 'a -> 'a) ->
@@ -238,23 +240,23 @@ val map_constr_expr_with_binders :
 (**********************************************************************)
 (* Concrete syntax for modules and module types                       *)
 
-type with_declaration_ast = 
+type with_declaration_ast =
   | CWith_Module of identifier list located * qualid located
   | CWith_Definition of identifier list located * constr_expr
 
+type module_ast =
+  | CMident of qualid located
+  | CMapply of module_ast * module_ast
+  | CMwith of module_ast * with_declaration_ast
 
-type module_ast = 
-  | CMEident of qualid located
-  | CMEapply of module_ast * module_ast
-
-type module_type_ast = 
-  | CMTEident of qualid located
-  | CMTEapply of module_type_ast * module_ast
-  | CMTEwith of module_type_ast * with_declaration_ast
+type module_ast_inl = module_ast * bool (* honor the inline annotations or not *)
 
-type include_ast =
-  | CIMTE of module_type_ast
-  | CIME of module_ast
+type 'a module_signature =
+  | Enforce of 'a (* ... : T *)
+  | Check of 'a list (* ... <: T1 <: T2, possibly empty *)
 
-val ntn_loc : Util.loc -> constr_expr list -> string -> int
-val patntn_loc : Util.loc -> cases_pattern_expr list -> string -> int
+val ntn_loc :
+  Util.loc -> constr_expr notation_substitution -> string -> (int * int) list
+val patntn_loc :
+  Util.loc -> cases_pattern_expr notation_substitution -> string ->
+  (int * int) list
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h
index 8a45e973..e224a108 100644
--- a/kernel/byterun/coq_instruct.h
+++ b/kernel/byterun/coq_instruct.h
@@ -11,6 +11,10 @@
 #ifndef _COQ_INSTRUCT_
 #define _COQ_INSTRUCT_
 
+/* 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.                         */
+
 enum instructions {
   ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC,
   PUSH, 
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
index 0a61ad79..04e38656 100644
--- a/kernel/byterun/int64_emul.h
+++ b/kernel/byterun/int64_emul.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */
+/* $Id$ */
 
 /* Software emulation of 64-bit integer arithmetic, for C compilers
    that do not support it.  */
diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h
index 4fc3c220..f5bef4a6 100644
--- a/kernel/byterun/int64_native.h
+++ b/kernel/byterun/int64_native.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */
+/* $Id$ */
 
 /* Wrapper macros around native 64-bit integer arithmetic,
    so that it has the same interface as the software emulation
diff --git a/kernel/byterun/libcoqrun.clib b/kernel/byterun/libcoqrun.clib
new file mode 100644
index 00000000..c06e4086
--- /dev/null
+++ b/kernel/byterun/libcoqrun.clib
@@ -0,0 +1,4 @@
+coq_fix_code.o
+coq_memory.o
+coq_values.o
+coq_interp.o
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index ceba6e82..f4d0bb2b 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -1,7 +1,7 @@
 open Names
 open Term
 
-type tag = int 
+type tag = int
 
 let id_tag = 0
 let iddef_tag = 1
@@ -14,22 +14,22 @@ let cofix_evaluated_tag = 6
 type structured_constant =
   | Const_sorts of sorts
   | Const_ind of inductive
-  | Const_b0 of tag                
+  | Const_b0 of tag
   | Const_bn of tag * structured_constant array
 
 
-type reloc_table = (tag * int) array 
+type reloc_table = (tag * int) array
 
-type annot_switch = 
+type annot_switch =
    {ci : case_info; rtbl : reloc_table; tailcall : bool}
- 
-module Label = 
+
+module Label =
   struct
     type t = int
     let no = -1
     let counter = ref no
     let create () = incr counter; !counter
-    let reset_label_counter () = counter := no 
+    let reset_label_counter () = counter := no
   end
 
 
@@ -49,24 +49,24 @@ type instruction =
   | Kgrab of int                        (* number of arguments *)
   | Kgrabrec of int                     (* rec arg *)
   | Kclosure of Label.t * int           (* label, number of free variables *)
-  | Kclosurerec of int * int * Label.t array * Label.t array 
+  | Kclosurerec of int * int * Label.t array * Label.t array
                    (* nb fv, init, lbl types, lbl bodies *)
-  | Kclosurecofix of int * int * Label.t array * Label.t array 
+  | Kclosurecofix of int * int * Label.t array * Label.t array
                    (* nb fv, init, lbl types, lbl bodies *)
   | Kgetglobal of constant
   | Kconst of structured_constant
   | Kmakeblock of int * tag             (* size, tag *)
-  | Kmakeprod 
+  | Kmakeprod
   | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
   | Kswitch of Label.t array * Label.t array (* consts,blocks *)
-  | Kpushfields of int 
+  | Kpushfields of int
   | Kfield of int
   | Ksetfield of int
   | Kstop
   | Ksequence of bytecodes * bytecodes
 (* spiwack: instructions concerning integers *)
   | Kbranch of Label.t                  (* jump to label *)
-  | Kaddint31                           (* adds the int31 in the accu 
+  | Kaddint31                           (* adds the int31 in the accu
                                            and the one ontop of the stack *)
   | Kaddcint31                          (* makes the sum and keeps the carry *)
   | Kaddcarrycint31                     (* sum +1, keeps the carry *)
@@ -77,10 +77,10 @@ type instruction =
   | Kmulcint31                          (* multiplication, result in two
 					   int31, for exact computation *)
   | Kdiv21int31                          (* divides a double size integer
-                                           (represented by an int31 in the 
-					   accumulator and one on the top of 
+                                           (represented by an int31 in the
+					   accumulator and one on the top of
 					   the stack) by an int31. The result
-					   is a pair of the quotient and the 
+					   is a pair of the quotient and the
 					   rest.
 					   If the divisor is 0, it returns
 					   0. *)
@@ -90,11 +90,11 @@ type instruction =
 					   cycling. Takes 3 int31 i j and s,
 					   and returns x*2^s+y/(2^(31-s) *)
   | Kcompareint31                       (* unsigned comparison of int31
-					   cf COMPAREINT31 in 
+					   cf COMPAREINT31 in
 					   kernel/byterun/coq_interp.c
 					   for more info *)
   | Khead0int31                         (* Give the numbers of 0 in head of a in31*)
-  | Ktail0int31                         (* Give the numbers of 0 in tail of a in31 
+  | Ktail0int31                         (* Give the numbers of 0 in tail of a in31
                                            ie low bits *)
   | Kisconst of Label.t                 (* conditional jump *)
   | Kareconst of int*Label.t            (* conditional jump *)
@@ -118,19 +118,19 @@ exception NotClosed
 type vm_env = {
     size : int;              (* longueur de la liste [n] *)
     fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
-  }    
-   
-   
-type comp_env = { 
+  }
+
+
+type comp_env = {
     nb_stack : int;              (* nbre de variables sur la pile          *)
     in_stack : int list;         (* position dans la pile                  *)
     nb_rec : int;                (* nbre de fonctions mutuellement         *)
                                  (* recursives =  nbr                      *)
     pos_rec  : instruction list; (* instruction d'acces pour les variables *)
                                  (*  de point fix ou de cofix              *)
-    offset : int;                 
-    in_env : vm_env ref 
-  } 
+    offset : int;
+    in_env : vm_env ref
+  }
 
 
 
@@ -176,7 +176,7 @@ let rec instruction ppf = function
   | Kmakeprod -> fprintf ppf "\tmakeprod"
   | Kmakeswitchblock(lblt,lbls,_,sz) ->
       fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz
-  | Kswitch(lblc,lblb) -> 
+  | Kswitch(lblc,lblb) ->
       fprintf ppf "\tswitch";
       Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc;
       Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
@@ -185,7 +185,7 @@ let rec instruction ppf = function
   | Kfield  n -> fprintf ppf "\tgetfield %i" n
   | Kstop -> fprintf ppf "\tstop"
   | Ksequence (c1,c2) ->
-      fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 
+      fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2
 (* spiwack *)
   | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl
   | Kaddint31 -> fprintf ppf "\taddint31"
@@ -218,9 +218,9 @@ and instruction_list ppf = function
       fprintf ppf "%a@ %a" instruction instr instruction_list il
 
 
-(*spiwack: moved this type in this file  because I needed it for 
+(*spiwack: moved this type in this file  because I needed it for
   retroknowledge which can't depend from cbytegen *)
-type block = 
+type block =
   | Bconstr of constr
   | Bstrconst of structured_constant
   | Bmakeblock of int * block array
@@ -228,10 +228,10 @@ type block =
                   (* tag , nparams, arity *)
   | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array
                 (* spiwack: compilation given by a function *)
-                (* compilation function (see get_vm_constant_dynamic_info in 
+                (* compilation function (see get_vm_constant_dynamic_info in
                    retroknowledge.mli for more info) , argument array  *)
 
 
- 
+
 let draw_instr c =
   fprintf std_formatter "@[<v 0>%a@]" instruction_list c
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index c24b5a53..f4dc0b14 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -1,7 +1,7 @@
 open Names
 open Term
 
-type tag = int 
+type tag = int
 
 val id_tag : tag
 val iddef_tag : tag
@@ -14,21 +14,21 @@ val cofix_evaluated_tag : tag
 type structured_constant =
   | Const_sorts of sorts
   | Const_ind of inductive
-  | Const_b0 of tag                
+  | Const_b0 of tag
   | Const_bn of tag * structured_constant array
 
-type reloc_table = (tag * int) array 
+type reloc_table = (tag * int) array
 
-type annot_switch = 
+type annot_switch =
    {ci : case_info; rtbl : reloc_table; tailcall : bool}
 
-module Label : 
+module Label :
   sig
     type t = int
     val no : t
     val create : unit -> t
     val reset_label_counter : unit -> unit
-  end 
+  end
 
 type instruction =
   | Klabel of Label.t
@@ -46,24 +46,24 @@ type instruction =
   | Kgrab of int                        (* number of arguments *)
   | Kgrabrec of int                     (* rec arg *)
   | Kclosure of Label.t * int           (* label, number of free variables *)
-  | Kclosurerec of int * int * Label.t array * Label.t array 
+  | Kclosurerec of int * int * Label.t array * Label.t array
                    (* nb fv, init, lbl types, lbl bodies *)
-  | Kclosurecofix of int * int * Label.t array * Label.t array 
+  | Kclosurecofix of int * int * Label.t array * Label.t array
                    (* nb fv, init, lbl types, lbl bodies *)
   | Kgetglobal of constant
   | Kconst of structured_constant
   | Kmakeblock of int * tag             (* size, tag *)
-  | Kmakeprod 
+  | Kmakeprod
   | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
   | Kswitch of Label.t array * Label.t array (* consts,blocks *)
-  | Kpushfields of int 
+  | Kpushfields of int
   | Kfield of int
   | Ksetfield of int
   | Kstop
   | Ksequence of bytecodes * bytecodes
 (* spiwack: instructions concerning integers *)
   | Kbranch of Label.t                  (* jump to label, is it needed ? *)
-  | Kaddint31                           (* adds the int31 in the accu 
+  | Kaddint31                           (* adds the int31 in the accu
                                            and the one ontop of the stack *)
   | Kaddcint31                          (* makes the sum and keeps the carry *)
   | Kaddcarrycint31                     (* sum +1, keeps the carry *)
@@ -74,10 +74,10 @@ type instruction =
   | Kmulcint31                          (* multiplication, result in two
 					   int31, for exact computation *)
   | Kdiv21int31                         (* divides a double size integer
-                                           (represented by an int31 in the 
-					   accumulator and one on the top of 
+                                           (represented by an int31 in the
+					   accumulator and one on the top of
 					   the stack) by an int31. The result
-					   is a pair of the quotient and the 
+					   is a pair of the quotient and the
 					   rest.
 					   If the divisor is 0, it returns
 					   0. *)
@@ -87,11 +87,11 @@ type instruction =
 					   cycling. Takes 3 int31 i j and s,
 					   and returns x*2^s+y/(2^(31-s) *)
   | Kcompareint31                        (* unsigned comparison of int31
-					   cf COMPAREINT31 in 
+					   cf COMPAREINT31 in
 					   kernel/byterun/coq_interp.c
 					   for more info *)
   | Khead0int31                         (* Give the numbers of 0 in head of a in31*)
-  | Ktail0int31                         (* Give the numbers of 0 in tail of a in31 
+  | Ktail0int31                         (* Give the numbers of 0 in tail of a in31
                                            ie low bits *)
   | Kisconst of Label.t                 (* conditional jump *)
   | Kareconst of int*Label.t            (* conditional jump *)
@@ -116,31 +116,31 @@ exception NotClosed
 type vm_env = {
     size : int;              (* longueur de la liste [n] *)
     fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
-  }    
-   
-   
-type comp_env = { 
+  }
+
+
+type comp_env = {
     nb_stack : int;              (* nbre de variables sur la pile          *)
     in_stack : int list;         (* position dans la pile                  *)
     nb_rec : int;                (* nbre de fonctions mutuellement         *)
                                  (* recursives =  nbr                      *)
     pos_rec  : instruction list; (* instruction d'acces pour les variables *)
                                  (*  de point fix ou de cofix              *)
-    offset : int;                 
-    in_env : vm_env ref 
-  } 
+    offset : int;
+    in_env : vm_env ref
+  }
 
 val draw_instr : bytecodes -> unit
 
 
 
 (*spiwack: moved this here because I needed it for retroknowledge *)
-type block = 
+type block =
   | Bconstr of constr
   | Bstrconst of structured_constant
   | Bmakeblock of int * block array
   | Bconstruct_app of int * int * int * block array
                   (* tag , nparams, arity *)
   | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array
-                (* compilation function (see get_vm_constant_dynamic_info in 
+                (* compilation function (see get_vm_constant_dynamic_info in
                    retroknowledge.mli for more info) , argument array  *)
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 72113425..e7859962 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -80,71 +80,71 @@ open Pre_env
 (*  [a1] est mis a jour :                                                 *)
 (*  a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ]     *)
 (* Le cycle est cree ...                                                  *)
-   
+
 (* On conserve la fct de cofix pour la conversion                         *)
-   
-    
+
+
 let empty_fv = { size= 0;  fv_rev = [] }
-  
+
 let fv r = !(r.in_env)
-   
-let empty_comp_env ()= 
-  { nb_stack = 0; 
+
+let empty_comp_env ()=
+  { nb_stack = 0;
     in_stack = [];
     nb_rec = 0;
     pos_rec = [];
-    offset = 0; 
+    offset = 0;
     in_env = ref empty_fv;
-  } 
+  }
 
 (*i Creation functions for comp_env *)
 
 let rec add_param n sz l =
-  if n = 0 then l else add_param (n - 1) sz (n+sz::l) 
-   
-let comp_env_fun arity = 
-  { nb_stack = arity; 
+  if n = 0 then l else add_param (n - 1) sz (n+sz::l)
+
+let comp_env_fun arity =
+  { nb_stack = arity;
     in_stack = add_param arity 0 [];
     nb_rec = 0;
     pos_rec = [];
-    offset = 1; 
-    in_env = ref empty_fv 
-  } 
-    
+    offset = 1;
+    in_env = ref empty_fv
+  }
 
-let comp_env_type rfv = 
-  { nb_stack = 0; 
+
+let comp_env_type rfv =
+  { nb_stack = 0;
     in_stack = [];
     nb_rec = 0;
     pos_rec = [];
-    offset = 1; 
-    in_env = rfv 
+    offset = 1;
+    in_env = rfv
   }
-   
+
 let comp_env_fix ndef curr_pos arity rfv =
    let prec = ref [] in
    for i = ndef downto 1 do
-     prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec 
+     prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec
    done;
-   { nb_stack = arity; 
+   { nb_stack = arity;
      in_stack = add_param arity 0 [];
-     nb_rec = ndef; 
+     nb_rec = ndef;
      pos_rec = !prec;
      offset = 2 * (ndef - curr_pos - 1)+1;
-     in_env = rfv 
-   } 
+     in_env = rfv
+   }
 
 let comp_env_cofix ndef arity rfv =
    let prec = ref [] in
    for i = 1 to ndef do
      prec := Kenvacc i :: !prec
    done;
-   { nb_stack = arity; 
+   { nb_stack = arity;
      in_stack = add_param arity 0 [];
-     nb_rec = ndef; 
+     nb_rec = ndef;
      pos_rec = !prec;
      offset = ndef+1;
-     in_env = rfv 
+     in_env = rfv
    }
 
 (* [push_param ] ajoute les parametres de fonction dans la pile *)
@@ -155,15 +155,15 @@ let push_param n sz r =
 
 (* [push_local e sz] ajoute une nouvelle variable dans la pile a la *)
 (* position [sz]                                                    *)
-let push_local sz r = 
-  { r with 
+let push_local sz r =
+  { r with
     nb_stack = r.nb_stack + 1;
     in_stack = (sz + 1) :: r.in_stack }
 
 
 
 (*i Compilation of variables *)
-let find_at el l = 
+let find_at el l =
   let rec aux n = function
     | [] -> raise Not_found
     | hd :: tl -> if hd = el then n else aux (n+1) tl
@@ -178,12 +178,12 @@ let pos_named id r =
     r.in_env := { size = pos+1; fv_rev =  cid:: env.fv_rev};
     Kenvacc (r.offset + pos)
 
-let pos_rel i r sz = 
+let pos_rel i r sz =
   if i <= r.nb_stack then
     Kacc(sz - (List.nth r.in_stack (i-1)))
   else
     let i = i - r.nb_stack in
-    if i <= r.nb_rec then 
+    if i <= r.nb_rec then
       try List.nth r.pos_rec (i-1)
       with _ -> assert false
     else
@@ -223,7 +223,7 @@ let label_code = function
    when executed, branches to the continuation or performs what the
    continuation performs. We avoid generating branches to returns. *)
 (* spiwack: make_branch was only used once. Changed it back to the ZAM
-      one to match the appropriate semantics (old one avoided the 
+      one to match the appropriate semantics (old one avoided the
       introduction of an unconditional branch operation, which seemed
       appropriate for the 31-bit integers' code). As a memory, I leave
       the former version in this comment.
@@ -259,7 +259,7 @@ let rec is_tailcall = function
   | _ -> None
 
 (* Extention of the continuation *)
-	
+
 (* Add a Kpop n instruction in front of a continuation *)
 let rec add_pop n = function
   | Kpop m :: cont -> add_pop (n+m) cont
@@ -269,9 +269,9 @@ let rec add_pop n = function
 let add_grab arity lbl cont =
   if arity = 1 then Klabel lbl :: cont
   else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont
- 
+
 let add_grabrec rec_arg arity lbl cont =
-  if arity = 1 then 
+  if arity = 1 then
     Klabel lbl :: Kgrabrec 0 :: Krestart :: cont
   else
     Krestart :: Klabel lbl :: Kgrabrec rec_arg ::
@@ -288,11 +288,11 @@ let cont_cofix arity =
     Kacc 2;
     Kfield 1;
     Kfield 0;
-    Kmakeblock(2, cofix_evaluated_tag); 
+    Kmakeblock(2, cofix_evaluated_tag);
     Kpush;        (*  stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*)
     Kacc 2;
     Ksetfield 1;  (*   ai = [At|accumulate|[Cfxe_t|fcofix|res]|args]      *)
-                  (*  stk = res::ai::args::ra::...                        *)   
+                  (*  stk = res::ai::args::ra::...                        *)
     Kacc 0;       (* accu = res                                           *)
     Kreturn (arity+2) ]
 
@@ -315,24 +315,24 @@ let init_fun_code () = fun_code := []
 let code_construct tag nparams arity cont =
   let f_cont =
       add_pop nparams
-      (if arity = 0 then 
+      (if arity = 0 then
 	[Kconst (Const_b0 tag); Kreturn 0]
        else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0])
-    in 
+    in
     let lbl = Label.create() in
     fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)];
     Kclosure(lbl,0) :: cont
 
 let get_strcst = function
   | Bstrconst sc -> sc
-  | _ -> raise Not_found 
+  | _ -> raise Not_found
 
 
-let rec str_const c = 
+let rec str_const c =
   match kind_of_term c with
   | Sort s -> Bstrconst (Const_sorts s)
-  | Cast(c,_,_) -> str_const c 
-  | App(f,args) -> 
+  | Cast(c,_,_) -> str_const c
+  | App(f,args) ->
       begin
 	match kind_of_term f with
 	| Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *)
@@ -345,32 +345,32 @@ let rec str_const c =
               (* spiwack: *)
               (* 1/ tries to compile the constructor in an optimal way,
                     it is supposed to work only if the arguments are
-                    all fully constructed, fails with Cbytecodes.NotClosed. 
+                    all fully constructed, fails with Cbytecodes.NotClosed.
                     it can also raise Not_found when there is no special
-                    treatment for this constructor 
-                    for instance: tries to to compile an integer of the 
-                        form I31 D1 D2 ... D31 to [D1D2...D31] as 
+                    treatment for this constructor
+                    for instance: tries to to compile an integer of the
+                        form I31 D1 D2 ... D31 to [D1D2...D31] as
                         a processor number (a caml number actually) *)
-              try 
+              try
 		try
-		  Bstrconst (Retroknowledge.get_vm_constant_static_info 
+		  Bstrconst (Retroknowledge.get_vm_constant_static_info
                                               (!global_env).retroknowledge
                                               (kind_of_term f) args)
                 with NotClosed ->
-		  (* 2/ if the arguments are not all closed (this is 
-                        expectingly (and it is currently the case) the only 
-                        reason why this exception is raised) tries to 
+		  (* 2/ if the arguments are not all closed (this is
+                        expectingly (and it is currently the case) the only
+                        reason why this exception is raised) tries to
                         give a clever, run-time behavior to the constructor.
                         Raises Not_found if there is no special treatment
                         for this integer.
                         this is done in a lazy fashion, using the constructor
                         Bspecial because it needs to know the continuation
                         and such, which can't be done at this time.
-                        for instance, for int31: if one of the digit is 
+                        for instance, for int31: if one of the digit is
                             not closed, it's not impossible that the number
                             gets fully instanciated at run-time, thus to ensure
                             uniqueness of the representation in the vm
-                            it is necessary to try and build a caml integer 
+                            it is necessary to try and build a caml integer
                             during the execution *)
 		  let rargs = Array.sub args nparams arity in
 		  let b_args = Array.map str_const rargs in
@@ -385,16 +385,16 @@ let rec str_const c =
 		else
 		  let rargs = Array.sub args nparams arity in
 		  let b_args = Array.map str_const rargs in
-		  try 
+		  try
 		    let sc_args = Array.map get_strcst b_args in
 		    Bstrconst(Const_bn(num, sc_args))
 		  with Not_found ->
 		    Bmakeblock(num,b_args)
-	    else  
+	    else
               let b_args = Array.map str_const args in
 	     (* spiwack: tries first to apply the run-time compilation
                 behavior of the constructor, as in 2/ above *)
-	      try 
+	      try
 		Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
                                            (kind_of_term f)),
@@ -407,7 +407,7 @@ let rec str_const c =
   | Ind ind -> Bstrconst (Const_ind ind)
   | Construct ((kn,j),i) ->  (*arnaud: Construct ((kn,j),i as cstr) ->  *)
       begin
-      (* spiwack: tries first to apply the run-time compilation 
+      (* spiwack: tries first to apply the run-time compilation
            behavior of the constructor, as in 2/ above *)
       try
 	Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
@@ -415,7 +415,7 @@ let rec str_const c =
                                            (kind_of_term c)),
                          [| |])
       with Not_found ->
-	let oib = lookup_mind kn !global_env in 
+	let oib = lookup_mind kn !global_env in
 	let oip = oib.mind_packets.(j) in
 	let num,arity = oip.mind_reloc_tbl.(i-1) in
 	let nparams = oib.mind_nparams in
@@ -426,17 +426,17 @@ let rec str_const c =
 
 (* compilation des applications *)
 let comp_args comp_expr reloc args sz cont =
-  let nargs_m_1 = Array.length args - 1 in  
+  let nargs_m_1 = Array.length args - 1 in
   let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in
   for i = 1 to nargs_m_1 do
     c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c)
-  done; 
+  done;
   !c
-  
+
 let comp_app comp_fun comp_arg reloc f args sz cont =
   let nargs = Array.length args in
   match is_tailcall cont with
-  | Some k -> 
+  | Some k ->
       comp_args comp_arg reloc args sz
 	(Kpush ::
 	 comp_fun reloc f (sz + nargs)
@@ -445,14 +445,14 @@ let comp_app comp_fun comp_arg reloc f args sz cont =
       if nargs < 4 then
 	comp_args comp_arg reloc args sz
 	  (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont)))
-      else 
+      else
 	let lbl,cont1 = label_code cont in
 	Kpush_retaddr lbl ::
 	(comp_args comp_arg reloc args (sz + 3)
 	   (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1))))
 
 (* Compilation des variables libres *)
-  
+
 let compile_fv_elem reloc fv sz cont =
   match fv with
   | FVrel i -> pos_rel i reloc sz :: cont
@@ -463,7 +463,7 @@ let rec compile_fv reloc l sz cont =
   | [] -> cont
   | [fvn] -> compile_fv_elem reloc fvn sz cont
   | fvn :: tl ->
-      compile_fv_elem reloc fvn sz 
+      compile_fv_elem reloc fvn sz
 	(Kpush :: compile_fv reloc tl (sz + 1) cont)
 
 (* compilation des constantes *)
@@ -474,14 +474,14 @@ let rec get_allias env kn =
   | BCallias kn' -> get_allias env kn'
   | _ -> kn
 
-  
+
 (* compilation des expressions *)
- 
+
 let rec compile_constr reloc c sz cont =
   match kind_of_term c with
   | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta")
   | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar")
- 
+
   | Cast(c,_,_) -> compile_constr reloc c sz cont
 
   | Rel i -> pos_rel i reloc sz :: cont
@@ -489,13 +489,13 @@ let rec compile_constr reloc c sz cont =
   | Const kn -> compile_const reloc kn [||] sz cont
   | Sort _  | Ind _ | Construct _ ->
       compile_str_cst reloc (str_const c) sz cont
-  
+
   | LetIn(_,xb,_,body) ->
-      compile_constr reloc xb sz 
-	(Kpush :: 
+      compile_constr reloc xb sz
+	(Kpush ::
 	(compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont)))
   | Prod(id,dom,codom) ->
-      let cont1 = 
+      let cont1 =
 	Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in
       compile_constr reloc (mkLambda(id,dom,codom)) sz cont1
   | Lambda _ ->
@@ -503,18 +503,18 @@ let rec compile_constr reloc c sz cont =
       let arity = List.length params in
       let r_fun = comp_env_fun arity in
       let lbl_fun = Label.create() in
-      let cont_fun = 
+      let cont_fun =
 	compile_constr r_fun body arity [Kreturn arity] in
       fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)];
       let fv = fv r_fun in
       compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont)
- 
-  | App(f,args) -> 
-      begin 
+
+  | App(f,args) ->
+      begin
 	match kind_of_term f with
 	| Construct _ -> compile_str_cst reloc (str_const c) sz cont
         | Const kn -> compile_const reloc kn args sz cont
-	| _ -> comp_app compile_constr compile_constr reloc f args sz cont 
+	| _ -> comp_app compile_constr compile_constr reloc f args sz cont
       end
   | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) ->
       let ndef = Array.length type_bodies in
@@ -524,10 +524,10 @@ let rec compile_constr reloc c sz cont =
       (* Compilation des types *)
       let env_type = comp_env_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 
-	lbl_types.(i) <- lbl; 
+	let lbl,fcode =
+	  label_code
+	    (compile_constr env_type type_bodies.(i) 0 [Kstop]) in
+	lbl_types.(i) <- lbl;
 	fun_code := [Ksequence(fcode,!fun_code)]
       done;
       (* Compilation des corps *)
@@ -535,7 +535,7 @@ let rec compile_constr reloc c sz cont =
 	let params,body = decompose_lam rec_bodies.(i) in
 	let arity = List.length params in
 	let env_body = comp_env_fix ndef i arity rfv in
-	let cont1 = 
+	let cont1 =
 	  compile_constr env_body body arity [Kreturn arity] in
 	let lbl = Label.create () in
 	lbl_bodies.(i) <- lbl;
@@ -543,9 +543,9 @@ let rec compile_constr reloc c sz cont =
 	fun_code := [Ksequence(fcode,!fun_code)]
       done;
       let fv = !rfv in
-      compile_fv reloc fv.fv_rev sz 
+      compile_fv reloc fv.fv_rev sz
 	(Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont)
-  
+
   | CoFix(init,(_,type_bodies,rec_bodies)) ->
       let ndef = Array.length type_bodies in
       let lbl_types = Array.create ndef Label.no in
@@ -554,10 +554,10 @@ let rec compile_constr reloc c sz cont =
       let rfv = ref empty_fv in
       let env_type = comp_env_type rfv in
       for i = 0 to ndef - 1 do
-	let lbl,fcode = 
-	  label_code 
+	let lbl,fcode =
+	  label_code
 	    (compile_constr env_type type_bodies.(i) 0 [Kstop]) in
-	lbl_types.(i) <- lbl; 
+	lbl_types.(i) <- lbl;
 	fun_code := [Ksequence(fcode,!fun_code)]
       done;
       (* Compilation des corps *)
@@ -566,17 +566,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 = 
+	let cont1 =
 	  compile_constr env_body body (arity+1) (cont_cofix arity) in
-	let cont2 = 
+	let cont2 =
 	  add_grab (arity+1) lbl cont1 in
 	lbl_bodies.(i) <- lbl;
 	fun_code := [Ksequence(cont2,!fun_code)];
       done;
       let fv = !rfv in
-      compile_fv reloc fv.fv_rev sz 
+      compile_fv reloc fv.fv_rev sz
 	(Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont)
-  
+
   | Case(ci,t,a,branchs) ->
       let ind = ci.ci_ind in
       let mib = lookup_mind (fst ind) !global_env in
@@ -586,20 +586,20 @@ let rec compile_constr reloc c sz cont =
       let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in
       let branch1,cont = make_branch cont in
       (* Compilation du type *)
-      let lbl_typ,fcode = 	
+      let lbl_typ,fcode =
 	label_code (compile_constr reloc t sz [Kpop sz; Kstop])
       in fun_code := [Ksequence(fcode,!fun_code)];
-      (* Compilation des branches *) 
+      (* Compilation des branches *)
       let lbl_sw = Label.create () in
       let sz_b,branch,is_tailcall =
-	match branch1 with 
+	match branch1 with
 	| Kreturn k -> assert (k = sz); sz, branch1, true
 	| _ -> sz+3, Kjump, false
       in
       let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
      (* Compilation de la branche accumulate *)
-      let lbl_accu, code_accu = 
-	label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) 
+      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
@@ -607,14 +607,14 @@ let rec compile_constr reloc c sz cont =
       for i = 0 to Array.length tbl - 1 do
 	let tag, arity = tbl.(i) in
 	if arity = 0 then
-	  let lbl_b,code_b = 
+	  let lbl_b,code_b =
 	    label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in
-	  lbl_consts.(tag) <- lbl_b; 
+	  lbl_consts.(tag) <- lbl_b;
 	  c := code_b
-	else 
+	else
 	  let args, body = decompose_lam branchs.(i) in
 	  let nargs = List.length args in
-	  let lbl_b,code_b = 
+	  let lbl_b,code_b =
 	    label_code(
 	    if nargs = arity then
 	      Kpushfields arity ::
@@ -622,7 +622,7 @@ let rec compile_constr reloc c sz cont =
 		body (sz_b+arity) (add_pop arity (branch :: !c))
 	    else
 	      let sz_appterm = if is_tailcall then sz_b + arity else arity in
-	      Kpushfields arity :: 
+	      Kpushfields arity ::
 	      compile_constr reloc branchs.(i) (sz_b+arity)
 		(Kappterm(arity,sz_appterm) :: !c))
 	  in
@@ -630,21 +630,21 @@ let rec compile_constr reloc c sz cont =
 	  c := code_b
       done;
       c :=  Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c;
-      let code_sw = 
- 	match branch1 with 
-        (* spiwack : branch1 can't be a lbl anymore it's a Branch instead 
+      let code_sw =
+ 	match branch1 with
+        (* spiwack : branch1 can't be a lbl anymore it's a Branch instead
 	| Klabel lbl -> Kpush_retaddr lbl ::  !c *)
         | Kbranch lbl -> Kpush_retaddr lbl ::  !c
-	| _ -> !c 
+	| _ -> !c
       in
-      compile_constr reloc a sz 
-      (try 
+      compile_constr reloc a sz
+      (try
 	let entry = Term.Ind ind in
 	Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge
 	                                       entry code_sw
       with Not_found ->
 	code_sw)
-       
+
 and compile_str_cst reloc sc sz cont =
   match sc with
   | Bconstr c -> compile_constr reloc c sz cont
@@ -655,25 +655,25 @@ and compile_str_cst reloc sc sz cont =
   | Bconstruct_app(tag,nparams,arity,args) ->
       if Array.length args = 0 then code_construct tag nparams arity cont
       else
-	comp_app 
-	  (fun _ _ _ cont -> code_construct tag nparams arity cont) 
+	comp_app
+	  (fun _ _ _ cont -> code_construct tag nparams arity cont)
 	  compile_str_cst reloc () args sz cont
   | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont
 
 
-(* spiwack : compilation of constants with their arguments. 
+(* spiwack : compilation of constants with their arguments.
    Makes a special treatment with 31-bit integer addition *)
 and compile_const =
-(*arnaud:  let code_construct kn cont = 
-     let f_cont = 
+(*arnaud:  let code_construct kn cont =
+     let f_cont =
          let else_lbl = Label.create () in
          Kareconst(2, else_lbl):: Kacc 0:: Kpop 1::
           Kaddint31:: Kreturn 0:: Klabel else_lbl::
          (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*)
           Kgetglobal (get_allias !global_env kn)::
           Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *)
-     in 
-     let lbl = Label.create () in 
+     in
+     let lbl = Label.create () in
      fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)];
      Kclosure(lbl, 0)::cont
   in *)
@@ -685,14 +685,14 @@ and compile_const =
   try
     Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge
                   (kind_of_term (mkConst kn)) reloc args sz cont
-  with Not_found -> 
+  with Not_found ->
     if nargs = 0 then
       Kgetglobal (get_allias !global_env kn) :: cont
     else
-      comp_app (fun _ _ _ cont -> 
+      comp_app (fun _ _ _ cont ->
                    Kgetglobal (get_allias !global_env kn) :: cont)
         compile_constr reloc () args sz cont
-      
+
 let compile env c =
   set_global_env env;
   init_fun_code ();
@@ -723,8 +723,11 @@ let compile_constant_body env body opaque boxed =
 	BCdefined(true, to_patch)
       else
 	match kind_of_term body with
-	| Const kn' -> BCallias (get_allias env kn')
-	| _ -> 
+	| Const kn' ->
+	    (* we use the canonical name of the constant*)
+	    let con= constant_of_kn (canonical_con kn') in
+	      BCallias (get_allias env con)
+	| _ ->
 	    let res = compile env body in
 	    let to_patch = to_memory res in
 	    BCdefined (false, to_patch)
@@ -743,9 +746,9 @@ let make_areconst n else_lbl cont =
 (* try to compile int31 as a const_b0. Succeed if all the arguments are closed
    fails otherwise by raising NotClosed*)
 let compile_structured_int31 fc args =
-  if not fc then raise Not_found else 
+  if not fc then raise Not_found else
   Const_b0
-    (Array.fold_left 
+    (Array.fold_left
        (fun temp_i -> fun t -> match kind_of_term t with
           | Construct (_,d) -> 2*temp_i+d-1
           | _ -> raise NotClosed)
@@ -753,7 +756,7 @@ let compile_structured_int31 fc args =
     )
 
 (* this function is used for the compilation of the constructor of
-   the int31, it is used when it appears not fully applied, or 
+   the int31, it is used when it appears not fully applied, or
    applied to at least one non-closed digit *)
 let dynamic_int31_compilation fc reloc args sz cont =
   if not fc then raise Not_found else
@@ -761,32 +764,32 @@ let dynamic_int31_compilation fc reloc args sz cont =
       if nargs = 31 then
 	let (escape,labeled_cont) = make_branch cont in
 	let else_lbl = Label.create() in
-	  comp_args compile_str_cst reloc args sz 
+	  comp_args compile_str_cst reloc args sz
             ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont)
-      else 
+      else
 	let code_construct cont = (* spiwack: variant of the global code_construct
-                                     which handles dynamic compilation of 
+                                     which handles dynamic compilation of
                                      integers *)
-          let f_cont = 
+          let f_cont =
             let else_lbl = Label.create () in
 	      [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl);
                Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0]
-	  in 
+	  in
 	  let lbl = Label.create() in
 	    fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)];
 	    Kclosure(lbl,0) :: cont
-	in 
+	in
 	  if nargs = 0 then
 	    code_construct cont
 	  else
 	    comp_app (fun _ _ _ cont -> code_construct cont)
               compile_str_cst reloc () args sz cont
-       
+
 (*(* template compilation for 2ary operation, it probably possible
    to make a generic such function with arity abstracted *)
 let op2_compilation op =
   let code_construct normal cont =  (*kn cont =*)
-     let f_cont = 
+     let f_cont =
          let else_lbl = Label.create () in
          Kareconst(2, else_lbl):: Kacc 0:: Kpop 1::
           op:: Kreturn 0:: Klabel else_lbl::
@@ -795,7 +798,7 @@ let op2_compilation op =
           normal::
           Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *)
      in
-     let lbl = Label.create () in 
+     let lbl = Label.create () in
      fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)];
      Kclosure(lbl, 0)::cont
   in
@@ -805,8 +808,8 @@ let op2_compilation op =
   if nargs=2 then (*if it is a fully applied addition*)
     let (escape, labeled_cont) = make_branch cont in
     let else_lbl = Label.create () in
-      comp_args compile_constr reloc args sz 
-	(Kisconst else_lbl::(make_areconst 1  else_lbl 
+      comp_args compile_constr reloc args sz
+	(Kisconst else_lbl::(make_areconst 1  else_lbl
            (*Kaddint31::escape::Klabel else_lbl::Kpush::*)
            (op::escape::Klabel else_lbl::Kpush::
            (* works as comp_app with nargs = 2 and non-tailcall cont*)
@@ -820,14 +823,14 @@ let op2_compilation op =
       compile_constr reloc () args sz cont *)
 
 (*template for n-ary operation, invariant: n>=1,
-  the operations does the following : 
-  1/ checks if all the arguments are constants (i.e. non-block values) 
+  the operations does the following :
+  1/ checks if all the arguments are constants (i.e. non-block values)
   2/ if they are, uses the "op" instruction to execute
-  3/ if at least one is not, branches to the normal behavior: 
+  3/ if at least one is not, branches to the normal behavior:
       Kgetglobal (get_allias !global_env kn) *)
 let op_compilation n op =
-  let code_construct kn cont = 
-     let f_cont = 
+  let code_construct kn cont =
+     let f_cont =
          let else_lbl = Label.create () in
          Kareconst(n, else_lbl):: Kacc 0:: Kpop 1::
           op:: Kreturn 0:: Klabel else_lbl::
@@ -835,7 +838,7 @@ let op_compilation n op =
           Kgetglobal (get_allias !global_env kn)::
           Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *)
      in
-     let lbl = Label.create () in 
+     let lbl = Label.create () in
      fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)];
      Kclosure(lbl, 0)::cont
   in
@@ -845,8 +848,8 @@ let op_compilation n op =
   if nargs=n then (*if it is a fully applied addition*)
     let (escape, labeled_cont) = make_branch cont in
     let else_lbl = Label.create () in
-      comp_args compile_constr reloc args sz 
-	(Kisconst else_lbl::(make_areconst (n-1) else_lbl 
+      comp_args compile_constr reloc args sz
+	(Kisconst else_lbl::(make_areconst (n-1) else_lbl
            (*Kaddint31::escape::Klabel else_lbl::Kpush::*)
            (op::escape::Klabel else_lbl::Kpush::
            (* works as comp_app with nargs = n and non-tailcall cont*)
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index dfdcb074..f33fd6cb 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -1,6 +1,6 @@
 open Names
 open Cbytecodes
-open Cemitcodes 
+open Cemitcodes
 open Term
 open Declarations
 open Pre_env
@@ -9,7 +9,7 @@ open Pre_env
 val compile : env -> constr -> bytecodes * bytecodes * fv
                               (* init, fun, fv *)
 
-val compile_constant_body : 
+val compile_constant_body :
     env -> constr_substituted option -> bool -> bool -> body_code
                                  (* opaque *) (* boxed *)
 
@@ -17,15 +17,15 @@ val compile_constant_body :
 (* spiwack: this function contains the information needed to perform
             the static compilation of int31 (trying and obtaining
             a 31-bit integer in processor representation at compile time) *)
-val compile_structured_int31 : bool -> constr array -> 
+val compile_structured_int31 : bool -> constr array ->
                                structured_constant
 
 (* this function contains the information needed to perform
         the dynamic compilation of int31 (trying and obtaining a
         31-bit integer in processor representation at runtime when
         it failed at compile time *)
-val dynamic_int31_compilation : bool -> comp_env -> 
-                                block array -> 
+val dynamic_int31_compilation : bool -> comp_env ->
+                                block array ->
                                 int -> bytecodes -> bytecodes
 
 (*spiwack: template for the compilation n-ary operation, invariant: n>=1.
@@ -35,6 +35,6 @@ val dynamic_int31_compilation : bool -> comp_env ->
 val op_compilation : int -> instruction -> constant -> bool -> comp_env ->
                              constr array -> int -> bytecodes-> bytecodes
 
-(*spiwack: compiling function to insert dynamic decompilation before 
+(*spiwack: compiling function to insert dynamic decompilation before
            matching integers (in case they are in processor representation) *)
 val int31_escape_before_match : bool -> bytecodes -> bytecodes
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 7617c454..4a9c7da2 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -6,11 +6,11 @@ open Mod_subst
 
 (* Relocation information *)
 type reloc_info =
-  | Reloc_annot of annot_switch 
+  | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
   | Reloc_getglobal of constant
 
-type patch = reloc_info * int 
+type patch = reloc_info * int
 
 let patch_int buff pos n =
   String.unsafe_set buff pos (Char.unsafe_chr n);
@@ -76,10 +76,10 @@ type label_definition =
   | Label_undefined of (int * int) list
 
 let label_table  = ref ([| |] : label_definition array)
-(* le ieme element de la table = Label_defined n signifie que l'on a 
+(* le ieme element de la table = Label_defined n signifie que l'on a
    deja rencontrer le label i et qu'il est a l'offset n.
-                               = Label_undefined l signifie que l'on a 
-   pas encore rencontrer ce label, le premier entier indique ou est l'entier 
+                               = Label_undefined l signifie que l'on a
+   pas encore rencontrer ce label, le premier entier indique ou est l'entier
    a patcher dans la string, le deuxieme son origine  *)
 
 let extend_label_table needed =
@@ -156,11 +156,11 @@ let emit_instr = function
       if ofs = -2 || ofs = 0 || ofs = 2
       then out (opOFFSETCLOSURE0 + ofs / 2)
       else (out opOFFSETCLOSURE; out_int ofs)
-  | Kpush ->      
+  | Kpush ->
       out opPUSH
-  | Kpop n ->      
+  | Kpop n ->
       out opPOP; out_int n
-  | Kpush_retaddr lbl -> 
+  | Kpush_retaddr lbl ->
       out opPUSH_RETADDR; out_label lbl
   | Kapply n ->
       if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
@@ -173,11 +173,11 @@ let emit_instr = function
       out opRETURN; out_int 0
   | Krestart ->
       out opRESTART
-  | Kgrab n -> 
+  | Kgrab n ->
       out opGRAB; out_int n
-  | Kgrabrec(rec_arg) -> 
+  | Kgrabrec(rec_arg) ->
       out opGRABREC; out_int rec_arg
-  | Kclosure(lbl, n) -> 
+  | Kclosure(lbl, n) ->
       out opCLOSURE; out_int n; out_label lbl
   | Kclosurerec(nfv,init,lbl_types,lbl_bodies) ->
       out opCLOSUREREC;out_int (Array.length lbl_bodies);
@@ -193,12 +193,12 @@ let emit_instr = function
       Array.iter (out_label_with_orig org) lbl_types;
       let org = !out_position in
       Array.iter (out_label_with_orig org) lbl_bodies
-  | Kgetglobal q -> 
+  | Kgetglobal q ->
       out opGETGLOBAL; slot_for_getglobal q
-  | Kconst((Const_b0 i)) -> 
+  | Kconst((Const_b0 i)) ->
       if i >= 0 && i <= 3
           then out (opCONST0 + i)
-          else (out opCONSTINT; out_int i) 
+          else (out opCONSTINT; out_int i)
   | Kconst c ->
       out opGETGLOBAL; slot_for_const c
   | Kmakeblock(n, t) ->
@@ -223,7 +223,7 @@ let emit_instr = function
       if n <= 1 then out (opGETFIELD0+n)
       else (out opGETFIELD;out_int n)
   | Ksetfield n ->
-      if n <= 1 then out (opSETFIELD0+n) 
+      if n <= 1 then out (opSETFIELD0+n)
       else (out opSETFIELD;out_int n)
   | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
   (* spiwack *)
@@ -247,7 +247,7 @@ let emit_instr = function
   | Kcompint31 -> out opCOMPINT31
   | Kdecompint31 -> out opDECOMPINT31
   (*/spiwack *)
-  | Kstop -> 
+  | Kstop ->
       out opSTOP
 
 (* Emission of a list of instructions. Include some peephole optimization. *)
@@ -258,26 +258,26 @@ let rec emit = function
   | Kpush :: Kacc n :: c ->
       if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
       emit c
-  | Kpush :: Kenvacc n :: c -> 
+  | Kpush :: Kenvacc n :: c ->
       if n >= 1 && n <= 4
       then out(opPUSHENVACC1 + n - 1)
       else (out opPUSHENVACC; out_int n);
       emit c
-  | Kpush :: Koffsetclosure ofs :: c -> 
+  | Kpush :: Koffsetclosure ofs :: c ->
       if ofs = -2 || ofs = 0 || ofs = 2
       then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
       else (out opPUSHOFFSETCLOSURE; out_int ofs);
       emit c
   | Kpush :: Kgetglobal id :: c ->
-      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c 
-  | Kpush :: Kconst (Const_b0 i) :: c -> 
+      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
+  | Kpush :: Kconst (Const_b0 i) :: c ->
       if i >= 0 && i <= 3
       then out (opPUSHCONST0 + i)
       else (out opPUSHCONSTINT; out_int i);
       emit c
   | Kpush :: Kconst const :: c ->
       out opPUSHGETGLOBAL; slot_for_const const;
-      emit c 
+      emit c
   | Kpop n :: Kjump :: c ->
       out opRETURN; out_int n; emit c
   | Ksequence(c1,c2)::c ->
@@ -304,18 +304,18 @@ let rec subst_strcst s sc =
   match sc with
   | Const_sorts _ | Const_b0 _ -> sc
   | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args)
-  | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i))
+  | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i))
 
-let subst_patch s (ri,pos) = 
+let subst_patch s (ri,pos) =
   match ri with
   | Reloc_annot a ->
       let (kn,i) = a.ci.ci_ind in
-      let ci = {a.ci with ci_ind = (subst_kn s kn,i)} in
+      let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in
       (Reloc_annot {a with ci = ci},pos)
   | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos)
   | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos)
 
-let subst_to_patch s (code,pl,fv) = 
+let subst_to_patch s (code,pl,fv) =
   code,List.rev_map (subst_patch s) pl,fv
 
 type body_code =
@@ -334,7 +334,7 @@ let from_val = from_val
 
 let force = force subst_body_code
 
-let subst_to_patch_subst = subst_substituted 
+let subst_to_patch_subst = subst_substituted
 
 let is_boxed tps =
   match force tps with
@@ -348,10 +348,10 @@ let to_memory (init_code, fun_code, fv) =
   let code = String.create !out_position in
   String.unsafe_blit !out_buffer 0 code 0 !out_position;
   let reloc = List.rev !reloc_info in
-  Array.iter (fun lbl -> 
+  Array.iter (fun lbl ->
     (match lbl with
       Label_defined _ -> assert true
-    | Label_undefined patchlist -> 
+    | Label_undefined patchlist ->
 	assert (patchlist = []))) !label_table;
   (code, reloc, fv)
 
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index ca6da65e..965228fa 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -2,17 +2,17 @@ open Names
 open Cbytecodes
 
 type reloc_info =
-  | Reloc_annot of annot_switch 
+  | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
   | Reloc_getglobal of constant
 
-type patch = reloc_info * int 
+type patch = reloc_info * int
 (* A virer *)
 val subst_patch : Mod_subst.substitution -> patch -> patch
- 
-type emitcodes 
 
-val length : emitcodes -> int 
+type emitcodes
+
+val length : emitcodes -> int
 
 val patch_int : emitcodes -> (*pos*)int -> int -> unit
 
@@ -26,9 +26,9 @@ type body_code =
   | BCconstant
 
 
-type to_patch_substituted 
+type to_patch_substituted
 
-val from_val : body_code -> to_patch_substituted 
+val from_val : body_code -> to_patch_substituted
 
 val force : to_patch_substituted -> body_code
 
@@ -37,4 +37,4 @@ val is_boxed : to_patch_substituted -> bool
 val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
 
 val to_memory : bytecodes * bytecodes * fv -> to_patch
-               (* init code, fun code, fv *) 
+               (* init code, fun code, fv *)
diff --git a/kernel/closure.ml b/kernel/closure.ml
index a184c128..93788ed4 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -40,7 +40,7 @@ let incr_cnt red cnt =
   if red then begin
     if !stats then incr cnt;
     true
-  end else 
+  end else
     false
 
 let with_stats c =
@@ -126,13 +126,13 @@ module RedFlags = (struct
 	{ red with r_const = Idpred.remove id l1, l2 }
 
   let red_add_transparent red tr =
-    { red with r_const = tr } 
+    { red with r_const = tr }
 
   let mkflags = List.fold_left red_add no_red
 
   let red_set red = function
     | BETA -> incr_cnt red.r_beta beta
-    | CONST kn -> 
+    | CONST kn ->
 	let (_,l) = red.r_const in
 	let c = Cpred.mem kn l in
 	incr_cnt c delta
@@ -168,7 +168,7 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
 (* 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_red kn = 
+let unfold_red kn =
   let flag = match kn with
     | EvalVarRef id -> fVAR id
     | EvalConstRef kn -> fCONST kn in
@@ -196,6 +196,8 @@ let unfold_red kn =
 
 type table_key = id_key
 
+let eq_table_key = Names.eq_id_key
+
 type 'a infos = {
   i_flags : reds;
   i_repr : 'a infos -> constr -> 'a;
@@ -208,7 +210,7 @@ type 'a infos = {
 let info_flags info = info.i_flags
 
 let ref_value_cache info ref =
-  try  
+  try
     Some (Hashtbl.find info.i_tab ref)
   with Not_found ->
   try
@@ -232,7 +234,7 @@ let evar_value info ev =
 
 let defined_vars flags env =
 (*  if red_local_const (snd flags) then*)
-    Sign.fold_named_context 
+    Sign.fold_named_context
       (fun (id,b,_) e ->
 	 match b with
 	   | None -> e
@@ -242,7 +244,7 @@ let defined_vars flags env =
 
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
-  Sign.fold_rel_context 
+  Sign.fold_rel_context
       (fun (id,b,t) (i,subs) ->
 	 match b with
 	   | None -> (i+1, subs)
@@ -250,18 +252,6 @@ let defined_rels flags env =
       (rel_context env) ~init:(0,[])
 (*  else (0,[])*)
 
-let rec mind_equiv env (kn1,i1) (kn2,i2) =
-  let rec equiv kn1 kn2 =
-    kn1 = kn2 ||
-      match (lookup_mind kn1 env).mind_equiv with
-	  Some kn1' -> equiv kn2 kn1'
-	| None -> match (lookup_mind kn2 env).mind_equiv with
-	      Some kn2' -> equiv kn2' kn1
-	    | None -> false in
-  i1 = i2 && equiv kn1 kn2
-
-let mind_equiv_infos info = mind_equiv info.i_env
-
 let create mk_cl flgs env evars =
   { i_flags = flgs;
     i_repr = mk_cl;
@@ -300,8 +290,8 @@ let neutr = function
   | (Whnf|Norm) -> Whnf
   | (Red|Cstr) -> Red
 
-type fconstr = { 
-  mutable norm: red_state; 
+type fconstr = {
+  mutable norm: red_state;
   mutable term: fterm }
 
 and fterm =
@@ -339,7 +329,7 @@ let update v1 (no,t) =
   else {norm=no;term=t}
 
 (**********************************************************************)
-(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *)
 
 type stack_member =
   | Zapp of fconstr array
@@ -379,9 +369,6 @@ let rec decomp_stack = function
         | _ ->
             Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s)))
   | _ -> None
-let rec decomp_stackn = function
-  | Zapp v :: s -> if Array.length v = 0 then decomp_stackn s else (v, s)
-  | _ -> assert false
 let array_of_stack s =
   let rec stackrec = function
   | [] -> []
@@ -390,7 +377,7 @@ let array_of_stack s =
   in Array.concat (stackrec s)
 let rec stack_assign s p c = match s with
   | Zapp args :: s ->
-      let q = Array.length args in 
+      let q = Array.length args in
       if p >= q then
 	Zapp args :: stack_assign s (p-q) c
       else
@@ -398,7 +385,7 @@ let rec stack_assign s p c = match s with
          nargs.(p) <- c;
          Zapp nargs :: s)
   | _ -> s
-let rec stack_tail p s = 
+let rec stack_tail p s =
   if p = 0 then s else
     match s with
       | Zapp args :: s ->
@@ -430,8 +417,6 @@ let lift_fconstr k f =
   if k=0 then f else lft_fconstr k f
 let lift_fconstr_vect k v =
   if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
-let lift_fconstr_list k l =
-  if k=0 then l else List.map (fun f -> lft_fconstr k f) l
 
 let clos_rel e i =
   match expand_rel i e with
@@ -664,7 +649,7 @@ let term_of_fconstr =
 
 (* fstrong applies unfreeze_fun recursively on the (freeze) term and
  * yields a term.  Assumes that the unfreeze_fun never returns a
- * FCLOS term. 
+ * FCLOS term.
 let rec fstrong unfreeze_fun lfts v =
   to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
 *)
@@ -741,12 +726,6 @@ let get_nth_arg head n stk =
 
 (* Beta reduction: look for an applied argument in the stack.
    Since the encountered update marks are removed, h must be a whnf *)
-let get_arg h stk =
-  let (depth,stk') = strip_update_shift h stk in
-  match  decomp_stack stk' with
-      Some (v, s') -> (Some (depth,v), s')
-    | None -> (None, zshift depth stk')
-
 let rec get_args n tys f e stk =
   match stk with
       Zupdate r :: s ->
@@ -863,7 +842,7 @@ let rec knr info m stk =
   | FLambda(n,tys,f,e) when red_set info.i_flags fBETA ->
       (match get_args n tys f e stk with
           Inl e', s -> knit info e' f s
-        | Inr lam, s -> (lam,s)) 
+        | Inr lam, s -> (lam,s))
   | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) ->
       (match ref_value_cache info (ConstKey kn) with
           Some v -> kni info v stk
@@ -942,7 +921,7 @@ let rec kl info m =
     zip_term (kl info) (norm_head info nm) s
 
 (* no redex: go up for atoms and already normalized terms, go down
-   otherwise. *) 
+   otherwise. *)
 and norm_head info m =
   if is_val m then (incr prune; term_of_fconstr m) else
     match m.term with
diff --git a/kernel/closure.mli b/kernel/closure.mli
index a80f7a62..5cb6fc97 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: closure.mli 11897 2009-02-09 19:28:02Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -24,7 +24,7 @@ val with_stats: 'a Lazy.t -> 'a
 
 (*s Delta implies all consts (both global (= by
   [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
-  Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+  Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
   a LetIn expression is Letin reduction *)
 
 
@@ -102,7 +102,7 @@ type fconstr
 type fterm =
   | FRel of int
   | FAtom of constr (* Metas and Sorts *)
-  | FCast of fconstr * cast_kind * fconstr 
+  | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
   | FInd of inductive
   | FConstruct of constructor
@@ -179,9 +179,7 @@ val whd_stack :
 (* [unfold_reference] unfolds references in a [fconstr] *)
 val unfold_reference : clos_infos -> table_key -> fconstr option
 
-(* [mind_equiv] checks whether two inductive types are intentionally equal *)
-val mind_equiv : env -> inductive -> inductive -> bool
-val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool
+val eq_table_key : table_key -> table_key -> bool
 
 (************************************************************************)
 (*i This is for lazy debug *)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 898a1ab3..0851c7a5 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: conv_oracle.ml 10961 2008-05-21 23:26:23Z barras $ *)
+(* $Id$ *)
 
 open Names
 
@@ -45,14 +45,6 @@ let set_strategy k l =
       else Cmap.add c l !cst_opacity
   | RelKey _ -> Util.error "set_strategy: RelKey"
 
-let set_transparent_const kn =
-  cst_opacity := Cmap.remove kn !cst_opacity
-let set_transparent_var id =
-  var_opacity := Idmap.remove id !var_opacity
-
-let set_opaque_const kn = set_strategy (ConstKey kn) Opaque
-let set_opaque_var id = set_strategy (VarKey id) Opaque
-
 let get_transp_state () =
   (Idmap.fold
     (fun id l ts -> if  l=Opaque then Idpred.remove id ts else ts)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 6a774b4b..86e108c6 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: conv_oracle.mli 10961 2008-05-21 23:26:23Z barras $ i*)
+(*i $Id$ i*)
 
 open Names
 
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index e5a97897..c971ed29 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.ml 10877 2008-04-30 21:58:41Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -19,19 +19,19 @@ open Reduction
 
 (*s Cooking the constants. *)
 
-type work_list = identifier array Cmap.t * identifier array KNmap.t
+type work_list = identifier array Cmap.t * identifier array Mindmap.t
 
-let dirpath_prefix p = match repr_dirpath p with
+let pop_dirpath p = match repr_dirpath p with
   | [] -> anomaly "dirpath_prefix: empty dirpath"
   | _::l -> make_dirpath l
 
-let pop_kn kn =
-  let (mp,dir,l) = Names.repr_kn kn in
-  Names.make_kn mp (dirpath_prefix dir) l
+let pop_mind kn =
+  let (mp,dir,l) = Names.repr_mind kn in
+  Names.make_mind mp (pop_dirpath dir) l
 
-let pop_con con = 
+let pop_con con =
   let (mp,dir,l) = Names.repr_con con in
-  Names.make_con mp (dirpath_prefix dir) l
+  Names.make_con mp (pop_dirpath dir) l
 
 type my_global_reference =
   | ConstRef of constant
@@ -47,10 +47,10 @@ let share r (cstl,knl) =
   with Not_found ->
   let f,l =
     match r with
-    | IndRef (kn,i) -> 
-	mkInd (pop_kn kn,i), KNmap.find kn knl
-    | ConstructRef ((kn,i),j) -> 
-	mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl
+    | IndRef (kn,i) ->
+	mkInd (pop_mind kn,i), Mindmap.find kn knl
+    | ConstructRef ((kn,i),j) ->
+	mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl
     | ConstRef cst ->
 	mkConst (pop_con cst), Cmap.find cst cstl in
   let c = mkApp (f, Array.map mkVar l) in
@@ -60,7 +60,7 @@ let share r (cstl,knl) =
 
 let update_case_info ci modlist =
   try
-    let ind, n = 
+    let ind, n =
       match kind_of_term (share (IndRef ci.ci_ind) modlist) with
       | App (f,l) -> (destInd f, Array.length l)
       | Ind ind -> ind, 0
@@ -69,7 +69,7 @@ let update_case_info ci modlist =
   with Not_found ->
     ci
 
-let empty_modlist = (Cmap.empty, KNmap.empty)
+let empty_modlist = (Cmap.empty, Mindmap.empty)
 
 let expmod_constr modlist c =
   let rec substrec c =
@@ -80,19 +80,19 @@ let expmod_constr modlist c =
       | Ind ind ->
 	  (try
 	    share (IndRef ind) modlist
-	   with 
+	   with
 	    | Not_found -> map_constr substrec c)
-	  
+
       | Construct cstr ->
 	  (try
 	    share (ConstructRef cstr) modlist
-	   with 
+	   with
 	    | Not_found -> map_constr substrec c)
-	  
+
       | Const cst ->
 	  (try
 	    share (ConstRef cst) modlist
-	   with 
+	   with
 	    | Not_found -> map_constr substrec c)
 
   | _ -> map_constr substrec c
@@ -112,7 +112,7 @@ type recipe = {
   d_abstract : named_context;
   d_modlist : work_list }
 
-let on_body f = 
+let on_body f =
   Option.map (fun c -> Declarations.from_val (f (Declarations.force c)))
 
 let cook_constant env r =
@@ -120,7 +120,7 @@ let cook_constant env r =
   let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
   let body =
     on_body (fun c ->
-      abstract_constant_body (expmod_constr r.d_modlist c) hyps) 
+      abstract_constant_body (expmod_constr r.d_modlist c) hyps)
       cb.const_body in
   let typ = match cb.const_type with
     | NonPolymorphicType t ->
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index 7596bce6..db35031d 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.mli 9795 2007-04-25 15:13:45Z soubiran $ i*)
+(*i $Id$ i*)
 
 open Names
 open Term
@@ -16,7 +16,7 @@ open Univ
 
 (*s Cooking the constants. *)
 
-type work_list = identifier array Cmap.t * identifier array KNmap.t
+type work_list = identifier array Cmap.t * identifier array Mindmap.t
 
 type recipe = {
   d_from : constant_body;
@@ -24,8 +24,8 @@ type recipe = {
   d_modlist : work_list }
 
 val cook_constant :
-  env -> recipe -> 
-    constr_substituted option * constant_type * constraints * bool * bool 
+  env -> recipe ->
+    constr_substituted option * constant_type * constraints * bool * bool
   * bool
 
 (*s Utility functions used in module [Discharge]. *)
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index d81b98ac..145ca27d 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -11,15 +11,15 @@ open Cbytegen
 external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
 external free_tcode : tcode -> unit = "coq_static_free"
 external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
- 
+
 (*******************)
 (* Linkage du code *)
 (*******************)
 
 (* Table des globaux *)
 
-(* [global_data] contient les valeurs des constantes globales 
-   (axiomes,definitions), les annotations des switch et les structured 
+(* [global_data] contient les valeurs des constantes globales
+   (axiomes,definitions), les annotations des switch et les structured
    constant *)
 external global_data : unit -> values array = "get_coq_global_data"
 
@@ -28,18 +28,18 @@ external realloc_global_data : int -> unit = "realloc_coq_global_data"
 
 let check_global_data n =
   if n >= Array.length (global_data()) then realloc_global_data n
-  
+
 let num_global = ref 0
 
-let set_global v = 
+let set_global v =
   let n = !num_global in
   check_global_data n;
   (global_data()).(n) <- v;
   incr num_global;
   n
 
-(* [global_transp],[global_boxed] contiennent les valeurs des 
-   definitions gelees. Les deux versions sont maintenues en //. 
+(* [global_transp],[global_boxed] contiennent les valeurs des
+   definitions gelees. Les deux versions sont maintenues en //.
    [global_transp] contient la version transparente.
    [global_boxed] contient la version gelees. *)
 
@@ -50,7 +50,7 @@ external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed"
 
 let check_global_boxed n =
   if n >= Array.length (global_boxed()) then realloc_global_boxed n
-  
+
 let num_boxed = ref 0
 
 let boxed_tbl = Hashtbl.create 53
@@ -59,7 +59,7 @@ let cst_opaque = ref Cpred.full
 
 let is_opaque kn = Cpred.mem kn !cst_opaque
 
-let set_global_boxed kn v = 
+let set_global_boxed kn v =
   let n = !num_boxed in
   check_global_boxed n;
   (global_boxed()).(n) <- (is_opaque kn);
@@ -91,18 +91,18 @@ let key rk =
 
 (* slot_for_*, calcul la valeur de l'objet, la place
    dans la table global, rend sa position dans la table *)
- 
+
 let slot_for_str_cst key =
-  try Hashtbl.find str_cst_tbl key 
-  with Not_found -> 
+  try Hashtbl.find str_cst_tbl key
+  with Not_found ->
     let n = set_global (val_of_str_const key) in
     Hashtbl.add str_cst_tbl key n;
     n
 
 let slot_for_annot key =
-  try Hashtbl.find annot_tbl key 
-  with Not_found -> 
-    let n =  set_global (Obj.magic key) in
+  try Hashtbl.find annot_tbl key
+  with Not_found ->
+    let n =  set_global (val_of_annot_switch key) in
     Hashtbl.add annot_tbl key n;
     n
 
@@ -112,25 +112,25 @@ let rec slot_for_getglobal env kn =
   with NotEvaluated ->
     let pos =
       match Cemitcodes.force cb.const_body_code with
-      | BCdefined(boxed,(code,pl,fv)) -> 
+      | BCdefined(boxed,(code,pl,fv)) ->
 	let v = eval_to_patch env (code,pl,fv) in
-  	if boxed then set_global_boxed kn v 
-	else set_global v 
-    | BCallias kn' -> slot_for_getglobal env kn' 
+  	if boxed then set_global_boxed kn v
+	else set_global v
+    | BCallias kn' -> slot_for_getglobal env kn'
     | BCconstant -> set_global (val_of_constant kn) in
     rk := Some pos;
     pos
 
 and slot_for_fv env fv =
   match fv with
-  | FVnamed id -> 
+  | FVnamed id ->
       let nv = Pre_env.lookup_named_val id env in
       begin
 	match !nv with
 	| VKvalue (v,_) -> v
-	| VKnone -> 
+	| VKnone ->
 	    let (_, b, _) = Sign.lookup_named id env.env_named_context in
-	    let v,d = 
+	    let v,d =
 	      match b with
 		| None -> (val_of_named id, Idset.empty)
 		| Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c)
@@ -142,43 +142,43 @@ and slot_for_fv env fv =
       begin
 	match !rv with
 	| VKvalue (v, _) -> v
-	| VKnone -> 
-	    let (_, b, _) = Sign.lookup_rel i env.env_rel_context in
+	| VKnone ->
+	    let (_, b, _) = lookup_rel i env.env_rel_context in
 	    let (v, d) =
-	      match b with 
+	      match b with
 		| None -> (val_of_rel i, Idset.empty)
 		| Some c -> let renv =  env_of_rel i env in
 			      (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c)
 	    in
 	      rv := VKvalue (v,d); v
       end
- 
-and eval_to_patch env (buff,pl,fv) = 
+
+and eval_to_patch env (buff,pl,fv) =
   let patch = function
     | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a)
     | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc)
-    | Reloc_getglobal kn, pos -> 
+    | Reloc_getglobal kn, pos ->
 	patch_int buff pos (slot_for_getglobal env kn)
-  in 
+  in
   List.iter patch pl;
-  let vm_env = Array.map (slot_for_fv env) fv 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 compile env c 
+and val_of_constr env c =
+  let (_,fun_code,_ as ccfv) =
+    try compile env c
     with e -> print_string "can not compile \n";Format.print_flush();raise e in
   eval_to_patch env (to_memory ccfv)
- 
+
 let set_transparent_const kn =
   cst_opaque := Cpred.remove kn !cst_opaque;
-  List.iter (fun n -> (global_boxed()).(n) <- false) 
+  List.iter (fun n -> (global_boxed()).(n) <- false)
     (Hashtbl.find_all boxed_tbl kn)
 
 let set_opaque_const kn =
   cst_opaque := Cpred.add kn !cst_opaque;
-  List.iter (fun n -> (global_boxed()).(n) <- true) 
+  List.iter (fun n -> (global_boxed()).(n) <- true)
     (Hashtbl.find_all boxed_tbl kn)
 
 
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 2640a4df..894a33ef 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.mli
@@ -2,7 +2,7 @@ open Names
 open Term
 open Pre_env
 
-val val_of_constr : env -> constr -> values 
+val val_of_constr : env -> constr -> values
 
 val set_opaque_const      : constant -> unit
 val set_transparent_const : constant -> unit
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index f4827029..51500979 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.ml 11417 2008-09-17 15:06:57Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -38,7 +38,7 @@ type constr_substituted = constr substituted
 
 let from_val = from_val
 
-let force = force subst_mps 
+let force = force subst_mps
 
 let subst_constr_subst = subst_substituted
 
@@ -49,7 +49,7 @@ type constant_body = {
     const_body_code : Cemitcodes.to_patch_substituted;
    (* const_type_code : Cemitcodes.to_patch; *)
     const_constraints : constraints;
-    const_opaque : bool; 
+    const_opaque : bool;
     const_inline : bool}
 
 (*s Inductive types (internal representation with redundant
@@ -62,14 +62,14 @@ let subst_rel_declaration sub (id,copt,t as x) =
 
 let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
 
-type recarg = 
-  | Norec 
-  | Mrec of int 
+type recarg =
+  | Norec
+  | Mrec of int
   | Imbr of inductive
 
 let subst_recarg sub r = match r with
   | Norec | Mrec _  -> r
-  | Imbr (kn,i) -> let kn' = subst_kn sub kn in
+  | Imbr (kn,i) -> let kn' = subst_ind sub kn in
       if kn==kn' then r else Imbr (kn',i)
 
 type wf_paths = recarg Rtree.t
@@ -86,7 +86,7 @@ let dest_subterms p =
   let (_,cstrs) = Rtree.dest_node p in
   Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
 
-let recarg_length p j = 
+let recarg_length p j =
   let (_,cstrs) = Rtree.dest_node p in
   Array.length (snd (Rtree.dest_node cstrs.(j-1)))
 
@@ -105,7 +105,7 @@ type monomorphic_inductive_arity = {
   mind_sort : sorts;
 }
 
-type inductive_arity = 
+type inductive_arity =
 | Monomorphic of monomorphic_inductive_arity
 | Polymorphic of polymorphic_arity
 
@@ -135,6 +135,9 @@ type one_inductive_body = {
  (* Number of expected real arguments of the type (no let, no params) *)
     mind_nrealargs : int;
 
+ (* Length of realargs context (with let, no params) *)
+    mind_nrealargs_ctxt : int;
+
  (* List of allowed elimination sorts *)
     mind_kelim : sorts_family list;
 
@@ -155,7 +158,7 @@ type one_inductive_body = {
  (* number of no constant constructor *)
     mind_nb_args : int;
 
-    mind_reloc_tbl :  Cbytecodes.reloc_table; 
+    mind_reloc_tbl :  Cbytecodes.reloc_table;
   }
 
 type mutual_inductive_body = {
@@ -187,25 +190,25 @@ type mutual_inductive_body = {
   (* Universes constraints enforced by the inductive declaration *)
     mind_constraints : constraints;
 
-  (* Source of the inductive block when aliased in a module *)
-    mind_equiv : kernel_name option
   }
 
-let subst_arity sub = function
-| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
-| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
-
+let subst_arity sub arity =
+  if sub = empty_subst then arity
+  else match arity with
+    | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
+    | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
+	
 (* TODO: should be changed to non-coping after Term.subst_mps *)
 let subst_const_body sub cb = {
-    const_hyps = (assert (cb.const_hyps=[]); []);
-    const_body = Option.map (subst_constr_subst sub) cb.const_body;
-    const_type = subst_arity sub cb.const_type;
-    const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
-    (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
-    const_constraints = cb.const_constraints;
-    const_opaque = cb.const_opaque;
-    const_inline = cb.const_inline} 
-
+  const_hyps = (assert (cb.const_hyps=[]); []);
+  const_body = Option.map (subst_constr_subst sub) cb.const_body;
+  const_type = subst_arity sub cb.const_type;
+  const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+  (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
+  const_constraints = cb.const_constraints;
+  const_opaque = cb.const_opaque;
+  const_inline = cb.const_inline} 
+  
 let subst_arity sub = function
 | Monomorphic s ->
     Monomorphic {
@@ -214,7 +217,7 @@ let subst_arity sub = function
     }
 | Polymorphic s as x -> x
 
-let subst_mind_packet sub mbp = 
+let subst_mind_packet sub mbp =
   { mind_consnames = mbp.mind_consnames;
     mind_consnrealdecls = mbp.mind_consnrealdecls;
     mind_typename = mbp.mind_typename;
@@ -223,61 +226,61 @@ let subst_mind_packet sub mbp =
     mind_arity = subst_arity sub mbp.mind_arity;
     mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
+    mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
     mind_kelim = mbp.mind_kelim;
-    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); 
+    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
     mind_nb_constant = mbp.mind_nb_constant;
     mind_nb_args = mbp.mind_nb_args;
     mind_reloc_tbl = mbp.mind_reloc_tbl }
 
 
-let subst_mind sub mib = 
-  { mind_record = mib.mind_record ; 
+let subst_mind sub mib =
+  { mind_record = mib.mind_record ;
     mind_finite = mib.mind_finite ;
     mind_ntypes = mib.mind_ntypes ;
     mind_hyps = (assert (mib.mind_hyps=[]); []) ;
     mind_nparams = mib.mind_nparams;
     mind_nparams_rec = mib.mind_nparams_rec;
-    mind_params_ctxt = 
+    mind_params_ctxt =
       map_rel_context (subst_mps sub) mib.mind_params_ctxt;
     mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
-    mind_constraints = mib.mind_constraints ;
-    mind_equiv = Option.map (subst_kn sub) mib.mind_equiv }
+    mind_constraints = mib.mind_constraints  }
 
 
 (*s Modules: signature component specifications, module types, and
   module declarations *)
 
-type structure_field_body = 
+type structure_field_body =
   | SFBconst of constant_body
   | SFBmind of mutual_inductive_body
   | SFBmodule of module_body
-  | SFBalias of module_path * struct_expr_body option 
-      * constraints option
   | SFBmodtype of module_type_body
 
 and structure_body = (label * structure_field_body) list
 
 and struct_expr_body =
   | SEBident of module_path
-  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
-  | SEBstruct of mod_self_id * structure_body
-  | SEBapply of struct_expr_body * struct_expr_body
-      * constraints
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body
+  | SEBapply of struct_expr_body * struct_expr_body * constraints
+  | SEBstruct of structure_body
   | SEBwith of struct_expr_body * with_declaration_body
 
 and with_declaration_body =
-    With_module_body of identifier list * module_path 
-      * struct_expr_body option  * constraints
+    With_module_body of identifier list * module_path
   | With_definition_body of  identifier list * constant_body
-        
-and module_body = 
-    { mod_expr : struct_expr_body option;
-      mod_type : struct_expr_body option;
+
+and module_body =
+    { mod_mp : module_path;
+      mod_expr : struct_expr_body option; 
+      mod_type : struct_expr_body;
+      mod_type_alg : struct_expr_body option;
       mod_constraints : constraints;
-      mod_alias : substitution;
+      mod_delta : delta_resolver;
       mod_retroknowledge : Retroknowledge.action list}
 
-and module_type_body = 
-    { typ_expr : struct_expr_body;
-      typ_strength : module_path option;
-      typ_alias : substitution}
+and module_type_body =
+    { typ_mp : module_path;
+      typ_expr : struct_expr_body;
+      typ_expr_alg : struct_expr_body option ;
+      typ_constraints : constraints;
+      typ_delta :delta_resolver}
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index b4f5f1f7..adf1d14e 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.mli 11417 2008-09-17 15:06:57Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -55,9 +55,9 @@ val subst_const_body : substitution -> constant_body -> constant_body
 (**********************************************************************)
 (*s Representation of mutual inductive types in the kernel            *)
 
-type recarg = 
-  | Norec 
-  | Mrec of int 
+type recarg =
+  | Norec
+  | Mrec of int
   | Imbr of inductive
 
 val subst_recarg : substitution -> recarg -> recarg
@@ -85,7 +85,7 @@ type monomorphic_inductive_arity = {
   mind_sort : sorts;
 }
 
-type inductive_arity = 
+type inductive_arity =
 | Monomorphic of monomorphic_inductive_arity
 | Polymorphic of polymorphic_arity
 
@@ -115,13 +115,17 @@ type one_inductive_body = {
  (* Number of expected real arguments of the type (no let, no params) *)
     mind_nrealargs : int;
 
+ (* Length of realargs context (with let, no params) *)
+    mind_nrealargs_ctxt : int;
+
  (* List of allowed elimination sorts *)
     mind_kelim : sorts_family list;
 
  (* Head normalized constructor types so that their conclusion is atomic *)
     mind_nf_lc : types array;
 
- (* Length of the signature of the constructors (with let, w/o params) *)
+ (* Length of the signature of the constructors (with let, w/o params)
+    (not used in the kernel) *)
     mind_consnrealdecls : int array;
 
  (* Signature of recursive arguments in the constructors *)
@@ -135,7 +139,7 @@ type one_inductive_body = {
  (* number of no constant constructor *)
     mind_nb_args : int;
 
-    mind_reloc_tbl :  Cbytecodes.reloc_table; 
+    mind_reloc_tbl :  Cbytecodes.reloc_table;
   }
 
 type mutual_inductive_body = {
@@ -167,8 +171,6 @@ type mutual_inductive_body = {
   (* Universes constraints enforced by the inductive declaration *)
     mind_constraints : constraints;
 
-  (* Source of the inductive block when aliased in a module *)
-    mind_equiv : kernel_name option
   }
 
 val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
@@ -177,37 +179,49 @@ val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
 (*s Modules: signature component specifications, module types, and
   module declarations *)
 
-type structure_field_body = 
+type structure_field_body =
   | SFBconst of constant_body
   | SFBmind of mutual_inductive_body
   | SFBmodule of module_body
-  | SFBalias of module_path * struct_expr_body option
-      *constraints option
   | SFBmodtype of module_type_body
 
 and structure_body = (label * structure_field_body) list
 
 and struct_expr_body =
   | SEBident of module_path
-  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body 
-  | SEBstruct of mod_self_id * structure_body
-  | SEBapply of struct_expr_body * struct_expr_body
-      * constraints
+  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body
+  | SEBapply of struct_expr_body * struct_expr_body * constraints
+  | SEBstruct of structure_body
   | SEBwith of struct_expr_body * with_declaration_body
 
 and with_declaration_body =
-    With_module_body of identifier list * module_path 
-      * struct_expr_body option * constraints
+    With_module_body of identifier list * module_path
   | With_definition_body of  identifier list * constant_body
-        
-and module_body = 
-    { mod_expr : struct_expr_body option;
-      mod_type : struct_expr_body option;
+
+and module_body =
+    {  (*absolute path of the module*)
+      mod_mp : module_path;
+      (* Implementation *)
+      mod_expr : struct_expr_body option; 
+      (* Signature *)
+      mod_type : struct_expr_body;
+      (* algebraic structure expression is kept 
+	 if it's relevant for extraction  *)
+      mod_type_alg : struct_expr_body option; 
+      (* set of all constraint in the module  *)
       mod_constraints : constraints;
-      mod_alias : substitution;
+      (* quotiented set of equivalent constant and inductive name  *)
+      mod_delta : delta_resolver;
       mod_retroknowledge : Retroknowledge.action list}
-
-and module_type_body = 
-    { typ_expr : struct_expr_body;
-      typ_strength : module_path option;
-      typ_alias : substitution}
+      
+and module_type_body =
+    { 
+      (*Path of the module type*)
+      typ_mp : module_path;
+      typ_expr : struct_expr_body;
+      (* algebraic structure expression is kept 
+	 if it's relevant for extraction  *)
+      typ_expr_alg : struct_expr_body option ;
+      typ_constraints : constraints;
+      (* quotiented set of equivalent constant and inductive name  *)
+      typ_delta :delta_resolver}
diff --git a/kernel/entries.ml b/kernel/entries.ml
index b6b09c64..938d1c60 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.ml 10664 2008-03-14 11:27:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -62,34 +62,33 @@ type definition_entry = {
   const_entry_opaque : bool;
   const_entry_boxed  : bool}
 
-type parameter_entry = types*bool
+(* type and the inlining flag *)
+type parameter_entry = types * bool
 
-type constant_entry = 
+type constant_entry =
   | DefinitionEntry of definition_entry
   | ParameterEntry of parameter_entry
 
 (*s Modules *)
 
+
 type specification_entry = 
     SPEconst of constant_entry
   | SPEmind of mutual_inductive_entry
   | SPEmodule of module_entry
-  | SPEalias of module_path
   | SPEmodtype of module_struct_entry
-
+      
 and module_struct_entry = 
     MSEident of module_path
   | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
   | MSEwith of module_struct_entry * with_declaration
   | MSEapply of module_struct_entry * module_struct_entry
 
-and with_declaration = 
+and with_declaration =
     With_Module of identifier list * module_path
   | With_Definition of identifier list * constr
 
-and module_structure = (label * specification_entry) list
-
-and module_entry = 
+and module_entry =
     { mod_entry_type : module_struct_entry option;
       mod_entry_expr : module_struct_entry option}
 
diff --git a/kernel/entries.mli b/kernel/entries.mli
index ed315ab8..20fbbb8e 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -61,34 +61,32 @@ type definition_entry = {
   const_entry_opaque : bool;
   const_entry_boxed  : bool }
 
-type parameter_entry = types*bool  (*inline flag*)
+type parameter_entry = types * bool  (*inline flag*)
 
-type constant_entry = 
+type constant_entry =
   | DefinitionEntry of definition_entry
   | ParameterEntry of parameter_entry
 
 (*s Modules *)
 
+
 type specification_entry = 
     SPEconst of constant_entry
   | SPEmind of mutual_inductive_entry
   | SPEmodule of module_entry
-  | SPEalias of module_path
   | SPEmodtype of module_struct_entry
 
-and module_struct_entry = 
+and module_struct_entry =
     MSEident of module_path
   | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
   | MSEwith of module_struct_entry * with_declaration
   | MSEapply of module_struct_entry * module_struct_entry
 
-and with_declaration = 
+and with_declaration =
     With_Module of identifier list * module_path
   | With_Definition of identifier list * constr
 
-and module_structure = (label * specification_entry) list
-
-and module_entry = 
+and module_entry =
     { mod_entry_type : module_struct_entry option;
       mod_entry_expr : module_struct_entry option}
 
diff --git a/kernel/environ.ml b/kernel/environ.ml
index cd4efe27..8f6a619a 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: environ.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -35,49 +35,40 @@ let named_context env = env.env_named_context
 let named_context_val env = env.env_named_context,env.env_named_vals
 let rel_context env = env.env_rel_context
 
-let empty_context env = 
-  env.env_rel_context = empty_rel_context 
+let empty_context env =
+  env.env_rel_context = empty_rel_context
   && env.env_named_context = empty_named_context
 
 (* Rel context *)
 let lookup_rel n env =
-  Sign.lookup_rel n env.env_rel_context
+  lookup_rel n env.env_rel_context
 
 let evaluable_rel n env =
-  try
-    match lookup_rel n env with
-        (_,Some _,_) -> true
-      | _ -> false
-  with Not_found -> 
-    false
+  match lookup_rel n env with
+  | (_,Some _,_) -> true
+  | _ -> false
 
 let nb_rel env = env.env_nb_rel
 
 let push_rel = push_rel
 
 let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x
-    
+
 let push_rec_types (lna,typarray,_) env =
   let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
-    
-let reset_rel_context env =
-  { env with
-    env_rel_context = empty_rel_context;
-    env_rel_val = [];
-    env_nb_rel = 0 }
 
 let fold_rel_context f env ~init =
   let rec fold_right env =
     match env.env_rel_context with
     | [] -> init
     | rd::rc ->
-	let env = 
+	let env =
 	  { env with
 	    env_rel_context = rc;
 	    env_rel_val = List.tl env.env_rel_val;
 	    env_nb_rel = env.env_nb_rel - 1 } in
-	f env rd (fold_right env) 
+	f env rd (fold_right env)
   in fold_right env
 
 (* Named context *)
@@ -87,13 +78,13 @@ let named_vals_of_val = snd
 
 (* [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) = 
+   *** /!\ ***   [f t] should be convertible with t *)
+let map_named_val f (ctxt,ctxtv) =
   let ctxt =
     List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in
   (ctxt,ctxtv)
 
-let empty_named_context = empty_named_context 
+let empty_named_context = empty_named_context
 
 let push_named = push_named
 let push_named_context_val = push_named_context_val
@@ -117,12 +108,10 @@ let named_body id env =
   let (_,b,_) = lookup_named id env in b
 
 let evaluable_named id env =
-  try 
-    match named_body id env with
-    |Some _      -> true
-    | _          -> false
-  with Not_found -> false
-      
+  match named_body id env with
+  | Some _      -> true
+  | _          -> false
+
 let reset_with_named_context (ctxt,ctxtv) env =
   { env with
     env_named_context = ctxt;
@@ -132,36 +121,36 @@ let reset_with_named_context (ctxt,ctxtv) env =
     env_nb_rel = 0 }
 
 let reset_context = reset_with_named_context empty_named_context_val
- 
+
 let fold_named_context f env ~init =
   let rec fold_right env =
     match env.env_named_context with
     | [] -> init
     | d::ctxt ->
-	let env = 
+	let env =
 	  reset_with_named_context (ctxt,List.tl env.env_named_vals) env in
-	f env d (fold_right env) 
+	f env d (fold_right env)
   in fold_right env
 
 let fold_named_context_reverse f ~init env =
   Sign.fold_named_context_reverse f ~init:init (named_context env)
- 
+
 (* Global constants *)
 
 let lookup_constant = lookup_constant
 
 let add_constant kn cs env =
-  let new_constants = 
-    Cmap.add kn (cs,ref None) env.env_globals.env_constants in
-  let new_globals = 
-    { env.env_globals with 
-	env_constants = new_constants } in 
+  let new_constants =
+    Cmap_env.add kn (cs,ref None) env.env_globals.env_constants in
+  let new_globals =
+    { env.env_globals with
+	env_constants = new_constants } in
   { env with env_globals = new_globals }
 
 (* constant_type gives the type of a constant *)
 let constant_type env kn =
   let cb = lookup_constant kn env in
-    cb.const_type  
+    cb.const_type
 
 type const_evaluation_result = NoBody | Opaque
 
@@ -181,17 +170,15 @@ let constant_opt_value env cst =
 (* A global const is evaluable if it is defined and not opaque *)
 let evaluable_constant cst env =
   try let _  = constant_value env cst in true
-  with Not_found | NotEvaluableConst _ -> false
+  with NotEvaluableConst _ -> false
 
 (* Mutual Inductives *)
 let lookup_mind = lookup_mind
-let scrape_mind = scrape_mind
-
-
+  
 let add_mind kn mib env =
-  let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
-  let new_globals = 
-    { env.env_globals with 
+  let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in
+  let new_globals =
+    { env.env_globals with
 	env_inductives = new_inds } in
   { env with env_globals = new_globals }
 
@@ -199,15 +186,15 @@ let add_mind kn mib env =
 let set_universes g env =
   if env.env_stratification.env_universes == g then env
   else
-    { env with env_stratification = 
+    { env with env_stratification =
       { env.env_stratification with env_universes = g } }
 
 let add_constraints c env =
-  if c == Constraint.empty then 
-    env 
+  if c == Constraint.empty then
+    env
   else
     let s = env.env_stratification in
-    { env with env_stratification = 
+    { env with env_stratification =
       { s with env_universes = merge_constraints c s.env_universes } }
 
 let set_engagement c env = (* Unsafe *)
@@ -234,19 +221,23 @@ let vars_of_global env constr =
     | Const kn -> lookup_constant_variables kn env
     | Ind ind -> lookup_inductive_variables ind env
     | Construct cstr -> lookup_constructor_variables cstr env
-    | _ -> []
+    | _ -> raise Not_found
 
-let global_vars_set env constr = 
+let global_vars_set env constr =
   let rec filtrec acc c =
-    let vl = vars_of_global env c in
-    let acc = List.fold_right Idset.add vl acc in
-      fold_constr filtrec acc c
-  in 
+    let acc =
+      match kind_of_term c with
+      | Var _ | Const _ | Ind _ | Construct _ ->
+	  List.fold_right Idset.add (vars_of_global env c) acc
+      | _ ->
+	  acc in
+    fold_constr filtrec acc c
+  in
     filtrec Idset.empty constr
 
 
-(* [keep_hyps env ids] keeps the part of the section context of [env] which 
-   contains the variables of the set [ids], and recursively the variables 
+(* [keep_hyps env ids] keeps the part of the section context of [env] which
+   contains the variables of the set [ids], and recursively the variables
    contained in the types of the needed variables. *)
 
 let keep_hyps env needed =
@@ -254,12 +245,12 @@ let keep_hyps env needed =
     Sign.fold_named_context_reverse
       (fun need (id,copt,t) ->
         if Idset.mem id need then
-          let globc = 
+          let globc =
 	    match copt with
 	      | None -> Idset.empty
 	      | Some c -> global_vars_set env c in
 	  Idset.union
-            (global_vars_set env t) 
+            (global_vars_set env t)
 	    (Idset.union globc need)
         else need)
       ~init:needed
@@ -273,48 +264,30 @@ let keep_hyps env needed =
 
 (* Modules *)
 
-let add_modtype ln mtb env = 
+let add_modtype ln mtb env =
   let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
-  let new_globals = 
-    { env.env_globals with 
+  let new_globals =
+    { env.env_globals with
 	env_modtypes = new_modtypes } in
   { env with env_globals = new_globals }
 
-let shallow_add_module mp mb env = 
+let shallow_add_module mp mb env =
   let new_mods = MPmap.add mp mb env.env_globals.env_modules in
-  let new_globals = 
-    { env.env_globals with 
+  let new_globals =
+    { env.env_globals with
 	env_modules = new_mods } in
   { env with env_globals = new_globals }
 
-let rec scrape_alias mp env = 
-  try
-    let mp1 = MPmap.find mp env.env_globals.env_alias in
-      scrape_alias mp1 env
-  with
-      Not_found -> mp
-
-let lookup_module mp env = 
-  let mp = scrape_alias mp env in
+let lookup_module mp env =
     MPmap.find mp env.env_globals.env_modules
 
-let lookup_modtype ln env = 
-  let mp = scrape_alias ln env in
-  MPmap.find mp env.env_globals.env_modtypes
 
-let register_alias mp1 mp2 env =
-  let new_alias =  MPmap.add mp1 mp2 env.env_globals.env_alias in
-  let new_globals = 
-    { env.env_globals with 
-	env_alias = new_alias } in
-    { env with env_globals = new_globals }
-
-let lookup_alias mp env =
-  MPmap.find mp env.env_globals.env_alias
+let lookup_modtype mp env = 
+  MPmap.find mp env.env_globals.env_modtypes
 
 (*s Judgments. *)
-	
-type unsafe_judgment = { 
+
+type unsafe_judgment = {
   uj_val : constr;
   uj_type : types }
 
@@ -325,13 +298,13 @@ let make_judge v tj =
 let j_val j = j.uj_val
 let j_type j = j.uj_type
 
-type unsafe_type_judgment = { 
+type unsafe_type_judgment = {
   utj_val : constr;
   utj_type : sorts }
 
 (*s Compilation of global declaration *)
 
-let compile_constant_body = Cbytegen.compile_constant_body  
+let compile_constant_body = Cbytegen.compile_constant_body
 
 exception Hyp_not_found
 
@@ -341,7 +314,7 @@ let rec apply_to_hyp (ctxt,vals) id f =
     | (idc,c,ct as d)::ctxt, v::vals ->
 	if idc = id then
 	  (f ctxt d rtail)::ctxt, v::vals
-	else 
+	else
 	  let ctxt',vals' = aux (d::rtail) ctxt vals in
 	  d::ctxt', v::vals'
     | [],[] -> raise Hyp_not_found
@@ -354,8 +327,8 @@ let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
     | (idc,c,ct as d)::ctxt, v::vals ->
 	if idc = id then
 	  let sign = ctxt,vals in
-	  push_named_context_val (f d sign) sign 
-	else 
+	  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
@@ -367,9 +340,9 @@ let insert_after_hyp (ctxt,vals) id d check =
     match  ctxt, vals with
     | (idc,c,ct)::ctxt', v::vals' ->
 	if idc = id then begin
-	  check ctxt; 
-	  push_named_context_val d (ctxt,vals) 
-	end else 
+	  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
@@ -380,9 +353,9 @@ let insert_after_hyp (ctxt,vals) id d check =
 (* To be used in Logic.clear_hyps *)
 let remove_hyps ids check_context check_value (ctxt, vals) =
   List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) ->
-      if List.mem id ids then 
+      if List.mem id ids then
 	(ctxt,vals)
-      else 	  
+      else
 	let nd = check_context d in
 	let nv = check_value v in
 	  (nd::ctxt,(id',nv)::vals))
@@ -413,25 +386,25 @@ let registered env field =
    unregister function *)
 let unregister env field =
   match field with
-    | KInt31 (_,Int31Type) -> 
+    | KInt31 (_,Int31Type) ->
 	(*there is only one matching kind due to the fact that Environ.env
           is abstract, and that the only function which add elements to the
           retroknowledge is Environ.register which enforces this shape *)
-	(match retroknowledge find env field with 
+	(match retroknowledge find env field with
 	   | Ind i31t -> let i31c = Construct (i31t, 1) in
-	     {env with retroknowledge = 
+	     {env with retroknowledge =
 		 remove (retroknowledge clear_info env i31c) field}
 	   | _ -> assert false)
     |_ -> {env with retroknowledge =
-	   try 
-	     remove (retroknowledge clear_info env 
+	   try
+	     remove (retroknowledge clear_info env
                        (retroknowledge find env field)) field
 	   with Not_found ->
 	     retroknowledge remove env field}
 
 
 
-(* the Environ.register function syncrhonizes the proactive and reactive 
+(* the Environ.register function syncrhonizes the proactive and reactive
    retroknowledge. *)
 let register =
 
@@ -439,7 +412,7 @@ let register =
      see pretyping/vnorm.ml for more information) *)
   let constr_of_int31 =
     let nth_digit_plus_one i n = (* calculates the nth (starting with 0)
-                                    digit of i and adds 1 to it 
+                                    digit of i and adds 1 to it
                                     (nth_digit_plus_one 1 3 = 2) *)
       if (land) i ((lsl) 1 n) = 0 then
         1
@@ -456,8 +429,8 @@ let register =
 
   (* subfunction which adds the information bound to the constructor of
      the int31 type to the reactive retroknowledge *)
-  let add_int31c retroknowledge c = 
-    let rk = add_vm_constant_static_info retroknowledge c 
+  let add_int31c retroknowledge c =
+    let rk = add_vm_constant_static_info retroknowledge c
                                          Cbytegen.compile_structured_int31
     in
     add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation
@@ -475,7 +448,7 @@ fun env field value ->
      operators to the reactive retroknowledge. *)
   let add_int31_binop_from_const op =
     match value with
-      | Const kn ->  retroknowledge add_int31_op env value 2 
+      | Const kn ->  retroknowledge add_int31_op env value 2
 	                               op kn
       | _ -> anomaly "Environ.register: should be a constant"
   in
@@ -487,66 +460,66 @@ fun env field value ->
   in
   (* subfunction which completes the function constr_of_int31 above
      by performing the actual retroknowledge operations *)
-  let add_int31_decompilation_from_type rk = 
-    (* invariant : the type of bits is registered, otherwise the function 
+  let add_int31_decompilation_from_type rk =
+    (* invariant : the type of bits is registered, otherwise the function
        would raise Not_found. The invariant is enforced in safe_typing.ml *)
     match field with
-      | KInt31 (grp, Int31Type) -> 
+      | KInt31 (grp, Int31Type) ->
 	  (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with
-	    | Ind i31bit_type ->  
-		(match value with 
-		  | Ind i31t -> 
+	    | Ind i31bit_type ->
+		(match value with
+		  | Ind i31t ->
 		      Retroknowledge.add_vm_decompile_constant_info rk
 		               value (constr_of_int31 i31t i31bit_type)
 		  | _ -> anomaly "Environ.register: should be an inductive type")
 	    | _ -> anomaly "Environ.register: Int31Bits should be an inductive type")
       | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field"
   in
-  {env with retroknowledge = 
-  let retroknowledge_with_reactive_info = 
+  {env with retroknowledge =
+  let retroknowledge_with_reactive_info =
   match field with
-    | KInt31 (_, Int31Type) -> 
+    | KInt31 (_, Int31Type) ->
         let i31c = match value with
                      | Ind i31t -> (Construct (i31t, 1))
 		     | _ -> anomaly "Environ.register: should be an inductive type"
 	in
-	add_int31_decompilation_from_type 
-	  (add_vm_before_match_info 
-	     (retroknowledge add_int31c env i31c) 
+	add_int31_decompilation_from_type
+	  (add_vm_before_match_info
+	     (retroknowledge add_int31c env i31c)
 	     value Cbytegen.int31_escape_before_match)
     | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31
     | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31
     | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31
     | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31
     | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31
-    | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const 
+    | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const
 	                                           Cbytecodes.Ksubcarrycint31
     | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31
     | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31
     | KInt31 (_, Int31Div21) -> (* this is a ternary operation *)
                                 (match value with
 				 | Const kn ->
-				     retroknowledge add_int31_op env value 3 
+				     retroknowledge add_int31_op env value 3
 	                               Cbytecodes.Kdiv21int31 kn
 				 | _ -> anomaly "Environ.register: should be a constant")
     | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31
     | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *)
                                 (match value with
 				 | Const kn ->
-				     retroknowledge add_int31_op env value 3 
+				     retroknowledge add_int31_op env value 3
 	                               Cbytecodes.Kaddmuldivint31 kn
 				 | _ -> anomaly "Environ.register: should be a constant")
     | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31
     | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31
-    | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 
-    | _ -> env.retroknowledge 
+    | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31
+    | _ -> env.retroknowledge
   in
   Retroknowledge.add_field retroknowledge_with_reactive_info field value
   }
 
 
 (**************************************************************)
-(* spiwack: the following definitions are used by the function 
+(* spiwack: the following definitions are used by the function
    [assumptions] which gives as an output the set of all
    axioms and sections variables on which a given term depends
    in a context (expectingly the Global context) *)
@@ -557,10 +530,10 @@ type context_object =
   | Opaque of constant     (* An opaque constant. *)
 
 (* Defines a set of [assumption] *)
-module OrderedContextObject = 
-struct 
+module OrderedContextObject =
+struct
   type t = context_object
-  let compare x y = 
+  let compare x y =
       match x , y with
       | Variable i1 , Variable i2 -> id_ord i1 i2
       | Axiom k1 , Axiom k2 -> Pervasives.compare k1 k2
@@ -583,8 +556,8 @@ let assumptions ?(add_opaque=false) st (* t env *) =
      on a and a ContextObjectSet, ContextObjectMap.  *)
   let ( ** ) f1 f2 s m = let (s',m') = f1 s m in f2 s' m' in
   (* This function eases memoization, by checking if an object is already
-     stored before trying and applying a function. 
-     If the object is there, the function is not fired (we are in a 
+     stored before trying and applying a function.
+     If the object is there, the function is not fired (we are in a
      particular case where memoized object don't need a treatment at all).
      If the object isn't there, it is stored and the function is fired*)
   let try_and_go o f s m =
@@ -596,7 +569,7 @@ let assumptions ?(add_opaque=false) st (* t env *) =
   let identity2 s m = (s,m) in
   (* Goes recursively into the term to see if it depends on assumptions
     the 3 important cases are : - Const _ where we need to first unfold
-    the constant and return the needed assumptions of its body in the 
+    the constant and return the needed assumptions of its body in the
     environment,
                                 - Rel _ which means the term is a variable
     which has been bound earlier by a Lambda or a Prod (returns [] ),
@@ -612,30 +585,30 @@ let assumptions ?(add_opaque=false) st (* t env *) =
   let rec aux t env s acc =
     match kind_of_term t with
     | Var id -> aux_memoize_id id env s acc
-    | Meta _ | Evar _ -> 
+    | Meta _ | Evar _ ->
 	Util.anomaly "Environ.assumption: does not expect a meta or an evar"
-    | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> 
+    | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) ->
                            ((aux e1 env)**(aux e2 env)) s acc
     | LetIn (_,e1,e2,e3) -> ((aux e1 env)**
                              (aux e2 env)**
                              (aux e3 env))
-	                     s acc 
+	                     s acc
     | App (e1, e_array) -> ((aux e1 env)**
-			    (Array.fold_right 
+			    (Array.fold_right
 			       (fun e f -> (aux e env)**f)
                                e_array identity2))
 	                   s acc
     | Case (_,e1,e2,e_array) -> ((aux e1 env)**
                                  (aux e2 env)**
-				 (Array.fold_right 
+				 (Array.fold_right
 				    (fun e f -> (aux e env)**f)
                                     e_array identity2))
 	                        s acc
     | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) ->
-                  ((Array.fold_right 
+                  ((Array.fold_right
 		      (fun e f -> (aux e env)**f)
                       e1_array identity2) **
-                   (Array.fold_right 
+                   (Array.fold_right
 		      (fun e f -> (aux e env)**f)
                       e2_array identity2))
 		     s acc
@@ -665,7 +638,7 @@ let assumptions ?(add_opaque=false) st (* t env *) =
     let (s,acc) =
       if cb.Declarations.const_body <> None
 	&& (cb.Declarations.const_opaque || not (Cpred.mem kn knst))
-	&& add_opaque 
+	&& add_opaque
       then
 	do_type (Opaque kn)
       else (s,acc)
@@ -673,13 +646,13 @@ let assumptions ?(add_opaque=false) st (* t env *) =
       match cb.Declarations.const_body with
       | None -> do_type (Axiom kn)
       | Some body -> aux (Declarations.force body) env s acc
-	  
+
   and aux_memoize_kn kn env =
     try_and_go (Axiom kn) (add_kn kn env)
  in
  fun t env ->
    snd (aux t env (ContextObjectSet.empty) (ContextObjectMap.empty))
-    
+
 (* /spiwack *)
 
 
diff --git a/kernel/environ.mli b/kernel/environ.mli
index b68123f6..667a0ed4 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: environ.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -15,7 +15,7 @@ open Declarations
 open Sign
 (*i*)
 
-(*s Unsafe environments. We define here a datatype for environments. 
+(*s Unsafe environments. We define here a datatype for environments.
    Since typing is not yet defined, it is not possible to check the
    informations added in environments, and that is why we speak here
    of ``unsafe'' environments. *)
@@ -24,7 +24,7 @@ open Sign
    - a context for de Bruijn variables
    - a context for de Bruijn variables vm values
    - a context for section variables and goal assumptions
-   - a context for section variables and goal assumptions vm values 
+   - a context for section variables and goal assumptions vm values
    - a context for global constants and axioms
    - a context for inductive definitions
    - a set of universe constraints
@@ -55,7 +55,7 @@ val empty_context : env -> bool
 
 (************************************************************************)
 (*s Context of de Bruijn variables ([rel_context]) *)
-val nb_rel           : env -> int 
+val nb_rel           : env -> int
 val push_rel         : rel_declaration -> env -> env
 val push_rel_context :     rel_context -> env -> env
 val push_rec_types   : rec_declaration -> env -> env
@@ -80,12 +80,12 @@ val empty_named_context_val : named_context_val
 
 (* [map_named_val f ctxt] apply [f] to the body and the type of
    each declarations.
-   *** /!\ ***   [f t] should be convertible with t *)  
-val map_named_val : 
+   *** /!\ ***   [f t] should be convertible with t *)
+val map_named_val :
    (constr -> constr) -> named_context_val -> named_context_val
 
 val push_named : named_declaration -> env -> env
-val push_named_context_val  : 
+val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 
 
@@ -98,7 +98,7 @@ val lookup_named_val : variable -> named_context_val -> named_declaration
 val evaluable_named  : variable -> env -> bool
 val named_type : variable -> env -> types
 val named_body : variable -> env -> constr option
- 
+
 (*s Recurrence on [named_context]: older declarations processed first *)
 
 val fold_named_context :
@@ -142,9 +142,6 @@ val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
 (* raises [Not_found] if the required path is not found *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
-(* Find the ultimate inductive in the [mind_equiv] chain *)
-val scrape_mind : env -> mutual_inductive -> mutual_inductive
-
 (************************************************************************)
 (*s Modules *)
 val add_modtype : module_path -> module_type_body -> env -> env
@@ -155,10 +152,6 @@ val shallow_add_module : module_path -> module_body -> env -> env
 val lookup_module : module_path -> env -> module_body
 val lookup_modtype : module_path -> env -> module_type_body
 
-val register_alias : module_path -> module_path -> env -> env
-val lookup_alias : module_path -> env -> module_path
-val scrape_alias : module_path -> env -> module_path
-
 (************************************************************************)
 (*s Universe constraints *)
 val set_universes   :   Univ.universes -> env -> env
@@ -168,10 +161,11 @@ val set_engagement : engagement -> env -> env
 
 (************************************************************************)
 (* Sets of referred section variables *)
-(* [global_vars_set env c] returns the list of [id]'s occurring as
-   [VAR id] in [c] *)
+(* [global_vars_set env c] returns the list of [id]'s occurring either
+   directly as [Var id] in [c] or indirectly as a section variable
+   dependent in a global reference occurring in [c] *)
 val global_vars_set : env -> constr -> Idset.t
-(* the constr must be an atomic construction *)
+(* the constr must be a global reference *)
 val vars_of_global : env -> constr -> identifier list
 
 val keep_hyps : env -> Idset.t -> section_context
@@ -181,7 +175,7 @@ val keep_hyps : env -> Idset.t -> section_context
   actually only a datatype to store a term with its type and the type of its
   type. *)
 
-type unsafe_judgment = { 
+type unsafe_judgment = {
   uj_val  : constr;
   uj_type : types }
 
@@ -189,14 +183,14 @@ val make_judge : constr -> types -> unsafe_judgment
 val j_val  : unsafe_judgment -> constr
 val j_type : unsafe_judgment -> types
 
-type unsafe_type_judgment = { 
+type unsafe_type_judgment = {
   utj_val  : constr;
   utj_type : sorts }
 
 
 (*s Compilation of global declaration *)
 
-val compile_constant_body : 
+val compile_constant_body :
     env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code
                                  (* opaque *) (* boxed *)
 
@@ -206,7 +200,7 @@ 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 -> 
+val apply_to_hyp : named_context_val -> variable ->
   (named_context -> named_declaration -> named_context -> named_declaration) ->
     named_context_val
 
@@ -219,7 +213,7 @@ val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
       named_context_val
 
 val insert_after_hyp : named_context_val -> variable ->
-  named_declaration -> 
+  named_declaration ->
     (named_context -> unit) -> named_context_val
 
 val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
@@ -250,7 +244,7 @@ type context_object =
 module OrderedContextObject :  Set.OrderedType with type t = context_object
 module ContextObjectMap : Map.S with type key = context_object
 
-(* collects all the assumptions (optionally including opaque definitions) 
+(* collects all the assumptions (optionally including opaque definitions)
    on which a term relies (together with their type) *)
 val assumptions : ?add_opaque:bool -> transparent_state -> constr -> env -> Term.types ContextObjectMap.t
 
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index e32fc963..c8b5fb26 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: esubst.ml 8799 2006-05-09 21:15:07Z barras $ *)
+(* $Id$ *)
 
 open Util
 
@@ -110,7 +110,7 @@ let rec is_subs_id = function
  * the result is (Inr (k+lams,p)) when the variable is just relocated
  * where p is None if the variable points inside subs and Some(k) if the
  * variable points k bindings beyond subs.
- *) 
+ *)
 let rec exp_rel lams k subs =
   match subs with
     | CONS (def,_) when k <= Array.length def
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 3b40bdfc..bf1d2324 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -6,7 +6,47 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: esubst.mli 8799 2006-05-09 21:15:07Z barras $ i*)
+(*i $Id$ i*)
+
+(*s Explicit substitutions of type ['a]. *)
+(*  - ESID(n)             = %n END   bounded identity
+ *  - CONS([|t1..tn|],S)  = (S.t1...tn)    parallel substitution
+ *       (beware of the order: indice 1 is substituted by tn)
+ *  - SHIFT(n,S)          = (^n o S) terms in S are relocated with n vars
+ *  - LIFT(n,S)           = (%n S) stands for ((^n o S).n...1)
+         (corresponds to S crossing n binders) *)
+type 'a subs =
+  | ESID of int
+  | CONS of 'a array * 'a subs
+  | SHIFT of int * 'a subs
+  | LIFT of int * 'a subs
+
+(* Derived constructors granting basic invariants *)
+val subs_cons: 'a array * 'a subs -> 'a subs
+val subs_shft: int * 'a subs -> 'a subs
+val subs_lift: 'a subs -> 'a subs
+val subs_liftn: int -> 'a subs -> 'a subs
+(* [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *)
+val subs_shift_cons: int * 'a subs * 'a array -> 'a subs
+
+(* [expand_rel k subs] expands de Bruijn [k] in the explicit substitution
+ * [subs]. The result is either (Inl(lams,v)) when the variable is
+ * substituted by value [v] under lams binders (i.e. v *has* to be
+ * shifted by lams), or (Inr (k',p)) when the variable k is just relocated
+ * as k'; p is None if the variable points inside subs and Some(k) if the
+ * variable points k bindings beyond subs (cf argument of ESID).
+ *)
+val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union
+
+(* Tests whether a substitution behaves like the identity *)
+val is_subs_id: 'a subs -> bool
+
+(* Composition of substitutions: [comp mk_clos s1 s2] computes a
+ * substitution equivalent to applying s2 then s1. Argument
+ * mk_clos is used when a closure has to be created, i.e. when
+ * s1 is applied on an element of s2.
+ *)
+val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
 
 (*s Compact representation of explicit relocations. \\
    [ELSHFT(l,n)] == lift of [n], then apply [lift l].
@@ -21,23 +61,3 @@ val el_liftn : int -> lift -> lift
 val el_lift : lift -> lift
 val reloc_rel : int -> lift -> int
 val is_lift_id : lift -> bool
-
-(*s Explicit substitutions of type ['a]. *)
-type 'a subs =
-  | ESID of int            (* ESID(n)    = %n END   bounded identity *)
-  | CONS of 'a array * 'a subs
-                           (* CONS([|t1..tn|],S)  =
-                              (S.t1...tn)    parallel substitution
-                              beware of the order *)
-  | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *)
-                           (*                        with n vars *)
-  | LIFT of int * 'a subs  (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *)
-
-val subs_cons: 'a array * 'a subs -> 'a subs
-val subs_shft: int * 'a subs -> 'a subs
-val subs_lift: 'a subs -> 'a subs
-val subs_liftn: int -> 'a subs -> 'a subs
-val subs_shift_cons: int * 'a subs * 'a array -> 'a subs
-val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union
-val is_subs_id: 'a subs -> bool
-val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 941ab046..dd9720b3 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml 12616 2009-12-30 15:02:26Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -58,8 +58,8 @@ exception InductiveError of inductive_error
 let check_constructors_names =
   let rec check idset = function
     | [] -> idset
-    | c::cl -> 
-	if Idset.mem c idset then 
+    | c::cl ->
+	if Idset.mem c idset then
 	  raise (InductiveError (SameNamesConstructors c))
 	else
 	  check (Idset.add c idset) cl
@@ -73,7 +73,7 @@ let check_constructors_names =
 let mind_check_names mie =
   let rec check indset cstset = function
     | [] -> ()
-    | ind::inds -> 
+    | ind::inds ->
 	let id = ind.mind_entry_typename in
 	let cl = ind.mind_entry_consnames in
 	if Idset.mem id indset then
@@ -89,7 +89,7 @@ let mind_check_names mie =
 
 let mind_check_arities env mie =
   let check_arity id c =
-    if not (is_arity env c) then 
+    if not (is_arity env c) then
       raise (InductiveError (NotAnArity id))
   in
   List.iter
@@ -110,12 +110,12 @@ let is_small infos = List.for_all (fun (logic,small) -> small) infos
 let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos
 
 (* An inductive definition is a "unit" if it has only one constructor
-   and that all arguments expected by this constructor are 
-   logical, this is the case for equality, conjunction of logical properties 
+   and that all arguments expected by this constructor are
+   logical, this is the case for equality, conjunction of logical properties
 *)
 let is_unit constrsinfos =
   match constrsinfos with  (* One info = One constructor *)
-   | [constrinfos] -> is_logic_constr constrinfos 
+   | [constrinfos] -> is_logic_constr constrinfos
    | [] -> (* type without constructors *) true
    | _ -> false
 
@@ -132,7 +132,7 @@ let rec infos_and_sort env t =
     | _ -> (* don't fail if not positive, it is tested later *) []
 
 let small_unit constrsinfos =
-  let issmall = List.for_all is_small constrsinfos 
+  let issmall = List.for_all is_small constrsinfos
   and isunit = is_unit constrsinfos in
   issmall, isunit
 
@@ -154,7 +154,7 @@ let small_unit constrsinfos =
    w1,w2,w3 <= u1
    w1,w2 <= u2
    w1,w2,w3 <= u3
-*)   
+*)
 
 let extract_level (_,_,_,lc,lev) =
   (* Enforce that the level is not in Prop if more than two constructors *)
@@ -173,9 +173,7 @@ let inductive_levels arities inds =
 let constraint_list_union =
   List.fold_left Constraint.union Constraint.empty
 
-let infer_constructor_packet env_ar params lc =
-  (* builds the typing context "Gamma, I1:A1, ... In:An, params" *)
-  let env_ar_par = push_rel_context params env_ar in
+let infer_constructor_packet env_ar_par params lc =
   (* type-check the constructors *)
   let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in
   let cst = constraint_list_union cstl in
@@ -195,7 +193,6 @@ let typecheck_inductive env mie =
   if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration";
   (* Check unicity of names *)
   mind_check_names mie;
-  mind_check_arities env mie;
   (* Params are typed-checked here *)
   let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in
   (* We first type arity of each inductive definition *)
@@ -213,11 +210,13 @@ let typecheck_inductive env mie =
 	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
 	 let cst = Constraint.union cst cst2 in
 	 let id = ind.mind_entry_typename in
-	 let env_ar' = push_rel (Name id, None, full_arity) env_ar in
+	 let env_ar' =
+           push_rel (Name id, None, full_arity)
+             (add_constraints cst2 env_ar) in
 	 let lev =
 	   (* Decide that if the conclusion is not explicitly Type *)
 	   (* then the inductive type is not polymorphic *)
-	   match kind_of_term (snd (decompose_prod_assum arity.utj_val)) with
+	   match kind_of_term ((strip_prod_assum arity.utj_val)) with
 	   | Sort (Type u) -> Some u
 	   | _ -> None in
          (cst,env_ar',(id,full_arity,lev)::l))
@@ -226,12 +225,16 @@ let typecheck_inductive env mie =
 
   let arity_list = List.rev rev_arity_list in
 
+  (* builds the typing context "Gamma, I1:A1, ... In:An, params" *)
+  let env_ar_par =
+    push_rel_context params (add_constraints cst1 env_arities) in
+
   (* Now, we type the constructors (without params) *)
   let inds,cst =
     List.fold_right2
       (fun ind arity_data (inds,cst) ->
 	 let (info,lc',cstrs_univ,cst') =
-	   infer_constructor_packet env_arities params ind.mind_entry_lc in
+	   infer_constructor_packet env_ar_par params ind.mind_entry_lc in
 	 let consnames = ind.mind_entry_consnames in
 	 let ind' = (arity_data,consnames,info,lc',cstrs_univ) in
 	 (ind'::inds, Constraint.union cst cst'))
@@ -242,11 +245,11 @@ let typecheck_inductive env mie =
   let inds = Array.of_list inds in
   let arities = Array.of_list arity_list in
   let param_ccls = List.fold_left (fun l (_,b,p) ->
-    if b = None then 
+    if b = None then
       let _,c = dest_prod_assum env p in
       let u = match kind_of_term c with Sort (Type u) -> Some u | _ -> None in
       u::l
-    else 
+    else
       l) [] params in
 
   (* Compute/check the sorts of the inductive types *)
@@ -255,7 +258,7 @@ let typecheck_inductive env mie =
     array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst ->
       let sign, s = dest_arity env full_arity in
       let status,cst = match s with
-      | Type u when ar_level <> None (* Explicitly polymorphic *) 
+      | Type u when ar_level <> None (* Explicitly polymorphic *)
             && no_upper_constraints u cst ->
 	  (* The polymorphic level is a function of the level of the *)
 	  (* conclusions of the parameters *)
@@ -294,20 +297,20 @@ exception IllFormedInd of ill_formed_ind
 
 let mind_extract_params = decompose_prod_n_assum
 
-let explain_ind_err id ntyp env0 nbpar c nargs err = 
+let explain_ind_err id ntyp env0 nbpar c nargs err =
   let (lpar,c') = mind_extract_params nbpar c in
   let env = push_rel_context lpar env0 in
   match err with
-    | LocalNonPos kt -> 
+    | LocalNonPos kt ->
 	raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar))))
-    | LocalNotEnoughArgs kt -> 
-	raise (InductiveError 
+    | LocalNotEnoughArgs kt ->
+	raise (InductiveError
 		 (NotEnoughArgs (env,c',mkRel (kt+nbpar))))
     | LocalNotConstructor ->
-	raise (InductiveError 
+	raise (InductiveError
 		 (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs)))
     | LocalNonPar (n,l) ->
-	raise (InductiveError 
+	raise (InductiveError
 		 (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
 
 let failwith_non_pos n ntypes c =
@@ -327,7 +330,7 @@ let failwith_non_pos_list n ntypes l =
 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 
+  if Array.length largs < nparams then
     raise (IllFormedInd (LocalNotEnoughArgs l));
   let (lpar,largs') = array_chop nparams largs in
   let nhyps = List.length hyps in
@@ -339,20 +342,20 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
 	  | Rel w when w = index -> check (k-1) (index+1) hyps
 	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
   in check (nparams-1) (n-nhyps) hyps;
-  if not (array_for_all (noccur_between n ntypes) largs') then 
+  if not (array_for_all (noccur_between n ntypes) largs') then
     failwith_non_pos_vect n ntypes largs'
 
-(* 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 
+(* 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 = 
+let compute_rec_par (env,n,_,_) hyps nmr largs =
 if nmr = 0 then 0 else
 (* start from 0, hyps will be in reverse order *)
   let (lpar,_) = list_chop nmr largs in
-  let rec find k index = 
-      function 
+  let rec find k index =
+      function
 	  ([],_) -> nmr
 	| (_,[]) -> assert false (* |hyps|>=nmr *)
 	| (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
@@ -364,14 +367,14 @@ if nmr = 0 then 0 else
 
 (* This removes global parameters of the inductive types in lc (for
    nested inductive types only ) *)
-let abstract_mind_lc env ntyps npars lc = 
-  if npars = 0 then 
+let abstract_mind_lc env ntyps npars lc =
+  if npars = 0 then
     lc
-  else 
-    let make_abs = 
+  else
+    let make_abs =
       list_tabulate
-	(function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps 
-    in 
+	(function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps
+    in
     Array.map (substl make_abs) lc
 
 (* [env] is the typing environment
@@ -379,7 +382,7 @@ let abstract_mind_lc env ntyps npars lc =
    [ntypes] is the number of inductive types in the definition
      (i.e. range of inductives is [n; n+ntypes-1])
    [lra] is the list of recursive tree of each variable
- *) 
+ *)
 let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
  (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
 
@@ -389,13 +392,22 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   let env' =
     push_rel (Anonymous,None,
               hnf_prod_applist env (type_of_inductive env specif) lpar) env in
-  let ra_env' = 
+  let ra_env' =
     (Imbr mi,(Rtree.mk_rec_calls 1).(0)) ::
     List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
   (* New index of the inductive types *)
   let newidx = n + auxntyp in
   (env', newidx, ntypes, ra_env')
 
+let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
+  if n=0 then (ienv,c) else
+    let c' = whd_betadeltaiota env c in
+    match kind_of_term c' with
+	Prod(na,a,b) ->
+	  let ienv' = ienv_push_var ienv (na,a,mk_norec) in
+	  ienv_decompose_prod ienv' (n-1) b
+      | _ -> assert false
+
 let array_min nmr a = if nmr = 0 then 0 else
   Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a
 
@@ -404,8 +416,8 @@ let array_min nmr a = if nmr = 0 then 0 else
 let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
   let lparams = rel_context_length hyps in
   let nmr = rel_context_nhyps hyps in
-  (* check the inductive types occur positively in [c] *)
-  let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = 
+  (* Checking the (strict) positivity of a constructor argument type [c] *)
+  let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c =
     let x,largs = decompose_app (whd_betadeltaiota env c) in
       match kind_of_term x with
 	| Prod (na,b,d) ->
@@ -415,40 +427,41 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
               | Some b ->
 	          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 
+            (try let (ra,rarg) = List.nth ra_env (k-1) in
 	    let nmr1 =
 	      (match ra with
                   Mrec _ -> compute_rec_par ienv hyps nmr largs
 		|  _ -> nmr)
-	    in 
+	    in
 	      if not (List.for_all (noccur_between n ntypes) largs)
 	      then failwith_non_pos_list n ntypes largs
 	      else (nmr1,rarg)
               with Failure _ | Invalid_argument _ -> (nmr,mk_norec))
 	| Ind ind_kn ->
             (* If the inductive type being defined appears in a
-               parameter, then we have an imbricated type *)
+               parameter, then we have a nested indtype *)
             if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
-            else check_positive_imbr ienv nmr (ind_kn, largs)
-	| err -> 
+            else check_positive_nested ienv nmr (ind_kn, largs)
+	| err ->
 	    if noccur_between n ntypes x &&
-              List.for_all (noccur_between n ntypes) largs 
+              List.for_all (noccur_between n ntypes) largs
 	    then (nmr,mk_norec)
 	    else failwith_non_pos_list n ntypes (x::largs)
 
   (* accesses to the environment are not factorised, but is it worth? *)
-  and check_positive_imbr (env,n,ntypes,ra_env as ienv) nmr (mi, largs) =
+  and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, 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 
-      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
+      try list_chop auxnpar largs
+      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
       (* If the inductive appears in the args (non params) then the
 	 definition is not positive. *)
       if not (List.for_all (noccur_between n ntypes) auxlargs) then
-	raise (IllFormedInd (LocalNonPos n));
+        failwith_non_pos_list n ntypes auxlargs;
       (* We do not deal with imbricated mutual inductive types *)
-      let auxntyp = mib.mind_ntypes in 
+      let auxntyp = mib.mind_ntypes in
 	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
 	(* The nested inductive type with parameters removed *)
 	let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
@@ -457,35 +470,37 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
 	let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
 	  (* Parameters expressed in env' *)
 	let lpar' = List.map (lift auxntyp) lpar in
-	let irecargs_nmr = 
+	let irecargs_nmr =
 	  (* fails if the inductive type occurs non positively *)
-	  (* when substituted *) 
-	  Array.map 
-	    (function c -> 
-	      let c' = hnf_prod_applist env' c lpar' in 
-		check_constructors ienv' false nmr c') 
+	  (* with recursive parameters substituted *)
+	  Array.map
+	    (function c ->
+	      let c' = hnf_prod_applist env' c lpar' in
+	      (* skip non-recursive parameters *)
+	      let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in
+		check_constructors ienv' false nmr c')
 	    auxlcvect
 	in
 	let irecargs = Array.map snd irecargs_nmr
 	and nmr' = array_min nmr irecargs_nmr
-	in 
+	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 *) 
-	    
-  and check_constructors ienv check_head nmr c = 
-    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = 
+     the ith 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
 	match kind_of_term x with
 
-          | Prod (na,b,d) -> 
+          | Prod (na,b,d) ->
 	      assert (largs = []);
-              let nmr',recarg = check_pos ienv nmr b in 
+              let nmr',recarg = check_pos ienv nmr b in
               let ienv' = ienv_push_var ienv (na,b,mk_norec) in
 		check_constr_rec ienv' nmr' (recarg::lrec) d
-		  
+
 	  | hd ->
 	      if check_head then
 		if hd = Rel (n+ntypes-i-1) then
@@ -504,7 +519,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
         let _,rawc = mind_extract_params lparams c in
           try
 	    check_constructors ienv true nmr rawc
-          with IllFormedInd err -> 
+          with IllFormedInd err ->
 	    explain_ind_err id (ntypes-i) env lparams c nargs err)
       (Array.of_list lcnames) indlc
   in
@@ -523,9 +538,9 @@ let check_positivity env_ar params inds =
       list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ 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 i nargs lcnames lc 
+    check_positivity_one ienv params i nargs lcnames lc
   in
-  let irecargs_nmr = Array.mapi check_one inds in 
+  let irecargs_nmr = Array.mapi check_one inds in
   let irecargs = Array.map snd irecargs_nmr
   and nmr' = array_min nmr irecargs_nmr
   in (nmr',Rtree.mk_rec irecargs)
@@ -534,14 +549,14 @@ let check_positivity env_ar params inds =
 (************************************************************************)
 (************************************************************************)
 (* Build the inductive packet *)
-    
+
 (* Elimination sorts *)
 let is_recursive = Rtree.is_infinite
-(*  let rec one_is_rec rvec = 
-    List.exists (function Mrec(i) -> List.mem i listind 
+(*  let rec one_is_rec rvec =
+    List.exists (function Mrec(i) -> List.mem i listind
                    | Imbr(_,lvec) -> array_exists one_is_rec lvec
                    | Norec -> false) rvec
-  in 
+  in
   array_exists one_is_rec
 *)
 
@@ -585,6 +600,7 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
   (* 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
   (* Check one inductive *)
   let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg =
     (* Type of constructors in normal form *)
@@ -594,37 +610,39 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
     let consnrealargs =
       Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
 	splayed_lc in
-      (* Elimination sorts *)
+    (* Elimination sorts *)
     let arkind,kelim = match ar_kind with
       | Inr (param_levels,lev) ->
 	  Polymorphic {
 	      poly_param_levels = param_levels;
-	      poly_level = lev; 
+	      poly_level = lev;
 	    }, all_sorts
       | Inl ((issmall,isunit),ar,s) ->
 	  let kelim = allowed_sorts issmall isunit s in
 	    Monomorphic {
 		mind_user_arity = ar;
-		mind_sort = s; 
+		mind_sort = s;
 	      }, kelim in
-    let nconst, nblock = ref 0, ref 0 in 
+    (* Assigning VM tags to constructors *)
+    let nconst, nblock = ref 0, ref 0 in
     let transf num =
       let arity = List.length (dest_subterms recarg).(num) in
-	if arity = 0 then 
+	if arity = 0 then
 	  let p  = (!nconst, 0) in
 	    incr nconst; p
-	else 
+	else
 	  let p = (!nblock + 1, arity) in
 	    incr nblock; p
 	      (* les tag des constructeur constant commence a 0,
 		 les tag des constructeur non constant a 1 (0 => accumulator) *)
-    in 
+    in
     let rtbl = Array.init (List.length cnames) transf in
       (* Build the inductive packet *)
       { mind_typename = id;
 	mind_arity = arkind;
 	mind_arity_ctxt = ar_sign;
 	mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
+	mind_nrealargs_ctxt = rel_context_length ar_sign - nparamdecls;
 	mind_kelim = kelim;
 	mind_consnames = Array.of_list cnames;
 	mind_consnrealdecls = consnrealargs;
@@ -642,11 +660,10 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
       mind_finite = isfinite;
       mind_hyps = hyps;
       mind_nparams = nparamargs;
-      mind_nparams_rec = nmr;  
+      mind_nparams_rec = nmr;
       mind_params_ctxt = params;
       mind_packets = packets;
-      mind_constraints = cst;
-      mind_equiv = None;
+      mind_constraints = cst
     }
 
 (************************************************************************)
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 90ae70c3..0cbe1503 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indtypes.mli 11784 2009-01-14 11:36:32Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 99ec1650..5bcba626 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml 11647 2008-12-02 10:40:11Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -55,7 +55,7 @@ let inductive_params (mib,_) = mib.mind_nparams
 (* inductives *)
 let ind_subst mind mib =
   let ntypes = mib.mind_ntypes in
-  let make_Ik k = mkInd (mind,ntypes-k-1) in 
+  let make_Ik k = mkInd (mind,ntypes-k-1) in
   list_tabulate make_Ik ntypes
 
 (* Instantiate inductives in constructor type *)
@@ -64,7 +64,7 @@ let constructor_instantiate mind mib c =
   substl s c
 
 let instantiate_params full t args sign =
-  let fail () = 
+  let fail () =
     anomaly "instantiate_params: type, ctxt and args mismatch" in
   let (rem_args, subs, ty) =
     Sign.fold_rel_context
@@ -75,7 +75,7 @@ let instantiate_params full t args sign =
 	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
 	  | _                       -> fail ())
       sign
-      ~init:(args,[],t) 
+      ~init:(args,[],t)
   in
   if rem_args <> [] then fail();
   substl subs ty
@@ -101,11 +101,11 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) =
 let number_of_inductives mib = Array.length mib.mind_packets
 let number_of_constructors mip = Array.length mip.mind_consnames
 
-(* 
+(*
 Computing the actual sort of an applied or partially applied inductive type:
 
 I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a)
-uniformargs : utyps 
+uniformargs : utyps
 otherargs : otyps
 I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj
 s'_k = max(..s_kj..)
@@ -221,11 +221,11 @@ let type_of_constructor cstr (mib,mip) =
   if i > nconstr then error "Not enough constructors in the type.";
   constructor_instantiate (fst ind) mib specif.(i-1)
 
-let arities_of_specif kn (mib,mip) = 
+let arities_of_specif kn (mib,mip) =
   let specif = mip.mind_nf_lc in
   Array.map (constructor_instantiate kn mib) specif
 
-let arities_of_constructors ind specif = 
+let arities_of_constructors ind specif =
   arities_of_specif (fst ind) specif
 
 let type_of_constructors ind (mib,mip) =
@@ -250,7 +250,7 @@ let local_rels ctxt =
             None   -> (mkRel n :: rels, n+1)
           | Some _ -> (rels, n+1))
       ~init:([],1)
-      ctxt 
+      ctxt
   in
   rels
 
@@ -258,7 +258,7 @@ let local_rels ctxt =
 
 let inductive_sort_family mip =
   match mip.mind_arity with
-   | Monomorphic s -> family_of_sort s.mind_sort 
+   | Monomorphic s -> family_of_sort s.mind_sort
    | Polymorphic _ -> InType
 
 let mind_arity mip =
@@ -270,26 +270,30 @@ let get_instantiated_arity (mib,mip) params =
 
 let elim_sorts (_,mip) = mip.mind_kelim
 
-let rel_list n m = 
-  let rec reln l p = 
-    if p>m then l else reln (mkRel(n+p)::l) (p+1)
-  in 
-  reln [] 1
+let 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 nrealargs = mip.mind_nrealargs in
-  applist 
-    (mkInd ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs))
+  let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  applist
+    (mkInd ind,
+       List.map (lift mip.mind_nrealargs_ctxt) params
+       @ extended_rel_list 0 realargs)
 
 (* This exception is local *)
 exception LocalArity of (sorts_family * sorts_family * arity_error) option
 
 let check_allowed_sort ksort specif =
-  if not (List.exists ((=) ksort) (elim_sorts specif)) then 
+  if not (List.exists ((=) ksort) (elim_sorts specif)) then
     let s = inductive_sort_family (snd specif) in
     raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
 
-let is_correct_arity env c pj ind specif params = 
+let is_correct_arity env c pj ind specif params =
   let arsign,_ = get_instantiated_arity specif params in
   let rec srec env pt ar u =
     let pt' = whd_betadeltaiota env pt in
@@ -301,20 +305,19 @@ let is_correct_arity env c pj ind specif params =
           srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ)
       | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *)
           let ksort = match kind_of_term (whd_betadeltaiota env a2) with
-            | Sort s -> family_of_sort s 
+            | Sort s -> family_of_sort s
 	    | _ -> raise (LocalArity None) in
-	  let dep_ind = build_dependent_inductive ind specif params in 
+	  let dep_ind = build_dependent_inductive ind specif params in
           let univ =
             try conv env a1 dep_ind
             with NotConvertible -> raise (LocalArity None) in
 	  check_allowed_sort ksort specif;
-	  (true, Constraint.union u univ)
-      | Sort s', [] ->
-	  check_allowed_sort (family_of_sort s') specif;
-	  (false, u)
+	  Constraint.union u univ
+      | _, (_,Some _,_ as d)::ar' ->
+	  srec (push_rel d env) (lift 1 pt') ar' u
       | _ ->
 	  raise (LocalArity None)
-  in 
+  in
   try srec env pj.uj_type (List.rev arsign) Constraint.empty
   with LocalArity kinds ->
     error_elim_arity env ind (elim_sorts specif) c pj kinds
@@ -325,7 +328,7 @@ let is_correct_arity env c pj ind specif params =
 
 (* [p] is the predicate, [i] is the constructor number (starting from 0),
    and [cty] is the type of the constructor (params not instantiated) *)
-let build_branches_type ind (_,mip as specif) params dep p =
+let build_branches_type ind (_,mip as specif) params p =
   let build_one_branch i cty =
     let typi = full_constructor_instantiate (ind,specif,params) cty in
     let (args,ccl) = decompose_prod_assum typi in
@@ -333,50 +336,36 @@ let build_branches_type ind (_,mip as specif) params dep p =
     let (_,allargs) = decompose_app ccl in
     let (lparams,vargs) = list_chop (inductive_params specif) allargs in
     let cargs =
-      if dep then
-        let cstr = ith_constructor_of_inductive ind (i+1) in
-        let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in
-        vargs @ [dep_cstr]
-      else
-        vargs in
+      let cstr = ith_constructor_of_inductive ind (i+1) in
+      let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in
+      vargs @ [dep_cstr] in
     let base = beta_appvect (lift nargs p) (Array.of_list cargs) in
     it_mkProd_or_LetIn base args in
   Array.mapi build_one_branch mip.mind_nf_lc
 
 (* [p] is the predicate, [c] is the match object, [realargs] is the
    list of real args of the inductive type *)
-let build_case_type dep p c realargs =
-  let args = if dep then realargs@[c] else realargs in
-  beta_appvect p (Array.of_list args)
+let build_case_type n p c realargs =
+  whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c])))
 
 let type_case_branches env (ind,largs) pj c =
-  let specif = lookup_mind_specif env ind in 
+  let specif = lookup_mind_specif env ind in
   let nparams = inductive_params specif in
   let (params,realargs) = list_chop nparams largs in
   let p = pj.uj_val in
-  let (dep,univ) = is_correct_arity env c pj ind specif params in
-  let lc = build_branches_type ind specif params dep p in
-  let ty = build_case_type dep p c realargs in
+  let univ = is_correct_arity env c pj ind specif params in
+  let lc = build_branches_type ind specif params p in
+  let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in
   (lc, ty, univ)
 
 
 (************************************************************************)
 (* Checking the case annotation is relevent *)
 
-let rec inductive_kn_equiv env kn1 kn2 =
-  match (lookup_mind kn1 env).mind_equiv with
-    | Some kn1' -> inductive_kn_equiv env kn2 kn1'
-    | None -> match (lookup_mind kn2 env).mind_equiv with
-        | Some kn2' -> inductive_kn_equiv env kn2' kn1
-	| None -> false
-
-let inductive_equiv env (kn1,i1) (kn2,i2) =
-  i1=i2 & inductive_kn_equiv env kn1 kn2
-
 let check_case_info env indsp ci =
   let (mib,mip) = lookup_mind_specif env indsp in
   if
-    not (Closure.mind_equiv env indsp ci.ci_ind) or
+    not (eq_ind indsp ci.ci_ind) or
     (mib.mind_nparams <> ci.ci_npar) or
     (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
@@ -386,7 +375,7 @@ let check_case_info env indsp ci =
 
 (* Guard conditions for fix and cofix-points *)
 
-(* Check if t is a subterm of Rel n, and gives its specification, 
+(* Check if t is a subterm of Rel n, and gives its specification,
    assuming lst already gives index of
    subterms with corresponding specifications of recursive arguments *)
 
@@ -431,7 +420,7 @@ type subterm_spec =
 
 let spec_of_tree t =
   if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t)
- 
+
 let subterm_spec_glb =
   let glb2 s1 s2 =
     match s1,s2 with
@@ -444,7 +433,7 @@ let subterm_spec_glb =
           (* branches do not return objects with same spec *)
           else Not_subterm in
   Array.fold_left glb2 Dead_code
-          
+
 type guard_env =
   { env     : env;
     (* dB of last fixpoint *)
@@ -468,7 +457,7 @@ let make_renv env minds recarg (kn,tyi) =
     genv = [Subterm(Large,mind_recvec.(tyi))] }
 
 let push_var renv (x,ty,spec) =
-  { renv with 
+  { renv with
     env = push_rel (x,None,ty) renv.env;
     rel_min = renv.rel_min+1;
     genv = spec:: renv.genv }
@@ -480,7 +469,7 @@ let push_var_renv renv (x,ty) =
   push_var renv (x,ty,Not_subterm)
 
 (* Fetch recursive information about a variable p *)
-let subterm_var p renv = 
+let subterm_var p renv =
   try List.nth renv.genv (p-1)
   with Failure _ | Invalid_argument _ -> Not_subterm
 
@@ -490,7 +479,7 @@ let add_subterm renv (x,a,spec) =
 
 let push_ctxt_renv renv ctxt =
   let n = rel_context_length ctxt in
-  { renv with 
+  { renv with
     env = push_rel_context ctxt renv.env;
     rel_min = renv.rel_min+n;
     genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
@@ -529,8 +518,8 @@ let lookup_subterms env ind =
    associated to its own subterms.
    Rq: if branch is not eta-long, then the recursive information
    is not propagated to the missing abstractions *)
-let case_branches_specif renv c_spec ind lbr = 
-  let rec push_branch_args renv lrec c = 
+let case_branches_specif renv c_spec ind lbr =
+  let rec push_branch_args renv lrec c =
     match lrec with
         ra::lr ->
           let c' = whd_betadeltaiota renv.env c in
@@ -546,7 +535,7 @@ let case_branches_specif renv c_spec ind lbr =
         let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
         assert (Array.length sub_spec = Array.length lbr);
         array_map2 (push_branch_args renv) sub_spec lbr
-    | Dead_code -> 
+    | Dead_code ->
         let t = dest_subterms (lookup_subterms renv.env ind) in
         let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
         assert (Array.length sub_spec = Array.length lbr);
@@ -559,22 +548,19 @@ let case_branches_specif renv c_spec ind lbr =
    about variables.
 *)
 
-let rec subterm_specif renv t = 
+let rec subterm_specif renv t =
   (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
-  match kind_of_term f with 
+  match kind_of_term f with
     | Rel k -> subterm_var k renv
 
     | Case (ci,_,c,lbr) ->
-        if Array.length lbr = 0 then Dead_code
-        else
-          let c_spec = subterm_specif renv c in
-          let lbr_spec = case_branches_specif renv c_spec ci.ci_ind lbr in
-          let stl  =
-            Array.map (fun (renv',br') -> subterm_specif renv' br')
-              lbr_spec in
-          subterm_spec_glb stl
-	       
+        let lbr_spec = case_subterm_specif renv ci c lbr in
+        let stl  =
+          Array.map (fun (renv',br') -> subterm_specif renv' br')
+            lbr_spec in
+        subterm_spec_glb stl
+
     | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
 (* when proving that the fixpoint f(x)=e is less than n, it is enough
    to prove that e is less than n assuming f is less than n
@@ -597,7 +583,7 @@ let rec subterm_specif renv t =
                 (* Why Strict here ? To be general, it could also be
                    Large... *)
                 assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
-              let decrArg = recindxs.(i) in 
+              let decrArg = recindxs.(i) in
               let theBody = bodies.(i)   in
               let nbOfAbst = decrArg+1 in
               let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
@@ -611,7 +597,7 @@ let rec subterm_specif renv t =
                   assign_var_spec renv'' (1, arg_spec) in
 	      subterm_specif renv'' strippedBody)
 
-    | Lambda (x,a,b) -> 
+    | Lambda (x,a,b) ->
         assert (l=[]);
         subterm_specif (push_var_renv renv (x,a)) b
 
@@ -621,9 +607,14 @@ let rec subterm_specif renv t =
     (* Other terms are not subterms *)
     | _ -> Not_subterm
 
-
+and case_subterm_specif renv ci c lbr =
+  if Array.length lbr = 0 then [||]
+  else
+    let c_spec = subterm_specif renv c in
+    case_branches_specif renv c_spec ci.ci_ind lbr
+ 
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm renv c = 
+let check_is_subterm renv c =
   match subterm_specif renv c with
     Subterm (Strict,_) | Dead_code -> true
   |  _ -> false
@@ -651,21 +642,21 @@ let error_partial_apply renv fx =
    given [recpos], the decreasing arguments of each mutually defined
    fixpoint. *)
 let check_one_fix renv recpos def =
-  let nfi = Array.length recpos in 
+  let nfi = Array.length recpos in
 
   (* Checks if [t] only make valid recursive calls *)
-  let rec check_rec_call renv t = 
+  let rec check_rec_call renv t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
       let (f,l) = decompose_app (whd_betaiotazeta t) in
       match kind_of_term f with
-        | Rel p -> 
-            (* Test if [p] is a fixpoint (recursive call) *) 
+        | Rel p ->
+            (* Test if [p] is a fixpoint (recursive call) *)
 	    if renv.rel_min <= p & p < renv.rel_min+nfi then
               begin
                 List.iter (check_rec_call renv) l;
-                (* the position of the invoked fixpoint: *) 
+                (* the position of the invoked fixpoint: *)
 	        let glob = renv.rel_min+nfi-1-p in
                 (* the decreasing arg of the rec call: *)
 	        let np = recpos.(glob) in
@@ -691,31 +682,29 @@ let check_one_fix renv recpos def =
             List.iter (check_rec_call renv) (c_0::p::l);
             (* compute the recarg information for the arguments of
                each branch *)
-            let c_spec = subterm_specif renv c_0 in
-            let lbr = case_branches_specif renv c_spec ci.ci_ind lrest in
+            let lbr = case_subterm_specif renv ci c_0 lrest in
             Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
 
         (* Enables to traverse Fixpoint definitions in a more intelligent
            way, ie, the rule :
-           if - g = Fix g/p := [y1:T1]...[yp:Tp]e &
-              - f is guarded with respect to the set of pattern variables S 
+           if - g = fix g (y1:T1)...(yp:Tp) {struct yp} := e &
+              - f is guarded with respect to the set of pattern variables S
                 in a1 ... am        &
-              - f is guarded with respect to the set of pattern variables S 
+              - f is guarded with respect to the set of pattern variables S
                 in T1 ... Tp        &
               - ap is a sub-term of the formal argument of f &
               - f is guarded with respect to the set of pattern variables
                 S+{yp} in e
            then f is guarded with respect to S in (g a1 ... am).
            Eduardo 7/9/98 *)
-
         | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
             List.iter (check_rec_call renv) l;
             Array.iter (check_rec_call renv) typarray;
             let decrArg = recindxs.(i) in
-            let renv' = push_fix_renv renv recdef in 
+            let renv' = push_fix_renv renv recdef in
             if (List.length l < (decrArg+1)) then
 	      Array.iter (check_rec_call renv') bodies
-            else 
+            else
               Array.iteri
                 (fun j body ->
                   if i=j then
@@ -725,8 +714,8 @@ let check_one_fix renv recpos def =
                   else check_rec_call renv' body)
                 bodies
 
-        | Const kn -> 
-            if evaluable_constant kn renv.env then 
+        | Const kn ->
+            if evaluable_constant kn renv.env then
               try List.iter (check_rec_call renv) l
               with (FixGuardError _ ) ->
 	        check_rec_call renv(applist(constant_value renv.env kn, l))
@@ -734,14 +723,14 @@ let check_one_fix renv recpos def =
 
         (* The cases below simply check recursively the condition on the
            subterms *)
-        | Cast (a,_, b) -> 
+        | Cast (a,_, b) ->
             List.iter (check_rec_call renv) (a::b::l)
 
         | Lambda (x,a,b) ->
             List.iter (check_rec_call renv) (a::l);
             check_rec_call (push_var_renv renv (x,a)) b
 
-        | Prod (x,a,b) -> 
+        | Prod (x,a,b) ->
             List.iter (check_rec_call renv) (a::l);
             check_rec_call (push_var_renv renv (x,a)) b
 
@@ -787,9 +776,9 @@ let judgment_of_fixpoint (_, types, bodies) =
   array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
 
 let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
-  let nbfix = Array.length bodies in 
+  let nbfix = Array.length bodies in
   if nbfix = 0
-    or Array.length nvect <> nbfix 
+    or Array.length nvect <> nbfix
     or Array.length types <> nbfix
     or Array.length names <> nbfix
     or bodynum < 0
@@ -800,18 +789,18 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
   let raise_err env i err =
     error_ill_formed_rec_body env err names i fixenv vdefj in
   (* Check the i-th definition with recarg k *)
-  let find_ind i k def = 
-    (* check fi does not appear in the k+1 first abstractions, 
+  let find_ind i k def =
+    (* check fi does not appear in the k+1 first abstractions,
        gives the type of the k+1-eme abstraction (must be an inductive)  *)
-    let rec check_occur env n def = 
+    let rec check_occur env n def =
       match kind_of_term (whd_betadeltaiota env def) with
-        | Lambda (x,a,b) -> 
+        | Lambda (x,a,b) ->
 	    if noccur_with_meta n nbfix a then
 	      let env' = push_rel (x, None, a) env in
               if n = k+1 then
                 (* get the inductive type of the fixpoint *)
-                let (mind, _) = 
-                  try find_inductive env a 
+                let (mind, _) =
+                  try find_inductive env a
                   with Not_found ->
 		    raise_err env i (RecursionNotOnInductiveType a) in
                 (mind, (env', b))
@@ -831,7 +820,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
     let renv = make_renv fenv minds nvect.(i) minds.(i) in
     try check_one_fix renv nvect body
     with FixGuardError (fixenv,err) ->
-      error_ill_formed_rec_body fixenv err names i 
+      error_ill_formed_rec_body fixenv err names i
 	(push_rec_types recdef env) (judgment_of_fixpoint recdef)
   done
 
@@ -852,17 +841,17 @@ let rec codomain_is_coind env c =
   let b = whd_betadeltaiota 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 (x, None, a) env) b
+    | _ ->
 	(try find_coinductive env b
         with Not_found ->
 	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
 
-let check_one_cofix env nbfix def deftype = 
+let check_one_cofix env nbfix def deftype =
   let rec check_rec_call env alreadygrd n vlra  t =
     if not (noccur_with_meta n nbfix t) then
       let c,args = decompose_app (whd_betadeltaiota env t) in
-      match kind_of_term c with 
+      match kind_of_term c with
 	| Rel p when  n <= p && p < n+nbfix ->
 	    (* recursive call: must be guarded and no nested recursive
                call allowed *)
@@ -870,14 +859,14 @@ let check_one_cofix env nbfix def deftype =
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
             else if not(List.for_all (noccur_with_meta n nbfix) args) then
 	      raise (CoFixGuardError (env,NestedRecursiveOccurrences))
-		 
+
 	| Construct (_,i as cstr_kn)  ->
-            let lra = vlra.(i-1) in 
+            let lra = vlra.(i-1) in
             let mI = inductive_of_constructor cstr_kn in
 	    let (mib,mip) = lookup_mind_specif env mI in
             let realargs = list_skipn mib.mind_nparams args in
             let rec process_args_of_constr = function
-              | (t::lr), (rar::lrar) -> 
+              | (t::lr), (rar::lrar) ->
                   if rar = mk_norec then
                     if noccur_with_meta n nbfix t
                     then process_args_of_constr (lr, lrar)
@@ -888,26 +877,26 @@ let check_one_cofix env nbfix def deftype =
                     check_rec_call env true n spec t;
                     process_args_of_constr (lr, lrar)
               | [],_ -> ()
-              | _ -> anomaly_ill_typed () 
+              | _ -> anomaly_ill_typed ()
             in process_args_of_constr (realargs, lra)
-		 
+
 	| Lambda (x,a,b) ->
 	     assert (args = []);
             if noccur_with_meta n nbfix a then
               let env' = push_rel (x, None, a) env in
               check_rec_call env' alreadygrd (n+1)  vlra b
-            else 
+            else
 	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
-	      
+
 	| CoFix (j,(_,varit,vdefs as recdef)) ->
             if (List.for_all (noccur_with_meta n nbfix) args)
-            then 
+            then
               let nbfix = Array.length vdefs in
 	      if (array_for_all (noccur_with_meta n nbfix) varit) then
 		let env' = push_rec_types recdef env in
 		(Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs;
 		 List.iter (check_rec_call env alreadygrd n vlra) args)
-              else 
+              else
 		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
 	    else
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall c))
@@ -917,32 +906,32 @@ let check_one_cofix env nbfix def deftype =
               if (noccur_with_meta n nbfix tm) then
 		if (List.for_all (noccur_with_meta n nbfix) args) then
 		  Array.iter (check_rec_call env alreadygrd n vlra) vrest
-		else 
+		else
 		  raise (CoFixGuardError (env,RecCallInCaseFun c))
-              else 
+              else
 		raise (CoFixGuardError (env,RecCallInCaseArg c))
-            else 
+            else
 	      raise (CoFixGuardError (env,RecCallInCasePred c))
-              
+
 	| Meta _ -> ()
         | Evar _ ->
 	    List.iter (check_rec_call env alreadygrd n vlra) args
-	      
-	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in 
+
+	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in
 
   let (mind, _) = codomain_is_coind env deftype in
   let vlra = lookup_subterms env mind in
   check_rec_call env false 1 (dest_subterms vlra) def
 
-(* The  function which checks that the whole block of definitions 
+(* The  function which checks that the whole block of definitions
    satisfies the guarded condition *)
 
-let check_cofix env (bodynum,(names,types,bodies as recdef)) = 
-  let nbfix = Array.length bodies in 
+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 
+    with CoFixGuardError (errenv,err) ->
+      error_ill_formed_rec_body errenv err names i
 	fixenv (judgment_of_fixpoint recdef)
   done
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 8059051b..9ab78cc4 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductive.mli 11301 2008-08-04 19:41:18Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -51,8 +51,9 @@ val arities_of_constructors : inductive -> mind_specif -> types array
 val type_of_constructors : inductive -> mind_specif -> types array
 
 (* Transforms inductive specification into types (in nf) *)
-val arities_of_specif : mutual_inductive -> mind_specif -> types array 
+val arities_of_specif : mutual_inductive -> mind_specif -> types array
 
+val inductive_params : mind_specif -> int
 
 (* [type_case_branches env (I,args) (p:A) c] computes useful types
    about the following Cases expression:
@@ -65,8 +66,12 @@ val type_case_branches :
   env -> inductive * constr list -> unsafe_judgment -> constr
     -> types array * types * constraints
 
+val build_branches_type :
+  inductive -> mutual_inductive_body * one_inductive_body ->
+    constr list -> constr -> types array
+
 (* Return the arity of an inductive type *)
-val mind_arity : one_inductive_body -> Sign.rel_context * sorts_family
+val mind_arity : one_inductive_body -> rel_context * sorts_family
 
 val inductive_sort_family : one_inductive_body -> sorts_family
 
@@ -85,8 +90,8 @@ val type_of_inductive_knowing_parameters :
 
 val max_inductive_sort : sorts array -> universe
 
-val instantiate_universes : env -> Sign.rel_context ->
-    polymorphic_arity -> types array -> Sign.rel_context * sorts
+val instantiate_universes : env -> rel_context ->
+    polymorphic_arity -> types array -> rel_context * sorts
 
 (***************************************************************)
 (* Debug *)
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
new file mode 100644
index 00000000..a628e5cf
--- /dev/null
+++ b/kernel/kernel.mllib
@@ -0,0 +1,32 @@
+Names
+Univ
+Esubst
+Term
+Mod_subst
+Sign
+Cbytecodes
+Copcodes
+Cemitcodes
+Declarations
+Retroknowledge
+Pre_env
+Cbytegen
+Environ
+Conv_oracle
+Closure
+Reduction
+Type_errors
+Entries
+Modops
+Inductive
+Typeops
+Indtypes
+Cooking
+Term_typing
+Subtyping
+Mod_typing
+Safe_typing
+
+Vm
+Csymtable
+Vconv
\ No newline at end of file
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index 9a76922b..f85cfaaf 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -6,97 +6,299 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: mod_subst.ml 11924 2009-02-13 13:51:54Z soubiran $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Names
 open Term
 
-(* WARNING: not every constant in the associative list domain used to exist
-   in the environment. This allows a simple implementation of the join
-   operation. However, iterating over the associative list becomes a non-sense
-*)
-type resolver = (constant * constr option) list
 
-let make_resolver resolve = resolve
+type delta_hint =
+    Inline of constr option
+  | Equiv of kernel_name
+  | Prefix_equiv of module_path
 
-let apply_opt_resolver resolve kn =
- match resolve with
-    None -> None
-  | Some resolve ->
-     try List.assoc kn resolve with Not_found -> None
+type delta_key = 
+    KN of kernel_name
+  | MP of module_path
+
+module Deltamap =  Map.Make(struct 
+			      type t = delta_key
+			      let compare = Pervasives.compare
+			    end)
+
+type delta_resolver = delta_hint Deltamap.t
+
+let empty_delta_resolver = Deltamap.empty
 
 type substitution_domain = 
-    MSI of mod_self_id 
   | MBI of mod_bound_id
   | MPI of module_path
 
 let string_of_subst_domain = function
-   MSI msid -> debug_string_of_msid msid
  | MBI mbid -> debug_string_of_mbid mbid
  | MPI mp -> string_of_mp mp
 
-module Umap = Map.Make(struct 
+module Umap = Map.Make(struct
 			 type t = substitution_domain
 			 let compare = Pervasives.compare
 		       end)
 
-type substitution = (module_path * resolver option) Umap.t
-
+type substitution = (module_path * delta_resolver) Umap.t
+    
 let empty_subst = Umap.empty
 
-let add_msid msid mp =
-  Umap.add (MSI msid) (mp,None)
+
+let string_of_subst_domain = function
+  | MBI mbid -> debug_string_of_mbid mbid
+  | MPI mp -> string_of_mp mp
+      
 let add_mbid mbid mp resolve =
   Umap.add (MBI mbid) (mp,resolve)
-let add_mp mp1 mp2  =
-  Umap.add (MPI mp1) (mp2,None)
+let add_mp mp1 mp2 resolve =
+  Umap.add (MPI mp1) (mp2,resolve)
 
 
-let map_msid msid mp = add_msid msid mp empty_subst
 let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst
-let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst
+let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst
 
+let add_inline_delta_resolver con =
+  Deltamap.add (KN(user_con con)) (Inline None)
+    
+let add_inline_constr_delta_resolver con cstr =
+  Deltamap.add (KN(user_con con)) (Inline (Some cstr))
+
+let add_constant_delta_resolver con =
+  Deltamap.add (KN(user_con con)) (Equiv (canonical_con con))
+
+let add_mind_delta_resolver mind =
+  Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind))
+
+let add_mp_delta_resolver mp1 mp2 = 
+  Deltamap.add (MP mp1) (Prefix_equiv mp2)
+
+let mp_in_delta mp = 
+  Deltamap.mem (MP mp) 
+
+let con_in_delta con resolver = 
+try 
+  match Deltamap.find (KN(user_con con)) resolver with
+  | Inline _  | Prefix_equiv _ -> false
+  | Equiv _ -> true
+with
+ Not_found -> false
+
+let mind_in_delta mind resolver = 
+try 
+  match Deltamap.find (KN(user_mind mind)) resolver with
+  | Inline _  | Prefix_equiv _ -> false
+  | Equiv _ -> true
+with
+ Not_found -> false
+
+let delta_of_mp resolve mp =
+  try 
+    match Deltamap.find (MP mp) resolve with
+      | Prefix_equiv mp1 -> mp1
+      | _ -> anomaly "mod_subst: bad association in delta_resolver"
+  with
+      Not_found -> mp
+	
+let delta_of_kn resolve kn =
+  try 
+    match Deltamap.find (KN kn) resolve with
+      | Equiv kn1 -> kn1
+      | Inline _ -> kn
+      | _ -> anomaly 
+	  "mod_subst: bad association in delta_resolver"
+  with
+      Not_found -> kn
+
+let remove_mp_delta_resolver resolver mp =
+    Deltamap.remove (MP mp) resolver
+
+exception Inline_kn
+
+let rec find_prefix resolve mp = 
+  let rec sub_mp = function
+    | MPdot(mp,l) as mp_sup -> 
+	(try 
+	   match Deltamap.find (MP mp_sup) resolve with
+	     | Prefix_equiv mp1 -> mp1
+	     | _ -> anomaly 
+		 "mod_subst: bad association in delta_resolver"
+	 with
+	     Not_found -> MPdot(sub_mp mp,l))
+    | p -> 
+	match Deltamap.find (MP p) resolve with
+	  | Prefix_equiv mp1 -> mp1
+	  | _ -> anomaly 
+		 "mod_subst: bad association in delta_resolver"	
+  in
+    try 
+      sub_mp mp
+    with
+	Not_found -> mp
+
+exception Change_equiv_to_inline of constr
+
+let solve_delta_kn resolve kn =
+  try 
+      match Deltamap.find (KN kn) resolve with
+	| Equiv kn1 -> kn1
+	| Inline (Some c) -> 
+	    raise (Change_equiv_to_inline c)
+	| Inline None -> raise Inline_kn
+	| _ -> anomaly 
+	    "mod_subst: bad association in delta_resolver"
+  with
+      Not_found | Inline_kn -> 
+	let mp,dir,l = repr_kn kn in
+	let new_mp = find_prefix resolve mp in
+	  if mp == new_mp then 
+	    kn
+	  else
+	    make_kn new_mp dir l
+	      
+
+let constant_of_delta resolve con =
+  let kn = user_con con in
+    try 
+      let new_kn = solve_delta_kn resolve kn in
+	if kn == new_kn then
+	  con
+	else
+	  constant_of_kn_equiv kn new_kn
+    with 
+	_ -> con 
+	
+let constant_of_delta2 resolve con =
+  let kn = canonical_con con in
+  let kn1 = user_con con in
+    try 
+      let new_kn = solve_delta_kn resolve kn in
+	if kn == new_kn then
+	  con
+	else
+	  constant_of_kn_equiv kn1 new_kn
+    with 
+	_ -> con
+
+let mind_of_delta resolve mind =
+  let kn = user_mind mind in
+    try
+      let new_kn = solve_delta_kn resolve kn in
+	if kn == new_kn then
+	  mind
+	else
+	  mind_of_kn_equiv kn new_kn
+    with 
+	_ -> mind 
+
+let mind_of_delta2 resolve mind =
+  let kn = canonical_mind mind in
+  let kn1 = user_mind mind in
+    try
+      let new_kn = solve_delta_kn resolve kn in
+	if kn == new_kn then
+	  mind
+	else
+	  mind_of_kn_equiv kn1 new_kn
+    with 
+	_ -> mind
+	  
+
+let inline_of_delta resolver = 
+  let extract key hint l =
+    match key,hint with 
+      |KN kn, Inline _ -> kn::l
+      | _,_ -> l
+  in
+    Deltamap.fold extract resolver []
+
+exception Not_inline
+  
+let constant_of_delta_with_inline resolve con =
+  let kn1,kn2 = canonical_con con,user_con con in
+    try
+      match Deltamap.find (KN kn2) resolve with 
+	| Inline None -> None
+	| Inline (Some const) -> Some const
+	| _ -> raise Not_inline
+    with
+	Not_found | Not_inline -> 
+	  try match Deltamap.find (KN kn1) resolve with 
+	    | Inline None -> None
+	    | Inline (Some const) -> Some const
+	    | _ -> raise Not_inline
+	  with
+	      Not_found | Not_inline -> None
+
+let string_of_key = function
+      | KN kn -> string_of_kn kn
+      | MP mp -> string_of_mp mp
+
+let string_of_hint = function
+      | Inline _ -> "inline"
+      | Equiv kn -> string_of_kn kn
+      | Prefix_equiv mp -> string_of_mp mp
+
+let debug_string_of_delta resolve =
+  let to_string key hint s = 
+    s^", "^(string_of_key key)^"=>"^(string_of_hint hint)
+  in 
+    Deltamap.fold to_string resolve ""  
+      
 let list_contents sub = 
-  let one_pair uid (mp,_) l =
-    (string_of_subst_domain uid, string_of_mp mp)::l
+  let one_pair uid (mp,reso) l =
+    (string_of_subst_domain uid, string_of_mp mp,debug_string_of_delta reso)::l
   in
     Umap.fold one_pair sub []
-
-let debug_string_of_subst sub = 
-  let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in
+      
+let debug_string_of_subst sub =
+  let l = List.map (fun (s1,s2,s3) -> s1^"|->"^s2^"["^s3^"]")
+    (list_contents sub) in
     "{" ^ String.concat "; " l ^ "}"
+      
+let debug_pr_delta resolve = 
+  str (debug_string_of_delta resolve)
 
-let debug_pr_subst sub = 
+let debug_pr_subst sub =
   let l = list_contents sub in
-  let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) 
+  let f (s1,s2,s3) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++
+			      spc () ++ str "[" ++ str s3 ++ str "]") 
   in
-    str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
-
-
+    str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}"
+      
+      
 let subst_mp0 sub mp = (* 's like subst *)
  let rec aux mp =
   match mp with
-    | MPself sid -> 
-        let mp',resolve = Umap.find (MSI sid) sub in
+    | MPfile sid -> 
+        let mp',resolve = Umap.find (MPI (MPfile sid)) sub in
          mp',resolve
     | MPbound bid ->
-        let mp',resolve = Umap.find (MBI bid) sub in
-          mp',resolve
+	begin
+	  try
+            let mp',resolve = Umap.find (MBI bid) sub in
+              mp',resolve
+	  with Not_found ->
+	    let mp',resolve = Umap.find (MPI mp) sub in
+              mp',resolve
+	end
     | MPdot (mp1,l) as mp2 ->
 	begin
-	  try  
+	  try
 	    let mp',resolve = Umap.find (MPI mp2) sub in
               mp',resolve
-	  with Not_found ->    
+	  with Not_found ->
 	    let mp1',resolve = aux mp1 in
 	      MPdot (mp1',l),resolve
 	end
-    | _ -> raise Not_found
  in
   try
-    Some (aux mp) 
+    Some (aux mp)
   with Not_found -> None
 
 let subst_mp sub mp =
@@ -104,39 +306,126 @@ let subst_mp sub mp =
     None -> mp
   | Some (mp',_) -> mp'
 
+let subst_kn_delta sub kn =
+ let mp,dir,l = repr_kn kn in
+  match subst_mp0 sub mp with
+     Some (mp',resolve) ->
+      solve_delta_kn resolve (make_kn mp' dir l)
+   | None -> kn
+
 
-let subst_kn0 sub kn =
+let subst_kn sub kn =
  let mp,dir,l = repr_kn kn in
   match subst_mp0 sub mp with
      Some (mp',_) ->
-      Some (make_kn mp' dir l)
-   | None -> None
+      (make_kn mp' dir l)
+   | None -> kn
 
-let subst_kn sub kn =
- match subst_kn0 sub kn with
-    None -> kn
-  | Some kn' -> kn'
+exception No_subst
+
+type sideconstantsubst =
+  | User
+  | Canonical
+
+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
+    try 
+      let side,mind',resolve =   
+        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_mind_equiv mp1' mp2' dir l), resolve2 
+      in
+	match side with
+	  |User ->
+	     let mind = mind_of_delta resolve mind' in
+	       mind
+	  |Canonical ->
+	     let mind = mind_of_delta2 resolve mind' in
+	       mind
+    with 
+	No_subst -> mind
+
+let subst_mind0 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
+    try 
+      let side,mind',resolve =   
+        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_mind_equiv mp1' mp2' dir l), resolve2
+      in
+	match side with
+	  |User ->
+	     let mind = mind_of_delta resolve mind' in
+	       Some mind
+	  |Canonical ->
+	     let mind = mind_of_delta2 resolve mind' in
+	       Some mind
+    with 
+	No_subst -> Some mind
 
 let subst_con sub con =
- let mp,dir,l = repr_con con in
-  match subst_mp0 sub mp with
-     None -> con,mkConst con
-   | Some (mp',resolve) ->
-      let con' = make_con mp' dir l in
-       match apply_opt_resolver resolve con with
-          None -> con',mkConst con'
-        | Some t -> con',t
+  let kn1,kn2 = user_con con,canonical_con con in
+  let mp1,dir,l = repr_kn kn1 in
+  let mp2,_,_ = repr_kn kn2 in
+    try 
+      let side,con',resolve =   
+        match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_con_equiv mp1' mp2' dir l), resolve2 
+      in
+	match constant_of_delta_with_inline resolve con' with
+            None -> begin
+	      match side with
+	      |User ->
+	      let con = constant_of_delta resolve con' in
+		con,mkConst con
+	      |Canonical ->
+		  let con = constant_of_delta2 resolve con' in
+		con,mkConst con
+	    end
+	  | Some t -> con',t
+    with No_subst -> con , mkConst con 
+ 
 
 let subst_con0 sub con =
- let mp,dir,l = repr_con con in
-  match subst_mp0 sub mp with
-      None -> None
-    | Some (mp',resolve) ->
-	let con' = make_con mp' dir l in
-       match apply_opt_resolver resolve con with
-           None -> Some (mkConst con')
-         | Some t -> Some t
-
+  let kn1,kn2 = user_con con,canonical_con con in
+  let mp1,dir,l = repr_kn kn1 in
+  let mp2,_,_ = repr_kn kn2 in
+    try  
+      let side,con',resolve =   
+	match subst_mp0 sub mp1,subst_mp0 sub mp2 with
+	    None,None ->raise No_subst
+	  | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
+	  | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
+	  | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
+	      (make_con_equiv mp1' mp2' dir l), resolve2 
+      in
+	match constant_of_delta_with_inline resolve con' with
+	    None ->begin
+	      match side with
+	      |User ->
+	      let con = constant_of_delta resolve con' in
+		Some (mkConst con)
+	      |Canonical ->
+		  let con = constant_of_delta2 resolve con' in
+		Some (mkConst con)
+	    end
+	  | t ->  t
+    with No_subst -> Some (mkConst con) 
+		
 (* Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
    Does the user mean "Unfold X.t" or does she mean "Unfold y"
@@ -148,352 +437,296 @@ let subst_evaluable_reference subst = function
 
 
 
-let rec map_kn f f' c = 
+let rec map_kn f f' c =
   let func = map_kn f f' in
     match kind_of_term c with
-      | Const kn -> 
+      | Const kn ->
 	  (match f' kn with
 	       None -> c
 	     | Some const ->const)
-      | Ind (kn,i) -> 
+      | Ind (kn,i) ->
          (match f kn with
              None -> c
            | Some kn' ->
 	      mkInd (kn',i))
-      | Construct ((kn,i),j) -> 
+      | Construct ((kn,i),j) ->
          (match f kn with
              None -> c
            | Some kn' ->
 	       mkConstruct ((kn',i),j))
-      | Case (ci,p,ct,l) -> 
+      | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
               (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
 	  let p' = func p in
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
-	    if (ci.ci_ind==ci_ind && p'==p 
+	    if (ci.ci_ind==ci_ind && p'==p
 		&& l'==l && ct'==ct)then c
-	    else 
+	    else
 	      mkCase ({ci with ci_ind = ci_ind},
-		      p',ct', l')  
-      | Cast (ct,k,t) -> 
+		      p',ct', l')
+      | Cast (ct,k,t) ->
 	  let ct' = func ct in
 	  let t'= func t in
-	    if (t'==t && ct'==ct) then c 
+	    if (t'==t && ct'==ct) then c
 	    else mkCast (ct', k, t')
-      | Prod (na,t,ct) -> 
+      | Prod (na,t,ct) ->
 	  let ct' = func ct in
 	  let t'= func t in
-	    if (t'==t && ct'==ct) then c 
+	    if (t'==t && ct'==ct) then c
 	    else mkProd (na, t', ct')
-      | Lambda (na,t,ct) -> 
+      | Lambda (na,t,ct) ->
 	  let ct' = func ct in
 	  let t'= func t in
-	    if (t'==t && ct'==ct) then c 
+	    if (t'==t && ct'==ct) then c
 	    else mkLambda (na, t', ct')
-      | LetIn (na,b,t,ct) -> 
+      | LetIn (na,b,t,ct) ->
 	  let ct' = func ct in
 	  let t'= func t in
 	  let b'= func b in
-	    if (t'==t && ct'==ct && b==b') then c 
+	    if (t'==t && ct'==ct && b==b') then c
 	    else mkLetIn (na, b', t', ct')
-      | App (ct,l) -> 
+      | App (ct,l) ->
 	  let ct' = func ct in
 	  let l' = array_smartmap func l in
 	    if (ct'== ct && l'==l) then c
 	    else mkApp (ct',l')
-      | Evar (e,l) -> 
+      | Evar (e,l) ->
 	  let l' = array_smartmap func l in
 	    if (l'==l) then c
 	    else mkEvar (e,l')
       | Fix (ln,(lna,tl,bl)) ->
 	  let tl' = array_smartmap func tl in
 	  let bl' = array_smartmap func bl in
-	    if (bl == bl'&& tl == tl') then c  
+	    if (bl == bl'&& tl == tl') then c
 	    else mkFix (ln,(lna,tl',bl'))
       | CoFix(ln,(lna,tl,bl)) ->
 	  let tl' = array_smartmap func tl in
 	  let bl' = array_smartmap func bl in
-	    if (bl == bl'&& tl == tl') then c  
+	    if (bl == bl'&& tl == tl') then c
 	    else mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
 
-let subst_mps sub = 
-  map_kn (subst_kn0 sub) (subst_con0 sub)
+let subst_mps sub =
+  map_kn (subst_mind0 sub) (subst_con0 sub)
 
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
     | _ when mp = mpfrom -> mpto
-    | MPdot (mp1,l) -> 
+    | MPdot (mp1,l) ->
 	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
 	  if mp1==mp1' then mp
 	  else MPdot (mp1',l)
     | _ -> mp
 
-let replace_mp_in_con mpfrom mpto kn =
- let mp,dir,l = repr_con kn in
+let replace_mp_in_kn mpfrom mpto kn =
+ let mp,dir,l = repr_kn kn in
   let mp'' = replace_mp_in_mp mpfrom mpto mp in
     if mp==mp'' then kn
-    else make_con mp'' dir l
+    else make_kn mp'' dir l
 
-exception BothSubstitutionsAreIdentitySubstitutions
-exception ChangeDomain of resolver
+let rec mp_in_mp mp mp1 =
+  match mp1 with
+    | _ when mp1 = mp -> true
+    | MPdot (mp2,l) -> mp_in_mp mp mp2
+    | _ -> false
+	
+let mp_in_key mp key = 
+  match key with
+    | MP mp1 -> 
+	mp_in_mp mp mp1
+    | KN kn -> 
+	let mp1,dir,l = repr_kn kn in
+	  mp_in_mp mp mp1
+	    
+let subset_prefixed_by mp resolver =
+  let prefixmp key hint resolv =
+    match hint with 
+      | Inline _ -> resolv
+      | _ ->
+	  if mp_in_key mp key then
+	    Deltamap.add key hint resolv
+	  else 
+	    resolv
+  in
+    Deltamap.fold prefixmp resolver empty_delta_resolver
 
-let join (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst (sub : substitution) key (mp,resolve) =
-    let mp',resolve' =
-      match subst_mp0 sub mp with
-	  None -> mp, None
-	| Some (mp',resolve') -> mp',resolve' in
-    let resolve'' : resolver option =
-      try
-	let res =
-	  match resolve with
-	    |None -> begin
-		match resolve' with
-		    None -> raise BothSubstitutionsAreIdentitySubstitutions
-		  | Some res -> raise (ChangeDomain res) end
-	    | Some res -> res
-	in
-	  Some
-	    (List.map
-               (fun (kn,topt) ->
-		  kn,
-		  match topt with
-		      None ->
-			(match key with
-			     MSI msid ->
-			       let kn' = replace_mp_in_con (MPself msid) mp kn in
-				 apply_opt_resolver resolve' kn'
-			   | MBI mbid ->
-			       let kn' = replace_mp_in_con (MPbound mbid) mp kn in
-				 apply_opt_resolver resolve' kn'
-			   | MPI mp1 ->
-			       let kn' = replace_mp_in_con mp1 mp kn in
-				 apply_opt_resolver resolve' kn')
-		    | Some t -> Some (subst_mps sub t)) res)
-      with
-	  BothSubstitutionsAreIdentitySubstitutions -> None
-	| ChangeDomain res ->
-	    let rec changeDom = function
-	      | [] -> []
-	      | (kn,topt)::r ->
-		  let key' =
-		    match key with
-			MSI msid -> MPself msid
-                      | MBI mbid -> MPbound mbid 
-		      | MPI mp1 -> mp1 in
-		  let kn' = replace_mp_in_con mp key' kn in
-		    if kn==kn' then
-		      (*the key does not appear in kn, we remove it
-			from the resolver that we are building*)
-		      changeDom r
-		    else
-		      (kn',topt)::(changeDom r)
-	    in
-	      Some (changeDom res)
-    in
-      mp',resolve'' in
-  let subst = Umap.mapi (apply_subst subst2) subst1 in
-    (Umap.fold Umap.add subst2 subst)
-      
-let subst_key subst1 subst2 =
-  let replace_in_key key (mp,resolve) sub=
-    let newkey = 
-      match key with
-	| MPI mp1 -> 
-	    begin
-	      match subst_mp0 subst1 mp1 with
-		| None -> None
-		| Some (mp2,_) -> Some (MPI mp2)
-	    end
-	| _ -> None
-    in
-      match newkey with
-	| None -> Umap.add key (mp,resolve) sub
-	| Some mpi -> Umap.add mpi (mp,resolve) sub
+let subst_dom_delta_resolver subst resolver =
+  let apply_subst key hint resolver =
+    match key with
+	(MP mp) ->
+	  Deltamap.add (MP (subst_mp subst mp)) hint resolver
+      | (KN kn) ->
+	  Deltamap.add (KN (subst_kn subst kn)) hint resolver
   in
-    Umap.fold replace_in_key subst2 empty_subst
-
-let update_subst_alias subst1 subst2 =
- let subst_inv key (mp,resolve) sub =
-    let newmp = 
-      match key with 
-	| MBI msid -> MPbound msid
-	| MSI msid -> MPself msid
-	| MPI mp -> mp
-    in
-   match mp with 
-     | MPbound mbid -> Umap.add (MBI mbid) (newmp,None) sub
-     | MPself msid -> Umap.add (MSI msid) (newmp,None) sub
-     | _ ->  Umap.add (MPI mp) (newmp,None) sub
-  in 
-  let subst_mbi = Umap.fold subst_inv subst2 empty_subst in
-  let alias_subst key (mp,resolve) sub=
-    let newkey = 
-      match key with
-	| MPI mp1 -> 
-	    begin
-	      match subst_mp0 subst_mbi mp1 with
-		| None -> None
-		| Some (mp2,_) -> Some (MPI mp2)
-	    end
-	| _ -> None
-    in
-      match newkey with
-	| None -> Umap.add key (mp,resolve) sub
-	| Some mpi -> Umap.add mpi (mp,resolve) sub
+    Deltamap.fold apply_subst resolver empty_delta_resolver
+
+let subst_mp_delta sub mp key=
+ match subst_mp0 sub mp with
+    None -> empty_delta_resolver,mp
+  | Some (mp',resolve) -> 
+      let mp1 = find_prefix resolve mp' in
+      let resolve1 = subset_prefixed_by mp1 resolve in
+	match key with
+	    MP mpk ->
+	      (subst_dom_delta_resolver 
+		 (map_mp mp1 mpk empty_delta_resolver) resolve1),mp1
+	  | _ -> anomaly "Mod_subst: Bad association in resolver" 
+
+let subst_codom_delta_resolver subst resolver =
+  let apply_subst key hint resolver =
+    match hint with
+	Prefix_equiv mp ->
+	  let derived_resolve,mpnew = subst_mp_delta subst mp key in
+	    Deltamap.fold Deltamap.add derived_resolve
+	      (Deltamap.add key (Prefix_equiv mpnew) resolver)
+      | (Equiv kn) ->
+	  (try
+	     Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
+	   with
+	       Change_equiv_to_inline c ->
+		 Deltamap.add key (Inline (Some c)) resolver)
+      | Inline None ->
+	  Deltamap.add key hint resolver
+      | Inline (Some t) ->
+	  Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
   in
-    Umap.fold alias_subst subst1 empty_subst
-
-let update_subst subst1 subst2 =
- let subst_inv key (mp,resolve) l =
-    let newmp = 
-      match key with 
-	| MBI msid -> MPbound msid
-	| MSI msid -> MPself msid
-	| MPI mp -> mp
-    in
-   match mp with 
-     | MPbound mbid ->  ((MBI mbid),newmp,resolve)::l
-     | MPself msid ->  ((MSI msid),newmp,resolve)::l
-     | _ ->   ((MPI mp),newmp,resolve)::l
-  in 
-  let subst_mbi = Umap.fold subst_inv subst2 [] in
-  let alias_subst key (mp,resolve) sub=
-    let newsetkey = 
-      match key with
-	| MPI mp1 -> 
-	    let compute_set_newkey l (k,mp',resolve) = 
-	      let mp_from_key = match k with
-		  	| MBI msid -> MPbound msid
-			| MSI msid -> MPself msid
-			| MPI mp -> mp
-	      in
-	      let new_mp1 = replace_mp_in_mp mp_from_key mp' mp1 in
-		if new_mp1 == mp1 then l else (MPI new_mp1,resolve)::l
-	    in
-	    begin
-	      match List.fold_left compute_set_newkey [] subst_mbi with
-		| [] -> None
-		| l -> Some (l)
-	    end
-	| _ -> None
+    Deltamap.fold apply_subst resolver empty_delta_resolver
+
+let subst_dom_codom_delta_resolver subst resolver =
+  let apply_subst key hint resolver =
+    match key,hint with
+	(MP mp1),Prefix_equiv mp ->
+	  let key = MP (subst_mp subst mp1) in
+	  let derived_resolve,mpnew = subst_mp_delta subst mp key in
+	    Deltamap.fold Deltamap.add derived_resolve
+	      (Deltamap.add key (Prefix_equiv mpnew) resolver)
+      | (KN kn1),(Equiv kn) ->
+	  let key = KN (subst_kn subst kn1) in
+	    (try
+	       Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
+	     with
+		 Change_equiv_to_inline c ->
+		   Deltamap.add key (Inline (Some c)) resolver)
+      | (KN kn),Inline None ->
+	  let key = KN (subst_kn subst kn) in
+	    Deltamap.add key hint resolver
+      | (KN kn),Inline (Some t) ->
+	  let key = KN (subst_kn subst kn) in
+	  Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
+      | _,_ -> anomaly "Mod_subst: Bad association in resolver" 
+  in
+    Deltamap.fold apply_subst resolver empty_delta_resolver
+
+let update_delta_resolver resolver1 resolver2 =
+ let apply_res key hint res = 
+      try
+	if Deltamap.mem key resolver2 then
+	  res else
+	match hint with
+	    Prefix_equiv mp ->
+	      let new_hint =
+		Prefix_equiv (find_prefix resolver2 mp)
+	      in Deltamap.add key new_hint res
+	  | Equiv kn ->
+	      (try 
+		 let new_hint =
+		   Equiv (solve_delta_kn resolver2 kn)
+		 in Deltamap.add key new_hint res
+	       with
+		   Change_equiv_to_inline c ->
+		     Deltamap.add key (Inline (Some c)) res)
+	  | _ -> Deltamap.add key hint res
+      with not_found -> 
+	Deltamap.add key hint res
     in
-      match newsetkey with
-	| None -> sub
-	| Some l -> 
-	    List.fold_left (fun s (k,r) -> Umap.add k (mp,r) s)
-	      sub l
+      Deltamap.fold apply_res resolver1 empty_delta_resolver
+
+let add_delta_resolver resolver1 resolver2 =
+  if resolver1 == resolver2 then
+    resolver2
+  else if resolver2 = empty_delta_resolver then
+    resolver1
+  else
+    Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2)
+      resolver2
+
+let substition_prefixed_by k mp subst =
+  let prefixmp key (mp_to,reso) sub =
+    match key with 
+      | MPI mpk ->
+	  if mp_in_mp mp mpk && mp <> mpk then
+	    let new_key = replace_mp_in_mp mp k mpk in
+	      Umap.add (MPI new_key) (mp_to,reso) sub
+	  else 
+	    sub
+      |  _ -> sub
   in
-    Umap.fold alias_subst subst1 empty_subst
+    Umap.fold prefixmp subst empty_subst
 
-let join_alias (subst1 : substitution) (subst2 : substitution) =
-  let apply_subst (sub : substitution) key (mp,resolve) =
+let join (subst1 : substitution) (subst2 : substitution) =
+  let apply_subst key (mp,resolve) res =
     let mp',resolve' =
-      match subst_mp0 sub mp with
+      match subst_mp0 subst2 mp with
 	  None -> mp, None
-	| Some (mp',resolve') -> mp',resolve' in
-    let resolve'' : resolver option =
-      try
-	let res =
-	  match resolve with
-              Some res -> res
-	    | None ->
-		match resolve' with
-		    None -> raise BothSubstitutionsAreIdentitySubstitutions
-		  | Some res -> raise (ChangeDomain res)
-	in
-	  Some
-	    (List.map
-               (fun (kn,topt) ->
-		  kn,
-		  match topt with
-		      None ->
-			(match key with
-			     MSI msid ->
-			       let kn' = replace_mp_in_con (MPself msid) mp kn in
-				 apply_opt_resolver resolve' kn'
-			   | MBI mbid ->
-			       let kn' = replace_mp_in_con (MPbound mbid) mp kn in
-				 apply_opt_resolver resolve' kn'
-			   | MPI mp1 ->
-			       let kn' = replace_mp_in_con mp1 mp kn in
-				 apply_opt_resolver resolve' kn')
-		    | Some t -> Some (subst_mps sub t)) res)
-      with
-	  BothSubstitutionsAreIdentitySubstitutions -> None
-	| ChangeDomain res ->
-	    let rec changeDom = function
-	      | [] -> []
-	      | (kn,topt)::r ->
-		  let key' =
-		    match key with
-			MSI msid -> MPself msid
-                      | MBI mbid -> MPbound mbid 
-		      | MPI mp1 -> mp1 in
-		  let kn' = replace_mp_in_con mp key' kn in
-		    if kn==kn' then
-		      (*the key does not appear in kn, we remove it
-			from the resolver that we are building*)
-		      changeDom r
-		    else
-		      (kn',topt)::(changeDom r)
-	    in
-	      Some (changeDom res)
+	| Some (mp',resolve') ->  mp'
+	    ,Some resolve' in
+    let resolve'' : delta_resolver =
+      match resolve' with
+          Some res -> 
+	    add_delta_resolver 
+	      (subst_dom_codom_delta_resolver subst2 resolve) res
+	| None -> 
+	    subst_codom_delta_resolver subst2 resolve
     in
-      mp',resolve'' in
-  Umap.mapi (apply_subst subst2) subst1 
+    let k = match key with MBI mp -> MPbound mp | MPI mp -> mp in
+    let prefixed_subst = substition_prefixed_by k mp subst2 in
+      Umap.fold Umap.add prefixed_subst 
+	(Umap.add key (mp',resolve'') res) in
+  let subst = Umap.fold apply_subst subst1 empty_subst in
+    (Umap.fold Umap.add subst2 subst)   
+
 
-let remove_alias subst =
-  let rec remove key (mp,resolve) sub =
-    match key with
-	MPI _ -> sub
-      | _ -> Umap.add key (mp,resolve) sub
-  in
-    Umap.fold remove subst empty_subst
-      
 
 let rec occur_in_path uid path =
  match uid,path with
-  | MSI sid,MPself sid' -> sid = sid'
   | MBI bid,MPbound bid' -> bid = bid'
   | _,MPdot (mp1,_) -> occur_in_path uid mp1
   | _ -> false
-    
-let occur_uid uid sub = 
+
+let occur_uid uid sub =
   let check_one uid' (mp,_) =
     if uid = uid' || occur_in_path uid mp then raise Exit
   in
-    try 
+    try
       Umap.iter check_one sub;
       false
     with Exit -> true
 
-let occur_msid uid = occur_uid (MSI uid)
+
 let occur_mbid uid = occur_uid (MBI uid)
-    
+
 type 'a lazy_subst =
   | LSval of 'a
-  | LSlazy of substitution * 'a
-	
+  | LSlazy of substitution list * 'a
+
 type 'a substituted = 'a lazy_subst ref
-      
+
 let from_val a = ref (LSval a)
-    
-let force fsubst r = 
+
+let force fsubst r =
   match !r with
   | LSval a -> a
-  | LSlazy(s,a) -> 
-      let a' = fsubst s a in
+  | LSlazy(s,a) ->
+      let subst = List.fold_left join empty_subst (List.rev s) in
+      let a' = fsubst subst a in
       r := LSval a';
-      a' 
+      a'
 
 let subst_substituted s r =
   match !r with
-    | LSval a -> ref (LSlazy(s,a))
+    | LSval a -> ref (LSlazy([s],a))
     | LSlazy(s',a) ->
-	let s'' = join s' s in
-	  ref (LSlazy(s'',a))
-	    
+	  ref (LSlazy(s::s',a))
+
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index a2e45c52..a948d164 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -6,35 +6,83 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_subst.mli 10849 2008-04-25 15:55:16Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*s [Mod_subst] *)
 
 open Names
 open Term
 
-type resolver
+(* A delta_resolver maps name (constant, inductive, module_path) 
+   to canonical name  *)
+type delta_resolver
+
 type substitution
 
-val make_resolver :  (constant * constr option) list -> resolver
+val empty_delta_resolver : delta_resolver
+
+val add_inline_delta_resolver : constant -> delta_resolver -> delta_resolver
+
+val add_inline_constr_delta_resolver :  constant -> constr -> delta_resolver 
+  -> delta_resolver
+
+val add_constant_delta_resolver : constant -> delta_resolver -> delta_resolver
+
+val add_mind_delta_resolver : mutual_inductive -> delta_resolver -> delta_resolver
+
+val add_mp_delta_resolver : module_path -> module_path -> delta_resolver 
+  -> delta_resolver
+
+val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver
+
+(* Apply the substitution on the domain of the resolver  *)
+val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver
+
+(* Apply the substitution on the codomain of the resolver  *)
+val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver
+
+val subst_dom_codom_delta_resolver : 
+  substitution -> delta_resolver -> delta_resolver
+
+(* *_of_delta return the associated name of arg2 in arg1   *)
+val constant_of_delta : delta_resolver -> constant -> constant
+
+val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
+
+val delta_of_mp : delta_resolver -> module_path -> module_path
+
+(* Extract the set of inlined constant in the resolver *)
+val inline_of_delta : delta_resolver -> kernel_name list
+
+(* remove_mp is used for the computation of a resolver induced by Include P *)
+val remove_mp_delta_resolver : delta_resolver -> module_path -> delta_resolver
+
+
+(* mem tests *)
+val mp_in_delta : module_path -> delta_resolver -> bool
+
+val con_in_delta : constant -> delta_resolver -> bool
+
+val mind_in_delta : mutual_inductive -> delta_resolver -> bool
+
+(*substitution*)
 
 val empty_subst : substitution
 
-val add_msid : 
-  mod_self_id -> module_path -> substitution -> substitution
-val add_mbid : 
-  mod_bound_id -> module_path -> resolver option -> substitution -> substitution
+(* add_* add [arg2/arg1]{arg3} to the substitution with no 
+   sequential composition  *)
+val add_mbid :
+  mod_bound_id -> module_path -> delta_resolver  -> substitution -> substitution
 val add_mp :
-  module_path -> module_path -> substitution -> substitution
+  module_path -> module_path -> delta_resolver -> substitution -> substitution
 
-val map_msid :
-  mod_self_id -> module_path -> substitution
+(* map_* create a new substitution [arg2/arg1]{arg3} *)
 val map_mbid :
-  mod_bound_id -> module_path -> resolver option -> substitution
+  mod_bound_id -> module_path -> delta_resolver -> substitution
 val map_mp :
-  module_path -> module_path -> substitution
+  module_path -> module_path -> delta_resolver -> substitution
 
-(* sequential composition: 
+(* sequential composition:
    [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
 *)
 val join : substitution -> substitution -> substitution
@@ -47,16 +95,21 @@ val subst_substituted : substitution -> 'a substituted -> 'a substituted
 (*i debugging *)
 val debug_string_of_subst : substitution -> string
 val debug_pr_subst : substitution -> Pp.std_ppcmds
+val debug_string_of_delta : delta_resolver -> string
+val debug_pr_delta : delta_resolver -> Pp.std_ppcmds
 (*i*)
 
 (* [subst_mp sub mp] guarantees that whenever the result of the
-   substitution is structutally equal [mp], it is equal by pointers 
-   as well [==] *) 
+   substitution is structutally equal [mp], it is equal by pointers
+   as well [==] *)
 
-val subst_mp : 
+val subst_mp :
   substitution -> module_path -> module_path
 
-val subst_kn :
+val subst_ind :
+  substitution -> mutual_inductive -> mutual_inductive
+
+val subst_kn : 
   substitution -> kernel_name -> kernel_name
 
 val subst_con :
@@ -71,24 +124,14 @@ val subst_evaluable_reference :
   substitution -> evaluable_global_reference -> evaluable_global_reference
 
 (* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
-val replace_mp_in_con : module_path -> module_path -> constant -> constant
+val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name
 
 (* [subst_mps sub c] performs the substitution [sub] on all kernel
    names appearing in [c] *)
 val subst_mps : substitution -> constr -> constr
 
-(* [occur_*id id sub] returns true iff [id] occurs in [sub] 
+(* [occur_*id id sub] returns true iff [id] occurs in [sub]
    on either side *)
 
-val occur_msid : mod_self_id -> substitution -> bool
 val occur_mbid : mod_bound_id -> substitution -> bool
 
-val update_subst_alias : substitution -> substitution -> substitution
-
-val update_subst : substitution -> substitution -> substitution
-
-val subst_key : substitution -> substitution -> substitution
-
-val join_alias : substitution -> substitution -> substitution
-
-val remove_alias : substitution -> substitution
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 4a9fb606..f0ca555c 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.ml 11514 2008-10-28 13:39:02Z soubiran $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
@@ -30,61 +30,45 @@ let rec list_split_assoc k rev_before = function
   | (k',b)::after when k=k' -> rev_before,b,after
   | h::tail -> list_split_assoc k (h::rev_before) tail
 
-let rec list_fold_map2 f e = function 
+let rec list_fold_map2 f e = function
   |  []  -> (e,[],[])
-  |  h::t -> 
+  |  h::t ->
        let e',h1',h2' = f e h in
        let e'',t1',t2' = list_fold_map2 f e' t in
 	 e'',h1'::t1',h2'::t2'
 
+let discr_resolver env mtb =
+     match mtb.typ_expr with
+	SEBstruct _ -> 
+	  mtb.typ_delta
+      | _ -> (*case mp is a functor *)
+	  empty_delta_resolver
+	
 let rec rebuild_mp mp l =
   match l with
       []-> mp
     | i::r -> rebuild_mp (MPdot(mp,i)) r 
-
-let type_of_struct env b meb = 
-  let rec aux env = function 
-  | SEBfunctor (mp,mtb,body) ->
-      let env = add_module (MPbound mp) (module_body_of_type mtb) env in
-	SEBfunctor(mp,mtb, aux env body)
-  | SEBident mp -> 
-      strengthen env (lookup_modtype mp env).typ_expr mp
-  | SEBapply _ as mtb -> eval_struct env mtb
-  | str -> str
-  in
-    if b then
-      Some (aux env meb)
+	
+let rec check_with env sign with_decl alg_sign mp equiv = 
+  let sign,wd,equiv,cst= match with_decl with
+    | With_Definition (id,_) ->
+	let sign,cb,cst = check_with_aux_def env sign with_decl mp equiv in
+	  sign,With_definition_body(id,cb),equiv,cst
+    | With_Module (id,mp1) -> 
+	let sign,equiv,cst = 
+	  check_with_aux_mod env sign with_decl mp equiv in
+	  sign,With_module_body(id,mp1),equiv,cst in
+    if alg_sign = None then
+      sign,None,equiv,cst
     else
-    None
-
-let rec bounded_str_expr = function
-     | SEBfunctor (mp,mtb,body) -> bounded_str_expr body
-     | SEBident mp -> (check_bound_mp mp)
-     | SEBapply (f,a,_)->(bounded_str_expr f)
-     | _ -> false
-
-let return_opt_type mp env mtb = 
-  if (check_bound_mp mp) then
-    Some (strengthen env mtb.typ_expr mp)
-  else
-    None
-
-let rec check_with env mtb with_decl = 
-  match with_decl with
-    | With_Definition (id,_) -> 
-	let cb = check_with_aux_def env mtb with_decl in
-	  SEBwith(mtb,With_definition_body(id,cb)),empty_subst
-    | With_Module (id,mp) -> 
-	let cst,sub,typ_opt = check_with_aux_mod env mtb with_decl true in
-	  SEBwith(mtb,With_module_body(id,mp,typ_opt,cst)),sub
-
-and check_with_aux_def env mtb with_decl = 
-  let msid,sig_b = match (eval_struct env mtb) with 
-    | SEBstruct(msid,sig_b) ->
-	msid,sig_b
-    | _ -> error_signature_expected mtb
+      sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst
+	    
+and check_with_aux_def env sign with_decl mp equiv = 
+  let sig_b = match sign with 
+    | SEBstruct(sig_b) -> sig_b
+    | _ -> error_signature_expected sign
   in
-  let id,idl = match with_decl with 
+  let id,idl = match with_decl with
     | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
     | With_Definition ([],_) | With_Module ([],_) -> assert false
   in
@@ -92,43 +76,43 @@ and check_with_aux_def env mtb with_decl =
     try
       let rev_before,spec,after = list_split_assoc l [] sig_b in
       let before = List.rev rev_before in
-      let env' = Modops.add_signature (MPself msid) before env in
+      let env' = Modops.add_signature mp before equiv env in
 	match with_decl with
           | With_Definition ([],_) -> assert false
-	  | With_Definition ([id],c) -> 
+	  | With_Definition ([id],c) ->
 	      let cb = match spec with
 		  SFBconst cb -> cb
 		| _ -> error_not_a_constant l
-	      in 
+	      in
 		begin
 		  match cb.const_body with
-		    | None -> 
+		    | None ->
 			let (j,cst1) = Typeops.infer env' c in
 			let typ = Typeops.type_of_constant_type env' cb.const_type in
 			let cst2 = Reduction.conv_leq env' j.uj_type typ in
-			let cst = 
-			  Constraint.union 
+			let cst =
+			  Constraint.union
 			    (Constraint.union cb.const_constraints cst1)
 			    cst2 in
 			let body = Some (Declarations.from_val j.uj_val) in
-			let cb' = {cb with 
+			let cb' = {cb with
 				     const_body = body;
 				     const_body_code = Cemitcodes.from_val
                             (compile_constant_body env' body false false);
                                      const_constraints = cst} in
-			  cb'
-		    | Some b -> 
+			  SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
+		    | Some b ->
 			let cst1 = Reduction.conv env' c (Declarations.force b) in
 			let cst = Constraint.union cb.const_constraints cst1 in
 			let body = Some (Declarations.from_val c) in
-			let cb' = {cb with 
+			let cb' = {cb with
 				     const_body = body;
 				     const_body_code = Cemitcodes.from_val
                             (compile_constant_body env' body false false);
                                      const_constraints = cst} in
-			  cb'
+			  SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
 	      end
-	  | With_Definition (_::_,_) ->
+	  | With_Definition (_::_,c) ->
 	      let old = match spec with
 		  SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
@@ -136,10 +120,14 @@ and check_with_aux_def env mtb with_decl =
 		begin
 		  match old.mod_expr with
                     | None ->
-			let new_with_decl = match with_decl with
-			    With_Definition (_,c) -> With_Definition (idl,c)
-			  | With_Module (_,c) -> With_Module (idl,c) in 
-			  check_with_aux_def env' (type_of_mb env old) new_with_decl
+			let new_with_decl = With_Definition (idl,c) in 
+			let sign,cb,cst = 
+			  check_with_aux_def env' old.mod_type new_with_decl 
+			    (MPdot(mp,l)) old.mod_delta in
+			let new_spec = SFBmodule({old with
+						    mod_type = sign;
+						    mod_type_alg = None}) in
+			  SEBstruct(before@((l,new_spec)::after)),cb,cst
                     | Some msb ->
 			error_a_generative_module_expected l
 		end
@@ -148,13 +136,12 @@ and check_with_aux_def env mtb with_decl =
 	Not_found -> error_no_such_label l
       | Reduction.NotConvertible -> error_with_incorrect l
 
-and check_with_aux_mod env mtb with_decl now = 
-  let initmsid,msid,sig_b = match (eval_struct env mtb) with 
-    | SEBstruct(msid,sig_b) ->let msid'=(refresh_msid msid) in
-	msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b)
-    | _ -> error_signature_expected mtb
+and check_with_aux_mod env sign with_decl mp equiv = 
+  let sig_b = match sign with 
+    | SEBstruct(sig_b) ->sig_b
+    | _ -> error_signature_expected sign
   in
-  let id,idl = match with_decl with 
+  let id,idl = match with_decl with
     | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
     | With_Definition ([],_) | With_Module ([],_) -> assert false
   in
@@ -163,265 +150,329 @@ and check_with_aux_mod env mtb with_decl now =
       let rev_before,spec,after = list_split_assoc l [] sig_b in
       let before = List.rev rev_before in
       let rec mp_rec = function
-	| [] -> MPself initmsid
+	| [] -> mp
 	| i::r -> MPdot(mp_rec r,label_of_id i)
-      in 
-      let env' = Modops.add_signature (MPself msid) before env in
+      in
+      let env' = Modops.add_signature mp before equiv env in
 	match with_decl with
           | With_Module ([],_) -> assert false
-	  | With_Module ([id], mp) ->
-	      let old,alias = match spec with
-		  SFBmodule msb -> Some msb,None
-		| SFBalias (mp',_,cst) -> None,Some (mp',cst)
+	  | With_Module ([id], mp1) ->
+	      let old = match spec with
+		  SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
 	      in
-	      let mtb' = lookup_modtype mp env' in
+	      let mb_mp1 = (lookup_module mp1 env) in
+	      let mtb_mp1 = 
+		module_type_of_module env' None mb_mp1  in
 	      let cst =
-		match old,alias with
-		    Some msb,None ->
+		match old.mod_expr with
+		    None ->
 		      begin
-			try Constraint.union 
-			  (check_subtypes env' mtb' (module_type_of_module None msb))
-			  msb.mod_constraints
+			try Constraint.union
+			  (check_subtypes env' mtb_mp1 
+			     (module_type_of_module env' None old))
+			  old.mod_constraints
 			with Failure _ -> error_with_incorrect (label_of_id id)
 		      end
-		  | None,Some (mp',None) ->
-		      check_modpath_equiv env' mp mp';
-		      Constraint.empty
-		  | None,Some (mp',Some cst) ->
-		      check_modpath_equiv env' mp mp';
-		      cst
-		  | _,_ ->
-		      anomaly "Mod_typing:no implementation and no alias"
+		  | Some (SEBident(mp')) ->
+		      check_modpath_equiv env' mp1 mp';
+		      old.mod_constraints
+		  | _ ->  error_a_generative_module_expected l
+	      in
+	      let new_mb = strengthen_and_subst_mb mb_mp1
+		(MPdot(mp,l)) env false in
+	      let new_spec = SFBmodule {new_mb with 
+					  mod_mp = MPdot(mp,l);
+					  mod_expr = Some (SEBident mp1);
+					  mod_constraints = cst} in
+		(* we propagate the new equality in the rest of the signature
+		   with the identity substitution accompagned by the new resolver*)
+	      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in
+		SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
+	      add_delta_resolver equiv new_mb.mod_delta,cst
+          | With_Module (idc,mp1) -> 
+	      let old = match spec with
+		  SFBmodule msb -> msb
+		| _ -> error_not_a_module (string_of_label l)
 	      in
-		if now then 
-		  let mp' = scrape_alias mp env' in
-		  let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in
-		  let up_subst = update_subst sub (map_mp (mp_rec [id]) mp') in
-		    cst, (join (map_mp (mp_rec [id]) mp') up_subst),(return_opt_type mp env' mtb')
-		else
-		cst,empty_subst,(return_opt_type mp env' mtb')
-        | With_Module (_::_,mp) -> 
-	    let old,alias = match spec with
-		SFBmodule msb -> Some msb, None
-	      | SFBalias (mpold,typ_opt,cst)->None, Some mpold
-	      | _ -> error_not_a_module (string_of_label l)
-	    in
 	      begin
-		if alias = None then
-		  let old = Option.get old in
-		    match old.mod_expr with
-			None ->
-			  let new_with_decl = match with_decl with
-			      With_Definition (_,c) -> 
-				With_Definition (idl,c)
-			    | With_Module (_,c) -> With_Module (idl,c) in
-			  let cst,_,typ_opt =
-			    check_with_aux_mod env' 
-			      (type_of_mb env' old) new_with_decl false in
-			    if now then 
-			    let mtb' = lookup_modtype mp env' in
-			    let mp' = scrape_alias mp env' in
-			    let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in
-			    let up_subst = update_subst 
-			      sub (map_mp (mp_rec (List.rev (id::idl))) mp') in
-			      cst, 
-			  (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst),
-			  typ_opt
-			    else
-			      cst,empty_subst,typ_opt
-		      | Some msb ->
-			  error_a_generative_module_expected l
-		else
-		  let mpold =  Option.get alias in 
-		  let mpnew = rebuild_mp mpold (List.map label_of_id idl) in
-		    check_modpath_equiv env' mpnew mp;
-		    let mtb' = lookup_modtype mp env' in
-		      Constraint.empty,empty_subst,(return_opt_type mp env' mtb')
+		match old.mod_expr with
+		    None ->
+		      let new_with_decl = With_Module (idl,mp1) in
+		      let sign,equiv',cst =
+			check_with_aux_mod env'
+			  old.mod_type new_with_decl (MPdot(mp,l)) old.mod_delta in
+		      let new_equiv = add_delta_resolver equiv equiv' in
+		      let new_spec = SFBmodule {old with 
+						  mod_type = sign;
+						  mod_type_alg = None;
+						  mod_delta = equiv'}
+		      in
+		      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) equiv' in
+			SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
+		      new_equiv,cst
+		  | Some (SEBident(mp')) ->
+		      let mpnew = rebuild_mp mp' (List.map label_of_id idl) in
+			check_modpath_equiv env' mpnew mp;
+			  SEBstruct(before@(l,spec)::after)
+			    ,equiv,Constraint.empty
+		  | _ ->
+		      error_a_generative_module_expected l
               end
-	| _ -> anomaly "Modtyping:incorrect use of with"
+	  | _ -> anomaly "Modtyping:incorrect use of with"
     with
 	Not_found -> error_no_such_label l
       | Reduction.NotConvertible -> error_with_incorrect l
-	  
-and translate_module env me =
+
+and translate_module env mp inl me =
   match me.mod_entry_expr, me.mod_entry_type with
-    | None, None -> 
+    | None, None ->
 	anomaly "Mod_typing.translate_module: empty type and expr in module entry"
-    | None, Some mte -> 
-	let mtb,sub = translate_struct_entry env mte in
-	{ mod_expr = None;
-	  mod_type = Some mtb;
-	  mod_alias = sub;
-	  mod_constraints = Constraint.empty; 
-	  mod_retroknowledge = []}
-    | Some mexpr, _ -> 
-	let meb,sub1 = translate_struct_entry env mexpr in
-	let mod_typ,sub,cst =
+    | None, Some mte ->
+	let mtb = translate_module_type env mp inl mte in
+	  { mod_mp = mp;
+	    mod_expr = None;
+	    mod_type = mtb.typ_expr;
+	    mod_type_alg = mtb.typ_expr_alg;
+	    mod_delta = mtb.typ_delta;
+	    mod_constraints = mtb.typ_constraints; 
+	    mod_retroknowledge = []}
+   | Some mexpr, _ ->
+	let sign,alg_implem,resolver,cst1 =
+	  translate_struct_module_entry env mp inl mexpr in
+	let sign,alg1,resolver,cst2 =
 	  match me.mod_entry_type with
-	    | None ->  
-		(type_of_struct env (bounded_str_expr meb) meb)
-		  ,sub1,Constraint.empty
-	    | Some mte -> 
-		let mtb2,sub2 = translate_struct_entry env mte in
+	    | None ->
+		sign,None,resolver,Constraint.empty
+	    | Some mte ->
+		let mtb = translate_module_type env mp inl mte in
                 let cst = check_subtypes env
-		  {typ_expr = meb;
-		   typ_strength = None;
-		   typ_alias = sub1;}
-		  {typ_expr = mtb2;
-		   typ_strength = None;
-		   typ_alias = sub2;}
+		  {typ_mp = mp;
+		   typ_expr = sign;
+		   typ_expr_alg = None;
+		   typ_constraints = Constraint.empty;
+		   typ_delta = resolver;}
+		  mtb
 		in
-		  Some mtb2,sub2,cst
+		  mtb.typ_expr,mtb.typ_expr_alg,mtb.typ_delta,cst
 	in
-	  { mod_type = mod_typ;
-	    mod_expr = Some meb;
-	    mod_constraints = cst;
-	    mod_alias = sub;
-	    mod_retroknowledge = []} (* spiwack: not so sure about that. It may
-					cause a bug when closing nested modules.
-					If it does, I don't really know how to
-					fix the bug.*)
+	  { mod_mp = mp;
+	    mod_type = sign;
+	    mod_expr = Some alg_implem;
+	    mod_type_alg = alg1;
+	    mod_constraints = Univ.Constraint.union cst1 cst2;
+	    mod_delta = resolver;
+	    mod_retroknowledge = []} 
+	    (* spiwack: not so sure about that. It may
+	       cause a bug when closing nested modules.
+	       If it does, I don't really know how to
+	       fix the bug.*)
 
 
-and translate_struct_entry env mse = match mse with
-  | MSEident mp ->
-      let mtb = lookup_modtype mp env in 
-      SEBident mp,mtb.typ_alias
+and translate_struct_module_entry env mp inl mse  = match mse with
+  | MSEident mp1 ->
+      let mb = lookup_module mp1 env in 
+      let mb' = strengthen_and_subst_mb mb mp env false in
+	mb'.mod_type, SEBident mp1, mb'.mod_delta,Univ.Constraint.empty
   | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let arg_b,sub = translate_struct_entry env arg_e in
-      let mtb =
-	{typ_expr = arg_b;
-	 typ_strength = None;
-	 typ_alias = sub} in
-      let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in
-      let body_b,sub = translate_struct_entry env' body_expr in
-	SEBfunctor (arg_id, mtb, body_b),sub
+      let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
+      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) 
+	env in
+      let sign,alg,resolver,cst =
+	translate_struct_module_entry env' mp inl body_expr in
+      SEBfunctor (arg_id, mtb, sign),SEBfunctor (arg_id, mtb, alg),resolver,
+      Univ.Constraint.union cst mtb.typ_constraints
   | MSEapply (fexpr,mexpr) ->
-      let feb,sub1 = translate_struct_entry env fexpr in
-      let feb'= eval_struct env feb
+      let sign,alg,resolver,cst1 =
+	translate_struct_module_entry env mp inl fexpr
       in
-      let farg_id, farg_b, fbody_b = destr_functor env feb' in
-      let mtb,mp = 
+      let farg_id, farg_b, fbody_b = destr_functor env sign in
+      let mtb,mp1 = 
 	try
-	  let mp = scrape_alias (path_of_mexpr mexpr) env in
-	  lookup_modtype mp env,mp
+	  let mp1 = path_of_mexpr mexpr in
+	      let mtb = module_type_of_module env None (lookup_module mp1 env) in
+		mtb,mp1
 	with
 	  | Not_path -> error_application_to_not_path mexpr
 	      (* place for nondep_supertype *) in
-      let meb,sub2= translate_struct_entry env (MSEident mp) in
-	if sub1 = empty_subst then 
-	  let cst = check_subtypes env mtb farg_b in
-	    SEBapply(feb,meb,cst),sub1
-	else
-	  let sub2 = match eval_struct env (SEBident mp) with
-	    | SEBstruct (msid,sign) -> 
-		join_alias 
-		  (subst_key (map_msid msid mp) sub2)
-		  (map_msid msid mp)
-	    | _ -> sub2 in
-	  let sub3 = join_alias sub1 (map_mbid farg_id mp None) in
-	  let sub4 = update_subst sub2 sub3 in
-	  let cst = check_subtypes env mtb farg_b in
-	    SEBapply(feb,meb,cst),(join sub3 sub4)
+      let cst = check_subtypes env mtb farg_b in
+      let mp_delta = discr_resolver env mtb in
+      let mp_delta = if not inl then mp_delta else
+	complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
+      in
+      let subst = map_mbid farg_id mp1 mp_delta in
+	(subst_struct_expr subst fbody_b),SEBapply(alg,SEBident mp1,cst),
+      (subst_codom_delta_resolver subst resolver),
+      Univ.Constraint.union cst1 cst
   | MSEwith(mte, with_decl) ->
-	let mtb,sub1 = translate_struct_entry env mte in
-	let mtb',sub2 = check_with env mtb with_decl in
-	  mtb',join sub1 sub2
-	    
+      let sign,alg,resolve,cst1 = translate_struct_module_entry env mp inl mte in
+      let sign,alg,resolve,cst2 = check_with env sign with_decl (Some alg) mp resolve in
+	sign,Option.get alg,resolve,Univ.Constraint.union cst1 cst2
+	  
+and translate_struct_type_entry env inl mse = match mse with
+  | MSEident mp1 ->
+      let mtb = lookup_modtype mp1 env in 
+	mtb.typ_expr,
+      Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty
+  | MSEfunctor (arg_id, arg_e, body_expr) ->
+      let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
+      let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env  in
+      let sign,alg,resolve,mp_from,cst =
+	translate_struct_type_entry env' inl body_expr in
+	SEBfunctor (arg_id, mtb, sign),None,resolve,mp_from,
+      Univ.Constraint.union cst mtb.typ_constraints
+  | MSEapply (fexpr,mexpr) ->
+      let sign,alg,resolve,mp_from,cst1 =
+	translate_struct_type_entry env inl fexpr
+      in
+      let farg_id, farg_b, fbody_b = destr_functor env sign in
+      let mtb,mp1 = 
+	try
+	  let mp1 = path_of_mexpr mexpr in
+	  let mtb = module_type_of_module env None (lookup_module mp1 env) in
+	    mtb,mp1
+	with
+	  | Not_path -> error_application_to_not_path mexpr
+	      (* place for nondep_supertype *) in
+      let cst2 = check_subtypes env mtb farg_b in
+      let mp_delta = discr_resolver env mtb in
+      let mp_delta = if not inl then mp_delta else
+	complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
+      in
+      let subst = map_mbid farg_id mp1 mp_delta in
+	(subst_struct_expr subst fbody_b),None,
+      (subst_codom_delta_resolver subst resolve),mp_from,Univ.Constraint.union cst1 cst2
+  | MSEwith(mte, with_decl) ->
+      let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in
+      let sign,alg,resolve,cst1 = 
+	check_with env sign with_decl alg mp_from resolve in
+	sign,alg,resolve,mp_from,Univ.Constraint.union cst cst1    
+
+and translate_module_type env mp inl mte =
+	let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in
+	let mtb = subst_modtype_and_resolver
+	  {typ_mp = mp_from;
+	   typ_expr = sign;
+	   typ_expr_alg = None;
+	   typ_constraints = cst;
+	   typ_delta = resolve} mp env
+	in {mtb with typ_expr_alg = alg}
+
+let rec translate_struct_include_module_entry env mp inl mse  = match mse with
+  | MSEident mp1 ->
+      let mb = lookup_module mp1 env in 
+      let mb' = strengthen_and_subst_mb mb mp env true in
+      let mb_typ = clean_bounded_mod_expr mb'.mod_type in 
+	mb_typ, mb'.mod_delta,Univ.Constraint.empty
+  | MSEapply (fexpr,mexpr) ->
+      let sign,resolver,cst1 =
+	translate_struct_include_module_entry env mp inl fexpr in
+      let farg_id, farg_b, fbody_b = destr_functor env sign in
+      let mtb,mp1 = 
+	try
+	  let mp1 = path_of_mexpr mexpr in
+	      let mtb = module_type_of_module env None (lookup_module mp1 env) in
+		mtb,mp1
+	with
+	  | Not_path -> error_application_to_not_path mexpr
+	      (* place for nondep_supertype *) in
+      let cst = check_subtypes env mtb farg_b in
+      let mp_delta =  discr_resolver env mtb in
+      let mp_delta = if not inl then mp_delta else
+	complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
+      in
+      let subst = map_mbid farg_id mp1 mp_delta in
+	(subst_struct_expr subst fbody_b),
+      (subst_codom_delta_resolver subst resolver),
+      Univ.Constraint.union cst1 cst
+  | _ -> error ("You cannot Include a high-order structure.")
+  
 
 let rec add_struct_expr_constraints env = function
   | SEBident _ -> env
 
-  | SEBfunctor (_,mtb,meb) -> 
-      add_struct_expr_constraints 
+  | SEBfunctor (_,mtb,meb) ->
+      add_struct_expr_constraints
 	(add_modtype_constraints env mtb) meb
 
-  | SEBstruct (_,structure_body) ->
-      List.fold_left 
+  | SEBstruct (structure_body) ->
+      List.fold_left
         (fun env (l,item) -> add_struct_elem_constraints env item)
         env
         structure_body
 
   | SEBapply (meb1,meb2,cst) ->
-      Environ.add_constraints cst 
-        (add_struct_expr_constraints 
-	  (add_struct_expr_constraints env meb1) 
+      Environ.add_constraints cst
+        (add_struct_expr_constraints
+	  (add_struct_expr_constraints env meb1)
 	  meb2)
   | SEBwith(meb,With_definition_body(_,cb))->
       Environ.add_constraints cb.const_constraints
 	(add_struct_expr_constraints env meb)
-  | SEBwith(meb,With_module_body(_,_,_,cst))->
-      Environ.add_constraints cst
-	(add_struct_expr_constraints env meb)	
+  | SEBwith(meb,With_module_body(_,_))->
+      add_struct_expr_constraints env meb
 		
 and add_struct_elem_constraints env = function 
   | SFBconst cb -> Environ.add_constraints cb.const_constraints env
   | SFBmind mib -> Environ.add_constraints mib.mind_constraints env
   | SFBmodule mb -> add_module_constraints env mb
-  | SFBalias (mp,_,Some cst) -> Environ.add_constraints cst env
-  | SFBalias (mp,_,None) -> env
   | SFBmodtype mtb -> add_modtype_constraints env mtb
 
-and add_module_constraints env mb = 
+and add_module_constraints env mb =
   let env = match mb.mod_expr with
     | None -> env
     | Some meb -> add_struct_expr_constraints env meb
   in
-  let env = match mb.mod_type with
-    | None -> env
-    | Some mtb -> 
-	add_struct_expr_constraints env mtb
+  let env =
+    add_struct_expr_constraints env mb.mod_type
   in
     Environ.add_constraints mb.mod_constraints env
 
-and add_modtype_constraints env mtb = 
-  add_struct_expr_constraints env mtb.typ_expr
-      
+and add_modtype_constraints env mtb =
+  Environ.add_constraints mtb.typ_constraints
+    (add_struct_expr_constraints env mtb.typ_expr)
+
 
 let rec struct_expr_constraints cst = function
   | SEBident _ -> cst
 
-  | SEBfunctor (_,mtb,meb) -> 
-      struct_expr_constraints 
+  | SEBfunctor (_,mtb,meb) ->
+      struct_expr_constraints
 	(modtype_constraints cst mtb) meb
 
-  | SEBstruct (_,structure_body) ->
-      List.fold_left 
+  | SEBstruct (structure_body) ->
+      List.fold_left
         (fun cst (l,item) -> struct_elem_constraints cst item)
         cst
         structure_body
 
   | SEBapply (meb1,meb2,cst1) ->
-      struct_expr_constraints 
+      struct_expr_constraints
 	(struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1)
 	meb2
   | SEBwith(meb,With_definition_body(_,cb))->
       struct_expr_constraints
         (Univ.Constraint.union cb.const_constraints cst) meb
-  | SEBwith(meb,With_module_body(_,_,_,cst1))->
-      struct_expr_constraints (Univ.Constraint.union cst1 cst) meb	
+  | SEBwith(meb,With_module_body(_,_))->
+      struct_expr_constraints  cst meb	
 		
 and struct_elem_constraints cst = function 
   | SFBconst cb -> cst
   | SFBmind mib -> cst
   | SFBmodule mb -> module_constraints cst mb
-  | SFBalias (mp,_,Some cst1) -> Univ.Constraint.union cst1 cst
-  | SFBalias (mp,_,None) -> cst
   | SFBmodtype mtb -> modtype_constraints cst mtb
 
-and module_constraints cst mb = 
+and module_constraints cst mb =
   let cst = match mb.mod_expr with
     | None -> cst
     | Some meb -> struct_expr_constraints cst meb in
-  let cst = match mb.mod_type with
-    | None -> cst
-    | Some mtb -> struct_expr_constraints cst mtb in
+  let cst = 
+      struct_expr_constraints cst mb.mod_type in
   Univ.Constraint.union mb.mod_constraints cst
 
-and modtype_constraints cst mtb = 
-  struct_expr_constraints cst mtb.typ_expr
-      
+and modtype_constraints cst mtb =
+  struct_expr_constraints  (Univ.Constraint.union mtb.typ_constraints cst) mtb.typ_expr
+
 
 let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty
 let module_constraints = module_constraints Univ.Constraint.empty
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index b9c68a23..63f7696c 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -6,20 +6,31 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.mli 11170 2008-06-25 08:31:04Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Declarations
 open Environ
 open Entries
 open Mod_subst
+open Names
 (*i*)
 
 
-val translate_module : env -> module_entry -> module_body
+val translate_module : env -> module_path -> bool -> module_entry
+  -> module_body
 
-val translate_struct_entry : env -> module_struct_entry -> 
-  struct_expr_body * substitution
+val translate_module_type : env -> module_path -> bool -> module_struct_entry ->
+  module_type_body
+
+val translate_struct_module_entry : env -> module_path -> bool -> module_struct_entry ->
+  struct_expr_body * struct_expr_body * delta_resolver * Univ.constraints
+
+val translate_struct_type_entry : env -> bool -> module_struct_entry ->
+  struct_expr_body * struct_expr_body option * delta_resolver * module_path * Univ.constraints
+
+val translate_struct_include_module_entry : env -> module_path 
+  -> bool -> module_struct_entry -> struct_expr_body * delta_resolver * Univ.constraints
 
 val add_modtype_constraints : env -> module_type_body -> env
 
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 34d9e930..b49d34b3 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.ml 12234 2009-07-09 09:14:09Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -21,6 +21,7 @@ open Mod_subst
 (*i*)
 
 
+
 let error_existing_label l = 
   error ("The label "^string_of_label l^" is already declared.")
 
@@ -60,6 +61,9 @@ let error_not_a_modtype_loc loc s =
 let error_not_a_module_loc loc s = 
   user_err_loc (loc,"",str ("\""^s^"\" is not a module."))
 
+let error_not_a_module_or_modtype_loc loc s =
+  user_err_loc (loc,"",str ("\""^s^"\" is not a module or module type."))
+
 let error_not_a_module s = error_not_a_module_loc dummy_loc s
 
 let error_not_a_constant l = 
@@ -82,20 +86,12 @@ let error_local_context lo =
 	       (string_of_label l)^" is not empty.")
 
 
-let error_no_such_label_sub l l1 l2 =
-  error (l1^" is not a subtype of "^l2^".\nThe field "^(string_of_label l)^" is missing in "^l1^".")
-
+let error_no_such_label_sub l l1 =
+  error ("The field "^(string_of_label l)^" is missing in "^l1^".")
 
+let error_with_in_module _ = error "The syntax \"with\" is not allowed for modules."
 
-let rec list_split_assoc k rev_before = function
-  | [] -> raise Not_found
-  | (k',b)::after when k=k' -> rev_before,b,after
-  | h::tail -> list_split_assoc k (h::rev_before) tail
-
-let path_of_seb = function
-  | SEBident mp -> mp
-  | _ -> anomaly "Modops: evaluation failed."
-
+let error_application_to_module_type _ = error "Module application to a module type."
 
 let destr_functor env mtb =
   match mtb with
@@ -103,123 +99,126 @@ let destr_functor env mtb =
       	    (arg_id,arg_t,body_t)
   | _ -> error_not_a_functor mtb
 
-(* the constraints are not important here *)
+let is_functor = function
+ | SEBfunctor (arg_id,arg_t,body_t) -> true
+ | _ -> false
 
-let module_body_of_type mtb = 
-  { mod_type = Some mtb.typ_expr;
+let module_body_of_type mp mtb = 
+  { mod_mp = mp;
+    mod_type = mtb.typ_expr;
+    mod_type_alg = mtb.typ_expr_alg;
     mod_expr = None;
-    mod_constraints = Constraint.empty;
-    mod_alias = mtb.typ_alias;
+    mod_constraints = mtb.typ_constraints;
+    mod_delta = mtb.typ_delta;
     mod_retroknowledge = []}
 
-let module_type_of_module mp mb =
-  let mp1,expr = 
-      (match mb.mod_type with
-	| Some expr -> mp,expr
-	| None -> (match mb.mod_expr with
-		     | Some (SEBident mp') ->(Some mp'),(SEBident mp')
-		     | Some expr -> mp,expr
-		     | None -> 
-			 anomaly "Modops: empty expr and type")) in
-    {typ_expr = expr;
-      typ_alias = mb.mod_alias;
-      typ_strength = mp1
-    }
-
-let rec check_modpath_equiv env mp1 mp2 = 
+let check_modpath_equiv env mp1 mp2 = 
   if mp1=mp2 then () else
-  let mp1 = scrape_alias mp1 env in
-  let mp2 = scrape_alias mp2 env in
-    if mp1=mp2 then ()
-    else 
-      error_not_equal mp1 mp2
+    let mb1=lookup_module  mp1 env in
+    let mb2=lookup_module mp2 env in
+      if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2)
+      then ()
+      else error_not_equal mp1 mp2
 	
 let rec subst_with_body sub = function
-  | With_module_body(id,mp,typ_opt,cst) ->
-      With_module_body(id,subst_mp sub mp,Option.smartmap 
-			 (subst_struct_expr sub) typ_opt,cst)
+  | With_module_body(id,mp) ->
+      With_module_body(id,subst_mp sub mp)
   | With_definition_body(id,cb) ->
       With_definition_body( id,subst_const_body sub cb)
 
-and subst_modtype sub mtb =
-  let typ_expr' = subst_struct_expr sub mtb.typ_expr in
-  let sub_mtb = join_alias mtb.typ_alias sub in
-    if typ_expr'==mtb.typ_expr && sub_mtb==mtb.typ_alias then
-      mtb
+and subst_modtype sub do_delta mtb=
+  let mp = subst_mp sub mtb.typ_mp in
+  let sub = add_mp mtb.typ_mp mp empty_delta_resolver sub in
+  let typ_expr' = subst_struct_expr sub do_delta mtb.typ_expr in
+  let typ_alg' = 
+    Option.smartmap 
+      (subst_struct_expr sub (fun x y-> x)) mtb.typ_expr_alg in
+  let mtb_delta = do_delta mtb.typ_delta sub in
+    if typ_expr'==mtb.typ_expr && 
+      typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then
+	mtb
     else
-      { mtb with 
-	  typ_expr = typ_expr';
-	  typ_alias = sub_mtb}
+      {mtb with 
+	 typ_mp = mp;
+	 typ_expr = typ_expr';
+	 typ_expr_alg = typ_alg';
+	 typ_delta = mtb_delta}
 	
-and subst_structure sub sign = 
-  let subst_body  = function
+and subst_structure sub do_delta sign = 
+  let subst_body = function
       SFBconst cb -> 
 	SFBconst (subst_const_body sub cb)
     | SFBmind mib -> 
 	SFBmind (subst_mind sub mib)
     | SFBmodule mb -> 
-	SFBmodule (subst_module sub mb)
+	SFBmodule (subst_module sub do_delta mb)
     | SFBmodtype mtb -> 
-	SFBmodtype (subst_modtype sub mtb)
-    | SFBalias (mp,typ_opt,cst) ->
-	SFBalias (subst_mp sub mp,Option.smartmap 
-		    (subst_struct_expr sub) typ_opt,cst)
+	SFBmodtype (subst_modtype sub do_delta mtb)
   in
     List.map (fun (l,b) -> (l,subst_body b)) sign
 
-and subst_module  sub mb =
-  let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in
-  (* This is similar to the previous case. In this case we have
-     a module M in a signature that is knows to be equivalent to a module M'
-     (because the signature is "K with Module M := M'") and we are substituting
-     M' with some M''. *)
-  let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in
-  let mb_alias = update_subst sub mb.mod_alias in
-   let mb_alias =  if mb_alias = empty_subst then
-     join_alias mb.mod_alias sub 
-   else 
-     join mb_alias (join_alias mb.mod_alias sub)
-   in
-     if mtb'==mb.mod_type && mb.mod_expr == me' 
-      && mb_alias == mb.mod_alias
+and subst_module sub do_delta mb =
+  let mp = subst_mp sub mb.mod_mp in
+  let sub = if is_functor mb.mod_type && not(mp=mb.mod_mp) then
+    add_mp mb.mod_mp mp
+      empty_delta_resolver sub else sub in 
+  let id_delta = (fun x y-> x) in
+  let mtb',me' = 
+    let mtb = subst_struct_expr sub do_delta mb.mod_type in 
+      match mb.mod_expr with
+	  None -> mtb,None
+	| Some me -> if me==mb.mod_type then
+	    mtb,Some mtb
+	  else mtb,Option.smartmap 
+	    (subst_struct_expr sub id_delta) mb.mod_expr
+  in
+  let typ_alg' = Option.smartmap 
+    (subst_struct_expr sub id_delta) mb.mod_type_alg in
+  let mb_delta = do_delta mb.mod_delta sub in
+    if mtb'==mb.mod_type && mb.mod_expr == me' 
+      && mb_delta == mb.mod_delta && mp == mb.mod_mp
     then mb else
-      { mod_expr = me';
-	mod_type=mtb'; 
-	mod_constraints=mb.mod_constraints;
-	mod_alias = mb_alias;
-	mod_retroknowledge=mb.mod_retroknowledge}
-
-
-and subst_struct_expr sub = function
-    | SEBident mp -> SEBident (subst_mp sub  mp)
-    | SEBfunctor (msid, mtb, meb') -> 
-	SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb')
-    | SEBstruct (msid,str)->
-	SEBstruct(msid, subst_structure sub str)
+      { mb with
+	  mod_mp = mp;
+	  mod_expr = me';
+	  mod_type_alg = typ_alg';
+	  mod_type=mtb'; 
+	  mod_delta = mb_delta}
+
+and subst_struct_expr sub do_delta = function
+    | SEBident mp -> SEBident (subst_mp sub mp)
+    | SEBfunctor (mbid, mtb, meb') -> 
+	SEBfunctor(mbid,subst_modtype sub do_delta mtb
+		     ,subst_struct_expr sub do_delta meb')
+    | SEBstruct (str)->
+	SEBstruct( subst_structure sub do_delta str)
     | SEBapply (meb1,meb2,cst)->
-	SEBapply(subst_struct_expr sub meb1,
-		 subst_struct_expr sub meb2,
+	SEBapply(subst_struct_expr sub do_delta meb1,
+		 subst_struct_expr sub do_delta meb2,
 		 cst)
     | SEBwith (meb,wdb)-> 
-	SEBwith(subst_struct_expr sub meb,
+	SEBwith(subst_struct_expr sub do_delta meb,
 		subst_with_body sub wdb)
- 
 
-let subst_signature_msid msid mp = 
-  subst_structure (map_msid msid mp)
+let subst_signature subst =
+  subst_structure subst 
+    (fun resolver subst-> subst_codom_delta_resolver subst resolver)
+
+let subst_struct_expr subst = 
+  subst_struct_expr subst
+    (fun resolver subst-> subst_codom_delta_resolver subst resolver)
 
 (* spiwack: here comes the function which takes care of importing 
    the retroknowledge declared in the library *)
 (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *)
-let add_retroknowledge msid mp =
-  let subst = add_msid msid mp empty_subst in
-  let subst_and_perform rkaction env =
+let add_retroknowledge mp =
+  let perform rkaction env =
     match rkaction with
       | Retroknowledge.RKRegister (f, e) ->
 	  Environ.register env f 
 	  (match e with 
-	    | Const kn -> kind_of_term (subst_mps subst (mkConst kn))
-	    | Ind ind -> kind_of_term (subst_mps subst (mkInd ind))
+	    | Const kn -> kind_of_term (mkConst kn)
+	    | Ind ind -> kind_of_term (mkInd ind)
 	    | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term")
   in
   fun lclrk env ->
@@ -231,302 +230,341 @@ let add_retroknowledge msid mp =
      for things to go right (the pun is not intented). So we lose 
      tail recursivity, but the world will have exploded before any module
      imports 10 000 retroknowledge registration.*)
-  List.fold_right subst_and_perform lclrk env
-
-
+  List.fold_right perform lclrk env
 
-let strengthen_const env mp l cb = 
-  match cb.const_opaque, cb.const_body with
-  | false, Some _ -> cb
-  | true, Some _ 
-  | _, None -> 
-      let const = mkConst (make_con mp empty_dirpath l) in 
-      let const_subs = Some (Declarations.from_val const) in
-	{cb with 
-      	   const_body = const_subs;
-	   const_opaque = false;
-           const_body_code = Cemitcodes.from_val
-             (compile_constant_body env const_subs false false)
-	}
-
-let strengthen_mind env mp l mib = match mib.mind_equiv with
-  | Some _ -> mib
-  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
-
-
-let rec eval_struct env = function 
-  | SEBident mp -> 
-      begin
-	let mtb =lookup_modtype mp env in
-	match mtb.typ_expr,mtb.typ_strength with
-	    mtb,None -> eval_struct env mtb
-	  | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb)
-      end
-  | SEBapply (seb1,seb2,_) -> 
-      let svb1 = eval_struct env seb1 in
-      let farg_id, farg_b, fbody_b = destr_functor env svb1 in
-      let mp = path_of_seb seb2 in
-      let mp = scrape_alias mp env in
-      let sub_alias = (lookup_modtype mp env).typ_alias in
-      let sub_alias = match eval_struct env (SEBident mp) with
-	| SEBstruct (msid,sign) ->
-	    join_alias 
-	      (subst_key (map_msid msid mp) sub_alias)
-	      (map_msid msid mp)
-	| _ -> sub_alias in
-    let resolve = resolver_of_environment farg_id farg_b mp sub_alias env in  
-    let sub_alias1 = update_subst sub_alias 
-	(map_mbid farg_id mp (Some resolve)) in
-	eval_struct env (subst_struct_expr 
-			   (join sub_alias1 
-			      (map_mbid farg_id mp (Some resolve))) fbody_b)
-  | SEBwith (mtb,(With_definition_body _ as wdb)) ->
-      let mtb',_ = merge_with env mtb wdb empty_subst in
-	mtb'
-  | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) ->
-      let alias_in_mp =
-	(lookup_modtype mp env).typ_alias in
-      let alias_in_mp = match eval_struct env (SEBident mp) with
-	| SEBstruct (msid,sign) -> subst_key (map_msid msid mp) alias_in_mp
-	| _ -> alias_in_mp in
-      let mtb',_ = merge_with env mtb wdb alias_in_mp in
-	mtb'
-(*  | SEBfunctor(mbid,mtb,body) -> 
-    let env = add_module (MPbound mbid) (module_body_of_type mtb) env in
-    SEBfunctor(mbid,mtb,eval_struct env body) *)
-  | mtb -> mtb
-      
-and type_of_mb env mb =
-  match mb.mod_type,mb.mod_expr with
-      None,Some b -> eval_struct env b
-    | Some t, _ -> eval_struct env t
-    | _,_ -> anomaly 
-	"Modops:  empty type and empty expr" 
-	  
-and merge_with env mtb with_decl alias= 
-  let msid,sig_b = match (eval_struct env mtb) with 
-    | SEBstruct(msid,sig_b) -> msid,sig_b
-    | _ -> error_signature_expected mtb
-  in
-  let id,idl = match with_decl with 
-    | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl
-    | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false
-  in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc l [] sig_b in
-      let before = List.rev rev_before in
-      let rec mp_rec = function
-	| [] -> MPself msid
-	| i::r -> MPdot(mp_rec r,label_of_id i)
-      in 
-      let env' = add_signature (MPself msid) before env in
-      let new_spec,subst = match with_decl with
-        | With_definition_body ([],_)
-        | With_module_body ([],_,_,_) -> assert false
-	| With_definition_body ([id],c) -> 
-	    SFBconst c,None
-	| With_module_body ([id], mp,typ_opt,cst) ->
-	    let mp' = scrape_alias mp env' in
-	    let new_alias = update_subst alias (map_mp (mp_rec [id]) mp') in
-	      SFBalias (mp,typ_opt,Some cst),
-	    Some(join (map_mp (mp_rec [id]) mp') new_alias)
-	| With_definition_body (_::_,_) 
-        | With_module_body (_::_,_,_,_) -> 
-	    let old,aliasold = match spec with
-		SFBmodule msb -> Some msb, None
-	      | SFBalias (mpold,typ_opt,cst) ->None, Some (mpold,typ_opt,cst)
-	      | _ -> error_not_a_module (string_of_label l)
-	    in
-	      if aliasold = None then
-		let old = Option.get old in
-		let new_with_decl,subst1 = 
-		  match with_decl with
-                      With_definition_body (_,c) -> With_definition_body (idl,c),None
-		    | With_module_body (idc,mp,typ_opt,cst) -> 
-			let mp' = scrape_alias mp env' in
-			  With_module_body (idl,mp,typ_opt,cst),
-			Some(map_mp (mp_rec (List.rev idc)) mp') 
-		in
-		let subst = match subst1 with
-		  | None -> None
-		  | Some s -> Some (join s (update_subst alias s)) in
-		let modtype,subst_msb = 
-		  merge_with env' (type_of_mb env' old) new_with_decl alias in
-		let msb =
-		  { mod_expr = None;
-		    mod_type = Some modtype; 
-		    mod_constraints = old.mod_constraints;
-		    mod_alias = begin 
-		      match subst_msb with
-			|None -> empty_subst
-			|Some s -> s
-		    end;
-		    mod_retroknowledge = old.mod_retroknowledge}
-		in
-		  (SFBmodule msb),subst
-	      else 
-		let mpold,typ_opt,cst =  Option.get aliasold in 
-		  SFBalias (mpold,typ_opt,cst),None
-      in
-	SEBstruct(msid,  before@(l,new_spec)::
-		    (Option.fold_right subst_structure subst after)),subst
-    with
-	Not_found -> error_no_such_label l
-
-and add_signature mp sign env = 
+let rec add_signature mp sign resolver env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
-    let con = make_con mp empty_dirpath l in
+    let con = constant_of_kn kn in
+    let mind = mind_of_kn kn in
       match elem with
-	| SFBconst cb -> Environ.add_constant con cb env
-	| SFBmind mib -> Environ.add_mind kn mib env
-	| SFBmodule mb -> 
-	    add_module (MPdot (mp,l)) mb env 
+	| SFBconst cb -> 
+	    let con =  constant_of_delta resolver con in
+	      Environ.add_constant con cb env
+	| SFBmind mib -> 
+	    let mind =  mind_of_delta resolver mind in
+	    Environ.add_mind mind mib env
+	| SFBmodule mb -> add_module mb env
 	      (* adds components as well *)
-	| SFBalias (mp1,_,cst) -> 
-	    Environ.register_alias (MPdot(mp,l)) mp1 env
-	| SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) 
-	    mtb env
+	| SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
   in
     List.fold_left add_one env sign
 
-and add_module mp mb env = 
+and add_module mb env = 
+  let mp = mb.mod_mp in
   let env = Environ.shallow_add_module mp mb env in
-  let env =
-    Environ.add_modtype mp (module_type_of_module (Some mp) mb) env
-  in
-  let mod_typ = type_of_mb env mb in
-    match mod_typ with
-      | SEBstruct (msid,sign) -> 
-	  add_retroknowledge msid mp (mb.mod_retroknowledge)
-	    (add_signature mp (subst_signature_msid msid mp sign) env)
+    match mb.mod_type with
+      | SEBstruct (sign) -> 
+	  add_retroknowledge mp mb.mod_retroknowledge 
+	    (add_signature mp sign mb.mod_delta env)
       | SEBfunctor _ -> env
       | _ -> anomaly "Modops:the evaluation of the structure failed "
-	  
-
 
-and  constants_of_specification env mp sign =
- let aux (env,res) (l,elem) =
-  match elem with
-   | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
-   | SFBmind _ -> env,res
-   | SFBmodule mb ->
-       let new_env =  add_module (MPdot (mp,l)) mb env in 
-       new_env,(constants_of_modtype env (MPdot (mp,l))
-		   (type_of_mb env mb)) @ res
-   | SFBalias (mp1,typ_opt,cst) ->
-       let new_env =  register_alias (MPdot (mp,l)) mp1 env in 
-       new_env,(constants_of_modtype env (MPdot (mp,l))
-		   (eval_struct env (SEBident mp1))) @ res
-   | SFBmodtype mtb -> 
-       (* module type dans un module type. 
-	  Il faut au moins mettre mtb dans l'environnement (avec le bon 
-	  kn pour pouvoir continuer aller deplier les modules utilisant ce 
-	  mtb
-	  ex: 
-	  Module Type T1. 
-	  Module Type T2.
-	     ....
-    	    End T2.
-	  .....
-            Declare Module M : T2.
-         End T2 
-	  si on ne rajoute pas T2 dans l'environement de typage 
-	  on va exploser au moment du Declare Module
-       *)
-       let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in 
-       new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res
- in
- snd (List.fold_left aux (env,[]) sign)
-
-and constants_of_modtype env mp modtype =
-  match (eval_struct env modtype) with
-      SEBstruct (msid,sign) ->
-	constants_of_specification env mp
-	  (subst_signature_msid msid mp sign)
-    | SEBfunctor _ -> []
-    | _ -> anomaly "Modops:the evaluation of the structure failed "
-
-(* returns a resolver for kn that maps mbid to mp. We only keep
-   constants that have the inline flag *)
-and  resolver_of_environment mbid modtype mp alias env =
- let constants = constants_of_modtype env (MPbound mbid) modtype.typ_expr in
- let constants = List.map (fun (l,cb) -> (l,subst_const_body alias cb)) constants in
- let rec make_resolve = function
-   | [] -> []
-   | (con,expecteddef)::r ->
-       let con' = replace_mp_in_con (MPbound mbid) mp con in
-       let con',_ = subst_con alias con' in
-  (*     let con' = replace_mp_in_con (MPbound mbid) mp con' in *)
-	 try
-	   if expecteddef.Declarations.const_inline then
-	     let constant = lookup_constant con' env in
-	     if (not constant.Declarations.const_opaque) then
-	       let constr = Option.map Declarations.force
-		 constant.Declarations.const_body in
-		 (con,constr)::(make_resolve r)
-	     else make_resolve r
-	   else make_resolve r
-	 with Not_found -> error_no_such_label (con_label con')
- in
- let resolve = make_resolve constants in
-   Mod_subst.make_resolver resolve
+let strengthen_const env mp_from l cb resolver = 
+  match cb.const_opaque, cb.const_body with
+  | false, Some _ -> cb
+  | true, Some _ 
+  | _, None ->
+      let con = make_con mp_from empty_dirpath l in
+      let con =  constant_of_delta resolver con in
+      let const = mkConst con in 
+      let const_subs = Some (Declarations.from_val const) in
+	{cb with 
+	   const_body = const_subs;
+	   const_opaque = false;
+	   const_body_code = Cemitcodes.from_val
+            (compile_constant_body env const_subs false false)
+	}
+	  
 
+let rec strengthen_mod env mp_from mp_to mb = 
+  if mp_in_delta mb.mod_mp mb.mod_delta then
+    mb 
+  else
+    match mb.mod_type with
+     | SEBstruct (sign) -> 
+	 let resolve_out,sign_out = 
+	   strengthen_sig env mp_from sign mp_to mb.mod_delta in
+	   { mb with
+	       mod_expr = Some (SEBident mp_to);
+	       mod_type = SEBstruct(sign_out);
+	       mod_type_alg = mb.mod_type_alg;
+	       mod_constraints = mb.mod_constraints;
+	       mod_delta = add_mp_delta_resolver mp_from mp_to 
+	       (add_delta_resolver mb.mod_delta resolve_out);
+	       mod_retroknowledge = mb.mod_retroknowledge}
+     | SEBfunctor _ -> mb
+     | _ -> anomaly "Modops:the evaluation of the structure failed "
+	 
+and strengthen_sig env mp_from sign mp_to resolver =
+  match sign with
+    | [] -> empty_delta_resolver,[]
+    | (l,SFBconst cb) :: rest ->
+	let item' = 
+	  l,SFBconst (strengthen_const env mp_from l cb resolver) in
+	let resolve_out,rest' =
+	  strengthen_sig env mp_from rest mp_to resolver in
+	  resolve_out,item'::rest'
+    | (_,SFBmind _ as item):: rest ->
+	let resolve_out,rest' = 
+	  strengthen_sig env mp_from rest mp_to resolver in
+	  resolve_out,item::rest'
+    | (l,SFBmodule mb) :: rest ->
+	let mp_from' = MPdot (mp_from,l) in
+	let mp_to' = MPdot(mp_to,l) in 
+	let mb_out = 
+	  strengthen_mod env mp_from' mp_to' mb in
+	let item' = l,SFBmodule (mb_out) in
+	let env' = add_module mb_out env in
+	let resolve_out,rest' = 
+	  strengthen_sig env' mp_from rest mp_to resolver in
+	  add_delta_resolver resolve_out mb.mod_delta,
+	item':: rest'
+    | (l,SFBmodtype mty as item) :: rest -> 
+	let env' = add_modtype 
+	  (MPdot(mp_from,l)) mty env
+	in
+	let resolve_out,rest' = 
+	  strengthen_sig env' mp_from rest mp_to resolver in
+	  resolve_out,item::rest'
     
-and strengthen_mtb env mp mtb =
-  let mtb1 = eval_struct env mtb in 
-  match  mtb1 with
-  | SEBfunctor _ -> mtb1
-  | SEBstruct (msid,sign) -> 
-      SEBstruct (msid,strengthen_sig env msid sign mp)
-  | _ -> anomaly "Modops:the evaluation of the structure failed "
-
-and strengthen_mod env mp mb = 
-  let mod_typ = type_of_mb env mb in
-    { mod_expr = mb.mod_expr;
-      mod_type = Some (strengthen_mtb env mp mod_typ);
-      mod_constraints = mb.mod_constraints;
-      mod_alias = mb.mod_alias;
-      mod_retroknowledge = mb.mod_retroknowledge}
-      
-and strengthen_sig env msid sign mp = match sign with
-  | [] -> []
-  | (l,SFBconst cb) :: rest ->
-      let item' = l,SFBconst (strengthen_const env mp l cb) in
-      let rest' = strengthen_sig env msid rest mp in
+let strengthen env mtb mp = 
+  if mp_in_delta mtb.typ_mp mtb.typ_delta then
+    (* in this case mtb has already been strengthened*)
+    mtb 
+  else
+    match mtb.typ_expr with
+      | SEBstruct (sign) -> 
+	  let resolve_out,sign_out =
+	    strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in
+	    {mtb with
+	       typ_expr = SEBstruct(sign_out);
+	       typ_delta = add_delta_resolver mtb.typ_delta
+		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)}
+      | SEBfunctor _ -> mtb
+      | _ -> anomaly "Modops:the evaluation of the structure failed "
+	  
+let module_type_of_module env mp mb =
+  match mp with
+      Some mp ->
+	strengthen env {
+	  typ_mp = mp;
+	  typ_expr = mb.mod_type;
+	  typ_expr_alg = None;
+	  typ_constraints = mb.mod_constraints;
+	  typ_delta = mb.mod_delta} mp
+	  
+    | None ->
+	{typ_mp = mb.mod_mp;
+	 typ_expr = mb.mod_type;
+	 typ_expr_alg = None;
+	 typ_constraints = mb.mod_constraints;
+	 typ_delta = mb.mod_delta}
+
+let complete_inline_delta_resolver env mp mbid mtb delta =
+  let constants = inline_of_delta mtb.typ_delta in
+  let rec make_inline delta = function
+    | [] -> delta
+    | kn::r -> 
+	let kn = replace_mp_in_kn (MPbound mbid) mp kn in
+	let con = constant_of_kn kn in
+	let con' = constant_of_delta delta con in
+	  try
+	    let constant = lookup_constant con' env in
+	      if (not constant.Declarations.const_opaque) then
+		let constr = Option.map Declarations.force 
+		  constant.Declarations.const_body in
+		  if constr = None then 
+		    (make_inline delta r)
+		  else
+		    add_inline_constr_delta_resolver con (Option.get constr)
+		      (make_inline delta r)
+	      else
+		(make_inline delta r)
+	  with 
+	      Not_found -> error_no_such_label_sub (con_label con) 
+		(string_of_mp (con_modpath con))
+  in
+    make_inline delta constants
+
+let rec strengthen_and_subst_mod
+    mb subst env mp_from mp_to env resolver =
+     match mb.mod_type with
+	 SEBstruct(str) ->
+	   let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
+	   if mb_is_an_alias then 
+	     subst_module subst 
+	       (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb 
+	   else
+	     let resolver,new_sig = 
+	       strengthen_and_subst_struct str subst env
+		 mp_from mp_from mp_to false false mb.mod_delta 
+	     in
+	       {mb with 
+		  mod_mp = mp_to;
+		  mod_expr = Some (SEBident mp_from);
+		  mod_type = SEBstruct(new_sig);
+		  mod_delta = add_mp_delta_resolver mp_to mp_from resolver}
+       | SEBfunctor(arg_id,arg_b,body) ->
+	   let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in
+	   subst_module subst 
+	     (fun resolver subst-> subst_dom_codom_delta_resolver subst resolver) mb  
+	
+       | _ -> anomaly "Modops:the evaluation of the structure failed "
+	   
+and strengthen_and_subst_struct 
+    str subst env mp_alias mp_from mp_to alias incl resolver =
+  match str with
+    | [] -> empty_delta_resolver,[]
+    | (l,SFBconst cb) :: rest ->
+	let item' = if alias then
+	  l,SFBconst (subst_const_body subst cb) 
+	else 
+	  l,SFBconst (strengthen_const env mp_from l 
+			(subst_const_body subst cb) resolver)
+	in
+	let con = make_con mp_from empty_dirpath l in
+	let resolve_out,rest' =
+	  strengthen_and_subst_struct rest subst env 
+	    mp_alias mp_from mp_to alias incl resolver in
+	  if incl then
+	    let old_name = constant_of_delta resolver con in
+	    (add_constant_delta_resolver
+	      (constant_of_kn_equiv (make_kn mp_to empty_dirpath l)
+		 (canonical_con old_name)) 
+	      resolve_out),
 	item'::rest'
-  | (l,SFBmind mib) :: rest ->
-      let item' = l,SFBmind (strengthen_mind env mp l mib) in
-      let rest' = strengthen_sig env msid rest mp in
+	  else
+	    resolve_out,item'::rest'
+    | (l,SFBmind mib) :: rest ->
+	let item' = l,SFBmind (subst_mind subst mib) in
+	let mind = make_mind mp_from empty_dirpath l in
+	let resolve_out,rest' =
+	  strengthen_and_subst_struct rest subst env 
+	    mp_alias mp_from mp_to alias incl resolver in
+	  if incl then
+	    let old_name =  mind_of_delta resolver mind in 
+	    (add_mind_delta_resolver
+	      (mind_of_kn_equiv (make_kn mp_to empty_dirpath l) (canonical_mind old_name)) resolve_out),
 	item'::rest'
-  | (l,SFBmodule mb) :: rest ->
-      let mp' = MPdot (mp,l) in
-	let item' = l,SFBmodule (strengthen_mod env mp' mb) in
-	let env' = add_module 
-	  (MPdot (MPself msid,l)) mb env in
-        let rest' = strengthen_sig env' msid rest mp in
+	  else
+	    resolve_out,item'::rest'
+    | (l,SFBmodule mb) :: rest ->
+	let mp_from' = MPdot (mp_from,l) in
+	let mp_to' = MPdot(mp_to,l) in
+	let mb_out = if alias then 
+	  subst_module subst 
+	  (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb 
+	else
+	  strengthen_and_subst_mod
+	    mb subst env mp_from' mp_to' env resolver
+	in
+	let item' = l,SFBmodule (mb_out) in
+	let env' = add_module mb_out env in
+	let resolve_out,rest' = 
+	  strengthen_and_subst_struct rest subst env' 
+	    mp_alias mp_from mp_to alias incl resolver in
+	  if  is_functor mb_out.mod_type then (add_mp_delta_resolver 
+	     mp_to' mp_to' resolve_out),item':: rest' else
+	    add_delta_resolver resolve_out mb_out.mod_delta,
 	item':: rest'
-  | ((l,SFBalias (mp1,_,cst)) as item) :: rest ->
-      let env' = register_alias (MPdot(MPself msid,l)) mp1 env in
-      let rest' = strengthen_sig env' msid rest mp in
-	item::rest'
-  | (l,SFBmodtype mty as item) :: rest -> 
-      let env' = add_modtype 
-		   (MPdot((MPself msid),l)) 
-		   mty
-		   env
-      in
-      let rest' = strengthen_sig env' msid rest mp in
-	item::rest'
-
+    | (l,SFBmodtype mty) :: rest -> 
+	let mp_from' = MPdot (mp_from,l) in
+	let mp_to' = MPdot(mp_to,l) in
+	let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in
+	let mty = subst_modtype subst' 
+	  (fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in
+	let env' = add_modtype mp_from' mty env	in
+	let resolve_out,rest' = strengthen_and_subst_struct rest subst env' 
+	    mp_alias mp_from mp_to alias incl resolver in
+	  (add_mp_delta_resolver 
+	     mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest'
     
-let strengthen env mtb mp = strengthen_mtb env mp mtb
+let strengthen_and_subst_mb mb mp env include_b =
+    match mb.mod_type with
+	SEBstruct str ->
+	  let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
+	    (*if mb is an alias then the strengthening is useless 
+	      (i.e. it is already done)*)
+	  let mp_alias = delta_of_mp mb.mod_delta mb.mod_mp in
+	  let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
+	  let new_resolver = 
+	    add_mp_delta_resolver mp mp_alias
+	      (subst_dom_delta_resolver subst_resolver mb.mod_delta) in	    
+	  let subst = map_mp mb.mod_mp mp new_resolver in 
+	  let resolver_out,new_sig = 
+	    strengthen_and_subst_struct str subst env
+	     mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta
+	  in
+	    {mb with 
+	       mod_mp = mp;
+	       mod_type = SEBstruct(new_sig);
+	       mod_expr = Some (SEBident mb.mod_mp);
+	       mod_delta = if include_b then resolver_out 
+	       else add_delta_resolver new_resolver resolver_out}
+      | SEBfunctor(arg_id,argb,body) ->
+	  let subst = map_mp mb.mod_mp mp empty_delta_resolver in
+	  subst_module subst 
+	    (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mb 
+      | _ -> anomaly "Modops:the evaluation of the structure failed "
 
 
-let update_subst env mb mp =
-  match type_of_mb env mb with
-    | SEBstruct(msid,str) -> false, join_alias 
-	(subst_key (map_msid msid mp) mb.mod_alias)
-	(map_msid msid mp)
-    | _ -> true, mb.mod_alias
+let subst_modtype_and_resolver mtb mp env =
+  let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in
+  let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in 
+  let full_subst = (map_mp mtb.typ_mp mp new_delta) in
+    subst_modtype full_subst
+      (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mtb
+
+let rec is_bounded_expr l = function
+  | SEBident mp -> List.mem mp l
+  | SEBapply (fexpr,mexpr,_) ->  
+      is_bounded_expr l mexpr || is_bounded_expr l fexpr
+  | _ -> false
+
+let rec clean_struct l = function
+  | (lab,SFBmodule mb) as field -> 
+      let clean_typ = clean_expr l mb.mod_type in 
+      let clean_impl = 
+	begin try
+	  if (is_bounded_expr l (Option.get mb.mod_expr)) then
+	    Some clean_typ
+	  else  Some (clean_expr l (Option.get mb.mod_expr))
+	with
+	    Option.IsNone -> None 
+	end in
+	  if clean_typ==mb.mod_type && clean_impl==mb.mod_expr then
+	    field 
+	  else 
+	    (lab,SFBmodule {mb with 
+			      mod_type=clean_typ;
+			      mod_expr=clean_impl})
+  | field -> field
+      
+and clean_expr l = function
+ | SEBfunctor (mbid,sigt,str) as s->
+     let str_clean = clean_expr l str in
+     let sig_clean = clean_expr l sigt.typ_expr in 
+       if  str_clean == str && sig_clean = sigt.typ_expr then
+	 s else SEBfunctor (mbid,{sigt with typ_expr=sig_clean},str_clean)
+  | SEBstruct str as s->
+      let str_clean = Util.list_smartmap (clean_struct l) str in 
+	if  str_clean == str then s else SEBstruct(str_clean)
+  |  str -> str 
+
+let rec collect_mbid l = function
+  | SEBfunctor (mbid,sigt,str) as s->
+      let str_clean = collect_mbid ((MPbound mbid)::l) str in 
+	if  str_clean == str then s else 
+      SEBfunctor (mbid,sigt,str_clean)
+  | SEBstruct str as s->
+      let str_clean = Util.list_smartmap (clean_struct l) str in 
+	if  str_clean == str then s else SEBstruct(str_clean)
+  |  _ -> anomaly "Modops:the evaluation of the structure failed "
+       
+       
+let clean_bounded_mod_expr = function
+  | SEBfunctor _ as str -> 
+      let str_clean = collect_mbid [] str in 
+	if  str_clean == str then str else str_clean
+  | str -> str
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 2d8b21ad..3488a312 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -20,46 +20,40 @@ open Mod_subst
 
 (* Various operations on modules and module types *)
 
-(* make the environment entry out of type *)
-val module_body_of_type : module_type_body -> module_body
 
-val  module_type_of_module : module_path option -> module_body -> 
-  module_type_body 
+val module_body_of_type : module_path -> module_type_body  -> module_body 
 
-val destr_functor : 
-  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
+val module_type_of_module : env -> module_path option -> module_body -> 
+  module_type_body
 
-val subst_modtype : substitution -> module_type_body -> module_type_body
-val subst_structure : substitution -> structure_body -> structure_body
+val destr_functor :
+  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
 
 val subst_struct_expr :  substitution -> struct_expr_body -> struct_expr_body
 
-val subst_signature_msid :
-  mod_self_id -> module_path -> 
-  structure_body -> structure_body
+val subst_signature : substitution -> structure_body -> structure_body
 
-val subst_structure : substitution -> structure_body -> structure_body
+val add_signature :
+  module_path -> structure_body -> delta_resolver -> env -> env
 
-(* Evaluation functions *)
-val eval_struct : env -> struct_expr_body -> struct_expr_body
+(* adds a module and its components, but not the constraints *)
+val add_module : module_body -> env -> env
 
-val type_of_mb : env -> module_body -> struct_expr_body
+val check_modpath_equiv : env -> module_path -> module_path -> unit
 
-(* [add_signature mp sign env] assumes that the substitution [msid]
-   $\mapsto$ [mp] has already been performed (or is not necessary, like
-   when [mp = MPself msid]) *)
-val add_signature : 
-  module_path -> structure_body -> env -> env
+val strengthen : env -> module_type_body -> module_path -> module_type_body
 
-(* adds a module and its components, but not the constraints *)
-val add_module :
-  module_path -> module_body -> env -> env
+val complete_inline_delta_resolver :
+  env -> module_path -> mod_bound_id -> module_type_body ->
+  delta_resolver -> delta_resolver
 
-val check_modpath_equiv : env -> module_path -> module_path -> unit
+val strengthen_and_subst_mb : module_body -> module_path -> env -> bool 
+  -> module_body
 
-val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body
+val subst_modtype_and_resolver : module_type_body -> module_path -> env ->
+  module_type_body
 
-val update_subst : env -> module_body -> module_path -> bool * substitution
+val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body
 
 val error_existing_label : label -> 'a
 
@@ -69,13 +63,13 @@ val error_application_to_not_path : module_struct_entry -> 'a
 
 val error_not_a_functor :  module_struct_entry -> 'a
 
-val error_incompatible_modtypes : 
+val error_incompatible_modtypes :
   module_type_body -> module_type_body -> 'a
 
 val error_not_equal : module_path -> module_path -> 'a
 
 val error_not_match : label -> structure_field_body -> 'a
-  
+
 val error_incompatible_labels : label -> label -> 'a
 
 val error_no_such_label : label -> 'a
@@ -84,15 +78,17 @@ val error_result_must_be_signature : unit -> 'a
 
 val error_signature_expected : struct_expr_body -> 'a
 
-val error_no_module_to_end : unit -> 'a 
+val error_no_module_to_end : unit -> 'a
 
 val error_no_modtype_to_end : unit -> 'a
 
-val error_not_a_modtype_loc : loc -> string -> 'a 
+val error_not_a_modtype_loc : loc -> string -> 'a
 
-val error_not_a_module_loc : loc -> string -> 'a 
+val error_not_a_module_loc : loc -> string -> 'a
 
-val error_not_a_module : string -> 'a 
+val error_not_a_module_or_modtype_loc : loc -> string -> 'a
+
+val error_not_a_module : string -> 'a
 
 val error_not_a_constant : label -> 'a
 
@@ -102,9 +98,9 @@ val error_a_generative_module_expected : label -> 'a
 
 val error_local_context : label option -> 'a
 
-val error_no_such_label_sub : label->string->string->'a
+val error_no_such_label_sub : label->string->'a
+
+val error_with_in_module : unit -> 'a
 
-val resolver_of_environment :
-  mod_bound_id -> module_type_body -> module_path -> substitution 
-  -> env -> resolver
+val error_application_to_module_type : unit -> 'a
 
diff --git a/kernel/names.ml b/kernel/names.ml
index b4dcd7c8..4e444985 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: names.ml 11750 2009-01-05 20:47:34Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -23,7 +23,7 @@ let string_of_id id = String.copy id
 
 (* Hash-consing of identifier *)
 module Hident = Hashcons.Make(
-  struct 
+  struct
     type t = string
     type u = string -> string
     let hash_sub hstr id = hstr id
@@ -31,7 +31,7 @@ module Hident = Hashcons.Make(
     let hash = Hashtbl.hash
   end)
 
-module IdOrdered = 
+module IdOrdered =
   struct
     type t = identifier
     let compare = id_ord
@@ -47,17 +47,11 @@ type name = Name of identifier | Anonymous
 
 (* Dirpaths are lists of module identifiers. The actual representation
    is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *)
- 
+
 type module_ident = identifier
 type dir_path = module_ident list
 
-module ModIdOrdered = 
-  struct
-    type t = identifier
-    let compare = Pervasives.compare
-  end
-
-module ModIdmap = Map.Make(ModIdOrdered)
+module ModIdmap = Idmap
 
 let make_dirpath x = x
 let repr_dirpath x = x
@@ -69,30 +63,21 @@ let string_of_dirpath = function
   | sl -> String.concat "." (List.map string_of_id (List.rev sl))
 
 
-let u_number = ref 0 
+let u_number = ref 0
 type uniq_ident = int * string * dir_path
 let make_uid dir s = incr u_number;(!u_number,String.copy s,dir)
  let debug_string_of_uid (i,s,p) =
  "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
-let string_of_uid (i,s,p) = 
+let string_of_uid (i,s,p) =
   string_of_dirpath p ^"."^s
 
-module Umap = Map.Make(struct 
-			 type t = uniq_ident 
+module Umap = Map.Make(struct
+			 type t = uniq_ident
 			 let compare = Pervasives.compare
 		       end)
 
 type label = string
 
-type mod_self_id = uniq_ident
-let make_msid = make_uid
-let repr_msid (n, id, dp) = (n, id, dp)
-let debug_string_of_msid = debug_string_of_uid
-let refresh_msid (_,s,dir) = make_uid dir s
-let string_of_msid = string_of_uid
-let id_of_msid (_,s,_) = s
-let label_of_msid (_,s,_) = s
-
 type mod_bound_id = uniq_ident
 let make_mbid = make_uid
 let repr_mbid (n, id, dp) = (n, id, dp)
@@ -114,10 +99,9 @@ module Labmap = Idmap
 type module_path =
   | MPfile of dir_path
   | MPbound of mod_bound_id
-  | MPself of mod_self_id 
+ (* | MPapp of module_path * module_path *)
   | MPdot of module_path * label
 
-
 let rec check_bound_mp = function
   | MPbound _ -> true
   | MPdot(mp,_) ->check_bound_mp mp
@@ -126,12 +110,14 @@ let rec check_bound_mp = function
 let rec string_of_mp = function
   | MPfile sl -> "MPfile (" ^ string_of_dirpath sl ^ ")"
   | MPbound uid -> string_of_uid uid
-  | MPself uid -> string_of_uid uid
+ (* | MPapp (mp1,mp2) -> 
+      "("^string_of_mp mp ^ " " ^ 
+	string_of_mp mp^")"*)
   | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
 
 (* we compare labels first if both are MPdots *)
 let rec mp_ord mp1 mp2 = match (mp1,mp2) with
-    MPdot(mp1,l1), MPdot(mp2,l2) -> 
+    MPdot(mp1,l1), MPdot(mp2,l2) ->
       let c = Pervasives.compare l1 l2 in
 	if c<>0 then
 	  c
@@ -154,31 +140,53 @@ type kernel_name = module_path * dir_path * label
 let make_kn mp dir l = (mp,dir,l)
 let repr_kn kn = kn
 
-let modpath kn = 
+let modpath kn =
   let mp,_,_ = repr_kn kn in mp
 
-let label kn = 
+let label kn =
   let _,_,l = repr_kn kn in l
 
-let string_of_kn (mp,dir,l) = 
+let string_of_kn (mp,dir,l) =
   string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l
 
 let pr_kn kn = str (string_of_kn kn)
 
 
-let kn_ord kn1 kn2 = 
+let kn_ord kn1 kn2 =
     let mp1,dir1,l1 = kn1 in
     let mp2,dir2,l2 = kn2 in
     let c = Pervasives.compare l1 l2 in
       if c <> 0 then
 	c
-      else 
+      else
 	let c = Pervasives.compare dir1 dir2 in
 	  if c<>0 then
-	    c 
+	    c
 	  else
 	    MPord.compare mp1 mp2
 
+(* a constant name is a kernel name couple (kn1,kn2) 
+   where kn1 corresponds to the name used at toplevel
+   (i.e. what the user see) 
+   and kn2 corresponds to the canonical kernel name 
+   i.e. in the environment we have 
+   kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *)
+type constant = kernel_name*kernel_name
+
+(* For the environment we distinguish constants by their 
+   user part*)
+module User_ord = struct
+  type t = kernel_name*kernel_name
+  let compare x y= kn_ord (fst x) (fst y)
+end
+
+(* For other uses (ex: non-logical things) it is enough
+   to deal with the canonical part *)
+module Canonical_ord = struct
+  type t = kernel_name*kernel_name
+  let compare x y= kn_ord (snd x) (snd y)
+end
+
 
 module KNord = struct
   type t = kernel_name
@@ -188,64 +196,115 @@ end
 module KNmap = Map.Make(KNord)
 module KNpred = Predicate.Make(KNord)
 module KNset = Set.Make(KNord)
-module Cmap = KNmap
-module Cpred = KNpred
-module Cset = KNset
+
+module Cmap = Map.Make(Canonical_ord)
+module Cmap_env = Map.Make(User_ord)
+module Cpred = Predicate.Make(Canonical_ord)
+module Cset = Set.Make(Canonical_ord)
+module Cset_env = Set.Make(User_ord)
+
+module Mindmap = Map.Make(Canonical_ord)
+module Mindset = Set.Make(Canonical_ord)
+module Mindmap_env = Map.Make(User_ord)
 
 let default_module_name = "If you see this, it's a bug"
 
 let initial_dir = make_dirpath [default_module_name]
-
-let initial_msid = (make_msid initial_dir "If you see this, it's a bug")
-let initial_path = MPself initial_msid
+let initial_path = MPfile initial_dir
 
 type variable = identifier
-type constant = kernel_name
-type mutual_inductive = kernel_name
+
+(* The same thing is done for mutual inductive names 
+   it replaces also the old mind_equiv field of mutual 
+   inductive types*)
+type mutual_inductive = kernel_name*kernel_name
 type inductive = mutual_inductive * int
 type constructor = inductive * int
 
-let constant_of_kn kn = kn
-let make_con mp dir l = (mp,dir,l)
-let repr_con con = con
-let string_of_con = string_of_kn
-let con_label = label
-let pr_con = pr_kn
-let con_modpath = modpath
-
-let mind_modpath = modpath
+let constant_of_kn kn = (kn,kn)
+let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
+let make_con mp dir l = ((mp,dir,l),(mp,dir,l))
+let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
+let canonical_con con = snd con
+let user_con con = fst con
+let repr_con con = fst con
+let string_of_con con = string_of_kn (fst con)
+let con_label con = label (fst con)
+let pr_con con = pr_kn (fst con)
+let debug_pr_con con = str "("++ pr_kn (fst con) ++ str ","++ pr_kn (snd con)++ str ")"
+let eq_constant (_,kn1) (_,kn2) = kn1=kn2
+let debug_string_of_con con =  string_of_kn (fst con)^"'"^string_of_kn (snd con)
+
+let con_modpath con = modpath (fst con)
+
+let mind_modpath mind = modpath (fst mind)
 let ind_modpath ind = mind_modpath (fst ind)
 let constr_modpath c = ind_modpath (fst c)
 
+
+let mind_of_kn kn = (kn,kn)
+let mind_of_kn_equiv kn1 kn2 = (kn1,kn2)
+let make_mind mp dir l = ((mp,dir,l),(mp,dir,l))
+let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
+let canonical_mind mind = snd mind
+let user_mind mind = fst mind
+let repr_mind mind = fst mind
+let string_of_mind mind = string_of_kn (fst mind)
+let mind_label mind= label (fst mind)
+let pr_mind mind = pr_kn (fst mind)
+let debug_pr_mind mind = str "("++ pr_kn (fst mind) ++ str ","++ pr_kn (snd mind)++ str ")"
+let eq_mind (_,kn1) (_,kn2) = kn1=kn2
+let debug_string_of_mind mind =  string_of_kn (fst mind)^"'"^string_of_kn (snd mind)
+
 let ith_mutual_inductive (kn,_) i = (kn,i)
 let ith_constructor_of_inductive ind i = (ind,i)
 let inductive_of_constructor (ind,i) = ind
 let index_of_constructor (ind,i) = i
+let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2
+let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2
 
 module InductiveOrdered = struct
   type t = inductive
-  let compare (spx,ix) (spy,iy) = 
-    let c = ix - iy in if c = 0 then KNord.compare spx spy else c
+  let compare (spx,ix) (spy,iy) =
+    let c = ix - iy in if c = 0 then Canonical_ord.compare spx spy else c
+end
+
+module InductiveOrdered_env = struct
+  type t = inductive
+  let compare (spx,ix) (spy,iy) =
+    let c = ix - iy in if c = 0 then User_ord.compare spx spy else c
 end
 
 module Indmap = Map.Make(InductiveOrdered)
+module Indmap_env = Map.Make(InductiveOrdered_env)
 
 module ConstructorOrdered = struct
   type t = constructor
-  let compare (indx,ix) (indy,iy) = 
+  let compare (indx,ix) (indy,iy) =
     let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c
 end
 
+module ConstructorOrdered_env = struct
+  type t = constructor
+  let compare (indx,ix) (indy,iy) =
+    let c = ix - iy in if c = 0 then InductiveOrdered_env.compare indx indy else c
+end
+
 module Constrmap = Map.Make(ConstructorOrdered)
+module Constrmap_env = Map.Make(ConstructorOrdered_env)
 
 (* Better to have it here that in closure, since used in grammar.cma *)
 type evaluable_global_reference =
   | EvalVarRef of identifier
   | EvalConstRef of constant
 
+let eq_egr e1 e2 = match e1,e2 with
+    EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2
+  | _,_ -> e1 = e2
+
 (* Hash-consing of name objects *)
 module Hname = Hashcons.Make(
-  struct 
+  struct
     type t = name
     type u = identifier -> identifier
     let hash_sub hident = function
@@ -260,7 +319,7 @@ module Hname = Hashcons.Make(
   end)
 
 module Hdir = Hashcons.Make(
-  struct 
+  struct
     type t = dir_path
     type u = identifier -> identifier
     let hash_sub hident d = List.map hident d
@@ -272,7 +331,7 @@ module Hdir = Hashcons.Make(
   end)
 
 module Huniqid = Hashcons.Make(
-  struct 
+  struct
     type t = uniq_ident
     type u = (string -> string) * (dir_path -> dir_path)
     let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir)
@@ -281,31 +340,31 @@ module Huniqid = Hashcons.Make(
   end)
 
 module Hmod = Hashcons.Make(
-  struct 
+  struct
     type t = module_path
     type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) *
 	(string -> string)
     let rec hash_sub (hdir,huniqid,hstr as hfuns) = function
       | MPfile dir -> MPfile (hdir dir)
       | MPbound m -> MPbound (huniqid m)
-      | MPself m -> MPself (huniqid m)
       | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l)
     let rec equal d1 d2 = match (d1,d2) with
       | MPfile dir1, MPfile dir2 -> dir1 == dir2
       | MPbound m1, MPbound m2 -> m1 == m2
-      | MPself m1, MPself m2 -> m1 == m2
       | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2
       | _ -> false
     let hash = Hashtbl.hash
   end)
 
-module Hkn = Hashcons.Make(
+
+module Hcn = Hashcons.Make(
   struct 
-    type t = kernel_name
+    type t = kernel_name*kernel_name
     type u = (module_path -> module_path)
 	* (dir_path -> dir_path) * (string -> string)
-    let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l)
-    let equal (mod1,dir1,l1) (mod2,dir2,l2) =
+    let hash_sub (hmod,hdir,hstr) ((md,dir,l),(mde,dire,le)) = 
+      ((hmod md, hdir dir, hstr l),(hmod mde, hdir dire, hstr le))
+    let equal ((mod1,dir1,l1),_) ((mod2,dir2,l2),_) =
       mod1 == mod2 && dir1 == dir2 && l1 == l2
     let hash = Hashtbl.hash
   end)
@@ -317,8 +376,9 @@ let hcons_names () =
   let hdir = Hashcons.simple_hcons Hdir.f hident in
   let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in
   let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in
-  let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in
-  (hkn,hkn,hdir,hname,hident,hstring)
+  let hmind = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in
+  let hcn = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in
+  (hcn,hmind,hdir,hname,hident,hstring)
 
 
 (*******)
@@ -333,12 +393,21 @@ let cst_full_transparent_state = (Idpred.empty, Cpred.full)
 type 'a tableKey =
   | ConstKey of constant
   | VarKey of identifier
-  | RelKey of 'a 
+  | RelKey of 'a
 
 
 type inv_rel_key = int (* index in the [rel_context] part of environment
-			  starting by the end, {\em inverse} 
+			  starting by the end, {\em inverse}
 			  of de Bruijn indice *)
 
 type id_key = inv_rel_key tableKey
 
+let eq_id_key ik1 ik2 =
+  match ik1,ik2 with
+    ConstKey (_,kn1),
+      ConstKey (_,kn2) -> kn1=kn2
+    | a,b -> a=b
+
+let eq_con_chk (kn1,_) (kn2,_) = kn1=kn2
+let eq_mind_chk (kn1,_) (kn2,_) = kn1=kn2
+let eq_ind_chk (kn1,i1) (kn2,i2) = i1=i2&&eq_mind_chk kn1 kn2
diff --git a/kernel/names.mli b/kernel/names.mli
index 49b10bfe..632f3733 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: names.mli 11582 2008-11-12 19:49:57Z notin $ i*)
+(*i $Id$ i*)
 
 (*s Identifiers *)
 
@@ -39,25 +39,13 @@ val empty_dirpath : dir_path
 (* Printing of directory paths as ["coq_root.module.submodule"] *)
 val string_of_dirpath : dir_path -> string
 
-
-(*s Unique identifier to be used as "self" in structures and 
-  signatures - invisible for users *)
-type label 
-type mod_self_id
-
-(* The first argument is a file name - to prevent conflict between 
-   different files *)
-val make_msid : dir_path -> string -> mod_self_id
-val repr_msid : mod_self_id -> int * string * dir_path
-val id_of_msid : mod_self_id -> identifier
-val label_of_msid : mod_self_id -> label
-val refresh_msid : mod_self_id -> mod_self_id
-val debug_string_of_msid : mod_self_id -> string
-val string_of_msid : mod_self_id -> string
+type label
 
 (*s Unique names for bound modules *)
 type mod_bound_id
 
+(* The first argument is a file name - to prevent conflict between
+   different files *)
 val make_mbid : dir_path -> string -> mod_bound_id
 val repr_mbid : mod_bound_id -> int * string * dir_path
 val id_of_mbid : mod_bound_id -> identifier
@@ -80,9 +68,9 @@ module Labmap : Map.S with type key = label
 type module_path =
   | MPfile of dir_path
   | MPbound of mod_bound_id
-  | MPself of mod_self_id 
+ (* | MPapp of module_path * module_path  very soon *)
   | MPdot of module_path * label
-(*i  | MPapply of module_path * module_path    in the future (maybe) i*)
+
 
 val check_bound_mp : module_path -> bool
 
@@ -91,13 +79,12 @@ val string_of_mp : module_path -> string
 module MPset : Set.S with type elt = module_path
 module MPmap : Map.S with type key = module_path
 
-(* Name of the toplevel structure *)
-val initial_msid : mod_self_id
-val initial_path : module_path (* [= MPself initial_msid] *)
-
 (* Initial "seed" of the unique identifier generator *)
 val initial_dir : dir_path
 
+(* Name of the toplevel structure *)
+val initial_path : module_path (* [= MPfile initial_dir] *)
+
 (*s The absolute names of objects seen by kernel *)
 
 type kernel_name
@@ -122,25 +109,64 @@ module KNmap  : Map.S with type key = kernel_name
 
 type variable = identifier
 type constant
-type mutual_inductive = kernel_name
+type mutual_inductive
 (* Beware: first inductive has index 0 *)
 type inductive = mutual_inductive * int
 (* Beware: first constructor has index 1 *)
 type constructor = inductive * int
 
+(* *_env modules consider an order on user part of names
+   the others consider an order on canonical part of names*)
 module Cmap  : Map.S with type key = constant
+module Cmap_env  : Map.S with type key = constant
 module Cpred  : Predicate.S with type elt = constant
 module Cset  : Set.S with type elt = constant
+module Cset_env  : Set.S with type elt = constant
+module Mindmap : Map.S with type key = mutual_inductive
+module Mindmap_env : Map.S with type key = mutual_inductive
+module Mindset : Set.S with type elt = mutual_inductive
 module Indmap : Map.S with type key = inductive
 module Constrmap : Map.S with type key = constructor
+module Indmap_env : Map.S with type key = inductive
+module Constrmap_env : Map.S with type key = constructor
 
 val constant_of_kn : kernel_name -> constant
+val constant_of_kn_equiv : kernel_name -> kernel_name -> constant
 val make_con : module_path -> dir_path -> label -> constant
+val make_con_equiv : module_path -> module_path -> dir_path 
+  -> label -> constant
+val user_con : constant -> kernel_name
+val canonical_con : constant -> kernel_name
 val repr_con : constant -> module_path * dir_path * label
+val eq_constant : constant -> constant -> bool
+
 val string_of_con : constant -> string
 val con_label : constant -> label
 val con_modpath : constant -> module_path
 val pr_con : constant -> Pp.std_ppcmds
+val debug_pr_con : constant -> Pp.std_ppcmds
+val debug_string_of_con : constant -> string
+
+
+
+val mind_of_kn : kernel_name -> mutual_inductive
+val mind_of_kn_equiv : kernel_name -> kernel_name -> mutual_inductive
+val make_mind : module_path -> dir_path -> label -> mutual_inductive
+val make_mind_equiv : module_path -> module_path -> dir_path 
+  -> label -> mutual_inductive
+val user_mind : mutual_inductive -> kernel_name
+val canonical_mind : mutual_inductive -> kernel_name
+val repr_mind : mutual_inductive -> module_path * dir_path * label
+val eq_mind : mutual_inductive -> mutual_inductive -> bool
+
+val string_of_mind : mutual_inductive -> string
+val mind_label : mutual_inductive -> label
+val mind_modpath : mutual_inductive -> module_path
+val pr_mind : mutual_inductive -> Pp.std_ppcmds
+val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds
+val debug_string_of_mind : mutual_inductive -> string
+
+
 
 val mind_modpath : mutual_inductive -> module_path
 val ind_modpath : inductive -> module_path
@@ -150,16 +176,21 @@ val ith_mutual_inductive : inductive -> int -> inductive
 val ith_constructor_of_inductive : inductive -> int -> constructor
 val inductive_of_constructor : constructor -> inductive
 val index_of_constructor : constructor -> int
+val eq_ind : inductive -> inductive -> bool
+val eq_constructor : constructor -> constructor -> bool
 
 (* Better to have it here that in Closure, since required in grammar.cma *)
 type evaluable_global_reference =
   | EvalVarRef of identifier
   | EvalConstRef of constant
 
+val eq_egr : evaluable_global_reference ->  evaluable_global_reference
+  -> bool
+
 (* Hash-consing *)
 val hcons_names : unit ->
   (constant -> constant) *
-  (kernel_name -> kernel_name) * (dir_path -> dir_path) *
+  (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) *
   (name -> name) * (identifier -> identifier) * (string -> string)
 
 
@@ -168,7 +199,7 @@ val hcons_names : unit ->
 type 'a tableKey =
   | ConstKey of constant
   | VarKey of identifier
-  | RelKey of 'a 
+  | RelKey of 'a
 
 type transparent_state = Idpred.t * Cpred.t
 
@@ -178,7 +209,16 @@ val var_full_transparent_state : transparent_state
 val cst_full_transparent_state : transparent_state
 
 type inv_rel_key = int (* index in the [rel_context] part of environment
-			  starting by the end, {\em inverse} 
+			  starting by the end, {\em inverse}
 			  of de Bruijn indice *)
 
 type id_key = inv_rel_key tableKey
+
+val eq_id_key : id_key -> id_key -> bool
+
+(*equalities on constant and inductive 
+  names for the checker*)
+
+val eq_con_chk : constant -> constant -> bool
+val eq_ind_chk : inductive -> inductive -> bool
+
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index dd4d430a..b58951e9 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.ml 10664 2008-03-14 11:27:37Z soubiran $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -18,23 +18,22 @@ open Declarations
 (* The type of environments. *)
 
 
-type key = int option ref 
+type key = int option ref
 
 type constant_key = constant_body * key
- 
+
 type globals = {
-  env_constants : constant_key Cmap.t;
-  env_inductives : mutual_inductive_body KNmap.t;
+  env_constants : constant_key Cmap_env.t;
+  env_inductives : mutual_inductive_body Mindmap_env.t;
   env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body MPmap.t;
-  env_alias : module_path MPmap.t }
+  env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
   env_engagement : engagement option
 }
 
-type val_kind = 
+type val_kind =
     | VKvalue of values * Idset.t
     | VKnone
 
@@ -56,13 +55,12 @@ type named_context_val = named_context * named_vals
 
 let empty_named_context_val = [],[]
 
-let empty_env = { 
+let empty_env = {
   env_globals = {
-    env_constants = Cmap.empty;
-    env_inductives = KNmap.empty;
+    env_constants = Cmap_env.empty;
+    env_inductives = Mindmap_env.empty;
     env_modules = MPmap.empty;
-    env_modtypes = MPmap.empty;
-    env_alias = MPmap.empty };
+    env_modtypes = MPmap.empty};
   env_named_context = empty_named_context;
   env_named_vals = [];
   env_rel_context = empty_rel_context;
@@ -77,25 +75,25 @@ let empty_env = {
 (* Rel context *)
 
 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_val = rval :: env.env_rel_val;
       env_nb_rel = env.env_nb_rel + 1 }
- 
+
 let lookup_rel_val n env =
   try List.nth env.env_rel_val (n - 1)
   with _ -> raise Not_found
-    
+
 let env_of_rel n env =
   { env with
     env_rel_context = Util.list_skipn n env.env_rel_context;
     env_rel_val = Util.list_skipn n env.env_rel_val;
     env_nb_rel = env.env_nb_rel - n
   }
-    
+
 (* Named context *)
 
 let push_named_context_val d (ctxt,vals) =
@@ -103,36 +101,32 @@ let push_named_context_val d (ctxt,vals) =
   let rval = ref VKnone in
     Sign.add_named_decl d ctxt, (id,rval)::vals
 
-exception ASSERT of Sign.rel_context
+exception ASSERT of rel_context
 
-let push_named d env = 
+let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
   let id,body,_ = d in
   let rval = ref VKnone in
-    { env with  
+    { env with
       env_named_context = Sign.add_named_decl d env.env_named_context;
       env_named_vals =  (id,rval):: env.env_named_vals }
 
 let lookup_named_val id env =
   snd(List.find (fun (id',_) -> id = id') env.env_named_vals)
-    
+
 (* Warning all the names should be different *)
 let env_of_named id env = env
- 
+
 (* Global constants *)
 
 let lookup_constant_key kn env =
-  Cmap.find kn env.env_globals.env_constants
+  Cmap_env.find kn env.env_globals.env_constants
 
 let lookup_constant kn env =
-  fst (Cmap.find kn env.env_globals.env_constants)
+  fst (Cmap_env.find kn env.env_globals.env_constants)
 
 (* Mutual Inductives *)
 let lookup_mind kn env =
-  KNmap.find kn env.env_globals.env_inductives
+  Mindmap_env.find kn env.env_globals.env_inductives
 
-let rec scrape_mind env kn = 
-  match (lookup_mind kn env).mind_equiv with
-    | None -> kn
-    | Some kn' -> scrape_mind env kn'
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 445f4e5f..718132b3 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pre_env.mli 10664 2008-03-14 11:27:37Z soubiran $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -18,23 +18,22 @@ open Declarations
 (* The type of environments. *)
 
 
-type key = int option ref 
+type key = int option ref
 
 type constant_key = constant_body * key
- 
+
 type globals = {
-  env_constants : constant_key Cmap.t;
-  env_inductives : mutual_inductive_body KNmap.t;
+  env_constants : constant_key Cmap_env.t;
+  env_inductives : mutual_inductive_body Mindmap_env.t;
   env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body MPmap.t;
-  env_alias : module_path MPmap.t }
+  env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
   env_engagement : engagement option
 }
 
-type val_kind = 
+type val_kind =
     | VKvalue of values * Idset.t
     | VKnone
 
@@ -49,7 +48,7 @@ type env = {
     env_rel_context   : rel_context;
     env_rel_val       : lazy_val list;
     env_nb_rel        : int;
-    env_stratification : stratification; 
+    env_stratification : stratification;
     retroknowledge : Retroknowledge.retroknowledge }
 
 type named_context_val = named_context * named_vals
@@ -63,14 +62,14 @@ val empty_env : env
 val nb_rel         : env -> int
 val push_rel       : rel_declaration -> env -> env
 val lookup_rel_val : int -> env -> lazy_val
-val env_of_rel     : int -> env -> env       
+val env_of_rel     : int -> env -> env
 (* Named context *)
 
-val push_named_context_val  : 
+val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 val push_named       : named_declaration -> env -> env
 val lookup_named_val : identifier -> env -> lazy_val
-val env_of_named     : identifier -> env -> env  
+val env_of_named     : identifier -> env -> env
 (* Global constants *)
 
 
@@ -80,5 +79,3 @@ val lookup_constant : constant -> env -> constant_body
 (* Mutual Inductives *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
-(* Find the ultimate inductive in the [mind_equiv] chain *)
-val scrape_mind : env -> mutual_inductive -> mutual_inductive
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 76b32463..18e2c156 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -22,7 +22,7 @@ let unfold_reference ((ids, csts), infos) k =
     | VarKey id when not (Idpred.mem id ids) -> None
     | ConstKey cst when not (Cpred.mem cst csts) -> None
     | _ -> unfold_reference infos k
-	  
+
 let rec is_empty_stack = function
     [] -> true
   | Zupdate _::s -> is_empty_stack s
@@ -87,6 +87,9 @@ let pure_stack lfts stk =
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
 
+let whd_betaiota t =
+  whd_val (create_clos_infos betaiota empty_env) (inject t)
+
 let nf_betaiota t =
   norm_val (create_clos_infos betaiota empty_env) (inject t)
 
@@ -96,13 +99,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_betadeltaiota 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)
 
-let whd_betadeltaiota_nolet env t = 
+let whd_betadeltaiota_nolet env t =
   match kind_of_term t with
     | (Sort _|Meta _|Evar _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
@@ -117,6 +120,15 @@ let beta_appvect c v =
       | _ -> applist (substl env t, stack) in
   stacklam [] c (Array.to_list v)
 
+let betazeta_appvect n c v =
+  let rec stacklam n env t stack =
+    if n = 0 then applist (substl env t, stack) else
+    match kind_of_term t, stack with
+        Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl
+      | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack
+      | _ -> anomaly "Not enough lambda/let's" in
+  stacklam n [] c (Array.to_list v)
+
 (********************************************************************)
 (*                         Conversion                               *)
 (********************************************************************)
@@ -158,8 +170,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
     and this holds whatever Set is predicative or impredicative
 *)
 
-type conv_pb = 
-  | CONV 
+type conv_pb =
+  | CONV
   | CUMUL
 
 let sort_cmp pb s0 s1 cuniv =
@@ -218,7 +230,7 @@ let in_whnf (t,stk) =
     | FLOCKED -> assert false
 
 (* Conversion between  [lft1]term1 and [lft2]term2 *)
-let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = 
+let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv =
   eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
@@ -240,7 +252,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     (* case of leaves *)
     | (FAtom a1, FAtom a2) ->
 	(match kind_of_term a1, kind_of_term a2 with
-	   | (Sort s1, Sort s2) -> 
+	   | (Sort s1, Sort s2) ->
 	       assert (is_empty_stack v1 && is_empty_stack v2);
 	       sort_cmp cv_pb s1 s2 cuniv
 	   | (Meta n, Meta m) ->
@@ -265,7 +277,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     (* 2 constants, 2 local defined vars or 2 defined rels *)
     | (FFlex fl1, FFlex fl2) ->
 	(try (* try first intensional equality *)
-	  if fl1 = fl2
+	  if eq_table_key fl1 fl2
           then convert_stacks infos lft1 lft2 v1 v2 cuniv
           else raise NotConvertible
         with NotConvertible ->
@@ -290,7 +302,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     (* only one constant, defined var or defined rel *)
     | (FFlex fl1, _)      ->
         (match unfold_reference infos fl1 with
-           | Some def1 -> 
+           | Some def1 ->
 	       eqappr cv_pb infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
            | None -> raise NotConvertible)
     | (_, FFlex fl2)      ->
@@ -298,7 +310,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
            | Some def2 ->
 	       eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
            | None -> raise NotConvertible)
-	
+
     (* other constructors *)
     | (FLambda _, FLambda _) ->
         assert (is_empty_stack v1 && is_empty_stack v2);
@@ -316,13 +328,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
      | (FInd ind1, FInd ind2) ->
-         if mind_equiv_infos (snd infos) ind1 ind2
+         if eq_ind ind1 ind2
 	 then
            convert_stacks infos lft1 lft2 v1 v2 cuniv
          else raise NotConvertible
 
      | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
-	 if j1 = j2 && mind_equiv_infos (snd infos) ind1 ind2
+	 if j1 = j2 && eq_ind ind1 ind2
 	 then
            convert_stacks infos lft1 lft2 v1 v2 cuniv
          else raise NotConvertible
@@ -337,7 +349,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
            let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
 	   let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
            let u2 =
-             convert_vect infos 
+             convert_vect infos
 		 (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
            convert_stacks infos lft1 lft2 v1 v2 u2
          else raise NotConvertible
@@ -361,22 +373,22 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
      | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
        | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
        | (FLOCKED,_) | (_,FLOCKED) ) -> assert false
-    
+
      (* In all other cases, terms are not convertible *)
      | _ -> raise NotConvertible
 
 and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
     (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
-    (mind_equiv_infos (snd infos))
+    (eq_ind)
     lft1 stk1 lft2 stk2 cuniv
 
 and convert_vect infos lft1 lft2 v1 v2 cuniv =
   let lv1 = Array.length v1 in
   let lv2 = Array.length v2 in
   if lv1 = lv2
-  then 
-    let rec fold n univ = 
+  then
+    let rec fold n univ =
       if n >= lv1 then univ
       else
         let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in
@@ -403,10 +415,10 @@ let conv ?(evars=fun _->None) = fconv CONV evars
 let conv_leq ?(evars=fun _->None) = fconv CUMUL evars
 
 let conv_leq_vecti ?(evars=fun _->None) env v1 v2 =
-  array_fold_left2_i 
+  array_fold_left2_i
     (fun i c t1 t2 ->
       let c' =
-        try conv_leq ~evars env t1 t2 
+        try conv_leq ~evars env t1 t2
         with NotConvertible -> raise (NotConvertibleVect i) in
       Constraint.union c c')
     Constraint.empty
@@ -417,25 +429,25 @@ let conv_leq_vecti ?(evars=fun _->None) env v1 v2 =
 
 let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
 let set_vm_conv f = vm_conv := f
-let vm_conv cv_pb env t1 t2 = 
-  try 
+let vm_conv cv_pb env t1 t2 =
+  try
     !vm_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
       fconv cv_pb (fun _->None) env t1 t2
-  
+
 
 let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
 
 let set_default_conv f = default_conv := f
 
-let default_conv cv_pb env t1 t2 = 
-  try 
+let default_conv cv_pb env t1 t2 =
+  try
     !default_conv cv_pb env t1 t2
   with Not_found | Invalid_argument _ ->
       (* If compilation fails, fall-back to closure conversion *)
       fconv cv_pb (fun _->None) env t1 t2
-  
+
 let default_conv_leq = default_conv CUMUL
 (*
 let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";;
@@ -462,37 +474,37 @@ let hnf_prod_app env t n =
     | Prod (_,_,b) -> subst1 n b
     | _ -> anomaly "hnf_prod_app: Need a product"
 
-let hnf_prod_applist env t nl = 
+let hnf_prod_applist env t nl =
   List.fold_left (hnf_prod_app env) t nl
 
 (* Dealing with arities *)
 
-let dest_prod env = 
+let dest_prod env =
   let rec decrec env m c =
     let t = whd_betadeltaiota env c in
     match kind_of_term t with
       | Prod (n,a,c0) ->
           let d = (n,None,a) in
-	  decrec (push_rel d env) (Sign.add_rel_decl d m) c0
+	  decrec (push_rel d env) (add_rel_decl d m) c0
       | _ -> m,t
-  in 
-  decrec env Sign.empty_rel_context
+  in
+  decrec env empty_rel_context
 
 (* The same but preserving lets *)
-let dest_prod_assum env = 
+let dest_prod_assum env =
   let rec prodec_rec env l ty =
     let rty = whd_betadeltaiota_nolet 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) (Sign.add_rel_decl d l) c
+	prodec_rec (push_rel d env) (add_rel_decl d l) c
     | LetIn (x,b,t,c) ->
         let d = (x,Some b,t) in
-	prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c
+	prodec_rec (push_rel d env) (add_rel_decl d l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> l,rty
   in
-  prodec_rec env Sign.empty_rel_context
+  prodec_rec env empty_rel_context
 
 let dest_arity env c =
   let l, c = dest_prod_assum env c in
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index d8658d43..c7c040c8 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli 11897 2009-02-09 19:28:02Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -21,6 +21,7 @@ val whd_betaiotazeta        : constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
 val whd_betadeltaiota_nolet : env -> constr -> constr
 
+val whd_betaiota      : constr -> constr
 val nf_betaiota      : constr -> constr
 
 (************************************************************************)
@@ -33,7 +34,7 @@ type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -
 
 type conv_pb = CONV | CUMUL
 
-val sort_cmp : 
+val sort_cmp :
     conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints
 
 val conv_sort      : sorts conversion_function
@@ -63,9 +64,12 @@ val default_conv_leq : types conversion_function
 
 (************************************************************************)
 
-(* Builds an application node, reducing beta redexes it may produce. *) 
+(* 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
+
 (* Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
 val hnf_prod_applist : env -> types -> constr list -> types
 
@@ -73,8 +77,8 @@ val hnf_prod_applist : env -> types -> constr list -> types
 (************************************************************************)
 (*s Recognizing products and arities modulo reduction *)
 
-val dest_prod       : env -> types -> Sign.rel_context * types
-val dest_prod_assum : env -> types -> Sign.rel_context * types
+val dest_prod       : env -> types -> rel_context * types
+val dest_prod_assum : env -> types -> rel_context * types
 
-val dest_arity : env -> types -> Sign.arity
+val dest_arity : env -> types -> arity
 val is_arity   : env -> types -> bool
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index 7a1880be..a3e493db 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retroknowledge.ml 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id$ *)
 
 open Term
 open Names
@@ -28,8 +28,8 @@ type nat_field =
   | NatType
   | NatPlus
   | NatTimes
-  
-type n_field = 
+
+type n_field =
   | NPositive
   | NType
   | NTwice
@@ -39,7 +39,7 @@ type n_field =
   | NPlus
   | NTimes
 
-type int31_field = 
+type int31_field =
   | Int31Bits
   | Int31Type
   | Int31Twice
@@ -77,20 +77,15 @@ type flags = {fastcomputation : bool}
 
 (*A definition of maps from strings to pro_int31, to be able
   to have any amount of coq representation for the 31bits integers *)
-module OrderedField =
-struct
-  type t = field
-  let compare = compare
-end
-
-module Proactive = Map.Make (OrderedField)
 
+module Proactive =
+  Map.Make (struct type t = field let compare = compare end)
 
 type proactive = entry Proactive.t
 
-(* the reactive knowledge is represented as a functionaly map 
+(* the reactive knowledge is represented as a functionaly map
    from the type of terms (actually it is the terms whose outermost
-   layer is unfolded (typically by Term.kind_of_term)) to the 
+   layer is unfolded (typically by Term.kind_of_term)) to the
    type reactive_end which is a record containing all the kind of reactive
    information needed *)
 (* todo: because of the bug with output state, reactive_end should eventually
@@ -98,13 +93,8 @@ type proactive = entry Proactive.t
    a finite type describing the fields to the field of proactive retroknowledge
    (and then to make as many functions as needed in environ.ml) *)
 
-module OrderedEntry =
-struct
-  type t = entry
-  let compare = compare
-end
-
-module Reactive = Map.Make (OrderedEntry)
+module Reactive =
+  Map.Make (struct type t = entry let compare = compare end)
 
 type reactive_end = {(*information required by the compiler of the VM *)
   vm_compiling :
@@ -141,18 +131,18 @@ type action =
 
 
 (*initialisation*)
-let initial_flags = 
+let initial_flags =
       {fastcomputation = true;}
 
-let initial_proactive = 
+let initial_proactive =
   (Proactive.empty:proactive)
 
-let initial_reactive = 
+let initial_reactive =
   (Reactive.empty:reactive)
 
 let initial_retroknowledge =
-  {flags = initial_flags; 
-   proactive = initial_proactive; 
+  {flags = initial_flags;
+   proactive = initial_proactive;
    reactive = initial_reactive }
 
 let empty_reactive_end =
@@ -185,7 +175,7 @@ let find knowledge field =
 (*access functions for reactive retroknowledge*)
 
 (* used for compiling of functions (add, mult, etc..) *)
-let get_vm_compiling_info knowledge key = 
+let get_vm_compiling_info knowledge key =
   match (Reactive.find key knowledge.reactive).vm_compiling
   with
     | None -> raise Not_found
@@ -205,18 +195,18 @@ let get_vm_constant_dynamic_info knowledge key =
     | None -> raise Not_found
     | Some f -> f knowledge.flags.fastcomputation
 
-let get_vm_before_match_info knowledge key = 
+let get_vm_before_match_info knowledge key =
   match (Reactive.find key knowledge.reactive).vm_before_match
   with
     | None -> raise Not_found
     | Some f -> f knowledge.flags.fastcomputation
 
-let get_vm_decompile_constant_info knowledge key = 
+let get_vm_decompile_constant_info knowledge key =
   match (Reactive.find key knowledge.reactive).vm_decompile_const
   with
     | None -> raise Not_found
     | Some f -> f
-  
+
 
 
 (* functions manipulating reactive knowledge *)
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index ee3fccd5..0f1cdc8e 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: retroknowledge.mli 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,8 +24,8 @@ type nat_field =
   | NatType
   | NatPlus
   | NatTimes
-  
-type n_field = 
+
+type n_field =
   | NPositive
   | NType
   | NTwice
@@ -35,7 +35,7 @@ type n_field =
   | NPlus
   | NTimes
 
-type int31_field = 
+type int31_field =
   | Int31Bits
   | Int31Type
   | Int31Twice
@@ -81,14 +81,14 @@ val initial_retroknowledge : retroknowledge
    returns the compilation of id in cont if it has a specific treatment
    or raises Not_found if id should be compiled as usual *)
 val get_vm_compiling_info  : retroknowledge -> entry -> Cbytecodes.comp_env ->
-                             constr array -> 
+                             constr array ->
                              int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes
 (*Given an identifier id (usually Construct _)
    and its argument array, returns a function that tries an ad-hoc optimisated
    compilation (in the case of the 31-bit integers it means compiling them
    directly into an integer)
    raises Not_found if id should be compiled as usual, and expectingly
-   CBytecodes.NotClosed if the term is not a closed constructor pattern 
+   CBytecodes.NotClosed if the term is not a closed constructor pattern
    (a constant for the compiler) *)
 val get_vm_constant_static_info : retroknowledge -> entry ->
                                    constr array ->
@@ -99,19 +99,19 @@ val get_vm_constant_static_info : retroknowledge -> entry ->
    of id+args+cont when id has a specific treatment (in the case of
    31-bit integers, that would be the dynamic compilation into integers)
    or raises Not_found if id should be compiled as usual *)
-val get_vm_constant_dynamic_info : retroknowledge -> entry -> 
-                                Cbytecodes.comp_env -> 
-                                Cbytecodes.block array -> 
+val get_vm_constant_dynamic_info : retroknowledge -> entry ->
+                                Cbytecodes.comp_env ->
+                                Cbytecodes.block array ->
                                 int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes
-(* Given a type identifier, this function is used before compiling a match 
-   over this type. In the case of 31-bit integers for instance, it is used 
+(* Given a type identifier, this function is used before compiling a match
+   over this type. In the case of 31-bit integers for instance, it is used
    to add the instruction sequence which would perform a dynamic decompilation
    in case the argument of the match is not in coq representation *)
 val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes
                                                        -> Cbytecodes.bytecodes
 
-(* Given a type identifier, this function is used by pretyping/vnorm.ml to 
-   recover the elements of that type from their compiled form if it's non 
+(* Given a type identifier, this function is used by pretyping/vnorm.ml to
+   recover the elements of that type from their compiled form if it's non
    standard (it is used (and can be used) only when the compiled form
    is not a block *)
 val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr
@@ -127,26 +127,26 @@ val find : retroknowledge -> field -> entry
 (* the following function manipulate the reactive information of values
    they are only used by the functions of Pre_env, and Environ to implement
    the functions register and unregister of Environ *)
-val add_vm_compiling_info : retroknowledge-> entry -> 
+val add_vm_compiling_info : retroknowledge-> entry ->
                             (bool -> Cbytecodes.comp_env -> constr array -> int ->
                             Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
                             retroknowledge
-val add_vm_constant_static_info : retroknowledge-> entry -> 
+val add_vm_constant_static_info : retroknowledge-> entry ->
                                   (bool->constr array->
                                       Cbytecodes.structured_constant) ->
                                   retroknowledge
-val add_vm_constant_dynamic_info : retroknowledge-> entry -> 
-                                   (bool -> Cbytecodes.comp_env -> 
-                                   Cbytecodes.block array -> int -> 
+val add_vm_constant_dynamic_info : retroknowledge-> entry ->
+                                   (bool -> Cbytecodes.comp_env ->
+                                   Cbytecodes.block array -> int ->
                                    Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
                                    retroknowledge
 val add_vm_before_match_info : retroknowledge -> entry ->
                               (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) ->
                               retroknowledge
 
-val add_vm_decompile_constant_info : retroknowledge -> entry -> 
+val add_vm_decompile_constant_info : retroknowledge -> entry ->
                                     (int -> constr) -> retroknowledge
-                                      
+
 
 val clear_info : retroknowledge-> entry -> retroknowledge
 
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 7a2db86b..cf3546c7 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: safe_typing.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -27,21 +27,21 @@ open Subtyping
 open Mod_typing
 open Mod_subst
 
-type modvariant = 
-  | NONE 
-  | SIG of (* funsig params *) (mod_bound_id * module_type_body) list 
+
+type modvariant =
+  | NONE
+  | SIG of (* funsig params *) (mod_bound_id * module_type_body) list
   | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list
   | LIBRARY of dir_path
 
-type module_info = 
-    { msid : mod_self_id;
-      modpath : module_path;
-      seed : dir_path; (* the "seed" of unique identifier generator *)
-      label : label;
-      variant : modvariant;
-      alias_subst : substitution}
-
-let check_label l labset = 
+type module_info =
+    {modpath : module_path;
+     label : label;
+     variant : modvariant;
+     resolver : delta_resolver;
+     resolver_of_param : delta_resolver;}
+      
+let check_label l labset =
   if Labset.mem l labset then error_existing_label l
 
 let set_engagement_opt oeng env =
@@ -51,7 +51,7 @@ let set_engagement_opt oeng env =
 
 type library_info = dir_path * Digest.t
 
-type safe_environment = 
+type safe_environment =
     { old : safe_environment;
       env : env;
       modinfo : module_info;
@@ -75,16 +75,15 @@ type safe_environment =
 
 
 (* a small hack to avoid variants and an unused case in all functions *)
-let rec empty_environment = 
-  { old = empty_environment; 
+let rec empty_environment =
+  { old = empty_environment;
     env = empty_env;
     modinfo = {
-      msid = initial_msid;
       modpath = initial_path;
-      seed = initial_dir;
       label = mk_label "_";
       variant = NONE;
-      alias_subst = empty_subst};
+      resolver = empty_delta_resolver;
+      resolver_of_param = empty_delta_resolver};
     labset = Labset.empty;
     revstruct = [];
     univ = Univ.Constraint.empty;
@@ -102,7 +101,7 @@ let env_of_senv = env_of_safe_env
 
 
 
-let add_constraints cst senv = 
+let add_constraints cst senv =
   {senv with
     env = Environ.add_constraints cst senv.env;
     univ = Univ.Constraint.union cst senv.univ }
@@ -112,7 +111,7 @@ let add_constraints cst senv =
 
 (* terms which are closed under the environnement env, i.e
    terms which only depends on constant who are themselves closed *)
-let closed env term = 
+let closed env term =
   ContextObjectMap.is_empty (assumptions full_transparent_state env term)
 
 (* the set of safe terms in an environement any recursive set of
@@ -125,15 +124,15 @@ let safe =
 
 
 (* universal lifting, used for the "get" operations mostly *)
-let retroknowledge f senv = 
+let retroknowledge f senv =
   Environ.retroknowledge f (env_of_senv senv)
 
-let register senv field value by_clause = 
+let register senv field value by_clause =
   (* todo : value closed, by_clause safe, by_clause of the proper type*)
   (* spiwack : updates the safe_env with the information that the register
      action has to be performed (again) when the environement is imported *)
   {senv with env = Environ.register senv.env field value;
-             local_retroknowledge = 
+             local_retroknowledge =
       Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
   }
 
@@ -162,7 +161,7 @@ let unregister senv field  =
 let safe_push_named (id,_,_ as d) env =
   let _ =
     try
-      let _ = lookup_named id env in 
+      let _ = lookup_named id env in
       error ("Identifier "^string_of_id id^" already defined.")
     with Not_found -> () in
   Environ.push_named d env
@@ -182,7 +181,7 @@ let push_named_assum (id,t) senv =
 
 (* Insertion of constants and parameters in environment. *)
 
-type global_declaration = 
+type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
 
@@ -205,8 +204,8 @@ let hcons_constant_body cb =
 let add_constant dir l decl senv =
   check_label l senv.labset;
   let kn = make_con senv.modinfo.modpath dir l in
-  let cb = 
-    match decl with 
+  let cb =
+    match decl with
       | ConstantEntry ce -> translate_constant senv.env kn ce
       | GlobalRecipe r ->
 	  let cb = translate_recipe senv.env kn r in
@@ -214,9 +213,16 @@ let add_constant dir l decl senv =
   in
   let senv' = add_constraints cb.const_constraints senv in
   let env'' = Environ.add_constant kn cb senv'.env in
+  let resolver = 
+    if cb.const_inline then
+      add_inline_delta_resolver kn senv'.modinfo.resolver
+    else
+      senv'.modinfo.resolver
+  in
     kn, { old = senv'.old;
 	  env = env'';
-	  modinfo = senv'.modinfo;
+	  modinfo = {senv'.modinfo with
+		       resolver = resolver};
 	  labset = Labset.add l senv'.labset;
 	  revstruct = (l,SFBconst cb)::senv'.revstruct;
           univ = senv'.univ;
@@ -224,24 +230,24 @@ let add_constant dir l decl senv =
 	  imports = senv'.imports;
 	  loads = senv'.loads ;
 	  local_retroknowledge = senv'.local_retroknowledge }
-    
+
 
 (* Insertion of inductive types. *)
 
 let add_mind dir l mie senv =
-  if mie.mind_entry_inds = [] then 
-    anomaly "empty inductive types declaration"; 
+  if mie.mind_entry_inds = [] then
+    anomaly "empty inductive types declaration";
             (* this test is repeated by translate_mind *)
   let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in
   if l <> label_of_id id then
     anomaly ("the label of inductive packet and its first inductive"^
 	     " type do not match");
-  check_label l senv.labset; 
-    (* TODO: when we will allow reorderings we will have to verify 
+  check_label l senv.labset;
+    (* TODO: when we will allow reorderings we will have to verify
        all labels *)
   let mib = translate_mind senv.env mie in
   let senv' = add_constraints mib.mind_constraints senv in
-  let kn = make_kn senv.modinfo.modpath dir l in
+  let kn = make_mind senv.modinfo.modpath dir l in
   let env'' = Environ.add_mind kn mib senv'.env in
   kn, { old = senv'.old;
 	env = env'';
@@ -256,212 +262,221 @@ let add_mind dir l mie senv =
 
 (* Insertion of module types *)
 
-let add_modtype l mte senv = 
-  check_label l senv.labset; 
-  let mtb_expr,sub = translate_struct_entry senv.env mte  in
-  let mtb = { typ_expr = mtb_expr;
-	      typ_strength = None;
-	      typ_alias = sub} in
-  let senv' = add_constraints 
-    (struct_expr_constraints mtb_expr) senv in
+let add_modtype l mte inl senv =
+  check_label l senv.labset;
   let mp = MPdot(senv.modinfo.modpath, l) in
-  let env'' = Environ.add_modtype mp mtb senv'.env in
-  mp, { old = senv'.old;
-	env = env'';
-	modinfo = senv'.modinfo;
-	labset = Labset.add l senv'.labset;
-	revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
-        univ = senv'.univ;
-        engagement = senv'.engagement;
-	imports = senv'.imports;
-	loads = senv'.loads;
-        local_retroknowledge = senv'.local_retroknowledge }
+  let mtb = translate_module_type senv.env mp inl mte  in
+  let senv' = add_constraints mtb.typ_constraints senv in
+   let env'' = Environ.add_modtype mp mtb senv'.env in
+    mp, { old = senv'.old;
+	  env = env'';
+	  modinfo = senv'.modinfo;
+	  labset = Labset.add l senv'.labset;
+	  revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
+          univ = senv'.univ;
+          engagement = senv'.engagement;
+	  imports = senv'.imports;
+	  loads = senv'.loads;
+          local_retroknowledge = senv'.local_retroknowledge }
 
 
 (* full_add_module adds module with universes and constraints *)
-let full_add_module mp mb senv =
-  let senv = add_constraints (module_constraints mb) senv in
-  let env = Modops.add_module mp mb senv.env in
+let full_add_module mb senv =
+  let senv = add_constraints mb.mod_constraints senv in
+  let env = Modops.add_module mb senv.env in
     {senv with env = env}
-      
+
 (* Insertion of modules *)
-      
-let add_module l me senv = 
-  check_label l senv.labset; 
-  let mb = translate_module senv.env me in
+
+let add_module l me inl senv =
+  check_label l senv.labset;
   let mp = MPdot(senv.modinfo.modpath, l) in
-  let senv' = full_add_module mp mb senv in
-  let is_functor,sub = Modops.update_subst senv'.env mb mp in
-  mp, { old = senv'.old;
-	env = senv'.env;
-	modinfo = 
-      if is_functor then
-	senv'.modinfo
-      else
-	{senv'.modinfo with 
-	   alias_subst = join senv'.modinfo.alias_subst sub};
-	labset = Labset.add l senv'.labset;
-	revstruct = (l,SFBmodule mb)::senv'.revstruct;
-        univ = senv'.univ;
-        engagement = senv'.engagement;
-	imports = senv'.imports;
-	loads = senv'.loads;
-        local_retroknowledge = senv'.local_retroknowledge }
-    
-let add_alias l mp senv =
-  check_label l senv.labset; 
-  let mp' = MPdot(senv.modinfo.modpath, l) in
-  let mp1 = scrape_alias mp senv.env in
-  let typ_opt = 
-    if check_bound_mp mp then
-      Some (strengthen senv.env
-	(lookup_modtype mp senv.env).typ_expr mp)
-    else
-      None 
+  let mb = translate_module senv.env mp inl me in
+  let senv' = full_add_module mb senv  in
+  let modinfo = match mb.mod_type with
+      SEBstruct _ -> 
+	{ senv'.modinfo with
+	    resolver = 
+	    add_delta_resolver mb.mod_delta senv'.modinfo.resolver}
+    | _ -> senv'.modinfo
   in
-    (* we get all updated alias substitution {mp1.K\M}  that comes from mp1 *)
-  let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in
-    (* transformation of {mp1.K\M} to {mp.K\M}*)
-  let sub = update_subst sub (map_mp mp' mp1) in
-   (* transformation of {mp.K\M}  to {mp.K\M'} where M'=M{mp1\mp'}*)
-  let sub = join_alias sub (map_mp mp' mp1) in
-    (* we add the alias substitution  *)
-  let sub = add_mp mp' mp1 sub in
-  let env' = register_alias mp' mp senv.env in
-    mp', { old = senv.old;
-	env = env';
-	modinfo = { senv.modinfo with 
-		      alias_subst = join 
-	    senv.modinfo.alias_subst sub};
-	labset = Labset.add l senv.labset;
-	revstruct = (l,SFBalias (mp,typ_opt,None))::senv.revstruct;
-        univ = senv.univ;
-        engagement = senv.engagement;
-	imports = senv.imports;
-	loads = senv.loads;
-        local_retroknowledge = senv.local_retroknowledge }
-
+    mp,mb.mod_delta,
+  { old = senv'.old;
+    env = senv'.env;
+    modinfo = modinfo;
+    labset = Labset.add l senv'.labset;
+    revstruct = (l,SFBmodule mb)::senv'.revstruct;
+    univ = senv'.univ;
+    engagement = senv'.engagement;
+    imports = senv'.imports;
+    loads = senv'.loads;
+    local_retroknowledge = senv'.local_retroknowledge }
+    
 (* Interactive modules *)
 
-let start_module l senv = 
-  check_label l senv.labset; 
-  let msid = make_msid senv.modinfo.seed (string_of_label l) in
-  let mp = MPself msid in
-  let modinfo = { msid = msid;
-		  modpath = mp;
-		  seed = senv.modinfo.seed;
-		  label = l;
-		  variant = STRUCT [];
-		  alias_subst = empty_subst}
-  in
-  mp, { old = senv;
-	env = senv.env;
-	modinfo = modinfo;
-	labset = Labset.empty;
-	revstruct = [];
-        univ = Univ.Constraint.empty;
-        engagement = None;
-	imports = senv.imports;
-	loads = [];
-	(* spiwack : not sure, but I hope it's correct *)
-        local_retroknowledge = [] }
-
-let end_module l restype senv = 
+let start_module l senv =
+  check_label l senv.labset;
+ let mp = MPdot(senv.modinfo.modpath, l) in
+ let modinfo = { modpath = mp;
+		 label = l;
+		 variant = STRUCT [];
+		 resolver = empty_delta_resolver;
+		 resolver_of_param = empty_delta_resolver}
+ in
+   mp, { old = senv;
+	 env = senv.env;
+	 modinfo = modinfo;
+	 labset = Labset.empty;
+	 revstruct = [];
+         univ = Univ.Constraint.empty;
+         engagement = None;
+	 imports = senv.imports;
+	 loads = [];
+	 (* spiwack : not sure, but I hope it's correct *)
+         local_retroknowledge = [] }
+
+let end_module l restype senv =
   let oldsenv = senv.old in
   let modinfo = senv.modinfo in
-  let restype = Option.map (translate_struct_entry senv.env) restype in
-  let params,is_functor = 
+  let mp = senv.modinfo.modpath in
+  let restype =
+    Option.map
+      (fun (res,inl) -> translate_module_type senv.env mp inl res) restype in
+  let params,is_functor =
     match modinfo.variant with
       | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
       | STRUCT params -> params, (List.length params > 0)
   in
   if l <> modinfo.label then error_incompatible_labels l modinfo.label;
   if not (empty_context senv.env) then error_local_context None;
-  let functorize_struct tb = 
+  let functorize_struct tb =
     List.fold_left
-      (fun mtb (arg_id,arg_b) -> 
+      (fun mtb (arg_id,arg_b) ->
 	SEBfunctor(arg_id,arg_b,mtb))
       tb
       params
   in
-   let auto_tb = 
-     SEBstruct (modinfo.msid, List.rev senv.revstruct)
+   let auto_tb =
+     SEBstruct (List.rev senv.revstruct)
   in
-  let mod_typ,subst,cst = 
+   let mexpr,mod_typ,mod_typ_alg,resolver,cst = 
     match restype with
-      | None ->  None,modinfo.alias_subst,Constraint.empty
-      | Some (res_tb,subst) -> 
-	  let cst = check_subtypes senv.env
-	    {typ_expr = auto_tb;
-	     typ_strength = None;
-	     typ_alias = modinfo.alias_subst}
-	    {typ_expr = res_tb;
-	     typ_strength = None;
-	     typ_alias = subst} in
-	  let mtb = functorize_struct res_tb in
-	    Some mtb,subst,cst
+      | None ->  let mexpr = functorize_struct auto_tb in
+	 mexpr,mexpr,None,modinfo.resolver,Constraint.empty
+      | Some mtb ->
+	  let auto_mtb = {
+	    typ_mp = senv.modinfo.modpath;
+	    typ_expr = auto_tb;
+	    typ_expr_alg = None;
+	    typ_constraints = Constraint.empty;
+	    typ_delta = empty_delta_resolver} in
+	  let cst = check_subtypes senv.env auto_mtb
+	    mtb in
+	  let mod_typ = functorize_struct mtb.typ_expr in
+	  let mexpr = functorize_struct auto_tb in
+	  let typ_alg = 
+	    Option.map functorize_struct mtb.typ_expr_alg in
+	    mexpr,mod_typ,typ_alg,mtb.typ_delta,cst
   in
-  let mexpr = functorize_struct auto_tb in
   let cst = Constraint.union cst senv.univ in
-  let mb = 
-    { mod_expr = Some mexpr;
+  let mb =
+    { mod_mp = mp;
+      mod_expr = Some mexpr;
       mod_type = mod_typ;
+      mod_type_alg = mod_typ_alg;
       mod_constraints = cst;
-      mod_alias = subst;
+      mod_delta = resolver;
       mod_retroknowledge = senv.local_retroknowledge }
   in
-  let mp = MPdot (oldsenv.modinfo.modpath, l) in
   let newenv = oldsenv.env in
   let newenv = set_engagement_opt senv.engagement newenv in
   let senv'= {senv with env=newenv} in
-  let senv' = 
+  let senv' =
     List.fold_left
-      (fun env (mp,mb) -> full_add_module mp mb env) 
+      (fun env (_,mb) -> full_add_module mb env) 
       senv'
       (List.rev senv'.loads)
   in
   let newenv = Environ.add_constraints cst senv'.env in
-  let newenv = 
-    Modops.add_module mp mb newenv
-  in 
-  let is_functor,subst = Modops.update_subst newenv mb mp in
-  let newmodinfo = 
-    if is_functor then
-      oldsenv.modinfo
-    else
-      { oldsenv.modinfo with 
-	  alias_subst = join 
-	  oldsenv.modinfo.alias_subst 
-	  subst };
+  let newenv =
+    Modops.add_module mb newenv in 
+  let modinfo = match mb.mod_type with
+      SEBstruct _ -> 
+	{ oldsenv.modinfo with
+	    resolver = 
+	    add_delta_resolver resolver oldsenv.modinfo.resolver}
+    | _ -> oldsenv.modinfo
   in
-    mp, { old = oldsenv.old;
-	env = newenv;
-	modinfo = newmodinfo;
-	labset = Labset.add l oldsenv.labset;
-	revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
-        univ = Univ.Constraint.union senv'.univ oldsenv.univ;
-        (* engagement is propagated to the upper level *)
-        engagement = senv'.engagement;
-	imports = senv'.imports;
-	loads = senv'.loads@oldsenv.loads;
-	local_retroknowledge = senv'.local_retroknowledge@oldsenv.local_retroknowledge }
+    mp,resolver,{ old = oldsenv.old;
+		  env = newenv;
+		  modinfo = modinfo;
+		  labset = Labset.add l oldsenv.labset;
+		  revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
+		  univ = Univ.Constraint.union senv'.univ oldsenv.univ;
+		  (* engagement is propagated to the upper level *)
+		  engagement = senv'.engagement;
+		  imports = senv'.imports;
+		  loads = senv'.loads@oldsenv.loads;
+		  local_retroknowledge = 
+	senv'.local_retroknowledge@oldsenv.local_retroknowledge }
 
 
 (* Include for module and module type*)
- let add_include me senv =
-   let struct_expr,_ =  translate_struct_entry senv.env me in
-   let senv = add_constraints (struct_expr_constraints struct_expr) senv in
-   let msid,str = match (eval_struct senv.env struct_expr) with
-     | SEBstruct(msid,str_l) -> msid,str_l
-     | _ -> error ("You cannot Include a higher-order Module or Module Type.")
+ let add_include me is_module inl senv =
+   let sign,cst,resolver =
+     if is_module then
+       let sign,resolver,cst =  
+	 translate_struct_include_module_entry senv.env 
+	   senv.modinfo.modpath inl me in
+	 sign,cst,resolver
+     else
+       let mtb = 
+	 translate_module_type senv.env 
+	   senv.modinfo.modpath inl me in
+       mtb.typ_expr,mtb.typ_constraints,mtb.typ_delta
    in
+   let senv = add_constraints cst senv in
    let mp_sup = senv.modinfo.modpath in
-   let str1 = subst_signature_msid msid mp_sup str in
-   let add senv (l,elem)  = 
+     (* Include Self support  *)
+  let rec compute_sign sign mb resolver senv = 
+     match sign with
+     | SEBfunctor(mbid,mtb,str) ->
+	 let cst_sub = check_subtypes senv.env mb mtb in
+	 let senv = add_constraints cst_sub senv in
+	 let mpsup_delta = if not inl then mb.typ_delta else
+	   complete_inline_delta_resolver senv.env mp_sup mbid mtb mb.typ_delta
+	 in
+	 let subst = map_mbid mbid mp_sup mpsup_delta in
+	 let resolver = subst_codom_delta_resolver subst resolver in
+	   (compute_sign 
+	      (subst_struct_expr subst str) mb resolver senv)
+     | str -> resolver,str,senv
+  in
+   let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup;
+				      typ_expr = SEBstruct (List.rev senv.revstruct);
+				      typ_expr_alg = None;
+				      typ_constraints = Constraint.empty;
+				      typ_delta = senv.modinfo.resolver} resolver senv in
+   let str = match sign with
+     | SEBstruct(str_l) -> str_l
+     | _ -> error ("You cannot Include a high-order structure.")
+   in
+   let senv =
+     {senv 
+      with modinfo = 
+	 {senv.modinfo
+	  with resolver =
+	     add_delta_resolver resolver senv.modinfo.resolver}}
+   in
+   let add senv (l,elem)  =
      check_label l senv.labset;
      match elem with
        | SFBconst cb ->
-	   let con = make_con mp_sup empty_dirpath l in
+	   let kn = make_kn mp_sup empty_dirpath l in
+	   let con = constant_of_kn_equiv kn
+	     (canonical_con 
+		(constant_of_delta resolver (constant_of_kn kn)))
+	   in
 	   let senv' = add_constraints cb.const_constraints senv in
 	   let env'' = Environ.add_constant con cb senv'.env in
 	     { old = senv'.old;
@@ -474,34 +489,30 @@ let end_module l restype senv =
 	       imports = senv'.imports;
 	       loads = senv'.loads ;
 	       local_retroknowledge = senv'.local_retroknowledge }
-	       	     
        | SFBmind mib ->
 	   let kn = make_kn mp_sup empty_dirpath l in
+	   let mind = mind_of_kn_equiv kn
+	     (canonical_mind 
+		(mind_of_delta resolver (mind_of_kn kn)))
+	   in
 	   let senv' = add_constraints mib.mind_constraints senv in
-	   let env'' = Environ.add_mind kn mib senv'.env in
+	   let env'' = Environ.add_mind mind mib senv'.env in
 	     { old = senv'.old;
 	       env = env'';
 	       modinfo = senv'.modinfo;
-	       labset = Labset.add l senv'.labset;  
+	       labset = Labset.add l senv'.labset;
 	       revstruct = (l,SFBmind mib)::senv'.revstruct;
                univ = senv'.univ;
                engagement = senv'.engagement;
 	       imports = senv'.imports;
 	       loads = senv'.loads;
                local_retroknowledge = senv'.local_retroknowledge }
-	       
+
        | SFBmodule mb ->
-	   let mp = MPdot(senv.modinfo.modpath, l) in
-	   let is_functor,sub = Modops.update_subst senv.env mb mp in
-	   let senv' = full_add_module mp mb senv in
+	   let senv' = full_add_module mb senv in
 	     { old = senv'.old;
 	       env = senv'.env;
-	       modinfo = 
-		 if is_functor then
-		   senv'.modinfo
-		 else
-		   {senv'.modinfo with 
-		      alias_subst = join senv'.modinfo.alias_subst sub};
+	       modinfo = senv'.modinfo;
 	       labset = Labset.add l senv'.labset;
 	       revstruct = (l,SFBmodule mb)::senv'.revstruct;
 	       univ = senv'.univ;
@@ -509,87 +520,69 @@ let end_module l restype senv =
 	       imports = senv'.imports;
 	       loads = senv'.loads;
 	       local_retroknowledge = senv'.local_retroknowledge }
-       | SFBalias (mp',typ_opt,cst) ->
-	   let env' = Option.fold_right 
-	     Environ.add_constraints cst senv.env in
-	   let mp = MPdot(senv.modinfo.modpath, l) in
-	   let mp1 = scrape_alias mp' senv.env in
-	   let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in
-	   let sub = update_subst sub (map_mp mp mp1) in
-	   let sub = join_alias sub (map_mp mp mp1) in
-	   let sub = add_mp mp mp1 sub in
-	   let env' = register_alias mp mp' env' in
-	     { old = senv.old;
-	       env = env';
-	       modinfo =  { senv.modinfo with 
-			      alias_subst = join 
-		   senv.modinfo.alias_subst sub};
-	       labset = Labset.add l senv.labset;
-	       revstruct = (l,SFBalias (mp',typ_opt,cst))::senv.revstruct;
-               univ = senv.univ;
-               engagement = senv.engagement;
-	       imports = senv.imports;
-	       loads = senv.loads;
-               local_retroknowledge = senv.local_retroknowledge }
        | SFBmodtype mtb ->
-	   let env' = add_modtype_constraints senv.env mtb in
+	   let senv' = add_constraints mtb.typ_constraints senv in
 	   let mp = MPdot(senv.modinfo.modpath, l) in
-	   let env'' = Environ.add_modtype mp mtb env' in
+	   let env' = Environ.add_modtype mp mtb senv'.env in
 	     { old = senv.old;
-	       env = env'';
-	       modinfo = senv.modinfo;
+	       env = env';
+	       modinfo = senv'.modinfo;
 	       labset = Labset.add l senv.labset;
-	       revstruct = (l,SFBmodtype mtb)::senv.revstruct;
-               univ = senv.univ;
-               engagement = senv.engagement;
-	       imports = senv.imports;
-	       loads = senv.loads;
-               local_retroknowledge = senv.local_retroknowledge }
+	       revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
+               univ = senv'.univ;
+               engagement = senv'.engagement;
+	       imports = senv'.imports;
+	       loads = senv'.loads;
+               local_retroknowledge = senv'.local_retroknowledge }
    in
-     List.fold_left add senv str1
-	   
+     resolver,(List.fold_left add senv str)
+
 (* Adding parameters to modules or module types *)
 
-let add_module_parameter mbid mte senv =
+let add_module_parameter mbid mte inl senv =
   if  senv.revstruct <> [] or senv.loads <> [] then
     anomaly "Cannot add a module parameter to a non empty module";
-  let mtb_expr,sub = translate_struct_entry senv.env mte in
-  let mtb = {typ_expr = mtb_expr;
-	    typ_strength = None;
-	    typ_alias = sub} in
-  let senv = full_add_module (MPbound mbid) (module_body_of_type mtb) senv 
+  let mtb = translate_module_type senv.env (MPbound mbid) inl mte in
+  let senv = 
+    full_add_module (module_body_of_type (MPbound mbid) mtb) senv
   in
   let new_variant = match senv.modinfo.variant with
     | STRUCT params -> STRUCT ((mbid,mtb) :: params)
     | SIG params -> SIG ((mbid,mtb) :: params)
-    | _ -> 
-	anomaly "Module parameters can only be added to modules or signatures"
+    | _ ->
+	anomaly "Module parameters can only be added to modules or signatures"  
   in
-  { old = senv.old;
-    env = senv.env;
-    modinfo = { senv.modinfo with variant = new_variant };
-    labset = senv.labset;
-    revstruct = [];
-    univ = senv.univ;
-    engagement = senv.engagement;
-    imports = senv.imports;
-    loads = [];
-    local_retroknowledge = senv.local_retroknowledge }
-
+    
+  let resolver_of_param = match mtb.typ_expr with
+      SEBstruct _ -> mtb.typ_delta
+    | _ -> empty_delta_resolver
+  in
+    mtb.typ_delta, { old = senv.old;
+		     env = senv.env;
+		     modinfo = { senv.modinfo with 
+				   variant = new_variant;
+				   resolver_of_param = add_delta_resolver
+			      resolver_of_param senv.modinfo.resolver_of_param};
+		     labset = senv.labset;
+		     revstruct = [];
+		     univ = senv.univ;
+		     engagement = senv.engagement;
+		     imports = senv.imports;
+		     loads = [];
+		     local_retroknowledge = senv.local_retroknowledge }
+      
 
 (* Interactive module types *)
 
-let start_modtype l senv = 
-  check_label l senv.labset; 
-  let msid = make_msid senv.modinfo.seed (string_of_label l) in
-  let mp = MPself msid in
-  let modinfo = { msid = msid;
-		  modpath = mp;
-		  seed = senv.modinfo.seed;
-		  label = l;
-		  variant = SIG [];
-		  alias_subst = empty_subst }
-  in
+let start_modtype l senv =
+  check_label l senv.labset;
+ let mp = MPdot(senv.modinfo.modpath, l) in
+ let modinfo = { modpath = mp;
+		 label = l;
+		 variant = SIG [];
+		 resolver = empty_delta_resolver;
+		 resolver_of_param = empty_delta_resolver}
+ in
   mp, { old = senv;
 	env = senv.env;
 	modinfo = modinfo;
@@ -602,64 +595,61 @@ let start_modtype l senv =
 	(* spiwack: not 100% sure, but I think it should be like that *)
         local_retroknowledge = []}
 
-let end_modtype l senv = 
+let end_modtype l senv =
   let oldsenv = senv.old in
   let modinfo = senv.modinfo in
-  let params = 
+  let params =
     match modinfo.variant with
       | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end ()
       | SIG params -> params
   in
   if l <> modinfo.label then error_incompatible_labels l modinfo.label;
   if not (empty_context senv.env) then error_local_context None;
-  let auto_tb = 
-     SEBstruct (modinfo.msid, List.rev senv.revstruct)
+  let auto_tb =
+     SEBstruct (List.rev senv.revstruct)
   in
-  let mtb_expr = 
+  let mtb_expr =
     List.fold_left
-      (fun mtb (arg_id,arg_b) -> 
+      (fun mtb (arg_id,arg_b) ->
 	 SEBfunctor(arg_id,arg_b,mtb))
       auto_tb
       params
   in
   let mp = MPdot (oldsenv.modinfo.modpath, l) in
   let newenv = oldsenv.env in
-  (* since universes constraints cannot be stored in the modtype,
-     they are propagated to the upper level *)
   let newenv = Environ.add_constraints senv.univ  newenv in
   let newenv = set_engagement_opt senv.engagement newenv in
   let senv = {senv with env=newenv} in
-  let senv = 
+  let senv =
     List.fold_left
-      (fun env (mp,mb) -> full_add_module mp mb env) 
+      (fun env (mp,mb) -> full_add_module mb env)
       senv
       (List.rev senv.loads)
   in
-  let subst = senv.modinfo.alias_subst in
-  let mtb = {typ_expr = mtb_expr;
-	    typ_strength = None;
-	    typ_alias = subst} in
-  let newenv = 
+  let mtb = {typ_mp = mp;
+    typ_expr = mtb_expr;
+    typ_expr_alg = None;
+    typ_constraints = senv.univ;
+    typ_delta = senv.modinfo.resolver} in
+  let newenv =
     Environ.add_modtype mp mtb senv.env
-  in 
+  in
     mp, { old = oldsenv.old;
 	  env = newenv;
-	modinfo = oldsenv.modinfo;
-	labset = Labset.add l oldsenv.labset;
-	revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
-        univ = Univ.Constraint.union senv.univ oldsenv.univ;
-        engagement = senv.engagement;
-	imports = senv.imports;
-	loads = senv.loads@oldsenv.loads;
-        (* spiwack : if there is a bug with retroknowledge in nested modules
-                     it's likely to come from here *)
-        local_retroknowledge = 
-                   senv.local_retroknowledge@oldsenv.local_retroknowledge}
-  
+	  modinfo = oldsenv.modinfo;
+	  labset = Labset.add l oldsenv.labset;
+	  revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
+          univ = Univ.Constraint.union senv.univ oldsenv.univ;
+          engagement = senv.engagement;
+	  imports = senv.imports;
+	  loads = senv.loads@oldsenv.loads;
+          (* spiwack : if there is a bug with retroknowledge in nested modules
+             it's likely to come from here *)
+          local_retroknowledge = 
+        senv.local_retroknowledge@oldsenv.local_retroknowledge}
 
 let current_modpath senv = senv.modinfo.modpath
-let current_msid senv = senv.modinfo.msid
-
+let delta_of_senv senv = senv.modinfo.resolver,senv.modinfo.resolver_of_param
 
 (* Check that the engagement expected by a library matches the initial one *)
 let check_engagement env c =
@@ -676,34 +666,32 @@ let set_engagement c senv =
 
 (* Libraries = Compiled modules *)
 
-type compiled_library = 
+type compiled_library =
     dir_path * module_body * library_info list * engagement option
 
-(* We check that only initial state Require's were performed before 
+(* We check that only initial state Require's were performed before
    [start_library] was called *)
 
 let is_empty senv =
   senv.revstruct = [] &&
-  senv.modinfo.msid = initial_msid &&
+  senv.modinfo.modpath = initial_path &&
   senv.modinfo.variant = NONE
 
 let start_library dir senv =
   if not (is_empty senv) then
     anomaly "Safe_typing.start_library: environment should be empty";
-  let dir_path,l = 
+  let dir_path,l =
     match (repr_dirpath dir) with
 	[] -> anomaly "Empty dirpath in Safe_typing.start_library"
       | hd::tl ->
 	  make_dirpath tl, label_of_id hd
   in
-  let msid = make_msid dir_path (string_of_label l) in
-  let mp = MPself msid in
-  let modinfo = { msid = msid;
-		  modpath = mp;
-		  seed = dir;
-		  label = l;
-		  variant = LIBRARY dir;
-		  alias_subst = empty_subst }
+  let mp = MPfile dir in
+  let modinfo = {modpath = mp;
+		 label = l;
+		 variant = LIBRARY dir;
+		 resolver = empty_delta_resolver;
+		 resolver_of_param = empty_delta_resolver}
   in
   mp, { old = senv;
 	env = senv.env;
@@ -716,13 +704,21 @@ let start_library dir senv =
 	loads = [];
         local_retroknowledge = [] }
 
+let pack_module senv =
+  {mod_mp=senv.modinfo.modpath;
+   mod_expr=None;
+   mod_type= SEBstruct (List.rev senv.revstruct);
+   mod_type_alg=None;
+   mod_constraints=Constraint.empty;
+   mod_delta=senv.modinfo.resolver;
+   mod_retroknowledge=[];
+  }
 
-
-let export senv dir = 
+let export senv dir =
   let modinfo = senv.modinfo in
   begin
     match modinfo.variant with
-      | LIBRARY dp -> 
+      | LIBRARY dp ->
 	  if dir <> dp then
 	    anomaly "We are not exporting the right library!"
       | _ ->
@@ -730,14 +726,18 @@ let export senv dir =
   end;
   (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then
     (* error_export_simple *) (); *)
-  let mb = 
-    { mod_expr = Some (SEBstruct (modinfo.msid, List.rev senv.revstruct));
-      mod_type = None;
+    let str = SEBstruct (List.rev senv.revstruct) in
+    let mp = senv.modinfo.modpath in
+    let mb = 
+    { mod_mp = mp;
+      mod_expr = Some str;
+      mod_type = str;
+      mod_type_alg = None;
       mod_constraints = senv.univ;
-      mod_alias = senv.modinfo.alias_subst;
+      mod_delta = senv.modinfo.resolver;
       mod_retroknowledge = senv.local_retroknowledge}
   in
-    modinfo.msid, (dir,mb,senv.imports,engagement senv.env)
+   mp, (dir,mb,senv.imports,engagement senv.env)
 
 
 let check_imports senv needed =
@@ -748,7 +748,7 @@ let check_imports senv needed =
       if stamp <> actual_stamp then
 	error
 	  ("Inconsistent assumptions over module "^(string_of_dirpath id)^".")
-    with Not_found -> 
+    with Not_found ->
       error ("Reference to unknown module "^(string_of_dirpath id)^".")
   in
   List.iter check needed
@@ -767,16 +767,20 @@ environment, and store for the future (instead of just its type)
 loaded by side-effect once and for all (like it is done in OCaml).
 Would this be correct with respect to undo's and stuff ?
 *)
- 
-let import (dp,mb,depends,engmt) digest senv = 
+
+let import (dp,mb,depends,engmt) digest senv =
   check_imports senv depends;
   check_engagement senv.env engmt;
   let mp = MPfile dp in
   let env = senv.env in
   let env = Environ.add_constraints mb.mod_constraints env in
-  let env = Modops.add_module mp mb env in
-  mp, { senv with 
-	  env = env; 
+  let env = Modops.add_module mb env in
+  mp, { senv with
+	  env = env;
+	  modinfo = 
+      {senv.modinfo with 
+	 resolver = 
+	    add_delta_resolver mb.mod_delta senv.modinfo.resolver};
 	  imports = (dp,digest)::senv.imports;
 	  loads = (mp,mb)::senv.loads }
 
@@ -784,35 +788,35 @@ let import (dp,mb,depends,engmt) digest senv =
 (* Remove the body of opaque constants in modules *)
  let rec lighten_module mb =
   { mb with
-    mod_expr = Option.map lighten_modexpr mb.mod_expr;
-    mod_type = Option.map lighten_modexpr mb.mod_type;
+    mod_expr = None;
+    mod_type = lighten_modexpr mb.mod_type;
   }
-    
-and lighten_struct struc = 
+
+and lighten_struct struc =
   let lighten_body (l,body) = (l,match body with
     | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
-    | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x
+    | (SFBconst _ | SFBmind _ ) as x -> x
     | SFBmodule m -> SFBmodule (lighten_module m)
-    | SFBmodtype m -> SFBmodtype 
-	({m with 
+    | SFBmodtype m -> SFBmodtype
+	({m with
 	    typ_expr = lighten_modexpr m.typ_expr}))
   in
     List.map lighten_body struc
 
 and lighten_modexpr = function
   | SEBfunctor (mbid,mty,mexpr) ->
-      SEBfunctor (mbid, 
-		    ({mty with 
+      SEBfunctor (mbid,
+		    ({mty with
 			typ_expr = lighten_modexpr mty.typ_expr}),
 		  lighten_modexpr mexpr)
   | SEBident mp as x -> x
-  | SEBstruct (msid, struc) ->
-      SEBstruct (msid, lighten_struct struc)
+  | SEBstruct (struc) ->
+      SEBstruct  (lighten_struct struc)
   | SEBapply (mexpr,marg,u) ->
       SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
   | SEBwith (seb,wdcl) ->
-      SEBwith (lighten_modexpr seb,wdcl) 
- 
+      SEBwith (lighten_modexpr seb,wdcl)
+
 let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
 
 
@@ -822,8 +826,5 @@ let j_val j = j.uj_val
 let j_type j = j.uj_type
 
 let safe_infer senv = infer (env_of_senv senv)
-    
-let typing senv = Typeops.typing (env_of_senv senv)
-
-
 
+let typing senv = Typeops.typing (env_of_senv senv)
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 6d656f8b..c378d8cc 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: safe_typing.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
 open Term
 open Declarations
 open Entries
+open Mod_subst
 (*i*)
 
 (*s Safe environments. Since we are now able to type terms, we can
@@ -20,7 +21,7 @@ open Entries
   typed before being added.
 
   We also add [open_structure] and [close_section], [close_module] to
-  provide functionnality for sections and interactive modules 
+  provide functionnality for sections and interactive modules
 *)
 
 type safe_environment
@@ -39,35 +40,31 @@ val push_named_def :
     Univ.constraints * safe_environment
 
 (* Adding global axioms or definitions *)
-type global_declaration = 
+type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
 
-val add_constant : 
-  dir_path -> label -> global_declaration -> safe_environment -> 
+val add_constant :
+  dir_path -> label -> global_declaration -> safe_environment ->
       constant * safe_environment
 
 (* Adding an inductive type *)
-val add_mind : 
+val add_mind :
   dir_path -> label -> mutual_inductive_entry -> safe_environment ->
     mutual_inductive * safe_environment
 
 (* Adding a module *)
 val add_module :
-  label -> module_entry -> safe_environment 
-    -> module_path * safe_environment
+  label -> module_entry -> bool -> safe_environment
+    -> module_path * delta_resolver * safe_environment
 
-(* Adding a module alias*)
-val add_alias :
-  label -> module_path -> safe_environment 
-    -> module_path * safe_environment
 (* Adding a module type *)
 val add_modtype :
-  label -> module_struct_entry -> safe_environment 
+  label -> module_struct_entry -> bool -> safe_environment
     -> module_path * safe_environment
 
 (* Adding universe constraints *)
-val add_constraints : 
+val add_constraints :
   Univ.constraints -> safe_environment -> safe_environment
 
 (* Settin the strongly constructive or classical logical engagement *)
@@ -75,14 +72,15 @@ val set_engagement : engagement -> safe_environment -> safe_environment
 
 
 (*s Interactive module functions *)
-val start_module : 
+val start_module :
   label -> safe_environment -> module_path * safe_environment
+
 val end_module :
-  label -> module_struct_entry option 
-      -> safe_environment -> module_path * safe_environment 
+  label -> (module_struct_entry * bool) option
+      -> safe_environment -> module_path * delta_resolver * safe_environment 
 
 val add_module_parameter :
-  mod_bound_id -> module_struct_entry -> safe_environment -> safe_environment
+  mod_bound_id -> module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment
 
 val start_modtype :
   label -> safe_environment -> module_path * safe_environment
@@ -91,24 +89,25 @@ val end_modtype :
   label -> safe_environment -> module_path * safe_environment
 
 val add_include :
-  module_struct_entry -> safe_environment -> safe_environment
+  module_struct_entry -> bool -> bool -> safe_environment ->
+   delta_resolver * safe_environment
 
+val pack_module : safe_environment -> module_body
 val current_modpath : safe_environment -> module_path
-val current_msid : safe_environment -> mod_self_id
-
-
+val delta_of_senv : safe_environment -> delta_resolver*delta_resolver
+  
 (* Loading and saving compilation units *)
 
 (* exporting and importing modules *)
 type compiled_library
 
-val start_library : dir_path -> safe_environment 
+val start_library : dir_path -> safe_environment
       -> module_path * safe_environment
 
-val export : safe_environment -> dir_path  
-      -> mod_self_id * compiled_library
+val export : safe_environment -> dir_path
+      -> module_path * compiled_library
 
-val import : compiled_library -> Digest.t -> safe_environment 
+val import : compiled_library -> Digest.t -> safe_environment
       -> module_path * safe_environment
 
 (* Remove the body of opaque constants *)
diff --git a/kernel/sign.ml b/kernel/sign.ml
index 8fa59809..d30d7086 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sign.ml 10451 2008-01-18 17:20:28Z barras $ *)
+(* $Id$ *)
 
 open Names
 open Util
@@ -43,31 +43,6 @@ 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
 
-(*s Signatures of ordered optionally named variables, intended to be
-   accessed by de Bruijn indices (to represent bound variables) *)
-
-type rel_declaration = name * constr option * types
-type rel_context = rel_declaration list
-
-let empty_rel_context = []
-
-let add_rel_decl d ctxt = d::ctxt
-
-let rec lookup_rel n sign =
-  match n, sign with
-  | 1, decl :: _ -> decl
-  | n, _ :: sign -> lookup_rel (n-1) sign
-  | _, []        -> raise Not_found
-
-let rel_context_length = List.length
-
-let rel_context_nhyps hyps =
-  let rec nhyps acc = function
-    | [] -> acc
-    | (_,None,_)::hyps -> nhyps (1+acc) hyps
-    | (_,Some _,_)::hyps -> nhyps acc hyps in
-  nhyps 0 hyps
-
 let 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
 
@@ -102,98 +77,3 @@ let push_named_to_rel_context hyps ctxt =
 	(n+1), (map_rel_declaration (substn_vars n s) d)::ctxt
     | [] -> 1, hyps in
   snd (subst ctxt)
-
-
-(*********************************)
-(*       Term constructors       *)
-(*********************************)
-
-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)
-
-(*********************************)
-(*       Term destructors        *)
-(*********************************)
-
-type arity = rel_context * sorts
-
-(* Decompose an arity (i.e. a product of the form (x1:T1)..(xn:Tn)s
-   with s a sort) into the pair ([(xn,Tn);...;(x1,T1)],s) *)
-
-let destArity = 
-  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
-    | Cast (c,_,_)      -> prodec_rec l c
-    | Sort s          -> l,s
-    | _               -> anomaly "destArity: not an arity"
-  in 
-  prodec_rec []
-
-let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign
-
-let rec isArity c =
-  match kind_of_term c with
-  | Prod (_,_,c)    -> isArity c
-  | LetIn (_,b,_,c) -> isArity (subst1 b c)
-  | Cast (c,_,_)      -> isArity c
-  | Sort _          -> true
-  | _               -> false
-
-(* 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 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
-    | Cast (c,_,_)      -> prodec_rec l c
-    | _               -> l,c
-  in 
-  prodec_rec empty_rel_context
-
-(* 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 =
-    match kind_of_term c with
-    | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) c
-    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c
-    | Cast (c,_,_)      -> lamdec_rec l c
-    | _               -> l,c
-  in 
-  lamdec_rec empty_rel_context
-
-(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T 
-   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
-let decompose_prod_n_assum n =
-  if n < 0 then
-    error "decompose_prod_n_assum: integer parameter must be positive";
-  let rec prodec_rec l n c = 
-    if n=0 then l,c
-    else match 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"
-  in 
-  prodec_rec empty_rel_context n
-
-(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
-   into the pair ([(xn,Tn);...;(x1,T1)],T)
-   Lets in between are not expanded but turn into local definitions,
-   but n is the actual number of destructurated lambdas.  *)
-let decompose_lam_n_assum n =
-  if n < 0 then
-    error "decompose_lam_n_assum: integer parameter must be positive";
-  let rec lamdec_rec l n c = 
-    if n=0 then l,c 
-    else match 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"
-  in 
-  lamdec_rec empty_rel_context n 
-
diff --git a/kernel/sign.mli b/kernel/sign.mli
index 88e9dbf0..b3e7ace5 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: sign.mli 9103 2006-09-01 11:02:52Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -40,16 +40,6 @@ val instance_from_named_context : named_context -> constr array
 (*s Signatures of ordered optionally named variables, intended to be
    accessed by de Bruijn indices *)
 
-(* In [rel_context], more recent declaration is on top *)
-type rel_context = rel_declaration list
-
-val empty_rel_context : rel_context
-val add_rel_decl : rel_declaration -> rel_context -> rel_context
-
-val lookup_rel : int -> rel_context -> rel_declaration
-val rel_context_length : rel_context -> int
-val rel_context_nhyps : rel_context -> int
-
 val push_named_to_rel_context : named_context -> rel_context -> rel_context
 
 (*s Recurrence on [rel_context]: older declarations processed first *)
@@ -70,35 +60,3 @@ val iter_rel_context : (constr -> unit) -> rel_context -> unit
 
 (*s Map function of [named_context] *)
 val iter_named_context : (constr -> unit) -> named_context -> unit
-
-(*s Term constructors *)
-
-val it_mkLambda_or_LetIn : constr -> rel_context -> constr
-val it_mkProd_or_LetIn : types -> rel_context -> types
-
-(*s Term destructors *)
-
-(* Destructs a term of the form $(x_1:T_1)..(x_n:T_n)s$ into the pair *)
-type arity = rel_context * sorts
-val destArity : types -> arity
-val mkArity : arity -> types
-val isArity : types -> bool
-
-(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ including letins
-   into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a
-   product nor a let. *)
-val decompose_prod_assum : types -> rel_context * types
-
-(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ including letins
-   into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a
-   lambda nor a let. *)
-val decompose_lam_assum : constr -> rel_context * constr
-
-(* Given a positive integer n, transforms a product term 
-   $(x_1:T_1)..(x_n:T_n)T$
-   into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
-val decompose_prod_n_assum : int -> types -> rel_context * types
-
-(* Given a positive integer $n$, transforms a lambda term 
-   $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
-val decompose_lam_n_assum : int -> constr -> rel_context * constr
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 98ee1dbb..e07af3ba 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.ml 11453 2008-10-15 14:42:34Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -27,22 +27,21 @@ open Entries
 (* This local type is used to subtype a constant with a constructor or
    an inductive type. It can also be useful to allow reorderings in
    inductive types *)
-type namedobject = 
+type namedobject =
   | Constant of constant_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
   | Module of module_body
   | Modtype of module_type_body
-  | Alias of module_path * struct_expr_body option
 
 (* adds above information about one mutual inductive: all types and
    constructors *)
 
-let add_nameobjects_of_mib ln mib map = 
+let add_nameobjects_of_mib ln mib map =
   let add_nameobjects_of_one j oib map =
     let ip = (ln,j) in
-    let map = 
-      array_fold_right_i 
+    let map =
+      array_fold_right_i
       (fun i id map ->
         Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
       oib.mind_consnames
@@ -55,16 +54,15 @@ let add_nameobjects_of_mib ln mib map =
 
 (* creates namedobject map for the whole signature *)
 
-let make_label_map mp list = 
-  let add_one (l,e) map = 
+let make_label_map mp list =
+  let add_one (l,e) map =
    let add_map obj = Labmap.add l obj map in
    match e with
     | SFBconst cb -> add_map (Constant cb)
     | SFBmind mib ->
-       add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map
+       add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map
     | SFBmodule mb -> add_map (Module mb)
     | SFBmodtype mtb -> add_map (Modtype mtb)
-    | SFBalias (mp,typ_opt,cst) -> add_map (Alias (mp,typ_opt))
   in
     List.fold_right add_one list Labmap.empty
 
@@ -75,20 +73,23 @@ let check_conv_error error cst f env a1 a2 =
       NotConvertible -> error ()
 
 (* for now we do not allow reorderings *)
-let check_inductive cst env msid1 l info1 mib2 spec2 = 
-  let kn = make_kn (MPself msid1) empty_dirpath l in
+
+let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= 
+  let kn1 = make_mind mp1 empty_dirpath l in
+  let kn2 = make_mind mp2 empty_dirpath l in
   let error () = error_not_match l spec2 in
   let check_conv cst f = check_conv_error error cst f in
-  let mib1 = 
+  let mib1 =
     match info1 with
-      | IndType ((_,0), mib) -> mib
+      | IndType ((_,0), mib) -> subst_mind subst1 mib
       | _ -> error ()
   in
+  let mib2 =  subst_mind subst2 mib2 in
   let check_inductive_type cst env t1 t2 =
 
     (* Due to sort-polymorphism in inductive types, the conclusions of
        t1 and t2, if in Type, are generated as the least upper bounds
-       of the types of the constructors. 
+       of the types of the constructors.
 
        By monotonicity of the infered l.u.b.  wrt subtyping (i.e.  if X:U
        |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each
@@ -115,8 +116,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
       | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort
       | (Prop _, Type _) | (Type _,Prop _) -> error ()
       | _ -> (s1, s2) in
-    check_conv cst conv_leq env 
-      (Sign.mkArity (ctx1,s1)) (Sign.mkArity (ctx2,s2))
+    check_conv cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
   in
 
   let check_packet cst p1 p2 =
@@ -139,17 +139,17 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
 	cst
   in
   let check_cons_types i cst p1 p2 =
-    array_fold_left2 
+    array_fold_left2
       (fun cst t1 t2 -> check_conv cst conv env t1 t2)
       cst
-      (arities_of_specif kn (mib1,p1))
-      (arities_of_specif kn (mib2,p2))
+      (arities_of_specif kn1 (mib1,p1))
+      (arities_of_specif kn1 (mib2,p2))
   in
   let check f = if f mib1 <> f mib2 then error () in
   check (fun mib -> mib.mind_finite);
   check (fun mib -> mib.mind_ntypes);
   assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
-  assert (Array.length mib1.mind_packets >= 1 
+  assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
 
   (* Check that the expected numbers of uniform parameters are the same *)
@@ -159,46 +159,43 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
   (* the inductive types and constructors types have to be convertible *)
   check (fun mib -> mib.mind_nparams);
 
-  begin 
-    match mib2.mind_equiv with
-      | None -> ()
-      | Some kn2' -> 
-	  let kn2 = scrape_mind env kn2' in
-	  let kn1 = match mib1.mind_equiv with
-	      None -> kn
-	    | Some kn1' -> scrape_mind env kn1'
-	  in
-	    if kn1 <> kn2 then error ()
+  begin  
+  match mind_of_delta reso2 kn2  with
+      | kn2' when kn2=kn2' -> ()
+      | kn2' -> 
+	  if not (eq_mind (mind_of_delta reso1 kn1) kn2') then 
+	    error ()
   end;
   (* we check that records and their field names are preserved. *)
   check (fun mib -> mib.mind_record);
-  if mib1.mind_record then begin 
-    let rec names_prod_letin t = match kind_of_term t with 
+  if mib1.mind_record then begin
+    let rec names_prod_letin t = match kind_of_term t with
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
       | Cast(t,_,_) -> names_prod_letin t
       | _ -> []
-    in 
+    in
     assert (Array.length mib1.mind_packets = 1);
     assert (Array.length mib2.mind_packets = 1);
-    assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); 
-    assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); 
+    assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
+    assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
     check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
   end;
   (* we first check simple things *)
-  let cst = 
+  let cst =
     array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
   in
   (* and constructor types in the end *)
-  let cst = 
+  let cst =
     array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
   in
     cst
+
     
-let check_constant cst env msid1 l info1 cb2 spec2 = 
+let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = 
   let error () = error_not_match l spec2 in
   let check_conv cst f = check_conv_error error cst f in
-  let check_type cst env t1 t2 = 
+  let check_type cst env t1 t2 =
 
     (* If the type of a constant is generated, it may mention
        non-variable algebraic universes that the general conversion
@@ -209,9 +206,9 @@ let check_constant cst env msid1 l info1 cb2 spec2 =
        Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
        Hence they don't have to be checked again *)
 
-    let t1,t2 = 
-      if Sign.isArity t2 then
-        let (ctx2,s2) = Sign.destArity t2 in
+    let t1,t2 =
+      if isArity t2 then
+        let (ctx2,s2) = destArity t2 in
         match s2 with
         | Type v when not (is_univ_variable v) ->
           (* The type in the interface is inferred and is made of algebraic
@@ -222,13 +219,13 @@ let check_constant cst env msid1 l info1 cb2 spec2 =
             | Type u when not (is_univ_variable u) ->
               (* Both types are inferred, no need to recheck them. We
                  cheat and collapse the types to Prop *)
-                Sign.mkArity (ctx1,prop_sort), Sign.mkArity (ctx2,prop_sort)
+                mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort)
             | Prop _ ->
               (* The type in the interface is inferred, it may be the case
                  that the type in the implementation is smaller because
                  the body is more reduced. We safely collapse the upper
                  type to Prop *)
-                Sign.mkArity (ctx1,prop_sort), Sign.mkArity (ctx2,prop_sort)
+                mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort)
             | Type _ ->
               (* The type in the interface is inferred and the type in the
                  implementation is not inferred or is inferred but from a
@@ -246,32 +243,40 @@ let check_constant cst env msid1 l info1 cb2 spec2 =
   in
 
   match info1 with
-   | Constant cb1 ->
-      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
-      (*Start by checking types*)
+    | Constant cb1 ->
+	assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+	(*Start by checking types*)
+	let cb1 = subst_const_body subst1 cb1 in
+	let cb2 = subst_const_body subst2 cb2 in
       let typ1 = Typeops.type_of_constant_type env cb1.const_type in
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
       let cst = check_type cst env typ1 typ2 in
-      let con = make_con (MPself msid1) empty_dirpath l in
+      let con = make_con mp1 empty_dirpath l in
       let cst =
 	if cb2.const_opaque then
+	  (* In this case we compare opaque definitions, we need to bypass
+	     the opacity and do a delta step*)
 	  match cb2.const_body with
             | None -> cst
             | Some lc2 ->
 		let c2 = Declarations.force lc2 in
 		let c1 = match cb1.const_body with
-		  | Some lc1 -> 
+		  | Some lc1 ->
 		      let c = Declarations.force lc1 in
 			begin
-			  match (kind_of_term c) with
-			      Const n -> 
-				let cb = lookup_constant n env in
+			  match (kind_of_term c),(kind_of_term c2) with
+			      Const n1,Const n2 when (eq_constant n1 n2) -> c
+				(* c1 may have been strenghtened 
+				   we need to unfold it*)
+			    | Const n,_ ->
+				let cb = subst_const_body subst1
+				  (lookup_constant n env) in
 				  (match cb.const_opaque,
 				     cb.const_body with
-				       | true, Some lc1 -> 
+				       | true, Some lc1 ->
 					   Declarations.force lc1
 				       | _,_ -> c)
-			    | _ -> c
+			    | _ ,_-> c
 			end
 		  | None -> mkConst con
 		in
@@ -311,120 +316,103 @@ let check_constant cst env msid1 l info1 cb2 spec2 =
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
        check_conv cst conv env ty1 ty2
    | _ -> error ()
-	      
-let rec check_modules cst env msid1 l msb1 msb2 alias =
-  let mp = (MPdot(MPself msid1,l)) in
-  let mty1 = module_type_of_module (Some mp) msb1 in
-  let alias1,struct_expr = match eval_struct env mty1.typ_expr with
-    	| SEBstruct (msid,sign) as str ->
-	    update_subst alias (map_msid msid mp),str
-	| _ as str -> empty_subst,str in
-  let mty1 = {mty1 with 
-		typ_expr = struct_expr;
-		typ_alias = join alias1 mty1.typ_alias } in
-  let mty2 =  module_type_of_module None msb2 in
-  let cst = check_modtypes cst env mty1 mty2 false in
+
+let rec check_modules cst env msb1 msb2 subst1 subst2 =
+  let mty1 = module_type_of_module env None msb1 in
+  let mty2 =  module_type_of_module env None msb2 in
+  let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in
     cst
-	
 
-and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = 
-  let mp1 = MPself msid1 in
-  let env = add_signature mp1 sig1 env in 
-  let sig1 = subst_structure alias sig1 in
-  let alias1 = update_subst alias (map_msid msid2 mp1) in
-  let sig2 = subst_structure alias1 sig2' in
-  let sig2 = subst_signature_msid msid2 mp1 sig2 in
+and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= 
   let map1 = make_label_map mp1 sig1 in
-  let check_one_body cst (l,spec2) = 
-    let info1 = 
-      try 
-	Labmap.find l map1 
-      with 
-	  Not_found -> error_no_such_label_sub l 
-	    (string_of_msid msid1) (string_of_msid msid2)
+  let check_one_body cst (l,spec2) =
+    let info1 =
+      try
+	Labmap.find l map1
+      with
+	  Not_found -> error_no_such_label_sub l
+	    (string_of_mp mp1)
     in
       match spec2 with
 	| SFBconst cb2 ->
-	    check_constant cst env msid1 l info1 cb2 spec2
-	| SFBmind mib2 -> 
-	    check_inductive cst env msid1 l info1 mib2 spec2
-	| SFBmodule msb2 ->  
+	    check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2
+	| SFBmind mib2 ->
+	    check_inductive cst env
+	      mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
+	| SFBmodule msb2 ->
 	    begin
 	      match info1 with
-		| Module msb -> check_modules cst env msid1 l msb msb2 alias
-		| Alias (mp,typ_opt) ->let msb = 
-		    {mod_expr = Some (SEBident mp);
-		     mod_type = typ_opt;
-		     mod_constraints = Constraint.empty;
-		     mod_alias = (lookup_modtype mp env).typ_alias;
-		     mod_retroknowledge = []} in
-		    check_modules cst env msid1 l msb msb2 alias
-		| _ -> error_not_match l spec2
-	    end
-	| SFBalias (mp,typ_opt,_) ->
-	    begin	
-	      match info1 with
-		| Alias (mp1,_) -> check_modpath_equiv env mp mp1; cst
-		| Module msb -> 
-		    let msb1 = 
-		      {mod_expr = Some (SEBident mp);
-		       mod_type = typ_opt;
-		       mod_constraints = Constraint.empty;
-		       mod_alias = (lookup_modtype mp env).typ_alias;
-		       mod_retroknowledge = []} in
-			check_modules cst env msid1 l msb msb1 alias
+		| Module msb -> check_modules cst env msb msb2 
+		    subst1 subst2
 		| _ -> error_not_match l spec2
 	    end
 	| SFBmodtype mtb2 ->
-	    let mtb1 = 
+	    let mtb1 =
 	      match info1 with
 		| Modtype mtb -> mtb
 		| _ -> error_not_match l spec2
 	    in
-	      check_modtypes cst env mtb1 mtb2 true
+	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
+	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
+	      check_modtypes cst env mtb1 mtb2 subst1 subst2 true
   in
     List.fold_left check_one_body cst sig2
-    
 
-and check_modtypes cst env mtb1 mtb2 equiv = 
-  if mtb1==mtb2 then cst else (* just in case  :) *)
-  let mtb1',mtb2'=
-    (match mtb1.typ_strength with
-	 None -> eval_struct env mtb1.typ_expr,
-	   eval_struct env mtb2.typ_expr
-       | Some mp -> strengthen  env mtb1.typ_expr mp,
-	   eval_struct env mtb2.typ_expr) in
-      let rec check_structure cst env str1 str2 equiv = 
-	match str1, str2 with
-	  | SEBstruct (msid1,list1), 
-	    SEBstruct (msid2,list2) -> 
-	      let cst = check_signatures cst env
-		(msid1,list1) mtb1.typ_alias (msid2,list2) in
-		if equiv then
-		  check_signatures cst env 
-		    (msid2,list2) mtb2.typ_alias  (msid1,list1) 
-		else
-		  cst
-	  | SEBfunctor (arg_id1,arg_t1,body_t1), 
+and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = 
+  if mtb1==mtb2 then cst else 
+  let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in
+  let rec check_structure cst env str1 str2 equiv subst1 subst2 = 
+	match str1,str2 with
+	  | SEBstruct (list1), 
+	    SEBstruct (list2) -> 
+	      if equiv then
+		let subst2 = 
+		  add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in
+		Univ.Constraint.union 
+		  (check_signatures cst env
+		     mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
+		  mtb1.typ_delta mtb2.typ_delta) 
+		  (check_signatures cst env 
+		     mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1
+		  mtb2.typ_delta  mtb1.typ_delta)
+	      else
+		check_signatures cst env
+		  mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
+		  mtb1.typ_delta  mtb2.typ_delta
+	  | SEBfunctor (arg_id1,arg_t1,body_t1),
 	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
-	      let cst = check_modtypes cst env arg_t2 arg_t1 equiv in 
+	      let subst1 = 
+		(join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in
+	      let cst = check_modtypes cst env 
+		arg_t2 arg_t1 subst2 subst1
+		equiv in 
 		(* contravariant *)
-	      let env = 
-		add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
+	      let env = add_module 
+		(module_body_of_type (MPbound arg_id2) arg_t2) env 
 	      in
-	      let body_t1' = 
-		(* since we are just checking well-typedness we do not need
-		   to expand any constant. Hence the identity resolver. *)
-		subst_struct_expr
-		  (map_mbid arg_id1 (MPbound arg_id2) None)
-		  body_t1
+	      let env = match body_t1 with
+		  SEBstruct str -> 
+		    add_module {mod_mp = mtb1.typ_mp;
+				mod_expr = None;
+				mod_type = subst_struct_expr subst1 body_t1;
+				mod_type_alg= None;
+				mod_constraints=mtb1.typ_constraints;
+				mod_retroknowledge = [];
+				mod_delta = mtb1.typ_delta} env
+		| _ -> env
 	      in
-		check_structure cst env (eval_struct env body_t1')
-		  (eval_struct env body_t2) equiv
+		check_structure cst env body_t1 body_t2 equiv 
+		  subst1
+		  subst2
 	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
-      in 
-     if mtb1'== mtb2' then cst 
-     else check_structure cst env mtb1' mtb2' equiv
-	  
-let check_subtypes env sup super = 
-  check_modtypes Constraint.empty env sup super false
+      in
+     if mtb1'== mtb2' then cst
+     else check_structure cst env mtb1' mtb2' equiv subst1 subst2
+
+let check_subtypes env sup super =
+  let env = add_module 
+		(module_body_of_type sup.typ_mp sup) env in
+  check_modtypes Constraint.empty env 
+    (strengthen env sup sup.typ_mp) super empty_subst 
+    (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false
+
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index 0445666d..c0b1ee5d 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Univ
diff --git a/kernel/term.ml b/kernel/term.ml
index 1f3d2635..68565659 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 (* This module instantiates the structure of generic deBruijn terms to Coq *)
 
@@ -26,7 +26,7 @@ type metavariable = int
 (* This defines Cases annotations *)
 type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 type case_printing =
-  { ind_nargs : int; (* number of real args of the inductive type *)
+  { ind_nargs : int; (* length of the arity of the inductive type *)
     style     : case_style }
 type case_info =
   { ci_ind        : inductive;
@@ -42,7 +42,7 @@ type contents = Pos | Null
 type sorts =
   | Prop of contents                      (* proposition types *)
   | Type of universe
-      
+
 let prop_sort = Prop Null
 let set_sort = Prop Pos
 let type1_sort = Type type1_univ
@@ -58,7 +58,7 @@ let family_of_sort = function
 (*       Constructions as implemented                               *)
 (********************************************************************)
 
-type cast_kind = VMcast | DEFAULTcast 
+type cast_kind = VMcast | DEFAULTcast
 
 (* [constr array] is an instance matching definitional [named_context] in
    the same order (i.e. last argument first) *)
@@ -93,7 +93,7 @@ type ('constr, 'types) kind_of_term =
 (* Experimental *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
-  | CastType   of 'types * 'types 
+  | CastType   of 'types * 'types
   | ProdType   of name * 'types * 'types
   | LetInType  of name * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
@@ -118,7 +118,7 @@ type fixpoint = (int array * int) * rec_declaration
 type cofixpoint = int * rec_declaration
 
 (***************************)
-(* hash-consing functions  *)                         
+(* hash-consing functions  *)
 (***************************)
 
 let comp_term t1 t2 =
@@ -184,7 +184,7 @@ module Hconstr =
       type t = constr
       type u = (constr -> constr) *
                ((sorts -> sorts) * (constant -> constant) *
-               (kernel_name -> kernel_name) * (name -> name) *
+               (mutual_inductive -> mutual_inductive) * (name -> name) *
                (identifier -> identifier))
       let hash_sub = hash_term
       let equal = comp_term
@@ -211,7 +211,7 @@ let mkVar id = Var id
 let mkSort s = Sort s
 
 (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) 
+(* (that means t2 is declared as the type of t1)
    [s] is the strategy to use when *)
 let mkCast (t1,k2,t2) =
   match t1 with
@@ -230,14 +230,14 @@ let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
 (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
 (* We ensure applicative terms have at least one argument and the
    function is not itself an applicative term *)
-let mkApp (f, a) = 
+let mkApp (f, a) =
   if Array.length a = 0 then f else
     match f with
       | App (g, cl) -> App (g, Array.append cl a)
       | _ -> App (f, a)
 
 
-(* Constructs a constant *) 
+(* Constructs a constant *)
 (* The array of terms correspond to the variables introduced in the section *)
 let mkConst c = Const c
 
@@ -248,7 +248,7 @@ let mkEvar e = Evar e
 (* The array of terms correspond to the variables introduced in the section *)
 let mkInd m = Ind m
 
-(* Constructs the jth constructor of the ith (co)inductive type of the 
+(* Constructs the jth constructor of the ith (co)inductive type of the
    block named kn. The array of terms correspond to the variables
    introduced in the section *)
 let mkConstruct c = Construct c
@@ -261,6 +261,7 @@ let mkFix fix = Fix fix
 let mkCoFix cofix = CoFix cofix
 
 let kind_of_term c = c
+let kind_of_term2 c = c
 
 (************************************************************************)
 (*    kind_of_term = constructions as seen by the user                 *)
@@ -284,7 +285,7 @@ type hnftype =
 (*          Non primitive term destructors                            *)
 (**********************************************************************)
 
-(* Destructor operations : partial functions 
+(* Destructor operations : partial functions
    Raise invalid_arg "dest*" if the const has not the expected form *)
 
 (* Destructs a DeBrujin index *)
@@ -348,8 +349,12 @@ let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2)
 (* Tests if an evar *)
 let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
 
+let isEvar_or_Meta c = match kind_of_term c with
+  | Evar _ | Meta _ -> true
+  | _ -> false
+
 (* Destructs a casted term *)
-let destCast c = match kind_of_term c with 
+let destCast c = match kind_of_term c with
   | Cast (t1,k,t2) -> (t1,k,t2)
   | _ -> invalid_arg "destCast"
 
@@ -366,22 +371,22 @@ let isVar c = match kind_of_term c with Var _ -> true | _ -> false
 let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
 
 (* Destructs the product (x:t1)t2 *)
-let destProd c = match kind_of_term c with 
-  | Prod (x,t1,t2) -> (x,t1,t2) 
+let destProd c = match kind_of_term c with
+  | Prod (x,t1,t2) -> (x,t1,t2)
   | _ -> invalid_arg "destProd"
 
 let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false
 
 (* Destructs the abstraction [x:t1]t2 *)
-let destLambda c = match kind_of_term c with 
-  | Lambda (x,t1,t2) -> (x,t1,t2) 
+let destLambda c = match kind_of_term c with
+  | Lambda (x,t1,t2) -> (x,t1,t2)
   | _ -> invalid_arg "destLambda"
 
 let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
 
 (* Destructs the let [x:=b:t1]t2 *)
-let destLetIn c = match kind_of_term c with 
-  | LetIn (x,b,t1,t2) -> (x,b,t1,t2) 
+let destLetIn c = match kind_of_term c with
+  | LetIn (x,b,t1,t2) -> (x,b,t1,t2)
   | _ -> invalid_arg "destProd"
 
 let isLetIn c =  match kind_of_term c with LetIn _ -> true | _ -> false
@@ -430,13 +435,13 @@ let destCase c = match kind_of_term c with
 
 let isCase c =  match kind_of_term c with Case _ -> true | _ -> false
 
-let destFix c = match kind_of_term c with 
+let destFix c = match kind_of_term c with
   | Fix fix -> fix
   | _ -> invalid_arg "destFix"
 
 let isFix c =  match kind_of_term c with Fix _ -> true | _ -> false
 
-let destCoFix c = match kind_of_term c with 
+let destCoFix c = match kind_of_term c with
   | CoFix cofix -> cofix
   | _ -> invalid_arg "destCoFix"
 
@@ -466,7 +471,7 @@ let rec under_casts f c = match kind_of_term c with
 
 (* flattens application lists throwing casts in-between *)
 let rec collapse_appl c = match kind_of_term c with
-  | App (f,cl) -> 
+  | App (f,cl) ->
       let rec collapse_rec f cl2 =
         match kind_of_term (strip_outer_cast f) with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
@@ -482,12 +487,12 @@ let decompose_app c =
 
 (* strips head casts and flattens head applications *)
 let rec strip_head_cast c = match kind_of_term c with
-  | App (f,cl) -> 
+  | App (f,cl) ->
       let rec collapse_rec f cl2 = match kind_of_term f with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
 	| Cast (c,_,_) -> collapse_rec c cl2
 	| _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
-      in 
+      in
       collapse_rec f cl
   | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
@@ -550,7 +555,7 @@ let iter_constr_with_binders g f n c = match kind_of_term c with
   | App (c,l) -> f n c; Array.iter (f n) l
   | Evar (_,l) -> Array.iter (f n) l
   | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
-  | Fix (_,(_,tl,bl)) -> 
+  | Fix (_,(_,tl,bl)) ->
       Array.iter (f n) tl;
       Array.iter (f (iterate g (Array.length tl) n)) bl
   | CoFix (_,(_,tl,bl)) ->
@@ -604,6 +609,7 @@ let map_constr_with_binders g f l c = match kind_of_term c with
    application associativity, binders name and Cases annotations are
    not taken into account *)
 
+
 let compare_constr f t1 t2 =
   match kind_of_term t1, kind_of_term t2 with
   | Rel n1, Rel n2 -> n1 = n2
@@ -619,15 +625,15 @@ let compare_constr f t1 t2 =
       if Array.length l1 = Array.length l2 then
         f c1 c2 & array_for_all2 f l1 l2
       else
-        let (h1,l1) = decompose_app t1 in        
+        let (h1,l1) = decompose_app t1 in
         let (h2,l2) = decompose_app t2 in
         if List.length l1 = List.length l2 then
           f h1 h2 & List.for_all2 f l1 l2
         else false
   | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
-  | Const c1, Const c2 -> c1 = c2
-  | Ind c1, Ind c2 -> c1 = c2
-  | Construct c1, Construct c2 -> c1 = c2
+  | Const c1, Const c2 -> eq_constant c1 c2
+  | Ind c1, Ind c2 -> eq_ind c1 c2
+  | Construct c1, Construct c2 -> eq_constructor c1 c2
   | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
       f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
   | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
@@ -642,7 +648,7 @@ let compare_constr f t1 t2 =
 
 type types = constr
 
-type strategy = types option 
+type strategy = types option
 
 type named_declaration = identifier * constr option * types
 type rel_declaration = name * constr option * types
@@ -653,6 +659,34 @@ let map_rel_declaration = map_named_declaration
 let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
 let fold_rel_declaration = fold_named_declaration
 
+(***************************************************************************)
+(*     Type of local contexts (telescopes)                                 *)
+(***************************************************************************)
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices (to represent bound variables) *)
+
+type rel_context = rel_declaration list
+
+let empty_rel_context = []
+
+let add_rel_decl d ctxt = d::ctxt
+
+let rec lookup_rel n sign =
+  match n, sign with
+  | 1, decl :: _ -> decl
+  | n, _ :: sign -> lookup_rel (n-1) sign
+  | _, []        -> raise Not_found
+
+let rel_context_length = List.length
+
+let rel_context_nhyps hyps =
+  let rec nhyps acc = function
+    | [] -> acc
+    | (_,None,_)::hyps -> nhyps (1+acc) hyps
+    | (_,Some _,_)::hyps -> nhyps acc hyps in
+  nhyps 0 hyps
+
 (****************************************************************************)
 (*              Functions for dealing with constr terms                     *)
 (****************************************************************************)
@@ -666,11 +700,11 @@ exception LocalOccur
 (* (closedn n M) raises FreeVar if a variable of height greater than n
    occurs in M, returns () otherwise *)
 
-let closedn n c = 
+let closedn n c =
   let rec closed_rec n c = match kind_of_term c with
     | Rel m -> if m>n then raise LocalOccur
     | _ -> iter_constr_with_binders succ closed_rec n c
-  in 
+  in
   try closed_rec n c; true with LocalOccur -> false
 
 (* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
@@ -679,21 +713,21 @@ let closed0 = closedn 0
 
 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
 
-let noccurn n term = 
+let noccurn n term =
   let rec occur_rec n c = match kind_of_term c with
     | Rel m -> if m = n then raise LocalOccur
     | _ -> iter_constr_with_binders succ occur_rec n c
-  in 
+  in
   try occur_rec n term; true with LocalOccur -> false
 
-(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M 
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M
   for n <= p < n+m *)
 
-let noccur_between n m term = 
+let noccur_between n m term =
   let rec occur_rec n c = match kind_of_term c with
     | Rel(p) -> if n<=p && p<n+m then raise LocalOccur
     | _        -> iter_constr_with_binders succ occur_rec n c
-  in 
+  in
   try occur_rec n term; true with LocalOccur -> false
 
 (* Checking function for terms containing existential variables.
@@ -703,7 +737,7 @@ let noccur_between n m term =
  which may contain the CoFix variables. These occurrences of CoFix variables
  are not considered *)
 
-let noccur_with_meta n m term = 
+let noccur_with_meta n m term =
   let rec occur_rec n c = match kind_of_term c with
     | Rel p -> if n<=p & p<n+m then raise LocalOccur
     | App(f,cl) ->
@@ -728,18 +762,18 @@ let rec exliftn el c = match kind_of_term c with
 
 (* Lifting the binding depth across k bindings *)
 
-let liftn k n = 
+let liftn k n =
   match el_liftn (pred n) (el_shft k ELID) with
     | ELID -> (fun c -> c)
     | el -> exliftn el
- 
+
 let lift k = liftn k 1
 
 (*********************)
 (*   Substituting    *)
 (*********************)
 
-(* (subst1 M c) substitutes M for Rel(1) in c 
+(* (subst1 M c) substitutes M for Rel(1) in c
    we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
    M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
 
@@ -759,15 +793,15 @@ let rec lift_substituend depth s =
 let make_substituend c = { sinfo=Unknown; sit=c }
 
 let substn_many lamv n c =
-  let lv = Array.length lamv in 
+  let lv = Array.length lamv in
   if lv = 0 then c
-  else 
+  else
     let rec substrec depth c = match kind_of_term c with
       | Rel k     ->
           if k<=depth then c
           else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1)
           else mkRel (k-lv)
-      | _ -> map_constr_with_binders succ substrec depth c in 
+      | _ -> map_constr_with_binders succ substrec depth c in
     substrec n c
 
 (*
@@ -791,21 +825,21 @@ let substl_named_decl = substl_decl
 
 let rec thin_val = function
   | [] -> []
-  | (((id,{ sit = v }) as s)::tl) when isVar v -> 
+  | (((id,{ sit = v }) as s)::tl) when isVar v ->
       if id = destVar v then thin_val tl else s::(thin_val tl)
   | h::tl -> h::(thin_val tl)
 
 (* (replace_vars sigma M) applies substitution sigma to term M *)
-let replace_vars var_alist = 
+let replace_vars var_alist =
   let var_alist =
     List.map (fun (str,c) -> (str,make_substituend c)) var_alist in
-  let var_alist = thin_val var_alist in 
+  let var_alist = thin_val var_alist in
   let rec substrec n c = match kind_of_term c with
     | Var x ->
         (try lift_substituend n (List.assoc x var_alist)
          with Not_found -> c)
     | _ -> map_constr_with_binders succ substrec n c
-  in 
+  in
   if var_alist = [] then (function x -> x) else substrec 0
 
 (*
@@ -910,7 +944,7 @@ let mkAppA v =
   if l=0 then anomaly "mkAppA received an empty array"
   else mkApp (v.(0), Array.sub v 1 (Array.length v -1))
 
-(* Constructs a constant *) 
+(* Constructs a constant *)
 (* The array of terms correspond to the variables introduced in the section *)
 let mkConst = mkConst
 
@@ -921,7 +955,7 @@ let mkEvar = mkEvar
 (* The array of terms correspond to the variables introduced in the section *)
 let mkInd = mkInd
 
-(* Constructs the jth constructor of the ith (co)inductive type of the 
+(* Constructs the jth constructor of the ith (co)inductive type of the
    block named kn. The array of terms correspond to the variables
    introduced in the section *)
 let mkConstruct = mkConstruct
@@ -930,15 +964,15 @@ let mkConstruct = mkConstruct
 let mkCase = mkCase
 let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac)
 
-(* If recindxs = [|i1,...in|] 
+(* If recindxs = [|i1,...in|]
       funnames = [|f1,...fn|]
       typarray = [|t1,...tn|]
       bodies   = [|b1,...bn|]
-   then    
+   then
 
       mkFix ((recindxs,i),(funnames,typarray,bodies))
-   
-   constructs the ith function of the block  
+
+   constructs the ith function of the block
 
     Fixpoint f1 [ctx1] : t1 := b1
     with     f2 [ctx2] : t2 := b2
@@ -953,12 +987,12 @@ let mkFix = mkFix
 (* If funnames = [|f1,...fn|]
       typarray = [|t1,...tn|]
       bodies   = [|b1,...bn|]
-   then 
+   then
 
       mkCoFix (i,(funnames,typsarray,bodies))
 
-   constructs the ith function of the block  
-   
+   constructs the ith function of the block
+
     CoFixpoint f1 : t1 := b1
     with       f2 : t2 := b2
     ...
@@ -984,7 +1018,7 @@ let prodn n env b =
     | (0, env, b)        -> b
     | (n, ((v,t)::l), b) -> prodrec (n-1,  l, mkProd (v,t,b))
     | _ -> assert false
-  in 
+  in
   prodrec (n,env,b)
 
 (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *)
@@ -996,7 +1030,7 @@ let lamn n env b =
     | (0, env, b)        -> b
     | (n, ((v,t)::l), b) -> lamrec (n-1,  l, mkLambda (v,t,b))
     | _ -> assert false
-  in 
+  in
   lamrec (n,env,b)
 
 (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *)
@@ -1007,29 +1041,29 @@ let applist (f,l) = mkApp (f, Array.of_list l)
 let applistc f l = mkApp (f, Array.of_list l)
 
 let appvect = mkApp
-	    
+
 let appvectc f l = mkApp (f,l)
-		     
+
 (* to_lambda n (x1:T1)...(xn:Tn)T =
  * [x1:T1]...[xn:Tn]T *)
 let rec to_lambda n prod =
-  if n = 0 then 
-    prod 
-  else 
-    match kind_of_term prod with 
+  if n = 0 then
+    prod
+  else
+    match kind_of_term prod with
       | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd)
       | Cast (c,_,_) -> to_lambda n c
-      | _   -> errorlabstrm "to_lambda" (mt ())                      
+      | _   -> errorlabstrm "to_lambda" (mt ())
 
 let rec to_prod n lam =
-  if n=0 then 
+  if n=0 then
     lam
-  else   
-    match kind_of_term lam with 
+  else
+    match kind_of_term lam with
       | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd)
       | Cast (c,_,_) -> to_prod n c
-      | _   -> errorlabstrm "to_prod" (mt ())                      
-	    
+      | _   -> 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 *)
@@ -1048,91 +1082,190 @@ let prod_appvect t nL = Array.fold_left prod_app t nL
 (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *)
 let prod_applist t nL = List.fold_left prod_app t nL
 
+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)
+
 (*********************************)
 (* Other term destructors        *)
 (*********************************)
 
 (* 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 = 
+let decompose_prod =
   let rec prodec_rec l c = match kind_of_term c with
     | Prod (x,t,c) -> prodec_rec ((x,t)::l) c
     | Cast (c,_,_)   -> prodec_rec l c
     | _              -> l,c
-  in 
+  in
   prodec_rec []
 
 (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
    ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
-let decompose_lam = 
+let decompose_lam =
   let rec lamdec_rec l c = match kind_of_term c with
     | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
     | Cast (c,_,_)     -> lamdec_rec l c
     | _                -> l,c
-  in 
+  in
   lamdec_rec []
 
-(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T 
+(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T
    into the pair ([(xn,Tn);...;(x1,T1)],T) *)
 let decompose_prod_n n =
   if n < 0 then error "decompose_prod_n: integer parameter must be positive";
-  let rec prodec_rec l n c = 
-    if n=0 then l,c 
-    else match kind_of_term c with 
+  let rec prodec_rec l n c =
+    if n=0 then l,c
+    else match kind_of_term c with
       | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)   -> prodec_rec l n c
       | _ -> error "decompose_prod_n: not enough products"
-  in 
-  prodec_rec [] n 
+  in
+  prodec_rec [] n
 
-(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
+(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T
    into the pair ([(xn,Tn);...;(x1,T1)],T) *)
 let decompose_lam_n n =
   if n < 0 then error "decompose_lam_n: integer parameter must be positive";
-  let rec lamdec_rec l n c = 
-    if n=0 then l,c 
-    else match kind_of_term c with 
+  let rec lamdec_rec l n c =
+    if n=0 then l,c
+    else match kind_of_term c with
       | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)     -> lamdec_rec l n c
       | _ -> error "decompose_lam_n: not enough abstractions"
-  in 
-  lamdec_rec [] n 
+  in
+  lamdec_rec [] 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 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
+    | Cast (c,_,_)      -> prodec_rec l c
+    | _               -> l,c
+  in
+  prodec_rec empty_rel_context
+
+(* 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 =
+    match kind_of_term c with
+    | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) c
+    | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c
+    | Cast (c,_,_)      -> lamdec_rec l c
+    | _               -> l,c
+  in
+  lamdec_rec empty_rel_context
+
+(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_prod_n_assum n =
+  if n < 0 then
+    error "decompose_prod_n_assum: integer parameter must be positive";
+  let rec prodec_rec l n c =
+    if n=0 then l,c
+    else match 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"
+  in
+  prodec_rec empty_rel_context n
+
+(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T
+   into the pair ([(xn,Tn);...;(x1,T1)],T)
+   Lets in between are not expanded but turn into local definitions,
+   but n is the actual number of destructurated lambdas.  *)
+let decompose_lam_n_assum n =
+  if n < 0 then
+    error "decompose_lam_n_assum: integer parameter must be positive";
+  let rec lamdec_rec l n c =
+    if n=0 then l,c
+    else match 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"
+  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 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 
+  in
   nbrec 0
-    
+
 (* similar to nb_lam, but gives the number of products instead *)
-let nb_prod = 
+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 
+  in
   nbrec 0
 
-(* Rem: end of import from old module Generic *)
+let prod_assum t = fst (decompose_prod_assum t)
+let prod_n_assum n t = fst (decompose_prod_n_assum n t)
+let strip_prod_assum t = snd (decompose_prod_assum t)
+let strip_prod t = snd (decompose_prod t)
+let strip_prod_n n t = snd (decompose_prod_n n t)
+let lam_assum t = fst (decompose_lam_assum t)
+let lam_n_assum n t = fst (decompose_lam_n_assum n t)
+let strip_lam_assum t = snd (decompose_lam_assum t)
+let strip_lam t = snd (decompose_lam t)
+let strip_lam_n n t = snd (decompose_lam_n n t)
+
+(***************************)
+(* Arities                 *)
+(***************************)
+
+(* An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
+   Such a term can canonically be seen as the pair of a context of types
+   and of a sort *)
+
+type arity = rel_context * sorts
+
+let destArity =
+  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
+    | Cast (c,_,_)      -> prodec_rec l c
+    | Sort s          -> l,s
+    | _               -> anomaly "destArity: not an arity"
+  in
+  prodec_rec []
+
+let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign
+
+let rec isArity c =
+  match kind_of_term c with
+  | Prod (_,_,c)    -> isArity c
+  | LetIn (_,b,_,c) -> isArity (subst1 b c)
+  | Cast (c,_,_)      -> isArity c
+  | Sort _          -> true
+  | _               -> false
 
 (*******************************)
-(*  alpha conversion functions *)                         
+(*  alpha conversion functions *)
 (*******************************)
 
 (* alpha conversion : ignore print names and casts *)
 
-let rec eq_constr m n = 
+let rec eq_constr m n =
   (m==n) or
   compare_constr eq_constr m n
 
 let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
 
 (*******************)
-(*  hash-consing   *)                         
+(*  hash-consing   *)
 (*******************)
 
 module Htype =
diff --git a/kernel/term.mli b/kernel/term.mli
index 3b5a2bc1..0de83166 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -42,7 +42,7 @@ type metavariable = int
 (*s Case annotation *)
 type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 type case_printing =
-  { ind_nargs : int; (* number of real args of the inductive type *)
+  { ind_nargs : int; (* length of the arity of the inductive type *)
     style     : case_style }
 (* the integer is the number of real args, needed for reduction *)
 type case_info =
@@ -63,13 +63,13 @@ val eq_constr : constr -> constr -> bool
 
 (* [types] is the same as [constr] but is intended to be used for
    documentation to indicate that such or such function specifically works
-   with {\em types} (i.e. terms of type a sort). 
+   with {\em types} (i.e. terms of type a sort).
    (Rem:plurial form since [type] is a reserved ML keyword) *)
 
 type types = constr
 
 (*s Functions for dealing with constr terms.
-  The following functions are intended to simplify and to uniform the 
+  The following functions are intended to simplify and to uniform the
   manipulation of terms. Some of these functions may be overlapped with
   previous ones. *)
 
@@ -96,9 +96,9 @@ val mkType : Univ.universe -> types
 
 
 (* This defines the strategy to use for verifiying a Cast *)
-type cast_kind = VMcast | DEFAULTcast 
+type cast_kind = VMcast | DEFAULTcast
 
-(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the 
+(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the
    type $t_2$ (that means t2 is declared as the type of t1). *)
 val mkCast : constr * cast_kind * constr -> constr
 
@@ -122,7 +122,7 @@ val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
    $(f~t_1~\dots~t_n)$. *)
 val mkApp : constr * constr array -> constr
 
-(* Constructs a constant *) 
+(* Constructs a constant *)
 (* The array of terms correspond to the variables introduced in the section *)
 val mkConst : constant -> constr
 
@@ -132,7 +132,7 @@ val mkConst : constant -> constr
 (* The array of terms correspond to the variables introduced in the section *)
 val mkInd : inductive -> constr
 
-(* Constructs the jth constructor of the ith (co)inductive type of the 
+(* Constructs the jth constructor of the ith (co)inductive type of the
    block named kn. The array of terms correspond to the variables
    introduced in the section *)
 val mkConstruct : constructor -> constr
@@ -162,8 +162,8 @@ val mkFix : fixpoint -> constr
       [typarray = [|t1,...tn|]]
       [bodies   = [b1,.....bn]] \par\noindent
    then [mkCoFix (i, (typsarray, funnames, bodies))]
-   constructs the ith function of the block  
-   
+   constructs the ith function of the block
+
     [CoFixpoint f1 = b1
      with       f2 = b2
      ...
@@ -208,11 +208,12 @@ type ('constr, 'types) kind_of_term =
    term *)
 
 val kind_of_term : constr -> (constr, types) kind_of_term
+val kind_of_term2 : constr -> ((constr,types) kind_of_term,constr) kind_of_term
 
 (* Experimental *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
-  | CastType   of 'types * 'types 
+  | CastType   of 'types * 'types
   | ProdType   of name * 'types * 'types
   | LetInType  of name * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
@@ -226,6 +227,7 @@ val isVar  : constr -> bool
 val isInd  : constr -> bool
 val isEvar : constr -> bool
 val isMeta : constr -> bool
+val isEvar_or_Meta : constr -> bool
 val isSort : constr -> bool
 val isCast : constr -> bool
 val isApp : constr -> bool
@@ -245,7 +247,7 @@ val is_Type : constr -> bool
 val iskind : constr -> bool
 val is_small : sorts -> bool
 
-(*s Term destructors. 
+(*s Term destructors.
    Destructor operations are partial functions and
    raise [invalid_arg "dest*"] if the term has not the expected form. *)
 
@@ -258,7 +260,7 @@ val destMeta : constr -> metavariable
 (* Destructs a variable *)
 val destVar : constr -> identifier
 
-(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether 
+(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether
    [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *)
 val destSort : constr -> sorts
 
@@ -298,7 +300,7 @@ val destConstruct : constr -> constructor
 (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
 val destCase : constr -> case_info * constr * constr * constr array
 
-(* Destructs the $i$th function of the block  
+(* Destructs the $i$th function of the block
    $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1
     \mathit{with}     ~ f_2 ~ [ctx_2] = b_2
     \dots
@@ -330,6 +332,18 @@ val fold_named_declaration :
 val fold_rel_declaration :
   (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
 
+(*s Contexts of declarations referred to by de Bruijn indices *)
+
+(* In [rel_context], more recent declaration is on top *)
+type rel_context = rel_declaration list
+
+val empty_rel_context : rel_context
+val add_rel_decl : rel_declaration -> rel_context -> rel_context
+
+val lookup_rel : int -> rel_context -> rel_declaration
+val rel_context_length : rel_context -> int
+val rel_context_nhyps : rel_context -> int
+
 (* Constructs either [(x:t)c] or [[x=b:t]c] *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
 val mkNamedProd_or_LetIn : named_declaration -> types -> types
@@ -352,7 +366,7 @@ val applistc : constr -> constr list -> constr
 val appvect : constr * constr array -> constr
 val appvectc : constr -> constr array -> constr
 
-(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ 
+(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$
    where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
 val prodn : int -> (name * constr) list -> constr -> constr
 
@@ -367,15 +381,15 @@ val lamn : int -> (name * constr) list -> constr -> constr
 
 (* [compose_lam l b] = $[x_1:T_1]..[x_n:T_n]b$
    where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
-   Inverse of [decompose_lam] *)
+   Inverse of [it_destLam] *)
 val compose_lam : (name * constr) list -> constr -> constr
 
-(* [to_lambda n l] 
+(* [to_lambda n l]
    = $[x_1:T_1]...[x_n:T_n]T$
    where $l = (x_1:T_1)...(x_n:T_n)T$ *)
 val to_lambda : int -> constr -> constr
 
-(* [to_prod n l] 
+(* [to_prod n l]
    = $(x_1:T_1)...(x_n:T_n)T$
    where $l = [x_1:T_1]...[x_n:T_n]T$ *)
 val to_prod : int -> constr -> constr
@@ -386,6 +400,9 @@ val to_prod : int -> constr -> constr
 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
+
 (*s Other term destructors. *)
 
 (* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair
@@ -397,22 +414,53 @@ val decompose_prod : constr -> (name*constr) list * constr
    $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *)
 val decompose_lam : constr -> (name*constr) list * constr
 
-(* Given a positive integer n, transforms a product term 
+(* Given a positive integer n, transforms a product term
    $(x_1:T_1)..(x_n:T_n)T$
    into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
 val decompose_prod_n : int -> constr -> (name * constr) list * constr
 
-(* Given a positive integer $n$, transforms a lambda term 
+(* Given a positive integer $n$, transforms a lambda term
    $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
 val decompose_lam_n : int -> constr -> (name * constr) list * constr
 
+(* 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
+
+(* Idem with lambda's *)
+val decompose_lam_assum : constr -> rel_context * constr
+
+(* Idem but extract the first [n] premisses *)
+val decompose_prod_n_assum : int -> types -> rel_context * types
+val decompose_lam_n_assum : 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 *)
+(* Similar to [nb_lam], but gives the number of products instead *)
 val nb_prod : constr -> int
 
+(* Returns the premisses/parameters of a type/term (let-in included) *)
+val prod_assum : types -> rel_context
+val lam_assum : constr -> rel_context
+
+(* Returns the first n-th premisses/parameters of a type/term (let included)*)
+val prod_n_assum : int -> types -> rel_context
+val lam_n_assum : int -> constr -> rel_context
+
+(* Remove the premisses/parameters of a type/term *)
+val strip_prod : types -> types
+val strip_lam : constr -> constr
+
+(* Remove the first n-th premisses/parameters of a type/term *)
+val strip_prod_n : int -> types -> types
+val strip_lam_n : int -> constr -> constr
+
+(* Remove the premisses/parameters of a type/term (including let-in) *)
+val strip_prod_assum : types -> types
+val strip_lam_assum : constr -> constr
+
 (* flattens application lists *)
 val collapse_appl : constr -> constr
 
@@ -427,6 +475,21 @@ val under_casts : (constr -> constr) -> constr -> constr
 (* Apply a function under components of Cast if any *)
 val under_outer_cast : (constr -> constr) -> constr -> constr
 
+(*s An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
+    Such a term can canonically be seen as the pair of a context of types
+    and of a sort *)
+
+type arity = rel_context * sorts
+
+(* Build an "arity" from its canonical form *)
+val mkArity : arity -> types
+
+(* Destructs an "arity" into its canonical form *)
+val destArity : types -> arity
+
+(* Tells if a term has the form of an arity *)
+val isArity : types -> bool
+
 (*s Occur checks *)
 
 (* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
@@ -532,11 +595,11 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
 
 val hcons_constr:
   (constant -> constant) *
-  (kernel_name -> kernel_name) *
+  (mutual_inductive -> mutual_inductive) *
   (dir_path -> dir_path) *
   (name -> name) *
   (identifier -> identifier) *
-  (string -> string) 
+  (string -> string)
   ->
     (constr -> constr) *
     (types -> types)
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index f50a0b83..c465adfa 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term_typing.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -25,7 +25,7 @@ open Typeops
 let constrain_type env j cst1 = function
   | None ->
       make_polymorphic_if_constant_for_ind env j, cst1
-  | Some t -> 
+  | Some t ->
       let (tj,cst2) = infer_type env t in
       let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
       assert (t = tj.utj_val);
@@ -34,7 +34,7 @@ let constrain_type env j cst1 = function
 let local_constrain_type env j cst1 = function
   | None ->
       j.uj_type, cst1
-  | Some t -> 
+  | Some t ->
       let (tj,cst2) = infer_type env t in
       let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
       assert (t = tj.utj_val);
@@ -59,7 +59,7 @@ let translate_local_assum env t =
 let safe_push_named (id,_,_ as d) env =
   let _ =
     try
-      let _ = lookup_named id env in 
+      let _ = lookup_named id env in
       error ("Identifier "^string_of_id id^" already defined.")
     with Not_found -> () in
   push_named d env
@@ -99,18 +99,18 @@ let infer_declaration env dcl =
 let global_vars_set_constant_type env = function
   | NonPolymorphicType t -> global_vars_set env t
   | PolymorphicArity (ctx,_) ->
-      Sign.fold_rel_context 
+      Sign.fold_rel_context
         (fold_rel_declaration
 	  (fun t c -> Idset.union (global_vars_set env t) c))
       ctx ~init:Idset.empty
 
 let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) =
   let ids =
-    match body with 
+    match body with
     | None -> global_vars_set_constant_type env typ
     | Some b ->
-        Idset.union 
-	  (global_vars_set env (Declarations.force b)) 
+        Idset.union
+	  (global_vars_set env (Declarations.force b))
 	  (global_vars_set_constant_type env typ)
   in
   let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in
@@ -121,7 +121,7 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) =
       const_body_code = tps;
      (* const_type_code = to_patch env typ;*)
       const_constraints = cst;
-      const_opaque = op; 
+      const_opaque = op;
       const_inline = inline}
 
 (*s Global and local constant declaration. *)
@@ -129,9 +129,9 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) =
 let translate_constant env kn ce =
   build_constant_declaration env kn (infer_declaration env ce)
 
-let translate_recipe env kn r = 
+let translate_recipe env kn r =
   build_constant_declaration env kn (Cooking.cook_constant env r)
 
 (* Insertion of inductive types. *)
 
-let translate_mind env mie = check_inductive env mie 
+let translate_mind env mie = check_inductive env mie
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index d84cfe91..69b13e3b 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term_typing.mli 9795 2007-04-25 15:13:45Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -19,13 +19,13 @@ open Entries
 open Typeops
 (*i*)
 
-val translate_local_def : env -> constr * types option -> 
+val translate_local_def : env -> constr * types option ->
   constr * types * Univ.constraints
 
 val translate_local_assum : env -> types ->
   types * Univ.constraints
 
-val infer_declaration : env -> constant_entry -> 
+val infer_declaration : env -> constant_entry ->
    constr_substituted option * constant_type * constraints * bool * bool * bool
 
 val build_constant_declaration : env -> 'a ->
@@ -34,8 +34,8 @@ val build_constant_declaration : env -> 'a ->
 
 val translate_constant : env -> constant -> constant_entry -> constant_body
 
-val translate_mind : 
+val translate_mind :
   env -> mutual_inductive_entry -> mutual_inductive_body
 
-val translate_recipe : 
+val translate_recipe :
   env -> constant -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 1a49531b..2d26d27e 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: type_errors.ml 10533 2008-02-08 16:54:47Z msozeau $ *)
+(* $Id$ *)
 
 open Names
 open Term
@@ -80,10 +80,10 @@ let error_assumption env j =
 let error_reference_variables env id =
   raise (TypeError (env, ReferenceVariables id))
 
-let error_elim_arity env ind aritylst c pj okinds = 
+let error_elim_arity env ind aritylst c pj okinds =
   raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
 
-let error_case_not_inductive env j = 
+let error_case_not_inductive env j =
   raise (TypeError (env, CaseNotInductive j))
 
 let error_number_branches env cj expn =
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 368e1723..9c7b6561 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: type_errors.mli 10533 2008-02-08 16:54:47Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -71,11 +71,11 @@ val error_unbound_var : env -> variable -> 'a
 val error_not_type : env -> unsafe_judgment -> 'a
 
 val error_assumption : env -> unsafe_judgment -> 'a
- 
+
 val error_reference_variables : env -> constr -> 'a
 
-val error_elim_arity : 
-  env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> 
+val error_elim_arity :
+  env -> inductive -> sorts_family list -> constr -> unsafe_judgment ->
       (sorts_family * sorts_family * arity_error) option -> 'a
 
 val error_case_not_inductive : env -> unsafe_judgment -> 'a
@@ -88,11 +88,11 @@ val error_generalization : env -> name * types -> unsafe_judgment -> 'a
 
 val error_actual_type : env -> unsafe_judgment -> types -> 'a
 
-val error_cant_apply_not_functional : 
+val error_cant_apply_not_functional :
   env -> unsafe_judgment -> unsafe_judgment array -> 'a
 
-val error_cant_apply_bad_type : 
-  env -> int * constr * constr -> 
+val error_cant_apply_bad_type :
+  env -> int * constr * constr ->
       unsafe_judgment -> unsafe_judgment array -> 'a
 
 val error_ill_formed_rec_body :
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index e548e6f5..27db208c 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml 10877 2008-04-30 21:58:41Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -19,15 +19,15 @@ open Entries
 open Reduction
 open Inductive
 open Type_errors
-  
+
 let conv = default_conv CONV
 let conv_leq = default_conv CUMUL
 
 let conv_leq_vecti env v1 v2 =
-  array_fold_left2_i 
+  array_fold_left2_i
     (fun i c t1 t2 ->
       let c' =
-        try default_conv CUMUL env t1 t2 
+        try default_conv CUMUL env t1 t2
         with NotConvertible -> raise (NotConvertibleVect i) in
       Constraint.union c c')
     Constraint.empty
@@ -77,13 +77,13 @@ let judge_of_type u =
     uj_type = mkType uu }
 
 (*s Type of a de Bruijn index. *)
-	  
-let judge_of_relative env n = 
+
+let judge_of_relative env n =
   try
     let (_,_,typ) = lookup_rel n env in
     { uj_val  = mkRel n;
       uj_type = lift n typ }
-  with Not_found -> 
+  with Not_found ->
     error_unbound_rel env n
 
 (* Type of variables *)
@@ -91,7 +91,7 @@ let judge_of_variable env id =
   try
     let ty = named_type id env in
     make_judge (mkVar id) ty
-  with Not_found -> 
+  with Not_found ->
     error_unbound_var env id
 
 (* Management of context of variables. *)
@@ -164,7 +164,7 @@ let type_of_constant env cst =
 let judge_of_constant_knowing_parameters env cst jl =
   let c = mkConst cst in
   let cb = lookup_constant cst env in
-  let _ = check_args env c cb.const_hyps in 
+  let _ = check_args env c cb.const_hyps in
   let paramstyp = Array.map (fun j -> j.uj_type) jl in
   let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in
   make_judge c t
@@ -198,25 +198,25 @@ let judge_of_letin env name defj typj j =
 
 let judge_of_apply env funj argjv =
   let rec apply_rec n typ cst = function
-    | [] -> 
+    | [] ->
 	{ uj_val  = mkApp (j_val funj, Array.map j_val argjv);
           uj_type = typ },
 	cst
     | hj::restjl ->
         (match kind_of_term (whd_betadeltaiota env typ) with
           | Prod (_,c1,c2) ->
-	      (try 
+	      (try
 		let c = conv_leq env hj.uj_type c1 in
 		let cst' = Constraint.union cst c in
 		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
-	      with NotConvertible -> 
+	      with NotConvertible ->
 		error_cant_apply_bad_type env
 		  (n,c1, hj.uj_type)
 		  funj argjv)
 
           | _ ->
 	      error_cant_apply_not_functional env funj argjv)
-  in 
+  in
   apply_rec 1
     funj.uj_type
     Constraint.empty
@@ -226,7 +226,7 @@ let judge_of_apply env funj argjv =
 
 let sort_of_product env domsort rangsort =
   match (domsort, rangsort) with
-    (* Product rule (s,Prop,Prop) *) 
+    (* Product rule (s,Prop,Prop) *)
     | (_,       Prop Null)  -> rangsort
     (* Product rule (Prop/Set,Set,Set) *)
     | (Prop _,  Prop Pos) -> rangsort
@@ -242,7 +242,7 @@ let sort_of_product env domsort rangsort =
     | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
     (* Product rule (Prop,Type_i,Type_i) *)
     | (Prop Null, Type _)  -> rangsort
-    (* Product rule (Type_i,Type_i,Type_i) *) 
+    (* Product rule (Type_i,Type_i,Type_i) *)
     | (Type u1, Type u2) -> Type (sup u1 u2)
 
 (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
@@ -269,8 +269,8 @@ let judge_of_product env name t1 t2 =
 
 let judge_of_cast env cj k tj =
   let expected_type = tj.utj_val in
-  try 
-    let cst = 
+  try
+    let cst =
       match k with
       | VMcast -> vm_conv CUMUL env cj.uj_type expected_type
       | DEFAULTcast -> conv_leq env cj.uj_type expected_type in
@@ -312,13 +312,13 @@ let judge_of_constructor env c =
   let _ =
     let ((kn,_),_) = c in
     let mib = lookup_mind kn env in
-    check_args env constr mib.mind_hyps in 
+    check_args env constr mib.mind_hyps in
   let specif = lookup_mind_specif env (inductive_of_constructor c) in
   make_judge constr (type_of_constructor c specif)
 
 (* Case. *)
 
-let check_branch_types env cj (lfj,explft) = 
+let check_branch_types env cj (lfj,explft) =
   try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
@@ -368,16 +368,16 @@ let univ_combinator (cst,univ) (j,c') =
 let rec execute env cstr cu =
   match kind_of_term cstr with
     (* Atomic terms *)
-    | Sort (Prop c) -> 
+    | Sort (Prop c) ->
 	(judge_of_prop_contents c, cu)
 
     | Sort (Type u) ->
 	(judge_of_type u, cu)
 
-    | Rel n -> 
+    | Rel n ->
 	(judge_of_relative env n, cu)
 
-    | Var id -> 
+    | Var id ->
 	(judge_of_variable env id, cu)
 
     | Const c ->
@@ -391,21 +391,21 @@ let rec execute env cstr cu =
 	    | Ind ind ->
 		(* Sort-polymorphism of inductive types *)
 		judge_of_inductive_knowing_parameters env ind jl, cu1
-	    | Const cst -> 
+	    | Const cst ->
 		(* Sort-polymorphism of constant *)
 		judge_of_constant_knowing_parameters env cst jl, cu1
-	    | _ -> 
+	    | _ ->
 		(* No sort-polymorphism *)
 		execute env f cu1
 	in
 	univ_combinator cu2 (judge_of_apply env j jl)
-	    
-    | Lambda (name,c1,c2) -> 
+
+    | Lambda (name,c1,c2) ->
         let (varj,cu1) = execute_type env c1 cu in
 	let env1 = push_rel (name,None,varj.utj_val) env in
-        let (j',cu2) = execute env1 c2 cu1 in 
+        let (j',cu2) = execute env1 c2 cu1 in
         (judge_of_abstraction env name varj j', cu2)
-	  
+
     | Prod (name,c1,c2) ->
         let (varj,cu1) = execute_type env c1 cu in
 	let env1 = push_rel (name,None,varj.utj_val) env in
@@ -415,12 +415,12 @@ let rec execute env cstr cu =
     | LetIn (name,c1,c2,c3) ->
         let (j1,cu1) = execute env c1 cu in
         let (j2,cu2) = execute_type env c2 cu1 in
-        let (_,cu3) = 
+        let (_,cu3) =
 	  univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in
         let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
         let (j',cu4) = execute env1 c3 cu3 in
         (judge_of_letin env name j1 j2 j', cu4)
-	  
+
     | Cast (c,k, t) ->
         let (cj,cu1) = execute env c cu in
         let (tj,cu2) = execute_type env t cu1 in
@@ -431,7 +431,7 @@ let rec execute env cstr cu =
     | Ind ind ->
 	(judge_of_inductive env ind, cu)
 
-    | Construct c -> 
+    | Construct c ->
 	(judge_of_constructor env c, cu)
 
     | Case (ci,p,c,lf) ->
@@ -440,13 +440,13 @@ let rec execute env cstr cu =
         let (lfj,cu3) = execute_array env lf cu2 in
         univ_combinator cu3
           (judge_of_case env ci pj cj lfj)
-  
+
     | Fix ((vn,i as vni),recdef) ->
         let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
         let fix = (vni,recdef') in
         check_fix env fix;
 	(make_judge (mkFix fix) fix_ty, cu1)
-	  
+
     | CoFix (i,recdef) ->
         let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
         let cofix = (i,recdef') in
@@ -460,10 +460,10 @@ let rec execute env cstr cu =
     | Evar _ ->
 	anomaly "the kernel does not support existential variables"
 
-and execute_type env constr cu = 
+and execute_type env constr cu =
   let (j,cu1) = execute env constr cu in
   (type_judgment env j, cu1)
-	  
+
 and execute_recdef env (names,lar,vdef) i cu =
   let (larj,cu1) = execute_array env lar cu in
   let lara = Array.map (assumption_of_judgment env) larj in
@@ -476,7 +476,7 @@ and execute_recdef env (names,lar,vdef) i cu =
 
 and execute_array env = array_fold_map' (execute env)
 
-and execute_list env = list_fold_map' (execute env) 
+and execute_list env = list_fold_map' (execute env)
 
 (* Derived functions *)
 let infer env constr =
@@ -494,11 +494,11 @@ let infer_v env cv =
   let (jv,(cst,_)) =
     execute_array env cv (Constraint.empty, universes env) in
   (jv, cst)
- 
+
 (* Typing of several terms. *)
 
 let infer_local_decl env id = function
-  | LocalDef c -> 
+  | LocalDef c ->
       let (j,cst) = infer env c in
       (Name id, Some j.uj_val, j.uj_type), cst
   | LocalAssum c ->
@@ -507,7 +507,7 @@ let infer_local_decl env id = function
 
 let infer_local_decls env decls =
   let rec inferec env = function
-  | (id, d) :: l -> 
+  | (id, d) :: l ->
       let env, l, cst1 = inferec env l in
       let d, cst2 = infer_local_decl env id d in
       push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2
@@ -516,7 +516,7 @@ let infer_local_decls env decls =
 
 (* Exported typing functions *)
 
-let typing env c = 
+let typing env c =
   let (j,cst) = infer env c in
   let _ = add_constraints cst env in
   j
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index c427055a..b0f15e75 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeops.mli 10877 2008-04-30 21:58:41Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -25,7 +25,7 @@ val infer_type : env -> types        -> unsafe_type_judgment * constraints
 
 val infer_local_decls :
   env -> (identifier * local_entry) list
-    -> env * Sign.rel_context * constraints
+    -> env * rel_context * constraints
 
 (*s Basic operations of the typing machine. *)
 
@@ -52,23 +52,23 @@ val judge_of_constant_knowing_parameters :
   env -> constant -> unsafe_judgment array -> unsafe_judgment
 
 (*s Type of application. *)
-val judge_of_apply : 
+val judge_of_apply :
   env -> unsafe_judgment -> unsafe_judgment array
     -> unsafe_judgment * constraints
 
 (*s Type of an abstraction. *)
-val judge_of_abstraction : 
-  env -> name -> unsafe_type_judgment -> unsafe_judgment 
+val judge_of_abstraction :
+  env -> name -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
 (*s Type of a product. *)
 val judge_of_product :
-  env -> name -> unsafe_type_judgment -> unsafe_type_judgment 
+  env -> name -> unsafe_type_judgment -> unsafe_type_judgment
     -> unsafe_judgment
 
 (* s Type of a let in. *)
 val judge_of_letin :
-  env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment 
+  env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
 (*s Type of a cast. *)
@@ -80,7 +80,7 @@ val judge_of_cast :
 
 val judge_of_inductive : env -> inductive -> unsafe_judgment
 
-val judge_of_inductive_knowing_parameters : 
+val judge_of_inductive_knowing_parameters :
   env -> inductive -> unsafe_judgment array -> unsafe_judgment
 
 val judge_of_constructor : env -> constructor -> unsafe_judgment
@@ -91,7 +91,7 @@ val judge_of_case : env -> case_info
     -> unsafe_judgment * constraints
 
 (* Typecheck general fixpoint (not checking guard conditions) *)
-val type_fixpoint : env -> name array -> types array 
+val type_fixpoint : env -> name array -> types array
     -> unsafe_judgment array -> constraints
 
 (* Kernel safe typing but applicable to partial proofs *)
@@ -101,7 +101,7 @@ val type_of_constant : env -> constant -> types
 
 val type_of_constant_type : env -> constant_type -> types
 
-val type_of_constant_knowing_parameters : 
+val type_of_constant_knowing_parameters :
   env -> constant_type -> constr array -> types
 
 (* Make a type polymorphic if an arity *)
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 3d254ce6..16544eca 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml 11596 2008-11-16 15:34:06Z letouzey $ *)
+(* $Id$ *)
 
 (* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
 (* Extension with algebraic universes by HH [Sep 2001] *)
@@ -55,40 +55,38 @@ let cmp_univ_level u v = match u,v with
       else if i1 > i2 then 1
       else compare dp1 dp2
 
+let string_of_univ_level = function
+  | Set -> "Set"
+  | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
+
+module UniverseLMap =
+ Map.Make (struct type t = universe_level let compare = cmp_univ_level end)
+
 type universe =
   | Atom of universe_level
   | Max of universe_level list * universe_level list
-  
-module UniverseOrdered = struct
-  type t = universe_level
-  let compare = cmp_univ_level
-end
-
-let string_of_univ_level = function
-  | Set -> "0"
-  | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
 
 let make_univ (m,n) = Atom (Level (m,n))
 
 let pr_uni_level u = str (string_of_univ_level u)
 
 let pr_uni = function
-  | Atom u -> 
+  | Atom u ->
       pr_uni_level u
   | Max ([],[u]) ->
       str "(" ++ pr_uni_level u ++ str ")+1"
   | Max (gel,gtl) ->
       str "max(" ++ hov 0
-       (prlist_with_sep pr_coma pr_uni_level gel ++
-	  (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++
-	prlist_with_sep pr_coma
+       (prlist_with_sep pr_comma pr_uni_level gel ++
+	  (if gel <> [] & gtl <> [] then pr_comma () else mt ()) ++
+	prlist_with_sep pr_comma
 	  (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++
       str ")"
 
 (* Returns the formal universe that lies juste above the universe variable u.
    Used to type the sort u. *)
 let super = function
-  | Atom u -> 
+  | Atom u ->
       Max ([],[u])
   | Max _ ->
       anomaly ("Cannot take the successor of a non variable universe:\n"^
@@ -121,18 +119,17 @@ type univ_entry =
     Canonical of canonical_arc
   | Equiv of universe_level * universe_level
 
-module UniverseMap = Map.Make(UniverseOrdered)
 
-type universes = univ_entry UniverseMap.t
-		   
+type universes = univ_entry UniverseLMap.t
+
 let enter_equiv_arc u v g =
-  UniverseMap.add u (Equiv(u,v)) g
+  UniverseLMap.add u (Equiv(u,v)) g
 
 let enter_arc ca g =
-  UniverseMap.add ca.univ (Canonical ca) g
+  UniverseLMap.add ca.univ (Canonical ca) g
 
 let declare_univ u g =
-  if not (UniverseMap.mem u g) then
+  if not (UniverseLMap.mem u g) then
     enter_arc (terminal u) g
   else
     g
@@ -162,20 +159,20 @@ let is_univ_variable = function
 
 let type1_univ = Max ([],[Set])
 
-let initial_universes = UniverseMap.empty
+let initial_universes = UniverseLMap.empty
 
 (* Every universe_level has a unique canonical arc representative *)
 
 (* repr : universes -> universe_level -> canonical_arc *)
 (* canonical representative : we follow the Equiv links *)
-let repr g u = 
+let repr g u =
   let rec repr_rec u =
     let a =
-      try UniverseMap.find u g
+      try UniverseLMap.find u g
       with Not_found -> anomalylabstrm "Univ.repr"
-	  (str"Universe " ++ pr_uni_level u ++ str" undefined") 
+	  (str"Universe " ++ pr_uni_level u ++ str" undefined")
     in
-    match a with 
+    match a with
       | Equiv(_,v) -> repr_rec v
       | Canonical arc -> arc
   in
@@ -192,16 +189,16 @@ let collect g arcu =
   let rec coll_rec lt le = function
     | [],[] -> (lt, list_subtractq le lt)
     | arcv::lt', le' ->
-	if List.memq arcv lt then 
+	if List.memq arcv lt then
 	  coll_rec lt le (lt',le')
 	else
           coll_rec (arcv::lt) le ((can g (arcv.lt@arcv.le))@lt',le')
-    | [], arcw::le' -> 
-	if (List.memq arcw lt) or (List.memq arcw le) then 
+    | [], arcw::le' ->
+	if (List.memq arcw lt) or (List.memq arcw le) then
 	  coll_rec lt le ([],le')
 	else
           coll_rec lt (arcw::le) (can g arcw.lt, (can g arcw.le)@le')
-  in 
+  in
   coll_rec [] [] ([],[arcu])
 
 (* reprleq : canonical_arc -> canonical_arc list *)
@@ -211,19 +208,19 @@ let reprleq g arcu =
     | [] -> w
     | v :: vl ->
 	let arcv = repr g v in
-        if List.memq arcv w || arcu==arcv then 
+        if List.memq arcv w || arcu==arcv then
 	  searchrec w vl
-        else 
+        else
 	  searchrec (arcv :: w) vl
-  in 
+  in
   searchrec [] arcu.le
 
 
 (* between : universe_level -> canonical_arc -> canonical_arc list *)
-(* between u v = {w|u<=w<=v, w canonical}          *)     
+(* between u v = {w|u<=w<=v, w canonical}          *)
 (* between is the most costly operation *)
 
-let between g u arcv = 
+let between g u arcv =
   (* good are all w | u <= w <= v  *)
   (* bad are all w | u <= w ~<= v *)
     (* find good and bad nodes in {w | u <= w} *)
@@ -233,50 +230,50 @@ let between g u arcv =
       (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 
+    else
+      let leq = reprleq g arcu in
 	(* is some universe >= u good ? *)
-      let good, bad, b_leq = 
+      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 
+	else
 	  good, arcu::bad, b    (* b or false *)
   in
   let good,_,_ = explore ([arcv],[],false) (repr g u) 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 = [] 
+   Otherwise, between g u v = []
  *)
 
 
 type order = EQ | LT | LE | NLE
 
 (* compare : universe_level -> universe_level -> order *)
-let compare g u v = 
-  let arcu = repr g u 
+let compare g u v =
+  let arcu = repr g u
   and arcv = repr g v in
-  if arcu==arcv then 
+  if arcu==arcv then
     EQ
-  else 
+  else
     let (lt,leq) = collect g arcu in
-    if List.memq arcv lt then 
+    if List.memq arcv lt then
       LT
-    else if List.memq arcv leq then 
+    else if List.memq arcv leq then
       LE
-    else 
+    else
       NLE
 
 (* 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 
+   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 
+   Adding u>v is consistent iff compare(v,u) = NLE
     and then it is redundant iff compare(u,v) = LT *)
 
 let compare_eq g u v =
@@ -288,7 +285,7 @@ let compare_eq g u v =
 type check_function = universes -> universe -> universe -> bool
 
 let incl_list cmp l1 l2 =
-  List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 
+  List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1
 
 let compare_list cmp l1 l2 =
   incl_list cmp l1 l2 && incl_list cmp l2 l1
@@ -361,7 +358,7 @@ let merge g u v =
                  (* redirected to it *)
 	let redirect (g,w,w') arcv =
  	  let g' = enter_equiv_arc arcv.univ arcu.univ g in
- 	  (g',list_unionq arcv.lt w,arcv.le@w') 
+ 	  (g',list_unionq arcv.lt w,arcv.le@w')
 	in
 	let (g',w,w') = List.fold_left redirect (g,[],[]) v in
 	let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in
@@ -395,7 +392,7 @@ let enforce_univ_leq u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
-    | NLE -> 
+    | NLE ->
 	(match compare g v u with
            | LT -> error_inconsistency Le u v
            | LE -> merge g v u
@@ -412,7 +409,7 @@ let enforce_univ_eq u v g =
     | EQ -> g
     | LT -> error_inconsistency Eq u v
     | LE -> merge g u v
-    | NLE -> 
+    | NLE ->
 	(match compare g v u with
            | LT -> error_inconsistency Eq u v
            | LE -> merge g v u
@@ -427,13 +424,13 @@ let enforce_univ_lt u v g =
     | LT -> g
     | LE -> setlt g u v
     | EQ -> error_inconsistency Lt u v
-    | NLE -> 
+    | NLE ->
 	(match compare g v u with
            | NLE -> setlt g u v
            | _ -> error_inconsistency Lt u v)
 
 (*
-let enforce_univ_relation g = function 
+let enforce_univ_relation g = function
   | Equiv (u,v) -> enforce_univ_eq u v g
   | Canonical {univ=u; lt=lt; le=le} ->
       let g' = List.fold_right (enforce_univ_lt u) lt g in
@@ -443,7 +440,7 @@ let enforce_univ_relation g = function
 (* Merging 2 universe graphs *)
 (*
 let merge_universes sp u1 u2 =
-  UniverseMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2
+  UniverseLMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2
 *)
 
 
@@ -461,14 +458,14 @@ let enforce_constraint cst g =
 
 
 module Constraint = Set.Make(
-  struct 
-    type t = univ_constraint 
-    let compare = Pervasives.compare 
+  struct
+    type t = univ_constraint
+    let compare = Pervasives.compare
   end)
-		      
+
 type constraints = Constraint.t
 
-type constraint_function = 
+type constraint_function =
     universe -> universe -> constraints -> constraints
 
 let constraint_add_leq v u c =
@@ -515,17 +512,17 @@ let is_direct_constraint u = function
   | Atom u' -> u = u'
   | Max (le,lt) -> List.mem u le
 
-(* 
+(*
    Solve a system of universe constraint of the form
 
    u_s11, ..., u_s1p1, w1 <= u1
    ...
    u_sn1, ..., u_snpn, wn <= un
 
-where 
+where
 
   - the ui (1 <= i <= n) are universe variables,
-  - the sjk select subsets of the ui for each equations, 
+  - the sjk select subsets of the ui for each equations,
   - the wi are arbitrary complex universes that do not mention the ui.
 *)
 
@@ -534,7 +531,7 @@ let is_direct_sort_constraint s v = match s with
   | None -> false
 
 let solve_constraints_system levels level_bounds =
-  let levels = 
+  let levels =
     Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom"))
       levels in
   let v = Array.copy level_bounds in
@@ -553,7 +550,7 @@ let solve_constraints_system levels level_bounds =
   v
 
 let subst_large_constraint u u' v =
-  match u with 
+  match u with
   | Atom u ->
       if is_direct_constraint u v then sup u' (remove_large_constraint u v)
       else v
@@ -571,16 +568,16 @@ let no_upper_constraints u cst =
 (* Pretty-printing *)
 
 let num_universes g =
-  UniverseMap.fold (fun _ _ -> succ) g 0
+  UniverseLMap.fold (fun _ _ -> succ) g 0
 
 let num_edges g =
   let reln_len = function
     | Equiv _ -> 1
     | Canonical {lt=lt;le=le} -> List.length lt + List.length le
   in
-  UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0
-    
-let pr_arc = function 
+  UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0
+
+let pr_arc = function
   | Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
   | Canonical {univ=u; lt=lt; le=le} ->
@@ -590,43 +587,43 @@ let pr_arc = function
 	 (if lt <> [] & le <> [] then spc () else mt()) ++
          prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++
       fnl ()
-  | Equiv (u,v) -> 
+  | Equiv (u,v) ->
       pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
 
 let pr_universes g =
-  let graph = UniverseMap.fold (fun k a l -> (k,a)::l) g [] in
+  let graph = UniverseLMap.fold (fun k a l -> (k,a)::l) g [] in
   prlist (function (_,a) -> pr_arc a) graph
-    
+
 let pr_constraints c =
-  Constraint.fold (fun (u1,op,u2) pp_std -> 
-		     let op_str = match op with 
+  Constraint.fold (fun (u1,op,u2) pp_std ->
+		     let op_str = match op with
 		       | Lt -> " < "
 		       | Leq -> " <= "
 		       | Eq -> " = "
 		     in pp_std ++  pr_uni_level u1 ++ str op_str ++
 			  pr_uni_level u2 ++ fnl () )  c (str "")
-    
-(* Dumping constrains to a file *)
 
-let dump_universes output g = 
+(* Dumping constraints to a file *)
+
+let dump_universes output g =
   let dump_arc _ = function
-    | Canonical {univ=u; lt=lt; le=le} -> 
+    | Canonical {univ=u; lt=lt; le=le} ->
 	let u_str = string_of_univ_level u in
-	  List.iter 
-	    (fun v -> 
+	  List.iter
+	    (fun v ->
 	       Printf.fprintf output "%s < %s ;\n" u_str
-		 (string_of_univ_level v)) 
+		 (string_of_univ_level v))
 	    lt;
-	  List.iter 
-	    (fun v -> 
+	  List.iter
+	    (fun v ->
 	       Printf.fprintf output "%s <= %s ;\n" u_str
-		 (string_of_univ_level v)) 
+		 (string_of_univ_level v))
 	    le
     | Equiv (u,v) ->
 	Printf.fprintf output "%s = %s ;\n"
 	  (string_of_univ_level u) (string_of_univ_level v)
   in
-    UniverseMap.iter dump_arc g 
+    UniverseLMap.iter dump_arc g
 
 (* Hash-consing *)
 
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 668e99a0..2bfcc2aa 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli 11301 2008-08-04 19:41:18Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Universes. *)
 
@@ -53,7 +53,7 @@ type constraint_function = universe -> universe -> constraints -> constraints
 val enforce_geq : constraint_function
 val enforce_eq : constraint_function
 
-(*s Merge of constraints in a universes graph. 
+(*s 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. *)
@@ -68,12 +68,12 @@ val merge_constraints : constraints -> universes -> universes
 
 val fresh_local_univ : unit -> universe
 
-val solve_constraints_system : universe option array -> universe array -> 
+val solve_constraints_system : universe option array -> universe array ->
   universe array
 
 val subst_large_constraint : universe -> universe -> universe -> universe
 
-val subst_large_constraints : 
+val subst_large_constraints :
   (universe * universe) list -> universe -> universe
 
 val no_upper_constraints : universe -> constraints -> bool
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index 7c515735..a35d1d88 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -3,10 +3,10 @@ open Declarations
 open Term
 open Environ
 open Conv_oracle
-open Reduction 
+open Reduction
 open Closure
 open Vm
-open Csymtable 
+open Csymtable
 open Univ
 
 let val_of_constr env c =
@@ -27,7 +27,7 @@ let rec compare_stack stk1 stk2 =
   | z1::stk1, z2::stk2 ->
       if compare_zipper z1 z2 then compare_stack stk1 stk2
       else false
-  | _, _ -> false 
+  | _, _ -> false
 
 (* Conversion *)
 let conv_vect fconv vect1 vect2 cu =
@@ -42,13 +42,13 @@ let conv_vect fconv vect1 vect2 cu =
 
 let infos = ref (create_clos_infos betaiotazeta Environ.empty_env)
 
-let rec conv_val pb k v1 v2 cu = 
-  if v1 == v2 then cu 
+let rec conv_val pb k v1 v2 cu =
+  if v1 == v2 then cu
   else conv_whd pb k (whd_val v1) (whd_val v2) cu
-    
-and conv_whd pb k whd1 whd2 cu =  
+
+and conv_whd pb k whd1 whd2 cu =
   match whd1, whd2 with
-  | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu 
+  | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu
   | Vprod p1, Vprod p2 ->
       let cu = conv_val CONV k (dom p1) (dom p2) cu in
       conv_fun pb k (codom p1) (codom p2) cu
@@ -58,11 +58,11 @@ and conv_whd pb k whd1 whd2 cu =
       if nargs args1 <> nargs args2 then raise NotConvertible
       else conv_arguments k args1 args2 (conv_fix k f1 f2 cu)
   | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu
-  | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) ->	
+  | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) ->
       if nargs args1 <> nargs args2 then raise NotConvertible
       else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu)
-  | Vconstr_const i1, Vconstr_const i2 -> 
-      if i1 = i2 then cu else raise NotConvertible 
+  | Vconstr_const i1, Vconstr_const i2 ->
+      if i1 = i2 then cu else raise NotConvertible
   | Vconstr_block b1, Vconstr_block b2 ->
       let sz = bsize b1 in
       if btag b1 = btag b2 && sz = bsize b2 then
@@ -72,33 +72,33 @@ and conv_whd pb k whd1 whd2 cu =
 	done;
 	!rcu
       else raise NotConvertible
-  | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> 
+  | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
       conv_atom pb k a1 stk1 a2 stk2 cu
-  | _, Vatom_stk(Aiddef(_,v),stk) -> 
+  | _, Vatom_stk(Aiddef(_,v),stk) ->
       conv_whd pb k whd1 (force_whd v stk) cu
-  | Vatom_stk(Aiddef(_,v),stk), _ -> 
+  | Vatom_stk(Aiddef(_,v),stk), _ ->
       conv_whd pb k (force_whd v stk) whd2 cu
   | _, _ -> raise NotConvertible
 
 and conv_atom pb k a1 stk1 a2 stk2 cu =
   match a1, a2 with
   | Aind (kn1,i1), Aind(kn2,i2) ->
-      if mind_equiv_infos !infos (kn1,i1) (kn2,i2) && compare_stack stk1 stk2
+      if eq_ind (kn1,i1) (kn2,i2) && compare_stack stk1 stk2
       then
 	conv_stack k stk1 stk2 cu
       else raise NotConvertible
-  | Aid ik1, Aid ik2 -> 
-      if ik1 = ik2 && compare_stack stk1 stk2 then 
-	conv_stack k stk1 stk2 cu 
+  | Aid ik1, Aid ik2 ->
+      if ik1 = ik2 && compare_stack stk1 stk2 then
+	conv_stack k stk1 stk2 cu
       else raise NotConvertible
   | Aiddef(ik1,v1), Aiddef(ik2,v2) ->
       begin
 	try
-	  if ik1 = ik2 && compare_stack stk1 stk2 then
-	    conv_stack k stk1 stk2 cu 
+	  if eq_table_key ik1 ik2 && compare_stack stk1 stk2 then
+	    conv_stack k stk1 stk2 cu
 	  else raise NotConvertible
 	with NotConvertible ->
-	  if oracle_order ik1 ik2 then             
+	  if oracle_order ik1 ik2 then
             conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
           else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
       end
@@ -106,15 +106,15 @@ and conv_atom pb k a1 stk1 a2 stk2 cu =
       conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
   | _, Aiddef(ik2,v2) ->
       conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
-  | _, _ -> raise NotConvertible 
-	
+  | _, _ -> raise NotConvertible
+
 and conv_stack k stk1 stk2 cu =
   match stk1, stk2 with
   | [], [] -> cu
   | Zapp args1 :: stk1, Zapp args2 :: stk2 ->
-      conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) 
+      conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu)
   | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 ->
-      conv_stack k stk1 stk2 
+      conv_stack k stk1 stk2
 	(conv_arguments k args1 args2 (conv_fix k f1 f2 cu))
   | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 ->
       if check_switch sw1 sw2 then
@@ -122,7 +122,7 @@ and conv_stack k stk1 stk2 cu =
 	let rcu = ref (conv_val CONV k vt1 vt2 cu) in
 	let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in
 	for i = 0 to Array.length b1 - 1 do
-	  rcu := 
+	  rcu :=
 	    conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu
 	done;
 	conv_stack k stk1 stk2 !rcu
@@ -136,7 +136,7 @@ and conv_fun pb k f1 f2 cu =
     conv_val pb (k+arity) b1 b2 cu
 
 and conv_fix k f1 f2 cu =
-  if f1 == f2 then cu 
+  if f1 == f2 then cu
   else
     if check_fix f1 f2 then
       let bf1, tf1 = reduce_fix k f1 in
@@ -168,34 +168,34 @@ and conv_arguments k args1 args2 cu =
     else raise NotConvertible
 
 let rec conv_eq pb t1 t2 cu =
-  if t1 == t2 then cu 
+  if t1 == t2 then cu
   else
     match kind_of_term t1, kind_of_term t2 with
-    | Rel n1, Rel n2 -> 
+    | Rel n1, Rel n2 ->
 	if n1 = n2 then cu else raise NotConvertible
     | Meta m1, Meta m2 ->
 	if m1 = m2 then cu else raise NotConvertible
-    | Var id1, Var id2 -> 
+    | Var id1, Var id2 ->
 	if id1 = id2 then cu else raise NotConvertible
     | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu
     | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu
     | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu
-    | Prod (_,t1,c1), Prod (_,t2,c2) -> 
+    | Prod (_,t1,c1), Prod (_,t2,c2) ->
 	conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu)
     | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu
-    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> 
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
 	conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu)
     | App (c1,l1), App (c2,l2) ->
 	conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu)
     | Evar (e1,l1), Evar (e2,l2) ->
 	if e1 = e2 then conv_eq_vect l1 l2 cu
 	else raise NotConvertible
-    | Const c1, Const c2 -> 
-	if c1 = c2 then cu else raise NotConvertible
-    | Ind c1, Ind c2 -> 
-	if c1 = c2 then cu else raise NotConvertible
-    | Construct c1, Construct c2 -> 
-	if c1 = c2 then cu else raise NotConvertible
+    | Const c1, Const c2 ->
+	if eq_constant c1 c2 then cu else raise NotConvertible
+    | Ind c1, Ind c2 ->
+	if eq_ind c1 c2 then cu else raise NotConvertible
+    | Construct c1, Construct c2 ->
+	if eq_constructor c1 c2 then cu else raise NotConvertible
     | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
 	let pcu = conv_eq CONV p1 p2 cu in
 	let ccu = conv_eq CONV c1 c2 pcu in
@@ -203,7 +203,7 @@ let rec conv_eq pb t1 t2 cu =
     | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
 	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
 	else raise NotConvertible
-    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->	
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
 	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
 	else raise NotConvertible
     | _ -> raise NotConvertible
@@ -216,7 +216,7 @@ and conv_eq_vect vt1 vt2 cu =
       rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu
     done; !rcu
   else raise NotConvertible
-      
+
 let vconv pb env t1 t2 =
   let cu =
     try conv_eq pb t1 t2 Constraint.empty
@@ -227,7 +227,7 @@ let vconv pb env t1 t2 =
       let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in
       cu
   in cu
-    
+
 let _ = Reduction.set_vm_conv vconv
 
 let use_vm = ref false
@@ -236,7 +236,7 @@ let set_use_vm b =
   use_vm := b;
   if b then Reduction.set_default_conv vconv
   else Reduction.set_default_conv Reduction.conv_cmp
-      
+
 let use_vm _ = !use_vm
 
 
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 4ed0592d..33893625 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vm.ml 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id$ *)
 
 open Names
 open Term
@@ -39,11 +39,11 @@ external set_transp_values : bool -> unit = "coq_set_transp_value"
 (* Le code machine  ************************)
 (*******************************************)
 
-type tcode 
+type tcode
 let tcode_of_obj v = ((Obj.obj v):tcode)
-let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) 
+let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0)
+
 
-  
 
 external mkAccuCode : int -> tcode = "coq_makeaccu"
 external mkPopStopCode : int -> tcode = "coq_pushpop"
@@ -57,21 +57,21 @@ let accumulate = accumulate ()
 
 external is_accumulate : tcode -> bool = "coq_is_accumulate_code"
 
-let popstop_tbl =  ref (Array.init 30 mkPopStopCode) 
+let popstop_tbl =  ref (Array.init 30 mkPopStopCode)
 
 let popstop_code i =
   let len = Array.length !popstop_tbl in
-  if i < len then !popstop_tbl.(i) 
+  if i < len then !popstop_tbl.(i)
   else
     begin
       popstop_tbl :=
 	Array.init (i+10)
 	  (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j);
-      !popstop_tbl.(i) 
+      !popstop_tbl.(i)
     end
 
 let stop = popstop_code 0
- 
+
 (******************************************************)
 (* Types de donnees abstraites et fonctions associees *)
 (******************************************************)
@@ -81,23 +81,23 @@ let val_of_obj v = ((Obj.obj v):values)
 let crasy_val = (val_of_obj (Obj.repr 0))
 
 (* Abstract data *)
-type vprod 
+type vprod
 type vfun
 type vfix
 type vcofix
 type vblock
 type arguments
 
-type vm_env      
+type vm_env
 type vstack = values array
 
 type vswitch = {
-    sw_type_code : tcode; 
-    sw_code : tcode; 
+    sw_type_code : tcode;
+    sw_code : tcode;
     sw_annot : annot_switch;
     sw_stk : vstack;
     sw_env : vm_env
-  } 
+  }
 
 (* Representation des types abstraits:                                    *)
 (* + Les produits :                                                       *)
@@ -105,10 +105,10 @@ type vswitch = {
 (*             dom : values, codom : vfun                                 *)
 (*                                                                        *)
 (* + Les fonctions ont deux representations possibles :                   *)
-(*   - fonction non applique :  vf = Ct_[ C | fv1 | ... | fvn]            *) 
+(*   - fonction non applique :  vf = Ct_[ C | fv1 | ... | fvn]            *)
 (*                                       C:tcode, fvi : values            *)
 (*     Remarque : il n'y a pas de difference entre la fct et son          *)
-(*                environnement.                                          *) 
+(*                environnement.                                          *)
 (*   - Application partielle  : Ct_[Restart:C| vf | arg1 | ... argn]      *)
 (*                                                                        *)
 (* + Les points fixes :                                                   *)
@@ -138,7 +138,7 @@ type vswitch = {
 (*     -- 4_[accu|vswitch] : un case bloque par un accu                   *)
 (*     -- 5_[fcofix]       : une fonction de cofix                        *)
 (*     -- 6_[fcofix|val]   : une fonction de cofix, val represente        *)
-(*        la valeur de la reduction de la fct applique a arg1 ... argn    *) 
+(*        la valeur de la reduction de la fct applique a arg1 ... argn    *)
 (* Le type [arguments] est utiliser de maniere abstraite comme un         *)
 (* tableau, il represente la structure de donnee suivante :               *)
 (*          tag[ _ | _ |v1|... | vn]                                      *)
@@ -146,7 +146,7 @@ type vswitch = {
 
 (* Ne pas changer ce type sans modifier le code C, *)
 (* en particulier le fichier "coq_values.h"        *)
-type atom = 
+type atom =
   | Aid of id_key
   | Aiddef of id_key * values
   | Aind of inductive
@@ -164,7 +164,7 @@ type to_up = values
 
 type whd =
   | Vsort of sorts
-  | Vprod of vprod 
+  | Vprod of vprod
   | Vfun of vfun
   | Vfix of vfix * arguments option
   | Vcofix of vcofix * to_up * arguments option
@@ -177,16 +177,16 @@ type whd =
 (*************************************************)
 
 let rec whd_accu a stk =
-  let stk = 
+  let stk =
     if Obj.size a = 2 then stk
     else Zapp (Obj.obj a) :: stk in
   let at = Obj.field a 1 in
   match Obj.tag at with
-  | i when i <= 2 -> 
+  | i when i <= 2 ->
       Vatom_stk(Obj.magic at, stk)
   | 3 (* fix_app tag *) ->
       let fa = Obj.field at 1 in
-      let zfix  = 
+      let zfix  =
 	Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in
       whd_accu (Obj.field at 0) (zfix :: stk)
   | 4 (* switch tag  *) ->
@@ -194,7 +194,7 @@ let rec whd_accu a stk =
       whd_accu (Obj.field at 0) (zswitch :: stk)
   | 5 (* cofix_tag *) ->
       begin match stk with
-      | [] -> 
+      | [] ->
 	  let vcfx = Obj.obj (Obj.field at 0) in
 	  let to_up = Obj.obj a in
 	  Vcofix(vcfx, to_up, None)
@@ -210,7 +210,7 @@ let rec whd_accu a stk =
 	  let vcofix = Obj.obj (Obj.field at 0) in
 	  let res = Obj.obj a in
 	  Vcofix(vcofix, res, None)
-      | [Zapp args] -> 
+      | [Zapp args] ->
 	  let vcofix = Obj.obj (Obj.field at 0) in
 	  let res = Obj.obj a in
 	  Vcofix(vcofix, res, Some args)
@@ -221,18 +221,18 @@ let rec whd_accu a stk =
 external kind_of_closure : Obj.t -> int = "coq_kind_of_closure"
 
 let whd_val : values -> whd =
-  fun v -> 
-    let o = Obj.repr v in 
+  fun v ->
+    let o = Obj.repr v in
     if Obj.is_int o then Vconstr_const (Obj.obj o)
-    else 
+    else
       let tag = Obj.tag o in
       if tag = accu_tag then
 	(
 	if Obj.size o = 1 then Obj.obj o (* sort *)
-	else 
+	else
 	  if is_accumulate (fun_code o) then whd_accu o []
 	  else (Vprod(Obj.obj o)))
-      else 
+      else
 	if tag = Obj.closure_tag || tag = Obj.infix_tag then
 	  (	   match kind_of_closure o with
 	   | 0 -> Vfun(Obj.obj o)
@@ -241,7 +241,7 @@ let whd_val : values -> whd =
 	   | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), [])
 	   | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work")
 	else Vconstr_block(Obj.obj o)
-	
+
 
 
 (************************************************)
@@ -263,16 +263,16 @@ external interprete : tcode -> values -> vm_env -> int -> values =
 
 (* Functions over arguments *)
 let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2
-let arg args i = 
-  if  0 <= i && i < (nargs args) then 
+let arg args i =
+  if  0 <= i && i < (nargs args) then
     val_of_obj (Obj.field (Obj.repr args) (i+2))
-  else raise (Invalid_argument 
+  else raise (Invalid_argument
 		("Vm.arg size = "^(string_of_int (nargs args))^
 		 " acces "^(string_of_int i)))
 
 let apply_arguments vf vargs =
   let n = nargs vargs in
-  if n = 0 then vf 
+  if n = 0 then vf
   else
    begin
      push_ra stop;
@@ -283,7 +283,7 @@ let apply_arguments vf vargs =
 let apply_vstack vf vstk =
   let n = Array.length vstk in
   if n = 0 then vf
-  else 
+  else
     begin
       push_ra stop;
       push_vstack vstk;
@@ -295,23 +295,23 @@ let apply_vstack vf vstk =
 (**********************************************)
 
 let obj_of_atom : atom -> Obj.t =
-  fun a -> 
+  fun a ->
     let res = Obj.new_block accu_tag 2 in
     Obj.set_field res 0 (Obj.repr accumulate);
     Obj.set_field res 1 (Obj.repr a);
-    res 
+    res
 
 (* obj_of_str_const : structured_constant -> Obj.t *)
 let rec obj_of_str_const str =
-  match str with 
+  match str with
   | Const_sorts s -> Obj.repr (Vsort s)
   | Const_ind ind -> obj_of_atom (Aind ind)
   | Const_b0 tag -> Obj.repr tag
   | Const_bn(tag, args) ->
       let len = Array.length args in
       let res = Obj.new_block tag len in
-      for i = 0 to len - 1 do 
-	Obj.set_field res i (obj_of_str_const args.(i)) 
+      for i = 0 to len - 1 do
+	Obj.set_field res i (obj_of_str_const args.(i))
       done;
       res
 
@@ -324,8 +324,8 @@ let val_of_atom a = val_of_obj (obj_of_atom a)
 let idkey_tbl = Hashtbl.create 31
 
 let val_of_idkey key =
-  try Hashtbl.find idkey_tbl key 
-  with Not_found -> 
+  try Hashtbl.find idkey_tbl key
+  with Not_found ->
     let v = val_of_atom (Aid key) in
     Hashtbl.add idkey_tbl key v;
     v
@@ -335,14 +335,16 @@ let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v))
 
 let val_of_named id = val_of_idkey (VarKey id)
 let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v))
-  
+
 let val_of_constant c = val_of_idkey (ConstKey c)
-let val_of_constant_def n c v = 
+let val_of_constant_def n c v =
   let res = Obj.new_block accu_tag 2 in
   Obj.set_field res 0 (Obj.repr (mkAccuCond n));
   Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v)));
   val_of_obj res
 
+external val_of_annot_switch : annot_switch -> values = "%identity"
+
 let mkrel_vstack k arity =
   let max = k + arity - 1 in
   Array.init arity (fun i -> val_of_rel (max - i))
@@ -354,7 +356,7 @@ let mkrel_vstack k arity =
 
 (* Functions over products *)
 
-let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) 
+let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0)
 let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1))
 
 (* Functions over vfun *)
@@ -383,7 +385,7 @@ let current_fix vf = - (offset (Obj.repr vf) / 2)
 let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i))
 
 let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1
-  
+
 let rec_args vf =
   let fb = first (Obj.repr vf) in
   let size = Obj.size (last fb) in
@@ -391,7 +393,7 @@ let rec_args vf =
 
 exception FALSE
 
-let check_fix f1 f2 = 
+let check_fix f1 f2 =
   let i1, i2 = current_fix f1, current_fix f2 in
   (* Verification du point de depart *)
   if i1 = i2 then
@@ -407,22 +409,22 @@ let check_fix f1 f2 =
 	done;
 	true
       with FALSE -> false
-    else false 
+    else false
   else false
 
 (* Functions over vfix *)
 external atom_rel : unit -> atom array = "get_coq_atom_tbl"
 external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl"
 
-let relaccu_tbl =  
+let relaccu_tbl =
   let atom_rel = atom_rel() in
   let len = Array.length atom_rel in
   for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done;
-  ref (Array.init len mkAccuCode) 
+  ref (Array.init len mkAccuCode)
 
 let relaccu_code i =
   let len = Array.length !relaccu_tbl in
-  if i < len then !relaccu_tbl.(i) 
+  if i < len then !relaccu_tbl.(i)
   else
     begin
       realloc_atom_rel i;
@@ -432,7 +434,7 @@ let relaccu_code i =
       relaccu_tbl :=
 	Array.init nl
 	  (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j);
-      !relaccu_tbl.(i) 
+      !relaccu_tbl.(i)
     end
 
 let reduce_fix k vf =
@@ -441,8 +443,8 @@ let reduce_fix k vf =
   let fc_typ = ((Obj.obj (last fb)) : tcode array) in
   let ndef = Array.length fc_typ in
   let et = offset_closure fb (2*(ndef - 1)) in
-  let ftyp =  
-    Array.map 
+  let ftyp =
+    Array.map
       (fun c -> interprete c crasy_val (Obj.magic et) 0) fc_typ in
   (* Construction de l' environnement des corps des points fixes *)
   let e = Obj.dup fb in
@@ -455,12 +457,12 @@ let reduce_fix k vf =
     let res = Obj.new_block Obj.closure_tag 2 in
     Obj.set_field res 0 (Obj.repr c);
     Obj.set_field res 1 (offset_closure e (2*i));
-    ((Obj.obj res) : vfun)  in 
+    ((Obj.obj res) : vfun)  in
   (Array.init ndef fix_body, ftyp)
- 
+
 (* Functions over vcofix *)
 
-let get_fcofix vcf i = 
+let get_fcofix vcf i =
   match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with
   | Vcofix(vcfi, _, _) -> vcfi
   | _ -> assert false
@@ -482,29 +484,29 @@ let check_cofix vcf1 vcf2 =
 let reduce_cofix k vcf =
   let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in
   let ndef = Array.length fc_typ in
-  let ftyp =  
+  let ftyp =
     Array.map (fun c -> interprete c crasy_val (Obj.magic vcf) 0) fc_typ in
   (* Construction de l'environnement des corps des cofix *)
 
-  let e = Obj.dup (Obj.repr vcf) in 
+  let e = Obj.dup (Obj.repr vcf) in
   for i = 0 to ndef - 1 do
-    Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) 
+    Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i)))
   done;
-   
+
   let cofix_body i =
     let vcfi = get_fcofix vcf i in
     let c = Obj.field (Obj.repr vcfi) 0 in
-    Obj.set_field e 0 c; 
+    Obj.set_field e 0 c;
     let atom = Obj.new_block cofix_tag 1 in
     let self = Obj.new_block accu_tag 2 in
     Obj.set_field self 0 (Obj.repr accumulate);
     Obj.set_field self 1 (Obj.repr atom);
-    apply_vstack (Obj.obj e) [|Obj.obj self|] in  
+    apply_vstack (Obj.obj e) [|Obj.obj self|] in
   (Array.init ndef cofix_body, ftyp)
 
 
 (* Functions over vblock *)
-  
+
 let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b)
 let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b)
 let bfield b i =
@@ -514,15 +516,15 @@ let bfield b i =
 
 (* Functions over vswitch *)
 
-let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl 
-    
+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 = 
+
+let type_of_switch sw =
   push_vstack sw.sw_stk;
-  interprete sw.sw_type_code crasy_val sw.sw_env 0 
-    
-let branch_arg k (tag,arity) = 
+  interprete sw.sw_type_code crasy_val sw.sw_env 0
+
+let branch_arg k (tag,arity) =
   if arity = 0 then  ((Obj.magic tag):values)
   else
     let b = Obj.new_block tag arity in
@@ -533,38 +535,38 @@ let branch_arg k (tag,arity) =
 
 let apply_switch sw arg =
   let tc = sw.sw_annot.tailcall in
-  if tc then 
+  if tc then
     (push_ra stop;push_vstack sw.sw_stk)
-  else 
+  else
     (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk)));
   interprete sw.sw_code arg sw.sw_env 0
-        
+
 let branch_of_switch k sw =
   let eval_branch (_,arity as ta) =
     let arg = branch_arg k ta in
     let v = apply_switch sw arg in
     (arity, v)
-  in 
+  in
   Array.map eval_branch sw.sw_annot.rtbl
-	
+
 
 (* Evaluation *)
 
 
-let is_accu v = 
+let is_accu v =
   let o = Obj.repr v in
-  Obj.is_block o && Obj.tag o = accu_tag && 
-  fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag 
+  Obj.is_block o && Obj.tag o = accu_tag &&
+  fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag
 
-let rec whd_stack v stk =  
+let rec whd_stack v stk =
   match stk with
   | [] -> whd_val v
   | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt
-  | Zfix (f,args) :: stkt -> 
+  | Zfix (f,args) :: stkt ->
       let o = Obj.repr v in
       if Obj.is_block o && Obj.tag o = accu_tag then
 	whd_accu (Obj.repr v) stk
-      else 
+      else
 	let v', stkt =
 	  match stkt with
 	  | Zapp args' :: stkt ->
@@ -573,30 +575,30 @@ let rec whd_stack v stk =
 	      push_val v;
 	      push_arguments args;
 	      let v' =
-		interprete (fun_code f) (Obj.magic f) (Obj.magic f) 
+		interprete (fun_code f) (Obj.magic f) (Obj.magic f)
 		  (nargs args+ nargs args') in
 	      v', stkt
-	  | _ -> 
+	  | _ ->
 	      push_ra stop;
 	      push_val v;
 	      push_arguments args;
 	      let v' =
-		interprete (fun_code f) (Obj.magic f) (Obj.magic f) 
+		interprete (fun_code f) (Obj.magic f) (Obj.magic f)
 		  (nargs args) in
 	      v', stkt
 	in
 	whd_stack v' stkt
-  | Zswitch sw :: stkt -> 
+  | Zswitch sw :: stkt ->
       let o = Obj.repr v in
       if Obj.is_block o && Obj.tag o = accu_tag then
 	if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk
 	else
-	  let to_up = 
+	  let to_up =
 	    match whd_accu (Obj.repr v) [] with
 	    | Vcofix (_, to_up, _) -> to_up
 	    | _ -> assert false in
 	  whd_stack (apply_switch sw to_up) stkt
-      else whd_stack (apply_switch sw v) stkt 
+      else whd_stack (apply_switch sw v) stkt
 
 let rec force_whd v stk =
   match whd_stack v stk with
diff --git a/kernel/vm.mli b/kernel/vm.mli
index 279ac937..5ecc8d99 100644
--- a/kernel/vm.mli
+++ b/kernel/vm.mli
@@ -9,11 +9,11 @@ val set_drawinstr : unit -> unit
 val transp_values : unit -> bool
 val set_transp_values : bool -> unit
 (* le code machine *)
-type tcode 
+type tcode
 
 (* Les valeurs ***********)
 
-type vprod 
+type vprod
 type vfun
 type vfix
 type vcofix
@@ -21,7 +21,7 @@ type vblock
 type vswitch
 type arguments
 
-type atom = 
+type atom =
   | Aid of id_key
   | Aiddef of id_key * values
   | Aind of inductive
@@ -39,30 +39,32 @@ type to_up
 
 type whd =
   | Vsort of sorts
-  | Vprod of vprod 
+  | Vprod of vprod
   | Vfun of vfun
   | Vfix of vfix * arguments option
   | Vcofix of vcofix * to_up * arguments option
   | Vconstr_const of int
   | Vconstr_block of vblock
   | Vatom_stk of atom * stack
- 
+
 (** Constructors *)
 val val_of_str_const : structured_constant -> values
 
-val val_of_rel : int -> values 
-val val_of_rel_def : int -> values -> values 
+val val_of_rel : int -> values
+val val_of_rel_def : int -> values -> values
 
 val val_of_named : identifier -> values
 val val_of_named_def : identifier -> values -> values
 
-val val_of_constant : constant -> values 
+val val_of_constant : constant -> values
 val val_of_constant_def : int -> constant -> values -> values
 
+external val_of_annot_switch : annot_switch -> values = "%identity"
+
 (** Destructors *)
 val whd_val : values -> whd
 
-(* Arguments *)  
+(* Arguments *)
 val nargs : arguments -> int
 val arg : arguments -> int -> values
 
@@ -71,18 +73,18 @@ val dom : vprod -> values
 val codom : vprod -> vfun
 
 (* Function *)
-val body_of_vfun : int -> vfun -> values 
+val body_of_vfun : int -> vfun -> values
 val decompose_vfun2  : int -> vfun -> vfun -> int * values * values
 
 (* Fix *)
 val current_fix : vfix -> int
 val check_fix : vfix -> vfix -> bool
-val rec_args : vfix -> int array 
+val rec_args : vfix -> int array
 val reduce_fix : int -> vfix -> vfun array * values array
                               (* bodies ,  types *)
 
 (* CoFix *)
-val current_cofix : vcofix -> int 
+val current_cofix : vcofix -> int
 val check_cofix : vcofix -> vcofix -> bool
 val reduce_cofix : int -> vcofix -> values array * values array
                                       (* bodies , types *)
diff --git a/lib/bigint.ml b/lib/bigint.ml
index 7671b0fc..f505bbe1 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: bigint.ml 9821 2007-05-11 17:00:58Z aspiwack $ *)
+(* $Id$ *)
 
 (*i*)
 open Pp
@@ -19,8 +19,8 @@ open Pp
 (* An integer is canonically represented as an array of k-digits blocs.
 
    0 is represented by the empty array and -1 by the singleton [|-1|].
-   The first bloc is in the range ]0;10^k[ for positive numbers. 
-   The first bloc is in the range ]-10^k;-1[ for negative ones. 
+   The first bloc is in the range ]0;10^k[ for positive numbers.
+   The first bloc is in the range ]-10^k;-1[ for negative ones.
    All other blocs are numbers in the range [0;10^k[.
 
    Negative numbers are represented using 2's complementation. For instance,
@@ -78,7 +78,7 @@ let normalize_neg n =
   if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
 
 let rec normalize n =
-  if Array.length n = 0 then n else 
+  if Array.length n = 0 then n else
     if n.(0) = -1 then normalize_neg n else normalize_pos n
 
 let neg m =
@@ -167,8 +167,6 @@ let less_than m n =
     (Array.length m = Array.length n && less_than_same_size m n 0 0))
 
 let equal m n = (m = n)
-  
-let less_or_equal_than m n = equal m n or less_than m n
 
 let less_than_shift_pos k m n =
   (Array.length m - k < Array.length n)
@@ -194,7 +192,7 @@ let euclid m d =
     if is_strictly_neg m then (-1),neg m else 1,Array.copy m in
   let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in
   if d = zero then raise Division_by_zero;
-  let q,r = 
+  let q,r =
     if less_than m d then (zero,m) else
     let ql = Array.length m - Array.length d in
     let q = Array.create (ql+1) 0 in
@@ -202,7 +200,7 @@ let euclid m d =
     while not (less_than_shift_pos !i m d) do
       if m.(!i)=0 then incr i else
       if can_divide !i m d 0 then begin
-        let v = 
+        let v =
           if Array.length d > 1 && d.(0) <> m.(!i) then
             (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1)
           else
@@ -234,11 +232,11 @@ let of_string s =
   let r = (String.length s - !d) mod size in
   let h = String.sub s (!d) r in
   if !d = String.length s - 1 && isneg && h="1" then neg_one else
-  let e = if h<>"" then 1 else 0 in 
+  let e = if h<>"" then 1 else 0 in
   let l = (String.length s - !d) / size in
   let a = Array.create (l + e + n) 0 in
   if isneg then begin
-    a.(0) <- (-1); 
+    a.(0) <- (-1);
     let carry = ref 0 in
     for i=l downto 1 do
       let v = int_of_string (String.sub s ((i-1)*size + !d +r) size)+ !carry in
@@ -298,7 +296,7 @@ let app_pair f (m, n) =
   (f m, f n)
 
 let add m n =
-  if Obj.is_int m & Obj.is_int n 
+  if Obj.is_int m & Obj.is_int n
   then big_of_int (coerce_to_int m + coerce_to_int n)
   else big_of_ints (add (ints_of_z m) (ints_of_z n))
 
@@ -313,8 +311,8 @@ let mult m n =
   else big_of_ints (mult (ints_of_z m) (ints_of_z n))
 
 let euclid m n =
-  if Obj.is_int m & Obj.is_int n 
-  then app_pair big_of_int 
+  if Obj.is_int m & Obj.is_int n
+  then app_pair big_of_int
     (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n)
   else app_pair big_of_ints (euclid (ints_of_z m) (ints_of_z n))
 
@@ -335,9 +333,7 @@ let one = big_of_int 1
 let sub_1 n = sub n one
 let add_1 n = add n one
 let two = big_of_int 2
-let neg_two = big_of_int (-2)
 let mult_2 n = add n n
-let is_zero n = n=zero
 
 let div2_with_rest n =
   let (q,b) = euclid n two in
@@ -364,12 +360,12 @@ let pow  =
       let (quo,rem) = div2_with_rest m in
       pow_aux
 	((* [if m mod 2 = 1]*)
-         if rem then 
+         if rem then
           mult n odd_rest
 	 else
           odd_rest )
 	(* quo = [m/2] *)
-	(mult n n) quo 
+	(mult n n) quo
   in
   pow_aux one
 
@@ -397,7 +393,7 @@ let check () =
     let s = Printf.sprintf "%30s" (to_string n) in
     let s' = Printf.sprintf "% 30.0f" (round n') in
     if s <> s' then Printf.printf "%s: %s <> %s\n" op s s' in
-List.iter (fun a -> List.iter (fun b ->  
+List.iter (fun a -> List.iter (fun b ->
   let n = of_string a and m = of_string b in
   let n' = float_of_string a and m' = float_of_string b in
   let a = add n m and a' = n' +. m' in
diff --git a/lib/bigint.mli b/lib/bigint.mli
index f6d3da7b..69b035c4 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: bigint.mli 9821 2007-05-11 17:00:58Z aspiwack $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
diff --git a/lib/bstack.ml b/lib/bstack.ml
index 35bbf32b..4191ccdb 100644
--- a/lib/bstack.ml
+++ b/lib/bstack.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: bstack.ml 10441 2008-01-15 16:37:46Z lmamane $ *)
+(* $Id$ *)
 
 (* Queues of a given length *)
 
@@ -47,10 +47,10 @@ let push bs e =
   incr_size bs;
   bs.depth <- bs.depth + 1;
   bs.stack.(bs.pos) <- e
-	  
+
 let pop bs =
   if bs.size > 1 then begin
-    bs.size <- bs.size - 1; 
+    bs.size <- bs.size - 1;
     bs.depth <- bs.depth - 1;
     let oldpos = bs.pos in
     decr_pos bs;
@@ -61,7 +61,7 @@ let pop bs =
 let top bs =
   if bs.size >= 1 then bs.stack.(bs.pos)
   else error "Nothing on the stack"
-	  
+
 let app_push bs f =
   if bs.size = 0 then error "Nothing on the stack"
   else push bs (f (bs.stack.(bs.pos)))
diff --git a/lib/bstack.mli b/lib/bstack.mli
index ca2b5f02..cef8e1d9 100644
--- a/lib/bstack.mli
+++ b/lib/bstack.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: bstack.mli 10441 2008-01-15 16:37:46Z lmamane $ i*)
+(*i $Id$ i*)
 
 (* Bounded stacks. If the depth is [None], then there is no depth limit. *)
 
diff --git a/lib/compat.ml4 b/lib/compat.ml4
index 40cffadb..7566624b 100644
--- a/lib/compat.ml4
+++ b/lib/compat.ml4
@@ -12,8 +12,8 @@
 
 IFDEF OCAML309 THEN DEFINE OCAML308 END
 
-IFDEF CAMLP5 THEN 
-module M = struct 
+IFDEF CAMLP5 THEN
+module M = struct
 type loc = Stdpp.location
 let dummy_loc = Stdpp.dummy_loc
 let make_loc = Stdpp.make_loc
@@ -23,7 +23,6 @@ let join_loc loc1 loc2 =
  else Stdpp.encl_loc loc1 loc2
 type token = string*string
 type lexer = token Token.glexer
-let using l x = l.Token.tok_using x
 end
 ELSE IFDEF OCAML308 THEN
 module M = struct
@@ -40,12 +39,11 @@ let unloc (b,e) =
   loc
 let join_loc loc1 loc2 =
  if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc
- else (fst loc1, snd loc2) 
+ else (fst loc1, snd loc2)
 type token = Token.t
 type lexer = Token.lexer
-let using l x = l.Token.using x
 end
-ELSE 
+ELSE
 module M = struct
 type loc = int * int
 let dummy_loc = (0,0)
@@ -56,7 +54,6 @@ let join_loc loc1 loc2 =
  else (fst loc1, snd loc2)
 type token = Token.t
 type lexer = Token.lexer
-let using l x = l.Token.using x
 end
 END
 END
@@ -68,4 +65,3 @@ let unloc = M.unloc
 let join_loc = M.join_loc
 type token = M.token
 type lexer = M.lexer
-let using = M.using
diff --git a/lib/dnet.ml b/lib/dnet.ml
new file mode 100644
index 00000000..f7b36929
--- /dev/null
+++ b/lib/dnet.ml
@@ -0,0 +1,295 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(* Generic dnet implementation over non-recursive types *)
+
+module type Datatype =
+sig
+  type 'a t
+  val map : ('a -> 'b) -> 'a t -> 'b t
+  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+  val fold2 : ('a -> 'b -> 'c -> 'a)  -> 'a -> 'b t -> 'c t -> 'a
+  val compare : unit t -> unit t -> int
+  val terminal : 'a t -> bool
+  val choose : ('a -> 'b) -> 'a t -> 'b
+end
+
+module type S =
+sig
+  type t
+  type ident
+  type meta
+  type 'a structure
+  module Idset : Set.S with type elt=ident
+  type 'a pattern =
+    | Term of 'a
+    | Meta of meta
+  type term_pattern = ('a structure) pattern as 'a
+  val empty : t
+  val add : t -> term_pattern -> ident -> t
+  val find_all : t -> Idset.t
+  val fold_pattern :
+    ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
+  val find_match : term_pattern -> t -> Idset.t
+  val inter : t -> t -> t
+  val union : t -> t -> t
+  val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
+end
+
+module Make =
+  functor (T:Datatype) ->
+  functor (Ident:Set.OrderedType) ->
+  functor (Meta:Set.OrderedType) ->
+struct
+
+  type ident = Ident.t
+  type meta = Meta.t
+
+  type 'a pattern =
+    | Term of 'a
+    | Meta of meta
+
+  type 'a structure = 'a T.t
+
+  module Idset = Set.Make(Ident)
+  module Mmap = Map.Make(Meta)
+  module Tmap = Map.Make(struct type t = unit structure
+				let compare = T.compare end)
+
+  type term_pattern = term_pattern structure pattern
+  type idset = Idset.t
+
+
+
+  (* we store identifiers at the leaf of the dnet *)
+  type node =
+    | Node of t structure
+    | Terminal of t structure * idset
+
+  (* at each node, we have a bunch of nodes (actually a map between
+     the bare node and a subnet) and a bunch of metavariables *)
+  and t = Nodes of node Tmap.t * idset Mmap.t
+
+  let empty : t = Nodes (Tmap.empty, Mmap.empty)
+
+  (* the head of a data is of type unit structure *)
+  let head w = T.map (fun c -> ()) w
+
+  (* given a node of the net and a word, returns the subnet with the
+     same head as the word (with the rest of the nodes) *)
+  let split l (w:'a structure) : node * node Tmap.t =
+    let elt : node = Tmap.find (head w) l in
+    (elt, Tmap.remove (head w) l)
+
+  let select l w = Tmap.find (head w) l
+
+  let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t =
+    match w with Term w ->
+      ( try
+	  let (n,tl) = split t w in
+	  let new_node = match n with
+	    | Terminal (e,is) -> Terminal (e,Idset.add id is)
+	    | Node e -> Node (T.map2 (fun t p -> add t p id)  e w) in
+	  Nodes ((Tmap.add (head w) new_node tl), m)
+	with Not_found ->
+	  let new_content = T.map (fun p -> add empty p id) w in
+	  let new_node =
+	    if T.terminal w then
+	      Terminal (new_content, Idset.singleton id)
+	    else Node new_content in
+	  Nodes ((Tmap.add (head w) new_node t), m) )
+      | Meta i ->
+	  let m =
+	    try Mmap.add i (Idset.add id (Mmap.find i m)) m
+	    with Not_found -> Mmap.add i (Idset.singleton id) m in
+	  Nodes (t, m)
+
+  let add t w id = add t w id
+
+  let rec find_all (Nodes (t,m)) : idset =
+    Idset.union
+      (Mmap.fold (fun _ -> Idset.union) m Idset.empty)
+      (Tmap.fold
+	 ( fun _ n acc ->
+	     let s2 = match n with
+	       | Terminal (_,is) -> is
+	       | Node e -> T.choose find_all e in
+	     Idset.union acc s2
+	 ) t Idset.empty)
+
+(*   (\* optimization hack: Not_found is catched in fold_pattern *\) *)
+(*   let fast_inter s1 s2 = *)
+(*     if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *)
+(*     else Idset.inter s1 s2 *)
+
+(*   let option_any2 f s1 s2 = match s1,s2 with *)
+(*     | Some s1, Some s2 -> f s1 s2 *)
+(*     | (Some s, _ | _, Some s) -> s *)
+(*     | _ -> raise Not_found *)
+
+(*   let fold_pattern ?(complete=true) f acc pat dn = *)
+(*     let deferred = ref [] in *)
+(*     let leafs,metas = ref None, ref None in *)
+(*     let leaf s = leafs := match !leafs with *)
+(*       | None -> Some s *)
+(*       | Some s' -> Some (fast_inter s s') in *)
+(*     let meta s = metas := match !metas with *)
+(*       | None -> Some s *)
+(*       | Some s' -> Some (Idset.union s s') in *)
+(*     let defer c = deferred := c::!deferred in *)
+(*     let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *)
+(*       Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *)
+(*       match p with *)
+(* 	| Meta m -> defer (m,dn) *)
+(* 	| Term w -> *)
+(* 	    try match select t w with *)
+(* 	      | Terminal (_,is) -> leaf is *)
+(* 	      | Node e -> *)
+(* 		  if complete then T.fold2 (fun _ -> fp_rec) () w e else *)
+(* 		    if T.fold2 *)
+(* 		      (fun b p dn -> match p with *)
+(* 			 | Term _ -> fp_rec p dn; false *)
+(* 			 | Meta _ -> b *)
+(* 		      ) true w e *)
+(* 		    then T.choose (T.choose fp_rec w) e *)
+(* 	    with Not_found -> *)
+(* 	      if Mmap.is_empty m then raise Not_found else () *)
+(*     in try *)
+(*       fp_rec pat dn; *)
+(*       (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *)
+(*       List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *)
+(*     with Not_found -> None,acc *)
+
+  (* Sets with a neutral element for inter *)
+  module OSet (S:Set.S) = struct
+    type t = S.t option
+    let union s1 s2 = match s1,s2 with
+      | (None, _ | _, None) -> None
+      | Some a, Some b -> Some (S.union a b)
+    let inter s1 s2 = match s1,s2 with
+      | (None, a | a, None) -> a
+      | Some a, Some b -> Some (S.inter a b)
+    let is_empty = function 
+      | None -> false
+      | Some s -> S.is_empty s
+    (* optimization hack: Not_found is catched in fold_pattern *)
+    let fast_inter s1 s2 =
+      if is_empty s1 || is_empty s2 then raise Not_found
+      else let r = inter s1 s2 in 
+      if is_empty r then raise Not_found else r
+    let full = None
+    let empty = Some S.empty
+  end
+
+  module OIdset = OSet(Idset)
+
+  let fold_pattern ?(complete=true) f acc pat dn =
+    let deferred = ref [] in
+    let defer c = deferred := c::!deferred in
+
+    let rec fp_rec metas p (Nodes(t,m) as dn:t) =
+      (* TODO gérer les dnets non-linéaires *)
+      let metas = Mmap.fold (fun _ -> Idset.union) m metas in
+      match p with 
+	| Meta m -> defer (metas,m,dn); OIdset.full
+	| Term w ->
+	    let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in
+	    try match select t w with
+	      | Terminal (_,is) -> Some (Idset.union curm is)
+	      | Node e -> 
+		  let ids = if complete then T.fold2
+		    (fun acc w e ->
+		       OIdset.fast_inter acc (fp_rec metas w e)
+		    ) OIdset.full w e 
+		  else
+		    let (all_metas, res) = T.fold2
+		      (fun (b,acc) w e -> match w with
+			 | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e)
+			 | Meta _ -> b, acc
+		      ) (true,OIdset.full) w e in
+		    if all_metas then T.choose (T.choose (fp_rec metas) w) e
+		    else res in
+		  OIdset.union ids (Some curm)
+	    with Not_found -> 
+	      if Idset.is_empty metas then raise Not_found else Some curm in
+    let cand = 
+      try fp_rec Idset.empty pat dn
+      with Not_found -> OIdset.empty in
+    let res = List.fold_left f acc !deferred in
+    cand, res
+
+  (* intersection of two dnets. keep only the common pairs *)
+  let rec inter (t1:t) (t2:t) : t =
+    let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
+      Nodes
+	(Tmap.fold
+	   ( fun k e acc ->
+	       try Tmap.add k (f e (Tmap.find k t2)) acc
+	       with Not_found -> acc
+	   ) t1 Tmap.empty,
+	 Mmap.fold
+	   ( fun m s acc ->
+	       try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc
+	       with Not_found -> acc
+	   ) m1 Mmap.empty
+	) in
+    inter_map
+      (fun n1 n2 -> match n1,n2 with
+	 | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2)
+	 | Node e1, Node e2 -> Node (T.map2 inter e1 e2)
+	 | _ -> assert false
+      ) t1 t2
+
+  let rec union (t1:t) (t2:t) : t =
+    let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
+      Nodes
+	(Tmap.fold
+	   ( fun k e acc ->
+	       try Tmap.add k (f e (Tmap.find k acc)) acc
+	       with Not_found -> Tmap.add k e acc
+	   ) t1 t2,
+	 Mmap.fold
+	   ( fun m s acc ->
+	       try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc
+	       with Not_found -> Mmap.add m s acc
+	   ) m1 m2
+	) in
+    union_map
+      (fun n1 n2 -> match n1,n2 with
+	 | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2)
+	 | Node e1, Node e2 -> Node (T.map2 union e1 e2)
+	 | _ -> assert false
+      ) t1 t2
+
+  let find_match (p:term_pattern) (t:t) : idset =
+    let metas = ref Mmap.empty in
+    let (mset,lset) = fold_pattern ~complete:false
+      (fun acc (mset,m,t) ->
+	 let all = OIdset.fast_inter acc
+	   (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in
+		 metas := Mmap.add m t !metas;
+		 find_all t)) in
+	 OIdset.union (Some mset) all
+      ) None p t in
+    Option.get (OIdset.inter mset lset)
+
+  let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn
+
+  let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty
+  let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty
+
+  let rec map sidset sterm (Nodes (t,m)) : t =
+    let snode = function
+      | Terminal (e,is) -> Terminal (e,idset_map sidset is)
+      | Node e -> Node (T.map (map sidset sterm) e) in
+    Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m)
+
+end
diff --git a/lib/dnet.mli b/lib/dnet.mli
new file mode 100644
index 00000000..61998d63
--- /dev/null
+++ b/lib/dnet.mli
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(* Generic discrimination net implementation over recursive
+   types. This module implements a association data structure similar
+   to tries but working on any types (not just lists). It is a term
+   indexing datastructure, a generalization of the discrimination nets
+   described for example in W.W.McCune, 1992, related also to
+   generalized tries [Hinze, 2000].
+
+   You can add pairs of (term,identifier) into a dnet, where the
+   identifier is *unique*, and search terms in a dnet filtering a
+   given pattern (retrievial of instances). It returns all identifiers
+   associated with terms matching the pattern. It also works the other
+   way around : You provide a set of patterns and a term, and it
+   returns all patterns which the term matches (retrievial of
+   generalizations). That's why you provide *patterns* everywhere.
+
+   Warning 1: Full unification doesn't work as for now. Make sure the
+   set of metavariables in the structure and in the queries are
+   distincts, or you'll get unexpected behaviours.
+
+   Warning 2: This structure is perfect, i.e. the set of candidates
+   returned is equal to the set of solutions. Beware of DeBruijn
+   shifts and sorts subtyping though (which makes the comparison not
+   symmetric, see term_dnet.ml).
+
+   The complexity of the search is (almost) the depth of the term.
+
+   To use it, you have to provide a module (Datatype) with the datatype
+   parametrized on the recursive argument. example:
+
+   type btree =                      type 'a btree0 =
+   | Leaf                    ===>    | Leaf
+   | Node of btree * btree           | Node of 'a * 'a
+
+*)
+
+(* datatype you want to build a dnet on *)
+module type Datatype =
+sig
+  (* parametric datatype. ['a] is morally the recursive argument *)
+  type 'a t
+
+  (* non-recursive mapping of subterms *)
+  val map : ('a -> 'b) -> 'a t -> 'b t
+  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+
+  (* non-recursive folding of subterms *)
+  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+  val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a
+
+  (* comparison of constructors *)
+  val compare : unit t -> unit t -> int
+
+  (* for each constructor, is it not-parametric on 'a? *)
+  val terminal : 'a t -> bool
+
+  (* [choose f w] applies f on ONE of the subterms of w *)
+  val choose : ('a -> 'b) -> 'a t -> 'b
+end
+
+module type S =
+sig
+  type t
+
+  (* provided identifier type *)
+  type ident
+
+  (* provided metavariable type *)
+  type meta
+
+  (* provided parametrized datastructure *)
+  type 'a structure
+
+  (* returned sets of solutions *)
+  module Idset : Set.S with type elt=ident
+
+  (* a pattern is a term where each node can be a unification
+     variable *)
+  type 'a pattern =
+    | Term of 'a
+    | Meta of meta
+
+  type term_pattern = 'a structure pattern as 'a
+
+  val empty : t
+
+  (* [add t w i] adds a new association (w,i) in t. *)
+  val add : t -> term_pattern -> ident -> t
+
+  (* [find_all t] returns all identifiers contained in t. *)
+  val find_all : t -> Idset.t
+
+  (* [fold_pattern f acc p dn] folds f on each meta of p, passing the
+     meta and the sub-dnet under it. The result includes:
+     - Some set if identifiers were gathered on the leafs of the term
+     - None if the pattern contains no leaf (only Metas at the leafs).
+  *)
+  val fold_pattern :
+    ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
+
+  (* [find_match p t] returns identifiers of all terms matching p in
+     t. *)
+  val find_match : term_pattern -> t -> Idset.t
+
+  (* set operations on dnets *)
+  val inter : t -> t -> t
+  val union : t -> t -> t
+
+  (* apply a function on each identifier and node of terms in a dnet *)
+  val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
+end
+
+module Make :
+  functor (T:Datatype) ->
+  functor (Ident:Set.OrderedType) ->
+  functor (Meta:Set.OrderedType) ->
+    S with type ident = Ident.t
+      and  type meta = Meta.t
+      and  type 'a structure = 'a T.t
diff --git a/lib/dyn.ml b/lib/dyn.ml
index 94979835..d2bd458a 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dyn.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 
@@ -17,7 +17,7 @@ type t = string * Obj.t
 let dyntab = ref ([] : string list)
 
 let create s =
-  if List.mem s !dyntab then 
+  if List.mem s !dyntab then
     anomaly ("Dyn.create: already declared dynamic " ^ s);
   dyntab := s :: !dyntab;
   ((fun v -> (s,Obj.repr v)),
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 86a1560a..1149612f 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dyn.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Dynamics. Use with extreme care. Not for kids. *)
 
diff --git a/lib/edit.ml b/lib/edit.ml
index 380abfd8..fd870a21 100644
--- a/lib/edit.ml
+++ b/lib/edit.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: edit.ml 10441 2008-01-15 16:37:46Z lmamane $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -16,7 +16,7 @@ type ('a,'b,'c) t = {
   mutable last_focused_stk : 'a list;
   buf : ('a, 'b Bstack.t * 'c) Hashtbl.t }
 
-let empty () = { 
+let empty () = {
   focus = None;
   last_focused_stk = [];
   buf = Hashtbl.create 17 }
@@ -38,7 +38,7 @@ let unfocus e =
 	  e.last_focused_stk <- foc::(list_except foc e.last_focused_stk);
 	  e.focus <- None
 	end
-    
+
 let last_focused e =
   match e.last_focused_stk with
     | [] -> None
@@ -48,7 +48,7 @@ let restore_last_focus e =
   match e.last_focused_stk with
     | [] -> ()
     | f::_ -> focus e f
-			     
+
 let focusedp e =
   match e.focus with
     | None -> false
@@ -96,8 +96,8 @@ let depth e =
 (* Undo focused proof of [e] to reach depth [n] *)
 let undo_todepth e n =
   match e.focus with
-    | None -> 
-	if n <> 0 
+    | None ->
+	if n <> 0
 	then errorlabstrm "Edit.undo_todepth" (str"No proof in progress")
 	else () (* if there is no proof in progress, then n must be zero *)
     | Some d ->
@@ -109,7 +109,7 @@ let undo_todepth e n =
 
 let create e (d,b,c,usize) =
   if Hashtbl.mem e.buf d then
-    errorlabstrm "Edit.create" 
+    errorlabstrm "Edit.create"
       (str"Already editing something of that name");
   let bs = Bstack.create usize b in
   Hashtbl.add e.buf d (bs,c)
@@ -123,11 +123,11 @@ let delete e d =
     | Some d' -> if d = d' then (e.focus <- None ; (restore_last_focus e))
     | None -> ()
 
-let dom e = 
+let dom e =
   let l = ref [] in
   Hashtbl.iter (fun x _ -> l := x :: !l) e.buf;
   !l
-	      
+
 let clear e =
   e.focus <- None;
   e.last_focused_stk <- [];
diff --git a/lib/edit.mli b/lib/edit.mli
index ab82c1f9..d13d9c6f 100644
--- a/lib/edit.mli
+++ b/lib/edit.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: edit.mli 6947 2005-04-20 16:18:41Z coq $ i*)
+(*i $Id$ i*)
 
 (* The type of editors.
  * An editor is a finite map, ['a -> 'b], which knows how to apply
diff --git a/lib/envars.ml b/lib/envars.ml
index d700ffe1..2e680ad0 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -9,77 +9,77 @@
 (* This file gathers environment variables needed by Coq to run (such
    as coqlib) *)
 
-let coqbin () = 
+let coqbin () =
   if !Flags.boot || Coq_config.local
   then Filename.concat Coq_config.coqsrc "bin"
   else System.canonical_path_name (Filename.dirname Sys.executable_name)
 
-let guess_coqlib () = 
+let guess_coqlib () =
   let file = "states/initial.coq" in
-    if Sys.file_exists (Filename.concat Coq_config.coqlib file) 
+    if Sys.file_exists (Filename.concat Coq_config.coqlib file)
     then Coq_config.coqlib
-    else 
+    else
       let coqbin = System.canonical_path_name (Filename.dirname Sys.executable_name) in
       let prefix = Filename.dirname coqbin in
-      let rpath = if Coq_config.local then [] else 
+      let rpath = if Coq_config.local then [] else
 	  (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) in
       let coqlib = List.fold_left Filename.concat prefix rpath in
 	if Sys.file_exists (Filename.concat coqlib file) then coqlib else
 	  Util.error "cannot guess a path for Coq libraries; please use -coqlib option"
-	  
-let coqlib () = 
+
+let coqlib () =
   if !Flags.coqlib_spec then !Flags.coqlib else
     (if !Flags.boot then Coq_config.coqsrc else guess_coqlib ())
 
 let path_to_list p =
   let sep = if Sys.os_type = "Win32" then ';' else ':' in
-    Util.split_string_at sep p 
+    Util.split_string_at sep p
 
 let rec which l f =
   match l with
     | [] -> raise Not_found
-    | p :: tl -> 
-	if Sys.file_exists (Filename.concat p f) 
-	then p 
+    | p :: tl ->
+	if Sys.file_exists (Filename.concat p f)
+	then p
 	else which tl f
- 
-let guess_camlbin () = 
-  let path = try Sys.getenv "PATH" with _ -> raise Not_found in 
+
+let guess_camlbin () =
+  let path = try Sys.getenv "PATH" with _ -> raise Not_found in
   let lpath = path_to_list path in
     which lpath "ocamlc"
 
-let guess_camlp4bin () = 
-  let path = try Sys.getenv "PATH" with _ -> raise Not_found in 
+let guess_camlp4bin () =
+  let path = try Sys.getenv "PATH" with _ -> raise Not_found in
   let lpath = path_to_list path in
     which lpath Coq_config.camlp4
 
-let camlbin () = 
+let camlbin () =
   if !Flags.camlbin_spec then !Flags.camlbin else
     if !Flags.boot then Coq_config.camlbin else
       try guess_camlbin () with _ -> Coq_config.camlbin
 
-let camllib () = 
+let camllib () =
   if !Flags.boot
   then Coq_config.camllib
-  else 
-    let camlbin = camlbin () in 
+  else
+    let camlbin = camlbin () in
     let com = (Filename.concat camlbin "ocamlc") ^ " -where" in
     let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
     Util.strip res
 
 (* TODO : essayer aussi camlbin *)
-let camlp4bin () = 
+let camlp4bin () =
   if !Flags.camlp4bin_spec then !Flags.camlp4bin else
     if !Flags.boot then Coq_config.camlp4bin else
       try guess_camlp4bin () with _ -> Coq_config.camlp4bin
 
-let camlp4lib () = 
+let camlp4lib () =
   if !Flags.boot
   then Coq_config.camlp4lib
-  else 
-    let camlp4bin = camlp4bin () in 
+  else
+    let camlp4bin = camlp4bin () in
     let com = (Filename.concat camlp4bin Coq_config.camlp4) ^ " -where" in
     let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
     Util.strip res
 
-    
+
diff --git a/lib/explore.ml b/lib/explore.ml
index 7e6de0c4..76049509 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: explore.ml 6066 2004-09-06 22:54:50Z barras $ i*)
+(*i $Id$ i*)
 
 open Format
 
@@ -23,7 +23,7 @@ module Make = functor(S : SearchProblem) -> struct
 
   type position = int list
 
-  let pp_position p = 
+  let pp_position p =
     let rec pp_rec = function
       | [] -> ()
       | [i] -> printf "%d" i
@@ -33,21 +33,21 @@ module Make = functor(S : SearchProblem) -> struct
 
   (*s Depth first search. *)
 
-  let rec depth_first s = 
+  let rec depth_first s =
     if S.success s then s else depth_first_many (S.branching s)
   and depth_first_many = function
     | [] -> raise Not_found
     | [s] -> depth_first s
     | s :: l -> try depth_first s with Not_found -> depth_first_many l
 
-  let debug_depth_first s = 
+  let debug_depth_first s =
     let rec explore p s =
       pp_position p; S.pp s;
       if S.success s then s else explore_many 1 p (S.branching s)
     and explore_many i p = function
       | [] -> raise Not_found
       | [s] -> explore (i::p) s
-      | s :: l -> 
+      | s :: l ->
 	  try explore (i::p) s with Not_found -> explore_many (succ i) p l
     in
     explore [1] s
@@ -66,7 +66,7 @@ module Make = functor(S : SearchProblem) -> struct
     | h, x::t -> x, (h,t)
     | h, [] -> match List.rev h with x::t -> x, ([],t) | [] -> raise Empty
 
-  let breadth_first s = 
+  let breadth_first s =
     let rec explore q =
       let (s, q') = try pop q with Empty -> raise Not_found in
       enqueue q' (S.branching s)
@@ -76,15 +76,15 @@ module Make = functor(S : SearchProblem) -> struct
     in
     enqueue empty [s]
 
-  let debug_breadth_first s = 
+  let debug_breadth_first s =
     let rec explore q =
-      let ((p,s), q') = try pop q with Empty -> raise Not_found in 
+      let ((p,s), q') = try pop q with Empty -> raise Not_found in
       enqueue 1 p q' (S.branching s)
     and enqueue i p q = function
-      | [] -> 
+      | [] ->
 	  explore q
       | s :: l ->
-	  let ps = i::p in 
+	  let ps = i::p in
 	  pp_position ps; S.pp s;
 	  if S.success s then s else enqueue (succ i) p (push (ps,s) q) l
     in
diff --git a/lib/explore.mli b/lib/explore.mli
index 07f95e8a..e29f2795 100644
--- a/lib/explore.mli
+++ b/lib/explore.mli
@@ -6,18 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: explore.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*s Search strategies. *)
 
 (*s A search problem implements the following signature [SearchProblem].
     [state] is the type of states of the search tree.
-    [branching] is the branching function; if [branching s] returns an 
+    [branching] is the branching function; if [branching s] returns an
     empty list, then search from [s] is aborted; successors of [s] are
     recursively searched in the order they appear in the list.
-    [success] determines whether a given state is a success. 
+    [success] determines whether a given state is a success.
 
-    [pp] is a pretty-printer for states used in debugging versions of the 
+    [pp] is a pretty-printer for states used in debugging versions of the
     search functions. *)
 
 module type SearchProblem = sig
@@ -33,7 +33,7 @@ module type SearchProblem = sig
 end
 
 (*s Functor [Make] returns some search functions given a search problem.
-    Search functions raise [Not_found] if no success is found. 
+    Search functions raise [Not_found] if no success is found.
     States are always visited in the order they appear in the
     output of [branching] (whatever the search method is).
     Debugging versions of the search functions print the position of the
diff --git a/lib/flags.ml b/lib/flags.ml
index 928912e6..12d25c54 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: flags.ml 11801 2009-01-18 20:11:41Z herbelin $ i*)
+(*i $Id$ i*)
 
 let with_option o f x =
   let old = !o in o:=true;
@@ -37,6 +37,14 @@ let raw_print = ref false
 
 let unicode_syntax = ref false
 
+(* Compatibility mode *)
+
+type compat_version = V8_2
+let compat_version = ref None
+let version_strictly_greater v =
+  match !compat_version with None -> true | Some v' -> v'>v
+let version_less_or_equal v = not (version_strictly_greater v)
+
 (* Translate *)
 let beautify = ref false
 let make_beautify f = beautify := f
@@ -55,6 +63,10 @@ let verbosely f x = without_option silent f x
 let if_silent f x = if !silent then f x
 let if_verbose f x = if not !silent then f x
 
+let auto_intros = ref true
+let make_auto_intros flag = auto_intros := flag
+let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros
+
 let hash_cons_proofs = ref true
 
 let warn = ref true
@@ -80,8 +92,8 @@ let is_unsafe s = Stringset.mem s !unsafe_set
 
 let boxed_definitions = ref true
 let set_boxed_definitions b = boxed_definitions := b
-let boxed_definitions _ = !boxed_definitions 
- 
+let boxed_definitions _ = !boxed_definitions
+
 (* Flags for external tools *)
 
 let subst_command_placeholder s t =
@@ -102,6 +114,15 @@ let browser_cmd_fmt =
  with
   Not_found -> Coq_config.browser
 
+let is_standard_doc_url url =
+  let wwwcompatprefix = "http://www.lix.polytechnique.fr/coq/" in
+  let wwwprefix = "http://coq.inria.fr/" in
+  let n = String.length wwwprefix in
+  let n' = String.length Coq_config.wwwrefman in
+  url = Coq_config.localwwwrefman ||
+  url = Coq_config.wwwrefman ||
+  url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n)
+
 (* Options for changing coqlib *)
 let coqlib_spec = ref false
 let coqlib = ref Coq_config.coqlib
diff --git a/lib/flags.mli b/lib/flags.mli
index c5903285..50ba923b 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: flags.mli 11801 2009-01-18 20:11:41Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Global options of the system. *)
 
@@ -29,6 +29,11 @@ val raw_print : bool ref
 
 val unicode_syntax : bool ref
 
+type compat_version = V8_2
+val compat_version : compat_version option ref
+val version_strictly_greater : compat_version -> bool
+val version_less_or_equal : compat_version -> bool
+
 val beautify : bool ref
 val make_beautify : bool -> unit
 val do_beautify : unit -> bool
@@ -42,6 +47,9 @@ val verbosely : ('a -> 'b) -> 'a -> 'b
 val if_silent : ('a -> unit) -> 'a -> unit
 val if_verbose : ('a -> unit) -> 'a -> unit
 
+val make_auto_intros : bool -> unit
+val is_auto_intros : unit -> bool
+
 val make_warn : bool -> unit
 val if_warn : ('a -> unit) -> 'a -> unit
 
@@ -70,7 +78,9 @@ val boxed_definitions : unit -> bool
 
 (* Returns string format for default browser to use from Coq or CoqIDE *)
 val browser_cmd_fmt : string
- 
+
+val is_standard_doc_url : string -> bool
+
 (* Substitute %s in the first chain by the second chain *)
 val subst_command_placeholder : string -> string -> string
 
diff --git a/lib/fmap.ml b/lib/fmap.ml
new file mode 100644
index 00000000..8ca56fe7
--- /dev/null
+++ b/lib/fmap.ml
@@ -0,0 +1,133 @@
+
+module Make = functor (X:Map.OrderedType) -> struct
+  type key = X.t
+  type 'a t =
+        Empty
+      | Node of 'a t * key * 'a * 'a t * int
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let height = function
+        Empty -> 0
+      | Node(_,_,_,_,h) -> h
+
+    let create l x d r =
+      let hl = height l and hr = height r in
+      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let bal l x d r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Map.bal"
+        | Node(ll, lv, ld, lr, _) ->
+            if height ll >= height lr then
+              create ll lv ld (create lr x d r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Map.bal"
+              | Node(lrl, lrv, lrd, lrr, _)->
+                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Map.bal"
+        | Node(rl, rv, rd, rr, _) ->
+            if height rr >= height rl then
+              create (create l x d rl) rv rd rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Map.bal"
+              | Node(rll, rlv, rld, rlr, _) ->
+                  create (create l x d rll) rlv rld (create rlr rv rd rr)
+            end
+      end else
+        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let rec add x data = function
+        Empty ->
+          Node(Empty, x, data, Empty, 1)
+      | Node(l, v, d, r, h) ->
+          let c = X.compare x v in
+          if c = 0 then
+            Node(l, x, data, r, h)
+          else if c < 0 then
+            bal (add x data l) v d r
+          else
+            bal l v d (add x data r)
+
+    let rec find x = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          let c = X.compare x v in
+          if c = 0 then d
+          else find x (if c < 0 then l else r)
+
+    let rec mem x = function
+        Empty ->
+          false
+      | Node(l, v, d, r, _) ->
+          let c = X.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec min_binding = function
+        Empty -> raise Not_found
+      | Node(Empty, x, d, r, _) -> (x, d)
+      | Node(l, x, d, r, _) -> min_binding l
+
+    let rec remove_min_binding = function
+        Empty -> invalid_arg "Map.remove_min_elt"
+      | Node(Empty, x, d, r, _) -> r
+      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+    let merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) ->
+          let (x, d) = min_binding t2 in
+          bal t1 x d (remove_min_binding t2)
+
+    let rec remove x = function
+        Empty ->
+          Empty
+      | Node(l, v, d, r, h) ->
+          let c = X.compare x v in
+          if c = 0 then
+            merge l r
+          else if c < 0 then
+            bal (remove x l) v d r
+          else
+            bal l v d (remove x r)
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, d, r, _) ->
+          iter f l; f v d; iter f r
+
+    let rec map f = function
+        Empty               -> Empty
+      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+
+    (* Maintien de fold_right par compatibilité (changé en fold_left dans
+       ocaml-3.09.0) *)
+
+    let rec fold f m accu =
+      match m with
+        Empty -> accu
+      | Node(l, v, d, r, _) ->
+          fold f l (f v d (fold f r accu))
+
+(* Added with respect to ocaml standard library. *)
+
+    let dom m = fold (fun x _ acc -> x::acc) m []
+
+    let rng m = fold (fun _ y acc -> y::acc) m []
+
+    let to_list m = fold (fun x y acc -> (x,y)::acc) m []
+
+end
diff --git a/lib/fmap.mli b/lib/fmap.mli
new file mode 100644
index 00000000..c323b055
--- /dev/null
+++ b/lib/fmap.mli
@@ -0,0 +1,23 @@
+
+module Make : functor (X : Map.OrderedType) ->
+sig
+  type key = X.t
+  type 'a t
+
+val empty : 'a t
+val is_empty : 'a t -> bool
+val add : key -> 'a -> 'a t -> 'a t
+val find : key -> 'a t -> 'a
+val remove : key -> 'a t -> 'a t
+val mem :  key -> 'a t -> bool
+val iter : (key -> 'a -> unit) -> 'a t -> unit
+val map : ('a -> 'b) -> 'a t -> 'b t
+val fold : (key -> 'a -> 'c -> 'c) -> 'a t -> 'c -> 'c
+
+(* Additions with respect to ocaml standard library. *)
+
+val dom : 'a t -> key list
+val rng : 'a t -> 'a list
+val to_list : 'a t -> (key * 'a) list
+end
+ 
diff --git a/lib/fset.ml b/lib/fset.ml
new file mode 100644
index 00000000..567feaa7
--- /dev/null
+++ b/lib/fset.ml
@@ -0,0 +1,235 @@
+module Make = functor (X : Set.OrderedType) ->
+struct
+  
+  type elt = X.t
+    type t = Empty | Node of t * elt * t * int
+
+
+    (* Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+    let height = function
+        Empty -> 0
+      | Node(_, _, _, h) -> h
+
+    (* Creates a new node with left son l, value x and right son r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+    let create l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+    let bal l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Set.bal"
+        | Node(ll, lv, lr, _) ->
+            if height ll >= height lr then
+              create ll lv (create lr x r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrv, lrr, _)->
+                  create (create ll lv lrl) lrv (create lrr x r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Set.bal"
+        | Node(rl, rv, rr, _) ->
+            if height rr >= height rl then
+              create (create l x rl) rv rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlv, rlr, _) ->
+                  create (create l x rll) rlv (create rlr rv rr)
+            end
+      end else
+        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as bal, but repeat rebalancing until the final result
+       is balanced. *)
+
+    let rec join l x r =
+      match bal l x r with
+        Empty -> invalid_arg "Set.join"
+      | Node(l', x', r', _) as t' ->
+          let d = height l' - height r' in
+          if d < -2 or d > 2 then join l' x' r' else t'
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assumes | height l - height r | <= 2. *)
+
+    let rec merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          bal l1 v1 (bal (merge r1 l2) v2 r2)
+
+    (* Same as merge, but does not assume anything about l and r. *)
+
+    let rec concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          join l1 v1 (join (concat r1 l2) v2 r2)
+
+    (* Splitting *)
+
+    let rec split x = function
+        Empty ->
+          (Empty, None, Empty)
+      | Node(l, v, r, _) ->
+          let c = X.compare x v in
+          if c = 0 then (l, Some v, r)
+          else if c < 0 then
+            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
+          else
+            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
+
+    (* Implementation of the set operations *)
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let rec mem x = function
+        Empty -> false
+      | Node(l, v, r, _) ->
+          let c = X.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec add x = function
+        Empty -> Node(Empty, x, Empty, 1)
+      | Node(l, v, r, _) as t ->
+          let c = X.compare x v in
+          if c = 0 then t else
+          if c < 0 then bal (add x l) v r else bal l v (add x r)
+
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    let rec remove x = function
+        Empty -> Empty
+      | Node(l, v, r, _) ->
+          let c = X.compare x v in
+          if c = 0 then merge l r else
+          if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+
+    let rec union s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> t2
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          if h1 >= h2 then
+            if h2 = 1 then add v2 s1 else begin
+              let (l2, _, r2) = split v1 s2 in
+              join (union l1 l2) v1 (union r1 r2)
+            end
+          else
+            if h1 = 1 then add v1 s2 else begin
+              let (l1, _, r1) = split v2 s1 in
+              join (union l1 l2) v2 (union r1 r2)
+            end
+
+    let rec inter s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> Empty
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              concat (inter l1 l2) (inter r1 r2)
+          | (l2, Some _, r2) ->
+              join (inter l1 l2) v1 (inter r1 r2)
+
+    let rec diff s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              join (diff l1 l2) v1 (diff r1 r2)
+          | (l2, Some _, r2) ->
+              concat (diff l1 l2) (diff r1 r2)
+
+    let rec compare_aux l1 l2 =
+        match (l1, l2) with
+        ([], []) -> 0
+      | ([], _)  -> -1
+      | (_, []) -> 1
+      | (Empty :: t1, Empty :: t2) ->
+          compare_aux t1 t2
+      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+          let c = compare v1 v2 in
+          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
+      | (Node(l1, v1, r1, _) :: t1, t2) ->
+          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
+      | (t1, Node(l2, v2, r2, _) :: t2) ->
+          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+
+    let compare s1 s2 =
+      compare_aux [s1] [s2]
+
+    let equal s1 s2 =
+      compare s1 s2 = 0
+
+    let rec subset s1 s2 =
+      match (s1, s2) with
+        Empty, _ ->
+          true
+      | _, Empty ->
+          false
+      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+          let c = X.compare v1 v2 in
+          if c = 0 then
+            subset l1 l2 && subset r1 r2
+          else if c < 0 then
+            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+          else
+            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+    let rec fold f s accu =
+      match s with
+        Empty -> accu
+      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+    let rec elements_aux accu = function
+        Empty -> accu
+      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+    let elements s =
+      elements_aux [] s
+
+    let rec min_elt = function
+        Empty -> raise Not_found
+      | Node(Empty, v, r, _) -> v
+      | Node(l, v, r, _) -> min_elt l
+
+    let rec max_elt = function
+        Empty -> raise Not_found
+      | Node(l, v, Empty, _) -> v
+      | Node(l, v, r, _) -> max_elt r
+
+    let choose = min_elt
+end
diff --git a/lib/fset.mli b/lib/fset.mli
new file mode 100644
index 00000000..b1751d0b
--- /dev/null
+++ b/lib/fset.mli
@@ -0,0 +1,25 @@
+module Make : functor (X : Set.OrderedType) ->
+sig
+  type elt = X.t
+  type  t
+
+val empty :  t
+val is_empty :  t -> bool
+val mem : elt ->  t -> bool
+val add : elt ->  t ->  t
+val singleton : elt ->  t
+val remove : elt -> t -> t
+val union : t -> t -> t
+val inter : t -> t -> t
+val diff : t -> t -> t
+val compare : t -> t -> int
+val equal : t -> t -> bool
+val subset : t -> t -> bool
+val iter : ( elt -> unit) -> t -> unit
+val fold : (elt -> 'b -> 'b) -> t -> 'b -> 'b
+val cardinal : t -> int
+val elements : t -> elt list
+val min_elt : t -> elt
+val max_elt : t -> elt
+val choose : t -> elt
+end
diff --git a/lib/gmap.ml b/lib/gmap.ml
index 7a4cb56e..0c498fe7 100644
--- a/lib/gmap.ml
+++ b/lib/gmap.ml
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: gmap.ml 10250 2007-10-23 15:02:23Z aspiwack $ *)
+(* $Id$ *)
 
 (* Maps using the generic comparison function of ocaml. Code borrowed from
    the ocaml standard library (Copyright 1996, INRIA). *)
diff --git a/lib/gmap.mli b/lib/gmap.mli
index 5186cff4..ac1a9922 100644
--- a/lib/gmap.mli
+++ b/lib/gmap.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gmap.mli 10250 2007-10-23 15:02:23Z aspiwack $ i*)
+(*i $Id$ i*)
 
 (* Maps using the generic comparison function of ocaml. Same interface as
    the module [Map] from the ocaml standard library. *)
diff --git a/lib/gmapl.ml b/lib/gmapl.ml
index 0974909d..cec10d64 100644
--- a/lib/gmapl.ml
+++ b/lib/gmapl.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gmapl.ml 7780 2006-01-03 20:33:53Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 
@@ -32,4 +32,4 @@ let remove x y m =
   let l = Gmap.find x m in
   Gmap.add x (if List.mem y l then list_subtract l [y] else l) m
 
-  
+
diff --git a/lib/gmapl.mli b/lib/gmapl.mli
index db8f4358..5a5c9a2a 100644
--- a/lib/gmapl.mli
+++ b/lib/gmapl.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gmapl.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Maps from ['a] to lists of ['b]. *)
 
diff --git a/lib/gset.ml b/lib/gset.ml
index e90386a0..d39cb23f 100644
--- a/lib/gset.ml
+++ b/lib/gset.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gset.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 (* Sets using the generic comparison function of ocaml. Code borrowed from
    the ocaml standard library. *)
diff --git a/lib/gset.mli b/lib/gset.mli
index 5c794381..78fc61e1 100644
--- a/lib/gset.mli
+++ b/lib/gset.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gset.mli 10840 2008-04-23 21:29:34Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Sets using the generic comparison function of ocaml. Same interface as
    the module [Set] from the ocaml standard library. *)
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index 50be0ec4..921a4ed5 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hashcons.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 (* Hash consing of datastructures *)
 
@@ -19,7 +19,7 @@
  *   the hash-consing functions u provides.
  * [equal] is a comparison function. It is allowed to use physical equality
  *   on the sub-terms hash-consed by the hash_sub function.
- * [hash] is the hash function given to the Hashtbl.Make function 
+ * [hash] is the hash function given to the Hashtbl.Make function
  *
  * Note that this module type coerces to the argument of Hashtbl.Make.
  *)
@@ -106,7 +106,7 @@ let recursive_loop_hcons h u =
   let rec hrec visited x =
     if List.memq x visited then x
     else hc (hrec (x::visited),u) x
-  in 
+  in
   hrec []
 
 (* For 2 mutually recursive types *)
@@ -164,7 +164,7 @@ let comp_obj o1 o2 =
       else false
   else o1=o2
 
-let hash_obj hrec o = 
+let hash_obj hrec o =
   begin
     if tuple_p o then
       let n = Obj.size o in
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index f1e55ba1..243368d0 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hashcons.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Generic hash-consing. *)
 
diff --git a/lib/heap.ml b/lib/heap.ml
index 92aa0070..7ddb4a72 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heap.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 (*s Heaps *)
 
@@ -16,35 +16,35 @@ module type Ordered = sig
 end
 
 module type S =sig
-  
+
   (* Type of functional heaps *)
   type t
 
   (* Type of elements *)
   type elt
-    
+
   (* The empty heap *)
   val empty : t
-    
+
   (* [add x h] returns a new heap containing the elements of [h], plus [x];
      complexity $O(log(n))$ *)
   val add : elt -> t -> t
-    
+
   (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap]
      when [h] is empty; complexity $O(1)$ *)
   val maximum : t -> elt
-    
+
   (* [remove h] returns a new heap containing the elements of [h], except
-     the maximum of [h]; raises [EmptyHeap] when [h] is empty; 
-     complexity $O(log(n))$ *) 
+     the maximum of [h]; raises [EmptyHeap] when [h] is empty;
+     complexity $O(log(n))$ *)
   val remove : t -> t
-    
+
   (* usual iterators and combinators; elements are presented in
      arbitrary order *)
   val iter : (elt -> unit) -> t -> unit
-    
+
   val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    
+
 end
 
 exception EmptyHeap
@@ -54,9 +54,9 @@ exception EmptyHeap
 module Functional(X : Ordered) = struct
 
   (* Heaps are encoded as complete binary trees, i.e., binary trees
-     which are full expect, may be, on the bottom level where it is filled 
-     from the left. 
-     These trees also enjoy the heap property, namely the value of any node 
+     which are full expect, may be, on the bottom level where it is filled
+     from the left.
+     These trees also enjoy the heap property, namely the value of any node
      is greater or equal than those of its left and right subtrees.
 
      There are 4 kinds of complete binary trees, denoted by 4 constructors:
@@ -68,7 +68,7 @@ module Functional(X : Ordered) = struct
      and [PFP] for a partial tree with a full left subtree and a partial
      right subtree. *)
 
-  type t = 
+  type t =
     | Empty
     | FFF of t * X.t * t (* full    (full,    full) *)
     | PPF of t * X.t * t (* partial (partial, full) *)
@@ -78,7 +78,7 @@ module Functional(X : Ordered) = struct
   type elt = X.t
 
   let empty = Empty
- 
+
   (* smart constructors for insertion *)
   let p_f l x r = match l with
     | Empty | FFF _ -> PFF (l, x, r)
@@ -89,7 +89,7 @@ module Functional(X : Ordered) = struct
     | r -> PFP (l, x, r)
 
   let rec add x = function
-    | Empty -> 
+    | Empty ->
 	FFF (Empty, x, Empty)
     (* insertion to the left *)
     | FFF (l, y, r) | PPF (l, y, r) ->
@@ -113,9 +113,9 @@ module Functional(X : Ordered) = struct
     | r -> PFP (l, x, r)
 
   let rec remove = function
-    | Empty -> 
+    | Empty ->
 	raise EmptyHeap
-    | FFF (Empty, _, Empty) -> 
+    | FFF (Empty, _, Empty) ->
 	Empty
     | PFF (l, _, Empty) ->
 	l
@@ -124,30 +124,30 @@ module Functional(X : Ordered) = struct
         let xl = maximum l in
 	let xr = maximum r in
 	let l' = remove l in
-	if X.compare xl xr >= 0 then 
-	  p_f l' xl r 
-	else 
+	if X.compare xl xr >= 0 then
+	  p_f l' xl r
+	else
 	  p_f l' xr (add xl (remove r))
     (* remove on the right *)
     | FFF (l, x, r) | PFP (l, x, r) ->
         let xl = maximum l in
 	let xr = maximum r in
 	let r' = remove r in
-	if X.compare xl xr > 0 then 
+	if X.compare xl xr > 0 then
 	  pf_ (add xr (remove l)) xl r'
-	else 
+	else
 	  pf_ l xr r'
 
   let rec iter f = function
-    | Empty -> 
+    | Empty ->
 	()
-    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> 
+    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
 	iter f l; f x; iter f r
 
   let rec fold f h x0 = match h with
-    | Empty -> 
+    | Empty ->
 	x0
-    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> 
+    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
 	fold f l (fold f r (f x x0))
 
 end
diff --git a/lib/heap.mli b/lib/heap.mli
index d351edd0..777e356d 100644
--- a/lib/heap.mli
+++ b/lib/heap.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: heap.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Heaps *)
 
@@ -16,35 +16,35 @@ module type Ordered = sig
 end
 
 module type S =sig
-  
+
   (* Type of functional heaps *)
   type t
 
   (* Type of elements *)
   type elt
-    
+
   (* The empty heap *)
   val empty : t
-    
+
   (* [add x h] returns a new heap containing the elements of [h], plus [x];
      complexity $O(log(n))$ *)
   val add : elt -> t -> t
-    
+
   (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap]
      when [h] is empty; complexity $O(1)$ *)
   val maximum : t -> elt
-    
+
   (* [remove h] returns a new heap containing the elements of [h], except
-     the maximum of [h]; raises [EmptyHeap] when [h] is empty; 
-     complexity $O(log(n))$ *) 
+     the maximum of [h]; raises [EmptyHeap] when [h] is empty;
+     complexity $O(log(n))$ *)
   val remove : t -> t
-    
+
   (* usual iterators and combinators; elements are presented in
      arbitrary order *)
   val iter : (elt -> unit) -> t -> unit
-    
+
   val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    
+
 end
 
 exception EmptyHeap
diff --git a/lib/lib.mllib b/lib/lib.mllib
new file mode 100644
index 00000000..1743ce26
--- /dev/null
+++ b/lib/lib.mllib
@@ -0,0 +1,29 @@
+Pp_control
+Pp
+Compat
+Flags
+Segmenttree
+Unicodetable
+Util
+Bigint
+Hashcons
+Dyn
+System
+Envars
+Bstack
+Edit
+Gset
+Gmap
+Fset
+Fmap
+Tlm
+tries
+Gmapl
+Profile
+Explore
+Predicate
+Rtree
+Heap
+Option
+Dnet
+
diff --git a/lib/option.ml b/lib/option.ml
index 85efdd44..942fff48 100644
--- a/lib/option.ml
+++ b/lib/option.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: option.ml 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (** Module implementing basic combinators for OCaml option type.
    It tries follow closely the style of OCaml standard library.
@@ -20,7 +20,7 @@
 let has_some = function
   | None -> false
   | _ -> true
-  
+
 exception IsNone
 
 (** [get x] returns [y] where [x] is [Some y]. It raises IsNone
@@ -34,11 +34,11 @@ let make x = Some x
 
 (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *)
 let init b x =
-  if b then 
+  if b then
     Some x
   else
     None
-    
+
 
 (** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *)
 let flatten = function
@@ -48,7 +48,7 @@ let flatten = function
 
 (** {6 "Iterators"} ***)
 
-(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing 
+(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing
     otherwise. *)
 let iter f = function
   | Some y -> f y
@@ -60,7 +60,7 @@ 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. *)
-let iter2 f x y = 
+let iter2 f x y =
   match x,y with
   | Some z, Some w -> f z w
   | None,None -> ()
@@ -92,11 +92,17 @@ let fold_left2 f a x y =
   | _ -> raise Heterogeneous
 
 (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *)
-let fold_right f x a = 
+let fold_right f x a =
   match x with
   | Some y -> f y a
   | _ -> a
 
+(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *)
+let fold_map f a x =
+  match x with
+  | Some y -> let a, z = f a y in a, Some z
+  | _ -> a, None
+
 (** [cata f a x] is [a] if [x] is [None] and [f y] if [x] is [Some y]. *)
 let cata f a = function
   | Some c -> f c
@@ -112,20 +118,20 @@ let default a = function
 (** [lift f x] is the same as [map f x]. *)
 let lift = map
 
-(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and 
+(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and
     [None] otherwise. *)
 let lift_right f a = function
   | Some y -> Some (f a y)
   | _ -> None
 
-(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and 
+(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and
     [None] otherwise. *)
 let lift_left f x a =
   match x with
   | Some y -> Some (f y a)
   | _ -> None
 
-(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals 
+(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals
     [Some w]. It is [None] otherwise. *)
 let lift2 f x y =
   match x,y with
@@ -137,18 +143,18 @@ let lift2 f x y =
 (** {6 Operations with Lists} *)
 
 module List =
- struct 
+ struct
   (** [List.cons x l] equals [y::l] if [x] is [Some y] and [l] otherwise. *)
   let cons x l =
     match x with
     | Some y -> y::l
     | _ -> l
- 
+
   (** [List.flatten l] is the list of all the [y]s such that [l] contains
       [Some y] (in the same order). *)
   let rec flatten = function
     | x::l -> cons x (flatten l)
-    | [] -> [] 
+    | [] -> []
 end
 
 
@@ -157,8 +163,8 @@ end
 
 module Misc =
  struct
-  (** [Misc.compare f x y] lifts the equality predicate [f] to 
-      option types. That is, if both [x] and [y] are [None] then 
+  (** [Misc.compare f x y] lifts the equality predicate [f] to
+      option types. That is, if both [x] and [y] are [None] then
       it returns [true], if they are bothe [Some _] then
       [f] is called. Otherwise it returns [false]. *)
    let compare f x y =
diff --git a/lib/option.mli b/lib/option.mli
index 6fa89098..ef2e311a 100644
--- a/lib/option.mli
+++ b/lib/option.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: option.mli 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 (** Module implementing basic combinators for OCaml option type.
    It tries follow closely the style of OCaml standard library.
@@ -18,7 +18,7 @@
 (** [has_some x] is [true] if [x] is of the form [Some y] and [false]
     otherwise.  *)
 val has_some : 'a option -> bool
-  
+
 exception IsNone
 
 (** [get x] returns [y] where [x] is [Some y]. It raises IsNone
@@ -37,7 +37,7 @@ val flatten : 'a option option -> 'a option
 
 (** {6 "Iterators"} ***)
 
-(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing 
+(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing
     otherwise. *)
 val iter : ('a -> unit) -> 'a option -> unit
 
@@ -66,6 +66,9 @@ 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. *)
 val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
 
+(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *)
+val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option
+
 (** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
 val cata : ('a -> 'b) -> 'b -> 'a option -> 'b
 
@@ -77,15 +80,15 @@ val default : 'a -> 'a option -> 'a
 (** [lift] is the same as {!map}. *)
 val lift : ('a -> 'b) -> 'a option -> 'b option
 
-(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and 
+(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and
     [None] otherwise. *)
 val lift_right : ('a -> 'b -> 'c) -> 'a -> 'b option -> 'c option
 
-(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and 
+(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and
     [None] otherwise. *)
 val lift_left : ('a -> 'b -> 'c) -> 'a option -> 'b -> 'c option
 
-(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals 
+(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals
     [Some w]. It is [None] otherwise. *)
 val lift2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option
 
@@ -105,8 +108,8 @@ end
 (** {6 Miscelaneous Primitives} *)
 
 module Misc : sig
-  (** [Misc.compare f x y] lifts the equality predicate [f] to 
-      option types. That is, if both [x] and [y] are [None] then 
+  (** [Misc.compare f x y] lifts the equality predicate [f] to
+      option types. That is, if both [x] and [y] are [None] then
       it returns [true], if they are bothe [Some _] then
       [f] is called. Otherwise it returns [false]. *)
    val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
diff --git a/lib/pp.ml4 b/lib/pp.ml4
index 616302ac..b0948b0f 100644
--- a/lib/pp.ml4
+++ b/lib/pp.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pp.ml4 10803 2008-04-16 09:30:05Z cek $ *)
+(* $Id$ *)
 
 open Pp_control
 
@@ -19,7 +19,7 @@ let print_emacs = ref false
 let make_pp_emacs() = print_emacs:=true
 let make_pp_nonemacs() = print_emacs:=false
 
-(* The different kinds of blocks are: 
+(* The different kinds of blocks are:
    \begin{description}
    \item[hbox:] Horizontal block no line breaking;
    \item[vbox:] Vertical block each break leads to a new line;
@@ -31,9 +31,9 @@ let make_pp_nonemacs() = print_emacs:=false
       (except if no mark yet on the reste of the line)
    \end{description}
  *)
- 
+
 let comments = ref []
-  
+
 let rec split_com comacc acc pos = function
     [] -> comments := List.rev acc; comacc
   | ((b,e),c as com)::coms ->
@@ -132,7 +132,7 @@ let real r = str (string_of_float r)
 let bool b = str (string_of_bool b)
 let strbrk s =
   let rec aux p n =
-    if n < String.length s then 
+    if n < String.length s then
       if s.[n] = ' ' then
 	if p=n then [< spc (); aux (n+1) (n+1) >]
 	else [< str (String.sub s p (n-p)); spc (); aux (n+1) (n+1) >]
@@ -224,13 +224,13 @@ let rec pr_com ft s =
     | None -> ()
 
 (* pretty printing functions *)
-let pp_dirs ft = 
+let pp_dirs ft =
   let pp_open_box = function
     | Pp_hbox n   -> Format.pp_open_hbox ft ()
     | Pp_vbox n   -> Format.pp_open_vbox ft n
     | Pp_hvbox n  -> Format.pp_open_hvbox ft n
     | Pp_hovbox n -> Format.pp_open_hovbox ft n
-    | Pp_tbox     -> Format.pp_open_tbox ft () 
+    | Pp_tbox     -> Format.pp_open_tbox ft ()
   in
   let rec pp_cmd = function
     | Ppcmd_print(n,s)        ->
@@ -264,12 +264,12 @@ let pp_dirs ft =
     | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream
     | Ppdir_print_newline    ->
         com_brk ft; Format.pp_print_newline ft ()
-    | Ppdir_print_flush      -> Format.pp_print_flush ft () 
+    | Ppdir_print_flush      -> Format.pp_print_flush ft ()
   in
   fun dirstream ->
-    try  
+    try
       Stream.iter pp_dir dirstream; com_brk ft
-    with 
+    with
       | e -> Format.pp_print_flush ft () ; raise e
 
 
@@ -284,10 +284,10 @@ let ppcmds x = Ppdir_ppcmds x
 let emacs_warning_start_string = String.make 1 (Char.chr 254)
 let emacs_warning_end_string = String.make 1 (Char.chr 255)
 
-let warnstart() = 
+let warnstart() =
   if not !print_emacs then mt() else str emacs_warning_start_string
 
-let warnend() = 
+let warnend() =
   if not !print_emacs then mt() else str emacs_warning_end_string
 
 let warnbody strm =
diff --git a/lib/pp.mli b/lib/pp.mli
index 85b8345d..66d9bfa6 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pp.mli 10803 2008-04-16 09:30:05Z cek $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp_control
@@ -85,7 +85,7 @@ val warning_with : Format.formatter -> string -> unit
 val warn_with : Format.formatter -> std_ppcmds -> unit
 val pp_flush_with : Format.formatter -> unit -> unit
 
-val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit 
+val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit
 
 (*s Pretty-printing functions \emph{with flush}. *)
 
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index 7aa05975..ecc54649 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pp_control.ml 10917 2008-05-10 16:35:46Z herbelin $ *)
+(* $Id$ *)
 
 (* Parameters of pretty-printing *)
 
@@ -18,7 +18,7 @@ type pp_global_params = {
 
 (* Default parameters of pretty-printing *)
 
-let dflt_gp = { 
+let dflt_gp = {
   margin     = 78;
   max_indent = 50;
   max_depth  = 50;
@@ -26,7 +26,7 @@ let dflt_gp = {
 
 (* A deeper pretty-printer to print proof scripts *)
 
-let deep_gp = { 
+let deep_gp = {
   margin     = 78;
   max_indent = 50;
   max_depth  = 10000;
@@ -35,13 +35,13 @@ let deep_gp = {
 (* set_gp : Format.formatter -> pp_global_params -> unit
  * set the parameters of a formatter *)
 
-let set_gp ft gp = 
+let set_gp ft gp =
   Format.pp_set_margin ft gp.margin ;
   Format.pp_set_max_indent ft gp.max_indent ;
   Format.pp_set_max_boxes ft gp.max_depth ;
   Format.pp_set_ellipsis_text ft gp.ellipsis
 
-let set_dflt_gp ft = set_gp ft dflt_gp 
+let set_dflt_gp ft = set_gp ft dflt_gp
 
 let get_gp ft =
   { margin = Format.pp_get_margin ft ();
@@ -56,7 +56,7 @@ type 'a pp_formatter_params = {
   fp_output : out_channel ;
   fp_output_function : string -> int -> int -> unit ;
   fp_flush_function : unit -> unit }
-				
+
 (* Output functions for stdout and stderr *)
 
 let std_fp = {
@@ -69,7 +69,7 @@ let err_fp = {
   fp_output_function = output stderr;
   fp_flush_function = (fun () -> flush stderr) }
 
-(* with_fp : 'a pp_formatter_params -> Format.formatter 
+(* with_fp : 'a pp_formatter_params -> Format.formatter
  * returns of formatter for given formatter functions *)
 
 let with_fp fp =
@@ -83,7 +83,7 @@ let with_output_to ch =
   let ft = with_fp { fp_output = ch ;
       	             fp_output_function = (output ch) ;
 	             fp_flush_function = (fun () -> flush ch) } in
-  set_gp ft deep_gp; 
+  set_gp ft deep_gp;
   ft
 
 let std_ft = ref Format.std_formatter
@@ -105,5 +105,7 @@ let set_depth_boxes v =
 
 let get_margin () = Some (Format.pp_get_margin !std_ft ())
 let set_margin v =
-  Format.pp_set_margin !std_ft (match v with None -> default_margin | Some v -> v)
+  let v = match v with None -> default_margin | Some v -> v in
+  Format.pp_set_margin !std_ft v;
+  Format.pp_set_margin !deep_ft v
 
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index f245d942..5c481b89 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.mli
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pp_control.mli 10917 2008-05-10 16:35:46Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Parameters of pretty-printing. *)
 
-type pp_global_params = { 
+type pp_global_params = {
   margin : int;
   max_indent : int;
   max_depth : int;
@@ -25,7 +25,7 @@ val get_gp : Format.formatter -> pp_global_params
 
 (*s Output functions of pretty-printing. *)
 
-type 'a pp_formatter_params = { 
+type 'a pp_formatter_params = {
   fp_output : out_channel;
   fp_output_function : string -> int -> int -> unit;
   fp_flush_function : unit -> unit }
diff --git a/lib/predicate.ml b/lib/predicate.ml
index 93b74463..af66c0f2 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (************************************************************************)
 
-(* $Id: predicate.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 (* Sets over ordered types *)
 
@@ -44,7 +44,7 @@ module type S =
 module Make(Ord: OrderedType) =
   struct
     module EltSet = Set.Make(Ord)
- 
+
     (* when bool is false, the denoted set is the complement of
        the given set *)
     type elt = Ord.t
diff --git a/lib/predicate.mli b/lib/predicate.mli
index 85596fea..41d5399b 100644
--- a/lib/predicate.mli
+++ b/lib/predicate.mli
@@ -1,5 +1,5 @@
 
-(*i $Id: predicate.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Module [Pred]: sets over infinite ordered types with complement. *)
 
diff --git a/lib/profile.ml b/lib/profile.ml
index dd7e977e..7bf71d0b 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: profile.ml 7538 2005-11-08 17:14:52Z herbelin $ *)
+(* $Id$ *)
 
 open Gc
 
@@ -17,8 +17,7 @@ let float_of_time t = float_of_int t /. 100.
 let time_of_float f = int_of_float (f *. 100.)
 
 let get_time () =
-  let  {Unix.tms_utime = ut;Unix.tms_stime = st} = Unix.times () in
-  time_of_float (ut +. st)
+  time_of_float (Sys.time ())
 
 (* Since ocaml 3.01, gc statistics are in float *)
 let get_alloc () =
@@ -113,12 +112,12 @@ let ajoute_to_list ((name,n) as e) l =
   with Not_found -> e::l
 
 let magic = 1249
-  
+
 let merge_profile filename (curr_table, curr_outside, curr_total as new_data) =
   let (old_table, old_outside, old_total) =
-    try 
+    try
       let c = open_in filename in
-      if input_binary_int c <> magic 
+      if input_binary_int c <> magic
       then Printf.printf "Incompatible recording file: %s\n" filename;
       let old_data = input_value c in
       close_in c;
@@ -134,7 +133,7 @@ let merge_profile filename (curr_table, curr_outside, curr_total as new_data) =
   begin
     (try
        let c =
-	 open_out_gen 
+	 open_out_gen
            [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in
        output_binary_int c magic;
        output_value c updated_data;
@@ -157,7 +156,10 @@ let merge_profile filename (curr_table, curr_outside, curr_total as new_data) =
 (* Unix measure of time is approximative and shoitt delays are often
    unperceivable; therefore, total times are measured in one (big)
    step to avoid rounding errors and to get the best possible
-   approximation *)
+   approximation.
+   Note: Sys.time is the same as:
+     Unix.(let x = times () in x.tms_utime +. x.tms_stime)
+ *)
 
 (*
 ----------        start profile for f1
@@ -186,7 +188,7 @@ overheadA|        ...
      real 2' |        ...
     ----------        end 2nd f2
     overheadC|        ...
-    ---------- [2'w2]  2nd call to get_time for 2nd f2 
+    ---------- [2'w2]  2nd call to get_time for 2nd f2
   overheadD|        ...
   ----------        end profile for f2
    real 1  |        ...
@@ -242,7 +244,7 @@ let time_overhead_A_D () =
       ajoute_totalloc p (e.totalloc-.totalloc0);
       p.intcount <- p.intcount + e.intcount - intcount0 + 1;
       p.immcount <- p.immcount + 1;
-      if not (p==e) then 
+      if not (p==e) then
 	(match !dummy_stack with [] -> assert false | _::s -> stack := s);
       dummy_last_alloc := get_alloc ()
   done;
@@ -279,7 +281,7 @@ let compute_alloc lo = lo /. (float_of_int word_length)
 
 let format_profile (table, outside, total) =
   print_newline ();
-  Printf.printf 
+  Printf.printf
     "%-23s  %9s %9s %10s %10s %10s\n"
     "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls ";
   let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in
@@ -293,7 +295,7 @@ let format_profile (table, outside, total) =
       e.owncount e.intcount)
     l;
   Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f        %6d\n"
-    "others" 
+    "others"
     (float_of_time outside.owntime) (float_of_time outside.tottime)
     (compute_alloc outside.ownalloc)
     (compute_alloc outside.totalloc)
@@ -305,7 +307,7 @@ let format_profile (table, outside, total) =
     (compute_alloc total.ownalloc)
     (compute_alloc total.totalloc);
   Printf.printf
-    "Time in seconds and allocation in words (1 word = %d bytes)\n" 
+    "Time in seconds and allocation in words (1 word = %d bytes)\n"
     word_length
 
 let recording_file = ref ""
@@ -319,7 +321,7 @@ let adjust_time ov_bc ov_ad e =
      tottime = e.tottime - int_of_float (abcd_all +. bc_imm);
      owntime = e.owntime - int_of_float (ad_imm +. bc_imm) }
 
-let close_profile print = 
+let close_profile print =
   let dw = spent_alloc () in
   let t = get_time () in
   match !stack with
@@ -390,7 +392,7 @@ let profile1 e f a =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -404,7 +406,7 @@ let profile1 e f a =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -432,7 +434,7 @@ let profile2 e f a b =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -446,7 +448,7 @@ let profile2 e f a b =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -474,7 +476,7 @@ let profile3 e f a b c =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -488,7 +490,7 @@ let profile3 e f a b c =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -516,7 +518,7 @@ let profile4 e f a b c d =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -530,7 +532,7 @@ let profile4 e f a b c d =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -558,7 +560,7 @@ let profile5 e f a b c d g =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -572,7 +574,7 @@ let profile5 e f a b c d g =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -600,7 +602,7 @@ let profile6 e f a b c d g h =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -614,7 +616,7 @@ let profile6 e f a b c d g h =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -642,7 +644,7 @@ let profile7 e f a b c d g h i =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
@@ -656,7 +658,7 @@ let profile7 e f a b c d g h i =
     ajoute_totalloc p (e.totalloc -. totalloc0);
     p.intcount <- p.intcount + e.intcount - intcount0 + 1;
     p.immcount <- p.immcount + 1;
-    if not (p==e) then 
+    if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     raise exn
@@ -664,22 +666,20 @@ let profile7 e f a b c d g h i =
 (* Some utilities to compute the logical and physical sizes and depth
    of ML objects *)
 
-open Obj
-
 let c = ref 0
 let s = ref 0
 let b = ref 0
 let m = ref 0
 
 let rec obj_stats d t =
-  if is_int t then m := max d !m
-  else if tag t >= no_scan_tag then
-    if tag t = string_tag then
-      (c := !c + size t; b := !b + 1; m := max d !m)
-    else if tag t = double_tag then
+  if Obj.is_int t then m := max d !m
+  else if Obj.tag t >= Obj.no_scan_tag then
+    if Obj.tag t = Obj.string_tag then
+      (c := !c + Obj.size t; b := !b + 1; m := max d !m)
+    else if Obj.tag t = Obj.double_tag then
       (s := !s + 2; b := !b + 1; m := max d !m)
-    else if tag t = double_array_tag then
-      (s := !s + 2 * size t; b := !b + 1; m := max d !m)
+    else if Obj.tag t = Obj.double_array_tag then
+      (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
     else (b := !b + 1; m := max d !m)
   else
     let n = Obj.size t in
@@ -687,7 +687,7 @@ let rec obj_stats d t =
     block_stats (d + 1) (n - 1) t
 
 and block_stats d i t =
-  if i >= 0 then (obj_stats d (field t i); block_stats d (i-1) t)
+  if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
 
 let obj_stats a =
   c := 0; s:= 0; b:= 0; m:= 0;
@@ -695,24 +695,24 @@ let obj_stats a =
   (!c, !s + !b, !m)
 
 module H = Hashtbl.Make(
-  struct 
-    type t = Obj.t 
-    let equal = (==) 
-    let hash o = Hashtbl.hash (magic o : int)
+  struct
+    type t = Obj.t
+    let equal = (==)
+    let hash o = Hashtbl.hash (Obj.magic o : int)
   end)
 
 let tbl = H.create 13
 
 let rec obj_shared_size s t =
-  if is_int t then s
+  if Obj.is_int t then s
   else if H.mem tbl t then s
   else begin
     H.add tbl t ();
     let n = Obj.size t in
-    if tag t >= no_scan_tag then
-      if tag t = string_tag then (c := !c + n; s + 1)
-      else if tag t = double_tag then s + 3
-      else if tag t = double_array_tag then s + 2 * n + 1
+    if Obj.tag t >= Obj.no_scan_tag then
+      if Obj.tag t = Obj.string_tag then (c := !c + n; s + 1)
+      else if Obj.tag t = Obj.double_tag then s + 3
+      else if Obj.tag t = Obj.double_array_tag then s + 2 * n + 1
       else s + 1
     else
       block_shared_size (s + n + 1) (n - 1) t
@@ -720,7 +720,7 @@ let rec obj_shared_size s t =
 
 and block_shared_size s i t =
   if i < 0 then s
-  else block_shared_size (obj_shared_size s (field t i)) (i-1) t
+  else block_shared_size (obj_shared_size s (Obj.field t i)) (i-1) t
 
 let obj_shared_size a =
   H.clear tbl;
diff --git a/lib/profile.mli b/lib/profile.mli
index 0937e9e3..9466ad30 100644
--- a/lib/profile.mli
+++ b/lib/profile.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: profile.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*s This program is a small time and allocation profiler for Objective Caml *)
 
@@ -14,8 +14,7 @@
 
 (* Adapted from Christophe Raffalli *)
 
-(* To use it, link it with the program you want to profile (do not forget
-"-cclib -lunix -custom unix.cma" among the link options).
+(* To use it, link it with the program you want to profile.
 
 To trace a function "f" you first need to get a key for it by using :
 
@@ -49,7 +48,7 @@ let g = profile gkey g';;
 Before the program quits, you should call "print_profile ();;". It
 produces a result of the following kind:
 
-Function name              Own time Total time  Own alloc Tot. alloc     Calls 
+Function name              Own time Total time  Own alloc Tot. alloc     Calls
 f                            0.28      0.47        116        116      5      4
 h                            0.19      0.19          0          0      4      0
 g                            0.00      0.00          0          0      0      0
@@ -65,7 +64,7 @@ Est. overhead/total          0.00      0.47       2752       3260
   the number of calls to profiled functions inside the scope of the
   current function
 
-Remarks: 
+Remarks:
 
 - If a function has a polymorphic type, you need to supply it with at
   least one argument as in "let f a = profile1 fkey f a;;" (instead of
@@ -103,7 +102,7 @@ val profile6 :
     -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g
 val profile7 :
   profile_key ->
-  ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) 
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h)
     -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h
 
 
diff --git a/lib/refutpat.ml4 b/lib/refutpat.ml4
new file mode 100644
index 00000000..7c6801a8
--- /dev/null
+++ b/lib/refutpat.ml4
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
+
+open Pcaml
+
+(** * Non-irrefutable patterns
+
+    This small camlp4 extension creates a "let*" variant of the "let"
+    syntax that allow the use of a non-exhaustive pattern. The typical
+    usage is:
+
+      let* x::l = foo in ...
+
+    when foo is already known to be non-empty. This way, no warnings by ocamlc.
+    A Failure is raised if the pattern doesn't match the expression.
+*)
+
+
+EXTEND
+ expr:
+   [[ "let"; "*"; p = patt; "="; e1 = expr; "in"; e2 = expr ->
+       <:expr< match $e1$ with
+	        [ $p$ -> $e2$
+                | _ -> failwith "Refutable pattern failed"
+                ] >> ]];
+END
diff --git a/lib/rtree.ml b/lib/rtree.ml
index 4742a90d..ec50e556 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rtree.ml 10690 2008-03-18 13:30:04Z barras $ i*)
+(*i $Id$ i*)
 
 open Util
 
@@ -53,7 +53,7 @@ let rec subst_rtree_rec depth sub = function
 
 let subst_rtree sub t = subst_rtree_rec 0 [|sub|] t
 
-(* To avoid looping, we must check that every body introduces a node 
+(* To avoid looping, we must check that every body introduces a node
    or a parameter *)
 let rec expand = function
   | Rec(j,defs) ->
@@ -81,17 +81,17 @@ the last one should be accepted
 *)
 
 (* Tree destructors, expanding loops when necessary *)
-let dest_param t = 
+let dest_param t =
   match expand t with
       Param (i,j) -> (i,j)
     | _ -> failwith "Rtree.dest_param"
 
-let dest_node t = 
+let dest_node t =
   match expand t with
       Node (l,sons) -> (l,sons)
     | _ -> failwith "Rtree.dest_node"
 
-let is_node t = 
+let is_node t =
   match expand t with
       Node _ -> true
     | _ -> false
@@ -104,13 +104,13 @@ let rec map f t = match t with
 
 let rec smartmap f t = match t with
     Param _ -> t
-  | Node (a,sons) -> 
+  | Node (a,sons) ->
       let a'=f a and sons' = Util.array_smartmap (map f) sons in
 	if a'==a && sons'==sons then
 	  t
 	else
 	  Node (a',sons')
-  | Rec(j,defs) -> 
+  | Rec(j,defs) ->
       let defs' = Util.array_smartmap (map f) defs in
 	if defs'==defs then
 	  t
@@ -175,11 +175,11 @@ let rec pp_tree prl t =
     | Node(lab,[||]) -> hov 2 (str"("++prl lab++str")")
     | Node(lab,v) ->
         hov 2 (str"("++prl lab++str","++brk(1,0)++
-               Util.prvect_with_sep Util.pr_coma (pp_tree prl) v++str")")
+               Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str")")
     | Rec(i,v) ->
         if Array.length v = 0 then str"Rec{}"
         else if Array.length v = 1 then
           hov 2 (str"Rec{"++pp_tree prl v.(0)++str"}")
         else
           hov 2 (str"Rec{"++int i++str","++brk(1,0)++
-                 Util.prvect_with_sep Util.pr_coma (pp_tree prl) v++str"}")
+                 Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str"}")
diff --git a/lib/rtree.mli b/lib/rtree.mli
index b61e6965..de5a9aa3 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rtree.mli 10690 2008-03-18 13:30:04Z barras $ i*)
+(*i $Id$ i*)
 
 (* Type of regular tree with nodes labelled by values of type 'a *)
 (* The implementation uses de Bruijn indices, so binding capture
    is avoided by the lift operator (see example below) *)
-type 'a t 
+type 'a t
 
 (* Building trees *)
 
@@ -40,7 +40,7 @@ val mk_rec_calls : int -> 'a t array
 val mk_rec   : 'a t array -> 'a t array
 
 (* [lift k t] increases of [k] the free parameters of [t]. Needed
-   to avoid captures when a tree appears under [mk_rec] *) 
+   to avoid captures when a tree appears under [mk_rec] *)
 val lift : int -> 'a t -> 'a t
 
 val is_node : 'a t -> bool
diff --git a/lib/segmenttree.ml b/lib/segmenttree.ml
new file mode 100644
index 00000000..2a7f9df0
--- /dev/null
+++ b/lib/segmenttree.ml
@@ -0,0 +1,131 @@
+(** This module is a very simple implementation of "segment trees".
+
+    A segment tree of type ['a t] represents a mapping from a union of
+    disjoint segments to some values of type 'a. 
+*)
+
+(** Misc. functions. *)
+let list_iteri f l =
+  let rec loop i = function
+    | [] -> ()
+    | x :: xs -> f i x; loop (i + 1) xs
+  in
+    loop 0 l
+
+let log2 x = log x /. log 2.
+
+let log2n x = int_of_float (ceil (log2 (float_of_int x))) 
+
+(** We focus on integers but this module can be generalized. *)
+type elt = int
+
+(** A value of type [domain] is interpreted differently given its position 
+    in the tree. On internal nodes, a domain represents the set of 
+    integers which are _not_ in the set of keys handled by the tree. On 
+    leaves, a domain represents the st of integers which are in the set of 
+    keys. *)
+type domain = 
+    (** On internal nodes, a domain [Interval (a, b)] represents 
+	the interval [a + 1; b - 1]. On leaves, it represents [a; b]. 
+	We always have [a] <= [b]. *)
+  | Interval of elt * elt
+      (** On internal node or root, a domain [Universe] represents all
+	  the integers. When the tree is not a trivial root,
+	  [Universe] has no interpretation on leaves. (The lookup
+	  function should never reach the leaves.) *)
+  | Universe
+
+(** We use an array to store the almost complete tree. This array
+    contains at least one element. *)
+type 'a t = (domain * 'a option) array
+
+(** The root is the first item of the array. *)
+let is_root i = (i = 0)
+
+(** Standard layout for left child. *)
+let left_child i = 2 * i + 1
+
+(** Standard layout for right child. *)
+let right_child i = 2 * i + 2
+
+(** Extract the annotation of a node, be it internal or a leaf. *)
+let value_of i t = match t.(i) with (_, Some x) -> x | _ -> raise Not_found
+
+(** Initialize the array to store [n] leaves. *)
+let create n init = 
+  Array.make (1 lsl (log2n n + 1) - 1) init
+
+(** Make a complete interval tree from a list of disjoint segments. 
+    Precondition : the segments must be sorted. *)
+let make segments = 
+  let nsegments = List.length segments in
+  let tree = create nsegments (Universe, None) in 
+  let leaves_offset = (1 lsl (log2n nsegments)) - 1 in
+
+    (** The algorithm proceeds in two steps using an intermediate tree
+	to store minimum and maximum of each subtree as annotation of
+	the node. *)
+
+    (** We start from leaves: the last level of the tree is initialized
+	with the given segments... *)
+    list_iteri 
+      (fun i ((start, stop), value) ->
+	 let k = leaves_offset + i in
+	 let i = Interval (start, stop) in
+	   tree.(k) <- (i, Some i))
+      segments;
+    (** ... the remaining leaves are initialized with neutral information. *)
+    for k = leaves_offset + nsegments to Array.length tree -1 do 
+      tree.(k) <- (Universe, Some Universe)
+    done;
+    
+    (** We traverse the tree bottom-up and compute the interval and
+	annotation associated to each node from the annotations of its
+	children. *)
+    for k = leaves_offset - 1 downto 0 do
+      let node, annotation = 
+	match value_of (left_child k) tree, value_of (right_child k) tree with
+	  | Interval (left_min, left_max), Interval (right_min, right_max) ->
+	      (Interval (left_max, right_min), Interval (left_min, right_max))
+	  | Interval (min, max), Universe -> 
+	      (Interval (max, max), Interval (min, max))
+	  | Universe, Universe -> Universe, Universe
+	  | Universe, _ -> assert false
+      in
+	tree.(k) <- (node, Some annotation)
+    done;
+
+    (** Finally, annotation are replaced with the image related to each leaf. *)
+    let final_tree = 
+      Array.mapi (fun i (segment, value) -> (segment, None)) tree
+    in
+      list_iteri 
+	(fun i ((start, stop), value) -> 
+	   final_tree.(leaves_offset + i) 
+	   <- (Interval (start, stop), Some value))
+	segments;      
+      final_tree
+
+(** [lookup k t] looks for an image for key [k] in the interval tree [t]. 
+    Raise [Not_found] if it fails. *)
+let lookup k t = 
+  let i = ref 0 in 
+    while (snd t.(!i) = None) do
+      match fst t.(!i) with
+	| Interval (start, stop) -> 
+	    if k <= start then i := left_child !i
+	    else if k >= stop then i:= right_child !i 
+	    else raise Not_found
+	| Universe -> raise Not_found
+    done;
+    match fst t.(!i) with
+      | Interval (start, stop) -> 
+	  if k >= start && k <= stop then
+	    match snd t.(!i) with 
+	      | Some v -> v
+	      | None -> assert false
+	  else 
+	    raise Not_found
+      | Universe -> assert false
+      
+
diff --git a/lib/segmenttree.mli b/lib/segmenttree.mli
new file mode 100644
index 00000000..4aea13e9
--- /dev/null
+++ b/lib/segmenttree.mli
@@ -0,0 +1,20 @@
+(** This module is a very simple implementation of "segment trees".
+
+    A segment tree of type ['a t] represents a mapping from a union of
+    disjoint segments to some values of type 'a. 
+*)
+
+(** A mapping from a union of disjoint segments to some values of type ['a]. *)
+type 'a t
+
+(** [make [(i1, j1), v1; (i2, j2), v2; ...] creates a mapping that
+    associates to every integer [x] the value [v1] if [i1 <= x <= j1],
+    [v2] if [i2 <= x <= j2], and so one. 
+    Precondition: the segments must be sorted. *)
+val make : ((int * int) * 'a) list -> 'a t
+
+(** [lookup k t] looks for an image for key [k] in the interval tree [t]. 
+    Raise [Not_found] if it fails. *)
+val lookup : int -> 'a t -> 'a
+
+
diff --git a/lib/system.ml b/lib/system.ml
index 3fa32ef8..6eb4e751 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: system.ml 13175 2010-06-22 06:28:37Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,7 +15,7 @@ open Unix
 (* Expanding shell variables and home-directories *)
 
 let safe_getenv_def var def =
-  try 
+  try
     Sys.getenv var
   with Not_found ->
     warning ("Environment variable "^var^" not found: using '"^def^"' .");
@@ -38,7 +38,7 @@ let rec expand_macros s i =
   let l = String.length s in
   if i=l then s else
     match s.[i] with
-      | '$' -> 
+      | '$' ->
 	  let n = expand_atom s (i+1) in
 	  let v = safe_getenv (String.sub s (i+1) (n-i-1)) in
 	  let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
@@ -64,7 +64,7 @@ let physical_path_of_string s = s
 let string_of_physical_path p = p
 
 (* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p = 
+let rec remove_path_dot p =
   let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
   let n = String.length curdir in
   if String.length p > n && String.sub p 0 n = curdir then
@@ -82,7 +82,7 @@ let strip_path p =
 
 let canonical_path_name p =
   let current = Sys.getcwd () in
-  try 
+  try
     Sys.chdir p;
     let p' = Sys.getcwd () in
     Sys.chdir current;
@@ -100,7 +100,7 @@ let skipped_dirnames = ref ["CVS"; "_darcs"]
 
 let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
 
-let ok_dirname f = 
+let ok_dirname f =
   f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) &&
   try ignore (check_ident f); true with _ -> false
 
@@ -114,7 +114,7 @@ let all_subdirs ~unix_path:root =
 	let f = readdir dirh in
 	if ok_dirname f then
 	  let file = Filename.concat dir f in
-	  try 
+	  try
 	    if (stat file).st_kind = S_DIR then begin
 	      let newrel = rel@[f] in
 	      add file newrel;
@@ -132,14 +132,14 @@ let where_in_path ?(warn=true) path filename =
   let rec search = function
     | lpe :: rem ->
 	let f = Filename.concat lpe filename in
-	  if Sys.file_exists f 
+	  if Sys.file_exists f
 	  then (lpe,f) :: search rem
 	  else search rem
     | [] -> [] in
   let rec check_and_warn l =
     match l with
       | [] -> raise Not_found
-      | (lpe, f) :: l' -> 
+      | (lpe, f) :: l' ->
 	  if warn & l' <> [] then
 	    msg_warning
 	      (str filename ++ str " has been found in" ++ spc () ++
@@ -159,11 +159,11 @@ let find_file_in_path ?(warn=true) paths filename =
     else
       errorlabstrm "System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename))
-  else 
+  else
     try where_in_path ~warn paths filename
     with Not_found ->
       errorlabstrm "System.find_file_in_path"
-	(hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ 
+	(hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++
 		str "on loadpath"))
 
 let is_in_path lpath filename =
@@ -192,40 +192,40 @@ let marshal_in ch =
 exception Bad_magic_number of string
 
 let raw_extern_intern magic suffix =
-  let extern_state name = 
+  let extern_state name =
     let filename = make_suffix name suffix in
     let channel = open_trapping_failure filename in
     output_binary_int channel magic;
     filename,channel
-  and intern_state filename = 
+  and intern_state filename =
     let channel = open_in_bin filename in
     if input_binary_int channel <> magic then
       raise (Bad_magic_number filename);
     channel
-  in 
+  in
   (extern_state,intern_state)
 
 let extern_intern ?(warn=true) magic suffix =
   let (raw_extern,raw_intern) = raw_extern_intern magic suffix in
-  let extern_state name val_0 = 
+  let extern_state name val_0 =
     try
       let (filename,channel) = raw_extern name in
       try
         marshal_out channel val_0;
         close_out channel
-      with e -> 
+      with e ->
 	begin try_remove filename; raise e end
     with Sys_error s -> error ("System error: " ^ s)
-  and intern_state paths name = 
+  and intern_state paths name =
     try
       let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in
       let channel = raw_intern filename in
       let v = marshal_in channel in
-      close_in channel; 
+      close_in channel;
       v
-    with Sys_error s -> 
+    with Sys_error s ->
       error("System error: " ^ s)
-  in 
+  in
   (extern_state,intern_state)
 
 let with_magic_number_check f a =
@@ -244,14 +244,14 @@ let connect writefun readfun com =
   let ch_to_in,ch_to_out =
     try open_in tmp_to, open_out tmp_to
     with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in
-  let ch_from_in,ch_from_out = 
+  let ch_from_in,ch_from_out =
     try open_in tmp_from, open_out tmp_from
     with Sys_error s ->
-      close_out ch_to_out; close_in ch_to_in; 
+      close_out ch_to_out; close_in ch_to_in;
       error ("Cannot set connection from "^com^"("^s^")") in
   writefun ch_to_out;
   close_out ch_to_out;
-  let pid = 
+  let pid =
     let ch_to' = Unix.descr_of_in_channel ch_to_in in
     let ch_from' = Unix.descr_of_out_channel ch_from_out in
     try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout
@@ -279,32 +279,52 @@ let run_command converter f c =
   let n = ref 0 in
   let ne = ref 0 in
 
-  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; 
+  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
     !n+ !ne <> 0
-  do 
-    let r = converter (String.sub buff 0 !n) in 
+  do
+    let r = converter (String.sub buff 0 !n) in
     f r;
     Buffer.add_string result r;
-    let r = converter (String.sub buffe 0 !ne) in 
+    let r = converter (String.sub buffe 0 !ne) in
     f r;
-    Buffer.add_string result r 
+    Buffer.add_string result r
   done;
   (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
 
+let path_separator = if Sys.os_type = "Unix" then ':' else ';'
+
+let search_exe_in_path exe =
+  try
+    let path = Sys.getenv "PATH" in
+    let n = String.length path in
+    let rec aux i =
+      if i < n then
+        let j =
+          try String.index_from path i path_separator
+          with Not_found -> n
+        in
+        let dir = String.sub path i (j-i) in
+        let exe = Filename.concat dir exe in
+        if Sys.file_exists exe then Some exe else aux (i+1)
+      else
+        None
+    in aux 0
+  with Not_found -> None
+
 (* Time stamps. *)
 
 type time = float * float * float
 
-let process_time () = 
+let process_time () =
   let t = times ()  in
   (t.tms_utime, t.tms_stime)
 
-let get_time () = 
+let get_time () =
   let t = times ()  in
   (time(), t.tms_utime, t.tms_stime)
 
 let time_difference (t1,_,_) (t2,_,_) = t2 -. t1
-			      
+
 let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) =
   real (stopreal -. startreal) ++ str " secs " ++
   str "(" ++
diff --git a/lib/system.mli b/lib/system.mli
index 426a00df..2b8057f8 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: system.mli 13175 2010-06-22 06:28:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*s Files and load paths. Load path entries remember the original root
     given by the user. For efficiency, we keep the full path (field
@@ -48,26 +48,28 @@ val marshal_in : in_channel -> 'a
 
 exception Bad_magic_number of string
 
-val raw_extern_intern : int -> string -> 
+val raw_extern_intern : int -> string ->
   (string -> string * out_channel) * (string -> in_channel)
 
-val extern_intern : ?warn:bool -> int -> string -> 
+val extern_intern : ?warn:bool -> int -> string ->
   (string -> 'a -> unit) * (load_path -> string -> 'a)
 
 val with_magic_number_check : ('a -> 'b) -> 'a -> 'b
 
 (*s Sending/receiving once with external executable *)
 
-val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a 
+val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a
 
 (*s [run_command converter f com] launches command [com], and returns
     the contents of stdout and stderr that have been processed with
     [converter]; the processed contents of stdout and stderr is also
     passed to [f] *)
 
-val run_command : (string -> string) -> (string -> unit) -> string -> 
+val run_command : (string -> string) -> (string -> unit) -> string ->
   Unix.process_status * string
 
+val search_exe_in_path : string -> string option
+
 (*s Time stamps. *)
 
 type time
diff --git a/lib/tlm.ml b/lib/tlm.ml
index 2939e91a..1c1483ad 100644
--- a/lib/tlm.ml
+++ b/lib/tlm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tlm.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 type ('a,'b) t = Node of 'b Gset.t * ('a, ('a,'b) t) Gmap.t
 
@@ -23,41 +23,41 @@ let in_dom (Node (_,m)) lbl = Gmap.mem lbl m
 let is_empty_node (Node(a,b)) = (Gset.elements a = []) & (Gmap.to_list b = [])
 
 let assure_arc m lbl =
-  if Gmap.mem lbl m then 
+  if Gmap.mem lbl m then
     m
-  else 
+  else
     Gmap.add lbl (Node (Gset.empty,Gmap.empty)) m
 
 let cleanse_arcs (Node (hereset,m)) =
-  let l = Gmap.rng m in 
+  let l = Gmap.rng m in
   Node(hereset, if List.for_all is_empty_node l then Gmap.empty else m)
 
 let rec at_path f (Node (hereset,m)) = function
-  | [] -> 
+  | [] ->
       cleanse_arcs (Node(f hereset,m))
   | h::t ->
-      let m = assure_arc m h in 
+      let m = assure_arc m h in
       cleanse_arcs (Node(hereset,
                          Gmap.add h (at_path f (Gmap.find h m) t) m))
 
 let add tm (path,v) =
   at_path (fun hereset -> Gset.add v hereset) tm path
-    
+
 let rmv tm (path,v) =
   at_path (fun hereset -> Gset.remove v hereset) tm path
 
-let app f tlm = 
+let app f tlm =
   let rec apprec pfx (Node(hereset,m)) =
-    let path = List.rev pfx in 
+    let path = List.rev pfx in
     Gset.iter (fun v -> f(path,v)) hereset;
     Gmap.iter (fun l tm -> apprec (l::pfx) tm) m
-  in 
+  in
   apprec [] tlm
-    
-let to_list tlm = 
+
+let to_list tlm =
   let rec torec pfx (Node(hereset,m)) =
-    let path = List.rev pfx in 
+    let path = List.rev pfx in
     List.flatten((List.map (fun v -> (path,v)) (Gset.elements hereset))::
 		 (List.map (fun (l,tm) -> torec (l::pfx) tm) (Gmap.to_list m)))
-  in 
+  in
   torec [] tlm
diff --git a/lib/tlm.mli b/lib/tlm.mli
index 982bb5ed..54eb1759 100644
--- a/lib/tlm.mli
+++ b/lib/tlm.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tlm.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Tries. This module implements a data structure [('a,'b) t] mapping lists
    of values of type ['a] to sets (as lists) of values of type ['b]. *)
diff --git a/lib/tries.ml b/lib/tries.ml
new file mode 100644
index 00000000..fdde344c
--- /dev/null
+++ b/lib/tries.ml
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+
+
+module Make = 
+  functor (X : Set.OrderedType) ->
+    functor (Y : Map.OrderedType) ->
+struct
+  module T_dom = Fset.Make(X) 
+  module T_codom = Fmap.Make(Y) 
+
+  type t = Node of T_dom.t * t T_codom.t
+
+  let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m []
+
+  let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m []
+
+  let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m []
+
+  let empty = Node (T_dom.empty, T_codom.empty)
+
+  let map (Node (_,m)) lbl = T_codom.find lbl m
+
+  let xtract (Node (hereset,_)) = T_dom.elements hereset
+    
+  let dom (Node (_,m)) = codom_dom m
+
+  let in_dom (Node (_,m)) lbl = T_codom.mem lbl m
+
+  let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = [])
+
+let assure_arc m lbl =
+  if T_codom.mem lbl m then 
+    m
+  else 
+    T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m
+
+let cleanse_arcs (Node (hereset,m)) =
+  let l = codom_rng m in 
+  Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m)
+
+let rec at_path f (Node (hereset,m)) = function
+  | [] -> 
+      cleanse_arcs (Node(f hereset,m))
+  | h::t ->
+      let m = assure_arc m h in 
+      cleanse_arcs (Node(hereset,
+                         T_codom.add h (at_path f (T_codom.find h m) t) m))
+
+let add tm (path,v) =
+  at_path (fun hereset -> T_dom.add v hereset) tm path
+    
+let rmv tm (path,v) =
+  at_path (fun hereset -> T_dom.remove v hereset) tm path
+
+let app f tlm = 
+  let rec apprec pfx (Node(hereset,m)) =
+    let path = List.rev pfx in 
+    T_dom.iter (fun v -> f(path,v)) hereset;
+    T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
+  in 
+  apprec [] tlm
+    
+let to_list tlm = 
+  let rec torec pfx (Node(hereset,m)) =
+    let path = List.rev pfx in 
+    List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset))::
+		 (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m)))
+  in 
+  torec [] tlm
+
+end
diff --git a/lib/tries.mli b/lib/tries.mli
new file mode 100644
index 00000000..342c81ec
--- /dev/null
+++ b/lib/tries.mli
@@ -0,0 +1,34 @@
+
+
+
+
+
+module Make :
+  functor (X : Set.OrderedType) ->
+    functor (Y : Map.OrderedType) ->
+sig
+     
+  type t 
+    
+  val empty : t
+      
+  (* Work on labels, not on paths. *)
+
+  val map : t -> Y.t -> t
+
+  val xtract : t -> X.t list
+    
+  val dom : t -> Y.t list
+
+  val in_dom : t -> Y.t -> bool
+
+  (* Work on paths, not on labels. *)
+
+  val add : t -> Y.t list * X.t -> t
+  
+  val rmv : t -> Y.t list * X.t -> t 
+
+  val app : ((Y.t list * X.t) -> unit) -> t -> unit
+    
+  val to_list : t -> (Y.t list * X.t) list
+end
diff --git a/lib/unicodetable.ml b/lib/unicodetable.ml
new file mode 100644
index 00000000..f4e978d6
--- /dev/null
+++ b/lib/unicodetable.ml
@@ -0,0 +1,2619 @@
+
+(** Unicode tables generated from Camomile. *)
+
+(* Letter, Uppercase *)
+let lu = [
+  (0x00041,0x0005A);
+  (0x000C0,0x000D6);
+  (0x000D8,0x000DE);
+  (0x00100,0x00100);
+  (0x00102,0x00102);
+  (0x00104,0x00104);
+  (0x00106,0x00106);
+  (0x00108,0x00108);
+  (0x0010A,0x0010A);
+  (0x0010C,0x0010C);
+  (0x0010E,0x0010E);
+  (0x00110,0x00110);
+  (0x00112,0x00112);
+  (0x00114,0x00114);
+  (0x00116,0x00116);
+  (0x00118,0x00118);
+  (0x0011A,0x0011A);
+  (0x0011C,0x0011C);
+  (0x0011E,0x0011E);
+  (0x00120,0x00120);
+  (0x00122,0x00122);
+  (0x00124,0x00124);
+  (0x00126,0x00126);
+  (0x00128,0x00128);
+  (0x0012A,0x0012A);
+  (0x0012C,0x0012C);
+  (0x0012E,0x0012E);
+  (0x00130,0x00130);
+  (0x00132,0x00132);
+  (0x00134,0x00134);
+  (0x00136,0x00136);
+  (0x00139,0x00139);
+  (0x0013B,0x0013B);
+  (0x0013D,0x0013D);
+  (0x0013F,0x0013F);
+  (0x00141,0x00141);
+  (0x00143,0x00143);
+  (0x00145,0x00145);
+  (0x00147,0x00147);
+  (0x0014A,0x0014A);
+  (0x0014C,0x0014C);
+  (0x0014E,0x0014E);
+  (0x00150,0x00150);
+  (0x00152,0x00152);
+  (0x00154,0x00154);
+  (0x00156,0x00156);
+  (0x00158,0x00158);
+  (0x0015A,0x0015A);
+  (0x0015C,0x0015C);
+  (0x0015E,0x0015E);
+  (0x00160,0x00160);
+  (0x00162,0x00162);
+  (0x00164,0x00164);
+  (0x00166,0x00166);
+  (0x00168,0x00168);
+  (0x0016A,0x0016A);
+  (0x0016C,0x0016C);
+  (0x0016E,0x0016E);
+  (0x00170,0x00170);
+  (0x00172,0x00172);
+  (0x00174,0x00174);
+  (0x00176,0x00176);
+  (0x00178,0x00179);
+  (0x0017B,0x0017B);
+  (0x0017D,0x0017D);
+  (0x00181,0x00182);
+  (0x00184,0x00184);
+  (0x00186,0x00187);
+  (0x00189,0x0018B);
+  (0x0018E,0x00191);
+  (0x00193,0x00194);
+  (0x00196,0x00198);
+  (0x0019C,0x0019D);
+  (0x0019F,0x001A0);
+  (0x001A2,0x001A2);
+  (0x001A4,0x001A4);
+  (0x001A6,0x001A7);
+  (0x001A9,0x001A9);
+  (0x001AC,0x001AC);
+  (0x001AE,0x001AF);
+  (0x001B1,0x001B3);
+  (0x001B5,0x001B5);
+  (0x001B7,0x001B8);
+  (0x001BC,0x001BC);
+  (0x001C4,0x001C4);
+  (0x001C7,0x001C7);
+  (0x001CA,0x001CA);
+  (0x001CD,0x001CD);
+  (0x001CF,0x001CF);
+  (0x001D1,0x001D1);
+  (0x001D3,0x001D3);
+  (0x001D5,0x001D5);
+  (0x001D7,0x001D7);
+  (0x001D9,0x001D9);
+  (0x001DB,0x001DB);
+  (0x001DE,0x001DE);
+  (0x001E0,0x001E0);
+  (0x001E2,0x001E2);
+  (0x001E4,0x001E4);
+  (0x001E6,0x001E6);
+  (0x001E8,0x001E8);
+  (0x001EA,0x001EA);
+  (0x001EC,0x001EC);
+  (0x001EE,0x001EE);
+  (0x001F1,0x001F1);
+  (0x001F4,0x001F4);
+  (0x001F6,0x001F8);
+  (0x001FA,0x001FA);
+  (0x001FC,0x001FC);
+  (0x001FE,0x001FE);
+  (0x00200,0x00200);
+  (0x00202,0x00202);
+  (0x00204,0x00204);
+  (0x00206,0x00206);
+  (0x00208,0x00208);
+  (0x0020A,0x0020A);
+  (0x0020C,0x0020C);
+  (0x0020E,0x0020E);
+  (0x00210,0x00210);
+  (0x00212,0x00212);
+  (0x00214,0x00214);
+  (0x00216,0x00216);
+  (0x00218,0x00218);
+  (0x0021A,0x0021A);
+  (0x0021C,0x0021C);
+  (0x0021E,0x0021E);
+  (0x00220,0x00220);
+  (0x00222,0x00222);
+  (0x00224,0x00224);
+  (0x00226,0x00226);
+  (0x00228,0x00228);
+  (0x0022A,0x0022A);
+  (0x0022C,0x0022C);
+  (0x0022E,0x0022E);
+  (0x00230,0x00230);
+  (0x00232,0x00232);
+  (0x00386,0x00386);
+  (0x00388,0x0038A);
+  (0x0038C,0x0038C);
+  (0x0038E,0x0038F);
+  (0x00391,0x003A1);
+  (0x003A3,0x003AB);
+  (0x003D2,0x003D4);
+  (0x003D8,0x003D8);
+  (0x003DA,0x003DA);
+  (0x003DC,0x003DC);
+  (0x003DE,0x003DE);
+  (0x003E0,0x003E0);
+  (0x003E2,0x003E2);
+  (0x003E4,0x003E4);
+  (0x003E6,0x003E6);
+  (0x003E8,0x003E8);
+  (0x003EA,0x003EA);
+  (0x003EC,0x003EC);
+  (0x003EE,0x003EE);
+  (0x003F4,0x003F4);
+  (0x00400,0x0042F);
+  (0x00460,0x00460);
+  (0x00462,0x00462);
+  (0x00464,0x00464);
+  (0x00466,0x00466);
+  (0x00468,0x00468);
+  (0x0046A,0x0046A);
+  (0x0046C,0x0046C);
+  (0x0046E,0x0046E);
+  (0x00470,0x00470);
+  (0x00472,0x00472);
+  (0x00474,0x00474);
+  (0x00476,0x00476);
+  (0x00478,0x00478);
+  (0x0047A,0x0047A);
+  (0x0047C,0x0047C);
+  (0x0047E,0x0047E);
+  (0x00480,0x00480);
+  (0x0048A,0x0048A);
+  (0x0048C,0x0048C);
+  (0x0048E,0x0048E);
+  (0x00490,0x00490);
+  (0x00492,0x00492);
+  (0x00494,0x00494);
+  (0x00496,0x00496);
+  (0x00498,0x00498);
+  (0x0049A,0x0049A);
+  (0x0049C,0x0049C);
+  (0x0049E,0x0049E);
+  (0x004A0,0x004A0);
+  (0x004A2,0x004A2);
+  (0x004A4,0x004A4);
+  (0x004A6,0x004A6);
+  (0x004A8,0x004A8);
+  (0x004AA,0x004AA);
+  (0x004AC,0x004AC);
+  (0x004AE,0x004AE);
+  (0x004B0,0x004B0);
+  (0x004B2,0x004B2);
+  (0x004B4,0x004B4);
+  (0x004B6,0x004B6);
+  (0x004B8,0x004B8);
+  (0x004BA,0x004BA);
+  (0x004BC,0x004BC);
+  (0x004BE,0x004BE);
+  (0x004C0,0x004C1);
+  (0x004C3,0x004C3);
+  (0x004C5,0x004C5);
+  (0x004C7,0x004C7);
+  (0x004C9,0x004C9);
+  (0x004CB,0x004CB);
+  (0x004CD,0x004CD);
+  (0x004D0,0x004D0);
+  (0x004D2,0x004D2);
+  (0x004D4,0x004D4);
+  (0x004D6,0x004D6);
+  (0x004D8,0x004D8);
+  (0x004DA,0x004DA);
+  (0x004DC,0x004DC);
+  (0x004DE,0x004DE);
+  (0x004E0,0x004E0);
+  (0x004E2,0x004E2);
+  (0x004E4,0x004E4);
+  (0x004E6,0x004E6);
+  (0x004E8,0x004E8);
+  (0x004EA,0x004EA);
+  (0x004EC,0x004EC);
+  (0x004EE,0x004EE);
+  (0x004F0,0x004F0);
+  (0x004F2,0x004F2);
+  (0x004F4,0x004F4);
+  (0x004F8,0x004F8);
+  (0x00500,0x00500);
+  (0x00502,0x00502);
+  (0x00504,0x00504);
+  (0x00506,0x00506);
+  (0x00508,0x00508);
+  (0x0050A,0x0050A);
+  (0x0050C,0x0050C);
+  (0x0050E,0x0050E);
+  (0x00531,0x00556);
+  (0x010A0,0x010C5);
+  (0x01E00,0x01E00);
+  (0x01E02,0x01E02);
+  (0x01E04,0x01E04);
+  (0x01E06,0x01E06);
+  (0x01E08,0x01E08);
+  (0x01E0A,0x01E0A);
+  (0x01E0C,0x01E0C);
+  (0x01E0E,0x01E0E);
+  (0x01E10,0x01E10);
+  (0x01E12,0x01E12);
+  (0x01E14,0x01E14);
+  (0x01E16,0x01E16);
+  (0x01E18,0x01E18);
+  (0x01E1A,0x01E1A);
+  (0x01E1C,0x01E1C);
+  (0x01E1E,0x01E1E);
+  (0x01E20,0x01E20);
+  (0x01E22,0x01E22);
+  (0x01E24,0x01E24);
+  (0x01E26,0x01E26);
+  (0x01E28,0x01E28);
+  (0x01E2A,0x01E2A);
+  (0x01E2C,0x01E2C);
+  (0x01E2E,0x01E2E);
+  (0x01E30,0x01E30);
+  (0x01E32,0x01E32);
+  (0x01E34,0x01E34);
+  (0x01E36,0x01E36);
+  (0x01E38,0x01E38);
+  (0x01E3A,0x01E3A);
+  (0x01E3C,0x01E3C);
+  (0x01E3E,0x01E3E);
+  (0x01E40,0x01E40);
+  (0x01E42,0x01E42);
+  (0x01E44,0x01E44);
+  (0x01E46,0x01E46);
+  (0x01E48,0x01E48);
+  (0x01E4A,0x01E4A);
+  (0x01E4C,0x01E4C);
+  (0x01E4E,0x01E4E);
+  (0x01E50,0x01E50);
+  (0x01E52,0x01E52);
+  (0x01E54,0x01E54);
+  (0x01E56,0x01E56);
+  (0x01E58,0x01E58);
+  (0x01E5A,0x01E5A);
+  (0x01E5C,0x01E5C);
+  (0x01E5E,0x01E5E);
+  (0x01E60,0x01E60);
+  (0x01E62,0x01E62);
+  (0x01E64,0x01E64);
+  (0x01E66,0x01E66);
+  (0x01E68,0x01E68);
+  (0x01E6A,0x01E6A);
+  (0x01E6C,0x01E6C);
+  (0x01E6E,0x01E6E);
+  (0x01E70,0x01E70);
+  (0x01E72,0x01E72);
+  (0x01E74,0x01E74);
+  (0x01E76,0x01E76);
+  (0x01E78,0x01E78);
+  (0x01E7A,0x01E7A);
+  (0x01E7C,0x01E7C);
+  (0x01E7E,0x01E7E);
+  (0x01E80,0x01E80);
+  (0x01E82,0x01E82);
+  (0x01E84,0x01E84);
+  (0x01E86,0x01E86);
+  (0x01E88,0x01E88);
+  (0x01E8A,0x01E8A);
+  (0x01E8C,0x01E8C);
+  (0x01E8E,0x01E8E);
+  (0x01E90,0x01E90);
+  (0x01E92,0x01E92);
+  (0x01E94,0x01E94);
+  (0x01EA0,0x01EA0);
+  (0x01EA2,0x01EA2);
+  (0x01EA4,0x01EA4);
+  (0x01EA6,0x01EA6);
+  (0x01EA8,0x01EA8);
+  (0x01EAA,0x01EAA);
+  (0x01EAC,0x01EAC);
+  (0x01EAE,0x01EAE);
+  (0x01EB0,0x01EB0);
+  (0x01EB2,0x01EB2);
+  (0x01EB4,0x01EB4);
+  (0x01EB6,0x01EB6);
+  (0x01EB8,0x01EB8);
+  (0x01EBA,0x01EBA);
+  (0x01EBC,0x01EBC);
+  (0x01EBE,0x01EBE);
+  (0x01EC0,0x01EC0);
+  (0x01EC2,0x01EC2);
+  (0x01EC4,0x01EC4);
+  (0x01EC6,0x01EC6);
+  (0x01EC8,0x01EC8);
+  (0x01ECA,0x01ECA);
+  (0x01ECC,0x01ECC);
+  (0x01ECE,0x01ECE);
+  (0x01ED0,0x01ED0);
+  (0x01ED2,0x01ED2);
+  (0x01ED4,0x01ED4);
+  (0x01ED6,0x01ED6);
+  (0x01ED8,0x01ED8);
+  (0x01EDA,0x01EDA);
+  (0x01EDC,0x01EDC);
+  (0x01EDE,0x01EDE);
+  (0x01EE0,0x01EE0);
+  (0x01EE2,0x01EE2);
+  (0x01EE4,0x01EE4);
+  (0x01EE6,0x01EE6);
+  (0x01EE8,0x01EE8);
+  (0x01EEA,0x01EEA);
+  (0x01EEC,0x01EEC);
+  (0x01EEE,0x01EEE);
+  (0x01EF0,0x01EF0);
+  (0x01EF2,0x01EF2);
+  (0x01EF4,0x01EF4);
+  (0x01EF6,0x01EF6);
+  (0x01EF8,0x01EF8);
+  (0x01F08,0x01F0F);
+  (0x01F18,0x01F1D);
+  (0x01F28,0x01F2F);
+  (0x01F38,0x01F3F);
+  (0x01F48,0x01F4D);
+  (0x01F59,0x01F59);
+  (0x01F5B,0x01F5B);
+  (0x01F5D,0x01F5D);
+  (0x01F5F,0x01F5F);
+  (0x01F68,0x01F6F);
+  (0x01FB8,0x01FBB);
+  (0x01FC8,0x01FCB);
+  (0x01FD8,0x01FDB);
+  (0x01FE8,0x01FEC);
+  (0x01FF8,0x01FFB);
+  (0x02102,0x02102);
+  (0x02107,0x02107);
+  (0x0210B,0x0210D);
+  (0x02110,0x02112);
+  (0x02115,0x02115);
+  (0x02119,0x0211D);
+  (0x02124,0x02124);
+  (0x02126,0x02126);
+  (0x02128,0x02128);
+  (0x0212A,0x0212D);
+  (0x02130,0x02131);
+  (0x02133,0x02133);
+  (0x0213E,0x0213F);
+  (0x02145,0x02145);
+  (0x0FF21,0x0FF3A);
+  (0x10400,0x10425);
+  (0x1D400,0x1D419);
+  (0x1D434,0x1D44D);
+  (0x1D468,0x1D481);
+  (0x1D49C,0x1D49C);
+  (0x1D49E,0x1D49F);
+  (0x1D4A2,0x1D4A2);
+  (0x1D4A5,0x1D4A6);
+  (0x1D4A9,0x1D4AC);
+  (0x1D4AE,0x1D4B5);
+  (0x1D4D0,0x1D4E9);
+  (0x1D504,0x1D505);
+  (0x1D507,0x1D50A);
+  (0x1D50D,0x1D514);
+  (0x1D516,0x1D51C);
+  (0x1D538,0x1D539);
+  (0x1D53B,0x1D53E);
+  (0x1D540,0x1D544);
+  (0x1D546,0x1D546);
+  (0x1D54A,0x1D550);
+  (0x1D56C,0x1D585);
+  (0x1D5A0,0x1D5B9);
+  (0x1D5D4,0x1D5ED);
+  (0x1D608,0x1D621);
+  (0x1D63C,0x1D655);
+  (0x1D670,0x1D689);
+  (0x1D6A8,0x1D6C0);
+  (0x1D6E2,0x1D6FA);
+  (0x1D71C,0x1D734);
+  (0x1D756,0x1D76E);
+  (0x1D790,0x1D7A8)
+]
+(* Letter, Lowercase *)
+let ll = [
+  (0x00061,0x0007A);
+  (0x000AA,0x000AA);
+  (0x000B5,0x000B5);
+  (0x000BA,0x000BA);
+  (0x000DF,0x000F6);
+  (0x000F8,0x000FF);
+  (0x00101,0x00101);
+  (0x00103,0x00103);
+  (0x00105,0x00105);
+  (0x00107,0x00107);
+  (0x00109,0x00109);
+  (0x0010B,0x0010B);
+  (0x0010D,0x0010D);
+  (0x0010F,0x0010F);
+  (0x00111,0x00111);
+  (0x00113,0x00113);
+  (0x00115,0x00115);
+  (0x00117,0x00117);
+  (0x00119,0x00119);
+  (0x0011B,0x0011B);
+  (0x0011D,0x0011D);
+  (0x0011F,0x0011F);
+  (0x00121,0x00121);
+  (0x00123,0x00123);
+  (0x00125,0x00125);
+  (0x00127,0x00127);
+  (0x00129,0x00129);
+  (0x0012B,0x0012B);
+  (0x0012D,0x0012D);
+  (0x0012F,0x0012F);
+  (0x00131,0x00131);
+  (0x00133,0x00133);
+  (0x00135,0x00135);
+  (0x00137,0x00138);
+  (0x0013A,0x0013A);
+  (0x0013C,0x0013C);
+  (0x0013E,0x0013E);
+  (0x00140,0x00140);
+  (0x00142,0x00142);
+  (0x00144,0x00144);
+  (0x00146,0x00146);
+  (0x00148,0x00149);
+  (0x0014B,0x0014B);
+  (0x0014D,0x0014D);
+  (0x0014F,0x0014F);
+  (0x00151,0x00151);
+  (0x00153,0x00153);
+  (0x00155,0x00155);
+  (0x00157,0x00157);
+  (0x00159,0x00159);
+  (0x0015B,0x0015B);
+  (0x0015D,0x0015D);
+  (0x0015F,0x0015F);
+  (0x00161,0x00161);
+  (0x00163,0x00163);
+  (0x00165,0x00165);
+  (0x00167,0x00167);
+  (0x00169,0x00169);
+  (0x0016B,0x0016B);
+  (0x0016D,0x0016D);
+  (0x0016F,0x0016F);
+  (0x00171,0x00171);
+  (0x00173,0x00173);
+  (0x00175,0x00175);
+  (0x00177,0x00177);
+  (0x0017A,0x0017A);
+  (0x0017C,0x0017C);
+  (0x0017E,0x00180);
+  (0x00183,0x00183);
+  (0x00185,0x00185);
+  (0x00188,0x00188);
+  (0x0018C,0x0018D);
+  (0x00192,0x00192);
+  (0x00195,0x00195);
+  (0x00199,0x0019B);
+  (0x0019E,0x0019E);
+  (0x001A1,0x001A1);
+  (0x001A3,0x001A3);
+  (0x001A5,0x001A5);
+  (0x001A8,0x001A8);
+  (0x001AA,0x001AB);
+  (0x001AD,0x001AD);
+  (0x001B0,0x001B0);
+  (0x001B4,0x001B4);
+  (0x001B6,0x001B6);
+  (0x001B9,0x001BA);
+  (0x001BD,0x001BF);
+  (0x001C6,0x001C6);
+  (0x001C9,0x001C9);
+  (0x001CC,0x001CC);
+  (0x001CE,0x001CE);
+  (0x001D0,0x001D0);
+  (0x001D2,0x001D2);
+  (0x001D4,0x001D4);
+  (0x001D6,0x001D6);
+  (0x001D8,0x001D8);
+  (0x001DA,0x001DA);
+  (0x001DC,0x001DD);
+  (0x001DF,0x001DF);
+  (0x001E1,0x001E1);
+  (0x001E3,0x001E3);
+  (0x001E5,0x001E5);
+  (0x001E7,0x001E7);
+  (0x001E9,0x001E9);
+  (0x001EB,0x001EB);
+  (0x001ED,0x001ED);
+  (0x001EF,0x001F0);
+  (0x001F3,0x001F3);
+  (0x001F5,0x001F5);
+  (0x001F9,0x001F9);
+  (0x001FB,0x001FB);
+  (0x001FD,0x001FD);
+  (0x001FF,0x001FF);
+  (0x00201,0x00201);
+  (0x00203,0x00203);
+  (0x00205,0x00205);
+  (0x00207,0x00207);
+  (0x00209,0x00209);
+  (0x0020B,0x0020B);
+  (0x0020D,0x0020D);
+  (0x0020F,0x0020F);
+  (0x00211,0x00211);
+  (0x00213,0x00213);
+  (0x00215,0x00215);
+  (0x00217,0x00217);
+  (0x00219,0x00219);
+  (0x0021B,0x0021B);
+  (0x0021D,0x0021D);
+  (0x0021F,0x0021F);
+  (0x00223,0x00223);
+  (0x00225,0x00225);
+  (0x00227,0x00227);
+  (0x00229,0x00229);
+  (0x0022B,0x0022B);
+  (0x0022D,0x0022D);
+  (0x0022F,0x0022F);
+  (0x00231,0x00231);
+  (0x00233,0x00233);
+  (0x00250,0x002AD);
+  (0x00390,0x00390);
+  (0x003AC,0x003CE);
+  (0x003D0,0x003D1);
+  (0x003D5,0x003D7);
+  (0x003D9,0x003D9);
+  (0x003DB,0x003DB);
+  (0x003DD,0x003DD);
+  (0x003DF,0x003DF);
+  (0x003E1,0x003E1);
+  (0x003E3,0x003E3);
+  (0x003E5,0x003E5);
+  (0x003E7,0x003E7);
+  (0x003E9,0x003E9);
+  (0x003EB,0x003EB);
+  (0x003ED,0x003ED);
+  (0x003EF,0x003F3);
+  (0x003F5,0x003F5);
+  (0x00430,0x0045F);
+  (0x00461,0x00461);
+  (0x00463,0x00463);
+  (0x00465,0x00465);
+  (0x00467,0x00467);
+  (0x00469,0x00469);
+  (0x0046B,0x0046B);
+  (0x0046D,0x0046D);
+  (0x0046F,0x0046F);
+  (0x00471,0x00471);
+  (0x00473,0x00473);
+  (0x00475,0x00475);
+  (0x00477,0x00477);
+  (0x00479,0x00479);
+  (0x0047B,0x0047B);
+  (0x0047D,0x0047D);
+  (0x0047F,0x0047F);
+  (0x00481,0x00481);
+  (0x0048B,0x0048B);
+  (0x0048D,0x0048D);
+  (0x0048F,0x0048F);
+  (0x00491,0x00491);
+  (0x00493,0x00493);
+  (0x00495,0x00495);
+  (0x00497,0x00497);
+  (0x00499,0x00499);
+  (0x0049B,0x0049B);
+  (0x0049D,0x0049D);
+  (0x0049F,0x0049F);
+  (0x004A1,0x004A1);
+  (0x004A3,0x004A3);
+  (0x004A5,0x004A5);
+  (0x004A7,0x004A7);
+  (0x004A9,0x004A9);
+  (0x004AB,0x004AB);
+  (0x004AD,0x004AD);
+  (0x004AF,0x004AF);
+  (0x004B1,0x004B1);
+  (0x004B3,0x004B3);
+  (0x004B5,0x004B5);
+  (0x004B7,0x004B7);
+  (0x004B9,0x004B9);
+  (0x004BB,0x004BB);
+  (0x004BD,0x004BD);
+  (0x004BF,0x004BF);
+  (0x004C2,0x004C2);
+  (0x004C4,0x004C4);
+  (0x004C6,0x004C6);
+  (0x004C8,0x004C8);
+  (0x004CA,0x004CA);
+  (0x004CC,0x004CC);
+  (0x004CE,0x004CE);
+  (0x004D1,0x004D1);
+  (0x004D3,0x004D3);
+  (0x004D5,0x004D5);
+  (0x004D7,0x004D7);
+  (0x004D9,0x004D9);
+  (0x004DB,0x004DB);
+  (0x004DD,0x004DD);
+  (0x004DF,0x004DF);
+  (0x004E1,0x004E1);
+  (0x004E3,0x004E3);
+  (0x004E5,0x004E5);
+  (0x004E7,0x004E7);
+  (0x004E9,0x004E9);
+  (0x004EB,0x004EB);
+  (0x004ED,0x004ED);
+  (0x004EF,0x004EF);
+  (0x004F1,0x004F1);
+  (0x004F3,0x004F3);
+  (0x004F5,0x004F5);
+  (0x004F9,0x004F9);
+  (0x00501,0x00501);
+  (0x00503,0x00503);
+  (0x00505,0x00505);
+  (0x00507,0x00507);
+  (0x00509,0x00509);
+  (0x0050B,0x0050B);
+  (0x0050D,0x0050D);
+  (0x0050F,0x0050F);
+  (0x00561,0x00587);
+  (0x01E01,0x01E01);
+  (0x01E03,0x01E03);
+  (0x01E05,0x01E05);
+  (0x01E07,0x01E07);
+  (0x01E09,0x01E09);
+  (0x01E0B,0x01E0B);
+  (0x01E0D,0x01E0D);
+  (0x01E0F,0x01E0F);
+  (0x01E11,0x01E11);
+  (0x01E13,0x01E13);
+  (0x01E15,0x01E15);
+  (0x01E17,0x01E17);
+  (0x01E19,0x01E19);
+  (0x01E1B,0x01E1B);
+  (0x01E1D,0x01E1D);
+  (0x01E1F,0x01E1F);
+  (0x01E21,0x01E21);
+  (0x01E23,0x01E23);
+  (0x01E25,0x01E25);
+  (0x01E27,0x01E27);
+  (0x01E29,0x01E29);
+  (0x01E2B,0x01E2B);
+  (0x01E2D,0x01E2D);
+  (0x01E2F,0x01E2F);
+  (0x01E31,0x01E31);
+  (0x01E33,0x01E33);
+  (0x01E35,0x01E35);
+  (0x01E37,0x01E37);
+  (0x01E39,0x01E39);
+  (0x01E3B,0x01E3B);
+  (0x01E3D,0x01E3D);
+  (0x01E3F,0x01E3F);
+  (0x01E41,0x01E41);
+  (0x01E43,0x01E43);
+  (0x01E45,0x01E45);
+  (0x01E47,0x01E47);
+  (0x01E49,0x01E49);
+  (0x01E4B,0x01E4B);
+  (0x01E4D,0x01E4D);
+  (0x01E4F,0x01E4F);
+  (0x01E51,0x01E51);
+  (0x01E53,0x01E53);
+  (0x01E55,0x01E55);
+  (0x01E57,0x01E57);
+  (0x01E59,0x01E59);
+  (0x01E5B,0x01E5B);
+  (0x01E5D,0x01E5D);
+  (0x01E5F,0x01E5F);
+  (0x01E61,0x01E61);
+  (0x01E63,0x01E63);
+  (0x01E65,0x01E65);
+  (0x01E67,0x01E67);
+  (0x01E69,0x01E69);
+  (0x01E6B,0x01E6B);
+  (0x01E6D,0x01E6D);
+  (0x01E6F,0x01E6F);
+  (0x01E71,0x01E71);
+  (0x01E73,0x01E73);
+  (0x01E75,0x01E75);
+  (0x01E77,0x01E77);
+  (0x01E79,0x01E79);
+  (0x01E7B,0x01E7B);
+  (0x01E7D,0x01E7D);
+  (0x01E7F,0x01E7F);
+  (0x01E81,0x01E81);
+  (0x01E83,0x01E83);
+  (0x01E85,0x01E85);
+  (0x01E87,0x01E87);
+  (0x01E89,0x01E89);
+  (0x01E8B,0x01E8B);
+  (0x01E8D,0x01E8D);
+  (0x01E8F,0x01E8F);
+  (0x01E91,0x01E91);
+  (0x01E93,0x01E93);
+  (0x01E95,0x01E9B);
+  (0x01EA1,0x01EA1);
+  (0x01EA3,0x01EA3);
+  (0x01EA5,0x01EA5);
+  (0x01EA7,0x01EA7);
+  (0x01EA9,0x01EA9);
+  (0x01EAB,0x01EAB);
+  (0x01EAD,0x01EAD);
+  (0x01EAF,0x01EAF);
+  (0x01EB1,0x01EB1);
+  (0x01EB3,0x01EB3);
+  (0x01EB5,0x01EB5);
+  (0x01EB7,0x01EB7);
+  (0x01EB9,0x01EB9);
+  (0x01EBB,0x01EBB);
+  (0x01EBD,0x01EBD);
+  (0x01EBF,0x01EBF);
+  (0x01EC1,0x01EC1);
+  (0x01EC3,0x01EC3);
+  (0x01EC5,0x01EC5);
+  (0x01EC7,0x01EC7);
+  (0x01EC9,0x01EC9);
+  (0x01ECB,0x01ECB);
+  (0x01ECD,0x01ECD);
+  (0x01ECF,0x01ECF);
+  (0x01ED1,0x01ED1);
+  (0x01ED3,0x01ED3);
+  (0x01ED5,0x01ED5);
+  (0x01ED7,0x01ED7);
+  (0x01ED9,0x01ED9);
+  (0x01EDB,0x01EDB);
+  (0x01EDD,0x01EDD);
+  (0x01EDF,0x01EDF);
+  (0x01EE1,0x01EE1);
+  (0x01EE3,0x01EE3);
+  (0x01EE5,0x01EE5);
+  (0x01EE7,0x01EE7);
+  (0x01EE9,0x01EE9);
+  (0x01EEB,0x01EEB);
+  (0x01EED,0x01EED);
+  (0x01EEF,0x01EEF);
+  (0x01EF1,0x01EF1);
+  (0x01EF3,0x01EF3);
+  (0x01EF5,0x01EF5);
+  (0x01EF7,0x01EF7);
+  (0x01EF9,0x01EF9);
+  (0x01F00,0x01F07);
+  (0x01F10,0x01F15);
+  (0x01F20,0x01F27);
+  (0x01F30,0x01F37);
+  (0x01F40,0x01F45);
+  (0x01F50,0x01F57);
+  (0x01F60,0x01F67);
+  (0x01F70,0x01F7D);
+  (0x01F80,0x01F87);
+  (0x01F90,0x01F97);
+  (0x01FA0,0x01FA7);
+  (0x01FB0,0x01FB4);
+  (0x01FB6,0x01FB7);
+  (0x01FBE,0x01FBE);
+  (0x01FC2,0x01FC4);
+  (0x01FC6,0x01FC7);
+  (0x01FD0,0x01FD3);
+  (0x01FD6,0x01FD7);
+  (0x01FE0,0x01FE7);
+  (0x01FF2,0x01FF4);
+  (0x01FF6,0x01FF7);
+  (0x02071,0x02071);
+  (0x0207F,0x0207F);
+  (0x0210A,0x0210A);
+  (0x0210E,0x0210F);
+  (0x02113,0x02113);
+  (0x0212F,0x0212F);
+  (0x02134,0x02134);
+  (0x02139,0x02139);
+  (0x0213D,0x0213D);
+  (0x02146,0x02149);
+  (0x0FB00,0x0FB06);
+  (0x0FB13,0x0FB17);
+  (0x0FF41,0x0FF5A);
+  (0x10428,0x1044D);
+  (0x1D41A,0x1D433);
+  (0x1D44E,0x1D454);
+  (0x1D456,0x1D467);
+  (0x1D482,0x1D49B);
+  (0x1D4B6,0x1D4B9);
+  (0x1D4BB,0x1D4BB);
+  (0x1D4BD,0x1D4C0);
+  (0x1D4C2,0x1D4C3);
+  (0x1D4C5,0x1D4CF);
+  (0x1D4EA,0x1D503);
+  (0x1D51E,0x1D537);
+  (0x1D552,0x1D56B);
+  (0x1D586,0x1D59F);
+  (0x1D5BA,0x1D5D3);
+  (0x1D5EE,0x1D607);
+  (0x1D622,0x1D63B);
+  (0x1D656,0x1D66F);
+  (0x1D68A,0x1D6A3);
+  (0x1D6C2,0x1D6DA);
+  (0x1D6DC,0x1D6E1);
+  (0x1D6FC,0x1D714);
+  (0x1D716,0x1D71B);
+  (0x1D736,0x1D74E);
+  (0x1D750,0x1D755);
+  (0x1D770,0x1D788);
+  (0x1D78A,0x1D78F);
+  (0x1D7AA,0x1D7C2);
+  (0x1D7C4,0x1D7C9)
+]
+(* Letter, Titlecase *)
+let lt = [
+  (0x001C5,0x001C5);
+  (0x001C8,0x001C8);
+  (0x001CB,0x001CB);
+  (0x001F2,0x001F2);
+  (0x01F88,0x01F8F);
+  (0x01F98,0x01F9F);
+  (0x01FA8,0x01FAF);
+  (0x01FBC,0x01FBC);
+  (0x01FCC,0x01FCC);
+  (0x01FFC,0x01FFC)
+]
+(* Mark, Non-Spacing *)
+let mn = [
+  (0x00300,0x0034F);
+  (0x00360,0x0036F);
+  (0x00483,0x00486);
+  (0x00591,0x005A1);
+  (0x005A3,0x005B9);
+  (0x005BB,0x005BD);
+  (0x005BF,0x005BF);
+  (0x005C1,0x005C2);
+  (0x005C4,0x005C4);
+  (0x0064B,0x00655);
+  (0x00670,0x00670);
+  (0x006D6,0x006DC);
+  (0x006DF,0x006E4);
+  (0x006E7,0x006E8);
+  (0x006EA,0x006ED);
+  (0x00711,0x00711);
+  (0x00730,0x0074A);
+  (0x007A6,0x007B0);
+  (0x00901,0x00902);
+  (0x0093C,0x0093C);
+  (0x00941,0x00948);
+  (0x0094D,0x0094D);
+  (0x00951,0x00954);
+  (0x00962,0x00963);
+  (0x00981,0x00981);
+  (0x009BC,0x009BC);
+  (0x009C1,0x009C4);
+  (0x009CD,0x009CD);
+  (0x009E2,0x009E3);
+  (0x00A02,0x00A02);
+  (0x00A3C,0x00A3C);
+  (0x00A41,0x00A42);
+  (0x00A47,0x00A48);
+  (0x00A4B,0x00A4D);
+  (0x00A70,0x00A71);
+  (0x00A81,0x00A82);
+  (0x00ABC,0x00ABC);
+  (0x00AC1,0x00AC5);
+  (0x00AC7,0x00AC8);
+  (0x00ACD,0x00ACD);
+  (0x00B01,0x00B01);
+  (0x00B3C,0x00B3C);
+  (0x00B3F,0x00B3F);
+  (0x00B41,0x00B43);
+  (0x00B4D,0x00B4D);
+  (0x00B56,0x00B56);
+  (0x00B82,0x00B82);
+  (0x00BC0,0x00BC0);
+  (0x00BCD,0x00BCD);
+  (0x00C3E,0x00C40);
+  (0x00C46,0x00C48);
+  (0x00C4A,0x00C4D);
+  (0x00C55,0x00C56);
+  (0x00CBF,0x00CBF);
+  (0x00CC6,0x00CC6);
+  (0x00CCC,0x00CCD);
+  (0x00D41,0x00D43);
+  (0x00D4D,0x00D4D);
+  (0x00DCA,0x00DCA);
+  (0x00DD2,0x00DD4);
+  (0x00DD6,0x00DD6);
+  (0x00E31,0x00E31);
+  (0x00E34,0x00E3A);
+  (0x00E47,0x00E4E);
+  (0x00EB1,0x00EB1);
+  (0x00EB4,0x00EB9);
+  (0x00EBB,0x00EBC);
+  (0x00EC8,0x00ECD);
+  (0x00F18,0x00F19);
+  (0x00F35,0x00F35);
+  (0x00F37,0x00F37);
+  (0x00F39,0x00F39);
+  (0x00F71,0x00F7E);
+  (0x00F80,0x00F84);
+  (0x00F86,0x00F87);
+  (0x00F90,0x00F97);
+  (0x00F99,0x00FBC);
+  (0x00FC6,0x00FC6);
+  (0x0102D,0x01030);
+  (0x01032,0x01032);
+  (0x01036,0x01037);
+  (0x01039,0x01039);
+  (0x01058,0x01059);
+  (0x01712,0x01714);
+  (0x01732,0x01734);
+  (0x01752,0x01753);
+  (0x01772,0x01773);
+  (0x017B7,0x017BD);
+  (0x017C6,0x017C6);
+  (0x017C9,0x017D3);
+  (0x0180B,0x0180D);
+  (0x018A9,0x018A9);
+  (0x020D0,0x020DC);
+  (0x020E1,0x020E1);
+  (0x020E5,0x020EA);
+  (0x0302A,0x0302F);
+  (0x03099,0x0309A);
+  (0x0FB1E,0x0FB1E);
+  (0x0FE00,0x0FE0F);
+  (0x0FE20,0x0FE23);
+  (0x1D167,0x1D169);
+  (0x1D17B,0x1D182);
+  (0x1D185,0x1D18B);
+  (0x1D1AA,0x1D1AD)
+]
+(* Mark, Spacing Combining *)
+let mc = [
+  (0x00903,0x00903);
+  (0x0093E,0x00940);
+  (0x00949,0x0094C);
+  (0x00982,0x00983);
+  (0x009BE,0x009C0);
+  (0x009C7,0x009C8);
+  (0x009CB,0x009CC);
+  (0x009D7,0x009D7);
+  (0x00A3E,0x00A40);
+  (0x00A83,0x00A83);
+  (0x00ABE,0x00AC0);
+  (0x00AC9,0x00AC9);
+  (0x00ACB,0x00ACC);
+  (0x00B02,0x00B03);
+  (0x00B3E,0x00B3E);
+  (0x00B40,0x00B40);
+  (0x00B47,0x00B48);
+  (0x00B4B,0x00B4C);
+  (0x00B57,0x00B57);
+  (0x00BBE,0x00BBF);
+  (0x00BC1,0x00BC2);
+  (0x00BC6,0x00BC8);
+  (0x00BCA,0x00BCC);
+  (0x00BD7,0x00BD7);
+  (0x00C01,0x00C03);
+  (0x00C41,0x00C44);
+  (0x00C82,0x00C83);
+  (0x00CBE,0x00CBE);
+  (0x00CC0,0x00CC4);
+  (0x00CC7,0x00CC8);
+  (0x00CCA,0x00CCB);
+  (0x00CD5,0x00CD6);
+  (0x00D02,0x00D03);
+  (0x00D3E,0x00D40);
+  (0x00D46,0x00D48);
+  (0x00D4A,0x00D4C);
+  (0x00D57,0x00D57);
+  (0x00D82,0x00D83);
+  (0x00DCF,0x00DD1);
+  (0x00DD8,0x00DDF);
+  (0x00DF2,0x00DF3);
+  (0x00F3E,0x00F3F);
+  (0x00F7F,0x00F7F);
+  (0x0102C,0x0102C);
+  (0x01031,0x01031);
+  (0x01038,0x01038);
+  (0x01056,0x01057);
+  (0x017B4,0x017B6);
+  (0x017BE,0x017C5);
+  (0x017C7,0x017C8);
+  (0x1D165,0x1D166);
+  (0x1D16D,0x1D172)
+]
+(* Mark, Enclosing *)
+let me = [
+  (0x00488,0x00489);
+  (0x006DE,0x006DE);
+  (0x020DD,0x020E0);
+  (0x020E2,0x020E4)
+]
+(* Number, Decimal Digit *)
+let nd = [
+  (0x00030,0x00039);
+  (0x00660,0x00669);
+  (0x006F0,0x006F9);
+  (0x00966,0x0096F);
+  (0x009E6,0x009EF);
+  (0x00A66,0x00A6F);
+  (0x00AE6,0x00AEF);
+  (0x00B66,0x00B6F);
+  (0x00BE7,0x00BEF);
+  (0x00C66,0x00C6F);
+  (0x00CE6,0x00CEF);
+  (0x00D66,0x00D6F);
+  (0x00E50,0x00E59);
+  (0x00ED0,0x00ED9);
+  (0x00F20,0x00F29);
+  (0x01040,0x01049);
+  (0x01369,0x01371);
+  (0x017E0,0x017E9);
+  (0x01810,0x01819);
+  (0x0FF10,0x0FF19);
+  (0x1D7CE,0x1D7FF)
+]
+(* Number, Letter *)
+let nl = [
+  (0x016EE,0x016F0);
+  (0x02160,0x02183);
+  (0x03007,0x03007);
+  (0x03021,0x03029);
+  (0x03038,0x0303A);
+  (0x1034A,0x1034A)
+]
+(* Number, Other *)
+let no = [
+  (0x000B2,0x000B3);
+  (0x000B9,0x000B9);
+  (0x000BC,0x000BE);
+  (0x009F4,0x009F9);
+  (0x00BF0,0x00BF2);
+  (0x00F2A,0x00F33);
+  (0x01372,0x0137C);
+  (0x02070,0x02070);
+  (0x02074,0x02079);
+  (0x02080,0x02089);
+  (0x02153,0x0215F);
+  (0x02460,0x0249B);
+  (0x024EA,0x024FE);
+  (0x02776,0x02793);
+  (0x03192,0x03195);
+  (0x03220,0x03229);
+  (0x03251,0x0325F);
+  (0x03280,0x03289);
+  (0x032B1,0x032BF);
+  (0x10320,0x10323)
+]
+(* Separator, Space *)
+let zs = [
+  (0x00020,0x00020);
+  (0x000A0,0x000A0);
+  (0x01680,0x01680);
+  (0x02000,0x0200B);
+  (0x0202F,0x0202F);
+  (0x0205F,0x0205F);
+  (0x03000,0x03000)
+]
+(* Separator, Line *)
+let zl = [
+  (0x02028,0x02028)
+]
+(* Separator, Paragraph *)
+let zp = [
+  (0x02029,0x02029)
+]
+(* Other, Control *)
+let cc = [
+  (0x00000,0x0001F);
+  (0x0007F,0x0009F)
+]
+(* Other, Format *)
+let cf = [
+  (0x006DD,0x006DD);
+  (0x0070F,0x0070F);
+  (0x0180E,0x0180E);
+  (0x0200C,0x0200F);
+  (0x0202A,0x0202E);
+  (0x02060,0x02063);
+  (0x0206A,0x0206F);
+  (0x0FEFF,0x0FEFF);
+  (0x0FFF9,0x0FFFB);
+  (0x1D173,0x1D17A);
+  (0xE0001,0xE0001);
+  (0xE0020,0xE007F)
+]
+(* Other, Surrogate *)
+let cs = [
+  (0x0D800,0x0DEFE);
+  (0x0DFFF,0x0DFFF)
+]
+(* Other, Private Use *)
+let co = [
+  (0x0E000,0x0F8FF)
+]
+(* Other, Not Assigned *)
+let cn = [
+  (0x00221,0x00221);
+  (0x00234,0x0024F);
+  (0x002AE,0x002AF);
+  (0x002EF,0x002FF);
+  (0x00350,0x0035F);
+  (0x00370,0x00373);
+  (0x00376,0x00379);
+  (0x0037B,0x0037D);
+  (0x0037F,0x00383);
+  (0x0038B,0x0038B);
+  (0x0038D,0x0038D);
+  (0x003A2,0x003A2);
+  (0x003CF,0x003CF);
+  (0x003F7,0x003FF);
+  (0x00487,0x00487);
+  (0x004CF,0x004CF);
+  (0x004F6,0x004F7);
+  (0x004FA,0x004FF);
+  (0x00510,0x00530);
+  (0x00557,0x00558);
+  (0x00560,0x00560);
+  (0x00588,0x00588);
+  (0x0058B,0x00590);
+  (0x005A2,0x005A2);
+  (0x005BA,0x005BA);
+  (0x005C5,0x005CF);
+  (0x005EB,0x005EF);
+  (0x005F5,0x0060B);
+  (0x0060D,0x0061A);
+  (0x0061C,0x0061E);
+  (0x00620,0x00620);
+  (0x0063B,0x0063F);
+  (0x00656,0x0065F);
+  (0x006EE,0x006EF);
+  (0x006FF,0x006FF);
+  (0x0070E,0x0070E);
+  (0x0072D,0x0072F);
+  (0x0074B,0x0077F);
+  (0x007B2,0x00900);
+  (0x00904,0x00904);
+  (0x0093A,0x0093B);
+  (0x0094E,0x0094F);
+  (0x00955,0x00957);
+  (0x00971,0x00980);
+  (0x00984,0x00984);
+  (0x0098D,0x0098E);
+  (0x00991,0x00992);
+  (0x009A9,0x009A9);
+  (0x009B1,0x009B1);
+  (0x009B3,0x009B5);
+  (0x009BA,0x009BB);
+  (0x009BD,0x009BD);
+  (0x009C5,0x009C6);
+  (0x009C9,0x009CA);
+  (0x009CE,0x009D6);
+  (0x009D8,0x009DB);
+  (0x009DE,0x009DE);
+  (0x009E4,0x009E5);
+  (0x009FB,0x00A01);
+  (0x00A03,0x00A04);
+  (0x00A0B,0x00A0E);
+  (0x00A11,0x00A12);
+  (0x00A29,0x00A29);
+  (0x00A31,0x00A31);
+  (0x00A34,0x00A34);
+  (0x00A37,0x00A37);
+  (0x00A3A,0x00A3B);
+  (0x00A3D,0x00A3D);
+  (0x00A43,0x00A46);
+  (0x00A49,0x00A4A);
+  (0x00A4E,0x00A58);
+  (0x00A5D,0x00A5D);
+  (0x00A5F,0x00A65);
+  (0x00A75,0x00A80);
+  (0x00A84,0x00A84);
+  (0x00A8C,0x00A8C);
+  (0x00A8E,0x00A8E);
+  (0x00A92,0x00A92);
+  (0x00AA9,0x00AA9);
+  (0x00AB1,0x00AB1);
+  (0x00AB4,0x00AB4);
+  (0x00ABA,0x00ABB);
+  (0x00AC6,0x00AC6);
+  (0x00ACA,0x00ACA);
+  (0x00ACE,0x00ACF);
+  (0x00AD1,0x00ADF);
+  (0x00AE1,0x00AE5);
+  (0x00AF0,0x00B00);
+  (0x00B04,0x00B04);
+  (0x00B0D,0x00B0E);
+  (0x00B11,0x00B12);
+  (0x00B29,0x00B29);
+  (0x00B31,0x00B31);
+  (0x00B34,0x00B35);
+  (0x00B3A,0x00B3B);
+  (0x00B44,0x00B46);
+  (0x00B49,0x00B4A);
+  (0x00B4E,0x00B55);
+  (0x00B58,0x00B5B);
+  (0x00B5E,0x00B5E);
+  (0x00B62,0x00B65);
+  (0x00B71,0x00B81);
+  (0x00B84,0x00B84);
+  (0x00B8B,0x00B8D);
+  (0x00B91,0x00B91);
+  (0x00B96,0x00B98);
+  (0x00B9B,0x00B9B);
+  (0x00B9D,0x00B9D);
+  (0x00BA0,0x00BA2);
+  (0x00BA5,0x00BA7);
+  (0x00BAB,0x00BAD);
+  (0x00BB6,0x00BB6);
+  (0x00BBA,0x00BBD);
+  (0x00BC3,0x00BC5);
+  (0x00BC9,0x00BC9);
+  (0x00BCE,0x00BD6);
+  (0x00BD8,0x00BE6);
+  (0x00BF3,0x00C00);
+  (0x00C04,0x00C04);
+  (0x00C0D,0x00C0D);
+  (0x00C11,0x00C11);
+  (0x00C29,0x00C29);
+  (0x00C34,0x00C34);
+  (0x00C3A,0x00C3D);
+  (0x00C45,0x00C45);
+  (0x00C49,0x00C49);
+  (0x00C4E,0x00C54);
+  (0x00C57,0x00C5F);
+  (0x00C62,0x00C65);
+  (0x00C70,0x00C81);
+  (0x00C84,0x00C84);
+  (0x00C8D,0x00C8D);
+  (0x00C91,0x00C91);
+  (0x00CA9,0x00CA9);
+  (0x00CB4,0x00CB4);
+  (0x00CBA,0x00CBD);
+  (0x00CC5,0x00CC5);
+  (0x00CC9,0x00CC9);
+  (0x00CCE,0x00CD4);
+  (0x00CD7,0x00CDD);
+  (0x00CDF,0x00CDF);
+  (0x00CE2,0x00CE5);
+  (0x00CF0,0x00D01);
+  (0x00D04,0x00D04);
+  (0x00D0D,0x00D0D);
+  (0x00D11,0x00D11);
+  (0x00D29,0x00D29);
+  (0x00D3A,0x00D3D);
+  (0x00D44,0x00D45);
+  (0x00D49,0x00D49);
+  (0x00D4E,0x00D56);
+  (0x00D58,0x00D5F);
+  (0x00D62,0x00D65);
+  (0x00D70,0x00D81);
+  (0x00D84,0x00D84);
+  (0x00D97,0x00D99);
+  (0x00DB2,0x00DB2);
+  (0x00DBC,0x00DBC);
+  (0x00DBE,0x00DBF);
+  (0x00DC7,0x00DC9);
+  (0x00DCB,0x00DCE);
+  (0x00DD5,0x00DD5);
+  (0x00DD7,0x00DD7);
+  (0x00DE0,0x00DF1);
+  (0x00DF5,0x00E00);
+  (0x00E3B,0x00E3E);
+  (0x00E5C,0x00E80);
+  (0x00E83,0x00E83);
+  (0x00E85,0x00E86);
+  (0x00E89,0x00E89);
+  (0x00E8B,0x00E8C);
+  (0x00E8E,0x00E93);
+  (0x00E98,0x00E98);
+  (0x00EA0,0x00EA0);
+  (0x00EA4,0x00EA4);
+  (0x00EA6,0x00EA6);
+  (0x00EA8,0x00EA9);
+  (0x00EAC,0x00EAC);
+  (0x00EBA,0x00EBA);
+  (0x00EBE,0x00EBF);
+  (0x00EC5,0x00EC5);
+  (0x00EC7,0x00EC7);
+  (0x00ECE,0x00ECF);
+  (0x00EDA,0x00EDB);
+  (0x00EDE,0x00EFF);
+  (0x00F48,0x00F48);
+  (0x00F6B,0x00F70);
+  (0x00F8C,0x00F8F);
+  (0x00F98,0x00F98);
+  (0x00FBD,0x00FBD);
+  (0x00FCD,0x00FCE);
+  (0x00FD0,0x00FFF);
+  (0x01022,0x01022);
+  (0x01028,0x01028);
+  (0x0102B,0x0102B);
+  (0x01033,0x01035);
+  (0x0103A,0x0103F);
+  (0x0105A,0x0109F);
+  (0x010C6,0x010CF);
+  (0x010F9,0x010FA);
+  (0x010FC,0x010FF);
+  (0x0115A,0x0115E);
+  (0x011A3,0x011A7);
+  (0x011FA,0x011FF);
+  (0x01207,0x01207);
+  (0x01247,0x01247);
+  (0x01249,0x01249);
+  (0x0124E,0x0124F);
+  (0x01257,0x01257);
+  (0x01259,0x01259);
+  (0x0125E,0x0125F);
+  (0x01287,0x01287);
+  (0x01289,0x01289);
+  (0x0128E,0x0128F);
+  (0x012AF,0x012AF);
+  (0x012B1,0x012B1);
+  (0x012B6,0x012B7);
+  (0x012BF,0x012BF);
+  (0x012C1,0x012C1);
+  (0x012C6,0x012C7);
+  (0x012CF,0x012CF);
+  (0x012D7,0x012D7);
+  (0x012EF,0x012EF);
+  (0x0130F,0x0130F);
+  (0x01311,0x01311);
+  (0x01316,0x01317);
+  (0x0131F,0x0131F);
+  (0x01347,0x01347);
+  (0x0135B,0x01360);
+  (0x0137D,0x0139F);
+  (0x013F5,0x01400);
+  (0x01677,0x0167F);
+  (0x0169D,0x0169F);
+  (0x016F1,0x016FF);
+  (0x0170D,0x0170D);
+  (0x01715,0x0171F);
+  (0x01737,0x0173F);
+  (0x01754,0x0175F);
+  (0x0176D,0x0176D);
+  (0x01771,0x01771);
+  (0x01774,0x0177F);
+  (0x017DD,0x017DF);
+  (0x017EA,0x017FF);
+  (0x0180F,0x0180F);
+  (0x0181A,0x0181F);
+  (0x01878,0x0187F);
+  (0x018AA,0x01DFF);
+  (0x01E9C,0x01E9F);
+  (0x01EFA,0x01EFF);
+  (0x01F16,0x01F17);
+  (0x01F1E,0x01F1F);
+  (0x01F46,0x01F47);
+  (0x01F4E,0x01F4F);
+  (0x01F58,0x01F58);
+  (0x01F5A,0x01F5A);
+  (0x01F5C,0x01F5C);
+  (0x01F5E,0x01F5E);
+  (0x01F7E,0x01F7F);
+  (0x01FB5,0x01FB5);
+  (0x01FC5,0x01FC5);
+  (0x01FD4,0x01FD5);
+  (0x01FDC,0x01FDC);
+  (0x01FF0,0x01FF1);
+  (0x01FF5,0x01FF5);
+  (0x01FFF,0x01FFF);
+  (0x02053,0x02056);
+  (0x02058,0x0205E);
+  (0x02064,0x02069);
+  (0x02072,0x02073);
+  (0x0208F,0x0209F);
+  (0x020B2,0x020CF);
+  (0x020EB,0x020FF);
+  (0x0213B,0x0213C);
+  (0x0214C,0x02152);
+  (0x02184,0x0218F);
+  (0x023CF,0x023FF);
+  (0x02427,0x0243F);
+  (0x0244B,0x0245F);
+  (0x024FF,0x024FF);
+  (0x02614,0x02615);
+  (0x02618,0x02618);
+  (0x0267E,0x0267F);
+  (0x0268A,0x02700);
+  (0x02705,0x02705);
+  (0x0270A,0x0270B);
+  (0x02728,0x02728);
+  (0x0274C,0x0274C);
+  (0x0274E,0x0274E);
+  (0x02753,0x02755);
+  (0x02757,0x02757);
+  (0x0275F,0x02760);
+  (0x02795,0x02797);
+  (0x027B0,0x027B0);
+  (0x027BF,0x027CF);
+  (0x027EC,0x027EF);
+  (0x02B00,0x02E7F);
+  (0x02E9A,0x02E9A);
+  (0x02EF4,0x02EFF);
+  (0x02FD6,0x02FEF);
+  (0x02FFC,0x02FFF);
+  (0x03040,0x03040);
+  (0x03097,0x03098);
+  (0x03100,0x03104);
+  (0x0312D,0x03130);
+  (0x0318F,0x0318F);
+  (0x031B8,0x031EF);
+  (0x0321D,0x0321F);
+  (0x03244,0x03250);
+  (0x0327C,0x0327E);
+  (0x032CC,0x032CF);
+  (0x032FF,0x032FF);
+  (0x03377,0x0337A);
+  (0x033DE,0x033DF);
+  (0x033FF,0x033FF);
+  (0x04DB6,0x04DFF);
+  (0x09FA6,0x09FFF);
+  (0x0A48D,0x0A48F);
+  (0x0A4C7,0x0ABFF);
+  (0x0D7A4,0x0D7FF);
+  (0x0DEFF,0x0DFFE);
+  (0x0FA2E,0x0FA2F);
+  (0x0FA6B,0x0FAFF);
+  (0x0FB07,0x0FB12);
+  (0x0FB18,0x0FB1C);
+  (0x0FB37,0x0FB37);
+  (0x0FB3D,0x0FB3D);
+  (0x0FB3F,0x0FB3F);
+  (0x0FB42,0x0FB42);
+  (0x0FB45,0x0FB45);
+  (0x0FBB2,0x0FBD2);
+  (0x0FD40,0x0FD4F);
+  (0x0FD90,0x0FD91);
+  (0x0FDC8,0x0FDEF);
+  (0x0FDFD,0x0FDFF);
+  (0x0FE10,0x0FE1F);
+  (0x0FE24,0x0FE2F);
+  (0x0FE47,0x0FE48);
+  (0x0FE53,0x0FE53);
+  (0x0FE67,0x0FE67);
+  (0x0FE6C,0x0FE6F);
+  (0x0FE75,0x0FE75);
+  (0x0FEFD,0x0FEFE);
+  (0x0FF00,0x0FF00);
+  (0x0FFBF,0x0FFC1);
+  (0x0FFC8,0x0FFC9);
+  (0x0FFD0,0x0FFD1);
+  (0x0FFD8,0x0FFD9);
+  (0x0FFDD,0x0FFDF);
+  (0x0FFE7,0x0FFE7);
+  (0x0FFEF,0x0FFF8);
+  (0x0FFFE,0x102FF);
+  (0x1031F,0x1031F);
+  (0x10324,0x1032F);
+  (0x1034B,0x103FF);
+  (0x10426,0x10427);
+  (0x1044E,0x1CFFF);
+  (0x1D0F6,0x1D0FF);
+  (0x1D127,0x1D129);
+  (0x1D1DE,0x1D3FF);
+  (0x1D455,0x1D455);
+  (0x1D49D,0x1D49D);
+  (0x1D4A0,0x1D4A1);
+  (0x1D4A3,0x1D4A4);
+  (0x1D4A7,0x1D4A8);
+  (0x1D4AD,0x1D4AD);
+  (0x1D4BA,0x1D4BA);
+  (0x1D4BC,0x1D4BC);
+  (0x1D4C1,0x1D4C1);
+  (0x1D4C4,0x1D4C4);
+  (0x1D506,0x1D506);
+  (0x1D50B,0x1D50C);
+  (0x1D515,0x1D515);
+  (0x1D51D,0x1D51D);
+  (0x1D53A,0x1D53A);
+  (0x1D53F,0x1D53F);
+  (0x1D545,0x1D545);
+  (0x1D547,0x1D549);
+  (0x1D551,0x1D551);
+  (0x1D6A4,0x1D6A7);
+  (0x1D7CA,0x1D7CD);
+  (0x1D800,0x1FFFF);
+  (0x2A6D7,0x2F7FF);
+  (0x2FA1E,0xE0000);
+  (0xE0002,0xE001F);
+  (0xE0080,0x7FFFFFFF)
+]
+(* Letter, Modifier *)
+let lm = [
+  (0x002B0,0x002B8);
+  (0x002BB,0x002C1);
+  (0x002D0,0x002D1);
+  (0x002E0,0x002E4);
+  (0x002EE,0x002EE);
+  (0x0037A,0x0037A);
+  (0x00559,0x00559);
+  (0x00640,0x00640);
+  (0x006E5,0x006E6);
+  (0x00E46,0x00E46);
+  (0x00EC6,0x00EC6);
+  (0x017D7,0x017D7);
+  (0x01843,0x01843);
+  (0x03005,0x03005);
+  (0x03031,0x03035);
+  (0x0303B,0x0303B);
+  (0x0309D,0x0309E);
+  (0x030FC,0x030FE);
+  (0x0FF70,0x0FF70);
+  (0x0FF9E,0x0FF9F)
+]
+(* Letter, Other *)
+let lo = [
+  (0x001BB,0x001BB);
+  (0x001C0,0x001C3);
+  (0x005D0,0x005EA);
+  (0x005F0,0x005F2);
+  (0x00621,0x0063A);
+  (0x00641,0x0064A);
+  (0x0066E,0x0066F);
+  (0x00671,0x006D3);
+  (0x006D5,0x006D5);
+  (0x006FA,0x006FC);
+  (0x00710,0x00710);
+  (0x00712,0x0072C);
+  (0x00780,0x007A5);
+  (0x007B1,0x007B1);
+  (0x00905,0x00939);
+  (0x0093D,0x0093D);
+  (0x00950,0x00950);
+  (0x00958,0x00961);
+  (0x00985,0x0098C);
+  (0x0098F,0x00990);
+  (0x00993,0x009A8);
+  (0x009AA,0x009B0);
+  (0x009B2,0x009B2);
+  (0x009B6,0x009B9);
+  (0x009DC,0x009DD);
+  (0x009DF,0x009E1);
+  (0x009F0,0x009F1);
+  (0x00A05,0x00A0A);
+  (0x00A0F,0x00A10);
+  (0x00A13,0x00A28);
+  (0x00A2A,0x00A30);
+  (0x00A32,0x00A33);
+  (0x00A35,0x00A36);
+  (0x00A38,0x00A39);
+  (0x00A59,0x00A5C);
+  (0x00A5E,0x00A5E);
+  (0x00A72,0x00A74);
+  (0x00A85,0x00A8B);
+  (0x00A8D,0x00A8D);
+  (0x00A8F,0x00A91);
+  (0x00A93,0x00AA8);
+  (0x00AAA,0x00AB0);
+  (0x00AB2,0x00AB3);
+  (0x00AB5,0x00AB9);
+  (0x00ABD,0x00ABD);
+  (0x00AD0,0x00AD0);
+  (0x00AE0,0x00AE0);
+  (0x00B05,0x00B0C);
+  (0x00B0F,0x00B10);
+  (0x00B13,0x00B28);
+  (0x00B2A,0x00B30);
+  (0x00B32,0x00B33);
+  (0x00B36,0x00B39);
+  (0x00B3D,0x00B3D);
+  (0x00B5C,0x00B5D);
+  (0x00B5F,0x00B61);
+  (0x00B83,0x00B83);
+  (0x00B85,0x00B8A);
+  (0x00B8E,0x00B90);
+  (0x00B92,0x00B95);
+  (0x00B99,0x00B9A);
+  (0x00B9C,0x00B9C);
+  (0x00B9E,0x00B9F);
+  (0x00BA3,0x00BA4);
+  (0x00BA8,0x00BAA);
+  (0x00BAE,0x00BB5);
+  (0x00BB7,0x00BB9);
+  (0x00C05,0x00C0C);
+  (0x00C0E,0x00C10);
+  (0x00C12,0x00C28);
+  (0x00C2A,0x00C33);
+  (0x00C35,0x00C39);
+  (0x00C60,0x00C61);
+  (0x00C85,0x00C8C);
+  (0x00C8E,0x00C90);
+  (0x00C92,0x00CA8);
+  (0x00CAA,0x00CB3);
+  (0x00CB5,0x00CB9);
+  (0x00CDE,0x00CDE);
+  (0x00CE0,0x00CE1);
+  (0x00D05,0x00D0C);
+  (0x00D0E,0x00D10);
+  (0x00D12,0x00D28);
+  (0x00D2A,0x00D39);
+  (0x00D60,0x00D61);
+  (0x00D85,0x00D96);
+  (0x00D9A,0x00DB1);
+  (0x00DB3,0x00DBB);
+  (0x00DBD,0x00DBD);
+  (0x00DC0,0x00DC6);
+  (0x00E01,0x00E30);
+  (0x00E32,0x00E33);
+  (0x00E40,0x00E45);
+  (0x00E81,0x00E82);
+  (0x00E84,0x00E84);
+  (0x00E87,0x00E88);
+  (0x00E8A,0x00E8A);
+  (0x00E8D,0x00E8D);
+  (0x00E94,0x00E97);
+  (0x00E99,0x00E9F);
+  (0x00EA1,0x00EA3);
+  (0x00EA5,0x00EA5);
+  (0x00EA7,0x00EA7);
+  (0x00EAA,0x00EAB);
+  (0x00EAD,0x00EB0);
+  (0x00EB2,0x00EB3);
+  (0x00EBD,0x00EBD);
+  (0x00EC0,0x00EC4);
+  (0x00EDC,0x00EDD);
+  (0x00F00,0x00F00);
+  (0x00F40,0x00F47);
+  (0x00F49,0x00F6A);
+  (0x00F88,0x00F8B);
+  (0x01000,0x01021);
+  (0x01023,0x01027);
+  (0x01029,0x0102A);
+  (0x01050,0x01055);
+  (0x010D0,0x010F8);
+  (0x01100,0x01159);
+  (0x0115F,0x011A2);
+  (0x011A8,0x011F9);
+  (0x01200,0x01206);
+  (0x01208,0x01246);
+  (0x01248,0x01248);
+  (0x0124A,0x0124D);
+  (0x01250,0x01256);
+  (0x01258,0x01258);
+  (0x0125A,0x0125D);
+  (0x01260,0x01286);
+  (0x01288,0x01288);
+  (0x0128A,0x0128D);
+  (0x01290,0x012AE);
+  (0x012B0,0x012B0);
+  (0x012B2,0x012B5);
+  (0x012B8,0x012BE);
+  (0x012C0,0x012C0);
+  (0x012C2,0x012C5);
+  (0x012C8,0x012CE);
+  (0x012D0,0x012D6);
+  (0x012D8,0x012EE);
+  (0x012F0,0x0130E);
+  (0x01310,0x01310);
+  (0x01312,0x01315);
+  (0x01318,0x0131E);
+  (0x01320,0x01346);
+  (0x01348,0x0135A);
+  (0x013A0,0x013F4);
+  (0x01401,0x0166C);
+  (0x0166F,0x01676);
+  (0x01681,0x0169A);
+  (0x016A0,0x016EA);
+  (0x01700,0x0170C);
+  (0x0170E,0x01711);
+  (0x01720,0x01731);
+  (0x01740,0x01751);
+  (0x01760,0x0176C);
+  (0x0176E,0x01770);
+  (0x01780,0x017B3);
+  (0x017DC,0x017DC);
+  (0x01820,0x01842);
+  (0x01844,0x01877);
+  (0x01880,0x018A8);
+  (0x02135,0x02138);
+  (0x03006,0x03006);
+  (0x0303C,0x0303C);
+  (0x03041,0x03096);
+  (0x0309F,0x0309F);
+  (0x030A1,0x030FA);
+  (0x030FF,0x030FF);
+  (0x03105,0x0312C);
+  (0x03131,0x0318E);
+  (0x031A0,0x031B7);
+  (0x031F0,0x031FF);
+  (0x03400,0x04DB5);
+  (0x04E00,0x09FA5);
+  (0x0A000,0x0A48C);
+  (0x0AC00,0x0D7A3);
+  (0x0F900,0x0FA2D);
+  (0x0FA30,0x0FA6A);
+  (0x0FB1D,0x0FB1D);
+  (0x0FB1F,0x0FB28);
+  (0x0FB2A,0x0FB36);
+  (0x0FB38,0x0FB3C);
+  (0x0FB3E,0x0FB3E);
+  (0x0FB40,0x0FB41);
+  (0x0FB43,0x0FB44);
+  (0x0FB46,0x0FBB1);
+  (0x0FBD3,0x0FD3D);
+  (0x0FD50,0x0FD8F);
+  (0x0FD92,0x0FDC7);
+  (0x0FDF0,0x0FDFB);
+  (0x0FE70,0x0FE74);
+  (0x0FE76,0x0FEFC);
+  (0x0FF66,0x0FF6F);
+  (0x0FF71,0x0FF9D);
+  (0x0FFA0,0x0FFBE);
+  (0x0FFC2,0x0FFC7);
+  (0x0FFCA,0x0FFCF);
+  (0x0FFD2,0x0FFD7);
+  (0x0FFDA,0x0FFDC);
+  (0x10300,0x1031E);
+  (0x10330,0x10349);
+  (0x20000,0x2A6D6);
+  (0x2F800,0x2FA1D)
+]
+(* Punctuation, Connector *)
+let pc = [
+  (0x0005F,0x0005F);
+  (0x0203F,0x02040);
+  (0x030FB,0x030FB);
+  (0x0FE33,0x0FE34);
+  (0x0FE4D,0x0FE4F);
+  (0x0FF3F,0x0FF3F);
+  (0x0FF65,0x0FF65)
+]
+(* Punctuation, Dash *)
+let pd = [
+  (0x0002D,0x0002D);
+  (0x000AD,0x000AD);
+  (0x0058A,0x0058A);
+  (0x01806,0x01806);
+  (0x02010,0x02015);
+  (0x0301C,0x0301C);
+  (0x03030,0x03030);
+  (0x030A0,0x030A0);
+  (0x0FE31,0x0FE32);
+  (0x0FE58,0x0FE58);
+  (0x0FE63,0x0FE63);
+  (0x0FF0D,0x0FF0D)
+]
+(* Punctuation, Open *)
+let ps = [
+  (0x00028,0x00028);
+  (0x0005B,0x0005B);
+  (0x0007B,0x0007B);
+  (0x00F3A,0x00F3A);
+  (0x00F3C,0x00F3C);
+  (0x0169B,0x0169B);
+  (0x0201A,0x0201A);
+  (0x0201E,0x0201E);
+  (0x02045,0x02045);
+  (0x0207D,0x0207D);
+  (0x0208D,0x0208D);
+  (0x02329,0x02329);
+  (0x023B4,0x023B4);
+  (0x02768,0x02768);
+  (0x0276A,0x0276A);
+  (0x0276C,0x0276C);
+  (0x0276E,0x0276E);
+  (0x02770,0x02770);
+  (0x02772,0x02772);
+  (0x02774,0x02774);
+  (0x027E6,0x027E6);
+  (0x027E8,0x027E8);
+  (0x027EA,0x027EA);
+  (0x02983,0x02983);
+  (0x02985,0x02985);
+  (0x02987,0x02987);
+  (0x02989,0x02989);
+  (0x0298B,0x0298B);
+  (0x0298D,0x0298D);
+  (0x0298F,0x0298F);
+  (0x02991,0x02991);
+  (0x02993,0x02993);
+  (0x02995,0x02995);
+  (0x02997,0x02997);
+  (0x029D8,0x029D8);
+  (0x029DA,0x029DA);
+  (0x029FC,0x029FC);
+  (0x03008,0x03008);
+  (0x0300A,0x0300A);
+  (0x0300C,0x0300C);
+  (0x0300E,0x0300E);
+  (0x03010,0x03010);
+  (0x03014,0x03014);
+  (0x03016,0x03016);
+  (0x03018,0x03018);
+  (0x0301A,0x0301A);
+  (0x0301D,0x0301D);
+  (0x0FD3E,0x0FD3E);
+  (0x0FE35,0x0FE35);
+  (0x0FE37,0x0FE37);
+  (0x0FE39,0x0FE39);
+  (0x0FE3B,0x0FE3B);
+  (0x0FE3D,0x0FE3D);
+  (0x0FE3F,0x0FE3F);
+  (0x0FE41,0x0FE41);
+  (0x0FE43,0x0FE43);
+  (0x0FE59,0x0FE59);
+  (0x0FE5B,0x0FE5B);
+  (0x0FE5D,0x0FE5D);
+  (0x0FF08,0x0FF08);
+  (0x0FF3B,0x0FF3B);
+  (0x0FF5B,0x0FF5B);
+  (0x0FF5F,0x0FF5F);
+  (0x0FF62,0x0FF62)
+]
+(* Punctuation, Close *)
+let pe = [
+  (0x00029,0x00029);
+  (0x0005D,0x0005D);
+  (0x0007D,0x0007D);
+  (0x00F3B,0x00F3B);
+  (0x00F3D,0x00F3D);
+  (0x0169C,0x0169C);
+  (0x02046,0x02046);
+  (0x0207E,0x0207E);
+  (0x0208E,0x0208E);
+  (0x0232A,0x0232A);
+  (0x023B5,0x023B5);
+  (0x02769,0x02769);
+  (0x0276B,0x0276B);
+  (0x0276D,0x0276D);
+  (0x0276F,0x0276F);
+  (0x02771,0x02771);
+  (0x02773,0x02773);
+  (0x02775,0x02775);
+  (0x027E7,0x027E7);
+  (0x027E9,0x027E9);
+  (0x027EB,0x027EB);
+  (0x02984,0x02984);
+  (0x02986,0x02986);
+  (0x02988,0x02988);
+  (0x0298A,0x0298A);
+  (0x0298C,0x0298C);
+  (0x0298E,0x0298E);
+  (0x02990,0x02990);
+  (0x02992,0x02992);
+  (0x02994,0x02994);
+  (0x02996,0x02996);
+  (0x02998,0x02998);
+  (0x029D9,0x029D9);
+  (0x029DB,0x029DB);
+  (0x029FD,0x029FD);
+  (0x03009,0x03009);
+  (0x0300B,0x0300B);
+  (0x0300D,0x0300D);
+  (0x0300F,0x0300F);
+  (0x03011,0x03011);
+  (0x03015,0x03015);
+  (0x03017,0x03017);
+  (0x03019,0x03019);
+  (0x0301B,0x0301B);
+  (0x0301E,0x0301F);
+  (0x0FD3F,0x0FD3F);
+  (0x0FE36,0x0FE36);
+  (0x0FE38,0x0FE38);
+  (0x0FE3A,0x0FE3A);
+  (0x0FE3C,0x0FE3C);
+  (0x0FE3E,0x0FE3E);
+  (0x0FE40,0x0FE40);
+  (0x0FE42,0x0FE42);
+  (0x0FE44,0x0FE44);
+  (0x0FE5A,0x0FE5A);
+  (0x0FE5C,0x0FE5C);
+  (0x0FE5E,0x0FE5E);
+  (0x0FF09,0x0FF09);
+  (0x0FF3D,0x0FF3D);
+  (0x0FF5D,0x0FF5D);
+  (0x0FF60,0x0FF60);
+  (0x0FF63,0x0FF63)
+]
+(* Punctuation, Initial quote  *)
+let pi = [
+  (0x000AB,0x000AB);
+  (0x02018,0x02018);
+  (0x0201B,0x0201C);
+  (0x0201F,0x0201F);
+  (0x02039,0x02039)
+]
+(* Punctuation, Final quote  *)
+let pf = [
+  (0x000BB,0x000BB);
+  (0x02019,0x02019);
+  (0x0201D,0x0201D);
+  (0x0203A,0x0203A)
+]
+(* Punctuation, Other *)
+let po = [
+  (0x00021,0x00023);
+  (0x00025,0x00027);
+  (0x0002A,0x0002A);
+  (0x0002C,0x0002C);
+  (0x0002E,0x0002F);
+  (0x0003A,0x0003B);
+  (0x0003F,0x00040);
+  (0x0005C,0x0005C);
+  (0x000A1,0x000A1);
+  (0x000B7,0x000B7);
+  (0x000BF,0x000BF);
+  (0x0037E,0x0037E);
+  (0x00387,0x00387);
+  (0x0055A,0x0055F);
+  (0x00589,0x00589);
+  (0x005BE,0x005BE);
+  (0x005C0,0x005C0);
+  (0x005C3,0x005C3);
+  (0x005F3,0x005F4);
+  (0x0060C,0x0060C);
+  (0x0061B,0x0061B);
+  (0x0061F,0x0061F);
+  (0x0066A,0x0066D);
+  (0x006D4,0x006D4);
+  (0x00700,0x0070D);
+  (0x00964,0x00965);
+  (0x00970,0x00970);
+  (0x00DF4,0x00DF4);
+  (0x00E4F,0x00E4F);
+  (0x00E5A,0x00E5B);
+  (0x00F04,0x00F12);
+  (0x00F85,0x00F85);
+  (0x0104A,0x0104F);
+  (0x010FB,0x010FB);
+  (0x01361,0x01368);
+  (0x0166D,0x0166E);
+  (0x016EB,0x016ED);
+  (0x01735,0x01736);
+  (0x017D4,0x017D6);
+  (0x017D8,0x017DA);
+  (0x01800,0x01805);
+  (0x01807,0x0180A);
+  (0x02016,0x02017);
+  (0x02020,0x02027);
+  (0x02030,0x02038);
+  (0x0203B,0x0203E);
+  (0x02041,0x02043);
+  (0x02047,0x02051);
+  (0x02057,0x02057);
+  (0x023B6,0x023B6);
+  (0x03001,0x03003);
+  (0x0303D,0x0303D);
+  (0x0FE30,0x0FE30);
+  (0x0FE45,0x0FE46);
+  (0x0FE49,0x0FE4C);
+  (0x0FE50,0x0FE52);
+  (0x0FE54,0x0FE57);
+  (0x0FE5F,0x0FE61);
+  (0x0FE68,0x0FE68);
+  (0x0FE6A,0x0FE6B);
+  (0x0FF01,0x0FF03);
+  (0x0FF05,0x0FF07);
+  (0x0FF0A,0x0FF0A);
+  (0x0FF0C,0x0FF0C);
+  (0x0FF0E,0x0FF0F);
+  (0x0FF1A,0x0FF1B);
+  (0x0FF1F,0x0FF20);
+  (0x0FF3C,0x0FF3C);
+  (0x0FF61,0x0FF61);
+  (0x0FF64,0x0FF64)
+]
+(* Symbol, Math *)
+let sm = [
+  (0x0002B,0x0002B);
+  (0x0003C,0x0003E);
+  (0x0007C,0x0007C);
+  (0x0007E,0x0007E);
+  (0x000AC,0x000AC);
+  (0x000B1,0x000B1);
+  (0x000D7,0x000D7);
+  (0x000F7,0x000F7);
+  (0x003F6,0x003F6);
+  (0x02044,0x02044);
+  (0x02052,0x02052);
+  (0x0207A,0x0207C);
+  (0x0208A,0x0208C);
+  (0x02140,0x02144);
+  (0x0214B,0x0214B);
+  (0x02190,0x02194);
+  (0x0219A,0x0219B);
+  (0x021A0,0x021A0);
+  (0x021A3,0x021A3);
+  (0x021A6,0x021A6);
+  (0x021AE,0x021AE);
+  (0x021CE,0x021CF);
+  (0x021D2,0x021D2);
+  (0x021D4,0x021D4);
+  (0x021F4,0x022FF);
+  (0x02308,0x0230B);
+  (0x02320,0x02321);
+  (0x0237C,0x0237C);
+  (0x0239B,0x023B3);
+  (0x025B7,0x025B7);
+  (0x025C1,0x025C1);
+  (0x025F8,0x025FF);
+  (0x0266F,0x0266F);
+  (0x027D0,0x027E5);
+  (0x027F0,0x027FF);
+  (0x02900,0x02982);
+  (0x02999,0x029D7);
+  (0x029DC,0x029FB);
+  (0x029FE,0x02AFF);
+  (0x0FB29,0x0FB29);
+  (0x0FE62,0x0FE62);
+  (0x0FE64,0x0FE66);
+  (0x0FF0B,0x0FF0B);
+  (0x0FF1C,0x0FF1E);
+  (0x0FF5C,0x0FF5C);
+  (0x0FF5E,0x0FF5E);
+  (0x0FFE2,0x0FFE2);
+  (0x0FFE9,0x0FFEC);
+  (0x1D6C1,0x1D6C1);
+  (0x1D6DB,0x1D6DB);
+  (0x1D6FB,0x1D6FB);
+  (0x1D715,0x1D715);
+  (0x1D735,0x1D735);
+  (0x1D74F,0x1D74F);
+  (0x1D76F,0x1D76F);
+  (0x1D789,0x1D789);
+  (0x1D7A9,0x1D7A9);
+  (0x1D7C3,0x1D7C3)
+]
+(* Symbol, Currency *)
+let sc = [
+  (0x00024,0x00024);
+  (0x000A2,0x000A5);
+  (0x009F2,0x009F3);
+  (0x00E3F,0x00E3F);
+  (0x017DB,0x017DB);
+  (0x020A0,0x020B1);
+  (0x0FDFC,0x0FDFC);
+  (0x0FE69,0x0FE69);
+  (0x0FF04,0x0FF04);
+  (0x0FFE0,0x0FFE1);
+  (0x0FFE5,0x0FFE6)
+]
+(* Symbol, Modifier *)
+let sk = [
+  (0x0005E,0x0005E);
+  (0x00060,0x00060);
+  (0x000A8,0x000A8);
+  (0x000AF,0x000AF);
+  (0x000B4,0x000B4);
+  (0x000B8,0x000B8);
+  (0x002B9,0x002BA);
+  (0x002C2,0x002CF);
+  (0x002D2,0x002DF);
+  (0x002E5,0x002ED);
+  (0x00374,0x00375);
+  (0x00384,0x00385);
+  (0x01FBD,0x01FBD);
+  (0x01FBF,0x01FC1);
+  (0x01FCD,0x01FCF);
+  (0x01FDD,0x01FDF);
+  (0x01FED,0x01FEF);
+  (0x01FFD,0x01FFE);
+  (0x0309B,0x0309C);
+  (0x0FF3E,0x0FF3E);
+  (0x0FF40,0x0FF40);
+  (0x0FFE3,0x0FFE3)
+]
+(* Symbol, Other  *)
+let so = [
+  (0x000A6,0x000A7);
+  (0x000A9,0x000A9);
+  (0x000AE,0x000AE);
+  (0x000B0,0x000B0);
+  (0x000B6,0x000B6);
+  (0x00482,0x00482);
+  (0x006E9,0x006E9);
+  (0x006FD,0x006FE);
+  (0x009FA,0x009FA);
+  (0x00B70,0x00B70);
+  (0x00F01,0x00F03);
+  (0x00F13,0x00F17);
+  (0x00F1A,0x00F1F);
+  (0x00F34,0x00F34);
+  (0x00F36,0x00F36);
+  (0x00F38,0x00F38);
+  (0x00FBE,0x00FC5);
+  (0x00FC7,0x00FCC);
+  (0x00FCF,0x00FCF);
+  (0x02100,0x02101);
+  (0x02103,0x02106);
+  (0x02108,0x02109);
+  (0x02114,0x02114);
+  (0x02116,0x02118);
+  (0x0211E,0x02123);
+  (0x02125,0x02125);
+  (0x02127,0x02127);
+  (0x02129,0x02129);
+  (0x0212E,0x0212E);
+  (0x02132,0x02132);
+  (0x0213A,0x0213A);
+  (0x0214A,0x0214A);
+  (0x02195,0x02199);
+  (0x0219C,0x0219F);
+  (0x021A1,0x021A2);
+  (0x021A4,0x021A5);
+  (0x021A7,0x021AD);
+  (0x021AF,0x021CD);
+  (0x021D0,0x021D1);
+  (0x021D3,0x021D3);
+  (0x021D5,0x021F3);
+  (0x02300,0x02307);
+  (0x0230C,0x0231F);
+  (0x02322,0x02328);
+  (0x0232B,0x0237B);
+  (0x0237D,0x0239A);
+  (0x023B7,0x023CE);
+  (0x02400,0x02426);
+  (0x02440,0x0244A);
+  (0x0249C,0x024E9);
+  (0x02500,0x025B6);
+  (0x025B8,0x025C0);
+  (0x025C2,0x025F7);
+  (0x02600,0x02613);
+  (0x02616,0x02617);
+  (0x02619,0x0266E);
+  (0x02670,0x0267D);
+  (0x02680,0x02689);
+  (0x02701,0x02704);
+  (0x02706,0x02709);
+  (0x0270C,0x02727);
+  (0x02729,0x0274B);
+  (0x0274D,0x0274D);
+  (0x0274F,0x02752);
+  (0x02756,0x02756);
+  (0x02758,0x0275E);
+  (0x02761,0x02767);
+  (0x02794,0x02794);
+  (0x02798,0x027AF);
+  (0x027B1,0x027BE);
+  (0x02800,0x028FF);
+  (0x02E80,0x02E99);
+  (0x02E9B,0x02EF3);
+  (0x02F00,0x02FD5);
+  (0x02FF0,0x02FFB);
+  (0x03004,0x03004);
+  (0x03012,0x03013);
+  (0x03020,0x03020);
+  (0x03036,0x03037);
+  (0x0303E,0x0303F);
+  (0x03190,0x03191);
+  (0x03196,0x0319F);
+  (0x03200,0x0321C);
+  (0x0322A,0x03243);
+  (0x03260,0x0327B);
+  (0x0327F,0x0327F);
+  (0x0328A,0x032B0);
+  (0x032C0,0x032CB);
+  (0x032D0,0x032FE);
+  (0x03300,0x03376);
+  (0x0337B,0x033DD);
+  (0x033E0,0x033FE);
+  (0x0A490,0x0A4C6);
+  (0x0FFE4,0x0FFE4);
+  (0x0FFE8,0x0FFE8);
+  (0x0FFED,0x0FFEE);
+  (0x0FFFC,0x0FFFD);
+  (0x1D000,0x1D0F5);
+  (0x1D100,0x1D126);
+  (0x1D12A,0x1D164);
+  (0x1D16A,0x1D16C);
+  (0x1D183,0x1D184);
+  (0x1D18C,0x1D1A9);
+  (0x1D1AE,0x1D1DD)
+]
+
+(* Conversion to lower case. *)
+let to_lower = [
+  (0x00041,0x0005A), `Delta (32);
+  (0x000C0,0x000D6), `Delta (32);
+  (0x000D8,0x000DE), `Delta (32);
+  (0x00100,0x00100), `Abs (0x00101);
+  (0x00102,0x00102), `Abs (0x00103);
+  (0x00104,0x00104), `Abs (0x00105);
+  (0x00106,0x00106), `Abs (0x00107);
+  (0x00108,0x00108), `Abs (0x00109);
+  (0x0010A,0x0010A), `Abs (0x0010B);
+  (0x0010C,0x0010C), `Abs (0x0010D);
+  (0x0010E,0x0010E), `Abs (0x0010F);
+  (0x00110,0x00110), `Abs (0x00111);
+  (0x00112,0x00112), `Abs (0x00113);
+  (0x00114,0x00114), `Abs (0x00115);
+  (0x00116,0x00116), `Abs (0x00117);
+  (0x00118,0x00118), `Abs (0x00119);
+  (0x0011A,0x0011A), `Abs (0x0011B);
+  (0x0011C,0x0011C), `Abs (0x0011D);
+  (0x0011E,0x0011E), `Abs (0x0011F);
+  (0x00120,0x00120), `Abs (0x00121);
+  (0x00122,0x00122), `Abs (0x00123);
+  (0x00124,0x00124), `Abs (0x00125);
+  (0x00126,0x00126), `Abs (0x00127);
+  (0x00128,0x00128), `Abs (0x00129);
+  (0x0012A,0x0012A), `Abs (0x0012B);
+  (0x0012C,0x0012C), `Abs (0x0012D);
+  (0x0012E,0x0012E), `Abs (0x0012F);
+  (0x00130,0x00130), `Abs (0x00069);
+  (0x00132,0x00132), `Abs (0x00133);
+  (0x00134,0x00134), `Abs (0x00135);
+  (0x00136,0x00136), `Abs (0x00137);
+  (0x00139,0x00139), `Abs (0x0013A);
+  (0x0013B,0x0013B), `Abs (0x0013C);
+  (0x0013D,0x0013D), `Abs (0x0013E);
+  (0x0013F,0x0013F), `Abs (0x00140);
+  (0x00141,0x00141), `Abs (0x00142);
+  (0x00143,0x00143), `Abs (0x00144);
+  (0x00145,0x00145), `Abs (0x00146);
+  (0x00147,0x00147), `Abs (0x00148);
+  (0x0014A,0x0014A), `Abs (0x0014B);
+  (0x0014C,0x0014C), `Abs (0x0014D);
+  (0x0014E,0x0014E), `Abs (0x0014F);
+  (0x00150,0x00150), `Abs (0x00151);
+  (0x00152,0x00152), `Abs (0x00153);
+  (0x00154,0x00154), `Abs (0x00155);
+  (0x00156,0x00156), `Abs (0x00157);
+  (0x00158,0x00158), `Abs (0x00159);
+  (0x0015A,0x0015A), `Abs (0x0015B);
+  (0x0015C,0x0015C), `Abs (0x0015D);
+  (0x0015E,0x0015E), `Abs (0x0015F);
+  (0x00160,0x00160), `Abs (0x00161);
+  (0x00162,0x00162), `Abs (0x00163);
+  (0x00164,0x00164), `Abs (0x00165);
+  (0x00166,0x00166), `Abs (0x00167);
+  (0x00168,0x00168), `Abs (0x00169);
+  (0x0016A,0x0016A), `Abs (0x0016B);
+  (0x0016C,0x0016C), `Abs (0x0016D);
+  (0x0016E,0x0016E), `Abs (0x0016F);
+  (0x00170,0x00170), `Abs (0x00171);
+  (0x00172,0x00172), `Abs (0x00173);
+  (0x00174,0x00174), `Abs (0x00175);
+  (0x00176,0x00176), `Abs (0x00177);
+  (0x00178,0x00178), `Abs (0x000FF);
+  (0x00179,0x00179), `Abs (0x0017A);
+  (0x0017B,0x0017B), `Abs (0x0017C);
+  (0x0017D,0x0017D), `Abs (0x0017E);
+  (0x00181,0x00181), `Abs (0x00253);
+  (0x00182,0x00182), `Abs (0x00183);
+  (0x00184,0x00184), `Abs (0x00185);
+  (0x00186,0x00186), `Abs (0x00254);
+  (0x00187,0x00187), `Abs (0x00188);
+  (0x00189,0x0018A), `Delta (205);
+  (0x0018B,0x0018B), `Abs (0x0018C);
+  (0x0018E,0x0018E), `Abs (0x001DD);
+  (0x0018F,0x0018F), `Abs (0x00259);
+  (0x00190,0x00190), `Abs (0x0025B);
+  (0x00191,0x00191), `Abs (0x00192);
+  (0x00193,0x00193), `Abs (0x00260);
+  (0x00194,0x00194), `Abs (0x00263);
+  (0x00196,0x00196), `Abs (0x00269);
+  (0x00197,0x00197), `Abs (0x00268);
+  (0x00198,0x00198), `Abs (0x00199);
+  (0x0019C,0x0019C), `Abs (0x0026F);
+  (0x0019D,0x0019D), `Abs (0x00272);
+  (0x0019F,0x0019F), `Abs (0x00275);
+  (0x001A0,0x001A0), `Abs (0x001A1);
+  (0x001A2,0x001A2), `Abs (0x001A3);
+  (0x001A4,0x001A4), `Abs (0x001A5);
+  (0x001A6,0x001A6), `Abs (0x00280);
+  (0x001A7,0x001A7), `Abs (0x001A8);
+  (0x001A9,0x001A9), `Abs (0x00283);
+  (0x001AC,0x001AC), `Abs (0x001AD);
+  (0x001AE,0x001AE), `Abs (0x00288);
+  (0x001AF,0x001AF), `Abs (0x001B0);
+  (0x001B1,0x001B2), `Delta (217);
+  (0x001B3,0x001B3), `Abs (0x001B4);
+  (0x001B5,0x001B5), `Abs (0x001B6);
+  (0x001B7,0x001B7), `Abs (0x00292);
+  (0x001B8,0x001B8), `Abs (0x001B9);
+  (0x001BC,0x001BC), `Abs (0x001BD);
+  (0x001C4,0x001C4), `Abs (0x001C6);
+  (0x001C7,0x001C7), `Abs (0x001C9);
+  (0x001CA,0x001CA), `Abs (0x001CC);
+  (0x001CD,0x001CD), `Abs (0x001CE);
+  (0x001CF,0x001CF), `Abs (0x001D0);
+  (0x001D1,0x001D1), `Abs (0x001D2);
+  (0x001D3,0x001D3), `Abs (0x001D4);
+  (0x001D5,0x001D5), `Abs (0x001D6);
+  (0x001D7,0x001D7), `Abs (0x001D8);
+  (0x001D9,0x001D9), `Abs (0x001DA);
+  (0x001DB,0x001DB), `Abs (0x001DC);
+  (0x001DE,0x001DE), `Abs (0x001DF);
+  (0x001E0,0x001E0), `Abs (0x001E1);
+  (0x001E2,0x001E2), `Abs (0x001E3);
+  (0x001E4,0x001E4), `Abs (0x001E5);
+  (0x001E6,0x001E6), `Abs (0x001E7);
+  (0x001E8,0x001E8), `Abs (0x001E9);
+  (0x001EA,0x001EA), `Abs (0x001EB);
+  (0x001EC,0x001EC), `Abs (0x001ED);
+  (0x001EE,0x001EE), `Abs (0x001EF);
+  (0x001F1,0x001F1), `Abs (0x001F3);
+  (0x001F4,0x001F4), `Abs (0x001F5);
+  (0x001F6,0x001F6), `Abs (0x00195);
+  (0x001F7,0x001F7), `Abs (0x001BF);
+  (0x001F8,0x001F8), `Abs (0x001F9);
+  (0x001FA,0x001FA), `Abs (0x001FB);
+  (0x001FC,0x001FC), `Abs (0x001FD);
+  (0x001FE,0x001FE), `Abs (0x001FF);
+  (0x00200,0x00200), `Abs (0x00201);
+  (0x00202,0x00202), `Abs (0x00203);
+  (0x00204,0x00204), `Abs (0x00205);
+  (0x00206,0x00206), `Abs (0x00207);
+  (0x00208,0x00208), `Abs (0x00209);
+  (0x0020A,0x0020A), `Abs (0x0020B);
+  (0x0020C,0x0020C), `Abs (0x0020D);
+  (0x0020E,0x0020E), `Abs (0x0020F);
+  (0x00210,0x00210), `Abs (0x00211);
+  (0x00212,0x00212), `Abs (0x00213);
+  (0x00214,0x00214), `Abs (0x00215);
+  (0x00216,0x00216), `Abs (0x00217);
+  (0x00218,0x00218), `Abs (0x00219);
+  (0x0021A,0x0021A), `Abs (0x0021B);
+  (0x0021C,0x0021C), `Abs (0x0021D);
+  (0x0021E,0x0021E), `Abs (0x0021F);
+  (0x00220,0x00220), `Abs (0x0019E);
+  (0x00222,0x00222), `Abs (0x00223);
+  (0x00224,0x00224), `Abs (0x00225);
+  (0x00226,0x00226), `Abs (0x00227);
+  (0x00228,0x00228), `Abs (0x00229);
+  (0x0022A,0x0022A), `Abs (0x0022B);
+  (0x0022C,0x0022C), `Abs (0x0022D);
+  (0x0022E,0x0022E), `Abs (0x0022F);
+  (0x00230,0x00230), `Abs (0x00231);
+  (0x00232,0x00232), `Abs (0x00233);
+  (0x00386,0x00386), `Abs (0x003AC);
+  (0x00388,0x0038A), `Delta (37);
+  (0x0038C,0x0038C), `Abs (0x003CC);
+  (0x0038E,0x0038F), `Delta (63);
+  (0x00391,0x003A1), `Delta (32);
+  (0x003A3,0x003AB), `Delta (32);
+  (0x003D8,0x003D8), `Abs (0x003D9);
+  (0x003DA,0x003DA), `Abs (0x003DB);
+  (0x003DC,0x003DC), `Abs (0x003DD);
+  (0x003DE,0x003DE), `Abs (0x003DF);
+  (0x003E0,0x003E0), `Abs (0x003E1);
+  (0x003E2,0x003E2), `Abs (0x003E3);
+  (0x003E4,0x003E4), `Abs (0x003E5);
+  (0x003E6,0x003E6), `Abs (0x003E7);
+  (0x003E8,0x003E8), `Abs (0x003E9);
+  (0x003EA,0x003EA), `Abs (0x003EB);
+  (0x003EC,0x003EC), `Abs (0x003ED);
+  (0x003EE,0x003EE), `Abs (0x003EF);
+  (0x003F4,0x003F4), `Abs (0x003B8);
+  (0x00400,0x0040F), `Delta (80);
+  (0x00410,0x0042F), `Delta (32);
+  (0x00460,0x00460), `Abs (0x00461);
+  (0x00462,0x00462), `Abs (0x00463);
+  (0x00464,0x00464), `Abs (0x00465);
+  (0x00466,0x00466), `Abs (0x00467);
+  (0x00468,0x00468), `Abs (0x00469);
+  (0x0046A,0x0046A), `Abs (0x0046B);
+  (0x0046C,0x0046C), `Abs (0x0046D);
+  (0x0046E,0x0046E), `Abs (0x0046F);
+  (0x00470,0x00470), `Abs (0x00471);
+  (0x00472,0x00472), `Abs (0x00473);
+  (0x00474,0x00474), `Abs (0x00475);
+  (0x00476,0x00476), `Abs (0x00477);
+  (0x00478,0x00478), `Abs (0x00479);
+  (0x0047A,0x0047A), `Abs (0x0047B);
+  (0x0047C,0x0047C), `Abs (0x0047D);
+  (0x0047E,0x0047E), `Abs (0x0047F);
+  (0x00480,0x00480), `Abs (0x00481);
+  (0x0048A,0x0048A), `Abs (0x0048B);
+  (0x0048C,0x0048C), `Abs (0x0048D);
+  (0x0048E,0x0048E), `Abs (0x0048F);
+  (0x00490,0x00490), `Abs (0x00491);
+  (0x00492,0x00492), `Abs (0x00493);
+  (0x00494,0x00494), `Abs (0x00495);
+  (0x00496,0x00496), `Abs (0x00497);
+  (0x00498,0x00498), `Abs (0x00499);
+  (0x0049A,0x0049A), `Abs (0x0049B);
+  (0x0049C,0x0049C), `Abs (0x0049D);
+  (0x0049E,0x0049E), `Abs (0x0049F);
+  (0x004A0,0x004A0), `Abs (0x004A1);
+  (0x004A2,0x004A2), `Abs (0x004A3);
+  (0x004A4,0x004A4), `Abs (0x004A5);
+  (0x004A6,0x004A6), `Abs (0x004A7);
+  (0x004A8,0x004A8), `Abs (0x004A9);
+  (0x004AA,0x004AA), `Abs (0x004AB);
+  (0x004AC,0x004AC), `Abs (0x004AD);
+  (0x004AE,0x004AE), `Abs (0x004AF);
+  (0x004B0,0x004B0), `Abs (0x004B1);
+  (0x004B2,0x004B2), `Abs (0x004B3);
+  (0x004B4,0x004B4), `Abs (0x004B5);
+  (0x004B6,0x004B6), `Abs (0x004B7);
+  (0x004B8,0x004B8), `Abs (0x004B9);
+  (0x004BA,0x004BA), `Abs (0x004BB);
+  (0x004BC,0x004BC), `Abs (0x004BD);
+  (0x004BE,0x004BE), `Abs (0x004BF);
+  (0x004C1,0x004C1), `Abs (0x004C2);
+  (0x004C3,0x004C3), `Abs (0x004C4);
+  (0x004C5,0x004C5), `Abs (0x004C6);
+  (0x004C7,0x004C7), `Abs (0x004C8);
+  (0x004C9,0x004C9), `Abs (0x004CA);
+  (0x004CB,0x004CB), `Abs (0x004CC);
+  (0x004CD,0x004CD), `Abs (0x004CE);
+  (0x004D0,0x004D0), `Abs (0x004D1);
+  (0x004D2,0x004D2), `Abs (0x004D3);
+  (0x004D4,0x004D4), `Abs (0x004D5);
+  (0x004D6,0x004D6), `Abs (0x004D7);
+  (0x004D8,0x004D8), `Abs (0x004D9);
+  (0x004DA,0x004DA), `Abs (0x004DB);
+  (0x004DC,0x004DC), `Abs (0x004DD);
+  (0x004DE,0x004DE), `Abs (0x004DF);
+  (0x004E0,0x004E0), `Abs (0x004E1);
+  (0x004E2,0x004E2), `Abs (0x004E3);
+  (0x004E4,0x004E4), `Abs (0x004E5);
+  (0x004E6,0x004E6), `Abs (0x004E7);
+  (0x004E8,0x004E8), `Abs (0x004E9);
+  (0x004EA,0x004EA), `Abs (0x004EB);
+  (0x004EC,0x004EC), `Abs (0x004ED);
+  (0x004EE,0x004EE), `Abs (0x004EF);
+  (0x004F0,0x004F0), `Abs (0x004F1);
+  (0x004F2,0x004F2), `Abs (0x004F3);
+  (0x004F4,0x004F4), `Abs (0x004F5);
+  (0x004F8,0x004F8), `Abs (0x004F9);
+  (0x00500,0x00500), `Abs (0x00501);
+  (0x00502,0x00502), `Abs (0x00503);
+  (0x00504,0x00504), `Abs (0x00505);
+  (0x00506,0x00506), `Abs (0x00507);
+  (0x00508,0x00508), `Abs (0x00509);
+  (0x0050A,0x0050A), `Abs (0x0050B);
+  (0x0050C,0x0050C), `Abs (0x0050D);
+  (0x0050E,0x0050E), `Abs (0x0050F);
+  (0x00531,0x00556), `Delta (48);
+  (0x01E00,0x01E00), `Abs (0x01E01);
+  (0x01E02,0x01E02), `Abs (0x01E03);
+  (0x01E04,0x01E04), `Abs (0x01E05);
+  (0x01E06,0x01E06), `Abs (0x01E07);
+  (0x01E08,0x01E08), `Abs (0x01E09);
+  (0x01E0A,0x01E0A), `Abs (0x01E0B);
+  (0x01E0C,0x01E0C), `Abs (0x01E0D);
+  (0x01E0E,0x01E0E), `Abs (0x01E0F);
+  (0x01E10,0x01E10), `Abs (0x01E11);
+  (0x01E12,0x01E12), `Abs (0x01E13);
+  (0x01E14,0x01E14), `Abs (0x01E15);
+  (0x01E16,0x01E16), `Abs (0x01E17);
+  (0x01E18,0x01E18), `Abs (0x01E19);
+  (0x01E1A,0x01E1A), `Abs (0x01E1B);
+  (0x01E1C,0x01E1C), `Abs (0x01E1D);
+  (0x01E1E,0x01E1E), `Abs (0x01E1F);
+  (0x01E20,0x01E20), `Abs (0x01E21);
+  (0x01E22,0x01E22), `Abs (0x01E23);
+  (0x01E24,0x01E24), `Abs (0x01E25);
+  (0x01E26,0x01E26), `Abs (0x01E27);
+  (0x01E28,0x01E28), `Abs (0x01E29);
+  (0x01E2A,0x01E2A), `Abs (0x01E2B);
+  (0x01E2C,0x01E2C), `Abs (0x01E2D);
+  (0x01E2E,0x01E2E), `Abs (0x01E2F);
+  (0x01E30,0x01E30), `Abs (0x01E31);
+  (0x01E32,0x01E32), `Abs (0x01E33);
+  (0x01E34,0x01E34), `Abs (0x01E35);
+  (0x01E36,0x01E36), `Abs (0x01E37);
+  (0x01E38,0x01E38), `Abs (0x01E39);
+  (0x01E3A,0x01E3A), `Abs (0x01E3B);
+  (0x01E3C,0x01E3C), `Abs (0x01E3D);
+  (0x01E3E,0x01E3E), `Abs (0x01E3F);
+  (0x01E40,0x01E40), `Abs (0x01E41);
+  (0x01E42,0x01E42), `Abs (0x01E43);
+  (0x01E44,0x01E44), `Abs (0x01E45);
+  (0x01E46,0x01E46), `Abs (0x01E47);
+  (0x01E48,0x01E48), `Abs (0x01E49);
+  (0x01E4A,0x01E4A), `Abs (0x01E4B);
+  (0x01E4C,0x01E4C), `Abs (0x01E4D);
+  (0x01E4E,0x01E4E), `Abs (0x01E4F);
+  (0x01E50,0x01E50), `Abs (0x01E51);
+  (0x01E52,0x01E52), `Abs (0x01E53);
+  (0x01E54,0x01E54), `Abs (0x01E55);
+  (0x01E56,0x01E56), `Abs (0x01E57);
+  (0x01E58,0x01E58), `Abs (0x01E59);
+  (0x01E5A,0x01E5A), `Abs (0x01E5B);
+  (0x01E5C,0x01E5C), `Abs (0x01E5D);
+  (0x01E5E,0x01E5E), `Abs (0x01E5F);
+  (0x01E60,0x01E60), `Abs (0x01E61);
+  (0x01E62,0x01E62), `Abs (0x01E63);
+  (0x01E64,0x01E64), `Abs (0x01E65);
+  (0x01E66,0x01E66), `Abs (0x01E67);
+  (0x01E68,0x01E68), `Abs (0x01E69);
+  (0x01E6A,0x01E6A), `Abs (0x01E6B);
+  (0x01E6C,0x01E6C), `Abs (0x01E6D);
+  (0x01E6E,0x01E6E), `Abs (0x01E6F);
+  (0x01E70,0x01E70), `Abs (0x01E71);
+  (0x01E72,0x01E72), `Abs (0x01E73);
+  (0x01E74,0x01E74), `Abs (0x01E75);
+  (0x01E76,0x01E76), `Abs (0x01E77);
+  (0x01E78,0x01E78), `Abs (0x01E79);
+  (0x01E7A,0x01E7A), `Abs (0x01E7B);
+  (0x01E7C,0x01E7C), `Abs (0x01E7D);
+  (0x01E7E,0x01E7E), `Abs (0x01E7F);
+  (0x01E80,0x01E80), `Abs (0x01E81);
+  (0x01E82,0x01E82), `Abs (0x01E83);
+  (0x01E84,0x01E84), `Abs (0x01E85);
+  (0x01E86,0x01E86), `Abs (0x01E87);
+  (0x01E88,0x01E88), `Abs (0x01E89);
+  (0x01E8A,0x01E8A), `Abs (0x01E8B);
+  (0x01E8C,0x01E8C), `Abs (0x01E8D);
+  (0x01E8E,0x01E8E), `Abs (0x01E8F);
+  (0x01E90,0x01E90), `Abs (0x01E91);
+  (0x01E92,0x01E92), `Abs (0x01E93);
+  (0x01E94,0x01E94), `Abs (0x01E95);
+  (0x01EA0,0x01EA0), `Abs (0x01EA1);
+  (0x01EA2,0x01EA2), `Abs (0x01EA3);
+  (0x01EA4,0x01EA4), `Abs (0x01EA5);
+  (0x01EA6,0x01EA6), `Abs (0x01EA7);
+  (0x01EA8,0x01EA8), `Abs (0x01EA9);
+  (0x01EAA,0x01EAA), `Abs (0x01EAB);
+  (0x01EAC,0x01EAC), `Abs (0x01EAD);
+  (0x01EAE,0x01EAE), `Abs (0x01EAF);
+  (0x01EB0,0x01EB0), `Abs (0x01EB1);
+  (0x01EB2,0x01EB2), `Abs (0x01EB3);
+  (0x01EB4,0x01EB4), `Abs (0x01EB5);
+  (0x01EB6,0x01EB6), `Abs (0x01EB7);
+  (0x01EB8,0x01EB8), `Abs (0x01EB9);
+  (0x01EBA,0x01EBA), `Abs (0x01EBB);
+  (0x01EBC,0x01EBC), `Abs (0x01EBD);
+  (0x01EBE,0x01EBE), `Abs (0x01EBF);
+  (0x01EC0,0x01EC0), `Abs (0x01EC1);
+  (0x01EC2,0x01EC2), `Abs (0x01EC3);
+  (0x01EC4,0x01EC4), `Abs (0x01EC5);
+  (0x01EC6,0x01EC6), `Abs (0x01EC7);
+  (0x01EC8,0x01EC8), `Abs (0x01EC9);
+  (0x01ECA,0x01ECA), `Abs (0x01ECB);
+  (0x01ECC,0x01ECC), `Abs (0x01ECD);
+  (0x01ECE,0x01ECE), `Abs (0x01ECF);
+  (0x01ED0,0x01ED0), `Abs (0x01ED1);
+  (0x01ED2,0x01ED2), `Abs (0x01ED3);
+  (0x01ED4,0x01ED4), `Abs (0x01ED5);
+  (0x01ED6,0x01ED6), `Abs (0x01ED7);
+  (0x01ED8,0x01ED8), `Abs (0x01ED9);
+  (0x01EDA,0x01EDA), `Abs (0x01EDB);
+  (0x01EDC,0x01EDC), `Abs (0x01EDD);
+  (0x01EDE,0x01EDE), `Abs (0x01EDF);
+  (0x01EE0,0x01EE0), `Abs (0x01EE1);
+  (0x01EE2,0x01EE2), `Abs (0x01EE3);
+  (0x01EE4,0x01EE4), `Abs (0x01EE5);
+  (0x01EE6,0x01EE6), `Abs (0x01EE7);
+  (0x01EE8,0x01EE8), `Abs (0x01EE9);
+  (0x01EEA,0x01EEA), `Abs (0x01EEB);
+  (0x01EEC,0x01EEC), `Abs (0x01EED);
+  (0x01EEE,0x01EEE), `Abs (0x01EEF);
+  (0x01EF0,0x01EF0), `Abs (0x01EF1);
+  (0x01EF2,0x01EF2), `Abs (0x01EF3);
+  (0x01EF4,0x01EF4), `Abs (0x01EF5);
+  (0x01EF6,0x01EF6), `Abs (0x01EF7);
+  (0x01EF8,0x01EF8), `Abs (0x01EF9);
+  (0x01F08,0x01F0F), `Delta (-8);
+  (0x01F18,0x01F1D), `Delta (-8);
+  (0x01F28,0x01F2F), `Delta (-8);
+  (0x01F38,0x01F3F), `Delta (-8);
+  (0x01F48,0x01F4D), `Delta (-8);
+  (0x01F59,0x01F59), `Abs (0x01F51);
+  (0x01F5B,0x01F5B), `Abs (0x01F53);
+  (0x01F5D,0x01F5D), `Abs (0x01F55);
+  (0x01F5F,0x01F5F), `Abs (0x01F57);
+  (0x01F68,0x01F6F), `Delta (-8);
+  (0x01FB8,0x01FB9), `Delta (-8);
+  (0x01FBA,0x01FBB), `Delta (-74);
+  (0x01FC8,0x01FCB), `Delta (-86);
+  (0x01FD8,0x01FD9), `Delta (-8);
+  (0x01FDA,0x01FDB), `Delta (-100);
+  (0x01FE8,0x01FE9), `Delta (-8);
+  (0x01FEA,0x01FEB), `Delta (-112);
+  (0x01FEC,0x01FEC), `Abs (0x01FE5);
+  (0x01FF8,0x01FF9), `Delta (-128);
+  (0x01FFA,0x01FFB), `Delta (-126);
+  (0x02126,0x02126), `Abs (0x003C9);
+  (0x0212A,0x0212A), `Abs (0x0006B);
+  (0x0212B,0x0212B), `Abs (0x000E5);
+  (0x0FF21,0x0FF3A), `Delta (32);
+  (0x10400,0x10425), `Delta (40);
+  (0x001C5,0x001C5), `Abs (0x001C6);
+  (0x001C8,0x001C8), `Abs (0x001C9);
+  (0x001CB,0x001CB), `Abs (0x001CC);
+  (0x001F2,0x001F2), `Abs (0x001F3);
+  (0x01F88,0x01F8F), `Delta (-8);
+  (0x01F98,0x01F9F), `Delta (-8);
+  (0x01FA8,0x01FAF), `Delta (-8);
+  (0x01FBC,0x01FBC), `Abs (0x01FB3);
+  (0x01FCC,0x01FCC), `Abs (0x01FC3);
+  (0x01FFC,0x01FFC), `Abs (0x01FF3);
+  (0x02160,0x0216F), `Delta (16)
+]
+
diff --git a/lib/util.ml b/lib/util.ml
index 0d6e7ff2..6d04c3c2 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: util.ml 13200 2010-06-25 22:36:25Z letouzey $ *)
+(* $Id$ *)
 
 open Pp
 
@@ -20,8 +20,15 @@ exception UserError of string * std_ppcmds (* User errors *)
 let error string = raise (UserError(string, str string))
 let errorlabstrm l pps = raise (UserError(l,pps))
 
+exception AnomalyOnError of string * exn
+
+exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
+let alreadydeclared pps = raise (AlreadyDeclared(pps))
+
 let todo s = prerr_string ("TODO: "^s^"\n")
 
+exception Timeout
+
 type loc = Compat.loc
 let dummy_loc = Compat.dummy_loc
 let unloc = Compat.unloc
@@ -34,7 +41,7 @@ let anomaly_loc (loc,s,strm) = Stdpp.raise_with_loc loc (Anomaly (s,strm))
 let user_err_loc (loc,s,strm) = Stdpp.raise_with_loc loc (UserError (s,strm))
 let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s)
 
-let located_fold_left f x (_,a) = f x a 
+let located_fold_left f x (_,a) = f x a
 let located_iter2 f (_,a) (_,b) = f a b
 
 (* Like Exc_located, but specifies the outermost file read, the filename
@@ -47,6 +54,12 @@ exception Error_in_file of string * (bool * string * loc) * exn
 let on_fst f (a,b) = (f a,b)
 let on_snd f (a,b) = (a,f b)
 
+(* Mapping under pairs *)
+
+let on_pi1 f (a,b,c) = (f a,b,c)
+let on_pi2 f (a,b,c) = (a,f b,c)
+let on_pi3 f (a,b,c) = (a,b,f c)
+
 (* Projections from triplets *)
 
 let pi1 (a,_,_) = a
@@ -65,13 +78,13 @@ let is_blank = function
 
 (* Strings *)
 
-let explode s = 
+let explode s =
   let rec explode_rec n =
     if n >= String.length s then
       []
-    else 
+    else
       String.make 1 (String.get s n) :: explode_rec (succ n)
-  in 
+  in
   explode_rec 0
 
 let implode sl = String.concat "" sl
@@ -91,16 +104,20 @@ let strip s =
   let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
   String.sub s a (b-a+1)
 
+let drop_simple_quotes s =
+  let n = String.length s in
+  if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
+
 (* substring searching... *)
 
 (* gdzie = where, co = what *)
 (* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
-let rec is_sub gdzie gl gi co cl ci = 
+let rec is_sub gdzie gl gi co cl ci =
   (ci>=cl) ||
-  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && 
+  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
    (is_sub gdzie gl (gi+1) co cl (ci+1)))
 
-let rec raw_str_index i gdzie l c co cl = 
+let rec raw_str_index i gdzie l c co cl =
   (* First adapt to ocaml 3.11 new semantics of index_from *)
   if (i+cl > l) then raise Not_found;
   (* Then proceed as in ocaml < 3.11 *)
@@ -108,7 +125,7 @@ let rec raw_str_index i gdzie l c co cl =
     if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else
       raw_str_index (i'+1) gdzie l c co cl
 
-let string_index_from gdzie i co = 
+let string_index_from gdzie i co =
   if co="" then i else
     raw_str_index i gdzie (String.length gdzie)
       (String.unsafe_get co 0) co (String.length co)
@@ -130,7 +147,7 @@ let ordinal n =
 let split_string_at c s =
   let len = String.length s in
   let rec split n =
-    try  
+    try
       let pos = String.index_from s n c in
       let dir = String.sub s n (pos-n) in
       dir :: split (succ pos)
@@ -153,138 +170,105 @@ type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
 
 exception UnsupportedUtf8
 
-let classify_unicode unicode =
-    match unicode land 0x1F000 with
-    | 0x0 ->
-    begin match unicode with
-    (* utf-8 Basic Latin underscore *)
-    | x when x = 0x005F -> UnicodeLetter
-    (* utf-8 Basic Latin letters *)
-    | x when 0x0041 <= x & x <= 0x005A -> UnicodeLetter
-    | x when 0x0061 <= x & x <= 0x007A -> UnicodeLetter
-    (* utf-8 Basic Latin digits and quote *)
-    | x when 0x0030 <= x & x <= 0x0039 or x = 0x0027 -> UnicodeIdentPart
-    (* utf-8 Basic Latin symbols *)
-    | x when x <= 0x007F -> UnicodeSymbol
-    (* utf-8 Latin-1 non breaking space U00A0 *)
-    | 0x00A0 -> UnicodeLetter
-    (* utf-8 Latin-1 symbols U00A1-00BF *)
-    | x when 0x00A0 <= x & x <= 0x00BF -> UnicodeSymbol
-    (* utf-8 Latin-1 letters U00C0-00D6 *)
-    | x when 0x00C0 <= x & x <= 0x00D6 -> UnicodeLetter
-    (* utf-8 Latin-1 symbol U00D7 *)
-    | 0x00D7 -> UnicodeSymbol
-    (* utf-8 Latin-1 letters U00D8-00F6 *)
-    | x when 0x00D8 <= x & x <= 0x00F6 -> UnicodeLetter
-    (* utf-8 Latin-1 symbol U00F7 *)
-    | 0x00F7 -> UnicodeSymbol
-    (* utf-8 Latin-1 letters U00F8-00FF *)
-    | x when 0x00F8 <= x & x <= 0x00FF -> UnicodeLetter
-    (* utf-8 Latin Extended A U0100-017F and Latin Extended B U0180-U0241 *)
-    | x when 0x0100 <= x & x <= 0x0241 -> UnicodeLetter
-    (* utf-8 Phonetic letters U0250-02AF *)
-    | x when 0x0250 <= x & x <= 0x02AF -> UnicodeLetter
-    (* utf-8 what do to with diacritics U0300-U036F ? *)
-    (* utf-8 Greek letters U0380-03FF *)
-    | x when 0x0380 <= x & x <= 0x03FF -> UnicodeLetter
-    (* utf-8 Cyrillic letters U0400-0481 *)
-    | x when 0x0400 <= x & x <= 0x0481 -> UnicodeLetter
-    (* utf-8 Cyrillic symbol U0482 *)
-    | 0x0482 -> UnicodeSymbol
-    (* utf-8 what do to with diacritics U0483-U0489 \ U0487 ? *)
-    (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *)
-    | x when 0x048A <= x & x <= 0x04F9 -> UnicodeLetter
-    (* utf-8 Cyrillic supplement letters U0500-U050F *)
-    | x when 0x0500 <= x & x <= 0x050F -> UnicodeLetter
-    (* utf-8 Hebrew letters U05D0-05EA *)
-    | x when 0x05D0 <= x & x <= 0x05EA -> UnicodeLetter
-    (* utf-8 Arabic letters U0621-064A *)
-    | x when 0x0621 <= x & x <= 0x064A -> UnicodeLetter
-    (* utf-8 Arabic supplement letters U0750-076D *)
-    | x when 0x0750 <= x & x <= 0x076D -> UnicodeLetter
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x1000 ->
-    begin match unicode with
-    (* utf-8 Georgian U10A0-10FF (has holes) *)
-    | x when 0x10A0 <= x & x <= 0x10FF -> UnicodeLetter
-    (* utf-8 Hangul Jamo U1100-11FF (has holes) *)
-    | x when 0x1100 <= x & x <= 0x11FF -> UnicodeLetter
-    (* utf-8 Latin additional letters U1E00-1E9B and U1EA0-1EF9 *)
-    | x when 0x1E00 <= x & x <= 0x1E9B -> UnicodeLetter
-    | x when 0x1EA0 <= x & x <= 0x1EF9 -> UnicodeLetter
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x2000 ->
-    begin match unicode with
-    (* utf-8 general punctuation U2080-2089 *)
-    (* Hyphens *)
-    | x when 0x2010 <= x & x <= 0x2011 -> UnicodeLetter 
-    (* Dashes and other symbols *)
-    | x when 0x2012 <= x & x <= 0x2027 -> UnicodeSymbol
-    (* Per mille and per ten thousand signs *)
-    | x when 0x2030 <= x & x <= 0x2031 -> UnicodeSymbol
-    (* Prime letters *)
-    | x when 0x2032 <= x & x <= 0x2034 or x = 0x2057 -> UnicodeIdentPart
-    (* Miscellaneous punctuation *)
-    | x when 0x2039 <= x & x <= 0x2056 -> UnicodeSymbol
-    | x when 0x2058 <= x & x <= 0x205E -> UnicodeSymbol
-    (* Invisible mathematical operators *)
-    | x when 0x2061 <= x & x <= 0x2063 -> UnicodeSymbol
-    (* utf-8 superscript U2070-207C *) 
-    | x when 0x2070 <= x & x <= 0x207C -> UnicodeSymbol
-    (* utf-8 subscript U2080-2089 *) 
-    | x when 0x2080 <= x & x <= 0x2089 -> UnicodeIdentPart
-    (* utf-8 letter-like U2100-214F *)
-    | x when 0x2100 <= x & x <= 0x214F -> UnicodeLetter
-    (* utf-8 number-forms U2153-2183 *)
-    | x when 0x2153 <= x & x <= 0x2183 -> UnicodeSymbol
-    (* utf-8 arrows A U2190-21FF *)
-    (* utf-8 mathematical operators U2200-22FF *)
-    (* utf-8 miscellaneous technical U2300-23FF *)
-    | x when 0x2190 <= x & x <= 0x23FF -> UnicodeSymbol
-    (* utf-8 box drawing U2500-257F has ceiling, etc. *)
-    (* utf-8 block elements U2580-259F *)
-    (* utf-8 geom. shapes U25A0-25FF (has triangles, losange, etc) *)
-    (* utf-8 miscellaneous symbols U2600-26FF *)
-    | x when 0x2500 <= x & x <= 0x26FF -> UnicodeSymbol
-    (* utf-8 arrows B U2900-297F *)
-    | x when 0x2900 <= x & x <= 0x297F -> UnicodeSymbol
-    (* utf-8 mathematical operators U2A00-2AFF *)
-    | x when 0x2A00 <= x & x <= 0x2AFF -> UnicodeSymbol
-    (* utf-8 bold symbols U2768-U2775 *)
-    | x when 0x2768 <= x & x <= 0x2775 -> UnicodeSymbol
-    (* utf-8 arrows and brackets U27E0-U27FF *)
-    | x when 0x27E0 <= x & x <= 0x27FF -> UnicodeSymbol
-    (* utf-8 brackets, braces and parentheses *)
-    | x when 0x2980 <= x & x <= 0x29FF -> UnicodeSymbol
-    (* utf-8 miscellaneous including double-plus U29F0-U29FF *)
-    | x when 0x29F0 <= x & x <= 0x29FF -> UnicodeSymbol
-    | _ -> raise UnsupportedUtf8
-    end
-    | _ ->
-    begin match unicode with
-    (* utf-8 CJC Symbols and Punctuation  *)
-    | x when 0x3008 <= x & x <= 0x3020 -> UnicodeSymbol
-    (* utf-8 Hiragana U3040-309F and Katakana U30A0-30FF *)
-    | x when 0x3040 <= x & x <= 0x30FF -> UnicodeLetter
-    (* utf-8 Unified CJK Ideographs U4E00-9FA5 *)
-    | x when 0x4E00 <= x & x <= 0x9FA5 -> UnicodeLetter
-    (* utf-8 Hangul syllables UAC00-D7AF *)
-    | x when 0xAC00 <= x & x <= 0xD7AF -> UnicodeLetter
-    (* utf-8 Gothic U10330-1034A *)
-    | x when 0x10330 <= x & x <= 0x1034A -> UnicodeLetter
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (letters) (has holes) *)
-    | x when 0x1D400 <= x & x <= 0x1D7CB -> UnicodeLetter
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (digits) *)
-    | x when 0x1D7CE <= x & x <= 0x1D7FF -> UnicodeIdentPart
-    | _ -> raise UnsupportedUtf8
-    end
+(* The following table stores classes of Unicode characters that
+   are used by the lexer. There are 3 different classes so 2 bits are
+   allocated for each character. We only use 16 bits over the 31 bits
+   to simplify the masking process. (This choice seems to be a good
+   trade-off between speed and space after some benchmarks.) *)
+
+(* A 256ko table, initially filled with zeros. *)
+let table = Array.create (1 lsl 17) 0
+
+(* Associate a 2-bit pattern to each status at position [i]. 
+   Only the 3 lowest bits of [i] are taken into account to 
+   define the position of the pattern in the word. 
+   Notice that pattern "00" means "undefined". *)
+let mask i = function
+  | UnicodeLetter    -> 1 lsl ((i land 7) lsl 1) (* 01 *)
+  | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
+  | UnicodeSymbol    -> 3 lsl ((i land 7) lsl 1) (* 11 *)
+
+(* Helper to reset 2 bits in a word. *)
+let reset_mask i =
+  lnot (3 lsl ((i land 7) lsl 1))
+
+(* Initialize the lookup table from a list of segments, assigning
+   a status to every character of each segment. The order of these
+   assignments is relevant: it is possible to assign status [s] to
+   a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
+   between [c1] and [c2]. *)
+let mk_lookup_table_from_unicode_tables_for status tables =
+  List.iter
+    (List.iter
+       (fun (c1, c2) ->
+          for i = c1 to c2 do
+            table.(i lsr 3) <-
+              (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
+          done))
+    tables
+
+(* Look up into the table and interpret the found pattern. *)
+let lookup x =
+  let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
+    if      v = 1 then UnicodeLetter
+    else if v = 2 then UnicodeIdentPart
+    else if v = 3 then UnicodeSymbol
+    else raise UnsupportedUtf8
+
+(* [classify_unicode] discriminates between 3 different kinds of
+   symbols based on the standard unicode classification (extracted from
+   Camomile). *)
+let classify_unicode =
+  let single c = [ (c, c) ] in
+    (* General tables. *)
+    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
+      [
+        Unicodetable.sm;           (* Symbol, maths.             *)
+        Unicodetable.sc;           (* Symbol, currency.          *)
+        Unicodetable.so;           (* Symbol, modifier.          *)
+        Unicodetable.pd;           (* Punctation, dash.          *)
+        Unicodetable.pc;           (* Punctation, connector.     *)
+        Unicodetable.pe;           (* Punctation, open.          *)
+        Unicodetable.ps;           (* Punctation, close.         *)
+        Unicodetable.pi;           (* Punctation, initial quote. *)
+        Unicodetable.pf;           (* Punctation, final quote.   *)
+        Unicodetable.po;           (* Punctation, other.         *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeLetter
+      [
+        Unicodetable.lu;           (* Letter, uppercase.         *)
+        Unicodetable.ll;           (* Letter, lowercase.         *)
+        Unicodetable.lt;           (* Letter, titlecase.         *)
+        Unicodetable.lo;           (* Letter, others.            *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
+      [
+        Unicodetable.nd;           (* Number, decimal digits.    *)
+        Unicodetable.nl;           (* Number, letter.            *)
+        Unicodetable.no;           (* Number, other.             *)
+      ];
+    (* Exceptions (from a previous version of this function). *)
+    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
+      [
+        single 0x000B2;            (* Squared.                   *)
+        single 0x0002E;            (* Dot.                       *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeLetter
+      [
+        single 0x005F;             (* Underscore.                *)
+        single 0x00A0;             (* Non breaking space.        *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
+      [
+        single 0x0027;             (* Special space.             *)
+      ];
+    (* Lookup *)
+    lookup
 
 exception End_of_input
 
 let utf8_of_unicode n =
-  if n < 128 then 
+  if n < 128 then
     String.make 1 (Char.chr n)
   else if n < 2048 then
     let s = String.make 2 (Char.chr (128 + n mod 64)) in
@@ -294,18 +278,18 @@ let utf8_of_unicode n =
     end
   else if n < 65536 then
     let s = String.make 3 (Char.chr (128 + n mod 64)) in
-    begin 
+    begin
       s.[1] <- Char.chr (128 + (n / 64) mod 64);
-      s.[0] <- Char.chr (224 + n / 4096); 
+      s.[0] <- Char.chr (224 + n / 4096);
       s
     end
   else
     let s = String.make 4 (Char.chr (128 + n mod 64)) in
-    begin 
+    begin
       s.[2] <- Char.chr (128 + (n / 64) mod 64);
       s.[1] <- Char.chr (128 + (n / 4096) mod 64);
       s.[0] <- Char.chr (240 + n / 262144);
-      s 
+      s
     end
 
 let next_utf8 s i =
@@ -358,7 +342,7 @@ let check_ident_gen handle s =
 	i := !i + j
       done
     with End_of_input -> ()
-  with 
+  with
   | End_of_input -> error "The empty string is not an identifier."
   | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.")
   | Invalid_argument _ -> error (s^": invalid utf8 sequence.")
@@ -366,127 +350,21 @@ let check_ident_gen handle s =
 let check_ident_soft = check_ident_gen warning
 let check_ident = check_ident_gen error
 
-let lowercase_unicode s unicode =
-    match unicode land 0x1F000 with
-    | 0x0 ->
-    begin match unicode with
-    (* utf-8 Basic Latin underscore *)
-    | x when x = 0x005F -> x
-    (* utf-8 Basic Latin letters *)
-    | x when 0x0041 <= x & x <= 0x005A -> x + 32
-    | x when 0x0061 <= x & x <= 0x007A -> x
-    (* utf-8 Latin-1 non breaking space U00A0 *)
-    | 0x00A0 as x -> x
-    (* utf-8 Latin-1 letters U00C0-00D6 *)
-    | x when 0x00C0 <= x & x <= 0x00D6 -> x + 32
-    (* utf-8 Latin-1 letters U00D8-00F6 *)
-    | x when 0x00D8 <= x & x <= 0x00DE -> x + 32
-    | x when 0x00E0 <= x & x <= 0x00F6 -> x
-    (* utf-8 Latin-1 letters U00F8-00FF *)
-    | x when 0x00F8 <= x & x <= 0x00FF -> x
-    (* utf-8 Latin Extended A U0100-017F and Latin Extended B U0180-U0241 *)
-    | x when 0x0100 <= x & x <= 0x017F ->
-	if x mod 2 = 1 then x else x + 1
-    | x when 0x0180 <= x & x <= 0x0241 ->
-	warning ("Unable to decide which lowercase letter to map to "^s); x
-    (* utf-8 Phonetic letters U0250-02AF *)
-    | x when 0x0250 <= x & x <= 0x02AF -> x
-    (* utf-8 what do to with diacritics U0300-U036F ? *)
-    (* utf-8 Greek letters U0380-03FF *)
-    | x when 0x0380 <= x & x <= 0x0385 -> x
-    | 0x0386 -> 0x03AC
-    | x when 0x0388 <= x & x <= 0x038A -> x + 37
-    | 0x038C -> 0x03CC
-    | x when 0x038E <= x & x <= 0x038F -> x + 63
-    | x when 0x0390 <= x & x <= 0x03AB & x <> 0x03A2 -> x + 32
-    (* utf-8 Greek lowercase letters U03B0-03CE *)	
-    | x when 0x03AC <= x & x <= 0x03CE -> x
-    | x when 0x03CF <= x & x <= 0x03FF ->
-	warning ("Unable to decide which lowercase letter to map to "^s); x
-    (* utf-8 Cyrillic letters U0400-0481 *)
-    | x when 0x0400 <= x & x <= 0x040F -> x + 80
-    | x when 0x0410 <= x & x <= 0x042F -> x + 32
-    | x when 0x0430 <= x & x <= 0x045F -> x 
-    | x when 0x0460 <= x & x <= 0x0481 ->
-	if x mod 2 = 1 then x else x + 1
-    (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *)
-    | x when 0x048A <= x & x <= 0x04F9 & x <> 0x04CF -> 
-	if x mod 2 = 1 then x else x + 1
-    (* utf-8 Cyrillic supplement letters U0500-U050F *)
-    | x when 0x0500 <= x & x <= 0x050F ->
-	if x mod 2 = 1 then x else x + 1
-    (* utf-8 Hebrew letters U05D0-05EA *)
-    | x when 0x05D0 <= x & x <= 0x05EA -> x
-    (* utf-8 Arabic letters U0621-064A *)
-    | x when 0x0621 <= x & x <= 0x064A -> x
-    (* utf-8 Arabic supplement letters U0750-076D *)
-    | x when 0x0750 <= x & x <= 0x076D -> x
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x1000 ->
-    begin match unicode with
-    (* utf-8 Georgian U10A0-10FF (has holes) *)
-    | x when 0x10A0 <= x & x <= 0x10FF -> x
-    (* utf-8 Hangul Jamo U1100-11FF (has holes) *)
-    | x when 0x1100 <= x & x <= 0x11FF -> x
-    (* utf-8 Latin additional letters U1E00-1E9B and U1EA0-1EF9 *)
-    | x when 0x1E00 <= x & x <= 0x1E95 ->
-	if x mod 2 = 1 then x else x + 1
-    | x when 0x1E96 <= x & x <= 0x1E9B -> x
-    | x when 0x1EA0 <= x & x <= 0x1EF9 ->
-	if x mod 2 = 1 then x else x + 1
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x2000 ->
-    begin match unicode with
-    (* utf-8 general punctuation U2080-2089 *)
-    (* Hyphens *)
-    | x when 0x2010 <= x & x <= 0x2011 -> x
-    (* utf-8 letter-like U2100-214F *)
-    | 0x2102 (* double-struck C *) -> Char.code 'x'
-    | 0x2115 (* double-struck N *) -> Char.code 'n'
-    | 0x2119 (* double-struck P *) -> Char.code 'x'
-    | 0x211A (* double-struck Q *) -> Char.code 'x'
-    | 0x211D (* double-struck R *) -> Char.code 'r'
-    | 0x2124 (* double-struck Z *) -> Char.code 'x'
-    | x when 0x2100 <= x & x <= 0x214F ->
-	warning ("Unable to decide which lowercase letter to map to "^s); x
-    | _ -> raise UnsupportedUtf8
-    end
-    | _ ->
-    begin match unicode with
-    (* utf-8 Hiragana U3040-309F and Katakana U30A0-30FF *)
-    | x when 0x3040 <= x & x <= 0x30FF -> x
-    (* utf-8 Unified CJK Ideographs U4E00-9FA5 *)
-    | x when 0x4E00 <= x & x <= 0x9FA5 -> x
-    (* utf-8 Hangul syllables UAC00-D7AF *)
-    | x when 0xAC00 <= x & x <= 0xD7AF -> x
-    (* utf-8 Gothic U10330-1034A *)
-    | x when 0x10330 <= x & x <= 0x1034A -> x
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (letters) (has holes) *)
-    | x when 0x1D6A8 <= x & x <= 0x1D7C9 ->
-        let a = (x - 0x1D6A8) mod 58 in
-        if a <= 16 or (18 <= a & a <= 24)
-        then x + 26 (* all but nabla and theta symbol *)
-        else x
-    | x when 0x1D538 <= x & x <= 0x1D56B ->
-        (* Use ordinary lowercase in both small and capital double-struck *)
-        (x - 0x1D538) mod 26 + Char.code 'a'
-    | x when 0x1D468 <= x & x <= 0x1D6A3 -> (* General case *)
-        if (x - 0x1D400 / 26) mod 2 = 0 then x + 26 else x
-    | x when 0x1D400 <= x & x <= 0x1D7CB -> (* fallback *)
-        x
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (digits) *)
-    | x when 0x1D7CE <= x & x <= 0x1D7FF -> x
-    | _ -> raise UnsupportedUtf8
-    end
+let lowercase_unicode =
+  let tree = Segmenttree.make Unicodetable.to_lower in
+  fun unicode ->
+    try
+      match Segmenttree.lookup unicode tree with
+	| `Abs c -> c
+	| `Delta d -> unicode + d
+    with Not_found -> unicode
 
 let lowercase_first_char_utf8 s =
   assert (s <> "");
   let j, n = next_utf8 s 0 in
-  utf8_of_unicode (lowercase_unicode (String.sub s 0 j) n)
+  utf8_of_unicode (lowercase_unicode n)
 
-(* For extraction, we need to encode unicode character into ascii ones *)
+(** For extraction, we need to encode unicode character into ascii ones *)
 
 let ascii_of_ident s =
   let check_ascii s =
@@ -499,50 +377,60 @@ let ascii_of_ident s =
     begin try while true do
       let j, n = next_utf8 s !i in
       out :=
-       if n >= 128
-       then Printf.sprintf "%s__U%04x_" !out n
-       else Printf.sprintf "%s%c" !out s.[!i];
+	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
 
 (* Lists *)
 
-let list_intersect l1 l2 = 
+let rec list_compare cmp l1 l2 =
+  match l1,l2 with
+      [], [] -> 0
+    | _::_, [] -> 1
+    | [], _::_ -> -1
+    | x1::l1, x2::l2 ->
+	(match cmp x1 x2 with
+	   | 0 -> list_compare cmp l1 l2
+	   | c -> c)
+
+let list_intersect l1 l2 =
   List.filter (fun x -> List.mem x l2) l1
 
-let list_union l1 l2 = 
+let list_union l1 l2 =
   let rec urec = function
     | [] -> l2
     | a::l -> if List.mem a l2 then urec l else a::urec l
-  in 
+  in
   urec l1
 
-let list_unionq l1 l2 = 
+let list_unionq l1 l2 =
   let rec urec = function
     | [] -> l2
     | a::l -> if List.memq a l2 then urec l else a::urec l
-  in 
+  in
   urec l1
 
 let list_subtract l1 l2 =
   if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1
 
-let list_subtractq l1 l2 = 
+let list_subtractq l1 l2 =
   if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1
 
-let list_chop n l = 
+let list_chop n l =
   let rec chop_aux acc = function
     | (0, l2) -> (List.rev acc, l2)
     | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
     | (_, []) -> failwith "list_chop"
-  in 
+  in
   chop_aux [] (n,l)
 
-let list_tabulate f len = 
+let list_tabulate f len =
   let rec tabrec n =
     if n = len then [] else (f n)::(tabrec (n+1))
-  in 
+  in
   tabrec 0
 
 let rec list_make n v =
@@ -550,41 +438,41 @@ let rec list_make n v =
   else if n < 0 then invalid_arg "list_make"
   else v::list_make (n-1) v
 
-let list_assign l n e = 
+let list_assign l n e =
   let rec assrec stk = function
     | ((h::t), 0) -> List.rev_append stk (e::t)
     | ((h::t), n) -> assrec (h::stk) (t, n-1)
     | ([], _) -> failwith "list_assign"
-  in 
+  in
   assrec [] (l,n)
 
 let rec list_smartmap f l = match l with
     [] -> l
-  | h::tl -> 
+  | h::tl ->
       let h' = f h and tl' = list_smartmap f tl in
 	if h'==h && tl'==tl then l
 	else h'::tl'
 
 let list_map_left f = (* ensures the order in case of side-effects *)
   let rec map_rec = function
-    | [] -> [] 
+    | [] -> []
     | x::l -> let v = f x in v :: map_rec l
-  in 
+  in
   map_rec
 
-let list_map_i f = 
+let list_map_i f =
   let rec map_i_rec i = function
-    | [] -> [] 
+    | [] -> []
     | x::l -> let v = f i x in v :: map_i_rec (i+1) l
-  in 
+  in
   map_i_rec
 
-let list_map2_i f i l1 l2 =  
+let list_map2_i f i l1 l2 =
   let rec map_i i = function
     | ([], []) -> []
     | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
     | (_, _) -> invalid_arg "map2_i"
-  in 
+  in
   map_i i (l1,l2)
 
 let list_map3 f l1 l2 l3 =
@@ -592,7 +480,7 @@ let list_map3 f l1 l2 l3 =
     | ([], [], []) -> []
     | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
     | (_, _, _) -> invalid_arg "map3"
-  in 
+  in
   map (l1,l2,l3)
 
 let list_map4 f l1 l2 l3 l4 =
@@ -600,41 +488,41 @@ let list_map4 f l1 l2 l3 l4 =
     | ([], [], [], []) -> []
     | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
     | (_, _, _, _) -> invalid_arg "map4"
-  in 
+  in
   map (l1,l2,l3,l4)
 
-let list_index x = 
+let list_index x =
   let rec index_x n = function
     | y::l -> if x = y then n else index_x (succ n) l
     | [] -> raise Not_found
-  in 
+  in
   index_x 1
 
-let list_index0 x l = list_index x l - 1 
+let list_index0 x l = list_index x l - 1
 
-let list_unique_index x = 
+let list_unique_index x =
   let rec index_x n = function
-    | y::l -> 
-	if x = y then 
+    | y::l ->
+	if x = y then
 	  if List.mem x l then raise Not_found
-	  else n 
+	  else n
 	else index_x (succ n) l
-    | [] -> raise Not_found 
+    | [] -> raise Not_found
   in index_x 1
 
 let list_fold_right_i f i l =
   let rec it_list_f i l a = match l with
     | [] -> a
     | b::l -> f (i-1) b (it_list_f (i-1) l a)
-  in 
+  in
   it_list_f (List.length l + i) l
 
-let list_fold_left_i f = 
+let list_fold_left_i f =
   let rec it_list_f i a = function
-    | [] -> a 
+    | [] -> a
     | b::l -> it_list_f (i+1) (f i a b) l
-  in 
-  it_list_f 
+  in
+  it_list_f
 
 let rec list_fold_left3 f accu l1 l2 l3 =
   match (l1, l2, l3) with
@@ -665,16 +553,16 @@ let list_iter3 f l1 l2 l3 =
     | ([], [], []) -> ()
     | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3)
     | (_, _, _) -> invalid_arg "map3"
-  in 
+  in
   iter (l1,l2,l3)
 
 let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l
 
-let list_for_all_i p = 
+let list_for_all_i p =
   let rec for_all_p i = function
-    | [] -> true 
+    | [] -> true
     | a::l -> p i a && for_all_p (i+1) l
-  in 
+  in
   for_all_p
 
 let list_except x l = List.filter (fun y -> not (x = y)) l
@@ -698,32 +586,33 @@ let list_eq_set l1 l2 =
   | a::l2 -> aux (list_remove_first a l1) l2 in
   try aux l1 l2 with Not_found -> false
 
-let list_for_all2eq f l1 l2 = try List.for_all2 f l1 l2 with Failure _ -> false
+let list_for_all2eq f l1 l2 =
+  try List.for_all2 f l1 l2 with Invalid_argument _ -> false
 
-let list_map_i f = 
-  let rec map_i_rec i = function
-    | [] -> [] 
-    | x::l -> let v = f i x in v::map_i_rec (i+1) l
-  in 
-  map_i_rec
+let list_filter_i p =
+  let rec filter_i_rec i = function
+    | [] -> []
+    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
+  in
+  filter_i_rec 0
 
 let rec list_sep_last = function
   | [] -> failwith "sep_last"
   | hd::[] -> (hd,[])
   | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
 
-let list_try_find_i f = 
+let list_try_find_i f =
   let rec try_find_f n = function
     | [] -> failwith "try_find_i"
     | h::t -> try f n h with Failure _ -> try_find_f (n+1) t
-  in 
+  in
   try_find_f
 
-let list_try_find f = 
+let list_try_find f =
   let rec try_find_f = function
     | [] -> failwith "try_find"
     | h::t -> try f h with Failure _ -> try_find_f t
-  in 
+  in
   try_find_f
 
 let list_uniquize l =
@@ -737,12 +626,12 @@ let list_uniquize l =
     | [] -> List.rev acc
   in aux [] l
 
-let rec list_distinct l = 
+let rec list_distinct l =
   let visited = Hashtbl.create 23 in
   let rec loop = function
     | h::t ->
 	if Hashtbl.mem visited h then false
-	else 
+	else
 	  begin
 	    Hashtbl.add visited h h;
 	    loop t
@@ -755,10 +644,10 @@ let rec list_merge_uniq cmp l1 l2 =
   | [], l2 -> l2
   | l1, [] -> l1
   | h1 :: t1, h2 :: t2 ->
-      let c = cmp h1 h2 in 
-      if c = 0 
+      let c = cmp h1 h2 in
+      if c = 0
       then h1 :: list_merge_uniq cmp t1 t2
-      else if c <= 0 
+      else if c <= 0
       then h1 :: list_merge_uniq cmp t1 l2
       else h2 :: list_merge_uniq cmp l1 t2
 
@@ -787,24 +676,29 @@ let list_subset l1 l2 =
   let rec look = function
     | [] -> true
     | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
-  in 
+  in
   look l1
 
-let list_split_at p = 
-  let rec split_at_loop x y = 
-    match y with 
-      | []      -> ([],[])
-      | (a::l)  -> if (p a) then (List.rev x,y) else split_at_loop (a::x) l
-  in 
-  split_at_loop []
-
-let list_split_by p = 
-  let rec split_loop = function
-  | []      -> ([],[])
-  | (a::l)  ->
-      let (l1,l2) = split_loop l in if (p a) then (a::l1,l2) else (l1,a::l2)
-  in 
-  split_loop
+(* [list_split_at i l] splits [l] into two lists [(l1,l2)] such that [l1++l2=l]
+    and [l1] has length [i].
+    It raises [Failure] when [i] is negative or greater than the length of [l]  *)
+let list_split_at index l =
+  let rec aux i acc = function
+      tl when i = index -> (List.rev acc), tl
+    | hd :: tl -> aux (succ i) (hd :: acc) tl
+    | [] -> failwith "list_split_at: Invalid argument"
+  in aux 0 [] l
+
+(* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that
+    [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
+    If there is no such [a], then it returns [(l,[])] instead *)
+let list_split_when p =
+  let rec split_when_loop x y =
+    match y with
+      | []      -> (List.rev x,[])
+      | (a::l)  -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
+  in
+  split_when_loop []
 
 let rec list_split3 = function
   | [] -> ([], [], [])
@@ -824,7 +718,7 @@ let list_firstn n l =
     | (0, l) -> List.rev acc
     | (n, (h::t)) -> aux (h::acc) (pred n, t)
     | _ -> failwith "firstn"
-  in 
+  in
   aux [] (n,l)
 
 let rec list_last = function
@@ -839,20 +733,23 @@ let list_lastn n l =
   in
   if len < n then failwith "lastn" else aux len l
 
-let rec list_skipn n l = match n,l with 
-  | 0, _ -> l 
-  | _, [] -> failwith "list_fromn"
+let rec list_skipn n l = match n,l with
+  | 0, _ -> l
+  | _, [] -> failwith "list_skipn"
   | n, _::l -> list_skipn (pred n) l
 
-let rec list_addn n x l = 
+let rec list_skipn_at_least n l =
+  try list_skipn n l with Failure _ -> []
+
+let rec list_addn n x l =
   if n = 0 then l else x :: (list_addn (pred n) x l)
 
-let list_prefix_of prefl l = 
+let list_prefix_of prefl l =
   let rec prefrec = function
     | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
     | ([], _) -> true
     | (_, _) -> false
-  in 
+  in
     prefrec (prefl,l)
 
 let list_drop_prefix p l =
@@ -860,7 +757,7 @@ let list_drop_prefix p l =
   let rec list_drop_prefix_rec = function
     | ([], tl) -> Some tl
     | (_, []) -> None
-    | (h1::tp, h2::tl) -> 
+    | (h1::tp, h2::tl) ->
 	if h1 = h2 then list_drop_prefix_rec (tp,tl) else None
   in
     match list_drop_prefix_rec (p,l) with
@@ -876,7 +773,7 @@ let list_share_tails l1 l2 =
   let rec shr_rev acc = function
     | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
     | (l1,l2) -> (List.rev l1, List.rev l2, acc)
-  in 
+  in
   shr_rev [] (List.rev l1, List.rev l2)
 
 let rec list_fold_map f e = function
@@ -887,10 +784,10 @@ let rec list_fold_map f e = function
          e'',h'::t'
 
 (* (* tail-recursive version of the above function *)
-let list_fold_map f e l = 
-  let g (e,b') h = 
+let list_fold_map f e l =
+  let g (e,b') h =
     let (e',h') = f e h in
-      (e',h'::b') 
+      (e',h'::b')
   in
   let (e',lrev) = List.fold_left g (e,[]) l in
     (e',List.rev lrev)
@@ -914,17 +811,17 @@ let list_union_map f l acc =
     acc
     l
 
-(* A generic cartesian product: for any operator (**), 
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], 
+(* A generic cartesian product: for any operator (**),
+   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
    and so on if there are more elements in the lists. *)
 
-let rec list_cartesian op l1 l2 = 
+let rec list_cartesian op l1 l2 =
   list_map_append (fun x -> List.map (op x) l2) l1
 
-(* [list_cartesians] is an n-ary cartesian product: it iterates 
+(* [list_cartesians] is an n-ary cartesian product: it iterates
    [list_cartesian] over a list of lists.  *)
 
-let list_cartesians op init ll = 
+let list_cartesians op init ll =
   List.fold_right (list_cartesian op) ll [init]
 
 (* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
@@ -933,12 +830,12 @@ let list_combinations l = list_cartesians (fun x l -> x::l) [] l
 
 (* Keep only those products that do not return None *)
 
-let rec list_cartesian_filter op l1 l2 = 
+let rec list_cartesian_filter op l1 l2 =
   list_map_append (fun x -> list_map_filter (op x) l2) l1
 
 (* Keep only those products that do not return None *)
 
-let rec list_cartesians_filter op init ll = 
+let rec list_cartesians_filter op init ll =
   List.fold_right (list_cartesian_filter op) ll [init]
 
 (* Drop the last element of a list *)
@@ -947,57 +844,76 @@ let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl
 
 (* Arrays *)
 
-let array_exists f v = 
+let array_compare item_cmp v1 v2 =
+  let c = compare (Array.length v1) (Array.length v2) in
+  if c<>0 then c else
+    let rec cmp = function
+	-1 -> 0
+      | i ->
+	  let c' = item_cmp v1.(i) v2.(i) in
+	  if c'<>0 then c'
+	  else cmp (i-1) in
+    cmp (Array.length v1 - 1)
+
+let array_exists f v =
   let rec exrec = function
     | -1 -> false
     | n -> (f v.(n)) || (exrec (n-1))
-  in 
-  exrec ((Array.length v)-1) 
+  in
+  exrec ((Array.length v)-1)
 
-let array_for_all f v = 
+let array_for_all f v =
   let rec allrec = function
     | -1 -> true
     | n -> (f v.(n)) && (allrec (n-1))
-  in 
-  allrec ((Array.length v)-1) 
+  in
+  allrec ((Array.length v)-1)
 
 let array_for_all2 f v1 v2 =
   let rec allrec = function
     | -1 -> true
     | n -> (f v1.(n) v2.(n)) && (allrec (n-1))
-  in 
+  in
   let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && allrec (pred lv1) 
+  lv1 = Array.length v2 && allrec (pred lv1)
 
 let array_for_all3 f v1 v2 v3 =
   let rec allrec = function
     | -1 -> true
     | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1))
-  in 
+  in
   let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) 
+  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
 
 let array_for_all4 f v1 v2 v3 v4 =
   let rec allrec = function
     | -1 -> true
     | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1))
-  in 
+  in
   let lv1 = Array.length v1 in
   lv1 = Array.length v2 &&
   lv1 = Array.length v3 &&
   lv1 = Array.length v4 &&
-    allrec (pred lv1) 
+    allrec (pred lv1)
 
-let array_for_all_i f i v = 
-  let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in 
+let array_for_all_i f i v =
+  let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in
   allrec i 0
 
-let array_hd v = 
+exception Found of int
+
+let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option =
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+    None
+  with Found i -> Some i
+
+let array_hd v =
   match Array.length v with
     | 0 -> failwith "array_hd"
     | _ -> v.(0)
 
-let array_tl v = 
+let array_tl v =
   match Array.length v with
     | 0 -> failwith "array_tl"
     | n -> Array.sub v 1 (pred n)
@@ -1009,12 +925,12 @@ let array_last v =
 
 let array_cons e v = Array.append [|e|] v
 
-let array_rev t = 
+let array_rev t =
   let n=Array.length t in
-    if n <=0 then () 
+    if n <=0 then ()
     else
       let tmp=ref t.(0) in
-      for i=0 to pred (n/2) do 
+      for i=0 to pred (n/2) do
 	tmp:=t.((pred n)-i);
 	t.((pred n)-i)<- t.(i);
 	t.(i)<- !tmp
@@ -1045,7 +961,7 @@ let array_fold_right2 f v1 v2 a =
 
 let array_fold_left2 f a v1 v2 =
   let lv1 = Array.length v1 in
-  let rec fold a n = 
+  let rec fold a n =
     if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n)
   in
   if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
@@ -1053,25 +969,25 @@ let array_fold_left2 f a v1 v2 =
 
 let array_fold_left2_i f a v1 v2 =
   let lv1 = Array.length v1 in
-  let rec fold a n = 
+  let rec fold a n =
     if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n)
   in
   if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
   fold a 0
 
-let array_fold_left_from n f a v = 
+let array_fold_left_from n f a v =
   let rec fold a n =
     if n >= Array.length v then a else fold (f a v.(n)) (succ n)
-  in 
+  in
   fold a n
 
-let array_fold_right_from n f v a = 
+let array_fold_right_from n f v a =
   let rec fold n =
     if n >= Array.length v then a else f v.(n) (fold (succ n))
-  in 
+  in
   fold n
 
-let array_app_tl v l = 
+let array_app_tl v l =
   if Array.length v = 0 then invalid_arg "array_app_tl";
   array_fold_right_from 1 (fun e l -> e::l) v l
 
@@ -1091,9 +1007,9 @@ exception Local of int
 
 (* If none of the elements is changed by f we return ar itself.
    The for loop looks for the first such an element.
-   If found it is temporarily stored in a ref and the new array is produced, 
+   If found it is temporarily stored in a ref and the new array is produced,
    but f is not re-applied to elements that are already checked *)
-let array_smartmap f ar = 
+let array_smartmap f ar =
   let ar_size = Array.length ar in
   let aux = ref None in
   try
@@ -1107,10 +1023,10 @@ let array_smartmap f ar =
     done;
     ar
   with
-      Local i -> 
-	let copy j = 
-	  if j<i then ar.(j) 
-	  else if j=i then 
+      Local i ->
+	let copy j =
+	  if j<i then ar.(j)
+	  else if j=i then
 	    match !aux with Some a' -> a' | None -> failwith "Error"
 	  else f (ar.(j))
 	in
@@ -1118,8 +1034,8 @@ let array_smartmap f ar =
 
 let array_map2 f v1 v2 =
   if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then 
-    [| |] 
+  if Array.length v1 == 0 then
+    [| |]
   else begin
     let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in
     for i = 1 to pred (Array.length v1) do
@@ -1130,8 +1046,8 @@ let array_map2 f v1 v2 =
 
 let array_map2_i f v1 v2 =
   if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then 
-    [| |] 
+  if Array.length v1 == 0 then
+    [| |]
   else begin
     let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in
     for i = 1 to pred (Array.length v1) do
@@ -1143,8 +1059,8 @@ let array_map2_i f v1 v2 =
 let array_map3 f v1 v2 v3 =
   if Array.length v1 <> Array.length v2 ||
      Array.length v1 <> Array.length v3 then invalid_arg "array_map3";
-  if Array.length v1 == 0 then 
-    [| |] 
+  if Array.length v1 == 0 then
+    [| |]
   else begin
     let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in
     for i = 1 to pred (Array.length v1) do
@@ -1185,7 +1101,7 @@ let pure_functional = false
 let array_fold_map' f v e =
 if pure_functional then
   let (l,e) =
-    Array.fold_right 
+    Array.fold_right
       (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
       v ([],e) in
   (Array.of_list l,e)
@@ -1201,8 +1117,8 @@ let array_fold_map f e v =
 
 let array_fold_map2' f v1 v2 e =
   let e' = ref e in
-  let v' = 
-    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 
+  let v' =
+    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
   in
   (v',!e')
 
@@ -1223,6 +1139,11 @@ let array_union_map f a acc =
     acc
     a
 
+let array_rev_to_list a =
+  let rec tolist i res =
+    if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
+  tolist 0 []
+
 (* Matrices *)
 
 let matrix_transpose mat =
@@ -1235,10 +1156,12 @@ let identity x = x
 
 let compose f g x = f (g x)
 
-let iterate f = 
+let const x _ = x
+
+let iterate f =
   let rec iterate_f n x =
     if n <= 0 then x else iterate_f (pred n) (f x)
-  in 
+  in
   iterate_f
 
 let repeat n f x =
@@ -1247,7 +1170,7 @@ let repeat n f x =
 let iterate_for a b f x =
   let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
   iterate a x
- 
+
 (* Misc *)
 
 type ('a,'b) union = Inl of 'a | Inr of 'b
@@ -1263,27 +1186,27 @@ let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m []
 
 let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m []
 
-let interval n m = 
+let interval n m =
   let rec interval_n (l,m) =
     if n > m then l else interval_n (m::l,pred m)
-  in 
+  in
   interval_n ([],m)
 
 
-let map_succeed f = 
-  let rec map_f = function 
+let map_succeed f =
+  let rec map_f = function
     | [] -> []
     |  h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t
-  in 
-  map_f 
+  in
+  map_f
 
 (* Pretty-printing *)
-  
+
 let pr_spc = spc
 let pr_fnl = fnl
 let pr_int = int
 let pr_str = str
-let pr_coma () = str "," ++ spc ()
+let pr_comma () = str "," ++ spc ()
 let pr_semicolon () = str ";" ++ spc ()
 let pr_bar () = str "|" ++ spc ()
 let pr_arg pr x = spc () ++ pr x
@@ -1294,7 +1217,7 @@ let nth n = str (ordinal n)
 
 (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
 
-let rec prlist elem l = match l with 
+let rec prlist elem l = match l with
   | []   -> mt ()
   | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t)
 
@@ -1302,7 +1225,7 @@ let rec prlist elem l = match l with
    if a strict behavior is needed, use [prlist_strict] instead.
    evaluation is done from left to right. *)
 
-let rec prlist_strict elem l = match l with 
+let rec prlist_strict elem l = match l with
   | []   -> mt ()
   | h::t ->
       let e = elem h in let r = prlist_strict elem t in e++r
@@ -1326,22 +1249,22 @@ let rec pr_sequence elem = function
       let e = elem h and r = pr_sequence elem t in
       if e = mt () then r else e ++ spc () ++ r
 
-(* [pr_enum pr [a ; b ; ... ; c]] outputs 
+(* [pr_enum pr [a ; b ; ... ; c]] outputs
    [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
 
 let pr_enum pr l =
   let c,l' = list_sep_last l in
-  prlist_with_sep pr_coma pr l' ++
+  prlist_with_sep pr_comma pr l' ++
   (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c
 
 let pr_vertical_list pr = function
   | [] -> str "none" ++ fnl ()
   | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl ()
-      
+
 let prvecti elem v =
   let n = Array.length v in
   let rec pr i =
-    if i = 0 then 
+    if i = 0 then
       elem 0 v.(0)
     else
       let r = pr (i-1) and e = elem i v.(i) in r ++ e
@@ -1353,10 +1276,10 @@ let prvecti elem v =
 
 let prvect_with_sep sep elem v =
   let rec pr n =
-    if n = 0 then 
+    if n = 0 then
       elem v.(0)
-    else 
-      let r = pr (n-1) and s = sep() and e = elem v.(n) in 
+    else
+      let r = pr (n-1) and s = sep() and e = elem v.(n) in
       r ++ s ++ e
       in
   let n = Array.length v in
@@ -1410,64 +1333,62 @@ let memon_eq eq n f =
 (*s Size of ocaml values. *)
 
 module Size = struct
-  
-  open Obj
 
   (*s Pointers already visited are stored in a hash-table, where
       comparisons are done using physical equality. *)
 
   module H = Hashtbl.Make(
-    struct 
-      type t = Obj.t 
-      let equal = (==) 
-      let hash o = Hashtbl.hash (magic o : int)
+    struct
+      type t = Obj.t
+      let equal = (==)
+      let hash o = Hashtbl.hash (Obj.magic o : int)
     end)
-	       
+
   let node_table = (H.create 257 : unit H.t)
-		     
+
   let in_table o = try H.find node_table o; true with Not_found -> false
-      
+
   let add_in_table o = H.add node_table o ()
-			 
+
   let reset_table () = H.clear node_table
-			 
+
   (*s Objects are traversed recursively, as soon as their tags are less than
       [no_scan_tag]. [count] records the numbers of words already visited. *)
 
-  let size_of_double = size (repr 1.0)
-			 
+  let size_of_double = Obj.size (Obj.repr 1.0)
+
   let count = ref 0
-		
+
   let rec traverse t =
     if not (in_table t) then begin
       add_in_table t;
-      if is_block t then begin
-	let n = size t in
-	let tag = tag t in
-	if tag < no_scan_tag then begin
+      if Obj.is_block t then begin
+	let n = Obj.size t in
+	let tag = Obj.tag t in
+	if tag < Obj.no_scan_tag then begin
 	  count := !count + 1 + n;
 	  for i = 0 to n - 1 do
-      	    let f = field t i in 
-	    if is_block f then traverse f
+      	    let f = Obj.field t i in
+	    if Obj.is_block f then traverse f
 	  done
-	end else if tag = string_tag then
-	  count := !count + 1 + n 
-	else if tag = double_tag then
+	end else if tag = Obj.string_tag then
+	  count := !count + 1 + n
+	else if tag = Obj.double_tag then
 	  count := !count + size_of_double
-	else if tag = double_array_tag then
-	  count := !count + 1 + size_of_double * n 
+	else if tag = Obj.double_array_tag then
+	  count := !count + 1 + size_of_double * n
 	else
 	  incr count
       end
     end
-      
+
   (*s Sizes of objects in words and in bytes. The size in bytes is computed
       system-independently according to [Sys.word_size]. *)
 
   let size_w o =
     reset_table ();
     count := 0;
-    traverse (repr o);
+    traverse (Obj.repr o);
     !count
 
   let size_b o = (size_w o) * (Sys.word_size / 8)
@@ -1493,6 +1414,5 @@ let heap_size_kb () = (heap_size () + 1023) / 1024
 (*s interruption *)
 
 let interrupt = ref false
-let check_for_interrupt () = 
+let check_for_interrupt () =
   if !interrupt then begin interrupt := false; raise Sys.Break end
-
diff --git a/lib/util.mli b/lib/util.mli
index 97bda074..cd8e3135 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: util.mli 13200 2010-06-25 22:36:25Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -26,12 +26,19 @@ exception UserError of string * std_ppcmds
 val error : string -> 'a
 val errorlabstrm : string -> std_ppcmds -> 'a
 
+exception AlreadyDeclared of std_ppcmds
+val alreadydeclared : std_ppcmds -> 'a
+
+exception AnomalyOnError of string * exn
+
 (* [todo] is for running of an incomplete code its implementation is
    "do nothing" (or print a message), but this function should not be
    used in a released code *)
 
 val todo : string -> unit
 
+exception Timeout
+
 type loc = Compat.loc
 
 type 'a located = loc * 'a
@@ -57,6 +64,12 @@ exception Error_in_file of string * (bool * string * loc) * exn
 val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
 val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
 
+(* Mapping under triple *)
+
+val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd
+val on_pi2 : ('a -> 'b) -> 'c * 'a * 'd -> 'c * 'b * 'd
+val on_pi3 : ('a -> 'b) -> 'c * 'd * 'a -> 'c * 'd * 'b
+
 (*s Projections from triplets *)
 
 val pi1 : 'a * 'b * 'c -> 'a
@@ -75,6 +88,7 @@ val is_blank : char -> bool
 val explode : string -> string list
 val implode : string list -> string
 val strip : string -> string
+val drop_simple_quotes : string -> string
 val string_index_from : string -> int -> string -> int
 val string_string_contains : where:string -> what:string -> bool
 val plural : int -> string -> string
@@ -98,6 +112,7 @@ val ascii_of_ident : string -> string
 
 (*s Lists. *)
 
+val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
 val list_add_set : 'a -> 'a list -> 'a list
 val list_eq_set : 'a list -> 'a list -> bool
 val list_intersect : 'a list -> 'a list -> 'a list
@@ -119,16 +134,18 @@ val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list
 val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
 val list_map_left : ('a -> 'b) -> 'a list -> 'b list
 val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
-val list_map2_i : 
+val list_map2_i :
   (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
 val list_map3 :
   ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
 val list_map4 :
   ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
+val list_filter_i :
+  (int -> 'a -> bool) -> 'a list -> 'a list
 (* [list_index] returns the 1st index of an element in a list (counting from 1) *)
 val list_index : 'a -> 'a list -> int
 (* [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
-val list_unique_index : 'a -> 'a list -> int 
+val list_unique_index : 'a -> 'a list -> int
 (* [list_index0] behaves as [list_index] except that it starts counting at 0 *)
 val list_index0 : 'a -> 'a list -> int
 val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit
@@ -151,16 +168,18 @@ val list_uniquize : 'a list -> 'a list
 (* merges two sorted lists and preserves the uniqueness property: *)
 val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
 val list_subset : 'a list -> 'a list -> bool
-val list_split_at : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list
+val list_split_at : int -> 'a list -> 'a list*'a list
+val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
 val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
 val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list
 val list_firstn : int -> 'a list -> 'a list
 val list_last : 'a list -> 'a
 val list_lastn : int -> 'a list -> 'a list
-val list_skipn : int -> 'a list -> 'a list 
+val list_skipn : int -> 'a list -> 'a list
+val list_skipn_at_least : int -> 'a list -> 'a list
 val list_addn : int -> 'a -> 'a list -> 'a list
 val list_prefix_of : 'a list -> 'a list -> bool
+(* [list_drop_prefix p l] returns [t] if [l=p++t] else return [l] *)
 val list_drop_prefix : 'a list -> 'a list -> 'a list
 val list_drop_last : 'a list -> 'a list
 (* [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *)
@@ -174,11 +193,11 @@ val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
 val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
 val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
 val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
-(* A generic cartesian product: for any operator (**), 
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], 
+(* A generic cartesian product: for any operator (**),
+   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
    and so on if there are more elements in the lists. *)
 val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-(* [list_cartesians] is an n-ary cartesian product: it iterates 
+(* [list_cartesians] is an n-ary cartesian product: it iterates
    [list_cartesian] over a list of lists.  *)
 val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
 (* list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
@@ -193,6 +212,7 @@ val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
 
 (*s Arrays. *)
 
+val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
 val array_exists : ('a -> bool) -> 'a array -> bool
 val array_for_all : ('a -> bool) -> 'a array -> bool
 val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
@@ -201,19 +221,20 @@ val array_for_all3 : ('a -> 'b -> 'c -> bool) ->
 val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
   'a array -> 'b array -> 'c array -> 'd array -> bool
 val array_for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+val array_find_i : (int -> 'a -> bool) -> 'a array -> int option
 val array_hd : 'a array -> 'a
 val array_tl : 'a array -> 'a array
 val array_last : 'a array -> 'a
 val array_cons : 'a -> 'a array -> 'a array
 val array_rev : 'a array -> unit
-val array_fold_right_i : 
+val array_fold_right_i :
   (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
 val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
 val array_fold_right2 :
   ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
-val array_fold_left2 : 
+val array_fold_left2 :
   ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left2_i : 
+val array_fold_left2_i :
   (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
 val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
 val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
@@ -224,7 +245,7 @@ val array_chop : int -> 'a array -> 'a array * 'a array
 val array_smartmap : ('a -> 'a) -> 'a array -> 'a array
 val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
 val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map3 : 
+val array_map3 :
   ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
 val array_map_left : ('a -> 'b) -> 'a array -> 'b array
 val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array ->
@@ -236,6 +257,7 @@ val array_fold_map2' :
   ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
 val array_distinct : 'a array -> bool
 val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
+val array_rev_to_list : 'a array -> 'a list
 
 (*s Matrices *)
 
@@ -245,6 +267,7 @@ val matrix_transpose : 'a list list -> 'a list list
 
 val identity : 'a -> 'a
 val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
+val const : 'a -> 'b -> 'a
 val iterate : ('a -> 'a) -> int -> 'a -> 'a
 val repeat : int -> ('a -> unit) -> 'a -> unit
 val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a
@@ -275,7 +298,7 @@ val pr_spc : unit -> std_ppcmds
 val pr_fnl : unit -> std_ppcmds
 val pr_int : int -> std_ppcmds
 val pr_str : string -> std_ppcmds
-val pr_coma : unit -> std_ppcmds
+val pr_comma : unit -> std_ppcmds
 val pr_semicolon : unit -> std_ppcmds
 val pr_bar : unit -> std_ppcmds
 val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml
index d6dfbb6b..5fd27f46 100644
--- a/library/decl_kinds.ml
+++ b/library/decl_kinds.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_kinds.ml 11809 2009-01-20 11:39:55Z aspiwack $ *)
+(* $Id$ *)
 
 open Util
 open Libnames
@@ -44,7 +44,7 @@ type definition_object_kind =
 
 type assumption_object_kind = Definitional | Logical | Conjectural
 
-(* [assumption_kind] 
+(* [assumption_kind]
 
                 |  Local      | Global
    ------------------------------------
diff --git a/library/decl_kinds.mli b/library/decl_kinds.mli
index 70c63c39..0ebab9ca 100644
--- a/library/decl_kinds.mli
+++ b/library/decl_kinds.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_kinds.mli 11809 2009-01-20 11:39:55Z aspiwack $ *)
+(* $Id$ *)
 
 open Util
 open Libnames
@@ -44,7 +44,7 @@ type definition_object_kind =
 
 type assumption_object_kind = Definitional | Logical | Conjectural
 
-(* [assumption_kind] 
+(* [assumption_kind]
 
                 |  Local      | Global
    ------------------------------------
diff --git a/library/declare.ml b/library/declare.ml
index c349bef1..3e4853c8 100644
--- a/library/declare.ml
+++ b/library/declare.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: declare.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 (** This module is about the low-level declaration of logical objects *)
 
@@ -27,11 +27,17 @@ open Cooking
 open Decls
 open Decl_kinds
 
+(** flag for internal message display *)
+type internal_flag = 
+  | KernelVerbose (* kernel action, a message is displayed *)
+  | KernelSilent  (* kernel action, no message is displayed *)
+  | UserVerbose   (* user action, a message is displayed *)
+
 (** XML output hooks *)
 
 let xml_declare_variable = ref (fun (sp:object_name) -> ())
-let xml_declare_constant = ref (fun (sp:bool * constant)-> ())
-let xml_declare_inductive = ref (fun (sp:bool * object_name) -> ())
+let xml_declare_constant = ref (fun (sp:internal_flag * constant)-> ())
+let xml_declare_inductive = ref (fun (sp:internal_flag * object_name) -> ())
 
 let if_xml f x = if !Flags.xml_export then f x else ()
 
@@ -39,11 +45,14 @@ let set_xml_declare_variable f = xml_declare_variable := if_xml f
 let set_xml_declare_constant f = xml_declare_constant := if_xml f
 let set_xml_declare_inductive f = xml_declare_inductive := if_xml f
 
+let cache_hook = ref ignore
+let add_cache_hook f = cache_hook := f
+
 (** Declaration of section variables and local definitions *)
 
 type section_variable_entry =
   | SectionLocalDef of constr * types option * bool (* opacity *)
-  | SectionLocalAssum of types * bool * identifier list (* Implicit status, Keep *)
+  | SectionLocalAssum of types * bool (* Implicit status *)
 
 type variable_declaration = dir_path * section_variable_entry * logical_kind
 
@@ -53,18 +62,17 @@ let cache_variable ((sp,_),o) =
   | Inr (id,(p,d,mk)) ->
   (* Constr raisonne sur les noms courts *)
   if variable_exists id then
-    errorlabstrm "cache_variable" (pr_id id ++ str " already exists");
-  let impl,opaq,cst,keep = match d with (* Fails if not well-typed *)
-    | SectionLocalAssum (ty, impl, keep) ->
+    alreadydeclared (pr_id id ++ str " already exists");
+  let impl,opaq,cst = match d with (* Fails if not well-typed *)
+    | SectionLocalAssum (ty, impl) ->
         let cst = Global.push_named_assum (id,ty) in
 	let impl = if impl then Lib.Implicit else Lib.Explicit in
-	let keep = if keep <> [] then Some (ty, keep) else None in
-	impl, true, cst, keep
-    | SectionLocalDef (c,t,opaq) -> 
+	impl, true, cst
+    | SectionLocalDef (c,t,opaq) ->
         let cst = Global.push_named_def (id,c,t) in
-        Lib.Explicit, opaq, cst, None in
+        Lib.Explicit, opaq, cst in
   Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id);
-  add_section_variable id impl keep;
+  add_section_variable id impl;
   Dischargedhypsmap.set_discharged_hyps sp [];
   add_variable_data id (p,opaq,cst,mk)
 
@@ -72,7 +80,7 @@ let discharge_variable (_,o) = match o with
   | Inr (id,_) -> Some (Inl (variable_constraints id))
   | Inl _ -> Some o
 
-let (inVariable, outVariable) =
+let (inVariable,_) =
   declare_object { (default_object "VARIABLE") with
     cache_function = cache_variable;
     discharge_function = discharge_variable;
@@ -87,6 +95,7 @@ let declare_variable id obj =
   !xml_declare_variable oname;
   oname
 
+
 (** Declaration of constants and parameters *)
 
 type constant_declaration = constant_entry * logical_kind
@@ -95,26 +104,28 @@ type constant_declaration = constant_entry * logical_kind
 (* section (if Remark or Fact) is needed to access a construction *)
 let load_constant i ((sp,kn),(_,_,kind)) =
   if Nametab.exists_cci sp then
-    errorlabstrm "cache_constant" 
-      (pr_id (basename sp) ++ str " already exists");
-  Nametab.push (Nametab.Until i) sp (ConstRef (constant_of_kn kn));
-  add_constant_kind (constant_of_kn kn) kind
+    alreadydeclared (pr_id (basename sp) ++ str " already exists");
+  let con = Global.constant_of_delta (constant_of_kn kn) in
+  Nametab.push (Nametab.Until i) sp (ConstRef con);
+  add_constant_kind con kind
 
 (* Opening means making the name without its module qualification available *)
 let open_constant i ((sp,kn),_) =
-  Nametab.push (Nametab.Exactly i) sp (ConstRef (constant_of_kn kn))
+  let con = Global.constant_of_delta (constant_of_kn kn) in
+    Nametab.push (Nametab.Exactly i) sp (ConstRef con)
 
 let cache_constant ((sp,kn),(cdt,dhyps,kind)) =
   let id = basename sp in
   let _,dir,_ = repr_kn kn in
   if variable_exists id or Nametab.exists_cci sp then
-    errorlabstrm "cache_constant" (pr_id id ++ str " already exists");
+    alreadydeclared (pr_id id ++ str " already exists");
   let kn' = Global.add_constant dir id cdt in
   assert (kn' = constant_of_kn kn);
   Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn));
   add_section_constant kn' (Global.lookup_constant kn').const_hyps;
   Dischargedhypsmap.set_discharged_hyps sp dhyps;
-  add_constant_kind (constant_of_kn kn) kind
+  add_constant_kind (constant_of_kn kn) kind;
+  !cache_hook sp
 
 let discharged_hyps kn sechyps =
   let (_,dir,_) = repr_kn kn in
@@ -134,19 +145,16 @@ let dummy_constant_entry = ConstantEntry (ParameterEntry (mkProp,false))
 
 let dummy_constant (ce,_,mk) = dummy_constant_entry,[],mk
 
-let export_constant cst = Some (dummy_constant cst)
-
-let classify_constant (_,cst) = Substitute (dummy_constant cst)
+let classify_constant cst = Substitute (dummy_constant cst)
 
-let (inConstant, outConstant) =
+let (inConstant,_) =
   declare_object { (default_object "CONSTANT") with
     cache_function = cache_constant;
     load_function = load_constant;
     open_function = open_constant;
     classify_function = classify_constant;
     subst_function = ident_subst_function;
-    discharge_function = discharge_constant;
-    export_function = export_constant } 
+    discharge_function = discharge_constant }
 
 let hcons_constant_declaration = function
   | DefinitionEntry ce when !Flags.hash_cons_proofs ->
@@ -154,17 +162,17 @@ let hcons_constant_declaration = function
       DefinitionEntry
        { const_entry_body = hcons1_constr ce.const_entry_body;
 	 const_entry_type = Option.map hcons1_constr ce.const_entry_type;
-         const_entry_opaque = ce.const_entry_opaque; 
+         const_entry_opaque = ce.const_entry_opaque;
          const_entry_boxed = ce.const_entry_boxed }
   | cd -> cd
 
 let declare_constant_common id dhyps (cd,kind) =
   let (sp,kn) = add_leaf id (inConstant (cd,dhyps,kind)) in
-  let kn = constant_of_kn kn in
-  declare_constant_implicits kn;
-  Heads.declare_head (EvalConstRef kn);
-  Notation.declare_ref_arguments_scope (ConstRef kn);
-  kn
+  let c = Global.constant_of_delta (constant_of_kn kn) in
+  declare_constant_implicits c;
+  Heads.declare_head (EvalConstRef c);
+  Notation.declare_ref_arguments_scope (ConstRef c);
+  c
 
 let declare_constant_gen internal id (cd,kind) =
   let cd = hcons_constant_declaration cd in
@@ -172,8 +180,10 @@ let declare_constant_gen internal id (cd,kind) =
   !xml_declare_constant (internal,kn);
   kn
 
-let declare_internal_constant = declare_constant_gen true
-let declare_constant = declare_constant_gen false
+(* TODO: add a third function to distinguish between KernelVerbose
+ * and user Verbose *)
+let declare_internal_constant = declare_constant_gen KernelSilent
+let declare_constant = declare_constant_gen UserVerbose
 
 (** Declaration of inductive blocks *)
 
@@ -186,14 +196,15 @@ let declare_inductive_argument_scopes kn mie =
 
 let inductive_names sp kn mie =
   let (dp,_) = repr_path sp in
-  let names, _ = 
+  let kn = Global.mind_of_delta (mind_of_kn kn) in
+  let names, _ =
     List.fold_left
       (fun (names, n) ind ->
 	 let ind_p = (kn,n) in
 	 let names, _ =
 	   List.fold_left
 	     (fun (names, p) l ->
-		let sp = 
+		let sp =
 		  Libnames.make_path dp l
 		in
 		  ((sp, ConstructRef (ind_p,p)) :: names, p+1))
@@ -206,16 +217,15 @@ let inductive_names sp kn mie =
 
 let check_exists_inductive (sp,_) =
   (if variable_exists (basename sp) then
-    errorlabstrm ""
-      (pr_id (basename sp) ++ str " already exists"));
+    alreadydeclared (pr_id (basename sp) ++ str " already exists"));
   if Nametab.exists_cci sp then
     let (_,id) = repr_path sp in
-    errorlabstrm "" (pr_id id ++ str " already exists")
+    alreadydeclared (pr_id id ++ str " already exists")
 
 let load_inductive i ((sp,kn),(_,mie)) =
   let names = inductive_names sp kn mie in
   List.iter check_exists_inductive names;
-  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref) names
+  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names
 
 let open_inductive i ((sp,kn),(_,mie)) =
   let names = inductive_names sp kn mie in
@@ -227,15 +237,18 @@ let cache_inductive ((sp,kn),(dhyps,mie)) =
   let id = basename sp in
   let _,dir,_ = repr_kn kn in
   let kn' = Global.add_mind dir id mie in
-  assert (kn'=kn);
-  add_section_kn kn (Global.lookup_mind kn').mind_hyps;
+  assert (kn'= mind_of_kn kn);
+  add_section_kn kn' (Global.lookup_mind kn').mind_hyps;
   Dischargedhypsmap.set_discharged_hyps sp dhyps;
-  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names
+  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names;
+  List.iter (fun (sp,_) -> !cache_hook sp) (inductive_names sp kn mie)
+
 
 let discharge_inductive ((sp,kn),(dhyps,mie)) =
-  let mie = Global.lookup_mind kn in
+  let mind = (Global.mind_of_delta (mind_of_kn kn)) in
+  let mie = Global.lookup_mind mind in
   let repl = replacement_context () in
-  let sechyps = section_segment_of_mutual_inductive kn in
+  let sechyps = section_segment_of_mutual_inductive mind in
   Some (discharged_hyps kn sechyps,
         Discharge.process_inductive (named_of_variable_context sechyps) repl mie)
 
@@ -253,17 +266,14 @@ let dummy_inductive_entry (_,m) = ([],{
   mind_entry_finite = true;
   mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds })
 
-let export_inductive x = Some (dummy_inductive_entry x)
-
-let (inInductive, outInductive) =
-  declare_object {(default_object "INDUCTIVE") with 
+let (inInductive,_) =
+  declare_object {(default_object "INDUCTIVE") with
     cache_function = cache_inductive;
     load_function = load_inductive;
     open_function = open_inductive;
-    classify_function = (fun (_,a) -> Substitute (dummy_inductive_entry a));
+    classify_function = (fun a -> Substitute (dummy_inductive_entry a));
     subst_function = ident_subst_function;
-    discharge_function = discharge_inductive;
-    export_function = export_inductive } 
+    discharge_function = discharge_inductive }
 
 (* for initial declaration *)
 let declare_mind isrecord mie =
@@ -271,8 +281,43 @@ let declare_mind isrecord mie =
     | ind::_ -> ind.mind_entry_typename
     | [] -> anomaly "cannot declare an empty list of inductives" in
   let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in
-  declare_mib_implicits kn;
-  declare_inductive_argument_scopes kn mie;
+  let mind = (Global.mind_of_delta (mind_of_kn kn)) in
+  declare_mib_implicits mind;
+  declare_inductive_argument_scopes mind mie;
   !xml_declare_inductive (isrecord,oname);
   oname
 
+(* Declaration messages *)
+
+let pr_rank i = str (ordinal (i+1))
+
+let fixpoint_message indexes l =
+  Flags.if_verbose msgnl (match l with
+  | [] -> anomaly "no recursive definition"
+  | [id] -> pr_id id ++ str " is recursively defined" ++
+      (match indexes with
+	 | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)"
+	 | _ -> mt ())
+  | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++
+		  spc () ++ str "are recursively defined" ++
+		  match indexes with
+		    | Some a -> spc () ++ str "(decreasing respectively on " ++
+			prlist_with_sep pr_comma pr_rank (Array.to_list a) ++
+			str " arguments)"
+		    | None -> mt ()))
+
+let cofixpoint_message l =
+  Flags.if_verbose msgnl (match l with
+  | [] -> anomaly "No corecursive definition."
+  | [id] -> pr_id id ++ str " is corecursively defined"
+  | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++
+                    spc () ++ str "are corecursively defined"))
+
+let recursive_message isfix i l =
+  (if isfix then fixpoint_message i else cofixpoint_message) l
+
+let definition_message id =
+  Flags.if_verbose msgnl (pr_id id ++ str " is defined")
+
+let assumption_message id =
+  Flags.if_verbose msgnl (pr_id id ++ str " is assumed")
diff --git a/library/declare.mli b/library/declare.mli
index 2f1cd06e..12e323f1 100644
--- a/library/declare.mli
+++ b/library/declare.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declare.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -21,11 +21,11 @@ open Nametab
 open Decl_kinds
 (*i*)
 
-(* This module provides the official functions to declare new variables, 
+(* This module provides the official functions to declare new variables,
    parameters, constants and inductive types. Using the following functions
    will add the entries in the global environment (module [Global]), will
    register the declarations in the library (module [Lib]) --- so that the
-   reset works properly --- and will fill some global tables such as 
+   reset works properly --- and will fill some global tables such as
    [Nametab] and [Impargs]. *)
 
 open Nametab
@@ -34,7 +34,7 @@ open Nametab
 
 type section_variable_entry =
   | SectionLocalDef of constr * types option * bool (* opacity *)
-  | SectionLocalAssum of types * bool * identifier list (* Implicit status, Keep list *)
+  | SectionLocalAssum of types * bool (* Implicit status *)
 
 type variable_declaration = dir_path * section_variable_entry * logical_kind
 
@@ -48,6 +48,11 @@ type constant_declaration = 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 *)
+type internal_flag =
+  | KernelVerbose
+  | KernelSilent
+  | UserVerbose
+
 val declare_constant :
  identifier -> constant_declaration -> constant
 
@@ -57,9 +62,22 @@ val declare_internal_constant :
 (* [declare_mind me] declares a block of inductive types with
    their constructors in the current section; it returns the path of
    the whole block (boolean must be true iff it is a record) *)
-val declare_mind : bool -> mutual_inductive_entry -> object_name
+val declare_mind : internal_flag -> mutual_inductive_entry -> object_name
 
-(* hooks for XML output *)
+(* Hooks for XML output *)
 val set_xml_declare_variable : (object_name -> unit) -> unit
-val set_xml_declare_constant : (bool * constant -> unit) -> unit
-val set_xml_declare_inductive : (bool * object_name -> unit) -> unit
+val set_xml_declare_constant : (internal_flag * constant -> unit) -> unit
+val set_xml_declare_inductive : (internal_flag * object_name -> unit) -> unit
+
+(* Hook for the cache function of constants and inductives *)
+val add_cache_hook : (full_path -> unit) -> unit
+
+(* Declaration messages *)
+
+val definition_message : identifier -> unit
+val assumption_message : identifier -> unit
+val fixpoint_message : int array option -> identifier list -> unit
+val cofixpoint_message : identifier list -> unit
+val recursive_message : bool (* true = fixpoint *) ->
+  int array option -> identifier list -> unit
+
diff --git a/library/declaremods.ml b/library/declaremods.ml
index cfada00c..4449c531 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -6,7 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declaremods.ml 12295 2009-08-27 11:01:49Z soubiran $ i*)
+(*i $Id$ i*)
+
 open Pp
 open Util
 open Names
@@ -21,7 +22,7 @@ open Mod_subst
 (* modules and components *)
 
 
-(* This type is a functional closure of substitutive lib_objects.
+(* OBSOLETE This type is a functional closure of substitutive lib_objects.
 
    The first part is a partial substitution (which will be later
    applied to lib_objects when completed).
@@ -39,157 +40,161 @@ open Mod_subst
    therefore must be substitued with valid names before use.
 
 *)
-type substitutive_objects = 
-    substitution * mod_bound_id list * mod_self_id * lib_objects
+type substitutive_objects =
+     mod_bound_id list * module_path * lib_objects
 
 
 (* For each module, we store the following things:
 
-   In modtab_substobjs: substitutive_objects 
-     when we will do Module M:=N, the objects of N will be reloaded 
+   In modtab_substobjs: substitutive_objects
+     when we will do Module M:=N, the objects of N will be reloaded
      with M after substitution
 
    In modtab_objects: "substituted objects" @ "keep objects"
 
-   substituted objects - 
-     roughly the objects above after the substitution - we need to 
+   substituted objects -
+     roughly the objects above after the substitution - we need to
      keep them to call open_object when the module is opened (imported)
- 
+
    keep objects -
-     The list of non-substitutive objects - as above, for each of 
-     them we will call open_object when the module is opened 
-     
+     The list of non-substitutive objects - as above, for each of
+     them we will call open_object when the module is opened
+
    (Some) Invariants:
    * If the module is a functor, the two latter lists are empty.
 
-   * Module objects in substitutive_objects part have empty substituted 
+   * Module objects in substitutive_objects part have empty substituted
      objects.
 
-   * Modules which where created with Module M:=mexpr or with 
+   * Modules which where created with Module M:=mexpr or with
      Module M:SIG. ... End M. have the keep list empty.
 *)
-let modtab_substobjs = 
+let modtab_substobjs =
   ref (MPmap.empty : substitutive_objects MPmap.t)
-let modtab_objects = 
+let modtab_objects =
   ref (MPmap.empty : (object_prefix * lib_objects) MPmap.t)
 
 
 (* currently started interactive module (if any) - its arguments (if it
    is a functor) and declared output type *)
-let openmod_info = 
-  ref (([],None,None) : mod_bound_id list * module_struct_entry option 
-                                          * struct_expr_body option) 
+let openmod_info =
+  ref ((MPfile(initial_dir),[],None,[])
+	 : module_path *  mod_bound_id list *
+           (module_struct_entry * bool) option * module_type_body list)
 
 (* The library_cache here is needed to avoid recalculations of
    substituted modules object during "reloading" of libraries *)
 let library_cache = ref Dirmap.empty
 
 let _ = Summary.declare_summary "MODULE-INFO"
-	  { Summary.freeze_function = (fun () -> 
+	  { Summary.freeze_function = (fun () ->
 					 !modtab_substobjs,
 					 !modtab_objects,
 					 !openmod_info,
 					 !library_cache);
-	    Summary.unfreeze_function = (fun (sobjs,objs,info,libcache) -> 
+	    Summary.unfreeze_function = (fun (sobjs,objs,info,libcache) ->
 					   modtab_substobjs := sobjs;
 					   modtab_objects := objs;
 					   openmod_info := info;
 					   library_cache := libcache);
-	    Summary.init_function = (fun () -> 
+	    Summary.init_function = (fun () ->
 				       modtab_substobjs := MPmap.empty;
 				       modtab_objects := MPmap.empty;
-				       openmod_info := ([],None,None);
-				       library_cache := Dirmap.empty);
-	    Summary.survive_module = false;
-	    Summary.survive_section = false }
+				       openmod_info := ((MPfile(initial_dir),
+							 [],None,[]));
+				       library_cache := Dirmap.empty) }
 
-(* auxiliary functions to transform section_path and kernel_name given
+(* auxiliary functions to transform full_path and kernel_name given
    by Lib into module_path and dir_path needed for modules *)
 
-let mp_of_kn kn = 
-  let mp,sec,l = repr_kn kn in 
-    if sec=empty_dirpath then 
-      MPdot (mp,l) 
+let mp_of_kn kn =
+  let mp,sec,l = repr_kn kn in
+    if sec=empty_dirpath then
+      MPdot (mp,l)
     else
       anomaly ("Non-empty section in module name!" ^ string_of_kn kn)
 
-let is_bound mp =
-  match mp with
-    | MPbound _ -> true
-    | _ -> false
-
-let dir_of_sp sp = 
+let dir_of_sp sp =
   let dir,id = repr_path sp in
-    extend_dirpath dir id
+    add_dirpath_suffix dir id
 
-let msid_of_mp = function
-    MPself msid -> msid
-  | _ -> anomaly "'Self' module path expected!"
+(* Subtyping checks *)
 
-let msid_of_prefix (_,(mp,sec)) = 
-  if sec=empty_dirpath then 
-    msid_of_mp mp
-  else
-    anomaly ("Non-empty section in module name!" ^ 
-	     string_of_mp mp ^ "." ^ string_of_dirpath sec)
-
-let scrape_alias mp =
-  Environ.scrape_alias mp (Global.env())
-	
+let check_sub mtb sub_mtb_l =
+  (* The constraints are checked and forgot immediately : *)
+  ignore (List.fold_right
+	    (fun sub_mtb env ->
+	       Environ.add_constraints
+		 (Subtyping.check_subtypes env mtb sub_mtb) env)
+	    sub_mtb_l (Global.env()))
 
 (* This function checks if the type calculated for the module [mp] is
-   a subtype of [sub_mtb]. Uses only the global environment. *)
-let check_subtypes mp sub_mtb =
-  let env = Global.env () in
-  let mtb = Environ.lookup_modtype mp env in
-  let sub_mtb = 
-    {typ_expr = sub_mtb;
-    typ_strength = None;
-    typ_alias = empty_subst} in
-  let _ = Environ.add_constraints 
-	    (Subtyping.check_subtypes env mtb sub_mtb) 
-  in
-    ()  (* The constraints are checked and forgot immediately! *) 
+   a subtype of all signatures in [sub_mtb_l]. Uses only the global
+   environment. *)
 
-let compute_subst_objects mp (subst,mbids,msid,objs) =
-  match mbids with
-  | [] -> 
-      let subst' = join_alias (map_msid msid mp) subst in
-      Some (join (map_msid msid mp) (join subst' subst), objs)
-  | _ ->
-      None
+let check_subtypes mp sub_mtb_l =
+  let env = Global.env () in
+  let mb = Environ.lookup_module mp env in
+  let mtb = Modops.module_type_of_module env None mb in
+  check_sub mtb sub_mtb_l
+
+(* Same for module type [mp] *)
+
+let check_subtypes_mt mp sub_mtb_l =
+  check_sub (Environ.lookup_modtype mp (Global.env())) sub_mtb_l
+
+(* Create a functor type entry *)
+
+let funct_entry args m =
+  List.fold_right
+    (fun (arg_id,(arg_t,_)) mte -> MSEfunctor (arg_id,arg_t,mte))
+    args m
+
+(* Prepare the module type list for check of subtypes *)
+
+let build_subtypes interp_modtype mp args mtys =
+  List.map
+    (fun (m,inl) ->
+       let mte = interp_modtype (Global.env()) m in
+       let mtb = Mod_typing.translate_module_type (Global.env()) mp inl mte in
+       let funct_mtb =
+	 List.fold_right
+           (fun (arg_id,(arg_t,arg_inl)) mte ->
+              let arg_t =
+		Mod_typing.translate_module_type (Global.env())
+		  (MPbound arg_id) arg_inl arg_t
+	      in
+              SEBfunctor(arg_id,arg_t,mte))
+           args mtb.typ_expr
+       in
+       { mtb with typ_expr = funct_mtb })
+    mtys
 
-let subst_substobjs dir mp substobjs =
-  match compute_subst_objects mp substobjs with
-  | Some (subst, objs) ->
-	let prefix = dir,(mp,empty_dirpath) in
-	Some (subst_objects prefix subst objs)
-  | None -> None
 
 (* These functions register the visibility of the module and iterates
    through its components. They are called by plenty module functions *)
 
 let compute_visibility exists what i dir dirinfo =
-  if exists then 
-    if 
-      try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo 
-      with Not_found -> false 
+  if exists then
+    if
+      try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo
+      with Not_found -> false
     then
       Nametab.Exactly i
     else
       errorlabstrm (what^"_module")
-	(pr_dirpath dir ++ str " should already exist!") 
+	(pr_dirpath dir ++ str " should already exist!")
   else
     if Nametab.exists_dir dir then
       errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists")
     else
       Nametab.Until i
-
+(*
 let do_load_and_subst_module i dir mp substobjs keep =
   let prefix = (dir,(mp,empty_dirpath)) in
   let dirinfo = DirModule (dir,(mp,empty_dirpath)) in
   let vis = compute_visibility false "load_and_subst" i dir dirinfo in
-  let objects = compute_subst_objects mp substobjs in
+  let objects = compute_subst_objects mp substobjs resolver in
   Nametab.push_dir vis dir dirinfo;
   modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs;
   match objects with
@@ -200,101 +205,63 @@ let do_load_and_subst_module i dir mp substobjs keep =
       Some (seg@keep)
   | None ->
       None
+*)
 
-let do_module exists what iter_objects i dir mp substobjs objects =
+let do_module exists what iter_objects i dir mp substobjs keep=
   let prefix = (dir,(mp,empty_dirpath)) in
   let dirinfo = DirModule (dir,(mp,empty_dirpath)) in
   let vis = compute_visibility exists what i dir dirinfo in
     Nametab.push_dir vis dir dirinfo;
     modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs;
-    match objects with
-	Some seg -> 
-	  modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects;
-	  iter_objects (i+1) prefix seg	  
-      | None ->  ()
-
-let conv_names_do_module exists what iter_objects i 
-      (sp,kn) substobjs substituted =
+    match substobjs with
+	([],mp1,objs) -> 
+	  modtab_objects := MPmap.add mp (prefix,objs@keep) !modtab_objects;
+	  iter_objects (i+1) prefix (objs@keep)  
+      | (mbids,_,_) ->  ()
+
+let conv_names_do_module exists what iter_objects i
+      (sp,kn) substobjs =
   let dir,mp = dir_of_sp sp, mp_of_kn kn in
-  do_module exists what iter_objects i dir mp substobjs substituted
+  do_module exists what iter_objects i dir mp substobjs []
 
 (* Interactive modules and module types cannot be recached! cache_mod*
    functions can be called only once (and "end_mod*" set the flag to
    false then)
 *)
-
-let cache_module ((sp,kn as oname),(entry,substobjs,substituted)) =
-  let _ = match entry with
-    | None ->
-	anomaly "You must not recache interactive modules!"
-    | Some (me,sub_mte_o) ->
-	let sub_mtb_o = match sub_mte_o with 
-	    None -> None
-	  | Some mte -> Some (Mod_typing.translate_struct_entry
-				(Global.env()) mte)
-	in
-	  
-	let mp = Global.add_module (basename sp) me in
-	  if mp <> mp_of_kn kn then
-	    anomaly "Kernel and Library names do not match";
-	  
-	  match sub_mtb_o with
-	      None -> ()
-	    | Some (sub_mtb,sub) -> 
-		check_subtypes mp sub_mtb
-
-  in
-  conv_names_do_module false "cache" load_objects 1 oname substobjs substituted
-
-
-
-
+let cache_module ((sp,kn),(entry,substobjs)) =
+  let dir,mp = dir_of_sp sp, mp_of_kn kn in
+    do_module false "cache" load_objects 1 dir mp substobjs []
+    
 (* TODO: This check is not essential *)
 let check_empty s = function
      | None -> ()
-     | Some _ -> 
+     | Some _ ->
 	 anomaly ("We should never have full info in " ^ s^"!")
 
 
 (* When this function is called the module itself is already in the
    environment. This function loads its objects only *)
 
-let load_module i (oname,(entry,substobjs,substituted)) =
+let load_module i (oname,(entry,substobjs)) =
   (* TODO: This check is not essential *)
   check_empty "load_module" entry;
-  conv_names_do_module false "load" load_objects i oname substobjs substituted
+  conv_names_do_module false "load" load_objects i oname substobjs
 
 
-let open_module i (oname,(entry,substobjs,substituted)) =
+let open_module i (oname,(entry,substobjs)) =
   (* TODO: This check is not essential *)
   check_empty "open_module" entry;
-  conv_names_do_module true "open" open_objects i oname substobjs substituted
+  conv_names_do_module true "open" open_objects i oname substobjs
 
 
 
-let subst_module ((sp,kn),subst,(entry,substobjs,_)) =
+let subst_module (subst,(entry,(mbids,mp,objs))) =
   check_empty "subst_module" entry;
-  let dir,mp = dir_of_sp sp, mp_of_kn kn in
-  let (sub,mbids,msid,objs) = substobjs in
-  let sub = subst_key subst sub in
-  let sub' = update_subst_alias subst sub in
-  let sub' = update_subst_alias sub' (map_msid msid mp) in
- (* let sub = join_alias sub sub' in*)
-  let sub = join sub' sub in
-  let subst' = join sub subst in
-  (* substitutive_objects get the new substitution *)
-  let substobjs = (subst',mbids,msid,objs) in
-  (* if we are not a functor - calculate substitued.
-     We add "msid |-> mp" to the substitution *)
-  let substituted = subst_substobjs dir mp substobjs
-  in
-    (None,substobjs,substituted)
-
-
-let classify_module (_,(_,substobjs,_)) =
-  Substitute (None,substobjs,None)
+    (None,(mbids,subst_mp subst mp, subst_objects subst objs))
 
 
+let classify_module (_,substobjs) =
+  Substitute (None,substobjs)
 
 let (in_module,out_module) =
   declare_object {(default_object "MODULE") with
@@ -302,182 +269,17 @@ let (in_module,out_module) =
     load_function = load_module;
     open_function = open_module;
     subst_function = subst_module;
-    classify_function = classify_module;
-    export_function = (fun _ -> anomaly "No modules in sections!") }
-
-
-let rec replace_alias modalias_obj obj =
-  let rec put_alias (id_alias,obj_alias) l =
-    match l with 
-	[] -> []
-      | (id,o)::r 
-	  when ( object_tag o = "MODULE") ->
-	  if id = id_alias then
-(*	    let (entry,subst_o,substed_o) = out_module_alias obj_alias in
-	    let (entry',subst_o',substed_o') = out_module o in
-	      begin
-		match substed_o,substed_o' with
-		    Some a,Some b ->
-		      (id,in_module_alias 
-			 (entry,subst_o',Some (dump_alias_object a b)))::r*)
-	    (id_alias,obj_alias)::r
-		 (* | _,_ -> (id,o)::r
-	      end*)
-	  else (id,o)::(put_alias (id_alias,obj_alias) r)
-      | e::r -> e::(put_alias (id_alias,obj_alias) r) in
-  let rec choose_obj_alias list_alias list_obj =
-    match list_alias with
-      | [] -> list_obj
-      | o::r ->choose_obj_alias r (put_alias o list_obj) in
-    choose_obj_alias modalias_obj obj
-	  
-and dump_alias_object alias_obj obj =
-  let rec alias_in_obj seg =
-    match seg with
-      | [] -> []
-      | (id,o)::r when (object_tag o = "MODULE ALIAS") -> 
-	  (id,o)::(alias_in_obj r)
-      | e::r -> (alias_in_obj r) in
-  let modalias_obj = alias_in_obj alias_obj in
-    replace_alias modalias_obj obj
-      
-and do_module_alias exists what iter_objects i dir mp alias substobjs objects =
-  let prefix = (dir,(alias,empty_dirpath)) in
-  let alias_objects = 
-    try Some (MPmap.find alias !modtab_objects) with
-	Not_found -> None in
-  let dirinfo = DirModule (dir,(mp,empty_dirpath)) in
-  let vis = compute_visibility exists what i dir dirinfo in
-    Nametab.push_dir vis dir dirinfo;
-    modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs;
-    match alias_objects,objects with
-	Some (_,seg), Some seg' -> 
-	  let new_seg = dump_alias_object seg seg' in
-	  modtab_objects := MPmap.add mp (prefix,new_seg) !modtab_objects;
-	  iter_objects (i+1) prefix new_seg 	  
-      | _,_->  ()
-
-and cache_module_alias ((sp,kn),(entry,substobjs,substituted)) =
-  let dir,mp,alias = match entry with
-    | None ->
-	anomaly "You must not recache interactive modules!"
-    | Some (me,sub_mte_o) ->
-	let sub_mtb_o = match sub_mte_o with 
-	    None -> None
-	  | Some mte -> Some (Mod_typing.translate_struct_entry
-				(Global.env()) mte)
-	in
-
-	let mp' = match me with 
-	  | {mod_entry_type = None;
-	     mod_entry_expr = Some (MSEident mp)} ->
-	      Global.add_alias (basename sp) mp	 
-	  | _ -> anomaly "cache module alias"
-	in
-	  if mp' <> mp_of_kn kn then
-	    anomaly "Kernel and Library names do not match";
-	  
-	  let _ = match sub_mtb_o with
-	      None -> ()
-	    | Some (sub_mtb,sub) -> 
-	      check_subtypes mp' sub_mtb in
-	    match me with
-	      | {mod_entry_type = None;
-		 mod_entry_expr = Some (MSEident mp)} ->
-		    dir_of_sp sp,mp_of_kn kn,scrape_alias mp		
-	      | _ -> anomaly "cache module alias"
-  in
-    do_module_alias false "cache" load_objects 1 dir mp alias substobjs substituted
-
-and load_module_alias i ((sp,kn),(entry,substobjs,substituted)) =
-  let dir,mp,alias= 
-    match entry with 
-      | Some (me,_)->
-	  begin
-	    match me with
-	      |{mod_entry_type = None;
-		mod_entry_expr = Some (MSEident mp)} ->
-		 dir_of_sp sp,mp_of_kn kn,scrape_alias mp
-	      | _ -> anomaly "Modops: Not an alias"
-	  end
-      | None -> anomaly "Modops: Empty info"
-  in
-    do_module_alias false "load" load_objects i dir mp alias substobjs substituted
-
-and open_module_alias i ((sp,kn),(entry,substobjs,substituted)) =
-  let dir,mp,alias=
-    match entry with 
-      | Some (me,_)->
-	  begin
-	    match me with
-	      |{mod_entry_type = None;
-		mod_entry_expr = Some (MSEident mp)} ->
-		 dir_of_sp sp,mp_of_kn kn,scrape_alias mp
-	      | _ -> anomaly "Modops: Not an alias"
-	  end
-      | None -> anomaly "Modops: Empty info"
-  in
-    do_module_alias true "open" open_objects i dir mp alias substobjs substituted
-
-and subst_module_alias ((sp,kn),subst,(entry,substobjs,_)) =
-  let dir,mp = dir_of_sp sp, mp_of_kn kn in
-  let (sub,mbids,msid,objs) = substobjs in
-  let sub' = update_subst_alias subst (map_msid msid mp) in
-  let subst' = join sub' subst in
-  let subst' = join sub subst' in
-  (* substitutive_objects get the new substitution *)
-  let substobjs = (subst',mbids,msid,objs) in
-  (* if we are not a functor - calculate substitued.
-     We add "msid |-> mp" to the substitution *)
-    match entry with 
-      | Some (me,sub)->
-	  begin
-	    match me with
-	      |{mod_entry_type = None;
-		mod_entry_expr = Some (MSEident mp')} ->
-		 let mp' = subst_mp subst' mp' in
-		 let mp' = scrape_alias mp' in
-		   (Some ({mod_entry_type = None;
-			 mod_entry_expr = 
-			      Some (MSEident mp')},sub),
-		    substobjs, match mbids with
-		      | [] -> let subst = update_subst subst' (map_mp mp' mp) in
-			  Some (subst_objects (dir,(mp',empty_dirpath)) 
-				  (join (join subst' subst) (join (map_msid msid mp')
-						  (map_mp mp mp')))
-				   objs)
-			    
-		      | _ -> None)
-		     
-	      | _ -> anomaly "Modops: Not an alias"
-	  end
-      | None -> anomaly "Modops: Empty info"
-
-and classify_module_alias (_,(entry,substobjs,_)) =
-  Substitute (entry,substobjs,None)
-	        
-let (in_module_alias,out_module_alias) =
-  declare_object {(default_object "MODULE ALIAS") with
-		    cache_function = cache_module_alias;
-		    open_function = open_module_alias;
-		    classify_function = classify_module_alias;
-		    subst_function = subst_module_alias;
-		    load_function = load_module_alias;  
-		    export_function = (fun _ -> anomaly "No modules in sections!") }
-    
-
-
-
+    classify_function = classify_module }
 
 let cache_keep _ = anomaly "This module should not be cached!"
 
-let load_keep i ((sp,kn),seg) = 
+let load_keep i ((sp,kn),seg) =
   let mp = mp_of_kn kn in
   let prefix = dir_of_sp sp, (mp,empty_dirpath) in
-    begin 
+    begin
       try
 	let prefix',objects = MPmap.find mp !modtab_objects in
-	  if prefix' <> prefix then 
+	  if prefix' <> prefix then
 	    anomaly "Two different modules with the same path!";
 	  modtab_objects := MPmap.add mp (prefix,objects@seg) !modtab_objects;
       with
@@ -485,16 +287,15 @@ let load_keep i ((sp,kn),seg) =
     end;
     load_objects i prefix seg
 
-let open_keep i ((sp,kn),seg) = 
+let open_keep i ((sp,kn),seg) =
   let dirpath,mp = dir_of_sp sp, mp_of_kn kn in
     open_objects i (dirpath,(mp,empty_dirpath)) seg
 
-let (in_modkeep,out_modkeep) = 
+let (in_modkeep,_) =
   declare_object {(default_object "MODULE KEEP OBJECTS") with
     cache_function = cache_keep;
     load_function = load_keep;
-    open_function = open_keep;
-    export_function = (fun _ -> anomaly "No modules in sections!") }
+    open_function = open_keep }
 
 (* we remember objects for a module type. In case of a declaration:
    Module M:SIG:=...
@@ -506,7 +307,7 @@ let modtypetab =
 (* currently started interactive module type. We remember its arguments
    if it is a functor type *)
 let openmodtype_info =
-  ref ([] : mod_bound_id list)
+  ref ([],[] : mod_bound_id list * module_type_body list)
 
 let _ = Summary.declare_summary "MODTYPE-INFO"
 	  { Summary.freeze_function = (fun () ->
@@ -516,261 +317,253 @@ let _ = Summary.declare_summary "MODTYPE-INFO"
 					   openmodtype_info := snd ft);
 	    Summary.init_function = (fun () ->
 				       modtypetab := MPmap.empty;
-				       openmodtype_info := []);
-	    Summary.survive_module = false;
-	    Summary.survive_section = true }
+				       openmodtype_info := [],[]) }
 
 
-let cache_modtype ((sp,kn),(entry,modtypeobjs)) =
-  let _ = 
+let cache_modtype ((sp,kn),(entry,modtypeobjs,sub_mty_l)) =
+  let mp = mp_of_kn kn in
+
+  let _ =
     match entry with
       | None ->
 	  anomaly "You must not recache interactive module types!"
-      | Some mte ->
-	  let mp = Global.add_modtype (basename sp) mte in
-	  if mp <>mp_of_kn kn then
+      | Some (mte,inl) ->
+	  if mp <> Global.add_modtype (basename sp) mte inl then
 	    anomaly "Kernel and Library names do not match"
   in
 
+  (* Using declare_modtype should lead here, where we check
+     that any given subtyping is indeed accurate *)
+  check_subtypes_mt mp sub_mty_l;
+
   if Nametab.exists_modtype sp then
     errorlabstrm "cache_modtype"
-      (pr_sp sp ++ str " already exists") ;
+      (pr_path sp ++ str " already exists") ;
 
-  Nametab.push_modtype (Nametab.Until 1) sp (mp_of_kn kn);
+  Nametab.push_modtype (Nametab.Until 1) sp mp;
 
-  modtypetab := MPmap.add (mp_of_kn kn) modtypeobjs !modtypetab
+  modtypetab := MPmap.add mp modtypeobjs !modtypetab
 
 
-let load_modtype i ((sp,kn),(entry,modtypeobjs)) =
+let load_modtype i ((sp,kn),(entry,modtypeobjs,_)) =
   check_empty "load_modtype" entry;
 
   if Nametab.exists_modtype sp then
     errorlabstrm "cache_modtype"
-      (pr_sp sp ++ str " already exists") ;
+      (pr_path sp ++ str " already exists") ;
 
   Nametab.push_modtype (Nametab.Until i) sp (mp_of_kn kn);
-    
+
   modtypetab := MPmap.add (mp_of_kn kn) modtypeobjs !modtypetab
 
 
-let open_modtype i ((sp,kn),(entry,_)) =
+let open_modtype i ((sp,kn),(entry,_,_)) =
   check_empty "open_modtype" entry;
 
-  if 
-    try Nametab.locate_modtype (qualid_of_sp sp) <> (mp_of_kn kn) 
+  if
+    try Nametab.locate_modtype (qualid_of_path sp) <> (mp_of_kn kn)
     with Not_found -> true
   then
-    errorlabstrm ("open_modtype") 
-      (pr_sp sp ++ str " should already exist!");
+    errorlabstrm ("open_modtype")
+      (pr_path sp ++ str " should already exist!");
 
   Nametab.push_modtype (Nametab.Exactly i) sp (mp_of_kn kn)
 
-let subst_modtype (_,subst,(entry,(subs,mbids,msid,objs))) =
+let subst_modtype (subst,(entry,(mbids,mp,objs),_)) =
   check_empty "subst_modtype" entry;
-  (entry,(join subs subst,mbids,msid,objs))
+  (entry,(mbids,subst_mp subst mp,subst_objects subst objs),[])
 
 
-let classify_modtype (_,(_,substobjs)) =
-  Substitute (None,substobjs)
+let classify_modtype (_,substobjs,_) =
+  Substitute (None,substobjs,[])
 
 
-let (in_modtype,out_modtype) =
+let (in_modtype,_) =
     declare_object {(default_object "MODULE TYPE") with
       cache_function = cache_modtype;
       open_function = open_modtype;
       load_function = load_modtype;
       subst_function = subst_modtype;
-      classify_function = classify_modtype;
-      export_function = Option.make }
+      classify_function = classify_modtype }
 
 
-
-let rec replace_module_object idl (subst, mbids, msid, lib_stack) modobjs mp =
-  let rec mp_rec = function
-    | [] -> MPself msid
-	| i::r -> MPdot(mp_rec r,label_of_id i)
-  in 
-    if mbids<>[] then 
+let rec replace_module_object idl ( mbids, mp, lib_stack) (mbids2,mp2,objs) mp1=
+  if mbids<>[] then 
     error "Unexpected functor objects"
-    else
-      let rec replace_idl = function 
-	| _,[] -> [] 
-	| id::idl,(id',obj)::tail when id = id' ->
-	    let tag = object_tag obj in
-	    if tag = "MODULE" or tag ="MODULE ALIAS" then
-              (match idl with
-		   [] -> (id, in_module_alias (Some
-						 ({mod_entry_type = None;
-						   mod_entry_expr = Some (MSEident mp)},None)
-						 ,modobjs,None))::tail
-		 | _ ->
-		     let (a,substobjs,_) = if tag =  "MODULE ALIAS" then
-		       out_module_alias obj else out_module obj in
-                     let substobjs' = replace_module_object idl substobjs modobjs mp in
-  		       if tag =  "MODULE ALIAS" then
-			 (id, in_module_alias (a,substobjs',None))::tail
-		       else
-			 (id, in_module (None,substobjs',None))::tail
-              )
-	    else error "MODULE expected!"
-	| idl,lobj::tail -> lobj::replace_idl (idl,tail)
-      in
-	(join (map_mp (mp_rec (List.rev idl)) mp) subst, mbids, msid, replace_idl (idl,lib_stack))
-	  
-let abstract_substobjs mbids1 (subst, mbids2, msid, lib_stack) =
-  (subst, mbids1@mbids2, msid, lib_stack)
-
-let rec get_modtype_substobjs env = function
-    MSEident ln -> MPmap.find ln !modtypetab
+  else
+    let rec replace_idl = function 
+      | _,[] -> [] 
+      | id::idl,(id',obj)::tail when id = id' ->
+	  if object_tag obj = "MODULE" then
+           (match idl with
+               [] -> (id, in_module 
+			(None,(mbids,(MPdot(mp,label_of_id id)),subst_objects 
+				 (map_mp mp1 (MPdot(mp,label_of_id id)) empty_delta_resolver) objs)))::tail
+             | _ ->
+               let (_,substobjs) = out_module obj in
+                let substobjs' = replace_module_object idl substobjs 
+		  (mbids2,mp2,objs) mp in
+                  (id, in_module (None,substobjs'))::tail
+           )
+	  else error "MODULE expected!"
+      | idl,lobj::tail -> lobj::replace_idl (idl,tail)
+    in
+      (mbids, mp, replace_idl (idl,lib_stack))
+
+let discr_resolver mb  = 
+     match mb.mod_type with
+	SEBstruct _ -> 
+	  Some mb.mod_delta
+      | _ -> (*case mp is a functor *)
+	  None
+
+(* Small function to avoid module typing during substobjs retrivial  *)
+let rec get_objs_modtype_application env = function
+| MSEident mp -> 
+    MPmap.find mp !modtypetab,Environ.lookup_modtype mp env,[]
+| MSEapply (fexpr, MSEident mp) -> 
+    let objs,mtb,mp_l= get_objs_modtype_application env fexpr in
+      objs,mtb,mp::mp_l
+| MSEapply (_,mexpr) ->
+    Modops.error_application_to_not_path mexpr
+| _ -> error "Application of a non-functor."
+
+let rec compute_subst env mbids sign mp_l inline =
+  match mbids,mp_l with
+    | _,[] -> mbids,empty_subst
+    | [],r -> error "Application of a functor with too few arguments."
+    | mbid::mbids,mp::mp_l ->
+	let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in
+	let mb = Environ.lookup_module mp env in
+	let mbid_left,subst = compute_subst env mbids fbody_b mp_l inline in
+	match discr_resolver mb with
+	  | None ->
+	      mbid_left,join (map_mbid mbid mp empty_delta_resolver) subst
+	  | Some mp_delta ->
+	      let mp_delta =
+		if not inline then mp_delta else
+		  Modops.complete_inline_delta_resolver env mp
+		    farg_id farg_b mp_delta
+	      in
+	      mbid_left,join (map_mbid mbid mp mp_delta) subst
+
+let rec get_modtype_substobjs env mp_from inline = function
+    MSEident ln -> 
+      MPmap.find ln !modtypetab 
   | MSEfunctor (mbid,_,mte) ->
-      let (subst, mbids, msid, objs) = get_modtype_substobjs env mte in
-	(subst, mbid::mbids, msid, objs)
-  | MSEwith (mty, With_Definition _) -> get_modtype_substobjs env mty
-  | MSEwith (mty, With_Module (idl,mp)) -> 
-      let substobjs = get_modtype_substobjs env mty in
-      let mp = Environ.scrape_alias mp env in
-      let modobjs = MPmap.find mp !modtab_substobjs in
-	replace_module_object idl substobjs modobjs mp
-  | MSEapply (mexpr, MSEident mp) ->
-     let ftb,sub1 = Mod_typing.translate_struct_entry env mexpr in
-      let farg_id, farg_b, fbody_b = Modops.destr_functor env 
-	(Modops.eval_struct env ftb) in
-      let mp = Environ.scrape_alias mp env in
-      let sub_alias = (Environ.lookup_modtype mp env).typ_alias in
-      let sub_alias = match Modops.eval_struct env (SEBident mp) with
-	| SEBstruct (msid,sign) -> join_alias 
-	    (subst_key (map_msid msid mp) sub_alias)
-	      (map_msid msid mp)
-	| _ -> sub_alias in
-      let (subst, mbids, msid, objs) = get_modtype_substobjs env mexpr in
-      let mbid,mbids= (match mbids with
-	   | mbid::mbids -> mbid,mbids
-	   | [] -> match mexpr with
-	       | MSEident _  -> error "Application of a non-functor"
-	       | _ -> error "Application of a functor with too few arguments") in
-      let resolve =
-	Modops.resolver_of_environment farg_id farg_b mp sub_alias env in
-      let sub3=
-	if sub1 = empty_subst then
-	  update_subst sub_alias (map_mbid farg_id mp (Some resolve))
-	else
-	  let sub1' = join_alias sub1 (map_mbid farg_id mp (Some resolve)) in
-	  let sub_alias' =  update_subst sub_alias sub1' in
-	    join sub1' sub_alias'
+      let (mbids, mp, objs) = get_modtype_substobjs env mp_from inline mte in
+	(mbid::mbids, mp, objs)
+  | MSEwith (mty, With_Definition _) ->
+      get_modtype_substobjs env mp_from inline mty
+  | MSEwith (mty, With_Module (idl,mp1)) -> 
+      let substobjs = get_modtype_substobjs env mp_from inline mty in
+      let modobjs = MPmap.find mp1 !modtab_substobjs in
+	replace_module_object idl substobjs modobjs mp1
+  | MSEapply (fexpr, MSEident mp) as me ->
+      let (mbids, mp1, objs),mtb_mp1,mp_l =
+	get_objs_modtype_application env me in
+      let mbids_left,subst =
+	compute_subst env mbids mtb_mp1.typ_expr (List.rev mp_l) inline
       in
-      let sub3 = join sub3 
-	(update_subst sub_alias (map_mbid farg_id mp (Some resolve))) in
-	(* application outside the kernel, only for substitutive
-           objects (that are all non-logical objects) *)
-	((join 
-	    (join subst sub3)
-	    (map_mbid mbid mp (Some resolve)))
-	   , mbids, msid, objs)
+      (mbids_left, mp1,subst_objects subst objs)
   | MSEapply (_,mexpr) ->
       Modops.error_application_to_not_path mexpr
 
- 
 (* push names of bound modules (and their components) to Nametab *)
 (* add objects associated to them *)
 let process_module_bindings argids args =
-  let process_arg id (mbid,mty) =
+  let process_arg id (mbid,(mty,inl)) =
     let dir = make_dirpath [id] in
     let mp = MPbound mbid in
-    let substobjs = get_modtype_substobjs (Global.env()) mty in
-    ignore (do_load_and_subst_module 1 dir mp substobjs [])
-  in
-    List.iter2 process_arg argids args
-
-let intern_args interp_modtype (idl,arg) = 
+    let (mbids,mp_from,objs) =
+      get_modtype_substobjs (Global.env()) mp inl mty in
+    let substobjs = (mbids,mp,subst_objects
+		       (map_mp mp_from mp empty_delta_resolver) objs)in
+      do_module false "start" load_objects 1 dir mp substobjs []
+    in
+      List.iter2 process_arg argids args
+
+let intern_args interp_modtype (idl,(arg,inl)) =
   let lib_dir = Lib.library_dp() in
   let mbids = List.map (fun (_,id) -> make_mbid lib_dir (string_of_id id)) idl in
   let mty = interp_modtype (Global.env()) arg in
   let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in
-  let substobjs = get_modtype_substobjs (Global.env()) mty in
+  let (mbi,mp_from,objs) = get_modtype_substobjs (Global.env())
+    (MPbound (List.hd mbids)) inl mty in
   List.map2
-    (fun dir mbid -> 
-      Global.add_module_parameter mbid mty;
-      let mp = MPbound mbid in
-      ignore (do_load_and_subst_module 1 dir mp substobjs []);
-      (mbid,mty))
+    (fun dir mbid ->
+       let resolver = Global.add_module_parameter mbid mty inl in
+       let mp = MPbound mbid in
+       let substobjs = (mbi,mp,subst_objects
+			  (map_mp mp_from mp resolver) objs) in
+	 do_module false "interp" load_objects 1 dir mp substobjs [];
+	 (mbid,(mty,inl)))
     dirs mbids
 
-let start_module interp_modtype export id args res_o =
-  let fs = Summary.freeze_summaries () in
-
+let start_module_ interp_modtype export id args res fs =
   let mp = Global.start_module id in
   let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-
-  let res_entry_o, sub_body_o = match res_o with
-      None -> None, None
-    | Some (res, restricted) ->
-	(* we translate the module here to catch errors as early as possible *)
+  let res_entry_o, sub_body_l = match res with
+    | Topconstr.Enforce (res,inl) ->
 	let mte = interp_modtype (Global.env()) res in
-	if restricted then
-	  Some mte, None
-	else
-	  let mtb,_ = Mod_typing.translate_struct_entry (Global.env()) mte in
-	  let sub_mtb = 
-	    List.fold_right 
-	      (fun (arg_id,arg_t) mte -> 
-		let arg_t,sub = Mod_typing.translate_struct_entry (Global.env()) arg_t
-		in
-		let arg_t = {typ_expr = arg_t;
-			     typ_strength = None;
-			     typ_alias = sub} in
-		  SEBfunctor(arg_id,arg_t,mte))
-	      arg_entries mtb
-	  in
-	  None, Some sub_mtb
+	let _ = Mod_typing.translate_struct_type_entry (Global.env()) inl mte in
+	Some (mte,inl), []
+    | Topconstr.Check resl ->
+	None, build_subtypes interp_modtype mp arg_entries resl
   in
-
   let mbids = List.map fst arg_entries in
-    openmod_info:=(mbids,res_entry_o,sub_body_o);
+  openmod_info:=(mp,mbids,res_entry_o,sub_body_l);
   let prefix = Lib.start_module export id mp fs in
   Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix);
   Lib.add_frozen_state (); mp
 
 
-let end_module id =
+let end_module () =
 
-  let oldoname,oldprefix,fs,lib_stack = Lib.end_module id in
-  let mbids, res_o, sub_o = !openmod_info in
+  let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in
+  let mp,mbids, res_o, sub_l = !openmod_info in
   let substitute, keep, special = Lib.classify_segment lib_stack in
 
-  let dir = fst oldprefix in
-  let msid = msid_of_prefix oldprefix in
-
-  let substobjs, keep, special = try
+  let mp_from,substobjs, keep, special = try
     match res_o with
-      | None -> 
-	  (empty_subst, mbids, msid, substitute), keep, special
-      | Some (MSEident ln) ->
-	  abstract_substobjs mbids (MPmap.find ln (!modtypetab)), [], []
-      | Some (MSEwith _ as mty) ->
-	  abstract_substobjs mbids (get_modtype_substobjs (Global.env()) mty), [], []
-      | Some (MSEfunctor _) -> 
+      | None ->
+	  (* the module is not sealed *)
+	  None,( mbids, mp, substitute), keep, special
+      | Some (MSEident ln as mty, inline) ->
+	  let (mbids1,mp1,objs) =
+	    get_modtype_substobjs (Global.env()) mp inline mty in
+	  Some mp1,(mbids@mbids1,mp1,objs), [], []
+      | Some (MSEwith _ as mty, inline) ->
+	  let (mbids1,mp1,objs) =
+	    get_modtype_substobjs (Global.env()) mp inline mty in
+	  Some mp1,(mbids@mbids1,mp1,objs), [], []
+      | Some (MSEfunctor _, _) ->
 	  anomaly "Funsig cannot be here..."
-      | Some (MSEapply _ as mty) ->
-	  abstract_substobjs mbids (get_modtype_substobjs (Global.env()) mty), [], []
+      | Some (MSEapply _ as mty, inline) ->
+	  let (mbids1,mp1,objs) =
+	    get_modtype_substobjs (Global.env()) mp inline mty in
+	  Some mp1,(mbids@mbids1,mp1,objs), [], []
   with
 	Not_found -> anomaly "Module objects not found..."
   in
     (* must be called after get_modtype_substobjs, because of possible
      dependencies on functor arguments *)
 
-  let mp = Global.end_module id res_o in
+  let id = basename (fst oldoname) in
+  let mp,resolver = Global.end_module fs id res_o in
 
-  begin match sub_o with
-      None -> ()
-    | Some sub_mtb -> check_subtypes mp sub_mtb
-  end;
+  check_subtypes mp sub_l;
 
-  Summary.module_unfreeze_summaries fs;
-
-  let substituted = subst_substobjs dir mp substobjs in
-  let node = in_module (None,substobjs,substituted) in
-  let objects = 
-    if keep = [] || mbids <> [] then 
+(* we substitute objects if the module is 
+   sealed by a signature (ie. mp_from != None *)
+  let substobjs = match mp_from,substobjs with
+      None,_ -> substobjs
+    | Some mp_from,(mbids,_,objs) ->
+	(mbids,mp,subst_objects (map_mp mp_from mp resolver) objs) 
+  in
+  let node = in_module (None,substobjs) in
+  let objects =
+    if keep = [] || mbids <> [] then
       special@[node]   (* no keep objects or we are defining a functor *)
     else
       special@[node;in_modkeep keep]   (* otherwise *)
@@ -779,7 +572,7 @@ let end_module id =
 
     if (fst newoname) <> (fst oldoname) then
       anomaly "Names generated on start_ and end_module do not match";
-    if mp_of_kn (snd newoname) <> mp then 
+    if mp_of_kn (snd newoname) <> mp then
       anomaly "Kernel and Library names do not match";
 
     Lib.add_frozen_state () (* to prevent recaching *);
@@ -787,7 +580,7 @@ let end_module id =
 
 
 
-let module_objects mp = 
+let module_objects mp =
   let prefix,objects = MPmap.find mp !modtab_objects in
     segment_of_objects prefix objects
 
@@ -799,63 +592,67 @@ let module_objects mp =
 type library_name = dir_path
 
 (* The first two will form substitutive_objects, the last one is keep *)
-type library_objects = 
-    mod_self_id * lib_objects * lib_objects
+type library_objects =
+    module_path * lib_objects * lib_objects
 
 
 let register_library dir cenv objs digest =
   let mp = MPfile dir in
+  let substobjs, keep =
   try 
     ignore(Global.lookup_module mp);
     (* if it's in the environment, the cached objects should be correct *)
-    let substobjs, objects = Dirmap.find dir !library_cache in
-    do_module false "register_library" load_objects 1 dir mp substobjs objects
+    Dirmap.find dir !library_cache
   with Not_found ->
     if mp <> Global.import cenv digest then
       anomaly "Unexpected disk module name";
-    let msid,substitute,keep = objs in
-    let substobjs = empty_subst, [], msid, substitute in
-    let objects = do_load_and_subst_module 1 dir mp substobjs keep in
-    let modobjs = substobjs, objects in
-    library_cache := Dirmap.add dir modobjs !library_cache
+    let mp,substitute,keep = objs in
+    let substobjs = [], mp, substitute in
+    let modobjs = substobjs, keep in
+    library_cache := Dirmap.add dir modobjs !library_cache;
+      modobjs
+  in
+    do_module false "register_library" load_objects 1 dir mp substobjs keep
 
-let start_library dir = 
+let start_library dir =
   let mp = Global.start_library dir in
-  openmod_info:=[],None,None;
+  openmod_info:=mp,[],None,[];
   Lib.start_compilation dir mp;
   Lib.add_frozen_state ()
 
+let end_library_hook = ref ignore
+let set_end_library_hook f = end_library_hook := f
 
-let end_library dir = 
+let end_library dir =
+  !end_library_hook();
   let prefix, lib_stack = Lib.end_compilation dir in
-  let cenv = Global.export dir in
-  let msid = msid_of_prefix prefix in
+  let mp,cenv = Global.export dir in
   let substitute, keep, _ = Lib.classify_segment lib_stack in
-    cenv,(msid,substitute,keep)
+    cenv,(mp,substitute,keep)
 
 
 (* implementation of Export M and Import M *)
 
 
-let really_import_module mp = 
+let really_import_module mp =
   let prefix,objects = MPmap.find mp !modtab_objects in
     open_objects 1 prefix objects
 
 
-let cache_import (_,(_,mp)) = 
-(* for non-substitutive exports: 
+let cache_import (_,(_,mp)) =
+(* for non-substitutive exports:
   let mp = Nametab.locate_module (qualid_of_dirpath dir) in  *)
   really_import_module mp
 
-let classify_import (_,(export,_ as obj)) = 
+let classify_import (export,_ as obj) =
   if export then Substitute obj else Dispose
 
-let subst_import (_,subst,(export,mp as obj)) =
-  let mp' = subst_mp subst mp in
+let subst_import (subst,(export,mp as obj)) =
+   let mp' = subst_mp subst mp in
     if mp'==mp then obj else
       (export,mp')
-	
-let (in_import,out_import) = 
+
+let (in_import,_) =
   declare_object {(default_object "IMPORT MODULE") with
 		    cache_function = cache_import;
 		    open_function = (fun i o -> if i=1 then cache_import o);
@@ -863,125 +660,89 @@ let (in_import,out_import) =
 		    classify_function = classify_import }
 
 
-let import_module export mp = 
+let import_module export mp =
   Lib.add_anonymous_leaf (in_import (export,mp))
 
 (************************************************************************)
 (* module types *)
-let start_modtype interp_modtype id args =
-  let fs = Summary.freeze_summaries () in
 
+let start_modtype_ interp_modtype id args mtys fs =
   let mp = Global.start_modtype id in
   let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-
+  let sub_mty_l = build_subtypes interp_modtype mp arg_entries mtys in
   let mbids = List.map fst arg_entries in
-  openmodtype_info := mbids;
+  openmodtype_info := mbids, sub_mty_l;
   let prefix = Lib.start_modtype id mp fs in
   Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix);
   Lib.add_frozen_state (); mp
 
 
-let end_modtype id =
-
-  let oldoname,prefix,fs,lib_stack = Lib.end_modtype id in
-  let ln = Global.end_modtype id in
+let end_modtype () =
+  let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in
+  let id = basename (fst oldoname) in
   let substitute, _, special = Lib.classify_segment lib_stack in
-
-  let msid = msid_of_prefix prefix in
-  let mbids = !openmodtype_info in
-
-  Summary.module_unfreeze_summaries fs;
-
-  let modtypeobjs = empty_subst, mbids, msid, substitute in
-
-  let oname = Lib.add_leaves id (special@[in_modtype (None, modtypeobjs)]) in
+  let mbids, sub_mty_l = !openmodtype_info in
+  let mp = Global.end_modtype fs id in
+  let modtypeobjs = mbids, mp, substitute in
+  check_subtypes_mt mp sub_mty_l;
+  let oname = Lib.add_leaves id (special@[in_modtype (None, modtypeobjs,[])])
+  in
   if fst oname <> fst oldoname then
     anomaly
       "Section paths generated on start_ and end_modtype do not match";
-  if (mp_of_kn (snd oname)) <> ln then
+  if (mp_of_kn (snd oname)) <> mp then
     anomaly
       "Kernel and Library names do not match";
 
   Lib.add_frozen_state ()(* to prevent recaching *);
-  ln
-
+  mp
 
-let declare_modtype interp_modtype id args mty = 
-  let fs = Summary.freeze_summaries () in
 
-  try
+let declare_modtype_ interp_modtype id args mtys (mty,inl) fs =
   let mmp = Global.start_modtype id in
   let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-
-  let base_mty = interp_modtype (Global.env()) mty in
-  let entry = 
-    List.fold_right 
-      (fun (arg_id,arg_t) mte -> MSEfunctor(arg_id,arg_t,mte))
-      arg_entries
-      base_mty
-  in
-  let substobjs = get_modtype_substobjs (Global.env()) entry in
+  let entry = funct_entry arg_entries (interp_modtype (Global.env()) mty) in
+  (* NB: check of subtyping will be done in cache_modtype *)
+  let sub_mty_l = build_subtypes interp_modtype mmp arg_entries mtys in
+  let (mbids,mp_from,objs) = get_modtype_substobjs (Global.env()) mmp inl entry in
   (* Undo the simulated interactive building of the module type *)
   (* and declare the module type as a whole *)
+
+  let substobjs = (mbids,mmp,
+		   subst_objects (map_mp mp_from mmp empty_delta_resolver) objs)
+  in
   Summary.unfreeze_summaries fs;
-    
-  ignore (add_leaf id (in_modtype (Some entry, substobjs)));
+  ignore (add_leaf id (in_modtype (Some (entry,inl), substobjs, sub_mty_l)));
   mmp
-  with e ->
-    (* Something wrong: undo the whole process *)
-    Summary.unfreeze_summaries fs; raise e
-			       
 
-let rec get_module_substobjs env = function
-  | MSEident mp -> MPmap.find mp !modtab_substobjs 
+
+(* Small function to avoid module typing during substobjs retrivial  *)
+let rec get_objs_module_application env = function
+| MSEident mp -> 
+    MPmap.find mp !modtab_substobjs,Environ.lookup_module mp env,[]
+| MSEapply (fexpr, MSEident mp) -> 
+    let objs,mtb,mp_l= get_objs_module_application env fexpr in
+      objs,mtb,mp::mp_l
+| MSEapply (_,mexpr) ->
+    Modops.error_application_to_not_path mexpr
+| _ -> error "Application of a non-functor."
+
+
+let rec get_module_substobjs env mp_from inl = function
+  | MSEident mp -> MPmap.find mp !modtab_substobjs
   | MSEfunctor (mbid,mty,mexpr) ->
-       let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in
-	(subst, mbid::mbids, msid, objs)
-  | MSEapply (mexpr, MSEident mp) ->
-      let ftb,sub1 = Mod_typing.translate_struct_entry env mexpr in
-      let farg_id, farg_b, fbody_b = Modops.destr_functor env 
-	(Modops.eval_struct env ftb) in
-      let mp = Environ.scrape_alias mp env in
-      let sub_alias = (Environ.lookup_modtype mp env).typ_alias in
-      let sub_alias = match Modops.eval_struct env (SEBident mp) with
-	| SEBstruct (msid,sign) -> join_alias 
-	    (subst_key (map_msid msid mp) sub_alias)
-	      (map_msid msid mp)
-	| _ -> sub_alias in
-      let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in
-      let mbid,mbids = 
-	(match mbids with
-	   | mbid::mbids ->mbid,mbids
-	       
-	   | [] -> match mexpr with
-	       | MSEident _  -> error "Application of a non-functor"
-	       | _ -> error "Application of a functor with too few arguments") in
-      let resolve =
-	Modops.resolver_of_environment farg_id farg_b mp sub_alias env in
-      let sub3=
-	if sub1 = empty_subst then
-	  update_subst sub_alias (map_mbid farg_id mp (Some resolve))
-	else
-	  let sub1' = join_alias sub1 (map_mbid farg_id mp (Some resolve)) in
-	  let sub_alias' =  update_subst sub_alias sub1' in
-		     join sub1' sub_alias'
+       let (mbids, mp, objs) = get_module_substobjs env mp_from inl mexpr in
+	(mbid::mbids, mp, objs)
+  | MSEapply (fexpr, MSEident mp) as me ->
+      let (mbids, mp1, objs),mb_mp1,mp_l =
+	get_objs_module_application env me
       in
-      let sub3 = join sub3 (update_subst sub_alias 
-			      (map_mbid farg_id mp (Some resolve))) in
-	(* application outside the kernel, only for substitutive
-           objects (that are all non-logical objects) *)
-	((join 
-	    (join subst sub3)
-	    (map_mbid mbid mp (Some resolve)))
-	   , mbids, msid, objs)
-  | MSEapply (_,mexpr) ->
-      Modops.error_application_to_not_path mexpr
-  | MSEwith (mty, With_Definition _) -> get_module_substobjs env mty
-  | MSEwith (mty, With_Module (idl,mp)) -> 
-      let substobjs = get_module_substobjs env mty in
-      let modobjs = MPmap.find mp !modtab_substobjs in
-	replace_module_object idl substobjs modobjs mp
-
+      let mbids_left,subst =
+	compute_subst env mbids mb_mp1.mod_type (List.rev mp_l) inl in
+      (mbids_left, mp1,subst_objects subst objs)
+  | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr
+  | MSEwith (mty, With_Definition _) -> get_module_substobjs env mp_from inl mty
+  | MSEwith (mty, With_Module (idl,mp)) -> assert false
 
 (* Include *)
 
@@ -995,58 +756,43 @@ let rec subst_inc_expr subst me =
 	let const1 = Mod_subst.from_val const in
 	let force = Mod_subst.force subst_mps in
 	MSEwith (subst_inc_expr subst me,
-		 With_Definition(idl,force (subst_substituted 
+		 With_Definition(idl,force (subst_substituted
 					   subst const1)))
-    | MSEapply (me1,me2) -> 
+    | MSEapply (me1,me2) ->
 	MSEapply (subst_inc_expr subst me1,
 		  subst_inc_expr subst me2)
-    | _ -> anomaly "You cannot Include a high-order structure"
+    | MSEfunctor(mbid,me1,me2) ->
+        MSEfunctor (mbid, subst_inc_expr subst me1, subst_inc_expr subst me2)
 
 let lift_oname (sp,kn) =
   let mp,_,_ = Names.repr_kn kn in
   let dir,_ = Libnames.repr_path sp in
     (dir,mp)
 
-let cache_include (oname,((me,is_mod),substobjs,substituted)) =
+let cache_include (oname,((me,is_mod),(mbis,mp1,objs))) =
   let dir,mp1 = lift_oname oname in
   let prefix = (dir,(mp1,empty_dirpath)) in
-    Global.add_include me;
-    match substituted with
-	Some seg -> 
-	  load_objects 1 prefix seg;
-	  open_objects 1 prefix seg; 
-      | None ->  ()
-	  
-let load_include  i (oname,((me,is_mod),substobjs,substituted)) =
+    load_objects 1 prefix objs;
+    open_objects 1 prefix objs 
+    
+let load_include  i (oname,((me,is_mod),(mbis,mp1,objs))) =
   let dir,mp1 = lift_oname oname in
   let prefix = (dir,(mp1,empty_dirpath)) in
-    match substituted with
-	Some seg -> 
-	  load_objects i prefix seg
-      | None ->  ()
-
-let open_include i (oname,((me,is_mod),substobjs,substituted)) =
+    load_objects i prefix objs
+      
+      
+let open_include i (oname,((me,is_mod),(mbis,mp1,objs))) =
   let dir,mp1 = lift_oname oname in
   let prefix = (dir,(mp1,empty_dirpath)) in
-    match substituted with
-	Some seg -> 
-	  if is_mod then
-	  open_objects i prefix seg
-	  else 
-	    if i = 1 then	  
-	      open_objects i prefix seg
-      | None ->  ()
-
-let subst_include (oname,subst,((me,is_mod),substobj,_)) =
-  let dir,mp1 = lift_oname oname in
-  let (sub,mbids,msid,objs) = substobj in
-  let subst' = join sub subst in
-  let substobjs = (subst',mbids,msid,objs) in
-  let substituted = subst_substobjs dir mp1 substobjs in
-    ((subst_inc_expr subst' me,is_mod),substobjs,substituted)
-
-let classify_include (_,((me,is_mod),substobjs,_)) =
-  Substitute ((me,is_mod),substobjs,None)
+    open_objects i prefix objs
+      
+let subst_include (subst,((me,is_mod),substobj)) =
+  let (mbids,mp,objs) = substobj in
+  let substobjs = (mbids,subst_mp subst mp,subst_objects subst objs) in
+    ((subst_inc_expr subst me,is_mod),substobjs)
+      
+let classify_include ((me,is_mod),substobjs) =
+  Substitute ((me,is_mod),substobjs)
 
 let (in_include,out_include) =
   declare_object {(default_object "INCLUDE") with
@@ -1054,137 +800,182 @@ let (in_include,out_include) =
     load_function = load_include;
     open_function = open_include;
     subst_function = subst_include;
-    classify_function = classify_include;
-    export_function = (fun _ -> anomaly "No modules in section!") }
-
-let rec update_include (sub,mbids,msid,objs) =
-  let rec replace_include = function
-    | [] -> [] 
-    | (id,obj)::tail ->
-	if object_tag obj = "INCLUDE" then
-	  let ((me,is_mod),substobjs,substituted) = out_include obj in
-	  let substobjs' = update_include substobjs in
-            (id, in_include ((me,true),substobjs',substituted))::
-	      (replace_include tail)
-	else
-	  (id,obj)::(replace_include tail)
-  in
-    (sub,mbids,msid,replace_include objs)
-      
-      
-      
-let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o =
-  
-  let fs = Summary.freeze_summaries () in
+    classify_function = classify_include }
 
-  try
+
+let declare_module_ interp_modtype interp_modexpr id args res mexpr_o fs =
   let mmp = Global.start_module id in
   let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
 
-  let mty_entry_o, mty_sub_o = match mty_o with
-      None -> None, None
-    | (Some (mty, true)) -> 
-	Some (List.fold_right 
-		(fun (arg_id,arg_t) mte -> MSEfunctor(arg_id,arg_t,mte))
-		arg_entries 
-		(interp_modtype (Global.env()) mty)), 
-	None
-    | (Some (mty, false)) -> 
-	None, 
-	Some (List.fold_right 
-		(fun (arg_id,arg_t) mte -> MSEfunctor(arg_id,arg_t,mte))
-		arg_entries 
-		(interp_modtype (Global.env()) mty))
+  let funct f m = funct_entry arg_entries (f (Global.env ()) m) in
+  let env = Global.env() in
+  let mty_entry_o, subs, inl_res = match res with
+    | Topconstr.Enforce (mty,inl) -> Some (funct interp_modtype mty), [], inl
+    | Topconstr.Check mtys ->
+	None, build_subtypes interp_modtype mmp arg_entries mtys, true
   in
-  let mexpr_entry_o = match mexpr_o with
-      None -> None
-    | Some mexpr -> 
-	Some (List.fold_right 
-		(fun (mbid,mte) me -> MSEfunctor(mbid,mte,me))
-		arg_entries
-		(interp_modexpr (Global.env()) mexpr))
+ 
+  (*let subs = List.map (Mod_typing.translate_module_type env mmp) mty_sub_l in  *)
+  let mexpr_entry_o, inl_expr = match mexpr_o with
+    | None -> None, true
+    | Some (mexpr, inl) -> Some (funct interp_modexpr mexpr), inl
   in
-  let entry = 
-    {mod_entry_type = mty_entry_o;	    
+  let entry =
+    {mod_entry_type = mty_entry_o;
      mod_entry_expr = mexpr_entry_o }
   in
-  let env = Global.env() in
-  let substobjs =
+
+  let(mbids,mp_from,objs) =
     match entry with
-      | {mod_entry_type = Some mte} -> get_modtype_substobjs env mte
-      | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mexpr
+      | {mod_entry_type = Some mte} -> get_modtype_substobjs env mmp inl_res mte
+      | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mmp inl_expr mexpr
       | _ -> anomaly "declare_module: No type, no body ..."
   in
-  let substobjs = update_include substobjs in
-    (* Undo the simulated interactive building of the module *)
-    (* and declare the module as a whole *)
-    Summary.unfreeze_summaries fs;
-    match entry with 
-      |{mod_entry_type = None;	    
-	mod_entry_expr = Some (MSEident mp) } ->
-	 let dir,mp' = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in
-	 let (sub,mbids,msid,objs) = substobjs in
-	 let mp1 = Environ.scrape_alias mp env in
-	 let prefix =  dir,(mp1,empty_dirpath) in
-	 let substituted = 
-	   match mbids with
-		    | [] -> 
-			Some (subst_objects prefix 
-				(join sub (join (map_msid msid mp1) (map_mp mp' mp1))) objs)
-		    | _ -> None in
-	   ignore (add_leaf
-		     id
-		     (in_module_alias (Some ({mod_entry_type = None;	    
-					      mod_entry_expr = Some (MSEident mp1) }, mty_sub_o), 
-				       substobjs, substituted)));
-	   mmp
-      | _ ->
-	  let dir,mp = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in
-	  let (sub,mbids,msid,objs) = substobjs in
-	  let sub' = join_alias (subst_key (map_msid msid mp) sub) (map_msid msid mp) in
-	  let substobjs = (join sub sub',mbids,msid,objs) in
-	  let substituted = subst_substobjs dir mp substobjs in
-	    ignore (add_leaf
-		      id
-		      (in_module (Some (entry, mty_sub_o), substobjs, substituted)));
-	    mmp
-	      
-  with e -> 
+  (* Undo the simulated interactive building of the module *)
+  (* and declare the module as a whole *)
+  Summary.unfreeze_summaries fs;
+  let dir,mp = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in
+  let mp_env,resolver = Global.add_module id entry (inl_expr&&inl_res) in
+
+  if mp_env <> mp then anomaly "Kernel and Library names do not match";
+
+  
+  check_subtypes mp subs;
+
+  let substobjs = (mbids,mp_env,
+		   subst_objects(map_mp mp_from mp_env resolver) objs) in
+  ignore (add_leaf
+	    id
+	    (in_module (Some (entry), substobjs)));
+  mmp
+
+
+let rec include_subst env mb mbids sign inline =
+  match mbids with
+    | [] -> empty_subst
+    | mbid::mbids ->
+	let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in
+	let subst = include_subst env mb mbids fbody_b inline in
+	let mp_delta = if not inline then mb.mod_delta else
+	  Modops.complete_inline_delta_resolver env mb.mod_mp
+	    farg_id farg_b mb.mod_delta
+	in
+	join (map_mbid mbid mb.mod_mp mp_delta) subst
+
+exception NothingToDo
+
+let get_includeself_substobjs env objs me is_mod inline =
+  try
+    let mb_mp = match me with
+      | MSEident mp ->
+	  if is_mod then
+	    Environ.lookup_module mp env
+	  else
+	    Modops.module_body_of_type mp (Environ.lookup_modtype mp env)
+      | MSEapply(fexpr, MSEident p) as mexpr ->
+	  let _,mb_mp,mp_l =
+	    if is_mod then
+	      get_objs_module_application env mexpr
+	    else
+	      let o,mtb_mp,mp_l = get_objs_modtype_application env mexpr in
+	      o,Modops.module_body_of_type mtb_mp.typ_mp mtb_mp,mp_l
+	  in
+	  List.fold_left
+	    (fun mb _ ->
+	       match mb.mod_type with
+		 |  SEBfunctor(_,_,str) -> {mb with mod_type = str}
+		 | _ -> error "Application of a functor with too much arguments.")
+	    mb_mp mp_l
+      | _ -> raise NothingToDo
+    in
+    let (mbids,mp_self,objects) = objs in
+    let mb = Global.pack_module() in
+    let subst = include_subst env mb mbids mb_mp.mod_type inline in
+    ([],mp_self,subst_objects subst objects)
+  with NothingToDo -> objs
+
+let declare_one_include_inner inl (me,is_mod) =
+  let env = Global.env() in
+  let mp1,_ = current_prefix () in
+  let (mbids,mp,objs)=
+    if is_mod then
+      get_module_substobjs env mp1 inl me
+    else
+      get_modtype_substobjs env mp1 inl me in
+  let (mbids,mp,objs) =
+    if mbids <> [] then
+      get_includeself_substobjs env (mbids,mp,objs) me is_mod inl
+    else
+      (mbids,mp,objs) in
+  let id = current_mod_id() in
+  let resolver =  Global.add_include me is_mod inl in
+  let substobjs = (mbids,mp1,
+		   subst_objects (map_mp mp mp1 resolver) objs) in
+  ignore (add_leaf id
+	    (in_include ((me,is_mod), substobjs)))
+
+let declare_one_include interp_struct me_ast =
+  declare_one_include_inner (snd me_ast)
+    (interp_struct (Global.env()) (fst me_ast))
+
+let declare_include_ interp_struct me_asts =
+  List.iter (declare_one_include interp_struct) me_asts
+
+(** Versions of earlier functions taking care of the freeze/unfreeze
+    of summaries *)
+
+let protect_summaries f =
+  let fs = Summary.freeze_summaries () in
+  try f fs
+  with e ->
     (* Something wrong: undo the whole process *)
     Summary.unfreeze_summaries fs; raise e
-      
 
-let declare_include interp_struct me_ast is_mod =
+let declare_include interp_struct me_asts =
+  protect_summaries
+    (fun _ -> declare_include_ interp_struct me_asts)
+
+let declare_modtype interp_mt interp_mix id args mtys mty_l =
+  let declare_mt fs = match mty_l with
+    | [] -> assert false
+    | [mty] -> declare_modtype_ interp_mt id args mtys mty fs
+    | mty_l ->
+	ignore (start_modtype_ interp_mt id args mtys fs);
+	declare_include_ interp_mix mty_l;
+	end_modtype ()
+  in
+  protect_summaries declare_mt
+
+let start_modtype interp_modtype id args mtys =
+  protect_summaries (start_modtype_ interp_modtype id args mtys)
+
+let declare_module interp_mt interp_me interp_mix id args mtys me_l =
+  let declare_me fs = match me_l with
+    | [] -> declare_module_ interp_mt interp_me id args mtys None fs
+    | [me] -> declare_module_ interp_mt interp_me id args mtys (Some me) fs
+    | me_l ->
+	ignore (start_module_ interp_mt None id args mtys fs);
+	declare_include_ interp_mix me_l;
+	end_module ()
+  in
+  protect_summaries declare_me
+
+let start_module interp_modtype export id args res =
+ protect_summaries (start_module_ interp_modtype export id args res)
 
-  let fs = Summary.freeze_summaries () in
 
-    try 
-      let env = Global.env() in
-      let me = interp_struct env me_ast in 
-      let substobjs = 	
-	if is_mod then
-	  get_module_substobjs env me
-	else
-	  get_modtype_substobjs env me in
-      let mp1,_ = current_prefix () in
-      let dir = dir_of_sp (Lib.path_of_include()) in
-      let substituted = subst_substobjs dir mp1 substobjs in
-      let id = current_mod_id() in
-	
-	ignore (add_leaf id
-		  (in_include ((me,is_mod), substobjs, substituted)))
-    with e -> 
-      (* Something wrong: undo the whole process *)
-      Summary.unfreeze_summaries fs; raise e
-	
-	
 (*s Iterators. *)
-	
+
 let iter_all_segments f =
-  let _ = 
-    MPmap.iter 
-      (fun _ (prefix,objects) -> 
-	 let apply_obj (id,obj) = f (make_oname prefix id) obj in
+  let _ =
+    MPmap.iter
+      (fun _ (prefix,objects) ->
+	 let rec apply_obj (id,obj) = match object_tag obj with 
+	   | "INCLUDE" -> 
+	       let (_,(_,_,objs)) =  out_include obj in 
+		 List.iter apply_obj objs
+		   
+	   | _ -> f (make_oname prefix id) obj in
 	   List.iter apply_obj objects)
       !modtab_objects
   in
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 9c295451..e58f9674 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declaremods.mli 11065 2008-06-06 22:39:43Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -30,35 +30,41 @@ open Lib
    constructed by [interp_modtype] from functor arguments [fargs] and
    by [interp_modexpr] from [expr]. At least one of [typ], [expr] must
    be non-empty.
-   
+
    The [bool] in [typ] tells if the module must be abstracted [true]
    with respect to the module type or merely matched without any
    restriction [false].
 *)
 
-val declare_module : 
-  (env -> 'modtype -> module_struct_entry) -> (env -> 'modexpr -> module_struct_entry) ->
-  identifier -> 
-  (identifier located list * 'modtype) list -> ('modtype * bool) option -> 
-  'modexpr option -> module_path
- 
-val start_module : (env -> 'modtype -> module_struct_entry) -> 
-  bool option -> identifier -> (identifier located list * 'modtype) list ->
-   ('modtype * bool) option -> module_path
+val declare_module :
+  (env -> 'modast -> module_struct_entry) ->
+  (env -> 'modast -> module_struct_entry) ->
+  (env -> 'modast -> module_struct_entry * bool) ->
+  identifier ->
+  (identifier located list * ('modast * bool)) list ->
+  ('modast * bool) Topconstr.module_signature ->
+  ('modast * bool) list -> module_path
+
+val start_module : (env -> 'modast -> module_struct_entry) ->
+  bool option -> identifier -> (identifier located list * ('modast * bool)) list ->
+  ('modast * bool) Topconstr.module_signature -> module_path
 
-val end_module : identifier -> module_path
+val end_module : unit -> module_path
 
 
 
 (*s Module types *)
 
-val declare_modtype : (env -> 'modtype -> module_struct_entry) -> 
-  identifier -> (identifier located list * 'modtype) list -> 'modtype -> module_path
+val declare_modtype : (env -> 'modast -> module_struct_entry) ->
+  (env -> 'modast -> module_struct_entry * bool) ->
+  identifier -> (identifier located list * ('modast * bool)) list ->
+  ('modast * bool) list -> ('modast * bool) list -> module_path
 
-val start_modtype : (env -> 'modtype -> module_struct_entry) -> 
-  identifier -> (identifier located list * 'modtype) list -> module_path
+val start_modtype : (env -> 'modast -> module_struct_entry) ->
+  identifier -> (identifier located list * ('modast * bool)) list ->
+  ('modast * bool) list -> module_path
 
-val end_modtype : identifier -> module_path
+val end_modtype : unit -> module_path
 
 
 (*s Objects of a module. They come in two lists: the substitutive ones
@@ -73,8 +79,8 @@ type library_name = dir_path
 
 type library_objects
 
-val register_library : 
-  library_name -> 
+val register_library :
+  library_name ->
     Safe_typing.compiled_library -> library_objects -> Digest.t -> unit
 
 val start_library : library_name -> unit
@@ -82,6 +88,8 @@ val start_library : library_name -> unit
 val end_library :
   library_name -> Safe_typing.compiled_library * library_objects
 
+(* set a function to be executed at end_library *)
+val set_end_library_hook : (unit -> unit) -> unit
 
 (* [really_import_module mp] opens the module [mp] (in a Caml sense).
    It modifies Nametab and performs the [open_object] function for
@@ -97,8 +105,8 @@ val import_module : bool -> module_path -> unit
 
 (* Include  *)
 
-val declare_include : (env -> 'struct_expr -> module_struct_entry) -> 
-  'struct_expr -> bool -> unit
+val declare_include : (env -> 'struct_expr -> module_struct_entry * bool) ->
+  ('struct_expr * bool) list -> unit
 
 (*s [iter_all_segments] iterate over all segments, the modules'
     segments first and then the current segment. Modules are presented
@@ -114,5 +122,5 @@ val debug_print_modtab : unit -> Pp.std_ppcmds
 
 (* For translator *)
 val process_module_bindings : module_ident list ->
-  (mod_bound_id * module_struct_entry) list -> unit
+  (mod_bound_id * (module_struct_entry * bool)) list -> unit
 
diff --git a/library/decls.ml b/library/decls.ml
index 12808310..ac2203cc 100644
--- a/library/decls.ml
+++ b/library/decls.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decls.ml 10841 2008-04-24 07:19:57Z herbelin $ *)
+(* $Id$ *)
 
 (** This module registers tables for some non-logical informations
      associated declarations *)
@@ -27,9 +27,7 @@ let vartab = ref (Idmap.empty : variable_data Idmap.t)
 let _ = Summary.declare_summary "VARIABLE"
   { Summary.freeze_function = (fun () -> !vartab);
     Summary.unfreeze_function = (fun ft -> vartab := ft);
-    Summary.init_function = (fun () -> vartab := Idmap.empty);
-    Summary.survive_module = false;
-    Summary.survive_section = false }
+    Summary.init_function = (fun () -> vartab := Idmap.empty) }
 
 let add_variable_data id o = vartab := Idmap.add id o !vartab
 
@@ -38,6 +36,10 @@ let variable_opacity id = let (_,opaq,_,_) = Idmap.find id !vartab in opaq
 let variable_kind id = let (_,_,_,k) = Idmap.find id !vartab in k
 let variable_constraints id = let (_,_,cst,_) = Idmap.find id !vartab in cst
 
+let variable_secpath id =
+  let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in
+  make_qualid dir id
+
 let variable_exists id = Idmap.mem id !vartab
 
 (** Datas associated to global parameters and constants *)
@@ -47,9 +49,7 @@ let csttab = ref (Cmap.empty : logical_kind Cmap.t)
 let _ = Summary.declare_summary "CONSTANT"
 	  { Summary.freeze_function = (fun () -> !csttab);
 	    Summary.unfreeze_function = (fun ft -> csttab := ft);
-	    Summary.init_function = (fun () -> csttab := Cmap.empty);
-	    Summary.survive_module = false;
-	    Summary.survive_section = false }
+	    Summary.init_function = (fun () -> csttab := Cmap.empty) }
 
 let add_constant_kind kn k = csttab := Cmap.add kn k !csttab
 
@@ -59,7 +59,7 @@ let constant_kind kn = Cmap.find kn !csttab
 
 let clear_proofs sign =
   List.fold_right
-    (fun (id,c,t as d) signv -> 
+    (fun (id,c,t as d) signv ->
       let d = if variable_opacity id then (id,None,t) else d in
       Environ.push_named_context_val d signv) sign Environ.empty_named_context_val
 
@@ -70,7 +70,3 @@ let last_section_hyps dir =
       with Not_found -> sec_ids)
     (Environ.named_context (Global.env()))
     ~init:[]
-
-let is_section_variable = function
-  | VarRef _ -> true
-  | _ -> false
diff --git a/library/decls.mli b/library/decls.mli
index 39d258b3..29fa13ae 100644
--- a/library/decls.mli
+++ b/library/decls.mli
@@ -6,19 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: decls.mli 10841 2008-04-24 07:19:57Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Names
 open Sign
-(*
 open Libnames
-open Term
-open Declarations
-open Entries
-open Indtypes
-open Safe_typing
-open Nametab
-*)
 open Decl_kinds
 
 (** This module manages non-kernel informations about declarations. It
@@ -27,10 +19,12 @@ open Decl_kinds
 
 (** Registration and access to the table of variable *)
 
-type variable_data = 
+type variable_data =
     dir_path * bool (* opacity *) * Univ.constraints * logical_kind
 
 val add_variable_data : variable -> variable_data -> unit
+val variable_path : variable -> dir_path
+val variable_secpath : variable -> qualid
 val variable_kind : variable -> logical_kind
 val variable_opacity : variable -> bool
 val variable_constraints : variable -> Univ.constraints
diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml
index c7ccb3ae..85de6ab8 100644
--- a/library/dischargedhypsmap.ml
+++ b/library/dischargedhypsmap.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dischargedhypsmap.ml 9902 2007-06-21 17:01:21Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Libnames
@@ -20,11 +20,11 @@ open Libobject
 open Lib
 open Nametab
 
-type discharged_hyps = section_path list
+type discharged_hyps = full_path list
 
 let discharged_hyps_map = ref Spmap.empty
 
-let set_discharged_hyps sp hyps = 
+let set_discharged_hyps sp hyps =
   discharged_hyps_map := Spmap.add sp hyps !discharged_hyps_map
 
 let get_discharged_hyps sp =
@@ -42,10 +42,8 @@ let freeze () = !discharged_hyps_map
 
 let unfreeze dhm = discharged_hyps_map := dhm
 
-let _ = 
+let _ =
   Summary.declare_summary "discharged_hypothesis"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = true }
+      Summary.init_function = init }
diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli
index 9a3259ce..f9d0f9b4 100644
--- a/library/dischargedhypsmap.mli
+++ b/library/dischargedhypsmap.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dischargedhypsmap.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Libnames
@@ -15,10 +15,10 @@ open Environ
 open Nametab
 (*i*)
 
-type discharged_hyps = section_path list
+type discharged_hyps = full_path list
 
 (*s Discharged hypothesis. Here we store the discharged hypothesis of each *)
 (*  constant or inductive type declaration.                                *)
 
-val set_discharged_hyps : section_path -> discharged_hyps -> unit
-val get_discharged_hyps : section_path -> discharged_hyps
+val set_discharged_hyps : full_path -> discharged_hyps -> unit
+val get_discharged_hyps : full_path -> discharged_hyps
diff --git a/library/global.ml b/library/global.ml
index b2f9e127..d5fafbb8 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: global.ml 10664 2008-03-14 11:27:37Z soubiran $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -27,13 +27,11 @@ let env () = env_of_safe_env !global_env
 
 let env_is_empty () = is_empty !global_env
 
-let _ = 
+let _ =
   declare_summary "Global environment"
     { freeze_function = (fun () -> !global_env);
       unfreeze_function = (fun fr -> global_env := fr);
-      init_function = (fun () -> global_env := empty_environment);
-      survive_module = true;
-      survive_section = false }
+      init_function = (fun () -> global_env := empty_environment) }
 
 (* Then we export the functions of [Typing] on that environment. *)
 
@@ -50,31 +48,32 @@ let push_named_def d =
   global_env := env;
   cst
 
-(*let add_thing add kn thing =
-  let _,dir,l = repr_kn kn in
-  let kn',newenv = add dir l thing !global_env in
-    if kn = kn' then
-      global_env := newenv
-    else
-      anomaly "Kernel names do not match."
-*)
 
-let add_thing add dir id thing = 
+let add_thing add dir id thing =
   let kn, newenv = add dir (label_of_id id) thing !global_env in
     global_env := newenv;
     kn
 
-let add_constant = add_thing add_constant 
+let add_constant = add_thing add_constant
 let add_mind = add_thing add_mind
-let add_modtype = add_thing (fun _ -> add_modtype) ()
-let add_module = add_thing (fun _ -> add_module) ()
-let add_alias = add_thing (fun _ -> add_alias) ()
+let add_modtype x y inl = add_thing (fun _ x y -> add_modtype x y inl) () x y
+
+
+let add_module id me inl =
+  let l = label_of_id id in
+  let mp,resolve,new_env = add_module l me inl !global_env in
+    global_env := new_env;
+    mp,resolve
+    
 
 let add_constraints c = global_env := add_constraints c !global_env
 
 let set_engagement c = global_env := set_engagement c !global_env
 
-let add_include me = global_env := add_include me !global_env
+let add_include me is_module inl =
+  let resolve,newenv = add_include me is_module inl !global_env in
+    global_env := newenv;
+    resolve
 
 let start_module id =
   let l = label_of_id id in
@@ -82,16 +81,18 @@ let start_module id =
     global_env := newenv;
     mp
 
-let end_module id mtyo =
+let end_module fs id mtyo =
   let l = label_of_id id in
-  let mp,newenv = end_module l mtyo !global_env in
+  let mp,resolve,newenv = end_module l mtyo !global_env in
+    Summary.unfreeze_summaries fs;
     global_env := newenv;
-    mp
+    mp,resolve
 
 
-let add_module_parameter mbid mte =
-  let newenv = add_module_parameter mbid mte !global_env in
-    global_env := newenv
+let add_module_parameter mbid mte inl =
+  let resolve,newenv = add_module_parameter mbid mte inl !global_env in
+    global_env := newenv;
+    resolve
 
 
 let start_modtype id =
@@ -100,12 +101,15 @@ let start_modtype id =
     global_env := newenv;
     mp
 
-let end_modtype id =
+let end_modtype fs id =
   let l = label_of_id id in
   let kn,newenv = end_modtype l !global_env in
+    Summary.unfreeze_summaries fs;
     global_env := newenv;
     kn
 
+let pack_module () = 
+  pack_module !global_env
 
 
 
@@ -117,19 +121,26 @@ let lookup_mind kn = lookup_mind kn (env())
 let lookup_module mp = lookup_module mp (env())
 let lookup_modtype kn = lookup_modtype kn (env())
 
-
-
-
-let start_library dir = 
+let constant_of_delta con = 
+  let resolver,resolver_param = (delta_of_senv !global_env) in
+    Mod_subst.constant_of_delta resolver_param
+      (Mod_subst.constant_of_delta resolver con)
+
+let mind_of_delta mind = 
+  let resolver,resolver_param = (delta_of_senv !global_env) in
+    Mod_subst.mind_of_delta resolver_param
+      (Mod_subst.mind_of_delta resolver mind)
+	
+let start_library dir =
   let mp,newenv = start_library dir !global_env in
-    global_env := newenv; 
+    global_env := newenv;
     mp
 
-let export s = snd (export !global_env s)
+let export s = export !global_env s
 
-let import cenv digest = 
-  let mp,newenv = import cenv digest !global_env in 
-    global_env := newenv; 
+let import cenv digest =
+  let mp,newenv = import cenv digest !global_env in
+    global_env := newenv;
     mp
 
 
@@ -137,13 +148,13 @@ let import cenv digest =
 (*s Function to get an environment from the constants part of the global
     environment and a given context. *)
 
-let env_of_context hyps = 
+let env_of_context hyps =
   reset_with_named_context hyps (env())
 
 open Libnames
 
 let type_of_reference env = function
-  | VarRef id -> Environ.named_type id env 
+  | VarRef id -> Environ.named_type id env
   | ConstRef c -> Typeops.type_of_constant env c
   | IndRef ind ->
      let specif = Inductive.lookup_mind_specif env ind in
@@ -161,3 +172,5 @@ let register field value by_clause =
   let entry = kind_of_term value in
   let senv = Safe_typing.register !global_env field entry by_clause in
   global_env := senv
+
+
diff --git a/library/global.mli b/library/global.mli
index cb717cdf..a8d76c4f 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: global.mli 10664 2008-03-14 11:27:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -15,6 +15,7 @@ open Term
 open Declarations
 open Entries
 open Indtypes
+open Mod_subst
 open Safe_typing
    (*i*)
 
@@ -44,35 +45,40 @@ val push_named_def   : (identifier * constr * types option) -> Univ.constraints
 (*s Adding constants, inductives, modules and module types.  All these
   functions verify that given names match those generated by kernel *)
 
-val add_constant : 
+val add_constant :
   dir_path -> identifier -> global_declaration -> constant
-val add_mind        : 
-  dir_path -> identifier -> mutual_inductive_entry -> kernel_name
+val add_mind        :
+  dir_path -> identifier -> mutual_inductive_entry -> mutual_inductive
 
-val add_module      : identifier -> module_entry -> module_path
-val add_modtype     : identifier -> module_struct_entry -> module_path
-val add_include : module_struct_entry -> unit
-val add_alias : identifier -> module_path -> module_path
+val add_module      :
+ identifier -> module_entry -> bool -> module_path * delta_resolver
+val add_modtype     :
+ identifier -> module_struct_entry -> bool -> module_path
+val add_include :
+ module_struct_entry -> bool -> bool -> delta_resolver
 
 val add_constraints : constraints -> unit
 
 val set_engagement : engagement -> unit
 
 (*s Interactive modules and module types *)
-(* Both [start_*] functions take the [dir_path] argument to create a 
+(* Both [start_*] functions take the [dir_path] argument to create a
    [mod_self_id]. This should be the name of the compilation unit. *)
 
 (* [start_*] functions return the [module_path] valid for components
    of the started module / module type *)
 
 val start_module : identifier -> module_path
-val end_module : identifier -> module_struct_entry option -> module_path
 
-val add_module_parameter : mod_bound_id -> module_struct_entry -> unit
+val end_module : Summary.frozen ->identifier ->
+  (module_struct_entry * bool) option -> module_path * delta_resolver
 
-val start_modtype : identifier -> module_path
-val end_modtype : identifier -> module_path
+val add_module_parameter :
+ mod_bound_id -> module_struct_entry -> bool -> delta_resolver
 
+val start_modtype : identifier -> module_path
+val end_modtype : Summary.frozen -> identifier -> module_path
+val pack_module : unit -> module_body
 
 
 (* Queries *)
@@ -82,15 +88,17 @@ val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body
 val lookup_mind      : mutual_inductive -> mutual_inductive_body
 val lookup_module    : module_path -> module_body
 val lookup_modtype   : module_path -> module_type_body
+val constant_of_delta : constant -> constant
+val mind_of_delta : mutual_inductive -> mutual_inductive
 
 (* Compiled modules *)
 val start_library : dir_path -> module_path
-val export : dir_path -> compiled_library
+val export : dir_path -> module_path * compiled_library
 val import : compiled_library -> Digest.t -> module_path
 
 (*s Function to get an environment from the constants part of the global
  * environment and a given context. *)
-  
+
 val type_of_global : Libnames.global_reference -> types
 val env_of_context : Environ.named_context_val -> Environ.env
 
diff --git a/library/goptions.ml b/library/goptions.ml
index 8625ee52..e6933287 100644
--- a/library/goptions.ml
+++ b/library/goptions.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: goptions.ml 13196 2010-06-25 18:01:50Z herbelin $ *)
+(* $Id$ *)
 
 (* This module manages customization parameters at the vernacular level     *)
 
@@ -22,15 +22,9 @@ open Mod_subst
 (****************************************************************************)
 (* 0- Common things                                                         *)
 
-type option_name =
-  | PrimaryTable of string
-  | SecondaryTable of string * string
-  | TertiaryTable of string * string * string
+type option_name = string list
 
-let nickname = function
-  | PrimaryTable s         -> s
-  | SecondaryTable (s1,s2) -> s1^" "^s2
-  | TertiaryTable (s1,s2,s3) -> s1^" "^s2^" "^s3
+let nickname table = String.concat " " table
 
 let error_undeclared_key key =
   error ((nickname key)^": no table or option of this type")
@@ -75,14 +69,13 @@ module MakeTable =
 
     let _ =
       if List.mem_assoc nick !A.table then
-	error "Sorry, this table name is already used"
+	error "Sorry, this table name is already used."
 
-    module MyType = struct type t = A.t let compare = Pervasives.compare end
-    module MySet = Set.Make(MyType)
+    module MySet = Set.Make (struct type t = A.t let compare = compare end)
 
     let t = ref (MySet.empty : MySet.t)
 
-    let _ = 
+    let _ =
       if A.synchronous then
 	let freeze () = !t in
 	let unfreeze c = t := c in
@@ -90,9 +83,7 @@ module MakeTable =
 	Summary.declare_summary nick
           { Summary.freeze_function = freeze;
             Summary.unfreeze_function = unfreeze;
-            Summary.init_function = init;
-	    Summary.survive_module = false;
-	    Summary.survive_section = true }
+            Summary.init_function = init }
 
     let (add_option,remove_option) =
       if A.synchronous then
@@ -100,20 +91,18 @@ module MakeTable =
           | GOadd -> t := MySet.add p !t
           | GOrmv -> t := MySet.remove p !t in
         let load_options i o = if i=1 then cache_options o in
-	let subst_options (_,subst,(f,p as obj)) = 
+	let subst_options (subst,(f,p as obj)) = 
 	  let p' = A.subst subst p in
 	    if p' == p then obj else
 	      (f,p')
 	in
-	let export_options fp = Some fp in
         let (inGo,outGo) =
           Libobject.declare_object {(Libobject.default_object nick) with
                 Libobject.load_function = load_options;
 		Libobject.open_function = load_options;
 		Libobject.cache_function = cache_options;
 		Libobject.subst_function = subst_options;
-		Libobject.classify_function = (fun (_,x) -> Substitute x);
-		Libobject.export_function = export_options} 
+		Libobject.classify_function = (fun x -> Substitute x)}
 	in
         ((fun c -> Lib.add_anonymous_leaf (inGo (GOadd, c))),
          (fun c -> Lib.add_anonymous_leaf (inGo (GOrmv, c))))
@@ -122,8 +111,8 @@ module MakeTable =
          (fun c -> t := MySet.remove c !t))
 
     let print_table table_name printer table =
-      msg (str table_name ++ 
-	   (hov 0 
+      msg (str table_name ++
+	   (hov 0
 	      (if MySet.is_empty table then str "None" ++ fnl ()
                else MySet.fold
 		 (fun a b -> printer a ++ spc () ++ b)
@@ -133,11 +122,11 @@ module MakeTable =
     object
       method add x = add_option (A.encode x)
       method remove x = remove_option (A.encode x)
-      method mem x = 
+      method mem x =
 	let y = A.encode x in
         let answer = MySet.mem y !t in
         msg (A.member_message y answer ++ fnl ())
-      method print = print_table A.title A.printer !t 
+      method print = print_table A.title A.printer !t
     end
 
     let _ = A.table := (nick,new table_of_A ())::!A.table
@@ -190,7 +179,7 @@ sig
   val synchronous : bool
 end
 
-module RefConvert = functor (A : RefConvertArg) -> 
+module RefConvert = functor (A : RefConvertArg) ->
 struct
   type t = A.t
   type key = reference
@@ -217,10 +206,10 @@ type 'a option_sig = {
   optread  : unit -> 'a;
   optwrite : 'a -> unit }
 
-type option_type = bool * (unit -> value) -> (value -> unit) 
+type option_type = bool * (unit -> value) -> (value -> unit)
 
-module Key = struct type t = option_name let compare = Pervasives.compare end
-module OptionMap = Map.Make(Key)
+module OptionMap =
+  Map.Make (struct  type t = option_name let compare = compare end)
 
 let value_tab = ref OptionMap.empty
 
@@ -228,47 +217,65 @@ let value_tab = ref OptionMap.empty
 
 let get_option key = OptionMap.find key !value_tab
 
-let check_key key = try 
+let check_key key = try
   let _ = get_option key in
-  error "Sorry, this option name is already used"
+  error "Sorry, this option name is already used."
 with Not_found ->
   if List.mem_assoc (nickname key) !string_table
     or List.mem_assoc (nickname key) !ref_table
-  then error "Sorry, this option name is already used"
+  then error "Sorry, this option name is already used."
 
 open Summary
 open Libobject
 open Lib
 
-let declare_option cast uncast 
+let declare_option cast uncast
   { optsync=sync; optname=name; optkey=key; optread=read; optwrite=write } =
   check_key key;
   let default = read() in
-  let write = if sync then 
-    let (decl_obj,_) = 
-      declare_object {(default_object (nickname key)) with
+  (* 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 _ = declare_summary (nickname key) 
-	      {freeze_function = read;
+    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 -> Keep v);
+		       discharge_function = (fun (_,v) -> Some v);
+		       load_function = (fun _ (_,v) -> write v)}
+    in
+    let _ = declare_summary (nickname key)
+	     { freeze_function = read;
 	       unfreeze_function = write;
-	       init_function = (fun () -> write default);
-	       survive_module = false;
-	       survive_section = false}
-    in 
-    fun v -> add_anonymous_leaf (decl_obj v)
-  else write
-  in 
+	       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 cread () = cast (read ()) in
-  let cwrite v = write (uncast v) in 
-  value_tab := OptionMap.add key (name,(sync,cread,cwrite)) !value_tab; 
+  let cwrite v = write (uncast v) in
+  let clwrite v = lwrite (uncast v) in
+  let cgwrite v = gwrite (uncast v) in
+  value_tab := OptionMap.add key (name,(sync,cread,cwrite,clwrite,cgwrite)) !value_tab;
   write
 
 type 'a write_function = 'a -> unit
 
 let declare_int_option =
-  declare_option 
+  declare_option
     (fun v -> IntValue v)
     (function IntValue v -> v | _ -> anomaly "async_option")
 let declare_bool_option =
@@ -284,29 +291,38 @@ let declare_string_option =
 
 (* Setting values of options *)
 
-let set_option_value check_and_cast key v =
-  let (name,(_,read,write)) =
+let set_option_value locality check_and_cast key v =
+  let (name,(_,read,write,lwrite,gwrite)) =
     try get_option key
     with Not_found -> error ("There is no option "^(nickname key)^".")
   in
+  let write = match locality with
+    | None -> write
+    | Some true -> lwrite
+    | Some false -> gwrite
+  in
   write (check_and_cast v (read ()))
 
-let bad_type_error () = error "Bad type of value for this option"
+let bad_type_error () = error "Bad type of value for this option."
 
-let set_int_option_value = set_option_value
-  (fun v -> function 
+let set_int_option_value_gen locality = set_option_value  locality
+  (fun v -> function
      | (IntValue _) -> IntValue v
      | _ -> bad_type_error ())
-let set_bool_option_value key v =
-  try set_option_value (fun v -> function
+let set_bool_option_value_gen locality key v =
+  try set_option_value locality (fun v -> function
      | (BoolValue _) -> BoolValue v
      | _ -> bad_type_error ()) key v
   with UserError (_,s) -> Flags.if_verbose msg_warning s
-let set_string_option_value = set_option_value
- (fun v -> function 
+let set_string_option_value_gen locality = set_option_value locality
+ (fun v -> function
     | (StringValue _) -> StringValue v
     | _ -> bad_type_error ())
 
+let set_int_option_value = set_int_option_value_gen None
+let set_bool_option_value = set_bool_option_value_gen None
+let set_string_option_value = set_string_option_value_gen None
+
 (* Printing options/tables *)
 
 let msg_option_value (name,v) =
@@ -319,11 +335,11 @@ let msg_option_value (name,v) =
     | IdentValue r    -> pr_global_env Idset.empty r
 
 let print_option_value key =
-  let (name,(_,read,_)) = get_option key in
-  let s = read () in 
+  let (name,(_,read,_,_,_)) = get_option key in
+  let s = read () in
   match s with
-    | BoolValue b -> 
-	msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++ 
+    | BoolValue b ->
+	msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++
 	     fnl ())
     | _ ->
 	msg (str ("Current value of "^name^" is ") ++
@@ -333,20 +349,20 @@ let print_option_value key =
 let print_tables () =
   msg
     (str "Synchronous options:" ++ fnl () ++
-     OptionMap.fold 
-       (fun key (name,(sync,read,write)) p -> 
-	  if sync then 
+     OptionMap.fold
+       (fun key (name,(sync,read,_,_,_)) p ->
+	  if sync then
 	    p ++ str ("  "^(nickname key)^": ") ++
 	    msg_option_value (name,read()) ++ fnl ()
-	  else 
+	  else
 	    p)
        !value_tab (mt ()) ++
      str "Asynchronous options:" ++ fnl () ++
-     OptionMap.fold 
-       (fun key (name,(sync,read,write)) p -> 
-	  if sync then 
+     OptionMap.fold
+       (fun key (name,(sync,read,_,_,_)) p ->
+	  if sync then
 	    p
-	  else 
+	  else
 	    p ++ str ("  "^(nickname key)^": ") ++
             msg_option_value (name,read()) ++ fnl ())
        !value_tab (mt ()) ++
diff --git a/library/goptions.mli b/library/goptions.mli
index e076a396..511986a5 100644
--- a/library/goptions.mli
+++ b/library/goptions.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: goptions.mli 9810 2007-04-29 09:44:58Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* This module manages customization parameters at the vernacular level     *)
 
@@ -15,11 +15,12 @@
    - Variables storing options value are created by applying one of the
    [declare_int_option], [declare_bool_option], ... functions.
 
-   Each table/option is uniquely identified by a key of type [option_name].
-   There are two kinds of table/option idenfiers: the primary ones
-   (supposed to be more global) and the secondary ones
+   Each table/option is uniquely identified by a key of type [option_name]
+   which consists in a list of strings. Note that for parsing constraints,
+   table names must not be made of more than 2 strings while option names
+   can be of arbitrary length.
 
-   The declaration of a table, say of name [SecondaryTable("Toto","Titi")] 
+   The declaration of a table, say of name [["Toto";"Titi"]]
    automatically makes available the following vernacular commands:
 
       Add Toto Titi foo.
@@ -28,26 +29,18 @@
       Test Toto Titi.
 
    The declaration of a non boolean option value, say of name
-   [SecondaryTable("Tata","Tutu")], automatically makes available the
+   [["Tata";"Tutu";"Titi"]], automatically makes available the
    following vernacular commands:
 
-       Set Tata Tutu val.
-       Print Table Tata Tutu.
+       Set Tata Tutu Titi val.
+       Print Table Tata Tutu Titi.
 
    If it is the declaration of a boolean value, the following
    vernacular commands are made available:
 
-       Set Tata Tutu.
-       Unset Tata Tutu.
-       Print Table Tata Tutu. (* synonym: Test Table Tata Tutu. *)
-
-   For a primary table, say of name [PrimaryTable("Bidule")], the
-   vernacular commands look like
-
-      Add Bidule foo.
-      Print Table Bidule foo.
-      Set Bidule foo.
-      ...
+       Set Tata Tutu Titi.
+       Unset Tata Tutu Titi.
+       Print Table Tata Tutu Titi. (* synonym: Test Table Tata Tutu Titi. *)
 
    The created table/option may be declared synchronous or not
    (synchronous = consistent with the resetting commands)                   *)
@@ -64,11 +57,8 @@ open Mod_subst
 
 (*s Things common to tables and options. *)
 
-(* The type of primary or secondary table/option keys *)
-type option_name =
-  | PrimaryTable of string
-  | SecondaryTable of string * string
-  | TertiaryTable of string * string * string
+(* The type of table/option keys *)
+type option_name = string list
 
 val error_undeclared_key : option_name -> 'a
 
@@ -126,18 +116,18 @@ module MakeRefTable :
 (*s Options. *)
 
 (* These types and function are for declaring a new option of name [key]
-   and access functions [read] and [write]; the parameter [name] is the option name 
+   and access functions [read] and [write]; the parameter [name] is the option name
    used when printing the option value (command "Print Toto Titi." *)
 
 type 'a option_sig = {
-  optsync    : bool; 
+  optsync    : bool;
   optname    : string;
   optkey     : option_name;
   optread    : unit -> 'a;
   optwrite   : 'a -> unit
 }
 
-(* When an option is declared synchronous ([optsync] is [true]), the output is 
+(* When an option is declared synchronous ([optsync] is [true]), the output is
    a synchronous write function. Otherwise it is [optwrite] *)
 
 type 'a write_function = 'a -> unit
@@ -163,6 +153,11 @@ val get_ref_table :
       mem : reference -> unit;
       print : unit >
 
+(* The first argument is a locality flag. [Some true] = "Local", [Some false]="Global". *)
+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_int_option_value    : option_name -> int option -> unit
 val set_bool_option_value   : option_name -> bool   -> unit
 val set_string_option_value : option_name -> string -> unit
diff --git a/library/heads.ml b/library/heads.ml
index 970ae87b..056f78a5 100644
--- a/library/heads.ml
+++ b/library/heads.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heads.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -22,8 +22,8 @@ open Lib
 (** Characterization of the head of a term *)
 
 (* We only compute an approximation to ensure the computation is not
-   arbitrary long (e.g. the head constant of [h] defined to be 
-   [g (fun x -> phi(x))] where [g] is [fun f => g O] does not launch 
+   arbitrary long (e.g. the head constant of [h] defined to be
+   [g (fun x -> phi(x))] where [g] is [fun f => g O] does not launch
    the evaluation of [phi(0)] and the head of [h] is declared unknown). *)
 
 type rigid_head_kind =
@@ -41,10 +41,18 @@ type head_approximation =
 
 module Evalreford = struct
   type t = evaluable_global_reference
-  let compare = Pervasives.compare
+  let compare x y = 
+     let make_name = function
+      | EvalConstRef con -> 
+	  EvalConstRef(constant_of_kn(canonical_con con))
+      | k -> k
+     in 
+       Pervasives.compare (make_name x) (make_name y)
 end
 
-module Evalrefmap = Map.Make(Evalreford)
+module Evalrefmap =
+  Map.Make (Evalreford)
+
 
 let head_map = ref Evalrefmap.empty
 
@@ -54,13 +62,11 @@ let freeze () = !head_map
 
 let unfreeze hm = head_map := hm
 
-let _ = 
+let _ =
   Summary.declare_summary "Head_decl"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = true;
-      Summary.survive_section = false }
+      Summary.init_function = init }
 
 let variable_head id  = Evalrefmap.find (EvalVarRef id) !head_map
 let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map
@@ -69,7 +75,7 @@ let kind_of_head env t =
   let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta t) with
   | Rel n when n > k -> NotImmediatelyComputableHead
   | Rel n -> FlexibleHead (k,k+1-n,List.length l,b)
-  | Var id -> 
+  | Var id ->
       (try on_subterm k l b (variable_head id)
        with Not_found ->
         (* a goal variable *)
@@ -77,7 +83,7 @@ let kind_of_head env t =
         | Some c -> aux k l c b
         | None -> NotImmediatelyComputableHead)
   | Const cst -> on_subterm k l b (constant_head cst)
-  | Construct _ | CoFix _ -> 
+  | Construct _ | CoFix _ ->
       if b then NotImmediatelyComputableHead else ConstructorHead
   | Sort _ | Ind _ | Prod _ -> RigidHead RigidType
   | Cast (c,_,_) -> aux k l c b
@@ -94,7 +100,7 @@ let kind_of_head env t =
   and on_subterm k l with_case = function
   | FlexibleHead (n,i,q,with_subcase) ->
       let m = List.length l in
-      let k',rest,a = 
+      let k',rest,a =
         if n > m then
           (* eta-expansion *)
           let a =
@@ -121,12 +127,12 @@ let compute_head = function
      | Some c -> kind_of_head (Global.env()) c)
 | EvalVarRef id ->
     (match pi2 (Global.lookup_named id) with
-     | Some c when not (Decls.variable_opacity id) -> 
+     | Some c when not (Decls.variable_opacity id) ->
            kind_of_head (Global.env()) c
-     | _ -> 
+     | _ ->
            RigidHead (RigidVar id))
 
-let is_rigid env t = 
+let is_rigid env t =
   match kind_of_head env t with
   | RigidHead _ | ConstructorHead -> true
   | _ -> false
@@ -135,7 +141,7 @@ let is_rigid env t =
 
 let load_head _ (_,(ref,(k:head_approximation))) =
   head_map := Evalrefmap.add ref k !head_map
-  
+
 let cache_head o =
   load_head 1 o
 
@@ -150,7 +156,7 @@ let subst_head_approximation subst = function
         kind_of_head (Global.env()) c
   | x -> x
 
-let subst_head (_,subst,(ref,k)) =
+let subst_head (subst,(ref,k)) =
   (subst_evaluable_reference subst ref, subst_head_approximation subst k)
 
 let discharge_head (_,(ref,k)) =
@@ -161,17 +167,14 @@ let discharge_head (_,(ref,k)) =
 let rebuild_head (ref,k) =
   (ref, compute_head ref)
 
-let export_head o = Some o
-
 let (inHead, _) =
-  declare_object {(default_object "HEAD") with 
+  declare_object {(default_object "HEAD") with
     cache_function = cache_head;
     load_function = load_head;
     subst_function = subst_head;
-    classify_function = (fun (_,x) -> Substitute x);
+    classify_function = (fun x -> Substitute x);
     discharge_function = discharge_head;
-    rebuild_function = rebuild_head;
-    export_function = export_head }
+    rebuild_function = rebuild_head }
 
 let declare_head c =
   let hd = compute_head c in
diff --git a/library/heads.mli b/library/heads.mli
index 52270b49..203da612 100644
--- a/library/heads.mli
+++ b/library/heads.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heads.mli 10841 2008-04-24 07:19:57Z herbelin $ *)
+(* $Id$ *)
 
 open Names
 open Term
diff --git a/library/impargs.ml b/library/impargs.ml
index 14f88728..fead921a 100644
--- a/library/impargs.ml
+++ b/library/impargs.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: impargs.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -22,6 +22,7 @@ open Nametab
 open Pp
 open Topconstr
 open Termops
+open Namegen
 
 (*s Flags governing the computation of implicit arguments *)
 
@@ -34,9 +35,9 @@ type implicits_flags = {
   maximal : bool
 }
 
-(* les implicites sont stricts par défaut en v8 *)
+(* les implicites sont stricts par défaut en v8 *)
 
-let implicit_args = ref { 
+let implicit_args = ref {
   auto = false;
   strict = true;
   strongly_strict = false;
@@ -72,7 +73,7 @@ let is_maximal_implicit_args () = !implicit_args.maximal
 
 let with_implicits flags f x =
   let oflags = !implicit_args in
-  try 
+  try
     implicit_args := flags;
     let rslt = f x in
     implicit_args := oflags;
@@ -169,7 +170,7 @@ let is_flexible_reference env bound depth f =
 let push_lift d (e,n) = (push_rel d e,n+1)
 
 let is_reversible_pattern bound depth f l =
-  isRel f & let n = destRel f in (n < bound+depth) & (n >= depth) & 
+  isRel f & let n = destRel f in (n < bound+depth) & (n >= depth) &
   array_for_all (fun c -> isRel c & destRel c < depth) l &
   array_distinct l
 
@@ -194,37 +195,35 @@ let add_free_rels_until strict strongly_strict revpat bound env m pos acc =
     | Evar _ -> ()
     | _ ->
         iter_constr_with_full_binders push_lift (frec rig) ed c
-  in 
+  in
   frec true (env,1) m; acc
 
 (* calcule la liste des arguments implicites *)
 
-let concrete_name avoid_flags l env_names n all c =
-  if n = Anonymous & noccurn 1 c then
-    (Anonymous,l)
+let find_displayed_name_in all avoid na b =
+  if all then
+    compute_and_force_displayed_name_in (RenamingElsewhereFor b) avoid na b
   else
-    let fresh_id = next_name_not_occuring avoid_flags n l env_names c in
-    let idopt = if not all && noccurn 1 c then Anonymous else Name fresh_id in
-    (idopt, fresh_id::l)
+    compute_displayed_name_in (RenamingElsewhereFor b) avoid na b
 
 let compute_implicits_gen strict strongly_strict revpat contextual all env t =
   let rec aux env avoid n names t =
     let t = whd_betadeltaiota env t in
     match kind_of_term t with
       | Prod (na,a,b) ->
-	  let na',avoid' = concrete_name None avoid names na all b in
+	  let na',avoid' = find_displayed_name_in all avoid na 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)
-      | _ -> 
+      | _ ->
 	  let names = List.rev names in
 	  let v = Array.map (fun na -> na,None) (Array.of_list names) in
 	  if contextual then
 	    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 
+  in
+  match kind_of_term (whd_betadeltaiota env t) with
     | Prod (na,a,b) ->
-	let na',avoid = concrete_name None [] [] na all b in
+	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
 	Array.to_list v
     | _ -> []
@@ -232,16 +231,16 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t =
 let rec prepare_implicits f = function
   | [] -> []
   | (Anonymous, Some _)::_ -> anomaly "Unnamed implicit"
-  | (Name id, Some imp)::imps -> 
+  | (Name id, Some imp)::imps ->
       let imps' = prepare_implicits f imps in
-      Some (id,imp,set_maximality imps' f.maximal) :: imps'
+      Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps'
   | _::imps -> None :: prepare_implicits f imps
 
-let compute_implicits_flags env f all t = 
-  compute_implicits_gen 
+let compute_implicits_flags env f all t =
+  compute_implicits_gen
     (f.strict or f.strongly_strict) f.strongly_strict
     f.reversible_pattern f.contextual all env t
-    
+
 let set_implicit id imp insmax =
   (id,(match imp with None -> Manual | Some imp -> imp),insmax)
 
@@ -256,44 +255,44 @@ let compute_manual_implicits env flags t enriching l =
     else compute_implicits_gen false false false true true env t in
   let n = List.length autoimps in
   let try_forced k l =
-    try 
-      let (id, (b, f)), l' = assoc_by_pos k l in
-	if f then
+    try
+      let (id, (b, fi, fo)), l' = assoc_by_pos k l in
+	if fo then
 	  let id = match id with Some id -> id | None -> id_of_string ("arg_" ^ string_of_int k) in
-	    l', Some (id,Manual,b)
+	    l', Some (id,Manual,(b,fi))
 	else l, None
     with Not_found -> l, None
   in
-  if not (list_distinct l) then 
+  if not (list_distinct l) then
     error ("Some parameters are referred more than once");
   (* Compare with automatic implicits to recover printing data and names *)
   let rec merge k l = function
   | (Name id,imp)::imps ->
       let l',imp,m =
-	try 
-	  let (b, f) = List.assoc (ExplByName id) l in
-	  List.remove_assoc (ExplByName id) l, (Some Manual), (Some b)
+	try
+	  let (b, fi, fo) = List.assoc (ExplByName id) l in
+	  List.remove_assoc (ExplByName id) l, (Some Manual), (Some (b, fi))
 	with Not_found ->
-	try 
-	  let (id, (b, f)), l' = assoc_by_pos k l in
-	    l', (Some Manual), (Some b)
+	try
+	  let (id, (b, fi, fo)), l' = assoc_by_pos k l in
+	    l', (Some Manual), (Some (b,fi))
 	with Not_found ->
-	  l,imp, if enriching && imp <> None then Some flags.maximal else None
+	  l,imp, if enriching && imp <> None then Some (flags.maximal,true) else None
       in
       let imps' = merge (k+1) l' imps in
-      let m = Option.map (set_maximality imps') m in
+      let m = Option.map (fun (b,f) -> set_maximality imps' b, f) m in
       Option.map (set_implicit id imp) m :: imps'
   | (Anonymous,imp)::imps ->
       let l', forced = try_forced k l in
 	forced :: merge (k+1) l' imps
   | [] when l = [] -> []
   | [] ->
-      List.iter (function 
-	| ExplByName id,(b,forced) -> 
+      List.iter (function
+	| ExplByName id,(b,fi,forced) ->
 	    if not forced then
 	      error ("Wrong or not dependent implicit argument name: "^(string_of_id id))
 	| ExplByPos (i,_id),_t ->
-	    if i<1 or i>n then 
+	    if i<1 or i>n then
 	      error ("Bad implicit argument number: "^(string_of_int i))
 	    else
 	      errorlabstrm ""
@@ -307,19 +306,20 @@ let const v _ = v
 
 let compute_implicits_auto env f manual t =
   match manual with
-  | [] -> 
+  | [] ->
       if not f.auto then []
       else let l = compute_implicits_flags env f false t in
 	     prepare_implicits f l
   | _ -> compute_manual_implicits env f t f.auto manual
-	
+
 let compute_implicits env t = compute_implicits_auto env !implicit_args [] t
 
 type maximal_insertion = bool (* true = maximal contextual insertion *)
+type force_inference = bool (* true = always infer, never turn into evar/subgoal *)
 
 type implicit_status =
     (* None = Not implicit *)
-    (identifier * implicit_explanation * maximal_insertion) option
+    (identifier * implicit_explanation * (maximal_insertion * force_inference)) option
 
 type implicits_list = implicit_status list
 
@@ -332,7 +332,11 @@ let name_of_implicit = function
   | Some (id,_,_) -> id
 
 let maximal_insertion_of = function
-  | Some (_,_,b) -> b
+  | Some (_,_,(b,_)) -> b
+  | None -> anomaly "Not an implicit argument"
+
+let force_inference_of = function
+  | Some (_, _, (_, b)) -> b
   | None -> anomaly "Not an implicit argument"
 
 (* [in_ctx] means we know the expected type, [n] is the index of the argument *)
@@ -361,7 +365,7 @@ let compute_constant_implicits flags manual cst =
 
 (*s Inductives and constructors. Their implicit arguments are stored
    in an array, indexed by the inductive number, of pairs $(i,v)$ where
-   $i$ are the implicit arguments of the inductive and $v$ the array of 
+   $i$ are the implicit arguments of the inductive and $v$ the array of
    implicit arguments of the constructors. *)
 
 let compute_mib_implicits flags manual kn =
@@ -386,7 +390,7 @@ let compute_mib_implicits flags manual kn =
 
 let compute_all_mib_implicits flags manual kn =
   let imps = compute_mib_implicits flags manual kn in
-  List.flatten 
+  List.flatten
     (array_map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps)
 
 (*s Variables. *)
@@ -401,25 +405,18 @@ let compute_var_implicits flags manual id =
 let compute_global_implicits flags manual = function
   | VarRef id -> compute_var_implicits flags manual id
   | ConstRef kn -> compute_constant_implicits flags manual kn
-  | IndRef (kn,i) -> 
+  | IndRef (kn,i) ->
       let ((_,imps),_) = (compute_mib_implicits flags manual kn).(i) in imps
-  | ConstructRef ((kn,i),j) -> 
+  | ConstructRef ((kn,i),j) ->
       let (_,cimps) = (compute_mib_implicits flags manual kn).(i) in snd cimps.(j-1)
 
 (* Merge a manual explicitation with an implicit_status list *)
 
-let list_split_at index l = 
-  let rec aux i acc = function
-      tl when i = index -> (List.rev acc), tl
-    | hd :: tl -> aux (succ i) (hd :: acc) tl
-    | [] -> failwith "list_split_at: Invalid argument"
-  in aux 0 [] l
-    
 let merge_impls oldimpls newimpls =
-  let (before, news), olds = 
+  let (before, news), olds =
     let len = List.length newimpls - List.length oldimpls in
       if len >= 0 then list_split_at len newimpls, oldimpls
-      else 
+      else
 	let before, after = list_split_at (-len) oldimpls in
 	  (before, newimpls), after
   in
@@ -437,8 +434,8 @@ type implicit_interactive_request =
 type implicit_discharge_request =
   | ImplLocal
   | ImplConstant of constant * implicits_flags
-  | ImplMutualInductive of kernel_name * implicits_flags
-  | ImplInteractive of global_reference * implicits_flags * 
+  | ImplMutualInductive of mutual_inductive * implicits_flags
+  | ImplInteractive of global_reference * implicits_flags *
       implicit_interactive_request
 
 let implicits_table = ref Refmap.empty
@@ -457,11 +454,11 @@ let cache_implicits o =
 let subst_implicits_decl subst (r,imps as o) =
   let r' = fst (subst_global subst r) in if r==r' then o else (r',imps)
 
-let subst_implicits (_,subst,(req,l)) =
+let subst_implicits (subst,(req,l)) =
   (ImplLocal,list_smartmap (subst_implicits_decl subst) l)
 
 let impls_of_context ctx =
-  List.rev_map (fun (id,impl,_,_) -> if impl = Lib.Implicit then Some (id, Manual, true) else None)
+  List.rev_map (fun (id,impl,_,_) -> if impl = Lib.Implicit then Some (id, Manual, (true,true)) else None)
     (List.filter (fun (_,_,b,_) -> b = None) ctx)
 
 let section_segment_of_reference = function
@@ -473,9 +470,9 @@ let section_segment_of_reference = function
 let discharge_implicits (_,(req,l)) =
   match req with
   | ImplLocal -> None
-  | ImplInteractive (ref,flags,exp) -> 
+  | ImplInteractive (ref,flags,exp) ->
       let vars = section_segment_of_reference ref in
-      let ref' = pop_global_reference ref in
+      let ref' = if isVarRef ref then ref else pop_global_reference ref in
       let l' = [ref', impls_of_context vars @ snd (List.hd l)] in
       Some (ImplInteractive (ref',flags,exp),l')
   | ImplConstant (con,flags) ->
@@ -483,58 +480,61 @@ let discharge_implicits (_,(req,l)) =
       let l' = [ConstRef con',impls_of_context (section_segment_of_constant con) @ snd (List.hd l)] in
 	Some (ImplConstant (con',flags),l')
   | ImplMutualInductive (kn,flags) ->
-      let l' = List.map (fun (gr, l) -> 
+      let l' = List.map (fun (gr, l) ->
 	let vars = section_segment_of_reference gr in
-	  (pop_global_reference gr, impls_of_context vars @ l)) l 
+	((if isVarRef gr then gr else pop_global_reference gr),
+	 impls_of_context vars @ l)) l
       in
 	Some (ImplMutualInductive (pop_kn kn,flags),l')
 
 let rebuild_implicits (req,l) =
-  let l' = match req with
+  match req with
   | ImplLocal -> assert false
-  | ImplConstant (con,flags) -> 
+  | ImplConstant (con,flags) ->
       let oldimpls = snd (List.hd l) in
       let newimpls = compute_constant_implicits flags [] con in
-      [ConstRef con, merge_impls oldimpls newimpls]
+      req, [ConstRef con, merge_impls oldimpls newimpls]
   | ImplMutualInductive (kn,flags) ->
       let newimpls = compute_all_mib_implicits flags [] kn in
-      let rec aux olds news = 
+      let rec aux olds news =
 	match olds, news with
 	| (_, oldimpls) :: old, (gr, newimpls) :: tl ->
 	    (gr, merge_impls oldimpls newimpls) :: aux old tl
 	| [], [] -> []
 	| _, _ -> assert false
-      in aux l newimpls
+      in req, aux l newimpls
 
   | ImplInteractive (ref,flags,o) ->
+      (if isVarRef ref && is_in_section ref then ImplLocal else req),
       match o with
-      | ImplAuto -> 
+      | ImplAuto ->
 	  let oldimpls = snd (List.hd l) in
 	  let newimpls = compute_global_implicits flags [] ref in
 	    [ref,merge_impls oldimpls newimpls]
-      | ImplManual m -> 
+      | ImplManual m ->
 	  let oldimpls = snd (List.hd l) in
-	  let auto = 
+	  let auto =
 	    if flags.auto then
 	      let newimpls = compute_global_implicits flags [] ref in
 		merge_impls oldimpls newimpls
 	    else oldimpls
 	  in
-	  let l' = merge_impls auto m in [ref,l']
-  in (req,l')
+	  let l' = merge_impls auto m in
+	  [ref,l']
 
-let export_implicits (req,_ as x) = 
-  if req = ImplLocal then None else Some x
+let classify_implicits (req,_ as obj) =
+  if req = ImplLocal then Dispose else Substitute obj
 
 let (inImplicits, _) =
-  declare_object {(default_object "IMPLICITS") with 
+  declare_object {(default_object "IMPLICITS") with
     cache_function = cache_implicits;
     load_function = load_implicits;
     subst_function = subst_implicits;
-    classify_function = (fun (_,x) -> Substitute x);
+    classify_function = classify_implicits;
     discharge_function = discharge_implicits;
-    rebuild_function = rebuild_implicits;
-    export_function = export_implicits }
+    rebuild_function = rebuild_implicits }
+
+let is_local local ref = local || isVarRef ref && is_in_section ref
 
 let declare_implicits_gen req flags ref =
   let imps = compute_global_implicits flags [] ref in
@@ -542,10 +542,10 @@ let declare_implicits_gen req flags ref =
 
 let declare_implicits local ref =
   let flags = { !implicit_args with auto = true } in
-  let req = 
-    if local then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in
+  let req =
+    if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in
     declare_implicits_gen req flags ref
-      
+
 let declare_var_implicits id =
   let flags = !implicit_args in
     declare_implicits_gen ImplLocal flags (VarRef id)
@@ -561,11 +561,11 @@ let declare_mib_implicits kn =
     (compute_mib_implicits flags [] kn) in
     add_anonymous_leaf
       (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps))
-      
+
 (* Declare manual implicits *)
-type manual_explicitation = Topconstr.explicitation * (bool * bool) 
-  
-let compute_implicits_with_manual env typ enriching l = 
+type manual_explicitation = Topconstr.explicitation * (bool * bool * bool)
+
+let compute_implicits_with_manual env typ enriching l =
   compute_manual_implicits env !implicit_args typ enriching l
 
 let declare_manual_implicits local ref ?enriching l =
@@ -575,7 +575,7 @@ let declare_manual_implicits local ref ?enriching l =
   let enriching = Option.default flags.auto enriching in
   let l' = compute_manual_implicits env flags t enriching l in
   let req =
-    if local or isVarRef ref then ImplLocal
+    if is_local local ref then ImplLocal
     else ImplInteractive(ref,flags,ImplManual l')
   in
     add_anonymous_leaf (inImplicits (req,[ref,l']))
@@ -584,9 +584,9 @@ let maybe_declare_manual_implicits local ref ?enriching l =
   if l = [] then ()
   else declare_manual_implicits local ref ?enriching l
 
-let lift_implicits n = 
-  List.map (fun x -> 
-    match fst x with 
+let lift_implicits n =
+  List.map (fun x ->
+    match fst x with
 	ExplByPos (k, id) -> ExplByPos (k + n, id), snd x
       | _ -> x)
 
@@ -596,10 +596,8 @@ let init () = implicits_table := Refmap.empty
 let freeze () = !implicits_table
 let unfreeze t = implicits_table := t
 
-let _ = 
+let _ =
   Summary.declare_summary "implicits"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
diff --git a/library/impargs.mli b/library/impargs.mli
index c1f119e6..e8191e86 100644
--- a/library/impargs.mli
+++ b/library/impargs.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: impargs.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -16,7 +16,7 @@ open Environ
 open Nametab
 (*i*)
 
-(*s Implicit arguments. Here we store the implicit arguments. Notice that we 
+(*s Implicit arguments. Here we store the implicit arguments. Notice that we
     are outside the kernel, which knows nothing about implicit arguments. *)
 
 val make_implicit_args : bool -> unit
@@ -50,13 +50,14 @@ type implicit_explanation =
   | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position
   | Manual
 
-type implicit_status = (identifier * implicit_explanation * bool) option
+type implicit_status = (identifier * implicit_explanation * (bool * bool)) option
 type implicits_list = implicit_status list
 
 val is_status_implicit : implicit_status -> bool
 val is_inferable_implicit : bool -> int -> implicit_status -> bool
 val name_of_implicit : implicit_status -> identifier
 val maximal_insertion_of : implicit_status -> bool
+val force_inference_of : implicit_status -> bool
 
 val positions_of_implicits : implicits_list -> int list
 
@@ -65,10 +66,11 @@ val positions_of_implicits : implicits_list -> int list
 val compute_implicits : env -> types -> implicits_list
 
 (* A [manual_explicitation] is a tuple of a positional or named explicitation with
-   maximal insertion and forcing flags. *)
-type manual_explicitation = Topconstr.explicitation * (bool * bool)
+   maximal insertion, force inference and force usage flags. Forcing usage makes
+   the argument implicit even if the automatic inference considers it not inferable. *)
+type manual_explicitation = Topconstr.explicitation * (bool * bool * bool)
 
-val compute_implicits_with_manual : env -> types -> bool -> 
+val compute_implicits_with_manual : env -> types -> bool ->
   manual_explicitation list -> implicits_list
 
 (*s Computation of implicits (done using the global environment). *)
@@ -106,18 +108,7 @@ type implicit_interactive_request =
 type implicit_discharge_request =
   | ImplLocal
   | ImplConstant of constant * implicits_flags
-  | ImplMutualInductive of kernel_name * implicits_flags
-  | ImplInteractive of global_reference * implicits_flags * 
+  | ImplMutualInductive of mutual_inductive * implicits_flags
+  | ImplInteractive of global_reference * implicits_flags *
       implicit_interactive_request
 
-val discharge_implicits :     'a *
-    (implicit_discharge_request *
-     (Libnames.global_reference *
-      (Names.identifier * implicit_explanation * bool) option list)
-     list) ->
-    (implicit_discharge_request *
-     (Libnames.global_reference *
-      (Names.identifier * implicit_explanation * bool) option list)
-     list)
-    option
-
diff --git a/library/lib.ml b/library/lib.ml
index f0ec488b..c8f5c625 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: lib.ml 12496 2009-11-11 13:37:57Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -14,10 +14,7 @@ open Libnames
 open Nameops
 open Libobject
 open Summary
-
-
-
-type node = 
+type node =
   | Leaf of obj
   | CompilingLibrary of object_prefix
   | OpenedModule of bool option * object_prefix * Summary.frozen
@@ -40,31 +37,31 @@ let iter_objects f i prefix =
 let load_objects = iter_objects load_object
 let open_objects = iter_objects open_object
 
-let subst_objects prefix subst seg = 
+let subst_objects subst seg = 
   let subst_one = fun (id,obj as node) ->
-    let obj' = subst_object (make_oname prefix id, subst, obj) in
+    let obj' = subst_object (subst,obj) in
       if obj' == obj then node else
 	(id, obj')
   in
     list_smartmap subst_one seg
 
-let load_and_subst_objects i prefix subst seg =
+(*let load_and_subst_objects i prefix subst seg =
   List.rev (List.fold_left (fun seg (id,obj as node) ->
     let obj' =  subst_object (make_oname prefix id, subst, obj) in
     let node = if obj == obj' then node else (id, obj') in
     load_object i (make_oname prefix id, obj');
     node :: seg) [] seg)
-
+*)
 let classify_segment seg =
   let rec clean ((substl,keepl,anticipl) as acc) = function
     | (_,CompilingLibrary _) :: _ | [] -> acc
-    | ((sp,kn as oname),Leaf o) :: stk -> 
+    | ((sp,kn),Leaf o) :: stk ->
 	let id = Names.id_of_label (Names.label kn) in
-	  (match classify_object (oname,o) with 
+	  (match classify_object o with
 	     | Dispose -> clean acc stk
-	     | Keep o' -> 
+	     | Keep o' ->
 		 clean (substl, (id,o')::keepl, anticipl) stk
-	     | Substitute o' -> 
+	     | Substitute o' ->
 		 clean ((id,o')::substl, keepl, anticipl) stk
 	     | Anticipate o' ->
 		 clean (substl, keepl, o'::anticipl) stk)
@@ -84,12 +81,12 @@ let classify_segment seg =
 let segment_of_objects prefix =
   List.map (fun (id,obj) -> (make_oname prefix id, Leaf obj))
 
-(* We keep trace of operations in the stack [lib_stk]. 
-   [path_prefix] is the current path of sections, where sections are stored in 
-   ``correct'' order, the oldest coming first in the list. It may seems 
+(* We keep trace of operations in the stack [lib_stk].
+   [path_prefix] is the current path of sections, where sections are stored in
+   ``correct'' order, the oldest coming first in the list. It may seems
    costly, but in practice there is not so many openings and closings of
    sections, but on the contrary there are many constructions of section
-   paths based on the library path. *) 
+   paths based on the library path. *)
 
 let initial_prefix = default_library,(Names.initial_path,Names.empty_dirpath)
 
@@ -114,13 +111,17 @@ let sections_are_opened () =
 
 let cwd () = fst !path_prefix
 
+let cwd_except_section () =
+  Libnames.pop_dirpath_n (sections_depth ()) (cwd ())
+
 let current_dirpath sec =
-  Libnames.drop_dirpath_prefix (library_dp ()) 
-    (if sec then cwd () 
-      else Libnames.extract_dirpath_prefix (sections_depth ()) (cwd ()))
-    
+  Libnames.drop_dirpath_prefix (library_dp ())
+    (if sec then cwd () else cwd_except_section ())
+
 let make_path id = Libnames.make_path (cwd ()) id
 
+let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id
+
 let path_of_include () =
   let dir = Names.repr_dirpath (cwd ()) in
   let new_dir = List.tl dir in
@@ -129,11 +130,11 @@ let path_of_include () =
 
 let current_prefix () = snd !path_prefix
 
-let make_kn id = 
+let make_kn id =
   let mp,dir = current_prefix () in
     Names.make_kn mp dir (Names.label_of_id id)
 
-let make_con id = 
+let make_con id =
   let mp,dir = current_prefix () in
     Names.make_con mp dir (Names.label_of_id id)
 
@@ -151,25 +152,25 @@ let recalc_path_prefix () =
   in
   path_prefix := recalc !lib_stk
 
-let pop_path_prefix () = 
+let pop_path_prefix () =
   let dir,(mp,sec) = !path_prefix in
     path_prefix := fst (split_dirpath dir), (mp, fst (split_dirpath sec))
 
-let find_entry_p p = 
+let find_entry_p p =
   let rec find = function
     | [] -> raise Not_found
     | ent::l -> if p ent then ent else find l
   in
   find !lib_stk
 
-let find_split_p p = 
+let find_split_p p =
   let rec find = function
     | [] -> raise Not_found
     | ent::l -> if p ent then ent,l else find l
   in
   find !lib_stk
 
-let split_lib_gen test = 
+let split_lib_gen test =
   let rec collect after equal = function
     | hd::before when test hd -> collect after (hd::equal) before
     | before -> after,equal,before
@@ -196,18 +197,20 @@ let split_lib_gen test =
 let split_lib sp = split_lib_gen (fun x -> fst x = sp)
 
 let split_lib_at_opening sp =
-  split_lib_gen (function
+  let a,s,b = split_lib_gen (function
     | x,(OpenedSection _|OpenedModule _|OpenedModtype _|CompilingLibrary _) ->
 	x = sp
     | _ ->
-	false)
+	false) in
+  assert (List.tl s = []);
+  (a,List.hd s,b)
 
 (* Adding operations. *)
 
 let add_entry sp node =
   lib_stk := (sp,node) :: !lib_stk
 
-let anonymous_id = 
+let anonymous_id =
   let n = ref 0 in
   fun () -> incr n; Names.id_of_string ("_" ^ (string_of_int !n))
 
@@ -217,12 +220,8 @@ let add_anonymous_entry node =
   add_entry name node;
   name
 
-let add_absolutely_named_leaf sp obj =
-  cache_object (sp,obj);
-  add_entry sp (Leaf obj)
-
 let add_leaf id obj =
-  if fst (current_prefix ()) = Names.initial_path then 
+  if fst (current_prefix ()) = Names.initial_path then
     error ("No session module started (use -top dir)");
   let oname = make_oname id in
   cache_object (oname,obj);
@@ -237,9 +236,9 @@ let add_discharged_leaf id obj =
 
 let add_leaves id objs =
   let oname = make_oname id in
-  let add_obj obj = 
+  let add_obj obj =
     add_entry oname (Leaf obj);
-    load_object 1 (oname,obj) 
+    load_object 1 (oname,obj)
   in
   List.iter add_obj objs;
   oname
@@ -256,58 +255,55 @@ let add_frozen_state () =
 (* Modules. *)
 
 
-let is_something_opened = function 
-    (_,OpenedSection _) -> true 
-  | (_,OpenedModule _) -> true
-  | (_,OpenedModtype _) -> true
+let is_opened id = function
+    oname,(OpenedSection _ | OpenedModule _ | OpenedModtype _) when
+      basename (fst oname) = id -> true
+  | _ -> false
+
+let is_opening_node = function
+    _,(OpenedSection _ | OpenedModule _ | OpenedModtype _) -> true
   | _ -> false
 
 
-let current_mod_id () = 
-  try match find_entry_p is_something_opened with
-    | oname,OpenedModule (_,_,nametab) -> 
+let current_mod_id () =
+  try match find_entry_p is_opening_node with
+    | oname,OpenedModule (_,_,fs) ->
 	basename (fst oname)
-    | oname,OpenedModtype (_,nametab) -> 
+    | oname,OpenedModtype (_,fs) ->
 	basename (fst oname)
     | _ -> error "you are not in a module"
   with Not_found ->
     error "no opened modules"
 
 
-let start_module export id mp nametab = 
-  let dir = extend_dirpath (fst !path_prefix) id in
+let start_module export id mp fs =
+  let dir = add_dirpath_suffix (fst !path_prefix) id in
   let prefix = dir,(mp,Names.empty_dirpath) in
   let oname = make_path id, make_kn id in
   if Nametab.exists_module dir then
     errorlabstrm "open_module" (pr_id id ++ str " already exists") ;
-  add_entry oname (OpenedModule (export,prefix,nametab));
+  add_entry oname (OpenedModule (export,prefix,fs));
   path_prefix := prefix;
   prefix
 (*  add_frozen_state () must be called in declaremods *)
- 
-let end_module id = 
-  let oname,nametab = 
-    try match find_entry_p is_something_opened with
-      | oname,OpenedModule (_,_,nametab) -> 
-	  let id' = basename (fst oname) in
-	    if id<>id' then 
-	      errorlabstrm "end_module" (str "last opened module is " ++ pr_id id'); 
-	    oname,nametab
-      | oname,OpenedModtype _ ->
-	  let id' = basename (fst oname) in
-	    errorlabstrm "end_module" 
-	      (str "module type " ++ pr_id id' ++ str " is still opened")
-      | oname,OpenedSection _ ->
-	  let id' = basename (fst oname) in
-	    errorlabstrm  "end_module" 
-	      (str "section " ++ pr_id id' ++ str " is still opened")
+
+let error_still_opened string oname =
+  let id = basename (fst oname) in
+  errorlabstrm "" (str string ++ spc () ++ pr_id id ++ str " is still opened.")
+
+let end_module () =
+  let oname,fs =
+    try match find_entry_p is_opening_node with
+      | oname,OpenedModule (_,_,fs) -> oname,fs
+      | oname,OpenedModtype _ -> error_still_opened "Module Type" oname
+      | oname,OpenedSection _ -> error_still_opened "Section" oname
       | _ -> assert false
     with Not_found ->
-      error "no opened modules"
+      error "No opened modules."
   in
-  let (after,modopening,before) = split_lib_at_opening oname in
+  let (after,mark,before) = split_lib_at_opening oname in
   lib_stk := before;
-  add_entry (make_oname id) (ClosedModule (List.rev_append after (List.rev modopening)));
+  add_entry oname (ClosedModule (List.rev (mark::after)));
   let prefix = !path_prefix in
   (* LEM: This module business seems more complicated than sections;
           shouldn't a backtrack into a closed module also do something
@@ -315,50 +311,39 @@ let end_module id =
      TODO
    *)
   recalc_path_prefix ();
-  (* add_frozen_state must be called after processing the module, 
-     because we cannot recache interactive modules  *) 
-  (oname, prefix, nametab,after)
+  (* add_frozen_state must be called after processing the module,
+     because we cannot recache interactive modules  *)
+  (oname, prefix, fs, after)
 
-let start_modtype id mp nametab = 
-  let dir = extend_dirpath (fst !path_prefix) id in
+let start_modtype id mp fs =
+  let dir = add_dirpath_suffix (fst !path_prefix) id in
   let prefix = dir,(mp,Names.empty_dirpath) in
   let sp = make_path id in
   let name = sp, make_kn id in
   if Nametab.exists_cci sp then
     errorlabstrm "open_modtype" (pr_id id ++ str " already exists") ;
-  add_entry name (OpenedModtype (prefix,nametab));
+  add_entry name (OpenedModtype (prefix,fs));
   path_prefix := prefix;
   prefix
 
-let end_modtype id = 
-  let sp,nametab = 
-    try match find_entry_p is_something_opened with
-      | oname,OpenedModtype (_,nametab) -> 
-	  let id' = basename (fst oname) in
-	  if id<>id' then 
-	    errorlabstrm "end_modtype" (str "last opened module type is " ++ pr_id id'); 
-	    oname,nametab
-      | oname,OpenedModule _ ->
-	  let id' = basename (fst oname) in
-	    errorlabstrm "end_modtype" 
-	      (str "module " ++ pr_id id' ++ str " is still opened")
-      | oname,OpenedSection _ ->
-	  let id' = basename (fst oname) in
-	    errorlabstrm "end_modtype" 
-	      (str "section " ++ pr_id id' ++ str " is still opened")
+let end_modtype () =
+  let oname,fs =
+    try match find_entry_p is_opening_node with
+      | oname,OpenedModtype (_,fs) -> oname,fs
+      | oname,OpenedModule _ -> error_still_opened "Module" oname
+      | oname,OpenedSection _ -> error_still_opened "Section" oname
       | _ -> assert false
     with Not_found ->
       error "no opened module types"
   in
-  let (after,modtypeopening,before) = split_lib_at_opening sp in
+  let (after,mark,before) = split_lib_at_opening oname in
   lib_stk := before;
-  add_entry (make_oname id) (ClosedModtype (List.rev_append after (List.rev modtypeopening)));
+  add_entry oname (ClosedModtype (List.rev (mark::after)));
   let dir = !path_prefix in
   recalc_path_prefix ();
   (* add_frozen_state must be called after processing the module type.
-     This is because we cannot recache interactive module types *) 
-  (sp,dir,nametab,after)
-
+     This is because we cannot recache interactive module types *)
+  (oname,dir,fs,after)
 
 
 let contents_after = function
@@ -387,61 +372,68 @@ let start_compilation s mp =
 
 let end_compilation dir =
   let _ =
-    try match find_entry_p is_something_opened with
-      | _, OpenedSection _ -> error "There are some open sections"
-      | _, OpenedModule _ -> error "There are some open modules"
-      | _, OpenedModtype _ -> error "There are some open module types"
+    try match snd (find_entry_p is_opening_node) with
+      | OpenedSection _ -> error "There are some open sections."
+      | OpenedModule _ -> error "There are some open modules."
+      | OpenedModtype _ -> error "There are some open module types."
       | _ -> assert false
     with
-	Not_found -> () 
+	Not_found -> ()
   in
   let module_p =
-    function (_,CompilingLibrary _) -> true | x -> is_something_opened x
+    function (_,CompilingLibrary _) -> true | x -> is_opening_node x
   in
-  let oname = 
+  let oname =
     try match find_entry_p module_p with
 	(oname, CompilingLibrary prefix) -> oname
       | _ -> assert false
     with
 	Not_found -> anomaly "No module declared"
   in
-  let _ =  
+  let _ =
     match !comp_name with
       | None -> anomaly "There should be a module name..."
       | Some m ->
-	  if m <> dir then anomaly 
-	    ("The current open module has name "^ (Names.string_of_dirpath m) ^ 
+	  if m <> dir then anomaly
+	    ("The current open module has name "^ (Names.string_of_dirpath m) ^
 	       " and not " ^ (Names.string_of_dirpath m));
   in
-  let (after,_,before) = split_lib_at_opening oname in
+  let (after,mark,before) = split_lib_at_opening oname in
     comp_name := None;
     !path_prefix,after
 
 (* Returns true if we are inside an opened module type *)
-let is_modtype () = 
+let is_modtype () =
   let opened_p = function
-    | _, OpenedModtype _ -> true 
+    | _, OpenedModtype _ -> true
     | _ -> false
   in
-    try 
+    try
       let _ = find_entry_p opened_p in true
     with
 	Not_found -> false
 
 (* Returns true if we are inside an opened module *)
-let is_module () = 
+let is_module () =
   let opened_p = function
-    | _, OpenedModule _ -> true 
+    | _, OpenedModule _ -> true
     | _ -> false
   in
-    try 
+    try
       let _ = find_entry_p opened_p in true
     with
 	Not_found -> false
 
 
-(* Returns the most recent OpenedThing node *)
-let what_is_opened () = find_entry_p is_something_opened
+(* Returns the opening node of a given name *)
+let find_opening_node id =
+  try
+    let oname,entry = find_entry_p is_opening_node in
+    let id' = basename (fst oname) in
+    if id <> id' then
+      error ("Last block to end has name "^(Names.string_of_id id')^".");
+    entry
+  with Not_found -> error "There is nothing to end."
 
 (* Discharge tables *)
 
@@ -449,33 +441,29 @@ let what_is_opened () = find_entry_p is_something_opened
    - the list of variables in this section
    - the list of variables on which each constant depends in this section
    - the list of variables on which each inductive depends in this section
-   - the list of substitution to do at section closing 
+   - the list of substitution to do at section closing
 *)
 type binding_kind = Explicit | Implicit
 
 type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types
 type variable_context = variable_info list
-type abstr_list = variable_context Names.Cmap.t * variable_context Names.KNmap.t
+type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t
 
 let sectab =
-  ref ([] : ((Names.identifier * binding_kind * (Term.types * Names.identifier list) option) list * Cooking.work_list * abstr_list) list)
+  ref ([] : ((Names.identifier * binding_kind) list * Cooking.work_list * abstr_list) list)
 
 let add_section () =
-  sectab := ([],(Names.Cmap.empty,Names.KNmap.empty),(Names.Cmap.empty,Names.KNmap.empty)) :: !sectab
+  sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty),(Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab
 
-let add_section_variable id impl keep =
+let add_section_variable id impl =
   match !sectab with
     | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *)
     | (vars,repl,abs)::sl ->
-	sectab := ((id,impl,keep)::vars,repl,abs)::sl
+	sectab := ((id,impl)::vars,repl,abs)::sl
 
 let extract_hyps (secs,ohyps) =
   let rec aux = function
-    | ((id,impl,keep)::idl,(id',b,t)::hyps) when id=id' -> (id',impl,b,t) :: aux (idl,hyps)
-    | ((id,impl,Some (ty,keep))::idl,hyps) -> 
-	if List.exists (fun (id,_,_) -> List.mem id keep) ohyps then
-	  (id,impl,None,ty) :: aux (idl,hyps)
-	else aux (idl,hyps)
+    | ((id,impl)::idl,(id',b,t)::hyps) when id=id' -> (id',impl,b,t) :: aux (idl,hyps)
     | (id::idl,hyps) -> aux (idl,hyps)
     | [], _ -> []
   in aux (secs,ohyps)
@@ -496,9 +484,9 @@ let add_section_replacement f g hyps =
     let sechyps = extract_hyps (vars,hyps) in
     let args = instance_from_variable_context (List.rev sechyps) in
     sectab := (vars,f args exps,g sechyps abs)::sl
-	
+
 let add_section_kn kn =
-  let f x (l1,l2) = (l1,Names.KNmap.add kn x l2) in
+  let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in
   add_section_replacement f f
 
 let add_section_constant kn =
@@ -513,20 +501,20 @@ let section_segment_of_constant con =
   Names.Cmap.find con (fst (pi3 (List.hd !sectab)))
 
 let section_segment_of_mutual_inductive kn =
-  Names.KNmap.find kn (snd (pi3 (List.hd !sectab)))
+  Names.Mindmap.find kn (snd (pi3 (List.hd !sectab)))
 
-let rec list_mem_assoc_in_triple x = function
-    [] -> raise Not_found
-  | (a,_,_)::l -> compare a x = 0 or list_mem_assoc_in_triple x l
+let rec list_mem_assoc x = function
+  | [] -> raise Not_found
+  | (a,_)::l -> compare a x = 0 or list_mem_assoc x l
 
 let section_instance = function
   | VarRef id ->
-      if list_mem_assoc_in_triple id (pi1 (List.hd !sectab)) then [||]
+      if list_mem_assoc id (pi1 (List.hd !sectab)) then [||]
       else raise Not_found
   | ConstRef con ->
       Names.Cmap.find con (fst (pi2 (List.hd !sectab)))
   | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
-      Names.KNmap.find kn (snd (pi2 (List.hd !sectab)))
+      Names.Mindmap.find kn (snd (pi2 (List.hd !sectab)))
 
 let is_in_section ref =
   try ignore (section_instance ref); true with Not_found -> false
@@ -535,13 +523,11 @@ let init_sectab () = sectab := []
 let freeze_sectab () = !sectab
 let unfreeze_sectab s = sectab := s
 
-let _ = 
+let _ =
   Summary.declare_summary "section-context"
     { Summary.freeze_function = freeze_sectab;
       Summary.unfreeze_function = unfreeze_sectab;
-      Summary.init_function = init_sectab;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init_sectab }
 
 (*************)
 (* Sections. *)
@@ -555,18 +541,18 @@ let set_xml_close_section f = xml_close_section := f
 
 let open_section id =
   let olddir,(mp,oldsec) = !path_prefix in
-  let dir = extend_dirpath olddir id in
-  let prefix = dir, (mp, extend_dirpath oldsec id) in
+  let dir = add_dirpath_suffix olddir id in
+  let prefix = dir, (mp, add_dirpath_suffix oldsec id) in
   let name = make_path id, make_kn id (* this makes little sense however *) in
-    if Nametab.exists_section dir then
-      errorlabstrm "open_section" (pr_id id ++ str " already exists");
-    let sum = freeze_summaries() in
-      add_entry name (OpenedSection (prefix, sum));
-      (*Pushed for the lifetime of the section: removed by unfrozing the summary*)
-      Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
-      path_prefix := prefix;
-      if !Flags.xml_export then !xml_open_section id;
-      add_section ()
+  if Nametab.exists_section dir then
+    errorlabstrm "open_section" (pr_id id ++ str " already exists.");
+  let fs = freeze_summaries() in
+  add_entry name (OpenedSection (prefix, fs));
+  (*Pushed for the lifetime of the section: removed by unfrozing the summary*)
+  Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
+  path_prefix := prefix;
+  if !Flags.xml_export then !xml_open_section id;
+  add_section ()
 
 
 (* Restore lib_stk and summaries as before the section opening, and
@@ -581,26 +567,22 @@ let discharge_item ((sp,_ as oname),e) =
   | OpenedSection _ | OpenedModtype _ | OpenedModule _ | CompilingLibrary _ ->
       anomaly "discharge_item"
 
-let close_section id =
-  let oname,fs = 
-    try match find_entry_p is_something_opened with
-      | oname,OpenedSection (_,fs) -> 
-	  let id' = basename (fst oname) in 
-	    if id <> id' then 
-	      errorlabstrm "close_section" (str "Last opened section is " ++ pr_id id' ++ str ".");
-	    (oname,fs)
-      | _ -> assert false 
+let close_section () =
+  let oname,fs =
+    try match find_entry_p is_opening_node with
+      | oname,OpenedSection (_,fs) -> oname,fs
+      | _ -> assert false
     with Not_found ->
       error "No opened section."
   in
-  let (secdecls,secopening,before) = split_lib_at_opening oname in
+  let (secdecls,mark,before) = split_lib_at_opening oname in
   lib_stk := before;
   let full_olddir = fst !path_prefix in
   pop_path_prefix ();
-  add_entry (make_oname id) (ClosedSection (List.rev_append secdecls (List.rev secopening)));
-  if !Flags.xml_export then !xml_close_section id;
+  add_entry oname (ClosedSection (List.rev (mark::secdecls)));
+  if !Flags.xml_export then !xml_close_section (basename (fst oname));
   let newdecls = List.map discharge_item secdecls in
-  Summary.section_unfreeze_summaries fs;
+  Summary.unfreeze_summaries fs;
   List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls;
   Cooking.clear_cooking_sharing ();
   Nametab.push_dir (Nametab.Until 1) full_olddir (DirClosedSection full_olddir)
@@ -627,7 +609,7 @@ let has_top_frozen_state () =
   | (sp, FrozenState _)::_ -> Some sp
   | (sp, Leaf o)::t when object_tag o = "DOT" -> aux t
   | _ -> None
-  in aux !lib_stk 
+  in aux !lib_stk
 
 let set_lib_stk new_lib_stk =
   lib_stk := new_lib_stk;
@@ -652,7 +634,7 @@ let reset_to_state sp =
   let (_,eq,before) = split_lib sp in
   (* if eq a frozen state, we'll reset to it *)
   match eq with
-  | [_,FrozenState f] -> lib_stk := eq@before;  unfreeze_summaries f
+  | [_,FrozenState f] -> lib_stk := eq@before; recalc_path_prefix (); unfreeze_summaries f
   | _ -> error "Not a frozen state"
 
 
@@ -676,7 +658,7 @@ let delete_gen test =
 let delete sp = delete_gen (fun x -> fst x = sp)
 
 let reset_name (loc,id) =
-  let (sp,_) = 
+  let (sp,_) =
     try
       find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi)
     with Not_found ->
@@ -693,21 +675,21 @@ let remove_name (loc,id) =
   in
     delete sp
 
-let is_mod_node = function 
-  | OpenedModule _ | OpenedModtype _ | OpenedSection _ 
-  | ClosedModule _ | ClosedModtype _ | ClosedSection _  -> true 
-  | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE" 
+let is_mod_node = function
+  | OpenedModule _ | OpenedModtype _ | OpenedSection _
+  | ClosedModule _ | ClosedModtype _ | ClosedSection _  -> true
+  | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE"
 	|| t = "MODULE ALIAS"
   | _ -> false
 
-(* Reset on a module or section name in order to bypass constants with 
-   the same name *) 
+(* Reset on a module or section name in order to bypass constants with
+   the same name *)
 
 let reset_mod (loc,id) =
-  let (_,before) = 
+  let (_,before) =
     try
-      find_split_p (fun (sp,node) -> 
-                    let (_,spi) = repr_path (fst sp) in id = spi 
+      find_split_p (fun (sp,node) ->
+                    let (_,spi) = repr_path (fst sp) in id = spi
                     && is_mod_node node)
     with Not_found ->
       user_err_loc (loc,"reset_mod",pr_id id ++ str ": no such entry")
@@ -729,7 +711,7 @@ let is_label_n n x =
     | _ -> false
 
 (* Reset the label registered by [mark_end_of_command()] with number n. *)
-let reset_label n = 
+let reset_label n =
   let current = current_command_label() in
   if n < current then
     let res = reset_to_gen (is_label_n n) in
@@ -739,7 +721,7 @@ let reset_label n =
     match !lib_stk with
       | [] -> ()
       | x :: ls -> (lib_stk := ls;set_command_label (n-1))
-    
+
 let rec back_stk n stk =
   match stk with
       (sp,Leaf o)::tail when object_tag o = "DOT" ->
@@ -771,15 +753,15 @@ let init () =
 
 let initial_state = ref None
 
-let declare_initial_state () = 
+let declare_initial_state () =
   let name = add_anonymous_entry (FrozenState (freeze_summaries())) in
   initial_state := Some name
 
 let reset_initial () =
   match !initial_state with
-    | None -> 
+    | None ->
         error "Resetting to the initial state is possible only interactively"
-    | Some sp -> 
+    | Some sp ->
   	begin match split_lib sp with
 	  | (_,[_,FrozenState fs as hd],before) ->
 	      lib_stk := hd::before;
@@ -792,7 +774,7 @@ let reset_initial () =
 
 (* Misc *)
 
-let mp_of_global ref = 
+let mp_of_global ref =
   match ref with
     | VarRef id -> fst (current_prefix ())
     | ConstRef cst -> Names.con_modpath cst
@@ -802,45 +784,43 @@ let mp_of_global ref =
 let rec dp_of_mp modp =
   match modp with
     | Names.MPfile dp -> dp
-    | Names.MPbound _ | Names.MPself _ -> library_dp ()
+    | Names.MPbound _ -> library_dp ()
     | Names.MPdot (mp,_) -> dp_of_mp mp
 
-let rec split_mp mp = 
-  match mp with 
+let rec split_mp mp =
+  match mp with
     | Names.MPfile dp -> dp,  Names.empty_dirpath
-    | Names.MPdot (prfx, lbl) -> 
-	let mprec, dprec = split_mp prfx in 
+    | Names.MPdot (prfx, lbl) ->
+	let mprec, dprec = split_mp prfx in
 	  mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec))
-    | Names.MPself msid -> let (_, id, dp) = Names.repr_msid msid in  library_dp(), Names.make_dirpath [Names.id_of_string id]
     | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in  library_dp(), Names.make_dirpath [Names.id_of_string id]
 
 let split_modpath mp =
   let rec aux = function
     | Names.MPfile dp -> dp, []
-    | Names.MPbound mbid -> 
+    | Names.MPbound mbid ->
 	library_dp (), [Names.id_of_mbid mbid]
-    | Names.MPself msid -> library_dp (), [Names.id_of_msid msid]
     | Names.MPdot (mp,l) -> let (mp', lab) = aux mp in
 			      (mp', Names.id_of_label l :: lab)
-  in 
+  in
   let (mp, l) = aux mp in
     mp, l
-			
+
 let library_part ref =
-  match ref with 
+  match ref with
     | VarRef id -> library_dp ()
     | _ -> dp_of_mp (mp_of_global ref)
 
 let remove_section_part ref =
-  let sp = Nametab.sp_of_global ref in
+  let sp = Nametab.path_of_global ref in
   let dir,_ = repr_path sp in
   match ref with
-  | VarRef id -> 
+  | VarRef id ->
       anomaly "remove_section_part not supported on local variables"
   | _ ->
       if is_dirpath_prefix_of dir (cwd ()) then
         (* Not yet (fully) discharged *)
-        extract_dirpath_prefix (sections_depth ()) (cwd ())
+        pop_dirpath_n (sections_depth ()) (cwd ())
       else
 	(* Theorem/Lemma outside its outer section of definition *)
 	dir
@@ -849,19 +829,19 @@ let remove_section_part ref =
 (* Discharging names *)
 
 let pop_kn kn =
-  let (mp,dir,l) = Names.repr_kn kn in
-  Names.make_kn mp (dirpath_prefix dir) l
+  let (mp,dir,l) = Names.repr_mind kn in
+  Names.make_mind mp (pop_dirpath dir) l
 
-let pop_con con = 
+let pop_con con =
   let (mp,dir,l) = Names.repr_con con in
-  Names.make_con mp (dirpath_prefix dir) l
+  Names.make_con mp (pop_dirpath dir) l
 
-let con_defined_in_sec kn = 
+let con_defined_in_sec kn =
   let _,dir,_ = Names.repr_con kn in
   dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ())
 
-let defined_in_sec kn = 
-  let _,dir,_ = Names.repr_kn kn in
+let defined_in_sec kn =
+  let _,dir,_ = Names.repr_mind kn in
   dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ())
 
 let discharge_global = function
@@ -873,10 +853,10 @@ let discharge_global = function
       ConstructRef ((pop_kn kn,i),j)
   | r -> r
 
-let discharge_kn kn = 
+let discharge_kn kn =
   if defined_in_sec kn then pop_kn kn else kn
 
-let discharge_con cst = 
+let discharge_con cst =
   if con_defined_in_sec cst then pop_con cst else cst
 
 let discharge_inductive (kn,i) =
diff --git a/library/lib.mli b/library/lib.mli
index dacfed59..13c9baf6 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lib.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 
 (*s This module provides a general mechanism to keep a trace of all operations
    and to backtrack (undo) those operations. It provides also the section
    mechanism (at a low level; discharge is not known at this step). *)
 
-type node = 
+type node =
   | Leaf of Libobject.obj
   | CompilingLibrary of Libnames.object_prefix
   | OpenedModule of bool option * Libnames.object_prefix * Summary.frozen
@@ -32,15 +32,15 @@ type lib_objects = (Names.identifier * Libobject.obj) list
 
 val open_objects : int -> Libnames.object_prefix -> lib_objects -> unit
 val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit
-val subst_objects : Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects
-val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects
+val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects
+(*val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*)
 
 (* [classify_segment seg] verifies that there are no OpenedThings,
    clears ClosedSections and FrozenStates and divides Leafs according
    to their answers to the [classify_object] function in three groups:
    [Substitute], [Keep], [Anticipate] respectively.  The order of each
    returned list is the same as in the input list. *)
-val classify_segment : 
+val classify_segment :
   library_segment -> lib_objects * lib_objects * Libobject.obj list
 
 (* [segment_of_objects prefix objs] forms a list of Leafs *)
@@ -52,7 +52,6 @@ val segment_of_objects :
   current list of operations (most recent ones coming first). *)
 
 val add_leaf : Names.identifier -> Libobject.obj -> Libnames.object_name
-val add_absolutely_named_leaf : Libnames.object_name -> Libobject.obj -> unit
 val add_anonymous_leaf : Libobject.obj -> unit
 
 (* this operation adds all objects with the same name and calls [load_object]
@@ -70,7 +69,7 @@ val current_command_label : unit -> int
    registered after it. *)
 val reset_label : int -> unit
 
-(*s The function [contents_after] returns the current library segment, 
+(*s The function [contents_after] returns the current library segment,
   starting from a given section path. If not given, the entire segment
   is returned. *)
 
@@ -80,9 +79,11 @@ val contents_after : Libnames.object_name option -> library_segment
 
 (* User-side names *)
 val cwd : unit -> Names.dir_path
-val current_dirpath : bool -> Names.dir_path
-val make_path : Names.identifier -> Libnames.section_path
-val path_of_include : unit -> Libnames.section_path
+val cwd_except_section : unit -> Names.dir_path
+val current_dirpath : bool -> Names.dir_path (* false = except sections *)
+val make_path : Names.identifier -> Libnames.full_path
+val make_path_except_section : Names.identifier -> Libnames.full_path
+val path_of_include : unit -> Libnames.full_path
 
 (* Kernel-side names *)
 val current_prefix : unit -> Names.module_path * Names.dir_path
@@ -98,20 +99,19 @@ val is_modtype : unit -> bool
 val is_module : unit -> bool
 val current_mod_id : unit -> Names.module_ident
 
-(* Returns the most recent OpenedThing node *)
-val what_is_opened : unit -> Libnames.object_name * node
-
+(* Returns the opening node of a given name *)
+val find_opening_node : Names.identifier -> node
 
 (*s Modules and module types *)
 
-val start_module : 
+val start_module :
   bool option -> Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix
-val end_module : Names.module_ident 
+val end_module : unit
   -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment
 
-val start_modtype : 
+val start_modtype :
   Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix
-val end_modtype : Names.module_ident 
+val end_modtype : unit
   -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment
 (* [Lib.add_frozen_state] must be called after each of the above functions *)
 
@@ -134,7 +134,7 @@ val remove_section_part : Libnames.global_reference -> Names.dir_path
 (*s Sections *)
 
 val open_section : Names.identifier -> unit
-val close_section : Names.identifier -> unit
+val close_section : unit -> unit
 
 (*s Backtracking (undo). *)
 
@@ -146,7 +146,7 @@ val reset_to_state : Libnames.object_name -> unit
 
 val has_top_frozen_state : unit -> Libnames.object_name option
 
-(* [back n] resets to the place corresponding to the $n$-th call of 
+(* [back n] resets to the place corresponding to the $n$-th call of
    [mark_end_of_command] (counting backwards) *)
 val back : int -> unit
 
@@ -182,17 +182,16 @@ val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_cont
 val section_instance : Libnames.global_reference -> Names.identifier array
 val is_in_section : Libnames.global_reference -> bool
 
-val add_section_variable : Names.identifier -> binding_kind -> 
-  (Term.types * Names.identifier list) option -> unit
+val add_section_variable : Names.identifier -> binding_kind -> unit
 
 val add_section_constant : Names.constant -> Sign.named_context -> unit
-val add_section_kn : Names.kernel_name -> Sign.named_context -> unit
+val add_section_kn : Names.mutual_inductive -> Sign.named_context -> unit
 val replacement_context : unit ->
-  (Names.identifier array Names.Cmap.t * Names.identifier array Names.KNmap.t)
+  (Names.identifier array Names.Cmap.t * Names.identifier array Names.Mindmap.t)
 
 (*s Discharge: decrease the section level if in the current section *)
 
-val discharge_kn :  Names.kernel_name -> Names.kernel_name
+val discharge_kn :  Names.mutual_inductive -> Names.mutual_inductive
 val discharge_con : Names.constant -> Names.constant
 val discharge_global : Libnames.global_reference -> Libnames.global_reference
 val discharge_inductive : Names.inductive -> Names.inductive
diff --git a/library/libnames.ml b/library/libnames.ml
index 89a77128..9a7135ea 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libnames.ml 11878 2009-02-03 12:48:18Z soubiran $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -23,24 +23,49 @@ type global_reference =
   | ConstructRef of constructor
 
 let isVarRef = function VarRef _ -> true | _ -> false
+let isConstRef = function ConstRef _ -> true | _ -> false
+let isIndRef = function IndRef _ -> true | _ -> false
+let isConstructRef = function ConstructRef _ -> true | _ -> false
+
+let eq_gr gr1 gr2 =
+  match gr1,gr2 with 
+      ConstRef con1, ConstRef con2 ->
+	eq_constant con1 con2
+    | IndRef kn1,IndRef kn2 -> eq_ind kn1 kn2
+    | ConstructRef kn1,ConstructRef kn2 -> eq_constructor kn1 kn2
+    | _,_ -> gr1=gr2
+
+let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef"
+let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef"
+let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef"
+let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef"
 
 let subst_constructor subst ((kn,i),j as ref) =
-  let kn' = subst_kn subst kn in 
+  let kn' = subst_ind subst kn in
     if kn==kn' then ref, mkConstruct ref
     else ((kn',i),j), mkConstruct ((kn',i),j)
-      
+
 let subst_global subst ref = match ref with
   | VarRef var -> ref, mkVar var
   | ConstRef kn ->
      let kn',t = subst_con subst kn in
       if kn==kn' then ref, mkConst kn else ConstRef kn', t
   | IndRef (kn,i) ->
-      let kn' = subst_kn subst kn in
+      let kn' = subst_ind subst kn in
       if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i)
   | ConstructRef ((kn,i),j as c) ->
       let c',t = subst_constructor subst c in
 	if c'==c then ref,t else ConstructRef c', t
 
+let canonical_gr = function
+  | ConstRef con -> 
+      ConstRef(constant_of_kn(canonical_con con))
+  | IndRef (kn,i) ->
+      IndRef(mind_of_kn(canonical_mind kn),i)
+  | ConstructRef ((kn,i),j )->
+	  ConstructRef((mind_of_kn(canonical_mind kn),i),j)
+  | VarRef id ->  VarRef id
+
 let global_of_constr c = match kind_of_term c with
   | Const sp -> ConstRef sp
   | Ind ind_sp -> IndRef ind_sp
@@ -57,16 +82,32 @@ let constr_of_global = function
 let constr_of_reference = constr_of_global
 let reference_of_constr = global_of_constr
 
-module RefOrdered =
-  struct
-    type t = global_reference
-    let compare = Pervasives.compare
-  end
-
+(* outside of the kernel, names are ordered on their canonical part *)
+module RefOrdered = struct
+  type t = global_reference
+  let compare x y = 
+    let make_name = function
+      | ConstRef con -> 
+	  ConstRef(constant_of_kn(canonical_con con))
+      | IndRef (kn,i) ->
+	  IndRef(mind_of_kn(canonical_mind kn),i)
+      | ConstructRef ((kn,i),j )->
+	  ConstructRef((mind_of_kn(canonical_mind kn),i),j)
+      | VarRef id ->  VarRef id
+    in
+	Pervasives.compare (make_name x) (make_name y)
+end
+  
 module Refset = Set.Make(RefOrdered)
 module Refmap = Map.Make(RefOrdered)
+  
+(* Extended global references *)
+
+type syndef_name = kernel_name
 
-let inductives_table = ref Indmap.empty
+type extended_global_reference =
+  | TrueGlobal of global_reference
+  | SynDef of syndef_name
 
 (**********************************************)
 
@@ -75,10 +116,10 @@ let pr_dirpath sl = (str (string_of_dirpath sl))
 (*s Operations on dirpaths *)
 
 (* Pop the last n module idents *)
-let extract_dirpath_prefix n dir =
+let pop_dirpath_n n dir =
   make_dirpath (list_skipn n (repr_dirpath dir))
 
-let dirpath_prefix p = match repr_dirpath p with
+let pop_dirpath p = match repr_dirpath p with
   | [] -> anomaly "dirpath_prefix: empty dirpath"
   | _::l -> make_dirpath l
 
@@ -101,24 +142,8 @@ let add_dirpath_prefix id d = make_dirpath (repr_dirpath d @ [id])
 let split_dirpath d =
   let l = repr_dirpath d in (make_dirpath (List.tl l), List.hd l)
 
-let extend_dirpath p id = make_dirpath (id :: repr_dirpath p)
+let add_dirpath_suffix p id = make_dirpath (id :: repr_dirpath p)
 
-
-(*
-let path_of_constructor env ((sp,tyi),ind) =
-   let mib = Environ.lookup_mind sp env in
-   let mip = mib.mind_packets.(tyi) in 
-   let (pa,_) = repr_path sp in 
-   Names.make_path pa (mip.mind_consnames.(ind-1))
-
-let path_of_inductive env (sp,tyi) =
-  if tyi = 0 then sp
-  else
-    let mib = Environ.lookup_mind sp env in
-    let mip = mib.mind_packets.(tyi) in 
-    let (pa,_) = repr_path sp in 
-    Names.make_path pa (mip.mind_typename) 
-*)
 (* parsing *)
 let parse_dir s =
   let len = String.length s in
@@ -127,24 +152,27 @@ let parse_dir s =
     if n >= len then dirs else
     let pos =
       try
-	String.index_from s n '.' 
+	String.index_from s n '.'
       with Not_found -> len
     in
     if pos = n then error (s ^ " is an invalid path.");
     let dir = String.sub s n (pos-n) in
-    decoupe_dirs ((id_of_string dir)::dirs) (pos+1)	  
+    decoupe_dirs ((id_of_string dir)::dirs) (pos+1)
   in
     decoupe_dirs [] 0
 
 let dirpath_of_string s =
   make_dirpath (if s = "" then [] else parse_dir s)
 
+let string_of_dirpath = Names.string_of_dirpath
+
+
 module Dirset = Set.Make(struct type t = dir_path let compare = compare end)
 module Dirmap = Map.Make(struct type t = dir_path let compare = compare end)
 
 (*s Section paths are absolute names *)
 
-type section_path = {
+type full_path = {
   dirpath : dir_path ;
   basename : identifier }
 
@@ -165,7 +193,7 @@ let sp_ord sp1 sp2 =
 
 module SpOrdered =
   struct
-    type t = section_path
+    type t = full_path
     let compare = sp_ord
   end
 
@@ -183,41 +211,33 @@ let path_of_string s =
   with
     | Invalid_argument _ -> invalid_arg "path_of_string"
 
-let pr_sp sp = str (string_of_path sp) 
+let pr_path sp = str (string_of_path sp)
 
 let restrict_path n sp =
   let dir, s = repr_path sp in
   let dir' = list_firstn n (repr_dirpath dir) in
   make_path (make_dirpath dir') s
 
-type extended_global_reference =
-  | TrueGlobal of global_reference
-  | SyntacticDef of kernel_name
-
-let encode_kn dir id = make_kn (MPfile dir) empty_dirpath (label_of_id id)
+let encode_mind dir id = make_mind (MPfile dir) empty_dirpath (label_of_id id)
 
 let encode_con dir id = make_con (MPfile dir) empty_dirpath (label_of_id id)
 
-let decode_kn kn = 
+let decode_mind kn =
   let rec dir_of_mp = function
     | MPfile dir -> repr_dirpath dir
     | MPbound mbid -> 
 	let _,_,dp = repr_mbid mbid in
 	let id = id_of_mbid mbid in
 	  id::(repr_dirpath dp)
-    | MPself msid -> 
-	let _,_,dp = repr_msid msid in
-	let id = id_of_msid msid in
-	  id::(repr_dirpath dp) 
     | MPdot(mp,l) -> (id_of_label l)::(dir_of_mp mp)
   in
-  let mp,sec_dir,l = repr_kn kn in
+  let mp,sec_dir,l = repr_mind kn in
     if (repr_dirpath sec_dir) = [] then
      (make_dirpath (dir_of_mp mp)),id_of_label l
     else
       anomaly "Section part should be empty!"
 
-let decode_con kn = 
+let decode_con kn =
   let mp,sec_dir,l = repr_con kn in
     match mp,(repr_dirpath sec_dir) with
 	MPfile dir,[] -> (dir,id_of_label l)
@@ -225,31 +245,31 @@ let decode_con kn =
       | _ -> anomaly "Section part should be empty!"
 
 (*s qualified names *)
-type qualid = section_path
+type qualid = full_path
 
 let make_qualid = make_path
 let repr_qualid = repr_path
 
 let string_of_qualid = string_of_path
-let pr_qualid = pr_sp
+let pr_qualid = pr_path
 
 let qualid_of_string = path_of_string
 
-let qualid_of_sp sp = sp
-let make_short_qualid id = make_qualid empty_dirpath id
-let qualid_of_dirpath dir = 
+let qualid_of_path sp = sp
+let qualid_of_ident id = make_qualid empty_dirpath id
+let qualid_of_dirpath dir =
   let (l,a) = split_dirpath dir in
   make_qualid l a
 
-type object_name = section_path * kernel_name
+type object_name = full_path * kernel_name
 
 type object_prefix = dir_path * (module_path * dir_path)
 
-let make_oname (dirpath,(mp,dir)) id = 
+let make_oname (dirpath,(mp,dir)) id =
   make_path dirpath id, make_kn mp dir (label_of_id id)
 
 (* to this type are mapped dir_path's in the nametab *)
-type global_dir_reference = 
+type global_dir_reference =
   | DirOpenModule of object_prefix
   | DirOpenModtype of object_prefix
   | DirOpenSection of object_prefix
@@ -265,19 +285,19 @@ type global_dir_reference =
           ModTypeRef kn'
 *)
 
-type reference = 
+type reference =
   | Qualid of qualid located
   | Ident of identifier located
 
 let qualid_of_reference = function
   | Qualid (loc,qid) -> loc, qid
-  | Ident (loc,id) -> loc, make_short_qualid id
+  | Ident (loc,id) -> loc, qualid_of_ident id
 
 let string_of_reference = function
   | Qualid (loc,qid) -> string_of_qualid qid
   | Ident (loc,id) -> string_of_id id
 
-let pr_reference = function 
+let pr_reference = function
   | Qualid (_,qid) -> pr_qualid qid
   | Ident (_,id) -> pr_id id
 
@@ -289,14 +309,19 @@ let loc_of_reference = function
 
 let pop_con con =
   let (mp,dir,l) = repr_con con in
-  Names.make_con mp (dirpath_prefix dir) l
+  Names.make_con mp (pop_dirpath dir) l
 
 let pop_kn kn =
-  let (mp,dir,l) = repr_kn kn in
-  Names.make_kn mp (dirpath_prefix dir) l
+  let (mp,dir,l) = repr_mind kn in
+  Names.make_mind mp (pop_dirpath dir) l
 
 let pop_global_reference = function
   | ConstRef con -> ConstRef (pop_con con)
   | IndRef (kn,i) -> IndRef (pop_kn kn,i)
   | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j)
   | VarRef id -> anomaly "VarRef not poppable"
+
+(* Deprecated synonyms *)
+
+let make_short_qualid = qualid_of_ident
+let qualid_of_sp = qualid_of_path
diff --git a/library/libnames.mli b/library/libnames.mli
index cc664a08..9ee7d0ab 100644
--- a/library/libnames.mli
+++ b/library/libnames.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libnames.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -24,6 +24,18 @@ type global_reference =
   | ConstructRef of constructor
 
 val isVarRef : global_reference -> bool
+val isConstRef : global_reference -> bool
+val isIndRef : global_reference -> bool
+val isConstructRef : global_reference -> bool
+
+val eq_gr : global_reference -> global_reference -> bool
+val canonical_gr : global_reference -> global_reference
+
+val destVarRef : global_reference -> variable
+val destConstRef : global_reference -> constant
+val destIndRef : global_reference -> inductive
+val destConstructRef : global_reference -> constructor
+
 
 val subst_constructor : substitution -> constructor -> constructor * constr
 val subst_global : substitution -> global_reference -> global_reference * constr
@@ -39,97 +51,112 @@ val global_of_constr : constr -> global_reference
 val constr_of_reference : global_reference -> constr
 val reference_of_constr : constr -> global_reference
 
-module Refset : Set.S with type elt = global_reference 
+module RefOrdered : sig
+  type t = global_reference
+  val compare : global_reference -> global_reference -> int
+end
+  
+
+module Refset : Set.S with type elt = global_reference
 module Refmap : Map.S with type key = global_reference
 
+(*s Extended global references *)
+
+type syndef_name = kernel_name
+
+type extended_global_reference =
+  | TrueGlobal of global_reference
+  | SynDef of syndef_name
+
 (*s Dirpaths *)
 val pr_dirpath : dir_path -> Pp.std_ppcmds
 
 val dirpath_of_string : string -> dir_path
+val string_of_dirpath : dir_path -> string
 
-(* Give the immediate prefix of a [dir_path] *)
-val dirpath_prefix : dir_path -> dir_path 
+(* Pop the suffix of a [dir_path] *)
+val pop_dirpath : dir_path -> dir_path
+
+(* Pop the suffix n times *)
+val pop_dirpath_n : int -> dir_path -> dir_path
 
 (* Give the immediate prefix and basename of a [dir_path] *)
 val split_dirpath : dir_path -> dir_path * identifier
 
-val extend_dirpath : dir_path -> module_ident -> dir_path
+val add_dirpath_suffix : dir_path -> module_ident -> dir_path
 val add_dirpath_prefix : module_ident -> dir_path -> dir_path
 
 val chop_dirpath : int -> dir_path -> dir_path * dir_path
+val append_dirpath : dir_path -> dir_path -> dir_path
+
 val drop_dirpath_prefix : dir_path -> dir_path -> dir_path
-val extract_dirpath_prefix : int -> dir_path -> dir_path
 val is_dirpath_prefix_of : dir_path -> dir_path -> bool
-val append_dirpath : dir_path -> dir_path -> dir_path
 
 module Dirset : Set.S with type elt = dir_path
 module Dirmap : Map.S with type key = dir_path
 
-(*s Section paths are {\em absolute} names *)
-type section_path
+(*s Full paths are {\em absolute} paths of declarations *)
+type full_path
 
-(* Constructors of [section_path] *)
-val make_path : dir_path -> identifier -> section_path
+(* Constructors of [full_path] *)
+val make_path : dir_path -> identifier -> full_path
 
-(* Destructors of [section_path] *)
-val repr_path : section_path -> dir_path * identifier
-val dirpath : section_path -> dir_path
-val basename : section_path -> identifier
+(* Destructors of [full_path] *)
+val repr_path : full_path -> dir_path * identifier
+val dirpath : full_path -> dir_path
+val basename : full_path -> identifier
 
 (* Parsing and printing of section path as ["coq_root.module.id"] *)
-val path_of_string : string -> section_path
-val string_of_path : section_path -> string
-val pr_sp : section_path -> std_ppcmds
-
-module Sppred : Predicate.S with type elt = section_path
-module Spmap  : Map.S with type key = section_path
+val path_of_string : string -> full_path
+val string_of_path : full_path -> string
+val pr_path : full_path -> std_ppcmds
 
-val restrict_path : int -> section_path -> section_path
+module Sppred : Predicate.S with type elt = full_path
+module Spmap  : Map.S with type key = full_path
 
-type extended_global_reference =
-  | TrueGlobal of global_reference
-  | SyntacticDef of kernel_name
+val restrict_path : int -> full_path -> full_path
 
 (*s Temporary function to brutally form kernel names from section paths *)
 
-val encode_kn : dir_path -> identifier -> kernel_name
-val decode_kn : kernel_name -> dir_path * identifier
+val encode_mind : dir_path -> identifier -> mutual_inductive
+val decode_mind : mutual_inductive -> dir_path * identifier
 val encode_con : dir_path -> identifier -> constant
 val decode_con : constant -> dir_path * identifier
 
 
 (*s A [qualid] is a partially qualified ident; it includes fully
     qualified names (= absolute names) and all intermediate partial
-    qualifications of absolute names, including single identifiers *)
+    qualifications of absolute names, including single identifiers.
+    The [qualid] are used to access the name table. *)
+
 type qualid
 
 val make_qualid : dir_path -> identifier -> qualid
 val repr_qualid : qualid -> dir_path * identifier
 
-val string_of_qualid : qualid -> string
 val pr_qualid : qualid -> std_ppcmds
-
+val string_of_qualid : qualid -> string
 val qualid_of_string : string -> qualid
 
-(* Turns an absolute name into a qualified name denoting the same name *)
-val qualid_of_sp : section_path -> qualid
+(* Turns an absolute name, a dirpath, or an identifier into a
+   qualified name denoting the same name *)
 
+val qualid_of_path : full_path -> qualid
 val qualid_of_dirpath : dir_path -> qualid
-
-val make_short_qualid : identifier -> qualid
+val qualid_of_ident : identifier -> qualid
 
 (* Both names are passed to objects: a "semantic" [kernel_name], which
-   can be substituted and a "syntactic" [section_path] which can be printed
+   can be substituted and a "syntactic" [full_path] which can be printed
 *)
 
-type object_name = section_path * kernel_name
+type object_name = full_path * kernel_name
 
 type object_prefix = dir_path * (module_path * dir_path)
 
 val make_oname : object_prefix -> identifier -> object_name
 
 (* to this type are mapped [dir_path]'s in the nametab *)
-type global_dir_reference = 
+type global_dir_reference =
   | DirOpenModule of object_prefix
   | DirOpenModtype of object_prefix
   | DirOpenSection of object_prefix
@@ -137,7 +164,11 @@ type global_dir_reference =
   | DirClosedSection of dir_path
       (* this won't last long I hope! *)
 
-type reference = 
+(*s A [reference] is the user-level notion of name. It denotes either a
+    global name (referred either by a qualified name or by a single
+    name) or a variable *)
+
+type reference =
   | Qualid of qualid located
   | Ident of identifier located
 
@@ -146,8 +177,13 @@ val string_of_reference : reference -> string
 val pr_reference : reference -> std_ppcmds
 val loc_of_reference : reference -> loc
 
-(* popping one level of section in global names *)
+(*s Popping one level of section in global names *)
 
 val pop_con : constant -> constant
-val pop_kn : kernel_name -> kernel_name
+val pop_kn : mutual_inductive-> mutual_inductive
 val pop_global_reference : global_reference -> global_reference
+
+(* Deprecated synonyms *)
+
+val make_short_qualid : identifier -> qualid (* = qualid_of_ident *)
+val qualid_of_sp : full_path -> qualid (* = qualid_of_path *)
diff --git a/library/libobject.ml b/library/libobject.ml
index b455e2b3..ecdcacf1 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: libobject.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -25,7 +25,7 @@ let relax_flag = ref false;;
 
 let relax b = relax_flag := b;;
 
-type 'a substitutivity = 
+type 'a substitutivity =
     Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a
 
 type 'a object_declaration = {
@@ -33,11 +33,10 @@ type 'a object_declaration = {
   cache_function : object_name * 'a -> unit;
   load_function : int -> object_name * 'a -> unit;
   open_function : int -> object_name * 'a -> unit;
-  classify_function : object_name * 'a -> 'a substitutivity;
-  subst_function : object_name * substitution * 'a -> 'a;
+  classify_function : 'a -> 'a substitutivity;
+  subst_function :  substitution * 'a -> 'a;
   discharge_function : object_name * 'a -> 'a option;
-  rebuild_function : 'a -> 'a;
-  export_function : 'a -> 'a option }
+  rebuild_function : 'a -> 'a }
 
 let yell s = anomaly s
 
@@ -46,12 +45,11 @@ let default_object s = {
   cache_function = (fun _ -> ());
   load_function = (fun _ _ -> ());
   open_function = (fun _ _ -> ());
-  subst_function = (fun _ -> 
+  subst_function = (fun _ ->
     yell ("The object "^s^" does not know how to substitute!"));
-  classify_function = (fun (_,obj) -> Keep obj);
+  classify_function = (fun obj -> Keep obj);
   discharge_function = (fun _ -> None);
-  rebuild_function = (fun x -> x);
-  export_function = (fun _ -> None)} 
+  rebuild_function = (fun x -> x)}
 
 
 (* The suggested object declaration is the following:
@@ -59,13 +57,13 @@ let default_object s = {
    declare_object { (default_object "MY OBJECT") with
        cache_function = fun (sp,a) -> Mytbl.add sp a}
 
-   and the listed functions are only those which definitions accually 
+   and the listed functions are only those which definitions accually
    differ from the default.
 
    This helps introducing new functions in objects.
 *)
 
-let ident_subst_function (_,_,a) = a
+let ident_subst_function (_,a) = a
 
 type obj = Dyn.t (* persistent dynamic objects *)
 
@@ -73,15 +71,14 @@ type dynamic_object_declaration = {
   dyn_cache_function : object_name * obj -> unit;
   dyn_load_function : int -> object_name * obj -> unit;
   dyn_open_function : int -> object_name * obj -> unit;
-  dyn_subst_function : object_name * substitution * obj -> obj;
-  dyn_classify_function : object_name * obj -> obj substitutivity;
+  dyn_subst_function : substitution * obj -> obj;
+  dyn_classify_function : obj -> obj substitutivity;
   dyn_discharge_function : object_name * obj -> obj option;
-  dyn_rebuild_function : obj -> obj;
-  dyn_export_function : obj -> obj option }
+  dyn_rebuild_function : obj -> obj }
 
 let object_tag lobj = Dyn.tag lobj
 
-let cache_tab = 
+let cache_tab =
   (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
 
 let declare_object odecl =
@@ -96,85 +93,79 @@ let declare_object odecl =
   and opener i (oname,lobj) =
     if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj)
     else anomaly "somehow we got the wrong dynamic object in the openfun"
-  and substituter (oname,sub,lobj) = 
+  and substituter (sub,lobj) = 
     if Dyn.tag lobj = na then 
-      infun (odecl.subst_function (oname,sub,outfun lobj))
+      infun (odecl.subst_function (sub,outfun lobj))
     else anomaly "somehow we got the wrong dynamic object in the substfun"
-  and classifier (spopt,lobj) = 
-    if Dyn.tag lobj = na then 
-      match odecl.classify_function (spopt,outfun lobj) with
+  and classifier lobj =
+    if Dyn.tag lobj = na then
+      match odecl.classify_function (outfun lobj) with
 	| Dispose -> Dispose
 	| Substitute obj -> Substitute (infun obj)
 	| Keep obj -> Keep (infun obj)
 	| Anticipate (obj) -> Anticipate (infun obj)
-    else 
+    else
       anomaly "somehow we got the wrong dynamic object in the classifyfun"
-  and discharge (oname,lobj) = 
-    if Dyn.tag lobj = na then 
+  and discharge (oname,lobj) =
+    if Dyn.tag lobj = na then
       Option.map infun (odecl.discharge_function (oname,outfun lobj))
-    else 
+    else
       anomaly "somehow we got the wrong dynamic object in the dischargefun"
-  and rebuild lobj = 
+  and rebuild lobj =
     if Dyn.tag lobj = na then infun (odecl.rebuild_function (outfun lobj))
     else anomaly "somehow we got the wrong dynamic object in the rebuildfun"
-  and exporter lobj = 
-    if Dyn.tag lobj = na then 
-      Option.map infun (odecl.export_function (outfun lobj))
-    else 
-      anomaly "somehow we got the wrong dynamic object in the exportfun"
-
-  in 
+  in
   Hashtbl.add cache_tab na { dyn_cache_function = cacher;
 			     dyn_load_function = loader;
                              dyn_open_function = opener;
 			     dyn_subst_function = substituter;
 			     dyn_classify_function = classifier;
 			     dyn_discharge_function = discharge;
-			     dyn_rebuild_function = rebuild;
-                             dyn_export_function = exporter };
+			     dyn_rebuild_function = rebuild };
   (infun,outfun)
 
+let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t)
+
 (* 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. *)
 
 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 -> 
-	  if !relax_flag then
-	    failwith "local to_apply_dyn_fun"
-	  else
-	    error
-	      ("Cannot find library functions for an object with tag "^tag^
-	       " (maybe a plugin is missing)") in 
-	f dodecl
-    with
-	Failure "local to_apply_dyn_fun" -> deflt;;
+  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.warning ("Cannot find library functions for an object with tag "
+                      ^ tag ^ " (a plugin may be missing)");
+          Hashtbl.add missing_tab tag ()
+        end;
+      deflt
 
 let cache_object ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj
 
-let load_object i ((_,lobj) as node) = 
+let load_object i ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_load_function i node) lobj
 
-let open_object i ((_,lobj) as node) = 
+let open_object i ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj
 
-let subst_object ((_,_,lobj) as node) = 
+let subst_object ((_,lobj) as node) = 
   apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj
 
-let classify_object ((_,lobj) as node) = 
-  apply_dyn_fun Dispose (fun d -> d.dyn_classify_function node) lobj
+let classify_object lobj =
+  apply_dyn_fun Dispose (fun d -> d.dyn_classify_function lobj) lobj
 
-let discharge_object ((_,lobj) as node) = 
+let discharge_object ((_,lobj) as node) =
   apply_dyn_fun None (fun d -> d.dyn_discharge_function node) lobj
 
-let rebuild_object (lobj as node) =
-  apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function node) lobj
-
-let export_object lobj =
-  apply_dyn_fun None (fun d -> d.dyn_export_function lobj) lobj
+let rebuild_object lobj =
+  apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj
diff --git a/library/libobject.mli b/library/libobject.mli
index 4ec5746b..9c0abafd 100644
--- a/library/libobject.mli
+++ b/library/libobject.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libobject.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -18,38 +18,38 @@ open Mod_subst
 
    * a caching function specifying how to add the object in the current
      scope;
-     If the object wishes to register its visibility in the Nametab, 
+     If the object wishes to register its visibility in the Nametab,
      it should do so for all possible sufixes.
 
-   * a loading function, specifying what to do when the module 
-     containing the object is loaded; 
-     If the object wishes to register its visibility in the Nametab, 
-     it should do so for all sufixes no shorter then the "int" argument
+   * a loading function, specifying what to do when the module
+     containing the object is loaded;
+     If the object wishes to register its visibility in the Nametab,
+     it should do so for all sufixes no shorter than the "int" argument
 
-   * an opening function, specifying what to do when the module 
+   * an opening function, specifying what to do when the module
      containing the object is opened (imported);
-     If the object wishes to register its visibility in the Nametab, 
-     it should do so for the sufix of the length the "int" argument
+     If the object wishes to register its visibility in the Nametab,
+     it should do so for the suffix of the length the "int" argument
 
-   * a classification function, specyfying what to do with the object,
+   * a classification function, specifying what to do with the object,
      when the current module (containing the object) is ended;
      The possibilities are:
-     Dispose   - the object dies at the end of the module
-     Substitue - meaning the object is substitutive and 
-                 the module name must be updated
-     Keep      - the object is not substitutive, but survives module 
-                 closing
-     Anticipate - this is for objects which have to be explicitely 
-                 managed by the [end_module] function (like Require 
-                 and Read markers)
+     Dispose    - the object dies at the end of the module
+     Substitute - meaning the object is substitutive and
+                  the module name must be updated
+     Keep       - the object is not substitutive, but survives module
+                  closing
+     Anticipate - this is for objects that have to be explicitely
+                  managed by the [end_module] function (like Require
+                  and Read markers)
 
      The classification function is also an occasion for a cleanup
-     (if this function returns Keep or Substitute of some object, the 
+     (if this function returns Keep or Substitute of some object, the
      cache method is never called for it)
 
-   * a substitution function, performing the substitution; 
-     this function should be declared for substitutive objects 
-     only (see obove)
+   * a substitution function, performing the substitution;
+     this function should be declared for substitutive objects
+     only (see above)
 
    * a discharge function, that is applied at section closing time to
      collect the data necessary to rebuild the discharged form of the
@@ -59,16 +59,9 @@ open Mod_subst
      rebuild the non volatile content of a section from the data
      collected by the discharge function
 
-   * an export function, to enable optional writing of its contents 
-     to disk (.vo). This function is also the oportunity to remove 
-     redundant information in order to keep .vo size small 
-
-     The export function is a little obsolete and will be removed 
-     in the near future... 
-
 *)
 
-type 'a substitutivity = 
+type 'a substitutivity =
     Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a
 
 type 'a object_declaration = {
@@ -76,13 +69,12 @@ type 'a object_declaration = {
   cache_function : object_name * 'a -> unit;
   load_function : int -> object_name * 'a -> unit;
   open_function : int -> object_name * 'a -> unit;
-  classify_function : object_name * 'a -> 'a substitutivity;
-  subst_function : object_name * substitution * 'a -> 'a;
+  classify_function : 'a -> 'a substitutivity;
+  subst_function :  substitution * 'a -> 'a;
   discharge_function : object_name * 'a -> 'a option;
-  rebuild_function : 'a -> 'a;
-  export_function : 'a -> 'a option }
+  rebuild_function : 'a -> 'a }
 
-(* The default object is a "Keep" object with empty methods. 
+(* The default object is a "Keep" object with empty methods.
    Object creators are advised to use the construction
    [{(default_object "MY_OBJECT") with
       cache_function = ...
@@ -94,7 +86,7 @@ type 'a object_declaration = {
 val default_object : string -> 'a object_declaration
 
 (* the identity substitution function *)
-val ident_subst_function : object_name * substitution * 'a -> 'a
+val ident_subst_function : substitution * 'a -> 'a
 
 (*s Given an object declaration, the function [declare_object]
    will hand back two functions, the "injection" and "projection"
@@ -102,7 +94,7 @@ val ident_subst_function : object_name * substitution * 'a -> 'a
 
 type obj
 
-val declare_object : 
+val declare_object :
   'a object_declaration -> ('a -> obj) * (obj -> 'a)
 
 val object_tag : obj -> string
@@ -110,9 +102,8 @@ val object_tag : obj -> string
 val cache_object : object_name * obj -> unit
 val load_object : int -> object_name * obj -> unit
 val open_object : int -> object_name * obj -> unit
-val subst_object : object_name * substitution * obj -> obj
-val classify_object : object_name * obj -> obj substitutivity
-val export_object : obj -> obj option
+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
diff --git a/library/library.ml b/library/library.ml
index 2c6d02ae..d066ff89 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: library.ml 13175 2010-06-22 06:28:37Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -39,7 +39,7 @@ let is_in_load_paths phys_dir =
   let dir = System.canonical_path_name phys_dir in
   let lp = get_load_paths () in
   let check_p = fun p -> (String.compare dir p) == 0 in
-    List.exists check_p lp 
+    List.exists check_p lp
 
 let remove_load_path dir =
   load_paths := List.filter (fun (p,d,_) -> p <> dir) !load_paths
@@ -48,7 +48,7 @@ let add_load_path isroot (phys_path,coq_path) =
   let phys_path = System.canonical_path_name phys_path in
     match List.filter (fun (p,d,_) -> p = phys_path) !load_paths with
       | [_,dir,_] ->
-	  if coq_path <> dir 
+	  if coq_path <> dir
             (* If this is not the default -I . to coqtop *)
             && not
             (phys_path = System.canonical_path_name Filename.current_dir_name
@@ -71,7 +71,7 @@ let add_load_path isroot (phys_path,coq_path) =
 let physical_paths (dp,lp) = dp
 
 let extend_path_with_dirpath p dir =
-  List.fold_left Filename.concat p 
+  List.fold_left Filename.concat p
     (List.map string_of_id (List.rev (repr_dirpath dir)))
 
 let root_paths_matching_dir_path dir =
@@ -112,12 +112,12 @@ let loadpaths_matching_dir_path dir =
 let get_full_load_paths () = List.map (fun (a,b,c) -> (a,b)) !load_paths
 
 (************************************************************************)
-(*s Modules on disk contain the following informations (after the magic 
+(*s Modules on disk contain the following informations (after the magic
     number, and before the digest). *)
 
 type compilation_unit_name = dir_path
 
-type library_disk = { 
+type library_disk = {
   md_name : compilation_unit_name;
   md_compiled : compiled_library;
   md_objects : Declaremods.library_objects;
@@ -135,7 +135,7 @@ type library_t = {
   library_imports : compilation_unit_name list;
   library_digest : Digest.t }
 
-module LibraryOrdered = 
+module LibraryOrdered =
   struct
     type t = dir_path
     let compare d1 d2 =
@@ -164,7 +164,7 @@ let freeze () =
   !libraries_imports_list,
   !libraries_exports_list
 
-let unfreeze (mt,mo,mi,me) = 
+let unfreeze (mt,mo,mi,me) =
   libraries_table := mt;
   libraries_loaded_list := mo;
   libraries_imports_list := mi;
@@ -176,13 +176,11 @@ let init () =
   libraries_imports_list := [];
   libraries_exports_list := []
 
-let _ = 
+let _ =
   Summary.declare_summary "MODULES"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
 
 (* various requests to the tables *)
 
@@ -197,7 +195,7 @@ let try_find_library dir =
 let register_library_filename dir f =
   (* Not synchronized: overwrite the previous binding if one existed *)
   (* from a previous play of the session *)
-  libraries_filename_table := 
+  libraries_filename_table :=
     LibraryFilenameMap.add dir f !libraries_filename_table
 
 let library_full_filename dir =
@@ -214,13 +212,13 @@ let library_is_loaded dir =
   try let _ = find_library dir in true
   with Not_found -> false
 
-let library_is_opened dir = 
+let library_is_opened dir =
   List.exists (fun m -> m.library_name = dir) !libraries_imports_list
 
 let library_is_exported dir =
   List.exists (fun m -> m.library_name = dir) !libraries_exports_list
 
-let loaded_libraries () = 
+let loaded_libraries () =
   List.map (fun m -> m.library_name) !libraries_loaded_list
 
 let opened_libraries () =
@@ -251,7 +249,7 @@ let rec remember_last_of_each l m =
 
 let register_open_library export m =
   libraries_imports_list := remember_last_of_each !libraries_imports_list m;
-  if export then 
+  if export then
     libraries_exports_list := remember_last_of_each !libraries_exports_list m
 
 (************************************************************************)
@@ -273,14 +271,14 @@ let open_library export explicit_libs m =
     Declaremods.really_import_module (MPfile m.library_name)
   end
   else
-    if export then 
+    if export then
       libraries_exports_list := remember_last_of_each !libraries_exports_list m
 
-(* open_libraries recursively open a list of libraries but opens only once 
+(* open_libraries recursively open a list of libraries but opens only once
    a library that is re-exported many times *)
 
 let open_libraries export modl =
-  let to_open_list = 
+  let to_open_list =
     List.fold_left
       (fun l m ->
          let subimport =
@@ -301,19 +299,16 @@ let open_import i (_,(dir,export)) =
     (* if not (library_is_opened dir) then *)
       open_libraries export [try_find_library dir]
 
-let cache_import obj = 
+let cache_import obj =
   open_import 1 obj
 
-let subst_import (_,_,o) = o
+let subst_import (_,o) = o
 
-let export_import o = Some o
-
-let classify_import (_,(_,export as obj)) = 
+let classify_import (_,export as obj) =
   if export then Substitute obj else Dispose
 
-
 let (in_import, out_import) =
-  declare_object {(default_object "IMPORT LIBRARY") with 
+  declare_object {(default_object "IMPORT LIBRARY") with
        cache_function = cache_import;
        open_function = open_import;
        subst_function = subst_import;
@@ -359,7 +354,7 @@ let locate_qualified_library warn qid =
     if loadpath = [] then raise LibUnmappedDir;
     let name = string_of_id base ^ ".vo" in
     let lpath, file = System.where_in_path ~warn (List.map fst loadpath) name in
-    let dir = extend_dirpath (List.assoc lpath loadpath) base in
+    let dir = add_dirpath_suffix (List.assoc lpath loadpath) base in
     (* Look if loaded *)
     if library_is_loaded dir then (LibLoaded, dir, library_full_filename dir)
     (* Otherwise, look for it in the file system *)
@@ -370,7 +365,7 @@ let explain_locate_library_error qid = function
   | LibUnmappedDir ->
       let prefix, _ = repr_qualid qid in
       errorlabstrm "load_absolute_library_from"
-      (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ 
+      (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++
       str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ())
   | LibNotFound ->
       errorlabstrm "load_absolute_library_from"
@@ -387,14 +382,14 @@ let try_locate_qualified_library (loc,qid) =
   try
     let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in
     dir,f
-  with e -> 
+  with e ->
     explain_locate_library_error qid e
 
 
 (************************************************************************)
 (* Internalise libraries *)
 
-let lighten_library m = 
+let lighten_library m =
   if !Flags.dont_load_proofs then lighten_library m else m
 
 let mk_library md digest = {
@@ -458,7 +453,7 @@ let rec_intern_by_filename_only id f =
   (* We check no other file containing same library is loaded *)
   if library_is_loaded m.library_name then
     begin
-      Flags.if_verbose warning 
+      Flags.if_verbose warning
 	((string_of_dirpath m.library_name)^" is already loaded from file "^
 	library_full_filename m.library_name);
       m.library_name, []
@@ -470,15 +465,15 @@ let rec_intern_by_filename_only id f =
 let rec_intern_library_from_file idopt f =
   (* A name is specified, we have to check it contains library id *)
   let paths = get_load_paths () in
-  let _, f = 
+  let _, f =
     System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in
   rec_intern_by_filename_only idopt f
 
 (**********************************************************************)
-(*s [require_library] loads and possibly opens a library. This is a 
+(*s [require_library] loads and possibly opens a library. This is a
     synchronized operation. It is performed as follows:
 
-  preparation phase: (functions require_library* ) the library and its 
+  preparation phase: (functions require_library* ) the library and its
     dependencies are read from to disk (using intern_* )
     [they are read from disk to ensure that at section/module
      discharging time, the physical library referred to outside the
@@ -486,8 +481,8 @@ let rec_intern_library_from_file idopt f =
      the section/module]
 
   execution phase: (through add_leaf and cache_require)
-    the library is loaded in the environment and Nametab, the objects are 
-    registered etc, using functions from Declaremods (via load_library, 
+    the library is loaded in the environment and Nametab, the objects are
+    registered etc, using functions from Declaremods (via load_library,
     which recursively loads its dependencies)
 *)
 
@@ -495,14 +490,14 @@ type library_reference = dir_path list * bool option
 
 let register_library (dir,m) =
   Declaremods.register_library
-    m.library_name 
-    m.library_compiled 
-    m.library_objects 
+    m.library_name
+    m.library_compiled
+    m.library_objects
     m.library_digest;
   register_loaded_library m
 
 (* Follow the semantics of Anticipate object:
-   - called at module or module type closing when a Require occurs in 
+   - called at module or module type closing when a Require occurs in
      the module or module type
    - not called from a library (i.e. a module identified with a file) *)
 let load_require _ (_,(needed,modl,_)) =
@@ -517,22 +512,17 @@ let cache_require o =
   load_require 1 o;
   open_require 1 o
 
-  (* keeps the require marker for closed section replay but removes
-     OS dependent fields from .vo files for cross-platform compatibility *)
-let export_require (_,l,e) = Some ([],l,e)
-
 let discharge_require (_,o) = Some o
 
-(* open_function is never called from here because an Anticipate object *) 
+(* open_function is never called from here because an Anticipate object *)
 
 let (in_require, out_require) =
   declare_object {(default_object "REQUIRE") with
        cache_function = cache_require;
        load_function = load_require;
        open_function = (fun _ _ -> assert false);
-       export_function = export_require;
        discharge_function = discharge_require;
-       classify_function = (fun (_,o) -> Anticipate o) }
+       classify_function = (fun o -> Anticipate o) }
 
 (* Require libraries, import them if [export <> None], mark them for export
    if [export = Some true] *)
@@ -540,11 +530,10 @@ let (in_require, out_require) =
 let xml_require = ref (fun d -> ())
 let set_xml_require f = xml_require := f
 
-let require_library qidl export =
-  let modrefl = List.map try_locate_qualified_library qidl in
+let require_library_from_dirpath modrefl export =
   let needed = List.rev (List.fold_left rec_intern_library [] modrefl) in
   let modrefl = List.map fst modrefl in
-    if Lib.is_modtype () || Lib.is_module () then 
+    if Lib.is_modtype () || Lib.is_module () then
       begin
 	add_anonymous_leaf (in_require (needed,modrefl,None));
 	Option.iter (fun exp ->
@@ -556,6 +545,10 @@ let require_library qidl export =
     if !Flags.xml_export then List.iter !xml_require modrefl;
   add_frozen_state ()
 
+let require_library qidl export =
+  let modrefl = List.map try_locate_qualified_library qidl in
+    require_library_from_dirpath modrefl export
+
 let require_library_from_file idopt file export =
   let modref,needed = rec_intern_library_from_file idopt file in
   let needed = List.rev needed in
@@ -574,7 +567,7 @@ let require_library_from_file idopt file export =
 let import_module export (loc,qid) =
   try
     match Nametab.locate_module qid with
-      | MPfile dir -> 
+      | MPfile dir ->
 	  if Lib.is_modtype () || Lib.is_module () || not export then
 	    add_anonymous_leaf (in_import (dir, export))
 	  else
@@ -586,23 +579,25 @@ let import_module export (loc,qid) =
 	user_err_loc
           (loc,"import_library",
 	  str ((string_of_qualid qid)^" is not a module"))
-  
+
 (************************************************************************)
 (*s Initializing the compilation of a library. *)
 
-let check_coq_overwriting p =
+let check_coq_overwriting p id =
   let l = repr_dirpath p in
   if not !Flags.boot && l <> [] && string_of_id (list_last l) = "Coq" then
-    errorlabstrm "" (strbrk ("Name "^string_of_dirpath p^" starts with prefix \"Coq\" which is reserved for the Coq library."))
+    errorlabstrm ""
+      (strbrk ("Cannot build module "^string_of_dirpath p^"."^string_of_id id^
+      ": it starts with prefix \"Coq\" which is reserved for the Coq library."))
 
-let start_library f = 
+let start_library f =
   let paths = get_load_paths () in
   let _,longf =
     System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in
   let ldir0 = find_logical_path (Filename.dirname longf) in
-  check_coq_overwriting ldir0;
   let id = id_of_string (Filename.basename f) in
-  let ldir = extend_dirpath ldir0 id in
+  check_coq_overwriting ldir0 id;
+  let ldir = add_dirpath_suffix ldir0 id in
   Declaremods.start_library ldir;
   ldir,longf
 
@@ -617,15 +612,15 @@ let current_reexports () =
 
 let error_recursively_dependent_library dir =
   errorlabstrm ""
-    (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ 
+    (strbrk "Unable to use logical name " ++ pr_dirpath dir ++
      strbrk " to save current library because" ++
      strbrk " it already depends on a library of this name.")
 
 (* Security weakness: file might have been changed on disk between
-   writing the content and computing the checksum... *) 
+   writing the content and computing the checksum... *)
 let save_library_to dir f =
   let cenv, seg = Declaremods.end_library dir in
-  let md = { 
+  let md = {
     md_name = dir;
     md_compiled = cenv;
     md_objects = seg;
@@ -650,5 +645,5 @@ open Printf
 let mem s =
   let m = try_find_library s in
   h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)"
-		 (size_kb m) (size_kb m.library_compiled) 
+		 (size_kb m) (size_kb m.library_compiled)
 		 (size_kb m.library_objects)))
diff --git a/library/library.mli b/library/library.mli
index d61dc4b9..c6bd8fe0 100644
--- a/library/library.mli
+++ b/library/library.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: library.mli 11750 2009-01-05 20:47:34Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -26,6 +26,7 @@ open Libobject
 (*s Require = load in the environment + open (if the optional boolean
     is not [None]); mark also for export if the boolean is [Some true] *)
 val require_library : qualid located list -> bool option -> unit
+val require_library_from_dirpath : (dir_path * string) list -> bool option -> unit
 val require_library_from_file :
   identifier option -> System.physical_path -> bool option -> unit
 
@@ -78,8 +79,5 @@ val locate_qualified_library :
   bool -> qualid -> library_location * dir_path * System.physical_path
 val try_locate_qualified_library : qualid located -> dir_path * string
 
-(* Reserve Coq prefix for the standard library *)
-val check_coq_overwriting : dir_path -> unit
-
 (*s Statistics: display the memory use of a library. *)
 val mem : dir_path -> Pp.std_ppcmds
diff --git a/library/library.mllib b/library/library.mllib
new file mode 100644
index 00000000..4efb69a2
--- /dev/null
+++ b/library/library.mllib
@@ -0,0 +1,16 @@
+Nameops
+Libnames
+Libobject
+Summary
+Nametab
+Global
+Lib
+Declaremods
+Library
+States
+Decl_kinds
+Dischargedhypsmap
+Goptions
+Decls
+Heads
+
diff --git a/library/nameops.ml b/library/nameops.ml
index df9aa95d..28b799f5 100644
--- a/library/nameops.ml
+++ b/library/nameops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nameops.ml 9433 2006-12-12 09:38:53Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -30,14 +30,14 @@ let cut_ident skip_quote s =
   let slen = String.length s in
   (* [n'] is the position of the first non nullary digit *)
   let rec numpart n n' =
-    if n = 0 then 
+    if n = 0 then
       (* ident made of _ and digits only [and ' if skip_quote]: don't cut it *)
       slen
-    else 
+    else
       let c = Char.code (String.get s (n-1)) in
-      if c = code_of_0 && n <> slen then 
-	numpart (n-1) n' 
-      else if code_of_0 <= c && c <= code_of_9 then 
+      if c = code_of_0 && n <> slen then
+	numpart (n-1) n'
+      else if code_of_0 <= c && c <= code_of_9 then
 	numpart (n-1) (n-1)
       else if skip_quote & (c = Char.code '\'' || c = Char.code '_') then
 	numpart (n-1) (n-1)
@@ -50,14 +50,14 @@ let repr_ident s =
   let numstart = cut_ident false s in
   let s = string_of_id s in
   let slen = String.length s in
-  if numstart = slen then 
+  if numstart = slen then
     (s, None)
   else
     (String.sub s 0 numstart,
      Some (int_of_string (String.sub s numstart (slen - numstart))))
 
 let make_ident sa = function
-  | Some n -> 
+  | Some n ->
       let c = Char.code (String.get sa (String.length sa -1)) in
       let s =
         if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n)
@@ -112,26 +112,8 @@ let add_prefix s id = id_of_string (s ^ string_of_id id)
 
 let atompart_of_id id = fst (repr_ident id)
 
-(* Fresh names *)
-
 let lift_ident = lift_subscript
 
-let next_ident_away id avoid = 
-  if List.mem id avoid then
-    let id0 = if not (has_subscript id) then id else 
-    (* Ce serait sans doute mieux avec quelque chose inspiré de 
-       *** make_ident id (Some 0) *** mais ça brise la compatibilité... *)
-    forget_subscript id in
-    let rec name_rec id =
-      if List.mem id avoid then name_rec (lift_ident id) else id in 
-    name_rec id0
-  else id
-
-let next_ident_away_from id avoid = 
-  let rec name_rec id =
-    if List.mem id avoid then name_rec (lift_ident id) else id in 
-  name_rec id 
-
 (* Names *)
 
 let out_name = function
@@ -143,9 +125,11 @@ let name_fold f na a =
   | Name id -> f id a
   | Anonymous -> a
 
+let name_iter f na = name_fold (fun x () -> f x) na ()
+
 let name_cons na l =
   match na with
-  | Anonymous -> l 
+  | Anonymous -> l
   | Name id -> id::l
 
 let name_app f = function
@@ -156,13 +140,6 @@ let name_fold_map f e = function
   | Name id -> let (e,id) = f e id in (e,Name id)
   | Anonymous -> e,Anonymous
 
-let next_name_away_with_default default name l = 
-  match name with
-    | Name str  -> next_ident_away str l
-    | Anonymous -> next_ident_away (id_of_string default) l
-
-let next_name_away = next_name_away_with_default "H"
-
 let pr_lab l = str (string_of_label l)
 
 let default_library = Names.initial_dir (* = ["Top"] *)
diff --git a/library/nameops.mli b/library/nameops.mli
index b6a39c20..f69bf3ff 100644
--- a/library/nameops.mli
+++ b/library/nameops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nameops.mli 9433 2006-12-12 09:38:53Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Names
 
@@ -23,17 +23,14 @@ val root_of_id : identifier -> identifier (* remove trailing digits, $'$ and $\_
 val add_suffix : identifier -> string -> identifier
 val add_prefix : string -> identifier -> identifier
 
-val lift_ident           : identifier -> identifier
-val next_ident_away      : identifier -> identifier list -> identifier
-val next_ident_away_from : identifier -> identifier list -> identifier
-
-val next_name_away : name -> identifier list -> identifier
-val next_name_away_with_default :
-  string -> name -> identifier list -> identifier
+val has_subscript    : identifier -> bool
+val lift_subscript   : identifier -> identifier
+val forget_subscript : identifier -> identifier
 
 val out_name : name -> identifier
 
 val name_fold : (identifier -> 'a -> 'a) -> name -> 'a -> 'a
+val name_iter : (identifier -> unit) -> name -> unit
 val name_cons : name -> identifier list -> identifier list
 val name_app : (identifier -> identifier) -> name -> name
 val name_fold_map : ('a -> identifier -> 'a * identifier) -> 'a -> name -> 'a * name
diff --git a/library/nametab.ml b/library/nametab.ml
index 2c794fae..5eafa486 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nametab.ml 10664 2008-03-14 11:27:37Z soubiran $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -27,14 +27,16 @@ let error_global_constant_not_found_loc loc q =
 
 let error_global_not_found q = raise (GlobalizationError q)
 
+(* Kinds of global names *)
 
+type ltac_constant = kernel_name
 
-(* The visibility can be registered either 
+(* The visibility can be registered either
    - for all suffixes not shorter then a given int - when the object
      is loaded inside a module
    or
    - for a precise suffix, when the module containing (the module
-     containing ...) the object is open (imported) 
+     containing ...) the object is open (imported)
 *)
 type visibility = Until of int | Exactly of int
 
@@ -42,9 +44,9 @@ type visibility = Until of int | Exactly of int
 (* Data structure for nametabs *******************************************)
 
 
-(* This module type will be instantiated by [section_path] of [dir_path] *)
+(* This module type will be instantiated by [full_path] of [dir_path] *)
 (* The [repr] function is assumed to return the reversed list of idents. *)
-module type UserName = sig 
+module type UserName = sig
   type t
   val to_string : t -> string
   val repr : t -> identifier * module_ident list
@@ -55,15 +57,15 @@ end
    partially qualified names of type [qualid]. The mapping of
    partially qualified names to ['a] is determined by the [visibility]
    parameter of [push].
-   
+
    The [shortest_qualid] function given a user_name Coq.A.B.x, tries
    to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes
-   the same object. 
+   the same object.
 *)
 module type NAMETREE = sig
   type 'a t
   type user_name
-  
+
   val empty : 'a t
   val push : visibility -> user_name -> 'a -> 'a t -> 'a t
   val locate : qualid -> 'a t -> 'a
@@ -74,15 +76,15 @@ module type NAMETREE = sig
   val find_prefixes : qualid -> 'a t -> 'a list
 end
 
-module Make(U:UserName) : NAMETREE with type user_name = U.t 
-				     = 
+module Make(U:UserName) : NAMETREE with type user_name = U.t
+				     =
 struct
 
   type user_name = U.t
 
-  type 'a path_status = 
-      Nothing 
-    | Relative of user_name * 'a 
+  type 'a path_status =
+      Nothing
+    | Relative of user_name * 'a
     | Absolute of user_name * 'a
 
   (* Dictionaries of short names *)
@@ -91,38 +93,38 @@ struct
   type 'a t = 'a nametree Idmap.t
 
   let empty = Idmap.empty
-		
-  (* [push_until] is used to register [Until vis] visibility and 
+
+  (* [push_until] is used to register [Until vis] visibility and
      [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*)
 
   let rec push_until uname o level (current,dirmap) = function
     | modid :: path ->
-	let mc = 
+	let mc =
 	  try ModIdmap.find modid dirmap
 	  with Not_found -> (Nothing, ModIdmap.empty)
 	in
 	let this =
           if level <= 0 then
 	    match current with
-	      | Absolute (n,_) -> 
-		  (* This is an absolute name, we must keep it 
+	      | Absolute (n,_) ->
+		  (* This is an absolute name, we must keep it
 		     otherwise it may become unaccessible forever *)
 		  Flags.if_verbose
-		    warning ("Trying to mask the absolute name \"" 
-			     ^ U.to_string n ^ "\"!"); 
+		    warning ("Trying to mask the absolute name \""
+			     ^ U.to_string n ^ "\"!");
 		  current
 	      | Nothing
 	      | Relative _ -> Relative (uname,o)
-          else current 
+          else current
 	in
 	let ptab' = push_until uname o (level-1) mc path in
 	  (this, ModIdmap.add modid ptab' dirmap)
-    | [] -> 
+    | [] ->
 	match current with
-	  | Absolute (uname',o') -> 
+	  | Absolute (uname',o') ->
 	      if o'=o then begin
 		assert (uname=uname');
-		current, dirmap 
+		current, dirmap
 		  (* we are putting the same thing for the second time :) *)
 	      end
 	      else
@@ -137,15 +139,15 @@ struct
 
 let rec push_exactly uname o level (current,dirmap) = function
   | modid :: path ->
-      let mc = 
+      let mc =
 	try ModIdmap.find modid dirmap
 	with Not_found -> (Nothing, ModIdmap.empty)
       in
         if level = 0 then
 	  let this =
 	    match current with
-	      | Absolute (n,_) -> 
-		  (* This is an absolute name, we must keep it 
+	      | Absolute (n,_) ->
+		  (* This is an absolute name, we must keep it
 		     otherwise it may become unaccessible forever *)
 		  Flags.if_verbose
 		    warning ("Trying to mask the absolute name \""
@@ -158,7 +160,7 @@ let rec push_exactly uname o level (current,dirmap) = function
 	else (* not right level *)
 	  let ptab' = push_exactly uname o (level-1) mc path in
 	    (current, ModIdmap.add modid ptab' dirmap)
-  | [] -> 
+  | [] ->
       anomaly "Prefix longer than path! Impossible!"
 
 
@@ -166,7 +168,7 @@ let push visibility uname o tab =
   let id,dir = U.repr uname in
   let ptab =
     try Idmap.find id tab
-    with Not_found -> (Nothing, ModIdmap.empty) 
+    with Not_found -> (Nothing, ModIdmap.empty)
   in
   let ptab' = match visibility with
     | Until i -> push_until uname o (i-1) ptab dir
@@ -178,46 +180,46 @@ let push visibility uname o tab =
 let rec search (current,modidtab) = function
   | modid :: path -> search (ModIdmap.find modid modidtab) path
   | [] -> current
-      
+
 let find_node qid tab =
   let (dir,id) = repr_qualid qid in
     search (Idmap.find id tab) (repr_dirpath dir)
 
-let locate qid tab = 
+let locate qid tab =
   let o = match find_node qid tab with
     | Absolute (uname,o) | Relative (uname,o) -> o
-    | Nothing -> raise Not_found                                            
+    | Nothing -> raise Not_found
   in
     o
 
 let user_name qid tab =
   let uname = match find_node qid tab with
     | Absolute (uname,o) | Relative (uname,o) -> uname
-    | Nothing -> raise Not_found                                            
+    | Nothing -> raise Not_found
   in
     uname
-  
-let find uname tab = 
+
+let find uname tab =
   let id,l = U.repr uname in
     match search (Idmap.find id tab) l with
 	Absolute (_,o) -> o
       | _ -> raise Not_found
 
 let exists uname tab =
-  try 
+  try
     let _ = find uname tab in
       true
   with
       Not_found -> false
 
-let shortest_qualid ctx uname tab = 
+let shortest_qualid ctx uname tab =
   let id,dir = U.repr uname in
   let hidden = Idset.mem id ctx in
   let rec find_uname pos dir (path,tab) = match path with
     | Absolute (u,_) | Relative (u,_)
           when u=uname && not(pos=[] && hidden) -> List.rev pos
-    | _ -> 
-	match dir with 
+    | _ ->
+	match dir with
 	    [] -> raise Not_found
 	  | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tab)
   in
@@ -237,7 +239,7 @@ let rec flatten_idmap tab l =
 let rec search_prefixes (current,modidtab) = function
   | modid :: path -> search_prefixes (ModIdmap.find modid modidtab) path
   | [] -> List.rev (flatten_idmap  modidtab (push_node current []))
-      
+
 let find_prefixes qid tab =
   try
     let (dir,id) = repr_qualid qid in
@@ -250,10 +252,10 @@ end
 
 (* Global name tables *************************************************)
 
-module SpTab = Make (struct 
-		       type t = section_path
+module SpTab = Make (struct
+		       type t = full_path
 		       let to_string = string_of_path
-		       let repr sp = 
+		       let repr sp =
 			 let dir,id = repr_path sp in
 			   id, (repr_dirpath dir)
 		     end)
@@ -268,11 +270,8 @@ let the_tactictab = ref (SpTab.empty : kntab)
 type mptab = module_path SpTab.t
 let the_modtypetab = ref (SpTab.empty : mptab)
 
-type objtab = unit SpTab.t
-let the_objtab = ref (SpTab.empty : objtab)
-
 
-module DirTab = Make(struct 
+module DirTab = Make(struct
 		       type t = dir_path
 		       let to_string = string_of_dirpath
 		       let repr dir = match repr_dirpath dir with
@@ -289,22 +288,22 @@ let the_dirtab = ref (DirTab.empty : dirtab)
 (* Reversed name tables ***************************************************)
 
 (* This table translates extended_global_references back to section paths *)
-module Globrevtab = Map.Make(struct 
-			       type t=extended_global_reference 
-			       let compare = compare 
+module Globrevtab = Map.Make(struct
+			       type t=extended_global_reference
+			       let compare = compare
 			     end)
 
-type globrevtab = section_path Globrevtab.t
+type globrevtab = full_path Globrevtab.t
 let the_globrevtab = ref (Globrevtab.empty : globrevtab)
 
 
 type mprevtab = dir_path MPmap.t
 let the_modrevtab = ref (MPmap.empty : mprevtab)
 
-type mptrevtab = section_path MPmap.t
+type mptrevtab = full_path MPmap.t
 let the_modtyperevtab = ref (MPmap.empty : mptrevtab)
 
-type knrevtab = section_path KNmap.t
+type knrevtab = full_path KNmap.t
 let the_tacticrevtab = ref (KNmap.empty : knrevtab)
 
 
@@ -315,43 +314,45 @@ let the_tacticrevtab = ref (KNmap.empty : knrevtab)
    Parameter but also Remark and Fact) *)
 
 let push_xref visibility sp xref =
-  the_ccitab := SpTab.push visibility sp xref !the_ccitab;
   match visibility with
-    | Until _ -> 
-	if Globrevtab.mem xref !the_globrevtab then
-	  ()
-	else
-	  the_globrevtab := Globrevtab.add xref sp !the_globrevtab
-    | _ -> ()
+    | Until _ ->
+	the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+	the_globrevtab := Globrevtab.add xref sp !the_globrevtab
+    | _ ->
+	begin
+	  if SpTab.exists sp !the_ccitab then
+	    match SpTab.find sp !the_ccitab with
+	      | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) |
+		    TrueGlobal( ConstructRef _) as xref ->
+		  the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+	      | _ -> 
+		  the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+	    else
+	      the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+	end
 
 let push_cci visibility sp ref =
   push_xref visibility sp (TrueGlobal ref)
-
+    
 (* This is for Syntactic Definitions *)
-let push_syntactic_definition visibility sp kn =
-  push_xref visibility sp (SyntacticDef kn)
+let push_syndef visibility sp kn =
+  push_xref visibility sp (SynDef kn)
 
 let push = push_cci
 
-let push_modtype vis sp kn = 
+let push_modtype vis sp kn =
   the_modtypetab := SpTab.push vis sp kn !the_modtypetab;
   the_modtyperevtab := MPmap.add kn sp !the_modtyperevtab
 
 (* This is for tactic definition names *)
 
-let push_tactic vis sp kn = 
+let push_tactic vis sp kn =
   the_tactictab := SpTab.push vis sp kn !the_tactictab;
   the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab
 
 
-(* This is for dischargeable non-cci objects (removed at the end of the
-   section -- i.e. Hints, Grammar ...) *) (* --> Unused *)
-
-let push_object visibility sp =
-  the_objtab := SpTab.push visibility sp () !the_objtab
-
 (* This is to remember absolute Section/Module names and to avoid redundancy *)
-let push_dir vis dir dir_ref = 
+let push_dir vis dir dir_ref =
   the_dirtab := DirTab.push vis dir dir_ref !the_dirtab;
   match dir_ref with
       DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab
@@ -362,77 +363,75 @@ let push_dir vis dir dir_ref =
 
 
 (* This should be used when syntactic definitions are allowed *)
-let extended_locate qid = SpTab.locate qid !the_ccitab
+let locate_extended qid = SpTab.locate qid !the_ccitab
 
 (* This should be used when no syntactic definitions is expected *)
-let locate qid = match extended_locate qid with
+let locate qid = match locate_extended qid with
   | TrueGlobal ref -> ref
-  | SyntacticDef _ -> raise Not_found
+  | SynDef _ -> raise Not_found
 let full_name_cci qid = SpTab.user_name qid !the_ccitab
 
-let locate_syntactic_definition qid = match extended_locate qid with
+let locate_syndef qid = match locate_extended qid with
   | TrueGlobal _ -> raise Not_found
-  | SyntacticDef kn -> kn
+  | SynDef kn -> kn
 
 let locate_modtype qid = SpTab.locate qid !the_modtypetab
 let full_name_modtype qid = SpTab.user_name qid !the_modtypetab
 
-let locate_obj qid = SpTab.user_name qid !the_objtab
-
-type ltac_constant = kernel_name
 let locate_tactic qid = SpTab.locate qid !the_tactictab
 let full_name_tactic qid = SpTab.user_name qid !the_tactictab
 
 let locate_dir qid = DirTab.locate qid !the_dirtab
 
-let locate_module qid = 
+let locate_module qid =
   match locate_dir qid with
     | DirModule (_,(mp,_)) -> mp
     | _ -> raise Not_found
 
-let full_name_module qid = 
+let full_name_module qid =
   match locate_dir qid with
     | DirModule (dir,_) -> dir
     | _ -> raise Not_found
 
 let locate_section qid =
   match locate_dir qid with
-    | DirOpenSection (dir, _) 
+    | DirOpenSection (dir, _)
     | DirClosedSection dir -> dir
     | _ -> raise Not_found
 
-let locate_all qid = 
+let locate_all qid =
   List.fold_right (fun a l -> match a with TrueGlobal a -> a::l | _ -> l)
     (SpTab.find_prefixes qid !the_ccitab) []
 
-let extended_locate_all qid = SpTab.find_prefixes qid !the_ccitab
+let locate_extended_all qid = SpTab.find_prefixes qid !the_ccitab
 
 (* Derived functions *)
 
 let locate_constant qid =
-  match extended_locate qid with
+  match locate_extended qid with
     | TrueGlobal (ConstRef kn) -> kn
     | _ -> raise Not_found
 
-let locate_mind qid = 
-  match extended_locate qid with
+let locate_mind qid =
+  match locate_extended qid with
     | TrueGlobal (IndRef (kn,0)) -> kn
     | _ -> raise Not_found
 
-
-let absolute_reference sp =
+let global_of_path sp =
   match SpTab.find sp !the_ccitab with
     | TrueGlobal ref -> ref
     | _ -> raise Not_found
 
+let extended_global_of_path sp = SpTab.find sp !the_ccitab
+
 let locate_in_absolute_module dir id =
-  absolute_reference (make_path dir id)
+  global_of_path (make_path dir id)
 
 let global r =
   let (loc,qid) = qualid_of_reference r in
-  try match extended_locate qid with
+  try match locate_extended qid with
     | TrueGlobal ref -> ref
-    | SyntacticDef _ -> 
+    | SynDef _ ->
         user_err_loc (loc,"global",
           str "Unexpected reference to a notation: " ++
           pr_qualid qid)
@@ -442,7 +441,7 @@ let global r =
 (* Exists functions ********************************************************)
 
 let exists_cci sp = SpTab.exists sp !the_ccitab
-      
+
 let exists_dir dir = DirTab.exists dir !the_dirtab
 
 let exists_section = exists_dir
@@ -455,37 +454,40 @@ let exists_tactic sp = SpTab.exists sp !the_tactictab
 
 (* Reverse locate functions ***********************************************)
 
-let sp_of_global ref = 
+let path_of_global ref =
   match ref with
     | VarRef id -> make_path empty_dirpath id
     | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab
 
+let dirpath_of_global ref =
+  fst (repr_path (path_of_global ref))
 
-let id_of_global ref = 
-  let (_,id) = repr_path (sp_of_global ref) in 
-  id
+let basename_of_global ref =
+  snd (repr_path (path_of_global ref))
 
-let sp_of_syntactic_definition kn = 
-  Globrevtab.find (SyntacticDef kn) !the_globrevtab
+let path_of_syndef kn =
+  Globrevtab.find (SynDef kn) !the_globrevtab
 
-let dir_of_mp mp =
+let dirpath_of_module mp =
   MPmap.find mp !the_modrevtab
 
+let path_of_tactic kn =
+  KNmap.find kn !the_tacticrevtab
 
 (* Shortest qualid functions **********************************************)
 
-let shortest_qualid_of_global ctx ref = 
+let shortest_qualid_of_global ctx ref =
   match ref with
     | VarRef id -> make_qualid empty_dirpath id
     | _ ->
         let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in
         SpTab.shortest_qualid ctx sp !the_ccitab
 
-let shortest_qualid_of_syndef ctx kn = 
-  let sp = sp_of_syntactic_definition kn in
+let shortest_qualid_of_syndef ctx kn =
+  let sp = path_of_syndef kn in
     SpTab.shortest_qualid ctx sp !the_ccitab
 
-let shortest_qualid_of_module mp = 
+let shortest_qualid_of_module mp =
   let dir = MPmap.find mp !the_modrevtab in
     DirTab.shortest_qualid Idset.empty dir !the_dirtab
 
@@ -504,7 +506,7 @@ let pr_global_env env ref =
   let s = string_of_qualid (shortest_qualid_of_global env ref) in
   (str s)
 
-let inductive_of_reference r =
+let global_inductive r =
   match global r with
   | IndRef ind -> ind
   | ref ->
@@ -517,13 +519,12 @@ let inductive_of_reference r =
 (********************************************************************)
 (* Registration of tables as a global table and rollback            *)
 
-type frozen = ccitab * dirtab * objtab * kntab * kntab
+type frozen = ccitab * dirtab * kntab * kntab
     * globrevtab * mprevtab * knrevtab * knrevtab
 
-let init () = 
-  the_ccitab := SpTab.empty; 
+let init () =
+  the_ccitab := SpTab.empty;
   the_dirtab := DirTab.empty;
-  the_objtab := SpTab.empty;
   the_modtypetab := SpTab.empty;
   the_tactictab := SpTab.empty;
   the_globrevtab := Globrevtab.empty;
@@ -534,9 +535,8 @@ let init () =
 
 
 let freeze () =
-  !the_ccitab, 
+  !the_ccitab,
   !the_dirtab,
-  !the_objtab,
   !the_modtypetab,
   !the_tactictab,
   !the_globrevtab,
@@ -544,10 +544,9 @@ let freeze () =
   !the_modtyperevtab,
   !the_tacticrevtab
 
-let unfreeze (ccit,dirt,objt,mtyt,tact,globr,modr,mtyr,tacr) =
+let unfreeze (ccit,dirt,mtyt,tact,globr,modr,mtyr,tacr) =
   the_ccitab := ccit;
   the_dirtab := dirt;
-  the_objtab := objt;
   the_modtypetab := mtyt;
   the_tactictab := tact;
   the_globrevtab := globr;
@@ -555,10 +554,13 @@ let unfreeze (ccit,dirt,objt,mtyt,tact,globr,modr,mtyr,tacr) =
   the_modtyperevtab := mtyr;
   the_tacticrevtab := tacr
 
-let _ = 
+let _ =
   Summary.declare_summary "names"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
+
+(* Deprecated synonyms *)
+
+let extended_locate = locate_extended
+let absolute_reference = global_of_path
diff --git a/library/nametab.mli b/library/nametab.mli
index 71ea0aa5..b168d59c 100755
--- a/library/nametab.mli
+++ b/library/nametab.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nametab.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -16,34 +16,52 @@ open Libnames
 (*i*)
 
 (*s This module contains the tables for globalization, which
-  associates internal object references to qualified names (qualid). *)
+    associates internal object references to qualified names (qualid).
+
+    There are three classes of names:
+
+    1a- internal kernel names: [kernel_name], [constant], [inductive],
+        [module_path], [dir_path]
+
+    1b- other internal names: [global_reference], [syndef_name],
+        [extended_global_reference], [global_dir_reference], ...
+
+    2- full, non ambiguous user names: [full_path]
+
+    3- non necessarily full, possibly ambiguous user names: [reference]
+       and [qualid]
+*)
 
 (* Most functions in this module fall into one of the following categories:
    \begin{itemize}
    \item [push : visibility -> full_user_name -> object_reference -> unit]
-   
+
    Registers the [object_reference] to be referred to by the
    [full_user_name] (and its suffixes according to [visibility]).
-   [full_user_name] can either be a [section_path] or a [dir_path].
+   [full_user_name] can either be a [full_path] or a [dir_path].
+
+   \item [exists : full_user_name -> bool]
 
-   \item [exists : full_user_name -> bool] 
-   
    Is the [full_user_name] already atributed as an absolute user name
-   of some object? 
+   of some object?
 
    \item [locate : qualid -> object_reference]
 
    Finds the object referred to by [qualid] or raises [Not_found]
-   
-   \item [name_of : object_reference -> user_name]
 
-   The [user_name] can be for example the shortest non ambiguous [qualid] or 
-   the [full_user_name] or [identifier]. Such a function can also have a 
-   local context argument. 
+   \item [full_name : qualid -> full_user_name]
+
+   Finds the full user name referred to by [qualid] or raises [Not_found]
+
+   \item [shortest_qualid_of : object_reference -> user_name]
+
+   The [user_name] can be for example the shortest non ambiguous [qualid] or
+   the [full_user_name] or [identifier]. Such a function can also have a
+   local context argument.
    \end{itemize}
 *)
-   
-  
+
+
 exception GlobalizationError of qualid
 exception GlobalizationConstantError of qualid
 
@@ -52,9 +70,6 @@ val error_global_not_found_loc : loc -> qualid -> 'a
 val error_global_not_found     : qualid -> 'a
 val error_global_constant_not_found_loc : loc -> qualid -> 'a
 
-
-
-
 (*s Register visibility of things *)
 
 (* The visibility can be registered either
@@ -64,93 +79,84 @@ val error_global_constant_not_found_loc : loc -> qualid -> 'a
    object is loaded inside a module -- or
 
    \item for a precise suffix, when the module containing (the module
-   containing ...) the object is opened (imported) 
+   containing ...) the object is opened (imported)
    \end{itemize}
 *)
 
 type visibility = Until of int | Exactly of int
 
-val push : visibility -> section_path -> global_reference -> unit
-val push_syntactic_definition : 
-  visibility -> section_path -> kernel_name -> unit
-val push_modtype : visibility -> section_path -> module_path -> unit
+val push : visibility -> full_path -> global_reference -> unit
+val push_modtype : visibility -> full_path -> module_path -> unit
 val push_dir : visibility -> dir_path -> global_dir_reference -> unit
-val push_object : visibility -> section_path -> unit
-val push_tactic : visibility -> section_path -> kernel_name -> unit
-
-
-(*s The following functions perform globalization of qualified names *)
+val push_syndef : visibility -> full_path -> syndef_name -> unit
 
-(* This returns the section path of a constant or fails with [Not_found] *)
-val locate : qualid -> global_reference
-
-(* This function is used to transform a qualified identifier into a
-   global reference, with a nice error message in case of failure *)
-val global : reference -> global_reference
-
-(* The same for inductive types *)
-val inductive_of_reference : reference -> inductive
-
-(* This locates also syntactic definitions; raise [Not_found] if not found *)
-val extended_locate : qualid -> extended_global_reference
+type ltac_constant = kernel_name
+val push_tactic : visibility -> full_path -> ltac_constant -> unit
 
-(* This locates all names with a given suffix, if qualid is valid as
-   such, it comes first in the list *)
-val extended_locate_all : qualid -> extended_global_reference list
 
-(* This locates all global references with a given suffixe *)
-val locate_all : qualid -> global_reference list
+(*s The following functions perform globalization of qualified names *)
 
-val locate_obj : qualid -> section_path
+(* These functions globalize a (partially) qualified name or fail with
+   [Not_found] *)
 
+val locate : qualid -> global_reference
+val locate_extended : qualid -> extended_global_reference
 val locate_constant : qualid -> constant
-val locate_mind : qualid -> mutual_inductive
-val locate_section : qualid -> dir_path
+val locate_syndef : qualid -> syndef_name
 val locate_modtype : qualid -> module_path
-val locate_syntactic_definition : qualid -> kernel_name
-
-type ltac_constant = kernel_name
-val locate_tactic : qualid -> ltac_constant
 val locate_dir : qualid -> global_dir_reference
 val locate_module : qualid -> module_path
+val locate_section : qualid -> dir_path
+val locate_tactic : qualid -> ltac_constant
 
-(* A variant looking up a [section_path] *)
-val absolute_reference : section_path -> global_reference
+(* These functions globalize user-level references into global
+   references, like [locate] and co, but raise a nice error message
+   in case of failure *)
 
+val global : reference -> global_reference
+val global_inductive : reference -> inductive
 
-(*s These function tell if the given absolute name is already taken *)
+(* These functions locate all global references with a given suffix;
+   if [qualid] is valid as such, it comes first in the list *)
 
-val exists_cci : section_path -> bool
-val exists_modtype : section_path -> bool
+val locate_all : qualid -> global_reference list
+val locate_extended_all : qualid -> extended_global_reference list
 
-(* Those three functions are the same *)
-val exists_dir : dir_path -> bool
-val exists_section : dir_path -> bool (* deprecated *)
-val exists_module : dir_path -> bool (* deprecated *)
+(* Mapping a full path to a global reference *)
 
+val global_of_path : full_path -> global_reference
+val extended_global_of_path : full_path -> extended_global_reference
 
-(*s These functions turn qualids into full user names: [section_path]s
-  or [dir_path]s *)
+(*s These functions tell if the given absolute name is already taken *)
 
-val full_name_modtype : qualid -> section_path
-val full_name_cci : qualid -> section_path
+val exists_cci : full_path -> bool
+val exists_modtype : full_path -> bool
+val exists_dir : dir_path -> bool
+val exists_section : dir_path -> bool (* deprecated synonym of [exists_dir] *)
+val exists_module : dir_path -> bool (* deprecated synonym of [exists_dir] *)
 
-(* As above but checks that the path found is indeed a module *)
-val full_name_module : qualid -> dir_path
+(*s These functions locate qualids into full user names *)
 
+val full_name_cci : qualid -> full_path
+val full_name_modtype : qualid -> full_path
+val full_name_module : qualid -> dir_path
 
 (*s Reverse lookup -- finding user names corresponding to the given
   internal name *)
 
-val sp_of_syntactic_definition : kernel_name -> section_path
-val shortest_qualid_of_global : Idset.t -> global_reference -> qualid
-val shortest_qualid_of_syndef : Idset.t -> kernel_name -> qualid
-val shortest_qualid_of_tactic : ltac_constant -> qualid
+(* Returns the full path bound to a global reference or syntactic
+   definition, and the (full) dirpath associated to a module path *)
+
+val path_of_syndef : syndef_name -> full_path
+val path_of_global : global_reference -> full_path
+val dirpath_of_module : module_path -> dir_path
+val path_of_tactic : ltac_constant -> full_path
 
-val dir_of_mp : module_path -> dir_path
+(* Returns in particular the dirpath or the basename of the full path
+   associated to global reference *)
 
-val sp_of_global : global_reference -> section_path
-val id_of_global : global_reference -> identifier
+val dirpath_of_global : global_reference -> dir_path
+val basename_of_global : global_reference -> identifier
 
 (* Printing of global references using names as short as possible *)
 val pr_global_env : Idset.t -> global_reference -> std_ppcmds
@@ -160,13 +166,13 @@ val pr_global_env : Idset.t -> global_reference -> std_ppcmds
    Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and
    Coq.A.B.x that denotes the same object. *)
 
-val shortest_qualid_of_module : module_path -> qualid
+val shortest_qualid_of_global : Idset.t -> global_reference -> qualid
+val shortest_qualid_of_syndef : Idset.t -> syndef_name -> qualid
 val shortest_qualid_of_modtype : module_path -> qualid
+val shortest_qualid_of_module : module_path -> qualid
+val shortest_qualid_of_tactic : ltac_constant -> qualid
 
+(* Deprecated synonyms *)
 
-(*
-type frozen
-
-val freeze : unit -> frozen
-val unfreeze : frozen -> unit
-*)
+val extended_locate : qualid -> extended_global_reference (*= locate_extended *)
+val absolute_reference : full_path -> global_reference (* = global_of_path *)
diff --git a/library/states.ml b/library/states.ml
index 3a4be1ca..b2ece049 100644
--- a/library/states.ml
+++ b/library/states.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: states.ml 13175 2010-06-22 06:28:37Z herbelin $ *)
+(* $Id$ *)
 
 open System
 
@@ -32,14 +32,14 @@ let (extern_state,intern_state) =
 
 let with_heavy_rollback f x =
   let st = freeze () in
-  try 
+  try
     f x
   with reraise ->
     (unfreeze st; raise reraise)
 
 let with_state_protection f x =
   let st = freeze () in
-  try 
+  try
     let a = f x in unfreeze st; a
   with reraise ->
     (unfreeze st; raise reraise)
diff --git a/library/states.mli b/library/states.mli
index 210e06b2..782e41ca 100644
--- a/library/states.mli
+++ b/library/states.mli
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: states.mli 12080 2009-04-11 16:56:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*s States of the system. In that module, we provide functions to get
   and set the state of the whole system. Internally, it is done by
-  freezing the states of both [Lib] and [Summary]. We provide functions 
+  freezing the states of both [Lib] and [Summary]. We provide functions
   to write and restore state to and from a given file. *)
 
 val intern_state : string -> unit
@@ -21,7 +21,7 @@ val freeze : unit -> state
 val unfreeze : state -> unit
 
 (*s Rollback. [with_heavy_rollback f x] applies [f] to [x] and restores the
-  state of the whole system as it was before the evaluation if an exception 
+  state of the whole system as it was before the evaluation if an exception
   is raised. *)
 
 val with_heavy_rollback : ('a -> 'b) -> 'a -> 'b
diff --git a/library/summary.ml b/library/summary.ml
index 455ee264..e9b0bbd3 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: summary.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -14,11 +14,9 @@ open Util
 type 'a summary_declaration = {
   freeze_function : unit -> 'a;
   unfreeze_function : 'a -> unit;
-  init_function : unit -> unit;
-  survive_module : bool ;
-  survive_section : bool }
+  init_function : unit -> unit }
 
-let summaries = 
+let summaries =
   (Hashtbl.create 17 : (string, Dyn.t summary_declaration) Hashtbl.t)
 
 let internal_declare_summary sumname sdecl =
@@ -29,45 +27,32 @@ let internal_declare_summary sumname sdecl =
   let ddecl = {
     freeze_function = dyn_freeze;
     unfreeze_function = dyn_unfreeze;
-    init_function = dyn_init;
-    survive_module = sdecl.survive_module;
-    survive_section = sdecl.survive_section } 
+    init_function = dyn_init }
   in
   if Hashtbl.mem summaries sumname then
     anomalylabstrm "Summary.declare_summary"
       (str "Cannot declare a summary twice: " ++ str sumname);
   Hashtbl.add summaries sumname ddecl
 
-let declare_summary sumname decl = 
+let declare_summary sumname decl =
   internal_declare_summary (sumname^"-SUMMARY") decl
 
 type frozen = Dyn.t Stringmap.t
 
 let freeze_summaries () =
   let m = ref Stringmap.empty in
-  Hashtbl.iter 
+  Hashtbl.iter
     (fun id decl -> m := Stringmap.add id (decl.freeze_function()) !m)
     summaries;
   !m
 
 
-let unfreeze_some_summaries p fs = 
+let unfreeze_summaries fs =
   Hashtbl.iter
-    (fun id decl -> 
-       try 
-	 if p decl then
-	   decl.unfreeze_function (Stringmap.find id fs)
+    (fun id decl ->
+       try decl.unfreeze_function (Stringmap.find id fs)
        with Not_found -> decl.init_function())
     summaries
 
-let unfreeze_summaries = 
-  unfreeze_some_summaries (fun _ -> true)
-
-let section_unfreeze_summaries =
-  unfreeze_some_summaries (fun decl -> not decl.survive_section)
-
-let module_unfreeze_summaries =
-  unfreeze_some_summaries (fun decl -> not decl.survive_module)
-
 let init_summaries () =
   Hashtbl.iter (fun _ decl -> decl.init_function()) summaries
diff --git a/library/summary.mli b/library/summary.mli
index ba527bdf..e6e17ef8 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: summary.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* This module registers the declaration of global tables, which will be kept
    in synchronization during the various backtracks of the system. *)
@@ -14,9 +14,7 @@
 type 'a summary_declaration = {
   freeze_function : unit -> 'a;
   unfreeze_function : 'a -> unit;
-  init_function : unit -> unit;
-  survive_module : bool;    (* should be false is most cases *)
-  survive_section : bool }
+  init_function : unit -> unit }
 
 val declare_summary : string -> 'a summary_declaration -> unit
 
@@ -24,9 +22,11 @@ type frozen
 
 val freeze_summaries : unit -> frozen
 val unfreeze_summaries : frozen -> unit
-val section_unfreeze_summaries : frozen -> unit
-val module_unfreeze_summaries : frozen -> unit
 val init_summaries : unit -> unit
 
-
+(** Beware: if some code is dynamically loaded via dynlink after the
+    initialization of Coq, the init functions of any summary declared
+    by this code may not be run. It is hence the responsability of
+    plugins to initialize themselves properly.
+*)
 
diff --git a/man/coqchk.1 b/man/coqchk.1
index b0a9c6ab..f51861f0 100644
--- a/man/coqchk.1
+++ b/man/coqchk.1
@@ -52,7 +52,7 @@ makes coqchk less verbose.
 .TP
 .BI \-admit \ file-or-module
 tag the specified module and all its dependencies as trusted, and will
-not be rechecked, unless explicitely requested by other options.
+not be rechecked, unless explicitly requested by other options.
 
 .TP
 .BI \-norec \ file-or-module
@@ -73,6 +73,18 @@ verified: assumptions and usage of impredicativity
 allows the checker to verify libraries that have been compiled with
 this flag.
 
+.TP
+.BI \-v
+print Coq version and exit
+
+.TP
+.BI \-where
+print Coq's standard library location and exit
+
+.TP
+.BI \-h,\ \-\-help
+print list of options
+
 .SH SEE ALSO
 
 .BR coqtop (1),
diff --git a/man/coqdep.1 b/man/coqdep.1
index e2cbb40e..e9e0dd3e 100644
--- a/man/coqdep.1
+++ b/man/coqdep.1
@@ -39,7 +39,7 @@ When a directory is given as argument, it is recursively looked at.
 
 Dependencies of Coq modules are computed by looking at
 .IR Require \&
-commands (Require, Require Export, Require Import, Require Implementation),
+commands (Require, Require Export, Require Import),
 .IR Declare \& 
 .IR ML \& 
 .IR Module \&
@@ -69,9 +69,6 @@ is incorrect. (For instance, you wrote `Declare ML Module "A".',
 but the module A contains #open "B"). The correct command is printed
 (see option \-D). The warning is printed on standard error.
 .TP
-.BI \-i
-Prints also the dependencies for .vi files (Coq specification modules).
-.TP
 .BI \-D
 This commands looks for every command
 .IR Declare \& 
diff --git a/man/coqdoc.1 b/man/coqdoc.1
index e07ccdd3..8d71a874 100644
--- a/man/coqdoc.1
+++ b/man/coqdoc.1
@@ -121,6 +121,10 @@ globalizations are obtained with Coq option \-dump\-glob).
 Do not insert links to the Coq standard library.
 
 .TP
+.BI \-\-external \ url \  libroot
+Set base URL for the external library whose root prefix is libroot.
+
+.TP
 .BI \-\-coqlib \ url
 Set base URL for the Coq standard library (default is http://coq.inria.fr/library/).
 
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
new file mode 100644
index 00000000..f062b50b
--- /dev/null
+++ b/myocamlbuild.ml
@@ -0,0 +1,473 @@
+(** * 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 = "win32")
+
+let w32pref = "i586-mingw32msvc"
+let w32ocamlc = w32pref^"-ocamlc"
+let w32ocamlopt = w32pref^"-ocamlopt"
+let w32ocamlmklib = w32pref^"-ocamlmklib"
+let w32lib = "/usr/"^w32pref^"/lib/"
+let w32bin = "/usr/"^w32pref^"/bin/"
+
+let _ = if w32 then begin
+  Options.ocamlopt := A w32ocamlopt;
+  Options.ocamlmklib := A w32ocamlmklib;
+end
+
+let ocaml = A Coq_config.ocaml
+let camlp4o = A Coq_config.camlp4o
+let camlp4incl = S[A"-I"; A Coq_config.camlp4lib]
+let camlp4compat = Sh Coq_config.camlp4compat
+let opt = (Coq_config.best = "opt")
+let ide = Coq_config.has_coqide
+let hasdynlink = Coq_config.has_natdynlink
+let os5fix = (Coq_config.natdynlinkflag = "os5fixme")
+let flag_dynlink = if hasdynlink then A"-DHasDynlink" else N
+let dep_dynlink = if hasdynlink then N else Sh"-natdynlink no"
+let lablgtkincl = Sh Coq_config.coqideincl
+let local = Coq_config.local
+let coqsrc = Coq_config.coqsrc
+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/lib"; "kernel/kernel"; "library/library";
+   "pretyping/pretyping"; "interp/interp";  "proofs/proofs";
+   "parsing/parsing"; "tactics/tactics"; "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 ide_cma = "ide/ide.cma"
+let ide_cmxa = "ide/ide.cmxa"
+let ide_mllib = "ide/ide.mllib"
+
+let tolink = "scripts/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 grammar = "parsing/grammar.cma"
+let qconstr = "parsing/q_constr.cmo"
+let refutpat = "lib/refutpat.cmo"
+
+let initialcoq = "states/initial.coq"
+let init_vo = ["theories/Init/Prelude.vo";"theories/Init/Logic_Type.vo"]
+let makeinitial = "states/MakeInitial.v"
+
+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 = "scripts/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 =
+ [ "coqtop", coqtop, Both;
+   "coqide", coqide, Ide;
+   "coqmktop", coqmktop, Both;
+   "coqc", "scripts/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;
+ ]
+
+
+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
+let coqdepbest = coqdepboot^(if w32 then ".byte" else best_oext)
+let coqmktopbest = coqmktop^(if w32 then ".byte" else best_oext)
+
+let binaries_deps =
+  let rec deps = function
+    | [] -> []
+    | (_,bin,Ide)::l ->
+	(if ide = "opt" then [bin^".native"] else []) @
+	(if ide <> "no" then [bin^".byte"] else []) @ deps l
+    | (_,bin,Both)::l when opt ->
+	(bin^".native") :: (bin^".byte") :: deps l
+    | (_,bin,_)::l -> (bin^best_oext) :: deps l
+  in deps all_binaries
+
+let binariesopt_deps =
+  List.filter (fun s -> Filename.check_suffix s ".native") binaries_deps
+
+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 "binaries" ~stamp:"binaries" ~deps:binaries_deps (fun _ _ -> Nop);
+  rule "binariesopt" ~stamp:"binariesopt" ~deps:binariesopt_deps (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 srcbuild = Filename.concat coqsrc !_build in
+       let line0 = "\n(* Adapted variables for ocamlbuild *)\n" in
+       let line1 = "let coqsrc = \""^srcbuild^"\"\n" in
+       let line2 = "let coqlib = \""^srcbuild^"\"\n" in
+       (* TODO : line3 isn't completely accurate with respect to ./configure:
+	  the case of -local -coqrunbyteflags foo isn't supported *)
+       let line3 =
+	 "let coqrunbyteflags = \"-dllib -lcoqrun -dllpath '"
+	 ^srcbuild^"/kernel/byterun'\"\n"
+       in
+       Echo (lines @ [line0;line1] @ (if local then [line2;line3] 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 ["is_ml4"; "p4mod"; "use_macro"] (A"pa_macro.cmo");
+  flag ["is_ml4"; "p4mod"; "use_extend"] (A"pa_extend.cmo");
+  flag ["is_ml4"; "p4mod"; "use_MLast"] (A"q_MLast.cmo");
+
+  flag_and_dep ["is_ml4"; "p4mod"; "use_grammar"] (P grammar);
+  flag_and_dep ["is_ml4"; "p4mod"; "use_constr"] (P qconstr);
+  flag_and_dep ["is_ml4"; "p4mod"; "use_refutpat"] (P refutpat);
+
+(** Special case of toplevel/mltop.ml4:
+    - mltop.ml will be the old mltop.optml and be used to obtain mltop.cmx
+    - we add a special mltop.ml4 --> mltop.cmo rule, before all the others
+*)
+  flag ["is_mltop"; "p4option"] flag_dynlink;
+
+(*TODO: this is rather ugly for a simple file, we should try to
+        benefit more from predefined rules *)
+  let mltop = "toplevel/mltop" in
+  let ml4 = mltop^".ml4" and mlo = mltop^".cmo" and
+      ml = mltop^".ml" and mld = mltop^".ml.depends"
+  in
+  rule "mltop_byte" ~deps:[ml4;mld]  ~prod:mlo ~insert:`top
+    (fun env build ->
+       Ocaml_compiler.prepare_compile build ml;
+       Cmd (S [!Options.ocamlc; A"-c"; A"-pp";
+	       Quote (S [camlp4o; T(tags_of_pathname ml4 ++ "p4mod");
+			 A"-DByte";A"-DHasDynlink";camlp4compat;A"-impl"]);
+	       A"-rectypes"; camlp4incl; incl ml4; A"-impl"; P ml4]));
+
+(** All caml files are compiled with -rectypes and +camlp4/5
+    and ide files need +lablgtk2 *)
+
+  flag ["compile"; "ocaml"] (S [A"-rectypes"; camlp4incl]);
+  flag ["link"; "ocaml"] (S [A"-rectypes"; camlp4incl]);
+  flag ["compile"; "ocaml"; "ide"] lablgtkincl;
+  flag ["link"; "ocaml"; "ide"] lablgtkincl;
+
+(** Extra libraries *)
+
+  ocaml_lib ~extern:true "gramlib";
+
+(** C code for the VM *)
+
+  dep ["compile"; "c"] c_headers;
+  flag ["compile"; "c"] cflags;
+  dep ["link"; "ocaml"; "use_libcoqrun"] [libcoqrun];
+
+  (* 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:(ide_mllib::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 ide_mods = cat ide_mllib in
+       let core_cmas = String.concat " " core_cma in
+       Echo (["let copts = \"-cclib -lcoqrun\"\n";
+	      "let core_libs = \"coq_config.cmo "^core_cmas^"\"\n";
+	      "let core_objs = \"Coq_config "^core_mods^"\"\n";
+	      "let ide = \""^ide_mods^"\"\n"],
+	     tolink));
+
+(** Coqtop and coqide *)
+
+  let mktop_rule f is_ide =
+    let fo = f^".native" and fb = f^".byte" in
+    let ideflag = if is_ide then A"-ide" else N in
+    let depsall = [coqmktopbest;libcoqrun] in
+    let depso = "coq_config.cmx" :: core_cmxa in
+    let depsb = "coq_config.cmo" :: core_cma in
+    let depideo = if is_ide then [ide_cmxa] else [] in
+    let depideb = if is_ide then [ide_cma] else [] in
+    let w32ideflag = (*if is_ide then [A"-ccopt";A"\"-link -mwindows\""] else*) [] in
+    let w32flag = if not w32 then N else S ([A"-camlbin";A w32bin]@w32ideflag) in
+    if opt then rule fo ~prod:fo ~deps:(depsall@depso@depideo) ~insert:`top
+      (cmd [P coqmktopbest;w32flag;A"-boot";A"-opt";ideflag;incl fo;A"-o";Px fo]);
+    rule fb ~prod:fb ~deps:(depsall@depsb@depideb) ~insert:`top
+      (cmd [P coqmktopbest;w32flag;A"-boot";A"-top";ideflag;incl fb;A"-o";Px fb]);
+  in
+  mktop_rule coqtop false;
+  mktop_rule coqide true;
+
+(** Coq files dependencies *)
+
+  rule "coqdepready" ~stamp:"coqdepready" ~deps:coqdepdeps (fun _ _ -> Nop);
+
+  rule ".v.d" ~prod:"%.v.depends" ~deps:["%.v";coqdepbest;"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 coqdepbest;dep_dynlink;A"-slash";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 : *)
+    match string_list_of_file (f^".v.depends") with
+      | vo::vg::v::deps when vo=f^".vo" && vg=f^".glob:" && v=f^".v" ->
+	  let d = List.map (fun x -> [x]) deps in
+	  List.iter Outcome.ignore_good (build d)
+      | _ -> failwith ("Something wrong with dependencies of "^f^".v")
+  in
+
+  let coq_v_rule d init =
+    let bootflag = if init then A"-nois" else N in
+    let gendep = if init then coqtopbest else initialcoq in
+    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;
+
+(** Initial state *)
+
+  rule "initial.coq" ~prod:initialcoq ~deps:(makeinitial::init_vo)
+    (cmd [P coqtopbest;A"-boot";A"-batch";A"-nois";A"-notop";A"-silent";
+	  A"-l";P makeinitial; A"-outputstate";Px initialcoq]);
+
+(** Generation of _plugin_mod.ml files *)
+
+  rule "_mod.ml" ~prod:"%_plugin_mod.ml" ~dep:"%_plugin.mllib"
+    (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/argextend.ml4 b/parsing/argextend.ml4
index bd6be424..89edbb12 100644
--- a/parsing/argextend.ml4
+++ b/parsing/argextend.ml4
@@ -8,11 +8,12 @@
 
 (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
 
-(* $Id: argextend.ml4 11622 2008-11-23 08:45:56Z herbelin $ *)
+(* $Id$ *)
 
 open Genarg
 open Q_util
 open Q_coqast
+open Egrammar
 
 let join_loc = Util.join_loc
 let loc = Util.dummy_loc
@@ -39,7 +40,7 @@ let rec make_rawwit loc = function
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >>
   | List1ArgType t -> <:expr< Genarg.wit_list1 $make_rawwit loc t$ >>
   | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >>
-  | PairArgType (t1,t2) -> 
+  | PairArgType (t1,t2) ->
       <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >>
   | ExtraArgType s -> <:expr< $lid:"rawwit_"^s$ >>
 
@@ -64,7 +65,7 @@ let rec make_globwit loc = function
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >>
   | List1ArgType t -> <:expr< Genarg.wit_list1 $make_globwit loc t$ >>
   | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >>
-  | PairArgType (t1,t2) -> 
+  | PairArgType (t1,t2) ->
       <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >>
   | ExtraArgType s -> <:expr< $lid:"globwit_"^s$ >>
 
@@ -89,25 +90,31 @@ let rec make_wit loc = function
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >>
   | List1ArgType t -> <:expr< Genarg.wit_list1 $make_wit loc t$ >>
   | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >>
-  | PairArgType (t1,t2) -> 
+  | PairArgType (t1,t2) ->
       <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >>
   | ExtraArgType s -> <:expr< $lid:"wit_"^s$ >>
 
 let make_act loc act pil =
   let rec make = function
     | [] -> <:expr< Gramext.action (fun loc -> ($act$ : 'a)) >>
-    | None :: tl -> <:expr< Gramext.action (fun _ -> $make tl$) >>
-    | Some (p, t) :: tl ->
+    | GramNonTerminal (_,t,_,Some p) :: tl ->
+	let p = Names.string_of_id p in
 	<:expr<
-          Gramext.action 
+          Gramext.action
             (fun $lid:p$ ->
                let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
-        >> in
+        >>
+    | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl ->
+	<:expr< Gramext.action (fun _ -> $make tl$) >> in
   make (List.rev pil)
 
+let make_prod_item = function
+  | GramTerminal s -> <:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>
+  | GramNonTerminal (_,_,g,_) ->
+      <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >>
+
 let make_rule loc (prods,act) =
-  let (symbs,pil) = List.split prods in
-  <:expr< ($mlexpr_of_list (fun x -> x) symbs$,$make_act loc act pil$) >>
+  <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >>
 
 let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
   let rawtyp, rawpr = match rawtyppr with
@@ -124,14 +131,14 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
                (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >>
     | Some f -> <:expr< $lid:f$>> in
   let interp = match f with
-    | None -> 
+    | None ->
 	<:expr< fun ist gl x ->
           out_gen $make_wit loc typ$
             (Tacinterp.interp_genarg ist gl
                (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
     | Some f -> <:expr< $lid:f$>> in
   let substitute = match h with
-    | None -> 
+    | None ->
 	<:expr< fun s x ->
           out_gen $make_globwit loc globtyp$
 	    (Tacinterp.subst_genarg s
@@ -144,6 +151,8 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
   let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
   <:str_item<
     declare
+      open Pcoq;
+      open Extrawit;
       value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
         Genarg.create_arg $se$;
       value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
@@ -154,7 +163,7 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
           (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))),
         (fun subst x ->
           (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x)))));
-      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None 
+      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None
         [(None, None, $rules$)];
       Pptactic.declare_extra_genarg_pprule
         ($rawwit$, $lid:rawpr$)
@@ -174,11 +183,13 @@ let declare_vernac_argument loc s pr cl =
     | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in
   <:str_item<
     declare
+      open Pcoq;
+      open Extrawit;
       value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel),
              ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel),
               $lid:"rawwit_"^s$) = Genarg.create_arg $se$;
       value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
-      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None 
+      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None
         [(None, None, $rules$)];
       Pptactic.declare_extra_genarg_pprule
         ($rawwit$, $pr_rules$)
@@ -202,10 +213,10 @@ EXTEND
         h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
         rawtyppr =
         (* Necessary if the globalized type is different from the final type *)
-          OPT [ "RAW_TYPED"; "AS"; t = argtype; 
+          OPT [ "RAW_TYPED"; "AS"; t = argtype;
                 "RAW_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
         globtyppr =
-          OPT [ "GLOB_TYPED"; "AS"; t = argtype; 
+          OPT [ "GLOB_TYPED"; "AS"; t = argtype;
                 "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
         OPT "|"; l = LIST1 argrule SEP "|";
         "END" ->
@@ -221,13 +232,13 @@ EXTEND
          declare_vernac_argument loc s pr l ] ]
   ;
   argtype:
-    [ "2" 
+    [ "2"
       [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ]
     | "1"
       [ e = argtype; LIDENT "list" -> List0ArgType e
       | e = argtype; LIDENT "option" -> OptArgType e ]
     | "0"
-      [ e = LIDENT -> fst (interp_entry_name loc e "")
+      [ e = LIDENT -> fst (interp_entry_name false None e "")
       | "("; e = argtype; ")" -> e ] ]
   ;
   argrule:
@@ -235,13 +246,15 @@ EXTEND
   ;
   genarg:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name loc e "" in (g, Some (s,t))
+        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 loc e sep in (g, Some (s,t))
+        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
-	    Compat.using Pcoq.lexer ("", s);
-        (<:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>, None)
+	    Lexer.add_token ("", s);
+          GramTerminal s
     ] ]
   ;
   END
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
index 43836dbb..023ec0f3 100644
--- a/parsing/egrammar.ml
+++ b/parsing/egrammar.ml
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: egrammar.ml 11512 2008-10-27 12:28:36Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Pcoq
 open Extend
+open Ppextend
 open Topconstr
 open Genarg
 open Libnames
@@ -21,9 +22,9 @@ open Names
 open Vernacexpr
 
 (**************************************************************************)
-(*  
+(*
  * --- Note on the mapping of grammar productions to camlp4 actions ---
- *  
+ *
  * Translation of environments: a production
  *   [ nt1(x1) ... nti(xi) ] -> act(x1..xi)
  * is written (with camlp4 conventions):
@@ -33,9 +34,9 @@ open Vernacexpr
  * the make_*_action family build the following closure:
  *
  *      ((fun env ->
- *          (fun vi -> 
+ *          (fun vi ->
  *             (fun env -> ...
- *           
+ *
  *                  (fun v1 ->
  *                     (fun env -> gram_action .. env act)
  *                     ((x1,v1)::env))
@@ -47,69 +48,106 @@ open Vernacexpr
 (**********************************************************************)
 (** Declare Notations grammar rules                                   *)
 
-type prod_item =
-  | Term of Token.pattern
-  | NonTerm of constr_production_entry * 
-      (Names.identifier * constr_production_entry) option
+let constr_expr_of_name (loc,na) = match na with
+  | Anonymous -> CHole (loc,None)
+  | Name id -> CRef (Ident (loc,id))
+
+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 Token.pattern
+  | GramConstrNonTerminal of constr_prod_entry_key * identifier option
+  | GramConstrListMark of int * bool
+    (* tells action rule to make a list of the n previous parsed items; 
+       concat with last parsed list if true *)
 
 type 'a action_env = 'a list * 'a list list
 
 let make_constr_action
   (f : loc -> constr_expr action_env -> constr_expr) pil =
   let rec make (env,envlist as fullenv : constr_expr action_env) = function
-    | [] ->
-	Gramext.action (fun loc -> f loc fullenv)
-    | None :: tl -> (* parse a non-binding item *)
-        Gramext.action (fun _ -> make fullenv tl)
-    | Some (p, (ETConstr _| ETOther _)) :: tl -> (* constr non-terminal *)
+  | [] ->
+      Gramext.action (fun loc -> f loc fullenv)
+  | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
+      (* parse a non-binding item *)
+      Gramext.action (fun _ -> make fullenv tl)
+  | GramConstrNonTerminal (typ, Some _) :: tl ->
+      (* parse a binding non-terminal *)
+    (match typ with
+    | (ETConstr _| ETOther _) ->
         Gramext.action (fun (v:constr_expr) -> make (v :: env, envlist) tl)
-    | Some (p, ETReference) :: tl -> (* non-terminal *)
+    | ETReference ->
         Gramext.action (fun (v:reference) -> make (CRef v :: env, envlist) tl)
-    | Some (p, ETIdent) :: tl -> (* non-terminal *)
-        Gramext.action (fun (v:identifier) ->
-	  make (CRef (Ident (dummy_loc,v)) :: env, envlist) tl)
-    | Some (p, ETBigint) :: tl -> (* non-terminal *)
+    | ETName ->
+        Gramext.action (fun (na:name located) ->
+	  make (constr_expr_of_name na :: env, envlist) tl)
+    | ETBigint ->
         Gramext.action (fun (v:Bigint.bigint) ->
 	  make (CPrim (dummy_loc,Numeral v) :: env, envlist) tl)
-    | Some (p, ETConstrList _) :: tl ->
-        Gramext.action (fun (v:constr_expr list) -> make (env, v::envlist) tl)
-    | Some (p, ETPattern) :: tl -> 
-	failwith "Unexpected entry of type cases pattern" in
+    | ETConstrList (_,n) ->
+	Gramext.action (fun (v:constr_expr list) -> make (env, v::envlist) tl)
+    | ETPattern ->
+	failwith "Unexpected entry of type cases pattern")
+  | 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) tl
+      else make (env,heads::envlist) tl
+  in
   make ([],[]) (List.rev pil)
 
 let make_cases_pattern_action
   (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
   let rec make (env,envlist as fullenv : cases_pattern_expr action_env) = function
-    | [] ->
-	Gramext.action (fun loc -> f loc fullenv)
-    | None :: tl -> (* parse a non-binding item *)
-        Gramext.action (fun _ -> make fullenv tl)
-    | Some (p, ETConstr _) :: tl -> (* pattern non-terminal *)
+  | [] ->
+      Gramext.action (fun loc -> f loc fullenv)
+  | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
+      (* parse a non-binding item *)
+      Gramext.action (fun _ -> make fullenv tl)
+  | GramConstrNonTerminal (typ, Some _) :: tl ->
+      (* parse a binding non-terminal *)
+    (match typ with
+    | ETConstr _ -> (* pattern non-terminal *)
         Gramext.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl)
-    | Some (p, ETReference) :: tl -> (* non-terminal *)
+    | ETReference ->
         Gramext.action (fun (v:reference) ->
 	  make (CPatAtom (dummy_loc,Some v) :: env, envlist) tl)
-    | Some (p, ETIdent) :: tl -> (* non-terminal *)
-        Gramext.action (fun (v:identifier) ->
-	  make 
-	    (CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))::env, envlist) tl)
-    | Some (p, ETBigint) :: tl -> (* non-terminal *)
+    | ETName ->
+        Gramext.action (fun (na:name located) ->
+	  make (cases_pattern_expr_of_name na :: env, envlist) tl)
+    | ETBigint ->
         Gramext.action (fun (v:Bigint.bigint) ->
 	  make (CPatPrim (dummy_loc,Numeral v) :: env, envlist) tl)
-    | Some (p, ETConstrList _) :: tl ->
-        Gramext.action (fun (v:cases_pattern_expr list) ->
-	  make (env, v :: envlist) tl)
-    | Some (p, (ETPattern | ETOther _)) :: tl -> 
-	failwith "Unexpected entry of type cases pattern or other" in
+    | ETConstrList (_,_) ->
+        Gramext.action  (fun (vl:cases_pattern_expr list) ->
+	  make (env, vl :: envlist) tl)
+    | (ETPattern | ETOther _) ->
+	failwith "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) tl
+      else make (env,heads::envlist) tl
+  in
   make ([],[]) (List.rev pil)
 
-let make_constr_prod_item univ assoc from forpat = function
-  | Term tok -> (Gramext.Stoken tok, None)
-  | NonTerm (nt, ovar) ->
-      let eobj = symbol_of_production assoc from forpat nt in
-      (eobj, ovar)
-
-let prepare_empty_levels entry (pos,p4assoc,name,reinit) =
+let rec make_constr_prod_item assoc from forpat = function
+  | GramConstrTerminal tok :: l ->
+      Gramext.Stoken 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 pos reinit [(name, p4assoc, [])]
 
 let pure_sublevels level symbs =
@@ -119,26 +157,25 @@ let pure_sublevels level symbs =
   | _ ->
       failwith "") symbs
 
-let extend_constr (entry,level) (n,assoc) mkact forpat pt =
-  let univ = get_univ "constr" in
-  let pil = List.map (make_constr_prod_item univ assoc n forpat) pt in
-  let (symbs,ntl) = List.split pil in
+let extend_constr (entry,level) (n,assoc) mkact forpat rules =
+  List.iter (fun 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 pos,p4assoc,name,reinit = find_position forpat assoc level in
-  List.iter (prepare_empty_levels entry) needed_levels;
-  grammar_extend entry pos reinit [(name, p4assoc, [symbs, mkact ntl])]
+  List.iter (prepare_empty_levels forpat) needed_levels;
+  grammar_extend entry pos reinit [(name, p4assoc, [symbs, mkact pt])]) rules
 
-let extend_constr_notation (n,assoc,ntn,rule) =
+let extend_constr_notation (n,assoc,ntn,rules) =
   (* Add the notation in constr *)
   let mkact loc env = CNotation (loc,ntn,env) in
-  let e = get_constr_entry false (ETConstr (n,())) in
-  extend_constr e (ETConstr(n,()),assoc) (make_constr_action mkact) false rule;
+  let e = interp_constr_entry_key false (ETConstr (n,())) in
+  extend_constr e (ETConstr(n,()),assoc) (make_constr_action mkact) false rules;
   (* Add the notation in cases_pattern *)
   let mkact loc env = CPatNotation (loc,ntn,env) in
-  let e = get_constr_entry true (ETConstr (n,())) in
+  let e = interp_constr_entry_key true (ETConstr (n,())) in
   extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact)
-    true rule
+    true rules
 
 (**********************************************************************)
 (** Making generic actions in type generic_argument                   *)
@@ -146,7 +183,7 @@ let extend_constr_notation (n,assoc,ntn,rule) =
 let make_generic_action
   (f:loc -> ('b * raw_generic_argument) list -> 'a) pil =
   let rec make env = function
-    | [] -> 
+    | [] ->
 	Gramext.action (fun loc -> f loc env)
     | None :: tl -> (* parse a non-binding item *)
         Gramext.action (fun _ -> make env tl)
@@ -160,24 +197,21 @@ let make_rule univ f g pt =
   (symbs, act)
 
 (**********************************************************************)
-(** Grammar extensions declared at ML level                           *) 
+(** Grammar extensions declared at ML level                           *)
 
-type grammar_tactic_production =
-  | TacTerm of string
-  | TacNonTerm of
-      loc * (Gram.te Gramext.g_symbol * argument_type) * string option
+type grammar_prod_item =
+  | GramTerminal of string
+  | GramNonTerminal of
+      loc * argument_type * Gram.te prod_entry_key * identifier option
 
 let make_prod_item = function
-  | TacTerm s -> (Gramext.Stoken (Lexer.terminal s), None)
-  | TacNonTerm (_,(nont,t), po) -> (nont, Option.map (fun p -> (p,t)) po)
+  | GramTerminal s -> (Gramext.Stoken (Lexer.terminal s), None)
+  | GramNonTerminal (_,t,e,po) ->
+      (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po)
 
 (* Tactic grammar extensions *)
 
-let tac_exts = ref []
-let get_extend_tactic_grammars () = !tac_exts
-
 let extend_tactic_grammar s gl =
-  tac_exts := (s,gl) :: !tac_exts;
   let univ = get_univ "tactic" in
   let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
   let rules = List.map (make_rule univ mkact make_prod_item) gl in
@@ -196,53 +230,7 @@ let extend_vernac_command_grammar s gl =
   Gram.extend Vernac_.command None [(None, None, List.rev rules)]
 
 (**********************************************************************)
-(** Grammar declaration for Tactic Notation (Coq level)               *) 
-
-(* Interpretation of the grammar entry names *)
-
-let find_index s t =
-  let t,n = repr_ident (id_of_string t) in
-  if s <> t or n = None then raise Not_found;
-  Option.get n
-
-let rec interp_entry_name up_level s =
-  let l = String.length s in
-  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name up_level (String.sub s 3 (l-8)) in
-    List1ArgType t, Gramext.Slist1 g
-  else if l > 5 & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name up_level (String.sub s 0 (l-5)) in
-    List0ArgType t, Gramext.Slist0 g
-  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
-    let t, g = interp_entry_name up_level (String.sub s 0 (l-4)) in
-    OptArgType t, Gramext.Sopt g
-  else
-    let s = if s = "hyp" then "var" else s in
-    try 
-      let i = find_index "tactic" s in
-      ExtraArgType s, 
-      if up_level<>5 && i=up_level then Gramext.Sself else
-      if up_level<>5 && i=up_level-1 then Gramext.Snext else
-      Gramext.Snterml(Pcoq.Gram.Entry.obj Tactic.tactic_expr,string_of_int i)
-    with Not_found ->
-    let e = 
-      (* Qualified entries are no longer in use *)
-      try get_entry (get_univ "tactic") s
-      with _ -> 
-      try get_entry (get_univ "prim") s
-      with _ ->
-      try get_entry (get_univ "constr") s
-      with _ -> error ("Unknown entry "^s^".")
-    in
-    let o = object_of_typed_entry e in
-    let t = type_of_typed_entry e in
-    t,Gramext.Snterm (Pcoq.Gram.Entry.obj o)
-
-let make_vprod_item n = function
-  | VTerm s -> (Gramext.Stoken (Lexer.terminal s), None)
-  | VNonTerm (loc, nt, po) ->
-      let (etyp, e) = interp_entry_name n nt in
-      e, Option.map (fun p -> (p,etyp)) po
+(** Grammar declaration for Tactic Notation (Coq level)               *)
 
 let get_tactic_entry n =
   if n = 0 then
@@ -251,43 +239,42 @@ let get_tactic_entry n =
     weaken_entry Tactic.binder_tactic, None
   else if 1<=n && n<5 then
     weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n))
-  else 
+  else
     error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
 
 (* Declaration of the tactic grammar rule *)
 
-let head_is_ident = function VTerm _::_ -> true | _ -> false
+let head_is_ident = function GramTerminal _::_ -> true | _ -> false
 
 let add_tactic_entry (key,lev,prods,tac) =
   let univ = get_univ "tactic" in
   let entry, pos = get_tactic_entry lev in
-  let mkprod = make_vprod_item lev in
-  let rules = 
+  let rules =
     if lev = 0 then begin
       if not (head_is_ident prods) then
 	error "Notation for simple tactic must start with an identifier.";
       let mkact s tac loc l =
 	(TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in
-      make_rule univ (mkact key tac) mkprod prods
+      make_rule univ (mkact key tac) make_prod_item prods
     end
     else
-      let mkact s tac loc l = 
+      let mkact s tac loc l =
 	(TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in
-      make_rule univ (mkact key tac) mkprod prods in
+      make_rule univ (mkact key tac) make_prod_item prods in
   synchronize_level_positions ();
   grammar_extend entry pos None [(None, None, List.rev [rules])]
 
 (**********************************************************************)
 (** State of the grammar extensions                                   *)
 
-type notation_grammar = 
-    int * Gramext.g_assoc option * notation * prod_item list
+type notation_grammar =
+    int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list
 
 type all_grammar_command =
-  | Notation of Notation.level * notation_grammar
+  | Notation of (precedence * tolerability list) * notation_grammar
   | TacticGrammar of
-      (string * int * grammar_production list * 
-        (Names.dir_path * Tacexpr.glob_tactic_expr))
+      (string * int * grammar_prod_item list *
+         (dir_path * Tacexpr.glob_tactic_expr))
 
 let (grammar_state : all_grammar_command list ref) = ref []
 
@@ -297,14 +284,6 @@ let extend_grammar gram =
   | TacticGrammar g -> add_tactic_entry g);
   grammar_state := gram :: !grammar_state
 
-let reset_extend_grammars_v8 () =
-  let te = List.rev !tac_exts in
-  let tv = List.rev !vernac_exts in
-  tac_exts := [];
-  vernac_exts := [];
-  List.iter (fun (s,gl) -> print_string ("Resinstalling "^s); flush stdout; extend_tactic_grammar s gl) te;
-  List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv
-
 let recover_notation_grammar ntn prec =
   let l = map_succeed (function
     | Notation (prec',(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> x
@@ -319,7 +298,7 @@ type frozen_t = all_grammar_command list * Lexer.frozen_t
 
 let freeze () = (!grammar_state, Lexer.freeze ())
 
-(* We compare the current state of the grammar and the state to unfreeze, 
+(* 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
@@ -339,7 +318,7 @@ let unfreeze (grams, lex) =
   grammar_state := common;
   Lexer.unfreeze lex;
   List.iter extend_grammar (List.rev redo)
- 
+
 let init_grammar () =
   remove_grammars (number_of_entries !grammar_state);
   grammar_state := []
@@ -349,10 +328,8 @@ let init () =
 
 open Summary
 
-let _ = 
+let _ =
   declare_summary "GRAMMAR_LEXER"
     { freeze_function = freeze;
       unfreeze_function = unfreeze;
-      init_function = init;
-      survive_module = false;
-      survive_section = false }
+      init_function = init }
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
index d2d912d1..1228b40c 100644
--- a/parsing/egrammar.mli
+++ b/parsing/egrammar.mli
@@ -6,62 +6,63 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: egrammar.mli 10122 2007-09-15 10:35:59Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
+open Names
 open Topconstr
 open Pcoq
 open Extend
 open Vernacexpr
 open Ppextend
 open Rawterm
+open Genarg
 open Mod_subst
 (*i*)
 
 (** Mapping of grammar productions to camlp4 actions
-    Used for Coq-level Notation and Tactic Notation, 
+    Used for Coq-level Notation and Tactic Notation,
     and for ML-level tactic and vernac extensions
  *)
 
-type prod_item =
-  | Term of Token.pattern
-  | NonTerm of constr_production_entry * 
-      (Names.identifier * constr_production_entry) option
+(* For constr notations *)
 
-type notation_grammar = 
-    int * Gramext.g_assoc option * notation * prod_item list
+type grammar_constr_prod_item =
+  | GramConstrTerminal of Token.pattern
+  | GramConstrNonTerminal of constr_prod_entry_key * identifier option
+  | GramConstrListMark of int * bool
+    (* tells action rule to make a list of the n previous parsed items; 
+       concat with last parsed list if true *)
+
+type notation_grammar =
+    int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list
+
+(* For tactic and vernac notations *)
+
+type grammar_prod_item =
+  | GramTerminal of string
+  | GramNonTerminal of loc * argument_type *
+      Gram.te prod_entry_key * identifier option
+
+(* Adding notations *)
 
 type all_grammar_command =
   | Notation of (precedence * tolerability list) * notation_grammar
   | TacticGrammar of
-      (string * int * grammar_production list * 
-        (Names.dir_path * Tacexpr.glob_tactic_expr))
+      (string * int * grammar_prod_item list *
+         (dir_path * Tacexpr.glob_tactic_expr))
 
 val extend_grammar : all_grammar_command -> unit
 
-(* Add grammar rules for tactics *)
-
-type grammar_tactic_production =
-  | TacTerm of string
-  | TacNonTerm of
-      loc * (Compat.token Gramext.g_symbol * Genarg.argument_type) * string option
-
 val extend_tactic_grammar :
-  string -> grammar_tactic_production list list -> unit
+  string -> grammar_prod_item list list -> unit
 
 val extend_vernac_command_grammar :
-  string -> grammar_tactic_production list list -> unit
-(*
-val get_extend_tactic_grammars :
- unit -> (string * grammar_tactic_production list list) list
-*)
+  string -> grammar_prod_item list list -> unit
+
 val get_extend_vernac_grammars :
- unit -> (string * grammar_tactic_production list list) list
-(*
-val reset_extend_grammars_v8 : unit -> unit
-*)
-val interp_entry_name : int -> string -> entry_type * Compat.token Gramext.g_symbol
+ unit -> (string * grammar_prod_item list list) list
 
 val recover_notation_grammar :
   notation -> (precedence * tolerability list) -> notation_grammar
diff --git a/parsing/extend.ml b/parsing/extend.ml
index f4c98291..7643120f 100644
--- a/parsing/extend.ml
+++ b/parsing/extend.ml
@@ -6,52 +6,58 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-
-(*i $Id: extend.ml 7761 2005-12-30 10:52:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Util
-open Pp
-open Gramext
-open Names
-open Ppextend
-open Topconstr
-open Genarg
 
 (**********************************************************************)
-(* constr entry keys                                                  *)
+(* 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 'a prod_entry_key =
+  | Alist1 of 'a prod_entry_key
+  | Alist1sep of 'a prod_entry_key * string
+  | Alist0 of 'a prod_entry_key
+  | Alist0sep of 'a prod_entry_key * string
+  | Aopt of 'a prod_entry_key
+  | Amodifiers of 'a prod_entry_key
+  | Aself
+  | Anext
+  | Atactic of int
+  | Agram of 'a Gramext.g_entry
+  | Aentry of string * string
+
+(**********************************************************************)
+(* Entry keys for constr notations                                    *)
 
 type side = Left | Right
 
 type production_position =
-  | BorderProd of side * Gramext.g_assoc option  (* true=left; false=right *)
+  | BorderProd of side * Gramext.g_assoc option
   | InternalProd
 
 type production_level =
   | NextLevel
   | NumLevel of int
 
-type ('lev,'pos) constr_entry_key =
-  | ETIdent | ETReference | ETBigint
+type ('lev,'pos) constr_entry_key_gen =
+  | ETName | ETReference | ETBigint
   | ETConstr of ('lev * 'pos)
   | ETPattern
   | ETOther of string * string
   | ETConstrList of ('lev * 'pos) * Token.pattern list
 
-type constr_production_entry =
-    (production_level,production_position) constr_entry_key
-type constr_entry =
-    (int,unit) constr_entry_key
-type simple_constr_production_entry =
-    (production_level,unit) constr_entry_key
-
-(**********************************************************************)
-(* syntax modifiers                                                   *)
+(* Entries level (left-hand-side of grammar rules) *)
+type constr_entry_key =
+    (int,unit) constr_entry_key_gen
 
-type syntax_modifier =
-  | SetItemLevel of string list * production_level
-  | SetLevel of int
-  | SetAssoc of Gramext.g_assoc
-  | SetEntryType of string * simple_constr_production_entry
-  | SetOnlyParsing
-  | SetFormat of string located
+(* Entries used in productions (in right-hand-side of grammar rules) *)
+type constr_prod_entry_key =
+    (production_level,production_position) constr_entry_key_gen
 
+(* Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *)
+type simple_constr_prod_entry_key =
+    (production_level,unit) constr_entry_key_gen
diff --git a/parsing/extend.mli b/parsing/extend.mli
index 80de7108..7643120f 100644
--- a/parsing/extend.mli
+++ b/parsing/extend.mli
@@ -6,45 +6,58 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extend.mli 7761 2005-12-30 10:52:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Util
 
 (**********************************************************************)
-(* constr entry keys                                                  *)
+(* 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 'a prod_entry_key =
+  | Alist1 of 'a prod_entry_key
+  | Alist1sep of 'a prod_entry_key * string
+  | Alist0 of 'a prod_entry_key
+  | Alist0sep of 'a prod_entry_key * string
+  | Aopt of 'a prod_entry_key
+  | Amodifiers of 'a prod_entry_key
+  | Aself
+  | Anext
+  | Atactic of int
+  | Agram of 'a Gramext.g_entry
+  | Aentry of string * string
+
+(**********************************************************************)
+(* Entry keys for constr notations                                    *)
 
 type side = Left | Right
 
 type production_position =
-  | BorderProd of side * Gramext.g_assoc option  (* true=left; false=right *)
+  | BorderProd of side * Gramext.g_assoc option
   | InternalProd
 
 type production_level =
   | NextLevel
   | NumLevel of int
 
-type ('lev,'pos) constr_entry_key =
-  | ETIdent | ETReference | ETBigint
+type ('lev,'pos) constr_entry_key_gen =
+  | ETName | ETReference | ETBigint
   | ETConstr of ('lev * 'pos)
   | ETPattern
   | ETOther of string * string
   | ETConstrList of ('lev * 'pos) * Token.pattern list
 
-type constr_production_entry =
-    (production_level,production_position) constr_entry_key
-type constr_entry =
-    (int,unit) constr_entry_key
-type simple_constr_production_entry =
-    (production_level,unit) constr_entry_key
-
-(**********************************************************************)
-(* syntax modifiers                                                   *)
+(* Entries level (left-hand-side of grammar rules) *)
+type constr_entry_key =
+    (int,unit) constr_entry_key_gen
 
-type syntax_modifier =
-  | SetItemLevel of string list * production_level
-  | SetLevel of int
-  | SetAssoc of Gramext.g_assoc
-  | SetEntryType of string * simple_constr_production_entry
-  | SetOnlyParsing
-  | SetFormat of string located
+(* Entries used in productions (in right-hand-side of grammar rules) *)
+type constr_prod_entry_key =
+    (production_level,production_position) constr_entry_key_gen
 
+(* Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *)
+type simple_constr_prod_entry_key =
+    (production_level,unit) constr_entry_key_gen
diff --git a/parsing/extrawit.ml b/parsing/extrawit.ml
new file mode 100644
index 00000000..122730f7
--- /dev/null
+++ b/parsing/extrawit.ml
@@ -0,0 +1,62 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Util
+open Genarg
+
+(* This file defines extra argument types *)
+
+(* Tactics as arguments *)
+
+let tactic_main_level = 5
+
+let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg "tactic0"
+let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg "tactic1"
+let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg "tactic2"
+let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg "tactic3"
+let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg "tactic4"
+let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg "tactic5"
+
+let wit_tactic = function
+  | 0 -> wit_tactic0
+  | 1 -> wit_tactic1
+  | 2 -> wit_tactic2
+  | 3 -> wit_tactic3
+  | 4 -> wit_tactic4
+  | 5 -> wit_tactic5
+  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
+
+let globwit_tactic = function
+  | 0 -> globwit_tactic0
+  | 1 -> globwit_tactic1
+  | 2 -> globwit_tactic2
+  | 3 -> globwit_tactic3
+  | 4 -> globwit_tactic4
+  | 5 -> globwit_tactic5
+  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
+
+let rawwit_tactic = function
+  | 0 -> rawwit_tactic0
+  | 1 -> rawwit_tactic1
+  | 2 -> rawwit_tactic2
+  | 3 -> rawwit_tactic3
+  | 4 -> rawwit_tactic4
+  | 5 -> rawwit_tactic5
+  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
+
+let tactic_genarg_level s =
+  if String.length s = 7 && String.sub s 0 6 = "tactic" then
+    let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48)
+    else None
+  else None
+
+let is_tactic_genarg = function
+| ExtraArgType s -> tactic_genarg_level s <> None
+| _ -> false
diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli
new file mode 100644
index 00000000..9eff5dc1
--- /dev/null
+++ b/parsing/extrawit.mli
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Util
+open Genarg
+open Tacexpr
+
+(* This file defines extra argument types *)
+
+(* Tactics as arguments *)
+
+val tactic_main_level : int
+
+val rawwit_tactic : int -> (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic : int -> (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic : int -> (glob_tactic_expr,tlevel) abstract_argument_type
+
+val rawwit_tactic0 : (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic0 : (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic0 : (glob_tactic_expr,tlevel) abstract_argument_type
+
+val rawwit_tactic1 : (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic1 : (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic1 : (glob_tactic_expr,tlevel) abstract_argument_type
+
+val rawwit_tactic2 : (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic2 : (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic2 : (glob_tactic_expr,tlevel) abstract_argument_type
+
+val rawwit_tactic3 : (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic3 : (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic3 : (glob_tactic_expr,tlevel) abstract_argument_type
+
+val rawwit_tactic4 : (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic4 : (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic4 : (glob_tactic_expr,tlevel) abstract_argument_type
+
+val rawwit_tactic5 : (raw_tactic_expr,rlevel) abstract_argument_type
+val globwit_tactic5 : (glob_tactic_expr,glevel) abstract_argument_type
+val wit_tactic5 : (glob_tactic_expr,tlevel) abstract_argument_type
+
+val is_tactic_genarg : argument_type -> bool
+
+val tactic_genarg_level : string -> int option
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
index cdce13e6..393125e2 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -8,8 +8,9 @@
 
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(* $Id: g_constr.ml4 11709 2008-12-20 11:42:15Z msozeau $ *)
+(* $Id$ *)
 
+open Pp
 open Pcoq
 open Constr
 open Prim
@@ -22,7 +23,7 @@ open Topconstr
 open Util
 
 let constr_kw =
-  [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; 
+  [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for";
     "end"; "as"; "let"; "if"; "then"; "else"; "return";
     "Prop"; "Set"; "Type"; ".("; "_"; "..";
     "`{"; "`("; "{|"; "|}" ]
@@ -33,35 +34,21 @@ let mk_cast = function
     (c,(_,None)) -> c
   | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty))
 
-let mk_lam = function
-    ([],c) -> c
-  | (bl,c) -> CLambdaN(constr_loc c, bl,c)
-
 let loc_of_binder_let = function
   | LocalRawAssum ((loc,_)::_,_,_)::_ -> loc
   | LocalRawDef ((loc,_),_)::_ -> loc
   | _ -> dummy_loc
 
 let binders_of_lidents l =
-  List.map (fun (loc, id) -> 
-    LocalRawAssum ([loc, Name id], Default Rawterm.Explicit, 
+  List.map (fun (loc, id) ->
+    LocalRawAssum ([loc, Name id], Default Rawterm.Explicit,
 		  CHole (loc, Some (Evd.BinderType (Name id))))) l
-    
-let rec index_and_rec_order_of_annot loc bl ann =
-  match names_of_local_assums bl,ann with
-    | [loc,Name id], (None, r) -> Some (loc, id), r
-    | lids, (Some (loc, n), ro) ->
-        if List.exists (fun (_, x) -> x = Name n) lids then
-	  Some (loc, n), ro
-        else user_err_loc(loc,"index_of_annot", Pp.str"No such fix variable.")
-    | _, (None, r) -> None, r
 
 let mk_fixb (id,bl,ann,body,(loc,tyc)) =
-  let n,ro = index_and_rec_order_of_annot (fst id) bl ann in
   let ty = match tyc with
       Some ty -> ty
     | None -> CHole (loc, None) in
-  (id,(n,ro),bl,ty,body)
+  (id,ann,bl,ty,body)
 
 let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
   let _ = Option.map (fun (aloc,_) ->
@@ -74,7 +61,7 @@ let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
   (id,bl,ty,body)
 
 let mk_fix(loc,kw,id,dcls) =
-  if kw then 
+  if kw then
     let fb = List.map mk_fixb dcls in
     CFix(loc,id,fb)
   else
@@ -84,9 +71,6 @@ let mk_fix(loc,kw,id,dcls) =
 let mk_single_fix (loc,kw,dcl) =
   let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl])
 
-let binder_constr =
-  create_constr_entry (get_univ "constr") "binder_constr"
-
 (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
 (* admissible notation "(x t)" *)
 let lpar_id_coloneq =
@@ -108,16 +92,16 @@ let impl_ident =
   Gram.Entry.of_parser "impl_ident"
     (fun strm ->
       match Stream.npeek 1 strm with
-	| [(_,"{")] -> 
+	| [(_,"{")] ->
 	    (match Stream.npeek 2 strm with
 	      | [_;("IDENT",("wf"|"struct"|"measure"))] ->
 		  raise Stream.Failure
-	      | [_;("IDENT",s)] -> 
+	      | [_;("IDENT",s)] ->
 		  Stream.junk strm; Stream.junk strm;
 		  Names.id_of_string s
 	      | _ -> raise Stream.Failure)
 	| _ -> raise Stream.Failure)
-    
+
 let ident_colon =
   Gram.Entry.of_parser "ident_colon"
     (fun strm ->
@@ -141,7 +125,7 @@ let ident_with =
               Names.id_of_string s
           | _ -> raise Stream.Failure)
       | _ -> raise Stream.Failure)
-    
+
 let aliasvar = function CPatAlias (_, _, id) -> Some (Name id) | _ -> None
 
 GEXTEND Gram
@@ -176,21 +160,21 @@ GEXTEND Gram
     [ [ c = operconstr LEVEL "200" -> c ] ]
   ;
   constr:
-    [ [ c = operconstr LEVEL "8" -> c 
+    [ [ c = operconstr LEVEL "8" -> c
       | "@"; f=global -> CAppExpl(loc,(None,f),[]) ] ]
   ;
   operconstr:
     [ "200" RIGHTA
       [ c = binder_constr -> c ]
     | "100" RIGHTA
-      [ c1 = operconstr; "<:"; c2 = binder_constr -> 
+      [ c1 = operconstr; "<:"; c2 = binder_constr ->
                  CCast(loc,c1, CastConv (VMcast,c2))
-      | c1 = operconstr; "<:"; c2 = SELF -> 
+      | c1 = operconstr; "<:"; c2 = SELF ->
                  CCast(loc,c1, CastConv (VMcast,c2))
-      | c1 = operconstr; ":";c2 = binder_constr -> 
+      | c1 = operconstr; ":";c2 = binder_constr ->
+                 CCast(loc,c1, CastConv (DEFAULTcast,c2))
+      | c1 = operconstr; ":"; c2 = SELF ->
                  CCast(loc,c1, CastConv (DEFAULTcast,c2))
-      | c1 = operconstr; ":"; c2 = SELF -> 
-                 CCast(loc,c1, CastConv (DEFAULTcast,c2)) 
       | c1 = operconstr; ":>" ->
                  CCast(loc,c1, CastCoerce) ]
     | "99" RIGHTA [ ]
@@ -212,7 +196,7 @@ GEXTEND Gram
 	CApp(loc,(Some (List.length args+1),CRef f),args@[c,None])
       | c=operconstr; ".("; "@"; f=global;
         args=LIST0 (operconstr LEVEL "9"); ")" ->
-        CAppExpl(loc,(Some (List.length args+1),f),args@[c]) 
+        CAppExpl(loc,(Some (List.length args+1),f),args@[c])
       | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ]
     | "0"
       [ c=atomic_constr -> c
@@ -229,13 +213,13 @@ GEXTEND Gram
 	  CGeneralization (loc, Explicit, None, c)
       ] ]
   ;
-  forall: 
-    [ [ "forall" -> () 
+  forall:
+    [ [ "forall" -> ()
     | IDENT "Π" -> ()
     ] ]
   ;
-  lambda: 
-    [ [ "fun" -> () 
+  lambda:
+    [ [ "fun" -> ()
     | IDENT "λ" -> ()
     ] ]
   ;
@@ -246,7 +230,7 @@ GEXTEND Gram
     ] ]
   ;
   record_field_declaration:
-    [ [ id = identref; params = LIST0 identref; ":="; c = lconstr -> 
+    [ [ id = global; params = LIST0 identref; ":="; c = lconstr ->
       (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ]
   ;
   binder_constr:
@@ -273,10 +257,10 @@ GEXTEND Gram
       | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200";
           "in"; c2 = operconstr LEVEL "200" ->
 	    CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)])
-      | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; 
+      | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200";
 	  rt = case_type; "in"; c2 = operconstr LEVEL "200" ->
 	    CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(loc, [(loc, [p])], c2)])
-      | "let"; "'"; p=pattern; "in"; t = operconstr LEVEL "200"; 
+      | "let"; "'"; p=pattern; "in"; t = operconstr 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)])
@@ -315,7 +299,8 @@ GEXTEND Gram
   ;
   fix_decl:
     [ [ id=identref; bl=binders_let_fixannot; ty=type_cstr; ":=";
-        c=operconstr LEVEL "200" -> (id,fst bl,snd bl,c,ty) ] ]
+        c=operconstr LEVEL "200" ->
+          (id,fst bl,snd bl,c,ty) ] ]
   ;
   match_constr:
     [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with";
@@ -333,8 +318,8 @@ GEXTEND Gram
   ;
   return_type:
     [ [ a = OPT [ na = OPT["as"; id=name -> snd id];
-                  ty = case_type -> (na,ty) ] -> 
-        match a with 
+                  ty = case_type -> (na,ty) ] ->
+        match a with
           | None -> None, None
           | Some (na,t) -> (na, Some t)
     ] ]
@@ -349,6 +334,9 @@ GEXTEND Gram
     [ [ pll = LIST1 mult_pattern SEP "|";
         "=>"; rhs = lconstr -> (loc,pll,rhs) ] ]
   ;
+  recordpattern:
+    [ [ id = global; ":="; pat = pattern -> (id, pat) ] ]
+  ;
   pattern:
     [ "200" RIGHTA [ ]
     | "100" RIGHTA
@@ -358,7 +346,7 @@ GEXTEND Gram
       [ p = pattern; lp = LIST1 NEXT ->
         (match p with
           | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
-          | _ -> Util.user_err_loc 
+          | _ -> Util.user_err_loc
               (cases_pattern_expr_loc p, "compound_pattern",
                Pp.str "Constructor expected."))
       | p = pattern; "as"; id = ident ->
@@ -367,6 +355,7 @@ GEXTEND Gram
       [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ]
     | "0"
       [ r = Prim.reference -> CPatAtom (loc,Some r)
+      | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (loc, pat)
       | "_" -> CPatAtom (loc,None)
       | "("; p = pattern LEVEL "200"; ")" ->
           (match p with
@@ -377,9 +366,9 @@ GEXTEND Gram
       | s = string -> CPatPrim (loc, String s) ] ]
   ;
   binder_list:
-    [ [ idl=LIST1 name; bl=binders_let -> 
+    [ [ idl=LIST1 name; bl=binders_let ->
       LocalRawAssum (idl,Default Explicit,CHole (loc, Some (Evd.BinderType (snd (List.hd idl)))))::bl
-    | idl=LIST1 name; ":"; c=lconstr -> 
+    | idl=LIST1 name; ":"; c=lconstr ->
         [LocalRawAssum (idl,Default Explicit,c)]
     | cl = binders_let -> cl
     ] ]
@@ -397,15 +386,15 @@ GEXTEND Gram
   fixannot:
     [ [ "{"; IDENT "struct"; id=identref; "}" -> (Some id, CStructRec)
     | "{"; IDENT "wf"; rel=constr; id=OPT identref; "}" -> (id, CWfRec rel)
-    | "{"; IDENT "measure"; rel=constr; id=OPT identref; "}" -> (id, CMeasureRec rel)
+    | "{"; IDENT "measure"; m=constr; id=OPT identref;
+	rel=OPT constr; "}" -> (id, CMeasureRec (m,rel))
     ] ]
   ;
   binders_let_fixannot:
-    [ [ id=impl_ident; assum=binder_assum; bl = binders_let_fixannot -> 
+    [ [ id=impl_ident; assum=binder_assum; bl = binders_let_fixannot ->
 	(assum (loc, Name id) :: fst bl), snd bl
     | f = fixannot -> [], f
-    | b = binder_let; bl = binders_let_fixannot -> 
-	b @ fst bl, snd bl
+    | b = binder_let; bl = binders_let_fixannot -> b @ fst bl, snd bl
     | -> [], (None, CStructRec)
     ] ]
   ;
@@ -416,21 +405,21 @@ GEXTEND Gram
   binder_let:
     [ [ id=name ->
       [LocalRawAssum ([id],Default Explicit,CHole (loc, None))]
-    | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> 
+    | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" ->
         [LocalRawAssum (id::idl,Default Explicit,c)]
-    | "("; id=name; ":"; c=lconstr; ")" -> 
+    | "("; id=name; ":"; c=lconstr; ")" ->
         [LocalRawAssum ([id],Default Explicit,c)]
     | "("; id=name; ":="; c=lconstr; ")" ->
         [LocalRawDef (id,c)]
-    | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> 
+    | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" ->
         [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))]
     | "{"; id=name; "}" ->
         [LocalRawAssum ([id],Default Implicit,CHole (loc, None))]
-    | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> 
+    | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" ->
         [LocalRawAssum (id::idl,Default Implicit,c)]
-    | "{"; id=name; ":"; c=lconstr; "}" -> 
+    | "{"; id=name; ":"; c=lconstr; "}" ->
         [LocalRawAssum ([id],Default Implicit,c)]
-    | "{"; id=name; idl=LIST1 name; "}" -> 
+    | "{"; id=name; idl=LIST1 name; "}" ->
         List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl)
     | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" ->
 	List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc
@@ -440,8 +429,8 @@ GEXTEND Gram
   ;
   binder:
     [ [ id=name -> ([id],Default Explicit,CHole (loc, None))
-      | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,Default Explicit,c) 
-      | "{"; idl=LIST1 name; ":"; c=lconstr; "}" -> (idl,Default Implicit,c) 
+      | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,Default Explicit,c)
+      | "{"; idl=LIST1 name; ":"; c=lconstr; "}" -> (idl,Default Implicit,c)
     ] ]
   ;
   typeclass_constraint:
@@ -454,7 +443,7 @@ GEXTEND Gram
 	  (loc, Anonymous), false, c
     ] ]
   ;
-  
+
   type_cstr:
     [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ]
   ;
diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4
index 35fc064b..e73e54e7 100644
--- a/parsing/g_decl_mode.ml4
+++ b/parsing/g_decl_mode.ml4
@@ -9,7 +9,7 @@
 (*i camlp4deps: "parsing/grammar.cma" i*)
 (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
 
-(* $Id: g_decl_mode.ml4 12414 2009-10-25 18:50:41Z corbinea $ *)
+(* $Id$ *)
 
 
 open Decl_expr
@@ -29,7 +29,7 @@ let none_is_empty = function
 GEXTEND Gram
 GLOBAL: proof_instr;
   thesis :
-    [[ "thesis" -> Plain 
+    [[ "thesis" -> Plain
      | "thesis"; "for"; i=ident -> (For i)
      ]];
   statement :
@@ -42,9 +42,9 @@ GLOBAL: proof_instr;
      [[ t=thesis -> Thesis t ] |
       [ c=constr -> This c
       ]];
-  statement_or_thesis : 
+  statement_or_thesis :
     [
-      [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] 
+      [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ]
     |
       [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot}
       | i=ident -> {st_label=Anonymous;
@@ -52,25 +52,25 @@ GLOBAL: proof_instr;
       | c=constr -> {st_label=Anonymous;st_it=This c}
       ]
     ];
-  justification_items : 
-    [[ -> Some [] 
-     | IDENT "by"; l=LIST1 constr SEP "," -> Some l
-     | IDENT "by"; "*"                    -> None ]]
+  justification_items :
+    [[ -> Some []
+     | "by"; l=LIST1 constr SEP "," -> Some l
+     | "by"; "*"                    -> None ]]
   ;
-  justification_method : 
-    [[ -> None 
+  justification_method :
+    [[ -> None
      | "using";  tac = tactic -> Some tac ]]
   ;
   simple_cut_or_thesis :
     [[ ls = statement_or_thesis;
        j = justification_items;
-       taco = justification_method 	
+       taco = justification_method
 	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
   ;
   simple_cut :
     [[ ls = statement;
        j = justification_items;
-       taco = justification_method 	
+       taco = justification_method
 	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
   ;
   elim_type:
@@ -82,40 +82,40 @@ GLOBAL: proof_instr;
      | IDENT "focus" -> B_focus
      | IDENT "proof" -> B_proof
      | et=elim_type -> B_elim et ]]
-  ;    
+  ;
   elim_obj:
     [[ IDENT "on"; c=constr -> Real c
      | IDENT "of"; c=simple_cut -> Virtual c ]]
-  ;  
+  ;
   elim_step:
-    [[ IDENT "consider" ; 
+    [[ IDENT "consider" ;
        h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h)
      | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj)
      | IDENT "suffices"; ls=suff_clause;
        j = justification_items;
-       taco = justification_method 	
-	-> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] 
+       taco = justification_method
+	-> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]]
   ;
   rew_step :
-    [[ "~=" ;         c=simple_cut -> (Rhs,c)       
+    [[ "~=" ;         c=simple_cut -> (Rhs,c)
      | "=~" ;         c=simple_cut -> (Lhs,c)]]
   ;
   cut_step:
     [[ "then"; tt=elim_step -> Pthen tt
      | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c)
-     | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) 
+     | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c))
      | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c)
      | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c)
      | tt=elim_step -> tt
-     | tt=rew_step -> let s,c=tt in Prew (s,c); 
+     | tt=rew_step -> let s,c=tt in Prew (s,c);
      | IDENT "have"; c=simple_cut_or_thesis -> Pcut c;
      | IDENT "claim"; c=statement -> Pclaim c;
-     | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c;    
+     | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c;
      | "end"; bt = block_type -> Pend bt;
      | IDENT "escape" -> Pescape ]]
   ;
   (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*)
-  loc_id: 
+  loc_id:
     [[ id=ident -> fun x -> (loc,(id,x)) ]];
   hyp:
     [[ id=loc_id -> id None ;
@@ -124,27 +124,27 @@ GLOBAL: proof_instr;
   consider_vars:
     [[ name=hyp -> [Hvar name]
      | name=hyp; ","; v=consider_vars -> (Hvar name) :: v
-     | name=hyp; 
+     | name=hyp;
        IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h
      ]]
   ;
-  consider_hyps:  
+  consider_hyps:
     [[ st=statement; IDENT "and"; h=consider_hyps  -> Hprop st::h
-     | st=statement; IDENT "and"; 
+     | st=statement; IDENT "and";
        IDENT "consider" ; v=consider_vars  -> Hprop st::v
      | st=statement -> [Hprop st]
      ]]
-  ;  
+  ;
   assume_vars:
     [[ name=hyp -> [Hvar name]
      | name=hyp; ","; v=assume_vars -> (Hvar name) :: v
-     | name=hyp; 
+     | name=hyp;
        IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h
      ]]
   ;
-  assume_hyps:  
+  assume_hyps:
     [[ st=statement; IDENT "and"; h=assume_hyps  -> Hprop st::h
-     | st=statement; IDENT "and"; 
+     | st=statement; IDENT "and";
        IDENT "we"; IDENT "have" ; v=assume_vars  -> Hprop st::v
      | st=statement -> [Hprop st]
      ]]
@@ -152,38 +152,38 @@ GLOBAL: proof_instr;
   assume_clause:
     [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v
     |  h=assume_hyps -> h ]]
-  ; 
+  ;
   suff_vars:
     [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis ->
       [Hvar name],c
-     | name=hyp; ","; v=suff_vars -> 
+     | name=hyp; ","; v=suff_vars ->
 	 let (q,c) = v in ((Hvar name) :: q),c
-     | name=hyp; 
-       IDENT "such"; IDENT "that"; h=suff_hyps -> 
+     | name=hyp;
+       IDENT "such"; IDENT "that"; h=suff_hyps ->
 	 let (q,c) = h in ((Hvar name) :: q),c
      ]];
-  suff_hyps:  
-    [[ st=statement; IDENT "and"; h=suff_hyps  ->	 
+  suff_hyps:
+    [[ st=statement; IDENT "and"; h=suff_hyps  ->
 	 let (q,c) = h in (Hprop st::q),c
-     | st=statement; IDENT "and"; 
-       IDENT "to" ; IDENT "have" ; v=suff_vars -> 
+     | st=statement; IDENT "and";
+       IDENT "to" ; IDENT "have" ; v=suff_vars ->
 	 let (q,c) = v in (Hprop st::q),c
-     | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> 
+     | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis ->
 	 [Hprop st],c
      ]]
   ;
   suff_clause:
     [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v
     |  h=suff_hyps -> h ]]
-  ; 
+  ;
   let_vars:
     [[ name=hyp -> [Hvar name]
      | name=hyp; ","; v=let_vars -> (Hvar name) :: v
-     | name=hyp; IDENT "be"; 
+     | name=hyp; IDENT "be";
        IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h
      ]]
   ;
-  let_hyps:  
+  let_hyps:
     [[ st=statement; IDENT "and"; h=let_hyps  -> Hprop st::h
     |  st=statement; IDENT "and"; "let"; v=let_vars  -> Hprop st::v
     |  st=statement -> [Hprop st]
@@ -194,19 +194,19 @@ GLOBAL: proof_instr;
      | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h
      ]]
   ;
-  given_hyps:  
+  given_hyps:
     [[ st=statement; IDENT "and"; h=given_hyps  -> Hprop st::h
     |  st=statement; IDENT "and"; IDENT "given"; v=given_vars  -> Hprop st::v
     |  st=statement -> [Hprop st]
     ]];
   suppose_vars:
-    [[name=hyp -> [Hvar name] 
+    [[name=hyp -> [Hvar name]
      |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v
-     |name=hyp; OPT[IDENT "be"]; 
+     |name=hyp; OPT[IDENT "be"];
       IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h
      ]]
   ;
-  suppose_hyps:  
+  suppose_hyps:
     [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h
      | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have";
           v=suppose_vars -> Hprop st::v
@@ -223,17 +223,17 @@ GLOBAL: proof_instr;
        po=OPT[ "with"; p=LIST1 hyp SEP ","-> p  ] ; 
        ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> 
 	 Pcase (none_is_empty po,c,none_is_empty ho)
-     | "let" ; v=let_vars -> Plet v	 
+     | "let" ; v=let_vars -> Plet v
      | IDENT "take"; witnesses = LIST1 constr SEP ","  -> Ptake witnesses
      | IDENT "assume"; h=assume_clause -> Passume h
      | IDENT "given"; h=given_vars -> Pgiven h
-     | IDENT "define"; id=ident; args=LIST0 hyp; 
+     | IDENT "define"; id=ident; args=LIST0 hyp;
        "as"; body=constr -> Pdefine(id,args,body)
      | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ)
      | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ)
      ]]
   ;
-  emphasis : 
+  emphasis :
     [[ -> 0
      | "*" -> 1
      | "**" -> 2
@@ -249,4 +249,4 @@ GLOBAL: proof_instr;
   ;
 END;;
 
- 
+
diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4
index 316bf8e1..0e97b2a7 100644
--- a/parsing/g_ltac.ml4
+++ b/parsing/g_ltac.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(* $Id: g_ltac.ml4 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -35,7 +35,7 @@ GEXTEND Gram
   tactic_then_last:
     [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" ->
           Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta)
-      | -> [||] 
+      | -> [||]
     ] ]
   ;
   tactic_then_gen:
@@ -54,7 +54,7 @@ GEXTEND Gram
       [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, [||], ta1, [||])
       | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,  [||], ta1, [||])
       | ta0 = tactic_expr; ";"; "["; (first,tail) = tactic_then_gen; "]" ->
-	  match tail with 
+	  match tail with
 	  | Some (t,last) -> TacThen (ta0, Array.of_list first, t, last)
 	  | None -> TacThens (ta0,first) ]
     | "3" RIGHTA
@@ -94,7 +94,7 @@ GEXTEND Gram
           TacArg(MetaIdArg (loc,false,id))
       | IDENT "constr"; ":"; c = Constr.constr ->
           TacArg(ConstrMayEval(ConstrTerm c))
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> 
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern ->
 	  TacArg(IntroPattern ipat)
       | r = reference; la = LIST0 tactic_arg ->
           TacArg(TacCall (loc,r,la)) ]
@@ -107,7 +107,7 @@ GEXTEND Gram
     [ RIGHTA
       [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" ->
           TacFun (it,body)
-      | "let"; isrec = [IDENT "rec" -> true | -> false]; 
+      | "let"; isrec = [IDENT "rec" -> true | -> false];
           llc = LIST1 let_clause SEP "with"; "in";
           body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body)
       | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ]
@@ -153,7 +153,7 @@ GEXTEND Gram
     [ [ "match" -> false | "lazymatch" -> true ] ]
   ;
   input_fun:
-    [ [ "_" -> None 
+    [ [ "_" -> None
       | l = ident -> Some l ] ]
   ;
   let_clause:
@@ -172,11 +172,11 @@ GEXTEND Gram
       | pc = Constr.lconstr_pattern -> Term pc ] ]
   ;
   match_hyps:
-    [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp) 
-      | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) 
-      | na = name; ":="; mpv = match_pattern -> 
+    [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp)
+      | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt)
+      | na = name; ":="; mpv = match_pattern ->
 	  let t, ty =
-	    match mpv with 
+	    match mpv with
 	    | Term t -> (match t with
 	      | CCast (loc, t, CastConv (_, ty)) -> Term t, Some (Term ty)
 	      | _ -> mpv, None)
@@ -213,7 +213,7 @@ GEXTEND Gram
     [ [ ":=" -> false
       | "::=" -> true ] ]
   ;
-	
+
   (* Definitions for tactics *)
   tacdef_body:
     [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr ->
@@ -224,9 +224,9 @@ GEXTEND Gram
   tactic:
     [ [ tac = tactic_expr -> tac ] ]
   ;
-  Vernac_.command: 
+  Vernac_.command:
     [ [ IDENT "Ltac";
         l = LIST1 tacdef_body SEP "with" ->
-          VernacDeclareTacticDefinition (true, l) ] ]
+          VernacDeclareTacticDefinition (use_module_locality (), true, l) ] ]
   ;
   END
diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli
deleted file mode 100644
index 345d9575..00000000
--- a/parsing/g_minicoq.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: g_minicoq.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-(*i*)
-open Pp
-open Names
-open Term
-open Environ
-(*i*)
-
-val term : constr Grammar.Entry.e
-
-type command =
-  | Definition of identifier * constr option * constr
-  | Parameter of identifier * constr
-  | Variable of identifier * constr
-  | Inductive of 
-      (identifier * constr) list *
-      (identifier * constr * (identifier * constr) list) list
-  | Check of constr
-
-val command : command Grammar.Entry.e
-
-val pr_term : path_kind -> env -> constr -> std_ppcmds
diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli
index 09095959..bf3921bf 100644
--- a/parsing/g_natsyntax.mli
+++ b/parsing/g_natsyntax.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_natsyntax.mli 11087 2008-06-10 13:29:52Z letouzey $ i*)
+(*i $Id$ i*)
 
 (* Nice syntax for naturals. *)
 
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index 76225d77..6e7acd3f 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(*i $Id: g_prim.ml4 11525 2008-10-30 22:18:54Z amahboub $ i*)
+(*i $Id$ i*)
 
 open Pcoq
 open Names
@@ -34,10 +34,10 @@ let my_int_of_string loc s =
     Util.user_err_loc (loc,"",Pp.str "Cannot support a so large number.")
 
 GEXTEND Gram
-  GLOBAL: 
+  GLOBAL:
     bigint natural integer identref name ident var preident
-    fullyqualid qualid reference dirpath
-    ne_string string pattern_ident pattern_identref;
+    fullyqualid qualid reference dirpath ne_lstring
+    ne_string string pattern_ident pattern_identref by_notation smart_global;
   preident:
     [ [ s = IDENT -> s ] ]
   ;
@@ -45,7 +45,7 @@ GEXTEND Gram
     [ [ s = IDENT -> id_of_string s ] ]
   ;
   pattern_ident:
-    [ [ LEFTQMARK; id = ident -> id ] ]
+    [ [ s = LEFTQMARK; id = ident -> id ] ]
   ;
   pattern_identref:
     [ [ id = pattern_ident -> (loc, id) ] ]
@@ -71,7 +71,7 @@ GEXTEND Gram
   ;
   basequalid:
     [ [ id = ident; (l,id')=fields -> local_make_qualid (l@[id]) id'
-      | id = ident -> make_short_qualid id
+      | id = ident -> qualid_of_ident id
       ] ]
   ;
   name:
@@ -84,14 +84,24 @@ GEXTEND Gram
       | id = ident -> Ident (loc,id)
       ] ]
   ;
+  by_notation:
+    [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (loc,s,sc) ] ]
+  ;
+  smart_global:
+    [ [ c = reference -> Genarg.AN c
+      | ntn = by_notation -> Genarg.ByNotation ntn ] ]
+  ;
   qualid:
     [ [ qid = basequalid -> loc, qid ] ]
   ;
   ne_string:
-    [ [ s = STRING -> 
+    [ [ s = STRING ->
         if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string."); s
     ] ]
   ;
+  ne_lstring:
+    [ [ s = ne_string -> (loc,s) ] ]
+  ;
   dirpath:
     [ [ id = ident; l = LIST0 field ->
         make_dirpath (l@[id]) ] ]
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index 655bb267..39e577b8 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(* $Id: g_proofs.ml4 11784 2009-01-14 11:36:32Z herbelin $ *)
+(* $Id$ *)
 
 
 open Pcoq
@@ -53,7 +53,7 @@ GEXTEND Gram
       | IDENT "Save"; id = identref ->
 	  VernacEndProof (Proved (true,Some (id,None)))
       | IDENT "Defined" -> VernacEndProof (Proved (false,None))
-      |	IDENT "Defined"; id=identref -> 
+      |	IDENT "Defined"; id=identref ->
 	  VernacEndProof (Proved (false,Some (id,None)))
       | IDENT "Suspend" -> VernacSuspend
       | IDENT "Resume" -> VernacResume None
@@ -82,7 +82,7 @@ GEXTEND Gram
       | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis
       | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer ->
 	  VernacShow (ExplainProof l)
-      | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> 
+      | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer ->
 	  VernacShow (ExplainTree l)
       | IDENT "Go"; n = natural -> VernacGo (GoTo n)
       | IDENT "Go"; IDENT "top" -> VernacGo GoTop
@@ -90,16 +90,22 @@ GEXTEND Gram
       | IDENT "Go"; IDENT "next" -> VernacGo GoNext
       | IDENT "Guarded" -> VernacCheckGuard
 (* Hints for Auto and EAuto *)
-      | IDENT "Create"; IDENT "HintDb" ; 
+      | IDENT "Create"; IDENT "HintDb" ;
 	  id = IDENT ; b = [ "discriminated" -> true | -> false ] ->
-	    VernacCreateHintDb (use_locality (), id, b)
+	    VernacCreateHintDb (use_module_locality (), id, b)
       | IDENT "Hint"; local = obsolete_locality; h = hint;
-        dbnames = opt_hintbases ->
-	  VernacHints (enforce_locality_of local,dbnames, h)
-	  
+	  dbnames = opt_hintbases ->
+	  VernacHints (enforce_module_locality local,dbnames, h)
+
+(* Declare "Resolve" directly so as to be able to later extend with
+   "Resolve ->" and "Resolve <-" *)
+      | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural;
+	  dbnames = opt_hintbases ->
+	  VernacHints (use_module_locality (),dbnames,
+	    HintsResolve (List.map (fun x -> (n, true, x)) lc))
 
 (*This entry is not commented, only for debug*)
-      | IDENT "PrintConstr"; c = constr -> 
+      | IDENT "PrintConstr"; c = constr ->
 	  VernacExtend ("PrintConstr",
 	    [Genarg.in_gen Genarg.rawwit_constr c])
       ] ];
@@ -108,7 +114,7 @@ GEXTEND Gram
     [ [ IDENT "Local" -> true | -> false ] ]
   ;
   hint:
-    [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT [ n = natural -> n ] -> 
+    [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT natural ->
           HintsResolve (List.map (fun x -> (n, true, x)) lc)
       | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc
       | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true)
@@ -118,7 +124,7 @@ GEXTEND Gram
       | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>";
           tac = tactic ->
 	  HintsExtern (n,c,tac)
-      | IDENT "Destruct"; 
+      | IDENT "Destruct";
           id = ident; ":=";
           pri = natural;
           dloc = destruct_location;
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index ad093507..c845daf2 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(* $Id: g_tactic.ml4 12009 2009-03-23 22:55:37Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Pcoq
@@ -22,7 +22,7 @@ open Termops
 
 let all_with delta = make_red_flag [FBeta;FIota;FZeta;delta]
 
-let tactic_kw = [ "->"; "<-" ]
+let tactic_kw = [ "->"; "<-" ; "by" ]
 let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw
 
 (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
@@ -147,9 +147,29 @@ let induction_arg_of_constr (c,lbind as clbind) =
     with _ -> ElimOnConstr clbind
   else ElimOnConstr clbind
 
+let mkTacCase with_evar = function
+  | [([ElimOnConstr cl],None,(None,None))],None ->
+      TacCase (with_evar,cl)
+  (* Reinterpret numbers as a notation for terms *)
+  | [([(ElimOnAnonHyp n)],None,(None,None))],None ->
+      TacCase (with_evar,
+        (CPrim (dummy_loc, Numeral (Bigint.of_string (string_of_int n))),
+	 NoBindings))
+  (* Reinterpret ident as notations for variables in the context *)
+  (* because we don't know if they are quantified or not *)
+  | [([ElimOnIdent id],None,(None,None))],None ->
+      TacCase (with_evar,(CRef (Ident id),NoBindings))
+  | ic ->
+      if List.exists (fun (cl,a,b) ->
+           List.exists (function ElimOnAnonHyp _ -> true | _ -> false) cl)
+           (fst ic)
+      then
+	error "Use of numbers as direct arguments of 'case' is not supported.";
+      TacInductionDestruct (false,with_evar,ic)
+
 let rec mkCLambdaN_simple_loc loc bll c =
   match bll with
-  | ((loc1,_)::_ as idl,bk,t) :: bll -> 
+  | ((loc1,_)::_ as idl,bk,t) :: bll ->
       CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (join_loc loc1 loc) bll c)
   | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c
   | [] -> c
@@ -166,11 +186,39 @@ let map_int_or_var f = function
   | Rawterm.ArgArg x -> Rawterm.ArgArg (f x)
   | Rawterm.ArgVar _ as y -> y
 
+let all_concl_occs_clause = { onhyps=Some[]; concl_occs=all_occurrences_expr }
+
+let has_no_specified_occs cl =
+  (cl.onhyps = None || 
+    List.for_all (fun ((occs,_),_) -> occs = all_occurrences_expr)
+    (Option.get cl.onhyps))
+  && (cl.concl_occs = all_occurrences_expr 
+      || cl.concl_occs = no_occurrences_expr)
+
+let merge_occurrences loc cl = function
+  | None ->
+      if has_no_specified_occs cl then (None, cl)
+      else
+	user_err_loc (loc,"",str "Found an \"at\" clause without \"with\" clause.")
+  | Some (occs,p) ->
+      (Some p,
+      if occs = all_occurrences_expr then cl
+      else if cl = all_concl_occs_clause then { onhyps=Some[]; concl_occs=occs }
+      else match cl.onhyps with
+      | Some [(occs',id),l] when
+	  occs' = all_occurrences_expr && cl.concl_occs = no_occurrences_expr ->
+	  { cl with onhyps=Some[(occs,id),l] }
+      | _ ->
+	  if has_no_specified_occs cl then
+	    user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.")
+	  else
+	    user_err_loc (loc,"",str "Cannot use clause \"at\" twice."))
+
 (* Auxiliary grammar rules *)
 
 GEXTEND Gram
   GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
-  bindings red_expr int_or_var open_constr casted_open_constr 
+  bindings red_expr int_or_var open_constr casted_open_constr
   simple_intropattern;
 
   int_or_var:
@@ -183,7 +231,7 @@ GEXTEND Gram
   ;
   (* An identifier or a quotation meta-variable *)
   id_or_meta:
-    [ [ id = identref -> AI id 
+    [ [ id = identref -> AI id
 
       (* This is used in quotations *)
       | id = METAIDENT -> MetaId (loc,id) ] ]
@@ -215,19 +263,14 @@ GEXTEND Gram
       | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr ->
           (Some (occs,c1), c2) ] ]
   ;
-  smart_global:
-    [ [ c = global -> AN c
-      | s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> 
-	  ByNotation (loc,s,sc) ] ]
-  ;
   occs_nums:
     [ [ nl = LIST1 nat_or_var -> no_occurrences_expr_but nl
       | "-"; n = nat_or_var; nl = LIST0 int_or_var ->
 	  (* have used int_or_var instead of nat_or_var for compatibility *)
 	   all_occurrences_expr_but (List.map (map_int_or_var abs) (n::nl)) ] ]
-  ; 
+  ;
   occs:
-    [ [ "at"; occs = occs_nums -> occs | -> all_occurrences_expr_but [] ] ]
+    [ [ "at"; occs = occs_nums -> occs | -> all_occurrences_expr ] ]
   ;
   pattern_occ:
     [ [ c = constr; nl = occs -> (nl,c) ] ]
@@ -242,13 +285,13 @@ GEXTEND Gram
     [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> loc,IntroOrAndPattern tc
       | "()" -> loc,IntroOrAndPattern [[]]
       | "("; si = simple_intropattern; ")" -> loc,IntroOrAndPattern [[si]]
-      | "("; si = simple_intropattern; ","; 
-             tc = LIST1 simple_intropattern SEP "," ; ")" -> 
+      | "("; si = simple_intropattern; ",";
+             tc = LIST1 simple_intropattern SEP "," ; ")" ->
 	       loc,IntroOrAndPattern [si::tc]
-      | "("; si = simple_intropattern; "&"; 
-	     tc = LIST1 simple_intropattern SEP "&" ; ")" -> 
+      | "("; si = simple_intropattern; "&";
+	     tc = LIST1 simple_intropattern SEP "&" ; ")" ->
 	  (* (A & B & C) is translated into (A,(B,C)) *)
-	  let rec pairify = function 
+	  let rec pairify = function
 	    | ([]|[_]|[_;_]) as l -> IntroOrAndPattern [l]
 	    | t::q -> IntroOrAndPattern [[t;(loc_of_ne_list q,pairify q)]]
 	  in loc,pairify (si::tc) ] ]
@@ -256,10 +299,12 @@ GEXTEND Gram
   naming_intropattern:
     [ [ prefix = pattern_ident -> loc, IntroFresh prefix
       | "?" -> loc, IntroAnonymous
-      | id = ident -> loc, IntroIdentifier id ] ]
+      | id = ident -> loc, IntroIdentifier id
+      | "*" -> loc, IntroForthcoming true
+      | "**" -> loc, IntroForthcoming false ] ]
   ;
   intropattern_modifier:
-    [ [ IDENT "_eqn"; 
+    [ [ IDENT "_eqn";
         id = [ ":"; id = naming_intropattern -> id | -> loc, IntroAnonymous ]
         -> id ] ]
   ;
@@ -357,7 +402,7 @@ GEXTEND Gram
   clause_dft_concl:
     [ [ "in"; cl = in_clause -> cl
       | occs=occs -> {onhyps=Some[]; concl_occs=occs}
-      | -> {onhyps=Some[]; concl_occs=all_occurrences_expr} ] ]
+      | -> all_concl_occs_clause ] ]
   ;
   clause_dft_all:
     [ [ "in"; cl = in_clause -> cl
@@ -378,14 +423,14 @@ GEXTEND Gram
     [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat)
       | -> None ] ]
   ;
-  orient: 
-    [ [ "->" -> true 
+  orient:
+    [ [ "->" -> true
       | "<-" -> false
       | -> true ]]
   ;
   simple_binder:
     [ [ na=name -> ([na],Default Explicit,CHole (loc, None))
-      | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) 
+      | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c)
     ] ]
   ;
   fixdecl:
@@ -401,7 +446,7 @@ GEXTEND Gram
         (loc,id,bl,None,ty) ] ]
   ;
   bindings_with_parameters:
-    [ [ check_for_coloneq; "(";  id = ident; bl = LIST0 simple_binder; 
+    [ [ check_for_coloneq; "(";  id = ident; bl = LIST0 simple_binder;
         ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ]
   ;
   hintbases:
@@ -433,17 +478,17 @@ GEXTEND Gram
     [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ]
   ;
   by_tactic:
-    [ [ IDENT "by"; tac = tactic_expr LEVEL "3" -> TacComplete tac
+    [ [ "by"; tac = tactic_expr LEVEL "3" -> TacComplete tac
       | -> TacId [] ] ]
   ;
   opt_by_tactic:
-    [ [ IDENT "by"; tac = tactic_expr LEVEL "3" -> Some tac
+    [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac
     | -> None ] ]
   ;
-  rename : 
+  rename :
     [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ]
   ;
-  rewriter : 
+  rewriter :
     [ [ "!"; c = constr_with_bindings -> (RepeatPlus,c)
       | ["?"| LEFTQMARK]; c = constr_with_bindings -> (RepeatStar,c)
       | n = natural; "!"; c = constr_with_bindings -> (Precisely n,c)
@@ -452,12 +497,18 @@ GEXTEND Gram
       | c = constr_with_bindings -> (Precisely 1, c)
       ] ]
   ;
-  oriented_rewriter : 
+  oriented_rewriter :
     [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ]
-  ; 
+  ;
   induction_clause:
-    [ [ lc = LIST1 induction_arg; ipats = with_induction_names; 
-        el = OPT eliminator; cl = opt_clause -> (lc,el,ipats,cl) ] ]
+    [ [ lc = LIST1 induction_arg; ipats = with_induction_names;
+        el = OPT eliminator -> (lc,el,ipats) ] ]
+  ;
+  one_induction_clause:
+    [ [ ic = induction_clause; cl = opt_clause -> ([ic],cl) ] ]
+  ;
+  induction_clause_list:
+    [ [ ic = LIST1 induction_clause SEP ","; cl = opt_clause -> (ic,cl) ] ]
   ;
   move_location:
     [ [ IDENT "after"; id = id_or_meta -> MoveAfter id
@@ -466,9 +517,9 @@ GEXTEND Gram
       | "at"; IDENT "top" -> MoveToEnd false ] ]
   ;
   simple_tactic:
-    [ [ 
+    [ [
       (* Basic tactics *)
-        IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> 
+        IDENT "intros"; IDENT "until"; id = quantified_hypothesis ->
 	  TacIntrosUntil id
       | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl
       | IDENT "intro"; id = ident; hto = move_location ->
@@ -482,7 +533,7 @@ GEXTEND Gram
       | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c
       | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c
 
-      | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; 
+      | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ",";
           inhyp = in_hyp_as -> TacApply (true,false,cl,inhyp)
       | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP ",";
           inhyp = in_hyp_as -> TacApply (true,true,cl,inhyp)
@@ -495,8 +546,8 @@ GEXTEND Gram
       | IDENT "eelim"; cl = constr_with_bindings; el = OPT eliminator ->
           TacElim (true,cl,el)
       | IDENT "elimtype"; c = constr -> TacElimType c
-      | IDENT "case"; cl = constr_with_bindings -> TacCase (false,cl)
-      | IDENT "ecase"; cl = constr_with_bindings -> TacCase (true,cl)
+      | IDENT "case"; icl = induction_clause_list -> mkTacCase false icl
+      | IDENT "ecase"; icl = induction_clause_list -> mkTacCase true icl
       | IDENT "casetype"; c = constr -> TacCaseType c
       | "fix"; n = natural -> TacFix (None,n)
       | "fix"; id = ident; n = natural -> TacFix (Some id,n)
@@ -519,11 +570,11 @@ GEXTEND Gram
           TacLetTac (na,c,p,false)
 
       (* Begin compatibility *)
-      | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; 
-	  c = lconstr; ")" -> 
+      | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":=";
+	  c = lconstr; ")" ->
 	  TacAssert (None,Some (loc,IntroIdentifier id),c)
-      | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; 
-	  c = lconstr; ")"; tac=by_tactic -> 
+      | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
+	  c = lconstr; ")"; tac=by_tactic ->
 	  TacAssert (Some tac,Some (loc,IntroIdentifier id),c)
       (* End compatibility *)
 
@@ -538,8 +589,8 @@ GEXTEND Gram
       | IDENT "generalize"; c = constr; l = LIST1 constr ->
 	  let gen_everywhere c = ((all_occurrences_expr,c),Names.Anonymous) in
           TacGeneralize (List.map gen_everywhere (c::l))
-      | IDENT "generalize"; c = constr; lookup_at_as_coma; nl = occs; 
-          na = as_name; 
+      | IDENT "generalize"; c = constr; lookup_at_as_coma; nl = occs;
+          na = as_name;
           l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] ->
           TacGeneralize (((nl,c),na)::l)
       | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c
@@ -551,18 +602,18 @@ GEXTEND Gram
       (* Derived basic tactics *)
       | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
           TacSimpleInductionDestruct (true,h)
-      | IDENT "induction"; ic = induction_clause ->
-	  TacInductionDestruct (true,false,[ic])
-      | IDENT "einduction"; ic = induction_clause ->
-	  TacInductionDestruct(true,true,[ic])
+      | IDENT "induction"; ic = one_induction_clause ->
+	  TacInductionDestruct (true,false,ic)
+      | IDENT "einduction"; ic = one_induction_clause ->
+	  TacInductionDestruct(true,true,ic)
       | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
 	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
       | IDENT "simple"; IDENT "destruct"; h = quantified_hypothesis ->
           TacSimpleInductionDestruct (false,h)
-      | IDENT "destruct"; ic = induction_clause ->
-	  TacInductionDestruct(false,false,[ic])
-      | IDENT "edestruct";  ic = induction_clause ->
-	  TacInductionDestruct(false,true,[ic])
+      | IDENT "destruct"; icl = induction_clause_list ->
+	  TacInductionDestruct(false,false,icl)
+      | IDENT "edestruct";  icl = induction_clause_list ->
+	  TacInductionDestruct(false,true,icl)
       | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c
       | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c
       | IDENT "decompose"; "["; l = LIST1 smart_global; "]"; c = constr
@@ -600,10 +651,11 @@ GEXTEND Gram
       | IDENT "eleft";  bl = with_bindings -> TacLeft  (true,bl)
       | IDENT "right";  bl = with_bindings -> TacRight (false,bl)
       | IDENT "eright"; bl = with_bindings -> TacRight (true,bl)
-      | IDENT "split";  bl = with_bindings -> TacSplit (false,false,bl)
-      | IDENT "esplit"; bl = with_bindings -> TacSplit (true,false,bl)
-      | "exists";        bl = opt_bindings -> TacSplit (false,true,bl)
-      | IDENT "eexists"; bl = opt_bindings -> TacSplit (true,true,bl)
+      | IDENT "split";  bl = with_bindings -> TacSplit (false,false,[bl])
+      | IDENT "esplit"; bl = with_bindings -> TacSplit (true,false,[bl])
+      | "exists"; bll = LIST1 opt_bindings SEP "," -> TacSplit (false,true,bll)
+      | IDENT "eexists"; bll = LIST1 opt_bindings SEP "," ->
+	  TacSplit (true,true,bll)
       | IDENT "constructor"; n = num_or_meta; l = with_bindings ->
 	  TacConstructor (false,n,l)
       | IDENT "econstructor"; n = num_or_meta; l = with_bindings ->
@@ -614,33 +666,34 @@ GEXTEND Gram
       (* Equivalence relations *)
       | IDENT "reflexivity" -> TacReflexivity
       | IDENT "symmetry"; cl = clause_dft_concl -> TacSymmetry cl
-      | IDENT "transitivity"; c = constr -> TacTransitivity c
+      | IDENT "transitivity"; c = constr -> TacTransitivity (Some c)
+      | IDENT "etransitivity" -> TacTransitivity None
 
       (* Equality and inversion *)
-      | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; 
+      | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ",";
 	  cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (false,l,cl,t)
-      | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; 
+      | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ",";
 	  cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (true,l,cl,t)
       | IDENT "dependent"; k =
 	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
 	  | IDENT "inversion" -> FullInversion
 	  | IDENT "inversion_clear" -> FullInversionClear ];
-	  hyp = quantified_hypothesis; 
+	  hyp = quantified_hypothesis;
 	  ids = with_inversion_names; co = OPT ["with"; c = constr -> c] ->
 	    TacInversion (DepInversion (k,co,ids),hyp)
       | IDENT "simple"; IDENT "inversion";
 	  hyp = quantified_hypothesis; ids = with_inversion_names;
 	  cl = in_hyp_list ->
 	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
-      | IDENT "inversion"; 
+      | IDENT "inversion";
 	  hyp = quantified_hypothesis; ids = with_inversion_names;
 	  cl = in_hyp_list ->
 	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
-      | IDENT "inversion_clear"; 
-	  hyp = quantified_hypothesis; ids = with_inversion_names; 
+      | IDENT "inversion_clear";
+	  hyp = quantified_hypothesis; ids = with_inversion_names;
 	  cl = in_hyp_list ->
 	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
-      | IDENT "inversion"; hyp = quantified_hypothesis; 
+      | IDENT "inversion"; hyp = quantified_hypothesis;
 	  "using"; c = constr; cl = in_hyp_list ->
 	    TacInversion (InversionUsing (c,cl), hyp)
 
@@ -648,7 +701,8 @@ GEXTEND Gram
       | r = red_tactic; cl = clause_dft_concl -> TacReduce (r, cl)
       (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
       | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl ->
-	  TacChange (oc,c,cl)
+	  let p,cl = merge_occurrences loc cl oc in
+	  TacChange (p,c,cl)
     ] ]
   ;
 END;;
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index f727dfea..36dd0de1 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -9,20 +9,20 @@
 (*i camlp4deps: "parsing/grammar.cma" i*)
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(* $Id: g_vernac.ml4 13197 2010-06-25 22:36:17Z letouzey $ *)
+(* $Id$ *)
 
 
 open Pp
 open Util
 open Names
 open Topconstr
+open Extend
 open Vernacexpr
 open Pcoq
 open Decl_mode
 open Tactic
 open Decl_kinds
 open Genarg
-open Extend
 open Ppextend
 open Goptions
 
@@ -50,6 +50,7 @@ let decl_notation = Gram.Entry.create "vernac:decl_notation"
 let typeclass_context = Gram.Entry.create "vernac:typeclass_context"
 let record_field = Gram.Entry.create "vernac:record_field"
 let of_type_with_opt_coercion = Gram.Entry.create "vernac:of_type_with_opt_coercion"
+let instance_name = Gram.Entry.create "vernac:instance_name"
 
 let get_command_entry () =
   match Decl_mode.get_current_mode () with
@@ -58,34 +59,34 @@ let get_command_entry () =
     | Mode_none -> noedit_mode
 
 let default_command_entry =
-  Gram.Entry.of_parser "command_entry" 
+  Gram.Entry.of_parser "command_entry"
     (fun strm -> Gram.Entry.parse_token (get_command_entry ()) strm)
 
 let no_hook _ _ = ()
 GEXTEND Gram
   GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode;
   vernac: FIRST
-    [ [ IDENT "Time"; locality; v = vernac_aux -> 
-          check_locality (); VernacTime v 
-      | locality; v = vernac_aux -> 
-	  check_locality (); v ] ]
+    [ [ IDENT "Time"; v = vernac -> VernacTime v
+      | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v)
+      | IDENT "Fail"; v = vernac -> VernacFail v
+      | locality; v = vernac_aux -> v ] ]
   ;
   vernac_aux:
     (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
     (* "." is still in the stream and discard_to_dot works correctly         *)
-    [ [ g = gallina; "." -> g 
+    [ [ g = gallina; "." -> g
       | g = gallina_ext; "." -> g
-      | c = command; "." -> c 
+      | c = command; "." -> c
       | c = syntax; "." -> c
       | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
     ] ]
   ;
-  vernac_aux: LAST  
+  vernac_aux: LAST
     [ [ prfcom = default_command_entry -> prfcom ] ]
   ;
   locality:
-    [ [ IDENT "Local" -> locality_flag := Some true
-      | IDENT "Global" -> locality_flag := Some false
+    [ [ IDENT "Local" -> locality_flag := Some (loc,true)
+      | IDENT "Global" -> locality_flag := Some (loc,false)
       | -> locality_flag := None ] ]
   ;
   noedit_mode:
@@ -104,11 +105,11 @@ GEXTEND Gram
             VernacSolve(g,tac,use_dft_tac)) ] ]
   ;
   proof_mode:
-    [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ] 
+    [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ]
   ;
   proof_mode: LAST
     [ [ c=subgoal_command -> c (Some 1) ] ]
-  ; 
+  ;
   located_vernac:
     [ [ v = vernac -> loc, v ] ]
   ;
@@ -120,10 +121,11 @@ let test_plurial_form = function
    "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
   | _ -> ()
 
-let no_coercion loc (c,x) =
-  if c then Util.user_err_loc
-    (loc,"no_coercion",str"No coercion allowed here.");
-  x
+let test_plurial_form_types = function
+  | [([_],_)] ->
+      Flags.if_verbose warning
+   "Keywords Implicit Types expect more than one type"
+  | _ -> ()
 
 (* Gallina declarations *)
 GEXTEND Gram
@@ -133,27 +135,27 @@ GEXTEND Gram
   gallina:
       (* Definition, Theorem, Variable, Axiom, ... *)
     [ [ thm = thm_token; id = identref; bl = binders_let; ":"; c = lconstr;
-        l = LIST0 
+        l = LIST0
           [ "with"; id = identref; bl = binders_let; ":"; c = lconstr ->
-            (Some id,(bl,c)) ] ->
-          VernacStartTheoremProof (thm,(Some id,(bl,c))::l, false, no_hook)
-      | stre = assumption_token; nl = inline; bl = assum_list -> 
+            (Some id,(bl,c,None)) ] ->
+          VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false, no_hook)
+      | stre = assumption_token; nl = inline; bl = assum_list ->
 	  VernacAssumption (stre, nl, bl)
       | stre = assumptions_token; nl = inline; bl = assum_list ->
 	  test_plurial_form bl;
 	  VernacAssumption (stre, nl, bl)
-      | IDENT "Boxed";"Definition";id = identref; b = def_body -> 
+      | IDENT "Boxed";"Definition";id = identref; b = def_body ->
 	  VernacDefinition ((Global,true,Definition), id, b, no_hook)
-      | IDENT "Unboxed";"Definition";id = identref; b = def_body -> 
+      | IDENT "Unboxed";"Definition";id = identref; b = def_body ->
 	  VernacDefinition ((Global,false,Definition), id, b, no_hook)
-      | (f,d) = def_token; id = identref; b = def_body -> 
+      | (f,d) = def_token; id = identref; b = def_body ->
           VernacDefinition (d, id, b, f)
       (* Gallina inductive declarations *)
       | f = finite_token;
         indl = LIST1 inductive_definition SEP "with" ->
- 	  let (k,f) = f in
- 	  let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in
-          VernacInductive (f,indl)
+	  let (k,f) = f in
+	  let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in
+          VernacInductive (f,false,indl)
       | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
           VernacFixpoint (recs,true)
       | IDENT "Unboxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
@@ -163,21 +165,21 @@ GEXTEND Gram
       | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
           VernacCoFixpoint (corecs,false)
       | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l
-      | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; 
+      | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from";
 	l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) ] ]
   ;
   gallina_ext:
-    [ [ b = record_token; oc = opt_coercion; name = identref;
-        ps = binders_let; 
+    [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref;
+        ps = binders_let;
 	s = OPT [ ":"; s = lconstr -> s ];
 	cfs = [ ":="; l = constructor_list_or_record_decl -> l
 	  | -> RecordDecl (None, []) ] ->
 	  let (recf,indf) = b in
-	    VernacInductive (indf,[((oc,name),ps,s,recf,cfs),None])
+	    VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]])
   ] ]
   ;
   typeclass_context:
-    [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l 
+    [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l
     | -> [] ] ]
   ;
   thm_token:
@@ -190,14 +192,14 @@ GEXTEND Gram
       | IDENT "Property" -> Property ] ]
   ;
   def_token:
-    [ [ "Definition" -> 
+    [ [ "Definition" ->
 	no_hook, (Global, Flags.boxed_definitions(), Definition)
-      | IDENT "Let" -> 
+      | IDENT "Let" ->
 	no_hook, (Local, Flags.boxed_definitions(), Definition)
-      | IDENT "Example" -> 
+      | IDENT "Example" ->
 	no_hook, (Global, Flags.boxed_definitions(), Example)
       | IDENT "SubClass"  ->
-          Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ] 
+          Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ]
   ;
   assumption_token:
     [ [ "Hypothesis" -> (Local, Logical)
@@ -219,9 +221,12 @@ GEXTEND Gram
     [ [ "Inductive" -> (Inductive_kw,Finite)
       | "CoInductive" -> (CoInductive,CoFinite) ] ]
   ;
+  infer_token:
+    [ [ IDENT "Infer" -> true | -> false ] ]
+  ;
   record_token:
     [ [ IDENT "Record" -> (Record,BiFinite)
-      | IDENT "Structure" -> (Structure,BiFinite) 
+      | IDENT "Structure" -> (Structure,BiFinite)
       | IDENT "Class" -> (Class true,BiFinite) ] ]
   ;
   (* Simple definitions *)
@@ -239,25 +244,29 @@ GEXTEND Gram
     [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
       | -> None ] ]
   ;
+  one_decl_notation:
+    [ [ ntn = ne_lstring; ":="; c = constr;
+        scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ]
+  ;
   decl_notation:
-    [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; 
-         scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ]
-    ;
+    [ [ "where"; l = LIST1 one_decl_notation SEP IDENT "and" -> l
+    | -> [] ] ]
+  ;
   (* Inductives and records *)
   inductive_definition:
-    [ [ id = identref; oc = opt_coercion; indpar = binders_let; 
+    [ [ id = identref; oc = opt_coercion; indpar = binders_let;
         c = OPT [ ":"; c = lconstr -> c ];
         ":="; lc = constructor_list_or_record_decl; ntn = decl_notation ->
 	   (((oc,id),indpar,c,lc),ntn) ] ]
   ;
   constructor_list_or_record_decl:
     [ [ "|"; l = LIST1 constructor SEP "|" -> Constructors l
-      | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> 
+      | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" ->
 	  Constructors ((c id)::l)
       | id = identref ; c = constructor_type -> Constructors [ c id ]
-      | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> 
-	  RecordDecl (Some cstr,fs) 
-      | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) 
+      | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" ->
+	  RecordDecl (Some cstr,fs)
+      | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs)
       |  -> Constructors [] ] ]
   ;
 (*
@@ -271,36 +280,19 @@ GEXTEND Gram
   ;
   (* (co)-fixpoints *)
   rec_definition:
-    [ [ id = identref; 
+    [ [ id = identref;
 	bl = binders_let_fixannot;
-        ty = type_cstr; 
-	":="; def = lconstr; ntn = decl_notation ->
-	  let bl, annot = bl in
-          let names = names_of_local_assums bl in
-          let ni =
-            match fst annot with
-                Some (loc, id) ->
-                  (if List.exists (fun (_, id') -> Name id = id') names then
-		    Some (loc, id)
-		    else Util.user_err_loc
-                      (loc,"Fixpoint",
-                       str "No argument named " ++ Nameops.pr_id id ++ str"."))
-              | None -> 
-		  (* If there is only one argument, it is the recursive one, 
-		     otherwise, we search the recursive index later *)
-		  match names with
-		    | [(loc, Name na)] -> Some (loc, na)
-		    | _ -> None	  
-	  in 
-	  ((id,(ni,snd annot),bl,ty,def),ntn) ] ]
+        ty = type_cstr;
+	def = OPT [":="; def = lconstr -> def]; ntn = decl_notation ->
+	  let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ]
   ;
   corec_definition:
-    [ [ id = identref; bl = binders_let; ty = type_cstr; ":=";
-        def = lconstr; ntn = decl_notation ->
+    [ [ id = identref; bl = binders_let; ty = type_cstr; 
+        def = OPT [":="; def = lconstr -> def]; ntn = decl_notation ->
           ((id,bl,ty,def),ntn) ] ]
   ;
   type_cstr:
-    [ [ ":"; c=lconstr -> c 
+    [ [ ":"; c=lconstr -> c
       | -> CHole (loc, None) ] ]
   ;
   (* Inductive schemes *)
@@ -309,11 +301,11 @@ GEXTEND Gram
       | id = identref; ":="; kind = scheme_kind -> (Some id,kind) ] ]
   ;
   scheme_kind:
-    [ [ IDENT "Induction"; "for"; ind = global;
+    [ [ IDENT "Induction"; "for"; ind = smart_global;
           IDENT "Sort"; s = sort-> InductionScheme(true,ind,s)
-      | IDENT "Minimality"; "for"; ind = global;
+      | IDENT "Minimality"; "for"; ind = smart_global;
           IDENT "Sort"; s = sort-> InductionScheme(false,ind,s)
-      | IDENT "Equality"; "for" ; ind = global -> EqualityScheme(ind)  ] ]
+      | IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ]
   ;
   (* Various Binders *)
 (*
@@ -331,16 +323,22 @@ GEXTEND Gram
   record_field:
     [ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ]
   ;
+  record_binder_body:
+    [ [ l = binders_let; oc = of_type_with_opt_coercion;
+         t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t))
+      | l = binders_let; oc = of_type_with_opt_coercion;
+         t = lconstr; ":="; b = lconstr -> fun id ->
+	   (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
+      | l = binders_let; ":="; b = lconstr -> fun id ->
+         match b with
+	 | CCast(_,b, Rawterm.CastConv (_, t)) ->
+	     (false,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
+         | _ ->
+	     (false,DefExpr(id,mkCLambdaN loc l b,None)) ] ]
+  ;
   record_binder:
     [ [ id = name -> (false,AssumExpr(id,CHole (loc, None)))
-      | id = name; oc = of_type_with_opt_coercion; t = lconstr ->
-         (oc,AssumExpr (id,t))
-      | id = name; oc = of_type_with_opt_coercion;
-             t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t))
-      | id = name; ":="; b = lconstr ->
-         match b with
-             CCast(_,b, Rawterm.CastConv (_, t)) -> (false,DefExpr(id,b,Some t))
-           | _ -> (false,DefExpr(id,b,None)) ] ]
+      | id = name; f = record_binder_body -> f id ] ]
   ;
   assum_list:
     [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ]
@@ -349,12 +347,12 @@ GEXTEND Gram
     [ [ "("; a = simple_assum_coe; ")" -> a ] ]
   ;
   simple_assum_coe:
-    [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> 
+    [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr ->
         (oc,(idl,c)) ] ]
   ;
 
   constructor_type:
-    [[ l = binders_let; 
+    [[ l = binders_let;
       t= [ coe = of_type_with_opt_coercion; c = lconstr ->
 	            fun l id -> (coe,(id,mkCProdN loc l c))
             |  ->
@@ -380,18 +378,17 @@ GEXTEND Gram
 
   gallina_ext:
     [ [ (* Interactive module declaration *)
-        IDENT "Module"; export = export_token; id = identref; 
-	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
-	mexpr_o = OPT is_module_expr ->
-	  VernacDefineModule (export, id, bl, mty_o, mexpr_o)
-	  
-      | IDENT "Module"; "Type"; id = identref; 
-	bl = LIST0 module_binder; mty_o = OPT is_module_type ->
-	  VernacDeclareModuleType (id, bl, mty_o)
-	  
-      | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; 
-	bl = LIST0 module_binder; ":"; mty = module_type ->
-	  VernacDeclareModule (export, id, bl, (mty,true))
+        IDENT "Module"; export = export_token; id = identref;
+	bl = LIST0 module_binder; sign = of_module_type;
+	body = is_module_expr ->
+	  VernacDefineModule (export, id, bl, sign, body)
+      | IDENT "Module"; "Type"; id = identref;
+	bl = LIST0 module_binder; sign = check_module_types;
+	body = is_module_type ->
+	  VernacDeclareModuleType (id, bl, sign, body)
+      | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref;
+	bl = LIST0 module_binder; ":"; mty = module_type_inl ->
+	  VernacDeclareModule (export, id, bl, mty)
       (* Section beginning *)
       | IDENT "Section"; id = identref -> VernacBeginSection id
       | IDENT "Chapter"; id = identref -> VernacBeginSection id
@@ -402,43 +399,66 @@ GEXTEND Gram
       (* Requiring an already compiled module *)
       | IDENT "Require"; export = export_token; qidl = LIST1 global ->
           VernacRequire (export, None, qidl)
-      | IDENT "Require"; export = export_token; filename = ne_string -> 
+      | IDENT "Require"; export = export_token; filename = ne_string ->
 	  VernacRequireFrom (export, None, filename)
       | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
-      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) 
-      | IDENT "Include"; expr = module_expr -> VernacInclude(CIME(expr))
-      | IDENT "Include"; "Type"; expr = module_type -> VernacInclude(CIMTE(expr)) ] ]
+      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl)
+      | IDENT "Include"; e = module_expr_inl; l = LIST0 ext_module_expr ->
+	  VernacInclude(e::l)
+      | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type ->
+	  warning "Include Type is deprecated; use Include instead";
+          VernacInclude(e::l) ] ]
   ;
   export_token:
     [ [ IDENT "Import" -> Some false
       | IDENT "Export" -> Some true
       |  -> None ] ]
   ;
+  ext_module_type:
+    [ [ "<+"; mty = module_type_inl -> mty ] ]
+  ;
+  ext_module_expr:
+    [ [ "<+"; mexpr = module_expr_inl -> mexpr ] ]
+  ;
+  check_module_type:
+    [ [ "<:"; mty = module_type_inl -> mty ] ]
+  ;
+  check_module_types:
+    [ [ mtys = LIST0 check_module_type -> mtys ] ]
+  ;
   of_module_type:
-    [ [ ":"; mty = module_type -> (mty, true) 
-      | "<:"; mty = module_type -> (mty, false) ] ]
+    [ [ ":"; mty = module_type_inl -> Enforce mty
+      | mtys = check_module_types -> Check mtys ] ]
   ;
   is_module_type:
-    [ [ ":="; mty = module_type -> mty ] ]
+    [ [ ":="; mty = module_type_inl ; l = LIST0 ext_module_type -> (mty::l)
+      | -> [] ] ]
   ;
   is_module_expr:
-    [ [ ":="; mexpr = module_expr -> mexpr ] ]
+    [ [ ":="; mexpr = module_expr_inl; l = LIST0 ext_module_expr -> (mexpr::l)
+      | -> [] ] ]
+  ;
+  module_expr_inl:
+    [ [ "!"; me = module_expr -> (me,false)
+      | me = module_expr -> (me,true) ] ]
+  ;
+  module_type_inl:
+    [ [ "!"; me = module_type -> (me,false)
+      | me = module_type -> (me,true) ] ]
   ;
-
   (* Module binder  *)
   module_binder:
     [ [ "("; export = export_token; idl = LIST1 identref; ":";
-         mty = module_type; ")" -> (export,idl,mty) ] ]
+         mty = module_type_inl; ")" -> (export,idl,mty) ] ]
   ;
-
   (* Module expressions *)
   module_expr:
     [ [ me = module_expr_atom -> me
-      | me1 = module_expr; me2 = module_expr_atom -> CMEapply (me1,me2)
+      | me1 = module_expr; me2 = module_expr_atom -> CMapply (me1,me2)
       ] ]
   ;
   module_expr_atom:
-    [ [ qid = qualid -> CMEident qid | "("; me = module_expr; ")" -> me ] ]
+    [ [ qid = qualid -> CMident qid | "("; me = module_expr; ")" -> me ] ]
   ;
   with_declaration:
     [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr ->
@@ -447,94 +467,106 @@ GEXTEND Gram
 	  CWith_Module (fqid,qid)
       ] ]
   ;
-  module_type_atom:
-    [ [ qid = qualid -> CMTEident qid
-      | mty = module_type_atom; me = module_expr_atom -> CMTEapply (mty,me) 
-      ] ]
-  ;
   module_type:
-    [ [ mty = module_type_atom -> mty
-      | mty = module_type; "with"; decl = with_declaration -> CMTEwith (mty,decl)
+    [ [ qid = qualid -> CMident qid
+      | "("; mt = module_type; ")" -> mt
+      | mty = module_type; me = module_expr_atom -> CMapply (mty,me)
+      | mty = module_type; "with"; decl = with_declaration -> CMwith (mty,decl)
       ] ]
   ;
 END
 
-(* Extensions: implicits, coercions, etc. *)   
+(* Extensions: implicits, coercions, etc. *)
 GEXTEND Gram
-  GLOBAL: gallina_ext;
+  GLOBAL: gallina_ext instance_name;
 
   gallina_ext:
     [ [ (* Transparent and Opaque *)
-        IDENT "Transparent"; l = LIST1 global ->
+        IDENT "Transparent"; l = LIST1 smart_global ->
           VernacSetOpacity (use_non_locality (),[Conv_oracle.transparent,l])
-      | IDENT "Opaque"; l = LIST1 global ->
+      | IDENT "Opaque"; l = LIST1 smart_global ->
           VernacSetOpacity (use_non_locality (),[Conv_oracle.Opaque, l])
       | IDENT "Strategy"; l =
-          LIST1 [ lev=strategy_level; "["; q=LIST1 global; "]" -> (lev,q)] ->
+          LIST1 [ lev=strategy_level; "["; q=LIST1 smart_global; "]" -> (lev,q)] ->
             VernacSetOpacity (use_locality (),l)
       (* Canonical structure *)
       | IDENT "Canonical"; IDENT "Structure"; qid = global ->
-	  VernacCanonical qid
-      | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body ->
-          let s = coerce_global_to_id qid in
-	  VernacDefinition 
+	  VernacCanonical (AN qid)
+      | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation ->
+	  VernacCanonical (ByNotation ntn)
+      | IDENT "Canonical"; IDENT "Structure"; qid = global;
+          d = def_body ->
+          let s = coerce_reference_to_id qid in
+	  VernacDefinition
 	    ((Global,false,CanonicalStructure),(dummy_loc,s),d,
 	     (fun _ -> Recordops.declare_canonical_structure))
 
       (* Coercions *)
       | IDENT "Coercion"; qid = global; d = def_body ->
-          let s = coerce_global_to_id qid in
+          let s = coerce_reference_to_id qid in
 	  VernacDefinition ((use_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
       | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
-           let s = coerce_global_to_id qid in
-	  VernacDefinition ((enforce_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+           let s = coerce_reference_to_id qid in
+	  VernacDefinition ((enforce_locality_exp true,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
       | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref;
-         ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> 
-	   VernacIdentityCoercion (enforce_locality_exp (), f, s, t)
+         ":"; s = class_rawexpr; ">->"; t = class_rawexpr ->
+	   VernacIdentityCoercion (enforce_locality_exp true, f, s, t)
       | IDENT "Identity"; IDENT "Coercion"; f = identref; ":";
-         s = class_rawexpr; ">->"; t = class_rawexpr -> 
+         s = class_rawexpr; ">->"; t = class_rawexpr ->
 	   VernacIdentityCoercion (use_locality_exp (), f, s, t)
       | IDENT "Coercion"; IDENT "Local"; qid = global; ":";
-	 s = class_rawexpr; ">->"; t = class_rawexpr -> 
-	  VernacCoercion (enforce_locality_exp (), qid, s, t)
+	 s = class_rawexpr; ">->"; t = class_rawexpr ->
+	  VernacCoercion (enforce_locality_exp true, AN qid, s, t)
+      | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":";
+	 s = class_rawexpr; ">->"; t = class_rawexpr ->
+	  VernacCoercion (enforce_locality_exp true, ByNotation ntn, s, t)
       | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
          t = class_rawexpr ->
-	  VernacCoercion (use_locality_exp (), qid, s, t)
-	     
-      | IDENT "Context"; c = binders_let -> 
+	  VernacCoercion (use_locality_exp (), AN qid, s, t)
+      | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->";
+         t = class_rawexpr ->
+	  VernacCoercion (use_locality_exp (), ByNotation ntn, s, t)
+
+      | IDENT "Context"; c = binders_let ->
 	  VernacContext c
-	    
-      | IDENT "Instance"; name = identref; sup = OPT binders_let; ":";
+
+      | IDENT "Instance"; namesup = instance_name; ":";
 	 expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200";
-	 pri = OPT [ "|"; i = natural -> i ] ; 
-	 props = [ ":="; "{"; r = record_declaration; "}" -> r | 
+	 pri = OPT [ "|"; i = natural -> i ] ;
+	 props = [ ":="; "{"; r = record_declaration; "}" -> r |
 	     ":="; c = lconstr -> c | -> CRecord (loc, None, []) ] ->
-	   let sup =
-	     match sup with
-		 None -> []
-	       | Some l -> l
-	   in
-	   let n = 
-	     let (loc, id) = name in 
-	       (loc, Name id)
-	   in
-	     VernacInstance (not (use_non_locality ()), sup, (n, expl, t), props, pri)
-
-      | IDENT "Existing"; IDENT "Instance"; is = identref -> VernacDeclareInstance is
+	   VernacInstance (false, not (use_non_locality ()),
+			   snd namesup, (fst namesup, expl, t), props, pri)
+
+      | IDENT "Existing"; IDENT "Instance"; is = global -> 
+	  VernacDeclareInstance (not (use_section_locality ()), is)
+
+      | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is
 
       (* Implicit *)
-      | IDENT "Implicit"; IDENT "Arguments"; qid = global; 
-	   pos = OPT [ "["; l = LIST0 implicit_name; "]" -> 
+      | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global;
+	   pos = OPT [ "["; l = LIST0 implicit_name; "]" ->
 	     List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] ->
 	   VernacDeclareImplicits (use_section_locality (),qid,pos)
 
-      | IDENT "Implicit"; ["Type" | IDENT "Types"];
-	   idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ]
+      | IDENT "Implicit"; "Type"; bl = reserv_list ->
+	   VernacReserve bl
+
+      | IDENT "Implicit"; IDENT "Types"; bl = reserv_list ->
+          test_plurial_form_types bl;
+           VernacReserve bl
+
+      | IDENT "Generalizable"; 
+	   gen = [IDENT "All"; IDENT "Variables" -> Some []
+	     | IDENT "No"; IDENT "Variables" -> None
+	     | ["Variable" | IDENT "Variables"];
+		  idl = LIST1 identref -> Some idl ] ->
+	     VernacGeneralizable (use_non_locality (), gen) ] ]
   ;
   implicit_name:
     [ [ "!"; id = ident -> (id, false, true)
     | id = ident -> (id,false,false)
-    | "["; "!"; id = ident; "]" -> (id,true,true) 
+    | "["; "!"; id = ident; "]" -> (id,true,true)
     | "["; id = ident; "]" -> (id,true, false) ] ]
   ;
   strategy_level:
@@ -544,6 +576,22 @@ GEXTEND Gram
       | "-"; n=INT -> Conv_oracle.Level (- int_of_string n)
       | IDENT "transparent" -> Conv_oracle.transparent ] ]
   ;
+  instance_name:
+    [ [ name = identref; sup = OPT binders_let ->
+	  (let (loc,id) = name in (loc, Name id)),
+          (Option.default [] sup)
+      | -> (loc, Anonymous), []  ] ]
+  ;
+  reserv_list:
+    [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ]
+  ;
+  reserv_tuple:
+    [ [ "("; a = simple_reserv; ")" -> a ] ]
+  ;
+  simple_reserv:
+    [ [ idl = LIST1 identref; ":"; c = lconstr -> (idl,c) ] ]
+  ;
+
 END
 
 GEXTEND Gram
@@ -552,6 +600,14 @@ GEXTEND Gram
   command:
     [ [ 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 = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200";
+	 pri = OPT [ "|"; i = natural -> i ] ->
+	   VernacInstance (true, not (use_non_locality ()),
+			   snd namesup, (fst namesup, expl, t),
+			   CRecord (loc, None, []), pri)
+
       (* System directory *)
       | IDENT "Pwd" -> VernacChdir None
       | IDENT "Cd" -> VernacChdir None
@@ -559,14 +615,13 @@ GEXTEND Gram
 
       (* Toplevel control *)
       | IDENT "Drop" -> VernacToplevelControl Drop
-      | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop
       | IDENT "Quit" -> VernacToplevelControl Quit
 
       | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ];
 	s = [ s = ne_string -> s | s = IDENT -> s ] ->
 	  VernacLoad (verbosely, s)
       | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
-	  VernacDeclareMLModule l
+	  VernacDeclareMLModule (use_locality (), l)
 
       | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string ->
 	  error "This command is deprecated, use Print Universes"
@@ -576,7 +631,7 @@ GEXTEND Gram
       (* Managing load paths *)
       | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath ->
 	  VernacAddLoadPath (false, dir, alias)
-      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; 
+      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string;
 	  alias = as_dirpath -> VernacAddLoadPath (true, dir, alias)
       | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string ->
 	  VernacRemoveLoadPath dir
@@ -594,24 +649,24 @@ GEXTEND Gram
 
       (* Printing (careful factorization of entries) *)
       | IDENT "Print"; p = printable -> VernacPrint p
-      | IDENT "Print"; qid = global -> VernacPrint (PrintName qid)
-      | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> 
+      | IDENT "Print"; qid = smart_global -> VernacPrint (PrintName qid)
+      | IDENT "Print"; IDENT "Module"; "Type"; qid = global ->
 	  VernacPrint (PrintModuleType qid)
-      | IDENT "Print"; IDENT "Module"; qid = global -> 
+      | IDENT "Print"; IDENT "Module"; qid = global ->
 	  VernacPrint (PrintModule qid)
       | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
-      | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid)
+      | IDENT "About"; qid = smart_global -> VernacPrint (PrintAbout qid)
 
       (* Searching the environment *)
-      | IDENT "Search"; qid = global; l = in_or_out_modules -> 
-	  VernacSearch (SearchHead qid, l)
+      | IDENT "Search"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchHead c, l)
       | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
 	  VernacSearch (SearchPattern c, l)
       | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
 	  VernacSearch (SearchRewrite c, l)
-      | IDENT "SearchAbout"; 
+      | IDENT "SearchAbout";
 	  sl = [ "[";
-	         l = LIST1 [ 
+	         l = LIST1 [
 		   b = positive_search_mark; s = ne_string; sc = OPT scope
 		   -> b, SearchString (s,sc)
 		 | b = positive_search_mark; p = constr_pattern
@@ -619,7 +674,7 @@ GEXTEND Gram
 		 ]; "]" -> l
    	       | p = constr_pattern -> [true,SearchSubPattern p]
    	       | s = ne_string; sc = OPT scope -> [true,SearchString (s,sc)] ];
-	  l = in_or_out_modules -> 
+	  l = in_or_out_modules ->
 	  VernacSearch (SearchAbout sl, l)
 
       | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
@@ -629,23 +684,23 @@ GEXTEND Gram
 
       (* Pour intervenir sur les tables de param�ètres *)
       | "Set"; table = option_table; v = option_value ->
-  	  VernacSetOption (table,v)
+  	  VernacSetOption (use_locality_full(),table,v)
       | "Set"; table = option_table ->
-  	  VernacSetOption (table,BoolValue true)
+  	  VernacSetOption (use_locality_full(),table,BoolValue true)
       | IDENT "Unset"; table = option_table ->
-  	  VernacUnsetOption table
+  	  VernacUnsetOption (use_locality_full(),table)
 
       | IDENT "Print"; IDENT "Table"; table = option_table ->
 	  VernacPrintOption table
 
       | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
-        -> VernacAddOption (SecondaryTable (table,field), v)
+        -> VernacAddOption ([table;field], v)
       (* Un value global ci-dessous va �être cach�é par un field au dessus! *)
       (* En fait, on donne priorit�é aux tables secondaires *)
       (* Pas de syntaxe pour les tables tertiaires pour cause de conflit *)
       (* (mais de toutes fa�çons, pas utilis�ées) *)
       | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
-          VernacAddOption (PrimaryTable table, v)
+          VernacAddOption ([table], v)
 
       | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value
         -> VernacMemOption (table, v)
@@ -653,9 +708,9 @@ GEXTEND Gram
           VernacPrintOption table
 
       | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
-        -> VernacRemoveOption (SecondaryTable (table,field), v)
+        -> VernacRemoveOption ([table;field], v)
       | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
-	  VernacRemoveOption (PrimaryTable table, v) 
+	  VernacRemoveOption ([table], v)
 
       | IDENT "proof" -> VernacDeclProof
       | "return" -> VernacReturn ]]
@@ -669,14 +724,14 @@ GEXTEND Gram
 	  fun g -> VernacCheckMayEval (None, g, c) ] ]
   ;
   printable:
-    [ [ IDENT "Term"; qid = global -> PrintName qid
+    [ [ IDENT "Term"; qid = smart_global -> PrintName qid
       | IDENT "All" -> PrintFullContext
       | IDENT "Section"; s = global -> PrintSectionContext s
       | IDENT "Grammar"; ent = IDENT ->
           (* This should be in "syntax" section but is here for factorization*)
 	  PrintGrammar ent
       | IDENT "LoadPath"; dir = OPT dirpath -> PrintLoadPath dir
-      | IDENT "Modules" -> 
+      | IDENT "Modules" ->
           error "Print Modules is obsolete; use Print Libraries instead"
       | IDENT "Libraries" -> PrintModules
 
@@ -685,40 +740,37 @@ GEXTEND Gram
       | IDENT "Graph" -> PrintGraph
       | IDENT "Classes" ->  PrintClasses
       | IDENT "TypeClasses" -> PrintTypeClasses
-      | IDENT "Instances"; qid = global -> PrintInstances qid
+      | 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)
       | IDENT "Canonical"; IDENT "Projections" -> PrintCanonicalConversions
       | IDENT "Tables" -> PrintTables
-(* Obsolete: was used for cooking V6.3 recipes ??
-      | IDENT "Proof"; qid = global -> PrintOpaqueName qid
-*)
       | IDENT "Hint" -> PrintHintGoal
-      | IDENT "Hint"; qid = global -> PrintHint qid
+      | 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 IDENT -> PrintVisibility s
-      | IDENT "Implicit"; qid = global -> PrintImplicit qid
+      | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid
       | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses fopt
-      | IDENT "Assumptions"; qid = global -> PrintAssumptions (false, qid)
-      | IDENT "Opaque"; IDENT "Dependencies"; qid = global -> PrintAssumptions (true, qid) ] ]
+      | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, qid)
+      | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, qid) ] ]
   ;
   class_rawexpr:
     [ [ IDENT "Funclass" -> FunClass
       | IDENT "Sortclass" -> SortClass
-      | qid = global -> RefClass qid ] ]
+      | qid = smart_global -> RefClass qid ] ]
   ;
   locatable:
-    [ [ qid = global -> LocateTerm qid
+    [ [ qid = smart_global -> LocateTerm qid
       | IDENT "File"; f = ne_string -> LocateFile f
       | IDENT "Library"; qid = global -> LocateLibrary qid
       | IDENT "Module"; qid = global -> LocateModule qid
-      | s = ne_string -> LocateNotation s ] ]
+      | IDENT "Ltac"; qid = global -> LocateTactic qid ] ]
   ;
   option_value:
     [ [ n  = integer   -> IntValue n
@@ -729,9 +781,7 @@ GEXTEND Gram
       | s  = STRING   -> StringRefValue s ] ]
   ;
   option_table:
-    [ [ f1 = IDENT; f2 = IDENT; f3 = IDENT -> TertiaryTable (f1,f2,f3)
-      | f1 = IDENT; f2 = IDENT -> SecondaryTable (f1,f2)
-      | f1 = IDENT -> PrimaryTable f1 ] ]
+    [ [ fl = LIST1 IDENT -> fl ]]
   ;
   as_dirpath:
     [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
@@ -756,7 +806,7 @@ END;
 
 GEXTEND Gram
   command:
-    [ [ 
+    [ [
 (* State management *)
         IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
       | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s
@@ -770,15 +820,21 @@ GEXTEND Gram
       | IDENT "Back" -> VernacBack 1
       | IDENT "Back"; n = natural -> VernacBack n
       | IDENT "BackTo"; n = natural -> VernacBackTo n
-      | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> 
+      | IDENT "Backtrack"; n = natural ; m = natural ; p = natural ->
 	  VernacBacktrack (n,m,p)
 
 (* Tactic Debugger *)
-      |	IDENT "Debug"; IDENT "On" -> 
-          VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue true)
+      |	IDENT "Debug"; IDENT "On" ->
+          VernacSetOption (None,["Ltac";"Debug"], BoolValue true)
 
       |	IDENT "Debug"; IDENT "Off" ->
-          VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue false)
+          VernacSetOption (None,["Ltac";"Debug"], BoolValue false)
+
+(* registration of a custom reduction *)
+
+      | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":=";
+         r = Tactic.red_expr ->
+	   VernacDeclareReduction (use_locality(),s,r)
 
  ] ];
     END
@@ -790,47 +846,54 @@ GEXTEND Gram
   GLOBAL: syntax;
 
   syntax:
-   [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> 
-         VernacOpenCloseScope (enforce_locality_of local,true,sc)
+   [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT ->
+         VernacOpenCloseScope (enforce_section_locality local,true,sc)
 
-     | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> 
-         VernacOpenCloseScope (enforce_locality_of local,false,sc)
+     | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT ->
+         VernacOpenCloseScope (enforce_section_locality local,false,sc)
 
      | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
 	 VernacDelimiters (sc,key)
 
-     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; 
+     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with";
        refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
 
-     | IDENT "Arguments"; IDENT "Scope"; qid = global;
-       "["; scl = LIST0 opt_scope; "]" -> 
-	 VernacArgumentsScope (use_non_locality (),qid,scl)
+     | IDENT "Arguments"; IDENT "Scope"; qid = smart_global;
+       "["; scl = LIST0 opt_scope; "]" ->
+	 VernacArgumentsScope (use_section_locality (),qid,scl)
 
      | IDENT "Infix"; local = obsolete_locality;
-	 op = ne_string; ":="; p = global; 
+	 op = ne_lstring; ":="; p = constr;
          modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
 	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-         VernacInfix (enforce_locality_of local,(op,modl),p,sc)
-     | IDENT "Notation"; local = obsolete_locality; id = identref; 
+         VernacInfix (enforce_module_locality local,(op,modl),p,sc)
+     | IDENT "Notation"; local = obsolete_locality; id = identref;
 	 idl = LIST0 ident; ":="; c = constr;
 	 b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
-           VernacSyntacticDefinition (id,(idl,c),enforce_locality_of local,b)
-     | IDENT "Notation"; local = obsolete_locality; s = ne_string; ":="; 
+           VernacSyntacticDefinition
+	     (id,(idl,c),enforce_module_locality local,b)
+     | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":=";
 	 c = constr;
          modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
 	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-           VernacNotation (enforce_locality_of local,c,(s,modl),sc)
+           VernacNotation (enforce_module_locality local,c,(s,modl),sc)
 
-     | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; 
+     | IDENT "Tactic"; IDENT "Notation"; n = tactic_level;
 	 pil = LIST1 production_item; ":="; t = Tactic.tactic
          -> VernacTacticNotation (n,pil,t)
 
-     | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; 
-	 s = ne_string; 
+     | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring;
+	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] ->
+	   Metasyntax.check_infix_modifiers l;
+	   let (loc,s) = s in
+	   VernacSyntaxExtension (use_module_locality(),((loc,"x '"^s^"' y"),l))
+
+     | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality;
+	 s = ne_lstring;
 	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]
-	 -> VernacSyntaxExtension (enforce_locality_of local,(s,l))
+	 -> VernacSyntaxExtension (enforce_module_locality local,(s,l))
 
-     (* "Print" "Grammar" should be here but is in "command" entry in order 
+     (* "Print" "Grammar" should be here but is in "command" entry in order
         to factorize with other "Print"-based vernac entries *)
   ] ]
   ;
@@ -846,7 +909,7 @@ GEXTEND Gram
   ;
   syntax_modifier:
     [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
-      | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; 
+      | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at";
         lev = level -> SetItemLevel (x::l,lev)
       | "at"; IDENT "level"; n = natural -> SetLevel n
       | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
@@ -857,7 +920,7 @@ GEXTEND Gram
       | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ]
   ;
   syntax_extension_type:
-    [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference
+    [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference
       | IDENT "bigint" -> ETBigint
     ] ]
   ;
@@ -865,8 +928,9 @@ GEXTEND Gram
     [ [ "_" -> None | sc = IDENT -> Some sc ] ]
   ;
   production_item:
-    [ [ s = ne_string -> VTerm s
-      | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> 
-	  VNonTerm (loc,nt,po) ] ]
+    [ [ 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/g_xml.ml4 b/parsing/g_xml.ml4
index 72d5d275..0f702904 100644
--- a/parsing/g_xml.ml4
+++ b/parsing/g_xml.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo" i*)
 
-(* $Id: g_xml.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -30,7 +30,7 @@ type xml = XmlTag of loc * string * attribute list * xml list
 
 let check_tags loc otag ctag =
   if otag <> ctag then
-    user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ 
+    user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++
       str "does not match open xml tag " ++ str otag ++ str ".")
 
 let xml_eoi = (Gram.Entry.create "xml_eoi" : xml Gram.Entry.e)
@@ -57,6 +57,9 @@ END
 
 (* Errors *)
 
+let error_expect_two_arguments loc =
+  user_err_loc (loc,"",str "wrong number of arguments (expect two).")
+
 let error_expect_one_argument loc =
   user_err_loc (loc,"",str "wrong number of arguments (expect one).")
 
@@ -68,12 +71,8 @@ let error_expect_no_argument loc =
 let nmtoken (loc,a) =
   try int_of_string a
   with Failure _ -> user_err_loc (loc,"",str "nmtoken expected.")
-  
-let interp_xml_attr_qualid = function
-  | "uri", s -> qualid_of_string s
-  | _ -> error "Ill-formed xml attribute"
 
-let get_xml_attr s al = 
+let get_xml_attr s al =
   try List.assoc s al
   with Not_found -> error ("No attribute "^s)
 
@@ -144,7 +143,7 @@ let compute_inductive_nargs ind =
 let rec interp_xml_constr = function
   | XmlTag (loc,"REL",al,[]) ->
       RVar (loc, get_xml_ident al)
-  | XmlTag (loc,"VAR",al,[]) -> 
+  | XmlTag (loc,"VAR",al,[]) ->
       error "XML parser: unable to interp free variables"
   | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) ->
       let body,decls = list_sep_last xl in
@@ -201,7 +200,7 @@ let rec interp_xml_constr = function
 
 and interp_xml_tag s = function
   | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl)
-  | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", 
+  | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "",
     str "Expect tag " ++ str s ++ str " but find " ++ str s ++ str ".")
 
 and interp_xml_constr_alias s x =
@@ -232,17 +231,17 @@ and interp_xml_recursionOrder x =
   let (loc, al, l) = interp_xml_tag "RecursionOrder" x in
   let (locs, s) = get_xml_attr "type" al in
     match s with
-	"Structural" -> 
+	"Structural" ->
 	  (match l with [] -> RStructRec
 	     | _ -> error_expect_no_argument loc)
-      | "WellFounded" -> 
+      | "WellFounded" ->
 	  (match l with
 	       [c] -> RWfRec (interp_xml_type c)
 	     | _ -> error_expect_one_argument loc)
-      | "Measure" -> 
+      | "Measure" ->
 	  (match l with
-	       [c] -> RMeasureRec (interp_xml_type c)
-	     | _ -> error_expect_one_argument loc)
+	       [m;r] -> RMeasureRec (interp_xml_type m, Some (interp_xml_type r))
+	     | _ -> error_expect_two_arguments loc)
       | _ ->
           user_err_loc (locs,"",str "Invalid recursion order.")
 
@@ -262,7 +261,7 @@ and interp_xml_CoFixFunction x =
   match interp_xml_tag "CoFixFunction" x with
   | (loc,al,[x1;x2]) ->
       (get_xml_name al, interp_xml_type x1, interp_xml_body x2)
-    | (loc,_,_) -> 
+    | (loc,_,_) ->
 	error_expect_one_argument loc
 
 (* Interpreting tactic argument *)
diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli
index 11e0b6ac..b7e6e994 100644
--- a/parsing/g_zsyntax.mli
+++ b/parsing/g_zsyntax.mli
@@ -6,6 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_zsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Nice syntax for integers. *)
diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib
new file mode 100644
index 00000000..248a8ad9
--- /dev/null
+++ b/parsing/grammar.mllib
@@ -0,0 +1,84 @@
+Coq_config
+
+Profile
+Pp_control
+Pp
+Compat
+Flags
+Segmenttree
+Unicodetable
+Util
+Bigint
+Dyn
+Hashcons
+Predicate
+Rtree
+Option
+
+Names
+Univ
+Esubst
+Term
+Mod_subst
+Sign
+Cbytecodes
+Copcodes
+Cemitcodes
+Declarations
+Retroknowledge
+Pre_env
+Cbytegen
+Environ
+Conv_oracle
+Closure
+Reduction
+Type_errors
+Entries
+Modops
+Inductive
+Typeops
+Indtypes
+Cooking
+Term_typing
+Subtyping
+Mod_typing
+Safe_typing
+
+Nameops
+Libnames
+Summary
+Nametab
+Libobject
+Lib
+Goptions
+Decl_kinds
+Global
+Termops
+Namegen
+Evd
+Reductionops
+Inductiveops
+Rawterm
+Detyping
+Pattern
+Topconstr
+Genarg
+Ppextend
+Tacexpr
+Lexer
+Extend
+Vernacexpr
+Extrawit
+Pcoq
+Q_util
+Q_coqast
+
+Egrammar
+Argextend
+Tacextend
+Vernacextend
+
+G_prim
+G_tactic
+G_ltac
+G_constr
diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib
new file mode 100644
index 00000000..3eb27abb
--- /dev/null
+++ b/parsing/highparsing.mllib
@@ -0,0 +1,7 @@
+G_constr
+G_vernac
+G_prim
+G_proofs
+G_tactic
+G_ltac
+G_decl_mode
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index 52b5ede7..4ec61a23 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -6,13 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lexer.ml4 12891 2010-03-30 11:40:02Z herbelin $ i*)
-
-
-(*i camlp4use: "pr_o.cmo" i*) 
+(*i camlp4use: "pr_o.cmo pa_macro.cmo" i*)
 (* Add pr_o.cmo to circumvent a useless-warning bug when preprocessed with
  * ast-based camlp4 *)
 
+(*i $Id$ i*)
+
 open Pp
 open Util
 open Token
@@ -22,7 +21,7 @@ open Token
 
 module CharMap = Map.Make (struct type t = char let compare = compare end)
 
-type ttree = { 
+type ttree = {
   node : string option;
   branch : ttree CharMap.t }
 
@@ -30,7 +29,7 @@ let empty_ttree = { node = None; branch = CharMap.empty }
 
 let ttree_add ttree str =
   let rec insert tt i =
-    if i == String.length str then 
+    if i == String.length str then
       {node = Some str; branch = tt.branch}
     else
       let c = str.[i] in
@@ -43,7 +42,7 @@ let ttree_add ttree str =
               CharMap.add c (insert tt' (i + 1)) tt.branch
       in
       { node = tt.node; branch = br }
-  in 
+  in
   insert ttree 0
 
 (* Search a string in a dictionary: raises [Not_found]
@@ -51,15 +50,30 @@ let ttree_add ttree str =
 
 let ttree_find ttree str =
   let rec proc_rec tt i =
-    if i == String.length str then
-      match tt.node with
-	| Some s -> s
-	| None -> raise Not_found
-    else 
-      proc_rec (CharMap.find str.[i] tt.branch) (i+1)
-  in 
+    if i == String.length str then tt
+    else proc_rec (CharMap.find str.[i] tt.branch) (i+1)
+  in
   proc_rec ttree 0
 
+(* Removes a string from a dictionary: returns an equal dictionary
+   if the word not present. *)
+let ttree_remove ttree str =
+  let rec remove tt i =
+    if i == String.length str then
+      {node = None; branch = tt.branch}
+    else
+      let c = str.[i] in
+      let br =
+        match try Some (CharMap.find c tt.branch) with Not_found -> None with
+          | Some tt' ->
+              CharMap.add c (remove tt' (i + 1)) (CharMap.remove c tt.branch)
+          | None -> tt.branch
+      in
+      { node = tt.node; branch = br }
+  in
+  remove ttree 0
+
+
 (* Errors occuring while lexing (explained as "Lexer error: ...") *)
 
 type error =
@@ -108,7 +122,7 @@ let check_utf8_trailing_byte cs c =
 (* but don't certify full utf8 compliance (e.g. no emptyness check) *)
 let lookup_utf8_tail c cs =
   let c1 = Char.code c in
-  if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs 
+  if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs
   else
     let n, unicode =
       if c1 land 0x20 = 0 then
@@ -121,20 +135,20 @@ let lookup_utf8_tail c cs =
       match Stream.npeek 3 cs with
       | [_;c2;c3] ->
 	  check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
-	  3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + 
+	  3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 +
 	  (Char.code c3 land 0x3F)
       | _ -> error_utf8 cs
       else match Stream.npeek 4 cs with
       | [_;c2;c3;c4] ->
 	  check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
-	  check_utf8_trailing_byte cs c4; 
+	  check_utf8_trailing_byte cs c4;
 	  4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 +
 	  (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F)
       | _ -> error_utf8 cs
     in
     try classify_unicode unicode, n
     with UnsupportedUtf8 -> error_unsupported_unicode_character n cs
-	
+
 let lookup_utf8 cs =
   match Stream.peek cs with
     | Some ('\x00'..'\x7F') -> AsciiChar
@@ -171,15 +185,17 @@ let check_keyword str =
 (* Keyword and symbol dictionary *)
 let token_tree = ref empty_ttree
 
-let find_keyword s = ttree_find !token_tree s
-
-let is_keyword s = 
-  try let _ = ttree_find !token_tree s in true with Not_found -> false
+let is_keyword s =
+  try match (ttree_find !token_tree s).node with None -> false | Some _ -> true
+  with Not_found -> false
 
 let add_keyword str =
   check_keyword str;
   token_tree := ttree_add !token_tree str
 
+let remove_keyword str =
+  token_tree := ttree_remove !token_tree str
+
 (* Adding a new token (keyword or special token). *)
 let add_token (con, str) = match con with
   | "" -> add_keyword str
@@ -235,10 +251,18 @@ let rec number len = parser
 
 let escape len c = store len c
 
-let rec string bp len = parser
+let rec string in_comments bp len = parser
   | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] ->
-      if esc then string bp (store len '"') s else len
-  | [< 'c; s >] -> string bp (store len c) s 
+      if esc then string in_comments bp (store len '"') s else len
+  | [< ''*'; s >] ->
+      (parser
+        | [< '')'; s >] ->
+	    if in_comments then
+	      msg_warning (str "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment.");
+	    string in_comments 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
 
 (* Hook for exporting comment into xml theory files *)
@@ -254,8 +278,8 @@ let between_com = ref true
 
 type com_state = int option * string * bool
 let restore_com_state (o,s,b) =
-  comment_begin := o; 
-  Buffer.clear current; Buffer.add_string current s; 
+  comment_begin := o;
+  Buffer.clear current; Buffer.add_string current s;
   between_com := b
 let dflt_com = (None,"",true)
 let com_state () =
@@ -310,13 +334,13 @@ let rec comm_string bp = parser
                  | [< >] -> 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 
+  | [< 'c; s >] -> real_push_char c; comm_string bp s
 
 let rec comment bp = parser bp2
   | [< ''(';
        _ = (parser
               | [< ''*'; s >] -> push_string "(*"; comment bp s
-              | [< >] -> push_string "(" ); 
+              | [< >] -> push_string "(" );
        s >] -> comment bp s
   | [< ''*';
        _ = parser
@@ -324,7 +348,7 @@ let rec comment bp = parser bp2
          | [< s >] -> real_push_char '*'; comment bp s >] -> ()
   | [< ''"'; s >] ->
       if Flags.do_beautify() then (push_string"\"";comm_string bp2 s)
-      else ignore (string bp2 0 s);
+      else ignore (string true bp2 0 s);
       comment bp s
   | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment
   | [< 'z; s >] -> real_push_char z; comment bp s
@@ -340,12 +364,12 @@ let rec progress_further last nj tt cs =
 and update_longest_valid_token last nj tt cs =
   match tt.node with
   | Some _ as last' ->
-      for i=1 to nj do Stream.junk cs done; 
+      for i=1 to nj do Stream.junk cs done;
       progress_further last' 0 tt cs
   | None ->
       progress_further last nj tt cs
 
-(* nr is the number of char peeked since last valid token *)
+(* nj is the number of char peeked since last valid token *)
 (* n the number of char in utf8 block *)
 and progress_utf8 last nj n c tt cs =
   try
@@ -358,7 +382,7 @@ and progress_utf8 last nj n c tt cs =
 	 List.iter (check_utf8_trailing_byte cs) l;
 	 let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in
 	 update_longest_valid_token last (nj+n) tt cs
-      | _ -> 
+      | _ ->
 	  error_utf8 cs
   with Not_found ->
     last
@@ -366,6 +390,12 @@ and progress_utf8 last nj n c tt cs =
 and progress_from_byte last nj tt cs c =
   progress_utf8 last nj (utf8_char_size cs c) c tt cs
 
+let find_keyword id s =
+  let tt = ttree_find !token_tree id in
+  match progress_further tt.node 0 tt s with
+  | None -> raise Not_found
+  | Some c -> c
+
 (* Must be a special token *)
 let process_chars bp c cs =
   let t = progress_from_byte None (-1) !token_tree cs c in
@@ -379,7 +409,7 @@ let process_chars bp c cs =
 
 let parse_after_dollar bp =
   parser
-  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> 
+  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ->
       ("METAIDENT", get_buff len)
   | [< s >] ->
       match lookup_utf8 s with
@@ -394,9 +424,9 @@ let parse_after_dot bp c =
       ("FIELD", get_buff len)
   | [< s >] ->
       match lookup_utf8 s with
-      | Utf8Token (UnicodeLetter, n) -> 
+      | Utf8Token (UnicodeLetter, n) ->
 	  ("FIELD", get_buff (ident_tail (nstore n 0 s) s))
-      | AsciiChar | Utf8Token _ | EmptyStream -> 
+      | AsciiChar | Utf8Token _ | EmptyStream ->
 	  fst (process_chars bp c s)
 
 (* Parse what follows a question mark *)
@@ -409,6 +439,7 @@ let parse_after_qmark bp s =
 	  | Utf8Token (UnicodeLetter, _) -> ("LEFTQMARK", "")
 	  | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s)
 
+
 (* Parse a token in a char stream *)
 let rec next_token = parser bp
   | [< '' ' | '\t' | '\n' |'\r' as c; s >] ->
@@ -422,14 +453,14 @@ let rec next_token = parser bp
   | [< ''?'; s >] ep ->
       let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp))
   | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
-       len = ident_tail (store 0 c) >] ep ->
-      let id = get_buff len in 
+       len = ident_tail (store 0 c); s >] ep ->
+      let id = get_buff len in
       comment_stop bp;
-      (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
+      (try ("", find_keyword id s) with Not_found -> ("IDENT", id)), (bp, ep)
   | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep ->
       comment_stop bp;
       (("INT", get_buff len), (bp, ep))
-  | [< ''\"'; len = string bp 0 >] ep ->
+  | [< ''\"'; len = string false bp 0 >] ep ->
       comment_stop bp;
       (("STRING", get_buff len), (bp, ep))
   | [< ' ('(' as c);
@@ -448,8 +479,8 @@ let rec next_token = parser bp
 	    let id = get_buff len in
 	    let ep = Stream.count s in
 	    comment_stop bp;
-	    (try ("",find_keyword id) with Not_found -> ("IDENT",id)), (bp, ep)
-	| AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) -> 
+	    (try ("",find_keyword id s) with Not_found -> ("IDENT",id)), (bp, ep)
+	| AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) ->
 	    let t = process_chars bp (Stream.next s) s in
 	    comment_stop bp; t
 	| EmptyStream ->
@@ -514,16 +545,38 @@ let token_text = function
   | ("STRING", "") -> "string"
   | ("EOI", "") -> "end of input"
   | (con, "") -> con
-  | (con, prm) -> con ^ " \"" ^ prm ^ "\"" 
+  | (con, prm) -> con ^ " \"" ^ prm ^ "\""
 
-let tparse (p_con, p_prm) =
-  None
-  (*i was
-  if p_prm = "" then
-    (parser [< '(con, prm) when con = p_con >] -> prm)
-  else
-    (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm)
-  i*)
+(* The lexer of Coq *)
+
+(* Note: removing a token.
+   We do nothing because [remove_token] is called only when removing a grammar
+   rule with [Grammar.delete_rule]. The latter command is called only when
+   unfreezing the state of the grammar entries (see GRAMMAR summary, file
+   env/metasyntax.ml). Therefore, instead of removing tokens one by one,
+   we unfreeze the state of the lexer. This restores the behaviour of the
+   lexer. B.B. *)
+
+IFDEF CAMLP5 THEN
+
+let lexer = {
+  Token.tok_func = func;
+  Token.tok_using = add_token;
+  Token.tok_removing = (fun _ -> ());
+  Token.tok_match = default_match;
+  Token.tok_comm = None;
+  Token.tok_text = token_text }
+
+ELSE
+
+let lexer = {
+  Token.func = func;
+  Token.using = add_token;
+  Token.removing = (fun _ -> ());
+  Token.tparse = (fun _ -> None);
+  Token.text = token_text }
+
+END
 
 (* Terminal symbols interpretation *)
 
@@ -534,7 +587,7 @@ let is_ident_not_keyword s =
 
 let is_number s =
   let rec aux i =
-    String.length s = i or 
+    String.length s = i or
     match s.[i] with '0'..'9' -> aux (i+1) | _ -> false
   in aux 0
 
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index f1ab6446..1b40d7f1 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lexer.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -21,9 +21,9 @@ type error =
 exception Error of error
 
 val add_token : string * string -> unit
+val remove_keyword : string -> unit
 val is_keyword : string -> bool
 
-val func : char Stream.t -> (string * string) Stream.t * (int -> loc)
 val location_function : int -> loc
 
 (* for coqdoc *)
@@ -34,10 +34,6 @@ val restore_location_table : location_table -> unit
 val check_ident : string -> unit
 val check_keyword : string -> unit
 
-val tparse : string * string -> ((string * string) Stream.t -> string) option
-
-val token_text : string * string -> string
-
 type frozen_t
 val freeze : unit -> frozen_t
 val unfreeze : frozen_t -> unit
@@ -50,3 +46,7 @@ val restore_com_state: com_state -> unit
 val set_xml_output_comment : (string -> unit) -> unit
 
 val terminal : string -> string * string
+
+(* The lexer of Coq *)
+
+val lexer : Compat.lexer
diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib
new file mode 100644
index 00000000..c0c1817d
--- /dev/null
+++ b/parsing/parsing.mllib
@@ -0,0 +1,12 @@
+Extend
+Extrawit
+Pcoq
+Egrammar
+G_xml
+Ppconstr
+Printer
+Pptactic
+Ppdecl_proof
+Tactic_printer
+Printmod
+Prettyp
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
index d2d81cd1..7120f72d 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo pa_macro.cmo" i*)
 
-(*i $Id: pcoq.ml4 12055 2009-04-07 18:19:05Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -19,55 +19,28 @@ open Rawterm
 open Topconstr
 open Genarg
 open Tacexpr
+open Extrawit
 open Ppextend
 
-(* The lexer of Coq *)
-
-(* Note: removing a token.
-   We do nothing because [remove_token] is called only when removing a grammar
-   rule with [Grammar.delete_rule]. The latter command is called only when
-   unfreezing the state of the grammar entries (see GRAMMAR summary, file
-   env/metasyntax.ml). Therefore, instead of removing tokens one by one,
-   we unfreeze the state of the lexer. This restores the behaviour of the
-   lexer. B.B. *)
-
-IFDEF CAMLP5 THEN 
+(* The parser of Coq *)
 
-let lexer = {
-  Token.tok_func = Lexer.func;
-  Token.tok_using = Lexer.add_token;
-  Token.tok_removing = (fun _ -> ());
-  Token.tok_match = Token.default_match;
-  (* Token.parse = Lexer.tparse; *)
-  Token.tok_comm = None;
-  Token.tok_text = Lexer.token_text }
+IFDEF CAMLP5 THEN
 
 module L =
   struct
     type te = string * string
-    let lexer = lexer
+    let lexer = Lexer.lexer
   end
 
-(* The parser of Coq *)
-
 module G = Grammar.GMake(L)
 
-ELSE 
-
-let lexer = {
-  Token.func = Lexer.func;
-  Token.using = Lexer.add_token;
-  Token.removing = (fun _ -> ());
-  Token.tparse = Lexer.tparse;
-  Token.text = Lexer.token_text }
+ELSE
 
 module L =
   struct
-    let lexer = lexer
+    let lexer = Lexer.lexer
   end
 
-(* The parser of Coq *)
-
 module G = Grammar.Make(L)
 
 END
@@ -82,7 +55,7 @@ let grammar_delete e pos reinit rls =
 	 99 and 200. We didn't find a good solution to this problem
 	 (e.g. using G.extend to know if the level exists results in a
 	 printed error message as side effect). As a consequence an
-	 extension at 99 or 8 (and for pattern 200 too) inside a section 
+	 extension at 99 or 8 (and for pattern 200 too) inside a section
          corrupts the parser. *)
 
       List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
@@ -90,7 +63,7 @@ let grammar_delete e pos reinit rls =
   if reinit <> None then
     let lev = match pos with Some (Gramext.Level n) -> n | _ -> assert false in
     let pos =
-      if lev = "200" then Gramext.First 
+      if lev = "200" then Gramext.First
       else Gramext.After (string_of_int (int_of_string lev + 1)) in
     G.extend e (Some pos) [Some lev,reinit,[]];
 
@@ -134,12 +107,17 @@ end
 
 open Gramtypes
 
+type camlp4_rule =
+    Compat.token Gramext.g_symbol list * Gramext.g_action
+
+type camlp4_entry_rules =
+    (* first two parameters are name and assoc iff a level is created *)
+    string option * Gramext.g_assoc option * camlp4_rule list
+
 type ext_kind =
   | ByGrammar of
       grammar_object G.Entry.e * Gramext.position option *
-      (string option * Gramext.g_assoc option *
-       (Compat.token Gramext.g_symbol list * Gramext.g_action) list) list *
-        Gramext.g_assoc option
+      camlp4_entry_rules list * Gramext.g_assoc option
   | ByGEXTEND of (unit -> unit) * (unit -> unit)
 
 let camlp4_state = ref []
@@ -156,7 +134,15 @@ module Gram =
       :: !camlp4_state;
       G.extend e pos rls
     let delete_rule e pil =
-      errorlabstrm "Pcoq.delete_rule" (str "GDELETE_RULE forbidden.")
+      (* 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
+	  ByGEXTEND 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
 
 
@@ -212,14 +198,14 @@ let map_entry f en =
 let parse_string f x =
   let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm)
 
-type gram_universe = (string, typed_entry) Hashtbl.t
+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 grammar that
+(* 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, string * gram_universe) Hashtbl.t)
+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
@@ -229,49 +215,27 @@ let uconstr = create_univ "constr"
 let utactic = create_univ "tactic"
 let uvernac = create_univ "vernac"
 
-let create_univ_if_new s =
-  (* compatibilite *)
-  let s = if s = "command" then (warning "'command' grammar universe is obsolete; use name 'constr' instead"; "constr") else s in
+let get_univ s =
   try
     Hashtbl.find univ_tab s
-  with Not_found -> 
-    if !trace then begin 
-      Printf.eprintf "[Creating univ %s]\n" s; flush stderr; () 
-    end;
-    let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
+  with Not_found ->
+    anomaly ("Unknown grammar universe: "^s)
 
-let get_univ = create_univ_if_new
+let get_entry (u, utab) s = Hashtbl.find utab s
 
-let get_entry (u, utab) s =
+let get_entry_type (u, utab) s =
   try
-    Hashtbl.find utab s 
-  with Not_found -> 
+    type_of_typed_entry (get_entry (u, utab) s)
+  with Not_found ->
     errorlabstrm "Pcoq.get_entry"
       (str "Unknown grammar entry " ++ str u ++ str ":" ++ str s ++ str ".")
 
 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 entry_type (u, utab) s =
-  try
-    let e = Hashtbl.find utab s in
-    Some (type_of_typed_entry e)
-  with Not_found -> None
-
-let get_entry_type (u,n) =  type_of_typed_entry (get_entry (get_univ u) n)
-
-let create_entry_if_new (u, utab) s etyp =
-  try
-    if type_of_typed_entry (Hashtbl.find utab s) <> etyp then
-      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type")
-  with Not_found ->
-    if !trace then begin
-      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
-    end;
-    let _ = new_entry etyp (u, utab) s in ()
-
 let create_entry (u, utab) s etyp =
   try
     let e = Hashtbl.find utab s in
@@ -279,105 +243,13 @@ let create_entry (u, utab) s etyp =
       failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
     e
   with Not_found ->
-    if !trace then begin
-      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
-    end;
     new_entry etyp (u, utab) s
 
-let create_constr_entry u s =
-  outGramObj rawwit_constr (create_entry u s ConstrArgType)
-
-let create_generic_entry s wit = 
-  let (u,utab) = utactic in
-  let etyp = unquote wit in
-  try
-    let e = Hashtbl.find utab s in
-    if type_of_typed_entry e <> etyp then
-      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
-    outGramObj wit e
-  with Not_found ->
-    if !trace then begin
-      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
-    end;
-  let e = Gram.Entry.create s in
-  Hashtbl.add utab s (inGramObj wit e); e
-
-let get_generic_entry s =
-  let (u,utab) = utactic in
-  try
-    object_of_typed_entry (Hashtbl.find utab s)
-  with Not_found -> 
-    error ("Unknown grammar entry "^u^":"^s^".")
-
-let get_generic_entry_type (u,utab) s =
-  try type_of_typed_entry (Hashtbl.find utab s)
-  with Not_found -> 
-    error ("Unknown grammar entry "^u^":"^s^".")
-
-let force_entry_type (u, utab) s etyp =
-  try
-    let entry = Hashtbl.find utab s in
-    let extyp = type_of_typed_entry entry in
-    if etyp = extyp then 
-      entry
-    else begin
-      prerr_endline
-        ("Grammar entry " ^ u ^ ":" ^ s ^
-         " redefined with another type;\n older entry hidden.");
-      Hashtbl.remove utab s;
-      new_entry etyp (u, utab) s
-    end
-  with Not_found -> 
-    new_entry etyp (u, utab) s
-
-(* Tactics as arguments *)
-
-let tactic_main_level = 5
-
-let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg "tactic0"
-let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg "tactic1"
-let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg "tactic2"
-let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg "tactic3"
-let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg "tactic4"
-let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg "tactic5"
-
-let wit_tactic = function
-  | 0 -> wit_tactic0
-  | 1 -> wit_tactic1
-  | 2 -> wit_tactic2
-  | 3 -> wit_tactic3
-  | 4 -> wit_tactic4
-  | 5 -> wit_tactic5
-  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
-
-let globwit_tactic = function
-  | 0 -> globwit_tactic0
-  | 1 -> globwit_tactic1
-  | 2 -> globwit_tactic2
-  | 3 -> globwit_tactic3
-  | 4 -> globwit_tactic4
-  | 5 -> globwit_tactic5
-  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
-
-let rawwit_tactic = function
-  | 0 -> rawwit_tactic0
-  | 1 -> rawwit_tactic1
-  | 2 -> rawwit_tactic2
-  | 3 -> rawwit_tactic3
-  | 4 -> rawwit_tactic4
-  | 5 -> rawwit_tactic5
-  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
-
-let tactic_genarg_level s =
-  if String.length s = 7 && String.sub s 0 6 = "tactic" then
-    let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48)
-    else None
-  else None
-
-let is_tactic_genarg = function
-| ExtraArgType s -> tactic_genarg_level s <> None
-| _ -> false
+let create_constr_entry s =
+  outGramObj rawwit_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 *)
@@ -386,12 +258,12 @@ let make_gen_entry (u,univ) rawwit s =
   let e = Gram.Entry.create (u ^ ":" ^ s) in
   Hashtbl.add univ s (inGramObj rawwit e); e
 
-(* Grammar entries *)
+(* Initial grammar entries *)
 
 module Prim =
   struct
     let gec_gen x = make_gen_entry uprim x
-    
+
     (* Entries that can be refered via the string -> Gram.Entry.e table *)
     (* Typically for tactic or vernac extensions *)
     let preident = gec_gen rawwit_pre_ident "preident"
@@ -401,6 +273,8 @@ module Prim =
     let bigint = Gram.Entry.create "Prim.bigint"
     let string = gec_gen rawwit_string "string"
     let reference = make_gen_entry uprim rawwit_ref "reference"
+    let by_notation = Gram.Entry.create "by_notation"
+    let smart_global = Gram.Entry.create "smart_global"
 
     (* parsed like ident but interpreted as a term *)
     let var = gec_gen rawwit_var "var"
@@ -418,10 +292,10 @@ module Prim =
     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_constr
@@ -432,12 +306,11 @@ module Constr =
     let operconstr = gec_constr "operconstr"
     let constr_eoi = eoi_entry constr
     let lconstr = gec_constr "lconstr"
-    let binder_constr = create_constr_entry uconstr "binder_constr"
+    let binder_constr = create_constr_entry "binder_constr"
     let ident = make_gen_entry uconstr rawwit_ident "ident"
     let global = make_gen_entry uconstr rawwit_ref "global"
     let sort = make_gen_entry uconstr rawwit_sort "sort"
     let pattern = Gram.Entry.create "constr:pattern"
-    let annot = Gram.Entry.create "constr:annot"
     let constr_pattern = gec_constr "constr_pattern"
     let lconstr_pattern = gec_constr "lconstr_pattern"
     let binder = Gram.Entry.create "constr:binder"
@@ -462,7 +335,7 @@ module Tactic =
 
     (* Entries that can be refered via the string -> Gram.Entry.e table *)
     (* Typically for tactic user extensions *)
-    let open_constr = 
+    let open_constr =
       make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr"
     let casted_open_constr =
       make_gen_entry utactic (rawwit_open_constr_gen true) "casted_open_constr"
@@ -475,7 +348,7 @@ module Tactic =
       make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis"
     let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var"
     let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr"
-    let simple_intropattern = 
+    let simple_intropattern =
       make_gen_entry utactic rawwit_intro_pattern "simple_intropattern"
 
     (* Main entries for ltac *)
@@ -490,8 +363,6 @@ module Tactic =
 
   end
 
-
-
 module Vernac_ =
   struct
     let gec_vernac s = Gram.Entry.create ("vernac:" ^ s)
@@ -501,24 +372,22 @@ module Vernac_ =
     let gallina_ext = gec_vernac "gallina_ext"
     let command = gec_vernac "command"
     let syntax = gec_vernac "syntax_command"
-    let vernac = gec_vernac "Vernac_.vernac"
-
-    (* MMode *)
-
+    let vernac = gec_vernac "Vernac.vernac"
     let proof_instr = Gram.Entry.create "proofmode:instr"
 
-    (* /MMode *)
-
     let vernac_eoi = eoi_entry vernac
-  end
 
-let main_entry = Gram.Entry.create "vernac"
+    (* Main vernac entry *)
+    let main_entry = Gram.Entry.create "vernac"
+    GEXTEND Gram
+    main_entry:
+      [ [ a = vernac -> Some (loc,a) | EOI -> None ] ]
+    ;
+    END
 
-GEXTEND Gram
-  main_entry:
-    [ [ a = Vernac_.vernac -> Some (loc,a) | EOI -> None ] ]
-  ;
-END
+  end
+
+let main_entry = Vernac_.main_entry
 
 (**********************************************************************)
 (* This determines (depending on the associativity of the current
@@ -527,7 +396,7 @@ END
    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") 
+   (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
@@ -554,7 +423,7 @@ let default_pattern_levels =
    1,Gramext.LeftA,false;
    0,Gramext.RightA,false]
 
-let level_stack = 
+let level_stack =
   ref [(default_levels, default_pattern_levels)]
 
 (* At a same level, LeftA takes precedence over RightA and NoneA *)
@@ -574,7 +443,7 @@ let create_assoc = function
 let error_level_assoc p current expected =
   let pr_assoc = function
     | Gramext.LeftA -> str "left"
-    | Gramext.RightA -> str "right" 
+    | Gramext.RightA -> str "right"
     | Gramext.NonA -> str "non" in
   errorlabstrm ""
     (str "Level " ++ int p ++ str " is already declared " ++
@@ -640,13 +509,16 @@ let register_empty_levels forpat levels =
 let find_position forpat assoc level =
   find_position_gen forpat false assoc level
 
-(* Synchronise the stack of level updates *) 
+(* 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 Gramext.NonA | Some Gramext.RightA -> Gramext.RightA 
+  | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA
   | None | Some Gramext.LeftA -> Gramext.LeftA
 
 (* [adjust_level assoc from prod] where [assoc] and [from] are the name
@@ -690,22 +562,20 @@ let compute_entry allow_create adjust forpat = function
       (if forpat then weaken_entry Constr.pattern
        else weaken_entry Constr.operconstr),
       adjust (n,q), false
-  | ETIdent -> weaken_entry Constr.ident, None, false
+  | ETName -> weaken_entry Prim.name, None, false
   | ETBigint -> weaken_entry Prim.bigint, None, false
   | ETReference -> weaken_entry Constr.global, None, false
   | ETPattern -> weaken_entry Constr.pattern, None, false
-  | ETOther ("constr","annot") -> 
-      weaken_entry Constr.annot, None, false
   | ETConstrList _ -> error "List of entries cannot be registered."
   | ETOther (u,n) ->
       let u = get_univ u in
       let e =
         try get_entry u n
-        with e when allow_create -> create_entry u n ConstrArgType in
+        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 get_constr_entry forpat = function
+let interp_constr_entry_key forpat = function
   | ETConstr(200,()) when not forpat ->
       weaken_entry Constr.binder_constr, None
   | e ->
@@ -714,15 +584,18 @@ let get_constr_entry forpat = function
 
 (* This computes the name to give to a production knowing the name and
    associativity of the level where it must be added *)
-let get_constr_production_entry ass from forpat en =
+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(Gramext.NonA|Gramext.LeftA) *))) -> false
     | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n'
-    | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint
+    | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint
       | ETPattern, ETPattern) -> true
     | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2'
     | _ -> false
@@ -733,7 +606,7 @@ let is_binder_level from e =
       ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true
     | _ -> false
 
-let rec symbol_of_production assoc from forpat typ =
+let rec symbol_of_constr_prod_entry_key assoc from forpat typ =
   if is_binder_level from typ then
     if forpat then
       Gramext.Snterml (Gram.Entry.obj Constr.pattern,"200")
@@ -744,28 +617,90 @@ let rec symbol_of_production assoc from forpat typ =
   else
     match typ with
     | ETConstrList (typ',[]) ->
-        Gramext.Slist1 (symbol_of_production assoc from forpat (ETConstr typ'))
+        Gramext.Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
     | ETConstrList (typ',tkl) ->
         Gramext.Slist1sep
-          (symbol_of_production assoc from forpat (ETConstr typ'),
+          (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'),
            Gramext.srules
              [List.map (fun x -> Gramext.Stoken x) tkl,
               List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl
                 (Gramext.action (fun loc -> ()))])
     | _ ->
-    match get_constr_production_entry assoc from forpat typ with
+    match interp_constr_prod_entry_key assoc from forpat typ with
       | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj)
       | (eobj,Some None,_) -> Gramext.Snext
-      | (eobj,Some (Some (lev,cur)),_) -> 
+      | (eobj,Some (Some (lev,cur)),_) ->
           Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev)
 
-(*****************************)
-(* Coercions between entries *)
-
-let coerce_reference_to_id = function
-  | Ident (_,id) -> id
-  | Qualid (loc,_) ->
-      user_err_loc (loc, "coerce_reference_to_id",
-        str "This expression should be a simple identifier.")
+(**********************************************************************)
+(* Binding general entry keys to symbol                               *)
+
+let rec symbol_of_prod_entry_key = function
+  | Alist1 s -> Gramext.Slist1 (symbol_of_prod_entry_key s)
+  | Alist1sep (s,sep) ->
+      Gramext.Slist1sep (symbol_of_prod_entry_key s, Gramext.Stoken ("",sep))
+  | Alist0 s -> Gramext.Slist0 (symbol_of_prod_entry_key s)
+  | Alist0sep (s,sep) ->
+      Gramext.Slist0sep (symbol_of_prod_entry_key s, Gramext.Stoken ("",sep))
+  | Aopt s -> Gramext.Sopt (symbol_of_prod_entry_key s)
+  | Amodifiers s ->
+       Gramext.srules
+        [([], Gramext.action(fun _loc -> []));
+         ([Gramext.Stoken ("", "(");
+           Gramext.Slist1sep ((symbol_of_prod_entry_key s), Gramext.Stoken ("", ","));
+           Gramext.Stoken ("", ")")],
+	   Gramext.action (fun _ l _ _loc -> l))]
+  | Aself -> Gramext.Sself
+  | Anext -> Gramext.Snext
+  | Atactic 5 -> Gramext.Snterm (Gram.Entry.obj Tactic.binder_tactic)
+  | Atactic n ->
+      Gramext.Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n)
+  | Agram s -> Gramext.Snterm s
+  | Aentry (u,s) ->
+      Gramext.Snterm (Gram.Entry.obj
+	(object_of_typed_entry (get_entry (get_univ u) s)))
 
-let coerce_global_to_id = coerce_reference_to_id
+(**********************************************************************)
+(* Interpret entry names of the form "ne_constr_list" as entry keys   *)
+
+let rec interp_entry_name static up_level s sep =
+  let l = String.length s in
+  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in
+    List1ArgType t, Alist1 g
+  else if l > 12 & String.sub s 0 3 = "ne_" &
+                   String.sub s (l-9) 9 = "_list_sep" then
+    let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in
+    List1ArgType t, Alist1sep (g,sep)
+  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in
+    List0ArgType t, Alist0 g
+  else if l > 9 & String.sub s (l-9) 9 = "_list_sep" then
+    let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in
+    List0ArgType t, Alist0sep (g,sep)
+  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in
+    OptArgType t, Aopt g
+  else if l > 5 & String.sub s (l-5) 5 = "_mods" then
+    let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in
+    List0ArgType t, Amodifiers g
+  else
+    let s = if s = "hyp" then "var" else s in
+    let t, se =
+      match Extrawit.tactic_genarg_level s with
+	| Some n when Some n = up_level & up_level <> Some 5 -> None, Aself
+	| Some n when Some (n+1) = up_level & up_level <> Some 5 -> None, Anext
+	| Some n -> None, Atactic n
+	| None ->
+      try Some (get_entry uprim s), Aentry ("prim",s) with Not_found ->
+      try Some (get_entry uconstr s), Aentry ("constr",s) with Not_found ->
+      try Some (get_entry utactic s), Aentry ("tactic",s) with Not_found ->
+	if static then
+	  error ("Unknown entry "^s^".")
+	else
+	  None, Aentry ("",s) in
+    let t =
+      match t with
+	| Some t -> type_of_typed_entry t
+	| None -> ExtraArgType s in
+    t, se
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 0a4b349f..ed370a99 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -6,47 +6,131 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pcoq.mli 11784 2009-01-14 11:36:32Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
 open Rawterm
 open Extend
+open Vernacexpr
 open Genarg
 open Topconstr
 open Tacexpr
-open Vernacexpr
 open Libnames
 
-(* The lexer and parser of Coq. *)
-
-val lexer : Compat.lexer
+(**********************************************************************)
+(* The parser of Coq                                                  *)
 
 module Gram : Grammar.S with type te = Compat.token
 
+(**********************************************************************)
+(* The parser of Coq is built from three kinds of rule declarations:
+   - dynamic rules declared at the evaluation of Coq files (using
+     e.g. Notation, Infix, or Tactic Notation)
+   - static rules explicitly defined in files g_*.ml4
+   - static rules macro-generated by ARGUMENT EXTEND, TACTIC EXTEND and
+     VERNAC EXTEND (see e.g. file extratactics.ml4)
+*)
+
+(* Dynamic extension of rules
+
+    For constr notations, dynamic addition of new rules is done in
+    several steps:
+
+    - "x + y" (user gives a notation string of type Topconstr.notation)
+        |     (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
+        V
+      [String "x"; String "+"; String "y"] : symbol_token list
+        |
+        | interpreted as a mixed parsing/printing production
+        | by Metasyntax.analyse_notation_tokens
+        V
+      [NonTerminal "x"; Terminal "+"; NonTerminal "y"] : symbol list
+        |
+        | translated to a parsing production by Metasyntax.make_production
+        V
+      [GramConstrNonTerminal (ETConstr (NextLevel,(BorderProd Left,LeftA)),
+                              Some "x");
+       GramConstrTerminal ("","+");
+       GramConstrNonTerminal (ETConstr (NextLevel,(BorderProd Right,LeftA)),
+                              Some "y")]
+       : grammar_constr_prod_item list
+        |
+        | Egrammar.make_constr_prod_item
+        V
+      Gramext.g_symbol list which is sent to camlp4
+
+    For user level tactic notations, dynamic addition of new rules is
+    also done in several steps:
+
+    - "f" constr(x) (user gives a Tactic Notation command)
+        |
+        | parsing
+        V
+      [TacTerm "f"; TacNonTerm ("constr", Some "x")]
+      : grammar_tactic_prod_item_expr list
+        |
+        | Metasyntax.interp_prod_item
+        V
+      [GramTerminal "f";
+       GramNonTerminal (ConstrArgType, Aentry ("constr","constr"), Some "x")]
+      : grammar_prod_item list
+        |
+        | Egrammar.make_prod_item
+        V
+      Gramext.g_symbol list
+
+    For TACTIC/VERNAC/ARGUMENT EXTEND, addition of new rules is done as follows:
+
+    - "f" constr(x) (developer gives an EXTEND rule)
+        |
+        | macro-generation in tacextend.ml4/vernacextend.ml4/argextend.ml4
+        V
+      [GramTerminal "f";
+       GramNonTerminal (ConstrArgType, Aentry ("constr","constr"), Some "x")]
+        |
+        | Egrammar.make_prod_item
+        V
+      Gramext.g_symbol list
+
+*)
+
 (* The superclass of all grammar entries *)
 type grammar_object
 
+type camlp4_rule =
+    Compat.token Gramext.g_symbol list * Gramext.g_action
+
+type camlp4_entry_rules =
+    (* first two parameters are name and assoc iff a level is created *)
+    string option * Gramext.g_assoc option * camlp4_rule list
+
+(* Add one extension at some camlp4 position of some camlp4 entry *)
+val grammar_extend :
+  grammar_object Gram.Entry.e -> Gramext.position option ->
+   (* for reinitialization if ever needed: *) Gramext.g_assoc option ->
+     camlp4_entry_rules list -> 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.e
 val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e
 
-val get_constr_entry :
-  bool -> constr_entry -> grammar_object Gram.Entry.e * int option
-
-val grammar_extend :
-  grammar_object Gram.Entry.e -> Gramext.position option -> 
-   (* for reinitialization if ever: *) Gramext.g_assoc option ->
-    (string option * Gramext.g_assoc option *
-     (Compat.token Gramext.g_symbol list * Gramext.g_action) list) list
-    -> unit
-
-val remove_grammars : int -> unit
+(* Temporary activate camlp4 verbosity *)
 
 val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit
 
@@ -56,73 +140,28 @@ val parse_string : 'a Gram.Entry.e -> string -> 'a
 val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e
 val map_entry : ('a -> 'b) -> 'a Gram.Entry.e -> 'b Gram.Entry.e
 
-(* Entry types *)
-
-(* Table of Coq's grammar entries *)
+(**********************************************************************)
+(* Table of Coq statically defined grammar entries                    *)
 
 type gram_universe
 
-val create_univ_if_new : string -> string * gram_universe
-val get_univ : string -> string * gram_universe
-val get_entry : string * gram_universe -> string -> typed_entry
-
-val entry_type : string * gram_universe -> string -> entry_type option
-
-val get_entry_type : string * string -> entry_type
-val create_entry_if_new :
-  string * gram_universe -> string -> entry_type -> unit
-val create_entry :
-  string * gram_universe -> string -> entry_type -> typed_entry
-val force_entry_type :
-  string * gram_universe -> string -> entry_type -> typed_entry
-
-val create_constr_entry :
-  string * gram_universe -> string -> constr_expr Gram.Entry.e
-val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> 'a Gram.Entry.e
-val get_generic_entry : string -> grammar_object Gram.Entry.e
-val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type
-
-(* Tactics as arguments *)
-
-val tactic_main_level : int
+(* There are four predefined universes: "prim", "constr", "tactic", "vernac" *)
 
-val rawwit_tactic : int -> (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic : int -> (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic : int -> (glob_tactic_expr,tlevel) abstract_argument_type
+val get_univ : string -> gram_universe
 
-val rawwit_tactic0 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic0 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic0 : (glob_tactic_expr,tlevel) abstract_argument_type
+val uprim : gram_universe
+val uconstr : gram_universe
+val utactic : gram_universe
+val uvernac : gram_universe
 
-val rawwit_tactic1 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic1 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic1 : (glob_tactic_expr,tlevel) abstract_argument_type
+(*
+val get_entry : gram_universe -> string -> typed_entry
+val get_entry_type : gram_universe -> string -> entry_type
+*)
 
-val rawwit_tactic2 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic2 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic2 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic3 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic3 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic3 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic4 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic4 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic4 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic5 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic5 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic5 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val is_tactic_genarg : argument_type -> bool
-
-val tactic_genarg_level : string -> int option
-
-(* The main entry: reads an optional vernac command *)
-
-val main_entry : (loc * vernac_expr) option Gram.Entry.e
-
-(* Initial state of the grammar *)
+val create_entry : gram_universe -> string -> entry_type -> typed_entry
+val create_generic_entry : string -> ('a, rlevel) abstract_argument_type ->
+  'a Gram.Entry.e
 
 module Prim :
   sig
@@ -143,8 +182,11 @@ module Prim :
     val qualid : qualid located Gram.Entry.e
     val fullyqualid : identifier list located Gram.Entry.e
     val reference : reference Gram.Entry.e
+    val by_notation : (loc * string * string option) Gram.Entry.e
+    val smart_global : reference or_by_notation Gram.Entry.e
     val dirpath : dir_path Gram.Entry.e
     val ne_string : string Gram.Entry.e
+    val ne_lstring : string located Gram.Entry.e
     val var : identifier located Gram.Entry.e
   end
 
@@ -159,7 +201,6 @@ module Constr :
     val global : reference Gram.Entry.e
     val sort : rawsort Gram.Entry.e
     val pattern : cases_pattern_expr Gram.Entry.e
-    val annot : constr_expr Gram.Entry.e
     val constr_pattern : constr_expr Gram.Entry.e
     val lconstr_pattern : constr_expr Gram.Entry.e
     val binder : (name located list * binder_kind * constr_expr) Gram.Entry.e
@@ -171,10 +212,10 @@ module Constr :
     val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e
   end
 
-module Module : 
+module Module :
   sig
     val module_expr : module_ast Gram.Entry.e
-    val module_type : module_type_ast Gram.Entry.e
+    val module_type : module_ast Gram.Entry.e
   end
 
 module Tactic :
@@ -184,7 +225,7 @@ module Tactic :
     val casted_open_constr : open_constr_expr Gram.Entry.e
     val constr_with_bindings : constr_expr with_bindings Gram.Entry.e
     val bindings : constr_expr bindings Gram.Entry.e
-    val constr_may_eval : (constr_expr,reference or_by_notation) may_eval Gram.Entry.e
+    val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.Entry.e
     val quantified_hypothesis : quantified_hypothesis Gram.Entry.e
     val int_or_var : int or_var Gram.Entry.e
     val red_expr : raw_red_expr Gram.Entry.e
@@ -205,27 +246,43 @@ module Vernac_ :
     val command : vernac_expr Gram.Entry.e
     val syntax : vernac_expr Gram.Entry.e
     val vernac : vernac_expr Gram.Entry.e
-    
-  (* MMode *)
-
+    val vernac_eoi : vernac_expr Gram.Entry.e
     val proof_instr : Decl_expr.raw_proof_instr Gram.Entry.e
+  end
+
+(* The main entry: reads an optional vernac command *)
+val main_entry : (loc * vernac_expr) option Gram.Entry.e
 
-  (*/ MMode *)
+(**********************************************************************)
+(* Mapping formal entries into concrete ones                          *)
 
-    val vernac_eoi : vernac_expr Gram.Entry.e
-  end
+(* Binding constr entry keys to entries and symbols *)
 
-(* Binding entry names to campl4 entries *)
+val interp_constr_entry_key : bool (* true for cases_pattern *) ->
+  constr_entry_key -> grammar_object Gram.Entry.e * int option
 
-val symbol_of_production : Gramext.g_assoc option -> constr_entry ->
-  bool -> constr_production_entry -> Compat.token Gramext.g_symbol
+val symbol_of_constr_prod_entry_key : Gramext.g_assoc option ->
+  constr_entry_key -> bool -> constr_prod_entry_key ->
+    Compat.token Gramext.g_symbol
 
-(* Registering/resetting the level of an entry *)
+(* Binding general entry keys to symbols *)
 
-val find_position : 
+val symbol_of_prod_entry_key :
+  Gram.te prod_entry_key -> Gram.te Gramext.g_symbol
+
+(**********************************************************************)
+(* Interpret entry names of the form "ne_constr_list" as entry keys   *)
+
+val interp_entry_name : bool (* true to fail on unknown entry *) ->
+  int option -> string -> string -> entry_type * Gram.te prod_entry_key
+
+(**********************************************************************)
+(* Registering/resetting the level of a constr entry                  *)
+
+val find_position :
   bool (* true if for creation in pattern entry; false if in constr entry *) ->
   Gramext.g_assoc option -> int option ->
-    Gramext.position option * Gramext.g_assoc option * string option * 
+    Gramext.position option * Gramext.g_assoc option * string option *
     (* for reinitialization: *) Gramext.g_assoc option
 
 val synchronize_level_positions : unit -> unit
@@ -234,6 +291,4 @@ val register_empty_levels : bool -> int list ->
     (Gramext.position option * Gramext.g_assoc option *
      string option * Gramext.g_assoc option) list
 
-val remove_levels : int -> unit 
-
-val coerce_global_to_id : reference -> identifier
+val remove_levels : int -> unit
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
index d5357d86..06f3f381 100644
--- a/parsing/ppconstr.ml
+++ b/parsing/ppconstr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppconstr.ml 11739 2009-01-02 19:33:19Z herbelin $ *)      
+(* $Id$ *)
 
 (*i*)
 open Util
@@ -94,14 +94,14 @@ let pr_delimiters key strm =
 
 let pr_generalization bk ak c =
   let hd, tl =
-    match bk with 
+    match bk with
     | Implicit -> "{", "}"
     | Explicit -> "(", ")"
-  in (* TODO: syntax Abstraction Kind *) 
+  in (* TODO: syntax Abstraction Kind *)
     str "`" ++ str hd ++ c ++ str tl
 
 let pr_com_at n =
-  if Flags.do_beautify() && n <> 0 then comment n 
+  if Flags.do_beautify() && n <> 0 then comment n
   else mt()
 
 let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
@@ -114,7 +114,7 @@ let pr_optc pr = function
 
 let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
 
-let pr_universe = Univ.pr_uni 
+let pr_universe = Univ.pr_uni
 
 let pr_rawsort = function
   | RProp Term.Null -> str "Prop"
@@ -124,13 +124,14 @@ let pr_rawsort = function
 let pr_id = pr_id
 let pr_name = pr_name
 let pr_qualid = pr_qualid
+let pr_patvar = pr_id
 
 let pr_expl_args pr (a,expl) =
   match expl with
   | None -> pr (lapp,L) a
   | Some (_,ExplByPos (n,_id)) ->
       anomaly("Explicitation by position not implemented")
-  | Some (_,ExplByName id) -> 
+  | Some (_,ExplByName id) ->
       str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
 
 let pr_opt_type pr = function
@@ -164,16 +165,21 @@ let pr_evar pr n l =
   (match l with
    | Some l ->
        spc () ++ pr_in_comment
-         (fun l -> 
-	   str"[" ++ hov 0 (prlist_with_sep pr_coma (pr ltop) l) ++ str"]")
+         (fun l ->
+	   str"[" ++ hov 0 (prlist_with_sep pr_comma (pr ltop) l) ++ str"]")
          (List.rev l)
    | None -> mt()))
 
 let las = lapp
 let lpator = 100
+let lpatrec = 0
 
 let rec pr_patt sep inh p =
   let (strm,prec) = match p with
+  | CPatRecord (_, l) ->
+      let pp (c, p) =
+	pr_reference c ++ spc() ++ str ":=" ++ pr_patt spc (lpatrec, Any) p in
+      str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec
   | CPatAlias (_,p,id) ->
       pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
   | CPatCstr (_,c,[]) -> pr_reference c, latom
@@ -200,7 +206,7 @@ let pr_eqn pr (loc,pl,rhs) =
   spc() ++ hov 4
     (pr_with_comments loc
       (str "| " ++
-      hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl 
+      hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl
              ++ str " =>") ++
       pr_sep_com spc (pr ltop) rhs))
 
@@ -213,22 +219,22 @@ let begin_of_binders = function
   | b::_ -> begin_of_binder b
   | _ -> 0
 
-let surround_impl k p = 
+let surround_impl k p =
   match k with
   | Explicit -> str"(" ++ p ++ str")"
   | Implicit -> str"{" ++ p ++ str"}"
 
-let surround_binder k p = 
+let surround_binder k p =
   match k with
   | Default b -> hov 1 (surround_impl b p)
-  | Generalized (b, b', t) -> 
+  | Generalized (b, b', t) ->
       hov 1 (surround_impl b' (surround_impl b p))
-	
+
 let surround_implicit k p =
   match k with
   | Default Explicit -> p
   | Default Implicit -> (str"{" ++ p ++ str"}")
-  | Generalized (b, b', t) -> 
+  | Generalized (b, b', t) ->
       surround_impl b' (surround_impl b p)
 
 let pr_binder many pr (nal,k,t) =
@@ -281,7 +287,7 @@ let rec extract_lam_binders = function
       let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
       LocalRawAssum (nal,bk,t) :: bl, c
   | c -> [], c
-    
+
 let split_lambda = function
   | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c)
   | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
@@ -293,7 +299,7 @@ let rename na na' t c =
     | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c)
     | (_,Name id), (_,Anonymous) -> (na,t,c)
     | _ -> (na',t,c)
-  
+
 let split_product na' = function
   | CArrow (loc,t,c) -> (na',t,c)
   | CProdN (loc,[[na],bk,t],c) -> rename na na' t c
@@ -324,7 +330,7 @@ let merge_binders (na1,bk1,ty1) cofun (na2,bk2,ty2) codom =
           Constrextern.check_same_type ty1 ty2;
           ty2 in
   (LocalRawAssum ([na],bk1,ty), codom)
-            
+
 let rec strip_domain bvar cofun c =
   match c with
     | CArrow(loc,a,b) ->
@@ -401,13 +407,14 @@ let pr_fixdecl pr prd dangling_with_for ((_,id),(n,ro),bl,t,c) =
   let annot =
     match ro with
 	CStructRec ->
-	  if List.length bl > 1 && n <> None then 
+	  if List.length bl > 1 && n <> None then
 	    spc() ++ str "{struct " ++ pr_id (snd (Option.get n)) ++ str"}"
-	  else mt() 
+	  else mt()
       | CWfRec c ->
 	  spc () ++ str "{wf " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}"
-      | CMeasureRec c ->
-	  spc () ++ str "{measure " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}"
+      | CMeasureRec (m,r) ->
+	  spc () ++ str "{measure " ++ pr lsimple m ++ pr_id (snd (Option.get n)) ++
+	    (match r with None -> mt() | Some r -> str" on " ++ pr lsimple r) ++ str"}"
   in
     pr_recursive_decl pr prd dangling_with_for id bl annot t c
 
@@ -427,11 +434,11 @@ let is_var id = function
   | _ -> false
 
 let tm_clash = function
-  | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) 
+  | (CRef (Ident (_,id)), Some (CApp (_,_,nal)))
       when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false)
 	nal
       -> Some id
-  | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) 
+  | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal)))
       when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false)
 	nal
       -> Some id
@@ -444,7 +451,7 @@ let pr_asin pr (na,indnalopt) =
   (match indnalopt with
     | None -> mt ()
     | Some t -> spc () ++ str "in " ++ pr lsimple t)
-    
+
 let pr_case_item pr (tm,asin) =
   hov 0 (pr (lcast,E) tm ++ pr_asin pr asin)
 
@@ -473,7 +480,7 @@ let pr_appexpl pr f l =
 
 let pr_app pr a l =
   hov 2 (
-    pr (lapp,L) a  ++ 
+    pr (lapp,L) a  ++
     prlist (fun a -> spc () ++ pr_expl_args pr a) l)
 
 let pr_forall () =
@@ -486,18 +493,24 @@ let pr_fun () =
 
 let pr_fun_sep = lazy (if !Flags.unicode_syntax then str "," else str " =>")
 
-let rec pr sep inherited a =
+
+let pr_dangling_with_for sep pr inherited a =
+  match a with
+  | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
+  | _ -> pr sep inherited a
+
+let pr pr sep inherited a =
   let (strm,prec) = match a with
   | CRef r -> pr_reference r, latom
   | CFix (_,id,fix) ->
       hov 0 (str"fix " ++
              pr_recursive
-               (pr_fixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) fix),
+               (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix),
       lfix
   | CCoFix (_,id,cofix) ->
       hov 0 (str "cofix " ++
              pr_recursive
-              (pr_cofixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) cofix),
+              (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix),
       lfix
   | CArrow (_,a,b) ->
       hov 0 (pr mt (larrow,L) a ++ str " ->" ++
@@ -547,29 +560,29 @@ let rec pr sep inherited a =
       let c,l1 = list_sep_last l1 in
       assert (snd c = None);
       let p = pr_proj (pr mt) pr_app (fst c) f l1 in
-      if l2<>[] then 
+      if l2<>[] then
 	p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp
       else
 	p, lproj
   | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp
   | CRecord (_,w,l) ->
-      let beg = 
+      let beg =
 	match w with
-	| None -> spc () 
+	| None -> spc ()
 	| Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc ()
       in
-	hv 0 (str"{" ++ beg ++	       
-		 prlist_with_sep (fun () -> spc () ++ str";" ++ spc ())
-		 (fun ((_,id), c) -> pr_id id ++ spc () ++ str":=" ++ spc () ++ pr spc ltop c)
-		 l), latom
+	hv 0 (str"{|" ++ beg ++
+	      prlist_with_sep pr_semicolon
+		(fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l
+	      ++ str" |}"), latom
 
   | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) ->
       hv 0 (
-	str "let '" ++ 
-	  hov 0 (pr_patt ltop p ++ 
-		 pr_asin (pr_dangling_with_for mt) asin ++
-		 str " :=" ++ pr spc ltop c ++ 
-		 pr_case_type (pr_dangling_with_for mt) rtntypopt ++
+	str "let '" ++
+	  hov 0 (pr_patt ltop p ++
+		 pr_asin (pr_dangling_with_for mt pr) asin ++
+		 str " :=" ++ pr spc ltop c ++
+		 pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++
 		 str " in" ++ pr spc ltop b)),
 	lletpattern
   | CCases(_,_,rtntypopt,c,eqns) ->
@@ -577,8 +590,8 @@ let rec pr sep inherited a =
         (hv 0 (str "match" ++ brk (1,2) ++
 		  hov 0 (
 		    prlist_with_sep sep_v
-		      (pr_case_item (pr_dangling_with_for mt)) c
-		    ++ pr_case_type (pr_dangling_with_for mt) rtntypopt) ++
+		      (pr_case_item (pr_dangling_with_for mt pr)) c
+		    ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt) ++
 		  spc () ++ str "with") ++
 		  prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"),
       latom
@@ -601,7 +614,7 @@ let rec pr sep inherited a =
 	hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
 	hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
       lif
-     
+
   | CHole _ -> str "_", latom
   | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom
   | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
@@ -625,12 +638,6 @@ let rec pr sep inherited a =
   pr_with_comments loc
     (sep() ++ if prec_less prec inherited then strm else surround strm)
 
-and pr_dangling_with_for sep inherited a =
-  match a with
-  | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
-  | _ -> pr sep inherited a
-
-let pr = pr mt
 
 let rec strip_context n iscast t =
   if n = 0 then
@@ -644,7 +651,7 @@ let rec strip_context n iscast t =
 	else
 	let bl', c = strip_context (n-n') iscast
 	  (if bll=[] then c else CLambdaN (loc,bll,c)) in
-	LocalRawAssum (nal,bk,t) :: bl', c 
+	LocalRawAssum (nal,bk,t) :: bl', c
     | CProdN (loc,(nal,bk,t)::bll,c) ->
 	let n' = List.length nal in
 	if n' > n then
@@ -653,12 +660,12 @@ let rec strip_context n iscast t =
 	else
 	let bl', c = strip_context (n-n') iscast
 	  (if bll=[] then c else CProdN (loc,bll,c)) in
-	LocalRawAssum (nal,bk,t) :: bl', c 
+	LocalRawAssum (nal,bk,t) :: bl', c
     | CArrow (loc,t,c) ->
 	let bl', c = strip_context (n-1) iscast c in
 	LocalRawAssum ([loc,Anonymous],default_binder_kind,t) :: bl', c
     | CCast (_,c,_) -> strip_context n false c
-    | CLetIn (_,na,b,c) -> 
+    | CLetIn (_,na,b,c) ->
 	let bl', c = strip_context (n-1) iscast c in
 	LocalRawDef (na,b) :: bl', c
     | _ -> anomaly "strip_context"
@@ -670,6 +677,11 @@ type term_pr = {
   pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
 }
 
+type precedence =  Ppextend.precedence * Ppextend.parenRelation
+let modular_constr_pr = pr
+let rec fix rf x =rf (fix rf) x
+let pr = fix modular_constr_pr mt
+
 let default_term_pr = {
   pr_constr_expr   = pr lsimple;
   pr_lconstr_expr  = pr ltop;
@@ -690,16 +702,13 @@ let pr_cases_pattern_expr = pr_patt ltop
 
 let pr_binders = pr_undelimited_binders (pr ltop)
 
-let pr_with_occurrences_with_trailer pr occs trailer =
+let pr_with_occurrences pr occs =
   match occs with
-    ((false,[]),c) -> pr c ++ trailer
+    ((false,[]),c) -> pr c
   | ((nowhere_except_in,nl),c) ->
       hov 1 (pr c ++ spc() ++ str"at " ++
         (if nowhere_except_in then mt() else str "- ") ++
-        hov 0 (prlist_with_sep spc (pr_or_var int) nl) ++ trailer)
-
-let pr_with_occurrences pr occs = 
-  pr_with_occurrences_with_trailer pr occs (mt())
+        hov 0 (prlist_with_sep spc (pr_or_var int) nl))
 
 let pr_red_flag pr r =
   (if r.rBeta then pr_arg str "beta" else mt ()) ++
@@ -716,34 +725,34 @@ open Genarg
 
 let pr_metaid id = str"?" ++ pr_id id
 
-let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function
+let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function
   | Red false -> str "red"
   | Hnf -> str "hnf"
-  | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_constr) o  
+  | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_pattern) o
   | Cbv f ->
       if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
 	str "compute"
       else
 	hov 1 (str "cbv" ++ pr_red_flag pr_ref f)
-  | Lazy f -> 
+  | Lazy f ->
       hov 1 (str "lazy" ++ pr_red_flag pr_ref f)
   | Unfold l ->
       hov 1 (str "unfold" ++ spc() ++
-             prlist_with_sep pr_coma (pr_with_occurrences pr_ref) l)
+             prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l)
   | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l)
   | Pattern l ->
       hov 1 (str "pattern" ++
-        pr_arg (prlist_with_sep pr_coma (pr_with_occurrences pr_constr)) l)
-        
+        pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l)
+
   | Red true -> error "Shouldn't be accessible from user."
   | ExtraRedExpr s -> str s
   | CbvVm -> str "vm_compute"
 
-let rec pr_may_eval test prc prlc pr2 = function
+let rec pr_may_eval test prc prlc pr2 pr3 = function
   | ConstrEval (r,c) ->
       hov 0
         (str "eval" ++ brk (1,1) ++
-         pr_red_expr (prc,prlc,pr2) r ++
+         pr_red_expr (prc,prlc,pr2,pr3) r ++
 	 str " in" ++ spc() ++ prc c)
   | ConstrContext ((_,id),c) ->
       hov 0
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
index 0d0c8f56..b33ed682 100644
--- a/parsing/ppconstr.mli
+++ b/parsing/ppconstr.mli
@@ -6,8 +6,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: ppconstr.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
+
+(*i $Id$ i*)
 
 open Pp
 open Environ
@@ -28,11 +28,11 @@ val extract_def_binders :
   constr_expr -> constr_expr ->
   local_binder list * constr_expr * constr_expr
 val split_fix :
-  int -> constr_expr -> constr_expr -> 
+  int -> constr_expr -> constr_expr ->
   local_binder list *  constr_expr * constr_expr
 
 val prec_less : int -> int * Ppextend.parenRelation -> bool
- 
+
 val pr_tight_coma : unit -> std_ppcmds
 
 val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
@@ -51,17 +51,16 @@ val pr_sep_com :
 val pr_id : identifier -> std_ppcmds
 val pr_name : name -> std_ppcmds
 val pr_qualid : qualid -> std_ppcmds
+val pr_patvar : patvar -> std_ppcmds
 
 val pr_with_occurrences :
   ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds
-val pr_with_occurrences_with_trailer :
-  ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds -> std_ppcmds
 val pr_red_expr :
-  ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) ->
-    ('a,'b) red_expr_gen -> std_ppcmds
+  ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
+    ('a,'b,'c) red_expr_gen -> std_ppcmds
 val pr_may_eval :
-  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> 
-    ('a,'b) may_eval -> std_ppcmds
+  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+  ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds
 
 val pr_rawsort : rawsort -> std_ppcmds
 
@@ -81,3 +80,24 @@ type term_pr = {
 
 val set_term_pr : term_pr -> unit
 val default_term_pr : term_pr
+
+(* The modular constr printer.
+    [modular_constr_pr pr s p t] prints the head of the term [t] and calls
+    [pr] on its subterms.
+    [s] is typically {!Pp.mt} and [p] is [lsimple] for "constr" printers and [ltop]
+    for "lconstr" printers (spiwack: we might need more specification here).
+    We can make a new modular constr printer by overriding certain branches,
+    for instance if we want to build a printer which prints "Prop" as "Omega"
+    instead we can proceed as follows:
+    let my_modular_constr_pr pr s p = function
+      | CSort (_,RProp Null) -> str "Omega"
+      | t -> modular_constr_pr pr s p t
+    Which has the same type. We can turn a modular printer into a printer by
+    taking its fixpoint. *)
+
+type precedence
+val lsimple : precedence
+val ltop : precedence
+val modular_constr_pr :
+               ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
+                (unit->std_ppcmds) -> precedence  -> constr_expr -> std_ppcmds
diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml
index 3b9a002f..abcbedfa 100644
--- a/parsing/ppdecl_proof.ml
+++ b/parsing/ppdecl_proof.ml
@@ -6,45 +6,45 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppdecl_proof.ml 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id$ *)
 
-open Util 
+open Util
 open Pp
 open Decl_expr
-open Names 
+open Names
 open Nameops
 
 let pr_constr = Printer.pr_constr_env
 let pr_tac = Pptactic.pr_glob_tactic
-let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr 
+let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr
 
 let pr_label = function
     Anonymous -> mt ()
-  | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () 
+  | Name id -> pr_id id ++ spc () ++ str ":" ++ spc ()
 
 let pr_justification_items env = function
     Some [] -> mt ()
-  | Some (_::_ as l) -> 
-      spc () ++ str "by" ++ spc () ++  
+  | Some (_::_ as l) ->
+      spc () ++ str "by" ++ spc () ++
 	prlist_with_sep (fun () -> str ",") (pr_constr env) l
   | None -> spc () ++ str "by *"
 
 let pr_justification_method env = function
     None -> mt ()
-  | Some tac -> 
+  | Some tac ->
       spc () ++ str "using" ++ spc () ++ pr_tac env tac
 
-let pr_statement pr_it env st = 
+let pr_statement pr_it env st =
   pr_label st.st_label ++ pr_it env st.st_it
 
 let pr_or_thesis pr_this env = function
     Thesis Plain -> str "thesis"
-  | Thesis (For id) -> 
-      str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id 
+  | Thesis (For id) ->
+      str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id
   | This c -> pr_this env c
 
-let pr_cut pr_it env c = 
-  hov 1 (pr_it env c.cut_stat) ++ 
+let pr_cut pr_it env c =
+  hov 1 (pr_it env c.cut_stat) ++
     pr_justification_items env c.cut_by ++
     pr_justification_method env c.cut_using
 
@@ -54,45 +54,45 @@ let type_or_thesis = function
 
 let _I x = x
 
-let rec print_hyps pconstr gtyp env sep _be _have hyps = 
+let rec print_hyps pconstr gtyp env sep _be _have hyps =
   let pr_sep = if sep then str "and" ++ spc () else mt () in
-    match hyps with 
-	(Hvar _ ::_) as rest -> 
-	  spc () ++ pr_sep ++ str _have ++ 
+    match hyps with
+	(Hvar _ ::_) as rest ->
+	  spc () ++ pr_sep ++ str _have ++
 	    print_vars pconstr gtyp env false _be _have rest
-      | Hprop st :: rest -> 
+      | Hprop st :: rest ->
 	  begin
 	    let nenv =
 	      match st.st_label with
 		  Anonymous -> env
 		| Name id -> Environ.push_named (id,None,gtyp st.st_it) env in
-	      spc() ++ pr_sep ++ pr_statement pconstr env st ++ 
+	      spc() ++ pr_sep ++ pr_statement pconstr env st ++
 		print_hyps pconstr gtyp nenv true _be _have rest
 	  end
       | [] -> mt ()
 
 and print_vars pconstr gtyp env sep _be _have vars =
   match vars with
-    Hvar st :: rest -> 
+    Hvar st :: rest ->
       begin
-	let nenv = 
+	let nenv =
 	  match st.st_label with
 	      Anonymous -> anomaly "anonymous variable"
 	    | Name id -> Environ.push_named (id,None,st.st_it) env in
-	let pr_sep = if sep then pr_coma () else mt () in
+	let pr_sep = if sep then pr_comma () else mt () in
 		spc() ++ pr_sep ++
 		   pr_statement pr_constr env st ++
 		  print_vars pconstr gtyp nenv true _be _have rest
       end
    | (Hprop _ :: _) as rest ->
-      let _st =  if _be then 
-	str "be such that" 
-      else 
+      let _st =  if _be then
+	str "be such that"
+      else
 	str "such that" in
 	spc() ++ _st ++  print_hyps pconstr gtyp env false _be _have rest
   | [] -> mt ()
 
-let pr_suffices_clause env (hyps,c) = 
+let pr_suffices_clause env (hyps,c) =
     print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++
        str "to show" ++ spc () ++ pr_or_thesis pr_constr env c
 
@@ -110,68 +110,68 @@ let pr_side = function
 
 let rec pr_bare_proof_instr _then _thus env = function
   | Pescape -> str "escape"
-  | Pthen i -> pr_bare_proof_instr true _thus env i 
-  | Pthus i -> pr_bare_proof_instr _then true env i 
+  | Pthen i -> pr_bare_proof_instr true _thus env i
+  | Pthus i -> pr_bare_proof_instr _then true env i
   | Phence i -> pr_bare_proof_instr true true env i
-  | Pcut c -> 
+  | Pcut c ->
       begin
 	match _then,_thus with
-	    false,false -> str "have" ++ spc () ++ 
+	    false,false -> str "have" ++ spc () ++
 	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
-	  | false,true  -> str "thus" ++ spc () ++ 
+	  | false,true  -> str "thus" ++ spc () ++
 	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
 	  | true,false  -> str "then" ++ spc () ++
 	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
-	  | true,true   -> str "hence" ++ spc () ++ 
+	  | true,true   -> str "hence" ++ spc () ++
 	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
       end
   | Psuffices c ->
-      str "suffices" ++  pr_cut pr_suffices_clause env c 
+      str "suffices" ++  pr_cut pr_suffices_clause env c
   | Prew (sid,c) ->
       (if _thus then str "thus" else str "    ") ++ spc () ++
 	pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c
-  | Passume hyps -> 
+  | Passume hyps ->
       str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps
-  | Plet hyps -> 
+  | Plet hyps ->
       str "let" ++ print_vars pr_constr _I env false true "let" hyps
   | Pclaim st ->
       str "claim" ++ spc () ++ pr_statement pr_constr env st
   | Pfocus st ->
       str "focus on" ++ spc () ++ pr_statement pr_constr env st
   | Pconsider (id,hyps) ->
-      str "consider" ++ print_vars pr_constr _I env false false "consider" hyps 
-      ++ spc () ++ str "from " ++ pr_constr env id 
+      str "consider" ++ print_vars pr_constr _I env false false "consider" hyps
+      ++ spc () ++ str "from " ++ pr_constr env id
   | Pgiven hyps ->
       str "given" ++ print_vars pr_constr _I env false false "given" hyps
-  | Ptake witl -> 
-      str "take" ++ spc () ++ 
-	prlist_with_sep pr_coma (pr_constr env) witl
+  | Ptake witl ->
+      str "take" ++ spc () ++
+	prlist_with_sep pr_comma (pr_constr env) witl
   | Pdefine (id,args,body) ->
-      str "define" ++ spc () ++ pr_id id ++ spc () ++ 
-	prlist_with_sep spc 
-	(fun st -> str "(" ++ 
-	   pr_statement pr_constr env st ++ str ")") args ++ spc () ++ 
-	str "as" ++ (pr_constr env body) 
-  | Pcast (id,typ) -> 
-      str "reconsider" ++ spc () ++ 
-	pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ 
-	str "as" ++ spc () ++ (pr_constr env typ)  
-  | Psuppose hyps -> 
-      str "suppose" ++ 
+      str "define" ++ spc () ++ pr_id id ++ spc () ++
+	prlist_with_sep spc
+	(fun st -> str "(" ++
+	   pr_statement pr_constr env st ++ str ")") args ++ spc () ++
+	str "as" ++ (pr_constr env body)
+  | Pcast (id,typ) ->
+      str "reconsider" ++ spc () ++
+	pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++
+	str "as" ++ spc () ++ (pr_constr env typ)
+  | Psuppose hyps ->
+      str "suppose" ++
 	print_hyps pr_constr _I env false false "we have" hyps
   | Pcase (params,pat,hyps) ->
       str "suppose it is" ++ spc () ++ pr_pat pat ++
-	(if params = [] then mt () else 
-	   (spc () ++ str "with" ++ spc () ++ 
-	      prlist_with_sep spc 
-	      (fun st -> str "(" ++ 
-		 pr_statement pr_constr env st ++ str ")") params ++ spc ())) 
+	(if params = [] then mt () else
+	   (spc () ++ str "with" ++ spc () ++
+	      prlist_with_sep spc
+	      (fun st -> str "(" ++
+		 pr_statement pr_constr env st ++ str ")") params ++ spc ()))
       ++
-	(if hyps = [] then mt () else 
-	   (spc () ++ str "and" ++ 
+	(if hyps = [] then mt () else
+	   (spc () ++ str "and" ++
 	      print_hyps (pr_or_thesis pr_constr) type_or_thesis
 	      env false false "we have" hyps))
-  | Pper (et,c) -> 
+  | Pper (et,c) ->
       str "per" ++ spc () ++ pr_elim_type et ++ spc () ++
       pr_casee env c
   | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et
@@ -184,7 +184,7 @@ let pr_emph = function
   | 3 -> str "*** "
   | _ -> anomaly "unknown emphasis"
 
-let pr_proof_instr env instr = 
-  pr_emph instr.emph ++ spc () ++ 
+let pr_proof_instr env instr =
+  pr_emph instr.emph ++ spc () ++
     pr_bare_proof_instr false false env instr.instr
 
diff --git a/parsing/ppdecl_proof.mli b/parsing/ppdecl_proof.mli
index b0f0e110..fd6fb663 100644
--- a/parsing/ppdecl_proof.mli
+++ b/parsing/ppdecl_proof.mli
@@ -1,2 +1,2 @@
 
-val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds  
+val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
index f52ebc76..466c69eb 100644
--- a/parsing/pptactic.ml
+++ b/parsing/pptactic.ml
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pptactic.ml 12581 2009-12-13 15:02:33Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Names
-open Nameops
+open Namegen
 open Util
 open Tacexpr
 open Rawterm
@@ -36,8 +36,8 @@ let declare_extra_tactic_pprule (s,tags,prods) =
 let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags)
 
 type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) -> 
-    (constr_expr -> std_ppcmds) -> 
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
     (tolerability -> raw_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
@@ -48,8 +48,8 @@ type 'a glob_extra_genarg_printer =
     'a -> std_ppcmds
 
 type 'a extra_genarg_printer =
-    (Term.constr -> std_ppcmds) -> 
-    (Term.constr -> std_ppcmds) -> 
+    (Term.constr -> std_ppcmds) ->
+    (Term.constr -> std_ppcmds) ->
     (tolerability -> glob_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
@@ -57,7 +57,7 @@ let genarg_pprule = ref Stringmap.empty
 
 let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) =
   let s = match unquote wit with
-    | ExtraArgType s -> s 
+    | ExtraArgType s -> s
     | _ -> error
 	"Can declare a pretty-printing rule only for extra argument types."
   in
@@ -84,13 +84,13 @@ let pr_or_by_notation f = function
 
 let pr_located pr (loc,x) = pr x
 
-let pr_evaluable_reference = function 
+let pr_evaluable_reference = function
   | EvalVarRef id -> pr_id id
   | EvalConstRef sp -> pr_global (Libnames.ConstRef sp)
 
 let pr_quantified_hypothesis = function
   | AnonHyp n -> int n
-  | NamedHyp id -> pr_id id 
+  | NamedHyp id -> pr_id id
 
 let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
 
@@ -103,7 +103,7 @@ let pr_bindings prc prlc = function
       brk (1,1) ++ str "with" ++ brk (1,1) ++
       prlist_with_sep spc prc l
   | ExplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++ 
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
         prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | NoBindings -> mt ()
 
@@ -112,7 +112,7 @@ let pr_bindings_no_with prc prlc = function
       brk (1,1) ++
       prlist_with_sep spc prc l
   | ExplicitBindings l ->
-      brk (1,1) ++ 
+      brk (1,1) ++
         prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | NoBindings -> mt ()
 
@@ -139,7 +139,7 @@ let out_bindings = function
 
 let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c
 
-let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argument) =
+let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) =
   match Genarg.genarg_tag x with
   | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false")
   | IntArgType -> int (out_gen rawwit_int x)
@@ -153,35 +153,36 @@ let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argu
   | SortArgType -> pr_rawsort (out_gen rawwit_sort x)
   | ConstrArgType -> prc (out_gen rawwit_constr x)
   | ConstrMayEvalArgType ->
-      pr_may_eval prc prlc (pr_or_by_notation prref)
+      pr_may_eval prc prlc (pr_or_by_notation prref) prpat
         (out_gen rawwit_constr_may_eval x)
   | QuantHypArgType -> pr_quantified_hypothesis (out_gen rawwit_quant_hyp x)
   | RedExprArgType ->
-      pr_red_expr (prc,prlc,pr_or_by_notation prref)
+      pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat)
         (out_gen rawwit_red_expr x)
   | OpenConstrArgType b -> prc (snd (out_gen (rawwit_open_constr_gen b) x))
-  | ConstrWithBindingsArgType -> 
+  | ConstrWithBindingsArgType ->
       pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x)
-  | BindingsArgType -> 
+  | BindingsArgType ->
       pr_bindings_no_with prc prlc (out_gen rawwit_bindings x)
-  | List0ArgType _ -> 
-      hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref)
+  | List0ArgType _ ->
+      hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref)
 	(fold_list0 (fun a l -> a::l) x []))
   | List1ArgType _ ->
-      hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref)
+      hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref)
 	(fold_list1 (fun a l -> a::l) x []))
-  | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prref) (mt()) x)
+  | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prpat prref) (mt()) x)
   | PairArgType _ ->
       hov 0
         (fold_pair
-	  (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prref) [a;b])
+	  (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prpat prref)
+            [a;b])
 	  x)
-  | ExtraArgType s -> 
+  | ExtraArgType s ->
       try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str "[no printer for " ++ str s ++ str "]"
 
 
-let rec pr_glob_generic prc prlc prtac x =
+let rec pr_glob_generic prc prlc prtac prpat x =
   match Genarg.genarg_tag x with
   | BoolArgType -> str (if out_gen globwit_bool x then "true" else "false")
   | IntArgType -> int (out_gen globwit_int x)
@@ -196,38 +197,38 @@ let rec pr_glob_generic prc prlc prtac x =
   | ConstrArgType -> prc (out_gen globwit_constr x)
   | ConstrMayEvalArgType ->
       pr_may_eval prc prlc
-        (pr_or_var (pr_and_short_name pr_evaluable_reference))
+        (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat
         (out_gen globwit_constr_may_eval x)
   | QuantHypArgType ->
       pr_quantified_hypothesis (out_gen globwit_quant_hyp x)
   | RedExprArgType ->
-      pr_red_expr 
-        (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference))
+      pr_red_expr
+        (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat)
         (out_gen globwit_red_expr x)
   | OpenConstrArgType b -> prc (snd (out_gen (globwit_open_constr_gen b) x))
-  | ConstrWithBindingsArgType -> 
+  | ConstrWithBindingsArgType ->
       pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x)
-  | BindingsArgType -> 
+  | BindingsArgType ->
       pr_bindings_no_with prc prlc (out_gen globwit_bindings x)
-  | List0ArgType _ -> 
-      hov 0 (pr_sequence (pr_glob_generic prc prlc prtac)
+  | List0ArgType _ ->
+      hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat)
 	(fold_list0 (fun a l -> a::l) x []))
   | List1ArgType _ ->
-      hov 0 (pr_sequence (pr_glob_generic prc prlc prtac)
+      hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat)
 	(fold_list1 (fun a l -> a::l) x []))
-  | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac) (mt()) x)
+  | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac prpat) (mt()) x)
   | PairArgType _ ->
       hov 0
         (fold_pair
-	  (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac) [a;b])
+	  (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac prpat) [a;b])
 	  x)
-  | ExtraArgType s -> 
+  | ExtraArgType s ->
       try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str "[no printer for " ++ str s ++ str "]"
 
 open Closure
 
-let rec pr_generic prc prlc prtac x =
+let rec pr_generic prc prlc prtac prpat x =
   match Genarg.genarg_tag x with
   | BoolArgType -> str (if out_gen wit_bool x then "true" else "false")
   | IntArgType -> int (out_gen wit_int x)
@@ -243,25 +244,27 @@ let rec pr_generic prc prlc prtac x =
   | ConstrMayEvalArgType -> prc (out_gen wit_constr_may_eval x)
   | QuantHypArgType -> pr_quantified_hypothesis (out_gen wit_quant_hyp x)
   | RedExprArgType ->
-      pr_red_expr (prc,prlc,pr_evaluable_reference) (out_gen wit_red_expr x)
+      pr_red_expr (prc,prlc,pr_evaluable_reference,prpat)
+        (out_gen wit_red_expr x)
   | OpenConstrArgType b -> prc (snd (out_gen (wit_open_constr_gen b) x))
   | ConstrWithBindingsArgType ->
-      let (c,b) = out_gen wit_constr_with_bindings x in
-      pr_with_bindings prc prlc (c,out_bindings b)
-  | BindingsArgType -> 
-      pr_bindings_no_with prc prlc (out_bindings (out_gen wit_bindings x))
+      let (c,b) = (out_gen wit_constr_with_bindings x).Evd.it in
+      pr_with_bindings prc prlc (c,b)
+  | BindingsArgType ->
+      pr_bindings_no_with prc prlc (out_gen wit_bindings x).Evd.it
   | List0ArgType _ ->
-      hov 0 (pr_sequence (pr_generic prc prlc prtac)
+      hov 0 (pr_sequence (pr_generic prc prlc prtac prpat)
 	(fold_list0 (fun a l -> a::l) x []))
   | List1ArgType _ ->
-      hov 0 (pr_sequence (pr_generic prc prlc prtac)
+      hov 0 (pr_sequence (pr_generic prc prlc prtac prpat)
 	(fold_list1 (fun a l -> a::l) x []))
-  | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac) (mt()) x)
+  | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac prpat) (mt()) x)
   | PairArgType _ ->
       hov 0
-        (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac) [a;b])
+        (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac prpat)
+          [a;b])
 	  x)
-  | ExtraArgType s -> 
+  | ExtraArgType s ->
       try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str "[no printer for " ++ str s ++ str "]"
 
@@ -275,7 +278,7 @@ let pr_tacarg_using_rule pr_gen l=
   pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l)
 
 let pr_extend_gen pr_gen lev s l =
-  try 
+  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
@@ -283,12 +286,12 @@ let pr_extend_gen pr_gen lev s l =
   with Not_found ->
     str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)"
 
-let pr_raw_extend prc prlc prtac = 
-  pr_extend_gen (pr_raw_generic prc prlc prtac pr_reference)
-let pr_glob_extend prc prlc prtac =
-  pr_extend_gen (pr_glob_generic prc prlc prtac)
-let pr_extend prc prlc prtac =
-  pr_extend_gen (pr_generic (fun c -> prc (Evd.empty,c)) (fun c -> prlc (Evd.empty,c)) prtac)
+let pr_raw_extend prc prlc prtac prpat =
+  pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference)
+let pr_glob_extend prc prlc prtac prpat =
+  pr_extend_gen (pr_glob_generic prc prlc prtac prpat)
+let pr_extend prc prlc prtac prpat =
+  pr_extend_gen (pr_generic prc prlc prtac prpat)
 
 (**********************************************************************)
 (* The tactic printer                                                 *)
@@ -320,14 +323,14 @@ let pr_arg pr x = spc () ++ pr x
 let pr_ltac_constant sp =
   pr_qualid (Nametab.shortest_qualid_of_tactic sp)
 
-let pr_evaluable_reference_env env = function 
+let pr_evaluable_reference_env env = function
   | EvalVarRef id -> pr_id id
-  | EvalConstRef sp -> 
+  | EvalConstRef sp ->
       Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp)
 
 let pr_quantified_hypothesis = function
   | AnonHyp n -> int n
-  | NamedHyp id -> pr_id id 
+  | NamedHyp id -> pr_id id
 
 let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
 
@@ -362,7 +365,7 @@ let pr_with_constr prc = function
 let pr_with_induction_names = function
   | None, None -> mt ()
   | eqpat, ipat ->
-      spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++ 
+      spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++
                        pr_opt pr_intro_pattern ipat)
 
 let pr_as_intro_pattern ipat =
@@ -410,23 +413,27 @@ let pr_by_tactic prt = function
 let pr_hyp_location pr_id = function
   | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
   | occs, InHypTypeOnly ->
-      spc () ++ 
+      spc () ++
       pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs
   | occs, InHypValueOnly ->
-      spc () ++ 
+      spc () ++
       pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs
 
 let pr_in pp = spc () ++ hov 0 (str "in" ++ pp)
 
-let pr_simple_clause pr_id = function
+let pr_simple_hyp_clause pr_id = function
   | [] -> mt ()
   | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
 
 let pr_in_hyp_as pr_id = function
   | None -> mt ()
-  | Some (id,ipat) -> pr_simple_clause pr_id [id] ++ pr_as_ipat ipat
+  | Some (id,ipat) -> pr_simple_hyp_clause pr_id [id] ++ pr_as_ipat ipat
 
-let pr_clauses pr_id = function
+let pr_clauses default_is_concl pr_id = function
+  | { onhyps=Some []; concl_occs=occs }
+      when occs = all_occurrences_expr & default_is_concl = Some true -> mt ()
+  | { onhyps=None; concl_occs=occs }
+      when occs = all_occurrences_expr & default_is_concl = Some false -> mt ()
   | { onhyps=None; concl_occs=occs } ->
       if occs = no_occurrences_expr then pr_in (str " * |-")
       else pr_in (pr_with_occurrences (fun () -> str " *") (occs,()))
@@ -441,13 +448,13 @@ let pr_clause_pattern pr_id = function
   | (glopt,l) ->
       str " in" ++
       prlist
-        (fun (id,nl) -> prlist (pr_arg int) nl 
+        (fun (id,nl) -> prlist (pr_arg int) nl
 	  ++ spc () ++ pr_id id) l ++
         pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt
 
 let pr_orient b = if b then mt () else str " <-"
 
-let pr_multi = function 
+let pr_multi = function
   | Precisely 1 -> mt ()
   | Precisely n -> pr_int n ++ str "!"
   | UpTo n -> pr_int n ++ str "?"
@@ -485,15 +492,15 @@ let pr_match_rule m pr pr_pat = function
       spc () ++ str "=>" ++ brk (1,4) ++ pr t
 (*
   | Pat (rl,mp,t) ->
-      hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl ++
-        (if rl <> [] then spc () else mt ()) ++ 
+      hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++
+        (if rl <> [] then spc () else mt ()) ++
          hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
 	 str "=>" ++ brk (1,4) ++ pr t))
 *)
   | Pat (rl,mp,t) ->
       hov 0 (
-	hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl) ++
-        (if rl <> [] then spc () else mt ()) ++ 
+	hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++
+        (if rl <> [] then spc () else mt ()) ++
         hov 0 (
 	  str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
 	  str "=>" ++ brk (1,4) ++ pr t))
@@ -504,7 +511,7 @@ let pr_funvar = function
   | Some id -> spc () ++ pr_id id
 
 let pr_let_clause k pr (id,(bl,t)) =
-  hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ 
+  hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++
          str " :=" ++ brk (1,1) ++ pr (TacArg t))
 
 let pr_let_clauses recflag pr = function
@@ -538,8 +545,8 @@ let pr_hintbases = function
 
 let pr_auto_using prc = function
   | [] -> mt ()
-  | l -> spc () ++ 
-      hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_coma prc l)
+  | l -> spc () ++
+      hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
 
 let pr_autoarg_adding = function
   | [] -> mt ()
@@ -555,12 +562,6 @@ let pr_autoarg_usingTDB = function
   | true -> spc () ++ str "using tdb"
   | false -> mt ()
 
-let rec pr_tacarg_using_rule pr_gen = function
-  | Egrammar.TacTerm s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
-  | Egrammar.TacNonTerm _ :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al)
-  | [], [] -> mt ()
-  | _ -> failwith "Inconsistent arguments of extended tactic"
-
 let pr_then () = str ";"
 
 let ltop = (5,E)
@@ -587,7 +588,7 @@ open Closure
     used only at the glob and typed level: it is used to feed the
     constr printers *)
 
-let make_pr_tac 
+let make_pr_tac
   (pr_tac_level,pr_constr,pr_lconstr,pr_pat,
    pr_cst,pr_ind,pr_ref,pr_ident,
    pr_extend,strip_prod_binders) env =
@@ -596,6 +597,8 @@ let make_pr_tac
    constr and cst printers; hence we can make some abbreviations *)
 let pr_constr = pr_constr env in
 let pr_lconstr = pr_lconstr env in
+let pr_lpat = pr_pat true in
+let pr_pat = pr_pat false in
 let pr_cst = pr_cst env in
 let pr_ind = pr_ind env in
 let pr_tac_level = pr_tac_level env in
@@ -604,8 +607,8 @@ let pr_tac_level = pr_tac_level env in
 let pr_bindings = pr_bindings pr_lconstr pr_constr in
 let pr_ex_bindings = pr_bindings_gen true pr_lconstr pr_constr in
 let pr_with_bindings = pr_with_bindings pr_lconstr pr_constr in
-let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level in
-let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst) in
+let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level pr_pat in
+let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst,pr_pat) in
 
 let pr_constrarg c = spc () ++ pr_constr c in
 let pr_lconstrarg c = spc () ++ pr_lconstr c in
@@ -632,7 +635,7 @@ let pr_fix_tac (id,n,c) =
           match list_chop (n-1) nal with
               _, (_,Name id) :: _ -> id, (nal,ty)::bll
             | bef, (loc,Anonymous) :: aft ->
-                let id = next_ident_away_from (id_of_string"y") avoid in
+                let id = next_ident_away (id_of_string"y") avoid in
                 id, ((bef@(loc,Name id)::aft, ty)::bll)
             | _ -> assert false
         else
@@ -650,7 +653,7 @@ let pr_fix_tac (id,n,c) =
   let annot =
     if List.length names = 1 then mt()
     else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in
-  hov 1 (str"(" ++ pr_id id ++ 
+  hov 1 (str"(" ++ pr_id id ++
         prlist pr_binder_fix bll ++ annot ++ str" :" ++
         pr_lconstrarg ty ++ str")") in
 (*  spc() ++
@@ -687,7 +690,7 @@ and pr_atom1 = function
 
   (* Basic tactics *)
   | TacIntroPattern [] as t -> pr_atom0 t
-  | TacIntroPattern (_::_ as p) -> 
+  | TacIntroPattern (_::_ as p) ->
       hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
   | TacIntrosUntil h ->
       hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h)
@@ -701,11 +704,11 @@ and pr_atom1 = function
   | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c)
   | TacApply (a,ev,cb,inhyp) ->
       hov 1 ((if a then mt() else str "simple ") ++
-             str (with_evars ev "apply") ++ spc () ++ 
-             prlist_with_sep pr_coma pr_with_bindings cb ++
+             str (with_evars ev "apply") ++ spc () ++
+             prlist_with_sep pr_comma pr_with_bindings cb ++
              pr_in_hyp_as pr_ident inhyp)
   | TacElim (ev,cb,cbo) ->
-      hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ 
+      hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++
         pr_opt pr_eliminator cbo)
   | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c)
   | TacCase (ev,cb) ->
@@ -722,16 +725,16 @@ and pr_atom1 = function
       hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++
              str"with " ++ prlist_with_sep spc pr_cofix_tac l)
   | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c)
-  | TacAssert (Some tac,ipat,c) -> 
-      hov 1 (str "assert" ++ 
-             pr_assumption pr_lconstr pr_constr ipat c ++ 
+  | TacAssert (Some tac,ipat,c) ->
+      hov 1 (str "assert" ++
+             pr_assumption pr_lconstr pr_constr ipat c ++
              pr_by_tactic (pr_tac_level ltop) tac)
-  | TacAssert (None,ipat,c) -> 
+  | TacAssert (None,ipat,c) ->
       hov 1 (str "pose proof" ++
              pr_assertion pr_lconstr pr_constr ipat c)
   | TacGeneralize l ->
       hov 1 (str "generalize" ++ spc () ++
-             prlist_with_sep pr_coma (fun (cl,na) -> 
+             prlist_with_sep pr_comma (fun (cl,na) ->
 	       pr_with_occurrences pr_constr cl ++ pr_as_name na)
 	     l)
   | TacGeneralizeDep c ->
@@ -743,7 +746,7 @@ and pr_atom1 = function
       hov 1 ((if b then str "set" else str "remember") ++
              (if b then pr_pose pr_lconstr else pr_pose_as_style)
 	        pr_constr na c ++
-             pr_clauses pr_ident cl)
+             pr_clauses (Some b) pr_ident cl)
 (*  | TacInstantiate (n,c,ConclLocation ()) ->
       hov 1 (str "instantiate" ++ spc() ++
              hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
@@ -751,24 +754,24 @@ and pr_atom1 = function
   | TacInstantiate (n,c,HypLocation (id,hloc)) ->
       hov 1 (str "instantiate" ++ spc() ++
              hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
-                    pr_lconstrarg c ++ str ")" ) 
+                    pr_lconstrarg c ++ str ")" )
 	     ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None)))
 *)
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
       hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct")
              ++ pr_arg pr_quantified_hypothesis h)
-  | TacInductionDestruct (isrec,ev,l) ->
+  | TacInductionDestruct (isrec,ev,(l,cl)) ->
       hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++
              spc () ++
-             prlist_with_sep pr_coma (fun (h,e,ids,cl) ->
+             prlist_with_sep pr_comma (fun (h,e,ids) ->
 	       prlist_with_sep spc (pr_induction_arg pr_lconstr pr_constr) h ++
 	       pr_with_induction_names ids ++
-               pr_opt pr_eliminator e ++
-               pr_opt_no_spc (pr_clauses pr_ident) cl) l)
+               pr_opt pr_eliminator e) l ++
+               pr_opt_no_spc (pr_clauses None pr_ident) cl)
   | TacDoubleInduction (h1,h2) ->
       hov 1
-        (str "double induction" ++  
+        (str "double induction" ++
          pr_arg pr_quantified_hypothesis h1 ++
  	 pr_arg pr_quantified_hypothesis h2)
   | TacDecomposeAnd c ->
@@ -780,22 +783,22 @@ and pr_atom1 = function
         hov 0 (str "[" ++ prlist_with_sep spc pr_ind l
 	  ++ str "]" ++ pr_constrarg c))
   | TacSpecialize (n,c) ->
-      hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ 
+      hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++
              pr_with_bindings c)
-  | TacLApply c -> 
+  | TacLApply c ->
       hov 1 (str "lapply" ++ pr_constrarg c)
 
   (* Automation tactics *)
   | TacTrivial ([],Some []) as x -> pr_atom0 x
   | TacTrivial (lems,db) ->
-      hov 0 (str "trivial" ++ 
+      hov 0 (str "trivial" ++
              pr_auto_using pr_constr lems ++ pr_hintbases db)
   | TacAuto (None,[],Some []) as x -> pr_atom0 x
   | TacAuto (n,lems,db) ->
-      hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ 
+      hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++
              pr_auto_using pr_constr lems ++ pr_hintbases db)
   | TacDAuto (n,p,lems) ->
-      hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ 
+      hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++
              pr_opt int p ++ pr_auto_using pr_constr lems)
 
   (* Context management *)
@@ -809,59 +812,58 @@ and pr_atom1 = function
       (* Rem: only b = true is available for users *)
       assert b;
       hov 1
-        (str "move" ++ brk (1,1) ++ pr_ident id1 ++ 
+        (str "move" ++ brk (1,1) ++ pr_ident id1 ++
 	 pr_move_location pr_ident id2)
   | TacRename l ->
       hov 1
         (str "rename" ++ brk (1,1) ++
-         prlist_with_sep 
+         prlist_with_sep
 	   (fun () -> str "," ++ brk (1,1))
-	   (fun (i1,i2) -> 
+	   (fun (i1,i2) ->
 	      pr_ident i1 ++ spc () ++ str "into" ++ spc () ++ pr_ident i2)
 	   l)
-  | TacRevert l -> 
-      hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l) 
+  | TacRevert l ->
+      hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l)
 
   (* Constructors *)
   | TacLeft (ev,l) -> hov 1 (str (with_evars ev "left") ++ pr_bindings l)
   | TacRight (ev,l) -> hov 1 (str (with_evars ev "right") ++ pr_bindings l)
-  | TacSplit (ev,false,l) -> hov 1 (str (with_evars ev "split") ++ pr_bindings l)
-  | TacSplit (ev,true,l) -> hov 1 (str (with_evars ev "exists") ++ pr_ex_bindings l)
+  | TacSplit (ev,false,l) -> hov 1 (str (with_evars ev "split") ++ prlist_with_sep pr_comma pr_bindings l)
+  | TacSplit (ev,true,l) -> hov 1 (str (with_evars ev "exists") ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l)
   | TacAnyConstructor (ev,Some t) ->
       hov 1 (str (with_evars ev "constructor") ++ pr_arg (pr_tac_level (latom,E)) t)
   | TacAnyConstructor (ev,None) as t -> pr_atom0 t
   | TacConstructor (ev,n,l) ->
-      hov 1 (str (with_evars ev "constructor") ++ 
+      hov 1 (str (with_evars ev "constructor") ++
              pr_or_metaid pr_intarg n ++ pr_bindings l)
 
-  (* Conversion *)  
+  (* Conversion *)
   | TacReduce (r,h) ->
       hov 1 (pr_red_expr r ++
-             pr_clauses pr_ident h)
-  | TacChange (occ,c,h) ->
+             pr_clauses (Some true) pr_ident h)
+  | TacChange (op,c,h) ->
       hov 1 (str "change" ++ brk (1,1) ++
-      (match occ with
+      (match op with
           None -> mt()
-        | Some occlc ->
-	    pr_with_occurrences_with_trailer pr_constr occlc 
-	      (spc () ++ str "with ")) ++
-      pr_constr c ++ pr_clauses pr_ident h)
+        | Some p -> pr_pat p ++ spc () ++ str "with ") ++
+      pr_constr c ++ pr_clauses (Some true) pr_ident h)
 
   (* Equivalence relations *)
   | TacReflexivity as x -> pr_atom0 x
-  | TacSymmetry cls -> str "symmetry " ++ pr_clauses pr_ident cls
-  | TacTransitivity c -> str "transitivity" ++ pr_constrarg c
+  | TacSymmetry cls -> str "symmetry " ++ pr_clauses (Some true) pr_ident cls
+  | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c
+  | TacTransitivity None -> str "etransitivity"
 
   (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) -> 
-      hov 1 (str (with_evars ev "rewrite") ++ 
+  | TacRewrite (ev,l,cl,by) ->
+      hov 1 (str (with_evars ev "rewrite") ++
 	     prlist_with_sep
 	     (fun () -> str ","++spc())
-	     (fun (b,m,c) -> 
+	     (fun (b,m,c) ->
 		pr_orient b ++ spc() ++ pr_multi m ++ pr_with_bindings c)
 	     l
-	     ++ pr_clauses pr_ident cl
-	     ++	(match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) 
+	     ++ pr_clauses (Some true) pr_ident cl
+	     ++	(match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt()))
   | TacInversion (DepInversion (k,c,ids),hyp) ->
       hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++
       pr_quantified_hypothesis hyp ++
@@ -869,11 +871,11 @@ and pr_atom1 = function
   | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
       hov 1 (pr_induction_kind k ++ spc () ++
       pr_quantified_hypothesis hyp ++
-      pr_with_inversion_names ids ++ pr_simple_clause pr_ident cl)
+      pr_with_inversion_names ids ++ pr_simple_hyp_clause pr_ident cl)
   | TacInversion (InversionUsing (c,cl),hyp) ->
-      hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ 
-      spc () ++ str "using" ++ spc () ++ pr_constr c ++ 
-      pr_simple_clause pr_ident cl)
+      hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++
+      spc () ++ str "using" ++ spc () ++ pr_constr c ++
+      pr_simple_hyp_clause pr_ident cl)
 
 in
 
@@ -881,7 +883,7 @@ let rec pr_tac inherited tac =
   let (strm,prec) = match tac with
   | TacAbstract (t,None) ->
       str "abstract " ++ pr_tac (labstract,L) t, labstract
-  | TacAbstract (t,Some s) -> 
+  | TacAbstract (t,Some s) ->
       hov 0
        (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++
         str "using " ++ pr_id s),
@@ -896,16 +898,16 @@ let rec pr_tac inherited tac =
       hov 0 (pr_lazy lz ++ str "match " ++ pr_tac ltop t ++ str " with"
         ++ prlist
 	  (fun r -> fnl () ++ str "| " ++
-            pr_match_rule true (pr_tac ltop) pr_pat r)
+            pr_match_rule true (pr_tac ltop) pr_lpat r)
 	lrul
         ++ fnl() ++ str "end"),
       lmatch
   | TacMatchGoal (lz,lr,lrul) ->
-      hov 0 (pr_lazy lz ++ 
+      hov 0 (pr_lazy lz ++
 	str (if lr then "match reverse goal with" else "match goal with")
 	++ prlist
 	  (fun r -> fnl () ++ str "| " ++
-            pr_match_rule false (pr_tac ltop) pr_pat r)
+            pr_match_rule false (pr_tac ltop) pr_lpat r)
 	lrul
         ++ fnl() ++ str "end"),
       lmatch
@@ -914,7 +916,7 @@ let rec pr_tac inherited tac =
         prlist pr_funvar lvar ++ str " =>" ++ spc () ++
         pr_tac (lfun,E) body),
       lfun
-  | TacThens (t,tl) -> 
+  | TacThens (t,tl) ->
       hov 1 (pr_tac (lseq,E) t ++ pr_then () ++ spc () ++
              pr_seq_body (pr_tac ltop) tl),
       lseq
@@ -930,7 +932,7 @@ let rec pr_tac inherited tac =
       hov 1 (str "try" ++ spc () ++ pr_tac (ltactical,E) t),
       ltactical
   | TacDo (n,t) ->
-      hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ 
+      hov 1 (str "do " ++ pr_or_var int n ++ spc () ++
              pr_tac (ltactical,E) t),
       ltactical
   | TacRepeat t ->
@@ -946,7 +948,7 @@ let rec pr_tac inherited tac =
       hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++
              pr_tac (lorelse,E) t2),
       lorelse
-  | TacFail (n,l) -> 
+  | TacFail (n,l) ->
       str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
       prlist (pr_arg (pr_message_token pr_ident)) l, latom
   | TacFirst tl ->
@@ -967,7 +969,7 @@ let rec pr_tac inherited tac =
   | TacArg(ConstrMayEval (ConstrTerm c)) ->
       str "constr:" ++ pr_constr c, latom
   | TacArg(ConstrMayEval c) ->
-      pr_may_eval pr_constr pr_lconstr pr_cst c, leval
+      pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c, leval
   | TacArg(TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom
   | TacArg(Integer n) -> int n, latom
   | TacArg(TacCall(loc,f,[])) -> pr_ref f, latom
@@ -989,11 +991,10 @@ and pr_tacarg = function
   | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat
   | TacVoid -> str "()"
   | Reference r -> pr_ref r
-  | ConstrMayEval c ->
-      pr_may_eval pr_constr pr_lconstr pr_cst c
+  | ConstrMayEval c -> pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c
   | TacFreshId l -> str "fresh" ++ pr_fresh_ids l
   | TacExternal (_,com,req,la) ->
-      str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ 
+      str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++
       spc() ++ prlist_with_sep spc pr_tacarg la
   | (TacCall _|Tacexp _|Integer _) as a ->
       str "ltac:" ++ pr_tac (latom,E) (TacArg a)
@@ -1009,22 +1010,25 @@ let strip_prod_binders_rawterm n (ty,_) =
         | _ -> error "Cannot translate fix tactic: not enough products" in
   strip_ty [] n ty
 
-let strip_prod_binders_constr n (sigma,ty) =
+let strip_prod_binders_constr n ty =
   let rec strip_ty acc n ty =
-    if n=0 then (List.rev acc, (sigma,ty)) else
+    if n=0 then (List.rev acc, ty) else
       match Term.kind_of_term ty with
           Term.Prod(na,a,b) ->
-            strip_ty (([dummy_loc,na],(sigma,a))::acc) (n-1) b
+            strip_ty (([dummy_loc,na],a)::acc) (n-1) b
         | _ -> error "Cannot translate fix tactic: not enough products" in
   strip_ty [] n ty
 
 let drop_env f _env = f
 
+let pr_constr_or_lconstr_pattern_expr b =
+  if b then pr_lconstr_pattern_expr else pr_constr_pattern_expr
+
 let rec raw_printers =
-    (pr_raw_tactic_level, 
+    (pr_raw_tactic_level,
      drop_env pr_constr_expr,
      drop_env pr_lconstr_expr,
-     pr_lconstr_pattern_expr,
+     pr_constr_or_lconstr_pattern_expr,
      drop_env (pr_or_by_notation pr_reference),
      drop_env (pr_or_by_notation pr_reference),
      pr_reference,
@@ -1040,11 +1044,15 @@ and pr_raw_match_rule env t =
 
 let pr_and_constr_expr pr (c,_) = pr c
 
+let pr_pat_and_constr_expr b (c,_) =
+  pr_and_constr_expr ((if b then pr_lrawconstr_env else pr_rawconstr_env)
+    (Global.env())) c
+
 let rec glob_printers =
-    (pr_glob_tactic_level, 
+    (pr_glob_tactic_level,
      (fun env -> pr_and_constr_expr (pr_rawconstr_env env)),
      (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)),
-     (fun c -> pr_lconstr_pattern_env (Global.env()) c),
+     pr_pat_and_constr_expr,
      (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
      (fun env -> pr_or_var (pr_inductive env)),
      pr_ltac_or_var (pr_located pr_ltac_constant),
@@ -1058,11 +1066,14 @@ and pr_glob_tactic_level env n (t:glob_tactic_expr) =
 and pr_glob_match_rule env t =
   snd (make_pr_tac glob_printers env) t
 
+let pr_constr_or_lconstr_pattern b =
+  if b then pr_lconstr_pattern else pr_constr_pattern
+
 let typed_printers =
     (pr_glob_tactic_level,
-     pr_open_constr_env,
-     pr_open_lconstr_env,
-     pr_lconstr_pattern,
+     pr_constr_env,
+     pr_lconstr_env,
+     pr_constr_or_lconstr_pattern,
      pr_evaluable_reference_env,
      pr_inductive,
      pr_ltac_constant,
@@ -1084,9 +1095,10 @@ let _ = Tactic_debug.set_match_pattern_printer
 
 let _ = Tactic_debug.set_match_rule_printer
   (fun rl ->
-    pr_match_rule false (pr_glob_tactic (Global.env())) pr_constr_pattern rl)
+    pr_match_rule false (pr_glob_tactic (Global.env())) 
+      (fun (_,p) -> pr_constr_pattern p) rl)
 
-open Pcoq
+open Extrawit
 
 let pr_tac_polymorphic n _ _ prtac = prtac (n,E)
 
@@ -1096,3 +1108,4 @@ let _ = for i=0 to 5 do
   (globwit_tactic i, pr_tac_polymorphic i)
   (wit_tactic i, pr_tac_polymorphic i)
 done
+
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
index e24f666f..446dc9f9 100644
--- a/parsing/pptactic.mli
+++ b/parsing/pptactic.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pptactic.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Genarg
@@ -15,6 +15,7 @@ open Pretyping
 open Proof_type
 open Topconstr
 open Rawterm
+open Pattern
 open Ppextend
 open Environ
 open Evd
@@ -25,8 +26,8 @@ val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
 val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
 
 type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) -> 
-    (constr_expr -> std_ppcmds) -> 
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
     (tolerability -> raw_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
@@ -37,13 +38,13 @@ type 'a glob_extra_genarg_printer =
     'a -> std_ppcmds
 
 type 'a extra_genarg_printer =
-    (Term.constr -> std_ppcmds) -> 
-    (Term.constr -> std_ppcmds) -> 
+    (Term.constr -> std_ppcmds) ->
+    (Term.constr -> std_ppcmds) ->
     (tolerability -> glob_tactic_expr -> std_ppcmds) ->
     'a -> std_ppcmds
 
   (* if the boolean is false then the extension applies only to old syntax *)
-val declare_extra_genarg_pprule : 
+val declare_extra_genarg_pprule :
   ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) ->
   ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) ->
   ('b typed_abstract_argument_type * 'b extra_genarg_printer) -> unit
@@ -51,31 +52,35 @@ val declare_extra_genarg_pprule :
 type grammar_terminals = string option list
 
   (* if the boolean is false then the extension applies only to old syntax *)
-val declare_extra_tactic_pprule : 
+val declare_extra_tactic_pprule :
   string * argument_type list * (int * grammar_terminals) -> unit
 
 val exists_extra_tactic_pprule : string -> argument_type list -> bool
 
-val pr_raw_generic : 
+val pr_raw_generic :
   (constr_expr -> std_ppcmds) ->
   (constr_expr -> std_ppcmds) ->
   (tolerability -> raw_tactic_expr -> std_ppcmds) ->
-  (Libnames.reference -> std_ppcmds) -> constr_expr generic_argument ->
+  (constr_expr -> std_ppcmds) ->
+  (Libnames.reference -> std_ppcmds) -> rlevel generic_argument ->
     std_ppcmds
 
 val pr_raw_extend:
   (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
-  (tolerability -> raw_tactic_expr -> std_ppcmds) -> int ->
+  (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+  (constr_expr -> std_ppcmds) -> int ->
     string -> raw_generic_argument list -> std_ppcmds
 
 val pr_glob_extend:
   (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) ->
-  (tolerability -> glob_tactic_expr -> std_ppcmds) -> int ->
+  (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+  (rawconstr_pattern_and_expr -> std_ppcmds) -> int ->
     string -> glob_generic_argument list -> std_ppcmds
 
 val pr_extend :
-  (open_constr -> std_ppcmds) -> (open_constr -> std_ppcmds) ->
-  (tolerability -> glob_tactic_expr -> std_ppcmds) -> int ->
+  (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
+  (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+  (constr_pattern -> std_ppcmds) -> int ->
     string -> typed_generic_argument list -> std_ppcmds
 
 val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
@@ -83,7 +88,7 @@ val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
 val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds
 
 val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds
- 
+
 val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
 
 val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds
diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml
index 5f4ea5a6..ca41c633 100644
--- a/parsing/ppvernac.ml
+++ b/parsing/ppvernac.ml
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppvernac.ml 12187 2009-06-13 19:36:59Z msozeau $ *)  
+(* $Id$ *)
 
 open Pp
 open Names
 open Nameops
-open Nametab 
+open Nametab
 open Util
 open Extend
 open Vernacexpr
@@ -50,7 +50,9 @@ let pr_lname = function
     (loc,Name id) -> pr_lident (loc,id)
   | lna -> pr_located pr_name lna
 
-let pr_ltac_id = Libnames.pr_reference
+let pr_smart_global = pr_or_by_notation pr_reference
+
+let pr_ltac_ref = Libnames.pr_reference
 
 let pr_module = Libnames.pr_reference
 
@@ -60,20 +62,20 @@ let sep_end () = str"."
 
 (* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *)
 
-let pr_raw_tactic_env l env t = 
+let pr_raw_tactic_env l env t =
   pr_glob_tactic env (Tacinterp.glob_tactic_env l env t)
 
 let pr_gen env t =
-  pr_raw_generic 
+  pr_raw_generic
     pr_constr_expr
     pr_lconstr_expr
-    (pr_raw_tactic_level env) pr_reference t
+    (pr_raw_tactic_level env) pr_constr_expr pr_reference t
 
 let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac
 
 let rec extract_signature = function
   | [] -> []
-  | Egrammar.TacNonTerm (_,(_,t),_) :: l -> t :: extract_signature l
+  | Egrammar.GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
   | _::l -> extract_signature l
 
 let rec match_vernac_rule tys = function
@@ -105,7 +107,7 @@ let pr_prec = function
   | None -> mt()
 
 let pr_set_entry_type = function
-  | ETIdent -> str"ident"
+  | ETName -> str"ident"
   | ETReference -> str"global"
   | ETPattern -> str"pattern"
   | ETConstr _ -> str"constr"
@@ -119,9 +121,11 @@ let strip_meta id =
   else id
 
 let pr_production_item = function
-  | VNonTerm (loc,nt,Some p) -> str nt ++ str"(" ++ pr_id (strip_meta p) ++ str")"
-  | VNonTerm (loc,nt,None) -> str nt
-  | VTerm s -> qs s
+  | TacNonTerm (loc,nt,Some (p,sep)) ->
+      let pp_sep = if sep <> "" then str "," ++ quote (str sep) else mt () in
+      str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")"
+  | TacNonTerm (loc,nt,None) -> str nt
+  | TacTerm s -> qs s
 
 let pr_comment pr_c = function
   | CommentConstr c -> pr_c c
@@ -133,20 +137,28 @@ let pr_in_out_modules = function
   | SearchOutside [] -> mt()
   | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l
 
-let pr_search_about (b,c) = 
+let pr_search_about (b,c) =
   (if b then str "-" else mt()) ++
   match c with
   | SearchSubPattern p -> pr_constr_pattern_expr p
   | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
 
 let pr_search a b pr_p = match a with
-  | SearchHead qid -> str"Search" ++ spc() ++ pr_reference qid ++ pr_in_out_modules b
+  | SearchHead c -> str"Search" ++ spc() ++ pr_p c ++ pr_in_out_modules b
   | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b
   | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b
   | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b
 
+let pr_locality_full = function
+  | None -> mt()
+  | Some true -> str"Local "
+  | Some false -> str"Global "
 let pr_locality local = if local then str "Local " else str ""
 let pr_non_locality local = if local then str "" else str "Global "
+let pr_section_locality local =
+  if Lib.sections_are_opened () && not local then str "Global "
+  else if not (Lib.sections_are_opened ()) && local then str "Local "
+  else mt ()
 
 let pr_explanation (e,b,f) =
   let a = match e with
@@ -158,21 +170,18 @@ let pr_explanation (e,b,f) =
 let pr_class_rawexpr = function
   | FunClass -> str"Funclass"
   | SortClass -> str"Sortclass"
-  | RefClass qid -> pr_reference qid
+  | RefClass qid -> pr_smart_global qid
 
 let pr_option_ref_value = function
   | QualidRefValue id -> pr_reference id
   | StringRefValue s -> qs s
 
-let pr_printoption a b = match a with
-  | Goptions.PrimaryTable table -> str table ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b
-  | Goptions.SecondaryTable (table,field) -> str table ++ spc() ++ str field ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b
-  | Goptions.TertiaryTable (table,field1,field2) -> str table ++ spc() ++
-      str field1 ++ spc() ++ str field2 ++ 
-      pr_opt (prlist_with_sep sep pr_option_ref_value) b
+let pr_printoption table b =
+  prlist_with_sep spc str table ++
+  pr_opt (prlist_with_sep sep pr_option_ref_value) b
 
-let pr_set_option a b = 
-  let pr_opt_value = function 
+let pr_set_option a b =
+  let pr_opt_value = function
     | IntValue n -> spc() ++ int n
     | StringValue s -> spc() ++ str s
     | BoolValue b -> mt()
@@ -188,13 +197,13 @@ let pr_opt_hintbases l = match l with
   | [] -> mt()
   | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z
 
-let pr_hints local db h pr_c pr_pat = 
+let pr_hints local db h pr_c pr_pat =
   let opth = pr_opt_hintbases db  in
   let pph =
     match h with
     | HintsResolve l ->
-        str "Resolve " ++ prlist_with_sep sep 
-	  (fun (pri, _, c) -> pr_c c ++ 
+        str "Resolve " ++ prlist_with_sep sep
+	  (fun (pri, _, c) -> pr_c c ++
 	    match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ())
 	  l
     | HintsImmediate l ->
@@ -202,11 +211,11 @@ let pr_hints local db h pr_c pr_pat =
     | HintsUnfold l ->
         str "Unfold " ++ prlist_with_sep sep pr_reference l
     | HintsTransparency (l, b) ->
-        str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep 
+        str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep
 	  pr_reference l
     | HintsConstructors c ->
         str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c
-    | HintsExtern (n,c,tac) -> 
+    | HintsExtern (n,c,tac) ->
 	let pat = match c with None -> mt () | Some pat -> pr_pat pat in
           str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
           spc() ++ pr_raw_tactic tac
@@ -225,48 +234,45 @@ let pr_with_declaration pr_c = function
       str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
       pr_located pr_qualid qid
 
-let rec pr_module_type pr_c = function
-  | CMTEident qid -> spc () ++ pr_located pr_qualid qid
-  | CMTEwith (mty,decl) ->
-      let m = pr_module_type pr_c mty in
+let rec pr_module_ast pr_c = function
+  | CMident qid -> spc () ++ pr_located pr_qualid qid
+  | CMwith (mty,decl) ->
+      let m = pr_module_ast pr_c mty in
       let p = pr_with_declaration pr_c decl in
       m ++ spc() ++ str"with" ++ spc() ++ p
-  | CMTEapply (fexpr,mexpr)->
-      let f = pr_module_type pr_c fexpr in
-      let m = pr_module_expr mexpr in
-	f ++ spc () ++ m 
-	  
-and  pr_module_expr = function
-  | CMEident qid -> pr_located pr_qualid qid
-  | CMEapply (me1,(CMEident _ as me2)) ->
-      pr_module_expr me1 ++ spc() ++ pr_module_expr me2
-  | CMEapply (me1,me2) ->
-      pr_module_expr me1 ++ spc() ++
-      hov 1 (str"(" ++ pr_module_expr me2 ++ str")")
-
-let pr_of_module_type prc (mty,b) =
-  str (if b then ":" else "<:") ++
-  pr_module_type prc mty
+  | CMapply (me1,(CMident _ as me2)) ->
+      pr_module_ast pr_c me1 ++ spc() ++ pr_module_ast pr_c me2
+  | CMapply (me1,me2) ->
+      pr_module_ast pr_c me1 ++ spc() ++
+      hov 1 (str"(" ++ pr_module_ast pr_c me2 ++ str")")
+
+let pr_module_ast_inl pr_c (mast,b) =
+  (if b then mt () else str "!") ++ pr_module_ast pr_c mast
+
+let pr_of_module_type prc = function
+  | Enforce mty -> str ":" ++ pr_module_ast_inl prc mty
+  | Check mtys ->
+      prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl prc m) mtys
 
 let pr_require_token = function
   | Some true -> str "Export "
   | Some false -> str "Import "
   | None -> mt()
 
-let pr_module_vardecls pr_c (export,idl,mty) =
-  let m = pr_module_type pr_c mty in
+let pr_module_vardecls pr_c (export,idl,(mty,inl)) =
+  let m = pr_module_ast pr_c mty in
   (* Update the Nametab for interpreting the body of module/modtype *)
   let lib_dir = Lib.library_dp() in
   List.iter (fun (_,id) ->
     Declaremods.process_module_bindings [id]
       [make_mbid lib_dir (string_of_id id),
-       Modintern.interp_modtype (Global.env()) mty]) idl;
+       (Modintern.interp_modtype (Global.env()) mty, inl)]) idl;
   (* Builds the stream *)
   spc() ++
   hov 1 (str"(" ++ pr_require_token export ++
    prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
 
-let pr_module_binders l pr_c = 
+let pr_module_binders l pr_c =
   (* Effet de bord complexe pour garantir la declaration des noms des
   modules parametres dans la Nametab des l'appel de pr_module_binders
   malgre l'aspect paresseux des streams *)
@@ -279,10 +285,9 @@ let pr_type_option pr_c = function
   | CHole (loc, k) -> mt()
   | _ as c -> brk(0,2) ++ str":" ++ pr_c c
 
-let pr_decl_notation prc =
-  pr_opt (fun (ntn,c,scopt) -> fnl () ++
-    str "where " ++ qs ntn ++ str " := " ++ prc c ++
-    pr_opt (fun sc -> str ": " ++ str sc) scopt)
+let pr_decl_notation prc ((loc,ntn),c,scopt) =
+  fnl () ++ str "where " ++ qs ntn ++ str " := " ++ prc c ++
+  pr_opt (fun sc -> str ": " ++ str sc) scopt
 
 let pr_vbinders l =
   hv 0 (pr_binders l)
@@ -293,23 +298,45 @@ let pr_binders_arg =
 let pr_and_type_binders_arg bl =
   pr_binders_arg bl
 
+let names_of_binder = function
+  | LocalRawAssum (nal,_,_) -> nal
+  | LocalRawDef (_,_) -> []
+
+let pr_guard_annot bl (n,ro) =
+  match n with
+  | None -> mt ()
+  | Some (loc, id) ->
+      match (ro : Topconstr.recursion_order_expr) with
+      | CStructRec ->
+          let ids = List.flatten (List.map names_of_binder bl) in
+	  if List.length ids > 1 then
+	    spc() ++ str "{struct " ++ pr_id id ++ str"}"
+	  else mt()
+      | CWfRec c ->
+	  spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++
+	  pr_id id ++ str"}"
+      | CMeasureRec (m,r) ->
+	  spc() ++ str "{measure " ++ pr_lconstr_expr m ++ spc() ++
+	  pr_id id ++ (match r with None -> mt() | Some r -> str" on " ++
+	    pr_lconstr_expr r) ++ str"}"
+
 let pr_onescheme (idop,schem) =
-  match schem with 
+  match schem with
   | InductionScheme (dep,ind,s) ->
     (match idop with
       | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
       | None -> spc ()
     ) ++
     hov 0 ((if dep then str"Induction for" else str"Minimality for")
-    ++ spc() ++ pr_reference ind) ++ spc() ++ 
+    ++ spc() ++ pr_smart_global ind) ++ spc() ++
     hov 0 (str"Sort" ++ spc() ++ pr_rawsort s)
-  | EqualityScheme ind -> 
+  | EqualityScheme ind ->
     (match idop with
       | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
       | None -> spc()
     ) ++
     hov 0 (str"Equality for")
-    ++ spc() ++ pr_reference ind
+    ++ spc() ++ pr_smart_global ind
 
 let begin_of_inductive = function
     [] -> 0
@@ -318,7 +345,7 @@ let begin_of_inductive = function
 let pr_class_rawexpr = function
   | FunClass -> str"Funclass"
   | SortClass -> str"Sortclass"
-  | RefClass qid -> pr_reference qid
+  | RefClass qid -> pr_smart_global qid
 
 let pr_assumption_token many = function
   | (Local,Logical) ->
@@ -327,10 +354,10 @@ let pr_assumption_token many = function
       str (if many then "Variables" else "Variable")
   | (Global,Logical) ->
       str (if many then "Axioms" else "Axiom")
-  | (Global,Definitional) -> 
+  | (Global,Definitional) ->
       str (if many then "Parameters" else "Parameter")
   | (Global,Conjectural) -> str"Conjecture"
-  | (Local,Conjectural) -> 
+  | (Local,Conjectural) ->
       anomaly "Don't know how to beautify a local conjecture"
 
 let pr_params pr_c (xl,(c,t)) =
@@ -374,14 +401,14 @@ let pr_syntax_modifier = function
 
 let pr_syntax_modifiers = function
   | [] -> mt()
-  | l -> spc() ++ 
+  | l -> spc() ++
       hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
 
 let print_level n =
   if n <> 0 then str " (at level " ++ int n ++ str ")" else mt ()
 
 let pr_grammar_tactic_rule n (_,pil,t) =
-  hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ 
+  hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++
     hov 0 (prlist_with_sep sep pr_production_item pil ++
     spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
 
@@ -392,7 +419,7 @@ let pr_box b = let pr_boxkind = function
   | PpHOVB n -> str"hov" ++ spc() ++ int n
   | PpTB -> str"t"
 in str"<" ++ pr_boxkind b ++ str">"
- 
+
 let pr_paren_reln_or_extern = function
   | None,L -> str"L"
   | None,E -> str"E"
@@ -400,6 +427,14 @@ let pr_paren_reln_or_extern = function
   | Some pprim,Prec p -> qs pprim ++ spc() ++ str":" ++ spc() ++ int p
   | _ -> mt()
 
+let pr_statement head (id,(bl,c,guard)) =
+  assert (id<>None);
+  hov 0
+    (head ++ pr_lident (Option.get id) ++ spc() ++
+    (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
+    pr_opt (pr_guard_annot bl) guard ++
+    str":" ++ pr_spc_lconstr c)
+
 (**************************************)
 (* Pretty printer for vernac commands *)
 (**************************************)
@@ -409,7 +444,7 @@ 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_lident_constr sep (i,c) = pr_lident i ++ sep ++ pr_constrarg c in *)
-let pr_record_field (x, ntn) = 
+let pr_record_field (x, ntn) =
   let prx = match x with
     | (oc,AssumExpr (id,t)) ->
 	hov 1 (pr_lname id ++
@@ -423,15 +458,15 @@ let pr_record_field (x, ntn) =
       | None ->
           hov 1 (pr_lname id ++ str" :=" ++ spc() ++
                     pr_lconstr b)) in
-    prx ++ pr_decl_notation pr_constr ntn
+    prx ++ prlist (pr_decl_notation pr_constr) ntn
 in
-let pr_record_decl b c fs = 
+let pr_record_decl b c fs =
     pr_opt pr_lident c ++ str"{"  ++
     hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")
 in
 
 let rec pr_vernac = function
-  
+
   (* Proof management *)
   | VernacAbortAll -> str "Abort All"
   | VernacRestart -> str"Restart"
@@ -442,17 +477,17 @@ let rec pr_vernac = function
   | VernacResume id -> str"Resume" ++ pr_opt pr_lident id
   | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i
   | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i
-  | VernacBacktrack (i,j,k) -> 
+  | VernacBacktrack (i,j,k) ->
       str "Backtrack" ++  spc() ++ prlist_with_sep sep int [i;j;k]
   | VernacFocus i -> str"Focus" ++ pr_opt int i
-  | VernacGo g -> 
+  | VernacGo g ->
       let pr_goable = function
 	| GoTo i -> int i
 	| GoTop -> str"top"
 	| GoNext -> str"next"
-	| GoPrev -> str"prev" 
+	| GoPrev -> str"prev"
       in str"Go" ++ spc() ++  pr_goable g
-  | VernacShow s -> 
+  | VernacShow s ->
       let pr_showable = function
 	| ShowGoal n -> str"Show" ++ pr_opt int n
 	| ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n
@@ -466,7 +501,7 @@ let rec pr_vernac = function
 	| ShowMatch id -> str"Show Match " ++ pr_lident id
 	| ShowThesis -> str "Show Thesis"
 	| ExplainProof l -> str"Explain Proof" ++ spc() ++ prlist_with_sep sep int l
-	| ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l 
+	| ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l
       in pr_showable s
   | VernacCheckGuard -> str"Guarded"
 
@@ -485,15 +520,18 @@ let rec pr_vernac = function
   | VernacList l ->
       hov 2 (str"[" ++ spc() ++
              prlist (fun v -> pr_located pr_vernac v ++ sep_end () ++ fnl()) l
-             ++ spc() ++ str"]") 
+             ++ spc() ++ str"]")
   | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose"
   ++ spc()) else spc()  ++ qs s
   | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v
-  
-  (* Syntax *) 
+  | VernacTimeout(n,v) -> str"Timeout " ++ int n ++ spc() ++ pr_vernac v
+  | VernacFail v -> str"Fail" ++ spc() ++ pr_vernac v
+
+  (* Syntax *)
   | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e)
   | VernacOpenCloseScope (local,opening,sc) ->
-      str (if opening then "Open " else "Close ") ++ pr_locality local ++
+      pr_section_locality local ++ 
+      str (if opening then "Open " else "Close ") ++
       str "Scope" ++ spc() ++ str sc
   | VernacDelimiters (sc,key) ->
       str"Delimit Scope" ++ spc () ++ str sc ++
@@ -501,33 +539,34 @@ let rec pr_vernac = function
   | VernacBindScope (sc,cll) ->
       str"Bind Scope" ++ spc () ++ str sc ++
       spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll
-  | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function 
+  | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function
       |	None -> str"_"
-      |	Some sc -> str sc in 
-    str"Arguments Scope" ++ spc() ++ pr_non_locality local ++ pr_reference q 
+      |	Some sc -> str sc in
+    pr_section_locality local ++ str"Arguments Scope" ++ spc() ++ 
+    pr_smart_global q
     ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
-  | VernacInfix (local,(s,mv),q,sn) -> (* A Verifier *)
-      hov 0 (hov 0 (str"Infix " ++ pr_locality local
-      ++ qs s ++ str " :=" ++ spc() ++ pr_reference q) ++
+  | VernacInfix (local,((_,s),mv),q,sn) -> (* A Verifier *)
+      hov 0 (hov 0 (pr_locality local ++ str"Infix "
+      ++ qs s ++ str " :=" ++ pr_constrarg q) ++
       pr_syntax_modifiers mv ++
       (match sn with
     | None -> mt()
     | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
-  | VernacNotation (local,c,(s,l),opt) ->
+  | VernacNotation (local,c,((_,s),l),opt) ->
       let ps =
 	let n = String.length s in
-	if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' 
+	if n > 2 & s.[0] = '\'' & s.[n-1] = '\''
 	then
           let s' = String.sub s 1 (n-2) in
           if String.contains s' '\'' then qs s else str s'
 	else qs s in
-      hov 2( str"Notation" ++ spc() ++ pr_locality local ++ ps ++
+      hov 2 (pr_locality local ++ str"Notation" ++ spc() ++ ps ++
       str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++
       (match opt with
         | None -> mt()
         | Some sc -> str" :" ++ spc() ++ str sc))
   | VernacSyntaxExtension (local,(s,l)) ->
-      str"Reserved Notation" ++ spc() ++ pr_locality local ++ qs s ++
+      pr_locality local ++ str"Reserved Notation" ++ spc() ++ pr_located qs s ++
       pr_syntax_modifiers l
 
   (* Gallina *)
@@ -537,7 +576,7 @@ let rec pr_vernac = function
         | None -> mt()
         | Some r ->
             str"Eval" ++ spc() ++
-            pr_red_expr (pr_constr, pr_lconstr, pr_or_by_notation pr_reference) r ++
+            pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++
             str" in" ++ spc() in
       let pr_def_body = function
         | DefineBody (bl,red,body,d) ->
@@ -555,11 +594,6 @@ let rec pr_vernac = function
         | Some cc -> str" :=" ++ spc() ++ cc))
 
   | VernacStartTheoremProof (ki,l,_,_) ->
-      let pr_statement head (id,(bl,c)) =
-        hov 0
-          (head ++ pr_opt pr_lident id ++ spc() ++
-              (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
-              str":" ++ pr_spc_lconstr c) in
       hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
              prlist (pr_statement (spc () ++ str "with")) (List.tl l))
 
@@ -568,15 +602,15 @@ let rec pr_vernac = function
     | None -> if opac then str"Qed" else str"Defined"
     | Some (id,th) -> (match th with
       |	None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id
-      |	Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) 
+      |	Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id))
   | VernacExactProof c ->
       hov 2 (str"Proof" ++ pr_lconstrarg c)
   | VernacAssumption (stre,_,l) ->
       let n = List.length (List.flatten (List.map fst (List.map snd l))) in
       hov 2
-        (pr_assumption_token (n > 1) stre ++ spc() ++ 
+        (pr_assumption_token (n > 1) stre ++ spc() ++
 	 pr_ne_params_list pr_lconstr_expr l)
-  | VernacInductive (f,l) ->
+  | VernacInductive (f,i,l) ->
 
       let pr_constructor (coe,(id,c)) =
         hov 2 (pr_lident id ++ str" " ++
@@ -588,79 +622,52 @@ let rec pr_vernac = function
             pr_com_at (begin_of_inductive l) ++
             fnl() ++
             str (if List.length l = 1 then "   " else " | ") ++
-            prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l 
-       | RecordDecl (c,fs) ->   
+            prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l
+       | RecordDecl (c,fs) ->
 	    spc() ++
 	    pr_record_decl b c fs in
       let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) =
-	let kw =
-	  str (match k with Record -> "Record" | Structure -> "Structure"  
-		 | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
-		 | Class b -> if b then "Definitional Class" else "Class")
-	in
-	  hov 0 (
-	    kw ++ spc() ++
-              (if coe then str" > " else str" ") ++ pr_lident id ++
-              pr_and_type_binders_arg indpar ++ spc() ++ 
-	      Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ 
-	      str" :=") ++ pr_constructor_list k lc ++ 
-	    pr_decl_notation pr_constr ntn 
+	hov 0 (
+	    str key ++ spc() ++
+	      (if i then str"Infer " else str"") ++
+              (if coe then str"> " else str"") ++ pr_lident id ++
+              pr_and_type_binders_arg indpar ++ spc() ++
+	      Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++
+	      str" :=") ++ pr_constructor_list k lc ++
+	    prlist (pr_decl_notation pr_constr) ntn
       in
-      hov 1 (pr_oneind (if (Decl_kinds.recursivity_flag_of_kind f) then "Inductive" else "CoInductive") (List.hd l))
-      ++ 
+      let key =
+        let (_,_,_,k,_),_ = List.hd l in
+	match k with Record -> "Record" | Structure -> "Structure"
+	  | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
+	  | Class b -> if b then "Definitional Class" else "Class" in
+      hov 1 (pr_oneind key (List.hd l)) ++
       (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
 
 
   | VernacFixpoint (recs,b) ->
-      let name_of_binder = function
-        | LocalRawAssum (nal,_,_) -> nal
-        | LocalRawDef (_,_) -> [] in
       let pr_onerec = function
-        | ((loc,id),(n,ro),bl,type_,def),ntn ->
-            let (bl',def,type_) =
-              if Flags.do_beautify() then extract_def_binders def type_
-              else ([],def,type_) in
-            let bl = bl @ bl' in
-            let ids = List.flatten (List.map name_of_binder bl) in
-            let annot =
-	      match n with 
-		| None -> mt () 
-		| Some (loc, id) -> 
-		    match (ro : Topconstr.recursion_order_expr) with
-			CStructRec -> 
-			  if List.length ids > 1 then 
-			    spc() ++ str "{struct " ++ pr_id id ++ str"}"
-			  else mt()
-		      | CWfRec c -> 
-			  spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++ 
-			    pr_id id ++ str"}"
-		      | CMeasureRec c -> 
-			  spc() ++ str "{measure " ++ pr_lconstr_expr c ++ spc() ++ 
-			    pr_id id ++ str"}"
-	    in
+        | ((loc,id),ro,bl,type_,def),ntn ->
+            let annot = pr_guard_annot bl ro in
             pr_id id ++ pr_binders_arg bl ++ annot ++ spc()
             ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
-            ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ 
-	    pr_decl_notation pr_constr ntn
+            ++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++
+	    prlist (pr_decl_notation pr_constr) ntn
       in
       let start = if b then "Boxed Fixpoint" else "Fixpoint" in
-      hov 1 (str start ++ spc() ++
-        prlist_with_sep (fun _ -> fnl() ++ fnl() ++ str"with ") pr_onerec recs)
+      hov 0 (str start ++ spc() ++
+        prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onerec recs)
 
   | VernacCoFixpoint (corecs,b) ->
       let pr_onecorec (((loc,id),bl,c,def),ntn) =
-        let (bl',def,c) =
-              if Flags.do_beautify() then extract_def_binders def c
-              else ([],def,c) in
-        let bl = bl @ bl' in
         pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
         spc() ++ pr_lconstr_expr c ++
-        str" :=" ++ brk(1,1) ++ pr_lconstr def  ++ 
-	pr_decl_notation pr_constr ntn
+        pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++
+	prlist (pr_decl_notation pr_constr) ntn
       in
       let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in
-      hov 1 (str start ++ spc() ++
-      prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)  
+      hov 0 (str start ++ spc() ++
+      prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)
   | VernacScheme l ->
       hov 2 (str"Scheme" ++ spc() ++
              prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l)
@@ -668,7 +675,7 @@ let rec pr_vernac = function
       hov 2 (str"Combined Scheme" ++ spc() ++
 	       pr_lident id ++ spc() ++ str"from" ++ spc() ++
 	       prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l)
-	
+
 
   (* Gallina extensions *)
   | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id)
@@ -684,26 +691,38 @@ let rec pr_vernac = function
   | VernacImport (f,l) ->
       (if f then str"Export" else str"Import") ++ spc() ++
       prlist_with_sep sep pr_import_module l
-  | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_reference q
+  | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_smart_global q
   | VernacCoercion (s,id,c1,c2) ->
       hov 1 (
 	str"Coercion" ++ (match s with | Local -> spc() ++
 	  str"Local" ++ spc() | Global -> spc()) ++
-	pr_reference id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
+	pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
 	spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
   | VernacIdentityCoercion (s,id,c1,c2) ->
       hov 1 (
 	str"Identity Coercion" ++ (match s with | Local -> spc() ++
-	  str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ 
+	  str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++
 	spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
 	spc() ++ pr_class_rawexpr c2)
-	
- | VernacInstance (glob, sup, (instid, bk, cl), props, pri) -> 
+
+
+(*   | VernacClass (id, par, ar, sup, props) -> *)
+(*       hov 1 ( *)
+(* 	str"Class" ++ spc () ++ pr_lident id ++ *)
+(* (\* 	  prlist_with_sep (spc) (pr_lident_constr (spc() ++ str ":" ++ spc())) par ++  *\) *)
+(* 	  pr_and_type_binders_arg par ++ *)
+(* 	  (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_rawsort (snd ar) | None -> mt()) ++ *)
+(* 	  spc () ++ str":=" ++ spc () ++ *)
+(* 	  prlist_with_sep (fun () -> str";" ++ spc())  *)
+(* 	  (fun (lid,oc,c) -> pr_lident_constr ((if oc then str" :>" else str" :") ++ spc()) (lid,c)) props ) *)
+
+ | VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) ->
      hov 1 (
        pr_non_locality (not glob) ++
-       str"Instance" ++ spc () ++ 
+       (if abst then str"Declare " else mt ()) ++
+       str"Instance" ++ spc () ++
 	 pr_and_type_binders_arg sup ++
-	 str"=>" ++ spc () ++ 
+	 str"=>" ++ spc () ++
 	 (match snd instid with Name id -> pr_lident (fst instid, id) ++ spc () ++ str":" ++ spc () | Anonymous -> mt ()) ++
 	 pr_constr_expr cl ++ spc () ++
 	 spc () ++ str":=" ++ spc () ++
@@ -713,37 +732,40 @@ let rec pr_vernac = function
      hov 1 (
        str"Context" ++ spc () ++ str"[" ++ spc () ++
 	 pr_and_type_binders_arg l ++ spc () ++ str "]")
-	      
 
- | VernacDeclareInstance id ->
-     hov 1 (str"Instance" ++ spc () ++ pr_lident id)
-       
+
+ | VernacDeclareInstance (glob, id) ->
+     hov 1 (pr_non_locality (not glob) ++
+	       str"Existing" ++ spc () ++ str"Instance" ++ spc () ++ pr_reference id)
+
+ | VernacDeclareClass id ->
+     hov 1 (str"Existing" ++ spc () ++ str"Class" ++ spc () ++ pr_reference id)
+
   (* Modules and Module Types *)
-  | VernacDefineModule (export,m,bl,ty,bd) ->
-      let b = pr_module_binders_list bl pr_lconstr in 
+  | VernacDefineModule (export,m,bl,tys,bd) ->
+      let b = pr_module_binders_list bl pr_lconstr in
       hov 2 (str"Module" ++ spc() ++ pr_require_token export ++
                pr_lident m ++ b ++
-               pr_opt (pr_of_module_type pr_lconstr) ty ++
-               pr_opt (fun me -> str ":= " ++ pr_module_expr me) bd)
+               pr_of_module_type pr_lconstr tys ++
+	       (if bd = [] then mt () else str ":= ") ++
+	       prlist_with_sep (fun () -> str " <+ ")
+	        (pr_module_ast_inl pr_lconstr) bd)
   | VernacDeclareModule (export,id,bl,m1) ->
-      let b = pr_module_binders_list bl pr_lconstr in 
+      let b = pr_module_binders_list bl pr_lconstr in
 	hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++
              pr_lident id ++ b ++
-             pr_of_module_type pr_lconstr m1)
-  | VernacDeclareModuleType (id,bl,m) ->
-      let b = pr_module_binders_list bl pr_lconstr in 
+             pr_module_ast_inl pr_lconstr m1)
+  | VernacDeclareModuleType (id,bl,tyl,m) ->
+      let b = pr_module_binders_list bl pr_lconstr in
+      let pr_mt = pr_module_ast_inl pr_lconstr in
 	hov 2 (str"Module Type " ++ pr_lident id ++ b ++
-		 pr_opt (fun mt -> str ":= " ++ pr_module_type pr_lconstr mt) m)
-  | VernacInclude (in_ast) ->
-      begin
-	match in_ast with
-	  | CIMTE mty ->
-	      hov 2 (str"Include" ++ 
-		       (fun mt -> str " " ++ pr_module_type pr_lconstr mt) mty)
-	  | CIME mexpr ->
-	      hov 2 (str"Include" ++ 
-		       (fun me -> str " " ++ pr_module_expr me) mexpr)
-      end
+		 prlist_strict (fun m -> str " <: " ++ pr_mt m) tyl ++
+		 (if m = [] then mt () else str ":= ") ++
+		 prlist_with_sep (fun () -> str " <+ ") pr_mt m)
+  | VernacInclude (mexprs) ->
+      let pr_m = pr_module_ast_inl pr_lconstr in
+      hov 2 (str"Include " ++
+	     prlist_with_sep (fun () -> str " <+ ") pr_m mexprs)
   (* Solving *)
   | VernacSolve (i,tac,deftac) ->
       (if i = 1 then mt() else int i ++ str ": ") ++
@@ -755,12 +777,12 @@ let rec pr_vernac = function
       str"Existential " ++ int i ++ pr_lconstrarg c
 
   (* MMode *)
- 
+
   | VernacProofInstr instr -> anomaly "Not implemented"
-  | VernacDeclProof -> str "proof" 
+  | VernacDeclProof -> str "proof"
   | VernacReturn -> str "return"
 
-  (* /MMode *) 
+  (* /MMode *)
 
   (* Auxiliary file and library management *)
   | VernacRequireFrom (exp,spe,f) -> hov 2
@@ -774,62 +796,73 @@ let rec pr_vernac = function
       (str"Add" ++
        (if fl then str" Rec " else spc()) ++
        str"LoadPath" ++ spc() ++ qs s ++
-       (match d with 
+       (match d with
          | None -> mt()
-         | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) 
+         | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir))
   | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s
   | VernacAddMLPath (fl,s) ->
       str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s
-  | VernacDeclareMLModule l ->
+  | VernacDeclareMLModule (local, l) ->
+      pr_locality local ++
       hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
   | VernacChdir s -> str"Cd" ++ pr_opt qs s
 
   (* Commands *)
-  | VernacDeclareTacticDefinition (rc,l) ->
+  | VernacDeclareTacticDefinition (local,rc,l) ->
       let pr_tac_body (id, redef, body) =
         let idl, body =
           match body with
 	    | Tacexpr.TacFun (idl,b) -> idl,b
             | _ -> [], body in
-        pr_ltac_id id ++ 
+        pr_ltac_ref id ++
 	prlist (function None -> str " _"
                        | Some id -> spc () ++ pr_id id) idl
 	++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++
 	let idl = List.map Option.get (List.filter (fun x -> not (x=None)) idl)in
-        pr_raw_tactic_env 
-	  (idl @ List.map coerce_global_to_id 
+        pr_raw_tactic_env
+	  (idl @ List.map coerce_reference_to_id
 	    (List.map (fun (x, _, _) -> x) (List.filter (fun (_, redef, _) -> not redef) l)))
 	  (Global.env())
 	  body in
       hov 1
-        ((str "Ltac ") ++
+        (pr_locality local ++ str "Ltac " ++
         prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l)
   | VernacCreateHintDb (local,dbname,b) ->
-      hov 1 (str "Create " ++ pr_locality local ++ str "HintDb " ++ str dbname ++ (if b then str" discriminated" else mt ()))
+      hov 1 (pr_locality local ++ str "Create " ++ str "HintDb " ++ 
+		str dbname ++ (if b then str" discriminated" else mt ()))
   | VernacHints (local,dbnames,h) ->
       pr_hints local dbnames h pr_constr pr_constr_pattern_expr
   | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) ->
       hov 2
-        (str"Notation " ++ pr_locality local ++ pr_lident id ++ 
+        (pr_locality local ++ str"Notation " ++ pr_lident id ++
 	 prlist_with_sep spc pr_id ids ++ str" :=" ++ pr_constrarg c ++
          pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []))
   | VernacDeclareImplicits (local,q,None) ->
-      hov 2 (str"Implicit Arguments" ++ spc() ++ pr_reference q)
+      hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++ 
+	pr_smart_global q)
   | VernacDeclareImplicits (local,q,Some imps) ->
-      hov 1 (str"Implicit Arguments " ++ pr_non_locality local ++
-	spc() ++ pr_reference q ++ spc() ++
+      hov 1 (pr_section_locality local ++ str"Implicit Arguments " ++ 
+	spc() ++ pr_smart_global q ++ spc() ++
 	str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]")
-  | VernacReserve (idl,c) ->
-      hov 1 (str"Implicit Type" ++
-        str (if List.length idl > 1 then "s " else " ") ++
-        prlist_with_sep spc pr_lident idl ++ str " :" ++ spc () ++
-        pr_lconstr c)
+  | VernacReserve bl ->
+      let n = List.length (List.flatten (List.map fst bl)) in
+      hov 2 (str"Implicit Type" ++
+        str (if n > 1 then "s " else " ") ++
+        pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl))
+  | VernacGeneralizable (local, g) ->
+      hov 1 (pr_locality local ++ str"Generalizable Variable" ++
+		match g with
+		| None -> str "s none"
+		| Some [] -> str "s all"
+		| Some idl ->
+		    str (if List.length idl > 1 then "s " else " ") ++
+		      prlist_with_sep spc pr_lident idl)
   | VernacSetOpacity(b,[k,l]) when k=Conv_oracle.transparent ->
       hov 1 (str"Transparent" ++ pr_non_locality b ++
-             spc() ++ prlist_with_sep sep pr_reference l)
+             spc() ++ prlist_with_sep sep pr_smart_global l)
   | VernacSetOpacity(b,[Conv_oracle.Opaque,l]) ->
       hov 1 (str"Opaque" ++ pr_non_locality b ++
-             spc() ++ prlist_with_sep sep pr_reference l)
+             spc() ++ prlist_with_sep sep pr_smart_global l)
   | VernacSetOpacity (local,l) ->
       let pr_lev = function
           Conv_oracle.Opaque -> str"opaque"
@@ -838,28 +871,32 @@ let rec pr_vernac = function
         | Conv_oracle.Level n -> int n in
       let pr_line (l,q) =
         hov 2 (pr_lev l ++ spc() ++
-               str"[" ++ prlist_with_sep sep pr_reference q ++ str"]") in
-      hov 1 (pr_locality local ++ str"Strategy" ++ spc() ++
+               str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]") in
+      hov 1 (pr_non_locality local ++ str"Strategy" ++ spc() ++
              hv 0 (prlist_with_sep sep pr_line l))
-  | VernacUnsetOption na ->
-      hov 1 (str"Unset" ++ spc() ++ pr_printoption na None)
-  | VernacSetOption (na,v) -> hov 2 (str"Set" ++ spc() ++ pr_set_option na v)
+  | VernacUnsetOption (l,na) ->
+      hov 1 (pr_locality_full l ++ str"Unset" ++ spc() ++ pr_printoption na None)
+  | VernacSetOption (l,na,v) ->
+      hov 2 (pr_locality_full l ++ str"Set" ++ spc() ++ pr_set_option na v)
   | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l))
   | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l))
   | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l))
   | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None)
-  | VernacCheckMayEval (r,io,c) -> 
-      let pr_mayeval r c = match r with 
+  | VernacCheckMayEval (r,io,c) ->
+      let pr_mayeval r c = match r with
       | Some r0 ->
           hov 2 (str"Eval" ++ spc() ++
-          pr_red_expr (pr_constr,pr_lconstr,pr_or_by_notation pr_reference) r0 ++
+          pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
           spc() ++ str"in" ++ spc () ++ pr_constr c)
-      | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c) 
-      in 
-      (if io = None then mt() else int (Option.get io) ++ str ": ") ++ 
+      | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c)
+      in
+      (if io = None then mt() else int (Option.get io) ++ str ": ") ++
       pr_mayeval r c
   | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c)
-  | VernacPrint p -> 
+  | VernacDeclareReduction (b,s,r) ->
+     pr_locality b ++ str "Declare Reduction " ++ str s ++ str " := " ++
+     pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r
+  | VernacPrint p ->
       let pr_printable = function
 	| PrintFullContext -> str"Print All"
 	| PrintSectionContext s ->
@@ -873,54 +910,53 @@ let rec pr_vernac = function
 	| PrintGraph -> str"Print Graph"
 	| PrintClasses -> str"Print Classes"
 	| PrintTypeClasses -> str"Print TypeClasses"
-	| PrintInstances qid -> str"Print Instances" ++ spc () ++ pr_reference qid
-	| PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_reference qid
+	| PrintInstances qid -> str"Print Instances" ++ spc () ++ pr_smart_global qid
+	| PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_ltac_ref qid
 	| PrintCoercions -> str"Print Coercions"
 	| PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t
 	| PrintCanonicalConversions -> str"Print Canonical Structures"
 	| PrintTables -> str"Print Tables"
-	| PrintOpaqueName qid -> str"Print Term" ++ spc() ++ pr_reference qid
 	| PrintHintGoal -> str"Print Hint"
-	| PrintHint qid -> str"Print Hint" ++ spc() ++ pr_reference qid
+	| PrintHint qid -> str"Print Hint" ++ spc() ++ pr_smart_global qid
 	| PrintHintDb -> str"Print Hint *"
 	| PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s
 	| PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s
 	| PrintUniverses fopt -> str"Dump Universes" ++ pr_opt str fopt
-	| PrintName qid -> str"Print" ++ spc()  ++ pr_reference qid
+	| PrintName qid -> str"Print" ++ spc()  ++ pr_smart_global qid
 	| PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid
 	| PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid
 	| PrintInspect n -> str"Inspect" ++ spc() ++ int n
 	| PrintScopes -> str"Print Scopes"
-	| PrintScope s -> str"Print Scope" ++ spc() ++ str s 
-	| PrintVisibility s -> str"Print Visibility" ++ pr_opt str s 
-	| PrintAbout qid -> str"About" ++ spc()  ++ pr_reference qid
-	| PrintImplicit qid -> str"Print Implicit" ++ spc()  ++ pr_reference qid
-(* spiwack: command printing all the axioms and section variables used in a 
+	| PrintScope s -> str"Print Scope" ++ spc() ++ str s
+	| PrintVisibility s -> str"Print Visibility" ++ pr_opt str s
+	| PrintAbout qid -> str"About" ++ spc()  ++ pr_smart_global qid
+	| PrintImplicit qid -> str"Print Implicit" ++ spc()  ++ pr_smart_global qid
+(* spiwack: command printing all the axioms and section variables used in a
          term *)
 	| PrintAssumptions (b,qid) -> (if b then str"Print Assumptions" else str"Print Opaque Dependencies")
-	    ++spc()++pr_reference qid
+	    ++ spc() ++ pr_smart_global qid
       in pr_printable p
   | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_constr_pattern_expr
-  | VernacLocate loc -> 
+  | VernacLocate loc ->
       let pr_locate =function
-	| LocateTerm qid ->  pr_reference qid
+	| LocateTerm qid -> pr_smart_global qid
 	| LocateFile f -> str"File" ++ spc() ++ qs f
 	| LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid
 	| LocateModule qid -> str"Module" ++ spc () ++ pr_module qid
-	| LocateNotation s -> qs s
+	| LocateTactic qid -> str"Ltac" ++ spc () ++ pr_ltac_ref qid
       in str"Locate" ++ spc() ++ pr_locate loc
   | VernacComments l ->
       hov 2
         (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l)
   | VernacNop -> mt()
-  
+
   (* Toplevel control *)
   | VernacToplevelControl exn -> pr_topcmd exn
 
   (* For extension *)
   | VernacExtend (s,c) -> pr_extend s c
   | VernacProof (Tacexpr.TacId _) -> str "Proof"
-  | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te 
+  | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te
 
 and pr_extend s cl =
   let pr_arg a =
@@ -931,15 +967,15 @@ and pr_extend s cl =
     let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in
     let start,rl,cl =
       match rl with
-      | Egrammar.TacTerm s :: rl -> str s, rl, cl
-      | Egrammar.TacNonTerm _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl 
+      | Egrammar.GramTerminal s :: rl -> str s, rl, cl
+      | Egrammar.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl
       | [] -> anomaly "Empty entry" in
     let (pp,_) =
       List.fold_left
         (fun (strm,args) pi ->
           let pp,args = match pi with
-          | Egrammar.TacNonTerm _ -> (pr_arg (List.hd args), List.tl args)
-          | Egrammar.TacTerm s -> (str s, args) in
+          | Egrammar.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args)
+          | Egrammar.GramTerminal s -> (str s, args) in
           (strm ++ spc() ++ pp), args)
         (start,cl) rl in
     hov 1 pp
diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli
index 21d983f5..c24744f3 100644
--- a/parsing/ppvernac.mli
+++ b/parsing/ppvernac.mli
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: ppvernac.mli 7744 2005-12-27 09:16:06Z herbelin $ i*)
+
+(*i $Id$ i*)
 
 open Pp
 open Genarg
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
index 1e50bc51..21baeb58 100644
--- a/parsing/prettyp.ml
+++ b/parsing/prettyp.ml
@@ -10,7 +10,7 @@
  * on May-June 2006 for implementation of abstraction of pretty-printing of objects.
  *)
 
-(* $Id: prettyp.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -62,20 +62,20 @@ let with_line_skip p = if ismt p then mt() else (fnl () ++ p)
 
 (********************************)
 (** Printing implicit arguments *)
-			  		  
+
 let conjugate_to_be = function [_] -> "is" | _ -> "are"
 
 let pr_implicit imp = pr_id (name_of_implicit imp)
 
 let print_impl_args_by_name max = function
   | []  -> mt ()
-  | impls -> 
-      hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++ 
-      prlist_with_sep pr_coma pr_implicit impls ++ spc() ++ 
+  | impls ->
+      hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++
+      prlist_with_sep pr_comma pr_implicit impls ++ spc() ++
       str (conjugate_to_be impls) ++ str" implicit" ++
       (if max then strbrk " and maximally inserted" else mt())) ++ fnl()
 
-let print_impl_args l = 
+let print_impl_args l =
   let imps = List.filter is_status_implicit l in
   let maximps = List.filter Impargs.maximal_insertion_of imps in
   let nonmaximps = list_subtract imps maximps in
@@ -87,25 +87,25 @@ let print_impl_args l =
 
 let print_ref reduce ref =
   let typ = Global.type_of_global ref in
-  let typ = 
+  let typ =
     if reduce then
       let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ
-      in it_mkProd_or_LetIn ccl ctx 
+      in it_mkProd_or_LetIn ccl ctx
     else typ in
   hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) ++ fnl ()
 
 let print_argument_scopes = function
   | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl()
   | l when not (List.for_all ((=) None) l) ->
-      hov 2 (str"Argument scopes are" ++ spc() ++ 
-      str "[" ++ 
+      hov 2 (str"Argument scopes are" ++ spc() ++
+      str "[" ++
       prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++
       str "]") ++ fnl()
   | _  -> mt()
 
-let need_expansion impl ref = 
+let need_expansion impl ref =
   let typ = Global.type_of_global ref in
-  let ctx = fst (decompose_prod_assum typ) in
+  let ctx = (prod_assum typ) in
   let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in
   impl <> [] & List.length impl >= nprods &
     let _,lastimpl = list_chop nprods impl in
@@ -116,7 +116,7 @@ type opacity =
   | TransparentMaybeOpacified of Conv_oracle.level
 
 let opacity env = function
-  | VarRef v when pi2 (Environ.lookup_named v env) <> None -> 
+  | VarRef v when pi2 (Environ.lookup_named v env) <> None ->
       Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v)))
   | ConstRef cst ->
       let cb = Environ.lookup_constant cst env in
@@ -129,7 +129,7 @@ let opacity env = function
 let print_opacity ref =
   match opacity (Global.env()) ref with
     | None -> mt ()
-    | Some s -> pr_global ref ++ str " is " ++ 
+    | Some s -> pr_global ref ++ str " is " ++
         str (match s with
           | FullyOpaque -> "opaque"
           | TransparentMaybeOpacified Conv_oracle.Opaque ->
@@ -140,14 +140,14 @@ let print_opacity ref =
               "transparent (with expansion weight "^string_of_int n^")"
           | TransparentMaybeOpacified Conv_oracle.Expand ->
               "transparent (with minimal expansion weight)") ++ fnl()
-    
+
 let print_name_infos ref =
   let impl = implicits_of_global ref in
   let scopes = Notation.find_arguments_scope ref in
-  let type_for_implicit = 
+  let type_for_implicit =
     if need_expansion impl ref then
       (* Need to reduce since implicits are computed with products flattened *)
-      str "Expanded type for implicit arguments" ++ fnl () ++ 
+      str "Expanded type for implicit arguments" ++ fnl () ++
       print_ref true ref ++ fnl()
     else mt() in
   type_for_implicit ++ print_impl_args impl ++ print_argument_scopes scopes
@@ -155,14 +155,14 @@ let print_name_infos ref =
 let print_id_args_data test pr id l =
   if List.exists test l then
     str"For " ++ pr_id id ++ str": " ++ pr l
-  else 
+  else
     mt()
 
 let print_args_data_of_inductive_ids get test pr sp mipv =
   prvecti
-    (fun i mip -> 
+    (fun i mip ->
       print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) ++
-      prvecti 
+      prvecti
 	(fun j idc ->
 	  print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1))))
         mip.mind_consnames)
@@ -173,7 +173,7 @@ let print_inductive_implicit_args =
     implicits_of_global is_status_implicit print_impl_args
 
 let print_inductive_argument_scopes =
-  print_args_data_of_inductive_ids 
+  print_args_data_of_inductive_ids
     Notation.find_arguments_scope ((<>) None) print_argument_scopes
 
 (*********************)
@@ -190,8 +190,8 @@ let locate_any_name ref =
   let module N = Nametab in
   let (loc,qid) = qualid_of_reference ref in
   try Term (N.locate qid)
-  with Not_found -> 
-  try Syntactic (N.locate_syntactic_definition qid)
+  with Not_found ->
+  try Syntactic (N.locate_syndef qid)
   with Not_found ->
   try Dir (N.locate_dir qid)
   with Not_found ->
@@ -205,9 +205,9 @@ let pr_located_qualid = function
 	| IndRef _ -> "Inductive"
 	| ConstructRef _ -> "Constructor"
 	| VarRef _ -> "Variable" in
-      str ref_str ++ spc () ++ pr_sp (Nametab.sp_of_global ref)
+      str ref_str ++ spc () ++ pr_path (Nametab.path_of_global ref)
   | Syntactic kn ->
-      str "Notation" ++ spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn)
+      str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn)
   | Dir dir ->
       let s,dir = match dir with
 	| DirOpenModule (dir,_) -> "Open Module", dir
@@ -218,8 +218,8 @@ let pr_located_qualid = function
       in
       str s ++ spc () ++ pr_dirpath dir
   | ModuleType (qid,_) ->
-      str "Module Type" ++ spc () ++ pr_sp (Nametab.full_name_modtype qid)
-  | Undefined qid ->    
+      str "Module Type" ++ spc () ++ pr_path (Nametab.full_name_modtype qid)
+  | Undefined qid ->
       pr_qualid qid ++ spc () ++ str "not a defined object."
 
 let print_located_qualid ref =
@@ -228,10 +228,10 @@ let print_located_qualid ref =
   let expand = function
     | TrueGlobal ref ->
 	Term ref, N.shortest_qualid_of_global Idset.empty ref
-    | SyntacticDef kn ->
+    | SynDef kn ->
 	Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in
-  match List.map expand (N.extended_locate_all qid) with
-    | [] -> 
+  match List.map expand (N.locate_extended_all qid) with
+    | [] ->
 	let (dir,id) = repr_qualid qid in
 	if dir = empty_dirpath then
 	  str "No object of basename " ++ pr_id id
@@ -291,7 +291,7 @@ let print_constructors envpar names types =
     prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
       (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c)
       (Array.to_list (array_map2 (fun n t -> (n,t)) names types))
-  in 
+  in
   hv 0 (str "  " ++ pc)
 
 let build_inductive sp tyi =
@@ -300,7 +300,7 @@ let build_inductive sp tyi =
   let args = extended_rel_list 0 params in
   let env = Global.env() in
   let fullarity = match mip.mind_arity with
-    | Monomorphic ar -> ar.mind_user_arity 
+    | Monomorphic ar -> ar.mind_user_arity
     | Polymorphic ar ->
 	it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt in
   let arity = hnf_prod_applist env fullarity args in
@@ -335,7 +335,7 @@ let get_fields =
 	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
 	prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c
     | _               -> List.rev l
-  in 
+  in
   prodec_rec [] []
 
 let pr_record (sp,tyi) =
@@ -345,15 +345,15 @@ let pr_record (sp,tyi) =
   let fields = get_fields cstrtypes.(0) in
   hov 0 (
     hov 0 (
-      str "Record " ++ pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ 
+      str "Record " ++ pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++
       print_params env params ++
-      str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ 
-      str ":= " ++ pr_id cstrnames.(0)) ++ 
+      str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++
+      str ":= " ++ pr_id cstrnames.(0)) ++
     brk(1,2) ++
-    hv 2 (str "{" ++
-      prlist_with_sep (fun () -> str ";" ++ brk(1,0))
-        (fun (id,b,c) -> 
-	  str " " ++ pr_id id ++ str (if b then " : " else " := ") ++ 
+    hv 2 (str "{ " ++
+      prlist_with_sep (fun () -> str ";" ++ brk(2,0))
+        (fun (id,b,c) ->
+	  pr_id id ++ str (if b then " : " else " := ") ++
 	  pr_lconstr_env envpar c) fields) ++ str" }")
 
 let gallina_print_inductive sp =
@@ -364,11 +364,11 @@ let gallina_print_inductive sp =
     pr_record (List.hd names)
   else
     pr_mutual_inductive mib.mind_finite names) ++ fnl () ++
-  with_line_skip 
+  with_line_skip
     (print_inductive_implicit_args sp mipv ++
      print_inductive_argument_scopes sp mipv)
 
-let print_named_decl id = 
+let print_named_decl id =
   gallina_print_named_decl (Global.lookup_named id) ++ fnl ()
 
 let gallina_print_section_variable id =
@@ -391,26 +391,26 @@ let print_constant with_values sep sp =
   let val_0 = cb.const_body in
   let typ = ungeneralized_type_of_constant_type cb.const_type in
   hov 0 (
-    match val_0 with 
-    | None -> 
-	str"*** [ " ++ 
-	print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ 
+    match val_0 with
+    | None ->
+	str"*** [ " ++
+	print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++
 	str" ]"
-    | _ -> 
+    | _ ->
 	print_basename sp ++ str sep ++ cut () ++
 	(if with_values then print_typed_body (val_0,typ) else pr_ltype typ))
   ++ fnl ()
 
 let gallina_print_constant_with_infos sp =
-  print_constant true " = " sp ++ 
+  print_constant true " = " sp ++
   with_line_skip (print_name_infos (ConstRef sp))
 
 let gallina_print_syntactic_def kn =
   let sep = " := "
   and qid = Nametab.shortest_qualid_of_syndef Idset.empty kn
-  and (vars,a) = Syntax_def.search_syntactic_definition dummy_loc kn in 
+  and (vars,a) = Syntax_def.search_syntactic_definition kn in
   let c = Topconstr.rawconstr_of_aconstr dummy_loc a in
-  str "Notation " ++ pr_qualid qid ++ 
+  str "Notation " ++ pr_qualid qid ++
   prlist_with_sep spc pr_id (List.map fst vars) ++ str sep ++
   Constrextern.without_symbols pr_lrawconstr c ++ fnl ()
 
@@ -419,42 +419,42 @@ let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) =
   and tag = object_tag lobj in
     match (oname,tag) with
       | (_,"VARIABLE") ->
-	  (* Outside sections, VARIABLES still exist but only with universes 
+	  (* Outside sections, VARIABLES still exist but only with universes
              constraints *)
 	  (try Some(print_named_decl (basename sp)) with Not_found -> None)
       | (_,"CONSTANT") ->
 	  Some (print_constant with_values sep (constant_of_kn kn))
       | (_,"INDUCTIVE") ->
-	  Some (gallina_print_inductive kn)
+	  Some (gallina_print_inductive (mind_of_kn kn))
       | (_,"MODULE") ->
-	  let (mp,_,l) = repr_kn kn in 
+	  let (mp,_,l) = repr_kn kn in
 	    Some (print_module with_values (MPdot (mp,l)))
       | (_,"MODULE TYPE") ->
-	  let (mp,_,l) = repr_kn kn in 
+	  let (mp,_,l) = repr_kn kn in
 	  Some (print_modtype (MPdot (mp,l)))
       | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"|
 	    "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None
       (* To deal with forgotten cases... *)
       | (_,s) -> None
 
-let gallina_print_library_entry with_values ent = 
+let gallina_print_library_entry with_values ent =
   let pr_name (sp,_) = pr_id (basename sp) in
   match ent with
-    | (oname,Lib.Leaf lobj) -> 
+    | (oname,Lib.Leaf lobj) ->
 	gallina_print_leaf_entry with_values (oname,lobj)
-    | (oname,Lib.OpenedSection (dir,_)) -> 
+    | (oname,Lib.OpenedSection (dir,_)) ->
         Some (str " >>>>>>> Section " ++ pr_name oname)
-    | (oname,Lib.ClosedSection _) -> 
+    | (oname,Lib.ClosedSection _) ->
         Some (str " >>>>>>> Closed Section " ++ pr_name oname)
     | (_,Lib.CompilingLibrary (dir,_)) ->
 	Some (str " >>>>>>> Library " ++ pr_dirpath dir)
     | (oname,Lib.OpenedModule _) ->
 	Some (str " >>>>>>> Module " ++ pr_name oname)
-    | (oname,Lib.ClosedModule _) -> 
+    | (oname,Lib.ClosedModule _) ->
         Some (str " >>>>>>> Closed Module " ++ pr_name oname)
     | (oname,Lib.OpenedModtype _) ->
 	Some (str " >>>>>>> Module Type " ++ pr_name oname)
-    | (oname,Lib.ClosedModtype _) -> 
+    | (oname,Lib.ClosedModtype _) ->
         Some (str " >>>>>>> Closed Module Type " ++ pr_name oname)
     | (_,Lib.FrozenState _) ->
 	None
@@ -464,14 +464,14 @@ let gallina_print_leaf_entry with_values c =
     | None    -> mt ()
     | Some pp -> pp ++ fnl()
 
-let gallina_print_context with_values = 
+let gallina_print_context with_values =
   let rec prec n = function
-    | h::rest when n = None or Option.get n > 0 -> 
+    | h::rest when n = None or Option.get n > 0 ->
 	(match gallina_print_library_entry with_values h with
 	  | None -> prec n rest
 	  | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ())
     | _ -> mt ()
-  in 
+  in
   prec
 
 let gallina_print_eval red_fun env evmap _ {uj_val=trm;uj_type=typ} =
@@ -520,16 +520,16 @@ let print_typed_value x = print_typed_value_in_env (Global.env ()) x
 
 let print_judgment env {uj_val=trm;uj_type=typ} =
   print_typed_value_in_env env (trm, typ)
-    
+
 let print_safe_judgment env j =
   let trm = Safe_typing.j_val j in
   let typ = Safe_typing.j_type j in
   print_typed_value_in_env env (trm, typ)
-    
+
 (*********************)
 (* *)
 
-let print_full_context () = 
+let print_full_context () =
   print_context true None (Lib.contents_after None)
 
 let print_full_context_typ () =
@@ -540,33 +540,34 @@ let print_full_pure_context () =
   | ((_,kn),Lib.Leaf lobj)::rest ->
       let pp = match object_tag lobj with
       | "CONSTANT" ->
-	  let con = constant_of_kn kn in
+	  let con = Global.constant_of_delta (constant_of_kn kn) in
 	  let cb = Global.lookup_constant con in
 	  let val_0 = cb.const_body in
 	  let typ = ungeneralized_type_of_constant_type cb.const_type in
 	  hov 0 (
-	    match val_0 with 
+	    match val_0 with
 	    | None ->
 		str (if cb.const_opaque then "Axiom " else "Parameter ") ++
 		print_basename con ++ str " : " ++ cut () ++ pr_ltype typ
 	    | Some v ->
 		if cb.const_opaque then
-		  str "Theorem " ++ print_basename con ++ cut () ++ 
+		  str "Theorem " ++ print_basename con ++ cut () ++
 		  str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++
 		  str "Proof " ++ print_body val_0
 		else
-		  str "Definition " ++ print_basename con ++ cut () ++ 
+		  str "Definition " ++ print_basename con ++ cut () ++
 		  str "  : " ++ pr_ltype typ ++ cut () ++ str " := " ++
 		  print_body val_0) ++ str "." ++ fnl () ++ fnl ()
       | "INDUCTIVE" ->
-	  let (mib,mip) = Global.lookup_inductive (kn,0) in
+	  let mind = Global.mind_of_delta (mind_of_kn kn) in
+	  let (mib,mip) = Global.lookup_inductive (mind,0) in
 	  let mipv = mib.mind_packets in
-	  let names = list_tabulate (fun x -> (kn,x)) (Array.length mipv) in
-	  pr_mutual_inductive mib.mind_finite names ++ str "." ++ 
+	  let names = list_tabulate (fun x -> (mind,x)) (Array.length mipv) in
+	  pr_mutual_inductive mib.mind_finite names ++ str "." ++
 	  fnl () ++ fnl ()
       | "MODULE" ->
 	  (* TODO: make it reparsable *)
-	  let (mp,_,l) = repr_kn kn in 
+	  let (mp,_,l) = repr_kn kn in
 	  print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl ()
       | "MODULE TYPE" ->
 	  (* TODO: make it reparsable *)
@@ -576,7 +577,7 @@ let print_full_pure_context () =
       | _ -> mt () in
       prec rest ++ pp
   | _::rest -> prec rest
-  | _ -> mt () in 
+  | _ -> mt () in
   prec (Lib.contents_after None)
 
 (* For printing an inductive definition with
@@ -584,14 +585,14 @@ let print_full_pure_context () =
    assume that the declaration of constructors and eliminations
    follows the definition of the inductive type *)
 
-let list_filter_vec f vec = 
-  let rec frec n lf = 
-    if n < 0 then lf 
-    else if f vec.(n) then 
+let list_filter_vec f vec =
+  let rec frec n lf =
+    if n < 0 then lf
+    else if f vec.(n) then
       frec (n-1) (vec.(n)::lf)
-    else 
+    else
       frec (n-1) lf
-  in 
+  in
   frec (Array.length vec -1) []
 
 (* This is designed to print the contents of an opened section *)
@@ -608,19 +609,18 @@ let read_sec_context r =
         error "Cannot print the contents of a closed section."
 	(* LEM: Actually, we could if we wanted to. *)
     | [] -> []
-    | hd::rest -> get_cxt (hd::in_cxt) rest 
+    | hd::rest -> get_cxt (hd::in_cxt) rest
   in
   let cxt = (Lib.contents_after None) in
   List.rev (get_cxt [] cxt)
 
-let print_sec_context sec = 
+let print_sec_context sec =
   print_context true None (read_sec_context sec)
 
 let print_sec_context_typ sec =
   print_context false None (read_sec_context sec)
 
-let print_name ref = 
-  match locate_any_name ref with
+let print_any_name = function
   | Term (ConstRef sp) -> print_constant_with_infos sp
   | Term (IndRef (sp,_)) -> print_inductive sp
   | Term (ConstructRef ((sp,_),_)) -> print_inductive sp
@@ -631,49 +631,44 @@ let print_name ref =
   | ModuleType (_,kn) -> print_modtype kn
   | Undefined qid ->
   try  (* Var locale de but, pas var de section... donc pas d'implicits *)
-    let dir,str = repr_qualid qid in 
+    let dir,str = repr_qualid qid in
     if (repr_dirpath dir) <> [] then raise Not_found;
-    let (_,c,typ) = Global.lookup_named str in 
+    let (_,c,typ) = Global.lookup_named str in
     (print_named_decl (str,c,typ))
   with Not_found ->
-  try 
-    let sp = Nametab.locate_obj qid in
-    let (oname,lobj) = 
-      let (oname,entry) =
-	List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None)
-      in
-      match entry with
-	| Lib.Leaf obj -> (oname,obj)
-	| _ -> raise Not_found
-    in
-    print_leaf_entry true (oname,lobj)
-  with Not_found ->
     errorlabstrm
       "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.")
 
-let print_opaque_name qid = 
+let print_name = function
+  | Genarg.ByNotation (loc,ntn,sc) ->
+      print_any_name
+        (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
+               ntn sc))
+  | Genarg.AN ref ->
+      print_any_name (locate_any_name ref)
+
+let print_opaque_name qid =
   let env = Global.env () in
   match global qid with
     | ConstRef cst ->
 	let cb = Global.lookup_constant cst in
         if cb.const_body <> None then
 	  print_constant_with_infos cst
-        else 
+        else
 	  error "Not a defined constant."
     | IndRef (sp,_) ->
         print_inductive sp
-    | ConstructRef cstr -> 
+    | ConstructRef cstr ->
 	let ty = Inductiveops.type_of_constructor env cstr in
 	print_typed_value (mkConstruct cstr, ty)
     | VarRef id ->
-        let (_,c,ty) = lookup_named id env in 
+        let (_,c,ty) = lookup_named id env in
 	print_named_decl (id,c,ty)
 
-let print_about ref = 
-  let k = locate_any_name ref in
+let print_about_any k =
   begin match k with
   | Term ref ->
-      print_ref false ref ++ fnl () ++ print_name_infos ref ++ 
+      print_ref false ref ++ fnl () ++ print_name_infos ref ++
       print_opacity ref
   | Syntactic kn ->
       print_syntactic_def kn
@@ -682,26 +677,34 @@ let print_about ref =
   ++
   hov 0 (str "Expands to: " ++ pr_located_qualid k)
 
+let print_about = function
+  | Genarg.ByNotation (loc,ntn,sc) ->
+      print_about_any
+        (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
+               ntn sc))
+  | Genarg.AN ref ->
+      print_about_any (locate_any_name ref)
+
 let print_impargs ref =
-  let ref = Nametab.global ref in
+  let ref = Smartlocate.smart_global ref in
   let impl = implicits_of_global ref in
   let has_impl = List.filter is_status_implicit impl <> [] in
   (* Need to reduce since implicits are computed with products flattened *)
   print_ref (need_expansion impl ref) ref ++ fnl() ++
-  (if has_impl then print_impl_args impl 
+  (if has_impl then print_impl_args impl
    else (str "No implicit arguments" ++ fnl ()))
 
-let unfold_head_fconst = 
+let unfold_head_fconst =
   let rec unfrec k = match kind_of_term k with
-    | Const cst -> constant_value (Global.env ()) cst 
+    | Const cst -> constant_value (Global.env ()) cst
     | Lambda (na,t,b) -> mkLambda (na,t,unfrec b)
     | App (f,v) -> appvect (unfrec f,v)
     | _ -> k
-  in 
+  in
   unfrec
 
 (* for debug *)
-let inspect depth = 
+let inspect depth =
   print_context false (Some depth) (Lib.contents_after None)
 
 
@@ -715,8 +718,8 @@ let print_coercion_value v = pr_lconstr (get_coercion_value v)
 let print_class i =
   let cl,_ = class_info_from_index i in
   pr_class cl
-  
-let print_path ((i,j),p) = 
+
+let print_path ((i,j),p) =
   hov 2 (
     str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++
     str"] : ") ++
@@ -724,45 +727,39 @@ let print_path ((i,j),p) =
 
 let _ = Classops.install_path_printer print_path
 
-let print_graph () = 
+let print_graph () =
   prlist_with_sep pr_fnl print_path (inheritance_graph())
 
-let print_classes () = 
+let print_classes () =
   prlist_with_sep pr_spc pr_class (classes())
 
-let print_coercions () = 
+let print_coercions () =
   prlist_with_sep pr_spc print_coercion_value (coercions())
-  
+
 let index_of_class cl =
-  try 
+  try
     fst (class_info cl)
-  with _ -> 
+  with _ ->
     errorlabstrm "index_of_class"
       (pr_class cl ++ spc() ++ str "not a defined class.")
 
-let print_path_between cls clt = 
+let print_path_between cls clt =
   let i = index_of_class cls in
   let j = index_of_class clt in
-  let p = 
-    try 
-      lookup_path_between_class (i,j) 
-    with _ -> 
+  let p =
+    try
+      lookup_path_between_class (i,j)
+    with _ ->
       errorlabstrm "index_cl_of_id"
         (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt
 	 ++ str ".")
   in
   print_path ((i,j),p)
 
-let pr_cs_pattern = function  
-    Const_cs c -> pr_global c
-  | Prod_cs -> str "_ -> _"
-  | Default_cs -> str "_"
-  | Sort_cs s -> pr_sort_family s
-
 let print_canonical_projections () =
-  prlist_with_sep pr_fnl 
-    (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ 
-    str " <- " ++ 
+  prlist_with_sep pr_fnl
+    (fun ((r1,r2),o) -> pr_cs_pattern r2 ++
+    str " <- " ++
     pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )")
     (canonical_projections ())
 
@@ -773,25 +770,25 @@ let print_canonical_projections () =
 
 open Typeclasses
 
-let pr_typeclass env t = 
+let pr_typeclass env t =
   print_ref false t.cl_impl
 
 let print_typeclasses () =
   let env = Global.env () in
     prlist_with_sep fnl (pr_typeclass env) (typeclasses ())
-      
-let pr_instance env i = 
+
+let pr_instance env i =
   (*   gallina_print_constant_with_infos i.is_impl *)
   (* lighter *)
-  print_ref false (ConstRef (instance_impl i))
-    
+  print_ref false (instance_impl i)
+
 let print_all_instances () =
   let env = Global.env () in
-  let inst = all_instances () in 
+  let inst = all_instances () in
     prlist_with_sep fnl (pr_instance env) inst
 
 let print_instances r =
   let env = Global.env () in
-  let inst = instances r in 
+  let inst = instances r in
     prlist_with_sep fnl (pr_instance env) inst
-      
+
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
index ec2228c7..ba1977e8 100644
--- a/parsing/prettyp.mli
+++ b/parsing/prettyp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: prettyp.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -18,6 +18,7 @@ open Environ
 open Reductionops
 open Libnames
 open Nametab
+open Genarg
 (*i*)
 
 (* A Pretty-Printer for the Calculus of Inductive Constructions. *)
@@ -40,10 +41,10 @@ val print_eval :
 (* This function is exported for the graphical user-interface pcoq *)
 val build_inductive : mutual_inductive -> int ->
   global_reference * rel_context * types * identifier array * types array
-val print_name : reference -> std_ppcmds
+val print_name : reference or_by_notation -> std_ppcmds
 val print_opaque_name : reference -> std_ppcmds
-val print_about : reference -> std_ppcmds
-val print_impargs : reference -> std_ppcmds
+val print_about : reference or_by_notation -> std_ppcmds
+val print_impargs : reference or_by_notation -> std_ppcmds
 
 (*i
 val print_extracted_name : identifier -> std_ppcmds
diff --git a/parsing/printer.ml b/parsing/printer.ml
index 0c673fbd..7f5087a8 100644
--- a/parsing/printer.ml
+++ b/parsing/printer.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: printer.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -20,7 +20,6 @@ open Global
 open Declare
 open Libnames
 open Nametab
-open Ppconstr
 open Evd
 open Proof_type
 open Decl_mode
@@ -30,11 +29,11 @@ open Ppconstr
 open Constrextern
 open Tacexpr
 
-let emacs_str s alts = 
+let emacs_str s alts =
   match !Flags.print_emacs, !Flags.print_emacs_safechar with
     | true, true -> alts
     | true , false -> s
-    | false,_ -> "" 
+    | false,_ -> ""
 
 (**********************************************************************)
 (** Terms                                                             *)
@@ -59,6 +58,19 @@ let pr_constr t = pr_constr_env (Global.env()) t
 let pr_open_lconstr (_,c) = pr_lconstr c
 let pr_open_constr (_,c) = pr_constr c
 
+let pr_constr_under_binders_env_gen pr env (ids,c) =
+  (* Warning: clashes can occur with variables of same name in env but *)
+  (* we also need to preserve the actual names of the patterns *)
+  (* So what to do? *)
+  let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) ids in
+  pr (push_rels_assum assums env) c
+
+let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_constr_env
+let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_lconstr_env
+
+let pr_constr_under_binders c = pr_constr_under_binders_env (Global.env()) c
+let pr_lconstr_under_binders c = pr_lconstr_under_binders_env (Global.env()) c
+
 let pr_type_core at_top env t =
   pr_constr_expr (extern_type at_top env t)
 let pr_ltype_core at_top env t =
@@ -78,7 +90,7 @@ let pr_ljudge j = pr_ljudge_env (Global.env()) j
 
 let pr_lrawconstr_env env c =
   pr_lconstr_expr (extern_rawconstr (vars_of_env env) c)
-let pr_rawconstr_env env c = 
+let pr_rawconstr_env env c =
   pr_constr_expr (extern_rawconstr (vars_of_env env) c)
 
 let pr_lrawconstr c =
@@ -115,10 +127,7 @@ let pr_inductive env ind = pr_lconstr_env env (mkInd ind)
 let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr)
 
 let pr_evaluable_reference ref =
- let ref' = match ref with
-  | EvalConstRef const -> ConstRef const
-  | EvalVarRef sp -> VarRef sp in
- pr_global ref'
+  pr_global (Tacred.global_of_evaluable_reference ref)
 
 (*let pr_rawterm t =
   pr_lconstr (Constrextern.extern_rawconstr Idset.empty t)*)
@@ -134,7 +143,7 @@ let pr_var_decl env (id,c,typ) =
   let pbody = match c with
     | None ->  (mt ())
     | Some c ->
-	(* Force evaluation *) 
+	(* Force evaluation *)
 	let pb = pr_lconstr_env env c in
 	let pb = if isCast c then surround pb else pb in
 	(str" := " ++ pb ++ cut () ) in
@@ -146,7 +155,7 @@ let pr_rel_decl env (na,c,typ) =
   let pbody = match c with
     | None -> mt ()
     | Some c ->
-	(* Force evaluation *) 
+	(* Force evaluation *)
 	let pb = pr_lconstr_env env c in
 	let pb = if isCast c then surround pb else pb in
 	(str":=" ++ spc () ++ pb ++ spc ()) in
@@ -166,7 +175,7 @@ let pr_named_context_of env =
   let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in
   hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl)
 
-let pr_named_context env ne_context = 
+let pr_named_context env ne_context =
   hv 0 (Sign.fold_named_context
 	  (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d)
           ne_context ~init:(mt ()))
@@ -183,14 +192,14 @@ let pr_context_unlimited env =
     fold_named_context
       (fun env d pps ->
          let pidt =  pr_var_decl env d in (pps ++ fnl () ++ pidt))
-      env ~init:(mt ()) 
+      env ~init:(mt ())
   in
   let db_env =
     fold_rel_context
       (fun env d pps ->
          let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
       env ~init:(mt ())
-  in 
+  in
   (sign_env ++ db_env)
 
 let pr_ne_context_of header env =
@@ -201,21 +210,21 @@ let pr_ne_context_of header env =
 let pr_context_limit n env =
   let named_context = Environ.named_context env in
   let lgsign = List.length named_context in
-  if n >= lgsign then 
+  if n >= lgsign then
     pr_context_unlimited env
   else
     let k = lgsign-n in
     let _,sign_env =
       fold_named_context
         (fun env d (i,pps) ->
-           if i < k then 
+           if i < k then
 	     (i+1, (pps ++str "."))
 	   else
              let pidt = pr_var_decl env d in
 	     (i+1, (pps ++ fnl () ++
 		      str (emacs_str (String.make 1 (Char.chr 253)) "") ++
 		      pidt)))
-        env ~init:(0,(mt ())) 
+        env ~init:(0,(mt ()))
     in
     let db_env =
       fold_rel_context
@@ -225,10 +234,10 @@ let pr_context_limit n env =
 	      str (emacs_str (String.make 1 (Char.chr 253)) "") ++
 	      pnat))
         env ~init:(mt ())
-    in 
+    in
     (sign_env ++ db_env)
 
-let pr_context_of env = match Flags.print_hyps_limit () with 
+let pr_context_of env = match Flags.print_hyps_limit () with
   | None -> hv 0 (pr_context_unlimited env)
   | Some n -> hv 0 (pr_context_limit n env)
 
@@ -238,33 +247,33 @@ let pr_restricted_named_context among env =
   hv 0 (fold_named_context
 	  (fun env ((id,_,_) as d) pps ->
 	     if true || Idset.mem id among then
-	       pps ++ 
+	       pps ++
 		 fnl () ++ str (emacs_str (String.make 1 (Char.chr 253)) "") ++
 		 pr_var_decl env d
-	     else 
+	     else
 	       pps)
           env ~init:(mt ()))
 
 
-let pr_predicate pr_elt (b, elts) = 
+let pr_predicate pr_elt (b, elts) =
   let pr_elts = prlist_with_sep spc pr_elt elts in
     if b then
-      str"all" ++ 
+      str"all" ++
 	(if elts = [] then mt () else str" except: " ++ pr_elts)
     else
       if elts = [] then str"none" else pr_elts
-      
+
 let pr_cpred p = pr_predicate pr_con (Cpred.elements p)
 let pr_idpred p = pr_predicate Nameops.pr_id (Idpred.elements p)
 
-let pr_transparent_state (ids, csts) = 
+let pr_transparent_state (ids, csts) =
   hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++
 	str"CONSTANTS: " ++ pr_cpred csts ++ fnl ())
 
 let pr_subgoal_metas metas env=
-  let pr_one (meta,typ) = 
-    str "?" ++ int meta ++ str " : " ++ 
-      hov 0 (pr_ltype_env_at_top env typ) ++ fnl () ++ 
+  let pr_one (meta,typ) =
+    str "?" ++ int meta ++ str " : " ++
+      hov 0 (pr_ltype_env_at_top env typ) ++ fnl () ++
       str (emacs_str (String.make 1 (Char.chr 253)) "") in
     hv 0 (prlist_with_sep mt pr_one metas)
 
@@ -276,9 +285,9 @@ let default_pr_goal g =
           mt (), mt (),
 	  pr_context_of env,
 	  pr_ltype_env_at_top env g.evar_concl
-    else 
+    else
       (str "     *** Declarative Mode ***" ++ fnl ()++fnl ()),
-      (str"thesis := "  ++ fnl ()),
+      (str "thesis := "  ++ fnl ()),
        pr_context_of env,
        pr_ltype_env_at_top env g.evar_concl
   in
@@ -287,7 +296,7 @@ let default_pr_goal g =
 		       str (emacs_str (String.make 1 (Char.chr 253)) "")  ++
 		       str "============================" ++ fnl ()  ++
 		       thesis ++ str " " ++  pc) ++ fnl ()
-     
+
 (* display the conclusion of a goal *)
 let pr_concl n g =
   let env = evar_env g in
@@ -296,13 +305,13 @@ let pr_concl n g =
       str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" "  ++ pc
 
 (* display evar type: a context and a type *)
-let pr_evgl_sign gl = 
+let pr_evgl_sign gl =
   let ps = pr_named_context_of (evar_unfiltered_env gl) in
   let _,l = list_filter2 (fun b c -> not b) (evar_filter gl,evar_context gl) in
   let ids = List.rev (List.map pi1 l) in
   let warn =
     if ids = [] then mt () else
-      (str "(" ++ prlist_with_sep pr_coma pr_id ids ++ str " cannot be used)")
+      (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
   in
   let pc = pr_lconstr gl.evar_concl in
   hov 0 (str"[" ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]" ++ spc () ++ warn)
@@ -311,10 +320,10 @@ let pr_evgl_sign gl =
 let rec pr_evars_int i = function
   | [] -> (mt ())
   | (ev,evd)::rest ->
-      let pegl = pr_evgl_sign evd in 
+      let pegl = pr_evgl_sign evd in
       let pei = pr_evars_int (i+1) rest in
       (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++
-              str (string_of_existential ev)  ++ str " : " ++ pegl)) ++ 
+              str (string_of_existential ev)  ++ str " : " ++ pegl)) ++
       fnl () ++ pei
 
 let default_pr_subgoal n =
@@ -324,27 +333,27 @@ let default_pr_subgoal n =
        	if p = 1 then
           let pg = default_pr_goal g in
           v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg)
-       	else 
+       	else
 	  prrec (p-1) rest
-  in 
+  in
   prrec n
 
 (* Print open subgoals. Checks for uninstantiated existential variables *)
-let default_pr_subgoals close_cmd sigma = function 
-  | [] -> 
+let default_pr_subgoals close_cmd sigma = function
+  | [] ->
       begin
 	match close_cmd with
 	  Some cmd ->
-	    (str "Subproof completed, now type " ++ str cmd ++ 
+	    (str "Subproof completed, now type " ++ str cmd ++
 	       str "." ++ fnl ())
 	| None ->
-	    let exl = Evarutil.non_instantiated sigma in 
-	      if exl = [] then 
-		(str"Proof completed."  ++ fnl ())
+	    let exl = Evarutil.non_instantiated sigma in
+	      if exl = [] then
+		(str"Proof completed." ++ fnl ())
 	      else
 		let pei = pr_evars_int 1 exl in
 		  (str "No more subgoals but non-instantiated existential " ++
-		     str "variables :"  ++fnl () ++ (hov 0 pei))
+		     str "variables:" ++ fnl () ++ (hov 0 pei))
       end
   | [g] ->
       let pg = default_pr_goal g in
@@ -355,11 +364,11 @@ let default_pr_subgoals close_cmd sigma = function
         | g::rest ->
             let pc = pr_concl n g in
             let prest = pr_rec (n+1) rest in
-            (cut () ++ pc ++ prest) 
+            (cut () ++ pc ++ prest)
       in
       let pg1 = default_pr_goal g1 in
       let prest = pr_rec 2 rest in
-      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () 
+      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut ()
 	   ++ pg1 ++ prest ++ fnl ())
 
 
@@ -390,24 +399,19 @@ let pr_goal     x = !printer_pr.pr_goal     x
 (* End abstraction layer                                              *)
 (**********************************************************************)
 
-let pr_subgoals_of_pfts pfts =
-  let close_cmd = Decl_mode.get_end_command pfts in
-  let gls = fst (Refiner.frontier (proof_of_pftreestate pfts)) in 
-  let sigma = (top_goal_of_pftreestate pfts).sigma in
-    pr_subgoals close_cmd sigma gls
-      
 let pr_open_subgoals () =
   let pfts = get_pftreestate () in
+  let gls = fst (frontier (proof_of_pftreestate pfts)) in
   match focus() with
-    | 0 -> 
-	pr_subgoals_of_pfts pfts
-    | n -> 
-	let pf = proof_of_pftreestate pfts in
-	let gls = fst (frontier pf) in 
+    | 0 ->
+        let sigma = (top_goal_of_pftreestate pfts).sigma in
+        let close_cmd = Decl_mode.get_end_command pfts in
+        pr_subgoals close_cmd sigma gls
+    | n ->
 	assert (n > List.length gls);
-	if List.length gls < 2 then 
+	if List.length gls < 2 then
 	  pr_subgoal n gls
-	else 
+	else
 	  (* LEM TODO: this way of saying how many subgoals has to be abstracted out*)
 	  v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++
 	  pr_subgoal n gls)
@@ -419,25 +423,25 @@ let pr_nth_open_subgoal n =
 (* Elementary tactics *)
 
 let pr_prim_rule = function
-  | Intro id -> 
+  | Intro id ->
       str"intro " ++ pr_id id
-	
+
   | Cut (b,replace,id,t) ->
      if b then
        (* TODO: express "replace" *)
        (str"assert " ++ str"(" ++ pr_id id ++ str":" ++ pr_lconstr t ++ str")")
      else
        let cl = if replace then str"clear " ++ pr_id id ++ str"; " else mt() in
-       (str"cut " ++ pr_constr t ++ 
+       (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) -> 
+
+  | FixRule (f,n,others,j) ->
       if j<>0 then warning "Unsupported printing of \"fix\"";
       let rec print_mut = function
-	| (f,n,ar)::oth -> 
+	| (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 ++
@@ -453,26 +457,26 @@ let pr_prim_rule = function
 	  (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth)
         | [] -> mt () in
       (str"cofix " ++ pr_id f ++  str" with " ++ print_mut others)
-  | Refine c -> 
+  | Refine c ->
       str(if occur_meta c then "refine " else "exact ") ++
       Constrextern.with_meta_as_hole pr_constr c
-      
+
   | Convert_concl (c,_) ->
       (str"change "  ++ pr_constr c)
-      
+
   | Convert_hyp (id,None,t) ->
       (str"change "  ++ pr_constr t  ++ spc ()  ++ str"in "  ++ pr_id id)
 
   | Convert_hyp (id,Some c,t) ->
       (str"change "  ++ pr_constr c  ++ spc ()  ++ str"in "
        ++ pr_id id ++ str" (type of "  ++ pr_id id ++ str ")")
-      
+
   | Thin ids ->
       (str"clear "  ++ prlist_with_sep pr_spc pr_id ids)
-      
+
   | ThinBody ids ->
       (str"clearbody "  ++ prlist_with_sep pr_spc pr_id ids)
-      
+
   | Move (withdep,id1,id2) ->
       (str (if withdep then "dependent " else "") ++
 	 str"move "  ++ pr_id id1 ++ pr_move_location pr_id id2)
@@ -497,7 +501,7 @@ let prterm = pr_lconstr
 
 (* spiwack: printer function for sets of Environ.assumption.
             It is used primarily by the Print Assumption command. *)
-let pr_assumptionset env s = 
+let pr_assumptionset env s =
   if (Environ.ContextObjectMap.is_empty s) then
     str "Closed under the global context"
   else
@@ -506,7 +510,7 @@ let pr_assumptionset env s =
 	let (v,a,o) = r in
 	match t with
 	| Variable id -> (  Some (
-	                      Option.default (fnl ()) v 
+	                      Option.default (fnl ()) v
 			   ++ str (string_of_id id)
 			   ++ str " : "
 	                   ++ pr_ltype typ
@@ -536,7 +540,7 @@ let pr_assumptionset env s =
       )
 	s (None,None,None)
     in
-    let (vars,axioms,opaque) = 
+    let (vars,axioms,opaque) =
       ( Option.map (fun p -> str "Section Variables:" ++ p) vars ,
 	Option.map (fun p -> str "Axioms:" ++ p) axioms ,
 	Option.map (fun p -> str "Opaque constants:" ++ p) opaque
@@ -550,7 +554,7 @@ let cmap_to_list m = Cmap.fold (fun k v acc -> v :: acc) m []
 open Typeclasses
 
 let pr_instance i = 
-  pr_global (ConstRef (instance_impl i))
+  pr_global (instance_impl i)
     
 let pr_instance_gmap insts =
   prlist_with_sep fnl (fun (gr, insts) ->
diff --git a/parsing/printer.mli b/parsing/printer.mli
index 40bb9122..bfb7dfe1 100644
--- a/parsing/printer.mli
+++ b/parsing/printer.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: printer.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -42,6 +42,12 @@ val pr_open_constr         : open_constr -> std_ppcmds
 val pr_open_lconstr_env    : env -> open_constr -> std_ppcmds
 val pr_open_lconstr        : open_constr -> std_ppcmds
 
+val pr_constr_under_binders_env  : env -> constr_under_binders -> std_ppcmds
+val pr_constr_under_binders      : constr_under_binders -> std_ppcmds
+
+val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds
+val pr_lconstr_under_binders     : constr_under_binders -> std_ppcmds
+
 val pr_ltype_env_at_top    : env -> types -> std_ppcmds
 val pr_ltype_env           : env -> types -> std_ppcmds
 val pr_ltype               : types -> std_ppcmds
@@ -112,8 +118,8 @@ val pr_evars_int           : int -> (evar * evar_info) list -> std_ppcmds
 val pr_prim_rule           : prim_rule -> std_ppcmds
 
 (* Emacs/proof general support *)
-(* (emacs_str s alts) outputs 
-   - s if emacs mode & unicode allowed, 
+(* (emacs_str s alts) outputs
+   - s if emacs mode & unicode allowed,
    - alts if emacs mode and & unicode not allowed
    - nothing otherwise *)
 val emacs_str              : string -> string -> string
diff --git a/parsing/printmod.ml b/parsing/printmod.ml
index 596ce6b2..eb6e88c9 100644
--- a/parsing/printmod.ml
+++ b/parsing/printmod.ml
@@ -13,13 +13,13 @@ open Declarations
 open Nameops
 open Libnames
 
-let get_new_id locals id = 
-  let rec get_id l id = 
+let get_new_id locals id =
+  let rec get_id l id =
     let dir = make_dirpath [id] in
       if not (Nametab.exists_module dir) then
 	id
       else
-	get_id (id::l) (Nameops.next_ident_away id l)
+	get_id (id::l) (Namegen.next_ident_away id l)
   in
     get_id (List.map snd locals) id
 
@@ -27,21 +27,21 @@ let rec print_local_modpath locals = function
   | MPbound mbid -> pr_id (List.assoc mbid locals)
   | MPdot(mp,l) ->
       print_local_modpath locals mp ++ str "." ++ pr_lab l
-  | MPself _ | MPfile _ -> raise Not_found
+  | MPfile _ -> raise Not_found
 
-let print_modpath locals mp = 
+let print_modpath locals mp =
   try (* must be with let because streams are lazy! *)
-    let qid = Nametab.shortest_qualid_of_module mp in 
+    let qid = Nametab.shortest_qualid_of_module mp in
       pr_qualid qid
   with
     | Not_found -> print_local_modpath locals mp
 
-let print_kn locals kn = 
+let print_kn locals kn =
   try
-    let qid = Nametab.shortest_qualid_of_modtype kn in 
+    let qid = Nametab.shortest_qualid_of_modtype kn in
       pr_qualid qid
   with
-      Not_found -> 
+      Not_found ->
 	try
 	  print_local_modpath locals kn
 	with
@@ -52,108 +52,107 @@ let rec flatten_app mexpr l = match mexpr with
   | mexpr -> mexpr::l
 
 let rec print_module name locals with_body mb =
-  let body = match with_body, mb.mod_expr with 
-    | false, _ 
+  let body = match with_body, mb.mod_expr with
+    | false, _
     | true, None -> mt()
-    | true, Some mexpr -> 
+    | true, Some mexpr ->
 	spc () ++ str ":= " ++ print_modexpr locals mexpr
   in
-  let modtype = match mb.mod_type with
-      None -> str ""
-    | Some t -> spc () ++ str": " ++ 
+
+  let modtype = 
+    match mb.mod_type with
+    | t -> spc () ++ str": " ++ 
 	print_modtype locals t
   in
     hv 2 (str "Module " ++ name ++ modtype ++ body)
 
-and print_modtype locals mty = 
+and print_modtype locals mty =
   match mty with
     | SEBident kn -> print_kn locals kn
     | SEBfunctor (mbid,mtb1,mtb2) ->
-      (*    let env' = Modops.add_module (MPbid mbid) 
-	    (Modops.body_of_type mtb) env 
-	    in *) 
+      (*    let env' = Modops.add_module (MPbid mbid)
+	    (Modops.body_of_type mtb) env
+	    in *)
       let locals' = (mbid, get_new_id locals (id_of_mbid mbid))
 	::locals in
-	hov 2 (str "Funsig" ++ spc () ++ str "(" ++ 
-		 pr_id (id_of_mbid mbid) ++ str " : " ++ 
-		 print_modtype locals mtb1.typ_expr ++ 
+	hov 2 (str "Funsig" ++ spc () ++ str "(" ++
+		 pr_id (id_of_mbid mbid) ++ str " : " ++
+		 print_modtype locals mtb1.typ_expr ++
 		 str ")" ++ spc() ++ print_modtype locals' mtb2)
-  | SEBstruct (msid,sign) -> 
-      hv 2 (str "Sig" ++ spc () ++ print_sig locals msid sign ++ brk (1,-2) ++ str "End")
-  | SEBapply (mexpr,marg,_) -> 
+  | SEBstruct (sign) -> 
+      hv 2 (str "Sig" ++ spc () ++ print_sig locals  sign ++ brk (1,-2) ++ str "End")
+  | SEBapply (mexpr,marg,_) ->
       let lapp = flatten_app mexpr [marg] in
       let fapp = List.hd lapp in
       let mapp = List.tl lapp in
-	hov 3 (str"(" ++ (print_modtype locals fapp) ++ spc () ++ 
+	hov 3 (str"(" ++ (print_modtype locals fapp) ++ spc () ++
 		 prlist_with_sep spc (print_modexpr locals) mapp ++ str")")
   | SEBwith(seb,With_definition_body(idl,cb))->
       let s = (String.concat "." (List.map string_of_id idl)) in
-      hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ 
+      hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++
 	       str "Definition"++ spc() ++ str s ++ spc() ++  str ":="++ spc())
-  | SEBwith(seb,With_module_body(idl,mp,_,_))->
+  | SEBwith(seb,With_module_body(idl,mp))->
       let s =(String.concat "." (List.map string_of_id idl)) in
-      hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ 
+      hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++
 	       str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc())
 
-and print_sig locals msid sign = 
+and print_sig locals sign = 
   let print_spec (l,spec) = (match spec with
     | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition "
     | SFBconst {const_body=None}
     | SFBconst {const_opaque=true} -> str "Parameter "
     | SFBmind _ -> str "Inductive "
     | SFBmodule _ -> str "Module "
-    | SFBalias (mp,_,_) -> str "Module "
     | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
   in
     prlist_with_sep spc print_spec sign
 
-and print_struct locals msid struc = 
+and print_struct locals struc = 
   let print_body (l,body) = (match body with
     | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition "
     | SFBconst {const_body=Some _; const_opaque=true} -> str "Theorem "
     | SFBconst {const_body=None} -> str "Parameter "
     | SFBmind _ -> str "Inductive "
     | SFBmodule _ -> str "Module "
-    | SFBalias (mp,_,_) -> str "Module "
     | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
   in
     prlist_with_sep spc print_body struc
 
-and print_modexpr locals mexpr = match mexpr with 
+and print_modexpr locals mexpr = match mexpr with
   | SEBident mp -> print_modpath locals mp
   | SEBfunctor (mbid,mty,mexpr) ->
-(*    let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env 
+(*    let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env
       in *)
       let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
-      hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ 
-	     str ":" ++ print_modtype locals mty.typ_expr ++ 
+      hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++
+	     str ":" ++ print_modtype locals mty.typ_expr ++
       str ")" ++ spc () ++ print_modexpr locals' mexpr)
-  | SEBstruct (msid, struc) -> 
-      hv 2 (str "Struct" ++ spc () ++ print_struct locals msid struc ++ brk (1,-2) ++ str "End")
-  | SEBapply (mexpr,marg,_) -> 
+  | SEBstruct ( struc) -> 
+      hv 2 (str "Struct" ++ spc () ++ print_struct locals struc ++ brk (1,-2) ++ str "End")
+  | SEBapply (mexpr,marg,_) ->
       let lapp = flatten_app mexpr [marg] in
 	hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")")
   | SEBwith (_,_)-> anomaly "Not avaible yet"
 
 
-let rec printable_body dir =     
-  let dir = dirpath_prefix dir in
-    dir = empty_dirpath || 
-    try 
+let rec printable_body dir =
+  let dir = pop_dirpath dir in
+    dir = empty_dirpath ||
+    try
       match Nametab.locate_dir (qualid_of_dirpath dir) with
 	  DirOpenModtype _ -> false
 	| DirModule _ | DirOpenModule _ -> printable_body dir
 	| _ -> true
-    with 
+    with
 	Not_found -> true
 
 
-let print_module with_body mp = 
+let print_module with_body mp =
   let name = print_modpath [] mp in
     print_module name [] with_body (Global.lookup_module mp) ++ fnl ()
 
-let print_modtype kn = 
+let print_modtype kn =
   let mtb = Global.lookup_modtype kn in
   let name = print_kn [] kn in
-      str "Module Type " ++ name ++ str " = " ++ 
+      str "Module Type " ++ name ++ str " = " ++
 	print_modtype [] mtb.typ_expr ++ fnl ()
diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4
index 37817389..093910b4 100644
--- a/parsing/q_constr.ml4
+++ b/parsing/q_constr.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
 
-(* $Id: q_constr.ml4 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 open Rawterm
 open Term
@@ -21,8 +21,8 @@ open Pcaml
 let loc = dummy_loc
 let dloc = <:expr< Util.dummy_loc >>
 
-let apply_ref f l = 
-  <:expr< 
+let apply_ref f l =
+  <:expr<
     Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$)
   >>
 
@@ -57,13 +57,13 @@ EXTEND
       (* fix todo *)
       ]
     | "100" RIGHTA
-      [ c1 = constr; ":"; c2 = SELF -> 
+      [ c1 = constr; ":"; c2 = SELF ->
         <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
     | "90" RIGHTA
-      [ c1 = constr; "->"; c2 = SELF -> 
+      [ c1 = constr; "->"; c2 = SELF ->
         <:expr< Rawterm.RProd ($dloc$,Anonymous,Rawterm.Explicit,$c1$,$c2$) >> ]
     | "75" RIGHTA
-      [ "~"; c = constr -> 
+      [ "~"; c = constr ->
         apply_ref <:expr< coq_not_ref >> [c] ]
     | "70" RIGHTA
       [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT ->
@@ -85,26 +85,26 @@ EXTEND
   ;
   match_constr:
     [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type;
-        "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> 
+        "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" ->
           let br = mlexpr_of_list (fun x -> x) br in
-     <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> 
+     <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >>
     ] ]
   ;
   match_type:
-    [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name;  
-        "return"; ty = constr LEVEL "100" -> 
+    [ [ "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< Some $ty$ >>,
+          <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >>
       | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ]
   ;
   eqn:
-    [ [ (lid,pl) = pattern; "=>"; rhs = constr -> 
+    [ [ (lid,pl) = pattern; "=>"; rhs = constr ->
         let lid = mlexpr_of_list (fun x -> x) lid in
-        <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> 
+        <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >>
     ] ]
   ;
-  pattern: 
+  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
@@ -113,13 +113,13 @@ EXTEND
       | "("; p = pattern; ")" -> p ] ]
   ;
   patvar:
-    [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> 
-      | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> 
+    [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >>
+      | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >>
     ] ]
   ;
   END;;
 
-(* Example 
+(* Example
 open Coqlib
 let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ]
 *)
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
index aeee632c..1bd5af53 100644
--- a/parsing/q_coqast.ml4
+++ b/parsing/q_coqast.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4use: "q_MLast.cmo pa_macro.cmo" i*)
 
-(* $Id: q_coqast.ml4 11735 2009-01-02 17:22:31Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -28,11 +28,11 @@ IFDEF CAMLP5 THEN DEFINE NOP END
 let anti loc x =
   let e =
     let loc =
-      IFDEF NOP THEN 
+      IFDEF NOP THEN
         loc
-      ELSE 
+      ELSE
 	(1, snd loc - fst loc)
-      END 
+      END
     in <:expr< $lid:purge_str x$ >>
   in
   <:expr< $anti:e$ >>
@@ -47,7 +47,7 @@ let mlexpr_of_ident id =
 
 let mlexpr_of_name = function
   | Names.Anonymous -> <:expr< Names.Anonymous >>
-  | Names.Name id -> 
+  | Names.Name id ->
       <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >>
 
 let mlexpr_of_dirpath dir =
@@ -68,13 +68,14 @@ let mlexpr_of_loc loc = <:expr< $dloc$ >>
 
 let mlexpr_of_by_notation f = function
   | Genarg.AN x -> <:expr< Genarg.AN $f x$ >>
-  | Genarg.ByNotation (loc,s,sco) -> 
+  | Genarg.ByNotation (loc,s,sco) ->
       <:expr< Genarg.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >>
 
 let mlexpr_of_intro_pattern = function
   | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >>
   | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >>
   | Genarg.IntroFresh id -> <:expr< Genarg.IntroFresh (mlexpr_of_ident $dloc$ id) >>
+  | Genarg.IntroForthcoming b -> <:expr< Genarg.IntroForthcoming (mlexpr_of_bool $dloc$ b) >>
   | Genarg.IntroIdentifier id ->
       <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
   | Genarg.IntroOrAndPattern _ | Genarg.IntroRewrite _ ->
@@ -133,14 +134,14 @@ let mlexpr_of_red_flags {
 let mlexpr_of_explicitation = function
   | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >>
   | Topconstr.ExplByPos (n,_id) -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >>
- 
+
 let mlexpr_of_binding_kind = function
   | Rawterm.Implicit -> <:expr< Rawterm.Implicit >>
   | Rawterm.Explicit -> <:expr< Rawterm.Explicit >>
 
 let mlexpr_of_binder_kind = function
   | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >>
-  | Topconstr.Generalized (b,b',b'') -> 
+  | Topconstr.Generalized (b,b',b'') ->
       <:expr< Topconstr.TypeClass $mlexpr_of_binding_kind b$
 	$mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >>
 
@@ -152,7 +153,7 @@ let rec mlexpr_of_constr = function
   | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
   | Topconstr.CArrow (loc,a,b) ->
   <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >>
-  | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list 
+  | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list
       (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
   | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
   | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
@@ -163,10 +164,10 @@ let rec mlexpr_of_constr = function
   | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)"
   | Topconstr.CNotation(_,ntn,subst) ->
       <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$
-              $mlexpr_of_pair 
+              $mlexpr_of_pair
                 (mlexpr_of_list mlexpr_of_constr)
                 (mlexpr_of_list (mlexpr_of_list mlexpr_of_constr)) subst$ >>
-  | Topconstr.CPatVar (loc,n) -> 
+  | Topconstr.CPatVar (loc,n) ->
       <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >>
   | _ -> failwith "mlexpr_of_constr: TODO"
 
@@ -215,7 +216,7 @@ let rec mlexpr_of_argtype loc = function
   | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >>
   | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >>
   | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >>
-  | Genarg.PairArgType (t1,t2) -> 
+  | 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$ >>
@@ -236,10 +237,10 @@ let mlexpr_of_binding_kind = function
   | Rawterm.ExplicitBindings l ->
       let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in
       <:expr< Rawterm.ExplicitBindings $l$ >>
-  | Rawterm.ImplicitBindings l -> 
+  | Rawterm.ImplicitBindings l ->
       let l = mlexpr_of_list mlexpr_of_constr l in
       <:expr< Rawterm.ImplicitBindings $l$ >>
-  | Rawterm.NoBindings -> 
+  | Rawterm.NoBindings ->
        <:expr< Rawterm.NoBindings >>
 
 let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr
@@ -255,7 +256,7 @@ let mlexpr_of_move_location f = function
 let mlexpr_of_induction_arg = function
   | Tacexpr.ElimOnConstr c ->
       <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >>
-  | Tacexpr.ElimOnIdent (_,id) -> 
+  | Tacexpr.ElimOnIdent (_,id) ->
       <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >>
   | Tacexpr.ElimOnAnonHyp n ->
       <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >>
@@ -346,11 +347,11 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >>
   | Tacexpr.TacAssert (t,ipat,c) ->
       let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in
-      <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ 
+      <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$
 	      $mlexpr_of_constr c$ >>
   | Tacexpr.TacGeneralize cl ->
       <:expr< Tacexpr.TacGeneralize
-	      $mlexpr_of_list 
+	      $mlexpr_of_list
                 (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >>
   | Tacexpr.TacGeneralizeDep c ->
       <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >>
@@ -365,14 +366,14 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacSimpleInductionDestruct $mlexpr_of_bool isrec$
                   $mlexpr_of_quantified_hypothesis h$ >>
   | Tacexpr.TacInductionDestruct (isrec,ev,l) ->
-      <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ 
-	$mlexpr_of_list (mlexpr_of_quadruple 
+      <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$
+	$mlexpr_of_pair (mlexpr_of_list (mlexpr_of_triple
 	  (mlexpr_of_list mlexpr_of_induction_arg)
 	  (mlexpr_of_option mlexpr_of_constr_with_binding)
 	  (mlexpr_of_pair
 	    (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))
-	    (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)))
-	  (mlexpr_of_option mlexpr_of_clause)) l$ >>
+	    (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)))))
+	  (mlexpr_of_option mlexpr_of_clause) l$ >>
 
   (* Context management *)
   | Tacexpr.TacClear (b,l) ->
@@ -393,7 +394,7 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacRight $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>>
   | Tacexpr.TacSplit (ev,b,l) ->
       <:expr< Tacexpr.TacSplit
-        ($mlexpr_of_bool ev$,$mlexpr_of_bool b$,$mlexpr_of_binding_kind l$)>>
+        ($mlexpr_of_bool ev$,$mlexpr_of_bool b$,$mlexpr_of_list mlexpr_of_binding_kind l$)>>
   | Tacexpr.TacAnyConstructor (ev,t) ->
       <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_bool ev$ $mlexpr_of_option mlexpr_of_tactic t$>>
   | Tacexpr.TacConstructor (ev,n,l) ->
@@ -404,15 +405,15 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacReduce (r,cl) ->
       let l = mlexpr_of_clause cl in
       <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >>
-  | Tacexpr.TacChange (occl,c,cl) ->
+  | Tacexpr.TacChange (p,c,cl) ->
       let l = mlexpr_of_clause cl in
-      let g = mlexpr_of_option mlexpr_of_occ_constr in
-      <:expr< Tacexpr.TacChange $g occl$ $mlexpr_of_constr c$ $l$ >>
+      let g = mlexpr_of_option mlexpr_of_constr in
+      <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >>
 
   (* Equivalence relations *)
   | Tacexpr.TacReflexivity -> <:expr< Tacexpr.TacReflexivity >>
   | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >>
-  | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_constr c$ >>
+  | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >>
 
   (* Automation tactics *)
   | Tacexpr.TacAuto (n,lems,l) ->
@@ -436,7 +437,7 @@ let rec mlexpr_of_atomic_tactic = function
 and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
   | Tacexpr.TacAtom (loc,t) ->
       <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >>
-  | Tacexpr.TacThen (t1,[||],t2,[||]) -> 
+  | Tacexpr.TacThen (t1,[||],t2,[||]) ->
       <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ [||] $mlexpr_of_tactic t2$ [||]>>
   | Tacexpr.TacThens (t,tl) ->
       <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>>
@@ -454,7 +455,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >>
   | Tacexpr.TacProgress t ->
       <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >>
-  | Tacexpr.TacId l -> 
+  | Tacexpr.TacId l ->
       <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >>
   | Tacexpr.TacFail (n,l) ->
       <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >>
@@ -476,7 +477,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
         $mlexpr_of_tactic t$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
   | Tacexpr.TacMatchGoal (lz,lr,l) ->
-      <:expr< Tacexpr.TacMatchGoal 
+      <:expr< Tacexpr.TacMatchGoal
         $mlexpr_of_bool lz$
         $mlexpr_of_bool lr$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
@@ -494,7 +495,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
 
 and mlexpr_of_tactic_arg = function
   | Tacexpr.MetaIdArg (loc,true,id) -> anti loc id
-  | Tacexpr.MetaIdArg (loc,false,id) -> 
+  | Tacexpr.MetaIdArg (loc,false,id) ->
       <:expr< Tacexpr.ConstrMayEval (Rawterm.ConstrTerm $anti loc id$) >>
   | Tacexpr.TacCall (loc,t,tl) ->
       <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>>
@@ -522,7 +523,7 @@ let ftac e =
   let ep s = patt_of_expr (ee s) in
   Quotation.ExAst (ee, ep)
 
-let _ = 
+let _ =
   Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi);
   Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi);
   Quotation.default := "constr"
diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4
index da4329bb..7b9037d9 100644
--- a/parsing/q_util.ml4
+++ b/parsing/q_util.ml4
@@ -8,17 +8,19 @@
 
 (*i camlp4use: "q_MLast.cmo" i*)
 
-(* $Id: q_util.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 (* This file defines standard combinators to build ml expressions *)
 
 open Util
+open Extrawit
+open Pcoq
 
 let not_impl name x =
   let desc =
     if Obj.is_block (Obj.repr x) then
       "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
-    else 
+    else
       "int_val = " ^ string_of_int (Obj.magic x)
   in
   failwith ("<Q_util." ^ name ^ ", not impl: " ^ desc)
@@ -78,64 +80,16 @@ open Vernacexpr
 open Pcoq
 open Genarg
 
-let modifiers e =
-<:expr<  Gramext.srules
-    [([], Gramext.action(fun _loc -> []));
-     ([Gramext.Stoken ("", "(");
-       Gramext.Slist1sep ($e$, Gramext.Stoken ("", ","));
-       Gramext.Stoken ("", ")")],
-      Gramext.action (fun _ l _ _loc -> l))]
- >>
-
-let rec interp_entry_name loc s sep =
-  let l = String.length s in
-  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) "" in
-    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
-  else if l > 12 & String.sub s 0 3 = "ne_" &
-                   String.sub s (l-9) 9 = "_list_sep" then
-    let t, g = interp_entry_name loc (String.sub s 3 (l-12)) "" in
-    let sep = <:expr< Gramext.Stoken("",$str:sep$) >> in
-    List1ArgType t, <:expr< Gramext.Slist1sep $g$ $sep$ >>
-  else if l > 5 & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) "" in
-    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
-  else if l > 9 & String.sub s (l-9) 9 = "_list_sep" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-9)) "" in
-    let sep = <:expr< Gramext.Stoken("",$str:sep$) >> in
-    List0ArgType t, <:expr< Gramext.Slist0sep $g$ $sep$ >>
-  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) "" in
-    OptArgType t, <:expr< Gramext.Sopt $g$ >>
-  else if l > 5 & String.sub s (l-5) 5 = "_mods" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-1)) "" in
-    List0ArgType t, modifiers g
-  else
-    let s = if s = "hyp" then "var" else s in
-    let t, se, lev =
-      match tactic_genarg_level s with
-        | Some 5 ->
-            Some (ExtraArgType s), <:expr< Tactic. binder_tactic >>, None
-	| Some n ->
-            Some (ExtraArgType s), <:expr< Tactic. tactic_expr >>, Some n
-	| None ->
-      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
-	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>, None
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
-	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>, None
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
-	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>, None
-	| None -> None, <:expr< $lid:s$ >>, None in
-    let t =
-      match t with
-	| Some t -> t
-	| None -> ExtraArgType s in
-    let entry = match lev with
-      | Some n ->
-	  let s = string_of_int n in
-	  <:expr< Gramext.Snterml (Pcoq.Gram.Entry.obj $se$, $str:s$) >>
-      | None -> 
-	  <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
-    in t, entry
+let rec mlexpr_of_prod_entry_key = function
+  | Extend.Alist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key s$ >>
+  | Extend.Alist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
+  | Extend.Alist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key s$ >>
+  | Extend.Alist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
+  | Extend.Aopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key s$ >>
+  | Extend.Amodifiers s -> <:expr< Extend.Amodifiers $mlexpr_of_prod_entry_key s$ >>
+  | Extend.Aself -> <:expr< Extend.Aself >>
+  | Extend.Anext -> <:expr< Extend.Anext >>
+  | Extend.Atactic n -> <:expr< Extend.Atactic $mlexpr_of_int n$ >>
+  | Extend.Agram s -> anomaly "Agram not supported"
+  | Extend.Aentry ("",s) -> <:expr< Extend.Agram (Gram.Entry.obj $lid:s$) >>
+  | Extend.Aentry (u,s) -> <:expr< Extend.Aentry $str:u$ $str:s$ >>
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
index b950e68f..7c0fec9a 100644
--- a/parsing/q_util.mli
+++ b/parsing/q_util.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: q_util.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 val patt_of_expr : MLast.expr -> MLast.patt
 
@@ -32,5 +32,4 @@ val mlexpr_of_string : string -> MLast.expr
 
 val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
 
-val interp_entry_name : Util.loc -> string -> string -> 
-  Pcoq.entry_type * MLast.expr
+val mlexpr_of_prod_entry_key : Pcoq.Gram.te Extend.prod_entry_key -> MLast.expr
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
index 695677a3..517e34aa 100644
--- a/parsing/tacextend.ml4
+++ b/parsing/tacextend.ml4
@@ -8,30 +8,28 @@
 
 (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
 
-(* $Id: tacextend.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Genarg
 open Q_util
 open Q_coqast
 open Argextend
-
-let loc = Util.dummy_loc
-let default_loc = <:expr< Util.dummy_loc >>
-
-type grammar_tactic_production_expr =
-  | TacTerm of string
-  | TacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option
+open Pcoq
+open Extrawit
+open Egrammar
 
 let rec make_patt = function
   | [] -> <:patt< [] >>
-  | TacNonTerm(loc',_,_,Some p)::l ->
+  | GramNonTerminal(loc',_,_,Some p)::l ->
+      let p = Names.string_of_id p in
       <:patt< [ $lid:p$ :: $make_patt l$ ] >>
   | _::l -> make_patt l
 
 let rec make_when loc = function
   | [] -> <:expr< True >>
-  | TacNonTerm(loc',t,_,Some p)::l ->
+  | GramNonTerminal(loc',t,_,Some p)::l ->
+      let p = Names.string_of_id p in
       let l = make_when loc l in
       let loc = join_loc loc' loc in
       let t = mlexpr_of_argtype loc' t in
@@ -40,14 +38,15 @@ let rec make_when loc = function
 
 let rec make_let e = function
   | [] -> e
-  | TacNonTerm(loc,t,_,Some p)::l ->
+  | GramNonTerminal(loc,t,_,Some p)::l ->
+      let p = Names.string_of_id p in
       let loc = join_loc loc (MLast.loc_of_expr e) in
       let e = make_let e l in
       let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in
-      let v = 
+      let v =
         (* Special case for tactics which must be stored in algebraic
            form to avoid marshalling closures and to be reprinted *)
-        if Pcoq.is_tactic_genarg t then
+        if is_tactic_genarg t then
           <:expr< ($v$, Tacinterp.eval_tactic $v$) >>
         else v in
       <:expr< let $lid:p$ = $v$ in $e$ >>
@@ -60,7 +59,7 @@ let add_clause s (pt,e) l =
 
 let rec extract_signature = function
   | [] -> []
-  | TacNonTerm (_,t,_,_) :: l -> t :: extract_signature l
+  | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
   | _::l -> extract_signature l
 
 let check_unicity s l =
@@ -78,13 +77,15 @@ let make_clauses s l =
 
 let rec make_args = function
   | [] -> <:expr< [] >>
-  | TacNonTerm(loc,t,_,Some p)::l ->
+  | GramNonTerminal(loc,t,_,Some p)::l ->
+      let p = Names.string_of_id p in
       <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >>
   | _::l -> make_args l
 
 let rec make_eval_tactic e = function
   | [] -> e
-  | TacNonTerm(loc,tag,_,Some p)::l when Pcoq.is_tactic_genarg tag ->
+  | GramNonTerminal(loc,tag,_,Some p)::l when is_tactic_genarg tag ->
+      let p = Names.string_of_id p in
       let loc = join_loc loc (MLast.loc_of_expr e) in
       let e = make_eval_tactic e l in
         (* Special case for tactics which must be stored in algebraic
@@ -94,26 +95,27 @@ let rec make_eval_tactic e = function
 
 let rec make_fun e = function
   | [] -> e
-  | TacNonTerm(loc,_,_,Some p)::l -> 
+  | GramNonTerminal(loc,_,_,Some p)::l ->
+      let p = Names.string_of_id p in
       <:expr< fun $lid:p$ -> $make_fun e l$ >>
   | _::l -> make_fun e l
 
-let mlexpr_of_grammar_production = function
-  | TacTerm s ->
-      <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >>
-  | TacNonTerm (loc,nt,g,sopt) ->
-      <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >>
+let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function
+  | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >>
+  | GramNonTerminal (loc,nt,_,sopt) -> <:expr< None >>
 
-let mlexpr_terminals_of_grammar_production = function
-  | TacTerm s -> <:expr< Some $mlexpr_of_string s$ >>
-  | TacNonTerm (loc,nt,g,sopt) -> <:expr< None >>
+let make_prod_item = function
+  | GramTerminal s -> <:expr< Egrammar.GramTerminal $str:s$ >>
+  | GramNonTerminal (loc,nt,g,sopt) ->
+      <:expr< Egrammar.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$
+      $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >>
 
 let mlexpr_of_clause =
-  mlexpr_of_list (fun (a,b) -> mlexpr_of_list mlexpr_of_grammar_production a)
+  mlexpr_of_list (fun (a,b) -> mlexpr_of_list make_prod_item a)
 
 let rec make_tags loc = function
   | [] -> <:expr< [] >>
-  | TacNonTerm(loc',t,_,Some p)::l ->
+  | GramNonTerminal(loc',t,_,Some p)::l ->
       let l = make_tags loc l in
       let loc = join_loc loc' loc in
       let t = mlexpr_of_argtype loc' t in
@@ -123,7 +125,7 @@ let rec make_tags loc = function
 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_production pt in
+  let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in
   <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >>
 
 let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
@@ -136,10 +138,10 @@ let rec contains_epsilon = function
   | ExtraArgType("hintbases") -> true
   | _ -> false
 let is_atomic = function
-  | TacTerm s :: l when 
+  | GramTerminal s :: l when
       List.for_all (function
-          TacTerm _ -> false
-	| TacNonTerm(_,t,_,_) -> contains_epsilon t) l
+          GramTerminal _ -> false
+	| GramNonTerminal(_,t,_,_) -> contains_epsilon t) l
 	-> [s]
   | _ -> []
 
@@ -150,7 +152,7 @@ let declare_tactic loc s cl =
   let hide_tac (p,e) =
     (* reste a definir les fonctions cachees avec des noms frais *)
     let stac = "h_"^s in
-    let e = 
+    let e =
       make_fun
         <:expr<
           Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$
@@ -165,6 +167,7 @@ let declare_tactic loc s cl =
   <:str_item<
     declare
       open Pcoq;
+      open Extrawit;
       declare $list:hidden$ end;
       try
         let _=Tacinterp.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in
@@ -191,8 +194,8 @@ EXTEND
   ;
   tacrule:
     [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]"
-        -> 
-	  if match List.hd l with TacNonTerm _ -> true | _ -> false then
+        ->
+	  if match List.hd l with GramNonTerminal _ -> true | _ -> false then
 	    (* En attendant la syntaxe de tacticielles *)
 	    failwith "Tactic syntax must start with an identifier";
 	  (l,e)
@@ -200,14 +203,14 @@ EXTEND
   ;
   tacargs:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = Q_util.interp_entry_name loc e "" in
-        TacNonTerm (loc, t, g, Some s)
+        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 = Q_util.interp_entry_name loc e sep in
-        TacNonTerm (loc, t, g, Some s)
+        let t, g = interp_entry_name false None e sep in
+        GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
       | s = STRING ->
 	if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal.");
-        TacTerm s
+        GramTerminal s
     ] ]
   ;
   END
diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml
index e0836984..c09b3431 100644
--- a/parsing/tactic_printer.ml
+++ b/parsing/tactic_printer.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactic_printer.ml 11313 2008-08-07 11:15:03Z barras $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -23,30 +23,30 @@ let pr_tactic = function
   | TacArg (Tacexp t) ->
       (*top tactic from tacinterp*)
       Pptactic.pr_glob_tactic (Global.env()) t
-  | t -> 
+  | t ->
       Pptactic.pr_tactic (Global.env()) t
 
-let pr_proof_instr instr = 
+let pr_proof_instr instr =
     Ppdecl_proof.pr_proof_instr (Global.env()) instr
 
 let pr_rule = function
   | Prim r -> hov 0 (pr_prim_rule r)
   | Nested(cmpd,_) ->
       begin
-	match cmpd with 
+	match cmpd with
 	  | Tactic (texp,_) -> hov 0 (pr_tactic texp)
 	  | Proof_instr (_,instr) -> hov 0 (pr_proof_instr instr)
       end
   | Daimon -> str "<Daimon>"
-  | Decl_proof _ -> str "proof" 
+  | Decl_proof _ -> str "proof"
 
 let uses_default_tac = function
   | Nested(Tactic(_,dflt),_) -> dflt
   | _ -> false
 
 (* Does not print change of evars *)
-let pr_rule_dot = function 
-  | Prim Change_evars ->str "PC: ch_evars" ++  mt () 
+let pr_rule_dot = function
+  | Prim Change_evars ->str "PC: ch_evars" ++  mt ()
       (* PC: this might be redundant *)
   | r ->
       pr_rule r ++ if uses_default_tac r then str "..." else str"."
@@ -66,27 +66,27 @@ exception Different
 let thin_sign osign sign =
   Sign.fold_named_context
     (fun (id,c,ty as d) sign ->
-       try 
+       try
 	 if Sign.lookup_named id osign = (id,c,ty) then sign
 	 else raise Different
        with Not_found | Different -> Environ.push_named_context_val d sign)
     sign ~init:Environ.empty_named_context_val
 
-let rec print_proof sigma osign pf =
+let rec print_proof _sigma osign pf =
   let hyps = Environ.named_context_of_val pf.goal.evar_hyps in
   let hyps' = thin_sign osign hyps in
   match pf.ref with
-    | None -> 
+    | None ->
 	hov 0 (pr_goal {pf.goal with evar_hyps=hyps'})
     | Some(r,spfl) ->
-    	hov 0 
+    	hov 0
 	  (hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) ++
 	   spc () ++ str" BY " ++
 	   hov 0 (pr_rule r) ++ fnl () ++
 	   str"  " ++
-	   hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl))
-	  
-let pr_change gl = 
+	   hov 0 (prlist_with_sep pr_fnl (print_proof _sigma hyps) spfl))
+
+let pr_change gl =
   str"change " ++
   pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"."
 
@@ -94,9 +94,9 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf =
   let rec print_prf pf =
   match pf.ref with
     | None ->
-	(if nochange then 
+	(if nochange then
 	   (str"<Your Proof Text here>")
-	 else 
+	 else
 	   pr_change pf.goal)
 	++ fnl ()
     | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)"
@@ -114,17 +114,17 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf =
 	      (if opened then mt () else str "end claim." ++ fnl ()) ++
 	      print_prf cont
 	  | Pfocus _,[body;cont] ->
-	      hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ 
+	      hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++
 	      fnl () ++
 	      (if opened then mt () else str "end focus." ++ fnl ()) ++
 	      print_prf cont
 	  | (Psuppose _ |Pcase (_,_,_)),[body;cont] ->
 	      hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++
-	      print_prf cont 
+	      print_prf cont
 	  | _,[next] ->
 	      pr_rule_dot_fnl rule ++ print_prf next
 	  | _,[] ->
-	      pr_rule_dot rule		
+	      pr_rule_dot rule
 	  | _,_ -> anomaly "unknown branching instruction"
 	end
     | _ -> anomaly "Not Applicable" in
@@ -134,19 +134,19 @@ let print_script ?(nochange=true) sigma pf =
   let rec print_prf pf =
   match pf.ref with
     | None ->
-        (if nochange then 
-	   (str"<Your Tactic Text here>") 
-	 else 
+        (if nochange then
+	   (str"<Your Tactic Text here>")
+	 else
 	   pr_change pf.goal)
 	++ fnl ()
     | Some(Decl_proof opened,script) ->
 	assert (List.length script = 1);
 	begin
-	  if nochange then (mt ()) else (pr_change pf.goal ++ fnl ()) 
+	  if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())
 	end ++
 	  begin
-	    hov 0 (str "proof." ++ fnl () ++ 
-		     print_decl_script print_prf 
+	    hov 0 (str "proof." ++ fnl () ++
+		     print_decl_script print_prf
 		     ~nochange sigma (List.hd script))
 	  end ++ fnl () ++
 	  begin
@@ -167,7 +167,7 @@ let print_treescript ?(nochange=true) sigma pf =
   let rec print_prf pf =
     match pf.ref with
     | None ->
-        if nochange then 
+        if nochange then
 	  if pf.goal.evar_extra=None then str"<Your Tactic Text here>"
 	  else str"<Your Proof Text here>"
 	else pr_change pf.goal
@@ -176,10 +176,10 @@ let print_treescript ?(nochange=true) sigma pf =
 	begin
 	  if nochange then mt () else pr_change pf.goal ++ fnl ()
 	end ++
-	hov 0 
+	hov 0
 	  begin str "proof." ++ fnl () ++
-	    print_decl_script print_prf ~nochange sigma (List.hd script) 
-	  end ++ fnl () ++ 
+	    print_decl_script print_prf ~nochange sigma (List.hd script)
+	  end ++ fnl () ++
 	begin
 	  if opened then mt () else (str "end proof." ++ fnl ())
 	end
@@ -197,28 +197,29 @@ let rec print_info_script sigma osign pf =
   match pf.ref with
     | None -> (mt ())
     | Some(r,spfl) ->
-        (pr_rule r ++ 
+        (pr_rule r ++
            match spfl with
              | [pf1] ->
-                 if pf1.ref = None then 
+                 if pf1.ref = None then
 		   (str "." ++ fnl ())
-                 else 
+                 else
 		   (str";" ++ brk(1,3) ++
-		      print_info_script sigma 
+		      print_info_script sigma
 		      (Environ.named_context_of_val sign) pf1)
              | _ -> (str"." ++ fnl () ++
                        prlist_with_sep pr_fnl
-                         (print_info_script sigma 
+                         (print_info_script sigma
 			    (Environ.named_context_of_val sign)) spfl))
 
-let format_print_info_script sigma osign pf = 
+let format_print_info_script sigma osign pf =
   hov 0 (print_info_script sigma osign pf)
-    
-let print_subscript sigma sign pf = 
-  if is_tactic_proof pf then 
+
+let print_subscript sigma sign pf =
+  if is_tactic_proof pf then
     format_print_info_script sigma sign (subproof_of_proof pf)
-  else 
+  else
     format_print_info_script sigma sign pf
 
 let _ = Refiner.set_info_printer print_subscript
+let _ = Refiner.set_proof_printer print_proof
 
diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli
index affc5ec2..d46f19c6 100644
--- a/parsing/tactic_printer.mli
+++ b/parsing/tactic_printer.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_printer.mli 11313 2008-08-07 11:15:03Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4
index a7b27e21..e8a3094b 100644
--- a/parsing/vernacextend.ml4
+++ b/parsing/vernacextend.ml4
@@ -8,38 +8,21 @@
 
 (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
 
-(* $Id: vernacextend.ml4 11622 2008-11-23 08:45:56Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Genarg
 open Q_util
 open Q_coqast
 open Argextend
-
-let loc = Util.dummy_loc
-let default_loc = <:expr< Util.dummy_loc >>
-
-type grammar_tactic_production_expr =
-  | VernacTerm of string
-  | VernacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option
-let rec make_patt = function
-  | [] -> <:patt< [] >>
-  | VernacNonTerm(_,_,_,Some p)::l ->
-      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
-  | _::l -> make_patt l
-
-let rec make_when loc = function
-  | [] -> <:expr< True >>
-  | VernacNonTerm(loc',t,_,Some p)::l ->
-      let l = make_when loc l in
-      let loc = join_loc loc' loc in
-      let t = mlexpr_of_argtype loc' t in
-      <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
-  | _::l -> make_when loc l
+open Tacextend
+open Pcoq
+open Egrammar
 
 let rec make_let e = function
   | [] -> e
-  | VernacNonTerm(loc,t,_,Some p)::l ->
+  | GramNonTerminal(loc,t,_,Some p)::l ->
+      let p = Names.string_of_id p in
       let loc = join_loc loc (MLast.loc_of_expr e) in
       let e = make_let e l in
       <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >>
@@ -50,11 +33,6 @@ let add_clause s (_,pt,e) l =
   let w = Some (make_when (MLast.loc_of_expr e) pt) in
   (p, w, make_let e pt)::l
 
-let rec extract_signature = function
-  | [] -> []
-  | VernacNonTerm (_,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
@@ -68,22 +46,9 @@ let make_clauses s l =
     (<:patt< _ >>,None,<:expr< failwith "Vernac extension: cannot occur" >>) in
   List.fold_right (add_clause s) l [default]
 
-let rec make_fun e = function
-  | [] -> e
-  | VernacNonTerm(loc,_,_,Some p)::l -> 
-      <:expr< fun $lid:p$ -> $make_fun e l$ >>
-  | _::l -> make_fun e l
-
-let mlexpr_of_grammar_production = function
-  | VernacTerm s ->
-      <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >>
-  | VernacNonTerm (loc,nt,g,sopt) ->
-      <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >>
-
 let mlexpr_of_clause =
   mlexpr_of_list
-    (fun (a,b,c) -> 
-      mlexpr_of_list mlexpr_of_grammar_production (VernacTerm a::b))
+    (fun (a,b,c) -> mlexpr_of_list make_prod_item (GramTerminal a::b))
 
 let declare_command loc s cl =
   let gl = mlexpr_of_clause cl in
@@ -91,6 +56,7 @@ let declare_command loc s cl =
   <:str_item<
     declare
       open Pcoq;
+      open Extrawit;
       try Vernacinterp.vinterp_add $mlexpr_of_string s$ (fun [ $list:icl$ ])
       with e -> Pp.pp (Cerrors.explain_exn e);
       Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $gl$;
@@ -109,20 +75,20 @@ EXTEND
   ;
   rule:
     [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]"
-        -> 
+        ->
       if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty.");
       (s,l,<:expr< fun () -> $e$ >>)
     ] ]
   ;
   args:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = Q_util.interp_entry_name loc e "" in
-        VernacNonTerm (loc, t, g, Some s)
+        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 = Q_util.interp_entry_name loc e sep in
-        VernacNonTerm (loc, t, g, Some s)
+        let t, g = interp_entry_name false None e sep in
+        GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
       | s = STRING ->
-        VernacTerm s
+        GramTerminal s
     ] ]
   ;
   END
diff --git a/contrib/cc/README b/plugins/cc/README
index 073b140e..073b140e 100644
--- a/contrib/cc/README
+++ b/plugins/cc/README
diff --git a/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mllib
new file mode 100644
index 00000000..1bcfc537
--- /dev/null
+++ b/plugins/cc/cc_plugin.mllib
@@ -0,0 +1,5 @@
+Ccalgo
+Ccproof
+Cctac
+G_congruence
+Cc_plugin_mod
diff --git a/contrib/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index e67797e4..9cc6f9de 100644
--- a/contrib/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.ml 10579 2008-02-21 13:54:00Z corbinea $ *)
+(* $Id$ *)
 
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
@@ -22,45 +22,45 @@ open Proof_type
 
 let init_size=5
 
-let cc_verbose=ref false 
+let cc_verbose=ref false
 
-let debug f x = 
+let debug f x =
   if !cc_verbose then f x
 
 let _=
   let gdopt=
     { optsync=true;
       optname="Congruence Verbose";
-      optkey=SecondaryTable("Congruence","Verbose"); 
-      optread=(fun ()-> !cc_verbose); 
-      optwrite=(fun b -> cc_verbose := b)}  
+      optkey=["Congruence";"Verbose"];
+      optread=(fun ()-> !cc_verbose);
+      optwrite=(fun b -> cc_verbose := b)}
   in
     declare_bool_option gdopt
 
 (* Signature table *)
 
 module ST=struct
-  
+
   (* l: sign -> term r: term -> sign *)
-	
+
   type t = {toterm:(int*int,int) Hashtbl.t;
 	    tosign:(int,int*int) Hashtbl.t}
-	
+
   let empty ()=
     {toterm=Hashtbl.create init_size;
      tosign=Hashtbl.create init_size}
-      
+
   let enter t sign st=
-    if Hashtbl.mem st.toterm sign then 
+    if Hashtbl.mem st.toterm sign then
 	anomaly "enter: signature already entered"
-    else 
+    else
 	Hashtbl.replace st.toterm sign t;
 	Hashtbl.replace st.tosign t sign
-	  
+
   let query sign st=Hashtbl.find st.toterm sign
 
   let rev_query term st=Hashtbl.find st.tosign term
-	  
+
   let delete st t=
     try let sign=Hashtbl.find st.tosign t in
 	Hashtbl.remove st.toterm sign;
@@ -69,7 +69,7 @@ module ST=struct
 	Not_found -> ()
 
   let rec delete_set st s = Intset.iter (delete st) s
-	  
+
 end
 
 type pa_constructor=
@@ -85,11 +85,11 @@ type pa_mark=
     Fmark of pa_fun
   | Cmark of pa_constructor
 
-module PacMap=Map.Make(struct 
-			 type t=pa_constructor 
-			 let compare=Pervasives.compare end) 
+module PacMap=Map.Make(struct
+			 type t=pa_constructor
+			 let compare=Pervasives.compare end)
 
-module PafMap=Map.Make(struct 
+module PafMap=Map.Make(struct
 			 type t=pa_fun
 			 let compare=Pervasives.compare end)
 
@@ -107,11 +107,11 @@ type term=
 
 type ccpattern =
     PApp of term * ccpattern list (* arguments are reversed *)
-  | PVar of int 
+  | PVar of int
 
 type rule=
     Congruence
-  | Axiom of constr * bool 
+  | Axiom of constr * bool
   | Injection of int * pa_constructor * int * pa_constructor * int
 
 type from=
@@ -127,7 +127,7 @@ type equality = rule eq
 type disequality = from eq
 
 type patt_kind =
-    Normal 
+    Normal
   | Trivial of types
   | Creates_variables
 
@@ -146,7 +146,7 @@ let swap eq : equality =
     | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k)
     | Axiom (id,reversed) -> Axiom (id,not reversed)
   in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule}
-    
+
 type inductive_status =
     Unknown
   | Partial of pa_constructor
@@ -163,15 +163,15 @@ type representative=
      mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
 
 type cl = Rep of representative| Eqto of int*equality
-  
-type vertex = Leaf| Node of (int*int) 
 
-type node = 
+type vertex = Leaf| Node of (int*int)
+
+type node =
     {mutable clas:cl;
-     mutable cpath: int; 
+     mutable cpath: int;
      vertex:vertex;
      term:term}
-    
+
 type forest=
     {mutable max_size:int;
      mutable size:int;
@@ -180,11 +180,11 @@ type forest=
      mutable epsilons: pa_constructor list;
      syms:(term,int) Hashtbl.t}
 
-type state = 
+type state =
     {uf: forest;
      sigtable:ST.t;
-     mutable terms: Intset.t; 
-     combine: equality Queue.t; 
+     mutable terms: Intset.t;
+     combine: equality Queue.t;
      marks: (int * pa_mark) Queue.t;
      mutable diseq: disequality list;
      mutable quant: quant_eq list;
@@ -222,17 +222,17 @@ let empty depth gls:state =
   changed=false;
   gls=gls}
 
-let forest state = state.uf 
-       
+let forest state = state.uf
+
 let compress_path uf i j = uf.map.(j).cpath<-i
-			     
-let rec find_aux uf visited i=  
-  let j = uf.map.(i).cpath in 
+
+let rec find_aux uf visited i=
+  let j = uf.map.(i).cpath in
     if j<0 then let _ = List.iter (compress_path uf i) visited in i else
       find_aux uf (i::visited) j
-	
+
 let find uf i= find_aux uf [] i
-		 
+
 let get_representative uf i=
   match uf.map.(i).clas with
       Rep r -> r
@@ -245,7 +245,7 @@ let get_constructor_info uf i=
   match uf.map.(i).term with
       Constructor cinfo->cinfo
     | _ -> anomaly "get_constructor: not a constructor"
-	
+
 let size uf i=
   (get_representative uf i).weight
 
@@ -264,36 +264,36 @@ let add_rfather uf i t=
     r.weight<-r.weight+1;
     r.fathers <-Intset.add t r.fathers
 
-exception Discriminable of int * pa_constructor * int * pa_constructor 
+exception Discriminable of int * pa_constructor * int * pa_constructor
 
 let append_pac t p =
-  {p with arity=pred p.arity;args=t::p.args} 
+  {p with arity=pred p.arity;args=t::p.args}
 
 let tail_pac p=
   {p with arity=succ p.arity;args=List.tl p.args}
 
 let fsucc paf =
   {paf with fnargs=succ paf.fnargs}
-    
+
 let add_pac rep pac t =
   if not (PacMap.mem pac rep.constructors) then
     rep.constructors<-PacMap.add pac t rep.constructors
 
 let add_paf rep paf t =
-  let already = 
+  let already =
     try PafMap.find paf rep.functions with Not_found -> Intset.empty in
     rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
 
 let term uf i=uf.map.(i).term
-		
+
 let subterms uf i=
   match uf.map.(i).vertex with
       Node(j,k) -> (j,k)
     | _ -> anomaly "subterms: not a node"
-	
+
 let signature uf i=
   let j,k=subterms uf i in (find uf j,find uf k)
-			     
+
 let next uf=
   let size=uf.size in
   let nsize= succ size in
@@ -304,11 +304,11 @@ let next uf=
 	  uf.max_size<-newmax;
 	  Array.blit uf.map 0 newmap 0 size;
 	  uf.map<-newmap
-	end 
+	end
     else ();
-    uf.size<-nsize; 
+    uf.size<-nsize;
     size
-	
+
 let new_representative typ =
   {weight=0;
    lfathers=Intset.empty;
@@ -317,14 +317,14 @@ let new_representative typ =
    class_type=typ;
    functions=PafMap.empty;
    constructors=PacMap.empty}
-    
+
 (* rebuild a constr from an applicative term *)
-    
+
 let _A_ = Name (id_of_string "A")
 let _B_ = Name (id_of_string "A")
 let _body_ =  mkProd(Anonymous,mkRel 2,mkRel 2)
 
-let cc_product s1 s2 = 
+let cc_product s1 s2 =
   mkLambda(_A_,mkSort(Termops.new_sort_in_family s1),
 	   mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_))
 
@@ -332,27 +332,27 @@ let rec constr_of_term = function
     Symb s->s
   | Product(s1,s2) -> cc_product s1 s2
   | Eps id -> mkVar id
-  | Constructor cinfo -> mkConstruct cinfo.ci_constr 
+  | Constructor cinfo -> mkConstruct cinfo.ci_constr
   | Appli (s1,s2)->
       make_app [(constr_of_term s2)] s1
 and make_app l=function
-    Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1    
-  | other -> applistc (constr_of_term other) l 
+    Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1
+  | other -> applistc (constr_of_term other) l
 
 (* rebuild a term from a pattern and a substitution *)
 
 let build_subst uf subst =
-  Array.map (fun i -> 
-	       try term uf i 
+  Array.map (fun i ->
+	       try term uf i
 	       with _ -> anomaly "incomplete matching") subst
 
 let rec inst_pattern subst = function
-    PVar i -> 
-      subst.(pred i) 
-  | PApp (t, args) -> 
+    PVar i ->
+      subst.(pred i)
+  | PApp (t, args) ->
       List.fold_right
 	(fun spat f -> Appli (f,inst_pattern subst spat))
-	   args t  
+	   args t
 
 let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++
   Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]"
@@ -360,9 +360,9 @@ let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++
 let pr_term t = str "[" ++
   Termops.print_constr (constr_of_term t) ++ str "]"
 
-let rec add_term state t= 
+let rec add_term state t=
   let uf=state.uf in
-    try Hashtbl.find uf.syms t with 
+    try Hashtbl.find uf.syms t with
 	Not_found ->
 	  let b=next uf in
 	  let typ = pf_type_of state.gls (constr_of_term t) in
@@ -377,12 +377,12 @@ let rec add_term state t=
 		     cpath= -1;
 		     vertex= Leaf;
 		     term= t}
-	      | Eps id -> 
+	      | Eps id ->
 		  {clas= Rep (new_representative typ);
 		   cpath= -1;
 		   vertex= Leaf;
 		   term= t}
-	      | Appli (t1,t2) -> 
+	      | Appli (t1,t2) ->
 		  let i1=add_term state t1 and i2=add_term state t2 in
 		    add_lfather uf (find uf i1) b;
 		    add_rfather uf (find uf i2) b;
@@ -408,9 +408,9 @@ let rec add_term state t=
 	  in
 	    uf.map.(b)<-new_node;
 	    Hashtbl.add uf.syms t b;
-	    Hashtbl.replace state.by_type typ 
-	      (Intset.add b 
-		 (try Hashtbl.find state.by_type typ with 
+	    Hashtbl.replace state.by_type typ
+	      (Intset.add b
+		 (try Hashtbl.find state.by_type typ with
 		      Not_found -> Intset.empty));
 	    b
 
@@ -436,22 +436,22 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
      qe_rhs_valid=valid2}::state.quant
 
 let is_redundant state id args =
-  try  
+  try
     let norm_args = Array.map (find state.uf) args in
     let prev_args = Hashtbl.find_all state.q_history id in
-    List.exists 
-      (fun old_args -> 
-	 Util.array_for_all2 (fun i j -> i = find state.uf j) 
-         norm_args old_args) 
+    List.exists
+      (fun old_args ->
+	 Util.array_for_all2 (fun i j -> i = find state.uf j)
+         norm_args old_args)
       prev_args
     with Not_found -> false
 
-let add_inst state (inst,int_subst) = 
+let add_inst state (inst,int_subst) =
   check_for_interrupt ();
   if state.rew_depth > 0 then
   if is_redundant state inst.qe_hyp_id int_subst then
     debug msgnl (str "discarding redundant (dis)equality")
-  else   
+  else
     begin
       Hashtbl.add state.q_history inst.qe_hyp_id int_subst;
       let subst = build_subst (forest state) int_subst in
@@ -459,149 +459,149 @@ let add_inst state (inst,int_subst) =
       let args = Array.map constr_of_term subst in
       let _ = array_rev args in (* highest deBruijn index first *)
       let prf= mkApp(prfhead,args) in
-	  let s = inst_pattern subst inst.qe_lhs 
+	  let s = inst_pattern subst inst.qe_lhs
 	  and t = inst_pattern subst inst.qe_rhs in
 	    state.changed<-true;
 	    state.rew_depth<-pred state.rew_depth;
 	    if inst.qe_pol then
 	      begin
-		debug (fun () -> 
-		  msgnl 
+		debug (fun () ->
+		  msgnl
 		   (str "Adding new equality, depth="++ int state.rew_depth);
-	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++ 
+	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++
 			   pr_term s ++ str " == " ++ pr_term t ++ str "]")) ();
 		add_equality state prf s t
 	      end
 	    else
 	      begin
-		debug (fun () -> 
-		  msgnl 
+		debug (fun () ->
+		  msgnl
 		   (str "Adding new disequality, depth="++ int state.rew_depth);
-	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++ 
+	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++
 			   pr_term s ++ str " <> " ++ pr_term t ++ str "]")) ();
-		add_disequality state (Hyp prf) s t 
+		add_disequality state (Hyp prf) s t
 	      end
   end
 
 let link uf i j eq = (* links i -> j *)
-  let node=uf.map.(i) in 
+  let node=uf.map.(i) in
     node.clas<-Eqto (j,eq);
     node.cpath<-j
-	
+
 let rec down_path uf i l=
   match uf.map.(i).clas with
       Eqto(j,t)->down_path uf j (((i,j),t)::l)
     | Rep _ ->l
-	
+
 let rec min_path=function
     ([],l2)->([],l2)
   | (l1,[])->(l1,[])
-  | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) 
+  | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2)
   | cpl -> cpl
-      
+
 let join_path uf i j=
   assert (find uf i=find uf j);
   min_path (down_path uf i [],down_path uf j [])
 
 let union state i1 i2 eq=
-  debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ 
+  debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++
 		 str " and " ++ pr_idx_term state i2 ++ str ".")) ();
-  let r1= get_representative state.uf i1 
+  let r1= get_representative state.uf i1
   and r2= get_representative state.uf i2 in
     link state.uf i1 i2 eq;
-    Hashtbl.replace state.by_type r1.class_type 
-      (Intset.remove i1 
-	 (try Hashtbl.find state.by_type r1.class_type with 
+    Hashtbl.replace state.by_type r1.class_type
+      (Intset.remove i1
+	 (try Hashtbl.find state.by_type r1.class_type with
 	      Not_found -> Intset.empty));
     let f= Intset.union r1.fathers r2.fathers in
       r2.weight<-Intset.cardinal f;
       r2.fathers<-f;
       r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
       ST.delete_set state.sigtable r1.fathers;
-      state.terms<-Intset.union state.terms r1.fathers;       
-      PacMap.iter 
-	(fun pac b -> Queue.add (b,Cmark pac) state.marks) 
+      state.terms<-Intset.union state.terms r1.fathers;
+      PacMap.iter
+	(fun pac b -> Queue.add (b,Cmark pac) state.marks)
 	r1.constructors;
-      PafMap.iter 
-	(fun paf -> Intset.iter 
-	   (fun b -> Queue.add (b,Fmark paf) state.marks)) 
+      PafMap.iter
+	(fun paf -> Intset.iter
+	   (fun b -> Queue.add (b,Fmark paf) state.marks))
 	r1.functions;
-      match r1.inductive_status,r2.inductive_status with 
+      match r1.inductive_status,r2.inductive_status with
 	  Unknown,_ -> ()
-	| Partial pac,Unknown -> 
+	| Partial pac,Unknown ->
 	    r2.inductive_status<-Partial pac;
 	    state.pa_classes<-Intset.remove i1 state.pa_classes;
 	    state.pa_classes<-Intset.add i2 state.pa_classes
-	| Partial _ ,(Partial _ |Partial_applied) -> 
+	| Partial _ ,(Partial _ |Partial_applied) ->
 	    state.pa_classes<-Intset.remove i1 state.pa_classes
-	| Partial_applied,Unknown -> 
-	    r2.inductive_status<-Partial_applied	      
-	| Partial_applied,Partial _ -> 
+	| Partial_applied,Unknown ->
+	    r2.inductive_status<-Partial_applied
+	| Partial_applied,Partial _ ->
 	    state.pa_classes<-Intset.remove i2 state.pa_classes;
 	    r2.inductive_status<-Partial_applied
 	| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
-	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks    
-	| _,_ -> () 
-            
+	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks
+	| _,_ -> ()
+
 let merge eq state = (* merge and no-merge *)
-  debug (fun () -> msgnl 
-    (str "Merging " ++ pr_idx_term state eq.lhs ++ 
+  debug (fun () -> msgnl
+    (str "Merging " ++ pr_idx_term state eq.lhs ++
        str " and " ++ pr_idx_term state eq.rhs ++ str ".")) ();
   let uf=state.uf in
-  let i=find uf eq.lhs 
+  let i=find uf eq.lhs
   and j=find uf eq.rhs in
-    if i<>j then 
+    if i<>j then
       if (size uf i)<(size uf j) then
 	union state i j eq
       else
 	union state j i (swap eq)
 
 let update t state = (* update 1 and 2 *)
-  debug (fun () -> msgnl 
+  debug (fun () -> msgnl
     (str "Updating term " ++ pr_idx_term state 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
     begin
-      match rep.inductive_status with 
+      match rep.inductive_status with
 	  Partial _ ->
 	    rep.inductive_status <- Partial_applied;
 	    state.pa_classes <- Intset.remove i state.pa_classes
 	| _ -> ()
     end;
-    PacMap.iter 
-      (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) 
-      rep.constructors; 
-    PafMap.iter 
-      (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) 
-      rep.functions; 
-    try 
-      let s = ST.query sign state.sigtable in 
+    PacMap.iter
+      (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks)
+      rep.constructors;
+    PafMap.iter
+      (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks)
+      rep.functions;
+    try
+      let s = ST.query sign state.sigtable in
 	Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine
-    with 
+    with
 	Not_found -> ST.enter t sign state.sigtable
 
 let process_function_mark t rep paf state  =
   add_paf rep paf t;
   state.terms<-Intset.union rep.lfathers state.terms
-    
+
 let process_constructor_mark t i rep pac state =
     match rep.inductive_status with
 	Total (s,opac) ->
-	  if pac.cnode <> opac.cnode then (* Conflict *) 
-	    raise (Discriminable (s,opac,t,pac)) 
+	  if pac.cnode <> opac.cnode then (* Conflict *)
+	    raise (Discriminable (s,opac,t,pac))
 	  else (* Match *)
 	    let cinfo = get_constructor_info state.uf pac.cnode in
 	    let rec f n oargs args=
-	      if n > 0 then 
+	      if n > 0 then
 		match (oargs,args) with
 		    s1::q1,s2::q2->
-		      Queue.add 
+		      Queue.add
 			{lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
 			state.combine;
-		      f (n-1) q1 q2 
-		  | _-> anomaly 
-		      "add_pacs : weird error in injection subterms merge" 
+		      f (n-1) q1 q2
+		  | _-> anomaly
+		      "add_pacs : weird error in injection subterms merge"
 	    in f cinfo.ci_nhyps opac.args pac.args
       | Partial_applied | Partial _ ->
 	  add_pac rep pac t;
@@ -617,8 +617,8 @@ let process_constructor_mark t i rep pac state =
 	      state.pa_classes<- Intset.add i state.pa_classes
 	    end
 
-let process_mark t m state = 
-  debug (fun () -> msgnl 
+let process_mark t m state =
+  debug (fun () -> msgnl
     (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) ();
   let i=find state.uf t in
   let rep=get_representative state.uf i in
@@ -634,15 +634,15 @@ type explanation =
 let check_disequalities state =
   let uf=state.uf in
   let rec check_aux = function
-      dis::q -> 
-	debug (fun () -> msg   
-	(str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ 
-	 pr_idx_term state dis.rhs ++ str " ... ")) ();  
-	if find uf dis.lhs=find uf dis.rhs then 
-	  begin debug msgnl (str "Yes");Some dis end 
+      dis::q ->
+	debug (fun () -> msg
+	(str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++
+	 pr_idx_term state dis.rhs ++ str " ... ")) ();
+	if find uf dis.lhs=find uf dis.rhs then
+	  begin debug msgnl (str "Yes");Some dis end
 	else
 	  begin debug msgnl (str "No");check_aux q end
-    | [] -> None 
+    | [] -> None
   in
     check_aux state.diseq
 
@@ -651,8 +651,8 @@ let one_step state =
       let eq = Queue.take state.combine in
 	merge eq state;
 	true
-    with Queue.Empty -> 
-      try 
+    with Queue.Empty ->
+      try
 	let (t,m) = Queue.take state.marks in
 	  process_mark t m state;
 	  true
@@ -664,40 +664,40 @@ let one_step state =
 	    true
 	with Not_found -> false
 
-let __eps__ = id_of_string "_eps_"  
+let __eps__ = id_of_string "_eps_"
 
 let new_state_var typ state =
   let id = pf_get_new_id __eps__ state.gls in
     state.gls<-
       {state.gls with it =
-	  {state.gls.it with evar_hyps = 
-	      Environ.push_named_context_val (id,None,typ) 
+	  {state.gls.it with evar_hyps =
+	      Environ.push_named_context_val (id,None,typ)
 		state.gls.it.evar_hyps}};
     id
 
 let complete_one_class state i=
   match (get_representative state.uf i).inductive_status with
       Partial pac ->
-	let rec app t typ n = 
+	let rec app t typ n =
 	  if n<=0 then t else
 	    let _,etyp,rest= destProd typ in
 	    let id = new_state_var etyp state in
 		app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in
 	let _c = pf_type_of state.gls
 	  (constr_of_term (term state.uf pac.cnode)) in
-	let _args = 
-	  List.map (fun i -> constr_of_term (term state.uf  i)) 
+	let _args =
+	  List.map (fun i -> constr_of_term (term state.uf  i))
 	    pac.args in
-	let typ = prod_applist _c (List.rev _args) in 
+	let typ = prod_applist _c (List.rev _args) in
 	let ct = app (term state.uf i) typ pac.arity in
-	  state.uf.epsilons <- pac :: state.uf.epsilons; 
+	  state.uf.epsilons <- pac :: state.uf.epsilons;
 	  ignore (add_term state ct)
-    | _ -> anomaly "wrong incomplete class" 
+    | _ -> anomaly "wrong incomplete class"
 
 let complete state =
   Intset.iter (complete_one_class state) state.pa_classes
 
-type matching_problem = 
+type matching_problem =
 {mp_subst : int array;
  mp_inst : quant_eq;
  mp_stack : (ccpattern*int) list }
@@ -705,31 +705,31 @@ type matching_problem =
 let make_fun_table state =
   let uf= state.uf in
   let funtab=ref PafMap.empty in
-  Array.iteri 
+  Array.iteri
     (fun i inode -> if i < uf.size then
        match inode.clas with
 	   Rep rep ->
-	     PafMap.iter 
-	       (fun paf _ -> 
-		  let elem = 
-		    try PafMap.find paf !funtab 
+	     PafMap.iter
+	       (fun paf _ ->
+		  let elem =
+		    try PafMap.find paf !funtab
 		    with Not_found -> Intset.empty in
-		    funtab:= PafMap.add paf (Intset.add i elem) !funtab) 
+		    funtab:= PafMap.add paf (Intset.add i elem) !funtab)
 	       rep.functions
 	 | _ -> ()) state.uf.map;
     !funtab
-  
+
 
 let rec do_match state res pb_stack =
   let mp=Stack.pop pb_stack in
     match mp.mp_stack with
-	[] -> 
+	[] ->
 	  res:= (mp.mp_inst,mp.mp_subst) :: !res
       | (patt,cl)::remains ->
 	  let uf=state.uf in
 	    match patt with
-		PVar i -> 
-		  if mp.mp_subst.(pred i)<0 then  
+		PVar i ->
+		  if mp.mp_subst.(pred i)<0 then
 		    begin
 		      mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *)
 		      Stack.push {mp with mp_stack=remains} pb_stack
@@ -746,18 +746,18 @@ let rec do_match state res pb_stack =
 		    with Not_found -> ()
 		  end
 	      | PApp(f, ((last_arg::rem_args) as args)) ->
-		  try 
-		    let j=Hashtbl.find uf.syms f in 
+		  try
+		    let j=Hashtbl.find uf.syms f in
 		    let paf={fsym=j;fnargs=List.length args} in
 		    let rep=get_representative uf cl in
 		    let good_terms = PafMap.find paf rep.functions in
-		    let aux i = 
+		    let aux i =
 		      let (s,t) = signature state.uf i in
-			Stack.push 
-			  {mp with 
+			Stack.push
+			  {mp with
 			     mp_subst=Array.copy mp.mp_subst;
 			     mp_stack=
-			      (PApp(f,rem_args),s) :: 
+			      (PApp(f,rem_args),s) ::
 				(last_arg,t) :: remains} pb_stack in
 		      Intset.iter aux good_terms
 		  with Not_found -> ()
@@ -768,7 +768,7 @@ let paf_of_patt syms = function
       {fsym=Hashtbl.find syms f;
        fnargs=List.length args}
 
-let init_pb_stack state = 
+let init_pb_stack state =
   let syms= state.uf.syms in
   let pb_stack = Stack.create () in
   let funtab = make_fun_table state in
@@ -778,51 +778,51 @@ let init_pb_stack state =
 	match inst.qe_lhs_valid with
 	  Creates_variables -> Intset.empty
 	| Normal ->
-	    begin 
-	      try 
+	    begin
+	      try
 		let paf= paf_of_patt syms inst.qe_lhs in
 		  PafMap.find paf funtab
 	      with Not_found -> Intset.empty
 	    end
-	| Trivial typ -> 
-	    begin 
-	      try 
+	| Trivial typ ->
+	    begin
+	      try
 		Hashtbl.find state.by_type typ
 	      with Not_found -> Intset.empty
 	    end in
-	Intset.iter (fun i -> 
-		       Stack.push 
-			 {mp_subst = Array.make inst.qe_nvars (-1); 
+	Intset.iter (fun i ->
+		       Stack.push
+			 {mp_subst = Array.make inst.qe_nvars (-1);
 			  mp_inst=inst;
 			  mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
     end;
-    begin 
+    begin
       let good_classes =
 	match inst.qe_rhs_valid with
 	  Creates_variables -> Intset.empty
 	| Normal ->
-	    begin 
-	      try 
+	    begin
+	      try
 		let paf= paf_of_patt syms inst.qe_rhs in
 		  PafMap.find paf funtab
 	      with Not_found -> Intset.empty
 	    end
-	| Trivial typ -> 
-	    begin 
-	      try 
+	| Trivial typ ->
+	    begin
+	      try
 		Hashtbl.find state.by_type typ
 	      with Not_found -> Intset.empty
 	    end in
-	Intset.iter (fun i -> 
-		       Stack.push 
-			 {mp_subst = Array.make inst.qe_nvars (-1); 
+	Intset.iter (fun i ->
+		       Stack.push
+			 {mp_subst = Array.make inst.qe_nvars (-1);
 			  mp_inst=inst;
 			  mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
     end in
     List.iter aux state.quant;
     pb_stack
 
-let find_instances state = 
+let find_instances state =
   let pb_stack= init_pb_stack state in
   let res =ref [] in
   let _ =
@@ -830,7 +830,7 @@ let find_instances state =
     try
       while true do
 	check_for_interrupt ();
-	do_match state res pb_stack 
+	do_match state res pb_stack
       done;
       anomaly "get out of here !"
     with Stack.Empty -> () in
@@ -839,34 +839,34 @@ let find_instances state =
 let rec execute first_run state =
   debug msgnl (str "Executing ... ");
   try
-    while 
+    while
       check_for_interrupt ();
       one_step state do ()
     done;
     match check_disequalities state with
-	None -> 
+	None ->
 	  if not(Intset.is_empty state.pa_classes) then
-	    begin 
+	    begin
 	      debug msgnl (str "First run was incomplete, completing ... ");
 	      complete state;
 	      execute false state
 	    end
-	  else 
+	  else
 	    if state.rew_depth>0 then
 	      let l=find_instances state in
 		List.iter (add_inst state) l;
-		if state.changed then 
+		if state.changed then
 		  begin
 		    state.changed <- false;
 		    execute true state
 		  end
 		else
-	      begin 
+	      begin
 		debug msgnl (str "Out of instances ... ");
 		None
 	      end
-	    else 
-	      begin 
+	    else
+	      begin
 		debug msgnl (str "Out of depth ... ");
 		None
 	      end
diff --git a/contrib/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index cdc0065e..5f56c7e6 100644
--- a/contrib/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.mli 10579 2008-02-21 13:54:00Z corbinea $ *)
+(* $Id$ *)
 
 open Util
 open Term
@@ -25,35 +25,35 @@ type term =
   | Constructor of cinfo (* constructor arity + nhyps *)
 
 type patt_kind =
-    Normal 
+    Normal
   | Trivial of types
   | Creates_variables
 
 type ccpattern =
     PApp of term * ccpattern list
-  | PVar of int 
+  | PVar of int
 
 type pa_constructor =
     { cnode : int;
       arity : int;
       args  : int list}
 
-module PacMap : Map.S with type key = pa_constructor  
+module PacMap : Map.S with type key = pa_constructor
 
 type forest
 
-type state 
+type state
 
 type rule=
     Congruence
-  | Axiom of constr * bool 
+  | Axiom of constr * bool
   | Injection of int * pa_constructor * int * pa_constructor * int
 
 type from=
     Goal
   | Hyp of constr
   | HeqG of constr
-  | HeqnH of constr*constr 
+  | HeqnH of constr*constr
 
 type 'a eq = {lhs:int;rhs:int;rule:'a}
 
@@ -84,7 +84,7 @@ val add_equality : state -> constr -> term -> term -> unit
 
 val add_disequality : state -> from -> term -> term -> unit
 
-val add_quant : state -> identifier -> bool -> 
+val add_quant : state -> identifier -> bool ->
   int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
 
 val tail_pac : pa_constructor -> pa_constructor
@@ -99,7 +99,7 @@ val get_constructor_info : forest -> int -> cinfo
 
 val subterms : forest -> int -> int * int
 
-val join_path : forest -> int -> int -> 
+val join_path : forest -> int -> int ->
   ((int * int) * equality) list * ((int * int) * equality) list
 
 type quant_eq=
@@ -117,10 +117,10 @@ type pa_fun=
      fnargs:int}
 
 type matching_problem
- 
+
 module PafMap: Map.S with type key = pa_fun
 
-val make_fun_table : state -> Intset.t PafMap.t 
+val make_fun_table : state -> Intset.t PafMap.t
 
 val do_match :  state ->
     (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
@@ -150,20 +150,20 @@ val execute : bool -> state -> explanation option
 
 module PacMap:Map.S with type key=pa_constructor
 
-type term = 
-    Symb of Term.constr 
+type term =
+    Symb of Term.constr
   | Eps
-  | Appli of term * term 
+  | Appli of term * term
   | Constructor of Names.constructor*int*int
 
-type rule = 
-    Congruence 
+type rule =
+    Congruence
   | Axiom of Names.identifier
   | Injection of int*int*int*int
 
 type equality =
-    {lhs : int; 
-     rhs : int; 
+    {lhs : int;
+     rhs : int;
      rule : rule}
 
 module ST :
@@ -175,47 +175,47 @@ sig
   val delete : int -> t -> unit
   val delete_list : int list -> t -> unit
 end
-  
+
 module UF :
 sig
-  type t 
-  exception Discriminable of int * int * int * int * t 
+  type t
+  exception Discriminable of int * int * int * int * t
   val empty : unit -> t
   val find : t -> int -> int
   val size : t -> int -> int
   val get_constructor : t -> int -> Names.constructor
   val pac_arity : t -> int -> int * int -> int
-  val mem_node_pac : t -> int -> int * int -> int 
-  val add_pacs : t -> int -> pa_constructor PacMap.t -> 
+  val mem_node_pac : t -> int -> int * int -> int
+  val add_pacs : t -> int -> pa_constructor PacMap.t ->
     int list * equality list
-  val term : t -> int -> term    
+  val term : t -> int -> term
   val subterms : t -> int -> int * int
   val add : t -> term -> int
   val union : t -> int -> int -> equality -> int list * equality list
-  val join_path : t -> int -> int -> 
+  val join_path : t -> int -> int ->
     ((int*int)*equality) list*
     ((int*int)*equality) list
 end
-  
+
 
 val combine_rec : UF.t -> int list -> equality list
 val process_rec : UF.t -> equality list -> int list
 
 val cc : UF.t -> unit
-  
+
 val make_uf :
   (Names.identifier * (term * term)) list -> UF.t
 
 val add_one_diseq : UF.t -> (term * term) -> int * int
 
-val add_disaxioms : 
-  UF.t -> (Names.identifier * (term * term)) list -> 
+val add_disaxioms :
+  UF.t -> (Names.identifier * (term * term)) list ->
   (Names.identifier * (int * int)) list
-  
+
 val check_equal : UF.t -> int * int -> bool
 
-val find_contradiction : UF.t -> 
-  (Names.identifier * (int * int)) list -> 
+val find_contradiction : UF.t ->
+  (Names.identifier * (int * int)) list ->
   (Names.identifier * (int * int))
 *)
 
diff --git a/contrib/cc/ccproof.ml b/plugins/cc/ccproof.ml
index a459b18f..2a019ebf 100644
--- a/contrib/cc/ccproof.ml
+++ b/plugins/cc/ccproof.ml
@@ -6,32 +6,32 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.ml 9857 2007-05-24 14:21:08Z corbinea $ *)
+(* $Id$ *)
 
-(* This file uses the (non-compressed) union-find structure to generate *) 
+(* This file uses the (non-compressed) union-find structure to generate *)
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
 open Util
 open Names
 open Term
 open Ccalgo
-  
+
 type rule=
     Ax of constr
   | SymAx of constr
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
-  | Inject of proof*constructor*int*int 
-and proof = 
+  | Inject of proof*constructor*int*int
+and proof =
     {p_lhs:term;p_rhs:term;p_rule:rule}
 
 let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t}
 
-let pcongr p1 p2 = 
-  match p1.p_rule,p2.p_rule with 
+let pcongr p1 p2 =
+  match p1.p_rule,p2.p_rule with
     Refl t1, Refl t2 -> prefl (Appli (t1,t2))
-  | _, _ -> 
+  | _, _ ->
       {p_lhs=Appli (p1.p_lhs,p2.p_lhs);
        p_rhs=Appli (p1.p_rhs,p2.p_rhs);
        p_rule=Congr (p1,p2)}
@@ -44,25 +44,25 @@ let rec ptrans p1 p3=
     | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4)
     | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) ->
 	ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5
-  | _, _ -> 
-      if p1.p_rhs = p3.p_lhs then 
+  | _, _ ->
+      if p1.p_rhs = p3.p_lhs then
 	{p_lhs=p1.p_lhs;
 	 p_rhs=p3.p_rhs;
 	 p_rule=Trans (p1,p3)}
       else anomaly "invalid cc transitivity"
-	
-let rec psym p = 
-  match p.p_rule with 
-      Refl _ -> p 
+
+let rec psym p =
+  match p.p_rule with
+      Refl _ -> p
     | SymAx s ->
 	{p_lhs=p.p_rhs;
 	 p_rhs=p.p_lhs;
 	 p_rule=Ax s}
-    | Ax s->      
+    | Ax s->
 	{p_lhs=p.p_rhs;
 	 p_rhs=p.p_lhs;
 	 p_rule=SymAx s}
-  | Inject (p0,c,n,a)-> 
+  | Inject (p0,c,n,a)->
       {p_lhs=p.p_rhs;
        p_rhs=p.p_lhs;
        p_rule=Inject (psym p0,c,n,a)}
@@ -82,9 +82,9 @@ let psymax axioms s =
      p_rule=SymAx s}
 
 let rec nth_arg t n=
-  match t with 
-      Appli (t1,t2)-> 
-	if n>0 then 
+  match t with
+      Appli (t1,t2)->
+	if n>0 then
 	  nth_arg t1 (n-1)
 	else t2
     | _ -> anomaly "nth_arg: not enough args"
@@ -99,23 +99,23 @@ let build_proof uf=
   let axioms = axioms uf in
 
   let rec equal_proof i j=
-    if i=j then prefl (term uf i) else 
+    if i=j then prefl (term uf i) else
       let (li,lj)=join_path uf i j in
 	ptrans (path_proof i li) (psym (path_proof j lj))
-  
+
   and edge_proof ((i,j),eq)=
     let pi=equal_proof i eq.lhs in
     let pj=psym (equal_proof j eq.rhs) in
     let pij=
-      match eq.rule with 
+      match eq.rule with
 	  Axiom (s,reversed)->
-	    if reversed then psymax axioms s 
+	    if reversed then psymax axioms s
 	    else pax axioms s
 	| Congruence ->congr_proof eq.lhs eq.rhs
 	| Injection (ti,ipac,tj,jpac,k) ->
 	    let p=ind_proof ti ipac tj jpac in
 	    let cinfo= get_constructor_info uf ipac.cnode in
-	      pinject p cinfo.ci_constr cinfo.ci_nhyps k	
+	      pinject p cinfo.ci_constr cinfo.ci_nhyps k
     in  ptrans (ptrans pi pij) pj
 
   and constr_proof i t ipac=
@@ -133,15 +133,15 @@ let build_proof uf=
   and path_proof i=function
       [] -> prefl (term uf i)
     | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x)
-  
+
   and congr_proof i j=
     let (i1,i2) = subterms uf i
-    and (j1,j2) = subterms uf j in   
+    and (j1,j2) = subterms uf j in
       pcongr (equal_proof i1 j1) (equal_proof i2 j2)
-	
+
   and ind_proof i ipac j jpac=
-    let p=equal_proof i j 
-    and p1=constr_proof i i ipac 
+    let p=equal_proof i j
+    and p1=constr_proof i i ipac
     and p2=constr_proof j j jpac in
       ptrans (psym p1) (ptrans p p2)
   in
diff --git a/contrib/cc/ccproof.mli b/plugins/cc/ccproof.mli
index 0eb97efe..2a0ca688 100644
--- a/contrib/cc/ccproof.mli
+++ b/plugins/cc/ccproof.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.mli 9857 2007-05-24 14:21:08Z corbinea $ *)
+(* $Id$ *)
 
 open Ccalgo
 open Names
@@ -18,12 +18,12 @@ type rule=
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
-  | Inject of proof*constructor*int*int 
-and proof = 
+  | Inject of proof*constructor*int*int
+and proof =
     private {p_lhs:term;p_rhs:term;p_rule:rule}
 
-val build_proof : 
-  forest -> 
+val build_proof :
+  forest ->
   [ `Discr of int * pa_constructor * int * pa_constructor
   | `Prove of int * int ] -> proof
 
diff --git a/contrib/cc/cctac.ml b/plugins/cc/cctac.ml
index 00cbbeee..4e6ea802 100644
--- a/contrib/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: cctac.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
+(* $Id$ *)
 
 (* This file is the interface between the c-c algorithm and Coq *)
 
@@ -58,7 +58,7 @@ let whd_delta env=
 
 (* decompose member of equality in an applicative format *)
 
-let sf_of env sigma c = family_of_sort (destSort (whd_delta env (type_of env sigma c)))
+let sf_of env sigma c = family_of_sort (sort_of env sigma c)
 
 let rec decompose_term env sigma t=
     match kind_of_term (whd env t) with
@@ -80,18 +80,18 @@ let rec decompose_term env sigma t=
 		       ci_arity=nargs;
 		       ci_nhyps=nargs-oib.mind_nparams}
     | _ ->if closed0 t then (Symb t) else raise Not_found
-	
+
 (* decompose equality in members and type *)
-	
+
 let atom_of_constr env sigma term =
   let wh =  (whd_delta env term) in
-  let kot = kind_of_term wh in 
+  let kot = kind_of_term wh in
     match kot with
       App (f,args)->
-	  if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
+	  if eq_constr f (Lazy.force _eq) && (Array.length args)=3
 	  then `Eq (args.(0),
-		   decompose_term env sigma args.(1), 
-		   decompose_term env sigma args.(2)) 
+		   decompose_term env sigma args.(1),
+		   decompose_term env sigma args.(2))
 	  else `Other (decompose_term env sigma term)
     | _ -> `Other (decompose_term env sigma term)
 
@@ -99,7 +99,7 @@ let rec pattern_of_constr env sigma c =
   match kind_of_term (whd env c) with
       App (f,args)->
 	let pf = decompose_term env sigma f in
-	let pargs,lrels = List.split 
+	let pargs,lrels = List.split
 	  (array_map_to_list (pattern_of_constr env sigma) args) in
 	  PApp (pf,List.rev pargs),
 	List.fold_left Intset.union Intset.empty lrels
@@ -112,7 +112,7 @@ let rec pattern_of_constr env sigma c =
 	  PApp(Product (sort_a,sort_b),
 	       [pa;pb]),(Intset.union sa sb)
     | Rel i -> PVar i,Intset.singleton i
-    | _ -> 
+    | _ ->
 	let pf = decompose_term env sigma c in
 	  PApp (pf,[]),Intset.empty
 
@@ -121,58 +121,58 @@ let non_trivial = function
   | _ -> true
 
 let patterns_of_constr env sigma nrels term=
-  let f,args= 
+  let f,args=
     try destApp (whd_delta env term) with _ -> raise Not_found in
-	if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
-	then 
+	if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+	then
 	  let patt1,rels1 = pattern_of_constr env sigma args.(1)
 	  and patt2,rels2 = pattern_of_constr env sigma args.(2) in
-	  let valid1 = 
+	  let valid1 =
 	    if Intset.cardinal rels1 <> nrels then Creates_variables
 	    else if non_trivial patt1 then Normal
-	    else Trivial args.(0) 
+	    else Trivial args.(0)
 	  and valid2 =
 	    if Intset.cardinal rels2 <> nrels then Creates_variables
 	    else if non_trivial patt2 then Normal
 	    else Trivial args.(0) in
 	    if valid1 <> Creates_variables
-	      || valid2 <> Creates_variables  then 
+	      || valid2 <> Creates_variables  then
 	      nrels,valid1,patt1,valid2,patt2
 	    else raise Not_found
 	else raise Not_found
 
 let rec quantified_atom_of_constr env sigma nrels term =
   match kind_of_term (whd_delta env term) with
-      Prod (_,atom,ff) -> 
+      Prod (_,atom,ff) ->
 	if eq_constr ff (Lazy.force _False) then
 	  let patts=patterns_of_constr env sigma nrels atom in
 	      `Nrule patts
-	else 
+	else
 	  quantified_atom_of_constr env sigma (succ nrels) ff
-    | _ ->  
+    | _ ->
 	let patts=patterns_of_constr env sigma nrels term in
-	    `Rule patts	  
+	    `Rule patts
 
 let litteral_of_constr env sigma term=
   match kind_of_term (whd_delta env term) with
-    | Prod (_,atom,ff) -> 
+    | Prod (_,atom,ff) ->
 	if eq_constr ff (Lazy.force _False) then
 	  match (atom_of_constr env sigma atom) with
 	      `Eq(t,a,b) -> `Neq(t,a,b)
 	    | `Other(p) -> `Nother(p)
 	else
 	  begin
-	    try 
-	      quantified_atom_of_constr env sigma 1 ff  
+	    try
+	      quantified_atom_of_constr env sigma 1 ff
 	    with Not_found ->
 	      `Other (decompose_term env sigma term)
 	  end
-    | _ -> 
+    | _ ->
 	atom_of_constr env sigma term
-	
+
 
 (* store all equalities from the context *)
-	
+
 let rec make_prb gls depth additionnal_terms =
   let env=pf_env gls in
   let sigma=sig_sig gls in
@@ -182,8 +182,8 @@ let rec make_prb gls depth additionnal_terms =
     List.iter
       (fun c ->
 	 let t = decompose_term env sigma c in
-	   ignore (add_term state t)) additionnal_terms; 
-    List.iter 
+	   ignore (add_term state t)) additionnal_terms;
+    List.iter
       (fun (id,_,e) ->
 	 begin
 	   let cid=mkVar id in
@@ -191,15 +191,15 @@ let rec make_prb gls depth additionnal_terms =
 	       `Eq (t,a,b) -> add_equality state cid a b
 	     | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b
 	     | `Other ph ->
-		 List.iter 
-		   (fun (cidn,nh) -> 
-		      add_disequality state (HeqnH (cid,cidn)) ph nh) 
+		 List.iter
+		   (fun (cidn,nh) ->
+		      add_disequality state (HeqnH (cid,cidn)) ph nh)
 		   !neg_hyps;
 		 pos_hyps:=(cid,ph):: !pos_hyps
 	     | `Nother nh ->
-		 List.iter 
-		   (fun (cidp,ph) -> 
-		      add_disequality state (HeqnH (cidp,cid)) ph nh) 
+		 List.iter
+		   (fun (cidp,ph) ->
+		      add_disequality state (HeqnH (cidp,cid)) ph nh)
 		   !pos_hyps;
 		 neg_hyps:=(cid,nh):: !neg_hyps
 	     | `Rule patts -> add_quant state id true patts
@@ -208,9 +208,9 @@ let rec make_prb gls depth additionnal_terms =
     begin
       match atom_of_constr env sigma gls.it.evar_concl with
 	  `Eq (t,a,b) -> add_disequality state Goal a b
-	|	`Other g ->  
-		  List.iter 
-	      (fun (idp,ph) -> 
+	|	`Other g ->
+		  List.iter
+	      (fun (idp,ph) ->
 		 add_disequality state (HeqG idp) ph g) !pos_hyps
     end;
     state
@@ -218,28 +218,28 @@ let rec make_prb gls depth additionnal_terms =
 (* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
 
 let build_projection intype outtype (cstr:constructor) special default gls=
-  let env=pf_env gls in 
-  let (h,argv) = 
-    try destApp intype with 
+  let env=pf_env gls in
+  let (h,argv) =
+    try destApp intype with
 	Invalid_argument _ -> (intype,[||])  in
-  let ind=destInd h in 
+  let ind=destInd h in
   let types=Inductiveops.arities_of_constructors env ind in
   let lp=Array.length types in
   let ci=pred (snd cstr) in
   let branch i=
     let ti=Term.prod_appvect types.(i) argv in
-    let rc=fst (Sign.decompose_prod_assum ti) in
+    let rc=fst (decompose_prod_assum ti) in
     let head=
-      if i=ci then special else default in  
-      Sign.it_mkLambda_or_LetIn head rc in
+      if i=ci then special else default in
+      it_mkLambda_or_LetIn head rc in
   let branches=Array.init lp branch in
   let casee=mkRel 1 in
   let pred=mkLambda(Anonymous,intype,outtype) in
   let case_info=make_case_info (pf_env gls) ind RegularStyle in
   let body= mkCase(case_info, pred, casee, branches) in
-  let id=pf_get_new_id (id_of_string "t") gls in     
+  let id=pf_get_new_id (id_of_string "t") gls in
     mkLambda(Name id,intype,body)
-  
+
 (* generate an adhoc tactic following the proof tree  *)
 
 let _M =mkMeta
@@ -247,29 +247,29 @@ let _M =mkMeta
 let rec proof_tac p gls =
   match p.p_rule with
       Ax c -> exact_check c gls
-    | SymAx c -> 
-	let l=constr_of_term p.p_lhs and 
+    | SymAx c ->
+	let l=constr_of_term p.p_lhs and
 	    r=constr_of_term p.p_rhs in
-        let typ = refresh_universes (pf_type_of gls l) in 	  
+        let typ = refresh_universes (pf_type_of gls l) in
 	  exact_check
 	    (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls
     | Refl t ->
 	let lr = constr_of_term t in
-	let typ = refresh_universes (pf_type_of gls lr) in 
+	let typ = refresh_universes (pf_type_of gls lr) in
 	exact_check
 	   (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls
     | 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 = refresh_universes (pf_type_of gls t2) in 
-	let prf = 
+	let typ = refresh_universes (pf_type_of gls t2) in
+	let prf =
 	  mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in
 	  tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls
     | 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 
+	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 = refresh_universes (pf_type_of gls tf1) in
 	let typx = refresh_universes (pf_type_of gls tx1) in
@@ -282,7 +282,7 @@ let rec proof_tac p gls =
 	let lemma2=
 	  mkApp(Lazy.force _f_equal,
 		[|typx;typfx;tf2;tx1;tx2;_M 1|]) in
-	let prf = 
+	let prf =
 	  mkApp(Lazy.force _trans_eq,
 		[|typfx;
 		  mkApp(tf1,[|tx1|]);
@@ -294,8 +294,8 @@ let rec proof_tac p gls =
 	       [tclTHEN (refine lemma2) (proof_tac p2);
 		reflexivity;
 		fun gls ->
-		  errorlabstrm  "Congruence" 
-		    (Pp.str 
+		  errorlabstrm  "Congruence"
+		    (Pp.str
 		       "I don't know how to handle dependent equality")]] gls
   | Inject (prf,cstr,nargs,argind) ->
 	 let ti=constr_of_term prf.p_lhs in
@@ -306,10 +306,10 @@ let rec proof_tac p gls =
 	 let special=mkRel (1+nargs-argind) in
 	 let proj=build_projection intype outtype cstr special default gls in
 	 let injt=
-	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in 
+	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in
 	   tclTHEN (refine injt) (proof_tac prf) gls
 
-let refute_tac c t1 t2 p gls =      
+let refute_tac c t1 t2 p gls =
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
   let intype=refresh_universes (pf_type_of gls tt1) in
   let neweq=
@@ -323,13 +323,13 @@ let refute_tac c t1 t2 p gls =
 let convert_to_goal_tac c t1 t2 p gls =
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
   let sort=refresh_universes (pf_type_of gls tt2) in
-  let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in 
+  let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in
   let e=pf_get_new_id (id_of_string "e") gls in
   let x=pf_get_new_id (id_of_string "X") gls in
-  let identity=mkLambda (Name x,sort,mkRel 1) in 
+  let identity=mkLambda (Name x,sort,mkRel 1) in
   let endt=mkApp (Lazy.force _eq_rect,
 		  [|sort;tt1;identity;c;tt2;mkVar e|]) in
-    tclTHENS (assert_tac (Name e) neweq) 
+    tclTHENS (assert_tac (Name e) neweq)
       [proof_tac p;exact_check endt] gls
 
 let convert_to_hyp_tac c1 t1 c2 t2 p gls =
@@ -339,7 +339,7 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls =
     tclTHENS (assert_tac (Name h) tt2)
       [convert_to_goal_tac c1 t1 t2 p;
        simplest_elim false_t] gls
-  
+
 let discriminate_tac cstr p gls =
   let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
   let intype=refresh_universes (pf_type_of gls t1) in
@@ -351,25 +351,25 @@ let discriminate_tac cstr p gls =
   let trivial=pf_type_of gls identity in
   let outtype=mkType (new_univ ()) in
   let pred=mkLambda(Name xid,outtype,mkRel 1) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in     
+  let hid=pf_get_new_id (id_of_string "Heq") gls in
   let proj=build_projection intype outtype cstr trivial concl gls in
   let injt=mkApp (Lazy.force _f_equal,
-		  [|intype;outtype;proj;t1;t2;mkVar hid|]) in   
+		  [|intype;outtype;proj;t1;t2;mkVar hid|]) in
   let endt=mkApp (Lazy.force _eq_rect,
 		  [|outtype;trivial;pred;identity;concl;injt|]) in
   let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in
-    tclTHENS (assert_tac (Name hid) neweq) 
+    tclTHENS (assert_tac (Name hid) neweq)
       [proof_tac p;exact_check endt] gls
-      
+
 (* wrap everything *)
-	
+
 let build_term_to_complete uf meta pac =
   let cinfo = get_constructor_info uf pac.cnode in
   let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
   let dummy_args = List.rev (list_tabulate meta pac.arity) in
   let all_args = List.rev_append real_args dummy_args in
     applistc (mkConstruct cinfo.ci_constr) all_args
-      
+
 let cc_tactic depth additionnal_terms gls=
   Coqlib.check_required_library ["Coq";"Init";"Logic"];
   let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
@@ -379,7 +379,7 @@ let cc_tactic depth additionnal_terms gls=
   let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
   let uf=forest state in
     match sol with
-	None -> tclFAIL 0 (str "congruence failed") gls  
+	None -> tclFAIL 0 (str "congruence failed") gls
       | Some reason ->
 	  debug Pp.msgnl (Pp.str "Goal solved, generating proof ...");
 	  match reason with
@@ -390,22 +390,22 @@ let cc_tactic depth additionnal_terms gls=
 	    | Incomplete ->
 		let metacnt = ref 0 in
 		let newmeta _ = incr metacnt; _M !metacnt in
-		let terms_to_complete = 
-		  List.map 
-		    (build_term_to_complete uf newmeta) 
-		    (epsilons uf) in 
+		let terms_to_complete =
+		  List.map
+		    (build_term_to_complete uf newmeta)
+		    (epsilons uf) in
 		  Pp.msgnl
 		    (Pp.str "Goal is solvable by congruence but \
  some arguments are missing.");
 		  Pp.msgnl
 		    (Pp.str "  Try " ++
 		     hov 8
-		       begin 
-			 str "\"congruence with (" ++  
-			 prlist_with_sep 
+		       begin
+			 str "\"congruence with (" ++
+			 prlist_with_sep
 			   (fun () -> str ")" ++ pr_spc () ++ str "(")
 			   (print_constr_env (pf_env gls))
-			   terms_to_complete ++ 
+			   terms_to_complete ++
 			 str ")\","
 		       end);
 		  Pp.msgnl
@@ -417,18 +417,18 @@ let cc_tactic depth additionnal_terms gls=
 		  match dis.rule with
 		      Goal -> proof_tac p gls
 		    | Hyp id -> refute_tac id ta tb p gls
-		    | HeqG id -> 
+		    | HeqG id ->
 			convert_to_goal_tac id ta tb p gls
-		    | HeqnH (ida,idb) -> 
+		    | HeqnH (ida,idb) ->
 			convert_to_hyp_tac ida ta idb tb p gls
-		    
+
 
 let cc_fail gls =
-  errorlabstrm  "Congruence" (Pp.str "congruence failed.")     
+  errorlabstrm  "Congruence" (Pp.str "congruence failed.")
 
-let congruence_tac depth l = 
-  tclORELSE 
-    (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) 
+let congruence_tac depth l =
+  tclORELSE
+    (tclTHEN (tclREPEAT introf) (cc_tactic depth l))
     cc_fail
 
 (* Beware: reflexivity = constructor 1 = apply refl_equal
@@ -441,22 +441,22 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal)
 
    It mimics the use of lemmas [f_equal], [f_equal2], etc.
    This isn't particularly related with congruence, apart from
-   the fact that congruence is called internally. 
+   the fact that congruence is called internally.
 *)
 
-let f_equal gl = 
-  let cut_eq c1 c2 = 
-    let ty = refresh_universes (pf_type_of gl c1) in 
+let f_equal gl =
+  let cut_eq c1 c2 =
+    let ty = refresh_universes (pf_type_of gl c1) in
     tclTHENTRY
       (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|])))
       (simple_reflexivity ())
-  in 
-  try match kind_of_term (pf_concl gl) with 
-    | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> 
-	begin match kind_of_term t, kind_of_term t' with 
+  in
+  try match kind_of_term (pf_concl gl) with
+    | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) ->
+	begin match kind_of_term t, kind_of_term t' with
 	  | App (f,v), App (f',v') when Array.length v = Array.length v' ->
-	      let rec cuts i = 
-		if i < 0 then tclTRY (congruence_tac 1000 []) 
+	      let rec cuts i =
+		if i < 0 then tclTRY (congruence_tac 1000 [])
 		else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
 	      in cuts (Array.length v - 1) gl
 	  | _ -> tclIDTAC gl
diff --git a/contrib/cc/cctac.mli b/plugins/cc/cctac.mli
index 57ad0558..7ed077bd 100644
--- a/contrib/cc/cctac.mli
+++ b/plugins/cc/cctac.mli
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cctac.mli 10637 2008-03-07 23:52:56Z letouzey $ *)
+(* $Id$ *)
 
-open Term 
+open Term
 open Proof_type
 
 val proof_tac: Ccproof.proof -> Proof_type.tactic
diff --git a/contrib/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 9877e6fc..d9db927a 100644
--- a/contrib/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -8,19 +8,19 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_congruence.ml4 10637 2008-03-07 23:52:56Z letouzey $ *)
+(* $Id$ *)
 
 open Cctac
 open Tactics
 open Tacticals
 
 (* Tactic registration *)
-      
+
 TACTIC EXTEND cc
  [ "congruence" ] -> [ congruence_tac 1000 [] ]
  |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
  |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ]
- |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> 
+ |[ "congruence" integer(n) "with" ne_constr_list(l) ] ->
    [ congruence_tac n l ]
 END
 
diff --git a/contrib/dp/Dp.v b/plugins/dp/Dp.v
index 857c182c..bc7d73f6 100644
--- a/contrib/dp/Dp.v
+++ b/plugins/dp/Dp.v
@@ -6,7 +6,7 @@ Require Export Classical.
 (* Zenon *)
 
 (*  Copyright 2004 INRIA  *)
-(*  $Id: Dp.v 10739 2008-04-01 14:45:20Z herbelin $  *)
+(*  $Id$  *)
 
 Lemma zenon_nottrue :
   (~True -> False).
@@ -103,14 +103,14 @@ Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
 Set Implicit Arguments.
 Section congr.
   Variable t:Type.
-Lemma ergo_eq_concat_1 : 
+Lemma ergo_eq_concat_1 :
   forall (P:t -> Prop) (x y:t),
     P x -> x = y -> P y.
 Proof.
   intros; subst; auto.
 Qed.
 
-Lemma ergo_eq_concat_2 : 
+Lemma ergo_eq_concat_2 :
   forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
     P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
 Proof.
diff --git a/contrib/dp/TODO b/plugins/dp/TODO
index 44349e21..44349e21 100644
--- a/contrib/dp/TODO
+++ b/plugins/dp/TODO
diff --git a/contrib/dp/dp.ml b/plugins/dp/dp.ml
index d8803847..34b32c0a 100644
--- a/contrib/dp/dp.ml
+++ b/plugins/dp/dp.ml
@@ -1,7 +1,7 @@
 (* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *)
 (* Tactics to call decision procedures *)
 
-(* Works in two steps: 
+(* Works in two steps:
 
    - first the Coq context and the current goal are translated in
      Polymorphic First-Order Logic (see fol.mli in this directory)
@@ -22,6 +22,7 @@ open Tacticals
 open Fol
 open Names
 open Nameops
+open Namegen
 open Termops
 open Coqlib
 open Hipattern
@@ -36,41 +37,44 @@ let set_trace b = trace := b
 let timeout = ref 10
 let set_timeout n = timeout := n
 
-let (dp_timeout_obj,_) = 
-  declare_object 
-    {(default_object "Dp_timeout") with  
+let (dp_timeout_obj,_) =
+  declare_object
+    {(default_object "Dp_timeout") with
        cache_function = (fun (_,x) -> set_timeout x);
-       load_function = (fun _ (_,x) -> set_timeout x);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,x) -> set_timeout x)}
 
 let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x)
 
-let (dp_debug_obj,_) = 
-  declare_object 
-    {(default_object "Dp_debug") with  
+let (dp_debug_obj,_) =
+  declare_object
+    {(default_object "Dp_debug") with
        cache_function = (fun (_,x) -> set_debug x);
-       load_function = (fun _ (_,x) -> set_debug x);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,x) -> set_debug x)}
 
 let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x)
 
-let (dp_trace_obj,_) = 
-  declare_object 
-    {(default_object "Dp_trace") with  
+let (dp_trace_obj,_) =
+  declare_object
+    {(default_object "Dp_trace") with
        cache_function = (fun (_,x) -> set_trace x);
-       load_function = (fun _ (_,x) -> set_trace x);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,x) -> set_trace x)}
 
 let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x)
 
 let logic_dir = ["Coq";"Logic";"Decidable"]
 let coq_modules =
   init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
-    @ [["Coq"; "ZArith"; "BinInt"]]
+    @ [["Coq"; "ZArith"; "BinInt"];
+       ["Coq"; "Reals"; "Rdefinitions"];
+       ["Coq"; "Reals"; "Raxioms";];
+       ["Coq"; "Reals"; "Rbasic_fun";];
+       ["Coq"; "Reals"; "R_sqrt";];
+       ["Coq"; "Reals"; "Rfunctions";]]
     @ [["Coq"; "omega"; "OmegaLemmas"]]
 
 let constant = gen_constant_in_modules "dp" coq_modules
 
+(* integers constants and operations *)
 let coq_Z = lazy (constant "Z")
 let coq_Zplus = lazy (constant "Zplus")
 let coq_Zmult = lazy (constant "Zmult")
@@ -90,6 +94,21 @@ let coq_xI = lazy (constant "xI")
 let coq_xO = lazy (constant "xO")
 let coq_iff = lazy (constant "iff")
 
+(* real constants and operations *)
+let coq_R = lazy (constant "R")
+let coq_R0 = lazy (constant "R0")
+let coq_R1 = lazy (constant "R1")
+let coq_Rgt = lazy (constant "Rgt")
+let coq_Rle = lazy (constant "Rle")
+let coq_Rge = lazy (constant "Rge")
+let coq_Rlt = lazy (constant "Rlt")
+let coq_Rplus = lazy (constant "Rplus")
+let coq_Rmult = lazy (constant "Rmult")
+let coq_Ropp = lazy (constant "Ropp")
+let coq_Rminus = lazy (constant "Rminus")
+let coq_Rdiv = lazy (constant "Rdiv")
+let coq_powerRZ = lazy (constant "powerRZ")
+
 (* not Prop typed expressions *)
 exception NotProp
 
@@ -102,36 +121,36 @@ let global_names = Hashtbl.create 97
 let used_names = Hashtbl.create 97
 
 let rename_global r =
-  try 
+  try
     Hashtbl.find global_names r
   with Not_found ->
-    let rec loop id = 
-      if Hashtbl.mem used_names id then 
-	loop (lift_ident id)
-      else begin 
+    let rec loop id =
+      if Hashtbl.mem used_names id then
+	loop (lift_subscript id)
+      else begin
 	Hashtbl.add used_names id ();
 	let s = string_of_id id in
-	Hashtbl.add global_names r s; 
+	Hashtbl.add global_names r s;
 	s
       end
     in
-    loop (Nametab.id_of_global r)
+    loop (Nametab.basename_of_global r)
 
 let foralls =
-  List.fold_right 
+  List.fold_right
     (fun (x,t) p -> Forall (x, t, p))
 
 let fresh_var = function
   | Anonymous -> rename_global (VarRef (id_of_string "x"))
   | Name x -> rename_global (VarRef x)
 
-(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of 
-   env names, and returns the new variables together with the new 
+(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of
+   env names, and returns the new variables together with the new
    environment *)
 let coq_rename_vars env vars =
   let avoid = ref (ids_of_named_context (Environ.named_context env)) in
   List.fold_right
-    (fun (na,t) (newvars, newenv) -> 
+    (fun (na,t) (newvars, newenv) ->
        let id = next_name_away na !avoid in
        avoid := id :: !avoid;
        id :: newvars, Environ.push_named (id, None, t) newenv)
@@ -141,9 +160,9 @@ let coq_rename_vars env vars =
    type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *)
 let decomp_type_quantifiers env t =
   let rec loop vars t = match kind_of_term t with
-    | Prod (n, a, t) when is_Set a || is_Type a -> 
+    | Prod (n, a, t) when is_Set a || is_Type a ->
 	loop ((n,a) :: vars) t
-    | _ -> 
+    | _ ->
 	let vars, env = coq_rename_vars env vars in
 	let t = substl (List.map mkVar vars) t in
 	List.rev vars, env, t
@@ -153,21 +172,21 @@ let decomp_type_quantifiers env t =
 (* same thing with lambda binders (for axiomatize body) *)
 let decomp_type_lambdas env t =
   let rec loop vars t = match kind_of_term t with
-    | Lambda (n, a, t) when is_Set a || is_Type a -> 
+    | Lambda (n, a, t) when is_Set a || is_Type a ->
 	loop ((n,a) :: vars) t
-    | _ -> 
+    | _ ->
 	let vars, env = coq_rename_vars env vars in
 	let t = substl (List.map mkVar vars) t in
 	List.rev vars, env, t
   in
   loop [] t
 
-let decompose_arrows = 
+let decompose_arrows =
   let rec arrows_rec l c = match kind_of_term c with
     | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c
     | Cast (c,_,_) -> arrows_rec l c
     | _ -> List.rev l, c
-  in 
+  in
   arrows_rec []
 
 let rec eta_expanse t vars env i =
@@ -182,7 +201,7 @@ let rec eta_expanse t vars env i =
 	  let env' = Environ.push_named (id, None, a) env in
 	  let t' = mkApp (t, [| mkVar id |]) in
 	  eta_expanse t' (id :: vars) env' (pred i)
-      | _ -> 
+      | _ ->
 	  assert false
 
 let rec skip_k_args k cl = match k, cl with
@@ -201,11 +220,9 @@ let globals_stack = ref []
 let () =
   Summary.declare_summary "Dp globals"
     { Summary.freeze_function = (fun () -> !globals, !globals_stack);
-      Summary.unfreeze_function = 
+      Summary.unfreeze_function =
 	(fun (g,s) -> globals := g; globals_stack := s);
-      Summary.init_function = (fun () -> ());
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = (fun () -> ()) }
 
 let add_global r d = globals := Refmap.add r d !globals
 let mem_global r = Refmap.mem r !globals
@@ -219,7 +236,7 @@ let lookup_local r =  match Hashtbl.find locals r with
   | Gnot_fo -> raise NotFO
   | Gfo d -> d
 
-let iter_all_constructors i f =  
+let iter_all_constructors i f =
   let _, oib = Global.lookup_inductive i in
   Array.iteri
     (fun j tj -> f j (mkConstruct (i, j+1)))
@@ -227,7 +244,7 @@ let iter_all_constructors i f =
 
 
 (* injection c [t1,...,tn] adds the injection axiom
-     forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. 
+     forall x1:t1,...,xn:tn,y1:t1,...,yn:tn.
        c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *)
 
 let injection c l =
@@ -236,8 +253,8 @@ let injection c l =
   let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in
   i := 0;
   let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in
-  let f = 
-    List.fold_right2 
+  let f =
+    List.fold_right2
       (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p))
       xl yl True
   in
@@ -248,14 +265,14 @@ let injection c l =
   let ax = Axiom ("injection_" ^ c, f) in
   globals_stack := ax :: !globals_stack
 
-(* rec_names_for c [|n1;...;nk|] builds the list of constant names for 
+(* rec_names_for c [|n1;...;nk|] builds the list of constant names for
    identifiers n1...nk with the same path as c, if they exist; otherwise
    raises Not_found *)
 let rec_names_for c =
   let mp,dp,_ = Names.repr_con c in
   array_map_to_list
-    (function 
-       | Name id -> 
+    (function
+       | Name id ->
 	   let c' = Names.make_con mp dp (label_of_id id) in
 	   ignore (Global.lookup_constant c');
 	   msgnl (Printer.pr_constr (mkConst c'));
@@ -267,7 +284,7 @@ let rec_names_for c =
 
 let term_abstractions = Hashtbl.create 97
 
-let new_abstraction = 
+let new_abstraction =
   let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r
 
 (* Arithmetic constants *)
@@ -275,37 +292,87 @@ let new_abstraction =
 exception NotArithConstant
 
 (* translates a closed Coq term p:positive into a FOL term of type int *)
+
+let big_two = Big_int.succ_big_int Big_int.unit_big_int
+
 let rec tr_positive p = match kind_of_term p with
   | Term.Construct _ when p = Lazy.force coq_xH ->
-      Cst 1
+      Big_int.unit_big_int
   | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+(*
       Plus (Mult (Cst 2, tr_positive a), Cst 1)
+*)
+      Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a))
   | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+(*
       Mult (Cst 2, tr_positive a)
+*)
+      Big_int.mult_big_int big_two (tr_positive a)
   | Term.Cast (p, _, _) ->
       tr_positive p
   | _ ->
       raise NotArithConstant
 
-(* translates a closed Coq term t:Z into a FOL term of type int *)
+(* translates a closed Coq term t:Z or R into a FOL term of type int or real *)
 let rec tr_arith_constant t = match kind_of_term t with
   | Term.Construct _ when t = Lazy.force coq_Z0 ->
-      Cst 0
+      Cst Big_int.zero_big_int
   | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos ->
-      tr_positive a
+      Cst (tr_positive a)
   | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
-      Moins (Cst 0, tr_positive a)
+      Cst (Big_int.minus_big_int (tr_positive a))
+  | Term.Const _ when t = Lazy.force coq_R0 ->
+      RCst Big_int.zero_big_int
+  | Term.Const _ when t = Lazy.force coq_R1 ->
+      RCst Big_int.unit_big_int
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
+      let ta = tr_arith_constant a in
+      let tb = tr_arith_constant b in
+      begin match ta,tb with
+        | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb)
+        | _ -> raise NotArithConstant
+      end
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
+      let ta = tr_arith_constant a in
+      let tb = tr_arith_constant b in
+      begin match ta,tb with
+        | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb)
+        | _ -> raise NotArithConstant
+      end
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ ->
+      tr_powerRZ a b
   | Term.Cast (t, _, _) ->
       tr_arith_constant t
-  | _ -> 
+  | _ ->
       raise NotArithConstant
 
+(* translates a constant of the form (powerRZ 2 int_constant) *)
+and tr_powerRZ a b =
+  (* checking first that a is (R1 + R1) *)
+  match kind_of_term a with
+  | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus ->
+      begin
+      match kind_of_term c,kind_of_term d with
+        | Term.Const _, Term.Const _
+            when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 ->
+            begin
+              match tr_arith_constant b with
+                | Cst n -> Power2 n
+                | _ -> raise NotArithConstant
+            end
+        | _ -> raise NotArithConstant
+      end
+  | _ -> raise NotArithConstant
+
+
 (* translate a Coq term t:Set into a FOL type expression;
    tv = list of type variables *)
 and tr_type tv env t =
   let t = Reductionops.nf_betadeltaiota env Evd.empty t in
-  if t = Lazy.force coq_Z then 
+  if t = Lazy.force coq_Z then
     Tid ("int", [])
+  else if t = Lazy.force coq_R then
+    Tid ("real", [])
   else match kind_of_term t with
     | Var x when List.mem x tv ->
 	Tvar (string_of_id x)
@@ -314,15 +381,15 @@ and tr_type tv env t =
 	begin try
 	  let r = global_of_constr f in
 	  match tr_global env r with
-	    | DeclType (id, k) -> 
+	    | DeclType (id, k) ->
 		assert (k = List.length cl); (* since t:Set *)
 		Tid (id, List.map (tr_type tv env) cl)
-	    | _ -> 
+	    | _ ->
 		raise NotFO
-	with 
+	with
 	  | Not_found ->
 	      raise NotFO
-	  | NotFO -> 
+	  | NotFO ->
 	      (* we need to abstract some part of (f cl) *)
 	      (*TODO*)
 	      raise NotFO
@@ -332,7 +399,10 @@ and make_term_abstraction tv env c =
   let ty = Typing.type_of env Evd.empty c in
   let id = new_abstraction () in
   match tr_decl env id ty with
-    | DeclFun (id,_,_,_) as d ->
+    | DeclFun (id,_,_,_) as _d ->
+        raise NotFO
+        (* [CM 07/09/2009] deactivated because it generates
+           unbound identifiers 'abstraction_<number>'
 	begin try
 	  Hashtbl.find term_abstractions c
 	with Not_found ->
@@ -340,6 +410,7 @@ and make_term_abstraction tv env c =
 	  globals_stack := d :: !globals_stack;
 	  id
 	end
+        *)
     | _ ->
 	raise NotFO
 
@@ -355,7 +426,7 @@ and tr_decl env id ty =
     DeclType (id, List.length tv)
   else if is_Prop t then
     DeclPred (id, List.length tv, [])
-  else 
+  else
     let s = Typing.type_of env Evd.empty t in
     if is_Prop s then
       Axiom (id, tr_formula tv [] env t)
@@ -364,11 +435,11 @@ and tr_decl env id ty =
       let l = List.map (tr_type tv env) l in
       if is_Prop t then
 	DeclPred(id, List.length tv, l)
-      else 
+      else
 	let s = Typing.type_of env Evd.empty t in
-	if is_Set s || is_Type s then 
+	if is_Set s || is_Type s then
 	  DeclFun (id, List.length tv, l, tr_type tv env t)
-	else 
+	else
 	  raise NotFO
 
 (* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *)
@@ -384,7 +455,7 @@ and tr_global env r = match r with
 	  let id = rename_global r in
 	  let d = tr_decl env id ty in
 	  (* r can be already declared if it is a constructor *)
-	  if not (mem_global r) then begin 
+	  if not (mem_global r) then begin
 	    add_global r (Gfo d);
 	    globals_stack := d :: !globals_stack
 	  end;
@@ -395,7 +466,7 @@ and tr_global env r = match r with
 	  raise NotFO
 
 and axiomatize_body env r id d = match r with
-  | VarRef _ -> 
+  | VarRef _ ->
       assert false
   | ConstRef c ->
       begin match (Global.lookup_constant c).const_body with
@@ -415,7 +486,7 @@ and axiomatize_body env r id d = match r with
 		     (*Format.eprintf "axiomatize_body %S@." id;*)
 		     let b = match kind_of_term b with
 		       (* a single recursive function *)
-		       | Fix (_, (_,_,[|b|])) -> 
+		       | Fix (_, (_,_,[|b|])) ->
 			   subst1 (mkConst c) b
                        (* mutually recursive functions *)
 		       | Fix ((_,i), (names,_,bodies)) ->
@@ -426,7 +497,7 @@ and axiomatize_body env r id d = match r with
 			   with Not_found ->
 			     b
 			   end
-		       | _ -> 
+		       | _ ->
 			   b
 		     in
 		     let tv, env, b = decomp_type_lambdas env b in
@@ -448,9 +519,9 @@ and axiomatize_body env r id d = match r with
 			   begin match kind_of_term t with
 			     | Case (ci, _, e, br) ->
 				 equations_for_case env id vars tv bv ci e br
-			     | _ -> 
+			     | _ ->
 				 let t = tr_term tv bv env t in
-				 let ax = 
+				 let ax =
 				   add_proof (Fun_def (id, vars, ty, t))
 				 in
 				 let p = Fatom (Eq (App (id, fol_vars), t)) in
@@ -469,7 +540,7 @@ and axiomatize_body env r id d = match r with
 	    in
 	    let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in
 	    globals_stack := axioms @ !globals_stack
-	| None -> 
+	| None ->
 	    () (* Coq axiom *)
       end
   | IndRef i ->
@@ -524,12 +595,12 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
 		     | (y, t)::l' -> if y = string_of_id e then l'
 		       else (y, t)::(remove l' e) in
 		   let vars = remove vars x in
-		   let p = 
-		     Fatom (Eq (App (id, fol_vars), 
+		   let p =
+		     Fatom (Eq (App (id, fol_vars),
 				tr_term tv bv env b))
 		   in
 		   eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs
-	       | _ -> 
+	       | _ ->
 		   assert false end
 	   with NotFO ->
 	     ());
@@ -538,31 +609,44 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
       raise NotFO
 
 (* assumption: t:T:Set *)
-and tr_term tv bv env t = match kind_of_term t with
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> 
+and tr_term tv bv env t =
+      try
+	tr_arith_constant t
+      with NotArithConstant ->
+  match kind_of_term t with
+    (* binary operations on integers *)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus ->
+      Plus (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus ->
+      Moins (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult ->
+      Mult (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv ->
+      Div (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp ->
+      Opp (tr_term tv bv env a)
+    (* binary operations on reals *)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
       Plus (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> 
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus ->
       Moins (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> 
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
       Mult (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> 
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv ->
       Div (tr_term tv bv env a, tr_term tv bv env b)
   | Term.Var id when List.mem id bv ->
       App (string_of_id id, [])
   | _ ->
-      try
-	tr_arith_constant t
-      with NotArithConstant ->
 	let f, cl = decompose_app t in
 	begin try
 	  let r = global_of_constr f in
 	  match tr_global env r with
-	    | DeclFun (s, k, _, _) -> 
+	    | DeclFun (s, k, _, _) ->
 		let cl = skip_k_args k cl in
 		Fol.App (s, List.map (tr_term tv bv env) cl)
-	    | _ -> 
+	    | _ ->
 		raise NotFO
-	with 
+	with
 	  | Not_found ->
 	      raise NotFO
 	  | NotFO -> (* we need to abstract some part of (f cl) *)
@@ -577,7 +661,7 @@ and tr_term tv bv env t = match kind_of_term t with
 		      abstract (applist (app, [x])) l
 		    end
 	      in
-	      let app,l = match cl with 
+	      let app,l = match cl with
 		| x :: l -> applist (f, [x]), l | [] -> raise NotFO
 	      in
 	      abstract app l
@@ -595,15 +679,16 @@ and quantifiers n a b tv bv env =
 and tr_formula tv bv env f =
   let c, args = decompose_app f in
   match kind_of_term c, args with
-    | Var id, [] -> 
+    | Var id, [] ->
 	Fatom (Pred (rename_global (VarRef id), []))
     | _, [t;a;b] when c = build_coq_eq () ->
 	let ty = Typing.type_of env Evd.empty t in
 	if is_Set ty || is_Type ty then
 	  let _ = tr_type tv env t in
 	  Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b))
-	else 
+	else
 	  raise NotFO
+          (* comparisons on integers *)
     | _, [a;b] when c = Lazy.force coq_Zle ->
 	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
     | _, [a;b] when c = Lazy.force coq_Zlt ->
@@ -612,6 +697,15 @@ and tr_formula tv bv env f =
 	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
     | _, [a;b] when c = Lazy.force coq_Zgt ->
 	Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
+          (* comparisons on reals *)
+    | _, [a;b] when c = Lazy.force coq_Rle ->
+	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Rlt ->
+	Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Rge ->
+	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Rgt ->
+	Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
     | _, [] when c = build_coq_False () ->
 	False
     | _, [] when c = build_coq_True () ->
@@ -635,7 +729,7 @@ and tr_formula tv bv env f =
 	  | Lambda(n, a, b) ->
 	      let id, t, bv, env, b = quantifiers n a b tv bv env in
 	      Exists (string_of_id id, t, tr_formula tv bv env b)
-	  | _ -> 
+	  | _ ->
 	      (* unusual case of the shape (ex p) *)
 	      raise NotFO (* TODO: we could eta-expanse *)
 	end
@@ -643,10 +737,10 @@ and tr_formula tv bv env f =
 	begin try
 	  let r = global_of_constr c in
 	  match tr_global env r with
-	    | DeclPred (s, k, _) -> 
+	    | DeclPred (s, k, _) ->
 		let args = skip_k_args k args in
 		Fatom (Pred (s, List.map (tr_term tv bv env) args))
-	    | _ -> 
+	    | _ ->
 		raise NotFO
 	with Not_found ->
 	  raise NotFO
@@ -655,7 +749,7 @@ and tr_formula tv bv env f =
 
 let tr_goal gl =
   Hashtbl.clear locals;
-  let tr_one_hyp (id, ty) = 
+  let tr_one_hyp (id, ty) =
     try
       let s = rename_global (VarRef id) in
       let d = tr_decl (pf_env gl) s ty in
@@ -666,7 +760,7 @@ let tr_goal gl =
       raise NotFO
   in
   let hyps =
-    List.fold_right 
+    List.fold_right
       (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc)
       (pf_hyps_types gl) []
   in
@@ -675,7 +769,7 @@ let tr_goal gl =
   hyps, c
 
 
-type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy
+type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy | CVC3 | Z3
 
 let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
 
@@ -685,9 +779,9 @@ let file_contents f =
   let buf = Buffer.create 1024 in
   try
     let c = open_in f in
-    begin try 
-      while true do 
-	let s = input_line c in Buffer.add_string buf s; 
+    begin try
+      while true do
+	let s = input_line c in Buffer.add_string buf s;
 	Buffer.add_char buf '\n'
       done;
       assert false
@@ -695,7 +789,7 @@ let file_contents f =
       close_in c;
       Buffer.contents buf
     end
-  with _ -> 
+  with _ ->
     sprintf "(cannot open %s)" f
 
 let timeout_sys_command cmd =
@@ -703,46 +797,62 @@ let timeout_sys_command cmd =
   let out = Filename.temp_file "out" "" in
   let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in
   let ret = Sys.command cmd in
-  if !debug then 
+  if !debug then
     Format.eprintf "Output file %s:@.%s@." out (file_contents out);
   ret, out
 
 let timeout_or_failure c cmd out =
-  if c = 152 then 
-    Timeout 
+  if c = 152 then
+    Timeout
   else
-    Failure 
+    Failure
       (sprintf "command %s failed with output:\n%s " cmd (file_contents out))
 
+let call_prover ?(opt="") file =
+  if !debug then Format.eprintf "calling prover on %s@." file;
+  let out = Filename.temp_file "out" "" in
+  let cmd =
+    sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in
+  match Sys.command cmd with
+      0 -> Valid None
+    | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out))
+    | 2 -> Invalid
+    | 3 -> DontKnow
+    | 4 -> Timeout
+    | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out))
+    | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n)
+
 let prelude_files = ref ([] : string list)
 
 let set_prelude l = prelude_files := l
 
-let (dp_prelude_obj,_) = 
-  declare_object 
-    {(default_object "Dp_prelude") with  
+let (dp_prelude_obj,_) =
+  declare_object
+    {(default_object "Dp_prelude") with
        cache_function = (fun (_,x) -> set_prelude x);
-       load_function = (fun _ (_,x) -> set_prelude x);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,x) -> set_prelude x)}
 
 let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x)
 
 let why_files f = String.concat " " (!prelude_files @ [f])
 
 let call_simplify fwhy =
-  let cmd = 
+  let cmd =
     sprintf "why --simplify %s" (why_files fwhy)
   in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in
-  let cmd = 
+(*
+  let cmd =
     sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out"
       !timeout fsx
   in
   let out = Sys.command cmd in
-  let r = 
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout 
+  let r =
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
   in
+*)
+  let r = call_prover fsx in
   if not !debug then remove_files [fwhy; fsx];
   r
 
@@ -750,42 +860,34 @@ let call_ergo fwhy =
   let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in
-  let ftrace = Filename.temp_file "ergo_trace" "" in
-  let cmd = 
+  (*let ftrace = Filename.temp_file "ergo_trace" "" in*)
+  (*NB: why-dp can't handle -cctrace
+  let cmd =
     if !trace then
-      sprintf "ergo -cctrace %s %s" ftrace fwhy
-    else
-      sprintf "ergo %s" fwhy
-  in
-  let ret,out = timeout_sys_command cmd in
-  let r = 
-    if ret <> 0 then 
-      timeout_or_failure ret cmd out
-    else if Sys.command (sprintf "grep -q -w Valid %s" out) = 0 then
-      Valid (if !trace then Some ftrace else None)
-    else if Sys.command (sprintf "grep -q -w \"I don't know\" %s" out) = 0 then
-      DontKnow
-    else if Sys.command (sprintf "grep -q -w \"Invalid\" %s" out) = 0 then
-      Invalid
+      sprintf "alt-ergo -cctrace %s %s" ftrace fwhy
+
     else
-      Failure ("command failed: " ^ cmd)
-  in
-  if not !debug then remove_files [fwhy; out];
+      sprintf "alt-ergo %s" fwhy
+  in*)
+  let r = call_prover fwhy in
+  if not !debug then remove_files [fwhy; (*out*)];
   r
 
+
 let call_zenon fwhy =
-  let cmd = 
-    sprintf "why --no-prelude --no-zenon-prelude --zenon %s" (why_files fwhy)
+  let cmd =
+    sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy)
   in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
+(*  why-dp won't let us having coqterm...
   let out = Filename.temp_file "dp_out" "" in
-  let cmd = 
-    sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out 
+  let cmd =
+    sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out
   in
   let c = Sys.command cmd in
   if not !debug then remove_files [fwhy; fznn];
-  if c = 137 then 
+  if c = 137 then
     Timeout
   else begin
     if c <> 0 then anomaly ("command failed: " ^ cmd);
@@ -794,65 +896,106 @@ let call_zenon fwhy =
     let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in
     if c = 0 then Valid (Some out) else Invalid
   end
+ *)
+   let r = call_prover fznn in
+   if not !debug then remove_files [fwhy; fznn];
+   r
 
-let call_yices fwhy =
+let call_smt ~smt fwhy =
   let cmd = 
     sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
   in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
-  let cmd = 
+  let opt = "-smt-solver " ^ smt in
+  let r = call_prover ~opt fsmt in
+  if not !debug then remove_files [fwhy; fsmt];
+  r
+
+(*
+let call_yices fwhy =
+  let cmd =
+    sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
+  in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
+  let cmd =
     sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out"
       !timeout fsmt
   in
   let out = Sys.command cmd in
-  let r = 
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout 
+  let r =
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
   in
   if not !debug then remove_files [fwhy; fsmt];
   r
 
+let call_cvc3 fwhy =
+  let cmd =
+    sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
+  in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
+  let cmd =
+    sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out"
+      !timeout fsmt
+  in
+  let out = Sys.command cmd in
+  let r =
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
+  in
+  if not !debug then remove_files [fwhy; fsmt];
+  r
+*)
+
 let call_cvcl fwhy =
-  let cmd = 
+  let cmd =
     sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy)
   in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in
-  let cmd = 
-    sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" 
+(*
+  let cmd =
+    sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out"
       !timeout fcvc
   in
   let out = Sys.command cmd in
-  let r = 
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout 
+  let r =
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
   in
+*)
+  let r = call_prover fcvc in
   if not !debug then remove_files [fwhy; fcvc];
   r
 
 let call_harvey fwhy =
-  let cmd = 
+  let cmd =
     sprintf "why --harvey --encoding strat %s" (why_files fwhy)
   in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in
+(*
   let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in
   if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
   let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
   let outf = Filename.temp_file "rv" ".out" in
-  let out = 
-    Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" 
-		   !timeout f outf) 
+  let out =
+    Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1"
+		   !timeout f outf)
   in
   let r =
-    if out <> 0 then 
+    if out <> 0 then
       Timeout
     else
-      let cmd = 
+      let cmd =
 	sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
       in
       if Sys.command cmd = 0 then Valid None else Invalid
   in
   if not !debug then remove_files [fwhy; frv; outf];
+*)
+  let r = call_prover frv in
+  if not !debug then remove_files [fwhy; frv];
   r
 
 let call_gwhy fwhy =
@@ -880,17 +1023,19 @@ let call_prover prover q =
   match prover with
     | Simplify -> call_simplify fwhy
     | Ergo -> call_ergo fwhy
-    | Yices -> call_yices fwhy
+    | CVC3 -> call_smt ~smt:"cvc3" fwhy
+    | Yices -> call_smt ~smt:"yices" fwhy
+    | Z3 -> call_smt ~smt:"z3" fwhy
     | Zenon -> call_zenon fwhy
     | CVCLite -> call_cvcl fwhy
     | Harvey -> call_harvey fwhy
     | Gwhy -> call_gwhy fwhy
-  
+
 let dp prover gl =
   Coqlib.check_required_library ["Coq";"ZArith";"ZArith"];
   let concl_type = pf_type_of gl (pf_concl gl) in
   if not (is_Prop concl_type) then error "Conclusion is not a Prop";
-  try 
+  try
     let q = tr_goal gl in
     begin match call_prover prover q with
       | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl
@@ -904,11 +1049,13 @@ let dp prover gl =
     end
   with NotFO ->
     error "Not a first order goal"
-      
+
 
 let simplify = tclTHEN intros (dp Simplify)
 let ergo = tclTHEN intros (dp Ergo)
+let cvc3 = tclTHEN intros (dp CVC3)
 let yices = tclTHEN intros (dp Yices)
+let z3 = tclTHEN intros (dp Z3)
 let cvc_lite = tclTHEN intros (dp CVCLite)
 let harvey = dp Harvey
 let zenon = tclTHEN intros (dp Zenon)
@@ -916,7 +1063,7 @@ let gwhy = tclTHEN intros (dp Gwhy)
 
 let dp_hint l =
   let env = Global.env () in
-  let one_hint (qid,r) = 
+  let one_hint (qid,r) =
     if not (mem_global r) then begin
       let ty = Global.type_of_global r in
       let s = Typing.type_of env Evd.empty ty in
@@ -930,7 +1077,7 @@ let dp_hint l =
 	with NotFO ->
 	  add_global r Gnot_fo;
 	  msg_warning
-	    (pr_reference qid ++ 
+	    (pr_reference qid ++
 	     str " ignored (not a first order proposition)")
 	else begin
 	  add_global r Gnot_fo;
@@ -941,12 +1088,11 @@ let dp_hint l =
   in
   List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
 
-let (dp_hint_obj,_) = 
-  declare_object 
-    {(default_object "Dp_hint") with  
+let (dp_hint_obj,_) =
+  declare_object
+    {(default_object "Dp_hint") with
        cache_function = (fun (_,l) -> dp_hint l);
-       load_function = (fun _ (_,l) -> dp_hint l);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,l) -> dp_hint l)}
 
 let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l)
 
@@ -959,7 +1105,7 @@ let dp_predefined qid s =
     let d = match tr_decl env id ty with
       | DeclType (_, n) -> DeclType (s, n)
       | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty)
-      | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) 
+      | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl)
       | Axiom _ as d -> d
     in
     match d with
@@ -968,24 +1114,21 @@ let dp_predefined qid s =
   with NotFO ->
     msg_warning (str " ignored (not a first order declaration)")
 
-let (dp_predefined_obj,_) = 
-  declare_object 
-    {(default_object "Dp_predefined") with  
+let (dp_predefined_obj,_) =
+  declare_object
+    {(default_object "Dp_predefined") with
        cache_function = (fun (_,(id,s)) -> dp_predefined id s);
-       load_function = (fun _ (_,(id,s)) -> dp_predefined id s);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,(id,s)) -> dp_predefined id s)}
 
 let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s))
 
-let _ = declare_summary "Dp options" 
-	  { freeze_function = 
+let _ = declare_summary "Dp options"
+	  { freeze_function =
 	      (fun () -> !debug, !trace, !timeout, !prelude_files);
-	    unfreeze_function = 
-	      (fun (d,tr,tm,pr) -> 
+	    unfreeze_function =
+	      (fun (d,tr,tm,pr) ->
 		debug := d; trace := tr; timeout := tm; prelude_files := pr);
-	    init_function = 
-	      (fun () -> 
-		debug := false; trace := false; timeout := 10; 
-		prelude_files := []);
-	    survive_module = true;
-	    survive_section = true }  
+	    init_function =
+	      (fun () ->
+		debug := false; trace := false; timeout := 10;
+		prelude_files := []) }
diff --git a/contrib/dp/dp.mli b/plugins/dp/dp.mli
index 6dbc05e1..f40f8688 100644
--- a/contrib/dp/dp.mli
+++ b/plugins/dp/dp.mli
@@ -4,11 +4,13 @@ open Proof_type
 
 val simplify : tactic
 val ergo : tactic
+val cvc3 : tactic
 val yices : tactic
 val cvc_lite : tactic
 val harvey : tactic
 val zenon : tactic
 val gwhy : tactic
+val z3: tactic
 
 val dp_hint : reference list -> unit
 val dp_timeout : int -> unit
@@ -16,5 +18,3 @@ val dp_debug : bool -> unit
 val dp_trace : bool -> unit
 val dp_prelude : string list -> unit
 val dp_predefined : reference -> string -> unit
-
-
diff --git a/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib
new file mode 100644
index 00000000..63252d6a
--- /dev/null
+++ b/plugins/dp/dp_plugin.mllib
@@ -0,0 +1,5 @@
+Dp_why
+Dp_zenon
+Dp
+G_dp
+Dp_plugin_mod
diff --git a/contrib/dp/dp_why.ml b/plugins/dp/dp_why.ml
index e24049ad..9a62f39d 100644
--- a/contrib/dp/dp_why.ml
+++ b/plugins/dp/dp_why.ml
@@ -4,12 +4,12 @@
 open Format
 open Fol
 
-type proof = 
+type proof =
   | Immediate of Term.constr
   | Fun_def of string * (string * typ) list * typ * term
 
 let proofs = Hashtbl.create 97
-let proof_name = 
+let proof_name =
   let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r
 
 let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n
@@ -24,9 +24,9 @@ let rec print_list sep print fmt = function
 let space fmt () = fprintf fmt "@ "
 let comma fmt () = fprintf fmt ",@ "
 
-let is_why_keyword = 
+let is_why_keyword =
   let h = Hashtbl.create 17 in
-  List.iter 
+  List.iter
     (fun s -> Hashtbl.add h s ())
     ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin";
      "bool"; "do"; "done"; "else"; "end"; "exception"; "exists";
@@ -34,7 +34,7 @@ let is_why_keyword =
      "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not";
      "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises";
      "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try";
-     "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; 
+     "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ];
   Hashtbl.mem h
 
 let ident fmt s =
@@ -43,13 +43,20 @@ let ident fmt s =
 let rec print_typ fmt = function
   | Tvar x -> fprintf fmt "'%a" ident x
   | Tid ("int", []) -> fprintf fmt "int"
+  | Tid ("real", []) -> fprintf fmt "real"
   | Tid (x, []) -> fprintf fmt "%a" ident x
   | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x
   | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x
 
+let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ
+
 let rec print_term fmt = function
-  | Cst n -> 
-      fprintf fmt "%d" n
+  | Cst n ->
+      fprintf fmt "%s" (Big_int.string_of_big_int n)
+  | RCst s ->
+      fprintf fmt "%s.0" (Big_int.string_of_big_int s)
+  | Power2 n ->
+      fprintf fmt "0x1p%s" (Big_int.string_of_big_int n)
   | Plus (a, b) ->
       fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b
   | Moins (a, b) ->
@@ -58,16 +65,18 @@ let rec print_term fmt = function
       fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b
   | Div (a, b) ->
       fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b
+  | Opp (a) ->
+      fprintf fmt "@[(-@ %a)@]" print_term a
   | App (id, []) ->
       fprintf fmt "%a" ident id
   | App (id, tl) ->
       fprintf fmt "@[%a(%a)@]" ident id print_terms tl
 
-and print_terms fmt tl = 
+and print_terms fmt tl =
   print_list comma print_term fmt tl
 
-let rec print_predicate fmt p = 
-  let pp = print_predicate in 
+let rec print_predicate fmt p =
+  let pp = print_predicate in
   match p with
   | True ->
       fprintf fmt "true"
@@ -83,9 +92,9 @@ let rec print_predicate fmt p =
       fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b
   | Fatom (Gt (a, b)) ->
       fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b
-  | Fatom (Pred (id, [])) -> 
+  | Fatom (Pred (id, [])) ->
       fprintf fmt "%a" ident id
-  | Fatom (Pred (id, tl)) -> 
+  | Fatom (Pred (id, tl)) ->
       fprintf fmt "@[%a(%a)@]" ident id print_terms tl
   | Imp (a, b) ->
       fprintf fmt "@[(%a ->@ %a)@]" pp a pp b
@@ -97,12 +106,35 @@ let rec print_predicate fmt p =
       fprintf fmt "@[(%a or@ %a)@]" pp a pp b
   | Not a ->
       fprintf fmt "@[(not@ %a)@]" pp a
-  | Forall (id, t, p) -> 
+  | Forall (id, t, p) ->
       fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p
-  | Exists (id, t, p) -> 
+  | Exists (id, t, p) ->
       fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p
 
+let rec remove_iff args = function
+    Forall (id,t,p) -> remove_iff ((id,t)::args) p
+  | Iff(_,b) -> List.rev args, b
+  | _ -> raise Not_found
+
 let print_query fmt (decls,concl) =
+  let find_declared_preds l =
+    function
+        DeclPred (id,_,args) -> (id,args) :: l
+      | _ -> l
+  in
+  let find_defined_preds declared l = function
+      Axiom(id,f) ->
+        (try
+           let _decl = List.assoc id declared in
+           (id,remove_iff [] f)::l
+         with Not_found -> l)
+    | _ -> l
+  in
+  let declared_preds =
+    List.fold_left find_declared_preds [] decls in
+  let defined_preds =
+    List.fold_left (find_defined_preds declared_preds) [] decls
+  in
   let print_dtype = function
     | DeclType (id, 0) ->
 	fprintf fmt "@[type %a@]@\n@\n" ident id
@@ -110,7 +142,7 @@ let print_query fmt (decls,concl) =
 	fprintf fmt "@[type 'a %a@]@\n@\n" ident id
     | DeclType (id, n) ->
 	fprintf fmt "@[type (";
-	for i = 1 to n do 
+	for i = 1 to n do
 	  fprintf fmt "'a%d" i; if i < n then fprintf fmt ", "
 	done;
 	fprintf fmt ") %a@]@\n@\n" ident id
@@ -121,18 +153,22 @@ let print_query fmt (decls,concl) =
     | DeclFun (id, _, [], t) ->
 	fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t
     | DeclFun (id, _, l, t) ->
-	fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" 
+	fprintf fmt "@[logic %a : %a -> %a@]@\n@\n"
 	  ident id (print_list comma print_typ) l print_typ t
-    | DeclPred (id, _, []) ->
+    | DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) ->
 	fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
-    | DeclPred (id, _, l) -> 
-	fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" 
+    | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) ->
+	fprintf fmt "@[logic %a : %a -> prop@]@\n@\n"
 	  ident id (print_list comma print_typ) l
-    | DeclType _ | Axiom _ ->
+    | DeclType _ | Axiom _ | DeclPred _ ->
 	()
   in
   let print_assert = function
-    | Axiom (id, f)  -> 
+    | Axiom(id,_) when List.mem_assoc id defined_preds ->
+        let args, def = List.assoc id defined_preds in
+        fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id
+          (print_list comma print_arg) args print_predicate def  
+    | Axiom (id, f)  ->
 	fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f
     | DeclType _ | DeclFun _ | DeclPred _ ->
 	()
@@ -145,7 +181,6 @@ let print_query fmt (decls,concl) =
 let output_file f q =
   let c = open_out f in
   let fmt = formatter_of_out_channel c in
+  fprintf fmt "include \"real.why\"@.";
   fprintf fmt "@[%a@]@." print_query q;
   close_out c
-
-
diff --git a/contrib/dp/dp_why.mli b/plugins/dp/dp_why.mli
index b38a3d37..0efa24a2 100644
--- a/contrib/dp/dp_why.mli
+++ b/plugins/dp/dp_why.mli
@@ -7,7 +7,7 @@ val output_file : string -> query -> unit
 
 (* table to translate the proofs back to Coq (used in dp_zenon) *)
 
-type proof = 
+type proof =
   | Immediate of Term.constr
   | Fun_def of string * (string * typ) list * typ * term
 
diff --git a/contrib/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli
index 0a727d1f..0a727d1f 100644
--- a/contrib/dp/dp_zenon.mli
+++ b/plugins/dp/dp_zenon.mli
diff --git a/contrib/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll
index e15e280d..949e91e3 100644
--- a/contrib/dp/dp_zenon.mll
+++ b/plugins/dp/dp_zenon.mll
@@ -1,7 +1,7 @@
 
 {
 
-  open Lexing 
+  open Lexing
   open Pp
   open Util
   open Names
@@ -12,9 +12,9 @@
 
   let debug = ref false
   let set_debug b = debug := b
-  
+
   let buf = Buffer.create 1024
-    
+
   let string_of_global env ref =
     Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref)
 
@@ -50,15 +50,15 @@ and scan = parse
   { anomaly "malformed Zenon proof term" }
 
 and read_coq_term = parse
-| "." "\n" 
+| "." "\n"
   { let s = Buffer.contents buf in Buffer.clear buf; s }
 | "coq__" (ident as id) (* a Why keyword renamed *)
   { Buffer.add_string buf id; read_coq_term lexbuf }
-| ("dp_axiom__" ['0'-'9']+) as id 
+| ("dp_axiom__" ['0'-'9']+) as id
   { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf }
-| _ as c 
+| _ as c
   { Buffer.add_char buf c; read_coq_term lexbuf }
-| eof 
+| eof
   { anomaly "malformed Zenon proof term" }
 
 and read_lemma_proof = parse
@@ -71,7 +71,7 @@ and read_lemma_proof = parse
 and read_main_proof = parse
 | ":=" "\n"
   { read_coq_term lexbuf }
-| _ 
+| _
   { read_main_proof lexbuf }
 | eof
   { anomaly "malformed Zenon proof term" }
@@ -88,7 +88,7 @@ and read_main_proof = parse
     if not !debug then begin try Sys.remove f with _ -> () end;
     p
 
-  let constr_of_string gl s = 
+  let constr_of_string gl s =
     let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
     Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
 
@@ -102,7 +102,7 @@ and read_main_proof = parse
       | [] -> ()
       | [x] -> print fmt x
       | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-	  
+
     let space fmt () = fprintf fmt "@ "
     let comma fmt () = fprintf fmt ",@ "
 
@@ -110,13 +110,19 @@ and read_main_proof = parse
       | Tvar x -> fprintf fmt "%s" x
       | Tid ("int", []) -> fprintf fmt "Z"
       | Tid (x, []) -> fprintf fmt "%s" x
-      | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t 
-      | Tid (x,tl) -> 
-	  fprintf fmt "(%s %a)" x (print_list comma print_typ) tl 
-	  
+      | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t
+      | Tid (x,tl) ->
+	  fprintf fmt "(%s %a)" x (print_list comma print_typ) tl
+
     let rec print_term fmt = function
-      | Cst n -> 
-	  fprintf fmt "%d" n
+      | Cst n ->
+	  fprintf fmt "%s" (Big_int.string_of_big_int n)
+      | RCst s ->
+          fprintf fmt "%s" (Big_int.string_of_big_int s)
+      | Power2 n ->
+          fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n)
+
+          (* TODO: bug, it might be operations on reals *)
       | Plus (a, b) ->
 	  fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b
       | Moins (a, b) ->
@@ -125,12 +131,14 @@ and read_main_proof = parse
 	  fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b
       | Div (a, b) ->
 	  fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b
+      | Opp (a) ->
+	  fprintf fmt "@[(Zopp %a)@]" print_term a
       | App (id, []) ->
 	  fprintf fmt "%s" id
       | App (id, tl) ->
 	  fprintf fmt "@[(%s %a)@]" id print_terms tl
 
-    and print_terms fmt tl = 
+    and print_terms fmt tl =
       print_list space print_term fmt tl
 
     (* builds the text for "forall vars, f vars = t" *)
@@ -138,17 +146,17 @@ and read_main_proof = parse
       let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in
       fprintf str_formatter
 	"@[(forall %a, %s %a = %a)@]@."
-	(print_list space binder) vars f 
+	(print_list space binder) vars f
 	(print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars
 	print_term t;
       flush_str_formatter ()
-			   
+
   end
 
   let prove_axiom id = match Dp_why.find_proof id with
-    | Immediate t -> 
+    | Immediate t ->
 	exact_check t
-    | Fun_def (f, vars, ty, t) -> 
+    | Fun_def (f, vars, ty, t) ->
 	tclTHENS
 	  (fun gl ->
 	     let s = Coq.fun_def_axiom f vars t in
diff --git a/contrib/dp/fol.mli b/plugins/dp/fol.mli
index b94bd3e3..4fb763a6 100644
--- a/contrib/dp/fol.mli
+++ b/plugins/dp/fol.mli
@@ -1,19 +1,22 @@
 
 (* Polymorphic First-Order Logic (that is Why's input logic) *)
 
-type typ = 
+type typ =
   | Tvar of string
   | Tid of string * typ list
 
-type term =   
-  | Cst of int
+type term =
+  | Cst of Big_int.big_int
+  | RCst of Big_int.big_int
+  | Power2 of Big_int.big_int
   | Plus of term * term
   | Moins of term * term
   | Mult of term * term
   | Div of term * term
+  | Opp of term
   | App of string * term list
 
-and atom =   
+and atom =
   | Eq of term * term
   | Le of term * term
   | Lt of term * term
@@ -21,7 +24,7 @@ and atom =
   | Gt of term * term
   | Pred of string * term list
 
-and form = 
+and form =
   | Fatom of atom
   | Imp of form * form
   | Iff of form * form
@@ -45,8 +48,8 @@ type query = decl list * form
 
 (* prover result *)
 
-type prover_answer = 
-  | Valid of string option 
+type prover_answer =
+  | Valid of string option
   | Invalid
   | DontKnow
   | Timeout
diff --git a/contrib/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4
index 99bcf477..82f86cd8 100644
--- a/contrib/dp/g_dp.ml4
+++ b/plugins/dp/g_dp.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_dp.ml4 10924 2008-05-13 14:01:11Z filliatr $ *)
+(* $Id$ *)
 
 open Dp
 
@@ -24,6 +24,14 @@ TACTIC EXTEND Yices
   [ "yices" ] -> [ yices ]
 END
 
+TACTIC EXTEND CVC3
+  [ "cvc3" ] -> [ cvc3 ]
+END
+
+TACTIC EXTEND Z3
+  [ "z3" ] -> [ z3 ]
+END
+
 TACTIC EXTEND CVCLite
   [ "cvcl" ] -> [ cvc_lite ]
 END
@@ -40,20 +48,12 @@ TACTIC EXTEND Gwhy
   [ "gwhy" ] -> [ gwhy ]
 END
 
-TACTIC EXTEND Gappa_internal
-  [ "gappa_internal" ] -> [ Dp_gappa.gappa_internal ]
-END
-
-TACTIC EXTEND Gappa
-  [ "gappa" ] -> [ Dp_gappa.gappa ]
-END
-
 (* should be part of basic tactics syntax *)
 TACTIC EXTEND admit
   [ "admit"    ] -> [ Tactics.admit_as_an_axiom ]
 END
 
-VERNAC COMMAND EXTEND Dp_hint 
+VERNAC COMMAND EXTEND Dp_hint
   [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ]
 END
 
diff --git a/contrib/dp/test2.v b/plugins/dp/test2.v
index 3e4c0f6d..0940b135 100644
--- a/contrib/dp/test2.v
+++ b/plugins/dp/test2.v
@@ -36,7 +36,7 @@ Goal fct O = O.
  Admitted.
 
 Fixpoint even (n:nat) : Prop :=
-  match n with 
+  match n with
   O => True
   | S O => False
   | S (S p) => even p
@@ -64,9 +64,9 @@ BUG avec head prédéfini : manque eta-expansion sur A:Set
 
 Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
 
-Print value. 
+Print value.
 Print Some.
- 
+
 zenon.
 *)
 
diff --git a/contrib/dp/tests.v b/plugins/dp/tests.v
index a6d4f2e1..dc85d2ee 100644
--- a/contrib/dp/tests.v
+++ b/plugins/dp/tests.v
@@ -1,6 +1,18 @@
 
 Require Import ZArith.
 Require Import Classical.
+Require Export Reals.
+
+
+(* real numbers *)
+
+Lemma real_expr: (0 <= 9 * 4)%R.
+ergo.
+Qed.
+
+Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R.
+ergo.
+Qed.
 
 Dp_debug.
 Dp_timeout 3.
@@ -38,7 +50,7 @@ Qed.
 Parameter nlist: list nat -> Prop.
 
 Lemma poly_1 : forall l,  nlist l -> True.
-intros. 
+intros.
 simplify.
 Qed.
 
@@ -54,8 +66,8 @@ match l with
 | cons a l1 => cons A a (app A l1 m)
 end.
 
-Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. 
-intros; ergo. 
+Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True.
+intros; ergo.
 Qed.
 
 (* polymorphism *)
@@ -69,7 +81,7 @@ Parameter my_nlist: mylist nat -> Prop.
 
  Goal forall l,  my_nlist l -> True.
  intros.
- simplify. 
+ simplify.
 Qed.
 
 (* First example with the 0 and the equality translated *)
@@ -133,12 +145,12 @@ induction x0; ergo.
 Qed.
 
 
-(* No decision procedure can solve this problem 
+(* No decision procedure can solve this problem
   Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
 *)
 
 
-(* Functions definitions *) 
+(* Functions definitions *)
 
 Definition fst (x y : Z) : Z := x.
 
@@ -160,7 +172,7 @@ simplify.
 Qed.
 
 
-(* Inductive types definitions - call to incontrib/dp/jection function *)
+(* Inductive types definitions - call to dp/injection function *)
 
 Inductive even : Z -> Prop :=
 | even_0 : even 0
@@ -193,7 +205,7 @@ Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).
 Dp_hint add_0.
 Dp_hint add_S.
 
-(* Simplify can't prove this goal before the timeout 
+(* Simplify can't prove this goal before the timeout
    unlike zenon *)
 
 Goal forall n : nat, add n 0 = n.
@@ -246,7 +258,7 @@ Qed.
 
 (* sorts issues *)
 
-Parameter foo : Set.         
+Parameter foo : Set.
 Parameter ff : nat -> foo -> foo -> nat.
 Parameter g : foo -> foo.
 Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
diff --git a/plugins/dp/vo.itarget b/plugins/dp/vo.itarget
new file mode 100644
index 00000000..4d282709
--- /dev/null
+++ b/plugins/dp/vo.itarget
@@ -0,0 +1 @@
+Dp.vo
diff --git a/contrib/dp/zenon.v b/plugins/dp/zenon.v
index 4ad00a11..502465c6 100644
--- a/contrib/dp/zenon.v
+++ b/plugins/dp/zenon.v
@@ -1,5 +1,5 @@
 (*  Copyright 2004 INRIA  *)
-(*  $Id: zenon.v 10739 2008-04-01 14:45:20Z herbelin $  *)
+(*  $Id$  *)
 
 Require Export Classical.
 
diff --git a/contrib/extraction/CHANGES b/plugins/extraction/CHANGES
index acd1dbda..fbcd01a1 100644
--- a/contrib/extraction/CHANGES
+++ b/plugins/extraction/CHANGES
@@ -1,3 +1,8 @@
+8.0 -> today
+
+See the main CHANGES file in the archive
+
+
 7.4 -> 8.0
 
 No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, 
@@ -74,7 +79,7 @@ but also a few steps toward a more user-friendly extraction:
   were one would have been enough. 
   
   - Examples of code needing those Obj.magic: 
-     * contrib/extraction/test_extraction.v in the Coq source
+     * plugins/extraction/test_extraction.v in the Coq source
      * in the users' contributions: 
 	Lannion
 	Lyon/CIRCUITS
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
new file mode 100644
index 00000000..f0135221
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction to Ocaml : use of basic Ocaml types *)
+
+Extract Inductive bool => bool [ true false ].
+Extract Inductive option => option [ Some None ].
+Extract Inductive unit => unit [ "()" ].
+Extract Inductive list => list [ "[]" "( :: )" ].
+Extract Inductive prod => "( * )" [ "" ].
+
+(** NB: The "" above is a hack, but produce nicer code than "(,)" *)
+
+(** Mapping sumbool to bool and sumor to option is not always nicer,
+    but it helps when realizing stuff like [lt_eq_lt_dec] *)
+
+Extract Inductive sumbool => bool [ true false ].
+Extract Inductive sumor => option [ Some None ].
+
+(** Restore lazyness of andb, orb.
+    NB: without these Extract Constant, andb/orb would be inlined
+    by extraction in order to have lazyness, producing inelegant
+    (if ... then ... else false) and (if ... then true else ...).
+*)
+
+Extract Inlined Constant andb => "(&&)".
+Extract Inlined Constant orb => "(||)".
+
diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
new file mode 100644
index 00000000..b4490545
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlBigIntConv.v
@@ -0,0 +1,108 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction to Ocaml: conversion from/to [big_int] *)
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+    from ocaml's stdlib and with the wrapper [big.ml] that
+    simlifies the use of [Big_int] (it could be found in the sources
+    of Coq). *)
+
+Require Import Arith ZArith.
+
+Parameter bigint : Type.
+Parameter bigint_zero : bigint.
+Parameter bigint_succ : bigint -> bigint.
+Parameter bigint_opp : bigint -> bigint.
+Parameter bigint_twice : bigint -> bigint.
+
+Extract Inlined Constant bigint => "Big.big_int".
+Extract Inlined Constant bigint_zero => "Big.zero".
+Extract Inlined Constant bigint_succ => "Big.succ".
+Extract Inlined Constant bigint_opp => "Big.opp".
+Extract Inlined Constant bigint_twice => "Big.double".
+
+Definition bigint_of_nat : nat -> bigint :=
+ (fix loop acc n :=
+  match n with
+   | O => acc
+   | S n => loop (bigint_succ acc) n
+  end) bigint_zero.
+
+Fixpoint bigint_of_pos p :=
+ match p with
+  | xH => bigint_succ bigint_zero
+  | xO p => bigint_twice (bigint_of_pos p)
+  | xI p => bigint_succ (bigint_twice (bigint_of_pos p))
+ end.
+
+Fixpoint bigint_of_z z :=
+ match z with
+  | Z0 => bigint_zero
+  | Zpos p => bigint_of_pos p
+  | Zneg p => bigint_opp (bigint_of_pos p)
+ end.
+
+Fixpoint bigint_of_n n :=
+ match n with
+  | N0 => bigint_zero
+  | Npos p => bigint_of_pos p
+ end.
+
+(** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and
+    [pos_of_bigint] are total and return zero (resp. one) for
+    non-positive inputs. *)
+
+Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A.
+Extract Constant bigint_natlike_rec => "Big.nat_rec".
+
+Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S.
+
+Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A.
+Extract Constant bigint_poslike_rec => "Big.positive_rec".
+
+Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH.
+
+Parameter bigint_zlike_case :
+ forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A.
+Extract Constant bigint_zlike_case => "Big.z_rec".
+
+Definition z_of_bigint : bigint -> Z :=
+ bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i))
+                        (fun i => Zneg (pos_of_bigint i)).
+
+Definition n_of_bigint : bigint -> N :=
+ bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0).
+
+(* Tests:
+
+Definition small := 1234%nat.
+Definition big := 12345678901234567890%positive.
+
+Definition nat_0 := nat_of_bigint (bigint_of_nat 0).
+Definition nat_1 := nat_of_bigint (bigint_of_nat small).
+Definition pos_1 := pos_of_bigint (bigint_of_pos 1).
+Definition pos_2 := pos_of_bigint (bigint_of_pos big).
+Definition n_0 := n_of_bigint (bigint_of_n 0).
+Definition n_1 := n_of_bigint (bigint_of_n 1).
+Definition n_2 := n_of_bigint (bigint_of_n (Npos big)).
+Definition z_0 := z_of_bigint (bigint_of_z 0).
+Definition z_1 := z_of_bigint (bigint_of_z 1).
+Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)).
+Definition z_m1 := z_of_bigint (bigint_of_z (-1)).
+Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)).
+
+Definition test :=
+ (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2).
+Definition check :=
+ (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big).
+
+Extraction "/tmp/test.ml" check test.
+
+... and we check that test=check
+*)
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
new file mode 100644
index 00000000..e729d9ca
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction to Ocaml: conversion from/to [int]
+
+    Nota: no check that [int] values aren't generating overflows *)
+
+Require Import Arith ZArith.
+
+Parameter int : Type.
+Parameter int_zero : int.
+Parameter int_succ : int -> int.
+Parameter int_opp : int -> int.
+Parameter int_twice : int -> int.
+
+Extract Inlined Constant int => int.
+Extract Inlined Constant int_zero => "0".
+Extract Inlined Constant int_succ => "succ".
+Extract Inlined Constant int_opp => "-".
+Extract Inlined Constant int_twice => "2 *".
+
+Definition int_of_nat : nat -> int :=
+ (fix loop acc n :=
+  match n with
+   | O => acc
+   | S n => loop (int_succ acc) n
+  end) int_zero.
+
+Fixpoint int_of_pos p :=
+ match p with
+  | xH => int_succ int_zero
+  | xO p => int_twice (int_of_pos p)
+  | xI p => int_succ (int_twice (int_of_pos p))
+ end.
+
+Fixpoint int_of_z z :=
+ match z with
+  | Z0 => int_zero
+  | Zpos p => int_of_pos p
+  | Zneg p => int_opp (int_of_pos p)
+ end.
+
+Fixpoint int_of_n n :=
+ match n with
+  | N0 => int_zero
+  | Npos p => int_of_pos p
+ end.
+
+(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and
+    [pos_of_int] are total and return zero (resp. one) for
+    non-positive inputs. *)
+
+Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A.
+Extract Constant int_natlike_rec =>
+"fun fO fS ->
+ let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1)
+ in loop fO".
+
+Definition nat_of_int : int -> nat := int_natlike_rec _ O S.
+
+Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A.
+Extract Constant int_poslike_rec =>
+"fun f1 f2x f2x1 ->
+ let rec loop i = if i <= 1 then f1 else
+  if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1))
+ in loop".
+
+Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI.
+
+Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A.
+Extract Constant int_zlike_case =>
+"fun f0 fpos fneg i ->
+ if i = 0 then f0 else if i>0 then fpos i else fneg (-i)".
+
+Definition z_of_int : int -> Z :=
+ int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i))
+                     (fun i => Zneg (pos_of_int i)).
+
+Definition n_of_int : int -> N :=
+ int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0).
+
+(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int],
+    since [min_int] has no positive opposite ([-min_int = min_int]).
+*)
+
+(*
+Extraction "/tmp/test.ml"
+  nat_of_int int_of_nat
+  pos_of_int int_of_pos
+  z_of_int int_of_z
+  n_of_int int_of_n.
+*)
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
new file mode 100644
index 00000000..491e0258
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction of [nat] into Ocaml's [big_int] *)
+
+Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import ExtrOcamlBasic.
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+    from ocaml's stdlib and with the wrapper [big.ml] that
+    simlifies the use of [Big_int] (it could be found in the sources
+    of Coq). *)
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [nat] into [big_int] isn't necessarily a good idea.
+    See comments in [ExtrOcamlNatInt.v].
+*)
+
+
+(** Mapping of [nat] into [big_int]. The last string corresponds to
+    a [nat_case], see documentation of [Extract Inductive]. *)
+
+Extract Inductive nat => "Big.big_int" [ "Big.zero" "Big.succ" ]
+ "Big.nat_case".
+
+(** Efficient (but uncertified) versions for usual [nat] functions *)
+
+Extract Constant plus => "Big.add".
+Extract Constant mult => "Big.mult".
+Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)".
+Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)".
+Extract Constant max => "Big.max".
+Extract Constant min => "Big.min".
+Extract Constant nat_beq => "Big.eq".
+Extract Constant EqNat.beq_nat => "Big.eq".
+Extract Constant EqNat.eq_nat_decide => "Big.eq".
+
+Extract Constant Peano_dec.eq_nat_dec => "Big.eq".
+
+Extract Constant Compare_dec.nat_compare =>
+ "Big.compare_case Eq Lt Gt".
+
+Extract Constant Compare_dec.leb => "Big.le".
+Extract Constant Compare_dec.le_lt_dec => "Big.le".
+Extract Constant Compare_dec.lt_eq_lt_dec =>
+ "Big.compare_case (Some false) (Some true) None".
+
+Extract Constant Even.even_odd_dec =>
+ "fun n -> Big.sign (Big.mod n Big.two) = 0".
+Extract Constant Div2.div2 => "fun n -> Big.div n Big.two".
+
+Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""].
+Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n".
+Extract Constant Euclid.quotient => "fun n m -> Big.div m n".
+Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n".
+
+(*
+Require Import Euclid.
+Definition test n m (H:m>0) :=
+ let (q,r,_,_) := eucl_dev m H n in
+ nat_compare n (q*m+r).
+
+Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2.
+*)
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
new file mode 100644
index 00000000..fe03bc60
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -0,0 +1,75 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction of [nat] into Ocaml's [int] *)
+
+Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import ExtrOcamlBasic.
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [nat] into [int] is definitively *not* a good idea:
+
+    - Since [int] is bounded while [nat] is (theoretically) infinite,
+    you have to make sure by yourself that your program will not
+    manipulate numbers greater than [max_int]. Otherwise you should
+    consider the translation of [nat] into [big_int].
+
+    - Moreover, the mere translation of [nat] into [int] does not
+    change the complexity of functions. For instance, [mult] stays
+    quadratic. To mitigate this, we propose here a few efficient (but
+    uncertified) realizers for some common functions over [nat].
+
+    This file is hence provided mainly for testing / prototyping
+    purpose. For serious use of numbers in extracted programs,
+    you are advised to use either coq advanced representations
+    (positive, Z, N, BigN, BigZ) or modular/axiomatic representation.
+*)
+
+
+(** Mapping of [nat] into [int]. The last string corresponds to
+    a [nat_case], see documentation of [Extract Inductive]. *)
+
+Extract Inductive nat => int [ "0" "succ" ]
+ "(fun fO fS n -> if n=0 then fO () else fS (n-1))".
+
+(** Efficient (but uncertified) versions for usual [nat] functions *)
+
+Extract Constant plus => "(+)".
+Extract Constant pred => "fun n -> max 0 (n-1)".
+Extract Constant minus => "fun n m -> max 0 (n-m)".
+Extract Constant mult => "( * )".
+Extract Inlined Constant max => max.
+Extract Inlined Constant min => min.
+Extract Inlined Constant nat_beq => "(=)".
+Extract Inlined Constant EqNat.beq_nat => "(=)".
+Extract Inlined Constant EqNat.eq_nat_decide => "(=)".
+
+Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".
+
+Extract Constant Compare_dec.nat_compare =>
+ "fun n m -> if n=m then Eq else if n<m then Lt else Gt".
+Extract Inlined Constant Compare_dec.leb => "(<=)".
+Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
+Extract Constant Compare_dec.lt_eq_lt_dec =>
+ "fun n m -> if n>m then None else Some (n<m)".
+
+Extract Constant Even.even_odd_dec => "fun n -> n mod 2 = 0".
+Extract Constant Div2.div2 => "fun n -> n/2".
+
+Extract Inductive Euclid.diveucl => "(int * int)" [ "" ].
+Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)".
+Extract Constant Euclid.quotient => "fun n m -> m/n".
+Extract Constant Euclid.modulo => "fun n m -> m mod n".
+
+(*
+Definition test n m (H:m>0) :=
+ let (q,r,_,_) := eucl_dev m H n in
+ nat_compare n (q*m+r).
+
+Recursive Extraction test fact.
+*)
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v
new file mode 100644
index 00000000..3fcd01b0
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlString.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Extraction to Ocaml : special handling of ascii and strings *)
+
+Require Import Ascii String.
+
+Extract Inductive ascii => char
+[
+"(* If this appears, you're using Ascii internals. Please don't *)
+ (fun (b0,b1,b2,b3,b4,b5,b6,b7) ->
+  let f b i = if b then 1 lsl i else 0 in
+  Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))"
+]
+"(* If this appears, you're using Ascii internals. Please don't *)
+ (fun f c ->
+  let n = Char.code c in
+  let h i = (n land (1 lsl i)) <> 0 in
+  f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))".
+
+Extract Constant zero => "'\000'".
+Extract Constant one => "'\001'".
+Extract Constant shift =>
+ "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)".
+
+Extract Inlined Constant ascii_dec => "(=)".
+
+Extract Inductive string => "char list" [ "[]" "(::)" ].
+
+(*
+Definition test := "ceci est un test"%string.
+Recursive Extraction test Ascii.zero Ascii.one.
+*)
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
new file mode 100644
index 00000000..08f43d3f
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *)
+
+Require Import ZArith NArith ZOdiv_def.
+Require Import ExtrOcamlBasic.
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+    from ocaml's stdlib and with the wrapper [big.ml] that
+    simlifies the use of [Big_int] (it could be found in the sources
+    of Coq). *)
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [Z] into [big_int] isn't necessarily a good idea.
+    See the Disclaimer in [ExtrOcamlNatInt]. *)
+
+(** Mapping of [positive], [Z], [N] into [big_int]. The last strings
+    emulate the matching, see documentation of [Extract Inductive]. *)
+
+Extract Inductive positive => "Big.big_int"
+ [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case".
+
+Extract Inductive Z => "Big.big_int"
+ [ "Big.zero" "" "Big.opp" ] "Big.z_case".
+
+Extract Inductive N => "Big.big_int"
+ [ "Big.zero" "" ] "Big.n_case".
+
+(** Nota: the "" above is used as an identity function "(fun p->p)" *)
+
+(** Efficient (but uncertified) versions for usual functions *)
+
+Extract Constant Pplus => "Big.add".
+Extract Constant Psucc => "Big.succ".
+Extract Constant Ppred => "fun n -> Big.max Big.one (Big.pred n)".
+Extract Constant Pminus => "fun n m -> Big.max Big.one (Big.sub n m)".
+Extract Constant Pmult => "Big.mult".
+Extract Constant Pmin => "Big.min".
+Extract Constant Pmax => "Big.max".
+Extract Constant Pcompare =>
+ "fun x y c -> Big.compare_case c Lt Gt x y".
+
+Extract Constant Nplus => "Big.add".
+Extract Constant Nsucc => "Big.succ".
+Extract Constant Npred => "fun n -> Big.max Big.zero (Big.pred n)".
+Extract Constant Nminus => "fun n m -> Big.max Big.zero (Big.sub n m)".
+Extract Constant Nmult => "Big.mult".
+Extract Constant Nmin => "Big.min".
+Extract Constant Nmax => "Big.max".
+Extract Constant Ndiv =>
+ "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b".
+Extract Constant Nmod =>
+ "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b".
+Extract Constant Ncompare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Zplus => "Big.add".
+Extract Constant Zsucc => "Big.succ".
+Extract Constant Zpred => "Big.pred".
+Extract Constant Zminus => "Big.sub".
+Extract Constant Zmult => "Big.mult".
+Extract Constant Zopp => "Big.opp".
+Extract Constant Zabs => "Big.abs".
+Extract Constant Zmin => "Big.min".
+Extract Constant Zmax => "Big.max".
+Extract Constant Zcompare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Z_of_N => "fun p -> p".
+Extract Constant Zabs_N => "Big.abs".
+
+(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+    For the moment we don't even try *)
+
+(** Test:
+Require Import ZArith NArith.
+
+Extraction "/tmp/test.ml"
+ Pplus Ppred Pminus Pmult Pcompare Npred Nminus Ndiv Nmod Ncompare
+ Zplus Zmult BinInt.Zcompare Z_of_N Zabs_N Zdiv.Zdiv Zmod.
+*)
diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
new file mode 100644
index 00000000..d3ea7372
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlZInt.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction of [positive], [N] and [Z] into Ocaml's [int] *)
+
+Require Import ZArith NArith ZOdiv_def.
+Require Import ExtrOcamlBasic.
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [Z] into [int] is definitively *not* a good idea.
+    See the Disclaimer in [ExtrOcamlNatInt]. *)
+
+(** Mapping of [positive], [Z], [N] into [int]. The last strings
+    emulate the matching, see documentation of [Extract Inductive]. *)
+
+Extract Inductive positive => int
+[ "(fun p->1+2*p)" "(fun p->2*p)" "1" ]
+"(fun f2p1 f2p f1 p ->
+  if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))".
+
+Extract Inductive Z => int [ "0" "" "(~-)" ]
+"(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))".
+
+Extract Inductive N => int [ "0" "" ]
+"(fun f0 fp n -> if n=0 then f0 () else fp n)".
+
+(** Nota: the "" above is used as an identity function "(fun p->p)" *)
+
+(** Efficient (but uncertified) versions for usual functions *)
+
+Extract Constant Pplus => "(+)".
+Extract Constant Psucc => "succ".
+Extract Constant Ppred => "fun n -> max 1 (n-1)".
+Extract Constant Pminus => "fun n m -> max 1 (n-m)".
+Extract Constant Pmult => "( * )".
+Extract Constant Pmin => "min".
+Extract Constant Pmax => "max".
+Extract Constant Pcompare =>
+ "fun x y c -> if x=y then c else if x<y then Lt else Gt".
+
+
+Extract Constant Nplus => "(+)".
+Extract Constant Nsucc => "succ".
+Extract Constant Npred => "fun n -> max 0 (n-1)".
+Extract Constant Nminus => "fun n m -> max 0 (n-m)".
+Extract Constant Nmult => "( * )".
+Extract Constant Nmin => "min".
+Extract Constant Nmax => "max".
+Extract Constant Ndiv => "fun a b -> if b=0 then 0 else a/b".
+Extract Constant Nmod => "fun a b -> if b=0 then a else a mod b".
+Extract Constant Ncompare =>
+ "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
+
+
+Extract Constant Zplus => "(+)".
+Extract Constant Zsucc => "succ".
+Extract Constant Zpred => "pred".
+Extract Constant Zminus => "(-)".
+Extract Constant Zmult => "( * )".
+Extract Constant Zopp => "(~-)".
+Extract Constant Zabs => "abs".
+Extract Constant Zmin => "min".
+Extract Constant Zmax => "max".
+Extract Constant Zcompare =>
+ "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
+
+Extract Constant Z_of_N => "fun p -> p".
+Extract Constant Zabs_N => "abs".
+
+(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+    For the moment we don't even try *)
+
+
diff --git a/contrib/extraction/README b/plugins/extraction/README
index 7350365e..64c871fd 100644
--- a/contrib/extraction/README
+++ b/plugins/extraction/README
@@ -1,21 +1,40 @@
 
-Status of Extraction in Coq version 7.x
-======================================
+          Coq Extraction
+          ==============
 
-(* 22 jan 2003 : Updated for version 7.4 *)
 
+What is it ?
+------------
 
-J.C. Filliâtre
-P. Letouzey
+The extraction is a mechanism allowing to produce functional code
+(Ocaml/Haskell/Scheme) out of any Coq terms (either programs or
+proofs).
 
+Who did it ?
+------------
 
+The current implementation (from version 7.0 up to now) has been done
+by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
+by C. Paulin. 
 
-Extraction code has been completely rewritten since version V6.3. 
-This work is still not finished, but most parts of it are already usable. 
-In consequence it is included in the Coq V7.0 final release. 
-But don't be mistaken: 
+An earlier implementation (versions 6.x) was due to B. Werner and
+C. Paulin.
+
+
+Where can we find more information ?
+------------------------------------
+
+- Coq Reference Manual includes a full chapter about extraction
+- P. Letouzey's PhD thesis [3] forms a complete document about
+  both theory and implementation and test-cases of Coq-extraction
+- A more recent article [4] proposes a short overview of extraction
+- earlier documents [1] [2] may also be useful.
 
-	THIS WORK IS STILL EXPERIMENTAL !
+
+Why a complete re-implementation ?
+----------------------------------
+
+Extraction code has been completely rewritten since version V6.3. 
 
 1) Principles 
 
@@ -28,7 +47,7 @@ Translation between Coq and ML is based upon the following principles:
 
 - Terms of sort Prop don't have any computational meaning, so they are
 merged into one ML term "__". This part is done according to P. Letouzey's 
-works (*) and (**).
+works [1] and [2].
 
 This dummy constant "__" used to be implemented by the unit (), but 
 we recently found that this constant might be applied in some cases. 
@@ -50,14 +69,11 @@ gives an inductive, etc...
 
 This gives ML code that have no special reason to typecheck, due 
 to the incompatibilities between Coq and ML typing systems. In fact
-most of the time everything goes right. For example, it is sufficient 
-to extract and compile everything in the "theories" directory 
-(cf test subdirectory).
+most of the time everything goes right. 
 
 We now verify during extraction that the produced code is typecheckable, 
 and if it is not we insert unsafe type casting at critical points in the 
-code. For the moment, it is an Ocaml-only feature, using the "Obj.magic"
-function, but the same kind of trick will be soon made in Haskell.
+code, with either "Obj.magic" in Ocaml or "unsafeCoerce" in Haskell.
 
 
 2) Differences with previous extraction (V6.3 and before)
@@ -67,25 +83,25 @@ function, but the same kind of trick will be soon made in Haskell.
 The ability to extract every Coq term, as explain in the previous 
 paragraph. 
 
-The ability to extract from a file an ML module (cf Extraction Module in the 
+The ability to extract from a file an ML module (cf Extraction Library in the 
 documentation)
 
 You can have a taste of extraction directly at the toplevel by 
 using the "Extraction <ident>" or the "Recursive Extraction <ident>".
 This toplevel extraction was already there in V6.3, but was printing 
 Fw terms. It now prints in the language of your choice: 
-Ocaml, Haskell, Scheme, or an Ocaml-like with Coq namings. 
+Ocaml, Haskell or Scheme. 
 
 The optimization done on extracted code has been ported between 
 V6.3 and V7 and enhanced, and in particular the mechanism of automatic
-expansion. 
+expansion.
 
 2.b) The cons 
 
 The presence of some parasite "__" as dummy arguments
 in functions. This denotes the rests of a proof part. The previous 
 extraction was able to remove them totally. The current implementation
-removes a good deal of them (more that in 7.0), but not all. 
+removes a good deal of them, but not all. 
 
 This problem is due to extraction upon Type.
 For example, let's take this pathological term: 
@@ -97,38 +113,30 @@ extraction.
 There is no more "ML import" feature. You can compensate by using 
 Axioms, and then "Extract Constant ..." 
 
-3) Examples 
 
-The file "test-extraction.v" is made of some examples used while debugging.
 
-In the subdirectory "test", you can test extraction on the Coq theories.
-Go there.
-"make tree" to make a local copy of the "theories" tree
-"make" to extract & compile most of the theories file in Ocaml
-"make -f Makefile.haskell" to extract & compile in Haskell
 
-See also Reference Manual for explanation of extraction syntaxes
-and more examples. 
 
-
-(*):
+[1]:
 Exécution de termes de preuves: une nouvelle méthode d'extraction 
 pour le Calcul des Constructions Inductives, Pierre Letouzey,
 DEA thesis, 2000, 
-http://www.lri.fr/~letouzey/download/rapport_dea.ps.gz
+http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz
 
-(**) 
+[2]: 
 A New Extraction for Coq, Pierre Letouzey, 
-Types 2002 Post-Workshop Proceedings, to appear, 
-draft at http://www.lri.fr/~letouzey/download/extraction2002.ps.gz
-
-
-Any feedback is welcome: 
-Pierre.Letouzey@lri.fr
-Jean.Christophe.Filliatre@lri.fr
-
-
-
+Types 2002 Post-Workshop Proceedings. 
+http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz
+
+[3]: 
+Programmation fonctionnelle certifiée: l'extraction de programmes
+dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004.
+http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz
+http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz
+
+[4]:
+Coq Extraction, An overview. Pierre Letouzey. CiE2008.
+http://www.pps.jussieu.fr/~letouzey/download/letouzey_extr_cie08.pdf
 
 
 
diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml
new file mode 100644
index 00000000..9a5bf56b
--- /dev/null
+++ b/plugins/extraction/big.ml
@@ -0,0 +1,154 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** [Big] : a wrapper around ocaml [Big_int] with nicer names,
+    and a few extraction-specific constructions *)
+
+(** To be linked with [nums.(cma|cmxa)] *)
+
+open Big_int
+
+type big_int = Big_int.big_int
+    (** The type of big integers. *)
+
+let zero = zero_big_int
+        (** The big integer [0]. *)
+let one = unit_big_int
+        (** The big integer [1]. *)
+let two = big_int_of_int 2
+        (** The big integer [2]. *)
+
+(** {6 Arithmetic operations} *)
+
+let opp = minus_big_int
+        (** Unary negation. *)
+let abs = abs_big_int
+        (** Absolute value. *)
+let add = add_big_int
+        (** Addition. *)
+let succ = succ_big_int
+        (** Successor (add 1). *)
+let add_int = add_int_big_int
+        (** Addition of a small integer to a big integer. *)
+let sub = sub_big_int
+        (** Subtraction. *)
+let pred = pred_big_int
+        (** Predecessor (subtract 1). *)
+let mult = mult_big_int
+        (** Multiplication of two big integers. *)
+let mult_int = mult_int_big_int
+        (** Multiplication of a big integer by a small integer *)
+let square = square_big_int
+        (** Return the square of the given big integer *)
+let sqrt = sqrt_big_int
+        (** [sqrt_big_int a] returns the integer square root of [a],
+           that is, the largest big integer [r] such that [r * r <= a].
+           Raise [Invalid_argument] if [a] is negative. *)
+let quomod = quomod_big_int
+        (** Euclidean division of two big integers.
+           The first part of the result is the quotient,
+           the second part is the remainder.
+           Writing [(q,r) = quomod_big_int a b], we have
+           [a = q * b + r] and [0 <= r < |b|].
+           Raise [Division_by_zero] if the divisor is zero. *)
+let div = div_big_int
+        (** Euclidean quotient of two big integers.
+           This is the first result [q] of [quomod_big_int] (see above). *)
+let modulo = mod_big_int
+        (** Euclidean modulus of two big integers.
+           This is the second result [r] of [quomod_big_int] (see above). *)
+let gcd = gcd_big_int
+        (** Greatest common divisor of two big integers. *)
+let power = power_big_int_positive_big_int
+        (** Exponentiation functions.  Return the big integer
+           representing the first argument [a] raised to the power [b]
+           (the second argument).  Depending
+           on the function, [a] and [b] can be either small integers
+           or big integers.  Raise [Invalid_argument] if [b] is negative. *)
+
+(** {6 Comparisons and tests} *)
+
+let sign = sign_big_int
+        (** Return [0] if the given big integer is zero,
+           [1] if it is positive, and [-1] if it is negative. *)
+let compare = compare_big_int
+        (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
+           [1] if [a] is greater than [b], and [-1] if [a] is smaller
+           than [b]. *)
+let eq = eq_big_int
+let le = le_big_int
+let ge = ge_big_int
+let lt = lt_big_int
+let gt = gt_big_int
+        (** Usual boolean comparisons between two big integers. *)
+let max = max_big_int
+        (** Return the greater of its two arguments. *)
+let min = min_big_int
+        (** Return the smaller of its two arguments. *)
+
+(** {6 Conversions to and from strings} *)
+
+let to_string = string_of_big_int
+        (** Return the string representation of the given big integer,
+           in decimal (base 10). *)
+let of_string = big_int_of_string
+        (** Convert a string to a big integer, in decimal.
+           The string consists of an optional [-] or [+] sign,
+           followed by one or several decimal digits. *)
+
+(** {6 Conversions to and from other numerical types} *)
+
+let of_int = big_int_of_int
+        (** Convert a small integer to a big integer. *)
+let is_int = is_int_big_int
+        (** Test whether the given big integer is small enough to
+           be representable as a small integer (type [int])
+           without loss of precision.  On a 32-bit platform,
+           [is_int_big_int a] returns [true] if and only if
+           [a] is between 2{^30} and 2{^30}-1.  On a 64-bit platform,
+           [is_int_big_int a] returns [true] if and only if
+           [a] is between -2{^62} and 2{^62}-1. *)
+let to_int = int_of_big_int
+        (** Convert a big integer to a small integer (type [int]).
+           Raises [Failure "int_of_big_int"] if the big integer
+           is not representable as a small integer. *)
+
+(** Functions used by extraction *)
+
+let double x = mult_int 2 x
+let doubleplusone x = succ (double x)
+
+let nat_case fO fS n = if sign n <= 0 then fO () else fS (pred n)
+
+let positive_case f2p1 f2p f1 p =
+ if le p one then f1 () else
+   let (q,r) = quomod p two in if eq r zero then f2p q else f2p1 q
+
+let n_case fO fp n = if sign n <= 0 then fO () else fp n
+
+let z_case fO fp fn z =
+  let s = sign z in
+  if s = 0 then fO () else if s > 0 then fp z else fn (opp z)
+
+let compare_case e l g x y =
+  let s = compare x y in if s = 0 then e else if s<0 then l else g
+
+let nat_rec fO fS =
+  let rec loop acc n =
+    if sign n <= 0 then acc else loop (fS acc) (pred n)
+  in loop fO
+
+let positive_rec f2p1 f2p f1 =
+  let rec loop n =
+    if le n one then f1
+    else
+      let (q,r) = quomod n two in
+      if eq r zero then f2p (loop q) else f2p1 (loop q)
+  in loop
+
+let z_rec fO fp fn = z_case (fun _ -> fO) fp fn
diff --git a/contrib/extraction/common.ml b/plugins/extraction/common.ml
index 73f44e68..1db1c786 100644
--- a/contrib/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.ml 13200 2010-06-25 22:36:25Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
 open Names
 open Term
 open Declarations
+open Namegen
 open Nameops
 open Libnames
 open Table
@@ -21,7 +22,14 @@ open Mlutil
 open Modutil
 open Mod_subst
 
-let string_of_id id = ascii_of_ident (Names.string_of_id id)
+let string_of_id id =
+  let s = Names.string_of_id id in
+  for i = 0 to String.length s - 2 do
+    if s.[i] = '_' && s.[i+1] = '_' then warning_id s
+  done;
+  ascii_of_ident s
+
+let is_mp_bound = function MPbound _ -> true | _ -> false
 
 (*s Some pretty-print utility functions. *)
 
@@ -35,39 +43,42 @@ let pr_binding = function
   | [] -> mt ()
   | l  -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
 
-let fnl2 () = fnl () ++ fnl () 
+let fnl2 () = fnl () ++ fnl ()
 
 let space_if = function true -> str " " | false -> mt ()
 
 let sec_space_if = function true -> spc () | false -> mt ()
 
-let is_digit = function 
+let is_digit = function
   | '0'..'9' -> true
   | _ -> false
 
-let begins_with_CoqXX s = 
-  let n = String.length s in 
+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 
+  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 if is_digit s.[!i] then incr i
     else raise Not_found
   done; true
   with Not_found -> false
-  
-let unquote s = 
-  if lang () <> Scheme then s 
-  else 
-    let s = String.copy s in 
+
+let unquote s =
+  if lang () <> Scheme then s
+  else
+    let s = String.copy s in
     for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done;
     s
 
-let rec dottify = function
+let rec qualify delim = function
   | [] -> assert false
   | [s] -> s
-  | s::[""] -> s
-  | s::l -> (dottify l)^"."^s
+  | ""::l -> qualify delim l
+  | s::l -> s^delim^(qualify delim l)
+
+let dottify = qualify "."
+let pseudo_qualify = qualify "__"
 
 (*s Uppercase/lowercase renamings. *)
 
@@ -97,11 +108,11 @@ type env = identifier list * Idset.t
 
 (*s Generic renaming issues for local variable names. *)
 
-let rec rename_id id avoid = 
-  if Idset.mem id avoid then rename_id (lift_ident id) avoid else id
+let rec rename_id id avoid =
+  if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id
 
 let rec rename_vars avoid = function
-  | [] -> 
+  | [] ->
       [], avoid
   | id :: idl when id == dummy_name ->
       (* we don't rename dummy binders *)
@@ -112,12 +123,12 @@ let rec rename_vars avoid = function
       let id = rename_id (lowercase_id id) avoid in
       (id :: idl, Idset.add id avoid)
 
-let rename_tvars avoid l = 
-  let rec rename avoid = function 
-    | [] -> [],avoid 
-    | id :: idl -> 
-	let id = rename_id (lowercase_id id) avoid in 
-	let idl, avoid = rename (Idset.add id avoid) idl in 
+let rename_tvars avoid l =
+  let rec rename avoid = function
+    | [] -> [],avoid
+    | id :: idl ->
+	let id = rename_id (lowercase_id id) avoid in
+	let idl, avoid = rename (Idset.add id avoid) idl in
 	(id :: idl, avoid) in
   fst (rename avoid l)
 
@@ -125,8 +136,8 @@ let push_vars ids (db,avoid) =
   let ids',avoid' = rename_vars avoid ids in
   ids', (ids' @ db, avoid')
 
-let get_db_name n (db,_) = 
-  let id = List.nth db (pred n) in 
+let get_db_name n (db,_) =
+  let id = List.nth db (pred n) in
   if id = dummy_name then id_of_string "__" else id
 
 
@@ -178,47 +189,54 @@ let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear =
   register_cleanup clear;
   (add,mem,list,clear)
 
+(*s List of module parameters that we should alpha-rename *)
+
+let params_ren_add, params_ren_mem =
+  let m = ref MPset.empty in
+  let add mp = m:=MPset.add mp !m
+  and mem mp = MPset.mem mp !m
+  and clear () = m:=MPset.empty
+  in
+  register_cleanup clear;
+  (add,mem)
+
 (*s table indicating the visible horizon at a precise moment,
     i.e. the stack of structures we are inside.
 
-  - The sequence of [mp] parts should have the following form: 
-  [X.Y; X; A.B.C; A.B; A; ...], i.e. each addition should either 
-  be a [MPdot] over the last entry, or something new, mainly 
-  [MPself], or [MPfile] at the beginning.
+  - The sequence of [mp] parts should have the following form:
+  a [MPfile] at the beginning, and then more and more [MPdot]
+  over this [MPfile], or [MPbound] when inside the type of a
+  module parameter.
+
+  - the [params] are the [MPbound] when [mp] is a functor,
+    the innermost [MPbound] coming first in the list.
 
-  - The [content] part is used to recoard all the names already
+  - The [content] part is used to record all the names already
   seen at this level.
-  
-  - The [subst] part is here mainly for printing signature
-  (in which names are still short, i.e. relative to a [msid]).
 *)
 
 type visible_layer = { mp : module_path;
-		       content : ((kind*string),unit) Hashtbl.t }
+		       params : module_path list;
+		       content : ((kind*string),label) Hashtbl.t }
 
-let pop_visible, push_visible, get_visible, subst_mp =
-  let vis = ref [] and sub = ref [empty_subst] in
-  register_cleanup (fun () -> vis := []; sub := [empty_subst]);
+let pop_visible, push_visible, get_visible =
+  let vis = ref [] in
+  register_cleanup (fun () -> vis := []);
   let pop () =
     let v = List.hd !vis in
     (* we save the 1st-level-content of MPfile for later use *)
     if get_phase () = Impl && modular () && is_modfile v.mp
     then add_mpfiles_content v.mp v.content;
-    vis := List.tl !vis;
-    sub := List.tl !sub
-  and push mp o =
-    vis := { mp = mp; content = Hashtbl.create 97 } :: !vis;
-    let s = List.hd !sub in
-    let s = match o with None -> s | Some msid -> add_msid msid mp s in
-    sub := s :: !sub
+    vis := List.tl !vis
+  and push mp mps =
+    vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis
   and get () = !vis
-  and subst mp = subst_mp (List.hd !sub) mp
-  in (pop,push,get,subst)
+  in (pop,push,get)
 
 let get_visible_mps () = List.map (function v -> v.mp) (get_visible ())
 let top_visible () = match get_visible () with [] -> assert false | v::_ -> v
 let top_visible_mp () = (top_visible ()).mp
-let add_visible ks = Hashtbl.add (top_visible ()).content ks ()
+let add_visible ks l = Hashtbl.add (top_visible ()).content ks l
 
 (* table of local module wrappers used to provide non-ambiguous names *)
 
@@ -229,7 +247,7 @@ let add_duplicate, check_duplicate =
      incr index;
      let ren = "Coq__" ^ string_of_int (!index) in
      dups := Gmap.add (mp,l) ren !dups
-  and check mp l = Gmap.find (subst_mp mp, l) !dups
+  and check mp l = Gmap.find (mp, l) !dups
   in (add,check)
 
 type reset_kind = AllButExternal | Everything
@@ -240,9 +258,9 @@ let reset_renaming_tables flag =
 
 (*S Renaming functions *)
 
-(* This function creates from [id] a correct uppercase/lowercase identifier. 
-   This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes 
-   with previous [Coq_id] variable, these prefixes are duplicated if already 
+(* This function creates from [id] a correct uppercase/lowercase identifier.
+   This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes
+   with previous [Coq_id] variable, these prefixes are duplicated if already
    existing. *)
 
 let modular_rename k id =
@@ -256,7 +274,7 @@ let modular_rename k id =
   then prefix ^ s
   else s
 
-(*s For monolithic extraction, first-level modules might have to be renamed 
+(*s For monolithic extraction, first-level modules might have to be renamed
     with unique numbers *)
 
 let modfstlev_rename =
@@ -284,8 +302,10 @@ let rec mp_renaming_fun mp = match mp with
       let lmp = mp_renaming mp in
       if lmp = [""] then (modfstlev_rename l)::lmp
       else (modular_rename Mod (id_of_label l))::lmp
-  | MPself msid -> [modular_rename Mod (id_of_msid msid)]
-  | MPbound mbid -> [modular_rename Mod (id_of_mbid mbid)]
+  | MPbound mbid ->
+      let s = modular_rename Mod (id_of_mbid mbid) in
+      if not (params_ren_mem mp) then [s]
+      else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i]
   | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *)
   | MPfile _ ->
       assert (get_phase () = Pre);
@@ -297,21 +317,24 @@ let rec mp_renaming_fun mp = match mp with
 
 and mp_renaming =
   let add,get,_ = mktable true in
-  fun x ->  try get x with Not_found -> let y = mp_renaming_fun x in add x y; y
+  fun x ->
+    try if is_mp_bound (base_mp x) then raise Not_found; get x
+    with Not_found -> let y = mp_renaming_fun x in add x y; y
 
 (*s Renamings creation for a [global_reference]: we build its fully-qualified
     name in a [string list] form (head is the short name). *)
 
 let ref_renaming_fun (k,r) =
-  let mp = subst_mp (modpath_of_r r) in
+  let mp = modpath_of_r r in
   let l = mp_renaming mp in
+  let l = if lang () <> Ocaml && not (modular ()) then [""] else l in
   let s =
     if l = [""] (* this happens only at toplevel of the monolithic case *)
     then
       let globs = Idset.elements (get_global_ids ()) in
-      let id = next_ident_away (kindcase_id k (safe_id_of_global r)) globs in
+      let id = next_ident_away (kindcase_id k (safe_basename_of_global r)) globs in
       string_of_id id
-    else modular_rename k (safe_id_of_global r)
+    else modular_rename k (safe_basename_of_global r)
   in
   add_global_ids (id_of_string s);
   s::l
@@ -320,12 +343,14 @@ let ref_renaming_fun (k,r) =
 
 let ref_renaming =
   let add,get,_ = mktable true in
-  fun x -> try get x with Not_found -> let y = ref_renaming_fun x in add x y; y
+  fun x ->
+    try if is_mp_bound (base_mp (modpath_of_r (snd x))) then raise Not_found; get x
+    with Not_found -> let y = ref_renaming_fun x in add x y; y
 
 (* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k]
    can be printed as [s] in the current context of visible
-   modules. More precisely, we check if there exists a 
-   visible [mp] that contains [s]. 
+   modules. More precisely, we check if there exists a
+   visible [mp] that contains [s].
    The verification stops if we encounter [mp=mp0]. *)
 
 let rec clash mem mp0 ks = function
@@ -338,12 +363,38 @@ let mpfiles_clash mp0 ks =
   clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks
     (List.rev (mpfiles_list ()))
 
+let rec params_lookup mp0 ks = function
+  | [] -> false
+  | param :: _ when mp0 = param -> true
+  | param :: params ->
+      if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param;
+      params_lookup mp0 ks params
+
 let visible_clash mp0 ks =
   let rec clash = function
     | [] -> false
     | v :: _ when v.mp = mp0 -> false
-    | v :: _ when Hashtbl.mem v.content ks -> true
-    | _ :: vis -> clash vis
+    | v :: vis ->
+	let b = Hashtbl.mem v.content ks in
+	if b && not (is_mp_bound mp0) then true
+	else begin
+	  if b then params_ren_add mp0;
+	  if params_lookup mp0 ks v.params then false
+	  else clash vis
+	end
+  in clash (get_visible ())
+
+(* Same, but with verbose output (and mp0 shouldn't be a MPbound) *)
+
+let visible_clash_dbg mp0 ks =
+  let rec clash = function
+    | [] -> None
+    | v :: _ when v.mp = mp0 -> None
+    | v :: vis ->
+	try Some (v.mp,Hashtbl.find v.content ks)
+	with Not_found ->
+	  if params_lookup mp0 ks v.params then None
+	  else clash vis
   in clash (get_visible ())
 
 (* After the 1st pass, we can decide which modules will be opened initially *)
@@ -368,77 +419,117 @@ let opened_libraries () =
 (*s On-the-fly qualification issues for both monolithic or modular extraction. *)
 
 (* First, a function that factorize the printing of both [global_reference]
-   and module names for ocaml. When [k=Mod] then [olab=None], otherwise it 
-   contains the label of the reference to print. 
-   Invariant: [List.length ls >= 2], simpler situations are handled elsewhere. *)
-
-let pp_gen k mp ls olab =
-  try (* what is the largest prefix of [mp] that belongs to [visible]? *)
-    let prefix = common_prefix_from_list mp (get_visible_mps ()) in
-    let delta = mp_length mp - mp_length prefix in
-    assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
-    let ls = list_firstn (delta + if k = Mod then 0 else 1) ls in
-    let s,ls' = list_sep_last ls in
-    (* Reference r / module path mp is of the form [<prefix>.s.<List.rev ls'>].
-       Difficulty: in ocaml the prefix part cannot be used for
-       qualification (we are inside it) and the rest of the long
-       name may be hidden. 
-       Solution: we duplicate the _definition_ of r / mp in a Coq__XXX module *)
-    let k' = if ls' = [] then k else Mod in
-    if visible_clash prefix (k',s) then
-      let front = if ls' = [] && k <> Mod then [s] else ls' in
-      let lab = (* label associated with s *)
-	if delta = 0 && k <> Mod then Option.get olab
-	else get_nth_label_mp delta mp
-      in
-      try dottify (front @ [check_duplicate prefix lab])
-      with Not_found ->
-	assert (get_phase () = Pre); (* otherwise it's too late *)
-	add_duplicate prefix lab; dottify ls
-    else dottify ls
+   and module names for ocaml. When [k=Mod] then [olab=None], otherwise it
+   contains the label of the reference to print.
+   [rls] is the string list giving the qualified name, short name at the end.
+   Invariant: [List.length rls >= 2], simpler situations are handled elsewhere. *)
+
+(* In Coq, we can qualify [M.t] even if we are inside [M], but in Ocaml we
+   cannot do that. So, if [t] gets hidden and we need a long name for it,
+   we duplicate the _definition_ of t in a Coq__XXX module, and similarly
+   for a sub-module [M.N] *)
+
+let pp_duplicate k' prefix mp rls olab =
+  let rls', lbl =
+    if k'<>Mod then
+      (* Here rls=[s], the ref to print is <prefix>.<s>, and olab<>None *)
+      rls, Option.get olab
+    else
+      (* Here rls=s::rls', we search the label for s inside mp *)
+      List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp
+  in
+  try dottify (check_duplicate prefix lbl :: rls')
   with Not_found ->
-    (* [mp] belongs to a closed module, not one of [visible]. *)
-    let base = base_mp mp in
-    let base_s,ls1 = list_sep_last ls in
-    let s,ls2 = list_sep_last ls1 in
-    (* [List.rev ls] is [base_s :: s :: List.rev ls2] *)
-    let k' = if ls2 = [] then k else Mod in
-    if modular () && (mpfiles_mem base) &&
-      (not (mpfiles_clash base (k',s))) &&
-      (not (visible_clash base (k',s)))
-    then (* Standard situation of an object in another file: *)
-      (* Thanks to the "open" of this file we remove its name *)
-      dottify ls1
-    else if visible_clash base (Mod,base_s) then
-      error_module_clash base_s
-    else dottify ls
+    assert (get_phase () = Pre); (* otherwise it's too late *)
+    add_duplicate prefix lbl; dottify rls
+
+let fstlev_ks k = function
+  | [] -> assert false
+  | [s] -> k,s
+  | s::_ -> Mod,s
+
+(* [pp_ocaml_local] : [mp] has something in common with [top_visible ()]
+   but isn't equal to it *)
+
+let pp_ocaml_local k prefix mp rls olab =
+  (* what is the largest prefix of [mp] that belongs to [visible]? *)
+  assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
+  let rls' = list_skipn (mp_length prefix) rls in
+  let k's = fstlev_ks k rls' in
+  (* Reference r / module path mp is of the form [<prefix>.s.<...>]. *)
+  if not (visible_clash prefix k's) then dottify rls'
+  else pp_duplicate (fst k's) prefix mp rls' olab
+
+(* [pp_ocaml_bound] : [mp] starts with a [MPbound], and we are not inside
+   (i.e. we are not printing the type of the module parameter) *)
+
+let pp_ocaml_bound base rls =
+  (* clash with a MPbound will be detected and fixed by renaming this MPbound *)
+  if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls));
+  dottify rls
+
+(* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *)
+
+let pp_ocaml_extern k base rls = match rls with
+  | [] | [_] -> assert false
+  | base_s :: rls' ->
+      let k's = fstlev_ks k rls' in
+      if modular () && (mpfiles_mem base) &&
+	(not (mpfiles_clash base k's)) &&
+	(not (visible_clash base k's))
+      then (* Standard situation of an object in another file: *)
+	(* Thanks to the "open" of this file we remove its name *)
+	dottify rls'
+      else match visible_clash_dbg base (Mod,base_s) with
+	| None -> dottify rls
+	| Some (mp,l) -> error_module_clash base (MPdot (mp,l))
+
+(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *)
+
+let pp_ocaml_gen k mp rls olab =
+  match common_prefix_from_list mp (get_visible_mps ()) with
+    | Some prefix -> pp_ocaml_local k prefix mp rls olab
+    | None ->
+	let base = base_mp mp in
+	if is_mp_bound base then pp_ocaml_bound base rls
+	else pp_ocaml_extern k base rls
+
+(* For Haskell, things are simplier: we have removed (almost) all structures *)
+
+let pp_haskell_gen k mp rls = match rls with
+  | [] -> assert false
+  | s::rls' ->
+      (if base_mp mp <> top_visible_mp () then s ^ "." else "") ^
+	(if upperkind k then "" else "_") ^ pseudo_qualify rls'
+
+(* Main name printing function for a reference *)
 
 let pp_global k r =
   let ls = ref_renaming (k,r) in
   assert (List.length ls > 1);
   let s = List.hd ls in
-  let mp = subst_mp (modpath_of_r r) in
+  let mp,_,l = repr_of_r r in
   if mp = top_visible_mp () then
     (* simpliest situation: definition of r (or use in the same context) *)
     (* we update the visible environment *)
-    (add_visible (k,s); unquote s)
-  else match lang () with
-    | Scheme -> unquote s (* no modular Scheme extraction... *)
-    | Haskell -> if modular () then dottify ls else s
-	(* for the moment we always qualify in modular Haskell... *)
-    | Ocaml -> pp_gen k mp ls (Some (label_of_r r))
+    (add_visible (k,s) l; unquote s)
+  else
+    let rls = List.rev ls in (* for what come next it's easier this way *)
+    match lang () with
+      | Scheme -> unquote s (* no modular Scheme extraction... *)
+      | Haskell -> if modular () then pp_haskell_gen k mp rls else s
+      | Ocaml -> pp_ocaml_gen k mp rls (Some l)
 
 (* The next function is used only in Ocaml extraction...*)
+
 let pp_module mp =
-  let mp = subst_mp mp in
   let ls = mp_renaming mp in
-  if List.length ls = 1 then dottify ls
-  else match mp with
-    | MPdot (mp0,_) when mp0 = top_visible_mp () ->
+  match mp with
+    | MPdot (mp0,l) when mp0 = top_visible_mp () ->
 	(* simpliest situation: definition of mp (or use in the same context) *)
 	(* we update the visible environment *)
 	let s = List.hd ls in
-	add_visible (Mod,s); s
-    | _ -> pp_gen Mod mp ls None
+	add_visible (Mod,s) l; s
+    | _ -> pp_ocaml_gen Mod mp (List.rev ls) None
 
 
diff --git a/contrib/extraction/common.mli b/plugins/extraction/common.mli
index b7e70414..93be15d1 100644
--- a/contrib/extraction/common.mli
+++ b/plugins/extraction/common.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.mli 11559 2008-11-07 22:03:34Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Names
 open Libnames
@@ -19,7 +19,7 @@ val space_if : bool -> std_ppcmds
 val sec_space_if : bool -> std_ppcmds
 
 val pp_par : bool -> std_ppcmds -> std_ppcmds
-val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds 
+val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds
 val pr_binding : identifier list -> std_ppcmds
 
 val rename_id : identifier -> Idset.t -> identifier
@@ -28,7 +28,7 @@ type env = identifier list * Idset.t
 val empty_env : unit -> env
 
 val rename_vars: Idset.t -> identifier list -> env
-val rename_tvars: Idset.t -> identifier list -> identifier list 
+val rename_tvars: Idset.t -> identifier list -> identifier list
 val push_vars : identifier list -> env -> identifier list * env
 val get_db_name : int -> env -> identifier
 
@@ -45,7 +45,9 @@ val pp_global : kind -> global_reference -> string
 val pp_module : module_path -> string
 
 val top_visible_mp : unit -> module_path
-val push_visible : module_path -> mod_self_id option -> unit
+(* In [push_visible], the [module_path list] corresponds to
+   module parameters, the innermost one coming first in the list *)
+val push_visible : module_path -> module_path list -> unit
 val pop_visible : unit -> unit
 
 val check_duplicate : module_path -> label -> string
diff --git a/contrib/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 057a7b29..ab9c242a 100644
--- a/contrib/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.ml 13201 2010-06-25 22:36:27Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Term
 open Declarations
@@ -25,332 +25,346 @@ open Mod_subst
 (*S Part I: computing Coq environment. *)
 (***************************************)
 
-let toplevel_env () = 
-  let seg = Lib.contents_after None in 
-  let get_reference = function 
+let toplevel_env () =
+  let seg = Lib.contents_after None in
+  let get_reference = function
     | (_,kn), Lib.Leaf o ->
-	let mp,_,l = repr_kn kn in 
+	let mp,_,l = repr_kn kn in
 	let seb = match Libobject.object_tag o with
 	  | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn))
-	  | "INDUCTIVE" -> SFBmind (Global.lookup_mind kn) 
+	  | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn))
 	  | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l)))
-	  | "MODULE TYPE" -> 
+	  | "MODULE TYPE" ->
 	      SFBmodtype (Global.lookup_modtype (MPdot (mp,l)))
 	  | _ -> failwith "caught"
 	in l,seb
     | _ -> failwith "caught"
-  in 
-  match current_toplevel () with 
-    | MPself msid -> SEBstruct (msid, List.rev (map_succeed get_reference seg))
-    | _ -> assert false
+  in
+  match current_toplevel () with
+    | _ -> SEBstruct (List.rev (map_succeed get_reference seg))
+ 
 
-let environment_until dir_opt = 
-  let rec parse = function 
+let environment_until dir_opt =
+  let rec parse = function
     | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
-    | [] -> [] 
-    | d :: l -> 
-	match (Global.lookup_module (MPfile d)).mod_expr with 
-	  | Some meb -> 
+    | [] -> []
+    | d :: l ->
+	match (Global.lookup_module (MPfile d)).mod_expr with
+	  | Some meb ->
 	      if dir_opt = Some d then [MPfile d, meb]
 	      else (MPfile d, meb) :: (parse l)
 	  | _ -> assert false
   in parse (Library.loaded_libraries ())
 
 
-(*s Visit: 
+(*s Visit:
   a structure recording the needed dependencies for the current extraction *)
 
-module type VISIT = sig 
+module type VISIT = sig
   (* Reset the dependencies by emptying the visit lists *)
   val reset : unit -> unit
-    
-  (* Add the module_path and all its prefixes to the mp visit list *)  
+
+  (* Add the module_path and all its prefixes to the mp visit list *)
   val add_mp : module_path -> unit
-    
-  (* Add kernel_name / constant / reference / ... in the visit lists. 
+
+  (* Add kernel_name / constant / reference / ... in the visit lists.
      These functions silently add the mp of their arg in the mp list *)
-  val add_kn : kernel_name -> unit
+  val add_kn : mutual_inductive -> unit
   val add_con : constant -> unit
   val add_ref : global_reference -> unit
   val add_decl_deps : ml_decl -> unit
   val add_spec_deps : ml_spec -> unit
 
-  (* Test functions: 
+  (* Test functions:
      is a particular object a needed dependency for the current extraction ? *)
-  val needed_kn : kernel_name -> bool 
+  val needed_kn : mutual_inductive -> bool
   val needed_con : constant -> bool
   val needed_mp : module_path -> bool
 end
-  
-module Visit : VISIT = struct 
+
+module Visit : VISIT = struct
   (* What used to be in a single KNset should now be split into a KNset
      (for inductives and modules names) and a Cset for constants
      (and still the remaining MPset) *)
-  type must_visit = 
-      { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t }
+  type must_visit =
+      { mutable kn : Mindset.t; mutable con : Cset.t; mutable mp : MPset.t }
   (* the imperative internal visit lists *)
-  let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } 
+  let v = { kn = Mindset.empty ; con = Cset.empty ; mp = MPset.empty }
   (* the accessor functions *)
-  let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
-  let needed_kn kn = KNset.mem kn v.kn
+  let reset () = v.kn <- Mindset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
+  let needed_kn kn = Mindset.mem kn v.kn
   let needed_con c = Cset.mem c v.con
   let needed_mp mp = MPset.mem mp v.mp
-  let add_mp mp = 
+  let add_mp mp =
     check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp
-  let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn)
+  let add_kn kn = v.kn <- Mindset.add kn v.kn; add_mp (mind_modpath kn)
   let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c)
-  let add_ref = function 
+  let add_ref = function
     | ConstRef c -> add_con c
     | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn
     | VarRef _ -> assert false
-  let add_decl_deps = decl_iter_references add_ref add_ref add_ref 
+  let add_decl_deps = decl_iter_references add_ref add_ref add_ref
   let add_spec_deps = spec_iter_references add_ref add_ref add_ref
 end
 
 exception Impossible
 
-let check_arity env cb = 
+let check_arity env cb =
   let t = Typeops.type_of_constant_type env cb.const_type in
   if Reduction.is_arity env t then raise Impossible
 
-let check_fix env cb i = 
-  match cb.const_body with 
+let check_fix env cb i =
+  match cb.const_body with
     | None -> raise Impossible
-    | Some lbody -> 
-	match kind_of_term (Declarations.force lbody) with 
+    | Some lbody ->
+	match kind_of_term (Declarations.force lbody) with
 	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
 	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
 	  | _ -> raise Impossible
 
-let factor_fix env l cb msb = 
-  let _,recd as check = check_fix env cb 0 in 
+let factor_fix env l cb msb =
+  let _,recd as check = check_fix env cb 0 in
   let n = Array.length (let fi,_,_ = recd in fi) in
   if n = 1 then [|l|], recd, msb
-  else begin 
-    if List.length msb < n-1 then raise Impossible; 
-    let msb', msb'' = list_chop (n-1) msb in 
-    let labels = Array.make n l in 
-    list_iter_i 
-      (fun j -> 
-	 function 
-	   | (l,SFBconst cb') -> 
-	       if check <> check_fix env cb' (j+1) then raise Impossible; 
-	       labels.(j+1) <- l; 
-	   | _ -> raise Impossible) msb'; 
+  else begin
+    if List.length msb < n-1 then raise Impossible;
+    let msb', msb'' = list_chop (n-1) msb in
+    let labels = Array.make n l in
+    list_iter_i
+      (fun j ->
+	 function
+	   | (l,SFBconst cb') ->
+	       if check <> check_fix env cb' (j+1) then raise Impossible;
+	       labels.(j+1) <- l;
+	   | _ -> raise Impossible) msb';
     labels, recd, msb''
   end
 
-let build_mb expr typ_opt =
-  { mod_expr = Some expr;
-    mod_type = typ_opt;
-    mod_constraints = Univ.Constraint.empty;
-    mod_alias = Mod_subst.empty_subst;
-    mod_retroknowledge = [] }
+(** Expanding a [struct_expr_body] into a version without abbreviations
+    or functor applications. This is done via a detour to entries
+    (hack proposed by Elie)
+*)
+
+let rec seb2mse = function
+  | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s')
+  | SEBident mp -> Entries.MSEident mp
+  | _ -> failwith "seb2mse: received a non-atomic seb"
+
+let expand_seb env mp seb =
+  let seb,_,_,_ =
+    Mod_typing.translate_struct_module_entry env mp true (seb2mse seb)
+  in seb
+
+(** When possible, we use the nicer, shorter, algebraic type structures
+    instead of the expanded ones. *)
+
+let my_type_of_mb mb =
+  let m0 = mb.mod_type in
+  match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0
 
-let my_type_of_mb env mb =
-  match mb.mod_type with
-    | Some mtb -> mtb
-    | None -> Modops.eval_struct env (Option.get mb.mod_expr)
+let my_type_of_mtb mtb =
+  let m0 = mtb.typ_expr in
+  match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0
 
 (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def].
     To check with Elie. *)
 
-let env_for_mtb_with env mtb idl =
-  let msid,sig_b = match Modops.eval_struct env mtb with
-    | SEBstruct(msid,sig_b) -> msid,sig_b
+let rec msid_of_seb = function
+  | SEBident mp -> mp
+  | SEBwith (seb,_) -> msid_of_seb seb
+  | _ -> assert false
+
+let env_for_mtb_with env mp seb idl =
+  let sig_b = match seb with
+    | SEBstruct(sig_b) -> sig_b
     | _ -> assert false
   in
   let l = label_of_id (List.hd idl) in
-  let before = fst (list_split_at (fun (l',_) -> l=l') sig_b) in
-  Modops.add_signature (MPself msid) before env
+  let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in
+  Modops.add_signature mp before empty_delta_resolver env
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
    to specifications. *)
 
-let rec extract_sfb_spec env mp = function 
-  | [] -> [] 
-  | (l,SFBconst cb) :: msig -> 
-      let kn = make_con mp empty_dirpath l in 
-      let s = extract_constant_spec env kn cb in 
+let rec extract_sfb_spec env mp = function
+  | [] -> []
+  | (l,SFBconst cb) :: msig ->
+      let kn = make_con mp empty_dirpath l in
+      let s = extract_constant_spec env kn cb in
       let specs = extract_sfb_spec env mp msig in
-      if logical_spec s then specs 
+      if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
-  | (l,SFBmind _) :: msig -> 
-      let kn = make_kn mp empty_dirpath l in 
-      let s = Sind (kn, extract_inductive env kn) in 
+  | (l,SFBmind _) :: msig ->
+      let kn = make_kn mp empty_dirpath l in
+      let mind = mind_of_kn kn in
+      let s = Sind (kn, extract_inductive env mind) in
       let specs = extract_sfb_spec env mp msig in
-      if logical_spec s then specs 
+      if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
-  | (l,SFBmodule mb) :: msig -> 
-      let specs = extract_sfb_spec env mp msig in 
-      let spec = extract_seb_spec env (my_type_of_mb env mb) in
+  | (l,SFBmodule mb) :: msig ->
+      let specs = extract_sfb_spec env mp msig in
+      let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb mb) in
       (l,Smodule spec) :: specs
-  | (l,SFBmodtype mtb) :: msig -> 
+  | (l,SFBmodtype mtb) :: msig ->
       let specs = extract_sfb_spec env mp msig in
-      (l,Smodtype (extract_seb_spec env mtb.typ_expr)) :: specs
-  | (l,SFBalias(mp1,typ_opt,_))::msig -> 
-      let mb = build_mb (SEBident mp1) typ_opt in
-      extract_sfb_spec env mp ((l,SFBmodule mb) :: msig)
+      let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in
+      (l,Smodtype spec) :: specs
 
 (* From [struct_expr_body] to specifications *)
 
-(* Invariant: the [seb] given to [extract_seb_spec] should either come:
-   - from a [mod_type] or [type_expr] field
-   - from the output of [Modops.eval_struct].
+(* Invariant: the [seb] given to [extract_seb_spec] should either come
+   from a [mod_type] or [type_expr] field, or their [_alg] counterparts.
    This way, any encountered [SEBident] should be a true module type.
-   For instance, [my_type_of_mb] ensures this invariant.
 *)
 
-and extract_seb_spec env = function
+and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
   | SEBident mp -> Visit.add_mp mp; MTident mp
-  | SEBwith(mtb',With_definition_body(idl,cb))->
-      let env' = env_for_mtb_with env mtb' idl in
-      let mtb''= extract_seb_spec env mtb' in
+  | SEBwith(seb',With_definition_body(idl,cb))->
+      let env' = env_for_mtb_with env (msid_of_seb seb') seb idl in
+      let mt = extract_seb_spec env mp1 (seb,seb') in
       (match extract_with_type env' cb with (* cb peut contenir des kn  *)
-	 | None ->  mtb''
-	 | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ)))
-  | SEBwith(mtb',With_module_body(idl,mp,_,_))-> 
+	 | None -> mt
+	 | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ)))
+  | SEBwith(seb',With_module_body(idl,mp))->
       Visit.add_mp mp;
-      MTwith(extract_seb_spec env mtb',
+      MTwith(extract_seb_spec env mp1 (seb,seb'),
 	     ML_With_module(idl,mp))
-(* TODO: On pourrait peut-etre oter certaines eta-expansion, du genre:
-   | SEBfunctor(mbid,_,SEBapply(m,SEBident (MPbound mbid2),_)) 
-     when mbid = mbid2 -> extract_seb_spec env m 
-   (* faudrait alors ajouter un test de non-apparition de mbid dans mb *)
-*)
-  | SEBfunctor (mbid, mtb, mtb') -> 
-      let mp = MPbound mbid in 
-      let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in
-      MTfunsig (mbid, extract_seb_spec env mtb.typ_expr,
-		extract_seb_spec env' mtb')
-  | SEBstruct (msid, msig) -> 
-      let mp = MPself msid in 
-      let env' = Modops.add_signature mp msig env in 
-	MTsig (msid, extract_sfb_spec env' mp msig) 
-  | SEBapply _ as mtb ->
-      extract_seb_spec env (Modops.eval_struct env mtb)
+  | SEBfunctor (mbid, mtb, seb_alg') ->
+      let seb' = match seb with
+	| SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb'
+	| _ -> assert false
+      in
+      let mp = MPbound mbid in
+      let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in
+      MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb),
+		extract_seb_spec env' mp1 (seb',seb_alg'))
+  | SEBstruct (msig) ->
+      let env' = Modops.add_signature mp1 msig empty_delta_resolver env in
+      MTsig (mp1, extract_sfb_spec env' mp1 msig)
+  | SEBapply _ ->
+      if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb)
+      else assert false
+
 
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
-   to implementations. 
+   to implementations.
 
    NB: when [all=false], the evaluation order of the list is
    important: last to first ensures correct dependencies.
 *)
 
-let rec extract_sfb env mp all = function 
-  | [] -> [] 
-  | (l,SFBconst cb) :: msb -> 
-      (try 
-	 let vl,recd,msb = factor_fix env l cb msb in 
+let rec extract_sfb env mp all = function
+  | [] -> []
+  | (l,SFBconst cb) :: msb ->
+      (try
+	 let vl,recd,msb = factor_fix env l cb msb in
 	 let vc = Array.map (make_con mp empty_dirpath) vl in
-	 let ms = extract_sfb env mp all msb in 
-	 let b = array_exists Visit.needed_con vc in 
-	 if all || b then 
+	 let ms = extract_sfb env mp all msb in
+	 let b = array_exists Visit.needed_con vc in
+	 if all || b then
 	   let d = extract_fixpoint env vc recd in
-	   if (not b) && (logical_decl d) then ms 
+	   if (not b) && (logical_decl d) then ms
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms
        with Impossible ->
-	 let ms = extract_sfb env mp all msb in 
-	 let c = make_con mp empty_dirpath l in 
-	 let b = Visit.needed_con c in 
-	 if all || b then 
+	 let ms = extract_sfb env mp all msb in
+	 let c = make_con mp empty_dirpath l in
+	 let b = Visit.needed_con c in
+	 if all || b then
 	   let d = extract_constant env c cb in
-	   if (not b) && (logical_decl d) then ms 
+	   if (not b) && (logical_decl d) then ms
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms)
   | (l,SFBmind mib) :: msb ->
       let ms = extract_sfb env mp all msb in
-      let kn = make_kn mp empty_dirpath l in 
-      let b = Visit.needed_kn kn in
-      if all || b then 
-	let d = Dind (kn, extract_inductive env kn) in 
-	if (not b) && (logical_decl d) then ms 
+      let kn = make_kn mp empty_dirpath l in
+      let mind = mind_of_kn kn in
+      let b = Visit.needed_kn mind in
+      if all || b then
+	let d = Dind (kn, extract_inductive env mind) in
+	if (not b) && (logical_decl d) then ms
 	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
-  | (l,SFBmodule mb) :: msb -> 
+  | (l,SFBmodule mb) :: msb ->
       let ms = extract_sfb env mp all msb in
-      let mp = MPdot (mp,l) in 
-      if all || Visit.needed_mp mp then 
+      let mp = MPdot (mp,l) in
+      if all || Visit.needed_mp mp then
 	(l,SEmodule (extract_module env mp true mb)) :: ms
       else ms
   | (l,SFBmodtype mtb) :: msb ->
       let ms = extract_sfb env mp all msb in
       let mp = MPdot (mp,l) in
-       if all || Visit.needed_mp mp then 
-	(l,SEmodtype (extract_seb_spec env mtb.typ_expr)) :: ms
+       if all || Visit.needed_mp mp then
+	(l,SEmodtype (extract_seb_spec env mp (my_type_of_mtb mtb))) :: ms
       else ms
-  | (l,SFBalias (mp1,typ_opt,_)) :: msb ->
-      let mb = build_mb (SEBident mp1) typ_opt in
-      extract_sfb env mp all ((l,SFBmodule mb) :: msb)
 
 (* From [struct_expr_body] to implementations *)
 
-and extract_seb env mpo all = function 
-  | SEBident mp ->  
-      if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; 
-      Visit.add_mp mp; MEident mp 
-  | SEBapply (meb, meb',_) -> 
-      MEapply (extract_seb env None true meb, 
-	       extract_seb env None true meb')
-  | SEBfunctor (mbid, mtb, meb) -> 
-      let mp = MPbound mbid in 
-      let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
-      MEfunctor (mbid, extract_seb_spec env mtb.typ_expr,
-		 extract_seb env' None true meb)
-  | SEBstruct (msid, msb) -> 
-      let mp,msb = match mpo with 
-	| None -> MPself msid, msb 
-	| Some mp -> mp, Modops.subst_structure (map_msid msid mp) msb
-      in 
-      let env' = Modops.add_signature mp msb env in 
-      MEstruct (msid, extract_sfb env' mp all msb) 
+and extract_seb env mp all = function
+  | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml ->
+      (* in Haskell/Scheme, we expand everything *)
+      extract_seb env mp all (expand_seb env mp seb)
+  | SEBident mp ->
+      if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false;
+      Visit.add_mp mp; MEident mp
+  | SEBapply (meb, meb',_) ->
+      MEapply (extract_seb env mp true meb,
+	       extract_seb env mp true meb')
+  | SEBfunctor (mbid, mtb, meb) ->
+      let mp1 = MPbound mbid in
+      let env' = Modops.add_module (Modops.module_body_of_type  mp1 mtb)
+	env  in
+      MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb),
+		 extract_seb env' mp true meb)
+  | SEBstruct (msb) ->
+      let env' = Modops.add_signature mp msb empty_delta_resolver env in
+      MEstruct (mp,extract_sfb env' mp all msb)
   | SEBwith (_,_) -> anomaly "Not available yet"
 
-and extract_module env mp all mb = 
+and extract_module env mp all mb =
   (* [mb.mod_expr <> None ], since we look at modules from outside. *)
   (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *)
-  { ml_mod_expr = extract_seb env (Some mp) all (Option.get mb.mod_expr);
-    ml_mod_type = extract_seb_spec env (my_type_of_mb env mb) }
+  { ml_mod_expr = extract_seb env mp all (Option.get mb.mod_expr);
+    ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) }
 
 
-let unpack = function MEstruct (_,sel) -> sel | _ -> assert false 
+let unpack = function MEstruct (_,sel) -> sel | _ -> assert false
 
-let mono_environment refs mpl = 
+let mono_environment refs mpl =
   Visit.reset ();
-  List.iter Visit.add_ref refs; 
-  List.iter Visit.add_mp mpl; 
-  let env = Global.env () in 
-  let l = List.rev (environment_until None) in 
-  List.rev_map 
-    (fun (mp,m) -> mp, unpack (extract_seb env (Some mp) false m)) l
+  List.iter Visit.add_ref refs;
+  List.iter Visit.add_mp mpl;
+  let env = Global.env () in
+  let l = List.rev (environment_until None) in
+  List.rev_map
+    (fun (mp,m) -> mp, unpack (extract_seb env mp false m)) l
 
 (**************************************)
 (*S Part II : Input/Output primitives *)
 (**************************************)
 
-let descr () = match lang () with 
-  | Ocaml -> Ocaml.ocaml_descr 
-  | Haskell -> Haskell.haskell_descr 
+let descr () = match lang () with
+  | Ocaml -> Ocaml.ocaml_descr
+  | Haskell -> Haskell.haskell_descr
   | Scheme -> Scheme.scheme_descr
 
-(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" 
+(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli"
    Works similarly for the other languages. *)
 
 let default_id = id_of_string "Main"
 
-let mono_filename f = 
-  let d = descr () in 
-  match f with 
+let mono_filename f =
+  let d = descr () in
+  match f with
     | None -> None, None, default_id
-    | Some f -> 
-	let f = 
-	  if Filename.check_suffix f d.file_suffix then 
-	    Filename.chop_suffix f d.file_suffix 
+    | Some f ->
+	let f =
+	  if Filename.check_suffix f d.file_suffix then
+	    Filename.chop_suffix f d.file_suffix
 	  else f
 	in
-	let id = 
+	let id =
 	  if lang () <> Haskell then default_id
 	  else try id_of_string (Filename.basename f)
 	  with _ -> error "Extraction: provided filename is not a valid identifier"
@@ -359,11 +373,10 @@ let mono_filename f =
 
 (* Builds a suitable filename from a module id *)
 
-let module_filename fc =
+let module_filename mp =
+  let f = file_of_modfile mp in
   let d = descr () in
-  let fn = if d.capital_file then fc else String.uncapitalize fc
-  in
-  Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, id_of_string fc
+  Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f
 
 (*s Extraction of one decl to stdout. *)
 
@@ -373,7 +386,7 @@ let print_one_decl struc mp decl =
   set_phase Pre;
   ignore (d.pp_struct struc);
   set_phase Impl;
-  push_visible mp None;
+  push_visible mp [];
   msgnl (d.pp_decl decl);
   pop_visible ()
 
@@ -392,11 +405,11 @@ let print_structure_to_file (fn,si,mo) dry struc =
   let d = descr () in
   reset_renaming_tables AllButExternal;
   let unsafe_needs = {
-    mldummy = struct_ast_search ((=) MLdummy) struc; 
-    tdummy = struct_type_search Mlutil.isDummy struc; 
-    tunknown = struct_type_search ((=) Tunknown) struc; 
-    magic = 
-      if lang () <> Haskell then false 
+    mldummy = struct_ast_search ((=) MLdummy) struc;
+    tdummy = struct_type_search Mlutil.isDummy struc;
+    tunknown = struct_type_search ((=) Tunknown) struc;
+    magic =
+      if lang () <> Haskell then false
       else struct_ast_search (function MLmagic _ -> true | _ -> false) struc }
   in
   (* First, a dry run, for computing objects to rename or duplicate *)
@@ -412,8 +425,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
     set_phase Impl;
     msg_with ft (d.preamble mo opened unsafe_needs);
     msg_with ft (d.pp_struct struc);
-    Option.iter close_out cout; 
-  with e -> 
+    Option.iter close_out cout;
+  with e ->
     Option.iter close_out cout; raise e
   end;
   if not dry then Option.iter info_file fn;
@@ -427,9 +440,9 @@ let print_structure_to_file (fn,si,mo) dry struc =
 	 msg_with ft (d.sig_preamble mo opened unsafe_needs);
 	 msg_with ft (d.pp_sig (signature_of_structure struc));
 	 close_out cout;
-       with e -> 
-	 close_out cout; raise e 
-       end; 
+       with e ->
+	 close_out cout; raise e
+       end;
        info_file si)
     (if dry then None else si)
 
@@ -439,10 +452,10 @@ let print_structure_to_file (fn,si,mo) dry struc =
 (*********************************************)
 
 
-let reset () =  
+let reset () =
   Visit.reset (); reset_tables (); reset_renaming_tables Everything
 
-let init modular = 
+let init modular =
   check_inside_section (); check_inside_module ();
   set_keywords (descr ()).keywords;
   set_modular modular;
@@ -467,8 +480,8 @@ let rec locate_ref = function
 	    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 
-    extracting to a file with the command: 
+    \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when
+    extracting to a file with the command:
     \verb!Extraction "file"! [qualid1] ... [qualidn]. *)
 
 let full_extr f (refs,mps) =
@@ -481,8 +494,7 @@ let full_extr f (refs,mps) =
 
 let full_extraction f lr = full_extr f (locate_ref lr)
 
-
-(*s Simple extraction in the Coq toplevel. The vernacular command 
+(*s Simple extraction in the Coq toplevel. The vernacular command
     is \verb!Extraction! [qualid]. *)
 
 let simple_extraction r = match locate_ref [r] with
@@ -498,21 +510,21 @@ let simple_extraction r = match locate_ref [r] with
   | _ -> assert false
 
 
-(*s (Recursive) Extraction of a library. The vernacular command is 
-  \verb!(Recursive) Extraction Library! [M]. *) 
+(*s (Recursive) Extraction of a library. The vernacular command is
+  \verb!(Recursive) Extraction Library! [M]. *)
 
 let extraction_library is_rec m =
-  init true; 
-  let dir_m = 
-    let q = make_short_qualid m in 
+  init true;
+  let dir_m =
+    let q = qualid_of_ident m in
     try Nametab.full_name_module q with Not_found -> error_unknown_module q
-  in 
-  Visit.add_mp (MPfile dir_m); 
-  let env = Global.env () in	
-  let l = List.rev (environment_until (Some dir_m)) in 
-  let select l (mp,meb) = 
-    if Visit.needed_mp mp 
-    then (mp, unpack (extract_seb env (Some mp) true meb)) :: l 
+  in
+  Visit.add_mp (MPfile dir_m);
+  let env = Global.env () in
+  let l = List.rev (environment_until (Some dir_m)) in
+  let select l (mp,meb) =
+    if Visit.needed_mp mp
+    then (mp, unpack (extract_seb env mp true meb)) :: l
     else l
   in
   let struc = List.fold_left select [] l in
@@ -521,8 +533,7 @@ let extraction_library is_rec m =
   let print = function
     | (MPfile dir as mp, sel) as e ->
 	let dry = not is_rec && dir <> dir_m in
-	let s = string_of_modfile mp in
-	print_structure_to_file (module_filename s) dry [e]
+	print_structure_to_file (module_filename mp) dry [e]
     | _ -> assert false
   in
   List.iter print struc;
diff --git a/contrib/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 8d906985..dcb4601e 100644
--- a/contrib/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.mli 10895 2008-05-07 16:06:26Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*s This module declares the extraction commands. *)
 
@@ -19,5 +19,5 @@ val extraction_library : bool -> identifier -> unit
 
 (* For debug / external output via coqtop.byte + Drop : *)
 
-val mono_environment : 
+val mono_environment :
  global_reference list -> module_path list -> Miniml.ml_structure
diff --git a/contrib/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 2cf457c6..99682ae6 100644
--- a/contrib/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.ml 11897 2009-02-09 19:28:02Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -20,7 +20,7 @@ open Inductive
 open Termops
 open Inductiveops
 open Recordops
-open Nameops
+open Namegen
 open Summary
 open Libnames
 open Nametab
@@ -44,18 +44,18 @@ let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None
 
 (*S Generation of flags and signatures. *)
 
-(* The type [flag] gives us information about any Coq term: 
+(* The type [flag] gives us information about any Coq term:
    \begin{itemize}
-   \item [TypeScheme] denotes a type scheme, that is 
-     something that will become a type after enough applications. 
-     More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with 
-     [s = Set], [Prop] or [Type] 
-   \item [Default] denotes the other cases. It may be inexact after 
+   \item [TypeScheme] denotes a type scheme, that is
+     something that will become a type after enough applications.
+     More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with
+     [s = Set], [Prop] or [Type]
+   \item [Default] denotes the other cases. It may be inexact after
      instanciation. For example [(X:Type)X] is [Default] and may give [Set]
      after instanciation, which is rather [TypeScheme]
    \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
-   \item [Info] is the opposite. The same example [(X:Type)X] shows 
-     that an [Info] term might in fact be [Logic] later on. 
+   \item [Info] is the opposite. The same example [(X:Type)X] shows
+     that an [Info] term might in fact be [Logic] later on.
    \end{itemize} *)
 
 type info = Logic | Info
@@ -64,11 +64,11 @@ type scheme = TypeScheme | Default
 
 type flag = info * scheme
 
-(*s [flag_of_type] transforms a type [t] into a [flag]. 
+(*s [flag_of_type] transforms a type [t] into a [flag].
   Really important function. *)
 
-let rec flag_of_type env t = 
-  let t = whd_betadeltaiota env none t in 
+let rec flag_of_type env t =
+  let t = whd_betadeltaiota env none t in
   match kind_of_term t with
     | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
     | Sort (Prop Null) -> (Logic,TypeScheme)
@@ -81,8 +81,8 @@ let is_default env t = (flag_of_type env t = (Info, Default))
 
 exception NotDefault of kill_reason
 
-let check_default env t = 
-  match flag_of_type env t with 
+let check_default env t =
+  match flag_of_type env t with
     | _,TypeScheme -> raise (NotDefault Ktype)
     | Logic,_ -> raise (NotDefault Kother)
     | _ -> ()
@@ -91,17 +91,17 @@ let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
 
 (*s [type_sign] gernerates a signature aimed at treating a type application. *)
 
-let rec type_sign env c = 
+let rec type_sign env c =
   match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) -> 
+    | Prod (n,t,d) ->
 	(if is_info_scheme env t then Keep else Kill Kother)
 	:: (type_sign (push_rel_assum (n,t) env) d)
     | _ -> []
 
-let rec type_scheme_nb_args env c = 
+let rec type_scheme_nb_args env c =
   match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) -> 
-	let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in 
+    | 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
     | _ -> 0
 
@@ -109,128 +109,152 @@ let _ = register_type_scheme_nb_args type_scheme_nb_args
 
 (*s [type_sign_vl] does the same, plus a type var list. *)
 
-let rec type_sign_vl env c = 
+let rec type_sign_vl env c =
   match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) -> 
-	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in 
+    | Prod (n,t,d) ->
+	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in
 	if not (is_info_scheme env t) then Kill Kother::s, vl
 	else Keep::s, (next_ident_away (id_of_name n) vl) :: vl
     | _ -> [],[]
 
-let rec nb_default_params env c = 
+let rec nb_default_params env c =
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) ->
-	let n = nb_default_params (push_rel_assum (n,t) env) d in 
+	let n = nb_default_params (push_rel_assum (n,t) env) d in
 	if is_default env t then n+1 else n
     | _ -> 0
 
+(* Enriching a signature with implicit information *)
+
+let sign_with_implicits r s =
+  let implicits = implicits_of_global r in
+  let rec add_impl i = function
+    | [] -> []
+    | sign::s ->
+	let sign' =
+	  if sign = Keep && List.mem i implicits then Kill Kother else sign
+	in sign' :: add_impl (succ i) s
+  in
+  add_impl 1 s
+
+(* Enriching a exception message *)
+
+let rec handle_exn r n fn_name = function
+  | MLexn s ->
+      (try Scanf.sscanf s "UNBOUND %d"
+	 (fun i ->
+	    assert ((0 < i) && (i <= n));
+	    MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i)))
+       with _ -> MLexn s)
+  | a -> ast_map (handle_exn r n fn_name) a
+
 (*S Management of type variable contexts. *)
 
-(* A De Bruijn variable context (db) is a context for translating Coq [Rel]  
+(* A De Bruijn variable context (db) is a context for translating Coq [Rel]
    into ML type [Tvar]. *)
 
 (*s From a type signature toward a type variable context (db). *)
 
-let db_from_sign s = 
-  let rec make i acc = function 
-    | [] -> acc  
+let db_from_sign s =
+  let rec make i acc = function
+    | [] -> acc
     | Keep :: l -> make (i+1) (i::acc) l
     | Kill _ :: l -> make i (0::acc) l
   in make 1 [] s
 
-(*s Create a type variable context from indications taken from 
-  an inductive type (see just below). *) 
+(*s Create a type variable context from indications taken from
+  an inductive type (see just below). *)
 
-let rec db_from_ind dbmap i = 
+let rec db_from_ind dbmap i =
   if i = 0 then []
   else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
 
-(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument 
+(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument
   of a constructor corresponds to the j-th type var of the ML inductive. *)
 
 (* \begin{itemize}
    \item [si] : signature of the inductive
-   \item [i] :  counter of Coq args for [(I args)] 
-   \item [j] : counter of ML type vars 
-   \item [relmax] : total args number of the constructor 
+   \item [i] :  counter of Coq args for [(I args)]
+   \item [j] : counter of ML type vars
+   \item [relmax] : total args number of the constructor
    \end{itemize} *)
 
-let parse_ind_args si args relmax = 
-  let rec parse i j = function 
+let parse_ind_args si args relmax =
+  let rec parse i j = function
     | [] -> Intmap.empty
     | Kill _ :: s -> parse (i+1) j s
-    | Keep :: s -> 
-      (match kind_of_term args.(i-1) with 
+    | Keep :: s ->
+      (match kind_of_term args.(i-1) with
 	 | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
 	 | _ -> parse (i+1) (j+1) s)
-  in parse 1 1 si 
+  in parse 1 1 si
 
 (*S Extraction of a type. *)
 
-(* [extract_type env db c args] is used to produce an ML type from the 
+(* [extract_type env db c args] is used to produce an ML type from the
    coq term [(c args)], which is supposed to be a Coq type. *)
 
 (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
 
-(* [j] stands for the next ML type var. [j=0] means we do not 
-   generate ML type var anymore (in subterms for example). *) 
+(* [j] stands for the next ML type var. [j=0] means we do not
+   generate ML type var anymore (in subterms for example). *)
 
 
-let rec extract_type env db j c args = 
+let rec extract_type env db j c args =
   match kind_of_term (whd_betaiotazeta Evd.empty c) with
     | App (d, args') ->
 	(* We just accumulate the arguments. *)
 	extract_type env db j d (Array.to_list args' @ args)
-    | Lambda (_,_,d) -> 
-	(match args with 
+    | Lambda (_,_,d) ->
+	(match args with
 	   | [] -> assert false (* otherwise the lambda would be reductible. *)
 	   | a :: args -> extract_type env db j (subst1 a d) args)
     | Prod (n,t,d) ->
-	assert (args = []); 
-	let env' = push_rel_assum (n,t) env in 
-	(match flag_of_type env t with 
-	   | (Info, Default) -> 
+	assert (args = []);
+	let env' = push_rel_assum (n,t) env in
+	(match flag_of_type env t with
+	   | (Info, Default) ->
 	       (* Standard case: two [extract_type] ... *)
-	       let mld = extract_type env' (0::db) j d [] in 
-	       (match expand env mld with 
+	       let mld = extract_type env' (0::db) j d [] in
+	       (match expand env mld with
 		  | Tdummy d -> Tdummy d
 		  | _ -> Tarr (extract_type env db 0 t [], mld))
-	   | (Info, TypeScheme) when j > 0 -> 
+	   | (Info, TypeScheme) when j > 0 ->
 	       (* A new type var. *)
-	       let mld = extract_type env' (j::db) (j+1) d [] in 
-	       (match expand env mld with 
+	       let mld = extract_type env' (j::db) (j+1) d [] in
+	       (match expand env mld with
 		  | Tdummy d -> Tdummy d
 		  | _ -> Tarr (Tdummy Ktype, mld))
-	   | _,lvl -> 
-	       let mld = extract_type env' (0::db) j d [] in 
-	       (match expand env mld with 
+	   | _,lvl ->
+	       let mld = extract_type env' (0::db) j d [] in
+	       (match expand env mld with
 		  | Tdummy d -> Tdummy d
-		  | _ -> 
+		  | _ ->
 		      let reason = if lvl=TypeScheme then Ktype else Kother in
 		      Tarr (Tdummy reason, mld)))
     | Sort _ -> Tdummy Ktype (* The two logical cases. *)
     | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother
-    | Rel n -> 
+    | Rel n ->
 	(match lookup_rel n env with
            | (_,Some t,_) -> extract_type env db j (lift n t) args
-	   | _ -> 
+	   | _ ->
 	       (* Asks [db] a translation for [n]. *)
-	       if n > List.length db then Tunknown 
-	       else let n' = List.nth db (n-1) in 
+	       if n > List.length db then Tunknown
+	       else let n' = List.nth db (n-1) in
 	       if n' = 0 then Tunknown else Tvar n')
-    | Const kn -> 
-	let r = ConstRef kn in 
-	let cb = lookup_constant kn env in 
-	let typ = Typeops.type_of_constant_type env cb.const_type in 
-	(match flag_of_type env typ with 
-	   | (Info, TypeScheme) -> 
-	       let mlt = extract_type_app env db (r, type_sign env typ) args in 
-	       (match cb.const_body with 
+    | Const kn ->
+	let r = ConstRef kn in
+	let cb = lookup_constant kn env in
+	let typ = Typeops.type_of_constant_type env cb.const_type in
+	(match flag_of_type env typ with
+	   | (Info, TypeScheme) ->
+	       let mlt = extract_type_app env db (r, type_sign env typ) args in
+	       (match cb.const_body with
 		  | None -> mlt
-		  | Some _ when is_custom r -> mlt 
-		  | Some lbody -> 
-		      let newc = applist (Declarations.force lbody, args) in 
-		      let mlt' = extract_type env db j newc [] in 
+		  | Some _ when is_custom r -> mlt
+		  | Some lbody ->
+		      let newc = applist (Declarations.force lbody, args) in
+		      let mlt' = extract_type env db j newc [] in
 		      (* ML type abbreviations interact badly with Coq *)
 		      (* reduction, so [mlt] and [mlt'] might be different: *)
 		      (* The more precise is [mlt'], extracted after reduction *)
@@ -238,34 +262,34 @@ let rec extract_type env db j c args =
 		      (* If possible, we take [mlt], otherwise [mlt']. *)
 		      if expand env mlt = expand env mlt' then mlt else mlt')
 	   | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
-	       (match cb.const_body with 
+	       (match cb.const_body with
 		  | None -> Tunknown (* Brutal approximation ... *)
-		  | Some lbody -> 
+		  | Some lbody ->
 		      (* We try to reduce. *)
-		      let newc = applist (Declarations.force lbody, args) in 
+		      let newc = applist (Declarations.force lbody, args) in
 		      extract_type env db j newc []))
     | Ind (kn,i) ->
-	let s = (extract_ind env kn).ind_packets.(i).ip_sign in  
+	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
     | _ -> assert false
 
-(* [extract_maybe_type] calls [extract_type] when used on a Coq type, 
+(* [extract_maybe_type] calls [extract_type] when used on a Coq type,
    and otherwise returns [Tdummy] or [Tunknown] *)
 
-and extract_maybe_type env db c = 
-  let t = whd_betadeltaiota env none (type_of env c) in 
-  if isSort t then extract_type env db 0 c [] 
+and extract_maybe_type env db c =
+  let t = whd_betadeltaiota env none (type_of env c) in
+  if isSort t then extract_type env db 0 c []
   else if sort_of env t = InProp then Tdummy Kother else Tunknown
 
-(*s Auxiliary function dealing with type application. 
-  Precondition: [r] is a type scheme represented by the signature [s], 
+(*s Auxiliary function dealing with type application.
+  Precondition: [r] is a type scheme represented by the signature [s],
   and is completely applied: [List.length args = List.length s]. *)
-		  
+
 and extract_type_app env db (r,s) args =
-  let ml_args = 
-    List.fold_right 
-      (fun (b,c) a -> if b=Keep then 
+  let ml_args =
+    List.fold_right
+      (fun (b,c) a -> if b=Keep then
 	 let p = List.length (fst (splay_prod env none (type_of env c))) in
          let db = iterate (fun l -> 0 :: l) p db in
          (extract_type_scheme env db c p) :: a
@@ -276,23 +300,23 @@ and extract_type_app env db (r,s) args =
 (*S Extraction of a type scheme. *)
 
 (* [extract_type_scheme env db c p] works on a Coq term [c] which is
-  an informative type scheme. It means that [c] is not a Coq type, but will 
-  be when applied to sufficiently many arguments ([p] in fact).  
+  an informative type scheme. It means that [c] is not a Coq type, but will
+  be when applied to sufficiently many arguments ([p] in fact).
   This function decomposes p lambdas, with eta-expansion if needed. *)
 
 (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
 
-and extract_type_scheme env db c p = 
-  if p=0 then extract_type env db 0 c [] 
-  else 
-    let c = whd_betaiotazeta Evd.empty c in 
-    match kind_of_term c with 
-      | Lambda (n,t,d) -> 
+and extract_type_scheme env db c p =
+  if p=0 then extract_type env db 0 c []
+  else
+    let c = whd_betaiotazeta Evd.empty c in
+    match kind_of_term c with
+      | Lambda (n,t,d) ->
           extract_type_scheme (push_rel_assum (n,t) env) db d (p-1)
-      | _ ->  
+      | _ ->
           let rels = fst (splay_prod env none (type_of env c)) in
-          let env = push_rels_assum rels env in  
-          let eta_args = List.rev_map mkRel (interval 1 p) in 
+          let env = push_rels_assum rels env in
+          let eta_args = List.rev_map mkRel (interval 1 p) in
           extract_type env db 0 (lift p c) eta_args
 
 
@@ -302,174 +326,179 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
   let mib = Environ.lookup_mind kn env in
   try
     (* For a same kn, we can get various bodies due to module substitutions.
-       We hence check that the mib has not changed from recording 
+       We hence check that the mib has not changed from recording
        time to retrieving time. Ideally we should also check the env. *)
-    let (mib0,ml_ind) = lookup_ind kn in 
-    if not (mib = mib0) then raise Not_found; 
+    let (mib0,ml_ind) = lookup_ind kn in
+    if not (mib = mib0) then raise Not_found;
     ml_ind
-  with Not_found -> 
+  with Not_found ->
     (* First, if this inductive is aliased via a Module, *)
     (* we process the original inductive. *)
-    Option.iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv; 
+    let equiv = 
+      if (canonical_mind kn) = (user_mind kn) then
+	NoEquiv
+      else
+	begin
+	  ignore (extract_ind env (mind_of_kn (canonical_mind kn)));
+	  Equiv (canonical_mind kn)
+	end
+    in
     (* Everything concerning parameters. *)
     (* We do that first, since they are common to all the [mib]. *)
-    let mip0 = mib.mind_packets.(0) in 
+    let mip0 = mib.mind_packets.(0) in
     let npar = mib.mind_nparams in
     let epar = push_rel_context mib.mind_params_ctxt env in
     (* First pass: we store inductive signatures together with *)
     (* their type var list. *)
-    let packets = 
-      Array.map 
+    let packets =
+      Array.map
 	(fun mip ->
 	   let b = snd (mind_arity mip) <> InProp in
 	   let ar = Inductive.type_of_inductive env (mib,mip) in
 	   let s,v = if b then type_sign_vl env ar else [],[] in
-	   let t = Array.make (Array.length mip.mind_nf_lc) [] in 
+	   let t = Array.make (Array.length mip.mind_nf_lc) [] in
 	   { ip_typename = mip.mind_typename;
 	     ip_consnames = mip.mind_consnames;
-	     ip_logical = (not b); 
-	     ip_sign = s; 
-	     ip_vars = v; 
-	     ip_types = t }) 
-	mib.mind_packets 
-    in 
+	     ip_logical = (not b);
+	     ip_sign = s;
+	     ip_vars = v;
+	     ip_types = t;
+	     ip_optim_id_ok = None })
+	mib.mind_packets
+    in
+
     add_ind kn mib
-      {ind_info = Standard; 
-       ind_nparams = npar; 
-       ind_packets = packets; 
-       ind_equiv = match mib.mind_equiv with 
-         | None -> NoEquiv 
-	 | Some kn -> Equiv kn
+      {ind_info = Standard;
+       ind_nparams = npar;
+       ind_packets = packets;
+       ind_equiv = equiv
       };
     (* Second pass: we extract constructors *)
     for i = 0 to mib.mind_ntypes - 1 do
-      let p = packets.(i) in 
+      let p = packets.(i) in
       if not p.ip_logical then
-	let types = arities_of_constructors env (kn,i) in 
-	for j = 0 to Array.length types - 1 do 
+	let types = arities_of_constructors env (kn,i) in
+	for j = 0 to Array.length types - 1 do
 	  let t = snd (decompose_prod_n npar types.(j)) in
-	  let prods,head = dest_prod epar t in 
-	  let nprods = List.length prods in 
+	  let prods,head = dest_prod epar t in
+	  let nprods = List.length prods in
           let args = match kind_of_term head with
             | App (f,args) -> args (* [kind_of_term f = Ind ip] *)
             | _ -> [||]
           in
-	  let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in 
-	  let db = db_from_ind dbmap npar in 
+	  let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in
+	  let db = db_from_ind dbmap npar in
 	  p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1)
 	done
     done;
     (* Third pass: we determine special cases. *)
-    let ind_info = 
-      try 
-	if not mib.mind_finite then raise (I Coinductive); 
-	if mib.mind_ntypes <> 1 then raise (I Standard); 
-	let p = packets.(0) in 
+    let ind_info =
+      try
+	if not mib.mind_finite then raise (I Coinductive);
+	if mib.mind_ntypes <> 1 then raise (I Standard);
+	let p = packets.(0) in
 	if p.ip_logical then raise (I Standard);
 	if Array.length p.ip_types <> 1 then raise (I Standard);
-	let typ = p.ip_types.(0) in 
-	let l = List.filter (fun t -> not (isDummy (expand env t))) typ in 
-	if List.length l = 1 && not (type_mem_kn kn (List.hd l)) 
-	then raise (I Singleton); 
+	let typ = p.ip_types.(0) in
+	let l = List.filter (fun t -> not (isDummy (expand env t))) typ in
+	if List.length l = 1 && not (type_mem_kn kn (List.hd l))
+	then raise (I Singleton);
 	if l = [] then raise (I Standard);
 	if not mib.mind_record then raise (I Standard);
-	let ip = (kn, 0) in 
-	let r = IndRef ip in 
-	if is_custom r then raise (I Standard); 
+	let ip = (kn, 0) in
+	let r = IndRef ip in
+	if is_custom r then raise (I Standard);
 	(* Now we're sure it's a record. *)
 	(* First, we find its field names. *)
-	let rec names_prod t = match kind_of_term t with 
+	let rec names_prod t = match kind_of_term t with
 	  | Prod(n,_,t) -> n::(names_prod t)
 	  | LetIn(_,_,_,t) -> names_prod t
 	  | Cast(t,_,_) -> names_prod t
 	  | _ -> []
-	in 
-	let field_names = 
-	  list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in 
+	in
+	let field_names =
+	  list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
 	assert (List.length field_names = List.length typ);
-	let projs = ref Cset.empty in 
-	let mp,d,_ = repr_kn kn in 
-	let rec select_fields l typs = match l,typs with 
+	let projs = ref Cset.empty in
+	let mp,d,_ = repr_mind kn in
+	let rec select_fields l typs = match l,typs with
 	  | [],[] -> []
-	  | (Name id)::l, typ::typs -> 
-	      if isDummy (expand env typ) then select_fields l typs 
-	      else  
-		let knp = make_con mp d (label_of_id id) in 
-		if not (List.exists isKill (type2signature env typ))
-		then 
-		  projs := Cset.add knp !projs; 
+	  | (Name id)::l, typ::typs ->
+	      if isDummy (expand env typ) then select_fields l typs
+	      else
+		let knp = make_con mp d (label_of_id id) in
+		if List.for_all ((=) Keep) (type2signature env typ)
+		then
+		  projs := Cset.add knp !projs;
 		(ConstRef knp) :: (select_fields l typs)
-	  | Anonymous::l, typ::typs -> 
+	  | Anonymous::l, typ::typs ->
 	      if isDummy (expand env typ) then select_fields l typs
 	      else error_record r
-	  | _ -> assert false 
-	in 
+	  | _ -> assert false
+	in
 	let field_glob = select_fields field_names typ
 	in
 	(* Is this record officially declared with its projections ? *)
 	(* If so, we use this information. *)
-	begin try 
+	begin try
 	  let n = nb_default_params env
             (Inductive.type_of_inductive env (mib,mip0))
 	  in
-	  List.iter 
-	    (Option.iter 
+	  List.iter
+	    (Option.iter
 	       (fun kn -> if Cset.mem kn !projs then add_projection n kn))
 	    (lookup_projections ip)
 	with Not_found -> ()
-	end; 
+	end;
 	Record field_glob
       with (I info) -> info
     in
-    let i = {ind_info = ind_info; 
-	     ind_nparams = npar; 
-	     ind_packets = packets; 
-	     ind_equiv = match mib.mind_equiv with 
-	       | None -> NoEquiv
-	       | Some kn -> Equiv kn }
+    let i = {ind_info = ind_info;
+	     ind_nparams = npar;
+	     ind_packets = packets;
+	     ind_equiv = equiv }
     in
-    add_ind kn mib i; 
+    add_ind kn mib i;
     i
 
-(*s [extract_type_cons] extracts the type of an inductive 
-  constructor toward the corresponding list of ML types. *)
+(*s [extract_type_cons] extracts the type of an inductive
+  constructor toward the corresponding list of ML types.
 
-(* \begin{itemize}
-   \item [db] is a context for translating Coq [Rel] into ML type [Tvar] 
-   \item [dbmap] is a translation map (produced by a call to [parse_in_args])
-   \item [i] is the rank of the current product (initially [params_nb+1]) 
-   \end{itemize} *)
+   - [db] is a context for translating Coq [Rel] into ML type [Tvar]
+   - [dbmap] is a translation map (produced by a call to [parse_in_args])
+   - [i] is the rank of the current product (initially [params_nb+1])
+*)
 
 and extract_type_cons env db dbmap c i =
-  match kind_of_term (whd_betadeltaiota env none c) with 
-    | Prod (n,t,d) -> 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) ->
 	let env' = push_rel_assum (n,t) env in
 	let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
-	let l = extract_type_cons env' db' dbmap d (i+1) in 
-	(extract_type env db 0 t []) :: l 
-    | _ -> [] 
+	let l = extract_type_cons env' db' dbmap d (i+1) in
+	(extract_type env db 0 t []) :: l
+    | _ -> []
 
 (*s Recording the ML type abbreviation of a Coq type scheme constant. *)
 
-and mlt_env env r = match r with 
-  | ConstRef kn -> 
-      (try 
-	 if not (visible_con kn) then raise Not_found; 
-	 match lookup_term kn with 
+and mlt_env env r = match r with
+  | ConstRef kn ->
+      (try
+	 if not (visible_con kn) then raise Not_found;
+	 match lookup_term kn with
 	   | Dtype (_,vl,mlt) -> Some mlt
 	   | _ -> None
-       with Not_found -> 
+       with Not_found ->
 	 let cb = Environ.lookup_constant kn env in
-	 let typ = Typeops.type_of_constant_type env cb.const_type in 
+	 let typ = Typeops.type_of_constant_type env cb.const_type in
 	 match cb.const_body with
 	   | None -> None
-	   | Some l_body -> 
-	       (match flag_of_type env typ with 
-		  | Info,TypeScheme -> 
+	   | Some l_body ->
+	       (match flag_of_type env typ with
+		  | Info,TypeScheme ->
 		      let body = Declarations.force l_body in
-		      let s,vl = type_sign_vl env typ in 
-		      let db = db_from_sign s in 
-		      let t = extract_type_scheme env db body (List.length s) 
+		      let s,vl = type_sign_vl env typ in
+		      let db = db_from_sign s in
+		      let t = extract_type_scheme env db body (List.length s)
 		      in add_term kn (Dtype (r, vl, t)); Some t
 		  | _ -> None))
   | _ -> None
@@ -478,18 +507,19 @@ and expand env = type_expand (mlt_env env)
 and type2signature env = type_to_signature (mlt_env env)
 let type2sign env = type_to_sign (mlt_env env)
 let type_expunge env = type_expunge (mlt_env env)
+let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env)
 
 (*s Extraction of the type of a constant. *)
 
-let record_constant_type env kn opt_typ = 
-  try 
-    if not (visible_con kn) then raise Not_found; 
-    lookup_type kn 
+let record_constant_type env kn opt_typ =
+  try
+    if not (visible_con kn) then raise Not_found;
+    lookup_type kn
   with Not_found ->
-    let typ = match opt_typ with 
+    let typ = match opt_typ with
       | None -> Typeops.type_of_constant env kn
-      | Some typ -> typ 
-    in let mlt = extract_type env [] 1 typ [] 
+      | Some typ -> typ
+    in let mlt = extract_type env [] 1 typ []
     in let schema = (type_maxvar mlt, mlt)
     in add_type kn schema; schema
 
@@ -500,40 +530,41 @@ let record_constant_type env kn opt_typ =
 (* [mle] is a ML environment [Mlenv.t]. *)
 (* [mlt] is the ML type we want our extraction of [(c args)] to have. *)
 
-let rec extract_term env mle mlt c args = 
+let rec extract_term env mle mlt c args =
   match kind_of_term c with
     | App (f,a) ->
 	extract_term env mle mlt f (Array.to_list a @ args)
     | Lambda (n, t, d) ->
-	let id = id_of_name n in 
-	(match args with 
-	   | a :: l -> 
+	let id = id_of_name n in
+	(match args with
+	   | a :: l ->
 	       (* We make as many [LetIn] as possible. *)
  	       let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l))
 	       in extract_term env mle mlt d' []
-	   | [] -> 
-	       let env' = push_rel_assum (Name id, t) env in 
-	       let id, a = try check_default env t; id, new_meta()
-	       with NotDefault d -> dummy_name, Tdummy d
-	       in 
-	       let b = new_meta () in 
+	   | [] ->
+	       let env' = push_rel_assum (Name id, t) env in
+	       let id, a =
+		 try check_default env t; Id id, new_meta()
+		 with NotDefault d -> Dummy, Tdummy d
+	       in
+	       let b = new_meta () in
 	       (* If [mlt] cannot be unified with an arrow type, then magic! *)
-	       let magic = needs_magic (mlt, Tarr (a, b)) in 
-	       let d' = extract_term env' (Mlenv.push_type mle a) b d [] in 
+	       let magic = needs_magic (mlt, Tarr (a, b)) in
+	       let d' = extract_term env' (Mlenv.push_type mle a) b d [] in
 	       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 args' = List.map (lift 1) args in 
-	(try 
-	  check_default env t1; 
-	  let a = new_meta () in 
+	let id = id_of_name n in
+	let env' = push_rel (Name id, Some c1, t1) env in
+	let args' = List.map (lift 1) args in
+	(try
+	  check_default env t1;
+	  let a = new_meta () in
 	  let c1' = extract_term env mle a c1 [] in
 	  (* The type of [c1'] is generalized and stored in [mle]. *)
-	  let mle' = Mlenv.push_gen mle a in 
-	  MLletin (id, c1', extract_term env' mle' mlt c2 args') 
-	with NotDefault d -> 
-	  let mle' = Mlenv.push_std_type mle (Tdummy d) in 
+	  let mle' = Mlenv.push_gen mle a in
+	  MLletin (Id id, c1', extract_term env' mle' mlt c2 args')
+	with NotDefault d ->
+	  let mle' = Mlenv.push_std_type mle (Tdummy d) in
 	  ast_pop (extract_term env' mle' mlt c2 args'))
     | Const kn ->
 	extract_cst_app env mle mlt kn args
@@ -543,112 +574,112 @@ let rec extract_term env mle mlt c args =
 	(* As soon as the expected [mlt] for the head is known, *)
 	(* we unify it with an fresh copy of the stored type of [Rel n]. *)
 	let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
-	in extract_app env mle mlt extract_rel args 
+	in extract_app env mle mlt extract_rel args
     | Case ({ci_ind=ip},_,c0,br) ->
  	extract_app env mle mlt (extract_case env mle (ip,c0,br)) args
     | Fix ((_,i),recd) ->
- 	extract_app env mle mlt (extract_fix env mle i recd) args 
+ 	extract_app env mle mlt (extract_fix env mle i recd) args
     | CoFix (i,recd) ->
  	extract_app env mle mlt (extract_fix env mle i recd) args
     | Cast (c,_,_) -> extract_term env mle mlt c args
-    | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false 
+    | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false
 
-(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) 
+(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *)
 
 and extract_maybe_term env mle mlt c =
-  try check_default env (type_of env c); 
-    extract_term env mle mlt c [] 
-  with NotDefault d -> 
+  try check_default env (type_of env c);
+    extract_term env mle mlt c []
+  with NotDefault d ->
     put_magic (mlt, Tdummy d) MLdummy
 
 (*s Generic way to deal with an application. *)
 
-(* We first type all arguments starting with unknown meta types. 
-   This gives us the expected type of the head. Then we use the 
+(* We first type all arguments starting with unknown meta types.
+   This gives us the expected type of the head. Then we use the
    [mk_head] to produce the ML head from this type. *)
 
-and extract_app env mle mlt mk_head args = 
-  let metas = List.map new_meta args in 
-  let type_head = type_recomp (metas, mlt) in 
-  let mlargs = List.map2 (extract_maybe_term env mle) metas args in 
-  if mlargs = [] then mk_head type_head else MLapp (mk_head type_head, mlargs)
+and extract_app env mle mlt mk_head args =
+  let metas = List.map new_meta args in
+  let type_head = type_recomp (metas, mlt) in
+  let mlargs = List.map2 (extract_maybe_term env mle) metas args in
+  mlapp (mk_head type_head) mlargs
 
 (*s Auxiliary function used to extract arguments of constant or constructor. *)
 
-and make_mlargs env e s args typs = 
-  let l = ref s in 
-  let keep () = match !l with [] -> true | b :: s -> l:=s; b=Keep in
-  let rec f = function  
-    | [], [] -> [] 
-    | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt))
-    | _::la, _::lt -> f (la,lt)
-    | _ -> assert false 
-  in f (args,typs)
+and make_mlargs env e s args typs =
+  let rec f = function
+    | [], [], _ -> []
+    | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[]))
+    | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s))
+    | _::la, _::lt, _::s -> f (la,lt,s)
+    | _ -> assert false
+  in f (args,typs,s)
 
 (*s Extraction of a constant applied to arguments. *)
 
-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 
+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
   (* Can we instantiate types variables for this constant ? *)
   (* In Ocaml, inside the definition of this constant, the answer is no. *)
-  let instantiated = 
+  let instantiated =
     if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema)
     else instantiation schema
-  in 
+  in
   (* Then the expected type of this constant. *)
-  let a = new_meta () in 
+  let a = new_meta () in
   (* We compare stored and expected types in two steps. *)
   (* First, can [kn] be applied to all args ? *)
-  let metas = List.map new_meta args in 
-  let magic1 = needs_magic (type_recomp (metas, a), instantiated) in 
+  let metas = List.map new_meta args in
+  let magic1 = needs_magic (type_recomp (metas, a), instantiated) in
   (* Second, is the resulting type compatible with the expected type [mlt] ? *)
-  let magic2 = needs_magic (a, mlt) in 
+  let magic2 = needs_magic (a, mlt) in
   (* The internal head receives a magic if [magic1] *)
-  let head = put_magic_if magic1 (MLglob (ConstRef kn)) in 
+  let head = put_magic_if magic1 (MLglob (ConstRef kn)) in
   (* Now, the extraction of the arguments. *)
-  let s = type2signature env (snd schema) in 
-  let ls = List.length s in 
+  let s_full = type2signature env (snd schema) in
+  let s_full = sign_with_implicits (ConstRef kn) s_full in
+  let s = sign_no_final_keeps s_full in
+  let ls = List.length s in
   let la = List.length args in
-  let mla = make_mlargs env mle s args metas in 
+  (* The ml arguments, already expunged from known logical ones *)
+  let mla = make_mlargs env mle s args metas in
   let mla =
-    if not magic1 then 
-      try 
-	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in 
+    if not magic1 then
+      try
+	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in
 	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
 	else mla
       with _ -> mla
     else mla
-  in 			    
+  in
+  (* For strict languages, purely logical signatures with at least
+     one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left
+     accordingly. *)
+  let optdummy = match sign_kind s_full with
+    | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy]
+    | _ -> []
+  in
   (* Different situations depending of the number of arguments: *)
-  if ls = 0 then put_magic_if magic2 head
-  else if List.mem Keep s then 
-    if la >= ls || not (List.exists isKill s) 
-    then 
-      put_magic_if (magic2 && not magic1) (MLapp (head, mla))
-    else 
-      (* Not enough arguments. We complete via eta-expansion. *)
-      let ls' = ls-la in
-      let s' = list_lastn ls' s in
-      let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
-      put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s')
-  else if List.mem (Kill Kother) s then 
-    (* In the special case of always false signature, one dummy lam is left. *)
-    (* So a [MLdummy] is left accordingly. *) 
-    if la >= ls 
-    then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla))
-    else put_magic_if magic2 (dummy_lams head (ls-la-1))
-  else (* s is made only of [Kill Ktype] *)
-    if la >= ls 
-    then put_magic_if (magic2 && not magic1) (MLapp (head, mla))
-    else put_magic_if magic2 (dummy_lams head (ls-la))
-
+  if la >= ls
+  then
+    (* Enough args, cleanup already done in [mla], we only add the
+       additionnal dummy if needed. *)
+    put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla))
+  else
+    (* Partially applied function with some logical arg missing.
+       We complete via eta and expunge logical args. *)
+    let ls' = ls-la in
+    let s' = list_skipn la s in
+    let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
+    let e = anonym_or_dummy_lams (mlapp head mla) s' in
+    put_magic_if magic2 (remove_n_lams (List.length optdummy) e)
 
 (*s Extraction of an inductive constructor applied to arguments. *)
 
 (* \begin{itemize}
-   \item In ML, contructor arguments are uncurryfied. 
+   \item In ML, contructor arguments are uncurryfied.
    \item We managed to suppress logical parts inside inductive definitions,
    but they must appears outside (for partial applications for instance)
    \item We also suppressed all Coq parameters to the inductives, since
@@ -657,223 +688,248 @@ and extract_cst_app env mle mlt kn 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 
-  let oi = mi.ind_packets.(i) in 
+  let mi = extract_ind env kn in
+  let params_nb = mi.ind_nparams in
+  let oi = mi.ind_packets.(i) in
   let nb_tvars = List.length oi.ip_vars
   and types = List.map (expand env) oi.ip_types.(j-1) in
-  let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in 
+  let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in
   let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
-  let type_cons = instantiation (nb_tvars, type_cons) in 
+  let type_cons = instantiation (nb_tvars, type_cons) in
   (* Then, the usual variables [s], [ls], [la], ... *)
   let s = List.map (type2sign env) types in
-  let ls = List.length s in 
-  let la = List.length args in 
+  let s = sign_with_implicits (ConstructRef cp) s in
+  let ls = List.length s in
+  let la = List.length args in
   assert (la <= ls + params_nb);
-  let la' = max 0 (la - params_nb) in 
-  let args' = list_lastn la' args in 
+  let la' = max 0 (la - params_nb) in
+  let args' = list_lastn la' args in
   (* Now, we build the expected type of the constructor *)
-  let metas = List.map new_meta args' in 
+  let metas = List.map new_meta args' in
   (* If stored and expected types differ, then magic! *)
-  let a = new_meta () in 
+  let a = new_meta () in
   let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
-  let magic2 = needs_magic (a, mlt) in 
-  let head mla = 
-    if mi.ind_info = Singleton then 
+  let magic2 = needs_magic (a, mlt) in
+  let head mla =
+    if mi.ind_info = Singleton then
       put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
     else put_magic_if magic1 (MLcons (mi.ind_info, ConstructRef cp, mla))
-  in 
+  in
   (* Different situations depending of the number of arguments: *)
-  if la < params_nb then 
-    let head' = head (eta_args_sign ls s) in 
-    put_magic_if magic2 
+  if la < params_nb then
+    let head' = head (eta_args_sign ls s) in
+    put_magic_if magic2
       (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
-  else 
-    let mla = make_mlargs env mle s args' metas in 
-    if la = ls + params_nb 
+  else
+    let mla = make_mlargs env mle s args' metas in
+    if la = ls + params_nb
     then put_magic_if (magic2 && not magic1) (head mla)
-    else (* [ params_nb <= la <= ls + params_nb ] *) 
-      let ls' = params_nb + ls - la in 
-      let s' = list_lastn ls' s in 
+    else (* [ params_nb <= la <= ls + params_nb ] *)
+      let ls' = params_nb + ls - la in
+      let s' = list_lastn ls' s in
       let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
       put_magic_if magic2 (anonym_or_dummy_lams (head mla) s')
 
 (*S Extraction of a case. *)
 
-and extract_case env mle ((kn,i) as ip,c,br) mlt = 
+and extract_case env mle ((kn,i) as ip,c,br) mlt =
   (* [br]: bodies of each branch (in functional form) *)
   (* [ni]: number of arguments without parameters in each branch *)
   let ni = mis_constr_nargs_env env ip in
-  let br_size = Array.length br in 
-  assert (Array.length ni = br_size); 
+  let br_size = Array.length br in
+  assert (Array.length ni = br_size);
   if br_size = 0 then begin
     add_recursors env kn; (* May have passed unseen if logical ... *)
     MLexn "absurd case"
-  end else 
+  end else
     (* [c] has an inductive type, and is not a type scheme type. *)
-    let t = type_of env c in 
+    let t = type_of env c in
     (* The only non-informative case: [c] is of sort [Prop] *)
-    if (sort_of env t) = InProp then 
-      begin 
+    if (sort_of env t) = InProp then
+      begin
 	add_recursors env kn; (* May have passed unseen if logical ... *)
 	(* Logical singleton case: *)
 	(* [match c with C i j k -> t] becomes [t'] *)
 	assert (br_size = 1);
 	let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in
-	let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in 
-	let e = extract_maybe_term env mle mlt br.(0) in 
+	let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in
+	let e = extract_maybe_term env mle mlt br.(0) in
 	snd (case_expunge s e)
-      end 
-    else 
-      let mi = extract_ind env kn in 
-      let oi = mi.ind_packets.(i) in 
-      let metas = Array.init (List.length oi.ip_vars) new_meta in 
+      end
+    else
+      let mi = extract_ind env kn in
+      let oi = mi.ind_packets.(i) in
+      let metas = Array.init (List.length oi.ip_vars) new_meta in
       (* The extraction of the head. *)
       let type_head = Tglob (IndRef ip, Array.to_list metas) in
-      let a = extract_term env mle type_head c [] in 
+      let a = extract_term env mle type_head c [] in
       (* The extraction of each branch. *)
-      let extract_branch i = 
+      let extract_branch i =
+	let r = ConstructRef (ip,i+1) in
 	(* The types of the arguments of the corresponding constructor. *)
-	let f t = type_subst_vect metas (expand env t) in 
+	let f t = type_subst_vect metas (expand env t) in
 	let l = List.map f oi.ip_types.(i) in
 	(* the corresponding signature *)
 	let s = List.map (type2sign env) oi.ip_types.(i) in
+	let s = sign_with_implicits r s in
 	(* Extraction of the branch (in functional form). *)
-	let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in 
+	let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in
 	(* We suppress dummy arguments according to signature. *)
 	let ids,e = case_expunge s e in
-	(ConstructRef (ip,i+1), List.rev ids, e)
+	let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in
+	(r, List.rev ids, e')
       in
-      if mi.ind_info = Singleton then 
-	begin 
+      if mi.ind_info = Singleton then
+	begin
 	  (* Informative singleton case: *)
 	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
 	  assert (br_size = 1);
 	  let (_,ids,e') = extract_branch 0 in
 	  assert (List.length ids = 1);
-	  MLletin (List.hd ids,a,e')
-	end 
-      else 
+	  MLletin (tmp_id (List.hd ids),a,e')
+	end
+      else
 	(* Standard case: we apply [extract_branch]. *)
-	MLcase ((mi.ind_info,[]), a, Array.init br_size extract_branch)
-  
+	MLcase ((mi.ind_info,BranchNone), a, Array.init br_size extract_branch)
+
 (*s Extraction of a (co)-fixpoint. *)
 
-and extract_fix env mle i (fi,ti,ci as recd) mlt = 
-  let env = push_rec_types recd env in 
+and extract_fix env mle i (fi,ti,ci as recd) mlt =
+  let env = push_rec_types recd env in
   let metas = Array.map new_meta fi in
-  metas.(i) <- mlt; 
-  let mle = Array.fold_left Mlenv.push_type mle metas in 
-  let ei = array_map2 (extract_maybe_term env mle) metas ci in 
+  metas.(i) <- mlt;
+  let mle = Array.fold_left Mlenv.push_type mle metas in
+  let ei = array_map2 (extract_maybe_term env mle) metas ci in
   MLfix (i, Array.map id_of_name fi, ei)
 
 (*S ML declarations. *)
 
-(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], 
+(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t],
    and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
 
-let rec decomp_lams_eta_n n env c t = 
-  let rels = fst (decomp_n_prod env none n t) in 
-  let rels = List.map (fun (id,_,c) -> (id,c)) rels in 
-  let m = nb_lam c in 
-  if m >= n then decompose_lam_n n c 
-  else
-    let rels',c = decompose_lam c in 
-    let d = n - m in 
-    (* we'd better keep rels' as long as possible. *)
-    let rels = (list_firstn d rels) @ rels' in
-    let eta_args = List.rev_map mkRel (interval 1 d) in 
-    rels, applist (lift d c,eta_args)
+let rec decomp_lams_eta_n n m env c t =
+  let rels = fst (splay_prod_n env none n t) in
+  let rels = List.map (fun (id,_,c) -> (id,c)) rels in
+  let rels',c = decompose_lam c in
+  let d = n - m in
+  (* we'd better keep rels' as long as possible. *)
+  let rels = (list_firstn d rels) @ rels' in
+  let eta_args = List.rev_map mkRel (interval 1 d) in
+  rels, applist (lift d c,eta_args)
 
 (*s From a constant to a ML declaration. *)
 
-let extract_std_constant env kn body typ = 
-  reset_meta_count (); 
+let extract_std_constant env kn body typ =
+  reset_meta_count ();
   (* The short type [t] (i.e. possibly with abbreviations). *)
-  let t = snd (record_constant_type env kn (Some typ)) in 
-  (* The real type [t']: without head lambdas, expanded, *)
+  let t = snd (record_constant_type env kn (Some typ)) in
+  (* The real type [t']: without head products, expanded, *)
   (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
-  let l,t' = type_decomp (expand env (var2var' t)) in 
-  let s = List.map (type2sign env) l in 
+  let l,t' = type_decomp (expand env (var2var' t)) in
+  let s = List.map (type2sign env) l in
+  (* Check for user-declared implicit information *)
+  let s = sign_with_implicits (ConstRef kn) s in
+  (* Decomposing the top level lambdas of [body].
+     If there isn't enough, it's ok, as long as remaining args
+     aren't to be pruned (and initial lambdas aren't to be all
+     removed if the target language is strict). In other situations,
+     eta-expansions create artificially enough lams (but that may
+     break user's clever let-ins and partial applications). *)
+  let rels, c =
+    let n = List.length s
+    and m = nb_lam body in
+    if n <= m then decompose_lam_n n body
+    else
+      let s,s' = list_split_at m s in
+      if List.for_all ((=) Keep) s' &&
+	(lang () = Haskell || sign_kind s <> UnsafeLogicalSig)
+      then decompose_lam_n m body
+      else decomp_lams_eta_n n m env body typ
+  in
+  let n = List.length rels in
+  let s = list_firstn n s in
+  let l,l' = list_split_at n l in
+  let t' = type_recomp (l',t') in
   (* The initial ML environment. *)
-  let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in 
-  (* Decomposing the top level lambdas of [body]. *)
-  let rels,c = decomp_lams_eta_n (List.length s) env body typ in
+  let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in
   (* The lambdas names. *)
-  let ids = List.map (fun (n,_) -> id_of_name n) rels in 
+  let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in
   (* The according Coq environment. *)
   let env = push_rels_assum rels env in
   (* The real extraction: *)
   let e = extract_term env mle t' c [] in
-  (* Expunging term and type from dummy lambdas. *) 
-  term_expunge s (ids,e), type_expunge env t
-
-let extract_fixpoint env vkn (fi,ti,ci) = 
-  let n = Array.length vkn in 
+  (* Expunging term and type from dummy lambdas. *)
+  let trm = term_expunge s (ids,e) in
+  let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm
+  in
+  trm, type_expunge_from_sign env s t
+
+let extract_fixpoint env vkn (fi,ti,ci) =
+  let n = Array.length vkn in
   let types = Array.make n (Tdummy Kother)
-  and terms = Array.make n MLdummy in 
-  let kns = Array.to_list vkn in 
-  current_fixpoints := kns; 
+  and terms = Array.make n MLdummy in
+  let kns = Array.to_list vkn in
+  current_fixpoints := kns;
   (* 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 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; 
+      terms.(i) <- e;
       types.(i) <- t;
-    end 
-  done; 
+    end
+  done;
   current_fixpoints := [];
-  Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) 
-		 
-let extract_constant env kn cb = 
-  let r = ConstRef kn in 
-  let typ = Typeops.type_of_constant_type env cb.const_type in 
+  Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types)
+
+let extract_constant env kn cb =
+  let r = ConstRef kn in
+  let typ = Typeops.type_of_constant_type env cb.const_type in
   match cb.const_body with
-    | None -> (* A logical axiom is risky, an informative one is fatal. *) 
+    | None -> (* A logical axiom is risky, an informative one is fatal. *)
         (match flag_of_type env typ with
-	   | (Info,TypeScheme) -> 
-	       if not (is_custom r) then add_info_axiom r; 
-	       let n = type_scheme_nb_args env typ in 
-	       let ids = iterate (fun l -> anonymous::l) n [] in 
-	       Dtype (r, ids, Taxiom) 
-           | (Info,Default) -> 
-	       if not (is_custom r) then add_info_axiom r; 
-	       let t = snd (record_constant_type env kn (Some typ)) in 
-	       Dterm (r, MLaxiom, type_expunge env t) 
-           | (Logic,TypeScheme) -> 
+	   | (Info,TypeScheme) ->
+	       if not (is_custom r) then add_info_axiom r;
+	       let n = type_scheme_nb_args env typ in
+	       let ids = iterate (fun l -> anonymous_name::l) n [] in
+	       Dtype (r, ids, Taxiom)
+           | (Info,Default) ->
+	       if not (is_custom r) then add_info_axiom r;
+	       let t = snd (record_constant_type env kn (Some typ)) in
+	       Dterm (r, MLaxiom, type_expunge env t)
+           | (Logic,TypeScheme) ->
 	       add_log_axiom r; Dtype (r, [], Tdummy Ktype)
-	   | (Logic,Default) -> 
+	   | (Logic,Default) ->
 	       add_log_axiom r; Dterm (r, MLdummy, Tdummy Kother))
     | Some body ->
 	(match flag_of_type env typ with
 	   | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother)
 	   | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype)
-	   | (Info, Default) -> 
-	       let e,t = extract_std_constant env kn (force body) typ in 
+	   | (Info, Default) ->
+	       let e,t = extract_std_constant env kn (force body) typ in
 	       Dterm (r,e,t)
-	   | (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 (force body) (List.length s) 
+	   | (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 (force body) (List.length s)
 	       in Dtype (r, vl, t))
 
-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 
+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
     | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
-    | (Logic, Default) -> Sval (r, Tdummy Kother) 
-    | (Info, TypeScheme) -> 
-	let s,vl = type_sign_vl env typ in 
-	(match cb.const_body with 
+    | (Logic, Default) -> Sval (r, Tdummy Kother)
+    | (Info, TypeScheme) ->
+	let s,vl = type_sign_vl env typ in
+	(match cb.const_body with
 	  | None -> Stype (r, vl, None)
-	  | Some body -> 
-	      let db = db_from_sign s in 
+	  | Some body ->
+	      let db = db_from_sign s in
 	      let t = extract_type_scheme env db (force body) (List.length s)
-	      in Stype (r, vl, Some t)) 
-    | (Info, Default) -> 
-	let t = snd (record_constant_type env kn (Some typ)) in 
+	      in Stype (r, vl, Some t))
+    | (Info, Default) ->
+	let t = snd (record_constant_type env kn (Some typ)) in
 	Sval (r, type_expunge env t)
 
 let extract_with_type env cb =
@@ -887,30 +943,39 @@ let extract_with_type env cb =
 	Some (vl, t)
     | _ -> None
 
-		   
-let extract_inductive env kn = 
-  let ind = extract_ind env kn in 
-  add_recursors env kn; 
-  let f l = List.filter (fun t -> not (isDummy (expand env t))) l in 
-  let packets = 
-    Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) 
+
+let extract_inductive env kn =
+  let ind = extract_ind env kn in
+  add_recursors env kn;
+  let f i j l =
+    let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in
+    let rec filter i = function
+      | [] -> []
+      | t::l ->
+	  let l' = filter (succ i) l in
+	  if isDummy (expand env t) || List.mem i implicits then l'
+	  else t::l'
+    in filter 1 l
+  in
+  let packets =
+    Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types })
       ind.ind_packets
   in { ind with ind_packets = packets }
 
-(*s Is a [ml_decl] logical ? *) 
+(*s Is a [ml_decl] logical ? *)
 
-let logical_decl = function 
+let logical_decl = function
   | Dterm (_,MLdummy,Tdummy _) -> true
-  | Dtype (_,[],Tdummy _) -> true 
-  | Dfix (_,av,tv) -> 
-      (array_for_all ((=) MLdummy) av) && 
+  | Dtype (_,[],Tdummy _) -> true
+  | Dfix (_,av,tv) ->
+      (array_for_all ((=) MLdummy) av) &&
       (array_for_all isDummy tv)
   | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
 
 (*s Is a [ml_spec] logical ? *)
 
-let logical_spec = function 
+let logical_spec = function
   | Stype (_, [], Some (Tdummy _)) -> true
   | Sval (_,Tdummy _) -> true
   | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
diff --git a/contrib/extraction/extraction.mli b/plugins/extraction/extraction.mli
index 6d41b630..6bcd2476 100644
--- a/contrib/extraction/extraction.mli
+++ b/plugins/extraction/extraction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*s Extraction from Coq terms to Miniml. *)
 
@@ -23,12 +23,12 @@ val extract_constant_spec : env -> constant -> constant_body -> ml_spec
 
 val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option
 
-val extract_fixpoint : 
-  env -> constant array -> (constr, types) prec_declaration -> ml_decl 
+val extract_fixpoint :
+  env -> constant array -> (constr, types) prec_declaration -> ml_decl
 
-val extract_inductive : env -> kernel_name -> ml_ind
+val extract_inductive : env -> mutual_inductive -> ml_ind
 
-(*s Is a [ml_decl] or a [ml_spec] logical ? *) 
+(*s Is a [ml_decl] or a [ml_spec] logical ? *)
 
 val logical_decl : ml_decl -> bool
 val logical_spec : ml_spec -> bool
diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mllib
new file mode 100644
index 00000000..b7f45861
--- /dev/null
+++ b/plugins/extraction/extraction_plugin.mllib
@@ -0,0 +1,11 @@
+Table
+Mlutil
+Modutil
+Extraction
+Common
+Ocaml
+Haskell
+Scheme
+Extract_env
+G_extraction
+Extraction_plugin_mod
diff --git a/contrib/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index 345cb307..18828241 100644
--- a/contrib/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -14,6 +14,10 @@ open Vernacexpr
 open Pcoq
 open Genarg
 open Pp
+open Names
+open Nameops
+open Table
+open Extract_env
 
 let pr_mlname _ _ _ s = spc () ++ qs s
 
@@ -24,11 +28,19 @@ ARGUMENT EXTEND mlname
 | [ string(s) ] -> [ s ]
 END
 
-open Table
-open Extract_env
+let pr_int_or_id _ _ _ = function
+  | ArgInt i -> int i
+  | 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 ]
+END
 
 let pr_language = function
-  | Ocaml -> str "Ocaml" 
+  | Ocaml -> str "Ocaml"
   | Haskell -> str "Haskell"
   | Scheme -> str "Scheme"
 
@@ -47,7 +59,7 @@ VERNAC COMMAND EXTEND Extraction
 | [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ]
 
 (* Monolithic extraction to a file *)
-| [ "Extraction" string(f) ne_global_list(l) ] 
+| [ "Extraction" string(f) ne_global_list(l) ]
   -> [ full_extraction (Some f) l ]
 END
 
@@ -64,18 +76,18 @@ END
 
 (* Target Language *)
 VERNAC COMMAND EXTEND ExtractionLanguage
-| [ "Extraction" "Language" language(l) ] 
+| [ "Extraction" "Language" language(l) ]
   -> [ extraction_language l ]
 END
 
 VERNAC COMMAND EXTEND ExtractionInline
 (* Custom inlining directives *)
-| [ "Extraction" "Inline" ne_global_list(l) ] 
+| [ "Extraction" "Inline" ne_global_list(l) ]
   -> [ extraction_inline true l ]
 END
 
 VERNAC COMMAND EXTEND ExtractionNoInline
-| [ "Extraction" "NoInline" ne_global_list(l) ] 
+| [ "Extraction" "NoInline" ne_global_list(l) ]
   -> [ extraction_inline false l ]
 END
 
@@ -89,6 +101,12 @@ VERNAC COMMAND EXTEND ResetExtractionInline
   -> [ reset_extraction_inline () ]
 END
 
+VERNAC COMMAND EXTEND ExtractionImplicit
+(* Custom implicit arguments of some csts/inds/constructors *)
+| [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ]
+  -> [ extraction_implicit r l ]
+END
+
 VERNAC COMMAND EXTEND ExtractionBlacklist
 (* Force Extraction to not use some filenames *)
 | [ "Extraction" "Blacklist" ne_ident_list(l) ]
@@ -118,6 +136,7 @@ VERNAC COMMAND EXTEND ExtractionInlinedConstant
 END
 
 VERNAC COMMAND EXTEND ExtractionInductive
-| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ]
-  -> [ extract_inductive x (id,idl) ]
+| [ "Extract" "Inductive" global(x) "=>"
+    mlname(id) "[" mlname_list(idl) "]" string_opt(o) ]
+  -> [ extract_inductive x id idl o ]
 END
diff --git a/contrib/extraction/haskell.ml b/plugins/extraction/haskell.ml
index 3f0366e6..bb1dbd48 100644
--- a/contrib/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.ml 11559 2008-11-07 22:03:34Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*s Production of Haskell syntax. *)
 
@@ -25,27 +25,27 @@ open Common
 let pr_lower_id id = str (String.uncapitalize (string_of_id id))
 let pr_upper_id id = str (String.capitalize (string_of_id id))
 
-let keywords =     
+let keywords =
   List.fold_right (fun s -> Idset.add (id_of_string s))
   [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
-    "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; 
+    "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance";
     "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
     "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
   Idset.empty
 
 let preamble mod_name used_modules usf =
   let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n")
-  in 
-  (if not usf.magic then mt () 
+  in
+  (if not usf.magic then mt ()
    else
      str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++
      str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n")
   ++
   str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++
   str "import qualified Prelude" ++ fnl () ++
-  prlist pp_import used_modules ++ fnl () ++ 
+  prlist pp_import used_modules ++ fnl () ++
   (if used_modules = [] then mt () else fnl ()) ++
-  (if not usf.magic then mt () 
+  (if not usf.magic then mt ()
    else str "\
 #ifdef __GLASGOW_HASKELL__
 import qualified GHC.Base
@@ -56,7 +56,7 @@ import qualified IOExts
 unsafeCoerce = IOExts.unsafeCoerce
 #endif" ++ fnl2 ())
   ++
-  (if not usf.mldummy then mt () 
+  (if not usf.mldummy then mt ()
    else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ())
 
 let pp_abst = function
@@ -67,36 +67,36 @@ let pp_abst = function
 
 (*s The pretty-printer for haskell syntax *)
 
-let pp_global k r = 
-  if is_inline_custom r then str (find_custom r) 
+let pp_global k r =
+  if is_inline_custom r then str (find_custom r)
   else str (Common.pp_global k r)
 
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
 
-let kn_sig = 
-  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in 
+let kn_sig =
+  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in
   make_kn specif empty_dirpath (mk_label "sig")
 
 let rec pp_type par vl t =
   let rec pp_rec par = function
-    | Tmeta _ | Tvar' _ -> assert false 
+    | Tmeta _ | Tvar' _ -> assert false
     | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i))
-    | Tglob (r,[]) -> pp_global Type r	
-    | Tglob (r,l) -> 
-	if r = IndRef (kn_sig,0) then 
+    | Tglob (r,[]) -> pp_global Type r
+    | Tglob (r,l) ->
+	if r = IndRef (mind_of_kn kn_sig,0) then
 	  pp_type true vl (List.hd l)
-	else 
-	  pp_par par 
-	    (pp_global Type r ++ spc () ++ 
+	else
+	  pp_par par
+	    (pp_global Type r ++ spc () ++
 	     prlist_with_sep spc (pp_type true vl) l)
     | Tarr (t1,t2) ->
-	pp_par par 
+	pp_par par
 	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
     | Tdummy _ -> str "()"
     | Tunknown -> str "()"
     | Taxiom -> str "() -- AXIOM TO BE REALIZED\n"
- in 
+ in
   hov 0 (pp_rec par t)
 
 (*s Pretty-printing of expressions. [par] indicates whether
@@ -107,37 +107,37 @@ let rec pp_type par vl t =
 let expr_needs_par = function
   | MLlam _  -> true
   | MLcase _ -> true
-  | _        -> false 
+  | _        -> false
 
 
 let rec pp_expr par env args =
   let par' = args <> [] || par
-  and apply st = pp_apply st par args in 
+  and apply st = pp_apply st par args in
   function
-    | MLrel n -> 
+    | MLrel n ->
 	let id = get_db_name n env in apply (pr_id id)
     | MLapp (f,args') ->
 	let stl = List.map (pp_expr true env []) args' in
         pp_expr par env (stl @ args) f
-    | MLlam _ as a -> 
+    | MLlam _ as a ->
       	let fl,a' = collect_lams a in
-	let fl,env' = push_vars fl env in
+	let fl,env' = push_vars (List.map id_of_mlid fl) env in
 	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
 	apply (pp_par par' st)
     | MLletin (id,a1,a2) ->
-	let i,env' = push_vars [id] env in
+	let i,env' = push_vars [id_of_mlid id] env in
 	let pp_id = pr_id (List.hd i)
 	and pp_a1 = pp_expr false env [] a1
 	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in
-	hv 0 
-	  (apply 
-	     (pp_par par' 
-		(hv 0 
-		   (hov 5 
-		      (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ 
+	hv 0
+	  (apply
+	     (pp_par par'
+		(hv 0
+		   (hov 5
+		      (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++
 		    spc () ++ str "in") ++
 		 spc () ++ hov 0 pp_a2)))
-    | MLglob r -> 
+    | MLglob r ->
 	apply (pp_global Term r)
     | MLcons (_,r,[]) ->
 	assert (args=[]); pp_global Cons r
@@ -146,65 +146,83 @@ let rec pp_expr par env args =
 	pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a)
     | MLcons (_,r,args') ->
 	assert (args=[]);
-	pp_par par (pp_global Cons r ++ spc () ++ 
+	pp_par par (pp_global Cons r ++ spc () ++
 		    prlist_with_sep spc (pp_expr true env []) args')
+    | MLcase (_,t, pv) when is_custom_match pv ->
+	let mkfun (_,ids,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	hov 2 (str (find_custom_match pv) ++ fnl () ++
+		 prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv
+	       ++ pp_expr true env [] t)
     | MLcase ((_,factors),t, pv) ->
-      	apply (pp_par par' 
+      	apply (pp_par par'
 		 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
 		       fnl () ++ str "  " ++ pp_pat env factors pv)))
     | 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
-    | MLexn s -> 
+    | MLexn s ->
 	(* An [MLexn] may be applied, but I don't really care. *)
 	pp_par par (str "Prelude.error" ++ spc () ++ qs s)
     | MLdummy ->
 	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
-    | MLmagic a ->  
+    | MLmagic a ->
 	pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args)
     | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"")
 
-and pp_pat env factors pv = 
+and pp_pat env factors pv =
   let pp_one_pat (name,ids,t) =
-    let ids,env' = push_vars (List.rev ids) env in
+    let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
     let par = expr_needs_par t in
     hov 2 (pp_global Cons name ++
-	   (match ids with 
+	   (match ids with
 	      | [] -> mt ()
-	      | _  -> (str " " ++ 
-		       prlist_with_sep 
+	      | _  -> (str " " ++
+		       prlist_with_sep
 			 (fun () -> (spc ())) pr_id (List.rev ids))) ++
 	   str " ->" ++ spc () ++ pp_expr par env' [] t)
-  in 
-  prvecti 
-    (fun i x -> if List.mem i factors then mt () else 
+  in
+  let factor_br, factor_l = try match factors with
+    | BranchFun (i::_ as l) -> check_function_branch pv.(i), l
+    | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l
+    | _ -> MLdummy, []
+  with Impossible -> MLdummy, []
+  in
+  let par = expr_needs_par factor_br in
+  let last = Array.length pv - 1 in
+  prvecti
+    (fun i x -> if List.mem i factor_l then mt () else
        (pp_one_pat pv.(i) ++
-	if factors = [] && i = Array.length pv - 1 then mt ()
-	else fnl () ++ str "  ")) pv
+       if i = last && factor_l = [] then mt () else
+       fnl () ++ str "  ")) pv
   ++
-  match factors with 
-    | [] -> mt ()
-    | i::_ -> 
-	let (_,ids,t) = pv.(i) in 
-	let t = ast_lift (-List.length ids) t in 
-	hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t)
+  if factor_l = [] then mt () else match factors with
+    | BranchFun _ ->
+	let ids, env' = push_vars [anonymous_name] env in
+	pr_id (List.hd ids) ++ str " ->" ++ spc () ++
+	pp_expr par env' [] factor_br
+    | BranchCst _ ->
+	str "_ ->" ++ spc () ++ pp_expr par env [] factor_br
+    | BranchNone -> mt ()
 
 (*s names of the functions ([ids]) are already pushed in [env],
     and passed here just for convenience. *)
 
 and pp_fix par env i (ids,bl) args =
   pp_par par
-    (v 0  
+    (v 0
        (v 2 (str "let" ++ fnl () ++
-	     prvect_with_sep fnl 
-	       (fun (fi,ti) -> pp_function env (pr_id fi) ti) 
-	       (array_map2 (fun a b -> a,b) ids bl)) ++ 
-	fnl () ++ 
+	     prvect_with_sep fnl
+	       (fun (fi,ti) -> pp_function env (pr_id fi) ti)
+	       (array_map2 (fun a b -> a,b) ids bl)) ++
+	fnl () ++
 	hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
 
 and pp_function env f t =
   let bl,t' = collect_lams t in
-  let bl,env' = push_vars bl env in
+  let bl,env' = push_vars (List.map id_of_mlid bl) env in
   (f ++ pr_binding (List.rev bl) ++
      str " =" ++ fnl () ++ str "  " ++
      hov 2 (pp_expr false env' [] t'))
@@ -213,19 +231,19 @@ and pp_function env f t =
 
 let pp_comment s = str "-- " ++ s ++ fnl ()
 
-let pp_logical_ind packet = 
+let pp_logical_ind packet =
   pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
-  pp_comment (str "with constructors : " ++ 
+  pp_comment (str "with constructors : " ++
 	      prvect_with_sep spc pr_id packet.ip_consnames)
 
-let pp_singleton kn packet = 
-  let l = rename_tvars keywords packet.ip_vars in 
-  let l' = List.rev l in 
-  hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ 
+let pp_singleton kn packet =
+  let l = rename_tvars keywords packet.ip_vars in
+  let l' = List.rev l in
+  hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++
 	 prlist_with_sep spc pr_id l ++
 	 (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
 	 pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
-	 pp_comment (str "singleton inductive, whose constructor was " ++ 
+	 pp_comment (str "singleton inductive, whose constructor was " ++
 		     pr_id packet.ip_consnames.(0)))
 
 let pp_one_ind ip pl cv =
@@ -233,102 +251,107 @@ let pp_one_ind ip pl cv =
   let pp_constructor (r,l) =
     (pp_global Cons r ++
      match l with
-       | [] -> (mt ()) 
+       | [] -> (mt ())
        | _  -> (str " " ++
-      	       	prlist_with_sep 
+      	       	prlist_with_sep
 		  (fun () -> (str " ")) (pp_type true pl) l))
   in
-  str (if Array.length cv = 0 then "type " else "data ") ++ 
+  str (if Array.length cv = 0 then "type " else "data ") ++
   pp_global Type (IndRef ip) ++ str " " ++
   prlist_with_sep (fun () -> str " ") pr_lower_id pl ++
   (if pl = [] then mt () else str " ") ++
   if Array.length cv = 0 then str "= () -- empty inductive"
-  else 
+  else
     (v 0 (str "= " ++
-	  prvect_with_sep (fun () -> fnl () ++ str "  | ") pp_constructor 
+	  prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor
 	    (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv)))
-  
+
 let rec pp_ind first kn i ind =
-  if i >= Array.length ind.ind_packets then 
-    if first then mt () else fnl () 
-  else 
-    let ip = (kn,i) in 
-    let p = ind.ind_packets.(i) in 
-    if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind 
-    else 
-      if p.ip_logical then  
+  if i >= Array.length ind.ind_packets then
+    if first then mt () else fnl ()
+  else
+    let ip = (kn,i) in
+    let p = ind.ind_packets.(i) in
+    if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind
+    else
+      if p.ip_logical then
 	pp_logical_ind p ++ pp_ind first kn (i+1) ind
-      else 
-	pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ 
+      else
+	pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++
 	pp_ind false kn (i+1) ind
-	  
+
 
 (*s Pretty-printing of a declaration. *)
 
 let pp_string_parameters ids = prlist (fun id -> str id ++ str " ")
 
 let pp_decl = function
-  | Dind (kn,i) when i.ind_info = Singleton -> 
-      pp_singleton kn i.ind_packets.(0) ++ fnl ()
-  | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
+  | Dind (kn,i) when i.ind_info = Singleton ->
+      pp_singleton (mind_of_kn kn) i.ind_packets.(0) ++ fnl ()
+  | Dind (kn,i) -> hov 0 (pp_ind true (mind_of_kn kn) 0 i)
   | Dtype (r, l, t) ->
-      if is_inline_custom r then mt () 
-      else 
-	let l = rename_tvars keywords l in 
-	let st = 
-	  try 
-	    let ids,s = find_type_custom r in 
+      if is_inline_custom r then mt ()
+      else
+	let l = rename_tvars keywords l in
+	let st =
+	  try
+	    let ids,s = find_type_custom r in
 	    prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s
-	  with not_found -> 
+	  with not_found ->
 	    prlist (fun id -> pr_id id ++ str " ") l ++
 	    if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
 	    else str "=" ++ spc () ++ pp_type false l t
-	in 
+	in
 	hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 ()
   | Dfix (rv, defs, typs) ->
-      let max = Array.length rv in 
-      let rec iter i = 
-	if i = max then mt () 
+      let max = Array.length rv in
+      let rec iter i =
+	if i = max then mt ()
 	else
-	  let e = pp_global Term rv.(i) in 
-	  e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () 
+	  let e = pp_global Term rv.(i) in
+	  e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl ()
 	  ++ pp_function (empty_env ()) e defs.(i) ++ fnl2 ()
 	  ++ iter (i+1)
       in iter 0
   | Dterm (r, a, t) ->
-      if is_inline_custom r then mt () 
-      else 
-	let e = pp_global Term r in 
+      if is_inline_custom r then mt ()
+      else
+	let e = pp_global Term r in
 	e ++ str " :: " ++ pp_type false [] t ++ fnl () ++
-	  if is_custom r then 	
+	  if is_custom r then
 	    hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
-	  else 
+	  else
 	    hov 0 (pp_function (empty_env ()) e a ++ fnl2 ())
 
-let pp_structure_elem = function 
+let rec pp_structure_elem = function
   | (l,SEdecl d) -> pp_decl d
-  | (l,SEmodule m) -> 
-      failwith "TODO: Haskell extraction of modules not implemented yet"
-  | (l,SEmodtype m) -> 
-      failwith "TODO: Haskell extraction of modules not implemented yet"
-
-let pp_struct = 
-  let pp_sel (mp,sel) = 
-    push_visible mp None; 
-    let p = prlist_strict pp_structure_elem sel in 
+  | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr
+  | (l,SEmodtype m) -> mt ()
+      (* for the moment we simply discard module type *)
+
+and pp_module_expr = function
+  | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel
+  | MEfunctor _ -> mt ()
+      (* for the moment we simply discard unapplied functors *)
+  | MEident _ | MEapply _ -> assert false
+      (* should be expansed in extract_env *)
+
+let pp_struct =
+  let pp_sel (mp,sel) =
+    push_visible mp [];
+    let p = prlist_strict pp_structure_elem sel in
     pop_visible (); p
-  in 
-  prlist_strict pp_sel 
+  in
+  prlist_strict pp_sel
 
 
 let haskell_descr = {
-  keywords = keywords;  
-  file_suffix = ".hs"; 
-  capital_file = true;  
-  preamble = preamble; 
-  pp_struct = pp_struct; 
+  keywords = keywords;
+  file_suffix = ".hs";
+  preamble = preamble;
+  pp_struct = pp_struct;
   sig_suffix = None;
-  sig_preamble = (fun _ _ _ -> mt ()); 
+  sig_preamble = (fun _ _ _ -> mt ());
   pp_sig = (fun _ -> mt ());
-  pp_decl = pp_decl; 
+  pp_decl = pp_decl;
 }
diff --git a/contrib/extraction/haskell.mli b/plugins/extraction/haskell.mli
index 1af9c231..1b5dbc71 100644
--- a/contrib/extraction/haskell.mli
+++ b/plugins/extraction/haskell.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
+(*i $Id$ i*)
 
 val haskell_descr : Miniml.language_descr
 
diff --git a/contrib/extraction/miniml.mli b/plugins/extraction/miniml.mli
index dfe4eb48..61b3fc13 100644
--- a/contrib/extraction/miniml.mli
+++ b/plugins/extraction/miniml.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: miniml.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
+(*i $Id$ i*)
 
 (*s Target language for extraction: a core ML called MiniML. *)
 
@@ -20,22 +20,23 @@ open Libnames
    object. *)
 
 (* We eliminate from terms:  1) types 2) logical parts.
-   [Kother] stands both for logical or unknown reason. *)
+   [Kother] stands both for logical or other reasons
+   (for instance user-declared implicit arguments w.r.t. extraction). *)
 
 type kill_reason = Ktype | Kother
 
 type sign = Keep | Kill of kill_reason
 
-   
+
 (* Convention: outmost lambda/product gives the head of the list. *)
 
 type signature = sign list
 
 (*s ML type expressions. *)
 
-type ml_type = 
+type ml_type =
   | Tarr    of ml_type * ml_type
-  | Tglob   of global_reference * ml_type list 
+  | Tglob   of global_reference * ml_type list
   | Tvar    of int
   | Tvar'   of int (* same as Tvar, used to avoid clash *)
   | Tmeta   of ml_meta (* used during ML type reconstruction *)
@@ -45,62 +46,75 @@ type ml_type =
 
 and ml_meta = { id : int; mutable contents : ml_type option }
 
-(* ML type schema. 
+(* ML type schema.
    The integer is the number of variable in the schema. *)
 
-type ml_schema = int * ml_type 
+type ml_schema = int * ml_type
 
 (*s ML inductive types. *)
 
-type inductive_info = 
-  | Singleton 
-  | Coinductive 
-  | Standard 
-  | Record of global_reference list 
-
-type case_info = int list (* list of branches to merge in a _ pattern *)
+type inductive_info =
+  | Singleton
+  | Coinductive
+  | Standard
+  | Record of global_reference list
 
-(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. 
+(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body].
    If the inductive is logical ([ip_logical = false]), then all other fields
-   are unused. Otherwise, 
-   [ip_sign] is a signature concerning the arguments of the inductive, 
-   [ip_vars] contains the names of the type variables surviving in ML, 
-   [ip_types] contains the ML types of all constructors.    
+   are unused. Otherwise,
+   [ip_sign] is a signature concerning the arguments of the inductive,
+   [ip_vars] contains the names of the type variables surviving in ML,
+   [ip_types] contains the ML types of all constructors.
 *)
 
-type ml_ind_packet = { 
-  ip_typename : identifier; 
-  ip_consnames : identifier array; 
+type ml_ind_packet = {
+  ip_typename : identifier;
+  ip_consnames : identifier array;
   ip_logical : bool;
-  ip_sign : signature; 
-  ip_vars : identifier list; 
-  ip_types : (ml_type list) array }  
+  ip_sign : signature;
+  ip_vars : identifier list;
+  ip_types : (ml_type list) array;
+  mutable ip_optim_id_ok : bool option
+}
 
 (* [ip_nparams] contains the number of parameters. *)
 
-type equiv = 
+type equiv =
   | NoEquiv
-  | Equiv of kernel_name 
+  | Equiv of kernel_name
   | RenEquiv of string
 
 type ml_ind = {
   ind_info : inductive_info;
-  ind_nparams : int; 	       
+  ind_nparams : int;
   ind_packets : ml_ind_packet array;
   ind_equiv : equiv
 }
 
 (*s ML terms. *)
 
-type ml_ast = 
+type ml_ident =
+  | Dummy
+  | Id of identifier
+  | Tmp of identifier
+
+(* list of branches to merge in a common pattern *)
+
+type case_info =
+  | BranchNone
+  | BranchFun of int list
+  | BranchCst of int list
+
+type ml_branch = global_reference * ml_ident list * ml_ast
+
+and ml_ast =
   | MLrel    of int
   | MLapp    of ml_ast * ml_ast list
-  | MLlam    of identifier * ml_ast
-  | MLletin  of identifier * ml_ast * ml_ast
+  | MLlam    of ml_ident * ml_ast
+  | MLletin  of ml_ident * ml_ast * ml_ast
   | MLglob   of global_reference
   | MLcons   of inductive_info * global_reference * ml_ast list
-  | MLcase   of (inductive_info*case_info) * ml_ast * 
-      (global_reference * identifier list * ml_ast) array
+  | MLcase   of (inductive_info*case_info) * ml_ast * ml_branch array
   | MLfix    of int * identifier array * ml_ast array
   | MLexn    of string
   | MLdummy
@@ -109,52 +123,52 @@ type ml_ast =
 
 (*s ML declarations. *)
 
-type ml_decl = 
+type ml_decl =
   | Dind  of kernel_name * ml_ind
   | Dtype of global_reference * identifier list * ml_type
   | Dterm of global_reference * ml_ast * ml_type
   | Dfix  of global_reference array * ml_ast array * ml_type array
 
-type ml_spec = 
+type ml_spec =
   | Sind  of kernel_name * ml_ind
-  | Stype of global_reference * identifier list * ml_type option 
+  | Stype of global_reference * identifier list * ml_type option
   | Sval  of global_reference * ml_type
 
-type ml_specif = 
-  | Spec of ml_spec 
+type ml_specif =
+  | Spec of ml_spec
   | Smodule of ml_module_type
   | Smodtype of ml_module_type
 
-and ml_module_type = 
+and ml_module_type =
   | MTident of module_path
   | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
-  | MTsig of mod_self_id * ml_module_sig
+  | MTsig of module_path * ml_module_sig
   | MTwith of ml_module_type * ml_with_declaration
 
-and ml_with_declaration =  
+and ml_with_declaration =
   | ML_With_type of identifier list * identifier list * ml_type
   | ML_With_module of identifier list * module_path
 
 and ml_module_sig = (label * ml_specif) list
 
-type ml_structure_elem = 
+type ml_structure_elem =
   | SEdecl of ml_decl
   | SEmodule of ml_module
   | SEmodtype of ml_module_type
 
 and ml_module_expr =
   | MEident of module_path
-  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr 
-  | MEstruct of mod_self_id * ml_module_structure
+  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr
+  | MEstruct of module_path * ml_module_structure
   | MEapply of ml_module_expr * ml_module_expr
 
 and ml_module_structure = (label * ml_structure_elem) list
 
-and ml_module = 
-    { ml_mod_expr : ml_module_expr; 
+and ml_module =
+    { ml_mod_expr : ml_module_expr;
       ml_mod_type : ml_module_type }
 
-(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] 
+(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp]
    implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *)
 
 type ml_structure = (module_path * ml_module_structure) list
@@ -162,27 +176,26 @@ type ml_structure = (module_path * ml_module_structure) list
 type ml_signature = (module_path * ml_module_sig) list
 
 type unsafe_needs = {
-  mldummy : bool; 
-  tdummy : bool; 
-  tunknown : bool; 
+  mldummy : bool;
+  tdummy : bool;
+  tunknown : bool;
   magic : bool
 }
 
 type language_descr = {
-  keywords : Idset.t; 
+  keywords : Idset.t;
 
   (* Concerning the source file *)
-  file_suffix : string;  
-  capital_file : bool; (* should we capitalize filenames ? *)
-  preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; 
-  pp_struct : ml_structure -> std_ppcmds; 
+  file_suffix : string;
+  preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+  pp_struct : ml_structure -> std_ppcmds;
 
   (* Concerning a possible interface file *)
-  sig_suffix : string option; 
+  sig_suffix : string option;
   sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
-  pp_sig : ml_signature -> std_ppcmds; 
+  pp_sig : ml_signature -> std_ppcmds;
 
   (* for an isolated declaration print *)
-  pp_decl : ml_decl -> std_ppcmds; 
+  pp_decl : ml_decl -> std_ppcmds;
 
-}  
+}
diff --git a/contrib/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 4e2904ba..6dd43c44 100644
--- a/contrib/extraction/mlutil.ml
+++ b/plugins/extraction/mlutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.ml 13202 2010-06-25 22:36:30Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -25,40 +25,53 @@ exception Impossible
 
 (*S Names operations. *)
 
-let anonymous = id_of_string "x"
+let anonymous_name = id_of_string "x"
 let dummy_name = id_of_string "_"
 
+let anonymous = Id anonymous_name
+
 let id_of_name = function
-  | Anonymous -> anonymous
-  | Name id when id = dummy_name -> anonymous
-  | Name id -> id 
+  | Anonymous -> anonymous_name
+  | Name id when id = dummy_name -> anonymous_name
+  | Name id -> id
+
+let id_of_mlid = function
+  | Dummy -> dummy_name
+  | Id id -> id
+  | Tmp id -> id
+
+let tmp_id = function
+  | Id id -> Tmp id
+  | a -> a
+
+let is_tmp = function Tmp _ -> true | _ -> false
 
 (*S Operations upon ML types (with meta). *)
 
-let meta_count = ref 0 
-		     
+let meta_count = ref 0
+
 let reset_meta_count () = meta_count := 0
-			      
-let new_meta _ = 
-  incr meta_count; 
+
+let new_meta _ =
+  incr meta_count;
   Tmeta {id = !meta_count; contents = None}
 
 (*s Sustitution of [Tvar i] by [t] in a ML type. *)
 
-let type_subst i t0 t = 
+let type_subst i t0 t =
   let rec subst t = match t with
     | Tvar j when i = j -> t0
-    | Tmeta {contents=None} -> t 
+    | Tmeta {contents=None} -> t
     | Tmeta {contents=Some u} -> subst u
     | Tarr (a,b) -> Tarr (subst a, subst b)
     | Tglob (r, l) -> Tglob (r, List.map subst l)
-    | a -> a 
+    | a -> a
   in subst t
-       
+
 (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
 
-let type_subst_list l t = 
-  let rec subst t = match t with 
+let type_subst_list l t =
+  let rec subst t = match t with
     | Tvar j -> List.nth l (j-1)
     | Tmeta {contents=None} -> t
     | Tmeta {contents=Some u} -> subst u
@@ -69,8 +82,8 @@ let type_subst_list l t =
 
 (* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *)
 
-let type_subst_vect v t = 
-  let rec subst t = match t with 
+let type_subst_vect v t =
+  let rec subst t = match t with
     | Tvar j -> v.(j-1)
     | Tmeta {contents=None} -> t
     | Tmeta {contents=Some u} -> subst u
@@ -90,17 +103,17 @@ let rec type_occurs alpha t =
   | Tmeta {id=beta; contents=None} -> alpha = beta
   | Tmeta {contents=Some u} -> type_occurs alpha u
   | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
-  | Tglob (r,l) -> List.exists (type_occurs alpha) l  
+  | Tglob (r,l) -> List.exists (type_occurs alpha) l
   | _ -> false
 
 (*s Most General Unificator *)
 
 let rec mgu = function
   | Tmeta m, Tmeta m' when m.id = m'.id -> ()
-  | Tmeta m, t when m.contents=None -> 
+  | Tmeta m, t when m.contents=None ->
       if type_occurs m.id t then raise Impossible
       else m.contents <- Some t
-  | t, Tmeta m when m.contents=None -> 
+  | t, Tmeta m when m.contents=None ->
       if type_occurs m.id t then raise Impossible
       else m.contents <- Some t
   | Tmeta {contents=Some u}, t -> mgu (u, t)
@@ -124,12 +137,12 @@ let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a
 
 (*S ML type env. *)
 
-module Mlenv = struct 
-  
-  let meta_cmp m m' = compare m.id m'.id 
+module Mlenv = struct
+
+  let meta_cmp m m' = compare m.id m'.id
   module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end)
 
-  (* Main MLenv type. [env] is the real environment, whereas [free] 
+  (* Main MLenv type. [env] is the real environment, whereas [free]
      (tries to) record the free meta variables occurring in [env]. *)
 
   type t = { env : ml_schema list; mutable free : Metaset.t}
@@ -138,68 +151,68 @@ module Mlenv = struct
 
   let empty = { env = []; free = Metaset.empty }
 
-  (* [get] returns a instantiated copy of the n-th most recently added 
+  (* [get] returns a instantiated copy of the n-th most recently added
      type in the environment. *)
 
-  let get mle n = 
-    assert (List.length mle.env >= n); 
+  let get mle n =
+    assert (List.length mle.env >= n);
     instantiation (List.nth mle.env (n-1))
 
-  (* [find_free] finds the free meta in a type. *) 
+  (* [find_free] finds the free meta in a type. *)
 
-  let rec find_free set = function 
+  let rec find_free set = function
     | Tmeta m when m.contents = None -> Metaset.add m set
     | Tmeta {contents = Some t} -> find_free set t
     | Tarr (a,b) -> find_free (find_free set a) b
     | Tglob (_,l) -> List.fold_left find_free set l
     | _ -> set
 
-  (* The [free] set of an environment can be outdate after 
-     some unifications. [clean_free] takes care of that. *) 
-			
-  let clean_free mle = 
-    let rem = ref Metaset.empty 
-    and add = ref Metaset.empty in 
-    let clean m = match m.contents with 
-      | None -> () 
+  (* The [free] set of an environment can be outdate after
+     some unifications. [clean_free] takes care of that. *)
+
+  let clean_free mle =
+    let rem = ref Metaset.empty
+    and add = ref Metaset.empty in
+    let clean m = match m.contents with
+      | None -> ()
       | Some u -> rem := Metaset.add m !rem; add := find_free !add u
-    in 
-    Metaset.iter clean mle.free; 
+    in
+    Metaset.iter clean mle.free;
     mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add
 
   (* From a type to a type schema. If a [Tmeta] is still uninstantiated
      and does appears in the [mle], then it becomes a [Tvar]. *)
 
-  let generalization mle t = 
-    let c = ref 0 in 
-    let map = ref (Intmap.empty : int Intmap.t) in 
-    let add_new i = incr c; map := Intmap.add i !c !map; !c in 
-    let rec meta2var t = match t with 
-      | Tmeta {contents=Some u} -> meta2var u 
-      | Tmeta ({id=i} as m) -> 
-	  (try Tvar (Intmap.find i !map) 
-	   with Not_found ->  
-	     if Metaset.mem m mle.free then t 
+  let generalization mle t =
+    let c = ref 0 in
+    let map = ref (Intmap.empty : int Intmap.t) in
+    let add_new i = incr c; map := Intmap.add i !c !map; !c in
+    let rec meta2var t = match t with
+      | Tmeta {contents=Some u} -> meta2var u
+      | Tmeta ({id=i} as m) ->
+	  (try Tvar (Intmap.find i !map)
+	   with Not_found ->
+	     if Metaset.mem m mle.free then t
 	     else Tvar (add_new i))
       | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2)
-      | Tglob (r,l) -> Tglob (r, List.map meta2var l) 
-      | t -> t 
+      | Tglob (r,l) -> Tglob (r, List.map meta2var l)
+      | t -> t
     in !c, meta2var t
-	
+
   (* Adding a type in an environment, after generalizing. *)
 
-  let push_gen mle t = 
-    clean_free mle; 
+  let push_gen mle t =
+    clean_free mle;
     { env = generalization mle t :: mle.env; free = mle.free }
 
   (* Adding a type with no [Tvar], hence no generalization needed. *)
 
-  let push_type {env=e;free=f} t = 
-    { env = (0,t) :: e; free = find_free f t} 
-    
+  let push_type {env=e;free=f} t =
+    { env = (0,t) :: e; free = find_free f t}
+
   (* Adding a type with no [Tvar] nor [Tmeta]. *)
 
-  let push_std_type {env=e;free=f} t = 
+  let push_std_type {env=e;free=f} t =
     { env = (0,t) :: e; free = f}
 
 end
@@ -208,7 +221,7 @@ end
 
 (*s Does a section path occur in a ML type ? *)
 
-let rec type_mem_kn kn = function 
+let rec type_mem_kn kn = function
   | Tmeta {contents = Some t} -> type_mem_kn kn t
   | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l
   | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b)
@@ -216,31 +229,46 @@ let rec type_mem_kn kn = function
 
 (*s Greatest variable occurring in [t]. *)
 
-let type_maxvar t = 
-  let rec parse n = function 
+let type_maxvar t =
+  let rec parse n = function
     | Tmeta {contents = Some t} -> parse n t
-    | Tvar i -> max i n 
+    | Tvar i -> max i n
     | Tarr (a,b) -> parse (parse n a) b
-    | Tglob (_,l) -> List.fold_left parse n l 
-    | _ -> n 
+    | Tglob (_,l) -> List.fold_left parse n l
+    | _ -> n
   in parse 0 t
 
-(*s From [a -> b -> c] to [[a;b],c]. *) 
+(*s What are the type variables occurring in [t]. *)
+
+let intset_union_map_list f l =
+  List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l
 
-let rec type_decomp = function 
-  | Tmeta {contents = Some t} -> type_decomp t 
-  | Tarr (a,b) -> let l,h = type_decomp b in a::l, h 
+let intset_union_map_array f a =
+  Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a
+
+let rec type_listvar = function
+  | Tmeta {contents = Some t} -> type_listvar t
+  | Tvar i | Tvar' i -> Intset.singleton i
+  | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b)
+  | Tglob (_,l) -> intset_union_map_list type_listvar l
+  | _ -> Intset.empty
+
+(*s From [a -> b -> c] to [[a;b],c]. *)
+
+let rec type_decomp = function
+  | Tmeta {contents = Some t} -> type_decomp t
+  | Tarr (a,b) -> let l,h = type_decomp b in a::l, h
   | a -> [],a
 
 (*s The converse: From [[a;b],c] to [a -> b -> c]. *)
 
-let rec type_recomp (l,t) = match l with 
-  | [] -> t 
+let rec type_recomp (l,t) = match l with
+  | [] -> t
   | a::l -> Tarr (a, type_recomp (l,t))
 
 (*s Translating [Tvar] to [Tvar'] to avoid clash. *)
 
-let rec var2var' = function 
+let rec var2var' = function
   | Tmeta {contents = Some t} -> var2var' t
   | Tvar i -> Tvar' i
   | Tarr (a,b) -> Tarr (var2var' a, var2var' b)
@@ -252,84 +280,96 @@ type abbrev_map = global_reference -> ml_type option
 (*s Delta-reduction of type constants everywhere in a ML type [t].
    [env] is a function of type [ml_type_env]. *)
 
-let type_expand env t = 
+let type_expand env t =
   let rec expand = function
     | Tmeta {contents = Some t} -> expand t
-    | Tglob (r,l) ->    
-	(match env r with 
-	   | Some mlt -> expand (type_subst_list l mlt) 
+    | Tglob (r,l) ->
+	(match env r with
+	   | Some mlt -> expand (type_subst_list l mlt)
 	   | None -> Tglob (r, List.map expand l))
     | Tarr (a,b) -> Tarr (expand a, expand b)
     | a -> a
   in if Table.type_expand () then expand t else t
 
-(*s Idem, but only at the top level of implications. *)
-
-let is_arrow = function Tarr _ -> true | _ -> false
-
-let type_weak_expand env t = 
-  let rec expand = function
-    | Tmeta {contents = Some t} -> expand t
-    | Tglob (r,l) as t ->    
-	(match env r with 
-	   | Some mlt -> 
-	       let u = expand (type_subst_list l mlt) in 
-	       if is_arrow u then u else t
-	   | None -> t)
-    | Tarr (a,b) -> Tarr (a, expand b)
-    | a -> a
-  in expand t
-
 (*s Generating a signature from a ML type. *)
 
-let type_to_sign env t = match type_expand env t with 
-  | Tdummy d -> Kill d 
+let type_to_sign env t = match type_expand env t with
+  | Tdummy d -> Kill d
   | _ -> Keep
 
-let type_to_signature env t = 
-  let rec f = function 
-    | Tmeta {contents = Some t} -> f t 
+let type_to_signature env t =
+  let rec f = function
+    | Tmeta {contents = Some t} -> f t
     | Tarr (Tdummy d, b) -> Kill d :: f b
     | Tarr (_, b) -> Keep :: f b
-    | _ -> [] 
+    | _ -> []
   in f (type_expand env t)
 
 let isKill = function Kill _ -> true | _ -> false
 
 let isDummy = function Tdummy _ -> true | _ -> false
 
-let sign_of_id i = if i = dummy_name then Kill Kother else Keep
+let sign_of_id = function
+  | Dummy -> Kill Kother
+  | _ -> Keep
+
+(* Classification of signatures *)
+
+type sign_kind =
+  | EmptySig
+  | NonLogicalSig (* at least a [Keep] *)
+  | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *)
+  | SafeLogicalSig (* only [Kill Ktype] *)
+
+let rec sign_kind = function
+  | [] -> EmptySig
+  | Keep :: _ -> NonLogicalSig
+  | Kill k :: s ->
+      match sign_kind s with
+	| NonLogicalSig -> NonLogicalSig
+	| UnsafeLogicalSig -> UnsafeLogicalSig
+	| SafeLogicalSig | EmptySig ->
+	    if k = Kother then UnsafeLogicalSig else SafeLogicalSig
+
+(* Removing the final [Keep] in a signature *)
+
+let rec sign_no_final_keeps = function
+  | [] -> []
+  | k :: s ->
+      let s' = k :: sign_no_final_keeps s in
+      if s' = [Keep] then [] else s'
 
 (*s Removing [Tdummy] from the top level of a ML type. *)
 
-let type_expunge env t = 
-  let s = type_to_signature env t in 
-  if s = [] then t 
-  else if List.mem Keep s then 
-    let rec f t s = 
-      if List.exists isKill s then 
-	match t with 
-	  | Tmeta {contents = Some t} -> f t s
-	  | Tarr (a,b) -> 
-	      let t = f b (List.tl s) in 
-	      if List.hd s = Keep then Tarr (a, t) else t  
-	  | Tglob (r,l) ->
-	      (match env r with 
-		 | Some mlt -> f (type_subst_list l mlt) s
-		 | None -> assert false)
-	  | _ -> assert false
-      else t 
-    in f t s 
-  else if List.mem (Kill Kother) s then 
-    Tarr (Tdummy Kother, snd (type_decomp (type_weak_expand env t))) 
-  else snd (type_decomp (type_weak_expand env t))
+let type_expunge_from_sign env s t =
+  let rec expunge s t =
+    if s = [] then t else match t with
+      | Tmeta {contents = Some t} -> expunge s t
+      | Tarr (a,b) ->
+	  let t = expunge (List.tl s) b in
+	  if List.hd s = Keep then Tarr (a, t) else t
+      | Tglob (r,l) ->
+	  (match env r with
+	     | Some mlt -> expunge s (type_subst_list l mlt)
+	     | None -> assert false)
+      | _ -> assert false
+  in
+  let t = expunge (sign_no_final_keeps s) t in
+  if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then
+    Tarr (Tdummy Kother, t)
+  else t
+
+let type_expunge env t =
+  type_expunge_from_sign env (type_to_signature env t) t
 
 (*S Generic functions over ML ast terms. *)
 
-(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care 
+let mlapp f a = if a = [] then f else MLapp (f,a)
+
+(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care
    of the number of bingings crossed before reaching the [MLrel]. *)
 
-let ast_iter_rel f = 
+let ast_iter_rel f =
   let rec iter n = function
     | MLrel i -> f (i-n)
     | MLlam (_,a) -> iter (n+1) a
@@ -341,7 +381,7 @@ let ast_iter_rel f =
     | MLcons (_,_,l) ->  List.iter (iter n) l
     | MLmagic a -> iter n a
     | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
-  in iter 0 
+  in iter 0
 
 (*s Map over asts. *)
 
@@ -361,18 +401,18 @@ let ast_map f = function
 
 let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
 
-let ast_map_lift f n = function 
+let ast_map_lift f n = function
   | MLlam (i,a) -> MLlam (i, f (n+1) a)
   | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b)
   | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v)
-  | MLfix (i,ids,v) -> 
+  | MLfix (i,ids,v) ->
       let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v)
   | MLapp (a,l) -> MLapp (f n a, List.map (f n) l)
   | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l)
   | MLmagic a -> MLmagic (f n a)
-  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a	
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
 
-(*s Iter over asts. *) 
+(*s Iter over asts. *)
 
 let ast_iter_case f (c,ids,a) = f a
 
@@ -390,23 +430,23 @@ let ast_iter f = function
 
 (*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *)
 
-let ast_occurs k t = 
-  try 
-    ast_iter_rel (fun i -> if i = k then raise Found) t; false 
+let ast_occurs k t =
+  try
+    ast_iter_rel (fun i -> if i = k then raise Found) t; false
   with Found -> true
 
-(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] 
+(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)]
    in [t] with [k<=i<=k'] *)
 
-let ast_occurs_itvl k k' t = 
-  try 
-    ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false 
+let ast_occurs_itvl k k' t =
+  try
+    ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false
   with Found -> true
 
-(*s Number of occurences of [Rel k] and [Rel 1] in [t]. *)
+(*s Number of occurences of [Rel k] (resp. [Rel 1]) in [t]. *)
 
 let nb_occur_k k t =
-  let cpt = ref 0 in 
+  let cpt = ref 0 in
   ast_iter_rel (fun i -> if i = k then incr cpt) t;
   !cpt
 
@@ -415,19 +455,19 @@ let nb_occur t = nb_occur_k 1 t
 (* Number of occurences of [Rel 1] in [t], with special treatment of match:
    occurences in different branches aren't added, but we rather use max. *)
 
-let nb_occur_match = 
-  let rec nb k = function 
+let nb_occur_match =
+  let rec nb k = function
     | MLrel i -> if i = k then 1 else 0
-    | MLcase(_,a,v) -> 
+    | MLcase(_,a,v) ->
         (nb k a) +
-	Array.fold_left 
+	Array.fold_left
 	  (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
-    | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) 
-    | MLfix (_,ids,v) -> let k = k+(Array.length ids) in 
+    | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b)
+    | MLfix (_,ids,v) -> let k = k+(Array.length ids) in
       Array.fold_left (fun r a -> r+(nb k a)) 0 v
     | MLlam (_,a) -> nb (k+1) a
     | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l
-    | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l 
+    | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l
     | MLmagic a -> nb k a
     | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0
   in nb 1
@@ -435,7 +475,7 @@ let nb_occur_match =
 (*s Lifting on terms.
     [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *)
 
-let ast_lift k t = 
+let ast_lift k t =
   let rec liftrec n = function
     | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
     | a -> ast_map_lift liftrec n a
@@ -443,45 +483,47 @@ let ast_lift k t =
 
 let ast_pop t = ast_lift (-1) t
 
-(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... 
+(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ...
   Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *)
 
-let permut_rels k k' = 
+let permut_rels k k' =
   let rec permut n = function
     | MLrel i as a ->
 	let i' = i-n in
-	if i'<1 || i'>k+k' then a 
+	if i'<1 || i'>k+k' then a
 	else if i'<=k then MLrel (i+k')
 	else MLrel (i-k)
     | a -> ast_map_lift permut n a
-  in permut 0  
+  in permut 0
 
-(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. 
+(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t].
     Lifting (of one binder) is done at the same time. *)
 
 let ast_subst e =
   let rec subst n = function
     | MLrel i as a ->
-	let i' = i-n in 
+	let i' = i-n in
 	if i'=1 then ast_lift n e
-	else if i'<1 then a 
+	else if i'<1 then a
 	else MLrel (i-1)
     | a -> ast_map_lift subst n a
   in subst 0
 
-(*s Generalized substitution. 
-   [gen_subst v d t] applies to [t] the substitution coded in the 
-   [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies 
+(*s Generalized substitution.
+   [gen_subst v d t] applies to [t] the substitution coded in the
+   [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies
    to [Rel] greater than [Array.length v]. *)
 
-let gen_subst v d t = 
+let gen_subst v d t =
   let rec subst n = function
-    | MLrel i as a -> 
-	let i'= i-n in 
-	if i' < 1 then a 
-	else if i' <= Array.length v then 
-	  ast_lift n v.(i'-1) 
-	else MLrel (i+d) 
+    | MLrel i as a ->
+	let i'= i-n in
+	if i' < 1 then a
+	else if i' <= Array.length v then
+	  match v.(i'-1) with
+	    | None -> MLexn ("UNBOUND " ^ string_of_int i')
+	    | Some u -> ast_lift n u
+	else MLrel (i+d)
     | a -> ast_map_lift subst n a
   in subst 0 t
 
@@ -490,7 +532,7 @@ let gen_subst v d t =
 (*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
     [[idn;...;id1]] and the term [t]. *)
 
-let collect_lams = 
+let collect_lams =
   let rec collect acc = function
     | MLlam(id,t) -> collect (id::acc) t
     | x           -> acc,x
@@ -498,92 +540,90 @@ let collect_lams =
 
 (*s [collect_n_lams] does the same for a precise number of [MLlam]. *)
 
-let collect_n_lams = 
-  let rec collect acc n t = 
-    if n = 0 then acc,t 
-    else match t with 
+let collect_n_lams =
+  let rec collect acc n t =
+    if n = 0 then acc,t
+    else match t with
       | MLlam(id,t) -> collect (id::acc) (n-1) t
       | _ -> assert false
-  in collect [] 
+  in collect []
 
 (*s [remove_n_lams] just removes some [MLlam]. *)
 
-let rec remove_n_lams n t = 
-  if n = 0 then t  
-  else match t with 
+let rec remove_n_lams n t =
+  if n = 0 then t
+  else match t with
       | MLlam(_,t) -> remove_n_lams (n-1) t
       | _ -> assert false
 
 (*s [nb_lams] gives the number of head [MLlam]. *)
 
-let rec nb_lams = function 
+let rec nb_lams = function
   | MLlam(_,t) -> succ (nb_lams t)
-  | _ -> 0 
+  | _ -> 0
 
 (*s [named_lams] does the converse of [collect_lams]. *)
 
-let rec named_lams ids a = match ids with 
-  | [] -> a 
+let rec named_lams ids a = match ids with
+  | [] -> a
   | id :: ids -> named_lams ids (MLlam (id,a))
 
-(*s The same in anonymous version. *)
-
-let rec anonym_lams a = function 
-  | 0 -> a 
-  | n -> anonym_lams (MLlam (anonymous,a)) (pred n)
+(*s The same for a specific identifier (resp. anonymous, dummy) *)
 
-(*s Idem for [dummy_name]. *)
+let rec many_lams id a = function
+  | 0 -> a
+  | n -> many_lams id (MLlam (id,a)) (pred n)
 
-let rec dummy_lams a = function 
-  | 0 -> a 
-  | n -> dummy_lams (MLlam (dummy_name,a)) (pred n)
+let anonym_lams a n = many_lams anonymous a n
+let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n
+let dummy_lams a n = many_lams Dummy a n
 
 (*s mixed according to a signature. *)
 
-let rec anonym_or_dummy_lams a = function 
-  | [] -> a 
+let rec anonym_or_dummy_lams a = function
+  | [] -> a
   | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s)
-  | Kill _ :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s)
+  | Kill _ :: s -> MLlam(Dummy, anonym_or_dummy_lams a s)
 
 (*S Operations concerning eta. *)
 
 (*s The following function creates [MLrel n;...;MLrel 1] *)
 
-let rec eta_args n = 
+let rec eta_args n =
   if n = 0 then [] else (MLrel n)::(eta_args (pred n))
 
 (*s Same, but filtered by a signature. *)
 
-let rec eta_args_sign n = function 
-  | [] -> [] 
-  | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) 
+let rec eta_args_sign n = function
+  | [] -> []
+  | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s)
   | Kill _ :: s -> eta_args_sign (n-1) s
 
 (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
 
-let rec test_eta_args_lift k n = function 
+let rec test_eta_args_lift k n = function
   | [] -> n=0
   | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
 
 (*s Computes an eta-reduction. *)
 
-let eta_red e = 
-  let ids,t = collect_lams e in 
+let eta_red e =
+  let ids,t = collect_lams e in
   let n = List.length ids in
-  if n = 0 then e 
-  else match t with 
-    | MLapp (f,a) -> 
-	let m = List.length a in 
-	let ids,body,args = 
-	  if m = n then 
+  if n = 0 then e
+  else match t with
+    | MLapp (f,a) ->
+	let m = List.length a in
+	let ids,body,args =
+	  if m = n then
 	    [], f, a
-	  else if m < n then 
+	  else if m < n then
 	    list_skipn m ids, f, a
 	  else (* m > n *)
-	    let a1,a2 = list_chop (m-n) a in 
+	    let a1,a2 = list_chop (m-n) a in
 	    [], MLapp (f,a1), a2
-	in 
-	let p = List.length args in  
+	in
+	let p = List.length args in
 	if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body)
 	then named_lams ids (ast_lift (-p) body)
 	else e
@@ -592,24 +632,31 @@ let eta_red e =
 (*s Computes all head linear beta-reductions possible in [(t a)].
   Non-linear head beta-redex become let-in. *)
 
-let rec linear_beta_red a t = match a,t with  
-  | [], _ -> t 
+let rec linear_beta_red a t = match a,t with
+  | [], _ -> t
   | a0::a, MLlam (id,t) ->
       (match nb_occur_match t with
 	 | 0 -> linear_beta_red a (ast_pop t)
 	 | 1 -> linear_beta_red a (ast_subst a0 t)
-	 | _ -> 
-	     let a = List.map (ast_lift 1) a in 
+	 | _ ->
+	     let a = List.map (ast_lift 1) a in
 	     MLletin (id, a0, linear_beta_red a t))
   | _ -> MLapp (t, a)
 
-(*s Applies a substitution [s] of constants by their body, plus 
-  linear beta reductions at modified positions. *)  
+let rec tmp_head_lams = function
+  | MLlam (id, t) -> MLlam (tmp_id id, tmp_head_lams t)
+  | e -> e
 
-let rec ast_glob_subst s t = match t with 
-  | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> 
-      let a = List.map (ast_glob_subst s) a in 
-      (try linear_beta_red a (Refmap.find refe s) 
+(*s Applies a substitution [s] of constants by their body, plus
+  linear beta reductions at modified positions.
+  Moreover, we mark some lambdas as suitable for later linear
+  reduction (this helps the inlining of recursors).
+*)
+
+let rec ast_glob_subst s t = match t with
+  | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) ->
+      let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in
+      (try linear_beta_red a (Refmap.find refe s)
        with Not_found -> MLapp (f, a))
   | MLglob ((ConstRef kn) as refe) ->
       (try Refmap.find refe s with Not_found -> t)
@@ -618,115 +665,140 @@ let rec ast_glob_subst s t = match t with
 
 (*S Auxiliary functions used in simplification of ML cases. *)
 
-(*s [check_and_generalize (r0,l,c)] transforms any [MLcons(r0,l)] in [MLrel 1]
-  and raises [Impossible] if any variable in [l] occurs outside such a 
-  [MLcons] *)
-
-let check_and_generalize (r0,l,c) = 
-  let nargs = List.length l in 
-  let rec genrec n = function 
-    | MLrel i as c -> 
-	let i' = i-n in 
-	if i'<1 then c 
-	else if i'>nargs then MLrel (i-nargs+1) 
+(*s [check_function_branch (r,l,c)] checks if branch [c] can be seen
+  as a function [f] applied to [MLcons(r,l)]. For that it transforms
+  any [MLcons(r,l)] in [MLrel 1] and raises [Impossible] if any
+  variable in [l] occurs outside such a [MLcons] *)
+
+let check_function_branch (r,l,c) =
+  let nargs = List.length l in
+  let rec genrec n = function
+    | MLrel i as c ->
+	let i' = i-n in
+	if i'<1 then c
+	else if i'>nargs then MLrel (i-nargs+1)
 	else raise Impossible
-    | MLcons(_,r,args) when r=r0 && (test_eta_args_lift n nargs args) -> 
-	MLrel (n+1) 
+    | MLcons(_,r',args) when r=r' && (test_eta_args_lift n nargs args) ->
+	MLrel (n+1)
     | a -> ast_map_lift genrec n a
-  in genrec 0 c  
-
-(*s [check_generalizable_case] checks if all branches can be seen as the 
-  same function [f] applied to the term matched. It is a generalized version 
-  of the identity case optimization. *)
-
-(* CAVEAT: this optimization breaks typing in some special case. example: 
-   [type 'x a = A]. Then [let f = function A -> A] has type ['x a -> 'y a],
+  in genrec 0 c
+
+(*s [check_constant_branch (r,l,c)] checks if branch [c] is independent
+   from the pattern [MLcons(r,l)]. For that is raises [Impossible] if any
+   variable in [l] occurs in [c], and otherwise returns [c] lifted to
+   appear like a function with one arg (for uniformity with the
+   branch-as-function optimization) *)
+
+let check_constant_branch (_,l,c) =
+  let n = List.length l in
+  if ast_occurs_itvl 1 n c then raise Impossible;
+  ast_lift (1-n) c
+
+(* The following structure allows to record which element occurred
+   at what position, and then finally return the most frequent
+   element and its positions. *)
+
+let census_add, census_max, census_clean =
+  let h = Hashtbl.create 13 in
+  let clear () = Hashtbl.clear h in
+  let add e i =
+    let l = try Hashtbl.find h e with Not_found -> [] in
+    Hashtbl.replace h e (i::l)
+  in
+  let max e0 =
+    let len = ref 0 and lst = ref [] and elm = ref e0 in
+    Hashtbl.iter
+      (fun e l ->
+	 let n = List.length l in
+	 if n > !len then begin len := n; lst := l; elm := e end)
+      h;
+    (!elm,!lst)
+  in
+  (add,max,clear)
+
+(* Given an abstraction function [abstr] (one of [check_*_branch]),
+   return the longest possible list of branches that have the
+   same abstraction, along with this abstraction. *)
+
+let factor_branches abstr br =
+  census_clean ();
+  for i = 0 to Array.length br - 1 do
+    try census_add (abstr br.(i)) i with Impossible -> ()
+  done;
+  let br_factor, br_list = census_max MLdummy in
+  if br_list = [] then None
+  else if Array.length br >= 2 && List.length br_list < 2 then None
+  else Some (br_factor, br_list)
+
+(*s [check_generalizable_case] checks if all branches can be seen as the
+  same function [f] applied to the term matched. It is a generalized version
+  of both the identity case optimization and the constant case optimisation
+  ([f] can be a constant function) *)
+
+(* The optimisation [factor_branches check_function_branch] breaks types
+   in some special case. Example: [type 'x a = A].
+   Then [let f = function A -> A] has type ['x a -> 'y a],
    which is incompatible with the type of [let f x = x].
-   By default, we brutally disable this optim except for some known types: 
-   [bool], [sumbool], [sumor] *)
-
-let generalizable_list = 
-  let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes")
-  and specif = MPfile (dirpath_of_string "Coq.Init.Specif")
-  in 
-  [ make_kn datatypes empty_dirpath (mk_label "bool"); 
-    make_kn specif empty_dirpath (mk_label "sumbool");
-    make_kn specif empty_dirpath (mk_label "sumor") ]
-
-let check_generalizable_case unsafe br = 
-  if not unsafe then 
-    (match br.(0) with 
-     | ConstructRef ((kn,_),_), _, _ ->
-	 if not (List.mem kn generalizable_list) then raise Impossible
-     | _ -> assert false); 
-  let f = check_and_generalize br.(0) in 
-  for i = 1 to Array.length br - 1 do 
-    if check_and_generalize br.(i) <> f then raise Impossible 
-  done; f
-
-(*s Detecting similar branches of a match *)
-
-(* If several branches of a match are equal (and independent from their 
-   patterns) we will print them using a _ pattern. If _all_ branches 
-   are equal, we remove the match.
-*)
-
-let common_branches br = 
-  let tab = Hashtbl.create 13 in 
-  for i = 0 to Array.length br - 1 do 
-    let (r,ids,t) = br.(i) in 
-    let n = List.length ids in 
-    if not (ast_occurs_itvl 1 n t) then 
-       let t = ast_lift (-n) t in 
-       let l = try Hashtbl.find tab t with Not_found -> [] in 
-       Hashtbl.replace tab t (i::l)
-  done; 
-  let best = ref [] in 
-  Hashtbl.iter 
-    (fun _ l -> if List.length l > List.length !best then best := l) tab; 
-  if List.length !best < 2 then [] else !best
+   We check first that there isn't such phantom variable in the inductive type
+   we're considering. *)
+
+let check_optim_id br =
+  let (kn,i) =
+    match br.(0) with (ConstructRef (c,_),_,_) -> c | _ -> assert false
+  in
+  let ip = (snd (lookup_ind kn)).ind_packets.(i) in
+  match ip.ip_optim_id_ok with
+    | Some ok -> ok
+    | None ->
+	let tvars =
+	  intset_union_map_array (intset_union_map_list type_listvar)
+	    ip.ip_types
+	in
+	let ok = (Intset.cardinal tvars = List.length ip.ip_vars) in
+	ip.ip_optim_id_ok <- Some ok;
+	ok
 
 (*s If all branches are functions, try to permut the case and the functions. *)
 
-let rec merge_ids ids ids' = match ids,ids' with 
-  | [],l -> l 
+let rec merge_ids ids ids' = match ids,ids' with
+  | [],l -> l
   | l,[] -> l
-  | i::ids, i'::ids' -> 
-      (if i = dummy_name then i' else i) :: (merge_ids ids ids')
+  | i::ids, i'::ids' ->
+      (if i = Dummy then i' else i) :: (merge_ids ids ids')
 
 let is_exn = function MLexn _ -> true | _ -> false
 
-let rec permut_case_fun br acc = 
-  let nb = ref max_int in 
-  Array.iter (fun (_,_,t) -> 
-		let ids, c = collect_lams t in 
-		let n = List.length ids in 
-		if (n < !nb) && (not (is_exn c)) then nb := n) br; 
-  if !nb = max_int || !nb = 0 then ([],br) 
+let rec permut_case_fun br acc =
+  let nb = ref max_int in
+  Array.iter (fun (_,_,t) ->
+		let ids, c = collect_lams t in
+		let n = List.length ids in
+		if (n < !nb) && (not (is_exn c)) then nb := n) br;
+  if !nb = max_int || !nb = 0 then ([],br)
   else begin
-    let br = Array.copy br in 
-    let ids = ref [] in  
-    for i = 0 to Array.length br - 1 do 
-      let (r,l,t) = br.(i) in 
-      let local_nb = nb_lams t in 
+    let br = Array.copy br in
+    let ids = ref [] in
+    for i = 0 to Array.length br - 1 do
+      let (r,l,t) = br.(i) in
+      let local_nb = nb_lams t in
       if local_nb < !nb then (* t = MLexn ... *)
 	br.(i) <- (r,l,remove_n_lams local_nb t)
       else begin
-	let local_ids,t = collect_n_lams !nb t in 
-	ids := merge_ids !ids local_ids; 
+	let local_ids,t = collect_n_lams !nb t in
+	ids := merge_ids !ids local_ids;
 	br.(i) <- (r,l,permut_rels !nb (List.length l) t)
       end
-    done; 
+    done;
     (!ids,br)
   end
-  
+
 (*S Generalized iota-reduction. *)
 
-(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] 
-   with [(is_iota_gen e)=true]. Any generalized iota-redex is 
+(* Definition of a generalized iota-redex: it's a [MLcase(e,_)]
+   with [(is_iota_gen e)=true]. Any generalized iota-redex is
    transformed into beta-redexes. *)
 
-let rec is_iota_gen = function 
+let rec is_iota_gen = function
   | MLcons _ -> true
   | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
   | _ -> false
@@ -735,156 +807,165 @@ let constructor_index = function
   | ConstructRef (_,j) -> pred j
   | _ -> assert false
 
-let iota_gen br = 
-  let rec iota k = function 
+let iota_gen br =
+  let rec iota k = function
     | MLcons (i,r,a) ->
 	let (_,ids,c) = br.(constructor_index r) in
 	let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in
-	let c = ast_lift k c in 
+	let c = ast_lift k c in
 	MLapp (c,a)
-    | MLcase(i,e,br') -> 
-	let new_br = 
+    | MLcase(i,e,br') ->
+	let new_br =
 	  Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br'
 	in MLcase(i,e, new_br)
     | _ -> assert false
-  in iota 0 
+  in iota 0
 
-let is_atomic = function 
+let is_atomic = function
   | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
   | _ -> false
 
+let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false
+
 (*S The main simplification function. *)
 
 (* Some beta-iota reductions + simplifications. *)
 
 let rec simpl o = function
-  | MLapp (f, []) ->
-      simpl o f
-  | MLapp (f, a) -> 
-      simpl_app o (List.map (simpl o) a) (simpl o f)
+  | MLapp (f, []) -> simpl o f
+  | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f)
   | MLcase (i,e,br) ->
-      let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in 
-      simpl_case o i br (simpl o e) 
-  | MLletin(id,c,e) -> 
-      let e = (simpl o e) in 
-      if 
-	(id = dummy_name) || (is_atomic c) || (is_atomic e) ||
-	(let n = nb_occur_match e in n = 0 || (n=1 && o.opt_lin_let))
-      then 
+      let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in
+      simpl_case o i br (simpl o e)
+  | MLletin(Dummy,_,e) -> simpl o (ast_pop e)
+  | MLletin(id,c,e) ->
+      let e = simpl o e in
+      if
+	(is_atomic c) || (is_atomic e) ||
+	(let n = nb_occur_match e in
+	 (n = 0 || (n=1 && (is_tmp id || is_imm_apply e || o.opt_lin_let))))
+      then
 	simpl o (ast_subst c e)
-      else 
+      else
 	MLletin(id, simpl o c, e)
-  | MLfix(i,ids,c) -> 
-      let n = Array.length ids in 
-      if ast_occurs_itvl 1 n c.(i) then 
+  | MLfix(i,ids,c) ->
+      let n = Array.length ids in
+      if ast_occurs_itvl 1 n c.(i) then
 	MLfix (i, ids, Array.map (simpl o) c)
       else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *)
-  | a -> ast_map (simpl o) a 
+  | a -> ast_map (simpl o) a
+
+(* invariant : list [a] of arguments is non-empty *)
 
-and simpl_app o a = function  
+and simpl_app o a = function
   | MLapp (f',a') -> simpl_app o (a'@a) f'
-  | MLlam (id,t) when id = dummy_name -> 
+  | MLlam (Dummy,t) ->
       simpl o (MLapp (ast_pop t, List.tl a))
   | MLlam (id,t) -> (* Beta redex *)
       (match nb_occur_match t with
 	 | 0 -> simpl o (MLapp (ast_pop t, List.tl a))
-	 | 1 when o.opt_lin_beta -> 
+	 | 1 when (is_tmp id || o.opt_lin_beta) ->
 	     simpl o (MLapp (ast_subst (List.hd a) t, List.tl a))
-	 | _ -> 
+	 | _ ->
 	     let a' = List.map (ast_lift 1) (List.tl a) in
 	     simpl o (MLletin (id, List.hd a, MLapp (t, a'))))
-  | MLletin (id,e1,e2) when o.opt_let_app -> 
+  | MLletin (id,e1,e2) when o.opt_let_app ->
       (* Application of a letin: we push arguments inside *)
       MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a)))
-  | MLcase (i,e,br) when o.opt_case_app -> 
+  | MLcase (i,e,br) when o.opt_case_app ->
       (* Application of a case: we push arguments inside *)
-      let br' = 
-	Array.map 
-      	  (fun (n,l,t) -> 
+      let br' =
+	Array.map
+      	  (fun (n,l,t) ->
 	     let k = List.length l in
 	     let a' = List.map (ast_lift k) a in
-      	     (n, l, simpl o (MLapp (t,a')))) br 
-      in simpl o (MLcase (i,e,br')) 
-  | (MLdummy | MLexn _) as e -> e 
+      	     (n, l, simpl o (MLapp (t,a')))) br
+      in simpl o (MLcase (i,e,br'))
+  | (MLdummy | MLexn _) as e -> e
 	(* We just discard arguments in those cases. *)
   | f -> MLapp (f,a)
 
-and simpl_case o i br e = 
+(* Invariant : all empty matches should now be [MLexn] *)
+
+and simpl_case o i br e =
   if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *)
     simpl o (iota_gen br e)
-  else 
-    try (* Does a term [f] exist such that each branch is [(f e)] ? *)
-      if not o.opt_case_idr then raise Impossible;
-      let f = check_generalizable_case o.opt_case_idg br in 
-      simpl o (MLapp (MLlam (anonymous,f),[e]))
-    with Impossible -> 
-      (* Detect common branches *)
-      let common_br = if not o.opt_case_cst then [] else common_branches br in
-      if List.length common_br = Array.length br && br <> [||] then 
-	let (_,ids,t) = br.(0) in ast_lift (-List.length ids) t
-      else 
-	let new_i = (fst i, common_br) in 
-	(* Swap the case and the lam if possible *)
-	if o.opt_case_fun 
-	then 
-	  let ids,br = permut_case_fun br [] in 
-	  let n = List.length ids in 
-	  if n <> 0 then named_lams ids (MLcase (new_i,ast_lift n e, br))
-	  else MLcase (new_i,e,br) 
-	else MLcase (new_i,e,br)
-
-let rec post_simpl = function 
-  | MLletin(_,c,e) when (is_atomic (eta_red c)) -> 
-      post_simpl (ast_subst (eta_red c) e)
-  | a -> ast_map post_simpl a 
-
-(*S Local prop elimination. *) 
+  else
+    (* Swap the case and the lam if possible *)
+    let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in
+    let n = List.length ids in
+    if n <> 0 then
+      simpl o (named_lams ids (MLcase (i,ast_lift n e, br)))
+    else
+      (* Does a term [f] exist such that many branches are [(f e)] ? *)
+      let opt1 =
+	if o.opt_case_idr && (o.opt_case_idg || check_optim_id br) then
+	  factor_branches check_function_branch br
+	else None
+      in
+      (* Detect common constant branches. Often a particular case of
+	 branch-as-function optim, but not always (e.g. A->A|B->A) *)
+      let opt2 =
+	if opt1 = None && o.opt_case_cst then
+	  factor_branches check_constant_branch br
+	else opt1
+      in
+      match opt2 with
+	| Some (f,ints) when List.length ints = Array.length br ->
+	    (* if all branches have been factorized, we remove the match *)
+	    simpl o (MLletin (Tmp anonymous_name, e, f))
+	| Some (f,ints) ->
+	    let ci = if ast_occurs 1 f then BranchFun ints else BranchCst ints
+	    in MLcase ((fst i,ci), e, br)
+	| None -> MLcase (i, e, br)
+
+(*S Local prop elimination. *)
 (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *)
 
-(*s In a list, it selects only the elements corresponding to a [Keep] 
+(*s In a list, it selects only the elements corresponding to a [Keep]
    in the boolean list [l]. *)
 
-let rec select_via_bl l args = match l,args with 
+let rec select_via_bl l args = match l,args with
   | [],_ -> args
   | Keep::l,a::args -> a :: (select_via_bl l args)
   | Kill _::l,a::args -> select_via_bl l args
-  | _ -> assert false 
+  | _ -> assert false
 
 (*s [kill_some_lams] removes some head lambdas according to the signature [bl].
    This list is build on the identifier list model: outermost lambda
-   is on the right. 
-   [Rels] corresponding to removed lambdas are supposed not to occur, and 
+   is on the right.
+   [Rels] corresponding to removed lambdas are supposed not to occur, and
    the other [Rels] are made correct via a [gen_subst].
    Output is not directly a [ml_ast], compose with [named_lams] if needed. *)
 
 let kill_some_lams bl (ids,c) =
   let n = List.length bl in
-  let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in 
+  let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in
   if n = n' then ids,c
-  else if n' = 0 then [],ast_lift (-n) c 
+  else if n' = 0 then [],ast_lift (-n) c
   else begin
-    let v = Array.make n MLdummy in 
-    let rec parse_ids i j = function 
+    let v = Array.make n None in
+    let rec parse_ids i j = function
       | [] -> ()
-      | Keep :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l
+      | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l
       | Kill _ :: l -> parse_ids (i+1) j l
-    in parse_ids 0 1 bl ; 
+    in parse_ids 0 1 bl;
     select_via_bl bl ids, gen_subst v (n'-n) c
   end
 
-(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding 
-  to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or 
+(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding
+  to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or
   if there is no lambda left at all. *)
 
-let kill_dummy_lams c = 
-  let ids,c = collect_lams c in 
+let kill_dummy_lams c =
+  let ids,c = collect_lams c in
   let bl = List.map sign_of_id ids in
-  if (List.mem Keep bl) && (List.exists isKill bl) then 
-    let ids',c = kill_some_lams bl (ids,c) in 
+  if (List.mem Keep bl) && (List.exists isKill bl) then
+    let ids',c = kill_some_lams bl (ids,c) in
     ids, named_lams ids' c
   else raise Impossible
 
-(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] 
+(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c]
    and a signature [s] and builds a eta-long version. *)
 
 (* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is :
@@ -892,137 +973,153 @@ let kill_dummy_lams c =
 
 let eta_expansion_sign s (ids,c) =
   let rec abs ids rels i = function
-    | [] -> 
+    | [] ->
 	let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels
-	in ids, MLapp (ast_lift (i-1) c, a) 
-    | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l 
-    | Kill _ :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l
+	in ids, MLapp (ast_lift (i-1) c, a)
+    | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l
+    | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l
   in abs ids [] 1 s
 
-(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] 
-  in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas 
+(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e]
+  in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas
   corresponding to [Del] in [s]. *)
 
-let case_expunge s e = 
-  let m = List.length s in 
-  let n = nb_lams e in 
-  let p = if m <= n then collect_n_lams m e 
-  else eta_expansion_sign (list_skipn n s) (collect_lams e) in 
+let case_expunge s e =
+  let m = List.length s in
+  let n = nb_lams e in
+  let p = if m <= n then collect_n_lams m e
+  else eta_expansion_sign (list_skipn n s) (collect_lams e) in
   kill_some_lams (List.rev s) p
 
-(*s [term_expunge] takes a function [fun idn ... id1 -> c] 
-  and a signature [s] and remove dummy lams. The difference 
-  with [case_expunge] is that we here leave one dummy lambda 
-  if all lambdas are logical dummy. *)
+(*s [term_expunge] takes a function [fun idn ... id1 -> c]
+  and a signature [s] and remove dummy lams. The difference
+  with [case_expunge] is that we here leave one dummy lambda
+  if all lambdas are logical dummy and the target language is strict. *)
 
 let term_expunge s (ids,c) =
-  if s = [] then c 
-  else 
-    let ids,c = kill_some_lams (List.rev s) (ids,c) in 
-    if ids = [] && List.mem (Kill Kother) s then 
-      MLlam (dummy_name, ast_lift 1 c)
+  if s = [] then c
+  else
+    let ids,c = kill_some_lams (List.rev s) (ids,c) in
+    if ids = [] && lang () <> Haskell && List.mem (Kill Kother) s then
+      MLlam (Dummy, ast_lift 1 c)
     else named_lams ids c
 
-(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and 
-  purge the args of [t0] corresponding to a [dummy_name]. 
-  It makes eta-expansion if needed. *) 
+(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and
+  purge the args of [t0] corresponding to a [dummy_name].
+  It makes eta-expansion if needed. *)
 
 let kill_dummy_args ids t0 t =
-  let m = List.length ids in 
+  let m = List.length ids in
   let bl = List.rev_map sign_of_id ids in
-  let rec killrec n = function 
-    | MLapp(e, a) when e = ast_lift n t0 -> 
-	let k = max 0 (m - (List.length a)) in 
-	let a = List.map (killrec n) a in  
-	let a = List.map (ast_lift k) a in 
-	let a = select_via_bl bl (a @ (eta_args k)) in 
-	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) 
-    | e when e = ast_lift n t0 -> 
-	let a = select_via_bl bl (eta_args m) in 
+  let rec killrec n = function
+    | MLapp(e, a) when e = ast_lift n t0 ->
+	let k = max 0 (m - (List.length a)) in
+	let a = List.map (killrec n) a in
+	let a = List.map (ast_lift k) a in
+	let a = select_via_bl bl (a @ (eta_args k)) in
+	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a))
+    | e when e = ast_lift n t0 ->
+	let a = select_via_bl bl (eta_args m) in
 	named_lams ids (MLapp (ast_lift m e, a))
-    | e -> ast_map_lift killrec n e 
-  in killrec 0 t 
+    | e -> ast_map_lift killrec n e
+  in killrec 0 t
 
 (*s The main function for local [dummy] elimination. *)
 
-let rec kill_dummy = function 
-  | MLfix(i,fi,c) -> 
-      (try 
-	 let ids,c = kill_dummy_fix i fi c in 
+let rec kill_dummy = function
+  | MLfix(i,fi,c) ->
+      (try
+	 let ids,c = kill_dummy_fix i c in
 	 ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1))
        with Impossible -> MLfix (i,fi,Array.map kill_dummy c))
-  | MLapp (MLfix (i,fi,c),a) -> 
-      (try 
-	 let ids,c = kill_dummy_fix i fi c in 
-	 let a = List.map (fun t -> ast_lift 1 (kill_dummy t)) a in 
-	 let e = kill_dummy_args ids (MLrel 1) (MLapp (MLrel 1,a)) in
-	 ast_subst (MLfix (i,fi,c)) e  
-       with Impossible -> 
-	 MLapp(MLfix(i,fi,Array.map kill_dummy c),List.map kill_dummy a))
-  | MLletin(id, MLfix (i,fi,c),e) -> 
-      (try 
-	 let ids,c = kill_dummy_fix i fi c in
-	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in 
+  | MLapp (MLfix (i,fi,c),a) ->
+      let a = List.map kill_dummy a in
+      (try
+	 let ids,c = kill_dummy_fix i c in
+	 let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in
+	 let fake' = kill_dummy_args ids (MLrel 1) fake in
+	 ast_subst (MLfix (i,fi,c)) fake'
+       with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a))
+  | MLletin(id, MLfix (i,fi,c),e) ->
+      (try
+	 let ids,c = kill_dummy_fix i c in
+	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in
 	 MLletin(id, MLfix(i,fi,c),e)
-      with Impossible -> 
+      with Impossible ->
 	MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e))
-  | MLletin(id,c,e) -> 
-      (try 
-	 let ids,c = kill_dummy_lams c in 
-	 let e = kill_dummy_args ids (MLrel 1) e in 
-	 MLletin (id, kill_dummy c,kill_dummy e) 
+  | MLletin(id,c,e) ->
+      (try
+	 let ids,c = kill_dummy_lams (kill_dummy_hd c) in
+	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in
+	 let c = eta_red (kill_dummy c) in
+	 if is_atomic c then ast_subst c e else MLletin (id, c, e)
        with Impossible -> MLletin(id,kill_dummy c,kill_dummy e))
   | a -> ast_map kill_dummy a
 
-and kill_dummy_fix i fi c = 
-  let n = Array.length fi in 
-  let ids,ci = kill_dummy_lams c.(i) in 
-  let c = Array.copy c in c.(i) <- ci; 
-  for j = 0 to (n-1) do 
-    c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) 
+(* Similar function, but acting only on head lambdas and let-ins *)
+
+and kill_dummy_hd = function
+  | MLlam(id,e) -> MLlam(id, kill_dummy_hd e)
+  | MLletin(id,c,e) ->
+      (try
+	 let ids,c = kill_dummy_lams (kill_dummy_hd c) in
+	 let e = kill_dummy_hd (kill_dummy_args ids (MLrel 1) e) in
+	 let c = eta_red (kill_dummy c) in
+	 if is_atomic c then ast_subst c e else MLletin (id, c, e)
+       with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e))
+  | a -> a
+
+and kill_dummy_fix i c =
+  let n = Array.length c in
+  let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in
+  let c = Array.copy c in c.(i) <- ci;
+  for j = 0 to (n-1) do
+    c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j))
   done;
   ids,c
 
 (*s Putting things together. *)
 
-let normalize a = 
-  let o = optims () in 
-  let a = simpl o a in 
-  if o.opt_kill_dum then post_simpl (kill_dummy a) else a
+let normalize a =
+  let o = optims () in
+  let rec norm a =
+    let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in
+    if a = a' then a else norm a'
+  in norm a
 
 (*S Special treatment of fixpoint for pretty-printing purpose. *)
 
-let general_optimize_fix f ids n args m c = 
-  let v = Array.make n 0 in 
+let general_optimize_fix f ids n args m c =
+  let v = Array.make n 0 in
   for i=0 to (n-1) do v.(i)<-i done;
-  let aux i = function 
-    | MLrel j when v.(j-1)>=0 -> 
+  let aux i = function
+    | MLrel j when v.(j-1)>=0 ->
 	if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1)
     | _ -> raise Impossible
-  in list_iter_i aux args; 
+  in list_iter_i aux args;
   let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
-  let new_f = anonym_lams (MLapp (MLrel (n+m+1),args_f)) m in  
+  let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in
   let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
   MLfix(0,[|f|],[|new_c|])
 
-let optimize_fix a = 
-  if not (optims()).opt_fix_fun then a 
+let optimize_fix a =
+  if not (optims()).opt_fix_fun then a
   else
-    let ids,a' = collect_lams a in 
-    let n = List.length ids in 
-    if n = 0 then a 
-    else match a' with 
+    let ids,a' = collect_lams a in
+    let n = List.length ids in
+    if n = 0 then a
+    else match a' with
       | MLfix(_,[|f|],[|c|]) ->
-	  let new_f = MLapp (MLrel (n+1),eta_args n) in 
+	  let new_f = MLapp (MLrel (n+1),eta_args n) in
 	  let new_c = named_lams ids (normalize (ast_subst new_f c))
 	  in MLfix(0,[|f|],[|new_c|])
       | MLapp(a',args) ->
-	  let m = List.length args in 
-	  (match a' with 
-	     | MLfix(_,_,_) when 
-		 (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') 
+	  let m = List.length args in
+	  (match a' with
+	     | MLfix(_,_,_) when
+		 (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a')
 		 -> a'
-	     | MLfix(_,[|f|],[|c|]) -> 
+	     | MLfix(_,[|f|],[|c|]) ->
 		 (try general_optimize_fix f ids n args m c
 		  with Impossible -> a)
 	     | _ -> a)
@@ -1036,7 +1133,7 @@ let rec ml_size = function
   | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l
   | MLlam(_,t) -> 1 + ml_size t
   | MLcons(_,_,l) -> ml_size_list l
-  | MLcase(_,t,pv) -> 
+  | MLcase(_,t,pv) ->
       1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0)
   | MLfix(_,_,f) -> ml_size_array f
   | MLletin (_,_,t) -> ml_size t
@@ -1057,111 +1154,140 @@ let rec is_constr = function
 (*s Strictness *)
 
 (* A variable is strict if the evaluation of the whole term implies
-   the evaluation of this variable. Non-strict variables can be found 
-   behind Match, for example. Expanding a term [t] is a good idea when 
-   it begins by at least one non-strict lambda, since the corresponding 
+   the evaluation of this variable. Non-strict variables can be found
+   behind Match, for example. Expanding a term [t] is a good idea when
+   it begins by at least one non-strict lambda, since the corresponding
    argument to [t] might be unevaluated in the expanded code. *)
 
 exception Toplevel
 
 let lift n l = List.map ((+) n) l
 
-let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l 
+let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l
 
 (* This function returns a list of de Bruijn indices of non-strict variables,
-   or raises [Toplevel] if it has an internal non-strict variable. 
-   In fact, not all variables are checked for strictness, only the ones which 
-   de Bruijn index is in the candidates list [cand]. The flag [add] controls 
-   the behaviour when going through a lambda: should we add the corresponding 
-   variable to the candidates?  We use this flag to check only the external 
+   or raises [Toplevel] if it has an internal non-strict variable.
+   In fact, not all variables are checked for strictness, only the ones which
+   de Bruijn index is in the candidates list [cand]. The flag [add] controls
+   the behaviour when going through a lambda: should we add the corresponding
+   variable to the candidates?  We use this flag to check only the external
    lambdas, those that will correspond to arguments. *)
 
-let rec non_stricts add cand = function 
-  | MLlam (id,t) -> 
+let rec non_stricts add cand = function
+  | MLlam (id,t) ->
       let cand = lift 1 cand in
       let cand = if add then 1::cand else cand in
       pop 1 (non_stricts add cand t)
-  | MLrel n -> 
-      List.filter ((<>) n) cand  
-  | MLapp (MLrel n, _) -> 
+  | MLrel n ->
       List.filter ((<>) n) cand
-	(* In [(x y)] we say that only x is strict. Cf [sig_rec]. We may *)
-	(* gain something if x is replaced by a function like a projection *)
-  | MLapp (t,l)-> 
-      let cand = non_stricts false cand t in 
-      List.fold_left (non_stricts false) cand l 
-  | MLcons (_,_,l) -> 
+  | MLapp (t,l)->
+      let cand = non_stricts false cand t in
       List.fold_left (non_stricts false) cand l
-  | MLletin (_,t1,t2) -> 
-      let cand = non_stricts false cand t1 in 
+  | MLcons (_,_,l) ->
+      List.fold_left (non_stricts false) cand l
+  | MLletin (_,t1,t2) ->
+      let cand = non_stricts false cand t1 in
       pop 1 (non_stricts add (lift 1 cand) t2)
-  | MLfix (_,i,f)-> 
+  | MLfix (_,i,f)->
       let n = Array.length i in
-      let cand = lift n cand in 
-      let cand = Array.fold_left (non_stricts false) cand f in 
+      let cand = lift n cand in
+      let cand = Array.fold_left (non_stricts false) cand f in
       pop n cand
-  | MLcase (_,t,v) -> 
+  | MLcase (_,t,v) ->
       (* The only interesting case: for a variable to be non-strict, *)
       (* it is sufficient that it appears non-strict in at least one branch, *)
       (* so we make an union (in fact a merge). *)
-      let cand = non_stricts false cand t in 
-      Array.fold_left 
-	(fun c (_,i,t)-> 
-	   let n = List.length i in 
-	   let cand = lift n cand in 
+      let cand = non_stricts false cand t in
+      Array.fold_left
+	(fun c (_,i,t)->
+	   let n = List.length i in
+	   let cand = lift n cand in
 	   let cand = pop n (non_stricts add cand t) in
 	   Sort.merge (<=) cand c) [] v
 	(* [merge] may duplicates some indices, but I don't mind. *)
-  | MLmagic t -> 
+  | MLmagic t ->
       non_stricts add cand t
-  | _ -> 
+  | _ ->
       cand
 
 (* The real test: we are looking for internal non-strict variables, so we start
-   with no candidates, and the only positive answer is via the [Toplevel] 
+   with no candidates, and the only positive answer is via the [Toplevel]
    exception. *)
 
-let is_not_strict t = 
+let is_not_strict t =
   try let _ = non_stricts true [] t in false
   with Toplevel -> true
 
 (*s Inlining decision *)
 
-(* [inline_test] answers the following question: 
-   If we could inline [t] (the user said nothing special), 
-   should we inline ? 
-   
-   We expand small terms with at least one non-strict 
+(* [inline_test] answers the following question:
+   If we could inline [t] (the user said nothing special),
+   should we inline ?
+
+   We expand small terms with at least one non-strict
    variable (i.e. a variable that may not be evaluated).
-   
-   Futhermore we don't expand fixpoints. *)
 
-let inline_test t = 
-  let t1 = eta_red t in 
-  let t2 = snd (collect_lams t1) in
-  not (is_fix t2) && ml_size t < 12 && is_not_strict t
+   Futhermore we don't expand fixpoints.
 
-let manual_inline_list = 
-  let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in 
-  List.map (fun s -> (make_con mp empty_dirpath (mk_label s)))
-    [ "well_founded_induction_type"; "well_founded_induction"; 
-      "Acc_rect"; "Acc_rec" ; "Acc_iter" ; "Fix" ]
+   Moreover, as mentionned by X. Leroy (bug #2241),
+   inling a constant from inside an opaque module might
+   break types. To avoid that, we require below that
+   both [r] and its body are globally visible. This isn't
+   fully satisfactory, since [r] might not be visible (functor),
+   and anyway it might be interesting to inline [r] at least
+   inside its own structure. But to be safe, we adopt this
+   restriction for the moment.
+*)
+
+open Declarations
 
-let manual_inline = function 
-  | ConstRef c -> List.mem c manual_inline_list
-  | _ -> false 
+let inline_test r t =
+  if not (auto_inline ()) then false
+  else
+    let c = match r with ConstRef c -> c | _ -> assert false in
+    let body = try (Global.lookup_constant c).const_body with _ -> None in
+    if body = None then false
+    else
+      let t1 = eta_red t in
+      let t2 = snd (collect_lams t1) in
+      not (is_fix t2) && ml_size t < 12 && is_not_strict t
+
+let con_of_string s =
+  let null = empty_dirpath in
+  match repr_dirpath (dirpath_of_string s) with
+    | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id)
+    | [] -> assert false
+
+let manual_inline_set =
+  List.fold_right (fun x -> Cset.add (con_of_string x))
+    [ "Coq.Init.Wf.well_founded_induction_type";
+      "Coq.Init.Wf.well_founded_induction";
+      "Coq.Init.Wf.Acc_iter";
+      "Coq.Init.Wf.Fix_F";
+      "Coq.Init.Wf.Fix";
+      "Coq.Init.Datatypes.andb";
+      "Coq.Init.Datatypes.orb";
+      "Coq.Init.Logic.eq_rec_r";
+      "Coq.Init.Logic.eq_rect_r";
+      "Coq.Init.Specif.proj1_sig";
+    ]
+    Cset.empty
+
+let manual_inline = function
+  | ConstRef c -> Cset.mem c manual_inline_set
+  | _ -> false
 
 (* If the user doesn't say he wants to keep [t], we inline in two cases:
    \begin{itemize}
-   \item the user explicitly requests it 
-   \item [expansion_test] answers that the inlining is a good idea, and 
+   \item the user explicitly requests it
+   \item [expansion_test] answers that the inlining is a good idea, and
    we are free to act (AutoInline is set)
    \end{itemize} *)
 
-let inline r t = 
+let inline r t =
   not (to_keep r) (* The user DOES want to keep it *)
-  && not (is_inline_custom r) 
-  && (to_inline r (* The user DOES want to inline it *) 
-     || (auto_inline () && lang () <> Haskell && not (is_projection r)
-         && (is_recursor r || manual_inline r || inline_test t)))
+  && not (is_inline_custom r)
+  && (to_inline r (* The user DOES want to inline it *)
+     || (lang () <> Haskell && not (is_projection r) &&
+         (is_recursor r || manual_inline r || inline_test r t)))
 
diff --git a/contrib/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
index a55caaf2..deaacc3f 100644
--- a/contrib/extraction/mlutil.mli
+++ b/plugins/extraction/mlutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
@@ -31,11 +31,11 @@ val put_magic : ml_type * ml_type -> ml_ast -> ml_ast
 
 (*s ML type environment. *)
 
-module Mlenv : sig 
-  type t 
+module Mlenv : sig
+  type t
   val empty : t
-    
-  (* get the n-th more recently entered schema and instantiate it. *) 
+
+  (* get the n-th more recently entered schema and instantiate it. *)
   val get : t -> int -> ml_type
 
   (* Adding a type in an environment, after generalizing free meta *)
@@ -43,57 +43,62 @@ module Mlenv : sig
 
   (* Adding a type with no [Tvar] *)
   val push_type : t -> ml_type -> t
-     
+
   (* Adding a type with no [Tvar] nor [Tmeta] *)
   val push_std_type : t -> ml_type -> t
 end
 
 (*s Utility functions over ML types without meta *)
 
-val type_mem_kn : kernel_name -> ml_type -> bool
+val type_mem_kn : mutual_inductive -> ml_type -> bool
 
 val type_maxvar : ml_type -> int
 
 val type_decomp : ml_type -> ml_type list * ml_type
 val type_recomp : ml_type list * ml_type -> ml_type
 
-val var2var' : ml_type -> ml_type 
+val var2var' : ml_type -> ml_type
 
 type abbrev_map = global_reference -> ml_type option
 
-val type_expand : abbrev_map -> ml_type -> ml_type 
+val type_expand : abbrev_map -> ml_type -> ml_type
 val type_to_sign : abbrev_map -> ml_type -> sign
 val type_to_signature : abbrev_map -> ml_type -> signature
 val type_expunge : abbrev_map -> ml_type -> ml_type
+val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type
 
 val isDummy : ml_type -> bool
 val isKill : sign -> bool
 
-val case_expunge : signature -> ml_ast -> identifier list * ml_ast
-val term_expunge : signature -> identifier list * ml_ast -> ml_ast
+val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast
+val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast
 
 
 (*s Special identifiers. [dummy_name] is to be used for dead code
     and will be printed as [_] in concrete (Caml) code. *)
 
-val anonymous : identifier
+val anonymous_name : identifier
 val dummy_name : identifier
 val id_of_name : name -> identifier
+val id_of_mlid : ml_ident -> identifier
+val tmp_id : ml_ident -> ml_ident
 
 (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
     the list [idn;...;id1] and the term [t]. *)
 
-val collect_lams : ml_ast -> identifier list * ml_ast
-val collect_n_lams : int -> ml_ast -> identifier list * ml_ast
+val collect_lams : ml_ast -> ml_ident list * ml_ast
+val collect_n_lams : int -> ml_ast -> ml_ident list * ml_ast
+val remove_n_lams : int -> ml_ast -> ml_ast
 val nb_lams : ml_ast -> int
-
+val named_lams : ml_ident list -> ml_ast -> ml_ast
 val dummy_lams : ml_ast -> int -> ml_ast
 val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast
 
-val eta_args_sign : int -> signature -> ml_ast list 
+val eta_args_sign : int -> signature -> ml_ast list
 
 (*s Utility functions over ML terms. *)
 
+val mlapp : ml_ast -> ml_ast list -> ml_ast
 val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast
 val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast
 val ast_iter : (ml_ast -> unit) -> ml_ast -> unit
@@ -105,9 +110,22 @@ val ast_subst : ml_ast -> ml_ast -> ml_ast
 
 val ast_glob_subst : ml_ast Refmap.t -> ml_ast -> ml_ast
 
-val normalize : ml_ast -> ml_ast 
+val normalize : ml_ast -> ml_ast
 val optimize_fix : ml_ast -> ml_ast
 val inline : global_reference -> ml_ast -> bool
 
+exception Impossible
+val check_function_branch : ml_branch -> ml_ast
+val check_constant_branch : ml_branch -> ml_ast
+
+(* Classification of signatures *)
+
+type sign_kind =
+  | EmptySig
+  | NonLogicalSig (* at least a [Keep] *)
+  | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *)
+  | SafeLogicalSig (* only [Kill Ktype] *)
 
+val sign_kind : signature -> sign_kind
 
+val sign_no_final_keeps : signature -> signature
diff --git a/contrib/extraction/modutil.ml b/plugins/extraction/modutil.ml
index 68adeb81..a7f0c017 100644
--- a/contrib/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.ml 11602 2008-11-18 00:08:33Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Names
 open Declarations
@@ -21,20 +21,16 @@ open Mod_subst
 (*S Functions upon ML modules. *)
 
 let rec msid_of_mt = function
-  | MTident mp -> begin
-      match Modops.eval_struct (Global.env()) (SEBident mp) with
-	| SEBstruct(msid,_) -> MPself msid
-	| _ -> anomaly "Extraction:the With can't be applied to a funsig"
-    end
+  | MTident mp -> mp
   | MTwith(mt,_)-> msid_of_mt mt
   | _ -> anomaly "Extraction:the With operator isn't applied to a name"
 
-(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a 
-   [ml_structure]. *) 
+(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a
+   [ml_structure]. *)
 
-let struct_iter do_decl do_spec s = 
-  let rec mt_iter = function 
-    | MTident _ -> () 
+let struct_iter do_decl do_spec s =
+  let rec mt_iter = function
+    | MTident _ -> ()
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
     | MTwith (mt,ML_With_type(idl,l,t))->
 	let mp_mt = msid_of_mt mt in
@@ -46,80 +42,81 @@ let struct_iter do_decl do_spec s =
 	mt_iter mt; do_decl (Dtype(r,l,t))
     | MTwith (mt,_)->mt_iter mt
     | MTsig (_, sign) -> List.iter spec_iter sign
-  and spec_iter = function 
+  and spec_iter = function
     | (_,Spec s) -> do_spec s
     | (_,Smodule mt) -> mt_iter mt
     | (_,Smodtype mt) -> mt_iter mt
   in
-  let rec se_iter = function 
+  let rec se_iter = function
     | (_,SEdecl d) -> do_decl d
-    | (_,SEmodule m) -> 
+    | (_,SEmodule m) ->
 	me_iter m.ml_mod_expr; mt_iter m.ml_mod_type
     | (_,SEmodtype m) -> mt_iter m
-  and me_iter = function 
-    | MEident _ -> () 
+  and me_iter = function
+    | MEident _ -> ()
     | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt
     | MEapply (me,me') -> me_iter me; me_iter me'
     | MEstruct (msid, sel) -> List.iter se_iter sel
-  in 
+  in
   List.iter (function (_,sel) -> List.iter se_iter sel) s
 
-(*s Apply some fonctions upon all references in [ml_type], [ml_ast], 
+(*s Apply some fonctions upon all references in [ml_type], [ml_ast],
   [ml_decl], [ml_spec] and [ml_structure]. *)
 
 type do_ref = global_reference -> unit
 
-let record_iter_references do_term = function 
-  | Record l -> List.iter do_term l 
+let record_iter_references do_term = function
+  | Record l -> List.iter do_term l
   | _ -> ()
 
-let type_iter_references do_type t = 
-  let rec iter = function 
-    | Tglob (r,l) -> do_type r; List.iter iter l 
-    | Tarr (a,b) -> iter a; iter b 
-    | _ -> () 
+let type_iter_references do_type t =
+  let rec iter = function
+    | Tglob (r,l) -> do_type r; List.iter iter l
+    | Tarr (a,b) -> iter a; iter b
+    | _ -> ()
   in iter t
 
-let ast_iter_references do_term do_cons do_type a = 
-  let rec iter a = 
+let ast_iter_references do_term do_cons do_type a =
+  let rec iter a =
     ast_iter iter a;
-    match a with 
+    match a with
       | MLglob r -> do_term r
-      | MLcons (i,r,_) -> 
-	  if lang () = Ocaml then record_iter_references do_term i; 
-	  do_cons r 
-      | MLcase (i,_,v) -> 
-	  if lang () = Ocaml then record_iter_references do_term (fst i); 
+      | MLcons (i,r,_) ->
+	  if lang () = Ocaml then record_iter_references do_term i;
+	  do_cons r
+      | MLcase (i,_,v) ->
+	  if lang () = Ocaml then record_iter_references do_term (fst i);
 	  Array.iter (fun (r,_,_) -> do_cons r) v
       | _ -> ()
   in iter a
 
-let ind_iter_references do_term do_cons do_type kn ind = 
+let ind_iter_references do_term do_cons do_type kn ind =
   let type_iter = type_iter_references do_type in
-  let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in 
-  let packet_iter ip p = 
-    do_type (IndRef ip); 
-    if lang () = Ocaml then 
-      (match ind.ind_equiv with 
-	 | Equiv kne -> do_type (IndRef (kne, snd ip)); 
-	 | _ -> ()); 
-    Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types 
+  let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in
+  let packet_iter ip p =
+    do_type (IndRef ip);
+    if lang () = Ocaml then
+      (match ind.ind_equiv with
+	 | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip));
+	 | _ -> ());
+    Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types
   in
-  if lang () = Ocaml then record_iter_references do_term ind.ind_info; 
-  Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
-  
-let decl_iter_references do_term do_cons do_type = 
-  let type_iter = type_iter_references do_type 
+  if lang () = Ocaml then record_iter_references do_term ind.ind_info;
+    Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
+
+let decl_iter_references do_term do_cons do_type =
+  let type_iter = type_iter_references do_type
   and ast_iter = ast_iter_references do_term do_cons do_type in
-  function 
-    | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind 
-    | Dtype (r,_,t) -> do_type r; type_iter t 
+  function
+    | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type 
+	(mind_of_kn kn) ind
+    | Dtype (r,_,t) -> do_type r; type_iter t
     | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t
-    | Dfix(rv,c,t) -> 	
+    | Dfix(rv,c,t) ->
 	Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t
 
-let spec_iter_references do_term do_cons do_type = function 
-  | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind
+let spec_iter_references do_term do_cons do_type = function
+  | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type (mind_of_kn kn) ind
   | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot
   | Sval (r,t) -> do_term r; type_iter_references do_type t
 
@@ -127,85 +124,86 @@ let spec_iter_references do_term do_cons do_type = function
 
 exception Found
 
-let rec ast_search f a = 
+let rec ast_search f a =
   if f a then raise Found else ast_iter (ast_search f) a
 
-let decl_ast_search f = function 
+let decl_ast_search f = function
   | Dterm (_,a,_) -> ast_search f a
   | Dfix (_,c,_) -> Array.iter (ast_search f) c
-  | _ -> () 
+  | _ -> ()
 
-let struct_ast_search f s = 
+let struct_ast_search f s =
   try struct_iter (decl_ast_search f) (fun _ -> ()) s; false
   with Found -> true
 
-let rec type_search f = function  
-  | Tarr (a,b) -> type_search f a; type_search f b 
+let rec type_search f = function
+  | Tarr (a,b) -> type_search f a; type_search f b
   | Tglob (r,l) -> List.iter (type_search f) l
   | u -> if f u then raise Found
 
-let decl_type_search f = function 
-  | Dind (_,{ind_packets=p})  -> 
-      Array.iter 
+let decl_type_search f = function
+  | Dind (_,{ind_packets=p})  ->
+      Array.iter
 	(fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
   | Dterm (_,_,u) -> type_search f u
   | Dfix (_,_,v) -> Array.iter (type_search f) v
   | Dtype (_,_,u) -> type_search f u
 
-let spec_type_search f = function 
-  | Sind (_,{ind_packets=p}) -> 
-      Array.iter 
+let spec_type_search f = function
+  | Sind (_,{ind_packets=p}) ->
+      Array.iter
 	(fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
   | Stype (_,_,ot) -> Option.iter (type_search f) ot
   | Sval (_,u) -> type_search f u
 
-let struct_type_search f s = 
+let struct_type_search f s =
   try struct_iter (decl_type_search f) (spec_type_search f) s; false
   with Found -> true
 
 
 (*s Generating the signature. *)
 
-let rec msig_of_ms = function 
-  | [] -> [] 
-  | (l,SEdecl (Dind (kn,i))) :: ms -> 
+let rec msig_of_ms = function
+  | [] -> []
+  | (l,SEdecl (Dind (kn,i))) :: ms ->
       (l,Spec (Sind (kn,i))) :: (msig_of_ms ms)
-  | (l,SEdecl (Dterm (r,_,t))) :: ms -> 
+  | (l,SEdecl (Dterm (r,_,t))) :: ms ->
       (l,Spec (Sval (r,t))) :: (msig_of_ms ms)
-  | (l,SEdecl (Dtype (r,v,t))) :: ms -> 
-      (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) 
-  | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> 
-      let msig = ref (msig_of_ms ms) in 
-      for i = Array.length rv - 1 downto 0 do 
+  | (l,SEdecl (Dtype (r,v,t))) :: ms ->
+      (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms)
+  | (l,SEdecl (Dfix (rv,_,tv))) :: ms ->
+      let msig = ref (msig_of_ms ms) in
+      for i = Array.length rv - 1 downto 0 do
 	msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig
-      done; 
+      done;
       !msig
   | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms)
   | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms)
 
-let signature_of_structure s = 
-  List.map (fun (mp,ms) -> mp,msig_of_ms ms) s 
+let signature_of_structure s =
+  List.map (fun (mp,ms) -> mp,msig_of_ms ms) s
 
 
 (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
 
-let get_decl_in_structure r struc = 
-  try 
-    let base_mp,ll = labels_of_ref r in 
+let get_decl_in_structure r struc =
+  try
+    let base_mp,ll = labels_of_ref r in
     if not (at_toplevel base_mp) then error_not_visible r;
     let sel = List.assoc base_mp struc in
-    let rec go ll sel = match ll with 
+    let rec go ll sel = match ll with
       | [] -> assert false
-      | l :: ll -> 
-	  match List.assoc l sel with 
-	    | SEdecl d -> d 
+      | l :: ll ->
+	  match List.assoc l sel with
+	    | SEdecl d -> d
 	    | SEmodtype m -> assert false
 	    | SEmodule m ->
-		match m.ml_mod_expr with 
-		  | MEstruct (_,sel) -> go ll sel 
-		  | _ -> error_not_visible r 
+		match m.ml_mod_expr with
+		  | MEstruct (_,sel) -> go ll sel
+		  | _ -> error_not_visible r
     in go ll sel
-  with Not_found -> assert false
+  with Not_found ->
+    anomaly "reference not found in extracted structure"
 
 
 (*s Optimization of a [ml_structure]. *)
@@ -216,83 +214,83 @@ let get_decl_in_structure r struc =
    a let-in redex is created for clarity) and iota redexes, plus some other
    optimizations. *)
 
-let dfix_to_mlfix rv av i = 
-  let rec make_subst n s = 
-    if n < 0 then s 
+let dfix_to_mlfix rv av i =
+  let rec make_subst n s =
+    if n < 0 then s
     else make_subst (n-1) (Refmap.add rv.(n) (n+1) s)
-  in 
-  let s = make_subst (Array.length rv - 1) Refmap.empty 
-  in 
-  let rec subst n t = match t with 
-    | MLglob ((ConstRef kn) as refe) -> 
+  in
+  let s = make_subst (Array.length rv - 1) Refmap.empty
+  in
+  let rec subst n t = match t with
+    | MLglob ((ConstRef kn) as refe) ->
 	(try MLrel (n + (Refmap.find refe s)) with Not_found -> t)
-    | _ -> ast_map_lift subst n t 
-  in 
-  let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in 
-  let c = Array.map (subst 0) av 
+    | _ -> ast_map_lift subst n t
+  in
+  let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in
+  let c = Array.map (subst 0) av
   in MLfix(i, ids, c)
 
 let rec optim to_appear s = function
   | [] -> []
   | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l ->
-      if List.mem r to_appear 
-      then d :: (optim to_appear s l) 
+      if List.mem r to_appear
+      then d :: (optim to_appear s l)
       else optim to_appear s l
   | Dterm (r,t,typ) :: l ->
-      let t = normalize (ast_glob_subst !s t) in 
-      let i = inline r t in 
-      if i then s := Refmap.add r t !s; 
-      if not i || modular () || List.mem r to_appear 
-      then 
-	let d = match optimize_fix t with 
-	  | MLfix (0, _, [|c|]) -> 
+      let t = normalize (ast_glob_subst !s t) in
+      let i = inline r t in
+      if i then s := Refmap.add r t !s;
+      if not i || modular () || List.mem r to_appear
+      then
+	let d = match optimize_fix t with
+	  | MLfix (0, _, [|c|]) ->
 	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|])
 	  | t -> Dterm (r, t, typ)
 	in d :: (optim to_appear s l)
       else optim to_appear s l
   | d :: l -> d :: (optim to_appear s l)
 
-let rec optim_se top to_appear s = function 
-  | [] -> [] 
-  | (l,SEdecl (Dterm (r,a,t))) :: lse -> 
-      let a = normalize (ast_glob_subst !s a) in 
-      let i = inline r a in 
-      if i then s := Refmap.add r a !s; 
+let rec optim_se top to_appear s = function
+  | [] -> []
+  | (l,SEdecl (Dterm (r,a,t))) :: lse ->
+      let a = normalize (ast_glob_subst !s a) in
+      let i = inline r a in
+      if i then s := Refmap.add r a !s;
       if top && i && not (modular ()) && not (List.mem r to_appear)
       then optim_se top to_appear s lse
-      else 
-	let d = match optimize_fix a with 
-	  | MLfix (0, _, [|c|]) -> 
+      else
+	let d = match optimize_fix a with
+	  | MLfix (0, _, [|c|]) ->
 	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
 	  | a -> Dterm (r, a, t)
 	in (l,SEdecl d) :: (optim_se top to_appear s lse)
-  | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> 
-      let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in 
-      let all = ref true in 
+  | (l,SEdecl (Dfix (rv,av,tv))) :: lse ->
+      let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in
+      let all = ref true in
       (* This fake body ensures that no fixpoint will be auto-inlined. *)
-      let fake_body = MLfix (0,[||],[||]) in 
-      for i = 0 to Array.length rv - 1 do 
+      let fake_body = MLfix (0,[||],[||]) in
+      for i = 0 to Array.length rv - 1 do
 	if inline rv.(i) fake_body
 	then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s
 	else all := false
-      done; 
+      done;
       if !all && top && not (modular ())
-	&& (array_for_all (fun r -> not (List.mem r to_appear)) rv)  
+	&& (array_for_all (fun r -> not (List.mem r to_appear)) rv)
       then optim_se top to_appear s lse
       else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse)
-  | (l,SEmodule m) :: lse -> 
+  | (l,SEmodule m) :: lse ->
       let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr}
       in (l,SEmodule m) :: (optim_se top to_appear s lse)
-  | se :: lse -> se :: (optim_se top to_appear s lse) 
+  | se :: lse -> se :: (optim_se top to_appear s lse)
 
-and optim_me to_appear s = function 
+and optim_me to_appear s = function
   | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse)
   | MEident mp as me -> me
-  | MEapply (me, me') -> 
+  | MEapply (me, me') ->
       MEapply (optim_me to_appear s me, optim_me to_appear s me')
   | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me)
 
-(* After these optimisations, some dependencies may not be needed anymore. 
+(* After these optimisations, some dependencies may not be needed anymore.
    For monolithic extraction, we recompute a minimal set of dependencies. *)
 
 exception NoDepCheck
@@ -311,18 +309,18 @@ let reset_needed, add_needed, found_needed, is_needed =
    (fun r -> Refset.mem (base_r r) !needed))
 
 let declared_refs = function
-  | Dind (kn,_) -> [|IndRef (kn,0)|]
+  | Dind (kn,_) -> [|IndRef (mind_of_kn kn,0)|]
   | Dtype (r,_,_) -> [|r|]
   | Dterm (r,_,_) -> [|r|]
   | Dfix (rv,_,_) -> rv
 
-(* Computes the dependencies of a declaration, except in case 
+(* Computes the dependencies of a declaration, except in case
    of custom extraction. *)
 
 let compute_deps_decl = function
   | Dind (kn,ind) ->
       (* Todo Later : avoid dependencies when Extract Inductive *)
-      ind_iter_references add_needed add_needed add_needed kn ind
+      ind_iter_references add_needed add_needed add_needed (mind_of_kn kn) ind
   | Dtype (r,ids,t) ->
       if not (is_custom r) then type_iter_references add_needed t
   | Dterm (r,u,t) ->
@@ -351,12 +349,24 @@ let rec depcheck_struct = function
       let lse' = depcheck_se lse in
       (mp,lse')::struc'
 
+let check_implicits = function
+  | MLexn s ->
+      if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then
+	begin
+	  if String.sub s 0 7 = "UNBOUND" then assert false;
+	  if String.sub s 0 8 = "IMPLICIT" then
+	    error_non_implicit (String.sub s 9 (String.length s - 9));
+	end;
+      false
+  | _ -> false
+
 let optimize_struct to_appear struc =
   let subst = ref (Refmap.empty : ml_ast Refmap.t) in
   let opt_struc =
     List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc
   in
   let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in
+  ignore (struct_ast_search check_implicits opt_struc);
   try
     if modular () then raise NoDepCheck;
     reset_needed ();
diff --git a/contrib/extraction/modutil.mli b/plugins/extraction/modutil.mli
index e279261d..8e04a368 100644
--- a/contrib/extraction/modutil.mli
+++ b/plugins/extraction/modutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.mli 11602 2008-11-18 00:08:33Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Names
 open Declarations
@@ -20,7 +20,7 @@ open Mod_subst
 val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool
 val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
 
-type do_ref = global_reference -> unit 
+type do_ref = global_reference -> unit
 
 val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
 val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
diff --git a/contrib/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 0166d854..30004677 100644
--- a/contrib/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.ml 11559 2008-11-07 22:03:34Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*s Production of Ocaml syntax. *)
 
@@ -25,16 +25,16 @@ open Declarations
 
 (*s Some utility functions. *)
 
-let pp_tvar id = 
-  let s = string_of_id id in 
-  if String.length s < 2 || s.[1]<>'\'' 
+let pp_tvar id =
+  let s = string_of_id id in
+  if String.length s < 2 || s.[1]<>'\''
   then str ("'"^s)
   else str ("' "^s)
 
 let pp_tuple_light f = function
   | [] -> mt ()
   | [x] -> f true x
-  | l -> 
+  | l ->
       pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
 
 let pp_tuple f = function
@@ -49,19 +49,19 @@ let pp_boxed_tuple f = function
 
 let pp_abst = function
   | [] -> mt ()
-  | l  -> 
-      str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ 
+  | l  ->
+      str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++
       str " ->" ++ spc ()
 
-let pp_parameters l = 
+let pp_parameters l =
   (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
 
-let pp_string_parameters l = 
-  (pp_boxed_tuple str l ++ space_if (l<>[])) 
+let pp_string_parameters l =
+  (pp_boxed_tuple str l ++ space_if (l<>[]))
 
 (*s Ocaml renaming issues. *)
 
-let keywords =     
+let keywords =
   List.fold_right (fun s -> Idset.add (id_of_string s))
   [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
     "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
@@ -70,16 +70,16 @@ let keywords =
     "module"; "mutable"; "new"; "object"; "of"; "open"; "or";
     "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
     "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
-    "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] 
+    "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ]
   Idset.empty
 
 let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
 
-let preamble _ used_modules usf = 
+let preamble _ used_modules usf =
   prlist pp_open used_modules ++
   (if used_modules = [] then mt () else fnl ()) ++
   (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++
-  (if usf.mldummy then 
+  (if usf.mldummy then
      str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n"
    else mt ()) ++
   (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ())
@@ -92,25 +92,25 @@ let sig_preamble _ used_modules usf =
 (*s The pretty-printer for Ocaml syntax*)
 
 (* Beware of the side-effects of [pp_global] and [pp_modname].
-   They are used to update table of content for modules. Many [let] 
-   below should not be altered since they force evaluation order. 
+   They are used to update table of content for modules. Many [let]
+   below should not be altered since they force evaluation order.
 *)
 
-let pp_global k r =
-  if is_inline_custom r then str (find_custom r)
-  else str (Common.pp_global k r)
+let str_global k r =
+  if is_inline_custom r then find_custom r else Common.pp_global k r
 
-let pp_modname mp = str (Common.pp_module mp)
+let pp_global k r = str (str_global k r)
 
+let pp_modname mp = str (Common.pp_module mp)
 
-let is_infix r = 
-  is_inline_custom r && 
-  (let s = find_custom r in 
-   let l = String.length s in 
+let is_infix r =
+  is_inline_custom r &&
+  (let s = find_custom r in
+   let l = String.length s in
    l >= 2 && s.[0] = '(' && s.[l-1] = ')')
 
-let get_infix r = 
-  let s = find_custom r in 
+let get_infix r =
+  let s = find_custom r in
   String.sub s 1 (String.length s - 2)
 
 exception NoRecord
@@ -120,31 +120,27 @@ let find_projections = function Record l -> l | _ -> raise NoRecord
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
 
-let kn_sig = 
-  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in 
-  make_kn specif empty_dirpath (mk_label "sig")
+let mk_ind path s =
+  make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s)
 
 let rec pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ | Taxiom -> assert false
-    | Tvar i -> (try pp_tvar (List.nth vl (pred i)) 
+    | Tvar i -> (try pp_tvar (List.nth vl (pred i))
 		 with _ -> (str "'a" ++ int i))
-    | Tglob (r,[a1;a2]) when is_infix r -> 
-	pp_par par 
-	  (pp_rec true a1 ++ spc () ++ str (get_infix r) ++ spc () ++ 
-	   pp_rec true a2)
+    | Tglob (r,[a1;a2]) when is_infix r ->
+	pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2)
     | Tglob (r,[]) -> pp_global Type r
-    | Tglob (r,l) -> 
-	if r = IndRef (kn_sig,0) then 
-	  pp_tuple_light pp_rec l
-	else 
-	  pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r
+    | Tglob (IndRef(kn,0),l) when kn = mk_ind "Coq.Init.Specif" "sig" ->
+	pp_tuple_light pp_rec l
+    | Tglob (r,l) ->
+	pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r
     | Tarr (t1,t2) ->
-	pp_par par 
+	pp_par par
 	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
     | Tdummy _ -> str "__"
     | Tunknown -> str "__"
-  in 
+  in
   hov 0 (pp_rec par t)
 
 (*s Pretty-printing of expressions. [par] indicates whether
@@ -152,190 +148,237 @@ let rec pp_type par vl t =
     de Bruijn variables. [args] is the list of collected arguments
     (already pretty-printed). *)
 
-let is_ifthenelse = function 
-  | [|(r1,[],_);(r2,[],_)|] -> 
-      (try (find_custom r1 = "true") && (find_custom r2 = "false") 
+let is_ifthenelse = function
+  | [|(r1,[],_);(r2,[],_)|] ->
+      (try (find_custom r1 = "true") && (find_custom r2 = "false")
        with Not_found -> false)
   | _ -> false
 
 let expr_needs_par = function
   | MLlam _  -> true
-  | MLcase (_,_,[|_|]) -> false 
+  | MLcase (_,_,[|_|]) -> false
   | MLcase (_,_,pv) -> not (is_ifthenelse pv)
-  | _        -> false 
+  | _        -> false
+
+
+(** Special hack for constants of type Ascii.ascii : if an
+    [Extract Inductive ascii => char] has been declared, then
+    the constants are directly turned into chars *)
 
+let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii"
 
-let rec pp_expr par env args = 
+let check_extract_ascii () =
+  try find_custom (IndRef (ind_ascii,0)) = "char" with Not_found -> false
+
+let is_list_cons l =
+ List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l
+
+let pp_char l =
+  let rec cumul = function
+    | [] -> 0
+    | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l)
+    | _ -> assert false
+  in str ("'"^Char.escaped (Char.chr (cumul l))^"'")
+
+let rec pp_expr par env args =
   let par' = args <> [] || par
-  and apply st = pp_apply st par args in 
+  and apply st = pp_apply st par args in
   function
-    | MLrel n -> 
+    | MLrel n ->
 	let id = get_db_name n env in apply (pr_id id)
     | MLapp (f,args') ->
 	let stl = List.map (pp_expr true env []) args' in
         pp_expr par env (stl @ args) f
-    | MLlam _ as a -> 
+    | MLlam _ as a ->
       	let fl,a' = collect_lams a in
+	let fl = List.map id_of_mlid fl in
 	let fl,env' = push_vars fl env in
 	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
 	apply (pp_par par' st)
     | MLletin (id,a1,a2) ->
-	let i,env' = push_vars [id] env in
+	let i,env' = push_vars [id_of_mlid id] env in
 	let pp_id = pr_id (List.hd i)
 	and pp_a1 = pp_expr false env [] a1
-	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in 
-	hv 0 
-	  (apply 
-	     (pp_par par' 
-		(hv 0 
-		   (hov 2 
-		      (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ 
-		    spc () ++ str "in") ++ 
+	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in
+	hv 0
+	  (apply
+	     (pp_par par'
+		(hv 0
+		   (hov 2
+		      (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++
+		    spc () ++ str "in") ++
 		 spc () ++ hov 0 pp_a2)))
-    | MLglob r -> 
-	(try 
-	   let args = list_skipn (projection_arity r) args in 
-	   let record = List.hd args in 
+    | MLglob r ->
+	(try
+	   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 _ -> apply (pp_global Term r))
+    | MLcons(_,ConstructRef ((kn,0),1),l)
+        when kn = ind_ascii && check_extract_ascii () & is_list_cons l ->
+	assert (args=[]);
+	pp_char l
     | MLcons (Coinductive,r,[]) ->
 	assert (args=[]);
 	pp_par par (str "lazy " ++ pp_global Cons r)
-    | MLcons (Coinductive,r,args') -> 
+    | MLcons (Coinductive,r,args') ->
 	assert (args=[]);
-	let tuple = pp_tuple (pp_expr true env []) args' in 
+	let tuple = pp_tuple (pp_expr true env []) args' in
 	pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")")
-    | MLcons (_,r,[]) -> 
+    | MLcons (_,r,[]) ->
 	assert (args=[]);
 	pp_global Cons r
-    | MLcons (Record projs, r, args') -> 
-	assert (args=[]); 
+    | MLcons (Record projs, r, args') ->
+	assert (args=[]);
 	pp_record_pat (projs, List.map (pp_expr true env []) args')
-    | MLcons (_,r,[arg1;arg2]) when is_infix r -> 
-	assert (args=[]); 
+    | MLcons (_,r,[arg1;arg2]) when is_infix r ->
+	assert (args=[]);
 	pp_par par
-	  ((pp_expr true env [] arg1) ++ spc () ++ str (get_infix r) ++
-	   spc () ++ (pp_expr true env [] arg2))
-    | MLcons (_,r,args') -> 
+	  ((pp_expr true env [] arg1) ++ str (get_infix r) ++
+	   (pp_expr true env [] arg2))
+    | MLcons (_,r,args') ->
 	assert (args=[]);
-	let tuple = pp_tuple (pp_expr true env []) args' in 
-	pp_par par (pp_global Cons r ++ spc () ++ tuple)
+	let tuple = pp_tuple (pp_expr true env []) args' in
+	if str_global Cons r = "" (* hack Extract Inductive prod *)
+	then tuple
+	else pp_par par (pp_global Cons r ++ spc () ++ tuple)
+    | MLcase (_, t, pv) when is_custom_match pv ->
+	let mkfun (_,ids,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	hov 2 (str (find_custom_match pv) ++ fnl () ++
+		 prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv
+	       ++ pp_expr true env [] t)
     | MLcase ((i,factors), t, pv) ->
-	let expr = if i = Coinductive then 
+	let expr = if i = Coinductive then
 	  (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
-	else 
-	  (pp_expr false env [] t) 
-	in 
-	(try 
-	   let projs = find_projections i in 
-	   let (_, ids, c) = pv.(0) in 
-	   let n = List.length ids in 
-	   match c with 
-	     | MLrel i when i <= n -> 
-		 apply (pp_par par' (pp_expr true env [] t ++ str "." ++ 
+	else
+	  (pp_expr false env [] t)
+	in
+	(try
+	   let projs = find_projections i in
+	   let (_, ids, c) = pv.(0) in
+	   let n = List.length ids in
+	   match c with
+	     | MLrel i when i <= n ->
+		 apply (pp_par par' (pp_expr true env [] t ++ str "." ++
 				     pp_global Term (List.nth projs (n-i))))
-	     | MLapp (MLrel i, a) when i <= n -> 
-		 if List.exists (ast_occurs_itvl 1 n) a 
+	     | MLapp (MLrel i, a) when i <= n ->
+		 if List.exists (ast_occurs_itvl 1 n) a
 		 then raise NoRecord
 		 else
-		   let ids,env' = push_vars (List.rev ids) env in
-		   (pp_apply 
-		      (pp_expr true env [] t ++ str "." ++ 
+		   let ids,env' = push_vars (List.rev_map id_of_mlid ids) env
+		   in
+		   (pp_apply
+		      (pp_expr true env [] t ++ str "." ++
 		       pp_global Term (List.nth projs (n-i)))
 		      par ((List.map (pp_expr true env' []) a) @ args))
 	     | _ -> raise NoRecord
-	 with NoRecord -> 
-	   if Array.length pv = 1 then 
-	     let s1,s2 = pp_one_pat env i pv.(0) in 
-	     apply 
-	       (hv 0 
-		  (pp_par par' 
-		     (hv 0 
-			(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) 
-			 ++ spc () ++ str "in") ++ 
+	 with NoRecord ->
+	   if Array.length pv = 1 then
+	     let s1,s2 = pp_one_pat env i pv.(0) in
+	     apply
+	       (hv 0
+		  (pp_par par'
+		     (hv 0
+			(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr)
+			 ++ spc () ++ str "in") ++
 		      spc () ++ hov 0 s2)))
-	   else 
+	   else
  	     apply
-      	       (pp_par par' 
-		  (try pp_ifthenelse par' env expr pv 
-		   with Not_found -> 
+      	       (pp_par par'
+		  (try pp_ifthenelse par' env expr pv
+		   with Not_found ->
 		     v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++
 			  str "  | " ++ pp_pat env (i,factors) pv))))
     | 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
-    | MLexn s -> 
+    | MLexn s ->
 	(* An [MLexn] may be applied, but I don't really care. *)
 	pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)"))
     | MLdummy ->
 	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
     | MLmagic a ->
 	pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args)
-    | MLaxiom -> 
+    | MLaxiom ->
 	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
 
-	  
+
 and pp_record_pat (projs, args) =
    str "{ " ++
-   prlist_with_sep (fun () -> str ";" ++ spc ()) 
+   prlist_with_sep (fun () -> str ";" ++ spc ())
      (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a)
      (List.combine projs args) ++
    str " }"
 
-and pp_ifthenelse par env expr pv = match pv with 
-  | [|(tru,[],the);(fal,[],els)|] when 
+and pp_ifthenelse par env expr pv = match pv with
+  | [|(tru,[],the);(fal,[],els)|] when
       (find_custom tru = "true") && (find_custom fal = "false")
-      -> 
-      hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ 
+      ->
+      hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++
             hov 2 (str "then " ++
-		   hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ 
+		   hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++
 	    hov 2 (str "else " ++
 	           hov 2 (pp_expr (expr_needs_par els) env [] els)))
   | _ -> raise Not_found
 
-and pp_one_pat env i (r,ids,t) = 
-  let ids,env' = push_vars (List.rev ids) env in
-  let expr = pp_expr (expr_needs_par t) env' [] t in 
-  try 
-    let projs = find_projections i in 
+and pp_one_pat env i (r,ids,t) =
+  let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
+  let expr = pp_expr (expr_needs_par t) env' [] t in
+  try
+    let projs = find_projections i in
     pp_record_pat (projs, List.rev_map pr_id ids), expr
-  with NoRecord -> 
-    (match List.rev ids with 
-      | [i1;i2] when is_infix r -> 
-	  pr_id i1 ++ str " " ++ str (get_infix r) ++ str " " ++ pr_id i2
+  with NoRecord ->
+    (match List.rev ids with
+      | [i1;i2] when is_infix r -> pr_id i1 ++ str (get_infix r) ++ pr_id i2
       | [] -> pp_global Cons r
-      | ids -> pp_global Cons r ++ str " " ++ pp_boxed_tuple pr_id ids), 
+      | ids ->
+	  (* hack Extract Inductive prod *)
+	  (if str_global Cons r = "" then mt () else pp_global Cons r ++ spc ())
+	   ++ pp_boxed_tuple pr_id ids),
     expr
-  
-and pp_pat env (info,factors) pv = 
-  prvecti 
-    (fun i x -> if List.mem i factors then mt () else 
-       let s1,s2 = pp_one_pat env info x in 
+
+and pp_pat env (info,factors) pv =
+  let factor_br, factor_l = try match factors with
+    | BranchFun (i::_ as l) -> check_function_branch pv.(i), l
+    | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l
+    | _ -> MLdummy, []
+  with Impossible -> MLdummy, []
+  in
+  let par = expr_needs_par factor_br in
+  let last = Array.length pv - 1 in
+  prvecti
+    (fun i x -> if List.mem i factor_l then mt () else
+       let s1,s2 = pp_one_pat env info x in
        hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++
-       (if factors = [] && i = Array.length pv-1 then mt () 
-	else fnl () ++ str "  | ")) pv 
-  ++ 
-  match factors with 
-     | [] -> mt ()
-     | i::_ -> 
-	 let (_,ids,t) = pv.(i) in 
-	 let t = ast_lift (-List.length ids) t in 
-	 hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t)
+       if i = last && factor_l = [] then mt () else
+       fnl () ++ str "  | ") pv
+  ++
+  if factor_l = [] then mt () else match factors with
+    | BranchFun _ ->
+	let ids, env' = push_vars [anonymous_name] env in
+	hov 2 (pr_id (List.hd ids) ++ str " ->" ++ spc () ++
+	       pp_expr par env' [] factor_br)
+    | BranchCst _ ->
+	hov 2 (str "_ ->" ++ spc () ++ pp_expr par env [] factor_br)
+    | BranchNone -> mt ()
 
 and pp_function env t =
   let bl,t' = collect_lams t in
-  let bl,env' = push_vars bl env in
-  match t' with 
-    | MLcase(i,MLrel 1,pv) when fst i=Standard -> 
-	if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then 
+  let bl,env' = push_vars (List.map id_of_mlid bl) env in
+  match t' with
+    | MLcase(i,MLrel 1,pv) when fst i=Standard && not (is_custom_match pv) ->
+	if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then
 	  pr_binding (List.rev (List.tl bl)) ++
        	  str " = function" ++ fnl () ++
 	  v 0 (str "  | " ++ pp_pat env' i pv)
 	else
-          pr_binding (List.rev bl) ++ 
+          pr_binding (List.rev bl) ++
           str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++
 	  v 0 (str "  | " ++ pp_pat env' i pv)
-    | _ -> 
+    | _ ->
           pr_binding (List.rev bl) ++
 	  str " =" ++ fnl () ++ str "  " ++
 	  hov 2 (pp_expr false env' [] t')
@@ -344,7 +387,7 @@ and pp_function env t =
     and passed here just for convenience. *)
 
 and pp_fix par env i (ids,bl) args =
-  pp_par par 
+  pp_par par
     (v 0 (str "let rec " ++
 	  prvect_with_sep
       	    (fun () -> fnl () ++ str "and ")
@@ -353,34 +396,34 @@ and pp_fix par env i (ids,bl) args =
 	  fnl () ++
 	  hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
 
-let pp_val e typ = 
-  hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ 
+let pp_val e typ =
+  hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++
   str " **)")  ++ fnl2 ()
 
 (*s Pretty-printing of [Dfix] *)
 
-let pp_Dfix (rv,c,t) = 
-  let names = Array.map 
+let pp_Dfix (rv,c,t) =
+  let names = Array.map
     (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv
-  in 
-  let rec pp sep letand i = 
+  in
+  let rec pp sep letand i =
     if i >= Array.length rv then mt ()
     else if is_inline_custom rv.(i) then pp sep letand (i+1)
-    else 
-      let def = 
+    else
+      let def =
 	if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i))
 	else pp_function (empty_env ()) c.(i)
-      in 
-      sep () ++ pp_val names.(i) t.(i) ++ 
-      str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1) 
+      in
+      sep () ++ pp_val names.(i) t.(i) ++
+      str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1)
   in pp mt "let rec " 0
 
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_equiv param_list name = function 
+let pp_equiv param_list name = function
   | NoEquiv, _ -> mt ()
-  | Equiv kn, i -> 
-      str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (kn,i))
+  | Equiv kn, i ->
+      str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (mind_of_kn kn,i))
   | RenEquiv ren, _  ->
       str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name
 
@@ -389,97 +432,97 @@ let pp_comment s = str "(* " ++ s ++ str " *)"
 let pp_one_ind prefix ip_equiv pl name cnames ctyps =
   let pl = rename_tvars keywords pl in
   let pp_constructor i typs =
-    (if i=0 then mt () else fnl ()) ++ 
+    (if i=0 then mt () else fnl ()) ++
     hov 5 (str "  | " ++ cnames.(i) ++
 	   (if typs = [] then mt () else str " of ") ++
-	   prlist_with_sep 
+	   prlist_with_sep
 	    (fun () -> spc () ++ str "* ") (pp_type true pl) typs)
   in
   pp_parameters pl ++ str prefix ++ name ++
   pp_equiv pl name ip_equiv ++ str " =" ++
-  if Array.length ctyps = 0 then str " unit (* empty inductive *)" 
+  if Array.length ctyps = 0 then str " unit (* empty inductive *)"
   else fnl () ++ v 0 (prvecti pp_constructor ctyps)
 
-let pp_logical_ind packet = 
-  pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ 
+let pp_logical_ind packet =
+  pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
   fnl () ++
-  pp_comment (str "with constructors : " ++ 
+  pp_comment (str "with constructors : " ++
 	      prvect_with_sep spc pr_id packet.ip_consnames) ++
   fnl ()
 
-let pp_singleton kn packet = 
-  let name = pp_global Type (IndRef (kn,0)) in 
-  let l = rename_tvars keywords packet.ip_vars in 
+let pp_singleton kn packet =
+  let name = pp_global Type (IndRef (mind_of_kn kn,0)) in
+  let l = rename_tvars keywords packet.ip_vars in
   hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++
 	 pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++
-	 pp_comment (str "singleton inductive, whose constructor was " ++ 
+	 pp_comment (str "singleton inductive, whose constructor was " ++
 		     pr_id packet.ip_consnames.(0)))
 
-let pp_record kn projs ip_equiv packet = 
-  let name = pp_global Type (IndRef (kn,0)) in
-  let projnames = List.map (pp_global Term) projs in 
-  let l = List.combine projnames packet.ip_types.(0) in 
-  let pl = rename_tvars keywords packet.ip_vars in 
-  str "type " ++ pp_parameters pl ++ name ++ 
+let pp_record kn projs ip_equiv packet =
+  let name = pp_global Type (IndRef (mind_of_kn kn,0)) in
+  let projnames = List.map (pp_global Term) projs in
+  let l = List.combine projnames packet.ip_types.(0) in
+  let pl = rename_tvars keywords packet.ip_vars in
+  str "type " ++ pp_parameters pl ++ name ++
   pp_equiv pl name ip_equiv ++ str " = { "++
-  hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
-	   (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) 
+  hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ())
+	   (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l)
   ++ str " }"
 
-let pp_coind pl name = 
+let pp_coind pl name =
   let pl = rename_tvars keywords pl in
-  pp_parameters pl ++ name ++ str " = " ++ 
-  pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++ 
+  pp_parameters pl ++ name ++ str " = " ++
+  pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++
   fnl() ++ str "and "
 
 let pp_ind co kn ind =
-  let prefix = if co then "__" else "" in 
-  let some = ref false in 
-  let init= ref (str "type ") in 
-  let names = 
-    Array.mapi (fun i p -> if p.ip_logical then mt () else 
-		  pp_global Type (IndRef (kn,i)))
+  let prefix = if co then "__" else "" in
+  let some = ref false in
+  let init= ref (str "type ") in
+  let names =
+    Array.mapi (fun i p -> if p.ip_logical then mt () else
+		  pp_global Type (IndRef (mind_of_kn kn,i)))
       ind.ind_packets
-  in 
-  let cnames = 
-    Array.mapi 
-      (fun i p -> if p.ip_logical then [||] else 
-	 Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1)))
+  in
+  let cnames =
+    Array.mapi
+      (fun i p -> if p.ip_logical then [||] else
+	 Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((mind_of_kn kn,i),j+1)))
 	   p.ip_types)
       ind.ind_packets
-  in 
-  let rec pp i =  
-    if i >= Array.length ind.ind_packets then mt () 
-    else 
-      let ip = (kn,i) in 
-      let ip_equiv = ind.ind_equiv, i in 
-      let p = ind.ind_packets.(i) in 
+  in
+  let rec pp i =
+    if i >= Array.length ind.ind_packets then mt ()
+    else
+      let ip = (mind_of_kn kn,i) in
+      let ip_equiv = ind.ind_equiv, i in
+      let p = ind.ind_packets.(i) in
       if is_custom (IndRef ip) then pp (i+1)
-      else begin 
-	some := true; 
+      else begin
+	some := true;
 	if p.ip_logical then pp_logical_ind p ++ pp (i+1)
-	else 
-	  let s = !init in 
-	  begin 
-	    init := (fnl () ++ str "and "); 
+	else
+	  let s = !init in
+	  begin
+	    init := (fnl () ++ str "and ");
 	    s ++
 	    (if co then pp_coind p.ip_vars names.(i) else mt ()) ++
-	    pp_one_ind 
+	    pp_one_ind
 	      prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++
 	    pp (i+1)
 	  end
       end
-  in 
+  in
   let st = pp 0 in if !some then st else failwith "empty phrase"
-	     
+
 
 (*s Pretty-printing of a declaration. *)
 
-let pp_mind kn i = 
-  match i.ind_info with 
+let pp_mind kn i =
+  match i.ind_info with
     | Singleton -> pp_singleton kn i.ind_packets.(0)
     | Coinductive -> pp_ind true kn i
-    | Record projs -> 
+    | Record projs ->
 	pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0)
     | Standard -> pp_ind false kn i
 
@@ -487,129 +530,125 @@ let pp_decl = function
     | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase"
     | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase"
     | Dind (kn,i) -> pp_mind kn i
-    | Dtype (r, l, t) -> 
-        let name = pp_global Type r in 
-	let l = rename_tvars keywords l in 
-        let ids, def = 
-	  try 
-	    let ids,s = find_type_custom r in 
-	    pp_string_parameters ids, str "=" ++ spc () ++ str s 
-	  with Not_found -> 
-	    pp_parameters l, 
+    | Dtype (r, l, t) ->
+        let name = pp_global Type r in
+	let l = rename_tvars keywords l in
+        let ids, def =
+	  try
+	    let ids,s = find_type_custom r in
+	    pp_string_parameters ids, str "=" ++ spc () ++ str s
+	  with Not_found ->
+	    pp_parameters l,
 	    if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
 	    else str "=" ++ spc () ++ pp_type false l t
-	in 
+	in
 	hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
-    | Dterm (r, a, t) -> 
-	let def = 
+    | Dterm (r, a, t) ->
+	let def =
 	  if is_custom r then str (" = " ^ find_custom r)
-	  else if is_projection r then 
-	    (prvect str (Array.make (projection_arity r) " _")) ++ 
+	  else if is_projection r then
+	    (prvect str (Array.make (projection_arity r) " _")) ++
 	    str " x = x."
 	  else pp_function (empty_env ()) a
-	in 
-	let name = pp_global Term r in 
-	let postdef = if is_projection r then name else mt () in 
+	in
+	let name = pp_global Term r in
+	let postdef = if is_projection r then name else mt () in
 	pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef)
     | Dfix (rv,defs,typs) ->
 	pp_Dfix (rv,defs,typs)
 
-let pp_alias_decl ren = function 
+let pp_alias_decl ren = function
   | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren }
-  | Dtype (r, l, _) -> 
-      let name = pp_global Type r in 
-      let l = rename_tvars keywords l in 
-      let ids = pp_parameters l in 
-      hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ 
+  | Dtype (r, l, _) ->
+      let name = pp_global Type r in
+      let l = rename_tvars keywords l in
+      let ids = pp_parameters l in
+      hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++
 	     str (ren^".") ++ name)
-  | Dterm (r, a, t) -> 
+  | Dterm (r, a, t) ->
       let name = pp_global Term r in
       hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name)
   | Dfix (rv, _, _) ->
-      prvecti (fun i r -> if is_inline_custom r then mt () else 
-		 let name = pp_global Term r in 
+      prvecti (fun i r -> if is_inline_custom r then mt () else
+		 let name = pp_global Term r in
 		 hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++
-		 fnl ()) 
+		 fnl ())
 	rv
 
-let pp_spec = function 
+let pp_spec = function
   | Sval (r,_) when is_inline_custom r -> failwith "empty phrase"
   | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase"
   | Sind (kn,i) -> pp_mind kn i
-  | Sval (r,t) -> 
-      let def = pp_type false [] t in 
-      let name = pp_global Term r in 
+  | Sval (r,t) ->
+      let def = pp_type false [] t in
+      let name = pp_global Term r in
       hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def)
-  | Stype (r,vl,ot) -> 
+  | Stype (r,vl,ot) ->
       let name = pp_global Type r in
-      let l = rename_tvars keywords vl in 
-      let ids, def = 
-	try 
-	  let ids, s = find_type_custom r in 
-	  pp_string_parameters ids,  str "= " ++ str s 
-	with Not_found -> 
-	  let ids = pp_parameters l in 
-	  match ot with 
+      let l = rename_tvars keywords vl in
+      let ids, def =
+	try
+	  let ids, s = find_type_custom r in
+	  pp_string_parameters ids,  str "= " ++ str s
+	with Not_found ->
+	  let ids = pp_parameters l in
+	  match ot with
 	    | None -> ids, mt ()
-	    | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" 
-	    | Some t -> ids, str "=" ++ spc () ++ pp_type false l t 
-      in 
+	    | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)"
+	    | Some t -> ids, str "=" ++ spc () ++ pp_type false l t
+      in
       hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
 
-let pp_alias_spec ren = function 
+let pp_alias_spec ren = function
   | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren }
-  | Stype (r,l,_) ->       
-      let name = pp_global Type r in 
-      let l = rename_tvars keywords l in 
-      let ids = pp_parameters l in 
-      hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ 
+  | Stype (r,l,_) ->
+      let name = pp_global Type r in
+      let l = rename_tvars keywords l in
+      let ids = pp_parameters l in
+      hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++
 	     str (ren^".") ++ name)
   | Sval _ -> assert false
-	  
-let rec pp_specif = function 
+
+let rec pp_specif = function
   | (_,Spec (Sval _ as s)) -> pp_spec s
-  | (l,Spec s) -> 
-      (try 
-	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+  | (l,Spec s) ->
+      (try
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in
 	 hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++
 	 fnl () ++ str "end" ++ fnl () ++
 	 pp_alias_spec ren s
        with Not_found -> pp_spec s)
-  | (l,Smodule mt) -> 
-      let def = pp_module_type (Some l) mt in 
-      let def' = pp_module_type (Some l) mt in 
-      let name = pp_modname (MPdot (top_visible_mp (), l)) in 
+  | (l,Smodule mt) ->
+      let def = pp_module_type [] mt in
+      let def' = pp_module_type [] mt in
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in
       hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++
-      (try 
+      (try
 	 let ren = Common.check_duplicate (top_visible_mp ()) l in
 	 fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def')
        with Not_found -> Pp.mt ())
-  | (l,Smodtype mt) -> 
-      let def = pp_module_type None mt in 
+  | (l,Smodtype mt) ->
+      let def = pp_module_type [] mt in
       let name = pp_modname (MPdot (top_visible_mp (), l)) in
       hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++
-      (try 
-	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+      (try
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in
 	 fnl () ++ str ("module type "^ren^" = ") ++ name
        with Not_found -> Pp.mt ())
 
-and pp_module_type ol = function 
-  | MTident kn -> 
+and pp_module_type params = function
+  | MTident kn ->
       pp_modname kn
-  | MTfunsig (mbid, mt, mt') -> 
-      let typ = pp_module_type None mt in 
-      let name = pp_modname (MPbound mbid) in 
-      let def = pp_module_type None mt' in 
+  | MTfunsig (mbid, mt, mt') ->
+      let typ = pp_module_type [] mt in
+      let name = pp_modname (MPbound mbid) in
+      let def = pp_module_type (MPbound mbid :: params) mt' in
       str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
-  | MTsig (msid, sign) ->
-      let tvm = top_visible_mp () in
-      let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in
-      (* References in [sign] are in short form (relative to [msid]).
-	 In push_visible, [msid-->mp] is added to the current subst. *)
-      push_visible mp (Some msid);
-      let l = map_succeed pp_specif sign in 
-      pop_visible (); 
-      str "sig " ++ fnl () ++ 
+  | MTsig (mp, sign) ->
+      push_visible mp params;
+      let l = map_succeed pp_specif sign in
+      pop_visible ();
+      str "sig " ++ fnl () ++
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
 	fnl () ++ str "end"
   | MTwith(mt,ML_With_type(idl,vl,typ)) ->
@@ -619,88 +658,78 @@ and pp_module_type ol = function
       let mp_w =
 	List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
       in
-      let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l))
-      in
-      push_visible mp_mt None;
-      let s =
-	pp_module_type None mt ++ str " with type " ++
-	  pp_global Type r ++ ids
-      in
+      let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) in
+      push_visible mp_mt [];
+      let pp_w = str " with type " ++ ids ++ pp_global Type r in
       pop_visible();
-      s ++ str "=" ++ spc () ++ pp_type false vl typ
+      pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_type false vl typ
   | MTwith(mt,ML_With_module(idl,mp)) ->
       let mp_mt = msid_of_mt mt in
       let mp_w =
 	List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl
       in
-      push_visible mp_mt None;
-      let s =
-	pp_module_type None mt ++ str " with module " ++ pp_modname mp_w
-      in
+      push_visible mp_mt [];
+      let pp_w = str " with module " ++ pp_modname mp_w in
       pop_visible ();
-      s ++ str " = " ++ pp_modname mp
+      pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_modname mp
 
 let is_short = function MEident _ | MEapply _ -> true | _ -> false
-  
-let rec pp_structure_elem = function 
-  | (l,SEdecl d) -> 
-       (try 
-	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+
+let rec pp_structure_elem = function
+  | (l,SEdecl d) ->
+       (try
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in
 	 hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++
 	 fnl () ++ str "end" ++ fnl () ++
-	 pp_alias_decl ren d 
+	 pp_alias_decl ren d
 	with Not_found -> pp_decl d)
   | (l,SEmodule m) ->
       let typ =
         (* virtual printing of the type, in order to have a correct mli later*)
 	if Common.get_phase () = Pre then
-	  str ": " ++ pp_module_type (Some l) m.ml_mod_type
+	  str ": " ++ pp_module_type [] m.ml_mod_type
 	else mt ()
       in
-      let def = pp_module_expr (Some l) m.ml_mod_expr in 
-      let name = pp_modname (MPdot (top_visible_mp (), l)) in 
-      hov 1 
-	(str "module " ++ name ++ typ ++ str " = " ++ 
-	 (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ 
-      (try 
-	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+      let def = pp_module_expr [] m.ml_mod_expr in
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in
+      hov 1
+	(str "module " ++ name ++ typ ++ str " = " ++
+	 (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++
+      (try
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in
 	 fnl () ++ str ("module "^ren^" = ") ++ name
        with Not_found -> mt ())
-  | (l,SEmodtype m) -> 
-      let def = pp_module_type None m in 
-      let name = pp_modname (MPdot (top_visible_mp (), l)) in 
+  | (l,SEmodtype m) ->
+      let def = pp_module_type [] m in
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in
       hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++
-      (try 
-	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+      (try
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in
          fnl () ++ str ("module type "^ren^" = ") ++ name
        with Not_found -> mt ())
 
-and pp_module_expr ol = function 
-  | MEident mp' -> pp_modname mp'
-  | MEfunctor (mbid, mt, me) -> 
+and pp_module_expr params = function
+  | MEident mp -> pp_modname mp
+  | MEapply (me, me') ->
+      pp_module_expr [] me ++ str "(" ++ pp_module_expr [] me' ++ str ")"
+  | MEfunctor (mbid, mt, me) ->
       let name = pp_modname (MPbound mbid) in
-      let typ = pp_module_type None mt in 
-      let def = pp_module_expr None me in 
+      let typ = pp_module_type [] mt in
+      let def = pp_module_expr (MPbound mbid :: params) me in
       str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
-  | MEapply (me, me') -> 
-      pp_module_expr None me ++ str "(" ++ pp_module_expr None me' ++ str ")"
-  | MEstruct (msid, sel) -> 
-      let tvm = top_visible_mp () in 
-      let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in
-      (* No need to update the subst with [Some msid] below : names are
-	 already in long form (see [subst_structure] in [Extract_env]). *)
-      push_visible mp None; 
-      let l = map_succeed pp_structure_elem sel in 
-      pop_visible (); 
+  | MEstruct (mp, sel) ->
+      push_visible mp params;
+      let l = map_succeed pp_structure_elem sel in
+      pop_visible ();
       str "struct " ++ fnl () ++
-      v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ 
-      fnl () ++ str "end" 
+      v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
+      fnl () ++ str "end"
 
 let do_struct f s =
   let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt ()
   in
   let ppl (mp,sel) =
-    push_visible mp None;
+    push_visible mp [];
     let p = prlist_strict pp sel in
     (* for monolithic extraction, we try to simulate the unavailability
        of [MPfile] in names by artificially nesting these [MPfile] *)
@@ -717,15 +746,14 @@ let pp_signature s = do_struct pp_specif s
 let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt ()
 
 let ocaml_descr = {
-  keywords = keywords;  
-  file_suffix = ".ml"; 
-  capital_file = false;  
-  preamble = preamble; 
-  pp_struct = pp_struct; 
-  sig_suffix = Some ".mli";  
-  sig_preamble = sig_preamble; 
+  keywords = keywords;
+  file_suffix = ".ml";
+  preamble = preamble;
+  pp_struct = pp_struct;
+  sig_suffix = Some ".mli";
+  sig_preamble = sig_preamble;
   pp_sig = pp_signature;
-  pp_decl = pp_decl; 
+  pp_decl = pp_decl;
 }
 
 
diff --git a/contrib/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
index 3d90e74c..4a1c1778 100644
--- a/contrib/extraction/ocaml.mli
+++ b/plugins/extraction/ocaml.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
+(*i $Id$ i*)
 
-val ocaml_descr : Miniml.language_descr 
+val ocaml_descr : Miniml.language_descr
 
diff --git a/contrib/extraction/scheme.ml b/plugins/extraction/scheme.ml
index f4941a9c..108d3685 100644
--- a/contrib/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.ml 11559 2008-11-07 22:03:34Z letouzey $ i*)
+(*i $Id$ i*)
 
 (*s Production of Scheme syntax. *)
 
@@ -22,38 +22,38 @@ open Common
 
 (*s Scheme renaming issues. *)
 
-let keywords =     
+let keywords =
   List.fold_right (fun s -> Idset.add (id_of_string s))
-    [ "define"; "let"; "lambda"; "lambdas"; "match"; 
-      "apply"; "car"; "cdr"; 
-      "error"; "delay"; "force"; "_"; "__"] 
+    [ "define"; "let"; "lambda"; "lambdas"; "match";
+      "apply"; "car"; "cdr";
+      "error"; "delay"; "force"; "_"; "__"]
     Idset.empty
 
-let preamble _ _ usf = 
-  str ";; This extracted scheme code relies on some additional macros\n" ++ 
+let preamble _ _ usf =
+  str ";; This extracted scheme code relies on some additional macros\n" ++
   str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++
   str "(load \"macros_extr.scm\")\n\n" ++
   (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
 
-let pr_id id = 
+let pr_id id =
   let s = string_of_id id in
-  for i = 0 to String.length s - 1 do 
+  for i = 0 to String.length s - 1 do
     if s.[i] = '\'' then s.[i] <- '~'
-  done; 
+  done;
   str s
 
 let paren = pp_par true
 
-let pp_abst st = function 
+let pp_abst st = function
   | [] -> assert false
   | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st)
-  | l -> paren 
+  | l -> paren
 	(str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st)
 
-let pp_apply st _ = function 
-  | [] -> st 
+let pp_apply st _ = function
+  | [] -> st
   | [a] -> hov 2 (paren (st ++ spc () ++ a))
-  | args -> hov 2 (paren (str "@ " ++ st ++ 
+  | args -> hov 2 (paren (str "@ " ++ st ++
 			  (prlist_strict (fun x -> spc () ++ x) args)))
 
 (*s The pretty-printer for Scheme syntax *)
@@ -62,50 +62,58 @@ let pp_global k r = str (Common.pp_global k r)
 
 (*s Pretty-printing of expressions.  *)
 
-let rec pp_expr env args = 
-  let apply st = pp_apply st true args in 
+let rec pp_expr env args =
+  let apply st = pp_apply st true args in
   function
-    | MLrel n -> 
+    | MLrel n ->
 	let id = get_db_name n env in apply (pr_id id)
     | MLapp (f,args') ->
 	let stl = List.map (pp_expr env []) args' in
         pp_expr env (stl @ args) f
-    | MLlam _ as a -> 
+    | MLlam _ as a ->
       	let fl,a' = collect_lams a in
-	let fl,env' = push_vars fl env in
+	let fl,env' = push_vars (List.map id_of_mlid fl) env in
 	apply (pp_abst (pp_expr env' [] a') (List.rev fl))
     | MLletin (id,a1,a2) ->
-	let i,env' = push_vars [id] env in
-	apply 
-	  (hv 0 
-	     (hov 2 
-		(paren 
-		   (str "let " ++ 
-		    paren 
-		      (paren 
-			 (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) 
+	let i,env' = push_vars [id_of_mlid id] env in
+	apply
+	  (hv 0
+	     (hov 2
+		(paren
+		   (str "let " ++
+		    paren
+		      (paren
+			 (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1))
 		    ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
-    | MLglob r -> 
+    | MLglob r ->
 	apply (pp_global Term r)
     | MLcons (i,r,args') ->
 	assert (args=[]);
-	let st = 
-	  str "`" ++ 
-	  paren (pp_global Cons r ++ 
+	let st =
+	  str "`" ++
+	  paren (pp_global Cons r ++
 		 (if args' = [] then mt () else spc ()) ++
 		 prlist_with_sep spc (pp_cons_args env) args')
-	in 
-	if i = Coinductive then paren (str "delay " ++ st) else st 
-    | MLcase ((i,_),t, pv) ->
-	let e = 
-	  if i <> Coinductive then pp_expr env [] t 	
+	in
+	if i = Coinductive then paren (str "delay " ++ st) else st
+    | MLcase (_,t,pv) when is_custom_match pv ->
+	let mkfun (_,ids,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	hov 2 (str (find_custom_match pv) ++ fnl () ++
+		 prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv
+	       ++ pp_expr env [] t)
+     | MLcase ((i,_),t, pv) ->
+	let e =
+	  if i <> Coinductive then pp_expr env [] t
 	  else paren (str "force" ++ spc () ++ pp_expr env [] t)
-	in 
+	in
 	apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv)))
     | MLfix (i,ids,defs) ->
 	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
       	pp_fix env' i (Array.of_list (List.rev ids'),defs) args
-    | MLexn s -> 
+    | MLexn s ->
 	(* An [MLexn] may be applied, but I don't really care. *)
 	paren (str "error" ++ spc () ++ qs s)
     | MLdummy ->
@@ -114,36 +122,36 @@ let rec pp_expr env args =
 	pp_expr env args a
     | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"")
 
-and pp_cons_args env = function 
-  | MLcons (i,r,args) when i<>Coinductive -> 
-      paren (pp_global Cons r ++ 
+and pp_cons_args env = function
+  | MLcons (i,r,args) when i<>Coinductive ->
+      paren (pp_global Cons r ++
 	     (if args = [] then mt () else spc ()) ++
 	     prlist_with_sep spc (pp_cons_args env) args)
   | e -> str "," ++ pp_expr env [] e
-	
 
-and pp_one_pat env (r,ids,t) = 
-  let ids,env' = push_vars (List.rev ids) env in
-  let args = 
-    if ids = [] then mt () 
+
+and pp_one_pat env (r,ids,t) =
+  let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
+  let args =
+    if ids = [] then mt ()
     else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
-  in 
+  in
   (pp_global Cons r ++ args), (pp_expr env' [] t)
-  
-and pp_pat env pv = 
-  prvect_with_sep fnl  
-    (fun x -> let s1,s2 = pp_one_pat env x in 
+
+and pp_pat env pv =
+  prvect_with_sep fnl
+    (fun x -> let s1,s2 = pp_one_pat env x in
      hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv
 
 (*s names of the functions ([ids]) are already pushed in [env],
     and passed here just for convenience. *)
 
 and pp_fix env j (ids,bl) args =
-    paren 
+    paren
       (str "letrec " ++
-       (v 0 (paren 
+       (v 0 (paren
 	       (prvect_with_sep fnl
-		  (fun (fi,ti) -> 
+		  (fun (fi,ti) ->
 		     paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti)))
 		  (array_map2 (fun id b -> (id,b)) ids bl)) ++
 	     fnl () ++
@@ -153,50 +161,55 @@ and pp_fix env j (ids,bl) args =
 
 let pp_decl = function
   | Dind _ -> mt ()
-  | Dtype _ -> mt () 
+  | Dtype _ -> mt ()
   | Dfix (rv, defs,_) ->
-      let ppv = Array.map (pp_global Term) rv in 
-      prvect_with_sep fnl 
-	(fun (pi,ti) -> 
-	   hov 2 
-	     (paren (str "define " ++ pi ++ spc () ++ 
-		     (pp_expr (empty_env ()) [] ti)) 
+      let ppv = Array.map (pp_global Term) rv in
+      prvect_with_sep fnl
+	(fun (pi,ti) ->
+	   hov 2
+	     (paren (str "define " ++ pi ++ spc () ++
+		     (pp_expr (empty_env ()) [] ti))
 	      ++ fnl ()))
 	(array_map2 (fun p b -> (p,b)) ppv defs) ++
       fnl ()
   | Dterm (r, a, _) ->
-      if is_inline_custom r then mt () 
-      else 
-	if is_custom r then 
-	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ 
-			  str (find_custom r))) ++ fnl () ++ fnl () 
-	else 
+      if is_inline_custom r then mt ()
+      else
+	if is_custom r then
+	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
+			  str (find_custom r))) ++ fnl () ++ fnl ()
+	else
 	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
 			  pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl ()
 
-let pp_structure_elem = function 
+let rec pp_structure_elem = function
   | (l,SEdecl d) -> pp_decl d
-  | (l,SEmodule m) -> 
-      failwith "TODO: Scheme extraction of modules not implemented yet"
-  | (l,SEmodtype m) -> 
-      failwith "TODO: Scheme extraction of modules not implemented yet"
-
-let pp_struct = 
-  let pp_sel (mp,sel) = 
-    push_visible mp None; 
-    let p = prlist_strict pp_structure_elem sel in 
+  | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr
+  | (l,SEmodtype m) -> mt ()
+      (* for the moment we simply discard module type *)
+
+and pp_module_expr = function
+  | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel
+  | MEfunctor _ -> mt ()
+      (* for the moment we simply discard unapplied functors *)
+  | MEident _ | MEapply _ -> assert false
+      (* should be expansed in extract_env *)
+
+let pp_struct =
+  let pp_sel (mp,sel) =
+    push_visible mp [];
+    let p = prlist_strict pp_structure_elem sel in
     pop_visible (); p
   in
   prlist_strict pp_sel
 
 let scheme_descr = {
-  keywords = keywords;  
-  file_suffix = ".scm"; 
-  capital_file = false;  
-  preamble = preamble; 
-  pp_struct = pp_struct; 
+  keywords = keywords;
+  file_suffix = ".scm";
+  preamble = preamble;
+  pp_struct = pp_struct;
   sig_suffix = None;
-  sig_preamble = (fun _ _ _ -> mt ()); 
-  pp_sig = (fun _ -> mt ()); 
-  pp_decl = pp_decl; 
+  sig_preamble = (fun _ _ _ -> mt ());
+  pp_sig = (fun _ -> mt ());
+  pp_decl = pp_decl;
 }
diff --git a/contrib/extraction/scheme.mli b/plugins/extraction/scheme.mli
index a88bb6db..b0fa395c 100644
--- a/contrib/extraction/scheme.mli
+++ b/plugins/extraction/scheme.mli
@@ -6,6 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
+(*i $Id$ i*)
 
-val scheme_descr : Miniml.language_descr 
+val scheme_descr : Miniml.language_descr
diff --git a/contrib/extraction/table.ml b/plugins/extraction/table.ml
index c675a744..685b84fc 100644
--- a/contrib/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.ml 11844 2009-01-22 16:45:06Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Names
 open Term
 open Declarations
 open Nameops
+open Namegen
 open Summary
 open Libobject
 open Goptions
@@ -27,93 +28,96 @@ let occur_kn_in_ref kn = function
   | ConstructRef ((kn',_),_) -> kn = kn'
   | ConstRef _ -> false
   | VarRef _ -> assert false
-      
-let modpath_of_r = function 
-  | ConstRef kn -> con_modpath kn
-  | IndRef (kn,_)
-  | ConstructRef ((kn,_),_) -> modpath kn
-  | VarRef _ -> assert false
-      
-let label_of_r = function 
-  | ConstRef kn -> con_label kn
+
+let repr_of_r = function
+  | ConstRef kn -> repr_con kn
   | IndRef (kn,_)
-  | ConstructRef ((kn,_),_) -> label kn
+  | ConstructRef ((kn,_),_) -> repr_mind kn
   | VarRef _ -> assert false
 
-let rec base_mp = function 
-  | MPdot (mp,l) -> base_mp mp 
-  | mp -> mp 
+let modpath_of_r r =
+  let mp,_,_ = repr_of_r r in mp
 
-let rec mp_length = function
-  | MPdot (mp, _) -> 1 + (mp_length mp)
-  | _ -> 1
+let label_of_r r =
+  let _,_,l = repr_of_r r in l
 
-let is_modfile = function 
-  | MPfile _ -> true 
+let rec base_mp = function
+  | MPdot (mp,l) -> base_mp mp
+  | mp -> mp
+
+let is_modfile = function
+  | MPfile _ -> true
   | _ -> false
 
 let raw_string_of_modfile = function
   | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f)))
   | _ -> assert false
 
-let rec modfile_of_mp = function 
+let rec modfile_of_mp = function
   | (MPfile _) as mp -> mp
-  | MPdot (mp,_) -> modfile_of_mp mp 
+  | MPdot (mp,_) -> modfile_of_mp mp
   | _ -> raise Not_found
 
 let current_toplevel () = fst (Lib.current_prefix ())
 
-let is_toplevel mp = 
+let is_toplevel mp =
   mp = initial_path || mp = current_toplevel ()
 
-let at_toplevel mp = 
+let at_toplevel mp =
   is_modfile mp || is_toplevel mp
 
-let visible_kn kn = at_toplevel (base_mp (modpath kn))
+let rec mp_length mp =
+  let mp0 = current_toplevel () in
+  let rec len = function
+    | mp when mp = mp0 -> 1
+    | MPdot (mp,_) -> 1 + len mp
+    | _ -> 1
+  in len mp
+
 let visible_con kn = at_toplevel (base_mp (con_modpath kn))
 
-let rec prefixes_mp mp = match mp with 
+let rec prefixes_mp mp = match mp with
   | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
-  | _ -> MPset.singleton mp 
+  | _ -> MPset.singleton mp
 
 let rec get_nth_label_mp n = function
   | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp
   | _ -> failwith "get_nth_label: not enough MPdot"
 
-let common_prefix_from_list mp0 mpl = 
-  let prefixes = prefixes_mp mp0 in 
-  let rec f = function 
-    | [] -> raise Not_found
-    | mp :: l -> if MPset.mem mp prefixes then mp else f l 
+let common_prefix_from_list mp0 mpl =
+  let prefixes = prefixes_mp mp0 in
+  let rec f = function
+    | [] -> None
+    | mp :: l -> if MPset.mem mp prefixes then Some mp else f l
   in f mpl
 
-let rec parse_labels ll = function 
-  | MPdot (mp,l) -> parse_labels (l::ll) mp 
+let rec parse_labels ll = function
+  | MPdot (mp,l) -> parse_labels (l::ll) mp
   | mp -> mp,ll
 
-let labels_of_mp mp = parse_labels [] mp 
+let labels_of_mp mp = parse_labels [] mp
 
-let labels_of_ref r = 
- let mp,_,l =
-  match r with
-     ConstRef con -> repr_con con
-   | IndRef (kn,_)
-   | ConstructRef ((kn,_),_) -> repr_kn kn
-   | VarRef _ -> assert false
- in
-  parse_labels [l] mp
+let rec parse_labels2 ll mp1 = function
+  | mp when mp1=mp -> mp,ll
+  | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp
+  | mp -> mp,ll
 
-let rec add_labels_mp mp = function 
-  | [] -> mp 
+let labels_of_ref r =
+  let mp_top = current_toplevel () in
+  let mp,_,l = repr_of_r r in
+  parse_labels2 [l] mp_top mp
+
+let rec add_labels_mp mp = function
+  | [] -> mp
   | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
 
 
 (*S The main tables: constants, inductives, records, ... *)
 
-(* Theses tables are not registered within coq save/undo mechanism 
+(* Theses tables are not registered within coq save/undo mechanism
    since we reset their contents at each run of Extraction *)
 
-(*s Constants tables. *) 
+(*s Constants tables. *)
 
 let terms = ref (Cmap.empty : ml_decl Cmap.t)
 let init_terms () = terms := Cmap.empty
@@ -123,32 +127,32 @@ let lookup_term kn = Cmap.find kn !terms
 let types = ref (Cmap.empty : ml_schema Cmap.t)
 let init_types () = types := Cmap.empty
 let add_type kn s = types := Cmap.add kn s !types
-let lookup_type kn = Cmap.find kn !types 
+let lookup_type kn = Cmap.find kn !types
 
 (*s Inductives table. *)
 
-let inductives = ref (KNmap.empty : (mutual_inductive_body * ml_ind) KNmap.t)
-let init_inductives () = inductives := KNmap.empty
-let add_ind kn mib ml_ind = inductives := KNmap.add kn (mib,ml_ind) !inductives
-let lookup_ind kn = KNmap.find kn !inductives
+let inductives = ref (Mindmap.empty : (mutual_inductive_body * ml_ind) Mindmap.t)
+let init_inductives () = inductives := Mindmap.empty
+let add_ind kn mib ml_ind = inductives := Mindmap.add kn (mib,ml_ind) !inductives
+let lookup_ind kn = Mindmap.find kn !inductives
 
 (*s Recursors table. *)
 
 let recursors = ref Cset.empty
 let init_recursors () = recursors := Cset.empty
 
-let add_recursors env kn = 
-  let make_kn id = make_con (modpath kn) empty_dirpath (label_of_id id) in 
-  let mib = Environ.lookup_mind kn env in 
-  Array.iter 
-    (fun mip -> 
-       let id = mip.mind_typename in 
+let add_recursors env kn =
+  let make_kn id = make_con (mind_modpath kn) empty_dirpath (label_of_id id) in
+  let mib = Environ.lookup_mind kn env in
+  Array.iter
+    (fun mip ->
+       let id = mip.mind_typename in
        let kn_rec = make_kn (Nameops.add_suffix id "_rec")
-       and kn_rect = make_kn (Nameops.add_suffix id "_rect") in 
+       and kn_rect = make_kn (Nameops.add_suffix id "_rect") in
        recursors := Cset.add kn_rec (Cset.add kn_rect !recursors))
     mib.mind_packets
 
-let is_recursor = function 
+let is_recursor = function
   | ConstRef kn -> Cset.mem kn !recursors
   | _ -> false
 
@@ -179,19 +183,21 @@ let modular () = !modular_ref
 (*s Printing. *)
 
 (* The following functions work even on objects not in [Global.env ()].
-   WARNING: for inductive objects, an extract_inductive must have been 
+   WARNING: for inductive objects, an extract_inductive must have been
    done before. *)
 
-let safe_id_of_global = function 
+let safe_basename_of_global = function
   | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l
   | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename
-  | ConstructRef ((kn,i),j) -> 
+  | ConstructRef ((kn,i),j) ->
       (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1)
   | _ -> assert false
 
-let safe_pr_global r =
- try Printer.pr_global r
- with _ -> pr_id (safe_id_of_global r)
+let string_of_global r =
+ try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
+ with _ -> string_of_id (safe_basename_of_global r)
+
+let safe_pr_global r = str (string_of_global r)
 
 (* idem, but with qualification, and only for constants. *)
 
@@ -204,30 +210,30 @@ let safe_pr_long_global r =
     | _ -> assert false
 
 let pr_long_mp mp =
-  let lid = repr_dirpath (Nametab.dir_of_mp mp) in
+  let lid = repr_dirpath (Nametab.dirpath_of_module mp) in
   str (String.concat "." (List.map string_of_id (List.rev lid)))
 
-let pr_long_global ref = pr_sp (Nametab.sp_of_global ref)
+let pr_long_global ref = pr_path (Nametab.path_of_global ref)
 
 (*S Warning and Error messages. *)
 
 let err s = errorlabstrm "Extraction" s
 
-let warning_axioms () = 
-  let info_axioms = Refset.elements !info_axioms in 
-  if info_axioms = [] then () 
+let warning_axioms () =
+  let info_axioms = Refset.elements !info_axioms in
+  if info_axioms = [] then ()
   else begin
-    let s = if List.length info_axioms = 1 then "axiom" else "axioms" in 
-    msg_warning 
+    let s = if List.length info_axioms = 1 then "axiom" else "axioms" in
+    msg_warning
       (str ("The following "^s^" must be realized in the extracted code:")
        ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms)
        ++ str "." ++ fnl ())
   end;
-  let log_axioms = Refset.elements !log_axioms in 
+  let log_axioms = Refset.elements !log_axioms in
   if log_axioms = [] then ()
   else begin
-    let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" 
-    in 
+    let s = if List.length log_axioms = 1 then "axiom was" else "axioms were"
+    in
     msg_warning
       (str ("The following logical "^s^" encountered:") ++
        hov 1
@@ -248,51 +254,56 @@ let warning_both_mod_and_cst q mp r =
     str "First choice is assumed, for the second one please use " ++
     str "fully qualified name." ++ fnl ())
 
-let error_axiom_scheme r i = 
+let error_axiom_scheme r i =
   err (str "The type scheme axiom " ++ spc () ++
-       safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ 
-       str " type variable(s).") 
+       safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++
+       str " type variable(s).")
 
-let check_inside_module () = 
-  if Lib.is_modtype () then 
+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 
+	 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")
 
-let check_inside_section () = 
-  if Lib.sections_are_opened () then 
+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 error_constant r = 
-  err (safe_pr_global r ++ str " is not a constant.") 
+let warning_id s =
+  msg_warning (str ("The identifier "^s^
+		    " contains __ which is reserved for the extraction"))
+
+let error_constant r =
+  err (safe_pr_global r ++ str " is not a constant.")
 
-let error_inductive r = 
+let error_inductive r =
   err (safe_pr_global r ++ spc () ++ str "is not an inductive type.")
 
-let error_nb_cons () = 
+let error_nb_cons () =
   err (str "Not the right number of constructors.")
 
-let error_module_clash s = 
-  err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ 
-       str "This is not supported yet. Please do some renaming first.") 
+let error_module_clash mp1 mp2 =
+  err (str "The Coq modules " ++ pr_long_mp mp1 ++ str " and " ++
+       pr_long_mp mp2 ++ str " have the same ML name.\n" ++
+       str "This is not supported yet. Please do some renaming first.")
 
-let error_unknown_module m = 
-  err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") 
+let error_unknown_module m =
+  err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.")
 
-let error_scheme () = 
+let error_scheme () =
   err (str "No Scheme modular extraction available yet.")
 
-let error_not_visible r = 
+let error_not_visible r =
   err (safe_pr_global r ++ str " is not directly visible.\n" ++
-       str "For example, it may be inside an applied functor." ++
+       str "For example, it may be inside an applied functor.\n" ++
        str "Use Recursive Extraction to get the whole environment.")
 
-let error_MPfile_as_mod mp b = 
-  let s1 = if b then "asked" else "required" in 
+let error_MPfile_as_mod mp b =
+  let s1 = if b then "asked" else "required" in
   let s2 = if b then "extract some objects of this module or\n" else "" in
   err (str ("Extraction of file "^(raw_string_of_modfile mp)^
 	    ".v as a module is "^s1^".\n"^
@@ -303,32 +314,48 @@ let error_record r =
   err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++
        fnl () ++ str "To help extraction, please use an explicit name.")
 
-let check_loaded_modfile mp = match base_mp mp with 
-  | MPfile dp -> if not (Library.library_is_loaded dp) then 
-      err (str ("Please load library "^(string_of_dirpath dp^" first.")))
+let msg_non_implicit r n id =
+  let name = match id with
+    | Anonymous -> ""
+    | Name id -> "(" ^ string_of_id id ^ ") "
+  in
+  "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
+
+let error_non_implicit msg =
+  err (str (msg ^ " still occurs after extraction.") ++
+       fnl () ++ str "Please check the Extraction Implicit declarations.")
+
+let check_loaded_modfile mp = match base_mp mp with
+  | MPfile dp ->
+      if not (Library.library_is_loaded dp) then begin
+	match base_mp (current_toplevel ()) with
+	  | MPfile dp' when dp<>dp' ->
+	      err (str ("Please load library "^(string_of_dirpath dp^" first.")))
+	  | _ -> ()
+      end
   | _ -> ()
 
-let info_file f =   
-  Flags.if_verbose message 
+let info_file f =
+  Flags.if_verbose message
     ("The file "^f^" has been created by extraction.")
 
 
 (*S The Extraction auxiliary commands *)
 
-(* The objects defined below should survive an arbitrary time, 
+(* The objects defined below should survive an arbitrary time,
    so we register them to coq save/undo mechanism. *)
 
 (*s Extraction AutoInline *)
 
-let auto_inline_ref = ref true
+let auto_inline_ref = ref false
 
 let auto_inline () = !auto_inline_ref
 
-let _ = declare_bool_option 
+let _ = declare_bool_option
 	  {optsync = true;
 	   optname = "Extraction AutoInline";
-	   optkey = SecondaryTable ("Extraction", "AutoInline");
-	   optread = auto_inline; 
+	   optkey = ["Extraction"; "AutoInline"];
+	   optread = auto_inline;
 	   optwrite = (:=) auto_inline_ref}
 
 (*s Extraction TypeExpand *)
@@ -337,17 +364,17 @@ let type_expand_ref = ref true
 
 let type_expand () = !type_expand_ref
 
-let _ = declare_bool_option 
+let _ = declare_bool_option
 	  {optsync = true;
 	   optname = "Extraction TypeExpand";
-	   optkey = SecondaryTable ("Extraction", "TypeExpand");
-	   optread = type_expand; 
+	   optkey = ["Extraction"; "TypeExpand"];
+	   optread = type_expand;
 	   optwrite = (:=) type_expand_ref}
 
 (*s Extraction Optimize *)
 
-type opt_flag = 
-    { opt_kill_dum : bool; (* 1 *) 
+type opt_flag =
+    { opt_kill_dum : bool; (* 1 *)
       opt_fix_fun : bool;   (* 2 *)
       opt_case_iot : bool;  (* 4 *)
       opt_case_idr : bool;  (* 8 *)
@@ -361,12 +388,12 @@ type opt_flag =
 
 let kth_digit n k = (n land (1 lsl k) <> 0)
 
-let flag_of_int n = 
+let flag_of_int n =
     { opt_kill_dum = kth_digit n 0;
       opt_fix_fun = kth_digit n 1;
       opt_case_iot = kth_digit n 2;
       opt_case_idr = kth_digit n 3;
-      opt_case_idg = kth_digit n 4; 
+      opt_case_idg = kth_digit n 4;
       opt_case_cst = kth_digit n 5;
       opt_case_fun = kth_digit n 6;
       opt_case_app = kth_digit n 7;
@@ -374,10 +401,14 @@ let flag_of_int n =
       opt_lin_let = kth_digit n 9;
       opt_lin_beta = kth_digit n 10 }
 
-(* For the moment, we allow by default everything except the type-unsafe 
-   optimization [opt_case_idg]. *)
+(* For the moment, we allow by default everything except :
+   - the type-unsafe optimization [opt_case_idg]
+   - the linear let and beta reduction [opt_lin_let] and [opt_lin_beta]
+     (may lead to complexity blow-up, subsumed by finer reductions
+      when inlining recursors).
+*)
 
-let int_flag_init = 1 + 2 + 4 + 8 + 32 + 64 + 128 + 256 + 512 + 1024
+let int_flag_init = 1 + 2 + 4 + 8 (*+ 16*) + 32 + 64 + 128 + 256 (*+ 512 + 1024*)
 
 let int_flag_ref = ref int_flag_init
 let opt_flag_ref = ref (flag_of_int int_flag_init)
@@ -386,19 +417,19 @@ let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n
 
 let optims () = !opt_flag_ref
 
-let _ = declare_bool_option 
-	  {optsync = true; 
+let _ = declare_bool_option
+	  {optsync = true;
 	   optname = "Extraction Optimize";
-	   optkey = SecondaryTable ("Extraction", "Optimize");
-	   optread = (fun () -> !int_flag_ref <> 0); 
+	   optkey = ["Extraction"; "Optimize"];
+	   optread = (fun () -> !int_flag_ref <> 0);
 	   optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
 
 let _ = declare_int_option
           { optsync = true;
             optname = "Extraction Flag";
-            optkey = SecondaryTable("Extraction","Flag"); 
-            optread = (fun _ -> Some !int_flag_ref); 
-            optwrite = (function 
+            optkey = ["Extraction";"Flag"];
+            optread = (fun _ -> Some !int_flag_ref);
+            optwrite = (function
                           | None -> chg_flag 0
                           | Some i -> chg_flag (max i 0))}
 
@@ -411,20 +442,17 @@ let lang_ref = ref Ocaml
 
 let lang () = !lang_ref
 
-let (extr_lang,_) = 
-  declare_object 
-    {(default_object "Extraction Lang") with  
+let (extr_lang,_) =
+  declare_object
+    {(default_object "Extraction Lang") with
        cache_function = (fun (_,l) -> lang_ref := l);
-       load_function = (fun _ (_,l) -> lang_ref := l);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,l) -> lang_ref := l)}
 
-let _ = declare_summary "Extraction Lang" 
+let _ = declare_summary "Extraction Lang"
 	  { freeze_function = (fun () -> !lang_ref);
 	    unfreeze_function = ((:=) lang_ref);
-	    init_function = (fun () -> lang_ref := Ocaml);
-	    survive_module = true;
-	    survive_section = true }  
-	  
+	    init_function = (fun () -> lang_ref := Ocaml) }
+
 let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
 
 (*s Extraction Inline/NoInline *)
@@ -437,70 +465,118 @@ let to_inline r = Refset.mem r (fst !inline_table)
 
 let to_keep r = Refset.mem r (snd !inline_table)
 
-let add_inline_entries b l = 
-  let f b = if b then Refset.add else Refset.remove in 
-  let i,k = !inline_table in 
-  inline_table := 
-  (List.fold_right (f b) l i), 
+let add_inline_entries b l =
+  let f b = if b then Refset.add else Refset.remove in
+  let i,k = !inline_table in
+  inline_table :=
+  (List.fold_right (f b) l i),
   (List.fold_right (f (not b)) l k)
 
 (* Registration of operations for rollback. *)
 
 let (inline_extraction,_) =
-  declare_object 
-    {(default_object "Extraction Inline") with 
+  declare_object
+    {(default_object "Extraction Inline") with
        cache_function = (fun (_,(b,l)) -> add_inline_entries b l);
        load_function = (fun _ (_,(b,l)) -> add_inline_entries b l);
-       export_function = (fun x -> Some x); 
-       classify_function = (fun (_,o) -> Substitute o); 
+       classify_function = (fun o -> Substitute o);
        subst_function =
-        (fun (_,s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
+        (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
     }
 
 let _ = declare_summary "Extraction Inline"
 	  { freeze_function = (fun () -> !inline_table);
 	    unfreeze_function = ((:=) inline_table);
-	    init_function = (fun () -> inline_table := empty_inline_table);
-	    survive_module = true;
-	    survive_section = true }
+	    init_function = (fun () -> inline_table := empty_inline_table) }
 
 (* Grammar entries. *)
 
 let extraction_inline b l =
-  check_inside_section (); 
-  let refs = List.map Nametab.global l in 
-  List.iter 
-    (fun r -> match r with 
+  check_inside_section ();
+  let refs = List.map Nametab.global l in
+  List.iter
+    (fun r -> match r with
        | ConstRef _ -> ()
-       | _ -> error_constant r) refs; 
+       | _ -> error_constant r) refs;
   Lib.add_anonymous_leaf (inline_extraction (b,refs))
 
 (* Printing part *)
 
-let print_extraction_inline () = 
-  let (i,n)= !inline_table in 
-  let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in 
-  msg 
-    (str "Extraction Inline:" ++ fnl () ++ 
+let print_extraction_inline () =
+  let (i,n)= !inline_table in
+  let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in
+  msg
+    (str "Extraction Inline:" ++ fnl () ++
      Refset.fold
-       (fun r p -> 
+       (fun r p ->
 	  (p ++ str "  " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++
-     str "Extraction NoInline:" ++ fnl () ++ 
+     str "Extraction NoInline:" ++ fnl () ++
      Refset.fold
-       (fun r p -> 
+       (fun r p ->
 	  (p ++ str "  " ++ safe_pr_long_global r ++ fnl ())) n (mt ()))
 
 (* Reset part *)
 
-let (reset_inline,_) = 
+let (reset_inline,_) =
   declare_object
-    {(default_object "Reset Extraction Inline") with  
+    {(default_object "Reset Extraction Inline") with
        cache_function = (fun (_,_)-> inline_table :=  empty_inline_table);
-       load_function = (fun _ (_,_)-> inline_table :=  empty_inline_table); 
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,_)-> inline_table :=  empty_inline_table)}
 
 let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
 
+(*s Extraction Implicit *)
+
+type int_or_id = ArgInt of int | ArgId of identifier
+
+let implicits_table = ref Refmap.empty
+
+let implicits_of_global r =
+ try Refmap.find r !implicits_table with Not_found -> []
+
+let add_implicits r l =
+  let typ = Global.type_of_global r in
+  let rels,_ =
+    decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
+  let names = List.rev_map fst rels in
+  let n = List.length names in
+  let check = function
+    | ArgInt i ->
+	if 1 <= i && i <= n then i
+	else err (int i ++ str " is not a valid argument number for " ++
+		  safe_pr_global r)
+    | ArgId id ->
+	(try list_index (Name id) names
+	 with Not_found ->
+	   err (str "No argument " ++ pr_id id ++ str " for " ++
+		safe_pr_global r))
+  in
+  let l' = List.map check l in
+  implicits_table := Refmap.add r l' !implicits_table
+
+(* Registration of operations for rollback. *)
+
+let (implicit_extraction,_) =
+  declare_object
+    {(default_object "Extraction Implicit") with
+       cache_function = (fun (_,(r,l)) -> add_implicits r l);
+       load_function = (fun _ (_,(r,l)) -> add_implicits r l);
+       classify_function = (fun o -> Substitute o);
+       subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l))
+    }
+
+let _ = declare_summary "Extraction Implicit"
+	  { freeze_function = (fun () -> !implicits_table);
+	    unfreeze_function = ((:=) implicits_table);
+	    init_function = (fun () -> implicits_table := Refmap.empty) }
+
+(* Grammar entries. *)
+
+let extraction_implicit r l =
+  check_inside_section ();
+  Lib.add_anonymous_leaf (implicit_extraction (Nametab.global r,l))
+
+
 (*s Extraction Blacklist of filenames not to use while extracting *)
 
 let blacklist_table = ref Idset.empty
@@ -522,6 +598,17 @@ let string_of_modfile mp =
     modfile_mps := MPmap.add mp s' !modfile_mps;
     s'
 
+(* same as [string_of_modfile], but preserves the capital/uncapital 1st char *)
+
+let file_of_modfile mp =
+  let s0 = match mp with
+    | MPfile f -> string_of_id (List.hd (repr_dirpath f))
+    | _ -> assert false
+  in
+  let s = String.copy (string_of_modfile mp) in
+  if s.[0] <> s0.[0] then s.[0] <- s0.[0];
+  s
+
 let add_blacklist_entries l =
   blacklist_table :=
     List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s)))
@@ -534,17 +621,14 @@ let (blacklist_extraction,_) =
     {(default_object "Extraction Blacklist") with
        cache_function = (fun (_,l) -> add_blacklist_entries l);
        load_function = (fun _ (_,l) -> add_blacklist_entries l);
-       export_function = (fun x -> Some x);
-       classify_function = (fun (_,o) -> Libobject.Keep o);
-       subst_function = (fun (_,_,x) -> x)
+       classify_function = (fun o -> Libobject.Keep o);
+       subst_function = (fun (_,x) -> x)
     }
 
 let _ = declare_summary "Extraction Blacklist"
 	  { freeze_function = (fun () -> !blacklist_table);
 	    unfreeze_function = ((:=) blacklist_table);
-	    init_function = (fun () -> blacklist_table := Idset.empty);
-	    survive_module = true;
-	    survive_section = true }
+	    init_function = (fun () -> blacklist_table := Idset.empty) }
 
 (* Grammar entries. *)
 
@@ -564,16 +648,15 @@ let (reset_blacklist,_) =
   declare_object
     {(default_object "Reset Extraction Blacklist") with
        cache_function = (fun (_,_)-> blacklist_table := Idset.empty);
-       load_function = (fun _ (_,_)-> blacklist_table := Idset.empty);
-       export_function = (fun x -> Some x)}
+       load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)}
 
 let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ())
 
 (*s Extract Constant/Inductive. *)
 
 (* UGLY HACK: to be defined in [extraction.ml] *)
-let use_type_scheme_nb_args, register_type_scheme_nb_args = 
-  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r 
+let use_type_scheme_nb_args, register_type_scheme_nb_args =
+  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r
 
 let customs = ref Refmap.empty
 
@@ -581,68 +664,99 @@ let add_custom r ids s = customs := Refmap.add r (ids,s) !customs
 
 let is_custom r = Refmap.mem r !customs
 
-let is_inline_custom r = (is_custom r) && (to_inline r) 
+let is_inline_custom r = (is_custom r) && (to_inline r)
 
 let find_custom r = snd (Refmap.find r !customs)
 
 let find_type_custom r = Refmap.find r !customs
 
+let custom_matchs = ref Refmap.empty
+
+let add_custom_match r s =
+  custom_matchs := Refmap.add r s !custom_matchs
+
+let indref_of_match pv =
+  if Array.length pv = 0 then raise Not_found;
+  match pv.(0) with
+    | (ConstructRef (ip,_), _, _) -> IndRef ip
+    | _ -> raise Not_found
+
+let is_custom_match pv =
+  try Refmap.mem (indref_of_match pv) !custom_matchs
+  with Not_found -> false
+
+let find_custom_match pv =
+  Refmap.find (indref_of_match pv) !custom_matchs
+
 (* Registration of operations for rollback. *)
 
-let (in_customs,_) = 
-  declare_object 
-    {(default_object "ML extractions") with 
+let (in_customs,_) =
+  declare_object
+    {(default_object "ML extractions") with
        cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s);
        load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s);
-       export_function = (fun x -> Some x); 
-       classify_function = (fun (_,o) -> Substitute o); 
+       classify_function = (fun o -> Substitute o);
        subst_function =
-        (fun (_,s,(r,ids,str)) -> (fst (subst_global s r), ids, str))
+        (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))
     }
 
 let _ = declare_summary "ML extractions"
 	  { freeze_function = (fun () -> !customs);
 	    unfreeze_function = ((:=) customs);
-	    init_function = (fun () -> customs := Refmap.empty);
-	    survive_module = true;
-	    survive_section = true }
+	    init_function = (fun () -> customs := Refmap.empty) }
+
+let (in_custom_matchs,_) =
+  declare_object
+    {(default_object "ML extractions custom matchs") with
+       cache_function = (fun (_,(r,s)) -> add_custom_match r s);
+       load_function = (fun _ (_,(r,s)) -> add_custom_match r s);
+       classify_function = (fun o -> Substitute o);
+       subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s))
+    }
+
+let _ = declare_summary "ML extractions custom match"
+	  { freeze_function = (fun () -> !custom_matchs);
+	    unfreeze_function = ((:=) custom_matchs);
+	    init_function = (fun () -> custom_matchs := Refmap.empty) }
 
 (* Grammar entries. *)
 
 let extract_constant_inline inline r ids s =
   check_inside_section ();
-  let g = Nametab.global r in 
-  match g with 
-    | ConstRef kn -> 
-	let env = Global.env () in 
-	let typ = Typeops.type_of_constant env kn in 
+  let g = Nametab.global r in
+  match g with
+    | ConstRef kn ->
+	let env = Global.env () in
+	let typ = Typeops.type_of_constant env kn in
 	let typ = Reduction.whd_betadeltaiota env typ in
-	if Reduction.is_arity env typ 
-	  then begin 
-	    let nargs = use_type_scheme_nb_args env typ in 
+	if Reduction.is_arity env typ
+	  then begin
+	    let nargs = use_type_scheme_nb_args env typ in
 	    if List.length ids <> nargs then error_axiom_scheme g nargs
-	  end; 
+	  end;
 	Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
 	Lib.add_anonymous_leaf (in_customs (g,ids,s))
     | _ -> error_constant g
 
 
-let extract_inductive r (s,l) =
+let extract_inductive r s l optstr =
   check_inside_section ();
-  let g = Nametab.global r in 
+  let g = Nametab.global r in
   match g with
     | IndRef ((kn,i) as ip) ->
 	let mib = Global.lookup_mind kn in
 	let n = Array.length mib.mind_packets.(i).mind_consnames in
-	if n <> List.length l then error_nb_cons (); 
+	if n <> List.length l then error_nb_cons ();
 	Lib.add_anonymous_leaf (inline_extraction (true,[g]));
 	Lib.add_anonymous_leaf (in_customs (g,[],s));
+	Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s)))
+	  optstr;
 	list_iter_i
-	  (fun j s -> 
-	     let g = ConstructRef (ip,succ j) in 
+	  (fun j s ->
+	     let g = ConstructRef (ip,succ j) in
 	     Lib.add_anonymous_leaf (inline_extraction (true,[g]));
 	     Lib.add_anonymous_leaf (in_customs (g,[],s))) l
-    | _ -> error_inductive g 
+    | _ -> error_inductive g
 
 
 
diff --git a/contrib/extraction/table.mli b/plugins/extraction/table.mli
index 5ef7139e..ae46233d 100644
--- a/contrib/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -6,53 +6,58 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.mli 11844 2009-01-22 16:45:06Z letouzey $ i*)
+(*i $Id$ i*)
 
 open Names
 open Libnames
 open Miniml
 open Declarations
 
-val safe_id_of_global : global_reference -> identifier
+val safe_basename_of_global : global_reference -> identifier
 
 (*s Warning and Error messages. *)
 
 val warning_axioms : unit -> unit
 val warning_both_mod_and_cst :
  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
 val error_inductive : global_reference -> 'a
 val error_nb_cons : unit -> 'a
-val error_module_clash : string -> 'a 
+val error_module_clash : module_path -> module_path -> 'a
 val error_unknown_module : qualid -> 'a
 val error_scheme : unit -> 'a
 val error_not_visible : global_reference -> 'a
 val error_MPfile_as_mod : module_path -> bool -> 'a
-val error_record : global_reference -> 'a 
+val error_record : global_reference -> 'a
 val check_inside_module : unit -> unit
 val check_inside_section : unit -> unit
 val check_loaded_modfile : module_path -> unit
+val msg_non_implicit : global_reference -> int -> name -> string
+val error_non_implicit : string -> 'a
 
 val info_file : string -> unit
 
 (*s utilities about [module_path] and [kernel_names] and [global_reference] *)
 
-val occur_kn_in_ref : kernel_name -> global_reference -> bool
+val occur_kn_in_ref : mutual_inductive -> global_reference -> bool
+val repr_of_r : global_reference -> module_path * dir_path * label
 val modpath_of_r : global_reference -> module_path
 val label_of_r : global_reference -> label
 val current_toplevel : unit -> module_path
 val base_mp : module_path -> module_path
 val is_modfile : module_path -> bool
-val string_of_modfile : module_path -> string 
+val string_of_modfile : module_path -> string
+val file_of_modfile : module_path -> string
 val is_toplevel : module_path -> bool
-val at_toplevel : module_path -> bool 
-val visible_kn : kernel_name -> bool
+val at_toplevel : module_path -> bool
 val visible_con : constant -> bool
 val mp_length : module_path -> int
 val prefixes_mp : module_path -> MPset.t
 val modfile_of_mp : module_path -> module_path
-val common_prefix_from_list : module_path -> module_path list -> module_path
+val common_prefix_from_list :
+  module_path -> module_path list -> module_path option
 val add_labels_mp : module_path -> label list -> module_path
 val get_nth_label_mp : int -> module_path -> label
 val labels_of_ref : global_reference -> module_path * label list
@@ -65,14 +70,14 @@ val lookup_term : constant -> ml_decl
 val add_type : constant -> ml_schema -> unit
 val lookup_type : constant -> ml_schema
 
-val add_ind : kernel_name -> mutual_inductive_body -> ml_ind -> unit
-val lookup_ind : kernel_name -> mutual_inductive_body * ml_ind
+val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit
+val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind
 
-val add_recursors : Environ.env -> kernel_name -> unit
-val is_recursor : global_reference -> bool 
+val add_recursors : Environ.env -> mutual_inductive -> unit
+val is_recursor : global_reference -> bool
 
 val add_projection : int -> constant -> unit
-val is_projection : global_reference -> bool 
+val is_projection : global_reference -> bool
 val projection_arity : global_reference -> int
 
 val add_info_axiom : global_reference -> unit
@@ -81,18 +86,18 @@ val add_log_axiom : global_reference -> unit
 
 val reset_tables : unit -> unit
 
-(*s AutoInline parameter *) 
+(*s AutoInline parameter *)
 
 val auto_inline : unit -> bool
 
-(*s TypeExpand parameter *) 
+(*s TypeExpand parameter *)
 
 val type_expand : unit -> bool
 
-(*s Optimize parameter *) 
+(*s Optimize parameter *)
 
-type opt_flag = 
-    { opt_kill_dum : bool; (* 1 *) 
+type opt_flag =
+    { opt_kill_dum : bool; (* 1 *)
       opt_fix_fun : bool;   (* 2 *)
       opt_case_iot : bool;  (* 4 *)
       opt_case_idr : bool;  (* 8 *)
@@ -109,18 +114,22 @@ val optims :  unit -> opt_flag
 (*s Target language. *)
 
 type lang = Ocaml | Haskell | Scheme
-val lang : unit -> lang 
+val lang : unit -> lang
 
 (*s Extraction mode: modular or monolithic *)
 
 val set_modular : bool -> unit
-val modular : unit -> bool 
+val modular : unit -> bool
 
-(*s Table for custom inlining *) 
+(*s Table for custom inlining *)
 
 val to_inline : global_reference -> bool
 val to_keep : global_reference -> bool
 
+(*s Table for implicits arguments *)
+
+val implicits_of_global : global_reference -> int list
+
 (*s Table for user-given custom ML extractions. *)
 
 (* UGLY HACK: registration of a function defined in [extraction.ml] *)
@@ -131,15 +140,22 @@ val is_inline_custom : global_reference -> bool
 val find_custom : global_reference -> string
 val find_type_custom : global_reference -> string list * string
 
+val is_custom_match : ml_branch array -> bool
+val find_custom_match : ml_branch array -> string
+
 (*s Extraction commands. *)
 
 val extraction_language : lang -> unit
 val extraction_inline : bool -> reference list -> unit
 val print_extraction_inline : unit -> unit
 val reset_extraction_inline : unit -> unit
-val extract_constant_inline : 
+val extract_constant_inline :
   bool -> reference -> string list -> string -> unit
-val extract_inductive : reference -> string * string list -> unit
+val extract_inductive :
+  reference -> string -> string list -> string option -> unit
+
+type int_or_id = ArgInt of int | ArgId of identifier
+val extraction_implicit : reference -> int_or_id list -> unit
 
 (*s Table of blacklisted filenames *)
 
diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget
new file mode 100644
index 00000000..1fe09f6f
--- /dev/null
+++ b/plugins/extraction/vo.itarget
@@ -0,0 +1,8 @@
+ExtrOcamlBasic.vo
+ExtrOcamlIntConv.vo
+ExtrOcamlBigIntConv.vo
+ExtrOcamlNatInt.vo
+ExtrOcamlNatBigInt.vo
+ExtrOcamlZInt.vo
+ExtrOcamlZBigInt.vo
+ExtrOcamlString.vo
\ No newline at end of file
diff --git a/contrib/field/LegacyField.v b/plugins/field/LegacyField.v
index 08397d02..efa53b4e 100644
--- a/contrib/field/LegacyField.v
+++ b/plugins/field/LegacyField.v
@@ -6,10 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField.v 9273 2006-10-25 11:30:36Z barras $ *)
+(* $Id$ *)
 
 Require Export LegacyField_Compl.
 Require Export LegacyField_Theory.
 Require Export LegacyField_Tactic.
+Declare ML Module "field_plugin".
 
 (* Command declarations are moved to the ML side *)
diff --git a/contrib/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
index b37281e9..d4a39296 100644
--- a/contrib/field/LegacyField_Compl.v
+++ b/plugins/field/LegacyField_Compl.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *)
+(* $Id$ *)
 
 Require Import List.
 
 Definition assoc_2nd :=
   (fix assoc_2nd_rec (A:Type) (B:Set)
                      (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
-                     (lst:list (prod A B)) {struct lst} : 
+                     (lst:list (prod A B)) {struct lst} :
    B -> A -> A :=
      fun (key:B) (default:A) =>
        match lst with
@@ -26,7 +26,7 @@ Definition assoc_2nd :=
        end).
 
 Definition mem :=
-  (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) 
+  (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2})
            (a:A) (l:list A) {struct l} : bool :=
      match l with
      | nil => false
diff --git a/contrib/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
index 2b6ff5b4..5c1f228a 100644
--- a/contrib/field/LegacyField_Tactic.v
+++ b/plugins/field/LegacyField_Tactic.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *)
+(* $Id$ *)
 
 Require Import List.
 Require Import LegacyRing.
@@ -29,17 +29,17 @@ Ltac mem_assoc var lvar :=
       end
   end.
 
-Ltac number lvar := 
+Ltac number lvar :=
   let rec number_aux lvar cpt :=
     match constr:lvar with
     | (@nil ?X1) => constr:(@nil (prod X1 nat))
     | ?X2 :: ?X3 =>
         let l2 := number_aux X3 (S cpt) in
-        constr:((X2,cpt) :: l2) 
+        constr:((X2,cpt) :: l2)
     end
   in number_aux lvar 0.
 
-Ltac build_varlist FT trm := 
+Ltac build_varlist FT trm :=
   let rec seek_var lvar trm :=
     let AT := get_component A FT
     with AzeroT := get_component Azero FT
@@ -244,11 +244,11 @@ Ltac inverse_test FT :=
 
 Ltac apply_simplif sfun :=
   match goal with
-  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => 
+  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) =>
   sfun X1 X2 X3
   end;
    match goal with
-   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => 
+   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) =>
    sfun X1 X2 X3
    end.
 
diff --git a/contrib/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
index 9c3a12fb..cc8b043f 100644
--- a/contrib/field/LegacyField_Theory.v
+++ b/plugins/field/LegacyField_Theory.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *)
+(* $Id$ *)
 
 Require Import List.
 Require Import Peano_dec.
 Require Import LegacyRing.
 Require Import LegacyField_Compl.
 
-Record Field_Theory : Type := 
+Record Field_Theory : Type :=
   {A : Type;
    Aplus : A -> A -> A;
    Amult : A -> A -> A;
@@ -59,7 +59,7 @@ Proof.
   right; red in |- *; intro; inversion H1; auto.
   elim (eq_nat_dec n n0); intro y.
   left; rewrite y; auto.
-  right; red in |- *; intro; inversion H; auto. 
+  right; red in |- *; intro; inversion H; auto.
 Defined.
 
 Definition eq_nat_dec := Eval compute in eq_nat_dec.
@@ -149,7 +149,7 @@ Proof.
   repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
   legacy ring.
 Qed.
- 
+
 Lemma r_AmultT_mult :
  forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
 Proof.
@@ -164,22 +164,22 @@ Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
 Proof.
   intro; legacy ring.
 Qed.
- 
+
 Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
 Proof.
   intro; legacy ring.
 Qed.
- 
+
 Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
 Proof.
   intro; legacy ring.
 Qed.
- 
+
 Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
 Proof.
   intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
 Qed.
- 
+
 Lemma Rmult_neq_0_reg :
  forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
 Proof.
@@ -298,7 +298,7 @@ Lemma assoc_mult_correct1 :
 Proof.
 simple induction e1; auto; intros.
 rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
- simpl in |- *; rewrite merge_mult_correct; simpl in |- *; 
+ simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
  auto.
 Qed.
 
@@ -318,7 +318,7 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
  rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
  fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
  rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
- rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; 
+ rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc;
  legacy ring.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
@@ -365,7 +365,7 @@ Lemma assoc_plus_correct :
 Proof.
 simple induction e1; auto; intros.
 rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
- simpl in |- *; rewrite merge_plus_correct; simpl in |- *; 
+ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
  auto.
 Qed.
 
@@ -388,7 +388,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
         (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
  rewrite
   (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
-  ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; 
+  ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *;
  rewrite (H0 lvar);
  rewrite <-
   (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
@@ -402,13 +402,13 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
   (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
      (interp_ExprA lvar e1)); apply AplusT_comm.
 unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
- fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
+ fold interp_ExprA in |- *; rewrite assoc_mult_correct;
  rewrite (H0 lvar); simpl in |- *; auto.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
 unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
- fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
+ fold interp_ExprA in |- *; rewrite assoc_mult_correct;
  simpl in |- *; auto.
 Qed.
 
@@ -466,7 +466,7 @@ Proof.
 simple induction e1; try intros; simpl in |- *.
 rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
  apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. 
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
 rewrite AmultT_comm;
  rewrite
   (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
@@ -602,7 +602,7 @@ simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
 unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
 case (eqExprA e0 a); intros.
 rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto.
-inversion e1; simpl in |- *; elimtype False; auto.
+inversion e1; simpl in |- *; exfalso; auto.
 simpl in |- *; trivial.
 unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
  [ inversion e0 | simpl in |- *; trivial ].
@@ -629,7 +629,7 @@ Lemma monom_simplif_correct :
 Proof.
 simple induction e; intros; auto.
 simpl in |- *; case (eqExprA a e0); intros.
-rewrite <- e2; apply monom_simplif_rem_correct; auto. 
+rewrite <- e2; apply monom_simplif_rem_correct; auto.
 simpl in |- *; trivial.
 Qed.
 
diff --git a/contrib/field/field.ml4 b/plugins/field/field.ml4
index dea79773..238b4c1e 100644
--- a/contrib/field/field.ml4
+++ b/plugins/field/field.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: field.ml4 10076 2007-08-16 11:16:43Z notin $ *)
+(* $Id$ *)
 
 open Names
 open Pp
@@ -44,30 +44,27 @@ let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
 
 let lookup env typ =
   try Gmap.find typ !th_tab
-  with Not_found -> 
+  with Not_found ->
     errorlabstrm "field"
       (str "No field is declared for type" ++ spc() ++
       Printer.pr_lconstr_env env typ)
 
-let _ = 
+let _ =
   let init () = th_tab := Gmap.empty in
   let freeze () = !th_tab in
   let unfreeze fs = th_tab := fs in
   Summary.declare_summary "field"
     { Summary.freeze_function   = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init;
-      Summary.survive_module = false;
-      Summary.survive_section   = false }
+      Summary.init_function     = init }
 
 let load_addfield _ = ()
 let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab
-let subst_addfield (_,subst,(typ,th as obj)) =
+let subst_addfield (subst,(typ,th as obj)) =
   let typ' = subst_mps subst typ in
   let th' = subst_mps subst th in
     if typ' == typ && th' == th then obj else
       (typ',th')
-let export_addfield x = Some x
 
 (* Declaration of the Add Field library object *)
 let (in_addfield,out_addfield)=
@@ -75,8 +72,7 @@ let (in_addfield,out_addfield)=
        Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
        Libobject.cache_function = cache_addfield;
        Libobject.subst_function = subst_addfield;
-       Libobject.classify_function = (fun (_,a) -> Libobject.Substitute a);
-       Libobject.export_function = export_addfield }
+       Libobject.classify_function = (fun a -> Libobject.Substitute a)}
 
 (* Adds a theory to the table *)
 let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
@@ -118,7 +114,7 @@ END
 
 (* For the translator, otherwise the code above is OK *)
 open Ppconstr
-let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = 
+let pp_minus_div_arg _prc _prlc _prt (omin,odiv) =
   if omin=None && odiv=None then mt() else
     spc() ++ str "with" ++
     pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
@@ -130,7 +126,7 @@ let () =
     (globwit_minus_div_arg,pp_minus_div_arg)
     (wit_minus_div_arg,pp_minus_div_arg)
 *)
-ARGUMENT EXTEND minus_div_arg 
+ARGUMENT EXTEND minus_div_arg
   TYPED AS constr_opt * constr_opt
   PRINTED BY pp_minus_div_arg
 | [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
@@ -139,7 +135,7 @@ ARGUMENT EXTEND minus_div_arg
 END
 
 VERNAC COMMAND EXTEND Field
-  [ "Add" "Legacy" "Field" 
+  [ "Add" "Legacy" "Field"
       constr(a) constr(aplus) constr(amult) constr(aone)
       constr(azero) constr(aopp) constr(aeq)
       constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
@@ -154,11 +150,13 @@ END
 (* Guesses the type and calls field_gen with the right theory *)
 let field g =
   Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let typ = 
-    match Hipattern.match_with_equation (pf_concl g) with
-      | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t
-      | _ -> error "The statement is not built from Leibniz' equality" in
-  let th = VConstr (lookup (pf_env g) typ) in
+  let typ =
+    try match Hipattern.match_with_equation (pf_concl g) with
+      | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t
+      | _ -> raise Exit
+    with Hipattern.NoEquationFound | Exit ->
+      error "The statement is not built from Leibniz' equality" in
+  let th = VConstr ([],lookup (pf_env g) typ) in
   (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ())
     <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
 
@@ -178,8 +176,8 @@ let field_term l g =
   Coqlib.check_required_library ["Coq";"field";"LegacyField"];
   let env = (pf_env g)
   and evc = (project g) in
-  let th = valueIn (VConstr (guess_theory env evc l))
-  and nl = List.map (fun x -> valueIn (VConstr x)) (Quote.sort_subterm g l) in
+  let th = valueIn (VConstr ([],guess_theory env evc l))
+  and nl = List.map (fun x -> valueIn (VConstr ([],x))) (Quote.sort_subterm g l) in
   (List.fold_right
     (fun c a ->
      let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in
diff --git a/plugins/field/field_plugin.mllib b/plugins/field/field_plugin.mllib
new file mode 100644
index 00000000..3c3e87af
--- /dev/null
+++ b/plugins/field/field_plugin.mllib
@@ -0,0 +1,2 @@
+Field
+Field_plugin_mod
diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget
new file mode 100644
index 00000000..22b56f33
--- /dev/null
+++ b/plugins/field/vo.itarget
@@ -0,0 +1,4 @@
+LegacyField_Compl.vo
+LegacyField_Tactic.vo
+LegacyField_Theory.vo
+LegacyField.vo
diff --git a/contrib/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 3e49cd9c..45365cb2 100644
--- a/contrib/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
+(* $Id$ *)
 
 open Hipattern
 open Names
@@ -41,24 +41,24 @@ let meta_succ m = m+1
 
 let rec nb_prod_after n c=
   match kind_of_term c with
-    | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 
+    | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else
 	1+(nb_prod_after 0 b)
     | _ -> 0
 
 let construct_nhyps ind gls =
   let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
-  let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in 
-  let hyp = nb_prod_after nparams in	
+  let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in
+  let hyp = nb_prod_after nparams in
     Array.map hyp constr_types
 
 (* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
-let ind_hyps nevar ind largs gls= 
-  let types= Inductiveops.arities_of_constructors (pf_env gls) ind in 
-  let lp=Array.length types in     
+let ind_hyps nevar ind largs gls=
+  let types= Inductiveops.arities_of_constructors (pf_env gls) ind in
+  let lp=Array.length types in
   let myhyps i=
     let t1=Term.prod_applist types.(i) largs in
-    let t2=snd (Sign.decompose_prod_n_assum nevar t1) in
-      fst (Sign.decompose_prod_assum t2) in
+    let t2=snd (decompose_prod_n_assum nevar t1) in
+      fst (decompose_prod_assum t2) in
     Array.init lp myhyps
 
 let special_nf gl=
@@ -77,7 +77,7 @@ type kind_of_formula=
   | Exists of inductive*constr list
   | Forall of constr*constr
   | Atom of constr
-      
+
 let rec kind_of_formula gl term =
   let normalize=special_nf gl in
   let cciterm=special_whd gl term in
@@ -86,34 +86,34 @@ let rec kind_of_formula gl term =
       |_->
 	 match match_with_forall_term cciterm with
 	     Some (_,a,b)-> Forall(a,b)
-	   |_-> 
+	   |_->
 	      match match_with_nodep_ind cciterm with
 		  Some (i,l,n)->
 		    let ind=destInd i in
 		    let (mib,mip) = Global.lookup_inductive ind in
 		    let nconstr=Array.length mip.mind_consnames in
-		      if nconstr=0 then 
+		      if nconstr=0 then
 			False(ind,l)
 		      else
 			let has_realargs=(n>0) in
 			let is_trivial=
 			  let is_constant c =
-			    nb_prod c = mib.mind_nparams in  
-			    array_exists is_constant mip.mind_nf_lc in 
+			    nb_prod c = mib.mind_nparams in
+			    array_exists is_constant mip.mind_nf_lc in
 			  if Inductiveops.mis_is_recursive (ind,mib,mip) ||
 			    (has_realargs && not is_trivial)
 			  then
-			    Atom cciterm 
+			    Atom cciterm
 			  else
 			    if nconstr=1 then
 			      And(ind,l,is_trivial)
-			    else 
-			      Or(ind,l,is_trivial) 
-		| _ ->  
+			    else
+			      Or(ind,l,is_trivial)
+		| _ ->
 		    match match_with_sigma_type cciterm with
 			Some (i,l)-> Exists((destInd i),l)
 		      |_-> Atom (normalize cciterm)
-  
+
 type atoms = {positive:constr list;negative:constr list}
 
 type side = Hyp | Concl | Hint
@@ -126,7 +126,7 @@ let build_atoms gl metagen side cciterm =
   let trivial =ref false
   and positive=ref []
   and negative=ref [] in
-  let normalize=special_nf gl in 
+  let normalize=special_nf gl in
   let rec build_rec env polarity cciterm=
     match kind_of_formula gl cciterm with
 	False(_,_)->if not polarity then trivial:=true
@@ -134,12 +134,12 @@ let build_atoms gl metagen side cciterm =
 	  build_rec env (not polarity) a;
 	  build_rec env polarity b
       | And(i,l,b) | Or(i,l,b)->
-	  if b then 
+	  if b then
 	    begin
 	      let unsigned=normalize (substnl env 0 cciterm) in
-		if polarity then 
-		  positive:= unsigned :: !positive 
-		else 
+		if polarity then
+		  positive:= unsigned :: !positive
+		else
 		  negative:= unsigned :: !negative
 	    end;
 	  let v = ind_hyps 0 i l gl in
@@ -148,9 +148,9 @@ let build_atoms gl metagen side cciterm =
 	  let f l =
 	    list_fold_left_i g (1-(List.length l)) () l in
 	    if polarity && (* we have a constant constructor *)
-	      array_exists (function []->true|_->false) v 
+	      array_exists (function []->true|_->false) v
 	    then trivial:=true;
-	    Array.iter f v 
+	    Array.iter f v
       | Exists(i,l)->
 	  let var=mkMeta (metagen true) in
 	  let v =(ind_hyps 1 i l gl).(0) in
@@ -163,15 +163,15 @@ let build_atoms gl metagen side cciterm =
       | Atom t->
 	  let unsigned=substnl env 0 t in
 	    if not (isMeta unsigned) then (* discarding wildcard atoms *)
-	      if polarity then 
-		positive:= unsigned :: !positive 
-	      else 
+	      if polarity then
+		positive:= unsigned :: !positive
+	      else
 		negative:= unsigned :: !negative in
     begin
       match side with
 	  Concl    -> build_rec [] true cciterm
 	| Hyp      -> build_rec [] false cciterm
-	| Hint     -> 
+	| Hint     ->
 	    let rels,head=decompose_prod cciterm in
 	    let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in
 	      build_rec env false head;trivial:=false (* special for hints *)
@@ -179,15 +179,15 @@ let build_atoms gl metagen side cciterm =
     (!trivial,
      {positive= !positive;
       negative= !negative})
-    
+
 type right_pattern =
     Rarrow
   | Rand
-  | Ror 
+  | Ror
   | Rfalse
   | Rforall
   | Rexists of metavariable*constr*bool
-   
+
 type left_arrow_pattern=
     LLatom
   | LLfalse of inductive*constr list
@@ -198,9 +198,9 @@ type left_arrow_pattern=
   | LLarrow of constr*constr*constr
 
 type left_pattern=
-    Lfalse    
+    Lfalse
   | Land of inductive
-  | Lor of inductive 
+  | Lor of inductive
   | Lforall of metavariable*constr*bool
   | Lexists of inductive
   | LA of constr*left_arrow_pattern
@@ -209,14 +209,14 @@ type t={id:global_reference;
 	constr:constr;
 	pat:(left_pattern,right_pattern) sum;
 	atoms:atoms}
-    
+
 let build_formula side nam typ gl metagen=
   let normalize = special_nf gl in
-    try 
+    try
       let m=meta_succ(metagen false) in
       let trivial,atoms=
-	if !qflag then 
-	  build_atoms gl metagen side typ 
+	if !qflag then
+	  build_atoms gl metagen side typ
 	else no_atoms in
       let pattern=
 	match side with
@@ -227,10 +227,10 @@ let build_formula side nam typ gl metagen=
 		  | Atom a       -> raise (Is_atom a)
 		  | And(_,_,_)        -> Rand
 		  | Or(_,_,_)         -> Ror
-		  | Exists (i,l) -> 
+		  | Exists (i,l) ->
 		      let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in
 			Rexists(m,d,trivial)
-		  | Forall (_,a) -> Rforall 
+		  | Forall (_,a) -> Rforall
 		  | Arrow (a,b) -> Rarrow in
 		Right pat
 	  | _ ->
@@ -238,7 +238,7 @@ let build_formula side nam typ gl metagen=
 		match kind_of_formula gl typ with
 		    False(i,_)        ->  Lfalse
 		  | Atom a       ->  raise (Is_atom a)
-		  | And(i,_,b)         ->  
+		  | And(i,_,b)         ->
 		      if b then
 			let nftyp=normalize typ in raise (Is_atom nftyp)
 		      else Land i
@@ -246,12 +246,12 @@ let build_formula side nam typ gl metagen=
 		      if b then
 			let nftyp=normalize typ in raise (Is_atom nftyp)
 		      else Lor i
-		  | Exists (ind,_) ->  Lexists ind 
-		  | Forall (d,_) -> 
+		  | Exists (ind,_) ->  Lexists ind
+		  | Forall (d,_) ->
 		      Lforall(m,d,trivial)
 		  | Arrow (a,b) ->
 		      let nfa=normalize a in
-			LA (nfa, 
+			LA (nfa,
 			    match kind_of_formula gl a with
 				False(i,l)-> LLfalse(i,l)
 			      | Atom t->     LLatom
diff --git a/contrib/firstorder/formula.mli b/plugins/firstorder/formula.mli
index 8703045c..2e89ddb0 100644
--- a/contrib/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Term
 open Names
@@ -16,10 +16,10 @@ val qflag : bool ref
 
 val red_flags: Closure.RedFlags.reds ref
 
-val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> 
+val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) ->
   'a -> 'a -> 'b -> 'b -> int
-  
-val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 
+
+val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) ->
   'a -> 'a -> 'b -> 'b -> 'c ->'c -> int
 
 type ('a,'b) sum = Left of 'a | Right of 'b
@@ -28,26 +28,26 @@ type counter = bool -> metavariable
 
 val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array
 
-val ind_hyps : int -> inductive -> constr list -> 
-  Proof_type.goal Tacmach.sigma -> Sign.rel_context array
+val ind_hyps : int -> inductive -> constr list ->
+  Proof_type.goal Tacmach.sigma -> rel_context array
 
 type atoms = {positive:constr list;negative:constr list}
 
 type side = Hyp | Concl | Hint
 
 val dummy_id: global_reference
-			
-val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> 
+
+val build_atoms : Proof_type.goal Tacmach.sigma -> counter ->
   side -> constr -> bool * atoms
 
 type right_pattern =
     Rarrow
   | Rand
-  | Ror 
+  | Ror
   | Rfalse
   | Rforall
   | Rexists of metavariable*constr*bool
-    
+
 type left_arrow_pattern=
     LLatom
   | LLfalse of inductive*constr list
@@ -58,20 +58,20 @@ type left_arrow_pattern=
   | LLarrow of constr*constr*constr
 
 type left_pattern=
-    Lfalse    
+    Lfalse
   | Land of inductive
-  | Lor of inductive 
+  | Lor of inductive
   | Lforall of metavariable*constr*bool
   | Lexists of inductive
   | LA of constr*left_arrow_pattern
-      
+
 type t={id: global_reference;
 	constr: constr;
 	pat: (left_pattern,right_pattern) sum;
 	atoms: atoms}
-    
+
 (*exception Is_atom of constr*)
 
-val build_formula : side -> global_reference -> types -> 
+val build_formula : side -> global_reference -> types ->
   Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum
 
diff --git a/contrib/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index f7b0a546..9080e7db 100644
--- a/contrib/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
-(* $Id: g_ground.ml4 10346 2007-12-05 21:11:19Z aspiwack $ *)
+(* $Id$ *)
 
 open Formula
 open Sequent
@@ -30,10 +30,10 @@ let _=
   let gdopt=
     { optsync=true;
       optname="Firstorder Depth";
-      optkey=SecondaryTable("Firstorder","Depth"); 
-      optread=(fun ()->Some !ground_depth); 
+      optkey=["Firstorder";"Depth"];
+      optread=(fun ()->Some !ground_depth);
       optwrite=
-   (function 
+   (function
 	None->ground_depth:=3
       |	Some i->ground_depth:=(max i 0))}
   in
@@ -45,10 +45,10 @@ let _=
   let gdopt=
     { optsync=true;
       optname="Congruence Depth";
-      optkey=SecondaryTable("Congruence","Depth"); 
-      optread=(fun ()->Some !congruence_depth); 
+      optkey=["Congruence";"Depth"];
+      optread=(fun ()->Some !congruence_depth);
       optwrite=
-   (function 
+   (function
 	None->congruence_depth:=0
       |	Some i->congruence_depth:=(max i 0))}
   in
@@ -57,30 +57,23 @@ let _=
 let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
 
 let fail_solver=tclFAIL 0 (Pp.str "GTauto failed")
-		      
-type external_env=
-    Ids of global_reference list
-  | Bases of Auto.hint_db_name list
-  | Void
 
-let gen_ground_tac flag taco ext gl=
+let gen_ground_tac flag taco ids bases gl=
   let backup= !qflag in
     try
       qflag:=flag;
-      let solver= 
-	match taco with 
+      let solver=
+	match taco with
 	    Some tac-> tac
 	  | None-> default_solver in
-      let startseq=
-	match ext with
-	    Void -> (fun gl -> empty_seq !ground_depth)
-	  | Ids l-> create_with_ref_list l !ground_depth
-	  | Bases l-> create_with_auto_hints l !ground_depth in
-      let result=ground_tac solver startseq gl in 
+      let startseq gl=
+	let seq=empty_seq !ground_depth in
+	extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in
+      let result=ground_tac solver startseq gl in
 	qflag:=backup;result
     with e ->qflag:=backup;raise e
-      
-(* special for compatibility with Intuition 
+
+(* special for compatibility with Intuition
 
 let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
 
@@ -89,40 +82,67 @@ let defined_connectives=lazy
    [],EvalConstRef (destConst (constant "iff"))]
 
 let normalize_evaluables=
-  onAllClauses
-    (function 
+  onAllHypsAndConcl
+    (function
 	 None->unfold_in_concl (Lazy.force defined_connectives)
-       | Some id-> 
-	   unfold_in_hyp (Lazy.force defined_connectives) 
+       | Some id->
+	   unfold_in_hyp (Lazy.force defined_connectives)
 	   (Tacexpr.InHypType id)) *)
 
+open Genarg
+open Ppconstr
+open Printer
+let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference
+let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global))
+let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global
+
+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
+  GLOB_TYPED AS reference_list
+  GLOB_PRINTED BY pr_firstorder_using_glob
+| [ "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");
+    a::b::l
+  ]
+| [ ] -> [ [] ]
+END
+
 TACTIC EXTEND firstorder
-    [ "firstorder" tactic_opt(t) "using" ne_reference_list(l) ] -> 
-      [ gen_ground_tac true (Option.map eval_tactic t) (Ids l) ]
-|   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> 
-      [ gen_ground_tac true (Option.map eval_tactic t) (Bases l) ]
-|   [ "firstorder" tactic_opt(t) ] -> 
-      [ gen_ground_tac true (Option.map eval_tactic t) Void ]
+    [ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) l [] ]
+|   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) [] l ]
+|   [ "firstorder" tactic_opt(t) firstorder_using(l)
+       "with" ne_preident_list(l') ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) l l' ]
+|   [ "firstorder" tactic_opt(t) ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) [] [] ]
 END
 
 TACTIC EXTEND gintuition
   [ "gintuition" tactic_opt(t) ] ->
-     [ gen_ground_tac false (Option.map eval_tactic t) Void ]
+     [ gen_ground_tac false (Option.map eval_tactic t) [] [] ]
 END
 
 
-let default_declarative_automation gls = 
+let default_declarative_automation gls =
   tclORELSE
-    (tclORELSE (Auto.h_trivial [] None) 
+    (tclORELSE (Auto.h_trivial [] None)
     (Cctac.congruence_tac !congruence_depth []))
-    (gen_ground_tac true 
+    (gen_ground_tac true
        (Some (tclTHEN
 		default_solver
 		(Cctac.congruence_tac !congruence_depth [])))
-       Void) gls
+       [] []) gls
 
 
 
-let () = 
+let () =
   Decl_proof_instr.register_automation_tac default_declarative_automation
 
diff --git a/contrib/firstorder/ground.ml b/plugins/firstorder/ground.ml
index f4661869..8a0f02d2 100644
--- a/contrib/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.ml 9549 2007-01-28 23:30:12Z corbinea $ *)
+(* $Id$ *)
 
 open Formula
 open Sequent
@@ -19,10 +19,10 @@ open Tacticals
 open Libnames
 
 (*
-let old_search=ref !Auto.searchtable 
+let old_search=ref !Auto.searchtable
 
-(* I use this solution as a means to know whether hints have changed, 
-but this prevents the GC from collecting the previous table, 
+(* I use this solution as a means to know whether hints have changed,
+but this prevents the GC from collecting the previous table,
 resulting in some limited space wasting*)
 
 let update_flags ()=
@@ -30,7 +30,7 @@ let update_flags ()=
     begin
       old_search:=!Auto.searchtable;
       let predref=ref Names.KNpred.empty in
-      let f p_a_t = 
+      let f p_a_t =
 	match p_a_t.Auto.code with
 	    Auto.Unfold_nth (ConstRef kn)->
 	      predref:=Names.KNpred.add kn !predref
@@ -39,7 +39,7 @@ let update_flags ()=
       let h _ hdb=Auto.Hint_db.iter g hdb in
 	Util.Stringmap.iter h !Auto.searchtable;
 	red_flags:=
-	Closure.RedFlags.red_add_transparent 
+	Closure.RedFlags.red_add_transparent
 	  Closure.betaiotazeta (Names.Idpred.full,!predref)
     end
 *)
@@ -53,8 +53,8 @@ let update_flags ()=
     with Invalid_argument "destConst"-> () in
     List.iter f (Classops.coercions ());
     red_flags:=
-    Closure.RedFlags.red_add_transparent 
-      Closure.betaiotazeta 
+    Closure.RedFlags.red_add_transparent
+      Closure.betaiotazeta
       (Names.Idpred.full,Names.Cpred.complement !predref)
 
 let ground_tac solver startseq gl=
@@ -64,10 +64,10 @@ let ground_tac solver startseq gl=
     then Pp.msgnl (Printer.pr_goal (sig_it gl));
     tclORELSE (axiom_tac seq.gl seq)
       begin
-	try      
-	  let (hd,seq1)=take_formula seq  
+	try
+	  let (hd,seq1)=take_formula seq
 	  and re_add s=re_add_formula_list skipped s in
-	  let continue=toptac [] 
+	  let continue=toptac []
 	  and backtrack gl=toptac (hd::skipped) seq1 gl in
 	    match hd.pat with
 		Right rpat->
@@ -77,7 +77,7 @@ let ground_tac solver startseq gl=
 			  and_tac backtrack continue (re_add seq1)
 		      | Rforall->
 			  let backtrack1=
-			    if !qflag then 
+			    if !qflag then
 			      tclFAIL 0 (Pp.str "reversible in 1st order mode")
 			    else
 			      backtrack in
@@ -86,12 +86,12 @@ let ground_tac solver startseq gl=
 			  arrow_tac backtrack continue (re_add seq1)
 		      | Ror->
 			  or_tac  backtrack continue (re_add seq1)
-		      | Rfalse->backtrack 
+		      | Rfalse->backtrack
 		      | Rexists(i,dom,triv)->
 			  let (lfp,seq2)=collect_quantified seq in
 			  let backtrack2=toptac (lfp@skipped) seq2 in
-			    if  !qflag && seq.depth>0 then 
-			      quantified_tac lfp backtrack2 
+			    if  !qflag && seq.depth>0 then
+			      quantified_tac lfp backtrack2
 				continue (re_add seq)
 			    else
 			      backtrack2 (* need special backtracking *)
@@ -102,21 +102,21 @@ let ground_tac solver startseq gl=
 			Lfalse->
 			  left_false_tac hd.id
 		      | Land ind->
-			  left_and_tac ind backtrack 
+			  left_and_tac ind backtrack
 			  hd.id continue (re_add seq1)
 		      | Lor ind->
-			  left_or_tac ind backtrack 
+			  left_or_tac ind backtrack
 			  hd.id continue (re_add seq1)
 		      | Lforall (_,_,_)->
 			  let (lfp,seq2)=collect_quantified seq in
 			  let backtrack2=toptac (lfp@skipped) seq2 in
-			    if  !qflag && seq.depth>0 then 
-			      quantified_tac lfp backtrack2 
+			    if  !qflag && seq.depth>0 then
+			      quantified_tac lfp backtrack2
 				continue (re_add seq)
 			    else
 			      backtrack2 (* need special backtracking *)
   		      | Lexists ind ->
-			  if !qflag then 
+			  if !qflag then
 			    left_exists_tac ind backtrack hd.id
 			      continue (re_add seq1)
 			  else backtrack
@@ -124,14 +124,14 @@ let ground_tac solver startseq gl=
 			  let la_tac=
 			    begin
 			      match lap with
-				  LLatom -> backtrack 
-				| LLand (ind,largs) | LLor(ind,largs) 
+				  LLatom -> backtrack
+				| LLand (ind,largs) | LLor(ind,largs)
 				| LLfalse (ind,largs)->
-				    (ll_ind_tac ind largs backtrack 
-				       hd.id continue (re_add seq1)) 
-				| LLforall p ->	      
-				    if seq.depth>0 && !qflag then 
-				      (ll_forall_tac p backtrack 
+				    (ll_ind_tac ind largs backtrack
+				       hd.id continue (re_add seq1))
+				| LLforall p ->
+				    if seq.depth>0 && !qflag then
+				      (ll_forall_tac p backtrack
 					 hd.id continue (re_add seq1))
 				    else backtrack
 				| LLexists (ind,l) ->
@@ -140,13 +140,13 @@ let ground_tac solver startseq gl=
 					hd.id continue (re_add seq1)
 				    else
 				      backtrack
-				| LLarrow (a,b,c) ->	      
+				| LLarrow (a,b,c) ->
 				    (ll_arrow_tac a b c backtrack
 				       hd.id continue (re_add seq1))
-			    end in			 
+			    end in
 			    ll_atom_tac typ la_tac hd.id continue (re_add seq1)
 		  end
 	    with Heap.EmptyHeap->solver
       end gl in
     wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl
-      
+
diff --git a/contrib/firstorder/ground.mli b/plugins/firstorder/ground.mli
index 621f99db..3c0e903f 100644
--- a/contrib/firstorder/ground.mli
+++ b/plugins/firstorder/ground.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 val ground_tac:     Tacmach.tactic ->
   (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mllib
new file mode 100644
index 00000000..447a1fb5
--- /dev/null
+++ b/plugins/firstorder/ground_plugin.mllib
@@ -0,0 +1,8 @@
+Formula
+Unify
+Sequent
+Rules
+Instances
+Ground
+G_ground
+Ground_plugin_mod
diff --git a/contrib/firstorder/instances.ml b/plugins/firstorder/instances.ml
index 1432207d..810262a6 100644
--- a/contrib/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.ml 10410 2007-12-31 13:11:55Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Formula
 open Sequent
@@ -37,8 +37,8 @@ let compare_instance inst1 inst2=
 
 let compare_gr id1 id2=
   if id1==id2 then 0 else
-    if id1==dummy_id then 1 
-    else if id2==dummy_id then -1 
+    if id1==dummy_id then 1
+    else if id2==dummy_id then -1
     else Pervasives.compare id1 id2
 
 module OrderedInstance=
@@ -48,7 +48,7 @@ struct
     (compare_instance =? compare_gr) inst2 inst1 id2 id1
     (* we want a __decreasing__ total order *)
 end
-  
+
 module IS=Set.Make(OrderedInstance)
 
 let make_simple_atoms seq=
@@ -62,7 +62,7 @@ let do_sequent setref triv id seq i dom atoms=
   let flag=ref true in
   let phref=ref triv in
   let do_atoms a1 a2 =
-    let do_pair t1 t2 = 
+    let do_pair t1 t2 =
       match unif_atoms i dom t1 t2 with
 	  None->()
 	| Some (Phantom _) ->phref:=true
@@ -71,27 +71,27 @@ let do_sequent setref triv id seq i dom atoms=
       List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in
     HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes;
     do_atoms atoms (make_simple_atoms seq);
-    !flag && !phref 
- 
+    !flag && !phref
+
 let match_one_quantified_hyp setref seq lf=
-  match lf.pat with 
+  match lf.pat with
       Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))->
 	if do_sequent setref triv lf.id seq i dom lf.atoms then
-	  setref:=IS.add ((Phantom dom),lf.id) !setref 
-    | _ ->anomaly "can't happen" 
+	  setref:=IS.add ((Phantom dom),lf.id) !setref
+    | _ ->anomaly "can't happen"
 
 let give_instances lf seq=
   let setref=ref IS.empty in
     List.iter (match_one_quantified_hyp setref seq) lf;
     IS.elements !setref
-	  	  
+
 (* collector for the engine *)
 
 let rec collect_quantified seq=
   try
     let hd,seq1=take_formula seq in
-      (match hd.pat with 
-	   Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> 
+      (match hd.pat with
+	   Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) ->
 	     let (q,seq2)=collect_quantified seq1 in
 	       ((hd::q),seq2)
 	 | _->[],seq)
@@ -109,10 +109,10 @@ let mk_open_instance id gl m t=
   let var_id=
     if id==dummy_id then dummy_bvid else
       let typ=pf_type_of gl (constr_of_global id) in
-	(* since we know we will get a product, 
+	(* since we know we will get a product,
 	   reduction is not too expensive *)
       let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
-	match nam with 
+	match nam with
 	    Name id -> id
 	  | Anonymous ->  dummy_bvid in
   let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in
@@ -123,68 +123,68 @@ let mk_open_instance id gl m t=
   let nt=it_mkLambda_or_LetIn revt (aux m []) in
   let rawt=Detyping.detype false [] [] nt in
   let rec raux n t=
-    if n=0 then t else 
+    if n=0 then t else
       match t with
 	  RLambda(loc,name,k,_,t0)->
 	    let t1=raux (n-1) t0 in
 	      RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1)
 	| _-> anomaly "can't happen" in
-  let ntt=try 
+  let ntt=try
     Pretyping.Default.understand evmap env (raux m rawt)
-  with _ -> 
+  with _ ->
     error "Untypable instance, maybe higher-order non-prenex quantification" in
-    Sign.decompose_lam_n_assum m ntt
+    decompose_lam_n_assum m ntt
 
 (* tactics   *)
 
 let left_instance_tac (inst,id) continue seq=
   match inst with
       Phantom dom->
-	if lookup (id,None) seq then 
+	if lookup (id,None) seq then
 	  tclFAIL 0 (Pp.str "already done")
 	else
-	  tclTHENS (cut dom) 
+	  tclTHENS (cut dom)
 	    [tclTHENLIST
 	       [introf;
-		(fun gls->generalize 
+		(fun gls->generalize
 		   [mkApp(constr_of_global id,
 			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
 		introf;
-		tclSOLVE [wrap 1 false continue 
+		tclSOLVE [wrap 1 false continue
 			    (deepen (record (id,None) seq))]];
 	    tclTRY assumption]
     | Real((m,t) as c,_)->
-	if lookup (id,Some c) seq then 
+	if lookup (id,Some c) seq then
 	  tclFAIL 0 (Pp.str "already done")
-	else 
+	else
 	  let special_generalize=
-	    if m>0 then 
-	      fun gl-> 
+	    if m>0 then
+	      fun gl->
 		let (rc,ot)= mk_open_instance id gl m t in
-		let gt= 
-		  it_mkLambda_or_LetIn 
+		let gt=
+		  it_mkLambda_or_LetIn
 		    (mkApp(constr_of_global id,[|ot|])) rc in
 		  generalize [gt] gl
 	    else
 	      generalize [mkApp(constr_of_global id,[|t|])]
 	  in
-	    tclTHENLIST 
+	    tclTHENLIST
 	      [special_generalize;
-	       introf; 
-	       tclSOLVE 
+	       introf;
+	       tclSOLVE
 		 [wrap 1 false continue (deepen (record (id,Some c) seq))]]
-	      
+
 let right_instance_tac inst continue seq=
   match inst with
       Phantom dom ->
-	tclTHENS (cut dom) 
+	tclTHENS (cut dom)
 	[tclTHENLIST
 	   [introf;
 	    (fun gls->
-	       split (Rawterm.ImplicitBindings 
+	       split (Rawterm.ImplicitBindings
 			[mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
 	    tclSOLVE [wrap 0 true continue (deepen seq)]];
-	 tclTRY assumption] 
+	 tclTRY assumption]
     | Real ((0,t),_) ->
 	(tclTHEN (split (Rawterm.ImplicitBindings [t]))
 	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
@@ -192,7 +192,7 @@ let right_instance_tac inst continue seq=
 	tclFAIL 0 (Pp.str "not implemented ... yet")
 
 let instance_tac inst=
-  if (snd inst)==dummy_id then 
+  if (snd inst)==dummy_id then
     right_instance_tac (fst inst)
   else
     left_instance_tac inst
@@ -203,4 +203,4 @@ let quantified_tac lf backtrack continue seq gl=
       (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts))
       backtrack gl
 
- 
+
diff --git a/contrib/firstorder/instances.mli b/plugins/firstorder/instances.mli
index 7667c89f..95dd22ea 100644
--- a/contrib/firstorder/instances.mli
+++ b/plugins/firstorder/instances.mli
@@ -6,17 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Term
 open Tacmach
 open Names
 open Libnames
 open Rules
-  
+
 val collect_quantified : Sequent.t -> Formula.t list * Sequent.t
 
-val give_instances : Formula.t list -> Sequent.t -> 
+val give_instances : Formula.t list -> Sequent.t ->
   (Unify.instance * global_reference) list
 
 val quantified_tac : Formula.t list -> seqtac with_backtracking
diff --git a/contrib/firstorder/rules.ml b/plugins/firstorder/rules.ml
index cc7b19e0..515efea7 100644
--- a/contrib/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.ml 11512 2008-10-27 12:28:36Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -31,45 +31,45 @@ let wrap n b continue seq gls=
   let nc=pf_hyps gls in
   let env=pf_env gls in
   let rec aux i nc ctx=
-    if i<=0 then seq else 
+    if i<=0 then seq else
       match nc with
 	  []->anomaly "Not the expected number of hyps"
-	| ((id,_,typ) as nd)::q->  
-	    if occur_var env id (pf_concl gls) || 
+	| ((id,_,typ) as nd)::q->
+	    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
   let seq1=aux n nc [] in
-  let seq2=if b then 
+  let seq2=if b then
     add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in
     continue seq2 gls
 
-let id_of_global=function
+let basename_of_global=function
     VarRef id->id
   | _->assert false
 
 let clear_global=function
     VarRef id->clear [id]
   | _->tclIDTAC
-      
+
 
 (* connection rules *)
 
 let axiom_tac t seq=
-  try exact_no_check (constr_of_global (find_left t seq)) 
+  try exact_no_check (constr_of_global (find_left t seq))
   with Not_found->tclFAIL 0 (Pp.str "No axiom link")
 
-let ll_atom_tac a backtrack id continue seq= 
+let ll_atom_tac a backtrack id continue seq=
   tclIFTHENELSE
-    (try 
+    (try
       tclTHENLIST
 	[generalize [mkApp(constr_of_global id,
 			   [|constr_of_global (find_left a seq)|])];
 	 clear_global id;
 	 intro]
     with Not_found->tclFAIL 0 (Pp.str "No link"))
-    (wrap 1 false continue seq) backtrack 
+    (wrap 1 false continue seq) backtrack
 
 (* right connectives rules *)
 
@@ -77,7 +77,7 @@ let and_tac backtrack continue seq=
   tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack
 
 let or_tac backtrack continue seq=
-  tclORELSE 
+  tclORELSE
     (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
     backtrack
 
@@ -89,17 +89,17 @@ let arrow_tac backtrack continue seq=
 (* left connectives rules *)
 
 let left_and_tac ind backtrack id continue seq gls=
- let n=(construct_nhyps ind gls).(0) in  
+ let n=(construct_nhyps ind gls).(0) in
    tclIFTHENELSE
-     (tclTHENLIST 
+     (tclTHENLIST
       [simplest_elim (constr_of_global id);
-       clear_global id; 
+       clear_global id;
        tclDO n intro])
      (wrap n false continue seq)
      backtrack gls
 
 let left_or_tac ind backtrack id continue seq gls=
-  let v=construct_nhyps ind gls in  
+  let v=construct_nhyps ind gls in
   let f n=
     tclTHENLIST
       [clear_global id;
@@ -117,10 +117,10 @@ let left_false_tac id=
 
 (* We use this function for false, and, or, exists *)
 
-let ll_ind_tac ind largs backtrack id continue seq gl= 
+let ll_ind_tac ind largs backtrack id continue seq gl=
      let rcs=ind_hyps 0 ind largs gl in
      let vargs=Array.of_list largs in
-	     (* construire le terme  H->B, le generaliser etc *)   
+	     (* construire le terme  H->B, le generaliser etc *)
      let myterm i=
        let rc=rcs.(i) in
        let p=List.length rc in
@@ -128,11 +128,11 @@ let ll_ind_tac ind largs backtrack id continue seq gl=
        let vars=Array.init p (fun j->mkRel (p-j)) in
        let capply=mkApp ((lift p cstr),vars) in
        let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in
-	 Sign.it_mkLambda_or_LetIn head rc in
+	 it_mkLambda_or_LetIn head rc in
        let lp=Array.length rcs in
        let newhyps=list_tabulate myterm lp in
 	 tclIFTHENELSE
-	   (tclTHENLIST 
+	   (tclTHENLIST
 	      [generalize newhyps;
 	       clear_global id;
 	       tclDO lp intro])
@@ -149,9 +149,9 @@ let ll_arrow_tac a b c backtrack id continue seq=
 	    [introf;
 	     clear_global id;
 	     wrap 1 false continue seq];
-	  tclTHENS (cut cc) 
-            [exact_no_check (constr_of_global id); 
-	     tclTHENLIST 
+	  tclTHENS (cut cc)
+            [exact_no_check (constr_of_global id);
+	     tclTHENLIST
 	       [generalize [d];
 		clear_global id;
 		introf;
@@ -167,21 +167,21 @@ let forall_tac backtrack continue seq=
        (tclORELSE
 	  (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
 	  backtrack))
-    (if !qflag then 
+    (if !qflag then
        tclFAIL 0 (Pp.str "reversible in 1st order mode")
      else
        backtrack)
 
 let left_exists_tac ind backtrack id continue seq gls=
-  let n=(construct_nhyps ind gls).(0) in  
+  let n=(construct_nhyps ind gls).(0) in
     tclIFTHENELSE
       (simplest_elim (constr_of_global id))
       (tclTHENLIST [clear_global id;
                     tclDO n intro;
-                    (wrap (n-1) false continue seq)]) 
-      backtrack 
+                    (wrap (n-1) false continue seq)])
+      backtrack
       gls
-	
+
 let ll_forall_tac prod backtrack id continue seq=
   tclORELSE
     (tclTHENS (cut prod)
@@ -190,7 +190,7 @@ let ll_forall_tac prod backtrack id continue seq=
 	   (fun gls->
 	      let id0=pf_nth_hyp_id gls 1 in
 	      let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in
-		tclTHEN (generalize [term]) (clear [id0]) gls);  
+		tclTHEN (generalize [term]) (clear [id0]) gls);
 	   clear_global id;
 	   intro;
 	   tclCOMPLETE (wrap 1 false continue (deepen seq))];
@@ -208,9 +208,8 @@ let defined_connectives=lazy
    all_occurrences,EvalConstRef (destConst (constant "iff"))]
 
 let normalize_evaluables=
-  onAllClauses
-    (function 
+  onAllHypsAndConcl
+    (function
 	 None->unfold_in_concl (Lazy.force defined_connectives)
-       | Some ((_,id),_)-> 
-	   unfold_in_hyp (Lazy.force defined_connectives) 
-	   ((Rawterm.all_occurrences_expr,id),InHypTypeOnly))
+       | Some id ->
+	   unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))
diff --git a/contrib/firstorder/rules.mli b/plugins/firstorder/rules.mli
index 3798d8d4..fc32621c 100644
--- a/contrib/firstorder/rules.mli
+++ b/plugins/firstorder/rules.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.mli 6141 2004-09-27 14:55:34Z corbinea $ *)
+(* $Id$ *)
 
 open Term
 open Tacmach
@@ -21,7 +21,7 @@ type 'a with_backtracking = tactic -> 'a
 
 val wrap : int -> bool -> seqtac
 
-val id_of_global: global_reference -> identifier
+val basename_of_global: global_reference -> identifier
 
 val clear_global: global_reference -> tactic
 
@@ -49,6 +49,6 @@ val forall_tac : seqtac with_backtracking
 
 val left_exists_tac : inductive -> lseqtac with_backtracking
 
-val ll_forall_tac : types -> lseqtac with_backtracking 
+val ll_forall_tac : types -> lseqtac with_backtracking
 
 val normalize_evaluables : tactic
diff --git a/contrib/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index e931f8fd..685d44a8 100644
--- a/contrib/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
+(* $Id$ *)
 
 open Term
 open Util
@@ -27,7 +27,7 @@ let priority = (* pure heuristics, <=0 for non reversible *)
 	begin
 	  match rf with
 	      Rarrow               -> 100
-	    | Rand                 ->  40 
+	    | Rand                 ->  40
 	    | Ror                  -> -15
 	    | Rfalse               -> -50
 	    | Rforall              -> 100
@@ -38,7 +38,7 @@ let priority = (* pure heuristics, <=0 for non reversible *)
 	    Lfalse                 -> 999
 	  | Land _                 ->  90
 	  | Lor _                  ->  40
-	  | Lforall (_,_,_)        -> -30 
+	  | Lforall (_,_,_)        -> -30
 	  | Lexists _              ->  60
 	  | LA(_,lap) ->
 	      match lap with
@@ -48,7 +48,7 @@ let priority = (* pure heuristics, <=0 for non reversible *)
 		| LLor (_,_)       ->  70
 		| LLforall _       -> -20
 		| LLexists (_,_)   ->  50
-		| LLarrow  (_,_,_) -> -10 
+		| LLarrow  (_,_,_) -> -10
 
 let left_reversible lpat=(priority lpat)>0
 
@@ -71,15 +71,15 @@ let rec compare_list f l1 l2=
     | _,[] -> 1
     | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2
 
-let compare_array f v1 v2=  
+let compare_array f v1 v2=
   let l=Array.length v1 in
   let c=l - Array.length v2 in
     if c=0 then
       let rec comp_aux i=
-	if i<0 then 0 
+	if i<0 then 0
 	else
 	  let ci=f v1.(i) v2.(i) in
-	    if ci=0 then 
+	    if ci=0 then
 	      comp_aux (i-1)
 	    else ci
       in comp_aux (l-1)
@@ -93,16 +93,16 @@ let compare_constr_int f t1 t2 =
     | Sort s1, Sort s2 -> Pervasives.compare s1 s2
     | Cast (c1,_,_), _ -> f c1 t2
     | _, Cast (c2,_,_) -> f t1 c2
-    | Prod (_,t1,c1), Prod (_,t2,c2) 
+    | Prod (_,t1,c1), Prod (_,t2,c2)
     | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
-	(f =? f) t1 t2 c1 c2 
-    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> 
+	(f =? f) t1 t2 c1 c2
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
 	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
     | App (_,_), App (_,_) ->
-	let c1,l1=decompose_app t1 
+	let c1,l1=decompose_app t1
 	and c2,l2=decompose_app t2 in
 	  (f =? (compare_list f)) c1 c2 l1 l2
-    | Evar (e1,l1), Evar (e2,l2) -> 
+    | Evar (e1,l1), Evar (e2,l2) ->
 	((-) =? (compare_array f)) e1 e2 l1 l2
     | Const c1, Const c2 -> Pervasives.compare c1 c2
     | Ind c1, Ind c2 -> Pervasives.compare c1 c2
@@ -119,7 +119,7 @@ let compare_constr_int f t1 t2 =
 
 let rec compare_constr m n=
   compare_constr_int compare_constr m n
-    
+
 module OrderedConstr=
 struct
   type t=constr
@@ -129,13 +129,13 @@ end
 type h_item = global_reference * (int*constr) option
 
 module Hitem=
-struct 
+struct
   type t = h_item
   let compare (id1,co1) (id2,co2)=
-    (Pervasives.compare 
+    (Pervasives.compare
      =? (fun oc1 oc2 ->
-	   match oc1,oc2 with 
-	       Some (m1,c1),Some (m2,c2) -> 
+	   match oc1,oc2 with
+	       Some (m1,c1),Some (m2,c2) ->
 		 ((-) =? OrderedConstr.compare) m1 m2 c1 c2
 	     | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2
 end
@@ -145,16 +145,16 @@ module CM=Map.Make(OrderedConstr)
 module History=Set.Make(Hitem)
 
 let cm_add typ nam cm=
-  try 
+  try
     let l=CM.find typ cm in CM.add typ (nam::l) cm
   with
       Not_found->CM.add typ [nam] cm
-	
+
 let cm_remove typ nam cm=
   try
-    let l=CM.find typ cm in 
+    let l=CM.find typ cm in
     let l0=List.filter (fun id->id<>nam) l in
-      match l0 with 
+      match l0 with
 	  []->CM.remove typ cm
 	| _ ->CM.add typ l0 cm
       with Not_found ->cm
@@ -172,7 +172,7 @@ type t=
      depth:int}
 
 let deepen seq={seq with depth=seq.depth-1}
- 
+
 let record item seq={seq with history=History.add item seq.history}
 
 let lookup item seq=
@@ -192,12 +192,12 @@ let rec add_formula side nam t seq gl=
 	begin
 	  match side with
 	      Concl ->
-		{seq with 
+		{seq with
 		   redexes=HP.add f seq.redexes;
 		   gl=f.constr;
 		   glatom=None}
 	    | _ ->
-		{seq with 
+		{seq with
 		   redexes=HP.add f seq.redexes;
 		   context=cm_add f.constr nam seq.context}
 	end
@@ -206,15 +206,15 @@ let rec add_formula side nam t seq gl=
 	    Concl ->
 	      {seq with gl=t;glatom=Some t}
 	  | _ ->
-	      {seq with 
+	      {seq with
 		 context=cm_add t nam seq.context;
 		 latoms=t::seq.latoms}
-	      
+
 let re_add_formula_list lf seq=
   let do_one f cm=
     if f.id == dummy_id then cm
     else cm_add f.constr f.id cm in
-  {seq with 
+  {seq with
      redexes=List.fold_right HP.add lf seq.redexes;
      context=List.fold_right do_one lf seq.context}
 
@@ -234,17 +234,17 @@ let rec take_formula seq=
   and hp=HP.remove seq.redexes in
     if hd.id == dummy_id then
       let nseq={seq with redexes=hp} in
-	if seq.gl==hd.constr then 
+	if seq.gl==hd.constr then
 	  hd,nseq
 	else
 	  take_formula nseq (* discarding deprecated goal *)
     else
-      hd,{seq with 
+      hd,{seq with
 	    redexes=hp;
 	    context=cm_remove hd.constr hd.id seq.context}
-	
+
 let empty_seq depth=
-  {redexes=HP.empty;   
+  {redexes=HP.empty;
    context=CM.empty;
    latoms=[];
    gl=(mkMeta 1);
@@ -253,23 +253,32 @@ let empty_seq depth=
    history=History.empty;
    depth=depth}
 
-let create_with_ref_list l depth gl=
+let expand_constructor_hints =
+  list_map_append (function
+    | IndRef ind ->
+	list_tabulate (fun i -> ConstructRef (ind,i+1))
+	  (Inductiveops.nconstructors ind)
+    | gr ->
+	[gr])
+
+let extend_with_ref_list l seq gl=
+  let l = expand_constructor_hints l in
   let f gr seq=
-    let c=constr_of_global gr in    
+    let c=constr_of_global gr in
     let typ=(pf_type_of gl c) in
       add_formula Hyp gr typ seq gl in
-    List.fold_right f l (empty_seq depth)
+    List.fold_right f l seq
 
 open Auto
 
-let create_with_auto_hints l depth gl=
-  let seqref=ref (empty_seq depth) in
+let extend_with_auto_hints l seq gl=
+  let seqref=ref seq in
   let f p_a_t =
     match p_a_t.code with
 	Res_pf (c,_) | Give_exact c
       | Res_pf_THEN_trivial_fail (c,_) ->
-	  (try 
-	     let gr=global_of_constr c in 
+	  (try
+	     let gr=global_of_constr c in
 	     let typ=(pf_type_of gl c) in
 	       seqref:=add_formula Hint gr typ !seqref gl
 	   with Not_found->())
@@ -279,7 +288,7 @@ let create_with_auto_hints l depth gl=
     let hdb=
       try
 	searchtable_map dbname
-      with Not_found-> 
+      with Not_found->
 	error ("Firstorder: "^dbname^" : No such Hint database") in
       Hint_db.iter g hdb in
     List.iter h l;
@@ -288,16 +297,16 @@ let create_with_auto_hints l depth gl=
 let print_cmap map=
   let print_entry c l s=
     let xc=Constrextern.extern_constr false (Global.env ()) c in
-      str "| " ++ 
-      Util.prlist Printer.pr_global l ++ 
+      str "| " ++
+      Util.prlist Printer.pr_global l ++
       str " : " ++
-      Ppconstr.pr_constr_expr xc ++ 
-      cut () ++ 
+      Ppconstr.pr_constr_expr xc ++
+      cut () ++
       s in
-    msgnl (v 0 
-	     (str "-----" ++ 
+    msgnl (v 0
+	     (str "-----" ++
 	      cut () ++
 	      CM.fold print_entry map (mt ()) ++
 	      str "-----"))
 
-	
+
diff --git a/contrib/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
index 47fb74c7..ce0eddcc 100644
--- a/contrib/firstorder/sequent.mli
+++ b/plugins/firstorder/sequent.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Term
 open Util
@@ -46,7 +46,7 @@ val record: h_item -> t -> t
 
 val lookup: h_item -> t -> bool
 
-val add_formula : side -> global_reference -> constr -> t -> 
+val add_formula : side -> global_reference -> constr -> t ->
   Proof_type.goal sigma -> t
 
 val re_add_formula_list : Formula.t list -> t -> t
@@ -57,10 +57,10 @@ val take_formula : t -> Formula.t * t
 
 val empty_seq : int -> t
 
-val create_with_ref_list : global_reference list ->
-  int -> Proof_type.goal sigma -> t
+val extend_with_ref_list : global_reference list ->
+  t -> Proof_type.goal sigma -> t
 
-val create_with_auto_hints : Auto.hint_db_name list -> 
-  int -> Proof_type.goal sigma -> t
+val extend_with_auto_hints : Auto.hint_db_name list ->
+  t -> Proof_type.goal sigma -> t
 
-val print_cmap: global_reference list CM.t -> unit 
+val print_cmap: global_reference list CM.t -> unit
diff --git a/contrib/firstorder/unify.ml b/plugins/firstorder/unify.ml
index 27c06f54..e3a4c6a5 100644
--- a/contrib/firstorder/unify.ml
+++ b/plugins/firstorder/unify.ml
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: unify.ml 11897 2009-02-09 19:28:02Z barras $ i*)
+(*i $Id$ i*)
 
 open Util
-open Formula 
+open Formula
 open Tacmach
 open Term
 open Names
@@ -18,73 +18,73 @@ open Reductionops
 
 exception UFAIL of constr*constr
 
-(* 
-   RIGID-only Martelli-Montanari style unification for CLOSED terms 
-   I repeat : t1 and t2 must NOT have ANY free deBruijn                        
-   sigma is kept normal with respect to itself but is lazily applied 
-   to the equation set. Raises UFAIL with a pair of  terms 
+(*
+   RIGID-only Martelli-Montanari style unification for CLOSED terms
+   I repeat : t1 and t2 must NOT have ANY free deBruijn
+   sigma is kept normal with respect to itself but is lazily applied
+   to the equation set. Raises UFAIL with a pair of  terms
 *)
 
-let unif t1 t2= 
-  let bige=Queue.create () 
+let unif t1 t2=
+  let bige=Queue.create ()
   and sigma=ref [] in
   let bind i t=
     sigma:=(i,t)::
       (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in
-  let rec head_reduce t= 
+  let rec head_reduce t=
     (* forbids non-sigma-normal meta in head position*)
     match kind_of_term t with
 	Meta i->
-	  (try 
-	     head_reduce (List.assoc i !sigma) 
+	  (try
+	     head_reduce (List.assoc i !sigma)
 	   with Not_found->t)
-      | _->t in 
+      | _->t in
     Queue.add (t1,t2) bige;
     try while true do
       let t1,t2=Queue.take bige in
-      let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) 
+      let nt1=head_reduce (whd_betaiotazeta Evd.empty t1)
       and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in
 	match (kind_of_term nt1),(kind_of_term nt2) with
-	    Meta i,Meta j-> 
-	      if i<>j then 
+	    Meta i,Meta j->
+	      if i<>j then
 		if i<j then bind j nt1
 		else bind i nt2
 	  | Meta i,_ ->
 	      let t=subst_meta !sigma nt2 in
-		if Intset.is_empty (free_rels t) && 
+		if Intset.is_empty (free_rels t) &&
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
-	  | _,Meta i -> 
+	  | _,Meta i ->
 	      let t=subst_meta !sigma nt1 in
-		if Intset.is_empty (free_rels t) && 
+		if Intset.is_empty (free_rels t) &&
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
 	  | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
- 	  | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige 
+ 	  | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige
 	  | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))->
 	      Queue.add (a,c) bige;Queue.add (pop b,pop d) bige
 	  | Case (_,pa,ca,va),Case (_,pb,cb,vb)->
 	      Queue.add (pa,pb) bige;
 	      Queue.add (ca,cb) bige;
 	      let l=Array.length va in
-		if l<>(Array.length vb) then 
+		if l<>(Array.length vb) then
 		  raise (UFAIL (nt1,nt2))
-		else 
+		else
 		  for i=0 to l-1 do
 		    Queue.add (va.(i),vb.(i)) bige
-		  done	  
+		  done
 	  | App(ha,va),App(hb,vb)->
 	      Queue.add (ha,hb) bige;
 	      let l=Array.length va in
-		if l<>(Array.length vb) then 
+		if l<>(Array.length vb) then
 		  raise (UFAIL (nt1,nt2))
-		else 
+		else
 		  for i=0 to l-1 do
 		    Queue.add (va.(i),vb.(i)) bige
 		  done
 	  | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2))
     done;
-      assert false 
+      assert false
 	(* this place is unreachable but needed for the sake of typing *)
     with Queue.Empty-> !sigma
 
@@ -93,23 +93,23 @@ let value i t=
     if x<0 then y else if y<0 then x else x+y in
   let tref=mkMeta i in
   let rec vaux term=
-    if term=tref then 0 else 
+    if term=tref then 0 else
       let f v t=add v (vaux t) in
       let vr=fold_constr f (-1) term in
 	if vr<0 then -1 else vr+1 in
     vaux t
-	  
+
 type instance=
-    Real of (int*constr)*int 
-  | Phantom of constr 
+    Real of (int*constr)*int
+  | Phantom of constr
 
 let mk_rel_inst t=
   let new_rel=ref 1 in
   let rel_env=ref [] in
   let rec renum_rec d t=
-    match kind_of_term t with 
+    match kind_of_term t with
 	Meta n->
-	  (try 
+	  (try
 	     mkRel (d+(List.assoc n !rel_env))
 	   with Not_found->
 	     let m= !new_rel in
@@ -117,18 +117,18 @@ let mk_rel_inst t=
 	       rel_env:=(n,m) :: !rel_env;
 	       mkRel (m+d))
       | _ -> map_constr_with_binders succ renum_rec d t
-  in 
+  in
   let nt=renum_rec 0 t in (!new_rel - 1,nt)
 
 let unif_atoms i dom t1 t2=
-  try 
-    let t=List.assoc i (unif t1 t2) in 
+  try
+    let t=List.assoc i (unif t1 t2) in
       if isMeta t then Some (Phantom dom)
       else Some (Real(mk_rel_inst t,value i t1))
   with
       UFAIL(_,_) ->None
     | Not_found ->Some (Phantom dom)
-	   	  
+
 let renum_metas_from k n t= (* requires n = max (free_rels t) *)
   let l=list_tabulate (fun i->mkMeta (k+i)) n in
     substl l t
@@ -136,7 +136,7 @@ let renum_metas_from k n t= (* requires n = max (free_rels t) *)
 let more_general (m1,t1) (m2,t2)=
   let mt1=renum_metas_from 0 m1 t1
   and mt2=renum_metas_from m1 m2 t2 in
-    try 
+    try
       let sigma=unif mt1 mt2 in
       let p (n,t)= n<m1 || isMeta t in
 	List.for_all p sigma
diff --git a/contrib/firstorder/unify.mli b/plugins/firstorder/unify.mli
index 9fbe3dda..d6cb3a08 100644
--- a/contrib/firstorder/unify.mli
+++ b/plugins/firstorder/unify.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: unify.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Term
 
diff --git a/contrib/fourier/Fourier.v b/plugins/fourier/Fourier.v
index 024aa1c3..07b2973a 100644
--- a/contrib/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -6,13 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier.v 11672 2008-12-12 14:45:09Z herbelin $ *)
+(* $Id$ *)
 
 (* "Fourier's method to solve linear inequations/equations systems.".*)
 
-Require Export Fourier_util.
+Require Export LegacyRing.
 Require Export LegacyField.
 Require Export DiscrR.
+Require Export Fourier_util.
+Declare ML Module "fourier_plugin".
 
 Ltac fourier := abstract (fourierz; field; discrR).
 
diff --git a/contrib/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index 6a9ab051..0fd92d60 100644
--- a/contrib/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -6,23 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier_util.v 10710 2008-03-23 09:24:09Z herbelin $ *)
+(* $Id$ *)
 
 Require Export Rbase.
 Comments "Lemmas used by the tactic Fourier".
 
 Open Scope R_scope.
- 
+
 Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
 intros; apply Rmult_lt_compat_l; assumption.
 Qed.
- 
+
 Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
 red in |- *.
 intros.
 case H; auto with real.
 Qed.
- 
+
 Lemma Rfourier_lt_lt :
  forall x1 y1 x2 y2 a:R,
    x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
@@ -33,7 +33,7 @@ apply Rfourier_lt.
 try exact H0.
 try exact H1.
 Qed.
- 
+
 Lemma Rfourier_lt_le :
  forall x1 y1 x2 y2 a:R,
    x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
@@ -48,7 +48,7 @@ rewrite (Rplus_comm x1 (a * y2)).
 apply Rplus_lt_compat_l.
 try exact H.
 Qed.
- 
+
 Lemma Rfourier_le_lt :
  forall x1 y1 x2 y2 a:R,
    x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
@@ -59,7 +59,7 @@ rewrite H2.
 apply Rplus_lt_compat_l.
 apply Rfourier_lt; auto with real.
 Qed.
- 
+
 Lemma Rfourier_le_le :
  forall x1 y1 x2 y2 a:R,
    x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
@@ -81,25 +81,25 @@ red in |- *.
 right; try assumption.
 auto with real.
 Qed.
- 
+
 Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
 intros x H; try assumption.
 rewrite Rplus_comm.
 apply Rle_lt_0_plus_1.
 red in |- *; auto with real.
 Qed.
- 
+
 Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
 intros x y H H0; try assumption.
 replace 0 with (x * 0).
 apply Rmult_lt_compat_l; auto with real.
 ring.
 Qed.
- 
+
 Lemma Rlt_zero_1 : 0 < 1.
 exact Rlt_0_1.
 Qed.
- 
+
 Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
 intros x H; try assumption.
 case H; intros.
@@ -112,7 +112,7 @@ red in |- *; left.
 exact Rlt_zero_1.
 ring.
 Qed.
- 
+
 Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
 intros x y H H0; try assumption.
 case H; intros.
@@ -121,12 +121,12 @@ apply Rlt_mult_inv_pos; auto with real.
 rewrite <- H1.
 red in |- *; right; ring.
 Qed.
- 
+
 Lemma Rle_zero_1 : 0 <= 1.
 red in |- *; left.
 exact Rlt_zero_1.
 Qed.
- 
+
 Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
 intros n d H; red in |- *; intros H0; try exact H0.
 generalize (Rgt_not_le 0 (n * / d)).
@@ -144,14 +144,14 @@ ring.
 ring.
 ring.
 Qed.
- 
+
 Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x.
 intros x; try assumption.
 replace (0 * x) with 0.
 apply Rlt_irrefl.
 ring.
 Qed.
- 
+
 Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
 intros n d H; try assumption.
 apply Rgt_not_le.
@@ -162,7 +162,7 @@ try exact H.
 ring.
 ring.
 Qed.
- 
+
 Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
 unfold not in |- *; intros.
 apply H.
@@ -173,7 +173,7 @@ try exact H0.
 ring.
 ring.
 Qed.
- 
+
 Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
 unfold not in |- *; intros.
 apply H.
@@ -188,35 +188,35 @@ ring.
 right.
 rewrite H1; ring.
 Qed.
- 
+
 Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
 unfold Rgt in |- *; intros; assumption.
 Qed.
- 
+
 Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
 intros x y; exact (Rge_le y x).
 Qed.
- 
+
 Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y.
 exact Req_le.
 Qed.
- 
+
 Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y.
 exact Req_le_sym.
 Qed.
- 
+
 Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y.
 exact Rnot_ge_lt.
 Qed.
- 
+
 Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y.
 exact Rnot_gt_le.
 Qed.
- 
+
 Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y.
 exact Rnot_le_lt.
 Qed.
- 
+
 Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y.
 exact Rnot_lt_ge.
 Qed.
diff --git a/contrib/fourier/fourier.ml b/plugins/fourier/fourier.ml
index 195d8605..73fb4929 100644
--- a/contrib/fourier/fourier.ml
+++ b/plugins/fourier/fourier.ml
@@ -6,22 +6,22 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourier.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
+(* $Id$ *)
 
 (* Méthode d'élimination de Fourier *)
 (* Référence:
 Auteur(s) : Fourier, Jean-Baptiste-Joseph
- 
+
 Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
- 
+
 Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
- 
+
 Pages: 326-327
 
 http://gallica.bnf.fr/
 *)
 
-(* Un peu de calcul sur les rationnels... 
+(* Un peu de calcul sur les rationnels...
 Les opérations rendent des rationnels normalisés,
 i.e. le numérateur et le dénominateur sont premiers entre eux.
 *)
@@ -45,7 +45,7 @@ let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
               else (let d=pgcd x.num x.den in
 		    let d= (if d<0 then -d else d) in
                     {num=(x.num)/d;den=(x.den)/d});;
- 
+
 let rop x = rnorm {num=(-x.num);den=x.den};;
 
 let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
@@ -72,7 +72,7 @@ type ineq = {coef:rational list;
 
 let pop x l = l:=x::(!l);;
 
-(* sépare la liste d'inéquations s selon que leur premier coefficient est 
+(* sépare la liste d'inéquations s selon que leur premier coefficient est
 négatif, nul ou positif. *)
 let partitionne s =
    let lpos=ref [] in
@@ -98,7 +98,7 @@ let partitionne s =
 let add_hist le =
    let n = List.length le in
    let i=ref 0 in
-   List.map (fun (ie,s) -> 
+   List.map (fun (ie,s) ->
               let h =ref [] in
               for k=1 to (n-(!i)-1) do pop r0 h; done;
               pop r1 h;
@@ -107,7 +107,7 @@ let add_hist le =
               {coef=ie;hist=(!h);strict=s})
              le
 ;;
-(* additionne deux inéquations *)      
+(* additionne deux inéquations *)
 let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
                       hist=List.map2 rplus ie1.hist ie2.hist;
 		      strict=ie1.strict || ie2.strict}
@@ -142,7 +142,7 @@ let deduce_add lneg lpos =
 opération qu'on itère dans l'algorithme de Fourier.
 *)
 let deduce1 s =
-    match (partitionne s) with 
+    match (partitionne s) with
       [lneg;lnul;lpos] ->
     let lnew = deduce_add lneg lpos in
     (List.map ie_tl lnul)@lnew
@@ -172,7 +172,7 @@ let unsolvable lie =
    (try (List.iter (fun e ->
          match e with
            {coef=[c];hist=lc;strict=s} ->
-		  if (rinf c r0 && (not s)) || (rinfeq c r0 && s) 
+		  if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
                   then (res := [c,s,lc];
 			raise (Failure "contradiction found"))
           |_->assert false)
diff --git a/contrib/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 114d5f9c..3f490bab 100644
--- a/contrib/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourierR.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
+(* $Id$ *)
 
 
 
-(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients 
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
 des inéquations et équations sont entiers. En attendant la tactique Field.
 *)
 
@@ -26,9 +26,9 @@ open Contradiction
 
 (******************************************************************************
 Opérations sur les combinaisons linéaires affines.
-La partie homogène d'une combinaison linéaire est en fait une table de hash 
-qui donne le coefficient d'un terme du calcul des constructions, 
-qui est zéro si le terme n'y est pas. 
+La partie homogène d'une combinaison linéaire est en fait une table de hash
+qui donne le coefficient d'un terme du calcul des constructions,
+qui est zéro si le terme n'y est pas.
 *)
 
 type flin = {fhom:(constr , rational)Hashtbl.t;
@@ -38,27 +38,27 @@ let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};;
 
 let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;;
 
-let flin_add f x c = 
+let flin_add f x c =
     let cx = flin_coef f x in
     Hashtbl.remove f.fhom x;
     Hashtbl.add f.fhom x (rplus cx c);
     f
 ;;
-let flin_add_cste f c = 
+let flin_add_cste f c =
     {fhom=f.fhom;
      fcste=rplus f.fcste c}
 ;;
 
 let flin_one () = flin_add_cste (flin_zero()) r1;;
 
-let flin_plus f1 f2 = 
+let flin_plus f1 f2 =
     let f3 = flin_zero() in
     Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
     Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
     flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
 ;;
 
-let flin_minus f1 f2 = 
+let flin_minus f1 f2 =
     let f3 = flin_zero() in
     Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
     Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
@@ -69,17 +69,17 @@ let flin_emult a f =
     Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
     flin_add_cste f2 (rmult a f.fcste);
 ;;
-    
+
 (*****************************************************************************)
 open Vernacexpr
 
 type ineq = Rlt | Rle | Rgt | Rge
 
-let string_of_R_constant kn = 
+let string_of_R_constant kn =
   match Names.repr_con kn with
-    | MPfile dir, sec_dir, id when 
-	sec_dir = empty_dirpath && 
-	string_of_dirpath dir = "Coq.Reals.Rdefinitions" 
+    | MPfile dir, sec_dir, id when
+	sec_dir = empty_dirpath &&
+	string_of_dirpath dir = "Coq.Reals.Rdefinitions"
 	-> string_of_label id
     | _ -> "constant_not_of_R"
 
@@ -94,20 +94,20 @@ let rec rational_of_constr c =
   | Cast (c,_,_) -> (rational_of_constr c)
   | App (c,args) ->
       (match (string_of_R_constr c) with
-	 | "Ropp" -> 
+	 | "Ropp" ->
 	     rop (rational_of_constr args.(0))
-	 | "Rinv" -> 
+	 | "Rinv" ->
 	     rinv (rational_of_constr args.(0))
-	 | "Rmult" -> 
+	 | "Rmult" ->
 	     rmult (rational_of_constr args.(0))
                    (rational_of_constr args.(1))
-	 | "Rdiv" -> 
+	 | "Rdiv" ->
 	     rdiv (rational_of_constr args.(0))
                   (rational_of_constr args.(1))
-	 | "Rplus" -> 
+	 | "Rplus" ->
 	     rplus (rational_of_constr args.(0))
                    (rational_of_constr args.(1))
-	 | "Rminus" -> 
+	 | "Rminus" ->
 	     rminus (rational_of_constr args.(0))
                     (rational_of_constr args.(1))
 	 | _ -> failwith "not a rational")
@@ -125,9 +125,9 @@ let rec flin_of_constr c =
   | Cast (c,_,_) -> (flin_of_constr c)
   | App (c,args) ->
       (match (string_of_R_constr c) with
-	   "Ropp" -> 
+	   "Ropp" ->
              flin_emult (rop r1) (flin_of_constr args.(0))
-	 | "Rplus"-> 
+	 | "Rplus"->
              flin_plus (flin_of_constr args.(0))
 	               (flin_of_constr args.(1))
 	 | "Rminus"->
@@ -138,10 +138,10 @@ let rec flin_of_constr c =
                      try (let b = (rational_of_constr args.(1)) in
 			    (flin_add_cste (flin_zero()) (rmult a b)))
 		     with _-> (flin_add (flin_zero())
-				 args.(1) 
+				 args.(1)
 				 a))
 	      with _-> (flin_add (flin_zero())
-			  args.(0) 
+			  args.(0)
 			  (rational_of_constr args.(1))))
 	 | "Rinv"->
 	     let a=(rational_of_constr args.(0)) in
@@ -151,7 +151,7 @@ let rec flin_of_constr c =
 		try (let a = (rational_of_constr args.(0)) in
 		       (flin_add_cste (flin_zero()) (rdiv a b)))
 		with _-> (flin_add (flin_zero())
-		            args.(0) 
+		            args.(0)
                             (rinv b)))
          |_->assert false)
   | Const c ->
@@ -254,19 +254,19 @@ let ineq1_of_constr (h,t) =
 (* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
 *)
 
-let fourier_lineq lineq1 = 
+let fourier_lineq lineq1 =
    let nvar=ref (-1) in
    let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
    List.iter (fun f ->
 		Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin
-				nvar:=(!nvar)+1; 
+				nvar:=(!nvar)+1;
 				Hashtbl.add hvar x (!nvar)
 			      end)
                   f.hflin.fhom)
              lineq1;
    let sys= List.map (fun h->
                let v=Array.create ((!nvar)+1) r0 in
-               Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) 
+               Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c)
                   h.hflin.fhom;
                ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
              lineq1 in
@@ -281,7 +281,7 @@ let constant = Coqlib.gen_constant "Fourier"
 
 (* Standard library *)
 open Coqlib
-let coq_sym_eqT = lazy (build_coq_sym_eq ())
+let coq_sym_eqT = lazy (build_coq_eq_sym ())
 let coq_False = lazy (build_coq_False ())
 let coq_not = lazy (build_coq_not ())
 let coq_eq = lazy (build_coq_eq ())
@@ -346,7 +346,7 @@ let is_int x = (x.den)=1
 (* fraction = couple (num,den) *)
 let rec rational_to_fraction x= (x.num,x.den)
 ;;
-    
+
 (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
 *)
 let int_to_real n =
@@ -371,7 +371,7 @@ let rational_to_real x =
 let tac_zero_inf_pos gl (n,d) =
    let tacn=ref (apply (get coq_Rlt_zero_1)) in
    let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do 
+   for i=1 to n-1 do
        tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
    for i=1 to d-1 do
        tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
@@ -381,18 +381,18 @@ let tac_zero_inf_pos gl (n,d) =
 (* preuve que 0<=n*1/d
 *)
 let tac_zero_infeq_pos gl (n,d)=
-   let tacn=ref (if n=0 
+   let tacn=ref (if n=0
                  then (apply (get coq_Rle_zero_zero))
                  else (apply (get coq_Rle_zero_1))) in
    let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do 
+   for i=1 to n-1 do
        tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
    for i=1 to d-1 do
        tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
    (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
 ;;
-  
-(* preuve que 0<(-n)*(1/d) => False 
+
+(* preuve que 0<(-n)*(1/d) => False
 *)
 let tac_zero_inf_false gl (n,d) =
     if n=0 then (apply (get coq_Rnot_lt0))
@@ -401,7 +401,7 @@ let tac_zero_inf_false gl (n,d) =
 	      (tac_zero_infeq_pos gl (-n,d)))
 ;;
 
-(* preuve que 0<=(-n)*(1/d) => False 
+(* preuve que 0<=(-n)*(1/d) => False
 *)
 let tac_zero_infeq_false gl (n,d) =
      (tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
@@ -409,7 +409,7 @@ let tac_zero_infeq_false 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
@@ -467,22 +467,22 @@ let rec fourier gl=
      match (kind_of_term goal) with
       App (f,args) ->
       (match (string_of_R_constr f) with
-	     "Rlt" -> 
+	     "Rlt" ->
 	       (tclTHEN
 	         (tclTHEN (apply (get coq_Rfourier_not_ge_lt))
 			  (intro_using  fhyp))
 		 fourier)
-	    |"Rle" -> 
+	    |"Rle" ->
 	     (tclTHEN
 	      (tclTHEN (apply (get coq_Rfourier_not_gt_le))
 		       (intro_using  fhyp))
 			fourier)
-	    |"Rgt" -> 
+	    |"Rgt" ->
 	     (tclTHEN
 	      (tclTHEN (apply (get coq_Rfourier_not_le_gt))
 		       (intro_using  fhyp))
 	      fourier)
-	    |"Rge" -> 
+	    |"Rge" ->
 	     (tclTHEN
 	      (tclTHEN (apply (get coq_Rfourier_not_lt_ge))
 		       (intro_using  fhyp))
@@ -490,7 +490,7 @@ let rec fourier gl=
 	    |_->assert false)
         |_->assert false
       in tac gl)
-     with _ -> 
+     with _ ->
     (* les hypothèses *)
     let hyps = List.map (fun (h,t)-> (mkVar h,t))
                         (list_of_sign (pf_hyps gl)) in
@@ -511,12 +511,12 @@ let rec fourier gl=
        qui donnent 0<cres ou 0<=cres selon sres *)
 	(*print_string "Fourier's method can prove the goal...";flush stdout;*)
           let lutil=ref [] in
-	  List.iter 
+	  List.iter
             (fun (h,c) ->
 			  if c<>r0
         		  then (lutil:=(h,c)::(!lutil)(*;
 				print_rational(c);print_string " "*)))
-                    (List.combine (!lineq) lc); 
+                    (List.combine (!lineq) lc);
        (* on construit la combinaison linéaire des inéquation *)
              (match (!lutil) with
           (h1,c1)::lutil ->
@@ -545,7 +545,7 @@ let rec fourier gl=
 			      !t2 |] in
 	   let tc=rational_to_real cres in
        (* puis sa preuve *)
-           let tac1=ref (if h1.hstrict 
+           let tac1=ref (if h1.hstrict
                          then (tclTHENS (apply (get coq_Rfourier_lt))
                                  [tac_use h1;
                                   tac_zero_inf_pos  gl
@@ -555,24 +555,24 @@ let rec fourier gl=
 				  tac_zero_inf_pos  gl
                                       (rational_to_fraction c1)])) in
            s:=h1.hstrict;
-           List.iter (fun (h,c)-> 
+           List.iter (fun (h,c)->
              (if (!s)
 	      then (if h.hstrict
 	            then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt))
-			       [!tac1;tac_use h; 
+			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])
 	            else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le))
-			       [!tac1;tac_use h; 
+			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)]))
 	      else (if h.hstrict
 	            then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt))
-			       [!tac1;tac_use h; 
+			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])
 	            else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le))
-			       [!tac1;tac_use h; 
+			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])));
 	     s:=(!s)||(h.hstrict))
@@ -581,7 +581,7 @@ let rec fourier gl=
                       then tac_zero_inf_false gl (rational_to_fraction cres)
                       else tac_zero_infeq_false gl (rational_to_fraction cres)
            in
-           tac:=(tclTHENS (my_cut ineq) 
+           tac:=(tclTHENS (my_cut ineq)
                      [tclTHEN (change_in_concl None
 			       (mkAppL [| get coq_not; ineq|]
 				       ))
@@ -594,17 +594,17 @@ let rec fourier gl=
 		 	       [tac2;
                                 (tclTHENS
 				  (Equality.replace
-				    (mkApp (get coq_Rinv, 
+				    (mkApp (get coq_Rinv,
 				      [|get coq_R1|]))
 				    (get coq_R1))
-(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)	
+(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)
 
       			        [tclORELSE
                                    (Ring.polynom [])
                                    tclIDTAC;
 					  (tclTHEN (apply (get coq_sym_eqT))
 						(apply (get coq_Rinv_1)))]
-                               
+
 					 )
 				]));
                        !tac1]);
@@ -614,7 +614,7 @@ let rec fourier gl=
       |_-> assert false) |_-> assert false
 	  );
 (*    ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
-      (!tac gl) 
+      (!tac gl)
 (*      ((tclABSTRACT None !tac) gl) *)
 
 ;;
diff --git a/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mllib
new file mode 100644
index 00000000..0383b1a8
--- /dev/null
+++ b/plugins/fourier/fourier_plugin.mllib
@@ -0,0 +1,4 @@
+Fourier
+FourierR
+G_fourier
+Fourier_plugin_mod
diff --git a/contrib/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index 3a6be850..b952851f 100644
--- a/contrib/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_fourier.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
+(* $Id$ *)
 
 open FourierR
 
diff --git a/plugins/fourier/vo.itarget b/plugins/fourier/vo.itarget
new file mode 100644
index 00000000..87d82dac
--- /dev/null
+++ b/plugins/fourier/vo.itarget
@@ -0,0 +1,2 @@
+Fourier_util.vo
+Fourier.vo
diff --git a/contrib/funind/Recdef.v b/plugins/funind/Recdef.v
index 2d206220..00302a74 100644
--- a/contrib/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -20,21 +20,21 @@ Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
 End Iter.
 
 Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
-  intro p; intro p'; change (S p <= S (S (p + p'))); 
-    apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); 
+  intro p; intro p'; change (S p <= S (S (p + p')));
+    apply le_S; apply Gt.gt_le_S; change (p < S (p + p'));
     apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
 Qed.
- 
+
 
 Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
-  intro p; intro p'; change (S p' <= S (p + p')); 
+  intro p; intro p'; change (S p' <= S (p + p'));
     apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
        apply Plus.le_plus_r.
 Qed.
 
 Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
-intro x; intro y; intro H; change (S x <= S (S y)); 
-    apply le_S; apply Gt.gt_le_S; change (x < S y); 
+intro x; intro y; intro H; change (S x <= S (S y));
+    apply le_S; apply Gt.gt_le_S; change (x < S y);
     apply Lt.le_lt_n_Sm; exact H.
 Qed.
 
diff --git a/contrib/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index b13bea9d..e2cad944 100644
--- a/contrib/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,8 +1,9 @@
 open Printer
 open Util
 open Term
-open Termops 
-open Names 
+open Termops
+open Namegen
+open Names
 open Declarations
 open Pp
 open Entries
@@ -16,7 +17,7 @@ open Indfun_common
 open Libnames
 
 let msgnl = Pp.msgnl
-  
+
 
 let observe strm =
   if do_observe ()
@@ -35,11 +36,11 @@ 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 goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
-   msgnl (str "observation "++ s++str " raised exception " ++ 
-	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+   msgnl (str "observation "++ s++str " raised exception " ++
+	    Cerrors.explain_exn e ++ str " on goal " ++ goal );
    raise e;;
 
-let observe_tac_stream s tac g = 
+let observe_tac_stream s tac g =
   if do_observe ()
   then do_observe_tac  s tac g
   else tac g
@@ -52,54 +53,54 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g
 (*   else tac *)
 
 
-let list_chop ?(msg="") n l = 
-  try 
-    list_chop n l 
-  with Failure (msg') -> 
+let list_chop ?(msg="") n l =
+  try
+    list_chop n l
+  with Failure (msg') ->
     failwith (msg ^ msg')
-  
 
-let make_refl_eq type_of_t t  =
-  let refl_equal_term = Lazy.force refl_equal in
-  mkApp(refl_equal_term,[|type_of_t;t|])
+
+let make_refl_eq constructor type_of_t t  =
+(*   let refl_equal_term = Lazy.force refl_equal in *)
+  mkApp(constructor,[|type_of_t;t|])
 
 
-type pte_info = 
-    { 
+type pte_info =
+    {
       proving_tac : (identifier list ->  Tacmach.tactic);
       is_valid : constr -> bool
     }
 
 type ptes_info = pte_info Idmap.t
 
-type 'a dynamic_info = 
-    { 
+type 'a dynamic_info =
+    {
       nb_rec_hyps : int;
-      rec_hyps : identifier list ; 
+      rec_hyps : identifier list ;
       eq_hyps : identifier list;
       info : 'a
     }
 
-type body_info = constr dynamic_info 
-      
+type body_info = constr dynamic_info
+
 
-let finish_proof dynamic_infos g = 
-  observe_tac "finish" 
+let finish_proof dynamic_infos g =
+  observe_tac "finish"
     ( h_assumption)
     g
-	  
 
-let refine c = 
+
+let refine c =
   Tacmach.refine_no_check c
 
-let thin l = 
+let thin l =
   Tacmach.thin_no_check l
-  
 
-let cut_replacing id t tac :tactic= 
+
+let cut_replacing id t tac :tactic=
   tclTHENS (cut t)
     [ tclTHEN (thin_no_check [id]) (introduction_no_check id);
-      tac 
+      tac
     ]
 
 let intro_erasing id = tclTHEN (thin [id]) (introduction id)
@@ -108,37 +109,54 @@ let intro_erasing id = tclTHEN (thin [id]) (introduction id)
 
 let rec_hyp_id = id_of_string "rec_hyp"
 
-let is_trivial_eq t = 
-  match kind_of_term t with 
-    | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> 
-	eq_constr t1 t2
-    | _ -> false 
-
+let is_trivial_eq t =
+  let res =   try
+    begin
+      match kind_of_term t with
+	| App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+	    eq_constr t1 t2
+	| App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ())  ->
+	    eq_constr t1 t2 && eq_constr a1 a2
+	| _ -> false
+    end
+  with _ -> false
+  in
+(*   observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
+  res
 
-let rec incompatible_constructor_terms t1 t2 = 
-  let c1,arg1 = decompose_app t1 
-  and c2,arg2 = decompose_app t2 
-  in 
+let rec incompatible_constructor_terms t1 t2 =
+  let c1,arg1 = decompose_app t1
+  and c2,arg2 = decompose_app t2
+  in
   (not (eq_constr t1 t2)) &&
-    isConstruct c1 && isConstruct c2 && 
+    isConstruct c1 && isConstruct c2 &&
     (
-      not (eq_constr c1 c2) || 
+      not (eq_constr c1 c2) ||
 	List.exists2 incompatible_constructor_terms arg1 arg2
     )
 
-let is_incompatible_eq t = 
-  match kind_of_term t with 
-    | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> 
-	incompatible_constructor_terms t1 t2
-    | _ -> false 
+let is_incompatible_eq t =
+  let res =
+    try
+      match kind_of_term t with
+	| App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+	    incompatible_constructor_terms t1 t2
+	| App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) ->
+	    (eq_constr u1 u2 &&
+	       incompatible_constructor_terms t1 t2)
+	| _ -> false
+    with _ -> false
+  in
+  if res then   observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
+  res
 
-let change_hyp_with_using msg hyp_id t tac : tactic = 
-  fun g -> 
-    let prov_id = pf_get_new_id hyp_id g in 
+let change_hyp_with_using msg hyp_id t tac : tactic =
+  fun g ->
+    let prov_id = pf_get_new_id hyp_id g in
     tclTHENS
       ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac)))
-      [tclTHENLIST 
-      [	
+      [tclTHENLIST
+      [
 	(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
 	(* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
       ]] g
@@ -146,128 +164,152 @@ let change_hyp_with_using msg hyp_id t tac : tactic =
 exception TOREMOVE
 
 
-let prove_trivial_eq h_id context (type_of_term,term) = 
-  let nb_intros = List.length context in 
+let prove_trivial_eq h_id context (constructor,type_of_term,term) =
+  let nb_intros = List.length context in
   tclTHENLIST
     [
       tclDO nb_intros intro; (* introducing context *)
-      (fun g -> 
-	 let context_hyps =  
-	   fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) 
+      (fun g ->
+	 let context_hyps =
+	   fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g))
 	 in
-	 let context_hyps' = 
-	   (mkApp(Lazy.force refl_equal,[|type_of_term;term|]))::
+	 let context_hyps' =
+	   (mkApp(constructor,[|type_of_term;term|]))::
 	     (List.map mkVar context_hyps)
 	 in
-	 let to_refine = applist(mkVar h_id,List.rev context_hyps') in 
+	 let to_refine = applist(mkVar h_id,List.rev context_hyps') in
 	 refine to_refine g
       )
     ]
 
 
-let isAppConstruct t = 
-  if isApp t 
-  then isConstruct (fst (destApp t))
-  else false 
+
+let find_rectype env c =
+  let (t, l) = decompose_app (Reduction.whd_betadeltaiota env c) in
+  match kind_of_term t with
+  | Ind ind -> (t, l)
+  | Construct _ -> (t,l)
+  | _ -> raise Not_found
+
+
+let isAppConstruct ?(env=Global.env ()) t =
+  try
+    let t',l = find_rectype (Global.env ()) t in
+    observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist  (t',l)));
+    true
+  with Not_found -> false
 
 let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
   let clos_norm_flags flgs env sigma t =
     Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
   clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
-    
 
-let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type  = 
-  let nochange msg  = 
-    begin 
-(*       observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t    ); *)
-      failwith "NoChange"; 
+
+
+let change_eq env sigma hyp_id (context:rel_context) 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 );
+      failwith "NoChange";
     end
-  in    
-  let eq_constr = Reductionops.is_conv env sigma in 
+  in
+  let eq_constr = Reductionops.is_conv env sigma in
   if not (noccurn 1 end_of_type)
   then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
     if not (isApp t) then nochange "not an equality";
     let f_eq,args = destApp t in
-    if not (eq_constr f_eq (Lazy.force eq)) then nochange "not an equality";
-    let t1 = args.(1) 
-    and t2 = args.(2) 
-    and t1_typ = args.(0)
-    in 
-    if not (closed0 t1) then nochange "not a closed lhs";    
-    let rec compute_substitution sub t1 t2 = 
+    let constructor,t1,t2,t1_typ =
+      try
+	if (eq_constr f_eq (Lazy.force eq))
+	then
+	  let t1 = (args.(1),args.(0))
+	  and t2 = (args.(2),args.(0))
+	  and t1_typ = args.(0)
+	  in
+	  (Lazy.force refl_equal,t1,t2,t1_typ)
+	else
+	  if (eq_constr f_eq (jmeq ()))
+	  then
+	    (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
+	  else nochange "not an equality"
+      with _ -> 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 =
 (*       observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *)
-      if isRel t2 
-      then 
-	let t2 = destRel t2  in 
-	begin 
-	  try 
-	    let t1' = Intmap.find t2 sub in 
+      if isRel t2
+      then
+	let t2 = destRel t2  in
+	begin
+	  try
+	    let t1' = Intmap.find t2 sub in
 	    if not (eq_constr t1 t1') then nochange "twice bound variable";
 	    sub
-	  with Not_found -> 
+	  with Not_found ->
 	    assert (closed0 t1);
 	    Intmap.add t2 t1 sub
 	end
-      else if isAppConstruct t1 && isAppConstruct t2 
-      then 
+      else if isAppConstruct t1 && isAppConstruct t2
+      then
 	begin
-	  let c1,args1 = destApp t1 
-	  and c2,args2 = destApp t2 
-	  in 
-	  if not (eq_constr c1 c2) then anomaly "deconstructing equation";
-	  array_fold_left2 compute_substitution sub args1 args2
+	  let c1,args1 =  find_rectype env t1
+	  and c2,args2 = find_rectype env t2
+	  in
+	  if not (eq_constr c1 c2) then nochange "cannot solve (diff)";
+	  List.fold_left2 compute_substitution sub args1 args2
 	end
-      else 
-	if (eq_constr t1 t2) then sub else nochange "cannot solve"
+      else
+	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2)  "cannot solve (diff)"
     in
-    let sub = compute_substitution Intmap.empty t1 t2 in 
-    let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) 
-    let new_end_of_type = 
-      (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 
+    let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in
+    let sub = compute_substitution sub (fst t1) (fst t2) in
+    let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *)
+    let new_end_of_type =
+      (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
 	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
       *)
-      let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in 
-      let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in 
+      let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in
+      let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in
       List.fold_left (fun end_of_type (i,t)  -> lift 1 (substnl  [t] (i-1) end_of_type))
 	end_of_type_with_pop
 	sub''
     in
     let old_context_length = List.length context + 1 in
-    let witness_fun = 
-      mkLetIn(Anonymous,make_refl_eq t1_typ t1,t,
+    let witness_fun =
+      mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t,
 	       mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i)))
 	      )
     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) -> 
-	   try 
-	     let witness = Intmap.find i sub 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) ->
+	   try
+	     let witness = Intmap.find i sub in
 	     if b' <> None then anomaly "can not redefine a rel!";
 	     (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
-	   with Not_found  -> 
+	   with Not_found  ->
 	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
 	)
-	1 
+	1
 	(new_end_of_type,0,witness_fun)
 	context
     in
     let new_type_of_hyp =
-      Reductionops.nf_betaiota Evd.empty new_type_of_hyp in 
-    let new_ctxt,new_end_of_type = 
-      Sign.decompose_prod_n_assum ctxt_size new_type_of_hyp 
-    in 
-    let prove_new_hyp : tactic = 
+      Reductionops.nf_betaiota Evd.empty new_type_of_hyp in
+    let new_ctxt,new_end_of_type =
+      decompose_prod_n_assum ctxt_size new_type_of_hyp
+    in
+    let prove_new_hyp : tactic =
       tclTHEN
 	(tclDO ctxt_size intro)
 	(fun g ->
-	   let all_ids = pf_ids_of_hyps g in 
-	   let new_ids,_  = list_chop ctxt_size all_ids in 
-	   let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in 
+	   let all_ids = pf_ids_of_hyps g in
+	   let new_ids,_  = list_chop ctxt_size all_ids in
+	   let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in
 	   refine to_refine g
 	)
     in
-    let simpl_eq_tac = 
+    let simpl_eq_tac =
       change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp
     in
 (*     observe (str "In " ++ Ppconstr.pr_id hyp_id ++  *)
@@ -287,51 +329,51 @@ let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type  =
     new_ctxt,new_end_of_type,simpl_eq_tac
 
 
-let is_property ptes_info t_x full_type_of_hyp = 
-  if isApp t_x 
-  then 
-    let pte,args = destApp t_x in 
-    if isVar pte && array_for_all closed0 args 
-    then 
-      try 
-	let info = Idmap.find (destVar pte) ptes_info in 
-	info.is_valid full_type_of_hyp	  
-      with Not_found -> false 
-    else false 
-  else false 
+let is_property ptes_info t_x full_type_of_hyp =
+  if isApp t_x
+  then
+    let pte,args = destApp t_x in
+    if isVar pte && array_for_all closed0 args
+    then
+      try
+	let info = Idmap.find (destVar pte) ptes_info in
+	info.is_valid full_type_of_hyp
+      with Not_found -> false
+    else false
+  else false
 
-let isLetIn t = 
-  match kind_of_term t with 
-    | LetIn _ -> true 
-    | _ -> false 
+let isLetIn t =
+  match kind_of_term t with
+    | LetIn _ -> true
+    | _ -> false
 
 
-let h_reduce_with_zeta = 	 
-  h_reduce 
+let h_reduce_with_zeta =
+  h_reduce
     (Rawterm.Cbv
-       {Rawterm.all_flags 
-	with Rawterm.rDelta = false; 		 
+       {Rawterm.all_flags
+	with Rawterm.rDelta = false;
        })
-  
+
 
 
 let rewrite_until_var arg_num eq_ids : tactic =
-  (* tests if the declares recursive argument is neither a Constructor nor 
-     an applied Constructor since such a form for the recursive argument 
-     will break the Guard when trying to save the Lemma. 
+  (* tests if the declares recursive argument is neither a Constructor nor
+     an applied Constructor since such a form for the recursive argument
+     will break the Guard when trying to save the Lemma.
   *)
-  let test_var g = 
-    let _,args = destApp (pf_concl g) in 
+  let test_var g =
+    let _,args = destApp (pf_concl g) in
     not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
   in
-  let rec do_rewrite eq_ids g  = 
-    if test_var g 
+  let rec do_rewrite eq_ids g  =
+    if test_var g
     then tclIDTAC g
     else
-      match eq_ids with 
+      match eq_ids with
 	| [] -> anomaly "Cannot find a way to prove recursive property";
-	| eq_id::eq_ids -> 
-	    tclTHEN 
+	| eq_id::eq_ids ->
+	    tclTHEN
 	      (tclTRY (Equality.rewriteRL (mkVar eq_id)))
 	      (do_rewrite eq_ids)
 	      g
@@ -339,50 +381,50 @@ let rewrite_until_var arg_num eq_ids : tactic =
   do_rewrite eq_ids
 
 
-let rec_pte_id = id_of_string "Hrec" 
-let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = 
-  let coq_False = Coqlib.build_coq_False () in 
-  let coq_True = Coqlib.build_coq_True () in 
-  let coq_I = Coqlib.build_coq_I () in 
-  let rec scan_type  context type_of_hyp : tactic = 
-    if isLetIn type_of_hyp then 
+let rec_pte_id = id_of_string "Hrec"
+let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
+  let coq_False = Coqlib.build_coq_False () in
+  let coq_True = Coqlib.build_coq_True () in
+  let coq_I = Coqlib.build_coq_I () in
+  let rec scan_type  context type_of_hyp : tactic =
+    if isLetIn type_of_hyp then
       let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in
-      let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in 
+      let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in
       (* length of context didn't change ? *)
-      let new_context,new_typ_of_hyp = 
-	 Sign.decompose_prod_n_assum (List.length context) reduced_type_of_hyp
+      let new_context,new_typ_of_hyp =
+	 decompose_prod_n_assum (List.length context) reduced_type_of_hyp
       in
-        tclTHENLIST 
+        tclTHENLIST
 	[
 	  h_reduce_with_zeta
 	    (Tacticals.onHyp hyp_id)
 	  ;
-	  scan_type new_context new_typ_of_hyp 
-	  
+	  scan_type new_context new_typ_of_hyp
+
 	]
-    else if isProd type_of_hyp 
-    then 
-      begin 
-	let (x,t_x,t') = destProd type_of_hyp in	
-	let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in 
+    else if isProd type_of_hyp
+    then
+      begin
+	let (x,t_x,t') = destProd type_of_hyp in
+	let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in
 	if is_property ptes_infos t_x actual_real_type_of_hyp then
 	  begin
-	    let pte,pte_args =  (destApp t_x) in 
-	    let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in 
-	    let popped_t' = pop t' in 
-	    let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in 
-	    let prove_new_type_of_hyp = 
-	      let context_length = List.length context in 
+	    let pte,pte_args =  (destApp t_x) in
+	    let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in
+	    let popped_t' = pop t' in
+	    let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in
+	    let prove_new_type_of_hyp =
+	      let context_length = List.length context in
 	      tclTHENLIST
-		[ 
-		  tclDO context_length intro; 
-		  (fun g ->  
-		     let context_hyps_ids = 
+		[
+		  tclDO context_length intro;
+		  (fun g ->
+		     let context_hyps_ids =
 		       fst (list_chop ~msg:"rec hyp : context_hyps"
 			      context_length (pf_ids_of_hyps g))
 		     in
-		     let rec_pte_id = pf_get_new_id rec_pte_id g in 
-		     let to_refine = 
+		     let rec_pte_id = pf_get_new_id rec_pte_id g in
+		     let to_refine =
 		       applist(mkVar hyp_id,
 			       List.rev_map mkVar (rec_pte_id::context_hyps_ids)
 			      )
@@ -399,39 +441,39 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 		  )
 		]
 	    in
-	    tclTHENLIST 
+	    tclTHENLIST
 	      [
 (* 		observe_tac "hyp rec"  *)
 		  (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp);
 		scan_type context popped_t'
 	      ]
 	  end
-	else if eq_constr t_x coq_False then 
+	else if eq_constr t_x coq_False then
 	  begin
 (* 	    observe (str "Removing : "++ Ppconstr.pr_id hyp_id++  *)
 (* 		       str " since it has False in its preconds " *)
 (* 		    ); *)
 	    raise TOREMOVE;  (* False -> .. useless *)
 	  end
-	else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... =  C2 ... *) 
+	else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... =  C2 ... *)
 	else if eq_constr t_x coq_True  (* Trivial => we remove this precons *)
-	then 
+	then
 (* 	    observe (str "In "++Ppconstr.pr_id hyp_id++  *)
 (* 		       str " removing useless precond True" *)
 (* 		    );  *)
 	  let popped_t' = pop t' in
-	  let real_type_of_hyp = 
-	    it_mkProd_or_LetIn ~init:popped_t' context 
-	  in 
-	  let prove_trivial =  
-	    let nb_intro = List.length context in 
+	  let real_type_of_hyp =
+	    it_mkProd_or_LetIn ~init:popped_t' context
+	  in
+	  let prove_trivial =
+	    let nb_intro = List.length context in
 	    tclTHENLIST [
 	      tclDO nb_intro intro;
-	      (fun g -> 
-		 let context_hyps = 
+	      (fun g ->
+		 let context_hyps =
 		   fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
 		 in
-		 let to_refine = 
+		 let to_refine =
 		   applist (mkVar hyp_id,
 			    List.rev (coq_I::List.map mkVar context_hyps)
 			   )
@@ -441,93 +483,99 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	    ]
 	  in
 	  tclTHENLIST[
-	    change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp 
+	    change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp
 	      ((* observe_tac "prove_trivial" *) prove_trivial);
 	    scan_type context popped_t'
 	  ]
-	else if is_trivial_eq t_x 
-	then (*  t_x :=  t = t   => we remove this precond *) 
+	else if is_trivial_eq t_x
+	then (*  t_x :=  t = t   => we remove this precond *)
 	  let popped_t' = pop t' in
 	  let real_type_of_hyp =
 	    it_mkProd_or_LetIn ~init:popped_t' context
 	  in
-	  let _,args = destApp t_x in
+	  let hd,args = destApp t_x in
+	  let get_args hd args =
+	    if eq_constr hd (Lazy.force eq)
+	    then (Lazy.force refl_equal,args.(0),args.(1))
+	    else (jmeq_refl (),args.(0),args.(1))
+	  in
 	  tclTHENLIST
 	    [
 	      change_hyp_with_using
 		"prove_trivial_eq"
 		hyp_id
 		real_type_of_hyp
-		((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (args.(0),args.(1))));
+		((* observe_tac "prove_trivial_eq" *)
+		  (prove_trivial_eq hyp_id context (get_args hd args)));
 	      scan_type context popped_t'
-	    ] 
-	else 
+	    ]
+	else
 	  begin
-	    try 
-	      let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in 
+	    try
+	      let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in
 	      tclTHEN
-		tac 
+		tac
 		(scan_type new_context new_t')
-	    with Failure "NoChange" -> 
-	      (* Last thing todo : push the rel in the context and continue *) 
+	    with Failure "NoChange" ->
+	      (* Last thing todo : push the rel in the context and continue *)
 	      scan_type ((x,None,t_x)::context) t'
 	  end
       end
     else
       tclIDTAC
-  in 
-  try 
+  in
+  try
     scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id]
-  with TOREMOVE -> 
+  with TOREMOVE ->
     thin [hyp_id],[]
 
 
-let clean_goal_with_heq ptes_infos continue_tac dyn_infos  = 
-  fun g -> 
-    let env = pf_env g 
-    and sigma = project g 
+let clean_goal_with_heq ptes_infos continue_tac dyn_infos  =
+  fun g ->
+    let env = pf_env g
+    and sigma = project g
     in
-    let tac,new_hyps = 
-      List.fold_left ( 
+    let tac,new_hyps =
+      List.fold_left (
 	fun (hyps_tac,new_hyps) hyp_id ->
-	  let hyp_tac,new_hyp = 
-	    clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma 
+	  let hyp_tac,new_hyp =
+	    clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma
 	  in
 	  (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps
       )
 	(tclIDTAC,[])
 	dyn_infos.rec_hyps
     in
-    let new_infos = 
-      { dyn_infos with 
-	  rec_hyps = new_hyps; 
+    let new_infos =
+      { dyn_infos with
+	  rec_hyps = new_hyps;
 	  nb_rec_hyps  = List.length new_hyps
       }
     in
-    tclTHENLIST 
+    tclTHENLIST
       [
 	tac ;
 	(* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos)
       ]
-      g    
+      g
 
 let heq_id = id_of_string "Heq"
 
-let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = 
-  fun g -> 
-    let heq_id = pf_get_new_id heq_id g in 
+let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
+  fun g ->
     let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in
     tclTHENLIST
-      [ 
-	(* We first introduce the variables *) 
+      [
+	(* We first introduce the variables *)
 	tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
 	(* Then the equation itself *)
-	introduction_no_check heq_id;
-	(* Then the new hypothesis *) 
+	intro_using heq_id;
+	onLastHypId (fun heq_id -> tclTHENLIST [
+	(* Then the new hypothesis *)
 	tclMAP introduction_no_check dyn_infos.rec_hyps;
-	(* observe_tac "after_introduction"  *)(fun g' -> 
+	(* observe_tac "after_introduction"  *)(fun g' ->
 	   (* We get infos on the equations introduced*)
-	   let new_term_value_eq = pf_type_of g' (mkVar heq_id) in 
+	   let new_term_value_eq = pf_type_of g' (mkVar heq_id) in
 	   (* compute the new value of the body *)
 	   let new_term_value =
 	     match kind_of_term new_term_value_eq with
@@ -545,31 +593,31 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 		   )
 	 in
 	 let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
-	 let new_infos = 
-	   {dyn_infos with 
+	 let new_infos =
+	   {dyn_infos with
 	      info = new_body;
 	      eq_hyps = heq_id::dyn_infos.eq_hyps
 	   }
-	 in 
+	 in
 	 clean_goal_with_heq ptes_infos continue_tac new_infos  g'
-      )
+      )])
     ]
       g
 
 
-let my_orelse tac1 tac2 g = 
-  try 
-    tac1 g 
-  with e -> 
+let my_orelse tac1 tac2 g =
+  try
+    tac1 g
+  with e ->
 (*     observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
-    tac2 g 
+    tac2 g
 
-let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = 
-  let args = Array.of_list (List.map mkVar  args_id) in 
-  let instanciate_one_hyp hid = 
+let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
+  let args = Array.of_list (List.map mkVar  args_id) in
+  let instanciate_one_hyp hid =
     my_orelse
       ( (* we instanciate the hyp if possible  *)
-	fun g -> 
+	fun g ->
 	  let prov_hid = pf_get_new_id hid g in
 	  tclTHENLIST[
 	    pose_proof (Name prov_hid) (mkApp(mkVar hid,args));
@@ -578,21 +626,21 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
 	  ] g
       )
       ( (*
-	  if not then we are in a mutual function block 
+	  if not then we are in a mutual function block
 	  and this hyp is a recursive hyp on an other function.
-	  
-	  We are not supposed to use it while proving this 
-	  principle so that we can trash it 
-	  
+
+	  We are not supposed to use it while proving this
+	  principle so that we can trash it
+
 	*)
-	(fun g -> 
+	(fun g ->
 (* 	   observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *)
 	   thin [hid] g
 	)
       )
   in
-  if args_id = []  
-  then 
+  if args_id = []
+  then
     tclTHENLIST [
       tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
       do_prove hyps
@@ -602,58 +650,62 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
       [
 	tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
 	tclMAP instanciate_one_hyp hyps;
-	(fun g ->  
-	   let all_g_hyps_id = 
+	(fun g ->
+	   let all_g_hyps_id =
 	     List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
-	   in 
-	   let remaining_hyps = 
+	   in
+	   let remaining_hyps =
 	     List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
 	   in
 	   do_prove remaining_hyps g
 	  )
       ]
 
-let build_proof 
+let build_proof
     (interactive_proof:bool)
     (fnames:constant list)
     ptes_infos
     dyn_infos
     : tactic =
-  let rec build_proof_aux do_finalize dyn_infos : tactic = 
-    fun g -> 
+  let rec build_proof_aux do_finalize dyn_infos : tactic =
+    fun g ->
 (*      observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*)
-	match kind_of_term dyn_infos.info with 
-	  | Case(ci,ct,t,cb) -> 
-	      let do_finalize_t dyn_info' = 
+	match kind_of_term dyn_infos.info with
+	  | Case(ci,ct,t,cb) ->
+	      let do_finalize_t dyn_info' =
 		fun g ->
-		  let t = dyn_info'.info in 
-		  let dyn_infos = {dyn_info' with info = 
+		  let t = dyn_info'.info in
+		  let dyn_infos = {dyn_info' with info =
 		      mkCase(ci,ct,t,cb)} in
 		  let g_nb_prod = nb_prod (pf_concl g) in
 		  let type_of_term = pf_type_of g t in
 		  let term_eq =
-		    make_refl_eq type_of_term t
+		    make_refl_eq (Lazy.force refl_equal) type_of_term t
 		  in
 		  tclTHENSEQ
 		    [
 		      h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
 		      thin dyn_infos.rec_hyps;
 		      pattern_option [(false,[1]),t] None;
-		      h_simplest_case t;
-		      (fun g' -> 
-			 let g'_nb_prod = nb_prod (pf_concl g') in 
-			 let nb_instanciate_partial = g'_nb_prod - g_nb_prod in 
-			 		     observe_tac "treat_new_case"
-			 (treat_new_case  
-			    ptes_infos
-			    nb_instanciate_partial 
-			    (build_proof do_finalize) 
-			    t 
-			    dyn_infos)
-			   g'
+		      (fun g -> observe_tac "toto" (
+			 tclTHENSEQ [h_simplest_case t;
+				     (fun g' ->
+					let g'_nb_prod = nb_prod (pf_concl g') in
+					let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
+			 		observe_tac "treat_new_case"
+					  (treat_new_case
+					     ptes_infos
+					     nb_instanciate_partial
+					     (build_proof do_finalize)
+					     t
+					     dyn_infos)
+					  g'
+				     )
+
+				    ]) g
 		      )
-			
-		    ] g
+		    ]
+		    g
 	      in
 	      build_proof do_finalize_t {dyn_infos with info = t} g
 	  | Lambda(n,t,b) ->
@@ -664,25 +716,25 @@ let build_proof
 			intro
 			(fun g' ->
 			   let (id,_,_) = pf_last_hyp g' in
-			   let new_term = 
-			     pf_nf_betaiota g' 
-			       (mkApp(dyn_infos.info,[|mkVar id|])) 
+			   let new_term =
+			     pf_nf_betaiota g'
+			       (mkApp(dyn_infos.info,[|mkVar id|]))
 			   in
 			   let new_infos = {dyn_infos with info = new_term} in
-			   let do_prove new_hyps = 
-			     build_proof do_finalize 
+			   let do_prove new_hyps =
+			     build_proof do_finalize
 			       {new_infos with
-			       	  rec_hyps = new_hyps; 
+			       	  rec_hyps = new_hyps;
 				  nb_rec_hyps  = List.length new_hyps
 			       }
-			   in 
+			   in
 (* 			   observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g'
 			     (* 			   build_proof do_finalize new_infos g' *)
 			) g
 		  | _ ->
-		      do_finalize dyn_infos g 
+		      do_finalize dyn_infos g
 	      end
-	  | Cast(t,_,_) -> 
+	  | Cast(t,_,_) ->
 	      build_proof do_finalize {dyn_infos with info = t} g
 	  | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
 	      do_finalize dyn_infos g
@@ -692,15 +744,15 @@ let build_proof
 		match kind_of_term f with
 		  | App _ -> assert false (* we have collected all the app in decompose_app *)
 		  | Var _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ | Sort _ | Prod _ ->
-		      let new_infos = 
-			{ dyn_infos with 
+		      let new_infos =
+			{ dyn_infos with
 			    info = (f,args)
 			}
 		      in
 		      build_proof_args do_finalize new_infos  g
 		  | Const c when not (List.mem c fnames) ->
-		      let new_infos = 
-			{ dyn_infos with 
+		      let new_infos =
+			{ dyn_infos with
 			    info = (f,args)
 			}
 		      in
@@ -708,93 +760,93 @@ let build_proof
 		      build_proof_args do_finalize new_infos g
 		  | Const _ ->
 		      do_finalize dyn_infos  g
-		  | Lambda _ -> 
+		  | Lambda _ ->
 		      let new_term =
-                        Reductionops.nf_beta Evd.empty dyn_infos.info in 
-		      build_proof do_finalize {dyn_infos with info = new_term} 
+                        Reductionops.nf_beta Evd.empty dyn_infos.info in
+		      build_proof do_finalize {dyn_infos with info = new_term}
 			g
-		  | LetIn _ -> 
-		      let new_infos = 
-			{ dyn_infos with info = nf_betaiotazeta dyn_infos.info } 
-		      in 
-
-		      tclTHENLIST 
-			[tclMAP 
-			   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) 
+		  | LetIn _ ->
+		      let new_infos =
+			{ dyn_infos with info = nf_betaiotazeta dyn_infos.info }
+		      in
+
+		      tclTHENLIST
+			[tclMAP
+			   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
 			   dyn_infos.rec_hyps;
 			 h_reduce_with_zeta Tacticals.onConcl;
 			 build_proof do_finalize new_infos
-			] 
+			]
 			g
-		  | Cast(b,_,_) -> 
+		  | Cast(b,_,_) ->
 		      build_proof do_finalize {dyn_infos with info = b } g
 		  | Case _ | Fix _ | CoFix _ ->
-		      let new_finalize dyn_infos = 
-			let new_infos = 
-			  { dyn_infos with 
+		      let new_finalize dyn_infos =
+			let new_infos =
+			  { dyn_infos with
 			      info = dyn_infos.info,args
 			  }
-			in 
-			build_proof_args do_finalize new_infos 
-		      in 
+			in
+			build_proof_args do_finalize new_infos
+		      in
 		      build_proof new_finalize {dyn_infos  with info = f } g
 	      end
 	  | Fix _ | CoFix _ ->
 	      error ( "Anonymous local (co)fixpoints are not handled yet")
 
-	  | Prod _ -> error "Prod" 
-	  | LetIn _ -> 
-	      let new_infos = 
-		{ dyn_infos with 
-		    info = nf_betaiotazeta dyn_infos.info 
+	  | Prod _ -> error "Prod"
+	  | LetIn _ ->
+	      let new_infos =
+		{ dyn_infos with
+		    info = nf_betaiotazeta dyn_infos.info
 		}
-	      in 
+	      in
 
-	      tclTHENLIST 
-		[tclMAP 
-		   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) 
+	      tclTHENLIST
+		[tclMAP
+		   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
 		   dyn_infos.rec_hyps;
 		 h_reduce_with_zeta Tacticals.onConcl;
 		 build_proof do_finalize new_infos
 		] g
-	  | Rel _ -> anomaly "Free var in goal conclusion !" 
+	  | Rel _ -> anomaly "Free var in goal conclusion !"
   and build_proof do_finalize dyn_infos g =
 (*     observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
     observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g
   and build_proof_args do_finalize dyn_infos (* f_args'  args *) :tactic =
     fun g ->
-      let (f_args',args) = dyn_infos.info in 
+      let (f_args',args) = dyn_infos.info in
       let tac : tactic =
-	fun g -> 
+	fun g ->
 	match args with
 	  | []  ->
-	      do_finalize {dyn_infos with info = f_args'} g 
+	      do_finalize {dyn_infos with info = f_args'} g
 	  | arg::args ->
 (* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
 (* 			fnl () ++  *)
 (* 			pr_goal (Tacmach.sig_it g) *)
 (* 			); *)
 	      let do_finalize dyn_infos =
-		let new_arg = dyn_infos.info in 
+		let new_arg = dyn_infos.info in
 		(* 		tclTRYD *)
 		(build_proof_args
 		   do_finalize
 		   {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args}
 		)
 	      in
-	      build_proof do_finalize 
+	      build_proof do_finalize
 		{dyn_infos with info = arg }
 		g
       in
       (* observe_tac "build_proof_args" *) (tac ) g
    in
-   let do_finish_proof dyn_infos = 
-     (* tclTRYD *) (clean_goal_with_heq 
+   let do_finish_proof dyn_infos =
+     (* tclTRYD *) (clean_goal_with_heq
       ptes_infos
       finish_proof dyn_infos)
   in
   (* observe_tac "build_proof" *)
-    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) 
+    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
 
 
 
@@ -807,16 +859,16 @@ let build_proof
 
 
 
-(* Proof of principles from structural functions *) 
+(* Proof of principles from structural functions *)
 let is_pte_type t =
-  isSort (snd (decompose_prod t))
-    
+  isSort ((strip_prod t))
+
 let is_pte (_,_,t) = is_pte_type t
 
 
 
 
-type static_fix_info = 
+type static_fix_info =
     {
       idx : int;
       name : identifier;
@@ -824,18 +876,18 @@ type static_fix_info =
       offset : int;
       nb_realargs : int;
       body_with_param : constr;
-      num_in_block : int 
+      num_in_block : int
     }
 
 
 
-let prove_rec_hyp_for_struct fix_info = 
-      (fun  eq_hyps -> tclTHEN 
+let prove_rec_hyp_for_struct fix_info =
+      (fun  eq_hyps -> tclTHEN
 	(rewrite_until_var (fix_info.idx) eq_hyps)
-	(fun g -> 
-	   let _,pte_args = destApp (pf_concl g) in 
-	   let rec_hyp_proof = 
-	     mkApp(mkVar fix_info.name,array_get_start pte_args) 
+	(fun g ->
+	   let _,pte_args = destApp (pf_concl g) in
+	   let rec_hyp_proof =
+	     mkApp(mkVar fix_info.name,array_get_start pte_args)
 	   in
 	   refine rec_hyp_proof g
 	))
@@ -843,38 +895,38 @@ let prove_rec_hyp_for_struct fix_info =
 let prove_rec_hyp fix_info  =
   { proving_tac = prove_rec_hyp_for_struct fix_info
   ;
-    is_valid = fun _ -> true 
+    is_valid = fun _ -> true
   }
 
 
 exception Not_Rec
-    
-let generalize_non_dep hyp g = 
+
+let generalize_non_dep hyp g =
 (*   observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
-  let hyps = [hyp] in 
-  let env = Global.env () in 
-  let hyp_typ = pf_type_of g (mkVar hyp) in 
-  let to_revert,_ = 
+  let hyps = [hyp] in
+  let env = Global.env () in
+  let hyp_typ = pf_type_of g (mkVar hyp) in
+  let to_revert,_ =
     Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
       if List.mem hyp hyps
 	or List.exists (occur_var_in_decl env hyp) keep
 	or occur_var env hyp hyp_typ
-	or Termops.is_section_variable hyp (* should be dangerous *) 
+	or Termops.is_section_variable hyp (* should be dangerous *)
       then (clear,decl::keep)
       else (hyp::clear,keep))
       ~init:([],[]) (pf_env g)
   in
 (*   observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
-  tclTHEN 
+  tclTHEN
     ((* observe_tac "h_generalize" *) (h_generalize  (List.map mkVar to_revert) ))
     ((* observe_tac "thin" *) (thin to_revert))
     g
-  
+
 let id_of_decl (na,_,_) =  (Nameops.out_name na)
 let var_of_decl decl = mkVar (id_of_decl decl)
-let revert idl = 
-  tclTHEN 
-    (generalize (List.map mkVar idl)) 
+let revert idl =
+  tclTHEN
+    (generalize (List.map mkVar idl))
     (thin idl)
 
 let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
@@ -899,7 +951,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 (*   observe (str "f_body_with_params_and_other_fun " ++  pr_lconstr f_body_with_params_and_other_fun); *)
   let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
 (*   observe (str "eq_rhs " ++  pr_lconstr eq_rhs); *)
-  let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) 
+  let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args)
     (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
   let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
   let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
@@ -917,85 +969,85 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 	)
       ]
   in
-  Command.start_proof
+  Lemmas.start_proof
     (*i The next call to mk_equation_id is valid since we are constructing the lemma
       Ensures by: obvious
-      i*) 
+      i*)
     (mk_equation_id f_id)
     (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
     lemma_type
     (fun _ _ -> ());
   Pfedit.by (prove_replacement);
-  Command.save_named false
+  Lemmas.save_named false
+
 
 
 
-  
 let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
-  let equation_lemma = 
-    try 
-      let finfos = find_Function_infos (destConst f) in 
+  let equation_lemma =
+    try
+      let finfos = find_Function_infos (destConst f) in
       mkConst (Option.get finfos.equation_lemma)
-    with (Not_found | Option.IsNone as e) -> 
-      let f_id = id_of_label (con_label (destConst f)) in 
+    with (Not_found | Option.IsNone as e) ->
+      let f_id = id_of_label (con_label (destConst f)) in
       (*i The next call to mk_equation_id is valid since we will construct the lemma
 	Ensures by: obvious
-	i*) 
-      let equation_lemma_id = (mk_equation_id f_id) in 
+	i*)
+      let equation_lemma_id = (mk_equation_id f_id) in
       generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
       let _ =
-	match e with 
-	  | Option.IsNone -> 
-	      let finfos = find_Function_infos (destConst f) in 
-	      update_Function 
+	match e with
+	  | Option.IsNone ->
+	      let finfos = find_Function_infos (destConst f) in
+	      update_Function
 		{finfos with
-		   equation_lemma = Some (match Nametab.locate (make_short_qualid equation_lemma_id) with
+		   equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
 					      ConstRef c -> c
-					    | _ -> Util.anomaly "Not a constant" 
+					    | _ -> Util.anomaly "Not a constant"
 					 )
 		}
-	  | _ -> () 
+	  | _ -> ()
 
-      in 
+      in
       Tacinterp.constr_of_id (pf_env g) equation_lemma_id
   in
   let nb_intro_to_do = nb_prod (pf_concl g) in
     tclTHEN
       (tclDO nb_intro_to_do intro)
       (
-	fun g' -> 
-	  let just_introduced = nLastHyps nb_intro_to_do g' in 
-	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in 
+	fun g' ->
+	  let just_introduced = nLastDecls nb_intro_to_do g' in
+	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
 	  tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
       )
       g
 
 let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic =
-  fun g -> 
-    let princ_type = pf_concl g in 
-    let princ_info = compute_elim_sig princ_type in 
-    let fresh_id = 
-      let avoid = ref (pf_ids_of_hyps g) in 
-      (fun na -> 
-	 let new_id = 
-	   match na with 
-	       Name id -> fresh_id !avoid (string_of_id id) 
+  fun g ->
+    let princ_type = pf_concl g in
+    let princ_info = compute_elim_sig princ_type in
+    let fresh_id =
+      let avoid = ref (pf_ids_of_hyps g) in
+      (fun na ->
+	 let new_id =
+	   match na with
+	       Name id -> fresh_id !avoid (string_of_id id)
 	     | Anonymous -> fresh_id !avoid "H"
 	 in
-	 avoid := new_id :: !avoid; 
+	 avoid := new_id :: !avoid;
 	 (Name new_id)
       )
     in
-    let fresh_decl = 
-      (fun (na,b,t) -> 
+    let fresh_decl =
+      (fun (na,b,t) ->
 	 (fresh_id na,b,t)
       )
     in
-    let princ_info : elim_scheme = 
-      { princ_info with 
+    let princ_info : elim_scheme =
+      { princ_info with
 	  params = List.map fresh_decl princ_info.params;
-	  predicates = List.map fresh_decl princ_info.predicates; 
-	  branches = List.map fresh_decl princ_info.branches; 
+	  predicates = List.map fresh_decl princ_info.predicates;
+	  branches = List.map fresh_decl princ_info.branches;
 	  args = List.map fresh_decl princ_info.args
       }
     in
@@ -1011,15 +1063,15 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	| None -> error ( "Cannot define a principle over an axiom ")
     in
     let fbody = get_body fnames.(fun_num) in
-    let f_ctxt,f_body = decompose_lam fbody in 
-    let f_ctxt_length = List.length f_ctxt in 
-    let diff_params = princ_info.nparams - f_ctxt_length in 
-    let full_params,princ_params,fbody_with_full_params = 
+    let f_ctxt,f_body = decompose_lam fbody in
+    let f_ctxt_length = List.length f_ctxt in
+    let diff_params = princ_info.nparams - f_ctxt_length in
+    let full_params,princ_params,fbody_with_full_params =
       if diff_params > 0
-      then 
-	let princ_params,full_params = 
-	  list_chop  diff_params princ_info.params 
-	in 
+      then
+	let princ_params,full_params =
+	  list_chop  diff_params princ_info.params
+	in
 	(full_params, (* real params *)
 	 princ_params, (* the params of the principle which are not params of the function *)
 	 substl (* function instanciated with real params *)
@@ -1027,9 +1079,9 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	   f_body
 	)
       else
-	let f_ctxt_other,f_ctxt_params = 
-	  list_chop (- diff_params) f_ctxt in 
-	let f_body = compose_lam f_ctxt_other f_body in 
+	let f_ctxt_other,f_ctxt_params =
+	  list_chop (- diff_params) f_ctxt in
+	let f_body = compose_lam f_ctxt_other f_body in
 	(princ_info.params, (* real params *)
 	 [],(* all params are full params *)
 	 substl (* function instanciated with real params *)
@@ -1048,32 +1100,32 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 (*     observe (str "fbody_with_full_params := " ++  *)
 (* 	       pr_lconstr fbody_with_full_params *)
 (* 	    );  *)
-    let all_funs_with_full_params = 
+    let all_funs_with_full_params =
       Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs
     in
-    let fix_offset = List.length princ_params in 
-    let ptes_to_fix,infos = 
-      match kind_of_term fbody_with_full_params with 
-	| Fix((idxs,i),(names,typess,bodies)) -> 
-	    let bodies_with_all_params = 
-	      Array.map 
-		(fun body -> 
+    let fix_offset = List.length princ_params in
+    let ptes_to_fix,infos =
+      match kind_of_term fbody_with_full_params with
+	| Fix((idxs,i),(names,typess,bodies)) ->
+	    let bodies_with_all_params =
+	      Array.map
+		(fun body ->
 		   Reductionops.nf_betaiota Evd.empty
 		     (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body,
 			      List.rev_map var_of_decl princ_params))
 		)
 		bodies
 	    in
-	    let info_array = 
-	      Array.mapi 
-		(fun i types -> 
+	    let info_array =
+	      Array.mapi
+		(fun i types ->
 		   let types = prod_applist types (List.rev_map var_of_decl princ_params) in
 		   { idx = idxs.(i)  - fix_offset;
 		     name = Nameops.out_name (fresh_id names.(i));
-		     types = types; 
+		     types = types;
 		     offset = fix_offset;
-		     nb_realargs = 
-		       List.length 
+		     nb_realargs =
+		       List.length
 			 (fst (decompose_lam bodies.(i))) - fix_offset;
 		     body_with_param = bodies_with_all_params.(i);
 		     num_in_block = i
@@ -1081,65 +1133,65 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		)
 		typess
 	    in
-	    let pte_to_fix,rev_info = 
-	      list_fold_left_i 
-		(fun i (acc_map,acc_info) (pte,_,_) -> 
-		   let infos = info_array.(i) in 
-		   let type_args,_ = decompose_prod infos.types in 
-		   let nargs = List.length type_args in 
+	    let pte_to_fix,rev_info =
+	      list_fold_left_i
+		(fun i (acc_map,acc_info) (pte,_,_) ->
+		   let infos = info_array.(i) in
+		   let type_args,_ = decompose_prod infos.types in
+		   let nargs = List.length type_args in
 		   let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in
 		   let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in
 		   let app_f = mkApp(f,first_args) in
-		   let pte_args = (Array.to_list first_args)@[app_f] in 
-		   let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in 
-		   let body_with_param,num = 
-		     let body = get_body fnames.(i) in 
-		     let body_with_full_params = 
+		   let pte_args = (Array.to_list first_args)@[app_f] in
+		   let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in
+		   let body_with_param,num =
+		     let body = get_body fnames.(i) in
+		     let body_with_full_params =
 		       Reductionops.nf_betaiota Evd.empty (
 			 applist(body,List.rev_map var_of_decl full_params))
 		     in
-		     match kind_of_term body_with_full_params with 
-		       | Fix((_,num),(_,_,bs)) -> 
+		     match kind_of_term body_with_full_params with
+		       | Fix((_,num),(_,_,bs)) ->
 			       Reductionops.nf_betaiota Evd.empty
 				 (
 				   (applist
-				      (substl 
-					 (List.rev 
-					    (Array.to_list all_funs_with_full_params)) 
+				      (substl
+					 (List.rev
+					    (Array.to_list all_funs_with_full_params))
 					 bs.(num),
 				       List.rev_map var_of_decl princ_params))
 				 ),num
 			 | _ -> error "Not a mutual block"
 		   in
-		   let info = 
-		     {infos with 
+		   let info =
+		     {infos with
 			types = compose_prod type_args app_pte;
 			 body_with_param = body_with_param;
 			 num_in_block = num
 		     }
-		   in 
+		   in
 (* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++  *)
 (* 			      str " to " ++ Ppconstr.pr_id info.name); *)
 		   (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
 		   )
-		0 
-		(Idmap.empty,[]) 
+		0
+		(Idmap.empty,[])
 		(List.rev princ_info.predicates)
 	    in
 	    pte_to_fix,List.rev rev_info
 	| _ -> Idmap.empty,[]
     in
-    let mk_fixes : tactic = 
-      let pre_info,infos = list_chop fun_num infos in 
-      match pre_info,infos with 
+    let mk_fixes : tactic =
+      let pre_info,infos = list_chop fun_num infos in
+      match pre_info,infos with
 	| [],[] -> tclIDTAC
-	| _, this_fix_info::others_infos -> 
+	| _, this_fix_info::others_infos ->
 	    let other_fix_infos =
 	      List.map
-		(fun fi -> fi.name,fi.idx + 1 ,fi.types) 
+		(fun fi -> fi.name,fi.idx + 1 ,fi.types)
 		(pre_info@others_infos)
-	    in 
-	    if other_fix_infos = [] 
+	    in
+	    if other_fix_infos = []
 	    then
 	      (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
 	    else
@@ -1148,34 +1200,34 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	| _ -> anomaly "Not a valid information"
     in
     let first_tac : tactic = (* every operations until fix creations *)
-      tclTHENSEQ 
-	[ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); 
-	  (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); 
-	  (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); 
+      tclTHENSEQ
+	[ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params));
+	  (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates));
+	  (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches));
 	  (* observe_tac "building fixes" *) mk_fixes;
 	]
     in
-    let intros_after_fixes : tactic = 
-      fun gl -> 
-	let ctxt,pte_app =  (Sign.decompose_prod_assum (pf_concl gl)) in
+    let intros_after_fixes : tactic =
+      fun gl ->
+	let ctxt,pte_app =  (decompose_prod_assum (pf_concl gl)) in
 	let pte,pte_args = (decompose_app pte_app) in
 	try
-	  let pte = try destVar pte with _ -> anomaly "Property is not a variable"  in 
+	  let pte = try destVar pte with _ -> anomaly "Property is not a variable"  in
 	  let fix_info = Idmap.find  pte ptes_to_fix in
-	  let nb_args = fix_info.nb_realargs in 
+	  let nb_args = fix_info.nb_realargs in
 	  tclTHENSEQ
 	    [
 	      (* observe_tac ("introducing args") *) (tclDO nb_args intro);
 	      (fun g -> (* replacement of the function by its body *)
-		 let args = nLastHyps nb_args g in 
+		 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 dyn_infos = 
+		 let dyn_infos =
 		   {
 		     nb_rec_hyps = -100;
 		     rec_hyps = [];
-		     info = 
+		     info =
 		       Reductionops.nf_betaiota Evd.empty
 			 (applist(fix_body,List.rev_map mkVar args_id));
 		     eq_hyps = []
@@ -1184,42 +1236,42 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		 tclTHENSEQ
 		   [
 (* 		     observe_tac "do_replace"  *)
-		       (do_replace 
-			  full_params 
-			  (fix_info.idx + List.length princ_params) 
+		       (do_replace
+			  full_params
+			  (fix_info.idx + List.length princ_params)
 			  (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
-			  (all_funs.(fix_info.num_in_block)) 
-			  fix_info.num_in_block 
+			  (all_funs.(fix_info.num_in_block))
+			  fix_info.num_in_block
 			  all_funs
 		       );
 (* 		     observe_tac "do_replace"  *)
 (* 		       (do_replace princ_info.params fix_info.idx args_id *)
 (* 			  (List.hd (List.rev pte_args)) fix_body); *)
-		     let do_prove = 
-		       build_proof 
+		     let do_prove =
+		       build_proof
 			 interactive_proof
-			 (Array.to_list fnames) 
+			 (Array.to_list fnames)
 			 (Idmap.map prove_rec_hyp ptes_to_fix)
 		     in
-		     let prove_tac branches  = 
-		       let dyn_infos = 
-			 {dyn_infos with 
+		     let prove_tac branches  =
+		       let dyn_infos =
+			 {dyn_infos with
 			    rec_hyps = branches;
 			    nb_rec_hyps = List.length branches
 			 }
 		       in
-		       (* observe_tac "cleaning" *) (clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix) 
-			 do_prove 
+		       observe_tac "cleaning" (clean_goal_with_heq
+			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 do_prove
 			 dyn_infos)
 		     in
 (* 		     observe (str "branches := " ++ *)
 (* 				prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++  fnl () ++ *)
 (* 			   str "args := " ++ prlist_with_sep spc Ppconstr.pr_id  args_id *)
-			   
+
 (* 			   ); *)
-		     (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac 
-		       (List.rev_map id_of_decl princ_info.branches) 
+		     (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac
+		       (List.rev_map id_of_decl princ_info.branches)
 		       (List.rev args_id))
 		   ]
 		   g
@@ -1231,14 +1283,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	    [
 	      tclDO nb_args intro;
 	      (fun g -> (* replacement of the function by its body *)
-		 let args = nLastHyps nb_args g in 
+		 let args = nLastDecls nb_args g in
 		 let args_id = List.map (fun (id,_,_) -> id) args in
-		 let dyn_infos = 
+		 let dyn_infos =
 		   {
 		     nb_rec_hyps = -100;
 		     rec_hyps = [];
-		     info = 
-		       Reductionops.nf_betaiota Evd.empty 
+		     info =
+		       Reductionops.nf_betaiota Evd.empty
 			 (applist(fbody_with_full_params,
 				  (List.rev_map var_of_decl princ_params)@
 				    (List.rev_map mkVar args_id)
@@ -1249,44 +1301,44 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
 		 tclTHENSEQ
 		   [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
-		    let do_prove = 
-		      build_proof 
+		    let do_prove =
+		      build_proof
 			interactive_proof
-			(Array.to_list fnames) 
+			(Array.to_list fnames)
 			 (Idmap.map prove_rec_hyp ptes_to_fix)
 		    in
-		    let prove_tac branches  = 
-		      let dyn_infos = 
-			 {dyn_infos with 
+		    let prove_tac branches  =
+		      let dyn_infos =
+			 {dyn_infos with
 			    rec_hyps = branches;
 			    nb_rec_hyps = List.length branches
 			 }
 		      in
 		       clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix) 
-			 do_prove 
+			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 do_prove
 			 dyn_infos
 		    in
-		    instanciate_hyps_with_args prove_tac 
-		       (List.rev_map id_of_decl princ_info.branches) 
+		    instanciate_hyps_with_args prove_tac
+		       (List.rev_map id_of_decl princ_info.branches)
 		      (List.rev args_id)
 		   ]
 		   g
 	      )
-	    ] 
+	    ]
 	  gl
     in
-    tclTHEN 
+    tclTHEN
       first_tac
       intros_after_fixes
       g
-	    
 
 
 
 
 
-(* Proof of principles of general functions *) 
+
+(* Proof of principles of general functions *)
 let h_id = Recdef.h_id
 and hrec_id = Recdef.hrec_id
 and acc_inv_id = Recdef.acc_inv_id
@@ -1307,7 +1359,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
     | None -> anomaly "No tcc proof !!"
     | Some lemma ->
 	fun gls ->
-(* 	  let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in *)
+(* 	  let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *)
 (* 	  let ids = hid::pf_ids_of_hyps gls in  *)
 	  tclTHENSEQ
 	    [
@@ -1325,73 +1377,73 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
 	    gls
 
 
-let backtrack_eqs_until_hrec hrec eqs : tactic = 
-  fun gls -> 
-    let eqs = List.map mkVar eqs in 
-    let rewrite = 
+let backtrack_eqs_until_hrec hrec eqs : tactic =
+  fun gls ->
+    let eqs = List.map mkVar eqs in
+    let rewrite =
       tclFIRST (List.map Equality.rewriteRL eqs )
-    in 
-    let _,hrec_concl  = decompose_prod (pf_type_of gls (mkVar hrec)) in 
-    let f_app = array_last (snd (destApp hrec_concl)) in 
-    let f =  (fst (destApp f_app)) in 
-    let rec backtrack : tactic = 
-      fun g -> 
-	let f_app = array_last (snd (destApp (pf_concl g))) in 
-	match kind_of_term f_app with 
+    in
+    let _,hrec_concl  = decompose_prod (pf_type_of gls (mkVar hrec)) in
+    let f_app = array_last (snd (destApp hrec_concl)) in
+    let f =  (fst (destApp f_app)) in
+    let rec backtrack : tactic =
+      fun g ->
+	let f_app = array_last (snd (destApp (pf_concl g))) in
+	match kind_of_term f_app with
 	  | App(f',_) when eq_constr f' f -> tclIDTAC g
 	  | _ -> tclTHEN rewrite backtrack g
     in
     backtrack gls
 
-    
-    
-let build_clause eqs = 
+
+
+let build_clause eqs =
   {
-    Tacexpr.onhyps = 
-      Some (List.map 
+    Tacexpr.onhyps =
+      Some (List.map
 	      (fun id -> (Rawterm.all_occurrences_expr,id),InHyp)
 	      eqs
 	   );
-    Tacexpr.concl_occs = Rawterm.no_occurrences_expr 
+    Tacexpr.concl_occs = Rawterm.no_occurrences_expr
   }
 
-let rec rewrite_eqs_in_eqs eqs = 
-  match eqs with 
+let rec rewrite_eqs_in_eqs eqs =
+  match eqs with
     | [] -> tclIDTAC
-    | eq::eqs -> 
-	
-	  tclTHEN 
-	    (tclMAP 
-	       (fun id gl -> 
-		  observe_tac 
-		    (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) 
-		    (tclTRY (Equality.general_rewrite_in true all_occurrences id (mkVar eq) false))
+    | eq::eqs ->
+
+	  tclTHEN
+	    (tclMAP
+	       (fun id gl ->
+		  observe_tac
+		    (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id))
+		    (tclTRY (Equality.general_rewrite_in true all_occurrences (* dep proofs also: *) true id (mkVar eq) false))
 		    gl
-	       ) 
+	       )
 	       eqs
 	    )
-	    (rewrite_eqs_in_eqs eqs) 
+	    (rewrite_eqs_in_eqs eqs)
 
-let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = 
+let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
   fun gls ->
-    (tclTHENSEQ 
+    (tclTHENSEQ
        [
 	 backtrack_eqs_until_hrec hrec eqs;
 	 (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *)
 	 (tclTHENS  (* We must have exactly ONE subgoal !*)
 	    (apply (mkVar hrec))
-	    [ tclTHENSEQ 
+	    [ tclTHENSEQ
 		[
 		  keep (tcc_hyps@eqs);
 		  apply (Lazy.force acc_inv);
-		  (fun g -> 
-		     if is_mes 
-		     then 
-		       unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g 
+		  (fun g ->
+		     if is_mes
+		     then
+		       unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
 		     else tclIDTAC g
 		  );
 		  observe_tac "rew_and_finish"
-		    (tclTHENLIST 
+		    (tclTHENLIST
 		       [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs));
 			observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs);
 			 (observe_tac "finishing using"
@@ -1411,7 +1463,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 	    ])
        ])
       gls
-      
+
 
 let is_valid_hypothesis predicates_name =
   let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
@@ -1426,78 +1478,78 @@ let is_valid_hypothesis predicates_name =
   in
   let rec is_valid_hypothesis typ =
     is_pte typ ||
-      match kind_of_term typ with 
+      match kind_of_term typ with
 	| Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ'
-	| _ -> false 
+	| _ -> false
   in
-  is_valid_hypothesis 
+  is_valid_hypothesis
 
 let prove_principle_for_gen
     (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
-    rec_arg_num rec_arg_type relation gl = 
-  let princ_type = pf_concl gl in 
-  let princ_info = compute_elim_sig princ_type in 
-  let fresh_id = 
-    let avoid = ref (pf_ids_of_hyps gl) in 
-    fun na -> 
-      let new_id = 
-	  match na with 
-	    | Name id -> fresh_id !avoid (string_of_id id) 
-	    | Anonymous -> fresh_id !avoid "H" 
+    rec_arg_num rec_arg_type relation gl =
+  let princ_type = pf_concl gl in
+  let princ_info = compute_elim_sig princ_type in
+  let fresh_id =
+    let avoid = ref (pf_ids_of_hyps gl) in
+    fun na ->
+      let new_id =
+	  match na with
+	    | Name id -> fresh_id !avoid (string_of_id id)
+	    | Anonymous -> fresh_id !avoid "H"
       in
       avoid := new_id :: !avoid;
       Name new_id
   in
   let fresh_decl (na,b,t) = (fresh_id na,b,t) in
-  let princ_info : elim_scheme = 
-    { princ_info with 
+  let princ_info : elim_scheme =
+    { princ_info with
 	params = List.map fresh_decl princ_info.params;
-	predicates = List.map fresh_decl princ_info.predicates; 
-	branches = List.map fresh_decl princ_info.branches; 
+	predicates = List.map fresh_decl princ_info.predicates;
+	branches = List.map fresh_decl princ_info.branches;
 	args = List.map fresh_decl princ_info.args
     }
   in
-  let wf_tac = 
-    if is_mes 
-    then 
+  let wf_tac =
+    if is_mes
+    then
       (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None)
     else fun _ -> prove_with_tcc tcc_lemma_ref []
   in
-  let real_rec_arg_num = rec_arg_num - princ_info.nparams in 
-  let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in 
+  let real_rec_arg_num = rec_arg_num - princ_info.nparams in
+  let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in
 (*   observe ( *)
 (*     str "princ_type := " ++ pr_lconstr  princ_type ++ fnl () ++ *)
 (*     str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++  *)
-      
+
 (*       str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++  *)
 (*     str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++  *)
 (* 	     str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *)
 (* 	     str "npost_rec_arg := " ++ int npost_rec_arg ); *)
-  let (post_rec_arg,pre_rec_arg) = 
+  let (post_rec_arg,pre_rec_arg) =
     Util.list_chop npost_rec_arg princ_info.args
   in
-  let rec_arg_id = 
-    match List.rev post_rec_arg with 
-      | (Name id,_,_)::_ -> id 
-      | _ -> assert false 
+  let rec_arg_id =
+    match List.rev post_rec_arg with
+      | (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 relation = substl subst_constrs relation in 
-  let input_type = substl subst_constrs rec_arg_type in 
-  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in 
-  let acc_rec_arg_id = 
+  let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
+  let relation = substl subst_constrs relation in
+  let input_type = substl subst_constrs rec_arg_type in
+  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in
+  let acc_rec_arg_id =
     Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
-  in 
-  let revert l = 
-    tclTHEN (h_generalize (List.map mkVar l)) (clear l) 
   in
-  let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in 
-  let prove_rec_arg_acc g = 
+  let revert l =
+    tclTHEN (h_generalize (List.map mkVar l)) (clear l)
+  in
+  let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
+  let prove_rec_arg_acc g =
       ((* observe_tac "prove_rec_arg_acc"  *)
 	 (tclCOMPLETE
 	    (tclTHEN
-	       (assert_by (Name wf_thm_id)  
+	       (assert_by (Name wf_thm_id)
 		  (mkApp (delayed_force well_founded,[|input_type;relation|]))
 		  (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))
 	       (
@@ -1511,8 +1563,8 @@ let prove_principle_for_gen
       g
   in
   let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
-  let lemma = 
-    match !tcc_lemma_ref with 
+  let lemma =
+    match !tcc_lemma_ref with
      | None -> anomaly ( "No tcc proof !!")
      | Some lemma -> lemma
   in
@@ -1527,11 +1579,11 @@ let prove_principle_for_gen
 (*                f::(list_diff r check_list) *)
 (*   in *)
   let tcc_list = ref [] in
-  let start_tac gls = 
-    let hyps = pf_ids_of_hyps gls in 
-      let hid = 
-	next_global_ident_away true 
-	  (id_of_string "prov") 
+  let start_tac gls =
+    let hyps = pf_ids_of_hyps gls in
+      let hid =
+	next_ident_away_in_goal
+	  (id_of_string "prov")
 	  hyps
       in
       tclTHENSEQ
@@ -1539,12 +1591,12 @@ let prove_principle_for_gen
 	  generalize [lemma];
 	  h_intro hid;
 	  Elim.h_decompose_and (mkVar hid);
-	  (fun g -> 
-	     let new_hyps = pf_ids_of_hyps g in 
+	  (fun g ->
+	     let new_hyps = pf_ids_of_hyps g in
 	     tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
 	     if !tcc_list = []
-	     then 
-	       begin 
+	     then
+	       begin
 		 tcc_list := [hid];
 		 tclIDTAC g
 	       end
@@ -1554,10 +1606,10 @@ let prove_principle_for_gen
 	  gls
   in
   tclTHENSEQ
-    [ 	      
+    [
       observe_tac "start_tac" start_tac;
-      h_intros 
-	(List.rev_map (fun (na,_,_) -> Nameops.out_name na) 
+      h_intros
+	(List.rev_map (fun (na,_,_) -> Nameops.out_name na)
 	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
 	);
       (* observe_tac "" *) (assert_by
@@ -1568,24 +1620,24 @@ 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 " *) (h_fix (Some fix_id) (List.length args_ids + 1)); 
+      (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1));
 (*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *)
       h_intros (List.rev (acc_rec_arg_id::args_ids));
       Equality.rewriteLR (mkConst eq_ref);
-      (* observe_tac "finish" *) (fun gl' -> 
-	 let body = 
-	   let _,args = destApp (pf_concl gl') in 
+      (* observe_tac "finish" *) (fun gl' ->
+	 let body =
+	   let _,args = destApp (pf_concl gl') in
 	   array_last args
 	 in
-	 let body_info rec_hyps = 
+	 let body_info rec_hyps =
 	   {
 	     nb_rec_hyps = List.length rec_hyps;
 	     rec_hyps = rec_hyps;
 	     eq_hyps = [];
 	     info = body
 	   }
-	 in 
-	 let acc_inv = 
+	 in
+	 let acc_inv =
 	   lazy (
 	     mkApp (
 	       delayed_force acc_inv_id,
@@ -1594,12 +1646,12 @@ let prove_principle_for_gen
 	   )
 	 in
 	 let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar  acc_rec_arg_id|])) in
-	 let predicates_names = 
+	 let predicates_names =
 	   List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
 	 in
-	 let pte_info = 
+	 let pte_info =
 	   { proving_tac =
-	       (fun eqs -> 
+	       (fun eqs ->
 (* 		  msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id  !tcc_list); *)
 (* 		  msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *)
 (* 		  msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *)
@@ -1607,47 +1659,47 @@ let prove_principle_for_gen
 (* 		  msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id  eqs); *)
 
 		  (* observe_tac "new_prove_with_tcc"  *)
-		    (new_prove_with_tcc  
-		       is_mes acc_inv fix_id  
-		         
-		       (!tcc_list@(List.map 
-			   (fun (na,_,_) -> (Nameops.out_name na)) 
+		    (new_prove_with_tcc
+		       is_mes acc_inv fix_id
+
+		       (!tcc_list@(List.map
+			   (fun (na,_,_) -> (Nameops.out_name na))
 			   (princ_info.args@princ_info.params)
 			)@ ([acc_rec_arg_id])) eqs
 		    )
-	       
+
 	       );
 	     is_valid = is_valid_hypothesis predicates_names
 	   }
 	 in
-	 let ptes_info : pte_info Idmap.t = 
+	 let ptes_info : pte_info Idmap.t =
 	   List.fold_left
-	     (fun map pte_id -> 
-		Idmap.add pte_id 
-		  pte_info			       
+	     (fun map pte_id ->
+		Idmap.add pte_id
+		  pte_info
 		  map
 	     )
 	     Idmap.empty
 	     predicates_names
 	 in
-	 let make_proof rec_hyps = 
-	   build_proof 
-	     false 
+	 let make_proof rec_hyps =
+	   build_proof
+	     false
 	     [f_ref]
 	     ptes_info
 	     (body_info rec_hyps)
 	 in
 	 (* observe_tac "instanciate_hyps_with_args"  *)
-	   (instanciate_hyps_with_args 
+	   (instanciate_hyps_with_args
 	      make_proof
 	      (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
 	      (List.rev args_ids)
 	   )
 	   gl'
       )
-			   
+
     ]
-    gl    
+    gl
 
 
 
diff --git a/contrib/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli
index 62eb528e..ff98f2b9 100644
--- a/contrib/funind/functional_principles_proofs.mli
+++ b/plugins/funind/functional_principles_proofs.mli
@@ -6,11 +6,11 @@ val prove_princ_for_struct :
   int -> constant array -> constr array -> int -> Tacmach.tactic
 
 
-val prove_principle_for_gen : 
+val prove_principle_for_gen :
   constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *)
   constr option ref -> (* a pointer to the obligation proofs lemma *)
   bool -> (* is that function uses measure *)
-  int -> (* the number of recursive argument *) 
+  int -> (* the number of recursive argument *)
   types -> (* the type of the recursive argument *)
   constr -> (* the wf relation used to prove the function *)
   Tacmach.tactic
diff --git a/contrib/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index b03bdf31..b756492b 100644
--- a/contrib/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,8 +1,9 @@
 open Printer
 open Util
 open Term
-open Termops 
-open Names 
+open Termops
+open Namegen
+open Names
 open Declarations
 open Pp
 open Entries
@@ -19,102 +20,102 @@ exception Toberemoved_with_rel of int*constr
 exception Toberemoved
 
 
-let pr_elim_scheme el = 
-  let env = Global.env () in 
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
-  let env = Environ.push_rel_context el.params env in 
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
-  let env = Environ.push_rel_context el.predicates env in 
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
-  let env = Environ.push_rel_context el.branches env in 
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
-  let env = Environ.push_rel_context el.args env in 
+let pr_elim_scheme el =
+  let env = Global.env () in
+  let msg = str "params := " ++ Printer.pr_rel_context env el.params in
+  let env = Environ.push_rel_context el.params env in
+  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
+  let env = Environ.push_rel_context el.predicates env in
+  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
+  let env = Environ.push_rel_context el.branches env in
+  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
+  let env = Environ.push_rel_context el.args env in
   msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
 
 
-let observe s = 
-  if do_observe () 
-  then Pp.msgnl s 
+let observe s =
+  if do_observe ()
+  then Pp.msgnl s
 
 
-let pr_elim_scheme el = 
-  let env = Global.env () in 
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
-  let env = Environ.push_rel_context el.params env in 
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
-  let env = Environ.push_rel_context el.predicates env in 
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
-  let env = Environ.push_rel_context el.branches env in 
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
-  let env = Environ.push_rel_context el.args env in 
+let pr_elim_scheme el =
+  let env = Global.env () in
+  let msg = str "params := " ++ Printer.pr_rel_context env el.params in
+  let env = Environ.push_rel_context el.params env in
+  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
+  let env = Environ.push_rel_context el.predicates env in
+  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
+  let env = Environ.push_rel_context el.branches env in
+  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
+  let env = Environ.push_rel_context el.args env in
   msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
 
 
-let observe s = 
-  if do_observe () 
-  then Pp.msgnl s 
+let observe s =
+  if do_observe ()
+  then Pp.msgnl s
 
-(* 
-   Transform an inductive induction principle into 
+(*
+   Transform an inductive induction principle into
    a functional one
-*)  
+*)
 let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
-  let princ_type_info = compute_elim_sig princ_type in 
-  let env = Global.env () in 
+  let princ_type_info = compute_elim_sig princ_type in
+  let env = Global.env () in
   let env_with_params = Environ.push_rel_context princ_type_info.params env in
   let tbl = Hashtbl.create 792 in
-  let rec change_predicates_names (avoid:identifier list) (predicates:Sign.rel_context)  : Sign.rel_context = 
-    match predicates with 
+  let rec change_predicates_names (avoid:identifier list) (predicates:rel_context)  : rel_context =
+    match predicates with
     | [] -> []
-    |(Name x,v,t)::predicates -> 
-       let id =  Nameops.next_ident_away x avoid in 
+    |(Name x,v,t)::predicates ->
+       let id =  Namegen.next_ident_away x avoid in
        Hashtbl.add tbl id x;
        (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
     | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
   in
   let avoid = (Termops.ids_of_context env_with_params ) in
-  let princ_type_info = 
+  let princ_type_info =
     { princ_type_info with
 	predicates = change_predicates_names avoid princ_type_info.predicates
     }
-  in 
+  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 (x,_,t) =
     let new_sort = sorts.(i) in
-    let args,_ = decompose_prod t in 
-    let real_args = 
-      if princ_type_info.indarg_in_concl 
-      then List.tl args 
+    let args,_ = decompose_prod t 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) 
+    Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
   in
-  let new_predicates = 
+  let new_predicates =
     list_map_i
-      change_predicate_sort 
+      change_predicate_sort
       0
       princ_type_info.predicates
   in
   let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
-  let rel_as_kn = 
+  let rel_as_kn =
     fst (match princ_type_info.indref with
-	   | Some (Libnames.IndRef ind) -> ind 
+	   | Some (Libnames.IndRef ind) -> ind
 	   | _ -> error "Not a valid predicate"
 	)
   in
   let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
-  let is_pte = 
-    let set = List.fold_right Idset.add ptes_vars Idset.empty in 
-    fun t -> 
-      match kind_of_term t with 
-	| Var id -> Idset.mem id set 
-	| _ -> false 
-  in
-  let pre_princ = 
-    it_mkProd_or_LetIn 
+  let is_pte =
+    let set = List.fold_right Idset.add ptes_vars Idset.empty in
+    fun t ->
+      match kind_of_term t with
+	| Var id -> Idset.mem id set
+	| _ -> false
+  in
+  let pre_princ =
+    it_mkProd_or_LetIn
       ~init:
-      (it_mkProd_or_LetIn 
+      (it_mkProd_or_LetIn
 	 ~init:(Option.fold_right
 			   mkProd_or_LetIn
 			   princ_type_info.indarg
@@ -139,7 +140,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   in
   let dummy_var = mkVar (id_of_string "________") in
   let mk_replacement c i args =
-    let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in 
+    let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in
 (*     observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res); *)
     res
   in
@@ -168,10 +169,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	    let num = get_fun_num f in
 	    raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
 	| App(f,args) ->
-	    let args = 
-	      if is_pte f && remove 
-	      then array_get_start args 
-	      else args 
+	    let args =
+	      if is_pte f && remove
+	      then array_get_start args
+	      else args
 	    in
 	    let new_args,binders_to_remove =
 	      Array.fold_right (compute_new_princ_type_with_acc remove env)
@@ -193,7 +194,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 (* 	      pr_lconstr_env env new_princ_type ++ fnl ()) *)
 (* 	| _ -> () in *)
     res
-	
+
   and compute_new_princ_type_for_binder remove bind_fun env x t b =
     begin
       try
@@ -240,7 +241,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	      (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v)
 	      (List.map pop binders_to_remove_from_b)
 	  )
-	
+
       with
 	| Toberemoved ->
 (* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
@@ -257,54 +258,54 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
   in
 (*   observe (str "Computing new principe from " ++ pr_lconstr_env  env_with_params_and_predicates pre_princ); *)
-  let pre_res,_ = 
-    compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ 
-  in 
-  let pre_res = 
-    replace_vars 
+  let pre_res,_ =
+    compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ
+  in
+  let pre_res =
+    replace_vars
       (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
       (lift (List.length ptes_vars) pre_res)
   in
-  it_mkProd_or_LetIn  	 
-    ~init:(it_mkProd_or_LetIn 
-	     ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) 
+  it_mkProd_or_LetIn
+    ~init:(it_mkProd_or_LetIn
+	     ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
 			      new_predicates)
 	  )
     princ_type_info.params
-    
-  
 
-let change_property_sort toSort princ princName = 
-  let princ_info = compute_elim_sig princ in 
-  let change_sort_in_predicate (x,v,t) = 
+
+
+let change_property_sort toSort princ princName =
+  let princ_info = compute_elim_sig princ in
+  let change_sort_in_predicate (x,v,t) =
     (x,None,
-     let args,_ = decompose_prod t in 
+     let args,_ = decompose_prod t in
      compose_prod args (mkSort toSort)
     )
-  in 
-  let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in 
-  let init = 
-    let nargs =  (princ_info.nparams + (List.length  princ_info.predicates)) in 
+  in
+  let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in
+  let init =
+    let nargs =  (princ_info.nparams + (List.length  princ_info.predicates)) in
     mkApp(princName_as_constr,
 	  Array.init nargs
 	    (fun i -> mkRel (nargs - i )))
   in
   it_mkLambda_or_LetIn
-    ~init: 
-    (it_mkLambda_or_LetIn ~init 
+    ~init:
+    (it_mkLambda_or_LetIn ~init
        (List.map change_sort_in_predicate princ_info.predicates)
     )
     princ_info.params
-    
 
-let pp_dur time time' = 
+
+let pp_dur time time' =
   str (string_of_float (System.time_difference time time'))
 
 (* let qed () = save_named true  *)
-let defined () = 
-  try 
-    Command.save_named false 
-  with 
+let defined () =
+  try
+    Lemmas.save_named false
+  with
     | UserError("extract_proof",msg) ->
 	Util.errorlabstrm
 	  "defined"
@@ -318,7 +319,7 @@ let defined () =
 
 let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
   (* First we get the type of the old graph principle *)
-  let mutr_nparams = (compute_elim_sig old_princ_type).nparams in 
+  let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
   (*   let time1 = System.get_time ()  in *)
   let new_principle_type =
     compute_new_princ_type_from_rel
@@ -328,12 +329,12 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro
   in
   (*    let time2 = System.get_time ()  in *)
   (*    Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
-  (*    observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *)
+     observe (str "new_principle_type : " ++ pr_lconstr new_principle_type);
   let new_princ_name =
-    next_global_ident_away true (id_of_string "___________princ_________") []
+    next_ident_away_in_goal (id_of_string "___________princ_________") []
   in
   begin
-    Command.start_proof
+    Lemmas.start_proof
       new_princ_name
       (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
       new_principle_type
@@ -346,7 +347,7 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro
     (* 	  let dur1 = System.time_difference tim1 tim2 in *)
     (* 	  Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
     (* 	end; *)
-    get_proof_clean true 
+    get_proof_clean true
   end
 
 
@@ -355,7 +356,8 @@ let generate_functional_principle
     interactive_proof
     old_princ_type sorts new_princ_name funs i proof_tac
     =
-  try 
+  try
+
   let f = funs.(i) in
   let type_sort = Termops.new_sort_in_family InType in
   let new_sorts =
@@ -394,8 +396,8 @@ let generate_functional_principle
 	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
 	    )
 	);
-	Flags.if_verbose 
-	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) 
+	Flags.if_verbose
+	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
 	  name;
 	names := name :: !names
       in
@@ -403,21 +405,21 @@ let generate_functional_principle
       register_with_sort InSet
   in
   let (id,(entry,g_kind,hook)) =
-    build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook 
+    build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
   in
   (* Pr  1278 :
      Don't forget to close the goal if an error is raised !!!!
-  *) 
+  *)
   save false new_princ_name entry g_kind hook
-  with e -> 
+  with e ->
     begin
-      begin 
-	try 
-	  let id = Pfedit.get_current_proof_name () in 
-	  let s = string_of_id id in 
+      begin
+	try
+	  let id = Pfedit.get_current_proof_name () in
+	  let s = string_of_id id in
 	  let n = String.length "___________princ_________" in
-	  if String.length s >= n 
-	  then if String.sub s 0 n = "___________princ_________" 
+	  if String.length s >= n
+	  then if String.sub s 0 n = "___________princ_________"
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
@@ -430,24 +432,24 @@ let generate_functional_principle
 
 exception Not_Rec
 
-let get_funs_constant mp dp = 
-  let rec get_funs_constant const e : (Names.constant*int) array = 
-    match kind_of_term (snd (decompose_lam e)) with 
-      | Fix((_,(na,_,_))) -> 
-	  Array.mapi 
-	    (fun i na -> 
-	       match na with 
-		 | Name id -> 
-		     let const = make_con mp dp (label_of_id id) in 
+let get_funs_constant mp dp =
+  let rec get_funs_constant const e : (Names.constant*int) array =
+    match kind_of_term ((strip_lam e)) with
+      | Fix((_,(na,_,_))) ->
+	  Array.mapi
+	    (fun i na ->
+	       match na with
+		 | Name id ->
+		     let const = make_con mp dp (label_of_id id) in
 		     const,i
-		 | Anonymous -> 
-		     anomaly "Anonymous fix" 
+		 | Anonymous ->
+		     anomaly "Anonymous fix"
 	    )
 	    na
       | _ -> [|const,0|]
   in
-  function const -> 
-    let find_constant_body const = 
+  function const ->
+    let find_constant_body const =
       match (Global.lookup_constant const ).const_body with
 	| Some b ->
 	    let body = force b in
@@ -461,97 +463,96 @@ let get_funs_constant mp dp =
 	| None -> error ( "Cannot define a principle over an axiom ")
     in
     let f = find_constant_body const in
-    let l_const = get_funs_constant const f in 
-    (* 
-       We need to check that all the functions found are in the same block 
+    let l_const = get_funs_constant const f in
+    (*
+       We need to check that all the functions found are in the same block
        to prevent Reset stange thing
-    *) 
-    let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in 
-    let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in 
-    (* all the paremeter must be equal*) 
-    let _check_params = 
-      let first_params = List.hd l_params  in 
-      List.iter 
-	(fun params -> 
-	   if not ((=) first_params params) 
+    *)
+    let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in
+    let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in
+    (* all the paremeter must be equal*)
+    let _check_params =
+      let first_params = List.hd l_params  in
+      List.iter
+	(fun params ->
+	   if not ((=) first_params params)
 	   then error "Not a mutal recursive block"
 	)
 	l_params
     in
-    (* The bodies has to be very similar *) 
-    let _check_bodies = 
-      try 
-	let extract_info is_first body = 
-	  match kind_of_term body with 
+    (* The bodies has to be very similar *)
+    let _check_bodies =
+      try
+	let extract_info is_first body =
+	  match kind_of_term body with
 	    | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
-	    | _ -> 
-		if is_first && (List.length l_bodies = 1) 
+	    | _ ->
+		if is_first && (List.length l_bodies = 1)
 		then raise Not_Rec
 		else error "Not a mutal recursive block"
 	in
-	let first_infos = extract_info true (List.hd l_bodies) in 
+	let first_infos = extract_info true (List.hd l_bodies) in
 	let check body  = (* Hope this is correct *)
-	  if not (first_infos = (extract_info false body)) 
+	  if not (first_infos = (extract_info false body))
 	  then  error "Not a mutal recursive block"
-	in 
+	in
 	List.iter check l_bodies
       with Not_Rec -> ()
     in
     l_const
 
-exception No_graph_found 
-exception Found_type of int 
+exception No_graph_found
+exception Found_type of int
 
-let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = 
-  let env = Global.env () 
+let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list =
+  let env = Global.env ()
   and sigma = Evd.empty in
-  let funs = List.map fst fas in 
-  let first_fun = List.hd funs in 
+  let funs = List.map fst fas in
+  let first_fun = List.hd funs in
 
 
   let funs_mp,funs_dp,_ = Names.repr_con first_fun in
-  let first_fun_kn = 
-    try 
-      fst (find_Function_infos  first_fun).graph_ind 
-    with Not_found -> raise No_graph_found 
+  let first_fun_kn =
+    try
+      fst (find_Function_infos  first_fun).graph_ind
+    with Not_found -> raise No_graph_found
   in
   let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
-  let this_block_funs = Array.map fst this_block_funs_indexes in 
+  let this_block_funs = Array.map fst this_block_funs_indexes in
   let prop_sort = InProp in
-  let funs_indexes = 
-    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in 
+  let funs_indexes =
+    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
     List.map
       (function const -> List.assoc const this_block_funs_indexes)
       funs
   in
-  let ind_list = 
-    List.map 
-      (fun (idx) -> 
-	 let ind = first_fun_kn,idx in 
-	 let (mib,mip) = Global.lookup_inductive ind in
-	 ind,mib,mip,true,prop_sort
+  let ind_list =
+    List.map
+      (fun (idx) ->
+	 let ind = first_fun_kn,idx in
+	 ind,true,prop_sort
       )
       funs_indexes
   in
-  let l_schemes = 
+  let l_schemes =
     List.map
-      (Typing.type_of env sigma) 
-      (Indrec.build_mutual_indrec env sigma ind_list)
-  in 
+      (Typing.type_of env sigma)
+      (Indrec.build_mutual_induction_scheme env sigma ind_list)
+  in
   let i = ref (-1) in
-  let sorts = 
-    List.rev_map (fun (_,x) -> 
+  let sorts =
+    List.rev_map (fun (_,x) ->
 		Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
-	     ) 
-      fas 
+	     )
+      fas
   in
   (* We create the first priciple by tactic *)
-  let first_type,other_princ_types = 
-    match l_schemes with 
+  let first_type,other_princ_types =
+    match l_schemes with
 	s::l_schemes -> s,l_schemes
       | _ -> anomaly ""
   in
-  let (_,(const,_,_)) = 
+  let (_,(const,_,_)) =
     try
       build_functional_principle false
 	first_type
@@ -560,15 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
 	0
 	(prove_princ_for_struct false 0 (Array.of_list funs))
 	(fun _ _ _ -> ())
-  with e -> 
+  with e ->
     begin
-      begin 
-	try 
-	  let id = Pfedit.get_current_proof_name () in 
-	  let s = string_of_id id in 
+      begin
+	try
+	  let id = Pfedit.get_current_proof_name () in
+	  let s = string_of_id id in
 	  let n = String.length "___________princ_________" in
-	  if String.length s >= n 
-	  then if String.sub s 0 n = "___________princ_________" 
+	  if String.length s >= n
+	  then if String.sub s 0 n = "___________princ_________"
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
@@ -577,71 +578,71 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
       raise (Defining_principle e)
     end
 
-  in      
+  in
   incr i;
-  let opacity = 
-    let finfos = find_Function_infos this_block_funs.(0) in 
-    try 
-      let equation =  Option.get finfos.equation_lemma in  
-      (Global.lookup_constant equation).Declarations.const_opaque 
-    with Option.IsNone -> (* non recursive definition *) 
+  let opacity =
+    let finfos = find_Function_infos this_block_funs.(0) in
+    try
+      let equation =  Option.get finfos.equation_lemma in
+      (Global.lookup_constant equation).Declarations.const_opaque
+    with Option.IsNone -> (* non recursive definition *)
       false
   in
-  let const = {const with const_entry_opaque = opacity } in 
+  let const = {const with const_entry_opaque = opacity } in
   (* The others are just deduced *)
-  if other_princ_types = [] 
+  if other_princ_types = []
   then
     [const]
   else
-    let other_fun_princ_types = 
-      let funs = Array.map mkConst this_block_funs in 
-      let sorts = Array.of_list sorts in 
+    let other_fun_princ_types =
+      let funs = Array.map mkConst this_block_funs in
+      let sorts = Array.of_list sorts in
       List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
     in
-    let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in 
-    let ctxt,fix = Sign.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
-    let (idxs,_),(_,ta,_ as decl) = destFix fix in 
-    let other_result = 
+    let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
+    let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
+    let (idxs,_),(_,ta,_ as decl) = destFix fix in
+    let other_result =
       List.map (* we can now compute the other principles *)
-	(fun scheme_type -> 
+	(fun scheme_type ->
 	   incr i;
 	   observe (Printer.pr_lconstr scheme_type);
-	   let type_concl = snd (Sign.decompose_prod_assum scheme_type) in 
-	   let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in 
+	   let type_concl = (strip_prod_assum scheme_type) in
+	   let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in
 	   let f = fst (decompose_app applied_f) in
 	   try (* we search the number of the function in the fix block (name of the function) *)
-	     Array.iteri 
-	     (fun j t -> 
-		let t =  snd (Sign.decompose_prod_assum t) in 
-		let applied_g = List.hd (List.rev (snd (decompose_app t))) in 
+	     Array.iteri
+	     (fun j t ->
+		let t =  (strip_prod_assum t) in
+		let applied_g = List.hd (List.rev (snd (decompose_app t))) in
 		let g = fst (decompose_app applied_g) in
 		if eq_constr f g
-		then raise (Found_type j); 
+		then raise (Found_type j);
 		observe (Printer.pr_lconstr f ++ str " <> " ++
 			   Printer.pr_lconstr g)
-		  
+
 	     )
 	     ta;
-	   (* If we reach this point, the two principle are not mutually recursive 
-	      We fall back to the previous method 
+	   (* If we reach this point, the two principle are not mutually recursive
+	      We fall back to the previous method
 	   *)
-	     let (_,(const,_,_)) = 
+	     let (_,(const,_,_)) =
 	       build_functional_principle
-		 false 
+		 false
 		 (List.nth other_princ_types (!i - 1))
 		 (Array.of_list sorts)
 		 this_block_funs
 		 !i
 		 (prove_princ_for_struct false !i (Array.of_list funs))
 		 (fun _ _ _ -> ())
-	     in 
+	     in
 	     const
-	 with Found_type i -> 
-	   let princ_body = 
+	 with Found_type i ->
+	   let princ_body =
 	     Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
-	   in 
-	   {const with 
-	      Entries.const_entry_body = princ_body; 
+	   in
+	   {const with
+	      Entries.const_entry_body = princ_body;
 	      Entries.const_entry_type = Some scheme_type
 	   }
       )
@@ -649,49 +650,51 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
     in
     const::other_result
 
-let build_scheme fas = 
-  let bodies_types = 
-    make_scheme 
-      (List.map 
-	 (fun (_,f,sort) -> 
+let build_scheme fas =
+  Dumpglob.pause ();
+  let bodies_types =
+    make_scheme
+      (List.map
+	 (fun (_,f,sort) ->
 	    let f_as_constant =
 	      try
-		match Nametab.global f with 
-		  | Libnames.ConstRef c -> c 
+		match Nametab.global f with
+		  | Libnames.ConstRef c -> c
 		  | _ -> Util.error "Functional Scheme can only be used with functions"
 	      with Not_found ->
 	      	Util.error ("Cannot find "^ Libnames.string_of_reference f)
 	    in
 	    (f_as_constant,sort)
-	 ) 
+	 )
 	 fas
-      ) 
-  in 
-  List.iter2 
-    (fun (princ_id,_,_) def_entry -> 
-       ignore 
-	 (Declare.declare_constant 
-	    princ_id 
+      )
+  in
+  List.iter2
+    (fun (princ_id,_,_) def_entry ->
+       ignore
+	 (Declare.declare_constant
+	    princ_id
 	    (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
-       Flags.if_verbose 
+       Flags.if_verbose
 	 (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
     )
     fas
-    bodies_types
-  
+    bodies_types;
+    Dumpglob.continue ()
+
 
 
-let build_case_scheme fa = 
-  let env = Global.env () 
+let build_case_scheme fa =
+  let env = Global.env ()
   and sigma = Evd.empty in
 (*   let id_to_constr id =  *)
 (*     Tacinterp.constr_of_id env  id *)
 (*   in  *)
-  let funs =  (fun (_,f,_) ->  
+  let funs =  (fun (_,f,_) ->
 		 try Libnames.constr_of_global (Nametab.global f)
-		 with Not_found -> 
-		   Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in 
-  let first_fun = destConst  funs in 
+		 with Not_found ->
+		   Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
+  let first_fun = destConst  funs in
 
   let funs_mp,funs_dp,_ = Names.repr_con first_fun in
   let first_fun_kn = try fst (find_Function_infos  first_fun).graph_ind with Not_found -> raise No_graph_found in
@@ -699,17 +702,17 @@ let build_case_scheme fa =
 
 
   let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
-  let this_block_funs = Array.map fst this_block_funs_indexes in 
+  let this_block_funs = Array.map fst this_block_funs_indexes in
   let prop_sort = InProp in
-  let funs_indexes = 
-    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in 
+  let funs_indexes =
+    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
     List.assoc (destConst funs) this_block_funs_indexes
   in
-  let ind_fun = 
-	 let ind = first_fun_kn,funs_indexes in 
+  let ind_fun =
+	 let ind = first_fun_kn,funs_indexes in
 	 ind,prop_sort
   in
-  let scheme_type =  (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf)  ind_fun) in 
+  let scheme_type =  (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf)  ind_fun) in
   let sorts =
     (fun (_,_,x) ->
        Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
@@ -717,10 +720,11 @@ let build_case_scheme fa =
       fa
   in
   let princ_name =  (fun (x,_,_) -> x) fa in
-  let _ = 
-(*     observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *)
-(* 	       pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *)
-(* 	    ); *)
+  let _ =
+  (*  Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++
+	       pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs
+	    );
+  *)
     generate_functional_principle
       false
       scheme_type
diff --git a/contrib/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
index cf28c6e6..fb04c6ec 100644
--- a/contrib/funind/functional_principles_types.mli
+++ b/plugins/funind/functional_principles_types.mli
@@ -2,26 +2,26 @@ open Names
 open Term
 
 
-val generate_functional_principle : 
+val generate_functional_principle :
   (* do we accept interactive proving *)
   bool ->
-  (* induction principle on rel *) 
+  (* induction principle on rel *)
   types ->
   (* *)
-  sorts array option -> 
-  (* Name of the new principle *) 
-  (identifier) option -> 
+  sorts array option ->
+  (* Name of the new principle *)
+  (identifier) option ->
   (* the compute functions to use   *)
-  constant array -> 
+  constant array ->
   (* We prove the nth- principle *)
   int  ->
   (* The tactic to use to make the proof w.r
      the number of params
   *)
-  (constr array -> int -> Tacmach.tactic) -> 
+  (constr array -> int -> Tacmach.tactic) ->
   unit
 
-val compute_new_princ_type_from_rel : constr array -> sorts array -> 
+val compute_new_princ_type_from_rel : constr array -> sorts array ->
   types -> types
 
 
diff --git a/contrib/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index a79b46d9..bc400ae1 100644
--- a/contrib/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -11,7 +11,7 @@ open Term
 open Names
 open Pp
 open Topconstr
-open Indfun_common 
+open Indfun_common
 open Indfun
 open Genarg
 open Pcoq
@@ -26,17 +26,17 @@ let pr_bindings prc prlc = function
       brk (1,1) ++ str "with" ++ brk (1,1) ++
       Util.prlist_with_sep spc prc l
   | Rawterm.ExplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++ 
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
         Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | Rawterm.NoBindings -> mt ()
 
 let pr_with_bindings prc prlc (c,bl) =
   prc c ++ hv 0 (pr_bindings prc prlc bl)
 
-let pr_fun_ind_using  prc prlc _ opt_c = 
+let pr_fun_ind_using  prc prlc _ opt_c =
   match opt_c with
     | None -> mt ()
-    | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b))
+    | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b)
 
 (* Duplication of printing functions because "'a with_bindings" is
    (internally) not uniform in 'a: indeed constr_with_bindings at the
@@ -45,13 +45,13 @@ let pr_fun_ind_using  prc prlc _ opt_c =
    (prc,prlc)... *)
 
 let pr_with_bindings_typed prc prlc (c,bl) =
-  prc c ++ 
-  hv 0 (pr_bindings (fun c -> prc (snd c)) (fun c -> prlc (snd c))  bl)
+  prc c ++
+  hv 0 (pr_bindings prc prlc bl)
 
-let pr_fun_ind_using_typed prc prlc _ opt_c = 
+let pr_fun_ind_using_typed prc prlc _ opt_c =
   match opt_c with
     | None -> mt ()
-    | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b))
+    | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it)
 
 
 ARGUMENT EXTEND fun_ind_using
@@ -67,51 +67,51 @@ END
 
 
 TACTIC EXTEND newfuninv
-   [ "functional" "inversion"  quantified_hypothesis(hyp) reference_opt(fname) ] -> 
+   [ "functional" "inversion"  quantified_hypothesis(hyp) reference_opt(fname) ] ->
      [
        Invfun.invfun hyp fname
      ]
 END
 
 
-let pr_intro_as_pat prc _ _ pat = 
-  match pat with 
+let pr_intro_as_pat prc _ _ pat =
+  match pat with
     | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
     | None -> mt ()
 
 
 ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
-|   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ] 
-| []  ->[ None ] 
+|   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ]
+| []  ->[ None ]
 END
 
 
 
 
 TACTIC EXTEND newfunind
-   ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> 
-     [ 
-       let c = match cl with 
+   ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
+     [
+       let c = match cl with
 	 | [] -> assert false
-	 | [c] -> c 
+	 | [c] -> c
 	 | c::cl -> applist(c,cl)
-       in 
-       functional_induction true c  princl pat ]
+       in
+       Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ]
 END
 (***** debug only ***)
 TACTIC EXTEND snewfunind
-   ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> 
-     [ 
-       let c = match cl with 
+   ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
+     [
+       let c = match cl with
 	 | [] -> assert false
-	 | [c] -> c 
+	 | [c] -> c
 	 | c::cl -> applist(c,cl)
-       in 
-       functional_induction false c princl pat ]
+       in
+       Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ]
 END
 
 
-let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_coma prc
+let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc
 
 ARGUMENT EXTEND constr_coma_sequence'
   TYPED AS constr_list
@@ -130,8 +130,8 @@ ARGUMENT EXTEND auto_using'
 END
 
 let pr_rec_annotation2_aux s r id l =
-  str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ 
-    Util.pr_opt Nameops.pr_id id ++ 
+  str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++
+    Util.pr_opt Nameops.pr_id id ++
     Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}"
 
 let pr_rec_annotation2 = function
@@ -143,11 +143,11 @@ VERNAC ARGUMENT EXTEND rec_annotation2
 PRINTED BY pr_rec_annotation2
   [ "{"  "struct" ident(id)  "}"] -> [ Struct id ]
 | [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ]
-| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] 
+| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ]
 END
 
 let pr_binder2 (idl,c) =
-  str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ 
+  str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++
     str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")"
 
 VERNAC ARGUMENT EXTEND binder2
@@ -159,9 +159,9 @@ let make_binder2 (idl,c) =
   LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c)
 
 let pr_rec_definition2 (id,bl,annot,type_,def) =
-  Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ 
+  Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++
     Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++
-    Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ 
+    Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++
     Ppconstr.pr_lconstr_expr def
 
 VERNAC ARGUMENT EXTEND rec_definition2
@@ -182,11 +182,11 @@ let make_rec_definitions2 (id,bl,annot,type_,def) =
             Pp.str "the recursive argument needs to be specified");
      in
      let check_exists_args an =
-       try 
-	 let id = match an with 
-	   | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id 
-	   | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" 
-	 in 
+       try
+	 let id = match an with
+	   | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id
+	   | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args"
+	 in
 	 (try ignore(Util.list_index0 (Name id) names); annot
 	  with Not_found ->  Util.user_err_loc
             (Util.dummy_loc,"Function",
@@ -206,33 +206,33 @@ let make_rec_definitions2 (id,bl,annot,type_,def) =
 
 VERNAC COMMAND EXTEND Function
    ["Function" ne_rec_definition2_list_sep(recsl,"with")] ->
-	[ 
-	  do_generate_principle false (List.map make_rec_definitions2 recsl); 
-	  
+	[
+	  do_generate_principle false (List.map make_rec_definitions2 recsl);
+
 	]
 END
 
-let pr_fun_scheme_arg (princ_name,fun_name,s) = 
-  Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ 
-  Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ 
+let pr_fun_scheme_arg (princ_name,fun_name,s) =
+  Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++
+  Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++
   Ppconstr.pr_rawsort s
 
 VERNAC ARGUMENT EXTEND fun_scheme_arg
 PRINTED BY pr_fun_scheme_arg
-| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] 
-END 
+| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
+END
 
 
-let warning_error names e = 
-  match e with 
-    | Building_graph e -> 
-	Pp.msg_warning 
-	  (str "Cannot define graph(s) for " ++ 
+let warning_error names e =
+  match e with
+    | Building_graph e ->
+	Pp.msg_warning
+	  (str "Cannot define graph(s) for " ++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
 	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
-    | Defining_principle e -> 
+    | Defining_principle e ->
 	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++ 
+	  (str "Cannot define principle(s) for "++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
 	     if do_observe () then Cerrors.explain_exn e else mt ())
     | _ -> anomaly ""
@@ -242,29 +242,29 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
    ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] ->
     [
       begin
-	try 
+	try
 	  Functional_principles_types.build_scheme fas
-	with Functional_principles_types.No_graph_found -> 
+	with Functional_principles_types.No_graph_found ->
 	  begin
-	    match fas with 
-	      | (_,fun_name,_)::_ -> 
+	    match fas with
+	      | (_,fun_name,_)::_ ->
 		  begin
 		    begin
 		      make_graph (Nametab.global fun_name)
 		    end
 		    ;
 		    try Functional_principles_types.build_scheme fas
-		    with Functional_principles_types.No_graph_found -> 
+		    with Functional_principles_types.No_graph_found ->
 		      Util.error ("Cannot generate induction principle(s)")
-    		      | e -> 
-			  let names = List.map (fun (_,na,_) -> na) fas in 
+    		      | 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 -> 
-	      let names = List.map (fun (_,na,_) -> na) fas in 
+    	  | e ->
+	      let names = List.map (fun (_,na,_) -> na) fas in
 	      warning_error names e
 
       end
@@ -280,7 +280,7 @@ VERNAC COMMAND EXTEND NewFunctionalCase
 END
 
 (***** debug only ***)
-VERNAC COMMAND EXTEND GenerateGraph 
+VERNAC COMMAND EXTEND GenerateGraph
 ["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
 END
 
@@ -296,7 +296,7 @@ let msg x = () ;; let pr_lconstr c = str ""
 let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
 let prlistconstr lc = List.iter prconstr lc
 let prstr s = msg(str s)
-let prNamedConstr s c = 
+let prNamedConstr s c =
   begin
     msg(str "");
     msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n");
@@ -318,8 +318,8 @@ type fapp_info = {
 
 (** [constr_head_match(a b c) a] returns true, false otherwise. *)
 let constr_head_match u t=
-  if isApp u 
-  then 
+  if isApp u
+  then
     let uhd,args= destApp u in
     uhd=t
   else false
@@ -328,40 +328,40 @@ let constr_head_match u t=
     [inu]. DeBruijn are not pushed, so some of them may be unbound in
     the result. *)
 let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
-  let subres = 
+  let subres =
     match kind_of_term inu with
-      | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> 
+      | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) ->
 	  hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test
       | Fix (_,(lna,tl,bl))  -> (* not sure Fix is correct *)
-	  Array.fold_left 
-	    (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) 
+	  Array.fold_left
+	    (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test)
 	    [] bl
       | _ -> (* Cofix will be wrong *)
-	  fold_constr 
-	    (fun l cstr -> 
-	      l @ hdMatchSub cstr test) [] inu in 
+	  fold_constr
+	    (fun l cstr ->
+	      l @ hdMatchSub cstr test) [] inu in
   if not (test inu) then subres
   else
     let f,args = decompose_app inu in
     let freeset = Termops.free_rels inu in
     let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
     {fname = f; largs = args; free = Util.Intset.is_empty freeset;
-    max_rel = max_rel; onlyvars = List.for_all isVar args } 
+    max_rel = max_rel; onlyvars = List.for_all isVar args }
     ::subres
 
-let mkEq typ c1 c2 = 
+let mkEq typ c1 c2 =
   mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
 
 
 let poseq_unsafe idunsafe cstr gl =
   let typ = Tacmach.pf_type_of gl cstr in
   tclTHEN
-    (Tactics.letin_tac None (Name idunsafe) cstr None allClauses)
-    (tclTHENFIRST 
-      (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) 
+    (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl)
+    (tclTHENFIRST
+      (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr))
       Tactics.reflexivity)
     gl
-  
+
 
 let poseq id cstr gl =
   let x = Tactics.fresh_id [] id gl in
@@ -374,16 +374,16 @@ let list_constr_largs = ref []
 let rec poseq_list_ids_rec lcstr gl =
   match lcstr with
     | [] -> tclIDTAC gl
-    | c::lcstr' -> 
+    | c::lcstr' ->
 	match kind_of_term c with
-	  | Var _ -> 
+	  | Var _ ->
 	      (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl)
-	  | _ -> 
+	  | _ ->
 	      let _ = prstr "c = " in
 	      let _ = prconstr c in
 	      let _ = prstr "\n" in
 	      let typ = Tacmach.pf_type_of gl c in
-	      let cname = Termops.id_of_name_using_hdchar (Global.env()) typ Anonymous in
+	      let cname = Namegen.id_of_name_using_hdchar (Global.env()) typ Anonymous in
 	      let x = Tactics.fresh_id [] cname gl in
 	      let _ = list_constr_largs:=mkVar x :: !list_constr_largs in
 	      let _ = prstr " list_constr_largs = " in
@@ -395,16 +395,16 @@ let rec poseq_list_ids_rec lcstr gl =
 		(poseq_list_ids_rec lcstr')
 		gl
 
-let poseq_list_ids lcstr gl = 
+let poseq_list_ids lcstr gl =
   let _ = list_constr_largs := [] in
   poseq_list_ids_rec lcstr gl
 
 (** [find_fapp test g] returns the list of [app_info] of all calls to
     functions that satisfy [test] in the conclusion of goal g. Trivial
     repetition (not modulo conversion) are deleted. *)
-let find_fapp (test:constr -> bool) g : fapp_info list = 
+let find_fapp (test:constr -> bool) g : fapp_info list =
   let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
-  let res = 
+  let res =
     List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
   (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
   res)
@@ -418,24 +418,24 @@ let find_fapp (test:constr -> bool) g : fapp_info list =
 let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
     (nexttac:Proof_type.tactic) g =
   let test = match oid with
-    | Some id -> 
+    | Some id ->
 	let idconstr = mkConst (const_of_id id) in
 	(fun u -> constr_head_match u idconstr) (* select only id *)
     | None -> (fun u -> isApp u) in (* select calls to any function *)
   let info_list = find_fapp test g in
   let ordered_info_list = heuristic info_list in
-  prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); 
+  prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
   if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
-  let taclist: Proof_type.tactic list = 
-    List.map 
+  let taclist: Proof_type.tactic list =
+    List.map
       (fun info ->
 	(tclTHEN
 	  (tclTHEN (poseq_list_ids info.largs)
 	    (
-	      fun gl -> 
-		  (functional_induction 
-		    true (applist (info.fname, List.rev !list_constr_largs)) 
-		    None None) gl)) 
+	      fun gl ->
+		  (functional_induction
+		    true (applist (info.fname, List.rev !list_constr_largs))
+		    None None) gl))
 	  nexttac)) ordered_info_list in
   (* we try each (f t u v) until one does not fail *)
   (* TODO: try also to mix functional schemes *)
@@ -450,7 +450,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l
 let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
   match oi with
     | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
-    | None -> 
+    | None ->
 	(* Default heuristic: put first occurrences where all arguments
 	   are *bound* (meaning already introduced) variables *)
 	let ordering x y =
@@ -464,11 +464,11 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
 
 
 TACTIC EXTEND finduction
-    ["finduction" ident(id) natural_opt(oi)] -> 
-      [ 
+    ["finduction" ident(id) natural_opt(oi)] ->
+      [
 	match oi with
 	  | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
-	  | _ -> 
+	  | _ ->
 	      let heuristic = chose_heuristic oi in
 	      finduction (Some id) heuristic tclIDTAC
       ]
@@ -477,13 +477,13 @@ END
 
 
 TACTIC EXTEND fauto
-    [ "fauto" tactic(tac)] -> 
+    [ "fauto" tactic(tac)] ->
       [
 	let heuristic = chose_heuristic None in
 	finduction None heuristic (snd tac)
       ]
   |
-    [ "fauto" ] -> 
+    [ "fauto" ] ->
       [
 	let heuristic = chose_heuristic None in
 	finduction None heuristic tclIDTAC
@@ -493,7 +493,7 @@ END
 
 
 TACTIC EXTEND poseq
-  [ "poseq" ident(x) constr(c) ] -> 
+  [ "poseq" ident(x) constr(c) ] ->
       [ poseq x c ]
 END
 
@@ -502,10 +502,10 @@ VERNAC COMMAND EXTEND Showindinfo
 END
 
 VERNAC COMMAND EXTEND MergeFunind
-  [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" 
-      "with" "(" ident(id2) ne_ident_list(cl2)  ")" "using" ident(id) ] -> 
-     [ 
-       let f1 = Constrintern.interp_constr Evd.empty (Global.env()) 
+  [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
+      "with" "(" ident(id2) ne_ident_list(cl2)  ")" "using" ident(id) ] ->
+     [
+       let f1 = Constrintern.interp_constr Evd.empty (Global.env())
 	 (CRef (Libnames.Ident (Util.dummy_loc,id1))) in
        let f2 = Constrintern.interp_constr Evd.empty (Global.env())
 	 (CRef (Libnames.Ident (Util.dummy_loc,id2))) in
@@ -513,11 +513,11 @@ VERNAC COMMAND EXTEND MergeFunind
        let f2type = Typing.type_of (Global.env()) Evd.empty f2 in
        let ar1 = List.length (fst (decompose_prod f1type)) in
        let ar2 = List.length (fst (decompose_prod f2type)) in
-       let _ = 
-	 if ar1 <> List.length cl1 then 
+       let _ =
+	 if ar1 <> List.length cl1 then
 	   Util.error ("not the right number of arguments for " ^ string_of_id id1) in
-       let _ = 
-	 if ar2 <> List.length cl2 then 
+       let _ =
+	 if ar2 <> List.length cl2 then
 	   Util.error ("not the right number of arguments for " ^ string_of_id id2) in
        Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2)  id
      ]
diff --git a/contrib/funind/indfun.ml b/plugins/funind/indfun.ml
index b6b2cbd1..38f42844 100644
--- a/contrib/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -7,13 +7,13 @@ open Libnames
 open Rawterm
 open Declarations
 
-let is_rec_info scheme_info = 
-  let test_branche min acc (_,_,br) = 
+let is_rec_info scheme_info =
+  let test_branche min acc (_,_,br) =
     acc || (
-      let new_branche = 
-	Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in 
-      let free_rels_in_br = Termops.free_rels new_branche in 
-      let max = min + scheme_info.Tactics.npredicates in 
+      let new_branche =
+	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
+      let free_rels_in_br = Termops.free_rels new_branche in
+      let max = min + scheme_info.Tactics.npredicates in
       Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
     )
   in
@@ -27,38 +27,39 @@ let choose_dest_or_ind scheme_info =
 
 
 let functional_induction with_clean c princl pat =
-  let f,args = decompose_app c in 
-  fun g ->      
-    let princ,bindings, princ_type = 
-      match princl with 
+  Dumpglob.pause ();
+  let res = let f,args = decompose_app c in
+	      fun g ->
+		let princ,bindings, princ_type =
+		  match princl with
 	| None -> (* No principle is given let's find the good one *)
 	    begin
 	      match kind_of_term f with
 		| Const c' ->
-		    let princ_option = 
+		    let princ_option =
 		      let finfo = (* we first try to find out a graph on f *)
-			try find_Function_infos c' 
-			with Not_found -> 
+			try find_Function_infos c'
+			with Not_found ->
 			  errorlabstrm "" (str "Cannot find induction information on "++
 					     Printer.pr_lconstr (mkConst c') )
 		      in
-		      match Tacticals.elimination_sort_of_goal g with 
+		      match Tacticals.elimination_sort_of_goal g with
 			| InProp -> finfo.prop_lemma
 			| InSet -> finfo.rec_lemma
 			| InType -> finfo.rect_lemma
 		    in
 		    let princ =  (* then we get the principle *)
 		      try mkConst (Option.get princ_option )
-		      with Option.IsNone -> 
-			(*i If there is not default lemma defined then, 
-			  we cross our finger and try to find a lemma named f_ind 
+		      with Option.IsNone ->
+			(*i If there is not default lemma defined then,
+			  we cross our finger and try to find a lemma named f_ind
 			  (or f_rec, f_rect) i*)
-			let princ_name = 
+			let princ_name =
 			  Indrec.make_elimination_ident
 			    (id_of_label (con_label c'))
 			    (Tacticals.elimination_sort_of_goal g)
 			in
-			try 
+			try
 			  mkConst(const_of_id princ_name )
 			with Not_found -> (* This one is neither defined ! *)
 			  errorlabstrm "" (str "Cannot find induction principle for "
@@ -66,57 +67,57 @@ let functional_induction with_clean c princl pat =
 		    in
 		    (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ)
 		| _ -> raise (UserError("",str "functional induction must be used with a function" ))
-		    
+
 	    end
-	| Some ((princ,binding)) -> 
+	| Some ((princ,binding)) ->
 	    princ,binding,Tacmach.pf_type_of g princ
     in
-    let princ_infos = Tactics.compute_elim_sig princ_type in 
+    let princ_infos = Tactics.compute_elim_sig princ_type in
     let args_as_induction_constr =
-      let c_list = 
-	if princ_infos.Tactics.farg_in_concl 
-	then [c] else [] 
+      let c_list =
+	if princ_infos.Tactics.farg_in_concl
+	then [c] else []
       in
-      List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) 
-    in 
-    let princ' = Some (princ,bindings) in 
-    let princ_vars = 
-      List.fold_right 
-	(fun a acc -> 
+      List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list)
+    in
+    let princ' = Some (princ,bindings) in
+    let princ_vars =
+      List.fold_right
+	(fun a acc ->
 	  try Idset.add (destVar a) acc
 	  with _ -> acc
 	)
 	args
 	Idset.empty
     in
-    let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in 
-    let old_idl = Idset.diff old_idl princ_vars in 
-    let subst_and_reduce g = 
-      if with_clean 
+    let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
+    let old_idl = Idset.diff old_idl princ_vars in
+    let subst_and_reduce g =
+      if with_clean
       then
-	let idl = 
-	  map_succeed 
-	    (fun id -> 
+	let idl =
+	  map_succeed
+	    (fun id ->
 	       if Idset.mem id old_idl then failwith "subst_and_reduce";
-	       id 
+	       id
 	    )
 	    (Tacmach.pf_ids_of_hyps g)
-	in 
-	let flag = 
+	in
+	let flag =
 	  Rawterm.Cbv
-	    {Rawterm.all_flags 
-	     with Rawterm.rDelta = false; 		 
+	    {Rawterm.all_flags
+	     with Rawterm.rDelta = false;
 	    }
 	in
 	Tacticals.tclTHEN
-	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
-	  (Hiddentac.h_reduce flag Tacticals.allClauses)	
+	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl )
+	  (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
 	  g
-      else Tacticals.tclIDTAC g 
-	
+      else Tacticals.tclIDTAC g
+
     in
     Tacticals.tclTHEN
-      (choose_dest_or_ind 
+      (choose_dest_or_ind
 	 princ_infos
 	 args_as_induction_constr
 	 princ'
@@ -124,12 +125,15 @@ let functional_induction with_clean c princl pat =
          None)
       subst_and_reduce
       g
-      
-      
+  in
+    Dumpglob.continue ();
+    res
 
 
-type annot = 
-    Struct of identifier 
+
+
+type annot =
+    Struct of identifier
   | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
   | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
 
@@ -146,12 +150,12 @@ let rec abstract_rawconstr c = function
 
 let interp_casted_constr_with_implicits sigma env impls c  =
 (*   Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *)
-  Constrintern.intern_gen false sigma env ~impls:([],impls) 
+  Constrintern.intern_gen false sigma env ~impls
     ~allow_patvar:false  ~ltacvars:([],[]) c
 
 
-(* 
-   Construct a fixpoint as a Rawterm 
+(*
+   Construct a fixpoint as a Rawterm
    and not as a constr
 *)
 let build_newrecursive
@@ -162,15 +166,12 @@ let build_newrecursive
   let (rec_sign,rec_impls) =
     List.fold_left
       (fun (env,impls) ((_,recname),_,bl,arityc,_) ->
-        let arityc = Command.generalize_constr_expr arityc bl in
+        let arityc = Topconstr.prod_constr_expr arityc bl in
         let arity = Constrintern.interp_type sigma env0 arityc in
-	let impl =
-	  if Impargs.is_implicit_args()
-	  then Impargs.compute_implicits  env0 arity
-	  else [] in
-	let impls' =(recname,(Constrintern.Recursive,[],impl,Notation.compute_arguments_scope arity))::impls in
-        (Environ.push_named (recname,None,arity) env, impls'))
+	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in
+        (Environ.push_named (recname,None,arity) env, (recname,impl) :: impls))
       (env0,[]) lnameargsardef in
+  let rec_impls = Constrintern.set_internalization_env_params rec_impls [] in
   let recdef =
     (* Declare local notations *)
     let fs = States.freeze() in
@@ -188,7 +189,7 @@ let build_newrecursive
     States.unfreeze fs; def
   in
   recdef,rec_impls
-	
+
 
 let compute_annot (name,annot,args,types,body) =
   let names = List.map snd (Topconstr.names_of_local_assums args) in
@@ -203,114 +204,130 @@ let compute_annot (name,annot,args,types,body) =
     | Some r -> (name,r,args,types,body)
 
 
-(* Checks whether or not the mutual bloc is recursive *) 
-let rec is_rec names = 
-  let names = List.fold_right Idset.add names Idset.empty in 
-  let check_id id names =  Idset.mem id names in 
-  let rec lookup names = function 
+(* Checks whether or not the mutual bloc is recursive *)
+let rec is_rec names =
+  let names = List.fold_right Idset.add names Idset.empty in
+  let check_id id names =  Idset.mem id names in
+  let rec lookup names = function
     | RVar(_,id) -> check_id id names
     | RRef _ | REvar _ | RPatVar _ | RSort _ |  RHole _ | RDynamic _ -> false
     | RCast(_,b,_) -> lookup names b
     | RRec _ -> error "RRec not handled"
-    | RIf(_,b,_,lhs,rhs) -> 
+    | RIf(_,b,_,lhs,rhs) ->
 	(lookup names b) || (lookup names lhs) || (lookup names rhs)
-    | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b)  -> 
+    | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b)  ->
 	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
-    | RLetTuple(_,nal,_,t,b) -> lookup names t || 
-	lookup 
-	  (List.fold_left 
+    | RLetTuple(_,nal,_,t,b) -> lookup names t ||
+	lookup
+	  (List.fold_left
 	     (fun acc na -> Nameops.name_fold Idset.remove na acc)
 	     names
 	     nal
 	  )
 	  b
     | RApp(_,f,args) -> List.exists (lookup names) (f::args)
-    | RCases(_,_,_,el,brl) -> 
+    | RCases(_,_,_,el,brl) ->
 	List.exists (fun (e,_) -> lookup names e) el ||
 	  List.exists (lookup_br names) brl
-  and lookup_br names (_,idl,_,rt) = 
-    let new_names = List.fold_right Idset.remove idl names in 
+  and lookup_br names (_,idl,_,rt) =
+    let new_names = List.fold_right Idset.remove idl names in
     lookup new_names rt
   in
   lookup names
 
-let prepare_body (name,annot,args,types,body) rt = 
-  let n = (Topconstr.local_binders_length args) in 
+let rec local_binders_length = function
+  (* Assume that no `{ ... } contexts occur *)
+  | [] -> 0
+  | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl
+  | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+
+let prepare_body (name,annot,args,types,body) rt =
+  let n = local_binders_length args in
 (*   Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *)
   let fun_args,rt' = chop_rlambda_n n rt in
   (fun_args,rt')
 
 
 let derive_inversion fix_names =
-  try 
+  try
     (* we first transform the fix_names identifier into their corresponding constant *)
-    let fix_names_as_constant = 
-      List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names 
-    in 
-    (* 
-       Then we check that the graphs have been defined 
-       If one of the graphs haven't been defined 
+    let fix_names_as_constant =
+      List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names
+    in
+    (*
+       Then we check that the graphs have been defined
+       If one of the graphs haven't been defined
        we do nothing
     *)
     List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ;
     try
-      Invfun.derive_correctness 
+      Invfun.derive_correctness
 	Functional_principles_types.make_scheme
-	functional_induction 
+	functional_induction
 	fix_names_as_constant
-	(*i The next call to mk_rel_id is valid since we have just construct the graph 
+	(*i The next call to mk_rel_id is valid since we have just construct the graph
 	  Ensures by : register_built
-	  i*) 
+	  i*)
 	(List.map
 	   (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
 	   fix_names
 	)
-    with e -> 
-      msg_warning 
-	(str "Cannot built inversion information" ++ 
+    with e ->
+      msg_warning
+	(str "Cannot built inversion information" ++
 	   if do_observe () then Cerrors.explain_exn e else mt ())
   with _ -> ()
 
-let warning_error names e = 
-  match e with 
-    | Building_graph e -> 
-	Pp.msg_warning 
-	  (str "Cannot define graph(s) for " ++ 
+let warning_error names e =
+  let e_explain e =
+    match e with
+      | ToShow e -> spc () ++ Cerrors.explain_exn e
+      | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn 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) ++
-	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
-    | Defining_principle e -> 
+	     e_explain e)
+    | Defining_principle e ->
 	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++ 
+	  (str "Cannot define principle(s) for "++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     if do_observe () then Cerrors.explain_exn e else mt ())
+	     e_explain e)
     | _ -> anomaly ""
 
-let error_error names e = 
-  match e with 
-    | Building_graph e -> 
-	errorlabstrm ""  
-	  (str "Cannot define graph(s) for " ++ 
+let error_error names e =
+  let e_explain e =
+    match e with
+      | ToShow e -> spc () ++ Cerrors.explain_exn e
+      | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()
+  in
+  match e with
+    | Building_graph e ->
+	errorlabstrm ""
+	  (str "Cannot define graph(s) for " ++
 	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
+	     e_explain e)
     | _ -> anomaly ""
 
 let generate_principle  on_error
-    is_general do_built fix_rec_l recdefs  interactive_proof 
-    (continue_proof : int -> Names.constant array -> Term.constr array -> int -> 
+    is_general do_built fix_rec_l recdefs  interactive_proof
+    (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
       Tacmach.tactic) : unit =
   let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in
   let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
   let funs_args = List.map fst fun_bodies in
   let funs_types =  List.map (function (_,_,_,types,_) -> types) fix_rec_l in
-  try 
+  try
     (* We then register the Inductive graphs of the functions  *)
     Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
-    if do_built 
+    if do_built
     then
       begin
-	(*i The next call to mk_rel_id is valid since we have just construct the graph 
+	(*i The next call to mk_rel_id is valid since we have just construct the graph
 	   Ensures by : do_built
-	i*) 
+	i*)
 	let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
 	let ind_kn =
 	  fst (locate_with_msg
@@ -325,101 +342,103 @@ let generate_principle  on_error
 	    locate_constant
 	    f_ref
 	in
-	let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in 
-	let _ = 
+	let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
+	let _ =
 	  list_map_i
 	    (fun i x ->
-	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in 
+	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
 	       let princ_type = Typeops.type_of_constant (Global.env()) princ
 	       in
 	       Functional_principles_types.generate_functional_principle
-		 interactive_proof 
+		 interactive_proof
 		 princ_type
 		 None
-		 None 
+		 None
 		 funs_kn
 		 i
-		 (continue_proof  0 [|funs_kn.(i)|]) 
+		 (continue_proof  0 [|funs_kn.(i)|])
 	    )
 	    0
 	    fix_rec_l
-	in 
+	in
 	Array.iter (add_Function is_general) funs_kn;
 	()
       end
-  with e -> 
-    on_error names e 
-
-let register_struct is_rec fixpoint_exprl = 
-  match fixpoint_exprl with 
-    | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> 
+  with e ->
+    on_error names e
+
+let register_struct is_rec fixpoint_exprl =
+  match fixpoint_exprl with
+    | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
+	let ce,imps =
+	  Command.interp_definition
+	    (Flags.boxed_definitions ()) bl None body (Some ret_type)
+	in
 	Command.declare_definition
-	  fname
-	  (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition)
-	  bl
-	  None
-  	  body
-	  (Some ret_type)
-	  (fun _ _ -> ())
-    | _ -> 
-	Command.build_recursive fixpoint_exprl (Flags.boxed_definitions())
-
-let generate_correction_proof_wf f_ref tcc_lemma_ref   
+	  fname (Decl_kinds.Global,Decl_kinds.Definition)
+	  ce imps (fun _ _ -> ())
+    | _ ->
+        let fixpoint_exprl =
+          List.map (fun ((name,annot,bl,types,body),ntn) ->
+            ((name,annot,bl,types,Some body),ntn)) fixpoint_exprl in
+	Command.do_fixpoint fixpoint_exprl (Flags.boxed_definitions())
+
+let generate_correction_proof_wf f_ref tcc_lemma_ref
     is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
-    (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = 
+    (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic =
   Functional_principles_proofs.prove_principle_for_gen
     (f_ref,functional_ref,eq_ref)
     tcc_lemma_ref is_mes  rec_arg_num rec_arg_type relation
 
 
 let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
-    pre_hook 
-    =  
-  let type_of_f = Command.generalize_constr_expr ret_type args in 
-  let rec_arg_num = 
-    let names = 
+    pre_hook
+    =
+  let type_of_f = Topconstr.prod_constr_expr ret_type args in
+  let rec_arg_num =
+    let names =
       List.map
 	snd
-	(Topconstr.names_of_local_assums args) 
-    in 
-    match wf_arg with 
-      | None -> 
+	(Topconstr.names_of_local_assums args)
+    in
+    match wf_arg with
+      | None ->
 	  if List.length names = 1 then 1
 	  else error "Recursive argument must be specified"
-      | Some wf_arg -> 
-	  list_index (Name wf_arg) names 
+      | Some wf_arg ->
+	  list_index (Name wf_arg) names
   in
-  let unbounded_eq = 
-    let f_app_args = 
-      Topconstr.CAppExpl 
-	(dummy_loc, 
+  let unbounded_eq =
+    let f_app_args =
+      Topconstr.CAppExpl
+	(dummy_loc,
 	 (None,(Ident (dummy_loc,fname))) ,
-	 (List.map 
+	 (List.map
 	    (function
-	       | _,Anonymous -> assert false 
+	       | _,Anonymous -> assert false
 	       | _,Name e -> (Topconstr.mkIdentC e)
-	    ) 
+	    )
 	    (Topconstr.names_of_local_assums args)
 	 )
-	) 
+	)
     in
     Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
 		    [(f_app_args,None);(body,None)])
   in
-  let eq = Command.generalize_constr_expr unbounded_eq args in 
+  let eq = Topconstr.prod_constr_expr unbounded_eq args in
   let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
       nb_args relation =
-    try 
-      pre_hook 
+    try
+      pre_hook
 	(generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
 	   functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
 	);
       derive_inversion [fname]
-    with e -> 
-      (* No proof done *) 
+    with e ->
+      (* No proof done *)
       ()
-  in 
-  Recdef.recursive_definition 
+  in
+  Recdef.recursive_definition
     is_mes fname rec_impls
     type_of_f
     wf_rel_expr
@@ -428,115 +447,115 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
     hook
     using_lemmas
 
-    
-let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = 
-  let wf_arg_type,wf_arg = 
-    match wf_arg with 
-      | None -> 
+
+let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body =
+  let wf_arg_type,wf_arg =
+    match wf_arg with
+      | None ->
 	  begin
-	    match args with 
-	      | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x 
-	      | _ -> error "Recursive argument must be specified" 
+	    match args with
+	      | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
+	      | _ -> error "Recursive argument must be specified"
 	  end
-      | Some wf_args -> 
-	  try 
-	    match 
-	      List.find 
-		(function 
-		   | Topconstr.LocalRawAssum(l,k,t) -> 
-		       List.exists 
-			 (function (_,Name id) -> id =  wf_args | _ -> false) 
-			 l 
+      | Some wf_args ->
+	  try
+	    match
+	      List.find
+		(function
+		   | Topconstr.LocalRawAssum(l,k,t) ->
+		       List.exists
+			 (function (_,Name id) -> id =  wf_args | _ -> false)
+			 l
 		   | _ -> false
 		)
-		args 
-	    with 
+		args
+	    with
 	      | Topconstr.LocalRawAssum(_,k,t)  ->	    t,wf_args
-	      | _ -> assert false 
-	  with Not_found -> assert false 
+	      | _ -> assert false
+	  with Not_found -> assert false
   in
-  let ltof = 
-    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in 
-    Libnames.Qualid (dummy_loc,Libnames.qualid_of_sp 
+  let ltof =
+    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in
+    Libnames.Qualid (dummy_loc,Libnames.qualid_of_path
       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
   in
-  let fun_from_mes = 
-    let applied_mes = 
+  let fun_from_mes =
+    let applied_mes =
       Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
-    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) 
+    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
   in
-  let wf_rel_from_mes = 
+  let wf_rel_from_mes =
     Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
   in
-  register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) 
+  register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg)
     using_lemmas args ret_type body
-	  
-
-let do_generate_principle on_error register_built interactive_proof fixpoint_exprl  = 
-  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in 
-  let _is_struct = 
-    match fixpoint_exprl with 
-      | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> 
-	  let pre_hook = 
-	    generate_principle 
+
+
+let do_generate_principle on_error register_built interactive_proof fixpoint_exprl  =
+  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+  let _is_struct =
+    match fixpoint_exprl with
+      | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] ->
+	  let pre_hook =
+	    generate_principle
 	      on_error
 	      true
 	      register_built
-	      fixpoint_exprl 
+	      fixpoint_exprl
 	      recdefs
 	      true
-	  in 
-	  if register_built 
+	  in
+	  if register_built
 	  then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
 	  false
-      | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> 
-	  let pre_hook = 
-	    generate_principle 
+      | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] ->
+	  let pre_hook =
+	    generate_principle
 	      on_error
 	      true
 	      register_built
-	      fixpoint_exprl 
+	      fixpoint_exprl
 	      recdefs
 	      true
-	  in 
-	  if register_built 
+	  in
+	  if register_built
 	  then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
 	  true
-      | _ -> 
-	  let fix_names = 
-	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl 
+      | _ ->
+	  let fix_names =
+	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
 	  in
 	  let is_one_rec = is_rec fix_names  in
-	  let old_fixpoint_exprl =  
+	  let old_fixpoint_exprl =
 	    List.map
 	      (function
-		 | (name,Some (Struct id),args,types,body),_ -> 
-		     let annot = 
-		       try Some (dummy_loc, id), Topconstr.CStructRec 
-		       with Not_found -> 
-			 raise (UserError("",str "Cannot find argument " ++ 
-					    Ppconstr.pr_id id)) 
-		     in 
- 		     (name,annot,args,types,body),(None:Vernacexpr.decl_notation) 
-		 | (name,None,args,types,body),recdef -> 
+		 | (name,Some (Struct id),args,types,body),_ ->
+		     let annot =
+		       try Some (dummy_loc, id), Topconstr.CStructRec
+		       with Not_found ->
+			 raise (UserError("",str "Cannot find argument " ++
+					    Ppconstr.pr_id id))
+		     in
+		     (name,annot,args,types,body),([]:Vernacexpr.decl_notation list)
+		 | (name,None,args,types,body),recdef ->
 		     let names =  (Topconstr.names_of_local_assums args) in
 		     if  is_one_rec recdef  && List.length names > 1 then
 		       user_err_loc
 			 (dummy_loc,"Function",
 			  Pp.str "the recursive argument needs to be specified in Function")
-		     else 
+		     else
 		       let loc, na = List.hd names in
 			 (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body),
-		     (None:Vernacexpr.decl_notation)
-		 | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> 
-		     error 
+		     ([]:Vernacexpr.decl_notation list)
+		 | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_->
+		     error
 		       ("Cannot use mutual definition with well-founded recursion or measure")
-	      ) 
+	      )
 	      (List.combine fixpoint_exprl recdefs)
 	  in
-	  (* ok all the expressions are structural *) 
-	  let fix_names = 
-	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl 
+	  (* ok all the expressions are structural *)
+	  let fix_names =
+	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
 	  in
 	  let is_rec = List.exists (is_rec fix_names) recdefs in
 	  if register_built then register_struct is_rec old_fixpoint_exprl;
@@ -545,7 +564,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 	    false
 	    register_built
 	    fixpoint_exprl
-	    recdefs 
+	    recdefs
 	    interactive_proof
 	    (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
 	  if register_built then derive_inversion fix_names;
@@ -554,52 +573,52 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
   ()
 
 open Topconstr
-let rec add_args id new_args b = 
-  match b with 
-  | CRef r -> 
-      begin      match r with 
-	| Libnames.Ident(loc,fname) when fname = id -> 
+let rec add_args id new_args b =
+  match b with
+  | CRef r ->
+      begin      match r with
+	| Libnames.Ident(loc,fname) when fname = id ->
 	    CAppExpl(dummy_loc,(None,r),new_args)
 	| _ -> b
       end
   | CFix  _  | CCoFix _ -> anomaly "add_args : todo"
-  | CArrow(loc,b1,b2) -> 
+  | CArrow(loc,b1,b2) ->
       CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
-  | CProdN(loc,nal,b1) -> 
+  | CProdN(loc,nal,b1) ->
       CProdN(loc,
-	     List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, 
+	     List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
 	     add_args id new_args  b1)
-  | CLambdaN(loc,nal,b1) -> 
+  | CLambdaN(loc,nal,b1) ->
       CLambdaN(loc,
-	       List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args  b2)) nal, 
+	       List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args  b2)) nal,
 	       add_args id new_args  b1)
-  | CLetIn(loc,na,b1,b2) -> 
+  | CLetIn(loc,na,b1,b2) ->
       CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
-  | CAppExpl(loc,(pf,r),exprl) -> 
-      begin 
-	match r with 
-	| Libnames.Ident(loc,fname) when fname = id -> 
+  | CAppExpl(loc,(pf,r),exprl) ->
+      begin
+	match r with
+	| Libnames.Ident(loc,fname) when fname = id ->
 	    CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
 	| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
       end
-  | CApp(loc,(pf,b),bl) -> 
-      CApp(loc,(pf,add_args id new_args b), 
+  | CApp(loc,(pf,b),bl) ->
+      CApp(loc,(pf,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,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,Option.map (add_args id new_args) b_option)) cel, 
+			 (na,Option.map (add_args id new_args) 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) -> 
+  | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
       CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option),
 		add_args id new_args b1,
 		add_args id new_args b2
 	       )
-		
-  | CIf(loc,b1,(na,b_option),b2,b3) -> 
-      CIf(loc,add_args id new_args b1, 
+
+  | CIf(loc,b1,(na,b_option),b2,b3) ->
+      CIf(loc,add_args id new_args b1,
 	  (na,Option.map (add_args id new_args) b_option),
 	  add_args id new_args b2,
 	  add_args id new_args b3
@@ -608,11 +627,14 @@ let rec add_args id new_args b =
   | CPatVar _ -> b
   | CEvar _ -> b
   | CSort _ -> b
-  | CCast(loc,b1,CastConv(ck,b2))  -> 
+  | CCast(loc,b1,CastConv(ck,b2))  ->
       CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2))
   | CCast(loc,b1,CastCoerce) ->
       CCast(loc,add_args id new_args b1,CastCoerce)
-  | CRecord _ -> anomaly "add_args : CRecord"
+  | CRecord (loc, w, pars) ->
+      CRecord (loc,
+	       (match w with Some w -> Some (add_args id new_args w) | _ -> None),
+	       List.map (fun (e,o) -> e, add_args id new_args o) pars)
   | CNotation _ -> anomaly "add_args : CNotation"
   | CGeneralization _ -> anomaly "add_args : CGeneralization"
   | CPrim _ -> b
@@ -621,84 +643,85 @@ let rec add_args id new_args b =
 exception Stop of  Topconstr.constr_expr
 
 
-(* [chop_n_arrow n t] chops the [n] first arrows in [t] 
-   Acts on Topconstr.constr_expr 
+(* [chop_n_arrow n t] chops the [n] first arrows in [t]
+   Acts on Topconstr.constr_expr
 *)
-let rec chop_n_arrow n t = 
-  if n <= 0 
+let rec chop_n_arrow n t =
+  if n <= 0
   then t (* If we have already removed all the arrows then return the type *)
-  else (* If not we check the form of [t] *) 
-    match t with 
+  else (* If not we check the form of [t] *)
+    match t with
       | Topconstr.CArrow(_,_,t) ->  (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
 	  chop_n_arrow (n-1) t
-      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : 
+      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
 					     either we need to discard more than the number of arrows contained
 					     in this product declaration then we just recall [chop_n_arrow] on
-					     the remaining number of arrow to chop and [t'] we discard it and 
-					     recall [chop_n_arrow], either this product contains more arrows 
+					     the remaining number of arrow to chop and [t'] we discard it and
+					     recall [chop_n_arrow], either this product contains more arrows
 					     than the number we need to chop and then we return the new type
 					  *)
-	  begin 
-	    try 
+	  begin
+	    try
 	      let new_n =
-		let rec aux (n:int) = function 
+		let rec aux (n:int) = function
 		    [] -> n
-		| (nal,k,t'')::nal_ta' -> 
-		    let nal_l = List.length nal in 
+		| (nal,k,t'')::nal_ta' ->
+		    let nal_l = List.length nal in
 		    if n >= nal_l
-		    then 
+		    then
 		      aux (n - nal_l) nal_ta'
-		    else 
-		      let new_t' = 
+		    else
+		      let new_t' =
 			Topconstr.CProdN(dummy_loc,
 					((snd (list_chop n nal)),k,t'')::nal_ta',t')
-		      in 
+		      in
 		      raise (Stop new_t')
 		in
 		aux n nal_ta'
-	    in 
+	    in
 	      chop_n_arrow new_n t'
 	    with Stop t -> t
 	  end
       | _ -> anomaly "Not enough products"
-  
 
-let rec get_args b t : Topconstr.local_binder list * 
-    Topconstr.constr_expr * Topconstr.constr_expr = 
-  match b with 
-    | Topconstr.CLambdaN (loc, (nal_ta), b') -> 
+
+let rec get_args b t : Topconstr.local_binder list *
+    Topconstr.constr_expr * Topconstr.constr_expr =
+  match b with
+    | Topconstr.CLambdaN (loc, (nal_ta), b') ->
 	begin
-	  let n = 
-	    (List.fold_left (fun n (nal,_,_) -> 
+	  let n =
+	    (List.fold_left (fun n (nal,_,_) ->
 			       n+List.length nal) 0 nal_ta )
 	  in
-	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in 
-	  (List.map (fun (nal,k,ta) -> 
-		       (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' 
+	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
+	  (List.map (fun (nal,k,ta) ->
+		       (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
 	end
     | _ -> [],b,t
 
 
 let make_graph (f_ref:global_reference) =
- let c,c_body = 
-      match f_ref with 
-	| ConstRef c -> 
-	    begin try c,Global.lookup_constant c 
-	    with Not_found -> 
+ let c,c_body =
+      match f_ref with
+	| ConstRef c ->
+	    begin try c,Global.lookup_constant c
+	    with Not_found ->
 	      raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
 	    end
 	| _ -> raise (UserError ("", str "Not a function reference") )
 
   in
-  match c_body.const_body with
+   Dumpglob.pause ();
+  (match c_body.const_body with
     | None -> error "Cannot build a graph over an axiom !"
     | Some b ->
 	let env = Global.env () in
 	let body = (force b) in
-	let extern_body,extern_type = 
-	  with_full_print 
-	    (fun () -> 
-	       (Constrextern.extern_constr false env body, 
+	let extern_body,extern_type =
+	  with_full_print
+	    (fun () ->
+	       (Constrextern.extern_constr false env body,
 		Constrextern.extern_type false env
                   (Typeops.type_of_constant_type env c_body.const_type)
 	       )
@@ -706,47 +729,48 @@ let make_graph (f_ref:global_reference) =
 	    ()
 	in
 	let (nal_tas,b,t)  = get_args extern_body extern_type in
-	let expr_list = 
-	  match b with 
-	    | Topconstr.CFix(loc,l_id,fixexprl) -> 
-		let l = 
+	let expr_list =
+	  match b with
+	    | Topconstr.CFix(loc,l_id,fixexprl) ->
+		let l =
 		  List.map
-		    (fun (id,(n,recexp),bl,t,b) -> 
+		    (fun (id,(n,recexp),bl,t,b) ->
 		       let loc, rec_id = Option.get n in
-		       let new_args = 
-			 List.flatten 
-			   (List.map 
+		       let new_args =
+			 List.flatten
+			   (List.map
 			      (function
  				 | Topconstr.LocalRawDef (na,_)-> []
-			      	 | Topconstr.LocalRawAssum (nal,_,_) -> 
-				     List.map 
-				       (fun (loc,n) -> 
-					  CRef(Libnames.Ident(loc, Nameops.out_name n))) 
+			      	 | Topconstr.LocalRawAssum (nal,_,_) ->
+				     List.map
+				       (fun (loc,n) ->
+					  CRef(Libnames.Ident(loc, Nameops.out_name n)))
 				       nal
 			      )
 			      nal_tas
 			   )
 		       in
-		       let b' = add_args (snd id) new_args b in 
+		       let b' = add_args (snd id) new_args b in
 		       (id, Some (Struct rec_id),nal_tas@bl,t,b')
 		    )
 		    fixexprl
 		in
 		l
-	    | _ ->   
-		let id = id_of_label (con_label c) in 
+	    | _ ->
+		let id = id_of_label (con_label c) in
 		[((dummy_loc,id),None,nal_tas,t,b)]
 	in
 	do_generate_principle error_error false false expr_list;
 	(* We register the infos *)
-	let mp,dp,_ = repr_con c in 
-	List.iter 
-	  (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) 
-	  expr_list
+	let mp,dp,_ = repr_con c in
+	List.iter
+	  (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id)))
+	  expr_list);
+  Dumpglob.continue ()
 
 
 (* let make_graph _ = assert false	 *)
-	  
-let do_generate_principle = do_generate_principle warning_error true 
+
+let do_generate_principle = do_generate_principle warning_error true
 
 
diff --git a/contrib/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index a3c169b7..0f048f59 100644
--- a/contrib/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -15,7 +15,7 @@ let msgnl m =
 let invalid_argument s = raise (Invalid_argument s)
 
 
-let fresh_id avoid s = Termops.next_global_ident_away true (id_of_string s) avoid
+let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid
 
 let fresh_name avoid s = Name (fresh_id avoid s)
 
@@ -24,13 +24,13 @@ let get_name avoid ?(default="H") = function
   | Name n -> Name n
 
 let array_get_start a =
-  try 
+  try
     Array.init
       (Array.length a - 1)
       (fun i -> a.(i))
-  with Invalid_argument "index out of bounds" -> 
+  with Invalid_argument "index out of bounds" ->
     invalid_argument "array_get_start"
-      
+
 let id_of_name = function
     Name id -> id
   | _ -> raise Not_found
@@ -78,7 +78,7 @@ let chop_rlambda_n  =
 	match rt with
 	  | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
 	  | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
-	  | _ -> 
+	  | _ ->
 	      raise (Util.UserError("chop_rlambda_n",
 				    str "chop_rlambda_n: Not enough Lambdas"))
   in
@@ -107,11 +107,11 @@ let list_union_eq eq_fun l1 l2 =
 let list_add_set_eq eq_fun x l =
   if List.exists (eq_fun x) l then l else x::l
 
-  
+
 
 
 let const_of_id id =
-  let _,princ_ref = 
+  let _,princ_ref =
     qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
   in
   try Nametab.locate_constant princ_ref
@@ -119,7 +119,7 @@ let const_of_id id =
 
 let def_of_const t =
    match (Term.kind_of_term t) with
-    Term.Const sp -> 
+    Term.Const sp ->
       (try (match (Global.lookup_constant sp) with
              {Declarations.const_body=Some c} -> Declarations.force c
 	     |_ -> assert false)
@@ -127,26 +127,26 @@ let def_of_const t =
     |_ -> assert false
 
 let coq_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition" 
-    (Coqlib.init_modules @ Coqlib.arith_modules) s;;
+  Coqlib.gen_constant_in_modules "RecursiveDefinition"
+    Coqlib.init_modules s;;
 
 let constant sl s =
   constr_of_global
-    (Nametab.locate (make_qualid(Names.make_dirpath 
+    (Nametab.locate (make_qualid(Names.make_dirpath
 			   (List.map id_of_string (List.rev sl)))
 	       (id_of_string s)));;
 
 let find_reference sl s =
-    (Nametab.locate (make_qualid(Names.make_dirpath 
+    (Nametab.locate (make_qualid(Names.make_dirpath
 			   (List.map id_of_string (List.rev sl)))
 	       (id_of_string s)));;
 
 let eq = lazy(coq_constant "eq")
-let refl_equal = lazy(coq_constant "refl_equal")
+let refl_equal = lazy(coq_constant "eq_refl")
 
 (*****************************************************************)
 (* Copy of the standart save mechanism but without the much too  *)
-(* slow reduction function                                       *) 
+(* slow reduction function                                       *)
 (*****************************************************************)
 open Declarations
 open Entries
@@ -183,7 +183,7 @@ let save with_clean id const (locality,kind) hook =
 
 let extract_pftreestate pts =
   let pfterm,subgoals = Refiner.extract_open_pftreestate pts in
-  let tpfsigma = Refiner.evc_of_pftreestate pts in 
+  let tpfsigma = Refiner.evc_of_pftreestate pts in
   let exl = Evarutil.non_instantiated tpfsigma  in
   if subgoals <> [] or exl <> [] then
     Util.errorlabstrm "extract_proof"
@@ -198,19 +198,19 @@ let extract_pftreestate pts =
 let nf_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  
+  clos_norm_flags Closure.betaiotazeta
 
 let nf_betaiota =
   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.betaiota  
+  clos_norm_flags Closure.betaiota
 
 let cook_proof do_reduce =
-  let pfs = Pfedit.get_pftreestate () 
+  let pfs = Pfedit.get_pftreestate ()
 (*   and ident = Pfedit.get_current_proof_name ()  *)
   and (ident,strength,concl,hook) = Pfedit.current_proof_statement ()  in
   let env,sigma,pfterm = extract_pftreestate pfs in
-  let pfterm = 
+  let pfterm =
     if do_reduce
     then nf_betaiota env sigma pfterm
     else pfterm
@@ -228,32 +228,32 @@ let new_save_named opacity =
   let const = { const with const_entry_opaque = opacity } in
   save true id const persistence hook
 
-let get_proof_clean do_reduce = 
-  let result = cook_proof do_reduce in 
+let get_proof_clean do_reduce =
+  let result = cook_proof do_reduce in
   Pfedit.delete_current_proof ();
   result
 
-let with_full_print f a = 
+let with_full_print f a =
   let old_implicit_args = Impargs.is_implicit_args ()
   and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
   and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
-  let old_rawprint = !Flags.raw_print in 
+  let old_rawprint = !Flags.raw_print in
   Flags.raw_print := true;
   Impargs.make_implicit_args false;
   Impargs.make_strict_implicit_args false;
   Impargs.make_contextual_implicit_args false;
   Impargs.make_contextual_implicit_args false;
   Dumpglob.pause ();
-  try 
-    let res = f a in 
+  try
+    let res = f a in
     Impargs.make_implicit_args old_implicit_args;
     Impargs.make_strict_implicit_args old_strict_implicit_args;
     Impargs.make_contextual_implicit_args old_contextual_implicit_args;
     Flags.raw_print := old_rawprint;
     Dumpglob.continue ();
     res
-  with  
-    | e -> 
+  with
+    | e ->
 	Impargs.make_implicit_args old_implicit_args;
 	Impargs.make_strict_implicit_args old_strict_implicit_args;
 	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
@@ -268,19 +268,19 @@ let with_full_print f a =
 
 (**********************)
 
-type function_info = 
-    { 
+type function_info =
+    {
       function_constant : constant;
       graph_ind : inductive;
       equation_lemma : constant option;
       correctness_lemma : constant option;
-      completeness_lemma : constant option; 
+      completeness_lemma : constant option;
       rect_lemma : constant option;
       rec_lemma : constant option;
       prop_lemma : constant option;
       is_general : bool; (* Has this function been defined using general recursive definition *)
     }
-      
+
 
 (* type function_db  = function_info list *)
 
@@ -290,54 +290,54 @@ type function_info =
 let from_function = ref Cmap.empty
 let from_graph = ref Indmap.empty
 (*
-let rec do_cache_info finfo = function 
-  | [] -> raise Not_found 
-  | (finfo'::finfos as l) -> 
-      if finfo' == finfo then l 
-      else if finfo'.function_constant = finfo.function_constant 
+let rec do_cache_info finfo = function
+  | [] -> raise Not_found
+  | (finfo'::finfos as l) ->
+      if finfo' == finfo then l
+      else if finfo'.function_constant = finfo.function_constant
       then finfo::finfos
       else
-	let res = do_cache_info finfo finfos in 
+	let res = do_cache_info finfo finfos in
 	if res == finfos then l else  finfo'::l
-  
 
-let cache_Function (_,(finfos)) = 
-  let new_tbl = 
+
+let cache_Function (_,(finfos)) =
+  let new_tbl =
     try do_cache_info finfos !function_table
     with Not_found -> finfos::!function_table
-  in  
-  if new_tbl != !function_table 
+  in
+  if new_tbl != !function_table
   then function_table := new_tbl
 *)
 
-let cache_Function (_,finfos) = 
+let cache_Function (_,finfos) =
   from_function := Cmap.add finfos.function_constant finfos !from_function;
   from_graph := Indmap.add finfos.graph_ind finfos !from_graph
 
 
 let load_Function _  = cache_Function
 let open_Function _ = cache_Function
-let subst_Function (_,subst,finfos) = 
+let subst_Function (subst,finfos) =
   let do_subst_con c = fst (Mod_subst.subst_con subst c)
-  and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i)
+  and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i)
   in
-  let function_constant' = do_subst_con finfos.function_constant in 
-  let graph_ind' = do_subst_ind finfos.graph_ind in 
-  let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in 
-  let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in 
-  let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in 
+  let function_constant' = do_subst_con finfos.function_constant in
+  let graph_ind' = do_subst_ind finfos.graph_ind in
+  let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in
+  let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in
+  let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in
   let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in
-  let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in 
-  let prop_lemma' =  Option.smartmap do_subst_con finfos.prop_lemma in 
-  if function_constant' == finfos.function_constant && 
-    graph_ind' == finfos.graph_ind && 
+  let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in
+  let prop_lemma' =  Option.smartmap do_subst_con finfos.prop_lemma in
+  if function_constant' == finfos.function_constant &&
+    graph_ind' == finfos.graph_ind &&
     equation_lemma' == finfos.equation_lemma &&
-    correctness_lemma' == finfos.correctness_lemma && 
-    completeness_lemma' == finfos.completeness_lemma && 
-    rect_lemma' == finfos.rect_lemma && 
-    rec_lemma' == finfos.rec_lemma && 
-    prop_lemma' == finfos.prop_lemma 
-  then finfos 
+    correctness_lemma' == finfos.correctness_lemma &&
+    completeness_lemma' == finfos.completeness_lemma &&
+    rect_lemma' == finfos.rect_lemma &&
+    rec_lemma' == finfos.rec_lemma &&
+    prop_lemma' == finfos.prop_lemma
+  then finfos
   else
     { function_constant = function_constant';
       graph_ind = graph_ind';
@@ -350,30 +350,28 @@ let subst_Function (_,subst,finfos) =
       is_general = finfos.is_general
     }
 
-let classify_Function (_,infos) = Libobject.Substitute infos
-
-let export_Function infos = Some infos
+let classify_Function infos = Libobject.Substitute infos
 
 
-let discharge_Function (_,finfos) = 
+let discharge_Function (_,finfos) =
   let function_constant' = Lib.discharge_con finfos.function_constant
-  and graph_ind' = Lib.discharge_inductive finfos.graph_ind 
-  and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma 
-  and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma 
-  and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma 
-  and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma 
+  and graph_ind' = Lib.discharge_inductive finfos.graph_ind
+  and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma
+  and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma
+  and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma
+  and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma
   and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma
   and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma
   in
-  if function_constant' == finfos.function_constant && 
-    graph_ind' == finfos.graph_ind && 
+  if function_constant' == finfos.function_constant &&
+    graph_ind' == finfos.graph_ind &&
     equation_lemma' == finfos.equation_lemma &&
-    correctness_lemma' == finfos.correctness_lemma && 
-    completeness_lemma' == finfos.completeness_lemma && 
-    rect_lemma' == finfos.rect_lemma && 
-    rec_lemma' == finfos.rec_lemma && 
-    prop_lemma' == finfos.prop_lemma 
-  then Some finfos 
+    correctness_lemma' == finfos.correctness_lemma &&
+    completeness_lemma' == finfos.completeness_lemma &&
+    rect_lemma' == finfos.rect_lemma &&
+    rec_lemma' == finfos.rec_lemma &&
+    prop_lemma' == finfos.prop_lemma
+  then Some finfos
   else
     Some { function_constant = function_constant' ;
 	   graph_ind = graph_ind' ;
@@ -384,12 +382,12 @@ let discharge_Function (_,finfos) =
 	   rec_lemma = rec_lemma';
 	   prop_lemma = prop_lemma' ;
 	   is_general = finfos.is_general
-	 }    
+	 }
 
 open Term
-let pr_info f_info = 
+let pr_info f_info =
   str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
-    str "function_constant_type := " ++ 
+    str "function_constant_type := " ++
     (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
     str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
     str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
@@ -397,20 +395,19 @@ let pr_info f_info =
     str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
     str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
     str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
-    str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () 
+    str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
 
-let pr_table tb = 
-  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in 
+let pr_table tb =
+  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in
   Util.prlist_with_sep fnl pr_info l
 
-let in_Function,out_Function = 
+let in_Function,out_Function =
   Libobject.declare_object
-    {(Libobject.default_object "FUNCTIONS_DB") with 
+    {(Libobject.default_object "FUNCTIONS_DB") with
        Libobject.cache_function = cache_Function;
        Libobject.load_function  = load_Function;
        Libobject.classify_function  = classify_Function;
        Libobject.subst_function = subst_Function;
-       Libobject.export_function = export_Function;
        Libobject.discharge_function = discharge_Function
 (*        Libobject.open_function = open_Function; *)
     }
@@ -418,59 +415,57 @@ let in_Function,out_Function =
 
 
 (* Synchronisation with reset *)
-let freeze () = 
+let freeze () =
   !from_function,!from_graph
-let unfreeze (functions,graphs) = 
+let unfreeze (functions,graphs) =
 (*   Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
   from_function := functions;
   from_graph := graphs
 
-let init () = 
+let init () =
 (*   Pp.msgnl (str "reseting function_table");  *)
   from_function := Cmap.empty;
   from_graph := Indmap.empty
 
-let _ = 
+let _ =
   Summary.declare_summary "functions_db_sum"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false; 
-      Summary.survive_section = false }
-
-let find_or_none id = 
-  try Some 
-    (match Nametab.locate (make_short_qualid id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" 
-    ) 
+      Summary.init_function = init }
+
+let find_or_none id =
+  try Some
+    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
+    )
   with Not_found -> None
 
 
 
-let find_Function_infos f = 
+let find_Function_infos f =
   Cmap.find f !from_function
 
 
-let find_Function_of_graph ind = 
+let find_Function_of_graph ind =
   Indmap.find ind !from_graph
-  
-let update_Function finfo = 
+
+let update_Function finfo =
 (*   Pp.msgnl (pr_info finfo); *)
   Lib.add_anonymous_leaf (in_Function finfo)
-      
-  
-let add_Function is_general f = 
-  let f_id = id_of_label (con_label f) in 
+
+
+let add_Function is_general f =
+  let f_id = id_of_label (con_label f) in
   let equation_lemma = find_or_none (mk_equation_id f_id)
-  and correctness_lemma = find_or_none (mk_correct_id f_id) 
-  and completeness_lemma = find_or_none (mk_complete_id f_id) 
+  and correctness_lemma = find_or_none (mk_correct_id f_id)
+  and completeness_lemma = find_or_none (mk_complete_id f_id)
   and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect")
   and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec")
   and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
-  and graph_ind = 
-    match Nametab.locate (make_short_qualid (mk_rel_id f_id)) 
+  and graph_ind =
+    match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
     with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
   in
-  let finfos = 
+  let finfos =
     { function_constant = f;
       equation_lemma = equation_lemma;
       completeness_lemma = completeness_lemma;
@@ -480,7 +475,7 @@ let add_Function is_general f =
       prop_lemma = prop_lemma;
       graph_ind = graph_ind;
       is_general = is_general
-      
+
     }
   in
   update_Function finfos
@@ -488,14 +483,27 @@ let add_Function is_general f =
 let pr_table () = pr_table !from_function
 (*********************************)
 (* Debuging *)
-let function_debug = ref false 
+let functional_induction_rewrite_dependent_proofs = ref true
+let function_debug = ref false
 open Goptions
 
+let functional_induction_rewrite_dependent_proofs_sig = 
+  {
+    optsync = false;
+    optname = "Functional Induction Rewrite Dependent";
+    optkey =  ["Functional";"Induction";"Rewrite";"Dependent"];
+    optread = (fun () -> !functional_induction_rewrite_dependent_proofs);
+    optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b)
+  }
+let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig
+
+let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true
+
 let function_debug_sig =
   {
     optsync = false;
     optname = "Function debug";
-    optkey =  PrimaryTable("Function_debug");
+    optkey =  ["Function_debug"];
     optread = (fun () -> !function_debug);
     optwrite = (fun b -> function_debug := b)
   }
@@ -503,10 +511,48 @@ let function_debug_sig =
 let _ = declare_bool_option function_debug_sig
 
 
-let do_observe () = 
+let do_observe () =
   !function_debug = true
-      
-      
-    
-exception Building_graph of exn 
+
+
+
+let strict_tcc = ref false
+let is_strict_tcc () = !strict_tcc
+let strict_tcc_sig =
+  {
+    optsync = false;
+    optname = "Raw Function Tcc";
+    optkey =  ["Function_raw_tcc"];
+    optread = (fun () -> !strict_tcc);
+    optwrite = (fun b -> strict_tcc := b)
+  }
+
+let _ = declare_bool_option strict_tcc_sig
+
+
+exception Building_graph of exn
 exception Defining_principle of exn
+exception ToShow of exn
+
+let init_constant dir s =
+  try
+    Coqlib.gen_constant "Function" dir s
+  with e -> raise (ToShow e)
+
+let jmeq () =
+  try
+    (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+     init_constant ["Logic";"JMeq"] "JMeq")
+  with e -> raise (ToShow e)
+
+let jmeq_rec () =
+  try
+    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+	  init_constant ["Logic";"JMeq"] "JMeq_rec"
+  with e -> raise (ToShow e)
+
+let jmeq_refl () =
+  try
+    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+    init_constant ["Logic";"JMeq"] "JMeq_refl"
+  with e -> raise (ToShow e)
diff --git a/contrib/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index 7da1d6f0..6f6607fc 100644
--- a/contrib/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -1,10 +1,10 @@
 open Names
 open Pp
 
-(* 
-   The mk_?_id function build different name w.r.t. a function 
-   Each of their use is justified in the code 
-*) 
+(*
+   The mk_?_id function build different name w.r.t. a function
+   Each of their use is justified in the code
+*)
 val mk_rel_id : identifier -> identifier
 val mk_correct_id : identifier -> identifier
 val mk_complete_id : identifier -> identifier
@@ -16,8 +16,8 @@ val msgnl : std_ppcmds -> unit
 val invalid_argument : string -> 'a
 
 val fresh_id : identifier list -> string -> identifier
-val fresh_name : identifier list -> string -> name 
-val get_name : identifier list -> ?default:string -> name -> name 
+val fresh_name : identifier list -> string -> name
+val get_name : identifier list -> ?default:string -> name -> name
 
 val array_get_start : 'a array -> 'a array
 
@@ -45,11 +45,12 @@ val def_of_const : Term.constr -> Term.constr
 val eq : Term.constr Lazy.t
 val refl_equal : Term.constr Lazy.t
 val const_of_id: identifier -> constant
+val jmeq : unit -> Term.constr
+val jmeq_refl : unit -> Term.constr
 
+(* [save_named] is a copy of [Command.save_named] but uses
+   [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast]
 
-(* [save_named] is a copy of [Command.save_named] but uses 
-   [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] 
-   
 
 
    DON'T USE IT if you cannot ensure that there is no VMcast in the proof
@@ -58,32 +59,32 @@ val const_of_id: identifier -> constant
 
 (* val nf_betaiotazeta : Reductionops.reduction_function *)
 
-val new_save_named : bool -> unit 
+val new_save_named : bool -> unit
 
-val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind -> 
-  Tacexpr.declaration_hook -> unit 
+val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind ->
+  Tacexpr.declaration_hook -> unit
 
-(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and 
-   abort the proof 
+(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
+   abort the proof
 *)
-val get_proof_clean : bool ->     
+val get_proof_clean : bool ->
   Names.identifier *
     (Entries.definition_entry * Decl_kinds.goal_kind *
        Tacexpr.declaration_hook)
-    
 
 
-(* [with_full_print f a] applies [f] to [a] in full printing environment 
-   
-   This function preserves the print settings 
+
+(* [with_full_print f a] applies [f] to [a] in full printing environment
+
+   This function preserves the print settings
 *)
 val with_full_print : ('a -> 'b) -> 'a -> 'b
 
 
 (*****************)
 
-type function_info = 
-    { 
+type function_info =
+    {
       function_constant : constant;
       graph_ind : inductive;
       equation_lemma : constant option;
@@ -100,18 +101,21 @@ val find_Function_of_graph : inductive -> function_info
 (* WARNING: To be used just after the graph definition !!! *)
 val add_Function : bool -> constant -> unit
 
-val update_Function : function_info -> unit 
+val update_Function : function_info -> unit
 
 
-(** debugging *) 
+(** debugging *)
 val pr_info : function_info -> Pp.std_ppcmds
 val pr_table : unit -> Pp.std_ppcmds
 
 
 (* val function_debug : bool ref  *)
 val do_observe : unit -> bool
+val do_rewrite_dependent : unit -> bool
 
 (* To localize pb *)
-exception Building_graph of exn 
+exception Building_graph of exn
 exception Defining_principle of exn
+exception ToShow of exn
 
+val is_strict_tcc : unit -> bool
diff --git a/contrib/funind/invfun.ml b/plugins/funind/invfun.ml
index 5c8f0871..8c22265d 100644
--- a/contrib/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -22,17 +22,17 @@ open Hiddentac
 
 (* Some pretty printing function for debugging purpose *)
 
-let pr_binding prc  = 
+let pr_binding prc  =
   function
-    | loc, Rawterm.NamedHyp id, (_,c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
-    | loc, Rawterm.AnonHyp n, (_,c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
 
 let pr_bindings prc prlc = function
   | Rawterm.ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-      Util.prlist_with_sep spc (fun (_,c) -> prc c) l
+      Util.prlist_with_sep spc prc l
   | Rawterm.ExplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++ 
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
         Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | Rawterm.NoBindings -> mt ()
 
@@ -42,7 +42,7 @@ let pr_with_bindings prc prlc (c,bl) =
 
 
 
-let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds = 
+let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds =
   pr_with_bindings prc prc  (c,bl)
 
 (* The local debuging mechanism *)
@@ -61,11 +61,11 @@ let observennl strm =
 
 let do_observe_tac s tac g =
   let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
-  try    
+  try
     let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
   with e ->
-    msgnl (str "observation "++ s++str " raised exception " ++ 
-	     Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+    msgnl (str "observation "++ s++str " raised exception " ++
+	     Cerrors.explain_exn e ++ str " on goal " ++ goal );
     raise e;;
 
 
@@ -75,117 +75,115 @@ let observe_tac s tac g =
   else tac g
 
 (* [nf_zeta] $\zeta$-normalization of a term *)
-let nf_zeta =       
+let nf_zeta =
   Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
     Environ.empty_env
     Evd.empty
 
 
 (* [id_to_constr id] finds the term associated to [id] in the global environment *)
-let id_to_constr id = 
+let id_to_constr id =
   try
     Tacinterp.constr_of_id (Global.env ())  id
-  with Not_found -> 
+  with Not_found ->
     raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
 
-(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] 
-   (resp. g_to_f = false) where [graph]  is the graph of [f] and is the [i]th function in the block. 
+(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true]
+   (resp. g_to_f = false) where [graph]  is the graph of [f] and is the [i]th function in the block.
 
-   [generate_type true f i] returns 
-   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, 
-   graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion 
+   [generate_type true f i] returns
+   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
+   graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion
 
-   [generate_type false f i] returns 
-   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, 
-   res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion 
+   [generate_type false f i] returns
+   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
+   res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion
  *)
 
-let generate_type g_to_f f graph i = 
+let generate_type g_to_f f graph i =
   (*i we deduce the number of arguments of the function and its returned type from the graph i*)
-  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in 
-  let ctxt,_ = decompose_prod_assum graph_arity in 
-  let fun_ctxt,res_type = 
-    match ctxt with 
+  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in
+  let ctxt,_ = decompose_prod_assum graph_arity in
+  let fun_ctxt,res_type =
+    match ctxt with
       | [] | [_] -> anomaly "Not a valid context"
       | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
   in
   let nb_args = List.length fun_ctxt in
-  let args_from_decl i decl = 
-    match decl with 
+  let args_from_decl i decl =
+    match decl with
       | (_,Some _,_) -> incr i; failwith "args_from_decl"
-      | _ -> let j = !i in incr i;mkRel (nb_args - j  + 1) 
+      | _ -> let j = !i in incr i;mkRel (nb_args - j  + 1)
   in
   (*i We need to name the vars [res] and [fv] i*)
-  let res_id = 
-    Termops.next_global_ident_away 
-      true
+  let res_id =
+    Namegen.next_ident_away_in_goal
       (id_of_string "res")
       (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
   in
-  let fv_id = 
-    Termops.next_global_ident_away 
-      true
+  let fv_id =
+    Namegen.next_ident_away_in_goal
       (id_of_string "fv")
       (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
   in
   (*i we can then type the argument to be applied to the function [f] i*)
-  let args_as_rels = 
+  let args_as_rels =
     let i = ref 0 in
-    Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) 
+    Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
   in
   let args_as_rels = Array.map Termops.pop args_as_rels in
   (*i
-    the hypothesis [res = fv] can then be computed 
-    We will need to lift it by one in order to use it as a conclusion 
+    the hypothesis [res = fv] can then be computed
+    We will need to lift it by one in order to use it as a conclusion
     i*)
   let res_eq_f_of_args =
     mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
-  in 
-  (*i 
-    The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed 
-    We will need to lift it by one in order to use it as a conclusion 
-    i*)  
-  let graph_applied = 
-    let args_and_res_as_rels = 
+  in
+  (*i
+    The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
+    We will need to lift it by one in order to use it as a conclusion
+    i*)
+  let graph_applied =
+    let args_and_res_as_rels =
       let i = ref 0 in
       Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
     in
-    let args_and_res_as_rels = 
+    let args_and_res_as_rels =
       Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
     in
-    mkApp(graph,args_and_res_as_rels) 
-  in 
-  (*i The [pre_context]  is the defined to be the context corresponding to 
+    mkApp(graph,args_and_res_as_rels)
+  in
+  (*i The [pre_context]  is the defined to be the context corresponding to
     \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,  \]
     i*)
-  let pre_ctxt = 
-    (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt 
-  in 
+  let pre_ctxt =
+    (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst 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 
+  if g_to_f
   then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args)
   else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied)
 
 
-(* 
+(*
    [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect]
-   
+
    WARNING: while convertible, [type_of body] and [type] can be non equal
 *)
-let find_induction_principle f = 
-  let f_as_constant =  match kind_of_term f with  
+let find_induction_principle f =
+  let f_as_constant =  match kind_of_term f with
     | Const c' -> c'
     | _ -> error "Must be used with a function"
   in
-  let infos = find_Function_infos f_as_constant in 
-  match infos.rect_lemma with 
-    | None -> raise Not_found 
-    | Some rect_lemma -> 
-	let rect_lemma = mkConst rect_lemma in 
-	let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in 
+  let infos = find_Function_infos f_as_constant in
+  match infos.rect_lemma with
+    | None -> raise Not_found
+    | Some rect_lemma ->
+	let rect_lemma = mkConst rect_lemma in
+	let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in
 	rect_lemma,typ
-	
-  
+
+
 
 (*     let fname =  *)
 (*       match kind_of_term f with  *)
@@ -205,41 +203,41 @@ let find_induction_principle f =
 (*     c,Typing.type_of (Global.env ()) Evd.empty c *)
 
 
-let rec generate_fresh_id x avoid i = 
-  if i == 0 
-  then [] 
+let rec generate_fresh_id x avoid i =
+  if i == 0
+  then []
   else
-    let id = Termops.next_global_ident_away true x avoid in 
+    let id = Namegen.next_ident_away_in_goal x avoid in
     id::(generate_fresh_id x (id::avoid) (pred i))
 
 
-(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] 
-   is the tactic used to prove correctness lemma. 
-   
+(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
+   is the tactic used to prove correctness lemma.
+
    [functional_induction] is the tactic defined in [indfun] (dependency problem)
    [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
-   (resp. graphs of the functions and principles and correctness lemma types) to prove correct. 
-   
+   (resp. graphs of the functions and principles and correctness lemma types) to prove correct.
+
    [i] is the indice of the function to prove correct
 
-   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is 
+   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
    it looks like~:
-   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, 
+   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
    res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res]
 
 
-   The sketch of the proof is the following one~: 
+   The sketch of the proof is the following one~:
    \begin{enumerate}
    \item intros until $x_n$
    \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i)
-   \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the 
+   \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the
    apply the corresponding constructor of the corresponding graph inductive.
    \end{enumerate}
-   
+
 *)
 let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
   fun g ->
-    (* first of all we recreate the lemmas types to be used as predicates of the induction principle 
+    (* first of all we recreate the lemmas types to be used as predicates of the induction principle
        that is~:
        \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
     *)
@@ -257,8 +255,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
     in
     (* we the get the definition of the graphs block *)
     let graph_ind = destInd graphs_constr.(i) in
-    let kn = fst graph_ind in 
-    let mib,_ = Global.lookup_inductive graph_ind in 
+    let kn = fst graph_ind in
+    let mib,_ = Global.lookup_inductive graph_ind in
     (* and the principle to use in this lemma in $\zeta$ normal form *)
     let f_principle,princ_type = schemes.(i) in
     let princ_type =  nf_zeta princ_type in
@@ -267,11 +265,11 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
     let nb_fun_args = nb_prod (pf_concl g)  - 2  in
     let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
-    (* Since we cannot ensure that the funcitonnal principle is defined in the 
+    (* Since we cannot ensure that the funcitonnal principle is defined in the
        environement and due to the bug #1174, we will need to pose the principle
-       using a name 
+       using a name
     *)
-    let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in
+    let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in
     let ids = principle_id :: ids in
     (* We get the branches of the principle *)
     let branches = List.rev princ_infos.branches in
@@ -290,8 +288,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
     let eq_ind = Coqlib.build_coq_eq () in
     let eq_construct = mkConstruct((destInd eq_ind),1) in
     (* The next to referencies will be used to find out which constructor to apply in each branch *)
-    let ind_number = ref 0 
-    and min_constr_number = ref 0 in 
+    let ind_number = ref 0
+    and min_constr_number = ref 0 in
     (* The tactic to prove the ith branch of the principle *)
     let prove_branche i g =
       (* We get the identifiers of this branch *)
@@ -317,18 +315,18 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 		     (pre_args,
 		      tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
 		     )
-		     
+
 	     else (pre_args,pre_tac)
 	  )
 	  (pf_hyps g)
 	  ([],tclIDTAC)
       in
-      (* 
-	 We can then recompute the arguments of the constructor. 
-	 For each [hid] introduced by this branch, if [hid] has type  
+      (*
+	 We can then recompute the arguments of the constructor.
+	 For each [hid] introduced by this branch, if [hid] has type
 	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
-	 [ fv (hid fv (refl_equal fv)) ]. 
-	 
+	 [ fv (hid fv (refl_equal fv)) ].
+
 	 If [hid] has another type the corresponding argument of the constructor is [hid]
       *)
       let constructor_args =
@@ -360,21 +358,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	let params_id = fst (list_chop princ_infos.nparams args_names) in
 	(List.map mkVar params_id)@(List.rev constructor_args)
       in
-      (* We then get the constructor corresponding to this branch and 
-	 modifies the references has needed i.e. 
-	 if the constructor is the last one of the current inductive then 
-	 add one the number of the inductive to take and add the number of constructor of the previous 
-	 graph to the minimal constructor number 
+      (* We then get the constructor corresponding to this branch and
+	 modifies the references has needed i.e.
+	 if the constructor is the last one of the current inductive then
+	 add one the number of the inductive to take and add the number of constructor of the previous
+	 graph to the minimal constructor number
       *)
-      let constructor = 
-	let constructor_num = i - !min_constr_number in 
-	let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in 
+      let constructor =
+	let constructor_num = i - !min_constr_number in
+	let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
 	if constructor_num <= length
-	then 
-	  begin 
+	then
+	  begin
 	    (kn,!ind_number),constructor_num
 	  end
-	else 
+	else
 	  begin
 	    incr ind_number;
 	    min_constr_number := !min_constr_number + length ;
@@ -418,15 +416,15 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
     let param_names = fst (list_chop princ_infos.nparams args_names) in
     let params = List.map mkVar param_names in
     let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
-    (* The bindings of the principle 
-       that is the params of the principle and the different lemma types 
+    (* The bindings of the principle
+       that is the params of the principle and the different lemma types
     *)
     let bindings =
       let params_bindings,avoid =
 	List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
-	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Rawterm.NamedHyp id,inj_open p)::bindings,id::avoid
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
 	  princ_infos.params
@@ -435,8 +433,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       let lemmas_bindings =
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
-	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in 
-	     (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid)
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (dummy_loc,Rawterm.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
 	  (lemmas)))
@@ -451,7 +449,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	  (h_exact f_principle));
 	tclTHEN_i
 	  (observe_tac "functional_induction" (
-	     fun g -> 
+	     fun g ->
 	       observe
 		 (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
 	       functional_induction  false (applist(funs_constr.(i),List.map mkVar args_names))
@@ -462,13 +460,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       ]
       g
 
-(* [generalize_dependent_of x hyp g] 
-   generalize every hypothesis which depends of [x] but [hyp] 
+(* [generalize_dependent_of x hyp g]
+   generalize every hypothesis which depends of [x] but [hyp]
 *)
-let generalize_dependent_of x hyp g = 
-  tclMAP 
-    (function 
-       | (id,None,t) when not (id = hyp) && 
+let generalize_dependent_of x hyp g =
+  tclMAP
+    (function
+       | (id,None,t) when not (id = hyp) &&
 	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
        | _ -> tclIDTAC
     )
@@ -479,100 +477,100 @@ let generalize_dependent_of x hyp g =
 
 
 
-    (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis 
+    (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
        (unfolding, substituting, destructing cases \ldots)
     *)
-let  rec intros_with_rewrite g = 
+let  rec intros_with_rewrite g =
   observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
-and intros_with_rewrite_aux : tactic = 
-  fun g -> 
-    let eq_ind = Coqlib.build_coq_eq () in 
-    match kind_of_term (pf_concl g) with 
-	  | Prod(_,t,t') -> 
-	      begin 
-		match kind_of_term t with 
-		  | App(eq,args) when (eq_constr eq eq_ind)  -> 
+and intros_with_rewrite_aux : tactic =
+  fun g ->
+    let eq_ind = Coqlib.build_coq_eq () in
+    match kind_of_term (pf_concl g) with
+	  | Prod(_,t,t') ->
+	      begin
+		match kind_of_term t with
+		  | App(eq,args) when (eq_constr eq eq_ind)  ->
  		      if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
 		      then
 			let id = pf_get_new_id (id_of_string "y") g  in
 			tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g
 
 		      else if isVar args.(1)
-		      then 			
-			let id = pf_get_new_id (id_of_string "y") g  in 
+		      then
+			let id = pf_get_new_id (id_of_string "y") g  in
 			tclTHENSEQ [ h_intro id;
-				     generalize_dependent_of (destVar args.(1)) id; 
+				     generalize_dependent_of (destVar args.(1)) id;
 				     tclTRY (Equality.rewriteLR (mkVar id));
 				     intros_with_rewrite
-				   ] 
+				   ]
 			  g
 		      else
-			begin 
-			  let id = pf_get_new_id (id_of_string "y") g  in 
+			begin
+			  let id = pf_get_new_id (id_of_string "y") g  in
 			  tclTHENSEQ[
 			    h_intro id;
 			    tclTRY (Equality.rewriteLR (mkVar id));
 			    intros_with_rewrite
 			  ] g
 			end
-		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> 
+		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
 		      Tauto.tauto g
-		  | Case(_,_,v,_) -> 
+		  | Case(_,_,v,_) ->
 		      tclTHENSEQ[
 			h_case false (v,Rawterm.NoBindings);
 			intros_with_rewrite
 		      ] g
-		  | LetIn _ -> 
+		  | LetIn _ ->
 		      tclTHENSEQ[
-			h_reduce 
+			h_reduce
 			  (Rawterm.Cbv
-			     {Rawterm.all_flags 
-			      with Rawterm.rDelta = false; 		 
-			     }) 
+			     {Rawterm.all_flags
+			      with Rawterm.rDelta = false;
+			     })
 			  onConcl
 			;
 			intros_with_rewrite
 		      ] g
-		  | _ -> 			
-		      let id = pf_get_new_id (id_of_string "y") g  in 
+		  | _ ->
+		      let id = pf_get_new_id (id_of_string "y") g  in
 		      tclTHENSEQ [ h_intro id;intros_with_rewrite] g
 	      end
-	  | LetIn _ -> 
+	  | LetIn _ ->
 	      tclTHENSEQ[
-		h_reduce 
+		h_reduce
 		  (Rawterm.Cbv
-		     {Rawterm.all_flags 
-		      with Rawterm.rDelta = false; 		 
-		     }) 
+		     {Rawterm.all_flags
+		      with Rawterm.rDelta = false;
+		     })
 		  onConcl
 		;
 		intros_with_rewrite
 	      ] g
-	  | _ -> tclIDTAC g 
-  
-let rec reflexivity_with_destruct_cases g = 
-  let destruct_case () = 
-    try 
-      match kind_of_term (snd (destApp (pf_concl g))).(2) with 
-	| Case(_,_,v,_) -> 
+	  | _ -> tclIDTAC g
+
+let rec reflexivity_with_destruct_cases g =
+  let destruct_case () =
+    try
+      match kind_of_term (snd (destApp (pf_concl g))).(2) with
+	| Case(_,_,v,_) ->
 	    tclTHENSEQ[
 	      h_case false (v,Rawterm.NoBindings);
 	      intros;
-	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases 
+	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
 	    ]
 	| _ -> reflexivity
     with _ -> reflexivity
   in
   let eq_ind =     Coqlib.build_coq_eq () in
   let discr_inject =
-    Tacticals.onAllClauses (
-       fun sc g -> 
-	 match sc with 
+    Tacticals.onAllHypsAndConcl (
+       fun sc g ->
+	 match sc with
 	     None -> tclIDTAC g
-	   | Some ((_,id),_) -> 
-	       match kind_of_term  (pf_type_of g (mkVar id)) with 
-		 | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> 
-		     if Equality.discriminable (pf_env g) (project g) t1 t2 
+	   | Some id ->
+	       match kind_of_term  (pf_type_of g (mkVar id)) with
+		 | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
+		     if Equality.discriminable (pf_env g) (project g) t1 t2
 		     then Equality.discrHyp id g
 		     else if Equality.injectable (pf_env g) (project g) t1 t2
 		     then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite]  g
@@ -583,10 +581,10 @@ let rec reflexivity_with_destruct_cases g =
   (tclFIRST
     [ reflexivity;
       tclTHEN (tclPROGRESS discr_inject) (destruct_case ());
-      (*  We reach this point ONLY if 
-	  the same value is matched (at least) two times 
+      (*  We reach this point ONLY if
+	  the same value is matched (at least) two times
 	  along binding path.
-	  In this case, either we have a discriminable hypothesis and we are done, 
+	  In this case, either we have a discriminable hypothesis and we are done,
 	  either at least an injectable one and we do the injection before continuing
       *)
       tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases
@@ -594,95 +592,95 @@ let rec reflexivity_with_destruct_cases g =
     g
 
 
-(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] 
-   is the tactic used to prove completness lemma. 
-   
+(* [prove_fun_complete funs graphs schemes lemmas_types_infos i]
+   is the tactic used to prove completness lemma.
+
    [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions
-   (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. 
-   
+   (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct.
+
    [i] is the indice of the function to prove complete
 
-   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is 
+   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
    it looks like~:
-   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, 
+   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
    graph\ x_1\ldots x_n\ res, \rightarrow  res = f x_1\ldots x_n in]
 
 
-   The sketch of the proof is the following one~: 
+   The sketch of the proof is the following one~:
    \begin{enumerate}
    \item intros until $H:graph\ x_1\ldots x_n\ res$
    \item $elim\ H$ using schemes.(i)
-   \item for each generated branch, intro  the news hyptohesis, for each such hyptohesis [h], if [h] has 
-   type [x=?] with [x] a variable, then subst [x], 
-   if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else 
-   if [h] is a match then destruct it, else do just introduce it, 
+   \item for each generated branch, intro  the news hyptohesis, for each such hyptohesis [h], if [h] has
+   type [x=?] with [x] a variable, then subst [x],
+   if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else
+   if [h] is a match then destruct it, else do just introduce it,
    after all intros, the conclusion should be a reflexive equality.
    \end{enumerate}
-   
+
 *)
 
 
-let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = 
-  fun g ->  
-    (* We compute the types of the different mutually recursive lemmas 
+let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
+  fun g ->
+    (* We compute the types of the different mutually recursive lemmas
        in $\zeta$ normal form
     *)
-    let lemmas = 
-      Array.map 
-	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) 
+    let lemmas =
+      Array.map
+	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt))
 	lemmas_types_infos
     in
     (* We get the constant and the principle corresponding to this lemma *)
     let f = funcs.(i) in
-    let graph_principle = nf_zeta schemes.(i)  in 
-    let princ_type = pf_type_of g graph_principle in 
-    let princ_infos = Tactics.compute_elim_sig princ_type in 
-    (* Then we get the number of argument of the function 
+    let graph_principle = nf_zeta schemes.(i)  in
+    let princ_type = pf_type_of g graph_principle in
+    let princ_infos = Tactics.compute_elim_sig princ_type in
+    (* Then we get the number of argument of the function
        and compute a fresh name for each of them
     *)
-    let nb_fun_args = nb_prod (pf_concl g)  - 2  in 
+    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
     let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* and fresh names for res H and the principle (cf bug bug #1174) *)
-    let res,hres,graph_principle_id = 
-      match generate_fresh_id (id_of_string "z") ids 3 with 
+    let res,hres,graph_principle_id =
+      match generate_fresh_id (id_of_string "z") ids 3 with
 	| [res;hres;graph_principle_id] -> res,hres,graph_principle_id
-	| _ -> assert false 
+	| _ -> assert false
     in
-    let ids = res::hres::graph_principle_id::ids in 
+    let ids = res::hres::graph_principle_id::ids in
     (* we also compute fresh names for each hyptohesis of each branche of the principle *)
-    let branches = List.rev princ_infos.branches in 
-    let intro_pats = 
-      List.map 
-	(fun (_,_,br_type) -> 
-	   List.map 
-	     (fun id -> id) 
+    let branches = List.rev princ_infos.branches in
+    let intro_pats =
+      List.map
+	(fun (_,_,br_type) ->
+	   List.map
+	     (fun id -> id)
 	     (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
 	)
 	branches
     in
-    (* We will need to change the function by its body 
-       using [f_equation] if it is recursive (that is the graph is infinite 
-       or unfold if the graph is finite 
+    (* We will need to change the function by its body
+       using [f_equation] if it is recursive (that is the graph is infinite
+       or unfold if the graph is finite
     *)
-    let rewrite_tac j ids : tactic = 
-      let graph_def = graphs.(j) in 
-      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in 
+    let rewrite_tac j ids : tactic =
+      let graph_def = graphs.(j) in
+      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in
       if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
-      then 
-	let eq_lemma = 
+      then
+	let eq_lemma =
 	  try Option.get (infos).equation_lemma
 	  with Option.IsNone -> anomaly "Cannot find equation lemma"
-	in 
+	in
 	tclTHENSEQ[
 	  tclMAP h_intro ids;
 	  Equality.rewriteLR (mkConst eq_lemma);
 	  (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
-	  h_reduce 
+	  h_reduce
 	    (Rawterm.Cbv
-	       {Rawterm.all_flags 
-		with Rawterm.rDelta = false; 		 
-	       }) 
+	       {Rawterm.all_flags
+		with Rawterm.rDelta = false;
+	       })
 	    onConcl
 	  ;
 	  h_generalize (List.map mkVar ids);
@@ -691,16 +689,16 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
       else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
     in
     (* The proof of each branche itself *)
-    let ind_number = ref 0 in 
+    let ind_number = ref 0 in
     let min_constr_number = ref 0 in
-    let prove_branche i g = 
+    let prove_branche i g =
       (* we fist compute the inductive corresponding to the branch *)
-      let this_ind_number = 
-	let constructor_num = i - !min_constr_number in 
-	let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in 
+      let this_ind_number =
+	let constructor_num = i - !min_constr_number in
+	let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in
 	if constructor_num <= length
 	then !ind_number
-	else 
+	else
 	  begin
 	    incr ind_number;
 	    min_constr_number := !min_constr_number + length;
@@ -719,13 +717,13 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	g
     in
     let params_names = fst (list_chop princ_infos.nparams args_names) in
-    let params = List.map mkVar params_names in 
-    tclTHENSEQ 
+    let params = List.map mkVar params_names in
+    tclTHENSEQ
       [ tclMAP h_intro (args_names@[res;hres]);
-	observe_tac "h_generalize" 
+	observe_tac "h_generalize"
 	(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
 	h_intro graph_principle_id;
-	observe_tac "" (tclTHEN_i 
+	observe_tac "" (tclTHEN_i
 	  (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
 	  (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
       ]
@@ -734,123 +732,123 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 
 
 
-let do_save () = Command.save_named false
+let do_save () = Lemmas.save_named false
 
 
-(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness 
+(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
    lemmas for each function in [funs] w.r.t. [graphs]
-   
-   [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and 
-   [functional_induction] is Indfun.functional_induction (same pb) 
+
+   [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and
+   [functional_induction] is Indfun.functional_induction (same pb)
 *)
-   
-let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = 
+
+let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
   let funs = Array.of_list funs and graphs = Array.of_list graphs in
   let funs_constr = Array.map mkConst funs  in
-  try 
-    let graphs_constr = Array.map mkInd graphs in 
-    let lemmas_types_infos = 
-      Util.array_map2_i 
-	(fun i f_constr graph -> 
-	   let const_of_f = destConst f_constr in 
-	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = 
+  try
+    let graphs_constr = Array.map mkInd graphs in
+    let lemmas_types_infos =
+      Util.array_map2_i
+	(fun i f_constr graph ->
+	   let const_of_f = destConst f_constr in
+	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
 	     generate_type false const_of_f graph i
-	   in 
-	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in 
+	   in
+	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
 	   let type_of_lemma = nf_zeta type_of_lemma in
 	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
 	   type_of_lemma,type_info
 	)
 	funs_constr
-	graphs_constr 
+	graphs_constr
     in
-    let schemes = 
-      (* The functional induction schemes are computed and not saved if there is more that one function 
+    let schemes =
+      (* The functional induction schemes are computed and not saved if there is more that one function
 	 if the block contains only one function we can safely reuse [f_rect]
       *)
       try
 	if Array.length funs_constr <> 1 then raise Not_found;
 	[| find_induction_principle funs_constr.(0) |]
-      with Not_found -> 
-	  Array.of_list 
-	    (List.map 
-	       (fun entry -> 
+      with Not_found ->
+	  Array.of_list
+	    (List.map
+	       (fun entry ->
 		  (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type )
 	       )
 	       (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs))
 	    )
     in
-    let proving_tac = 
+    let proving_tac =
       prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos
     in
-    Array.iteri 
-      (fun i f_as_constant -> 
+    Array.iteri
+      (fun i f_as_constant ->
 	 let f_id = id_of_label (con_label f_as_constant) in
-	 Command.start_proof 
+	 Lemmas.start_proof
 	   (*i The next call to mk_correct_id is valid since we are constructing the lemma
 	     Ensures by: obvious
-	     i*) 
+	     i*)
 	   (mk_correct_id f_id)
 	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
 	   (fst lemmas_types_infos.(i))
 	   (fun _ _ -> ());
 	 Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
 	 do_save ();
-	 let finfo = find_Function_infos f_as_constant in 
+	 let finfo = find_Function_infos f_as_constant in
 	 update_Function
-	   {finfo with 
+	   {finfo with
 	      correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
 	   }
 
       )
       funs;
-    let lemmas_types_infos = 
-      Util.array_map2_i 
-	(fun i f_constr graph -> 
-	   let const_of_f = destConst f_constr in 
-	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = 
+    let lemmas_types_infos =
+      Util.array_map2_i
+	(fun i f_constr graph ->
+	   let const_of_f = destConst f_constr in
+	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
 	     generate_type true  const_of_f graph i
-	   in 
-	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in 
+	   in
+	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
 	   let type_of_lemma = nf_zeta type_of_lemma in
 	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
 	   type_of_lemma,type_info
 	)
 	funs_constr
-	graphs_constr 
+	graphs_constr
     in
-    let kn,_ as graph_ind  = destInd graphs_constr.(0) in 
+    let kn,_ as graph_ind  = destInd graphs_constr.(0) in
     let  mib,mip = Global.lookup_inductive graph_ind in
-    let schemes = 
-      Array.of_list 
-	(Indrec.build_mutual_indrec (Global.env ()) Evd.empty
-	   (Array.to_list 
+    let schemes =
+      Array.of_list
+	(Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty
+	   (Array.to_list
 	      (Array.mapi
-		 (fun i mip -> (kn,i),mib,mip,true,InType)
+		 (fun i _ -> (kn,i),true,InType)
 		 mib.Declarations.mind_packets
 	      )
 	   )
 	)
     in
-    let proving_tac = 
+    let proving_tac =
       prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
     in
-    Array.iteri 
-      (fun i f_as_constant -> 
+    Array.iteri
+      (fun i f_as_constant ->
 	 let f_id = id_of_label (con_label f_as_constant) in
-	 Command.start_proof 
+	 Lemmas.start_proof
 	   (*i The next call to mk_complete_id is valid since we are constructing the lemma
 	     Ensures by: obvious
-	     i*) 
+	     i*)
 	   (mk_complete_id f_id)
 	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
 	   (fst lemmas_types_infos.(i))
 	   (fun _ _ -> ());
 	 Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
 	 do_save ();
-	 let finfo = find_Function_infos f_as_constant in 
+	 let finfo = find_Function_infos f_as_constant in
 	 update_Function
-	   {finfo with 
+	   {finfo with
 	      completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
 	   }
       )
@@ -859,16 +857,16 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
     (* In case of problem, we reset all the lemmas *)
     (*i The next call to mk_correct_id is valid since we are erasing the lemmas
       Ensures by: obvious
-      i*) 
-    let first_lemma_id = 
-      let f_id = id_of_label (con_label funs.(0)) in 
-      
-      mk_correct_id f_id 
+      i*)
+    let first_lemma_id =
+      let f_id = id_of_label (con_label funs.(0)) in
+
+      mk_correct_id f_id
     in
      ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
     raise e
-	   
-		   
+
+
 
 
 
@@ -876,73 +874,73 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 
 (* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res
    when [kn] denotes a graph block  into
-   f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result 
-   
+   f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result
+
    if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
 *)
 let revert_graph kn post_tac hid g =
-    let typ = pf_type_of g (mkVar hid) in 
-    match kind_of_term typ with 
-      | App(i,args) when isInd i -> 
-	  let ((kn',num) as ind') = destInd i in 
-	  if kn = kn' 
+    let typ = pf_type_of g (mkVar hid) in
+    match kind_of_term typ with
+      | App(i,args) when isInd i ->
+	  let ((kn',num) as ind') = destInd i in
+	  if kn = kn'
 	  then (* We have generated a graph hypothesis so that we must change it if we can *)
-	    let info = 
+	    let info =
 	      try find_Function_of_graph ind'
 	      with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
 		anomaly "Cannot retrieve infos about a mutual block"
-	    in 
-	    (* if we can find a completeness lemma for this function 
-	       then we can come back to the functional form. If not, we do nothing 
+	    in
+	    (* if we can find a completeness lemma for this function
+	       then we can come back to the functional form. If not, we do nothing
 	    *)
-	    match info.completeness_lemma with 
+	    match info.completeness_lemma with
 	      | None -> tclIDTAC g
-	      | Some f_complete -> 
+	      | Some f_complete ->
 		  let f_args,res = array_chop (Array.length args - 1) args in
 		  tclTHENSEQ
 		    [
 		      h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
 		      thin [hid];
-		      h_intro hid; 
+		      h_intro hid;
 		      post_tac hid
 		    ]
 		    g
-		    
+
 	  else tclIDTAC g
       | _ -> tclIDTAC g
 
 
-(* 
+(*
    [functional_inversion hid fconst f_correct ] is the functional version of [inversion]
-   
+
    [hid] is the hypothesis to invert, [fconst] is the function to invert and  [f_correct]
    is the correctness lemma for [fconst].
 
-   The sketch is the follwing~: 
-   \begin{enumerate} 
-   \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ 
+   The sketch is the follwing~:
+   \begin{enumerate}
+   \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$
    (fails if it is not possible)
    \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct]
    \item apply [inversion] on [hid]
-   \item finally in each branch, replace each  hypothesis [R\_f ..]  by [f ...] using [f_complete] (whenever 
+   \item finally in each branch, replace each  hypothesis [R\_f ..]  by [f ...] using [f_complete] (whenever
    such a lemma exists)
    \end{enumerate}
 *)
-     
-let functional_inversion kn hid fconst f_correct : tactic = 
-  fun g -> 
-    let old_ids = List.fold_right Idset.add  (pf_ids_of_hyps g) Idset.empty in 
-    let type_of_h = pf_type_of g (mkVar hid) in 
-    match kind_of_term type_of_h with 
-      | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ())  -> 
-	  let pre_tac,f_args,res = 
-	    match kind_of_term args.(1),kind_of_term args.(2) with 
-	      | App(f,f_args),_ when eq_constr f fconst -> 
+
+let functional_inversion kn hid fconst f_correct : tactic =
+  fun g ->
+    let old_ids = List.fold_right Idset.add  (pf_ids_of_hyps g) Idset.empty in
+    let type_of_h = pf_type_of g (mkVar hid) in
+    match kind_of_term type_of_h with
+      | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ())  ->
+	  let pre_tac,f_args,res =
+	    match kind_of_term args.(1),kind_of_term args.(2) with
+	      | App(f,f_args),_ when eq_constr f fconst ->
 		  ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
-	      |_,App(f,f_args) when eq_constr f fconst -> 
-		 ((fun hid -> tclIDTAC),f_args,args.(1)) 
+	      |_,App(f,f_args) when eq_constr f fconst ->
+		 ((fun hid -> tclIDTAC),f_args,args.(1))
 	      | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
-	  in 
+	  in
 	  tclTHENSEQ[
 	    pre_tac hid;
 	    h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
@@ -950,7 +948,7 @@ let functional_inversion kn hid fconst f_correct : tactic =
 	    h_intro hid;
 	    Inv.inv FullInversion None (Rawterm.NamedHyp hid);
 	    (fun g ->
-	       let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in 
+	       let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in
 	       tclMAP (revert_graph kn pre_tac)  (hid::new_ids)  g
 	    );
 	  ] g
@@ -958,62 +956,62 @@ let functional_inversion kn hid fconst f_correct : tactic =
 
 
 
-let invfun qhyp f  =  
-  let f = 
-    match f with 
-      | ConstRef f -> f 
+let invfun qhyp f  =
+  let f =
+    match f with
+      | ConstRef f -> f
       | _ -> raise (Util.UserError("",str "Not a function"))
   in
-  try 
-    let finfos = find_Function_infos f in 
-    let f_correct = mkConst(Option.get finfos.correctness_lemma) 
+  try
+    let finfos = find_Function_infos f in
+    let f_correct = mkConst(Option.get finfos.correctness_lemma)
     and kn = fst finfos.graph_ind
     in
-    Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f)  f_correct) qhyp 
-  with 
-    | Not_found ->  error "No graph found" 
+    Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f)  f_correct) qhyp
+  with
+    | Not_found ->  error "No graph found"
     | Option.IsNone  -> error "Cannot use equivalence with graph!"
 
 
-let invfun qhyp f g = 
-  match f with 
+let invfun qhyp f g =
+  match f with
     | Some f -> invfun qhyp f g
-    | None -> 
-	Tactics.try_intros_until 
-	  (fun hid g -> 
-	     let hyp_typ = pf_type_of g (mkVar hid)  in 
-	     match kind_of_term hyp_typ with 
-	       | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> 
+    | None ->
+	Tactics.try_intros_until
+	  (fun hid g ->
+	     let hyp_typ = pf_type_of g (mkVar hid)  in
+	     match kind_of_term hyp_typ with
+	       | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
 		   begin
-		     let f1,_ = decompose_app args.(1) in 
-		     try 
+		     let f1,_ = decompose_app args.(1) in
+		     try
 		       if not (isConst f1) then failwith "";
-		       let finfos = find_Function_infos (destConst f1) in 
-		       let f_correct = mkConst(Option.get finfos.correctness_lemma) 
+		       let finfos = find_Function_infos (destConst f1) in
+		       let f_correct = mkConst(Option.get finfos.correctness_lemma)
 		       and kn = fst finfos.graph_ind
 		       in
 		       functional_inversion kn hid f1 f_correct g
-		     with | Failure "" | Option.IsNone | Not_found -> 
-		       try 
-			 let f2,_ = decompose_app args.(2) in 
+		     with | Failure "" | Option.IsNone | Not_found ->
+		       try
+			 let f2,_ = decompose_app args.(2) in
 			 if not (isConst f2) then failwith "";
-			 let finfos = find_Function_infos (destConst f2) in 
-			 let f_correct = mkConst(Option.get finfos.correctness_lemma) 
+			 let finfos = find_Function_infos (destConst f2) in
+			 let f_correct = mkConst(Option.get finfos.correctness_lemma)
 			 and kn = fst finfos.graph_ind
 			 in
 			 functional_inversion kn hid  f2 f_correct g
 		       with
-			 | Failure "" -> 
+			 | Failure "" ->
 			     errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
-			 | Option.IsNone  ->  
-			     if do_observe () 
+			 | Option.IsNone  ->
+			     if do_observe ()
 			     then
 			       error "Cannot use equivalence with graph for any side of the equality"
 			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
-			 | Not_found -> 
-			     if do_observe () 
+			 | Not_found ->
+			     if do_observe ()
 			     then
-			       error "No graph found for any side of equality" 
+			       error "No graph found for any side of equality"
 			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
 		   end
 	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
diff --git a/contrib/funind/merge.ml b/plugins/funind/merge.ml
index 9bbd165d..f596e2d7 100644
--- a/contrib/funind/merge.ml
+++ b/plugins/funind/merge.ml
@@ -18,7 +18,7 @@ open Vernacexpr
 open Pp
 open Names
 open Term
-open Termops 
+open Termops
 open Declarations
 open Environ
 open Rawterm
@@ -32,19 +32,19 @@ let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
 
 (** Substitutions in constr *)
 let compare_constr_nosub t1 t2 =
-  if compare_constr (fun _ _ -> false) t1 t2 
+  if compare_constr (fun _ _ -> false) t1 t2
   then true
   else false
 
 let rec compare_constr' t1 t2 =
-  if compare_constr_nosub t1 t2 
+  if compare_constr_nosub t1 t2
   then true
   else (compare_constr (compare_constr') t1 t2)
 
 let rec substitterm prof t by_t in_u =
   if (compare_constr' (lift prof t) in_u)
   then (lift prof by_t)
-  else map_constr_with_binders succ 
+  else map_constr_with_binders succ
     (fun i -> substitterm i t by_t) prof in_u
 
 let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
@@ -59,25 +59,25 @@ let name_of_string str = Name (id_of_string str)
 let string_of_name nme = string_of_id (id_of_name nme)
 
 (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
-let isVarf f x = 
+let isVarf f x =
     match x with
-      | RVar (_,x) -> Pervasives.compare x f = 0 
+      | RVar (_,x) -> Pervasives.compare x f = 0
       | _ -> false
 
 (** [ident_global_exist id] returns true if identifier [id] is linked
     in global environment. *)
-let ident_global_exist id = 
-  try 
+let ident_global_exist id =
+  try
     let ans = CRef (Libnames.Ident (dummy_loc,id)) in
     let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
     true
-  with _ -> false 
+  with _ -> false
 
 (** [next_ident_fresh id] returns a fresh identifier (ie not linked in
     global env) with base [id]. *)
-let next_ident_fresh (id:identifier) = 
+let next_ident_fresh (id:identifier) =
     let res = ref id in
-    while ident_global_exist !res do res := Nameops.lift_ident !res done;
+    while ident_global_exist !res do res := Nameops.lift_subscript !res done;
     !res
 
 
@@ -89,37 +89,37 @@ let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c)
 let prconstrnl c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
 let prlistconstr lc = List.iter prconstr lc
 let prstr s = msg(str s)
-let prNamedConstr s c = 
+let prNamedConstr s c =
   begin
     msg(str "");
     msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
     msg(str "");
   end
-let prNamedRConstr s c = 
+let prNamedRConstr s c =
   begin
     msg(str "");
     msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
     msg(str "");
   end
 let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
-let prNamedLConstr s lc = 
+let prNamedLConstr s lc =
   begin
     prstr "[§§§ ";
     prstr s;
     prNamedLConstr_aux lc;
     prstr " §§§]\n";
   end
-let prNamedLDecl s lc = 
+let prNamedLDecl s lc =
   begin
     prstr s; prstr "\n";
     List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
     prstr "\n";
   end
-let prNamedRLDecl s lc = 
+let prNamedRLDecl s lc =
   begin
     prstr s; prstr "\n"; prstr "{§§ ";
-    List.iter 
-      (fun x -> 
+    List.iter
+      (fun x ->
         match x with
           | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp
           | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy
@@ -133,16 +133,16 @@ let showind (id:identifier) =
   let cstrid = Tacinterp.constr_of_id (Global.env()) id in
   let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
   let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
-  List.iter (fun (nm, optcstr, tp) -> 
+  List.iter (fun (nm, optcstr, tp) ->
     print_string (string_of_name nm^":");
-    prconstr tp; print_string "\n") 
+    prconstr tp; print_string "\n")
     ib1.mind_arity_ctxt;
   (match ib1.mind_arity with
     | Monomorphic x ->
         Printf.printf "arity :"; prconstr x.mind_user_arity
-    | Polymorphic x -> 
+    | Polymorphic x ->
         Printf.printf "arity : universe?");
-  Array.iteri 
+  Array.iteri
     (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
     ib1.mind_user_lc
 
@@ -151,11 +151,6 @@ let showind (id:identifier) =
 exception Found of int
 
 (* Array scanning *)
-let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = 
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    None
-  with Found i -> Some i
 
 let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
   try
@@ -163,10 +158,10 @@ let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
     Array.length arr (* all elt are positive *)
   with Found i -> i
 
-let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = 
-  let i = ref 0 in 
-  Array.fold_left 
-    (fun acc x -> 
+let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a =
+  let i = ref 0 in
+  Array.fold_left
+    (fun acc x ->
       let res = f !i acc x in i := !i + 1; res)
     acc arr
 
@@ -176,25 +171,25 @@ let list_chop_end i l =
   if size_prefix < 0 then failwith "list_chop_end"
   else list_chop size_prefix l
 
-let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = 
-  let i = ref 0 in 
-  List.fold_left 
-    (fun acc x -> 
+let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
+  let i = ref 0 in
+  List.fold_left
+    (fun acc x ->
       let res = f !i acc x in i := !i + 1; res)
     acc arr
 
-let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = 
-  let i = ref 0 in 
+let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list =
+  let i = ref 0 in
   List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
 
 
 (** Iteration module *)
-module For = 
+module For =
 struct
   let rec map i j (f: int -> 'a)  = if i>j then [] else f i :: (map (i+1) j f)
-  let rec foldup i j (f: 'a -> int -> 'a) acc = 
+  let rec foldup i j (f: 'a -> int -> 'a) acc =
     if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
-  let rec folddown i j (f: 'a -> int -> 'a) acc = 
+  let rec folddown i j (f: 'a -> int -> 'a) acc =
     if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
   let fold i j = if i<j then foldup i j else folddown i j
 end
@@ -231,7 +226,7 @@ let prlinked x =
     | Unlinked -> Printf.sprintf "Unlinked"
     | Funres -> Printf.sprintf "Funres"
 
-let linkmonad f lnkvar = 
+let linkmonad f lnkvar =
   match lnkvar with
     | Linked i -> Linked (f i)
     | Unlinked -> Unlinked
@@ -242,7 +237,7 @@ let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
 (* This map is used to deal with debruijn linked indices. *)
 module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
 
-let pr_links l = 
+let pr_links l =
   Printf.printf "links:\n";
   Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
   Printf.printf "_____________\n"
@@ -255,16 +250,16 @@ type 'a merged_arg =
     | Arg_linked of 'a
     | Arg_funres
 
-(** Information about graph merging of two inductives. 
+(** Information about graph merging of two inductives.
    All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *)
 
 type merge_infos =
     {
       ident:identifier; (** new inductive name *)
       mib1: mutual_inductive_body;
-      oib1: one_inductive_body; 
+      oib1: one_inductive_body;
       mib2: mutual_inductive_body;
-      oib2: one_inductive_body; 
+      oib2: one_inductive_body;
 
       (** Array of links of the first inductive (should be all stable) *)
       lnk1: int merged_arg array;
@@ -275,24 +270,24 @@ type merge_infos =
       (** rec params which remain rec param (ie not linked) *)
       recprms1: rel_declaration list;
       recprms2: rel_declaration list;
-      nrecprms1: int; 
+      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;      
-      notherprms1:int; 
+      otherprms1: rel_declaration list;
+      otherprms2: rel_declaration list;
+      notherprms1:int;
       notherprms2:int;
 
       (** args which remain args in merge *)
-      args1:rel_declaration list; 
+      args1:rel_declaration list;
       args2:rel_declaration list;
       nargs1:int;
       nargs2:int;
 
       (** functional result args *)
-      funresprms1: rel_declaration list; 
+      funresprms1: rel_declaration list;
       funresprms2: rel_declaration list;
       nfunresprms1:int;
       nfunresprms2:int;
@@ -301,7 +296,7 @@ type merge_infos =
 
 let pr_merginfo x =
   let i,s=
-    match x with 
+    match x with
       | Prm_linked i -> Some i,"Prm_linked"
       | Arg_linked i -> Some i,"Arg_linked"
       | Prm_stable i -> Some i,"Prm_stable"
@@ -317,7 +312,7 @@ let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
 (* ?? prm_linked?? *)
 let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false
 
-let is_stable x = 
+let is_stable x =
   match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false
 
 let isArg_funres x = match x with Arg_funres -> true | _ -> false
@@ -332,22 +327,22 @@ let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
     of int as several vars may be linked to the same var. *)
 let revlinked lnk =
   For.fold 0 (Array.length lnk - 1)
-    (fun acc k -> 
-      match lnk.(k) with 
-        | Unlinked | Funres -> acc 
-        | Linked i -> 
+    (fun acc k ->
+      match lnk.(k) with
+        | Unlinked | Funres -> acc
+        | Linked i ->
             let old = try Link.find i acc with Not_found -> [] in
             Link.add i (k::old) acc)
     Link.empty
 
-let array_switch arr i j = 
+let array_switch arr i j =
   let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
 
 let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
   let larr = Array.of_list l in
   let _ =
     Array.iteri
-      (fun j x -> 
+      (fun j x ->
         match x with
           | Prm_linked i -> array_switch larr i j
           | Arg_linked i -> array_switch larr i j
@@ -392,7 +387,7 @@ let build_raw_params prms_decl avoid =
 
 let ids_of_rawlist avoid rawl =
     List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl)
-  
+
 
 
 (** {1 Merging function graphs} *)
@@ -402,7 +397,7 @@ let ids_of_rawlist avoid rawl =
     remain uniform when linked by [lnk]. All parameters are
     considered, ie we take parameters of the first inductive body of
     [mib1] and [mib2].
-    
+
     Explanation: The two inductives have parameters, some of the first
     are recursively uniform, some of the last are functional result of
     the functional graph.
@@ -418,14 +413,14 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
   let linked_targets = revlinked lnk2 in
   let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
   let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
-  let is_targetted_by_non_recparam_lnk1 i = 
-    try 
-      let targets = Link.find i linked_targets in 
+  let is_targetted_by_non_recparam_lnk1 i =
+    try
+      let targets = Link.find i linked_targets in
       List.exists (fun x -> not (is_param_of_mib2 x)) targets
     with Not_found -> false in
-  let mlnk1 = 
+  let mlnk1 =
     Array.mapi
-      (fun i lkv -> 
+      (fun i lkv ->
         let isprm = is_param_of_mib1 i in
         let prmlost = is_targetted_by_non_recparam_lnk1 i in
         match isprm , prmlost, lnk1.(i) with
@@ -435,13 +430,13 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
           | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
           | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
       lnk1 in
-  let mlnk2 = 
+  let mlnk2 =
     Array.mapi
-      (fun i lkv -> 
+      (fun i lkv ->
         (* Is this correct if some param of ind2 is lost? *)
         let isprm = is_param_of_mib2 i in
         match isprm , lnk2.(i) with
-          | true , Linked j when not (is_param_of_mib1 j) -> 
+          | true , Linked j when not (is_param_of_mib1 j) ->
               Prm_arg j (* recparam becoming ordinary *)
           | true , Linked j -> Prm_linked j (*recparam linked to recparam*)
           | true , Unlinked -> Prm_stable i (* recparam remains recparam*)
@@ -456,9 +451,9 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
   (* count params remaining params *)
   let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
   let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
-  let bldprms arity_ctxt mlnk = 
+  let bldprms arity_ctxt mlnk =
     list_fold_lefti
-      (fun i (acc1,acc2,acc3,acc4) x -> 
+      (fun i (acc1,acc2,acc3,acc4) x ->
         prstr (pr_merginfo mlnk.(i));prstr "\n";
         match mlnk.(i) with
           | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4
@@ -467,19 +462,19 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
           | Arg_funres -> acc1 , acc2 , acc3, x::acc4
           | _ -> acc1 , acc2 , acc3, acc4)
       ([],[],[],[]) arity_ctxt in
-(*  let arity_ctxt2 = 
-    build_raw_params oib2.mind_arity_ctxt 
+(*  let arity_ctxt2 =
+    build_raw_params oib2.mind_arity_ctxt
       (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*)
   let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
   let _ = prstr "\n\n\n" in
   let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
   let _ = prstr "\notherprms1:\n" in
-  let _ = 
-    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") 
+  let _ =
+    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
     otherprms1 in
   let _ = prstr "\notherprms2:\n" in
-  let _ = 
-    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") 
+  let _ =
+    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
     otherprms2 in
   {
     ident=id;
@@ -514,38 +509,38 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
 
 exception NoMerge
 
-let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = 
+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
-    | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> 
+    | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
         let _ = prstr "\nICI1!\n";Pp.flush_all() in
         let args = filter_shift_stable lnk (arr1 @ arr2) in
         RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args)
     | RApp(_,f1, arr1), RApp(_,f2,arr2)  -> raise NoMerge
-    | RLetIn(_,nme,bdy,trm) , _ -> 
-        let _ = prstr "\nICI2!\n";Pp.flush_all() in 
+    | RLetIn(_,nme,bdy,trm) , _ ->
+        let _ = prstr "\nICI2!\n";Pp.flush_all() in
         let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
         RLetIn(dummy_loc,nme,bdy,newtrm)
-    | _, RLetIn(_,nme,bdy,trm) -> 
-        let _ = prstr "\nICI3!\n";Pp.flush_all() in 
+    | _, RLetIn(_,nme,bdy,trm) ->
+        let _ = prstr "\nICI3!\n";Pp.flush_all() in
         let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
         RLetIn(dummy_loc,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
            raise NoMerge
 
-let rec merge_app_unsafe c1 c2 shift filter_shift_stable = 
+let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
   let lnk = Array.append shift.lnk1 shift.lnk2 in
   match c1 , c2 with
-    | RApp(_,f1, arr1), RApp(_,f2,arr2) -> 
+    | RApp(_,f1, arr1), RApp(_,f2,arr2) ->
         let args = filter_shift_stable lnk (arr1 @ arr2) in
         RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
           (* FIXME: what if the function appears in the body of the let? *)
-    | RLetIn(_,nme,bdy,trm) , _ -> 
-        let _ = prstr "\nICI2 '!\n";Pp.flush_all() in 
+    | RLetIn(_,nme,bdy,trm) , _ ->
+        let _ = prstr "\nICI2 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
         RLetIn(dummy_loc,nme,bdy,newtrm)
-    | _, RLetIn(_,nme,bdy,trm) -> 
-        let _ = prstr "\nICI3 '!\n";Pp.flush_all() in 
+    | _, RLetIn(_,nme,bdy,trm) ->
+        let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
         RLetIn(dummy_loc,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
@@ -555,33 +550,33 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
 (* Heuristic when merging two lists of hypothesis: merge every rec
    calls of branch 1 with all rec calls of branch 2. *)
 (* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
-let rec merge_rec_hyps shift accrec 
-    (ltyp:(Names.name * rawconstr option * rawconstr option) list) 
+let rec merge_rec_hyps shift accrec
+    (ltyp:(Names.name * rawconstr option * rawconstr option) list)
     filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list =
-  let mergeonehyp t reldecl = 
+  let mergeonehyp t reldecl =
     match reldecl with
-      | (nme,x,Some (RApp(_,i,args) as ind)) 
+      | (nme,x,Some (RApp(_,i,args) as ind))
         -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable)
       | (nme,Some _,None) -> error "letins with recursive calls not treated yet"
-      | (nme,None,Some _) -> assert false 
+      | (nme,None,Some _) -> assert false
       | (nme,None,None) | (nme,Some _,Some _) -> assert false in
   match ltyp with
     | [] -> []
-    | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> 
+    | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f ->
         let rechyps = List.map (mergeonehyp t) accrec in
         rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable
     | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
 
 
-let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = 
+let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift =
   List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
 
 
-let find_app (nme:identifier) ltyp = 
+let find_app (nme:identifier) ltyp =
   try
     ignore
       (List.map
-          (fun x -> 
+          (fun x ->
             match x with
               | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
               | _ -> ())
@@ -589,17 +584,17 @@ let find_app (nme:identifier) ltyp =
     false
   with Found _ -> true
 
-let prnt_prod_or_letin nm letbdy typ = 
+let prnt_prod_or_letin nm letbdy typ =
   match letbdy , typ with
     | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy
     | None , Some tp -> prNamedRConstr (string_of_name nm) tp
     | _ , _ -> assert false
 
-        
-let rec merge_types shift accrec1 
+
+let rec merge_types shift accrec1
     (ltyp1:(name * rawconstr option * rawconstr option) list)
     (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2
-    : (name * rawconstr option * rawconstr option) list * rawconstr = 
+    : (name * rawconstr option * rawconstr option) list * rawconstr =
   let _ = prstr "MERGE_TYPES\n" in
   let _ = prstr "ltyp 1 : " in
   let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
@@ -608,20 +603,20 @@ let rec merge_types shift accrec1
   let _ = prstr "\n" in
   let res =
     match ltyp1 with
-      | [] -> 
+      | [] ->
           let isrec1 = (accrec1<>[]) in
           let isrec2 = find_app ind2name ltyp2 in
           let rechyps =
-            if isrec1 && isrec2 
+            if isrec1 && isrec2
             then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *)
-              merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 
+              merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
                 filter_shift_stable_right
               @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2]
                 filter_shift_stable
-            else if isrec1 
+            else if isrec1
                 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
-            then  
-              merge_rec_hyps shift accrec1 
+            then
+              merge_rec_hyps shift accrec1
                 (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable
             else if isrec2
             then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
@@ -634,22 +629,22 @@ let rec merge_types shift accrec1
           let _ = prstr " with " in
           let _ = prNamedRConstr "concl2" concl2 in
           let _ = prstr "\n" in
-          let concl = 
+          let concl =
             merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
           let _ = prstr "FIN " in
           let _ = prNamedRConstr "concl" concl in
           let _ = prstr "\n" in
 
           rechyps , concl
-      | (nme,None, Some t1)as e ::lt1 -> 
+      | (nme,None, Some t1)as e ::lt1 ->
           (match t1 with
-            | RApp(_,f,carr) when isVarf ind1name f -> 
-                merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 
-            | _ -> 
+            | RApp(_,f,carr) when isVarf ind1name f ->
+                merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2
+            | _ ->
                 let recres, recconcl2 =
                   merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
-                ((nme,None,Some t1) :: recres) , recconcl2)            
-      | (nme,Some bd, None) ::lt1 -> 
+                ((nme,None,Some t1) :: recres) , recconcl2)
+      | (nme,Some bd, None) ::lt1 ->
           (* FIXME: what if ind1name appears in bd? *)
           let recres, recconcl2 =
             merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
@@ -666,10 +661,10 @@ let rec merge_types shift accrec1
 let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
     (lnk:int merged_arg array) =
   array_fold_lefti
-    (fun i acc e -> 
+    (fun i acc e ->
       if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
-      else 
-        match e with 
+      else
+        match e with
           | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
           | _ -> acc)
     Idmap.empty lnk
@@ -696,10 +691,10 @@ let build_link_map allargs1 allargs2 lnk =
 
     forall recparams1 (recparams2 without linked params),
      forall ordparams1 (ordparams2 without linked params),
-      H1a' -> H2a' -> ...  -> H2a' -> H2b'(shifted) -> ... 
+      H1a' -> H2a' -> ...  -> H2a' -> H2b'(shifted) -> ...
         -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
 
-    where Hix' have been adapted, ie: 
+    where Hix' have been adapted, ie:
       - linked vars have been changed,
       - rec calls to I1 and I2 have been replaced by rec calls to
         newI. More precisely calls to I1 and I2 have been merge by an
@@ -715,26 +710,26 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
   (* FIXME: les noms des parametres corerspondent en principe au
      parametres du niveau mib, mais il faudrait s'en assurer *)
   (* shift.nfunresprmsx last args are functional result *)
-  let nargs1 = 
+  let nargs1 =
     shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
   let nargs2 =
     shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
   let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in
-  let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in  
+  let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in
   (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *)
   let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in
   let rest2 = change_vars linked_map rest2 in
   let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in
   let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in
-  let ltyp,concl2 = 
+  let ltyp,concl2 =
     merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in
   let _ = prNamedRLDecl "ltyp result:" ltyp in
   let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in
-  let revargs1 = 
+  let revargs1 =
     list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
   let _ = prNamedRLDecl "ltyp allargs1" allargs1 in
   let _ = prNamedRLDecl "ltyp revargs1" revargs1 in
-  let revargs2 = 
+  let revargs2 =
     list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
   let _ = prNamedRLDecl "ltyp allargs2" allargs2 in
   let _ = prNamedRLDecl "ltyp revargs2" revargs2 in
@@ -746,7 +741,7 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
 (** constructor numbering *)
 let fresh_cstror_suffix , cstror_suffix_init =
   let cstror_num = ref 0 in
-  (fun () -> 
+  (fun () ->
     let res = string_of_int !cstror_num in
     cstror_num := !cstror_num + 1;
     res) ,
@@ -755,7 +750,7 @@ let fresh_cstror_suffix , cstror_suffix_init =
 (** [merge_constructor_id id1 id2 shift] returns the identifier of the
     new constructor from the id of the two merged constructor and
     the merging info. *)
-let merge_constructor_id id1 id2 shift:identifier = 
+let merge_constructor_id id1 id2 shift:identifier =
   let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
   next_ident_fresh (id_of_string id)
 
@@ -765,43 +760,43 @@ let merge_constructor_id id1 id2 shift:identifier =
     constructor [(name*type)]. These are translated to rawterms
     first, each of them having distinct var names. *)
 let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
-    (typcstr1:(identifier * rawconstr) list) 
+    (typcstr1:(identifier * rawconstr) list)
     (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
-  List.flatten 
+  List.flatten
     (List.map
-        (fun (id1,rawtyp1) -> 
+        (fun (id1,rawtyp1) ->
           List.map
-            (fun (id2,rawtyp2) -> 
+            (fun (id2,rawtyp2) ->
               let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
               let newcstror_id = merge_constructor_id id1 id2 shift in
               let _ = prstr "\n**************\n" in
               newcstror_id , typ)
             typcstr2)
         typcstr1)
-    
+
 (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
     inductive bodies [oib1] and [oib2], linking with [lnk], params
     info in [shift], avoiding identifiers in [avoid]. *)
 let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
     (oib2:one_inductive_body) =
   (* building rawconstr type of constructors *)
-  let mkrawcor nme avoid typ = 
+  let mkrawcor nme avoid typ =
     (* first replace rel 1 by a varname *)
     let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
     Detyping.detype false (Idset.elements avoid) [] substindtyp in
-  let lcstr1: rawconstr list = 
+  let lcstr1: rawconstr list =
     Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
   (* add  to avoid all indentifiers of lcstr1 *)
   let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in
-  let lcstr2 = 
+  let lcstr2 =
     Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
   let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
 
-  let params1 = 
-    try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) 
+  let params1 =
+    try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
     with _ -> [] in
-  let params2 = 
-    try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) 
+  let params2 =
+    try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
     with _ -> [] in
 
   let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
@@ -819,17 +814,17 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
 let rec merge_mutual_inductive_body
     (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
   (* Mutual not treated, we take first ind body of each. *)
-  merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) 
+  merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
+
 
-  
 let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
   Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x
 
-let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = 
+let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
   let params = prms2 @ prms1 in
   let resparams =
     List.fold_left
-      (fun acc (nme,tp) -> 
+      (fun acc (nme,tp) ->
         let _ = prstr "param :" in
         let _ = prNamedRConstr (string_of_name nme) tp in
         let _ = prstr "  ;  " in
@@ -837,18 +832,18 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
         LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc)
       [] params in
   let concl = Constrextern.extern_constr false (Global.env()) concl in
-  let arity,_ = 
-    List.fold_left 
-      (fun (acc,env) (nm,_,c) -> 
+  let arity,_ =
+    List.fold_left
+      (fun (acc,env) (nm,_,c) ->
         let typ = Constrextern.extern_constr false env c in
         let newenv = Environ.push_rel (nm,None,c) env in
         CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
       (concl,Global.env())
-      (shift.funresprms2 @ shift.funresprms1 
-        @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in  
+      (shift.funresprms2 @ shift.funresprms1
+        @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
   resparams,arity
 
-  
+
 
 (** [rawterm_list_to_inductive_expr ident rawlist] returns the
     induct_expr corresponding to the the list of constructor types
@@ -859,17 +854,17 @@ let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
   let lident = dummy_loc, shift.ident in
   let bindlist , cstr_expr = (* params , arities *)
     merge_rec_params_and_arity prms1 prms2 shift mkSet in
-  let lcstor_expr : (bool * (lident * constr_expr)) list  = 
+  let lcstor_expr : (bool * (lident * constr_expr)) list  =
     List.map (* zeta_normalize t ? *)
       (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t))
-      rawlist in  
+      rawlist in
   lident , bindlist , Some cstr_expr , lcstor_expr
 
 
 
 let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
   match rdecl with
-    | (nme,None,t) -> 
+    | (nme,None,t) ->
         let traw = Detyping.detype false [] [] t in
         RProd (dummy_loc,nme,Explicit,traw,t2)
     | (_,Some _,_) -> assert false
@@ -879,7 +874,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
 
 let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
   match rdecl with
-    | (nme,None,t) -> 
+    | (nme,None,t) ->
         let traw = Detyping.detype false [] [] t in
         RProd (dummy_loc,nme,Explicit,traw,t2)
     | (_,Some _,_) -> assert false
@@ -888,7 +883,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
 (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
     variables specified in [lnk]. Graphs are not supposed to be mutual
     inductives for the moment. *)
-let merge_inductive (ind1: inductive) (ind2: inductive) 
+let merge_inductive (ind1: inductive) (ind2: inductive)
     (lnk1: linked_var array) (lnk2: linked_var array) id =
   let env = Global.env() in
   let mib1,_ = Inductive.lookup_mind_specif env ind1 in
@@ -898,18 +893,21 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
   let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
   let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
   let _ = prstr "\nrawlist : " in
-  let _ = 
+  let _ =
     List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in
   let _ = prstr "\nend rawlist\n" in
 (* FIX: retransformer en constr ici
-   let shift_prm = 
+   let shift_prm =
     { shift_prm with
       recprms1=prms1;
-      recprms1=prms1;    
+      recprms1=prms1;
     } in *)
   let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
   (* Declare inductive *)
-  Command.build_mutual [(indexpr,None)] true (* means: not coinductive *)
+  let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in
+  let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in
+  (* Declare the mutual inductive block with its associated schemes *)
+  ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls)
 
 
 (* Find infos on identifier id. *)
@@ -927,28 +925,28 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
     [ind1] and [ind2]. identifiers occuring in both arrays [args1] and
     [args2] are considered linked (i.e. are the same variable) in the
     new graph.
-    
+
     Warning: For the moment, repetitions of an id in [args1] or
     [args2] are not supported. *)
-let merge (id1:identifier) (id2:identifier) (args1:identifier array) 
+let merge (id1:identifier) (id2:identifier) (args1:identifier array)
     (args2:identifier array) id : unit =
   let finfo1 = find_Function_infos_safe id1 in
   let finfo2 = find_Function_infos_safe id2 in
   (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
   (* We add one arg (functional arg of the graph) *)
   let lnk1 = Array.make (Array.length args1 + 1) Unlinked in
-  let lnk2' = (* args2 may be linked to args1 members. FIXME: same 
+  let lnk2' = (* args2 may be linked to args1 members. FIXME: same
                  as above: vars may be linked inside args2?? *)
     Array.mapi
-      (fun i c -> 
-        match array_find args1 (fun i x -> x=c) with
+      (fun i c ->
+        match array_find_i (fun i x -> x=c) args1 with
           | Some j -> Linked j
-          | None -> Unlinked) 
+          | None -> Unlinked)
       args2 in
   (* We add one arg (functional arg of the graph) *)
   let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in
   (* setting functional results *)
-  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in 
+  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in
   let _ = lnk2.(Array.length lnk2 - 1) <- Funres in
   merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id
 
@@ -968,12 +966,12 @@ let remove_last_n_arg n c =
 
 (* [funify_branches relinfo nfuns branch] returns the branch [branch]
    of the relinfo [relinfo] modified to fit in a functional principle.
-   Things to do: 
+   Things to do:
     - remove indargs from rel applications
     - replace *variables only* corresponding to function (recursive)
       results by the actual function application. *)
-let funify_branches relinfo nfuns branch = 
-  let mut_induct, induct = 
+let funify_branches relinfo nfuns branch =
+  let mut_induct, induct =
     match relinfo.indref with
       | None -> assert false
       | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind
@@ -987,13 +985,13 @@ let funify_branches relinfo nfuns branch =
     match kind_of_term c with
       | Ind((u,i)) | Construct((u,_),i) -> i
       | _ -> assert false in
-  let _is_pred c shift = 
+  let _is_pred c shift =
     match kind_of_term c with
       | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
       | _ -> false in
   (* FIXME: *)
   (Anonymous,Some mkProp,mkProp)
-  
+
 
 let relprinctype_to_funprinctype relprinctype nfuns =
   let relinfo = compute_elim_sig relprinctype in
@@ -1010,7 +1008,7 @@ let relprinctype_to_funprinctype relprinctype nfuns =
     args = remove_n_fst_list nfuns relinfo_noindarg.args;
     concl = popn nfuns relinfo_noindarg.concl
   } in
-  let new_branches = 
+  let new_branches =
     List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in
   let relinfo_branches = { relinfo_argsok with branches = new_branches } in
   relinfo_branches
@@ -1026,9 +1024,9 @@ let relprinctype_to_funprinctype relprinctype nfuns =
     url = "citeseer.ist.psu.edu/bundy93rippling.html" }
 
  *)
-(* 
+(*
 *** Local Variables: ***
-*** compile-command: "make -C ../.. contrib/funind/merge.cmo" ***
+*** compile-command: "make -C ../.. plugins/funind/merge.cmo" ***
 *** indent-tabs-mode: nil ***
 *** End: ***
 *)
diff --git a/contrib/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml
index 09b7fbdf..3c3a36f0 100644
--- a/contrib/funind/rawterm_to_relation.ml
+++ b/plugins/funind/rawterm_to_relation.ml
@@ -1,6 +1,6 @@
 open Printer
 open Pp
-open Names 
+open Names
 open Term
 open Rawterm
 open Libnames
@@ -8,77 +8,76 @@ open Indfun_common
 open Util
 open Rawtermops
 
-let observe strm =  
+let observe strm =
   if do_observe ()
-  then Pp.msgnl strm 
+  then Pp.msgnl strm
   else ()
-let observennl strm =  
+let observennl strm =
   if do_observe ()
-  then Pp.msg strm 
+  then Pp.msg strm
   else ()
 
 
 type binder_type =
-  | Lambda of name 
-  | Prod of name 
+  | Lambda of name
+  | Prod of name
   | LetIn of name
 
 type raw_context = (binder_type*rawconstr) list
 
-
-(* 
-   compose_raw_context [(bt_1,n_1,t_1);......] rt returns 
-   b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the 
+(*
+   compose_raw_context [(bt_1,n_1,t_1);......] rt returns
+   b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the
    binders corresponding to the bt_i's
 *)
-let compose_raw_context = 
+let compose_raw_context =
   let compose_binder  (bt,t) acc =
-    match bt with 
+    match bt with
       | Lambda n -> mkRLambda(n,t,acc)
       | Prod n -> mkRProd(n,t,acc)
       | LetIn n -> mkRLetIn(n,t,acc)
   in
   List.fold_right compose_binder
-  
 
-(* 
+
+(*
    The main part deals with building a list of raw constructor expressions
-   from the rhs of a fixpoint equation. 
+   from the rhs of a fixpoint equation.
 *)
 
-type 'a build_entry_pre_return = 
+type 'a build_entry_pre_return =
     {
       context : raw_context;  (* the binding context of the result *)
       value : 'a; (* The value *)
     }
 
-type 'a build_entry_return = 
+type 'a build_entry_return =
     {
-      result : 'a build_entry_pre_return list; 
+      result : 'a build_entry_pre_return list;
       to_avoid : identifier list
     }
 
 (*
-  [combine_results combine_fun res1 res2] combine two results [res1] and [res2] 
+  [combine_results combine_fun res1 res2] combine two results [res1] and [res2]
   w.r.t. [combine_fun].
 
-  Informally, both [res1] and [res2] are lists of "constructors"  [res1_1;...] 
-  and [res2_1,....] and we need to produce 
+  Informally, both [res1] and [res2] are lists of "constructors"  [res1_1;...]
+  and [res2_1,....] and we need to produce
   [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........]
 *)
 
-let combine_results 
-    (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 
+let combine_results
+    (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return ->
       'c build_entry_pre_return
-    )  
-    (res1: 'a build_entry_return) 
-    (res2 : 'b build_entry_return) 
-    : 'c build_entry_return 
-    = 
-  let pre_result =     List.map 
+    )
+    (res1: 'a build_entry_return)
+    (res2 : 'b build_entry_return)
+    : 'c build_entry_return
+    =
+  let pre_result =     List.map
     ( fun res1 ->  (* for each result in arg_res *)
-	  List.map (* we add it in each args_res *) 
-	    (fun res2 -> 
+	  List.map (* we add it in each args_res *)
+	    (fun res2 ->
 	       combine_fun res1 res2
 	    )
 	    res2.result
@@ -86,107 +85,107 @@ let combine_results
       res1.result
   in (* and then we flatten the map *)
   {
-    result = List.concat pre_result; 
+    result = List.concat pre_result;
     to_avoid = list_union res1.to_avoid res2.to_avoid
   }
-    
 
-(* 
-   The combination function for an argument with a list of argument 
+
+(*
+   The combination function for an argument with a list of argument
 *)
 
-let combine_args arg args = 
+let combine_args arg args =
   {
-    context = arg.context@args.context; 
-    (* Note that the binding context of [arg] MUST be placed before the one of 
-       [args] in order to preserve possible type dependencies 
+    context = arg.context@args.context;
+    (* Note that the binding context of [arg] MUST be placed before the one of
+       [args] in order to preserve possible type dependencies
     *)
     value = arg.value::args.value;
   }
 
 
-let ids_of_binder =  function 
+let ids_of_binder =  function
   | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
   | LetIn (Name id)  | Prod (Name id) | Lambda (Name id) -> [id]
 
-let rec change_vars_in_binder mapping = function 
+let rec change_vars_in_binder mapping = function
     [] -> []
   | (bt,t)::l ->
-      let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in 
+      let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in
       (bt,change_vars mapping t)::
 	(if idmap_is_empty new_mapping
-	 then l 
+	 then l
 	 else change_vars_in_binder new_mapping l
 	)
 
 let rec replace_var_by_term_in_binder x_id term = function
   | [] -> []
-  | (bt,t)::l -> 
+  | (bt,t)::l ->
       (bt,replace_var_by_term x_id term t)::
-	if List.mem x_id (ids_of_binder bt) 
+	if List.mem x_id (ids_of_binder bt)
 	then l
 	else replace_var_by_term_in_binder x_id term l
 
 let add_bt_names bt = List.append (ids_of_binder bt)
 
-let apply_args ctxt body args = 
-  let need_convert_id avoid id = 
-    List.exists (is_free_in id) args || List.mem id avoid 
-  in 
-  let need_convert avoid  bt =  
+let apply_args ctxt body args =
+  let need_convert_id avoid id =
+    List.exists (is_free_in id) args || List.mem id avoid
+  in
+  let need_convert avoid  bt =
     List.exists (need_convert_id avoid) (ids_of_binder bt)
   in
-  let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = 
-    match na with 
-       | Name id when List.mem id avoid -> 
-	   let new_id = Nameops.next_ident_away id avoid in 
+  let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) =
+    match na with
+       | Name id when List.mem id avoid ->
+	   let new_id = Namegen.next_ident_away id avoid in
 	   Name new_id,Idmap.add id new_id mapping,new_id::avoid
        | _ -> na,mapping,avoid
   in
-  let next_bt_away bt (avoid:identifier list) = 
-    match bt with 
-      | LetIn na -> 
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
+  let next_bt_away bt (avoid:identifier list) =
+    match bt with
+      | LetIn na ->
+	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
 	  LetIn new_na,mapping,new_avoid
-      | Prod na -> 
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
+      | Prod na ->
+	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
 	  Prod new_na,mapping,new_avoid
-      | Lambda na -> 
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
+      | Lambda na ->
+	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
 	  Lambda new_na,mapping,new_avoid
   in
-  let rec do_apply avoid ctxt body args = 
-    match ctxt,args with  
+  let rec do_apply avoid ctxt body args =
+    match ctxt,args with
       | _,[] -> (* No more args *)
 	  (ctxt,body)
       | [],_ -> (* no more fun *)
 	  let f,args' = raw_decompose_app body in
 	  (ctxt,mkRApp(f,args'@args))
-      | (Lambda Anonymous,t)::ctxt',arg::args' -> 
+      | (Lambda Anonymous,t)::ctxt',arg::args' ->
 	  do_apply avoid ctxt' body args'
-      | (Lambda (Name id),t)::ctxt',arg::args' -> 
-	  let new_avoid,new_ctxt',new_body,new_id = 
-	    if need_convert_id avoid id 
-	    then 
-	      let new_avoid =  id::avoid in 
-	      let new_id = Nameops.next_ident_away id new_avoid in 
-	      let new_avoid' = new_id :: new_avoid in 
-	      let mapping = Idmap.add id new_id Idmap.empty in 
-	      let new_ctxt' = change_vars_in_binder mapping ctxt' in 
-	      let new_body = change_vars mapping body in 
+      | (Lambda (Name id),t)::ctxt',arg::args' ->
+	  let new_avoid,new_ctxt',new_body,new_id =
+	    if need_convert_id avoid id
+	    then
+	      let new_avoid =  id::avoid in
+	      let new_id = Namegen.next_ident_away id new_avoid in
+	      let new_avoid' = new_id :: new_avoid in
+	      let mapping = Idmap.add id new_id Idmap.empty in
+	      let new_ctxt' = change_vars_in_binder mapping ctxt' in
+	      let new_body = change_vars mapping body in
 	      new_avoid',new_ctxt',new_body,new_id
-	    else 
-	      id::avoid,ctxt',body,id 
+	    else
+	      id::avoid,ctxt',body,id
 	  in
 	  let new_body = replace_var_by_term new_id arg new_body in
 	  let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in
 	  do_apply avoid new_ctxt' new_body args'
-      | (bt,t)::ctxt',_ -> 
-	  let new_avoid,new_ctxt',new_body,new_bt = 
-	    let new_avoid = add_bt_names bt avoid in 
-	    if need_convert avoid bt 
-	    then 
-	      let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in 
+      | (bt,t)::ctxt',_ ->
+	  let new_avoid,new_ctxt',new_body,new_bt =
+	    let new_avoid = add_bt_names bt avoid in
+	    if need_convert avoid bt
+	    then
+	      let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in
 	      (
 		new_avoid,
 		change_vars_in_binder mapping ctxt',
@@ -195,93 +194,93 @@ let apply_args ctxt body args =
 	     )
 	    else new_avoid,ctxt',body,bt
 	  in
-	  let new_ctxt',new_body = 
-	    do_apply new_avoid new_ctxt' new_body args 
+	  let new_ctxt',new_body =
+	    do_apply new_avoid new_ctxt' new_body args
 	  in
 	  (new_bt,t)::new_ctxt',new_body
-  in 
+  in
   do_apply []  ctxt body args
 
 
-let combine_app f args = 
-  let new_ctxt,new_value = apply_args f.context f.value args.value in 
-  { 
-    (* Note that the binding context of [args] MUST be placed before the one of 
-       the applied value in order to preserve possible type dependencies 
+let combine_app f args =
+  let new_ctxt,new_value = apply_args f.context f.value args.value in
+  {
+    (* Note that the binding context of [args] MUST be placed before the one of
+       the applied value in order to preserve possible type dependencies
     *)
       context = args.context@new_ctxt;
       value = new_value;
   }
 
-let combine_lam n t b = 
+let combine_lam n t b =
   {
-    context = []; 
-    value = mkRLambda(n, compose_raw_context t.context t.value, 
+    context = [];
+    value = mkRLambda(n, compose_raw_context t.context t.value,
 		      compose_raw_context b.context b.value )
   }
 
 
 
-let combine_prod n t b = 
+let combine_prod n t b =
   { context = t.context@((Prod n,t.value)::b.context); value = b.value}
 
-let combine_letin n t b = 
+let combine_letin n t b =
   { context = t.context@((LetIn n,t.value)::b.context); value = b.value}
 
 
-let mk_result ctxt value avoid = 
-  { 
-    result = 
+let mk_result ctxt value avoid =
+  {
+    result =
       [{context = ctxt;
 	value = value}]
 	;
     to_avoid = avoid
   }
 (*************************************************
-  Some functions to deal with overlapping patterns 
+  Some functions to deal with overlapping patterns
 **************************************************)
 
-let coq_True_ref = 
+let coq_True_ref =
   lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "True")
 
-let coq_False_ref = 
+let coq_False_ref =
   lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "False")
 
 (*
   [make_discr_match_el \[e1,...en\]] builds match e1,...,en with
   (the list of expresions on which we will do the matching)
- *) 
-let make_discr_match_el  = 
+ *)
+let make_discr_match_el  =
   List.map (fun e -> (e,(Anonymous,None)))
 
 (*
-  [make_discr_match_brl i \[pat_1,...,pat_n\]]  constructs a discrimination pattern matching on the ith expression. 
-  that is. 
+  [make_discr_match_brl i \[pat_1,...,pat_n\]]  constructs a discrimination pattern matching on the ith expression.
+  that is.
   match ?????? with \\
   | pat_1 => False  \\
   | pat_{i-1} => False \\
   | pat_i => True \\
   | pat_{i+1} => False \\
-  \vdots 
+  \vdots
   | pat_n => False
   end
 *)
-let make_discr_match_brl i = 
-  list_map_i 
-    (fun j (_,idl,patl,_) -> 
+let make_discr_match_brl i =
+  list_map_i
+    (fun j (_,idl,patl,_) ->
        if j=i
        then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref))
        else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
     )
-    0 
-(* 
-   [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff 
-   brl_{i} is the first branch matched by [el] 
+    0
+(*
+   [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff
+   brl_{i} is the first branch matched by [el]
 
    Used when we want to simulate the coq pattern matching algorithm
 *)
-let make_discr_match brl = 
-  fun el i -> 
+let make_discr_match brl =
+  fun el i ->
   mkRCases(None,
 	   make_discr_match_el el,
 	   make_discr_match_brl i brl)
@@ -292,32 +291,32 @@ let pr_name = function
 
 (**********************************************************************)
 (*  functions used to build case expression from lettuple and if ones *)
-(**********************************************************************)		
+(**********************************************************************)
 
-(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)	  
-let build_constructors_of_type ind' argl = 
+(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)
+let build_constructors_of_type ind' argl =
   let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in
   let npar = mib.Declarations.mind_nparams in
   Array.mapi (fun i _ ->
-		let construct = ind',i+1 in 
-		let constructref = ConstructRef(construct) in 
+		let construct = ind',i+1 in
+		let constructref = ConstructRef(construct) in
 		let _implicit_positions_of_cst =
 		  Impargs.implicits_of_global constructref
 		in
-		let cst_narg = 
+		let cst_narg =
 		  Inductiveops.mis_constructor_nargs_env
 		    (Global.env ())
 		    construct
-		in 
-		let argl = 
-		  if argl = [] 
+		in
+		let argl =
+		  if argl = []
 		  then
- 		    Array.to_list 
+ 		    Array.to_list
 		      (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
 		      )
 		  else argl
 		in
-		let pat_as_term = 
+		let pat_as_term =
 		  mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
 		in
 		cases_pattern_of_rawconstr Anonymous pat_as_term
@@ -325,36 +324,36 @@ let build_constructors_of_type ind' argl =
     ind.Declarations.mind_consnames
 
 (* [find_type_of] very naive attempts to discover the type of an if or a letin *)
-let rec find_type_of nb b = 
-  let f,_ = raw_decompose_app b in 
-  match f with 
-    | RRef(_,ref) -> 
-	begin 
-	  let ind_type  = 
-	    match ref with 
-	      | VarRef _ | ConstRef _ -> 
-		  let constr_of_ref = constr_of_global ref in  
-		  let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in 
-		  let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in 
-		  let ret_type,_ = decompose_app ret_type in 
-		  if not (isInd ret_type) then 
+let rec find_type_of nb b =
+  let f,_ = raw_decompose_app b in
+  match f with
+    | RRef(_,ref) ->
+	begin
+	  let ind_type  =
+	    match ref with
+	      | VarRef _ | ConstRef _ ->
+		  let constr_of_ref = constr_of_global ref in
+		  let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in
+		  let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in
+		  let ret_type,_ = decompose_app ret_type in
+		  if not (isInd ret_type) then
 		    begin
 (* 		      Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
 		      raise (Invalid_argument "not an inductive")
 		    end;
 		  destInd ret_type
 	      | IndRef ind -> ind
-	      | ConstructRef c -> fst c 
+	      | ConstructRef c -> fst c
 	  in
-	  let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in 
+	  let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in
 	  if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
 	  then raise (Invalid_argument "find_type_of : not a valid inductive");
-	  ind_type	   
+	  ind_type
 	end
-    | RCast(_,b,_) -> find_type_of nb b 
+    | RCast(_,b,_) -> find_type_of nb b
     | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
     | _ -> raise (Invalid_argument "not a ref")
-    
+
 
 
 
@@ -364,32 +363,32 @@ let rec find_type_of nb b =
 
 
 
-let raw_push_named (na,raw_value,raw_typ) env = 
-  match na with 
-    | Anonymous -> env 
-    | Name id -> 
-	let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in 
-	let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in 
+let raw_push_named (na,raw_value,raw_typ) env =
+  match na with
+    | Anonymous -> env
+    | Name id ->
+	let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in
+	let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
 	Environ.push_named (id,value,typ) env
 
 
-let add_pat_variables pat typ env : Environ.env = 
-  let rec add_pat_variables env pat typ  : Environ.env = 
+let add_pat_variables pat typ env : Environ.env =
+  let rec add_pat_variables env pat typ  : Environ.env =
     observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
 
-    match pat with 
-      | PatVar(_,na) -> Environ.push_rel (na,None,typ) env 
-      | PatCstr(_,c,patl,na) -> 
-	  let Inductiveops.IndType(indf,indargs) = 
+    match pat with
+      | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
+      | PatCstr(_,c,patl,na) ->
+	  let Inductiveops.IndType(indf,indargs) =
 	    try Inductiveops.find_rectype env Evd.empty typ
-	    with Not_found -> assert false 
+	    with Not_found -> assert false
 	  in
-	  let constructors = Inductiveops.get_constructors env indf in 
-	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in 
-	  let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in 
-	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) 
+	  let constructors = Inductiveops.get_constructors env indf in
+	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
+	  let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
   in
-  let new_env = add_pat_variables  env pat typ in 
+  let new_env = add_pat_variables  env pat typ in
   let res =
     fst (
       Sign.fold_rel_context
@@ -427,15 +426,15 @@ let rec pattern_to_term_and_type env typ  = function
 	  (Global.env ())
 	  constr
       in
-      let Inductiveops.IndType(indf,indargs) = 
+      let Inductiveops.IndType(indf,indargs) =
 	try Inductiveops.find_rectype env Evd.empty typ
-	with Not_found -> assert false 
+	with Not_found -> assert false
       in
-      let constructors = Inductiveops.get_constructors env indf in 
-      let constructor  = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in 
-      let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in 
-      let _,cstl = Inductiveops.dest_ind_family indf in 
-      let csta = Array.of_list cstl in 
+      let constructors = Inductiveops.get_constructors env indf in
+      let constructor  = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
+      let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+      let _,cstl = Inductiveops.dest_ind_family indf in
+      let csta = Array.of_list cstl in
       let implicit_args =
 	Array.to_list
 	  (Array.init
@@ -450,44 +449,44 @@ let rec pattern_to_term_and_type env typ  = function
 	     implicit_args@patl_as_term
 	    )
 
-(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) 
-   of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the 
-   corresponding graphs. 
+(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return)
+   of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the
+   corresponding graphs.
 
 
    The idea to transform a term [t] into a list of constructors [lc] is the following:
-   \begin{itemize} 
-   \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding 
+   \begin{itemize}
+   \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding
    to [body] and add (bind x. _) to each elements of [lc]
-   \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) 
-   then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], 
-   then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], 
+   \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames)
+   then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
+   then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn],
    [g c1 ... cn] is an element of [lc]
-   \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then 
-   compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], 
+   \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then
+   compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
    then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn]
    create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc]
    \item if the term is a cast just treat its body part
-   \item 
-   if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case 
+   \item
+   if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case
    and concatenate them (informally, each branch of a match produces a new constructor)
    \end{itemize}
-   
-   WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. 
-   We must wait to have complete all the current calculi to set the recursive calls. 
-   At this point, each term [f t1 ... tn]  (where f appears in [funnames]) is replaced by 
-   a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. 
-   We in fact not create a constructor list since then end of each constructor has not the expected form 
-   but only the value of the function 
+
+   WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed.
+   We must wait to have complete all the current calculi to set the recursive calls.
+   At this point, each term [f t1 ... tn]  (where f appears in [funnames]) is replaced by
+   a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later.
+   We in fact not create a constructor list since then end of each constructor has not the expected form
+   but only the value of the function
 *)
 
 
-let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return = 
+let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
   observe (str " Entering : " ++ Printer.pr_rawconstr rt);
-  match rt with 
-    | RRef _ | RVar _ | REvar _ | RPatVar _     | RSort _  | RHole _  -> 
+  match rt with
+    | RRef _ | RVar _ | REvar _ | RPatVar _     | RSort _  | RHole _  ->
 	(* do nothing (except changing type of course) *)
-	mk_result [] rt avoid 
+	mk_result [] rt avoid
     | RApp(_,_,_) ->
 	let f,args = raw_decompose_app rt in
 	let args_res : (rawconstr list) build_entry_return =
@@ -501,110 +500,122 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	in
 	begin
 	  match f with
+	    | RLambda _  -> 
+		let rec aux t l = 
+		  match l with 
+		    | [] -> t
+		    | u::l -> 
+			match t with 
+			  | RLambda(loc,na,_,nat,b) -> 
+			      RLetIn(dummy_loc,na,u,aux b l)
+			  | _ -> 
+			      RApp(dummy_loc,t,l)
+		in
+		build_entry_lc env funnames avoid (aux f args)
 	    | RVar(_,id) when Idset.mem id funnames ->
 		(* if we have [f t1 ... tn] with [f]$\in$[fnames]
-		   then we create a fresh variable [res], 
-		   add [res] and its "value" (i.e. [res v1 ... vn]) to each 
-		   pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and 
-		   a pseudo value "v1 ... vn". 
+		   then we create a fresh variable [res],
+		   add [res] and its "value" (i.e. [res v1 ... vn]) to each
+		   pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and
+		   a pseudo value "v1 ... vn".
 		   The "value" of this branch is then simply [res]
 		*)
-		let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in 
-		let rt_typ = Typing.type_of env Evd.empty rt_as_constr in 
+		let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
+		let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
 		let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
 		let res = fresh_id args_res.to_avoid "res" in
 		let new_avoid = res::args_res.to_avoid in
-		let res_rt = mkRVar res in 
-		let new_result = 
-		  List.map 
-		    (fun arg_res -> 
-		       let new_hyps = 
+		let res_rt = mkRVar res in
+		let new_result =
+		  List.map
+		    (fun arg_res ->
+		       let new_hyps =
 			 [Prod (Name res),res_raw_type;
 			  Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
 		       in
-		       {context =  arg_res.context@new_hyps; value = res_rt } 
+		       {context =  arg_res.context@new_hyps; value = res_rt }
 		    )
 		    args_res.result
-		in 
+		in
 		{ result = new_result; to_avoid = new_avoid }
-	    | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> 
-		(* if have [g t1 ... tn] with [g] not appearing in [funnames] 
-		   then  
-		   foreach [ctxt,v1 ... vn] in [args_res] we return  
+	    | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
+		(* if have [g t1 ... tn] with [g] not appearing in [funnames]
+		   then
+		   foreach [ctxt,v1 ... vn] in [args_res] we return
 		   [ctxt, g v1 .... vn]
 		*)
 		{
-		  args_res with 
-		    result = 
-		    List.map 
-		      (fun args_res -> 
+		  args_res with
+		    result =
+		    List.map
+		      (fun args_res ->
 			 {args_res with value = mkRApp(f,args_res.value)})
 		      args_res.result
 		}
 	    | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
-       	    | RLetIn(_,n,t,b) -> 
-		(* if we have [(let x := v in b) t1 ... tn] , 
-		   we discard our work and compute the list of constructor for 
-		   [let x = v in (b t1 ... tn)] up to alpha conversion 
+       	    | RLetIn(_,n,t,b) ->
+		(* if we have [(let x := v in b) t1 ... tn] ,
+		   we discard our work and compute the list of constructor for
+		   [let x = v in (b t1 ... tn)] up to alpha conversion
 		*)
-		let new_n,new_b,new_avoid = 
-		  match n with 
-		    | Name id when List.exists (is_free_in id) args -> 
+		let new_n,new_b,new_avoid =
+		  match n with
+		    | Name id when List.exists (is_free_in id) args ->
 			(* need to alpha-convert the name *)
-			let new_id = Nameops.next_ident_away id avoid in 
+			let new_id = Namegen.next_ident_away id avoid in
 			let new_avoid = id:: avoid in
-			let new_b = 
+			let new_b =
 			  replace_var_by_term
 			    id
-			    (RVar(dummy_loc,id)) 
+			    (RVar(dummy_loc,id))
 			    b
-			in 
+			in
 			(Name new_id,new_b,new_avoid)
 		    | _ -> n,b,avoid
 		in
-		build_entry_lc 
+		build_entry_lc
 		  env
-		  funnames 
+		  funnames
 		  avoid
 		  (mkRLetIn(new_n,t,mkRApp(new_b,args)))
-	    | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> 
+	    | RCases _  | RIf _ | RLetTuple _ ->
 		(* we have [(match e1, ...., en with ..... end) t1 tn]
-		   we first compute the result from the case and 
+		   we first compute the result from the case and
 		   then combine each of them with each of args one
 		*)
 		let f_res = build_entry_lc env funnames args_res.to_avoid f in
 		combine_results combine_app f_res  args_res
-	    | RDynamic _ ->error "Not handled RDynamic" 
-	    | RCast(_,b,_) -> 
-		(* for an applied cast we just trash the cast part 
-		   and restart the work. 
+	    | RDynamic _ ->error "Not handled RDynamic"
+	    | RCast(_,b,_) ->
+		(* for an applied cast we just trash the cast part
+		   and restart the work.
 
 		   WARNING: We need to restart since [b] itself should be an application term
 		*)
 		build_entry_lc env funnames avoid (mkRApp(b,args))
 	    | RRec _ -> error "Not handled RRec"
 	    | RProd _ -> error "Cannot apply a type"
-	end (* end of the application treatement *) 
+	end (* end of the application treatement *)
 
     | RLambda(_,n,_,t,b) ->
-	(* we first compute the list of constructor 
-	   corresponding to the body of the function, 
-	   then the one corresponding to the type 
+	(* we first compute the list of constructor
+	   corresponding to the body of the function,
+	   then the one corresponding to the type
 	   and combine the two result
 	*)
 	let t_res = build_entry_lc env funnames avoid t  in
-	let new_n = 
-	  match n with 
-	    | Name _ -> n 
+	let new_n =
+	  match n with
+	    | Name _ -> n
 	    | Anonymous -> Name (Indfun_common.fresh_id [] "_x")
 	in
 	let new_env = raw_push_named (new_n,None,t) env in
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_lam new_n) t_res b_res
     | RProd(_,n,_,t,b) ->
-	(* we first compute the list of constructor 
-	   corresponding to the body of the function, 
-	   then the one corresponding to the type 
+	(* we first compute the list of constructor
+	   corresponding to the body of the function,
+	   then the one corresponding to the type
 	   and combine the two result
 	*)
 	let t_res = build_entry_lc env funnames avoid t in
@@ -612,38 +623,38 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_prod n) t_res b_res
     | RLetIn(_,n,v,b) ->
-	(* we first compute the list of constructor 
-	   corresponding to the body of the function, 
-	   then the one corresponding to the value [t] 
+	(* we first compute the list of constructor
+	   corresponding to the body of the function,
+	   then the one corresponding to the value [t]
 	   and combine the two result
 	*)
 	let v_res = build_entry_lc env funnames avoid v in
-	let v_as_constr = Pretyping.Default.understand Evd.empty env v in 
-	let v_type = Typing.type_of env Evd.empty v_as_constr in 
-	let new_env = 
+	let v_as_constr = Pretyping.Default.understand Evd.empty env v in
+	let v_type = Typing.type_of env Evd.empty v_as_constr in
+	let new_env =
 	  match n with
 	      Anonymous -> env
-	    | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env 
+	    | Name id -> Environ.push_named (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
-    | RCases(_,_,_,el,brl) -> 
-	(* we create the discrimination function 
-	   and treat the case itself 
+    | RCases(_,_,_,el,brl) ->
+	(* we create the discrimination function
+	   and treat the case itself
 	*)
-	let make_discr = make_discr_match brl in 
+	let make_discr = make_discr_match brl in
 	build_entry_lc_from_case env funnames make_discr el brl avoid
-    | RIf(_,b,(na,e_option),lhs,rhs) -> 
+    | RIf(_,b,(na,e_option),lhs,rhs) ->
 	let b_as_constr = Pretyping.Default.understand Evd.empty env b in
-	let b_typ = Typing.type_of env Evd.empty b_as_constr in 
-	let (ind,_) =  
-	  try Inductiveops.find_inductive env Evd.empty b_typ 
-	  with Not_found -> 
-	    errorlabstrm "" (str "Cannot find the inductive associated to " ++ 
+	let b_typ = Typing.type_of env Evd.empty b_as_constr in
+	let (ind,_) =
+	  try Inductiveops.find_inductive env Evd.empty b_typ
+	  with Not_found ->
+	    errorlabstrm "" (str "Cannot find the inductive associated to " ++
 			       Printer.pr_rawconstr b ++ str " in " ++
 			       Printer.pr_rawconstr rt ++ str ". try again with a cast")
 	in
-	let case_pats = build_constructors_of_type ind [] in 
+	let case_pats = build_constructors_of_type ind [] in
 	assert (Array.length case_pats = 2);
 	let brl =
 	  list_map_i
@@ -656,7 +667,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	in
 	(* 		Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
 	build_entry_lc env funnames avoid match_expr
-    | RLetTuple(_,nal,_,b,e) ->  
+    | RLetTuple(_,nal,_,b,e) ->
 	begin
 	  let nal_as_rawconstr =
 	    List.map
@@ -667,15 +678,15 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	      nal
 	  in
 	  let b_as_constr = Pretyping.Default.understand Evd.empty env b in
-	  let b_typ = Typing.type_of env Evd.empty b_as_constr in 
-	  let (ind,_) = 
-	    try Inductiveops.find_inductive env Evd.empty b_typ 
-	    with Not_found -> 
-	      errorlabstrm "" (str "Cannot find the inductive associated to " ++ 
+	  let b_typ = Typing.type_of env Evd.empty b_as_constr in
+	  let (ind,_) =
+	    try Inductiveops.find_inductive env Evd.empty b_typ
+	    with Not_found ->
+	      errorlabstrm "" (str "Cannot find the inductive associated to " ++
 				 Printer.pr_rawconstr b ++ str " in " ++
 				 Printer.pr_rawconstr rt ++ str ". try again with a cast")
 	  in
-	  let case_pats = build_constructors_of_type ind nal_as_rawconstr in 
+	  let case_pats = build_constructors_of_type ind nal_as_rawconstr in
 	  assert (Array.length case_pats = 1);
 	  let br =
 	    (dummy_loc,[],[case_pats.(0)],e)
@@ -685,25 +696,25 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 
 	end
     | RRec _ -> error "Not handled RRec"
-    | RCast(_,b,_) -> 
+    | RCast(_,b,_) ->
 	build_entry_lc env funnames  avoid b
     | RDynamic _ -> error "Not handled RDynamic"
 and build_entry_lc_from_case env funname make_discr
     (el:tomatch_tuples)
-    (brl:Rawterm.cases_clauses) avoid : 
-    rawconstr build_entry_return = 
-  match el with 
-    | [] -> assert false (* this case correspond to match <nothing> with .... !*) 
-    | el -> 
-	(* this case correspond to 
+    (brl:Rawterm.cases_clauses) avoid :
+    rawconstr build_entry_return =
+  match el with
+    | [] -> assert false (* this case correspond to match <nothing> with .... !*)
+    | el ->
+	(* this case correspond to
 	   match el with brl end
-	   we first compute the list of lists corresponding to [el] and 
-	   combine them . 
-	   Then for each elemeent of the combinations, 
-	   we compute the result we compute one list per branch in [brl] and 
-	   finally we just concatenate those list 
+	   we first compute the list of lists corresponding to [el] and
+	   combine them .
+	   Then for each elemeent of the combinations,
+	   we compute the result we compute one list per branch in [brl] and
+	   finally we just concatenate those list
 	*)
-	let case_resl = 
+	let case_resl =
 	    List.fold_right
 	    (fun (case_arg,_) ctxt_argsl ->
 	       let arg_res = build_entry_lc env funname avoid case_arg  in
@@ -712,27 +723,32 @@ and build_entry_lc_from_case env funname make_discr
 	    el
 	      (mk_result [] [] avoid)
 	in
-	(****** The next works only if the match is not dependent ****)
-	let types = 
-	  List.map (fun (case_arg,_) -> 
-		      let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in 
+	let types =
+	  List.map (fun (case_arg,_) ->
+		      let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
 		      Typing.type_of env Evd.empty case_arg_as_constr
 		   ) el
 	in
+	(****** The next works only if the match is not dependent ****)
 	let results =
-	  List.map 
-	    (build_entry_lc_from_case_term
+	  List.map
+	    (fun ca ->
+	       let res = build_entry_lc_from_case_term
 	       env types
-	       funname (make_discr (* (List.map fst el) *))
-	       []  brl 
-	       case_resl.to_avoid) 
-	    case_resl.result 
-	in 
-	{ 
+	       funname (make_discr)
+	       []  brl
+	       case_resl.to_avoid
+	       ca
+	       in
+	       res
+	    )
+	    case_resl.result
+	in
+	{
 	  result = List.concat (List.map (fun r -> r.result) results);
-	  to_avoid = 
+	  to_avoid =
 	    List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
-	} 
+	}
 
 and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
     matched_expr =
@@ -742,45 +758,48 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	(* alpha convertion to prevent name clashes *)
 	let _,idl,patl,return = alpha_br avoid br in
 	let new_avoid  = idl@avoid in 	(* for now we can no more use idl as an indentifier *)
-	(* building a list of precondition stating that we are not in this branch 
+	(* building a list of precondition stating that we are not in this branch
 	   (will be used in the following recursive calls)
 	*)
-	let new_env = List.fold_right2 add_pat_variables patl types env in 
-	let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = 
+	let new_env = List.fold_right2 add_pat_variables patl types env in
+	let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
 	  List.map2
-	    (fun pat typ -> 
-	       fun avoid pat'_as_term -> 
+	    (fun pat typ ->
+	       fun avoid pat'_as_term ->
 		 let renamed_pat,_,_ = alpha_pat avoid pat in
-		 let pat_ids = get_pattern_id renamed_pat  in 
-		 let env_with_pat_ids = add_pat_variables pat typ new_env in 
-		   List.fold_right 
-		   (fun id acc -> 		 
-		      let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in 
-		      let raw_typ_of_id = 
-			Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
-		      in
-		      mkRProd (Name id,raw_typ_of_id,acc))
-		   pat_ids
-		   (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
+		 let pat_ids = get_pattern_id renamed_pat  in
+		 let env_with_pat_ids = add_pat_variables pat typ new_env in
+		   List.fold_right
+		     (fun id acc ->
+			let typ_of_id =
+			  Typing.type_of env_with_pat_ids Evd.empty (mkVar id)
+			in
+			let raw_typ_of_id =
+			  Detyping.detype false []
+			    (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
+			in
+			mkRProd (Name id,raw_typ_of_id,acc))
+		     pat_ids
+		     (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
 	    )
 	    patl
 	    types
 	in
-	(* Checking if we can be in this branch 
+	(* Checking if we can be in this branch
 	   (will be used in the following recursive calls)
-	*)	   
+	*)
 	let unify_with_those_patterns : (cases_pattern -> bool*bool) list =
-	  List.map 
-	    (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') 
+	  List.map
+	    (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat')
 	    patl
 	in
-	(* 
-	   we first compute the other branch result (in ordrer to keep the order of the matching 
+	(*
+	   we first compute the other branch result (in ordrer to keep the order of the matching
 	   as much as possible)
 	*)
 	let brl'_res =
 	  build_entry_lc_from_case_term
-	    env 
+	    env
 	    types
 	    funname
 	    make_discr
@@ -790,10 +809,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	    matched_expr
 	in
 	(* We now create the precondition of this branch i.e.
-
-	   1- the list of variable appearing in the different patterns of this branch and 
+	   1- the list of variable appearing in the different patterns of this branch and
 	      the list of equation stating than el = patl (List.flatten ...)
-	   2- If there exists a previous branch which pattern unify with the one of this branch 
+	   2- If there exists a previous branch which pattern unify with the one of this branch
               then a discrimination precond stating that we are not in a previous branch (if List.exists ...)
 	*)
       	let those_pattern_preconds =
@@ -801,21 +819,20 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	    (
 	      list_map3
 	      (fun pat e typ_as_constr ->
-		 let this_pat_ids = ids_of_pat pat in 
+		 let this_pat_ids = ids_of_pat pat in
 		 let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
 		 let pat_as_term = pattern_to_term pat in
-		 List.fold_right 
-		   (fun id  acc -> 
-		      if Idset.mem id this_pat_ids 
+		 List.fold_right
+		   (fun id  acc ->
+		      if Idset.mem id this_pat_ids
 		      then (Prod (Name id),
-		      let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in 
-		      let raw_typ_of_id = 
+		      let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
+		      let raw_typ_of_id =
 			Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
 		      in
 		      raw_typ_of_id
 			   )::acc
 		      else acc
-			
 		   )
 		   idl
 		   [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
@@ -827,15 +844,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	  )
 	  @
 	  (if List.exists (function (unifl,_) ->
-			     let (unif,_) = 
+			     let (unif,_) =
 			       List.split (List.map2 (fun x y -> x y) unifl patl)
 			     in
 			     List.for_all (fun x -> x) unif) patterns_to_prevent
-	   then 
-	     let i = List.length patterns_to_prevent in 
+	   then
+	     let i = List.length patterns_to_prevent in
 	     let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in
 	     [(Prod Anonymous,make_discr pats_as_constr i  )]
-	   else 
+	   else
 	     []
 	  )
 	in
@@ -851,80 +868,183 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	    return_res.result
 	in
 	{ brl'_res with result = this_branch_res@brl'_res.result }
-	  
-	  
-let is_res id = 
+
+
+let is_res id =
   try
     String.sub (string_of_id id) 0 3 = "res"
-  with Invalid_argument _ -> false 
+  with Invalid_argument _ -> false
+
 
-(* 
-   The second phase which reconstruct the real type of the constructor. 
-   rebuild the raw constructors expression. 
+exception Continue
+(*
+   The second phase which reconstruct the real type of the constructor.
+   rebuild the raw constructors expression.
    eliminates some meaningless equalities, applies some rewrites......
 *)
-let rec rebuild_cons nb_args relname args crossed_types depth rt = 
-  match rt with 
-    | RProd(_,n,k,t,b) -> 
-	let not_free_in_t id = not (is_free_in id t) in 
-	let new_crossed_types = t::crossed_types in 
+let rec rebuild_cons env nb_args relname args crossed_types depth rt =
+  observe (str "rebuilding : " ++ pr_rawconstr rt);
+
+  match rt with
+    | RProd(_,n,k,t,b) ->
+	let not_free_in_t id = not (is_free_in id t) in
+	let new_crossed_types = t::crossed_types in
 	begin
-	  match t with 
+	  match t with
 	    | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
 		begin
-		  match args' with 
-		    | (RVar(_,this_relname))::args' -> 
-			let new_b,id_to_exclude =  
-			  rebuild_cons 
+		  match args' with
+		    | (RVar(_,this_relname))::args' ->
+			(*i The next call to mk_rel_id is
+			  valid since we are constructing the graph
+			  Ensures by: obvious
+			  i*)
+
+			let new_t =
+			  mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
+			in
+			let t' = Pretyping.Default.understand Evd.empty env new_t in
+			let new_env = Environ.push_rel (n,None,t') env in
+			let new_b,id_to_exclude =
+			  rebuild_cons new_env
 			    nb_args relname
 			    args new_crossed_types
 			    (depth + 1) b
-			in 
-			(*i The next call to mk_rel_id is valid since we are constructing the graph
-			  Ensures by: obvious
-			  i*) 
-
-			let new_t = 
-			  mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) 
-			in mkRProd(n,new_t,new_b),
+			in
+			mkRProd(n,new_t,new_b),
 			Idset.filter not_free_in_t id_to_exclude
 		    | _ -> (* the first args is the name of the function! *)
-			assert false 
+			assert false
 		end
-	    | RApp(_,RRef(_,eq_as_ref),[_;RVar(_,id);rt]) 
+	    | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
 		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
-		  -> 
-		let is_in_b = is_free_in id b in
-		let _keep_eq = 
-		  not (List.exists (is_free_in id) args) || is_in_b  || 
-		    List.exists (is_free_in id) crossed_types 
-		in 
-		let new_args = List.map (replace_var_by_term id rt) args in 
-		let subst_b = 
-		  if is_in_b then b else  replace_var_by_term id rt b 
-		in 
-		let new_b,id_to_exclude =  
-		  rebuild_cons 
-		    nb_args relname
-		    new_args new_crossed_types
-		    (depth + 1) subst_b
-		in 
-		mkRProd(n,t,new_b),id_to_exclude
-		  (* J.F:. keep this comment  it explain how to remove some meaningless equalities 
+		  ->
+		begin
+		  try
+		    observe (str "computing new type for eq : " ++ pr_rawconstr rt);
+		    let t' =
+		      try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue
+		    in
+		    let is_in_b = is_free_in id b in
+		    let _keep_eq =
+		      not (List.exists (is_free_in id) args) || is_in_b  ||
+			List.exists (is_free_in id) crossed_types
+		    in
+		    let new_args = List.map (replace_var_by_term id rt) args in
+		    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_b,id_to_exclude =
+		      rebuild_cons
+			new_env
+			nb_args relname
+			new_args new_crossed_types
+			(depth + 1) subst_b
+		    in
+		    mkRProd(n,t,new_b),id_to_exclude
+		  with Continue ->
+		    let jmeq = Libnames.IndRef (destInd (jmeq ())) in
+		    let ty' = Pretyping.Default.understand Evd.empty env ty in
+		    let ind,args' = Inductive.find_inductive env ty' in
+		    let mib,_ = Global.lookup_inductive ind in
+		    let nparam = mib.Declarations.mind_nparams in
+		    let params,arg' =
+		      ((Util.list_chop nparam args'))
+		    in
+		    let rt_typ =
+		       RApp(Util.dummy_loc,
+			    RRef (Util.dummy_loc,Libnames.IndRef ind),
+			    (List.map
+			      (fun p -> Detyping.detype false []
+				 (Termops.names_of_rel_context env)
+				 p) params)@(Array.to_list
+				      (Array.make
+					 (List.length args' - nparam)
+					 (mkRHole ()))))
+		    in
+		    let eq' =
+		      RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt])
+		    in
+		    observe (str "computing new type for jmeq : " ++ pr_rawconstr eq');
+		    let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
+		    observe (str " computing new type for jmeq : done") ;
+		    let new_args =
+		      match kind_of_term eq'_as_constr with
+			| App(_,[|_;_;ty;_|]) ->
+			    let ty = Array.to_list (snd (destApp ty)) in
+			    let ty' = snd (Util.list_chop nparam ty) in
+			    List.fold_left2
+			      (fun acc var_as_constr arg ->
+				 if isRel var_as_constr
+				 then
+				   let (na,_,_) =
+				     Environ.lookup_rel (destRel var_as_constr) env
+				   in
+				   match na with
+				     | Anonymous -> acc
+				     | Name id' ->
+					 (id',Detyping.detype false []
+					    (Termops.names_of_rel_context env)
+					    arg)::acc
+				 else if isVar var_as_constr
+				 then (destVar var_as_constr,Detyping.detype false []
+					 (Termops.names_of_rel_context env)
+					 arg)::acc
+				 else acc
+			      )
+			      []
+			      arg'
+			      ty'
+			| _ -> assert false
+		    in
+		    let is_in_b = is_free_in id b in
+		    let _keep_eq =
+		      not (List.exists (is_free_in id) args) || is_in_b  ||
+			List.exists (is_free_in id) crossed_types
+		    in
+		    let new_args =
+		      List.fold_left
+			(fun args (id,rt) ->
+			   List.map (replace_var_by_term id rt) args
+			)
+			args
+			((id,rt)::new_args)
+		    in
+		    let subst_b =
+		     if is_in_b then b else  replace_var_by_term id rt b
+		    in
+		    let new_env =
+		      let t' = Pretyping.Default.understand Evd.empty env eq' in
+		      Environ.push_rel (n,None,t') env
+		    in
+		    let new_b,id_to_exclude =
+		      rebuild_cons
+			new_env
+			nb_args relname
+			new_args new_crossed_types
+			(depth + 1) subst_b
+		    in
+		    mkRProd(n,eq',new_b),id_to_exclude
+		end
+		  (* J.F:. keep this comment  it explain how to remove some meaningless equalities
 		     if keep_eq then
 		     mkRProd(n,t,new_b),id_to_exclude
 		     else new_b, Idset.add id id_to_exclude
 		  *)
-	    | _ -> 
-		let new_b,id_to_exclude =  
-		  rebuild_cons 
+	    | _ ->
+		observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+		let t' = Pretyping.Default.understand Evd.empty env t in
+		let new_env = Environ.push_rel (n,None,t') env in
+		let new_b,id_to_exclude =
+		  rebuild_cons new_env
 		    nb_args relname
 		    args new_crossed_types
 		    (depth + 1) b
-		in 
+		in
 		match n with
 		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
-		      new_b,Idset.remove id 
+		      new_b,Idset.remove id
 			(Idset.filter not_free_in_t id_to_exclude)
 		  | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
 	end
@@ -932,53 +1052,61 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt =
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_crossed_types = t :: crossed_types in
+	  observe (str "computing new type for lambda : " ++ pr_rawconstr rt);
+	  let t' = Pretyping.Default.understand Evd.empty env t in
 	  match n with
 	    | Name id ->
-		let new_b,id_to_exclude = 
-		  rebuild_cons 
+		let new_env = Environ.push_rel (n,None,t') env in
+		let new_b,id_to_exclude =
+		  rebuild_cons new_env
 		    nb_args relname
 		    (args@[mkRVar id])new_crossed_types
-		    (depth + 1 ) b 
+		    (depth + 1 ) b
 		in
 		if Idset.mem id id_to_exclude && depth >= nb_args
-		then 
+		then
 		  new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
 		else
 		  RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
-	    | _ -> anomaly "Should not have an anonymous function here" 
+	    | _ -> anomaly "Should not have an anonymous function here"
 		(* We have renamed all the anonymous functions during alpha_renaming phase *)
-	  
+
 	end
-    | RLetIn(_,n,t,b) -> 
+    | RLetIn(_,n,t,b) ->
 	begin
-	  let not_free_in_t id = not (is_free_in id t) in 
-	  let new_b,id_to_exclude = 
-	    rebuild_cons 
+	  let not_free_in_t id = not (is_free_in id t) in
+	  let t' = Pretyping.Default.understand Evd.empty env t in
+	  let type_t' = Typing.type_of env Evd.empty t' in
+	  let new_env = Environ.push_rel (n,Some t',type_t') env in
+	  let new_b,id_to_exclude =
+	    rebuild_cons new_env
 	      nb_args relname
 	      args (t::crossed_types)
 	      (depth + 1 ) b in
-	  match n with 
-	    | Name id when Idset.mem id id_to_exclude && depth >= nb_args  -> 
+	  match n with
+	    | Name id when Idset.mem id id_to_exclude && depth >= nb_args  ->
 		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
 	    | _ -> RLetIn(dummy_loc,n,t,new_b),
 		Idset.filter not_free_in_t id_to_exclude
 	end
-    | RLetTuple(_,nal,(na,rto),t,b) -> 
+    | RLetTuple(_,nal,(na,rto),t,b) ->
 	assert (rto=None);
 	begin
-	  let not_free_in_t id = not (is_free_in id t) in 
-	  let new_t,id_to_exclude' = 
-	    rebuild_cons 
+	  let not_free_in_t id = not (is_free_in id t) in
+	  let new_t,id_to_exclude' =
+	    rebuild_cons env
 	      nb_args
-	      relname 
-	      args (crossed_types) 
-	      depth t 
+	      relname
+	      args (crossed_types)
+	      depth t
 	  in
-	  let new_b,id_to_exclude = 
-	    rebuild_cons 
+	  let t' = Pretyping.Default.understand Evd.empty env new_t in
+	  let new_env = Environ.push_rel (na,None,t') env in
+	  let new_b,id_to_exclude =
+	    rebuild_cons new_env
 	      nb_args relname
-	      args (t::crossed_types) 
-	      (depth + 1) b 
+	      args (t::crossed_types)
+	      (depth + 1) b
 	  in
 (* 	  match n with  *)
 (* 	    | Name id when Idset.mem id id_to_exclude ->  *)
@@ -993,142 +1121,171 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt =
 
 
 (* debuging wrapper *)
-let rebuild_cons nb_args relname args crossed_types rt = 
+let rebuild_cons env nb_args relname args crossed_types rt =
 (*   observennl  (str "rebuild_cons : rt := "++ pr_rawconstr rt ++  *)
 (* 		 str "nb_args := " ++ str (string_of_int nb_args)); *)
-  let res = 
-    rebuild_cons nb_args relname args crossed_types 0 rt 
+  let res =
+    rebuild_cons env nb_args relname args crossed_types 0 rt
   in
 (*   observe (str " leads to "++ pr_rawconstr (fst res)); *)
   res
 
 
-(* naive implementation of parameter detection. 
+(* naive implementation of parameter detection.
 
-   A parameter is an argument which is only preceded by parameters and whose 
-   calls are all syntaxically equal. 
+   A parameter is an argument which is only preceded by parameters and whose
+   calls are all syntaxically equal.
 
-   TODO: Find a valid way to deal with implicit arguments here! 
+   TODO: Find a valid way to deal with implicit arguments here!
 *)
-let rec compute_cst_params relnames params = function 
+let rec compute_cst_params relnames params = function
   | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
   | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
       compute_cst_params_from_app [] (params,rtl)
-  | RApp(_,f,args) -> 
+  | RApp(_,f,args) ->
       List.fold_left (compute_cst_params relnames) params (f::args)
-  | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> 
-      let t_params = compute_cst_params relnames params t in 
+  | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) ->
+      let t_params = compute_cst_params relnames params t in
       compute_cst_params relnames t_params b
   | RCases _ ->
-      params  (* If there is still cases at this point they can only be 
+      params  (* If there is still cases at this point they can only be
 		 discriminitation ones *)
   | RSort _ -> params
   | RHole _ -> params
   | RIf _ | RRec _ | RCast _ | RDynamic _  ->
       raise (UserError("compute_cst_params", str "Not handled case"))
-and compute_cst_params_from_app acc (params,rtl) = 
-  match params,rtl with 
+and compute_cst_params_from_app acc (params,rtl) =
+  match params,rtl with
     | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
-    | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' 
-	when id_ord id id' == 0 && not is_defined -> 
+    | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl'
+	when id_ord id id' == 0 && not is_defined ->
 	compute_cst_params_from_app (param::acc) (params',rtl')
-    | _  -> List.rev acc 
-   
-let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =  
-  let rels_params = 
-    Array.mapi 
-      (fun i args -> 
-	 List.fold_left 
-	   (fun params (_,cst) -> compute_cst_params relnames params cst) 
+    | _  -> List.rev acc
+
+let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =
+  let rels_params =
+    Array.mapi
+      (fun i args ->
+	 List.fold_left
+	   (fun params (_,cst) -> compute_cst_params relnames params cst)
 	   args
 	   csts.(i)
       )
       args
-  in 
-  let l = ref [] in 
-  let _ = 
-    try 
+  in
+  let l = ref [] in
+  let _ =
+    try
       list_iter_i
-	(fun i ((n,nt,is_defined) as param) -> 
-	   if array_for_all 
-	     (fun l -> 
-		let (n',nt',is_defined') = List.nth l i in 
+	(fun i ((n,nt,is_defined) as param) ->
+	   if array_for_all
+	     (fun l ->
+		let (n',nt',is_defined') = List.nth l i in
 		n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined')
 	     rels_params
-	   then 
+	   then
 	     l := param::!l
-	) 
+	)
 	rels_params.(0)
-    with _ -> 
+    with _ ->
       ()
-  in 
+  in
   List.rev !l
 
-let rec rebuild_return_type rt = 
-  match rt with 
-    | Topconstr.CProdN(loc,n,t') -> 
-	Topconstr.CProdN(loc,n,rebuild_return_type t') 
-    | Topconstr.CArrow(loc,t,t') -> 
+let rec rebuild_return_type rt =
+  match rt with
+    | Topconstr.CProdN(loc,n,t') ->
+	Topconstr.CProdN(loc,n,rebuild_return_type t')
+    | Topconstr.CArrow(loc,t,t') ->
 	Topconstr.CArrow(loc,t,rebuild_return_type t')
-    | Topconstr.CLetIn(loc,na,t,t') -> 
-	Topconstr.CLetIn(loc,na,t,rebuild_return_type t') 
+    | Topconstr.CLetIn(loc,na,t,t') ->
+	Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
     | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
 
 
-let do_build_inductive 
-    funnames (funsargs: (Names.name * rawconstr * bool) list list)  
-    returned_types 
+let do_build_inductive
+    funnames (funsargs: (Names.name * rawconstr * bool) list list)
+    returned_types
     (rtl:rawconstr list) =
   let _time1 = System.get_time () in
 (*   Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
   let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
-  let funnames = Array.of_list funnames in  
-  let funsargs = Array.of_list funsargs in 
+  let funnames = Array.of_list funnames in
+  let funsargs = Array.of_list funsargs in
   let returned_types = Array.of_list returned_types in
   (* alpha_renaming of the body to prevent variable capture during manipulation *)
   let rtl_alpha = List.map (function rt ->  expand_as (alpha_rt [] rt)) rtl in
   let rta = Array.of_list rtl_alpha in
   (*i The next call to mk_rel_id is valid since we are constructing the graph
     Ensures by: obvious
-    i*) 
+    i*)
   let relnames = Array.map mk_rel_id funnames in
-  let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in 
+  let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
   (* Construction of the pseudo constructors *)
-  let env = 
-    Array.fold_right 
-      (fun id env -> 
+  let env =
+    Array.fold_right
+      (fun id env ->
 	 Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id))  env
       )
-      funnames 
+      funnames
       (Global.env ())
-  in      
-  let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in 
+  in
+  let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in
+  let env_with_graphs =
+    let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
+      let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  =
+	funargs
+      in
+      List.fold_right
+	(fun (n,t,is_defined) acc ->
+	   if is_defined
+	   then
+	     Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+			      acc)
+	   else
+	     Topconstr.CProdN
+	       (dummy_loc,
+		[[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+		acc
+	       )
+	)
+	rel_first_args
+	(rebuild_return_type returned_types.(i))
+    in
+    (* We need to lift back our work topconstr but only with all information
+       We mimick a Set Printing All.
+       Then save the graphs and reset Printing options to their primitive values
+    *)
+    let rel_arities = Array.mapi rel_arity funsargs in
+    Util.array_fold_left2 (fun env rel_name rel_ar ->
+			     Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities
+  in
   (* and of the real constructors*)
-  let constr i res = 
-    List.map 
-      (function result (* (args',concl') *) -> 
-	 let rt = compose_raw_context result.context result.value in 
-	 let nb_args = List.length funsargs.(i) in 
+  let constr i res =
+    List.map
+      (function result (* (args',concl') *) ->
+	 let rt = compose_raw_context result.context result.value in
+	 let nb_args = List.length funsargs.(i) in
 	 (*  with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
 	 fst (
-	   rebuild_cons nb_args relnames.(i)
+	   rebuild_cons env_with_graphs nb_args relnames.(i)
 	     []
 	     []
-	     rt 
+	     rt
 	 )
-      ) 
-      res.result 
-  in 
+      )
+      res.result
+  in
   (* adding names to constructors  *)
- let next_constructor_id = ref (-1) in 
-  let mk_constructor_id i = 
+ let next_constructor_id = ref (-1) in
+  let mk_constructor_id i =
     incr next_constructor_id;
     (*i The next call to mk_rel_id is valid since we are constructing the graph
       Ensures by: obvious
-      i*) 
+      i*)
     id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
   in
-  let rel_constructors i rt : (identifier*rawconstr) list = 
+  let rel_constructors i rt : (identifier*rawconstr) list =
     next_constructor_id := (-1);
     List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
   in
@@ -1137,18 +1294,18 @@ let do_build_inductive
   let rels_params = compute_params_name relnames_as_set funsargs  rel_constructors in
   let nrel_params = List.length rels_params in
   let rel_constructors = (* Taking into account the parameters in constructors *)
-    Array.map (List.map 
+    Array.map (List.map
     (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt))))
     rel_constructors
   in
   let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-    let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  = 
+    let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  =
       (snd (list_chop nrel_params funargs))
-    in 
+    in
     List.fold_right
-      (fun (n,t,is_defined) acc -> 
+      (fun (n,t,is_defined) acc ->
 	 if is_defined
-	 then 
+	 then
 	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
 			    acc)
 	 else
@@ -1161,26 +1318,26 @@ let do_build_inductive
       rel_first_args
       (rebuild_return_type returned_types.(i))
   in
-  (* We need to lift back our work topconstr but only with all information 
-     We mimick a Set Printing All. 
-     Then save the graphs and reset Printing options to their primitive values 
+  (* We need to lift back our work topconstr but only with all information
+     We mimick a Set Printing All.
+     Then save the graphs and reset Printing options to their primitive values
   *)
   let rel_arities = Array.mapi rel_arity funsargs in
-  let rel_params =  
-    List.map 
-      (fun (n,t,is_defined) -> 
-	 if is_defined 
+  let rel_params =
+    List.map
+      (fun (n,t,is_defined) ->
+	 if is_defined
 	 then
 	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
 	 else
-	 Topconstr.LocalRawAssum 
+	 Topconstr.LocalRawAssum
 	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
       )
       rels_params
-  in 
-  let ext_rels_constructors = 
-    Array.map (List.map 
-      (fun (id,t) -> 
+  in
+  let ext_rels_constructors =
+    Array.map (List.map
+      (fun (id,t) ->
 	 false,((dummy_loc,id),
 		Flags.with_option
 		  Flags.raw_print
@@ -1189,14 +1346,14 @@ let do_build_inductive
       ))
       (rel_constructors)
   in
-  let rel_ind i ext_rel_constructors = 
+  let rel_ind i ext_rel_constructors =
     ((dummy_loc,relnames.(i)),
     rel_params,
     Some rel_arities.(i),
-    ext_rel_constructors),None
+    ext_rel_constructors),[]
   in
-  let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in 
-  let rel_inds = Array.to_list ext_rel_constructors in 
+  let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in
+  let rel_inds = Array.to_list ext_rel_constructors in
 (*   let _ =  *)
 (*   Pp.msgnl  (\* observe *\) ( *)
 (*       str "Inductive" ++ spc () ++ *)
@@ -1217,35 +1374,35 @@ let do_build_inductive
 (* 	rel_inds *)
 (*     ) *)
 (*   in *)
-  let _time2 = System.get_time () in 
-  try 
-    with_full_print (Flags.silently (Command.build_mutual rel_inds)) true
-  with 
+  let _time2 = System.get_time () in
+  try
+    with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true
+  with
     | UserError(s,msg) as e ->
 	let _time3 = System.get_time () in
 (* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
-	let repacked_rel_inds = 
+	let repacked_rel_inds =
 	  List.map  (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
 	                  rel_inds
 	in
-	let msg = 		     
+	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds))
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
 	    ++ fnl () ++
 	    msg
 	in
 	observe (msg);
 	raise e
-    | e -> 
+    | e ->
 	let _time3 = System.get_time () in
 (* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
-	let repacked_rel_inds = 
+	let repacked_rel_inds =
 	  List.map  (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
 	                  rel_inds
 	in
-	let msg = 		     
+	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) 
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
 	    ++ fnl () ++
 	    Cerrors.explain_exn e
 	in
@@ -1254,9 +1411,9 @@ let do_build_inductive
 
 
 
-let build_inductive funnames funsargs returned_types rtl = 
-  try 
+let build_inductive funnames funsargs returned_types rtl =
+  try
     do_build_inductive funnames funsargs returned_types rtl
   with e -> raise (Building_graph e)
-      
+
 
diff --git a/contrib/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli
index 0075fb0a..a314050f 100644
--- a/contrib/funind/rawterm_to_relation.mli
+++ b/plugins/funind/rawterm_to_relation.mli
@@ -2,8 +2,8 @@
 
 
 (*
-  [build_inductive parametrize funnames funargs returned_types bodies] 
-  constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments 
+  [build_inductive parametrize funnames funargs returned_types bodies]
+  constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments
   and returning [returned_types] using bodies [bodies]
 *)
 
diff --git a/contrib/funind/rawtermops.ml b/plugins/funind/rawtermops.ml
index 92396af5..e31f1452 100644
--- a/contrib/funind/rawtermops.ml
+++ b/plugins/funind/rawtermops.ml
@@ -1,11 +1,11 @@
-open Pp 
+open Pp
 open Rawterm
 open Util
 open Names
 (* Ocaml 3.06 Map.S does not handle is_empty *)
 let idmap_is_empty m = m = Idmap.empty
 
-(* 
+(*
    Some basic functions to rebuild rawconstr
    In each of them the location is Util.dummy_loc
 *)
@@ -24,152 +24,152 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
   Some basic functions to decompose rawconstrs
   These are analogous to the ones constrs
 *)
-let raw_decompose_prod = 
-  let rec raw_decompose_prod args = function 
-  | RProd(_,n,k,t,b) -> 
-      raw_decompose_prod ((n,t)::args) b 
+let raw_decompose_prod =
+  let rec raw_decompose_prod args = function
+  | RProd(_,n,k,t,b) ->
+      raw_decompose_prod ((n,t)::args) b
   | rt -> args,rt
   in
   raw_decompose_prod []
 
-let raw_decompose_prod_or_letin = 
-  let rec raw_decompose_prod args = function 
-  | RProd(_,n,k,t,b) -> 
-      raw_decompose_prod ((n,None,Some t)::args) b 
-  | RLetIn(_,n,t,b) -> 
-      raw_decompose_prod ((n,Some t,None)::args) b 
+let raw_decompose_prod_or_letin =
+  let rec raw_decompose_prod args = function
+  | RProd(_,n,k,t,b) ->
+      raw_decompose_prod ((n,None,Some t)::args) b
+  | RLetIn(_,n,t,b) ->
+      raw_decompose_prod ((n,Some t,None)::args) b
   | rt -> args,rt
   in
   raw_decompose_prod []
 
-let raw_compose_prod = 
+let raw_compose_prod =
   List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
 
-let raw_compose_prod_or_letin = 
+let raw_compose_prod_or_letin =
   List.fold_left (
-      fun concl decl -> 
-	match decl with 
+      fun concl decl ->
+	match decl with
 	  | (n,None,Some t) -> mkRProd(n,t,concl)
 	  | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl)
 	  | _ -> assert false)
 
-let raw_decompose_prod_n n = 
-  let rec raw_decompose_prod i args c = 
+let raw_decompose_prod_n n =
+  let rec raw_decompose_prod i args c =
     if i<=0 then args,c
     else
       match c with
-	| RProd(_,n,_,t,b) -> 
-	    raw_decompose_prod (i-1) ((n,t)::args) b 
+	| RProd(_,n,_,t,b) ->
+	    raw_decompose_prod (i-1) ((n,t)::args) b
 	| rt -> args,rt
   in
   raw_decompose_prod n []
 
 
-let raw_decompose_prod_or_letin_n n = 
-  let rec raw_decompose_prod i args c = 
+let raw_decompose_prod_or_letin_n n =
+  let rec raw_decompose_prod i args c =
     if i<=0 then args,c
     else
       match c with
-	| RProd(_,n,_,t,b) -> 
-	    raw_decompose_prod (i-1) ((n,None,Some t)::args) b 
-	| RLetIn(_,n,t,b) -> 
-	    raw_decompose_prod (i-1) ((n,Some t,None)::args) b 
+	| RProd(_,n,_,t,b) ->
+	    raw_decompose_prod (i-1) ((n,None,Some t)::args) b
+	| RLetIn(_,n,t,b) ->
+	    raw_decompose_prod (i-1) ((n,Some t,None)::args) b
 	| rt -> args,rt
   in
   raw_decompose_prod n []
 
 
-let raw_decompose_app = 
+let raw_decompose_app =
   let rec decompose_rapp acc rt =
 (*     msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
-    match rt with 
-    | RApp(_,rt,rtl) -> 
+    match rt with
+    | RApp(_,rt,rtl) ->
 	decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
     | rt -> rt,List.rev acc
   in
-  decompose_rapp [] 
+  decompose_rapp []
 
 
 
 
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) 
-let raw_make_eq ?(typ= mkRHole ()) t1 t2  = 
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
+let raw_make_eq ?(typ= mkRHole ()) t1 t2  =
   mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
 
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) 
-let raw_make_neq t1 t2 = 
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
+let raw_make_neq t1 t2 =
   mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
 
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) 
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
 let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
 
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding 
-   to [P1 \/ ( .... \/ Pn)] 
-*) 
-let rec raw_make_or_list = function  
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+   to [P1 \/ ( .... \/ Pn)]
+*)
+let rec raw_make_or_list = function
   | [] -> raise (Invalid_argument "mk_or")
   | [e] -> e
   | e::l -> raw_make_or e (raw_make_or_list l)
 
-  
-let remove_name_from_mapping mapping na = 
-  match na with 
-    | Anonymous -> mapping 
+
+let remove_name_from_mapping mapping na =
+  match na with
+    | Anonymous -> mapping
     | Name id -> Idmap.remove id mapping
 
-let change_vars = 
-  let rec change_vars mapping rt = 
-    match rt with 
-      | RRef _ -> rt 
-      | RVar(loc,id) ->  
-	  let new_id = 
-	    try 
-	      Idmap.find id mapping 
-	    with Not_found -> id 
+let change_vars =
+  let rec change_vars mapping rt =
+    match rt with
+      | RRef _ -> rt
+      | RVar(loc,id) ->
+	  let new_id =
+	    try
+	      Idmap.find id mapping
+	    with Not_found -> id
 	  in
 	  RVar(loc,new_id)
-      | REvar _ -> rt 
-      | RPatVar _ -> rt 
-      | RApp(loc,rt',rtl) -> 
+      | REvar _ -> rt
+      | RPatVar _ -> rt
+      | RApp(loc,rt',rtl) ->
 	  RApp(loc,
 	       change_vars mapping rt',
 	       List.map (change_vars mapping) rtl
 	      )
-      | RLambda(loc,name,k,t,b) -> 
+      | RLambda(loc,name,k,t,b) ->
 	  RLambda(loc,
 		  name,
 		  k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | RProd(loc,name,k,t,b) -> 
+      | RProd(loc,name,k,t,b) ->
 	  RProd(loc,
 		  name,
 	          k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | RLetIn(loc,name,def,b) -> 
+      | RLetIn(loc,name,def,b) ->
 	  RLetIn(loc,
 		 name,
 		 change_vars mapping def,
 		 change_vars (remove_name_from_mapping mapping name) b
 		)
-      | RLetTuple(loc,nal,(na,rto),b,e) -> 
-	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in 
+      | RLetTuple(loc,nal,(na,rto),b,e) ->
+	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
 	  RLetTuple(loc,
 		    nal,
-		    (na, Option.map (change_vars mapping) rto), 
-		    change_vars mapping b, 
+		    (na, Option.map (change_vars mapping) rto),
+		    change_vars mapping b,
 		    change_vars new_mapping e
 		   )
-      | RCases(loc,sty,infos,el,brl) -> 
+      | RCases(loc,sty,infos,el,brl) ->
 	  RCases(loc,sty,
 		 infos,
-		 List.map (fun (e,x) -> (change_vars mapping e,x)) el, 
+		 List.map (fun (e,x) -> (change_vars mapping e,x)) el,
 		 List.map (change_vars_br mapping) brl
 		)
-      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
+      | RIf(loc,b,(na,e_option),lhs,rhs) ->
 	  RIf(loc,
 	      change_vars mapping b,
 	      (na,Option.map (change_vars mapping) e_option),
@@ -177,211 +177,211 @@ let change_vars =
 	      change_vars mapping rhs
 	     )
       | RRec _ -> error "Local (co)fixes are not supported"
-      | RSort _ -> rt 
-      | RHole _ -> rt 
-      | RCast(loc,b,CastConv (k,t)) -> 
+      | RSort _ -> rt
+      | RHole _ -> rt
+      | RCast(loc,b,CastConv (k,t)) ->
 	  RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
-      | RCast(loc,b,CastCoerce) -> 
+      | RCast(loc,b,CastCoerce) ->
 	  RCast(loc,change_vars mapping b,CastCoerce)
       | RDynamic _ -> error "Not handled RDynamic"
-  and change_vars_br mapping ((loc,idl,patl,res) as br) = 
-    let new_mapping = List.fold_right Idmap.remove idl mapping in 
-    if idmap_is_empty new_mapping 
-    then br 
+  and change_vars_br mapping ((loc,idl,patl,res) as br) =
+    let new_mapping = List.fold_right Idmap.remove idl mapping in
+    if idmap_is_empty new_mapping
+    then br
     else (loc,idl,patl,change_vars new_mapping res)
   in
-  change_vars 
+  change_vars
 
 
 
-let rec alpha_pat excluded pat = 
-  match pat with 
-    | PatVar(loc,Anonymous) -> 
-	let new_id = Indfun_common.fresh_id excluded "_x" in 
+let rec alpha_pat excluded pat =
+  match pat with
+    | PatVar(loc,Anonymous) ->
+	let new_id = Indfun_common.fresh_id excluded "_x" in
 	PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
-    | PatVar(loc,Name id) -> 
-	if List.mem id excluded 
-	then 
-	  let new_id = Nameops.next_ident_away id excluded in 
+    | PatVar(loc,Name id) ->
+	if List.mem id excluded
+	then
+	  let new_id = Namegen.next_ident_away id excluded in
 	  PatVar(loc,Name new_id),(new_id::excluded),
 	(Idmap.add id new_id Idmap.empty)
 	else pat,excluded,Idmap.empty
-    | PatCstr(loc,constr,patl,na) -> 
-	let new_na,new_excluded,map = 
-	  match na with 
-	    | Name id when List.mem id excluded -> 
-		let new_id = Nameops.next_ident_away id excluded in 
+    | PatCstr(loc,constr,patl,na) ->
+	let new_na,new_excluded,map =
+	  match na with
+	    | Name id when List.mem id excluded ->
+		let new_id = Namegen.next_ident_away id excluded in
 		Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
 	    | _ -> na,excluded,Idmap.empty
-	in 
-	let new_patl,new_excluded,new_map = 
-	  List.fold_left 
-	    (fun (patl,excluded,map) pat -> 
-	       let new_pat,new_excluded,new_map = alpha_pat excluded pat in 
+	in
+	let new_patl,new_excluded,new_map =
+	  List.fold_left
+	    (fun (patl,excluded,map) pat ->
+	       let new_pat,new_excluded,new_map = alpha_pat excluded pat in
 	       (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
 	    )
 	    ([],new_excluded,map)
 	    patl
-	in 
+	in
 	PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map
 
-let alpha_patl excluded patl  = 
-  let patl,new_excluded,map = 
-    List.fold_left 
-      (fun (patl,excluded,map) pat -> 
-	 let new_pat,new_excluded,new_map = alpha_pat excluded pat in 
+let alpha_patl excluded patl  =
+  let patl,new_excluded,map =
+    List.fold_left
+      (fun (patl,excluded,map) pat ->
+	 let new_pat,new_excluded,new_map = alpha_pat excluded pat in
 	 new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
       )
       ([],excluded,Idmap.empty)
       patl
-  in 
+  in
   (List.rev patl,new_excluded,map)
 
 
 
-  
-let raw_get_pattern_id pat acc = 
-  let rec get_pattern_id pat = 
-    match pat with 
+
+let raw_get_pattern_id pat acc =
+  let rec get_pattern_id pat =
+    match pat with
       | PatVar(loc,Anonymous) -> assert false
-      | PatVar(loc,Name id) -> 
+      | PatVar(loc,Name id) ->
 	  [id]
-      | PatCstr(loc,constr,patternl,_) -> 
-	  List.fold_right 
-	  (fun pat idl -> 
-	     let idl' = get_pattern_id pat in 
+      | PatCstr(loc,constr,patternl,_) ->
+	  List.fold_right
+	  (fun pat idl ->
+	     let idl' = get_pattern_id pat in
 	     idl'@idl
 	  )
-	    patternl 
+	    patternl
 	    []
   in
   (get_pattern_id pat)@acc
 
 let get_pattern_id pat = raw_get_pattern_id pat []
-	      
-let rec alpha_rt excluded rt = 
-  let new_rt = 
-    match rt with   
+
+let rec alpha_rt excluded rt =
+  let new_rt =
+    match rt with
       | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
-      | RLambda(loc,Anonymous,k,t,b) -> 
-	  let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in 
-	  let new_excluded = new_id :: excluded in 
-	  let new_t = alpha_rt new_excluded t in 
-	  let new_b = alpha_rt new_excluded b in 
+      | RLambda(loc,Anonymous,k,t,b) ->
+	  let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in
+	  let new_excluded = new_id :: excluded in
+	  let new_t = alpha_rt new_excluded t in
+	  let new_b = alpha_rt new_excluded b in
 	  RLambda(loc,Name new_id,k,new_t,new_b)
-      | RProd(loc,Anonymous,k,t,b) -> 
-	let new_t = alpha_rt excluded t in 
-	let new_b = alpha_rt excluded b in 
+      | RProd(loc,Anonymous,k,t,b) ->
+	let new_t = alpha_rt excluded t in
+	let new_b = alpha_rt excluded b in
 	RProd(loc,Anonymous,k,new_t,new_b)
-    | RLetIn(loc,Anonymous,t,b) -> 
-	let new_t = alpha_rt excluded t in 
-	let new_b = alpha_rt excluded b in 
+    | RLetIn(loc,Anonymous,t,b) ->
+	let new_t = alpha_rt excluded t in
+	let new_b = alpha_rt excluded b in
 	RLetIn(loc,Anonymous,new_t,new_b)
-    | RLambda(loc,Name id,k,t,b) -> 
-	let new_id = Nameops.next_ident_away id excluded in 
-	let t,b = 
-	  if new_id = id 
+    | RLambda(loc,Name id,k,t,b) ->
+	let new_id = Namegen.next_ident_away id excluded in
+	let t,b =
+	  if new_id = id
 	  then t,b
-	  else 
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
+	  else
+	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
 	    (t,replace b)
 	in
-	let new_excluded = new_id::excluded in 
-	let new_t = alpha_rt new_excluded t in 
-	let new_b = alpha_rt new_excluded b in 
+	let new_excluded = new_id::excluded in
+	let new_t = alpha_rt new_excluded t in
+	let new_b = alpha_rt new_excluded b in
 	RLambda(loc,Name new_id,k,new_t,new_b)
-    | RProd(loc,Name id,k,t,b) -> 
-	let new_id = Nameops.next_ident_away id excluded in 
-	let new_excluded = new_id::excluded in 
-	let t,b = 
-	  if new_id = id 
+    | RProd(loc,Name id,k,t,b) ->
+	let new_id = Namegen.next_ident_away id excluded in
+	let new_excluded = new_id::excluded in
+	let t,b =
+	  if new_id = id
 	  then t,b
-	  else 
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
+	  else
+	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
 	    (t,replace b)
 	in
-	let new_t = alpha_rt new_excluded t in 
-	let new_b = alpha_rt new_excluded b in 
+	let new_t = alpha_rt new_excluded t in
+	let new_b = alpha_rt new_excluded b in
 	RProd(loc,Name new_id,k,new_t,new_b)
-    | RLetIn(loc,Name id,t,b) -> 
-	let new_id = Nameops.next_ident_away id excluded in 
-	let t,b = 
-	  if new_id = id 
+    | RLetIn(loc,Name id,t,b) ->
+	let new_id = Namegen.next_ident_away id excluded in
+	let t,b =
+	  if new_id = id
 	  then t,b
-	  else 
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
+	  else
+	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
 	    (t,replace b)
 	in
-	let new_excluded = new_id::excluded in 
-	let new_t = alpha_rt new_excluded t in 
-	let new_b = alpha_rt new_excluded b in 
+	let new_excluded = new_id::excluded in
+	let new_t = alpha_rt new_excluded t in
+	let new_b = alpha_rt new_excluded b in
 	RLetIn(loc,Name new_id,new_t,new_b)
 
 
-    | RLetTuple(loc,nal,(na,rto),t,b) -> 
-	let rev_new_nal,new_excluded,mapping = 
-	  List.fold_left 
-	    (fun (nal,excluded,mapping) na -> 
-	       match na with 
+    | RLetTuple(loc,nal,(na,rto),t,b) ->
+	let rev_new_nal,new_excluded,mapping =
+	  List.fold_left
+	    (fun (nal,excluded,mapping) na ->
+	       match na with
 		 | Anonymous -> (na::nal,excluded,mapping)
-		 | Name id ->  
-		     let new_id = Nameops.next_ident_away id excluded in 
-		     if new_id = id 
-		     then 
-		       na::nal,id::excluded,mapping 
-		     else 
+		 | Name id ->
+		     let new_id = Namegen.next_ident_away id excluded in
+		     if new_id = id
+		     then
+		       na::nal,id::excluded,mapping
+		     else
 		       (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
 	    )
 	    ([],excluded,Idmap.empty)
 	    nal
 	in
-	let new_nal = List.rev rev_new_nal in 
-	let new_rto,new_t,new_b = 
+	let new_nal = List.rev rev_new_nal in
+	let new_rto,new_t,new_b =
 	  if idmap_is_empty mapping
 	  then rto,t,b
-	  else let replace = change_vars mapping in 
+	  else let replace = change_vars mapping in
 	  (Option.map replace rto, t,replace b)
 	in
-	let new_t = alpha_rt new_excluded new_t in 
-	let new_b = alpha_rt new_excluded new_b in 
+	let new_t = alpha_rt new_excluded new_t in
+	let new_b = alpha_rt new_excluded new_b in
 	let new_rto = Option.map (alpha_rt new_excluded) new_rto  in
 	RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
-    | RCases(loc,sty,infos,el,brl) -> 
-	let new_el = 
-	  List.map (function (rt,i) -> alpha_rt excluded rt, i) el 
-	in 
-	RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) 
-    | RIf(loc,b,(na,e_o),lhs,rhs) -> 
+    | RCases(loc,sty,infos,el,brl) ->
+	let new_el =
+	  List.map (function (rt,i) -> alpha_rt excluded rt, i) el
+	in
+	RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
+    | RIf(loc,b,(na,e_o),lhs,rhs) ->
 	RIf(loc,alpha_rt excluded b,
 	    (na,Option.map (alpha_rt excluded) e_o),
 	    alpha_rt excluded lhs,
 	    alpha_rt excluded rhs
 	   )
     | RRec _ -> error "Not handled RRec"
-    | RSort _ -> rt 
-    | RHole _ -> rt 
-    | RCast (loc,b,CastConv (k,t)) -> 
+    | RSort _ -> rt
+    | RHole _ -> rt
+    | RCast (loc,b,CastConv (k,t)) ->
 	RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
-    | RCast (loc,b,CastCoerce) -> 
+    | RCast (loc,b,CastCoerce) ->
 	RCast(loc,alpha_rt excluded b,CastCoerce)
     | RDynamic _ -> error "Not handled RDynamic"
-    | RApp(loc,f,args) -> 
+    | RApp(loc,f,args) ->
 	RApp(loc,
 	     alpha_rt excluded f,
 	     List.map (alpha_rt excluded) args
 	    )
-  in 
+  in
   new_rt
 
-and alpha_br excluded (loc,ids,patl,res) = 
-  let new_patl,new_excluded,mapping = alpha_patl excluded patl in 
-  let new_ids = List.fold_right raw_get_pattern_id new_patl [] in 
-  let new_excluded = new_ids@excluded in 
-  let renamed_res = change_vars mapping res in 
-  let new_res = alpha_rt new_excluded renamed_res in 
+and alpha_br excluded (loc,ids,patl,res) =
+  let new_patl,new_excluded,mapping = alpha_patl excluded patl in
+  let new_ids = List.fold_right raw_get_pattern_id new_patl [] in
+  let new_excluded = new_ids@excluded in
+  let renamed_res = change_vars mapping res in
+  let new_res = alpha_rt new_excluded renamed_res in
   (loc,new_ids,new_patl,new_res)
-    
-(* 
+
+(*
    [is_free_in id rt] checks if [id] is a free variable in [rt]
 *)
 let is_free_in id =
@@ -401,12 +401,12 @@ let is_free_in id =
     | RCases(_,_,_,el,brl) ->
 	(List.exists (fun (e,_) -> is_free_in e) el) ||
 	  List.exists is_free_in_br brl
-    | RLetTuple(_,nal,_,b,t) -> 
-	let check_in_nal = 
-	  not (List.exists (function Name id' -> id'= id | _ -> false) nal) 
-	in 
+    | RLetTuple(_,nal,_,b,t) ->
+	let check_in_nal =
+	  not (List.exists (function Name id' -> id'= id | _ -> false) nal)
+	in
 	is_free_in t  || (check_in_nal && is_free_in b)
-	  
+
     | RIf(_,cond,_,br1,br2) ->
 	is_free_in cond || is_free_in br1 || is_free_in br2
     | RRec _ -> raise (UserError("",str "Not handled RRec"))
@@ -419,7 +419,7 @@ let is_free_in id =
     (not (List.mem id ids)) && is_free_in rt
   in
   is_free_in
-      
+
 
 
 let rec pattern_to_term  = function
@@ -446,23 +446,23 @@ let rec pattern_to_term  = function
 	     implicit_args@patl_as_term
 	    )
 
-  
 
-let replace_var_by_term x_id term = 
-  let rec replace_var_by_pattern rt = 
-    match rt with 
-      | RRef _ -> rt 
+
+let replace_var_by_term x_id term =
+  let rec replace_var_by_pattern rt =
+    match rt with
+      | RRef _ -> rt
       | RVar(_,id) when id_ord id x_id == 0 -> term
-      | RVar _ -> rt 
-      | REvar _ -> rt 
-      | RPatVar _ -> rt 
-      | RApp(loc,rt',rtl) -> 
+      | RVar _ -> rt
+      | REvar _ -> rt
+      | RPatVar _ -> rt
+      | RApp(loc,rt',rtl) ->
 	  RApp(loc,
 	       replace_var_by_pattern rt',
 	       List.map replace_var_by_pattern rtl
 	      )
       | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
-      | RLambda(loc,name,k,t,b) -> 
+      | RLambda(loc,name,k,t,b) ->
 	  RLambda(loc,
 		  name,
 		  k,
@@ -470,7 +470,7 @@ let replace_var_by_term x_id term =
 		  replace_var_by_pattern b
 		 )
       | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
-      | RProd(loc,name,k,t,b) -> 
+      | RProd(loc,name,k,t,b) ->
 	  RProd(loc,
 		  name,
 	          k,
@@ -478,94 +478,94 @@ let replace_var_by_term x_id term =
 		  replace_var_by_pattern b
 		 )
       | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
-      | RLetIn(loc,name,def,b) -> 
+      | RLetIn(loc,name,def,b) ->
 	  RLetIn(loc,
 		 name,
 		 replace_var_by_pattern def,
 		 replace_var_by_pattern b
 		)
-      | RLetTuple(_,nal,_,_,_) 
-	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->  
+      | RLetTuple(_,nal,_,_,_)
+	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->
 	  rt
-      | RLetTuple(loc,nal,(na,rto),def,b) -> 
+      | RLetTuple(loc,nal,(na,rto),def,b) ->
 	  RLetTuple(loc,
 		    nal,
 		    (na,Option.map replace_var_by_pattern rto),
 		    replace_var_by_pattern def,
 		    replace_var_by_pattern b
 		   )
-      | RCases(loc,sty,infos,el,brl) -> 
+      | RCases(loc,sty,infos,el,brl) ->
 	  RCases(loc,sty,
 		 infos,
-		 List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, 
+		 List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el,
 		 List.map replace_var_by_pattern_br brl
 		)
-      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
+      | RIf(loc,b,(na,e_option),lhs,rhs) ->
 	  RIf(loc, replace_var_by_pattern b,
 	      (na,Option.map replace_var_by_pattern e_option),
 	      replace_var_by_pattern lhs,
 	      replace_var_by_pattern rhs
 	     )
       | RRec _ -> raise (UserError("",str "Not handled RRec"))
-      | RSort _ -> rt 
-      | RHole _ -> rt 
-      | RCast(loc,b,CastConv(k,t)) -> 
+      | RSort _ -> rt
+      | RHole _ -> rt
+      | RCast(loc,b,CastConv(k,t)) ->
 	  RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
-      | RCast(loc,b,CastCoerce) -> 
+      | RCast(loc,b,CastCoerce) ->
 	  RCast(loc,replace_var_by_pattern b,CastCoerce)
       | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
-  and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = 
-    if List.exists (fun id -> id_ord id x_id == 0) idl 
-    then br 
+  and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
+    if List.exists (fun id -> id_ord id x_id == 0) idl
+    then br
     else (loc,idl,patl,replace_var_by_pattern res)
   in
-  replace_var_by_pattern 
+  replace_var_by_pattern
 
 
 
 
-(* checking unifiability of patterns *) 
-exception NotUnifiable  
+(* checking unifiability of patterns *)
+exception NotUnifiable
 
-let rec are_unifiable_aux  = function 
-  | [] -> () 
-  | eq::eqs -> 
-      match eq with 
-	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs 
-	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> 
-	     if constructor2 <> constructor1 
+let rec are_unifiable_aux  = function
+  | [] -> ()
+  | eq::eqs ->
+      match eq with
+	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
+	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+	     if constructor2 <> constructor1
 	     then raise NotUnifiable
-	     else 
-	       let eqs' = 
+	     else
+	       let eqs' =
  		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with _ -> anomaly "are_unifiable_aux" 
+		 with _ -> anomaly "are_unifiable_aux"
 	       in
 	       are_unifiable_aux eqs'
-		 
-let are_unifiable pat1 pat2 = 
-  try 
+
+let are_unifiable pat1 pat2 =
+  try
     are_unifiable_aux [pat1,pat2];
     true
   with NotUnifiable -> false
 
 
-let rec eq_cases_pattern_aux  = function 
-  | [] -> () 
-  | eq::eqs -> 
-      match eq with 
-	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs 
-	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> 
-	     if constructor2 <> constructor1 
+let rec eq_cases_pattern_aux  = function
+  | [] -> ()
+  | eq::eqs ->
+      match eq with
+	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
+	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+	     if constructor2 <> constructor1
 	     then raise NotUnifiable
-	     else 
-	       let eqs' = 
+	     else
+	       let eqs' =
  		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with _ -> anomaly "eq_cases_pattern_aux" 
+		 with _ -> anomaly "eq_cases_pattern_aux"
 	       in
 	       eq_cases_pattern_aux eqs'
 	 | _ -> raise NotUnifiable
 
-let eq_cases_pattern pat1 pat2 = 
+let eq_cases_pattern pat1 pat2 =
   try
     eq_cases_pattern_aux [pat1,pat2];
     true
@@ -573,25 +573,25 @@ let eq_cases_pattern pat1 pat2 =
 
 
 
-let ids_of_pat = 
-  let rec ids_of_pat ids = function 
-    | PatVar(_,Anonymous) -> ids 
-    | PatVar(_,Name id) -> Idset.add id ids 
+let ids_of_pat =
+  let rec ids_of_pat ids = function
+    | PatVar(_,Anonymous) -> ids
+    | PatVar(_,Name id) -> Idset.add id ids
     | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
   in
-  ids_of_pat Idset.empty 
-  
-let id_of_name = function 
-  | Names.Anonymous -> id_of_string "x" 
+  ids_of_pat Idset.empty
+
+let id_of_name = function
+  | Names.Anonymous -> id_of_string "x"
   | Names.Name x -> x
 
 (* TODO: finish Rec caes *)
-let ids_of_rawterm c = 
-  let rec ids_of_rawterm acc c = 
+let ids_of_rawterm c =
+  let rec ids_of_rawterm acc c =
     let idof = id_of_name in
     match c with
       | RVar (_,id) -> id::acc
-      | RApp (loc,g,args) -> 
+      | RApp (loc,g,args) ->
           ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
       | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
       | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
@@ -599,101 +599,101 @@ let ids_of_rawterm c =
       | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
       | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc
       | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
-      | RLetTuple (_,nal,(na,po),b,c) -> 
+      | RLetTuple (_,nal,(na,po),b,c) ->
           List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
-      | RCases (loc,sty,rtntypopt,tml,brchl) -> 
+      | RCases (loc,sty,rtntypopt,tml,brchl) ->
 	  List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl)
       | RRec _ -> failwith "Fix inside a constructor branch"
       | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> []
   in
   (* build the set *)
   List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
-  
 
 
 
 
-let zeta_normalize = 
-  let rec zeta_normalize_term rt = 
-    match rt with 
-      | RRef _ -> rt 
-      | RVar _ -> rt 
-      | REvar _ -> rt 
-      | RPatVar _ -> rt 
-      | RApp(loc,rt',rtl) -> 
+
+let zeta_normalize =
+  let rec zeta_normalize_term rt =
+    match rt with
+      | RRef _ -> rt
+      | RVar _ -> rt
+      | REvar _ -> rt
+      | RPatVar _ -> rt
+      | RApp(loc,rt',rtl) ->
 	  RApp(loc,
 	       zeta_normalize_term rt',
 	       List.map zeta_normalize_term rtl
 	      )
-      | RLambda(loc,name,k,t,b) -> 
+      | RLambda(loc,name,k,t,b) ->
 	  RLambda(loc,
 		  name,
 		  k,
 		  zeta_normalize_term t,
 		  zeta_normalize_term b
 		 )
-      | RProd(loc,name,k,t,b) -> 
+      | RProd(loc,name,k,t,b) ->
 	  RProd(loc,
-		name, 		
+		name,
 	        k,
 		zeta_normalize_term t,
 		zeta_normalize_term b
 		 )
-      | RLetIn(_,Name id,def,b) -> 
+      | RLetIn(_,Name id,def,b) ->
 	  zeta_normalize_term (replace_var_by_term id def b)
       | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
-      | RLetTuple(loc,nal,(na,rto),def,b) -> 
+      | RLetTuple(loc,nal,(na,rto),def,b) ->
 	  RLetTuple(loc,
 		    nal,
 		    (na,Option.map zeta_normalize_term rto),
 		    zeta_normalize_term def,
 		    zeta_normalize_term b
 		   )
-      | RCases(loc,sty,infos,el,brl) -> 
+      | RCases(loc,sty,infos,el,brl) ->
 	  RCases(loc,sty,
 		 infos,
-		 List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, 
+		 List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
 		 List.map zeta_normalize_br brl
 		)
-      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
+      | RIf(loc,b,(na,e_option),lhs,rhs) ->
 	  RIf(loc, zeta_normalize_term b,
 	      (na,Option.map zeta_normalize_term e_option),
 	      zeta_normalize_term lhs,
 	      zeta_normalize_term rhs
 	     )
       | RRec _ -> raise (UserError("",str "Not handled RRec"))
-      | RSort _ -> rt 
-      | RHole _ -> rt 
-      | RCast(loc,b,CastConv(k,t)) -> 
+      | RSort _ -> rt
+      | RHole _ -> rt
+      | RCast(loc,b,CastConv(k,t)) ->
 	  RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
-      | RCast(loc,b,CastCoerce) -> 
+      | RCast(loc,b,CastCoerce) ->
 	  RCast(loc,zeta_normalize_term b,CastCoerce)
       | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
-  and zeta_normalize_br (loc,idl,patl,res) = 
+  and zeta_normalize_br (loc,idl,patl,res) =
     (loc,idl,patl,zeta_normalize_term res)
   in
-  zeta_normalize_term 
+  zeta_normalize_term
 
 
 
 
-let expand_as = 
-  
-  let rec add_as map pat = 
-    match pat with 
-      | PatVar _ -> map 
-      | PatCstr(_,_,patl,Name id) -> 
+let expand_as =
+
+  let rec add_as map pat =
+    match pat with
+      | PatVar _ -> map
+      | PatCstr(_,_,patl,Name id) ->
 	  Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
       | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
-  in 
-  let rec expand_as map rt = 
-    match rt with 
-      | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt 
-      | RVar(_,id) -> 
+  in
+  let rec expand_as map rt =
+    match rt with
+      | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt
+      | RVar(_,id) ->
 	  begin
-	    try 
+	    try
 	      Idmap.find id map
-	    with Not_found -> rt 
+	    with Not_found -> rt
 	  end
       | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
       | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b)
@@ -712,7 +712,7 @@ let expand_as =
       | RCases(loc,sty,po,el,brl) ->
 	  RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
 		List.map (expand_as_br map) brl)
-  and expand_as_br map (loc,idl,cpl,rt) = 
+  and expand_as_br map (loc,idl,cpl,rt) =
     (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
   in
-  expand_as Idmap.empty 
+  expand_as Idmap.empty
diff --git a/contrib/funind/rawtermops.mli b/plugins/funind/rawtermops.mli
index 358c6ba6..455e7c89 100644
--- a/contrib/funind/rawtermops.mli
+++ b/plugins/funind/rawtermops.mli
@@ -7,12 +7,12 @@ val idmap_is_empty : 'a Names.Idmap.t -> bool
 (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
 val get_pattern_id : cases_pattern -> Names.identifier list
 
-(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. 
-   [pat] must not contain occurences of anonymous pattern 
+(* [pattern_to_term pat] returns a rawconstr corresponding to [pat].
+   [pat] must not contain occurences of anonymous pattern
 *)
-val pattern_to_term : cases_pattern -> rawconstr 
+val pattern_to_term : cases_pattern -> rawconstr
 
-(* 
+(*
    Some basic functions to rebuild rawconstr
    In each of them the location is Util.dummy_loc
 *)
@@ -23,35 +23,35 @@ val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr
 val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr
 val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr
 val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr
-val mkRSort : rawsort -> rawconstr 
+val mkRSort : rawsort -> rawconstr
 val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
-val mkRCast : rawconstr* rawconstr -> rawconstr 
+val mkRCast : rawconstr* rawconstr -> rawconstr
 (*
   Some basic functions to decompose rawconstrs
   These are analogous to the ones constrs
 *)
 val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr
-val raw_decompose_prod_or_letin : 
+val raw_decompose_prod_or_letin :
   rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr
 val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr
-val raw_decompose_prod_or_letin_n : int -> rawconstr -> 
+val raw_decompose_prod_or_letin_n : int -> rawconstr ->
   (Names.name*rawconstr option*rawconstr option) list * rawconstr
-val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list  ->  rawconstr 
-val raw_compose_prod_or_letin: rawconstr -> 
+val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list  ->  rawconstr
+val raw_compose_prod_or_letin: rawconstr ->
   (Names.name*rawconstr option*rawconstr option) list  ->  rawconstr
 val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list)
 
 
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) 
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
 val  raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) 
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
 val  raw_make_neq : rawconstr -> rawconstr -> rawconstr
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) 
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
 val  raw_make_or : rawconstr -> rawconstr -> rawconstr
 
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding 
-   to [P1 \/ ( .... \/ Pn)] 
-*) 
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+   to [P1 \/ ( .... \/ Pn)]
+*)
 val  raw_make_or_list : rawconstr list -> rawconstr
 
 
@@ -64,8 +64,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr
 
 
 
-(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. 
-   the result does not share variables with [avoid]. This function create 
+(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t.
+   the result does not share variables with [avoid]. This function create
    a fresh variable for each occurence of the anonymous pattern.
 
    Also returns a mapping  from old variables to new ones and the concatenation of
@@ -77,8 +77,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr
     Rawterm.cases_pattern * Names.Idmap.key list *
       Names.identifier Names.Idmap.t
 
-(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt 
-   conventions and  does not share bound variables with avoid 
+(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt
+   conventions and  does not share bound variables with avoid
 *)
 val alpha_rt : Names.identifier list -> rawconstr -> rawconstr
 
@@ -90,35 +90,35 @@ val alpha_br : Names.identifier list ->
     Rawterm.rawconstr
 
 
-(* Reduction function *) 
-val replace_var_by_term  :     
+(* Reduction function *)
+val replace_var_by_term  :
   Names.identifier ->
   Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr
 
 
 
-(* 
+(*
    [is_free_in id rt] checks if [id] is a free variable in [rt]
 *)
 val is_free_in : Names.identifier -> rawconstr -> bool
 
 
-val are_unifiable : cases_pattern -> cases_pattern -> bool 
+val are_unifiable : cases_pattern -> cases_pattern -> bool
 val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
 
 
 
-(* 
-   ids_of_pat : cases_pattern -> Idset.t 
-   returns the set of variables appearing in a pattern 
+(*
+   ids_of_pat : cases_pattern -> Idset.t
+   returns the set of variables appearing in a pattern
 *)
-val   ids_of_pat : cases_pattern -> Names.Idset.t 
+val   ids_of_pat : cases_pattern -> Names.Idset.t
 
 (* TODO: finish this function (Fix not treated) *)
 val ids_of_rawterm: rawconstr -> Names.Idset.t
 
-(* 
-   removing let_in construction in a rawterm 
+(*
+   removing let_in construction in a rawterm
 *)
 val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
 
diff --git a/contrib/funind/recdef.ml b/plugins/funind/recdef.ml
index 14bf7cf8..3b0b8628 100644
--- a/contrib/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -8,10 +8,11 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: recdef.ml 12221 2009-07-04 21:53:12Z jforest $ *)
+(* $Id$ *)
 
 open Term
 open Termops
+open Namegen
 open Environ
 open Declarations
 open Entries
@@ -49,36 +50,65 @@ open Eauto
 open Genarg
 
 
-let compute_renamed_type gls c = 
-  rename_bound_var (pf_env gls) [] (pf_type_of gls c)
+let compute_renamed_type gls c =
+  rename_bound_vars_as_displayed [] (pf_type_of gls c)
 
-let qed () = Command.save_named true 
-let defined () = Command.save_named false
+let qed () = Lemmas.save_named true
+let defined () = Lemmas.save_named false
 
-let pf_get_new_ids idl g = 
-  let ids = pf_ids_of_hyps g in 
+let pf_get_new_ids idl g =
+  let ids = pf_ids_of_hyps g in
   List.fold_right
-    (fun id acc -> next_global_ident_away false id (acc@ids)::acc)
-    idl 
+    (fun id acc -> next_global_ident_away id (acc@ids)::acc)
+    idl
     []
 
-let pf_get_new_id id g = 
+let pf_get_new_id id g =
   List.hd (pf_get_new_ids [id] g)
 
-let h_intros l = 
+let h_intros l =
   tclMAP h_intro l
 
-let do_observe_tac s tac g =
+let debug_queue = Queue.create ()
+
+
+let rec print_debug_queue e = 
+  let lmsg,goal = Queue.pop debug_queue in 
+  if Queue.is_empty debug_queue 
+  then 
+    msgnl (lmsg ++ (str " raised exception " ++ Cerrors.explain_exn e) ++ str " on goal " ++ goal)
+  else
+    begin
+      print_debug_queue e;
+      msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+    end
+  
+
+let do_observe_tac s tac g = 
+  let goal = Printer.pr_goal (sig_it g) in
+  let lmsg = (str "recdef ") ++ (str s) in 
+  Queue.add (lmsg,goal) debug_queue;
+  try 
+    let v = tac g in 
+    ignore(Queue.pop debug_queue);
+    v
+  with e -> 
+    if not (Queue.is_empty debug_queue)
+    then
+      print_debug_queue e;
+    raise e
+
+(*let do_observe_tac s tac g =
   let goal = begin (Printer.pr_goal (sig_it g)) end in
  try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++
     (str s)++(str " ")++(str "finished")); v
  with e ->
-   msgnl (str "observation "++str s++str " raised exception " ++ 
-	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+   msgnl (str "observation "++str s++str " raised exception " ++
+	    Cerrors.explain_exn e ++ str " on goal " ++ goal );
    raise e;;
+*)
 
-
-let observe_tac s tac g = 
+let observe_tac s tac g =
   if Tacinterp.get_debug () <> Tactic_debug.DebugOff
   then do_observe_tac s tac g
   else tac g
@@ -114,11 +144,11 @@ let message s = if Flags.is_verbose () then msgnl(str s);;
 
 let def_of_const t =
    match (kind_of_term t) with
-    Const sp -> 
+    Const sp ->
       (try (match (Global.lookup_constant sp) with
              {const_body=Some c} -> Declarations.force c
 	     |_ -> assert false)
-       with _ -> 
+       with _ ->
 	 anomaly ("Cannot find definition of constant "^
 		    (string_of_id (id_of_label (con_label sp))))
       )
@@ -135,14 +165,14 @@ let arg_type t =
     | _ -> assert false;;
 
 let evaluable_of_global_reference r =
-  match r with 
+  match r with
       ConstRef sp -> EvalConstRef sp
     | VarRef id -> EvalVarRef id
     | _ -> assert false;;
 
 
-let rank_for_arg_list h = 
-  let predicate a b = 
+let rank_for_arg_list h =
+  let predicate a b =
       try List.for_all2 eq_constr a b with
         Invalid_argument _ -> false in
   let rec rank_aux i = function
@@ -150,11 +180,11 @@ let rank_for_arg_list h =
   | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
   rank_aux 0;;
 
-let rec (find_call_occs : int -> constr -> constr -> 
+let rec (find_call_occs : int -> constr -> constr ->
   (constr list -> constr) * constr list list) =
  fun nb_lam f expr ->
   match (kind_of_term expr) with
-    App (g, args) when g = f -> 
+    App (g, args) when g = f ->
       (fun l -> List.hd l), [Array.to_list args]
   | App (g, args) ->
      let (largs: constr list) = Array.to_list args in
@@ -162,17 +192,17 @@ let rec (find_call_occs : int -> constr -> constr ->
 	 []    -> (fun x -> []), []
        | a::upper_tl ->
          (match find_aux upper_tl with
-          (cf, ((arg1::args) as args_for_upper_tl)) -> 
+          (cf, ((arg1::args) as args_for_upper_tl)) ->
            (match find_call_occs nb_lam f a with
              cf2, (_ :: _ as other_args) ->
                let rec avoid_duplicates args =
                   match args with
                   | [] -> (fun _ -> []), []
-                  | h::tl -> 
+                  | h::tl ->
                       let recomb_tl, args_for_tl =
                           avoid_duplicates tl in
                     match rank_for_arg_list h args_for_upper_tl with
-                    | None -> 
+                    | None ->
                         (fun l -> List.hd l::recomb_tl(List.tl l)),
                         h::args_for_tl
                     | Some i ->
@@ -182,7 +212,7 @@ let rec (find_call_occs : int -> constr -> constr ->
                in
                let recombine, other_args' =
                    avoid_duplicates other_args in
-	       let len1 = List.length other_args' in                   
+	       let len1 = List.length other_args' in
                    (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
                      other_args'@args_for_upper_tl
            | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
@@ -203,22 +233,22 @@ let rec (find_call_occs : int -> constr -> constr ->
   | Sort(_)  -> (fun l -> expr), []
   | Cast(b,_,_) -> find_call_occs nb_lam f b
   | Prod(_,_,_) -> error "find_call_occs : Prod"
-  | Lambda(na,t,b) -> 
+  | Lambda(na,t,b) ->
       begin
-	match find_call_occs (succ nb_lam) f b with 
-	  | _, [] ->  (* Lambda are authorized as long as they do not contain 
+	match find_call_occs (succ nb_lam) f b with
+	  | _, [] ->  (* Lambda are authorized as long as they do not contain
 			 recursives calls *)
 	      (fun l -> expr),[]
 	  | _ ->  error "find_call_occs : Lambda"
       end
-  | LetIn(na,v,t,b) -> 
+  | LetIn(na,v,t,b) ->
       begin
-	match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with 
-	  | (_,[]),(_,[]) -> 
+	match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with
+	  | (_,[]),(_,[]) ->
 	      ((fun l -> expr), [])
-	  | (_,[]),(cf,(_::_ as l)) -> 
+	  | (_,[]),(cf,(_::_ as l)) ->
 	      ((fun  l -> mkLetIn(na,v,t,cf l)),l)
-	  | (cf,(_::_ as l)),(_,[]) -> 
+	  | (cf,(_::_ as l)),(_,[]) ->
 	      ((fun l -> mkLetIn(na,cf l,t,b)), l)
 	  | _ -> error "find_call_occs : LetIn"
       end
@@ -233,40 +263,44 @@ let rec (find_call_occs : int -> constr -> constr ->
   | CoFix(_) -> error "find_call_occs : CoFix";;
 
 let coq_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition" 
+  Coqlib.gen_constant_in_modules "RecursiveDefinition"
     (Coqlib.init_modules @ Coqlib.arith_modules) s;;
 
+let coq_base_constant s =
+  Coqlib.gen_constant_in_modules "RecursiveDefinition"
+    (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;;
+
 let constant sl s =
   constr_of_global
-    (locate (make_qualid(Names.make_dirpath 
+    (locate (make_qualid(Names.make_dirpath
 			   (List.map id_of_string (List.rev sl)))
 	       (id_of_string s)));;
 
 let find_reference sl s =
-    (locate (make_qualid(Names.make_dirpath 
+    (locate (make_qualid(Names.make_dirpath
 			   (List.map id_of_string (List.rev sl)))
 	       (id_of_string s)));;
 
 let delayed_force f = f ()
 
 let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
-let le_lt_n_Sm = function () -> (coq_constant "le_lt_n_Sm")
-
-let le_trans = function () -> (coq_constant "le_trans")
-let le_lt_trans = function () -> (coq_constant "le_lt_trans")
-let lt_S_n = function () -> (coq_constant "lt_S_n")
-let le_n = function () -> (coq_constant "le_n")
-let refl_equal = function () -> (coq_constant "refl_equal")
-let eq = function () -> (coq_constant "eq")
-let ex = function () -> (coq_constant "ex")
+let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm")
+
+let le_trans = function () -> (coq_base_constant "le_trans")
+let le_lt_trans = function () -> (coq_base_constant "le_lt_trans")
+let lt_S_n = function () -> (coq_base_constant "lt_S_n")
+let le_n = function () -> (coq_base_constant "le_n")
+let refl_equal = function () -> (coq_base_constant "eq_refl")
+let eq = function () -> (coq_base_constant "eq")
+let ex = function () -> (coq_base_constant "ex")
 let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
-let coq_sig = function () -> (coq_constant "sig")
-let coq_O = function () -> (coq_constant "O")
-let coq_S = function () -> (coq_constant "S")
+let coq_sig = function () -> (coq_base_constant "sig")
+let coq_O = function () -> (coq_base_constant "O")
+let coq_S = function () -> (coq_base_constant "S")
 
 let gt_antirefl = function () -> (coq_constant "gt_irrefl")
-let lt_n_O = function () -> (coq_constant "lt_n_O")
-let lt_n_Sn = function () -> (coq_constant "lt_n_Sn")
+let lt_n_O = function () -> (coq_base_constant "lt_n_O")
+let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn")
 
 let f_equal = function () -> (coq_constant "f_equal")
 let well_founded_induction = function () -> (coq_constant "well_founded_induction")
@@ -284,8 +318,8 @@ let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
 
 (* These are specific to experiments in nat with lt as well_founded_relation, *)
 (*    but this should be made more general. *)
-let nat = function () -> (coq_constant "nat")
-let lt = function () -> (coq_constant "lt")
+let nat = function () -> (coq_base_constant "nat")
+let lt = function () -> (coq_base_constant "lt")
 
 (* This is simply an implementation of the case_eq tactic.  this code
   should be replaced with the tactic defined in Ltac in Init/Tactics.v *)
@@ -295,7 +329,7 @@ let  mkCaseEq a  : tactic =
        tclTHENLIST
          [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
           (fun g2 ->
-	    change_in_concl None 
+	    change_in_concl None
 	     (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2))
 		  g2);
 	  simplest_case a] g);;
@@ -308,76 +342,77 @@ let  mkCaseEq a  : tactic =
 let mkDestructEq :
   identifier list -> constr -> goal sigma -> tactic * identifier list =
   fun not_on_hyp expr g ->
-  let hyps = pf_hyps g in 
-  let to_revert = 
-    Util.map_succeed 
-      (fun (id,_,t) -> 
+  let hyps = pf_hyps g in
+  let to_revert =
+    Util.map_succeed
+      (fun (id,_,t) ->
         if List.mem id not_on_hyp || not (Termops.occur_term expr t)
         then failwith "is_expr_context";
         id) hyps in
-  let to_revert_constr = List.rev_map mkVar to_revert in 
+  let to_revert_constr = List.rev_map mkVar to_revert in
   let type_of_expr = pf_type_of g expr in
   let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|])::
            to_revert_constr in
     tclTHENLIST
      [h_generalize new_hyps;
       (fun g2 ->
-	change_in_concl None 
+	change_in_concl None
 	  (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2);
       simplest_case expr], to_revert
 
 let rec  mk_intros_and_continue thin_intros (extra_eqn:bool)
     cont_function (eqs:constr list) nb_lam (expr:constr) g =
+  observe_tac "mk_intros_and_continue" (
   let finalize () =  	if extra_eqn then
 	  let teq = pf_get_new_id teq_id g in
 	    tclTHENLIST
 	      [ h_intro teq;
 		thin thin_intros;
 		h_intros thin_intros;
-		
-		tclMAP 
-		  (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) 
+
+		tclMAP
+		  (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences (* deps proofs also: *) true teq eq false))
 		  (List.rev eqs);
-		(fun g1 -> 
-		   let ty_teq = pf_type_of g1 (mkVar teq) in 
-		   let teq_lhs,teq_rhs = 
-		     let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in 
-		     args.(1),args.(2) 
+		(fun g1 ->
+		   let ty_teq = pf_type_of g1 (mkVar teq) in
+		   let teq_lhs,teq_rhs =
+		     let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in
+		     args.(1),args.(2)
 		   in
 	           cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
 		)
 	      ]
-	      g
+	      
 	else
 	  tclTHENSEQ[
 	    thin thin_intros;
 	    h_intros thin_intros;
-	    cont_function eqs expr 
-	  ] g
+	    cont_function eqs expr
+	  ] 
   in
-  if nb_lam = 0 
-  then finalize () 
+  if nb_lam = 0
+  then finalize ()
   else
     match kind_of_term expr with
-      | Lambda (n, _, b) -> 
-     	  let n1 = 
+      | Lambda (n, _, b) ->
+     	  let n1 =
 	    match n with
       		Name x -> x
               | Anonymous -> ano_id
 	  in
      	  let new_n = pf_get_new_id n1 g in
 	  tclTHEN (h_intro new_n)
-	    (mk_intros_and_continue thin_intros extra_eqn cont_function eqs 
-	       (pred nb_lam) (subst1 (mkVar new_n) b)) g
-      | _ -> 
-	  assert false 
+	    (mk_intros_and_continue thin_intros extra_eqn cont_function eqs
+	       (pred nb_lam) (subst1 (mkVar new_n) b)) 
+      | _ ->
+	  assert false) g
 (* 	  finalize () *)
 let const_of_ref = function
     ConstRef kn -> kn
   | _ -> anomaly "ConstRef expected"
 
 let simpl_iter clause =
-  reduce 
+  reduce
     (Lazy
        {rBeta=true;rIota=true;rZeta= true; rDelta=false;
         rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
@@ -386,16 +421,16 @@ let simpl_iter clause =
 
 (* The boolean value is_mes expresses that the termination is expressed
   using a measure function instead of a well-founded relation. *)
-let tclUSER tac is_mes l g = 
-  let clear_tac = 
-    match l with 
+let tclUSER tac is_mes l g =
+  let clear_tac =
+    match l with
       | None -> h_clear true []
       | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
   in
-  tclTHENSEQ 
+  tclTHENSEQ
     [
       clear_tac;
-      if is_mes 
+      if is_mes
       then tclTHEN
              (unfold_in_concl [(all_occurrences, evaluable_of_global_reference
                                       (delayed_force ltof_ref))])
@@ -403,8 +438,8 @@ let tclUSER tac is_mes l g =
       else tac
     ]
     g
-    
-    
+
+
 let list_rewrite (rev:bool) (eqs: constr list) =
   tclREPEAT
     (List.fold_right
@@ -414,8 +449,8 @@ let list_rewrite (rev:bool) (eqs: constr list) =
 let base_leaf_terminate (func:global_reference) eqs expr =
 (*  let _ = msgnl (str "entering base_leaf") in *)
   (fun g ->
-     let k',h = 
-       match pf_get_new_ids [k_id;h_id] g with 
+     let k',h =
+       match pf_get_new_ids [k_id;h_id] g with
 	   [k';h] -> k',h
 	 | _ -> assert false
      in
@@ -424,9 +459,9 @@ let base_leaf_terminate (func:global_reference) eqs expr =
       observe_tac "second split"
         (split (ImplicitBindings [delayed_force coq_O]));
       observe_tac "intro k" (h_intro k');
-      observe_tac "case on k" 
+      observe_tac "case on k"
         (tclTHENS (simplest_case (mkVar k'))
-        [(tclTHEN (h_intro h) 
+        [(tclTHEN (h_intro h)
           (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl,
 					 [| delayed_force coq_O |])))
             default_auto)); tclIDTAC ]);
@@ -436,86 +471,87 @@ let base_leaf_terminate (func:global_reference) eqs expr =
       list_rewrite true eqs;
       default_auto] g);;
 
-(* La fonction est donnee en premier argument a la 
+(* La fonction est donnee en premier argument a la
    fonctionnelle suivie d'autres Lambdas et de Case ...
-   Pour recuperer la fonction f a partir de la 
+   Pour recuperer la fonction f a partir de la
    fonctionnelle *)
 
-let get_f foncl = 
+let get_f foncl =
   match (kind_of_term (def_of_const foncl)) with
-      Lambda (Name f, _, _) -> f  
+      Lambda (Name f, _, _) -> f
     |_ -> error "la fonctionnelle est mal definie";;
 
 
 let rec compute_le_proofs = function
     [] -> assumption
   | a::tl ->
-      tclORELSE assumption 
+      tclORELSE assumption
 	(tclTHENS
-	   (fun g -> 
-	      let le_trans = delayed_force le_trans in 
-	      let t_le_trans = compute_renamed_type g le_trans in 
-	      let m_id = 
-		let _,_,t = destProd t_le_trans in 
-		let na,_,_ = destProd t in 
+	   (fun g ->
+	      let le_trans = delayed_force le_trans in
+	      let t_le_trans = compute_renamed_type g le_trans in
+	      let m_id =
+		let _,_,t = destProd t_le_trans in
+		let na,_,_ = destProd t in
 		Nameops.out_name na
 	      in
 	      apply_with_bindings
 		(le_trans,
 		 ExplicitBindings[dummy_loc,NamedHyp m_id,a])
 		g)
-	   [compute_le_proofs tl; 
+	   [compute_le_proofs tl;
             tclORELSE (apply (delayed_force le_n)) assumption])
 
 let make_lt_proof pmax le_proof =
   tclTHENS
-    (fun g -> 
-       let le_lt_trans = delayed_force le_lt_trans in 
-       let t_le_lt_trans = compute_renamed_type g le_lt_trans in 
-       let m_id = 
-	 let _,_,t = destProd t_le_lt_trans in 
-	 let na,_,_ = destProd t in 
+    (fun g ->
+       let le_lt_trans = delayed_force le_lt_trans in
+       let t_le_lt_trans = compute_renamed_type g le_lt_trans in
+       let m_id =
+	 let _,_,t = destProd t_le_lt_trans in
+	 let na,_,_ = destProd t in
 	 Nameops.out_name na
        in
        apply_with_bindings
 	 (le_lt_trans,
 	  ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g)
-    [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); 
+    [observe_tac "compute_le_proofs" (compute_le_proofs le_proof);
      tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];;
 
 let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
   match cond_eqs with
     [] -> tclIDTAC
   | eq::eqs ->
-      (fun g -> 
-	 let t_eq = compute_renamed_type g (mkVar eq) in 
-	 let k_id,def_id = 
-	   let k_na,_,t = destProd t_eq in 
-	   let _,_,t  = destProd t in 
-	   let def_na,_,_ = destProd t in 
+      (fun g ->
+	 let t_eq = compute_renamed_type g (mkVar eq) in
+	 let k_id,def_id =
+	   let k_na,_,t = destProd t_eq in
+	   let _,_,t  = destProd t in
+	   let def_na,_,_ = destProd t in
 	   Nameops.out_name k_na,Nameops.out_name def_na
 	 in
 	 tclTHENS
 	   (general_rewrite_bindings false all_occurrences
+	      (* dep proofs also: *) true
 	      (mkVar eq,
 	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
 				dummy_loc, NamedHyp def_id, mkVar def]) false)
 	   [list_cond_rewrite k def pmax eqs le_proofs;
             observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g
-      ) 
+      )
 
-let rec introduce_all_equalities func eqs values specs bound le_proofs 
+let rec introduce_all_equalities func eqs values specs bound le_proofs
     cond_eqs =
   match specs with
-    [] -> 
+    [] ->
       fun g ->
 	let ids = pf_ids_of_hyps g in
 	let s_max = mkApp(delayed_force coq_S, [|bound|]) in
-	let k = next_global_ident_away true k_id ids in
+	let k = next_ident_away_in_goal k_id ids in
         let ids = k::ids in
-	let h' = next_global_ident_away true (h'_id) ids in
+	let h' = next_ident_away_in_goal (h'_id) ids in
         let ids = h'::ids in
-	let def = next_global_ident_away true def_id ids in
+	let def = next_ident_away_in_goal def_id ids in
 	tclTHENLIST
 	  [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max]));
 	   observe_tac "introduce_all_equalities_final intro k" (h_intro  k);
@@ -530,53 +566,53 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
 	   observe_tac "clearing k " (clear [k]);
 	   observe_tac "intros k h' def" (h_intros [k;h';def]);
 	   observe_tac "simple_iter" (simpl_iter onConcl);
-	   observe_tac "unfold functional" 
+	   observe_tac "unfold functional"
 	     (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
-	   observe_tac "rewriting equations" 
+	   observe_tac "rewriting equations"
 	     (list_rewrite true eqs);
            observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite  k def bound cond_eqs le_proofs);
 	   observe_tac "refl equal" (apply (delayed_force refl_equal))] g
   | spec1::specs ->
       fun g ->
 	let ids = ids_of_named_context (pf_hyps g) in
-	let p = next_global_ident_away true p_id ids in
+	let p = next_ident_away_in_goal p_id ids in
         let ids = p::ids in
-	let pmax = next_global_ident_away true pmax_id ids in
+	let pmax = next_ident_away_in_goal pmax_id ids in
         let ids = pmax::ids in
-	let hle1 = next_global_ident_away true hle_id ids in
+	let hle1 = next_ident_away_in_goal hle_id ids in
         let ids = hle1::ids in
-	let hle2 = next_global_ident_away true  hle_id ids in
+	let hle2 = next_ident_away_in_goal  hle_id ids in
 	let ids = hle2::ids in
-	let heq = next_global_ident_away true heq_id ids in
+	let heq = next_ident_away_in_goal heq_id ids in
 	tclTHENLIST
 	  [simplest_elim (mkVar spec1);
 	   list_rewrite true eqs;
 	   h_intros [p; heq];
 	   simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
 	   h_intros [pmax; hle1; hle2];
-	   introduce_all_equalities func eqs values specs 
+	   introduce_all_equalities func eqs values specs
 	     (mkVar pmax) ((mkVar pmax)::le_proofs)
 	     (heq::cond_eqs)] g;;
-    
+
 let string_match s =
   if String.length s < 3 then failwith "string_match";
-  try 
+  try
     for i = 0 to 3  do
       if String.get s i <> String.get "Acc_" i then failwith "string_match"
     done;
   with Invalid_argument _ -> failwith "string_match"
-	  
-let retrieve_acc_var g = 
-  (* Julien: I don't like this version .... *) 
-  let hyps = pf_ids_of_hyps g  in 
-  map_succeed 
+
+let retrieve_acc_var g =
+  (* Julien: I don't like this version .... *)
+  let hyps = pf_ids_of_hyps g  in
+  map_succeed
     (fun id -> string_match (string_of_id id);id)
-    hyps 
+    hyps
 
 let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
     eqs  hrec args values specs =
     (match args with
-    [] -> 
+    [] ->
       tclTHENLIST
 	[observe_tac "split" (split(ImplicitBindings
 		 [context_fn (List.map mkVar (List.rev values))]));
@@ -585,20 +621,20 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
   | arg::args ->
       (fun g ->
 	let ids = ids_of_named_context (pf_hyps g) in
-	let rec_res = next_global_ident_away true rec_res_id ids in
+	let rec_res = next_ident_away_in_goal rec_res_id ids in
         let ids = rec_res::ids in
-	let hspec = next_global_ident_away true hspec_id ids in
-	let tac =  
+	let hspec = next_ident_away_in_goal hspec_id ids in
+	let tac =
 	  observe_tac "introduce_all_values" (
 	    introduce_all_values concl_tac is_mes acc_inv func context_fn eqs
 	      hrec args
 	      (rec_res::values)(hspec::specs)) in
 	(tclTHENS
-	   (observe_tac "elim h_rec" 
+	   (observe_tac "elim h_rec"
 	      (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))
 	   )
 	   [tclTHENLIST [h_intros [rec_res; hspec];
-			 tac]; 
+			 tac];
 	    (tclTHENS
 		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
 		 [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
@@ -607,126 +643,126 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
 		  tclTHENLIST
 		    [
 		      tclTRY(list_rewrite true eqs);
-		      observe_tac "user proof" 
-			(fun g ->  
+		      observe_tac "user proof"
+			(fun g ->
 			   tclUSER
 			     concl_tac
 			     is_mes
 			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
 			     g
-			)		     
+			)
 		    ]
 		 ]
 	    )
 	   ]) g)
-	
+
     )
- 
-	   
+
+
 let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr =
   match find_call_occs 0 f_constr expr with
   | context_fn, args ->
-      observe_tac "introduce_all_values" 
+      observe_tac "introduce_all_values"
 	(introduce_all_values concl_tac is_mes acc_inv func context_fn eqs  hrec args  [] [])
 
-let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)  
-  (f_constr:constr) (func:global_reference) base_leaf rec_leaf = 
+let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)
+  (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
   let rec proveterminate (eqs:constr list) (expr:constr)  =
     try
       (*  let _ = msgnl (str "entering proveterminate") in *)
       let v =
         match (kind_of_term expr) with
-	  Case (ci, t, a, l) -> 
+	  Case (ci, t, a, l) ->
 	  (match find_call_occs 0 f_constr a with
 	    _,[] ->
-	    (fun g -> 
+	    (fun g ->
 	      let destruct_tac, rev_to_thin_intro =
-                mkDestructEq rec_arg_id a g in 
+                mkDestructEq rec_arg_id a g in
 		tclTHENS destruct_tac
-		  (list_map_i 
-		    (fun i -> mk_intros_and_continue 
-				(List.rev rev_to_thin_intro) 
-				true 
-				proveterminate 
+		  (list_map_i
+		    (fun i -> mk_intros_and_continue
+				(List.rev rev_to_thin_intro)
+				true
+				proveterminate
 				eqs
 				ci.ci_cstr_nargs.(i))
 		    0 (Array.to_list l)) g)
-		  | _, _::_ -> 
+		  | _, _::_ ->
 		    (match find_call_occs  0 f_constr expr with
 	     	      _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
-		    | _, _:: _ -> 
-		      observe_tac "rec_leaf" 
+		    | _, _:: _ ->
+		      observe_tac "rec_leaf"
 		      (rec_leaf is_mes acc_inv hrec  func eqs expr)))
 	  | _ ->
             (match find_call_occs  0 f_constr expr with
-	      _,[] -> 
+	      _,[] ->
 	      (try observe_tac "base_leaf" (base_leaf func eqs expr)
 	       with e -> (msgerrnl (str "failure in base case");raise e ))
-	    | _, _::_ -> 
+	    | _, _::_ ->
 	      observe_tac "rec_leaf"
 	        (rec_leaf is_mes acc_inv hrec func eqs expr)) in
       v
     with e -> begin msgerrnl(str "failure in proveterminate"); raise e end
-  in 
-  proveterminate 
-
-let hyp_terminates nb_args func = 
-  let a_arrow_b = arg_type (constr_of_global func) in 
-  let rev_args,b = decompose_prod_n nb_args a_arrow_b in 
-  let left = 
-    mkApp(delayed_force iter, 
-	  Array.of_list 
+  in
+  proveterminate
+
+let hyp_terminates nb_args func =
+  let a_arrow_b = arg_type (constr_of_global func) in
+  let rev_args,b = decompose_prod_n nb_args a_arrow_b in
+  let left =
+    mkApp(delayed_force iter,
+	  Array.of_list
 	    (lift 5 a_arrow_b:: mkRel 3::
 	       constr_of_global func::mkRel 1::
 	       List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
 	    )
 	 )
   in
-  let right = mkRel 5 in 
+  let right = mkRel 5 in
   let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in
   let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
   let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in
   let nb_iter =
     mkApp(delayed_force ex,
 	  [|delayed_force nat;
-	    (mkLambda 
+	    (mkLambda
 	       (Name
 		  p_id,
-		  delayed_force nat, 
-		  (mkProd (Name k_id, delayed_force nat, 
+		  delayed_force nat,
+		  (mkProd (Name k_id, delayed_force nat,
 			   mkArrow cond result))))|])in
-  let value = mkApp(delayed_force coq_sig, 
+  let value = mkApp(delayed_force coq_sig,
 		    [|b;
 		      (mkLambda (Name v_id, b, nb_iter))|]) in
   compose_prod rev_args value
-	     
 
 
-let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = 
-  if is_mes 
+
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
+  if is_mes
   then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof))
   else tclUSER concl_tac is_mes names_to_suppress
 
 let termination_proof_header is_mes input_type ids args_id relation
-    rec_arg_num rec_arg_id tac wf_tac : tactic = 
-  begin 
-    fun g -> 
+    rec_arg_num rec_arg_id tac wf_tac : tactic =
+  begin
+    fun g ->
       let nargs = List.length args_id in
-      let pre_rec_args = 
+      let pre_rec_args =
 	List.rev_map
-	  mkVar (fst (list_chop (rec_arg_num - 1) args_id)) 
-      in 
-      let relation = substl pre_rec_args relation in 
-      let input_type = substl pre_rec_args input_type in 
-      let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in 
-      let wf_rec_arg = 
-	next_global_ident_away true 
+	  mkVar (fst (list_chop (rec_arg_num - 1) args_id))
+      in
+      let relation = substl pre_rec_args relation in
+      let input_type = substl pre_rec_args input_type in
+      let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in
+      let wf_rec_arg =
+	next_ident_away_in_goal
 	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
-	  (wf_thm::ids) 
-      in 
-      let hrec = next_global_ident_away true hrec_id
-	(wf_rec_arg::wf_thm::ids) in 
-      let acc_inv = 
+	  (wf_thm::ids)
+      in
+      let hrec = next_ident_away_in_goal hrec_id
+	(wf_rec_arg::wf_thm::ids) in
+      let acc_inv =
 	  lazy (
 	    mkApp (
 	      delayed_force acc_inv_id,
@@ -737,41 +773,41 @@ let termination_proof_header is_mes input_type ids args_id relation
       tclTHEN
 	(h_intros args_id)
 	(tclTHENS
-	   (observe_tac 
-	      "first assert" 
-	      (assert_tac 
-		 (Name wf_rec_arg) 
+	   (observe_tac
+	      "first assert"
+	      (assert_tac
+		 (Name wf_rec_arg)
 		 (mkApp (delayed_force acc_rel,
 			 [|input_type;relation;mkVar rec_arg_id|])
 		 )
 	      )
 	   )
 	   [
-	     (* accesibility proof *) 
-	     tclTHENS 
-	       (observe_tac 
-		  "second assert" 
-		  (assert_tac 
+	     (* accesibility proof *)
+	     tclTHENS
+	       (observe_tac
+		  "second assert"
+		  (assert_tac
 		     (Name wf_thm)
 		     (mkApp (delayed_force well_founded,[|input_type;relation|]))
 		  )
 	       )
-	       [ 
+	       [
 		 (* interactive proof that the relation is well_founded *)
 		 observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
 		 (* this gives the accessibility argument *)
-		 observe_tac 
-		   "apply wf_thm" 
+		 observe_tac
+		   "apply wf_thm"
 		   (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
 		   )
 	       ]
 	     ;
 	     (* rest of the proof *)
-	     tclTHENSEQ 
-	       [observe_tac "generalize" 
-		  (onNLastHyps (nargs+1)
-		     (fun (id,_,_) -> 
-			tclTHEN (h_generalize [mkVar id]) (h_clear false [id])
+	     tclTHENSEQ
+	       [observe_tac "generalize"
+		  (onNLastHypsId (nargs+1)
+		     (tclMAP (fun id ->
+			tclTHEN (h_generalize [mkVar id]) (h_clear false [id]))
 		     ))
 	       ;
 		observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
@@ -780,38 +816,38 @@ let termination_proof_header is_mes input_type ids args_id relation
 		observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
 	       ]
 	   ]
-	) g  
+	) g
   end
 
 
 
-let rec instantiate_lambda t l = 
+let rec instantiate_lambda t l =
   match l with
   | [] -> t
-  | a::l -> 
+  | a::l ->
       let (bound_name, _, body) = destLambda t in
       instantiate_lambda (subst1 a body) l
 ;;
 
 
-let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num  : tactic = 
-  begin 
-    fun g -> 
+let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num  : tactic =
+  begin
+    fun g ->
       let ids = ids_of_named_context (pf_hyps g) in
       let func_body = (def_of_const (constr_of_global func)) in
       let (f_name, _, body1) = destLambda func_body in
       let f_id =
 	match f_name with
-	  | Name f_id -> next_global_ident_away true f_id ids
+	  | Name f_id -> next_ident_away_in_goal f_id ids
 	  | Anonymous -> anomaly "Anonymous function"
       in
-      let n_names_types,_ = decompose_lam_n nb_args body1 in 
-      let n_ids,ids = 
-	List.fold_left 
-	  (fun (n_ids,ids) (n_name,_) -> 
-	     match n_name with 
-	       | Name id -> 
-		   let n_id = next_global_ident_away true id ids in 
+      let n_names_types,_ = decompose_lam_n nb_args body1 in
+      let n_ids,ids =
+	List.fold_left
+	  (fun (n_ids,ids) (n_name,_) ->
+	     match n_name with
+	       | Name id ->
+		   let n_id = next_ident_away_in_goal id ids in
 		   n_id::n_ids,n_id::ids
 	       | _ -> anomaly "anonymous argument"
 	  )
@@ -819,151 +855,136 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	  n_names_types
       in
       let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
-      let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in 
-      termination_proof_header 
+      let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in
+      termination_proof_header
 	is_mes
 	input_type
 	ids
 	n_ids
-	relation 
+	relation
 	rec_arg_num
 	rec_arg_id
-	(fun rec_arg_id hrec acc_inv g ->  
-           (proveterminate 
+	(fun rec_arg_id hrec acc_inv g ->
+           (proveterminate
 	      [rec_arg_id]
 	      is_mes
-	      acc_inv 
+	      acc_inv
 	      hrec
 	      (mkVar f_id)
 	      func
-	      base_leaf_terminate 
+	      base_leaf_terminate
 	      (rec_leaf_terminate (mkVar f_id) concl_tac)
 	      []
 	      expr
 	   )
-	     g 
+	     g
 	)
 	(tclUSER_if_not_mes concl_tac)
-	g 
+	g
   end
 
-let get_current_subgoals_types () = 
-  let pts =  get_pftreestate () in 
-  let _,subs = extract_open_pftreestate pts in 
+let get_current_subgoals_types () =
+  let pts =  get_pftreestate () in
+  let _,subs = extract_open_pftreestate pts in
   List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs )
 
-let build_and_l l = 
-  let and_constr =  Coqlib.build_coq_and () in 
-  let conj_constr = coq_conj () in 
-  let mk_and p1 p2 = 
-    Term.mkApp(and_constr,[|p1;p2|]) in 
-  let rec f  = function 
-    | [] -> failwith "empty list of subgoals!" 
-    | [p] -> p,tclIDTAC,1 
-    | p1::pl -> 
-	let c,tac,nb = f pl in 
-	mk_and p1 c, 
+let build_and_l l =
+  let and_constr =  Coqlib.build_coq_and () in
+  let conj_constr = coq_conj () in
+  let mk_and p1 p2 =
+    Term.mkApp(and_constr,[|p1;p2|]) in
+  let rec f  = function
+    | [] -> failwith "empty list of subgoals!"
+    | [p] -> p,tclIDTAC,1
+    | p1::pl ->
+	let c,tac,nb = f pl in
+	mk_and p1 c,
 	tclTHENS
-	  (apply (constr_of_global conj_constr)) 
+	  (apply (constr_of_global conj_constr))
 	  [tclIDTAC;
 	   tac
 	  ],nb+1
   in f l
 
 
-let is_rec_res id = 
-  let rec_res_name = string_of_id rec_res_id   in 
-  let id_name = string_of_id id in 
-  try 
-    String.sub id_name 0 (String.length rec_res_name) = rec_res_name 
+let is_rec_res id =
+  let rec_res_name = string_of_id rec_res_id   in
+  let id_name = string_of_id id in
+  try
+    String.sub id_name 0 (String.length rec_res_name) = rec_res_name
   with _ -> false
 
-let clear_goals = 
-  let rec clear_goal t = 
-    match kind_of_term t with 
-      | Prod(Name id as na,t,b) -> 
-	  let b' = clear_goal b in 
-	  if noccurn 1 b' && (is_rec_res id) 
-	  then pop b' 
-	  else if b' == b then t 
-	  else mkProd(na,t,b')
+let clear_goals =
+  let rec clear_goal t =
+    match kind_of_term t with
+      | Prod(Name id as na,t',b) ->
+	  let b' = clear_goal b in
+	  if noccurn 1 b' && (is_rec_res id)
+	  then pop b'
+	  else if b' == b then t
+	  else mkProd(na,t',b')
       | _ -> map_constr clear_goal t
-  in 
-  List.map clear_goal 
+  in
+  List.map clear_goal
 
 
-let build_new_goal_type () = 
-  let sub_gls_types = get_current_subgoals_types () in 
-  let sub_gls_types = clear_goals sub_gls_types in 
-  let res = build_and_l sub_gls_types in 
+let build_new_goal_type () =
+  let sub_gls_types = get_current_subgoals_types () in
+  (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+  let sub_gls_types = clear_goals sub_gls_types in
+  (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+  let res = build_and_l sub_gls_types in
   res
-  
 
-    (*
-let prove_with_tcc lemma _ : tactic = 
-  fun gls ->
-    let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in 
-    tclTHENSEQ 
-      [
-	h_generalize [lemma];
-	h_intro hid;
-	Elim.h_decompose_and (mkVar hid); 
-	gen_eauto(* default_eauto *) false (false,5) [] (Some [])
-	  (* 	      default_auto *)
-      ]
-      gls
-    *)
-      
-	     
-
-let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   = 
+let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
+  (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *)
   let current_proof_name = get_current_proof_name () in
-  let name = match goal_name with 
-    | Some s -> s 
-    | None   ->  
-	try (add_suffix current_proof_name "_subproof") 
+  let name = match goal_name with
+    | Some s -> s
+    | None   ->
+	try (add_suffix current_proof_name "_subproof")
 	with _ -> anomaly "open_new_goal with an unamed theorem"
-  in  
+  in
   let sign = Global.named_context () in
   let sign = clear_proofs sign in
-  let na = next_global_ident_away false name [] in
+  let na = next_global_ident_away name [] in
   if occur_existential gls_type then
     Util.error "\"abstract\" cannot handle existentials";
-  let hook _ _ = 
-    let opacity = 
-      let na_ref = Libnames.Ident (dummy_loc,na) in 
+  let hook _ _ =
+    let opacity =
+      let na_ref = Libnames.Ident (dummy_loc,na) in
       let na_global = Nametab.global na_ref in
-      match na_global with 
-	  ConstRef c -> 
-	    let cb = Global.lookup_constant c in 
-	    if cb.Declarations.const_opaque then true 
-	    else begin  match cb.const_body with None -> true | _ -> false end 
+      match na_global with
+	  ConstRef c ->
+	    let cb = Global.lookup_constant c in
+	    if cb.Declarations.const_opaque then true
+	    else begin  match cb.const_body with None -> true | _ -> false end
 	| _ -> anomaly "equation_lemma: not a constant"
     in
-    let lemma = mkConst (Lib.make_con na) in 
+    let lemma = mkConst (Lib.make_con na) in
     ref_ := Some lemma ;
-    let lid = ref [] in 
-    let h_num = ref (-1) in 
+    let lid = ref [] in
+    let h_num = ref (-1) in
     Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None);
-    build_proof 
+    build_proof
       (  fun gls ->
-	   let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in 
-	   tclTHENSEQ 
+	   let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in
+	   tclTHENSEQ
 	     [
 	       h_generalize [lemma];
 	       h_intro hid;
-	       (fun g -> 
-		  let ids = pf_ids_of_hyps g in 
+	       (fun g ->
+		  let ids = pf_ids_of_hyps g in
 		  tclTHEN
 		    (Elim.h_decompose_and (mkVar hid))
-		    (fun g -> 
-		       let ids' = pf_ids_of_hyps g in 
+		    (fun g ->
+		       let ids' = pf_ids_of_hyps g in
 		       lid := List.rev (list_subtract ids' ids);
 		       if !lid = [] then lid := [hid];
 		       tclIDTAC g
 		    )
 		    g
-	       ); 
+	       );
 	     ] gls)
       (fun g ->
 	 match kind_of_term (pf_concl g) with
@@ -977,7 +998,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 		      tclFIRST[
 			tclTHEN
 			  (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
-			  e_assumption;			  
+			  e_assumption;
 		      Eauto.eauto_with_bases
 			false
 			(true,5)
@@ -986,101 +1007,108 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 		      ]
 		    )
 		  )
-	       ) 
+	       )
       		 g)
 ;
-    Command.save_named opacity;
+    Lemmas.save_named opacity;
   in
   start_proof
     na
-    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) 
+    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
     sign
-    gls_type 
+    gls_type
     hook ;
-  by (
-    fun g -> 
-      tclTHEN 
-	(decompose_and_tac)
-	(tclORELSE 
-	(tclFIRST 
-	   (List.map
-	      (fun c -> 
-		 tclTHENSEQ
-		   [intros; 
-		    h_simplest_apply (interp_constr Evd.empty (Global.env()) c); 
-		    tclCOMPLETE Auto.default_auto
-		   ]
-	      )
-	      using_lemmas)
-	) tclIDTAC)
-	g);
+  if Indfun_common.is_strict_tcc  ()
+  then
+    by (tclIDTAC)
+  else 
+    begin
+      by (
+	fun g ->
+	  tclTHEN
+	    (decompose_and_tac)
+	    (tclORELSE
+	       (tclFIRST
+	 	  (List.map
+	 	     (fun c ->
+	 		tclTHENSEQ
+	 		  [intros;
+	 		   h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
+	 		   tclCOMPLETE Auto.default_auto
+	 		  ]
+	 	     )
+	 	     using_lemmas)
+	       ) tclIDTAC)
+	    g)
+    end;
   try
     by tclIDTAC; (* raises UserError _ if the proof is complete *)
     if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
-  with UserError _ -> 
+  with UserError _ ->
     defined ()
-  
-;;    
+
+;;
 
 
-let com_terminate 
-    tcc_lemma_name 
-    tcc_lemma_ref 
-    is_mes 
+let com_terminate
+    tcc_lemma_name
+    tcc_lemma_ref
+    is_mes
     fonctional_ref
     input_type
-    relation 
+    relation
     rec_arg_num
-    thm_name using_lemmas 
+    thm_name using_lemmas
     nb_args
     hook =
-  let start_proof (tac_start:tactic) (tac_end:tactic) = 
-    let (evmap, env) = Command.get_current_context() in
+  let start_proof (tac_start:tactic) (tac_end:tactic) =
+    let (evmap, env) = Lemmas.get_current_context() in
     start_proof thm_name
       (Global, Proof Lemma) (Environ.named_context_val env)
       (hyp_terminates nb_args fonctional_ref) hook;
+
     by (observe_tac "starting_tac" tac_start);
     by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref
 				   input_type relation rec_arg_num ))
-    
   in
   start_proof tclIDTAC tclIDTAC;
-  try 
-    let new_goal_type = build_new_goal_type () in 
+  try
+    let new_goal_type = build_new_goal_type () in
     open_new_goal start_proof using_lemmas tcc_lemma_ref
       (Some tcc_lemma_name)
-      (new_goal_type)
-  with Failure "empty list of subgoals!" -> 
+      (new_goal_type);
+
+  with Failure "empty list of subgoals!" ->
     (* a non recursive function declared with measure ! *)
     defined ()
-    
 
-    
 
-let ind_of_ref = function 
+
+
+let ind_of_ref = function
   | IndRef (ind,i) -> (ind,i)
   | _ -> anomaly "IndRef expected"
 
 let (value_f:constr list -> global_reference -> constr) =
   fun al fterm ->
-    let d0 = dummy_loc in 
-    let rev_x_id_l =  
+    let d0 = dummy_loc in
+    let rev_x_id_l =
       (
-	List.fold_left 
-	  (fun x_id_l _ -> 
-	     let x_id = next_global_ident_away true x_id x_id_l in 
+	List.fold_left
+	  (fun x_id_l _ ->
+	     let x_id = next_ident_away_in_goal x_id x_id_l in
 	     x_id::x_id_l
 	  )
 	  []
 	  al
       )
     in
-    let fun_body = 
+    let fun_body =
       RCases
 	(d0,RegularStyle,None,
 	 [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l),
 	  (Anonymous,None)],
-	 [d0, [v_id], [PatCstr(d0,(ind_of_ref 
+	 [d0, [v_id], [PatCstr(d0,(ind_of_ref
 				     (delayed_force coq_sig_ref),1),
 			       [PatVar(d0, Name v_id);
 				PatVar(d0, Anonymous)],
@@ -1088,12 +1116,12 @@ let (value_f:constr list -> global_reference -> constr) =
 	  RVar(d0,v_id)])
     in
     let value =
-      List.fold_left2 
-	(fun acc x_id a -> 
+      List.fold_left2
+	(fun acc x_id a ->
 	   RLambda
       	     (d0, Name x_id, Explicit, RDynamic(d0, constr_in a),
 	      acc
-	     ) 
+	     )
 	)
 	fun_body
 	rev_x_id_l
@@ -1115,69 +1143,69 @@ let (declare_f : identifier -> logical_kind -> constr list -> global_reference -
 
 let rec n_x_id ids n =
   if n = 0 then []
-  else let x = next_global_ident_away true x_id ids in
+  else let x = next_ident_away_in_goal x_id ids in
           x::n_x_id (x::ids) (n-1);;
 
-let start_equation (f:global_reference) (term_f:global_reference) 
+let start_equation (f:global_reference) (term_f:global_reference)
   (cont_tactic:identifier list -> tactic) g =
   let ids = pf_ids_of_hyps g in
-  let terminate_constr = constr_of_global term_f in 
-  let nargs = nb_prod (type_of_const terminate_constr) in 
+  let terminate_constr = constr_of_global term_f in
+  let nargs = nb_prod (type_of_const terminate_constr) in
   let x = n_x_id ids nargs in
   tclTHENLIST [
     h_intros x;
     unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)];
-    observe_tac "simplest_case" 
+    observe_tac "simplest_case"
       (simplest_case (mkApp (terminate_constr,
                              Array.of_list (List.map mkVar x))));
     observe_tac "prove_eq" (cont_tactic x)] g;;
 
 let base_leaf_eq func eqs f_id g =
   let ids = pf_ids_of_hyps g in
-  let k = next_global_ident_away true k_id ids in
-  let p = next_global_ident_away true p_id (k::ids) in
-  let v = next_global_ident_away true v_id (p::k::ids) in
-  let heq = next_global_ident_away true heq_id (v::p::k::ids) in
-  let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in
-  let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in
+  let k = next_ident_away_in_goal k_id ids in
+  let p = next_ident_away_in_goal p_id (k::ids) in
+  let v = next_ident_away_in_goal v_id (p::k::ids) in
+  let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in
+  let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in
+  let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in
     tclTHENLIST [
-      h_intros [v; hex]; 
+      h_intros [v; hex];
       simplest_elim (mkVar hex);
       h_intros [p;heq1];
       tclTRY
-	(rewriteRL 
-	   (mkApp(mkVar heq1, 
+	(rewriteRL
+	   (mkApp(mkVar heq1,
 		  [|mkApp (delayed_force coq_S, [|mkVar p|]);
 		    mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
       simpl_iter onConcl;
       tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]);
-      list_rewrite true eqs;
+      observe_tac "list_revrite" (list_rewrite true eqs);
       apply (delayed_force refl_equal)] g;;
 
 let f_S t = mkApp(delayed_force coq_S, [|t|]);;
 
 
-let rec introduce_all_values_eq cont_tac functional termine 
+let rec introduce_all_values_eq cont_tac functional termine
     f p heq1 pmax bounds le_proofs eqs ids =
   function
       [] ->
-       let heq2 = next_global_ident_away true heq_id ids in
+       let heq2 = next_ident_away_in_goal heq_id ids in
 	tclTHENLIST
 	  [pose_proof (Name heq2)
              (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|]));
            simpl_iter (onHyp heq2);
-           unfold_in_hyp [((true,[1]), evaluable_of_global_reference 
+           unfold_in_hyp [((true,[1]), evaluable_of_global_reference
                              (global_of_constr functional))]
-             ((all_occurrences_expr, heq2), InHyp);
+             (heq2, InHyp);
            tclTHENS
-	     (fun gls -> 
-		let t_eq = compute_renamed_type gls (mkVar heq2) in 
-		let def_id = 
-		  let _,_,t  = destProd t_eq in let def_na,_,_ = destProd t in 
+	     (fun gls ->
+		let t_eq = compute_renamed_type gls (mkVar heq2) in
+		let def_id =
+		  let _,_,t  = destProd t_eq in let def_na,_,_ = destProd t in
 		  Nameops.out_name def_na
 		in
 		observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences
-		(mkVar heq2,
+		(* dep proofs also: *) true (mkVar heq2,
 		 ExplicitBindings[dummy_loc,NamedHyp def_id,
 				  f]) false) gls)
 	     [tclTHENLIST
@@ -1186,21 +1214,21 @@ let rec introduce_all_values_eq cont_tac functional termine
 	      tclTHENLIST[apply (delayed_force le_lt_SS);
 			compute_le_proofs le_proofs]]]
     | arg::args ->
-	let v' = next_global_ident_away true v_id ids in
+	let v' = next_ident_away_in_goal v_id ids in
         let ids = v'::ids in
-	let hex' = next_global_ident_away true hex_id ids in
+	let hex' = next_ident_away_in_goal hex_id ids in
         let ids = hex'::ids in
-	let p' = next_global_ident_away true p_id ids in
+	let p' = next_ident_away_in_goal p_id ids in
         let ids = p'::ids in
-	let new_pmax = next_global_ident_away true pmax_id ids in
+	let new_pmax = next_ident_away_in_goal pmax_id ids in
         let ids = pmax::ids in
-	let hle1 = next_global_ident_away true hle_id ids in
+	let hle1 = next_ident_away_in_goal hle_id ids in
         let ids = hle1::ids in
-	let hle2 = next_global_ident_away true hle_id ids in
+	let hle2 = next_ident_away_in_goal hle_id ids in
         let ids = hle2::ids in
-	let heq = next_global_ident_away true heq_id ids in
+	let heq = next_ident_away_in_goal heq_id ids in
         let ids = heq::ids in
-	let heq2 = next_global_ident_away true heq_id ids in
+	let heq2 = next_ident_away_in_goal heq_id ids in
         let ids = heq2::ids in
 	tclTHENLIST
 	  [mkCaseEq(mkApp(termine, Array.of_list arg));
@@ -1210,7 +1238,7 @@ let rec introduce_all_values_eq cont_tac functional termine
 	   simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
 							mkVar p'|]));
 	   h_intros [new_pmax;hle1;hle2];
-           introduce_all_values_eq 
+           introduce_all_values_eq
               (fun pmax' le_proofs'->
 		tclTHENLIST
 		  [cont_tac pmax' le_proofs';
@@ -1218,12 +1246,12 @@ let rec introduce_all_values_eq cont_tac functional termine
 		   observe_tac ("rewriteRL " ^ (string_of_id heq2))
                      (tclTRY (rewriteLR (mkVar heq2)));
 		   tclTRY (tclTHENS
-		     ( fun g -> 
-			 let t_eq = compute_renamed_type g (mkVar heq) in 
-			 let k_id,def_id = 
-			   let k_na,_,t = destProd t_eq in 
-			   let _,_,t  = destProd t in 
-			   let def_na,_,_ = destProd t in 
+		     ( fun g ->
+			 let t_eq = compute_renamed_type g (mkVar heq) in
+			 let k_id,def_id =
+			   let k_na,_,t = destProd t_eq in
+			   let _,_,t  = destProd t in
+			   let def_na,_,_ = destProd t in
 			   Nameops.out_name k_na,Nameops.out_name def_na
 			 in
 			 let c_b = (mkVar heq,
@@ -1232,8 +1260,8 @@ let rec introduce_all_values_eq cont_tac functional termine
 			       f_S(mkVar pmax');
 			       dummy_loc, NamedHyp def_id, f])
 			 in
-			   observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences
-								       c_b false))
+			   observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences (* dep proofs also: *) true
+							       c_b false))
 			     g
 		     )
 		     [tclIDTAC;
@@ -1243,18 +1271,18 @@ let rec introduce_all_values_eq cont_tac functional termine
 	     functional termine f p heq1 new_pmax
 	     (p'::bounds)((mkVar pmax)::le_proofs) eqs
              (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
-  
+
 
 let rec_leaf_eq termine f ids functional eqs expr fn args =
-  let p = next_global_ident_away true p_id ids in
+  let p = next_ident_away_in_goal p_id ids in
   let ids = p::ids in
-  let v = next_global_ident_away true v_id ids in
+  let v = next_ident_away_in_goal v_id ids in
   let ids = v::ids in
-  let hex = next_global_ident_away true hex_id ids in
+  let hex = next_ident_away_in_goal hex_id ids in
   let ids = hex::ids in
-  let heq1 = next_global_ident_away true heq_id ids in
+  let heq1 = next_ident_away_in_goal heq_id ids in
   let ids = heq1::ids in
-  let hle1 = next_global_ident_away true hle_id ids in
+  let hle1 = next_ident_away_in_goal hle_id ids in
   let ids = hle1::ids in
     tclTHENLIST
       [observe_tac "intros v hex" (h_intros [v;hex]);
@@ -1270,36 +1298,36 @@ let rec_leaf_eq termine f ids functional eqs expr fn args =
 let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
     (eqs:constr list) (expr:constr) =
 (*   tclTRY *)
-  (match kind_of_term expr with
+  observe_tac "prove_eq"  (match kind_of_term expr with
      Case(ci,t,a,l) ->
      (match find_call_occs 0 f a with
-	_,[] -> 
-	(fun g -> 
-	  let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in 
+	_,[] ->
+	(fun g ->
+	  let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
 	  tclTHENS
             destruct_tac
-	    (list_map_i  
+	    (list_map_i
 	       (fun i -> mk_intros_and_continue
-                          (List.rev rev_to_thin_intro) true 
-			  (prove_eq termine f functional)  
+                          (List.rev rev_to_thin_intro) true
+			  (prove_eq termine f functional)
 			  eqs ci.ci_cstr_nargs.(i))
 	       0 (Array.to_list l)) g)
 	   | _,_::_ ->
 	      (match find_call_occs 0 f expr with
-		_,[] -> base_leaf_eq functional eqs f
+		_,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f)
 	      | fn,args ->
 	        fun g ->
 		  let ids = ids_of_named_context (pf_hyps g) in
-	          rec_leaf_eq termine f ids
+	          observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids
 		    (constr_of_global functional)
-		    eqs expr fn args g))
-       | _ -> 
+		    eqs expr fn args) g))
+       | _ ->
 	   (match find_call_occs 0 f expr with
-		_,[] -> base_leaf_eq functional eqs f
+		_,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f)
 	      | fn,args ->
 		  fun g ->
 		    let ids = ids_of_named_context (pf_hyps g) in
-		    observe_tac "rec_leaf_eq" (rec_leaf_eq  
+		    observe_tac "rec_leaf_eq" (rec_leaf_eq
 		      termine f ids (constr_of_global functional)
 		      eqs expr fn args) g));;
 
@@ -1307,15 +1335,15 @@ let (com_eqn : identifier ->
        global_reference -> global_reference -> global_reference
 	 -> constr -> unit) =
   fun eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
-    let opacity = 
-      match terminate_ref with 
-	| ConstRef c -> 	      
-	    let cb = Global.lookup_constant c in 
-	    if cb.Declarations.const_opaque then true 
-	    else begin match cb.const_body with None -> true | _ -> false end 
+    let opacity =
+      match terminate_ref with
+	| ConstRef c ->
+	    let cb = Global.lookup_constant c in
+	    if cb.Declarations.const_opaque then true
+	    else begin match cb.const_body with None -> true | _ -> false end
 	| _ -> anomaly "terminate_lemma: not a constant"
-    in 
-    let (evmap, env) = Command.get_current_context() in
+    in
+    let (evmap, env) = Lemmas.get_current_context() in
     let f_constr = (constr_of_global f_ref) in
     let equation_lemma_type = subst1 f_constr equation_lemma_type in
     (start_proof eq_name (Global, Proof Lemma)
@@ -1323,9 +1351,9 @@ let (com_eqn : identifier ->
      by
        (start_equation f_ref terminate_ref
 	  (fun  x ->
-	     prove_eq 
+	     prove_eq
 	       (constr_of_global terminate_ref)
-	       f_constr 
+	       f_constr
 	       functional_ref
 	       []
 	       (instantiate_lambda
@@ -1336,61 +1364,70 @@ let (com_eqn : identifier ->
        );
 (*      (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
 (*      Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
-     Flags.silently (fun () ->Command.save_named opacity) () ;  
+     Flags.silently (fun () -> Lemmas.save_named opacity) () ;
 (*      Pp.msgnl (str "eqn finished"); *)
-    
+
     );;
 
-let nf_zeta env =       
+let nf_zeta env =
   Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
     env
     Evd.empty
 
-let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq 
+let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
+  let clos_norm_flags flgs env sigma t =
+    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
+
+
+let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
     generate_induction_principle using_lemmas : unit =
   let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
   let env = push_named (function_name,None,function_type) (Global.env()) in
 (*   Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)
-  let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in 
-(*   Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *)
-  let res_vars,eq' = decompose_prod equation_lemma_type in 
+  let equation_lemma_type = 
+    nf_betaiotazeta
+      (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) 
+  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 eq' = nf_zeta env_eq' eq'  in 
-  let res = 
+  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'); *)
 (*     Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
 (*     Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
-    match kind_of_term eq' with 
-      | App(e,[|_;_;eq_fix|]) -> 
+    match kind_of_term eq' with
+      | App(e,[|_;_;eq_fix|]) ->
 	  mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars  eq_fix))
       | _ -> failwith "Recursive Definition (res not eq)"
   in
-  let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in 
+  let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in
   let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in
   let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in
   let equation_id = add_suffix function_name "_equation" in
   let functional_id =  add_suffix function_name "_F" in
   let term_id = add_suffix function_name "_terminate" in
   let functional_ref = declare_fun functional_id (IsDefinition Definition) 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 = 
+  let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in  
+  let relation =
     interp_constr
-      Evd.empty 
+      Evd.empty
       env_with_pre_rec_args
       r
-  in 
+  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 (make_short_qualid term_id) 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
 (*     message "start second proof"; *)
-    let stop = ref false in 
-    begin 
+    let stop = ref false in
+    begin
       try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
-      with e -> 
-	begin 
+      with e ->
+	begin
 	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
 	  then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e)
 	  else anomaly "Cannot create equation Lemma"
@@ -1401,21 +1438,21 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
     end;
     if not !stop
     then
-      let eq_ref = Nametab.locate (make_short_qualid equation_id ) in
-      let f_ref = destConst (constr_of_global f_ref) 
-      and functional_ref = destConst (constr_of_global functional_ref) 
+      let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in
+      let f_ref = destConst (constr_of_global f_ref)
+      and functional_ref = destConst (constr_of_global functional_ref)
       and eq_ref = destConst (constr_of_global eq_ref) in
       generate_induction_principle f_ref tcc_lemma_constr
 	functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
       if Flags.is_verbose ()
-      then msgnl (h 1 (Ppconstr.pr_id function_name ++ 
-			 spc () ++ str"is defined" )++ fnl () ++ 
-		    h 1 (Ppconstr.pr_id equation_id ++ 
+      then msgnl (h 1 (Ppconstr.pr_id function_name ++
+			 spc () ++ str"is defined" )++ fnl () ++
+		    h 1 (Ppconstr.pr_id equation_id ++
 			   spc () ++ str"is defined" )
 		 )
   in
-  try 
-    com_terminate 
+  try
+    com_terminate
       tcc_lemma_name
       tcc_lemma_constr
       is_mes functional_ref
@@ -1425,7 +1462,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
       using_lemmas
       (List.length res_vars)
       hook
-  with e -> 
+  with e ->
     begin
       ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
 (*       anomaly "Cannot create termination Lemma" *)
diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mllib
new file mode 100644
index 00000000..31818c39
--- /dev/null
+++ b/plugins/funind/recdef_plugin.mllib
@@ -0,0 +1,11 @@
+Indfun_common
+Rawtermops
+Recdef
+Rawterm_to_relation
+Functional_principles_proofs
+Functional_principles_types
+Invfun
+Indfun
+Merge
+G_indfun
+Recdef_plugin_mod
diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget
new file mode 100644
index 00000000..33c96830
--- /dev/null
+++ b/plugins/funind/vo.itarget
@@ -0,0 +1 @@
+Recdef.vo
diff --git a/contrib/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v
index 93b4d213..93b4d213 100644
--- a/contrib/micromega/CheckerMaker.v
+++ b/plugins/micromega/CheckerMaker.v
diff --git a/contrib/micromega/Env.v b/plugins/micromega/Env.v
index 40db9e46..231004bc 100644
--- a/contrib/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -17,9 +17,9 @@ Require Import Coq.Arith.Max.
 Require Import List.
 Set Implicit Arguments.
 
-(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) 
+(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v)
    -- this is harmless and spares a lot of Empty.
-   This means smaller proof-terms. 
+   This means smaller proof-terms.
    BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
 *)
 
@@ -40,7 +40,7 @@ Section S.
   Lemma psucc : forall p,  (match p with
                               | xI y' => xO (Psucc y')
                               | xO y' => xI y'
-                              | 1%positive => 2%positive 
+                              | 1%positive => 2%positive
                             end) = (p+1)%positive.
   Proof.
     destruct p.
@@ -50,7 +50,7 @@ Section S.
     reflexivity.
   Qed.
 
-  Lemma jump_Pplus : forall i j l, 
+  Lemma jump_Pplus : forall i j l,
     forall x, jump (i + j) l x = jump i (jump j l) x.
   Proof.
     unfold jump.
@@ -60,7 +60,7 @@ Section S.
   Qed.
 
   Lemma jump_simpl : forall p l,
-    forall x, jump p l x = 
+    forall x, jump p l x =
     match p with
       | xH => tail l x
       | xO p => jump p (jump p l) x
@@ -80,15 +80,15 @@ Section S.
   Qed.
 
   Ltac jump_s :=
-    repeat 
+    repeat
       match goal with
         | |- context [jump xH ?e] => rewrite (jump_simpl xH)
         | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
         | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
       end.
-    
+
   Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x.
-  Proof. 
+  Proof.
     unfold tail.
     intros.
     repeat rewrite <- jump_Pplus.
@@ -96,7 +96,7 @@ Section S.
     reflexivity.
   Qed.
 
-  Lemma jump_Psucc : forall j l, 
+  Lemma jump_Psucc : forall j l,
     forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
   Proof.
     intros.
@@ -129,13 +129,13 @@ Section S.
     reflexivity.
   Qed.
 
-  Lemma nth_spec : forall p l x, 
-    nth p l = 
+  Lemma nth_spec : forall p l x,
+    nth p l =
     match p with
       | xH => hd x l
       | xO p => nth p (jump p l)
       | xI p => nth p (jump p (tail l))
-    end. 
+    end.
   Proof.
     unfold nth.
     destruct p.
diff --git a/contrib/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index 04e68272..e58f8e68 100644
--- a/contrib/micromega/EnvRing.v
+++ b/plugins/micromega/EnvRing.v
@@ -55,12 +55,12 @@ Section MakeRingPol.
  Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
  Notation "x == y" := (req x y).
 
- (* C notations *)		
+ (* C notations *)
  Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
  Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
  Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
 
- (* Usefull tactics *)		
+ (* Usefull tactics *)
   Add Setoid R req Rsth as R_set1.
  Ltac rrefl := gen_reflexivity Rsth.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
@@ -554,7 +554,7 @@ Section MakeRingPol.
   intros;simpl;apply (morph0 CRmorph).
  Qed.
 
-Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> 
+Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) ->
  p @ e1 = p @ e2.
 Proof.
   induction p ; simpl.
@@ -578,7 +578,7 @@ Proof.
   reflexivity.
 Qed.
 
-Lemma Pjump_xO_tail : forall P p l, 
+Lemma Pjump_xO_tail : forall P p l,
   P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
 Proof.
   intros.
@@ -743,9 +743,9 @@ Qed.
    induction P;simpl;intros;try apply (ARadd_comm ARth).
    destruct p2; simpl; try apply (ARadd_comm ARth).
    rewrite Pjump_xO_tail.
-   apply (ARadd_comm ARth).   
+   apply (ARadd_comm ARth).
    rewrite Pjump_Pdouble_minus_one.
-   apply (ARadd_comm ARth).   
+   apply (ARadd_comm ARth).
     assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
     rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
     rewrite IHP'1;simpl;Esimpl.
@@ -785,7 +785,7 @@ Qed.
   destruct p0;simpl;Esimpl2.
   rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
   rewrite Pjump_xO_tail.
-  add_push (P @ ((jump (xI p0) l)));rrefl.  
+  add_push (P @ ((jump (xI p0) l)));rrefl.
   rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
   add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
   unfold tail.
@@ -931,7 +931,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
   rrefl.
  Qed.
 
- Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> 
+ Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) ->
    Mphi env P = Mphi env' P.
  Proof.
    induction P ; simpl.
@@ -952,7 +952,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    intros. symmetry. apply H.
  Qed.
 
-Lemma Mjump_xO_tail : forall M p l, 
+Lemma Mjump_xO_tail : forall M p l,
   Mphi  (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
 Proof.
   intros.
@@ -1117,7 +1117,7 @@ Qed.
    rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
  intros i P5 H; rewrite H.
    intros HH H1; injection HH; intros; subst; rsimpl.
-   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. 
+   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
  intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
    assert (P4 = Q1 ++ P3 ** PX i P5 P6).
    injection H2; intros; subst;trivial.
@@ -1385,13 +1385,13 @@ Section POWER.
    intros.
    induction pe;simpl;Esimpl3.
    apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
    rewrite IHpe1;rewrite IHpe2;rrefl.
    rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
    rewrite IHpe;rrefl.
-   rewrite Ppow_N_ok by reflexivity. 
+   rewrite Ppow_N_ok by reflexivity.
    rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
       repeat rewrite Pmul_ok;rrefl.
   Qed.
 
diff --git a/contrib/micromega/LICENSE.sos b/plugins/micromega/LICENSE.sos
index 5aadfa2a..5aadfa2a 100644
--- a/contrib/micromega/LICENSE.sos
+++ b/plugins/micromega/LICENSE.sos
diff --git a/contrib/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index a5ac92db..1d7fbd56 100644
--- a/contrib/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -16,8 +16,33 @@
 
 Require Import ZMicromega.
 Require Import QMicromega.
+Require Import RMicromega.
 Require Import VarMap.
 Require Import RingMicromega.
 Require Import NArith.
+Require Import QArith.
 
-Extraction "micromega.ml"  List.map simpl_cone map_cone indexes  n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find.
+Extract Inductive prod => "( * )" [ "(,)" ].
+Extract Inductive List.list => list [ "[]" "(::)" ].
+Extract Inductive bool => bool [ true false ].
+Extract Inductive sumbool => bool [ true false ].
+Extract Inductive option => option [ Some None ].
+Extract Inductive sumor => option [ Some None ].
+(** Then, in a ternary alternative { }+{ }+{ },
+   -  leftmost choice (Inleft Left) is (Some true),
+   -  middle choice (Inleft Right) is (Some false),
+   -  rightmost choice (Inright) is (None) *)
+
+
+(** To preserve its laziness, andb is normally expansed.
+    Let's rather use the ocaml && *)
+Extract Inlined Constant andb => "(&&)".
+
+Extraction "micromega.ml"
+  List.map simpl_cone (*map_cone  indexes*)
+  denorm Qpower
+  n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
index 149b7731..803dd903 100644
--- a/contrib/micromega/OrderedRing.v
+++ b/plugins/micromega/OrderedRing.v
@@ -162,7 +162,7 @@ Qed.
 Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
 Proof.
 intros n m.
-split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. 
+split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H.
 now rewrite Rplus_0_l.
 rewrite H; ring.
 Qed.
diff --git a/contrib/micromega/Psatz.v b/plugins/micromega/Psatz.v
index b2dd9910..444a590a 100644
--- a/contrib/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -22,24 +22,29 @@ Require Import Raxioms.
 Require Export RingMicromega.
 Require Import VarMap.
 Require Tauto.
+Declare ML Module "micromega_plugin".
 
 Ltac xpsatz dom d :=
   let tac := lazymatch dom with
-  | Z => 
+  | Z =>
     (sos_Z || psatz_Z d) ;
-    intros __wit __varmap __ff ; 
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+    intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
     apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
   | R =>
     (sos_R || psatz_R d) ;
-    intros __wit __varmap __ff ; 
-    change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; 
-    apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (intros __wit __varmap __ff ;
+        change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+        apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
   | Q =>
-      (sos_Q || psatz_Q d) ;
-    intros __wit __varmap __ff ; 
-    change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; 
-    apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+    (sos_Q || psatz_Q d) ;
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (intros __wit __varmap __ff ;
+        change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+        apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
   | _ => fail "Unsupported domain"
   end in tac.
 
@@ -51,25 +56,31 @@ Ltac psatzl dom :=
   | Z =>
     psatzl_Z ;
     intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
     apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
   | Q =>
-    psatzl_Q ; 
-    intros __wit __varmap __ff ; 
-    change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; 
-    apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
-  | R => 
+    psatzl_Q ;
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (intros __wit __varmap __ff ;
+        change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+        apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+  | R =>
     psatzl_R ;
-    intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; 
-    apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (intros __wit __varmap __ff ;
+        change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+        apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
   | _ => fail "Unsupported domain"
   end in tac.
 
-
-
-Ltac lia := 
+Ltac lia :=
   xlia ;
   intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
       apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index c054f218..1e909cbc 100644
--- a/contrib/micromega/QMicromega.v
+++ b/plugins/micromega/QMicromega.v
@@ -17,6 +17,7 @@ Require Import RingMicromega.
 Require Import Refl.
 Require Import QArith.
 Require Import Qfield.
+(*Declare ML Module "micromega_plugin".*)
 
 Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq  Qle Qlt.
 Proof.
@@ -30,13 +31,8 @@ Proof.
   rewrite <- H ; rewrite <- H0 ; auto.
   rewrite H ; rewrite  H0 ; auto.
   apply Qsrt.
-  apply Qle_refl.
-  apply Qle_antisym ; auto.
   eapply Qle_trans ; eauto.
-  apply Qlt_le_weak ; auto.
   apply (Qlt_not_eq n m H H0) ; auto.
-  destruct (Qle_lt_or_eq _ _ H0) ; auto.
-  tauto.
   destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto.
   apply (Qplus_le_compat  p p n m  (Qle_refl p) H).
   generalize (Qmult_lt_compat_r 0 n m H0 H).
@@ -79,7 +75,7 @@ Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
   end.
 
 Lemma Qeval_expr_simpl : forall env e,
-  Qeval_expr env e = 
+  Qeval_expr env e =
   match e with
     | PEc c =>  c
     | PEX j =>  env j
@@ -104,6 +100,7 @@ Qed.
 Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e.
 Proof.
   induction e ; simpl ; subst ; try congruence.
+  reflexivity.
   rewrite IHe.
   apply QNpower.
 Qed.
@@ -136,9 +133,8 @@ Proof.
 Qed.
 
 
-
 Definition Qeval_nformula :=
-  eval_nformula 0 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+  eval_nformula 0 Qplus Qmult  Qeq Qle Qlt (fun x => x) .
 
 Definition Qeval_op1 (o : Op1) : Q -> Prop :=
 match o with
@@ -148,22 +144,15 @@ match o with
 | NonStrict => fun x : Q => 0 <= x
 end.
 
-Lemma Qeval_nformula_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)).
-Proof.
-  intros.
-  destruct f.
-  rewrite Qeval_expr_compat.
-  reflexivity.
-Qed.
-  
+
 Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
 Proof.
-  exact (fun env d =>eval_nformula_dec Qsor (fun x => x) (fun x => x) (pow_N 1 Qmult) env d).
+  exact (fun env d =>eval_nformula_dec Qsor (fun x => x)  env d).
 Qed.
 
-Definition QWitness := ConeMember Q.
+Definition QWitness := Psatz Q.
 
-Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool.
 
 Require Import List.
 
@@ -181,8 +170,15 @@ Qed.
 
 Require Import 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.
+
 Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness)  : bool :=
-  @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q)  QWitness QWeakChecker f w.
+  @tauto_checker (Formula Q) (NFormula Q)
+  Qnormalise
+  Qnegate QWitness QWeakChecker f w.
+
+
 
 Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f  (Qeval_formula env)  f.
 Proof.
@@ -190,10 +186,12 @@ Proof.
   unfold QTautoChecker.
   apply (tauto_checker_sound  Qeval_formula Qeval_nformula).
   apply Qeval_nformula_dec.
-  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor).
-  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor).
+  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now  apply (cnf_normalise_correct Qsor QSORaddon).
+  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon).
   intros t w0.
   apply QWeakChecker_sound.
 Qed.
 
-
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 7c6969c2..21f991ef 100644
--- a/contrib/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -17,6 +17,7 @@ Require Import RingMicromega.
 Require Import Refl.
 Require Import Raxioms RIneq Rpow_def DiscrR.
 Require Setoid.
+(*Declare ML Module "micromega_plugin".*)
 
 Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
 Proof.
@@ -60,7 +61,6 @@ Proof.
 Qed.
 
 Require ZMicromega.
-
 (* R with coeffs in Z *)
 
 Lemma RZSORaddon :
@@ -127,17 +127,17 @@ Proof.
 Qed.
 
 Definition Reval_nformula :=
-  eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+  eval_nformula 0 Rplus Rmult  (@eq R) Rle Rlt IZR.
 
 
 Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
 Proof.
-  exact (fun env d =>eval_nformula_dec Rsor IZR Nnat.nat_of_N pow env d).
+  exact (fun env d =>eval_nformula_dec Rsor IZR env d).
 Qed.
 
-Definition RWitness := ConeMember Z.
+Definition RWitness := Psatz Z.
 
-Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
+Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult  Zeq_bool Zle_bool.
 
 Require Import List.
 
@@ -155,8 +155,13 @@ Qed.
 
 Require Import Tauto.
 
+Definition Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
 Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness)  : bool :=
-  @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z)  RWitness RWeakChecker f w.
+  @tauto_checker (Formula Z) (NFormula Z)
+  Rnormalise Rnegate
+  RWitness RWeakChecker f w.
 
 Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f  (Reval_formula env)  f.
 Proof.
@@ -165,10 +170,13 @@ Proof.
   apply (tauto_checker_sound  Reval_formula Reval_nformula).
   apply Reval_nformula_dec.
   intros. rewrite Reval_formula_compat.
-  unfold Reval_formula'. now apply (cnf_normalise_correct Rsor).
-  intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor).
+  unfold Reval_formula'. now apply (cnf_normalise_correct Rsor RZSORaddon).
+  intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor RZSORaddon).
   intros t w0.
   apply RWeakChecker_sound.
 Qed.
 
 
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/Refl.v b/plugins/micromega/Refl.v
index 801d8b21..3b0de76b 100644
--- a/contrib/micromega/Refl.v
+++ b/plugins/micromega/Refl.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -8,7 +9,7 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -107,7 +108,7 @@ Proof.
 Qed.
 
 Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval
-  (no_middle_eval : forall d, eval d \/ ~ eval d) , 
+  (no_middle_eval : forall d, eval d \/ ~ eval d) ,
   ~ make_conj  eval (t ++ a) -> (~ make_conj  eval t) \/ (~ make_conj eval a).
 Proof.
   induction t.
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
new file mode 100644
index 00000000..d556cd03
--- /dev/null
+++ b/plugins/micromega/RingMicromega.v
@@ -0,0 +1,884 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import NArith.
+Require Import Relation_Definitions.
+Require Import Setoid.
+(*****)
+Require Import Env.
+Require Import EnvRing.
+(*****)
+Require Import List.
+Require Import Bool.
+Require Import OrderedRing.
+Require Import Refl.
+
+Set Implicit Arguments.
+
+Import OrderedRingSyntax.
+
+Section Micromega.
+
+(* Assume we have a strict(ly?) ordered ring *)
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+(* Assume we have a type of coefficients C and a morphism from C to R *)
+
+Variable C : Type.
+Variables cO cI : C.
+Variables cplus ctimes cminus: C -> C -> C.
+Variable copp : C -> C.
+Variables ceqb cleb : C -> C -> bool.
+Variable phi : C -> R.
+
+(* Power coefficients *)
+Variable E : Set. (* the type of exponents *)
+Variable pow_phi : N -> E.
+Variable rpow : R -> E -> R.
+
+Notation "[ x ]" := (phi x).
+Notation "x [=] y" := (ceqb x y).
+Notation "x [<=] y" := (cleb x y).
+
+(* Let's collect all hypotheses in addition to the ordered ring axioms into
+one structure *)
+
+Record SORaddon := mk_SOR_addon {
+  SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
+  SORpower : power_theory rI rtimes req pow_phi rpow;
+  SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
+  SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
+}.
+
+Variable addon : SORaddon.
+
+Add Relation R req
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as micomega_sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+  exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+  exact sor.(SORlt_wd).
+Qed.
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+  exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
+Qed.
+
+Definition cneqb (x y : C) := negb (ceqb x y).
+Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
+
+Notation "x [~=] y" := (cneqb x y).
+Notation "x [<] y" := (cltb x y).
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
+
+Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
+Proof.
+  exact addon.(SORcleb_morph).
+Qed.
+
+Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
+Proof.
+intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
+destruct (ceqb x y); now try discriminate.
+Qed.
+
+
+Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
+Proof.
+intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
+apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
+Qed.
+
+(* Begin Micromega *)
+
+Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
+Definition PolEnv := Env R. (* For interpreting PolC *)
+Definition eval_pol (env : PolEnv) (p:PolC) : R :=
+   Pphi 0 rplus rtimes phi env p.
+
+Inductive Op1 : Set := (* relations with 0 *)
+| Equal (* == 0 *)
+| NonEqual (* ~= 0 *)
+| Strict (* > 0 *)
+| NonStrict (* >= 0 *).
+
+Definition NFormula := (PolC * Op1)%type. (* normalized formula *)
+
+Definition eval_op1 (o : Op1) : R -> Prop :=
+match o with
+| Equal => fun x => x == 0
+| NonEqual => fun x : R => x ~= 0
+| Strict => fun x : R => 0 < x
+| NonStrict => fun x : R => 0 <= x
+end.
+
+Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
+let (p, op) := f in eval_op1 op (eval_pol env p).
+
+
+(** Rule of "signs" for addition and multiplication.
+   An arbitrary result is coded buy None. *)
+
+Definition OpMult (o o' : Op1) : option Op1 :=
+match o with
+| Equal => Some Equal
+| NonStrict =>
+  match o' with
+    | Equal => Some Equal
+    | NonEqual  => None
+    | Strict    => Some NonStrict
+    | NonStrict => Some NonStrict
+  end
+| Strict => match o' with
+              | NonEqual => None
+              |  _       => Some o'
+            end
+| NonEqual => match o' with
+                | Equal => Some Equal
+                | NonEqual => Some NonEqual
+                | _        => None
+              end
+end.
+
+Definition OpAdd (o o': Op1) : option Op1 :=
+  match o with
+    | Equal => Some o'
+    | NonStrict =>
+      match o' with
+        | Strict => Some Strict
+        | NonEqual => None
+        | _ => Some NonStrict
+      end
+    | Strict => match o' with
+                  | NonEqual => None
+                  |  _        => Some Strict
+                end
+    | NonEqual => match o' with
+                    | Equal  => Some NonEqual
+                    | _      => None
+                  end
+  end.
+
+
+Lemma OpMult_sound :
+  forall (o o' om: Op1) (x y : R),
+    eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y).
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3.
+(* x == 0 *)
+inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor).
+(* x ~= 0 *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2. now rewrite (Rtimes_0_r sor).
+ (* y ~= 0 *)
+ apply (Rtimes_neq_0 sor) ; auto.
+(* 0 < x *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2; now rewrite (Rtimes_0_r sor).
+ (* 0 < y *)
+ now apply (Rtimes_pos_pos sor).
+ (* 0 <= y *)
+  apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
+(* 0 <= x *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2; now rewrite (Rtimes_0_r sor).
+ (* 0 < y *)
+ apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ].
+ (* 0 <= y *)
+ now apply (Rtimes_nonneg_nonneg sor).
+Qed.
+
+Lemma OpAdd_sound :
+  forall (o o' oa : Op1) (e e' : R),
+    eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e').
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa.
+(* e == 0 *)
+inversion Hoa. rewrite <- H0.
+destruct o' ; rewrite H1 ; now rewrite  (Rplus_0_l sor).
+(* e ~= 0 *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ rewrite H2. now rewrite (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ discriminate.
+ (* 0 <= e' *)
+ discriminate.
+(* 0 < e *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ rewrite H2.  now rewrite (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ inversion Hoa.
+ now apply (Rplus_pos_pos sor).
+ (* 0 <= e' *)
+ inversion Hoa.
+ now apply (Rplus_pos_nonneg sor).
+(* 0 <= e *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ now rewrite H2, (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ inversion Hoa.
+ now apply (Rplus_nonneg_pos sor).
+ (* 0 <= e' *)
+ inversion Hoa.
+ now apply (Rplus_nonneg_nonneg sor).
+Qed.
+
+Inductive Psatz : Type :=
+| PsatzIn : nat -> Psatz
+| PsatzSquare : PolC -> Psatz
+| PsatzMulC : PolC -> Psatz -> Psatz
+| PsatzMulE : Psatz -> Psatz -> Psatz
+| PsatzAdd  : Psatz -> Psatz -> Psatz
+| PsatzC    : C -> Psatz
+| PsatzZ    : Psatz.
+
+(** Given a list [l] of NFormula and an extended polynomial expression
+   [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a
+   logic consequence of the conjunction of the formulae in l.
+   Moreover, the polynomial expression is obtained by replacing the (PsatzIn n)
+   by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *)
+
+(* Might be defined elsewhere *)
+Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :=
+  match o with
+    | None => None
+    | Some x => f x
+  end.
+
+Implicit Arguments map_option [A B].
+
+Definition map_option2 (A B C : Type) (f : A -> B -> option C)
+  (o: option A) (o': option B) : option C :=
+  match o , o' with
+    | None , _ => None
+    | _ , None => None
+    | Some x , Some x' => f x x'
+  end.
+
+Implicit Arguments map_option2 [A B C].
+
+Definition Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd).
+
+Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula :=
+  let (ef,o) := f in
+    match o with
+      | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal)
+      |   _   => None
+    end.
+
+Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula :=
+  let (e1,o1) := f1 in
+    let (e2,o2) := f2 in
+      map_option  (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x)))    (OpMult o1 o2).
+
+ Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula :=
+  let (e1,o1) := f1 in
+    let (e2,o2) := f2 in
+      map_option  (fun x => (Some (Padd cO cplus ceqb e1 e2,x)))    (OpAdd o1 o2).
+
+
+Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula :=
+  match e with
+    | PsatzIn n => Some (nth n l (Pc cO, Equal))
+    | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e  , NonStrict)
+    | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e)
+    | PsatzMulE f1 f2 => map_option2 nformula_times_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
+    | PsatzAdd f1 f2  => map_option2 nformula_plus_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
+    | PsatzC  c  => if cltb cO c then Some (Pc c, Strict) else None
+(* This could be 0, or <> 0 -- but these cases are useless *)
+    | PsatzZ     => Some (Pc cO, Equal) (* Just to make life easier *)
+  end.
+
+Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula),
+  eval_nformula env f -> pexpr_times_nformula e f = Some f' ->
+   eval_nformula env f'.
+Proof.
+  unfold pexpr_times_nformula.
+  destruct f.
+  intros. destruct o ; inversion H0 ; try discriminate.
+  simpl in *.    unfold eval_pol in *.
+  rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm)).
+  rewrite H. apply (Rtimes_0_r sor).
+Qed.
+
+Lemma nformula_times_nformula_correct : forall (env:PolEnv)
+  (f1 f2 f : NFormula),
+  eval_nformula env f1 -> eval_nformula env f2 ->
+  nformula_times_nformula f1 f2 = Some f  ->
+   eval_nformula env f.
+Proof.
+  unfold nformula_times_nformula.
+  destruct f1 ; destruct f2.
+  case_eq (OpMult o o0) ; simpl ; try discriminate.
+  intros. inversion H2 ; simpl.
+  unfold eval_pol.
+  destruct o1; simpl;
+  rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
+  apply OpMult_sound with (3:= H);assumption.
+Qed.
+
+Lemma nformula_plus_nformula_correct : forall (env:PolEnv)
+  (f1 f2 f : NFormula),
+  eval_nformula env f1 -> eval_nformula env f2 ->
+  nformula_plus_nformula f1 f2 = Some f  ->
+   eval_nformula env f.
+Proof.
+  unfold nformula_plus_nformula.
+  destruct f1 ; destruct f2.
+  case_eq (OpAdd o o0) ; simpl ; try discriminate.
+  intros. inversion H2 ; simpl.
+  unfold eval_pol.
+  destruct o1; simpl;
+  rewrite (Padd_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
+  apply OpAdd_sound with (3:= H);assumption.
+Qed.
+
+Lemma eval_Psatz_Sound :
+  forall (l : list NFormula) (env : PolEnv),
+    (forall (f : NFormula), In f l -> eval_nformula env f) ->
+      forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f ->
+        eval_nformula env f.
+Proof.
+  induction e.
+  (* PsatzIn *)
+  simpl ; intros.
+  destruct (nth_in_or_default n l (Pc cO, Equal)).
+  (* index is in bounds *)
+  apply H ; congruence.
+  (* index is out-of-bounds *)
+  inversion H0.
+  rewrite e. simpl.
+  now apply  addon.(SORrm).(morph0).
+  (* PsatzSquare *)
+  simpl. intros. inversion H0.
+  simpl. unfold eval_pol.
+  rewrite (Psquare_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
+  now apply (Rtimes_square_nonneg sor).
+  (* PsatzMulC *)
+  simpl.
+  intro.
+  case_eq  (eval_Psatz l e) ; simpl ; intros.
+  apply IHe in H0.
+  apply pexpr_times_nformula_correct with (1:=H0) (2:= H1).
+  discriminate.
+  (* PsatzMulC *)
+  simpl ; intro.
+  case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
+  case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
+  intros.
+  apply IHe1 in H1. apply IHe2 in H0.
+  apply (nformula_times_nformula_correct env n0 n) ; assumption.
+  (* PsatzAdd *)
+  simpl ; intro.
+  case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
+  case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
+  intros.
+  apply IHe1 in H1. apply IHe2 in H0.
+  apply (nformula_plus_nformula_correct env n0 n) ; assumption.
+  (* PsatzC *)
+  simpl.
+  intro. case_eq (cO [<] c).
+  intros.  inversion H1. simpl.
+  rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+  discriminate.
+  (* PsatzZ *)
+  simpl. intros. inversion H0.
+  simpl.   apply  addon.(SORrm).(morph0).
+Qed.
+
+Fixpoint ge_bool (n m  : nat) : bool :=
+ match n with
+   | O   => match m with
+            |  O => true
+            | S _ => false
+          end
+   | S n  => match m with
+               | O => true
+               | S m => ge_bool n m
+             end
+   end.
+
+Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat.
+Proof.
+  induction n ; simpl.
+  destruct m ; simpl.
+  constructor.
+  omega.
+  destruct m.
+  constructor.
+  omega.
+  generalize (IHn m).
+  destruct (ge_bool n m) ; omega.
+Qed.
+
+
+Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz)  : list nat :=
+  match prf with
+    | PsatzC _ | PsatzZ | PsatzSquare _ => acc
+    | PsatzMulC _ prf => xhyps_of_psatz base acc prf
+    | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1
+    | PsatzIn n => if ge_bool n base then (n::acc) else acc
+  end.
+
+
+(* roughly speaking, normalise_pexpr_correct is a proof of
+  forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
+
+(*****)
+Definition paddC := PaddC cplus.
+Definition psubC := PsubC cminus.
+
+Definition PsubC_ok : forall c P env, eval_pol env (psubC  P c) == eval_pol env P - [c] :=
+  let Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd) in
+                       PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+                addon.(SORrm).
+
+Definition PaddC_ok : forall c P env, eval_pol env (paddC  P c) == eval_pol env P + [c] :=
+  let Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd) in
+                       PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+                addon.(SORrm).
+
+
+(* Check that a formula f is inconsistent by normalizing and comparing the
+resulting constant with 0 *)
+
+Definition check_inconsistent (f : NFormula) : bool :=
+let (e, op) := f in
+  match  e with
+  | Pc c =>
+    match op with
+    | Equal => cneqb c cO
+    | NonStrict => c [<] cO
+    | Strict => c [<=] cO
+    | NonEqual => c [=] cO
+    end
+  | _ => false (* not a constant *)
+  end.
+
+Lemma check_inconsistent_sound :
+  forall (p : PolC) (op : Op1),
+    check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p).
+Proof.
+intros p op H1 env. unfold check_inconsistent in H1.
+destruct op; simpl ;
+(*****)
+destruct p ; simpl; try discriminate H1;
+try rewrite <- addon.(SORrm).(morph0); trivial.
+now apply cneqb_sound.
+apply addon.(SORrm).(morph_eq) in H1. congruence.
+apply cleb_sound in H1. now apply -> (Rle_ngt sor).
+apply cltb_sound in H1. now apply -> (Rlt_nge sor).
+Qed.
+
+Definition check_normalised_formulas : list NFormula -> Psatz -> bool :=
+  fun l cm =>
+    match eval_Psatz l cm with
+      | None => false
+      | Some f => check_inconsistent f
+    end.
+
+Lemma checker_nf_sound :
+  forall (l : list NFormula) (cm : Psatz),
+    check_normalised_formulas l cm = true ->
+      forall env : PolEnv, make_impl (eval_nformula env) l False.
+Proof.
+intros l cm H env.
+unfold check_normalised_formulas in H.
+revert H.
+case_eq (eval_Psatz l cm) ; [|discriminate].
+intros nf. intros.
+rewrite <- make_conj_impl. intro.
+assert (H1' := make_conj_in _ _ H1).
+assert (Hnf :=  @eval_Psatz_Sound  _ _  H1' _ _ H).
+destruct nf.
+apply (@check_inconsistent_sound _ _ H0 env Hnf).
+Qed.
+
+(** Normalisation of formulae **)
+
+Inductive Op2 : Set := (* binary relations *)
+| OpEq
+| OpNEq
+| OpLe
+| OpGe
+| OpLt
+| OpGt.
+
+Definition eval_op2 (o : Op2) : R -> R -> Prop :=
+match o with
+| OpEq => req
+| OpNEq => fun x y : R => x ~= y
+| OpLe => rle
+| OpGe => fun x y : R => y <= x
+| OpLt => fun x y : R => x < y
+| OpGt => fun x y : R => y < x
+end.
+
+Definition  eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe.
+
+Record Formula : Type := {
+  Flhs : PExpr C;
+  Fop : Op2;
+  Frhs : PExpr C
+}.
+
+Definition eval_formula (env : PolEnv) (f : Formula) : Prop :=
+  let (lhs, op, rhs) := f in
+    (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).
+
+(* We normalize Formulas by moving terms to one side *)
+
+Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb.
+
+Definition psub := Psub cO  cplus cminus copp ceqb.
+
+Definition padd  := Padd cO  cplus ceqb.
+
+Definition normalise (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+  let lhs := norm lhs in
+    let rhs := norm rhs in
+  match op with
+  | OpEq =>  (psub  lhs rhs, Equal)
+  | OpNEq => (psub lhs rhs, NonEqual)
+  | OpLe =>  (psub rhs lhs, NonStrict)
+  | OpGe =>  (psub lhs rhs, NonStrict)
+  | OpGt => (psub  lhs rhs, Strict)
+  | OpLt => (psub  rhs lhs, Strict)
+  end.
+
+Definition negate (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+  let lhs := norm lhs in
+    let rhs := norm rhs in
+      match op with
+        | OpEq => (psub rhs lhs, NonEqual)
+        | OpNEq => (psub rhs lhs, Equal)
+        | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
+        | OpGe => (psub rhs lhs, Strict)
+        | OpGt => (psub rhs lhs, NonStrict)
+        | OpLt => (psub lhs rhs, NonStrict)
+      end.
+
+
+Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) == eval_pol env lhs - eval_pol env rhs.
+Proof.
+  intros.
+  apply (Psub_ok  sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd  lhs rhs) == eval_pol env lhs + eval_pol env rhs.
+Proof.
+  intros.
+  apply (Padd_ok  sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env  (norm lhs).
+Proof.
+  intros.
+  apply  (norm_aux_spec sor.(SORsetoid) Rops_wd   (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ).
+Qed.
+
+
+Theorem normalise_sound :
+  forall (env : PolEnv) (f : Formula),
+    eval_formula env f -> eval_nformula env (normalise f).
+Proof.
+intros env f H; destruct f as [lhs op rhs]; simpl in *.
+destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+now apply <- (Rminus_eq_0 sor).
+intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
+now apply -> (Rle_le_minus sor).
+now apply -> (Rle_le_minus sor).
+now apply -> (Rlt_lt_minus sor).
+now apply -> (Rlt_lt_minus sor).
+Qed.
+
+Theorem negate_correct :
+  forall (env : PolEnv) (f : Formula),
+    eval_formula env f <-> ~ (eval_nformula env (negate f)).
+Proof.
+intros env f; destruct f as [lhs op rhs]; simpl.
+destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+symmetry. rewrite (Rminus_eq_0 sor).
+split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
+rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
+rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
+Qed.
+
+(** Another normalistion - this is used for cnf conversion **)
+
+Definition xnormalise (t:Formula) : list (NFormula)  :=
+  let (lhs,o,rhs) := t in
+  let lhs := norm lhs in
+    let rhs := norm rhs in
+    match o with
+      | OpEq =>
+        (psub lhs  rhs, Strict)::(psub rhs lhs , Strict)::nil
+      | OpNEq => (psub lhs rhs,Equal) :: nil
+      | OpGt   => (psub rhs lhs,NonStrict) :: nil
+      | OpLt => (psub lhs rhs,NonStrict) :: nil
+      | OpGe => (psub rhs lhs , Strict) :: nil
+      | OpLe => (psub lhs rhs ,Strict) :: nil
+    end.
+
+Require Import Tauto.
+
+Definition cnf_normalise (t:Formula) : cnf (NFormula) :=
+  List.map  (fun x => x::nil) (xnormalise t).
+
+
+Add Ring SORRing : sor.(SORrt).
+
+Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t.
+Proof.
+  unfold cnf_normalise, xnormalise ; simpl ; intros env t.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o ; simpl;
+    repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ;
+    generalize (eval_pexpr  env lhs);
+      generalize (eval_pexpr  env rhs) ; intros z1 z2 ; intros.
+  (**)
+  apply sor.(SORle_antisymm).
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  now rewrite <- (Rminus_eq_0 sor).
+  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
+  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
+  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
+  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
+Qed.
+
+Definition xnegate (t:Formula) : list (NFormula)  :=
+  let (lhs,o,rhs) := t in
+    let lhs := norm lhs in
+      let rhs := norm rhs in
+    match o with
+      | OpEq  => (psub lhs rhs,Equal) :: nil
+      | OpNEq => (psub lhs  rhs ,Strict)::(psub rhs lhs,Strict)::nil
+      | OpGt  => (psub lhs  rhs,Strict) :: nil
+      | OpLt  => (psub rhs lhs,Strict) :: nil
+      | OpGe  => (psub lhs rhs,NonStrict) :: nil
+      | OpLe  => (psub rhs lhs,NonStrict) :: nil
+    end.
+
+Definition cnf_negate (t:Formula) : cnf (NFormula) :=
+  List.map  (fun x => x::nil) (xnegate t).
+
+Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t.
+Proof.
+  unfold cnf_negate, xnegate ; simpl ; intros env t.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o ; simpl;
+    repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ;
+    generalize (eval_pexpr  env lhs);
+      generalize (eval_pexpr  env rhs) ; intros z1 z2 ; intros ; intuition.
+  (**)
+  apply H0.
+  rewrite H1 ; ring.
+  (**)
+  apply H1.
+  apply sor.(SORle_antisymm).
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  (**)
+  apply H0. now rewrite  (Rle_le_minus sor) in H1.
+  apply H0. now rewrite (Rle_le_minus sor) in H1.
+  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+Qed.
+
+Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+  intros.
+  destruct d ; simpl.
+  generalize (eval_pol env p); intros.
+  destruct o ; simpl.
+  apply (Req_em sor r 0).
+  destruct (Req_em sor r 0) ; tauto.
+  rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
+  rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
+Qed.
+
+(** Reverse transformation *)
+
+Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C :=
+  match p with
+    | Pc c => PEc c
+    | Pinj j p => xdenorm  (Pplus j jmp ) p
+    | PX p j q   => PEadd
+      (PEmul (xdenorm jmp p) (PEpow (PEX _  jmp) (Npos j)))
+      (xdenorm (Psucc jmp) q)
+  end.
+
+Lemma xdenorm_correct : forall p i  env, eval_pol (jump i env)  p == eval_pexpr env (xdenorm (Psucc i) p).
+Proof.
+  unfold eval_pol.
+  induction p.
+  simpl. reflexivity.
+  (* Pinj *)
+  simpl.
+  intros.
+  rewrite Pplus_succ_permute_r.
+  rewrite <- IHp.
+  symmetry.
+  rewrite Pplus_comm.
+  rewrite Pjump_Pplus. reflexivity.
+  (* PX *)
+  simpl.
+  intros.
+  rewrite <- IHp1.
+  rewrite <- IHp2.
+  unfold Env.tail , Env.hd.
+  rewrite <- Pjump_Pplus.
+  rewrite <- Pplus_one_succ_r.
+  unfold Env.nth.
+  unfold jump at 2.
+  rewrite Pplus_one_succ_l.
+  rewrite addon.(SORpower).(rpow_pow_N).
+  unfold pow_N. ring.
+Qed.
+
+Definition denorm (p : Pol C)  := xdenorm xH p.
+
+Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
+Proof.
+  unfold denorm.
+  induction p.
+  reflexivity.
+  simpl.
+  rewrite <- Pplus_one_succ_r.
+  apply xdenorm_correct.
+  simpl.
+  intros.
+  rewrite IHp1.
+  unfold Env.tail.
+  rewrite xdenorm_correct.
+  change (Psucc xH) with 2%positive.
+  rewrite addon.(SORpower).(rpow_pow_N).
+  simpl. reflexivity.
+Qed.
+
+
+(** Some syntactic simplifications of expressions  *)
+
+
+Definition simpl_cone (e:Psatz) : Psatz :=
+  match e with
+    | PsatzSquare t =>
+                    match t with
+                      | Pc c   => if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
+                      | _ => PsatzSquare t
+                    end
+    | PsatzMulE t1 t2 =>
+      match t1 , t2 with
+        | PsatzZ      , x        => PsatzZ
+        |    x     , PsatzZ      => PsatzZ
+        | PsatzC c ,  PsatzC c' => PsatzC (ctimes c c')
+        | PsatzC p1 , PsatzMulE (PsatzC p2)  x => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzC p1 , PsatzMulE x (PsatzC p2)  => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzMulE (PsatzC p2)  x  , PsatzC p1   => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzMulE x (PsatzC p2)   , PsatzC p1   => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzC x   , PsatzAdd y z   => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z)
+        | PsatzC c ,  _        => if ceqb cI c then t2 else PsatzMulE t1 t2
+        | _ ,  PsatzC c        => if ceqb cI c then t1 else PsatzMulE t1 t2
+        |     _     , _   => e
+      end
+    | PsatzAdd t1 t2 =>
+      match t1 ,  t2 with
+        | PsatzZ     , x => x
+        |   x     , PsatzZ => x
+        |   x     , y   => PsatzAdd x y
+      end
+    |   _     => e
+  end.
+
+
+
+
+End Micromega.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
\ No newline at end of file
diff --git a/contrib/micromega/Tauto.v b/plugins/micromega/Tauto.v
index ef48efa6..b1d02176 100644
--- a/contrib/micromega/Tauto.v
+++ b/plugins/micromega/Tauto.v
@@ -20,14 +20,14 @@ Set Implicit Arguments.
 
 
   Inductive BFormula (A:Type) : Type :=
-  | TT   : BFormula A 
+  | TT   : BFormula A
   | FF   : BFormula A
   | X : Prop -> BFormula A
-  | A : A -> BFormula A 
+  | A : A -> BFormula A
   | Cj  : BFormula A -> BFormula A -> BFormula A
   | D   : BFormula A-> BFormula A -> BFormula A
   | N  : BFormula A -> BFormula A
-  | I : BFormula A-> BFormula A-> BFormula A. 
+  | I : BFormula A-> BFormula A-> BFormula A.
 
   Fixpoint eval_f (A:Type)  (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
     match f with
@@ -42,7 +42,7 @@ Set Implicit Arguments.
     end.
 
 
-  Lemma map_simpl : forall A B f l, @map A B f l = match l with 
+  Lemma map_simpl : forall A B f l, @map A B f l = match l with
                                                  | nil => nil
                                                  | a :: l=> (f a) :: (@map A B f l)
                                                end.
@@ -57,7 +57,7 @@ Set Implicit Arguments.
     Variable Env   : Type.
     Variable Term  : Type.
     Variable eval  : Env -> Term -> Prop.
-    Variable Term' : Type.  
+    Variable Term' : Type.
     Variable eval'  : Env -> Term' -> Prop.
 
 
@@ -78,17 +78,17 @@ Set Implicit Arguments.
 
     Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
       List.map (fun x => (t++x)) f.
-    
+
     Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
       match f with
         | nil => tt
         | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
       end.
-    
+
 
     Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
       f1 ++ f2.
-    
+
     Fixpoint xcnf (pol : bool) (f : BFormula Term)  {struct f}: cnf :=
       match f with
         | TT => if pol then tt else ff
@@ -96,14 +96,14 @@ Set Implicit Arguments.
         | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
         | A x => if pol then normalise x else negate x
         | N e  => xcnf (negb pol) e
-        | Cj e1 e2 => 
+        | Cj e1 e2 =>
           (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
         | D e1 e2  => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
         | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
       end.
 
   Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj  (fun cl => ~ make_conj  env cl) f.
-  
+
 
   Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
   Proof.
@@ -111,7 +111,7 @@ Set Implicit Arguments.
     intros.
     rewrite make_conj_app in H ; auto.
   Qed.
-    
+
 
   Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj  (eval' env) t) \/ (eval_cnf (eval' env) f).
   Proof.
@@ -258,8 +258,8 @@ Set Implicit Arguments.
     unfold and_cnf in H.
     simpl in H.
     destruct (eval_cnf_app _ _ _ H).
-    generalize (IHf1 _ _ H0).    
-    generalize (IHf2 _ _ H1).    
+    generalize (IHf1 _ _ H0).
+    generalize (IHf2 _ _ H1).
     simpl.
     tauto.
   Qed.
@@ -267,13 +267,13 @@ Set Implicit Arguments.
 
   Variable Witness : Type.
   Variable checker : list Term' -> Witness -> bool.
-  
+
   Variable checker_sound : forall t  w, checker t w = true -> forall env, make_impl (eval' env)  t False.
 
   Fixpoint cnf_checker (f : cnf) (l : list Witness)  {struct f}: bool :=
     match f with
       | nil => true
-      | e::f => match l with 
+      | e::f => match l with
                   | nil => false
                   | c::l => match checker e c with
                               | true => cnf_checker f l
@@ -322,3 +322,6 @@ Set Implicit Arguments.
 
 End S.
 
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 240c0fb7..0a66fce3 100644
--- a/contrib/micromega/VarMap.v
+++ b/plugins/micromega/VarMap.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -8,7 +9,7 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -17,21 +18,21 @@ Require Import Coq.Arith.Max.
 Require Import List.
 Set Implicit Arguments.
 
-(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) 
+(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v)
    -- this is harmless and spares a lot of Empty.
-   This means smaller proof-terms. 
+   This means smaller proof-terms.
    BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
 *)
 
 Section MakeVarMap.
   Variable A : Type.
   Variable default : A.
-  
+
   Inductive t  : Type :=
-  | Empty : t 
-  | Leaf : A -> t 
+  | Empty : t
+  | Leaf : A -> t
   | Node : t  -> A -> t  -> t .
-  
+
   Fixpoint find   (vm : t ) (p:positive) {struct vm} : A :=
     match vm with
       | Empty => default
@@ -43,13 +44,13 @@ Section MakeVarMap.
                       end
     end.
 
- (* an off_map (a map with offset) offers the same functionalites  as /contrib/setoid_ring/BinList.v - it is used in EnvRing.v *)
+ (* an off_map (a map with offset) offers the same functionalites  as /plugins/setoid_ring/BinList.v - it is used in EnvRing.v *)
 (*
   Definition off_map  :=  (option positive *t )%type.
 
 
 
-  Definition jump  (j:positive) (l:off_map ) := 
+  Definition jump  (j:positive) (l:off_map ) :=
     let (o,m) := l in
       match o with
         | None => (Some j,m)
@@ -74,7 +75,7 @@ Section MakeVarMap.
   Lemma psucc : forall p,  (match p with
                               | xI y' => xO (Psucc y')
                               | xO y' => xI y'
-                              | 1%positive => 2%positive 
+                              | 1%positive => 2%positive
                             end) = (p+1)%positive.
   Proof.
     destruct p.
@@ -84,7 +85,7 @@ Section MakeVarMap.
     reflexivity.
   Qed.
 
-  Lemma jump_Pplus : forall i j l, 
+  Lemma jump_Pplus : forall i j l,
     (jump (i + j) l) = (jump i (jump j l)).
   Proof.
     unfold jump.
@@ -96,7 +97,7 @@ Section MakeVarMap.
   Qed.
 
   Lemma jump_simpl : forall p l,
-    jump p l = 
+    jump p l =
     match p with
       | xH => tail l
       | xO p => jump p (jump p l)
@@ -116,15 +117,15 @@ Section MakeVarMap.
   Qed.
 
   Ltac jump_s :=
-    repeat 
+    repeat
       match goal with
         | |- context [jump xH ?e] => rewrite (jump_simpl xH)
         | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
         | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
       end.
-    
+
   Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
-  Proof. 
+  Proof.
     unfold tail.
     intros.
     repeat rewrite <- jump_Pplus.
@@ -132,7 +133,7 @@ Section MakeVarMap.
     reflexivity.
   Qed.
 
-  Lemma jump_Psucc : forall j l, 
+  Lemma jump_Psucc : forall j l,
     (jump (Psucc j) l) = (jump 1 (jump j l)).
   Proof.
     intros.
@@ -162,14 +163,14 @@ Section MakeVarMap.
     reflexivity.
   Qed.
 
-  
-  Lemma nth_spec : forall p l, 
-    nth p l = 
+
+  Lemma nth_spec : forall p l,
+    nth p l =
     match p with
       | xH => hd  l
       | xO p => nth p (jump p l)
       | xI p => nth p (jump p (tail l))
-    end. 
+    end.
   Proof.
     unfold nth.
     destruct l.
diff --git a/contrib/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v
index ced67e39..f27cd15e 100644
--- a/contrib/micromega/ZCoeff.v
+++ b/plugins/micromega/ZCoeff.v
@@ -56,7 +56,7 @@ Proof.
   destruct sor.(SORsetoid).
   apply Equivalence_Transitive.
 Qed.
-  
+
 
 Add Relation R req
   reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
new file mode 100644
index 00000000..b02a9850
--- /dev/null
+++ b/plugins/micromega/ZMicromega.v
@@ -0,0 +1,1023 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZCoeff.
+Require Import Refl.
+Require Import ZArith.
+Require Import List.
+Require Import Bool.
+(*Declare ML Module "micromega_plugin".*)
+
+Ltac flatten_bool :=
+  repeat match goal with
+           [ id : (_ && _)%bool = true |- _ ] =>  destruct (andb_prop _ _ id); clear id
+           |  [ id : (_ || _)%bool = true |- _ ] =>  destruct (orb_prop _ _ id); clear id
+         end.
+
+Ltac inv H := inversion H ; try subst ; clear H.
+
+
+Require Import EnvRing.
+
+Open Scope Z_scope.
+
+Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
+Proof.
+  constructor ; intros ; subst ; try (intuition (auto  with zarith)).
+  apply Zsth.
+  apply Zth.
+  destruct (Ztrichotomy n m) ; intuition (auto with zarith).
+  apply Zmult_lt_0_compat ; auto.
+Qed.
+
+Lemma ZSORaddon :
+  SORaddon 0 1 Zplus Zmult Zminus Zopp  (@eq Z) Zle (* ring elements *)
+  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
+  Zeq_bool Zle_bool
+  (fun x => x) (fun x => x) (pow_N 1 Zmult).
+Proof.
+  constructor.
+  constructor ; intros ; try reflexivity.
+  apply Zeq_bool_eq ; auto.
+  constructor.
+  reflexivity.
+  intros x y.
+  apply Zeq_bool_neq ; auto.
+  apply Zle_bool_imp_le.
+Qed.
+
+Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
+  match e with
+    | PEc c => c
+    | PEX x => env x
+    | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
+    | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
+    | PEpow e1 n  => Zpower (Zeval_expr env e1) (Z_of_N n)
+    | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2)
+    | PEopp e   => Zopp (Zeval_expr env e)
+  end.
+
+Definition eval_expr := eval_pexpr  Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
+Proof.
+  destruct n.
+  reflexivity.
+  simpl.
+  unfold Zpower_pos.
+  replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
+  generalize 1.
+  induction p; simpl ; intros ; repeat rewrite IHp ; ring.
+Qed.
+
+Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e.
+Proof.
+  induction e ; simpl ; try congruence.
+  reflexivity.
+  rewrite ZNpower. congruence.
+Qed.
+
+Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
+match o with
+| OpEq =>  @eq Z
+| OpNEq => fun x y  => ~ x = y
+| OpLe => Zle
+| OpGe => Zge
+| OpLt => Zlt
+| OpGt => Zgt
+end.
+
+Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):=
+  let (lhs, op, rhs) := f in
+    (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs).
+
+Definition Zeval_formula' :=
+  eval_formula  Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
+Proof.
+  destruct f ; simpl.
+  rewrite Zeval_expr_compat. rewrite Zeval_expr_compat.
+  unfold eval_expr.
+  generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Zmult) env Flhs).
+  generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Zmult) env Frhs)).
+  destruct Fop ; simpl; intros ; intuition (auto with zarith).
+Qed.
+
+
+Definition eval_nformula :=
+  eval_nformula 0 Zplus Zmult  (@eq Z) Zle Zlt (fun x => x) .
+
+Definition Zeval_op1 (o : Op1) : Z -> Prop :=
+match o with
+| Equal => fun x : Z => x = 0
+| NonEqual => fun x : Z => x <> 0
+| Strict => fun x : Z => 0 < x
+| NonStrict => fun x : Z => 0 <= x
+end.
+
+
+Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+  intros.
+  apply (eval_nformula_dec Zsor).
+Qed.
+
+Definition ZWitness := Psatz Z.
+
+Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool.
+
+Lemma ZWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : ZWitness),
+  ZWeakChecker l cm = true ->
+  forall env, make_impl (eval_nformula env) l False.
+Proof.
+  intros l cm H.
+  intro.
+  unfold eval_nformula.
+  apply (checker_nf_sound Zsor ZSORaddon l cm).
+  unfold ZWeakChecker in H.
+  exact H.
+Qed.
+
+Definition psub  := psub Z0  Zplus Zminus Zopp Zeq_bool.
+
+Definition padd  := padd Z0  Zplus Zeq_bool.
+
+Definition norm  := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool.
+
+Definition eval_pol := eval_pol 0  Zplus Zmult (fun x => x).
+
+Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) = eval_pol env lhs - eval_pol env rhs.
+Proof.
+  intros.
+  apply (eval_pol_sub Zsor ZSORaddon).
+Qed.
+
+Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd  lhs rhs) = eval_pol env lhs + eval_pol env rhs.
+Proof.
+  intros.
+  apply (eval_pol_add Zsor ZSORaddon).
+Qed.
+
+Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) .
+Proof.
+  intros.
+  apply (eval_pol_norm Zsor ZSORaddon).
+Qed.
+
+Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
+  let (lhs,o,rhs) := t in
+    let lhs := norm lhs in
+      let rhs := norm rhs in
+    match o with
+      | OpEq =>
+        ((psub lhs (padd  rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
+      | OpNEq => (psub lhs rhs,Equal) :: nil
+      | OpGt   => (psub rhs lhs,NonStrict) :: nil
+      | OpLt => (psub lhs rhs,NonStrict) :: nil
+      | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
+      | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
+    end.
+
+Require Import Tauto.
+
+Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
+  List.map  (fun x => x::nil) (xnormalise t).
+
+
+Lemma normalise_correct : forall env t, eval_cnf (eval_nformula env) (normalise t) <-> Zeval_formula env t.
+Proof.
+  Opaque padd.
+  unfold normalise, xnormalise  ; simpl; intros env t.
+  rewrite Zeval_formula_compat.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o; simpl;
+    repeat rewrite eval_pol_sub;
+      repeat rewrite eval_pol_add;
+      repeat rewrite <- eval_pol_norm ; simpl in *;
+  unfold eval_expr;
+  generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+    (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+  generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+    (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
+    intuition (auto with zarith).
+  Transparent padd.
+Qed.
+
+Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
+  let (lhs,o,rhs) := t in
+    let lhs := norm lhs in
+      let rhs := norm rhs in
+    match o with
+      | OpEq  => (psub lhs rhs,Equal) :: nil
+      | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
+      | OpGt  => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
+      | OpLt  => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
+      | OpGe  => (psub lhs rhs,NonStrict) :: nil
+      | OpLe  => (psub rhs lhs,NonStrict) :: nil
+    end.
+
+Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) :=
+  List.map  (fun x => x::nil) (xnegate t).
+
+Lemma negate_correct : forall env t, eval_cnf (eval_nformula env) (negate t) <-> ~ Zeval_formula env t.
+Proof.
+Proof.
+  Opaque padd.
+  intros env t.
+  rewrite Zeval_formula_compat.
+  unfold negate, xnegate  ; simpl.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o; simpl;
+    repeat rewrite eval_pol_sub;
+      repeat rewrite eval_pol_add;
+      repeat rewrite <- eval_pol_norm ; simpl in *;
+  unfold eval_expr;
+  generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+    (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+  generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+    (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
+    intuition (auto with zarith).
+  Transparent padd.
+Qed.
+
+
+
+Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
+  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZWitness ZWeakChecker f w.
+
+(* To get a complete checker, the proof format has to be enriched *)
+
+Require Import Zdiv.
+Open Scope Z_scope.
+
+Definition ceiling (a b:Z) : Z :=
+  let (q,r) := Zdiv_eucl a b in
+    match r with
+      | Z0 => q
+      | _  => q + 1
+    end.
+
+Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x  >= b -> x >= ceiling b a.
+Proof.
+  unfold ceiling.
+  intros.
+  generalize (Z_div_mod b a H).
+  destruct (Zdiv_eucl b a).
+  intros.
+  destruct H1.
+  destruct H2.
+  subst.
+  destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
+  assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
+  destruct HH ;auto.
+  generalize (Zmult_lt_compat_l _ _ _ H3 H1).
+  auto with zarith.
+  clear H2.
+  assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
+  destruct HH ;auto.
+  assert (0 < a) by auto with zarith.
+  generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
+  intros.
+  rewrite Zmult_comm  in H4.
+  rewrite (Zmult_comm z)  in H4.
+  auto with zarith.
+Qed.
+
+(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *)
+
+Require Import QArith.
+
+Inductive ZArithProof : Type :=
+| DoneProof
+| RatProof : ZWitness -> ZArithProof -> ZArithProof
+| CutProof : ZWitness -> ZArithProof -> ZArithProof
+| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof.
+
+(* n/d <= x  -> d*x - n >= 0 *)
+(*
+Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
+  let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc  n),NonStrict).
+
+(* x <= n/d  -> d * x <= d  *)
+Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
+  let (n,d) := q in
+    (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).
+
+Definition qceiling (q:Q) : Z :=
+  let (n,d) := q in ceiling n (Zpos d).
+
+Definition qfloor (q:Q) : Z :=
+  let (n,d) := q in Zdiv n (Zpos d).
+
+Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z :=
+  (PEsub v  (PEc (qceiling  q)), NonStrict).
+
+Definition neg_nformula (f : NFormula Z) :=
+  let (e,o) := f in
+    (PEopp (PEadd e (PEc 1%Z)), o).
+
+Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f).
+Proof.
+  unfold neg_nformula.
+  destruct f.
+  simpl.
+  intros ; subst ; simpl in *.
+  split;  auto with zarith.
+Qed.
+*)
+
+(* In order to compute the 'cut', we need to express a polynomial P as a * Q + b.
+   - b is the constant
+   - a is the gcd of the other coefficient.
+*)
+Require Import Znumtheory.
+
+Definition isZ0 (x:Z) :=
+  match x with
+    | Z0 => true
+    | _  => false
+  end.
+
+Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0.
+Proof.
+  destruct x ; simpl ; intuition congruence.
+Qed.
+
+Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0.
+Proof.
+  destruct x ; simpl ; intuition congruence.
+Qed.
+
+Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1.
+
+
+Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) :=
+  match p with
+    | Pc c => (0,c)
+    | Pinj _ p => Zgcd_pol p
+    | PX p _ q =>
+      let (g1,c1) := Zgcd_pol p in
+        let (g2,c2) := Zgcd_pol q in
+          (ZgcdM (ZgcdM g1 c1) g2 , c2)
+  end.
+
+(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*)
+
+
+Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z :=
+  match p with
+    | Pc c => Pc (Zdiv c x)
+    | Pinj j p => Pinj j (Zdiv_pol p x)
+    | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x)
+  end.
+
+Inductive Zdivide_pol (x:Z): PolC Z -> Prop :=
+| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c)
+| Zdiv_Pinj : forall p, Zdivide_pol x p ->  forall j, Zdivide_pol x (Pinj j p)
+| Zdiv_PX   : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q).
+
+
+Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p  ->
+  forall env, eval_pol env p =  a * eval_pol env (Zdiv_pol p a).
+Proof.
+  intros until 2.
+  induction H0.
+  (* Pc *)
+  simpl.
+  intros.
+  apply Zdivide_Zdiv_eq ; auto.
+  (* Pinj *)
+  simpl.
+  intros.
+  apply IHZdivide_pol.
+  (* PX *)
+  simpl.
+  intros.
+  rewrite IHZdivide_pol1.
+  rewrite IHZdivide_pol2.
+  ring.
+Qed.
+
+Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0.
+Proof.
+  induction p.
+  simpl. auto with zarith.
+  simpl. auto.
+  simpl.
+  case_eq (Zgcd_pol p1).
+  case_eq (Zgcd_pol p3).
+  intros.
+  simpl.
+  unfold ZgcdM.
+  generalize (Zgcd_is_pos z1 z2).
+  generalize (Zmax_spec (Zgcd z1 z2) 1).
+  generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z).
+  generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1).
+  auto with zarith.
+Qed.
+
+Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) ->  Zdivide_pol y p.
+Proof.
+  intros.
+  induction H.
+  constructor.
+  apply Zdivide_trans with (1:= H0) ; assumption.
+  constructor. auto.
+  constructor ; auto.
+Qed.
+
+Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p.
+Proof.
+  induction p ; constructor ; auto.
+  exists c. ring.
+Qed.
+
+Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c).
+Proof.
+  intros a b c (q,Hq).
+  destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _].
+  set (g:=Zgcd a b) in *; clearbody g.
+  exists (q * a' + b').
+  symmetry in Hq. rewrite <- Zeq_plus_swap in Hq.
+  rewrite <- Hq, Hb, Ha. ring.
+Qed.
+
+Lemma Zdivide_pol_sub : forall p a b,
+  0 < Zgcd a b ->
+  Zdivide_pol a (PsubC Zminus p b) ->
+   Zdivide_pol (Zgcd a b) p.
+Proof.
+  induction p.
+  simpl.
+  intros. inversion H0.
+  constructor.
+  apply Zgcd_minus ; auto.
+  intros.
+  constructor.
+  simpl in H0. inversion H0 ; subst; clear H0.
+  apply IHp ; auto.
+  simpl. intros.
+  inv H0.
+  constructor.
+  apply Zdivide_pol_Zdivide with (1:= H3).
+  destruct (Zgcd_is_gcd a b) ; assumption.
+  apply IHp2 ; assumption.
+Qed.
+
+Lemma Zdivide_pol_sub_0 : forall p a,
+  Zdivide_pol a (PsubC Zminus p 0) ->
+   Zdivide_pol a p.
+Proof.
+  induction p.
+  simpl.
+  intros. inversion H.
+  constructor.  replace (c - 0) with c in H1 ; auto with zarith.
+  intros.
+  constructor.
+  simpl in H. inversion H ; subst; clear H.
+  apply IHp ; auto.
+  simpl. intros.
+  inv H.
+  constructor. auto.
+  apply IHp2 ; assumption.
+Qed.
+
+
+Lemma Zgcd_pol_div : forall p g c,
+  Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c).
+Proof.
+  induction p ; simpl.
+  (* Pc *)
+  intros. inv H.
+  constructor.
+  exists 0. now ring.
+  (* Pinj *)
+  intros.
+  constructor.  apply IHp ; auto.
+  (* PX *)
+  intros g c.
+  case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros.
+  inv H1.
+  unfold ZgcdM at 1.
+  destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1];
+  destruct HH1 as [HH1 HH1'] ; rewrite HH1'.
+  constructor.
+  apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2).
+  unfold ZgcdM.
+  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
+  destruct HH2.
+  rewrite H2.
+  apply Zdivide_pol_sub ; auto.
+  auto with zarith.
+  destruct HH2. rewrite H2.
+  apply Zdivide_pol_one.
+  unfold ZgcdM in HH1. unfold ZgcdM.
+  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
+  destruct HH2. rewrite H2 in *.
+  destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto.
+  destruct HH2. rewrite H2.
+  destruct (Zgcd_is_gcd 1  z); auto.
+  apply Zdivide_pol_Zdivide with (x:= z).
+  apply (IHp2 _ _ H); auto.
+  destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto.
+  constructor. apply Zdivide_pol_one.
+  apply Zdivide_pol_one.
+Qed.
+
+
+
+
+Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g))  + c.
+Proof.
+  intros.
+  rewrite <- Zdiv_pol_correct ; auto.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  unfold eval_pol. ring.
+  (**)
+  apply Zgcd_pol_div ; auto.
+Qed.
+
+
+
+Definition makeCuttingPlane (p : PolC Z) : PolC  Z * Z :=
+  let (g,c) := Zgcd_pol p in
+    if Zgt_bool g Z0
+      then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g))
+      else (p,Z0).
+
+
+Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) :=
+  let (e,op) := f in
+    match op with
+      | Equal => let (g,c) := Zgcd_pol e in
+        if andb (Zgt_bool g Z0) (andb (Zgt_bool c Z0) (negb (Zeq_bool (Zgcd g c) g)))
+          then None (* inconsistent *)
+          else Some (e, Z0,op) (* It could still be inconsistent -- but not a cut *)
+      | NonEqual => Some (e,Z0,op)
+      | Strict   =>  let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in
+        Some (p,c,NonStrict)
+      | NonStrict => let (p,c) := makeCuttingPlane e  in
+        Some (p,c,NonStrict)
+    end.
+
+Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z :=
+  let (e_z, o) := t in
+    let (e,z) := e_z in
+      (padd e (Pc z) , o).
+
+Definition is_pol_Z0 (p : PolC Z) : bool :=
+  match p with
+    | Pc Z0 => true
+    |   _   => false
+  end.
+
+Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0.
+Proof.
+  unfold is_pol_Z0.
+  destruct p ; try discriminate.
+  destruct z ; try discriminate.
+  reflexivity.
+Qed.
+
+
+
+
+
+Definition eval_Psatz  : list (NFormula Z) -> ZWitness ->  option (NFormula Z) :=
+  eval_Psatz 0 1 Zplus Zmult Zeq_bool Zle_bool.
+
+
+Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool.
+
+
+
+Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof)  {struct pf} : bool :=
+  match pf with
+    | DoneProof => false
+    | RatProof w pf =>
+      match eval_Psatz l w  with
+        | None => false
+        | Some f =>
+          if check_inconsistent f then true
+            else ZChecker (f::l) pf
+      end
+    | CutProof w pf =>
+      match eval_Psatz l w with
+        | None => false
+        | Some f =>
+          match genCuttingPlane f with
+            | None => true
+            | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf
+          end
+      end
+    | EnumProof w1 w2 pf =>
+      match eval_Psatz l w1 , eval_Psatz l w2 with
+        |  Some f1 , Some f2 =>
+          match genCuttingPlane f1 , genCuttingPlane f2 with
+            |Some (e1,z1,op1) , Some (e2,z2,op2) =>
+              match op1 , op2 with
+                | NonStrict , NonStrict =>
+                  if is_pol_Z0 (padd e1 e2)
+                    then
+                      (fix label (pfs:list ZArithProof) :=
+                        fun lb ub =>
+                          match pfs with
+                            | nil => if Zgt_bool lb ub then true else false
+                            | pf::rsr => andb (ZChecker  ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
+                          end)
+                      pf (Zopp z1)  z2
+                    else false
+                |   _    ,   _   => false
+              end
+            |   _   ,  _ => false
+          end
+        |   _   , _  => false
+      end
+      end.
+
+
+
+Fixpoint bdepth (pf : ZArithProof) : nat :=
+  match pf with
+    | DoneProof  => O
+    | RatProof _ p =>  S (bdepth p)
+    | CutProof _  p =>   S  (bdepth p)
+    | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x)   O l)
+  end.
+
+Require Import Wf_nat.
+
+Lemma in_bdepth : forall l a b  y, In y l ->  ltof ZArithProof bdepth y (EnumProof a b  l).
+Proof.
+  induction l.
+  (* nil *)
+  simpl.
+  tauto.
+  (* cons *)
+  simpl.
+  intros.
+  destruct H.
+  subst.
+  unfold ltof.
+  simpl.
+  generalize (         (fold_right
+            (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
+  intros.
+  generalize (bdepth y) ; intros.
+  generalize (Max.max_l n0 n) (Max.max_r n0 n).
+  auto with zarith.
+  generalize (IHl a0 b  y  H).
+  unfold ltof.
+  simpl.
+  generalize (      (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat
+         l)).
+  intros.
+  generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
+  auto with zarith.
+Qed.
+
+
+Lemma eval_Psatz_sound : forall env w l f',
+  make_conj (eval_nformula env) l ->
+  eval_Psatz l w  = Some f' ->  eval_nformula env f'.
+Proof.
+  intros.
+  apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto.
+  apply make_conj_in ; auto.
+Qed.
+
+Lemma makeCuttingPlane_sound : forall env e e' c,
+  eval_nformula env (e, NonStrict) ->
+  makeCuttingPlane e = (e',c) ->
+  eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)).
+Proof.
+  unfold nformula_of_cutting_plane.
+  unfold eval_nformula. unfold RingMicromega.eval_nformula.
+  unfold eval_op1.
+  intros.
+  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+  simpl.
+  (**)
+  unfold makeCuttingPlane in H0.
+  revert H0.
+  case_eq (Zgcd_pol e) ; intros g c0.
+  generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0).
+  intros.
+  inv H2.
+  change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *.
+  apply Zgcd_pol_correct_lt with (env:=env) in H1.
+  generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0).
+  auto with zarith.
+  auto with zarith.
+  (* g <= 0 *)
+  intros. inv H2. auto with zarith.
+Qed.
+
+
+Lemma cutting_plane_sound : forall env f p,
+  eval_nformula env f ->
+  genCuttingPlane f = Some p ->
+   eval_nformula env (nformula_of_cutting_plane p).
+Proof.
+  unfold genCuttingPlane.
+  destruct f as [e op].
+  destruct op.
+  (* Equal *)
+  destruct p as [[e' z] op].
+  case_eq (Zgcd_pol e) ; intros g c.
+  destruct (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))) ; [discriminate|].
+  intros. inv H1. unfold nformula_of_cutting_plane.
+  unfold eval_nformula in *.
+  unfold RingMicromega.eval_nformula in *.
+  unfold eval_op1 in *.
+  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+  simpl. rewrite H0. reflexivity.
+  (* NonEqual *)
+  intros.
+  inv H0.
+  unfold eval_nformula in *.
+  unfold RingMicromega.eval_nformula in *.
+  unfold nformula_of_cutting_plane.
+  unfold eval_op1 in *.
+  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+  simpl. auto with zarith.
+  (* Strict *)
+  destruct p as [[e' z] op].
+  case_eq (makeCuttingPlane (PsubC Zminus e 1)).
+  intros.
+  inv H1.
+  apply makeCuttingPlane_sound with (env:=env) (2:= H).
+  simpl in *.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  auto with zarith.
+  (* NonStrict *)
+  destruct p as [[e' z] op].
+  case_eq (makeCuttingPlane e).
+  intros.
+  inv H1.
+  apply makeCuttingPlane_sound with (env:=env) (2:= H).
+  assumption.
+Qed.
+
+Lemma  genCuttingPlaneNone : forall env f,
+  genCuttingPlane f = None ->
+  eval_nformula env f -> False.
+Proof.
+  unfold genCuttingPlane.
+  destruct f.
+  destruct o.
+  case_eq (Zgcd_pol p) ; intros g c.
+  case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))).
+  intros.
+  flatten_bool.
+  rewrite negb_true_iff in H5.
+  apply Zeq_bool_neq in H5.
+  contradict H5.
+  rewrite <- Zgt_is_gt_bool in H3.
+  rewrite <- Zgt_is_gt_bool in H.
+  apply Zis_gcd_gcd; auto with zarith.
+  constructor; auto with zarith.
+  change (eval_pol env p = 0) in H2.
+  rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith.
+  set (x:=eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) in *; clearbody x.
+  exists (-x).
+  rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith.
+  (**)
+  discriminate.
+  discriminate.
+  destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate.
+  destruct (makeCuttingPlane p) ; discriminate.
+Qed.
+
+
+Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl  (eval_nformula env)  l False.
+Proof.
+  induction w    using (well_founded_ind (well_founded_ltof _ bdepth)).
+  destruct w as [ | w pf | w pf | w1 w2 pf].
+  (* DoneProof *)
+  simpl. discriminate.
+  (* RatProof *)
+  simpl.
+  intro l. case_eq (eval_Psatz l w) ; [| discriminate].
+  intros f Hf.
+  case_eq (check_inconsistent f).
+  intros.
+  apply (checker_nf_sound Zsor ZSORaddon l w).
+  unfold check_normalised_formulas.  unfold eval_Psatz in Hf. rewrite Hf.
+  unfold check_inconsistent in H0. assumption.
+  intros.
+  assert (make_impl  (eval_nformula env) (f::l) False).
+   apply H with (2:= H1).
+   unfold ltof.
+   simpl.
+   auto with arith.
+  destruct f.
+  rewrite <- make_conj_impl in H2.
+  rewrite make_conj_cons in H2.
+  rewrite <- make_conj_impl.
+  intro.
+  apply H2.
+  split ; auto.
+  apply eval_Psatz_sound with (2:= Hf) ; assumption.
+  (* CutProof *)
+  simpl.
+  intro l.
+  case_eq (eval_Psatz l w) ; [ | discriminate].
+  intros f' Hlc.
+  case_eq (genCuttingPlane f').
+  intros.
+  assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False).
+   eapply (H pf) ; auto.
+   unfold ltof.
+   simpl.
+   auto with arith.
+  rewrite <- make_conj_impl in H2.
+  rewrite make_conj_cons in H2.
+  rewrite <- make_conj_impl.
+  intro.
+  apply H2.
+  split ; auto.
+  apply eval_Psatz_sound with (env:=env) in Hlc.
+  apply cutting_plane_sound with (1:= Hlc) (2:= H0).
+  auto.
+  (* genCuttingPlane = None *)
+  intros.
+  rewrite <- make_conj_impl.
+  intros.
+  apply eval_Psatz_sound with (2:= Hlc) in H2.
+  apply genCuttingPlaneNone with (2:= H2) ; auto.
+  (* EnumProof *)
+  intro.
+  simpl.
+  case_eq (eval_Psatz l w1) ; [  | discriminate].
+  case_eq (eval_Psatz l w2) ; [  | discriminate].
+  intros f1 Hf1 f2 Hf2.
+  case_eq (genCuttingPlane f2) ;  [  | discriminate].
+  destruct p as [ [p1 z1] op1].
+  case_eq (genCuttingPlane f1) ;  [  | discriminate].
+  destruct p as [ [p2 z2] op2].
+  case_eq op1 ; case_eq op2 ; try discriminate.
+  case_eq (is_pol_Z0 (padd p1 p2)) ; try discriminate.
+  intros.
+  (* get the bounds of the enum *)
+  rewrite <- make_conj_impl.
+  intro.
+  assert (-z1 <= eval_pol env p1 <= z2).
+   split.
+   apply  eval_Psatz_sound with (env:=env) in Hf2 ; auto.
+   apply cutting_plane_sound with (1:= Hf2) in H4.
+   unfold nformula_of_cutting_plane in H4.
+   unfold eval_nformula in H4.
+   unfold RingMicromega.eval_nformula in H4.
+   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4.
+   unfold eval_op1 in H4.
+   rewrite eval_pol_add in H4. simpl in H4.
+   auto with zarith.
+   (**)
+   apply is_pol_Z0_eval_pol with (env := env) in H0.
+   rewrite eval_pol_add in H0.
+   replace (eval_pol env p1) with (- eval_pol env p2) by omega.
+   apply  eval_Psatz_sound with (env:=env) in Hf1 ; auto.
+   apply cutting_plane_sound with (1:= Hf1) in H3.
+   unfold nformula_of_cutting_plane in H3.
+   unfold eval_nformula in H3.
+   unfold RingMicromega.eval_nformula in H3.
+   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3.
+   unfold eval_op1 in H3.
+   rewrite eval_pol_add in H3. simpl in H3.
+   omega.
+  revert H5.
+  set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool :=
+    match pfs with
+      | nil => if Z_gt_dec lb ub then true else false
+      | pf :: rsr =>
+        (ZChecker ((PsubC Zminus p1  lb, Equal) :: l) pf &&
+          label rsr (lb + 1)%Z ub)%bool
+    end)).
+  intros.
+  assert (HH :forall x, -z1 <= x <= z2 -> exists pr,
+    (In pr pf /\
+      ZChecker  ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z).
+  clear H.
+  clear H0 H1 H2 H3 H4 H7.
+  revert H5.
+  generalize (-z1). clear z1. intro z1.
+  revert z1 z2.
+  induction pf;simpl ;intros.
+  generalize (Zgt_cases z1 z2).
+  destruct (Zgt_bool z1 z2).
+  intros.
+  apply False_ind ; omega.
+  discriminate.
+  flatten_bool.
+  assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
+  destruct HH.
+  subst.
+  exists a ; auto.
+  assert (z1 + 1 <= x <= z2)%Z by omega.
+  destruct (IHpf _ _ H1 _ H3).
+  destruct H4.
+  exists x0 ; split;auto.
+  (*/asser *)
+  destruct (HH _ H7) as [pr [Hin Hcheker]].
+  assert (make_impl (eval_nformula env) ((PsubC Zminus p1 (eval_pol env p1),Equal) :: l) False).
+   apply (H pr);auto.
+   apply in_bdepth ; auto.
+  rewrite <- make_conj_impl in H8.
+  apply H8.
+  rewrite  make_conj_cons.
+  split ;auto.
+  unfold  eval_nformula.
+  unfold RingMicromega.eval_nformula.
+  simpl.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  unfold eval_pol. ring.
+Qed.
+
+Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
+  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZArithProof ZChecker f w.
+
+Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f  (Zeval_formula env)  f.
+Proof.
+  intros f w.
+  unfold ZTautoChecker.
+  apply (tauto_checker_sound  Zeval_formula eval_nformula).
+  apply Zeval_nformula_dec.
+  intros env t.
+  rewrite normalise_correct ; auto.
+  intros env t.
+  rewrite negate_correct ; auto.
+  intros t w0.
+  apply ZChecker_sound.
+Qed.
+
+Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof)  : list nat :=
+  match pt with
+    | DoneProof => acc
+    | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
+    | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
+    | EnumProof c1 c2 l =>
+      let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in
+        List.fold_left (xhyps_of_pt (S base)) l acc
+  end.
+
+Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt.
+
+
+(*Lemma hyps_of_pt_correct : forall pt l, *)
+
+
+
+
+
+
+Open Scope Z_scope.
+
+
+(** To ease bindings from ml code **)
+(*Definition varmap := Quote.varmap.*)
+Definition make_impl := Refl.make_impl.
+Definition make_conj := Refl.make_conj.
+
+Require VarMap.
+
+(*Definition varmap_type := VarMap.t Z. *)
+Definition env := PolEnv Z.
+Definition node := @VarMap.Node Z.
+Definition empty := @VarMap.Empty Z.
+Definition leaf := @VarMap.Leaf Z.
+
+Definition coneMember := ZWitness.
+
+Definition eval := eval_formula.
+
+Definition prod_pos_nat := prod positive nat.
+
+Definition n_of_Z (z:Z) : BinNat.N :=
+  match z with
+    | Z0 => N0
+    | Zpos p => Npos p
+    | Zneg p => N0
+  end.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
+
+
diff --git a/contrib/micromega/certificate.ml b/plugins/micromega/certificate.ml
index f4efcd08..c5760229 100644
--- a/contrib/micromega/certificate.ml
+++ b/plugins/micromega/certificate.ml
@@ -18,6 +18,7 @@
 (*open Micromega.Polynomial*)
 open Big_int
 open Num
+open Sos_lib
 
 module Mc = Micromega
 module Ml2C = Mutils.CamlToCoq
@@ -46,28 +47,28 @@ struct
  (* A monomial is represented by a multiset of variables  *)
  module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
  open Map
- 
+
  type t = int Map.t
 
  (* The monomial that corresponds to a constant *)
  let const = Map.empty
-  
+
  (* The monomial 'x' *)
  let var x = Map.add x 1 Map.empty
 
  (* Get the degre of a variable in a monomial *)
  let find x m = try find x m with Not_found -> 0
-  
+
  (* Multiply a monomial by a variable *)
  let mult x m = add x (  (find x m) + 1) m
-  
+
  (* Product of monomials *)
  let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
-  
+
  (* Total ordering of monomials *)
  let compare m1 m2 = Map.compare Pervasives.compare m1 m2
 
- let pp o m = Map.iter (fun k v -> 
+ let pp o m = Map.iter (fun k v ->
   if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k)
   else     Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m
 
@@ -76,10 +77,10 @@ struct
 end
 
 
-module  Poly :
+module Poly :
  (* A polynomial is a map of monomials *)
- (* 
-    This is probably a naive implementation 
+ (*
+    This is probably a naive implementation
     (expected to be fast enough - Coq is probably the bottleneck)
     *The new ring contribution is using a sparse Horner representation.
  *)
@@ -96,6 +97,7 @@ sig
  val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
  val pp : out_channel -> t -> unit
  val compare : t -> t -> int
+ val is_null : t -> bool
 end =
 struct
  (*normalisation bug : 0*x ... *)
@@ -104,22 +106,22 @@ struct
 
  type t = num P.t
 
- let pp o p = P.iter (fun k v -> 
+ let pp o p = P.iter (fun k v ->
   if compare_num v (Int 0) <> 0
-  then 
+  then
    if Monomial.compare Monomial.const k = 0
    then         Printf.fprintf o "%s " (string_of_num v)
-   else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p  
+   else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p
 
  (* Get the coefficient of monomial mn *)
- let get : Monomial.t -> t -> num = 
+ let get : Monomial.t -> t -> num =
   fun mn p -> try find mn p with Not_found -> (Int 0)
 
 
  (* The polynomial 1.x *)
  let variable : var -> t =
   fun  x ->  add (Monomial.var x) (Int 1) empty
-   
+
  (*The constant polynomial *)
  let constant : num -> t =
   fun c -> add (Monomial.const) c empty
@@ -127,27 +129,27 @@ struct
  (* The addition of a monomial *)
 
  let add : Monomial.t -> num -> t -> t =
-  fun mn v p -> 
+  fun mn v p ->
    let vl = (get mn p) <+> v in
     add mn vl p
 
 
- (** Design choice: empty is not a polynomial 
-     I do not remember why .... 
+ (** Design choice: empty is not a polynomial
+     I do not remember why ....
  **)
 
  (* The product by a monomial *)
  let mult : Monomial.t -> num -> t -> t =
-  fun mn v p -> 
+  fun mn v p ->
    fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
 
 
  let  addition : t -> t -> t =
   fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
-   
+
 
  let product : t -> t -> t =
-  fun p1 p2 -> 
+  fun p1 p2 ->
    fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
 
 
@@ -156,6 +158,8 @@ struct
 
  let fold = P.fold
 
+ let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p  true
+
  let compare = compare compare_num
 end
 
@@ -166,7 +170,7 @@ type 'a number_spec = {
  zero : 'a;
  unit : 'a;
  mult : 'a -> 'a -> 'a;
- eqb  : 'a -> 'a -> Mc.bool
+ eqb  : 'a -> 'a -> bool
 }
 
 let z_spec = {
@@ -177,7 +181,7 @@ let z_spec = {
  mult = Mc.zmult;
  eqb  = Mc.zeq_bool
 }
- 
+
 
 let q_spec = {
  bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
@@ -194,53 +198,53 @@ let r_spec = z_spec
 
 
 let dev_form n_spec  p =
- let rec dev_form 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 v
-   | Mc.PEmul(p1,p2) -> 
+   | Mc.PEmul(p1,p2) ->
       let p1 = dev_form p1 in
       let p2 = dev_form p2 in
-       Poly.product p1 p2 
+       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)   ->  
+   | Mc.PEpow(p,n)   ->
       let p = dev_form p in
       let n = C2Ml.n n in
-      let rec pow n = 
-       if n = 0 
+      let rec pow n =
+       if 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 monomial_to_polynomial mn =
+ Monomial.fold
+  (fun v i acc ->
    let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
     if acc = Mc.PEc (Mc.Zpos Mc.XH)
-    then mn 
+    then mn
     else Mc.PEmul(mn,acc))
-  mn 
+  mn
   (Mc.PEc (Mc.Zpos Mc.XH))
-  
-let list_to_polynomial vars l = 
+
+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 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 
+  | c::l -> if c =/  (Int 0) then xtopoly p (i+1) l
     else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
-    let mn = 
+    let mn =
      if c =  Mc.PEc (Mc.Zpos Mc.XH)
      then var i
      else Mc.PEmul (c,var i) in
     let p' = if p = Mc.PEc Mc.Z0 then mn else
       Mc.PEadd (mn, p) in
      xtopoly p' (i+1) l in
-  
+
   xtopoly (Mc.PEc Mc.Z0) 0 l
 
 let rec fixpoint f x =
@@ -255,56 +259,56 @@ let rec fixpoint f x =
 
 
 
-let  rec_simpl_cone n_spec e = 
- let simpl_cone = 
+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.S_Mult(t1, t2) -> 
-    simpl_cone  (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.S_Add(t1,t2)  -> 
-    simpl_cone (Mc.S_Add (rec_simpl_cone t1, rec_simpl_cone t2))
+ | 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 
+
+type cone_prod =
+  Const of cone
+  | Ideal of cone *cone
+  | Mult of cone * cone
   | Other of cone
 and cone =   Mc.zWitness
 
 
 
 let factorise_linear_cone c =
- 
- let rec cone_list  c l = 
+
+ let rec cone_list  c l =
   match c with
-   | Mc.S_Add (x,r) -> cone_list  r (x::l)
+   | Mc.PsatzAdd (x,r) -> cone_list  r (x::l)
    |  _        ->  c :: l in
-  
+
  let factorise c1 c2 =
   match c1 , c2 with
-   | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') -> 
-      if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None
-   | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') -> 
-      if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None
+   | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
+      if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+   | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
+      if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
    |  _     -> None in
-  
+
  let rec rebuild_cone l pending  =
   match l with
    | [] -> (match pending with
-      | None -> Mc.S_Z
+      | None -> Mc.PsatzZ
       | Some p -> p
      )
-   | e::l -> 
+   | e::l ->
       (match pending with
-       | None -> rebuild_cone l (Some e) 
+       | None -> rebuild_cone l (Some e)
        | Some p -> (match factorise p e with
-          | None -> Mc.S_Add(p, rebuild_cone l (Some e))
+          | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
           | Some f -> rebuild_cone l (Some f) )
       ) in
 
@@ -312,15 +316,15 @@ let factorise_linear_cone c =
 
 
 
-(* The binding with Fourier might be a bit obsolete 
+(* The binding with Fourier might be a bit obsolete
    -- how does it handle equalities ? *)
 
 (* Certificates are elements of the cone such that P = 0  *)
 
 (* To begin with, we search for certificates of the form:
-   a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0   
+   a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0
    where pi >= 0 qi > 0
-   ai >= 0 
+   ai >= 0
    bi >= 0
    Sum bi + c >= 1
    This is a linear problem: each monomial is considered as a variable.
@@ -332,184 +336,232 @@ let factorise_linear_cone c =
 open Mfourier
    (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*)
    (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*)
-module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)
+(*module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)*)
 
-module Vect = Fourier.Vect
-open Fourier.Cstr
+(*module Vect = Fourier.Vect*)
+(*open Fourier.Cstr*)
 
 (* fold_left followed by a rev ! *)
 
-let constrain_monomial mn l  = 
+let constrain_monomial mn l  =
  let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
   if mn = Monomial.const
-  then  
-   { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; 
-     op = Eq ; 
+  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 ; 
+   { 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 = 
+
+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 ; 
+   | (_,_)::l ->
+      {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ;
+       op = Ge ;
        cst = Int 0 }  :: (xpositivity (i+1) l)
  in
   xpositivity 0 l
 
 
 let string_of_op = function
- | Mc.Strict -> "> 0" 
- | Mc.NonStrict -> ">= 0" 
+ | Mc.Strict -> "> 0"
+ | Mc.NonStrict -> ">= 0"
  | Mc.Equal -> "= 0"
  | Mc.NonEqual -> "<> 0"
 
 
 
-(* If the certificate includes at least one strict inequality, 
+(* If the certificate includes at least one strict inequality,
    the obtained polynomial can also be 0 *)
 let build_linear_system l =
 
  (* Gather the monomials:  HINT add up of the polynomials *)
  let l' = List.map fst l in
- let monomials = 
+ let monomials =
   List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l'
  in  (* For each monomial, compute a constraint *)
- let s0 = 
+ let s0 =
   Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in
   (* 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 
+                            (List.map (fun (x,y) ->
+			      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 ; 
+  {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
- 
-(* For Q, this is a pity that the certificate has been scaled 
+
+(* For Q, this is a pity that the certificate has been scaled
    -- at a lower layer, certificates are using nums... *)
-let make_certificate n_spec cert li = 
+let make_certificate n_spec (cert,li) =
  let bint_to_cst = n_spec.bigint_to_number in
   match cert with
-   | [] -> None
-   | e::cert' -> 
+   | [] -> failwith "empty_certificate"
+   | e::cert' ->
       let cst = match compare_big_int e zero_big_int with
-       | 0 -> Mc.S_Z
-       | 1 ->  Mc.S_Pos (bint_to_cst e) 
-       | _ -> failwith "positivity error" 
+       | 0 -> Mc.PsatzZ
+       | 1 ->  Mc.PsatzC (bint_to_cst e)
+       | _ -> failwith "positivity error"
       in
       let rec scalar_product cert l =
        match cert with
-        | [] -> Mc.S_Z
+        | [] -> Mc.PsatzZ
         | c::cert -> match l with
            | [] -> failwith "make_certificate(1)"
-           | i::l ->  
+           | i::l ->
               let r = scalar_product cert l in
                match compare_big_int c  zero_big_int with
-                | -1 -> Mc.S_Add (
-                   Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)), 
+                | -1 -> Mc.PsatzAdd (
+                   Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
                    r)
                 | 0  -> r
-                | _ ->  Mc.S_Add (
-                   Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)),
+                | _ ->  Mc.PsatzAdd (
+                   Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
                    r) in
-       
-      Some ((factorise_linear_cone 
-              (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li)))))
+
+        ((factorise_linear_cone
+             (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li)))))
 
 
 exception Found of Monomial.t
- 
-let raw_certificate l = 
+
+exception Strict
+
+let primal l =
+  let vr = ref 0 in
+  let module Mmn = Map.Make(Monomial) in
+
+  let vect_of_poly map p =
+    Poly.fold (fun mn vl (map,vect) ->
+      if mn = Monomial.const
+      then (map,vect)
+      else
+	let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in
+	  (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in
+
+  let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
+
+  let cmp x y = Pervasives.compare (fst x) (fst y) in
+
+   snd (List.fold_right (fun  (p,op) (map,l) ->
+      let (mp,vect) = vect_of_poly map p in
+      let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
+
+	(mp,cstr::l)) l (Mmn.empty,[]))
+
+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 ; *)
+
+
  let sys = build_linear_system l in
-  try 
+
+   try
    match Fourier.find_point sys with
-    | None -> None
-    | Some cert ->  Some (rats_to_ints (Vect.to_list cert)) 
+    | Inr _ -> None
+    | Inl cert ->  Some (rats_to_ints (Vect.to_list cert))
        (* should not use rats_to_ints *)
-  with x -> 
-   if debug 
-   then (Printf.printf "raw certificate %s" (Printexc.to_string x);   
+  with x ->
+   if debug
+   then (Printf.printf "raw certificate %s" (Printexc.to_string x);
          flush stdout) ;
    None
 
 
-let simple_linear_prover to_constant l =
+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 ->
+    (* Fourier elimination should handle > *)
+    dual_raw_certificate l
+
+
+let simple_linear_prover (*to_constant*) l =
  let (lc,li) = List.split l in
   match raw_certificate lc with
    |  None -> None (* No certificate *)
-   | Some cert -> make_certificate to_constant cert li
-      
-      
+   | Some cert -> (* make_certificate to_constant*)Some (cert,li)
+
+
 
 let linear_prover n_spec l  =
  let li = List.combine l (interval 0 (List.length l -1)) in
- let (l1,l') = List.partition 
-  (fun (x,_) -> if snd' x = Mc.NonEqual then true else false) li in
- let l' = List.map 
-  (fun (c,i) -> let (Mc.Pair(x,y)) = c in 
-                 match y with 
-                   Mc.NonEqual -> failwith "cannot happen" 
+ let (l1,l') = List.partition
+  (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in
+ let l' = List.map
+  (fun ((x,y),i) -> match y with
+                   Mc.NonEqual -> failwith "cannot happen"
                   |  y -> ((dev_form n_spec x, y),i)) l' in
-  
-  simple_linear_prover n_spec l' 
+
+  simple_linear_prover (*n_spec*) l'
 
 
 let linear_prover n_spec l  =
  try linear_prover n_spec l with
    x -> (print_string (Printexc.to_string x); None)
 
+let linear_prover_with_cert spec l =
+  match linear_prover spec l with
+    | None -> None
+    | Some cert -> Some (make_certificate spec cert)
+
+
+
 (* zprover.... *)
 
 (* I need to gather the set of variables --->
-   Then go for fold 
+   Then go for fold
    Once I have an interval, I need a certificate : 2 other fourier elims.
-   (I could probably get the certificate directly 
+   (I could probably get the certificate directly
    as it is done in the fourier contrib.)
 *)
 
 let make_linear_system l =
  let l' = List.map fst l in
- let monomials = List.fold_left (fun acc p -> Poly.addition p acc) 
+ let monomials = List.fold_left (fun acc p -> Poly.addition p acc)
   (Poly.constant (Int 0)) l' in
- let monomials = Poly.fold 
+ let monomials = Poly.fold
   (fun mn _ l -> if 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 ; 
+  (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)
 
 
-open Interval 
 let pplus x y = Mc.PEadd(x,y)
 let pmult x y = Mc.PEmul(x,y)
 let pconst x = Mc.PEc x
 let popp x = Mc.PEopp x
- 
+
 let debug = false
- 
+
 (* keep track of enumerated vectors *)
-let rec mem p x  l = 
+let rec mem p x  l =
  match l with  [] -> false | e::l -> if p x e then true else mem p x l
 
-let rec remove_assoc 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 = Vect.compare x y = 0
 
@@ -519,105 +571,111 @@ let  remove e  l  = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
 (* The prover is (probably) incomplete --
    only searching for naive cutting planes *)
 
-let candidates sys = 
+let candidates sys =
  let ll = List.fold_right (
-  fun (Mc.Pair(e,k)) r -> 
-   match k with 
+  fun (e,k) r ->
+   match k with
     | Mc.NonStrict -> (dev_form z_spec e , Ge)::r
-    | Mc.Equal     ->  (dev_form z_spec e , Eq)::r 
+    | Mc.Equal     ->  (dev_form z_spec e , Eq)::r
        (* we already know the bound -- don't compute it again *)
     | _     -> failwith "Cannot happen candidates") sys [] in
 
  let (sys,var_mn) = make_linear_system ll in
  let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in
-  (List.fold_left (fun l cstr ->   
+  (List.fold_left (fun l cstr ->
    let gcd = Big_int (Vect.gcd cstr.coeffs) in
-    if gcd =/ (Int 1) && cstr.op = Eq 
-    then l 
+    if gcd =/ (Int 1) && cstr.op = Eq
+    then l
     else  (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars
 
 
-let rec xzlinear_prover planes sys = 
+
+
+let rec xzlinear_prover planes sys =
  match linear_prover z_spec sys with
-  | Some prf -> Some (Mc.RatProof prf)
+  | Some prf ->  Some (Mc.RatProof (make_certificate z_spec prf,Mc.DoneProof))
   | None     -> (* find the candidate with the smallest range *)
      (* Grrr - linear_prover is also calling 'make_linear_system' *)
-     let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with 
-       Mc.NonEqual -> r  
-      | k -> (dev_form z_spec e , 
+     let ll = List.fold_right (fun (e,k) r -> match k with
+       Mc.NonEqual -> r
+      | k -> (dev_form z_spec e ,
              match k with
-               Mc.NonStrict -> Ge 
+               Mc.NonStrict -> Ge
               | Mc.Equal              -> Eq
               | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in
      let (ll,var) = make_linear_system ll in
-     let candidates = List.fold_left (fun  acc vect -> 
+     let candidates = List.fold_left (fun  acc vect ->
       match Fourier.optimise vect ll with
        | None -> acc
-       | Some i -> 
+       | Some i ->
 (*	  Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *)
-	  flush stdout ; 
+	  flush stdout ;
 	  (vect,i) ::acc)  [] planes in
 
-     let smallest_interval = 
-      match List.fold_left (fun (x1,i1) (x2,i2) -> 
-       if smaller_itv i1 i2 
-       then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates 
+     let smallest_interval =
+      match List.fold_left (fun (x1,i1) (x2,i2) ->
+       if Itv.smaller_itv i1 i2
+       then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates
       with
-       | (x,Itv(Some i, Some j))  -> Some(i,x,j)
-       | (x,Point n) ->  Some(n,x,n)
+       | (x,(Some i, Some j))  -> Some(i,x,j)
        |   x        ->   None (* This might be a cutting plane *)
       in
       match smallest_interval with
-       | Some (lb,e,ub) -> 
-          let (lbn,lbd) = 
+       | Some (lb,e,ub) ->
+          let (lbn,lbd) =
            (Ml2C.bigint (sub_big_int (numerator lb)  unit_big_int),
            Ml2C.bigint (denominator lb)) in
-          let (ubn,ubd) = 
-           (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , 
+          let (ubn,ubd) =
+           (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) ,
            Ml2C.bigint (denominator ub)) in
           let expr = list_to_polynomial var (Vect.to_list e) in
-           (match 
+           (match
              (*x <= ub ->  x  > ub *)
-             linear_prover  z_spec 
-              (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst  ubn)),
+             linear_prover  z_spec
+              ((pplus (pmult (pconst ubd) expr) (popp (pconst  ubn)),
                       Mc.NonStrict) :: sys),
             (* lb <= x  -> lb > x *)
-            linear_prover z_spec 
-             (Mc.Pair( pplus  (popp (pmult  (pconst lbd) expr)) (pconst lbn) ,  
-                     Mc.NonStrict)::sys) 
+            linear_prover z_spec
+             ((pplus (popp (pmult  (pconst lbd) expr)) (pconst lbn),
+                     Mc.NonStrict)::sys)
             with
-             | Some cub , Some clb  ->   
-                (match zlinear_enum  (remove e planes)   expr 
-                  (ceiling_num lb)  (floor_num ub) sys 
+             | Some cub , Some clb  ->
+                (match zlinear_enum  (remove e planes)   expr
+                  (ceiling_num lb)  (floor_num ub) sys
                  with
                   | None -> None
-                  | Some prf -> 
-                     Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf)))
+                  | Some prf ->
+		      let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in
+
+                     Some (Mc.EnumProof((*Ml2C.q lb,expr,Ml2C.q ub,*) bound_proof clb, bound_proof cub,prf)))
              | _ -> None
            )
        |  _ -> None
-and zlinear_enum  planes expr clb cub l = 
+and zlinear_enum  planes expr clb cub l =
  if clb >/  cub
- then Some Mc.Nil
- else 
+ then Some []
+ else
   let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in
-  let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in
+  let sys' = (pexpr, Mc.Equal)::l in
    (*let enum =  *)
    match xzlinear_prover planes sys' with
     | None -> if debug then print_string "zlp?"; None
     | Some prf -> if debug then print_string "zlp!";
     match zlinear_enum planes expr (clb +/ (Int 1)) cub l with
      | None -> None
-     | Some prfl -> Some (Mc.Cons(prf,prfl))
+     | Some prfl -> Some (prf :: prfl)
 
-let zlinear_prover sys =  
+let zlinear_prover sys =
  let candidates = candidates sys in
- (*  Printf.printf "candidates %d" (List.length candidates) ; *) 
- xzlinear_prover candidates sys
+ (*  Printf.printf "candidates %d" (List.length candidates) ; *)
+ (*let t0 = Sys.time () in*)
+ let res = xzlinear_prover candidates sys in
+   (*Printf.printf "Time prover : %f" (Sys.time () -. t0) ;*) res
 
-open Sos
+open Sos_types
+open Mutils
 
-let rec scale_term t = 
+let rec scale_term t =
  match t with
   | Zero    -> unit_big_int , Zero
   | Const n ->  (denominator n) , Const (Big_int (numerator n))
@@ -650,7 +708,7 @@ let get_index_of_ith_match f i l  =
   match l with
    | [] -> failwith "bad index"
    | e::l -> if f e
-     then 
+     then
        (if j = i then res else get (j+1) (res+1) l )
      else get j (res+1) l in
   get 0 0 l
@@ -664,19 +722,19 @@ let rec scale_certificate pos = match pos with
  | Rational_eq n ->  (denominator n) , Rational_eq (Big_int (numerator n))
  | 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 
+ | Square t -> let s,t' =  scale_term t in
 		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)
- | Sum (y, z) -> let s1,y1 = scale_certificate y 
+ | 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'), 
+    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) -> 
+ | Product (y, z) ->
     let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
      mult_big_int s1 s2 , Product (y1,y2)
 
@@ -685,7 +743,7 @@ 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 
+  | 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)
@@ -694,26 +752,36 @@ open Micromega
   | Sub(t1,t2) ->  PEsub (term_to_q_expr t1,  term_to_q_expr t2)
   | _ -> failwith "term_to_q_expr: not implemented"
 
-let  q_cert_of_pos  pos = 
+ 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.S_In (Ml2C.nat i)
-  | Axiom_le i ->  Mc.S_In (Ml2C.nat i)
-  | Axiom_lt i ->  Mc.S_In (Ml2C.nat i)
-  | Monoid l  -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
-  | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if compare_num n (Int 0) = 0 then Mc.S_Z else
-      Mc.S_Pos (Ml2C.q   n)
-  | Square t -> Mc.S_Square (term_to_q_expr  t)
-  | Eqmul (t, y) -> Mc.S_Ideal(term_to_q_expr t, _cert_of_pos y)
-  | Sum (y, z) -> Mc.S_Add  (_cert_of_pos y, _cert_of_pos z)
-  | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+   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 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)
 
 
  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 
+  | 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)
@@ -722,19 +790,24 @@ let  q_cert_of_pos  pos =
   | Sub(t1,t2) ->  PEsub (term_to_z_expr t1,  term_to_z_expr t2)
   | _ -> failwith "term_to_z_expr: not implemented"
 
-let  z_cert_of_pos  pos = 
+ let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.zplus  Mc.zmult Mc.zminus Mc.zopp 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.S_In (Ml2C.nat i)
-  | Axiom_le i ->  Mc.S_In (Ml2C.nat i)
-  | Axiom_lt i ->  Mc.S_In (Ml2C.nat i)
-  | Monoid l  -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
-  | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if compare_num n (Int 0) = 0 then Mc.S_Z else
-      Mc.S_Pos (Ml2C.bigint (big_int_of_num  n))
-  | Square t -> Mc.S_Square (term_to_z_expr  t)
-  | Eqmul (t, y) -> Mc.S_Ideal(term_to_z_expr t, _cert_of_pos y)
-  | Sum (y, z) -> Mc.S_Add  (_cert_of_pos y, _cert_of_pos z)
-  | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+   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 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) -> 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)
 
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
new file mode 100644
index 00000000..abe4b368
--- /dev/null
+++ b/plugins/micromega/coq_micromega.ml
@@ -0,0 +1,1710 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(* ** Toplevel definition of tactics **                                 *)
+(*                                                                      *)
+(* - Modules ISet, M, Mc, Env, Cache, CacheZ                            *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2009                             *)
+(*                                                                      *)
+(************************************************************************)
+
+open Mutils
+
+(**
+  * Debug flag 
+  *)
+
+let debug = false
+
+(**
+  * Time function
+  *)
+
+let time str f x =
+ let t0 = (Unix.times()).Unix.tms_utime in
+ let res = f x in
+ let t1 = (Unix.times()).Unix.tms_utime in
+  (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ;
+		     flush stdout);
+  res
+
+(**
+  * Initialize a tag type to the Tag module declaration (see Mutils).
+  *)
+
+type tag = Tag.t
+
+(**
+  * An atom is of the form:
+  *   pExpr1 {<,>,=,<>,<=,>=} pExpr2
+  * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are
+  * parametrized by 'cst, which is used as the type of constants.
+  *)
+
+type 'cst atom = 'cst Micromega.formula
+
+(**
+  * Micromega's encoding of formulas.
+  * By order of appearance: boolean constants, variables, atoms, conjunctions,
+  * disjunctions, negation, implication.
+  *)
+
+type 'cst formula =
+  | TT
+  | FF
+  | X of Term.constr
+  | A of 'cst atom * tag * Term.constr
+  | C of 'cst formula * 'cst formula
+  | D of 'cst formula * 'cst formula
+  | N of 'cst formula
+  | I of 'cst formula * Names.identifier option * 'cst formula
+
+(**
+  * Formula pretty-printer.
+  *)
+
+let rec pp_formula o f =
+  match f with
+    | TT -> output_string  o "tt"
+    | FF -> output_string  o "ff"
+    | X c -> output_string o "X "
+    | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t
+    | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2
+    | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2
+    | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)"
+	pp_formula f1
+	  (match n with
+	    | Some id -> Names.string_of_id id
+	    | None -> "") pp_formula f2
+    | N(f) -> Printf.fprintf o "N(%a)" pp_formula f
+
+(**
+  * Collect the identifiers of a (string of) implications. Implication labels
+  * are inherited from Coq/CoC's higher order dependent type constructor (Pi).
+  *)
+
+let rec ids_of_formula f =
+  match f with
+    | I(f1,Some id,f2) -> id::(ids_of_formula f2)
+    | _                -> []
+
+(**
+  * A clause is a list of (tagged) nFormulas.
+  * nFormulas are normalized formulas, i.e., of the form:
+  *   cPol {=,<>,>,>=} 0
+  * with cPol compact polynomials (see the Pol inductive type in EnvRing.v).
+  *)
+
+type 'cst clause = ('cst Micromega.nFormula * tag) list
+
+(**
+  * A CNF is a list of clauses.
+  *)
+
+type 'cst cnf = ('cst clause) list
+
+(**
+  * True and False are empty cnfs and clauses.
+  *)
+
+let tt : 'cst cnf = []
+
+let ff : 'cst cnf = [ [] ]
+
+(**
+  * A refinement of cnf with tags left out. This is an intermediary form
+  * between the cnf tagged list representation ('cst cnf) used to solve psatz,
+  * and the freeform formulas ('cst formula) that is retrieved from Coq.
+  *)
+
+type 'cst mc_cnf = ('cst Micromega.nFormula) list list
+
+(**
+  * From a freeform formula, build a cnf.
+  * The parametric functions negate and normalize are theory-dependent, and
+  * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v
+  * and RingMicromega.v).
+  *)
+
+let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) =
+ let negate a t =
+  List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in
+
+ let normalise a t =
+  List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in
+
+ let and_cnf x y = x @ y in
+
+ let or_clause_cnf t f =  List.map (fun x -> t@x) f in
+
+ let rec or_cnf f f' =
+  match f with
+   | [] -> tt
+   | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
+
+ let rec xcnf (polarity : bool) f =
+  match f with
+   | TT -> if polarity then tt else ff
+   | FF  -> if polarity then ff else tt
+   | X p -> if polarity then ff else ff
+   | A(x,t,_) -> if polarity then normalise x t else negate x t
+   | N(e)  -> xcnf (not polarity) e
+   | C(e1,e2) ->
+      (if polarity then and_cnf else or_cnf) (xcnf polarity e1) (xcnf polarity e2)
+   | D(e1,e2)  ->
+      (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2)
+   | I(e1,_,e2) ->
+      (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in
+
+  xcnf true f
+
+(**
+  * MODULE: Ordered set of integers.
+  *)
+
+module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+
+(**
+  * 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.
+  *)
+
+let selecti s m =
+  let rec xselecti i m =
+    match m with
+      | [] -> []
+      | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in
+    xselecti 0 m
+
+(**
+  * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted
+  * code. This includes initializing Caml variables based on Coq terms, parsing
+  * various Coq expressions into Caml, and dumping Caml expressions into Coq.
+  *
+  * Opened here and in csdpcert.ml.
+  *)
+
+module M =
+struct
+
+  open Coqlib
+  open Term
+
+  (**
+    * Location of the Coq libraries.
+    *)
+
+  let logic_dir = ["Coq";"Logic";"Decidable"]
+  let coq_modules =
+   init_modules @
+    [logic_dir] @ arith_modules @ zarith_base_modules @
+    [ ["Coq";"Lists";"List"];
+      ["ZMicromega"];
+      ["Tauto"];
+      ["RingMicromega"];
+      ["EnvRing"];
+      ["Coq"; "micromega"; "ZMicromega"];
+      ["Coq" ; "micromega" ; "Tauto"];
+      ["Coq" ; "micromega" ; "RingMicromega"];
+      ["Coq" ; "micromega" ; "EnvRing"];
+      ["Coq";"QArith"; "QArith_base"];
+      ["Coq";"Reals" ; "Rdefinitions"];
+      ["Coq";"Reals" ; "Rpow_def"];
+      ["LRing_normalise"]]
+
+  (**
+    * Initialization : a large amount of Caml symbols are derived from
+    * ZMicromega.v
+    *)
+
+  let init_constant = gen_constant_in_modules "ZMicromega" init_modules
+  let constant = gen_constant_in_modules "ZMicromega" coq_modules
+  (* let constant = gen_constant_in_modules "Omicron" coq_modules *)
+
+  let coq_and = lazy (init_constant "and")
+  let coq_or = lazy (init_constant "or")
+  let coq_not = lazy (init_constant "not")
+  let coq_iff = lazy (init_constant "iff")
+  let coq_True = lazy (init_constant "True")
+  let coq_False = lazy (init_constant "False")
+
+  let coq_cons = lazy (constant "cons")
+  let coq_nil = lazy (constant "nil")
+  let coq_list = lazy (constant "list")
+
+  let coq_O = lazy (init_constant "O")
+  let coq_S = lazy (init_constant "S")
+  let coq_nat = lazy (init_constant "nat")
+
+  let coq_NO = lazy
+   (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]]  "N0")
+  let coq_Npos = lazy
+   (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]]  "Npos")
+   (* let coq_n = lazy (constant "N")*)
+
+  let coq_pair = lazy (constant "pair")
+  let coq_None = lazy (constant "None")
+  let coq_option = lazy (constant "option")
+  let coq_positive = lazy (constant "positive")
+  let coq_xH = lazy (constant "xH")
+  let coq_xO = lazy (constant "xO")
+  let coq_xI = lazy (constant "xI")
+
+  let coq_N0 = lazy (constant "N0")
+  let coq_N0 = lazy (constant "Npos")
+
+  let coq_Z = lazy (constant "Z")
+  let coq_Q = lazy (constant "Q")
+  let coq_R = lazy (constant "R")
+
+  let coq_ZERO = lazy (constant  "Z0")
+  let coq_POS = lazy (constant  "Zpos")
+  let coq_NEG = lazy (constant  "Zneg")
+
+  let coq_Build_Witness = lazy (constant "Build_Witness")
+
+  let coq_Qmake = lazy (constant "Qmake")
+  let coq_R0    = lazy (constant "R0")
+  let coq_R1    = lazy (constant "R1")
+
+  let coq_proofTerm = lazy (constant "ZArithProof")
+  let coq_doneProof = lazy (constant "DoneProof")
+  let coq_ratProof = lazy (constant "RatProof")
+  let coq_cutProof = lazy (constant "CutProof")
+  let coq_enumProof = lazy (constant "EnumProof")
+
+  let coq_Zgt = lazy (constant "Zgt")
+  let coq_Zge = lazy (constant "Zge")
+  let coq_Zle = lazy (constant "Zle")
+  let coq_Zlt = lazy (constant "Zlt")
+  let coq_Eq  = lazy (init_constant "eq")
+
+  let coq_Zplus = lazy (constant "Zplus")
+  let coq_Zminus = lazy (constant "Zminus")
+  let coq_Zopp = lazy (constant "Zopp")
+  let coq_Zmult = lazy (constant "Zmult")
+  let coq_Zpower = lazy (constant "Zpower")
+
+  let coq_Qgt = lazy (constant "Qgt")
+  let coq_Qge = lazy (constant "Qge")
+  let coq_Qle = lazy (constant "Qle")
+  let coq_Qlt = lazy (constant "Qlt")
+  let coq_Qeq = lazy (constant "Qeq")
+
+  let coq_Qplus = lazy (constant "Qplus")
+  let coq_Qminus = lazy (constant "Qminus")
+  let coq_Qopp = lazy (constant "Qopp")
+  let coq_Qmult = lazy (constant "Qmult")
+  let coq_Qpower = lazy (constant "Qpower")
+
+  let coq_Rgt = lazy (constant "Rgt")
+  let coq_Rge = lazy (constant "Rge")
+  let coq_Rle = lazy (constant "Rle")
+  let coq_Rlt = lazy (constant "Rlt")
+
+  let coq_Rplus = lazy (constant "Rplus")
+  let coq_Rminus = lazy (constant "Rminus")
+  let coq_Ropp = lazy (constant "Ropp")
+  let coq_Rmult = lazy (constant "Rmult")
+  let coq_Rpower = lazy (constant "pow")
+
+  let coq_PEX = lazy (constant "PEX" )
+  let coq_PEc = lazy (constant"PEc")
+  let coq_PEadd = lazy (constant "PEadd")
+  let coq_PEopp = lazy (constant "PEopp")
+  let coq_PEmul = lazy (constant "PEmul")
+  let coq_PEsub = lazy (constant "PEsub")
+  let coq_PEpow = lazy (constant "PEpow")
+
+  let coq_PX = lazy (constant "PX" )
+  let coq_Pc = lazy (constant"Pc")
+  let coq_Pinj = lazy (constant "Pinj")
+
+  let coq_OpEq = lazy (constant "OpEq")
+  let coq_OpNEq = lazy (constant "OpNEq")
+  let coq_OpLe = lazy (constant "OpLe")
+  let coq_OpLt = lazy (constant  "OpLt")
+  let coq_OpGe = lazy (constant "OpGe")
+  let coq_OpGt = lazy (constant  "OpGt")
+
+  let coq_PsatzIn = lazy (constant "PsatzIn")
+  let coq_PsatzSquare = lazy (constant "PsatzSquare")
+  let coq_PsatzMulE = lazy (constant "PsatzMulE")
+  let coq_PsatzMultC = lazy (constant "PsatzMulC")
+  let coq_PsatzAdd  = lazy (constant "PsatzAdd")
+  let coq_PsatzC  = lazy (constant "PsatzC")
+  let coq_PsatzZ    = lazy (constant "PsatzZ")
+  let coq_coneMember    = lazy (constant "coneMember")
+
+  let coq_make_impl = lazy
+   (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl")
+  let coq_make_conj = lazy
+   (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj")
+
+  let coq_TT = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "TT")
+  let coq_FF = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "FF")
+  let coq_And = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "Cj")
+  let coq_Or = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]    "D")
+  let coq_Neg = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "N")
+  let coq_Atom = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "A")
+  let coq_X = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "X")
+  let coq_Impl = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "I")
+  let coq_Formula = lazy
+   (gen_constant_in_modules "ZMicromega"
+     [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "BFormula")
+
+  (**
+    * Initialization : a few Caml symbols are derived from other libraries;
+    * QMicromega, ZArithRing, RingMicromega.
+    *)
+
+  let coq_QWitness = lazy
+   (gen_constant_in_modules "QMicromega"
+     [["Coq"; "micromega"; "QMicromega"]] "QWitness")
+  let coq_ZWitness = lazy
+   (gen_constant_in_modules "QMicromega"
+     [["Coq"; "micromega"; "ZMicromega"]] "ZWitness")
+
+  let coq_N_of_Z = lazy
+   (gen_constant_in_modules "ZArithRing"
+     [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
+
+  let coq_Build = lazy
+   (gen_constant_in_modules "RingMicromega"
+     [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ]
+     "Build_Formula")
+  let coq_Cstr = lazy
+   (gen_constant_in_modules "RingMicromega"
+     [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
+
+  (**
+    * Parsing and dumping : transformation functions between Caml and Coq
+    * data-structures.
+    *
+    * dump_*    functions go from Micromega to Coq terms
+    * parse_*   functions go from Coq to Micromega terms
+    * pp_*      functions pretty-print Coq terms.
+    *)
+
+  (* Error datastructures *)
+
+  type parse_error  =
+    | Ukn
+    | BadStr of string
+    | BadNum of int
+    | BadTerm of Term.constr
+    | Msg   of string
+    | Goal of (Term.constr list ) * Term.constr * parse_error
+
+  let string_of_error = function
+   | Ukn -> "ukn"
+   | BadStr s -> s
+   | BadNum i -> string_of_int i
+   | BadTerm _ -> "BadTerm"
+   | Msg  s    -> s
+   | Goal _    -> "Goal"
+
+  exception ParseError
+
+  (* A simple but useful getter function *)
+
+  let get_left_construct term =
+   match Term.kind_of_term term with
+    | Term.Construct(_,i) -> (i,[| |])
+    | Term.App(l,rst) ->
+       (match Term.kind_of_term l with
+        | Term.Construct(_,i) -> (i,rst)
+        |   _     -> raise ParseError
+       )
+    | _ ->   raise ParseError
+
+  (* Access the Micromega module *)
+  
+  module Mc = Micromega
+
+  (* parse/dump/print from numbers up to expressions and formulas *)
+
+  let rec parse_nat term =
+   let (i,c) = get_left_construct term in
+    match i with
+     | 1 -> Mc.O
+     | 2 -> Mc.S (parse_nat (c.(0)))
+     | i -> raise ParseError
+
+  let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
+
+  let rec dump_nat x =
+   match x with
+    | Mc.O -> Lazy.force coq_O
+    | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |])
+
+  let rec parse_positive term =
+   let (i,c) = get_left_construct term in
+    match i with
+     | 1 -> Mc.XI (parse_positive c.(0))
+     | 2 -> Mc.XO (parse_positive c.(0))
+     | 3 -> Mc.XH
+     | i -> raise ParseError
+
+  let rec dump_positive x =
+   match x with
+    | Mc.XH -> Lazy.force coq_xH
+    | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |])
+    | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |])
+
+  let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
+
+  let rec dump_n x =
+   match x with
+    | Mc.N0 -> Lazy.force coq_N0
+    | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
+
+  let rec dump_index x =
+   match x with
+    | Mc.XH -> Lazy.force coq_xH
+    | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |])
+    | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |])
+
+  let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)
+
+  let rec dump_n x =
+   match x with
+    | Mc.N0 -> Lazy.force coq_NO
+    | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |])
+
+  let rec pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
+
+  let dump_pair t1 t2 dump_t1 dump_t2 (x,y) =
+   Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
+
+  let rec parse_z term =
+   let (i,c) = get_left_construct term in
+    match i with
+     | 1 -> Mc.Z0
+     | 2 -> Mc.Zpos (parse_positive c.(0))
+     | 3 -> Mc.Zneg (parse_positive c.(0))
+     | i -> raise ParseError
+
+  let dump_z x =
+   match x with
+    | Mc.Z0 ->Lazy.force coq_ZERO
+    | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|])
+    | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|])
+
+  let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x)
+
+  let dump_num bd1 =
+   Term.mkApp(Lazy.force coq_Qmake,
+             [|dump_z (CamlToCoq.bigint (numerator bd1)) ;
+               dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |])
+
+  let dump_q q =
+   Term.mkApp(Lazy.force coq_Qmake,
+             [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|])
+
+  let parse_q term =
+     match Term.kind_of_term term with
+       | Term.App(c, args) -> if c = Lazy.force coq_Qmake then
+             {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
+       else raise ParseError
+   |  _ -> raise ParseError
+
+  let rec parse_list parse_elt term =
+   let (i,c) = get_left_construct term in
+    match i with
+     | 1 -> []
+     | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2)
+     | i -> raise ParseError
+
+  let rec dump_list typ dump_elt l =
+   match l with
+    | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+    | e :: l -> Term.mkApp(Lazy.force coq_cons,
+                                [| typ; dump_elt e;dump_list typ dump_elt l|])
+
+  let pp_list op cl elt o l =
+   let rec _pp  o l =
+    match l with
+     | [] -> ()
+     | [e] -> Printf.fprintf o "%a" elt e
+     | e::l -> Printf.fprintf o "%a ,%a" elt e  _pp l in
+    Printf.fprintf o "%s%a%s" op _pp l cl
+
+  let pp_var  = pp_positive
+
+  let dump_var = dump_positive
+
+  let pp_expr pp_z o e =
+  let rec pp_expr  o e =
+   match e with
+    | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n
+    | Mc.PEc z -> pp_z o z
+    | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2
+    | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2
+    | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e
+    | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2
+    | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n  n in
+    pp_expr o e
+
+  let dump_expr typ dump_z e =
+   let rec dump_expr  e =
+   match e with
+    | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |])
+    | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |])
+    | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd,
+                              [| typ; dump_expr e1;dump_expr e2|])
+    | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub,
+                              [| typ; dump_expr  e1;dump_expr  e2|])
+    | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp,
+                         [| typ; dump_expr  e|])
+    | Mc.PEmul(e1,e2) ->  mkApp(Lazy.force coq_PEmul,
+                               [| typ; dump_expr  e1;dump_expr e2|])
+    | Mc.PEpow(e,n) ->  mkApp(Lazy.force coq_PEpow,
+                             [| typ; dump_expr  e; dump_n  n|])
+      in
+    dump_expr e
+
+  let dump_pol typ dump_c e =
+    let rec dump_pol e =
+      match e with
+        | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|])
+        | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|])
+        | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in
+      dump_pol e
+
+  let pp_pol pp_c o e =
+    let rec pp_pol o e =
+      match e with
+        | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n
+        | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol
+        | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in
+      pp_pol o e
+
+  let pp_cnf pp_c o f =
+    let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c)  p Tag.pp t) l in
+      List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f
+
+  let dump_psatz typ dump_z e =
+   let z = Lazy.force typ in
+  let rec dump_cone e =
+   match e with
+    | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |])
+    | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC,
+                              [| z; dump_pol z dump_z e ; dump_cone c |])
+    | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare,
+                            [| z;dump_pol z dump_z e|])
+    | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd,
+                              [| z; dump_cone e1; dump_cone e2|])
+    | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE,
+                               [| z; dump_cone e1; dump_cone e2|])
+    | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|])
+    | Mc.PsatzZ    -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in
+   dump_cone e
+
+  let  pp_psatz pp_z o e =
+   let rec pp_cone o e =
+    match e with
+     | Mc.PsatzIn n ->
+        Printf.fprintf o "(In %a)%%nat" pp_nat n
+     | Mc.PsatzMulC(e,c) ->
+        Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c
+     | Mc.PsatzSquare e ->
+        Printf.fprintf o "(%a^2)" (pp_pol pp_z) e
+     | Mc.PsatzAdd(e1,e2) ->
+        Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2
+     | Mc.PsatzMulE(e1,e2) ->
+        Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2
+     | Mc.PsatzC p ->
+        Printf.fprintf o "(%a)%%positive" pp_z p
+     | Mc.PsatzZ    ->
+        Printf.fprintf o "0" in
+    pp_cone o e
+
+  let rec dump_op = function
+   | Mc.OpEq-> Lazy.force coq_OpEq
+   | Mc.OpNEq-> Lazy.force coq_OpNEq
+   | Mc.OpLe -> Lazy.force coq_OpLe
+   | Mc.OpGe -> Lazy.force coq_OpGe
+   | Mc.OpGt-> Lazy.force coq_OpGt
+   | Mc.OpLt-> Lazy.force coq_OpLt
+
+  let pp_op o e=
+   match e with
+    | Mc.OpEq-> Printf.fprintf o "="
+    | Mc.OpNEq-> Printf.fprintf o "<>"
+    | Mc.OpLe -> Printf.fprintf o "=<"
+    | Mc.OpGe -> Printf.fprintf o ">="
+    | Mc.OpGt-> Printf.fprintf o ">"
+    | Mc.OpLt-> Printf.fprintf o "<"
+
+  let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
+   Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r
+
+  let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
+    Term.mkApp(Lazy.force coq_Build,
+              [| typ; dump_expr typ dump_constant e1 ;
+                 dump_op o ;
+                 dump_expr typ dump_constant e2|])
+
+  let assoc_const x l =
+   try
+   snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+   with
+     Not_found -> raise ParseError
+
+  let zop_table = [
+   coq_Zgt, Mc.OpGt ;
+   coq_Zge, Mc.OpGe ;
+   coq_Zlt, Mc.OpLt ;
+   coq_Zle, Mc.OpLe ]
+
+  let rop_table = [
+   coq_Rgt, Mc.OpGt ;
+   coq_Rge, Mc.OpGe ;
+   coq_Rlt, Mc.OpLt ;
+   coq_Rle, Mc.OpLe ]
+
+  let qop_table = [
+   coq_Qlt, Mc.OpLt ;
+   coq_Qle, Mc.OpLe ;
+   coq_Qeq, Mc.OpEq
+  ]
+
+  let parse_zop (op,args) =
+   match kind_of_term op with
+    | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
+    |  Ind(n,0) ->
+        if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_Z
+        then (Mc.OpEq, args.(1), args.(2))
+        else raise ParseError
+    |   _ -> failwith "parse_zop"
+
+  let parse_rop (op,args) =
+    match kind_of_term op with
+     | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
+     |  Ind(n,0) ->
+        if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_R
+        then (Mc.OpEq, args.(1), args.(2))
+        else raise ParseError
+    |   _ -> failwith "parse_zop"
+
+  let parse_qop (op,args) =
+    (assoc_const op qop_table, args.(0) , args.(1))
+
+  let is_constant t = (* This is an approx *)
+   match kind_of_term t with
+    | Construct(i,_) -> true
+    |   _ -> false
+
+  type 'a op =
+    | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr)
+    | Opp
+    | Power
+    | Ukn of string
+
+  let assoc_ops x l =
+   try
+     snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+   with
+     Not_found -> Ukn "Oups"
+
+  (**
+    * MODULE: Env is for environment.
+    *)
+
+  module Env =
+  struct
+   type t = constr list
+
+   let compute_rank_add env v =
+    let rec _add env n v =
+     match env with
+      | [] -> ([v],n)
+      | e::l ->
+         if eq_constr e v
+         then (env,n)
+         else
+          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)
+
+   let empty = []
+
+   let elements env = env
+
+  end (* MODULE END: Env *)
+
+  (**
+    * This is the big generic function for expression parsers.
+    *)
+
+  let parse_expr parse_constant parse_exp ops_spec env term =
+    if debug
+    then (Pp.pp (Pp.str "parse_expr: ");
+          Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ());
+
+    let constant_or_variable env term =
+     try
+      ( Mc.PEc (parse_constant term) , env)
+     with ParseError ->
+      let (env,n) = Env.compute_rank_add env term in
+       (Mc.PEX  n , env) in
+
+    let rec parse_expr env term =
+     let combine env op (t1,t2) =
+      let (expr1,env) = parse_expr env t1 in
+      let (expr2,env) = parse_expr env t2 in
+      (op expr1 expr2,env) in
+
+      match kind_of_term term with
+       | App(t,args) ->
+          (
+           match kind_of_term t with
+            | Const c ->
+               ( match assoc_ops t ops_spec  with
+                | Binop f -> combine env f (args.(0),args.(1))
+                | Opp     -> let (expr,env) = parse_expr env args.(0) in
+                              (Mc.PEopp expr, env)
+                | Power   ->
+                    begin
+                      try
+                        let (expr,env) = parse_expr env args.(0) in
+                        let power = (parse_exp expr args.(1)) in
+                          (power  , env)
+                      with _ ->   (* if the exponent is a variable *)
+                        let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
+                    end
+                | Ukn  s ->
+                   if debug
+                   then (Printf.printf "unknown op: %s\n" s; flush stdout;);
+                   let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
+               )
+            |   _ -> constant_or_variable env term
+          )
+       | _ -> constant_or_variable env term in
+     parse_expr env term
+
+  let zop_spec =
+    [
+      coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
+      coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
+      coq_Zmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ;
+      coq_Zopp   , Opp ;
+      coq_Zpower , Power]
+
+  let qop_spec =
+   [
+      coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
+      coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
+      coq_Qmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ;
+      coq_Qopp   , Opp ;
+      coq_Qpower , Power]
+
+  let rop_spec =
+   [
+      coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
+      coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
+      coq_Rmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ;
+      coq_Ropp   , Opp ;
+      coq_Rpower , Power]
+
+  let zconstant = parse_z
+  let qconstant = parse_q
+
+  let rconstant term =
+   if debug
+   then (Pp.pp_flush ();
+         Pp.pp (Pp.str "rconstant: ");
+         Pp.pp (Printer.prterm  term); Pp.pp_flush ());
+   match Term.kind_of_term term with
+    | Const x ->
+        if term = Lazy.force coq_R0
+        then Mc.Z0
+        else if term = Lazy.force coq_R1
+        then Mc.Zpos Mc.XH
+        else raise ParseError
+    |  _ -> raise ParseError
+
+  let parse_zexpr =  parse_expr
+    zconstant
+    (fun expr x ->
+      let exp = (parse_z x) in
+        match exp with
+          | Mc.Zneg _ -> Mc.PEc Mc.Z0
+          |   _     ->  Mc.PEpow(expr, Mc.n_of_Z exp))
+    zop_spec
+
+  let parse_qexpr  =  parse_expr
+   qconstant
+    (fun expr x ->
+      let exp = parse_z x in
+        match exp with
+          | Mc.Zneg _ ->
+              begin
+                match expr with
+                | Mc.PEc q -> Mc.PEc (Mc.qpower q exp)
+                |     _    -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError
+              end
+          | _     ->  let exp = Mc.n_of_Z  exp in
+                        Mc.PEpow(expr,exp))
+   qop_spec
+
+  let parse_rexpr =  parse_expr
+   rconstant
+   (fun expr x ->
+      let exp = Mc.n_of_nat (parse_nat x) in
+        Mc.PEpow(expr,exp))
+   rop_spec
+
+  let  parse_arith parse_op parse_expr env cstr =
+   if debug
+   then (Pp.pp_flush ();
+         Pp.pp (Pp.str "parse_arith: ");
+         Pp.pp (Printer.prterm  cstr);
+         Pp.pp_flush ());
+   match kind_of_term cstr with
+    | App(op,args) ->
+       let (op,lhs,rhs) = parse_op (op,args) in
+       let (e1,env) = parse_expr env lhs in
+       let (e2,env) = parse_expr env rhs in
+        ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
+    |  _ -> failwith "error : parse_arith(2)"
+
+  let parse_zarith = parse_arith  parse_zop parse_zexpr
+
+  let parse_qarith = parse_arith  parse_qop parse_qexpr
+
+  let parse_rarith = parse_arith  parse_rop parse_rexpr
+
+  (* generic parsing of arithmetic expressions *)
+
+  let rec f2f = function
+   | TT  -> Mc.TT
+   | FF  -> Mc.FF
+   | X _  -> Mc.X
+   | A (x,_,_) -> Mc.A x
+   | C (a,b)  -> Mc.Cj(f2f a,f2f b)
+   | D (a,b)  -> Mc.D(f2f a,f2f b)
+   | 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)
+  let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1))
+  let mkI f1 f2 = I(f1,None,f2)
+
+  let mkformula_binary g term f1 f2 =
+    match f1 , f2 with
+    |  X _  , X _ -> X(term)
+    |   _         -> g f1 f2
+
+  (**
+    * This is the big generic function for formula parsers.
+    *)
+  
+  let parse_formula parse_atom env term =
+
+    let parse_atom env tg t = try let (at,env) = parse_atom env t in
+                                    (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in
+
+    let rec xparse_formula env tg term =
+     match kind_of_term term with
+      | App(l,rst) ->
+          (match rst with
+           | [|a;b|] when 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 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 l = Lazy.force coq_not ->
+               let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
+           | [|a;b|] when 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) ->
+          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 term = Lazy.force coq_True -> (TT,env,tg)
+      | _ when term = Lazy.force coq_False -> (FF,env,tg)
+      | _  -> X(term),env,tg in
+    xparse_formula env term
+
+  let dump_formula typ dump_atom f =
+   let rec xdump f =
+    match f with
+     | TT  -> mkApp(Lazy.force coq_TT,[|typ|])
+     | FF  -> mkApp(Lazy.force coq_FF,[|typ|])
+     | C(x,y) -> mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|])
+     | D(x,y) -> mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|])
+     | I(x,_,y) -> mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|])
+     | N(x) -> mkApp(Lazy.force coq_Neg,[|typ ; xdump x|])
+     | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|])
+     | 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 set l concl =
+   let rec xset acc = function
+    | [] -> acc
+    | (e::l) ->
+       let (name,expr,typ) = e in
+        xset (Term.mkNamedLetIn
+               (Names.id_of_string name)
+               expr typ acc) l in
+    xset concl l
+
+end (**
+      * MODULE END: M 
+      *)
+
+open M
+
+let rec sig_of_cone = function
+ | Mc.PsatzIn n ->          [CoqToCaml.nat n]
+ | Mc.PsatzMulE(w1,w2) ->   (sig_of_cone w1)@(sig_of_cone w2)
+ | Mc.PsatzMulC(w1,w2) ->   (sig_of_cone w2)
+ | Mc.PsatzAdd(w1,w2) ->    (sig_of_cone w1)@(sig_of_cone w2)
+ | _  -> []
+
+let same_proof sg cl1 cl2 =
+ let rec xsame_proof sg =
+  match sg with
+   | [] -> true
+   | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false)
+      && (xsame_proof sg ) in
+  xsame_proof sg
+
+let tags_of_clause tgs wit clause =
+ let rec xtags tgs = function
+  | Mc.PsatzIn n -> Names.Idset.union tgs
+     (snd (List.nth clause (CoqToCaml.nat n) ))
+  | Mc.PsatzMulC(e,w) -> xtags tgs w
+  | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2
+  |   _   -> tgs in
+  xtags tgs wit
+
+let tags_of_cnf wits cnf =
+ List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
+  Names.Idset.empty wits cnf
+
+let find_witness prover polys1 = try_any prover polys1
+
+let rec witness prover   l1 l2 =
+ match l2 with
+  | [] -> Some []
+  | e :: l2 ->
+     match find_witness prover (e::l1) with
+      | None -> None
+      | Some w ->
+	 (match witness prover l1 l2 with
+	  | None -> None
+	  | Some l -> Some (w::l)
+	 )
+
+let rec apply_ids t ids =
+ match ids with
+  | [] -> t
+  | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids
+
+let coq_Node = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+   [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")
+let coq_Leaf = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+   [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")
+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 ->
+  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 rec pp_varmap o vm =
+ match vm with
+  | Mc.Empty -> output_string o "[]"
+  | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z  z
+  | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l  pp_z z pp_varmap r
+
+
+
+let rec dump_proof_term = function
+  | Micromega.DoneProof -> Lazy.force coq_doneProof
+  | Micromega.RatProof(cone,rst) ->
+    Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|])
+ | Micromega.CutProof(cone,prf) ->
+    Term.mkApp(Lazy.force coq_cutProof,
+	      [| dump_psatz coq_Z dump_z cone ;
+		 dump_proof_term prf|])
+ | Micromega.EnumProof(c1,c2,prfs) ->
+    Term.mkApp (Lazy.force coq_enumProof,
+	       [|  dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ;
+		  dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |])
+
+let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
+
+
+let rec pp_proof_term o = function
+  | Micromega.DoneProof -> Printf.fprintf o "D"
+  | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz  pp_z) cone pp_proof_term rst
+  | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz  pp_z) cone pp_proof_term rst
+  | Micromega.EnumProof(c1,c2,rst) ->
+      Printf.fprintf o "EP[%a,%a,%a]"
+	(pp_psatz pp_z) c1 (pp_psatz pp_z) c2
+     (pp_list "[" "]" pp_proof_term) rst
+
+let rec parse_hyps parse_arith env tg hyps =
+ match hyps with
+  | [] -> ([],env,tg)
+  | (i,t)::l ->
+     let (lhyps,env,tg) = parse_hyps parse_arith env tg l in
+      try
+       let (c,env,tg) = parse_formula parse_arith env  tg t in
+	((i,c)::lhyps, env,tg)
+      with _ -> 		(lhyps,env,tg)
+       (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+
+
+(*exception ParseError*)
+
+let parse_goal parse_arith env hyps term =
+ (*  try*)
+ let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in
+ let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in
+  (lhyps,f,env)
+   (*  with Failure x -> raise ParseError*)
+
+(**
+  * The datastructures that aggregate theory-dependent proof values.
+  *)
+
+type ('d, 'prf) domain_spec = {
+ typ : Term.constr; (* Z, Q , R *)
+ coeff : Term.constr ; (* Z, Q *)
+ dump_coeff : 'd -> Term.constr ;
+ proof_typ : Term.constr ;
+ dump_proof : 'prf -> Term.constr
+}
+
+let zz_domain_spec  = lazy {
+ typ = Lazy.force coq_Z;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z ;
+ proof_typ = Lazy.force coq_proofTerm ;
+ dump_proof = dump_proof_term
+}
+
+let qq_domain_spec  = lazy {
+ typ = Lazy.force coq_Q;
+ coeff = Lazy.force coq_Q;
+ dump_coeff = dump_q ;
+ proof_typ = Lazy.force coq_QWitness ;
+ dump_proof = dump_psatz coq_Q dump_q
+}
+
+let rz_domain_spec  = lazy {
+ typ = Lazy.force coq_R;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z;
+ proof_typ = Lazy.force coq_ZWitness ;
+ dump_proof = dump_psatz coq_Z dump_z
+}
+
+(**
+  * Instanciate the current Coq goal with a Micromega formula, a varmap, and a
+  * witness.
+  *)
+
+let micromega_order_change spec cert cert_typ env ff gl =
+ 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
+  Tactics.change_in_concl None
+   (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
+
+(**
+  * The datastructures that aggregate prover attributes.
+  *)
+
+type ('a,'prf) prover = {
+  name : string ; (* name of the prover *)
+  prover : '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
+  * datastructure.
+  *)
+
+let find_witness provers polys1 =
+  let provers = List.map (fun p ->
+    (fun l ->
+      match p.prover l with
+        | None -> None
+        | Some prf -> Some(prf,p)) , p.name) provers in
+  try_any provers (List.map fst polys1)
+
+(**
+  * Given a list of provers and a CNF, find a proof for each of the clauses.
+  * Return the proofs as a list.
+  *)
+
+let witness_list prover l =
+ let rec xwitness_list l =
+  match l with
+   | [] -> Some []
+   | e :: l ->
+      match find_witness prover e  with
+       | None -> None
+       | Some w ->
+	  (match xwitness_list l with
+	   | None -> None
+	   | Some l -> Some (w :: l)
+	  ) in
+  xwitness_list l
+
+let witness_list_tags  = witness_list
+
+(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *)
+
+let pp_ml_list pp_elt o l =
+  output_string o "[" ;
+  List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ;
+  output_string o "]"
+
+(**
+  * Prune the proof object, according to the 'diff' between two cnf formulas.
+  *)
+
+let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
+
+  let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
+    let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in
+    let remap i =
+      let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in
+      List.assoc formula new_cl in
+    if debug then
+      begin
+        Printf.printf "\ncompact_proof : %a %a %a"
+          (pp_ml_list prover.pp_f) (List.map fst old_cl)
+          prover.pp_prf prf
+          (pp_ml_list prover.pp_f) (List.map fst new_cl)   ;
+          flush stdout
+      end ;
+    let res = try prover.compact prf remap with 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
+        | None -> failwith "proof compaction error"
+        | Some p ->  p
+    in
+    if debug then
+      begin
+        Printf.printf " -> %a\n"
+          prover.pp_prf res ;
+        flush stdout
+      end ;
+    res in
+
+  let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
+    let hyps_idx = prover.hyps prf in
+    let hyps = selecti hyps_idx old_cl in
+      is_sublist hyps new_cl in
+
+  let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *)
+
+  List.map (fun x ->
+    let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res
+    in compact_proof o p x) cnf_ff'
+
+
+(**
+  * "Hide out" tagged atoms of a formula by transforming them into generic
+  * variables. See the Tag module in mutils.ml for more.
+  *)
+
+let abstract_formula hyps f =
+  let rec xabs f =
+    match f with
+      | X c -> X c
+      | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term)
+      | C(f1,f2) ->
+	  (match xabs f1 , xabs f2 with
+	    |   X a1    ,  X a2   -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|]))
+	    |    f1     , f2      -> C(f1,f2) )
+      | D(f1,f2) ->
+	  (match xabs f1 , xabs f2 with
+	    |   X a1    ,  X a2   -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|]))
+	    |    f1     , f2      -> D(f1,f2) )
+      | N(f) ->
+	  (match xabs f with
+	    |   X a    -> X (Term.mkApp(Lazy.force coq_not, [|a|]))
+	    |     f     -> N f)
+      | I(f1,hyp,f2) ->
+	  (match xabs f1 , hyp, xabs f2 with
+	    | X a1      , Some _ , af2    ->  af2
+	    | X a1      , None   , X a2   -> X (Term.mkArrow a1 a2)
+	    |   af1     ,  _     , af2    -> I(af1,hyp,af2)
+	  )
+      | FF -> FF
+      | TT -> TT
+  in  xabs f
+
+(**
+  * This exception is raised by really_call_csdpcert if Coq's configure didn't
+  * find a CSDP executable.
+  *)
+
+exception CsdpNotFound
+
+(**
+  * This is the core of Micromega: apply the prover, analyze the result and
+  * prune unused fomulas, and finally modify the proof state.
+  *)
+
+let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
+ let spec = Lazy.force spec in
+
+ (* Express the goal as one big implication *)
+ let (ff,ids) =
+  List.fold_right
+   (fun (id,f) (cc,ids) ->
+    match f with
+      X _ -> (cc,ids)
+     | _ -> (I(f,Some id,cc), id::ids))
+   polys1 (polys2,[]) in
+
+ (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *)
+ let cnf_ff = cnf negate normalise ff in
+
+ if debug then
+   begin
+     Pp.pp (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
+   end;
+
+ match witness_list_tags prover cnf_ff with
+  | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+  | Some res -> (*Printf.printf "\nList %i" (List.length `res); *)
+  let hyps = List.fold_left (fun s (cl,(prf,p)) ->
+    let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in
+                                     if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ;
+      (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in
+    TagSet.union s tags) TagSet.empty (List.combine cnf_ff res) in
+
+  if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout;
+                 Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ;
+
+  let ff'     = abstract_formula hyps ff in
+  let cnf_ff' = cnf negate normalise ff' in
+
+  if debug then
+    begin
+      Pp.pp (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 ();
+        Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff'
+    end;
+
+  (* Even if it does not work, this does not mean it is not provable
+  -- the prover is REALLY incomplete *)
+  (* if debug then
+      begin
+        (* recompute the proofs *)
+        match witness_list_tags prover  cnf_ff' with
+          | None -> failwith "abstraction is wrong"
+          | Some res -> ()
+      end ; *)
+  let res' = compact_proofs cnf_ff res cnf_ff' in
+
+  let (ff',res',ids) = (ff',res',List.map Term.mkVar (ids_of_formula ff')) in
+
+  let res' = dump_list (spec.proof_typ) spec.dump_proof res' in
+    (Tacticals.tclTHENSEQ
+      [
+        Tactics.generalize ids ;
+        micromega_order_change spec res'
+          (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
+      ]) gl
+
+(**
+  * Parse the proof environment, and call micromega_tauto
+  *)
+
+let micromega_gen
+    parse_arith
+    (negate:'cst atom -> 'cst mc_cnf)
+    (normalise:'cst atom -> 'cst mc_cnf)
+    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 parse_arith Env.empty hyps concl in
+   let env = Env.elements env in
+    micromega_tauto negate normalise spec prover env hyps concl gl
+  with
+   | Failure x -> flush stdout ; Pp.pp_flush () ;
+      Tacticals.tclFAIL 0 (Pp.str x) gl
+   | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
+   | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
+      Tacticals.tclFAIL 0 (Pp.str 
+      (" Skipping what remains of this tactic: the complexity of the goal requires "
+      ^ "the use of a specialized external tool called csdp. \n\n" 
+      ^ "Unfortunately this instance of Coq isn't aware of the presence of any \"csdp\" executable. \n\n"
+      ^ "You may need to specify the location during Coq's pre-compilation configuration step")) gl
+
+let lift_ratproof  prover l =
+ match prover l with
+  | None -> None
+  | Some c -> Some (Mc.RatProof( c,Mc.DoneProof))
+
+type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
+type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
+type provername = string * int option
+
+(**
+  * The caching mechanism.
+  *)
+
+open Persistent_cache
+
+module Cache = PHashtable(struct
+  type t = (provername * micromega_polys)
+  let equal = (=)
+  let hash  = Hashtbl.hash
+end)
+
+let csdp_cache = "csdp.cache"
+
+(**
+  * Build the command to call csdpcert, and launch it. This in turn will call
+  * the sos driver to the csdp executable.
+  * Throw CsdpNotFound if a Coq isn't aware of any csdp executable.
+  *)
+
+let require_csdp =
+  match System.search_exe_in_path "csdp" with
+    | Some _ -> lazy ()
+    | _ -> lazy (raise CsdpNotFound)
+
+let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option  =
+  fun provername poly ->
+
+  Lazy.force require_csdp;
+
+  let cmdname =
+    List.fold_left Filename.concat (Envars.coqlib ())
+      ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in
+
+    match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with
+      | F str -> failwith str
+      | S res -> res
+
+(**
+  * Check the cache before calling the prover.
+  *)
+
+let xcall_csdpcert =
+  Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb)
+
+(**
+  * Prover callback functions.
+  *)
+
+let call_csdpcert prover pb = xcall_csdpcert (prover,pb)
+
+let rec z_to_q_pol e =
+ match e with
+  | Mc.Pc z   -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH}
+  | Mc.Pinj(p,pol)   -> Mc.Pinj(p,z_to_q_pol pol)
+  | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2)
+
+let call_csdpcert_q provername poly =
+ match call_csdpcert provername poly with
+  | None -> None
+  | Some cert ->
+     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)
+
+let call_csdpcert_z provername poly =
+ let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in
+  match call_csdpcert provername l with
+   | None -> None
+   | Some cert ->
+      let cert = Certificate.z_cert_of_pos cert in
+      if Mc.zWeakChecker poly cert
+      then Some cert
+      else ((print_string "buggy certificate" ; flush stdout) ;None)
+
+let xhyps_of_cone base acc prf =
+  let rec xtract e acc =
+    match e with
+    | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc
+    | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in
+			if n >= base
+			then  ISet.add (n-base) acc
+			else acc
+    | Mc.PsatzMulC(_,c) -> xtract  c acc
+    | Mc.PsatzAdd(e1,e2) |  Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in
+
+    xtract prf acc
+
+let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf
+
+let compact_cone prf f  =
+  let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in
+
+  let rec xinterp prf =
+    match prf with
+    | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf
+    | Mc.PsatzIn n -> Mc.PsatzIn (np n)
+    | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c)
+    | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2)
+    | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in
+
+    xinterp prf
+
+let hyps_of_pt pt =
+
+  let rec xhyps base pt acc =
+    match pt with
+      | Mc.DoneProof -> acc
+      | Mc.RatProof(c,pt) ->  xhyps (base+1) pt (xhyps_of_cone base acc c)
+      | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c)
+      | Mc.EnumProof(c1,c2,l) ->
+	  let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in
+	    List.fold_left (fun s x -> xhyps (base + 1) x s) s l in
+
+    xhyps 0 pt ISet.empty
+
+let hyps_of_pt pt =
+  let res = hyps_of_pt pt in
+    if debug
+    then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res);
+    res
+
+let compact_pt pt f =
+  let translate ofset x =
+    if x < ofset then x
+    else (f (x-ofset) + ofset) in
+
+  let rec compact_pt ofset pt =
+    match pt with
+      | Mc.DoneProof -> Mc.DoneProof
+      | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
+      | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
+      | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)),
+						   Mc.map (fun x -> compact_pt (ofset+1) x) l) in
+    compact_pt 0 pt
+
+(** 
+  * Definition of provers.
+  * Instantiates the type ('a,'prf) prover defined above.
+  *)
+
+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)
+}
+
+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)
+}
+
+let linear_prover_R = {
+  name    = "linear prover";
+  prover  = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ;
+  hyps    = hyps_of_cone ;
+  compact = compact_cone ;
+  pp_prf  = pp_psatz pp_z ;
+  pp_f    =  fun o x -> pp_pol pp_z o (fst x)
+}
+
+let non_linear_prover_Q str o = {
+  name    = "real nonlinear prover";
+  prover  = call_csdpcert_q (str, o);
+  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_R str o = {
+  name    = "real nonlinear prover";
+  prover  = call_csdpcert_z (str, o);
+  hyps    = hyps_of_cone;
+  compact = compact_cone;
+  pp_prf  = pp_psatz pp_z;
+  pp_f    = fun o x -> pp_pol pp_z o  (fst x)
+}
+
+let non_linear_prover_Z str o  = {
+  name    = "real nonlinear prover";
+  prover  = lift_ratproof (call_csdpcert_z (str, o));
+  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 = (=)
+  let hash  = Hashtbl.hash
+end)
+
+let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)
+
+let linear_Z =   {
+  name    = "lia";
+  prover  = memo_zlinear_prover ;
+  hyps    = hyps_of_pt;
+  compact = compact_pt;
+  pp_prf  = pp_proof_term;
+  pp_f    = fun o x -> pp_pol pp_z o (fst x)
+}
+
+(** 
+  * Functions instantiating micromega_gen with the appropriate theories and
+  * solvers
+  *)
+
+let psatzl_Z gl =
+ micromega_gen parse_zarith  Mc.negate Mc.normalise zz_domain_spec
+  [ linear_prover_Z ] gl
+
+let psatzl_Q gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+  [ linear_prover_Q ] gl
+
+let psatz_Q i gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+  [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl
+
+let psatzl_R gl =
+ micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec
+  [ linear_prover_R ] gl
+
+let psatz_R i gl =
+ micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec
+  [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl
+
+let psatz_Z i gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+  [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl
+
+let sos_Z gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise  zz_domain_spec
+  [ non_linear_prover_Z "pure_sos" None ] gl
+
+let sos_Q gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise  qq_domain_spec
+  [ non_linear_prover_Q "pure_sos" None ] gl
+
+let sos_R gl =
+ micromega_gen parse_rarith Mc.rnegate Mc.rnormalise  rz_domain_spec
+  [ non_linear_prover_R "pure_sos" None ] gl
+
+let xlia gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise   zz_domain_spec
+  [ linear_Z ] gl
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
index e451a38f..d4e6d920 100644
--- a/contrib/micromega/csdpcert.ml
+++ b/plugins/micromega/csdpcert.ml
@@ -15,12 +15,24 @@
 open Big_int
 open Num
 open Sos
+open Sos_types
+open Sos_lib
+
 
 module Mc = Micromega
 module Ml2C = Mutils.CamlToCoq
 module C2Ml = Mutils.CoqToCaml
 
-let debug = false
+type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
+type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
+type provername = string * int option
+
+
+let debug = true
+let flags = [Open_append;Open_binary;Open_creat]
+
+let chan = open_out_gen flags 0o666 "trace"
+
 
 module M =
 struct
@@ -29,7 +41,7 @@ struct
  let rec expr_to_term = function
   |  PEc z ->  Const  (C2Ml.q_to_num z)
   |  PEX v ->  Var ("x"^(string_of_int (C2Ml.index v)))
-  |  PEmul(p1,p2) -> 
+  |  PEmul(p1,p2) ->
       let p1 = expr_to_term p1 in
       let p2 = expr_to_term p2 in
       let res = Mul(p1,p2) in 	   res
@@ -39,22 +51,12 @@ struct
   | PEpow(p,n)   -> Pow(expr_to_term p , C2Ml.n n)
   |  PEopp p ->  Opp (expr_to_term p)
 
-      
-
 
-(* let term_to_expr e =
-  let e' = term_to_expr e in
-   if debug 
-   then Printf.printf "term_to_expr : %s - %s\n"  
-    (string_of_poly (poly_of_term  e)) 
-    (string_of_poly (poly_of_term (expr_to_term e')));
-   e' *)
-
-end 
-open M      
+end
+open M
 
 open List
-open Mutils 
+open Mutils
 
 
 
@@ -63,29 +65,29 @@ let rec canonical_sum_to_string = function s -> failwith "not implemented"
 
 let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
 
-let print_list_term l = 
- print_string "print_list_term\n";
- List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "q: %s %s ;" 
-  (string_of_poly (poly_of_term (expr_to_term e))) 
-  (match k with 
-    Mc.Equal -> "= " 
-   | Mc.Strict -> "> " 
-   | Mc.NonStrict -> ">= " 
-   | _ -> failwith "not_implemented")) l ;
- print_string "\n"
+let print_list_term o l =
+  output_string o "print_list_term\n";
+ List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;"
+  (string_of_poly (poly_of_term (expr_to_term e)))
+  (match k with
+    Mc.Equal -> "= "
+   | Mc.Strict -> "> "
+   | Mc.NonStrict -> ">= "
+   | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ;
+ output_string o "\n"
 
 
-let partition_expr l = 
+let partition_expr l =
  let rec f i = function
   | [] -> ([],[],[])
-  | Mc.Pair(e,k)::l -> 
+  | (e,k)::l ->
      let (eq,ge,neq) = f (i+1) l in
-      match k with 
+      match k with
        | Mc.Equal -> ((e,i)::eq,ge,neq)
        | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq)
-       | Mc.Strict    -> (* e > 0 == e >= 0 /\ e <> 0 *) 
+       | Mc.Strict    -> (* e > 0 == e >= 0 /\ e <> 0 *)
 	  (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq)
-       | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) 
+       | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq)
 	  (* Not quite sure -- Coq interface has changed *)
  in f 0 l
 
@@ -94,27 +96,28 @@ let rec sets_of_list l =
  match l with
   | [] -> [[]]
   | e::l -> let s = sets_of_list l in
-	     s@(List.map (fun s0 -> e::s0) s) 
+	     s@(List.map (fun s0 -> e::s0) s)
 
 (* The exploration is probably not complete - for simple cases, it works... *)
 let real_nonlinear_prover d l =
- try 
+  let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in
+ try
   let (eq,ge,neq) = partition_expr l in
 
   let rec elim_const  = function
     [] ->  []
    | (x,y)::l -> let p = poly_of_term (expr_to_term x) in
-		  if poly_isconst p 
-		  then elim_const l 
+		  if poly_isconst p
+		  then elim_const l
 		  else (p,y)::(elim_const l) in
 
   let eq = elim_const eq in
   let peq = List.map  fst eq in
-   
-  let pge = List.map 
+
+  let pge = List.map
    (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in
-   
-  let monoids = List.map (fun m ->  (List.fold_right (fun (p,kd) y -> 
+
+  let monoids = List.map (fun m ->  (List.fold_right (fun (p,kd) y ->
    let p = poly_of_term (expr_to_term p) in
     match kd with
      | Axiom_lt i -> poly_mul p y
@@ -122,76 +125,90 @@ let real_nonlinear_prover d l =
      |   _        -> failwith "monoids") m (poly_const (Int 1)) , map  snd m))
    (sets_of_list neq) in
 
-  let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> 
-   list_try_find (fun m -> let (ci,cc) = 
+  let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
+   list_try_find (fun m -> let (ci,cc) =
     real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
 		      (ci,cc,snd m)) monoids) 0 in
-   
-  let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))  
+
+  let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
    cert_ideal (List.map snd eq) in
 
   let proofs_cone = map term_of_sos cert_cone in
-   
-  let proof_ne =  
-   let (neq , lt) = List.partition 
+
+  let proof_ne =
+   let (neq , lt) = List.partition
     (function  Axiom_eq _ -> true | _ -> false ) monoid in
-   let sq = match 
-     (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) 
+   let sq = match
+     (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq)
     with
     | []  -> Rational_lt (Int 1)
     | l   -> Monoid l in
     List.fold_right (fun x y -> Product(x,y)) lt sq in
 
-  let proof = list_fold_right_elements 
+  let proof = list_fold_right_elements
    (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
-   Some proof
- with 
-  | Sos.TooDeep -> None
-
+   S (Some proof)
+ with
+  | Sos_lib.TooDeep -> S None
+  |    x        ->   F (Printexc.to_string x)
 
 (* This is somewhat buggy, over Z, strict inequality vanish... *)
 let pure_sos  l =
- (* If there is no strict inequality, 
+  let l = List.map (fun (e,o) -> Mc.denorm e, o) l in
+
+ (* If there is no strict inequality,
     I should nonetheless be able to try something - over Z  > is equivalent to -1  >= *)
- try 
+ try
   let l = List.combine l (interval 0 (length l -1)) in
-  let (lt,i) =  try (List.find (fun (x,_) -> snd' x =  Mc.Strict) l) 
+  let (lt,i) =  try (List.find (fun (x,_) -> snd x =  Mc.Strict) l)
    with Not_found -> List.hd l in
-  let plt = poly_neg (poly_of_term (expr_to_term (fst' lt))) in
+  let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in
   let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
-  let pos = Product (Rational_lt n, 
+  let pos = Product (Rational_lt n,
 		    List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square
-		     (term_of_poly p)), rst)) 
+		     (term_of_poly p)), rst))
 		     polys (Rational_lt (Int 0))) in
   let proof = Sum(Axiom_lt i, pos) in
 (*  let s,proof' = scale_certificate proof in
   let cert  = snd (cert_of_pos proof') in *)
-   Some proof
+    S (Some proof)
  with
-  | Not_found -> (* This is no strict inequality *) None
-  |  x        -> None
+(*   | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
+   |  x        -> (* May be that could be refined *) S None
 
 
-type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list
-type csdp_certificate = Sos.positivstellensatz option
-type provername = string * int option
 
-let main () =
-  if Array.length Sys.argv <> 3 then
-    (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1);
-  let input_file = Sys.argv.(1) in
-  let output_file = Sys.argv.(2) in
-  let inch = open_in input_file in
-  let (prover,poly) = (input_value inch : provername * micromega_polys) in
-  close_in inch;
-  let cert =
+let run_prover prover pb =
     match prover with
-    | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly
-    | "pure_sos", None -> pure_sos poly
-    | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in
-  let outch = open_out output_file in
-  output_value outch (cert:csdp_certificate);
-  close_out outch;
-  exit 0;;
+    | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb
+    | "pure_sos", None -> pure_sos pb
+    | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1)
+
+
+let output_csdp_certificate o = function
+  | S None -> output_string o "S None"
+  | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p
+  | F s        -> Printf.fprintf o "F %s" s
+
+
+let main () =
+  try
+    let (prover,poly) = (input_value stdin : provername * micromega_polys) in
+    let cert = run_prover prover poly in
+(*      Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ;
+      close_out chan ;   *)
+
+      output_value stdout (cert:csdp_certificate);
+      flush stdout ;
+      Marshal.to_channel  chan (cert:csdp_certificate) [] ;
+      flush chan ;
+      exit 0
+  with  x -> (Printf.fprintf chan "error %s" (Printexc.to_string x)  ; exit 1)
+
+;;
 
 let _ = main () in ()
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 50024e78..f4d04e5d 100644
--- a/contrib/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -14,7 +14,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_micromega.ml4 11306 2008-08-05 16:51:08Z notin $ *)
+(* $Id$ *)
 
 open Quote
 open Ring
@@ -31,6 +31,11 @@ TACTIC EXTEND PsatzZ
 | [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ]
 END
 
+TACTIC EXTEND ZOmicron
+[ "xlia"  ] -> [ Coq_micromega.xlia]
+END
+
+
 TACTIC EXTEND Sos_Z
 | [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
    END
@@ -53,9 +58,6 @@ TACTIC EXTEND QOmicron
 END
 
 
-TACTIC EXTEND ZOmicron
-[ "xlia"  ] -> [ Coq_micromega.xlia]
-END
 
 TACTIC EXTEND ROmicron
 [ "psatzl_R"  ] -> [ Coq_micromega.psatzl_R]
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
new file mode 100644
index 00000000..6250e324
--- /dev/null
+++ b/plugins/micromega/mfourier.ml
@@ -0,0 +1,1012 @@
+open Num
+module Utils = Mutils
+
+let map_option = Utils.map_option
+let from_option = Utils.from_option
+
+let debug = false
+type ('a,'b) lr = Inl of 'a | Inr of 'b
+
+
+module Vect =
+  struct
+    (** [t] is the type of vectors.
+	A vector [(x1,v1) ; ... ; (xn,vn)] is such that:
+	- variables indexes are ordered (x1 < ... < xn
+	- values are all non-zero
+    *)
+    type var = int
+    type t = (var * num) list
+
+(** [equal v1 v2 = true] if the vectors are syntactically equal.
+    ([num] is not handled by  [Pervasives.equal] *)
+
+    let rec equal v1 v2 =
+      match v1 , v2 with
+	| [] , []   -> true
+	| [] , _    -> false
+	| _::_ , [] -> false
+	| (i1,n1)::v1 , (i2,n2)::v2 ->
+	    (i1 = i2) && n1 =/ n2 && equal v1 v2
+
+    let hash v =
+      let rec hash i = function
+	| [] -> i
+	| (vr,vl)::l ->  hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in
+	Hashtbl.hash (hash 0 v )
+
+
+    let null = []
+
+    let pp_vect o vect =
+      List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect
+
+    let from_list (l: num list) =
+      let rec xfrom_list i l =
+	match l with
+	  | [] -> []
+	  | e::l ->
+	      if e <>/ Int 0
+	      then (i,e)::(xfrom_list (i+1) l)
+	      else xfrom_list (i+1) l in
+
+	xfrom_list 0 l
+
+    let zero_num = Int 0
+    let unit_num = Int 1
+
+
+    let to_list m =
+      let rec xto_list i l =
+	match l with
+	  | [] -> []
+	  |	(x,v)::l' ->
+		  if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
+	xto_list 0 m
+
+
+    let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
+
+    let rec update i f t =
+      match t with
+	| [] -> cons i (f zero_num) []
+	| (k,v)::l ->
+	    match Pervasives.compare i k with
+	  | 0 -> cons k (f v) l
+	  | -1 -> cons i (f zero_num) t
+	  |  1 -> (k,v) ::(update i f l)
+	  |  _  -> failwith "compare_num"
+
+    let rec set i n t =
+      match t with
+	| [] -> cons i n []
+	| (k,v)::l ->
+	    match Pervasives.compare i k with
+	      | 0 -> cons k n l
+	      | -1 -> cons i n t
+	      |  1 -> (k,v) :: (set i n l)
+	      |  _  -> failwith "compare_num"
+
+    let gcd m =
+      let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int  x (Utils.numerator e))  Big_int.zero_big_int m in
+	if Big_int.compare_big_int res Big_int.zero_big_int = 0
+	then Big_int.unit_big_int else res
+
+    let rec mul z t =
+      match z with
+	| Int 0 -> []
+	| Int 1 -> t
+	|  _    -> List.map (fun (i,n) -> (i, mult_num z n)) t
+
+    let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical
+      [
+	(fun () -> Pervasives.compare (fst x) (fst y));
+	(fun () -> compare_num (snd x) (snd y))])
+
+    (** [tail v vect] returns
+	- [None] if [v] is not a variable of the vector [vect]
+	- [Some(vl,rst)]  where [vl] is the value of [v] in vector [vect]
+        and [rst] is the remaining of the vector
+	We exploit that vectors are ordered lists
+    *)
+    let rec tail (v:var) (vect:t) =
+      match vect with
+	| [] -> None
+	| (v',vl)::vect' ->
+	    match Pervasives.compare v' v with
+	      | 0 -> Some (vl,vect) (* Ok, found *)
+	      | -1 -> tail v vect' (* Might be in the tail *)
+	      | _  -> None (* Hopeless *)
+
+    let get v vect =
+      match tail v vect with
+	| None -> None
+	| Some(vl,_) -> Some vl
+
+
+    let rec fresh v =
+	match v with
+	  | [] -> 1
+	  | [v,_] -> v + 1
+	  | _::v  -> fresh v
+
+  end
+open Vect
+
+(** Implementation of intervals *)
+module Itv =
+struct
+
+  (** The type of intervals is *)
+  type interval = num option * num option
+      (** None models the absence of bound i.e. infinity *)
+      (** As a result,
+	  - None , None   -> ]-oo,+oo[
+	  - None , Some v -> ]-oo,v]
+	  - Some v, None  -> [v,+oo[
+	  - Some v, Some v' -> [v,v']
+      Intervals needs to be explicitely normalised.
+      *)
+
+  type who = Left | Right
+
+
+  (** if then interval [itv] is empty, [norm_itv itv] returns [None]
+      otherwise, it returns [Some itv] *)
+
+  let norm_itv itv =
+    match itv with
+      | Some a , Some b -> if a <=/ b then Some itv else None
+      |   _             -> Some itv
+
+  (** [opp_itv itv] computes the opposite interval *)
+  let opp_itv itv =
+  let (l,r) = itv in
+    (map_option minus_num r, map_option minus_num l)
+
+
+
+
+(** [inter i1 i2 = None] if the intersection of intervals is empty
+    [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *)
+  let inter i1 i2 =
+    let (l1,r1) = i1
+    and (l2,r2) = i2 in
+
+    let inter f o1 o2 =
+      match o1 , o2 with
+	| None , None -> None
+	| Some _ , None -> o1
+	| None  , Some _ -> o2
+	| Some n1 , Some n2 -> Some (f n1 n2) in
+
+    norm_itv (inter max_num l1 l2 , inter min_num r1 r2)
+
+  let range = function
+    | None,_ | _,None -> None
+    | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1))
+
+
+  let smaller_itv i1 i2 =
+    match  range i1 ,  range i2  with
+      | None , _ -> false
+      |  _   , None -> true
+      | Some i , Some j -> i <=/ j
+
+
+(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *)
+let in_bound bnd v =
+  let (l,r) = bnd in
+  match l , r with
+    | None , None -> true
+    | None , Some a -> v <=/ a
+    | Some a , None -> a <=/ v
+    | Some a , Some b -> a <=/ v && v <=/ b
+
+end
+open Itv
+type vector = Vect.t
+
+type cstr = { coeffs : vector ; bound : interval }
+(** 'cstr' is the type of constraints.
+    {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r
+**)
+
+module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end)
+
+
+module PSet = ISet
+
+
+module System = Hashtbl.Make(Vect)
+
+  type proof =
+      | Hyp of int
+      | Elim of  var * proof * proof
+      | And of proof * proof
+
+
+
+type system = {
+  sys : cstr_info ref System.t ;
+  vars : ISet.t
+}
+and cstr_info = {
+  bound : interval ;
+  prf : proof ;
+  pos : int ;
+  neg : int ;
+}
+
+
+(** 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.
+       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
+    - [neg] is the number of negative values of the vector
+    ( [neg] + [pos] is therefore the length of the vector)
+    [v] is an upper-bound of the set of variables which appear in [s].
+*)
+
+(** To be thrown when a system has no solution *)
+exception SystemContradiction of proof
+let hyps prf =
+  let rec hyps prf acc =
+    match prf with
+      | Hyp i -> ISet.add i acc
+      | Elim(_,prf1,prf2)
+      | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in
+    hyps prf ISet.empty
+
+
+(** Pretty printing *)
+  let rec pp_proof o prf =
+    match prf with
+      | Hyp i -> Printf.fprintf o "H%i" i
+      | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2
+      | And(prf1,prf2)   -> Printf.fprintf o "A(%a,%a)"  pp_proof prf1 pp_proof prf2
+
+let pp_bound o  = function
+  | None -> output_string o "oo"
+  | Some a -> output_string o (string_of_num a)
+
+let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r
+
+let rec pp_list f o l =
+  match l with
+    | [] -> ()
+    | e::l -> f o e ; output_string o ";" ; pp_list f o l
+
+let pp_iset o s =
+  output_string o "{" ;
+  ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s ();
+  output_string o "}"
+
+let pp_pset o s =
+  output_string o "{" ;
+  PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s ();
+  output_string o "}"
+
+
+let pp_info o i = pp_itv o i.bound
+
+let pp_cstr o (vect,bnd) =
+    let (l,r) = bnd in
+      (match l with
+	| None -> ()
+	| Some n -> Printf.fprintf o "%s <= " (string_of_num n))
+      ;
+      pp_vect o vect ;
+      (match r with
+	      | None -> output_string o"\n"
+	      | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n))
+
+
+let pp_system o sys=
+  System.iter (fun vect ibnd ->
+    pp_cstr o (vect,(!ibnd).bound)) sys
+
+
+
+let pp_split_cstr o (vl,v,c,_) =
+  Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect  v  (string_of_num c)
+
+(** [merge_cstr_info] takes:
+    - the intersection of bounds and
+    - the union of proofs
+    - [pos] and [neg] fields should be identical *)
+
+let merge_cstr_info i1 i2 =
+  let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1
+  and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in
+    assert (p1 = p2 && n1 = n2) ;
+    match inter i1 i2 with
+      | None -> None (* Could directly raise a system contradiction exception *)
+      | Some bnd ->
+	  Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) }
+
+(** [xadd_cstr vect cstr_info] loads an constraint into the system.
+    The constraint is neither redundant nor contradictory.
+    @raise SystemContradiction if [cstr_info] returns [None]
+*)
+
+let xadd_cstr vect cstr_info sys =
+  if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ;
+  try
+    let info = System.find sys vect in
+      match merge_cstr_info cstr_info !info with
+	  | None       -> raise (SystemContradiction  (And(cstr_info.prf, (!info).prf)))
+	  | Some info' -> info := info'
+      with
+	| Not_found -> System.replace  sys vect (ref cstr_info)
+
+
+type cstr_ext =
+    | Contradiction (** The constraint is contradictory.
+			Typically, a [SystemContradiction] exception will be raised. *)
+    | Redundant  (** The constrain is redundant.
+		     Typically, the constraint will be dropped *)
+    | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant.
+				     Typically, it will be added to the constraint system. *)
+
+(** [normalise_cstr] : vector -> cstr_info -> cstr_ext *)
+let normalise_cstr vect cinfo =
+  match norm_itv cinfo.bound with
+    | None -> Contradiction
+    | Some (l,r) ->
+	match vect with
+	  | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction
+	  | (_,n)::_ ->  Cstr(
+	      (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect),
+			     let divn x = x // n in
+			       if sign_num n = 1
+			       then{cinfo with bound = (map_option divn l , map_option  divn r) }
+			       else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)})
+
+(** For compatibility, there an external representation of constraints *)
+
+type cstr_compat = {coeffs : vector ; op : op ; cst : num}
+and op = |Eq | Ge
+
+let string_of_op = function Eq -> "=" | Ge -> ">="
+
+
+let eval_op = function
+  | Eq -> (=/)
+  | Ge ->  (>=/)
+
+let count v =
+  let rec count n p v =
+    match v with
+      | [] -> (n,p)
+      | (_,vl)::v -> let sg = sign_num vl in
+		       assert (sg <> 0) ;
+	  if sg = 1 then count n (p+1) v else count (n+1) p v in
+    count 0 0 v
+
+
+let norm_cstr {coeffs = v ; op = o ; cst = c} idx =
+  let (n,p) = count v in
+
+  normalise_cstr v {pos = p ; neg = n ; bound =
+  (match o with
+	| Eq -> Some c , Some c
+	| Ge -> Some c , None) ;
+	    prf = Hyp idx }
+
+
+(** [load_system l] takes a list of constraints of type [cstr_compat]
+    @return a system of constraints
+    @raise SystemContradiction if a contradiction is found
+*)
+let load_system l =
+
+  let sys = System.create 1000 in
+
+  let li = Mutils.mapi (fun e i -> (e,i)) l in
+
+  let vars = List.fold_left (fun vrs (cstr,i) ->
+    match norm_cstr cstr i with
+      | Contradiction -> raise (SystemContradiction (Hyp i))
+      | Redundant      -> vrs
+      | Cstr(vect,info) ->
+	  xadd_cstr  vect info sys ;
+	  List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li   in
+
+    {sys = sys ;vars = vars}
+
+let system_list sys =
+  let { sys = s ; vars  = v } = sys in
+    System.fold (fun k bi l -> (k, !bi)::l) s []
+
+
+(** [add (v1,c1)  (v2,c2)  ]
+    precondition:  (c1 <>/ Int 0 && c2 <>/ Int 0)
+    @return a pair [(v,ln)] such that
+    [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2]
+    Note that the resulting vector is not normalised.
+*)
+
+let add (v1,c1)  (v2,c2)  =
+    assert (c1 <>/ Int 0 && c2 <>/ Int 0) ;
+
+  let rec xadd v1 v2  =
+    match v1 , v2 with
+      | (x1,n1)::v1' , (x2,n2)::v2' ->
+	  if x1 = x2
+	  then
+	    let n' = (n1 // c1) +/ (n2 // c2) in
+	      if n' =/ Int 0 then xadd v1' v2'
+	      else
+		let res = xadd v1' v2'  in
+		  (x1,n') ::res
+	  else if x1 < x2
+	  then let res = xadd v1' v2   in
+		 (x1, n1 // c1)::res
+	  else let res = xadd v1 v2'  in
+		 (x2, n2 // c2)::res
+      |  [] , [] -> []
+      |  [] ,  _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2
+      |  _  , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in
+
+  let res = xadd v1 v2 in
+    (res, count res)
+
+let add (v1,c1)   (v2,c2)  =
+  let res = add (v1,c1)   (v2,c2)  in
+    (*    Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*)
+    res
+
+type tlr = (num * vector * cstr_info) list
+type tm = (vector * cstr_info ) list
+
+(** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *)
+
+(** [split x vect info (l,m,r)]
+    @param v is the variable to eliminate
+    @param l contains constraints such that (e + a*x) // a >= c / a
+    @param r contains constraints such that (e + a*x) // - a >= c / -a
+    @param m contains constraints which do not mention [x]
+*)
+
+let split x (vect: vector) info (l,m,r) =
+    match get x vect with
+      | None -> (* The constraint does not mention [x], store it in m *)
+	  (l,(vect,info)::m,r)
+      | Some vl -> (* otherwise *)
+
+          let cons_bound lst bd =
+            match  bd with
+              | None -> lst
+              | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in
+
+          let lb,rb = info.bound in
+            if sign_num vl = 1
+            then  (cons_bound l lb,m,cons_bound r rb)
+            else (* sign_num vl = -1 *)
+              (cons_bound l rb,m,cons_bound r lb)
+
+
+(** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ].
+    This is a one step Fourier elimination.
+*)
+let project vr sys =
+
+  let (l,m,r)  = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys  ([],[],[])  in
+
+  let new_sys = System.create (System.length sys.sys) in
+
+    (* Constraints in [m] belong to the projection - for those [vr] is already projected out *)
+    List.iter (fun  (vect,info) -> System.replace new_sys vect (ref info) )  m ;
+
+    let elim (v1,vect1,info1) (v2,vect2,info2) =
+      let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1
+      and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in
+
+      let bnd1 = from_option (fst bound1)
+      and bnd2 = from_option (fst bound2) in
+      let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in
+      let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2)  in
+        (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in
+
+      List.iter(fun  l_elem -> List.iter (fun r_elem ->
+        let (vect,info) = elim l_elem r_elem in
+	  match normalise_cstr vect info with
+	    | Redundant -> ()
+	    | Contradiction -> raise (SystemContradiction  info.prf)
+	    | Cstr(vect,info)   -> xadd_cstr vect info new_sys) r ) l;
+      {sys = new_sys ; vars = ISet.remove  vr sys.vars}
+
+
+(** [project_using_eq] performs elimination by pivoting using an equation.
+    This is the counter_part of the [elim] sub-function of [!project].
+    @param vr is the variable to be used as pivot
+    @param c is the coefficient of variable [vr] in vector [vect]
+    @param len is the length of the equation
+    @param bound is the bound of the equation
+    @param prf is the proof of the equation
+*)
+
+let project_using_eq vr c vect bound  prf (vect',info') =
+    match get vr vect' with
+    | Some c2 ->
+	let c1 = if c2 >=/ Int 0 then minus_num c else c in
+
+	let c2 = abs_num c2 in
+
+	let (vres,(n,p)) = add (vect,c1) (vect', c2)  in
+
+	let cst = bound // c1 in
+
+	let bndres =
+	  let f x = cst +/ x // c2 in
+	  let (l,r) = info'.bound in
+	    (map_option f l , map_option f r) in
+
+	  (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)})
+    | None -> (vect',info')
+
+let elim_var_using_eq vr vect cst  prf sys =
+  let c = from_option (get vr vect) in
+
+  let elim_var = project_using_eq vr c vect cst prf  in
+
+  let  new_sys  =  System.create (System.length sys.sys) in
+
+    System.iter(fun vect iref ->
+      let (vect',info') = elim_var (vect,!iref) in
+	match normalise_cstr vect' info' with
+	    | Redundant -> ()
+	    | Contradiction -> raise (SystemContradiction info'.prf)
+	    | Cstr(vect,info')   -> xadd_cstr vect info' new_sys) sys.sys ;
+
+    {sys = new_sys ; vars = ISet.remove  vr sys.vars}
+
+
+(** [size sys] computes the number of entries in the system of constraints *)
+let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0
+
+module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+
+let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map ()
+
+(** [eval_vect map vect] evaluates vector [vect] using the values of [map].
+    If [map] binds all the variables of [vect], we get
+    [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []]
+    The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *)
+
+let  eval_vect map vect =
+  let rec xeval_vect vect sum rst =
+    match vect with
+      | [] -> (sum,rst)
+      | (v,vl)::vect ->
+	  try
+	    let val_v = IMap.find v map in
+	      xeval_vect vect (sum +/ (val_v */ vl)) rst
+	  with
+	      Not_found -> xeval_vect vect sum ((v,vl)::rst) in
+    xeval_vect vect (Int 0) []
+
+
+(** [restrict_bound n sum itv] returns the interval of [x]
+    given that (fst itv) <=  x * n + sum <= (snd itv) *)
+let restrict_bound n sum (itv:interval) =
+  let f x  = (x -/ sum) // n in
+  let l,r = itv in
+    match sign_num n with
+      | 0 -> if in_bound itv sum
+	then (None,None) (* redundant *)
+	else failwith "SystemContradiction"
+      | 1 ->  map_option f l , map_option f r
+      | _ -> map_option f r , map_option f l
+
+
+(** [bound_of_variable map v sys] computes the interval of [v] in
+    [sys] given a mapping [map] binding all the other variables *)
+let bound_of_variable map v sys =
+  System.fold (fun vect iref bnd  ->
+    let sum,rst = eval_vect  map vect in
+    let vl = match get v rst with
+      | None -> Int 0
+      | Some v -> v in
+      match inter bnd (restrict_bound vl sum (!iref).bound) with
+	| None -> failwith "bound_of_variable: impossible"
+	| Some itv -> itv) sys  (None,None)
+
+
+(** [pick_small_value bnd] picks a value being closed to zero within the interval *)
+let pick_small_value bnd =
+  match bnd with
+    | None , None   ->  Int 0
+    | None , Some i ->  if  (Int 0) <=/ (floor_num  i) then Int 0 else floor_num i
+    | Some i,None   ->  if i <=/ (Int 0) then Int 0 else ceiling_num i
+    | Some i,Some j ->
+	if i <=/ Int 0 && Int 0 <=/ j
+	then Int 0
+	else if ceiling_num i <=/ floor_num j
+	then ceiling_num i (* why not *) else i
+
+
+(** [solution s1 sys_l  = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)]
+    then [sn] is a  system which contains only [black_v] -- if it existed in [s1]
+    and [sn+1] is obtained by projecting [vn] out of [sn]
+    @raise SystemContradiction if  system [s] has no solution
+*)
+
+let solve_sys black_v choose_eq choose_variable sys sys_l =
+
+  let rec solve_sys sys sys_l =
+    if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys);
+
+    let eqs = choose_eq sys in
+      try
+	let (v,vect,cst,ln) =  fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in
+	  if debug then
+	    (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ;
+	     flush stdout);
+	  let sys' = elim_var_using_eq v vect cst ln sys in
+	    solve_sys sys' ((v,sys)::sys_l)
+    with Not_found ->
+      let vars = choose_variable  sys in
+	try
+	  let (v,est) =  (List.find (fun (v,_) -> v <> black_v) vars) in
+	    if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ;
+	    let sys' =  project v sys in
+	      solve_sys sys' ((v,sys)::sys_l)
+	with Not_found ->  (* we are done *) Inl (sys,sys_l)  in
+    solve_sys sys sys_l
+
+
+
+
+let  solve black_v choose_eq choose_variable cstrs =
+
+  try
+    let sys = load_system cstrs in
+(*      Printf.printf "solve :\n %a" pp_system sys.sys ; *)
+      solve_sys black_v choose_eq choose_variable sys []
+  with SystemContradiction prf -> Inr prf
+
+
+(** The  purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable.
+    The output is an ordered list of (variable,cost).
+*)
+
+module EstimateElimVar =
+struct
+  type sys_list = (vector * cstr_info) list
+
+  let abstract_partition (v:int) (l: sys_list) =
+
+    let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) =
+      match l with
+        | [] -> (ltl, n,z,p)
+        | (l1,info) ::rl ->
+            match  l1 with
+            | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p
+            | (vr,vl)::rl1 ->
+		if v = vr
+		then
+		  let cons_bound lst bd =
+		    match  bd with
+		      | None -> lst
+		      | Some bnd -> info.neg+info.pos::lst in
+
+		  let lb,rb = info.bound in
+		    if sign_num vl = 1
+		    then  xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb)
+		    else  xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb)
+		else
+		  (* the variable is greater *)
+		  xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p
+
+    in
+    let (sys',n,z,p) =  xpart l [] [] 0 []  in
+
+    let ln = float_of_int (List.length n) in
+    let sn = float_of_int (List.fold_left (+) 0 n) in
+    let lp = float_of_int (List.length p) in
+    let sp = float_of_int (List.fold_left (+) 0 p) in
+      (sys',  float_of_int z +.  lp *.  sn +.  ln *.  sp -. lp*.ln)
+
+
+  let choose_variable   sys =
+    let {sys = s ; vars = v} = sys in
+
+    let sl = system_list sys in
+
+    let evals  = fst
+      (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s  in
+                                      ((v,vl)::eval, ts)) v ([],sl)) in
+
+      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals
+
+
+end
+open EstimateElimVar
+
+(** The  module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations.
+*)
+module EstimateElimEq =
+struct
+
+  let itv_point bnd =
+    match bnd with
+      |(Some a, Some b) -> a =/ b
+      | _   -> false
+
+  let eq_bound bnd c =
+    match bnd with
+      |(Some a, Some b) -> a =/ b && c =/ b
+      | _   -> false
+
+
+  let rec unroll_until v l =
+    match l with
+      | [] -> (false,[])
+      | (i,_)::rl -> if i = v
+	then (true,rl)
+	else if i < v then unroll_until v rl else (false,l)
+
+
+  let choose_primal_equation eqs sys_l =
+
+    let is_primal_equation_var v =
+      List.fold_left (fun (nb_eq,nb_cst) (vect,info) ->
+	if fst (unroll_until v vect)
+	then if itv_point  info.bound then (nb_eq +  1,nb_cst) else (nb_eq,nb_cst)
+	else (nb_eq,nb_cst)) (0,0) sys_l in
+
+    let rec find_var vect =
+      match vect with
+	| [] -> None
+	| (i,_)::vect ->
+	    let (nb_eq,nb_cst) = is_primal_equation_var i in
+	      if nb_eq = 2 && nb_cst = 0
+	      then Some i else find_var vect in
+
+    let rec find_eq_var eqs =
+      match eqs with
+	| [] -> None
+	| (vect,a,prf,ln)::l ->
+	    match find_var vect with
+		| None -> find_eq_var l
+		| Some r -> Some (r,vect,a,prf,ln)
+    in
+
+
+      find_eq_var eqs
+
+
+
+
+  let choose_equality_var  sys =
+
+    let sys_l = system_list sys in
+
+    let equalities = List.fold_left
+      (fun  l (vect,info) ->
+	match  info.bound with
+	  | Some a , Some b ->
+	      if a =/ b then (* This an equation *)
+		(vect,a,info.prf,info.neg+info.pos)::l else l
+	  |   _ -> l
+      ) [] sys_l  in
+
+    let rec estimate_cost v ct sysl acc tlsys =
+      match sysl with
+	| [] -> (acc,tlsys)
+	| (l,info)::rsys ->
+	    let ln = info.pos + info.neg in
+	    let (b,l) = unroll_until v l in
+	    match b with
+	      | true ->
+		  if itv_point info.bound
+		  then estimate_cost  v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *)
+		  else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys)  (* should be more ? *)
+	      | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in
+
+      match choose_primal_equation equalities sys_l with
+	| None ->
+	    let cost_eq eq const prf ln acc_costs =
+
+	      let rec cost_eq eqr sysl costs =
+		match eqr with
+		  | [] -> costs
+		  | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in
+				     cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in
+		cost_eq eq sys_l acc_costs     in
+
+	    let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in
+
+	      (*      pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
+
+	      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs
+	| Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0]
+
+
+end
+open EstimateElimEq
+
+module Fourier =
+struct
+
+  let optimise vect l =
+    (* We add a dummy (fresh) variable for vector *)
+    let fresh =
+      List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in
+    let cstr = {
+      coeffs = Vect.set fresh (Int (-1)) vect ;
+      op = Eq ;
+      cst = (Int 0)} in
+      match solve fresh choose_equality_var choose_variable (cstr::l) with
+	| Inr prf -> None (* This is an unsatisfiability proof *)
+	| Inl (s,_) ->
+	    try
+	      Some (bound_of_variable IMap.empty fresh s.sys)
+	    with
+		x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
+
+
+  let find_point cstrs =
+
+    match solve max_int choose_equality_var choose_variable cstrs with
+      | Inr prf -> Inr prf
+      | Inl (_,l) ->
+
+	let rec rebuild_solution l map =
+	  match l with
+	    | [] -> map
+	    | (v,e)::l ->
+		let itv = bound_of_variable map v e.sys in
+		let map = IMap.add v (pick_small_value itv) map in
+		  rebuild_solution l map
+	in
+
+	let map = rebuild_solution l IMap.empty in
+	  let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in
+(*	    Printf.printf "SOLUTION %a" pp_vect vect ; *)
+	  let res = Inl vect in
+	    res
+
+
+end
+
+
+module Proof =
+struct
+
+
+
+
+(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction.
+    The proofs constructed by Fourier elimination are more like execution traces:
+         - certain facts are recorded but are useless
+         - certain inferences are implicit.
+    The following code implements proof reconstruction.
+*)
+  let add x y = fst (add x y)
+
+
+  let forall_pairs f l1 l2 =
+    List.fold_left (fun acc e1 ->
+      List.fold_left (fun acc e2 ->
+	match f e1 e2 with
+	  | None -> acc
+	  | Some v -> v::acc) acc l2) [] l1
+
+
+  let add_op x y =
+    match x , y with
+      | Eq , Eq -> Eq
+      |     _   -> Ge
+
+
+  let pivot v (p1,c1) (p2,c2) =
+    let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+    and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+
+      match Vect.get v v1 , Vect.get v v2 with
+        | None , _ | _ , None -> None
+        | Some a   , Some b   ->
+            if (sign_num a) * (sign_num b) = -1
+            then Some (add (p1,abs_num a) (p2,abs_num b) ,
+                      {coeffs = add (v1,abs_num a) (v2,abs_num b) ;
+                       op = add_op op1 op2 ;
+                       cst = n1 // (abs_num a) +/ n2 // (abs_num b) })
+            else if op1 = Eq
+            then Some (add (p1,minus_num (a // b)) (p2,Int 1),
+                      {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ;
+                       op     = add_op op1 op2;
+                       cst    = n1 // (minus_num (a// b)) +/ n2 // (Int 1)})
+            else if op2 = Eq
+	    then
+	      Some (add (p2,minus_num (b // a)) (p1,Int 1),
+                   {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ;
+                    op     = add_op op1 op2;
+                    cst    = n2 // (minus_num (b// a)) +/ n1 // (Int 1)})
+	    else  None (* op2 could be Eq ... this might happen *)
+
+
+  let normalise_proofs l =
+    List.fold_left (fun acc (prf,cstr) ->
+      match acc with
+        | Inr _ -> acc (* I already found a contradiction *)
+        | Inl acc ->
+            match norm_cstr cstr 0 with
+              | Redundant -> Inl acc
+              | Contradiction -> Inr (prf,cstr)
+              | Cstr(v,info)  -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l
+
+
+  type oproof = (vector * cstr_compat * num) option
+
+  let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) =
+    let (l,r) = info.bound in
+
+    let keep p ob bd =
+      match ob , bd with
+        | None , None -> None
+        | None , Some b -> Some(prf,cstr,b)
+        | Some _ , None -> ob
+        | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in
+
+    let oleft  = keep (<=/) oleft l in
+    let oright = keep (>=/) oright r in
+      (* Now, there might be a contradiction *)
+      match oleft , oright with
+        | None , _ | _ , None -> Inl (oleft,oright)
+        | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) ->
+            if l <=/ r
+            then Inl (oleft,oright)
+            else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*)
+              match cstrr.coeffs with
+                | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *)
+                | (v,_)::_ ->
+                    match pivot v (prfl,cstrl) (prfr,cstrr) with
+                      | None -> failwith "merge_proof : pivot is not possible"
+                      | Some x -> Inr x
+
+let  mk_proof hyps prf =
+  (* I am keeping list - I might have a proof for the left bound and a proof for the right bound.
+     If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2.
+     For each proof list, all the vectors should be of the form a.v for different constants a.
+  *)
+
+  let rec mk_proof prf =
+    match prf with
+      | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ]
+
+      | 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 *)
+            forall_pairs (pivot v) prfsl prfsr
+      | And(prf1,prf2) ->
+          let prfsl1 = mk_proof prf1
+          and prfsl2 = mk_proof prf2 in
+          (* detect trivial redundancies and contradictions *)
+            match normalise_proofs (prfsl1@prfsl2) with
+              | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *)
+              | Inl l -> (* All the vectors are the same *)
+                  let prfs =
+                    List.fold_left (fun acc e ->
+                      match acc with
+                        | Inr _ -> acc (* I have a contradiction *)
+                        | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in
+                    match prfs with
+                      | Inr x -> [x]
+                      | Inl (oleft,oright) ->
+			  match oleft , oright with
+			    | None , None -> []
+			    | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr]
+			    | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in
+
+    mk_proof prf
+
+
+end
+
diff --git a/contrib/micromega/micromega.ml b/plugins/micromega/micromega.ml
index e151e4e1..c350ed0f 100644
--- a/contrib/micromega/micromega.ml
+++ b/plugins/micromega/micromega.ml
@@ -1,27 +1,13 @@
-type __ = Obj.t
-let __ = let rec f _ = Obj.repr f in Obj.repr f
-
-type bool =
-  | True
-  | False
-
 (** val negb : bool -> bool **)
 
 let negb = function
-  | True -> False
-  | False -> True
+  | true -> false
+  | false -> true
 
 type nat =
   | O
   | S of nat
 
-type 'a option =
-  | Some of 'a
-  | None
-
-type ('a, 'b) prod =
-  | Pair of 'a * 'b
-
 type comparison =
   | Eq
   | Lt
@@ -34,42 +20,36 @@ let compOpp = function
   | Lt -> Gt
   | Gt -> Lt
 
-type sumbool =
-  | Left
-  | Right
+(** val plus : nat -> nat -> nat **)
 
-type 'a sumor =
-  | Inleft of 'a
-  | Inright
-
-type 'a list =
-  | Nil
-  | Cons of 'a * 'a list
+let rec plus n0 m =
+  match n0 with
+    | O -> m
+    | S p -> S (plus p m)
 
 (** val app : 'a1 list -> 'a1 list -> 'a1 list **)
 
 let rec app l m =
   match l with
-    | Nil -> m
-    | Cons (a, l1) -> Cons (a, (app l1 m))
+    | [] -> m
+    | a :: l1 -> a :: (app l1 m)
 
 (** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
 
 let rec nth n0 l default =
   match n0 with
     | O -> (match l with
-              | Nil -> default
-              | Cons (x, l') -> x)
-    | S m ->
-        (match l with
-           | Nil -> default
-           | Cons (x, t0) -> nth m t0 default)
+              | [] -> default
+              | x :: l' -> x)
+    | S m -> (match l with
+                | [] -> default
+                | x :: t0 -> nth m t0 default)
 
 (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
 
 let rec map f = function
-  | Nil -> Nil
-  | Cons (a, t0) -> Cons ((f a), (map f t0))
+  | [] -> []
+  | a :: t0 -> (f a) :: (map f t0)
 
 type positive =
   | XI of positive
@@ -229,10 +209,24 @@ let rec pcompare x y r =
                | XH -> r
                | _ -> Lt)
 
+(** val psize : positive -> nat **)
+
+let rec psize = function
+  | XI p2 -> S (psize p2)
+  | XO p2 -> S (psize p2)
+  | XH -> S O
+
 type n =
   | N0
   | Npos of positive
 
+(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **)
+
+let rec pow_pos rmul x = function
+  | XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p)
+  | XO i0 -> let p = pow_pos rmul x i0 in rmul p p
+  | XH -> x
+
 type z =
   | Z0
   | Zpos of positive
@@ -347,55 +341,47 @@ let zcompare x y =
            | Zneg y' -> compOpp (pcompare x' y' Eq)
            | _ -> Lt)
 
-(** val dcompare_inf : comparison -> sumbool sumor **)
+(** val zabs : z -> z **)
 
-let dcompare_inf = function
-  | Eq -> Inleft Left
-  | Lt -> Inleft Right
-  | Gt -> Inright
-
-(** val zcompare_rec :
-    z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
-let zcompare_rec x y h1 h2 h3 =
-  match dcompare_inf (zcompare x y) with
-    | Inleft x0 -> (match x0 with
-                      | Left -> h1 __
-                      | Right -> h2 __)
-    | Inright -> h3 __
+let zabs = function
+  | Z0 -> Z0
+  | Zpos p -> Zpos p
+  | Zneg p -> Zpos p
 
-(** val z_gt_dec : z -> z -> sumbool **)
+(** val zmax : z -> z -> z **)
 
-let z_gt_dec x y =
-  zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left)
+let zmax m n0 =
+  match zcompare m n0 with
+    | Lt -> n0
+    | _ -> m
 
 (** val zle_bool : z -> z -> bool **)
 
 let zle_bool x y =
   match zcompare x y with
-    | Gt -> False
-    | _ -> True
+    | Gt -> false
+    | _ -> true
 
 (** val zge_bool : z -> z -> bool **)
 
 let zge_bool x y =
   match zcompare x y with
-    | Lt -> False
-    | _ -> True
+    | Lt -> false
+    | _ -> true
 
 (** val zgt_bool : z -> z -> bool **)
 
 let zgt_bool x y =
   match zcompare x y with
-    | Gt -> True
-    | _ -> False
+    | Gt -> true
+    | _ -> false
 
 (** val zeq_bool : z -> z -> bool **)
 
 let zeq_bool x y =
   match zcompare x y with
-    | Eq -> True
-    | _ -> False
+    | Eq -> true
+    | _ -> false
 
 (** val n_of_nat : nat -> n **)
 
@@ -403,54 +389,54 @@ let n_of_nat = function
   | O -> N0
   | S n' -> Npos (p_of_succ_nat n')
 
-(** val zdiv_eucl_POS : positive -> z -> (z, z) prod **)
+(** val zdiv_eucl_POS : positive -> z -> z  *  z **)
 
 let rec zdiv_eucl_POS a b =
   match a with
     | XI a' ->
-        let Pair (q0, r) = zdiv_eucl_POS a' b in
+        let q0 , r = zdiv_eucl_POS a' b in
         let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
-        (match zgt_bool b r' with
-           | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
-           | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
-               (zminus r' b)))
+        if zgt_bool b r'
+        then (zmult (Zpos (XO XH)) q0) , r'
+        else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b)
     | XO a' ->
-        let Pair (q0, r) = zdiv_eucl_POS a' b in
+        let q0 , r = zdiv_eucl_POS a' b in
         let r' = zmult (Zpos (XO XH)) r in
-        (match zgt_bool b r' with
-           | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
-           | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
-               (zminus r' b)))
+        if zgt_bool b r'
+        then (zmult (Zpos (XO XH)) q0) , r'
+        else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b)
     | XH ->
-        (match zge_bool b (Zpos (XO XH)) with
-           | True -> Pair (Z0, (Zpos XH))
-           | False -> Pair ((Zpos XH), Z0))
+        if zge_bool b (Zpos (XO XH)) then Z0 , (Zpos XH) else (Zpos XH) , Z0
 
-(** val zdiv_eucl : z -> z -> (z, z) prod **)
+(** val zdiv_eucl : z -> z -> z  *  z **)
 
 let zdiv_eucl a b =
   match a with
-    | Z0 -> Pair (Z0, Z0)
+    | Z0 -> Z0 , Z0
     | Zpos a' ->
         (match b with
-           | Z0 -> Pair (Z0, Z0)
+           | Z0 -> Z0 , Z0
            | Zpos p -> zdiv_eucl_POS a' b
            | Zneg b' ->
-               let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+               let q0 , r = zdiv_eucl_POS a' (Zpos b') in
                (match r with
-                  | Z0 -> Pair ((zopp q0), Z0)
-                  | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r))))
+                  | Z0 -> (zopp q0) , Z0
+                  | _ -> (zopp (zplus q0 (Zpos XH))) , (zplus b r)))
     | Zneg a' ->
         (match b with
-           | Z0 -> Pair (Z0, Z0)
+           | Z0 -> Z0 , Z0
            | Zpos p ->
-               let Pair (q0, r) = zdiv_eucl_POS a' b in
+               let q0 , r = zdiv_eucl_POS a' b in
                (match r with
-                  | Z0 -> Pair ((zopp q0), Z0)
-                  | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r)))
+                  | Z0 -> (zopp q0) , Z0
+                  | _ -> (zopp (zplus q0 (Zpos XH))) , (zminus b r))
            | Zneg b' ->
-               let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
-               Pair (q0, (zopp r)))
+               let q0 , r = zdiv_eucl_POS a' (Zpos b') in q0 , (zopp r))
+
+(** val zdiv : z -> z -> z **)
+
+let zdiv a b =
+  let q0 , x = zdiv_eucl a b in q0
 
 type 'c pol =
   | Pc of 'c
@@ -473,24 +459,21 @@ let rec peq ceqb p p' =
   match p with
     | Pc c -> (match p' with
                  | Pc c' -> ceqb c c'
-                 | _ -> False)
+                 | _ -> false)
     | Pinj (j, q0) ->
         (match p' with
            | Pinj (j', q') ->
                (match pcompare j j' Eq with
                   | Eq -> peq ceqb q0 q'
-                  | _ -> False)
-           | _ -> False)
+                  | _ -> false)
+           | _ -> false)
     | PX (p2, i, q0) ->
         (match p' with
            | PX (p'0, i', q') ->
                (match pcompare i i' Eq with
-                  | Eq ->
-                      (match peq ceqb p2 p'0 with
-                         | True -> peq ceqb q0 q'
-                         | False -> False)
-                  | _ -> False)
-           | _ -> False)
+                  | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false
+                  | _ -> false)
+           | _ -> false)
 
 (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
 
@@ -506,18 +489,17 @@ let mkPinj_pred j p =
 let mkPX cO ceqb p i q0 =
   match p with
     | Pc c ->
-        (match ceqb c cO with
-           | True ->
-               (match q0 with
-                  | Pc c0 -> q0
-                  | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
-                  | PX (p2, p3, p4) -> Pinj (XH, q0))
-           | False -> PX (p, i, q0))
+        if ceqb c cO
+        then (match q0 with
+                | Pc c0 -> q0
+                | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+                | PX (p2, p3, p4) -> Pinj (XH, q0))
+        else PX (p, i, q0)
     | Pinj (p2, p3) -> PX (p, i, q0)
     | PX (p', i', q') ->
-        (match peq ceqb q' (p0 cO) with
-           | True -> PX (p', (pplus i' i), q0)
-           | False -> PX (p, i, q0))
+        if peq ceqb q' (p0 cO)
+        then PX (p', (pplus i' i), q0)
+        else PX (p, i, q0)
 
 (** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **)
 
@@ -751,12 +733,9 @@ let rec pmulC_aux cO cmul ceqb p c =
     'a1 -> 'a1 pol **)
 
 let pmulC cO cI cmul ceqb p c =
-  match ceqb c cO with
-    | True -> p0 cO
-    | False ->
-        (match ceqb c cI with
-           | True -> p
-           | False -> pmulC_aux cO cmul ceqb p c)
+  if ceqb c cO
+  then p0 cO
+  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 ->
@@ -831,13 +810,32 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
                      (match q0 with
                         | Pc c -> q0
                         | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
-                        | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' 
+                        | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i'
                  (p0 cO))
                (mkPX cO ceqb
                  (pmulI cO cI cmul ceqb (fun x x0 ->
                    pmul cO cI cadd cmul ceqb x x0) q' XH p2) i
                  (pmul cO cI cadd cmul ceqb q0 q')))
 
+(** val psquare :
+    '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)
+  | Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0))
+  | PX (p2, i, q0) ->
+      mkPX cO ceqb
+        (padd cO cadd ceqb
+          (mkPX cO ceqb (psquare cO cI cadd cmul ceqb p2) i (p0 cO))
+          (pmul cO cI cadd cmul ceqb p2
+            (let p3 = pmulC cO cI cmul ceqb q0 (cadd cI cI) in
+            match p3 with
+              | Pc c -> p3
+              | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+              | PX (p4, p5, p6) -> Pinj (XH, p3)))) i
+        (psquare cO cI cadd cmul ceqb q0)
+
 type 'c pExpr =
   | PEc of 'c
   | PEX of positive
@@ -928,12 +926,12 @@ type 'term' cnf = 'term' clause list
 (** val tt : 'a1 cnf **)
 
 let tt =
-  Nil
+  []
 
 (** val ff : 'a1 cnf **)
 
 let ff =
-  Cons (Nil, Nil)
+  [] :: []
 
 (** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **)
 
@@ -944,8 +942,8 @@ let or_clause_cnf t0 f =
 
 let rec or_cnf f f' =
   match f with
-    | Nil -> tt
-    | Cons (e, rst) -> app (or_cnf rst f') (or_clause_cnf e f')
+    | [] -> tt
+    | e :: rst -> app (or_cnf rst f') (or_clause_cnf e f')
 
 (** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
 
@@ -956,64 +954,48 @@ let and_cnf f1 f2 =
     ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
 
 let rec xcnf normalise0 negate0 pol0 = function
-  | TT -> (match pol0 with
-             | True -> tt
-             | False -> ff)
-  | FF -> (match pol0 with
-             | True -> ff
-             | False -> tt)
+  | TT -> if pol0 then tt else ff
+  | FF -> if pol0 then ff else tt
   | X -> ff
-  | A x -> (match pol0 with
-              | True -> normalise0 x
-              | False -> negate0 x)
+  | A x -> if pol0 then normalise0 x else negate0 x
   | Cj (e1, e2) ->
-      (match pol0 with
-         | True ->
-             and_cnf (xcnf normalise0 negate0 pol0 e1)
-               (xcnf normalise0 negate0 pol0 e2)
-         | False ->
-             or_cnf (xcnf normalise0 negate0 pol0 e1)
-               (xcnf normalise0 negate0 pol0 e2))
+      if pol0
+      then and_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
+      else or_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
   | D (e1, e2) ->
-      (match pol0 with
-         | True ->
-             or_cnf (xcnf normalise0 negate0 pol0 e1)
-               (xcnf normalise0 negate0 pol0 e2)
-         | False ->
-             and_cnf (xcnf normalise0 negate0 pol0 e1)
-               (xcnf normalise0 negate0 pol0 e2))
+      if pol0
+      then or_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
+      else and_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
   | N e -> xcnf normalise0 negate0 (negb pol0) e
   | I (e1, e2) ->
-      (match pol0 with
-         | True ->
-             or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
-               (xcnf normalise0 negate0 pol0 e2)
-         | False ->
-             and_cnf (xcnf normalise0 negate0 (negb pol0) e1)
-               (xcnf normalise0 negate0 pol0 e2))
+      if pol0
+      then or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+             (xcnf normalise0 negate0 pol0 e2)
+      else and_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+             (xcnf normalise0 negate0 pol0 e2)
 
 (** val cnf_checker :
     ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **)
 
 let rec cnf_checker checker f l =
   match f with
-    | Nil -> True
-    | Cons (e, f0) ->
+    | [] -> true
+    | e :: f0 ->
         (match l with
-           | Nil -> False
-           | Cons (c, l0) ->
-               (match checker e c with
-                  | True -> cnf_checker checker f0 l0
-                  | False -> False))
+           | [] -> false
+           | c :: l0 ->
+               if checker e c then cnf_checker checker f0 l0 else false)
 
 (** val tauto_checker :
     ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
     bFormula -> 'a3 list -> bool **)
 
 let tauto_checker normalise0 negate0 checker f w =
-  cnf_checker checker (xcnf normalise0 negate0 True f) w
-
-type 'c pExprC = 'c pExpr
+  cnf_checker checker (xcnf normalise0 negate0 true f) w
 
 type 'c polC = 'c pol
 
@@ -1023,123 +1005,137 @@ type op1 =
   | Strict
   | NonStrict
 
-type 'c nFormula = ('c pExprC, op1) prod
-
-type monoidMember = nat list
-
-type 'c coneMember =
-  | S_In of nat
-  | S_Ideal of 'c pExprC * 'c coneMember
-  | S_Square of 'c pExprC
-  | S_Monoid of monoidMember
-  | S_Mult of 'c coneMember * 'c coneMember
-  | S_Add of 'c coneMember * 'c coneMember
-  | S_Pos of 'c
-  | S_Z
-
-(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
-
-let nformula_times f f' =
-  let Pair (p, op) = f in
-  let Pair (p', op') = f' in
-  Pair ((PEmul (p, p')),
-  (match op with
-     | Equal -> Equal
-     | NonEqual -> NonEqual
-     | Strict -> op'
-     | NonStrict -> NonStrict))
-
-(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
-
-let nformula_plus f f' =
-  let Pair (p, op) = f in
-  let Pair (p', op') = f' in
-  Pair ((PEadd (p, p')),
-  (match op with
-     | Equal -> op'
-     | NonEqual -> NonEqual
-     | Strict -> Strict
-     | NonStrict -> (match op' with
-                       | Strict -> Strict
-                       | _ -> NonStrict)))
-
-(** val eval_monoid :
-    'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **)
-
-let rec eval_monoid cI l = function
-  | Nil -> PEc cI
-  | Cons (n0, ns0) -> PEmul
-      ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in
-       (match o with
-          | NonEqual -> q0
-          | _ -> PEc cI)), (eval_monoid cI l ns0))
-
-(** val eval_cone :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
-    nFormula list -> 'a1 coneMember -> 'a1 nFormula **)
-
-let rec eval_cone cO cI ceqb cleb l = function
-  | S_In n0 ->
-      let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in
-      (match o with
-         | NonEqual -> Pair ((PEc cO), Equal)
-         | _ -> nth n0 l (Pair ((PEc cO), Equal)))
-  | S_Ideal (p, cm') ->
-      let f = eval_cone cO cI ceqb cleb l cm' in
-      let Pair (q0, op) = f in
-      (match op with
-         | Equal -> Pair ((PEmul (q0, p)), Equal)
-         | _ -> f)
-  | S_Square p -> Pair ((PEmul (p, p)), NonStrict)
-  | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict)
-  | S_Mult (p, q0) ->
-      nformula_times (eval_cone cO cI ceqb cleb l p)
-        (eval_cone cO cI ceqb cleb l q0)
-  | S_Add (p, q0) ->
-      nformula_plus (eval_cone cO cI ceqb cleb l p)
-        (eval_cone cO cI ceqb cleb l q0)
-  | S_Pos c ->
-      (match match cleb cO c with
-               | True -> negb (ceqb cO c)
-               | False -> False with
-         | True -> Pair ((PEc c), Strict)
-         | False -> Pair ((PEc cO), Equal))
-  | S_Z -> Pair ((PEc cO), Equal)
-
-(** val normalise_pexpr :
+type 'c nFormula = 'c polC  *  op1
+
+(** val opAdd : op1 -> op1 -> op1 option **)
+
+let opAdd o o' =
+  match o with
+    | Equal -> Some o'
+    | NonEqual -> (match o' with
+                     | Equal -> Some NonEqual
+                     | _ -> None)
+    | Strict -> (match o' with
+                   | NonEqual -> None
+                   | _ -> Some Strict)
+    | NonStrict ->
+        (match o' with
+           | NonEqual -> None
+           | Strict -> Some Strict
+           | _ -> Some NonStrict)
+
+type 'c psatz =
+  | PsatzIn of nat
+  | PsatzSquare of 'c polC
+  | PsatzMulC of 'c polC * 'c psatz
+  | PsatzMulE of 'c psatz * 'c psatz
+  | PsatzAdd of 'c psatz * 'c psatz
+  | PsatzC of 'c
+  | PsatzZ
+
+(** val pexpr_times_nformula :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **)
+    -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
 
-let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x =
-  norm_aux cO cI cplus ctimes cminus copp ceqb x
+let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
+  | ef , o ->
+      (match o with
+         | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef) , Equal)
+         | _ -> None)
 
-(** val check_inconsistent :
+(** val nformula_times_nformula :
+    '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
+  let e2 , o2 = f2 in
+  (match o1 with
+     | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal)
+     | NonEqual ->
+         (match o2 with
+            | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal)
+            | NonEqual -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) ,
+                NonEqual)
+            | _ -> None)
+     | Strict ->
+         (match o2 with
+            | NonEqual -> None
+            | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , o2))
+     | NonStrict ->
+         (match o2 with
+            | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal)
+            | NonEqual -> None
+            | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , NonStrict)))
+
+(** val nformula_plus_nformula :
+    '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
+  let e2 , o2 = f2 in
+  (match opAdd o1 o2 with
+     | Some x -> Some ((padd cO cplus ceqb e1 e2) , x)
+     | None -> None)
+
+(** val eval_Psatz :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
-    -> 'a1 nFormula -> bool **)
+    -> 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))
+  | PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0) , NonStrict)
+  | PsatzMulC (re, e0) ->
+      (match eval_Psatz cO cI cplus ctimes ceqb cleb l e0 with
+         | Some x -> pexpr_times_nformula cO cI cplus ctimes ceqb re x
+         | None -> None)
+  | PsatzMulE (f1, f2) ->
+      (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with
+         | Some x ->
+             (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with
+                | Some x' ->
+                    nformula_times_nformula cO cI cplus ctimes ceqb x x'
+                | None -> None)
+         | None -> None)
+  | PsatzAdd (f1, f2) ->
+      (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with
+         | Some x ->
+             (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with
+                | Some x' -> nformula_plus_nformula cO cplus ceqb x x'
+                | None -> None)
+         | None -> None)
+  | PsatzC c ->
+      if (&&) (cleb cO c) (negb (ceqb cO c))
+      then Some ((Pc c) , Strict)
+      else None
+  | PsatzZ -> Some ((Pc cO) , Equal)
 
-let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function
-  | Pair (e, op) ->
-      (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with
+(** val check_inconsistent :
+    'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+    bool **)
+
+let check_inconsistent cO ceqb cleb = function
+  | e , op ->
+      (match e with
          | Pc c ->
              (match op with
                 | Equal -> negb (ceqb c cO)
-                | NonEqual -> False
+                | NonEqual -> ceqb c cO
                 | Strict -> cleb c cO
-                | NonStrict ->
-                    (match cleb c cO with
-                       | True -> negb (ceqb c cO)
-                       | False -> False))
-         | _ -> False)
+                | NonStrict -> (&&) (cleb c cO) (negb (ceqb c cO)))
+         | _ -> false)
 
 (** val check_normalised_formulas :
     'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
-    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
-    -> 'a1 nFormula list -> 'a1 coneMember -> bool **)
+    -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+    bool **)
 
-let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm =
-  check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb
-    (eval_cone cO cI ceqb cleb l cm)
+let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm =
+  match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with
+    | Some f -> check_inconsistent cO ceqb cleb f
+    | None -> false
 
 type op2 =
   | OpEq
@@ -1149,9 +1145,9 @@ type op2 =
   | OpLt
   | OpGt
 
-type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
 
-(** val flhs : 'a1 formula -> 'a1 pExprC **)
+(** val flhs : 'a1 formula -> 'a1 pExpr **)
 
 let flhs x = x.flhs
 
@@ -1159,132 +1155,164 @@ let flhs x = x.flhs
 
 let fop x = x.fop
 
-(** val frhs : 'a1 formula -> 'a1 pExprC **)
+(** val frhs : 'a1 formula -> 'a1 pExpr **)
 
 let frhs x = x.frhs
 
-(** val xnormalise : 'a1 formula -> 'a1 nFormula list **)
+(** val norm :
+    '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 pe =
+  norm_aux cO cI cplus ctimes cminus copp ceqb pe
 
-let xnormalise t0 =
+(** val psub0 :
+    '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 p p' =
+  psub cO cplus cminus copp ceqb p p'
+
+(** val padd0 :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+    -> 'a1 pol **)
+
+let padd0 cO cplus ceqb p p' =
+  padd cO cplus ceqb p p'
+
+(** val xnormalise :
+    '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 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 -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
-         ((PEsub (rhs, lhs)), Strict)), Nil)))
-     | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
-     | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)
-     | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
-     | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
-     | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
-
-(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **)
+     | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) ::
+         (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [])
+     | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: []
+     | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: []
+     | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []
+     | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) ::
+         []
+     | 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 **)
 
-let cnf_normalise t0 =
-  map (fun x -> Cons (x, Nil)) (xnormalise t0)
+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 formula -> 'a1 nFormula list **)
+(** val xnegate :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+    nFormula list **)
 
-let xnegate t0 =
+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 -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
-     | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
-         ((PEsub (rhs, lhs)), Strict)), Nil)))
-     | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
-     | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
-     | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
-     | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil))
-
-(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **)
-
-let cnf_negate t0 =
-  map (fun x -> Cons (x, Nil)) (xnegate t0)
-
-(** val simpl_expr :
-    'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **)
-
-let rec simpl_expr cI ceqb e = match e with
-  | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y))
-  | PEmul (y, z0) ->
-      let y' = simpl_expr cI ceqb y in
-      (match y' with
-         | PEc c ->
-             (match ceqb c cI with
-                | True -> simpl_expr cI ceqb z0
-                | False -> PEmul (y', (simpl_expr cI ceqb z0)))
-         | _ -> PEmul (y', (simpl_expr cI ceqb z0)))
-  | _ -> e
+     | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: []
+     | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) ::
+         (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [])
+     | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) ::
+         []
+     | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) ::
+         []
+     | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []
+     | 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 **)
+
+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 **)
+
+let rec xdenorm jmp = function
+  | Pc c -> PEc c
+  | Pinj (j, p2) -> xdenorm (pplus j jmp) p2
+  | PX (p2, j, q0) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp),
+      (Npos j))))), (xdenorm (psucc jmp) q0))
+
+(** val denorm : 'a1 pol -> 'a1 pExpr **)
+
+let denorm p =
+  xdenorm XH p
 
 (** val simpl_cone :
-    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1
-    coneMember -> 'a1 coneMember **)
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
+    'a1 psatz **)
 
 let simpl_cone cO cI ctimes ceqb e = match e with
-  | S_Square t0 ->
-      (match simpl_expr cI ceqb t0 with
-         | PEc c ->
-             (match ceqb cO c with
-                | True -> S_Z
-                | False -> S_Pos (ctimes c c))
-         | _ -> S_Square (simpl_expr cI ceqb t0))
-  | S_Mult (t1, t2) ->
+  | PsatzSquare t0 ->
+      (match t0 with
+         | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
+         | _ -> PsatzSquare t0)
+  | PsatzMulE (t1, t2) ->
       (match t1 with
-         | S_Mult (x, x0) ->
+         | PsatzMulE (x, x0) ->
              (match x with
-                | S_Pos p2 ->
+                | PsatzC p2 ->
                     (match t2 with
-                       | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0)
-                       | S_Z -> S_Z
+                       | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
+                       | PsatzZ -> PsatzZ
                        | _ -> e)
                 | _ ->
                     (match x0 with
-                       | S_Pos p2 ->
+                       | PsatzC p2 ->
                            (match t2 with
-                              | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x)
-                              | S_Z -> S_Z
+                              | PsatzC c -> PsatzMulE ((PsatzC
+                                  (ctimes c p2)), x)
+                              | PsatzZ -> PsatzZ
                               | _ -> e)
                        | _ ->
                            (match t2 with
-                              | S_Pos c ->
-                                  (match ceqb cI c with
-                                     | True -> t1
-                                     | False -> S_Mult (t1, t2))
-                              | S_Z -> S_Z
+                              | PsatzC c ->
+                                  if ceqb cI c
+                                  then t1
+                                  else PsatzMulE (t1, t2)
+                              | PsatzZ -> PsatzZ
                               | _ -> e)))
-         | S_Pos c ->
+         | PsatzC c ->
              (match t2 with
-                | S_Mult (x, x0) ->
+                | PsatzMulE (x, x0) ->
                     (match x with
-                       | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0)
+                       | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
                        | _ ->
                            (match x0 with
-                              | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x)
+                              | PsatzC p2 -> PsatzMulE ((PsatzC
+                                  (ctimes c p2)), x)
                               | _ ->
-                                  (match ceqb cI c with
-                                     | True -> t2
-                                     | False -> S_Mult (t1, t2))))
-                | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult
-                    ((S_Pos c), z0)))
-                | S_Pos c0 -> S_Pos (ctimes c c0)
-                | S_Z -> S_Z
-                | _ ->
-                    (match ceqb cI c with
-                       | True -> t2
-                       | False -> S_Mult (t1, t2)))
-         | S_Z -> S_Z
+                                  if ceqb cI c
+                                  then t2
+                                  else PsatzMulE (t1, t2)))
+                | PsatzAdd (y, 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))
+         | PsatzZ -> PsatzZ
          | _ ->
              (match t2 with
-                | S_Pos c ->
-                    (match ceqb cI c with
-                       | True -> t1
-                       | False -> S_Mult (t1, t2))
-                | S_Z -> S_Z
+                | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2)
+                | PsatzZ -> PsatzZ
                 | _ -> e))
-  | S_Add (t1, t2) ->
+  | PsatzAdd (t1, t2) ->
       (match t1 with
-         | S_Z -> t2
+         | PsatzZ -> t2
          | _ -> (match t2 with
-                   | S_Z -> t1
-                   | _ -> S_Add (t1, t2)))
+                   | PsatzZ -> t1
+                   | _ -> PsatzAdd (t1, t2)))
   | _ -> e
 
 type q = { qnum : z; qden : positive }
@@ -1297,6 +1325,16 @@ let qnum x = x.qnum
 
 let qden x = x.qden
 
+(** val qeq_bool : q -> q -> bool **)
+
+let qeq_bool x y =
+  zeq_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))
+
+(** val qle_bool : q -> q -> bool **)
+
+let qle_bool x y =
+  zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))
+
 (** val qplus : q -> q -> q **)
 
 let qplus x y =
@@ -1318,6 +1356,70 @@ let qopp x =
 let qminus x y =
   qplus x (qopp y)
 
+(** val qinv : q -> q **)
+
+let qinv x =
+  match x.qnum with
+    | Z0 -> { qnum = Z0; qden = XH }
+    | Zpos p -> { qnum = (Zpos x.qden); qden = p }
+    | Zneg p -> { qnum = (Zneg x.qden); qden = p }
+
+(** val qpower_positive : q -> positive -> q **)
+
+let qpower_positive q0 p =
+  pow_pos qmult q0 p
+
+(** val qpower : q -> z -> q **)
+
+let qpower q0 = function
+  | Z0 -> { qnum = (Zpos XH); qden = XH }
+  | Zpos p -> qpower_positive q0 p
+  | Zneg p -> qinv (qpower_positive q0 p)
+
+(** val pgcdn : nat -> positive -> positive -> positive **)
+
+let rec pgcdn n0 a b =
+  match n0 with
+    | O -> XH
+    | S n1 ->
+        (match a with
+           | XI a' ->
+               (match b with
+                  | XI b' ->
+                      (match pcompare a' b' Eq with
+                         | Eq -> a
+                         | Lt -> pgcdn n1 (pminus b' a') a
+                         | Gt -> pgcdn n1 (pminus a' b') b)
+                  | XO b0 -> pgcdn n1 a b0
+                  | XH -> XH)
+           | XO a0 ->
+               (match b with
+                  | XI p -> pgcdn n1 a0 b
+                  | XO b0 -> XO (pgcdn n1 a0 b0)
+                  | XH -> XH)
+           | XH -> XH)
+
+(** val pgcd : positive -> positive -> positive **)
+
+let pgcd a b =
+  pgcdn (plus (psize a) (psize b)) a b
+
+(** val zgcd : z -> z -> z **)
+
+let zgcd a b =
+  match a with
+    | Z0 -> zabs b
+    | Zpos a0 ->
+        (match b with
+           | Z0 -> zabs a
+           | Zpos b0 -> Zpos (pgcd a0 b0)
+           | Zneg b0 -> Zpos (pgcd a0 b0))
+    | Zneg a0 ->
+        (match b with
+           | Z0 -> zabs a
+           | Zpos b0 -> Zpos (pgcd a0 b0)
+           | Zneg b0 -> Zpos (pgcd a0 b0))
+
 type 'a t =
   | Empty
   | Leaf of 'a
@@ -1335,150 +1437,216 @@ let rec find default vm p =
            | XO p2 -> find default l p2
            | XH -> e)
 
-type zWitness = z coneMember
+type zWitness = z psatz
 
-(** val zWeakChecker : z nFormula list -> z coneMember -> bool **)
+(** val zWeakChecker : z nFormula list -> z psatz -> bool **)
 
 let zWeakChecker x x0 =
-  check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool
-    zle_bool x x0
+  check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val psub1 : z pol -> z pol -> z pol **)
+
+let psub1 p p' =
+  psub0 Z0 zplus zminus zopp zeq_bool p p'
+
+(** val padd1 : z pol -> z pol -> z pol **)
+
+let padd1 p p' =
+  padd0 Z0 zplus zeq_bool p p'
+
+(** val norm0 : z pExpr -> z pol **)
+
+let norm0 pe =
+  norm Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool pe
 
 (** val xnormalise0 : z formula -> z nFormula list **)
 
 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
-     | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
-         NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
-         XH)))))), NonStrict)), Nil)))
-     | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
-     | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
-         NonStrict)), Nil)
-     | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
-         NonStrict)), Nil)
-     | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
-     | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+     | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) ::
+         (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [])
+     | OpNEq -> ((psub1 lhs0 rhs0) , Equal) :: []
+     | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: []
+     | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []
+     | OpLt -> ((psub1 lhs0 rhs0) , NonStrict) :: []
+     | OpGt -> ((psub1 rhs0 lhs0) , NonStrict) :: [])
 
 (** val normalise : z formula -> z nFormula cnf **)
 
 let normalise t0 =
-  map (fun x -> Cons (x, Nil)) (xnormalise0 t0)
+  map (fun x -> x :: []) (xnormalise0 t0)
 
 (** val xnegate0 : z formula -> z nFormula list **)
 
 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
-     | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
-     | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
-         NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
-         XH)))))), NonStrict)), Nil)))
-     | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
-     | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
-     | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
-         NonStrict)), Nil)
-     | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
-         NonStrict)), Nil))
+     | OpEq -> ((psub1 lhs0 rhs0) , Equal) :: []
+     | OpNEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) ::
+         (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [])
+     | OpLe -> ((psub1 rhs0 lhs0) , NonStrict) :: []
+     | OpGe -> ((psub1 lhs0 rhs0) , NonStrict) :: []
+     | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []
+     | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: [])
 
 (** val negate : z formula -> z nFormula cnf **)
 
 let negate t0 =
-  map (fun x -> Cons (x, Nil)) (xnegate0 t0)
+  map (fun x -> x :: []) (xnegate0 t0)
 
 (** val ceiling : z -> z -> z **)
 
 let ceiling a b =
-  let Pair (q0, r) = zdiv_eucl a b in
+  let q0 , r = zdiv_eucl a b in
   (match r with
      | Z0 -> q0
      | _ -> zplus q0 (Zpos XH))
 
-type proofTerm =
-  | RatProof of zWitness
-  | CutProof of z pExprC * q * zWitness * proofTerm
-  | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+type zArithProof =
+  | DoneProof
+  | RatProof of zWitness * zArithProof
+  | CutProof of zWitness * zArithProof
+  | EnumProof of zWitness * zWitness * zArithProof list
 
-(** val makeLb : z pExpr -> q -> z nFormula **)
+(** val zgcdM : z -> z -> z **)
 
-let makeLb v q0 =
-  let { qnum = n0; qden = d } = q0 in
-  Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict)
+let zgcdM x y =
+  zmax (zgcd x y) (Zpos XH)
 
-(** val qceiling : q -> z **)
+(** val zgcd_pol : z polC -> z  *  z **)
 
-let qceiling q0 =
-  let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d)
+let rec zgcd_pol = function
+  | Pc c -> Z0 , c
+  | Pinj (p2, p3) -> zgcd_pol p3
+  | PX (p2, p3, q0) ->
+      let g1 , c1 = zgcd_pol p2 in
+      let g2 , c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2) , c2
 
-(** val makeLbCut : z pExprC -> q -> z nFormula **)
+(** val zdiv_pol : z polC -> z -> z polC **)
 
-let makeLbCut v q0 =
-  Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict)
+let rec zdiv_pol p x =
+  match p with
+    | Pc c -> Pc (zdiv c x)
+    | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x))
+    | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x))
 
-(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **)
+(** val makeCuttingPlane : z polC -> z polC  *  z **)
 
-let neg_nformula = function
-  | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o)
+let makeCuttingPlane p =
+  let g , c = zgcd_pol p in
+  if zgt_bool g Z0
+  then (zdiv_pol (psubC zminus p c) g) , (zopp (ceiling (zopp c) g))
+  else p , Z0
 
-(** val cutChecker :
-    z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **)
+(** val genCuttingPlane : z nFormula -> ((z polC  *  z)  *  op1) option **)
 
-let cutChecker l e lb pf =
-  match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with
-    | True -> Some (makeLbCut e lb)
-    | False -> None
+let genCuttingPlane = function
+  | e , op ->
+      (match op with
+         | Equal ->
+             let g , c = zgcd_pol e in
+             if (&&) (zgt_bool g Z0)
+                  ((&&) (zgt_bool c Z0) (negb (zeq_bool (zgcd g c) g)))
+             then None
+             else Some ((e , Z0) , op)
+         | NonEqual -> Some ((e , Z0) , op)
+         | Strict ->
+             let p , c = makeCuttingPlane (psubC zminus e (Zpos XH)) in
+             Some ((p , c) , NonStrict)
+         | NonStrict ->
+             let p , c = makeCuttingPlane e in Some ((p , c) , NonStrict))
 
-(** val zChecker : z nFormula list -> proofTerm -> bool **)
+(** val nformula_of_cutting_plane :
+    ((z polC  *  z)  *  op1) -> z nFormula **)
 
-let rec zChecker l = function
-  | RatProof pf0 -> zWeakChecker l pf0
-  | CutProof (e, q0, pf0, rst) ->
-      (match cutChecker l e q0 pf0 with
-         | Some c -> zChecker (Cons (c, l)) rst
-         | None -> False)
-  | EnumProof (lb, e, ub, pf1, pf2, rst) ->
-      (match cutChecker l e lb pf1 with
-         | Some n0 ->
-             (match cutChecker l (PEopp e) (qopp ub) pf2 with
-                | Some n1 ->
-                    let rec label pfs lb0 ub0 =
-                      match pfs with
-                        | Nil ->
-                            (match z_gt_dec lb0 ub0 with
-                               | Left -> True
-                               | Right -> False)
-                        | Cons (pf0, rsr) ->
-                            (match zChecker (Cons ((Pair ((PEsub (e, (PEc
-                                     lb0))), Equal)), l)) pf0 with
-                               | True -> label rsr (zplus lb0 (Zpos XH)) ub0
-                               | False -> False)
-                    in label rst (qceiling lb) (zopp (qceiling (qopp ub)))
-                | None -> False)
-         | None -> False)
-
-(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **)
+let nformula_of_cutting_plane = function
+  | e_z , o -> let e , z0 = e_z in (padd1 e (Pc z0)) , o
 
-let zTautoChecker f w =
-  tauto_checker normalise negate zChecker f w
+(** val is_pol_Z0 : z polC -> bool **)
 
-(** val map_cone : (nat -> nat) -> zWitness -> zWitness **)
+let is_pol_Z0 = function
+  | Pc z0 -> (match z0 with
+                | Z0 -> true
+                | _ -> false)
+  | _ -> false
 
-let rec map_cone f e = match e with
-  | S_In n0 -> S_In (f n0)
-  | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm))
-  | S_Monoid l -> S_Monoid (map f l)
-  | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2))
-  | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2))
-  | _ -> e
+(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **)
+
+let eval_Psatz0 x x0 =
+  eval_Psatz Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val check_inconsistent0 : z nFormula -> bool **)
 
-(** val indexes : zWitness -> nat list **)
+let check_inconsistent0 f =
+  check_inconsistent Z0 zeq_bool zle_bool f
 
-let rec indexes = function
-  | S_In n0 -> Cons (n0, Nil)
-  | S_Ideal (e0, cm) -> indexes cm
-  | S_Monoid l -> l
-  | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2)
-  | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2)
-  | _ -> Nil
+(** val zChecker : z nFormula list -> zArithProof -> bool **)
+
+let rec zChecker l = function
+  | DoneProof -> false
+  | RatProof (w, pf0) ->
+      (match eval_Psatz0 l w with
+         | Some f ->
+             if check_inconsistent0 f then true else zChecker (f :: l) pf0
+         | None -> false)
+  | CutProof (w, pf0) ->
+      (match eval_Psatz0 l w with
+         | Some f ->
+             (match genCuttingPlane f with
+                | Some cp ->
+                    zChecker ((nformula_of_cutting_plane cp) :: l) pf0
+                | None -> true)
+         | None -> false)
+  | EnumProof (w1, w2, pf0) ->
+      (match eval_Psatz0 l w1 with
+         | Some f1 ->
+             (match eval_Psatz0 l w2 with
+                | Some f2 ->
+                    (match genCuttingPlane f1 with
+                       | Some p ->
+                           let p2 , op3 = p in
+                           let e1 , z1 = p2 in
+                           (match genCuttingPlane f2 with
+                              | Some p3 ->
+                                  let p4 , op4 = p3 in
+                                  let e2 , z2 = p4 in
+                                  (match op3 with
+                                     | NonStrict ->
+                                         (match op4 with
+                                            | NonStrict ->
+                                                if is_pol_Z0 (padd1 e1 e2)
+                                                then
+                                                  let rec label pfs lb ub =
+
+                                                  match pfs with
+                                                    |
+                                                  [] -> zgt_bool lb ub
+                                                    |
+                                                  pf1 :: rsr ->
+                                                  (&&)
+                                                  (zChecker
+                                                  (((psub1 e1 (Pc lb)) ,
+                                                  Equal) :: l) pf1)
+                                                  (label rsr
+                                                  (zplus lb (Zpos XH)) ub)
+                                                  in label pf0 (zopp z1) z2
+                                                else false
+                                            | _ -> false)
+                                     | _ -> false)
+                              | None -> false)
+                       | None -> false)
+                | None -> false)
+         | None -> false)
+
+(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **)
+
+let zTautoChecker f w =
+  tauto_checker normalise negate zChecker f w
 
 (** val n_of_Z : z -> n **)
 
@@ -1486,27 +1654,50 @@ let n_of_Z = function
   | Zpos p -> Npos p
   | _ -> N0
 
-(** val qeq_bool : q -> q -> bool **)
+type qWitness = q psatz
 
-let qeq_bool p q0 =
-  zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.qden))
+(** val qWeakChecker : q nFormula list -> q psatz -> bool **)
 
-(** val qle_bool : q -> q -> bool **)
+let qWeakChecker x x0 =
+  check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+    qden = XH } qplus qmult qeq_bool qle_bool x x0
 
-let qle_bool x y =
-  zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))
+(** val qnormalise : q formula -> q nFormula cnf **)
 
-type qWitness = q coneMember
+let qnormalise t0 =
+  cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+    qplus qmult qminus qopp qeq_bool t0
 
-(** val qWeakChecker : q nFormula list -> q coneMember -> bool **)
+(** val qnegate : q formula -> q nFormula cnf **)
 
-let qWeakChecker x x0 =
-  check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
-    qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0
+let qnegate t0 =
+  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
+    qmult qminus qopp qeq_bool t0
 
 (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
 
 let qTautoChecker f w =
-  tauto_checker (fun x -> cnf_normalise x) (fun x -> 
-    cnf_negate x) qWeakChecker f w
+  tauto_checker qnormalise qnegate qWeakChecker f w
+
+type rWitness = z psatz
+
+(** val rWeakChecker : z nFormula list -> z psatz -> bool **)
+
+let rWeakChecker x x0 =
+  check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val rnormalise : z formula -> z nFormula cnf **)
+
+let rnormalise t0 =
+  cnf_normalise Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+
+(** val rnegate : z formula -> z nFormula cnf **)
+
+let rnegate t0 =
+  cnf_negate Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+
+(** val rTautoChecker : z formula bFormula -> rWitness list -> bool **)
+
+let rTautoChecker f w =
+  tauto_checker rnormalise rnegate rWeakChecker f w
 
diff --git a/contrib/micromega/micromega.mli b/plugins/micromega/micromega.mli
index f94f091e..3e3ae2c3 100644
--- a/contrib/micromega/micromega.mli
+++ b/plugins/micromega/micromega.mli
@@ -1,22 +1,9 @@
-type __ = Obj.t
-
-type bool =
-  | True
-  | False
-
 val negb : bool -> bool
 
 type nat =
   | O
   | S of nat
 
-type 'a option =
-  | Some of 'a
-  | None
-
-type ('a, 'b) prod =
-  | Pair of 'a * 'b
-
 type comparison =
   | Eq
   | Lt
@@ -24,17 +11,7 @@ type comparison =
 
 val compOpp : comparison -> comparison
 
-type sumbool =
-  | Left
-  | Right
-
-type 'a sumor =
-  | Inleft of 'a
-  | Inright
-
-type 'a list =
-  | Nil
-  | Cons of 'a * 'a list
+val plus : nat -> nat -> nat
 
 val app : 'a1 list -> 'a1 list -> 'a1 list
 
@@ -78,10 +55,14 @@ val pmult : positive -> positive -> positive
 
 val pcompare : positive -> positive -> comparison -> comparison
 
+val psize : positive -> nat
+
 type n =
   | N0
   | Npos of positive
 
+val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
+
 type z =
   | Z0
   | Zpos of positive
@@ -105,11 +86,9 @@ val zmult : z -> z -> z
 
 val zcompare : z -> z -> comparison
 
-val dcompare_inf : comparison -> sumbool sumor
-
-val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+val zabs : z -> z
 
-val z_gt_dec : z -> z -> sumbool
+val zmax : z -> z -> z
 
 val zle_bool : z -> z -> bool
 
@@ -121,9 +100,11 @@ val zeq_bool : z -> z -> bool
 
 val n_of_nat : nat -> n
 
-val zdiv_eucl_POS : positive -> z -> (z, z) prod
+val zdiv_eucl_POS : positive -> z -> z  *  z
 
-val zdiv_eucl : z -> z -> (z, z) prod
+val zdiv_eucl : z -> z -> z  *  z
+
+val zdiv : z -> z -> z
 
 type 'c pol =
   | Pc of 'c
@@ -191,6 +172,10 @@ val pmul :
   '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
+
 type 'c pExpr =
   | PEc of 'c
   | PEX of positive
@@ -247,8 +232,6 @@ val tauto_checker :
   ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
   bFormula -> 'a3 list -> bool
 
-type 'c pExprC = 'c pExpr
-
 type 'c polC = 'c pol
 
 type op1 =
@@ -257,43 +240,42 @@ type op1 =
   | Strict
   | NonStrict
 
-type 'c nFormula = ('c pExprC, op1) prod
-
-type monoidMember = nat list
+type 'c nFormula = 'c polC  *  op1
 
-type 'c coneMember =
-  | S_In of nat
-  | S_Ideal of 'c pExprC * 'c coneMember
-  | S_Square of 'c pExprC
-  | S_Monoid of monoidMember
-  | S_Mult of 'c coneMember * 'c coneMember
-  | S_Add of 'c coneMember * 'c coneMember
-  | S_Pos of 'c
-  | S_Z
+val opAdd : op1 -> op1 -> op1 option
 
-val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+type 'c psatz =
+  | PsatzIn of nat
+  | PsatzSquare of 'c polC
+  | PsatzMulC of 'c polC * 'c psatz
+  | PsatzMulE of 'c psatz * 'c psatz
+  | PsatzAdd of 'c psatz * 'c psatz
+  | PsatzC of 'c
+  | PsatzZ
 
-val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+val pexpr_times_nformula :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
 
-val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC
+val nformula_times_nformula :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
 
-val eval_cone :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula
-  list -> 'a1 coneMember -> 'a1 nFormula
+val nformula_plus_nformula :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
+  nFormula -> 'a1 nFormula option
 
-val normalise_pexpr :
+val eval_Psatz :
   'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC
+  bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
+  nFormula option
 
 val check_inconsistent :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
-  'a1) -> ('a1 -> '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 ->
-  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
-  nFormula list -> 'a1 coneMember -> bool
+  bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
 
 type op2 =
   | OpEq
@@ -303,27 +285,53 @@ type op2 =
   | OpLt
   | OpGt
 
-type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
 
-val flhs : 'a1 formula -> 'a1 pExprC
+val flhs : 'a1 formula -> 'a1 pExpr
 
 val fop : 'a1 formula -> op2
 
-val frhs : 'a1 formula -> 'a1 pExprC
+val frhs : 'a1 formula -> 'a1 pExpr
 
-val xnormalise : 'a1 formula -> 'a1 nFormula list
+val norm :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
 
-val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf
+val psub0 :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+  -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
 
-val xnegate : 'a1 formula -> 'a1 nFormula list
+val padd0 :
+  '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
 
-val cnf_negate : 'a1 formula -> 'a1 nFormula cnf
+val cnf_normalise :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+  cnf
 
-val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC
+val xnegate :
+  '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
+
+val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
+
+val denorm : 'a1 pol -> 'a1 pExpr
 
 val simpl_cone :
-  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember
-  -> 'a1 coneMember
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
+  'a1 psatz
 
 type q = { qnum : z; qden : positive }
 
@@ -331,6 +339,10 @@ val qnum : q -> z
 
 val qden : q -> positive
 
+val qeq_bool : q -> q -> bool
+
+val qle_bool : q -> q -> bool
+
 val qplus : q -> q -> q
 
 val qmult : q -> q -> q
@@ -339,6 +351,18 @@ val qopp : q -> q
 
 val qminus : q -> q -> q
 
+val qinv : q -> q
+
+val qpower_positive : q -> positive -> q
+
+val qpower : q -> z -> q
+
+val pgcdn : nat -> positive -> positive -> positive
+
+val pgcd : positive -> positive -> positive
+
+val zgcd : z -> z -> z
+
 type 'a t =
   | Empty
   | Leaf of 'a
@@ -346,9 +370,15 @@ type 'a t =
 
 val find : 'a1 -> 'a1 t -> positive -> 'a1
 
-type zWitness = z coneMember
+type zWitness = z psatz
+
+val zWeakChecker : z nFormula list -> z psatz -> bool
+
+val psub1 : z pol -> z pol -> z pol
+
+val padd1 : z pol -> z pol -> z pol
 
-val zWeakChecker : z nFormula list -> z coneMember -> bool
+val norm0 : z pExpr -> z pol
 
 val xnormalise0 : z formula -> z nFormula list
 
@@ -360,39 +390,53 @@ val negate : z formula -> z nFormula cnf
 
 val ceiling : z -> z -> z
 
-type proofTerm =
-  | RatProof of zWitness
-  | CutProof of z pExprC * q * zWitness * proofTerm
-  | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+type zArithProof =
+  | DoneProof
+  | RatProof of zWitness * zArithProof
+  | CutProof of zWitness * zArithProof
+  | EnumProof of zWitness * zWitness * zArithProof list
 
-val makeLb : z pExpr -> q -> z nFormula
+val zgcdM : z -> z -> z
 
-val qceiling : q -> z
+val zgcd_pol : z polC -> z  *  z
 
-val makeLbCut : z pExprC -> q -> z nFormula
+val zdiv_pol : z polC -> z -> z polC
 
-val neg_nformula : z nFormula -> (z pExpr, op1) prod
+val makeCuttingPlane : z polC -> z polC  *  z
 
-val cutChecker :
-  z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option
+val genCuttingPlane : z nFormula -> ((z polC  *  z)  *  op1) option
 
-val zChecker : z nFormula list -> proofTerm -> bool
+val nformula_of_cutting_plane : ((z polC  *  z)  *  op1) -> z nFormula
 
-val zTautoChecker : z formula bFormula -> proofTerm list -> bool
+val is_pol_Z0 : z polC -> bool
 
-val map_cone : (nat -> nat) -> zWitness -> zWitness
+val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option
 
-val indexes : zWitness -> nat list
+val check_inconsistent0 : z nFormula -> bool
+
+val zChecker : z nFormula list -> zArithProof -> bool
+
+val zTautoChecker : z formula bFormula -> zArithProof list -> bool
 
 val n_of_Z : z -> n
 
-val qeq_bool : q -> q -> bool
+type qWitness = q psatz
 
-val qle_bool : q -> q -> bool
+val qWeakChecker : q nFormula list -> q psatz -> bool
 
-type qWitness = q coneMember
+val qnormalise : q formula -> q nFormula cnf
 
-val qWeakChecker : q nFormula list -> q coneMember -> bool
+val qnegate : q formula -> q nFormula cnf
 
 val qTautoChecker : q formula bFormula -> qWitness list -> bool
 
+type rWitness = z psatz
+
+val rWeakChecker : z nFormula list -> z psatz -> bool
+
+val rnormalise : z formula -> z nFormula cnf
+
+val rnegate : z formula -> z nFormula cnf
+
+val rTautoChecker : z formula bFormula -> rWitness list -> bool
+
diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib
new file mode 100644
index 00000000..debc296e
--- /dev/null
+++ b/plugins/micromega/micromega_plugin.mllib
@@ -0,0 +1,9 @@
+Sos_types
+Mutils
+Micromega
+Mfourier
+Certificate
+Persistent_cache
+Coq_micromega
+G_micromega
+Micromega_plugin_mod
diff --git a/contrib/micromega/mutils.ml b/plugins/micromega/mutils.ml
index 2473608f..ec06fa58 100644
--- a/contrib/micromega/mutils.ml
+++ b/plugins/micromega/mutils.ml
@@ -14,16 +14,63 @@
 
 let debug = false
 
-let fst' (Micromega.Pair(x,y)) = x
-let snd' (Micromega.Pair(x,y)) = y
+let finally f rst =
+  try
+    let res = f () in
+      rst () ; res
+  with x ->
+    (try rst ()
+    with _  -> raise x
+    ); raise x
+
+let map_option f x =
+  match x with
+    | None -> None
+    | Some v -> Some (f v)
+
+let from_option = function
+  | None -> failwith "from_option"
+  | Some v -> v
 
-let rec try_any l x = 
+let rec try_any l x =
  match l with
   | [] -> None
   | (f,s)::l -> match f x with
      | None -> try_any l x
      | x -> x
 
+let iteri f l =
+ let rec xiter i l =
+  match l with
+   | [] -> ()
+   | e::l -> f i e ; xiter (i+1) l in
+  xiter 0 l
+
+let mapi f l =
+ let rec xmap i l =
+  match l with
+   | [] -> []
+   | e::l -> (f i e)::xmap (i+1) l in
+  xmap 0 l
+
+let rec map3 f l1 l2 l3 =
+  match l1 , l2 ,l3 with
+    | [] , [] , [] -> []
+    | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3)
+    |      _   -> raise (Invalid_argument "map3")
+
+
+
+let rec is_sublist l1 l2 =
+  match l1 ,l2 with
+    | [] ,_ -> true
+    | e::l1', [] -> false
+    | e::l1' , e'::l2' ->
+	if e = e' then is_sublist l1' l2'
+	else is_sublist l1 l2'
+
+
+
 let list_try_find f =
   let rec try_find_f = function
     | [] -> failwith "try_find"
@@ -38,16 +85,16 @@ let rec list_fold_right_elements f l =
     | x::l -> f x (aux l) in
   aux l
 
-let interval n m = 
+let interval n m =
   let rec interval_n (l,m) =
     if n > m then l else interval_n (m::l,pred m)
-  in 
+  in
   interval_n ([],m)
 
 open Num
 open Big_int
 
-let ppcm x y = 
+let ppcm x y =
  let g = gcd_big_int x y in
  let x' = div_big_int x g in
  let y' = div_big_int y g in
@@ -68,26 +115,26 @@ let rec ppcm_list c l =
   | [] -> c
   | e::l -> ppcm_list (ppcm c (denominator e)) l
 
-let rec rec_gcd_list c l  = 
+let rec rec_gcd_list c l  =
  match l with
   | [] -> c
   | e::l -> rec_gcd_list (gcd_big_int  c (numerator e)) l
 
-let rec gcd_list l = 
+let rec gcd_list l =
  let res = rec_gcd_list zero_big_int l in
-  if compare_big_int res zero_big_int = 0 
+  if compare_big_int res zero_big_int = 0
   then unit_big_int else res
-   
-   
-   
-let rats_to_ints l = 
+
+
+
+let rats_to_ints l =
  let c = ppcm_list unit_big_int l in
-  List.map (fun x ->  (div_big_int (mult_big_int (numerator x) c) 
+  List.map (fun x ->  (div_big_int (mult_big_int (numerator x) c)
 			(denominator x))) l
-   
+
 (* Nasty reordering of lists - useful to trim certificate down *)
 let mapi f l =
- let rec xmapi i l = 
+ let rec xmapi i l =
   match l with
    | []   -> []
    | e::l ->  (f e i)::(xmapi (i+1) l) in
@@ -99,11 +146,11 @@ let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l)
 (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *)
 let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l))
 
-let assoc_pos_assoc l = 
+let assoc_pos_assoc l =
  let rec xpos i l =
   match l with
    | [] -> []
-   | (x,l) ::rst -> let (l',j) = assoc_pos i l in 
+   | (x,l) ::rst -> let (l',j) = assoc_pos i l in
 		     (x,l')::(xpos j rst) in
   xpos 0 l
 
@@ -112,7 +159,7 @@ let filter_pos f l =
  let rec xfilter l =
   match l with
    | []  -> []
-   | (x,e)::l -> 
+   | (x,e)::l ->
       if List.exists (fun ee -> List.mem ee f) (List.map snd e)
       then (x,e)::(xfilter l)
       else xfilter l in
@@ -122,11 +169,11 @@ let  select_pos lpos l =
  let rec xselect i lpos l =
   match lpos with
    | [] -> []
-   | j::rpos -> 
+   | j::rpos ->
       match l with
        | []   -> failwith "select_pos"
-       | e::l -> 
-	  if i = j 
+       | e::l ->
+	  if i = j
 	  then e:: (xselect (i+1) rpos l)
 	  else xselect (i+1) lpos l in
   xselect 0 lpos l
@@ -141,7 +188,7 @@ struct
   | S n -> (nat n) + 1
 
 
- let rec positive p = 
+ let rec positive p =
   match p with
    | XH -> 1
    | XI p -> 1+ 2*(positive p)
@@ -161,7 +208,7 @@ struct
    | XO i -> 2*(index i)
 
 
- let z x = 
+ let z x =
   match x with
    | Z0 -> 0
    | Zpos p -> (positive p)
@@ -176,7 +223,7 @@ struct
    | XO p -> (mult_int_big_int 2 (positive_big_int p))
 
 
- let z_big_int x = 
+ let z_big_int x =
   match x with
    | Z0 -> zero_big_int
    | Zpos p -> (positive_big_int p)
@@ -185,14 +232,9 @@ struct
 
  let num x = Num.Big_int (z_big_int x)
 
- let rec list elt l =
-  match l with
-   | Nil -> []
-   | Cons(e,l) -> (elt e)::(list elt l)
-
- let q_to_num {qnum = x ; qden = y} = 
+ let q_to_num {qnum = x ; qden = y} =
   Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y)))
-  
+
 end
 
 
@@ -210,92 +252,83 @@ struct
   else if n land 1 = 1 then XI (positive (n lsr 1))
   else  XO (positive (n lsr 1))
 
- let  n nt = 
-  if nt < 0 
+ let  n nt =
+  if nt < 0
   then assert false
   else if nt = 0 then N0
   else Npos (positive nt)
 
-
-   
-
-   
  let rec index  n =
   if n=1 then XH
   else if n land 1 = 1 then XI (index (n lsr 1))
   else  XO (index (n lsr 1))
 
 
- let idx n = 
+ 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 n=1 then [] 
+   if n=1 then []
    else (n mod 2 = 1)::(digits_of_int (n lsr 1))
   in
-   List.fold_right 
+   List.fold_right
     (fun b c -> (if b then XI c else XO c))
     (List.rev (digits_of_int n))
     (XH)
 
-    
-
- let z x = 
+ let z x =
   match compare x 0 with
    | 0 -> Z0
    | 1 -> Zpos (positive x)
    | _ -> (* this should be -1 *)
-      Zneg (positive (-x)) 
+      Zneg (positive (-x))
 
  open Big_int
 
- let positive_big_int n = 
-  let two = big_int_of_int 2 in 
-  let rec _pos n = 
+ let positive_big_int n =
+  let two = big_int_of_int 2 in
+  let rec _pos n =
    if eq_big_int n unit_big_int then XH
    else
     let (q,m) = quomod_big_int n two  in
-     if eq_big_int unit_big_int m 
+     if eq_big_int unit_big_int m
      then XI (_pos q)
      else XO (_pos q) in
    _pos n
 
- let bigint x = 
+ let bigint x =
   match sign_big_int x with
    | 0 -> Z0
    | 1 -> Zpos (positive_big_int x)
    | _ -> Zneg (positive_big_int (minus_big_int x))
 
- let q n = 
-  {Micromega.qnum = bigint (numerator n) ; 
+ let q n =
+  {Micromega.qnum = bigint (numerator n) ;
    Micromega.qden = positive_big_int (denominator n)}
 
-
- let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil
-
 end
 
 module Cmp =
 struct
 
- let rec compare_lexical l = 
+ let rec compare_lexical l =
   match l with
    | [] -> 0 (* Equal *)
-   | f::l -> 
+   | f::l ->
       let cmp = f () in
        if cmp = 0 	then  compare_lexical l else cmp
 
- let rec compare_list cmp l1 l2 = 
+ let rec compare_list cmp l1 l2 =
   match l1 , l2 with
    | []  , [] -> 0
    | []  , _  -> -1
    | _   , [] -> 1
-   | e1::l1 , e2::l2 -> 
+   | e1::l1 , e2::l2 ->
       let c = cmp e1 e2 in
        if c = 0 then compare_list cmp l1 l2 else c
-	
- let hash_list hash l = 
+
+ let hash_list hash l =
   let rec _hash_list l h =
    match l with
     | []  -> h lxor (Hashtbl.hash [])
@@ -303,3 +336,67 @@ struct
 
    _hash_list  l 0
 end
+
+module type Tag =
+sig
+  type t
+
+  val from : int -> t
+  val next : t -> t
+  val pp : out_channel -> t -> unit
+  val compare : t -> t -> int
+end
+
+module Tag : Tag =
+struct
+  type t = int
+  let from i = i
+  let next i = i + 1
+  let pp o i = output_string o (string_of_int i)
+  let compare : int -> int -> int = Pervasives.compare
+end
+
+module TagSet = Set.Make(Tag)
+
+
+let command exe_path args vl =
+  (* creating pipes for stdin, stdout, stderr *)
+  let (stdin_read,stdin_write) = Unix.pipe ()
+  and (stdout_read,stdout_write) = Unix.pipe ()
+  and (stderr_read,stderr_write) = Unix.pipe () in
+
+
+  (* Create the process *)
+  let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in
+
+  (* Write the data on the stdin of the created process *)
+  let outch = Unix.out_channel_of_descr stdin_write in
+    output_value outch vl ;
+    flush outch ;
+
+  (* Wait for its completion *)
+    let _pid,status = Unix.waitpid [] pid in
+
+      finally
+	(fun () ->
+	  (* Recover the result *)
+	  match status with
+	    | Unix.WEXITED 0 ->
+		let inch  = Unix.in_channel_of_descr  stdout_read in
+		  begin try Marshal.from_channel inch with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end
+	    | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
+	    | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
+	    | Unix.WSTOPPED  i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
+	(fun () ->
+	  (* Cleanup  *)
+	  List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write]
+	)
+
+
+
+
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
new file mode 100644
index 00000000..f17e1c35
--- /dev/null
+++ b/plugins/micromega/persistent_cache.ml
@@ -0,0 +1,180 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* A persistent hashtable                                               *)
+(*                                                                      *)
+(*  Frédéric Besson (Inria Rennes) 2009                                 *)
+(*                                                                      *)
+(************************************************************************)
+
+
+module type PHashtable =
+  sig
+    type 'a t
+    type key
+
+    val create : int -> string -> 'a t
+    (** [create i f] creates an empty persistent table
+	with initial size i
+	associated with file [f] *)
+
+
+    val open_in : string -> 'a t
+    (** [open_in f] rebuilds a table from the records stored in file [f].
+	As marshaling is not type-safe, it migth segault.
+    *)
+
+    val find : 'a t -> key -> 'a
+    (** find has the specification of Hashtable.find *)
+
+    val add  : 'a t -> key -> 'a -> unit
+    (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl].
+	(and writes the binding to the file associated with [tbl].)
+	If [key] is already bound, raises KeyAlreadyBound *)
+
+    val close : 'a t -> unit
+    (** [close tbl] is closing the table.
+	Once closed, a table cannot be used.
+	i.e, copy, find,add will raise UnboundTable *)
+
+    val memo : string -> (key -> 'a) -> (key -> 'a)
+      (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table.
+	  Note that the cache will only be loaded when the function is used for the first time *)
+
+  end
+
+open Hashtbl
+
+module PHashtable(Key:HashedType) : PHashtable with type key = Key.t  =
+struct
+
+  type key = Key.t
+
+  module Table = Hashtbl.Make(Key)
+
+
+
+  exception InvalidTableFormat
+  exception UnboundTable
+
+
+  type mode = Closed | Open
+
+
+  type 'a t =
+      {
+	outch : out_channel ;
+	mutable status : mode ;
+	htbl : 'a Table.t
+      }
+
+
+let create i f =
+  {
+    outch = open_out_bin f ;
+    status = Open ;
+    htbl = Table.create i
+  }
+
+let finally f rst =
+  try
+    let res = f () in
+      rst () ; res
+  with x ->
+    (try rst ()
+    with _  -> raise x
+    ); raise x
+
+
+let read_key_elem inch =
+  try
+    Some (Marshal.from_channel inch)
+  with
+    | End_of_file -> None
+    |    _        -> raise InvalidTableFormat
+
+let open_in f =
+  let flags = [Open_rdonly;Open_binary;Open_creat] in
+  let inch = open_in_gen flags 0o666 f in
+  let htbl = Table.create 10 in
+
+  let rec xload () =
+    match read_key_elem inch with
+      | None -> ()
+      | Some (key,elem) ->
+	  Table.add htbl key elem ;
+	  xload () in
+
+    try
+      finally (fun () -> xload () ) (fun () -> close_in inch) ;
+      {
+	outch = begin
+	  let flags = [Open_append;Open_binary;Open_creat] in
+	    open_out_gen flags 0o666 f
+	end ;
+	status = Open ;
+	htbl = htbl
+      }
+    with InvalidTableFormat ->
+      (* Try to keep as many entries as possible *)
+      begin
+	let flags = [Open_wronly; Open_trunc;Open_binary;Open_creat] in
+	let outch = open_out_gen flags 0o666 f in
+	  Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
+	  { outch = outch ;
+	    status = Open ;
+	    htbl   = htbl
+	  }
+      end
+
+
+let close t =
+  let {outch = outch ; status = status ; htbl = tbl} = t in
+    match t.status with
+    | Closed -> () (* don't do it twice *)
+    | Open  ->
+	close_out outch ;
+	Table.clear tbl ;
+	t.status <- Closed
+
+let add t k e =
+  let {outch = outch ; status = status ; htbl = tbl} = t in
+    if status = Closed
+    then raise UnboundTable
+    else
+      begin
+	Table.add tbl k e ;
+	Marshal.to_channel outch (k,e) [Marshal.No_sharing]
+      end
+
+let find t k =
+  let {outch = outch ; status = status ; htbl = tbl} = t in
+    if status = Closed
+    then raise UnboundTable
+    else
+      let res = Table.find tbl k in
+	res
+
+let memo cache f =
+  let tbl = lazy (open_in cache) in
+    fun x ->
+      let tbl = Lazy.force tbl in
+	try
+	  find tbl x
+	with
+	    Not_found ->
+	      let res = f x in
+		add tbl x res ;
+		res
+
+end
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/contrib/micromega/sos.ml b/plugins/micromega/sos.ml
index e3d72ed9..3029496b 100644
--- a/contrib/micromega/sos.ml
+++ b/plugins/micromega/sos.ml
@@ -1,18 +1,22 @@
 (* ========================================================================= *)
-(* - This code originates from John Harrison's HOL LIGHT 2.20                *)
+(* - This code originates from John Harrison's HOL LIGHT 2.30                *)
 (*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
 (* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
 (*   independent bits                                                        *)
 (* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
-(* - Addition of a csdp cache by the Coq development team                    *)
 (* ========================================================================= *)
 
 (* ========================================================================= *)
 (* Nonlinear universal reals procedure using SOS decomposition.              *)
 (* ========================================================================= *)
-
 open Num;;
 open List;;
+open Sos_types;;
+open Sos_lib;;
+
+(*
+prioritize_real();;
+*)
 
 let debugging = ref false;;
 
@@ -21,522 +25,6 @@ exception Sanity;;
 exception Unsolvable;;
 
 (* ------------------------------------------------------------------------- *)
-(* Comparisons that are reflexive on NaN and also short-circuiting.          *)
-(* ------------------------------------------------------------------------- *)
-
-let (=?) = fun x y -> Pervasives.compare x y = 0;;
-let (<?) = fun x y -> Pervasives.compare x y < 0;;
-let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
-let (>?) = fun x y -> Pervasives.compare x y > 0;;
-let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
-
-(* ------------------------------------------------------------------------- *)
-(* Combinators.                                                              *)
-(* ------------------------------------------------------------------------- *)
-
-let (o) = fun f g x -> f(g x);;
-
-(* ------------------------------------------------------------------------- *)
-(* Some useful functions on "num" type.                                      *)
-(* ------------------------------------------------------------------------- *)
-
-
-let num_0 = Int 0
-and num_1 = Int 1
-and num_2 = Int 2
-and num_10 = Int 10;;
-
-let pow2 n = power_num num_2 (Int n);;
-let pow10 n = power_num num_10 (Int n);;
-
-let numdom r =
-  let r' = Ratio.normalize_ratio (ratio_of_num r) in
-  num_of_big_int(Ratio.numerator_ratio r'),
-  num_of_big_int(Ratio.denominator_ratio r');;
-
-let numerator = (o) fst numdom
-and denominator = (o) snd numdom;;
-
-let gcd_num n1 n2 =
-  num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
-
-let lcm_num x y =
-  if x =/ num_0 & y =/ num_0 then num_0
-  else abs_num((x */ y) // gcd_num x y);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* List basics.                                                              *)
-(* ------------------------------------------------------------------------- *)
-
-let rec el n l =
-  if n = 0 then hd l else el (n - 1) (tl l);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Various versions of list iteration.                                       *)
-(* ------------------------------------------------------------------------- *)
-
-let rec itlist f l b =
-  match l with
-    [] -> b
-  | (h::t) -> f h (itlist f t b);;
-
-let rec end_itlist f l =
-  match l with
-        []     -> failwith "end_itlist"
-      | [x]    -> x
-      | (h::t) -> f h (end_itlist f t);;
-
-let rec itlist2 f l1 l2 b =
-  match (l1,l2) with
-    ([],[]) -> b
-  | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
-  | _ -> failwith "itlist2";;
-
-(* ------------------------------------------------------------------------- *)
-(* All pairs arising from applying a function over two lists.                *)
-(* ------------------------------------------------------------------------- *)
-
-let rec allpairs f l1 l2 =
-  match l1 with
-   h1::t1 ->  itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
-  | [] -> [];;
-
-(* ------------------------------------------------------------------------- *)
-(* String operations (surely there is a better way...)                       *)
-(* ------------------------------------------------------------------------- *)
-
-let implode l = itlist (^) l "";;
-
-let explode s =
-  let rec exap n l =
-      if n < 0 then l else
-      exap (n - 1) ((String.sub s n 1)::l) in
-  exap (String.length s - 1) [];;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Attempting function or predicate applications.                            *)
-(* ------------------------------------------------------------------------- *)
-
-let can f x = try (f x; true) with Failure _ -> false;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Repetition of a function.                                                 *)
-(* ------------------------------------------------------------------------- *)
-
-let rec funpow n f x =
-  if n < 1 then x else funpow (n-1) f (f x);;
-
-
-(* ------------------------------------------------------------------------- *)
-(*  term??                                                                   *)
-(* ------------------------------------------------------------------------- *)
-
-type vname = string;;
-
-type term =
-| Zero
-| Const of Num.num
-| Var of vname
-| Inv of term
-| Opp of term
-| Add of (term * term)
-| Sub of (term * term)
-| Mul of (term * term)
-| Div of (term * term)
-| Pow of (term * int);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Data structure for Positivstellensatz refutations.                        *)
-(* ------------------------------------------------------------------------- *)
-
-type positivstellensatz =
-   Axiom_eq of int
- | Axiom_le of int
- | Axiom_lt of int
- | Rational_eq of num
- | Rational_le of num
- | Rational_lt of num
- | Square of term
- | Monoid of int list
- | Eqmul of term * positivstellensatz
- | Sum of positivstellensatz * positivstellensatz
- | Product of positivstellensatz * positivstellensatz;;
-
-
-
-(* ------------------------------------------------------------------------- *)
-(* Replication and sequences.                                                *)
-(* ------------------------------------------------------------------------- *)
-
-let rec replicate x n =
-    if n < 1 then []
-    else x::(replicate x (n - 1));;
-
-let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
-
-(* ------------------------------------------------------------------------- *)
-(* Various useful list operations.                                           *)
-(* ------------------------------------------------------------------------- *)
-
-let rec forall p l =
-  match l with
-    [] -> true
-  | h::t -> p(h) & forall p t;;
-
-let rec tryfind f l =
-  match l with
-      [] -> failwith "tryfind"
-    | (h::t) -> try f h with Failure _ -> tryfind f t;;
-
-let index x =
-  let rec ind n l =
-    match l with
-      [] -> failwith "index"
-    | (h::t) -> if x =? h then n else ind (n + 1) t in
-  ind 0;;
-
-(* ------------------------------------------------------------------------- *)
-(* "Set" operations on lists.                                                *)
-(* ------------------------------------------------------------------------- *)
-
-let rec mem x lis =
-  match lis with
-    [] -> false
-  | (h::t) -> x =? h or mem x t;;
-
-let insert x l =
-  if mem x l then l else x::l;;
-
-let union l1 l2 = itlist insert l1 l2;;
-
-let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
-
-(* ------------------------------------------------------------------------- *)
-(* Merging and bottom-up mergesort.                                          *)
-(* ------------------------------------------------------------------------- *)
-
-let rec merge ord l1 l2 =
-  match l1 with
-    [] -> l2
-  | h1::t1 -> match l2 with
-                [] -> l1
-              | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
-                          else h2::(merge ord l1 t2);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Common measure predicates to use with "sort".                             *)
-(* ------------------------------------------------------------------------- *)
-
-let increasing f x y = f x <? f y;;
-
-let decreasing f x y = f x >? f y;;
-
-(* ------------------------------------------------------------------------- *)
-(* Zipping, unzipping etc.                                                   *)
-(* ------------------------------------------------------------------------- *)
-
-let rec zip l1 l2 =
-  match (l1,l2) with
-        ([],[]) -> []
-      | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
-      | _ -> failwith "zip";;
-
-let rec unzip =
-  function [] -> [],[]
-         | ((a,b)::rest) -> let alist,blist = unzip rest in
-                            (a::alist,b::blist);;
-
-(* ------------------------------------------------------------------------- *)
-(* Iterating functions over lists.                                           *)
-(* ------------------------------------------------------------------------- *)
-
-let rec do_list f l =
-  match l with
-    [] -> ()
-  | (h::t) -> (f h; do_list f t);;
-
-(* ------------------------------------------------------------------------- *)
-(* Sorting.                                                                  *)
-(* ------------------------------------------------------------------------- *)
-
-let rec sort cmp lis =
-  match lis with
-    [] -> []
-  | piv::rest ->
-      let r,l = partition (cmp piv) rest in
-      (sort cmp l) @ (piv::(sort cmp r));;
-
-(* ------------------------------------------------------------------------- *)
-(* Removing adjacent (NB!) equal elements from list.                         *)
-(* ------------------------------------------------------------------------- *)
-
-let rec uniq l =
-  match l with
-    x::(y::_ as t) -> let t' = uniq t in
-                      if x =? y then t' else
-                      if t'==t then l else x::t'
- | _ -> l;;
-
-(* ------------------------------------------------------------------------- *)
-(* Convert list into set by eliminating duplicates.                          *)
-(* ------------------------------------------------------------------------- *)
-
-let setify s = uniq (sort (<=?) s);;
-
-(* ------------------------------------------------------------------------- *)
-(* Polymorphic finite partial functions via Patricia trees.                  *)
-(*                                                                           *)
-(* The point of this strange representation is that it is canonical (equal   *)
-(* functions have the same encoding) yet reasonably efficient on average.    *)
-(*                                                                           *)
-(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10).        *)
-(* ------------------------------------------------------------------------- *)
-
-type ('a,'b)func =
-   Empty
- | Leaf of int * ('a*'b)list
- | Branch of int * int * ('a,'b)func * ('a,'b)func;;
-
-(* ------------------------------------------------------------------------- *)
-(* Undefined function.                                                       *)
-(* ------------------------------------------------------------------------- *)
-
-let undefined = Empty;;
-
-(* ------------------------------------------------------------------------- *)
-(* In case of equality comparison worries, better use this.                  *)
-(* ------------------------------------------------------------------------- *)
-
-let is_undefined f =
-  match f with
-    Empty -> true
-  | _ -> false;;
-
-(* ------------------------------------------------------------------------- *)
-(* Operation analagous to "map" for lists.                                   *)
-(* ------------------------------------------------------------------------- *)
-
-let mapf =
-  let rec map_list f l =
-    match l with
-      [] -> []
-    | (x,y)::t -> (x,f(y))::(map_list f t) in
-  let rec mapf f t =
-    match t with
-      Empty -> Empty
-    | Leaf(h,l) -> Leaf(h,map_list f l)
-    | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
-  mapf;;
-
-(* ------------------------------------------------------------------------- *)
-(* Operations analogous to "fold" for lists.                                 *)
-(* ------------------------------------------------------------------------- *)
-
-let foldl =
-  let rec foldl_list f a l =
-    match l with
-      [] -> a
-    | (x,y)::t -> foldl_list f (f a x y) t in
-  let rec foldl f a t =
-    match t with
-      Empty -> a
-    | Leaf(h,l) -> foldl_list f a l
-    | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
-  foldl;;
-
-let foldr =
-  let rec foldr_list f l a =
-    match l with
-      [] -> a
-    | (x,y)::t -> f x y (foldr_list f t a) in
-  let rec foldr f t a =
-    match t with
-      Empty -> a
-    | Leaf(h,l) -> foldr_list f l a
-    | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
-  foldr;;
-
-(* ------------------------------------------------------------------------- *)
-(* Redefinition and combination.                                             *)
-(* ------------------------------------------------------------------------- *)
-
-let (|->),combine =
-  let ldb x y = let z = x lxor y in z land (-z) in
-  let newbranch p1 t1 p2 t2 =
-    let b = ldb p1 p2 in
-    let p = p1 land (b - 1) in
-    if p1 land b = 0 then Branch(p,b,t1,t2)
-    else Branch(p,b,t2,t1) in
-  let rec define_list (x,y as xy) l =
-    match l with
-      (a,b as ab)::t ->
-          if x =? a then xy::t
-          else if x <? a then xy::l
-          else ab::(define_list xy t)
-    | [] -> [xy]
-  and combine_list op z l1 l2 =
-    match (l1,l2) with
-      [],_ -> l2
-    | _,[] -> l1
-    | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
-          if x1 <? x2 then xy1::(combine_list op z t1 l2)
-          else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
-          let y = op y1 y2 and l = combine_list op z t1 t2 in
-          if z(y) then l else (x1,y)::l in
-  let (|->) x y =
-    let k = Hashtbl.hash x in
-    let rec upd t =
-      match t with
-        Empty -> Leaf (k,[x,y])
-      | Leaf(h,l) ->
-           if h = k then Leaf(h,define_list (x,y) l)
-           else newbranch h t k (Leaf(k,[x,y]))
-      | Branch(p,b,l,r) ->
-          if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
-          else if k land b = 0 then Branch(p,b,upd l,r)
-          else Branch(p,b,l,upd r) in
-    upd in
-  let rec combine op z t1 t2 =
-    match (t1,t2) with
-      Empty,_ -> t2
-    | _,Empty -> t1
-    | Leaf(h1,l1),Leaf(h2,l2) ->
-          if h1 = h2 then
-            let l = combine_list op z l1 l2 in
-            if l = [] then Empty else Leaf(h1,l)
-          else newbranch h1 t1 h2 t2
-    | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) |
-      (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
-          if k land (b - 1) = p then
-            if k land b = 0 then
-              let l' = combine op z lf l in
-              if is_undefined l' then r else Branch(p,b,l',r)
-            else
-              let r' = combine op z lf r in
-              if is_undefined r' then l else Branch(p,b,l,r')
-          else
-            newbranch k lf p br
-    | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
-          if b1 < b2 then
-            if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
-            else if p2 land b1 = 0 then
-              let l = combine op z l1 t2 in
-              if is_undefined l then r1 else Branch(p1,b1,l,r1)
-            else
-              let r = combine op z r1 t2 in
-              if is_undefined r then l1 else Branch(p1,b1,l1,r)
-          else if b2 < b1 then
-            if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
-            else if p1 land b2 = 0 then
-              let l = combine op z t1 l2 in
-              if is_undefined l then r2 else Branch(p2,b2,l,r2)
-            else
-              let r = combine op z t1 r2 in
-              if is_undefined r then l2 else Branch(p2,b2,l2,r)
-          else if p1 = p2 then
-            let l = combine op z l1 l2 and r = combine op z r1 r2 in
-            if is_undefined l then r
-            else if is_undefined r then l else Branch(p1,b1,l,r)
-          else
-            newbranch p1 t1 p2 t2 in
-  (|->),combine;;
-
-(* ------------------------------------------------------------------------- *)
-(* Special case of point function.                                           *)
-(* ------------------------------------------------------------------------- *)
-
-let (|=>) = fun x y -> (x |-> y) undefined;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Grab an arbitrary element.                                                *)
-(* ------------------------------------------------------------------------- *)
-
-let rec choose t =
-  match t with
-    Empty -> failwith "choose: completely undefined function"
-  | Leaf(h,l) -> hd l
-  | Branch(b,p,t1,t2) -> choose t1;;
-
-(* ------------------------------------------------------------------------- *)
-(* Application.                                                              *)
-(* ------------------------------------------------------------------------- *)
-
-let applyd =
-  let rec apply_listd l d x =
-    match l with
-      (a,b)::t -> if x =? a then b
-                  else if x >? a then apply_listd t d x else d x
-    | [] -> d x in
-  fun f d x ->
-    let k = Hashtbl.hash x in
-    let rec look t =
-      match t with
-        Leaf(h,l) when h = k -> apply_listd l d x
-      | Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
-      | _ -> d x in
-    look f;;
-
-let apply f = applyd f (fun x -> failwith "apply");;
-
-let tryapplyd f a d = applyd f (fun x -> d) a;;
-
-let defined f x = try apply f x; true with Failure _ -> false;;
-
-(* ------------------------------------------------------------------------- *)
-(* Undefinition.                                                             *)
-(* ------------------------------------------------------------------------- *)
-
-let undefine =
-  let rec undefine_list x l =
-    match l with
-      (a,b as ab)::t ->
-          if x =? a then t
-          else if x <? a then l else
-          let t' = undefine_list x t in
-          if t' == t then l else ab::t'
-    | [] -> [] in
-  fun x ->
-    let k = Hashtbl.hash x in
-    let rec und t =
-      match t with
-        Leaf(h,l) when h = k ->
-          let l' = undefine_list x l in
-          if l' == l then t
-          else if l' = [] then Empty
-          else Leaf(h,l')
-      | Branch(p,b,l,r) when k land (b - 1) = p ->
-          if k land b = 0 then
-            let l' = und l in
-            if l' == l then t
-            else if is_undefined l' then r
-            else Branch(p,b,l',r)
-          else
-            let r' = und r in
-            if r' == r then t
-            else if is_undefined r' then l
-            else Branch(p,b,l,r')
-      | _ -> t in
-    und;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Mapping to sorted-list representation of the graph, domain and range.     *)
-(* ------------------------------------------------------------------------- *)
-
-let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
-
-let dom f = setify(foldl (fun a x y -> x::a) [] f);;
-
-let ran f = setify(foldl (fun a x y -> y::a) [] f);;
-
-(* ------------------------------------------------------------------------- *)
 (* Turn a rational into a decimal string with d sig digits.                  *)
 (* ------------------------------------------------------------------------- *)
 
@@ -555,7 +43,6 @@ let decimalize =
     implode(tl(explode(string_of_num k))) ^
     (if e = 0 then "" else "e"^string_of_int e);;
 
-
 (* ------------------------------------------------------------------------- *)
 (* Iterations over numbers, and lists indexed by numbers.                    *)
 (* ------------------------------------------------------------------------- *)
@@ -618,7 +105,7 @@ let vector_1 = vector_const (Int 1);;
 let vector_cmul c (v:vector) =
   let n = dim v in
   if c =/ Int 0 then vector_0 n
-  else n,mapf (fun x -> c */ x) (snd v);;
+  else n,mapf (fun x -> c */ x) (snd v)
 
 let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);;
 
@@ -629,6 +116,12 @@ let vector_add (v1:vector) (v2:vector) =
 
 let vector_sub v1 v2 = vector_add v1 (vector_neg v2);;
 
+let vector_dot (v1:vector) (v2:vector) =
+  let m = dim v1 and n = dim v2 in
+  if m <> n then failwith "vector_add: incompatible dimensions" else
+  foldl (fun a i x -> x +/ a) (Int 0)
+        (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));;
+
 let vector_of_list l =
   let n = length l in
   (n,itlist2 (|->) (1--n) l undefined :vector);;
@@ -790,13 +283,13 @@ let poly_variables (p:poly) =
 (* Order monomials for human presentation.                                   *)
 (* ------------------------------------------------------------------------- *)
 
-let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or (x1 = x2 & k1 > k2);;
+let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;;
 
 let humanorder_monomial =
   let rec ord l1 l2 = match (l1,l2) with
     _,[] -> true
   | [],_ -> false
-  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or (h1 = h2 & ord t1 t2) in
+  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 & ord t1 t2 in
   fun m1 m2 -> m1 = m2 or
                ord (sort humanorder_varpow (graph m1))
                    (sort humanorder_varpow (graph m2));;
@@ -825,16 +318,16 @@ let string_of_vname (v:vname): string = (v: string);;
 let rec string_of_term t =
   match t with
   Opp t1 -> "(- " ^ string_of_term t1 ^ ")"
-| Add (t1, t2) -> 
+| Add (t1, t2) ->
    "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")"
-| Sub (t1, t2) -> 
+| Sub (t1, t2) ->
    "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")"
-| Mul (t1, t2) -> 
+| Mul (t1, t2) ->
    "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")"
 | Inv t1 -> "(/ " ^ string_of_term t1 ^ ")"
-| Div (t1, t2) -> 
+| Div (t1, t2) ->
    "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")"
-| Pow (t1, n1) -> 
+| Pow (t1, n1) ->
    "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")"
 | Zero -> "0"
 | Var v -> "x" ^ (string_of_vname v)
@@ -887,15 +380,15 @@ let print_poly m = Format.print_string(string_of_poly m);;
 *)
 
 (* ------------------------------------------------------------------------- *)
-(* Conversion from term.                                                     *)
+(* Conversion from  term.                                                 *)
 (* ------------------------------------------------------------------------- *)
 
 let rec poly_of_term t = match t with
-  Zero -> poly_0 
+  Zero -> poly_0
 | Const n -> poly_const n
 | Var x -> poly_var x
 | Opp t1 -> poly_neg (poly_of_term t1)
-| Inv t1 -> 
+| Inv t1 ->
       let p = poly_of_term t1 in
       if poly_isconst p then poly_const(Int 1 // eval undefined p)
       else failwith "poly_of_term: inverse of non-constant polyomial"
@@ -915,7 +408,7 @@ let rec poly_of_term t = match t with
 
 let sdpa_of_vector (v:vector) =
   let n = dim v in
-  let strs = map (o (decimalize 20) (element v)) (1--n) in
+  let strs = map (o (decimalize 20)  (element v)) (1--n) in
   end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
 
 (* ------------------------------------------------------------------------- *)
@@ -966,103 +459,28 @@ let sdpa_of_problem comment obj mats =
 (* More parser basics.                                                       *)
 (* ------------------------------------------------------------------------- *)
 
-exception Noparse;;
-
-
-let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
-  let charcode s = Char.code(String.get s 0) in
-  let spaces = " \t\n\r"
-  and separators = ",;"
-  and brackets = "()[]{}"
-  and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
-  and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
-  and nums = "0123456789" in
-  let allchars = spaces^separators^brackets^symbs^alphas^nums in
-  let csetsize = itlist ((o) max charcode) (explode allchars) 256 in
-  let ctable = Array.make csetsize 0 in
-  do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
-  do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
-  do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
-  do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
-  do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
-  do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
-  let isspace c = Array.get ctable (charcode c) = 1
-  and issep c  = Array.get ctable (charcode c) = 2
-  and isbra c  = Array.get ctable (charcode c) = 4
-  and issymb c = Array.get ctable (charcode c) = 8
-  and isalpha c = Array.get ctable (charcode c) = 16
-  and isnum c = Array.get ctable (charcode c) = 32
-  and isalnum c = Array.get ctable (charcode c) >= 16 in
-  isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;
-
-let (||) parser1 parser2 input =
-  try parser1 input
-  with Noparse -> parser2 input;;
-
-let (++) parser1 parser2 input =
-  let result1,rest1 = parser1 input in
-  let result2,rest2 = parser2 rest1 in
-  (result1,result2),rest2;;
-
-let rec many prs input =
-  try let result,next = prs input in
-      let results,rest = many prs next in
-      (result::results),rest
-  with Noparse -> [],input;;
-
-let (>>) prs treatment input =
-  let result,rest = prs input in
-  treatment(result),rest;;
-
-let fix err prs input =
-  try prs input
-  with Noparse -> failwith (err ^ " expected");;
-
-let rec listof prs sep err =
-  prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
-
-let possibly prs input =
-  try let x,rest = prs input in [x],rest
-  with Noparse -> [],input;;
-
-let some p =
-  function
-      [] -> raise Noparse
-    | (h::t) -> if p h then (h,t) else raise Noparse;;
-
-let a tok = some (fun item -> item = tok);;
-
-let rec atleast n prs i =
-  (if n <= 0 then many prs
-   else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
-
-let finished input =
-  if input = [] then 0,input else failwith "Unparsed input";;
-
 let word s =
    end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
               (map a (explode s));;
-
 let token s =
   many (some isspace) ++ word s ++ many (some isspace)
   >> (fun ((_,t),_) -> t);;
 
 let decimal =
   let numeral = some isnum in
-  let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in
+  let decimalint = atleast 1 numeral >> ((o) Num.num_of_string  implode) in
   let decimalfrac = atleast 1 numeral
     >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
   let decimalsig =
     decimalint ++ possibly (a "." ++ decimalfrac >> snd)
-    >> (function (h,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") in
+    >> (function (h,[x]) -> h +/ x | (h,_) -> h) in
   let signed prs =
        a "-" ++ prs >> ((o) minus_num snd)
     || a "+" ++ prs >> snd
     || prs in
   let exponent = (a "e" || a "E") ++ signed decimalint >> snd in
     signed decimalsig ++ possibly exponent
-    >> (function (h,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ -> 
-     failwith "exponent");;
+    >> (function (h,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);;
 
 let mkparser p s =
   let x,rst = p(explode s) in
@@ -1074,15 +492,71 @@ let parse_decimal = mkparser decimal;;
 (* Parse back a vector.                                                      *)
 (* ------------------------------------------------------------------------- *)
 
-let parse_csdpoutput =
+let parse_sdpaoutput,parse_csdpoutput =
+  let vector =
+    token "{" ++ listof decimal (token ",") "decimal" ++ token "}"
+               >> (fun ((_,v),_) -> vector_of_list v) in
   let rec skipupto dscr prs inp =
       (dscr ++ prs >> snd
     || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
   let ignore inp = (),[] in
+  let sdpaoutput =
+    skipupto (word "xVec" ++ token "=")
+             (vector ++ ignore >> fst) in
   let csdpoutput =
     (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
     (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
-  mkparser csdpoutput;;
+  mkparser sdpaoutput,mkparser csdpoutput;;
+
+(* ------------------------------------------------------------------------- *)
+(* Also parse the SDPA output to test success (CSDP yields a return code).   *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_run_succeeded =
+   let rec skipupto dscr prs inp =
+      (dscr ++ prs >> snd
+    || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+  let prs = skipupto (word "phase.value" ++ token "=")
+                     (possibly (a "p") ++ possibly (a "d") ++
+                      (word "OPT" || word "FEAS")) in
+  fun s -> try ignore (prs (explode s)); true with Noparse -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* The default parameters. Unfortunately this goes to a fixed file.          *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_default_parameters =
+"100     unsigned int maxIteration;
+1.0E-7  double 0.0 < epsilonStar;
+1.0E2   double 0.0 < lambdaStar;
+2.0     double 1.0 < omegaStar;
+-1.0E5  double lowerBound;
+1.0E5   double upperBound;
+0.1     double 0.0 <= betaStar <  1.0;
+0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;
+0.9     double 0.0 < gammaStar  <  1.0;
+1.0E-7  double 0.0 < epsilonDash;
+";;
+
+(* ------------------------------------------------------------------------- *)
+(* These were suggested by Makoto Yamashita for problems where we are        *)
+(* right at the edge of the semidefinite cone, as sometimes happens.         *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_alt_parameters =
+"1000    unsigned int maxIteration;
+1.0E-7  double 0.0 < epsilonStar;
+1.0E4   double 0.0 < lambdaStar;
+2.0     double 1.0 < omegaStar;
+-1.0E5  double lowerBound;
+1.0E5   double upperBound;
+0.1     double 0.0 <= betaStar <  1.0;
+0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;
+0.9     double 0.0 < gammaStar  <  1.0;
+1.0E-7  double 0.0 < epsilonDash;
+";;
+
+let sdpa_params = sdpa_alt_parameters;;
 
 (* ------------------------------------------------------------------------- *)
 (* CSDP parameters; so far I'm sticking with the defaults.                   *)
@@ -1108,103 +582,34 @@ printlevel=1
 let csdp_params = csdp_default_parameters;;
 
 (* ------------------------------------------------------------------------- *)
-(* The same thing with CSDP.                                                 *)
-(* Modified by the Coq development team to use a cache                       *)
-(* ------------------------------------------------------------------------- *)
-
-let buffer_add_line buff line =
-  Buffer.add_string buff line; Buffer.add_char buff '\n'
-
-let string_of_file filename =
-  let fd = open_in filename in
-  let buff = Buffer.create 16 in
-  try while true do buffer_add_line buff (input_line fd) done; failwith ""
-  with End_of_file -> (close_in fd; Buffer.contents buff)
-
-let file_of_string filename s =
-  let fd = Pervasives.open_out filename in
-  output_string fd s; close_out fd
-
-let request_mark = "*** REQUEST ***"
-let answer_mark  = "*** ANSWER ***"
-let end_mark     = "*** END ***"
-let infeasible_mark = "Infeasible\n"
-let failure_mark    = "Failure\n"
-
-let cache_name = "csdp.cache"
-
-let look_in_cache string_problem =
-  let n = String.length string_problem in
-  try
-    let inch = open_in cache_name in
-    let rec search () =
-      while input_line inch <> request_mark do () done;
-      let i = ref 0 in
-      while !i < n & string_problem.[!i] = input_char inch do incr i done;
-      if !i < n or input_line inch <> answer_mark then
-	search ()
-      else begin
-	let buff = Buffer.create 16 in
-	let line = ref (input_line inch) in
-	while (!line <> end_mark) do
-	  buffer_add_line buff !line; line := input_line inch
-	done;
-	close_in inch;
-	Buffer.contents buff
-      end in
-    try search () with End_of_file -> close_in inch; raise Not_found
-  with Sys_error _ -> raise Not_found
-
-let flush_to_cache string_problem string_result =
-  try
-    let flags = [Open_append;Open_text;Open_creat] in
-    let outch = open_out_gen flags 0o666 cache_name in
-    begin 
-    try
-      Printf.fprintf outch "%s\n" request_mark;
-      Printf.fprintf outch "%s" string_problem;
-      Printf.fprintf outch "%s\n" answer_mark;
-      Printf.fprintf outch "%s" string_result;
-      Printf.fprintf outch "%s\n" end_mark;
-    with Sys_error _ as e -> close_out outch; raise e
-    end;
-    close_out outch
-  with Sys_error _ -> 
-    print_endline "Warning: Could not open or write to csdp cache"
-
-exception CsdpInfeasible
-
-let run_csdp dbg string_problem =
-  try
-   let res = look_in_cache string_problem in
-   if res = infeasible_mark then raise CsdpInfeasible;
-   if res = failure_mark then failwith "csdp error";
-   res
-  with Not_found ->
+(* Now call CSDP on a problem and parse back the output.                     *)
+(* ------------------------------------------------------------------------- *)
+
+let run_csdp dbg obj mats =
   let input_file = Filename.temp_file "sos" ".dat-s" in
-  let output_file = Filename.temp_file "sos" ".dat-s" in
-  let temp_path = Filename.dirname input_file in
-  let params_file = Filename.concat temp_path "param.csdp" in
-  file_of_string input_file string_problem;
+  let output_file =
+    String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+  and params_file = Filename.concat (!temp_path) "param.csdp" in
+  file_of_string input_file (sdpa_of_problem "" obj mats);
   file_of_string params_file csdp_params;
-  let rv = Sys.command("cd "^temp_path^"; csdp "^input_file^" "^output_file^
+  let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^
+                        " " ^ output_file ^
                        (if dbg then "" else "> /dev/null")) in
-  if rv = 1 or rv = 2 then 
-    (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible);
-  if rv = 127 then
-     (print_string "csdp not found, exiting..."; exit 1);
-  if rv <> 0 & rv <> 3 (* reduced accuracy *) then
-    (flush_to_cache string_problem failure_mark;
-     failwith("csdp: error "^string_of_int rv));
-  let string_result = string_of_file output_file in
-  flush_to_cache string_problem string_result;
-  if not dbg then
-    (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file);
-  string_result
+  let op = string_of_file output_file in
+  let res = parse_csdpoutput op in
+  ((if dbg then ()
+    else (Sys.remove input_file; Sys.remove output_file));
+    rv,res);;
 
 let csdp obj mats =
-  try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats))
-  with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+  let rv,res = run_csdp (!debugging) obj mats in
+  (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+   else if rv = 3 then ()
+    (* Format.print_string "csdp warning: Reduced accuracy";
+     Format.print_newline() *)
+   else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+   else ());
+  res;;
 
 (* ------------------------------------------------------------------------- *)
 (* Try some apparently sensible scaling first. Note that this is purely to   *)
@@ -1248,8 +653,24 @@ let linear_program_basic a =
   let m,n = dimensions a in
   let mats =  map (fun j -> diagonal (column j a)) (1--n)
   and obj = vector_const (Int 1) m in
-  try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true
-  with CsdpInfeasible -> false
+  let rv,res = run_csdp false obj mats in
+  if rv = 1 or rv = 2 then false
+  else if rv = 0 then true
+  else failwith "linear_program: An error occurred in the SDP solver";;
+
+(* ------------------------------------------------------------------------- *)
+(* Alternative interface testing A x >= b for matrix A, vector b.            *)
+(* ------------------------------------------------------------------------- *)
+
+let linear_program a b =
+  let m,n = dimensions a in
+  if dim b <> m then failwith "linear_program: incompatible dimensions" else
+  let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n)
+  and obj = vector_const (Int 1) m in
+  let rv,res = run_csdp false obj mats in
+  if rv = 1 or rv = 2 then false
+  else if rv = 0 then true
+  else failwith "linear_program: An error occurred in the SDP solver";;
 
 (* ------------------------------------------------------------------------- *)
 (* Test whether a point is in the convex hull of others. Rather than use     *)
@@ -1274,9 +695,9 @@ let in_convex_hull pts pt =
 (* ------------------------------------------------------------------------- *)
 
 let minimal_convex_hull =
-  let augment1 = function (m::ms) -> if in_convex_hull ms m then ms else ms@[m] 
-          | _ -> failwith "augment1"
-  in
+  let augment1 = function
+    | [] -> assert false
+    | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in
   let augment m ms = funpow 3 augment1 (m::ms) in
   fun mons ->
     let mons' = itlist augment (tl mons) [hd mons] in
@@ -1301,6 +722,7 @@ let equation_eval assig eq =
 (* "one" that's used for a constant term.                                    *)
 (* ------------------------------------------------------------------------- *)
 
+let failstore = ref [];;
 
 let eliminate_equations =
   let rec extract_first p l =
@@ -1312,7 +734,7 @@ let eliminate_equations =
   let rec eliminate vars dun eqs =
     match vars with
       [] -> if forall is_undefined eqs then dun
-            else (raise Unsolvable)
+            else (failstore := [vars,dun,eqs]; raise Unsolvable)
     | v::vs ->
             try let eq,oeqs = extract_first (fun e -> defined e v) eqs in
                 let a = apply eq v in
@@ -1430,8 +852,8 @@ let deration d =
             foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
     (c // (a */ a)),mapa (fun x -> a */ x) l in
   let d' = map adj d in
-  let a = itlist ((o) lcm_num ((o) denominator fst)) d' (Int 1) //
-          itlist ((o) gcd_num ((o) numerator fst)) d' (Int 0)  in
+  let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) //
+          itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0)  in
   (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
 
 (* ------------------------------------------------------------------------- *)
@@ -1483,9 +905,9 @@ let epoly_pmul p q acc =
 let epoly_cmul c l =
   if c =/ Int 0 then undefined else mapf (equation_cmul c) l;;
 
-let epoly_neg x = epoly_cmul (Int(-1)) x;;
+let epoly_neg = epoly_cmul (Int(-1));;
 
-let epoly_add x = combine equation_add is_undefined x;;
+let epoly_add = combine equation_add is_undefined;;
 
 let epoly_sub p q = epoly_add p (epoly_neg q);;
 
@@ -1528,10 +950,32 @@ let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
 (* Hence run CSDP on a problem in block diagonal form.                       *)
 (* ------------------------------------------------------------------------- *)
 
-let csdp_blocks nblocks blocksizes obj mats =
-  let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in
-  try parse_csdpoutput (run_csdp !debugging string_problem)
-  with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+let run_csdp dbg nblocks blocksizes obj mats =
+  let input_file = Filename.temp_file "sos" ".dat-s" in
+  let output_file =
+    String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+  and params_file = Filename.concat (!temp_path) "param.csdp" in
+  file_of_string input_file
+   (sdpa_of_blockproblem "" nblocks blocksizes obj mats);
+  file_of_string params_file csdp_params;
+  let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^
+                        " " ^ output_file ^
+                       (if dbg then "" else "> /dev/null")) in
+  let op = string_of_file output_file in
+  let res = parse_csdpoutput op in
+  ((if dbg then ()
+    else (Sys.remove input_file; Sys.remove output_file));
+    rv,res);;
+
+let csdp nblocks blocksizes obj mats =
+  let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in
+  (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+   else if rv = 3 then ()
+    (*Format.print_string "csdp warning: Reduced accuracy";
+     Format.print_newline() *)
+   else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+   else ());
+  res;;
 
 (* ------------------------------------------------------------------------- *)
 (* 3D versions of matrix operations to consider blocks separately.           *)
@@ -1556,7 +1000,6 @@ let blocks blocksizes bm =
         let m = foldl
           (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
           undefined bm in
-        (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m in*)
         (((bs,bs),m):matrix))
       (zip blocksizes (1--length blocksizes));;
 
@@ -1564,9 +1007,7 @@ let blocks blocksizes bm =
 (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
 (* ------------------------------------------------------------------------- *)
 
-let real_positivnullstellensatz_general linf d eqs leqs pol 
-  :   poly list *  (positivstellensatz * (num * poly) list) list  =
-  
+let real_positivnullstellensatz_general linf d eqs leqs pol =
   let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
   let monoid =
     if linf then
@@ -1619,7 +1060,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol
             itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
                         undefined in
   let raw_vec = if pvs = [] then vector_0 0
-                else scale_then (csdp_blocks nblocks blocksizes) obj mats in
+                else scale_then (csdp nblocks blocksizes) obj mats in
   let find_rounding d =
    (if !debugging then
      (Format.print_string("Trying rounding with limit "^string_of_num d);
@@ -1659,24 +1100,20 @@ let real_positivnullstellensatz_general linf d eqs leqs pol
            (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
                     (poly_neg pol)) in
   if not(is_undefined sanity) then raise Sanity else
-     cfs,map (fun (a,b) -> snd a,b) msq;;
-
+  cfs,map (fun (a,b) -> snd a,b) msq;;
 
-let term_of_monoid l1 m = itlist  (fun i m -> Mul (nth l1 i,m)) m (Const num_1)
+(* ------------------------------------------------------------------------- *)
+(* Iterative deepening.                                                      *)
+(* ------------------------------------------------------------------------- *)
 
-let rec term_of_pos l1 x = match x with
-   Axiom_eq i -> failwith "term_of_pos"
- | Axiom_le i -> nth l1 i
- | Axiom_lt i -> nth l1 i
- | Monoid m   -> term_of_monoid l1 m
- | Rational_eq n -> Const n
- | Rational_le n -> Const n
- | Rational_lt n -> Const n
- | Square t -> Pow (t, 2)
- | Eqmul (t, y) -> Mul (t, term_of_pos l1 y)
- | Sum (y, z) -> Add  (term_of_pos l1 y, term_of_pos l1 z)
- | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);;
+let rec deepen f n =
+  try print_string "Searching with depth limit ";
+      print_int n; print_newline(); f n
+  with Failure _ -> deepen f (n + 1);;
 
+(* ------------------------------------------------------------------------- *)
+(* The ordering so we can create canonical HOL polynomials.                  *)
+(* ------------------------------------------------------------------------- *)
 
 let dest_monomial mon = sort (increasing fst) (graph mon);;
 
@@ -1705,7 +1142,7 @@ let dest_poly p =
       (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
 
 (* ------------------------------------------------------------------------- *)
-(* Map back polynomials and their composites to term.                        *)
+(* Map back polynomials and their composites to HOL.                         *)
 (* ------------------------------------------------------------------------- *)
 
 let term_of_varpow =
@@ -1738,74 +1175,196 @@ let term_of_sos (pr,sqs) =
   if sqs = [] then pr
   else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
 
-let rec deepen f n =
-  try (*print_string "Searching with depth limit ";
-      print_int n; print_newline();*) f n
-  with Failure _ -> deepen f (n + 1);;
-
-
-
-
-
-exception TooDeep
-
-let deepen_until limit f n = 
-  match compare limit 0 with
-    | 0 -> raise TooDeep
-    | -1 -> deepen f n
-    | _  -> 
-	let rec d_until  f n =
-	  try if !debugging 
-	  then (print_string "Searching with depth limit "; 
-		print_int n; print_newline()) ; f n
-	  with Failure x -> 
-	    if !debugging then (Printf.printf "solver error : %s\n" x) ; 
-	    if n = limit then raise TooDeep else  d_until f (n + 1) in
-	  d_until f n
-
-
-(* patch to remove  zero polynomials from equalities.
-   In this case, hol light loops *)
-
-let real_nonlinear_prover  depthmax eqs les lts =
-  let eq = map poly_of_term eqs
-  and le = map poly_of_term les
-  and lt = map poly_of_term lts in
-  let pol = itlist poly_mul lt (poly_const num_1)
-  and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1)))
-  and ltp =  map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1))) 
-  and eqp =  itlist2 (fun t i res -> 
-   if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) []
-  in
-    
-  let proof =
-      let leq = lep @ ltp in
-      let eq = List.map fst eqp in
-      let tryall d =
-	let e = multidegree pol (*and pol' = poly_neg pol*) in
-	let k = if e = 0 then 1 else d / e in
-	  tryfind (fun i -> d,i, 
-	   real_positivnullstellensatz_general false d  eq leq
-            (poly_neg(poly_pow pol i)))
-           (0--k) in
-      let d,i,(cert_ideal,cert_cone) = deepen_until depthmax tryall 0 in
-      let proofs_ideal =
-       map2 (fun q i -> Eqmul(term_of_poly q,i))
-        cert_ideal (List.map snd eqp)
-      and proofs_cone = map term_of_sos cert_cone
-      and proof_ne =
-       if lt = [] then Rational_lt num_1 else
-	let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in
-	 funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in
-       end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
-   if !debugging then (print_string("Translating proof certificate to Coq"); print_newline());
-   proof;;
-
-
+(* ------------------------------------------------------------------------- *)
+(* Interface to HOL.                                                         *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_NONLINEAR_PROVER translator (eqs,les,lts) =
+  let eq0 = map (poly_of_term o lhand o concl) eqs
+  and le0 = map (poly_of_term o lhand o concl) les
+  and lt0 = map (poly_of_term o lhand o concl) lts in
+  let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1)))
+  and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1)))
+  and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in
+  let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0
+  and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0
+  and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in
+  let trivial_axiom (p,ax) =
+    match ax with
+      Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs
+    | Axiom_le n when eval undefined p </ num_0 -> el n les
+    | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts
+    | _ -> failwith "not a trivial axiom" in
+  try let th = tryfind trivial_axiom (keq @ klep @ kltp) in
+      CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th
+  with Failure _ ->
+  let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in
+  let leq = lep @ ltp in
+  let tryall d =
+    let e = multidegree pol in
+    let k = if e = 0 then 0 else d / e in
+    let eq' = map fst eq in
+    tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq
+                          (poly_neg(poly_pow pol i)))
+            (0--k) in
+  let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in
+  let proofs_ideal =
+    map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq
+  and proofs_cone = map term_of_sos cert_cone
+  and proof_ne =
+    if ltp = [] then Rational_lt num_1 else
+    let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in
+    funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in
+  let proof = end_itlist (fun s t -> Sum(s,t))
+                         (proof_ne :: proofs_ideal @ proofs_cone) in
+  print_string("Translating proof certificate to HOL");
+  print_newline();
+  translator (eqs,les,lts) proof;;
+*)
+(* ------------------------------------------------------------------------- *)
+(* A wrapper that tries to substitute away variables first.                  *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_NONLINEAR_SUBST_PROVER =
+  let zero = `&0:real`
+  and mul_tm = `( * ):real->real->real`
+  and shuffle1 =
+    CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`))
+  and shuffle2 =
+    CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in
+  let rec substitutable_monomial fvs tm =
+    match tm with
+      Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm
+    | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t))
+         when is_ratconst c & not (mem t fvs)
+          -> rat_of_term c,t
+    | Comb(Comb(Const("real_add",_),s),t) ->
+         (try substitutable_monomial (union (frees t) fvs) s
+          with Failure _ -> substitutable_monomial (union (frees s) fvs) t)
+    | _ -> failwith "substitutable_monomial"
+  and isolate_variable v th =
+    match lhs(concl th) with
+      x when x = v -> th
+    | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t)
+        when x = v -> shuffle2 th
+    | Comb(Comb(Const("real_add",_),s),t) ->
+        isolate_variable v(shuffle1 th) in
+  let make_substitution th =
+    let (c,v) = substitutable_monomial [] (lhs(concl th)) in
+    let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in
+    let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in
+    CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in
+  fun translator ->
+    let rec substfirst(eqs,les,lts) =
+      try let eth = tryfind make_substitution eqs in
+          let modify =
+            CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in
+          substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs),
+                     map modify les,map modify lts)
+      with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in
+    substfirst;;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Overall function.                                                         *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_SOS =
+  let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL]
+  and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in
+  fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Add hacks for division.                                                   *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_SOSFIELD =
+  let inv_tm = `inv:real->real` in
+  let prenex_conv =
+    TOP_DEPTH_CONV BETA_CONV THENC
+    PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div;
+                      REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC
+    NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC
+    PRENEX_CONV
+  and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV
+  and core_rule t =
+    try REAL_ARITH t
+    with Failure _ -> try REAL_RING t
+    with Failure _ -> REAL_SOS t
+  and is_inv =
+    let is_div = is_binop `(/):real->real->real` in
+    fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) &
+              not(is_ratconst(rand tm)) in
+  let BASIC_REAL_FIELD tm =
+    let is_freeinv t = is_inv t & free_in t tm in
+    let itms = setify(map rand (find_terms is_freeinv tm)) in
+    let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in
+    let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in
+    let itms' = map (curry mk_comb inv_tm) itms in
+    let gvs = map (genvar o type_of) itms' in
+    let tm'' = subst (zip gvs itms') tm' in
+    let th1 = setup_conv tm'' in
+    let cjs = conjuncts(rand(concl th1)) in
+    let ths = map core_rule cjs in
+    let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in
+    rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in
+  fun tm ->
+    let th0 = prenex_conv tm in
+    let tm0 = rand(concl th0) in
+    let avs,bod = strip_forall tm0 in
+    let th1 = setup_conv bod in
+    let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in
+    EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Integer version.                                                          *)
+(* ------------------------------------------------------------------------- *)
+(*
+let INT_SOS =
+  let atom_CONV =
+    let pth = prove
+      (`(~(x <= y) <=> y + &1 <= x:int) /\
+        (~(x < y) <=> y <= x) /\
+        (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\
+        (x < y <=> x + &1 <= y)`,
+       REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in
+    GEN_REWRITE_CONV I [pth]
+  and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV
+   [int_eq; int_le; int_lt; int_ge; int_gt;
+    int_of_num_th; int_neg_th; int_add_th; int_mul_th;
+    int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in
+  let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in
+  let NNF_NORM_CONV = GEN_NNF_CONV false
+   (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in
+  let init_CONV =
+    GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC
+    GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC
+    CONDS_ELIM_CONV THENC NNF_NORM_CONV in
+  let p_tm = `p:bool`
+  and not_tm = `(~)` in
+  let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in
+  fun tm ->
+    let th0 = INST [tm,p_tm] pth
+    and th1 = NNF_NORM_CONV(mk_neg tm) in
+    let th2 = REAL_SOS(mk_neg(rand(concl th1))) in
+    EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Natural number version.                                                   *)
+(* ------------------------------------------------------------------------- *)
+(*
+let SOS_RULE tm =
+  let avs = frees tm in
+  let tm' = list_mk_forall(avs,tm) in
+  let th1 = NUM_TO_INT_CONV tm' in
+  let th2 = INT_SOS (rand(concl th1)) in
+  SPECL avs (EQ_MP (SYM th1) th2);;
+*)
 (* ------------------------------------------------------------------------- *)
 (* Now pure SOS stuff.                                                       *)
 (* ------------------------------------------------------------------------- *)
 
+(*prioritize_real();;*)
+
 (* ------------------------------------------------------------------------- *)
 (* Some combinatorial helper functions.                                      *)
 (* ------------------------------------------------------------------------- *)
@@ -1826,6 +1385,70 @@ let changevariables zoln pol =
         poly_0 pol;;
 
 (* ------------------------------------------------------------------------- *)
+(* Return to original non-block matrices.                                    *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_vector (v:vector) =
+  let n = dim v in
+  let strs = map (o (decimalize 20) (element v)) (1--n) in
+  end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
+
+let sdpa_of_blockdiagonal k m =
+  let pfx = string_of_int k ^" " in
+  let ents =
+    foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+  let entss = sort (increasing fst) ents in
+  itlist (fun ((b,i,j),c) a ->
+     pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+let sdpa_of_matrix k (m:matrix) =
+  let pfx = string_of_int k ^ " 1 " in
+  let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
+                 (snd m) [] in
+  let mss = sort (increasing fst) ms in
+  itlist (fun ((i,j),c) a ->
+     pfx ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
+
+let sdpa_of_problem comment obj mats =
+  let m = length mats - 1
+  and n,_ = dimensions (hd mats) in
+  "\"" ^ comment ^ "\"\n" ^
+  string_of_int m ^ "\n" ^
+  "1\n" ^
+  string_of_int n ^ "\n" ^
+  sdpa_of_vector obj ^
+  itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
+          (1--length mats) mats "";;
+
+let run_csdp dbg obj mats =
+  let input_file = Filename.temp_file "sos" ".dat-s" in
+  let output_file =
+    String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+  and params_file = Filename.concat (!temp_path) "param.csdp" in
+  file_of_string input_file (sdpa_of_problem "" obj mats);
+  file_of_string params_file csdp_params;
+  let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^
+                       " " ^ output_file ^
+                       (if dbg then "" else "> /dev/null")) in
+  let op = string_of_file output_file in
+  let res = parse_csdpoutput op in
+  ((if dbg then ()
+    else (Sys.remove input_file; Sys.remove output_file));
+    rv,res);;
+
+let csdp obj mats =
+  let rv,res = run_csdp (!debugging) obj mats in
+  (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+    else if rv = 3 then ()
+(*    (Format.print_string "csdp warning: Reduced accuracy";
+     Format.print_newline()) *)
+   else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+   else ());
+  res;;
+
+(* ------------------------------------------------------------------------- *)
 (* Sum-of-squares function with some lowbrow symmetry reductions.            *)
 (* ------------------------------------------------------------------------- *)
 
@@ -1838,11 +1461,6 @@ let sumofsquares_general_symmetry tool pol =
      (fun vars' ->
         is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
      (allpermutations vars) in
-(*    let lpps2 = allpairs monomial_mul lpps lpps in*)
-(*    let lpp2_classes =
-       setify(map (fun m ->
-         setify(map (fun vars' -> changevariables_monomial (zip vars vars') m)
-                   invariants)) lpps2) in *)
     let lpns = zip lpps (1--length lpps) in
     let lppcs =
       filter (fun (m,(n1,n2)) -> n1 <= n2)
@@ -1915,5 +1533,327 @@ let sumofsquares_general_symmetry tool pol =
   let sos = poly_cmul rat (end_itlist poly_add sqs) in
   if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
 
-let (sumofsquares: poly -> Num.num * (( Num.num * poly) list))  = 
-sumofsquares_general_symmetry csdp;;
+let sumofsquares = sumofsquares_general_symmetry csdp;;
+
+(* ------------------------------------------------------------------------- *)
+(* Pure HOL SOS conversion.                                                  *)
+(* ------------------------------------------------------------------------- *)
+(*
+let SOS_CONV =
+  let mk_square =
+    let pow_tm = `(pow)` and two_tm = `2` in
+    fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm)
+  and mk_prod = mk_binop `( * )`
+  and mk_sum = mk_binop `(+)` in
+  fun tm ->
+    let k,sos = sumofsquares(poly_of_term tm) in
+    let mk_sqtm(c,p) =
+      mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in
+    let tm' = end_itlist mk_sum (map mk_sqtm sos) in
+    let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in
+    TRANS th (SYM th');;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Attempt to prove &0 <= x by direct SOS decomposition.                     *)
+(* ------------------------------------------------------------------------- *)
+(*
+let PURE_SOS_TAC =
+  let tac =
+    MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE
+    MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE
+    (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE
+    (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE
+    CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in
+  REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN
+  GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN
+  CONV_TAC(RAND_CONV SOS_CONV) THEN
+  REPEAT tac THEN NO_TAC;;
+
+let PURE_SOS tm = prove(tm,PURE_SOS_TAC);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Examples.                                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+(*****
+
+time REAL_SOS
+  `a1 >= &0 /\ a2 >= &0 /\
+   (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\
+   (a1 * b1 + a2 * b2 = &0)
+   ==> a1 * a2 - b1 * b2 >= &0`;;
+
+time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;;
+
+time REAL_SOS
+  `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;;
+
+time REAL_SOS
+  `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;;
+
+time REAL_SOS
+ `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1
+  ==> x pow 2 + y pow 2 < &1 \/
+      (x - &1) pow 2 + y pow 2 < &1 \/
+      x pow 2 + (y - &1) pow 2 < &1 \/
+      (x - &1) pow 2 + (y - &1) pow 2 < &1`;;
+
+time REAL_SOS
+ `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\
+  (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b)
+  ==> a * c <= y * x`;;
+
+time REAL_SOS
+ `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3
+  ==> x * y + x * z + y * z >= &3 * x * y * z`;;
+
+time REAL_SOS
+ `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;;
+
+time REAL_SOS
+ `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1)
+  ==> (w + x + y + z) pow 2 <= &4`;;
+
+time REAL_SOS
+ `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;;
+
+time REAL_SOS
+ `x > &1 /\ y > &1 ==> x * y > x + y - &1`;;
+
+time REAL_SOS
+ `abs(x) <= &1
+  ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;;
+
+time REAL_SOS
+ `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1)
+  ==> abs((u * x + v * y) - z) <= e`;;
+
+(* ------------------------------------------------------------------------- *)
+(* One component of denominator in dodecahedral example.                     *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+  `&2 <= x /\ x <= &125841 / &50000 /\
+   &2 <= y /\ y <= &125841 / &50000 /\
+   &2 <= z /\ z <= &125841 / &50000
+   ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Over a larger but simpler interval.                                       *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4
+  ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* We can do 12. I think 12 is a sharp bound; see PP's certificate.          *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4
+  ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Gloptipoly example.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+(*** This works but normalization takes minutes
+
+time REAL_SOS
+ `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3
+  ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;;
+
+ ***)
+
+(* ------------------------------------------------------------------------- *)
+(* Inequality from sci.math (see "Leon-Sotelo, por favor").                  *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+  `&0 <= x /\ &0 <= y /\ (x * y = &1)
+   ==> x + y <= x pow 2 + y pow 2`;;
+
+time REAL_SOS
+  `&0 <= x /\ &0 <= y /\ (x * y = &1)
+   ==> x * y * (x + y) <= x pow 2 + y pow 2`;;
+
+time REAL_SOS
+  `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Some examples over integers and natural numbers.                          *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;;
+time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;;
+time SOS_RULE  `!m n. m < n ==> (m DIV n = 0)`;;
+time SOS_RULE `!n:num. n <= n * n`;;
+time SOS_RULE  `!m n. n * (m DIV n) <= m`;;
+time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;;
+time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;;
+time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* This is particularly gratifying --- cf hideous manual proof in arith.ml   *)
+(* ------------------------------------------------------------------------- *)
+
+(*** This doesn't now seem to work as well as it did; what changed?
+
+time SOS_RULE
+ `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;;
+
+ ***)
+
+(* ------------------------------------------------------------------------- *)
+(* Key lemma for injectivity of Cantor-type pairing functions.               *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE
+ `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1)
+                ==> (x1 + y1 = x2 + y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\
+                (x1 + y1 = x2 + y2)
+                ==> (x1 = x2) /\ (y1 = y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2.
+      (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 =
+       ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2)
+       ==> (x1 + y1 = x2 + y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2.
+      (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 =
+       ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\
+      (x1 + y1 = x2 + y2)
+      ==> (x1 = x2) /\ (y1 = y2)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Reciprocal multiplication (actually just ARITH_RULE does these).          *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;;
+
+time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `0 < m /\ m < n  ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Some conversion examples.                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_CONV
+ `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;;
+
+time SOS_CONV
+ `x pow 4 - (&2 * y * z + &1) * x pow 2 +
+  (y pow 2 * z pow 2 + &2 * y * z + &2)`;;
+
+time SOS_CONV `&4 * x pow 4 +
+          &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 +
+          &10 * y pow 4`;;
+
+time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;;
+
+time SOS_CONV
+  `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;;
+
+time SOS_CONV
+ `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 +
+  &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;;
+
+time SOS_CONV
+ `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 +
+  &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 +
+  &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;;
+
+time SOS_CONV
+ `(x pow 2 + y pow 2 + z pow 2) *
+  (x pow 4 * y pow 2 + x pow 2 * y pow 4 +
+   z pow 6 - &3 * x pow 2 * y pow 2 *   z pow 2)`;;
+
+time SOS_CONV
+ `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;;
+
+(*** I think this will work, but normalization is slow
+
+time SOS_CONV
+ `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;;
+
+ ***)
+
+time SOS_CONV
+ `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;;
+
+time SOS_CONV
+ `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y +
+    &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Example of basic rule.                                                    *)
+(* ------------------------------------------------------------------------- *)
+
+time PURE_SOS
+  `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3
+       >= &1 / &7`;;
+
+time PURE_SOS
+ `&0 <= &98 * x pow 12 +
+        -- &980 * x pow 10 +
+        &3038 * x pow 8 +
+        -- &2968 * x pow 6 +
+        &1022 * x pow 4 +
+        -- &84 * x pow 2 +
+        &2`;;
+
+time PURE_SOS
+ `!x. &0 <= &2 * x pow 14 +
+            -- &84 * x pow 12 +
+            &1022 * x pow 10 +
+            -- &2968 * x pow 8 +
+            &3038 * x pow 6 +
+            -- &980 * x pow 4 +
+            &98 * x pow 2`;;
+
+(* ------------------------------------------------------------------------- *)
+(* From Zeng et al, JSC vol 37 (2004), p83-99.                               *)
+(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *)
+(* ------------------------------------------------------------------------- *)
+
+PURE_SOS
+  `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;;
+
+PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;;
+
+PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 +
+&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;;
+
+(**** This is harder. Interestingly, this fails the pure SOS test, it seems.
+      Yet only on rounding(!?) Poor Newton polytope optimization or something?
+      But REAL_SOS does finally converge on the second run at level 12!
+
+REAL_SOS
+`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x
+pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow
+2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;;
+
+ ****)
+
+PURE_SOS
+`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z
+pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y +
+&3*w pow 2 + &2*z pow 2 + &1 >= &0`;;
+
+PURE_SOS
+`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w +
+&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >=
+&0`;;
+
+*****)
diff --git a/contrib/micromega/sos.mli b/plugins/micromega/sos.mli
index 31c9518c..e38caba0 100644
--- a/contrib/micromega/sos.mli
+++ b/plugins/micromega/sos.mli
@@ -6,33 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-
-type vname = string;;
-
-type term =
-| Zero
-| Const of Num.num
-| Var of vname
-| Inv of term
-| Opp of term
-| Add of (term * term)
-| Sub of (term * term)
-| Mul of (term * term)
-| Div of (term * term)
-| Pow of (term * int)
-
-type positivstellensatz =
-   Axiom_eq of int
- | Axiom_le of int
- | Axiom_lt of int
- | Rational_eq of Num.num
- | Rational_le of Num.num
- | Rational_lt of Num.num
- | Square of term
- | Monoid of int list
- | Eqmul of term * positivstellensatz
- | Sum of positivstellensatz * positivstellensatz
- | Product of positivstellensatz * positivstellensatz
+open Sos_types
 
 type poly
 
@@ -50,15 +24,11 @@ val poly_of_term : term -> poly
 
 val term_of_poly : poly -> term
 
-val term_of_sos : positivstellensatz * (Num.num * poly) list -> 
+val term_of_sos : positivstellensatz * (Num.num * poly) list ->
      positivstellensatz
 
 val string_of_poly : poly -> string
 
-exception TooDeep
-
-val deepen_until : int -> (int -> 'a) -> int -> 'a
-
 val real_positivnullstellensatz_general : bool -> int -> poly list ->
      (poly * positivstellensatz) list ->
      poly -> poly list * (positivstellensatz * (Num.num * poly) list) list
diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml
new file mode 100644
index 00000000..baf90d4d
--- /dev/null
+++ b/plugins/micromega/sos_lib.ml
@@ -0,0 +1,621 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.30                *)
+(*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
+(*   This code is the HOL LIGHT library code used by sos.ml                  *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
+(*   independent bits                                                        *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
+(* ========================================================================= *)
+open Sos_types
+open Num
+open List
+
+let debugging = ref false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparisons that are reflexive on NaN and also short-circuiting.          *)
+(* ------------------------------------------------------------------------- *)
+
+let (=?) = fun x y -> Pervasives.compare x y = 0;;
+let (<?) = fun x y -> Pervasives.compare x y < 0;;
+let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
+let (>?) = fun x y -> Pervasives.compare x y > 0;;
+let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* Combinators.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let (o) = fun f g x -> f(g x);;
+
+(* ------------------------------------------------------------------------- *)
+(* Some useful functions on "num" type.                                      *)
+(* ------------------------------------------------------------------------- *)
+
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10;;
+
+let pow2 n = power_num num_2 (Int n);;
+let pow10 n = power_num num_10 (Int n);;
+
+let numdom r =
+  let r' = Ratio.normalize_ratio (ratio_of_num r) in
+  num_of_big_int(Ratio.numerator_ratio r'),
+  num_of_big_int(Ratio.denominator_ratio r');;
+
+let numerator = (o) fst numdom
+and denominator = (o) snd numdom;;
+
+let gcd_num n1 n2 =
+  num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
+
+let lcm_num x y =
+  if x =/ num_0 & y =/ num_0 then num_0
+  else abs_num((x */ y) // gcd_num x y);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* List basics.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let rec el n l =
+  if n = 0 then hd l else el (n - 1) (tl l);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Various versions of list iteration.                                       *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itlist f l b =
+  match l with
+    [] -> b
+  | (h::t) -> f h (itlist f t b);;
+
+let rec end_itlist f l =
+  match l with
+        []     -> failwith "end_itlist"
+      | [x]    -> x
+      | (h::t) -> f h (end_itlist f t);;
+
+let rec itlist2 f l1 l2 b =
+  match (l1,l2) with
+    ([],[]) -> b
+  | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
+  | _ -> failwith "itlist2";;
+
+(* ------------------------------------------------------------------------- *)
+(* All pairs arising from applying a function over two lists.                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpairs f l1 l2 =
+  match l1 with
+   h1::t1 ->  itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
+  | [] -> [];;
+
+(* ------------------------------------------------------------------------- *)
+(* String operations (surely there is a better way...)                       *)
+(* ------------------------------------------------------------------------- *)
+
+let implode l = itlist (^) l "";;
+
+let explode s =
+  let rec exap n l =
+      if n < 0 then l else
+      exap (n - 1) ((String.sub s n 1)::l) in
+  exap (String.length s - 1) [];;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Attempting function or predicate applications.                            *)
+(* ------------------------------------------------------------------------- *)
+
+let can f x = try (f x; true) with Failure _ -> false;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Repetition of a function.                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+let rec funpow n f x =
+  if n < 1 then x else funpow (n-1) f (f x);;
+
+
+
+(* ------------------------------------------------------------------------- *)
+(* Replication and sequences.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec replicate x n =
+    if n < 1 then []
+    else x::(replicate x (n - 1));;
+
+let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Various useful list operations.                                           *)
+(* ------------------------------------------------------------------------- *)
+
+let rec forall p l =
+  match l with
+    [] -> true
+  | h::t -> p(h) & forall p t;;
+
+let rec tryfind f l =
+  match l with
+      [] -> failwith "tryfind"
+    | (h::t) -> try f h with Failure _ -> tryfind f t;;
+
+let index x =
+  let rec ind n l =
+    match l with
+      [] -> failwith "index"
+    | (h::t) -> if x =? h then n else ind (n + 1) t in
+  ind 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* "Set" operations on lists.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec mem x lis =
+  match lis with
+    [] -> false
+  | (h::t) -> x =? h or mem x t;;
+
+let insert x l =
+  if mem x l then l else x::l;;
+
+let union l1 l2 = itlist insert l1 l2;;
+
+let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Merging and bottom-up mergesort.                                          *)
+(* ------------------------------------------------------------------------- *)
+
+let rec merge ord l1 l2 =
+  match l1 with
+    [] -> l2
+  | h1::t1 -> match l2 with
+                [] -> l1
+              | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
+                          else h2::(merge ord l1 t2);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Common measure predicates to use with "sort".                             *)
+(* ------------------------------------------------------------------------- *)
+
+let increasing f x y = f x <? f y;;
+
+let decreasing f x y = f x >? f y;;
+
+(* ------------------------------------------------------------------------- *)
+(* Zipping, unzipping etc.                                                   *)
+(* ------------------------------------------------------------------------- *)
+
+let rec zip l1 l2 =
+  match (l1,l2) with
+        ([],[]) -> []
+      | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
+      | _ -> failwith "zip";;
+
+let rec unzip =
+  function [] -> [],[]
+         | ((a,b)::rest) -> let alist,blist = unzip rest in
+                            (a::alist,b::blist);;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterating functions over lists.                                           *)
+(* ------------------------------------------------------------------------- *)
+
+let rec do_list f l =
+  match l with
+    [] -> ()
+  | (h::t) -> (f h; do_list f t);;
+
+(* ------------------------------------------------------------------------- *)
+(* Sorting.                                                                  *)
+(* ------------------------------------------------------------------------- *)
+
+let rec sort cmp lis =
+  match lis with
+    [] -> []
+  | piv::rest ->
+      let r,l = partition (cmp piv) rest in
+      (sort cmp l) @ (piv::(sort cmp r));;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing adjacent (NB!) equal elements from list.                         *)
+(* ------------------------------------------------------------------------- *)
+
+let rec uniq l =
+  match l with
+    x::(y::_ as t) -> let t' = uniq t in
+                      if x =? y then t' else
+                      if t'==t then l else x::t'
+ | _ -> l;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert list into set by eliminating duplicates.                          *)
+(* ------------------------------------------------------------------------- *)
+
+let setify s = uniq (sort (<=?) s);;
+
+(* ------------------------------------------------------------------------- *)
+(* Polymorphic finite partial functions via Patricia trees.                  *)
+(*                                                                           *)
+(* The point of this strange representation is that it is canonical (equal   *)
+(* functions have the same encoding) yet reasonably efficient on average.    *)
+(*                                                                           *)
+(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10).        *)
+(* ------------------------------------------------------------------------- *)
+
+type ('a,'b)func =
+   Empty
+ | Leaf of int * ('a*'b)list
+ | Branch of int * int * ('a,'b)func * ('a,'b)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefined function.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+let undefined = Empty;;
+
+(* ------------------------------------------------------------------------- *)
+(* In case of equality comparison worries, better use this.                  *)
+(* ------------------------------------------------------------------------- *)
+
+let is_undefined f =
+  match f with
+    Empty -> true
+  | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operation analagous to "map" for lists.                                   *)
+(* ------------------------------------------------------------------------- *)
+
+let mapf =
+  let rec map_list f l =
+    match l with
+      [] -> []
+    | (x,y)::t -> (x,f(y))::(map_list f t) in
+  let rec mapf f t =
+    match t with
+      Empty -> Empty
+    | Leaf(h,l) -> Leaf(h,map_list f l)
+    | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
+  mapf;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operations analogous to "fold" for lists.                                 *)
+(* ------------------------------------------------------------------------- *)
+
+let foldl =
+  let rec foldl_list f a l =
+    match l with
+      [] -> a
+    | (x,y)::t -> foldl_list f (f a x y) t in
+  let rec foldl f a t =
+    match t with
+      Empty -> a
+    | Leaf(h,l) -> foldl_list f a l
+    | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
+  foldl;;
+
+let foldr =
+  let rec foldr_list f l a =
+    match l with
+      [] -> a
+    | (x,y)::t -> f x y (foldr_list f t a) in
+  let rec foldr f t a =
+    match t with
+      Empty -> a
+    | Leaf(h,l) -> foldr_list f l a
+    | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
+  foldr;;
+
+(* ------------------------------------------------------------------------- *)
+(* Redefinition and combination.                                             *)
+(* ------------------------------------------------------------------------- *)
+
+let (|->),combine =
+  let ldb x y = let z = x lxor y in z land (-z) in
+  let newbranch p1 t1 p2 t2 =
+    let b = ldb p1 p2 in
+    let p = p1 land (b - 1) in
+    if p1 land b = 0 then Branch(p,b,t1,t2)
+    else Branch(p,b,t2,t1) in
+  let rec define_list (x,y as xy) l =
+    match l with
+      (a,b as ab)::t ->
+          if x =? a then xy::t
+          else if x <? a then xy::l
+          else ab::(define_list xy t)
+    | [] -> [xy]
+  and combine_list op z l1 l2 =
+    match (l1,l2) with
+      [],_ -> l2
+    | _,[] -> l1
+    | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
+          if x1 <? x2 then xy1::(combine_list op z t1 l2)
+          else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
+          let y = op y1 y2 and l = combine_list op z t1 t2 in
+          if z(y) then l else (x1,y)::l in
+  let (|->) x y =
+    let k = Hashtbl.hash x in
+    let rec upd t =
+      match t with
+        Empty -> Leaf (k,[x,y])
+      | Leaf(h,l) ->
+           if h = k then Leaf(h,define_list (x,y) l)
+           else newbranch h t k (Leaf(k,[x,y]))
+      | Branch(p,b,l,r) ->
+          if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
+          else if k land b = 0 then Branch(p,b,upd l,r)
+          else Branch(p,b,l,upd r) in
+    upd in
+  let rec combine op z t1 t2 =
+    match (t1,t2) with
+      Empty,_ -> t2
+    | _,Empty -> t1
+    | Leaf(h1,l1),Leaf(h2,l2) ->
+          if h1 = h2 then
+            let l = combine_list op z l1 l2 in
+            if l = [] then Empty else Leaf(h1,l)
+          else newbranch h1 t1 h2 t2
+    | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) |
+      (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
+          if k land (b - 1) = p then
+            if k land b = 0 then
+              let l' = combine op z lf l in
+              if is_undefined l' then r else Branch(p,b,l',r)
+            else
+              let r' = combine op z lf r in
+              if is_undefined r' then l else Branch(p,b,l,r')
+          else
+            newbranch k lf p br
+    | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
+          if b1 < b2 then
+            if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
+            else if p2 land b1 = 0 then
+              let l = combine op z l1 t2 in
+              if is_undefined l then r1 else Branch(p1,b1,l,r1)
+            else
+              let r = combine op z r1 t2 in
+              if is_undefined r then l1 else Branch(p1,b1,l1,r)
+          else if b2 < b1 then
+            if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
+            else if p1 land b2 = 0 then
+              let l = combine op z t1 l2 in
+              if is_undefined l then r2 else Branch(p2,b2,l,r2)
+            else
+              let r = combine op z t1 r2 in
+              if is_undefined r then l2 else Branch(p2,b2,l2,r)
+          else if p1 = p2 then
+            let l = combine op z l1 l2 and r = combine op z r1 r2 in
+            if is_undefined l then r
+            else if is_undefined r then l else Branch(p1,b1,l,r)
+          else
+            newbranch p1 t1 p2 t2 in
+  (|->),combine;;
+
+(* ------------------------------------------------------------------------- *)
+(* Special case of point function.                                           *)
+(* ------------------------------------------------------------------------- *)
+
+let (|=>) = fun x y -> (x |-> y) undefined;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Grab an arbitrary element.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec choose t =
+  match t with
+    Empty -> failwith "choose: completely undefined function"
+  | Leaf(h,l) -> hd l
+  | Branch(b,p,t1,t2) -> choose t1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Application.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let applyd =
+  let rec apply_listd l d x =
+    match l with
+      (a,b)::t -> if x =? a then b
+                  else if x >? a then apply_listd t d x else d x
+    | [] -> d x in
+  fun f d x ->
+    let k = Hashtbl.hash x in
+    let rec look t =
+      match t with
+        Leaf(h,l) when h = k -> apply_listd l d x
+      | Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
+      | _ -> d x in
+    look f;;
+
+let apply f = applyd f (fun x -> failwith "apply");;
+
+let tryapplyd f a d = applyd f (fun x -> d) a;;
+
+let defined f x = try apply f x; true with Failure _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefinition.                                                             *)
+(* ------------------------------------------------------------------------- *)
+
+let undefine =
+  let rec undefine_list x l =
+    match l with
+      (a,b as ab)::t ->
+          if x =? a then t
+          else if x <? a then l else
+          let t' = undefine_list x t in
+          if t' == t then l else ab::t'
+    | [] -> [] in
+  fun x ->
+    let k = Hashtbl.hash x in
+    let rec und t =
+      match t with
+        Leaf(h,l) when h = k ->
+          let l' = undefine_list x l in
+          if l' == l then t
+          else if l' = [] then Empty
+          else Leaf(h,l')
+      | Branch(p,b,l,r) when k land (b - 1) = p ->
+          if k land b = 0 then
+            let l' = und l in
+            if l' == l then t
+            else if is_undefined l' then r
+            else Branch(p,b,l',r)
+          else
+            let r' = und r in
+            if r' == r then t
+            else if is_undefined r' then l
+            else Branch(p,b,l,r')
+      | _ -> t in
+    und;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to sorted-list representation of the graph, domain and range.     *)
+(* ------------------------------------------------------------------------- *)
+
+let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
+
+let dom f = setify(foldl (fun a x y -> x::a) [] f);;
+
+let ran f = setify(foldl (fun a x y -> y::a) [] f);;
+
+(* ------------------------------------------------------------------------- *)
+(* More parser basics.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+exception Noparse;;
+
+
+let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
+  let charcode s = Char.code(String.get s 0) in
+  let spaces = " \t\n\r"
+  and separators = ",;"
+  and brackets = "()[]{}"
+  and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
+  and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+  and nums = "0123456789" in
+  let allchars = spaces^separators^brackets^symbs^alphas^nums in
+  let csetsize = itlist ((o) max charcode) (explode allchars) 256 in
+  let ctable = Array.make csetsize 0 in
+  do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
+  do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
+  do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
+  do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
+  do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
+  do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
+  let isspace c = Array.get ctable (charcode c) = 1
+  and issep c  = Array.get ctable (charcode c) = 2
+  and isbra c  = Array.get ctable (charcode c) = 4
+  and issymb c = Array.get ctable (charcode c) = 8
+  and isalpha c = Array.get ctable (charcode c) = 16
+  and isnum c = Array.get ctable (charcode c) = 32
+  and isalnum c = Array.get ctable (charcode c) >= 16 in
+  isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;
+
+let (||) parser1 parser2 input =
+  try parser1 input
+  with Noparse -> parser2 input;;
+
+let (++) parser1 parser2 input =
+  let result1,rest1 = parser1 input in
+  let result2,rest2 = parser2 rest1 in
+  (result1,result2),rest2;;
+
+let rec many prs input =
+  try let result,next = prs input in
+      let results,rest = many prs next in
+      (result::results),rest
+  with Noparse -> [],input;;
+
+let (>>) prs treatment input =
+  let result,rest = prs input in
+  treatment(result),rest;;
+
+let fix err prs input =
+  try prs input
+  with Noparse -> failwith (err ^ " expected");;
+
+let rec listof prs sep err =
+  prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
+
+let possibly prs input =
+  try let x,rest = prs input in [x],rest
+  with Noparse -> [],input;;
+
+let some p =
+  function
+      [] -> raise Noparse
+    | (h::t) -> if p h then (h,t) else raise Noparse;;
+
+let a tok = some (fun item -> item = tok);;
+
+let rec atleast n prs i =
+  (if n <= 0 then many prs
+   else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
+
+let finished input =
+  if input = [] then 0,input else failwith "Unparsed input";;
+
+(* ------------------------------------------------------------------------- *)
+
+let temp_path = ref Filename.temp_dir_name;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convenient conversion between files and (lists of) strings.               *)
+(* ------------------------------------------------------------------------- *)
+
+let strings_of_file filename =
+  let fd = try Pervasives.open_in filename
+           with Sys_error _ ->
+             failwith("strings_of_file: can't open "^filename) in
+  let rec suck_lines acc =
+    try let l = Pervasives.input_line fd in
+        suck_lines (l::acc)
+    with End_of_file -> rev acc in
+  let data = suck_lines [] in
+  (Pervasives.close_in fd; data);;
+
+let string_of_file filename =
+  end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);;
+
+let file_of_string filename s =
+  let fd = Pervasives.open_out filename in
+  output_string fd s; close_out fd;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Iterative deepening.                                                      *)
+(* ------------------------------------------------------------------------- *)
+
+let rec deepen f n =
+  try (*print_string "Searching with depth limit ";
+      print_int n; print_newline();*) f n
+  with Failure _ -> deepen f (n + 1);;
+
+exception TooDeep
+
+let deepen_until limit f n =
+  match compare limit 0 with
+    | 0 -> raise TooDeep
+    | -1 -> deepen f n
+    | _  ->
+	let rec d_until  f n =
+	  try(* if !debugging
+	  then (print_string "Searching with depth limit ";
+		print_int n; print_newline()) ;*) f n
+	  with Failure x ->
+	    (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *)
+	    if n = limit then raise TooDeep else  d_until f (n + 1) in
+	  d_until f n
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
new file mode 100644
index 00000000..fe481ecc
--- /dev/null
+++ b/plugins/micromega/sos_types.ml
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* The type of positivstellensatz -- used to communicate with sos *)
+open Num
+
+type vname = string;;
+
+type term =
+| Zero
+| Const of Num.num
+| Var of vname
+| Inv of term
+| Opp of term
+| Add of (term * term)
+| Sub of (term * term)
+| Mul of (term * term)
+| Div of (term * term)
+| Pow of (term * int);;
+
+
+let rec output_term o t =
+  match t with
+    | Zero -> output_string o "0"
+    | Const n -> output_string o (string_of_num n)
+    | Var n   -> Printf.fprintf o "v%s" n
+    | Inv t   -> Printf.fprintf o "1/(%a)" output_term t
+    | Opp t    -> Printf.fprintf o "- (%a)" output_term t
+    | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2
+    | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2
+    | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2
+    | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2
+    | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i
+(* ------------------------------------------------------------------------- *)
+(* Data structure for Positivstellensatz refutations.                        *)
+(* ------------------------------------------------------------------------- *)
+
+type positivstellensatz =
+   Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of num
+ | Rational_le of num
+ | Rational_lt of num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz;;
+
+
+let rec output_psatz o = function
+  | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i
+  | Axiom_le i -> Printf.fprintf o "Ale(%i)" i
+  | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i
+  | Rational_eq  n -> Printf.fprintf o "eq(%s)" (string_of_num n)
+  | Rational_le  n -> Printf.fprintf o "le(%s)" (string_of_num n)
+  | Rational_lt n  ->  Printf.fprintf o "lt(%s)" (string_of_num n)
+  | Square t       -> Printf.fprintf o "(%a)^2" output_term t
+  | Monoid l       -> Printf.fprintf o "monoid"
+  | Eqmul (t,ps)   -> Printf.fprintf o "%a * %a" output_term t output_psatz ps
+  | Sum (t1,t2)    -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2
+  | Product (t1,t2)    -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
new file mode 100644
index 00000000..30201308
--- /dev/null
+++ b/plugins/micromega/vo.itarget
@@ -0,0 +1,13 @@
+CheckerMaker.vo
+EnvRing.vo
+Env.vo
+OrderedRing.vo
+Psatz.vo
+QMicromega.vo
+Refl.vo
+RingMicromega.vo
+RMicromega.vo
+Tauto.vo
+VarMap.vo
+ZCoeff.vo
+ZMicromega.vo
diff --git a/plugins/nsatz/NsatzR.v b/plugins/nsatz/NsatzR.v
new file mode 100644
index 00000000..c68c9584
--- /dev/null
+++ b/plugins/nsatz/NsatzR.v
@@ -0,0 +1,407 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*
+ Tactic nsatz: proofs of polynomials equalities with variables in R.
+ Uses Hilbert Nullstellensatz and Buchberger algorithm.
+ Thanks to B.Gregoire and L.Thery for help on ring tactic,
+ and to B.Barras for modularization of the ocaml code.
+ Example: see test-suite/success/Nsatz.v
+ L.Pottier, june 2010
+*)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Import RealField Rdefinitions Rfunctions RIneq DiscrR.
+Require Import Ring_polynom Ring_tac InitialRing.
+
+Declare ML Module "nsatz_plugin".
+
+Local Open Scope R_scope.
+
+Lemma psos_r1b: forall x y, x - y = 0 -> x = y.
+intros x y H; replace x with ((x - y) + y);
+  [rewrite H | idtac]; ring.
+Qed.
+
+Lemma psos_r1: forall x y, x = y -> x - y = 0.
+intros x y H; rewrite H; ring.
+Qed.
+
+Lemma nsatzR_not1: forall x y:R, x<>y -> exists z:R, z*(x-y)-1=0.
+intros.
+exists (1/(x-y)).
+field.
+unfold not.
+unfold not in H.
+intros.
+apply H.
+replace x with ((x-y)+y).
+rewrite H0.
+ring.
+ring.
+Qed.
+
+Lemma nsatzR_not1_0: forall x:R, x<>0 -> exists z:R, z*x-1=0.
+intros.
+exists (1/(x)).
+field.
+auto.
+Qed.
+
+
+Ltac equalities_to_goal :=
+  lazymatch goal with
+  |  H: (@eq R ?x 0) |- _ => try revert H
+  |  H: (@eq R 0 ?x) |- _ =>
+          try generalize (sym_equal H); clear H
+  |  H: (@eq R ?x ?y) |- _ =>
+          try generalize (psos_r1 _ _ H); clear H
+   end.
+
+Lemma nsatzR_not2: 1<>0.
+auto with *.
+Qed.
+
+Lemma nsatzR_diff: forall x y:R, x<>y -> x-y<>0.
+intros.
+intro; apply H.
+replace x with (x-y+y) by ring.
+rewrite H0; ring.
+Qed.
+
+(* Removes x<>0 from hypothesis *)
+Ltac nsatzR_not_hyp:=
+ match goal with
+ | H: ?x<>?y |- _ =>
+  match y with
+   |0 =>
+     let H1:=fresh "Hnsatz" in
+     let y:=fresh "x" in
+     destruct (@nsatzR_not1_0 _ H) as (y,H1); clear H
+   |_ => generalize (@nsatzR_diff _ _ H); clear H; intro
+  end
+ end.
+
+Ltac nsatzR_not_goal :=
+ match goal with
+ | |- ?x<>?y :> R => red; intro; apply nsatzR_not2
+ | |- False       => apply nsatzR_not2
+ end.
+
+Ltac nsatzR_begin :=
+  intros;
+  repeat nsatzR_not_hyp;
+  try nsatzR_not_goal;
+  try apply psos_r1b;
+  repeat equalities_to_goal.
+
+(* code de Benjamin *)
+
+Definition PolZ := Pol Z.
+Definition PEZ := PExpr Z.
+
+Definition P0Z : PolZ := @P0 Z 0%Z.
+
+Definition PolZadd : PolZ -> PolZ -> PolZ :=
+  @Padd Z 0%Z Zplus Zeq_bool.
+
+Definition PolZmul : PolZ -> PolZ -> PolZ :=
+  @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+
+Definition PolZeq := @Peq Z Zeq_bool.
+
+Definition norm :=
+  @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
+ match la, lp with
+ | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
+ | _, _ => P0Z
+ end.
+
+Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
+ match lla with
+ | List.nil => lp
+ | la::lla => compute_list lla ((mult_l la lp)::lp)
+ end.
+
+Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
+ let (lla, lq) := certif in
+ let lp := List.map norm lpe in
+ PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
+
+
+(* Correction *)
+Definition PhiR : list R -> PolZ -> R :=
+  (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)).
+
+Definition PEevalR : list R -> PEZ -> R :=
+   PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp)
+         Nnat.nat_of_N pow.
+
+Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
+Proof. trivial. Qed.
+
+
+Lemma PolZadd_correct : forall P' P l,
+  PhiR l (PolZadd P P') = (PhiR l P + PhiR l P').
+Proof.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+           (gen_phiZ_morph Rset Rext (F_R Rfield))).
+Qed.
+
+Lemma PolZmul_correct : forall P P' l,
+  PhiR l (PolZmul P P') = (PhiR l P * PhiR l P').
+Proof.
+ refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+           (gen_phiZ_morph Rset Rext (F_R Rfield))).
+Qed.
+
+Lemma norm_correct :
+  forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
+Proof.
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+           (gen_phiZ_morph Rset Rext (F_R Rfield)) R_power_theory) with (lmp:= List.nil).
+ compute;trivial.
+Qed.
+
+Lemma PolZeq_correct : forall P P' l,
+  PolZeq P P' = true ->
+  PhiR l P = PhiR l P'.
+Proof.
+ intros;apply
+   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial.
+Qed.
+
+Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
+  match l with
+  | List.nil => True
+  | a::l => Interp a = 0 /\ Cond0 A Interp l
+  end.
+
+Lemma mult_l_correct : forall l la lp,
+  Cond0 PolZ (PhiR l) lp ->
+  PhiR l (mult_l la lp) = 0.
+Proof.
+ induction la;simpl;intros;trivial.
+ destruct lp;trivial.
+ simpl in H;destruct H.
+ rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring | trivial].
+Qed.
+
+Lemma compute_list_correct : forall l lla lp,
+  Cond0 PolZ (PhiR l) lp ->
+  Cond0 PolZ (PhiR l) (compute_list lla lp).
+Proof.
+ induction lla;simpl;intros;trivial.
+ apply IHlla;simpl;split;trivial.
+ apply mult_l_correct;trivial.
+Qed.
+
+Lemma check_correct :
+  forall l lpe qe certif,
+    check lpe qe certif = true ->
+    Cond0 PEZ (PEevalR l) lpe ->
+    PEevalR l qe = 0.
+Proof.
+ unfold check;intros l lpe qe (lla, lq) H2 H1.
+ apply PolZeq_correct with (l:=l) in H2.
+ rewrite norm_correct, H2.
+ apply mult_l_correct.
+ apply compute_list_correct.
+ clear H2 lq lla qe;induction lpe;simpl;trivial.
+ simpl in H1;destruct H1.
+ rewrite <- norm_correct;auto.
+Qed.
+
+(* fin du code de Benjamin *)
+
+Lemma nsatzR_l3:forall c p r, ~c=0 -> c*p^r=0 -> p=0.
+intros.
+elim (Rmult_integral _ _ H0);intros.
+ absurd (c=0);auto.
+
+ clear H0; induction r; simpl in *.
+  contradict H1; discrR.
+
+  elim (Rmult_integral _ _ H1); auto.
+Qed.
+
+
+Ltac generalise_eq_hyps:=
+  repeat
+    (match goal with
+     |h : (?p = ?q)|- _ => revert h
+     end).
+
+Ltac lpol_goal t :=
+  match t with
+  | ?a = 0 -> ?b =>
+    let r:= lpol_goal b in
+    constr:(a::r)
+  | ?a = 0 => constr:(a::nil)
+ end.
+
+Fixpoint IPR p {struct p}: R :=
+  match p with
+    xH => 1
+  | xO xH => 1 + 1
+  | xO p1 => 2 * (IPR p1)
+  | xI xH => 1 + (1 + 1)
+  | xI p1 => 1 + 2 * (IPR p1)
+  end.
+
+Definition IZR1 z :=
+  match z with Z0 => 0
+             | Zpos p => IPR p
+             | Zneg p => -(IPR p)
+  end.
+
+Fixpoint interpret3 t fv {struct t}: R :=
+  match t with
+  | (PEadd t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 + v2)
+  | (PEmul t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 * v2)
+  | (PEsub t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 - v2)
+  | (PEopp t1) =>
+       let v1  := interpret3 t1 fv in (-v1)
+  | (PEpow t1 t2) =>
+       let v1  := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2)
+  | (PEc t1) => (IZR1 t1)
+  | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+  end.
+
+(* lp est incluse dans fv. La met en tete. *)
+
+Ltac parametres_en_tete fv lp :=
+    match fv with
+     | (@nil _)          => lp
+     | (@cons _ ?x ?fv1) =>
+       let res := AddFvTail x lp in
+         parametres_en_tete fv1 res
+    end.
+
+Ltac append1 a l :=
+ match l with
+ | (@nil _)     => constr:(cons a l)
+ | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
+ end.
+
+Ltac rev l :=
+  match l with
+   |(@nil _)      => l
+   | (cons ?x ?l) => let l' := rev l in append1 x l'
+  end.
+
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+  nsatz_compute (PEc info :: PEc nparam :: PEpow p rr :: lp);
+  match goal with
+  | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
+    intros _;
+    set (lci:=lci0);
+    set (lq:=lq0);
+    kont c rr lq lci
+  end.
+
+Ltac nsatz_call radicalmax info nparam p lp kont :=
+  let rec try_n n :=
+    lazymatch n with
+    | 0%N => fail
+    | _ =>
+(*        idtac "Trying power: " n;*)
+        (let r := eval compute in (Nminus radicalmax (Npred n)) in
+         nsatz_call_n info nparam p r lp kont) ||
+         let n' := eval compute in (Npred n) in try_n n'
+    end in
+  try_n radicalmax.
+
+
+Ltac nsatzR_gen radicalmax info lparam lvar n RNG lH _rl :=
+  get_Pre RNG ();
+  let mkFV := Ring_tac.get_RingFV RNG in
+  let mkPol := Ring_tac.get_RingMeta RNG in
+  generalise_eq_hyps;
+  let t := Get_goal in
+  let lpol := lpol_goal t in
+  intros;
+  let fv :=
+    match lvar with
+    | nil =>
+        let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+        let fv1 := list_fold_right mkFV fv1 lpol in
+        rev fv1
+    (* heuristique: les dernieres variables auront le poid le plus fort *)
+    | _ => lvar
+    end in
+  check_fv fv;
+  (*idtac "variables:";idtac fv;*)
+  let nparam := eval compute in (Z_of_nat (List.length lparam)) in
+  let fv := parametres_en_tete fv lparam in
+  idtac "variables:"; idtac fv;
+   (* idtac "nparam:"; idtac nparam;*)
+  let lpol := list_fold_right
+    ltac:(fun p l => let p' := mkPol p fv in constr:(p'::l))
+    (@nil (PExpr Z))
+    lpol in
+  let lpol := eval compute in (List.rev lpol) in
+  (*idtac lpol;*)
+  let SplitPolyList kont :=
+    match lpol with
+    | ?p2::?lp2 => kont p2 lp2
+    | _ => idtac "polynomial not in the ideal"
+    end in
+  SplitPolyList ltac:(fun p lp =>
+    set (p21:=p) ;
+    set (lp21:=lp);
+    nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
+      set (q := PEmul c (PEpow p21 r));
+      let Hg := fresh "Hg" in
+      assert (Hg:check lp21 q (lci,lq) = true);
+      [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
+      | let Hg2 := fresh "Hg" in
+        assert (Hg2: interpret3 q fv = 0);
+        [ simpl; apply (@check_correct fv lp21 q (lci,lq) Hg); simpl;
+          repeat (split;[assumption|idtac]); exact I
+        | simpl in Hg2; simpl;
+          apply nsatzR_l3 with (interpret3 c fv) (Nnat.nat_of_N r);simpl;
+          [ discrR || idtac "could not prove discrimination result"
+          | exact Hg2]
+        ]
+      ])).
+
+Ltac nsatzRpv radicalmax info lparam lvar:=
+  nsatzR_begin;
+  intros;
+  let G := Get_goal in
+  ring_lookup
+    (PackRing ltac:(nsatzR_gen radicalmax info lparam lvar ring_subst_niter))
+    [] G.
+
+Ltac nsatzR := nsatzRpv 6%N 1%Z (@nil R) (@nil R).
+Ltac nsatzRradical radicalmax := nsatzRpv radicalmax 1%Z (@nil R) (@nil R).
+Ltac nsatzRparameters lparam := nsatzRpv 6%N 1%Z lparam (@nil R).
+
+Tactic Notation "nsatz" := nsatzR.
+Tactic Notation "nsatz" "with" "lexico" :=
+  nsatzRpv 6%N 2%Z (@nil R) (@nil R).
+Tactic Notation "nsatz" "with" "lexico" "sugar":=
+  nsatzRpv 6%N 3%Z (@nil R) (@nil R).
+Tactic Notation "nsatz" "without" "sugar":=
+  nsatzRpv 6%N 0%Z (@nil R) (@nil R).
+
+
diff --git a/plugins/nsatz/NsatzZ.v b/plugins/nsatz/NsatzZ.v
new file mode 100644
index 00000000..a65efac2
--- /dev/null
+++ b/plugins/nsatz/NsatzZ.v
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Reals ZArith.
+Require Export NsatzR.
+
+Open Scope Z_scope.
+
+Lemma nsatzZhypR: forall x y:Z, x=y -> IZR x = IZR y.
+Proof IZR_eq. (* or f_equal ... *)
+
+Lemma nsatzZconclR: forall x y:Z, IZR x = IZR y -> x = y.
+Proof eq_IZR.
+
+Lemma nsatzZhypnotR: forall x y:Z, x<>y -> IZR x <> IZR y.
+Proof IZR_neq.
+
+Lemma nsatzZconclnotR: forall x y:Z, IZR x <> IZR y -> x <> y.
+Proof.
+intros x y H. contradict H. f_equal. assumption.
+Qed.
+
+Ltac nsatzZtoR1 :=
+ repeat
+  (match goal with
+   | H:(@eq Z ?x ?y) |- _ =>
+       generalize (@nsatzZhypR _ _ H); clear H; intro H
+   | |- (@eq Z ?x ?y) => apply nsatzZconclR
+   | H:not (@eq Z ?x ?y) |- _ =>
+       generalize (@nsatzZhypnotR _ _ H); clear H; intro H
+   | |- not (@eq Z ?x ?y) => apply nsatzZconclnotR
+   end).
+
+Lemma nsatzZR1: forall x y:Z, IZR(x+y) = (IZR x + IZR y)%R.
+Proof plus_IZR.
+
+Lemma nsatzZR2: forall x y:Z, IZR(x*y) = (IZR x * IZR y)%R.
+Proof mult_IZR.
+
+Lemma nsatzZR3: forall x y:Z, IZR(x-y) = (IZR x - IZR y)%R.
+Proof.
+intros; symmetry. apply Z_R_minus.
+Qed.
+
+Lemma nsatzZR4: forall (x:Z) p, IZR(x ^ Zpos p) = (IZR x ^ nat_of_P p)%R.
+Proof.
+intros. rewrite pow_IZR.
+do 2 f_equal.
+apply Zpos_eq_Z_of_nat_o_nat_of_P.
+Qed.
+
+Ltac nsatzZtoR2:=
+  repeat
+   (rewrite nsatzZR1 in * ||
+    rewrite nsatzZR2 in * ||
+    rewrite nsatzZR3 in * ||
+    rewrite nsatzZR4 in *).
+
+Ltac nsatzZ_begin :=
+ intros;
+ nsatzZtoR1;
+ nsatzZtoR2;
+ simpl in *.
+ (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*)
+
+Ltac nsatzZ :=
+ nsatzZ_begin; (*idtac "nsatzZ_begin;";*)
+ nsatzR.
diff --git a/plugins/nsatz/Nsatz_domain.v b/plugins/nsatz/Nsatz_domain.v
new file mode 100644
index 00000000..11f905f9
--- /dev/null
+++ b/plugins/nsatz/Nsatz_domain.v
@@ -0,0 +1,558 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*
+ Tactic nsatz: proofs of polynomials equalities with variables in R.
+ Uses Hilbert Nullstellensatz and Buchberger algorithm.
+ Thanks to B.Gregoire for the verification of the certicate
+ and L.Thery for help on ring tactic,
+ and to B.Barras for modularization of the ocaml code.
+ Example: see test-suite/success/Nsatz.v
+ L.Pottier, june 2010
+*)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Import Ring_polynom Ring_tac InitialRing.
+
+Declare ML Module "nsatz_plugin".
+
+
+Class Zero (A : Type) := {zero : A}.
+Notation "0" := zero.
+Class One (A : Type) := {one : A}.
+Notation "1" := one.
+Class Addition (A : Type) := {addition : A -> A -> A}.
+Notation "x + y" := (addition x y).
+Class Multiplication (A : Type) := {multiplication : A -> A -> A}.
+Notation "x * y" := (multiplication x y).
+Class Subtraction (A : Type) := {subtraction : A -> A -> A}.
+Notation "x - y" := (subtraction x y).
+Class Opposite (A : Type) := {opposite : A -> A}.
+Notation "- x" := (opposite x).
+
+Class Ring (R:Type) := {
+ ring0: R; ring1: R;
+ ring_plus: R->R->R; ring_mult: R->R->R;
+ ring_sub:  R->R->R; ring_opp: R->R;
+ ring_ring:
+   ring_theory ring0 ring1 ring_plus ring_mult ring_sub
+               ring_opp (@eq R)}.
+
+Class Domain (R : Type) := {
+ domain_ring:> Ring R;
+ domain_axiom_product:
+   forall x y, ring_mult x y = ring0 -> x = ring0 \/ y = ring0;
+ domain_axiom_one_zero: ring1 <> ring0}.
+
+Ltac ring2 := simpl; ring.
+
+Section domain.
+
+Variable R: Type.
+Variable Rd: Domain R.
+Add Ring Rr: (@ring_ring R (@domain_ring R Rd)).
+
+Instance zero_ring : Zero R := {zero := ring0}.
+Instance one_ring : One R := {one := ring1}.
+Instance addition_ring : Addition R := {addition x y := ring_plus x y}.
+Instance multiplication_ring : Multiplication R := {multiplication x y := ring_mult x y}.
+Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}.
+Instance opposite_ring : Opposite R := {opposite x := ring_opp x}.
+
+Lemma psos_r1b: forall x y:R, x - y = 0 -> x = y.
+intros x y H; replace x with ((x - y) + y);
+  [rewrite H | idtac]; ring2.
+Qed.
+
+Lemma psos_r1: forall x y, x = y -> x - y = 0.
+intros x y H; rewrite H; ring2.
+Qed.
+
+
+Lemma nsatzR_diff: forall x y:R, x<>y -> x - y<>0.
+intros.
+intro; apply H.
+replace x with ((x - y) + y) by ring2.
+rewrite H0; ring2.
+Qed.
+
+(* code de Benjamin *)
+Require Import ZArith.
+
+Definition PolZ := Pol Z.
+Definition PEZ := PExpr Z.
+
+Definition P0Z : PolZ := @P0 Z 0%Z.
+
+Definition PolZadd : PolZ -> PolZ -> PolZ :=
+  @Padd Z 0%Z Zplus Zeq_bool.
+
+Definition PolZmul : PolZ -> PolZ -> PolZ :=
+  @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+
+Definition PolZeq := @Peq Z Zeq_bool.
+
+Definition norm :=
+  @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
+ match la, lp with
+ | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
+ | _, _ => P0Z
+ end.
+
+Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
+ match lla with
+ | List.nil => lp
+ | la::lla => compute_list lla ((mult_l la lp)::lp)
+ end.
+
+Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
+ let (lla, lq) := certif in
+ let lp := List.map norm lpe in
+ PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
+
+
+(* Correction *)
+Definition PhiR : list R -> PolZ -> R :=
+  (Pphi 0 ring_plus ring_mult (gen_phiZ 0 1 ring_plus ring_mult ring_opp)).
+
+Definition pow (r : R) (n : nat) := pow_N 1 ring_mult r (Nnat.N_of_nat n).
+
+Definition PEevalR : list R -> PEZ -> R :=
+   PEeval 0 ring_plus ring_mult ring_sub ring_opp
+    (gen_phiZ 0 1 ring_plus ring_mult ring_opp)
+         Nnat.nat_of_N pow.
+
+Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
+Proof. trivial. Qed.
+
+Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp eq.
+apply mk_reqe. intros. rewrite H; rewrite H0; trivial.
+ intros. rewrite H; rewrite H0; trivial.
+intros. rewrite H; trivial. Qed.
+
+Lemma Rset : Setoid_Theory R eq.
+apply Eqsth.
+Qed.
+
+Lemma PolZadd_correct : forall P' P l,
+  PhiR l (PolZadd P P') = ((PhiR l P) + (PhiR l P')).
+Proof.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
+Qed.
+
+Lemma PolZmul_correct : forall P P' l,
+  PhiR l (PolZmul P P') = ((PhiR l P) * (PhiR l P')).
+Proof.
+ refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
+Qed.
+
+Lemma R_power_theory
+     : power_theory 1 ring_mult eq Nnat.nat_of_N pow.
+apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. trivial. Qed.
+
+Lemma norm_correct :
+  forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
+Proof.
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory)
+    with (lmp:= List.nil).
+ compute;trivial.
+Qed.
+
+Lemma PolZeq_correct : forall P P' l,
+  PolZeq P P' = true ->
+  PhiR l P = PhiR l P'.
+Proof.
+ intros;apply
+   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial.
+Qed.
+
+Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
+  match l with
+  | List.nil => True
+  | a::l => Interp a = 0 /\ Cond0 A Interp l
+  end.
+
+Lemma mult_l_correct : forall l la lp,
+  Cond0 PolZ (PhiR l) lp ->
+  PhiR l (mult_l la lp) = 0.
+Proof.
+ induction la;simpl;intros;trivial.
+ destruct lp;trivial.
+ simpl in H;destruct H.
+ rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring2 | trivial].
+Qed.
+
+Lemma compute_list_correct : forall l lla lp,
+  Cond0 PolZ (PhiR l) lp ->
+  Cond0 PolZ (PhiR l) (compute_list lla lp).
+Proof.
+ induction lla;simpl;intros;trivial.
+ apply IHlla;simpl;split;trivial.
+ apply mult_l_correct;trivial.
+Qed.
+
+Lemma check_correct :
+  forall l lpe qe certif,
+    check lpe qe certif = true ->
+    Cond0 PEZ (PEevalR l) lpe ->
+    PEevalR l qe = 0.
+Proof.
+ unfold check;intros l lpe qe (lla, lq) H2 H1.
+ apply PolZeq_correct with (l:=l) in H2.
+ rewrite norm_correct, H2.
+ apply mult_l_correct.
+ apply compute_list_correct.
+ clear H2 lq lla qe;induction lpe;simpl;trivial.
+ simpl in H1;destruct H1.
+ rewrite <- norm_correct;auto.
+Qed.
+
+(* fin du code de Benjamin *)
+
+Lemma pow_not_zero: forall p n, pow p n = 0 -> p = 0.
+induction n. unfold pow; simpl. intros. absurd (1 = 0).
+simpl. apply domain_axiom_one_zero.
+ trivial. replace (pow p (S n)) with (p * (pow p n)). intros.
+case (@domain_axiom_product _ _ _ _ H). trivial. trivial.
+unfold pow; simpl.
+clear IHn. induction n; try ring2. simpl.
+ rewrite pow_pos_Psucc. trivial. exact Rset.
+ intros. rewrite H; rewrite H0; trivial.
+ intros. ring2. intros. ring2. Qed.
+
+Lemma Rdomain_pow: forall c p r, ~c= 0 -> c * (pow p r)= 0 -> p = ring0.
+intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c = 0); auto.
+intros. apply pow_not_zero with r. trivial. Qed.
+
+Definition R2:= 1 + 1.
+
+Fixpoint IPR p {struct p}: R :=
+  match p with
+    xH => 1
+  | xO xH => 1 + 1
+  | xO p1 => R2 + (IPR p1)
+  | xI xH => 1 + (1 + 1)
+  | xI p1 => 1 + (R2 * (IPR p1))
+  end.
+
+Definition IZR1 z :=
+  match z with Z0 => 0
+             | Zpos p => IPR p
+             | Zneg p => -(IPR p)
+  end.
+
+Fixpoint interpret3 t fv {struct t}: R :=
+  match t with
+  | (PEadd t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 + v2)
+  | (PEmul t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 * v2)
+  | (PEsub t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 - v2)
+  | (PEopp t1) =>
+       let v1  := interpret3 t1 fv in (- v1)
+  | (PEpow t1 t2) =>
+       let v1  := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2)
+  | (PEc t1) => (IZR1 t1)
+  | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+  end.
+
+
+End domain.
+
+Ltac equalities_to_goal :=
+  lazymatch goal with
+  |  H: (@eq _ ?x 0) |- _ => try revert H
+  |  H: (@eq _ 0 ?x) |- _ =>
+          try generalize (sym_equal H); clear H
+  |  H: (@eq _ ?x ?y) |- _ =>
+          try generalize (@psos_r1 _ _ _ _ H); clear H
+   end.
+
+Ltac nsatz_domain_begin tacsimpl:=
+  intros;
+  try apply (@psos_r1b _ _);
+  repeat equalities_to_goal;
+  tacsimpl.
+
+Ltac generalise_eq_hyps:=
+  repeat
+    (match goal with
+     |h : (?p = ?q)|- _ => revert h
+     end).
+
+Ltac lpol_goal t :=
+  match t with
+  | ?a = ring0 -> ?b =>
+    let r:= lpol_goal b in
+    constr:(a::r)
+  | ?a = ring0 => constr:(a::nil)
+ end.
+
+(* lp est incluse dans fv. La met en tete. *)
+
+Ltac parametres_en_tete fv lp :=
+    match fv with
+     | (@nil _)          => lp
+     | (@cons _ ?x ?fv1) =>
+       let res := AddFvTail x lp in
+         parametres_en_tete fv1 res
+    end.
+
+Ltac append1 a l :=
+ match l with
+ | (@nil _)     => constr:(cons a l)
+ | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
+ end.
+
+Ltac rev l :=
+  match l with
+   |(@nil _)      => l
+   | (cons ?x ?l) => let l' := rev l in append1 x l'
+  end.
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+  let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in
+  nsatz_compute ll;
+  match goal with
+  | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
+    intros _;
+    set (lci:=lci0);
+    set (lq:=lq0);
+    kont c rr lq lci
+  end.
+
+Ltac nsatz_call radicalmax info nparam p lp kont :=
+  let rec try_n n :=
+    lazymatch n with
+    | 0%N => fail
+    | _ =>
+(*        idtac "Trying power: " n;*)
+        (let r := eval compute in (Nminus radicalmax (Npred n)) in
+         nsatz_call_n info nparam p r lp kont) ||
+         let n' := eval compute in (Npred n) in try_n n'
+    end in
+  try_n radicalmax.
+
+
+Set Implicit Arguments.
+Class Cclosed_seq T (l:list T) := {}.
+Instance Iclosed_nil T : Cclosed_seq (T:=T) nil.
+Instance Iclosed_cons T t l `{Cclosed_seq (T:=T) l} : Cclosed_seq (T:=T) (t::l).
+
+Class Cfind_at (R:Type) (b:R) (l:list R) (i:nat) := {}.
+Instance  Ifind0 (R:Type) (b:R) l: Cfind_at b (b::l) 0.
+Instance  IfindS (R:Type) (b2 b1:R) l i `{Cfind_at R b1 l i} : Cfind_at b1 (b2::l) (S i) | 1.
+Definition Ifind0' := Ifind0.
+Definition IfindS' := IfindS.
+
+Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=R) l} := (l,i).
+
+Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}.
+Instance  Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0.
+Instance  Ireify_one (R:Type)  (Rd:Domain R) l : Creify (PEc 1%Z) l ring1.
+Instance  Ireify_plus (R:Type)  (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEadd e1 e2) l (ring_plus b1 b2).
+Instance  Ireify_mult (R:Type)  (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEmul e1 e2) l (ring_mult b1 b2).
+Instance  Ireify_sub (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEsub e1 e2) l (ring_sub b1 b2).
+Instance  Ireify_opp (R:Type) (Rd:Domain R) e1 l b1 `{Creify R e1 l b1}
+ : Creify (PEopp e1) l (ring_opp b1).
+Instance  Ireify_var (R:Type) b l i `{Cfind_at R b l i}
+ : Creify (PEX _ (P_of_succ_nat i)) l b | 100.
+
+
+Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}.
+Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R).
+Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2}
+ : Creifylist (e1::le2) l (b1::lb2).
+
+Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb}
+ {H:Cclosed_seq (T:=R) l} := (l,le).
+
+Unset Implicit Arguments.
+
+Ltac lterm_goal g :=
+  match g with
+  ?b1 = ?b2 => constr:(b1::b2::nil)
+  | ?b1 = ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l)
+  end.
+
+Ltac reify_goal l le lb:=
+  match le with
+     nil => idtac
+   | ?e::?le1 =>
+        match lb with
+         ?b::?lb1 =>
+           let x := fresh "B" in
+           set (x:= b) at 1;
+           change x with (@interpret3 _ _ e l);
+          clear x;
+           reify_goal l le1 lb1
+        end
+  end.
+
+Ltac get_lpol g :=
+  match g with
+  (interpret3 _ _ ?p _) = _ => constr:(p::nil)
+  | (interpret3 _ _ ?p _) = _ -> ?g =>
+       let l := get_lpol g in constr:(p::l)
+  end.
+
+Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd :=
+  match goal with
+  |- ?g => let lb := lterm_goal g in
+     (*idtac "lb"; idtac lb;*)
+     match eval red in (li_reifyl (lb:=lb)) with
+     | (?fv, ?le) =>
+        let fv := match lvar with
+                     (@nil _) => fv
+                    | _ => lvar
+                  end in
+        (* idtac "variables:";idtac fv;*)
+        let nparam := eval compute in (Z_of_nat (List.length lparam)) in
+        let fv := parametres_en_tete fv lparam in
+        (*idtac "variables:"; idtac fv;
+        idtac "nparam:"; idtac nparam;*)
+        match eval red in (li_reifyl (l:=fv) (lb:=lb)) with
+          | (?fv, ?le) =>
+              idtac "variables:";idtac fv;
+              reify_goal fv le lb;
+                match goal with
+                   |- ?g =>
+                       let lp := get_lpol g in
+                       let lpol := eval compute in (List.rev lp) in
+                       (*idtac "polynomes:"; idtac lpol;*)
+                       tacsimpl; intros;
+
+  let SplitPolyList kont :=
+    match lpol with
+    | ?p2::?lp2 => kont p2 lp2
+    | _ => idtac "polynomial not in the ideal"
+    end in
+  tacsimpl;
+  SplitPolyList ltac:(fun p lp =>
+    set (p21:=p) ;
+    set (lp21:=lp);
+    (*idtac "lp:"; idtac lp; *)
+    nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
+      set (q := PEmul c (PEpow p21 r));
+      let Hg := fresh "Hg" in
+      assert (Hg:check lp21 q (lci,lq) = true);
+      [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
+      | let Hg2 := fresh "Hg" in
+            assert (Hg2: interpret3 _ _ q fv = ring0);
+        [ tacsimpl;
+          apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg);
+          tacsimpl;
+          repeat (split;[assumption|idtac]); exact I
+        | simpl in Hg2; tacsimpl;
+          apply Rdomain_pow with (interpret3 _ _ c fv) (Nnat.nat_of_N r); tacsimpl;
+          [ apply domain_axiom_one_zero || idtac "could not prove discrimination result"
+          | exact Hg2]
+        ]
+      ]
+)
+)
+end end end end .
+
+Ltac nsatz_domainpv radicalmax info lparam lvar tacsimpl rd:=
+  nsatz_domain_begin tacsimpl;
+  nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd.
+
+Ltac nsatz_domain:=
+  intros;
+  match goal with
+    |- (@eq ?r _ _ ) =>
+       let a := constr:(@Ireify_zero _ _  (@nil r)) in
+       match a with
+          (@Ireify_zero _ ?rd _) =>
+          nsatz_domainpv 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd
+       end
+  end.
+
+
+
+(* Dans Z *)
+Instance Zri : Ring Z := {
+  ring0 := 0%Z;
+  ring1 := 1%Z;
+  ring_plus := Zplus;
+  ring_mult := Zmult;
+  ring_sub := Zminus;
+  ring_opp := Zopp;
+  ring_ring := Zth}.
+
+Lemma Zaxiom_one_zero: 1%Z <> 0%Z.
+discriminate.
+Qed.
+
+Instance Zdi : Domain Z := {
+  domain_ring := Zri;
+  domain_axiom_product := Zmult_integral;
+  domain_axiom_one_zero := Zaxiom_one_zero}.
+
+
+Ltac simplZ:=
+  simpl;
+replace 0%Z with (@ring0 _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace 1%Z with (@ring1 _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zplus with (@ring_plus _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zmult with (@ring_mult _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zminus with (@ring_sub _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zopp with (@ring_opp _ (@domain_ring _ Zdi));[idtac|reflexivity].
+
+Ltac nsatz_domainZ:= nsatz_domainpv 6%N 1%Z (@nil Z) (@nil Z) ltac:simplZ Zdi.
+
+
+(* Dans R *)
+Require Import Reals.
+Require Import RealField.
+
+Instance Rri : Ring R := {
+  ring0 := 0%R;
+  ring1 := 1%R;
+  ring_plus := Rplus;
+  ring_mult := Rmult;
+  ring_sub := Rminus;
+  ring_opp := Ropp;
+  ring_ring := RTheory}.
+
+Lemma Raxiom_one_zero: 1%R <> 0%R.
+discrR.
+Qed.
+
+Instance Rdi : Domain R := {
+  domain_ring := Rri;
+  domain_axiom_product := Rmult_integral;
+  domain_axiom_one_zero := Raxiom_one_zero}.
+
+
+Ltac simplR:=
+  simpl;
+replace 0%R with (@ring0 _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace 1%R with (@ring1 _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rplus with (@ring_plus _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rmult with (@ring_mult _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rminus with (@ring_sub _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Ropp with (@ring_opp _ (@domain_ring _ Rdi));[idtac|reflexivity].
+
+Ltac nsatz_domainR:= nsatz_domainpv 6%N 1%Z (@List.nil R) (@List.nil R) ltac:simplR Rdi.
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
new file mode 100644
index 00000000..b91f01d1
--- /dev/null
+++ b/plugins/nsatz/ideal.ml
@@ -0,0 +1,1057 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Nullstellensatz with Groebner basis computation
+
+We use a sparse representation for polynomials:
+a monomial is an array of exponents (one for each variable)
+with its degree in head
+a polynomial is a sorted list of (coefficient, monomial)
+
+ *)
+
+open Utile
+open List
+
+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
+*)
+let lexico = ref false
+let use_hmon = ref false
+
+(* division of tail monomials *)
+
+let reduire_les_queues = false
+
+(* divide first with new polynomials *)
+
+let nouveaux_pol_en_tete = false
+
+(***********************************************************************
+   Functor
+*)
+
+module Make (P:Polynom.S) = struct
+
+  type coef = P.t
+  let coef0 = P.of_num (Num.Int 0)
+  let coef1 = P.of_num (Num.Int 1)
+  let coefm1 = P.of_num (Num.Int (-1))
+  let string_of_coef c = "["^(P.to_string c)^"]"
+
+(***********************************************************************
+   Monomials
+ array of integers, first is the degree
+*)
+
+type mon = int array
+type deg = int
+type poly = (coef * mon) list
+type polynom = 
+   {pol : poly ref;
+    num : int;
+    sugar : int}
+
+let nvar m =  Array.length m - 1
+
+let deg m = m.(0)
+
+let mult_mon m m' =
+  let d = nvar m in
+  let m'' = Array.create (d+1) 0 in
+  for i=0 to d do
+    m''.(i)<- (m.(i)+m'.(i));
+  done;
+  m''
+
+
+let compare_mon m m' =
+  let d = nvar m in
+  if !lexico
+  then (
+    (* Comparaison de monomes avec ordre du degre lexicographique = on commence par regarder la 1ere variable*)
+    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));
+      i:=!i+1;
+    done;
+    !res)
+  else (
+     (* degre lexicographique inverse *)
+    match 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));
+	  i:=!i-1;
+	done;
+	!res
+    | x -> x)
+
+let div_mon m m' =
+  let d = nvar m in
+  let m'' = Array.create (d+1) 0 in
+  for i=0 to d do
+    m''.(i)<- (m.(i)-m'.(i));
+  done;
+  m''
+
+let div_pol_coef p c =
+  List.map (fun (a,m) -> (P.divP a c,m)) p
+
+(* m' divides m  *)
+let div_mon_test m m' =
+  let d = nvar m in
+  let res=ref true in
+  let i=ref 0 in (*il faut que le degre total soit bien mis sinon, i=ref 1*)
+  while (!res) && (!i<=d) do
+    res:= (m.(!i) >= m'.(!i));
+    i:=succ !i;
+  done;
+  !res
+
+let set_deg m =
+  let d = nvar m in
+  m.(0)<-0;
+  for i=1 to d do
+    m.(0)<-  m.(i)+m.(0);
+  done;
+  m
+
+(* lcm *)
+let ppcm_mon m m' =
+  let d = nvar m in
+  let m'' = Array.create (d+1) 0 in
+  for i=1 to d do
+    m''.(i)<- (max m.(i) m'.(i));
+  done;
+  set_deg m''
+
+
+
+(**********************************************************************
+  Polynomials
+  list of (coefficient, monomial) decreasing order 
+*)
+
+let repr p = p
+
+let equal =
+  Util.list_for_all2eq
+    (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2)
+
+let hash p =
+  let c = map fst p in
+  let m = map snd p in
+  fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
+
+module Hashpol = Hashtbl.Make(
+  struct
+    type t = poly
+    let equal = equal
+    let hash = hash
+  end)
+
+
+(* A pretty printer for polynomials, with Maple-like syntax. *)
+
+open Format
+
+let getvar lv i =
+  try (nth lv i)
+  with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv)
+    ^" i="^(string_of_int i)
+
+let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef
+    dimmon string_of_exp lvar p =
+
+
+  let rec string_of_mon m coefone =
+    let s=ref [] in
+    for i=1 to (dimmon m) do
+      (match (string_of_exp m i) with
+        "0" -> ()
+      | "1" -> s:= (!s) @ [(getvar !lvar (i-1))]
+      | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]);
+    done;
+    (match !s with
+      [] -> if coefone 
+      then  "1"
+      else ""
+    | l -> if coefone 
+    then  (String.concat "*" l)
+    else ( "*" ^
+           (String.concat "*" l)))
+  and string_of_term t start = let a = coefterm t and m = monterm t in
+  match (string_of_coef a) with
+    "0" -> ""
+  | "1" ->(match start with
+      true -> string_of_mon m true
+    |false -> ( "+ "^
+                (string_of_mon m true)))
+  | "-1" ->( "-" ^" "^(string_of_mon m true))
+  | c -> if (String.get c 0)='-'
+  then ( "- "^
+         (String.sub c 1 
+            ((String.length c)-1))^
+         (string_of_mon m false))
+  else (match start with
+    true -> ( c^(string_of_mon m false))
+  |false -> ( "+ "^
+              c^(string_of_mon m false)))
+  and stringP p start = 
+    if (zeroP p)
+    then (if start 
+    then ("0")
+    else "")
+    else ((string_of_term (hdP p) start)^
+          " "^
+          (stringP (tlP p) false))
+  in 
+  (stringP p true)
+
+
+
+let print_pol zeroP hdP tlP coefterm monterm string_of_coef
+    dimmon string_of_exp lvar p =
+
+  let rec print_mon m coefone =
+    let s=ref [] in
+    for i=1 to (dimmon m) do
+      (match (string_of_exp m i) with
+        "0" -> ()
+      | "1" -> s:= (!s) @ [(getvar !lvar (i-1))]
+      | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]);
+    done;
+    (match !s with
+      [] -> if coefone 
+      then print_string "1"
+      else ()
+    | l -> if coefone 
+    then print_string (String.concat "*" l)
+    else (print_string "*"; 
+          print_string (String.concat "*" l)))
+  and print_term t start = let a = coefterm t and m = monterm t in
+  match (string_of_coef a) with
+    "0" -> ()
+  | "1" ->(match start with
+      true -> print_mon m true
+    |false -> (print_string "+ ";
+               print_mon m true))
+  | "-1" ->(print_string "-";print_space();print_mon m true)
+  | c -> if (String.get c 0)='-'
+  then (print_string "- ";
+        print_string (String.sub c 1 
+                        ((String.length c)-1));
+        print_mon m false)
+  else (match start with
+    true -> (print_string c;print_mon m false)
+  |false -> (print_string "+ ";
+             print_string c;print_mon m false))
+  and printP p start = 
+    if (zeroP p)
+    then (if start 
+    then print_string("0")
+    else ())
+    else (print_term (hdP p) start;
+          if start then open_hovbox 0;
+          print_space();
+          print_cut();
+          printP (tlP p) false)
+  in open_hovbox 3;
+  printP p true;
+  print_flush()
+
+
+let name_var= ref []
+
+let stringP p =
+  string_of_pol 
+    (fun p -> match p with [] -> true | _ -> false)
+    (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal")
+    (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal")
+    (fun (a,m) -> a)
+    (fun (a,m) -> m)
+    string_of_coef
+    (fun m -> (Array.length m)-1)
+    (fun m i -> (string_of_int (m.(i))))
+    name_var
+    p
+
+let nsP2 = ref max_int
+
+let stringPcut p =
+  (*Polynomesrec.nsP1:=20;*)
+  nsP2:=10;
+  let res =
+    if (length p)> !nsP2
+    then (stringP [hd p])^" + "^(string_of_int (length p))^" termes"
+    else  stringP p in
+  (*Polynomesrec.nsP1:= max_int;*)
+  nsP2:= max_int;
+  res
+
+let rec lstringP l =
+  match l with
+    [] -> ""
+  |p::l -> (stringP p)^("\n")^(lstringP l)
+
+let printP = print_pol 
+    (fun p -> match p with [] -> true | _ -> false)
+    (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal")
+    (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal")
+    (fun (a,m) -> a)
+    (fun (a,m) -> m)
+    string_of_coef
+    (fun m -> (Array.length m)-1)
+    (fun m i -> (string_of_int (m.(i))))
+    name_var
+
+
+let rec lprintP l =
+  match l with
+    [] -> ()
+  |p::l -> printP p;print_string "\n"; lprintP l
+
+
+(* Operations *)
+
+let zeroP = []
+
+(* returns a constant polynom ial with d variables *)
+let polconst d c =
+  let m = Array.create (d+1) 0 in
+  let m = set_deg m in 
+  [(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
+
+(* 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 coef_of_int x = P.of_num (Num.Int x)
+
+(* variable i *)
+let gen d i =
+  let m = Array.create (d+1) 0 in
+  m.(i) <- 1;
+  let m = set_deg m in 
+  [((coef_of_int 1),m)]
+
+let oppP p =
+  let rec oppP p =
+    match p with
+      [] -> []
+    |(b,m')::p -> ((P.oppP b),m')::(oppP p)
+  in oppP p
+
+(* multiplication by a coefficient *)
+let emultP a p =
+  let rec emultP p =
+    match p with
+      [] -> []
+    |(b,m')::p -> ((P.multP a b),m')::(emultP p)
+  in emultP p
+
+let multP p q =
+  let rec aux p =
+    match p with
+      [] -> []
+    |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p')
+  in aux p
+
+let puisP p n=
+  match p with
+    [] -> []
+  |_ ->
+      let d = nvar (snd (hd p)) in
+      let rec puisP n =
+	match n with
+	  0 -> [coef1, Array.create (d+1) 0]
+	| 1 -> p
+	|_ -> multP p (puisP (n-1))
+      in puisP n
+	
+let rec contentP p =
+  match p with
+  |[] -> coef1
+  |[a,m] -> a
+  |(a,m)::p1 ->
+      if P.equal a coef1 || P.equal a coefm1
+      then a
+      else P.pgcdP a (contentP p1)
+
+let contentPlist lp =
+  match lp with
+  |[] -> coef1
+  |p::l1 ->
+      fold_left
+	(fun r q ->
+	  if P.equal r coef1 || P.equal r coefm1
+	  then r
+	  else P.pgcdP r (contentP q))
+	(contentP p) l1
+	
+(***********************************************************************
+   Division of polynomials
+ *)
+
+let pgcdpos a b  = P.pgcdP a b
+
+let polynom0 =  {pol = ref []; num = 0; sugar = 0}
+   
+let ppol p = !(p.pol)
+
+let lm p = snd (hd (ppol p))
+
+let nallpol = ref 0
+
+let allpol = ref (Array.create 1000 polynom0)
+
+let new_allpol p s =
+  nallpol := !nallpol + 1;
+  if !nallpol >= Array.length !allpol
+  then
+    allpol := Array.append !allpol (Array.create !nallpol polynom0);
+  let p = {pol = ref p; num = !nallpol; sugar = s} in
+  !allpol.(!nallpol)<- p;
+  p
+
+(* returns a polynomial of l whose head monomial divides m, else [] *)
+
+let rec selectdiv m l =
+  match l with
+    [] -> polynom0
+  |q::r -> let m'= snd (hd (ppol q)) in
+    match (div_mon_test m m') with
+      true -> q
+    |false -> selectdiv m r
+
+let div_pol p q a b m = 
+(*  info ".";*)
+  plusP (emultP a p) (mult_t_pol b m q)
+
+let hmon = Hashtbl.create 1000
+
+let use_hmon = ref false
+
+let find_hmon m =
+  if !use_hmon
+  then Hashtbl.find hmon m
+  else raise Not_found
+
+let add_hmon m q =
+  if !use_hmon
+  then Hashtbl.add hmon m q
+  else ()
+
+let div_coef a b = P.divP a b
+
+
+(* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *)
+
+let reduce2 p l =
+  let l = if nouveaux_pol_en_tete then rev l else l in
+  let rec reduce p =
+    match p with
+      [] -> (coef1,[])
+    |t::p' ->
+	let (a,m)=t in
+      let q = (try find_hmon m 
+      with Not_found -> 
+	let q = selectdiv m l in
+	match (ppol q) with 
+          t'::q' -> (add_hmon m q;
+		     q)
+	|[] -> q) in
+      match (ppol q) with
+	[] -> if reduire_les_queues
+	then
+	  let (c,r)=(reduce p') in
+          (c,((P.multP a c,m)::r))
+	else (coef1,p)
+      |(b,m')::q' -> 
+          let c=(pgcdpos a b) in
+          let a'= (div_coef b c) in
+          let b'=(P.oppP (div_coef a c)) in
+          let (e,r)=reduce (div_pol p' q' a' b'
+                              (div_mon m m')) in
+          (P.multP a' e,r)
+  in let (c,r) = reduce p in
+  (c,r)
+
+(* trace of divisions *)
+
+(* list of initial polynomials *)
+let poldep = ref [] 
+let poldepcontent = ref []
+
+(* coefficients of polynomials when written with initial polynomials *)
+let coefpoldep = Hashtbl.create 51
+
+(* coef of q in p = sum_i c_i*q_i *)
+let coefpoldep_find p q =
+  try (Hashtbl.find coefpoldep (p.num,q.num))
+  with _ -> []
+
+let coefpoldep_remove p q =
+  Hashtbl.remove coefpoldep (p.num,q.num)
+
+let coefpoldep_set p q c =
+  Hashtbl.add coefpoldep (p.num,q.num) c
+
+let initcoefpoldep d lp =
+  poldep:=lp;
+  poldepcontent:= map (fun p -> contentP (ppol p)) lp;
+  iter
+    (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1)))
+    lp
+
+(* keeps trace in coefpoldep 
+   divides without pseudodivisions *)
+
+let reduce2_trace p l lcp =
+  let l = if nouveaux_pol_en_tete then rev l else l in
+  (* rend (lq,r), ou r = p + sum(lq) *)
+  let rec reduce p =
+    match p with
+      [] -> ([],[])
+    |t::p' ->
+	let (a,m)=t in
+      let q =
+	(try find_hmon m 
+	with Not_found -> 
+	  let q = selectdiv m l in
+	  match (ppol q) with 
+            t'::q' -> (add_hmon m q;
+		       q)
+          |[] -> q) in
+      match (ppol q) with
+	[] ->
+	  if reduire_les_queues
+	  then
+	    let (lq,r)=(reduce p') in
+            (lq,((a,m)::r))
+	  else ([],p)
+      |(b,m')::q' -> 
+          let b'=(P.oppP (div_coef a b)) in
+          let m''= div_mon m m' in
+          let p1=plusP p' (mult_t_pol b' m'' q') in
+          let (lq,r)=reduce p1 in
+          ((b',m'',q)::lq, r)
+  in let (lq,r) = reduce p in
+  (*info "reduce2_trace:\n";
+     iter
+     (fun (a,m,s) ->
+     let x = mult_t_pol a m s in
+     info ((stringP x)^"\n"))
+     lq;
+     info "ok\n";*)
+  (map2
+     (fun c0 q ->
+       let c =
+	 fold_left
+	   (fun x (a,m,s) ->
+	     if equal (ppol s) (ppol q)
+	     then
+	       plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1)))
+	     else x)
+	   c0
+	   lq in
+       c)
+     lcp
+     !poldep,
+   r)     
+
+let homogeneous = ref false
+let pol_courant = ref polynom0
+
+(***********************************************************************
+   Completion
+ *)
+
+let sugar_flag = ref true
+
+let compute_sugar p =
+  fold_left (fun s (a,m) -> max s m.(0)) 0 p
+
+let mk_polynom p = 
+  new_allpol p (compute_sugar p)
+
+let spol ps qs=
+  let p = ppol ps in
+  let q = ppol qs in
+  let m = snd (hd p) in
+  let m'= snd (hd q) in
+  let a = fst (hd p) in
+  let b = fst (hd q) in
+  let p'= tl p in
+  let q'= tl q in
+  let c = (pgcdpos a b) in
+  let m''=(ppcm_mon m m') in
+  let m1 = div_mon m'' m in
+  let m2 = div_mon m'' m' in
+  let fsp p' q' =
+    plusP 
+      (mult_t_pol 
+	 (div_coef b c)
+	 m1 p')
+      (mult_t_pol 
+	 (P.oppP (div_coef a c))
+         m2 q') in
+  let sp = fsp p' q' in
+  let sps =
+    new_allpol
+      sp
+      (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in
+  coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []);
+  coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1)));
+  sps
+  
+
+let etrangers p p'=
+  let m = snd (hd p) in
+  let m'= snd (hd p') in
+  let d = nvar m in
+  let res=ref true in
+  let i=ref 1 in
+  while (!res) && (!i<=d) do
+    res:= (m.(!i) = 0) || (m'.(!i)=0);
+      i:=!i+1;
+  done;
+  !res
+
+(* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *)
+
+let div_ppcm p p' p'' =
+  let m = snd (hd p) in
+  let m'= snd (hd p') in
+  let m''= snd (hd p'') in
+  let d = nvar m in
+  let res=ref true in
+  let i=ref 1 in
+  while (!res) && (!i<=d) do
+    res:= ((max m.(!i) m'.(!i)) >= m''.(!i));
+    i:=!i+1;
+  done;
+  !res
+
+(* code from extraction of Laurent Théry Coq program *)
+
+type 'poly cpRes =
+    Keep of ('poly list)
+  | DontKeep of ('poly list)
+
+let list_rec f0 f1 =
+  let rec f2 = function
+      [] -> f0
+    | a0::l0 -> f1 a0 l0 (f2 l0)
+  in f2
+
+let addRes i = function
+    Keep h'0 -> Keep (i::h'0)
+  | DontKeep h'0 -> DontKeep (i::h'0)
+
+let slice i a q =
+  list_rec
+    (match etrangers (ppol i) (ppol a) with
+      true -> DontKeep []
+    | false -> Keep [])
+    (fun b q1 rec_ren ->
+      match div_ppcm (ppol i) (ppol a) (ppol b) with
+	true ->  DontKeep (b::q1)
+      | false ->
+          (match div_ppcm (ppol i) (ppol b) (ppol a) with
+            true -> rec_ren
+          | false -> addRes b rec_ren)) q
+
+(* sugar strategy *)
+
+let rec addS x l =    l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
+			  
+let addSsugar x l =
+  if !sugar_flag
+  then 
+    let sx = x.sugar in
+    let rec insere l  =
+      match l with
+      | [] -> [x]
+      | y::l1 ->
+	  if sx <= y.sugar
+	  then x::l
+	  else y::(insere l1)
+    in insere l
+  else addS x l
+
+(* ajoute les spolynomes de i avec la liste de polynomes aP, 
+   a la liste q *)
+
+let genPcPf i aP q =
+  (let rec genPc aP0 =
+    match aP0 with
+      [] -> (fun r -> r)
+    | a::l1 -> 
+	(fun l ->
+          (match slice i a l1 with
+            Keep l2 -> addSsugar (spol i a) (genPc l2 l)
+          | DontKeep l2 -> genPc l2 l))
+  in genPc aP) q
+
+let genOCPf h' =
+  list_rec [] (fun a l rec_ren ->
+    genPcPf a l rec_ren) h'
+    
+(***********************************************************************
+ critical pairs/s-polynomials
+ *)
+    
+let ordcpair ((i1,j1),m1) ((i2,j2),m2) =
+(*  let s1 = (max
+	      (!allpol.(i1).sugar + m1.(0)
+		   - (snd (hd (ppol !allpol.(i1)))).(0))
+	      (!allpol.(j1).sugar + m1.(0)
+		   - (snd (hd (ppol !allpol.(j1)))).(0))) in 
+  let s2 = (max
+	      (!allpol.(i2).sugar + m2.(0)
+		   - (snd (hd (ppol !allpol.(i2)))).(0))
+	      (!allpol.(j2).sugar + m2.(0)
+		   - (snd (hd (ppol !allpol.(j2)))).(0))) in 
+  match compare s1 s2 with
+  | 1 -> 1
+  |(-1) -> -1
+  |0 ->  compare_mon m1 m2*)
+
+  compare_mon m1 m2 
+
+let sortcpairs lcp = 
+  sort ordcpair lcp
+
+let mergecpairs l1 l2 =
+  merge ordcpair l1 l2 
+
+let ord i j =
+  if i<j then (i,j) else (j,i)
+    
+let cpair p q =
+  if etrangers (ppol p) (ppol q)
+  then []
+  else [(ord p.num q.num,
+	 ppcm_mon (lm p) (lm q))]
+      
+let cpairs1 p lq =
+  sortcpairs (fold_left (fun r q -> r @ (cpair p q)) [] lq)
+    
+let cpairs lp =
+  let rec aux l =
+    match l with
+      []|[_] -> []
+    |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1)
+  in aux lp
+    
+    
+let critere2 ((i,j),m) lp lcp =
+  exists
+    (fun h ->
+      h.num <> i && h.num <> j
+        && (div_mon_test m (lm h))
+	&& (let c1 = ord i h.num in
+	not (exists (fun (c,_) -> c1 = c) lcp))
+	&& (let c1 = ord j h.num in
+	not (exists (fun (c,_) -> c1 = c) lcp)))
+    lp
+
+let critere3 ((i,j),m) lp lcp =
+  exists
+    (fun h ->
+      h.num <> i && h.num <> j
+        && (div_mon_test m (lm h))
+	&& (h.num < j
+	   || not (m = ppcm_mon 
+		   (lm (!allpol.(i)))
+		   (lm h)))
+	&& (h.num < i
+	  || not (m = ppcm_mon 
+		   (lm (!allpol.(j)))
+		   (lm h))))
+    lp
+
+let add_cpairs p lp lcp =
+  mergecpairs (cpairs1 p lp) lcp 
+
+let step = ref 0
+
+let infobuch p q =
+  if !step = 0 
+  then (info ("[" ^ (string_of_int (length p))
+              ^ "," ^  (string_of_int (length q))
+              ^ "]"))
+
+(* in lp new polynomials are at the end *)
+
+let coef_courant = ref coef1
+
+type certificate =
+    { coef : coef; power : int;
+      gb_comb : poly list list; last_comb : poly list }
+
+let test_dans_ideal p lp lp0 =
+  let (c,r) = reduce2 (ppol !pol_courant) lp in
+  info ("remainder: "^(stringPcut r)^"\n");
+  coef_courant:= P.multP !coef_courant c;
+  pol_courant:= mk_polynom r;
+  if r=[]
+  then (info "polynomial reduced to 0\n";
+	let lcp = map (fun q -> []) !poldep in
+	let c = !coef_courant in
+	let (lcq,r) = reduce2_trace (emultP c p) lp lcp in
+	info "r ok\n";
+	info ("r: "^(stringP r)^"\n");
+        let res=ref  (emultP c p) in
+	iter2
+	  (fun cq q -> res:=plusP (!res) (multP cq (ppol q));
+	  )
+	  lcq !poldep;
+	info ("verif sum: "^(stringP (!res))^"\n");
+	info ("coefficient: "^(stringP (polconst 1 c))^"\n");
+	let rec aux lp =
+	  match lp with
+	  |[] -> []
+	  |p::lp ->
+	      (map
+		 (fun q -> coefpoldep_find p q)
+		 lp)::(aux lp)
+	in
+	let coefficient_multiplicateur = c in
+	let liste_polynomes_de_depart = rev lp0 in
+	let polynome_a_tester = p in
+	let liste_des_coefficients_intermediaires =
+	  (let lci = rev (aux (rev lp)) in
+	  let lci = ref lci (* (map rev lci) *) in
+	  iter (fun x -> lci := tl (!lci)) lp0;
+	  !lci) in
+	let liste_des_coefficients =
+	  map
+	    (fun cq -> emultP (coef_of_int (-1)) cq)
+	    (rev lcq) in
+	(liste_polynomes_de_depart,
+	 polynome_a_tester,
+	 {coef = coefficient_multiplicateur;
+	  power = 1;
+	  gb_comb = liste_des_coefficients_intermediaires;
+	  last_comb = liste_des_coefficients})
+       )
+  else ((*info "polynomial not reduced to 0\n";
+	   info ("\nremainder: "^(stringPcut r)^"\n");*)
+    raise NotInIdeal)
+      
+let divide_rem_with_critical_pair = ref false
+
+let list_diff l x =
+  filter (fun y -> y <> x) l
+
+let deg_hom p =
+  match p with
+  | [] -> -1
+  | (a,m)::_ -> m.(0)
+
+let pbuchf pq p lp0=
+  info "computation of the Groebner basis\n";
+  step:=0;
+  Hashtbl.clear hmon;
+  let rec pbuchf (lp, lpc) =
+      infobuch lp lpc;
+(*      step:=(!step+1)mod 10;*)
+      match lpc with
+        [] ->
+	  
+	 (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));
+	  info "--------------------\n";*)
+	  test_dans_ideal (ppol p) lp lp0
+      | ((i,j),m) :: lpc2 ->
+(*          info "choosen pair\n";*)
+	  if critere3 ((i,j),m) lp lpc2
+	  then (info "c"; pbuchf (lp, lpc2))
+	  else    
+	    let a = spol !allpol.(i) !allpol.(j) in
+	    if !homogeneous && (ppol a)<>[] && deg_hom (ppol a)
+		> deg_hom (ppol !pol_courant)
+	    then (info "h"; pbuchf (lp, lpc2))
+	    else
+(*	      let sa = a.sugar in*)
+              let (ca,a0)= reduce2 (ppol a) lp in
+              match a0 with
+		[] -> info "0";pbuchf (lp, lpc2)
+              | _ ->
+(*		info "pair reduced\n";*)
+		  a.pol := emultP ca (ppol a);
+		  let (lca,a0) = reduce2_trace (ppol a) lp
+		      (map (fun q -> emultP ca (coefpoldep_find a q))
+			 !poldep) in
+(*		info "paire re-reduced";*)
+		  a.pol := a0;
+(*		  let a0 = new_allpol a0 sa in*)
+		  iter2 (fun c q ->
+		    coefpoldep_remove a q;
+		    coefpoldep_set a q c) lca !poldep;
+		  let a0 = a in
+		  info ("\nnew polynomials: "^(stringPcut (ppol a0))^"\n");
+		  let ct = coef1 (* contentP a0 *) in
+		  (*info ("content: "^(string_of_coef ct)^"\n");*)
+		  poldep:=addS a0 lp;
+		  poldepcontent:=addS ct (!poldepcontent);
+		  
+		  try test_dans_ideal (ppol p) (addS a0 lp) lp0
+		  with NotInIdeal ->
+		    let newlpc = add_cpairs a0 lp lpc2 in
+		    pbuchf (((addS a0 lp), newlpc))
+  in pbuchf pq
+    
+let is_homogeneous p =
+  match p with
+  | [] -> true
+  | (a,m)::p1 -> let d = m.(0) in
+    for_all (fun (b,m') -> m'.(0)=d) p1
+    
+(* returns
+   c
+   lp = [pn;...;p1]
+   p
+   lci = [[a(n+1,n);...;a(n+1,1)];
+   [a(n+2,n+1);...;a(n+2,1)];
+   ...
+   [a(n+m,n+m-1);...;a(n+m,1)]]
+   lc = [qn+m; ... q1]
+
+   such that
+   c*p = sum qi*pi 
+   where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1
+ *)
+
+let in_ideal d lp p =
+  Hashtbl.clear hmon;
+  Hashtbl.clear coefpoldep;
+  nallpol := 0;
+  allpol := Array.create 1000 polynom0;
+  homogeneous := for_all is_homogeneous (p::lp);
+  if !homogeneous then info "homogeneous polynomials\n";
+  info ("p: "^(stringPcut p)^"\n");
+  info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
+  (*info ("p: "^(stringP p)^"\n");
+  info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*)
+
+  let lp = map mk_polynom lp in
+  let p = mk_polynom p in
+  initcoefpoldep d lp;
+  coef_courant:=coef1;
+  pol_courant:=p;
+
+  let (lp1,p1,cert) =
+    try test_dans_ideal (ppol p) lp lp
+    with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in
+  info "computed\n";
+
+  (map ppol lp1, p1, cert)
+    
+(* *)
+end
+
+	
+
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4
new file mode 100644
index 00000000..892d6037
--- /dev/null
+++ b/plugins/nsatz/nsatz.ml4
@@ -0,0 +1,608 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Closure
+open Environ
+open Libnames
+open Tactics
+open Rawterm
+open Tacticals
+open Tacexpr
+open Pcoq
+open Tactic
+open Constr
+open Proof_type
+open Coqlib
+open Tacmach
+open Mod_subst
+open Tacinterp
+open Libobject
+open Printer
+open Declare
+open Decl_kinds
+open Entries
+
+open Num
+open Unix
+open Utile
+
+(***********************************************************************
+ Operations on coefficients
+*)
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10
+
+let numdom r =
+  let r' = Ratio.normalize_ratio (ratio_of_num r) in
+  num_of_big_int(Ratio.numerator_ratio r'),
+  num_of_big_int(Ratio.denominator_ratio r')
+
+module BigInt = struct
+  open Big_int
+
+  type t = big_int
+  let of_int = big_int_of_int
+  let coef0 = of_int 0
+  let coef1 = of_int 1
+  let of_num = Num.big_int_of_num
+  let to_num = Num.num_of_big_int
+  let equal = eq_big_int
+  let lt = lt_big_int
+  let le = le_big_int
+  let abs = abs_big_int
+  let plus =add_big_int
+  let mult = mult_big_int
+  let sub = sub_big_int
+  let opp = minus_big_int
+  let div = div_big_int
+  let modulo = mod_big_int
+  let to_string = string_of_big_int
+  let to_int x = int_of_big_int x
+  let hash x =
+    try (int_of_big_int x)
+    with _-> 1
+  let puis = power_big_int_positive_int
+
+  (* a et b positifs, résultat positif *)
+  let rec pgcd a b =
+    if equal b coef0
+    then a
+    else if lt a b then pgcd b a else pgcd b (modulo a b)
+
+
+  (* signe du pgcd = signe(a)*signe(b) si non nuls. *)
+  let pgcd2 a b =
+    if equal a coef0 then b
+    else if equal b coef0 then a
+    else let c = pgcd (abs a) (abs b) in
+    if ((lt coef0 a)&&(lt b coef0))
+      ||((lt coef0 b)&&(lt a coef0))
+    then opp c else c
+end
+
+(*
+module Ent = struct
+  type t = Entiers.entiers
+  let of_int = Entiers.ent_of_int
+  let of_num x = Entiers.ent_of_string(Num.string_of_num x)
+  let to_num x = Num.num_of_string (Entiers.string_of_ent x)
+  let equal = Entiers.eq_ent
+  let lt = Entiers.lt_ent
+  let le = Entiers.le_ent
+  let abs = Entiers.abs_ent
+  let plus =Entiers.add_ent
+  let mult = Entiers.mult_ent
+  let sub = Entiers.moins_ent
+  let opp = Entiers.opp_ent
+  let div = Entiers.div_ent
+  let modulo = Entiers.mod_ent
+  let coef0 = Entiers.ent0
+  let coef1 = Entiers.ent1
+  let to_string = Entiers.string_of_ent
+  let to_int x = Entiers.int_of_ent x
+  let hash x =Entiers.hash_ent x
+  let signe = Entiers.signe_ent
+
+  let rec puis p n = match n with
+      0 -> coef1
+    |_ -> (mult p (puis p (n-1)))
+
+  (* a et b positifs, résultat positif *)
+  let rec pgcd a b =
+    if equal b coef0
+    then a
+    else if lt a b then pgcd b a else pgcd b (modulo a b)
+
+
+  (* signe du pgcd = signe(a)*signe(b) si non nuls. *)
+  let pgcd2 a b =
+    if equal a coef0 then b
+    else if equal b coef0 then a
+    else let c = pgcd (abs a) (abs b) in
+    if ((lt coef0 a)&&(lt b coef0))
+      ||((lt coef0 b)&&(lt a coef0))
+    then opp c else c
+end
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* ------------------------------------------------------------------------- *)
+
+type vname = string
+
+type term =
+  | Zero
+  | Const of Num.num
+  | Var of vname
+  | Opp of term
+  | Add of term * term
+  | Sub of term * term
+  | Mul of term * term
+  | Pow of term * int
+
+let const n =
+  if eq_num n num_0 then Zero else Const n
+let pow(p,i) = if i=1 then p else Pow(p,i)
+let add = function
+    (Zero,q) -> q
+  | (p,Zero) -> p
+  | (p,q) -> Add(p,q)
+let mul = function
+    (Zero,_) -> Zero
+  | (_,Zero) -> Zero
+  | (p,Const n) when eq_num n num_1 -> p
+  | (Const n,q) when eq_num n num_1 -> q
+  | (p,q) -> Mul(p,q)
+
+let unconstr = mkRel 1
+
+let tpexpr =
+  lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr")
+let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc")
+let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX")
+let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd")
+let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub")
+let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul")
+let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp")
+let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow")
+
+let tlist = lazy (gen_constant "CC" ["Lists";"List"] "list")
+let lnil = lazy (gen_constant "CC" ["Lists";"List"] "nil")
+let lcons = lazy (gen_constant "CC" ["Lists";"List"] "cons")
+
+let tz = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z")
+let z0 = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z0")
+let zpos = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Zpos")
+let zneg = lazy(gen_constant "CC" ["ZArith";"BinInt"] "Zneg")
+
+let pxI = lazy(gen_constant "CC" ["NArith";"BinPos"] "xI")
+let pxO = lazy(gen_constant "CC" ["NArith";"BinPos"] "xO")
+let pxH = lazy(gen_constant "CC" ["NArith";"BinPos"] "xH")
+
+let nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0")
+let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos")
+
+let mkt_app name l =  mkApp (Lazy.force name, Array.of_list l)
+
+let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]]
+let tllp () = mkt_app tlist [tlp()]
+
+let rec mkt_pos n =
+  if n =/ num_1 then Lazy.force pxH
+  else if mod_num n num_2 =/ num_0 then
+    mkt_app pxO [mkt_pos (quo_num n num_2)]
+  else
+    mkt_app pxI [mkt_pos (quo_num n num_2)]
+
+let mkt_n n =
+  if n=num_0
+  then Lazy.force nN0
+  else mkt_app nNpos [mkt_pos n]
+
+let mkt_z z  =
+  if z =/ num_0 then  Lazy.force z0
+  else if z >/ num_0 then
+    mkt_app zpos [mkt_pos z]
+  else
+    mkt_app zneg [mkt_pos ((Int 0) -/ z)]
+
+let rec mkt_term t  =  match t with
+| Zero -> mkt_term (Const num_0)
+| Const r -> let (n,d) = numdom r in
+  mkt_app  ttconst [Lazy.force tz; mkt_z n]
+| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)]
+| Opp t1 -> mkt_app  ttopp [Lazy.force tz; mkt_term t1]
+| Add (t1,t2) -> mkt_app  ttadd [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Sub (t1,t2) -> mkt_app  ttsub [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Mul (t1,t2) -> mkt_app  ttmul [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Pow (t1,n) ->  if (n = 0) then
+    mkt_app ttconst [Lazy.force tz; mkt_z num_1]
+else
+    mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)]
+
+let rec parse_pos p =
+  match kind_of_term p with
+| App (a,[|p2|]) ->
+    if a = Lazy.force pxO then num_2 */ (parse_pos p2)
+    else num_1 +/ (num_2 */ (parse_pos p2))
+| _ -> num_1
+
+let parse_z z =
+  match kind_of_term z with
+| App (a,[|p2|]) ->
+    if a = Lazy.force zpos then parse_pos p2 else (num_0 -/ (parse_pos p2))
+| _ -> num_0
+
+let parse_n z =
+  match kind_of_term z with
+| App (a,[|p2|]) ->
+    parse_pos p2
+| _ -> num_0
+
+let rec parse_term p =
+  match kind_of_term p with
+| App (a,[|_;p2|]) ->
+    if a = Lazy.force ttvar then Var (string_of_num (parse_pos p2))
+    else if a = Lazy.force ttconst then Const (parse_z p2)
+    else if a = Lazy.force ttopp then Opp (parse_term p2)
+    else Zero
+| App (a,[|_;p2;p3|]) ->
+    if a = Lazy.force ttadd then Add (parse_term p2, parse_term p3)
+    else if a = Lazy.force ttsub then Sub (parse_term p2, parse_term p3)
+    else if a = Lazy.force ttmul then Mul (parse_term p2, parse_term p3)
+    else if a = Lazy.force ttpow then
+      Pow (parse_term p2, int_of_num (parse_n p3))
+    else Zero
+| _ -> Zero
+
+let rec parse_request lp =
+  match kind_of_term lp with
+    | App (_,[|_|])  -> []
+    | App (_,[|_;p;lp1|])  ->
+	(parse_term p)::(parse_request lp1)
+    |_-> assert false
+
+let nvars = ref 0
+
+let set_nvars_term t =
+  let rec aux t =
+    match t with
+    | Zero -> ()
+    | Const r -> ()
+    | Var v -> let n = int_of_string v in
+      nvars:= max (!nvars) n
+    | Opp t1 -> aux t1
+    | Add (t1,t2) -> aux t1; aux t2
+    | Sub (t1,t2) -> aux t1; aux t2
+    | Mul (t1,t2) -> aux t1; aux t2
+    | Pow (t1,n) ->  aux t1
+  in aux t
+
+let string_of_term p =
+  let rec aux p =
+    match p with
+    | Zero -> "0"
+    | Const r -> string_of_num r
+    | Var v -> "x"^v
+    | Opp t1 -> "(-"^(aux t1)^")"
+    | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")"
+    | Sub (t1,t2) ->  "("^(aux t1)^"-"^(aux t2)^")"
+    | Mul (t1,t2) ->  "("^(aux t1)^"*"^(aux t2)^")"
+    | Pow (t1,n) ->  (aux t1)^"^"^(string_of_int n)
+  in aux p
+
+
+(***********************************************************************
+   Coefficients: recursive polynomials
+ *)
+
+module Coef = BigInt
+(*module Coef = Ent*)
+module Poly = Polynom.Make(Coef)
+module PIdeal = Ideal.Make(Poly)
+open PIdeal
+
+(* term to sparse polynomial 
+   varaibles <=np are in the coefficients
+*)
+
+let term_pol_sparse np t=
+  let d = !nvars in
+  let rec aux t =
+    match t with
+    | Zero -> zeroP
+    | Const r ->
+	if r = num_0
+	then zeroP
+	else polconst d (Poly.Pint (Coef.of_num r))
+    | Var v ->
+	let v = int_of_string v in
+	if v <= np
+	then polconst d (Poly.x v)
+	else gen d v
+    | Opp t1 ->  oppP (aux t1)
+    | Add (t1,t2) -> plusP (aux t1) (aux t2)
+    | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2))
+    | Mul (t1,t2) -> multP (aux t1) (aux t2)
+    | Pow (t1,n) ->  puisP (aux t1) n
+  in (*info ("conversion de: "^(string_of_term t)^"\n");*)
+  let res= aux t in
+  (*info ("donne: "^(stringP res)^"\n");*)
+  res
+
+(* sparse polynomial to term *)
+
+let polrec_to_term p =
+  let rec aux p =
+  match p with
+   |Poly.Pint n -> const (Coef.to_num n)
+   |Poly.Prec (v,coefs) ->
+     let res = ref Zero in
+     Array.iteri
+      (fun i c ->
+	 res:=add(!res, mul(aux c,
+			    pow (Var (string_of_int v),
+				 i))))
+      coefs;
+     !res
+  in aux p
+
+(* approximation of the Horner form used in the tactic ring *)
+
+let pol_sparse_to_term n2 p =
+  info "pol_sparse_to_term ->\n";
+  let p = PIdeal.repr p in
+  let rec aux p =
+    match p with
+      [] -> const (num_of_string "0")
+    | (a,m)::p1 ->
+      let n = (Array.length m)-1 in
+      let (i0,e0) =
+	List.fold_left (fun (r,d) (a,m) ->
+	      let i0= ref 0 in
+	      for k=1 to n do
+		if m.(k)>0
+		then i0:=k
+	      done;
+	      if !i0 = 0
+	      then (r,d)
+	      else if !i0 > r
+	      then (!i0, m.(!i0))
+	      else if !i0 = r && m.(!i0)<d
+	      then (!i0, m.(!i0))
+	      else (r,d))
+	  (0,0)
+	  p in
+      if i0=0
+      then
+	let mp = ref (polrec_to_term a) in
+        if p1=[]
+	then !mp
+	else add(!mp,aux p1)
+      else (
+	let p1=ref [] in
+	let p2=ref [] in
+	List.iter
+	  (fun (a,m) ->
+	     if m.(i0)>=e0
+	     then (m.(i0)<-m.(i0)-e0;
+		   p1:=(a,m)::(!p1))
+	     else p2:=(a,m)::(!p2))
+	  p;
+	let vm =
+	  if e0=1
+	  then Var (string_of_int (i0))
+	  else pow (Var (string_of_int (i0)),e0) in
+	add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2))))
+  in   info "-> pol_sparse_to_term\n";
+  aux p
+
+
+let rec remove_list_tail l i =
+  let rec aux l i =
+    if l=[]
+    then []
+    else if i<0
+    then l
+    else if i=0
+    then List.tl l
+    else
+      match l with
+      |(a::l1) ->
+	  a::(aux l1 (i-1))
+      |_ -> assert false
+  in
+  List.rev (aux (List.rev l) i)
+
+(*
+   lq = [cn+m+1 n+m ...cn+m+1 1]
+   lci=[[cn+1 n,...,cn1 1]
+   ...
+   [cn+m n+m-1,...,cn+m 1]]
+
+   removes intermediate polynomials not useful to compute the last one.
+ *)
+
+let remove_zeros zero lci =
+  let n = List.length (List.hd lci) in
+  let m=List.length lci in
+  let u = Array.create m false in
+  let rec utiles k =
+    if k>=m
+    then ()
+    else (
+      u.(k)<-true;
+      let lc = List.nth lci k in
+      for i=0 to List.length lc - 1 do
+	if not (zero (List.nth lc i))
+	then utiles (i+k+1);
+      done)
+  in utiles 0;
+  let lr = ref [] in
+  for i=0 to m-1 do
+    if u.(i)
+    then lr:=(List.nth lci i)::(!lr)
+  done;
+  let lr=List.rev !lr in
+  let lr = List.map
+      (fun lc ->
+	let lcr=ref lc in
+	for i=0 to m-1 do
+	  if not u.(i)
+	  then lcr:=remove_list_tail !lcr (m-i+(n-m))
+	done;
+	!lcr)
+      lr in
+  info ("unuseful spolynomials: "
+	^string_of_int (m-List.length lr)^"\n");
+  info ("useful spolynomials: "
+	^string_of_int (List.length lr)^"\n");
+  lr
+
+let theoremedeszeros lpol p =
+  let t1 = Unix.gettimeofday() in
+  let m = !nvars in
+  let (lp0,p,cert) = in_ideal m lpol p in
+  let lpc = List.rev !poldepcontent in
+  info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1));
+  (cert,lp0,p,lpc)
+
+open Ideal
+
+let theoremedeszeros_termes lp =
+  nvars:=0;(* mise a jour par term_pol_sparse *)
+  List.iter set_nvars_term  lp;
+  match lp with
+  | Const (Int sugarparam)::Const (Int nparam)::lp ->
+      ((match sugarparam with
+      |0 -> info "calcul sans sugar\n";
+	  lexico:=false;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := false
+      |1 -> info "calcul avec sugar\n";
+	  lexico:=false;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := false
+      |2 -> info "ordre lexico calcul sans sugar\n";
+	  lexico:=true;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := false
+      |3 -> info "ordre lexico calcul avec sugar\n";
+	  lexico:=true;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := false
+      |4 -> info "calcul sans sugar, division par les paires\n";
+	  lexico:=false;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := true
+      |5 -> info "calcul avec sugar, division par les paires\n";
+	  lexico:=false;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := true
+      |6 -> info "ordre lexico calcul sans sugar, division par les paires\n";
+	  lexico:=true;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := true
+      |7 -> info "ordre lexico calcul avec sugar, division par les paires\n";
+	  lexico:=true;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := true
+      | _ -> error "nsatz: bad parameter"
+       );
+      let m= !nvars in
+      let lvar=ref [] in
+      for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done;
+      lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *)
+      name_var:=!lvar;
+      let lp = List.map (term_pol_sparse nparam) lp in
+      match lp with
+      | [] -> assert false
+      | p::lp1 ->
+	  let lpol = List.rev lp1 in
+	  let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
+	  let lc = cert.last_comb::List.rev cert.gb_comb in
+	  match remove_zeros (fun x -> x=zeroP) lc with
+	  | [] -> assert false
+	  | (lq::lci) ->
+	      (* lci commence par les nouveaux polynomes *)
+	      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
+	      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 ("nombre de parametres: "^string_of_int nparam^"\n");
+	      info "terme calcule\n";
+	      (c,r,lci,lq)
+      )
+  |_ -> assert false
+
+
+(* version avec hash-consing du certificat:
+let nsatz lpol =
+  Hashtbl.clear Dansideal.hmon;
+  Hashtbl.clear Dansideal.coefpoldep;
+  Hashtbl.clear Dansideal.sugartbl;
+  Hashtbl.clear Polynomesrec.hcontentP;
+  init_constants ();
+  let lp= parse_request lpol in
+  let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in
+  let certif = certificat_vers_polynome_creux rthz in
+  let certif = hash_certif certif in
+  let certif = certif_term certif in
+  let c = mkt_term c in
+  info "constr calcule\n";
+  (c, certif)
+*)
+
+let nsatz lpol =
+  let lp= parse_request lpol in
+  let (c,r,lci,lq) = theoremedeszeros_termes lp in
+  let res = [c::r::lq]@lci in
+  let res = List.map (fun lx -> List.map mkt_term lx) res in
+  let res =
+    List.fold_right
+      (fun lt r ->
+	 let ltterm =
+	   List.fold_right
+	     (fun t r ->
+		mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r])
+	     lt
+	     (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in
+	 mkt_app lcons [tlp ();ltterm;r])
+      res
+      (mkt_app lnil [tlp ()]) in
+  info "terme calcule\n";
+  res
+
+let return_term t =
+  let a =
+    mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in
+  generalize [a]
+
+let nsatz_compute t =
+  let lpol =
+    try nsatz t
+    with Ideal.NotInIdeal ->
+      error "nsatz cannot solve this problem" in
+  return_term lpol
+
+TACTIC EXTEND nsatz_compute
+| [ "nsatz_compute"  constr(lt) ] -> [ nsatz_compute lt ]
+END
+
+
diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mllib
new file mode 100644
index 00000000..a25e649d
--- /dev/null
+++ b/plugins/nsatz/nsatz_plugin.mllib
@@ -0,0 +1,5 @@
+Utile
+Polynom
+Ideal
+Nsatz
+Nsatz_plugin_mod
diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml
new file mode 100644
index 00000000..14e279b5
--- /dev/null
+++ b/plugins/nsatz/polynom.ml
@@ -0,0 +1,679 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Recursive polynomials: R[x1]...[xn]. *)
+open Utile
+open Util
+
+(* 1. Coefficients: R *)
+
+module type Coef = sig
+  type t
+  val equal : t -> t -> bool
+  val lt : t -> t -> bool
+  val le : t -> t -> bool
+  val abs : t -> t
+  val plus : t -> t -> t
+  val mult : t -> t -> t
+  val sub : t -> t -> t
+  val opp : t -> t
+  val div : t -> t -> t
+  val modulo : t -> t -> t
+  val puis : t -> int -> t
+  val pgcd : t -> t -> t
+
+  val hash : t -> int
+  val of_num : Num.num -> t
+  val to_string : t -> string
+end
+
+module type S = sig
+  type coef
+  type variable = int
+  type t = Pint of coef | Prec of variable * t array
+
+  val of_num : Num.num -> t
+  val x : variable -> t
+  val monome : variable -> int -> t
+  val is_constantP : t -> bool
+  val is_zero : t -> bool
+
+  val max_var_pol : t -> variable
+  val max_var_pol2 : t -> variable
+  val max_var : t array -> variable
+  val equal : t -> t -> bool
+  val norm : t -> t
+  val deg : variable -> t -> int
+  val deg_total : t -> int
+  val copyP : t -> t
+  val coef : variable -> int -> t -> t
+
+  val plusP : t -> t -> t
+  val content : t -> coef
+  val div_int : t -> coef -> t
+  val vire_contenu : t -> t
+  val vars : t -> variable list
+  val int_of_Pint : t -> coef
+  val multx : int -> variable -> t -> t
+  val multP : t -> t -> t
+  val deriv : variable -> t -> t
+  val oppP : t -> t
+  val moinsP : t -> t -> t
+  val puisP : t -> int -> t
+  val ( @@ ) : t -> t -> t
+  val ( -- ) : t -> t -> t
+  val ( ^^ ) : t -> int -> t
+  val coefDom : variable -> t -> t
+  val coefConst : variable -> t -> t
+  val remP : variable -> t -> t
+  val coef_int_tete : t -> coef
+  val normc : t -> t
+  val coef_constant : t -> coef
+  val univ : bool ref
+  val string_of_var : int -> string
+  val nsP : int ref
+  val to_string : t -> string
+  val printP : t -> unit
+  val print_tpoly : t array -> unit
+  val print_lpoly : t list -> unit
+  val quo_rem_pol : t -> t -> variable -> t * t
+  val div_pol : t -> t -> variable -> t
+  val divP : t -> t -> t
+  val div_pol_rat : t -> t -> bool
+  val pseudo_div : t -> t -> variable -> t * t * int * t
+  val pgcdP : t -> t -> t
+  val pgcd_pol : t -> t -> variable -> t
+  val content_pol : t -> variable -> t
+  val pgcd_coef_pol : t -> t -> variable -> t
+  val pgcd_pol_rec : t -> t -> variable -> t
+  val gcd_sub_res : t -> t -> variable -> t
+  val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t
+  val lazard_power : t -> t -> int -> variable -> t
+  val hash : t -> int
+  module Hashpol : Hashtbl.S with type key=t
+end
+
+(***********************************************************************
+  2. Type of polynomials, operations.
+*)
+module Make (C:Coef) = struct
+
+type coef = C.t
+let coef_of_int i = C.of_num (Num.Int i)
+let coef0 = coef_of_int 0
+let coef1 = coef_of_int 1
+
+type variable = int
+
+type t =
+    Pint of coef                    (* constant polynomial *)
+  | Prec of variable * (t array)    (* coefficients, increasing degree *)
+
+(* by default, operations work with normalized polynomials:
+- variables are positive integers
+- coefficients of a polynomial in x only use variables < x
+- no zero coefficient at beginning
+- no Prec(x,a) where a is constant in x
+*)
+
+(* constant polynomials *)
+let of_num x = Pint (C.of_num x)
+let cf0 = of_num (Num.Int 0)
+let cf1 = of_num (Num.Int 1)
+
+(* nth variable *)
+let x n = Prec (n,[|cf0;cf1|])
+
+(* create v^n *)
+let monome v n =
+  match n with
+      0->Pint coef1;
+    |_->let tmp = Array.create (n+1) (Pint coef0) in
+        tmp.(n)<-(Pint coef1);
+        Prec (v, tmp)
+
+let is_constantP = function
+    Pint _ -> true
+  | Prec _ -> false
+
+let int_of_Pint = function
+    Pint x -> x
+  | _ -> failwith "non"
+
+let is_zero p =
+  match p with Pint n -> if C.equal n coef0 then true else false |_-> false
+
+let max_var_pol p =
+  match p with
+      Pint _ -> 0
+    |Prec(x,_) -> x
+
+(* p not normalized *)
+let rec max_var_pol2 p =
+  match p with
+      Pint _ -> 0
+    |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v
+
+let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
+
+(* equality between polynomials *)
+
+let rec equal p q =
+  match (p,q) with
+      (Pint a,Pint b) -> C.equal a b
+    |(Prec(x,p1),Prec(y,q1)) ->
+       if x<>y then false
+       else if (Array.length p1)<>(Array.length q1) then false
+       else (try (Array.iteri (fun i a -> if not (equal a q1.(i))
+			       then failwith "raté")
+		    p1;
+		  true)
+	     with _ -> false)
+    | (_,_) -> false
+
+(* normalize polynomial: remove head zeros, coefficients are normalized
+   if constant, returns the coefficient
+*)
+
+let rec norm p = match p with
+    Pint _ -> p
+  |Prec (x,a)->
+     let d = (Array.length a -1) in
+     let n = ref d in
+       while !n>0 && (equal a.(!n) (Pint coef0)) do
+	 n:=!n-1;
+       done;
+       if !n<0 then Pint coef0
+       else if !n=0 then a.(0)
+       else if !n=d then p
+       else (let b=Array.create (!n+1) (Pint coef0) in
+               for i=0 to !n do b.(i)<-a.(i);done;
+               Prec(x,b))
+
+
+(* degree in v, v >= max var of p *)
+let rec deg v p =
+  match p with
+      Prec(x,p1) when x=v -> Array.length p1 -1
+    |_ -> 0
+
+
+(* total degree *)
+let rec deg_total p =
+  match p with
+      Prec (x,p1) -> let d = ref 0 in
+        Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1;
+        !d
+    |_ -> 0
+
+let rec copyP p =
+  match p with
+      Pint i -> Pint i
+    |Prec(x,q) -> Prec(x,Array.map copyP q)
+
+(* coefficient of degree i in v, v >= max var of p *)
+let coef v i p =
+  match p with
+      Prec (x,p1) when x=v  -> if i<(Array.length p1) then p1.(i) else Pint coef0
+    |_ -> if i=0 then p else Pint coef0
+
+(* addition *)
+
+let rec plusP p q =
+  let res =
+    (match (p,q) with
+	 (Pint a,Pint b) -> Pint (C.plus a b)
+       |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in
+           q2.(0)<- plusP p q1.(0);
+           Prec (y,q2)
+       |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in
+           p2.(0)<- plusP p1.(0) q;
+           Prec (x,p2)
+       |(Prec (x,p1),Prec (y,q1)) ->
+          if x<y then (let q2=Array.map copyP q1 in
+                         q2.(0)<- plusP p q1.(0);
+                         Prec (y,q2))
+          else if x>y then (let p2=Array.map copyP p1 in
+                              p2.(0)<- plusP p1.(0) q;
+                              Prec (x,p2))
+          else
+            (let n=max (deg x p) (deg x q) in
+             let r=Array.create (n+1) (Pint coef0) in
+               for i=0 to n do
+                 r.(i)<- plusP (coef x i p) (coef x i q);
+               done;
+               Prec(x,r)))
+  in norm res
+
+
+(* content, positive integer *)
+let rec content p =
+  match p with
+      Pint a -> C.abs a
+    | Prec (x ,p1) ->
+       Array.fold_left C.pgcd coef0 (Array.map content p1)
+
+let rec div_int p a=
+  match p with
+      Pint b -> Pint (C.div b a)
+    | Prec(x,p1) -> Prec(x,Array.map (fun x -> div_int x a) p1)
+
+let vire_contenu p =
+  let c = content p in
+    if C.equal c coef0 then p else div_int p c
+
+(* sorted list of variables of a polynomial *)
+
+let rec vars=function
+    Pint _->[]
+  | Prec (x,l)->(List.flatten ([x]::(List.map vars (Array.to_list l))))
+
+
+(* multiply p by v^n, v >= max_var p *)
+let rec multx n v p =
+  match p with
+      Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in
+        for i=0 to (Array.length p1)-1 do
+          p2.(i+n)<-p1.(i);
+        done;
+        Prec (x,p2)
+    |_ -> if p = (Pint coef0) then (Pint coef0)
+       else (let p2=Array.create (n+1) (Pint coef0) in
+               p2.(n)<-p;
+               Prec (v,p2))
+
+
+(* product *)
+let rec multP p q =
+  match (p,q) with
+      (Pint a,Pint b) -> Pint (C.mult a b)
+    |(Pint a, Prec (y,q1)) ->
+       if C.equal a coef0 then Pint coef0
+       else let q2 = Array.map (fun z-> multP p z) q1 in
+         Prec (y,q2)
+
+    |(Prec (x,p1), Pint b) ->
+       if C.equal b coef0 then Pint coef0
+       else let p2 = Array.map (fun z-> multP z q) p1 in
+         Prec (x,p2)
+    |(Prec (x,p1), Prec(y,q1)) ->
+       if x<y
+       then (let q2 = Array.map (fun z-> multP p z) q1 in
+               Prec (y,q2))
+       else if x>y
+       then (let p2 = Array.map (fun z-> multP z q) p1 in
+               Prec (x,p2))
+       else Array.fold_left plusP (Pint coef0)
+         (Array.mapi (fun i z-> (multx i x (multP z q))) p1)
+
+
+
+(* derive p with variable v, v >= max_var p *)
+let rec deriv v p =
+  match p with
+      Pint a -> Pint coef0
+    | Prec(x,p1) when x=v ->
+       let d = Array.length p1 -1 in
+         if d=1 then p1.(1)
+         else
+           (let p2 = Array.create d (Pint coef0) in
+              for i=0 to d-1 do
+		p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1);
+              done;
+              Prec (x,p2))
+    | Prec(x,p1)-> Pint coef0
+
+
+(* opposite *)
+let rec oppP p =
+  match p with
+      Pint a -> Pint (C.opp a)
+    |Prec(x,p1) -> Prec(x,Array.map oppP p1)
+
+let moinsP p q=plusP p (oppP q)
+
+let rec puisP p n = match n with
+    0 -> cf1
+  |_ -> (multP p (puisP p (n-1)))
+
+
+(* infix notations *)
+(*let (++) a b = plusP a b
+*)
+let (@@) a b = multP a b
+
+let (--) a b = moinsP a b
+
+let (^^) a b = puisP a b
+
+
+(* leading coefficient in v,  v>= max_var p *)
+
+let coefDom v p= coef v (deg v p) p
+
+let coefConst v p = coef v 0 p
+
+(* tail of a polynomial *)
+let remP v p =
+  moinsP p (multP (coefDom v p) (puisP (x v) (deg v p)))
+
+
+(* first interger coefficient of p *)
+let rec coef_int_tete p =
+  let v = max_var_pol p in
+    if v>0
+    then coef_int_tete (coefDom v p)
+    else (match p with | Pint a -> a |_ -> assert false)
+
+
+(* divide by the content and make the head int coef positive *)
+let normc p =
+  let p = vire_contenu p in
+  let a = coef_int_tete p in
+    if C.le coef0 a then p else oppP p
+
+
+(* constant coef of normalized polynomial *)
+let rec coef_constant p =
+  match p with
+      Pint a->a
+    |Prec(_,q)->coef_constant q.(0)
+
+
+(***********************************************************************
+  3. Printing polynomials.
+*)
+
+(* if univ = false, we use x,y,z,a,b,c,d... as variables, else x1,x2,...
+*)
+let univ=ref true
+
+let string_of_var x=
+  if !univ then
+    "u"^(string_of_int x)
+  else
+    if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w')))
+    else String.make 1 (Char.chr(x-4+(Char.code 'a')))
+
+let nsP = ref 0
+
+let rec string_of_Pcut p =
+  if (!nsP)<=0
+  then "..."
+  else
+  match p with
+  |Pint a-> nsP:=(!nsP)-1;
+      if C.le coef0 a
+      then C.to_string a
+      else "("^(C.to_string a)^")"
+  |Prec (x,t)->
+      let v=string_of_var x
+      and s=ref ""
+      and sp=ref "" in
+    let st0 = string_of_Pcut t.(0) in
+      if st0<>"0"
+      then s:=st0;
+    let fin = ref false in
+    for i=(Array.length t)-1 downto 1 do
+      if (!nsP)<0
+      then (sp:="...";
+	    if not (!fin) then s:=(!s)^"+"^(!sp);
+	    fin:=true)
+      else (
+	let si=string_of_Pcut  t.(i) in
+	sp:="";
+	if i=1
+	then (
+	  if si<>"0"
+	  then (nsP:=(!nsP)-1;
+		if si="1"
+		then sp:=v
+		else
+		  (if (String.contains si '+')
+		  then sp:="("^si^")*"^v
+		  else sp:=si^"*"^v)))
+	else (
+	  if si<>"0"
+	  then (nsP:=(!nsP)-1;
+		if si="1"
+		then sp:=v^"^"^(string_of_int i)
+		else (if (String.contains si '+')
+		then sp:="("^si^")*"^v^"^"^(string_of_int i)
+		else  sp:=si^"*"^v^"^"^(string_of_int i))));
+	if !sp<>"" && not (!fin)
+	then (nsP:=(!nsP)-1;
+	      if !s=""
+	      then s:=!sp
+	      else s:=(!s)^"+"^(!sp)));
+    done;
+    if !s="" then (nsP:=(!nsP)-1;
+		   (s:="0"));
+    !s
+
+let to_string p =
+  nsP:=20;
+  string_of_Pcut p
+
+let printP p = Format.printf "@[%s@]" (to_string p)
+
+let print_tpoly lp =
+  let s = ref "\n{ " in
+    Array.iter (fun p -> s:=(!s)^(to_string p)^"\n") lp;
+    prt0 ((!s)^"}")
+
+let print_lpoly lp = print_tpoly (Array.of_list lp)
+
+(***********************************************************************
+  4. Exact division of polynomials.
+*)
+
+(* return (s,r) s.t. p = s*q+r *)
+let rec quo_rem_pol p q x =
+  if x=0
+  then (match (p,q) with
+          |(Pint a, Pint b) ->
+	     if C.equal (C.modulo a b) coef0
+             then (Pint (C.div a b), cf0)
+             else failwith "div_pol1"
+	  |_ -> assert false)
+  else
+    let m = deg x q in
+    let b = coefDom x q in
+    let q1 = remP x q in (* q = b*x^m+q1 *)
+    let r = ref p in
+    let s = ref cf0 in
+    let continue =ref true in
+      while (!continue) && (not (equal !r cf0)) do
+	let n = deg x !r in
+	  if n<m
+	  then continue:=false
+	  else (
+            let a = coefDom x !r in
+            let p1 = remP x !r in  (* r = a*x^n+p1 *)
+            let c = div_pol a b (x-1) in  (* a = c*b *)
+	    let s1 = c @@ ((monome x (n-m))) in
+              s:= plusP (!s) s1;
+              r:= p1 -- (s1 @@ q1);
+          )
+      done;
+      (!s,!r)
+
+(* returns quotient p/q if q divides p, else fails *)
+and div_pol p q x =
+  let (s,r) = quo_rem_pol p q x in
+    if equal r cf0
+    then s
+    else  failwith ("div_pol:\n"
+		   ^"p:"^(to_string p)^"\n"
+		   ^"q:"^(to_string q)^"\n"
+		   ^"r:"^(to_string r)^"\n"
+		   ^"x:"^(string_of_int x)^"\n"
+		   )
+let divP p q=
+  let x = max (max_var_pol p) (max_var_pol q) in
+  div_pol p q x
+
+let div_pol_rat p q=
+  let x = max (max_var_pol p) (max_var_pol q) in
+    try (let s = div_pol (multP p (puisP (Pint(coef_int_tete q))
+				     (1+(deg x p) - (deg x q))))
+		   q x in
+         (* degueulasse, mais c 'est pour enlever un warning *)
+         if s==s then true else true)
+    with _ -> false
+
+(***********************************************************************
+  5. Pseudo-division and gcd with subresultants.
+*)
+
+(* pseudo division :
+   q = c*x^m+q1
+   retruns (r,c,d,s) s.t. c^d*p = s*q + r.
+*)
+
+let pseudo_div p q x =
+  match q with
+      Pint _ -> (cf0, q,1, p)
+    | Prec (v,q1) when x<>v -> (cf0, q,1, p)
+    | Prec (v,q1) ->
+	(
+	  (*  pr "pseudo_division: c^d*p = s*q + r";*)
+	  let delta = ref 0 in
+	  let r = ref p in
+	  let c = coefDom x q in
+	  let q1 = remP x q in
+	  let d' = deg x q in
+	  let s = ref cf0 in
+	    while (deg x !r)>=(deg x q) do
+	      let d = deg x !r in
+	      let a = coefDom x !r in
+	      let r1=remP x !r in
+	      let u = a @@ ((monome x (d-d'))) in
+		r:=(c @@ r1) -- (u @@ q1);
+		s:=plusP (c @@ (!s)) u;
+		delta := (!delta) + 1;
+	    done;
+	    (*
+	      pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c)));
+	      pr ("deg r:"^(string_of_int (deg_total !r)));
+	    *)
+	    (!r,c,!delta, !s)
+	)
+
+(* gcd with subresultants *)
+
+let rec pgcdP p q =
+  let x = max (max_var_pol p) (max_var_pol q) in
+    pgcd_pol p q x
+
+and pgcd_pol p q x =
+  pgcd_pol_rec p q x
+
+and content_pol p x =
+  match p with
+      Prec(v,p1) when v=x ->
+        Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1
+    | _ -> p
+
+and pgcd_coef_pol c p x =
+  match p with
+      Prec(v,p1) when x=v ->
+        Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c  p1
+    |_ -> pgcd_pol_rec c p (x-1)
+
+and pgcd_pol_rec p q x =
+ match (p,q) with
+	(Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b))
+      |_ ->
+	  if equal p cf0
+	  then q
+	  else if equal q cf0
+	  then p
+	  else if (deg x q) = 0
+	  then pgcd_coef_pol q p x
+	  else if (deg x p) = 0
+	  then pgcd_coef_pol p q x
+	  else (
+	    let a = content_pol p x in
+	    let b = content_pol q x in
+	    let c = pgcd_pol_rec a b (x-1) in
+	    pr (string_of_int x);
+	    let p1 = div_pol p c x in
+	    let q1 = div_pol q c x in
+	    let r = gcd_sub_res p1 q1 x in
+	    let cr = content_pol r x in
+	    let res = c @@ (div_pol r cr x) in
+	    res
+	   )
+
+(* Sub-résultants:
+
+   ai*Ai = Qi*Ai+1 + bi*Ai+2
+
+   deg Ai+2 < deg Ai+1
+
+   Ai = ci*X^ni + ...
+   di = ni - ni+1
+
+   ai = (- ci+1)^(di + 1)
+   b1 = 1
+   bi = ci*si^di  si i>1
+
+   s1 = 1
+   si+1 = ((ci+1)^di*si)/si^di
+
+*)
+and gcd_sub_res p q x =
+  if equal q cf0
+  then p
+  else
+    let d = deg x p in
+    let d' = deg x q in
+      if d<d'
+      then gcd_sub_res q p x
+      else
+	let delta = d-d' in
+	let c' = coefDom x q in
+	let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
+	  gcd_sub_res_rec q r (c'^^delta) c' d' x
+
+and gcd_sub_res_rec p q s c d x =
+  if equal q cf0
+  then p
+  else (
+    let d' = deg x q in
+    let c' = coefDom x q in
+    let delta = d-d' in
+    let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
+    let s'= lazard_power c' s delta x in
+      gcd_sub_res_rec q (div_pol r (c @@ (s^^delta)) x) s' c' d' x
+  )
+
+and lazard_power c s d x =
+  let res = ref c in
+    for i=1 to d-1 do
+      res:= div_pol ((!res)@@c) s x;
+    done;
+    !res
+
+(* memoizations *)
+
+let rec hash = function
+    Pint a -> (C.hash a)
+  | Prec (v,p) ->
+      Array.fold_right (fun q h -> h + hash q) p 0
+
+module Hashpol = Hashtbl.Make(
+  struct
+    type poly = t
+    type t = poly
+    let equal = equal
+    let hash = hash
+  end)
+
+end
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
new file mode 100644
index 00000000..623d901e
--- /dev/null
+++ b/plugins/nsatz/polynom.mli
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Building recursive polynom operations from a type of coefficients *)
+
+module type Coef = sig
+  type t
+  val equal : t -> t -> bool
+  val lt : t -> t -> bool
+  val le : t -> t -> bool
+  val abs : t -> t
+  val plus : t -> t -> t
+  val mult : t -> t -> t
+  val sub : t -> t -> t
+  val opp : t -> t
+  val div : t -> t -> t
+  val modulo : t -> t -> t
+  val puis : t -> int -> t
+  val pgcd : t -> t -> t
+
+  val hash : t -> int
+  val of_num : Num.num -> t
+  val to_string : t -> string
+end
+
+module type S = sig
+  type coef
+  type variable = int
+  type t = Pint of coef | Prec of variable * t array
+
+  val of_num : Num.num -> t
+  val x : variable -> t
+  val monome : variable -> int -> t
+  val is_constantP : t -> bool
+  val is_zero : t -> bool
+
+  val max_var_pol : t -> variable
+  val max_var_pol2 : t -> variable
+  val max_var : t array -> variable
+  val equal : t -> t -> bool
+  val norm : t -> t
+  val deg : variable -> t -> int
+  val deg_total : t -> int
+  val copyP : t -> t
+  val coef : variable -> int -> t -> t
+
+  val plusP : t -> t -> t
+  val content : t -> coef
+  val div_int : t -> coef -> t
+  val vire_contenu : t -> t
+  val vars : t -> variable list
+  val int_of_Pint : t -> coef
+  val multx : int -> variable -> t -> t
+  val multP : t -> t -> t
+  val deriv : variable -> t -> t
+  val oppP : t -> t
+  val moinsP : t -> t -> t
+  val puisP : t -> int -> t
+  val ( @@ ) : t -> t -> t
+  val ( -- ) : t -> t -> t
+  val ( ^^ ) : t -> int -> t
+  val coefDom : variable -> t -> t
+  val coefConst : variable -> t -> t
+  val remP : variable -> t -> t
+  val coef_int_tete : t -> coef
+  val normc : t -> t
+  val coef_constant : t -> coef
+  val univ : bool ref
+  val string_of_var : int -> string
+  val nsP : int ref
+  val to_string : t -> string
+  val printP : t -> unit
+  val print_tpoly : t array -> unit
+  val print_lpoly : t list -> unit
+  val quo_rem_pol : t -> t -> variable -> t * t
+  val div_pol : t -> t -> variable -> t
+  val divP : t -> t -> t
+  val div_pol_rat : t -> t -> bool
+  val pseudo_div : t -> t -> variable -> t * t * int * t
+  val pgcdP : t -> t -> t
+  val pgcd_pol : t -> t -> variable -> t
+  val content_pol : t -> variable -> t
+  val pgcd_coef_pol : t -> t -> variable -> t
+  val pgcd_pol_rec : t -> t -> variable -> t
+  val gcd_sub_res : t -> t -> variable -> t
+  val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t
+  val lazard_power : t -> t -> int -> variable -> t
+  val hash : t -> int
+  module Hashpol : Hashtbl.S with type key=t
+end
+
+module Make (C:Coef) : S with type coef = C.t
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
new file mode 100644
index 00000000..c16bd425
--- /dev/null
+++ b/plugins/nsatz/utile.ml
@@ -0,0 +1,130 @@
+(* Printing *)
+
+let pr x =
+  if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else ()
+
+let prn x =
+  if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else ()
+
+let prt0 s = () (* print_string s;flush(stdout)*)
+
+let prt s =
+  if !Flags.debug then (print_string (s^"\n");flush(stdout)) else ()
+
+let info s =
+  Flags.if_verbose prerr_string s
+
+(* Lists *)
+
+let rec list_mem_eq eq x l =
+  match l with
+    [] -> false
+   |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1)
+
+let set_of_list_eq eq l =
+   let res = ref [] in
+   List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l;
+   List.rev !res
+
+
+(* Memoization
+   f is compatible with nf: f(nf(x)) = f(x)
+*)
+
+let memos s memoire nf f x =
+   try (let v = Hashtbl.find memoire (nf x) in pr s;v)
+   with _ -> (pr "#";
+	      let v = f x in
+	      Hashtbl.add memoire (nf x) v;
+	      v)
+
+
+(**********************************************************************
+  Eléments minimaux pour un ordre partiel de division.
+  E est un ensemble, avec une multiplication
+  et une division partielle div (la fonction div peut échouer),
+  constant est un prédicat qui définit un sous-ensemble C de E.
+*)
+(*
+  Etant donnée une partie A de E, on calcule une partie B de E disjointe de C
+  telle que:
+    - les éléments de A sont des produits d'éléments de B et d'un de C.
+    - B est minimale pour cette propriété.
+*)
+
+let facteurs_liste div constant lp =
+   let lp = List.filter (fun x -> not (constant x)) lp in
+   let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *)
+      match lp with
+        [] -> lmin
+       |p::lp1 ->
+         (let l1 = ref [] in
+          let p_dans_lmin = ref false in
+          List.iter (fun q -> try (let r = div p q in
+                                   if not (constant r)
+				   then l1:=r::(!l1)
+                                   else p_dans_lmin:=true)
+			      with _ -> ())
+                     lmin;
+          if !p_dans_lmin
+          then factor lmin lp1
+          else if (!l1)=[]
+          (* aucun q de lmin ne divise p *)
+          then (let l1=ref lp1 in
+		let lmin1=ref [] in
+                List.iter (fun q -> try (let r = div q p in
+					 if not (constant r)
+					 then l1:=r::(!l1))
+				    with _ -> lmin1:=q::(!lmin1))
+                          lmin;
+	        factor (List.rev (p::(!lmin1))) !l1)
+          (* au moins un q de lmin divise p non trivialement *)
+          else factor lmin ((!l1)@lp1))
+    in
+    factor [] lp
+
+
+(* On suppose que tout élément de A est produit d'éléments de B et d'un de C:
+   A et B sont deux tableaux,  rend un tableau de couples
+      (élément de C, listes d'indices l)
+   tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2)
+   zero est un prédicat sur E tel que (zero x) => (constant x):
+         si (zero x) est vrai on ne decompose pas x
+   c est un élément quelconque de E.
+*)
+let factorise_tableau div zero c f l1 =
+    let res = Array.create (Array.length f) (c,[]) in
+    Array.iteri (fun i p ->
+      let r = ref p in
+      let li = ref [] in
+      if not (zero p)
+      then
+      Array.iteri (fun j q ->
+	              try (while true do
+                               let rr = div !r q in
+      	                       li:=j::(!li);
+                               r:=rr;
+			   done)
+                      with _ -> ())
+                  l1;
+      res.(i)<-(!r,!li))
+     f;
+    (l1,res)
+
+
+(* exemples:
+
+let l =  [1;2;6;24;720]
+and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div")
+and constant = (fun x -> x<2)
+and zero = (fun x -> x=0)
+
+
+let f = facteurs_liste div1 constant l
+
+
+factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f)
+
+*)
+
+
diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli
new file mode 100644
index 00000000..83b2ac39
--- /dev/null
+++ b/plugins/nsatz/utile.mli
@@ -0,0 +1,22 @@
+
+(* Printing *)
+val pr : string -> unit
+val prn : string -> unit
+val prt0 : 'a -> unit
+val prt : string -> unit
+val info : string -> unit
+
+(* Listes *)
+val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
+val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(* Memoization *)
+val memos :
+  string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b
+
+
+val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list
+val factorise_tableau :
+  ('a -> 'b -> 'a) ->
+  ('a -> bool) ->
+  'a -> 'a array -> 'b array -> 'b array * ('a * int list) array
diff --git a/plugins/nsatz/vo.itarget b/plugins/nsatz/vo.itarget
new file mode 100644
index 00000000..4af4786d
--- /dev/null
+++ b/plugins/nsatz/vo.itarget
@@ -0,0 +1,3 @@
+NsatzR.vo
+Nsatz_domain.vo
+NsatzZ.vo
diff --git a/contrib/omega/Omega.v b/plugins/omega/Omega.v
index ee823502..30b94571 100644
--- a/contrib/omega/Omega.v
+++ b/plugins/omega/Omega.v
@@ -13,12 +13,13 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: Omega.v 10028 2007-07-18 22:38:06Z letouzey $ *)
+(* $Id$ *)
 
 (* We do not require [ZArith] anymore, but only what's necessary for Omega *)
 Require Export ZArith_base.
 Require Export OmegaLemmas.
 Require Export PreOmega.
+Declare ML Module "omega_plugin".
 
 Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
   Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
diff --git a/contrib/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
index 5c240553..56a854d6 100644
--- a/contrib/omega/OmegaLemmas.v
+++ b/plugins/omega/OmegaLemmas.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: OmegaLemmas.v 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith_base.
 Open Local Scope Z_scope.
@@ -31,7 +31,7 @@ Qed.
 Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
 Proof.
   intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; 
+    rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm;
       trivial with arith.
 Qed.
 
@@ -53,7 +53,7 @@ Qed.
 (** Other specific variants of theorems dedicated for the Omega tactic *)
 
 Lemma new_var : forall x : Z, exists y : Z, x = y.
-intros x; exists x; trivial with arith. 
+intros x; exists x; trivial with arith.
 Qed.
 
 Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y.
@@ -62,7 +62,7 @@ Qed.
 
 Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y.
 exact Zplus_le_0_compat.
-Qed. 
+Qed.
 
 Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0.
 
@@ -82,11 +82,11 @@ unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0);
        [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
        | apply Zle_gt_trans with x;
           [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
-             apply Zplus_le_compat_r; rewrite Zmult_comm; 
+             apply Zplus_le_compat_r; rewrite Zmult_comm;
              generalize H4; unfold Zgt in |- *; case y;
              [ simpl in |- *; intros H7; discriminate H7
              | intros p H7; rewrite <- (Zmult_0_r (Zpos p));
-                unfold Zle in |- *; rewrite Zcompare_mult_compat; 
+                unfold Zle in |- *; rewrite Zcompare_mult_compat;
                 exact H6
              | simpl in |- *; intros p H7; discriminate H7 ]
           | assumption ] ]
@@ -116,7 +116,7 @@ Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0.
 intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1);
  [ intros H4; absurd (0 < x);
     [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
-       rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; 
+       rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r;
        assumption
     | assumption ]
  | intros H4; rewrite H4; trivial with arith ].
@@ -143,7 +143,7 @@ Lemma OMEGA11 :
  (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
  trivial with arith.
 Qed.
 
@@ -152,7 +152,7 @@ Lemma OMEGA12 :
  l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
  rewrite Zplus_permute; trivial with arith.
 Qed.
 
@@ -166,7 +166,7 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
  rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r;
  trivial with arith.
 Qed.
- 
+
 Lemma OMEGA14 :
  forall (v l1 l2 : Z) (x : positive),
  v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.
@@ -188,14 +188,14 @@ Qed.
 Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k.
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
  trivial with arith.
 Qed.
 
 Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
 
 unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
- apply Zplus_reg_l with (y * z); rewrite Zplus_comm; 
+ apply Zplus_reg_l with (y * z); rewrite Zplus_comm;
  rewrite H3; rewrite H2; auto with arith.
 Qed.
 
@@ -213,7 +213,7 @@ unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x);
        rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
     | intros H2; absurd (x = 0); auto with arith ]
  | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm;
-    apply Zle_left; apply Zsucc_le_reg; simpl in |- *; 
+    apply Zle_left; apply Zsucc_le_reg; simpl in |- *;
     apply Zlt_le_succ; auto with arith ].
 Qed.
 
@@ -229,7 +229,7 @@ Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
 Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
   (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).
 
-Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) 
+Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop)
   (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p).
 
 Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
@@ -257,7 +257,7 @@ Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
 
 Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
   (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x).
-Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) 
+Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop)
   (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).
 
 Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
@@ -272,18 +272,18 @@ Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
 Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
   eq_ind_r P H (Zopp_involutive x).
 
-Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) 
+Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop)
   (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).
 
 Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
   (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p).
-Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) 
+Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop)
   (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y).
 
 Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
   (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).
 
-Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) 
+Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop)
   (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x).
 
 Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop)
@@ -295,8 +295,8 @@ Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop)
 Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop)
   (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z).
 
-Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) 
+Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop)
   (H : P y) := eq_ind_r P H (Zred_factor5 x y).
 
-Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) 
+Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop)
   (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).
diff --git a/states/MakeInitialNew.v b/plugins/omega/OmegaPlugin.v
index 64c540fa..21535f0d 100644
--- a/states/MakeInitialNew.v
+++ b/plugins/omega/OmegaPlugin.v
@@ -5,5 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-Require Export Prelude.
-Require Export Logic_Type.
+
+(* $Id$ *)
+
+Declare ML Module "omega_plugin".
diff --git a/contrib/omega/PreOmega.v b/plugins/omega/PreOmega.v
index 47e22a97..a5a085a9 100644
--- a/contrib/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -5,16 +5,16 @@ Open Local Scope Z_scope.
 
 (** * zify: the Z-ification tactic *)
 
-(* This tactic searches for nat and N and positive elements in the goal and 
-   translates everything into Z. It is meant as a pre-processor for 
+(* This tactic searches for nat and N and positive elements in the goal and
+   translates everything into Z. It is meant as a pre-processor for
    (r)omega; for instance a positivity hypothesis is added whenever
      - a multiplication is encountered
      - an atom is encountered (that is a variable or an unknown construct)
 
    Recognized relations (can be handled as deeply as allowed by setoid rewrite):
      - { eq, le, lt, ge, gt } on { Z, positive, N, nat }
-   
-   Recognized operations: 
+
+   Recognized operations:
      - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
      - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
      - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
@@ -26,31 +26,31 @@ Open Local Scope Z_scope.
 
 (** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)
 
-Ltac zify_unop_core t thm a := 
+Ltac zify_unop_core t thm a :=
  (* Let's introduce the specification theorem for t *)
- let H:= fresh "H" in assert (H:=thm a); 
+ let H:= fresh "H" in assert (H:=thm a);
  (* Then we replace (t a) everywhere with a fresh variable *)
  let z := fresh "z" in set (z:=t a) in *; clearbody z.
 
-Ltac zify_unop_var_or_term t thm a := 
+Ltac zify_unop_var_or_term t thm a :=
  (* If a is a variable, no need for aliasing *)
- let za := fresh "z" in 
+ let za := fresh "z" in
  (rename a into za; rename za into a; zify_unop_core t thm a) ||
  (* Otherwise, a is a complex term: we alias it. *)
  (remember a as za; zify_unop_core t thm za).
 
-Ltac zify_unop t thm a := 
+Ltac zify_unop t thm a :=
  (* if a is a scalar, we can simply reduce the unop *)
- let isz := isZcst a in 
- match isz with 
+ let isz := isZcst a in
+ match isz with
   | true => simpl (t a) in *
   | _ => zify_unop_var_or_term t thm a
  end.
 
-Ltac zify_unop_nored t thm a := 
+Ltac zify_unop_nored t thm a :=
  (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
- let isz := isZcst a in 
- match isz with 
+ let isz := isZcst a in
+ match isz with
   | true => zify_unop_core t thm a
   | _ => zify_unop_var_or_term t thm a
  end.
@@ -58,20 +58,20 @@ Ltac zify_unop_nored t thm a :=
 Ltac zify_binop t thm a b:=
  (* works as zify_unop, except that we should be careful when
     dealing with b, since it can be equal to a *)
- let isza := isZcst a in 
- match isza with 
+ let isza := isZcst a in
+ match isza with
    | true => zify_unop (t a) (thm a) b
-   | _ => 
-       let za := fresh "z" in 
+   | _ =>
+       let za := fresh "z" in
        (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
-       (remember a as za; match goal with 
+       (remember a as za; match goal with
          | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
          | _ => zify_unop_nored (t za) (thm za) b
         end)
  end.
 
-Ltac zify_op_1 := 
-  match goal with 
+Ltac zify_op_1 :=
+  match goal with
    | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
    | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
    | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
@@ -93,13 +93,13 @@ Ltac zify_op := repeat zify_op_1.
 
 Definition Z_of_nat' := Z_of_nat.
 
-Ltac hide_Z_of_nat t := 
-  let z := fresh "z" in set (z:=Z_of_nat t) in *; 
-  change Z_of_nat with Z_of_nat' in z; 
+Ltac hide_Z_of_nat t :=
+  let z := fresh "z" in set (z:=Z_of_nat t) in *;
+  change Z_of_nat with Z_of_nat' in z;
   unfold z in *; clear z.
 
-Ltac zify_nat_rel := 
- match goal with 
+Ltac zify_nat_rel :=
+ match goal with
   (* I: equalities *)
   | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
   | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
@@ -127,8 +127,8 @@ Ltac zify_nat_rel :=
   | |- context [ ge ?a ?b ] =>       rewrite (inj_ge_iff a b)
  end.
 
-Ltac zify_nat_op := 
- match goal with 
+Ltac zify_nat_op :=
+ match goal with
   (* misc type conversions: positive/N/Z to nat *)
   | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
   | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
@@ -158,11 +158,11 @@ Ltac zify_nat_op :=
   | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)
 
   (* mult -> Zmult and a positivity hypothesis *)
-  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => 
-        let H:= fresh "H" in 
+  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
+        let H:= fresh "H" in
         assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
-  | |- context [ Z_of_nat (mult ?a ?b) ] => 
-        let H:= fresh "H" in 
+  | |- context [ Z_of_nat (mult ?a ?b) ] =>
+        let H:= fresh "H" in
         assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
 
   (* O -> Z0 *)
@@ -170,29 +170,29 @@ Ltac zify_nat_op :=
   | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)
 
   (* S -> number or Zsucc *)
-  | H : context [ Z_of_nat (S ?a) ] |- _ => 
-     let isnat := isnatcst a in 
-     match isnat with 
+  | H : context [ Z_of_nat (S ?a) ] |- _ =>
+     let isnat := isnatcst a in
+     match isnat with
       | true => simpl (Z_of_nat (S a)) in H
       | _ => rewrite (inj_S a) in H
      end
-  | |- context [ Z_of_nat (S ?a) ] => 
-     let isnat := isnatcst a in 
-     match isnat with 
+  | |- context [ Z_of_nat (S ?a) ] =>
+     let isnat := isnatcst a in
+     match isnat with
       | true => simpl (Z_of_nat (S a))
       | _ => rewrite (inj_S a)
      end
 
-  (* atoms of type nat : we add a positivity condition (if not already there) *) 
-  | H : context [ Z_of_nat ?a ] |- _ => 
-        match goal with 
+  (* atoms of type nat : we add a positivity condition (if not already there) *)
+  | H : context [ Z_of_nat ?a ] |- _ =>
+        match goal with
           | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
           | H' : 0 <= Z_of_nat' a |- _ => fail
           | _ => let H:= fresh "H" in
                  assert (H:=Zle_0_nat a); hide_Z_of_nat a
         end
-  | |- context [ Z_of_nat ?a ] => 
-        match goal with 
+  | |- context [ Z_of_nat ?a ] =>
+        match goal with
           | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
           | H' : 0 <= Z_of_nat' a |- _ => fail
           | _ => let H:= fresh "H" in
@@ -205,18 +205,18 @@ Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.
 
 
 
-(* III) conversion from positive to Z *) 
+(* III) conversion from positive to Z *)
 
 Definition Zpos' := Zpos.
 Definition Zneg' := Zneg.
 
-Ltac hide_Zpos t := 
-  let z := fresh "z" in set (z:=Zpos t) in *; 
-  change Zpos with Zpos' in z; 
+Ltac hide_Zpos t :=
+  let z := fresh "z" in set (z:=Zpos t) in *;
+  change Zpos with Zpos' in z;
   unfold z in *; clear z.
 
-Ltac zify_positive_rel := 
- match goal with 
+Ltac zify_positive_rel :=
+ match goal with
   (* I: equalities *)
   | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
   | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
@@ -236,18 +236,18 @@ Ltac zify_positive_rel :=
   | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
  end.
 
-Ltac zify_positive_op := 
- match goal with 
+Ltac zify_positive_op :=
+ match goal with
   (* Zneg -> -Zpos (except for numbers) *)
-  | H : context [ Zneg ?a ] |- _ => 
-     let isp := isPcst a in 
-     match isp with 
+  | H : context [ Zneg ?a ] |- _ =>
+     let isp := isPcst a in
+     match isp with
       | true => change (Zneg a) with (Zneg' a) in H
       | _ => change (Zneg a) with (- Zpos a) in H
      end
-  | |- context [ Zneg ?a ] => 
-     let isp := isPcst a in 
-     match isp with 
+  | |- context [ Zneg ?a ] =>
+     let isp := isPcst a in
+     match isp with
       | true => change (Zneg a) with (Zneg' a)
       | _ => change (Zneg a) with (- Zpos a)
      end
@@ -272,45 +272,45 @@ Ltac zify_positive_op :=
   | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
   | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)
 
-  (* Psucc -> Zsucc *) 
+  (* Psucc -> Zsucc *)
   | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
   | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)
 
   (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
   | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
   | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)
- 
+
   (* Pmult -> Zmult and a positivity hypothesis *)
-  | H : context [ Zpos (Pmult ?a ?b) ] |- _ => 
-        let H:= fresh "H" in 
+  | H : context [ Zpos (Pmult ?a ?b) ] |- _ =>
+        let H:= fresh "H" in
         assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
-  | |- context [ Zpos (Pmult ?a ?b) ] => 
-        let H:= fresh "H" in 
+  | |- context [ Zpos (Pmult ?a ?b) ] =>
+        let H:= fresh "H" in
         assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
 
   (* xO *)
-  | H : context [ Zpos (xO ?a) ] |- _ => 
-     let isp := isPcst a in 
-     match isp with 
+  | H : context [ Zpos (xO ?a) ] |- _ =>
+     let isp := isPcst a in
+     match isp with
       | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
       | _ => rewrite (Zpos_xO a) in H
      end
-  | |- context [ Zpos (xO ?a) ] => 
-     let isp := isPcst a in 
-     match isp with 
+  | |- context [ Zpos (xO ?a) ] =>
+     let isp := isPcst a in
+     match isp with
       | true => change (Zpos (xO a)) with (Zpos' (xO a))
       | _ => rewrite (Zpos_xO a)
      end
-  (* xI *) 
-  | H : context [ Zpos (xI ?a) ] |- _ => 
-     let isp := isPcst a in 
-     match isp with 
+  (* xI *)
+  | H : context [ Zpos (xI ?a) ] |- _ =>
+     let isp := isPcst a in
+     match isp with
       | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
       | _ => rewrite (Zpos_xI a) in H
      end
-  | |- context [ Zpos (xI ?a) ] => 
-     let isp := isPcst a in 
-     match isp with 
+  | |- context [ Zpos (xI ?a) ] =>
+     let isp := isPcst a in
+     match isp with
       | true => change (Zpos (xI a)) with (Zpos' (xI a))
       | _ => rewrite (Zpos_xI a)
      end
@@ -320,38 +320,38 @@ Ltac zify_positive_op :=
   | |- context [ Zpos xH ] => hide_Zpos xH
 
   (* atoms of type positive : we add a positivity condition (if not already there) *)
-  | H : context [ Zpos ?a ] |- _ => 
-        match goal with 
+  | H : context [ Zpos ?a ] |- _ =>
+        match goal with
          | H' : Zpos a > 0 |- _ => hide_Zpos a
          | H' : Zpos' a > 0 |- _ => fail
          | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
         end
-  | |- context [ Zpos ?a ] => 
-        match goal with 
+  | |- context [ Zpos ?a ] =>
+        match goal with
          | H' : Zpos a > 0 |- _ => hide_Zpos a
          | H' : Zpos' a > 0 |- _ => fail
          | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
         end
  end.
 
-Ltac zify_positive := 
+Ltac zify_positive :=
  repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.
 
 
 
 
 
-(* IV) conversion from N to Z *) 
+(* IV) conversion from N to Z *)
 
 Definition Z_of_N' := Z_of_N.
 
-Ltac hide_Z_of_N t := 
-  let z := fresh "z" in set (z:=Z_of_N t) in *; 
-  change Z_of_N with Z_of_N' in z; 
+Ltac hide_Z_of_N t :=
+  let z := fresh "z" in set (z:=Z_of_N t) in *;
+  change Z_of_N with Z_of_N' in z;
   unfold z in *; clear z.
 
-Ltac zify_N_rel := 
- match goal with 
+Ltac zify_N_rel :=
+ match goal with
   (* I: equalities *)
   | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
   | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
@@ -378,9 +378,9 @@ Ltac zify_N_rel :=
   | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H
   | |- context [ (?a>=?b)%N ] =>       rewrite (Z_of_N_ge_iff a b)
  end.
- 
-Ltac zify_N_op := 
- match goal with 
+
+Ltac zify_N_op :=
+ match goal with
   (* misc type conversions: nat to positive *)
   | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
   | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
@@ -407,27 +407,27 @@ Ltac zify_N_op :=
   | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
   | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)
 
-  (* Nsucc -> Zsucc *) 
+  (* Nsucc -> Zsucc *)
   | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
   | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)
- 
+
   (* Nmult -> Zmult and a positivity hypothesis *)
-  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => 
-        let H:= fresh "H" in 
+  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ =>
+        let H:= fresh "H" in
         assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
-  | |- context [ Z_of_N  (Nmult ?a ?b) ] => 
-        let H:= fresh "H" in 
+  | |- context [ Z_of_N  (Nmult ?a ?b) ] =>
+        let H:= fresh "H" in
         assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
 
-  (* atoms of type N : we add a positivity condition (if not already there) *) 
-  | H : context [ Z_of_N ?a ] |- _ => 
-        match goal with 
+  (* atoms of type N : we add a positivity condition (if not already there) *)
+  | H : context [ Z_of_N ?a ] |- _ =>
+        match goal with
          | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
          | H' : 0 <= Z_of_N' a |- _ => fail
          | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
         end
-  | |- context [ Z_of_N ?a ] => 
-        match goal with 
+  | |- context [ Z_of_N ?a ] =>
+        match goal with
          | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
          | H' : 0 <= Z_of_N' a |- _ => fail
          | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
@@ -440,6 +440,6 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
 
 (** The complete Z-ification tactic *)
 
-Ltac zify := 
+Ltac zify :=
  repeat progress (zify_nat; zify_positive; zify_N); zify_op.
 
diff --git a/contrib/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 58873c2d..60616845 100644
--- a/contrib/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: coq_omega.ml 11735 2009-01-02 17:22:31Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -58,26 +58,26 @@ let write f x = f:=x
 open Goptions
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = false;
       optname  = "Omega system time displaying flag";
-      optkey   = SecondaryTable ("Omega","System");
+      optkey   = ["Omega";"System"];
       optread  = read display_system_flag;
       optwrite = write display_system_flag }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = false;
       optname  = "Omega action display flag";
-      optkey   = SecondaryTable ("Omega","Action");
+      optkey   = ["Omega";"Action"];
       optread  = read display_action_flag;
       optwrite = write display_action_flag }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = false;
       optname  = "Omega old style flag";
-      optkey   = SecondaryTable ("Omega","OldStyle");
+      optkey   = ["Omega";"OldStyle"];
       optread  = read old_style_flag;
       optwrite = write old_style_flag }
 
@@ -89,16 +89,16 @@ let elim_time       = timing "Elim      "
 let simpl_time      = timing "Simpl     "
 let generalize_time = timing "Generalize"
 
-let new_identifier = 
-  let cpt = ref 0 in 
+let new_identifier =
+  let cpt = ref 0 in
   (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s)
 
-let new_identifier_state = 
-  let cpt = ref 0 in 
+let new_identifier_state =
+  let cpt = ref 0 in
   (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s)
 
-let new_identifier_var = 
-  let cpt = ref 0 in 
+let new_identifier_var =
+  let cpt = ref 0 in
   (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s)
 
 let new_id =
@@ -115,17 +115,17 @@ let display_var i = Printf.sprintf "X%d" i
 let intern_id,unintern_id =
   let cpt = ref 0 in
   let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in
-  (fun (name : identifier) -> 
-     try Hashtbl.find table name with Not_found -> 
+  (fun (name : identifier) ->
+     try Hashtbl.find table name with Not_found ->
        let idx = !cpt in
-       Hashtbl.add table name idx; 
+       Hashtbl.add table name idx;
        Hashtbl.add co_table idx name;
        incr cpt; idx),
-  (fun idx -> 
-     try Hashtbl.find co_table idx with Not_found -> 
+  (fun idx ->
+     try Hashtbl.find co_table idx with Not_found ->
        let v = new_var () in
        Hashtbl.add table v idx; Hashtbl.add co_table idx v; v)
-    
+
 let mk_then = tclTHENLIST
 
 let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c])
@@ -134,10 +134,10 @@ let generalize_tac t = generalize_time (generalize t)
 let elim t = elim_time (simplest_elim t)
 let exact t = exact_time (Tactics.refine t)
 let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s]
- 
+
 let rev_assoc k =
   let rec loop = function
-    | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l 
+    | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l
   in
   loop
 
@@ -162,12 +162,11 @@ let hide_constr,find_constr,clear_tables,dump_tables =
 open Coqlib
 
 let logic_dir = ["Coq";"Logic";"Decidable"]
-let init_arith_modules = init_modules @ arith_modules
 let coq_modules =
-  init_arith_modules @ [logic_dir] @ zarith_base_modules
+  init_modules @arith_modules @ [logic_dir] @ zarith_base_modules
     @ [["Coq"; "omega"; "OmegaLemmas"]]
 
-let init_arith_constant = gen_constant_in_modules "Omega" init_arith_modules
+let init_constant = gen_constant_in_modules "Omega" init_modules
 let constant = gen_constant_in_modules "Omega" coq_modules
 
 (* Zarith *)
@@ -268,17 +267,17 @@ let coq_Zge = lazy (constant "Zge")
 let coq_Zlt = lazy (constant "Zlt")
 
 (* Peano/Datatypes *)
-let coq_le = lazy (init_arith_constant "le")
-let coq_lt = lazy (init_arith_constant "lt")
-let coq_ge = lazy (init_arith_constant "ge")
-let coq_gt = lazy (init_arith_constant "gt")
-let coq_minus = lazy (init_arith_constant "minus")
-let coq_plus = lazy (init_arith_constant "plus")
-let coq_mult = lazy (init_arith_constant "mult")
-let coq_pred = lazy (init_arith_constant "pred")
-let coq_nat = lazy (init_arith_constant "nat")
-let coq_S = lazy (init_arith_constant "S")
-let coq_O = lazy (init_arith_constant "O")
+let coq_le = lazy (init_constant "le")
+let coq_lt = lazy (init_constant "lt")
+let coq_ge = lazy (init_constant "ge")
+let coq_gt = lazy (init_constant "gt")
+let coq_minus = lazy (init_constant "minus")
+let coq_plus = lazy (init_constant "plus")
+let coq_mult = lazy (init_constant "mult")
+let coq_pred = lazy (init_constant "pred")
+let coq_nat = lazy (init_constant "nat")
+let coq_S = lazy (init_constant "S")
+let coq_O = lazy (init_constant "O")
 
 (* Compare_dec/Peano_dec/Minus *)
 let coq_pred_of_minus = lazy (constant "pred_of_minus")
@@ -347,15 +346,15 @@ let mk_eq_rel t1 t2 = mkApp (build_coq_eq (),
 let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |])
 
 let mk_integer n =
-  let rec loop n = 
-    if n =? one then Lazy.force coq_xH else 
+  let rec loop n =
+    if n =? one then Lazy.force coq_xH else
     mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI),
 		[| loop (n/two) |])
   in
-  if n =? zero then Lazy.force coq_Z0 
+  if n =? zero then Lazy.force coq_Z0
   else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg),
 		 [| loop (abs n) |])
-    
+
 type omega_constant =
   | Zplus | Zmult | Zminus | Zsucc | Zopp
   | Plus | Mult | Minus | Pred | S | O
@@ -371,7 +370,7 @@ type omega_proposition =
   | Keq of constr * constr * constr
   | Kn
 
-type result = 
+type result =
   | Kvar of identifier
   | Kapp of omega_constant * constr list
   | Kimp of constr * constr
@@ -398,11 +397,11 @@ let destructurate_prop t =
     | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args)
     | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args)
     | Const sp, args ->
-	Kapp (Other (string_of_id (id_of_global (ConstRef sp))),args)
+	Kapp (Other (string_of_id (basename_of_global (ConstRef sp))),args)
     | Construct csp , args ->
-	Kapp (Other (string_of_id (id_of_global (ConstructRef csp))), args)
+	Kapp (Other (string_of_id (basename_of_global (ConstructRef csp))), args)
     | Ind isp, args ->
-	Kapp (Other (string_of_id (id_of_global (IndRef isp))),args)
+	Kapp (Other (string_of_id (basename_of_global (IndRef isp))),args)
     | Var id,[] -> Kvar id
     | Prod (Anonymous,typ,body), [] -> Kimp(typ,body)
     | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal"
@@ -442,18 +441,18 @@ let recognize_number t =
       | f, [t] when f = Lazy.force coq_xI -> one + two * loop t
       | f, [t] when f = Lazy.force coq_xO -> two * loop t
       | f, [] when f = Lazy.force coq_xH -> one
-      | _ -> failwith "not a number" 
+      | _ -> failwith "not a number"
   in
-  match decompose_app t with 
+  match decompose_app t with
     | f, [t] when f = Lazy.force coq_Zpos -> loop t
     | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t)
     | f, [] when f = Lazy.force coq_Z0 -> zero
     | _ -> failwith "not a number"
-	  
+
 type constr_path =
   | P_APP of int
   (* Abstraction and product *)
-  | P_BODY 
+  | P_BODY
   | P_TYPE
   (* Case *)
   | P_BRANCH of int
@@ -461,8 +460,8 @@ type constr_path =
   | P_ARG
 
 let context operation path (t : constr) =
-  let rec loop i p0 t = 
-    match (p0,kind_of_term t) with 
+  let rec loop i p0 t =
+    match (p0,kind_of_term t) with
       | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t)
       | ([], _) -> operation i t
       | ((P_APP n :: p),  App (f,v)) ->
@@ -493,9 +492,9 @@ let context operation path (t : constr) =
 	  (mkLambda (n,loop i p t,c))
       | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
 	  (mkLetIn (n,b,loop i p t,c))
-      | (p, _) -> 
+      | (p, _) ->
 	  ppnl (Printer.pr_lconstr t);
-	  failwith ("abstract_path " ^ string_of_int(List.length p)) 
+	  failwith ("abstract_path " ^ string_of_int(List.length p))
   in
   loop 1 path t
 
@@ -514,9 +513,9 @@ let occurence path (t : constr) =
     | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term
     | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term
     | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term
-    | (p, _) -> 
+    | (p, _) ->
 	ppnl (Printer.pr_lconstr t);
-	failwith ("occurence " ^ string_of_int(List.length p)) 
+	failwith ("occurence " ^ string_of_int(List.length p))
   in
   loop path t
 
@@ -539,13 +538,13 @@ type oformula =
   | Oz of bigint
   | Oufo of constr
 
-let rec oprint = function 
-  | Oplus(t1,t2) -> 
-      print_string "("; oprint t1; print_string "+"; 
+let rec oprint = function
+  | Oplus(t1,t2) ->
+      print_string "("; oprint t1; print_string "+";
       oprint t2; print_string ")"
   | Oinv t -> print_string "~"; oprint t
-  | Otimes (t1,t2) -> 
-      print_string "("; oprint t1; print_string "*"; 
+  | Otimes (t1,t2) ->
+      print_string "("; oprint t1; print_string "*";
       oprint t2; print_string ")"
   | Oatom s -> print_string (string_of_id s)
   | Oz i -> print_string (string_of_bigint i)
@@ -567,92 +566,92 @@ let rec val_of = function
   | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |])
   | Oufo c -> c
 
-let compile name kind = 
+let compile name kind =
   let rec loop accu = function
     | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r
     | Oz n ->
 	let id = new_id () in
 	tag_hypothesis name id;
 	{kind = kind; body = List.rev accu; constant = n; id = id}
-    | _ -> anomaly "compile_equation" 
+    | _ -> anomaly "compile_equation"
   in
   loop []
 
-let rec decompile af = 
+let rec decompile af =
   let rec loop = function
-    | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) 
-    | [] -> Oz af.constant 
+    | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r)
+    | [] -> Oz af.constant
   in
   loop af.body
 
 let mkNewMeta () = mkMeta (Evarutil.new_meta())
 
-let clever_rewrite_base_poly typ p result theorem gl = 
+let clever_rewrite_base_poly typ p result theorem gl =
   let full = pf_concl gl in
   let (abstracted,occ) = abstract_path typ (List.rev p) full in
-  let t = 
+  let t =
     applist
       (mkLambda
-	 (Name (id_of_string "P"), 
+	 (Name (id_of_string "P"),
 	  mkArrow typ mkProp,
           mkLambda
 	    (Name (id_of_string "H"),
 	     applist (mkRel 1,[result]),
-	     mkApp (Lazy.force coq_eq_ind_r, 
+	     mkApp (Lazy.force coq_eq_ind_r,
 		       [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))),
-       [abstracted]) 
+       [abstracted])
   in
   exact (applist(t,[mkNewMeta()])) gl
 
-let clever_rewrite_base p result theorem gl = 
+let clever_rewrite_base p result theorem gl =
   clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl
 
-let clever_rewrite_base_nat p result theorem gl = 
+let clever_rewrite_base_nat p result theorem gl =
   clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl
 
-let clever_rewrite_gen p result (t,args) = 
-  let theorem = applist(t, args) in 
+let clever_rewrite_gen p result (t,args) =
+  let theorem = applist(t, args) in
   clever_rewrite_base p result theorem
 
-let clever_rewrite_gen_nat p result (t,args) = 
-  let theorem = applist(t, args) in 
+let clever_rewrite_gen_nat p result (t,args) =
+  let theorem = applist(t, args) in
   clever_rewrite_base_nat p result theorem
 
-let clever_rewrite p vpath t gl = 
+let clever_rewrite p vpath t gl =
   let full = pf_concl gl in
   let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in
   let vargs = List.map (fun p -> occurence p occ) vpath in
   let t' = applist(t, (vargs @ [abstracted])) in
   exact (applist(t',[mkNewMeta()])) gl
 
-let rec shuffle p (t1,t2) = 
+let rec shuffle p (t1,t2) =
   match t1,t2 with
     | Oplus(l1,r1), Oplus(l2,r2) ->
-	if weight l1 > weight l2 then 
+	if weight l1 > weight l2 then
           let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
-          (clever_rewrite p [[P_APP 1;P_APP 1]; 
+          (clever_rewrite p [[P_APP 1;P_APP 1];
 			     [P_APP 1; P_APP 2];[P_APP 2]]
              (Lazy.force coq_fast_Zplus_assoc_reverse)
            :: tac,
            Oplus(l1,t'))
-	else 
+	else
 	  let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
           (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
              (Lazy.force coq_fast_Zplus_permute)
            :: tac,
            Oplus(l2,t'))
-    | Oplus(l1,r1), t2 -> 
+    | Oplus(l1,r1), t2 ->
 	if weight l1 > weight t2 then
           let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
           clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
             (Lazy.force coq_fast_Zplus_assoc_reverse)
-          :: tac, 
+          :: tac,
           Oplus(l1, t')
-	else 
-          [clever_rewrite p [[P_APP 1];[P_APP 2]] 
+	else
+          [clever_rewrite p [[P_APP 1];[P_APP 2]]
 	     (Lazy.force coq_fast_Zplus_comm)],
           Oplus(t2,t1)
-    | t1,Oplus(l2,r2) -> 
+    | t1,Oplus(l2,r2) ->
 	if weight l2 > weight t1 then
           let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
           clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
@@ -664,11 +663,11 @@ let rec shuffle p (t1,t2) =
 	[focused_simpl p], Oz(Bigint.add t1 t2)
     | t1,t2 ->
 	if weight t1 < weight t2 then
-          [clever_rewrite p [[P_APP 1];[P_APP 2]] 
+          [clever_rewrite p [[P_APP 1];[P_APP 2]]
 	     (Lazy.force coq_fast_Zplus_comm)],
 	  Oplus(t2,t1)
 	else [],Oplus(t1,t2)
-	  
+
 let rec shuffle_mult p_init k1 e1 k2 e2 =
   let rec loop p = function
     | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
@@ -681,13 +680,13 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
                               [P_APP 2; P_APP 1; P_APP 2];
                               [P_APP 1; P_APP 2];
                               [P_APP 2; P_APP 2]]
-              (Lazy.force coq_fast_OMEGA10) 
+              (Lazy.force coq_fast_OMEGA10)
 	  in
-          if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then 
-            let tac' = 
+          if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then
+            let tac' =
 	      clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
                 (Lazy.force coq_fast_Zred_factor5) in
-	    tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: 
+	    tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' ::
 	    loop p (l1,l2)
           else tac :: loop (P_APP 2 :: p) (l1,l2)
 	else if v1 > v2 then
@@ -706,7 +705,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
                             [P_APP 2; P_APP 2]]
             (Lazy.force coq_fast_OMEGA12) ::
           loop (P_APP 2 :: p) (l1',l2)
-    | ({c=c1;v=v1}::l1), [] -> 
+    | ({c=c1;v=v1}::l1), [] ->
         clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
                           [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
                           [P_APP 1; P_APP 1; P_APP 2];
@@ -714,7 +713,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
                           [P_APP 1; P_APP 2]]
           (Lazy.force coq_fast_OMEGA11) ::
         loop (P_APP 2 :: p) (l1,[])
-    | [],({c=c2;v=v2}::l2) -> 
+    | [],({c=c2;v=v2}::l2) ->
         clever_rewrite p  [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
                            [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
                            [P_APP 1];
@@ -722,10 +721,10 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
                            [P_APP 2; P_APP 2]]
           (Lazy.force coq_fast_OMEGA12) ::
         loop (P_APP 2 :: p) ([],l2)
-    | [],[] -> [focused_simpl p_init] 
+    | [],[] -> [focused_simpl p_init]
   in
   loop p_init (e1,e2)
-    
+
 let rec shuffle_mult_right p_init e1 k2 e2 =
   let rec loop p = function
     | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
@@ -738,14 +737,14 @@ let rec shuffle_mult_right p_init e1 k2 e2 =
                [P_APP 1; P_APP 2];
                [P_APP 2; P_APP 1; P_APP 2];
                [P_APP 2; P_APP 2]]
-              (Lazy.force coq_fast_OMEGA15) 
+              (Lazy.force coq_fast_OMEGA15)
 	  in
-          if Bigint.add c1 (Bigint.mult k2 c2) =? zero then 
-            let tac' = 
+          if Bigint.add c1 (Bigint.mult k2 c2) =? zero then
+            let tac' =
               clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
-                (Lazy.force coq_fast_Zred_factor5) 
+                (Lazy.force coq_fast_Zred_factor5)
 	    in
-            tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: 
+            tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' ::
             loop p (l1,l2)
           else tac :: loop (P_APP 2 :: p) (l1,l2)
 	else if v1 > v2 then
@@ -760,11 +759,11 @@ let rec shuffle_mult_right p_init e1 k2 e2 =
                             [P_APP 2; P_APP 2]]
             (Lazy.force coq_fast_OMEGA12) ::
           loop (P_APP 2 :: p) (l1',l2)
-    | ({c=c1;v=v1}::l1), [] -> 
+    | ({c=c1;v=v1}::l1), [] ->
         clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
           (Lazy.force coq_fast_Zplus_assoc_reverse) ::
         loop (P_APP 2 :: p) (l1,[])
-    | [],({c=c2;v=v2}::l2) -> 
+    | [],({c=c2;v=v2}::l2) ->
         clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
                           [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
                           [P_APP 1];
@@ -772,89 +771,89 @@ let rec shuffle_mult_right p_init e1 k2 e2 =
                           [P_APP 2; P_APP 2]]
           (Lazy.force coq_fast_OMEGA12) ::
         loop (P_APP 2 :: p) ([],l2)
-    | [],[] -> [focused_simpl p_init] 
+    | [],[] -> [focused_simpl p_init]
   in
   loop p_init (e1,e2)
 
-let rec shuffle_cancel p = function 
+let rec shuffle_cancel p = function
   | [] -> [focused_simpl p]
   | ({c=c1}::l1) ->
-      let tac = 
+      let tac =
 	clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2];
-                          [P_APP 2; P_APP 2]; 
+                          [P_APP 2; P_APP 2];
                           [P_APP 1; P_APP 1; P_APP 2; P_APP 1]]
-          (if c1 >? zero then 
-	     (Lazy.force coq_fast_OMEGA13) 
-	   else 
-	     (Lazy.force coq_fast_OMEGA14)) 
+          (if c1 >? zero then
+	     (Lazy.force coq_fast_OMEGA13)
+	   else
+	     (Lazy.force coq_fast_OMEGA14))
       in
       tac :: shuffle_cancel p l1
-	
+
 let rec scalar p n = function
-  | Oplus(t1,t2) -> 
-      let tac1,t1' = scalar (P_APP 1 :: p) n t1 and 
+  | Oplus(t1,t2) ->
+      let tac1,t1' = scalar (P_APP 1 :: p) n t1 and
         tac2,t2' = scalar (P_APP 2 :: p) n t2 in
       clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
-        (Lazy.force coq_fast_Zmult_plus_distr_l) :: 
+        (Lazy.force coq_fast_Zmult_plus_distr_l) ::
       (tac1 @ tac2), Oplus(t1',t2')
   | Oinv t ->
-      [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
+      [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
 	 (Lazy.force coq_fast_Zmult_opp_comm);
        focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n))
-  | Otimes(t1,Oz x) -> 
+  | Otimes(t1,Oz x) ->
       [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
          (Lazy.force coq_fast_Zmult_assoc_reverse);
-       focused_simpl (P_APP 2 :: p)], 
+       focused_simpl (P_APP 2 :: p)],
       Otimes(t1,Oz (n*x))
   | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
   | (Oatom _ as t) -> [], Otimes(t,Oz n)
   | Oz i -> [focused_simpl p],Oz(n*i)
   | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |]))
-      
-let rec scalar_norm p_init = 
+
+let rec scalar_norm p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
-    | (_::l) -> 
+    | (_::l) ->
 	clever_rewrite p
           [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2];
            [P_APP 1; P_APP 2];[P_APP 2]]
-          (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l 
+          (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l
   in
   loop p_init
 
 let rec norm_add p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
-    | _:: l -> 
+    | _:: l ->
 	clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
           (Lazy.force coq_fast_Zplus_assoc_reverse) ::
-	loop (P_APP 2 :: p) l 
+	loop (P_APP 2 :: p) l
   in
   loop p_init
 
 let rec scalar_norm_add p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
-    | _ :: l -> 
+    | _ :: l ->
 	clever_rewrite p
           [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
            [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
            [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]]
-          (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l 
+          (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l
   in
   loop p_init
 
 let rec negate p = function
-  | Oplus(t1,t2) -> 
-      let tac1,t1' = negate (P_APP 1 :: p) t1 and 
+  | Oplus(t1,t2) ->
+      let tac1,t1' = negate (P_APP 1 :: p) t1 and
         tac2,t2' = negate (P_APP 2 :: p) t2 in
       clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
-        (Lazy.force coq_fast_Zopp_plus_distr) :: 
+        (Lazy.force coq_fast_Zopp_plus_distr) ::
       (tac1 @ tac2),
       Oplus(t1',t2')
   | Oinv t ->
       [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t
-  | Otimes(t1,Oz x) -> 
+  | Otimes(t1,Oz x) ->
       [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
          (Lazy.force coq_fast_Zopp_mult_distr_r);
        focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x))
@@ -864,13 +863,13 @@ let rec negate p = function
       [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r
   | Oz i -> [focused_simpl p],Oz(neg i)
   | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |]))
-      
-let rec transform p t = 
+
+let rec transform p t =
   let default isnat t' =
-    try 
+    try
       let v,th,_ = find_constr t' in
       [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
-    with _ -> 
+    with _ ->
       let v = new_identifier_var ()
       and th = new_identifier () in
       hide_constr t' v th isnat;
@@ -878,12 +877,12 @@ let rec transform p t =
   in
   try match destructurate_term t with
     | Kapp(Zplus,[t1;t2]) ->
-	let tac1,t1' = transform (P_APP 1 :: p) t1 
+	let tac1,t1' = transform (P_APP 1 :: p) t1
 	and tac2,t2' = transform (P_APP 2 :: p) t2 in
 	let tac,t' = shuffle p (t1',t2') in
 	tac1 @ tac2 @ tac, t'
     | Kapp(Zminus,[t1;t2]) ->
-	let tac,t = 
+	let tac,t =
 	  transform p
 	    (mkApp (Lazy.force coq_Zplus,
 		     [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
@@ -893,18 +892,18 @@ let rec transform p t =
 					 [| t1; mk_integer one |])) in
 	unfold sp_Zsucc :: tac,t
    | Kapp(Zmult,[t1;t2]) ->
-       let tac1,t1' = transform (P_APP 1 :: p) t1 
+       let tac1,t1' = transform (P_APP 1 :: p) t1
        and tac2,t2' = transform (P_APP 2 :: p) t2 in
        begin match t1',t2' with
          | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t'
          | (Oz n,_) ->
-             let sym = 
-	       clever_rewrite p [[P_APP 1];[P_APP 2]] 
+             let sym =
+	       clever_rewrite p [[P_APP 1];[P_APP 2]]
 		 (Lazy.force coq_fast_Zmult_comm) in
              let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t'
          | _ -> default false t
        end
-   | Kapp((Zpos|Zneg|Z0),_) -> 
+   | Kapp((Zpos|Zneg|Z0),_) ->
        (try ([],Oz(recognize_number t)) with _ -> default false t)
    | Kvar s -> [],Oatom s
    | Kapp(Zopp,[t]) ->
@@ -914,28 +913,28 @@ let rec transform p t =
    | Kapp(Z_of_nat,[t']) -> default true t'
    | _ -> default false t
   with e when catchable_exception e -> default false t
-      
+
 let shrink_pair p f1 f2 =
   match f1,f2 with
-    | Oatom v,Oatom _ -> 
+    | Oatom v,Oatom _ ->
 	let r = Otimes(Oatom v,Oz two) in
 	clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r
-    | Oatom v, Otimes(_,c2) -> 
+    | Oatom v, Otimes(_,c2) ->
 	let r = Otimes(Oatom v,Oplus(c2,Oz one)) in
-	clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] 
+	clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]]
 	  (Lazy.force coq_fast_Zred_factor2), r
-    | Otimes (v1,c1),Oatom v -> 
+    | Otimes (v1,c1),Oatom v ->
 	let r = Otimes(Oatom v,Oplus(c1,Oz one)) in
 	clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]]
           (Lazy.force coq_fast_Zred_factor3), r
     | Otimes (Oatom v,c1),Otimes (v2,c2) ->
 	let r = Otimes(Oatom v,Oplus(c1,c2)) in
-	clever_rewrite p 
+	clever_rewrite p
           [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]]
           (Lazy.force coq_fast_Zred_factor4),r
-    | t1,t2 -> 
-	begin 
-	  oprint t1; print_newline (); oprint t2; print_newline (); 
+    | t1,t2 ->
+	begin
+	  oprint t1; print_newline (); oprint t2; print_newline ();
 	  flush Pervasives.stdout; error "shrink.1"
 	end
 
@@ -948,7 +947,7 @@ let reduce_factor p = function
       let rec compute = function
         | Oz n -> n
 	| Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2)
-	| _ -> error "condense.1" 
+	| _ -> error "condense.1"
       in
       [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c))
   | t -> oprint t; error "reduce_factor.1"
@@ -957,31 +956,31 @@ let rec condense p = function
   | Oplus(f1,(Oplus(f2,r) as t)) ->
       if weight f1 = weight f2 then begin
 	let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in
-	let assoc_tac = 
-          clever_rewrite p 
+	let assoc_tac =
+          clever_rewrite p
             [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
             (Lazy.force coq_fast_Zplus_assoc) in
 	let tac_list,t' = condense p (Oplus(t,r)) in
 	(assoc_tac :: shrink_tac :: tac_list), t'
       end else begin
 	let tac,f = reduce_factor (P_APP 1 :: p) f1 in
-	let tac',t' = condense (P_APP 2 :: p) t in 
-	(tac @ tac'), Oplus(f,t') 
+	let tac',t' = condense (P_APP 2 :: p) t in
+	(tac @ tac'), Oplus(f,t')
       end
-  | Oplus(f1,Oz n) -> 
+  | Oplus(f1,Oz n) ->
       let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n)
-  | Oplus(f1,f2) -> 
+  | Oplus(f1,f2) ->
       if weight f1 = weight f2 then begin
 	let tac_shrink,t = shrink_pair p f1 f2 in
 	let tac,t' = condense p t in
 	tac_shrink :: tac,t'
       end else begin
 	let tac,f = reduce_factor (P_APP 1 :: p) f1 in
-	let tac',t' = condense (P_APP 2 :: p) f2 in 
-	(tac @ tac'),Oplus(f,t') 
+	let tac',t' = condense (P_APP 2 :: p) f2 in
+	(tac @ tac'),Oplus(f,t')
       end
   | Oz _ as t -> [],t
-  | t -> 
+  | t ->
       let tac,t' = reduce_factor p t in
       let final = Oplus(t',Oz zero) in
       let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in
@@ -990,99 +989,99 @@ let rec condense p = function
 let rec clear_zero p = function
   | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero ->
       let tac =
-	clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
+	clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
 	  (Lazy.force coq_fast_Zred_factor5) in
       let tac',t = clear_zero p r in
       tac :: tac',t
-  | Oplus(f,r) -> 
+  | Oplus(f,r) ->
       let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t)
   | t -> [],t
 
-let replay_history tactic_normalisation = 
+let replay_history tactic_normalisation =
   let aux  = id_of_string "auxiliary" in
   let aux1 = id_of_string "auxiliary_1" in
   let aux2 = id_of_string "auxiliary_2" in
   let izero = mk_integer zero in
   let rec loop t =
     match t with
-      | HYP e :: l -> 
-	  begin 
-	    try 
-	      tclTHEN 
-		(List.assoc (hyp_of_tag e.id) tactic_normalisation) 
+      | HYP e :: l ->
+	  begin
+	    try
+	      tclTHEN
+		(List.assoc (hyp_of_tag e.id) tactic_normalisation)
 		(loop l)
 	    with Not_found -> loop l end
       | NEGATE_CONTRADICT (e2,e1,b) :: l ->
-	  let eq1 = decompile e1 
-	  and eq2 = decompile e2 in 
-	  let id1 = hyp_of_tag e1.id 
+	  let eq1 = decompile e1
+	  and eq2 = decompile e2 in
+	  let id1 = hyp_of_tag e1.id
 	  and id2 = hyp_of_tag e2.id in
 	  let k = if b then negone else one in
 	  let p_initial = [P_APP 1;P_TYPE] in
 	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
 	  tclTHENLIST [
-	    (generalize_tac 
-	      [mkApp (Lazy.force coq_OMEGA17, [| 
+	    (generalize_tac
+	      [mkApp (Lazy.force coq_OMEGA17, [|
 		val_of eq1;
 		val_of eq2;
-		mk_integer k; 
+		mk_integer k;
 		mkVar id1; mkVar id2 |])]);
 	    (mk_then tac);
 	    (intros_using [aux]);
 	    (resolve_id aux);
             reflexivity
           ]
-      | CONTRADICTION (e1,e2) :: l -> 
-	  let eq1 = decompile e1 
-	  and eq2 = decompile e2 in 
+      | CONTRADICTION (e1,e2) :: l ->
+	  let eq1 = decompile e1
+	  and eq2 = decompile e2 in
 	  let p_initial = [P_APP 2;P_TYPE] in
 	  let tac = shuffle_cancel p_initial e1.body in
 	  let solve_le =
-            let not_sup_sup = mkApp (build_coq_eq (), [| 
-					Lazy.force coq_comparison; 
+            let not_sup_sup = mkApp (build_coq_eq (), [|
+					Lazy.force coq_comparison;
 					Lazy.force coq_Gt;
 					Lazy.force coq_Gt |])
 	    in
-            tclTHENS 
+            tclTHENS
 	      (tclTHENLIST [
 		(unfold sp_Zle);
 		(simpl_in_concl);
 		intro;
 		(absurd not_sup_sup) ])
-	      [ assumption ; reflexivity ] 
+	      [ assumption ; reflexivity ]
 	  in
 	  let theorem =
-            mkApp (Lazy.force coq_OMEGA2, [| 
-		      val_of eq1; val_of eq2; 
+            mkApp (Lazy.force coq_OMEGA2, [|
+		      val_of eq1; val_of eq2;
 		      mkVar (hyp_of_tag e1.id);
 		      mkVar (hyp_of_tag e2.id) |])
 	  in
 	  tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le)
       | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
 	  let id = hyp_of_tag e1.id in
-	  let eq1 = val_of(decompile e1) 
+	  let eq1 = val_of(decompile e1)
 	  and eq2 = val_of(decompile e2) in
-	  let kk = mk_integer k 
+	  let kk = mk_integer k
 	  and dd = mk_integer d in
 	  let rhs = mk_plus (mk_times eq2 kk) dd in
 	  let state_eg = mk_eq eq1 rhs in
 	  let tac = scalar_norm_add [P_APP 3] e2.body in
-	  tclTHENS 
-	    (cut state_eg) 
+	  tclTHENS
+	    (cut state_eg)
 	    [ tclTHENS
 	        (tclTHENLIST [
 		  (intros_using [aux]);
-		  (generalize_tac 
+		  (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA1,
 		      [| eq1; rhs; mkVar aux; mkVar id |])]);
 		  (clear [aux;id]);
 		  (intros_using [id]);
 		  (cut (mk_gt kk dd)) ])
-	        [ tclTHENS 
-		    (cut (mk_gt kk izero)) 
+	        [ tclTHENS
+		    (cut (mk_gt kk izero))
 		    [ tclTHENLIST [
 		        (intros_using [aux1; aux2]);
-		        (generalize_tac 
+		        (generalize_tac
 			  [mkApp (Lazy.force coq_Zmult_le_approx,
 			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
 		        (clear [aux1;aux2;id]);
@@ -1095,23 +1094,23 @@ let replay_history tactic_normalisation =
 		  tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ]
                 ];
 	      tclTHEN (mk_then tac) reflexivity ]
-	    
+
       | NOT_EXACT_DIVIDE (e1,k) :: l ->
 	  let c = floor_div e1.constant k in
 	  let d = Bigint.sub e1.constant (Bigint.mult c k) in
-	  let e2 =  {id=e1.id; kind=EQUA;constant = c; 
+	  let e2 =  {id=e1.id; kind=EQUA;constant = c;
                      body = map_eq_linear (fun c -> c / k) e1.body } in
 	  let eq2 = val_of(decompile e2) in
-	  let kk = mk_integer k 
+	  let kk = mk_integer k
 	  and dd = mk_integer d in
 	  let tac = scalar_norm_add [P_APP 2] e2.body in
-	  tclTHENS 
-	    (cut (mk_gt dd izero)) 
-	    [ tclTHENS (cut (mk_gt kk dd)) 
+	  tclTHENS
+	    (cut (mk_gt dd izero))
+	    [ tclTHENS (cut (mk_gt kk dd))
 		[tclTHENLIST [
 		  (intros_using [aux2;aux1]);
-		  (generalize_tac 
-		    [mkApp (Lazy.force coq_OMEGA4, 
+		  (generalize_tac
+		    [mkApp (Lazy.force coq_OMEGA4,
                       [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
 		  (clear [aux1;aux2]);
 		  (unfold sp_not);
@@ -1121,7 +1120,7 @@ let replay_history tactic_normalisation =
 		  assumption ] ;
 		 tclTHENLIST [
 		   (unfold sp_Zgt);
-		   simpl_in_concl; 
+		   simpl_in_concl;
 		   reflexivity ] ];
               tclTHENLIST [
 		(unfold sp_Zgt);
@@ -1130,18 +1129,18 @@ let replay_history tactic_normalisation =
       | EXACT_DIVIDE (e1,k) :: l ->
 	  let id = hyp_of_tag e1.id in
 	  let e2 =  map_eq_afine (fun c -> c / k) e1 in
-	  let eq1 = val_of(decompile e1) 
+	  let eq1 = val_of(decompile e1)
 	  and eq2 = val_of(decompile e2) in
 	  let kk = mk_integer k in
 	  let state_eq = mk_eq eq1 (mk_times eq2 kk) in
 	  if e1.kind = DISE then
             let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS 
-	      (cut state_eq) 
+            tclTHENS
+	      (cut state_eq)
 	      [tclTHENLIST [
 		(intros_using [aux1]);
-		(generalize_tac 
-		  [mkApp (Lazy.force coq_OMEGA18, 
+		(generalize_tac
+		  [mkApp (Lazy.force coq_OMEGA18,
                     [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
 		(clear [aux1;id]);
 		(intros_using [id]);
@@ -1149,14 +1148,14 @@ let replay_history tactic_normalisation =
 	       tclTHEN (mk_then tac) reflexivity ]
 	  else
             let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS (cut state_eq) 
+            tclTHENS (cut state_eq)
 	      [
-		tclTHENS 
-		 (cut (mk_gt kk izero)) 
+		tclTHENS
+		 (cut (mk_gt kk izero))
 		 [tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   (generalize_tac 
-		     [mkApp (Lazy.force coq_OMEGA3, 
+		   (generalize_tac
+		     [mkApp (Lazy.force coq_OMEGA3,
 		       [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
 		   (clear [aux1;aux2;id]);
 		   (intros_using [id]);
@@ -1169,35 +1168,35 @@ let replay_history tactic_normalisation =
       | (MERGE_EQ(e3,e1,e2)) :: l ->
 	  let id = new_identifier () in
 	  tag_hypothesis id e3;
-	  let id1 = hyp_of_tag e1.id 
+	  let id1 = hyp_of_tag e1.id
 	  and id2 = hyp_of_tag e2 in
-	  let eq1 = val_of(decompile e1) 
+	  let eq1 = val_of(decompile e1)
 	  and eq2 = val_of (decompile (negate_eq e1)) in
-	  let tac = 
-	    clever_rewrite [P_APP 3] [[P_APP 1]] 
+	  let tac =
+	    clever_rewrite [P_APP 3] [[P_APP 1]]
 	      (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
-            scalar_norm [P_APP 3] e1.body 
+            scalar_norm [P_APP 3] e1.body
 	  in
-	  tclTHENS 
-	    (cut (mk_eq eq1 (mk_inv eq2))) 
+	  tclTHENS
+	    (cut (mk_eq eq1 (mk_inv eq2)))
 	    [tclTHENLIST [
 	      (intros_using [aux]);
-	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8, 
+	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
 	        [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
 	      (clear [id1;id2;aux]);
 	      (intros_using [id]);
 	      (loop l) ];
             tclTHEN (mk_then tac) reflexivity]
-	    
+
       | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l ->
-	  let id = new_identifier () 
+	  let id = new_identifier ()
 	  and id2 = hyp_of_tag orig.id in
 	  tag_hypothesis id e.id;
-	  let eq1 = val_of(decompile def) 
+	  let eq1 = val_of(decompile def)
 	  and eq2 = val_of(decompile orig) in
 	  let vid = unintern_id v in
 	  let theorem =
-            mkApp (build_coq_ex (), [| 
+            mkApp (build_coq_ex (), [|
 		      Lazy.force coq_Z;
 		      mkLambda
 			(Name vid,
@@ -1206,57 +1205,57 @@ let replay_history tactic_normalisation =
 	  in
 	  let mm = mk_integer m in
 	  let p_initial = [P_APP 2;P_TYPE] in
-	  let tac = 
-            clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) 
+	  let tac =
+            clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial)
               [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             shuffle_mult_right p_initial
               orig.body m ({c= negone;v= v}::def.body) in
-	  tclTHENS 
-	    (cut theorem)  
+	  tclTHENS
+	    (cut theorem)
 	    [tclTHENLIST [
 	      (intros_using [aux]);
 	      (elim_id aux);
 	      (clear [aux]);
 	      (intros_using [vid; aux]);
 	      (generalize_tac
-		[mkApp (Lazy.force coq_OMEGA9, 
+		[mkApp (Lazy.force coq_OMEGA9,
 		  [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
 	      (mk_then tac);
 	      (clear [aux]);
 	      (intros_using [id]);
 	      (loop l) ];
-            tclTHEN (exists_tac (inj_open eq1)) reflexivity ]
+            tclTHEN (exists_tac eq1) reflexivity ]
       | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
-	  let id1 = new_identifier () 
+	  let id1 = new_identifier ()
 	  and id2 = new_identifier () in
 	  tag_hypothesis id1 e1; tag_hypothesis id2 e2;
 	  let id = hyp_of_tag e.id in
 	  let tac1 = norm_add [P_APP 2;P_TYPE] e.body in
 	  let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in
 	  let eq = val_of(decompile e) in
-	  tclTHENS 
+	  tclTHENS
 	    (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))
 	    [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ];
              tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]]
       | SUM(e3,(k1,e1),(k2,e2)) :: l ->
 	  let id = new_identifier () in
 	  tag_hypothesis id e3;
-	  let id1 = hyp_of_tag e1.id 
+	  let id1 = hyp_of_tag e1.id
 	  and id2 = hyp_of_tag e2.id in
-	  let eq1 = val_of(decompile e1) 
+	  let eq1 = val_of(decompile e1)
 	  and eq2 = val_of(decompile e2) in
 	  if k1 =? one & e2.kind = EQUA then
             let tac_thm =
               match e1.kind with
-		| EQUA -> Lazy.force coq_OMEGA5 
-		| INEQ -> Lazy.force coq_OMEGA6 
-		| DISE -> Lazy.force coq_OMEGA20 
+		| EQUA -> Lazy.force coq_OMEGA5
+		| INEQ -> Lazy.force coq_OMEGA6
+		| DISE -> Lazy.force coq_OMEGA20
 	    in
             let kk = mk_integer k2 in
             let p_initial =
               if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
             let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
-            tclTHENLIST [ 
+            tclTHENLIST [
 	      (generalize_tac
                 [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
 	      (mk_then tac);
@@ -1264,18 +1263,18 @@ let replay_history tactic_normalisation =
 	      (loop l)
             ]
 	  else
-            let kk1 = mk_integer k1 
+            let kk1 = mk_integer k1
 	    and kk2 = mk_integer k2 in
 	    let p_initial = [P_APP 2;P_TYPE] in
 	    let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in
-            tclTHENS (cut (mk_gt kk1 izero)) 
-	      [tclTHENS 
-		 (cut (mk_gt kk2 izero)) 
+            tclTHENS (cut (mk_gt kk1 izero))
+	      [tclTHENS
+		 (cut (mk_gt kk2 izero))
 		 [tclTHENLIST [
 		   (intros_using [aux2;aux1]);
 		   (generalize_tac
-		     [mkApp (Lazy.force coq_OMEGA7, [| 
-		       eq1;eq2;kk1;kk2; 
+		     [mkApp (Lazy.force coq_OMEGA7, [|
+		       eq1;eq2;kk1;kk2;
 		       mkVar aux1;mkVar aux2;
 		       mkVar id1;mkVar id2 |])]);
 		   (clear [aux1;aux2]);
@@ -1288,11 +1287,11 @@ let replay_history tactic_normalisation =
 		   reflexivity ] ];
 	      tclTHENLIST [
 		(unfold sp_Zgt);
-                simpl_in_concl; 
+                simpl_in_concl;
 		reflexivity ] ]
-      | CONSTANT_NOT_NUL(e,k) :: l -> 
+      | CONSTANT_NOT_NUL(e,k) :: l ->
 	  tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl
-      | CONSTANT_NUL(e) :: l -> 
+      | CONSTANT_NUL(e) :: l ->
 	  tclTHEN (resolve_id (hyp_of_tag e)) reflexivity
       | CONSTANT_NEG(e,k) :: l ->
 	  tclTHENLIST [
@@ -1302,43 +1301,43 @@ let replay_history tactic_normalisation =
 	    (unfold sp_not);
 	    (intros_using [aux]);
 	    (resolve_id aux);
-	    reflexivity 
+	    reflexivity
           ]
-      | _ -> tclIDTAC 
+      | _ -> tclIDTAC
   in
   loop
 
 let normalize p_initial t =
   let (tac,t') = transform p_initial t in
   let (tac',t'') = condense p_initial t' in
-  let (tac'',t''') = clear_zero p_initial t'' in 
+  let (tac'',t''') = clear_zero p_initial t'' in
   tac @ tac' @ tac'' , t'''
-    
+
 let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
   let p_initial = [P_APP pos ;P_TYPE] in
   let (tac,t') = normalize p_initial t in
-  let shift_left = 
-    tclTHEN 
+  let shift_left =
+    tclTHEN
       (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
       (tclTRY (clear [id]))
   in
   if tac <> [] then
-    let id' = new_identifier () in 
+    let id' = new_identifier () in
     ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ]))
           :: tactic,
      compile id' flag t' :: defs)
-  else 
+  else
     (tactic,defs)
-    
+
 let destructure_omega gl tac_def (id,c) =
-  if atompart_of_id id = "State" then 
+  if atompart_of_id id = "State" then
     tac_def
   else
     try match destructurate_prop c with
-      | Kapp(Eq,[typ;t1;t2]) 
+      | Kapp(Eq,[typ;t1;t2])
 	when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) ->
 	  let t = mk_plus t1 (mk_inv t2) in
-	  normalize_equation 
+	  normalize_equation
 	    id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def
       | Kapp(Zne,[t1;t2]) ->
 	  let t = mk_plus t1 (mk_inv t2) in
@@ -1369,10 +1368,10 @@ let reintroduce id =
 
 let coq_omega gl =
   clear_tables ();
-  let tactic_normalisation, system = 
+  let tactic_normalisation, system =
     List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in
-  let prelude,sys = 
-    List.fold_left 
+  let prelude,sys =
+    List.fold_left
       (fun (tac,sys) (t,(v,th,b)) ->
 	 if b then
            let id = new_identifier () in
@@ -1385,8 +1384,8 @@ let coq_omega gl =
 	     (clear [id]);
 	     (intros_using [th;id]);
 	     tac ]),
-           {kind = INEQ; 
-	    body = [{v=intern_id v; c=one}]; 
+           {kind = INEQ;
+	    body = [{v=intern_id v; c=one}];
             constant = zero; id = i} :: sys
 	 else
            (tclTHENLIST [
@@ -1399,17 +1398,17 @@ let coq_omega gl =
   let system = system @ sys in
   if !display_system_flag then display_system display_var system;
   if !old_style_flag then begin
-    try 
+    try
       let _ = simplify (new_id,new_var_num,display_var) false system in
       tclIDTAC gl
-    with UNSOLVABLE -> 
+    with UNSOLVABLE ->
       let _,path = depend [] [] (history ()) in
       if !display_action_flag then display_action display_var path;
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl 
-  end else begin 
+      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
+  end else begin
     try
       let path = simplify_strong (new_id,new_var_num,display_var) system in
-      if !display_action_flag then display_action display_var path; 
+      if !display_action_flag then display_action display_var path;
       (tclTHEN prelude (replay_history tactic_normalisation path)) gl
     with NO_CONTRADICTION -> error "Omega can't solve this system"
   end
@@ -1417,10 +1416,10 @@ let coq_omega gl =
 let coq_omega = solver_time coq_omega
 
 let nat_inject gl =
-  let rec explore p t = 
+  let rec explore p t =
     try match destructurate_term t with
       | Kapp(Plus,[t1;t2]) ->
-          tclTHENLIST [ 
+          tclTHENLIST [
 	    (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
               ((Lazy.force coq_inj_plus),[t1;t2]));
 	    (explore (P_APP 1 :: p) t1);
@@ -1436,61 +1435,61 @@ let nat_inject gl =
       | Kapp(Minus,[t1;t2]) ->
           let id = new_identifier () in
           tclTHENS
-            (tclTHEN 
-	       (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) 
-	       (intros_using [id])) 
+            (tclTHEN
+	       (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1])))
+	       (intros_using [id]))
 	    [
 	      tclTHENLIST [
-	        (clever_rewrite_gen p 
+	        (clever_rewrite_gen p
 		  (mk_minus (mk_inj t1) (mk_inj t2))
                   ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id]));
 		(loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]);
 		(explore (P_APP 1 :: p) t1);
 		(explore (P_APP 2 :: p) t2) ];
-	      (tclTHEN 
+	      (tclTHEN
 		 (clever_rewrite_gen p (mk_integer zero)
                     ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
 		 (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
 	    ]
       | Kapp(S,[t']) ->
           let rec is_number t =
-            try match destructurate_term t with 
+            try match destructurate_term t with
 		Kapp(S,[t]) -> is_number t
               | Kapp(O,[]) -> true
               | _ -> false
-            with e when catchable_exception e -> false 
+            with e when catchable_exception e -> false
 	  in
           let rec loop p t =
-            try match destructurate_term t with 
+            try match destructurate_term t with
 		Kapp(S,[t]) ->
-                  (tclTHEN 
-                     (clever_rewrite_gen p 
+                  (tclTHEN
+                     (clever_rewrite_gen p
 			(mkApp (Lazy.force coq_Zsucc, [| mk_inj t |]))
-			((Lazy.force coq_inj_S),[t])) 
+			((Lazy.force coq_inj_S),[t]))
 		     (loop (P_APP 1 :: p) t))
-              | _ -> explore p t 
-            with e when catchable_exception e -> explore p t 
+              | _ -> explore p t
+            with e when catchable_exception e -> explore p t
 	  in
           if is_number t' then focused_simpl p else loop p t
       | Kapp(Pred,[t]) ->
-          let t_minus_one = 
-	    mkApp (Lazy.force coq_minus, [| t; 
+          let t_minus_one =
+	    mkApp (Lazy.force coq_minus, [| t;
 		      mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in
           tclTHEN
-            (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one 
+            (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one
                ((Lazy.force coq_pred_of_minus),[t]))
-            (explore p t_minus_one) 
+            (explore p t_minus_one)
       | Kapp(O,[]) -> focused_simpl p
-      | _ -> tclIDTAC 
-    with e when catchable_exception e -> tclIDTAC 
-	
+      | _ -> tclIDTAC
+    with e when catchable_exception e -> tclIDTAC
+
   and loop = function
     | [] -> tclIDTAC
-    | (i,t)::lit -> 
-	  begin try match destructurate_prop t with 
+    | (i,t)::lit ->
+	  begin try match destructurate_prop t with
               Kapp(Le,[t1;t2]) ->
 		tclTHENLIST [
-		  (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);
@@ -1499,7 +1498,7 @@ let nat_inject gl =
                 ]
             | Kapp(Lt,[t1;t2]) ->
 		tclTHENLIST [
-		  (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);
@@ -1508,7 +1507,7 @@ let nat_inject gl =
                 ]
             | Kapp(Ge,[t1;t2]) ->
 		tclTHENLIST [
-		  (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);
@@ -1536,7 +1535,7 @@ let nat_inject gl =
             | Kapp(Eq,[typ;t1;t2]) ->
 		if pf_conv_x gl typ (Lazy.force coq_nat) then
                   tclTHENLIST [
-		    (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);
@@ -1545,32 +1544,32 @@ let nat_inject gl =
                   ]
 		else loop lit
 	    | _ -> loop lit
-	  with e when catchable_exception e -> loop lit end 
+	  with e when catchable_exception e -> loop lit end
   in
   loop (List.rev (pf_hyps_types gl)) gl
-    
+
 let rec decidability gl t =
   match destructurate_prop t with
-    | Kapp(Or,[t1;t2]) -> 
+    | Kapp(Or,[t1;t2]) ->
 	mkApp (Lazy.force coq_dec_or, [| t1; t2;
 		  decidability gl t1; decidability gl t2 |])
-    | Kapp(And,[t1;t2]) -> 
+    | Kapp(And,[t1;t2]) ->
 	mkApp (Lazy.force coq_dec_and, [| t1; t2;
 		  decidability gl t1; decidability gl t2 |])
-    | Kapp(Iff,[t1;t2]) -> 
+    | Kapp(Iff,[t1;t2]) ->
 	mkApp (Lazy.force coq_dec_iff, [| t1; t2;
 		  decidability gl t1; decidability gl t2 |])
-    | Kimp(t1,t2) -> 
+    | Kimp(t1,t2) ->
 	mkApp (Lazy.force coq_dec_imp, [| t1; t2;
 		  decidability gl t1; decidability gl t2 |])
-    | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; 
+    | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1;
 				    decidability gl t1 |])
-    | Kapp(Eq,[typ;t1;t2]) -> 
+    | Kapp(Eq,[typ;t1;t2]) ->
 	begin match destructurate_type (pf_nf gl typ) with
           | Kapp(Z,[]) ->  mkApp (Lazy.force coq_dec_eq, [| t1;t2 |])
           | Kapp(Nat,[]) ->  mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |])
-          | _ -> errorlabstrm "decidability" 
-		(str "Omega: Can't solve a goal with equality on " ++ 
+          | _ -> errorlabstrm "decidability"
+		(str "Omega: Can't solve a goal with equality on " ++
 		   Printer.pr_lconstr typ)
 	end
     | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |])
@@ -1584,7 +1583,7 @@ let rec decidability gl t =
     | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |])
     | Kapp(False,[]) -> Lazy.force coq_dec_False
     | Kapp(True,[]) -> Lazy.force coq_dec_True
-    | Kapp(Other t,_::_) -> error 
+    | Kapp(Other t,_::_) -> error
 	("Omega: Unrecognized predicate or connective: "^t)
     | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t)
     | Kvar _ -> error "Omega: Can't solve a goal with proposition variables"
@@ -1595,7 +1594,7 @@ let onClearedName id tac =
   (* so renaming may be necessary *)
   tclTHEN
     (tclTRY (clear [id]))
-    (fun gl -> 
+    (fun gl ->
       let id = fresh_id [] id gl in
       tclTHEN (introduction id) (tac id) gl)
 
@@ -1607,7 +1606,7 @@ let destructure_hyps gl =
 	  | Kapp(False,[]) -> elim_id i
           | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
           | Kapp(Or,[t1;t2]) ->
-              (tclTHENS 
+              (tclTHENS
                 (elim_id i)
                 [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
                   onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
@@ -1615,7 +1614,7 @@ let destructure_hyps gl =
               tclTHENLIST [
                 (elim_id i);
 		(tclTRY (clear [i]));
-		(fun gl -> 
+		(fun gl ->
 		  let i1 = fresh_id [] (add_suffix i "_left") gl in
 		  let i2 = fresh_id [] (add_suffix i "_right") gl in
 		  tclTHENLIST [
@@ -1627,7 +1626,7 @@ let destructure_hyps gl =
               tclTHENLIST [
                 (elim_id i);
 		(tclTRY (clear [i]));
-		(fun gl -> 
+		(fun gl ->
 		  let i1 = fresh_id [] (add_suffix i "_left") gl in
 		  let i2 = fresh_id [] (add_suffix i "_right") gl in
 		  tclTHENLIST [
@@ -1661,16 +1660,16 @@ let destructure_hyps gl =
                 ]
               else
 		loop lit
-          | Kapp(Not,[t]) -> 
-              begin match destructurate_prop t with 
-		  Kapp(Or,[t1;t2]) -> 
+          | Kapp(Not,[t]) ->
+              begin match destructurate_prop t with
+		  Kapp(Or,[t1;t2]) ->
                     tclTHENLIST [
 		      (generalize_tac
                         [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
 		      (onClearedName i (fun i ->
                         (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
                     ]
-		| Kapp(And,[t1;t2]) -> 
+		| Kapp(And,[t1;t2]) ->
                     tclTHENLIST [
 		      (generalize_tac
 		        [mkApp (Lazy.force coq_not_and, [| t1; t2;
@@ -1690,8 +1689,8 @@ let destructure_hyps gl =
                     ]
 		| Kimp(t1,t2) ->
                     tclTHENLIST [
-		      (generalize_tac 
-		        [mkApp (Lazy.force coq_not_imp, [| t1; t2; 
+		      (generalize_tac
+		        [mkApp (Lazy.force coq_not_imp, [| t1; t2;
 		          decidability gl t1;mkVar i |])]);
 		      (onClearedName i (fun i ->
                         (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
@@ -1717,7 +1716,7 @@ let destructure_hyps gl =
                     ]
 		| Kapp(Zlt, [t1;t2]) ->
                     tclTHENLIST [
-		      (generalize_tac 
+		      (generalize_tac
                         [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]);
 		      (onClearedName i (fun _ -> loop lit))
                     ]
@@ -1752,33 +1751,33 @@ let destructure_hyps gl =
 		      (onClearedName i (fun _ -> loop lit))
                     ]
 		| Kapp(Eq,[typ;t1;t2]) ->
-                    if !old_style_flag then begin 
+                    if !old_style_flag then begin
 		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) -> 
+			| Kapp(Nat,_) ->
                             tclTHENLIST [
-			      (simplest_elim 
+			      (simplest_elim
 				(mkApp
                                   (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
 			      (onClearedName i (fun _ -> loop lit))
                             ]
 			| Kapp(Z,_) ->
                             tclTHENLIST [
-			      (simplest_elim 
+			      (simplest_elim
 				(mkApp
 				  (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
 			      (onClearedName i (fun _ -> loop lit))
                             ]
 			| _ -> loop lit
-                    end else begin 
+                    end else begin
 		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) -> 
-                               (tclTHEN 
+			| Kapp(Nat,_) ->
+                               (tclTHEN
 			       (convert_hyp_no_check
                                   (i,body,
 				  (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
 			       (loop lit))
 			| Kapp(Z,_) ->
-                               (tclTHEN 
+                               (tclTHEN
 			       (convert_hyp_no_check
                                   (i,body,
 				  (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
@@ -1786,10 +1785,10 @@ let destructure_hyps gl =
 			| _ -> loop lit
                     end
 		| _ -> loop lit
-              end 
-          | _ -> loop lit 
+              end
+          | _ -> loop lit
 	with e when catchable_exception e -> loop lit
-	end 
+	end
   in
   loop (pf_hyps gl) gl
 
@@ -1798,19 +1797,19 @@ let destructure_goal gl =
   let rec loop t =
     match destructurate_prop t with
       | Kapp(Not,[t]) ->
-          (tclTHEN 
-	     (tclTHEN (unfold sp_not) intro) 
+          (tclTHEN
+	     (tclTHEN (unfold sp_not) intro)
 	     destructure_hyps)
       | Kimp(a,b) -> (tclTHEN intro (loop b))
       | Kapp(False,[]) -> destructure_hyps
       | _ ->
-          (tclTHEN 
+          (tclTHEN
 	     (tclTHEN
-		(Tactics.refine 
+		(Tactics.refine
 		   (mkApp (Lazy.force coq_dec_not_not, [| t;
 			      decidability gl t; mkNewMeta () |])))
-		intro) 
-	     (destructure_hyps)) 
+		intro)
+	     (destructure_hyps))
   in
   (loop concl) gl
 
@@ -1818,7 +1817,7 @@ let destructure_goal = all_time (destructure_goal)
 
 let omega_solver gl =
   Coqlib.check_required_library ["Coq";"omega";"Omega"];
-  let result = destructure_goal gl in 
-  (* if !display_time_flag then begin text_time (); 
+  let result = destructure_goal gl in
+  (* if !display_time_flag then begin text_time ();
      flush Pervasives.stdout end; *)
   result
diff --git a/contrib/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index 02545b30..3bfdce7f 100644
--- a/contrib/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -15,21 +15,21 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_omega.ml4 10028 2007-07-18 22:38:06Z letouzey $ *)
+(* $Id$ *)
 
 open Coq_omega
 open Refiner
 
-let omega_tactic l = 
-  let tacs = List.map 
-    (function  
+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 -> Util.error ("No Omega knowledge base for type "^s))
     (Util.list_uniquize (List.sort compare l))
-  in 
+  in
   tclTHEN
     (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
     omega_solver
@@ -40,7 +40,7 @@ TACTIC EXTEND omega
 END
 
 TACTIC EXTEND omega'
-| [ "omega" "with" ne_ident_list(l) ] -> 
+| [ "omega" "with" ne_ident_list(l) ] ->
     [ omega_tactic (List.map Names.string_of_id l) ]
 | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ]
 END
diff --git a/contrib/omega/omega.ml b/plugins/omega/omega.ml
index fd774c16..11ab9c03 100644
--- a/contrib/omega/omega.ml
+++ b/plugins/omega/omega.ml
@@ -85,13 +85,13 @@ type linear = coeff list
 
 type eqn_kind = EQUA | INEQ | DISE
 
-type afine = { 
+type afine = {
   (* a number uniquely identifying the equation *)
-  id: int ; 
+  id: int ;
   (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *)
-  kind: eqn_kind; 
+  kind: eqn_kind;
   (* the variables and their coefficient *)
-  body: coeff list; 
+  body: coeff list;
   (* a constant *)
   constant: bigint }
 
@@ -108,7 +108,7 @@ type action =
   | FORGET_C of int
   | EXACT_DIVIDE of afine * bigint
   | SUM of int * (bigint * afine) * (bigint * afine)
-  | STATE of state_action 
+  | STATE of state_action
   | HYP of afine
   | FORGET   of int * int
   | FORGET_I of int * int
@@ -126,22 +126,22 @@ exception UNSOLVABLE
 exception NO_CONTRADICTION
 
 let display_eq print_var (l,e) =
-  let _ = 
-    List.fold_left 
+  let _ =
+    List.fold_left
       (fun not_first f ->
-	 print_string 
+	 print_string
 	   (if f.c <? zero then "- " else if not_first then "+ " else "");
 	 let c = abs f.c in
-	 if c =? one then 
+	 if c =? one then
 	   Printf.printf "%s " (print_var f.v)
-	 else 
-	   Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); 
+	 else
+	   Printf.printf "%s %s " (string_of_bigint c) (print_var f.v);
 	 true)
       false l
   in
-  if e >? zero then 
+  if e >? zero then
     Printf.printf "+ %s " (string_of_bigint e)
-  else if e <? zero then 
+  else if e <? zero then
     Printf.printf "- %s " (string_of_bigint (abs e))
 
 let rec trace_length l =
@@ -151,22 +151,22 @@ let rec trace_length l =
     | _ -> accu + one in
   List.fold_left action_length zero l
 
-let operator_of_eq = function 
+let operator_of_eq = function
   | EQUA -> "=" | DISE -> "!=" | INEQ -> ">="
 
 let kind_of = function
   | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation"
 
-let display_system print_var l = 
-  List.iter 
-    (fun { kind=b; body=e; constant=c; id=id} -> 
+let display_system print_var l =
+  List.iter
+    (fun { kind=b; body=e; constant=c; id=id} ->
        Printf.printf "E%d: " id;
        display_eq print_var (e,c);
        Printf.printf "%s 0\n" (operator_of_eq b))
     l;
   print_string "------------------------\n\n"
 
-let display_inequations print_var l = 
+let display_inequations print_var l =
   List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l;
   print_string "------------------------\n\n"
 
@@ -175,7 +175,7 @@ let sbi = string_of_bigint
 let rec display_action print_var = function
   | act :: l -> begin match act with
       | DIVIDE_AND_APPROX (e1,e2,k,d) ->
-          Printf.printf 
+          Printf.printf
             "Inequation E%d is divided by %s and the constant coefficient is \
             rounded by substracting %s.\n" e1.id (sbi k) (sbi d)
       | NOT_EXACT_DIVIDE (e,k) ->
@@ -187,28 +187,28 @@ let rec display_action print_var = function
             "Equation E%d is divided by the pgcd \
             %s of its coefficients.\n" e.id (sbi k)
       | WEAKEN (e,k) ->
-          Printf.printf 
+          Printf.printf
             "To ensure a solution in the dark shadow \
             the equation E%d is weakened by %s.\n" e (sbi k)
-      | SUM (e,(c1,e1),(c2,e2)) -> 
+      | SUM (e,(c1,e1),(c2,e2)) ->
           Printf.printf
-            "We state %s E%d = %s %s E%d + %s %s E%d.\n" 
+            "We state %s E%d = %s %s E%d + %s %s E%d.\n"
             (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2)
             (kind_of e2.kind) e2.id
       | STATE { st_new_eq = e } ->
-          Printf.printf "We define a new equation E%d: " e.id; 
-          display_eq print_var (e.body,e.constant); 
+          Printf.printf "We define a new equation E%d: " e.id;
+          display_eq print_var (e.body,e.constant);
           print_string (operator_of_eq e.kind); print_string " 0"
-      | HYP e ->   
-          Printf.printf "We define E%d: " e.id; 
-          display_eq print_var (e.body,e.constant); 
+      | HYP e ->
+          Printf.printf "We define E%d: " e.id;
+          display_eq print_var (e.body,e.constant);
           print_string (operator_of_eq e.kind); print_string " 0\n"
       | FORGET_C e ->  Printf.printf "E%d is trivially satisfiable.\n" e
       | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
       | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
       | MERGE_EQ (e,e1,e2) ->
          Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e
-      | CONTRADICTION (e1,e2) -> 
+      | CONTRADICTION (e1,e2) ->
           Printf.printf
             "Equations E%d and E%d imply a contradiction on their \
             constant factors.\n" e1.id e2.id
@@ -216,20 +216,20 @@ let rec display_action print_var = function
           Printf.printf
             "Equations E%d and E%d state that their body is at the same time
             equal and different\n" e1.id e2.id
-      | CONSTANT_NOT_NUL (e,k) -> 
+      | CONSTANT_NOT_NUL (e,k) ->
           Printf.printf "Equation E%d states %s = 0.\n" e (sbi k)
-      | CONSTANT_NEG(e,k) -> 
+      | CONSTANT_NEG(e,k) ->
           Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k)
       | CONSTANT_NUL e ->
           Printf.printf "Inequation E%d states 0 != 0.\n" e
-      | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> 
+      | SPLIT_INEQ (e,(e1,l1),(e2,l2)) ->
           Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2;
           display_action print_var l1;
           print_newline ();
           display_action print_var l2;
           print_newline ()
     end; display_action print_var l
-  | [] -> 
+  | [] ->
       flush stdout
 
 let default_print_var v = Printf.sprintf "X%d" v (* For debugging *)
@@ -245,38 +245,38 @@ let nf_linear = Sort.list (fun x y -> x.v > y.v)
 
 let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
 
-let map_eq_linear f = 
+let map_eq_linear f =
   let rec loop = function
     | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l
-    | [] -> [] 
+    | [] -> []
   in
   loop
 
-let map_eq_afine f e = 
-  { id = e.id; kind = e.kind; body = map_eq_linear f e.body; 
+let map_eq_afine f e =
+  { id = e.id; kind = e.kind; body = map_eq_linear f e.body;
     constant = f e.constant }
 
 let negate_eq = map_eq_afine (fun x -> neg x)
 
-let rec sum p0 p1 = match (p0,p1) with 
+let rec sum p0 p1 = match (p0,p1) with
   | ([], l) -> l | (l, []) -> l
-  | (((x1::l1) as l1'), ((x2::l2) as l2')) -> 
+  | (((x1::l1) as l1'), ((x2::l2) as l2')) ->
       if x1.v = x2.v then
 	let c = x1.c + x2.c in
 	if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2
-      else if x1.v > x2.v then 
+      else if x1.v > x2.v then
 	x1 :: sum l1 l2'
-      else 
+      else
 	x2 :: sum l1' l2
 
-let sum_afine new_eq_id eq1 eq2 = 
+let sum_afine new_eq_id eq1 eq2 =
   { kind = eq1.kind; id = new_eq_id ();
     body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant }
 
 exception FACTOR1
 
 let rec chop_factor_1 = function
-  | x :: l -> 
+  | x :: l ->
     if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l')
   | [] -> raise FACTOR1
 
@@ -287,7 +287,7 @@ let rec chop_var v = function
   | [] -> raise CHOPVAR
 
 let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
-  if e = [] then begin 
+  if e = [] then begin
     match eq_flag with
       | EQUA ->
           if x =? zero then [] else begin
@@ -310,7 +310,7 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
     end else if gcd <> one then begin
       let c = floor_div x gcd in
       let d = x - c * gcd in
-      let new_eq = {id=id; kind=eq_flag; constant=c; 
+      let new_eq = {id=id; kind=eq_flag; constant=c;
                     body=map_eq_linear (fun c -> c / gcd) e} in
       add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
                  else DIVIDE_AND_APPROX(eq,new_eq,gcd,d));
@@ -320,15 +320,15 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
 let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2
                         ({body=e1; constant=c1} as eq1) =
   try
-    let (f,_) = chop_var v e1 in 
-    let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c 
+    let (f,_) = chop_var v e1 in
+    let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c
                 else failwith "eliminate_with_in" in
     let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in
     add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res
   with CHOPVAR -> eq1
 
 let omega_mod a b = a - b * floor_div (two * a + b) (two * b)
-let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = 
+let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
   let e = original.body in
   let sigma = new_var_id () in
   let smallest,var =
@@ -339,7 +339,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
   let m = smallest + one in
   let new_eq =
     { constant = omega_mod original.constant m;
-      body = {c= neg m;v=sigma} :: 
+      body = {c= neg m;v=sigma} ::
              map_eq_linear (fun a -> omega_mod a m) original.body;
       id = new_eq_id (); kind = EQUA } in
   let definition =
@@ -351,11 +351,11 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
 		    st_orig = original; st_coef = m; st_var = sigma});
   let new_eq = List.hd (normalize new_eq) in
   let eliminated_var, def = chop_var var new_eq.body in
-  let other_equations = 
+  let other_equations =
     Util.list_map_append
-      (fun e -> 
+      (fun e ->
         normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in
-  let inequations = 
+  let inequations =
     Util.list_map_append
       (fun e ->
         normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in
@@ -364,7 +364,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
   add_event (EXACT_DIVIDE (original',m));
   List.hd (normalize mod_original),other_equations,inequations
 
-let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = 
+let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) =
   if !debug then display_system print_var (e::other);
   try
     let v,def = chop_factor_1 e.body in
@@ -377,22 +377,22 @@ let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,
 
 let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) =
   let rec fst_eq_1 = function
-     (eq::l) -> 
+     (eq::l) ->
         if List.exists (fun x -> abs x.c =? one) eq.body then eq,l
         else let (eq',l') = fst_eq_1 l in (eq',eq::l')
    | [] -> raise Not_found in
   match sys_eq with
      [] -> if !debug then display_system print_var sys_ineq; sys_ineq
-   | (e1::rest) -> 
+   | (e1::rest) ->
        let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in
-       if eq.body = [] then 
+       if eq.body = [] then
          if eq.constant =? zero then begin
            add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq)
          end else begin
            add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE
          end
        else
-	 banerjee new_ids 
+	 banerjee new_ids
 	   (eliminate_one_equation new_ids (eq,other,sys_ineq))
 
 type kind = INVERTED | NORMAL
@@ -403,37 +403,37 @@ let redundancy_elimination new_eq_id system =
    | e -> e,NORMAL in
   let table = Hashtbl.create 7 in
   List.iter
-    (fun e -> 
+    (fun e ->
        let ({body=ne} as nx) ,kind = normal e in
        if ne = [] then
          if nx.constant <? zero then begin
            add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE
          end else add_event (FORGET_C nx.id)
        else
-       try 
+       try
          let (optnormal,optinvert) = Hashtbl.find table ne in
          let final =
            if kind = NORMAL then begin
-             match optnormal with 
-                Some v -> 
+             match optnormal with
+                Some v ->
                   let kept =
-                    if v.constant <? nx.constant 
+                    if v.constant <? nx.constant
                     then begin add_event (FORGET (v.id,nx.id));v end
                     else begin add_event (FORGET (nx.id,v.id));nx end in
                   (Some(kept),optinvert)
               | None -> Some nx,optinvert
            end else begin
-             match optinvert with 
+             match optinvert with
                 Some v ->
                   let _kept =
-                    if v.constant >? nx.constant 
+                    if v.constant >? nx.constant
                     then begin add_event (FORGET_I (v.id,nx.id));v end
                     else begin add_event (FORGET_I (nx.id,v.id));nx end in
                   (optnormal,Some(if v.constant >? nx.constant then v else nx))
               | None -> optnormal,Some nx
            end in
          begin match final with
-            (Some high, Some low) -> 
+            (Some high, Some low) ->
               if high.constant <? low.constant then begin
                 add_event(CONTRADICTION (high,negate_eq low));
                 raise UNSOLVABLE
@@ -442,21 +442,21 @@ let redundancy_elimination new_eq_id system =
          Hashtbl.remove table ne;
          Hashtbl.add table ne final
        with Not_found ->
-         Hashtbl.add table ne 
+         Hashtbl.add table ne
            (if kind = NORMAL then (Some nx,None) else (None,Some nx)))
     system;
   let accu_eq = ref [] in
   let accu_ineq = ref [] in
   Hashtbl.iter
-    (fun p0 p1 -> match (p0,p1) with 
+    (fun p0 p1 -> match (p0,p1) with
        | (e, (Some x, Some y)) when x.constant =? y.constant ->
            let id=new_eq_id () in
            add_event (MERGE_EQ(id,x,y.id));
            push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq
        | (e, (optnorm,optinvert)) ->
-           begin match optnorm with 
+           begin match optnorm with
                Some x -> push x accu_ineq | _ -> () end;
-           begin match optinvert with 
+           begin match optinvert with
                Some x -> push (negate_eq x) accu_ineq | _ -> () end)
     table;
   !accu_eq,!accu_ineq
@@ -465,7 +465,7 @@ exception SOLVED_SYSTEM
 
 let select_variable system =
   let table = Hashtbl.create 7 in
-  let push v c= 
+  let push v c=
     try let r = Hashtbl.find table v in r := max !r (abs c)
     with Not_found -> Hashtbl.add table v (ref (abs c)) in
   List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system;
@@ -480,7 +480,7 @@ let select_variable system =
   !vmin
 
 let classify v system =
-  List.fold_left 
+  List.fold_left
     (fun (not_occ,below,over) eq ->
        try let f,eq' = chop_var v eq.body in
        if f.c >=? zero then (not_occ,((f.c,eq) :: below),over)
@@ -493,18 +493,18 @@ let product new_eq_id dark_shadow low high =
     (fun accu (a,eq1) ->
        List.fold_left
          (fun accu (b,eq2) ->
-            let eq = 
+            let eq =
               sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1)
                 (map_eq_afine (fun c -> c * a) eq2) in
             add_event(SUM(eq.id,(b,eq1),(a,eq2)));
             match normalize eq with
 	      | [eq] ->
                   let final_eq =
-                    if dark_shadow then 
+                    if dark_shadow then
                       let delta = (a - one) * (b - one) in
                       add_event(WEAKEN(eq.id,delta));
-                      {id = eq.id; kind=INEQ; body = eq.body; 
-                       constant = eq.constant - delta} 
+                      {id = eq.id; kind=INEQ; body = eq.body;
+                       constant = eq.constant - delta}
                     else eq
                   in final_eq :: accu
               | (e::_) -> failwith "Product dardk"
@@ -519,7 +519,7 @@ let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system =
   if !debug then display_system print_var expanded; expanded
 
 let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
-  if List.exists (fun e -> e.kind = DISE) system then 
+  if List.exists (fun e -> e.kind = DISE) system then
     failwith "disequation in simplify";
   clear_history ();
   List.iter (fun e -> add_event (HYP e)) system;
@@ -528,23 +528,23 @@ let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
   let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
   let system = (eqs @ simp_eq,simp_ineq) in
   let rec loop1a system =
-    let sys_ineq = banerjee new_ids system in 
-    loop1b sys_ineq 
+    let sys_ineq = banerjee new_ids system in
+    loop1b sys_ineq
   and loop1b sys_ineq =
     let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in
-    if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) 
+    if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq)
   in
   let rec loop2 system =
     try
       let expanded = fourier_motzkin new_ids dark_shadow system in
       loop2 (loop1b expanded)
     with SOLVED_SYSTEM ->
-      if !debug then display_system print_var system; system 
+      if !debug then display_system print_var system; system
   in
   loop2 (loop1a system)
 
 let rec depend relie_on accu = function
-  | act :: l -> 
+  | act :: l ->
       begin match act with
 	| DIVIDE_AND_APPROX (e,_,_,_) ->
             if List.mem e.id relie_on then depend relie_on (act::accu) l
@@ -555,40 +555,40 @@ let rec depend relie_on accu = function
 	| WEAKEN (e,_) ->
             if List.mem e relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
-	| SUM (e,(_,e1),(_,e2)) -> 
-            if List.mem e relie_on then 
+	| SUM (e,(_,e1),(_,e2)) ->
+            if List.mem e relie_on then
 	      depend (e1.id::e2.id::relie_on) (act::accu) l
-            else 
+            else
 	      depend relie_on accu l
 	| STATE {st_new_eq=e;st_orig=o} ->
             if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
             else depend relie_on accu l
-	| HYP e ->   
+	| HYP e ->
             if List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| FORGET_C _ -> depend relie_on accu l
 	| FORGET _ -> depend relie_on accu l
 	| FORGET_I _ -> depend relie_on accu l
 	| MERGE_EQ (e,e1,e2) ->
-            if List.mem e relie_on then 
+            if List.mem e relie_on then
 	      depend (e1.id::e2::relie_on) (act::accu) l
-            else 
+            else
 	      depend relie_on accu l
 	| NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l
-	| CONTRADICTION (e1,e2) -> 
+	| CONTRADICTION (e1,e2) ->
 	    depend (e1.id::e2.id::relie_on) (act::accu) l
 	| CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l
 	| CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l
 	| CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l
-	| NEGATE_CONTRADICT (e1,e2,_) -> 
+	| NEGATE_CONTRADICT (e1,e2,_) ->
             depend (e1.id::e2.id::relie_on) (act::accu) l
 	| SPLIT_INEQ _ -> failwith "depend"
       end
   | [] -> relie_on, accu
 
 (*
-let depend relie_on accu trace = 
-  Printf.printf "Longueur de la trace initiale : %d\n" 
+let depend relie_on accu trace =
+  Printf.printf "Longueur de la trace initiale : %d\n"
     (trace_length trace + trace_length accu);
   let rel',trace' = depend relie_on accu trace in
   Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
@@ -598,20 +598,20 @@ let depend relie_on accu trace =
 let solve (new_eq_id,new_eq_var,print_var) system =
   try let _ = simplify new_eq_id false system in failwith "no contradiction"
   with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
-      
+
 let negation (eqs,ineqs) =
   let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in
   let normal = function
     | ({body=f::_} as e) when f.c <? zero ->  negate_eq e, INVERTED
     | e -> e,NORMAL in
   let table = Hashtbl.create 7 in
-  List.iter (fun e -> 
+  List.iter (fun e ->
                let {body=ne;constant=c} ,kind = normal e in
                Hashtbl.add table (ne,c) (kind,e)) diseq;
   List.iter (fun e ->
                assert (e.kind = EQUA);
                let {body=ne;constant=c},kind = normal e in
-               try 
+               try
 		 let (kind',e') = Hashtbl.find table (ne,c) in
 		 add_event (NEGATE_CONTRADICT (e,e',kind=kind'));
 		 raise UNSOLVABLE
@@ -625,39 +625,39 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
   (* Initial simplification phase *)
   let rec loop1a system =
     negation system;
-    let sys_ineq = banerjee new_ids system in 
-    loop1b sys_ineq 
+    let sys_ineq = banerjee new_ids system in
+    loop1b sys_ineq
   and loop1b sys_ineq =
     let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in
     let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
     if simp_eq = [] then dise @ simp_ineq
-    else loop1a (simp_eq,dise @ simp_ineq) 
+    else loop1a (simp_eq,dise @ simp_ineq)
   in
   let rec loop2 system =
     try
       let expanded = fourier_motzkin new_ids false system in
       loop2 (loop1b expanded)
-    with SOLVED_SYSTEM -> if !debug then display_system print_var system; system 
+    with SOLVED_SYSTEM -> if !debug then display_system print_var system; system
   in
-  let rec explode_diseq = function 
+  let rec explode_diseq = function
     | (de::diseq,ineqs,expl_map) ->
-	let id1 = new_eq_id () 
+	let id1 = new_eq_id ()
 	and id2 = new_eq_id () in
-	let e1 = 
+	let e1 =
           {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in
-	let e2 = 
-	  {id = id2; kind=INEQ; body = map_eq_linear neg de.body; 
+	let e2 =
+	  {id = id2; kind=INEQ; body = map_eq_linear neg de.body;
            constant = neg de.constant - one} in
 	let new_sys =
-          List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) 
-	    ineqs @ 
-          List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) 
-	    ineqs 
+          List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys))
+	    ineqs @
+          List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys))
+	    ineqs
 	in
 	explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map)
-    | ([],ineqs,expl_map) -> ineqs,expl_map 
+    | ([],ineqs,expl_map) -> ineqs,expl_map
   in
-  try 
+  try
     let system = Util.list_map_append normalize system in
     let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
     let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in
@@ -669,45 +669,45 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
     let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in
     let all_solutions =
       List.map
-        (fun (decomp,sys) -> 
+        (fun (decomp,sys) ->
            clear_history ();
            try let _ = loop2 sys in raise NO_CONTRADICTION
-           with UNSOLVABLE -> 
+           with UNSOLVABLE ->
              let relie_on,path = depend [] [] (history ()) in
              let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in
              let red = List.map (fun (x,_,_) -> x) dc in
              (red,relie_on,decomp,path))
-        sys_exploded 
+        sys_exploded
     in
-    let max_count sys = 
+    let max_count sys =
       let tbl = Hashtbl.create 7 in
-      let augment x = 
-        try incr (Hashtbl.find tbl x) 
+      let augment x =
+        try incr (Hashtbl.find tbl x)
 	with Not_found -> Hashtbl.add tbl x (ref 1) in
       let eq = ref (-1) and c = ref 0 in
-      List.iter (function 
+      List.iter (function
 		   | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on))
                    | (l,_,_,_) -> List.iter augment l) sys;
       Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl;
-      !eq 
+      !eq
     in
-    let rec solve systems = 
-      try 
-	let id = max_count systems in 
-        let rec sign = function 
-	  | ((id',_,b)::l) -> if id=id' then b else sign l 
+    let rec solve systems =
+      try
+	let id = max_count systems in
+        let rec sign = function
+	  | ((id',_,b)::l) -> if id=id' then b else sign l
           | [] -> failwith "solve" in
         let s1,s2 =
           List.partition (fun (_,_,decomp,_) -> sign decomp) systems in
-        let s1' = 
+        let s1' =
 	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
-        let s2' = 
+        let s2' =
 	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
-        let (r1,relie1) = solve s1' 
+        let (r1,relie1) = solve s1'
 	and (r2,relie2) = solve s2' in
 	let (eq,id1,id2) = List.assoc id explode_map in
 	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
-      with FULL_SOLUTION (x0,x1) -> (x0,x1) 
+      with FULL_SOLUTION (x0,x1) -> (x0,x1)
     in
     let act,relie_on = solve all_solutions in
     snd(depend relie_on act first_segment)
diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mllib
new file mode 100644
index 00000000..2b387fdc
--- /dev/null
+++ b/plugins/omega/omega_plugin.mllib
@@ -0,0 +1,4 @@
+Omega
+Coq_omega
+G_omega
+Omega_plugin_mod
diff --git a/plugins/omega/vo.itarget b/plugins/omega/vo.itarget
new file mode 100644
index 00000000..9d9a77a8
--- /dev/null
+++ b/plugins/omega/vo.itarget
@@ -0,0 +1,4 @@
+OmegaLemmas.vo
+OmegaPlugin.vo
+Omega.vo
+PreOmega.vo
diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget
new file mode 100644
index 00000000..56aa42b0
--- /dev/null
+++ b/plugins/plugins.itarget
@@ -0,0 +1,3 @@
+pluginsopt.otarget
+pluginsbyte.otarget
+pluginsvo.otarget
\ No newline at end of file
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
new file mode 100644
index 00000000..1485c147
--- /dev/null
+++ b/plugins/pluginsbyte.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cma
+setoid_ring/newring_plugin.cma
+extraction/extraction_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
+dp/dp_plugin.cma
+xml/xml_plugin.cma
+subtac/subtac_plugin.cma
+ring/ring_plugin.cma
+cc/cc_plugin.cma
+nsatz/nsatz_plugin.cma
+funind/recdef_plugin.cma
+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
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
new file mode 100644
index 00000000..5d502411
--- /dev/null
+++ b/plugins/pluginsdyn.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cmxs
+setoid_ring/newring_plugin.cmxs
+extraction/extraction_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
+dp/dp_plugin.cmxs
+xml/xml_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
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
new file mode 100644
index 00000000..2f72dab8
--- /dev/null
+++ b/plugins/pluginsopt.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cmxa
+setoid_ring/newring_plugin.cmxa
+extraction/extraction_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
+dp/dp_plugin.cmxa
+xml/xml_plugin.cmxa
+subtac/subtac_plugin.cmxa
+ring/ring_plugin.cmxa
+cc/cc_plugin.cmxa
+nsatz/nsatz_plugin.cmxa
+funind/recdef_plugin.cmxa
+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
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
new file mode 100644
index 00000000..db56534c
--- /dev/null
+++ b/plugins/pluginsvo.itarget
@@ -0,0 +1,13 @@
+dp/vo.otarget
+field/vo.otarget
+fourier/vo.otarget
+funind/vo.otarget
+nsatz/vo.otarget
+micromega/vo.otarget
+omega/vo.otarget
+quote/vo.otarget
+ring/vo.otarget
+romega/vo.otarget
+rtauto/vo.otarget
+setoid_ring/vo.otarget
+extraction/vo.otarget
\ No newline at end of file
diff --git a/contrib/ring/Quote.v b/plugins/quote/Quote.v
index 6f7414a3..11726675 100644
--- a/contrib/ring/Quote.v
+++ b/plugins/quote/Quote.v
@@ -6,7 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Quote.v 6295 2004-11-12 16:40:39Z gregoire $ *)
+(* $Id$ *)
+
+Declare ML Module "quote_plugin".
 
 (***********************************************************************
   The "abstract" type index is defined to represent variables.
@@ -15,7 +17,7 @@
   index_eq : index -> bool
   index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
   index_lt : index -> bool
-  varmap : Type -> Type.	
+  varmap : Type -> Type.
   varmap_find : (A:Type)A -> index -> (varmap A) -> A.
 
   The first arg. of varmap_find is the default value to take
diff --git a/contrib/ring/g_quote.ml4 b/plugins/quote/g_quote.ml4
index d0058026..bdeb9844 100644
--- a/contrib/ring/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -8,11 +8,24 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_quote.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
+(* $Id$ *)
 
+open Util
+open Tacexpr
 open Quote
 
+let make_cont k x =
+  let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> fst k)) in
+  let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in
+  let tac = <:tactic<let cont := $k in cont $x>> in
+  Tacinterp.interp tac
+
 TACTIC EXTEND quote
   [ "quote" ident(f) ] -> [ quote f [] ]
 | [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ]
+| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] ->
+  [ gen_quote (make_cont k) c f [] ]
+| [ "quote" ident(f) "[" ne_ident_list(lc) "]"
+    "in" constr(c) "using" tactic(k) ] ->
+  [ gen_quote (make_cont k) c f lc ]
 END
diff --git a/contrib/ring/quote.ml b/plugins/quote/quote.ml
index 7cd22a36..2e4d07d6 100644
--- a/contrib/ring/quote.ml
+++ b/plugins/quote/quote.ml
@@ -6,24 +6,24 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: quote.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
+(* $Id$ *)
 
 (* The `Quote' tactic *)
 
-(* The basic idea is to automatize the inversion of interpetation functions 
-   in 2-level approach 
+(* The basic idea is to automatize the inversion of interpetation functions
+   in 2-level approach
 
    Examples are given in \texttt{theories/DEMOS/DemoQuote.v}
 
-   Suppose you have a langage \texttt{L} of 'abstract terms' 
-   and a type \texttt{A} of 'concrete terms' 
+   Suppose you have a langage \texttt{L} of 'abstract terms'
+   and a type \texttt{A} of 'concrete terms'
    and a function \texttt{f : L -> (varmap A L) -> A}.
 
-   Then, the tactic \texttt{Quote f} will replace an
-   expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} 
+   Then, the tactic \texttt{quote f} will replace an
+   expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)}
    such that \texttt{e} and \texttt{(f vm t)} are convertible.
 
-   The problem is then inverting the function f.
+   The problem is then inverting the function \texttt{f}.
 
    The tactic works when:
 
@@ -43,24 +43,24 @@
      When there are both a variable leaf and a constant leaf, there is
      an ambiguity on inversion. The term t can be either the
      interpretation of \texttt{(Cconst t)} or the interpretation of
-     (\texttt{Cvar}~$i$) in a variables map containing the binding $i
+     (\texttt{Cvar}~$i$) in a variable map containing the binding $i
      \rightarrow$~\texttt{t}. How to discriminate between these
-     choices ?
-     
-     To solve the dilemma, one gives to \texttt{Quote} a list of
+     choices?
+
+     To solve the dilemma, one gives to \texttt{quote} a list of
      \emph{constant constructors}: a term will be considered as a
-     constant if it is either a constant constructor of the
+     constant if it is either a constant constructor or the
      application of a constant constructor to constants. For example
      the list \verb+[S, O]+ defines the closed natural
      numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is
-     not. 
+     not.
 
      The definition of constants vary for each application of the
-     tactic, so it can even be different for two applications of 
-     \texttt{Quote} with the same function.
-     
+     tactic, so it can even be different for two applications of
+     \texttt{quote} with the same function.
+
    \item \texttt{f} is a quite simple fixpoint on
-     \texttt{L}. In particular, \texttt{f} must verify: 
+     \texttt{L}. In particular, \texttt{f} must verify:
 
 \begin{verbatim}
      (f (Cvar i)) = (varmap_find vm default_value i)
@@ -71,18 +71,18 @@
 
      where \texttt{index} and \texttt{varmap\_find} are those defined
      the \texttt{Quote} module. \emph{The tactic won't work with
-     user's own variables map !!}  It is mandatory to use the
-     variables map defined in module \texttt{Quote}.
-     
+     user's own variables map!!}  It is mandatory to use the
+     variable map defined in module \texttt{Quote}.
+
    \end{itemize}
 
    The method to proceed is then clear:
 
    \begin{itemize}
    \item Start with an empty hashtable of "registed leafs"
-      that map constr to integers and a "variable counter" equal to 0.
-    \item Try to match the term with every right hand side of the 
-      definition of f.
+      that maps constr to integers and a "variable counter" equal to 0.
+    \item Try to match the term with every right hand side of the
+      definition of \texttt{f}.
 
       If there is one match, returns the correponding left hand
       side and call yourself recursively to get the arguments of this
@@ -92,17 +92,17 @@
       interpretation of either a variable or a constant.
 
       If it is a constant, return \texttt{Cconst} applied to that
-      constant. 
+      constant.
 
-      If not, it is a variable. Look in the hashtable 
+      If not, it is a variable. Look in the hashtable
       if this leaf has been already encountered. If not, increment
-      the variables counter and add an entry to the hashtable; then
+      the variable counter and add an entry to the hashtable; then
       return \texttt{(Cvar !variables\_counter)}
    \end{itemize}
 *)
 
 
-(*i*) 
+(*i*)
 open Pp
 open Util
 open Names
@@ -119,7 +119,7 @@ open Tacexpr
   We do that lazily, because this code can be linked before
   the constants are loaded in the environment *)
 
-let constant dir s = Coqlib.gen_constant "Quote" ("ring"::dir) s
+let constant dir s = Coqlib.gen_constant "Quote" ("quote"::dir) s
 
 let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm")
 let coq_Node_vm = lazy (constant ["Quote"] "Node_vm")
@@ -134,19 +134,20 @@ let coq_End_idx = lazy (constant ["Quote"] "End_idx")
 For a function like:
 
 \begin{verbatim}
-  Fixpoint interp[vm:(varmap Prop); f:form] :=
-     Cases f of
-     | (f_and f1  f1 f2) => (interp f1)/\(interp f2)
-     | (f_or f1  f1 f2) => (interp f1)\/(interp f2)
-     | (f_var i) => (varmap_find Prop default_v i vm)
-     | (f_const c) => c
+  Fixpoint interp (vm:varmap Prop) (f:form) :=
+     match f with
+       | f_and f1 f1 f2 => (interp f1) /\ (interp f2)
+       | f_or f1 f1 f2 => (interp f1) \/ (interp f2)
+       | f_var i => varmap_find Prop default_v i vm
+       | f_const c => c
+     end.
 \end{verbatim}
 
 With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the
-corresponding scheme will be: 
+corresponding scheme will be:
 
 \begin{verbatim}
-  {normal_lhs_rhs = 
+  {normal_lhs_rhs =
      [ "(f_and ?1 ?2)", "?1 /\ ?2";
        "(f_or ?1 ?2)", " ?1 \/ ?2";];
    return_type = "Prop";
@@ -156,17 +157,17 @@ corresponding scheme will be:
   }
 \end{verbatim}
 
-If there is no constructor for variables in the type \texttt{form}, 
+If there is no constructor for variables in the type \texttt{form},
 then [variable_lhs] is [None]. Idem for constants and
 [constant_lhs]. Both cannot be equal to [None].
 
-The metas in the RHS must correspond to those in the LHS (one cannot 
-exchange ?1 and ?2 in the example above) 
+The metas in the RHS must correspond to those in the LHS (one cannot
+exchange ?1 and ?2 in the example above)
 
 *)
 
 module ConstrSet = Set.Make(
-  struct 
+  struct
     type t = constr
     let compare = (Pervasives.compare : t->t->int)
   end)
@@ -179,7 +180,7 @@ type inversion_scheme = {
   constant_lhs : constr option }
 
 (*s [compute_ivs gl f cs] computes the inversion scheme associated to
-  [f:constr] with constants list [cs:constr list] in the context of 
+  [f:constr] with constants list [cs:constr list] in the context of
   goal [gl]. This function uses the auxiliary functions
   [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *)
 
@@ -191,7 +192,7 @@ let decomp_term c = kind_of_term (strip_outer_cast c)
   ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive
   type [typ] *)
 
-let coerce_meta_out id = 
+let coerce_meta_out id =
   let s = string_of_id id in
   int_of_string (String.sub s 1 (String.length s - 1))
 let coerce_meta_in n =
@@ -199,7 +200,7 @@ let coerce_meta_in n =
 
 let compute_lhs typ i nargsi =
   match kind_of_term typ with
-    | Ind(sp,0) -> 
+    | Ind(sp,0) ->
         let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in
         mkApp (mkConstruct ((sp,0),i+1), argsi)
     | _ -> i_can't_do_that ()
@@ -208,15 +209,15 @@ let compute_lhs typ i nargsi =
   replaced by meta-variables ?i corresponding to those in the LHS *)
 
 let compute_rhs bodyi index_of_f =
-  let rec aux c = 
+  let rec aux c =
     match kind_of_term c with
-      | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> 
-          let i = destRel (array_last args) in 
+      | App (j, args) when j = mkRel (index_of_f) (* recursive call *) ->
+          let i = destRel (array_last args) in
 	  PMeta (Some (coerce_meta_in i))
       | App (f,args) ->
-          PApp (pattern_of_constr f, Array.map aux args)
-      | Cast (c,_,_) -> aux c 
-      | _ -> pattern_of_constr c
+          PApp (snd (pattern_of_constr Evd.empty f), Array.map aux args)
+      | Cast (c,_,_) -> aux c
+      | _ -> snd (pattern_of_constr Evd.empty c)
   in
   aux bodyi
 
@@ -235,34 +236,34 @@ let compute_ivs gl f cs =
               and v_lhs = ref (None : constr option)
               and c_lhs = ref (None : constr option) in
               Array.iteri
-                (fun i ci -> 
+                (fun i ci ->
                    let argsi, bodyi = decompose_lam ci in
                    let nargsi = List.length argsi in
            (* REL (narg3 + nargsi + 1) is f *)
            (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
            (* REL 1 to REL nargsi are argsi (reverse order) *)
            (* First we test if the RHS is the RHS for constants *)
-                   if bodyi = mkRel 1 then 
+                   if bodyi = mkRel 1 then
                      c_lhs := Some (compute_lhs (snd (List.hd args3))
                                       i nargsi)
            (* Then we test if the RHS is the RHS for variables *)
-                   else begin match decompose_app bodyi with 
+                   else begin match decompose_app bodyi with
                      | vmf, [_; _; a3; a4 ]
                          when isRel a3 & isRel a4 &
-			   pf_conv_x gl vmf 
+			   pf_conv_x gl vmf
                            (Lazy.force coq_varmap_find)->
-                             v_lhs := Some (compute_lhs 
+                             v_lhs := Some (compute_lhs
                                               (snd (List.hd args3))
                                               i nargsi)
            (* Third case: this is a normal LHS-RHS *)
-                     | _ -> 
+                     | _ ->
                          n_lhs_rhs :=
                          (compute_lhs (snd (List.hd args3)) i nargsi,
                           compute_rhs bodyi (nargs3 + nargsi + 1))
                          :: !n_lhs_rhs
-                   end) 
+                   end)
                 lci;
-	      
+
               if !c_lhs = None & !v_lhs = None then i_can't_do_that ();
 
 	      (* The Cases predicate is a lambda; we assume no dependency *)
@@ -270,14 +271,14 @@ let compute_ivs gl f cs =
 		| Lambda (_,_,p) -> Termops.pop p
 		| _ -> p
 	      in
-              
+
               { normal_lhs_rhs = List.rev !n_lhs_rhs;
                 variable_lhs = !v_lhs;
                 return_type = p;
                 constants = List.fold_right ConstrSet.add cs ConstrSet.empty;
                 constant_lhs = !c_lhs }
-                     
-              | _ -> i_can't_do_that ()
+
+          | _ -> i_can't_do_that ()
         end
     |_ -> i_can't_do_that ()
 
@@ -287,23 +288,23 @@ let compute_ivs gl f cs =
   function
 \item handle the case of simple mutual inductive (for example terms
   and lists of terms) formulas with the corresponding mutual
-  recursvive interpretation functions. 
+  recursvive interpretation functions.
 \end{itemize}
-*) 
+*)
 
 (*s Stuff to build variables map, currently implemented as complete
 binary search trees (see file \texttt{Quote.v}) *)
 
-(* First the function to distinghish between constants (closed terms) 
+(* First the function to distinghish between constants (closed terms)
    and variables (open terms) *)
 
 let rec closed_under cset t =
   (ConstrSet.mem t cset) or
   (match (kind_of_term t) with
-     | Cast(c,_,_) -> closed_under cset c  
+     | Cast(c,_,_) -> closed_under cset c
      | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
      | _ -> false)
-    
+
 (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
    binary search tree containing the [ci], that is:
 
@@ -317,35 +318,35 @@ let rec closed_under cset t =
 
 The second argument is a constr (the common type of the [ci])
 *)
-    
+
 let btree_of_array a ty =
   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_vm  
+  let node = Lazy.force coq_Node_vm
   and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in
   let rec aux n =
-    if n > size_of_a 
+    if n > size_of_a
     then empty
-    else if  n > semi_size_of_a 
+    else if  n > semi_size_of_a
     then mkApp (node, [| ty; a.(n-1); empty; empty |])
     else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |])
-  in 
+  in
   aux 1
 
 (*s [btree_of_array] and [path_of_int] verify the following invariant:\\
-   {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] 
+   {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)]
   = [a.(n)]\\
   [n] must be [> 0] *)
 
-let path_of_int n = 
+let path_of_int n =
   (* returns the list of digits of n in reverse order with
      initial 1 removed *)
   let rec digits_of_int n =
-    if n=1 then [] 
+    if n=1 then []
     else (n mod 2 = 1)::(digits_of_int (n lsr 1))
   in
-  List.fold_right 
-    (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx 
+  List.fold_right
+    (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx
                          else Lazy.force coq_Left_idx),
                          [| c |]))
     (List.rev (digits_of_int n))
@@ -359,88 +360,88 @@ let path_of_int n =
 (* [subterm t t'] tests if constr [t'] occurs in [t] *)
 (* This function does not descend under binders (lambda and Cases) *)
 
-let rec subterm gl (t : constr) (t' : constr) = 
+let rec subterm gl (t : constr) (t' : constr) =
   (pf_conv_x gl t t') or
-  (match (kind_of_term t) with 
+  (match (kind_of_term t) with
      | App (f,args) -> array_exists (fun t -> subterm gl t t') args
      | Cast(t,_,_) -> (subterm gl t t')
      | _ -> false)
-           
+
 (*s We want to sort the list according to reverse subterm order. *)
 (* Since it's a partial order the algoritm of Sort.list won't work !! *)
 
-let rec sort_subterm gl l = 
+let rec sort_subterm gl l =
   let rec insert c = function
     | [] -> [c]
     | (h::t as l) when c = h -> l (* Avoid doing the same work twice *)
-    | h::t -> if subterm gl c h then c::h::t else h::(insert c t)  
-  in 
-  match l with 
+    | h::t -> if subterm gl c h then c::h::t else h::(insert c t)
+  in
+  match l with
     | [] -> []
     | h::t -> insert h (sort_subterm gl t)
 
 (*s Now we are able to do the inversion itself.
   We destructurate the term and use an imperative hashtable
-  to store leafs that are already encountered. 
+  to store leafs that are already encountered.
   The type of arguments is:\\
   [ivs : inversion_scheme]\\
   [lc: constr list]\\
   [gl: goal sigma]\\ *)
 
 let quote_terms ivs lc gl =
-  Coqlib.check_required_library ["Coq";"ring";"Quote"];
+  Coqlib.check_required_library ["Coq";"quote";"Quote"];
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    let rec auxl l = 
+  let rec aux c =
+    let rec auxl l =
       match l with
         | (lhs, rhs)::tail ->
-            begin try 
+            begin try
               let s1 = matches rhs c in
               let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1
 	      in
               Termops.subst_meta s2 lhs
             with PatternMatchingFailure -> auxl tail
-            end 
-        |  [] -> 
-             begin match ivs.variable_lhs with 
-               | None -> 
+            end
+        |  [] ->
+             begin match ivs.variable_lhs with
+               | None ->
                    begin match ivs.constant_lhs with
                      | Some c_lhs -> Termops.subst_meta [1, c] c_lhs
                      | None -> anomaly "invalid inversion scheme for quote"
                    end
-               | Some var_lhs -> 
+               | Some var_lhs ->
                    begin match ivs.constant_lhs with
                      | Some c_lhs when closed_under ivs.constants c ->
 			 Termops.subst_meta [1, c] c_lhs
-                     | _ -> 
-			 begin 
-                           try Hashtbl.find varhash c 
-                           with Not_found -> 
-                             let newvar = 
-                               Termops.subst_meta [1, (path_of_int !counter)] 
+                     | _ ->
+			 begin
+                           try Hashtbl.find varhash c
+                           with Not_found ->
+                             let newvar =
+                               Termops.subst_meta [1, (path_of_int !counter)]
 				 var_lhs in
-                             begin 
+                             begin
                                incr counter;
                                varlist := c :: !varlist;
                                Hashtbl.add varhash c newvar;
                                newvar
                              end
 			 end
-                   end 
+                   end
              end
-    in 
-    auxl ivs.normal_lhs_rhs 
+    in
+    auxl ivs.normal_lhs_rhs
   in
-  let lp = List.map aux lc in 
-  (lp, (btree_of_array (Array.of_list (List.rev !varlist)) 
+  let lp = List.map aux lc in
+  (lp, (btree_of_array (Array.of_list (List.rev !varlist))
           ivs.return_type ))
 
-(*s actually we could "quote" a list of terms instead of the 
-  conclusion of current goal. Ring for example needs that, but Ring doesn't
-  uses Quote yet. *)
- 
+(*s actually we could "quote" a list of terms instead of a single
+  term. Ring for example needs that, but Ring doesn't use Quote
+  yet. *)
+
 let quote f lid gl =
   let f = pf_global gl f in
   let cl = List.map (pf_global gl) lid in
@@ -453,7 +454,19 @@ let quote f lid gl =
     | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl
     | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl
 
-(*i 
+let gen_quote cont c f lid gl =
+  let f = pf_global gl f in
+  let cl = List.map (pf_global gl) lid in
+  let ivs = compute_ivs gl f cl in
+  let (p, vm) = match quote_terms ivs [c] gl with
+    | [p], vm -> (p,vm)
+    | _ -> assert false
+  in
+  match ivs.variable_lhs with
+    | None -> cont (mkApp (f, [| p |])) gl
+    | Some _ -> cont (mkApp (f, [| vm; p |])) gl
+
+(*i
 
 Just testing ...
 
@@ -463,13 +476,13 @@ open Quote;;
 let r = raw_constr_of_string;;
 
 let ivs = {
-  normal_lhs_rhs = 
+  normal_lhs_rhs =
    [ r "(f_and ?1 ?2)", r "?1/\?2";
      r "(f_not ?1)", r "~?1"];
   variable_lhs = Some (r "(f_atom ?1)");
   return_type = r "Prop";
   constants = ConstrSet.empty;
-  constant_lhs = (r "nat") 
+  constant_lhs = (r "nat")
 };;
 
 let t1 = r "True/\(True /\ ~False)";;
@@ -479,7 +492,7 @@ quote_term ivs () t1;;
 quote_term ivs () t2;;
 
 let ivs2 =
-  normal_lhs_rhs = 
+  normal_lhs_rhs =
    [ r "(f_and ?1 ?2)", r "?1/\?2";
      r "(f_not ?1)", r "~?1"
      r "True", r "f_true"];
diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib
new file mode 100644
index 00000000..d1b3ccbe
--- /dev/null
+++ b/plugins/quote/quote_plugin.mllib
@@ -0,0 +1,3 @@
+Quote
+G_quote
+Quote_plugin_mod
diff --git a/plugins/quote/vo.itarget b/plugins/quote/vo.itarget
new file mode 100644
index 00000000..7a44fc5a
--- /dev/null
+++ b/plugins/quote/vo.itarget
@@ -0,0 +1 @@
+Quote.vo
\ No newline at end of file
diff --git a/contrib/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
index e062b731..231b5fbb 100644
--- a/contrib/ring/LegacyArithRing.v
+++ b/plugins/ring/LegacyArithRing.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id$ *)
 
 (* Instantiation of the Ring tactic for the naturals of Arith $*)
 
@@ -73,14 +73,14 @@ Ltac rewrite_S_to_plus :=
   match goal with
   |  |- (?X1 = ?X2) =>
       try
-       let t1 :=  
+       let t1 :=
        (**)  (**)
        rewrite_S_to_plus_term X1
        with t2 := rewrite_S_to_plus_term X2 in
        change (t1 = t2) in |- *
   |  |- (?X1 = ?X2) =>
       try
-       let t1 := 
+       let t1 :=
        (**)  (**)
        rewrite_S_to_plus_term X1
        with t2 := rewrite_S_to_plus_term X2 in
diff --git a/contrib/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
index c689fc40..ee9fb376 100644
--- a/contrib/ring/LegacyNArithRing.v
+++ b/plugins/ring/LegacyNArithRing.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id$ *)
 
 (* Instantiation of the Ring tactic for the binary natural numbers *)
 
diff --git a/contrib/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
index 40323b3d..4ae85baf 100644
--- a/contrib/ring/LegacyRing.v
+++ b/plugins/ring/LegacyRing.v
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyRing.v 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id$ *)
 
 Require Export Bool.
 Require Export LegacyRing_theory.
 Require Export Quote.
 Require Export Ring_normalize.
 Require Export Ring_abstract.
+Declare ML Module "ring_plugin".
 
 (* As an example, we provide an instantation for bool. *)
 (* Other instatiations are given in ArithRing and ZArithRing in the
diff --git a/contrib/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
index d15d18a6..30d29515 100644
--- a/contrib/ring/LegacyRing_theory.v
+++ b/plugins/ring/LegacyRing_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyRing_theory.v 9370 2006-11-13 09:21:31Z herbelin $ *)
+(* $Id$ *)
 
 Require Export Bool.
 
@@ -19,8 +19,8 @@ Variable Aplus : A -> A -> A.
 Variable Amult : A -> A -> A.
 Variable Aone : A.
 Variable Azero : A.
-(* There is also a "weakly decidable" equality on A. That means 
-  that if (A_eq x y)=true then x=y but x=y can arise when 
+(* There is also a "weakly decidable" equality on A. That means
+  that if (A_eq x y)=true then x=y but x=y can arise when
   (A_eq x y)=false. On an abstract ring the function [x,y:A]false
   is a good choice. The proof of A_eq_prop is in this case easy. *)
 Variable Aeq : A -> A -> bool.
@@ -30,7 +30,7 @@ Infix "*" := Amult (at level 40, left associativity).
 Notation "0" := Azero.
 Notation "1" := Aone.
 
-Record Semi_Ring_Theory : Prop := 
+Record Semi_Ring_Theory : Prop :=
   {SR_plus_comm : forall n m:A, n + m = m + n;
    SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
    SR_mult_comm : forall n m:A, n * m = m * n;
@@ -49,7 +49,7 @@ Let plus_assoc := SR_plus_assoc T.
 Let mult_comm := SR_mult_comm T.
 Let mult_assoc := SR_mult_assoc T.
 Let plus_zero_left := SR_plus_zero_left T.
-Let mult_one_left := SR_mult_one_left T. 
+Let mult_one_left := SR_mult_one_left T.
 Let mult_zero_left := SR_mult_zero_left T.
 Let distr_left := SR_distr_left T.
 (*Let plus_reg_left := SR_plus_reg_left T.*)
@@ -58,7 +58,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
   mult_one_left mult_zero_left distr_left (*plus_reg_left*).
 
 (* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *) 
+  not symmetry *)
 Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
 symmetry  in |- *; eauto. Qed.
 
@@ -150,7 +150,7 @@ Notation "0" := Azero.
 Notation "1" := Aone.
 Notation "- x" := (Aopp x).
 
-Record Ring_Theory : Prop := 
+Record Ring_Theory : Prop :=
   {Th_plus_comm : forall n m:A, n + m = m + n;
    Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
    Th_mult_comm : forall n m:A, n * m = m * n;
@@ -168,7 +168,7 @@ Let plus_assoc := Th_plus_assoc T.
 Let mult_comm := Th_mult_comm T.
 Let mult_assoc := Th_mult_assoc T.
 Let plus_zero_left := Th_plus_zero_left T.
-Let mult_one_left := Th_mult_one_left T. 
+Let mult_one_left := Th_mult_one_left T.
 Let opp_def := Th_opp_def T.
 Let distr_left := Th_distr_left T.
 
@@ -176,7 +176,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
   mult_one_left opp_def distr_left.
 
 (* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *) 
+  not symmetry *)
 Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
 symmetry  in |- *; eauto. Qed.
 
@@ -331,7 +331,7 @@ Qed.
 
 Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
 intros.
-eapply Th_plus_reg_left with n. 
+eapply Th_plus_reg_left with n.
 rewrite (plus_comm n m).
 rewrite (plus_comm n p).
 auto.
@@ -354,7 +354,7 @@ Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
 Unset Implicit Arguments.
 
 Definition Semi_Ring_Theory_of :
-  forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) 
+  forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A)
     (Aopp:A -> A) (Aeq:A -> A -> bool),
     Ring_Theory Aplus Amult Aone Azero Aopp Aeq ->
     Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
diff --git a/contrib/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
index a410fbc5..68a0dd27 100644
--- a/contrib/ring/LegacyZArithRing.v
+++ b/plugins/ring/LegacyZArithRing.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *)
+(* $Id$ *)
 
 (* Instantiation of the Ring tactic for the binary integers of ZArith *)
 
diff --git a/contrib/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
index c2467ebf..2a9df21b 100644
--- a/contrib/ring/Ring_abstract.v
+++ b/plugins/ring/Ring_abstract.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_abstract.v 9370 2006-11-13 09:21:31Z herbelin $ *)
+(* $Id$ *)
 
 Require Import LegacyRing_theory.
 Require Import Quote.
@@ -164,7 +164,7 @@ Lemma abstract_varlist_insert_ok :
   trivial.
 
   simpl in |- *; intros.
-  elim (varlist_lt l v); simpl in |- *.  	
+  elim (varlist_lt l v); simpl in |- *.
   eauto.
   rewrite iacs_aux_ok.
   rewrite H; auto.
@@ -175,7 +175,7 @@ Lemma abstract_sum_merge_ok :
  forall x y:abstract_sum,
    interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).
 
-Proof.  
+Proof.
   simple induction x.
   trivial.
   simple induction y; intros.
@@ -240,13 +240,13 @@ End abstract_semi_rings.
 Section abstract_rings.
 
 (* In abstract polynomials there is no constants other
-   than 0 and 1. An abstract ring is a ring whose operations plus, 
+   than 0 and 1. An abstract ring is a ring whose operations plus,
    and mult are not functions but  constructors. In other words,
    when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
    term. "closed" mean here "without plus and mult". *)
 
 (* this section is not parametrized by a (semi-)ring.
-   Nevertheless, they are two different types for semi-rings and rings 
+   Nevertheless, they are two different types for semi-rings and rings
    and there will be 2 correction theorems *)
 
 Inductive apolynomial : Type :=
@@ -488,7 +488,7 @@ Lemma signed_sum_merge_ok :
   intro Heq; rewrite (Heq I).
   rewrite H.
   repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T). 
+  rewrite (Th_plus_permute T).
   repeat rewrite (Th_plus_assoc T).
   rewrite
    (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0))
@@ -509,7 +509,7 @@ Lemma signed_sum_merge_ok :
   intro Heq; rewrite (Heq I).
   rewrite H.
   repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T). 
+  rewrite (Th_plus_permute T).
   repeat rewrite (Th_plus_assoc T).
   rewrite (Th_opp_def T).
   rewrite (Th_plus_zero_left T).
@@ -701,6 +701,6 @@ Proof.
   intros.
     rewrite signed_sum_opp_ok.
     rewrite H; reflexivity.
-Qed.  
+Qed.
 
 End abstract_rings.
diff --git a/contrib/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
index e8d9f1ee..7aeee218 100644
--- a/contrib/ring/Ring_normalize.v
+++ b/plugins/ring/Ring_normalize.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_normalize.v 10913 2008-05-09 14:40:04Z herbelin $ *)
+(* $Id$ *)
 
 Require Import LegacyRing_theory.
 Require Import Quote.
@@ -39,11 +39,11 @@ Variable Aeq : A -> A -> bool.
 (* Normal abtract Polynomials             *)
 (******************************************)
 (* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z 
+- A varlist is a sorted product of one or more variables : x, x*y*z
 - A monom is a constant, a varlist or the product of a constant by a varlist
   variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms 
-  (the order on monoms is defined later) 
+- A canonical sum is either a monom or an ordered sum of monoms
+  (the order on monoms is defined later)
 - A normal polynomial it either a constant or a canonical sum or a constant
   plus a canonical sum
 *)
@@ -61,14 +61,14 @@ Inductive canonical_sum : Type :=
 
 (* Order on monoms *)
 
-(* That's the lexicographic order on varlist, extended by : 
-  - A constant is less than every monom 
+(* That's the lexicographic order on varlist, extended by :
+  - A constant is less than every monom
   - The relation between two varlist is preserved by multiplication by a
   constant.
 
-  Examples : 
+  Examples :
   3 < x < y
-  x*y < x*y*y*z 
+  x*y < x*y*y*z
   2*x*y < x*y*y*z
   x*y < 54*x*y*y*z
   4*x*y < 59*x*y*y*z
@@ -214,7 +214,7 @@ Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
   end.
 
 (* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) 
+Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
  (s:canonical_sum) {struct s} : canonical_sum :=
   match s with
   | Cons_monom c l t =>
@@ -225,7 +225,7 @@ Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
   | Nil_monom => Nil_monom
   end.
 
-(* returns the product of two canonical sums *) 
+(* returns the product of two canonical sums *)
 Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
  canonical_sum :=
   match s1 with
@@ -282,7 +282,7 @@ Definition spolynomial_simplify (x:spolynomial) :=
 
 Variable vm : varmap A.
 
-(* Interpretation of list of variables 
+(* Interpretation of list of variables
  * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
  * The unbound variables are mapped to 0. Normally this case sould
  * never occur. Since we want only to prove correctness theorems, which form
@@ -608,7 +608,7 @@ repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
 rewrite H.
 rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
+repeat rewrite (SR_distr_right T).
 repeat rewrite <- (SR_mult_assoc T).
 repeat rewrite <- (SR_plus_assoc T).
 rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
@@ -620,7 +620,7 @@ repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
 rewrite H.
 rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
+repeat rewrite (SR_distr_right T).
 repeat rewrite <- (SR_mult_assoc T).
 repeat rewrite <- (SR_plus_assoc T).
 reflexivity.
@@ -639,7 +639,7 @@ repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
 rewrite H.
 rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
+repeat rewrite (SR_distr_right T).
 repeat rewrite <- (SR_mult_assoc T).
 repeat rewrite <- (SR_plus_assoc T).
 rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
@@ -651,7 +651,7 @@ repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
 rewrite H.
 rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
+repeat rewrite (SR_distr_right T).
 repeat rewrite <- (SR_mult_assoc T).
 repeat rewrite <- (SR_plus_assoc T).
 rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
diff --git a/contrib/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v
index 7bf33b17..93b9bc7c 100644
--- a/contrib/ring/Setoid_ring.v
+++ b/plugins/ring/Setoid_ring.v
@@ -6,8 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 Require Export Setoid_ring_theory.
 Require Export Quote.
-Require Export Setoid_ring_normalize.
\ No newline at end of file
+Require Export Setoid_ring_normalize.
+Declare ML Module "ring_plugin".
diff --git a/contrib/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
index 8eb49a37..9b4c46fe 100644
--- a/contrib/ring/Setoid_ring_normalize.v
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_normalize.v 9370 2006-11-13 09:21:31Z herbelin $ *)
+(* $Id$ *)
 
 Require Import Setoid_ring_theory.
 Require Import Quote.
 
 Set Implicit Arguments.
 Unset Boxed Definitions.
- 
+
 Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
 Proof.
   simple induction n; simple induction m; simpl in |- *;
@@ -75,11 +75,11 @@ Section semi_setoid_rings.
 (* Normal abtract Polynomials             *)
 (******************************************)
 (* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z 
+- A varlist is a sorted product of one or more variables : x, x*y*z
 - A monom is a constant, a varlist or the product of a constant by a varlist
   variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms 
-  (the order on monoms is defined later) 
+- A canonical sum is either a monom or an ordered sum of monoms
+  (the order on monoms is defined later)
 - A normal polynomial it either a constant or a canonical sum or a constant
   plus a canonical sum
 *)
@@ -97,14 +97,14 @@ Inductive canonical_sum : Type :=
 
 (* Order on monoms *)
 
-(* That's the lexicographic order on varlist, extended by : 
-  - A constant is less than every monom 
+(* That's the lexicographic order on varlist, extended by :
+  - A constant is less than every monom
   - The relation between two varlist is preserved by multiplication by a
   constant.
 
-  Examples : 
+  Examples :
   3 < x < y
-  x*y < x*y*y*z 
+  x*y < x*y*y*z
   2*x*y < x*y*y*z
   x*y < 54*x*y*y*z
   4*x*y < 59*x*y*y*z
@@ -250,7 +250,7 @@ Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
   end.
 
 (* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) 
+Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
  (s:canonical_sum) {struct s} : canonical_sum :=
   match s with
   | Cons_monom c l t =>
@@ -261,7 +261,7 @@ Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
   | Nil_monom => Nil_monom
   end.
 
-(* returns the product of two canonical sums *) 
+(* returns the product of two canonical sums *)
 Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
  canonical_sum :=
   match s1 with
@@ -540,7 +540,7 @@ rewrite
         end) c0)).
 rewrite H0.
 rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; 
+ rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *;
  auto.
 
 generalize (varlist_eq_prop v v0).
diff --git a/contrib/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
index 88abd7de..2c2314af 100644
--- a/contrib/ring/Setoid_ring_theory.v
+++ b/plugins/ring/Setoid_ring_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_theory.v 10631 2008-03-06 18:17:24Z msozeau $ *)
+(* $Id$ *)
 
 Require Export Bool.
 Require Export Setoid.
@@ -57,7 +57,7 @@ Qed.
 
 Section Theory_of_semi_setoid_rings.
 
-Record Semi_Setoid_Ring_Theory : Prop := 
+Record Semi_Setoid_Ring_Theory : Prop :=
   {SSR_plus_comm : forall n m:A, n + m == m + n;
    SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
    SSR_mult_comm : forall n m:A, n * m == m * n;
@@ -76,7 +76,7 @@ Let plus_assoc := SSR_plus_assoc T.
 Let mult_comm := SSR_mult_comm T.
 Let mult_assoc := SSR_mult_assoc T.
 Let plus_zero_left := SSR_plus_zero_left T.
-Let mult_one_left := SSR_mult_one_left T. 
+Let mult_one_left := SSR_mult_one_left T.
 Let mult_zero_left := SSR_mult_zero_left T.
 Let distr_left := SSR_distr_left T.
 Let plus_reg_left := SSR_plus_reg_left T.
@@ -90,7 +90,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
 Hint Immediate equiv_sym.
 
 (* Lemmas whose form is x=y are also provided in form y=x because
-  Auto does not symmetry *) 
+  Auto does not symmetry *)
 Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
 auto. Qed.
 
@@ -174,7 +174,7 @@ End Theory_of_semi_setoid_rings.
 
 Section Theory_of_setoid_rings.
 
-Record Setoid_Ring_Theory : Prop := 
+Record Setoid_Ring_Theory : Prop :=
   {STh_plus_comm : forall n m:A, n + m == m + n;
    STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
    STh_mult_comm : forall n m:A, n * m == m * n;
@@ -192,7 +192,7 @@ Let plus_assoc := STh_plus_assoc T.
 Let mult_comm := STh_mult_comm T.
 Let mult_assoc := STh_mult_assoc T.
 Let plus_zero_left := STh_plus_zero_left T.
-Let mult_one_left := STh_mult_one_left T. 
+Let mult_one_left := STh_mult_one_left T.
 Let opp_def := STh_opp_def T.
 Let distr_left := STh_distr_left T.
 Let equiv_refl := Seq_refl A Aequiv S.
diff --git a/contrib/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
index 2f964988..d766e344 100644
--- a/contrib/ring/g_ring.ml4
+++ b/plugins/ring/g_ring.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *)
+(* $Id$ *)
 
 open Quote
 open Ring
@@ -20,13 +20,13 @@ END
 
 (* The vernac commands "Add Ring" and co *)
 
-let cset_of_constrarg_list l = 
+let cset_of_constrarg_list l =
   List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
 
 VERNAC COMMAND EXTEND AddRing
-  [ "Add" "Legacy" "Ring" 
+  [ "Add" "Legacy" "Ring"
           constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
+          constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
   -> [ add_theory true false false
 			 (constr_of a)
 			 None
@@ -41,9 +41,9 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Legacy" "Semi" "Ring" 
+| [ "Add" "Legacy" "Semi" "Ring"
       	  constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
+          constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
   -> [ add_theory false false false
 			 (constr_of a)
 			 None
@@ -58,9 +58,9 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Legacy" "Abstract" "Ring" 
+| [ "Add" "Legacy" "Abstract" "Ring"
     	  constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aopp) constr(aeq) constr(t) ] 
+          constr(azero) constr(aopp) constr(aeq) constr(t) ]
   -> [ add_theory true true false
 			 (constr_of a)
 			 None
@@ -75,9 +75,9 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 ConstrSet.empty ]
 
-| [ "Add" "Legacy" "Abstract" "Semi" "Ring" 
+| [ "Add" "Legacy" "Abstract" "Semi" "Ring"
           constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aeq) constr(t) ] 
+          constr(azero) constr(aeq) constr(t) ]
   -> [ add_theory false true false
 			 (constr_of a)
 			 None
@@ -93,9 +93,9 @@ VERNAC COMMAND EXTEND AddRing
 			 ConstrSet.empty ]
 
 | [ "Add" "Legacy" "Setoid" "Ring"
-      	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) 
+      	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult)
 	  constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
-	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] 
+	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ]
   -> [ add_theory true false true
 			 (constr_of a)
 			 (Some (constr_of aequiv))
@@ -113,10 +113,10 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Legacy" "Semi" "Setoid" "Ring" 
+| [ "Add" "Legacy" "Semi" "Setoid" "Ring"
           constr(a) constr(aequiv) constr(asetth) constr(aplus)
-	  constr(amult) constr(aone) constr(azero) constr(aeq) 
-          constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] 
+	  constr(amult) constr(aone) constr(azero) constr(aeq)
+          constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ]
   -> [ add_theory false false true
 			 (constr_of a)
 			 (Some (constr_of aequiv))
diff --git a/contrib/ring/ring.ml b/plugins/ring/ring.ml
index f2706307..1e3765da 100644
--- a/contrib/ring/ring.ml
+++ b/plugins/ring/ring.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ring.ml 11800 2009-01-18 18:34:15Z msozeau $ *)
+(* $Id$ *)
 
 (* ML part of the Ring tactic *)
 
@@ -30,7 +30,7 @@ open Libobject
 open Closure
 open Tacred
 open Tactics
-open Pattern 
+open Pattern
 open Hiddentac
 open Nametab
 open Quote
@@ -96,13 +96,13 @@ let coq_SetPopp = lazy (ring_constant "SetPopp")
 let coq_interp_setsp = lazy (ring_constant "interp_setsp")
 let coq_interp_setp = lazy (ring_constant "interp_setp")
 let coq_interp_setcs = lazy (ring_constant "interp_setcs")
-let coq_setspolynomial_simplify = 
+let coq_setspolynomial_simplify =
   lazy (ring_constant "setspolynomial_simplify")
-let coq_setpolynomial_simplify = 
+let coq_setpolynomial_simplify =
   lazy (ring_constant "setpolynomial_simplify")
-let coq_setspolynomial_simplify_ok = 
+let coq_setspolynomial_simplify_ok =
   lazy (ring_constant "setspolynomial_simplify_ok")
-let coq_setpolynomial_simplify_ok = 
+let coq_setpolynomial_simplify_ok =
   lazy (ring_constant "setpolynomial_simplify_ok")
 
 (* Ring abstract *)
@@ -123,9 +123,9 @@ let coq_interp_acs = lazy (ring_constant "interp_acs")
 let coq_interp_sacs = lazy (ring_constant "interp_sacs")
 let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize")
 let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize")
-let coq_aspolynomial_normalize_ok = 
+let coq_aspolynomial_normalize_ok =
   lazy (ring_constant "aspolynomial_normalize_ok")
-let coq_apolynomial_normalize_ok = 
+let coq_apolynomial_normalize_ok =
   lazy (ring_constant "apolynomial_normalize_ok")
 
 (* Logic --> to be found in Coqlib *)
@@ -135,8 +135,8 @@ let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
 
 (*********** Useful types and functions ************)
 
-module OperSet = 
-  Set.Make (struct 
+module OperSet =
+  Set.Make (struct
 	      type t = global_reference
 	      let compare = (Pervasives.compare : t->t->int)
 	    end)
@@ -166,7 +166,7 @@ type theory =
                                        (* Must be empty for an abstract ring *)
     }
 
-(* Theories are stored in a table which is synchronised with the Reset 
+(* Theories are stored in a table which is synchronised with the Reset
    mechanism. *)
 
 module Cmap = Map.Make(struct type t = constr let compare = compare end)
@@ -177,36 +177,34 @@ let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map
 let theories_map_find c = Cmap.find c !theories_map
 let theories_map_mem c = Cmap.mem c !theories_map
 
-let _ = 
+let _ =
   Summary.declare_summary "tactic-ring-table"
     { Summary.freeze_function = (fun () -> !theories_map);
       Summary.unfreeze_function = (fun t -> theories_map := t);
-      Summary.init_function = (fun () -> theories_map := Cmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = (fun () -> theories_map := Cmap.empty) }
 
 (* declare a new type of object in the environment, "tactic-ring-theory"
    The functions theory_to_obj and obj_to_theory do the conversions
    between theories and environement objects. *)
 
 
-let subst_morph subst morph = 
+let subst_morph subst morph =
   let plusm' = subst_mps subst morph.plusm in
   let multm' = subst_mps subst morph.multm in
   let oppm' = Option.smartmap (subst_mps subst) morph.oppm in
-    if plusm' == morph.plusm 
-      && multm' == morph.multm 
-      && oppm' == morph.oppm then 
+    if plusm' == morph.plusm
+      && multm' == morph.multm
+      && oppm' == morph.oppm then
 	morph
     else
       { plusm = plusm' ;
 	multm = multm' ;
 	oppm = oppm' ;
       }
-  
-let subst_set subst cset = 
+
+let subst_set subst cset =
   let same = ref true in
-  let copy_subst c newset = 
+  let copy_subst c newset =
     let c' = subst_mps subst c in
       if not (c' == c) then same := false;
       ConstrSet.add c' newset
@@ -214,21 +212,21 @@ let subst_set subst cset =
   let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in
     if !same then cset else cset'
 
-let subst_theory subst th = 
+let subst_theory subst th =
   let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in
   let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in
   let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in
-  let th_a' = subst_mps subst th.th_a in                   
+  let th_a' = subst_mps subst th.th_a in
   let th_plus' = subst_mps subst th.th_plus in
   let th_mult' = subst_mps subst th.th_mult in
   let th_one' = subst_mps subst th.th_one in
   let th_zero' = subst_mps subst th.th_zero in
   let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in
   let th_eq' = subst_mps subst th.th_eq in
-  let th_t' = subst_mps subst th.th_t in          
+  let th_t' = subst_mps subst th.th_t in
   let th_closed' = subst_set subst th.th_closed in
-    if th_equiv' == th.th_equiv 
-      && th_setoid_th' == th.th_setoid_th 
+    if th_equiv' == th.th_equiv
+      && th_setoid_th' == th.th_setoid_th
       && th_morph' == th.th_morph
       && th_a' == th.th_a
       && th_plus' == th.th_plus
@@ -238,65 +236,63 @@ let subst_theory subst th =
       && th_opp' == th.th_opp
       && th_eq' == th.th_eq
       && th_t' == th.th_t
-      && th_closed' == th.th_closed 
-    then 
-      th 
+      && th_closed' == th.th_closed
+    then
+      th
     else
-    { th_ring = th.th_ring ;  
+    { th_ring = th.th_ring ;
       th_abstract = th.th_abstract ;
-      th_setoid = th.th_setoid ;  
+      th_setoid = th.th_setoid ;
       th_equiv = th_equiv' ;
       th_setoid_th = th_setoid_th' ;
       th_morph = th_morph' ;
-      th_a = th_a' ;            
+      th_a = th_a' ;
       th_plus = th_plus' ;
       th_mult = th_mult' ;
       th_one = th_one' ;
       th_zero = th_zero' ;
-      th_opp = th_opp' ;        
+      th_opp = th_opp' ;
       th_eq = th_eq' ;
-      th_t = th_t' ;            
-      th_closed = th_closed' ;  
+      th_t = th_t' ;
+      th_closed = th_closed' ;
     }
 
 
-let subst_th (_,subst,(c,th as obj)) = 
+let subst_th (subst,(c,th as obj)) =
   let c' = subst_mps subst c in
   let th' = subst_theory subst th in
     if c' == c && th' == th then obj else
       (c',th')
 
 
-let (theory_to_obj, obj_to_theory) = 
-  let cache_th (_,(c, th)) = theories_map_add (c,th)
-  and export_th x = Some x in
+let (theory_to_obj, obj_to_theory) =
+  let cache_th (_,(c, th)) = theories_map_add (c,th) in
   declare_object {(default_object "tactic-ring-theory") with
 		    open_function = (fun i o -> if i=1 then cache_th o);
                     cache_function = cache_th;
 		    subst_function = subst_th;
-		    classify_function = (fun (_,x) -> Substitute x);
-		    export_function = export_th }
+		    classify_function = (fun x -> Substitute x) }
 
 (* from the set A, guess the associated theory *)
 (* With this simple solution, the theory to use is automatically guessed *)
 (* But only one theory can be declared for a given Set *)
 
 let guess_theory a =
-  try 
+  try
     theories_map_find a
-  with Not_found -> 
-    errorlabstrm "Ring" 
+  with Not_found ->
+    errorlabstrm "Ring"
       (str "No Declared Ring Theory for " ++
 	 pr_lconstr a ++ fnl () ++
 	 str "Use Add [Semi] Ring to declare it")
 
 (* Looks up an option *)
 
-let unbox = function 
+let unbox = function
   | Some w -> w
   | None -> anomaly "Ring : Not in case of a setoid ring."
 
-(* Protects the convertibility test against undue exceptions when using it 
+(* Protects the convertibility test against undue exceptions when using it
    with untyped terms *)
 
 let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false
@@ -322,8 +318,8 @@ let states_compatibility_for env plus mult opp morphs =
    | Some opp, Some compat -> check opp compat
    | _,_ -> assert false)
 
-let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = 
-  if theories_map_mem a then errorlabstrm "Add Semi Ring" 
+let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset =
+  if theories_map_mem a then errorlabstrm "Add Semi Ring"
     (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++
        pr_lconstr a);
   let env = Global.env () in
@@ -334,10 +330,10 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus
 	not (implement_theory env (unbox asetth) coq_Setoid_Theory
 	  [| a; (unbox aequiv) |]) ||
         not (states_compatibility_for env aplus amult aopp (unbox amorph))
-        )) then 
+        )) then
       errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
     if (not want_ring & want_setoid & (
-        not (implement_theory env t coq_Semi_Setoid_Ring_Theory 
+        not (implement_theory env t coq_Semi_Setoid_Ring_Theory
 	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) ||
 	not (implement_theory env (unbox asetth) coq_Setoid_Theory
 	  [| a; (unbox aequiv) |]) ||
@@ -350,10 +346,10 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus
       errorlabstrm "addring" (str "Not a valid Ring theory");
     if (not want_ring & not want_setoid &
 	not (implement_theory env t coq_Semi_Ring_Theory
-	  [| a; aplus; amult; aone; azero; aeq |])) then 
+	  [| a; aplus; amult; aone; azero; aeq |])) then
       errorlabstrm "addring" (str "Not a valid Semi-Ring theory");
     Lib.add_anonymous_leaf
-      (theory_to_obj 
+      (theory_to_obj
 	 (a, { th_ring = want_ring;
 	       th_abstract = want_abstract;
 	       th_setoid = want_setoid;
@@ -376,9 +372,9 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus
    gl : goal sigma
    th : semi-ring theory (concrete)
    cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+
+Builds
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
   where c'i is convertible with ci and
   c'i_eq_c''i is a proof of equality of c'i and c''i
 
@@ -388,43 +384,43 @@ let build_spolynom gl th lc =
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the spolynom p by a recursive destructuration of c 
+  (* aux creates the spolynom p by a recursive destructuration of c
      and builds the varmap with side-effects *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
+  let rec aux c =
+    match (kind_of_term (strip_outer_cast c)) with
       | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
 	  mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |])
       | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |])
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_SPconst, [|th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
+      | _ ->
+	  try Hashtbl.find varhash c
+	  with Not_found ->
 	    let newvar =
               mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin 
+	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
 	      Hashtbl.add varhash c newvar;
 	      newvar
 	    end
-  in 
+  in
   let lp = List.map aux lc in
   let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map 
-    (fun p -> 
+  List.map
+    (fun p ->
        (mkLApp (coq_interp_sp,
                [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
 	mkLApp (coq_interp_cs,
                [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp (coq_spolynomial_simplify, 
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
+		  pf_reduce cbv_betadeltaiota gl
+		    (mkLApp (coq_spolynomial_simplify,
+			    [| th.th_a; th.th_plus; th.th_mult;
+			       th.th_one; th.th_zero;
 			       th.th_eq; p|])) |]),
 	mkLApp (coq_spolynomial_simplify_ok,
-	        [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+	        [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
 		  th.th_eq; v; th.th_t; p |])))
     lp
 
@@ -432,9 +428,9 @@ let build_spolynom gl th lc =
    gl : goal sigma
    th : ring theory (concrete)
    cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+
+Builds
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
   where c'i is convertible with ci and
   c'i_eq_c''i is a proof of equality of c'i and c''i
 
@@ -444,8 +440,8 @@ let build_polynom gl th lc =
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
+  let rec aux c =
+    match (kind_of_term (strip_outer_cast c)) with
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
 	  mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
@@ -461,12 +457,12 @@ let build_polynom gl th lc =
 	  mkLApp(coq_Popp, [|th.th_a; aux c1|])
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_Pconst, [|th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
+      | _ ->
+	  try Hashtbl.find varhash c
+	  with Not_found ->
 	    let newvar =
               mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin 
+	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
 	      Hashtbl.add varhash c newvar;
@@ -475,20 +471,20 @@ let build_polynom gl th lc =
   in
   let lp = List.map aux lc in
   let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map 
-    (fun p -> 
+  List.map
+    (fun p ->
        (mkLApp(coq_interp_p,
 	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
                  (unbox th.th_opp); v; p |])),
 	mkLApp(coq_interp_cs,
 	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
+		  pf_reduce cbv_betadeltaiota gl
 		    (mkLApp(coq_polynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
+			    [| th.th_a; th.th_plus; th.th_mult;
+			       th.th_one; th.th_zero;
 			       (unbox th.th_opp); th.th_eq; p |])) |]),
 	mkLApp(coq_polynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
 		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))
     lp
 
@@ -496,9 +492,9 @@ let build_polynom gl th lc =
    gl : goal sigma
    th : semi-ring theory (abstract)
    cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+
+Builds
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
   where c'i is convertible with ci and
   c'i_eq_c''i is a proof of equality of c'i and c''i
 
@@ -508,41 +504,41 @@ let build_aspolynom gl th lc =
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the aspolynom p by a recursive destructuration of c 
+  (* aux creates the aspolynom p by a recursive destructuration of c
      and builds the varmap with side-effects *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
+  let rec aux c =
+    match (kind_of_term (strip_outer_cast c)) with
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
 	  mkLApp(coq_ASPplus, [| aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_ASPmult, [| aux c1; aux c2 |])
       | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0
       | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
+      | _ ->
+	  try Hashtbl.find varhash c
+	  with Not_found ->
 	    let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
-	    begin 
+	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
 	      Hashtbl.add varhash c newvar;
 	      newvar
 	    end
-  in 
+  in
   let lp = List.map aux lc in
   let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map 
-    (fun p -> 
+  List.map
+    (fun p ->
        (mkLApp(coq_interp_asp,
-               [| th.th_a; th.th_plus; th.th_mult; 
+               [| th.th_a; th.th_plus; th.th_mult;
 		  th.th_one; th.th_zero; v; p |]),
 	mkLApp(coq_interp_acs,
-               [| th.th_a; th.th_plus; th.th_mult; 
+               [| th.th_a; th.th_plus; th.th_mult;
 		  th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
+		  pf_reduce cbv_betadeltaiota gl
 		    (mkLApp(coq_aspolynomial_normalize,[|p|])) |]),
 	mkLApp(coq_spolynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
 		  th.th_eq; v; th.th_t; p |])))
     lp
 
@@ -550,9 +546,9 @@ let build_aspolynom gl th lc =
    gl : goal sigma
    th : ring theory (abstract)
    cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+
+Builds
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
   where c'i is convertible with ci and
   c'i_eq_c''i is a proof of equality of c'i and c''i
 
@@ -562,14 +558,14 @@ let build_apolynom gl th lc =
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
+  let rec aux c =
+    match (kind_of_term (strip_outer_cast c)) with
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
 	  mkLApp(coq_APplus, [| aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_APmult, [| aux c1; aux c2 |])
       (* The special case of Zminus *)
-      | App (binop, [|c1; c2|]) 
+      | App (binop, [|c1; c2|])
 	  when safe_pf_conv_x gl c
             (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
 	    mkLApp(coq_APplus,
@@ -578,12 +574,12 @@ let build_apolynom gl th lc =
 	  mkLApp(coq_APopp, [| aux c1 |])
       | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0
       | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
+      | _ ->
+	  try Hashtbl.find varhash c
+	  with Not_found ->
 	    let newvar =
               mkLApp(coq_APvar, [| path_of_int !counter |]) in
-	    begin 
+	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
 	      Hashtbl.add varhash c newvar;
@@ -592,28 +588,28 @@ let build_apolynom gl th lc =
   in
   let lp = List.map aux lc in
   let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map 
-    (fun p -> 
+  List.map
+    (fun p ->
        (mkLApp(coq_interp_ap,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; 
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one;
 		  th.th_zero; (unbox th.th_opp); v; p |]),
 	mkLApp(coq_interp_sacs,
-	       [| th.th_a; th.th_plus; th.th_mult; 
-		  th.th_one; th.th_zero; (unbox th.th_opp); v; 
-		  pf_reduce cbv_betadeltaiota gl 
+	       [| th.th_a; th.th_plus; th.th_mult;
+		  th.th_one; th.th_zero; (unbox th.th_opp); v;
+		  pf_reduce cbv_betadeltaiota gl
 		    (mkLApp(coq_apolynomial_normalize, [|p|])) |]),
 	mkLApp(coq_apolynomial_normalize_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
 		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |])))
     lp
-    
+
 (*
    gl : goal sigma
    th : setoid ring theory (concrete)
    cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+
+Builds
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
   where c'i is convertible with ci and
   c'i_eq_c''i is a proof of equality of c'i and c''i
 
@@ -623,8 +619,8 @@ let build_setpolynom gl th lc =
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
+  let rec aux c =
+    match (kind_of_term (strip_outer_cast c)) with
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
 	  mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
@@ -640,12 +636,12 @@ let build_setpolynom gl th lc =
 	  mkLApp(coq_SetPopp, [| th.th_a; aux c1 |])
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_SetPconst, [| th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
+      | _ ->
+	  try Hashtbl.find varhash c
+	  with Not_found ->
 	    let newvar =
               mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
-	    begin 
+	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
 	      Hashtbl.add varhash c newvar;
@@ -654,17 +650,17 @@ let build_setpolynom gl th lc =
   in
   let lp = List.map aux lc in
   let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map 
-    (fun p -> 
+  List.map
+    (fun p ->
        (mkLApp(coq_interp_setp,
 	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
                   (unbox th.th_opp); v; p |]),
 	mkLApp(coq_interp_setcs,
 	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
+		  pf_reduce cbv_betadeltaiota gl
 		    (mkLApp(coq_setpolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
+			    [| th.th_a; th.th_plus; th.th_mult;
+			       th.th_one; th.th_zero;
 			       (unbox th.th_opp); th.th_eq; p |])) |]),
 	mkLApp(coq_setpolynomial_simplify_ok,
 	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
@@ -678,9 +674,9 @@ let build_setpolynom gl th lc =
    gl : goal sigma
    th : semi setoid ring theory (concrete)
    cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+
+Builds
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
   where c'i is convertible with ci and
   c'i_eq_c''i is a proof of equality of c'i and c''i
 
@@ -690,20 +686,20 @@ let build_setspolynom gl th lc =
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
+  let rec aux c =
+    match (kind_of_term (strip_outer_cast c)) with
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
 	  mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |])
       | _ when closed_under th.th_closed c ->
 	  mkLApp(coq_SetSPconst, [| th.th_a; c |])
-      | _ -> 
+      | _ ->
 	  try Hashtbl.find varhash c
 	  with Not_found ->
 	    let newvar =
               mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
-	    begin 
+	    begin
 	      incr counter;
 	      varlist := c :: !varlist;
 	      Hashtbl.add varhash c newvar;
@@ -718,10 +714,10 @@ let build_setspolynom gl th lc =
 	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
 	mkLApp(coq_interp_setcs,
                [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
+		  pf_reduce cbv_betadeltaiota gl
 		    (mkLApp(coq_setspolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
+			    [| th.th_a; th.th_plus; th.th_mult;
+			       th.th_one; th.th_zero;
 			       th.th_eq; p |])) |]),
 	mkLApp(coq_setspolynomial_simplify_ok,
 	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
@@ -733,18 +729,18 @@ let build_setspolynom gl th lc =
 
 module SectionPathSet =
   Set.Make(struct
-	     type t = section_path
+	     type t = full_path
 	     let compare = Pervasives.compare
 	   end)
 
 (* Avec l'uniformisation des red_kind, on perd ici sur la structure
    SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *)
-let constants_to_unfold = 
+let constants_to_unfold =
 (*  List.fold_right SectionPathSet.add *)
-  let transform s = 
+  let transform s =
     let sp = path_of_string s in
     let dir, id = repr_path sp in
-      Libnames.encode_con dir id 
+      Libnames.encode_con dir id
   in
   List.map transform
     [ "Coq.ring.Ring_normalize.interp_cs";
@@ -752,7 +748,7 @@ let constants_to_unfold =
       "Coq.ring.Ring_normalize.interp_vl";
       "Coq.ring.Ring_abstract.interp_acs";
       "Coq.ring.Ring_abstract.interp_sacs";
-      "Coq.ring.Quote.varmap_find";
+      "Coq.quote.Quote.varmap_find";
       (* anciennement des Local devenus Definition *)
       "Coq.ring.Ring_normalize.ics_aux";
       "Coq.ring.Ring_normalize.ivl_aux";
@@ -774,9 +770,9 @@ let polynom_unfold_tac =
   let flags =
     (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in
   reduct_in_concl (cbv_norm_flags flags,DEFAULTcast)
-      
+
 let polynom_unfold_tac_in_term gl =
-  let flags = 
+  let flags =
     (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold)))
   in
   cbv_norm_flags flags (pf_env gl) (project gl)
@@ -785,7 +781,7 @@ let polynom_unfold_tac_in_term gl =
 (* th : theory associated to t *)
 (* op : clause (None for conclusion or Some id for hypothesis id) *)
 (* gl : goal  *)
-(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) 
+(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i))
    where the ring R, the Ring theory RC, the varmap v and the polynomials p_i
    are guessed and such that c_i = (interp R RC v p_i) *)
 let raw_polynom th op lc gl =
@@ -793,7 +789,7 @@ let raw_polynom th op lc gl =
      after t in the list. This is to avoid that the normalization of t'
      modifies t in a non-desired way *)
   let lc = sort_subterm gl lc in
-  let ltriplets = 
+  let ltriplets =
     if th.th_setoid then
       if th.th_ring
       then build_setpolynom gl th lc
@@ -804,46 +800,46 @@ let raw_polynom th op lc gl =
 	then build_apolynom gl th lc
 	else build_polynom gl th lc
       else
-	if th.th_abstract 
+	if th.th_abstract
 	then build_aspolynom gl th lc
-	else build_spolynom gl th lc in 
-  let polynom_tac = 
+	else build_spolynom gl th lc in
+  let polynom_tac =
     List.fold_right2
       (fun ci (c'i, c''i, c'i_eq_c''i) tac ->
-         let c'''i = 
-	   if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i 
+         let c'''i =
+	   if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i
 	 in
-         if !term_quality && safe_pf_conv_x gl c'''i ci then 
+         if !term_quality && safe_pf_conv_x gl c'''i ci then
 	   tac (* convertible terms *)
          else if th.th_setoid
 	 then
-           (tclORELSE 
+           (tclORELSE
               (tclORELSE
 		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkLApp(coq_seq_sym, 
+		 (h_exact (mkLApp(coq_seq_sym,
 				  [| th.th_a; (unbox th.th_equiv);
                                      (unbox th.th_setoid_th);
 				     c'''i; ci; c'i_eq_c''i |]))))
 	      (tclTHENS
 		 (tclORELSE
                    (Equality.general_rewrite true
-		     Termops.all_occurrences c'i_eq_c''i)
-                   (Equality.general_rewrite false 
-		     Termops.all_occurrences c'i_eq_c''i))
+		     Termops.all_occurrences false c'i_eq_c''i)
+                   (Equality.general_rewrite false
+		     Termops.all_occurrences false c'i_eq_c''i))
                  [tac]))
 	 else
            (tclORELSE
               (tclORELSE
 		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkApp(build_coq_sym_eq (),
+		 (h_exact (mkApp(build_coq_eq_sym (),
 				 [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS 
-		 (elim_type 
+	      (tclTHENS
+		 (elim_type
 		    (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |])))
 		 [ tac;
                    h_exact c'i_eq_c''i ]))
 )
-      lc ltriplets polynom_unfold_tac 
+      lc ltriplets polynom_unfold_tac
   in
   polynom_tac gl
 
@@ -866,19 +862,19 @@ let guess_eq_tac th =
 				  th.th_plus |])))
 		 reflexivity)))))
 
-let guess_equiv_tac th = 
+let guess_equiv_tac th =
   (tclORELSE (apply (mkLApp(coq_seq_refl,
 			    [| th.th_a; (unbox th.th_equiv);
 			       (unbox th.th_setoid_th)|])))
-     (tclTHEN 
+     (tclTHEN
 	polynom_unfold_tac
-	(tclREPEAT 
-	   (tclORELSE 
+	(tclREPEAT
+	   (tclORELSE
 	      (apply (unbox th.th_morph).plusm)
 	      (apply (unbox th.th_morph).multm)))))
 
 let match_with_equiv c = match (kind_of_term c) with
-  | App (e,a) -> 
+  | App (e,a) ->
       if (List.mem e []) (*  (Setoid_replace.equiv_list ())) *)
       then Some (decompose_app c)
       else None
@@ -886,41 +882,43 @@ let match_with_equiv c = match (kind_of_term c) with
 
 let polynom lc gl =
   Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
-  match lc with 
+  match lc with
    (* If no argument is given, try to recognize either an equality or
-      a declared relation with arguments c1 ... cn, 
+      a declared relation with arguments c1 ... cn,
       do "Ring c1 c2 ... cn" and then try to apply the simplification
       theorems declared for the relation *)
     | [] ->
-	(match Hipattern.match_with_equation (pf_concl gl) with
-	   | Some (eq,t::args) ->
+	(try
+	  match Hipattern.match_with_equation (pf_concl gl) with
+	   | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) ->
 	       let th = guess_theory t in
-	       if List.exists 
-		 (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) args
-	       then 
-		 errorlabstrm "Ring :"
-		   (str" All terms must have the same type");
-	       (tclTHEN (raw_polynom th None args) (guess_eq_tac th)) gl
-	   | _ -> (match match_with_equiv (pf_concl gl) with
+	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
+	   | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2)
+	       when safe_pf_conv_x gl t1 t2 ->
+	       let th = guess_theory t1 in
+	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
+	   | _ -> raise Exit
+	  with Hipattern.NoEquationFound | Exit ->
+	          (match match_with_equiv (pf_concl gl) with
 		     | Some (equiv, c1::args) ->
 			 let t = (pf_type_of gl c1) in
 			 let th = (guess_theory t) in
-			   if List.exists 
+			   if List.exists
 			     (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args
-			   then 
+			   then
 			     errorlabstrm "Ring :"
 			       (str" All terms must have the same type");
-			   (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl		   
-		     | _ -> errorlabstrm "polynom :" 
+			   (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl
+		     | _ -> errorlabstrm "polynom :"
 			 (str" This goal is not an equality nor a setoid equivalence")))
     (* Elsewhere, guess the theory, check that all terms have the same type
        and apply raw_polynom *)
-    | c :: lc' -> 
-	let t = pf_type_of gl c in 
-	let th = guess_theory t in 
-	  if List.exists 
+    | c :: lc' ->
+	let t = pf_type_of gl c in
+	let th = guess_theory t in
+	  if List.exists
 	    (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc'
-	  then 
+	  then
 	    errorlabstrm "Ring :"
 	      (str" All terms must have the same type");
 	  (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl
diff --git a/plugins/ring/ring_plugin.mllib b/plugins/ring/ring_plugin.mllib
new file mode 100644
index 00000000..3c5f995f
--- /dev/null
+++ b/plugins/ring/ring_plugin.mllib
@@ -0,0 +1,3 @@
+Ring
+G_ring
+Ring_plugin_mod
diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget
new file mode 100644
index 00000000..da387be8
--- /dev/null
+++ b/plugins/ring/vo.itarget
@@ -0,0 +1,10 @@
+LegacyArithRing.vo
+LegacyNArithRing.vo
+LegacyRing_theory.vo
+LegacyRing.vo
+LegacyZArithRing.vo
+Ring_abstract.vo
+Ring_normalize.vo
+Setoid_ring_normalize.vo
+Setoid_ring_theory.vo
+Setoid_ring.vo
diff --git a/contrib/romega/README b/plugins/romega/README
index 86c9e58a..86c9e58a 100644
--- a/contrib/romega/README
+++ b/plugins/romega/README
diff --git a/contrib/romega/ROmega.v b/plugins/romega/ROmega.v
index 4281cc57..3ddb6bed 100644
--- a/contrib/romega/ROmega.v
+++ b/plugins/romega/ROmega.v
@@ -10,3 +10,5 @@ Require Import ReflOmegaCore.
 Require Export Setoid.
 Require Export PreOmega.
 Require Export ZArith_base.
+Require Import OmegaPlugin.
+Declare ML Module "romega_plugin".
\ No newline at end of file
diff --git a/contrib/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index 12176d66..c82abfc8 100644
--- a/contrib/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -12,19 +12,19 @@ Delimit Scope Int_scope with I.
 
 (* Abstract Integers. *)
 
-Module Type Int. 
+Module Type Int.
 
-  Parameter int : Set. 
+  Parameter int : Set.
 
-  Parameter zero : int. 
-  Parameter one : int. 
-  Parameter plus : int -> int -> int. 
+  Parameter zero : int.
+  Parameter one : int.
+  Parameter plus : int -> int -> int.
   Parameter opp : int -> int.
-  Parameter minus : int -> int -> int. 
+  Parameter minus : int -> int -> int.
   Parameter mult : int -> int -> int.
 
   Notation "0" := zero : Int_scope.
-  Notation "1" := one : Int_scope. 
+  Notation "1" := one : Int_scope.
   Infix "+" := plus : Int_scope.
   Infix "-" := minus : Int_scope.
   Infix "*" := mult : Int_scope.
@@ -57,17 +57,17 @@ Module Type Int.
   Axiom lt_0_1 : 0<1.
   Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l.
   Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
-  Axiom mult_lt_compat_l : 
+  Axiom mult_lt_compat_l :
    forall i j k, 0 < k -> i < j -> k*i<k*j.
 
-  (* We should have a way to decide the equality and the order*)  
+  (* We should have a way to decide the equality and the order*)
   Parameter compare : int -> int -> comparison.
   Infix "?=" := compare (at level 70, no associativity) : Int_scope.
   Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j.
   Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j.
   Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j.
 
-  (* Up to here, these requirements could be fulfilled 
+  (* Up to here, these requirements could be fulfilled
      by any totally ordered ring. Let's now be int-specific: *)
   Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1).
 
@@ -83,9 +83,9 @@ Module Z_as_Int <: Int.
 
   Open Scope Z_scope.
 
-  Definition int := Z. 
-  Definition zero := 0. 
-  Definition one := 1. 
+  Definition int := Z.
+  Definition zero := 0.
+  Definition one := 1.
   Definition plus := Zplus.
   Definition opp := Zopp.
   Definition minus := Zminus.
@@ -154,32 +154,32 @@ Module Z_as_Int <: Int.
    apply Zlt_succ.
   Qed.
 
-End Z_as_Int.  
+End Z_as_Int.
 
 
 
 
-Module IntProperties (I:Int). 
+Module IntProperties (I:Int).
  Import I.
- 
+
  (* Primo, some consequences of being a ring theory... *)
- 
+
  Definition two := 1+1.
- Notation "2" := two : Int_scope. 
+ Notation "2" := two : Int_scope.
 
  (* Aliases for properties packed in the ring record. *)
 
  Definition plus_assoc := ring.(Radd_assoc).
  Definition plus_comm := ring.(Radd_comm).
  Definition plus_0_l := ring.(Radd_0_l).
- Definition mult_assoc := ring.(Rmul_assoc). 
+ Definition mult_assoc := ring.(Rmul_assoc).
  Definition mult_comm := ring.(Rmul_comm).
  Definition mult_1_l := ring.(Rmul_1_l).
  Definition mult_plus_distr_r := ring.(Rdistr_l).
  Definition opp_def := ring.(Ropp_def).
  Definition minus_def := ring.(Rsub_def).
 
- Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l 
+ Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l
   mult_plus_distr_r opp_def minus_def.
 
  (* More facts about plus *)
@@ -188,7 +188,7 @@ Module IntProperties (I:Int).
  Proof. intros; rewrite plus_comm; apply plus_0_l. Qed.
 
  Lemma plus_0_r_reverse : forall x, x = x+0.
- Proof. intros; symmetry; apply plus_0_r. Qed. 
+ Proof. intros; symmetry; apply plus_0_r. Qed.
 
  Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z).
  Proof. intros; symmetry; apply plus_assoc. Qed.
@@ -197,14 +197,14 @@ Module IntProperties (I:Int).
  Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed.
 
  Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z.
- Proof. 
+ Proof.
   intros.
   rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x).
-  now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. 
+  now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute.
  Qed.
 
- (* More facts about mult *) 
-   
+ (* More facts about mult *)
+
  Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z).
  Proof. intros; symmetry; apply mult_assoc. Qed.
 
@@ -216,7 +216,7 @@ Module IntProperties (I:Int).
  Qed.
 
  Lemma mult_0_l : forall x, 0*x = 0.
- Proof. 
+ Proof.
   intros.
   generalize (mult_plus_distr_r 0 1 x).
   rewrite plus_0_l, mult_1_l, plus_comm; intros.
@@ -224,7 +224,7 @@ Module IntProperties (I:Int).
   rewrite <- H.
   apply plus_0_r_reverse.
  Qed.
- 
+
 
  (* More facts about opp *)
 
@@ -269,7 +269,7 @@ Module IntProperties (I:Int).
   rewrite <- mult_opp_comm.
   apply plus_reg_l with (x*y).
   now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l.
- Qed.  
+ Qed.
 
  Lemma egal_left : forall n m, n=m -> n+-m = 0.
  Proof. intros; subst; apply opp_def. Qed.
@@ -287,7 +287,7 @@ Module IntProperties (I:Int).
  Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed.
 
  Lemma red_factor1 : forall n, n+n = n*2.
- Proof. 
+ Proof.
   intros; unfold two.
   now rewrite mult_comm, mult_plus_distr_r, mult_1_l.
  Qed.
@@ -302,10 +302,10 @@ Module IntProperties (I:Int).
  Proof. intros; now rewrite plus_comm, red_factor2. Qed.
 
  Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p).
- Proof. 
+ Proof.
   intros; now rewrite mult_plus_distr_l.
  Qed.
- 
+
  Lemma red_factor5 : forall n m , n * 0 + m = m.
  Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed.
 
@@ -368,7 +368,7 @@ Module IntProperties (I:Int).
  Qed.
 
 
- (* Secondo, some results about order (and equality) *)  
+ (* Secondo, some results about order (and equality) *)
 
  Lemma lt_irrefl : forall n, ~ n<n.
  Proof.
@@ -440,7 +440,7 @@ Module IntProperties (I:Int).
  intros; unfold beq; generalize (compare_Eq i j).
  destruct compare; intuition discriminate.
  Qed.
-                               
+
  Lemma beq_true : forall i j, beq i j = true -> i=j.
  Proof.
  intros.
@@ -471,7 +471,7 @@ Module IntProperties (I:Int).
  Proof. intros; now rewrite <- bgt_iff. Qed.
 
  Lemma bgt_false : forall i j, bgt i j = false -> i<=j.
- Proof. 
+ Proof.
   intros.
   rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H.
  Qed.
@@ -498,7 +498,7 @@ Module IntProperties (I:Int).
   destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto.
   generalize (lt_trans _ _ _ H C); intuition.
  Qed.
- 
+
  (* order and operations *)
 
  Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0.
@@ -582,8 +582,8 @@ Module IntProperties (I:Int).
  Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0.
  Proof.
  intros.
- destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; 
-  destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; elimtype False.
+ destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto;
+  destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso.
 
  rewrite lt_0_neg' in Hn.
  rewrite lt_0_neg' in Hm.
@@ -611,7 +611,7 @@ Module IntProperties (I:Int).
  exact (lt_irrefl 0).
  Qed.
 
- Lemma mult_le_compat : 
+ Lemma mult_le_compat :
    forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l.
  Proof.
  intros.
@@ -624,9 +624,9 @@ Module IntProperties (I:Int).
 
  generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros.
  rewrite (mult_comm i), (mult_comm j).
- destruct (le_is_lt_or_eq _ _ H0); 
+ destruct (le_is_lt_or_eq _ _ H0);
   [ | subst; do 2 rewrite mult_0_l; apply le_refl].
- destruct (le_is_lt_or_eq _ _ H); 
+ destruct (le_is_lt_or_eq _ _ H);
   [ | subst; apply le_refl].
  apply lt_le_weak.
  apply mult_lt_compat_l; auto.
@@ -634,9 +634,9 @@ Module IntProperties (I:Int).
  subst i.
  rewrite mult_0_l.
  generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros.
- destruct (le_is_lt_or_eq _ _ H); 
+ destruct (le_is_lt_or_eq _ _ H);
   [ | subst; rewrite mult_0_l; apply le_refl].
- destruct (le_is_lt_or_eq _ _ H0); 
+ destruct (le_is_lt_or_eq _ _ H0);
   [ | subst; rewrite mult_comm, mult_0_l; apply le_refl].
  apply lt_le_weak.
  apply mult_lt_0_compat; auto.
@@ -766,7 +766,7 @@ Module IntProperties (I:Int).
  apply plus_lt_compat; auto.
  apply mult_lt_0_compat; auto.
  apply lt_trans with x; auto.
- Qed. 
+ Qed.
 
  Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1).
  Proof.
@@ -781,7 +781,7 @@ Module IntProperties (I:Int).
  apply opp_lt_compat; auto.
  Qed.
 
- Lemma mult_le_approx : 
+ Lemma mult_le_approx :
   forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
  Proof.
  intros n m p.
@@ -850,7 +850,7 @@ Module IntOmega (I:Int).
 Import I.
 Module IP:=IntProperties(I).
 Import IP.
-   
+
 (* \subsubsection{Definition of reified integer expressions}
    Terms are either:
    \begin{itemize}
@@ -903,7 +903,7 @@ Inductive proposition : Set :=
   | Tprop : nat -> proposition.
 
 (* Definition of goals as a list of hypothesis *)
-Notation hyps := (list proposition).      
+Notation hyps := (list proposition).
 
 (* Definition of lists of subgoals  (set of open goals) *)
 Notation lhyps := (list hyps).
@@ -930,7 +930,7 @@ Inductive t_fusion : Set :=
   | F_right : t_fusion.
 
 (* \subsubsection{Rewriting steps to normalize terms} *)
-Inductive step : Set := 
+Inductive step : Set :=
   (* apply the rewriting steps to both subterms of an operation *)
   | C_DO_BOTH : step -> step -> step
   (* apply the rewriting step to the first branch *)
@@ -938,9 +938,9 @@ Inductive step : Set :=
   (* apply the rewriting step to the second branch *)
   | C_RIGHT : step -> step
   (* apply two steps consecutively to a term *)
-  | C_SEQ : step -> step -> step 
+  | C_SEQ : step -> step -> step
   (* empty step *)
-  | C_NOP : step 
+  | C_NOP : step
   (* the following operations correspond to actual rewriting *)
   | C_OPP_PLUS : step
   | C_OPP_OPP : step
@@ -990,8 +990,8 @@ Inductive t_omega : Set :=
   | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega.
 
 (* \subsubsection{Rules for normalizing the hypothesis} *)
-(* These rules indicate how to normalize useful propositions 
-   of each useful hypothesis before the decomposition of hypothesis. 
+(* These rules indicate how to normalize useful propositions
+   of each useful hypothesis before the decomposition of hypothesis.
    The rules include the inversion phase for negation removal. *)
 
 Inductive p_step : Set :=
@@ -1001,19 +1001,19 @@ Inductive p_step : Set :=
   | P_STEP : step -> p_step
   | P_NOP : p_step.
 
-(* List of normalizations to perform : with a constructor of type 
-   [p_step] allowing to visit both left and right branches, we would be  
-   able to restrict to only one normalization by hypothesis. 
-   And since all hypothesis are useful (otherwise they wouldn't be included), 
+(* List of normalizations to perform : with a constructor of type
+   [p_step] allowing to visit both left and right branches, we would be
+   able to restrict to only one normalization by hypothesis.
+   And since all hypothesis are useful (otherwise they wouldn't be included),
    we would be able to replace [h_step] by a simple list. *)
 
 Inductive h_step : Set :=
     pair_step : nat -> p_step -> h_step.
 
 (* \subsubsection{Rules for decomposing the hypothesis} *)
-(* This type allows to navigate in the logical constructors that 
-   form the predicats of the hypothesis in order to decompose them. 
-   This allows in particular to extract one hypothesis from a 
+(* This type allows to navigate in the logical constructors that
+   form the predicats of the hypothesis in order to decompose them.
+   This allows in particular to extract one hypothesis from a
    conjonction with possibly the right level of negations. *)
 
 Inductive direction : Set :=
@@ -1022,8 +1022,8 @@ Inductive direction : Set :=
   | D_mono : direction.
 
 (* This type allows to extract useful components from hypothesis, either
-   hypothesis generated by splitting a disjonction, or equations. 
-   The last constructor indicates how to solve the obtained system 
+   hypothesis generated by splitting a disjonction, or equations.
+   The last constructor indicates how to solve the obtained system
    via the use of the trace type of Omega [t_omega] *)
 
 Inductive e_step : Set :=
@@ -1032,10 +1032,10 @@ Inductive e_step : Set :=
   | E_SOLVE : t_omega -> e_step.
 
 (* \subsection{Efficient decidable equality} *)
-(* For each reified data-type, we define an efficient equality test. 
+(* For each reified data-type, we define an efficient equality test.
    It is not the one produced by [Decide Equality].
-   
-   Then we prove two theorem allowing to eliminate such equalities : 
+
+   Then we prove two theorem allowing to eliminate such equalities :
    \begin{verbatim}
    (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
    (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
@@ -1056,21 +1056,21 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
   | _, _ => false
   end.
 
-Close Scope romega_scope.  
+Close Scope romega_scope.
 
 Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
 Proof.
  simple induction t1; intros until t2; case t2; simpl in *;
- try (intros; discriminate; fail); 
+ try (intros; discriminate; fail);
  [ intros; elim beq_true with (1 := H); trivial
  | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5); 
+    elim H with (1 := H4); elim H0 with (1 := H5);
     trivial
  | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5); 
+    elim H with (1 := H4); elim H0 with (1 := H5);
     trivial
  | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5); 
+    elim H with (1 := H4); elim H0 with (1 := H5);
     trivial
  | intros t21 H3; elim H with (1 := H3); trivial
  | intros; elim beq_nat_true with (1 := H); trivial ].
@@ -1083,7 +1083,7 @@ Theorem eq_term_false :
 Proof.
  simple induction t1;
  [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    intros; elim beq_false with (1 := H); simplify_eq H0; 
+    intros; elim beq_false with (1 := H); simplify_eq H0;
     auto
  | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
     intros t21 t22 H3; unfold not in |- *; intro H4;
@@ -1101,21 +1101,21 @@ Proof.
     [ elim H1 with (1 := H5); simplify_eq H4; auto
     | elim H2 with (1 := H5); simplify_eq H4; auto ]
  | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3;
-    unfold not in |- *; intro H4; elim H1 with (1 := H3); 
+    unfold not in |- *; intro H4; elim H1 with (1 := H3);
     simplify_eq H4; auto
  | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    intros; elim beq_nat_false with (1 := H); simplify_eq H0; 
+    intros; elim beq_nat_false with (1 := H); simplify_eq H0;
     auto ].
 Qed.
 
-(* \subsubsection{Tactiques pour éliminer ces tests} 
+(* \subsubsection{Tactiques pour éliminer ces tests}
 
-   Si on se contente de faire un [Case (eq_typ t1 t2)] on perd 
+   Si on se contente de faire un [Case (eq_typ t1 t2)] on perd
    totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2].
 
    Initialement, les développements avaient été réalisés avec les
    tests rendus par [Decide Equality], c'est à dire un test rendant
-   des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un 
+   des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un
    tel test préserve bien l'information voulue mais calculatoirement de
    telles fonctions sont trop lentes. *)
 
@@ -1132,8 +1132,8 @@ Ltac elim_beq t1 t2 :=
    [ generalize (beq_true t1 t2 Aux); clear Aux
    | generalize (beq_false t1 t2 Aux); clear Aux ].
 
-Ltac elim_bgt t1 t2 := 
-  pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; 
+Ltac elim_bgt t1 t2 :=
+  pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux;
   [ generalize (bgt_true t1 t2 Aux); clear Aux
   | generalize (bgt_false t1 t2 Aux); clear Aux ].
 
@@ -1151,7 +1151,7 @@ Fixpoint interp_term (env : list int) (t : term) {struct t} : int :=
   | [n]%term => nth n env 0
   end.
 
-(* \subsubsection{Interprétation des prédicats} *) 
+(* \subsubsection{Interprétation des prédicats} *)
 
 Fixpoint interp_proposition (envp : list Prop) (env : list int)
  (p : proposition) {struct p} : Prop :=
@@ -1179,7 +1179,7 @@ Fixpoint interp_proposition (envp : list Prop) (env : list int)
    Interprétation sous forme d'une conjonction d'hypothèses plus faciles
    à manipuler individuellement *)
 
-Fixpoint interp_hyps (envp : list Prop) (env : list int) 
+Fixpoint interp_hyps (envp : list Prop) (env : list int)
  (l : hyps) {struct l} : Prop :=
   match l with
   | nil => True
@@ -1191,7 +1191,7 @@ Fixpoint interp_hyps (envp : list Prop) (env : list int)
    [Generalize] et qu'une conjonction est forcément lourde (répétition des
    types dans les conjonctions intermédiaires) *)
 
-Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) 
+Fixpoint interp_goal_concl (c : proposition) (envp : list Prop)
  (env : list int) (l : hyps) {struct l} : Prop :=
   match l with
   | nil => interp_proposition envp env c
@@ -1219,7 +1219,7 @@ Theorem hyps_to_goal :
 Proof.
  simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
 Qed.
-      
+
 (* \subsection{Manipulations sur les hypothèses} *)
 
 (* \subsubsection{Définitions de base de stabilité pour la réflexion} *)
@@ -1228,7 +1228,7 @@ Definition term_stable (f : term -> term) :=
   forall (e : list int) (t : term), interp_term e t = interp_term e (f t).
 
 (* Une opération est valide sur une hypothèse, si l'hypothèse implique le
-   résultat de l'opération. \emph{Attention : cela ne concerne que des 
+   résultat de l'opération. \emph{Attention : cela ne concerne que des
    opérations sur les hypothèses et non sur les buts (contravariance)}.
    On définit la validité pour une opération prenant une ou deux propositions
    en argument (cela suffit pour omega). *)
@@ -1242,15 +1242,15 @@ Definition valid2 (f : proposition -> proposition -> proposition) :=
   interp_proposition ep e p1 ->
   interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2).
 
-(* Dans cette notion de validité, la fonction prend directement une 
-   liste de propositions et rend une nouvelle liste de proposition. 
+(* Dans cette notion de validité, la fonction prend directement une
+   liste de propositions et rend une nouvelle liste de proposition.
    On reste contravariant *)
 
 Definition valid_hyps (f : hyps -> hyps) :=
   forall (ep : list Prop) (e : list int) (lp : hyps),
   interp_hyps ep e lp -> interp_hyps ep e (f lp).
 
-(* Enfin ce théorème élimine la contravariance et nous ramène à une 
+(* Enfin ce théorème élimine la contravariance et nous ramène à une
    opération sur les buts *)
 
 Theorem valid_goal :
@@ -1264,14 +1264,14 @@ Qed.
 (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *)
 
 
-Fixpoint interp_list_hyps (envp : list Prop) (env : list int) 
+Fixpoint interp_list_hyps (envp : list Prop) (env : list int)
  (l : lhyps) {struct l} : Prop :=
   match l with
   | nil => False
   | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l'
   end.
 
-Fixpoint interp_list_goal (envp : list Prop) (env : list int) 
+Fixpoint interp_list_goal (envp : list Prop) (env : list int)
  (l : lhyps) {struct l} : Prop :=
   match l with
   | nil => True
@@ -1311,10 +1311,10 @@ Theorem goal_valid :
  forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f.
 Proof.
  unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
- intro H2; apply list_hyps_to_goal with (1 := H1); 
+ intro H2; apply list_hyps_to_goal with (1 := H1);
  apply (H ep e lp); assumption.
 Qed.
- 
+
 Theorem append_valid :
  forall (ep : list Prop) (e : list int) (l1 l2 : lhyps),
  interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 ->
@@ -1345,7 +1345,7 @@ Proof.
     | intros; simpl in |- *; apply H; elim H1; auto ] ].
 Qed.
 
-(* Appliquer une opération (valide) sur deux hypothèses extraites de 
+(* Appliquer une opération (valide) sur deux hypothèses extraites de
    la liste et ajouter le résultat à la liste. *)
 Definition apply_oper_2 (i j : nat)
   (f : proposition -> proposition -> proposition) (l : hyps) :=
@@ -1361,7 +1361,7 @@ Qed.
 
 (* Modifier une hypothèse par application d'une opération valide *)
 
-Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) 
+Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition)
  (l : hyps) {struct i} : hyps :=
   match l with
   | nil => nil (A:=proposition)
@@ -1390,7 +1390,7 @@ Qed.
 (* \subsubsection{Manipulations de termes} *)
 (* Les fonctions suivantes permettent d'appliquer une fonction de
    réécriture sur un sous terme du terme principal. Avec la composition,
-   cela permet de construire des réécritures complexes proches des 
+   cela permet de construire des réécritures complexes proches des
    tactiques de conversion *)
 
 Definition apply_left (f : term -> term) (t : term) :=
@@ -1415,7 +1415,7 @@ Definition apply_both (f g : term -> term) (t : term) :=
   | x => x
   end.
 
-(* Les théorèmes suivants montrent la stabilité (conditionnée) des 
+(* Les théorèmes suivants montrent la stabilité (conditionnée) des
    fonctions. *)
 
 Theorem apply_left_stable :
@@ -1448,21 +1448,21 @@ Proof.
 Qed.
 
 (* \subsection{Les règles de réécriture} *)
-(* Chacune des règles de réécriture est accompagnée par sa preuve de 
-   stabilité. Toutes ces preuves ont la même forme : il faut analyser 
+(* Chacune des règles de réécriture est accompagnée par sa preuve de
+   stabilité. Toutes ces preuves ont la même forme : il faut analyser
    suivant la forme du terme (élimination de chaque Case). On a besoin d'une
-   élimination uniquement dans les cas d'utilisation d'égalité décidable. 
+   élimination uniquement dans les cas d'utilisation d'égalité décidable.
 
    Cette tactique itère la décomposition des Case. Elle est
    constituée de deux fonctions s'appelant mutuellement :
-   \begin{itemize} 
+   \begin{itemize}
     \item une fonction d'enrobage qui lance la recherche sur le but,
     \item une fonction récursive qui décompose ce but. Quand elle a trouvé un
-          Case, elle l'élimine. 
-   \end{itemize}  
+          Case, elle l'élimine.
+   \end{itemize}
    Les motifs sur les cas sont très imparfaits et dans certains cas, il
    semble que cela ne marche pas. On aimerait plutot un motif de la
-   forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on 
+   forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on
    utilise le bon type.
 
    Chaque élimination introduit correctement exactement le nombre d'hypothèses
@@ -1520,15 +1520,15 @@ Ltac loop t :=
     | [x]%term => _
     end => destruct X1; auto; Simplify
   | (if beq ?X1 ?X2 then _ else _) =>
-      let H := fresh "H" in 
+      let H := fresh "H" in
       elim_beq X1 X2; intro H; try (rewrite H in *; clear H);
        simpl in |- *; auto; Simplify
   | (if bgt ?X1 ?X2 then _ else _) =>
-      let H := fresh "H" in 
+      let H := fresh "H" in
       elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify
   | (if eq_term ?X1 ?X2 then _ else _) =>
-      let H := fresh "H" in 
-      elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); 
+      let H := fresh "H" in
+      elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H);
        simpl in |- *; auto; Simplify
   | (if _ && _ then _ else _) => rewrite andb_if; Simplify
   | (if negb _ then _ else _) => rewrite negb_if; Simplify
@@ -1617,7 +1617,7 @@ Qed.
 Definition T_OMEGA10 (t : term) :=
   match t with
   | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term =>
-      if eq_term v v' 
+      if eq_term v v'
       then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term
       else t
   | _ => t
@@ -1650,12 +1650,12 @@ Definition T_OMEGA12 (t : term) :=
 Theorem T_OMEGA12_stable : term_stable T_OMEGA12.
 Proof.
  prove_stable T_OMEGA12 OMEGA12.
-Qed. 
+Qed.
 
 Definition T_OMEGA13 (t : term) :=
   match t with
   | (v * Tint x + l1 + (v' * Tint x' + l2))%term =>
-      if eq_term v v' && beq x (-x') 
+      if eq_term v v' && beq x (-x')
       then (l1+l2)%term
       else t
   | _ => t
@@ -1670,7 +1670,7 @@ Qed.
 Definition T_OMEGA15 (t : term) :=
   match t with
   | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term =>
-      if eq_term v v' 
+      if eq_term v v'
       then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term
       else t
   | _ => t
@@ -1792,9 +1792,9 @@ Qed.
 Definition Tred_factor1 (t : term) :=
   match t with
   | (x + y)%term =>
-      if eq_term x y 
+      if eq_term x y
       then (x * Tint 2)%term
-      else t 
+      else t
   | _ => t
   end.
 
@@ -1806,7 +1806,7 @@ Qed.
 Definition Tred_factor2 (t : term) :=
   match t with
   | (x + y * Tint k)%term =>
-      if eq_term x y 
+      if eq_term x y
       then (x * Tint (1 + k))%term
       else t
   | _ => t
@@ -1820,7 +1820,7 @@ Qed.
 Definition Tred_factor3 (t : term) :=
   match t with
   | (x * Tint k + y)%term =>
-      if eq_term x y 
+      if eq_term x y
       then (x * Tint (1 + k))%term
       else t
   | _ => t
@@ -1835,7 +1835,7 @@ Qed.
 Definition Tred_factor4 (t : term) :=
   match t with
   | (x * Tint k1 + y * Tint k2)%term =>
-      if eq_term x y 
+      if eq_term x y
       then (x * Tint (k1 + k2))%term
       else t
   | _ => t
@@ -1919,13 +1919,13 @@ Proof.
       | intros; auto
       | intros; auto
       | intros; auto
-      | intros; auto ])); intros t0 H0; simpl in |- *; 
+      | intros; auto ])); intros t0 H0; simpl in |- *;
  rewrite H0; case (reduce t0); intros; auto.
 Qed.
 
 (* \subsubsection{Fusions}
     \paragraph{Fusion de deux équations} *)
-(* On donne une somme de deux équations qui sont supposées normalisées. 
+(* On donne une somme de deux équations qui sont supposées normalisées.
    Cette fonction prend une trace de fusion en argument et transforme
    le terme en une équation normalisée. C'est une version très simplifiée
    du moteur de réécriture [rewrite]. *)
@@ -1941,7 +1941,7 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term :=
       | F_right => apply_right (fusion trace') (T_OMEGA12 t)
       end
   end.
-    
+
 Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t).
 Proof.
  simple induction t; simpl in |- *;
@@ -1985,7 +1985,7 @@ Proof.
  unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
  [ exact (reduce_stable e)
  | intros n H t; elim H; exact (T_OMEGA13_stable e t) ].
-Qed. 
+Qed.
 
 (* \subsubsection{Opérations affines sur une équation} *)
 (* \paragraph{Multiplication scalaire et somme d'une constante} *)
@@ -2004,7 +2004,7 @@ Proof.
  | intros n H e t; elim apply_right_stable;
     [ exact (T_OMEGA11_stable e t) | exact H ] ].
 Qed.
-   
+
 (* \paragraph{Multiplication scalaire} *)
 Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
   match trace with
@@ -2101,8 +2101,8 @@ Proof.
  | exact Tmult_comm_stable ].
 Qed.
 
-(* \subsection{tactiques de résolution d'un but omega normalisé} 
-   Trace de la procédure 
+(* \subsection{tactiques de résolution d'un but omega normalisé}
+   Trace de la procédure
 \subsubsection{Tactiques générant une contradiction}
 \paragraph{[O_CONSTANT_NOT_NUL]} *)
 
@@ -2117,17 +2117,17 @@ Theorem constant_not_nul_valid :
  forall i : nat, valid_hyps (constant_not_nul i).
 Proof.
  unfold valid_hyps, constant_not_nul in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *. 
- 
- elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; 
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *.
+
+ elim_beq i1 i0; auto; simpl in |- *; intros H1 H2;
  elim H1; symmetry  in |- *; auto.
-Qed.   
+Qed.
 
 (* \paragraph{[O_CONSTANT_NEG]} *)
 
 Definition constant_neg (i : nat) (h : hyps) :=
   match nth_hyps i h with
-  | LeqTerm (Tint Nul) (Tint Neg) => 
+  | LeqTerm (Tint Nul) (Tint Neg) =>
      if bgt Nul Neg then absurd else h
   | _ => h
   end.
@@ -2140,14 +2140,14 @@ Proof.
 Qed.
 
 (* \paragraph{[NOT_EXACT_DIVIDE]} *)
-Definition not_exact_divide (k1 k2 : int) (body : term) 
+Definition not_exact_divide (k1 k2 : int) (body : term)
   (t i : nat) (l : hyps) :=
   match nth_hyps i l with
   | EqTerm (Tint Nul) b =>
-      if beq Nul 0 && 
-         eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && 
-         bgt k2 0 && 
-         bgt k1 k2 
+      if beq Nul 0 &&
+         eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b &&
+         bgt k2 0 &&
+         bgt k1 k2
       then absurd
       else l
   | _ => l
@@ -2161,7 +2161,7 @@ Proof.
  generalize (nth_valid ep e i lp); Simplify.
  rewrite (scalar_norm_add_stable t e), <-H1.
  do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros.
- absurd (interp_term e body * k1 + k2 = 0); 
+ absurd (interp_term e body * k1 + k2 = 0);
  [ now apply OMEGA4 | symmetry; auto ].
 Qed.
 
@@ -2173,8 +2173,8 @@ Definition contradiction (t i j : nat) (l : hyps) :=
       match nth_hyps j l with
       | LeqTerm (Tint Nul') b2 =>
           match fusion_cancel t (b1 + b2)%term with
-          | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k 
-                      then absurd 
+          | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k
+                      then absurd
                       else l
           | _ => l
           end
@@ -2188,16 +2188,16 @@ Theorem contradiction_valid :
 Proof.
  unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
- case (nth_hyps i l); auto; intros t1 t2; case t1; 
- auto; case (nth_hyps j l); 
- auto; intros t3 t4; case t3; auto; 
+ case (nth_hyps i l); auto; intros t1 t2; case t1;
+ auto; case (nth_hyps j l);
+ auto; intros t3 t4; case t3; auto;
  simpl in |- *; intros z z' H1 H2;
  generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term)));
  pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *;
- case (fusion_cancel t (t2 + t4)%term); simpl in |- *; 
+ case (fusion_cancel t (t2 + t4)%term); simpl in |- *;
  auto; intro k; elim (fusion_cancel_stable t); simpl in |- *.
  Simplify; intro H3.
- generalize (OMEGA2 _ _ H2 H1); rewrite H3. 
+ generalize (OMEGA2 _ _ H2 H1); rewrite H3.
  rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
 Qed.
 
@@ -2208,17 +2208,17 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) :=
   | EqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
       | NeqTerm (Tint Nul') b2 =>
-          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 
-          then absurd 
+          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2
+          then absurd
           else h
       | _ => h
       end
   | NeqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
       | EqTerm (Tint Nul') b2 =>
-          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 
-          then absurd 
-          else h 
+          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2
+          then absurd
+          else h
       | _ => h
       end
   | _ => h
@@ -2229,7 +2229,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
   | EqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
       | NeqTerm (Tint Nul') b2 =>
-          if beq Nul 0 && beq Nul' 0 && 
+          if beq Nul 0 && beq Nul' 0 &&
              eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
           then absurd
           else h
@@ -2238,7 +2238,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
   | NeqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
       | EqTerm (Tint Nul') b2 =>
-          if beq Nul 0 && beq Nul' 0 && 
+          if beq Nul 0 && beq Nul' 0 &&
              eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
           then absurd
           else h
@@ -2252,9 +2252,9 @@ Theorem negate_contradict_valid :
 Proof.
  unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
- case (nth_hyps i l); auto; intros t1 t2; case t1; 
- auto; intros z; auto; case (nth_hyps j l); 
- auto; intros t3 t4; case t3; auto; intros z'; 
+ case (nth_hyps i l); auto; intros t1 t2; case t1;
+ auto; intros z; auto; case (nth_hyps j l);
+ auto; intros t3 t4; case t3; auto; intros z';
  auto; simpl in |- *; intros H1 H2; Simplify.
 Qed.
 
@@ -2263,15 +2263,15 @@ Theorem negate_contradict_inv_valid :
 Proof.
  unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
- case (nth_hyps i l); auto; intros t1 t2; case t1; 
- auto; intros z; auto; case (nth_hyps j l); 
- auto; intros t3 t4; case t3; auto; intros z'; 
- auto; simpl in |- *; intros H1 H2; Simplify; 
+ case (nth_hyps i l); auto; intros t1 t2; case t1;
+ auto; intros z; auto; case (nth_hyps j l);
+ auto; intros t3 t4; case t3; auto; intros z';
+ auto; simpl in |- *; intros H1 H2; Simplify;
  [
  rewrite <- scalar_norm_stable in H2; simpl in *;
  elim (mult_integral (interp_term e t4) (-(1))); intuition;
  elim minus_one_neq_zero; auto
- | 
+ |
  elim H2; clear H2;
  rewrite <- scalar_norm_stable; simpl in *;
  now rewrite <- H1, mult_0_l
@@ -2282,7 +2282,7 @@ Qed.
 (* \paragraph{[O_SUM]}
  C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant
  les opérateurs de comparaison des deux arguments) d'où une
- preuve un peu compliquée. On utilise quelques lemmes qui sont des 
+ preuve un peu compliquée. On utilise quelques lemmes qui sont des
  généralisations des théorèmes utilisés par OMEGA. *)
 
 Definition sum (k1 k2 : int) (trace : list t_fusion)
@@ -2291,11 +2291,11 @@ Definition sum (k1 k2 : int) (trace : list t_fusion)
   | EqTerm (Tint Null) b1 =>
       match prop2 with
       | EqTerm (Tint Null') b2 =>
-          if beq Null 0 && beq Null' 0 
+          if beq Null 0 && beq Null' 0
           then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
           else TrueTerm
       | LeqTerm (Tint Null') b2 =>
-          if beq Null 0 && beq Null' 0 && bgt k2 0 
+          if beq Null 0 && beq Null' 0 && bgt k2 0
           then LeqTerm (Tint 0)
                 (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
           else TrueTerm
@@ -2305,18 +2305,18 @@ Definition sum (k1 k2 : int) (trace : list t_fusion)
       if beq Null 0 && bgt k1 0
       then match prop2 with
           | EqTerm (Tint Null') b2 =>
-              if beq Null' 0 then 
+              if beq Null' 0 then
               LeqTerm (Tint 0)
                 (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
-              else TrueTerm  
+              else TrueTerm
           | LeqTerm (Tint Null') b2 =>
-              if beq Null' 0 && bgt k2 0 
+              if beq Null' 0 && bgt k2 0
               then LeqTerm (Tint 0)
                     (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
               else TrueTerm
           | _ => TrueTerm
           end
-      else TrueTerm 
+      else TrueTerm
   | NeqTerm (Tint Null) b1 =>
       match prop2 with
       | EqTerm (Tint Null') b2 =>
@@ -2334,7 +2334,7 @@ Theorem sum_valid :
  forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t).
 Proof.
  unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
- Simplify; simpl in |- *; auto; try elim (fusion_stable t); 
+ Simplify; simpl in |- *; auto; try elim (fusion_stable t);
  simpl in |- *; intros;
  [ apply sum1; assumption
  | apply sum2; try assumption; apply sum4; assumption
@@ -2350,13 +2350,13 @@ Definition exact_divide (k : int) (body : term) (t : nat)
   (prop : proposition) :=
   match prop with
   | EqTerm (Tint Null) b =>
-      if beq Null 0 && 
-         eq_term (scalar_norm t (body * Tint k)%term) b && 
-         negb (beq k 0) 
+      if beq Null 0 &&
+         eq_term (scalar_norm t (body * Tint k)%term) b &&
+         negb (beq k 0)
       then EqTerm (Tint 0) body
       else TrueTerm
   | NeqTerm (Tint Null) b =>
-      if beq Null 0 && 
+      if beq Null 0 &&
          eq_term (scalar_norm t (body * Tint k)%term) b &&
          negb (beq k 0)
       then NeqTerm (Tint 0) body
@@ -2367,8 +2367,8 @@ Definition exact_divide (k : int) (body : term) (t : nat)
 Theorem exact_divide_valid :
  forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n).
 Proof.
- unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; 
- Simplify; simpl; auto; subst; 
+ unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1;
+ Simplify; simpl; auto; subst;
  rewrite <- scalar_norm_stable; simpl; intros;
  [ destruct (mult_integral _ _ (sym_eq H0)); intuition
  | contradict H0; rewrite <- H0, mult_0_l; auto
@@ -2380,15 +2380,15 @@ Qed.
   La preuve reprend le schéma de la précédente mais on
   est sur une opération de type valid1 et non sur une opération terminale. *)
 
-Definition divide_and_approx (k1 k2 : int) (body : term) 
+Definition divide_and_approx (k1 k2 : int) (body : term)
   (t : nat) (prop : proposition) :=
   match prop with
   | LeqTerm (Tint Null) b =>
-      if beq Null 0 && 
+      if beq Null 0 &&
          eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b &&
-         bgt k1 0 && 
-         bgt k1 k2 
-      then LeqTerm (Tint 0) body 
+         bgt k1 0 &&
+         bgt k1 k2
+      then LeqTerm (Tint 0) body
       else prop
   | _ => prop
   end.
@@ -2411,7 +2411,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
       match prop2 with
       | LeqTerm (Tint Null') b2 =>
           if beq Null 0 && beq Null' 0 &&
-             eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) 
+             eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
           then EqTerm (Tint 0) b1
           else TrueTerm
       | _ => TrueTerm
@@ -2422,7 +2422,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
 Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n).
 Proof.
  unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
- auto; elim (scalar_norm_stable n e); simpl in |- *; 
+ auto; elim (scalar_norm_stable n e); simpl in |- *;
  intros; symmetry  in |- *; apply OMEGA8 with (2 := H0);
  [ assumption | elim opp_eq_mult_neg_1; trivial ].
 Qed.
@@ -2433,8 +2433,8 @@ Qed.
 
 Definition constant_nul (i : nat) (h : hyps) :=
   match nth_hyps i h with
-  | NeqTerm (Tint Null) (Tint Null') => 
-      if beq Null Null' then absurd else h 
+  | NeqTerm (Tint Null) (Tint Null') =>
+      if beq Null Null' then absurd else h
   | _ => h
   end.
 
@@ -2452,7 +2452,7 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
   | EqTerm (Tint Null) b1 =>
       match prop2 with
       | EqTerm b2 b3 =>
-          if beq Null 0 
+          if beq Null 0
           then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
           else TrueTerm
       | _ => TrueTerm
@@ -2463,20 +2463,20 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
 Theorem state_valid : forall (m : int) (s : step), valid2 (state m s).
 Proof.
  unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify;
- simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; 
+ simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *;
  intros H1 H2; elim H1.
  now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
 Qed.
 
 (* \subsubsection{Tactiques générant plusieurs but}
-   \paragraph{[O_SPLIT_INEQ]} 
+   \paragraph{[O_SPLIT_INEQ]}
    La seule pour le moment (tant que la normalisation n'est pas réfléchie). *)
 
-Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) 
+Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps)
   (l : hyps) :=
   match nth_hyps i l with
   | NeqTerm (Tint Null) b1 =>
-      if beq Null 0 then 
+      if beq Null 0 then
       f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++
       f2
         (LeqTerm (Tint 0)
@@ -2491,8 +2491,8 @@ Theorem split_ineq_valid :
  valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2).
 Proof.
  unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
- generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); 
- simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; 
+ generalize (nth_valid _ _ i _ H); case (nth_hyps i lp);
+ simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *;
  auto; intros z; simpl in |- *; auto; intro H3.
  Simplify.
  apply append_valid; elim (OMEGA19 (interp_term e t2));
@@ -2580,7 +2580,7 @@ Proof.
 Qed.
 
 
-(* \subsection{Les opérations globales sur le but} 
+(* \subsection{Les opérations globales sur le but}
    \subsubsection{Normalisation} *)
 
 Definition move_right (s : step) (p : proposition) :=
@@ -2615,7 +2615,7 @@ Proof.
  apply move_right_valid.
 Qed.
 
-Fixpoint do_normalize_list (l : list step) (i : nat) 
+Fixpoint do_normalize_list (l : list step) (i : nat)
  (h : hyps) {struct l} : hyps :=
   match l with
   | s :: l' => do_normalize_list l' (S i) (do_normalize i s h)
@@ -2659,7 +2659,7 @@ Proof.
 Qed.
 
 (* A simple decidability checker : if the proposition belongs to the
-   simple grammar describe below then it is decidable. Proof is by 
+   simple grammar describe below then it is decidable. Proof is by
    induction and uses well known theorem about arithmetic and propositional
    calculus *)
 
@@ -2703,7 +2703,7 @@ Qed.
 (* An interpretation function for a complete goal with an explicit
    conclusion. We use an intermediate fixpoint. *)
 
-Fixpoint interp_full_goal (envp : list Prop) (env : list int) 
+Fixpoint interp_full_goal (envp : list Prop) (env : list int)
  (c : proposition) (l : hyps) {struct l} : Prop :=
   match l with
   | nil => interp_proposition envp env c
@@ -2711,7 +2711,7 @@ Fixpoint interp_full_goal (envp : list Prop) (env : list int)
       interp_proposition envp env p' -> interp_full_goal envp env c l'
   end.
 
-Definition interp_full (ep : list Prop) (e : list int) 
+Definition interp_full (ep : list Prop) (e : list int)
   (lc : hyps * proposition) : Prop :=
   match lc with
   | (l, c) => interp_full_goal ep e c l
@@ -2729,7 +2729,7 @@ Proof.
 Qed.
 
 (* Push the conclusion in the list of hypothesis using a double negation
-   If the decidability cannot be "proven", then just forget about the 
+   If the decidability cannot be "proven", then just forget about the
    conclusion (equivalent of replacing it with false) *)
 
 Definition to_contradict (lc : hyps * proposition) :=
@@ -2765,16 +2765,16 @@ Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} :
   | l :: ll => (x :: l) :: map_cons A x ll
   end.
 
-(* This function breaks up a list of hypothesis in a list of simpler 
+(* This function breaks up a list of hypothesis in a list of simpler
    list of hypothesis that together implie the original one. The goal
-   of all this is to transform the goal in a list of solvable problems. 
+   of all this is to transform the goal in a list of solvable problems.
    Note that :
 	- we need a way to drive the analysis as some hypotheis may not
-          require a split. 
+          require a split.
         - this procedure must be perfectly mimicked by the ML part otherwise
           hypothesis will get desynchronised and this will be a mess.
  *)
- 
+
 Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps :=
   match nn with
   | O => ll :: nil
@@ -2834,7 +2834,7 @@ Proof.
            (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
              auto);
           [ simpl in |- *; intros p1 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_eq_ind; 
+             pattern (decidability p1) in |- *; apply bool_eq_ind;
              intro H3;
              [ apply H; simpl in |- *; split;
                 [ apply not_not; auto | assumption ]
@@ -2842,7 +2842,7 @@ Proof.
           | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *;
              elim not_or with (1 := H1); auto
           | simpl in |- *; intros p1 p2 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_eq_ind; 
+             pattern (decidability p1) in |- *; apply bool_eq_ind;
              intro H3;
              [ apply append_valid; elim not_and with (2 := H1);
                 [ intro; left; apply H; simpl in |- *; auto
@@ -2850,11 +2850,11 @@ Proof.
                 | auto ]
              | auto ] ]
        | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid;
-          (elim H1; intro H3; simpl in |- *; [ left | right ]); 
+          (elim H1; intro H3; simpl in |- *; [ left | right ]);
           apply H; simpl in |- *; auto
        | simpl in |- *; intros; apply H; simpl in |- *; tauto
        | simpl in |- *; intros p1 p2 (H1, H2);
-          pattern (decidability p1) in |- *; apply bool_eq_ind; 
+          pattern (decidability p1) in |- *; apply bool_eq_ind;
           intro H3;
           [ apply append_valid; elim imp_simp with (2 := H1);
              [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto
@@ -2867,7 +2867,7 @@ Definition prop_stable (f : proposition -> proposition) :=
   forall (ep : list Prop) (e : list int) (p : proposition),
   interp_proposition ep e p <-> interp_proposition ep e (f p).
 
-Definition p_apply_left (f : proposition -> proposition) 
+Definition p_apply_left (f : proposition -> proposition)
   (p : proposition) :=
   match p with
   | Timp x y => Timp (f x) y
@@ -2907,7 +2907,7 @@ Proof.
    | intros p1 p2; elim (H ep e p2); tauto ]).
 Qed.
 
-Definition p_invert (f : proposition -> proposition) 
+Definition p_invert (f : proposition -> proposition)
   (p : proposition) :=
   match p with
   | EqTerm x y => Tnot (f (NeqTerm x y))
@@ -2960,7 +2960,7 @@ Proof.
  | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s);
     simpl in |- *; intro H1;
     [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1;
-       rewrite plus_permute; rewrite plus_opp_r; 
+       rewrite plus_permute; rewrite plus_opp_r;
        rewrite plus_0_r; trivial
     | apply (fun a b => plus_le_reg_r a b (- interp_term e t));
        rewrite plus_opp_r; assumption
@@ -3037,7 +3037,7 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
                    end
   | _ => p
   end
- 
+
  with extract_hyp_neg (s : list direction) (p : proposition) {struct s} :
  proposition :=
   match s with
@@ -3087,7 +3087,7 @@ Proof.
       (apply H2; tauto) ||
         (pattern (decidability p0) in |- *; apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e p0 H3);
-             unfold decidable in |- *; intro H4; apply H1; 
+             unfold decidable in |- *; intro H4; apply H1;
              tauto
           | intro; tauto ]) ].
 Qed.
@@ -3103,8 +3103,8 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
            decompose_solve s1 (Tnot x :: h) ++
            decompose_solve s2 (Tnot y :: h)
           else h :: nil
-      | Timp x y => 
-          if decidability x then 
+      | Timp x y =>
+          if decidability x then
             decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h)
           else h::nil
       | _ => h :: nil
@@ -3130,11 +3130,11 @@ Proof.
           | simpl in |- *; auto ]
        | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2;
           [ intros H3; left; apply H; simpl in |- *; auto
-          | intros H3; right; apply H0; simpl in |- *; auto ] 
+          | intros H3; right; apply H0; simpl in |- *; auto ]
        | intros p1 p2 H2;
          pattern (decidability p1) in |- *; apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
-             apply append_valid; elim H4; intro H5; 
+             apply append_valid; elim H4; intro H5;
              [ right; apply H0; simpl in |- *; tauto
              | left; apply H; simpl in |- *; tauto ]
           | simpl in |- *; auto ] ]
@@ -3172,7 +3172,7 @@ Theorem do_reduce_lhyps :
  interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
 Proof.
  intros envp env l H; apply list_goal_to_hyps; intro H1;
- apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; 
+ apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid;
  assumption.
 Qed.
 
@@ -3193,12 +3193,12 @@ Proof.
  | simpl in |- *; tauto ].
 Qed.
 
-Definition omega_tactic (t1 : e_step) (t2 : list h_step) 
+Definition omega_tactic (t1 : e_step) (t2 : list h_step)
   (c : proposition) (l : hyps) :=
   reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))).
 
 Theorem do_omega :
- forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) 
+ forall (t1 : e_step) (t2 : list h_step) (envp : list Prop)
    (env : list int) (c : proposition) (l : hyps),
  interp_list_goal envp env (omega_tactic t1 t2 c l) ->
  interp_goal_concl c envp env l.
@@ -3210,7 +3210,7 @@ Qed.
 
 End IntOmega.
 
-(* For now, the above modular construction is instanciated on Z, 
+(* For now, the above modular construction is instanciated on Z,
    in order to retrieve the initial ROmega. *)
 
 Module ZOmega := IntOmega(Z_as_Int).
diff --git a/contrib/romega/const_omega.ml b/plugins/romega/const_omega.ml
index bdec6bf4..f4368a1b 100644
--- a/contrib/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -9,7 +9,7 @@
 let module_refl_name = "ReflOmegaCore"
 let module_refl_path = ["Coq"; "romega"; module_refl_name]
 
-type result = 
+type result =
    Kvar of string
  | Kapp of string * Term.constr list
  | Kimp of Term.constr * Term.constr
@@ -20,15 +20,15 @@ let destructurate t =
   match Term.kind_of_term c, args with
     | Term.Const sp, args ->
 	Kapp (Names.string_of_id
-		(Nametab.id_of_global (Libnames.ConstRef sp)),
+		(Nametab.basename_of_global (Libnames.ConstRef sp)),
 	      args)
     | Term.Construct csp , args ->
 	Kapp (Names.string_of_id
-		(Nametab.id_of_global (Libnames.ConstructRef csp)),
+		(Nametab.basename_of_global (Libnames.ConstructRef csp)),
 	      args)
     | Term.Ind isp, args ->
 	Kapp (Names.string_of_id
-		(Nametab.id_of_global (Libnames.IndRef isp)),
+		(Nametab.basename_of_global (Libnames.IndRef isp)),
 	      args)
     | Term.Var id,[] -> Kvar(Names.string_of_id id)
     | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
@@ -38,15 +38,15 @@ let destructurate t =
 
 exception Destruct
 
-let dest_const_apply t = 
-  let f,args = Term.decompose_app t in 
-  let ref = 
-  match Term.kind_of_term f with 
+let dest_const_apply t =
+  let f,args = Term.decompose_app t in
+  let ref =
+  match Term.kind_of_term f with
     | Term.Const sp      -> Libnames.ConstRef sp
     | Term.Construct csp -> Libnames.ConstructRef csp
     | Term.Ind isp       -> Libnames.IndRef isp
     | _ -> raise Destruct
-  in  Nametab.id_of_global ref, args
+  in  Nametab.basename_of_global ref, args
 
 let logic_dir = ["Coq";"Logic";"Decidable"]
 
@@ -56,17 +56,19 @@ let coq_modules =
     @ [module_refl_path]
     @ [module_refl_path@["ZOmega"]]
 
+
+let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules
 let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
 
 (* Logic *)
-let coq_eq = lazy(constant  "eq")
-let coq_refl_equal = lazy(constant  "refl_equal")
-let coq_and = lazy(constant "and")
-let coq_not = lazy(constant "not")
-let coq_or = lazy(constant "or")
-let coq_True = lazy(constant "True")
-let coq_False = lazy(constant "False")
-let coq_I = lazy(constant "I")
+let coq_eq = lazy(init_constant  "eq")
+let coq_refl_equal = lazy(init_constant  "eq_refl")
+let coq_and = lazy(init_constant "and")
+let coq_not = lazy(init_constant "not")
+let coq_or = lazy(init_constant "or")
+let coq_True = lazy(init_constant "True")
+let coq_False = lazy(init_constant "False")
+let coq_I = lazy(init_constant "I")
 
 (* ReflOmegaCore/ZOmega *)
 
@@ -165,15 +167,15 @@ let coq_do_omega = lazy (constant  "do_omega")
 
 (* \subsection{Construction d'expressions} *)
 
-let do_left t = 
+let do_left t =
   if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
   else Term.mkApp (Lazy.force coq_c_do_left, [|t |] )
 
-let do_right t = 
+let do_right t =
   if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
   else Term.mkApp (Lazy.force coq_c_do_right, [|t |])
 
-let do_both t1 t2 = 
+let do_both t1 t2 =
   if t1 = Lazy.force coq_c_nop then do_right t2
   else if t2 = Lazy.force coq_c_nop then do_left t1
   else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |])
@@ -182,7 +184,7 @@ let do_seq t1 t2 =
   if t1 = Lazy.force coq_c_nop then t2
   else if t2 = Lazy.force coq_c_nop then t1
   else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |])
-  
+
 let rec do_list = function
   | [] -> Lazy.force coq_c_nop
   | [x] -> x
@@ -190,8 +192,8 @@ let rec do_list = function
 
 (* Nat *)
 
-let coq_S = lazy(constant "S")
-let coq_O = lazy(constant "O")
+let coq_S = lazy(init_constant "S")
+let coq_O = lazy(init_constant "O")
 
 let rec mk_nat = function
   | 0 -> Lazy.force coq_O
@@ -206,7 +208,7 @@ let mk_list typ l =
   let rec loop = function
     | [] ->
 	Term.mkApp (Lazy.force coq_nil, [|typ|])
-    | (step :: l) -> 
+    | (step :: l) ->
 	Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
   loop l
 
@@ -215,16 +217,16 @@ let mk_plist l = mk_list Term.mkProp l
 let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l
 
 
-type parse_term = 
-  | Tplus of Term.constr * Term.constr 
+type parse_term =
+  | Tplus of Term.constr * Term.constr
   | Tmult of Term.constr * Term.constr
   | Tminus of Term.constr * Term.constr
   | Topp of Term.constr
   | Tsucc of Term.constr
   | Tnum of Bigint.bigint
-  | Tother 
+  | Tother
 
-type parse_rel = 
+type parse_rel =
   | Req of Term.constr * Term.constr
   | Rne of Term.constr * Term.constr
   | Rlt of Term.constr * Term.constr
@@ -240,12 +242,12 @@ type parse_rel =
   | Riff of Term.constr * Term.constr
   | Rother
 
-let parse_logic_rel c = 
+let parse_logic_rel c =
  try match destructurate c with
    | Kapp("True",[]) -> Rtrue
    | Kapp("False",[]) -> Rfalse
    | Kapp("not",[t]) -> Rnot t
-   | Kapp("or",[t1;t2]) -> Ror (t1,t2) 
+   | Kapp("or",[t1;t2]) -> Ror (t1,t2)
    | Kapp("and",[t1;t2]) -> Rand (t1,t2)
    | Kimp(t1,t2) -> Rimp (t1,t2)
    | Kapp("iff",[t1;t2]) -> Riff (t1,t2)
@@ -255,7 +257,7 @@ let parse_logic_rel c =
 
 module type Int = sig
   val typ : Term.constr Lazy.t
-  val plus : Term.constr Lazy.t 
+  val plus : Term.constr Lazy.t
   val mult : Term.constr Lazy.t
   val opp : Term.constr Lazy.t
   val minus : Term.constr Lazy.t
@@ -264,10 +266,10 @@ module type Int = sig
   val parse_term : Term.constr -> parse_term
   val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
   (* check whether t is built only with numbers and + * - *)
-  val is_scalar : Term.constr -> bool 
+  val is_scalar : Term.constr -> bool
 end
 
-module Z : Int = struct 
+module Z : Int = struct
 
 let typ = lazy (constant "Z")
 let plus = lazy (constant "Zplus")
@@ -297,16 +299,16 @@ let recognize t =
       | "Z0",[] -> Bigint.zero
       | _ -> failwith "not a number";;
 
-let rec mk_positive n = 
-  if n=Bigint.one then Lazy.force coq_xH 
+let rec mk_positive n =
+  if n=Bigint.one then Lazy.force coq_xH
   else
     let (q,r) = Bigint.euclid n Bigint.two in
     Term.mkApp
       ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI),
-       [| mk_positive q |]) 
+       [| mk_positive q |])
 
 let mk_Z n =
-  if n = Bigint.zero then Lazy.force coq_Z0 
+  if n = Bigint.zero then Lazy.force coq_Z0
   else if Bigint.is_strictly_pos n then
     Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |])
   else
@@ -314,7 +316,7 @@ let mk_Z n =
 
 let mk = mk_Z
 
-let parse_term t = 
+let parse_term t =
   try match destructurate t with
     | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2)
     | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2)
@@ -322,21 +324,21 @@ let parse_term t =
     | Kapp("Zopp",[t]) -> Topp t
     | Kapp("Zsucc",[t]) -> Tsucc t
     | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
-    | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> 
+    | Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
 	(try Tnum (recognize t) with _ -> Tother)
     | _ -> Tother
   with e when Logic.catchable_exception e -> Tother
-    
-let parse_rel gl t = 
-  try match destructurate t with 
-    | Kapp("eq",[typ;t1;t2]) 
+
+let parse_rel gl t =
+  try match destructurate t with
+    | Kapp("eq",[typ;t1;t2])
       when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2)
     | Kapp("Zne",[t1;t2]) -> Rne (t1,t2)
     | Kapp("Zle",[t1;t2]) -> Rle (t1,t2)
     | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2)
     | Kapp("Zge",[t1;t2]) -> Rge (t1,t2)
     | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2)
-    | _ -> parse_logic_rel t 
+    | _ -> parse_logic_rel t
   with e when Logic.catchable_exception e -> Rother
 
 let is_scalar t =
diff --git a/contrib/romega/const_omega.mli b/plugins/romega/const_omega.mli
index 0f00e918..b8db71e4 100644
--- a/contrib/romega/const_omega.mli
+++ b/plugins/romega/const_omega.mli
@@ -168,7 +168,7 @@ module type Int =
     val parse_term : Term.constr -> parse_term
     (* parsing a relation expression, including = < <= >= > *)
     val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
-    (* Is a particular term only made of numbers and + * - ? *) 
+    (* Is a particular term only made of numbers and + * - ? *)
     val is_scalar : Term.constr -> bool
   end
 
diff --git a/contrib/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 39b6c210..2db86e00 100644
--- a/contrib/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -11,23 +11,23 @@
 open Refl_omega
 open Refiner
 
-let romega_tactic l = 
-  let tacs = List.map 
-    (function  
+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 -> Util.error ("No ROmega knowledge base for type "^s))
     (Util.list_uniquize (List.sort compare l))
-  in 
+  in
   tclTHEN
     (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
-    (tclTHEN 
-       (* because of the contradiction process in (r)omega, 
+    (tclTHEN
+       (* because of the contradiction process in (r)omega,
           we'd better leave as little as possible in the conclusion,
           for an easier decidability argument. *)
-       Tactics.intros 
+       Tactics.intros
        total_reflexive_omega_tactic)
 
 
@@ -36,7 +36,7 @@ TACTIC EXTEND romega
 END
 
 TACTIC EXTEND romega'
-| [ "romega" "with" ne_ident_list(l) ] -> 
+| [ "romega" "with" ne_ident_list(l) ] ->
     [ romega_tactic (List.map Names.string_of_id l) ]
 | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ]
 END
diff --git a/contrib/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index fc4f7a8f..570bb187 100644
--- a/contrib/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -28,7 +28,7 @@ let mkApp = Term.mkApp
 (* \section{Types}
   \subsection{How to walk in a term}
   To represent how to get to a proposition. Only choice points are
-  kept (branch to choose in a disjunction  and identifier of the disjunctive 
+  kept (branch to choose in a disjunction  and identifier of the disjunctive
   connector) *)
 type direction = Left of int | Right of int
 
@@ -58,11 +58,11 @@ type oformula =
 (* Operators for comparison recognized by Omega *)
 type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
 
-(* Type des prédicats réifiés (fragment de calcul propositionnel. Les 
+(* Type des prédicats réifiés (fragment de calcul propositionnel. Les
  * quantifications sont externes au langage) *)
-type oproposition = 
+type oproposition =
     Pequa of Term.constr * oequation
-  | Ptrue 
+  | Ptrue
   | Pfalse
   | Pnot of oproposition
   | Por of int * oproposition * oproposition
@@ -77,16 +77,16 @@ and oequation = {
     e_right: oformula;			(* formule brute droite *)
     e_trace: Term.constr;		(* tactique de normalisation *)
     e_origin: occurence;		(* l'hypothèse dont vient le terme *)
-    e_negated: bool;			(* vrai si apparait en position nié 
+    e_negated: bool;			(* vrai si apparait en position nié
 					   après normalisation *)
-    e_depends: direction  list;		(* liste des points de disjonction dont 
-					   dépend l'accès à l'équation avec la 
+    e_depends: direction  list;		(* liste des points de disjonction dont
+					   dépend l'accès à l'équation avec la
 					   direction (branche) pour y accéder *)
     e_omega: afine		(* la fonction normalisée *)
-  } 
+  }
 
-(* \subsection{Proof context} 
-  This environment codes 
+(* \subsection{Proof context}
+  This environment codes
   \begin{itemize}
   \item the terms and propositions that are given as
   parameters of the reified proof (and are represented as variables in the
@@ -101,7 +101,7 @@ type environment = {
   mutable props : Term.constr list;
   (* Les variables introduites par omega *)
   mutable om_vars : (oformula * int) list;
-  (* Traduction des indices utilisés ici en les indices finaux utilisés par 
+  (* Traduction des indices utilisés ici en les indices finaux utilisés par
    * la tactique Omega après dénombrement des variables utiles *)
   real_indices : (int,int) Hashtbl.t;
   mutable cnt_connectors : int;
@@ -119,7 +119,7 @@ type solution = {
   s_trace : action list }
 
 (* Arbre de solution résolvant complètement un ensemble de systèmes *)
-type solution_tree = 
+type solution_tree =
     Leaf of solution
     (* un noeud interne représente un point de branchement correspondant à
        l'élimination d'un connecteur générant plusieurs buts
@@ -130,37 +130,37 @@ type solution_tree =
 (* Représentation de l'environnement extrait du but initial sous forme de
    chemins pour extraire des equations ou d'hypothèses *)
 
-type context_content = 
+type context_content =
     CCHyp of occurence
   | CCEqua of int
 
 (* \section{Specific utility functions to handle base types} *)
-(* Nom arbitraire de l'hypothèse codant la négation du but final *)  
+(* Nom arbitraire de l'hypothèse codant la négation du but final *)
 let id_concl = Names.id_of_string "__goal__"
 
 (* Initialisation de l'environnement de réification de la tactique *)
 let new_environment () = {
-  terms = []; props = []; om_vars = []; cnt_connectors = 0; 
+  terms = []; props = []; om_vars = []; cnt_connectors = 0;
   real_indices = Hashtbl.create 7;
   equations = Hashtbl.create 7;
   constructors = Hashtbl.create 7;
 }
 
 (* Génération d'un nom d'équation *)
-let new_connector_id env =  
+let new_connector_id env =
    env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors
 
 (* Calcul de la branche complémentaire *)
 let barre = function Left x -> Right x | Right x -> Left x
 
 (* Identifiant associé à une branche *)
-let indice = function Left x | Right x -> x 
+let indice = function Left x | Right x -> x
 
 (* Affichage de l'environnement de réification (termes et propositions) *)
-let print_env_reification env = 
+let print_env_reification env =
   let rec loop c i = function
       [] -> Printf.printf "  ===============================\n\n"
-    | t :: l -> 
+    | t :: l ->
 	Printf.printf "  (%c%02d) := " c i;
 	Pp.ppnl (Printer.pr_lconstr t);
 	Pp.flush_all ();
@@ -173,16 +173,16 @@ let print_env_reification env =
 (* \subsection{Gestion des environnements de variable pour Omega} *)
 (* generation d'identifiant d'equation pour Omega *)
 
-let new_omega_eq, rst_omega_eq = 
-  let cpt = ref 0 in 
-  (function () -> incr cpt; !cpt), 
+let new_omega_eq, rst_omega_eq =
+  let cpt = ref 0 in
+  (function () -> incr cpt; !cpt),
   (function () -> cpt:=0)
 
 (* generation d'identifiant de variable pour Omega *)
 
-let new_omega_var, rst_omega_var = 
-  let cpt = ref 0 in 
-  (function () -> incr cpt; !cpt), 
+let new_omega_var, rst_omega_var =
+  let cpt = ref 0 in
+  (function () -> incr cpt; !cpt),
   (function () -> cpt:=0)
 
 (* Affichage des variables d'un système *)
@@ -195,8 +195,8 @@ let display_omega_var i = Printf.sprintf "OV%d" i
 
 let intern_omega env t =
   begin try List.assoc t env.om_vars
-  with Not_found -> 
-    let v = new_omega_var () in 
+  with Not_found ->
+    let v = new_omega_var () in
     env.om_vars <- (t,v) :: env.om_vars; v
   end
 
@@ -207,14 +207,14 @@ let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
 
 (* Récupère le terme associé à une variable *)
 let unintern_omega env id =
-  let rec loop = function 
-	[] -> failwith "unintern" 
+  let rec loop = function
+	[] -> failwith "unintern"
       | ((t,j)::l) -> if id = j then t else loop l in
   loop env.om_vars
 
-(* \subsection{Gestion des environnements de variable pour la réflexion} 
+(* \subsection{Gestion des environnements de variable pour la réflexion}
    Gestion des environnements de traduction entre termes des constructions
-   non réifiés et variables des termes reifies. Attention il s'agit de 
+   non réifiés et variables des termes reifies. Attention il s'agit de
    l'environnement initial contenant tout. Il faudra le réduire après
    calcul des variables utiles. *)
 
@@ -224,7 +224,7 @@ let add_reified_atom t env =
     let i = List.length env.terms in
     env.terms <- env.terms @ [t]; i
 
-let get_reified_atom env = 
+let get_reified_atom env =
   try List.nth env.terms with _ -> failwith "get_reified_atom"
 
 (* \subsection{Gestion de l'environnement de proposition pour Omega} *)
@@ -245,33 +245,33 @@ let add_equation env e =
   with Not_found -> Hashtbl.add env.equations id e
 
 (* accès a une equation *)
-let get_equation env id = 
+let get_equation env id =
   try Hashtbl.find env.equations id
   with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e
 
 (* Affichage des termes réifiés *)
-let rec oprint ch = function 
+let rec oprint ch = function
   | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n)
-  | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2  
-  | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 
-  | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 
+  | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2
+  | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2
+  | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2
   | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1
   | Oatom n -> Printf.fprintf ch "V%02d" n
   | Oufo x ->  Printf.fprintf ch "?"
 
 let rec pprint ch = function
     Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 })  ->
-      let connector = 
-	match comp with 
+      let connector =
+	match comp with
 	  Eq -> "=" | Leq -> "<=" | Geq -> ">="
 	| Gt -> ">" | Lt -> "<" | Neq -> "!=" in
-      Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2  
+      Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2
   | Ptrue -> Printf.fprintf ch "TT"
   | Pfalse -> Printf.fprintf ch "FF"
   | Pnot t -> Printf.fprintf ch "not(%a)" pprint t
-  | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2  
-  | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2  
-  | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2  
+  | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2
+  | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2
+  | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2
   | Pprop c -> Printf.fprintf ch "Prop"
 
 let rec weight env = function
@@ -287,21 +287,21 @@ let rec weight env = function
 
 (* \subsection{Oformula vers Omega} *)
 
-let omega_of_oformula env kind = 
+let omega_of_oformula env kind =
   let rec loop accu = function
-    | Oplus(Omult(v,Oint n),r) -> 
+    | Oplus(Omult(v,Oint n),r) ->
 	loop ({v=intern_omega env v; c=n} :: accu) r
     | Oint n ->
 	let id = new_omega_eq () in
 	(*i tag_equation name id; i*)
-	{kind = kind; body = List.rev accu; 
+	{kind = kind; body = List.rev accu;
 	 constant = n; id = id}
     | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in
   loop []
 
 (* \subsection{Omega vers Oformula} *)
 
-let rec oformula_of_omega env af = 
+let rec oformula_of_omega env af =
   let rec loop = function
     | ({v=v; c=n}::r) ->
 	Oplus(Omult(unintern_omega env v,Oint n),loop r)
@@ -330,8 +330,8 @@ let rec coq_of_formula env t =
 
 let reified_of_atom env i =
   try Hashtbl.find env.real_indices i
-  with Not_found -> 
-    Printf.printf "Atome %d non trouvé\n" i; 
+  with Not_found ->
+    Printf.printf "Atome %d non trouvé\n" i;
     Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
     raise Not_found
 
@@ -352,55 +352,55 @@ let reified_of_formula env f =
   begin try reified_of_formula env f with e -> oprint stderr f; raise e end
 
 let rec reified_of_proposition env = function
-    Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> 
+    Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) ->
       app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> 
+  | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) ->
       app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> 
+  | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) ->
       app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> 
+  | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) ->
       app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) ->  
+  | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) ->
       app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> 
+  | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) ->
       app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |]
   | Ptrue -> Lazy.force coq_p_true
   | Pfalse -> Lazy.force coq_p_false
-  | Pnot t -> 
+  | Pnot t ->
       app coq_p_not [| reified_of_proposition env t |]
-  | Por (_,t1,t2) -> 
+  | Por (_,t1,t2) ->
       app coq_p_or
 	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
-  | Pand(_,t1,t2) -> 
+  | Pand(_,t1,t2) ->
       app coq_p_and
 	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
-  | Pimp(_,t1,t2) -> 
+  | Pimp(_,t1,t2) ->
       app coq_p_imp
 	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
   | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |]
 
 let reified_of_proposition env f =
-  begin try reified_of_proposition env f 
+  begin try reified_of_proposition env f
   with e -> pprint stderr f; raise e end
 
 (* \subsection{Omega vers COQ réifié} *)
 
-let reified_of_omega env body constant = 
-  let coeff_constant = 
+let reified_of_omega env body constant =
+  let coeff_constant =
     app coq_t_int [| Z.mk constant |] in
   let mk_coeff {c=c; v=v} t =
-    let coef = 
-      app coq_t_mult 
-	[| reified_of_formula env (unintern_omega env v); 
+    let coef =
+      app coq_t_mult
+	[| reified_of_formula env (unintern_omega env v);
 	   app coq_t_int [| Z.mk c |] |] in
     app coq_t_plus [|coef; t |] in
   List.fold_right mk_coeff body coeff_constant
 
-let reified_of_omega env body c  = 
-  begin try 
-    reified_of_omega env body c 
-  with e -> 
-    display_eq display_omega_var (body,c); raise e 
+let reified_of_omega env body c  =
+  begin try
+    reified_of_omega env body c
+  with e ->
+    display_eq display_omega_var (body,c); raise e
   end
 
 (* \section{Opérations sur les équations}
@@ -423,13 +423,13 @@ let rec vars_of_formula = function
   | Oufo _ -> []
 
 let rec vars_of_equations = function
-  | [] -> [] 
-  | e::l -> 
+  | [] -> []
+  | e::l ->
       (vars_of_formula e.e_left) @@
       (vars_of_formula e.e_right) @@
       (vars_of_equations l)
 
-let rec vars_of_prop = function 
+let rec vars_of_prop = function
   | Pequa(_,e) -> vars_of_equations [e]
   | Pnot p -> vars_of_prop p
   | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
@@ -440,16 +440,16 @@ let rec vars_of_prop = function
 (* \subsection{Multiplication par un scalaire} *)
 
 let rec scalar n = function
-   Oplus(t1,t2) -> 
-     let tac1,t1' = scalar  n t1 and 
+   Oplus(t1,t2) ->
+     let tac1,t1' = scalar  n t1 and
          tac2,t2' = scalar  n t2 in
-     do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], 
+     do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2],
      Oplus(t1',t2')
  | Oopp t ->
      do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n))
- | Omult(t1,Oint x) -> 
+ | Omult(t1,Oint x) ->
      do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
- | Omult(t1,t2) -> 
+ | Omult(t1,t2) ->
      Util.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)
@@ -459,16 +459,16 @@ let rec scalar n = function
 (* \subsection{Propagation de l'inversion} *)
 
 let rec negate = function
-   Oplus(t1,t2) -> 
-     let tac1,t1' = negate t1 and 
+   Oplus(t1,t2) ->
+     let tac1,t1' = negate t1 and
          tac2,t2' = negate t2 in
      do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)],
      Oplus(t1',t2')
  | Oopp t ->
      do_list [Lazy.force coq_c_opp_opp], t
- | Omult(t1,Oint x) -> 
+ | Omult(t1,Oint x) ->
      do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
- | Omult(t1,t2) -> 
+ | Omult(t1,t2) ->
      Util.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))
@@ -493,29 +493,29 @@ let rec shuffle_path k1 e1 k2 e2 =
 	  Lazy.force coq_f_left :: loop(l1,l2'))
 	else (
 	  Lazy.force coq_f_right :: loop(l1',l2))
-    | ({c=c1;v=v1}::l1), [] -> 
+    | ({c=c1;v=v1}::l1), [] ->
 	  Lazy.force coq_f_left :: loop(l1,[])
-    | [],({c=c2;v=v2}::l2) -> 
+    | [],({c=c2;v=v2}::l2) ->
 	  Lazy.force coq_f_right :: loop([],l2)
     | [],[] -> flush stdout; [] in
   mk_shuffle_list (loop (e1,e2))
 
 (* \subsubsection{Version sans coefficients} *)
-let rec shuffle env (t1,t2) = 
+let rec shuffle env (t1,t2) =
   match t1,t2 with
     Oplus(l1,r1), Oplus(l2,r2) ->
-      if weight env l1 > weight env l2 then 
+      if weight env l1 > weight env l2 then
 	let l_action,t' = shuffle env (r1,t2) in
 	do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t')
-      else 
+      else
 	let l_action,t' = shuffle env (t1,r2) in
 	do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
-  | Oplus(l1,r1), t2 -> 
+  | Oplus(l1,r1), t2 ->
       if weight env l1 > weight env t2 then
         let (l_action,t') = shuffle env (r1,t2) in
 	do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t')
       else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
-  | t1,Oplus(l2,r2) -> 
+  | t1,Oplus(l2,r2) ->
       if weight env l2 > weight env t1 then
         let (l_action,t') = shuffle env (t1,r2) in
 	do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
@@ -531,16 +531,16 @@ let rec shuffle env (t1,t2) =
 
 let shrink_pair f1 f2 =
   begin match f1,f2 with
-     Oatom v,Oatom _ -> 
+     Oatom v,Oatom _ ->
        Lazy.force coq_c_red1, Omult(Oatom v,Oint two)
-   | Oatom v, Omult(_,c2) -> 
+   | Oatom v, Omult(_,c2) ->
        Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one))
-   | Omult (v1,c1),Oatom v -> 
+   | Omult (v1,c1),Oatom v ->
        Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one))
    | Omult (Oatom v,c1),Omult (v2,c2) ->
        Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
-   | t1,t2 -> 
-       oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); 
+   | t1,t2 ->
+       oprint stdout t1; print_newline (); oprint stdout t2; print_newline ();
        flush Pervasives.stdout; Util.error "shrink.1"
   end
 
@@ -554,7 +554,7 @@ let reduce_factor = function
   | Omult(Oatom v,c) ->
       let rec compute = function
           Oint n -> n
-	| Oplus(t1,t2) -> compute t1 + compute t2 
+	| Oplus(t1,t2) -> compute t1 + compute t2
 	| _ -> Util.error "condense.1" in
 	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
   | t -> Util.error "reduce_factor.1"
@@ -570,24 +570,24 @@ let rec condense env = function
 	assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t'
       end else begin
 	let tac,f = reduce_factor f1 in
-	let tac',t' = condense env t in 
-	[do_both (do_list tac) (do_list tac')], Oplus(f,t') 
+	let tac',t' = condense env t in
+	[do_both (do_list tac) (do_list tac')], Oplus(f,t')
       end
-  | Oplus(f1,Oint n) -> 
-      let tac,f1' = reduce_factor f1 in 
+  | Oplus(f1,Oint n) ->
+      let tac,f1' = reduce_factor f1 in
       [do_left (do_list tac)],Oplus(f1',Oint n)
-  | Oplus(f1,f2) -> 
+  | Oplus(f1,f2) ->
       if weight env f1 = weight env f2 then begin
 	let tac_shrink,t = shrink_pair f1 f2 in
 	let tac,t' = condense env t in
 	tac_shrink :: tac,t'
       end else begin
 	let tac,f = reduce_factor f1 in
-	let tac',t' = condense env f2 in 
-	[do_both (do_list tac) (do_list tac')],Oplus(f,t') 
+	let tac',t' = condense env f2 in
+	[do_both (do_list tac) (do_list tac')],Oplus(f,t')
       end
   | (Oint _ as t)-> [],t
-  | t -> 
+  | t ->
       let tac,t' = reduce_factor t in
       let final = Oplus(t',Oint zero) in
       tac @ [Lazy.force coq_c_red6], final
@@ -598,8 +598,8 @@ let rec clear_zero = function
    Oplus(Omult(Oatom v,Oint n),r) when n=zero ->
      let tac',t = clear_zero r in
      Lazy.force coq_c_red5 :: tac',t
-  | Oplus(f,r) -> 
-      let tac,t = clear_zero r in 
+  | Oplus(f,r) ->
+      let tac,t = clear_zero r in
       (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t)
   | t -> [],t;;
 
@@ -641,14 +641,14 @@ let normalize_linear_term env t =
 (* Cette fonction reproduit très exactement le comportement de [p_invert] *)
 let negate_oper = function
     Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq
- 
-let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = 
+
+let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
   let mk_step t1 t2 f kind =
     let t = f t1 t2 in
     let trace, oterm = normalize_linear_term env t in
-    let equa = omega_of_oformula env kind oterm in 
-    { e_comp = oper; e_left = t1; e_right = t2; 
-      e_negated = negated; e_depends = depends; 
+    let equa = omega_of_oformula env kind oterm in
+    { e_comp = oper; e_left = t1; e_right = t2;
+      e_negated = negated; e_depends = depends;
       e_origin = { o_hyp = origin; o_path = List.rev path };
       e_trace = trace; e_omega = equa } in
   try match (if negated then (negate_oper oper) else oper) with
@@ -660,36 +660,36 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
         mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1))
 	  INEQ
     | Gt ->
-        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) 
+        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2))
 	  INEQ
   with e when Logic.catchable_exception e -> raise e
 
 (* \section{Compilation des hypothèses} *)
 
 let rec oformula_of_constr env t =
-  match Z.parse_term t with 
+  match Z.parse_term t with
     | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2
     | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2
-    | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> 
+    | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 ->
 	binop env (fun x y -> Omult(x,y)) t1 t2
     | Topp t -> Oopp(oformula_of_constr env t)
     | Tsucc t -> Oplus(oformula_of_constr env t, Oint one)
     | Tnum n -> Oint n
     | _ -> Oatom (add_reified_atom t env)
 
-and binop env c t1 t2 = 
+and binop env c t1 t2 =
   let t1' = oformula_of_constr env t1 in
   let t2' = oformula_of_constr env t2 in
   c t1' t2'
 
-and binprop env (neg2,depends,origin,path) 
+and binprop env (neg2,depends,origin,path)
              add_to_depends neg1 gl c t1 t2 =
   let i = new_connector_id env in
   let depends1 = if add_to_depends then Left i::depends else depends in
   let depends2 = if add_to_depends then Right i::depends else depends in
   if add_to_depends then
     Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path};
-  let t1' = 
+  let t1' =
     oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
   let t2' =
     oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
@@ -704,31 +704,31 @@ and mk_equation env ctxt c connector t1 t2 =
   add_equation env omega;
   Pequa (c,omega)
 
-and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = 
-  match Z.parse_rel gl c with 
+and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c =
+  match Z.parse_rel gl c with
     | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2
     | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2
     | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2
     | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2
     | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2
     | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2
-    | Rtrue -> Ptrue 
+    | Rtrue -> Ptrue
     | Rfalse -> Pfalse
-    | Rnot t -> 
-	let t' = 
-	  oproposition_of_constr 
-	    env (not negated, depends, origin,(O_mono::path)) gl t in 
+    | Rnot t ->
+	let t' =
+	  oproposition_of_constr
+	    env (not negated, depends, origin,(O_mono::path)) gl t in
 	Pnot t'
-    | Ror (t1,t2) -> 
+    | Ror (t1,t2) ->
 	binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2
-    | Rand (t1,t2) -> 
+    | Rand (t1,t2) ->
 	binprop env ctxt negated negated gl
 	  (fun i x y -> Pand(i,x,y)) t1 t2
     | Rimp (t1,t2) ->
-	binprop env ctxt (not negated) (not negated) gl 
+	binprop env ctxt (not negated) (not negated) gl
 	  (fun i x y -> Pimp(i,x,y)) t1 t2
     | Riff (t1,t2) ->
-	binprop env ctxt negated negated gl 
+	binprop env ctxt negated negated gl
 	  (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1)
     | _ -> Pprop c
 
@@ -751,30 +751,30 @@ let reify_gl env gl =
 	  Printf.printf "\n"
 	end;
 	(i,t') :: loop lhyps
-    | [] -> 
-	if !debug then print_env_reification env; 
+    | [] ->
+	if !debug then print_env_reification env;
 	[] in
   let t_lhyps = loop (Tacmach.pf_hyps_types gl) in
-  (id_concl,t_concl) :: t_lhyps 
+  (id_concl,t_concl) :: t_lhyps
 
 let rec destructurate_pos_hyp orig list_equations list_depends = function
   | Pequa (_,e) -> [e :: list_equations]
   | Ptrue | Pfalse | Pprop _ -> [list_equations]
   | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t
-  | Por (i,t1,t2) -> 
-      let s1 = 
+  | Por (i,t1,t2) ->
+      let s1 =
 	destructurate_pos_hyp orig list_equations (i::list_depends) t1 in
-      let s2 = 
+      let s2 =
 	destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
       s1 @ s2
-  | Pand(i,t1,t2) -> 
+  | Pand(i,t1,t2) ->
       let list_s1 =
 	destructurate_pos_hyp orig list_equations (list_depends) t1 in
-      let rec loop = function 
+      let rec loop = function
 	  le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll
 	| [] -> [] in
       loop list_s1
-  | Pimp(i,t1,t2) -> 
+  | Pimp(i,t1,t2) ->
       let s1 =
 	destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
       let s2 =
@@ -785,30 +785,30 @@ and destructurate_neg_hyp orig list_equations list_depends = function
   | Pequa (_,e) -> [e :: list_equations]
   | Ptrue | Pfalse | Pprop _ -> [list_equations]
   | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t
-  | Pand (i,t1,t2) -> 
+  | Pand (i,t1,t2) ->
       let s1 =
 	destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
       let s2 =
 	destructurate_neg_hyp orig list_equations (i::list_depends) t2 in
       s1 @ s2
-  | Por(_,t1,t2) -> 
+  | Por(_,t1,t2) ->
       let list_s1 =
 	destructurate_neg_hyp orig list_equations list_depends t1 in
-      let rec loop = function 
+      let rec loop = function
 	  le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
 	| [] -> [] in
       loop list_s1
-  | Pimp(_,t1,t2) -> 
+  | Pimp(_,t1,t2) ->
       let list_s1 =
 	destructurate_pos_hyp orig list_equations list_depends t1 in
-      let rec loop = function 
+      let rec loop = function
 	  le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
 	| [] -> [] in
       loop list_s1
 
 let destructurate_hyps syst =
   let rec loop = function
-      (i,t) :: l -> 
+      (i,t) :: l ->
 	let l_syst1 = destructurate_pos_hyp i []  [] t in
 	let l_syst2 = loop l in
 	list_cartesian (@) l_syst1 l_syst2
@@ -819,23 +819,23 @@ let destructurate_hyps syst =
 
 (* Affichage des dépendances de système *)
 let display_depend = function
-    Left i -> Printf.printf " L%d" i 
+    Left i -> Printf.printf " L%d" i
   | Right i -> Printf.printf " R%d" i
 
-let display_systems syst_list = 
-  let display_omega om_e = 
+let display_systems syst_list =
+  let display_omega om_e =
     Printf.printf "  E%d : %a %s 0\n"
       om_e.id
-      (fun _ -> display_eq display_omega_var) 
+      (fun _ -> display_eq display_omega_var)
       (om_e.body, om_e.constant)
       (operator_of_eq om_e.kind) in
 
-  let display_equation oformula_eq = 
+  let display_equation oformula_eq =
     pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline ();
     display_omega oformula_eq.e_omega;
-    Printf.printf "  Depends on:"; 
+    Printf.printf "  Depends on:";
     List.iter display_depend oformula_eq.e_depends;
-    Printf.printf "\n  Path: %s" 
+    Printf.printf "\n  Path: %s"
       (String.concat ""
 	 (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M")
 	    oformula_eq.e_origin.o_path));
@@ -852,10 +852,10 @@ let display_systems syst_list =
    calcul des hypothèses *)
 
 let rec hyps_used_in_trace = function
-  | act :: l -> 
+  | act :: l ->
       begin match act with
 	| HYP e -> [e.id] @@ (hyps_used_in_trace l)
-	| SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
+	| SPLIT_INEQ (_,(_,act1),(_,act2)) ->
 	    hyps_used_in_trace act1 @@ hyps_used_in_trace act2
 	| _ -> hyps_used_in_trace l
       end
@@ -866,33 +866,33 @@ let rec hyps_used_in_trace = function
    éviter les créations de variable au vol *)
 
 let rec variable_stated_in_trace = function
-  | act :: l -> 
+  | act :: l ->
       begin match act with
 	| STATE action ->
 	    (*i nlle_equa: afine, def: afine, eq_orig: afine, i*)
             (*i coef: int, var:int                            i*)
 	    action :: variable_stated_in_trace l
-	| SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
+	| SPLIT_INEQ (_,(_,act1),(_,act2)) ->
 	    variable_stated_in_trace act1 @ variable_stated_in_trace act2
 	| _ -> variable_stated_in_trace l
       end
   | [] -> []
 ;;
 
-let add_stated_equations env tree = 
+let add_stated_equations env tree =
   (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
      de définir dans le mauvais ordre *)
-  let stated_equations = 
-    let cmpvar x y = Pervasives.(-) x.st_var y.st_var in 
+  let stated_equations =
+    let cmpvar x y = Pervasives.(-) x.st_var y.st_var in
     let rec loop = function
       | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2)
-      | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) 
+      | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace)
     in loop tree
-  in 
-  let add_env st = 
+  in
+  let add_env st =
     (* On retransforme la définition de v en formule reifiée *)
     let v_def = oformula_of_omega env st.st_def in
-    (* Notez que si l'ordre de création des variables n'est pas respecté, 
+    (* Notez que si l'ordre de création des variables n'est pas respecté,
      * ca va planter *)
     let coq_v = coq_of_formula env v_def in
     let v = add_reified_atom coq_v env in
@@ -902,33 +902,33 @@ let add_stated_equations env tree =
      * l'environnement pour le faire correctement *)
     let term_to_reify = (v_def,Oatom v) in
     (* enregistre le lien entre la variable omega et la variable Coq *)
-    intern_omega_force env (Oatom v) st.st_var; 
+    intern_omega_force env (Oatom v) st.st_var;
     (v, term_to_generalize,term_to_reify,st.st_def.id) in
  List.map add_env stated_equations
 
-(* Calcule la liste des éclatements à réaliser sur les hypothèses 
+(* Calcule la liste des éclatements à réaliser sur les hypothèses
    nécessaires pour extraire une liste d'équations donnée *)
 
-(* PL: experimentally, the result order of the following function seems 
+(* PL: experimentally, the result order of the following function seems
    _very_ crucial for efficiency. No idea why. Do not remove the List.rev
-   or modify the current semantics of Util.list_union (some elements of first 
+   or modify the current semantics of Util.list_union (some elements of first
    arg, then second arg), unless you know what you're doing. *)
 
 let rec get_eclatement env = function
-    i :: r -> 
+    i :: r ->
       let l = try (get_equation env i).e_depends with Not_found -> [] in
       list_union (List.rev l) (get_eclatement env r)
   | [] -> []
 
-let select_smaller l = 
+let select_smaller l =
   let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in
   try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller"
 
 let filter_compatible_systems required systems =
   let rec select = function
-      (x::l) -> 
+      (x::l) ->
 	if List.mem x required then select l
-	else if List.mem (barre x) required then failwith "Exit" 
+	else if List.mem (barre x) required then failwith "Exit"
 	else x :: select l
     | [] -> [] in
   map_succeed (function (sol,splits) -> (sol,select splits)) systems
@@ -938,8 +938,8 @@ let rec equas_of_solution_tree = function
   | Leaf s -> s.s_equa_deps
 
 (* [really_useful_prop] pushes useless props in a new Pprop variable *)
-(* Things get shorter, but may also get wrong, since a Prop is considered 
-   to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance 
+(* Things get shorter, but may also get wrong, since a Prop is considered
+   to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance
    Pfalse is decidable. So should not be used on conclusion (??) *)
 
 let really_useful_prop l_equa c =
@@ -953,21 +953,21 @@ let really_useful_prop l_equa c =
     (* Attention : implications sur le lifting des variables à comprendre ! *)
     | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2)
     | Pprop t -> t in
-  let rec loop c = 
-    match c with 
+  let rec loop c =
+    match c with
       Pequa(_,e) ->
 	if List.mem e.e_omega.id l_equa then Some c else None
     | Ptrue -> None
     | Pfalse -> None
-    | Pnot t1 -> 
+    | Pnot t1 ->
 	begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end
     | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2
     | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2
     | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2
     | Pprop t -> None
-  and binop f t1 t2 = 
+  and binop f t1 t2 =
     begin match loop t1, loop t2 with
-      None, None -> None 
+      None, None -> None
     | Some t1',Some t2' -> Some (f(t1',t2'))
     | Some t1',None -> Some (f(t1',Pprop (real_of t2)))
     | None,Some t2' -> Some (f(Pprop (real_of t1),t2'))
@@ -977,36 +977,36 @@ let really_useful_prop l_equa c =
   | Some t -> t
 
 let rec display_solution_tree ch = function
-    Leaf t -> 
-      output_string ch 
-       (Printf.sprintf "%d[%s]" 
+    Leaf t ->
+      output_string ch
+       (Printf.sprintf "%d[%s]"
 	 t.s_index
          (String.concat " " (List.map string_of_int t.s_equa_deps)))
-  | Tree(i,t1,t2) -> 
-      Printf.fprintf ch "S%d(%a,%a)" i 
+  | Tree(i,t1,t2) ->
+      Printf.fprintf ch "S%d(%a,%a)" i
 	display_solution_tree t1 display_solution_tree t2
 
-let rec solve_with_constraints all_solutions path = 
+let rec solve_with_constraints all_solutions path =
   let rec build_tree sol buf = function
       [] -> Leaf sol
-    | (Left i :: remainder) -> 
+    | (Left i :: remainder) ->
 	Tree(i,
-	     build_tree sol (Left i :: buf) remainder, 
+	     build_tree sol (Left i :: buf) remainder,
 	     solve_with_constraints all_solutions (List.rev(Right i :: buf)))
-    | (Right i :: remainder) -> 
+    | (Right i :: remainder) ->
 	 Tree(i,
 	      solve_with_constraints all_solutions (List.rev (Left i ::  buf)),
 	      build_tree sol (Right i :: buf) remainder) in
   let weighted = filter_compatible_systems path all_solutions in
   let (winner_sol,winner_deps) =
-    try select_smaller weighted 
-    with e ->  
-      Printf.printf "%d - %d\n" 
+    try select_smaller weighted
+    with e ->
+      Printf.printf "%d - %d\n"
 	(List.length weighted) (List.length all_solutions);
       List.iter display_depend path; raise e in
-  build_tree winner_sol (List.rev path) winner_deps 
+  build_tree winner_sol (List.rev path) winner_deps
 
-let find_path {o_hyp=id;o_path=p} env = 
+let find_path {o_hyp=id;o_path=p} env =
   let rec loop_path = function
       ([],l) -> Some l
     | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2)
@@ -1021,8 +1021,8 @@ let find_path {o_hyp=id;o_path=p} env =
     | [] -> failwith "find_path" in
   loop_id 0 env
 
-let mk_direction_list l = 
-  let trans = function 
+let mk_direction_list l =
+  let trans = function
       O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in
   mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l)
 
@@ -1036,33 +1036,33 @@ let get_hyp env_hyp i =
 let replay_history env env_hyp =
   let rec loop env_hyp t =
     match t with
-      | CONTRADICTION (e1,e2) :: l -> 
+      | CONTRADICTION (e1,e2) :: l ->
 	  let trace = mk_nat (List.length e1.body) in
 	  mkApp (Lazy.force coq_s_contradiction,
-		 [| trace ; mk_nat (get_hyp env_hyp e1.id); 
+		 [| trace ; mk_nat (get_hyp env_hyp e1.id);
 		    mk_nat (get_hyp env_hyp e2.id) |])
       | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
 	  mkApp (Lazy.force coq_s_div_approx,
-		 [| Z.mk k; Z.mk d; 
+		 [| Z.mk k; Z.mk d;
 		    reified_of_omega env e2.body e2.constant;
-		    mk_nat (List.length e2.body); 
+		    mk_nat (List.length e2.body);
 		    loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |])
       | NOT_EXACT_DIVIDE (e1,k) :: l ->
 	  let e2_constant = floor_div e1.constant k in
 	  let d = e1.constant - e2_constant * k in
 	  let e2_body = map_eq_linear (fun c -> c / k) e1.body in
           mkApp (Lazy.force coq_s_not_exact_divide,
-		 [|Z.mk k; Z.mk d; 
-		   reified_of_omega env e2_body e2_constant; 
-		   mk_nat (List.length e2_body); 
+		 [|Z.mk k; Z.mk d;
+		   reified_of_omega env e2_body e2_constant;
+		   mk_nat (List.length e2_body);
 		   mk_nat (get_hyp env_hyp e1.id)|])
       | EXACT_DIVIDE (e1,k) :: l ->
-	  let e2_body =  
+	  let e2_body =
 	    map_eq_linear (fun c -> c / k) e1.body in
 	  let e2_constant = floor_div e1.constant k in
           mkApp (Lazy.force coq_s_exact_divide,
-		 [|Z.mk k; 
-		   reified_of_omega env e2_body e2_constant; 
+		 [|Z.mk k;
+		   reified_of_omega env e2_body e2_constant;
 		   mk_nat (List.length e2_body);
 		   loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|])
       | (MERGE_EQ(e3,e1,e2)) :: l ->
@@ -1072,22 +1072,22 @@ let replay_history env env_hyp =
 		    mk_nat n1; mk_nat n2;
 		    loop (CCEqua e3:: env_hyp) l |])
       | SUM(e3,(k1,e1),(k2,e2)) :: l ->
-	  let n1 = get_hyp env_hyp e1.id 
+	  let n1 = get_hyp env_hyp e1.id
 	  and n2 = get_hyp env_hyp e2.id in
 	  let trace = shuffle_path k1 e1.body k2 e2.body in
           mkApp (Lazy.force coq_s_sum,
 		 [| Z.mk k1; mk_nat n1; Z.mk k2;
 		    mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |])
-      | CONSTANT_NOT_NUL(e,k) :: l -> 
+      | CONSTANT_NOT_NUL(e,k) :: l ->
           mkApp (Lazy.force coq_s_constant_not_nul,
 		 [|  mk_nat (get_hyp env_hyp e) |])
       | CONSTANT_NEG(e,k) :: l ->
           mkApp (Lazy.force coq_s_constant_neg,
 		 [|  mk_nat (get_hyp env_hyp e) |])
-      | STATE {st_new_eq=new_eq; st_def =def; 
+      | STATE {st_new_eq=new_eq; st_def =def;
 		      st_orig=orig; st_coef=m;
                       st_var=sigma } :: l ->
-	  let n1 = get_hyp env_hyp orig.id 
+	  let n1 = get_hyp env_hyp orig.id
 	  and n2 = get_hyp env_hyp def.id in
 	  let v = unintern_omega env sigma in
 	  let o_def = oformula_of_omega env def in
@@ -1096,26 +1096,26 @@ let replay_history env env_hyp =
 	     Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in
           let trace,_ = normalize_linear_term env body in
 	  mkApp (Lazy.force coq_s_state,
-		 [| Z.mk m; trace; mk_nat n1; mk_nat n2; 
+		 [| Z.mk m; trace; mk_nat n1; mk_nat n2;
 		    loop (CCEqua new_eq.id :: env_hyp) l |])
       |	HYP _ :: l -> loop env_hyp l
       |	CONSTANT_NUL e :: l ->
-	  mkApp (Lazy.force coq_s_constant_nul, 
+	  mkApp (Lazy.force coq_s_constant_nul,
 		 [|  mk_nat (get_hyp env_hyp e) |])
       |	NEGATE_CONTRADICT(e1,e2,true) :: l ->
-	  mkApp (Lazy.force coq_s_negate_contradict, 
+	  mkApp (Lazy.force coq_s_negate_contradict,
 		 [|  mk_nat (get_hyp env_hyp e1.id);
 		     mk_nat (get_hyp env_hyp e2.id) |])
       |	NEGATE_CONTRADICT(e1,e2,false) :: l ->
-	  mkApp (Lazy.force coq_s_negate_contradict_inv, 
-		 [|  mk_nat (List.length e2.body); 
+	  mkApp (Lazy.force coq_s_negate_contradict_inv,
+		 [|  mk_nat (List.length e2.body);
 		     mk_nat (get_hyp env_hyp e1.id);
 		     mk_nat (get_hyp env_hyp e2.id) |])
       | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l ->
 	  let i =  get_hyp env_hyp e.id in
 	  let r1 = loop (CCEqua e1 :: env_hyp) l1 in
 	  let r2 = loop (CCEqua e2 :: env_hyp) l2 in
-	  mkApp (Lazy.force coq_s_split_ineq, 
+	  mkApp (Lazy.force coq_s_split_ineq,
                   [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |])
       |	(FORGET_C _ | FORGET _ | FORGET_I _) :: l ->
 	  loop env_hyp l
@@ -1125,14 +1125,14 @@ let replay_history env env_hyp =
 
 let rec decompose_tree env ctxt = function
    Tree(i,left,right) ->
-     let org = 
-       try Hashtbl.find env.constructors i 
+     let org =
+       try Hashtbl.find env.constructors i
        with Not_found ->
 	 failwith (Printf.sprintf "Cannot find constructor %d" i) in
      let (index,path) = find_path org ctxt in
      let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in
      let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in
-     app coq_e_split 
+     app coq_e_split
        [| mk_nat index;
 	  mk_direction_list path;
 	  decompose_tree env (left_hyp::ctxt) left;
@@ -1141,15 +1141,15 @@ let rec decompose_tree env ctxt = function
       decompose_tree_hyps s.s_trace env ctxt  s.s_equa_deps
 and decompose_tree_hyps trace env ctxt = function
     [] -> app coq_e_solve [| replay_history env ctxt trace |]
-  | (i::l) -> 
+  | (i::l) ->
       let equation =
-        try Hashtbl.find env.equations i 
+        try Hashtbl.find env.equations i
         with Not_found ->
 	  failwith (Printf.sprintf "Cannot find equation %d" i) in
       let (index,path) = find_path equation.e_origin ctxt in
       let full_path = if equation.e_negated then path @ [O_mono] else path in
-      let cont = 
-	decompose_tree_hyps trace env 
+      let cont =
+	decompose_tree_hyps trace env
 	   (CCEqua equation.e_omega.id :: ctxt) l in
       app coq_e_extract [|mk_nat index;
 			  mk_direction_list full_path;
@@ -1165,13 +1165,13 @@ de faire rejouer cette solution par la tactique réflexive. *)
 
 let resolution env full_reified_goal systems_list =
   let num = ref 0 in
-  let solve_system list_eq = 
+  let solve_system list_eq =
     let index = !num in
     let system = List.map (fun eq -> eq.e_omega) list_eq in
-    let trace = 
-      simplify_strong 
-	(new_omega_eq,new_omega_var,display_omega_var) 
-	system in 
+    let trace =
+      simplify_strong
+	(new_omega_eq,new_omega_var,display_omega_var)
+	system in
     (* calcule les hypotheses utilisées pour la solution *)
     let vars = hyps_used_in_trace trace in
     let splits = get_eclatement env vars in
@@ -1201,11 +1201,11 @@ let resolution env full_reified_goal systems_list =
   let l_hyps = id_concl :: list_remove id_concl l_hyps' in
   let useful_hyps =
     List.map (fun id -> List.assoc id full_reified_goal) l_hyps in
-  let useful_vars = 
+  let useful_vars =
     let really_useful_vars = vars_of_equations equations in
-    let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in     
+    let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in
     really_useful_vars @@ concl_vars
-  in 
+  in
   (* variables a introduire *)
   let to_introduce = add_stated_equations env solution_tree in
   let stated_vars =  List.map (fun (v,_,_,_) -> v) to_introduce in
@@ -1217,19 +1217,19 @@ let resolution env full_reified_goal systems_list =
   let all_vars_env = useful_vars @ stated_vars in
   let basic_env =
     let rec loop i = function
-	var :: l -> 
-	  let t = get_reified_atom env var in 
+	var :: l ->
+	  let t = get_reified_atom env var in
 	  Hashtbl.add env.real_indices var i; t :: loop (succ i) l
       |	[] -> [] in
     loop 0 all_vars_env in
   let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in
   (* On peut maintenant généraliser le but : env est a jour *)
   let l_reified_stated =
-     List.map (fun (_,_,(l,r),_) -> 
-                 app coq_p_eq [| reified_of_formula env l; 
+     List.map (fun (_,_,(l,r),_) ->
+                 app coq_p_eq [| reified_of_formula env l;
                                  reified_of_formula env r |])
               to_introduce in
-  let reified_concl = 
+  let reified_concl =
     match useful_hyps with
       (Pnot p) :: _ -> reified_of_proposition env p
     | _ ->  reified_of_proposition env Pfalse in
@@ -1239,51 +1239,51 @@ let resolution env full_reified_goal systems_list =
          reified_of_proposition env (really_useful_prop useful_equa_id p))
       (List.tl useful_hyps)) in
   let env_props_reified = mk_plist env.props in
-  let reified_goal = 
+  let reified_goal =
     mk_list (Lazy.force coq_proposition)
             (l_reified_stated @ l_reified_terms) in
-  let reified = 
-    app coq_interp_sequent 
+  let reified =
+    app coq_interp_sequent
        [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in
-  let normalize_equation e = 
+  let normalize_equation e =
     let rec loop = function
 	[] -> app (if e.e_negated then coq_p_invert else coq_p_step)
 	          [| e.e_trace |]
       |	((O_left | O_mono) :: l) -> app coq_p_left [| loop l |]
       |	(O_right :: l) -> app coq_p_right [| loop l |] in
-    let correct_index = 
-      let i = list_index0 e.e_origin.o_hyp l_hyps in 
-      (* PL: it seems that additionnally introduced hyps are in the way during 
-             normalization, hence this index shifting... *) 
+    let correct_index =
+      let i = list_index0 e.e_origin.o_hyp l_hyps in
+      (* PL: it seems that additionnally introduced hyps are in the way during
+             normalization, hence this index shifting... *)
       if i=0 then 0 else Pervasives.(+) i (List.length to_introduce)
-    in 	
+    in
     app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in
   let normalization_trace =
     mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in
 
   let initial_context =
     List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in
-  let context = 
+  let context =
     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 
+  Tactics.generalize
     (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
-  Tactics.change_in_concl None reified >> 
+  Tactics.change_in_concl None reified >>
   Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
   show_goal >>
   Tactics.normalise_vm_in_concl >>
-  (*i Alternatives to the previous line: 
-   - Normalisation without VM: 
+  (*i Alternatives to the previous line:
+   - Normalisation without VM:
       Tactics.normalise_in_concl
-   - Skip the conversion check and rely directly on the QED: 
-      Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> 
+   - Skip the conversion check and rely directly on the QED:
+      Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >>
   i*)
   Tactics.apply (Lazy.force coq_I)
 
-let total_reflexive_omega_tactic gl = 
+let total_reflexive_omega_tactic gl =
   Coqlib.check_required_library ["Coq";"romega";"ROmega"];
-  rst_omega_eq (); 
+  rst_omega_eq ();
   rst_omega_var ();
   try
   let env = new_environment () in
diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mllib
new file mode 100644
index 00000000..1625009d
--- /dev/null
+++ b/plugins/romega/romega_plugin.mllib
@@ -0,0 +1,4 @@
+Const_omega
+Refl_omega
+G_romega
+Romega_plugin_mod
diff --git a/plugins/romega/vo.itarget b/plugins/romega/vo.itarget
new file mode 100644
index 00000000..f7a3c41c
--- /dev/null
+++ b/plugins/romega/vo.itarget
@@ -0,0 +1,2 @@
+ReflOmegaCore.vo
+ROmega.vo
diff --git a/contrib/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index e90fea84..c06f6991 100644
--- a/contrib/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Bintree.v 10681 2008-03-16 13:40:45Z msozeau $ *)
+(* $Id$ *)
 
 Require Export List.
 Require Export BinPos.
@@ -15,7 +15,7 @@ Unset Boxed Definitions.
 
 Open Scope positive_scope.
 
-Ltac clean := try (simpl; congruence). 
+Ltac clean := try (simpl; congruence).
 Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
 
 Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.
@@ -85,7 +85,7 @@ match m, n with
 | xO mm, xO nn => pos_eq mm nn
 | xH, xH => true
 | _, _ => false
-end. 
+end.
 
 Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
 induction m;simpl;intro n;destruct n;congruence ||
@@ -96,7 +96,7 @@ Theorem refl_pos_eq : forall m, pos_eq m m = true.
 induction m;simpl;auto.
 Qed.
 
-Definition pos_eq_dec (m n:positive) :{m=n}+{m<>n} .
+Definition pos_eq_dec : forall (m n:positive), {m=n}+{m<>n} .
 fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence).
 case (pos_eq_dec mm nn).
 intro e;left;apply (f_equal xI e).
@@ -120,12 +120,12 @@ Theorem pos_eq_dec_ex : forall m n,
 fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence).
 simpl;intro e.
 elim (pos_eq_dec_ex _ _ e).
-intros x ex; rewrite ex. 
+intros x ex; rewrite ex.
 exists (f_equal xI x).
 reflexivity.
 simpl;intro e.
 elim (pos_eq_dec_ex _ _ e).
-intros x ex; rewrite ex. 
+intros x ex; rewrite ex.
 exists (f_equal xO x).
 reflexivity.
 simpl.
@@ -134,7 +134,7 @@ reflexivity.
 Qed.
 
 Fixpoint nat_eq (m n:nat) {struct m}: bool:=
-match m, n with 
+match m, n with
 O,O => true
 | S mm,S nn => nat_eq mm nn
 | _,_ => false
@@ -151,14 +151,14 @@ Defined.
 
 Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A :=
 match l with nil => None
-| x::q => 
+| x::q =>
 match n with O => Some x
 | S m => Lget A m q
 end end .
 
 Implicit Arguments Lget [A].
 
-Lemma map_app : forall (A B:Set) (f:A -> B) l m, 
+Lemma map_app : forall (A B:Set) (f:A -> B) l m,
 List.map  f (l ++ m) = List.map  f  l ++ List.map  f  m.
 induction l.
 reflexivity.
@@ -166,16 +166,16 @@ simpl.
 intro m ; apply f_equal with (list B);apply IHl.
 Qed.
 
-Lemma length_map : forall (A B:Set) (f:A -> B) l, 
+Lemma length_map : forall (A B:Set) (f:A -> B) l,
 length (List.map  f l) = length l.
 induction l.
 reflexivity.
 simpl; apply f_equal with nat;apply IHl.
 Qed.
 
-Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, 
-Lget i (List.map  f l) = 
-match Lget i l with Some a => 
+Lemma Lget_map : forall (A B:Set) (f:A -> B) i l,
+Lget i (List.map  f l) =
+match Lget i l with Some a =>
 Some (f a) | None => None end.
 induction i;intros [ | x l ] ;trivial.
 simpl;auto.
@@ -190,7 +190,7 @@ reflexivity.
 auto.
 Qed.
 
-Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), 
+Lemma Lget_app_Some : forall (A:Set) l delta i (a: A),
 Lget i l = Some a ->
 Lget i (l ++ delta) = Some a.
 induction l;destruct i;simpl;try congruence;auto.
@@ -208,8 +208,8 @@ Inductive Tree : Type :=
    Tempty : Tree
  | Branch0 : Tree -> Tree -> Tree
  | Branch1 : A -> Tree -> Tree -> Tree.
-        
-Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := 
+
+Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption :=
   match T with
     Tempty => PNone
   | Branch0 T1 T2 =>
@@ -226,7 +226,7 @@ Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption :=
     end
 end.
 
-Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := 
+Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree :=
  match T with
    | Tempty =>
        match p with
@@ -253,13 +253,13 @@ Definition mkBranch0 (T1 T2:Tree) :=
     Tempty ,Tempty => Tempty
   | _,_ => Branch0 T1 T2
   end.
-  
+
 Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
    match T with
       | Tempty => Tempty
-      | Branch0 T1 T2 => 
+      | Branch0 T1 T2 =>
         match p with
-        | xI pp => mkBranch0 T1 (Tremove pp T2)                  
+        | xI pp => mkBranch0 T1 (Tremove pp T2)
         | xO pp => mkBranch0 (Tremove pp T1) T2
         | xH => T
         end
@@ -270,8 +270,8 @@ Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
         | xH => mkBranch0 T1 T2
         end
       end.
-                                                                                                                        
- 
+
+
 Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone.
 destruct p;reflexivity.
 Qed.
@@ -293,7 +293,7 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*;
 destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
 Qed.
 
-Record Store : Type :=  
+Record Store : Type :=
 mkStore  {index:positive;contents:Tree}.
 
 Definition empty := mkStore xH Tempty.
@@ -317,7 +317,7 @@ intros S W;induction W.
 unfold empty,index,get,contents;intros;apply Tget_Tempty.
 unfold index,get,push;simpl contents.
 intros i e;rewrite Tget_Tadd.
-rewrite (Gt_Psucc _ _ e). 
+rewrite (Gt_Psucc _ _ e).
 unfold get in IHW.
 apply IHW;apply Gt_Psucc;assumption.
 Qed.
@@ -336,8 +336,8 @@ apply get_Full_Gt; auto.
 apply Psucc_Gt.
 Qed.
 
-Theorem get_push_Full : 
-  forall i a S, Full S -> 
+Theorem get_push_Full :
+  forall i a S, Full S ->
   get i (push a S) =
   match (i ?= index S) Eq with
     Eq => PSome a
@@ -359,9 +359,9 @@ apply get_Full_Gt;auto.
 Qed.
 
 Lemma Full_push_compat : forall i a S, Full S ->
-forall x, get i S = PSome x -> 
+forall x, get i S = PSome x ->
  get i (push a S) = PSome x.
-intros i a S F x H. 
+intros i a S F x H.
 caseq ((i ?= index S) Eq);intro test.
 rewrite (Pcompare_Eq_eq _ _ test) in H.
 rewrite (get_Full_Eq _ F) in H;congruence.
@@ -372,7 +372,7 @@ assumption.
 rewrite (get_Full_Gt _ F) in H;congruence.
 Qed.
 
-Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. 
+Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
 intros [ind cont] F one; inversion F.
 reflexivity.
 simpl index in one;assert (h:=Psucc_not_one (index S)).
@@ -382,7 +382,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 Psucc_not_one.
-Qed. 
+Qed.
 
 Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
 match F with
@@ -390,7 +390,7 @@ F_empty => False
 | F_push a SS FF => x=a \/ In x SS FF
 end.
 
-Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , 
+Lemma get_In : forall (x:A) (S:Store) (F:Full S) i ,
 get i S = PSome x -> In x S F.
 induction F.
 intro i;rewrite get_empty; congruence.
@@ -432,7 +432,7 @@ Implicit Arguments F_empty [A].
 Implicit Arguments F_push [A].
 Implicit Arguments In [A].
 
-Section Map. 
+Section Map.
 
 Variables A B:Set.
 
@@ -445,8 +445,8 @@ Tempty => Tempty
 | Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2)
 end.
 
-Lemma Tget_Tmap: forall T i, 
-Tget i (Tmap T)= match Tget i T with PNone => PNone 
+Lemma Tget_Tmap: forall T i,
+Tget i (Tmap T)= match Tget i T with PNone => PNone
 | PSome a => PSome (f a) end.
 induction T;intro i;case i;simpl;auto.
 Defined.
@@ -459,13 +459,13 @@ Defined.
 Definition map (S:Store A) : Store B :=
 mkStore (index S) (Tmap (contents S)).
 
-Lemma get_map: forall i S, 
-get i (map S)= match get i S with PNone => PNone 
+Lemma get_map: forall i S,
+get i (map S)= match get i S with PNone => PNone
 | PSome a => PSome (f a) end.
 destruct S;unfold get,map,contents,index;apply Tget_Tmap.
 Defined.
 
-Lemma map_push: forall a S, 
+Lemma map_push: forall a S,
 map (push a S) = push (f a) (map S).
 intros a S.
 case S.
@@ -474,7 +474,7 @@ intros;rewrite Tmap_Tadd;reflexivity.
 Defined.
 
 Theorem Full_map : forall S, Full S -> Full (map S).
-intros S F. 
+intros S F.
 induction F.
 exact F_empty.
 rewrite map_push;constructor 2;assumption.
diff --git a/contrib/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
index 98fca90f..0d1d09c7 100644
--- a/contrib/rtauto/Rtauto.v
+++ b/plugins/rtauto/Rtauto.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Rtauto.v 7639 2005-12-02 10:01:15Z gregoire $ *)
+(* $Id$ *)
 
 
 Require Export List.
@@ -14,6 +14,8 @@ Require Export Bintree.
 Require Import Bool.
 Unset Boxed Definitions.
 
+Declare ML Module "rtauto_plugin".
+
 Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
 Ltac clean:=try (simpl;congruence).
 
@@ -21,7 +23,7 @@ Inductive form:Set:=
   Atom : positive -> form
 | Arrow : form -> form -> form
 | Bot
-| Conjunct : form -> form -> form 
+| Conjunct : form -> form -> form
 | Disjunct : form -> form -> form.
 
 Notation "[ n ]":=(Atom n).
@@ -37,7 +39,7 @@ match m with
   xI mm => match n with xI nn => pos_eq mm nn | _ => false end
 | xO mm => match n with xO nn => pos_eq mm nn | _ => false end
 | xH => match n with xH => true | _ => false end
-end. 
+end.
 
 Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
 induction m;simpl;destruct n;congruence ||
@@ -47,32 +49,32 @@ Qed.
 Fixpoint form_eq (p q:form) {struct p} :bool :=
 match p with
   Atom m => match q with Atom n => pos_eq m n | _ => false end
-| Arrow p1 p2 => 
-match q with 
-  Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 
+| Arrow p1 p2 =>
+match q with
+  Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2
 | _ => false end
 | Bot => match q with Bot => true | _ => false end
-| Conjunct p1 p2 => 
-match q with 
-  Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 
-| _ => false 
+| Conjunct p1 p2 =>
+match q with
+  Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
+| _ => false
 end
-| Disjunct p1 p2 => 
-match q with 
-  Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 
-| _ => false 
+| Disjunct p1 p2 =>
+match q with
+  Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
+| _ => false
 end
-end. 
+end.
 
 Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q.
 induction p;destruct q;simpl;clean.
 intro h;generalize (pos_eq_refl _ _ h);congruence.
 caseq (form_eq p1 q1);clean.
-intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
 caseq (form_eq p1 q1);clean.
-intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
 caseq (form_eq p1 q1);clean.
-intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
 Qed.
 
 Implicit Arguments form_eq_refl [p q].
@@ -100,16 +102,16 @@ end.
 
 Require Export BinPos.
 
-Ltac wipe := intros;simpl;constructor.  
+Ltac wipe := intros;simpl;constructor.
 
-Lemma compose0 : 
+Lemma compose0 :
 forall hyps F (A:Prop),
- A -> 
+ A ->
  (interp_ctx hyps F A).
 induction F;intros A H;simpl;auto.
 Qed.
 
-Lemma compose1 : 
+Lemma compose1 :
 forall hyps F (A B:Prop),
  (A -> B) ->
  (interp_ctx hyps F A) ->
@@ -118,9 +120,9 @@ induction F;intros A B H;simpl;auto.
 apply IHF;auto.
 Qed.
 
-Theorem compose2 : 
+Theorem compose2 :
 forall hyps F (A B C:Prop),
- (A -> B -> C) -> 
+ (A -> B -> C) ->
  (interp_ctx hyps F A) ->
  (interp_ctx hyps F B) ->
  (interp_ctx hyps F C).
@@ -128,10 +130,10 @@ induction F;intros A B C H;simpl;auto.
 apply IHF;auto.
 Qed.
 
-Theorem compose3 : 
+Theorem compose3 :
 forall hyps F (A B C D:Prop),
- (A -> B -> C -> D) -> 
- (interp_ctx hyps F A) -> 
+ (A -> B -> C -> D) ->
+ (interp_ctx hyps F A) ->
  (interp_ctx hyps F B) ->
  (interp_ctx hyps F C) ->
  (interp_ctx hyps F D).
@@ -146,7 +148,7 @@ induction F;simpl;intros;auto.
 apply compose1 with ([[a]]-> G);auto.
 Qed.
 
-Theorem project_In : forall hyps F g, 
+Theorem project_In : forall hyps F g,
 In g hyps F ->
 interp_ctx hyps F [[g]].
 induction F;simpl.
@@ -156,7 +158,7 @@ subst;apply compose0;simpl;trivial.
 apply compose1 with [[g]];auto.
 Qed.
 
-Theorem project : forall hyps F p g, 
+Theorem project : forall hyps F p g,
 get  p hyps = PSome g->
 interp_ctx hyps F [[g]].
 intros hyps F p g e; apply project_In.
@@ -184,23 +186,23 @@ Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
 
 Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
  match P with
-   Ax i => 
+   Ax i =>
      match get i hyps with
          PSome F => form_eq F gl
  | _ => false
-    end 
+    end
 | I_Arrow p =>
    match gl with
       A  =>> B  => check_proof (hyps \ A) B p
-   | _ => false        
-    end 
+   | _ => false
+    end
 | E_Arrow i j p =>
    match get i hyps,get j hyps with
        PSome A,PSome (B =>>C) =>
          form_eq A B && check_proof (hyps \ C) (gl) p
     | _,_ => false
     end
-| D_Arrow i p1 p2 => 
+| D_Arrow i p1 p2 =>
    match get i hyps with
       PSome  ((A =>>B)=>>C) =>
      (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2)
@@ -217,12 +219,12 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
       check_proof hyps A p1 && check_proof hyps B p2
       | _ => false
       end
-| E_And i p => 
+| E_And i p =>
    match get i hyps with
       PSome  (A //\\ B) => check_proof (hyps \ A \ B) gl p
     | _=> false
    end
-| D_And i p => 
+| D_And i p =>
    match get i hyps with
       PSome  (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p
     | _=> false
@@ -243,7 +245,7 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
   check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2
   | _=> false
   end
-| D_Or i p => 
+| D_Or i p =>
    match get i hyps with
       PSome  (A \\// B =>> C) =>
       (check_proof (hyps \ A=>>C \ B=>>C) gl p)
@@ -251,10 +253,10 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
    end
 | Cut A p1 p2 =>
   check_proof hyps A p1 && check_proof (hyps \ A) gl p2
-end. 
+end.
 
-Theorem interp_proof: 
-forall p hyps F gl, 
+Theorem interp_proof:
+forall p hyps F gl,
 check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].
 
 induction p;intros hyps F gl.
@@ -279,7 +281,7 @@ intros f ef;caseq (get p0 hyps);clean.
 intros f0 ef0;destruct f0;clean.
 caseq (form_eq f f0_1);clean.
 simpl;intros e check_p1.
-generalize  (project  F ef) (project  F ef0) 
+generalize  (project  F ef) (project  F ef0)
 (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
 clear check_p1 IHp p p0 p1 ef ef0.
 simpl.
@@ -295,7 +297,7 @@ destruct f1;clean.
 caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
 intros check_p1 check_p2.
 generalize (project F ef)
-(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)   
+(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
 (F_push f1_1 (hyps \ f1_2 =>> f2)
  (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
 (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
@@ -329,7 +331,7 @@ simpl;caseq (get p hyps);clean.
 intros f ef;destruct f;clean.
 destruct f1;clean.
 intro H;generalize  (project F ef)
-(IHp (hyps \ f1_1 =>> f1_2 =>> f2)  
+(IHp (hyps \ f1_1 =>> f1_2 =>> f2)
 (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl.
 apply compose2;auto.
 
@@ -362,7 +364,7 @@ intros f ef;destruct f;clean.
 destruct f1;clean.
 intro check_p0;generalize (project F ef)
 (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
-(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) 
+(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2)
  (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl.
 apply compose2;auto.
 
@@ -370,7 +372,7 @@ apply compose2;auto.
 Focus 1.
 simpl;caseq (check_proof hyps f p1);clean.
 intros check_p1 check_p2;
-generalize (IHp1 hyps F f check_p1) 
+generalize (IHp1 hyps F f check_p1)
 (IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
 simpl; apply compose2;auto.
 Qed.
@@ -390,8 +392,8 @@ Parameters A B C D:Prop.
 Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
 exact (Reflect (empty \ A \ B \ C)
 ([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3])
-(I_Arrow (E_And 1 (E_Or 3 
-  (I_Or_l (I_And (Ax 2) (Ax 4))) 
+(I_Arrow (E_And 1 (E_Or 3
+  (I_Or_l (I_And (Ax 2) (Ax 4)))
   (I_Or_r (I_And (Ax 2) (Ax 4))))))).
 Qed.
 Print toto.
diff --git a/contrib/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index d7bb6e31..4cbe8436 100644
--- a/contrib/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_rtauto.ml4 7734 2005-12-26 14:06:51Z herbelin $*)
+(* $Id$*)
 
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
diff --git a/contrib/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 98643e0f..562e2e3b 100644
--- a/contrib/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: proof_search.ml 7233 2005-07-15 12:34:56Z corbinea $ *)
+(* $Id$ *)
 
 open Term
-open Util  
+open Util
 open Goptions
 
 type s_info=
@@ -50,16 +50,16 @@ let pruning = ref true
 let opt_pruning=
   {optsync=true;
    optname="Rtauto Pruning";
-   optkey=SecondaryTable("Rtauto","Pruning");
+   optkey=["Rtauto";"Pruning"];
    optread=(fun () -> !pruning);
    optwrite=(fun b -> pruning:=b)}
 
-let _ = declare_bool_option opt_pruning 
+let _ = declare_bool_option opt_pruning
 
 type form=
     Atom of int
   | Arrow of form * form
-  | Bot 
+  | Bot
   | Conjunct of form * form
   | Disjunct of form * form
 
@@ -67,14 +67,14 @@ type tag=int
 
 let decomp_form=function
     Atom i -> Some (i,[])
-  | Arrow (f1,f2) -> Some (-1,[f1;f2]) 
+  | Arrow (f1,f2) -> Some (-1,[f1;f2])
   | Bot -> Some (-2,[])
   | Conjunct (f1,f2) -> Some (-3,[f1;f2])
   | Disjunct (f1,f2) -> Some (-4,[f1;f2])
 
 module Fmap=Map.Make(struct type t=form let compare=compare end)
 
-type sequent = 
+type sequent =
     {rev_hyps: form Intmap.t;
      norev_hyps: form Intmap.t;
      size:int;
@@ -103,14 +103,14 @@ type proof =
   | E_Or of int*proof*proof
   | D_Or of int*proof
   | Pop of int*proof
-      
+
 type rule =
     SAx of int
-  | SI_Arrow 
+  | SI_Arrow
   | SE_Arrow of int*int
   | SD_Arrow of int
   | SE_False of int
-  | SI_And 
+  | SI_And
   | SE_And of int
   | SD_And of int
   | SI_Or_l
@@ -132,9 +132,9 @@ let add_step s sub =
     | SI_Or_r,[p] -> I_Or_r p
     | SE_Or i,[p1;p2] -> E_Or(i,p1,p2)
     | SD_Or i,[p] -> D_Or(i,p)
-    | _,_ -> anomaly "add_step: wrong arity" 
-    
-type 'a with_deps = 
+    | _,_ -> anomaly "add_step: wrong arity"
+
+type 'a with_deps =
     {dep_it:'a;
      dep_goal:bool;
      dep_hyps:Intset.t}
@@ -148,7 +148,7 @@ type slice=
      changes_goal:bool;
      creates_hyps:Intset.t}
 
-type state = 
+type state =
     Complete of proof
   | Incomplete of sequent * slice list
 
@@ -164,15 +164,15 @@ let pop n prf =
     {prf with dep_it = nprf}
 
 let rec fill stack proof =
-  match stack with 
+  match stack with
       [] -> Complete proof.dep_it
     | slice::super ->
-	if 
+	if
 	  !pruning &&
 	  slice.proofs_done=[] &&
 	  not (slice.changes_goal && proof.dep_goal) &&
-	  not (Intset.exists 
-		 (fun i -> Intset.mem i proof.dep_hyps) 
+	  not (Intset.exists
+		 (fun i -> Intset.mem i proof.dep_hyps)
 		 slice.creates_hyps)
 	then
 	  begin
@@ -181,23 +181,23 @@ let rec fill stack proof =
 	    List.length slice.proofs_todo;
 	    let created_here=Intset.cardinal slice.creates_hyps in
 	      s_info.pruned_hyps<-s_info.pruned_hyps+
-	      List.fold_left 
-		(fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) 
+	      List.fold_left
+		(fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps)
 		created_here slice.proofs_todo;
 	    fill super (pop (Intset.cardinal slice.creates_hyps) proof)
 	  end
 	else
 	  let dep_hyps=
-	    Intset.union slice.needs_hyps 
+	    Intset.union slice.needs_hyps
 	      (Intset.diff proof.dep_hyps slice.creates_hyps) in
 	  let dep_goal=
-	    slice.needs_goal || 
+	    slice.needs_goal ||
 	    ((not slice.changes_goal) && proof.dep_goal) in
 	  let proofs_done=
 	    proof.dep_it::slice.proofs_done in
 	    match slice.proofs_todo with
 		[] ->
-		  fill super {dep_it = 
+		  fill super {dep_it =
 				add_step slice.step (List.rev proofs_done);
 			      dep_goal = dep_goal;
 			      dep_hyps = dep_hyps}
@@ -214,8 +214,8 @@ let rec fill stack proof =
 
 let append stack (step,subgoals) =
   s_info.created_steps<-s_info.created_steps+1;
-  match subgoals with 
-      [] -> 
+  match subgoals with
+      [] ->
 	s_info.branch_successes<-s_info.branch_successes+1;
 	fill stack {dep_it=add_step step.dep_it [];
 		    dep_goal=step.dep_goal;
@@ -239,10 +239,10 @@ let embed seq=
    dep_hyps=Intset.empty}
 
 let change_goal seq gl=
-    {seq with 
+    {seq with
        dep_it={seq.dep_it with gl=gl};
        dep_goal=true}
-	
+
 let add_hyp seqwd f=
   s_info.created_hyps<-s_info.created_hyps+1;
   let seq=seqwd.dep_it in
@@ -256,71 +256,71 @@ let add_hyp seqwd f=
     with Not_found -> seq.cnx,seq.right in
   let nseq=
     match f with
-	Bot -> 
-	  {seq with 
+	Bot ->
+	  {seq with
 	     left=left;
 	     right=right;
 	     size=num;
 	     abs=Some num;
 	     cnx=cnx}
       | Atom _ ->
-	  {seq with 
+	  {seq with
 	     size=num;
 	     left=left;
 	     right=right;
 	     cnx=cnx}
       | Conjunct (_,_) | Disjunct (_,_) ->
 	  {seq with
-	     rev_hyps=Intmap.add num f seq.rev_hyps; 
+	     rev_hyps=Intmap.add num f seq.rev_hyps;
 	     size=num;
 	     left=left;
 	     right=right;
 	     cnx=cnx}
       | Arrow (f1,f2) ->
 	  let ncnx,nright=
-	    try 
-	      let i = Fmap.find f1 seq.left in	  
+	    try
+	      let i = Fmap.find f1 seq.left in
 		(i,num,f1,f2)::cnx,right
 	    with Not_found ->
 	      cnx,(add_one_arrow num f1 f2 right) in
 	    match f1 with
 		Conjunct (_,_) | Disjunct (_,_) ->
 		  {seq with
-		     rev_hyps=Intmap.add num f seq.rev_hyps; 
+		     rev_hyps=Intmap.add num f seq.rev_hyps;
 		     size=num;
 		     left=left;
 		     right=nright;
 		     cnx=ncnx}
 	      | Arrow(_,_) ->
 		  {seq with
-		     norev_hyps=Intmap.add num f seq.norev_hyps; 
+		     norev_hyps=Intmap.add num f seq.norev_hyps;
 		     size=num;
 		     left=left;
 		     right=nright;
 		     cnx=ncnx}
-	      | _ -> 
+	      | _ ->
 		  {seq with
 		     size=num;
 		     left=left;
 		     right=nright;
 		     cnx=ncnx} in
-    {seqwd with 
+    {seqwd with
        dep_it=nseq;
        dep_hyps=Intset.add num seqwd.dep_hyps}
 
 exception Here_is of (int*form)
 
-let choose m= 
-  try 
+let choose m=
+  try
     Intmap.iter (fun i f -> raise (Here_is (i,f))) m;
     raise Not_found
-  with 
+  with
       Here_is (i,f) -> (i,f)
 
 
 let search_or seq=
   match seq.gl with
-      Disjunct (f1,f2) -> 
+      Disjunct (f1,f2) ->
 	[{dep_it = SI_Or_l;
 	  dep_goal = true;
 	  dep_hyps = Intset.empty},
@@ -333,19 +333,19 @@ let search_or seq=
 
 let search_norev seq=
   let goals=ref (search_or seq) in
-  let add_one i f= 
+  let add_one i f=
     match f with
 	Arrow (Arrow (f1,f2),f3) ->
-	  let nseq = 
+	  let nseq =
 	    {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in
 	    goals:=
 	      ({dep_it=SD_Arrow(i);
 		dep_goal=false;
 		dep_hyps=Intset.singleton i},
-	       [add_hyp 
-		  (add_hyp 
-		     (change_goal (embed nseq) f2) 
-		     (Arrow(f2,f3))) 
+	       [add_hyp
+		  (add_hyp
+		     (change_goal (embed nseq) f2)
+		     (Arrow(f2,f3)))
 		  f1;
 		add_hyp (embed nseq) f3]):: !goals
       | _ -> anomaly "search_no_rev: can't happen" in
@@ -353,7 +353,7 @@ let search_norev seq=
     List.rev !goals
 
 let search_in_rev_hyps seq=
-  try 
+  try
     let i,f=choose seq.rev_hyps in
     let make_step step=
       {dep_it=step;
@@ -361,25 +361,25 @@ let search_in_rev_hyps seq=
        dep_hyps=Intset.singleton i} in
     let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in
       match f with
-	  Conjunct (f1,f2) -> 
+	  Conjunct (f1,f2) ->
 	    [make_step (SE_And(i)),
 	     [add_hyp (add_hyp (embed nseq) f1) f2]]
 	| Disjunct (f1,f2) ->
 	    [make_step (SE_Or(i)),
 	     [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]]
-	| Arrow (Conjunct (f1,f2),f0) -> 
+	| Arrow (Conjunct (f1,f2),f0) ->
 	    [make_step (SD_And(i)),
 	     [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]]
 	| Arrow (Disjunct (f1,f2),f0) ->
 	    [make_step (SD_Or(i)),
 	     [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]]
-	| _ -> anomaly "search_in_rev_hyps: can't happen"	      
+	| _ -> anomaly "search_in_rev_hyps: can't happen"
   with
       Not_found -> search_norev seq
- 
+
 let search_rev seq=
   match seq.cnx with
-      (i,j,f1,f2)::next -> 
+      (i,j,f1,f2)::next ->
 	let nseq=
 	  match f1 with
 	      Conjunct (_,_) | Disjunct (_,_) ->
@@ -394,7 +394,7 @@ let search_rev seq=
 	    dep_goal=false;
 	    dep_hyps=Intset.add i (Intset.singleton j)},
 	   [add_hyp (embed nseq) f2]]
-    | [] -> 
+    | [] ->
 	match seq.gl with
 	    Arrow (f1,f2) ->
 	      [{dep_it=SI_Arrow;
@@ -410,19 +410,19 @@ let search_rev seq=
 
 let search_all seq=
   match seq.abs with
-      Some i -> 
+      Some i ->
 	[{dep_it=SE_False (i);
 	  dep_goal=false;
 	  dep_hyps=Intset.singleton i},[]]
     | None ->
-	try 
+	try
 	  let ax = Fmap.find seq.gl seq.left in
 	    [{dep_it=SAx (ax);
 	      dep_goal=true;
 	      dep_hyps=Intset.singleton ax},[]]
 	with Not_found -> search_rev seq
 
-let bare_sequent = embed 
+let bare_sequent = embed
 		     {rev_hyps=Intmap.empty;
 		      norev_hyps=Intmap.empty;
 		      size=0;
@@ -431,7 +431,7 @@ let bare_sequent = embed
 		      cnx=[];
 		      abs=None;
 		      gl=Bot}
-		     
+
 let init_state hyps gl=
   let init = change_goal bare_sequent gl in
   let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in
@@ -448,12 +448,12 @@ let branching = function
       let _ =
 	match successors with
 	    [] -> s_info.branch_failures<-s_info.branch_failures+1
-	  | _::next ->  
+	  | _::next ->
 	      s_info.nd_branching<-s_info.nd_branching+List.length next in
 	List.map (append stack) successors
   | Complete prf -> anomaly "already succeeded"
 
-open Pp 
+open Pp
 
 let rec pp_form =
   function
@@ -470,13 +470,13 @@ and pp_and = function
 and pp_atom= function
     Bot -> str "#"
   | Atom n -> int n
-  | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" 
+  | f -> str "(" ++ hv 2 (pp_form f) ++ str ")"
 
 let pr_form f = msg (pp_form f)
 
-let pp_intmap map = 
-  let pp=ref (str "") in  
-   Intmap.iter (fun i obj -> pp:= (!pp ++ 
+let pp_intmap map =
+  let pp=ref (str "") in
+   Intmap.iter (fun i obj -> pp:= (!pp ++
 		pp_form obj ++ cut ())) map;
     str "{ " ++ v 0 (!pp) ++ str " }"
 
@@ -486,17 +486,17 @@ let pp=ref (str "") in
   str "[ " ++ !pp ++ str "]"
 
 let pp_mapint map =
-  let pp=ref (str "") in  
-   Fmap.iter (fun obj l -> pp:= (!pp ++ 
-		pp_form obj ++ str " => " ++ 
-				 pp_list (fun (i,f) -> pp_form f) l ++ 
+  let pp=ref (str "") in
+   Fmap.iter (fun obj l -> pp:= (!pp ++
+		pp_form obj ++ str " => " ++
+				 pp_list (fun (i,f) -> pp_form f) l ++
 				 cut ()) ) map;
     str "{ " ++ vb 0 ++  (!pp) ++ str " }" ++ close ()
 
 let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2
 
 let pp_gl gl= cut () ++
-  str "{ " ++ vb 0 ++ 
+  str "{ " ++ vb 0 ++
 	      begin
 		match gl.abs with
 		    None -> str ""
@@ -504,38 +504,38 @@ let pp_gl gl= cut () ++
 	      end ++
   str "rev   =" ++ pp_intmap gl.rev_hyps ++ cut () ++
   str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++
-  str "arrows=" ++ pp_mapint gl.right ++ cut () ++ 
-  str "cnx   =" ++ pp_list pp_connect gl.cnx ++ cut () ++ 
+  str "arrows=" ++ pp_mapint gl.right ++ cut () ++
+  str "cnx   =" ++ pp_list pp_connect gl.cnx ++ cut () ++
   str "goal  =" ++ pp_form gl.gl ++ str " }" ++ close ()
 
-let pp = 
+let pp =
   function
       Incomplete(gl,ctx) -> msgnl (pp_gl gl)
     | _ -> msg (str "<complete>")
 
-let pp_info () = 
-  let count_info = 
+let pp_info () =
+  let count_info =
     if !pruning then
-	str "Proof steps : " ++ 
-	int s_info.created_steps ++ str " created / " ++ 
+	str "Proof steps : " ++
+	int s_info.created_steps ++ str " created / " ++
 	int s_info.pruned_steps ++ str " pruned" ++ fnl () ++
-	str "Proof branches : " ++ 
-	int s_info.created_branches ++ str " created / " ++ 
+	str "Proof branches : " ++
+	int s_info.created_branches ++ str " created / " ++
 	int s_info.pruned_branches ++ str " pruned" ++ fnl () ++
-	str "Hypotheses : " ++ 
-	int s_info.created_hyps ++ str " created / " ++ 
+	str "Hypotheses : " ++
+	int s_info.created_hyps ++ str " created / " ++
 	int s_info.pruned_hyps ++ str " pruned" ++ fnl ()
     else
 	str "Pruning is off" ++ fnl () ++
-	str "Proof steps : " ++ 
+	str "Proof steps : " ++
 	int s_info.created_steps ++ str " created" ++ fnl () ++
-	str "Proof branches : " ++ 
+	str "Proof branches : " ++
 	int s_info.created_branches ++ str " created" ++ fnl () ++
-	str "Hypotheses : " ++ 
+	str "Hypotheses : " ++
 	int s_info.created_hyps ++ str " created" ++ fnl () in
     msgnl
       ( str "Proof-search statistics :" ++ fnl () ++
-	count_info ++ 
+	count_info ++
 	str "Branch ends: " ++
 	int s_info.branch_successes ++ str " successes / " ++
 	int s_info.branch_failures ++ str " failures" ++ fnl () ++
@@ -543,4 +543,4 @@ let pp_info () =
 	int s_info.nd_branching ++ str " branches")
 
 
- 
+
diff --git a/contrib/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
index eb11aeae..e52f6bbd 100644
--- a/contrib/rtauto/proof_search.mli
+++ b/plugins/rtauto/proof_search.mli
@@ -6,15 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: proof_search.mli 7233 2005-07-15 12:34:56Z corbinea $ *)
+(* $Id$ *)
 
 type form=
     Atom of int
   | Arrow of form * form
-  | Bot 
+  | Bot
   | Conjunct of form * form
   | Disjunct of form * form
-  
+
 type proof =
     Ax of int
   | I_Arrow of proof
diff --git a/contrib/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 81256f4a..23cb0705 100644
--- a/contrib/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refl_tauto.ml 10478 2008-01-29 10:31:39Z notin $ *)
+(* $Id$ *)
 
 module Search = Explore.Make(Proof_search)
 
@@ -18,24 +18,24 @@ open Evd
 open Tacmach
 open Proof_search
 
-let force count lazc = incr count;Lazy.force lazc 
+let force count lazc = incr count;Lazy.force lazc
 
 let step_count = ref 0
 
-let node_count = ref 0  
+let node_count = ref 0
 
-let logic_constant = 
-  Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] 
+let logic_constant =
+  Coqlib.gen_constant "refl_tauto" ["Init";"Logic"]
 
 let li_False = lazy (destInd (logic_constant "False"))
 let li_and = lazy (destInd (logic_constant "and"))
 let li_or =  lazy (destInd (logic_constant "or"))
 
 let data_constant =
-  Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] 
+  Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"]
 
-let l_true_equals_true = 
-  lazy (mkApp(logic_constant "refl_equal", 
+let l_true_equals_true =
+  lazy (mkApp(logic_constant "refl_equal",
         [|data_constant "bool";data_constant "true"|]))
 
 let pos_constant =
@@ -45,7 +45,7 @@ let l_xI = lazy (pos_constant "xI")
 let l_xO = lazy (pos_constant "xO")
 let l_xH = lazy (pos_constant "xH")
 
-let store_constant = 
+let store_constant =
   Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"]
 
 let l_empty = lazy (store_constant "empty")
@@ -103,17 +103,17 @@ let rec make_form atom_env gls term =
   let normalize=special_nf gls in
   let cciterm=special_whd gls term  in
     match kind_of_term cciterm with
-	Prod(_,a,b) -> 
-	  if not (dependent (mkRel 1) b) && 
-	    Retyping.get_sort_family_of 
+	Prod(_,a,b) ->
+	  if not (dependent (mkRel 1) b) &&
+	    Retyping.get_sort_family_of
 	    (pf_env gls) (Tacmach.project gls) a = InProp
-	  then 
+	  then
 	    let fa=make_form atom_env gls a in
 	    let fb=make_form atom_env gls b in
 	      Arrow (fa,fb)
 	  else
 	    make_atom atom_env (normalize term)
-      | Cast(a,_,_) -> 
+      | Cast(a,_,_) ->
 	  make_form atom_env gls a
       | Ind ind ->
 	  if ind = Lazy.force li_False then
@@ -122,7 +122,7 @@ let rec make_form atom_env gls term =
 	    make_atom atom_env (normalize term)
       | App(hd,argv) when Array.length argv = 2 ->
 	  begin
-	    try 
+	    try
 	      let ind = destInd hd in
 		if ind = Lazy.force li_and then
 		  let fa=make_form atom_env gls argv.(0) in
@@ -139,103 +139,103 @@ let rec make_form atom_env gls term =
 
 let rec make_hyps atom_env gls lenv = function
     [] -> []
-  | (_,Some body,typ)::rest -> 
-      make_hyps atom_env gls (typ::body::lenv) rest  
+  | (_,Some body,typ)::rest ->
+      make_hyps atom_env gls (typ::body::lenv) rest
   | (id,None,typ)::rest ->
       let hrec=
 	make_hyps atom_env gls (typ::lenv) rest in
-	if List.exists (dependent (mkVar id)) lenv || 
-	  (Retyping.get_sort_family_of 
-	     (pf_env gls) (Tacmach.project gls) typ <> InProp) 
+	if List.exists (dependent (mkVar id)) lenv ||
+	  (Retyping.get_sort_family_of
+	     (pf_env gls) (Tacmach.project gls) typ <> InProp)
 	then
-	  hrec 
+	  hrec
 	else
 	  (id,make_form atom_env gls typ)::hrec
 
 let rec build_pos n =
-  if n<=1 then force node_count l_xH 
-  else if n land 1 = 0 then 
+  if n<=1 then force node_count l_xH
+  else if n land 1 = 0 then
     mkApp (force node_count l_xO,[|build_pos (n asr 1)|])
-  else 
+  else
     mkApp (force node_count l_xI,[|build_pos (n asr 1)|])
 
 let rec build_form = function
     Atom n -> mkApp (force node_count l_Atom,[|build_pos n|])
-  | Arrow (f1,f2) -> 
+  | Arrow (f1,f2) ->
       mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|])
   | Bot -> force node_count l_Bot
-  | Conjunct (f1,f2) -> 
+  | Conjunct (f1,f2) ->
       mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|])
-  | Disjunct (f1,f2) -> 
+  | Disjunct (f1,f2) ->
       mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|])
 
-let rec decal k = function 
+let rec decal k = function
     [] -> k
-  | (start,delta)::rest -> 
+  | (start,delta)::rest ->
       if k>start then
 	k - delta
-      else 
+      else
 	decal k rest
 
 let add_pop size d pops=
   match pops with
       [] -> [size+d,d]
-    | (_,sum)::_ -> (size+sum,sum+d)::pops  
+    | (_,sum)::_ -> (size+sum,sum+d)::pops
 
-let rec build_proof pops size = 
+let rec build_proof pops size =
   function
       Ax i ->
 	mkApp (force step_count l_Ax,
 	       [|build_pos (decal i pops)|])
-      | I_Arrow p -> 
+      | I_Arrow p ->
 	  mkApp (force step_count l_I_Arrow,
 		 [|build_proof pops (size + 1) p|])
-      | E_Arrow(i,j,p) -> 
-	  mkApp (force step_count l_E_Arrow, 
+      | E_Arrow(i,j,p) ->
+	  mkApp (force step_count l_E_Arrow,
 		 [|build_pos (decal i pops);
 		   build_pos (decal j pops);
 		   build_proof pops (size + 1) p|])
-      | D_Arrow(i,p1,p2) -> 
-	  mkApp (force step_count l_D_Arrow, 
+      | D_Arrow(i,p1,p2) ->
+	  mkApp (force step_count l_D_Arrow,
 		 [|build_pos (decal i pops);
 		   build_proof pops (size + 2) p1;
 		   build_proof pops (size + 1) p2|])
-      | E_False i -> 
+      | E_False i ->
 	  mkApp (force step_count l_E_False,
 		 [|build_pos (decal i pops)|])
-      | I_And(p1,p2) -> 
-	  mkApp (force step_count l_I_And, 
+      | I_And(p1,p2) ->
+	  mkApp (force step_count l_I_And,
 		 [|build_proof pops size p1;
 		   build_proof pops size p2|])
-      | E_And(i,p) -> 
+      | E_And(i,p) ->
 	  mkApp (force step_count l_E_And,
 		 [|build_pos (decal i pops);
 		   build_proof pops (size + 2) p|])
-      | D_And(i,p) -> 
+      | D_And(i,p) ->
 	  mkApp (force step_count l_D_And,
 		 [|build_pos (decal i pops);
 		   build_proof pops (size + 1) p|])
-      | I_Or_l(p) -> 
+      | I_Or_l(p) ->
 	  mkApp (force step_count l_I_Or_l,
 		 [|build_proof pops size p|])
-      | I_Or_r(p) -> 
+      | I_Or_r(p) ->
 	  mkApp (force step_count l_I_Or_r,
 		 [|build_proof pops size p|])
       | E_Or(i,p1,p2) ->
-	  mkApp (force step_count l_E_Or, 
+	  mkApp (force step_count l_E_Or,
 		 [|build_pos (decal i pops);
 		   build_proof pops (size + 1) p1;
 		   build_proof pops (size + 1) p2|])
-      | D_Or(i,p) -> 
+      | D_Or(i,p) ->
 	  mkApp (force step_count l_D_Or,
 		 [|build_pos (decal i pops);
 		   build_proof pops (size + 2) p|])
       | Pop(d,p) ->
-	  build_proof (add_pop size d pops) size p 
-	    
+	  build_proof (add_pop size d pops) size p
+
 let build_env gamma=
-  List.fold_right (fun (p,_) e -> 
-		     mkApp(force node_count l_push,[|mkProp;p;e|])) 
+  List.fold_right (fun (p,_) e ->
+		     mkApp(force node_count l_push,[|mkProp;p;e|]))
     gamma.env (mkApp (force node_count l_empty,[|mkProp|]))
 
 open Goptions
@@ -245,22 +245,22 @@ let verbose = ref false
 let opt_verbose=
   {optsync=true;
    optname="Rtauto Verbose";
-   optkey=SecondaryTable("Rtauto","Verbose");
+   optkey=["Rtauto";"Verbose"];
    optread=(fun () -> !verbose);
    optwrite=(fun b -> verbose:=b)}
 
-let _ = declare_bool_option opt_verbose 
+let _ = declare_bool_option opt_verbose
 
 let check = ref false
 
 let opt_check=
   {optsync=true;
    optname="Rtauto Check";
-   optkey=SecondaryTable("Rtauto","Check");
+   optkey=["Rtauto";"Check"];
    optread=(fun () -> !check);
    optwrite=(fun b -> check:=b)}
 
-let _ = declare_bool_option opt_check 
+let _ = declare_bool_option opt_check
 
 open Pp
 
@@ -269,34 +269,34 @@ let rtauto_tac gls=
   let gamma={next=1;env=[]} in
   let gl=gls.it.evar_concl in
   let _=
-    if Retyping.get_sort_family_of 
-      (pf_env gls) (Tacmach.project gls) gl <> InProp 
+    if Retyping.get_sort_family_of
+      (pf_env gls) (Tacmach.project gls) gl <> InProp
     then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in
   let glf=make_form gamma gls gl in
-  let hyps=make_hyps gamma gls [gl] 
+  let hyps=make_hyps gamma gls [gl]
       (Environ.named_context_of_val gls.it.evar_hyps) in
   let formula=
-    List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in  
-  let search_fun = 
+    List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in
+  let search_fun =
     if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then
       Search.debug_depth_first
-    else 
+    else
       Search.depth_first in
-  let _ = 
+  let _ =
     begin
       reset_info ();
       if !verbose then
 	msgnl (str "Starting proof-search ...");
     end in
   let search_start_time = System.get_time () in
-  let prf = 
-    try project (search_fun (init_state [] formula)) 
+  let prf =
+    try project (search_fun (init_state [] formula))
     with Not_found ->
       errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in
   let search_end_time = System.get_time () in
   let _ = if !verbose then
     begin
-      msgnl (str "Proof tree found in " ++ 
+      msgnl (str "Proof tree found in " ++
 	     System.fmt_time_difference search_start_time search_end_time);
       pp_info ();
       msgnl (str "Building proof term ... ")
@@ -312,10 +312,10 @@ let rtauto_tac gls=
   let build_end_time=System.get_time () in
   let _ = if !verbose then
     begin
-      msgnl (str "Proof term built in " ++ 
+      msgnl (str "Proof term built in " ++
 	     System.fmt_time_difference build_start_time build_end_time ++
 	     fnl () ++
-	     str "Proof size : " ++ int !step_count ++ 
+	     str "Proof size : " ++ int !step_count ++
 	     str " steps" ++ fnl () ++
 	     str "Proof term size : " ++ int (!step_count+ !node_count) ++
 	     str " nodes (constants)" ++ fnl () ++
@@ -323,15 +323,15 @@ let rtauto_tac gls=
     end in
   let tac_start_time = System.get_time () in
   let result=
-    if !check then 
+    if !check then
       Tactics.exact_check term gls
     else
       Tactics.exact_no_check term gls in
   let tac_end_time = System.get_time () in
-  let _ = 
+  let _ =
     if !check then msgnl (str "Proof term type-checking is on");
     if !verbose then
-      msgnl (str "Internal tactic executed in " ++ 
+      msgnl (str "Internal tactic executed in " ++
 	     System.fmt_time_difference tac_start_time tac_end_time) in
     result
 
diff --git a/contrib/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index 480dbb30..a6d68a22 100644
--- a/contrib/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: refl_tauto.mli 7233 2005-07-15 12:34:56Z corbinea $ *)
+(* $Id$ *)
 
 (* raises Not_found if no proof is found *)
 
diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mllib
new file mode 100644
index 00000000..0e346044
--- /dev/null
+++ b/plugins/rtauto/rtauto_plugin.mllib
@@ -0,0 +1,4 @@
+Proof_search
+Refl_tauto
+G_rtauto
+Rtauto_plugin_mod
diff --git a/plugins/rtauto/vo.itarget b/plugins/rtauto/vo.itarget
new file mode 100644
index 00000000..4c9364ad
--- /dev/null
+++ b/plugins/rtauto/vo.itarget
@@ -0,0 +1,2 @@
+Bintree.vo
+Rtauto.vo
diff --git a/contrib/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 601cabe0..e5a4c8d1 100644
--- a/contrib/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -16,11 +16,11 @@ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
  Proof.
   constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
   exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
-  exact mult_plus_distr_r. 
+  exact mult_plus_distr_r.
  Qed.
 
-Lemma nat_morph_N : 
-   semi_morph 0 1 plus mult (eq (A:=nat)) 
+Lemma nat_morph_N :
+   semi_morph 0 1 plus mult (eq (A:=nat))
           0%N 1%N Nplus Nmult Neq_bool nat_of_N.
 Proof.
   constructor;trivial.
@@ -46,7 +46,7 @@ Ltac natprering :=
     |- context C [S ?p] =>
     match p with
       O => fail 1 (* avoid replacing 1 with 1+0 ! *)
-    | p => match isnatcst p with 
+    | p => match isnatcst p with
            | true => fail 1
            | false => let v := Ss_to_add p (S 0) in
                          fold v; natprering
diff --git a/contrib/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 50902004..d403c9ef 100644
--- a/contrib/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -28,17 +28,17 @@ Section MakeBinList.
   | xH => hd default l
   | xO p => nth p (jump p l)
   | xI p => nth p (jump p (tail l))
-  end. 
+  end.
 
  Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
- Proof. 
+ Proof.
   induction j;simpl;intros.
   repeat rewrite IHj;trivial.
   repeat rewrite IHj;trivial.
   trivial.
  Qed.
 
- Lemma jump_Psucc : forall j l, 
+ Lemma jump_Psucc : forall j l,
   (jump (Psucc j) l) = (jump 1 (jump j l)).
  Proof.
   induction j;simpl;intros.
@@ -47,7 +47,7 @@ Section MakeBinList.
   trivial.
  Qed.
 
- Lemma jump_Pplus : forall i j l, 
+ Lemma jump_Pplus : forall i j l,
   (jump (i + j) l) = (jump i (jump j l)).
  Proof.
   induction i;intros.
@@ -69,7 +69,7 @@ Section MakeBinList.
   trivial.
  Qed.
 
- 
+
  Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
  Proof.
   induction p;simpl;intros.
diff --git a/contrib/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
index a944ba5f..a944ba5f 100644
--- a/contrib/setoid_ring/Field.v
+++ b/plugins/setoid_ring/Field.v
diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
new file mode 100644
index 00000000..9d82d1fd
--- /dev/null
+++ b/plugins/setoid_ring/Field_tac.v
@@ -0,0 +1,571 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Ring_tac BinList Ring_polynom InitialRing.
+Require Export Field_theory.
+
+ (* syntaxification *)
+ Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv :=
+ let rec mkP t :=
+    let f :=
+    match Cst t with
+    | InitialRing.NotConstant =>
+        match t with
+        | (radd ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEadd e1 e2)
+        | (rmul ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEmul e1 e2)
+        | (rsub ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEsub e1 e2)
+        | (ropp ?t1) =>
+          fun _ => let e1 := mkP t1 in constr:(FEopp e1)
+        | (rdiv ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEdiv e1 e2)
+        | (rinv ?t1) =>
+          fun _ => let e1 := mkP t1 in constr:(FEinv e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant =>
+            fun _ =>
+            let p := Find_at t fv in
+            constr:(@FEX C p)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c)
+          end
+        | _ =>
+          fun _ =>
+          let p := Find_at t fv in
+          constr:(@FEX C p)
+        end
+    | ?c => fun _ => constr:(FEc c)
+    end in
+    f ()
+ in mkP t.
+
+Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
+ let rec TFV t fv :=
+  match Cst t with
+  | InitialRing.NotConstant =>
+      match t with
+      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (opp ?t1) => TFV t1 fv
+      | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (inv ?t1) => TFV t1 fv
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant =>
+            AddFvTail t fv
+        | _ => TFV t1 fv
+        end
+      | _ => AddFvTail t fv
+      end
+  | _ => fv
+  end
+ in TFV t fv.
+
+(* packaging the field structure *)
+
+(* TODO: inline PackField into field_lookup *)
+Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post :=
+  let FLD :=
+    match type of L1 with
+    | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
+                                      ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
+        (fun proj =>
+           proj Cst_tac Pow_tac pre post
+             req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
+    | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+    end in
+  F FLD.
+
+Ltac get_FldPre FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       pre).
+
+Ltac get_FldPost FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       post).
+
+Ltac get_L1 FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L1).
+
+Ltac get_SimplifyEqLemma FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L2).
+
+Ltac get_SimplifyLemma FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L3).
+
+Ltac get_L4 FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L4).
+
+Ltac get_CondLemma FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       cond_ok).
+
+Ltac get_FldEq FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       req).
+
+Ltac get_FldCarrier FLD :=
+  let req := get_FldEq FLD in
+  relation_carrier req.
+
+Ltac get_RingFV FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       FV Cst_tac Pow_tac radd rmul rsub ropp rpow).
+
+Ltac get_FFV FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+
+Ltac get_RingMeta FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow).
+
+Ltac get_Meta FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+
+Ltac get_Hyp_tac FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+       fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
+
+Ltac get_FEeval FLD :=
+  let L1 := get_L1 FLD in
+  match type of L1 with
+  | context
+    [(@FEeval
+      ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
+       constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow)
+  | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)"
+  end.
+
+(* simplifying the non-zero condition... *)
+
+Ltac fold_field_cond req :=
+  let rec fold_concl t :=
+    match t with
+      ?x /\ ?y =>
+        let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
+    | req ?x ?y -> False => constr:(~ req x y)
+    | _ => t
+    end in
+  let ft := fold_concl Get_goal in
+  change ft.
+
+Ltac simpl_PCond FLD :=
+  let req := get_FldEq FLD in
+  let lemma := get_CondLemma FLD in
+  try apply lemma;
+  protect_fv "field_cond";
+  fold_field_cond req;
+  try exact I.
+
+Ltac simpl_PCond_BEURK FLD :=
+  let req := get_FldEq FLD in
+  let lemma := get_CondLemma FLD in
+  apply lemma;
+  protect_fv "field_cond";
+  fold_field_cond req.
+
+(* Rewriting (field_simplify) *)
+Ltac Field_norm_gen f n FLD lH rl :=
+  let mkFV := get_RingFV FLD in
+  let mkFFV := get_FFV FLD in
+  let mkFE :=  get_Meta FLD in
+  let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in
+  let lemma_tac fv kont :=
+    let lemma := get_SimplifyLemma FLD in
+    (* reify equations of the context *)
+    let lpe := get_Hyp_tac FLD fv lH in
+    let vlpe := fresh "hyps" in
+    pose (vlpe := lpe);
+    let prh := proofHyp_tac lH in
+    (* compute the normal form of the reified hyps *)
+    let vlmp := fresh "hyps'" in
+    let vlmp_eq := fresh "hyps_eq" in
+    let mk_monpol := get_MonPol lemma in
+    compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
+    (* partially instantiate the lemma *)
+    let lem := fresh "f_rw_lemma" in
+    (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq)
+     || fail "type error when building the rewriting lemma");
+    (* continuation will call main_tac for all reified terms *)
+    kont lem;
+    (* at the end, cleanup *)
+    (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in
+  (* each instance of the lemma is simplified then passed to f *)
+  let main_tac H := protect_fv "field" in H; f H in
+  (* generate and use equations for each expression *)
+  ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl;
+  try simpl_PCond FLD.
+
+Ltac Field_simplify_gen f FLD lH rl :=
+  get_FldPre FLD ();
+  Field_norm_gen f ring_subst_niter FLD lH rl;
+  get_FldPost FLD ().
+
+Ltac Field_simplify :=
+  Field_simplify_gen ltac:(fun H => rewrite H).
+
+Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
+  let G := Get_goal in
+  field_lookup (PackField Field_simplify) [] rl G.
+
+Tactic Notation (at level 0)
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  let G := Get_goal in
+  field_lookup (PackField Field_simplify) [lH] rl G.
+
+Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=
+  let G := Get_goal in
+  let t := type of H in
+  let g := fresh "goal" in
+  set (g:= G);
+  revert H;
+  field_lookup (PackField Field_simplify) [] rl t;
+  intro H;
+  unfold g;clear g.
+
+Tactic Notation "field_simplify"
+    "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):=
+  let G := Get_goal in
+  let t := type of H in
+  let g := fresh "goal" in
+  set (g:= G);
+  revert H;
+  field_lookup (PackField Field_simplify) [lH] rl t;
+  intro H;
+  unfold g;clear g.
+
+(*
+Ltac Field_simplify_in hyp:=
+   Field_simplify_gen ltac:(fun H => rewrite H in hyp).
+
+Tactic Notation (at level 0)
+  "field_simplify" constr_list(rl) "in" hyp(h) :=
+  let t := type of h in
+  field_lookup (Field_simplify_in h) [] rl t.
+
+Tactic Notation (at level 0)
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
+  let t := type of h in
+  field_lookup (Field_simplify_in h) [lH] rl t.
+*)
+
+(** Generic tactic for solving equations *)
+
+Ltac Field_Scheme Simpl_tac n lemma FLD lH :=
+  let req := get_FldEq FLD in
+  let mkFV := get_RingFV FLD in
+  let mkFFV := get_FFV FLD in
+  let mkFE := get_Meta FLD in
+  let Main_eq t1 t2 :=
+    let fv := FV_hypo_tac mkFV req lH in
+    let fv := mkFFV t1 fv in
+    let fv := mkFFV t2 fv in
+    let lpe := get_Hyp_tac FLD fv lH in
+    let prh := proofHyp_tac lH in
+    let vlpe := fresh "list_hyp" in
+    let fe1 := mkFE t1 fv in
+    let fe2 := mkFE t2 fv in
+    pose (vlpe := lpe);
+    let nlemma := fresh "field_lemma" in
+    (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
+     || fail "field anomaly:failed to build lemma");
+    ProveLemmaHyps nlemma
+      ltac:(fun ilemma =>
+              apply ilemma
+               || fail "field anomaly: failed in applying lemma";
+              [ Simpl_tac | simpl_PCond FLD]);
+    clear nlemma;
+    subst vlpe in
+  OnEquation req Main_eq.
+
+(* solve completely a field equation, leaving non-zero conditions to be
+   proved (field) *)
+
+Ltac FIELD FLD lH rl :=
+  let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
+  let lemma := get_L1 FLD in
+  get_FldPre FLD ();
+  Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
+  try exact I;
+  get_FldPost FLD().
+
+Tactic Notation (at level 0) "field" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD) [] G.
+
+Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD) [lH] G.
+
+(* transforms a field equation to an equivalent (simplified) ring equation,
+   and leaves non-zero conditions to be proved (field_simplify_eq) *)
+Ltac FIELD_SIMPL FLD lH rl :=
+  let Simpl := (protect_fv "field") in
+  let lemma := get_SimplifyEqLemma FLD in
+  get_FldPre FLD ();
+  Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
+  get_FldPost FLD ().
+
+Tactic Notation (at level 0) "field_simplify_eq" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD_SIMPL) [] G.
+
+Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD_SIMPL) [lH] G.
+
+(* Same as FIELD_SIMPL but in hypothesis *)
+
+Ltac Field_simplify_eq n FLD lH :=
+  let req := get_FldEq FLD in
+  let mkFV := get_RingFV FLD in
+  let mkFFV := get_FFV FLD in
+  let mkFE := get_Meta FLD in
+  let lemma := get_L4 FLD in
+  let hyp := fresh "hyp" in
+  intro hyp;
+  OnEquationHyp req hyp ltac:(fun t1 t2 =>
+      let fv := FV_hypo_tac mkFV req lH in
+      let fv := mkFFV t1 fv in
+      let fv := mkFFV t2 fv in
+      let lpe := get_Hyp_tac FLD fv lH in
+      let prh := proofHyp_tac lH in
+      let fe1 := mkFE t1 fv in
+      let fe2 := mkFE t2 fv in
+      let vlpe := fresh "vlpe" in
+      ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh)
+         ltac:(fun ilemma =>
+             match type of ilemma with
+             | req _ _ ->  _ -> ?EQ =>
+               let tmp := fresh "tmp" in
+               assert (tmp : EQ);
+               [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD]
+               | protect_fv "field" in tmp; revert tmp ];
+               clear hyp
+             end)).
+
+Ltac FIELD_SIMPL_EQ FLD lH rl :=
+  get_FldPre FLD ();
+  Field_simplify_eq Ring_tac.ring_subst_niter FLD lH;
+  get_FldPost FLD ().
+
+Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
+  let t := type of H in
+  generalize H;
+  field_lookup (PackField FIELD_SIMPL_EQ) [] t;
+  [ try exact I
+  | clear H;intro H].
+
+
+Tactic Notation (at level 0)
+  "field_simplify_eq" "[" constr_list(lH) "]"  "in" hyp(H) :=
+  let t := type of H in
+  generalize H;
+  field_lookup (PackField FIELD_SIMPL_EQ) [lH] t;
+  [ try exact I
+  |clear H;intro H].
+
+(* More generic tactics to build variants of field *)
+
+(* This tactic reifies c and pass to F:
+   - the FLD structure gathering all info in the field DB
+   - the atom list
+   - the expression (FExpr)
+ *)
+Ltac gen_with_field F c :=
+  let MetaExpr FLD _ rl :=
+    let R := get_FldCarrier FLD in
+    let mkFFV := get_FFV FLD in
+    let mkFE  := get_Meta FLD in
+    let csr :=
+      match rl with
+      | List.cons ?r _ => r
+      | _ => fail 1 "anomaly: ill-formed list"
+      end in
+    let fv := mkFFV csr (@List.nil R) in
+    let expr := mkFE csr fv in
+    F FLD fv expr in
+  field_lookup (PackField MetaExpr) [] (c=c).
+
+
+(* pushes the equation expr = ope(expr) in the goal, and
+   discharge it with field *)
+Ltac prove_field_eqn ope FLD fv expr :=
+  let res := ope expr in
+  let expr' := fresh "input_expr" in
+  pose (expr' := expr);
+  let res' := fresh "result" in
+  pose (res' := res);
+  let lemma := get_L1 FLD in
+  let lemma :=
+    constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in
+  let ty := type of lemma in
+  let lhs := match ty with
+    forall _, ?lhs=_ -> _ => lhs
+    end in
+  let rhs := match ty with
+    forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs
+    end in
+  let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in
+  let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in
+  compute_assertion lhs_eq lhs' lhs;
+  compute_assertion rhs_eq rhs' rhs;
+  let H := fresh "fld_eqn" in
+  refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _));
+    (* main goal *)
+    [intro H;protect_fv "field" in H; revert H
+    (* ring-nf(lhs') = ring-nf(rhs') *)
+    | vm_compute; reflexivity || fail "field cannot prove this equality"
+    (* denominator condition *)
+    | simpl_PCond FLD];
+  clear lhs_eq rhs_eq; subst lhs' rhs'.
+
+Ltac prove_with_field ope c :=
+  gen_with_field ltac:(prove_field_eqn ope) c.
+
+(* Prove an equation x=ope(x) and rewrite with it *)
+Ltac prove_rw ope x :=
+  prove_with_field ope x;
+  [ let H := fresh "Heq_maple" in
+    intro H; rewrite H; clear H
+  |..].
+
+(* Apply ope (FExpr->FExpr) on an expression *)
+Ltac reduce_field_expr ope kont FLD fv expr :=
+  let evfun := get_FEeval FLD in
+  let res := ope expr in
+  let c := (eval simpl_field_expr in (evfun fv res)) in
+  kont c.
+
+(* Hack to let a Ltac return a term in the context of a primitive tactic *)
+Ltac return_term x := generalize (refl_equal x).
+Ltac get_term :=
+  match goal with
+  | |- ?x = _ -> _ => x
+  end.
+
+(* Turn an operation on field expressions (FExpr) into a reduction
+   on terms (in the field carrier). Because of field_lookup,
+   the tactic cannot return a term directly, so it is returned
+   via the conclusion of the goal (return_term). *)
+Ltac reduce_field_ope ope c :=
+  gen_with_field ltac:(reduce_field_expr ope return_term) c.
+
+
+(* Adding a new field *)
+
+Ltac ring_of_field f :=
+  match type of f with
+  | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
+  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
+  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
+  end.
+
+Ltac coerce_to_almost_field set ext f :=
+  match type of f with
+  | almost_field_theory _ _ _ _ _ _ _ _ _ => f
+  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
+  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
+  end.
+
+Ltac field_elements set ext fspec pspec sspec dspec rk :=
+  let afth := coerce_to_almost_field set ext fspec in
+  let rspec := ring_of_field fspec in
+  ring_elements set ext rspec pspec sspec dspec rk
+  ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec).
+
+Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
+  let get_lemma :=
+    match pspec with None => fun x y => x | _ => fun x y => y end in
+  let simpl_eq_lemma := get_lemma
+       Field_simplify_eq_correct       Field_simplify_eq_pow_correct in
+  let simpl_eq_in_lemma := get_lemma
+       Field_simplify_eq_in_correct   Field_simplify_eq_pow_in_correct in
+  let rw_lemma := get_lemma
+       Field_rw_correct                    Field_rw_pow_correct in
+  field_elements set ext fspec pspec sspec dspec rk
+   ltac:(fun afth ext_r morph p_spec s_spec d_spec =>
+     match morph with
+     | _ =>
+       let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in
+       match p_spec with
+       | mkhypo ?pp_spec =>
+         let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
+         match s_spec with
+         | mkhypo ?ss_spec =>
+           let field_ok3 := constr:(field_ok2 _ ss_spec) in
+           match d_spec with
+           | mkhypo ?dd_spec =>
+             let field_ok := constr:(field_ok3 _ dd_spec) in
+             let mk_lemma lemma :=
+              constr:(lemma _ _ _  _ _ _  _ _ _ _
+                   set ext_r inv_m afth
+                   _ _ _  _ _ _  _ _ _ morph
+                   _ _ _ pp_spec _ ss_spec _ dd_spec) in
+             let field_simpl_eq_ok := mk_lemma simpl_eq_lemma  in
+             let field_simpl_ok := mk_lemma rw_lemma in
+             let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in
+             let cond1_ok :=
+                constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in
+             let cond2_ok :=
+               constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in
+             (fun f =>
+               f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
+                  cond1_ok cond2_ok)
+           | _ => fail 4 "field: bad coefficiant division specification"
+           end
+         | _ => fail 3 "field: bad sign specification"
+         end
+       | _ => fail 2 "field: bad power specification"
+       end
+     | _ => fail 1 "field internal error : field_lemmas, please report"
+     end).
diff --git a/contrib/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index b2e5cc4b..9617d409 100644
--- a/contrib/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -14,7 +14,7 @@ Set Implicit Arguments.
 
 Section MakeFieldPol.
 
-(* Field elements *)     
+(* Field elements *)
  Variable R:Type.
  Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
  Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
@@ -30,7 +30,7 @@ Section MakeFieldPol.
  Variable Rsth : Setoid_Theory R req.
  Variable Reqe : ring_eq_ext radd rmul ropp req.
  Variable SRinv_ext : forall p q, p == q ->  / p == / q.
- 
+
  (* Field properties *)
   Record almost_field_theory : Prop := mk_afield {
     AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
@@ -47,10 +47,10 @@ Section AlmostField.
  Let rdiv_def := AFth.(AFdiv_def).
  Let rinv_l := AFth.(AFinv_l).
 
- (* Coefficients *) 
+ (* Coefficients *)
  Variable C: Type.
  Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool. 
+ Variable ceqb : C->C->bool.
  Variable phi : C -> R.
 
  Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
@@ -65,7 +65,7 @@ case (ceqb c1 c2); auto.
 Qed.
 
 
- (* C notations *)		 
+ (* C notations *)
  Notation "x +! y" := (cadd x y) (at level 50).
  Notation "x *! y " := (cmul x y) (at level 40).
  Notation "x -! y " := (csub x y) (at level 50).
@@ -74,14 +74,14 @@ Qed.
  Notation "[ x ]" := (phi x) (at level 0).
 
 
- (* Useful tactics *)		  
+ (* Useful tactics *)
   Add Setoid R req Rsth as R_set1.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
   Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
   Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
   Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
   Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
- 
+
 Let eq_trans := Setoid.Seq_trans _ _ Rsth.
 Let eq_sym := Setoid.Seq_sym _ _ Rsth.
 Let eq_refl := Setoid.Seq_refl _ _ Rsth.
@@ -90,15 +90,15 @@ Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
 Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
              (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
 Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
-             (ARmul_1_l  ARth) (ARmul_0_l  ARth) 
+             (ARmul_1_l  ARth) (ARmul_0_l  ARth)
              (ARmul_comm  ARth) (ARmul_assoc ARth) (ARdistr_l  ARth)
-             (ARopp_mul_l ARth) (ARopp_add  ARth) 
+             (ARopp_mul_l ARth) (ARopp_add  ARth)
              (ARsub_def  ARth) .
 
  (* Power coefficients *)
  Variable Cpow : Set.
  Variable Cp_phi : N -> Cpow.
- Variable rpow : R -> Cpow -> R. 
+ Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
  (* sign function *)
  Variable get_sign : C -> option C.
@@ -129,11 +129,11 @@ rewrite (ARopp_zero Rsth Reqe ARth) in |- *;  ring.
 Qed.
 
 (***************************************************************************
-                                                                          
-                       Properties of division                             
-                                                                          
+
+                       Properties of division
+
   ***************************************************************************)
- 
+
 Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
 intros p q H.
 rewrite rdiv_def in |- *.
@@ -141,7 +141,7 @@ transitivity (/ q * q * p); [  ring | idtac ].
 rewrite rinv_l in |- *; auto.
 Qed.
 Hint Resolve rdiv_simpl .
- 
+
 Theorem SRdiv_ext:
  forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 ->  p1 / q1 == p2 / q2.
 intros p1 p2 H q1 q2 H0.
@@ -195,7 +195,7 @@ Qed.
 Theorem rdiv1: forall r,  r == r / 1.
 intros r; transitivity (1 * (r / 1)); auto.
 Qed.
- 
+
 Theorem rdiv2:
  forall r1 r2 r3 r4,
  ~ r2 == 0 ->
@@ -224,7 +224,7 @@ intros r1 r2 r3 r4 r5 H H0.
 assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
 assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
 assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
-assert (HH4: ~ r2 * (r4 * r5) == 0) 
+assert (HH4: ~ r2 * (r4 * r5) == 0)
    by complete (repeat apply field_is_integral_domain; trivial).
 apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
 rewrite rdiv_simpl in |- *; trivial.
@@ -288,7 +288,7 @@ assert (~ r1 / r2 == 0) as Hk.
    repeat rewrite rinv_l in |- *; auto.
 Qed.
 Hint Resolve rdiv6 .
- 
+
  Theorem rdiv4:
  forall r1 r2 r3 r4,
  ~ r2 == 0 ->
@@ -385,9 +385,9 @@ transitivity (r1 / r2 * (r4 / r4)).
 Qed.
 
 (***************************************************************************
-                                                                          
-                       Some equality test                             
-                                                                          
+
+                       Some equality test
+
   ***************************************************************************)
 
 Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
@@ -397,7 +397,7 @@ Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
   | xI p3, xI p4 => positive_eq p3 p4
   | _, _ => false
  end.
- 
+
 Theorem positive_eq_correct:
  forall p1 p2,  if positive_eq p1 p2 then p1 = p2 else p1 <> p2.
 intros p1; elim p1;
@@ -411,8 +411,8 @@ generalize (rec p4); case (positive_eq p3 p4); auto.
 intros H1; apply f_equal with ( f := xO ); auto.
 intros H1 H2; case H1; injection H2; auto.
 Qed.
- 
-Definition N_eq n1 n2 := 
+
+Definition N_eq n1 n2 :=
   match n1, n2 with
   | N0, N0 => true
   | Npos p1, Npos p2 => positive_eq p1 p2
@@ -438,12 +438,12 @@ Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
   | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false
   | _, _ => false
  end.
- 
-Add Morphism (pow_pos rmul) : pow_morph.
+
+Add Morphism (pow_pos rmul) with signature req ==> eq ==> req as pow_morph.
 intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
 Qed.
 
-Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph.
+Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph.
 intros x y H [|p];simpl;auto. apply pow_morph;trivial.
 Qed.
 (*
@@ -508,10 +508,10 @@ Definition NPEpow x n :=
   | N0 => PEc cI
   | Npos p =>
     if positive_eq p xH then x else
-    match x with 
-    | PEc c => 
-      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)  
-    | _ => PEpow x n         
+    match x with
+    | PEc c =>
+      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)
+    | _ => PEpow x n
     end
   end.
 
@@ -530,7 +530,7 @@ Proof.
  induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
 Qed.
 
-(* mul *) 
+(* mul *)
 Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
   match x, y with
     PEc c1, PEc c2 => PEc (cmul c1 c2)
@@ -546,7 +546,7 @@ Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
 Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
 induction p;simpl;auto;try ring [IHp].
 Qed.
-          
+
 Theorem NPEmul_correct : forall l e1 e2,
   NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
 induction e1;destruct e2; simpl in |- *;try reflexivity;
@@ -581,17 +581,17 @@ destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
  try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
 apply (morph_sub CRmorph).
 Qed.
- 
+
 (* opp *)
 Definition NPEopp e1 :=
   match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
- 
+
 Theorem NPEopp_correct:
  forall l e1,  NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
 intros l e1; case e1; simpl; auto.
 intros; apply (morph_opp CRmorph).
 Qed.
- 
+
 (* simplification *)
 Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
  match e with
@@ -602,7 +602,7 @@ Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
   | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
   | _ => e
  end.
- 
+
 Theorem PExpr_simp_correct:
  forall l e,  NPEeval l (PExpr_simp e) == NPEeval l e.
 intros l e; elim e; simpl; auto.
@@ -630,9 +630,9 @@ Qed.
 
 
 (****************************************************************************
-                                                                          
-                               Datastructure                              
-                                                                          
+
+                               Datastructure
+
   ***************************************************************************)
 
 (* The input: syntax of a field expression *)
@@ -647,7 +647,7 @@ Inductive FExpr : Type :=
  | FEinv: FExpr ->  FExpr
  | FEdiv: FExpr -> FExpr ->  FExpr
  | FEpow: FExpr -> N -> FExpr .
- 
+
 Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
   match pe with
   | FEc c     => phi c
@@ -664,7 +664,7 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
 Strategy expand [FEeval].
 
 (* The result of the normalisation *)
- 
+
 Record linear : Type := mk_linear {
    num : PExpr C;
    denum : PExpr C;
@@ -675,7 +675,7 @@ Record linear : Type := mk_linear {
                 Semantics and properties of side condition
 
   ***************************************************************************)
- 
+
 Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
   match le with
   | nil => True
@@ -689,7 +689,7 @@ intros l a l1 H.
 destruct l1; simpl in H |- *; trivial.
 destruct H; trivial.
 Qed.
- 
+
 Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) ->  PCond l l1.
 intros l a l1 H.
 destruct l1; simpl in H |- *; trivial.
@@ -703,12 +703,12 @@ intros l l1 l2; elim l1; simpl app in |- *.
   destruct l2; firstorder.
   firstorder.
 Qed.
- 
+
 Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l2.
 intros l l1 l2; elim l1; simpl app; auto.
 intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
 Qed.
- 
+
 (* An unsatisfiable condition: issued when a division by zero is detected *)
 Definition absurd_PCond := cons (PEc cO) nil.
 
@@ -720,9 +720,9 @@ apply (morph0 CRmorph).
 Qed.
 
 (***************************************************************************
-                                                                          
-                               Normalisation                              
-                                                                          
+
+                               Normalisation
+
   ***************************************************************************)
 
 Fixpoint isIn (e1:PExpr C)  (p1:positive)
@@ -731,18 +731,18 @@ Fixpoint isIn (e1:PExpr C)  (p1:positive)
   | PEmul e3 e4 =>
        match isIn e1 p1 e3 p2 with
        | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
-       | Some (Npos p, e5) => 
+       | Some (Npos p, e5) =>
           match isIn e1 p e4 p2 with
           | Some (n, e6) => Some (n, NPEmul e5 e6)
           | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
           end
-       | None => 
+       | None =>
          match isIn e1 p1 e4 p2 with
          | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
          | None => None
          end
        end
-  | PEpow e3 N0 => None 
+  | PEpow e3 N0 => None
   | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2)
   | _ =>
      if  PExpr_eq e1 e2 then
@@ -751,27 +751,27 @@ Fixpoint isIn (e1:PExpr C)  (p1:positive)
           | Z0 => Some (N0, PEc cI)
           | Zneg p => Some (N0, NPEpow e2 (Npos p))
           end
-     else None 
+     else None
    end.
- 
+
  Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
  Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
 
- Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) 
+ Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext)
                         ARth.(ARmul_comm) ARth.(ARmul_assoc)).
 
- Lemma isIn_correct_aux : forall l e1 e2 p1 p2, 
-  match 
+ Lemma isIn_correct_aux : forall l e1 e2 p1 p2,
+  match
       (if  PExpr_eq e1 e2 then
          match Zminus (Zpos p1) (Zpos p2) with
           | Zpos p => Some (Npos p, PEc cI)
           | Z0 => Some (N0, PEc cI)
           | Zneg p => Some (N0, NPEpow e2 (Npos p))
           end
-     else None) 
+     else None)
    with
-   | Some(n, e3) => 
-       NPEeval l (PEpow e2 (Npos p2)) == 
+   | Some(n, e3) =>
+       NPEeval l (PEpow e2 (Npos p2)) ==
        NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
        (Zpos p1 > NtoZ n)%Z
    |  _ => True
@@ -779,15 +779,15 @@ Fixpoint isIn (e1:PExpr C)  (p1:positive)
 Proof.
   intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
    case (PExpr_eq e1 e2); simpl; auto; intros H.
-  case_eq ((p1 ?= p2)%positive Eq);intros;simpl. 
+  case_eq ((p1 ?= p2)%positive Eq);intros;simpl.
   repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _).
-  rewrite (Pcompare_Eq_eq _ _ H0).  
+  rewrite (Pcompare_Eq_eq _ _ H0).
   rewrite H by trivial. ring [ (morph1 CRmorph)].
   fold (NPEpow e2 (Npos (p2 - p1))).
   rewrite NPEpow_correct;simpl.
   repeat rewrite pow_th.(rpow_pow_N);simpl.
   rewrite H;trivial. split. 2:refine (refl_equal _).
-  rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. 
+  rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial.
   repeat rewrite pow_th.(rpow_pow_N);simpl.
   rewrite H;trivial.
    change (ZtoN
@@ -801,7 +801,7 @@ Proof.
   repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth).
   rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl.
   ring [ (morph1 CRmorph)].
- assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). 
+ assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _).
  apply Zplus_gt_reg_l with (Zpos p2).
  rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z.
  apply Zplus_gt_compat_r. refine (refl_equal _).
@@ -815,9 +815,9 @@ Qed.
 
 
 Theorem isIn_correct: forall l e1 p1 e2 p2,
-  match isIn e1 p1 e2 p2 with 
-   | Some(n, e3) => 
-       NPEeval l (PEpow e2 (Npos p2)) == 
+  match isIn e1 p1 e2 p2 with
+   | Some(n, e3) =>
+       NPEeval l (PEpow e2 (Npos p2)) ==
        NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
         (Zpos p1 > NtoZ n)%Z
    |  _ => True
@@ -827,7 +827,7 @@ Opaque NPEpow.
 intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
   try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
 generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
-destruct n. 
+destruct n.
   simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
   repeat rewrite pow_th.(rpow_pow_N);simpl.
   rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
@@ -838,12 +838,12 @@ destruct n.
     unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
     rewrite pow_pos_mul. rewrite H1;rewrite H3.
     assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == 
+        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) ==
         pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
         NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
    rewrite <- pow_pos_plus. rewrite Pplus_minus.
    split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
-   repeat rewrite pow_th.(rpow_pow_N);simpl. 
+   repeat rewrite pow_th.(rpow_pow_N);simpl.
    intros (H1,H2) (H3,H4).
    unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
    rewrite H2 in H1;simpl in H1.
@@ -857,16 +857,16 @@ destruct n.
              pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
                 NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
   rewrite <- pow_pos_plus.
-  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. 
+  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive.
  rewrite NPEmul_correct. simpl;ring.
-  assert 
+  assert
      (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
  change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
  rewrite <- Zplus_assoc. rewrite (Zplus_assoc  (- Zpos p4)).
  simpl. rewrite Pcompare_refl. simpl. reflexivity.
  unfold Zminus, Zopp in H0. simpl in H0.
   rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial.
- simpl. repeat rewrite pow_th.(rpow_pow_N). 
+ simpl. repeat rewrite pow_th.(rpow_pow_N).
  intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3.
  rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
  simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
@@ -879,8 +879,8 @@ destruct n.
  repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
  intros (H1, H2);rewrite H1;split.
    unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1.
-   simpl in H1;ring [H1]. trivial. 
- trivial. 
+   simpl in H1;ring [H1]. trivial.
+ trivial.
  destruct n. trivial.
  generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
  destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
@@ -910,18 +910,18 @@ Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :
                     (NPEmul (common r1) (common r2))
                     (right r2)
   | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
-  | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2      
-  | _ => 
+  | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2
+  | _ =>
        match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
+       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
        | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
        | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
        end
-  end. 
+  end.
 
 Lemma split_aux_correct_1 : forall l e1 p e2,
   let res :=  match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
+       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
        | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
        | None => mk_rsplit (NPEpow e1  (Npos p)) (PEc cI) e2
        end in
@@ -932,7 +932,7 @@ Proof.
  intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
  destruct (isIn e1 p e2 1). destruct p0.
  Opaque NPEpow NPEmul.
-  destruct n;simpl; 
+  destruct n;simpl;
     (repeat rewrite NPEmul_correct;simpl;
      repeat rewrite NPEpow_correct;simpl;
      repeat rewrite pow_th.(rpow_pow_N);simpl).
@@ -945,7 +945,7 @@ Proof.
 Qed.
 
 Theorem split_aux_correct: forall l e1 p e2,
-  NPEeval l (PEpow e1 (Npos p)) == 
+  NPEeval l (PEpow e1 (Npos p)) ==
        NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
 /\
   NPEeval l  e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
@@ -953,9 +953,9 @@ Theorem split_aux_correct: forall l e1 p e2,
 Proof.
 intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
 generalize (IHe1_1 k e2); clear IHe1_1.
-generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. 
+generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2.
 simpl. repeat (rewrite NPEmul_correct;simpl).
-repeat rewrite pow_th.(rpow_pow_N);simpl. 
+repeat rewrite pow_th.(rpow_pow_N);simpl.
 intros (H1,H2) (H3,H4);split.
 rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
 rewrite H4;rewrite H2;ring.
@@ -971,7 +971,7 @@ rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
 Qed.
 
 Definition split e1 e2 := split_aux e1 xH e2.
- 
+
 Theorem split_correct_l: forall l e1 e2,
   NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
                                    (common (split e1 e2))).
@@ -987,7 +987,7 @@ Proof.
 intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
 Qed.
 
-Fixpoint Fnorm (e : FExpr) : linear := 
+Fixpoint Fnorm (e : FExpr) : linear :=
   match e with
   | FEc c => mk_linear (PEc c) (PEc cI) nil
   | FEX x => mk_linear (PEX C x) (PEc cI) nil
@@ -999,7 +999,7 @@ Fixpoint Fnorm (e : FExpr) : linear :=
         (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
         (NPEmul (left s) (NPEmul (right s) (common s)))
         (condition x ++ condition y)
- 
+
   | FEsub e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
@@ -1050,13 +1050,13 @@ Proof.
  induction p;simpl.
   intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
   apply IHp.
-  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp). 
+  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
   reflexivity.
-  rewrite H1. ring. rewrite Hp;ring. 
+  rewrite H1. ring. rewrite Hp;ring.
   intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
   reflexivity. rewrite Hp;ring. trivial.
 Qed.
- 
+
 Theorem Pcond_Fnorm:
  forall l e,
  PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
@@ -1135,9 +1135,9 @@ Hint Resolve Pcond_Fnorm.
 
 
 (***************************************************************************
-                                                                          
-                       Main theorem                                       
-                                                                          
+
+                       Main theorem
+
   ***************************************************************************)
 
 Theorem Fnorm_FEeval_PEeval:
@@ -1242,8 +1242,8 @@ apply pow_pos_not_0;trivial.
 apply pow_pos_not_0;trivial.
 intro Hp. apply (pow_pos_not_0 Hdiff  p).
 rewrite  (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p)  0).
- reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. 
-rewrite <- rdiv4;trivial. 
+ reflexivity. apply pow_pos_not_0;trivial. ring [Hp].
+rewrite <- rdiv4;trivial.
 rewrite IHp;reflexivity.
 apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
 reflexivity.
@@ -1352,11 +1352,11 @@ Theorem Field_simplify_eq_old_correct :
 Proof.
 intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
 apply Fnorm_crossproduct; trivial.
-match goal with 
+match goal with
  [ |- NPEeval l ?x == NPEeval l ?y] =>
     rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
        O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x)));
-    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec 
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
        O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
  end.
 trivial.
@@ -1368,7 +1368,7 @@ Theorem Field_simplify_eq_correct :
  forall lmp, Nmk_monpol_list lpe = lmp ->
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall den, split (denum nfe1) (denum nfe2) = den ->
  NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
  NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
  PCond l (condition nfe1 ++ condition nfe2) ->
@@ -1387,14 +1387,14 @@ repeat rewrite (ARmul_assoc ARth) in |- *.
 rewrite <-(
   let x := PEmul (num (Fnorm fe1))
                      (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l 
+ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
         Hlpe (refl_equal (Nmk_monpol_list lpe))
         x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
 rewrite <-(
   let x := (PEmul (num (Fnorm fe2))
                      (rsplit_left
                         (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
-    ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l 
+    ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
         Hlpe (refl_equal (Nmk_monpol_list lpe))
         x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
 simpl in Hcrossprod.
@@ -1408,7 +1408,7 @@ Theorem Field_simplify_eq_pow_correct :
  forall lmp, Nmk_monpol_list lpe = lmp ->
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall den, split (denum nfe1) (denum nfe2) = den ->
  NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
  NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
  PCond l (condition nfe1 ++ condition nfe2) ->
@@ -1427,14 +1427,14 @@ repeat rewrite (ARmul_assoc ARth) in |- *.
 rewrite <-(
   let x := PEmul (num (Fnorm fe1))
                      (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l 
+ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
         Hlpe (refl_equal (Nmk_monpol_list lpe))
         x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
 rewrite <-(
   let x := (PEmul (num (Fnorm fe2))
                      (rsplit_left
                         (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
-    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l 
+    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
         Hlpe (refl_equal (Nmk_monpol_list lpe))
         x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
 simpl in Hcrossprod.
@@ -1448,7 +1448,7 @@ Theorem Field_simplify_eq_pow_in_correct :
  forall lmp, Nmk_monpol_list lpe = lmp ->
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall den, split (denum nfe1) (denum nfe2) = den ->
  forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
  forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
  FEeval l fe1 == FEeval l fe2 ->
@@ -1461,7 +1461,7 @@ Proof.
  repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
  assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
  assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
  intro Heq;apply N1.
  rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
  rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
@@ -1498,7 +1498,7 @@ forall n l lpe fe1 fe2,
  forall lmp, Nmk_monpol_list lpe = lmp ->
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall den, split (denum nfe1) (denum nfe2) = den ->
  forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
  forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
  FEeval l fe1 == FEeval l fe2 ->
@@ -1511,7 +1511,7 @@ Proof.
  repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
  assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
  assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
  intro Heq;apply N1.
  rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
  rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
@@ -1539,7 +1539,7 @@ Proof.
  rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
  repeat rewrite <- (AFth.(AFdiv_def)).
  repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
- apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). 
+ apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
 Qed.
 
 
@@ -1576,7 +1576,7 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
    nil       => cons e nil
  | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1)
  end.
- 
+
 Theorem PFcons_fcons_inv:
  forall l a l1, PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
 intros l a l1; elim l1; simpl Fcons; auto.
@@ -1600,9 +1600,10 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
  match l with
    nil       => cons e nil
  | cons a l1 =>
-     if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1)
+     if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l
+     else cons a (Fcons0 e l1)
  end.
- 
+
 Theorem PFcons0_fcons_inv:
  forall l a l1, PCond l (Fcons0 a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
 intros l a l1; elim l1; simpl Fcons0; auto.
@@ -1619,10 +1620,11 @@ split.
 generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
 apply H0.
 generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-clear get_sign get_sign_spec. 
+clear get_sign get_sign_spec.
 generalize Hp; case l0; simpl; intuition.
 Qed.
 
+(* split factorized denominators *)
 Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
  match e with
    PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l)
@@ -1645,7 +1647,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
    apply pow_pos_not_0;trivial.
 Qed.
 
-Definition Pcond_simpl_gen := 
+Definition Pcond_simpl_gen :=
   fcons_correct _ PFcons00_fcons_inv.
 
 
@@ -1672,7 +1674,7 @@ Qed.
 Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
  match e with
    PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
- | PEpow e _ => Fcons1 e l 
+ | PEpow e _ => Fcons1 e l
  | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
  | PEc c => if ceqb c cO then absurd_PCond else l
  | _ => Fcons0 e l
@@ -1708,7 +1710,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
 Qed.
 
 Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
- 
+
 Theorem PFcons2_fcons_inv:
  forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
 unfold Fcons2 in |- *; intros l a l1 H; split;
@@ -1718,7 +1720,7 @@ transitivity (NPEeval l a); trivial.
 apply PExpr_simp_correct.
 Qed.
 
-Definition Pcond_simpl_complete := 
+Definition Pcond_simpl_complete :=
   fcons_correct _ PFcons2_fcons_inv.
 
 End Fcons_simpl.
@@ -1749,7 +1751,7 @@ End FieldAndSemiField.
 
 End MakeFieldPol.
 
-  Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth 
+  Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth
     (sf:semi_field_theory rO rI radd rmul rdiv rinv req)  :=
     mk_afield _ _
       (SRth_ARth Rsth sf.(SF_SR))
diff --git a/contrib/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index e664b3b7..b5384f80 100644
--- a/contrib/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -27,7 +27,7 @@ Definition NotConstant := false.
 
 Lemma Zsth : Setoid_Theory Z (@eq Z).
 Proof (Eqsth Z).
- 
+
 Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z).
 Proof (Eq_ext Zplus Zmult Zopp).
 
@@ -65,7 +65,7 @@ Section ZMORPHISM.
 
  Fixpoint gen_phiPOS (p:positive) : R :=
   match p with
-  | xH => 1 
+  | xH => 1
   | xO xH => (1 + 1)
   | xO p => (1 + 1) * (gen_phiPOS p)
   | xI xH => 1 + (1 +1)
@@ -78,18 +78,18 @@ Section ZMORPHISM.
   | Z0 => 0
   | Zneg p => -(gen_phiPOS1 p)
   end.
- 
- Definition gen_phiZ z := 
+
+ Definition gen_phiZ z :=
   match z with
   | Zpos p => gen_phiPOS p
   | Z0 => 0
   | Zneg p => -(gen_phiPOS p)
   end.
- Notation "[ x ]" := (gen_phiZ x).   
+ Notation "[ x ]" := (gen_phiZ x).
 
  Definition get_signZ z :=
   match z with
-  | Zneg p => Some (Zpos p) 
+  | Zneg p => Some (Zpos p)
   | _ => None
   end.
 
@@ -101,16 +101,16 @@ Section ZMORPHISM.
   simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial.
  Qed.
 
- 
+
  Section ALMOST_RING.
  Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
    Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed.
    Ltac norm := gen_srewrite Rsth Reqe ARth.
    Ltac add_push := gen_add_push radd Rsth Reqe ARth.
- 
+
  Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
  Proof.
-  induction x;simpl. 
+  induction x;simpl.
   rewrite IHx;destruct x;simpl;norm.
   rewrite IHx;destruct x;simpl;norm.
   rrefl.
@@ -155,28 +155,28 @@ Section ZMORPHISM.
    Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed.
    Ltac norm := gen_srewrite Rsth Reqe ARth.
    Ltac add_push := gen_add_push radd Rsth Reqe ARth.
-  
+
 (*morphisms are extensionaly equal*)
  Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
  Proof.
   destruct x;simpl; try rewrite (same_gen ARth);rrefl.
  Qed.
- 
- Lemma gen_Zeqb_ok : forall x y, 
+
+ Lemma gen_Zeqb_ok : forall x y,
    Zeq_bool x y = true -> [x] == [y].
  Proof.
   intros x y H.
   assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1.
   rewrite H1;rrefl.
  Qed.
-  
+
  Lemma gen_phiZ1_add_pos_neg : forall x y,
  gen_phiZ1
     match (x ?= y)%positive Eq with
     | Eq => Z0
     | Lt => Zneg (y - x)
     | Gt => Zpos (x - y)
-    end 
+    end
  == gen_phiPOS1 x + -gen_phiPOS1 y.
  Proof.
   intros x y.
@@ -197,7 +197,7 @@ Section ZMORPHISM.
  Qed.
 
  Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
-  match CompOpp x with Eq => be | Lt => bl | Gt => bg end 
+  match CompOpp x with Eq => be | Lt => bl | Gt => bg end
   = match x with Eq => be | Lt => bg | Gt => bl end.
  Proof. destruct x;simpl;intros;trivial. Qed.
 
@@ -209,7 +209,7 @@ Section ZMORPHISM.
   apply gen_phiZ1_add_pos_neg.
   replace Eq with (CompOpp Eq);trivial.
   rewrite <- Pcompare_antisym;simpl.
-  rewrite match_compOpp.    
+  rewrite match_compOpp.
   rewrite (Radd_comm Rth).
   apply gen_phiZ1_add_pos_neg.
   rewrite (ARgen_phiPOS_add ARth); norm.
@@ -227,11 +227,11 @@ Section ZMORPHISM.
  Proof. intros;subst;rrefl. Qed.
 
 (*proof that [.] satisfies morphism specifications*)
- Lemma gen_phiZ_morph : 
-  ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) 
+ Lemma gen_phiZ_morph :
+  ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH)
    Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ.
- Proof. 
-  assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) 
+ Proof.
+  assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH)
                   Zplus Zmult Zeq_bool gen_phiZ).
    apply mkRmorph;simpl;try rrefl.
    apply gen_phiZ_add.  apply gen_phiZ_mul. apply gen_Zeqb_ok.
@@ -251,7 +251,7 @@ Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N).
 Proof.
  constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc.
  exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc.
- exact Nmult_plus_distr_r. 
+ exact Nmult_plus_distr_r.
 Qed.
 
 Definition Nsub := SRsub Nplus.
@@ -260,11 +260,11 @@ Definition Nopp := (@SRopp N).
 Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N).
 Proof (SReqe_Reqe Nseqe).
 
-Lemma Nath : 
+Lemma Nath :
  almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N).
 Proof (SRth_ARth Nsth Nth).
- 
-Definition Neq_bool (x y:N) := 
+
+Definition Neq_bool (x y:N) :=
   match Ncompare x y with
   | Eq => true
   | _ => false
@@ -273,17 +273,17 @@ Definition Neq_bool (x y:N) :=
 Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y.
  Proof.
   intros x y;unfold Neq_bool.
-  assert (H:=Ncompare_Eq_eq x y); 
+  assert (H:=Ncompare_Eq_eq x y);
    destruct (Ncompare x y);intros;try discriminate.
-  rewrite H;trivial. 
+  rewrite H;trivial.
  Qed.
 
 Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y.
  Proof.
   intros x y;unfold Neq_bool.
-  assert (H:=Ncompare_Eq_eq x y); 
+  assert (H:=Ncompare_Eq_eq x y);
    destruct (Ncompare x y);intros;try discriminate.
-  rewrite H;trivial. 
+  rewrite H;trivial.
  Qed.
 
 (**Same as above : definition of two,extensionaly equal, generic morphisms *)
@@ -298,7 +298,7 @@ Section NMORPHISM.
      Add Setoid R req Rsth as R_setoid4.
      Ltac rrefl := gen_reflexivity Rsth.
  Variable SReqe : sring_eq_ext radd rmul req.
- Variable SRth : semi_ring_theory 0 1 radd rmul req. 
+ Variable SRth : semi_ring_theory 0 1 radd rmul req.
  Let ARth := SRth_ARth Rsth SRth.
  Let Reqe := SReqe_Reqe SReqe.
  Let ropp := (@SRopp R).
@@ -315,15 +315,15 @@ Section NMORPHISM.
   match x with
   | N0 => 0
   | Npos x => gen_phiPOS1 1 radd rmul x
-  end. 
+  end.
 
  Definition gen_phiN x :=
   match x with
   | N0 => 0
   | Npos x => gen_phiPOS 1 radd rmul x
-  end. 
- Notation "[ x ]" := (gen_phiN x).   
-  
+  end.
+ Notation "[ x ]" := (gen_phiN x).
+
  Lemma same_genN : forall x, [x] == gen_phiN1 x.
  Proof.
   destruct x;simpl. rrefl.
@@ -336,7 +336,7 @@ Section NMORPHISM.
   destruct x;destruct y;simpl;norm.
   apply (ARgen_phiPOS_add Rsth Reqe ARth).
  Qed.
- 
+
  Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y].
  Proof.
   intros x y;repeat rewrite same_genN.
@@ -397,7 +397,7 @@ Fixpoint Nw_is0 (w : Nword) : bool :=
   | nil => true
   | 0%N :: w' => Nw_is0 w'
   | _ => false
-  end. 
+  end.
 
 Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool :=
   match w1, w2 with
@@ -559,7 +559,7 @@ induction x; intros.
 Qed.
 
 (* Proof that [.] satisfies morphism specifications *)
- Lemma gen_phiNword_morph : 
+ Lemma gen_phiNword_morph :
   ring_morph 0 1 radd rmul rsub ropp req
    NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword.
 constructor.
@@ -585,7 +585,7 @@ Qed.
 End NWORDMORPHISM.
 
 Section GEN_DIV.
-  
+
   Variables  (R : Type) (rO : R) (rI : R) (radd : R -> R -> R)
               (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R)
               (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C)
@@ -595,8 +595,8 @@ Section GEN_DIV.
  Variable Reqe : ring_eq_ext radd rmul ropp req.
  Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
  Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi.
- 
-  (* Useful tactics *)		  
+
+  (* Useful tactics *)
   Add Setoid R req Rsth as R_set1.
  Ltac rrefl := gen_reflexivity Rsth.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
@@ -605,7 +605,7 @@ Section GEN_DIV.
   Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
  Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
 
- Definition triv_div x y :=  
+ Definition triv_div x y :=
    if ceqb x y then (cI, cO)
    else (cO, x).
 
@@ -715,7 +715,7 @@ End GEN_DIV.
 (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above
    are only optimisations that directly returns the reifid constant
    instead of resorting to the constant propagation of the simplification
-   algorithm. *) 
+   algorithm. *)
 Ltac inv_gen_phi rO rI cO cI t :=
   match t with
   | rO => cO
@@ -769,10 +769,10 @@ Ltac gen_ring_sign morph sspec :=
   match sspec with
   | None =>
     match type of morph with
-    | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req  
+    | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi =>
        constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th)
-    | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req  
+    | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                ?C  ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi =>
         constr:(mkhypo (@get_sign_None_th C copp ceqb))
     | _ => fail 2 "ring anomaly : default_sign_spec"
@@ -782,24 +782,24 @@ Ltac gen_ring_sign morph sspec :=
 
 Ltac default_div_spec set reqe arth morph :=
  match type of morph with
- | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi =>
       constr:(mkhypo (Ztriv_div_th set phi))
- | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi =>
-      constr:(mkhypo (Ntriv_div_th set phi)) 
- | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+      constr:(mkhypo (Ntriv_div_th set phi))
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
       constr:(mkhypo (triv_div_th set reqe arth morph))
- | _ => fail 1 "ring anomaly : default_sign_spec" 
+ | _ => fail 1 "ring anomaly : default_sign_spec"
  end.
 
 Ltac gen_ring_div set reqe arth morph dspec  :=
  match dspec with
- | None => default_div_spec set reqe arth morph   
+ | None => default_div_spec set reqe arth morph
  | Some ?t => constr:(t)
  end.
- 
+
 Ltac ring_elements set ext rspec pspec sspec dspec rk :=
   let arth := coerce_to_almost_ring set ext rspec in
   let ext_r := coerce_to_ring_ext ext in
@@ -813,10 +813,10 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
         | _ => fail 2 "ring anomaly"
         end
     | @Morphism ?m =>
-       match type of m with 
-       | ring_morph _ _ _ _ _ _ _  _ _ _ _ _ _  _ _ => m 
-       | @semi_morph _ _ _ _ _ _  _ _ _ _ _  _ _   => 
-           constr:(SRmorph_Rmorph set m) 
+       match type of m with
+       | ring_morph _ _ _ _ _ _ _  _ _ _ _ _ _  _ _ => m
+       | @semi_morph _ _ _ _ _ _  _ _ _ _ _  _ _   =>
+           constr:(SRmorph_Rmorph set m)
        | _ => fail 2 "ring anomaly"
        end
     | _ => fail 1 "ill-formed ring kind"
@@ -832,27 +832,27 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
  Ltac ring_lemmas set ext rspec pspec sspec dspec rk :=
   let gen_lemma2 :=
     match pspec with
-    | None => constr:(ring_rw_correct) 
+    | None => constr:(ring_rw_correct)
     | Some _ => constr:(ring_rw_pow_correct)
     end in
   ring_elements set ext rspec pspec sspec dspec rk
     ltac:(fun arth ext_r morph p_spec s_spec d_spec =>
        match type of morph with
-       | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+       | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
-          let gen_lemma2_0 := 
-              constr:(gen_lemma2 R  r0 rI  radd rmul rsub ropp req set ext_r arth 
+          let gen_lemma2_0 :=
+              constr:(gen_lemma2 R  r0 rI  radd rmul rsub ropp req set ext_r arth
                                 C  c0 c1 cadd cmul csub copp ceq_b phi morph) in
           match p_spec with
-          | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec =>      
+          | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec =>
              let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in
              match d_spec with
              | @mkhypo (div_theory _ _ _ _  ?cdiv) ?dd_spec =>
                 let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in
                 match s_spec with
-                | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec =>    
-                  let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in 
-                  let lemma1 := 
+                | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec =>
+                  let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in
+                  let lemma1 :=
                     constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in
                   fun f => f arth ext_r morph lemma1 lemma2
                 | _ => fail 4 "ring: bad sign specification"
@@ -878,7 +878,7 @@ Ltac isPcst t :=
   | xO ?p => isPcst p
   | xH => constr:true
   (* nat -> positive *)
-  | P_of_succ_nat ?n => isnatcst n 
+  | P_of_succ_nat ?n => isnatcst n
   | _ => constr:false
   end.
 
diff --git a/contrib/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index 0ba519fd..0ba519fd 100644
--- a/contrib/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
diff --git a/contrib/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v
index 60641bcf..56473adb 100644
--- a/contrib/setoid_ring/RealField.v
+++ b/plugins/setoid_ring/RealField.v
@@ -1,5 +1,5 @@
 Require Import Nnat.
-Require Import ArithRing. 
+Require Import ArithRing.
 Require Export Ring Field.
 Require Import Rdefinitions.
 Require Import Rpow_def.
@@ -99,7 +99,7 @@ rewrite H in |- *; intro.
 apply (Rlt_asym 0 0); trivial.
 Qed.
 
-Lemma Zeq_bool_complete : forall x y, 
+Lemma Zeq_bool_complete : forall x y,
   InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x =
   InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y ->
   Zeq_bool x y = true.
@@ -114,21 +114,21 @@ Qed.
 Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R))  nat_of_N pow.
 Proof.
  constructor. destruct n. reflexivity.
- simpl. induction p;simpl. 
+ simpl. induction p;simpl.
  rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity.
  unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial.
  rewrite Rmult_comm;apply Rmult_1_l.
 Qed.
 
-Ltac Rpow_tac t := 
+Ltac Rpow_tac t :=
   match isnatcst t with
   | false => constr:(InitialRing.NotConstant)
   | _ => constr:(N_of_nat t)
-  end. 
+  end.
 
-Add Field RField : Rfield  
+Add Field RField : Rfield
    (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
 
 
 
- 
+
diff --git a/contrib/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index d01b1625..d01b1625 100644
--- a/contrib/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
diff --git a/contrib/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index 956a15fe..fd9dd8d0 100644
--- a/contrib/setoid_ring/Ring_base.v
+++ b/plugins/setoid_ring/Ring_base.v
@@ -10,6 +10,8 @@
    ring tactic. Abstract rings need more theory, depending on
    ZArith_base. *)
 
+Require Import Quote.
+Declare ML Module "newring_plugin".
 Require Export Ring_theory.
 Require Export Ring_tac.
 Require Import InitialRing.
diff --git a/contrib/setoid_ring/Ring_equiv.v b/plugins/setoid_ring/Ring_equiv.v
index 945f6c68..945f6c68 100644
--- a/contrib/setoid_ring/Ring_equiv.v
+++ b/plugins/setoid_ring/Ring_equiv.v
diff --git a/contrib/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index d8847036..faa83ded 100644
--- a/contrib/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -18,21 +18,21 @@ Open Local Scope positive_scope.
 Import RingSyntax.
 
 Section MakeRingPol.
- 
- (* Ring elements *)     
+
+ (* Ring elements *)
  Variable R:Type.
  Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
  Variable req : R -> R -> Prop.
- 
+
  (* Ring properties *)
  Variable Rsth : Setoid_Theory R req.
  Variable Reqe : ring_eq_ext radd rmul ropp req.
  Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
 
- (* Coefficients *) 
+ (* Coefficients *)
  Variable C: Type.
  Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool. 
+ Variable ceqb : C->C->bool.
  Variable phi : C -> R.
  Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
                                 cO cI cadd cmul csub copp ceqb phi.
@@ -40,7 +40,7 @@ Section MakeRingPol.
   (* Power coefficients *)
  Variable Cpow : Set.
  Variable Cp_phi : N -> Cpow.
- Variable rpow : R -> Cpow -> R. 
+ Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
 
  (* division is ok *)
@@ -54,12 +54,12 @@ Section MakeRingPol.
  Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
  Notation "x == y" := (req x y).
 
- (* C notations *)		 
+ (* C notations *)
  Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
  Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
  Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
 
- (* Useful tactics *)		  
+ (* Useful tactics *)
   Add Setoid R req Rsth as R_set1.
  Ltac rrefl := gen_reflexivity Rsth.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
@@ -93,20 +93,20 @@ Section MakeRingPol.
  *)
 
  Inductive Pol : Type :=
-  | Pc : C -> Pol 
-  | Pinj : positive -> Pol -> Pol                   
+  | Pc : C -> Pol
+  | Pinj : positive -> Pol -> Pol
   | PX : Pol -> positive -> Pol -> Pol.
 
  Definition P0 := Pc cO.
  Definition P1 := Pc cI.
- 
- Fixpoint Peq (P P' : Pol) {struct P'} : bool := 
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
   match P, P' with
   | Pc c, Pc c' => c ?=! c'
-  | Pinj j Q, Pinj j' Q' => 
+  | Pinj j Q, Pinj j' Q' =>
     match Pcompare j j' Eq with
-    | Eq => Peq Q Q' 
-    | _ => false 
+    | Eq => Peq Q Q'
+    | _ => false
     end
   | PX P i Q, PX P' i' Q' =>
     match Pcompare i i' Eq with
@@ -119,7 +119,7 @@ Section MakeRingPol.
  Notation " P ?== P' " := (Peq P P').
 
  Definition mkPinj j P :=
-  match P with 
+  match P with
   | Pc _ => P
   | Pinj j' Q => Pinj ((j + j'):positive) Q
   | _ => Pinj j P
@@ -132,7 +132,7 @@ Section MakeRingPol.
   | xI j => Pinj (xO j) P
   end.
 
- Definition mkPX P i Q := 
+ Definition mkPX P i Q :=
   match P with
   | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
   | Pinj _ _ => PX P i Q
@@ -142,20 +142,20 @@ Section MakeRingPol.
  Definition mkXi i := PX P1 i P0.
 
  Definition mkX := mkXi 1.
- 
+
  (** Opposite of addition *)
- 
- Fixpoint Popp (P:Pol) : Pol := 
+
+ Fixpoint Popp (P:Pol) : Pol :=
   match P with
   | Pc c => Pc (-! c)
   | Pinj j Q => Pinj j (Popp Q)
   | PX P i Q => PX (Popp P) i (Popp Q)
   end.
- 
+
  Notation "-- P" := (Popp P).
 
  (** Addition et subtraction *)
- 
+
  Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
   match P with
   | Pc c1 => Pc (c1 +! c)
@@ -178,39 +178,39 @@ Section MakeRingPol.
   Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
    match P with
    | Pc c => mkPinj j (PaddC Q c)
-   | Pinj j' Q' => 
+   | Pinj j' Q' =>
      match ZPminus j' j with
      | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
      | Z0 => mkPinj j (Pop Q' Q)
      | Zneg k => mkPinj j' (PaddI k Q')
      end
-   | PX P i Q' => 
+   | PX P i Q' =>
      match j with
      | xH => PX P i (Pop Q' Q)
      | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
      | xI j => PX P i (PaddI (xO j) Q')
-     end 
+     end
    end.
 
   Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
    match P with
    | Pc c => mkPinj j (PaddC (--Q) c)
-   | Pinj j' Q' => 
+   | Pinj j' Q' =>
      match ZPminus j' j with
      | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
      | Z0 => mkPinj j (Pop Q' Q)
      | Zneg k => mkPinj j' (PsubI k Q')
      end
-   | PX P i Q' => 
+   | PX P i Q' =>
      match j with
      | xH => PX P i (Pop Q' Q)
      | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
      | xI j => PX P i (PsubI (xO j) Q')
-     end 
+     end
    end.
- 
+
  Variable P' : Pol.
- 
+
  Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
   match P with
   | Pc c => PX P' i' P
@@ -245,7 +245,7 @@ Section MakeRingPol.
     end
   end.
 
-    
+
  End PopI.
 
  Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
@@ -255,12 +255,12 @@ Section MakeRingPol.
   | PX P' i' Q' =>
     match P with
     | Pc c => PX P' i' (PaddC Q' c)
-    | Pinj j Q =>  
+    | Pinj j Q =>
       match j with
       | xH => PX P' i' (Padd Q Q')
       | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
       | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
-      end 
+      end
     | PX P i Q =>
       match ZPminus i i' with
       | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
@@ -278,12 +278,12 @@ Section MakeRingPol.
   | PX P' i' Q' =>
     match P with
     | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
-    | Pinj j Q =>  
+    | Pinj j Q =>
       match j with
       | xH => PX (--P') i' (Psub Q Q')
       | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
       | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
-      end 
+      end
     | PX P i Q =>
       match ZPminus i i' with
       | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
@@ -293,8 +293,8 @@ Section MakeRingPol.
     end
   end.
  Notation "P -- P'" := (Psub P P').
- 
- (** Multiplication *) 
+
+ (** Multiplication *)
 
  Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
   match P with
@@ -306,14 +306,14 @@ Section MakeRingPol.
  Definition PmulC P c :=
   if c ?=! cO then P0 else
   if c ?=! cI then P else PmulC_aux P c.
- 
- Section PmulI. 
+
+ Section PmulI.
   Variable Pmul : Pol -> Pol -> Pol.
   Variable Q : Pol.
   Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
    match P with
    | Pc c => mkPinj j (PmulC Q c)
-   | Pinj j' Q' => 
+   | Pinj j' Q' =>
      match ZPminus j' j with
      | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
      | Z0 => mkPinj j (Pmul Q' Q)
@@ -326,7 +326,7 @@ Section MakeRingPol.
      | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
      end
    end.
- 
+
  End PmulI.
 (* A symmetric version of the multiplication *)
 
@@ -338,10 +338,10 @@ Section MakeRingPol.
      match P with
      | Pc c => PmulC P'' c
      | Pinj j Q =>
-       let QQ' := 
+       let QQ' :=
          match j with
          | xH => Pmul Q Q'
-         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' 
+         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
          | xI j => Pmul (Pinj (xO j) Q) Q'
          end in
        mkPX (Pmul P P') i' QQ'
@@ -352,15 +352,15 @@ Section MakeRingPol.
        let PP' := Pmul P P' in
        (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
      end
-  end.    
+  end.
 
 (* Non symmetric *)
-(*       
+(*
  Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
   match P' with
   | Pc c' => PmulC P c'
   | Pinj j' Q' => PmulI Pmul_aux Q' j' P
-  | PX P' i' Q' => 
+  | PX P' i' Q' =>
      (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
   end.
 
@@ -368,7 +368,7 @@ Section MakeRingPol.
   match P with
   | Pc c => PmulC P' c
   | Pinj j Q => PmulI Pmul_aux Q j P'
-  | PX P i Q => 
+  | PX P i Q =>
     (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
   end.
 *)
@@ -378,7 +378,7 @@ Section MakeRingPol.
    match P with
    | Pc c => Pc (c *! c)
    | Pinj j Q => Pinj j (Psquare Q)
-   | PX P i Q => 
+   | PX P i Q =>
      let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
      let Q2 := Psquare Q in
      let P2 := Psquare P in
@@ -386,10 +386,10 @@ Section MakeRingPol.
    end.
 
  (** Monomial **)
-     
+
   Inductive Mon: Set :=
-    mon0: Mon 
-  | zmon: positive -> Mon -> Mon 
+    mon0: Mon
+  | zmon: positive -> Mon -> Mon
   | vmon: positive -> Mon -> Mon.
 
  Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R :=
@@ -399,7 +399,7 @@ Section MakeRingPol.
   | vmon i M1 =>
      let x := hd 0 l in
      let xi := pow_pos rmul x i in
-    (Mphi (tail l) M1) * xi 
+    (Mphi (tail l) M1) * xi
   end.
 
  Definition mkZmon j M :=
@@ -409,8 +409,8 @@ Section MakeRingPol.
    match j with xH => M | _ => mkZmon (Ppred j) M end.
 
  Definition mkVmon i M :=
-   match M with 
-   | mon0 => vmon i mon0 
+   match M with
+   | mon0 => vmon i mon0
    | zmon j m => vmon i (zmon_pred j m)
    | vmon i' m => vmon (i+i') m
    end.
@@ -462,35 +462,35 @@ Section MakeRingPol.
   Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol :=
     let (c,M1) := cM1 in
     let (Q1,R1) := MFactor P1 c M1 in
-    match R1 with 
-     (Pc c) => if c ?=! cO then None 
+    match R1 with
+     (Pc c) => if c ?=! cO then None
                else Some (Padd Q1 (Pmul P2 R1))
     | _ => Some (Padd Q1 (Pmul P2 R1))
     end.
 
   Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
-    match POneSubst P1 cM1 P2 with 
+    match POneSubst P1 cM1 P2 with
      Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end
     | _ => P1
     end.
 
   Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol :=
-    match POneSubst P1 cM1 P2 with 
+    match POneSubst P1 cM1 P2 with
      Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end
     | _ => None
     end.
-            
-  Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: 
+
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}:
      Pol :=
-    match LM1 with 
+    match LM1 with
      cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
     | _ => P1
     end.
 
   Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol :=
-    match LM1 with 
+    match LM1 with
      cons (M1,P2) LM2 =>
-      match PNSubst P1 M1 P2 n with 
+      match PNSubst P1 M1 P2 n with
         Some P3 => Some (PSubstL1 P3 LM2 n)
      |  None => PSubstL P1 LM2 n
      end
@@ -498,7 +498,7 @@ Section MakeRingPol.
     end.
 
   Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol :=
-    match PSubstL P1 LM1 n with 
+    match PSubstL P1 LM1 n with
      Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
     | _ => P1
     end.
@@ -509,10 +509,10 @@ Section MakeRingPol.
   match P with
   | Pc c => [c]
   | Pinj j Q => Pphi (jump j l) Q
-  | PX P i Q => 
+  | PX P i Q =>
      let x := hd 0 l in
      let xi := pow_pos rmul x i in
-    (Pphi l P) * xi + (Pphi (tail l) Q)      
+    (Pphi l P) * xi + (Pphi (tail l) Q)
   end.
 
  Reserved Notation "P @ l " (at level 10, no associativity).
@@ -546,8 +546,8 @@ Section MakeRingPol.
   rewrite Psucc_o_double_minus_one_eq_xO;trivial.
   simpl;trivial.
  Qed.
-  
- Lemma Peq_ok : forall P P', 
+
+ Lemma Peq_ok : forall P P',
     (P ?== P') = true -> forall l, P@l == P'@ l.
  Proof.
   induction P;destruct P';simpl;intros;try discriminate;trivial.
@@ -580,10 +580,10 @@ Section MakeRingPol.
   rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl.
  Qed.
 
- Let pow_pos_Pplus := 
+ Let pow_pos_Pplus :=
     pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
 
- Lemma mkPX_ok : forall l P i Q, 
+ Lemma mkPX_ok : forall l P i Q,
   (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
  Proof.
   intros l P i Q;unfold mkPX.
@@ -616,8 +616,8 @@ Section MakeRingPol.
        | -! ?x => rewrite ((morph_opp CRmorph) x)
        end
    end));
-  rsimpl; simpl. 
- 
+  rsimpl; simpl.
+
  Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
  Proof.
   induction P;simpl;intros;Esimpl;trivial.
@@ -637,7 +637,7 @@ Section MakeRingPol.
   induction P;simpl;intros;Esimpl;trivial.
   rewrite IHP1;rewrite IHP2;rsimpl.
   mul_push ([c]);rrefl.
- Qed. 
+ Qed.
 
  Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
  Proof.
@@ -660,7 +660,7 @@ Section MakeRingPol.
  Ltac Esimpl2 :=
   Esimpl;
   repeat (progress (
-   match goal with 
+   match goal with
    | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
    | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
    | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
@@ -684,7 +684,7 @@ Section MakeRingPol.
   rewrite IHP2;simpl.
   rewrite jump_Pdouble_minus_one;rsimpl.
   rewrite IHP';rsimpl.
-  destruct P;simpl. 
+  destruct P;simpl.
   Esimpl2;add_push [c];rrefl.
   destruct p0;simpl;Esimpl2.
   rewrite IHP'2;simpl.
@@ -699,7 +699,7 @@ Section MakeRingPol.
   rewrite H;rewrite Pplus_comm.
   rewrite pow_pos_Pplus;rsimpl.
   add_push (P3 @ (tail l));rrefl.
-  assert (forall P k l, 
+  assert (forall P k l,
            (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
    induction P;simpl;intros;try apply (ARadd_comm ARth).
    destruct p2;simpl;try apply (ARadd_comm ARth).
@@ -727,7 +727,7 @@ Section MakeRingPol.
   induction P;simpl;intros.
   Esimpl2;apply (ARadd_comm ARth).
   assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
-  rewrite H;Esimpl. rewrite IHP';rsimpl. 
+  rewrite H;Esimpl. rewrite IHP';rsimpl.
   rewrite H;Esimpl. rewrite IHP';Esimpl.
   rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
   rewrite H;Esimpl. rewrite IHP.
@@ -736,8 +736,8 @@ Section MakeRingPol.
   rewrite IHP2;simpl;rsimpl.
   rewrite IHP2;simpl.
   rewrite jump_Pdouble_minus_one;rsimpl.
-  rewrite IHP';rsimpl. 
-  destruct P;simpl. 
+  rewrite IHP';rsimpl.
+  destruct P;simpl.
   repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
   destruct p0;simpl;Esimpl2.
   rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
@@ -752,7 +752,7 @@ Section MakeRingPol.
   rewrite H;rewrite Pplus_comm.
   rewrite pow_pos_Pplus;rsimpl.
   add_push (P3 @ (tail l));rrefl.
-  assert (forall P k l, 
+  assert (forall P k l,
            (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
    induction P;simpl;intros.
    rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
@@ -775,8 +775,8 @@ Section MakeRingPol.
  Qed.
 (* Proof for the symmetriv version *)
 
- Lemma PmulI_ok : 
-  forall P', 
+ Lemma PmulI_ok :
+  forall P',
    (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) ->
    forall (P : Pol) (p : positive) (l : list R),
     (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
@@ -801,8 +801,8 @@ Section MakeRingPol.
  Qed.
 
 (*
- Lemma PmulI_ok : 
-  forall P', 
+ Lemma PmulI_ok :
+  forall P',
    (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
    forall (P : Pol) (p : positive) (l : list R),
     (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
@@ -846,7 +846,7 @@ Section MakeRingPol.
   Esimpl2. rewrite IHP'1;Esimpl2.
    assert (match p0 with
            | xI j => Pinj (xO j) P ** P'2
-           | xO j => Pinj (Pdouble_minus_one j) P ** P'2 
+           | xO j => Pinj (Pdouble_minus_one j) P ** P'2
            | 1 => P ** P'2
            end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
    destruct p0;simpl;rewrite IHP'2;Esimpl.
@@ -886,8 +886,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    Mphi l (mkZmon j M) == Mphi l (zmon j M).
  intros M j l; case M; simpl; intros; rsimpl.
  Qed.
- 
- Lemma zmon_pred_ok : forall M j l, 
+
+ Lemma zmon_pred_ok : forall M j l,
     Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
  Proof.
    destruct j; simpl;intros auto; rsimpl.
@@ -902,7 +902,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
   rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
  Qed.
 
- Lemma Mcphi_ok: forall P c l, 
+ Lemma Mcphi_ok: forall P c l,
     let (Q,R) := CFactor P c in
       P@l == Q@l + (phi c) * (R@l).
  Proof.
@@ -924,7 +924,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    rewrite (ARadd_comm ARth); rsimpl.
  Qed.
 
- Lemma Mphi_ok: forall P (cM: C * Mon) l, 
+ Lemma Mphi_ok: forall P (cM: C * Mon) l,
     let (c,M) := cM in
     let (Q,R) := MFactor P c M in
       P@l == Q@l + (phi c) * (Mphi l M) * (R@l).
@@ -951,7 +951,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
        rewrite (Pcompare_Eq_eq _ _ He).
        generalize (Hrec (c, M) (jump j l)); case (MFactor P c M);
         simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
-       generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); 
+       generalize (Hrec (c, (zmon (j -i) M)) (jump i l));
        case (MFactor P c (zmon (j -i) M)); simpl.
        intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
        rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
@@ -973,14 +973,14 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
     apply (Radd_ext Reqe); rsimpl.
     rewrite (ARadd_comm ARth); rsimpl.
    intros j M1.
-     generalize (Hrec1 (c,zmon j M1) l); 
+     generalize (Hrec1 (c,zmon j M1) l);
      case (MFactor P2 c (zmon j M1)).
      intros R1 S1 H1.
-     generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); 
+     generalize (Hrec2 (c, zmon_pred j M1) (List.tail l));
      case (MFactor Q2 c (zmon_pred j M1)); simpl.
      intros R2 S2 H2; rewrite H1; rewrite H2.
      repeat rewrite mkPX_ok; simpl.
-     rsimpl.  
+     rsimpl.
      apply radd_ext; rsimpl.
      rewrite (ARadd_comm ARth); rsimpl.
      apply radd_ext; rsimpl.
@@ -1002,7 +1002,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
        repeat (rewrite <-(ARmul_assoc ARth)).
        apply rmul_ext; rsimpl.
        rewrite (ARmul_comm ARth); rsimpl.
-       generalize (Hrec1 (c, vmon (j - i) M1) l); 
+       generalize (Hrec1 (c, vmon (j - i) M1) l);
              case (MFactor P2 c (vmon (j - i) M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
@@ -1020,7 +1020,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
        apply rmul_ext; rsimpl.
        rewrite <- pow_pos_Pplus.
        rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
-       generalize (Hrec1 (c, mkZmon 1 M1) l); 
+       generalize (Hrec1 (c, mkZmon 1 M1) l);
              case (MFactor P2 c (mkZmon 1 M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rsimpl.
@@ -1064,7 +1064,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
  intros i P5 H; rewrite H.
    intros HH H1; injection HH; intros; subst; rsimpl.
-   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. 
+   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
  intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
    assert (P4 = Q1 ++ P3 ** PX i P5 P6).
    injection H2; intros; subst;trivial.
@@ -1092,18 +1092,18 @@ Proof.
    injection H2; intros; subst; rsimpl.
    rewrite Padd_ok.
    rewrite Pmul_ok; rsimpl.
- Qed. 
+ Qed.
 *)
  Lemma PNSubst1_ok: forall n P1 M1 P2 l,
     [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
  Proof.
  intros n; elim n; simpl; auto.
    intros P2 M1 P3 l H.
-   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
    case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
    intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
  intros n1 Hrec P2 M1 P3 l H.
-   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
    case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
    intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
  Qed.
@@ -1112,15 +1112,15 @@ Proof.
     PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
  Proof.
  intros n P2 (cc, M1) P3 l P4; unfold PNSubst.
- generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); 
+ generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l);
  case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate].
- intros P5 H1; case n; try (intros; discriminate). 
+ intros P5 H1; case n; try (intros; discriminate).
  intros n1 H2; injection H2; intros; subst.
  rewrite <- PNSubst1_ok; auto.
  Qed.
 
- Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
-    match LM1 with 
+ Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=
+    match LM1 with
      cons (M1,P2) LM2 =>  ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l)
     | _ => True
     end.
@@ -1189,7 +1189,7 @@ Proof.
 Strategy expand [PEeval].
 
  (** Correctness proofs *)
- 
+
  Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
  Proof.
   destruct p;simpl;intros;Esimpl;trivial.
@@ -1198,11 +1198,11 @@ Strategy expand [PEeval].
   rewrite nth_Pdouble_minus_one;rrefl.
  Qed.
 
- Ltac Esimpl3 := 
+ Ltac Esimpl3 :=
   repeat match goal with
   | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
   | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
-  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). 
+  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
 
 (* Power using the chinise algorithm *)
 (*Section POWER.
@@ -1213,13 +1213,13 @@ Strategy expand [PEeval].
    | xO p => subst_l (Psquare (Ppow_pos P p))
    | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
    end.
- 
+
   Definition Ppow_N P n :=
    match n with
    | N0 => P1
    | Npos p => Ppow_pos P p
    end.
- 
+
   Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
          forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
   Proof.
@@ -1228,28 +1228,28 @@ Strategy expand [PEeval].
    repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
    repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
   Qed.
- 
+
   Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
          forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
   Proof.  destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial.  Qed.
-    
+
  End POWER. *)
 
 Section POWER.
   Variable subst_l : Pol -> Pol.
   Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
    match p with
-   | xH => subst_l (Pmul res P) 
+   | xH => subst_l (Pmul res P)
    | xO p => Ppow_pos (Ppow_pos res P p) P p
    | xI p => subst_l (Pmul  (Ppow_pos (Ppow_pos res P p) P p) P)
    end.
- 
+
   Definition Ppow_N P n :=
    match n with
    | N0 => P1
    | Npos p => Ppow_pos P1 P p
    end.
- 
+
   Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
          forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
   Proof.
@@ -1257,11 +1257,11 @@ Section POWER.
    induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
    rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
   Qed.
- 
+
   Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
          forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
   Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl.  Qed.
-    
+
  End POWER.
 
  (** Normalization and rewriting *)
@@ -1276,86 +1276,86 @@ Section POWER.
   Fixpoint norm_aux (pe:PExpr) : Pol :=
    match pe with
    | PEc c => Pc c
-   | PEX j => mk_X j  
+   | PEX j => mk_X j
    | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
-   | PEadd pe1 (PEopp pe2) => 
+   | PEadd pe1 (PEopp pe2) =>
      Psub (norm_aux pe1) (norm_aux pe2)
    | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
    | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
-   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) 
+   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
    | PEopp pe1 => Popp (norm_aux pe1)
    | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
    end.
 
   Definition norm_subst pe := subst_l (norm_aux pe).
 
- (* 
+ (*
   Fixpoint norm_subst (pe:PExpr) : Pol :=
    match pe with
    | PEc c => Pc c
-   | PEX j => subst_l (mk_X j)  
+   | PEX j => subst_l (mk_X j)
    | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
-   | PEadd pe1 (PEopp pe2) => 
+   | PEadd pe1 (PEopp pe2) =>
      Psub (norm_subst pe1) (norm_subst pe2)
    | PEadd pe1 pe2 => Padd (norm_subst  pe1) (norm_subst pe2)
    | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
-   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) 
+   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
    | PEopp pe1 => Popp (norm_subst pe1)
    | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
    end.
 
-  Lemma norm_subst_spec : 
+  Lemma norm_subst_spec :
      forall l pe, MPcond lmp l ->
-       PEeval l pe == (norm_subst pe)@l. 
+       PEeval l pe == (norm_subst pe)@l.
   Proof.
-   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). 
+   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
       unfold subst_l;intros.
       rewrite <- PNSubstL_ok;trivial. rrefl.
    assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
     intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
    induction pe;simpl;Esimpl3.
    rewrite subst_l_ok;apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
    rewrite IHpe1;rewrite IHpe2;rrefl.
    rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
    rewrite IHpe;rrefl.
    unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
    rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
       repeat rewrite Pmul_ok;rrefl.
   Qed.
 *)
- Lemma norm_aux_spec : 
+ Lemma norm_aux_spec :
      forall l pe, MPcond lmp l ->
-       PEeval l pe == (norm_aux pe)@l. 
+       PEeval l pe == (norm_aux pe)@l.
   Proof.
    intros.
    induction pe;simpl;Esimpl3.
    apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
    rewrite IHpe1;rewrite IHpe2;rrefl.
    rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
    rewrite IHpe;rrefl.
    rewrite Ppow_N_ok by (intros;rrefl).
    rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
       repeat rewrite Pmul_ok;rrefl.
   Qed.
 
- Lemma norm_subst_spec : 
+ Lemma norm_subst_spec :
      forall l pe, MPcond lmp l ->
        PEeval l pe == (norm_subst pe)@l.
  Proof.
   intros;unfold norm_subst.
   unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial.
- Qed. 
- 
+ Qed.
+
  End NORM_SUBST_REC.
-  
+
  Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop :=
    match lpe with
    | nil => True
-   | (me,pe)::lpe => 
+   | (me,pe)::lpe =>
      match lpe with
      | nil => PEeval l me == PEeval l pe
      | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe
@@ -1366,9 +1366,9 @@ Section POWER.
   match P with
   | Pc c => if (c ?=! cO) then None else Some (c, mon0)
   | Pinj j P =>
-    match mon_of_pol P with 
+    match mon_of_pol P with
     | None => None
-    | Some (c,m) =>  Some (c, mkZmon j m) 
+    | Some (c,m) =>  Some (c, mkZmon j m)
     end
   | PX P i Q =>
     if Peq Q P0 then
@@ -1384,15 +1384,15 @@ Section POWER.
   | nil => nil
   | (me,pe)::lpe =>
     match mon_of_pol (norm_subst 0 nil me) with
-    | None => mk_monpol_list lpe 
-    | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe 
+    | None => mk_monpol_list lpe
+    | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe
     end
   end.
 
   Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
               forall l, [fst m] * Mphi l (snd m) == P@l.
   Proof.
-    induction P;simpl;intros;Esimpl.  
+    induction P;simpl;intros;Esimpl.
     assert (H1 := (morph_eq CRmorph) c cO).
     destruct (c ?=! cO).
     discriminate.
@@ -1418,14 +1418,14 @@ Section POWER.
     discriminate.
     intros;discriminate.
    Qed.
- 
- Lemma interp_PElist_ok : forall l lpe, 
+
+ Lemma interp_PElist_ok : forall l lpe,
          interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l.
  Proof.
    induction lpe;simpl. trivial.
    destruct a;simpl;intros.
    assert (HH:=mon_of_pol_ok (norm_subst 0 nil  p));
-     destruct  (mon_of_pol (norm_subst 0 nil p)).  
+     destruct  (mon_of_pol (norm_subst 0 nil p)).
    split.
    rewrite <- norm_subst_spec by exact I.
    destruct lpe;try destruct H;rewrite <- H;
@@ -1440,7 +1440,7 @@ Section POWER.
  Proof.
    intros;apply norm_subst_spec. apply interp_PElist_ok;trivial.
   Qed.
- 
+
  Lemma ring_correct : forall n l lpe pe1 pe2,
    interp_PElist l lpe ->
    (let lmp := mk_monpol_list lpe in
@@ -1448,9 +1448,9 @@ Section POWER.
    PEeval l pe1 == PEeval l pe2.
  Proof.
   simpl;intros.
-  do 2 (rewrite (norm_subst_ok n l lpe);trivial). 
+  do 2 (rewrite (norm_subst_ok n l lpe);trivial).
   apply Peq_ok;trivial.
- Qed.  
+ Qed.
 
 
 
@@ -1467,23 +1467,23 @@ Section POWER.
   Variable mkopp_pow : R -> positive -> R.
   (* [mkmult_pow r x p] = r * x^p *)
   Variable mkmult_pow : R -> R -> positive -> R.
-    
+
   Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R :=
    match lm with
    | nil => r
-   | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t 
+   | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t
    end.
 
   Definition mkmult1 lm :=
    match lm with
    | nil => 1
-   | cons (x,p) t => mkmult_rec (mkpow x p) t 
+   | cons (x,p) t => mkmult_rec (mkpow x p) t
    end.
 
   Definition mkmultm1 lm :=
    match lm with
    | nil => ropp rI
-   | cons (x,p) t => mkmult_rec (mkopp_pow x p) t 
+   | cons (x,p) t => mkmult_rec (mkopp_pow x p) t
    end.
 
   Definition mkmult_c_pos c lm :=
@@ -1493,11 +1493,11 @@ Section POWER.
   Definition mkmult_c c lm :=
    match get_sign c with
    | None => mkmult_c_pos c lm
-   | Some c' => 
+   | Some c' =>
      if c' ?=! cI then mkmultm1 (rev' lm)
      else mkmult_rec [c] (rev' lm)
    end.
-      
+
   Definition mkadd_mult rP c lm :=
    match get_sign c with
    | None => rP + mkmult_c_pos c lm
@@ -1505,49 +1505,49 @@ Section POWER.
    end.
 
   Definition add_pow_list (r:R) n l :=
-   match n with 
+   match n with
    | N0 => l
    | Npos p => (r,p)::l
    end.
 
-  Fixpoint add_mult_dev 
+  Fixpoint add_mult_dev
       (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R :=
    match P with
-   | Pc c => 
+   | Pc c =>
      let lm := add_pow_list (hd 0 fv) n lm in
      mkadd_mult rP c lm
-   | Pinj j Q => 
+   | Pinj j Q =>
      add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
-   | PX P i Q => 
+   | PX P i Q =>
      let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in
-     if Q ?== P0 then rP 
+     if Q ?== P0 then rP
      else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm)
    end.
 
-  Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) 
+  Fixpoint mult_dev (P:Pol) (fv : list R) (n:N)
                      (lm:list (R*positive)) {struct P} : R :=
-  (* P@l * (hd 0 l)^n * lm *)						      
+  (* P@l * (hd 0 l)^n * lm *)
   match P with
   | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm)
   | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
-  | PX P i Q => 
+  | PX P i Q =>
      let rP := mult_dev P fv (Nplus (Npos i) n) lm in
-     if Q ?== P0 then rP 
-     else 
+     if Q ?== P0 then rP
+     else
        let lmq := add_pow_list (hd 0 fv) n lm in
        add_mult_dev rP Q (tail fv) N0 lmq
-  end. 
+  end.
 
  Definition Pphi_avoid fv P := mult_dev P fv N0 nil.
- 
+
  Fixpoint r_list_pow (l:list (R*positive)) : R :=
   match l with
   | nil => rI
-  | cons (r,p) l => pow_pos rmul r p * r_list_pow l 
+  | cons (r,p) l => pow_pos rmul r p * r_list_pow l
   end.
 
   Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p.
-  Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). 
+  Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p).
   Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p.
 
  Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm.
@@ -1571,7 +1571,7 @@ Section POWER.
 
  Lemma r_list_pow_rev :  forall l, r_list_pow (rev' l) == r_list_pow l.
  Proof.
-   assert 
+   assert
     (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l).
    induction l;intros;simpl;Esimpl.
    destruct a;rewrite IHl;Esimpl.
@@ -1583,7 +1583,7 @@ Section POWER.
  Proof.
   intros;unfold mkmult_c_pos;simpl.
    assert (H := (morph_eq CRmorph) c cI).
-   rewrite <- r_list_pow_rev; destruct (c ?=! cI). 
+   rewrite <- r_list_pow_rev; destruct (c ?=! cI).
   rewrite H;trivial;Esimpl.
   apply mkmult1_ok.  apply mkmult_rec_ok.
  Qed.
@@ -1610,16 +1610,16 @@ Qed.
   rewrite mkmult_c_pos_ok;Esimpl.
  Qed.
 
- Lemma add_pow_list_ok : 
+ Lemma add_pow_list_ok :
       forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l.
  Proof.
    destruct n;simpl;intros;Esimpl.
  Qed.
 
- Lemma add_mult_dev_ok : forall P rP fv n lm, 
+ Lemma add_mult_dev_ok : forall P rP fv n lm,
     add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
   Proof.
-    induction P;simpl;intros.  
+    induction P;simpl;intros.
     rewrite mkadd_mult_ok. rewrite  add_pow_list_ok; Esimpl.
     rewrite IHP. simpl. rewrite  add_pow_list_ok; Esimpl.
     change (match P3 with
@@ -1639,7 +1639,7 @@ Qed.
    rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
  Qed.
 
- Lemma mult_dev_ok : forall P fv n lm,    
+ Lemma mult_dev_ok : forall P fv n lm,
     mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
  Proof.
    induction P;simpl;intros;Esimpl.
@@ -1669,14 +1669,14 @@ Qed.
 
  End EVALUATION.
 
-  Definition Pphi_pow := 
-   let mkpow x p := 
+  Definition Pphi_pow :=
+   let mkpow x p :=
       match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in
    let mkopp_pow x p := ropp (mkpow x p)  in
    let mkmult_pow r x p := rmul r (mkpow x p) in
     Pphi_avoid mkpow mkopp_pow mkmult_pow.
 
- Lemma local_mkpow_ok : 
+ Lemma local_mkpow_ok :
    forall (r : R) (p : positive),
     match p with
     | xI _ => rpow r (Cp_phi (Npos p))
@@ -1684,13 +1684,13 @@ Qed.
     | 1 => r
     end == pow_pos rmul r p.
  Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed.
- 
+
  Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P  == P@fv.
  Proof.
   unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl.
  Qed.
 
- Lemma ring_rw_pow_correct : forall n lH l,  
+ Lemma ring_rw_pow_correct : forall n lH l,
       interp_PElist l lH ->
       forall lmp, mk_monpol_list lH = lmp ->
       forall pe npe, norm_subst n lmp pe = npe ->
@@ -1701,22 +1701,22 @@ Qed.
   apply norm_subst_ok. trivial.
  Qed.
 
- Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := 
+ Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R :=
    match p with
-   | xH => r*x 
+   | xH => r*x
    | xO p => mkmult_pow (mkmult_pow r x p) x p
    | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p
    end.
- 
+
   Definition mkpow x p :=
-    match p with 
+    match p with
     | xH => x
     | xO p => mkmult_pow x x (Pdouble_minus_one p)
     | xI p => mkmult_pow x x (xO p)
     end.
- 
+
   Definition mkopp_pow x p :=
-    match p with 
+    match p with
     | xH => -x
     | xO p => mkmult_pow (-x) x (Pdouble_minus_one p)
     | xI p => mkmult_pow (-x) x (xO p)
@@ -1726,31 +1726,31 @@ Qed.
 
   Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p.
   Proof.
-    induction p;intros;simpl;Esimpl.   
+    induction p;intros;simpl;Esimpl.
     repeat rewrite IHp;Esimpl.
     repeat rewrite IHp;Esimpl.
   Qed.
-  
+
  Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p.
   Proof.
     destruct p;simpl;intros;Esimpl.
     repeat rewrite mkmult_pow_ok;Esimpl.
     rewrite mkmult_pow_ok;Esimpl.
-    pattern x at 1;replace x with (pow_pos rmul x 1). 
-    rewrite <- pow_pos_Pplus. 
+    pattern x at 1;replace x with (pow_pos rmul x 1).
+    rewrite <- pow_pos_Pplus.
     rewrite <- Pplus_one_succ_l.
     rewrite Psucc_o_double_minus_one_eq_xO.
     simpl;Esimpl.
     trivial.
   Qed.
- 
+
   Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p.
   Proof.
     destruct p;simpl;intros;Esimpl.
     repeat rewrite mkmult_pow_ok;Esimpl.
     rewrite mkmult_pow_ok;Esimpl.
-    pattern x at 1;replace x with (pow_pos rmul x 1). 
-    rewrite <- pow_pos_Pplus. 
+    pattern x at 1;replace x with (pow_pos rmul x 1).
+    rewrite <- pow_pos_Pplus.
     rewrite <- Pplus_one_succ_l.
     rewrite Psucc_o_double_minus_one_eq_xO.
     simpl;Esimpl.
@@ -1765,7 +1765,7 @@ Qed.
    intros;apply mkmult_pow_ok.
   Qed.
 
- Lemma ring_rw_correct : forall n lH l,  
+ Lemma ring_rw_correct : forall n lH l,
       interp_PElist l lH ->
       forall lmp, mk_monpol_list lH = lmp ->
       forall pe npe, norm_subst n lmp pe = npe ->
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
new file mode 100644
index 00000000..d33e9a82
--- /dev/null
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -0,0 +1,434 @@
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinPos.
+Require Import Ring_polynom.
+Require Import BinList.
+Require Import InitialRing.
+Require Import Quote.
+Declare ML Module "newring_plugin".
+
+
+(* adds a definition t' on the normal form of t and an hypothesis id
+   stating that t = t' (tries to produces a proof as small as possible) *)
+Ltac compute_assertion eqn t' t :=
+  let nft := eval vm_compute in t in
+  pose (t' := nft);
+  assert (eqn : t = t');
+  [vm_cast_no_check (refl_equal t')|idtac].
+
+Ltac relation_carrier req :=
+  let ty := type of req in
+  match eval hnf in ty with
+   ?R -> _ => R
+  | _ => fail 1000 "Equality has no relation type"
+  end.
+
+Ltac Get_goal := match goal with [|- ?G] => G end.
+
+(********************************************************************)
+(* Tacticals to build reflexive tactics *)
+
+Ltac OnEquation req :=
+  match goal with
+  | |- req ?lhs ?rhs => (fun f => f lhs rhs)
+  | _ => (fun _ => fail "Goal is not an equation (of expected equality)")
+  end.
+
+Ltac OnEquationHyp req h :=
+  match type of h with
+  | req ?lhs ?rhs => fun f => f lhs rhs
+  | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)")
+  end.
+
+(* Note: auxiliary subgoals in reverse order *)
+Ltac OnMainSubgoal H ty :=
+  match ty with
+  | _ -> ?ty' =>
+     let subtac := OnMainSubgoal H ty' in
+     fun kont => lapply H; [clear H; intro H; subtac kont | idtac]
+  | _ => (fun kont => kont())
+  end.
+
+(* A generic pattern to have reflexive tactics do some computation:
+   lemmas of the form [forall x', x=x' -> P(x')] are understood as:
+   compute the normal form of x, instantiate x' with it, prove
+   hypothesis x=x' with vm_compute and reflexivity, and pass the
+   instantiated lemma to the continuation.
+ *)
+Ltac ProveLemmaHyp lemma :=
+  match type of lemma with
+    forall x', ?x = x' -> _ =>
+      (fun kont =>
+        let x' := fresh "res" in
+        let H := fresh "res_eq" in
+        compute_assertion H x' x;
+        let lemma' := constr:(lemma x' H) in
+        kont lemma';
+        (clear H||idtac"ProveLemmaHyp: cleanup failed");
+        subst x')
+  | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form")
+  end.
+
+Ltac ProveLemmaHyps lemma :=
+  match type of lemma with
+    forall x', ?x = x' -> _ =>
+      (fun kont =>
+        let x' := fresh "res" in
+        let H := fresh "res_eq" in
+        compute_assertion H x' x;
+        let lemma' := constr:(lemma x' H) in
+        ProveLemmaHyps lemma' kont;
+        (clear H||idtac"ProveLemmaHyps: cleanup failed");
+        subst x')
+  | _ => (fun kont => kont lemma)
+  end.
+
+(*
+Ltac ProveLemmaHyps lemma := (* expects a continuation *)
+  let try_step := ProveLemmaHyp lemma in
+  (fun kont =>
+    try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) ||
+    kont lemma).
+*)
+Ltac ApplyLemmaThen lemma expr kont :=
+  let lem := constr:(lemma expr) in
+  ProveLemmaHyp lem ltac:(fun lem' =>
+    let Heq := fresh "thm" in
+    assert (Heq:=lem');
+    OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq);
+    (clear Heq||idtac"ApplyLemmaThen: cleanup failed")).
+(*
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
+  let pe :=
+    match type of (lemma expr) with
+      forall pe', ?pe = pe' -> _ => pe
+    | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression"
+    end in
+  let pe' := fresh "expr_nf" in
+  let nf_pe := fresh "pe_eq" in
+  compute_assertion nf_pe pe' pe;
+  let Heq := fresh "thm" in
+  (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma");
+  clear nf_pe;
+  OnMainSubgoal Heq ltac:(type of Heq)
+    ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)).
+*)
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac :=
+  ApplyLemmaThen lemma expr
+    ltac:(fun lemma' => try tac lemma'; CONT_tac()).
+
+(* General scheme of reflexive tactics using of correctness lemma
+   that involves normalisation of one expression
+   - [FV_tac term fv] is a tactic that adds the atomic expressions
+       of [term] into [fv]
+   - [SYN_tac term fv] reifies [term] given the list of atomic expressions
+   - [LEMMA_tac fv kont] computes the correctness lemma and passes it to
+       continuation kont
+   - [MAIN_tac H] process H which is the conclusion of the correctness lemma
+       instantiated with each reified term
+   - [fv] is the initial value of atomic expressions (to be completed by
+       the reification of the terms
+   - [terms] the list (a constr of type list) of terms to reify and process.
+ *)
+Ltac ReflexiveRewriteTactic
+     FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms :=
+  (* extend the atom list *)
+  let fv := list_fold_left FV_tac fv terms in
+  let RW_tac lemma :=
+     let fcons term CONT_tac :=
+      let expr := SYN_tac term fv in
+      let main H :=
+        match type of H with
+        | (?req _ ?rhs) => change (req term rhs) in H
+        end;
+        MAIN_tac H in
+      (ApplyLemmaThenAndCont lemma expr main CONT_tac) in
+     (* rewrite steps *)
+     lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in
+  LEMMA_tac fv RW_tac.
+
+(********************************************************)
+
+Ltac FV_hypo_tac mkFV req lH :=
+  let R := relation_carrier req in
+  let FV_hypo_l_tac h :=
+    match h with @mkhypo (req ?pe _) _ => mkFV pe end in
+  let FV_hypo_r_tac h :=
+    match h with @mkhypo (req _ ?pe) _ => mkFV pe end in
+  let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in
+  list_fold_right FV_hypo_r_tac fv lH.
+
+Ltac mkHyp_tac C req Reify lH :=
+  let mkHyp h res :=
+   match h with
+   | @mkhypo (req ?r1 ?r2) _ =>
+     let pe1 := Reify r1 in
+     let pe2 := Reify r2 in
+     constr:(cons (pe1,pe2) res)
+   | _ => fail 1 "hypothesis is not a ring equality"
+   end in
+  list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
+
+Ltac proofHyp_tac lH :=
+  let get_proof h :=
+    match h with
+    | @mkhypo _ ?p => p
+    end in
+  let rec bh l :=
+    match l with
+    | nil => constr:(I)
+    | cons ?h nil => get_proof h
+    | cons ?h ?tl =>
+      let l := get_proof h in
+      let r := bh tl in
+      constr:(conj l r)
+    end in
+  bh lH.
+
+Ltac get_MonPol lemma :=
+  match type of lemma with
+  | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] =>
+      constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb)
+  | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)"
+  end.
+
+(********************************************************)
+
+(* Building the atom list of a ring expression *)
+Ltac FV Cst CstPow add mul sub opp pow t fv :=
+ let rec TFV t fv :=
+  let f :=
+  match Cst t with
+  | NotConstant =>
+      match t with
+      | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+      | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+      | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+      | (opp ?t1) => fun _ => TFV t1 fv
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant => fun _ => AddFvTail t fv
+        | _ => fun _ => TFV t1 fv
+        end
+      | _ => fun _ => AddFvTail t fv
+      end
+  | _ => fun _ => fv
+  end in
+  f()
+ in TFV t fv.
+
+ (* syntaxification of ring expressions *)
+Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv :=
+ let rec mkP t :=
+    let f :=
+    match Cst t with
+    | InitialRing.NotConstant =>
+        match t with
+        | (radd ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(PEadd e1 e2)
+        | (rmul ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(PEmul e1 e2)
+        | (rsub ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(PEsub e1 e2)
+        | (ropp ?t1) =>
+          fun _ =>
+          let e1 := mkP t1 in constr:(PEopp e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant =>
+            fun _ => let p := Find_at t fv in constr:(PEX C p)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c)
+          end
+        | _ =>
+          fun _ => let p := Find_at t fv in constr:(PEX C p)
+        end
+    | ?c => fun _ => constr:(@PEc C c)
+    end in
+    f ()
+ in mkP t.
+
+(* packaging the ring structure *)
+
+Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post :=
+  let RNG :=
+    match type of lemma1 with
+    | context
+       [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+        (fun proj => proj
+             cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2)
+    | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+    end in
+  F RNG.
+
+Ltac get_Carrier RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            R).
+
+Ltac get_Eq RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            req).
+
+Ltac get_Pre RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            pre).
+
+Ltac get_Post RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            post).
+
+Ltac get_NormLemma RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            lemma1).
+
+Ltac get_SimplifyLemma RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            lemma2).
+
+Ltac get_RingFV RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            FV cst_tac pow_tac add mul sub opp pow).
+
+Ltac get_RingMeta RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            mkPolexpr C cst_tac pow_tac add mul sub opp pow).
+
+Ltac get_RingHypTac RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+       let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in
+       fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
+
+(* ring tactics *)
+
+Definition ring_subst_niter := (10*10*10)%nat.
+
+Ltac Ring RNG lemma lH :=
+  let req := get_Eq RNG in
+  OnEquation req ltac:(fun lhs rhs =>
+    let mkFV := get_RingFV RNG in
+    let mkPol := get_RingMeta RNG in
+    let mkHyp := get_RingHypTac RNG in
+    let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+    let fv := mkFV lhs fv in
+    let fv := mkFV rhs fv in
+    check_fv fv;
+    let pe1 := mkPol lhs fv in
+    let pe2 := mkPol rhs fv in
+    let lpe := mkHyp fv lH in
+    let vlpe := fresh "hyp_list" in
+    let vfv := fresh "fv_list" in
+    pose (vlpe := lpe);
+    pose (vfv := fv);
+    (apply (lemma vfv vlpe pe1 pe2)
+      || fail "typing error while applying ring");
+    [ ((let prh := proofHyp_tac lH in exact prh)
+        || idtac "can not automatically proof hypothesis :";
+           idtac " maybe a left member of a hypothesis is not a monomial")
+    | vm_compute;
+      (exact (refl_equal true) || fail "not a valid ring equation")]).
+
+Ltac Ring_norm_gen f RNG lemma lH rl :=
+  let mkFV := get_RingFV RNG in
+  let mkPol := get_RingMeta RNG in
+  let mkHyp := get_RingHypTac RNG in
+  let mk_monpol := get_MonPol lemma in
+  let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+  let lemma_tac fv kont :=
+    let lpe := mkHyp fv lH in
+    let vlpe := fresh "list_hyp" in
+    let vlmp := fresh "list_hyp_norm" in
+    let vlmp_eq := fresh "list_hyp_norm_eq" in
+    let prh := proofHyp_tac lH in
+    pose (vlpe := lpe);
+    compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
+    let H := fresh "ring_lemma" in
+    (assert (H := lemma vlpe fv prh vlmp vlmp_eq)
+      || fail "type error when build the rewriting lemma");
+    clear vlmp_eq;
+    kont H;
+    (clear H||idtac"Ring_norm_gen: cleanup failed");
+    subst vlpe vlmp in
+  let simpl_ring H := (protect_fv "ring" in H; f H) in
+  ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl.
+
+Ltac Ring_gen RNG lH rl :=
+  let lemma := get_NormLemma RNG in
+  get_Pre RNG ();
+  Ring RNG (lemma ring_subst_niter) lH.
+
+Tactic Notation (at level 0) "ring" :=
+  let G := Get_goal in
+  ring_lookup (PackRing Ring_gen) [] G.
+
+Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
+  let G := Get_goal in
+  ring_lookup (PackRing Ring_gen) [lH] G.
+
+(* Simplification *)
+
+Ltac Ring_simplify_gen f RNG lH rl :=
+  let lemma := get_SimplifyLemma RNG in
+  let l := fresh "to_rewrite" in
+  pose (l:= rl);
+  generalize (refl_equal l);
+  unfold l at 2;
+  get_Pre RNG ();
+  let rl :=
+    match goal with
+    | [|- l = ?RL -> _ ] => RL
+    | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+    end in
+  let Heq := fresh "Heq" in
+  intros Heq;clear Heq l;
+  Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl;
+  get_Post RNG ().
+
+Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H).
+
+Tactic Notation (at level 0) "ring_simplify" constr_list(rl) :=
+  let G := Get_goal in
+  ring_lookup (PackRing Ring_simplify) [] rl G.
+
+Tactic Notation (at level 0)
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  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
+  let g := fresh "goal" in
+  set (g:= G);
+  generalize H;clear H;
+  ring_lookup (PackRing Ring_simplify) [] rl t;
+  intro H;
+  unfold g;clear g.
+
+Tactic Notation
+  "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):=
+  let G := Get_goal in
+  let t := type of H in
+  let g := fresh "goal" in
+  set (g:= G);
+  generalize H;clear H;
+  ring_lookup (PackRing Ring_simplify) [lH] rl t;
+  intro H;
+  unfold g;clear g.
+
diff --git a/contrib/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 531ab3ca..b3250a51 100644
--- a/contrib/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -39,7 +39,7 @@ Section Power.
  Notation "x * y " := (rmul x y).
  Notation "x == y" := (req x y).
 
- Hypothesis mul_ext : 
+ Hypothesis mul_ext :
    forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2.
  Hypothesis mul_comm : forall x y, x * y == y * x.
  Hypothesis mul_assoc  : forall x y z, x * (y * z) == (x * y) * z.
@@ -79,11 +79,11 @@ Section Power.
    simpl. apply (Seq_refl _ _ Rsth).
  Qed.
 
- Definition pow_N (x:R) (p:N) := 
+ Definition pow_N (x:R) (p:N) :=
   match p with
   | N0 => rI
   | Npos p => pow_pos x p
-  end. 
+  end.
 
  Definition id_phi_N (x:N) : N := x.
 
@@ -109,12 +109,12 @@ Section DEFINITIONS.
     SRadd_comm   : forall n m, n + m == m + n ;
     SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p;
     SRmul_1_l   : forall n, 1*n == n;
-    SRmul_0_l   : forall n, 0*n == 0; 
+    SRmul_0_l   : forall n, 0*n == 0;
     SRmul_comm   : forall n m, n*m == m*n;
     SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p;
     SRdistr_l   : forall n m p, (n + m)*p == n*p + m*p
   }.
-  
+
  (** Almost Ring *)
 (*Almost ring are no ring : Ropp_def is missing **)
  Record almost_ring_theory : Prop := mk_art {
@@ -129,7 +129,7 @@ Section DEFINITIONS.
     ARopp_mul_l : forall x y, -(x * y) == -x * y;
     ARopp_add   : forall x y, -(x + y) == -x + -y;
     ARsub_def   : forall x y, x - y == x + -y
-  }. 
+  }.
 
  (** Ring *)
  Record ring_theory : Prop := mk_rt {
@@ -145,7 +145,7 @@ Section DEFINITIONS.
  }.
 
  (** Equality is extensional *)
-  
+
  Record sring_eq_ext : Prop := mk_seqe {
     (* SRing operators are compatible with equality *)
     SRadd_ext :
@@ -163,12 +163,12 @@ Section DEFINITIONS.
     Ropp_ext : forall x1 x2, x1 == x2 ->  -x1 == -x2
   }.
 
- (** Interpretation morphisms definition*) 
+ (** Interpretation morphisms definition*)
  Section MORPHISM.
  Variable C:Type.
  Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C).
  Variable ceqb : C->C->bool.
- (* [phi] est un morphisme de [C] dans [R] *) 
+ (* [phi] est un morphisme de [C] dans [R] *)
  Variable phi : C -> R.
  Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y).
  Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x).
@@ -180,7 +180,7 @@ Section DEFINITIONS.
     Smorph1 : [cI] == 1;
     Smorph_add : forall x y, [x +! y] == [x]+[y];
     Smorph_mul : forall x y, [x *! y] == [x]*[y];
-    Smorph_eq  : forall x y, x?=!y = true -> [x] == [y] 
+    Smorph_eq  : forall x y, x?=!y = true -> [x] == [y]
   }.
 
 (* for rings*)
@@ -191,7 +191,7 @@ Section DEFINITIONS.
     morph_sub : forall x y, [x -! y] == [x]-[y];
     morph_mul : forall x y, [x *! y] == [x]*[y];
     morph_opp : forall x, [-!x] == -[x];
-    morph_eq  : forall x y, x?=!y = true -> [x] == [y] 
+    morph_eq  : forall x y, x?=!y = true -> [x] == [y]
   }.
 
  Section SIGN.
@@ -213,7 +213,7 @@ Section DEFINITIONS.
   }.
  End DIV.
 
- End MORPHISM. 
+ End MORPHISM.
 
  (** Identity is a morphism *)
  Variable Rsth : Setoid_Theory R req.
@@ -231,8 +231,8 @@ Section DEFINITIONS.
  Section POWER.
   Variable Cpow : Set.
   Variable Cp_phi : N -> Cpow.
-  Variable rpow : R -> Cpow -> R. 
-  
+  Variable rpow : R -> Cpow -> R.
+
   Record power_theory : Prop := mkpow_th {
     rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n)
   }.
@@ -241,7 +241,7 @@ Section DEFINITIONS.
 
  Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
 
- 
+
 End DEFINITIONS.
 
 
@@ -268,7 +268,7 @@ Section ALMOST_RING.
  Variable Rsth : Setoid_Theory R req.
    Add Setoid R req Rsth as R_setoid2.
    Ltac sreflexivity := apply (Seq_refl _ _ Rsth).
- 
+
  Section SEMI_RING.
  Variable SReqe : sring_eq_ext radd rmul req.
    Add Morphism radd : radd_ext1.  exact (SRadd_ext SReqe). Qed.
@@ -278,7 +278,7 @@ Section ALMOST_RING.
  (** Every semi ring can be seen as an almost ring, by taking :
         -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).
 
  Lemma SRopp_ext : forall x y, x == y -> -x == -y.
@@ -296,7 +296,7 @@ Section ALMOST_RING.
  Lemma SRopp_add : forall x y, -(x + y) == -x + -y.
  Proof. intros;sreflexivity.  Qed.
 
-  
+
  Lemma SRsub_def   : forall x y, x - y == x + -y.
  Proof. intros;sreflexivity. Qed.
 
@@ -306,7 +306,7 @@ Section ALMOST_RING.
     (SRmul_1_l SRth) (SRmul_0_l SRth)
     (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth)
     SRopp_mul_l SRopp_add SRsub_def).
- 
+
  (** Identity morphism for semi-ring equipped with their almost-ring structure*)
  Variable reqb : R->R->bool.
 
@@ -337,12 +337,12 @@ Section ALMOST_RING.
  Qed.
 
  End  SEMI_RING.
- 
+
  Variable Reqe : ring_eq_ext radd rmul ropp req.
    Add Morphism radd : radd_ext2.  exact (Radd_ext Reqe). Qed.
    Add Morphism rmul : rmul_ext2.  exact (Rmul_ext Reqe). Qed.
    Add Morphism ropp : ropp_ext2.  exact (Ropp_ext Reqe). Qed.
- 
+
  Section RING.
  Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
 
@@ -368,7 +368,7 @@ Section ALMOST_RING.
   rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth).
   rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity.
  Qed.
- 
+
  Lemma Ropp_add : forall x y, -(x + y) == -x + -y.
  Proof.
   intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))).
@@ -387,7 +387,7 @@ Section ALMOST_RING.
   rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth).
   apply (Radd_comm Rth).
  Qed.
- 
+
  Lemma Ropp_opp : forall x, - -x == x.
  Proof.
   intros x; rewrite <- (Radd_0_l Rth (- -x)).
@@ -402,7 +402,7 @@ Section ALMOST_RING.
     (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth)
     Ropp_mul_l Ropp_add (Rsub_def Rth)).
 
- (** Every semi morphism between two rings is a morphism*) 
+ (** Every semi morphism between two rings is a morphism*)
  Variable C : Type.
  Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C).
  Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool).
@@ -431,7 +431,7 @@ Section ALMOST_RING.
   rewrite (Smorph0 Smorph).
   rewrite (Radd_comm Rth (-[x])).
   apply (Radd_0_l Rth);sreflexivity.
- Qed. 
+ Qed.
 
  Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y].
  Proof.
@@ -439,11 +439,11 @@ Section ALMOST_RING.
   rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity.
  Qed.
 
- Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req 
+ Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req
                                              cO cI cadd cmul csub copp ceqb phi.
  Proof
   (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi
-        (Smorph0 Smorph) (Smorph1 Smorph) 
+        (Smorph0 Smorph) (Smorph1 Smorph)
          (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp
          (Smorph_eq Smorph)).
 
@@ -462,7 +462,7 @@ Qed.
       forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
  Proof.
   intros.
-  setoid_replace (x1 - y1) with (x1 + -y1). 
+  setoid_replace (x1 - y1) with (x1 + -y1).
   setoid_replace (x2 - y2) with (x2 + -y2).
   rewrite H;rewrite H0;sreflexivity.
   apply (ARsub_def ARth).
@@ -483,10 +483,10 @@ Qed.
      | match goal with
        | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y))
        end].
- 
+
  Lemma ARadd_0_r : forall x, (x + 0) == x.
  Proof. intros; mrewrite. Qed.
- 
+
  Lemma ARmul_1_r   : forall x, x * 1 == x.
  Proof. intros;mrewrite. Qed.
 
@@ -495,7 +495,7 @@ Qed.
 
  Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y.
  Proof.
-  intros;mrewrite. 
+  intros;mrewrite.
   repeat rewrite (ARth.(ARmul_comm) z);sreflexivity.
  Qed.
 
@@ -516,7 +516,7 @@ Qed.
   intros;rewrite <-((ARmul_assoc ARth) x).
   rewrite ((ARmul_comm ARth) x);sreflexivity.
  Qed.
- 
+
  Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x.
  Proof.
   intros; repeat rewrite <- (ARmul_assoc ARth);
@@ -592,17 +592,17 @@ Ltac gen_srewrite Rsth Reqe ARth :=
 
 Ltac gen_add_push add Rsth Reqe ARth x :=
   repeat (match goal with
-  | |- context [add (add ?y x) ?z] => 
+  | |- context [add (add ?y x) ?z] =>
      progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z)
-  | |- context [add (add x ?y) ?z] => 
+  | |- context [add (add x ?y) ?z] =>
      progress rewrite (ARadd_assoc1 Rsth ARth x y z)
   end).
 
 Ltac gen_mul_push mul Rsth Reqe ARth x :=
   repeat (match goal with
-  | |- context [mul (mul ?y x) ?z] => 
+  | |- context [mul (mul ?y x) ?z] =>
      progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z)
-  | |- context [mul (mul x ?y) ?z] => 
+  | |- context [mul (mul x ?y) ?z] =>
      progress rewrite (ARmul_assoc1 Rsth ARth x y z)
   end).
 
diff --git a/contrib/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 942915ab..4cb5a05a 100644
--- a/contrib/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -21,7 +21,7 @@ Ltac Zcst t :=
   end.
 
 Ltac isZpow_coef t :=
-  match t with 
+  match t with
   | Zpos ?p => isPcst p
   | Z0 => constr:true
   | _ => constr:false
@@ -41,18 +41,18 @@ Ltac Zpow_tac t :=
 
 Ltac Zpower_neg :=
   repeat match goal with
-  | [|- ?G] => 
-    match G with 
+  | [|- ?G] =>
+    match G with
     | context c [Zpower _ (Zneg _)] =>
       let t := context c [Z0] in
       change t
     end
-  end.   
+  end.
 
 Add Ring Zr : Zth
   (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
    power_tac Zpower_theory [Zpow_tac],
-    (* The two following option are not needed, it is the default chose when the set of 
+    (* The two following option are not needed, it is the default chose when the set of
         coefficiant is usual ring Z *)
     div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
    sign get_signZ_th).
diff --git a/contrib/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
index 50b7e47b..535dbdbd 100644
--- a/contrib/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: newring.ml4 11800 2009-01-18 18:34:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -89,10 +89,10 @@ let interp_map l c =
 let interp_map l t =
   try Some(List.assoc t l) with Not_found -> None
 
-let protect_maps = ref ([]:(string*(constr->'a)) list)
-let add_map s m = protect_maps := (s,m) :: !protect_maps
+let protect_maps = ref Stringmap.empty
+let add_map s m = protect_maps := Stringmap.add s m !protect_maps
 let lookup_map map =
-  try List.assoc map !protect_maps
+  try Stringmap.find map !protect_maps
   with Not_found ->
     errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
 
@@ -104,14 +104,13 @@ let protect_tac map =
   Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
 
 let protect_tac_in map id =
-  Tactics.reduct_option (protect_red map,DEFAULTcast)
-    (Some((all_occurrences_expr,id),InHyp));;
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id,InHyp));;
 
 
 TACTIC EXTEND protect_fv
-  [ "protect_fv" string(map) "in" ident(id) ] -> 
+  [ "protect_fv" string(map) "in" ident(id) ] ->
     [ protect_tac_in map id ]
-| [ "protect_fv" string(map) ] -> 
+| [ "protect_fv" string(map) ] ->
     [ protect_tac map ]
 END;;
 
@@ -129,8 +128,8 @@ TACTIC EXTEND closed_term
 END
 ;;
 
-TACTIC EXTEND echo 
-| [ "echo" constr(t) ] -> 
+TACTIC EXTEND echo
+| [ "echo" constr(t) ] ->
   [ Pp.msg (Termops.print_constr t);  Tacinterp.eval_tactic (TacId []) ]
 END;;
 
@@ -160,24 +159,35 @@ let ic c =
 let ty c = Typing.type_of (Global.env()) Evd.empty c
 
 let decl_constant na c =
-  mkConst(declare_constant (id_of_string na) (DefinitionEntry 
+  mkConst(declare_constant (id_of_string na) (DefinitionEntry
     { const_entry_body = c;
       const_entry_type = None;
       const_entry_opaque = true;
-      const_entry_boxed = true}, 
+      const_entry_boxed = true},
     IsProof Lemma))
 
+(* Calling a global tactic *)
 let ltac_call tac (args:glob_tactic_arg list) =
   TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
-let ltac_acall tac (args:glob_tactic_arg list) =
-  TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)
 
+(* Calling a locally bound tactic *)
 let ltac_lcall tac args =
   TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
 
+let ltac_letin (x, e1) e2 =
+  TacLetIn(false,[(dummy_loc,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(dummy_loc,Pretyping.constr_in c)
 
-let dummy_goal env = 
+let dummy_goal env =
   {Evd.it = Evd.make_evar (named_context_val env) mkProp;
    Evd.sigma = Evd.empty}
 
@@ -196,7 +206,7 @@ let exec_tactic env n f args =
   !res
 
 let constr_of = function
-  | VConstr c -> c
+  | VConstr ([],c) -> c
   | _ -> failwith "Ring.exec_tactic: anomaly"
 
 let stdlib_modules =
@@ -218,7 +228,7 @@ let coq_eq = coq_constant "eq"
 
 let lapp f args = mkApp(Lazy.force f,args)
 
-let dest_rel0 t =  
+let dest_rel0 t =
   match kind_of_term t with
   | App(f,args) when Array.length args >= 2 ->
       let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
@@ -235,29 +245,29 @@ let rec dest_rel t =
 (****************************************************************************)
 (* Library linking *)
 
-let contrib_name = "setoid_ring"
+let plugin_dir = "setoid_ring"
 
-let cdir = ["Coq";contrib_name]
-let contrib_modules =
+let cdir = ["Coq";plugin_dir]
+let plugin_modules =
   List.map (fun d -> cdir@d)
     [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
      ["Field_tac"]; ["Field_theory"]
     ]
 
 let my_constant c =
-  lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c)
+  lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)
 
 let new_ring_path =
-  make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"])
+  make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"])
 let ltac s =
   lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
 let znew_ring_path =
-  make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"])
+  make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"])
 let zltac s =
   lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
 
 let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
-let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;;
+let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
 
 (* Ring theory *)
 
@@ -311,9 +321,9 @@ let _ = add_map "ring"
     (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
     pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
-    pol_cst "Pphi_pow", 
+    pol_cst "Pphi_pow",
           (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
-    (* PEeval: evaluate morphism and polynomial, protect ring 
+    (* PEeval: evaluate morphism and polynomial, protect ring
        operations and make recursive call on the var map *)
     pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
 
@@ -342,18 +352,11 @@ let from_name = ref Spmap.empty
 
 let ring_for_carrier r = Cmap.find r !from_carrier
 let ring_for_relation rel = Cmap.find rel !from_relation
-let ring_lookup_by_name ref =
-  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name
 
 
-let find_ring_structure env sigma l oname =
-  match oname, l with
-      Some rf, _ ->
-        (try ring_lookup_by_name rf
-        with Not_found ->
-          errorlabstrm "ring"
-            (str "found no ring named "++pr_reference rf))
-    | None, t::cl' ->
+let find_ring_structure env sigma l =
+  match l with
+    | t::cl' ->
         let ty = Retyping.get_type_of env sigma t in
         let check c =
           let ty' = Retyping.get_type_of env sigma c in
@@ -367,7 +370,7 @@ let find_ring_structure env sigma l oname =
           errorlabstrm "ring"
             (str"cannot find a declared ring structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
-    | None, [] -> assert false
+    | [] -> assert false
 (*
         let (req,_,_) = dest_rel cl in
         (try ring_for_relation req
@@ -376,7 +379,7 @@ let find_ring_structure env sigma l oname =
             (str"cannot find a declared ring structure for equality"++
              spc()++str"\""++pr_constr req++str"\"")) *)
 
-let _ = 
+let _ =
   Summary.declare_summary "tactic-new-ring-table"
     { Summary.freeze_function =
         (fun () -> !from_carrier,!from_relation,!from_name);
@@ -386,9 +389,7 @@ let _ =
       Summary.init_function =
         (fun () ->
           from_carrier := Cmap.empty; from_relation := Cmap.empty;
-          from_name := Spmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+          from_name := Spmap.empty) }
 
 let add_entry (sp,_kn) e =
 (*  let _ = ty e.ring_lemma1 in
@@ -396,11 +397,11 @@ let add_entry (sp,_kn) e =
 *)
   from_carrier := Cmap.add e.ring_carrier e !from_carrier;
   from_relation := Cmap.add e.ring_req e !from_relation;
-  from_name := Spmap.add sp e !from_name 
+  from_name := Spmap.add sp e !from_name
 
 
-let subst_th (_,subst,th) = 
-  let c' = subst_mps subst th.ring_carrier in                   
+let subst_th (subst,th) =
+  let c' = subst_mps subst th.ring_carrier in
   let eq' = subst_mps subst th.ring_req in
   let set' = subst_mps subst th.ring_setoid in
   let ext' = subst_mps subst th.ring_ext in
@@ -439,26 +440,24 @@ let subst_th (_,subst,th) =
       ring_post_tac = posttac' }
 
 
-let (theory_to_obj, obj_to_theory) = 
-  let cache_th (name,th) = add_entry name th
-  and export_th x = Some x in
+let (theory_to_obj, obj_to_theory) =
+  let cache_th (name,th) = add_entry name th in
   declare_object
     {(default_object "tactic-new-ring-theory") with
       open_function = (fun i o -> if i=1 then cache_th o);
       cache_function = cache_th;
       subst_function = subst_th;
-      classify_function = (fun (_,x) -> Substitute x);
-      export_function = export_th }
+      classify_function = (fun x -> Substitute x)}
 
 
 let setoid_of_relation env a r =
   let evm = Evd.empty in
-  try 
+  try
     lapp coq_mk_Setoid
-      [|a ; r ; 
-	Class_tactics.get_reflexive_proof env evm a r ; 
-	Class_tactics.get_symmetric_proof env evm a r ; 
-	Class_tactics.get_transitive_proof env evm a r |]
+      [|a ; r ;
+	Rewrite.get_reflexive_proof env evm a r ;
+	Rewrite.get_symmetric_proof env evm a r ;
+	Rewrite.get_transitive_proof env evm a r |]
   with Not_found ->
     error "cannot find setoid relation"
 
@@ -532,27 +531,27 @@ let ring_equality (r,add,mul,opp,req) =
 	  (setoid,op_morph)
     | _ ->
 	let setoid = setoid_of_relation (Global.env ()) r req in
-	let signature = [Some (r,req);Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in
+	let signature = [Some (r,req);Some (r,req)],Some(r,req) in
 	let add_m, add_m_lem =
-	  try Class_tactics.default_morphism signature add
+	  try Rewrite.default_morphism signature add
           with Not_found ->
             error "ring addition should be declared as a morphism" in
 	let mul_m, mul_m_lem =
-          try Class_tactics.default_morphism signature mul
+          try Rewrite.default_morphism signature mul
           with Not_found ->
             error "ring multiplication should be declared as a morphism" in
         let op_morph =
           match opp with
             | Some opp ->
 		(let opp_m,opp_m_lem =
-		  try Class_tactics.default_morphism ([Some(r,req)],Some(Lazy.lazy_from_val (r,req))) opp
+		  try Rewrite.default_morphism ([Some(r,req)],Some(r,req)) opp
 		  with Not_found ->
                     error "ring opposite should be declared as a morphism" in
 		let op_morph =
 		  op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
-		  Flags.if_verbose 
+		  Flags.if_verbose
 		    msgnl
-		    (str"Using setoid \""++pr_constr req++str"\""++spc()++  
+		    (str"Using setoid \""++pr_constr req++str"\""++spc()++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\","++spc()++ str"\""++pr_constr mul_m_lem++
 			str"\""++spc()++str"and \""++pr_constr opp_m_lem++
@@ -561,13 +560,13 @@ let ring_equality (r,add,mul,opp,req) =
             | None ->
 		(Flags.if_verbose
 		    msgnl
-		    (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++  
+		    (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\""++spc()++str"and \""++
 			pr_constr mul_m_lem++str"\"");
 		 op_smorph r add mul req add_m_lem mul_m_lem) in
           (setoid,op_morph)
-	    
+
 let build_setoid_params r add mul opp req eqth =
   match eqth with
       Some th -> th
@@ -622,7 +621,7 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
   match cst_tac with
       Some (CstTac t) -> Tacinterp.glob_tactic t
     | Some (Closed lc) ->
-        closed_term_ast (List.map Syntax_def.global_with_alias lc)
+        closed_term_ast (List.map Smartlocate.global_with_alias lc)
     | None ->
         (match rk, opp, kind with
             Abstract, None, _ ->
@@ -651,30 +650,30 @@ let make_hyp env c =
 
 let make_hyp_list env lH =
   let carrier = Lazy.force coq_hypo in
-  List.fold_right 
+  List.fold_right
     (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
     (lapp coq_nil [|carrier|])
 
-let interp_power env pow =  
+let interp_power env pow =
   let carrier = Lazy.force coq_hypo in
   match pow with
-  | None -> 
+  | None ->
       let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
       (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
-  | Some (tac, spec) -> 
-      let tac = 
+  | Some (tac, spec) ->
+      let tac =
         match tac with
         | CstTac t -> Tacinterp.glob_tactic t
         | Closed lc ->
-            closed_term_ast (List.map Syntax_def.global_with_alias lc) in
+            closed_term_ast (List.map Smartlocate.global_with_alias lc) in
       let spec = make_hyp env (ic spec) in
       (tac, lapp coq_Some [|carrier; spec|])
 
 let interp_sign env sign =
   let carrier = Lazy.force coq_hypo in
   match sign with
-  | None -> lapp coq_None [|carrier|] 
-  | Some spec -> 
+  | None -> lapp coq_None [|carrier|]
+  | Some spec ->
       let spec = make_hyp env (ic spec) in
       lapp coq_Some [|carrier;spec|]
        (* Same remark on ill-typed terms ... *)
@@ -682,8 +681,8 @@ let interp_sign env sign =
 let interp_div env div =
   let carrier = Lazy.force coq_hypo in
   match div with
-  | None -> lapp coq_None [|carrier|] 
-  | Some spec -> 
+  | None -> lapp coq_None [|carrier|]
+  | Some spec ->
       let spec = make_hyp env (ic spec) in
       lapp coq_Some [|carrier;spec|]
        (* Same remark on ill-typed terms ... *)
@@ -694,12 +693,12 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
   let sigma = Evd.empty in
   let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
   let (sth,ext) = build_setoid_params r add mul opp req eqth in
-  let (pow_tac, pspec) = interp_power env power in 
+  let (pow_tac, pspec) = interp_power env power in
   let sspec = interp_sign env sign in
   let dspec = interp_div env div in
   let rk = reflect_coeff morphth in
   let params =
-    exec_tactic env 5 (zltac "ring_lemmas") 
+    exec_tactic env 5 (zltac "ring_lemmas")
       (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
   let lemma1 = constr_of params.(3) in
   let lemma2 = constr_of params.(4) in
@@ -756,7 +755,7 @@ VERNAC ARGUMENT EXTEND ring_mod
   | [ "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) ]   
+           [ 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 ]
@@ -779,7 +778,7 @@ let process_ring_mods l =
     | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
     | Pre_tac t -> set_once "preprocess tactic" pre t
     | Post_tac t -> set_once "postprocess tactic" post t
-    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) 
+    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)
     | Pow_spec(t,spec) -> set_once "power" power (t,spec)
     | Sign_spec t -> set_once "sign" sign t
     | Div_spec t -> set_once "div" div t) l;
@@ -796,7 +795,7 @@ END
 (* The tactics consist then only in a lookup in the ring database and
    call the appropriate ltac. *)
 
-let make_args_list rl t = 
+let make_args_list rl t =
   match rl with
   | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
   | _ -> rl
@@ -806,14 +805,7 @@ let make_term_list carrier rl =
     (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
     (lapp coq_nil [|carrier|])
 
-
-let ring_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_ring_structure env sigma rl None in
-  let rl = carg (make_term_list e.ring_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
+let ltac_ring_structure e =
   let req = carg e.ring_req in
   let sth = carg e.ring_setoid in
   let ext = carg e.ring_ext in
@@ -825,12 +817,18 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl =
   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
-  Tacinterp.eval_tactic
-    (TacLetIn
-      (false,[(dummy_loc,id_of_string"f"),Tacexp f],
-       ltac_lcall "f"
-         [req;sth;ext;morph;th;cst_tac;pow_tac;
-          lemma1;lemma2;pretac;posttac;lH;rl])) gl
+  [req;sth;ext;morph;th;cst_tac;pow_tac;
+   lemma1;lemma2;pretac;posttac]
+
+let ring_lookup (f:glob_tactic_expr) lH rl t gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let rl = make_args_list rl t in
+  let e = find_ring_structure env sigma rl in
+  let rl = carg (make_term_list e.ring_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
+  let ring = ltac_ring_structure e in
+  ltac_apply f (ring@[lH;rl]) gl
 
 TACTIC EXTEND ring_lookup
 | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
@@ -838,11 +836,11 @@ TACTIC EXTEND ring_lookup
 END
 
 
- 
+
 (***********************************************************************)
 
 let new_field_path =
-  make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"])
+  make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"])
 
 let field_ltac s =
   lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
@@ -861,12 +859,12 @@ let _ = add_map "field"
    (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
     pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
-    pol_cst "Pphi_pow", 
+    pol_cst "Pphi_pow",
           (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
-    (* PEeval: evaluate morphism and polynomial, protect ring 
+    (* PEeval: evaluate morphism and polynomial, protect ring
        operations and make recursive call on the var map *)
     pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
-    (* FEeval: evaluate morphism, protect field 
+    (* FEeval: evaluate morphism, protect field
        operations and make recursive call on the var map *)
     my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
 
@@ -880,6 +878,11 @@ let _ = add_map "field_cond"
 (*                       (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
 
 
+let _ = Redexpr.declare_reduction "simpl_field_expr"
+  (protect_red "field")
+
+
+
 let afield_theory = my_constant "almost_field_theory"
 let field_theory = my_constant "field_theory"
 let sfield_theory = my_constant "semi_field_theory"
@@ -927,20 +930,11 @@ let field_from_name = ref Spmap.empty
 
 let field_for_carrier r = Cmap.find r !field_from_carrier
 let field_for_relation rel = Cmap.find rel !field_from_relation
-let field_lookup_by_name ref =
-  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref)))
-    !field_from_name
-
 
-let find_field_structure env sigma l oname =
+let find_field_structure env sigma l =
   check_required_library (cdir@["Field_tac"]);
-  match oname, l with
-      Some rf, _ ->
-        (try field_lookup_by_name rf
-        with Not_found ->
-          errorlabstrm "field"
-            (str "found no field named "++pr_reference rf))
-    | None, t::cl' ->
+  match l with
+    | t::cl' ->
         let ty = Retyping.get_type_of env sigma t in
         let check c =
           let ty' = Retyping.get_type_of env sigma c in
@@ -954,7 +948,7 @@ let find_field_structure env sigma l oname =
           errorlabstrm "field"
             (str"cannot find a declared field structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
-    | None, [] -> assert false
+    | [] -> assert false
 (*        let (req,_,_) = dest_rel cl in
         (try field_for_relation req
         with Not_found ->
@@ -962,7 +956,7 @@ let find_field_structure env sigma l oname =
             (str"cannot find a declared field structure for equality"++
              spc()++str"\""++pr_constr req++str"\"")) *)
 
-let _ = 
+let _ =
   Summary.declare_summary "tactic-new-field-table"
     { Summary.freeze_function =
         (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
@@ -973,9 +967,7 @@ let _ =
       Summary.init_function =
         (fun () ->
           field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
-          field_from_name := Spmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+          field_from_name := Spmap.empty) }
 
 let add_field_entry (sp,_kn) e =
 (*
@@ -986,10 +978,10 @@ let add_field_entry (sp,_kn) e =
 *)
   field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
   field_from_relation := Cmap.add e.field_req e !field_from_relation;
-  field_from_name := Spmap.add sp e !field_from_name 
+  field_from_name := Spmap.add sp e !field_from_name
 
-let subst_th (_,subst,th) = 
-  let c' = subst_mps subst th.field_carrier in                   
+let subst_th (subst,th) =
+  let c' = subst_mps subst th.field_carrier in
   let eq' = subst_mps subst th.field_req in
   let thm1' = subst_mps subst th.field_ok in
   let thm2' = subst_mps subst th.field_simpl_eq_ok in
@@ -1024,16 +1016,14 @@ let subst_th (_,subst,th) =
       field_pre_tac = pretac';
       field_post_tac = posttac' }
 
-let (ftheory_to_obj, obj_to_ftheory) = 
-  let cache_th (name,th) = add_field_entry name th
-  and export_th x = Some x in
+let (ftheory_to_obj, obj_to_ftheory) =
+  let cache_th (name,th) = add_field_entry name th in
   declare_object
     {(default_object "tactic-new-field-theory") with
       open_function = (fun i o -> if i=1 then cache_th o);
       cache_function = cache_th;
       subst_function = subst_th;
-      classify_function = (fun (_,x) -> Substitute x);
-      export_function = export_th }
+      classify_function = (fun x -> Substitute x) }
 
 let field_equality r inv req =
   match kind_of_term req with
@@ -1041,13 +1031,13 @@ let field_equality r inv req =
         mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
     | _ ->
 	let _setoid = setoid_of_relation (Global.env ()) r req in
-	let signature = [Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in
+	let signature = [Some (r,req)],Some(r,req) in
 	let inv_m, inv_m_lem =
-	  try Class_tactics.default_morphism signature inv
+	  try Rewrite.default_morphism signature inv
           with Not_found ->
             error "field inverse should be declared as a morphism" in
 	  inv_m_lem
-	    
+
 let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv =
   check_required_library (cdir@["Field_tac"]);
   let env = Global.env() in
@@ -1057,7 +1047,7 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi
   let (sth,ext) = build_setoid_params r add mul opp req eqth in
   let eqth = Some(sth,ext) in
   let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in
-  let (pow_tac, pspec) = interp_power env power in 
+  let (pow_tac, pspec) = interp_power env power in
   let sspec = interp_sign env sign in
   let dspec = interp_div env odiv in
   let inv_m = field_equality r inv req in
@@ -1118,7 +1108,7 @@ let process_field_mods l =
   let cst_tac = ref None in
   let pre = ref None in
   let post = ref None in
-  let inj = ref None in  
+  let inj = ref None in
   let sign = ref None in
   let power = ref None in
   let div = ref None in
@@ -1137,18 +1127,13 @@ let process_field_mods l =
   (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
 
 VERNAC COMMAND EXTEND AddSetoidField
-| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> 
+| [ "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]
 END
 
-let field_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_field_structure env sigma rl None in
-  let rl = carg (make_term_list e.field_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
+
+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
@@ -1159,14 +1144,21 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl =
   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
-  Tacinterp.eval_tactic
-    (TacLetIn
-      (false,[(dummy_loc,id_of_string"f"),Tacexp f],
-       ltac_lcall "f"
-        [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
-         field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl
+  [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
+   field_simpl_eq_in_ok;cond_ok;pretac;posttac]
+
+let field_lookup (f:glob_tactic_expr) lH rl t gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let rl = make_args_list rl t in
+  let e = find_field_structure env sigma rl in
+  let rl = carg (make_term_list e.field_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
+  let field = ltac_field_structure e in
+  ltac_apply f (field@[lH;rl]) gl
+
 
 TACTIC EXTEND field_lookup
-| [ "field_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> 
+| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
       [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ]
 END
diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib
new file mode 100644
index 00000000..a98392f1
--- /dev/null
+++ b/plugins/setoid_ring/newring_plugin.mllib
@@ -0,0 +1,2 @@
+Newring
+Newring_plugin_mod
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
new file mode 100644
index 00000000..6934375b
--- /dev/null
+++ b/plugins/setoid_ring/vo.itarget
@@ -0,0 +1,15 @@
+ArithRing.vo
+BinList.vo
+Field_tac.vo
+Field_theory.vo
+Field.vo
+InitialRing.vo
+NArithRing.vo
+RealField.vo
+Ring_base.vo
+Ring_equiv.vo
+Ring_polynom.vo
+Ring_tac.vo
+Ring_theory.vo
+Ring.vo
+ZArithRing.vo
diff --git a/contrib/subtac/eterm.ml b/plugins/subtac/eterm.ml
index 00a69bba..4b95df19 100644
--- a/contrib/subtac/eterm.ml
+++ b/plugins/subtac/eterm.ml
@@ -1,4 +1,4 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (**
    - Get types of existentials ;
    - Flatten dependency tree (prefix order) ;
@@ -16,11 +16,11 @@ open Util
 open Subtac_utils
 open Proof_type
 
-let trace s = 
+let trace s =
   if !Flags.debug then (msgnl s; msgerr s)
   else ()
 
-let succfix (depth, fixrels) = 
+let succfix (depth, fixrels) =
   (succ depth, List.map succ fixrels)
 
 type oblinfo =
@@ -30,115 +30,112 @@ type oblinfo =
     ev_chop: int option;
     ev_loc: Util.loc;
     ev_typ: types;
-    ev_tac: Tacexpr.raw_tactic_expr option;
+    ev_tac: tactic option;
     ev_deps: Intset.t }
-    
-(** Substitute evar references in t using De Bruijn indices, 
+
+(** Substitute evar references in t using De Bruijn indices,
   where n binders were passed through. *)
 
-let subst_evar_constr evs n t = 
+let subst_evar_constr evs n idf t = 
   let seen = ref Intset.empty in
   let transparent = ref Idset.empty in
   let evar_info id = List.assoc id evs in
   let rec substrec (depth, fixrels) c = match kind_of_term c with
     | Evar (k, args) ->
-	let { ev_name = (id, idstr) ; 
+	let { ev_name = (id, idstr) ;
 	      ev_hyps = hyps ; ev_chop = chop } =
 	  try evar_info k
-	  with Not_found -> 
+	  with Not_found ->
 	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
 	in
         seen := Intset.add id !seen;
-	  (* Evar arguments are created in inverse order, 
+	  (* Evar arguments are created in inverse order,
 	     and we must not apply to defined ones (i.e. LetIn's)
 	  *)
-	let args = 
-	  let n = match chop with None -> 0 | Some c -> c in 
+	let args =
+	  let n = match chop with None -> 0 | Some c -> c in
 	  let (l, r) = list_chop n (List.rev (Array.to_list args)) in
 	    List.rev r
 	in
 	let args =
 	  let rec aux hyps args acc =
 	     match hyps, args with
-		 ((_, None, _) :: tlh), (c :: tla) -> 
+		 ((_, None, _) :: tlh), (c :: tla) ->
 		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
 	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
 		   aux tlh tla acc
 	       | [], [] -> acc
 	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
-	  in aux hyps args [] 
+	  in aux hyps args []
 	in
 	  if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then
 	    transparent := Idset.add idstr !transparent;
-	  mkApp (mkVar idstr, Array.of_list args)
+	  mkApp (idf idstr, Array.of_list args)
     | Fix _ ->
 	map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
     | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
-  in 
+  in
   let t' = substrec (0, []) t in
     t', !seen, !transparent
 
-      
-(** Substitute variable references in t using De Bruijn indices, 
+
+(** Substitute variable references in t using De Bruijn indices,
   where n binders were passed through. *)
-let subst_vars acc n t = 
+let subst_vars acc n t =
   let var_index id = Util.list_index id acc in
   let rec substrec depth c = match kind_of_term c with
     | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
     | _ -> map_constr_with_binders succ substrec depth c
-  in 
+  in
     substrec 0 t
 
 (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
     to a product : forall H1 : t1, ..., forall Hn : tn, concl.
     Changes evars and hypothesis references to variable references.
-    A little optimization: don't include unnecessary let-ins and their dependencies.
-*) 
+*)
 let etype_of_evar evs hyps concl =
   let rec aux acc n = function
       (id, copt, t) :: tl ->
-	let t', s, trans = subst_evar_constr evs n t in
+	let t', s, trans = subst_evar_constr evs n mkVar t in
 	let t'' = subst_vars acc 0 t' in
 	let rest, s', trans' = aux (id :: acc) (succ n) tl in
 	let s' = Intset.union s s' in
 	let trans' = Idset.union trans trans' in
 	  (match copt with
 	      Some c -> 
-(* 		if noccurn 1 rest then lift (-1) rest, s', trans' *)
-(* 		else *)
-		  let c', s'', trans'' = subst_evar_constr evs n c in
-		  let c' = subst_vars acc 0 c' in
-		    mkNamedProd_or_LetIn (id, Some c', t'') rest, 
-		Intset.union s'' s', 
+		let c', s'', trans'' = subst_evar_constr evs n mkVar c in
+		let c' = subst_vars acc 0 c' in
+		  mkNamedProd_or_LetIn (id, Some c', t'') rest,
+		Intset.union s'' s',
 		Idset.union trans'' trans'
-	    | None -> 
+	    | None ->
 		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
     | [] ->
-	let t', s, trans = subst_evar_constr evs n concl in
+	let t', s, trans = subst_evar_constr evs n mkVar concl in
 	  subst_vars acc 0 t', s, trans
   in aux [] 0 (rev hyps)
 
 
 open Tacticals
-    
-let trunc_named_context n ctx = 
+
+let trunc_named_context n ctx =
   let len = List.length ctx in
     list_firstn (len - n) ctx
-  
-let rec chop_product n t = 
+
+let rec chop_product n t =
   if n = 0 then Some t
-  else 
+  else
     match kind_of_term t with
       | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
       | _ -> None
 
 let evar_dependencies evm ev =
-  let one_step deps = 
-    Intset.fold (fun ev s -> 
+  let one_step deps =
+    Intset.fold (fun ev s ->
       let evi = Evd.find evm ev in
 	Intset.union (Evarutil.evars_of_evar_info evi) s)
       deps deps
-  in 
+  in
   let rec aux deps =
     let deps' = one_step deps in
       if Intset.equal deps deps' then deps
@@ -146,11 +143,24 @@ let evar_dependencies evm ev =
   in aux (Intset.singleton ev)
 
 let sort_dependencies evl =
-  List.sort (fun (_, _, deps) (_, _, deps') -> 
-    if Intset.subset deps deps' then (* deps' depends on deps *) -1
-    else if Intset.subset deps' deps then 1
-    else Intset.compare deps deps')
+  List.stable_sort
+    (fun (id, ev, deps) (id', ev', deps') ->
+      if id = id' then 0
+      else if Intset.mem id deps' then -1
+      else if Intset.mem id' deps then 1
+      else Pervasives.compare id id')
     evl
+      
+let map_evar_body f = function
+  | Evar_empty -> Evar_empty
+  | Evar_defined c -> Evar_defined (f c)
+
+open Environ
+      
+let map_evar_info f evi =
+  { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps));
+    evar_concl = f evi.evar_concl;
+    evar_body = map_evar_body f evi.evar_body }
     
 let eterm_obligations env name isevars evm fs ?status t ty = 
   (* 'Serialize' the evars *)
@@ -160,53 +170,54 @@ let eterm_obligations env name isevars evm fs ?status t ty =
   let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
   let sevl = sort_dependencies evl in
   let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
-  let evn = 
+  let evn =
     let i = ref (-1) in
-      List.rev_map (fun (id, ev) -> incr i; 
+      List.rev_map (fun (id, ev) -> incr i;
 		      (id, (!i, id_of_string
 			      (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))),
 		       ev)) evl
   in
-  let evts = 
+  let evts =
     (* Remove existential variables in types and build the corresponding products *)
-    fold_right 
+    fold_right
       (fun (id, (n, nstr), ev) l ->
 	 let hyps = Evd.evar_filtered_context ev in
 	 let hyps = trunc_named_context nc_len hyps in
 	 let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
-	 let evtyp, hyps, chop = 
+	 let evtyp, hyps, chop =
 	   match chop_product fs evtyp with
 	   | Some t -> t, trunc_named_context fs hyps, fs
 	   | None -> evtyp, hyps, 0
 	 in
 	 let loc, k = evar_source id isevars in
 	 let status = match k with QuestionMark o -> Some o | _ -> status in
-	 let status, chop = match status with 
+	 let status, chop = match status with
 	   | Some (Define true as stat) ->
-	       if chop <> fs then Define false, None 
+	       if chop <> fs then Define false, None
 	       else stat, Some chop
 	   | Some s -> s, None
 	   | None -> Define true, None
 	 in
-	 let tac = match ev.evar_extra with 
-	   | Some t -> 
-	       if Dyn.tag t = "tactic" then 
-		 Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t))
+	 let tac = match ev.evar_extra with
+	   | Some t ->
+	       if Dyn.tag t = "tactic" then
+		 Some (Tacinterp.interp 
+			  (Tacinterp.globTacticIn (Tacinterp.tactic_out t)))
 	       else None
 	   | None -> None
 	 in
 	 let info = { ev_name = (n, nstr);
 		      ev_hyps = hyps; ev_status = status; ev_chop = chop;
 		      ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
-	 in (id, info) :: l) 
+	 in (id, info) :: l)
       evn []
-  in 
+  in
   let t', _, transparent = (* Substitute evar refs in the term by variables *)
-    subst_evar_constr evts 0 t 
+    subst_evar_constr evts 0 mkVar t 
   in
-  let ty, _, _ = subst_evar_constr evts 0 ty in
+  let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
   let evars = 
-    List.map (fun (_, info) ->
+    List.map (fun (ev, info) ->
       let { ev_name = (_, name); ev_status = status;
 	    ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
       in
@@ -214,8 +225,9 @@ let eterm_obligations env name isevars evm fs ?status t ty =
 	| Define true when Idset.mem name transparent -> Define false
 	| _ -> status
       in name, typ, loc, status, deps, tac) evts
-  in Array.of_list (List.rev evars), t', ty
+  in
+  let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
+  let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
+    Array.of_list (List.rev evars), (evnames, evmap), t', ty
 
 let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
-
-let etermtac (evm, t) = assert(false) (*eterm evm t None *)
diff --git a/contrib/subtac/eterm.mli b/plugins/subtac/eterm.mli
index 19e8ffe8..406f9433 100644
--- a/contrib/subtac/eterm.mli
+++ b/plugins/subtac/eterm.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: eterm.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 open Environ
 open Tacmach
 open Term
@@ -19,14 +19,16 @@ val mkMetas : int -> constr list
 
 val evar_dependencies : evar_map -> int -> Intset.t
 val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list
-  
+
 (* env, id, evars, number of function prototypes to try to clear from
    evars contexts, object and type *)
-val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> 
+val eterm_obligations : env -> identifier -> evar_map -> evar_map -> int ->
   ?status:obligation_definition_status -> constr -> types -> 
   (identifier * types * loc * obligation_definition_status * Intset.t * 
-      Tacexpr.raw_tactic_expr option) array * constr * types
-    (* Obl. name, type as product, location of the original evar, associated tactic,
+      tactic option) array
+    (* Existential key, obl. name, type as product, location of the original evar, associated tactic,
        status and dependencies as indexes into the array *)
-
-val etermtac : open_constr -> tactic
+  * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types
+    (* Translations from existential identifiers to obligation identifiers 
+       and for terms with existentials to closed terms, given a 
+       translation from obligation identifiers to constrs, new term, new type *)
diff --git a/contrib/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
index 7194d435..113b1680 100644
--- a/contrib/subtac/g_subtac.ml4
+++ b/plugins/subtac/g_subtac.ml4
@@ -7,14 +7,14 @@
 (************************************************************************)
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
-(*i camlp4use: "pa_extend.cmo" i*) 
+(*i camlp4use: "pa_extend.cmo" i*)
 
 
 (*
   Syntax for the subtac terms and types.
   Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
 
-(* $Id: g_subtac.ml4 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 
 open Flags
@@ -41,11 +41,11 @@ struct
 		(* types *)
   let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc"
 
-  let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt"
+  let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac"
 end
 
 open Rawterm
-open SubtacGram 
+open SubtacGram
 open Util
 open Pcoq
 open Prim
@@ -53,17 +53,17 @@ open Constr
 let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
 
 GEXTEND Gram
-  GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt;
- 
+  GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_withtac;
+
   subtac_gallina_loc:
     [ [ g = Vernac.gallina -> loc, g
     | g = Vernac.gallina_ext -> loc, g ] ]
     ;
 
-  subtac_nameopt:
-    [ [ "ofb"; id=Prim.ident -> Some (id) 
+  subtac_withtac:
+    [ [ "with"; t = Tactic.tactic -> Some t
       | -> None ] ]
-    ;
+  ;
 
   Constr.binder_let:
     [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
@@ -90,59 +90,80 @@ let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
   (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
   Genarg.create_arg "subtac_gallina_loc"
 
-type 'a nameopt_argtype = (identifier option, 'a) Genarg.abstract_argument_type
+type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
 
-let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype),
-  (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype),
-  (rawwit_subtac_nameopt : Genarg.rlevel nameopt_argtype) =
-  Genarg.create_arg "subtac_nameopt"
+let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
+  (globwit_subtac_withtac : Genarg.glevel withtac_argtype),
+  (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
+  Genarg.create_arg "subtac_withtac"
 
 VERNAC COMMAND EXTEND Subtac
 [ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
   END
 
+let try_catch_exn f e =
+  try f e
+  with exn -> errorlabstrm "Program" (Cerrors.explain_exn exn)
+
+let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e
+let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e
+let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e
+let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e
+let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e
+let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e
+
 VERNAC COMMAND EXTEND Subtac_Obligations
-| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, Some t) ]
-| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, None) ]
-| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, None, Some t) ]      
-| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None, None) ]
-| [ "Next" "Obligation" "of" ident(name) ] -> [ Subtac_obligations.next_obligation (Some name) ]
-| [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ]
+| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, Some name, Some t) tac ]
+| [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, Some name, None) tac ]
+| [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, None, Some t) tac ]
+| [ "Obligation" integer(num) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, None, None) tac ]
+| [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] -> 
+    [ next_obligation (Some name) tac ]
+| [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ]
 END
 
 VERNAC COMMAND EXTEND Subtac_Solve_Obligation
-| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligation num None (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] ->
+    [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] ->
+    [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
       END
 
 VERNAC COMMAND EXTEND Subtac_Solve_Obligations
-| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligations None (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" ] -> 
-    [ Subtac_obligations.try_solve_obligations None None ]
+| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] ->
+    [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" "using" tactic(t) ] ->
+    [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" ] ->
+    [ try_solve_obligations None None ]
       END
 
 VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations
-| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> 
-    [ Subtac_obligations.solve_all_obligations (Some (Tacinterp.interp t)) ]
-| [ "Solve" "All" "Obligations" ] -> 
-    [ Subtac_obligations.solve_all_obligations None ]
+| [ "Solve" "All" "Obligations" "using" tactic(t) ] ->
+    [ solve_all_obligations (Some (Tacinterp.interp t)) ]
+| [ "Solve" "All" "Obligations" ] ->
+    [ solve_all_obligations None ]
       END
 
 VERNAC COMMAND EXTEND Subtac_Admit_Obligations
-| [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] 
-| [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] 
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
+| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
     END
 
 VERNAC COMMAND EXTEND Subtac_Set_Solver
-| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ 
-    Coqlib.check_required_library ["Coq";"Program";"Tactics"];
-    Tacinterp.add_tacdef false 
-      [(Qualid (dummy_loc, qualid_of_string "Coq.Program.Tactics.obligation_tactic"), true, t)] ]
+| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
+    Subtac_obligations.set_default_tactic 
+      (Vernacexpr.use_section_locality ())
+      (Tacinterp.glob_tactic t) ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Solver
+| [ "Show" "Obligation" "Tactic" ] -> [
+    Pp.msgnl (Pptactic.pr_glob_tactic (Global.env ()) (Subtac_obligations.default_tactic_expr ())) ]
 END
 
 VERNAC COMMAND EXTEND Subtac_Show_Obligations
diff --git a/contrib/subtac/subtac.ml b/plugins/subtac/subtac.ml
index c0b64379..0eba0f63 100644
--- a/contrib/subtac/subtac.ml
+++ b/plugins/subtac/subtac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 12194 2009-06-17 16:38:09Z msozeau $ *)
+(* $Id$ *)
 
 open Global
 open Pp
@@ -16,6 +16,7 @@ open Sign
 open Evd
 open Term
 open Termops
+open Namegen
 open Reductionops
 open Environ
 open Type_errors
@@ -23,13 +24,12 @@ open Typeops
 open Libnames
 open Classops
 open List
-open Recordops 
+open Recordops
 open Evarutil
 open Pretype_errors
 open Rawterm
 open Evarconv
 open Pattern
-open Dyn
 open Vernacexpr
 
 open Subtac_coercion
@@ -50,14 +50,14 @@ open Tacinterp
 open Tacexpr
 
 let solve_tccs_in_type env id isevars evm c typ =
-  if not (evm = Evd.empty) then 
+  if not (evm = Evd.empty) then
     let stmt_id = Nameops.add_suffix id "_stmt" in
-    let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in
-      match Subtac_obligations.add_definition stmt_id c' typ obls with
-      Subtac_obligations.Defined cst -> constant_value (Global.env()) 
-	(match cst with ConstRef kn -> kn | _ -> assert false)
-      | _ -> 
-	  errorlabstrm "start_proof" 
+    let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in
+      match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with
+      | Subtac_obligations.Defined cst -> constant_value (Global.env()) 
+	  (match cst with ConstRef kn -> kn | _ -> assert false)
+      | _ ->
+	  errorlabstrm "start_proof"
 	    (str "The statement obligations could not be resolved automatically, " ++ spc () ++
 		str "write a statement definition first.")
   else
@@ -72,34 +72,36 @@ let start_proof_com env isevars sopt kind (bl,t) hook =
           user_err_loc (loc,"start_proof",pr_id id ++ str " already exists");
         id
     | None ->
-	next_global_ident_away false (id_of_string "Unnamed_thm")
+	next_global_ident_away (id_of_string "Unnamed_thm")
  	  (Pfedit.get_all_proof_names ())
   in
-  let evm, c, typ, _imps = 
-    Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None 
+  let evm, c, typ, imps =
+    Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr t bl) None
   in
   let c = solve_tccs_in_type env id isevars evm c typ in
-    Command.start_proof id kind c hook	
-      
+    Lemmas.start_proof id kind c (fun loc gr ->
+      Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true imps;
+      hook loc gr)
+
 let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
 
 let start_proof_and_print env isevars idopt k t hook =
   start_proof_com env isevars idopt k t hook;
   print_subgoals ()
-	  
+
 let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
-  
+
 let assumption_message id =
   Flags.if_verbose message ((string_of_id id) ^ " is assumed")
 
-let declare_assumption env isevars idl is_coe k bl c nl =
+let declare_assumptions env isevars idl is_coe k bl c nl =
   if not (Pfedit.refining ()) then
     let id = snd (List.hd idl) in
-    let evm, c, typ, imps = 
-      Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None 
+    let evm, c, typ, imps =
+      Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr c bl) None
     in
     let c = solve_tccs_in_type env id isevars evm c typ in
-      List.iter (Command.declare_one_assumption is_coe k c imps false [] nl) idl
+      List.iter (Command.declare_assumption is_coe k c imps false nl) idl
   else
     errorlabstrm "Command.Assumption"
 	(str "Cannot declare an assumption while in proof editing mode.")
@@ -113,17 +115,17 @@ let dump_variable lid = ()
 
 let vernac_assumption env isevars kind l nl =
   let global = fst kind = Global in
-    List.iter (fun (is_coe,(idl,c)) -> 
+    List.iter (fun (is_coe,(idl,c)) ->
       if Dumpglob.dump () then
-	List.iter (fun lid -> 
+	List.iter (fun lid ->
 	  if global then Dumpglob.dump_definition lid (not global) "ax"
 	  else dump_variable lid) idl;
-      declare_assumption env isevars idl is_coe kind [] c nl) l
+      declare_assumptions env isevars idl is_coe kind [] c nl) l
 
 let check_fresh (loc,id) =
   if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
     user_err_loc (loc,"",pr_id id ++ str " already exists")
-      
+
 let subtac (loc, command) =
   check_required_library ["Coq";"Init";"Datatypes"];
   check_required_library ["Coq";"Init";"Specif"];
@@ -131,26 +133,28 @@ let subtac (loc, command) =
   let isevars = ref (create_evar_defs Evd.empty) in
   try
   match command with
-  | VernacDefinition (defkind, (_, id as lid), expr, hook) -> 
+  | VernacDefinition (defkind, (_, id as lid), expr, hook) ->
       check_fresh lid;
       Dumpglob.dump_definition lid false "def";
       (match expr with
-      | ProveBody (bl, t) -> 
+      | ProveBody (bl, t) ->
 	  if Lib.is_modtype () then
 	    errorlabstrm "Subtac_command.StartProof"
 	      (str "Proof editing mode not supported in module types");
-	  start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) 
+	  start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t)
 	    (fun _ _ -> ())
-      | DefineBody (bl, _, c, tycon) -> 
+      | DefineBody (bl, _, c, tycon) ->
 	  ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon))
-  | VernacFixpoint (l, b) -> 
-      List.iter (fun ((lid, _, _, _, _), _) -> 
+  | VernacFixpoint (l, b) ->
+      List.iter (fun ((lid, _, _, _, _), _) ->
 	check_fresh lid;
 	Dumpglob.dump_definition lid false "fix") l;
       let _ = trace (str "Building fixpoint") in
 	ignore(Subtac_command.build_recursive l b)
-	  
-  | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) ->
+
+  | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) ->
+      if guard <> None then 
+        error "Do not support building theorems as a fixpoint.";
       Dumpglob.dump_definition id false "prf";
       if not(Pfedit.refining ()) then
 	if lettop then
@@ -161,30 +165,32 @@ let subtac (loc, command) =
 	  (str "Proof editing mode not supported in module types");
       check_fresh id;
       start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
-	
-  | VernacAssumption (stre,nl,l) -> 
+
+  | VernacAssumption (stre,nl,l) ->
       vernac_assumption env isevars stre l nl
-	
-  | VernacInstance (glob, sup, is, props, pri) ->
+
+  | VernacInstance (abst, glob, sup, is, props, pri) ->
       dump_constraint "inst" is;
+      if abst then
+	error "Declare Instance not supported here.";
       ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
-	
+
   | VernacCoFixpoint (l, b) ->
-      if Dumpglob.dump () then 
+      if Dumpglob.dump () then
 	List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l;
       ignore(Subtac_command.build_corecursive l b)
-	
-  (*| VernacEndProof e -> 
+
+  (*| VernacEndProof e ->
     subtac_end_proof e*)
 
   | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
-  with 
+  with
   | Typing_error e ->
       msg_warning (str "Type error in Program tactic:");
-      let cmds = 
+      let cmds =
 	(match e with
 	| NonFunctionalApp (loc, x, mux, e) ->
-	    str "non functional application of term " ++ 
+	    str "non functional application of term " ++
 	      e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
 	| NonSigma (loc, t) ->
 	    str "Term is not of Sigma type: " ++ t
@@ -195,10 +201,10 @@ let subtac (loc, command) =
 	    str "Term is ill-sorted:" ++ spc () ++ t
 	)
       in msg_warning cmds
-	
+
   | Subtyping_error e ->
       msg_warning (str "(Program tactic) Subtyping error:");
-      let cmds = 
+      let cmds =
 	match e with
 	| UncoercibleInferType (loc, x, y) ->
 	    str "Uncoercible terms:" ++ spc ()
@@ -215,15 +221,15 @@ let subtac (loc, command) =
   | Cases.PatternMatchingError (env, exn) as e ->
       debug 2 (Himsg.explain_pattern_matching_error env exn);
       raise e
-	
+
   | Type_errors.TypeError (env, exn) as e ->
       debug 2 (Himsg.explain_type_error env exn);
       raise e
-	
+
   | Pretype_errors.PretypeError (env, exn) as e ->
       debug 2 (Himsg.explain_pretype_error env exn);
       raise e
-	
+
   | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) |
      Stdpp.Exc_located (loc, e') as e) ->
       debug 2 (str "Parsing exception: ");
@@ -231,11 +237,14 @@ let subtac (loc, command) =
       | Type_errors.TypeError (env, exn) ->
 	  debug 2 (Himsg.explain_type_error env exn);
 	  raise e
-	    
+
       | Pretype_errors.PretypeError (env, exn) ->
 	  debug 2 (Himsg.explain_pretype_error env exn);
 	  raise e
 
-      | e'' -> raise e)
-	
-  | e -> raise e
+      | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
+	  raise e)
+
+  | e ->
+      msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
+      raise e
diff --git a/contrib/subtac/subtac.mli b/plugins/subtac/subtac.mli
index b51150aa..b51150aa 100644
--- a/contrib/subtac/subtac.mli
+++ b/plugins/subtac/subtac.mli
diff --git a/contrib/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
index bd06407f..e8f4f05f 100644
--- a/contrib/subtac/subtac_cases.ml
+++ b/plugins/subtac/subtac_cases.ml
@@ -1,4 +1,4 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_cases.ml 12194 2009-06-17 16:38:09Z msozeau $ *)
+(* $Id$ *)
 
 open Cases
 open Util
@@ -15,6 +15,7 @@ open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Declarations
 open Inductiveops
 open Environ
@@ -45,14 +46,11 @@ let mssg_may_need_inversion () =
 
 (* Utils *)
 let make_anonymous_patvars =
-  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) 
+  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous))
 
 (* Environment management *)
 let push_rels vars env = List.fold_right push_rel vars env
 
-let push_rel_defs =
-  List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e)
-
 (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
    over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
 
@@ -75,7 +73,7 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
 	| NonDepAlias ->
 	    if (not (dependent (mkRel 1) j.uj_type))
 	      or (* A leaf: *) isRel deppat
-	    then 
+	    then
 	      (* The body of pat is not needed to type j - see *)
 	      (* insert_aliases - and both deppat and nondeppat have the *)
 	      (* same type, then one can freely substitute one by the other *)
@@ -97,7 +95,7 @@ type rhs =
     }
 
 type equation =
-    { patterns     : cases_pattern list; 
+    { patterns     : cases_pattern list;
       rhs          : rhs;
       alias_stack  : name list;
       eqn_loc      : loc;
@@ -152,14 +150,12 @@ and pattern_continuation =
 
 let start_history n = Continuation (n, [], Top)
 
-let initial_history = function Continuation (_,[],Top) -> true | _ -> false
-
 let feed_history arg = function
   | Continuation (n, l, h) when n>=1 ->
       Continuation (n-1, arg :: l, h)
   | Continuation (n, _, _) ->
       anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
-  | Result _ -> 
+  | Result _ ->
       anomaly "Exhausted pattern history"
 
 (* This is for non exhaustive error message *)
@@ -190,7 +186,7 @@ let rec simplify_history = function
       let pat = match f with
 	| AliasConstructor pci ->
 	    PatCstr (dummy_loc,pci,pargs,Anonymous)
-	| AliasLeaf -> 
+	| AliasLeaf ->
 	    assert (l = []);
 	    PatVar (dummy_loc, Anonymous) in
       feed_history pat rh
@@ -208,7 +204,7 @@ let push_history_pattern n current cont =
 
   where tomatch is some sequence of "instructions" (t1  ... tn)
 
-  and mat is some matrix 
+  and mat is some matrix
    (p11 ... p1n -> rhs1)
    (    ...            )
    (pm1 ... pmn -> rhsm)
@@ -236,7 +232,7 @@ let push_history_pattern n current cont =
 *)
 type pattern_matching_problem =
     { env      : env;
-      isevars  : Evd.evar_defs ref;
+      isevars  : Evd.evar_map ref;
       pred     : predicate_signature option;
       tomatch  : tomatch_stack;
       history  : pattern_continuation;
@@ -268,7 +264,7 @@ let rec find_row_ind = function
 
 let inductive_template isevars env tmloc ind =
   let arsign = get_full_arity_sign env ind in
-  let hole_source = match tmloc with 
+  let hole_source = match tmloc with
     | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
     | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
    let (_,evarl,_) =
@@ -278,7 +274,7 @@ let inductive_template isevars env tmloc ind =
         | None ->
 	    let ty' = substl subst ty in
 	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
-	    (e::subst,e::evarl,n+1) 
+	    (e::subst,e::evarl,n+1)
 	| Some b ->
 	    (b::subst,evarl,n+1))
       arsign ([],[],1) in
@@ -296,13 +292,69 @@ let evd_comb2 f isevars x y =
   isevars := evd';
   y
 
+let context_of_arsign l =
+  let (x, _) = List.fold_right
+    (fun c (x, n) ->
+      (lift_rel_context n c @ x, List.length c + n))
+    l ([], 0)
+  in x
+
+(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
+
+let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
+  let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
+  let subst, len =
+    List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
+      let signlen = List.length sign in
+	match kind_of_term tm with
+	  | Rel n when dependent tm c
+		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
+	      ((n, len) :: subst, len - signlen)
+	  | Rel n when signlen > 1 (* The term is of a dependent type,
+				      maybe some variable in its type appears in the tycon. *) ->
+	      (match tmtype with
+	      | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
+	      | IsInd (_, IndType(indf,realargs)) ->
+		  let subst =
+		    if dependent tm c && List.for_all isRel realargs
+		    then (n, 1) :: subst else subst
+		  in
+		    List.fold_left
+		      (fun (subst, len) arg ->
+			match kind_of_term arg with
+			| Rel n when dependent arg c ->
+			    ((n, len) :: subst, pred len)
+			| _ -> (subst, pred len))
+		      (subst, len) realargs)
+	  | _ -> (subst, len - signlen))
+      ([], nar) tomatchs arsign
+  in
+  let rec predicate lift c =
+    match kind_of_term c with
+      | Rel n when n > lift ->
+	  (try
+	      (* Make the predicate dependent on the matched variable *)
+	      let idx = List.assoc (n - lift) subst in
+		mkRel (idx + lift)
+	    with Not_found ->
+	      (* A variable that is not matched, lift over the arsign. *)
+	      mkRel (n + nar))
+      | _ ->
+	  map_constr_with_binders succ predicate lift c
+  in
+    try
+      (* The tycon may be ill-typed after abstraction. *)
+      let pred = predicate 0 c in
+      let env' = push_rel_context (context_of_arsign arsign) env in
+	ignore(Typing.sort_of env' evm pred); pred
+    with _ -> lift nar c
 
 module Cases_F(Coercion : Coercion.S) : S = struct
 
 let inh_coerce_to_ind isevars env ty tyi =
   let expected_typ = inductive_template isevars env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour 
-        un inductif cela doit être égal *)
+     (* devrait être indifférent d'exiger leq ou pas puisque pour
+        un inductif cela doit être égal *)
   let _ = e_cumul env isevars expected_typ ty in ()
 
 let unify_tomatch_with_patterns isevars env loc typ pats =
@@ -310,7 +362,7 @@ let unify_tomatch_with_patterns isevars env loc typ pats =
     | None -> NotInd (None,typ)
     | Some (_,(ind,_)) ->
 	inh_coerce_to_ind isevars env typ ind;
-	try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+	try IsInd (typ,find_rectype env ( !isevars) typ)
 	with Not_found -> NotInd (None,typ)
 
 let find_tomatch_tycon isevars env loc = function
@@ -324,9 +376,9 @@ let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
   let j = typing_fun tycon env tomatch in
   let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in
   isevars := evd;
-  let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
+  let typ = nf_evar ( !isevars) j.uj_type in
   let t =
-    try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+    try IsInd (typ,find_rectype env ( !isevars) typ)
     with Not_found ->
       unify_tomatch_with_patterns isevars env loc typ pats in
   (j.uj_val,t)
@@ -344,11 +396,11 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps) =
   (* Ideally, we could find a common inductive type to which both the
      term to match and the patterns coerce *)
   (* In practice, we coerce the term to match if it is not already an
-     inductive type and it is not dependent; moreover, we use only 
+     inductive type and it is not dependent; moreover, we use only
      the first pattern type and forget about the others *)
   let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
   let typ =
-    try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
+    try IsInd (typ,find_rectype pb.env ( !(pb.isevars)) typ)
     with Not_found -> NotInd (None,typ) in
   let tomatch = ((current,typ),deps) in
   match typ with
@@ -366,7 +418,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps) =
 	      else
 		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
 		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
-	    let sigma = Evd.evars_of !(pb.isevars) in
+	    let sigma =  !(pb.isevars) in
 	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
 	    ((current,typ),deps))
   | _ -> tomatch
@@ -392,9 +444,6 @@ let map_tomatch_type f = function
 let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
 let lift_tomatch_type n = liftn_tomatch_type n 1
 
-let lift_tomatch n ((current,typ),info) =
-  ((lift n current,lift_tomatch_type n typ),info)
-
 (**********************************************************************)
 (* Utilities on patterns *)
 
@@ -407,12 +456,6 @@ let alias_of_pat = function
   | PatVar (_,name) -> name
   | PatCstr(_,_,_,name) -> name
 
-let unalias_pat = function
-  | PatVar (c,name) as p ->
-      if name = Anonymous then p else PatVar (c,Anonymous)
-  | PatCstr(a,b,c,name) as p ->
-      if name = Anonymous then p else PatCstr (a,b,c,Anonymous)
-
 let remove_current_pattern eqn =
   match eqn.patterns with
     | pat::pats ->
@@ -437,18 +480,18 @@ let rec adjust_local_defs loc = function
   | [], [] -> []
   | _ -> raise NotAdjustable
 
-let check_and_adjust_constructor env ind cstrs = function 
+let check_and_adjust_constructor env ind cstrs = function
   | PatVar _ as pat -> pat
   | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
       (* Check it is constructor of the right type *)
       let ind' = inductive_of_constructor cstr in
-      if Closure.mind_equiv env ind' ind then
+      if Names.eq_ind ind' ind then
 	(* Check the constructor has the right number of args *)
 	let ci = cstrs.(i-1) in
 	let nb_args_constr = ci.cs_nargs in
 	if List.length args = nb_args_constr then pat
 	else
-	  try 
+	  try
 	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
 	    in PatCstr (loc, cstr, args', alias)
 	  with NotAdjustable ->
@@ -458,7 +501,7 @@ let check_and_adjust_constructor env ind cstrs = function
 	(* Try to insert a coercion *)
 	try
 	  Coercion.inh_pattern_coerce_to loc pat ind' ind
-	with Not_found -> 
+	with Not_found ->
 	  error_bad_constructor_loc loc cstr ind
 
 let check_all_variables typ mat =
@@ -470,14 +513,14 @@ let check_all_variables typ mat =
     mat
 
 let check_unused_pattern env eqn =
-  if not !(eqn.used) then 
+  if not !(eqn.used) then
     raise_pattern_matching_error
       (eqn.eqn_loc, env, UnusedClause eqn.patterns)
 
 let set_used_pattern eqn = eqn.used := true
 
 let extract_rhs pb =
-  match pb.mat with 
+  match pb.mat with
     | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
     | eqn::_ ->
 	set_used_pattern eqn;
@@ -516,7 +559,7 @@ let dependent_decl a = function
 
 let rec find_dependency_list k n = function
   | [] -> []
-  | (used,tdeps,d)::rest -> 
+  | (used,tdeps,d)::rest ->
       let deps = find_dependency_list k (n+1) rest in
       if used && dependent_decl (mkRel n) d
       then list_add_set (List.length rest + 1) (list_union deps tdeps)
@@ -537,7 +580,7 @@ let find_dependencies_signature deps_in_rhs typs =
 
 (* A Pushed term to match has just been substituted by some
    constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
-   match 
+   match
 
    - all terms to match and to push (dependent on t by definition)
      must have (Rel depth) substituted by t and Rel's>depth lifted by n
@@ -562,7 +605,7 @@ let regeneralize_index_tomatch n =
       ::(genrec (depth+1) rest) in
   genrec 0
 
-let rec replace_term n c k t = 
+let rec replace_term n c k t =
   if t = mkRel (n+k) then lift k c
   else map_constr_with_binders succ (replace_term n c) k t
 
@@ -581,9 +624,6 @@ let replace_tomatch n c =
       ::(replrec (depth+1) rest) in
   replrec 0
 
-let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
-let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k)
-
 let rec liftn_tomatch_stack n depth = function
   | [] -> []
   | Pushed ((c,tm),l)::rest ->
@@ -613,7 +653,7 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1
    [match y with (S (S x)) => x | x => x end] should be compiled into
    [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
 
-   and [match y with (S (S n)) => n | n => n end] into 
+   and [match y with (S (S n)) => n | n => n end] into
    [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
 
   i.e. user names should be preserved and created names should not
@@ -628,7 +668,7 @@ let merge_names get_name = List.map2 (merge_name get_name)
 let get_names env sign eqns =
   let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
   (* If any, we prefer names used in pats, from top to bottom *)
-  let names2 = 
+  let names2 =
     List.fold_right
       (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
       eqns names1 in
@@ -642,7 +682,7 @@ let get_names env sign eqns =
 	 let na =
 	   merge_name
 	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
-	     d na 
+	     d na
 	 in
          (na::l,(out_name na)::avoid))
       ([],allvars) (List.rev sign) names2 in
@@ -683,7 +723,7 @@ let build_aliases_context env sigma names allpats pats =
 	let oldallpats = List.map List.tl oldallpats in
 	let decl = (na,Some deppat,t) in
 	let a = (deppat,nondeppat,d,t) in
-	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
+	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
 	  newallpats oldallpats (pats,names)
     | [], [] -> newallpats, sign1, sign2, env
     | _ -> anomaly "Inconsistent alias and name lists" in
@@ -693,16 +733,16 @@ let build_aliases_context env sigma names allpats pats =
 let insert_aliases_eqn sign eqnnames alias_rest eqn =
   let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
     push_rels_eqn thissign { eqn with  alias_stack = alias_rest; }
-	    
+
 
 let insert_aliases env sigma alias eqns =
-  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
-  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
-  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
+  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
+  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
+  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
   let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
   let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
   (* names2 takes the meet of all needed aliases *)
-  let names2 = 
+  let names2 =
     List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
   (* Only needed aliases are kept by build_aliases_context *)
   let eqnsnames, sign1, sign2, env =
@@ -714,12 +754,12 @@ let insert_aliases env sigma alias eqns =
 (* Functions to deal with elimination predicate *)
 
 exception Occur
-let noccur_between_without_evar n m term = 
+let noccur_between_without_evar n m term =
   let rec occur_rec n c = match kind_of_term c with
     | Rel p       -> if n<=p && p<n+m then raise Occur
     | Evar (_,cl) -> ()
     | _             -> iter_constr_with_binders succ occur_rec n c
-  in 
+  in
   try occur_rec n term; true with Occur -> false
 
 (* Inferring the predicate *)
@@ -797,9 +837,9 @@ let rec transpose_args n =
 
 let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
 
-let reloc_operator (k,n) = function OpRel p when p > k -> 
+let reloc_operator (k,n) = function OpRel p when p > k ->
 let rec unify_clauses k pv =
-  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
+  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in
   let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
   if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
   then
@@ -812,7 +852,7 @@ let rec unify_clauses k pv =
 let abstract_conclusion typ cs =
   let n = List.length (assums_of_rel_context cs.cs_args) in
   let (sign,p) = decompose_prod_n n typ in
-  lam_it p sign
+  it_mkLambda p sign
 
 let infer_predicate loc env isevars typs cstrs indf =
   (* Il faudra substituer les isevars a un certain moment *)
@@ -822,7 +862,7 @@ let infer_predicate loc env isevars typs cstrs indf =
     (* Empiric normalization: p may depend in a irrelevant way on args of the*)
     (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
     let typs =
-      Array.map (local_strong whd_beta (Evd.evars_of !isevars)) typs
+      Array.map (local_strong whd_beta ( !isevars)) typs
     in
     let eqns = array_map2 prepare_unif_pb typs cstrs in
     (* First strategy: no dependencies at all *)
@@ -843,10 +883,10 @@ let infer_predicate loc env isevars typs cstrs indf =
       (* Non dependent case -> turn it into a (dummy) dependent one *)
       let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
       let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-      (true,pred) (* true = dependent -- par défaut *)
+      (true,pred) (* true = dependent -- par défaut *)
     else
 (*
-      let s = get_sort_of env (evars_of isevars) typs.(0) in
+      let s = get_sort_of env ( isevars) typs.(0) in
       let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
       let caseinfo = make_default_case_info mis in
       let brs = array_map2 abstract_conclusion typs cstrs in
@@ -855,7 +895,7 @@ let infer_predicate loc env isevars typs cstrs indf =
 *)
       (* "TODO4-2" *)
       (* We skip parameters *)
-      let cis = 
+      let cis =
 	Array.map
 	  (fun cs ->
 	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
@@ -1040,11 +1080,11 @@ let find_predicate loc env isevars p typs cstrs current
   (IndType (indf,realargs)) tms =
   let (dep,pred) =
     match p with
-      | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
+      | Some p -> abstract_predicate env ( !isevars) indf current tms p
       | None -> infer_predicate loc env isevars typs cstrs indf in
-  let typ = whd_beta (Evd.evars_of !isevars) (applist (pred, realargs)) in
+  let typ = whd_beta ( !isevars) (applist (pred, realargs)) in
   if dep then
-    (pred, whd_beta (Evd.evars_of !isevars) (applist (typ, [current])),
+    (pred, whd_beta ( !isevars) (applist (typ, [current])),
      new_Type ())
   else
     (pred, typ, new_Type ())
@@ -1083,8 +1123,8 @@ let group_equations pb ind current cstrs mat =
       (fun eqn () ->
 	 let rest = remove_current_pattern eqn in
 	 let pat = current_pattern eqn in
-	 match check_and_adjust_constructor pb.env ind cstrs pat with 
-	   | PatVar (_,name) -> 
+	 match check_and_adjust_constructor pb.env ind cstrs pat with
+	   | PatVar (_,name) ->
 	       (* This is a default clause that we expand *)
 	       for i=1 to Array.length cstrs do
 		 let n = cstrs.(i-1).cs_nargs in
@@ -1137,10 +1177,10 @@ let build_branch current deps pb eqns const_info =
       & not (known_dependent pb.pred) & deps = []
     then
       NonDepAlias
-    else 
+    else
       DepAlias
   in
-  let history = 
+  let history =
     push_history_pattern const_info.cs_nargs
       (AliasConstructor const_info.cs_cstr)
       pb.history in
@@ -1165,7 +1205,7 @@ let build_branch current deps pb eqns const_info =
     find_dependencies_signature
       (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
 
-  (* The dependent term to subst in the types of the remaining UnPushed 
+  (* The dependent term to subst in the types of the remaining UnPushed
      terms is relative to the current context enriched by topushs *)
   let ci = build_dependent_constructor const_info in
 
@@ -1244,7 +1284,7 @@ and match_current pb tomatch =
 	  let brvals = Array.map (fun (v,_) -> v) brs in
 	  let brtyps = Array.map (fun (_,t) -> t) brs in
 	  let (pred,typ,s) =
-	    find_predicate pb.caseloc pb.env pb.isevars 
+	    find_predicate pb.caseloc pb.env pb.isevars
 	      pb.pred brtyps cstrs current indt pb.tomatch in
 	  let ci = make_case_info pb.env mind pb.casestyle in
 	  let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
@@ -1271,7 +1311,7 @@ and compile_generalization pb d rest =
 and compile_alias pb (deppat,nondeppat,d,t) rest =
   let history = simplify_history pb.history in
   let sign, newenv, mat =
-    insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
+    insert_aliases pb.env ( !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
   let n = List.length sign in
 
   (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
@@ -1294,7 +1334,7 @@ and compile_alias pb (deppat,nondeppat,d,t) rest =
   List.fold_left mkSpecialLetInJudge j sign
 
 (* pour les alias des initiaux, enrichir les env de ce qu'il faut et
-substituer après par les initiaux *)
+substituer après par les initiaux *)
 
 (**************************************************************************)
 (* Preparation of the pattern-matching problem                            *)
@@ -1334,19 +1374,19 @@ let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
   let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
   let names = List.rev (List.map (List.map pi1) signs) in
   let allargs =
-    List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
+    List.map (fun c -> lift n (nf_betadeltaiota env ( !isevars) c)) allargs in
   let rec build_skeleton env c =
     (* Don't put into normal form, it has effects on the synthesis of evars *)
- (* let c = whd_betadeltaiota env (evars_of isevars) c in *)
+ (* let c = whd_betadeltaiota env ( isevars) c in *)
     (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
     if isEvar c or List.exists (eq_constr c) allargs then
       e_new_evar isevars env  ~src:(loc, Evd.CasesType)
-        (Retyping.get_type_of env (Evd.evars_of !isevars) c)
+        (Retyping.get_type_of env ( !isevars) c)
     else
-      map_constr_with_full_binders push_rel build_skeleton env c 
+      map_constr_with_full_binders push_rel build_skeleton env c
   in
     names, build_skeleton env (lift n c)
-  
+
 (* Here, [pred] is assumed to be in the context built from all *)
 (* realargs and terms to match *)
 let build_initial_predicate isdep allnames pred =
@@ -1357,7 +1397,7 @@ let build_initial_predicate isdep allnames pred =
         let names' = if isdep then List.tl names else names in
         let n' = n + List.length names' in
         let pred, p, user_p =
-          if isdep then 
+          if isdep then
             if dependent (mkRel (nar-n')) pred then pred, 1, 1
             else liftn (-1) (nar-n') pred, 0, 1
           else pred, 0, 0 in
@@ -1375,10 +1415,10 @@ let build_initial_predicate isdep allnames pred =
 let extract_arity_signature env0 tomatchl tmsign =
   let get_one_sign n tm (na,t) =
     match tm with
-      | NotInd (bo,typ) -> 
+      | NotInd (bo,typ) ->
 	  (match t with
 	    | None -> [na,Option.map (lift n) bo,lift n typ]
-	    | Some (loc,_,_,_) -> 
+	    | Some (loc,_,_,_) ->
  	    user_err_loc (loc,"",
 	    str "Unexpected type annotation for a term of non inductive type"))
       | IsInd (_,IndType(indf,realargs)) ->
@@ -1409,10 +1449,10 @@ let extract_arity_signature env0 tomatchl tmsign =
 let extract_arity_signatures env0 tomatchl tmsign =
   let get_one_sign tm (na,t) =
     match tm with
-      | NotInd (bo,typ) -> 
+      | NotInd (bo,typ) ->
 	  (match t with
 	    | None -> [na,bo,typ]
-	    | Some (loc,_,_,_) -> 
+	    | Some (loc,_,_,_) ->
  	    user_err_loc (loc,"",
 	    str "Unexpected type annotation for a term of non inductive type"))
       | IsInd (_,IndType(indf,realargs)) ->
@@ -1448,69 +1488,69 @@ let inh_conv_coerce_to_tycon loc env isevars j tycon =
     | None -> j
 
 let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
-	       
-let string_of_name name = 
+
+let string_of_name name =
   match name with
     | Anonymous -> "anonymous"
     | Name n -> string_of_id n
-	
+
 let id_of_name n = id_of_string (string_of_name n)
 
-let make_prime_id name = 
+let make_prime_id name =
   let str = string_of_name name in
     id_of_string str, id_of_string (str ^ "'")
 
-let prime avoid name = 
+let prime avoid name =
   let previd, id = make_prime_id name in
-    previd, next_ident_away_from id avoid
+    previd, next_ident_away id avoid
 
 let make_prime avoid prevname =
   let previd, id = prime !avoid prevname in
     avoid := id :: !avoid;
     previd, id
 
-let eq_id avoid id = 
+let eq_id avoid id =
   let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away_from hid avoid in
+  let hid' = next_ident_away hid avoid in
     hid'
 
 let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
 let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
-    
-let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
+let mk_JMeq typ x typ' y =
+  mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |])
 
-let context_of_arsign l =
-  let (x, _) = List.fold_right
-    (fun c (x, n) -> 
-      (lift_rel_context n c @ x, List.length c + n))
-    l ([], 0)
-  in x
+let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
 
-let constr_of_pat env isevars arsign pat avoid = 
-  let rec typ env (ty, realargs) pat avoid = 
+let constr_of_pat env isevars arsign pat avoid =
+  let rec typ env (ty, realargs) pat avoid =
     match pat with
-    | PatVar (l,name) -> 
+    | PatVar (l,name) ->
 	let name, avoid = match name with
 	    Name n -> name, avoid
-	  | Anonymous -> 
+	  | Anonymous ->
 	      let previd, id = prime avoid (Name (id_of_string "wildcard")) in
-		Name id, id :: avoid 
+		Name id, id :: avoid
 	in
 	  PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid
     | PatCstr (l,((_, i) as cstr),args,alias) ->
 	let cind = inductive_of_constructor cstr in
-	let IndType (indf, _) = find_rectype env (Evd.evars_of !isevars) (lift (-(List.length realargs)) ty) in
+	let IndType (indf, _) = 
+	  try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) 
+	  with Not_found -> error_case_not_inductive env 
+	    {uj_val = ty; uj_type = Typing.type_of env !isevars ty}
+	in
 	let ind, params = dest_ind_family indf in
 	if ind <> cind then error_bad_constructor_loc l cstr ind;
 	let cstrs = get_constructors env indf in
 	let ci = cstrs.(i-1) in
 	let nb_args_constr = ci.cs_nargs in
 	assert(nb_args_constr = List.length args);
-	let patargs, args, sign, env, n, m, avoid = 
+	let patargs, args, sign, env, n, m, avoid =
 	  List.fold_right2
 	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid)  ->
-	       let pat', sign', arg', typ', argtypargs, n', avoid = 
-		 typ env (lift (n - m) t, []) ua avoid 
+	       let pat', sign', arg', typ', argtypargs, n', avoid =
+		 typ env (lift (n - m) t, []) ua avoid
 	       in
 	       let args' = arg' :: List.map (lift n') args in
 	       let env' = push_rels sign' env in
@@ -1523,8 +1563,8 @@ let constr_of_pat env isevars arsign pat avoid =
 	let cstr = mkConstruct ci.cs_cstr in
 	let app = applistc cstr (List.map (lift (List.length sign)) params) in
 	let app = applistc app args in
-	let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in	
-	let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in
+	let apptype = Retyping.get_type_of env ( !isevars) app in
+	let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in
 	  match alias with
 	      Anonymous ->
 		pat', sign, app, apptype, realargs, n, avoid
@@ -1538,38 +1578,38 @@ let constr_of_pat env isevars arsign pat avoid =
 		    let eq_t = mk_eq (lift (succ m) ty)
 		      (mkRel 1) (* alias *)
 		      (lift 1 app) (* aliased term *)
-		    in 
+		    in
 		    let neq = eq_id avoid id in
 		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
 		  with Reduction.NotConvertible -> sign, 1, avoid
 		in
 		  (* Mark the equality as a hole *)
 		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
-  in 
-  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in 
+  in
+  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
     pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
 
 
 (* shadows functional version *)
-let eq_id avoid id = 
+let eq_id avoid id =
   let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away_from hid !avoid in
+  let hid' = next_ident_away hid !avoid in
     avoid := hid' :: !avoid;
     hid'
 
-let rels_of_patsign = 
-  List.map (fun ((na, b, t) as x) -> 
-    match b with 
+let rels_of_patsign =
+  List.map (fun ((na, b, t) as x) ->
+    match b with
       | Some t' when kind_of_term t' = Rel 0 -> (na, None, t)
       | _ -> x)
 
-let vars_of_ctx ctx = 
+let vars_of_ctx ctx =
   let _, y =
-    List.fold_right (fun (na, b, t)  (prev, vars) -> 
-      match b with 
-	| Some t' when kind_of_term t' = Rel 0 -> 
-	    prev, 
-	    (RApp (dummy_loc, 
+    List.fold_right (fun (na, b, t)  (prev, vars) ->
+      match b with
+	| Some t' when kind_of_term t' = Rel 0 ->
+	    prev,
+	    (RApp (dummy_loc,
 		(RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars
 	| _ ->
 	    match na with
@@ -1578,7 +1618,7 @@ let vars_of_ctx ctx =
       ctx (id_of_string "vars_of_ctx_error", [])
   in List.rev y
 
-let rec is_included x y = 
+let rec is_included x y =
   match x, y with
     | PatVar _, _ -> true
     | _, PatVar _ -> true
@@ -1591,12 +1631,12 @@ let rec is_included x y =
  *)
 let build_ineqs prevpatterns pats liftsign =
   let _tomatchs = List.length pats in
-  let diffs = 
-    List.fold_left 
-      (fun c eqnpats -> 
+  let diffs =
+    List.fold_left
+      (fun c eqnpats ->
 	  let acc = List.fold_left2
 	    (* ppat is the pattern we are discriminating against, curpat is the current one. *)
-	    (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) 
+	    (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat)
 	      (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) ->
 	      match acc with
 		  None -> None
@@ -1606,33 +1646,33 @@ let build_ineqs prevpatterns pats liftsign =
 		      let lens = List.length ppat_sign in
 		      (* Accumulated length of previous pattern's signatures *)
 		      let len' = lens + len in
-		      let acc = 
+		      let acc =
 			((* Jump over previous prevpat signs *)
-			  lift_rel_context len ppat_sign @ sign, 
+			  lift_rel_context len ppat_sign @ sign,
 			  len',
 			  succ n, (* nth pattern *)
 			  mkApp (Lazy.force eq_ind,
 				[| lift (len' + liftsign) curpat_ty;
 				   liftn (len + liftsign) (succ lens) ppat_c ;
-				   lift len' curpat_c |]) :: 
+				   lift len' curpat_c |]) ::
 			    List.map (lift lens (* Jump over this prevpat signature *)) c)
 		      in Some acc
 		    else None)
 	   (Some ([], 0, 0, [])) eqnpats pats
-	 in match acc with 
+	 in match acc with
 	     None -> c
 	   | Some (sign, len, _, c') ->
-	       let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) 
-		 (lift_rel_context liftsign sign) 
+	       let conj = it_mkProd_or_LetIn (mk_not (mk_conj c'))
+		 (lift_rel_context liftsign sign)
 	       in
 		 conj :: c)
       [] prevpatterns
   in match diffs with [] -> None
     | _ -> Some (mk_conj diffs)
-	
+
 let subst_rel_context k ctx subst =
   let (_, ctx') =
-    List.fold_right 
+    List.fold_right
       (fun (n, b, t) (k, acc) ->
 	 (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc))
       ctx (k, [])
@@ -1648,29 +1688,29 @@ let lift_rel_contextn n k sign =
 
 let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
   let i = ref 0 in
-  let (x, y, z) = 
+  let (x, y, z) =
     List.fold_left
       (fun (branches, eqns, prevpatterns) eqn ->
-	 let _, newpatterns, pats = 
+	 let _, newpatterns, pats =
 	   List.fold_left2
-	     (fun (idents, newpatterns, pats) pat arsign -> 
+	     (fun (idents, newpatterns, pats) pat arsign ->
 		let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in
 		  (idents, pat' :: newpatterns, cpat :: pats))
 	      ([], [], []) eqn.patterns sign
 	 in
 	 let newpatterns = List.rev newpatterns and opats = List.rev pats in
-	 let rhs_rels, pats, signlen = 
-	   List.fold_left 
-	     (fun (renv, pats, n) (sign,c, (s, args), p) -> 
+	 let rhs_rels, pats, signlen =
+	   List.fold_left
+	     (fun (renv, pats, n) (sign,c, (s, args), p) ->
 	       (* Recombine signatures and terms of all of the row's patterns *)
 	       let sign' = lift_rel_context n sign in
 	       let len = List.length sign' in
-		 (sign' @ renv, 
+		 (sign' @ renv,
 		 (* lift to get outside of previous pattern's signatures. *)
 		 (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats,
 		 len + n))
 	     ([], [], 0) opats in
-	 let pats, _ = List.fold_left 
+	 let pats, _ = List.fold_left
 	   (* lift to get outside of past patterns to get terms in the combined environment. *)
 	   (fun (pats, n) (sign, c, (s, args), p) ->
 	     let len = List.length sign in
@@ -1681,7 +1721,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
 	 let rhs_rels' = rels_of_patsign rhs_rels in
 	 let _signenv = push_rel_context rhs_rels' env in
 	 let arity =
-	   let args, nargs = 
+	   let args, nargs =
 	     List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
 	       (args @ c :: allargs, List.length args + succ n))
 	       pats ([], 0)
@@ -1689,7 +1729,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
 	   let args = List.rev args in
 	     substl args (liftn signlen (succ nargs) arity)
 	 in
-	 let rhs_rels', tycon = 
+	 let rhs_rels', tycon =
 	   let neqs_rels, arity =
 	     match ineqs with
 	     | None -> [], arity
@@ -1705,7 +1745,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
 	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
 	 let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in
 	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
-	 let branch = 
+	 let branch =
 	   let bref = RVar (dummy_loc, branch_name) in
 	     match vars_of_ctx rhs_rels with
 		 [] -> bref
@@ -1732,28 +1772,30 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
 
  * A type constraint but no annotation case: it is assumed non dependent.
  *)
-  
-let lift_ctx n ctx = 
+
+let lift_ctx n ctx =
   let ctx', _ =
     List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
   in ctx'
 
 (* Turn matched terms into variables. *)
-let abstract_tomatch env tomatchs =
-  let prev, ctx, names = 
+let abstract_tomatch env tomatchs tycon =
+  let prev, ctx, names, tycon =
     List.fold_left
-      (fun (prev, ctx, names) (c, t) ->
+      (fun (prev, ctx, names, tycon) (c, t) ->
 	 let lenctx =  List.length ctx in
 	 match kind_of_term c with
-	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names
-	   | _ -> 
-	       let name = next_ident_away_from (id_of_string "filtered_var") names in
-		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, 
-	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, 
-	       name :: names)
-      ([], [], []) tomatchs
-  in List.rev prev, ctx
-    
+	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon
+	   | _ ->
+	       let tycon = Option.map
+		 (fun t -> subst_term_occ all_occurrences (lift 1 c) (lift 1 t)) tycon in
+	       let name = next_ident_away (id_of_string "filtered_var") names in
+		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
+	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
+	       name :: names, tycon)
+      ([], [], [], tycon) tomatchs
+  in List.rev prev, ctx, tycon
+
 let is_dependent_ind = function
     IsInd (_, IndType (indf, args)) when List.length args > 0 -> true
   | _ -> false
@@ -1763,13 +1805,13 @@ let build_dependent_signature env evars avoid tomatchs arsign =
   let arsign = List.rev arsign in
   let allnames = List.rev (List.map (List.map pi1) arsign) in
   let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let eqs, neqs, refls, slift, arsign' = 
-    List.fold_left2 
-      (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> 
+  let eqs, neqs, refls, slift, arsign' =
+    List.fold_left2
+      (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign ->
 	 (* The accumulator:
-	    previous eqs, 
-	    number of previous eqs, 
-	    lift to get outside eqs and in the introduced variables ('as' and 'in'), 
+	    previous eqs,
+	    number of previous eqs,
+	    lift to get outside eqs and in the introduced variables ('as' and 'in'),
 	    new arity signatures
 	 *)
 	 match ty with
@@ -1782,7 +1824,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 		 List.fold_left2
 		   (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
 		      let argt = Retyping.get_type_of env evars arg in
-		      let eq, refl_arg = 
+		      let eq, refl_arg =
 			if Reductionops.is_conv env evars argt t then
 			  (mk_eq (lift (nargeqs + slift) argt)
 			     (mkRel (nargeqs + slift))
@@ -1795,58 +1837,58 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 			     (lift (nargeqs + nar) arg),
 			   mk_JMeq_refl argt arg)
 		      in
-		      let previd, id = 
-			let name = 
-			  match kind_of_term arg with 
-			      Rel n -> pi1 (Environ.lookup_rel n env)
+		      let previd, id =
+			let name =
+			  match kind_of_term arg with
+			      Rel n -> pi1 (lookup_rel n env)
 			    | _ -> name
 			in
-			  make_prime avoid name 
+			  make_prime avoid name
 		      in
-			(env, succ nargeqs, 
-			 (Name (eq_id avoid previd), None, eq) :: argeqs, 
+			(env, succ nargeqs,
+			 (Name (eq_id avoid previd), None, eq) :: argeqs,
 			 refl_arg :: refl_args,
 			 pred slift,
 			 (Name id, b, t) :: argsign'))
 		   (env, 0, [], [], slift, []) args argsign
 	       in
-	       let eq = mk_JMeq 
+	       let eq = mk_JMeq
 		 (lift (nargeqs + slift) appt)
 		 (mkRel (nargeqs + slift))
-		 (lift (nargeqs + nar) ty) 
-		 (lift (nargeqs + nar) tm) 
+		 (lift (nargeqs + nar) ty)
+		 (lift (nargeqs + nar) tm)
 	       in
 	       let refl_eq = mk_JMeq_refl ty tm in
 	       let previd, id = make_prime avoid appn in
-		 (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, 
-		 succ nargeqs, 
+		 (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
+		 succ nargeqs,
 		 refl_eq :: refl_args,
-		 pred slift, 
+		 pred slift,
 		 (((Name id, appb, appt) :: argsign') :: arsigns))
-		   
-	   | _ -> 
+
+	   | _ ->
 	       (* Non dependent inductive or not inductive, just use a regular equality *)
 	       let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
 	       let previd, id = make_prime avoid name in
 	       let arsign' = (Name id, b, typ) in
 	       let tomatch_ty = type_of_tomatch ty in
-	       let eq = 
+	       let eq =
 		 mk_eq (lift nar tomatch_ty)
 		   (mkRel slift) (lift nar tm)
 	       in
-		 ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, 
+		 ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
 		  (mk_eq_refl tomatch_ty tm) :: refl_args,
 		  pred slift, (arsign' :: []) :: arsigns))
       ([], 0, [], nar, []) tomatchs arsign
-  in 
+  in
   let arsign'' = List.rev arsign' in
     assert(slift = 0); (* we must have folded over all elements of the arity signature *)
     arsign'', allnames, nar, eqs, neqs, refls
 
 (**************************************************************************)
 (* Main entry of the matching compilation                                 *)
-  
-let liftn_rel_context n k sign =  
+
+let liftn_rel_context n k sign =
   let rec liftrec k = function
     | (na,c,t)::sign ->
 	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
@@ -1854,62 +1896,15 @@ let liftn_rel_context n k sign =
   in
     liftrec (k + rel_context_length sign) sign
 
-let nf_evars_env evar_defs (env : env) : env = 
-  let nf t = nf_isevar evar_defs t in
-  let env0 : env = reset_context env in 
+let nf_evars_env sigma (env : env) : env =
+  let nf t = nf_evar sigma t in
+  let env0 : env = reset_context env in
   let f e (na, b, t) e' : env =
     Environ.push_named (na, Option.map nf b, nf t) e'
   in
   let env' = Environ.fold_named_context f ~init:env0 env in
     Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e')
      ~init:env' env
-      
-(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
-
-let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
-  let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
-  let subst, len = 
-    List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
-      let signlen = List.length sign in
-	match kind_of_term tm with
-	  | Rel n when dependent tm c 
-		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
-	      ((n, len) :: subst, len - signlen)
-	  | Rel _ when not (dependent tm c)
-		&& signlen > 1 (* The term is of a dependent type but does not appear in 
-				  the tycon, maybe some variable in its type does. *) ->
-	      (match tmtype with
-		  NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
-		| IsInd (_, IndType(indf,realargs)) ->
-		    List.fold_left
-		      (fun (subst, len) arg -> 
-			match kind_of_term arg with
-			  | Rel n when dependent arg c ->
-			      ((n, len) :: subst, pred len)
-			  | _ -> (subst, pred len))
-		      (subst, len) realargs)
-	  | _ -> (subst, len - signlen))
-      ([], nar) tomatchs arsign
-  in
-  let rec predicate lift c =
-    match kind_of_term c with
-      | Rel n when n > lift -> 
-	  (try 
-	      (* Make the predicate dependent on the matched variable *)
-	      let idx = List.assoc (n - lift) subst in
-		mkRel (idx + lift)
-	    with Not_found -> 
-	      (* A variable that is not matched, lift over the arsign. *)
-	      mkRel (n + nar))
-      | _ ->
-	  map_constr_with_binders succ predicate lift c 
-  in
-    try 
-      (* The tycon may be ill-typed after abstraction. *)
-      let pred = predicate 0 c in
-      let env' = push_rel_context (context_of_arsign arsign) env in
-	ignore(Typing.sort_of env' evm pred); pred
-    with _ -> lift nar c
 
 
 let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
@@ -1920,13 +1915,13 @@ let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon
     match rtntyp with
       | Some rtntyp ->
 	  let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in
-	  let predccl = (j_nf_isevar !isevars predcclj).uj_val in      
+	  let predccl = (j_nf_evar !isevars predcclj).uj_val in
 	    Some (build_initial_predicate true allnames predccl)
-      | None -> 
+      | None ->
 	  match valcon_of_tycon tycon with
-	    | Some ty -> 
-		let pred = 
-		  prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars) tomatchs arsign ty
+	    | Some ty ->
+		let pred =
+		  prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty
 		in Some (build_initial_predicate true allnames pred)
 	    | None -> None
 
@@ -1936,40 +1931,40 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra
 
   (* We build the matrix of patterns and right-hand-side *)
   let matx = matx_of_eqns env eqns in
-     
+
   (* We build the vector of terms to match consistently with the *)
   (* constructors found in patterns *)
   let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
   let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in
     if predopt = None then
-      let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in
-      let tomatchs_len = List.length tomatchs_lets in
+      let tycon = valcon_of_tycon tycon in
+      let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in
       let env = push_rel_context tomatchs_lets env in
-      let len = List.length eqns in 
-      let sign, allnames, signlen, eqs, neqs, args = 
+      let len = List.length eqns in
+      let sign, allnames, signlen, eqs, neqs, args =
 	(* The arity signature *)
 	let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in
 	  (* Build the dependent arity signature, the equalities which makes
 	     the first part of the predicate and their instantiations. *)
 	let avoid = [] in
-	  build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign
+	  build_dependent_signature env ( !isevars) avoid tomatchs arsign
 
       in
-      let tycon, arity = 
-	match valcon_of_tycon tycon with
+      let tycon, arity =
+	match tycon' with
 	| None -> let ev = mkExistential env isevars in ev, ev
-	| Some t -> 
-	    t, prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars)
-	      tomatchs sign (lift tomatchs_len t)
+	| Some t ->
+	    Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars)
+	      tomatchs sign t
       in
-      let neqs, arity = 
+      let neqs, arity =
 	let ctx = context_of_arsign eqs in
 	let neqs = List.length ctx in
 	  neqs, it_mkProd_or_LetIn (lift neqs arity) ctx
       in
-      let lets, matx = 
+      let lets, matx =
 	(* Type the rhs under the assumption of equations *)
-	constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity 
+	constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity
       in
       let matx = List.rev matx in
       let _ = assert(len = List.length lets) in
@@ -1983,7 +1978,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra
       (* We push the initial terms to match and push their alias to rhs' envs *)
       (* names of aliases will be recovered from patterns (hence Anonymous here) *)
       let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-	
+
       let pb =
 	{ env      = env;
 	  isevars  = isevars;
@@ -1994,14 +1989,14 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra
 	  caseloc  = loc;
 	  casestyle= style;
 	  typing_function = typing_fun } in
-	
+
       let j = compile pb in
 	(* We check for unused patterns *)
 	List.iter (check_unused_pattern env) matx;
 	let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
-	let j = 
+	let j =
 	  { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
-	    uj_type = nf_isevar !isevars tycon; }
+	    uj_type = nf_evar !isevars tycon; }
 	in j
     else
       (* We build the elimination predicate if any and check its consistency *)
@@ -2022,11 +2017,11 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra
 	  caseloc  = loc;
 	  casestyle= style;
 	  typing_function = typing_fun } in
-	
+
       let j = compile pb in
 	(* We check for unused patterns *)
 	List.iter (check_unused_pattern env) matx;
-	inh_conv_coerce_to_tycon loc env isevars j tycon	  
-	  
+	inh_conv_coerce_to_tycon loc env isevars j tycon
+
 end
-  
+
diff --git a/contrib/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli
index 6b8a0981..90989d2d 100644
--- a/contrib/subtac/subtac_cases.mli
+++ b/plugins/subtac/subtac_cases.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtac_cases.mli 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
new file mode 100644
index 00000000..59c877c8
--- /dev/null
+++ b/plugins/subtac/subtac_classes.ml
@@ -0,0 +1,182 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Pretyping
+open Evd
+open Environ
+open Term
+open Rawterm
+open Topconstr
+open Names
+open Libnames
+open Pp
+open Vernacexpr
+open Constrintern
+open Subtac_command
+open Typeclasses
+open Typeclasses_errors
+open Termops
+open Decl_kinds
+open Entries
+open Util
+
+module SPretyping = Subtac_pretyping.Pretyping
+
+let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+  SPretyping.understand_tcc_evars evdref env kind
+    (intern_gen (kind=IsType) ~impls ( !evdref) env c)
+
+let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
+  interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
+
+let interp_context_evars evdref env params =
+  Constrintern.interp_context_gen
+    (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
+    (SPretyping.understand_judgment_tcc evdref) !evdref env params
+
+let type_ctx_instance evars env ctx inst subst =
+  let rec aux (subst, instctx) l = function
+    (na, b, t) :: ctx ->
+      let t' = substl subst t in
+      let c', l =
+	match b with
+	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
+	| Some b -> substl subst b, l
+      in
+       evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
+       let d = na, Some c', t' in
+	aux (c' :: subst, d :: instctx) l ctx
+    | [] -> subst
+  in aux (subst, []) inst (List.rev ctx)
+
+let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri =
+  let env = Global.env() in
+  let evars = ref Evd.empty in
+  let tclass, _ =
+    match bk with
+    | Implicit ->
+	Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *)
+	  ~allow_partial:false (fun avoid (clname, (id, _, t)) ->
+	    match clname with
+	    | Some (cl, b) ->
+		let t =
+		  if b then
+		    let _k = class_info cl in
+		      CHole (Util.dummy_loc, Some Evd.InternalHole)
+		  else CHole (Util.dummy_loc, None)
+		in t, avoid
+	    | None -> failwith ("new instance: under-applied typeclass"))
+	  cl
+      | Explicit -> cl, Idset.empty
+  in
+  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
+  let k, cty, ctx', ctx, len, imps, subst =
+    let (env', ctx), imps = interp_context_evars evars env ctx in
+    let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
+    let len = List.length ctx in
+    let imps = imps @ Impargs.lift_implicits len imps' in
+    let ctx', c = decompose_prod_assum c' in
+    let ctx'' = ctx' @ ctx in
+    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
+    let _, args = 
+      List.fold_right (fun (na, b, t) (args, args') ->
+	match b with
+	| None -> (List.tl args, List.hd args :: args')
+	| Some b -> (args, substl args' b :: args'))
+	(snd cl.cl_context) (args, [])
+    in
+      cl, c', ctx', ctx, len, imps, args
+  in
+  let id =
+    match snd instid with
+    | Name id ->
+	let sp = Lib.make_path id in
+	  if Nametab.exists_cci sp then
+	    errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists");
+	  id
+    | Anonymous ->
+	let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
+	  Namegen.next_global_ident_away i (Termops.ids_of_context env)
+  in
+  let env' = push_rel_context ctx env in
+  evars := Evarutil.nf_evar_map !evars;
+  evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars;
+  let sigma =  !evars in
+  let subst = List.map (Evarutil.nf_evar sigma) subst in
+  let props =
+    match props with
+    | CRecord (loc, _, fs) ->
+	if List.length fs > List.length k.cl_props then
+	  Classes.mismatched_props env' (List.map snd fs) k.cl_props;
+	Inl fs
+    | _ -> Inr props
+  in
+  let subst =
+    match props with
+    | Inr term ->
+	let c = interp_casted_constr_evars evars env' term cty in
+	  Inr (c, subst)
+    | Inl props ->
+	let get_id =
+	  function
+	    | Ident id' -> id'
+	    | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
+	in
+	let props, rest =
+	  List.fold_left
+	    (fun (props, rest) (id,b,_) ->
+	      if b = None then
+		try
+		  let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in
+		  let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in
+		  let (loc, mid) = get_id loc_mid in
+		    Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs);
+		    c :: props, rest'
+		with Not_found ->
+		  (CHole (Util.dummy_loc, None) :: props), rest
+	      else props, rest)
+	    ([], props) k.cl_props
+	in
+	  if rest <> [] then
+	    unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
+	  else
+	    Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
+  in	  
+  evars := Evarutil.nf_evar_map !evars;
+  let term, termtype =
+    match subst with
+    | Inl subst ->
+	let subst = List.fold_left2
+	  (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
+	  [] subst (k.cl_props @ snd k.cl_context)
+	in
+	let app, ty_constr = instance_constructor k subst in
+	let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
+	let term = Termops.it_mkLambda_or_LetIn app (ctx' @ ctx) in
+	  term, termtype
+    | Inr (def, subst) ->
+	let termtype = it_mkProd_or_LetIn cty ctx in
+	let term = Termops.it_mkLambda_or_LetIn def ctx in
+	  term, termtype
+  in
+  let termtype = Evarutil.nf_evar !evars termtype in
+  let term = Evarutil.nf_evar !evars term in
+  evars := undefined_evars !evars;
+  Evarutil.check_evars env Evd.empty !evars termtype;
+  let hook vis gr =
+    let cst = match gr with ConstRef kn -> kn | _ -> assert false in
+    let inst = Typeclasses.new_instance k pri global (ConstRef cst) in
+      Impargs.declare_manual_implicits false gr ~enriching:false imps;
+      Typeclasses.add_instance inst
+  in
+  let evm = Subtac_utils.evars_of_term !evars Evd.empty term in
+  let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in
+    id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,false,Instance) ~hook obls
diff --git a/contrib/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
index 96a51027..ee78ff68 100644
--- a/contrib/subtac/subtac_classes.mli
+++ b/plugins/subtac/subtac_classes.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtac_classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,15 +24,14 @@ open Implicit_quantifiers
 open Classes
 (*i*)
 
-val type_ctx_instance :     Evd.evar_defs ref ->
-    Environ.env ->
+val type_ctx_instance :     Evd.evar_map ref ->
+  Environ.env ->
     ('a * Term.constr option * Term.constr) list ->
     Topconstr.constr_expr list ->
     Term.constr list ->
-    Term.constr list *
-    ('a * Term.constr option * Term.constr) list
+    Term.constr list
 
-val new_instance : 
+val new_instance :
   ?global:bool ->
   local_binder list ->
   typeclass_constraint ->
diff --git a/contrib/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
index 1bbbfbb1..5337baca 100644
--- a/contrib/subtac/subtac_coercion.ml
+++ b/plugins/subtac/subtac_coercion.ml
@@ -6,7 +6,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: subtac_coercion.ml 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -33,7 +33,7 @@ open Pp
 let pair_of_array a = (a.(0), a.(1))
 let make_name s = Name (id_of_string s)
 
-let rec disc_subset x = 
+let rec disc_subset x =
   match kind_of_term x with
   | App (c, l) ->
       (match kind_of_term c with
@@ -47,33 +47,33 @@ let rec disc_subset x =
 	  else None
       | _ -> None)
   | _ -> None
-      
+
 and disc_exist env x =
   match kind_of_term x with
   | App (c, l) ->
       (match kind_of_term c with
-      Construct c ->	       
+      Construct c ->
 	if c = Term.destConstruct (Lazy.force sig_).intro
 	then Some (l.(0), l.(1), l.(2), l.(3))
 	else None
       | _ -> None)
   | _ -> None
-      
+
 module Coercion = struct
-    
+
   exception NoSubtacCoercion
-    
+
   let disc_proj_exist env x =
     match kind_of_term x with
       | App (c, l) ->
-	  (if Term.eq_constr c (Lazy.force sig_).proj1 
-	     && Array.length l = 3 
+	  (if Term.eq_constr c (Lazy.force sig_).proj1
+	     && Array.length l = 3
 	   then disc_exist env l.(2)
 	   else None)
       | _ -> None
 
 
-  let sort_rel s1 s2 = 
+  let sort_rel s1 s2 =
     match s1, s2 with
 	Prop Pos, Prop Pos -> Prop Pos
       | Prop Pos, Prop Null -> Prop Null
@@ -83,7 +83,7 @@ module Coercion = struct
       | Type _, Prop Null -> Prop Null
       | _, Type _ -> s2
 
-  let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c
+  let hnf env isevars c = whd_betadeltaiota env ( !isevars) c
 
   let lift_args n sign =
     let rec liftrec k = function
@@ -92,40 +92,40 @@ module Coercion = struct
     in
       liftrec (List.length sign) sign
 
-  let rec mu env isevars t =   
+  let rec mu env isevars t =
     let isevars = ref isevars in
-    let rec aux v = 
+    let rec aux v =
       let v = hnf env isevars v in
       match disc_subset v with
-	  Some (u, p) -> 
+	  Some (u, p) ->
 	    let f, ct = aux u in
-	      (Some (fun x ->		   
-		       app_opt f (mkApp ((Lazy.force sig_).proj1, 
+	      (Some (fun x ->
+		       app_opt f (mkApp ((Lazy.force sig_).proj1,
 					 [| u; p; x |]))),
 	       ct)
 	| None -> (None, v)
     in aux t
 
-  and coerce loc env isevars (x : Term.constr) (y : Term.constr) 
-      : (Term.constr -> Term.constr) option 
+  and coerce loc env isevars (x : Term.constr) (y : Term.constr)
+      : (Term.constr -> Term.constr) option
       =
-    let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in
+    let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in
     let rec coerce_unify env x y =
       let x = hnf env isevars x and y = hnf env isevars y in
-	try 
+	try
 	  isevars := the_conv_x_leq env x y !isevars;
 	  None
 	with Reduction.NotConvertible -> coerce' env x y
     and coerce' env x y : (Term.constr -> Term.constr) option =
       let subco () = subset_coerce env isevars x y in
       let dest_prod c =
-	match Reductionops.decomp_n_prod env (evars_of !isevars) 1 c with
+	match Reductionops.splay_prod_n env ( !isevars) 1 c with
 	| [(na,b,t)], c -> (na,t), c
 	| _ -> raise NoSubtacCoercion
       in
       let rec coerce_application typ typ' c c' l l' =
 	let len = Array.length l in
-	let rec aux tele typ typ' i co = 
+	let rec aux tele typ typ' i co =
 	  if i < len then
 	    let hdx = l.(i) and hdy = l'.(i) in
 	      try isevars := the_conv_x_leq env hdx hdy !isevars;
@@ -135,15 +135,15 @@ module Coercion = struct
 	      with Reduction.NotConvertible ->
 		let (n, eqT), restT = dest_prod typ in
 		let (n', eqT'), restT' = dest_prod typ' in
-		let _ = 
+		let _ =
 		  try isevars := the_conv_x_leq env eqT eqT' !isevars
 		  with Reduction.NotConvertible -> raise NoSubtacCoercion
 		in
 		(* Disallow equalities on arities *)
 		if Reduction.is_arity env eqT then raise NoSubtacCoercion;
-		let restargs = lift_args 1 
+		let restargs = lift_args 1
 		  (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
-		in 
+		in
 		let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in
 		let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
 		let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in
@@ -152,21 +152,21 @@ module Coercion = struct
 				      [| eqT; hdx; pred; x; hdy; evar|]) in
 		  aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
 	  else Some co
-	in 
+	in
 	  if isEvar c || isEvar c' then
 	    (* Second-order unification needed. *)
 	    raise NoSubtacCoercion;
 	  aux [] typ typ' 0 (fun x -> x)
       in
 	match (kind_of_term x, kind_of_term y) with
-	  | Sort s, Sort s' -> 
+	  | Sort s, Sort s' ->
 	      (match s, s' with
 		   Prop x, Prop y when x = y -> None
 		 | Prop _, Type _ -> None
 		 | Type x, Type y when x = y -> None (* false *)
 		 | _ -> subco ())
 	  | Prod (name, a, b), Prod (name', a', b') ->
-	      let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
+	      let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
 	      let env' = push_rel (name', None, a') env in
 	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
 		(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
@@ -175,14 +175,14 @@ module Coercion = struct
 	      let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
 		(* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
 		(match c1, c2 with
-		     None, None -> failwith "subtac.coerce': Should have detected equivalence earlier"
-		   | _, _ ->
-		       Some
-			 (fun f -> 
-			   mkLambda (name', a',
-				    app_opt c2
-				      (mkApp (Term.lift 1 f, [| coec1 |])))))
-		  
+		| None, None -> None
+		| _, _ ->
+		    Some
+		      (fun f ->
+			mkLambda (name', a',
+				 app_opt c2
+				   (mkApp (Term.lift 1 f, [| coec1 |])))))
+
 	  | App (c, l), App (c', l') ->
 	      (match kind_of_term c, kind_of_term c' with
 		   Ind i, Ind i' -> (* Inductive types *)
@@ -192,16 +192,16 @@ module Coercion = struct
 		       (* Sigma types *)
 		       if len = Array.length l' && len = 2 && i = i'
 			 && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
-		       then 
-			 if i = Term.destInd existS.typ 
+		       then
+			 if i = Term.destInd existS.typ
 			 then
-			   begin 
-			     let (a, pb), (a', pb') = 
-			       pair_of_array l, pair_of_array l' 
+			   begin
+			     let (a, pb), (a', pb') =
+			       pair_of_array l, pair_of_array l'
 			     in
 			     let c1 = coerce_unify env a a' in
-			     let rec remove_head a c = 
-			       match kind_of_term c with 
+			     let rec remove_head a c =
+			       match kind_of_term c with
 				 | Lambda (n, t, t') -> c, t'
 				     (*| Prod (n, t, t') -> t'*)
 				 | Evar (k, args) ->
@@ -209,7 +209,7 @@ module Coercion = struct
 				       isevars := evs;
 				       let (n, dom, rng) = destLambda t in
 				       let (domk, args) = destEvar dom in
-					 isevars := evar_define domk a !isevars;
+					 isevars := define domk a !isevars;
 					 t, rng
 				 | _ -> raise NoSubtacCoercion
 			     in
@@ -217,43 +217,43 @@ module Coercion = struct
 			     let env' = push_rel (make_name "x", None, a) env in
 			     let c2 = coerce_unify env' b b' in
 			       match c1, c2 with
-				   None, None -> 
+				   None, None ->
 				     None
 				 | _, _ ->
-				     Some 
+				     Some
 				       (fun x ->
-					  let x, y = 
+					  let x, y =
 					    app_opt c1 (mkApp (existS.proj1,
 							       [| a; pb; x |])),
-					    app_opt c2 (mkApp (existS.proj2, 
+					    app_opt c2 (mkApp (existS.proj2,
 							       [| a; pb; x |]))
 					  in
 					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
 			   end
-			 else 
-			   begin 
-			     let (a, b), (a', b') = 
-			       pair_of_array l, pair_of_array l' 
+			 else
+			   begin
+			     let (a, b), (a', b') =
+			       pair_of_array l, pair_of_array l'
 			     in
 			     let c1 = coerce_unify env a a' in
 			     let c2 = coerce_unify env b b' in
 			       match c1, c2 with
 				   None, None -> None
 				 | _, _ ->
-				     Some 
+				     Some
 				       (fun x ->
-					  let x, y = 
+					  let x, y =
 					    app_opt c1 (mkApp (prod.proj1,
 							       [| a; b; x |])),
-					    app_opt c2 (mkApp (prod.proj2, 
+					    app_opt c2 (mkApp (prod.proj2,
 							       [| a; b; x |]))
 					  in
 					    mkApp (prod.intro, [| a'; b'; x ; y |]))
 			   end
 		       else
 			 if i = i' && len = Array.length l' then
-			   let evm = evars_of !isevars in
-			     (try subco () 
+			   let evm =  !isevars in
+			     (try subco ()
 			       with NoSubtacCoercion ->
 				 let typ = Typing.type_of env evm c in
 				 let typ' = Typing.type_of env evm c' in
@@ -264,7 +264,7 @@ module Coercion = struct
 			   subco ()
 		 | x, y when x = y ->
 		     if Array.length l = Array.length l' then
-		       let evm = evars_of !isevars in
+		       let evm =  !isevars in
 		       let lam_type = Typing.type_of env evm c in
 		       let lam_type' = Typing.type_of env evm c' in
 (* 			 if not (is_arity env evm lam_type) then ( *)
@@ -276,25 +276,25 @@ module Coercion = struct
 
     and subset_coerce env isevars x y =
       match disc_subset x with
-	  Some (u, p) -> 
+	  Some (u, p) ->
 	    let c = coerce_unify env u y in
-	    let f x = 
-	      app_opt c (mkApp ((Lazy.force sig_).proj1, 
+	    let f x =
+	      app_opt c (mkApp ((Lazy.force sig_).proj1,
 				[| u; p; x |]))
 	    in Some f
 	| None ->
 	    match disc_subset y with
 		Some (u, p) ->
 		  let c = coerce_unify env x u in
-		    Some 
+		    Some
 		      (fun x ->
 			 let cx = app_opt c x in
 			 let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
 			 in
-			   (mkApp 
-			      ((Lazy.force sig_).intro, 
+			   (mkApp
+			      ((Lazy.force sig_).intro,
 			       [| u; p; cx; evar |])))
-	      | None -> 
+	      | None ->
 		  raise NoSubtacCoercion
 		    (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars;
 		  None*)
@@ -304,7 +304,7 @@ module Coercion = struct
     let evars = ref isevars in
     let coercion = coerce loc env evars t c1 in
       !evars, Option.map (app_opt coercion) v
-	
+
   (* Taken from pretyping/coercion.ml *)
 
   (* Typing operations dealing with coercions *)
@@ -317,11 +317,11 @@ module Coercion = struct
       | h::restl ->
 	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
   	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	    | Prod (_,c1,c2) -> 
+	    | Prod (_,c1,c2) ->
 		(* Typage garanti par l'appel à app_coercion*)
 		apply_rec (h::acc) (subst1 h c2) restl
 	    | _ -> anomaly "apply_coercion_args"
-    in 
+    in
       apply_rec [] funj.uj_type argl
 
   (* appliquer le chemin de coercions de patterns p *)
@@ -342,22 +342,22 @@ module Coercion = struct
   (* appliquer le chemin de coercions p à hj *)
 
   let apply_coercion env sigma p hj typ_cl =
-    try 
+    try
       fst (List.fold_left
-             (fun (ja,typ_cl) i -> 
+             (fun (ja,typ_cl) i ->
 		let fv,isid = coercion_value i in
 		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
 		let jres = apply_coercion_args env argl fv in
-		  (if isid then 
+		  (if isid then
 		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
-		   else 
+		   else
 		     jres),
 		jres.uj_type)
              (hj,typ_cl) p)
     with _ -> anomaly "apply_coercion"
 
-  let inh_app_fun env isevars j = 
-    let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+  let inh_app_fun env isevars j =
+    let t = whd_betadeltaiota env ( isevars) j.uj_type in
       match kind_of_term t with
 	| Prod (_,_,_) -> (isevars,j)
 	| Evar ev when not (is_defined_evar isevars ev) ->
@@ -366,10 +366,10 @@ module Coercion = struct
 	| _ ->
        	    (try
       	       let t,p =
-		 lookup_path_to_fun_from env (evars_of isevars) j.uj_type in
-		 (isevars,apply_coercion env (evars_of isevars) p j t)
+		 lookup_path_to_fun_from env ( isevars) j.uj_type in
+		 (isevars,apply_coercion env ( isevars) p j t)
 	     with Not_found ->
-	       try 
+	       try
 		 let coercef, t = mu env isevars t in
 		   (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t })
 	       with NoSubtacCoercion | NoCoercion ->
@@ -377,14 +377,14 @@ module Coercion = struct
 
   let inh_tosort_force loc env isevars j =
     try
-      let t,p = lookup_path_to_sort_from env (evars_of isevars) j.uj_type in
-      let j1 = apply_coercion env (evars_of isevars) p j t in 
-	(isevars,type_judgment env (j_nf_evar (evars_of isevars) j1))
+      let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in
+      let j1 = apply_coercion env ( isevars) p j t in
+	(isevars,type_judgment env (j_nf_evar ( isevars) j1))
     with Not_found ->
-      error_not_a_type_loc loc env (evars_of isevars) j
+      error_not_a_type_loc loc env ( isevars) j
 
   let inh_coerce_to_sort loc env isevars j =
-    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+    let typ = whd_betadeltaiota env ( isevars) j.uj_type in
       match kind_of_term typ with
 	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
 	| Evar ev when not (is_defined_evar isevars ev) ->
@@ -394,31 +394,31 @@ module Coercion = struct
 	    inh_tosort_force loc env isevars j
 
   let inh_coerce_to_base loc env isevars j =
-    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+    let typ = whd_betadeltaiota env ( isevars) j.uj_type in
     let ct, typ' = mu env isevars typ in
-      isevars, { uj_val = app_opt ct j.uj_val; 
+      isevars, { uj_val = app_opt ct j.uj_val;
 		 uj_type = typ' }
 
   let inh_coerce_to_prod loc env isevars t =
-    let typ = whd_betadeltaiota env (evars_of isevars) (snd t) in
+    let typ = whd_betadeltaiota env ( isevars) (snd t) in
     let _, typ' = mu env isevars typ in
       isevars, (fst t, typ')
-	
+
   let inh_coerce_to_fail env evd rigidonly v t c1 =
     if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
     then
       raise NoCoercion
     else
     let v', t' =
-      try 
-	let t2,t1,p = lookup_path_between env (evars_of evd) (t,c1) in
+      try
+	let t2,t1,p = lookup_path_between env ( evd) (t,c1) in
 	  match v with
-	      Some v -> 
-		let j = apply_coercion env (evars_of evd) p
+	      Some v ->
+		let j = apply_coercion env ( evd) p
 		  {uj_val = v; uj_type = t} t2 in
 		  Some j.uj_val, j.uj_type
 	    | None -> None, t
-      with Not_found -> raise NoCoercion 
+      with Not_found -> raise NoCoercion
     in
       try (the_conv_x_leq env t' c1 evd, v')
       with Reduction.NotConvertible -> raise NoCoercion
@@ -430,15 +430,15 @@ module Coercion = struct
     try inh_coerce_to_fail env evd rigidonly v t c1
     with NoCoercion ->
     match
-      kind_of_term (whd_betadeltaiota env (evars_of evd) t),
-      kind_of_term (whd_betadeltaiota env (evars_of evd) c1)
+      kind_of_term (whd_betadeltaiota env ( evd) t),
+      kind_of_term (whd_betadeltaiota env ( evd) c1)
     with
-    | Prod (name,t1,t2), Prod (_,u1,u2) -> 
+    | Prod (name,t1,t2), Prod (_,u1,u2) ->
         (* Conversion did not work, we may succeed with a coercion. *)
         (* We eta-expand (hence possibly modifying the original term!) *)
 	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
 	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
-	let name = match name with 
+	let name = match name with
 	  | Anonymous -> Name (id_of_string "x")
 	  | _ -> name in
 	let env1 = push_rel (name,None,u1) env in
@@ -454,16 +454,15 @@ module Coercion = struct
 
   (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
   let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
-    let evd = nf_evar_defs evd in
     match n with
 	None ->
-	  let (evd', val') = 
-	    try 
+	  let (evd', val') =
+	    try
 	      inh_conv_coerce_to_fail loc env evd rigidonly
-		(Some (nf_isevar evd cj.uj_val))
-		(nf_isevar evd cj.uj_type) (nf_isevar evd t)
+		(Some (nf_evar evd cj.uj_val))
+		(nf_evar evd cj.uj_type) (nf_evar evd t)
 	    with NoCoercion ->
-	      let sigma = evars_of evd in
+	      let sigma =  evd in
 		try
 		  coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
 		with NoSubtacCoercion ->
@@ -483,8 +482,8 @@ module Coercion = struct
 	  None -> 0, 0
 	| Some (init, cur) -> init, cur
     in
-      try 
-	let rels, rng = Reductionops.decomp_n_prod env (evars_of isevars) nabs t in
+      try
+	let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in
 	(* The final range free variables must have been replaced by evars, we accept only that evars
 	   in rng are applied to free vars. *)
 	if noccur_with_meta 1 (succ nabs) rng then (
@@ -497,7 +496,7 @@ module Coercion = struct
 		   with NoCoercion ->
 		     coerce_itf loc env' isevars None t t')
 	    with NoSubtacCoercion ->
-	      let sigma = evars_of isevars in
+	      let sigma =  isevars in
 		error_cannot_coerce env' sigma (t, t'))
 	else isevars
       with _ -> isevars
diff --git a/contrib/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli
index 5678c10e..5678c10e 100644
--- a/contrib/subtac/subtac_coercion.mli
+++ b/plugins/subtac/subtac_coercion.mli
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
new file mode 100644
index 00000000..f2747225
--- /dev/null
+++ b/plugins/subtac/subtac_command.ml
@@ -0,0 +1,534 @@
+open Closure
+open RedFlags
+open Declarations
+open Entries
+open Libobject
+open Pattern
+open Matching
+open Pp
+open Rawterm
+open Sign
+open Tacred
+open Util
+open Names
+open Nameops
+open Libnames
+open Nametab
+open Pfedit
+open Proof_type
+open Refiner
+open Tacmach
+open Tactic_debug
+open Topconstr
+open Term
+open Termops
+open Tacexpr
+open Safe_typing
+open Typing
+open Hiddentac
+open Genarg
+open Decl_kinds
+open Mod_subst
+open Printer
+open Inductiveops
+open Syntax_def
+open Environ
+open Tactics
+open Tacticals
+open Tacinterp
+open Vernacexpr
+open Notation
+open Evd
+open Evarutil
+
+module SPretyping = Subtac_pretyping.Pretyping
+open Subtac_utils
+open Pretyping
+open Subtac_obligations
+
+(*********************************************************************)
+(* Functions to parse and interpret constructions *)
+
+let evar_nf isevars c =
+  Evarutil.nf_evar !isevars c
+
+let interp_gen kind isevars env
+               ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
+               c =
+  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in
+  let c' = SPretyping.understand_tcc_evars isevars env kind c' in
+    evar_nf isevars c'
+
+let interp_constr isevars env c =
+  interp_gen (OfType None) isevars env c
+
+let interp_type_evars isevars env ?(impls=([],[])) c =
+  interp_gen IsType isevars env ~impls c
+
+let interp_casted_constr isevars env ?(impls=([],[])) c typ =
+  interp_gen (OfType (Some typ)) isevars env ~impls c
+
+let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ =
+  interp_gen (OfType (Some typ)) isevars env ~impls c
+
+let interp_open_constr isevars env c =
+    msgnl (str "Pretyping " ++ my_print_constr_expr c);
+  let c = Constrintern.intern_constr ( !isevars) env c in
+  let c' = SPretyping.understand_tcc_evars isevars env (OfType None) c in
+    evar_nf isevars c'
+
+let interp_constr_judgment isevars env c =
+  let j =
+    SPretyping.understand_judgment_tcc isevars env
+      (Constrintern.intern_constr ( !isevars) env c)
+  in
+    { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
+
+let locate_if_isevar loc na = function
+  | RHole _ ->
+      (try match na with
+	| Name id ->  Reserve.find_reserved_type id
+	| Anonymous -> raise Not_found
+      with Not_found -> RHole (loc, Evd.BinderType na))
+  | x -> x
+
+let interp_binder sigma env na t =
+  let t = Constrintern.intern_gen true ( !sigma) env t in
+    SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_rawconstr t) na t)
+
+let interp_context_evars evdref env params =
+  let bl = Constrintern.intern_context false ( !evdref) env params in
+  let (env, par, _, impls) =
+    List.fold_left
+      (fun (env,params,n,impls) (na, k, b, t) ->
+	match b with
+	    None ->
+	      let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+	      let t = SPretyping.understand_tcc_evars evdref env IsType t' in
+	      let d = (na,None,t) in
+	      let impls =
+		if k = Implicit then
+		  let na = match na with Name n -> Some n | Anonymous -> None in
+		    (ExplByPos (n, na), (true, true, true)) :: impls
+		else impls
+	      in
+		(push_rel d env, d::params, succ n, impls)
+	  | Some b ->
+	      let c = SPretyping.understand_judgment_tcc evdref env b in
+	      let d = (na, Some c.uj_val, c.uj_type) in
+		(push_rel d env,d::params, succ n, impls))
+      (env,[],1,[]) (List.rev bl)
+  in (env, par), impls
+
+(* try to find non recursive definitions *)
+
+let list_chop_hd i l = match list_chop i l with
+  | (l1,x::l2) -> (l1,x,l2)
+  | (x :: [], l2) -> ([], x, [])
+  | _ -> assert(false)
+
+let collect_non_rec env =
+  let rec searchrec lnonrec lnamerec ldefrec larrec nrec =
+    try
+      let i =
+        list_try_find_i
+          (fun i f ->
+             if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
+             then i else failwith "try_find_i")
+          0 lnamerec
+      in
+      let (lf1,f,lf2) = list_chop_hd i lnamerec in
+      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
+      let (lar1,ar,lar2) = list_chop_hd i larrec in
+      let newlnv =
+	try
+	  match list_chop i nrec with
+            | (lnv1,_::lnv2) -> (lnv1@lnv2)
+	    | _ -> [] (* nrec=[] for cofixpoints *)
+        with Failure "list_chop" -> []
+      in
+      searchrec ((f,def,ar)::lnonrec)
+	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
+    with Failure "try_find_i" ->
+      (List.rev lnonrec,
+       (Array.of_list lnamerec, Array.of_list ldefrec,
+        Array.of_list larrec, Array.of_list nrec))
+  in
+  searchrec []
+
+let list_of_local_binders l =
+  let rec aux acc = function
+      Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
+    | Topconstr.LocalRawAssum (nl, k, c) :: tl ->
+	aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
+    | [] -> List.rev acc
+  in aux [] l
+
+let lift_binders k n l =
+  let rec aux n = function
+    | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
+    | [] -> []
+  in aux n l
+
+let rec gen_rels = function
+    0 -> []
+  | n -> mkRel n :: gen_rels (pred n)
+
+let split_args n rel = match list_chop ((List.length rel) - n) rel with
+    (l1, x :: l2) -> l1, x, l2
+  | _ -> assert(false)
+
+open Coqlib
+
+let sigT = Lazy.lazy_from_fun build_sigma_type
+let sigT_info = lazy
+  { ci_ind       = destInd (Lazy.force sigT).typ;
+    ci_npar      = 2;
+    ci_cstr_nargs = [|2|];
+    ci_pp_info   =  { ind_nargs = 0; style = LetStyle }
+  }
+
+let telescope = function
+  | [] -> assert false
+  | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
+  | (n, None, t) :: tl ->
+      let ty, tys, (k, constr) =
+	List.fold_left
+	  (fun (ty, tys, (k, constr)) (n, b, t) ->
+	    let pred = mkLambda (n, t, ty) in
+	    let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in
+	    let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in
+	      (sigty, pred :: tys, (succ k, intro)))
+	  (t, [], (2, mkRel 1)) tl
+      in
+      let (last, subst) = List.fold_right2
+	(fun pred (n, b, t) (prev, subst) ->
+	  let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in
+	  let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in
+	    (lift 1 proj2, (n, Some proj1, t) :: subst))
+	(List.rev tys) tl (mkRel 1, [])
+      in ty, ((n, Some last, t) :: subst), constr
+
+  | _ -> raise (Invalid_argument "telescope")
+
+let nf_evar_context isevars ctx =
+  List.map (fun (n, b, t) ->
+    (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx
+
+let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
+  Coqlib.check_required_library ["Coq";"Program";"Wf"];
+  let sigma = Evd.empty in
+  let isevars = ref (Evd.create_evar_defs sigma) in
+  let env = Global.env() in
+  let _pr c = my_print_constr env c in
+  let _prr = Printer.pr_rel_context env in
+  let _prn = Printer.pr_named_context env in
+  let _pr_rel env = Printer.pr_rel_context env in
+  let (env', binders_rel), impls = interp_context_evars isevars env bl in
+  let len = List.length binders_rel in
+  let top_env = push_rel_context binders_rel env in
+  let top_arity = interp_type_evars isevars top_env arityc in
+  let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
+  let argtyp, letbinders, make = telescope binders_rel in
+  let argname = id_of_string "recarg" in
+  let arg = (Name argname, None, argtyp) in
+  let binders = letbinders @ [arg] in
+  let binders_env = push_rel_context binders_rel env in
+  let rel = interp_constr isevars env r in
+  let relty = type_of env !isevars rel in
+  let relargty =
+    let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
+      match ctx, kind_of_term ar with
+      | [(_, None, t); (_, None, u)], Sort (Prop Null)
+	  when Reductionops.is_conv env !isevars t u -> t
+      | _, _ ->
+	  user_err_loc (constr_loc r,
+		       "Subtac_command.build_wellfounded",
+		       my_print_constr env rel ++ str " is not an homogeneous binary relation.")
+  in
+  let measure = interp_casted_constr isevars binders_env measure relargty in
+  let wf_rel, wf_rel_fun, measure_fn =
+    let measure_body, measure =
+      it_mkLambda_or_LetIn measure letbinders,
+      it_mkLambda_or_LetIn measure binders
+    in
+    let comb = constr_of_global (Lazy.force measure_on_R_ref) in
+    let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
+    let wf_rel_fun x y =
+      mkApp (rel, [| subst1 x measure_body;
+ 		     subst1 y measure_body |])
+    in wf_rel, wf_rel_fun, measure
+  in
+  let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in
+  let argid' = id_of_string (string_of_id argname ^ "'") in
+  let wfarg len = (Name argid', None,
+  		  mkSubset (Name argid') argtyp
+		    (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
+  in
+  let intern_bl = wfarg 1 :: [arg] in
+  let _intern_env = push_rel_context intern_bl env in
+  let proj = (Lazy.force sig_).Coqlib.proj1 in
+  let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
+  let projection = (* in wfarg :: arg :: before *)
+    mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
+  in
+  let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
+  let intern_arity = substl [projection] top_arity_let in
+  (* substitute the projection of wfarg for something,
+     now intern_arity is in wfarg :: arg *)
+  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
+  let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
+  let curry_fun =
+    let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
+    let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
+    let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
+    let rcurry = mkApp (rel, [| measure; lift len measure |]) in
+    let lam = (Name (id_of_string "recproof"), None, rcurry) in
+    let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
+    let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
+      (Name recname, Some body, ty)
+  in
+  let fun_bl = intern_fun_binder :: [arg] in
+  let lift_lets = Termops.lift_rel_context 1 letbinders in
+  let intern_body =
+    let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
+    let (r, l, impls, scopes) = 
+      Constrintern.compute_internalization_data env
+	Constrintern.Recursive full_arity impls 
+    in
+    let newimpls = [(recname, (r, l, impls @ 
+      [Some (id_of_string "recproof", Impargs.Manual, (true, false))], 
+			      scopes @ [None]))] in
+    let newimpls = Constrintern.set_internalization_env_params newimpls [] in
+    interp_casted_constr isevars ~impls:newimpls
+      (push_rel_context ctx env) body (lift 1 top_arity)
+  in
+  let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
+  let prop = mkLambda (Name argname, argtyp, top_arity_let) in
+  let def =
+    mkApp (constr_of_global (Lazy.force fix_sub_ref),
+	  [| argtyp ; wf_rel ;
+	     make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
+	     prop ; intern_body_lam |])
+  in
+  let _ = isevars := Evarutil.nf_evar_map !isevars in
+  let binders_rel = nf_evar_context !isevars binders_rel in
+  let binders = nf_evar_context !isevars binders in
+  let top_arity = Evarutil.nf_evar !isevars top_arity in
+  let hook, recname, typ = 
+    if List.length binders_rel > 1 then
+      let name = add_suffix recname "_func" in
+      let hook l gr = 
+	let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in
+	let ty = it_mkProd_or_LetIn top_arity binders_rel in
+	let ce =
+	  { const_entry_body = Evarutil.nf_evar !isevars body;
+	    const_entry_type = Some ty;
+	    const_entry_opaque = false;
+	    const_entry_boxed = false} 
+	in 
+	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
+	let gr = ConstRef c in
+	  if Impargs.is_implicit_args () || impls <> [] then
+	    Impargs.declare_manual_implicits false gr impls
+      in
+      let typ = it_mkProd_or_LetIn top_arity binders in
+	hook, name, typ
+    else 
+      let typ = it_mkProd_or_LetIn top_arity binders_rel in
+      let hook l gr = 
+	if Impargs.is_implicit_args () || impls <> [] then
+	  Impargs.declare_manual_implicits false gr impls
+      in hook, recname, typ
+  in
+  let fullcoqc = Evarutil.nf_evar !isevars def in
+  let fullctyp = Evarutil.nf_evar !isevars typ in
+  let evm = evars_of_term !isevars Evd.empty fullctyp in
+  let evm = evars_of_term !isevars evm fullcoqc in
+  let evm = non_instanciated_map env isevars evm in
+  let evars, _, evars_def, evars_typ = 
+    Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp 
+  in
+    Subtac_obligations.add_definition recname ~term:evars_def evars_typ evars ~hook
+
+let interp_fix_context evdref env fix =
+  interp_context_evars evdref env fix.Command.fix_binders
+
+let interp_fix_ccl evdref (env,_) fix =
+  interp_type_evars evdref env fix.Command.fix_type
+
+let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
+  let env = push_rel_context ctx env_rec in
+  let body = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in
+  Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body
+
+let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
+
+let prepare_recursive_declaration fixnames fixtypes fixdefs =
+  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
+  let names = List.map (fun id -> Name id) fixnames in
+  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
+
+let rel_index n ctx =
+  list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
+
+let rec unfold f b =
+  match f b with
+    | Some (x, b') -> x :: unfold f b'
+    | None -> []
+
+let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
+  match n with
+  | Some (loc, n) -> [rel_index n fixctx]
+  | None ->
+      (* If recursive argument was not given by user, we try all args.
+	 An earlier approach was to look only for inductive arguments,
+	 but doing it properly involves delta-reduction, and it finally
+         doesn't seem to worth the effort (except for huge mutual
+	 fixpoints ?) *)
+      let len = List.length fixctx in
+	unfold (function x when x = len -> None
+	  | n -> Some (n, succ n)) 0
+
+let push_named_context = List.fold_right push_named
+
+let check_evars env initial_sigma evd c =
+  let sigma =  evd in
+  let c = nf_evar sigma c in
+  let rec proc_rec c =
+    match kind_of_term c with
+      | Evar (evk,args) ->
+          assert (Evd.mem sigma evk);
+	  if not (Evd.mem initial_sigma evk) then
+            let (loc,k) = evar_source evk evd in
+	      (match k with
+	      | QuestionMark _
+	      | ImplicitArg (_, _, false) -> ()
+	      | _ ->
+		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
+		    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None)
+      | _ -> iter_constr proc_rec c
+  in proc_rec c
+
+let out_def = function
+  | Some def -> def
+  | None -> error "Program Fixpoint needs defined bodies."
+
+let interp_recursive fixkind l boxed =
+  let env = Global.env() in
+  let fixl, ntnl = List.split l in
+  let kind = fixkind <> IsCoFixpoint in
+  let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
+
+  (* Interp arities allowing for unresolved types *)
+  let evdref = ref Evd.empty in
+  let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in
+  let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
+  let fixtypes = List.map2 build_fix_type fixctxs fixccls in
+  let rec_sign =
+    List.fold_left2 (fun env' id t ->
+      let sort = Retyping.get_type_of env !evdref t in
+      let fixprot =
+	try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|])
+	with e -> t
+      in
+	(id,None,fixprot) :: env')
+      [] fixnames fixtypes
+  in
+  let env_rec = push_named_context rec_sign env in
+
+  (* Get interpretation metadatas *)
+  let impls = Constrintern.compute_full_internalization_env env 
+    Constrintern.Recursive [] fixnames fixtypes fiximps 
+  in
+  let notations = List.flatten ntnl in
+
+  (* Interp bodies with rollback because temp use of notations/implicit *)
+  let fixdefs =
+    States.with_state_protection (fun () ->
+      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
+      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
+      () in
+
+  let fixdefs = List.map out_def fixdefs in
+
+  (* Instantiate evars and check all are resolved *)
+  let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
+  let evd = Typeclasses.resolve_typeclasses
+    ~onlyargs:true ~split:true ~fail:false env_rec evd
+  in
+  let evd = Evarutil.nf_evar_map evd in
+  let fixdefs = List.map (nf_evar evd) fixdefs in
+  let fixtypes = List.map (nf_evar evd) fixtypes in
+  let rec_sign = nf_named_context_evar evd rec_sign in
+
+  let recdefs = List.length rec_sign in
+  List.iter (check_evars env_rec Evd.empty evd) fixdefs;
+  List.iter (check_evars env Evd.empty evd) fixtypes;
+  Command.check_mutuality env kind (List.combine fixnames fixdefs);
+
+  (* Russell-specific code *)
+
+  (* Get the interesting evars, those that were not instanciated *)
+  let isevars = Evd.undefined_evars evd in
+  let evm =  isevars in
+  (* Solve remaining evars *)
+  let rec collect_evars id def typ imps =
+      (* Generalize by the recursive prototypes  *)
+    let def =
+      Termops.it_mkNamedLambda_or_LetIn def rec_sign
+    and typ =
+      Termops.it_mkNamedProd_or_LetIn typ rec_sign
+    in
+    let evm' = Subtac_utils.evars_of_term evm Evd.empty def in
+    let evm' = Subtac_utils.evars_of_term evm evm' typ in
+    let evars, _, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in
+      (id, def, typ, imps, evars)
+  in
+  let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
+    (match fixkind with
+      | IsFixpoint wfl ->
+	  let possible_indexes =
+	    list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
+	  let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
+	    Array.of_list fixtypes,
+	    Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
+	  in
+	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
+	    list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l
+      | IsCoFixpoint -> ());
+    Subtac_obligations.add_mutual_definitions defs notations fixkind
+
+let out_n = function
+    Some n -> n
+  | None -> raise Not_found
+
+let build_recursive l b =
+  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
+    match g, l with
+	[(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
+	  ignore(build_wellfounded (id, n, bl, typ, out_def def) r
+		    (match n with Some n -> mkIdentC (snd n) | None ->
+		      errorlabstrm "Subtac_command.build_recursive"
+			(str "Recursive argument required for well-founded fixpoints"))
+		    ntn false)
+
+      | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] ->
+	  ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r)
+		    m ntn false)
+
+      | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
+	  let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) ->
+	    ({Command.fix_name = id; Command.fix_binders = bl; 
+	      Command.fix_body = def; Command.fix_type = typ},ntn)) l
+	  in interp_recursive (IsFixpoint g) fixl b
+      | _, _ ->
+	  errorlabstrm "Subtac_command.build_recursive"
+	    (str "Well-founded fixpoints not allowed in mutually recursive blocks")
+
+let build_corecursive l b =
+  let fixl = List.map (fun (((_,id),bl,typ,def),ntn) ->
+    ({Command.fix_name = id; Command.fix_binders = bl; 
+      Command.fix_body = def; Command.fix_type = typ},ntn))
+    l in
+  interp_recursive IsCoFixpoint fixl b
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
new file mode 100644
index 00000000..304aa139
--- /dev/null
+++ b/plugins/subtac/subtac_command.mli
@@ -0,0 +1,60 @@
+open Pretyping
+open Evd
+open Environ
+open Term
+open Topconstr
+open Names
+open Libnames
+open Pp
+open Vernacexpr
+open Constrintern
+
+val interp_gen :
+  typing_constraint ->
+  evar_map ref ->
+  env ->
+  ?impls:full_internalization_env ->
+  ?allow_patvar:bool ->
+  ?ltacvars:ltac_sign ->
+  constr_expr -> constr
+val interp_constr :
+  evar_map ref ->
+  env -> constr_expr -> constr
+val interp_type_evars :
+  evar_map ref ->
+  env ->
+  ?impls:full_internalization_env ->
+  constr_expr -> constr
+val interp_casted_constr_evars :
+  evar_map ref ->
+  env ->
+  ?impls:full_internalization_env ->
+  constr_expr -> types -> constr
+val interp_open_constr :
+  evar_map ref -> env -> constr_expr -> constr
+val interp_constr_judgment :
+  evar_map ref ->
+  env ->
+  constr_expr -> unsafe_judgment
+val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
+
+val interp_binder :     Evd.evar_map ref ->
+    Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
+
+
+val telescope :
+  (Names.name * 'a option * Term.types) list ->
+  Term.types * (Names.name * Term.types option * Term.types) list *
+    Term.constr
+
+val build_wellfounded :
+           Names.identifier * 'a * Topconstr.local_binder list *
+           Topconstr.constr_expr * Topconstr.constr_expr ->
+           Topconstr.constr_expr ->
+           Topconstr.constr_expr -> 'b -> 'c -> Subtac_obligations.progress
+
+val build_recursive :
+  (fixpoint_expr * decl_notation list) list -> bool -> unit
+
+val build_corecursive :
+  (cofixpoint_expr * decl_notation list) list -> bool -> unit
diff --git a/contrib/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml
index 3bbfe22b..067da150 100644
--- a/contrib/subtac/subtac_errors.ml
+++ b/plugins/subtac/subtac_errors.ml
@@ -4,12 +4,12 @@ open Printer
 
 type term_pp = Pp.std_ppcmds
 
-type subtyping_error = 
+type subtyping_error =
   | UncoercibleInferType of loc * term_pp * term_pp
   | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp
   | UncoercibleRewrite of term_pp * term_pp
 
-type typing_error = 
+type typing_error =
   | NonFunctionalApp of loc * term_pp * term_pp * term_pp
   | NonConvertible of loc * term_pp * term_pp
   | NonSigma of loc * term_pp
@@ -17,7 +17,7 @@ type typing_error =
 
 exception Subtyping_error of subtyping_error
 exception Typing_error of typing_error
-  
+
 exception Debug_msg of string
 
 let typing_error e = raise (Typing_error e)
diff --git a/contrib/subtac/subtac_errors.mli b/plugins/subtac/subtac_errors.mli
index 8d75b9c0..8d75b9c0 100644
--- a/contrib/subtac/subtac_errors.mli
+++ b/plugins/subtac/subtac_errors.mli
diff --git a/contrib/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
index 3dcd43d2..2836bc73 100644
--- a/contrib/subtac/subtac_obligations.ml
+++ b/plugins/subtac/subtac_obligations.ml
@@ -1,4 +1,4 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 open Printf
 open Pp
 open Subtac_utils
@@ -21,6 +21,9 @@ let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
 let pperror cmd = Util.errorlabstrm "Program" cmd
 let error s = pperror (str s)
 
+let reduce =
+  Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty
+
 exception NoObligations of identifier option
 
 let explain_no_obligations = function
@@ -28,21 +31,25 @@ let explain_no_obligations = function
   | None -> str "No obligations remaining"
 
 type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t
-			 * Tacexpr.raw_tactic_expr option) array
-  
+			 * tactic option) array
+
 type obligation =
-    { obl_name : identifier;
-      obl_type : types;
-      obl_location : loc;
-      obl_body : constr option;
-      obl_status : obligation_definition_status;
-      obl_deps : Intset.t;
-      obl_tac : Tacexpr.raw_tactic_expr option;
-    }
+  { obl_name : identifier;
+    obl_type : types;
+    obl_location : loc;
+    obl_body : constr option;
+    obl_status : obligation_definition_status;
+    obl_deps : Intset.t;
+    obl_tac : tactic option;
+  }
 
 type obligations = (obligation array * int)
 
-type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list
+type fixpoint_kind =
+  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
+  | IsCoFixpoint
+
+type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
 
 type program_info = {
   prg_name: identifier;
@@ -50,8 +57,8 @@ type program_info = {
   prg_type: constr;
   prg_obligations: obligations;
   prg_deps : identifier list;
-  prg_fixkind : Command.fixpoint_kind option ;
-  prg_implicits : (Topconstr.explicitation * (bool * bool)) list;
+  prg_fixkind : fixpoint_kind option ;
+  prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list;
   prg_notations : notations ;
   prg_kind : definition_kind;
   prg_hook : Tacexpr.declaration_hook;
@@ -74,18 +81,18 @@ let get_proofs_transparency () = !proofs_transparency
 open Goptions
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "transparency of Program obligations";
-      optkey   = (SecondaryTable ("Transparent","Obligations"));
+      optkey   = ["Transparent";"Obligations"];
       optread  = get_proofs_transparency;
-      optwrite = set_proofs_transparency; } 
+      optwrite = set_proofs_transparency; }
 
 let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
 
 let get_obligation_body expand obl =
   let c = Option.get obl.obl_body in
-    if expand && obl.obl_status = Expand then 
+    if expand && obl.obl_status = Expand then
       match kind_of_term c with
       | Const c -> constant_value (Global.env ()) c
       | _ -> c
@@ -96,89 +103,114 @@ let subst_deps expand obls deps t =
     Intset.fold
       (fun x acc ->
 	let xobl = obls.(x) in
-	let oblb = 
+	let oblb =
 	  try get_obligation_body expand xobl
 	  with _ -> assert(false)
 	in (xobl.obl_name, oblb) :: acc)
       deps []
   in(*  Termops.it_mkNamedProd_or_LetIn t subst *)
     Term.replace_vars subst t
-    
+
 let subst_deps_obl obls obl =
-  let t' = subst_deps false obls obl.obl_deps obl.obl_type in
+  let t' = subst_deps true obls obl.obl_deps obl.obl_type in
     { obl with obl_type = t' }
 
 module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
 
 let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
 
-let map_cardinal m = 
-  let i = ref 0 in 
+let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
+
+let map_cardinal m =
+  let i = ref 0 in
     ProgMap.iter (fun _ _ -> incr i) m;
     !i
 
 exception Found of program_info
 
-let map_first m = 
+let map_first m =
   try
     ProgMap.iter (fun _ v -> raise (Found v)) m;
     assert(false)
   with Found x -> x
-    
+
 let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
 
 let freeze () = !from_prg, !default_tactic_expr
 let unfreeze (v, t) = from_prg := v; set_default_tactic t
 let init () =
-  from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.tactics_call "obligation_tactic" [])
+  from_prg := ProgMap.empty; set_default_tactic (Tacexpr.TacId [])
+
+(** Beware: if this code is dynamically loaded via dynlink after the start
+    of Coq, then this [init] function will not be run by [Lib.init ()].
+    Luckily, here we can launch [init] at load-time. *)
+
+let _ = init ()
 
-let _ = 
+let _ =
   Summary.declare_summary "program-tcc-table"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
 
 let progmap_union = ProgMap.fold ProgMap.add
 
-let cache (_, (infos, tac)) =
-  from_prg := infos;
+let cache (_, (local, tac)) =
   set_default_tactic tac
 
-let (input,output) = 
+let load (_, (local, tac)) =
+  if not local then set_default_tactic tac
+
+let subst (s, (local, tac)) =
+  (local, Tacinterp.subst_tactic s tac)
+
+let (input,output) =
   declare_object
     { (default_object "Program state") with
       cache_function = cache;
-      load_function = (fun _ -> cache);
-      open_function = (fun _ -> cache);
-      classify_function = (fun _ -> Dispose);
-      export_function = (fun x -> Some x) }
+      load_function = (fun _ -> load);
+      open_function = (fun _ -> load);
+      classify_function = (fun (local, tac) ->
+	if not (ProgMap.is_empty !from_prg) then
+	  errorlabstrm "Program" (str "Unsolved obligations when closing module:" ++ spc () ++
+				     prlist_with_sep spc (fun x -> Nameops.pr_id x)
+				     (map_keys !from_prg));
+	if local then Dispose else Substitute (local, tac));
+      subst_function = subst}
     
+let update_state local =
+  Lib.add_anonymous_leaf (input (local, !default_tactic_expr))
+
+let set_default_tactic local t =
+  set_default_tactic t; update_state local
+
 open Evd
-	  
+
+let progmap_remove prg =
+  from_prg := ProgMap.remove prg.prg_name !from_prg
+
 let rec intset_to = function
     -1 -> Intset.empty
   | n -> Intset.add n (intset_to (pred n))
-  
-let subst_body expand prg = 
+
+let subst_body expand prg =
   let obls, _ = prg.prg_obligations in
   let ints = intset_to (pred (Array.length obls)) in
     subst_deps expand obls ints prg.prg_body,
   subst_deps expand obls ints (Termops.refresh_universes prg.prg_type)
-    
+
 let declare_definition prg =
-  let body, typ = subst_body false prg in
+  let body, typ = subst_body true prg in
     (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++
-		  my_print_constr (Global.env()) body ++ str " : " ++ 
+		  my_print_constr (Global.env()) body ++ str " : " ++
 		  my_print_constr (Global.env()) prg.prg_type);
      with _ -> ());
   let (local, boxed, kind) = prg.prg_kind in
-  let ce = 
+  let ce =
     { const_entry_body = body;
       const_entry_type = Some typ;
       const_entry_opaque = false;
-      const_entry_boxed = boxed} 
+      const_entry_boxed = boxed}
   in
     (Command.get_declare_definition_hook ()) ce;
     match local with
@@ -187,20 +219,22 @@ let declare_definition prg =
           SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in
         let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in
           print_message (Subtac_utils.definition_message prg.prg_name);
-          if Pfedit.refining () then 
-            Flags.if_verbose msg_warning 
-	      (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ 
+          if Pfedit.refining () then
+            Flags.if_verbose msg_warning
+	      (str"Local definition " ++ Nameops.pr_id prg.prg_name ++
 		  str" is not visible from current goals");
+	  progmap_remove prg; 
           VarRef prg.prg_name
     | (Global|Local) ->
 	let c =
-	  Declare.declare_constant 
+	  Declare.declare_constant
 	    prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind))
 	in
 	let gr = ConstRef c in
 	  if Impargs.is_implicit_args () || prg.prg_implicits <> [] then
 	    Impargs.declare_manual_implicits false gr prg.prg_implicits;
 	  print_message (Subtac_utils.definition_message prg.prg_name);
+	  progmap_remove prg; 
 	  prg.prg_hook local gr;
 	  gr
 
@@ -213,31 +247,30 @@ let rec lam_index n t acc =
 	if na = Name n then acc
 	else lam_index n b (succ acc)
     | _ -> raise Not_found
-	
+
 let compute_possible_guardness_evidences (n,_) fixbody fixtype =
-  match n with 
+  match n with
   | Some (loc, n) -> [lam_index n fixbody 0]
-  | None -> 
+  | None ->
       (* If recursive argument was not given by user, we try all args.
 	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally 
-         doesn't seem to worth the effort (except for huge mutual 
+	 but doing it properly involves delta-reduction, and it finally
+         doesn't seem to worth the effort (except for huge mutual
 	 fixpoints ?) *)
       let m = Term.nb_prod fixtype in
-      let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in
+      let ctx = fst (decompose_prod_n_assum m fixtype) in
 	list_map_i (fun i _ -> i) 0 ctx
 
-let reduce_fix =
-  Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty
-
 let declare_mutual_definition l =
   let len = List.length l in
   let first = List.hd l in
-  let fixdefs, fixtypes, fiximps = 
+  let fixdefs, fixtypes, fiximps =
     list_split3
       (List.map (fun x -> 
-	let subs, typ = (subst_body false x) in
-	  snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l)
+	let subs, typ = (subst_body true x) in
+	let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
+	let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
+	  reduce term, reduce typ, x.prg_implicits) l)
   in
 (*   let fixdefs = List.map reduce_fix fixdefs in *)
   let fixkind = Option.get first.prg_fixkind in
@@ -255,77 +288,89 @@ let declare_mutual_definition l =
 	    Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l
       | IsCoFixpoint ->
 	  None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
-  in      
+  in
   (* Declare the recursive definitions *)
   let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in
     (* Declare notations *)
-    List.iter (Command.declare_interning_data ([],[])) first.prg_notations;
-    Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames);
+    List.iter Metasyntax.add_notation_interpretation first.prg_notations;
+    Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames;
     let gr = List.hd kns in
     let kn = match gr with ConstRef kn -> kn | _ -> assert false in
-      first.prg_hook local gr; kn
+      first.prg_hook local gr;
+      List.iter progmap_remove l; kn
       
-let declare_obligation obl body =
+let declare_obligation prg obl body =
+  let body = reduce body in
+  let ty = reduce obl.obl_type in
   match obl.obl_status with
   | Expand -> { obl with obl_body = Some body }
   | Define opaque ->
+      let opaque = if get_proofs_transparency () then false else opaque in
       let ce = 
 	{ const_entry_body = body;
-	  const_entry_type = Some obl.obl_type;
-	  const_entry_opaque = 
-	    (if get_proofs_transparency () then false 
-	      else opaque) ;
+	  const_entry_type = Some ty;
+	  const_entry_opaque = opaque;
 	  const_entry_boxed = false} 
       in
-      let constant = Declare.declare_constant obl.obl_name 
+      let constant = Declare.declare_constant obl.obl_name
 	(DefinitionEntry ce,IsProof Property)
       in
+	if not opaque then
+	  Auto.add_hints false [string_of_id prg.prg_name]
+	    (Auto.HintsUnfoldEntry [EvalConstRef constant]);
 	print_message (Subtac_utils.definition_message obl.obl_name);
 	{ obl with obl_body = Some (mkConst constant) }
-	  
+
 let red = Reductionops.nf_betaiota Evd.empty
 
 let init_prog_info n b t deps fixkind notations obls impls kind hook =
-  let obls' = 
-    Array.mapi
-      (fun i (n, t, l, o, d, tac) ->
-	 debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d));
-         { obl_name = n ; obl_body = None; 
-	   obl_location = l; obl_type = red t; obl_status = o;
-	   obl_deps = d; obl_tac = tac })
-      obls
+  let obls', b = 
+    match b with
+    | None ->
+	assert(obls = [||]);
+	let n = Nameops.add_suffix n "_obligation" in
+	  [| { obl_name = n; obl_body = None;
+	       obl_location = dummy_loc; obl_type = t;
+	       obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |],
+	mkVar n
+    | Some b ->
+	Array.mapi
+	  (fun i (n, t, l, o, d, tac) ->
+            { obl_name = n ; obl_body = None; 
+	      obl_location = l; obl_type = red t; obl_status = o;
+	      obl_deps = d; obl_tac = tac })
+	  obls, b
   in
     { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
       prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
       prg_implicits = impls; prg_kind = kind; prg_hook = hook; }
-    
+
 let get_prog name =
   let prg_infos = !from_prg in
     match name with
-	Some n -> 
+	Some n ->
 	  (try ProgMap.find n prg_infos
 	   with Not_found -> raise (NoObligations (Some n)))
-      | None -> 
+      | None ->
 	  (let n = map_cardinal prg_infos in
-	     match n with 
+	     match n with
 		 0 -> raise (NoObligations None)
 	       | 1 -> map_first prg_infos
 	       | _ -> error "More than one program with unsolved obligations")
 
-let get_prog_err n = 
+let get_prog_err n =
   try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
 
 let obligations_solved prg = (snd prg.prg_obligations) = 0
 
-let update_state s = 
-(*   msgnl (str "Updating obligations info"); *)
-  Lib.add_anonymous_leaf (input s)
+let all_programs () =
+  ProgMap.fold (fun k p l -> p :: l) !from_prg []
 
-type progress = 
-    | Remain of int 
+type progress =
+    | Remain of int
     | Dependent
     | Defined of global_reference
-	  
+
 let obligations_message rem =
   if rem > 0 then
     if rem = 1 then
@@ -335,36 +380,29 @@ let obligations_message rem =
   else
     Flags.if_verbose msgnl (str "No more obligations remaining")
 
-let update_obls prg obls rem = 
+let update_obls prg obls rem =
   let prg' = { prg with prg_obligations = (obls, rem) } in
-    from_prg := map_replace prg.prg_name prg' !from_prg;
+    from_prg := map_replace prg.prg_name prg' !from_prg; 
     obligations_message rem;
-    let res = 
-      if rem > 0 then Remain rem
-      else (
-	match prg'.prg_deps with
-	    [] ->
-	      let kn = declare_definition prg' in
-		from_prg := ProgMap.remove prg.prg_name !from_prg;
-		Defined kn
-	  | l ->
-	      let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
-		if List.for_all (fun x -> obligations_solved x) progs then 
-		  (let kn = declare_mutual_definition progs in
-		     from_prg := List.fold_left
-		       (fun acc x -> 
-			 ProgMap.remove x.prg_name acc) !from_prg progs;
-		    Defined (ConstRef kn))
-		else Dependent);
-    in
-      update_state (!from_prg, !default_tactic_expr);
-      res
-	    
+    if rem > 0 then Remain rem
+    else (
+      match prg'.prg_deps with
+      | [] ->
+	  let kn = declare_definition prg' in
+	    progmap_remove prg';
+	    Defined kn
+      | l ->
+	  let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
+	    if List.for_all (fun x -> obligations_solved x) progs then
+	      let kn = declare_mutual_definition progs in
+		Defined (ConstRef kn)
+	    else Dependent)
+
 let is_defined obls x = obls.(x).obl_body <> None
 
-let deps_remaining obls deps = 
+let deps_remaining obls deps =
   Intset.fold
-    (fun x acc -> 
+    (fun x acc ->
       if is_defined obls x then acc
       else x :: acc)
     deps []
@@ -372,38 +410,38 @@ let deps_remaining obls deps =
 let has_dependencies obls n =
   let res = ref false in
     Array.iteri
-      (fun i obl -> 
+      (fun i obl ->
 	if i <> n && Intset.mem n obl.obl_deps then
 	  res := true)
       obls;
     !res
-      
+
 let kind_of_opacity o =
   match o with
   | Define false | Expand -> Subtac_utils.goal_kind
   | _ -> Subtac_utils.goal_proof_kind
 
-let not_transp_msg = 
+let not_transp_msg =
   str "Obligation should be transparent but was declared opaque." ++ spc () ++
     str"Use 'Defined' instead."
 
 let warn_not_transp () = ppwarn not_transp_msg
 let error_not_transp () = pperror not_transp_msg
 
-let rec solve_obligation prg num =
+let rec solve_obligation prg num tac =
   let user_num = succ num in
   let obls, rem = prg.prg_obligations in
   let obl = obls.(num) in
     if obl.obl_body <> None then
-      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")    
+      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")
     else
       match deps_remaining obls obl.obl_deps with
       | [] ->
 	  let obl = subst_deps_obl obls obl in
-	    Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type
-	      (fun strength gr -> 
+	    Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type
+	      (fun strength gr ->
 		let cst = match gr with ConstRef cst -> cst | _ -> assert false in
-		let obl = 
+		let obl =
 		  let transparent = evaluable_constant cst (Global.env ()) in
 		  let body =
 		    match obl.obl_status with
@@ -413,11 +451,18 @@ let rec solve_obligation prg num =
 		    | Define opaque ->
 			if not opaque && not transparent then error_not_transp ()
 			else Libnames.constr_of_global gr
-		  in { obl with obl_body = Some body }
+		  in
+		    if transparent then
+		      Auto.add_hints true [string_of_id prg.prg_name]
+			(Auto.HintsUnfoldEntry [EvalConstRef cst]);
+		    { obl with obl_body = Some body }
 		in
 		let obls = Array.copy obls in
 		let _ = obls.(num) <- obl in
-		  match update_obls prg obls (pred rem) with
+		let res = try update_obls prg obls (pred rem)
+		  with e -> pperror (Cerrors.explain_exn e)
+		in
+		  match res with
 		  | Remain n when n > 0 ->
 		      if has_dependencies obls num then
 			ignore(auto_solve_obligations (Some prg.prg_name) None)
@@ -425,100 +470,108 @@ let rec solve_obligation prg num =
 	    trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
 		      Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
 	    Pfedit.by !default_tactic;
+	    Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac;
 	    Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
       | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
 		       ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
-	  
-and subtac_obligation (user_num, name, typ) =
+
+and subtac_obligation (user_num, name, typ) tac =
   let num = pred user_num in
   let prg = get_prog_err name in
   let obls, rem = prg.prg_obligations in
     if num < Array.length obls then
       let obl = obls.(num) in
 	match obl.obl_body with
-	    None -> solve_obligation prg num
+	    None -> solve_obligation prg num tac
 	  | Some r -> error "Obligation already solved"
     else error (sprintf "Unknown obligation number %i" (succ num))
-      
-   
+
+
 and solve_obligation_by_tac prg obls i tac =
   let obl = obls.(i) in
-  match obl.obl_body with 
-      Some _ -> false
-    | None -> 
-	(try
-	    if deps_remaining obls obl.obl_deps = [] then
-	     let obl = subst_deps_obl obls obl in
-	     let tac = 
-	       match tac with
-	       | Some t -> t
-	       | None -> 
-		   match obl.obl_tac with
-		   | Some t -> Tacinterp.interp t
-		   | None -> !default_tactic
-	     in
-	     let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
-	       obls.(i) <- declare_obligation obl t;
-	       true
-	    else false
-	  with
-	    | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
-	    | Stdpp.Exc_located(_, Refiner.FailError (_, s))
-	    | Refiner.FailError (_, s) ->
-		user_err_loc (obl.obl_location, "solve_obligation", s)
-	    | e -> false)
-
-and solve_prg_obligations prg tac = 
+    match obl.obl_body with
+    | Some _ -> false
+    | None ->
+	try
+	  if deps_remaining obls obl.obl_deps = [] then
+	    let obl = subst_deps_obl obls obl in
+	    let tac =
+	      match tac with
+	      | Some t -> t
+	      | None ->
+		  match obl.obl_tac with
+		  | Some t -> t
+		  | None -> !default_tactic
+	    in
+	    let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
+	      obls.(i) <- declare_obligation prg obl t;
+	      true
+	  else false
+	with
+	| Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
+	| Stdpp.Exc_located(_, Refiner.FailError (_, s))
+	| Refiner.FailError (_, s) ->
+	    user_err_loc (obl.obl_location, "solve_obligation", Lazy.force s)
+	| e -> false
+
+and solve_prg_obligations prg tac =
   let obls, rem = prg.prg_obligations in
   let rem = ref rem in
   let obls' = Array.copy obls in
-  let _ = 
-    Array.iteri (fun i x -> 
+  let _ =
+    Array.iteri (fun i x ->
 		   if solve_obligation_by_tac prg obls' i tac then
 		     decr rem)
       obls'
   in
     update_obls prg obls' !rem
 
-and solve_obligations n tac = 
+and solve_obligations n tac =
   let prg = get_prog_err n in
     solve_prg_obligations prg tac
 
-and solve_all_obligations tac = 
+and solve_all_obligations tac =
   ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg
-      
-and try_solve_obligation n prg tac = 
-  let prg = get_prog prg in 
+
+and try_solve_obligation n prg tac =
+  let prg = get_prog prg in
   let obls, rem = prg.prg_obligations in
   let obls' = Array.copy obls in
     if solve_obligation_by_tac prg obls' n tac then
       ignore(update_obls prg obls' (pred rem));
 
-and try_solve_obligations n tac = 
+and try_solve_obligations n tac =
   try ignore (solve_obligations n tac) with NoObligations _ -> ()
 
 and auto_solve_obligations n tac : progress =
   Flags.if_verbose msgnl (str "Solving obligations automatically...");
   try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent
-      
+
 open Pp
-let show_obligations ?(msg=true) n =
-  let prg = get_prog_err n in
+let show_obligations_of_prg ?(msg=true) prg =
   let n = prg.prg_name in
   let obls, rem = prg.prg_obligations in
   let showed = ref 5 in
     if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
-    Array.iteri (fun i x -> 
-		   match x.obl_body with 
-		   | None -> 
+    Array.iteri (fun i x ->
+		   match x.obl_body with
+		   | None ->
 		       if !showed > 0 then (
 			 decr showed;
 			 msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
-				   str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ 
+				   str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++
 				   hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())))
 		   | Some _ -> ())
       obls
-      
+
+let show_obligations ?(msg=true) n =
+  let progs = match n with
+    | None -> all_programs ()
+    | Some n ->
+	try [ProgMap.find n !from_prg]
+	with Not_found -> raise (NoObligations (Some n))
+  in List.iter (show_obligations_of_prg ~msg) progs
+
 let show_term n =
   let prg = get_prog_err n in
   let n = prg.prg_name in
@@ -526,71 +579,74 @@ let show_term n =
 	      my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
 	    ++ my_print_constr (Global.env ()) prg.prg_body)
 
-let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun _ _ -> ()) obls =
+let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun _ _ -> ()) obls =
   Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
-  let prg = init_prog_info n b t [] None [] obls implicits kind hook in
+  let prg = init_prog_info n term t [] None [] obls implicits kind hook in
   let obls,_ = prg.prg_obligations in
   if Array.length obls = 0 then (
-    Flags.if_verbose ppnl (str ".");    
-    let cst = declare_definition prg in 
-      from_prg := ProgMap.remove prg.prg_name !from_prg;
+    Flags.if_verbose ppnl (str ".");
+    let cst = declare_definition prg in
       Defined cst)
   else (
     let len = Array.length obls in
     let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
-      from_prg := ProgMap.add n prg !from_prg; 
+      from_prg := ProgMap.add n prg !from_prg;
       let res = auto_solve_obligations (Some n) tactic in
 	match res with
 	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
 	| _ -> res)
-	
+
 let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind =
   let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
   let upd = List.fold_left
       (fun acc (n, b, t, imps, obls) ->
-	let prg = init_prog_info n b t deps (Some fixkind) notations obls imps kind hook in
+	let prg = init_prog_info n (Some b) t deps (Some fixkind) notations obls imps kind hook in
 	  ProgMap.add n prg acc)
       !from_prg l
   in
     from_prg := upd;
-    let _defined = 
-      List.fold_left (fun finished x -> 
-	if finished then finished 
+    let _defined =
+      List.fold_left (fun finished x ->
+	if finished then finished
 	else
 	  let res = auto_solve_obligations (Some x) tactic in
 	    match res with
 	    | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true
-	    | _ -> false) 
+	    | _ -> false)
 	false deps
     in ()
-	
+
 let admit_obligations n =
   let prg = get_prog_err n in
   let obls, rem = prg.prg_obligations in
-    Array.iteri (fun i x -> 
-		 match x.obl_body with 
-		     None -> 
-                       let x = subst_deps_obl obls x in
-		       let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), IsAssumption Conjectural) in
-			 assumption_message x.obl_name;
-			 obls.(i) <- { x with obl_body = Some (mkConst kn) }
-		   | Some _ -> ())
+    Array.iteri 
+      (fun i x ->
+	match x.obl_body with
+	| None ->
+            let x = subst_deps_obl obls x in
+	    let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), 
+							 IsAssumption Conjectural) 
+	    in
+	      assumption_message x.obl_name;
+	      obls.(i) <- { x with obl_body = Some (mkConst kn) }
+	| Some _ -> ())
       obls;
     ignore(update_obls prg obls 0)
 
 exception Found of int
 
-let array_find f arr = 
+let array_find f arr =
   try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
     raise Not_found
   with Found i -> i
 
-let next_obligation n =
+let next_obligation n tac =
   let prg = get_prog_err n in
   let obls, rem = prg.prg_obligations in
-  let i = 
+  let i =
     try array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = []) obls
     with Not_found -> anomaly "Could not find a solvable obligation."
-  in solve_obligation prg i
-      			
+  in solve_obligation prg i tac
+
 let default_tactic () = !default_tactic
+let default_tactic_expr () = !default_tactic_expr
diff --git a/contrib/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
index 766af2fa..1608c134 100644
--- a/contrib/subtac/subtac_obligations.mli
+++ b/plugins/subtac/subtac_obligations.mli
@@ -4,48 +4,54 @@ open Libnames
 open Evd
 open Proof_type
 
-type obligation_info = 
-  (identifier * Term.types * loc * 
-      obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array
+type obligation_info =
+  (identifier * Term.types * loc *
+      obligation_definition_status * Intset.t * tactic option) array
     (* ident, type, location, (opaque or transparent, expand or define),
        dependencies, tactic to solve it *)
 
 type progress = (* Resolution status of a program *)
-    | Remain of int  (* n obligations remaining *)
-    | Dependent (* Dependent on other definitions *)
-    | Defined of global_reference (* Defined as id *)
-	
-val set_default_tactic : Tacexpr.glob_tactic_expr -> unit
+  | 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 default_tactic : unit -> Proof_type.tactic
+val default_tactic_expr : unit -> Tacexpr.glob_tactic_expr
 
 val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
 val get_proofs_transparency : unit -> bool
 
-val add_definition : Names.identifier ->  Term.constr -> Term.types -> 
-  ?implicits:(Topconstr.explicitation * (bool * bool)) list ->
+val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> 
+  ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list ->
   ?kind:Decl_kinds.definition_kind ->
   ?tactic:Proof_type.tactic ->
-  ?hook:Tacexpr.declaration_hook -> obligation_info -> progress
+  ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress
 
-type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list
+type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
 
-val add_mutual_definitions : 
+type fixpoint_kind =
+  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
+  | IsCoFixpoint
+
+val add_mutual_definitions :
   (Names.identifier * Term.constr * Term.types *
-      (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> 
+      (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
   ?tactic:Proof_type.tactic ->
   ?kind:Decl_kinds.definition_kind ->
-  ?hook:Tacexpr.declaration_hook -> 
+  ?hook:Tacexpr.declaration_hook ->
   notations ->
-  Command.fixpoint_kind -> unit
+  fixpoint_kind -> unit
 
-val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> unit
+val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option ->
+  Tacexpr.raw_tactic_expr option -> unit
 
-val next_obligation : Names.identifier option -> unit
+val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit
 
 val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress
 (* Number of remaining obligations to be solved for this program *)
 
-val solve_all_obligations : Proof_type.tactic option -> unit 
+val solve_all_obligations : Proof_type.tactic option -> unit
 
 val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit
 
diff --git a/plugins/subtac/subtac_plugin.mllib b/plugins/subtac/subtac_plugin.mllib
new file mode 100644
index 00000000..a4b9d67e
--- /dev/null
+++ b/plugins/subtac/subtac_plugin.mllib
@@ -0,0 +1,13 @@
+Subtac_utils
+Eterm
+Subtac_errors
+Subtac_coercion
+Subtac_obligations
+Subtac_cases
+Subtac_pretyping_F
+Subtac_pretyping
+Subtac_command
+Subtac_classes
+Subtac
+G_subtac
+Subtac_plugin_mod
diff --git a/contrib/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
index 3ae7c95d..f1541f25 100644
--- a/contrib/subtac/subtac_pretyping.ml
+++ b/plugins/subtac/subtac_pretyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Global
 open Pp
@@ -23,13 +23,12 @@ open Typeops
 open Libnames
 open Classops
 open List
-open Recordops 
+open Recordops
 open Evarutil
 open Pretype_errors
 open Rawterm
 open Evarconv
 open Pattern
-open Dyn
 
 open Subtac_coercion
 open Subtac_utils
@@ -54,7 +53,7 @@ type recursion_info = {
   f_fulltype: types; (* Type with argument and wf proof product first *)
 }
 
-let my_print_rec_info env t = 
+let my_print_rec_info env t =
   str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++
   str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++
   str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++
@@ -65,16 +64,17 @@ let my_print_rec_info env t =
 (* 	   str " and tycon "++ my_print_tycon env tycon ++ *)
 (* 	   str " in environment: " ++ my_print_env env); *)
 
-let merge_evms x y = 
+let merge_evms x y =
   Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y
 
-let interp env isevars c tycon = 
+let interp env isevars c tycon =
   let j = pretype tycon env isevars ([],[]) c in
-  let _ = isevars := Evarutil.nf_evar_defs !isevars in
+  let _ = isevars := Evarutil.nf_evar_map !isevars in
   let evd,_ = consider_remaining_unif_problems env !isevars in
 (*   let unevd = undefined_evars evd in *)
   let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in
-  let evm = evars_of unevd' in
+  let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in
+  let evm =  unevd' in
     isevars := unevd';
     nf_evar evm j.uj_val, nf_evar evm j.uj_type
 
@@ -86,12 +86,12 @@ let find_with_index x l =
 
 open Vernacexpr
 
-let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env
-let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type (evars_of evd) env
+let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr ( evd) env
+let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type ( evd) env
 
 let env_with_binders env isevars l =
   let rec aux ((env, rels) as acc) = function
-      Topconstr.LocalRawDef ((loc, name), def) :: tl -> 
+      Topconstr.LocalRawDef ((loc, name), def) :: tl ->
 	let rawdef = coqintern_constr !isevars env def in
 	let coqdef, deftyp = interp env isevars rawdef empty_tycon in
 	let reldecl = (name, Some coqdef, deftyp) in
@@ -99,10 +99,10 @@ let env_with_binders env isevars l =
     | Topconstr.LocalRawAssum (bl, k, typ) :: tl ->
 	let rawtyp = coqintern_type !isevars env typ in
 	let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
-	let acc = 
-	  List.fold_left (fun (env, rels) (loc, name) -> 
+	let acc =
+	  List.fold_left (fun (env, rels) (loc, name) ->
 			    let reldecl = (name, None, coqtyp) in
-			      (push_rel reldecl env, 
+			      (push_rel reldecl env,
 			       reldecl :: rels))
 	    (env, rels) bl
 	in aux acc tl
@@ -110,21 +110,21 @@ let env_with_binders env isevars l =
   in aux (env, []) l
 
 let subtac_process env isevars id bl c tycon =
-  let c = Command.abstract_constr_expr c bl in
-  let tycon = 
+  let c = Topconstr.abstract_constr_expr c bl in
+  let tycon =
     match tycon with
 	None -> empty_tycon
-      | Some t -> 
-	  let t = Command.generalize_constr_expr t bl in
+      | Some t ->
+	  let t = Topconstr.prod_constr_expr t bl in
 	  let t = coqintern_type !isevars env t in
 	  let coqt, ttyp = interp env isevars t empty_tycon in
 	    mk_tycon coqt
-  in    
+  in
   let c = coqintern_constr !isevars env c in
   let imps = Implicit_quantifiers.implicits_of_rawterm c in
   let coqc, ctyp = interp env isevars c tycon in
-  let evm = non_instanciated_map env isevars (evars_of !isevars) in
-  let ty = nf_isevar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
+  let evm = non_instanciated_map env isevars ( !isevars) in
+  let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
     evm, coqc, ty, imps
 
 open Subtac_obligations
@@ -133,5 +133,5 @@ let subtac_proof kind hook env isevars id bl c tycon =
   let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in
   let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in
   let evm' = Subtac_utils.evars_of_term evm evm' coqt in
-  let evars, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in
-    add_definition id def ty ~implicits:imps ~kind ~hook evars
+  let evars, _, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in
+    add_definition id ~term:def ty ~implicits:imps ~kind ~hook evars
diff --git a/contrib/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
index ba0b7cd2..055c6df2 100644
--- a/contrib/subtac/subtac_pretyping.mli
+++ b/plugins/subtac/subtac_pretyping.mli
@@ -12,13 +12,12 @@ module Pretyping : Pretyping.S
 
 val interp :
     Environ.env ->
-    Evd.evar_defs ref ->
+    Evd.evar_map ref ->
     Rawterm.rawconstr ->
     Evarutil.type_constraint -> Term.constr * Term.constr
 
-val subtac_process : env -> evar_defs ref -> identifier -> local_binder list ->
+val subtac_process : env -> evar_map ref -> identifier -> local_binder list ->
   constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
 
-val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> 
-  env -> evar_defs ref -> identifier -> local_binder list ->
+val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list ->
   constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/contrib/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
index 00d37f35..e574ef3b 100644
--- a/contrib/subtac/subtac_pretyping_F.ml
+++ b/plugins/subtac/subtac_pretyping_F.ml
@@ -1,4 +1,4 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping_F.ml 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -24,13 +24,12 @@ open Libnames
 open Nameops
 open Classops
 open List
-open Recordops 
+open Recordops
 open Evarutil
 open Pretype_errors
 open Rawterm
 open Evarconv
 open Pattern
-open Dyn
 open Pretyping
 
 (************************************************************************)
@@ -46,61 +45,61 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
   let allow_anonymous_refs = ref true
 
-  let evd_comb0 f isevars =
-    let (evd',x) = f !isevars in
-      isevars := evd';
+  let evd_comb0 f evdref =
+    let (evd',x) = f !evdref in
+      evdref := evd';
       x
 
-  let evd_comb1 f isevars x =
-    let (evd',y) = f !isevars x in
-      isevars := evd';
+  let evd_comb1 f evdref x =
+    let (evd',y) = f !evdref x in
+      evdref := evd';
       y
 
-  let evd_comb2 f isevars x y =
-    let (evd',z) = f !isevars x y in
-      isevars := evd';
+  let evd_comb2 f evdref x y =
+    let (evd',z) = f !evdref x y in
+      evdref := evd';
       z
 
-  let evd_comb3 f isevars x y z =
-    let (evd',t) = f !isevars x y z in
-      isevars := evd';
+  let evd_comb3 f evdref x y z =
+    let (evd',t) = f !evdref x y z in
+      evdref := evd';
       t
-	
+
   let mt_evd = Evd.empty
-    
+
   (* Utilisé pour inférer le prédicat des Cases *)
   (* Semble exagérement fort *)
   (* Faudra préférer une unification entre les types de toutes les clauses *)
   (* et autoriser des ? à rester dans le résultat de l'unification *)
-  
-  let evar_type_fixpoint loc env isevars lna lar vdefj =
-    let lt = Array.length vdefj in 
-      if Array.length lar = lt then 
-	for i = 0 to lt-1 do 
-          if not (e_cumul env isevars (vdefj.(i)).uj_type
+
+  let evar_type_fixpoint loc env evdref lna lar vdefj =
+    let lt = Array.length vdefj in
+      if Array.length lar = lt then
+	for i = 0 to lt-1 do
+          if not (e_cumul env evdref (vdefj.(i)).uj_type
 		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env (evars_of !isevars)
+            error_ill_typed_rec_body_loc loc env ( !evdref)
               i lna vdefj lar
 	done
 
-  let check_branches_message loc env isevars c (explft,lft) = 
+  let check_branches_message loc env evdref c (explft,lft) =
     for i = 0 to Array.length explft - 1 do
-      if not (e_cumul env isevars lft.(i) explft.(i)) then 
-	let sigma = evars_of !isevars in
+      if not (e_cumul env evdref lft.(i) explft.(i)) then
+	let sigma =  !evdref in
 	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
     done
 
   (* coerce to tycon if any *)
-  let inh_conv_coerce_to_tycon loc env isevars j = function
-    | None -> j_nf_isevar !isevars j
-    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t
+  let inh_conv_coerce_to_tycon loc env evdref j = function
+    | None -> j_nf_evar !evdref j
+    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t
 
   let push_rels vars env = List.fold_right push_rel vars env
 
   (*
-    let evar_type_case isevars env ct pt lft p c =
-    let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
-    in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
+    let evar_type_case evdref env ct pt lft p c =
+    let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c
+    in check_branches_message evdref env (c,ct) (bty,lft); (mind,rslty)
   *)
 
   let strip_meta id = (* For Grammar v7 compatibility *)
@@ -108,14 +107,24 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
       if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
       else id
 
-  let pretype_id loc env (lvar,unbndltacvars) id =
+  let invert_ltac_bound_name env id0 id =
+    try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+    with Not_found ->
+      errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
+	str " depends on pattern variable name " ++ pr_id id ++
+	str " which is not bound in current context")
+
+  let pretype_id loc env sigma (lvar,unbndltacvars) id =
     let id = strip_meta id in (* May happen in tactics defined by Grammar *)
       try
-	let (n,typ) = lookup_rel_id id (rel_context env) in
+	let (n,_,typ) = lookup_rel_id id (rel_context env) in
 	  { uj_val  = mkRel n; uj_type = lift n typ }
       with Not_found ->
 	try
-	  List.assoc id lvar
+	  let (ids,c) = List.assoc id lvar in
+	  let subst = List.map (invert_ltac_bound_name env id) ids in
+	  let c = substl subst c in
+	  { uj_val = c; uj_type = Retyping.get_type_of env sigma c }
 	with Not_found ->
 	  try
 	    let (_,_,typ) = lookup_named id env in
@@ -137,19 +146,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
       if n=0 then p else
 	match kind_of_term p with
 	  | Lambda (_,_,c) -> decomp (n-1) c
-	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
+	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
     in
     let sign,s = decompose_prod_n n pj.uj_type in
     let ind = build_dependent_inductive env indf in
     let s' = mkProd (Anonymous, ind, s) in
     let ccl = lift 1 (decomp n pj.uj_val) in
     let ccl' = mkLambda (Anonymous, ind, ccl) in
-      {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
+      {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign}
 
   (*************************************************************************)
   (* Main pretyping function                                               *)
 
-  let pretype_ref isevars env ref = 
+  let pretype_ref evdref env ref =
     let c = constr_of_global ref in
       make_judge c (Retyping.get_type_of env Evd.empty c)
 
@@ -157,82 +166,89 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     | RProp c -> judge_of_prop_contents c
     | RType _ -> judge_of_new_Type ()
 
-  (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
-  (* in environment [env], with existential variables [(evars_of isevars)] and *)
+  (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
+  (* in environment [env], with existential variables [( evdref)] and *)
   (* the type constraint tycon *)
-  let rec pretype (tycon : type_constraint) env isevars lvar c = 
+  let rec pretype (tycon : type_constraint) env evdref lvar c =
 (*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *)
 (* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
 (*     with _ -> () *)
 (*     in *)
     match c with
     | RRef (loc,ref) ->
-	inh_conv_coerce_to_tycon loc env isevars
-	  (pretype_ref isevars env ref)
+	inh_conv_coerce_to_tycon loc env evdref
+	  (pretype_ref evdref env ref)
 	  tycon
 
     | RVar (loc, id) ->
-	inh_conv_coerce_to_tycon loc env isevars
-	  (pretype_id loc env lvar id)
+	inh_conv_coerce_to_tycon loc env evdref
+	  (pretype_id loc env !evdref lvar id)
 	  tycon
 
     | REvar (loc, ev, instopt) ->
 	(* Ne faudrait-il pas s'assurer que hyps est bien un
 	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_context (Evd.find (evars_of !isevars) ev) in
+	let hyps = evar_context (Evd.find ( !evdref) ev) in
 	let args = match instopt with
           | None -> instance_from_named_context hyps
           | Some inst -> failwith "Evar subtitutions not implemented" in
 	let c = mkEvar (ev, args) in
-	let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
-	  inh_conv_coerce_to_tycon loc env isevars j tycon
+	let j = (Retyping.get_judgment_of env ( !evdref) c) in
+	  inh_conv_coerce_to_tycon loc env evdref j tycon
 
-    | RPatVar (loc,(someta,n)) -> 
+    | RPatVar (loc,(someta,n)) ->
 	anomaly "Found a pattern variable in a rawterm to type"
-	  
+
     | RHole (loc,k) ->
 	let ty =
-          match tycon with 
+          match tycon with
             | Some (None, ty) -> ty
             | None | Some _ ->
-		e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in
-	  { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty }
+		e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
 
     | RRec (loc,fixkind,names,bl,lar,vdef) ->
 	let rec type_bl env ctxt = function
             [] -> ctxt
           | (na,k,None,ty)::bl ->
-              let ty' = pretype_type empty_valcon env isevars lvar ty in
+              let ty' = pretype_type empty_valcon env evdref lvar ty in
               let dcl = (na,None,ty'.utj_val) in
 		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
           | (na,k,Some bd,ty)::bl ->
-              let ty' = pretype_type empty_valcon env isevars lvar ty in
-              let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
+              let ty' = pretype_type empty_valcon env evdref lvar ty in
+              let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in
               let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
 		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
 	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
 	let larj =
           array_map2
             (fun e ar ->
-               pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
+               pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
             ctxtv lar in
 	let lara = Array.map (fun a -> a.utj_val) larj in
 	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
 	let nbfix = Array.length lar in
 	let names = Array.map (fun id -> Name id) names in
 	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
-	let newenv = push_rec_types (names,ftys,[||]) env in
+	let newenv =
+	  let marked_ftys =
+	    Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in
+				   mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |]))
+	      ftys
+	  in
+	    push_rec_types (names,marked_ftys,[||]) env
+	in
 	let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in
 	let vdefj =
-	  array_map2_i 
+	  array_map2_i
 	    (fun i ctxt def ->
-	      let fty = 
+	      let fty =
 		let ty = ftys.(i) in
 		  if i = fixi then (
 		    Option.iter (fun tycon ->
-		      isevars := Coercion.inh_conv_coerces_to loc env !isevars ftys.(i) tycon)
+		      evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon)
 		      tycon;
-		    nf_isevar !isevars ty)
+		    nf_evar !evdref ty)
 		  else ty
 	      in
               (* we lift nbfix times the type in tycon, because of
@@ -241,43 +257,43 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		decompose_prod_n_assum (rel_context_length ctxt)
                   (lift nbfix fty) in
               let nenv = push_rel_context ctxt newenv in
-              let j = pretype (mk_tycon ty) nenv isevars lvar def 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 isevars names ftys vdefj;
-	let ftys = Array.map (nf_evar (evars_of !isevars)) ftys in
-	let fdefs = Array.map (fun x -> nf_evar (evars_of !isevars) (j_val x)) vdefj in
+	evar_type_fixpoint loc env evdref names ftys vdefj;
+	let ftys = Array.map (nf_evar ( !evdref)) ftys in
+	let fdefs = Array.map (fun x -> nf_evar ( !evdref) (j_val x)) vdefj in
 	let fixj = match fixkind with
 	  | RFix (vn,i) ->
 	      (* First, let's find the guard indexes. *)
 	      (* If recursive argument was not given by user, we try all args.
 	         An earlier approach was to look only for inductive arguments,
-		 but doing it properly involves delta-reduction, and it finally 
-                 doesn't seem worth the effort (except for huge mutual 
+		 but doing it properly involves delta-reduction, and it finally
+                 doesn't seem worth the effort (except for huge mutual
 		 fixpoints ?) *)
-	      let possible_indexes = Array.to_list (Array.mapi 
-		(fun i (n,_) -> match n with 
+	      let possible_indexes = Array.to_list (Array.mapi
+		(fun i (n,_) -> match n with
 		   | Some n -> [n]
 		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
 		vn)
-	      in 
-	      let fixdecls = (names,ftys,fdefs) in 
-	      let indexes = search_guard loc env possible_indexes fixdecls in 
+	      in
+	      let fixdecls = (names,ftys,fdefs) in
+	      let indexes = search_guard loc env possible_indexes fixdecls in
 	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
-	  | RCoFix i -> 
+	  | RCoFix i ->
 	      let cofix = (i,(names,ftys,fdefs)) in
 	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
-	inh_conv_coerce_to_tycon loc env isevars fixj tycon
+	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
     | RSort (loc,s) ->
-	inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
+	inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon
 
-    | RApp (loc,f,args) -> 
-	let length = List.length args in 
+    | RApp (loc,f,args) ->
+	let length = List.length args in
 	let ftycon =
-	  let ty = 
+	  let ty =
 	    if length > 0 then
 	      match tycon with
 	      | None -> None
@@ -285,94 +301,94 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	      | Some (Some (init, cur), ty) ->
 		  Some (Some (length + init, length + cur), ty)
  	    else tycon
-	  in 
+	  in
 	    match ty with
 	    | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty
 	    | _ -> None
 	in
-	let fj = pretype ftycon env isevars lvar f in
+	let fj = pretype ftycon env evdref lvar f in
  	let floc = loc_of_rawconstr f in
 	let rec apply_rec env n resj tycon = function
 	  | [] -> resj
 	  | c::rest ->
 	      let argloc = loc_of_rawconstr c in
-	      let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in
-              let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in
+	      let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in
+              let resty = whd_betadeltaiota env ( !evdref) resj.uj_type in
       		match kind_of_term resty with
 		  | Prod (na,c1,c2) ->
-		      Option.iter (fun ty -> isevars :=
-			Coercion.inh_conv_coerces_to loc env !isevars resty ty) tycon;
-		      let evd, (_, _, tycon) = split_tycon loc env !isevars tycon in
-		      isevars := evd;
-		      let hj = pretype (mk_tycon (nf_isevar !isevars c1)) env isevars lvar c in
+		      Option.iter (fun ty -> evdref :=
+			Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
+		      let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
+		      evdref := evd;
+		      let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in
 		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-		      let typ' = nf_isevar !isevars typ in
-			apply_rec env (n+1) 
-			  { uj_val = nf_isevar !isevars value;
-			    uj_type = nf_isevar !isevars typ' }
-			  (Option.map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
+		      let typ' = nf_evar !evdref typ in
+			apply_rec env (n+1)
+			  { uj_val = nf_evar !evdref value;
+			    uj_type = nf_evar !evdref typ' }
+			  (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest
 
 		  | _ ->
-		      let hj = pretype empty_tycon env isevars lvar c in
-			error_cant_apply_not_functional_loc 
-			  (join_loc floc argloc) env (evars_of !isevars)
+		      let hj = pretype empty_tycon env evdref lvar c in
+			error_cant_apply_not_functional_loc
+			  (join_loc floc argloc) env ( !evdref)
 	      		  resj [hj]
 	in
-	let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in
+	let resj = j_nf_evar ( !evdref) (apply_rec env 1 fj ftycon args) in
 	let resj =
 	  match kind_of_term resj.uj_val with
 	  | App (f,args) when isInd f or isConst f ->
-	      let sigma = evars_of !isevars in
+	      let sigma =  !evdref in
 	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
 	      let t = Retyping.get_type_of env sigma c in
 	      make_judge c t
 	  | _ -> resj in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
+	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 
     | RLambda(loc,name,k,c1,c2)      ->
-	let tycon' = evd_comb1 
-	  (fun evd tycon -> 
-	    match tycon with 
-	    | None -> evd, tycon 
-	    | Some ty -> 
+	let tycon' = evd_comb1
+	  (fun evd tycon ->
+	    match tycon with
+	    | None -> evd, tycon
+	    | Some ty ->
 		let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
-		  evd, Some ty') 
-	  isevars tycon 
+		  evd, Some ty')
+	  evdref tycon
 	in
-	let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon' in
+	let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
 	let dom_valcon = valcon_of_tycon dom in
-	let j = pretype_type dom_valcon env isevars lvar c1 in
+	let j = pretype_type dom_valcon env evdref lvar c1 in
 	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) isevars lvar c2 in 
+	let j' = pretype rng (push_rel var env) evdref lvar c2 in
 	let resj = judge_of_abstraction env name j j' in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
+	  inh_conv_coerce_to_tycon loc env evdref resj tycon
 
     | RProd(loc,name,k,c1,c2)        ->
-	let j = pretype_type empty_valcon env isevars lvar c1 in
+	let j = pretype_type empty_valcon env evdref lvar c1 in
 	let var = (name,j.utj_val) in
 	let env' = push_rel_assum var env in
-	let j' = pretype_type empty_valcon env' isevars lvar c2 in
+	let j' = pretype_type empty_valcon env' evdref lvar c2 in
 	let resj =
 	  try judge_of_product env name j j'
 	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
-	    
+	  inh_conv_coerce_to_tycon loc env evdref resj tycon
+
     | RLetIn(loc,name,c1,c2)      ->
-	let j = pretype empty_tycon env isevars lvar c1 in
+	let j = pretype empty_tycon env evdref lvar c1 in
 	let t = refresh_universes j.uj_type in
 	let var = (name,Some j.uj_val,t) in
         let tycon = lift_tycon 1 tycon in
-	let j' = pretype tycon (push_rel var env) isevars lvar c2 in
+	let j' = pretype tycon (push_rel var env) evdref lvar c2 in
 	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
 	    uj_type = subst1 j.uj_val j'.uj_type }
 
     | RLetTuple (loc,nal,(na,po),c,d) ->
-	let cj = pretype empty_tycon env isevars lvar c in
-	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !isevars) cj.uj_type
+	let cj = pretype empty_tycon env evdref lvar c in
+	let (IndType (indf,realargs)) =
+	  try find_rectype env ( !evdref) cj.uj_type
 	  with Not_found ->
 	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj 
+	      error_case_not_inductive_loc cloc env ( !evdref) cj
 	in
 	let cstrs = get_constructors env indf in
 	if Array.length cstrs <> 1 then
@@ -395,59 +411,59 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	      (match po with
 		 | Some p ->
 		     let env_p = push_rels psign env in
-		     let pj = pretype_type empty_valcon env_p isevars lvar p in
-		     let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+		     let pj = pretype_type empty_valcon env_p evdref lvar p in
+		     let ccl = nf_evar ( !evdref) pj.utj_val in
 		     let psign = make_arity_signature env true indf in (* with names *)
 		     let p = it_mkLambda_or_LetIn ccl psign in
-		     let inst = 
+		     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 (evars_of !isevars) lp inst in
-		     let fj = pretype (mk_tycon fty) env_f isevars lvar d in
+		     let fty = hnf_lam_applist env ( !evdref) lp inst in
+		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
 		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|]) in 
+			 mkCase (ci, p, cj.uj_val,[|f|]) in
 		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
 
-		 | None -> 
+		 | None ->
 		     let tycon = lift_tycon cs.cs_nargs tycon in
-		     let fj = pretype tycon env_f isevars lvar d in
+		     let fj = pretype tycon env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_evar (evars_of !isevars) fj.uj_type in
+		     let ccl = nf_evar ( !evdref) fj.uj_type in
 		     let ccl =
 		       if noccur_between 1 cs.cs_nargs ccl then
-			 lift (- cs.cs_nargs) ccl 
+			 lift (- cs.cs_nargs) ccl
 		       else
-			 error_cant_find_case_type_loc loc env (evars_of !isevars) 
+			 error_cant_find_case_type_loc loc env ( !evdref)
 			   cj.uj_val in
 		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
 		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|] ) 
+			 mkCase (ci, p, cj.uj_val,[|f|] )
 		     in
 		       { uj_val = v; uj_type = ccl })
 
     | RIf (loc,c,(na,po),b1,b2) ->
-	let cj = pretype empty_tycon env isevars lvar c in
-	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !isevars) cj.uj_type
+	let cj = pretype empty_tycon env evdref lvar c in
+	let (IndType (indf,realargs)) =
+	  try find_rectype env ( !evdref) cj.uj_type
 	  with Not_found ->
 	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj in
-	let cstrs = get_constructors env indf in 
+	      error_case_not_inductive_loc cloc env ( !evdref) cj in
+	let cstrs = get_constructors env indf in
 	  if Array.length cstrs <> 2 then
             user_err_loc (loc,"",
-			  str "If is only for inductive types with two constructors");
+			  str "If is only for inductive types with two constructors.");
 
-	  let arsgn = 
+	  let arsgn =
 	    let arsgn,_ = get_arity env indf in
 	      if not !allow_anonymous_refs then
 		(* Make dependencies from arity signature impossible *)
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn 
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
 	      else arsgn
 	  in
 	  let nar = List.length arsgn in
@@ -455,42 +471,42 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  let pred,p = match po with
 	    | Some p ->
 		let env_p = push_rels psign env in
-		let pj = pretype_type empty_valcon env_p isevars lvar p in
-		let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+		let pj = pretype_type empty_valcon env_p evdref lvar p in
+		let ccl = nf_evar ( !evdref) pj.utj_val in
 		let pred = it_mkLambda_or_LetIn ccl psign in
 		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-		let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred;
-								     uj_type = typ} tycon 
+		let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred;
+								     uj_type = typ} tycon
 		in
 		  jtyp.uj_val, jtyp.uj_type
-	    | None -> 
+	    | None ->
 		let p = match tycon with
 		  | Some (None, ty) -> ty
 		  | None | Some _ ->
-                      e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ())
+                      e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ())
 		in
 		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar (evars_of !isevars) pred in
-	  let p = nf_evar (evars_of !isevars) p in
+	  let pred = nf_evar ( !evdref) pred in
+	  let p = nf_evar ( !evdref) p in
 	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
 	  let f cs b =
 	    let n = rel_context_length cs.cs_args in
 	    let pi = lift n pred in (* liftn n 2 pred ? *)
 	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	    let csgn = 
+	    let csgn =
 	      if not !allow_anonymous_refs then
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args 
-	      else 
-		List.map 
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+	      else
+		List.map
 		  (fun (n, b, t) ->
 		     match n with
                          Name _ -> (n, b, t)
                        | Anonymous -> (Name (id_of_string "H"), b, t))
 		cs.cs_args
 	    in
-	    let env_c = push_rels csgn env in 
+	    let env_c = push_rels csgn env in
 (* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
-	    let bj = pretype (mk_tycon pi) env_c isevars lvar b in
+	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
 	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
 	  let b1 = f cstrs.(0) b1 in
 	  let b2 = f cstrs.(1) b2 in
@@ -503,81 +519,81 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 
     | RCases (loc,sty,po,tml,eqns) ->
 	Cases.compile_cases loc sty
-	  ((fun vtyc env isevars -> pretype vtyc env isevars lvar),isevars)
+	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
 	  tycon env (* loc *) (po,tml,eqns)
 
-    | RCast(loc,c,k) ->
+    | RCast (loc,c,k) ->
 	let cj =
 	  match k with
 	      CastCoerce ->
-		let cj = pretype empty_tycon env isevars lvar c in
-		  evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj
+		let cj = pretype empty_tycon env evdref lvar c in
+		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
 	    | CastConv (k,t) ->
-		let tj = pretype_type empty_valcon env isevars lvar t in
-		let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
+		let tj = pretype_type empty_valcon env evdref lvar t in
+		let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
 		  (* User Casts are for helping pretyping, experimentally not to be kept*)
 		  (* ... except for Correctness *)
 		let v = mkCast (cj.uj_val, k, tj.utj_val) in
 		  { uj_val = v; uj_type = tj.utj_val }
 	in
-	  inh_conv_coerce_to_tycon loc env isevars cj tycon
+	  inh_conv_coerce_to_tycon loc env evdref cj tycon
 
     | RDynamic (loc,d) ->
-	if (tag d) = "constr" then
+	if (Dyn.tag d) = "constr" then
 	  let c = constr_out d in
-	  let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+	  let j = (Retyping.get_judgment_of env ( !evdref) c) in
 	    j
-	      (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
+	      (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
 	else
-	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
+	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic."))
 
-  (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
-  and pretype_type valcon env isevars lvar = function
+  (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
+  and pretype_type valcon env evdref lvar = function
     | RHole loc ->
 	(match valcon with
 	   | Some v ->
                let s =
-		 let sigma = evars_of !isevars in
+		 let sigma =  !evdref in
 		 let t = Retyping.get_type_of env sigma v in
 		   match kind_of_term (whd_betadeltaiota env sigma t) with
                      | Sort s -> s
-                     | Evar v when is_Type (existential_type sigma v) -> 
-			 evd_comb1 (define_evar_as_sort) isevars v
+                     | Evar ev when is_Type (existential_type sigma ev) ->
+			 evd_comb1 (define_evar_as_sort) evdref ev
                      | _ -> anomaly "Found a type constraint which is not a type"
                in
 		 { utj_val = v;
 		   utj_type = s }
 	   | None ->
 	       let s = new_Type_sort () in
-		 { utj_val = e_new_evar isevars env ~src:loc (mkSort s);
+		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
 		   utj_type = s})
     | c ->
-	let j = pretype empty_tycon env isevars lvar c in
+	let j = pretype empty_tycon env evdref lvar c in
 	let loc = loc_of_rawconstr c in
-	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in
+	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
 	  match valcon with
 	    | None -> tj
 	    | Some v ->
-		if e_cumul env isevars v tj.utj_val then tj
+		if e_cumul env evdref v tj.utj_val then tj
 		else
 		  error_unexpected_type_loc
-                    (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
+                    (loc_of_rawconstr c) env ( !evdref) tj.utj_val v
 
-  let pretype_gen_aux isevars env lvar kind c =
+  let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
     let c' = match kind with
       | OfType exptyp ->
 	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-	    (pretype tycon env isevars lvar c).uj_val
+	  (pretype tycon env evdref lvar c).uj_val
       | IsType ->
-	  (pretype_type empty_valcon env isevars lvar c).utj_val in
-    let evd,_ = consider_remaining_unif_problems env !isevars in
-      isevars:=evd;
-      nf_evar (evars_of !isevars) c'
-
-  let pretype_gen isevars env lvar kind c =
-    let c = pretype_gen_aux isevars env lvar kind c in
-      isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !isevars;
-      nf_evar (evars_of !isevars) c
+	  (pretype_type empty_valcon env evdref lvar c).utj_val in
+    evdref := fst (consider_remaining_unif_problems env !evdref);
+    if resolve_classes then
+      evdref :=
+        Typeclasses.resolve_typeclasses ~onlyargs:false
+	  ~split:true ~fail:fail_evar env !evdref;
+    let c = if expand_evar then nf_evar !evdref c' else c' in
+    if fail_evar then check_evars env Evd.empty !evdref c;
+    c
 
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
@@ -585,57 +601,45 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   *)
 
   let understand_judgment sigma env c =
-    let isevars = ref (create_evar_defs sigma) in
-    let j = pretype empty_tycon env isevars ([],[]) c in
-    let j = j_nf_evar (evars_of !isevars) j in
-    let isevars,_ = consider_remaining_unif_problems env !isevars in
-      check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
-      j
-
-  let understand_judgment_tcc isevars env c =
-    let j = pretype empty_tycon env isevars ([],[]) c in
-    let sigma = evars_of !isevars in
-    let j = j_nf_evar sigma j in
-      j
+    let evdref = ref (create_evar_defs sigma) in
+    let j = pretype empty_tycon env evdref ([],[]) c in
+    let evd,_ = consider_remaining_unif_problems env !evdref in
+    let j = j_nf_evar evd j in
+    check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
+    j
+
+  let understand_judgment_tcc evdref env c =
+    let j = pretype empty_tycon env evdref ([],[]) c in
+    j_nf_evar !evdref j
 
   (* Raw calls to the unsafe inference machine: boolean says if we must
      fail on unresolved evars; the unsafe_judgment list allows us to
      extend env with some bindings *)
 
-  let ise_pretype_gen fail_evar sigma env lvar kind c =
-    let isevars = ref (Evd.create_evar_defs sigma) in
-    let c = pretype_gen isevars env lvar kind c in
-    let evd = !isevars in
-      if fail_evar then check_evars env Evd.empty evd c;
-      evd, c
-	
+  let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
+    let evdref = ref (Evd.create_evar_defs sigma) in
+    let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
+    !evdref, c
+
   (** Entry points of the high-level type synthesis algorithm *)
 
   let understand_gen kind sigma env c =
-    snd (ise_pretype_gen true sigma env ([],[]) kind c)
+    snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
 
   let understand sigma env ?expected_type:exptyp c =
-    snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
+    snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
 
   let understand_type sigma env c =
-    snd (ise_pretype_gen false sigma env ([],[]) IsType c)
+    snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
 
-  let understand_ltac sigma env lvar kind c =
-    ise_pretype_gen false sigma env lvar kind c
-      
-  let understand_tcc_evars evdref env kind c =
-    pretype_gen evdref env ([],[]) kind c 
+  let understand_ltac expand_evar sigma env lvar kind c =
+    ise_pretype_gen expand_evar false true sigma env lvar kind c
 
   let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
-    let ev, t = 
-      if resolve_classes then
-	ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c 
-      else
-	let isevars = ref (Evd.create_evar_defs sigma) in
-	let c = pretype_gen_aux isevars env ([],[]) (OfType exptyp) c in
-	  !isevars, c
-    in
-      Evd.evars_of ev, t
+    ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
+
+  let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
+    pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
 end
 
 module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/contrib/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
index 2ee2018e..06a80f68 100644
--- a/contrib/subtac/subtac_utils.ml
+++ b/plugins/subtac/subtac_utils.ml
@@ -17,6 +17,7 @@ let fix_sub_module = "Wf"
 let utils_module = "Utils"
 let fixsub_module = subtac_dir @ [fix_sub_module]
 let utils_module = subtac_dir @ [utils_module]
+let tactics_module = subtac_dir @ ["Tactics"]
 let init_constant dir s = gen_constant contrib_name dir s
 let init_reference dir s = gen_reference contrib_name dir s
 
@@ -29,17 +30,17 @@ let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
 let acc_ref = make_ref  ["Init";"Wf"] "Acc"
 let acc_inv_ref = make_ref  ["Init";"Wf"] "Acc_inv"
 let fix_sub_ref = make_ref fixsub_module "Fix_sub"
+let measure_on_R_ref = make_ref fixsub_module "MR"
 let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
-let lt_ref = make_ref ["Init";"Peano"] "lt"
-let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf"
 let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
 
 let make_ref s = Qualid (dummy_loc, qualid_of_string s)
+let lt_ref = make_ref "Init.Peano.lt"
 let sig_ref = make_ref "Init.Specif.sig"
 let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
 let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
 
-let build_sig () = 
+let build_sig () =
   { proj1 = init_constant ["Init"; "Specif"] "proj1_sig";
     proj2 = init_constant ["Init"; "Specif"] "proj2_sig";
     elim = init_constant ["Init"; "Specif"] "sig_rec";
@@ -48,6 +49,12 @@ let build_sig () =
 
 let sig_ = lazy (build_sig ())
 
+let fix_proto = lazy (init_constant tactics_module "fix_proto")
+let fix_proto_ref () = 
+  match Nametab.global (make_ref "Program.Tactics.fix_proto") with
+  | ConstRef c -> c
+  | _ -> assert false
+
 let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq")
 let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec")
 let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect")
@@ -64,17 +71,15 @@ let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec")
 let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep")
 let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro")
 
-let jmeq_ind () =   
-  check_required_library ["Coq";"Logic";"JMeq"]; 
-  init_constant ["Logic";"JMeq"] "JMeq"
-
-let jmeq_rec () = 
-  check_required_library ["Coq";"Logic";"JMeq"]; 
-  init_constant ["Logic";"JMeq"] "JMeq_rec"
-
-let jmeq_refl () = 
-  check_required_library ["Coq";"Logic";"JMeq"];
-  init_constant ["Logic";"JMeq"] "JMeq_refl"
+let jmeq_ind =
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq")
+let jmeq_rec =
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq_rec")
+let jmeq_refl =
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq_refl")
 
 let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
 let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
@@ -87,7 +92,7 @@ let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool")
 let natind = lazy (init_constant ["Init"; "Datatypes"] "nat")
 let intind = lazy (init_constant ["ZArith"; "binint"] "Z")
 let existSind = lazy (init_constant ["Init"; "Specif"] "sigS")
-  
+
 let existS = lazy (build_sigma_type ())
 
 let prod = lazy (build_prod ())
@@ -111,7 +116,7 @@ let my_print_context = Termops.print_rel_context
 let my_print_named_context = Termops.print_named_context
 let my_print_env = Termops.print_env
 let my_print_rawconstr = Printer.pr_rawconstr_env
-let my_print_evardefs = Evd.pr_evar_defs
+let my_print_evardefs = Evd.pr_evar_map
 
 let my_print_tycon_type = Evarutil.pr_tycon_type
 
@@ -119,20 +124,20 @@ let debug_level = 2
 
 let debug_on = true
 
-let debug n s = 
+let debug n s =
   if debug_on then
     if !Flags.debug && n >= debug_level then
       msgnl s
     else ()
   else ()
 
-let debug_msg n s = 
+let debug_msg n s =
   if debug_on then
     if !Flags.debug  && n >= debug_level then s
     else mt ()
   else mt ()
 
-let trace s = 
+let trace s =
   if debug_on then
     if !Flags.debug  && debug_level > 0 then msgnl s
     else ()
@@ -144,28 +149,28 @@ let rec pp_list f = function
 
 let wf_relations = Hashtbl.create 10
 
-let std_relations () = 
+let std_relations () =
   let add k v = Hashtbl.add wf_relations k v in
     add (init_constant ["Init"; "Peano"] "lt")
       (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf"))
-      
+
 let std_relations = Lazy.lazy_from_fun std_relations
 
 type binders = Topconstr.local_binder list
 
-let app_opt c e = 
+let app_opt c e =
   match c with
       Some constr -> constr e
-    | None -> e	
+    | None -> e
 
-let print_args env args = 
+let print_args env args =
   Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
 
 let make_existential loc ?(opaque = Define true) env isevars c =
   let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in
   let (key, args) = destEvar evar in
     (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
-		  print_args env args ++ str " for type: "++ 
+		  print_args env args ++ str " for type: "++
 		  my_print_constr env c) with _ -> ());
     evar
 
@@ -184,29 +189,31 @@ let string_of_hole_kind = function
   | TomatchTypeParameter _ -> "TomatchTypeParameter"
   | GoalEvar -> "GoalEvar"
   | ImpossibleCase -> "ImpossibleCase"
+  | MatchingVar _ -> "MatchingVar"
 
-let evars_of_term evc init c = 
+let evars_of_term evc init c =
   let rec evrec acc c =
     match kind_of_term c with
     | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n)
     | Evar (n, _) -> assert(false)
     | _ -> fold_constr evrec acc c
-  in 
+  in
     evrec init c
 
 let non_instanciated_map env evd evm =
-  List.fold_left 
-    (fun evm (key, evi) -> 
+  List.fold_left
+    (fun evm (key, evi) ->
        let (loc,k) = evar_source key !evd in
-	 debug 2 (str "evar " ++ int key ++ str " has kind " ++ 
+	 debug 2 (str "evar " ++ int key ++ str " has kind " ++
 		    str (string_of_hole_kind k));
-	 match k with 
-	     QuestionMark _ -> Evd.add evm key evi
-	   | _ ->
-	       debug 2 (str " and is an implicit");
-	       Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None)
+	 match k with
+	 | QuestionMark _ -> Evd.add evm key evi
+	 | ImplicitArg (_,_,false) -> Evd.add evm key evi
+	 | _ ->
+	     debug 2 (str " and is an implicit");
+	     Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None)
     Evd.empty (Evarutil.non_instantiated evm)
-    
+
 let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
 let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
 
@@ -220,7 +227,7 @@ open Tactics
 open Tacticals
 
 let id x = x
-let filter_map f l = 
+let filter_map f l =
   let rec aux acc = function
       hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
 		     | None -> aux acc tl)
@@ -235,36 +242,36 @@ let build_dependent_sum l =
 	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
 	   with _ -> ());
 	let tac = assert_tac (Name n) hyptype in
-	let conttac = 
-	  (fun cont -> 
+	let conttac =
+	  (fun cont ->
 	     conttac
 	     (tclTHENS tac
 		([intros;
-		  (tclTHENSEQ 
-		     [constructor_tac false (Some 1) 1 
-			(Rawterm.ImplicitBindings [inj_open (mkVar n)]);
+		  (tclTHENSEQ
+		     [constructor_tac false (Some 1) 1
+			(Rawterm.ImplicitBindings [mkVar n]);
 		      cont]);
 		 ])))
 	in
-	let conttype = 
-	  (fun typ -> 
+	let conttype =
+	  (fun typ ->
 	     let tex = mkLambda (Name n, t, typ) in
 	       conttype
 		 (mkApp (Lazy.force ex_ind, [| t; tex |])))
 	in
 	  aux (mkVar n :: names) conttac conttype tl
-    | (n, t) :: [] -> 
+    | (n, t) :: [] ->
 	(conttac intros, conttype t)
     | [] -> raise (Invalid_argument "build_dependent_sum")
-  in aux [] id id (List.rev l)       
-	  
+  in aux [] id id (List.rev l)
+
 open Proof_type
 open Tacexpr
 
-let mkProj1 a b c = 
+let mkProj1 a b c =
   mkApp (Lazy.force proj1, [| a; b; c |])
 
-let mkProj2 a b c = 
+let mkProj2 a b c =
   mkApp (Lazy.force proj2, [| a; b; c |])
 
 let mk_ex_pi1 a b c =
@@ -272,15 +279,15 @@ let mk_ex_pi1 a b c =
 
 let mk_ex_pi2 a b c =
   mkApp (Lazy.force ex_pi2, [| a; b; c |])
-    
-let mkSubset name typ prop = 
+
+let mkSubset name typ prop =
   mkApp ((Lazy.force sig_).typ,
 	 [| typ; mkLambda (name, typ, prop) |])
 
 let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
 let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y = mkApp (jmeq_ind (), [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (jmeq_refl (), [| typ; x |])
+let mk_JMeq typ x typ' y = mkApp (Lazy.force jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (Lazy.force jmeq_refl, [| typ; x |])
 
 let unsafe_fold_right f = function
     hd :: tl -> List.fold_right f tl hd
@@ -298,44 +305,44 @@ let mk_not c =
     mkApp (notc, [| c |])
 
 let and_tac l hook =
-  let andc = Coqlib.build_coq_and () in      
+  let andc = Coqlib.build_coq_and () in
   let rec aux ((accid, goal, tac, extract) as acc) = function
     | [] -> (* Singleton *) acc
-	
+
     | (id, x, elgoal, eltac) :: tl ->
 	let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in
 	let proj = fun c -> mkProj2 goal elgoal c in
 	let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in
-	  aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', 
+	  aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac',
 	       (id, x, elgoal, proj) :: extract) tl
 
   in
-  let and_proof_id, and_goal, and_tac, and_extract = 
+  let and_proof_id, and_goal, and_tac, and_extract =
     match l with
       | [] -> raise (Invalid_argument "and_tac: empty list of goals")
-      | (hdid, x, hdg, hdt) :: tl -> 
+      | (hdid, x, hdg, hdt) :: tl ->
 	  aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl
   in
   let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in
-    Command.start_proof and_proofid goal_kind and_goal
+    Lemmas.start_proof and_proofid goal_kind and_goal
       (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract));
     trace (str "Started and proof");
     Pfedit.by and_tac;
     trace (str "Applied and tac")
-      
 
-let destruct_ex ext ex = 
-  let rec aux c acc = 
+
+let destruct_ex ext ex =
+  let rec aux c acc =
     match kind_of_term c with
 	App (f, args) ->
 	  (match kind_of_term f with
 	       Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 ->
-		 let (dom, rng) = 
+		 let (dom, rng) =
 		   try (args.(0), args.(1))
 		   with _ -> assert(false)
 		 in
 		 let pi1 = (mk_ex_pi1 dom rng acc) in
-		 let rng_body = 
+		 let rng_body =
 		   match kind_of_term rng with
 		       Lambda (_, _, t) -> subst1 pi1 t
 		     | t -> rng
@@ -346,19 +353,19 @@ let destruct_ex ext ex =
   in aux ex ext
 
 open Rawterm
-	
+
 let id_of_name = function
     Name n -> n
   | Anonymous -> raise (Invalid_argument "id_of_name")
 
 let definition_message id =
   Nameops.pr_id id ++ str " is defined"
-    
+
 let recursive_message v =
   match Array.length v with
     | 0 -> error "no recursive definition"
     | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_coma (Printer.pr_constant (Global.env ())) v ++
+    | _ -> hov 0 (prvect_with_sep pr_comma (Printer.pr_constant (Global.env ())) v ++
 		    spc () ++ str "are recursively defined")
 
 let print_message m =
@@ -372,7 +379,10 @@ let solve_by_tac evi t =
     (fun _ _ -> ());
     Pfedit.by (tclCOMPLETE t);
     let _,(const,_,_,_) = Pfedit.cook_proof ignore in
-      Pfedit.delete_current_proof (); const.Entries.const_entry_body
+      Pfedit.delete_current_proof (); 
+      Inductiveops.control_only_guard (Global.env ())
+	const.Entries.const_entry_body;
+      const.Entries.const_entry_body
   with e ->
     Pfedit.delete_current_proof();
     raise e
@@ -396,7 +406,7 @@ let rec string_of_list sep f = function
   | x :: [] -> f x
   | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
 
-let string_of_intset d = 
+let string_of_intset d =
   string_of_list "," string_of_int (Intset.elements d)
 
 (**********************************************************)
@@ -414,20 +424,20 @@ let pr_meta_map evd =
     | _ -> mt() in
   let pr_meta_binding = function
     | (mv,Cltyp (na,b)) ->
-      	hov 0 
+      	hov 0
 	  (pr_meta mv ++ pr_name na ++ str " : " ++
            print_constr b.rebus ++ fnl ())
     | (mv,Clval(na,b,_)) ->
-      	hov 0 
+      	hov 0
 	  (pr_meta mv ++ pr_name na ++ str " := " ++
              print_constr (fst b).rebus ++ fnl ())
   in
-  prlist pr_meta_binding ml    
+  prlist pr_meta_binding ml
 
 let pr_idl idl = prlist_with_sep pr_spc pr_id idl
 
 let pr_evar_info evi =
-  let phyps = 
+  let phyps =
     (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
     Printer.pr_named_context (Global.env()) (evar_context evi)
   in
@@ -440,7 +450,7 @@ let pr_evar_info evi =
   hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
 
 let pr_evar_map sigma =
-  h 0 
+  h 0
     (prlist_with_sep pr_fnl
       (fun (ev,evi) ->
         h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
@@ -452,12 +462,12 @@ let pr_constraints pbs =
       print_constr t1 ++ spc() ++
       str (match pbty with
 	| Reduction.CONV -> "=="
-	| Reduction.CUMUL -> "<=") ++ 
+	| Reduction.CUMUL -> "<=") ++
       spc() ++ print_constr t2) pbs)
 
-let pr_evar_defs evd =
+let pr_evar_map evd =
   let pp_evm =
-    let evars = evars_of evd in
+    let evars =  evd in
     if evars = empty then mt() else
       str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
   let pp_met =
diff --git a/contrib/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
index 9c014286..d0ad334d 100644
--- a/contrib/subtac/subtac_utils.mli
+++ b/plugins/subtac/subtac_utils.mli
@@ -24,16 +24,19 @@ val well_founded_ref : global_reference lazy_t
 val acc_ref : global_reference lazy_t
 val acc_inv_ref : global_reference lazy_t
 val fix_sub_ref : global_reference lazy_t
+val measure_on_R_ref : global_reference lazy_t
 val fix_measure_sub_ref : global_reference lazy_t
-val lt_ref : global_reference lazy_t
-val lt_wf_ref : global_reference lazy_t
 val refl_ref : global_reference lazy_t
+val lt_ref : reference
 val sig_ref : reference
 val proj1_sig_ref : reference
 val proj2_sig_ref : reference
 val build_sig : unit -> coq_sigma_data
 val sig_ : coq_sigma_data lazy_t
 
+val fix_proto : constr lazy_t
+val fix_proto_ref : unit -> constant
+
 val eq_ind : constr lazy_t
 val eq_rec : constr lazy_t
 val eq_rect : constr lazy_t
@@ -45,9 +48,9 @@ val and_typ : constr lazy_t
 val eqdep_ind : constr lazy_t
 val eqdep_rec : constr lazy_t
 
-val jmeq_ind : unit -> constr
-val jmeq_rec : unit -> constr
-val jmeq_refl : unit -> constr
+val jmeq_ind : constr lazy_t
+val jmeq_rec : constr lazy_t
+val jmeq_refl : constr lazy_t
 
 val boolind : constr lazy_t
 val sumboolind : constr lazy_t
@@ -66,7 +69,7 @@ val extsort : sorts -> constr_expr
 
 val my_print_constr : env -> constr -> std_ppcmds
 val my_print_constr_expr : constr_expr -> std_ppcmds
-val my_print_evardefs : evar_defs -> std_ppcmds
+val my_print_evardefs : evar_map -> std_ppcmds
 val my_print_context : env -> std_ppcmds
 val my_print_rel_context : env -> rel_context -> std_ppcmds
 val my_print_named_context : env -> std_ppcmds
@@ -83,12 +86,12 @@ val wf_relations : (constr, constr lazy_t) Hashtbl.t
 type binders = local_binder list
 val app_opt : ('a -> 'a) option -> 'a -> 'a
 val print_args : env -> constr array -> std_ppcmds
-val make_existential : loc -> ?opaque:obligation_definition_status -> 
-  env -> evar_defs ref -> types -> constr
+val make_existential : loc -> ?opaque:obligation_definition_status ->
+  env -> evar_map ref -> types -> constr
 val make_existential_expr : loc -> 'a -> 'b -> constr_expr
 val string_of_hole_kind : hole_kind -> string
 val evars_of_term : evar_map -> evar_map -> constr -> evar_map
-val non_instanciated_map : env -> evar_defs ref -> evar_map -> evar_map
+val non_instanciated_map : env -> evar_map ref -> evar_map -> evar_map
 val global_kind : logical_kind
 val goal_kind : locality * goal_object_kind
 val global_proof_kind : logical_kind
@@ -103,13 +106,13 @@ val mk_ex_pi1 : constr -> constr -> constr -> constr
 val mk_ex_pi1 : constr -> constr -> constr -> constr
 val mk_eq : types -> constr -> constr -> types
 val mk_eq_refl : types -> constr -> constr
-val mk_JMeq : types -> constr -> types -> constr -> types
+val mk_JMeq : types -> constr-> types -> constr -> types
 val mk_JMeq_refl : types -> constr -> constr
 val mk_conj : types list -> types
 val mk_not : types -> types
 
 val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types
-val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->  
+val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->
   ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit
 
 val destruct_ex : constr -> constr -> constr list
@@ -126,7 +129,7 @@ val solve_by_tac : evar_info -> Tacmach.tactic -> constr
 val string_of_list : string -> ('a -> string) -> 'a list -> string
 val string_of_intset : Intset.t -> string
 
-val pr_evar_defs : evar_defs -> Pp.std_ppcmds
+val pr_evar_map : evar_map -> Pp.std_ppcmds
 
 val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
 
diff --git a/contrib/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v
index da612c43..e3dbd127 100644
--- a/contrib/subtac/test/ListDep.v
+++ b/plugins/subtac/test/ListDep.v
@@ -22,7 +22,7 @@ Section Map_DependentRecursor.
   Variable l : list U.
   Variable f : { x : U | In x l } -> V.
 
-  Obligations Tactic := unfold sub_list in * ; 
+  Obligations Tactic := unfold sub_list in * ;
     program_simpl ; intuition.
 
   Program Fixpoint map_rec ( l' : list U | sub_list l' l )
@@ -32,16 +32,16 @@ Section Map_DependentRecursor.
       | cons x tl => let tl' := map_rec tl in
 	f x :: tl'
     end.
-    
+
   Next Obligation.
     destruct_call map_rec.
     simpl in *.
     subst l'.
     simpl ; auto with arith.
   Qed.
-      
+
   Program Definition map : list V := map_rec l.
-    
+
 End Map_DependentRecursor.
 
 Extraction map.
diff --git a/contrib/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v
index 05fc0803..2cea0841 100644
--- a/contrib/subtac/test/ListsTest.v
+++ b/plugins/subtac/test/ListsTest.v
@@ -7,7 +7,7 @@ Set Implicit Arguments.
 Section Accessors.
   Variable A : Set.
 
-  Program Definition myhd : forall (l : list A | length l <> 0), A :=  
+  Program Definition myhd : forall (l : list A | length l <> 0), A :=
     fun l =>
       match l with
         | nil => !
@@ -34,22 +34,22 @@ Section app.
     match l with
       | nil => l'
       | hd :: tl => hd :: (tl ++ l')
-    end 
+    end
     where "x ++ y" := (app x y).
 
   Next Obligation.
     intros.
     destruct_call app ; program_simpl.
   Defined.
-  
+
   Program Lemma app_id_l : forall l : list A, l = nil ++ l.
   Proof.
     simpl ; auto.
   Qed.
-  
+
   Program Lemma app_id_r : forall l : list A, l = l ++ nil.
   Proof.
-    induction l ; simpl in * ; auto. 
+    induction l ; simpl in * ; auto.
     rewrite <- IHl ; auto.
   Qed.
 
@@ -61,7 +61,7 @@ Section Nth.
 
   Variable A : Set.
 
-  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := 
+  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A :=
     match n, l with
       | 0, hd :: _ => hd
       | S n', _ :: tl => nth tl n'
@@ -70,7 +70,7 @@ Section Nth.
 
   Next Obligation.
   Proof.
-    simpl in *. auto with arith. 
+    simpl in *. auto with arith.
   Defined.
 
   Next Obligation.
@@ -78,7 +78,7 @@ Section Nth.
     inversion H.
   Qed.
 
-  Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := 
+  Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A :=
     match l, n with
       | hd :: _, 0 => hd
       | _ :: tl, S n' => nth' tl n'
@@ -86,7 +86,7 @@ Section Nth.
     end.
   Next Obligation.
   Proof.
-    simpl in *. auto with arith. 
+    simpl in *. auto with arith.
   Defined.
 
   Next Obligation.
diff --git a/contrib/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v
index ac49ca96..01e2d75f 100644
--- a/contrib/subtac/test/Mutind.v
+++ b/plugins/subtac/test/Mutind.v
@@ -1,11 +1,11 @@
 Require Import List.
 
-Program Fixpoint f a : { x : nat | x > 0 } := 
+Program Fixpoint f a : { x : nat | x > 0 } :=
   match a with
   | 0 => 1
   | S a' => g a a'
   end
-with g a b : { x : nat | x > 0 } := 
+with g a b : { x : nat | x > 0 } :=
   match b with
   | 0 => 1
   | S b' => f b'
diff --git a/contrib/subtac/test/Test1.v b/plugins/subtac/test/Test1.v
index 14b80854..7e0755d5 100644
--- a/contrib/subtac/test/Test1.v
+++ b/plugins/subtac/test/Test1.v
@@ -1,4 +1,4 @@
-Program Definition test (a b : nat) : { x : nat | x = a + b } := 
+Program Definition test (a b : nat) : { x : nat | x = a + b } :=
   ((a + b) : { x : nat | x = a + b }).
 Proof.
 intros.
diff --git a/contrib/subtac/test/euclid.v b/plugins/subtac/test/euclid.v
index 501aa798..97c3d941 100644
--- a/contrib/subtac/test/euclid.v
+++ b/plugins/subtac/test/euclid.v
@@ -1,12 +1,12 @@
 Require Import Coq.Program.Program.
 Require Import Coq.Arith.Compare_dec.
 Notation "( x & y )" := (existS _ x y) : core_scope.
-  
+
 Require Import Omega.
 
 Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a}  :
   { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
-  if le_lt_dec b a then let (q', r) := euclid (a - b) b in 
+  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
   (S q' & r)
   else (O & a).
 
diff --git a/contrib/subtac/test/id.v b/plugins/subtac/test/id.v
index 9ae11088..9ae11088 100644
--- a/contrib/subtac/test/id.v
+++ b/plugins/subtac/test/id.v
diff --git a/contrib/subtac/test/measure.v b/plugins/subtac/test/measure.v
index 4f938f4f..4f938f4f 100644
--- a/contrib/subtac/test/measure.v
+++ b/plugins/subtac/test/measure.v
diff --git a/contrib/subtac/test/rec.v b/plugins/subtac/test/rec.v
index aaefd8cc..aaefd8cc 100644
--- a/contrib/subtac/test/rec.v
+++ b/plugins/subtac/test/rec.v
diff --git a/contrib/subtac/test/take.v b/plugins/subtac/test/take.v
index 2e17959c..90ae8bae 100644
--- a/contrib/subtac/test/take.v
+++ b/plugins/subtac/test/take.v
@@ -11,7 +11,7 @@ Print cons.
 Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } :=
   match n with
   | 0 => nil
-  | S p => 
+  | S p =>
     match l with
     | cons hd tl => let rest := take tl p in cons hd rest
     | nil => !
diff --git a/contrib/subtac/test/wf.v b/plugins/subtac/test/wf.v
index 49fec2b8..5ccc154a 100644
--- a/contrib/subtac/test/wf.v
+++ b/plugins/subtac/test/wf.v
@@ -29,7 +29,7 @@ Require Import Wf_nat.
 
 Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
   { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
-  if le_lt_dec b a then let (q', r) := euclid (a - b) b in 
+  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
   (S q' & r)
   else (O & a).
 destruct b ; simpl_subtac.
diff --git a/parsing/g_ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index 944e2338..19473dfa 100644
--- a/parsing/g_ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: g_ascii_syntax.ml 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -21,7 +21,7 @@ open Bigint
 exception Non_closed_ascii
 
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let make_kn dir id = Libnames.encode_kn (make_dir dir) (id_of_string id)
+let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id)
 let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
 
 let ascii_module = ["Coq";"Strings";"Ascii"]
@@ -38,7 +38,7 @@ let glob_Ascii = lazy (make_reference "Ascii")
 open Lazy
 
 let interp_ascii dloc p =
-  let rec aux n p = 
+  let rec aux n p =
      if n = 0 then [] else
      let mp = p mod 2 in
      RRef (dloc,if mp = 0 then glob_false else glob_true)
@@ -46,7 +46,7 @@ let interp_ascii dloc p =
   RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p)
 
 let interp_ascii_string dloc s =
-  let p = 
+  let p =
     if String.length s = 1 then int_of_char s.[0]
     else
       if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
@@ -62,12 +62,12 @@ let uninterp_ascii r =
     | RRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
     | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
     | _ -> raise Non_closed_ascii in
-  try 
+  try
     let rec aux = function
     | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
     | _ -> raise Non_closed_ascii in
     Some (aux r)
-  with 
+  with
    Non_closed_ascii -> None
 
 let make_ascii_string n =
diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib
new file mode 100644
index 00000000..b00f9250
--- /dev/null
+++ b/plugins/syntax/ascii_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Ascii_syntax
+Ascii_syntax_plugin_mod
diff --git a/parsing/g_natsyntax.ml b/plugins/syntax/nat_syntax.ml
index 8804d81a..5d20c2a3 100644
--- a/parsing/g_natsyntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_natsyntax.ml 10348 2007-12-06 17:36:14Z aspiwack $ *)
+(* $Id$ *)
 
 (* This file defines the printer for natural numbers in [nat] *)
 
@@ -33,7 +33,7 @@ open Names
 let nat_of_int dloc n =
   if is_pos_or_zero n then begin
       if less_than (of_string "5000") n then
-	Flags.if_warn msg_warning 
+	Flags.if_warn 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 " ++
@@ -41,11 +41,11 @@ let nat_of_int dloc n =
       let ref_O = RRef (dloc, glob_O) in
       let ref_S = RRef (dloc, glob_S) in
       let rec mk_nat acc n =
-	if n <> zero then 
+	if n <> zero then
 	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
-	else 
+	else
 	  acc
-      in 
+      in
       mk_nat ref_O n
     end
   else
@@ -61,9 +61,9 @@ let rec int_of_nat = function
   | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
   | RRef (_,z) when z = glob_O -> zero
   | _ -> raise Non_closed_number
-	  
+
 let uninterp_nat p =
-  try 
+  try
     Some (int_of_nat p)
   with
     Non_closed_number -> None
diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib
new file mode 100644
index 00000000..69b0cb20
--- /dev/null
+++ b/plugins/syntax/nat_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Nat_syntax
+Nat_syntax_plugin_mod
diff --git a/parsing/g_intsyntax.ml b/plugins/syntax/numbers_syntax.ml
index 64fa0b49..4375d5e0 100644
--- a/parsing/g_intsyntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_intsyntax.ml 12509 2009-11-12 15:52:50Z letouzey $ i*)
+(*i $Id$ i*)
 
 (* digit-based syntax for int31, bigN bigZ and bigQ *)
 
@@ -14,23 +14,22 @@ open Bigint
 open Libnames
 open Rawterm
 
-(*** Constants for locating the int31 and bigN ***)
-
-
+(*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
 
 let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l))
 let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id)
 
-(* copied on g_zsyntax.ml, where it is said to be a temporary hack*)
-(* takes a path an identifier in the form of a string list and a string, 
-   returns a kernel_name *)
-let make_kn dir id = Libnames.encode_kn (make_dir dir) (Names.id_of_string id)
+let make_mind mp id = Names.make_mind mp Names.empty_dirpath (Names.mk_label id)
+let make_mind_mpfile dir id = make_mind (Names.MPfile (make_dir dir)) id
+let make_mind_mpdot dir modname id =
+  let mp = Names.MPdot (Names.MPfile (make_dir dir), Names.mk_label modname)
+  in make_mind mp id
 
 
 (* int31 stuff *)
 let int31_module = ["Coq"; "Numbers"; "Cyclic"; "Int31"; "Int31"]
 let int31_path = make_path int31_module "int31"
-let int31_id = make_kn int31_module
+let int31_id = make_mind_mpfile int31_module
 let int31_scope = "int31_scope"
 
 let int31_construct = ConstructRef ((int31_id "int31",0),1)
@@ -42,17 +41,14 @@ let int31_1 = ConstructRef ((int31_id "digits",0),2)
 (* bigN stuff*)
 let zn2z_module = ["Coq"; "Numbers"; "Cyclic"; "DoubleCyclic"; "DoubleType"]
 let zn2z_path = make_path zn2z_module "zn2z"
-let zn2z_id = make_kn zn2z_module
+let zn2z_id = make_mind_mpfile zn2z_module
 
 let zn2z_W0 = ConstructRef ((zn2z_id "zn2z",0),1)
 let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2)
 
 let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ]
 let bigN_path = make_path (bigN_module@["BigN"]) "t"
-(* big ugly hack *)
-let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), 
-                             Names.mk_label "BigN")),
-              [], Names.id_of_string id) : Names.kernel_name)
+let bigN_t = make_mind_mpdot bigN_module "BigN" "t_"
 let bigN_scope = "bigN_scope"
 
 (* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *)
@@ -69,8 +65,8 @@ let bigN_constructor =
       else
 	2*(to_int quo)
   in
-  fun i -> 
-  ConstructRef ((bigN_id "t_",0),
+  fun i ->
+  ConstructRef ((bigN_t,0),
 		if less_than i n_inlined then
 		  (to_int i)+1
 		else
@@ -80,27 +76,20 @@ let bigN_constructor =
 (*bigZ stuff*)
 let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ]
 let bigZ_path = make_path (bigZ_module@["BigZ"]) "t"
-(* big ugly hack bis *)
-let bigZ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), 
-                             Names.mk_label "BigZ")),
-              [], Names.id_of_string id) : Names.kernel_name)
+let bigZ_t = make_mind_mpdot bigZ_module "BigZ" "t_"
 let bigZ_scope = "bigZ_scope"
 
-let bigZ_pos = ConstructRef ((bigZ_id "t_",0),1)
-let bigZ_neg = ConstructRef ((bigZ_id "t_",0),2)
+let bigZ_pos = ConstructRef ((bigZ_t,0),1)
+let bigZ_neg = ConstructRef ((bigZ_t,0),2)
 
 
 (*bigQ stuff*)
 let bigQ_module = ["Coq"; "Numbers"; "Rational"; "BigQ"; "BigQ"]
-let qmake_module = ["Coq"; "Numbers"; "Rational"; "BigQ"; "QMake"]
 let bigQ_path = make_path (bigQ_module@["BigQ"]) "t"
-(* big ugly hack bis *)
-let bigQ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigQ_module)), 
-                             Names.mk_label "BigQ")),
-              [], Names.id_of_string id) : Names.kernel_name)
+let bigQ_t = make_mind_mpdot bigQ_module "BigQ" "t_"
 let bigQ_scope = "bigQ_scope"
 
-let bigQ_z =  ConstructRef ((bigQ_id "t_",0),1)
+let bigQ_z =  ConstructRef ((bigQ_t,0),1)
 
 
 (*** Definition of the Non_closed exception, used in the pretty printing ***)
@@ -110,7 +99,7 @@ exception Non_closed
 
 (* parses a *non-negative* integer (from bigint.ml) into an int31
    wraps modulo 2^31 *)
-let int31_of_pos_bigint dloc n = 
+let int31_of_pos_bigint dloc n =
   let ref_construct = RRef (dloc, int31_construct) in
   let ref_0 = RRef (dloc, int31_0) in
   let ref_1 = RRef (dloc, int31_1) in
@@ -126,7 +115,7 @@ let int31_of_pos_bigint dloc n =
 let error_negative dloc =
   Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
 
-let interp_int31 dloc n = 
+let interp_int31 dloc n =
   if is_pos_or_zero n then
     int31_of_pos_bigint dloc n
   else
@@ -134,20 +123,20 @@ let interp_int31 dloc n =
 
 (* Pretty prints an int31 *)
 
-let bigint_of_int31 = 
-  let rec args_parsing args cur = 
-    match args with 
+let bigint_of_int31 =
+  let rec args_parsing args cur =
+    match args with
       | [] -> cur
       | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
       | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
       | _ -> raise Non_closed
   in
-  function 
+  function
   | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero
   | _ -> raise Non_closed
 
-let uninterp_int31 i = 
-  try 
+let uninterp_int31 i =
+  try
     Some (bigint_of_int31 i)
   with Non_closed ->
     None
@@ -171,12 +160,12 @@ let rank n = pow base (pow two n)
 (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored
    it is expected to be used only when the quotient would also need 2^n int31 to be
    stored *)
-let split_at n bi = 
+let split_at n bi =
   euclid bi (rank (sub_1 n))
 
 (* search the height of the Coq bigint needed to represent the integer bi *)
 let height bi =
-  let rec height_aux n = 
+  let rec height_aux n =
     if less_than bi (rank n) then
       n
     else
@@ -201,22 +190,22 @@ let word_of_pos_bigint dloc hght n =
 			   decomp (sub_1 hgt) l])
   in
   decomp hght n
-      
+
 let bigN_of_pos_bigint dloc n =
   let ref_constructor i = RRef (dloc, bigN_constructor i) in
   let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then
 				                       [word]
 			                             else
-				                      [G_natsyntax.nat_of_int dloc (sub h n_inlined);
+				                      [Nat_syntax.nat_of_int dloc (sub h n_inlined);
 						       word])
   in
   let hght = height n in
   result hght (word_of_pos_bigint dloc hght n)
-  
+
 let bigN_error_negative dloc =
   Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
 
-let interp_bigN dloc n = 
+let interp_bigN dloc n =
   if is_pos_or_zero n then
     bigN_of_pos_bigint dloc n
   else
@@ -225,13 +214,13 @@ let interp_bigN dloc n =
 
 (* Pretty prints a bigN *)
 
-let bigint_of_word = 
+let bigint_of_word =
   let rec get_height rc =
     match rc with
-    | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> 
+    | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
 	                                  let hleft = get_height lft in
 					  let hright = get_height rght in
-					  add_1 
+					  add_1
 					    (if less_than hleft hright then
 						 hright
 					     else
@@ -250,15 +239,15 @@ let bigint_of_word =
   fun rc ->
     let hght = get_height rc in
     transform hght rc
-    
+
 let bigint_of_bigN rc =
   match rc with
   | RApp (_,_,[one_arg]) -> bigint_of_word one_arg
   | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg
   | _ -> raise Non_closed
 
-let uninterp_bigN rc = 
-  try 
+let uninterp_bigN rc =
+  try
     Some (bigint_of_bigN rc)
   with Non_closed ->
     None
@@ -268,7 +257,7 @@ let uninterp_bigN rc =
    numeral interpreter *)
 
 let bigN_list_of_constructors =
-  let rec build i = 
+  let rec build i =
     if less_than i (add_1 n_inlined) then
       RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i))
     else
@@ -286,7 +275,7 @@ let _ = Notation.declare_numeral_interpreter bigN_scope
 
 
 (*** Parsing for bigZ in digital notation ***)
-let interp_bigZ dloc n = 
+let interp_bigZ dloc n =
   let ref_pos = RRef (dloc, bigZ_pos) in
   let ref_neg = RRef (dloc, bigZ_neg) in
   if is_pos_or_zero n then
@@ -297,8 +286,8 @@ let interp_bigZ dloc n =
 (* pretty printing functions for bigZ *)
 let bigint_of_bigZ = function
   | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg
-  | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> 
-      let opp_val = bigint_of_bigN one_arg in 
+  | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg ->
+      let opp_val = bigint_of_bigN one_arg in
       if equal opp_val zero then
 	raise Non_closed
       else
@@ -306,13 +295,13 @@ let bigint_of_bigZ = function
   | _ -> raise Non_closed
 
 
-let uninterp_bigZ rc = 
-  try 
+let uninterp_bigZ rc =
+  try
     Some (bigint_of_bigZ rc)
   with Non_closed ->
     None
 
-(* Actually declares the interpreter for bigN *)
+(* Actually declares the interpreter for bigZ *)
 let _ = Notation.declare_numeral_interpreter bigZ_scope
   (bigZ_path, bigZ_module)
   interp_bigZ
@@ -322,23 +311,20 @@ let _ = Notation.declare_numeral_interpreter bigZ_scope
    true)
 
 (*** Parsing for bigQ in digital notation ***)
-let interp_bigQ dloc n = 
+let interp_bigQ dloc n =
   let ref_z = RRef (dloc, bigQ_z) in
-  let ref_pos = RRef (dloc, bigZ_pos) in
-  let ref_neg = RRef (dloc, bigZ_neg) in
-  if is_pos_or_zero n then
-    RApp (dloc, ref_z,
-       [RApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])])
-  else
-    RApp (dloc, ref_z,
-       [RApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)])])
-
-let uninterp_bigQ rc = None
+  RApp (dloc, ref_z, [interp_bigZ dloc n])
 
+let uninterp_bigQ rc =
+  try match rc with
+    | RApp (_, RRef(_,c), [one_arg]) when c = bigQ_z ->
+	Some (bigint_of_bigZ one_arg)
+    | _ -> None (* we don't pretty-print yet fractions *)
+  with Non_closed -> None
 
 (* Actually declares the interpreter for bigQ *)
 let _ = Notation.declare_numeral_interpreter bigQ_scope
   (bigQ_path, bigQ_module)
   interp_bigQ
-  ([], uninterp_bigQ,
+  ([RRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
    true)
diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib
new file mode 100644
index 00000000..ebc0bb20
--- /dev/null
+++ b/plugins/syntax/numbers_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Numbers_syntax
+Numbers_syntax_plugin_mod
diff --git a/parsing/g_rsyntax.ml b/plugins/syntax/r_syntax.ml
index b3425899..f85309e6 100644
--- a/parsing/g_rsyntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_rsyntax.ml 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -65,7 +65,7 @@ let r_of_posint dloc n =
 
 let r_of_int dloc z =
   if is_strictly_neg z then
-    RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) 
+    RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
   else
     r_of_posint dloc z
 
@@ -90,7 +90,7 @@ let rec bignat_of_pos = function
       mult_2 (bignat_of_pos b)
   (* 1+(1+1)*b *)
   | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])])
-      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  -> 
+      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  ->
       if bignat_of_pos a <> two then raise Non_closed_number;
         add_1 (mult_2 (bignat_of_pos b))
   | _ -> raise Non_closed_number
diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib
new file mode 100644
index 00000000..5c173a14
--- /dev/null
+++ b/plugins/syntax/r_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+R_syntax
+R_syntax_plugin_mod
diff --git a/parsing/g_string_syntax.ml b/plugins/syntax/string_syntax.ml
index 6a650987..bc02357a 100644
--- a/parsing/g_string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*i $Id: g_string_syntax.ml 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Util
@@ -14,7 +14,7 @@ open Names
 open Pcoq
 open Libnames
 open Topconstr
-open G_ascii_syntax
+open Ascii_syntax
 open Rawterm
 open Coqlib
 
@@ -38,14 +38,14 @@ open Lazy
 
 let interp_string dloc s =
   let le = String.length s in
-  let rec aux n = 
+  let rec aux n =
      if n = le then RRef (dloc, force glob_EmptyString) else
      RApp (dloc,RRef (dloc, force glob_String),
        [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
   in aux 0
 
 let uninterp_string r =
-  try 
+  try
     let b = Buffer.create 16 in
     let rec aux = function
     | RApp (_,RRef (_,k),[a;s]) when k = force glob_String ->
@@ -57,13 +57,13 @@ let uninterp_string r =
     | _ ->
 	raise Non_closed_string
     in aux r
-  with 
+  with
    Non_closed_string -> None
 
 let _ =
   Notation.declare_string_interpreter "string_scope"
     (string_path,["Coq";"Strings";"String"])
     interp_string
-    ([RRef (dummy_loc,static_glob_String); 
+    ([RRef (dummy_loc,static_glob_String);
       RRef (dummy_loc,static_glob_EmptyString)],
      uninterp_string, true)
diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib
new file mode 100644
index 00000000..b108c9e0
--- /dev/null
+++ b/plugins/syntax/string_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+String_syntax
+String_syntax_plugin_mod
diff --git a/parsing/g_zsyntax.ml b/plugins/syntax/z_syntax.ml
index 8b9c0d22..f6afd080 100644
--- a/parsing/g_zsyntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_zsyntax.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Pcoq
 open Pp
@@ -31,9 +31,9 @@ let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
 let positive_path = make_path positive_module "positive"
 
 (* TODO: temporary hack *)
-let make_kn dir id = Libnames.encode_kn dir id
+let make_kn dir id = Libnames.encode_mind dir id
 
-let positive_kn = 
+let positive_kn =
   make_kn (make_dir positive_module) (id_of_string "positive")
 let glob_positive = IndRef (positive_kn,0)
 let path_of_xI = ((positive_kn,0),1)
@@ -52,10 +52,10 @@ let pos_of_bignat dloc x =
       | (q,false) -> RApp (dloc, ref_xO,[pos_of q])
       | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q])
       | (q,true) -> ref_xH
-  in 
+  in
   pos_of x
 
-let error_non_positive dloc = 
+let error_non_positive dloc =
   user_err_loc (dloc, "interp_positive",
     str "Only strictly positive numbers in type \"positive\".")
 
@@ -74,9 +74,9 @@ let rec bignat_of_pos = function
   | _ -> raise Non_closed_number
 
 let uninterp_positive p =
-  try 
+  try
     Some (bignat_of_pos p)
-  with Non_closed_number -> 
+  with Non_closed_number ->
     None
 
 (************************************************************************)
@@ -87,7 +87,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope"
   (positive_path,positive_module)
   interp_positive
   ([RRef (dummy_loc, glob_xI);
-    RRef (dummy_loc, glob_xO); 
+    RRef (dummy_loc, glob_xO);
     RRef (dummy_loc, glob_xH)],
    uninterp_positive,
    true)
@@ -106,10 +106,10 @@ let glob_Npos = ConstructRef path_of_Npos
 
 let n_path = make_path binnat_module "N"
 
-let n_of_binnat dloc pos_or_neg n = 
+let n_of_binnat dloc pos_or_neg n =
   if n <> zero then
     RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n])
-  else 
+  else
     RRef (dloc, glob_N0)
 
 let error_negative dloc =
@@ -138,11 +138,11 @@ let uninterp_n p =
 let _ = Notation.declare_numeral_interpreter "N_scope"
   (n_path,binnat_module)
   n_of_int
-  ([RRef (dummy_loc, glob_N0); 
+  ([RRef (dummy_loc, glob_N0);
     RRef (dummy_loc, glob_Npos)],
   uninterp_n,
   true)
-   
+
 (**********************************************************************)
 (* Parsing Z via scopes                                               *)
 (**********************************************************************)
@@ -158,12 +158,12 @@ let glob_ZERO = ConstructRef path_of_ZERO
 let glob_POS = ConstructRef path_of_POS
 let glob_NEG = ConstructRef path_of_NEG
 
-let z_of_int dloc n = 
+let z_of_int dloc n =
   if n <> zero then
     let sgn, n =
       if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
     RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n])
-  else 
+  else
     RRef (dloc, glob_ZERO)
 
 (**********************************************************************)
@@ -187,8 +187,8 @@ let uninterp_z p =
 let _ = Notation.declare_numeral_interpreter "Z_scope"
   (z_path,binint_module)
   z_of_int
-  ([RRef (dummy_loc, glob_ZERO); 
-    RRef (dummy_loc, glob_POS); 
+  ([RRef (dummy_loc, glob_ZERO);
+    RRef (dummy_loc, glob_POS);
     RRef (dummy_loc, glob_NEG)],
   uninterp_z,
   true)
diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib
new file mode 100644
index 00000000..36d41acc
--- /dev/null
+++ b/plugins/syntax/z_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Z_syntax
+Z_syntax_plugin_mod
diff --git a/contrib/xml/COPYRIGHT b/plugins/xml/COPYRIGHT
index c8d231fd..c8d231fd 100644
--- a/contrib/xml/COPYRIGHT
+++ b/plugins/xml/COPYRIGHT
diff --git a/contrib/xml/README b/plugins/xml/README
index a45dd31a..a45dd31a 100644
--- a/contrib/xml/README
+++ b/plugins/xml/README
diff --git a/contrib/xml/acic.ml b/plugins/xml/acic.ml
index 032ddbeb..40bc61bb 100644
--- a/contrib/xml/acic.ml
+++ b/plugins/xml/acic.ml
@@ -56,7 +56,7 @@ type obj =
  | InductiveDefinition of
     inductiveType list *                           (* inductive types ,      *)
     params * int                                   (*  parameters,n ind. pars*)
-and inductiveType = 
+and inductiveType =
  identifier * bool * constr *                 (* typename, inductive, arity *)
   constructor list                            (*  constructors              *)
 and constructor =
@@ -78,9 +78,9 @@ type aconstr =
   | ACase      of id * uri * int * aconstr * aconstr * aconstr list
   | AFix       of id * int * ainductivefun list
   | ACoFix     of id * int * acoinductivefun list
-and ainductivefun = 
+and ainductivefun =
  id * identifier * int * aconstr * aconstr
-and acoinductivefun = 
+and acoinductivefun =
  id * identifier * aconstr * aconstr
 and explicit_named_substitution = id option * (uri * aconstr) list
 
@@ -101,7 +101,7 @@ type aobj =
  | AInductiveDefinition of id *
     anninductiveType list *                        (* inductive types ,      *)
     params * int                                   (*  parameters,n ind. pars*)
-and anninductiveType = 
+and anninductiveType =
  id * identifier * bool * aconstr *           (* typename, inductive, arity *)
   annconstructor list                         (*  constructors              *)
 and annconstructor =
diff --git a/contrib/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
index 64dc8a05..fb40ed86 100644
--- a/contrib/xml/acic2Xml.ml4
+++ b/plugins/xml/acic2Xml.ml4
@@ -44,7 +44,7 @@ let print_term ids_to_inner_sorts =
          X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort]
      | A.AEvar (id,n,l) ->
         let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "META" 
+         X.xml_nempty "META"
 	   ["no",(export_existential n) ; "id",id ; "sort",sort]
           (List.fold_left
             (fun i t ->
diff --git a/contrib/xml/cic.dtd b/plugins/xml/cic.dtd
index c8035cab..c8035cab 100644
--- a/contrib/xml/cic.dtd
+++ b/plugins/xml/cic.dtd
diff --git a/contrib/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml
index 08d3a850..981503a6 100644
--- a/contrib/xml/cic2Xml.ml
+++ b/plugins/xml/cic2Xml.ml
@@ -6,7 +6,7 @@ let print_xml_term ch env sigma cic =
   let ids_to_inner_types = Hashtbl.create 503 in
   let seed = ref 0 in
   let acic =
-   Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids 
+   Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids
     ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
     env [] sigma (Unshare.unshare cic) None in
   let xml = Acic2Xml.print_term ids_to_inner_sorts acic in
diff --git a/contrib/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
index 13e5e6d5..a80ceb0f 100644
--- a/contrib/xml/cic2acic.ml
+++ b/plugins/xml/cic2acic.ml
@@ -15,19 +15,19 @@
 (* Utility Functions *)
 
 exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;;
-let get_module_path_of_section_path path =
+let get_module_path_of_full_path path =
  let dirpath = fst (Libnames.repr_path path) in
  let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in
   match
    List.filter
     (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules
   with
-     [] -> 
+     [] ->
        Pp.warning ("Modules not supported: reference to "^
          Libnames.string_of_path path^" will be wrong");
        dirpath
    | [modul] -> modul
-   | _ -> 
+   | _ ->
        raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther
 ;;
 
@@ -80,7 +80,7 @@ let get_uri_of_var v pvars =
 
 type tag =
    Constant of Names.constant
- | Inductive of Names.kernel_name
+ | Inductive of Names.mutual_inductive
  | Variable of Names.kernel_name
 ;;
 
@@ -117,38 +117,6 @@ let subtract l1 l2 =
    Names.make_dirpath (List.rev (aux l1'))
 ;;
 
-(*CSC: Dead code to be removed
-let token_list_of_kernel_name ~keep_sections kn tag =
- let module N = Names in
-  let (modpath,dirpath,label) = Names.repr_kn kn in
-  let token_list_of_dirpath dirpath =
-   List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
-  let rec token_list_of_modpath =
-   function
-      N.MPdot (path,label) ->
-       token_list_of_modpath path @ [N.string_of_label label]
-    | N.MPfile dirpath -> token_list_of_dirpath dirpath
-    | N.MPself self ->
-       if self = Names.initial_msid then
-        [ "Top" ]
-       else
-        let module_path =
-          let f = N.string_of_id (N.id_of_msid self) in
-          let _,longf = 
-            System.find_file_in_path (Library.get_load_path ()) (f^".v") in
-          let ldir0 = Library.find_logical_path (Filename.dirname longf) in
-          let id = Names.id_of_string (Filename.basename f) in
-           Libnames.extend_dirpath ldir0 id
-        in
-          token_list_of_dirpath module_path
-    | N.MPbound _ -> raise FunctorsXMLExportationNotImplementedYet
-  in
-   token_list_of_modpath modpath @
-    (if keep_sections then token_list_of_dirpath dirpath else []) @
-    [N.string_of_label label ^ "." ^ (ext_of_tag tag)]
-;;
-*)
-
 let token_list_of_path dir id tag =
  let module N = Names in
   let token_list_of_dirpath dirpath =
@@ -159,13 +127,13 @@ let token_list_of_kernel_name tag =
  let module N = Names in
  let module LN = Libnames in
  let id,dir = match tag with
-   | Variable kn -> 
+   | Variable kn ->
        N.id_of_label (N.label kn), Lib.cwd ()
-   | Constant con -> 
+   | Constant con ->
        N.id_of_label (N.con_label con),
        Lib.remove_section_part (LN.ConstRef con)
    | Inductive kn ->
-       N.id_of_label (N.label kn),
+       N.id_of_label (N.mind_label kn),
        Lib.remove_section_part (LN.IndRef (kn,0))
  in
  token_list_of_path dir id (etag_of_tag tag)
@@ -177,7 +145,7 @@ let uri_of_kernel_name tag =
 
 let uri_of_declaration id tag =
  let module LN = Libnames in
- let dir = LN.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) in
+ let dir = LN.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) in
  let tokens = token_list_of_path dir id tag in
   "cic:/" ^ String.concat "/" tokens
 
@@ -211,7 +179,7 @@ module CPropRetyping =
         | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest
         | _ -> Util.anomaly "Non-functional construction"
 
-                                                                                
+
   let sort_of_atomic_type env sigma ft args =
   let rec concl_of_arity env ar =
     match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with
@@ -219,7 +187,7 @@ module CPropRetyping =
       | T.Sort s -> Coq_sort (T.family_of_sort s)
       | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
   in concl_of_arity env ft
-                                                                                
+
 let typeur sigma metamap =
   let rec type_of env cstr=
     match Term.kind_of_term cstr with
@@ -265,7 +233,7 @@ let typeur sigma metamap =
         | Coq_sort T.InSet -> T.mkSet
         | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *)
         | CProp -> T.mkConst DoubleTypeInference.cprop
-                                                                                
+
   and sort_of env t =
     match Term.kind_of_term t with
     | T.Cast (c,_, s) when T.isSort s -> family_of_term s
@@ -287,7 +255,7 @@ let typeur sigma metamap =
     | T.Lambda _ | T.Fix _ | T.Construct _ ->
         Util.anomaly "sort_of: Not a type (1)"
     | _ -> outsort env sigma (type_of env t)
-                                                                                
+
   and sort_family_of env t =
     match T.kind_of_term t with
     | T.Cast (c,_, s) when T.isSort s -> family_of_term s
@@ -299,7 +267,7 @@ let typeur sigma metamap =
     | T.Lambda _ | T.Fix _ | T.Construct _ ->
         Util.anomaly "sort_of: Not a type (1)"
     | _ -> outsort env sigma (type_of env t)
-                                                                                
+
   in type_of, sort_of, sort_family_of
 
   let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
@@ -468,14 +436,14 @@ print_endline "PASSATO" ; flush stdout ;
                 match g with
                    Libnames.ConstructRef ((induri,_),_)
                  | Libnames.IndRef (induri,_) ->
-                    Nametab.sp_of_global (Libnames.IndRef (induri,0))
+                    Nametab.path_of_global (Libnames.IndRef (induri,0))
                  | Libnames.VarRef id ->
                     (* Invariant: variables are never cooked in Coq *)
                     raise Not_found
-                 | _ -> Nametab.sp_of_global g
+                 | _ -> Nametab.path_of_global g
                in
                Dischargedhypsmap.get_discharged_hyps sp,
-               get_module_path_of_section_path sp
+               get_module_path_of_full_path sp
              with Not_found ->
                 (* no explicit substitution *)
                 [], Libnames.dirpath_of_string "dummy"
@@ -484,7 +452,7 @@ print_endline "PASSATO" ; flush stdout ;
            (* an explicit named substitution of "type" *)
            (* (variable * argument) list, whose        *)
            (* second element is the list of residual   *)
-           (* arguments and whose third argument is    *) 
+           (* arguments and whose third argument is    *)
            (* the list of uninstantiated variables     *)
            let rec get_explicit_subst variables arguments =
             match variables,arguments with
@@ -497,7 +465,7 @@ print_endline "PASSATO" ; flush stdout ;
                 let he1'' =
                  String.concat "/"
                   (List.map Names.string_of_id (List.rev he1')) ^ "/"
-                 ^ (Names.string_of_id he1_id) ^ ".var" 
+                 ^ (Names.string_of_id he1_id) ^ ".var"
                 in
                  (he1'',he2)::subst, extra_args, uninst
            in
@@ -528,7 +496,7 @@ print_endline "PASSATO" ; flush stdout ;
          in
 
           (* Now that we have all the auxiliary functions we  *)
-          (* can finally proceed with the main case analysis. *) 
+          (* can finally proceed with the main case analysis. *)
           match T.kind_of_term tt with
              T.Rel n ->
               let id =
@@ -571,7 +539,7 @@ print_endline "PASSATO" ; flush stdout ;
                    N.Anonymous
                   else
                    N.Name
-                    (Nameops.next_name_away n (Termops.ids_of_context env))
+                    (Namegen.next_name_away n (Termops.ids_of_context env))
               in
                Hashtbl.add ids_to_inner_sorts fresh_id''
                 (string_of_sort innertype) ;
@@ -607,7 +575,7 @@ print_endline "PASSATO" ; flush stdout ;
                match n with
                   N.Anonymous -> N.Anonymous
                 | _ ->
-                  N.Name (Nameops.next_name_away n (Termops.ids_of_context env))
+                  N.Name (Namegen.next_name_away n (Termops.ids_of_context env))
               in
                Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
                let sourcetype = CPropRetyping.get_type_of env evar_map s in
@@ -655,7 +623,7 @@ print_endline "PASSATO" ; flush stdout ;
                  | N.Name id -> id
               in
               let n' =
-               N.Name (Nameops.next_ident_away id (Termops.ids_of_context env))
+               N.Name (Namegen.next_ident_away id (Termops.ids_of_context env))
               in
                Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
                let sourcesort =
@@ -771,7 +739,7 @@ print_endline "PASSATO" ; flush stdout ;
                   (function
                       N.Anonymous -> Util.error "Anonymous fix function met"
                     | N.Name id as n ->
-                       let res = N.Name (Nameops.next_name_away n !ids) in
+                       let res = N.Name (Namegen.next_name_away n !ids) in
                         ids := id::!ids ;
                         res
                  ) f
@@ -805,7 +773,7 @@ print_endline "PASSATO" ; flush stdout ;
                   (function
                       N.Anonymous -> Util.error "Anonymous fix function met"
                     | N.Name id as n ->
-                       let res = N.Name (Nameops.next_name_away n !ids) in
+                       let res = N.Name (Namegen.next_name_away n !ids) in
                         ids := id::!ids ;
                         res
                  ) f
diff --git a/contrib/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
index 17d1d5da..f8921aec 100644
--- a/contrib/xml/doubleTypeInference.ml
+++ b/plugins/xml/doubleTypeInference.ml
@@ -69,12 +69,12 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
        T.Meta n ->
         Util.error
          "DoubleTypeInference.double_type_of: found a non-instanciated goal"
- 
+
      | T.Evar ((n,l) as ev) ->
         let ty = Unshare.unshare (Evd.existential_type sigma ev) in
         let jty = execute env sigma ty None in
         let jty = assumption_of_judgment env sigma jty in
-        let evar_context = 
+        let evar_context =
 	  E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in
          let rec iter actual_args evar_context =
           match actual_args,evar_context with
@@ -96,25 +96,25 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
           (* for side effects only *)
           iter (List.rev (Array.to_list l)) (List.rev evar_context) ;
           E.make_judge cstr jty
-	
-     | T.Rel n -> 
+
+     | T.Rel n ->
         Typeops.judge_of_relative env n
 
-     | T.Var id -> 
+     | T.Var id ->
         Typeops.judge_of_variable env id
-	  
+
      | T.Const c ->
         E.make_judge cstr (Typeops.type_of_constant env c)
-	  
+
      | T.Ind ind ->
         E.make_judge cstr (Inductiveops.type_of_inductive env ind)
-	  
-     | T.Construct cstruct -> 
+
+     | T.Construct cstruct ->
         E.make_judge cstr (Inductiveops.type_of_constructor env cstruct)
-	  
+
      | T.Case (ci,p,c,lf) ->
         let expectedtype =
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in 
+         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in
         let cj = execute env sigma c (Some expectedtype) in
         let pj = execute env sigma p None in
         let (expectedtypes,_,_) =
@@ -126,18 +126,18 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
           (Array.map (function x -> Some x) expectedtypes) in
         let (j,_) = Typeops.judge_of_case env ci pj cj lfj in
          j
-  
+
      | T.Fix ((vn,i as vni),recdef) ->
         let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
         let fix = (vni,recdef') in
         E.make_judge (T.mkFix fix) tys.(i)
-	  
+
      | T.CoFix (i,recdef) ->
         let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
         let cofix = (i,recdef') in
         E.make_judge (T.mkCoFix cofix) tys.(i)
-	  
-     | T.Sort (T.Prop c) -> 
+
+     | T.Sort (T.Prop c) ->
         Typeops.judge_of_prop_contents c
 
      | T.Sort (T.Type u) ->
@@ -153,8 +153,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
 )
 
      | T.App (f,args) ->
-        let expected_head = 
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in 
+        let expected_head =
+         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in
         let j = execute env sigma f (Some expected_head) in
         let expected_args =
          let rec aux typ =
@@ -172,8 +172,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
         let jl = execute_array env sigma args expected_args in
         let (j,_) = Typeops.judge_of_apply env j jl in
          j
-	    
-     | T.Lambda (name,c1,c2) -> 
+
+     | T.Lambda (name,c1,c2) ->
         let j = execute env sigma c1 None in
         let var = type_judgment env sigma j in
         let env1 = E.push_rel (name,None,var.E.utj_val) env in
@@ -186,9 +186,9 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
                   Some (Reductionops.nf_beta sigma expected_target_type)
                | _ -> assert false
         in
-        let j' = execute env1 sigma c2 expectedc2type in 
+        let j' = execute env1 sigma c2 expectedc2type in
          Typeops.judge_of_abstraction env1 name var j'
-	  
+
      | T.Prod (name,c1,c2) ->
         let j = execute env sigma c1 None in
         let varj = type_judgment env sigma j in
@@ -212,7 +212,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
         in
          let j3 = execute env1 sigma c3 None in
           Typeops.judge_of_letin env name j1 j2 j3
-  
+
      | T.Cast (c,k,t) ->
         let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in
         let tj = execute env sigma t None in
diff --git a/contrib/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
index 2e14b558..b604ec4c 100644
--- a/contrib/xml/doubleTypeInference.mli
+++ b/plugins/xml/doubleTypeInference.mli
@@ -12,7 +12,7 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-type types = { synthesized : Term.types; expected : Term.types option; } 
+type types = { synthesized : Term.types; expected : Term.types option; }
 
 val cprop : Names.constant
 
diff --git a/contrib/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
index 407f86b3..9419ba59 100644
--- a/contrib/xml/dumptree.ml4
+++ b/plugins/xml/dumptree.ml4
@@ -42,7 +42,7 @@ let thin_sign osign sign =
 ;;
 
 let pr_tactic_xml = function
-  | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" 
+  | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
   | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>"
 ;;
 
@@ -68,10 +68,10 @@ let pr_rule_xml pr = function
 let pr_var_decl_xml env (id,c,typ) =
   let ptyp = print_constr_env env typ in
   match c with
-  | None -> 
+  | None ->
       (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
   | Some c ->
-      (* Force evaluation *) 
+      (* Force evaluation *)
       let pb = print_constr_env env c in
       (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
          xmlstream pb ++ str "\"/>")
@@ -81,7 +81,7 @@ let pr_rel_decl_xml env (na,c,typ) =
   let pbody = match c with
     | None -> mt ()
     | Some c ->
-	(* Force evaluation *) 
+	(* Force evaluation *)
 	let pb = print_constr_env env c in
 	  (str" body=\"" ++ xmlstream pb ++ str "\"") in
   let ptyp = print_constr_env env typ in
@@ -108,15 +108,15 @@ let pr_context_xml env =
 ;;
 
 let pr_subgoal_metas_xml metas env=
-  let pr_one (meta, typ) = 
-    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++ 
+  let pr_one (meta, typ) =
+    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
       str "\"/>"
   in
   List.fold_left (++) (mt ()) (List.map pr_one metas)
 ;;
 
 let pr_goal_xml g =
-  let env = try evar_env g with _ -> empty_env in
+  let env = try evar_unfiltered_env g with _ -> empty_env in
   if g.evar_extra = None then
     (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
     xmlstream (pr_ltype_env_at_top env g.evar_concl) ++
@@ -124,7 +124,7 @@ let pr_goal_xml g =
     (pr_context_xml env)) ++
     fnl () ++ str "</goal>")
   else
-    (hov 2 (str "<goal type=\"declarative\">" ++ 
+    (hov 2 (str "<goal type=\"declarative\">" ++
     (pr_context_xml env)) ++
     fnl () ++ str "</goal>")
 ;;
@@ -140,13 +140,13 @@ let rec print_proof_xml sigma osign pf =
         (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "</tree>"
 ;;
 
-let print_proof_xml () = 
-  let pp = print_proof_xml Evd.empty Sign.empty_named_context 
+let print_proof_xml () =
+  let pp = print_proof_xml Evd.empty Sign.empty_named_context
       (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ())))
   in
   msgnl pp
 ;;
 
 VERNAC COMMAND EXTEND DumpTree
-  [ "Dump" "Tree" ] -> [ print_proof_xml () ] 
-END 
+  [ "Dump" "Tree" ] -> [ print_proof_xml () ]
+END
diff --git a/contrib/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
index 30dc7b71..1beabf26 100644
--- a/contrib/xml/proof2aproof.ml
+++ b/plugins/xml/proof2aproof.ml
@@ -63,8 +63,8 @@ let nf_evar sigma ~preserve =
 (* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
 let rec unshare_proof_tree =
  let module PT = Proof_type in
-  function {PT.open_subgoals = status ; 
-	    PT.goal = goal ; 
+  function {PT.open_subgoals = status ;
+	    PT.goal = goal ;
 	    PT.ref = ref} ->
    let unshared_ref =
     match ref with
@@ -78,8 +78,8 @@ let rec unshare_proof_tree =
 	in
          Some (unshared_rule, List.map unshare_proof_tree pfs)
    in
-    {PT.open_subgoals = status ; 
-     PT.goal = goal ; 
+    {PT.open_subgoals = status ;
+     PT.goal = goal ;
      PT.ref = unshared_ref}
 ;;
 
@@ -105,13 +105,13 @@ let extract_open_proof sigma pf =
     match node with
        {PT.ref=Some(PT.Prim _,_)} as pf ->
         L.prim_extractor proof_extractor vl pf
-	  
+
      | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} ->
 	 let sgl,v = Refiner.frontier hidden_proof in
 	 let flat_proof = v spfl in
          ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
 	 proof_extractor vl flat_proof
-	  
+
      | {PT.ref=None;PT.goal=goal} ->
 	 let visible_rels =
            Util.map_succeed
@@ -124,14 +124,14 @@ let extract_open_proof sigma pf =
 (*CSC: it becomes a Rel; otherwise a Var. Then it can be already used  *)
 (*CSC: as the evar_instance. Ordering the instance becomes useless (it *)
 (*CSC: will already be ordered.                                        *)
-             (Termops.ids_of_named_context 
+             (Termops.ids_of_named_context
 		(Environ.named_context_of_val goal.Evd.evar_hyps)) in
 	 let sorted_rels =
 	   Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in
 	 let context =
-	   let l = 
+	   let l =
              List.map
-               (fun (_,id) -> Sign.lookup_named id 
+               (fun (_,id) -> Sign.lookup_named id
 		   (Environ.named_context_of_val goal.Evd.evar_hyps))
                sorted_rels in
 	   Environ.val_of_named_context l
@@ -144,12 +144,12 @@ let extract_open_proof sigma pf =
              evar_instance in
          evd := evd' ;
          evar
-	  
+
      | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor"
    in
     let unsharedconstr =
      let evar_nf_constr =
-      nf_evar (Evd.evars_of !evd)
+      nf_evar ( !evd)
         ~preserve:(function e -> S.mem e !unshared_constrs) constr
      in
       Unshare.unshare
@@ -159,14 +159,14 @@ let extract_open_proof sigma pf =
 (*CSC: debugging stuff to be removed *)
 if ProofTreeHash.mem proof_tree_to_constr node then
  Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ")
- (Tactic_printer.print_proof (Evd.evars_of !evd) [] node)) ;
+ (Tactic_printer.print_proof ( !evd) [] node)) ;
      ProofTreeHash.add proof_tree_to_constr node unsharedconstr ;
      unshared_constrs := S.add unsharedconstr !unshared_constrs ;
      unsharedconstr
   in
   let unshared_pf = unshare_proof_tree pf in
   let pfterm = proof_extractor [] unshared_pf in
-   (pfterm, Evd.evars_of !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
+   (pfterm,  !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
     unshared_pf)
 ;;
 
diff --git a/contrib/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
index 7503d632..3f1e0a63 100644
--- a/contrib/xml/proofTree2Xml.ml4
+++ b/plugins/xml/proofTree2Xml.ml4
@@ -45,7 +45,7 @@ let constr_to_xml obj sigma env =
   let rel_context = Sign.push_named_to_rel_context named_context' [] in
   let rel_env =
    Environ.push_rel_context rel_context
-    (Environ.reset_with_named_context 
+    (Environ.reset_with_named_context
 	(Environ.val_of_named_context real_named_context) env) in
   let obj' =
    Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
@@ -149,7 +149,7 @@ Pp.ppnl (Pp.(++) (Pp.str
          Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
         in begin
         match tactic_expr with
-        | T.TacArg (T.Tacexp _) -> 
+        | T.TacArg (T.Tacexp _) ->
             (* We don't need to keep the level of abstraction introduced at *)
             (* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
             aux flat_proof old_hyps
@@ -189,7 +189,7 @@ Pp.ppnl (Pp.(++) (Pp.str
         end
 
      | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} ->
-         Util.anomaly "Not Implemented" 
+         Util.anomaly "Not Implemented"
 
      | {PT.ref=Some(PT.Daimon,_)} ->
          X.xml_empty "Hidden_open_goal" of_attribute
diff --git a/contrib/xml/theoryobject.dtd b/plugins/xml/theoryobject.dtd
index 953fe009..953fe009 100644
--- a/contrib/xml/theoryobject.dtd
+++ b/plugins/xml/theoryobject.dtd
diff --git a/contrib/xml/unshare.ml b/plugins/xml/unshare.ml
index f30f8230..f30f8230 100644
--- a/contrib/xml/unshare.ml
+++ b/plugins/xml/unshare.ml
diff --git a/contrib/xml/unshare.mli b/plugins/xml/unshare.mli
index 31ba9037..31ba9037 100644
--- a/contrib/xml/unshare.mli
+++ b/plugins/xml/unshare.mli
diff --git a/contrib/xml/xml.ml4 b/plugins/xml/xml.ml4
index 5b217119..5b217119 100644
--- a/contrib/xml/xml.ml4
+++ b/plugins/xml/xml.ml4
diff --git a/contrib/xml/xml.mli b/plugins/xml/xml.mli
index 38a4e01c..3775287a 100644
--- a/contrib/xml/xml.mli
+++ b/plugins/xml/xml.mli
@@ -12,7 +12,7 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-(*i $Id: xml.mli 6681 2005-02-04 18:20:16Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Tokens for XML cdata, empty elements and not-empty elements           *)
 (* Usage:                                                                *)
diff --git a/plugins/xml/xml_plugin.mllib b/plugins/xml/xml_plugin.mllib
new file mode 100644
index 00000000..90797e8d
--- /dev/null
+++ b/plugins/xml/xml_plugin.mllib
@@ -0,0 +1,13 @@
+Unshare
+Xml
+Acic
+DoubleTypeInference
+Cic2acic
+Acic2Xml
+Proof2aproof
+Xmlcommand
+ProofTree2Xml
+Xmlentries
+Cic2Xml
+Dumptree
+Xml_plugin_mod
diff --git a/contrib/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
index f4719594..2299e6c8 100644
--- a/contrib/xml/xmlcommand.ml
+++ b/plugins/xml/xmlcommand.ml
@@ -38,7 +38,7 @@ let print_if_verbose s = if !verbose then print_string s;;
 (* Next exception is used only inside print_coq_object and tag_of_string_tag *)
 exception Uninteresting;;
 
-(* NOT USED anymore, we back to the V6 point of view with global parameters 
+(* NOT USED anymore, we back to the V6 point of view with global parameters
 
 (* Internally, for Coq V7, params of inductive types are associated     *)
 (* not to the whole block of mutual inductive (as it was in V6) but to  *)
@@ -102,11 +102,11 @@ let filter_params pvars hyps =
  in
   let cwd = Lib.cwd () in
   let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in
+  let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
    aux (Names.repr_dirpath modulepath) (List.rev pvars)
 ;;
 
-type variables_type = 
+type variables_type =
    Definition of string * Term.constr * Term.types
  | Assumption of string * Term.constr
 ;;
@@ -118,7 +118,7 @@ let search_variables () =
  let module N = Names in
   let cwd = Lib.cwd () in
   let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in
+  let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
    let rec aux =
     function
        [] -> []
@@ -246,7 +246,7 @@ let find_hyps t =
    match T.kind_of_term t with
       T.Var id when not (List.mem id l) ->
        let (_,bo,ty) = Global.lookup_named id in
-        let boids = 
+        let boids =
          match bo with
             Some bo' -> aux l bo'
           | None -> l
@@ -393,7 +393,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite =
 (* The current channel for .theory files *)
 let theory_buffer = Buffer.create 4000;;
 
-let theory_output_string ?(do_not_quote = false) s = 
+let theory_output_string ?(do_not_quote = false) s =
   (* prepare for coqdoc post-processing *)
   let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in
   print_if_verbose s;
@@ -408,7 +408,11 @@ let kind_of_global_goal = function
 let kind_of_inductive isrecord kn =
  "DEFINITION",
  if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite
- then if isrecord then "Record" else "Inductive"
+ then begin 
+   match isrecord with 
+   | Declare.KernelSilent -> "Record"
+   | _ -> "Inductive"
+ end
  else "CoInductive"
 ;;
 
@@ -423,7 +427,7 @@ let kind_of_variable id =
     | _ -> Util.anomaly "Unsupported variable kind"
 ;;
 
-let kind_of_constant kn = 
+let kind_of_constant kn =
   let module DK = Decl_kinds in
   match Decls.constant_kind kn with
     | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
@@ -432,7 +436,7 @@ let kind_of_constant kn =
         Pp.warning "Conjecture not supported in dtd (used Declaration instead)";
         "AXIOM","Declaration"
     | DK.IsDefinition DK.Definition -> "DEFINITION","Definition"
-    | DK.IsDefinition DK.Example -> 
+    | DK.IsDefinition DK.Example ->
         Pp.warning "Example not supported in dtd (used Definition instead)";
         "DEFINITION","Definition"
     | DK.IsDefinition DK.Coercion ->
@@ -461,10 +465,10 @@ let kind_of_constant kn =
         "DEFINITION","Definition"
     | DK.IsDefinition DK.Instance ->
         Pp.warning "Instance not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition" 
+        "DEFINITION","Definition"
     | DK.IsDefinition DK.Method ->
         Pp.warning "Method not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition" 
+        "DEFINITION","Definition"
     | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) ->
         "THEOREM",DK.string_of_theorem_kind thm
     | DK.IsProof _ ->
@@ -476,10 +480,10 @@ let kind_of_global r =
   let module Ln = Libnames in
   let module DK = Decl_kinds in
   match r with
-  | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> 
+  | Ln.IndRef kn | Ln.ConstructRef (kn,_) ->
       let isrecord =
-	try let _ = Recordops.lookup_projections kn in true
-        with Not_found -> false in
+	try let _ = Recordops.lookup_projections kn in Declare.KernelSilent
+        with Not_found -> Declare.KernelVerbose in
       kind_of_inductive isrecord (fst kn)
   | Ln.VarRef id -> kind_of_variable id
   | Ln.ConstRef kn -> kind_of_constant kn
@@ -515,7 +519,7 @@ let print internal glob_ref kind xml_library_root =
    match glob_ref with
       Ln.VarRef id ->
        (* this kn is fake since it is not provided by Coq *)
-       let kn = 
+       let kn =
         let (mod_path,dir_path) = Lib.current_prefix () in
         N.make_kn mod_path dir_path (N.label_of_id id)
        in
@@ -539,13 +543,15 @@ let print internal glob_ref kind xml_library_root =
   in
   let fn = filename_of_path xml_library_root tag in
   let uri = Cic2acic.uri_of_kernel_name tag in
-   if not internal then print_object_kind uri kind;
+  (match internal with
+    | Declare.KernelSilent -> ()
+    | _ -> print_object_kind uri kind);
    print_object uri obj Evd.empty None fn
 ;;
 
 let print_ref qid fn =
   let ref = Nametab.global qid in
-  print false ref (kind_of_global ref) fn
+  print Declare.UserVerbose ref (kind_of_global ref) fn
 
 (* show dest                                                  *)
 (*  where dest is either None (for stdout) or (Some filename) *)
@@ -568,12 +574,16 @@ let show_pftreestate internal fn (kind,pftst) id =
         (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable)
       in
       let kind_of_var = "VARIABLE","LocalFact" in
-       if not internal then print_object_kind uri kind_of_var;
-      uri
+      (match internal with
+       | Declare.KernelSilent -> ()
+       | _ -> print_object_kind uri kind_of_var
+       ); uri
    | Decl_kinds.Global, _ ->
       let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in
-       if not internal then print_object_kind uri (kind_of_global_goal kind);
-       uri
+      (match internal with
+       | Declare.KernelSilent -> ()
+       | _ -> print_object_kind uri (kind_of_global_goal kind)
+      ); uri
  in
   print_object uri obj evar_map
    (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr,
@@ -583,7 +593,7 @@ let show_pftreestate internal fn (kind,pftst) id =
 let show fn =
  let pftst = Pfedit.get_pftreestate () in
  let (id,kind,_,_) = Pfedit.current_proof_statement () in
-  show_pftreestate false fn (kind,pftst) id
+  show_pftreestate Declare.KernelVerbose fn (kind,pftst) id
 ;;
 
 
@@ -606,7 +616,7 @@ let _ =
   Declare.set_xml_declare_variable
    (function (sp,kn) ->
      let id = Libnames.basename sp in
-     print false (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
+     print Declare.UserVerbose (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
      proof_to_export := None)
 ;;
 
@@ -615,13 +625,13 @@ let _ =
    (function (internal,kn) ->
      match !proof_to_export with
         None ->
-          print internal (Libnames.ConstRef kn) (kind_of_constant kn) 
+          print internal (Libnames.ConstRef kn) (kind_of_constant kn)
 	    xml_library_root
       | Some pftreestate ->
          (* It is a proof. Let's export it starting from the proof-tree *)
          (* I saved in the Pfedit.set_xml_cook_proof callback.          *)
         let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in
-         show_pftreestate internal fn pftreestate 
+         show_pftreestate internal fn pftreestate
 	  (Names.id_of_label (Names.con_label kn)) ;
          proof_to_export := None)
 ;;
@@ -629,7 +639,8 @@ let _ =
 let _ =
   Declare.set_xml_declare_inductive
    (function (isrecord,(sp,kn)) ->
-      print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) 
+      print Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0))
+        (kind_of_inductive isrecord (Names.mind_of_kn kn))
         xml_library_root)
 ;;
 
@@ -660,14 +671,14 @@ let _ =
            None ->
              Buffer.output_buffer stdout theory_buffer ;
          | Some fn ->
-            let ch = open_out (fn ^ ".v") in
+             let ch = open_out (fn ^ ".v") in
              Buffer.output_buffer ch theory_buffer ;
              close_out ch;
-            (* dummy glob file *)
-            let ch = open_out (fn ^ ".glob") in
+             (* dummy glob file *)
+             let ch = open_out (fn ^ ".glob") in
              close_out ch
        end ;
-       Option.iter 
+       Option.iter
 	(fun fn ->
 	  let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in
 	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
@@ -684,7 +695,7 @@ let _ =
 let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;;
 
 let uri_of_dirpath dir =
-  "/" ^ String.concat "/" 
+  "/" ^ String.concat "/"
     (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir)))
 ;;
 
@@ -702,7 +713,7 @@ let _ =
 
 let _ =
   Library.set_xml_require
-    (fun d -> theory_output_string 
+    (fun d -> theory_output_string
       (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
        (uri_of_dirpath d) (Names.string_of_dirpath d)))
 ;;
diff --git a/contrib/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
index 7c0d31a1..66ff9f0b 100644
--- a/contrib/xml/xmlcommand.mli
+++ b/plugins/xml/xmlcommand.mli
@@ -12,7 +12,7 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-(*i $Id: xmlcommand.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* print_global qid fn                                                    *)
 (*  where qid  is a long name denoting a definition/theorem or            *)
diff --git a/contrib/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
index 496debe1..41c107ad 100644
--- a/contrib/xml/xmlentries.ml4
+++ b/plugins/xml/xmlentries.ml4
@@ -14,7 +14,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: xmlentries.ml4 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Util;;
 open Vernacinterp;;
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index abe4fcc1..d3813660 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cases.ml 13112 2010-06-10 19:58:23Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Declarations
 open Inductiveops
 open Environ
@@ -73,11 +74,11 @@ let set_impossible_default_clause c = impossible_default_case := Some c
 let coq_unit_judge =
   let na1 = Name (id_of_string "A") in
   let na2 = Name (id_of_string "H") in
-  fun () -> 
+  fun () ->
     match !impossible_default_case with
     | Some (id,type_of_id) ->
 	make_judge id type_of_id
-    | None -> 
+    | None ->
 	(* In case the constants id/ID are not defined *)
 	make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1)))
                  (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2)))
@@ -87,8 +88,8 @@ let coq_unit_judge =
 module type S = sig
   val compile_cases :
     loc -> case_style ->
-    (type_constraint -> env -> evar_defs ref -> rawconstr -> unsafe_judgment) * evar_defs ref ->
-    type_constraint -> 
+    (type_constraint -> env -> evar_map ref -> rawconstr -> unsafe_judgment) * evar_map ref ->
+    type_constraint ->
     env -> rawconstr option * tomatch_tuples * cases_clauses ->
     unsafe_judgment
 end
@@ -97,8 +98,8 @@ let rec list_try_compile f = function
   | [a] -> f a
   | [] -> anomaly "try_find_f"
   | h::t ->
-      try f h 
-      with UserError _ | TypeError _ | PretypeError _ 
+      try f h
+      with UserError _ | TypeError _ | PretypeError _
 	| Stdpp.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) ->
 	    list_try_compile f t
 
@@ -119,14 +120,11 @@ let msg_may_need_inversion () =
 
 (* Utils *)
 let make_anonymous_patvars n =
-  list_make n (PatVar (dummy_loc,Anonymous)) 
+  list_make n (PatVar (dummy_loc,Anonymous))
 
 (* Environment management *)
 let push_rels vars env = List.fold_right push_rel vars env
 
-let push_rel_defs =
-  List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e)
-
 (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
    over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
 
@@ -172,7 +170,7 @@ type 'a rhs =
       it         : 'a option}
 
 type 'a equation =
-    { patterns     : cases_pattern list; 
+    { patterns     : cases_pattern list;
       rhs          : 'a rhs;
       alias_stack  : name list;
       eqn_loc      : loc;
@@ -210,14 +208,12 @@ and pattern_continuation =
 
 let start_history n = Continuation (n, [], Top)
 
-let initial_history = function Continuation (_,[],Top) -> true | _ -> false
-
 let feed_history arg = function
   | Continuation (n, l, h) when n>=1 ->
       Continuation (n-1, arg :: l, h)
   | Continuation (n, _, _) ->
       anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
-  | Result _ -> 
+  | Result _ ->
       anomaly "Exhausted pattern history"
 
 (* This is for non exhaustive error message *)
@@ -248,7 +244,7 @@ let rec simplify_history = function
       let pat = match f with
 	| AliasConstructor pci ->
 	    PatCstr (dummy_loc,pci,pargs,Anonymous)
-	| AliasLeaf -> 
+	| AliasLeaf ->
 	    assert (l = []);
 	    PatVar (dummy_loc, Anonymous) in
       feed_history pat rh
@@ -266,7 +262,7 @@ let push_history_pattern n current cont =
 
   where tomatch is some sequence of "instructions" (t1  ... tn)
 
-  and mat is some matrix 
+  and mat is some matrix
    (p11 ... p1n -> rhs1)
    (    ...            )
    (pm1 ... pmn -> rhsm)
@@ -295,14 +291,14 @@ let push_history_pattern n current cont =
 
 type 'a pattern_matching_problem =
     { env       : env;
-      evdref    : evar_defs ref;
+      evdref    : evar_map ref;
       pred      : constr;
       tomatch   : tomatch_stack;
       history   : pattern_continuation;
       mat       : 'a matrix;
       caseloc   : loc;
       casestyle : case_style;
-      typing_function: type_constraint -> env -> evar_defs ref -> 'a option -> unsafe_judgment }
+      typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment }
 
 (*--------------------------------------------------------------------------*
  * A few functions to infer the inductive type from the patterns instead of *
@@ -327,7 +323,7 @@ let rec find_row_ind = function
 
 let inductive_template evdref env tmloc ind =
   let arsign = get_full_arity_sign env ind in
-  let hole_source = match tmloc with 
+  let hole_source = match tmloc with
     | Some loc -> fun i -> (loc, TomatchTypeParameter (ind,i))
     | None -> fun _ -> (dummy_loc, InternalHole) in
    let (_,evarl,_) =
@@ -337,7 +333,7 @@ let inductive_template evdref env tmloc ind =
         | None ->
 	    let ty' = substl subst ty in
 	    let e = e_new_evar evdref env ~src:(hole_source n) ty' in
-	    (e::subst,e::evarl,n+1) 
+	    (e::subst,e::evarl,n+1)
 	| Some b ->
 	    (b::subst,evarl,n+1))
       arsign ([],[],1) in
@@ -354,7 +350,7 @@ let try_find_ind env sigma typ realnames =
 
 let inh_coerce_to_ind evdref env ty tyi =
   let expected_typ = inductive_template evdref env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour 
+     (* devrait être indifférent d'exiger leq ou pas puisque pour
         un inductif cela doit être égal *)
   let _ = e_cumul env evdref expected_typ ty in ()
 
@@ -363,23 +359,23 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames =
     | None -> NotInd (None,typ)
     | Some (_,(ind,_)) ->
 	inh_coerce_to_ind evdref env typ ind;
-	try try_find_ind env (evars_of !evdref) typ realnames
+	try try_find_ind env !evdref typ realnames
 	with Not_found -> NotInd (None,typ)
 
 let find_tomatch_tycon evdref env loc = function
   (* Try if some 'in I ...' is present and can be used as a constraint *)
-  | Some (_,ind,_,realnal) -> 		  
+  | Some (_,ind,_,realnal) ->
       mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal)
-  | None -> 
+  | None ->
       empty_tycon,None
 
 let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) =
   let loc = Some (loc_of_rawconstr tomatch) in
   let tycon,realnames = find_tomatch_tycon evdref env loc indopt in
   let j = typing_fun tycon env evdref tomatch in
-  let typ = nf_evar (evars_of !evdref) j.uj_type in
+  let typ = nf_evar !evdref j.uj_type in
   let t =
-    try try_find_ind env (evars_of !evdref) typ realnames
+    try try_find_ind env !evdref typ realnames
     with Not_found ->
       unify_tomatch_with_patterns evdref env loc typ pats realnames in
   (j.uj_val,t)
@@ -409,12 +405,12 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) =
   (* Ideally, we could find a common inductive type to which both the
      term to match and the patterns coerce *)
   (* In practice, we coerce the term to match if it is not already an
-     inductive type and it is not dependent; moreover, we use only 
+     inductive type and it is not dependent; moreover, we use only
      the first pattern type and forget about the others *)
   let typ,names =
     match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in
   let typ =
-    try try_find_ind pb.env (evars_of !(pb.evdref)) typ names
+    try try_find_ind pb.env !(pb.evdref) typ names
     with Not_found -> NotInd (None,typ) in
   let tomatch = ((current,typ),deps,dep) in
   match typ with
@@ -432,7 +428,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) =
 	      else
 		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
 		  pb.evdref (make_judge current typ) (mk_tycon_type indt)).uj_val in
-	    let sigma = evars_of !(pb.evdref) in
+	    let sigma =  !(pb.evdref) in
 	    let typ = try_find_ind pb.env sigma indt names in
 	    ((current,typ),deps,dep))
   | _ -> tomatch
@@ -452,9 +448,6 @@ let map_tomatch_type f = function
 let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
 let lift_tomatch_type n = liftn_tomatch_type n 1
 
-let lift_tomatch n ((current,typ),info) =
-  ((lift n current,lift_tomatch_type n typ),info)
-
 (**********************************************************************)
 (* Utilities on patterns *)
 
@@ -467,12 +460,6 @@ let alias_of_pat = function
   | PatVar (_,name) -> name
   | PatCstr(_,_,_,name) -> name
 
-let unalias_pat = function
-  | PatVar (c,name) as p ->
-      if name = Anonymous then p else PatVar (c,Anonymous)
-  | PatCstr(a,b,c,name) as p ->
-      if name = Anonymous then p else PatCstr (a,b,c,Anonymous)
-
 let remove_current_pattern eqn =
   match eqn.patterns with
     | pat::pats ->
@@ -497,18 +484,18 @@ let rec adjust_local_defs loc = function
   | [], [] -> []
   | _ -> raise NotAdjustable
 
-let check_and_adjust_constructor env ind cstrs = function 
+let check_and_adjust_constructor env ind cstrs = function
   | PatVar _ as pat -> pat
   | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
       (* Check it is constructor of the right type *)
       let ind' = inductive_of_constructor cstr in
-      if Closure.mind_equiv env ind' ind then
+      if eq_ind ind' ind then
 	(* Check the constructor has the right number of args *)
 	let ci = cstrs.(i-1) in
 	let nb_args_constr = ci.cs_nargs in
 	if List.length args = nb_args_constr then pat
 	else
-	  try 
+	  try
 	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
 	    in PatCstr (loc, cstr, args', alias)
 	  with NotAdjustable ->
@@ -518,7 +505,7 @@ let check_and_adjust_constructor env ind cstrs = function
 	(* Try to insert a coercion *)
 	try
 	  Coercion.inh_pattern_coerce_to loc pat ind' ind
-	with Not_found -> 
+	with Not_found ->
 	  error_bad_constructor_loc loc cstr ind
 
 let check_all_variables typ mat =
@@ -530,14 +517,14 @@ let check_all_variables typ mat =
     mat
 
 let check_unused_pattern env eqn =
-  if not !(eqn.used) then 
+  if not !(eqn.used) then
     raise_pattern_matching_error
       (eqn.eqn_loc, env, UnusedClause eqn.patterns)
 
 let set_used_pattern eqn = eqn.used := true
 
 let extract_rhs pb =
-  match pb.mat with 
+  match pb.mat with
     | [] -> errorlabstrm "build_leaf" (msg_may_need_inversion())
     | eqn::_ ->
 	set_used_pattern eqn;
@@ -588,7 +575,7 @@ let dependencies_in_rhs nargs current tms eqns =
 
 let rec find_dependency_list k n = function
   | [] -> []
-  | (used,tdeps,d)::rest -> 
+  | (used,tdeps,d)::rest ->
       let deps = find_dependency_list k (n+1) rest in
       if used && dependent_decl (mkRel n) d
       then list_add_set (List.length rest + 1) (list_union deps tdeps)
@@ -615,7 +602,7 @@ let find_dependencies_signature deps_in_rhs typs =
 
 let regeneralize_index_tomatch n =
   let rec genrec depth = function
-  | [] -> 
+  | [] ->
       []
   | Pushed ((c,tm),l,dep) :: rest ->
       let c = regeneralize_index n depth c in
@@ -629,7 +616,7 @@ let regeneralize_index_tomatch n =
       :: genrec (depth+1) rest in
   genrec 0
 
-let rec replace_term n c k t = 
+let rec replace_term n c k t =
   if t = mkRel (n+k) then lift k c
   else map_constr_with_binders succ (replace_term n c) k t
 
@@ -652,9 +639,6 @@ let replace_tomatch n c =
       :: replrec (depth+1) rest in
   replrec 0
 
-let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
-let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k)
-
 (* [liftn_tomatch_stack]: a term to match has just been substituted by
    some constructor t = (ci x1...xn) and the terms x1 ... xn have been
    added to match; all pushed terms to match must be lifted by n
@@ -690,7 +674,7 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1
    [match y with (S (S x)) => x | x => x end] should be compiled into
    [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
 
-   and [match y with (S (S n)) => n | n => n end] into 
+   and [match y with (S (S n)) => n | n => n end] into
    [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
 
   i.e. user names should be preserved and created names should not
@@ -705,7 +689,7 @@ 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
   (* If any, we prefer names used in pats, from top to bottom *)
-  let names2 = 
+  let names2 =
     List.fold_right
       (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
       eqns names1 in
@@ -719,7 +703,7 @@ let get_names env sign eqns =
 	 let na =
 	   merge_name
 	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
-	     d na 
+	     d na
 	 in
          (na::l,(out_name na)::avoid))
       ([],allvars) (List.rev sign) names2 in
@@ -756,7 +740,7 @@ let build_aliases_context env sigma names allpats pats =
 	let oldallpats = List.map List.tl oldallpats in
 	let decl = (na,Some deppat,t) in
 	let a = (deppat,nondeppat,d,t) in
-	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
+	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
 	  newallpats oldallpats (pats,names)
     | [], [] -> newallpats, sign1, sign2, env
     | _ -> anomaly "Inconsistent alias and name lists" in
@@ -776,7 +760,7 @@ let insert_aliases env sigma alias eqns =
   let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
   let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
   (* name2 takes the meet of all needed aliases *)
-  let name2 = 
+  let name2 =
     List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
   (* Only needed aliases are kept by build_aliases_context *)
   let eqnsnames, sign1, sign2, env =
@@ -793,7 +777,7 @@ let noccur_between_without_evar n m term =
     | Rel p       -> if n<=p && p<n+m then raise Occur
     | Evar (_,cl) -> ()
     | _             -> iter_constr_with_binders succ occur_rec n c
-  in 
+  in
   (m = 0) or (try occur_rec n term; true with Occur -> false)
 
 
@@ -870,7 +854,7 @@ let subst_predicate (args,copt) ccl tms =
 
 let specialize_predicate_var (cur,typ,dep) tms ccl =
   let c = if dep<>Anonymous then Some cur else None in
-  let l = 
+  let l =
     match typ with
     | IsInd (_,IndType(_,realargs),names) -> if names<>[] then realargs else []
     | NotInd _ -> [] in
@@ -918,7 +902,7 @@ let abstract_predicate env sigma indf cur (names,(nadep,_)) tms ccl =
       | Rel i -> regeneralize_index_tomatch (i+n) tms
       | _ -> (* Initial case *) tms in
   let sign = List.map2 (fun na (_,c,t) -> (na,c,t)) (nadep::names) sign in
-  let ccl = if nadep <> Anonymous then ccl else lift_predicate 1 ccl tms in 
+  let ccl = if nadep <> Anonymous then ccl else lift_predicate 1 ccl tms in
   let pred = extract_predicate [] ccl tms in
   it_mkLambda_or_LetIn_name env pred sign
 
@@ -930,24 +914,24 @@ let known_dependent (_,dep) = (dep = KnownDep)
    by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
 
 let expand_arg tms ccl ((_,t),_,na) =
-  let k = length_of_tomatch_type_sign na t in 
+  let k = length_of_tomatch_type_sign na t in
   lift_predicate (k-1) ccl tms
 
 let adjust_impossible_cases pb pred tomatch submat =
   if submat = [] then
-    match kind_of_term (whd_evar (evars_of !(pb.evdref)) pred) with
+    match kind_of_term (whd_evar !(pb.evdref) pred) with
     | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) = ImpossibleCase ->
 	let default = (coq_unit_judge ()).uj_type in
-	pb.evdref := Evd.evar_define evk default !(pb.evdref);
+	pb.evdref := Evd.define evk default !(pb.evdref);
       (* we add an "assert false" case *)
       let pats = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) tomatch in
       let aliasnames =
 	map_succeed (function Alias _ -> Anonymous | _ -> failwith"") tomatch
       in
       [ { patterns = pats;
-          rhs = { rhs_env = pb.env; 
-	          rhs_vars = []; 
-		  avoid_ids = []; 
+          rhs = { rhs_env = pb.env;
+	          rhs_vars = [];
+		  avoid_ids = [];
 		  it = None };
 	  alias_stack = Anonymous::aliasnames;
 	  eqn_loc = dummy_loc;
@@ -971,14 +955,18 @@ let adjust_impossible_cases pb pred tomatch submat =
 (* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
 (*                                                                           *)
 (*****************************************************************************)
-let specialize_predicate newtomatchs (names,(depna,_)) cs tms ccl =
+let specialize_predicate newtomatchs (names,(depna,_)) arsign cs tms ccl =
   (* Assume some gamma st: gamma, (X,x:=realargs,copt), tms |- ccl *)
   let nrealargs = List.length names in
   let k = nrealargs + (if depna<>Anonymous then 1 else 0) in
   (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt), tms |- ccl' *)
   let n = cs.cs_nargs in
   let ccl' = liftn_predicate n (k+1) ccl tms in
-  let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
+  let argsi =
+    if nrealargs <> 0 then
+      adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs)
+    else
+      [] in
   let copti = if depna<>Anonymous then Some (build_dependent_constructor cs) else None in
   (* The substituends argsi, copti are all defined in gamma, x1...xn *)
   (* We need _parallel_ bindings to get gamma, x1...xn, tms |- ccl'' *)
@@ -990,8 +978,8 @@ let specialize_predicate newtomatchs (names,(depna,_)) cs tms ccl =
   List.fold_left (expand_arg tms) ccl''' newtomatchs
 
 let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms =
-  let pred= abstract_predicate env (evars_of !evdref) indf current dep tms p in
-  (pred, whd_betaiota (evars_of !evdref)
+  let pred= abstract_predicate env !evdref indf current dep tms p in
+  (pred, whd_betaiota !evdref
            (applist (pred, realargs@[current])), new_Type ())
 
 let adjust_predicate_from_tomatch ((_,oldtyp),_,(nadep,_)) typ pb =
@@ -1037,8 +1025,8 @@ let group_equations pb ind current cstrs mat =
       (fun eqn () ->
 	 let rest = remove_current_pattern eqn in
 	 let pat = current_pattern eqn in
-	 match check_and_adjust_constructor pb.env ind cstrs pat with 
-	   | PatVar (_,name) -> 
+	 match check_and_adjust_constructor pb.env ind cstrs pat with
+	   | PatVar (_,name) ->
 	       (* This is a default clause that we expand *)
 	       for i=1 to Array.length cstrs do
 		 let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in
@@ -1058,6 +1046,7 @@ let rec generalize_problem names pb = function
   | [] -> pb
   | i::l ->
       let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
       let pb' = generalize_problem names pb l in
       let tomatch = lift_tomatch_stack 1 pb'.tomatch in
       let tomatch = regeneralize_index_tomatch (i+1) tomatch in
@@ -1069,7 +1058,7 @@ let rec generalize_problem names pb = function
 let build_leaf pb =
   let rhs = extract_rhs pb in
   let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in
-  j_nf_evar (evars_of !(pb.evdref)) j
+  j_nf_evar !(pb.evdref) j
 
 (* Building the sub-problem when all patterns are variables *)
 let shift_problem ((current,t),_,(nadep,_)) pb =
@@ -1080,17 +1069,17 @@ let shift_problem ((current,t),_,(nadep,_)) pb =
      mat = List.map remove_current_pattern pb.mat }
 
 (* Building the sub-pattern-matching problem for a given branch *)
-let build_branch current deps (realnames,dep) pb eqns const_info =
+let build_branch current deps (realnames,dep) pb arsign eqns const_info =
   (* We remember that we descend through a constructor *)
   let alias_type =
     if Array.length const_info.cs_concl_realargs = 0
       & not (known_dependent dep) & deps = []
     then
       NonDepAlias
-    else 
+    else
       DepAlias
   in
-  let history = 
+  let history =
     push_history_pattern const_info.cs_nargs
       (AliasConstructor const_info.cs_cstr)
       pb.history in
@@ -1109,10 +1098,10 @@ let build_branch current deps (realnames,dep) pb eqns const_info =
 
   let dep_sign =
     find_dependencies_signature
-      (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns) 
+      (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns)
       (List.rev typs) in
 
-  (* The dependent term to subst in the types of the remaining UnPushed 
+  (* The dependent term to subst in the types of the remaining UnPushed
      terms is relative to the current context enriched by topushs *)
   let ci = build_dependent_constructor const_info in
 
@@ -1125,7 +1114,7 @@ let build_branch current deps (realnames,dep) pb eqns const_info =
   let pred_is_not_dep =
     noccur_predicate_between 1 (List.length realnames + 1) pb.pred tomatch in
 
-  let typs'' = 
+  let typs'' =
     list_map2_i
       (fun i (na,t) deps ->
 	let dep = match dep with
@@ -1139,8 +1128,8 @@ let build_branch current deps (realnames,dep) pb eqns const_info =
 	((mkRel i, lift_tomatch_type i t),deps,dep))
       1 typs' (List.rev dep_sign) in
 
-  let pred = 
-    specialize_predicate typs'' (realnames,dep) const_info tomatch pb.pred in
+  let pred =
+    specialize_predicate typs'' (realnames,dep) arsign const_info tomatch pb.pred in
 
   let currents = List.map (fun x -> Pushed x) typs'' in
 
@@ -1199,6 +1188,7 @@ and match_current pb tomatch =
     | IsInd (_,(IndType(indf,realargs) as indt),names) ->
 	let mind,_ = dest_ind_family indf in
 	let cstrs = get_constructors pb.env indf in
+	let arsign, _ = get_arity pb.env indf in
 	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
 	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
 	  compile (shift_problem ct pb)
@@ -1209,12 +1199,12 @@ and match_current pb tomatch =
 	  let pb = generalize_problem (names,dep) pb deps in
 
 	  (* We compile branches *)
-	  let brs = array_map2 (compile_branch current (names,dep) deps pb) eqns cstrs in
+	  let brs = array_map2 (compile_branch current (names,dep) deps pb arsign) eqns cstrs in
 
 	  (* We build the (elementary) case analysis *)
 	  let brvals = Array.map (fun (v,_) -> v) brs in
 	  let (pred,typ,s) =
-	    find_predicate pb.caseloc pb.env pb.evdref 
+	    find_predicate pb.caseloc pb.env pb.evdref
 	      pb.pred current indt (names,dep) pb.tomatch in
 	  let ci = make_case_info pb.env mind pb.casestyle in
 	  let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
@@ -1222,8 +1212,8 @@ and match_current pb tomatch =
 	  { uj_val = applist (case, inst);
 	    uj_type = substl inst typ }
 
-and compile_branch current names deps pb eqn cstr =
-  let sign, pb = build_branch current deps names pb eqn cstr in
+and compile_branch current names deps pb arsign eqn cstr =
+  let sign, pb = build_branch current deps names pb arsign eqn cstr in
   let j = compile pb in
   (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
 
@@ -1240,7 +1230,7 @@ and compile_generalization pb d rest =
 and compile_alias pb (deppat,nondeppat,d,t) rest =
   let history = simplify_history pb.history in
   let sign, newenv, mat =
-    insert_aliases pb.env (evars_of !(pb.evdref)) (deppat,nondeppat,d,t) pb.mat in
+    insert_aliases pb.env !(pb.evdref) (deppat,nondeppat,d,t) pb.mat in
   let n = List.length sign in
 
   (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
@@ -1287,102 +1277,6 @@ let matx_of_eqns env tomatchl eqns =
       rhs = rhs }
   in List.map build_eqn eqns
 
-(************************************************************************)
-(* preparing the elimination predicate if any                          *)
-
-let build_expected_arity env evdref isdep tomatchl =
-  let cook n = function
-    | _,IsInd (_,IndType(indf,_),_) ->
-        let indf' = lift_inductive_family n indf in
-	Some (build_dependent_inductive env indf', fst (get_arity env indf'))
-    | _,NotInd _ -> None
-  in
-  let rec buildrec n env = function
-    | [] -> new_Type ()
-    | tm::ltm ->
-	match cook n tm with
-	  | None -> buildrec n env ltm
-	  | Some (ty1,aritysign) ->
-	      let rec follow n env = function
-		| d::sign ->
-		    mkProd_or_LetIn_name env
-		      (follow (n+1) (push_rel d env) sign) d
-		| [] ->
-		    if isdep then
-		      mkProd (Anonymous, ty1, 
-			      buildrec (n+1)
-				(push_rel_assum (Anonymous, ty1) env)
-				ltm)
-		    else buildrec n env ltm
-	      in follow n env (List.rev aritysign)
-  in buildrec 0 env tomatchl
-
-let extract_predicate_conclusion isdep tomatchl pred =
-  let cook = function
-    | _,IsInd (_,IndType(_,args),_) -> Some (List.length args)
-    | _,NotInd _ -> None in
-  let rec decomp_lam_force n l p =
-    if n=0 then (l,p) else
-    match kind_of_term p with
-      | Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c
-      | _ -> (* eta-expansion *)
-          let na = Name (id_of_string "x") in
-          decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in
-  let rec buildrec allnames p = function
-    | [] -> (List.rev allnames,p)
-    | tm::ltm ->
-	match cook tm with
-	  | None -> 
-              let p = 
-                (* adjust to a sign containing the NotInd's *)
-                if isdep then lift 1 p else p in
-              let names = if isdep then [Anonymous] else [] in
-              buildrec (names::allnames) p ltm
-	  | Some n ->
-              let n = if isdep then n+1 else n in
-              let names,p = decomp_lam_force n [] p in
-              buildrec (names::allnames) p ltm
-  in buildrec [] pred tomatchl
-
-let set_arity_signature dep n arsign tomatchl pred x =
-  (* avoid is not exhaustive ! *)
-  let rec decomp_lam_force n avoid l p =
-    if n = 0 then (List.rev l,p,avoid) else
-    match p with
-      | RLambda (_,(Name id as na),_,_,c) -> 
-          decomp_lam_force (n-1) (id::avoid) (na::l) c
-      | RLambda (_,(Anonymous as na),_,_,c) -> decomp_lam_force (n-1) avoid (na::l) c
-      | _ ->
-          let x = next_ident_away (id_of_string "x") avoid in
-          decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
-          (* eta-expansion *)
-            (let a = RVar (dummy_loc,x) in
-             match p with
-               | RApp (loc,p,l) -> RApp (loc,p,l@[a])
-               | _ -> (RApp (dummy_loc,p,[a]))) in
-  let rec decomp_block avoid p = function
-    | ([], _) -> x := Some p
-    | ((_,IsInd (_,IndType(indf,realargs),_))::l),(y::l')  ->
-	let (ind,params) = dest_ind_family indf in
-        let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p 
-        in
-        let na,p,avoid' = 
-          if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid'
-        in 
-        y :=
-        (List.hd na,
-         if List.for_all ((=) Anonymous) nal then
-           None
-         else
-           Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal));
-        decomp_block avoid' p (l,l')
-    | (_::l),(y::l') ->
-        y := (Anonymous,None);
-        decomp_block avoid p (l,l')
-    | _ -> anomaly "set_arity_signature"
-  in
-  decomp_block [] pred (tomatchl,arsign)
-
 (***************** Building an inversion predicate ************************)
 
 (* Let "match t1 in I1 u11..u1n_1 ... tm in Im um1..umn_m with ... end : T"
@@ -1395,9 +1289,9 @@ let set_arity_signature dep n arsign tomatchl pred x =
    variables (in practice, there is no reason that ti is already
    constructed and the qi will be degenerated).
 
-   We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that 
+   We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that
    T = U(..v1jk..t1 .. ..vmjk..tm). This a higher-order matching
-   problem with a priori different solution (one of them if T itself!).
+   problem with a priori different solutions (one of them if T itself!).
 
    We finally invert the uij and the ti and build the return clause
 
@@ -1414,27 +1308,27 @@ let set_arity_signature dep n arsign tomatchl pred x =
 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
-  (* We first remove the bindings that are dependently typed (they are 
+  (* 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:
      - [subst] is made of pairs [(id,u)] where id is a name in [extenv] and
        [u] a term typed in [env];
      - [subst0] is made of items [(p,u,(u,ty))] where [ty] is the type of [u]
-       and both are adjusted to [extenv] while [p] is the index of [id] in 
+       and both are adjusted to [extenv] while [p] is the index of [id] in
        [extenv] (after expansion of the aliases) *)
   let subst0 = map_succeed (fun (x,u) ->
     (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *)
     (* \--env-/          (= x:ty)         *)
     (* \--------------extenv------------/ *)
-    let (p,_) = lookup_rel_id x (rel_context extenv) in
+    let (p,_,_) = lookup_rel_id x (rel_context extenv) in
     let rec aux n (_,b,ty) =
       match b with
       | Some c ->
 	  assert (isRel c);
-	  let p = n + destRel c in aux p (lookup_rel p (rel_context extenv))
+	  let p = n + destRel c in aux p (lookup_rel p extenv)
       | None ->
 	  (n,ty) in
-    let (p,ty) = aux p (lookup_rel p (rel_context extenv)) in
+    let (p,ty) = aux p (lookup_rel p extenv) in
     if noccur_between_without_evar 1 (n'-p-n+1) ty
     then
       let u = lift (n'-n) u in
@@ -1444,12 +1338,15 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
   let t0 = lift (n'-n) t in
   (subst0,t0)
 
+let push_binder d (k,env,subst) =
+  (k+1,push_rel d env,List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst)
+
 (* Let vijk and ti be a set of dependent terms and T a type, all
  * defined in some environment env. The vijk and ti are supposed to be
  * instances for variables aijk and bi.
  *
- * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm) 
- * defined in some extended context 
+ * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm)
+ * defined in some extended context
  * "Gamma0, ..a1jk:V1jk.. b1:W1 .. ..amjk:Vmjk.. bm:Wm"
  * such that env |- T = U(..v1jk..t1 .. ..vmjk..tm). To not commit to
  * a particular solution, we replace each subterm t in T that unifies with
@@ -1460,7 +1357,7 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
 *)
 
 let abstract_tycon loc env evdref subst _tycon extenv t =
-  let sigma = evars_of !evdref in
+  let sigma = !evdref in
   let t = nf_betaiota sigma t in (* it helps in some cases to remove K-redex *)
   let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv subst t in
   (* We traverse the type T of the original problem Xi looking for subterms
@@ -1469,15 +1366,18 @@ let abstract_tycon loc env evdref subst _tycon extenv t =
      by an evar that may depend (and only depend) on the corresponding
      convertible subterms of the substitution *)
   let rec aux (k,env,subst as x) t =
+    if isRel t && pi2 (lookup_rel (destRel t) env) <> None then
+      map_constr_with_full_binders push_binder aux x t
+    else
     let good = List.filter (fun (_,u,_) -> is_conv_leq env sigma t u) subst in
     if good <> [] then
       let (u,ty) = pi3 (List.hd good) in
       let vl = List.map pi1 good in
-      let inst = 
+      let inst =
 	list_map_i
 	  (fun i _ -> if List.mem i vl then u else mkRel i) 1
 	  (rel_context extenv) in
-      let rel_filter = 
+      let rel_filter =
 	List.map (fun a -> not (isRel a) or dependent a u) inst in
       let named_filter =
 	List.map (fun (id,_,_) -> dependent (mkVar id) u)
@@ -1488,30 +1388,25 @@ let abstract_tycon loc env evdref subst _tycon extenv t =
       evdref := add_conv_pb (Reduction.CONV,extenv,substl inst ev,u) !evdref;
       lift k ev
     else
-      map_constr_with_full_binders 
-	(fun d (k,env,subst) ->
-	  k+1,
-	  push_rel d env, 
-	  List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst)
-	aux x t in
+      map_constr_with_full_binders push_binder aux x t in
   aux (0,extenv,subst0) t0
 
 let build_tycon loc env tycon_env subst tycon extenv evdref t =
   let t = match t with
     | None ->
-	(* This is the situation we are building a return predicate and 
+	(* 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 impossible_case_type = 
+	let impossible_case_type =
 	  e_new_evar evdref env ~src:(loc,ImpossibleCase) (new_Type ()) in
 	lift (n'-n) impossible_case_type
     | Some t -> abstract_tycon loc tycon_env evdref subst tycon extenv t in
-  get_judgment_of extenv (evars_of !evdref) t
+  get_judgment_of extenv !evdref t
 
 (* For a multiple pattern-matching problem Xi on t1..tn with return
  * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return
- * predicate for Xi that is itself made by an auxiliary 
+ * predicate for Xi that is itself made by an auxiliary
  * pattern-matching problem of which the first clause reveals the
  * pattern structure of the constraints on the inductive types of the t1..tn,
  * and the second clause is a wildcard clause for catching the
@@ -1519,8 +1414,7 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t =
  * further explanations
  *)
 
-let build_inversion_problem loc env evdref tms t =
-  let sigma = evars_of !evdref in
+let build_inversion_problem loc env sigma tms t =
   let make_patvar t (subst,avoid) =
     let id = next_name_away (named_hd env t Anonymous) avoid in
     PatVar (dummy_loc,Name id), ((id,t)::subst, id::avoid) in
@@ -1596,12 +1490,13 @@ let build_inversion_problem loc env evdref tms t =
       alias_stack = [];
       eqn_loc = dummy_loc;
       used = ref false;
-      rhs = { rhs_env = pb_env; 
-              rhs_vars = []; 
+      rhs = { rhs_env = pb_env;
+              rhs_vars = [];
 	      avoid_ids = avoid0;
 	      it = None } } in
-  (* [pb] is the auxiliary pattern-matching serving as skeleton for the 
+  (* [pb] is the auxiliary pattern-matching serving as skeleton for the
       return type of the original problem Xi *)
+  let evdref = ref sigma in
   let pb =
     { env       = pb_env;
       evdref    = evdref;
@@ -1612,26 +1507,9 @@ let build_inversion_problem loc env evdref tms t =
       caseloc   = loc;
       casestyle = RegularStyle;
       typing_function = build_tycon loc env pb_env subst} in
-  (compile pb).uj_val
+  let pred = (compile pb).uj_val in
+  (!evdref,pred)
 
-let prepare_predicate_from_tycon loc dep env evdref tomatchs sign c =
-  let cook (n, l, env, signs) = function
-    | c,IsInd (_,IndType(indf,realargs),_) ->
-	let indf' = lift_inductive_family n indf in
-	let sign = make_arity_signature env dep indf' in
-	let p = List.length realargs in
-	if dep then
-	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
-	else
-	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
-    | c,NotInd (bo,typ) ->
-	let sign = [Anonymous,Option.map (lift n) bo,lift n typ] in
-	let sign = name_context env sign in
-	(n + 1, c::l, push_rels sign env, sign::signs) in
-  let n,allargs,env',signs = List.fold_left cook (0, [], env, []) tomatchs in
-  let names = List.rev (List.map (List.map pi1) signs) in
-  names, build_inversion_problem loc env evdref tomatchs c
-  
 (* Here, [pred] is assumed to be in the context built from all *)
 (* realargs and terms to match *)
 let build_initial_predicate knowndep allnames pred =
@@ -1658,27 +1536,27 @@ let build_initial_predicate knowndep allnames pred =
 let extract_arity_signature env0 tomatchl tmsign =
   let get_one_sign n tm (na,t) =
     match tm with
-      | NotInd (bo,typ) -> 
+      | NotInd (bo,typ) ->
 	  (match t with
 	    | None -> [na,Option.map (lift n) bo,lift n typ]
-	    | Some (loc,_,_,_) -> 
+	    | Some (loc,_,_,_) ->
  	    user_err_loc (loc,"",
 	    str"Unexpected type annotation for a term of non inductive type."))
       | IsInd (term,IndType(indf,realargs),_) ->
           let indf' = lift_inductive_family n indf in
-	  let (ind,params) = dest_ind_family indf' in
-	  let nrealargs = List.length realargs in
+	  let (ind,_) = dest_ind_family indf' in
+	  let nparams_ctxt,nrealargs_ctxt = inductive_nargs env0 ind in
+	  let arsign = fst (get_arity env0 indf') in
 	  let realnal =
 	    match t with
 	      | Some (loc,ind',nparams,realnal) ->
 		  if ind <> ind' then
 		    user_err_loc (loc,"",str "Wrong inductive type.");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
+		  if nparams_ctxt <> nparams
+		    or nrealargs_ctxt <> List.length realnal then
 		      anomaly "Ill-formed 'in' clause in cases";
 		  List.rev realnal
-	      | None -> list_make nrealargs Anonymous in
-	  let arsign = fst (get_arity env0 indf') in
+	      | None -> list_make nrealargs_ctxt Anonymous in
 (* 	  let na =  *)
 (* 	    match na with  *)
 (* 	      | Name _ -> na *)
@@ -1707,43 +1585,46 @@ 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 loc env tomatchs sign arsign c =
+let prepare_predicate_from_arsign_tycon loc tomatchs sign arsign c =
   let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
-  let subst, len = 
+  let subst, len =
     List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
       let signlen = List.length sign in
 	match kind_of_term tm with
-	  | Rel n when dependent tm c 
+	  | Rel n when dependent tm c
 		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
 	      ((n, len) :: subst, len - signlen)
-	  | Rel _ when not (dependent tm c)
-		&& signlen > 1 (* The term is of a dependent type but does not appear in 
-				  the tycon, maybe some variable in its type does. *) ->
+	  | Rel n when signlen > 1 (* The term is of a dependent type,
+				      maybe some variable in its type appears in the tycon. *) ->
 	      (match tmtype with
 		  NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
 		| IsInd (_, IndType(indf,realargs),_) ->
-		    List.fold_left
-		      (fun (subst, len) arg -> 
-			match kind_of_term arg with
+		    let subst =
+		      if dependent tm c && List.for_all isRel realargs
+		      then (n, 1) :: subst else subst
+		    in
+		      List.fold_left
+			(fun (subst, len) arg ->
+			  match kind_of_term arg with
 			  | Rel n when dependent arg c ->
 			      ((n, len) :: subst, pred len)
 			  | _ -> (subst, pred len))
-		      (subst, len) realargs)
+			(subst, len) realargs)
 	  | _ -> (subst, len - signlen))
       ([], nar) tomatchs arsign
   in
   let rec predicate lift c =
     match kind_of_term c with
-      | Rel n when n > lift -> 
-	  (try 
+      | Rel n when n > lift ->
+	  (try
 	      (* Make the predicate dependent on the matched variable *)
 	      let idx = List.assoc (n - lift) subst in
 		mkRel (idx + lift)
-	    with Not_found -> 
+	    with Not_found ->
 	      (* A variable that is not matched, lift over the arsign. *)
 	      mkRel (n + nar))
       | _ ->
-	  map_constr_with_binders succ predicate lift c 
+	  map_constr_with_binders succ predicate lift c
   in predicate 0 c
 
 
@@ -1758,92 +1639,71 @@ let prepare_predicate_from_arsign_tycon loc env tomatchs sign arsign c =
  * tycon to make the predicate if it is not closed.
  *)
 
-let is_dependent_on_rel x t =
-  match kind_of_term x with
-      Rel n -> not (noccur_with_meta n n t)
-    | _ -> false
-
 let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred =
-  match pred with
-  (* No type annotation *)
-  | None ->
-      (match tycon with
-       | Some (None, 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 *)
-	   let evdref2 = ref !evdref in
-           let arsign = extract_arity_signature env tomatchs sign in
-           let env' = List.fold_right push_rels arsign env in
-	   (* First strategy: we abstract the tycon wrt to the dependencies *)
-           let names1 = List.rev (List.map (List.map pi1) arsign) in
-           let pred1 = prepare_predicate_from_arsign_tycon loc env' tomatchs sign arsign t in
-           let nal1,pred1 = build_initial_predicate KnownDep names1 pred1 in
-	   (* Second strategy: we build an "inversion" predicate *)
-	   let names2,pred2 = 
-	     prepare_predicate_from_tycon loc true env evdref2 tomatchs sign t
-	   in 
-	   let nal2,pred2 = build_initial_predicate DepUnknown names2 pred2 in
-	   [evdref, nal1, pred1; evdref2, nal2, pred2]
-       | Some (None, t) ->
-	   (* Only one strategy: we build an "inversion" predicate *)
-	   let names,pred = 
-	     prepare_predicate_from_tycon loc true env evdref tomatchs sign t
-	   in 
-	   let nal,pred = build_initial_predicate DepUnknown names pred in
-	   [evdref, nal, pred]
-       | _ ->
-	   (* No type constaints: we use two strategies *)
-	   let evdref2 = ref !evdref in
-	   let t1 = mkExistential env ~src:(loc, CasesType) evdref in
-	   (* First strategy: we pose a possibly dependent "inversion" evar *)
-	   let names1,pred1 = 
-	     prepare_predicate_from_tycon loc true env evdref tomatchs sign t1
-	   in 
-	   let nal1,pred1 = build_initial_predicate DepUnknown names1 pred1 in
-	   (* Second strategy: we pose a non dependent evar *)
-	   let t2 = mkExistential env ~src:(loc, CasesType) evdref2 in
-           let arsign = extract_arity_signature env tomatchs sign in
-           let names2 = List.rev (List.map (List.map pi1) arsign) in
-           let pred2 = lift (List.length names2) t2 in
-	   let nal2,pred2 = build_initial_predicate KnownNotDep names2 pred2 in
-	   [evdref, nal1, pred1; evdref2, nal2, pred2])
-
-  (* Some type annotation *)
-  | Some rtntyp ->
+  let arsign = extract_arity_signature env tomatchs sign in
+  let names = List.rev (List.map (List.map pi1) arsign) in
+  let preds =
+    match pred, tycon with
+    (* No type annotation *)
+    | None, Some (None, 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 pred1 =
+          prepare_predicate_from_arsign_tycon loc tomatchs sign arsign t in
+	(* Second strategy: we build an "inversion" predicate *)
+	let sigma2,pred2 = build_inversion_problem loc env !evdref tomatchs t in
+	[!evdref, KnownDep, pred1; sigma2, DepUnknown, pred2]
+    | None, Some (None, t) ->
+	(* Only one strategy: we build an "inversion" predicate *)
+	let sigma,pred = build_inversion_problem loc env !evdref tomatchs t in
+	[sigma, DepUnknown, pred]
+    | None,  _ ->
+	(* No type constaints: we use two strategies *)
+	let t = mkExistential env ~src:(loc, CasesType) evdref in
+	(* First strategy: we build an inversion problem *)
+	let sigma1,pred1 = build_inversion_problem loc env !evdref tomatchs t in
+	(* Second strategy: we directly use the evar as a non dependent pred *)
+        let pred2 = lift (List.length names) t in
+	[sigma1, DepUnknown, pred1; !evdref, KnownNotDep, pred2]
+    (* Some type annotation *)
+    | Some rtntyp, _ ->
       (* We extract the signature of the arity *)
-      let arsign = extract_arity_signature env tomatchs sign in
       let env = List.fold_right push_rels arsign env in
-      let allnames = List.rev (List.map (List.map pi1) arsign) in
       let predcclj = typing_fun (mk_tycon (new_Type ())) env evdref rtntyp in
-      let _ = 
-	Option.map (fun tycon -> 
-		      evdref := Coercion.inh_conv_coerces_to loc env !evdref predcclj.uj_val 
-		      (lift_tycon_type (List.length arsign) tycon))
-	  tycon
-      in
-      let predccl = (j_nf_isevar !evdref predcclj).uj_val in      
-      let nal,pred = build_initial_predicate KnownDep allnames predccl in
-      [evdref, nal, pred]
+      Option.iter (fun tycon ->
+          let tycon = lift_tycon_type (List.length arsign) tycon in
+	  evdref :=
+            Coercion.inh_conv_coerces_to loc env !evdref predcclj.uj_val tycon)
+        tycon;
+      let predccl = (j_nf_evar !evdref predcclj).uj_val in
+      [!evdref, KnownDep, predccl]
+  in
+  List.map
+    (fun (sigma,dep,pred) ->
+      let (nal,pred) = build_initial_predicate dep names pred in
+      sigma,nal,pred)
+    preds
 
 (**************************************************************************)
 (* Main entry of the matching compilation                                 *)
-  
+
 let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
 
   (* We build the matrix of patterns and right-hand-side *)
   let matx = matx_of_eqns env tomatchl eqns in
-    
+
   (* We build the vector of terms to match consistently with the *)
   (* constructors found in patterns *)
   let tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in
-    
+
   (* If an elimination predicate is provided, we check it is compatible
      with the type of arguments to match; if none is provided, we
      build alternative possible predicates *)
   let sign = List.map snd tomatchl in
   let preds = prepare_predicate loc typing_fun evdref env tomatchs sign tycon predopt in
-    
-  let compile_for_one_predicate (myevdref,nal,pred) =
+
+  let compile_for_one_predicate (sigma,nal,pred) =
     (* 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) *)
@@ -1854,6 +1714,8 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
     | Some t ->	typing_fun tycon env evdref t
     | None -> coq_unit_judge () in
 
+    let myevdref = ref sigma in
+
     let pb =
       { env       = env;
         evdref    = myevdref;
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 98923b2a..66924031 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cases.mli 11014 2008-05-28 19:09:32Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -64,8 +64,8 @@ type tomatch_status =
 module type S = sig
   val compile_cases :
     loc -> case_style ->
-    (type_constraint -> env -> evar_defs ref -> rawconstr -> unsafe_judgment) * evar_defs ref ->
-    type_constraint -> 
+    (type_constraint -> env -> evar_map ref -> rawconstr -> unsafe_judgment) * evar_map ref ->
+    type_constraint ->
     env -> rawconstr option * tomatch_tuples * cases_clauses ->
     unsafe_judgment
 end
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index f4c612a5..8c03d0df 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cbv.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -27,7 +27,14 @@ open Esubst
  *          in normal form and neutral (i.e. not a lambda, a construct or a
  *          (co)fix, because they may produce redexes by applying them,
  *          or putting them in a case)
- *  LAM(x,a,b,S) is the term [S]([x:a]b). the bindings is propagated
+ *  STACK(k,v,stk) represents an irreductible value [v] in the stack [stk].
+ *          [k] is a delayed shift to be applied to both the value and
+ *          the stack.
+ *  CBN(t,S) is the term [S]t. It is used to delay evaluation. For
+ *          instance products are evaluated only when actually needed
+ *          (CBN strategy).
+ *  LAM(n,a,b,S) is the term [S]([x:a]b) where [a] is a list of bindings and
+ *          [n] is the length of [a]. the environment [S] is propagated
  *          only when the abstraction is applied, and then we use the rule
  *                  ([S]([x:a]b) c) --> [S.c]b
  *          This corresponds to the usual strategy of weak reduction
@@ -36,28 +43,47 @@ open Esubst
  *          weak reduction.
  *  CONSTR(c,args) is the constructor [c] applied to [args].
  *
- * Note that any term has not an equivalent in cbv_value: for example,
- * a product (x:A)B must be in normal form because only VAL may
- * represent it, and the argument of VAL is always in normal
- * form. This remark precludes coding a head reduction with these
- * functions. Anyway, does it make sense to head reduce with a
- * call-by-value strategy ?
  *)
 type cbv_value =
   | VAL of int * constr
+  | STACK of int * cbv_value * cbv_stack
+  | CBN of constr * cbv_value subs
   | LAM of int * (name * constr) list * constr * cbv_value subs
   | FIXP of fixpoint * cbv_value subs * cbv_value array
   | COFIXP of cofixpoint * cbv_value subs * cbv_value array
   | CONSTR of constructor * cbv_value array
 
+(* type of terms with a hole. This hole can appear only under App or Case.
+ *   TOP means the term is considered without context
+ *   APP(v,stk) means the term is applied to v, and then the context stk
+ *      (v.0 is the first argument).
+ *      this corresponds to the application stack of the KAM.
+ *      The members of l are values: we evaluate arguments before
+        calling the function.
+ *   CASE(t,br,pat,S,stk) means the term is in a case (which is himself in stk
+ *      t is the type of the case and br are the branches, all of them under
+ *      the subs S, pat is information on the patterns of the Case
+ *      (Weak reduction: we propagate the sub only when the selected branch
+ *      is determined)
+ *
+ * Important remark: the APPs should be collapsed:
+ *    (APP (l,(APP ...))) forbidden
+ *)
+and cbv_stack =
+  | TOP
+  | APP of cbv_value array * cbv_stack
+  | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
+
 (* les vars pourraient etre des constr,
-   cela permet de retarder les lift: utile ?? *) 
+   cela permet de retarder les lift: utile ?? *)
 
 (* relocation of a value; used when a value stored in a context is expanded
  * in a larger context. e.g.  [%k (S.t)](k+1) --> [^k]t  (t is shifted of k)
  *)
 let rec shift_value n = function
-  | VAL (k,v) -> VAL ((k+n),v)
+  | VAL (k,t) -> VAL (k+n,t)
+  | STACK(k,v,stk) -> STACK(k+n,v,stk)
+  | CBN (t,s) -> CBN(t,subs_shft(n,s))
   | LAM (nlams,ctxt,b,s) -> LAM (nlams,ctxt,b,subs_shft (n,s))
   | FIXP (fix,s,args) ->
       FIXP (fix,subs_shft (n,s), Array.map (shift_value n) args)
@@ -68,6 +94,13 @@ let rec shift_value n = function
 let shift_value n v =
   if n = 0 then v else shift_value n v
 
+let rec shift_stack n = function
+    TOP -> TOP
+  | APP(v,stk) -> APP(Array.map (shift_value n) v, shift_stack n stk)
+  | CASE(c,b,i,s,stk) -> CASE(c,b,i,subs_shft(n,s), shift_stack n stk)
+let shift_stack n stk =
+  if n = 0 then stk else shift_stack n stk
+
 (* Contracts a fixpoint: given a fixpoint and a bindings,
  * returns the corresponding fixpoint body, and the bindings in which
  * it should be evaluated: its first variables are the fixpoint bodies
@@ -89,29 +122,6 @@ let make_constr_ref n = function
   | VarKey id -> mkVar id
   | ConstKey cst -> mkConst cst
 
-
-(* type of terms with a hole. This hole can appear only under App or Case.
- *   TOP means the term is considered without context
- *   APP(v,stk) means the term is applied to v, and then the context stk
- *      (v.0 is the first argument).
- *      this corresponds to the application stack of the KAM.
- *      The members of l are values: we evaluate arguments before
-        calling the function.
- *   CASE(t,br,pat,S,stk) means the term is in a case (which is himself in stk
- *      t is the type of the case and br are the branches, all of them under
- *      the subs S, pat is information on the patterns of the Case
- *      (Weak reduction: we propagate the sub only when the selected branch
- *      is determined)
- *
- * Important remark: the APPs should be collapsed:
- *    (APP (l,(APP ...))) forbidden
- *)
-
-type cbv_stack =
-  | TOP
-  | APP of cbv_value array * cbv_stack
-  | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
-
 (* Adds an application list. Collapse APPs! *)
 let stack_app appl stack =
   if Array.length appl = 0 then stack else
@@ -119,6 +129,20 @@ let stack_app appl stack =
     | APP(args,stk) -> APP(Array.append appl args,stk)
     | _             -> APP(appl, stack)
 
+let rec stack_concat stk1 stk2 =
+  match stk1 with
+      TOP -> stk2
+    | APP(v,stk1') -> APP(v,stack_concat stk1' stk2)
+    | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2)
+
+(* merge stacks when there is no shifts in between *)
+let mkSTACK = function
+    v, TOP -> v
+  | STACK(0,v0,stk0), stk -> STACK(0,v0,stack_concat stk0 stk)
+  | v,stk -> STACK(0,v,stk)
+
+
+(* Change: zeta reduction cannot be avoided in CBV *)
 
 open RedFlags
 
@@ -128,7 +152,8 @@ let red_set_ref flags = function
   | ConstKey sp -> red_set flags (fCONST sp)
 
 (* Transfer application lists from a value to the stack
- * useful because fixpoints may be totally applied in several times
+ * useful because fixpoints may be totally applied in several times.
+ * On the other hand, irreductible atoms absorb the full stack.
  *)
 let strip_appl head stack =
   match head with
@@ -148,7 +173,7 @@ let fixp_reducible flgs ((reci,i),_) stk =
               CONSTR _ -> true
             | _ -> false)
       | _ -> false
-  else 
+  else
     false
 
 let cofixp_reducible flgs _ stk =
@@ -156,7 +181,7 @@ let cofixp_reducible flgs _ stk =
     match stk with
       | (CASE _ | APP(_,CASE _)) -> true
       | _ -> false
-  else 
+  else
     false
 
 
@@ -196,27 +221,17 @@ let rec norm_head info env t stack =
 
   | Const sp -> norm_head_ref 0 info env stack (ConstKey sp)
 
-  | LetIn (x, b, t, c) ->
+  | LetIn (_, b, _, c) ->
       (* zeta means letin are contracted; delta without zeta means we *)
       (* allow bindings but leave let's in place *)
-      let zeta = red_set (info_flags info) fZETA in
-      let env' =
-	if zeta 
-          (* New rule: for Cbv, Delta does not apply to locally bound variables
-          or red_set (info_flags info) fDELTA
-          *)
-        then 
-	  subs_cons ([|cbv_stack_term info TOP env b|],env)
-	else
-	  subs_lift env in
-      if zeta then
+      if red_set (info_flags info) fZETA then
+        (* New rule: for Cbv, Delta does not apply to locally bound variables
+           or red_set (info_flags info) fDELTA
+         *)
+	let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in
         norm_head info env' c stack
       else
-	let normt =
-	  mkLetIn (x, cbv_norm_term info env b,
-		   cbv_norm_term info env t,
-		   cbv_norm_term info env' c) in
-	(VAL(0,normt), stack) (* Considérer une coupure commutative ? *)
+	(CBN(t,env), stack) (* Considérer une coupure commutative ? *)
 
   | Evar ev ->
       (match evar_value info ev with
@@ -233,23 +248,20 @@ let rec norm_head info env t stack =
 
   (* neutral cases *)
   | (Sort _ | Meta _ | Ind _) -> (VAL(0, t), stack)
-  | Prod (x,t,c) -> 
-      (VAL(0, mkProd (x, cbv_norm_term info env t,
-		      cbv_norm_term info (subs_lift env) c)),
-	     stack)
+  | Prod _ -> (CBN(t,env), stack)
 
 and norm_head_ref k info env stack normt =
   if red_set_ref (info_flags info) normt then
     match ref_value_cache info normt with
       | Some body -> strip_appl (shift_value k body) stack
-      | None -> (VAL(0,make_constr_ref k normt), stack)
-  else (VAL(0,make_constr_ref k normt), stack)
+      | None -> (VAL(0,make_constr_ref k normt),stack)
+  else (VAL(0,make_constr_ref k normt),stack)
 
 (* cbv_stack_term performs weak reduction on constr t under the subs
  * env, with context stack, i.e. ([env]t stack).  First computes weak
  * head normal form of t and checks if a redex appears with the stack.
  * If so, recursive call to reach the real head normal form.  If not,
- * we build a value. 
+ * we build a value.
  *)
 and cbv_stack_term info stack env t =
   match norm_head info env t stack with
@@ -268,47 +280,43 @@ and cbv_stack_term info stack env t =
           LAM(nlams-nargs,ctxt', b, subs_cons(args,env))
 
     (* a Fix applied enough -> IOTA *)
-    | (FIXP(fix,env,_), stk)
+    | (FIXP(fix,env,[||]), stk)
         when fixp_reducible (info_flags info) fix stk ->
         let (envf,redfix) = contract_fixp env fix in
         cbv_stack_term info stk envf redfix
 
     (* constructor guard satisfied or Cofix in a Case -> IOTA *)
-    | (COFIXP(cofix,env,_), stk)
+    | (COFIXP(cofix,env,[||]), stk)
         when cofixp_reducible (info_flags info) cofix stk->
         let (envf,redfix) = contract_cofixp env cofix in
         cbv_stack_term info stk envf redfix
 
     (* constructor in a Case -> IOTA *)
-    | (CONSTR((sp,n),_), APP(args,CASE(_,br,ci,env,stk)))
+    | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk)))
             when red_set (info_flags info) fIOTA ->
 	let cargs =
           Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in
         cbv_stack_term info (stack_app cargs stk) env br.(n-1)
-         
+
     (* constructor of arity 0 in a Case -> IOTA *)
     | (CONSTR((_,n),_), CASE(_,br,_,env,stk))
             when red_set (info_flags info) fIOTA ->
                     cbv_stack_term info stk env br.(n-1)
 
-    (* may be reduced later by application *)  
-    | (head, TOP) -> head
-    | (FIXP(fix,env,_), APP(appl,TOP)) -> FIXP(fix,env,appl) 
-    | (COFIXP(cofix,env,_), APP(appl,TOP)) -> COFIXP(cofix,env,appl) 
-    | (CONSTR(c,_), APP(appl,TOP)) -> CONSTR(c,appl)
-
-    (* absurd cases (ill-typed) *)
-    | (LAM _, CASE _) -> assert false
+    (* may be reduced later by application *)
+    | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl)
+    | (COFIXP(cofix,env,[||]), APP(appl,TOP)) -> COFIXP(cofix,env,appl)
+    | (CONSTR(c,[||]), APP(appl,TOP)) -> CONSTR(c,appl)
 
     (* definitely a value *)
-    | (head,stk) -> VAL(0,apply_stack info (cbv_norm_value info head) stk)
+    | (head,stk) -> mkSTACK(head, stk)
 
 
 (* When we are sure t will never produce a redex with its stack, we
  * normalize (even under binders) the applied terms and we build the
  * final term
  *)
-and apply_stack info t = function
+let rec apply_stack info t = function
   | TOP -> t
   | APP (args,st) ->
       apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st
@@ -318,7 +326,6 @@ and apply_stack info t = function
 		    Array.map (cbv_norm_term info env) br))
         st
 
-
 (* performs the reduction on a constr, and returns a constr *)
 and cbv_norm_term info env t =
   (* reduction under binders *)
@@ -326,7 +333,13 @@ and cbv_norm_term info env t =
 
 (* reduction of a cbv_value to a constr *)
 and cbv_norm_value info = function (* reduction under binders *)
-  | VAL (n,v) -> lift n v
+  | VAL (n,t) -> lift n t
+  | STACK (0,v,stk) ->
+      apply_stack info (cbv_norm_value info v) stk
+  | STACK (n,v,stk) ->
+      lift n (apply_stack info (cbv_norm_value info v) stk)
+  | CBN(t,env) ->
+      map_constr_with_binders subs_lift (cbv_norm_term info) env t
   | LAM (n,ctxt,b,env) ->
       let nctxt =
         list_map_i (fun i (x,ty) ->
@@ -337,14 +350,14 @@ and cbv_norm_value info = function (* reduction under binders *)
         (mkFix (lij,
 		(names,
                  Array.map (cbv_norm_term info env) lty,
-		 Array.map (cbv_norm_term info 
+		 Array.map (cbv_norm_term info
 			      (subs_liftn (Array.length lty) env)) bds)),
          Array.map (cbv_norm_value info) args)
   | COFIXP ((j,(names,lty,bds)),env,args) ->
       mkApp
         (mkCoFix (j,
 		  (names,Array.map (cbv_norm_term info env) lty,
-		   Array.map (cbv_norm_term info 
+		   Array.map (cbv_norm_term info
 				(subs_liftn (Array.length lty) env)) bds)),
          Array.map (cbv_norm_value info) args)
   | CONSTR (c,args) ->
@@ -354,7 +367,6 @@ and cbv_norm_value info = function (* reduction under binders *)
 let cbv_norm infos constr =
   with_stats (lazy (cbv_norm_term infos (ESID 0) constr))
 
-
 type cbv_infos = cbv_value infos
 
 (* constant bodies are normalized at the first expansion *)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index 9ab15886..de66d22b 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cbv.mli 11897 2009-02-09 19:28:02Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -29,18 +29,20 @@ val cbv_norm         : cbv_infos -> constr -> constr
 (*i This is for cbv debug *)
 type cbv_value =
   | VAL of int * constr
+  | STACK of int * cbv_value * cbv_stack
+  | CBN of constr * cbv_value subs
   | LAM of int * (name * constr) list * constr * cbv_value subs
   | FIXP of fixpoint * cbv_value subs * cbv_value array
   | COFIXP of cofixpoint * cbv_value subs * cbv_value array
   | CONSTR of constructor * cbv_value array
 
-val shift_value : int -> cbv_value -> cbv_value
-
-type cbv_stack =
+and cbv_stack =
   | TOP
   | APP of cbv_value array * cbv_stack
   | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
 
+val shift_value : int -> cbv_value -> cbv_value
+
 val stack_app : cbv_value array -> cbv_stack -> cbv_stack
 val strip_appl : cbv_value -> cbv_stack -> cbv_value * cbv_stack
 
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 27418b4d..23796325 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: classops.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -28,8 +28,8 @@ open Mod_subst
 (* A class is a type constructor, its type is an arity whose number of
    arguments is cl_param (0 for CL_SORT and CL_FUN) *)
 
-type cl_typ = 
-  | CL_SORT 
+type cl_typ =
+  | CL_SORT
   | CL_FUN
   | CL_SECVAR of variable
   | CL_CONST of constant
@@ -68,8 +68,6 @@ module Bijint = struct
 	(let v = Array.make (b.s + 8) (x,y) in Array.blit b.v 0 v 0 b.s; v)
       else b.v in
     v.(b.s) <- (x,y); { v = v; s = b.s+1; inv = Gmap.add x b.s b.inv }
-  let replace n x y b =
-    let v = Array.copy b.v in v.(n) <- (x,y); { b with v = v }
   let dom b = Gmap.dom b.inv
 end
 
@@ -84,7 +82,7 @@ let inheritance_graph =
 
 let freeze () = (!class_tab, !coercion_tab, !inheritance_graph)
 
-let unfreeze (fcl,fco,fig) = 
+let unfreeze (fcl,fco,fig) =
   class_tab:=fcl;
   coercion_tab:=fco;
   inheritance_graph:=fig
@@ -95,26 +93,24 @@ let add_new_class cl s =
   if not (Bijint.mem cl !class_tab) then
     class_tab := Bijint.add cl s !class_tab
 
-let add_new_coercion coe s = 
+let add_new_coercion coe s =
   coercion_tab := Gmap.add coe s !coercion_tab
 
 let add_new_path x y =
   inheritance_graph := Gmap.add x y !inheritance_graph
 
 let init () =
-  class_tab:= Bijint.empty; 
+  class_tab:= Bijint.empty;
   add_new_class CL_FUN  { cl_param = 0 };
   add_new_class CL_SORT { cl_param = 0 };
   coercion_tab:= Gmap.empty;
   inheritance_graph:= Gmap.empty
 
-let _ = 
+let _ =
   Summary.declare_summary "inh_graph"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
 
 let _ = init()
 
@@ -138,8 +134,6 @@ let coercion_info coe = Gmap.find coe !coercion_tab
 
 let coercion_exists coe = Gmap.mem coe !coercion_tab
 
-let coercion_params coe_info = coe_info.coe_param
-
 (* find_class_type : env -> evar_map -> constr -> cl_typ * int *)
 
 let find_class_type env sigma t =
@@ -157,12 +151,12 @@ let subst_cl_typ subst ct = match ct with
     CL_SORT
   | CL_FUN
   | CL_SECVAR _ -> ct
-  | CL_CONST kn -> 
-      let kn',t = subst_con subst kn in 
+  | CL_CONST kn ->
+      let kn',t = subst_con subst kn in
 	if kn' == kn then ct else
          fst (find_class_type (Global.env()) Evd.empty t)
   | CL_IND (kn,i) ->
-      let kn' = subst_kn subst kn in 
+      let kn' = subst_ind subst kn in
 	if kn' == kn then ct else
 	  CL_IND (kn',i)
 
@@ -172,15 +166,15 @@ let subst_coe_typ subst t = fst (subst_global subst t)
 
 (* class_of : Term.constr -> int *)
 
-let class_of env sigma t = 
-  let (t, n1, i, args) = 
+let class_of env sigma t =
+  let (t, n1, i, args) =
     try
       let (cl,args) = find_class_type env sigma t in
       let (i, { cl_param = n1 } ) = class_info cl in
       (t, n1, i, args)
     with Not_found ->
       let t = Tacred.hnf_constr env sigma t in
-      let (cl, args) = find_class_type env sigma t in 
+      let (cl, args) = find_class_type env sigma t in
       let (i, { cl_param = n1 } ) = class_info cl in
       (t, n1, i, args)
   in
@@ -224,7 +218,7 @@ let apply_on_class_of env sigma t cont =
   with Not_found ->
     (* Is it worth to be more incremental on the delta steps? *)
     let t = Tacred.hnf_constr env sigma t in
-    let (cl, args) = find_class_type env sigma t in 
+    let (cl, args) = find_class_type env sigma t in
     let (i, { cl_param = n1 } ) = class_info cl in
     if List.length args <> n1 then raise Not_found;
     t, cont i
@@ -239,7 +233,7 @@ let lookup_path_between env sigma (s,t) =
 let lookup_path_to_fun_from env sigma s =
   apply_on_class_of env sigma s lookup_path_to_fun_from_class
 
-let lookup_path_to_sort_from env sigma s = 
+let lookup_path_to_sort_from env sigma s =
   apply_on_class_of env sigma s lookup_path_to_sort_from_class
 
 let get_coercion_constructor coe =
@@ -247,7 +241,7 @@ let get_coercion_constructor coe =
     Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value
   in
   match kind_of_term c with
-  | Construct cstr -> 
+  | Construct cstr ->
       (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1)
   | _ ->
       raise Not_found
@@ -269,14 +263,14 @@ let path_printer = ref (fun _ -> str "<a class path>"
                         : (int * int) * inheritance_path -> std_ppcmds)
 
 let install_path_printer f = path_printer := f
- 
+
 let print_path x = !path_printer x
 
-let message_ambig l = 
+let message_ambig l =
   (str"Ambiguous paths:" ++ spc () ++
    prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l)
 
-(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit 
+(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit
                          coercion,source,target *)
 
 let different_class_params i j =
@@ -287,7 +281,7 @@ let add_coercion_in_graph (ic,source,target) =
   let ambig_paths =
     (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in
   let try_add_new_path (i,j as ij) p =
-    try 
+    try
       if i=j then begin
 	if different_class_params i j then begin
 	  let _ = lookup_path_between_class ij in
@@ -303,26 +297,26 @@ let add_coercion_in_graph (ic,source,target) =
       true
     end
   in
-  let try_add_new_path1 ij p = 
-    let _ = try_add_new_path ij p in () 
+  let try_add_new_path1 ij p =
+    let _ = try_add_new_path ij p in ()
   in
   if try_add_new_path (source,target) [ic] then begin
-    Gmap.iter 
+    Gmap.iter
       (fun (s,t) p ->
          if s<>t then begin
 	   if t = source then begin
              try_add_new_path1 (s,target) (p@[ic]);
              Gmap.iter
 	       (fun (u,v) q ->
-                  if u<>v & (u = target) & (p <> q) then 
+                  if u<>v & (u = target) & (p <> q) then
 		    try_add_new_path1 (s,v) (p@[ic]@q))
                old_inheritance_graph
            end;
            if s = target then try_add_new_path1 (source,t) (ic::p)
 	 end)
-      old_inheritance_graph 
+      old_inheritance_graph
   end;
-  if (!ambig_paths <> []) && is_verbose () then 
+  if (!ambig_paths <> []) && is_verbose () then
     ppnl (message_ambig !ambig_paths)
 
 type coercion = coe_typ * locality * bool * cl_typ * cl_typ * int
@@ -349,7 +343,7 @@ let load_coercion i (_,(coe,stre,isid,cls,clt,ps)) =
   add_class clt;
   let is,_ = class_info cls in
   let it,_ = class_info clt in
-  let xf = 
+  let xf =
     { coe_value = constr_of_global coe;
       coe_type = Global.type_of_global coe;
       coe_strength = stre;
@@ -361,7 +355,7 @@ let load_coercion i (_,(coe,stre,isid,cls,clt,ps)) =
 let cache_coercion o =
   load_coercion 1 o
 
-let subst_coercion (_,subst,(coe,stre,isid,cls,clt,ps as obj)) =
+let subst_coercion (subst,(coe,stre,isid,cls,clt,ps as obj)) =
   let coe' = subst_coe_typ subst coe in
   let cls' = subst_cl_typ subst cls in
   let clt' = subst_cl_typ subst clt in
@@ -374,7 +368,7 @@ let discharge_cl = function
   | cl -> cl
 
 let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) =
-  if stre = Local then None else 
+  if stre = Local then None else
     let n = try Array.length (Lib.section_instance coe) with Not_found -> 0 in
     Some (Lib.discharge_global coe,
           stre,
@@ -383,21 +377,20 @@ let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) =
 	  discharge_cl clt,
           n + ps)
 
-let (inCoercion,outCoercion) =
-  declare_object {(default_object "COERCION") with 
+let classify_coercion (coe,stre,isid,cls,clt,ps as obj) =
+  if stre = Local then Dispose else Substitute obj
+
+let (inCoercion,_) =
+  declare_object {(default_object "COERCION") with
     load_function = load_coercion;
     cache_function = cache_coercion;
     subst_function = subst_coercion;
-    classify_function = (fun (_,x) -> Substitute x);
-    discharge_function = discharge_coercion;
-    export_function = (function x -> Some x)  }
+    classify_function = classify_coercion;
+    discharge_function = discharge_coercion }
 
 let declare_coercion coef stre ~isid ~src:cls ~target:clt ~params:ps =
   Lib.add_anonymous_leaf (inCoercion (coef,stre,isid,cls,clt,ps))
 
-let coercion_strength v = v.coe_strength
-let coercion_identity v = v.coe_is_identity
-
 (* For printing purpose *)
 let get_coercion_value v = v.coe_value
 
@@ -410,7 +403,7 @@ let inheritance_graph () = Gmap.to_list !inheritance_graph
 let coercion_of_reference r =
   let ref = Nametab.global r in
   if not (coercion_exists ref) then
-    errorlabstrm "try_add_coercion" 
+    errorlabstrm "try_add_coercion"
       (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion.");
   ref
 
@@ -420,7 +413,7 @@ module CoercionPrinting =
     let encode = coercion_of_reference
     let subst = subst_coe_typ
     let printer x = pr_global_env Idset.empty x
-    let key = Goptions.SecondaryTable ("Printing","Coercion")
+    let key = ["Printing";"Coercion"]
     let title = "Explicitly printed coercions: "
     let member_message x b =
       str "Explicit printing of coercion " ++ printer x ++
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index a76fe75c..63d5b0a4 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classops.mli 11343 2008-09-01 20:55:13Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -19,9 +19,9 @@ open Mod_subst
 (*i*)
 
 (*s This is the type of class kinds *)
-type cl_typ = 
-  | CL_SORT 
-  | CL_FUN 
+type cl_typ =
+  | CL_SORT
+  | CL_FUN
   | CL_SECVAR of variable
   | CL_CONST of constant
   | CL_IND of inductive
@@ -36,7 +36,7 @@ type cl_info_typ = {
 type coe_typ = Libnames.global_reference
 
 (* This is the type of infos for declared coercions *)
-type coe_info_typ 
+type coe_info_typ
 
 (* [cl_index] is the type of class keys *)
 type cl_index
@@ -65,7 +65,7 @@ val inductive_class_of : inductive -> cl_index
 val class_args_of : env -> evar_map -> types -> constr list
 
 (*s [declare_coercion] adds a coercion in the graph of coercion paths *)
-val declare_coercion : 
+val declare_coercion :
   coe_typ -> locality -> isid:bool ->
       src:cl_typ -> target:cl_typ -> params:int -> unit
 
@@ -77,18 +77,18 @@ val coercion_value : coe_index -> (unsafe_judgment * bool)
 (*s Lookup functions for coercion paths *)
 val lookup_path_between_class : cl_index * cl_index -> inheritance_path
 
-val lookup_path_between : env -> evar_map -> types * types -> 
+val lookup_path_between : env -> evar_map -> types * types ->
       types * types * inheritance_path
 val lookup_path_to_fun_from : env -> evar_map -> types ->
       types * inheritance_path
-val lookup_path_to_sort_from : env -> evar_map -> types -> 
+val lookup_path_to_sort_from : env -> evar_map -> types ->
       types * inheritance_path
-val lookup_pattern_path_between : 
+val lookup_pattern_path_between :
   inductive * inductive -> (constructor * int) list
 
 (*i Crade *)
 open Pp
-val install_path_printer : 
+val install_path_printer :
   ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit
 (*i*)
 
diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml
index 0bfef04a..283d3f12 100644
--- a/pretyping/clenv.ml
+++ b/pretyping/clenv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: clenv.ml 13126 2010-06-13 11:09:51Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -14,6 +14,7 @@ open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Sign
 open Environ
 open Evd
@@ -31,8 +32,8 @@ open Coercion.Default
 (* Abbreviations *)
 
 let pf_env gls = Global.env_of_context gls.it.evar_hyps
+let pf_hyps gls = named_context_of_val gls.it.evar_hyps
 let pf_type_of gls c  = Typing.type_of (pf_env gls) gls.sigma c
-let pf_hnf_constr gls c = hnf_constr (pf_env gls) gls.sigma c
 let pf_concl gl = gl.it.evar_concl
 
 (******************************************************************)
@@ -40,14 +41,14 @@ let pf_concl gl = gl.it.evar_concl
 
 type clausenv = {
   env      : env;
-  evd      : evar_defs;
+  evd      : evar_map;
   templval : constr freelisted;
   templtyp : constr freelisted }
 
 let cl_env ce = ce.env
-let cl_sigma ce = evars_of ce.evd
+let cl_sigma ce =  ce.evd
 
-let subst_clenv sub clenv = 
+let subst_clenv sub clenv =
   { templval = map_fl (subst_mps sub) clenv.templval;
     templtyp = map_fl (subst_mps sub) clenv.templtyp;
     evd = subst_evar_defs_light sub clenv.evd;
@@ -62,8 +63,7 @@ let clenv_type clenv = meta_instance clenv.evd clenv.templtyp
 
 let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t
 
-let clenv_get_type_of ce c =
-  Retyping.get_type_of_with_meta (cl_env ce) (cl_sigma ce) (metas_of ce.evd) c
+let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c
 
 exception NotExtensibleClause
 
@@ -102,7 +102,7 @@ let clenv_environments evd bound t =
 	    (if dep then (subst1 (mkMeta mv) t2) else t2)
       | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t)
       | (n, _) -> (e, List.rev metas, t)
-  in 
+  in
   clrec (evd,[]) bound t
 
 (* Instantiate the first [bound] products of [t] with evars (all products if
@@ -120,7 +120,7 @@ let clenv_environments_evars env evd bound t =
 	    (if dep then (subst1 constr t2) else t2)
       | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t)
       | (n, _) -> (e, List.rev ts, t)
-  in 
+  in
   clrec (evd,[]) bound t
 
 let clenv_conv_leq env sigma t c bound =
@@ -129,16 +129,16 @@ let clenv_conv_leq env sigma t c bound =
   let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in
   let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in
   let evars,_ = Evarconv.consider_remaining_unif_problems env evars in
-  let args = List.map (whd_evar (Evd.evars_of evars)) args in
+  let args = List.map (whd_evar evars) args in
   check_evars env sigma evars (applist (c,args));
   args
 
 let mk_clenv_from_env environ sigma n (c,cty) =
   let evd = create_goal_evar_defs sigma in
-  let (env,args,concl) = clenv_environments evd n cty in
+  let (evd,args,concl) = clenv_environments evd n cty in
   { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args));
     templtyp = mk_freelisted concl;
-    evd = env;
+    evd = evd;
     env = environ }
 
 let mk_clenv_from_n gls n (c,cty) =
@@ -146,8 +146,8 @@ let mk_clenv_from_n gls n (c,cty) =
 
 let mk_clenv_from gls = mk_clenv_from_n gls None
 
-let mk_clenv_rename_from_n gls n (c,t) = 
-  mk_clenv_from_n gls n (c,rename_bound_var (pf_env gls) [] t)
+let mk_clenv_rename_from_n gls n (c,t) =
+  mk_clenv_from_n gls n (c,rename_bound_vars_as_displayed [] t)
 
 let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t)
 
@@ -168,21 +168,19 @@ let mentions clenv mv0 =
     meta_exists menrec mlist
   in menrec
 
-let clenv_defined clenv mv = meta_defined clenv.evd mv
-
 let error_incompatible_inst clenv mv  =
   let na = meta_name clenv.evd mv in
   match na with
       Name id ->
         errorlabstrm "clenv_assign"
-          (str "An incompatible instantiation has already been found for " ++ 
+          (str "An incompatible instantiation has already been found for " ++
            pr_id id)
     | _ ->
         anomaly "clenv_assign: non dependent metavar already assigned"
 
-(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *)		      
+(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *)
 let clenv_assign mv rhs clenv =
-  let rhs_fls = mk_freelisted rhs in 
+  let rhs_fls = mk_freelisted rhs in
   if meta_exists (mentions clenv mv) rhs_fls.freemetas then
     error "clenv_assign: circularity in unification";
   try
@@ -191,15 +189,13 @@ let clenv_assign mv rhs clenv =
         error_incompatible_inst clenv mv
       else
 	clenv
-    else 
+    else
       let st = (ConvUpToEta 0,TypeNotProcessed) in
       {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd}
-  with Not_found -> 
+  with Not_found ->
     error "clenv_assign: undefined meta"
 
 
-let clenv_wtactic f clenv = {clenv with evd = f clenv.evd }
-
 
 (* [clenv_dependent hyps_only clenv]
  * returns a list of the metavars which appear in the template of clenv,
@@ -222,7 +218,7 @@ let dependent_metas clenv mvs conclmetas =
        Metaset.union deps (clenv_metavars clenv.evd mv))
     mvs conclmetas
 
-let duplicated_metas c = 
+let duplicated_metas c =
   let rec collrec (one,more as acc) c =
     match kind_of_term c with
     | Meta mv -> if List.mem mv one then (one,mv::more) else (mv::one,more)
@@ -237,9 +233,9 @@ let clenv_dependent hyps_only clenv =
   let nonlinear = duplicated_metas (clenv_value clenv) in
   (* Make the assumption that duplicated metas have internal dependencies *)
   List.filter
-    (fun mv -> (Metaset.mem mv deps &&
-                not (hyps_only && Metaset.mem mv ctyp_mvs))
-               or List.mem mv nonlinear) 
+    (fun mv -> if Metaset.mem mv deps
+               then not (hyps_only && Metaset.mem mv ctyp_mvs)
+               else List.mem mv nonlinear)
     mvs
 
 let clenv_missing ce = clenv_dependent true ce
@@ -254,7 +250,7 @@ let clenv_unify_meta_types ?(flags=default_unify_flags) clenv =
   { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd }
 
 let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl =
-  if isMeta (fst (whd_stack (evars_of clenv.evd) clenv.templtyp.rebus)) then
+  if isMeta (fst (whd_stack clenv.evd clenv.templtyp.rebus)) then
     clenv_unify allow_K CUMUL ~flags:flags (clenv_type clenv) (pf_concl gl)
       (clenv_unify_meta_types ~flags:flags clenv)
   else
@@ -265,7 +261,7 @@ let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl =
  * For each dependent evar in the clause-env which does not have a value,
  * pose a value for it by constructing a fresh evar.  We do this in
  * left-to-right order, so that every evar's type is always closed w.r.t.
- * metas. 
+ * metas.
 
  * Node added 14/4/08 [HH]: before this date, evars were collected in
    clenv_dependent by collect_metas in the fold_constr order which is
@@ -277,7 +273,7 @@ let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl =
    dependency order when a clenv_fchain occurs (because clenv_fchain
    plugs a term with a list of consecutive metas in place of a - a priori -
    arbitrary metavariable belonging to another sequence of consecutive metas:
-   e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of 
+   e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of
    (nat_ind ?3 ?4 ?5 ?6), leading to a dependency order 3<4<5<1<2).
    To ensure the dependency order, we check that the type of each meta
    to pose is already meta-free, otherwise we postpone the transformation,
@@ -291,13 +287,13 @@ let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl =
 let clenv_pose_metas_as_evars clenv dep_mvs =
   let rec fold clenv = function
   | [] -> clenv
-  | mv::mvs -> 
+  | mv::mvs ->
       let ty = clenv_meta_type clenv mv in
       (* Postpone the evar-ization if dependent on another meta *)
       (* This assumes no cycle in the dependencies - is it correct ? *)
       if occur_meta ty then fold clenv (mvs@[mv])
       else
-	let (evd,evar) = 
+	let (evd,evar) =
 	  new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in
 	let clenv = clenv_assign mv evar {clenv with evd=evd} in
 	fold clenv mvs in
@@ -321,9 +317,9 @@ let connect_clenv gls clenv =
  * resolution can cause unification of already-existing metavars, and
  * of the fresh ones which get created.  This operation is a composite
  * of operations which pose new metavars, perform unification on
- * terms, and make bindings. 
+ * terms, and make bindings.
 
-   Otherwise said, from 
+   Otherwise said, from
 
      [clenv] = [env;sigma;metas |- c:T]
      [clenv'] = [env';sigma';metas' |- d:U]
@@ -340,8 +336,7 @@ let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv
   let clenv' =
     { templval = clenv.templval;
       templtyp = clenv.templtyp;
-      evd = 
-        evar_merge (meta_merge clenv.evd nextclenv.evd) (evars_of clenv.evd);
+      evd = meta_merge nextclenv.evd clenv.evd;
       env = nextclenv.env } in
   (* unify the type of the template of [nextclenv] with the type of [mv] *)
   let clenv'' =
@@ -352,13 +347,13 @@ let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv
   (* assign the metavar *)
   let clenv''' =
     clenv_assign mv (clenv_term clenv' nextclenv.templval) clenv''
-  in 
+  in
   clenv'''
 
 (***************************************************************)
 (* Bindings *)
 
-type arg_bindings = open_constr explicit_bindings
+type arg_bindings = constr explicit_bindings
 
 (* [clenv_independent clenv]
  * returns a list of metavariables which appear in the term cval,
@@ -374,9 +369,9 @@ let clenv_independent clenv =
 
 let check_bindings bl =
   match list_duplicates (List.map pi2 bl) with
-    | NamedHyp s :: _ -> 
+    | NamedHyp s :: _ ->
 	errorlabstrm ""
-	  (str "The variable " ++ pr_id s ++ 
+	  (str "The variable " ++ pr_id s ++
 	   str " occurs more than once in binding list.");
     | AnonHyp n :: _ ->
 	errorlabstrm ""
@@ -402,7 +397,7 @@ let error_already_defined b =
           (str "Position " ++ int n ++ str" already defined.")
 
 let clenv_unify_binding_type clenv c t u =
-  if isMeta (fst (whd_stack (evars_of clenv.evd) u)) then
+  if isMeta (fst (whd_stack clenv.evd u)) then
     (* Not enough information to know if some subtyping is needed *)
     CoerceToType, clenv, c
   else
@@ -410,16 +405,16 @@ let clenv_unify_binding_type clenv c t u =
     try
       let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in
       TypeProcessed, { clenv with evd = evd }, c
-    with
+    with 
       | PretypeError (_,NotClean _) as e -> raise e
-      | e when precatchable_exception e -> TypeNotProcessed, clenv, c
+      | e when precatchable_exception e ->
+	  TypeNotProcessed, clenv, c
 
-let clenv_assign_binding clenv k (sigma,c) =
+let clenv_assign_binding clenv k c =
   let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in
-  let clenv' = { clenv with evd = evar_merge clenv.evd sigma} in
-  let c_typ = nf_betaiota (evars_of clenv'.evd) (clenv_get_type_of clenv' c) in
-  let status,clenv'',c = clenv_unify_binding_type clenv' c c_typ k_typ in
-  { clenv'' with evd = meta_assign k (c,(UserGiven,status)) clenv''.evd }
+  let c_typ = nf_betaiota clenv.evd (clenv_get_type_of clenv c) in
+  let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in
+  { clenv' with evd = meta_assign k (c,(UserGiven,status)) clenv'.evd }
 
 let clenv_match_args bl clenv =
   if bl = [] then
@@ -428,13 +423,13 @@ let clenv_match_args bl clenv =
     let mvs = clenv_independent clenv in
     check_bindings bl;
     List.fold_left
-      (fun clenv (loc,b,(sigma,c as sc)) ->
+      (fun clenv (loc,b,c) ->
 	let k = meta_of_binder clenv loc mvs b in
         if meta_defined clenv.evd k then
           if eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv
           else error_already_defined b
         else
-	  clenv_assign_binding clenv k sc)
+	  clenv_assign_binding clenv k c)
       clenv bl
 
 exception NoSuchBinding
@@ -442,7 +437,7 @@ exception NoSuchBinding
 let clenv_constrain_last_binding c clenv =
   let all_mvs = collect_metas clenv.templval.rebus in
   let k = try list_last all_mvs with Failure _ -> raise NoSuchBinding in
-  clenv_assign_binding clenv k (Evd.empty,c)
+  clenv_assign_binding clenv k c
 
 let clenv_constrain_dep_args hyps_only bl clenv =
   if bl = [] then
@@ -451,8 +446,8 @@ let clenv_constrain_dep_args hyps_only bl clenv =
     let occlist = clenv_dependent hyps_only clenv in
     if List.length occlist = List.length bl then
       List.fold_left2 clenv_assign_binding clenv occlist bl
-    else 
-      errorlabstrm "" 
+    else
+      errorlabstrm ""
 	(strbrk "Not the right number of missing arguments (expected " ++
 	 int (List.length occlist) ++ str ").")
 
@@ -479,4 +474,4 @@ let pr_clenv clenv =
   h 0
     (str"TEMPL: " ++ print_constr clenv.templval.rebus ++
      str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++
-     pr_evar_defs clenv.evd)
+     pr_evar_map clenv.evd)
diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli
index 4c5535b3..62dfa7b5 100644
--- a/pretyping/clenv.mli
+++ b/pretyping/clenv.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: clenv.mli 13126 2010-06-13 11:09:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -32,7 +32,7 @@ open Unification
  *)
 type clausenv = {
   env      : env;
-  evd      : evar_defs;
+  evd      : evar_map;
   templval : constr freelisted;
   templtyp : constr freelisted }
 
@@ -60,14 +60,14 @@ val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> claus
 (* linking of clenvs *)
 
 val connect_clenv : evar_info sigma -> clausenv -> clausenv
-val clenv_fchain : 
+val clenv_fchain :
   ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv
 
 (***************************************************************)
 (* Unification with clenvs *)
 
 (* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *)
-val clenv_unify : 
+val clenv_unify :
   bool -> ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv
 
 (* unifies the concl of the goal with the type of the clenv *)
@@ -86,7 +86,7 @@ val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv
 (***************************************************************)
 (* Bindings *)
 
-type arg_bindings = open_constr explicit_bindings
+type arg_bindings = constr explicit_bindings
 
 (* bindings where the key is the position in the template of the
    clenv (dependent or not). Positions can be negative meaning to
@@ -109,10 +109,10 @@ val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv
 (* the optional int tells how many prods of the lemma have to be used *)
 (* use all of them if None *)
 val make_clenv_binding_apply :
-  evar_info sigma -> int option -> constr * constr -> open_constr bindings ->
+  evar_info sigma -> int option -> constr * constr -> constr bindings ->
    clausenv
 val make_clenv_binding :
-  evar_info sigma -> constr * constr -> open_constr bindings -> clausenv
+  evar_info sigma -> constr * constr -> constr bindings -> clausenv
 
 (* [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
    [lmetas] is a list of metas to be applied to a proof of [t] so that
@@ -124,12 +124,12 @@ val make_clenv_binding :
    [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1]
    and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *)
 val clenv_environments :
- evar_defs -> int option -> types -> evar_defs * constr list * types
+ evar_map -> int option -> types -> evar_map * constr list * types
 
 (* [clenv_environments_evars env sigma n t] does the same but returns
    a list of Evar's defined in [env] and extends [sigma] accordingly *)
 val clenv_environments_evars :
- env -> evar_defs -> int option -> types -> evar_defs * constr list * types
+ env -> evar_map -> int option -> types -> evar_map * constr list * types
 
 (* [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *)
 val clenv_conv_leq :
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 73fcd0ea..9f0b4352 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: coercion.ml 11343 2008-09-01 20:55:13Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -24,43 +24,43 @@ open Termops
 
 module type S = sig
   (*s Coercions. *)
-  
+
   (* [inh_app_fun env evd j] coerces [j] to a function; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a product; it returns [j] if no coercion is applicable *)
   val inh_app_fun :
-    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
-    
+    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
+
   (* [inh_coerce_to_sort env evd j] coerces [j] to a type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a sort; it fails if no coercion is applicable *)
   val inh_coerce_to_sort : loc ->
-    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
+    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
 
   (* [inh_coerce_to_base env evd j] coerces [j] to its base type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type its base type (the notion depends on the coercion system) *)
   val inh_coerce_to_base : loc ->
-    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
-    
-  (* [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
+    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
+
+  (* [inh_coerce_to_prod env evars t] coerces [t] to a product type *)
   val inh_coerce_to_prod : loc ->
-    env -> evar_defs -> type_constraint_type -> evar_defs * type_constraint_type
+    env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type
 
-  (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type 
+  (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type
      [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
      [j.uj_type] are convertible; it fails if no coercion is applicable *)
-  val inh_conv_coerce_to : loc -> 
-    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+  val inh_conv_coerce_to : loc ->
+    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
 
-  val inh_conv_coerce_rigid_to : loc -> 
-    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+  val inh_conv_coerce_rigid_to : loc ->
+    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
 
   (* [inh_conv_coerces_to loc env evd t t'] checks if an object of type [t]
      is coercible to an object of type [t'] adding evar constraints if needed;
      it fails if no coercion exists *)
-  val inh_conv_coerces_to : loc -> 
-    env -> evar_defs -> types -> type_constraint_type -> evar_defs
+  val inh_conv_coerces_to : loc ->
+    env -> evar_map -> types -> type_constraint_type -> evar_map
 
   (* [inh_pattern_coerce_to loc env evd pat ind1 ind2] coerces the Cases
      pattern [pat] typed in [ind1] into a pattern typed in [ind2];
@@ -73,24 +73,19 @@ module Default = struct
   (* Typing operations dealing with coercions *)
   exception NoCoercion
 
-  let whd_app_evar sigma t =
-    match kind_of_term t with
-      | App (f,l) -> mkApp (whd_evar sigma f,l)
-      | _ -> whd_evar sigma t
-
   (* Here, funj is a coercion therefore already typed in global context *)
   let apply_coercion_args env argl funj =
     let rec apply_rec acc typ = function
       | [] -> { uj_val = applist (j_val funj,argl);
 		uj_type = typ }
       | h::restl ->
-	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
+	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
   	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	    | Prod (_,c1,c2) -> 
+	    | Prod (_,c1,c2) ->
 		(* Typage garanti par l'appel à app_coercion*)
 		apply_rec (h::acc) (subst1 h c2) restl
 	    | _ -> anomaly "apply_coercion_args"
-    in 
+    in
       apply_rec [] funj.uj_type argl
 
   (* appliquer le chemin de coercions de patterns p *)
@@ -106,47 +101,55 @@ module Default = struct
     let p = lookup_pattern_path_between (ind1,ind2) in
       apply_pattern_coercion loc pat p
 
+  let saturate_evd env evd =
+    Typeclasses.resolve_typeclasses
+      ~onlyargs:true ~split:true ~fail:false env evd
+
   (* appliquer le chemin de coercions p à hj *)
   let apply_coercion env sigma p hj typ_cl =
-    try 
+    try
       fst (List.fold_left
-             (fun (ja,typ_cl) i -> 
+             (fun (ja,typ_cl) i ->
 		let fv,isid = coercion_value i in
 		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
 		let jres = apply_coercion_args env argl fv in
-		  (if isid then 
+		  (if isid then
 		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
-		   else 
+		   else
 		     jres),
 		jres.uj_type)
              (hj,typ_cl) p)
     with _ -> anomaly "apply_coercion"
 
-  let inh_app_fun env evd j = 
-    let t = whd_betadeltaiota env (evars_of evd) j.uj_type in
+  let inh_app_fun env evd j =
+    let t = whd_betadeltaiota env evd j.uj_type in
       match kind_of_term t with
 	| Prod (_,_,_) -> (evd,j)
 	| Evar ev ->
 	    let (evd',t) = define_evar_as_product evd ev in
 	      (evd',{ uj_val = j.uj_val; uj_type = t })
 	| _ ->
-       	    (try
-      	       let t,p =
-		 lookup_path_to_fun_from env (evars_of evd) j.uj_type in
-		 (evd,apply_coercion env (evars_of evd) p j t)
-	     with Not_found -> (evd,j))
+      	    let t,p =
+	      lookup_path_to_fun_from env ( evd) j.uj_type in
+	      (evd,apply_coercion env ( evd) p j t)
+
+  let inh_app_fun env evd j =
+    try inh_app_fun env evd j
+    with Not_found ->
+      try inh_app_fun env (saturate_evd env evd) j
+      with Not_found -> (evd, j)
 
   let inh_tosort_force loc env evd j =
     try
-      let t,p = lookup_path_to_sort_from env (evars_of evd) j.uj_type in
-      let j1 = apply_coercion env (evars_of evd) p j t in 
-      let j2 = on_judgment_type (whd_evar (evars_of evd)) j1 in
+      let t,p = lookup_path_to_sort_from env ( evd) j.uj_type in
+      let j1 = apply_coercion env ( evd) p j t in
+      let j2 = on_judgment_type (whd_evar ( evd)) j1 in
         (evd,type_judgment env j2)
     with Not_found ->
-      error_not_a_type_loc loc env (evars_of 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 (evars_of evd) j.uj_type in
+    let typ = whd_betadeltaiota env ( evd) j.uj_type in
       match kind_of_term typ with
 	| Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
 	| Evar ev when not (is_defined_evar evd ev) ->
@@ -156,7 +159,6 @@ module Default = struct
 	    inh_tosort_force loc env evd j
 
   let inh_coerce_to_base loc env evd j = (evd, j)
-
   let inh_coerce_to_prod loc env evd t = (evd, t)
 
   let inh_coerce_to_fail env evd rigidonly v t c1 =
@@ -165,16 +167,16 @@ module Default = struct
       raise NoCoercion
     else
     let v', t' =
-      try 
-	let t2,t1,p = lookup_path_between env (evars_of evd) (t,c1) in
+      try
+	let t2,t1,p = lookup_path_between env evd (t,c1) in
 	  match v with
-	      Some v -> 
+	      Some v ->
 		let j =
-		  apply_coercion env (evars_of evd) p
+		  apply_coercion env evd p
 		    {uj_val = v; uj_type = t} t2 in
 		  Some j.uj_val, j.uj_type
 	    | None -> None, t
-      with Not_found -> raise NoCoercion 
+      with Not_found -> raise NoCoercion
     in
       try (the_conv_x_leq env t' c1 evd, v')
       with Reduction.NotConvertible -> raise NoCoercion
@@ -185,15 +187,15 @@ module Default = struct
     try inh_coerce_to_fail env evd rigidonly v t c1
     with NoCoercion ->
     match
-      kind_of_term (whd_betadeltaiota env (evars_of evd) t),
-      kind_of_term (whd_betadeltaiota env (evars_of evd) c1)
+      kind_of_term (whd_betadeltaiota env evd t),
+      kind_of_term (whd_betadeltaiota env evd c1)
     with
-    | Prod (name,t1,t2), Prod (_,u1,u2) -> 
+    | Prod (name,t1,t2), Prod (_,u1,u2) ->
         (* Conversion did not work, we may succeed with a coercion. *)
         (* We eta-expand (hence possibly modifying the original term!) *)
 	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
 	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
-	let name = match name with 
+	let name = match name with
 	  | Anonymous -> Name (id_of_string "x")
 	  | _ -> name in
 	let env1 = push_rel (name,None,u1) env in
@@ -211,12 +213,15 @@ module Default = struct
   let inh_conv_coerce_to_gen rigidonly loc env evd cj (n, t) =
     match n with
 	None ->
-	  let (evd', val') = 
-	    try 
+	  let (evd', val') =
+	    try
 	      inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
 	    with NoCoercion ->
-	      let sigma = evars_of evd in
-		error_actual_type_loc loc env sigma cj t
+	      let evd = saturate_evd env evd in
+		try
+		  inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
+		with NoCoercion ->
+		  error_actual_type_loc loc env evd cj t
 	  in
 	  let val' = match val' with Some v -> v | None -> assert(false) in
 	    (evd',{ uj_val = val'; uj_type = t })
@@ -225,19 +230,19 @@ module Default = struct
   let inh_conv_coerce_to = inh_conv_coerce_to_gen false
   let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true
 
-      
-    let inh_conv_coerces_to loc env (evd : evar_defs) t (abs, t') = evd
-      (* Still problematic, as it changes unification 
-      let nabsinit, nabs = 
+
+    let inh_conv_coerces_to loc env (evd : evar_map) t (abs, t') = evd
+      (* Still problematic, as it changes unification
+      let nabsinit, nabs =
 	match abs with
 	    None -> 0, 0
 	  | Some (init, cur) -> init, cur
       in
-	try 
-	  let (rels, rng) = 
-	    (* a little more effort to get products is needed *) 
+	try
+	  let (rels, rng) =
+	    (* a little more effort to get products is needed *)
 	    try decompose_prod_n nabs t
-	    with _ -> 
+	    with _ ->
 	      if !Flags.debug then
 		msg_warning (str "decompose_prod_n failed");
 	      raise (Invalid_argument "Coercion.inh_conv_coerces_to")
@@ -245,15 +250,15 @@ module Default = struct
 	    (* The final range free variables must have been replaced by evars, we accept only that evars
 	       in rng are applied to free vars. *)
 	    if noccur_with_meta 0 (succ nabsinit) rng then (
-	      let env', t, t' = 
+	      let env', t, t' =
 		let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
 		  env', rng, lift nabs t'
 	      in
-		try 
+		try
 		  pi1 (inh_conv_coerce_to_fail loc env' evd None t t')
 		with NoCoercion ->
 		  evd) (* Maybe not enough information to unify *)
-	      (*let sigma = evars_of evd in
+	      (*let sigma =  evd in
 		error_cannot_coerce env' sigma (t, t'))*)
 	    else evd
 	with Invalid_argument _ -> evd	  *)
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index 8705080f..565cf0c4 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coercion.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -21,44 +21,44 @@ open Rawterm
 
 module type S = sig
   (*s Coercions. *)
-  
+
   (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a product; it returns [j] if no coercion is applicable *)
   val inh_app_fun :
-    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
-    
+    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
+
   (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type a sort; it fails if no coercion is applicable *)
   val inh_coerce_to_sort : loc ->
-    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
+    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
 
   (* [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
      inserts a coercion into [j], if needed, in such a way it gets as
      type its base type (the notion depends on the coercion system) *)
   val inh_coerce_to_base : loc ->
-    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
 
   (* [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
   val inh_coerce_to_prod : loc ->
-    env -> evar_defs -> type_constraint_type -> evar_defs * type_constraint_type
-    
-  (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type 
+    env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type
+
+  (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type
      [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
      [j.uj_type] are convertible; it fails if no coercion is applicable *)
-  val inh_conv_coerce_to : loc -> 
-    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+  val inh_conv_coerce_to : loc ->
+    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
+
+  val inh_conv_coerce_rigid_to : loc ->
+    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
 
-  val inh_conv_coerce_rigid_to : loc -> 
-    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
-    
   (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
      is coercible to an object of type [t'] adding evar constraints if needed;
      it fails if no coercion exists *)
-  val inh_conv_coerces_to : loc -> 
-    env -> evar_defs -> types -> type_constraint_type -> evar_defs
-   
+  val inh_conv_coerces_to : loc ->
+    env -> evar_map -> types -> type_constraint_type -> evar_map
+
   (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
      pattern [pat] typed in [ind1] into a pattern typed in [ind2];
      raises [Not_found] if no coercion found *)
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 20cbba94..9552fc24 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: detyping.ml 12887 2010-03-27 15:57:02Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -21,6 +21,7 @@ open Sign
 open Rawterm
 open Nameops
 open Termops
+open Namegen
 open Libnames
 open Nametab
 open Evd
@@ -32,7 +33,7 @@ let dl = dummy_loc
 (* Tools for printing of Cases                                              *)
 
 let encode_inductive r =
-  let indsp = inductive_of_reference r in
+  let indsp = global_inductive r in
   let constr_lengths = mis_constr_nargs indsp in
   (indsp,constr_lengths)
 
@@ -60,7 +61,7 @@ let encode_tuple r =
   x
 
 module PrintingCasesMake =
-  functor (Test : sig 
+  functor (Test : sig
      val encode : reference -> inductive * int array
      val member_message : std_ppcmds -> bool -> std_ppcmds
      val field : string
@@ -70,33 +71,33 @@ module PrintingCasesMake =
     type t = inductive * int array
     let encode = Test.encode
     let subst subst ((kn,i), ints as obj) =
-      let kn' = subst_kn subst kn in
+      let kn' = subst_ind subst kn in
 	if kn' == kn then obj else
 	  (kn',i), ints
     let printer (ind,_) = pr_global_env Idset.empty (IndRef ind)
-    let key = Goptions.SecondaryTable ("Printing",Test.field)
+    let key = ["Printing";Test.field]
     let title = Test.title
     let member_message x = Test.member_message (printer x)
     let synchronous = true
   end
 
 module PrintingCasesIf =
-  PrintingCasesMake (struct 
+  PrintingCasesMake (struct
     let encode = encode_bool
     let field = "If"
     let title = "Types leading to pretty-printing of Cases using a `if' form: "
     let member_message s b =
-      str "Cases on elements of " ++ s ++ 
+      str "Cases on elements of " ++ s ++
       str
 	(if b then " are printed using a `if' form"
          else " are not printed using a `if' form")
   end)
 
 module PrintingCasesLet =
-  PrintingCasesMake (struct 
+  PrintingCasesMake (struct
     let encode = encode_tuple
     let field = "Let"
-    let title = 
+    let title =
       "Types leading to a pretty-printing of Cases using a `let' form:"
     let member_message s b =
       str "Cases on elements of " ++ s ++
@@ -115,30 +116,30 @@ open Goptions
 let wildcard_value = ref true
 let force_wildcard () = !wildcard_value
 
-let _ = declare_bool_option 
+let _ = declare_bool_option
 	  { optsync  = true;
 	    optname  = "forced wildcard";
-	    optkey   = SecondaryTable ("Printing","Wildcard");
+	    optkey   = ["Printing";"Wildcard"];
 	    optread  = force_wildcard;
 	    optwrite = (:=) wildcard_value }
 
 let synth_type_value = ref true
 let synthetize_type () = !synth_type_value
 
-let _ = declare_bool_option 
+let _ = declare_bool_option
 	  { optsync  = true;
 	    optname  = "pattern matching return type synthesizability";
-	    optkey   = SecondaryTable ("Printing","Synth");
+	    optkey   = ["Printing";"Synth"];
 	    optread  = synthetize_type;
 	    optwrite = (:=) synth_type_value }
 
 let reverse_matching_value = ref true
 let reverse_matching () = !reverse_matching_value
 
-let _ = declare_bool_option 
+let _ = declare_bool_option
 	  { optsync  = true;
 	    optname  = "pattern-matching reversibility";
-	    optkey   = SecondaryTable ("Printing","Matching");
+	    optkey   = ["Printing";"Matching"];
 	    optread  = reverse_matching;
 	    optwrite = (:=) reverse_matching_value }
 
@@ -162,52 +163,48 @@ let computable p k =
        sinon on perd la réciprocité de la synthèse (qui, lui,
        engendrera un prédicat non dépendant) *)
 
-  (nb_lam p = k+1)
+  let sign,ccl = decompose_lam_assum p in
+  (rel_context_length sign = k+1)
   &&
-  let _,ccl = decompose_lam p in 
   noccur_between 1 (k+1) ccl
 
 let avoid_flag isgoal = if isgoal then Some true else None
- 
-let lookup_name_as_renamed env t s =
-  let rec lookup avoid env_names n c = match kind_of_term c with
+
+let lookup_name_as_displayed env t s =
+  let rec lookup avoid n c = match kind_of_term c with
     | Prod (name,_,c') ->
-	(match concrete_name (Some true) avoid env_names name c' with
-           | (Name id,avoid') -> 
-	       if id=s then (Some n) 
-	       else lookup avoid' (add_name (Name id) env_names) (n+1) c'
-	   | (Anonymous,avoid')    -> lookup avoid' env_names (n+1) (pop c'))
+	(match compute_displayed_name_in RenamingForGoal avoid name c' with
+           | (Name id,avoid') -> if id=s then Some n else lookup avoid' (n+1) c'
+	   | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c'))
     | LetIn (name,_,_,c') ->
-	(match concrete_name (Some true) avoid env_names name c' with
-           | (Name id,avoid') -> 
-	       if id=s then (Some n) 
-	       else lookup avoid' (add_name (Name id) env_names) (n+1) c'
-	   | (Anonymous,avoid')    -> lookup avoid' env_names (n+1) (pop c'))
-    | Cast (c,_,_) -> lookup avoid env_names n c
+	(match compute_displayed_name_in RenamingForGoal avoid name c' with
+           | (Name id,avoid') -> if id=s then Some n else lookup avoid' (n+1) c'
+	   | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c'))
+    | Cast (c,_,_) -> lookup avoid n c
     | _ -> None
-  in lookup (ids_of_named_context (named_context env)) empty_names_context 1 t
+  in lookup (ids_of_named_context (named_context env)) 1 t
 
 let lookup_index_as_renamed env t n =
   let rec lookup n d c = match kind_of_term c with
     | Prod (name,_,c') ->
-	  (match concrete_name (Some true) [] empty_names_context name c' with
+	  (match compute_displayed_name_in RenamingForGoal [] name c' with
                (Name _,_) -> lookup n (d+1) c'
-             | (Anonymous,_) -> 
+             | (Anonymous,_) ->
 		 if n=0 then
 		   Some (d-1)
-		 else if n=1 then 
-		   Some d 
-		 else 
+		 else if n=1 then
+		   Some d
+		 else
 		   lookup (n-1) (d+1) c')
     | LetIn (name,_,_,c') ->
-	  (match concrete_name (Some true) [] empty_names_context name c' with
+	  (match compute_displayed_name_in RenamingForGoal [] name c' with
              | (Name _,_) -> lookup n (d+1) c'
-             | (Anonymous,_) -> 
-		 if n=0 then 
-		   Some (d-1) 
-		 else if n=1 then 
-		   Some d 
-		 else 
+             | (Anonymous,_) ->
+		 if n=0 then
+		   Some (d-1)
+		 else if n=1 then
+		   Some d
+		 else
 		   lookup (n-1) (d+1) c'
 	  )
     | Cast (c,_,_) -> lookup n d c
@@ -225,16 +222,17 @@ let update_name na ((_,e),c) =
       na
 
 let rec decomp_branch n nal b (avoid,env as e) c =
+  let flag = if b then RenamingForGoal else RenamingForCasesPattern in
   if n=0 then (List.rev nal,(e,c))
   else
     let na,c,f =
       match kind_of_term (strip_outer_cast c) with
-	| Lambda (na,_,c) -> na,c,concrete_let_name
-	| LetIn (na,_,_,c) -> na,c,concrete_name
-	| _ -> 
-	    Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), 
-	    concrete_name in
-    let na',avoid' = f (Some b) avoid env na c in
+	| Lambda (na,_,c) -> na,c,compute_displayed_let_name_in
+	| LetIn (na,_,_,c) -> na,c,compute_displayed_name_in
+	| _ ->
+	    Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])),
+	    compute_displayed_name_in in
+    let na',avoid' = f flag avoid na c in
     decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c
 
 let rec build_tree na isgoal e ci cl =
@@ -248,14 +246,14 @@ and align_tree nal isgoal (e,c as rhs) = match nal with
   | [] -> [[],rhs]
   | na::nal ->
     match kind_of_term c with
-    | Case (ci,p,c,cl) when c = mkRel (list_index na (snd e)) 
+    | Case (ci,p,c,cl) when c = mkRel (list_index na (snd e))
 	& (* don't contract if p dependent *)
 	computable p (ci.ci_pp_info.ind_nargs) ->
 	let clauses = build_tree na isgoal e ci cl in
 	List.flatten
           (List.map (fun (pat,rhs) ->
 	      let lines = align_tree nal isgoal rhs in
-	      List.map (fun (hd,rest) -> pat::hd,rest) lines) 
+	      List.map (fun (hd,rest) -> pat::hd,rest) lines)
 	    clauses)
     | _ ->
 	let pat = PatVar(dl,update_name na rhs) in
@@ -294,14 +292,14 @@ let it_destRLambda_or_LetIn_names n c =
       | _ ->
           (* eta-expansion *)
 	  let rec next l =
-	    let x = Nameops.next_ident_away (id_of_string "x") l in
+	    let x = next_ident_away (id_of_string "x") l in
 	    (* Not efficient but unusual and no function to get free rawvars *)
 (* 	    if occur_rawconstr x c then next (x::l) else x in *)
 	    x
 	  in
-	  let x = next (free_rawvars c) in 
+	  let x = next (free_rawvars c) in
 	  let a = RVar (dl,x) in
-	  aux (n-1) (Name x :: nal) 
+	  aux (n-1) (Name x :: nal)
             (match c with
               | RApp (loc,p,l) -> RApp (loc,c,l@[a])
               | _ -> (RApp (dl,c,[a])))
@@ -311,16 +309,16 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
   let (indsp,st,nparams,consnargsl,k) = data in
   let synth_type = synthetize_type () in
   let tomatch = detype c in
-  let alias, aliastyp, pred= 
-    if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0 
-    then 
+  let alias, aliastyp, pred=
+    if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0
+    then
       Anonymous, None, None
     else
       match Option.map detype p with
         | None -> Anonymous, None, None
         | Some p ->
             let nl,typ = it_destRLambda_or_LetIn_names k p in
-	    let n,typ = match typ with 
+	    let n,typ = match typ with
               | RLambda (_,x,_,t,c) -> x, c
 	      | _ -> Anonymous, typ in
 	    let aliastyp =
@@ -330,21 +328,21 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
   in
   let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in
   let tag =
-    try 
+    try
       if !Flags.raw_print then
         RegularStyle
-      else if st = LetPatternStyle then 
+      else if st = LetPatternStyle then
 	st
       else if PrintingLet.active (indsp,consnargsl) then
 	LetStyle
-      else if PrintingIf.active (indsp,consnargsl) then 
+      else if PrintingIf.active (indsp,consnargsl) then
 	IfStyle
-      else 
+      else
 	st
     with Not_found -> st
   in
   match tag with
-  | LetStyle when aliastyp = None -> 
+  | LetStyle when aliastyp = None ->
       let bl' = Array.map detype bl in
       let (nal,d) = it_destRLambda_or_LetIn_names consnargsl.(0) bl'.(0) in
       RLetTuple (dl,nal,(alias,pred),tomatch,d)
@@ -400,7 +398,7 @@ let rec detype (isgoal:bool) avoid env t =
               array_map_to_list (detype isgoal avoid env) args)
     | Const sp -> RRef (dl, ConstRef sp)
     | Evar (ev,cl) ->
-        REvar (dl, ev, 
+        REvar (dl, ev,
                Some (List.map (detype isgoal avoid env) (Array.to_list cl)))
     | Ind ind_sp ->
 	RRef (dl, IndRef ind_sp)
@@ -410,7 +408,7 @@ let rec detype (isgoal:bool) avoid env t =
 	let comp = computable p (ci.ci_pp_info.ind_nargs) in
 	detype_case comp (detype isgoal avoid env)
 	  (detype_eqns isgoal avoid env ci comp)
-	  is_nondep_branch avoid 
+	  is_nondep_branch avoid
 	  (ci.ci_ind,ci.ci_pp_info.style,ci.ci_npar,
 	   ci.ci_cstr_nargs,ci.ci_pp_info.ind_nargs)
 	  (Some p) c bl
@@ -421,7 +419,7 @@ and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) =
   let def_avoid, def_env, lfi =
     Array.fold_left
       (fun (avoid, env, l) na ->
-	 let id = next_name_away na avoid in 
+	 let id = next_name_away na avoid in
 	 (id::avoid, add_name (Name id) env, id::l))
       (avoid, env, []) names in
   let n = Array.length tys in
@@ -437,7 +435,7 @@ and detype_cofix isgoal avoid env n (names,tys,bodies) =
   let def_avoid, def_env, lfi =
     Array.fold_left
       (fun (avoid, env, l) na ->
-	 let id = next_name_away na avoid in 
+	 let id = next_name_away na avoid in
 	 (id::avoid, add_name (Name id) env, id::l))
       (avoid, env, []) names in
   let ntys = Array.length tys in
@@ -456,16 +454,16 @@ and share_names isgoal n l avoid env c t =
         let na = match (na,na') with
             Name _, _ -> na
           | _, Name _ -> na'
-          | _ -> na in 
+          | _ -> na in
         let t = detype isgoal avoid env t in
-	let id = next_name_away na avoid in 
+	let id = next_name_away na avoid in
         let avoid = id::avoid and env = add_name (Name id) env in
         share_names isgoal (n-1) ((Name id,Explicit,None,t)::l) avoid env c c'
     (* May occur for fix built interactively *)
     | LetIn (na,b,t',c), _ when n > 0 ->
         let t' = detype isgoal avoid env t' in
         let b = detype isgoal avoid env b in
-	let id = next_name_away na avoid in 
+	let id = next_name_away na avoid in
         let avoid = id::avoid and env = add_name (Name id) env in
         share_names isgoal n ((Name id,Explicit,Some b,t')::l) avoid env c t
     (* Only if built with the f/n notation or w/o let-expansion in types *)
@@ -474,7 +472,7 @@ and share_names isgoal n l avoid env c t =
     (* If it is an open proof: we cheat and eta-expand *)
     | _, Prod (na',t',c') when n > 0 ->
         let t' = detype isgoal avoid env t' in
-	let id = next_name_away na' avoid in 
+	let id = next_name_away na' avoid in
         let avoid = id::avoid and env = add_name (Name id) env in
         let appc = mkApp (lift 1 c,[|mkRel 1|]) in
         share_names isgoal (n-1) ((Name id,Explicit,None,t')::l) avoid env appc c'
@@ -499,22 +497,22 @@ and detype_eqn isgoal avoid env constr construct_nargs branch =
   let make_pat x avoid env b ids =
     if force_wildcard () & noccurn 1 b then
       PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids
-    else 
+    else
       let id = next_name_away_in_cases_pattern x avoid in
       PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids
   in
   let rec buildrec ids patlist avoid env n b =
     if n=0 then
-      (dl, ids, 
+      (dl, ids,
        [PatCstr(dl, constr, List.rev patlist,Anonymous)],
        detype isgoal avoid env b)
     else
       match kind_of_term b with
-	| Lambda (x,_,b) -> 
+	| Lambda (x,_,b) ->
 	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
             buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
 
-	| LetIn (x,_,_,b) -> 
+	| LetIn (x,_,_,b) ->
 	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
             buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
 
@@ -528,21 +526,20 @@ and detype_eqn isgoal avoid env constr construct_nargs branch =
             let pat,new_avoid,new_env,new_ids =
 	      make_pat Anonymous avoid env new_b ids in
 	    buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b
-	  
-  in 
+
+  in
   buildrec [] [] avoid env construct_nargs branch
 
 and detype_binder isgoal bk avoid env na ty c =
+  let flag = if isgoal then RenamingForGoal else (RenamingElsewhereFor c) in
   let na',avoid' =
-    if bk = BLetIn then
-      concrete_let_name (avoid_flag isgoal) avoid env na c
-    else
-      concrete_name (avoid_flag isgoal) avoid env na c in
+    if bk = BLetIn then compute_displayed_let_name_in flag avoid na c
+    else compute_displayed_name_in flag avoid na c in
   let r =  detype isgoal avoid' (add_name na' env) c in
   match bk with
-  | BProd -> RProd (dl, na',Explicit,detype isgoal avoid env ty, r)
-  | BLambda -> RLambda (dl, na',Explicit,detype isgoal avoid env ty, r)
-  | BLetIn -> RLetIn (dl, na',detype isgoal avoid env ty, r)
+  | BProd -> RProd (dl, na',Explicit,detype false avoid env ty, r)
+  | BLambda -> RLambda (dl, na',Explicit,detype false avoid env ty, r)
+  | BLetIn -> RLetIn (dl, na',detype false avoid env ty, r)
 
 let rec detype_rel_context where avoid env sign =
   let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
@@ -553,8 +550,10 @@ let rec detype_rel_context where avoid env sign =
 	match where with
 	| None -> na,avoid
 	| Some c ->
-	    if b<>None then concrete_let_name None avoid env na c
-	    else concrete_name None avoid env na c in
+	    if b<>None then
+	      compute_displayed_let_name_in (RenamingElsewhereFor c) avoid na c
+	    else
+	      compute_displayed_name_in (RenamingElsewhereFor c) avoid na c in
       let b = Option.map (detype false avoid env) b in
       let t = detype false avoid env t in
       (na',Explicit,b,t) :: aux avoid' (add_name na' env) rest
@@ -563,19 +562,19 @@ let rec detype_rel_context where avoid env sign =
 (**********************************************************************)
 (* Module substitution: relies on detyping                            *)
 
-let rec subst_cases_pattern subst pat = 
+let rec subst_cases_pattern subst pat =
   match pat with
   | PatVar _ -> pat
-  | PatCstr (loc,((kn,i),j),cpl,n) -> 
-      let kn' = subst_kn subst kn 
+  | PatCstr (loc,((kn,i),j),cpl,n) ->
+      let kn' = subst_ind subst kn
       and cpl' = list_smartmap (subst_cases_pattern subst) cpl in
 	if kn' == kn && cpl' == cpl then pat else
 	  PatCstr (loc,((kn',i),j),cpl',n)
 
-let rec subst_rawconstr subst raw = 
+let rec subst_rawconstr subst raw =
   match raw with
-  | RRef (loc,ref) -> 
-      let ref',t = subst_global subst ref in 
+  | RRef (loc,ref) ->
+      let ref',t = subst_global subst ref in
 	if ref' == ref then raw else
          detype false [] [] t
 
@@ -583,38 +582,38 @@ let rec subst_rawconstr subst raw =
   | REvar _ -> raw
   | RPatVar _ -> raw
 
-  | RApp (loc,r,rl) -> 
-      let r' = subst_rawconstr subst r 
+  | RApp (loc,r,rl) ->
+      let r' = subst_rawconstr subst r
       and rl' = list_smartmap (subst_rawconstr subst) rl in
 	if r' == r && rl' == rl then raw else
 	  RApp(loc,r',rl')
 
-  | RLambda (loc,n,bk,r1,r2) -> 
+  | RLambda (loc,n,bk,r1,r2) ->
       let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  RLambda (loc,n,bk,r1',r2')
 
-  | RProd (loc,n,bk,r1,r2) -> 
+  | RProd (loc,n,bk,r1,r2) ->
       let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  RProd (loc,n,bk,r1',r2')
 
-  | RLetIn (loc,n,r1,r2) -> 
+  | RLetIn (loc,n,r1,r2) ->
       let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	if r1' == r1 && r2' == r2 then raw else
 	  RLetIn (loc,n,r1',r2')
 
-  | RCases (loc,sty,rtno,rl,branches) -> 
+  | RCases (loc,sty,rtno,rl,branches) ->
       let rtno' = Option.smartmap (subst_rawconstr subst) rtno
       and rl' = list_smartmap (fun (a,x as y) ->
         let a' = subst_rawconstr subst a in
-        let (n,topt) = x in 
+        let (n,topt) = x in
         let topt' = Option.smartmap
           (fun (loc,(sp,i),x,y as t) ->
-            let sp' = subst_kn subst sp in
+            let sp' = subst_ind subst sp in
             if sp == sp' then t else (loc,(sp',i),x,y)) topt in
         if a == a' && topt == topt' then y else (a',(n,topt'))) rl
-      and branches' = list_smartmap 
+      and branches' = list_smartmap
 			(fun (loc,idl,cpl,r as branch) ->
 			   let cpl' =
 			     list_smartmap (subst_cases_pattern subst) cpl
@@ -628,20 +627,20 @@ let rec subst_rawconstr subst raw =
 
   | RLetTuple (loc,nal,(na,po),b,c) ->
       let po' = Option.smartmap (subst_rawconstr subst) po
-      and b' = subst_rawconstr subst b 
+      and b' = subst_rawconstr subst b
       and c' = subst_rawconstr subst c in
 	if po' == po && b' == b && c' == c then raw else
           RLetTuple (loc,nal,(na,po'),b',c')
-	        
+
   | RIf (loc,c,(na,po),b1,b2) ->
       let po' = Option.smartmap (subst_rawconstr subst) po
-      and b1' = subst_rawconstr subst b1 
-      and b2' = subst_rawconstr subst b2 
+      and b1' = subst_rawconstr subst b1
+      and b2' = subst_rawconstr subst b2
       and c' = subst_rawconstr subst c in
 	if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
           RIf (loc,c',(na,po'),b1',b2')
 
-  | RRec (loc,fix,ida,bl,ra1,ra2) -> 
+  | RRec (loc,fix,ida,bl,ra1,ra2) ->
       let ra1' = array_smartmap (subst_rawconstr subst) ra1
       and ra2' = array_smartmap (subst_rawconstr subst) ra2 in
       let bl' = array_smartmap
@@ -655,20 +654,21 @@ let rec subst_rawconstr subst raw =
 
   | RSort _ -> raw
 
-  | RHole (loc,ImplicitArg (ref,i)) ->
-      let ref',_ = subst_global subst ref in 
+  | RHole (loc,ImplicitArg (ref,i,b)) ->
+      let ref',_ = subst_global subst ref in
 	if ref' == ref then raw else
 	  RHole (loc,InternalHole)
   | RHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole |
-      TomatchTypeParameter _ | GoalEvar | ImpossibleCase)) -> raw
+      TomatchTypeParameter _ | GoalEvar | ImpossibleCase | MatchingVar _)) ->
+      raw
 
-  | RCast (loc,r1,k) -> 
-      (match k with 
+  | RCast (loc,r1,k) ->
+      (match k with
 	   CastConv (k,r2) ->
 	     let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
 	       if r1' == r1 && r2' == r2 then raw else
 		 RCast (loc,r1', CastConv (k,r2'))
-	 | CastCoerce -> 
+	 | CastCoerce ->
 	     let r1' = subst_rawconstr subst r1 in
 	       if r1' == r1 then raw else RCast (loc,r1',k))
   | RDynamic _ -> raw
@@ -684,6 +684,6 @@ let simple_cases_matrix_of_branches ind brns brs =
       (dummy_loc,ids,[p],c))
     0 brns brs
 
-let return_type_of_predicate ind nparams n pred =
-  let nal,p = it_destRLambda_or_LetIn_names (n+1) pred in
+let return_type_of_predicate ind nparams nrealargs_ctxt pred =
+  let nal,p = it_destRLambda_or_LetIn_names (nrealargs_ctxt+1) pred in
   (List.hd nal, Some (dummy_loc, ind, nparams, List.tl nal)), Some p
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 23090858..d7fb01ae 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: detyping.mli 10410 2007-12-31 13:11:55Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -30,9 +30,9 @@ val subst_rawconstr : substitution -> rawconstr -> rawconstr
 
 val detype : bool -> identifier list -> names_context -> constr -> rawconstr
 
-val detype_case : 
+val detype_case :
   bool -> ('a -> rawconstr) ->
-  (constructor array -> int array -> 'a array -> 
+  (constructor array -> int array -> 'a array ->
     (loc * identifier list * cases_pattern list * rawconstr) list) ->
   ('a -> int -> bool) ->
   identifier list -> inductive * case_style * int * int array * int ->
@@ -44,7 +44,7 @@ val detype_rel_context : constr option -> identifier list -> names_context ->
   rel_context -> rawdecl list
 
 (* look for the index of a named var or a nondep var as it is renamed *)
-val lookup_name_as_renamed  : env -> constr -> identifier -> int option
+val lookup_name_as_displayed  : env -> constr -> identifier -> int option
 val lookup_index_as_renamed : env -> constr -> int -> int option
 
 val set_detype_anonymous : (loc -> int -> rawconstr) -> unit
@@ -54,7 +54,7 @@ val synthetize_type : unit -> bool
 (* Utilities to transform kernel cases to simple pattern-matching problem *)
 
 val it_destRLambda_or_LetIn_names : int -> rawconstr -> name list * rawconstr
-val simple_cases_matrix_of_branches : 
+val simple_cases_matrix_of_branches :
   inductive -> int list -> rawconstr list -> cases_clauses
 val return_type_of_predicate :
   inductive -> int -> int -> rawconstr -> predicate_pattern * rawconstr option
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 18e79e85..c1922d5d 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarconv.ml 12268 2009-08-11 09:02:16Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -17,15 +17,13 @@ open Reduction
 open Reductionops
 open Termops
 open Environ
-open Typing
-open Classops
-open Recordops 
+open Recordops
 open Evarutil
 open Libnames
 open Evd
 
 type flex_kind_of_term =
-  | Rigid of constr 
+  | Rigid of constr
   | MaybeFlexible of constr
   | Flexible of existential
 
@@ -52,7 +50,7 @@ let eval_flexible_term env c =
   | _ -> assert false
 
 let evar_apprec env evd stack c =
-  let sigma = evars_of evd in
+  let sigma =  evd in
   let rec aux s =
     let (t,stack) = whd_betaiota_deltazeta_for_iota_state env sigma s in
     match kind_of_term t with
@@ -62,7 +60,7 @@ let evar_apprec env evd stack c =
   in aux (c, append_stack_list stack empty_stack)
 
 let apprec_nohdbeta env evd c =
-  match kind_of_term (fst (Reductionops.whd_stack (evars_of evd) c)) with
+  match kind_of_term (fst (Reductionops.whd_stack evd c)) with
     | (Case _ | Fix _) -> applist (evar_apprec env evd [] c)
     | _ -> c
 
@@ -93,31 +91,31 @@ let position_problem l2r = function
 let check_conv_record (t1,l1) (t2,l2) =
   try
     let proji = global_of_constr t1 in
-    let canon_s,l2_effective = 
+    let canon_s,l2_effective =
       try
 	match kind_of_term t2 with
 	    Prod (_,a,b) -> (* assert (l2=[]); *)
       	      if dependent (mkRel 1) b then raise Not_found
 	      else lookup_canonical_conversion (proji, Prod_cs),[a;pop b]
-	  | Sort s -> 
-	      lookup_canonical_conversion 
+	  | Sort s ->
+	      lookup_canonical_conversion
 		(proji, Sort_cs (family_of_sort s)),[]
-	  | _ -> 
+	  | _ ->
 	      let c2 = global_of_constr t2 in
 		lookup_canonical_conversion (proji, Const_cs c2),l2
-      with Not_found -> 
+      with Not_found ->
 	lookup_canonical_conversion (proji,Default_cs),[]
     in
-    let { o_DEF = c; o_INJ=n; o_TABS = bs; 
+    let { o_DEF = c; o_INJ=n; o_TABS = bs;
           o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in
     let params1, c1, extra_args1 =
-      match list_chop nparams l1 with 
+      match list_chop nparams l1 with
 	| params1, c1::extra_args1 -> params1, c1, extra_args1
 	| _ -> raise Not_found in
     let us2,extra_args2 = list_chop (List.length us) l2_effective in
     c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1,
     (n,applist(t2,l2))
-  with Failure _ | Not_found -> 
+  with Failure _ | Not_found ->
     raise Not_found
 
 (* Precondition: one of the terms of the pb is an uninstantiated evar,
@@ -156,21 +154,21 @@ let ise_array2 evd f v1 v2 =
     | n ->
         let (i',b) = f i v1.(n) v2.(n) in
         if b then allrec i' (n-1) else (evd,false)
-  in 
+  in
   let lv1 = Array.length v1 in
-  if lv1 = Array.length v2 then allrec evd (pred lv1) 
+  if lv1 = Array.length v2 then allrec evd (pred lv1)
   else (evd,false)
 
-let rec evar_conv_x env evd pbty term1 term2 = 
-  let sigma = evars_of evd in
-  let term1 = whd_castappevar sigma term1 in
-  let term2 = whd_castappevar sigma term2 in
+let rec evar_conv_x env evd pbty term1 term2 =
+  let sigma =  evd in
+  let term1 = whd_head_evar sigma term1 in
+  let term2 = whd_head_evar sigma term2 in
   (* Maybe convertible but since reducing can erase evars which [evar_apprec]
      could have found, we do it only if the terms are free of evar.
      Note: incomplete heuristic... *)
   let ground_test =
     if is_ground_term evd term1 && is_ground_term evd term2 then
-      if is_fconv pbty env (evars_of evd) term1 term2 then
+      if is_fconv pbty env evd term1 term2 then
         Some true
       else if is_ground_env evd env then Some false
       else None
@@ -191,11 +189,11 @@ let rec evar_conv_x env evd pbty term1 term2 =
             (decompose_app term1) (decompose_app term2)
 
 and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
-  (* Evar must be undefined since we have whd_ised *)
+  (* Evar must be undefined since we have flushed evars *)
   match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with
     | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
 	let f1 i =
-	  if List.length l1 > List.length l2 then 
+	  if List.length l1 > List.length l2 then
             let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
             ise_and i
               [(fun i -> solve_simple_eqn evar_conv_x env i
@@ -212,23 +210,23 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	and f2 i =
           if sp1 = sp2 then
             ise_and i
-            [(fun i -> ise_list2 i 
+            [(fun i -> ise_list2 i
                   (fun i -> evar_conv_x env i CONV) l1 l2);
              (fun i -> solve_refl evar_conv_x env i sp1 al1 al2,
                   true)]
           else (i,false)
-	in 
+	in
 	ise_try evd [f1; f2]
 
     | Flexible ev1, MaybeFlexible flex2 ->
 	let f1 i =
-	  if 
-	    is_unification_pattern_evar env ev1 l1 (applist appr2) & 
+	  if
+	    is_unification_pattern_evar env ev1 l1 (applist appr2) &
 	    not (occur_evar (fst ev1) (applist appr2))
 	  then
 	    (* Miller-Pfenning's patterns unification *)
 	    (* Preserve generality (except that CCI has no eta-conversion) *)
-	    let t2 = nf_evar (evars_of evd) (applist appr2) in
+	    let t2 = nf_evar evd (applist appr2) in
 	    let t2 = solve_pattern_eqn env l1 t2 in
 	    solve_simple_eqn evar_conv_x env evd
 	      (position_problem true pbty,ev1,t2)
@@ -250,18 +248,18 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	    | Some v2 ->
 		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
 	    | None -> (i,false)
-	in 
+	in
 	ise_try evd [f1; f4]
 
     | MaybeFlexible flex1, Flexible ev2 ->
 	let f1 i =
-	  if 
-	    is_unification_pattern_evar env ev2 l2 (applist appr1) & 
+	  if
+	    is_unification_pattern_evar env ev2 l2 (applist appr1) &
 	    not (occur_evar (fst ev2) (applist appr1))
 	  then
 	    (* Miller-Pfenning's patterns unification *)
 	    (* Preserve generality (except that CCI has no eta-conversion) *)
-	    let t1 = nf_evar (evars_of evd) (applist appr1) in
+	    let t1 = nf_evar evd (applist appr1) in
 	    let t1 = solve_pattern_eqn env l2 t1 in
 	    solve_simple_eqn evar_conv_x env evd
 	      (position_problem false pbty,ev2,t1)
@@ -282,7 +280,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	    | Some v1 ->
 		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
 	    | None -> (i,false)
-	in 
+	in
 	ise_try evd [f1; f4]
 
     | MaybeFlexible flex1, MaybeFlexible flex2 ->
@@ -301,7 +299,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
              if the first argument is a beta-redex (expand a constant
              only if necessary) or the second argument is potentially
              usable as a canonical projection *)
-	  if isLambda flex1 or is_open_canonical_projection (evars_of i) appr2
+	  if isLambda flex1 or is_open_canonical_projection i appr2
 	  then
 	    match eval_flexible_term env flex1 with
 	    | Some v1 ->
@@ -320,17 +318,17 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 		| Some v1 ->
 		    evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
 		| None -> (i,false)
-	in 
+	in
 	ise_try evd [f1; f2; f3]
 
     | Flexible ev1, Rigid _ ->
-	if 
-	  is_unification_pattern_evar env ev1 l1 (applist appr2) & 
+	if
+	  is_unification_pattern_evar env ev1 l1 (applist appr2) &
 	  not (occur_evar (fst ev1) (applist appr2))
 	then
 	  (* Miller-Pfenning's patterns unification *)
 	  (* Preserve generality (except that CCI has no eta-conversion) *)
-	  let t2 = nf_evar (evars_of evd) (applist appr2) in
+	  let t2 = nf_evar evd (applist appr2) in
 	  let t2 = solve_pattern_eqn env l1 t2 in
 	  solve_simple_eqn evar_conv_x env evd
 	    (position_problem true pbty,ev1,t2)
@@ -340,13 +338,13 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	  true
 
     | Rigid _, Flexible ev2 ->
-	if 
-	  is_unification_pattern_evar env ev2 l2 (applist appr1) & 
+	if
+	  is_unification_pattern_evar env ev2 l2 (applist appr1) &
 	  not (occur_evar (fst ev2) (applist appr1))
 	then
 	  (* Miller-Pfenning's patterns unification *)
 	  (* Preserve generality (except that CCI has no eta-conversion) *)
-	  let t1 = nf_evar (evars_of evd) (applist appr1) in
+	  let t1 = nf_evar evd (applist appr1) in
 	  let t1 = solve_pattern_eqn env l2 t1 in
 	  solve_simple_eqn evar_conv_x env evd
 	    (position_problem false pbty,ev2,t1)
@@ -364,11 +362,11 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	    | Some v1 ->
  		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
 	    | None -> (i,false)
-	in 
+	in
 	ise_try evd [f3; f4]
-	     
-    | Rigid _ , MaybeFlexible flex2 -> 
-	let f3 i = 
+
+    | Rigid _ , MaybeFlexible flex2 ->
+	let f3 i =
 	  (try conv_record env i (check_conv_record appr2 appr1)
            with Not_found -> (i,false))
 	and f4 i =
@@ -376,11 +374,11 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	    | Some v2 ->
  		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
 	    | None -> (i,false)
-	in 
+	in
 	ise_try evd [f3; f4]
 
     | Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with
-	  
+
 	| Cast (c1,_,_), _ -> evar_eqappr_x env evd pbty (c1,l1) appr2
 
 	| _, Cast (c2,_,_) -> evar_eqappr_x env evd pbty appr1 (c2,l2)
@@ -388,11 +386,11 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	| Sort s1, Sort s2 when l1=[] & l2=[] ->
             (evd,base_sort_cmp pbty s1 s2)
 
-	| Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> 
+	| Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] ->
             ise_and evd
               [(fun i -> evar_conv_x env i CONV c1 c2);
                (fun i ->
-                 let c = nf_evar (evars_of i) c1 in
+                 let c = nf_evar i c1 in
                  evar_conv_x (push_rel (na,None,c) env) i CONV c'1 c'2)]
 
 	| LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) ->
@@ -400,8 +398,8 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
               ise_and i
                 [(fun i -> evar_conv_x env i CONV b1 b2);
                  (fun i ->
-                   let b = nf_evar (evars_of i) b1 in
-	           let t = nf_evar (evars_of i) t1 in
+                   let b = nf_evar i b1 in
+	           let t = nf_evar i t1 in
                    evar_conv_x (push_rel (na,Some b,t) env) i pbty c'1 c'2);
                  (fun i -> ise_list2 i
                      (fun i -> evar_conv_x env i CONV) l1 l2)]
@@ -409,7 +407,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
               let appr1 = evar_apprec env i l1 (subst1 b1 c'1)
               and appr2 = evar_apprec env i l2 (subst1 b2 c'2)
 	      in evar_eqappr_x env i pbty appr1 appr2
-	    in 
+	    in
 	    ise_try evd [f1; f2]
 
 	| LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *)
@@ -420,20 +418,20 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	    let appr2 = evar_apprec env evd l2 (subst1 b2 c'2)
             in evar_eqappr_x env evd pbty appr1 appr2
 
-	| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> 
+	| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] ->
             ise_and evd
               [(fun i -> evar_conv_x env i CONV c1 c2);
                (fun i ->
- 	         let c = nf_evar (evars_of i) c1 in
+ 	         let c = nf_evar i c1 in
 	         evar_conv_x (push_rel (n,None,c) env) i pbty c'1 c'2)]
 
 	| Ind sp1, Ind sp2 ->
-	    if sp1=sp2 then
+	    if eq_ind sp1 sp2 then
               ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2
             else (evd, false)
 
 	| Construct sp1, Construct sp2 ->
-	    if sp1=sp2 then
+	    if eq_constructor sp1 sp2 then
               ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2
             else (evd, false)
 
@@ -474,13 +472,13 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
 	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> (evd,false)
 	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> (evd,false)
 
-	| (App _ | Case _ | Fix _ | CoFix _), 
+	| (App _ | Case _ | Fix _ | CoFix _),
 	  (App _ | Case _ | Fix _ | CoFix _) -> (evd,false)
 
 	| (Rel _ | Var _ | Const _ | Evar _), _ -> assert false
 	| _, (Rel _ | Var _ | Const _ | Evar _) -> assert false
 
-and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = 
+and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
   let (evd',ks,_) =
     List.fold_left
       (fun (i,ks,m) b ->
@@ -492,15 +490,15 @@ and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
   in
   ise_and evd'
     [(fun i ->
-      ise_list2 i
-        (fun i u1 u -> evar_conv_x env i CONV u1 (substl ks u))
-        us2 us);
-     (fun i ->
        ise_list2 i
          (fun i x1 x -> evar_conv_x env i CONV x1 (substl ks x))
          params1 params);
-     (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) ts ts1);
-     (fun i -> evar_conv_x env i CONV c1 (applist (c,(List.rev ks))))]
+    (fun i ->
+      ise_list2 i
+        (fun i u1 u -> evar_conv_x env i CONV u1 (substl ks u))
+        us2 us);
+    (fun i -> evar_conv_x env i CONV c1 (applist (c,(List.rev ks))));
+    (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) ts ts1)]
 
 (* We assume here |l1| <= |l2| *)
 
@@ -518,15 +516,15 @@ let first_order_unification env evd (ev1,l1) (term2,l2) =
 	solve_simple_eqn ~choose:true evar_conv_x env i (None,ev1,t2))]
 
 let choose_less_dependent_instance evk evd term args =
-  let evi = Evd.find (evars_of evd) evk in
+  let evi = Evd.find evd evk in
   let subst = make_pure_subst evi args in
   let subst' = List.filter (fun (id,c) -> c = term) subst in
   if subst' = [] then error "Too complex unification problem." else
-  Evd.evar_define evk (mkVar (fst (List.hd subst'))) evd
+  Evd.define evk (mkVar (fst (List.hd subst'))) evd
 
 let apply_conversion_problem_heuristic env evd pbty t1 t2 =
-  let t1 = apprec_nohdbeta env evd (whd_castappevar (evars_of evd) t1) in
-  let t2 = apprec_nohdbeta env evd (whd_castappevar (evars_of evd) t2) in
+  let t1 = apprec_nohdbeta env evd (whd_head_evar evd t1) in
+  let t2 = apprec_nohdbeta env evd (whd_head_evar evd t2) in
   let (term1,l1 as appr1) = decompose_app t1 in
   let (term2,l2 as appr2) = decompose_app t2 in
   match kind_of_term term1, kind_of_term term2 with
@@ -535,7 +533,7 @@ let apply_conversion_problem_heuristic env evd pbty t1 t2 =
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
       choose_less_dependent_instance evk1 evd term2 args1, true
-  | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] 
+  | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = []
       & array_for_all (fun a -> a = term1 or isEvar a) args2 ->
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
@@ -569,7 +567,7 @@ let the_conv_x_leq env t1 t2 evd =
   match evar_conv_x env evd CUMUL t1 t2 with
       (evd', true) -> evd'
     | _ -> raise Reduction.NotConvertible
- 
+
 let e_conv env evd t1 t2 =
   match evar_conv_x env !evd CONV t1 t2 with
       (evd',true) -> evd := evd'; true
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index f92a6fdb..9a4247bc 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarconv.mli 9141 2006-09-15 10:07:01Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -17,21 +17,27 @@ open Evd
 (*i*)
 
 (* returns exception Reduction.NotConvertible if not unifiable *)
-val the_conv_x     : env -> constr -> constr -> evar_defs -> evar_defs
-val the_conv_x_leq : env -> constr -> constr -> evar_defs -> evar_defs
+val the_conv_x     : env -> constr -> constr -> evar_map -> evar_map
+val the_conv_x_leq : env -> constr -> constr -> evar_map -> evar_map
 
-(* The same function resolving evars by side-effect and 
+(* The same function resolving evars by side-effect and
    catching the exception *)
-val e_conv  : env -> evar_defs ref -> constr -> constr -> bool
-val e_cumul : env -> evar_defs ref -> constr -> constr -> bool
+val e_conv  : env -> evar_map ref -> constr -> constr -> bool
+val e_cumul : env -> evar_map ref -> constr -> constr -> bool
 
 (*i For debugging *)
 val evar_conv_x :
-  env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool
-val evar_eqappr_x : 
-  env -> evar_defs ->
+  env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool
+val evar_eqappr_x :
+  env -> evar_map ->
     conv_pb -> constr * constr list -> constr * constr list ->
-      evar_defs * bool
+      evar_map * bool
 (*i*)
 
-val consider_remaining_unif_problems : env -> evar_defs -> evar_defs * bool
+val consider_remaining_unif_problems : env -> evar_map -> evar_map * bool
+
+val check_conv_record : constr * types list -> constr * types list ->
+  constr * constr list * (constr list * constr list) *
+    (constr list * types list) *
+    (constr list * types list) * constr *
+    (int * constr)
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index fbaac79b..2b218da6 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -6,15 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarutil.ml 13116 2010-06-12 15:18:07Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Pp
 open Names
-open Nameops
 open Univ
 open Term
 open Termops
+open Namegen
 open Sign
 open Pre_env
 open Environ
@@ -23,33 +23,21 @@ open Reductionops
 open Pretype_errors
 open Retyping
 
-(* Expanding existential variables (pretyping.ml) *)
-(* 1- whd_ise fails if an existential is undefined *)
+open Pretype_errors
+open Retyping
+
+(* Expanding existential variables *)
+(* 1- flush_and_check_evars fails if an existential is undefined *)
 
 exception Uninstantiated_evar of existential_key
 
-let rec whd_ise sigma c =
+let rec flush_and_check_evars sigma c =
   match kind_of_term c with
-    | Evar (evk,args as ev) when Evd.mem sigma evk ->
-	if Evd.is_defined sigma evk then
-          whd_ise sigma (existential_value sigma ev)
-	else raise (Uninstantiated_evar evk)
-  | _ -> c
-
-
-(* Expand evars, possibly in the head of an application *)
-let whd_castappevar_stack sigma c = 
-  let rec whrec (c, l as s) =
-    match kind_of_term c with
-      | Evar (evk,args as ev) when Evd.mem sigma evk & Evd.is_defined sigma evk
-	  -> whrec (existential_value sigma ev, l)
-      | Cast (c,_,_) -> whrec (c, l)
-      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
-      | _ -> s
-  in 
-  whrec (c, [])
-
-let whd_castappevar sigma c = applist (whd_castappevar_stack sigma c)
+  | Evar (evk,_ as ev) ->
+      (match existential_opt_value sigma ev with
+       | None -> raise (Uninstantiated_evar evk)
+       | Some c -> flush_and_check_evars sigma c)
+  | _ -> map_constr (flush_and_check_evars sigma) c
 
 let nf_evar = Pretype_errors.nf_evar
 let j_nf_evar = Pretype_errors.j_nf_evar
@@ -57,32 +45,29 @@ let jl_nf_evar = Pretype_errors.jl_nf_evar
 let jv_nf_evar = Pretype_errors.jv_nf_evar
 let tj_nf_evar = Pretype_errors.tj_nf_evar
 
-let nf_named_context_evar sigma ctx = 
+let nf_named_context_evar sigma ctx =
   Sign.map_named_context (Reductionops.nf_evar sigma) ctx
 
-let nf_rel_context_evar sigma ctx = 
+let nf_rel_context_evar sigma ctx =
   Sign.map_rel_context (Reductionops.nf_evar sigma) ctx
-    
-let nf_env_evar sigma env = 
+
+let nf_env_evar sigma env =
   let nc' = nf_named_context_evar sigma (Environ.named_context env) in
   let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in
     push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env)
 
 let nf_evar_info evc info =
-  { info with 
+  { info with
     evar_concl = Reductionops.nf_evar evc info.evar_concl;
-    evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps}
+    evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps;
+    evar_body = match info.evar_body with
+      | Evar_empty -> Evar_empty
+      | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) }
 
 let nf_evars evm = Evd.fold (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
 		     evm Evd.empty
 
-let nf_evar_defs evd = Evd.evars_reset_evd (nf_evars (Evd.evars_of evd)) evd
-
-let nf_isevar evd = nf_evar (Evd.evars_of evd)
-let j_nf_isevar evd = j_nf_evar (Evd.evars_of evd)
-let jl_nf_isevar evd = jl_nf_evar (Evd.evars_of evd)
-let jv_nf_isevar evd = jv_nf_evar (Evd.evars_of evd)
-let tj_nf_isevar evd = tj_nf_evar (Evd.evars_of evd)
+let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd
 
 (**********************)
 (* Creating new metas *)
@@ -107,25 +92,25 @@ let collect_evars emap c =
 
 let push_dependent_evars sigma emap =
   Evd.fold (fun ev {evar_concl = ccl} (sigma',emap') ->
-    List.fold_left 
-      (fun (sigma',emap') ev -> 
+    List.fold_left
+      (fun (sigma',emap') ev ->
 	(Evd.add sigma' ev (Evd.find emap' ev),Evd.remove emap' ev))
       (sigma',emap') (collect_evars emap' ccl))
     emap (sigma,emap)
 
-let push_duplicated_evars sigma emap c	=
+let push_duplicated_evars sigma emap c =
   let rec collrec (one,(sigma,emap) as acc) c =
     match kind_of_term c with
     | Evar (evk,_) when not (Evd.mem sigma evk) ->
-       if List.mem evk one then
-         let sigma' = Evd.add sigma evk (Evd.find emap	evk) in
-         let emap' = Evd.remove emap evk in
-         (one,(sigma',emap'))
-       else
-         (evk::one,(sigma,emap))
+	if List.mem evk one then
+	  let sigma' = Evd.add sigma evk (Evd.find emap evk) in
+	  let emap' = Evd.remove emap evk in
+	  (one,(sigma',emap'))
+	else
+	  (evk::one,(sigma,emap))
     | _ ->
-       fold_constr collrec acc	c
-  in   
+	fold_constr collrec acc c
+  in
   snd (collrec ([],(sigma,emap)) c)
 
 (* replaces a mapping of existentials into a mapping of metas.
@@ -146,11 +131,11 @@ let evars_to_metas sigma (emap, c) =
 
 (* The list of non-instantiated existential declarations *)
 
-let non_instantiated sigma = 
+let non_instantiated sigma =
   let listev = to_list sigma in
-  List.fold_left 
-    (fun l (ev,evi) -> 
-       if evi.evar_body = Evar_empty then 
+  List.fold_left
+    (fun l (ev,evi) ->
+       if evi.evar_body = Evar_empty then
 	 ((ev,nf_evar_info sigma evi)::l) else l)
     [] listev
 
@@ -179,6 +164,79 @@ let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter insta
   let evd = evar_declare sign newevk typ ~src:src ?filter evd in
   (evd,mkEvar (newevk,Array.of_list instance))
 
+(* Expand rels and vars that are bound to other rels or vars so that
+   dependencies in variables are canonically associated to the most ancient
+   variable in its family of aliased variables *)
+
+let compute_aliases sign =
+  List.fold_right (fun (id,b,c) aliases ->
+    match b with
+    | Some t ->
+	(match kind_of_term t with
+	| Var id' ->
+	    let id'' = try Idmap.find id' aliases with Not_found -> id' in
+	    Idmap.add id id'' aliases
+	| _ -> aliases)
+    | None -> aliases) sign Idmap.empty
+
+let alias_of_var id aliases = try Idmap.find id aliases with Not_found -> id
+
+let make_alias_map env =
+  let var_aliases = compute_aliases (named_context env) in
+  let rels = rel_context env in
+  let rel_aliases = 
+    snd (List.fold_right (fun (_,b,t) (n,aliases) ->
+      (n-1,
+      match b with
+	| Some t when isRel t or isVar t -> Intmap.add n (lift n t) aliases
+	| _ -> aliases)) rels (List.length rels,Intmap.empty)) in
+  (var_aliases,rel_aliases)
+
+let expand_var_once aliases x = match kind_of_term x with
+  | Rel n -> Intmap.find n (snd aliases)
+  | Var id -> mkVar (Idmap.find id (fst aliases))
+  | _ -> raise Not_found
+
+let rec expand_var_at_least_once aliases x =
+  let t = expand_var_once aliases x in
+  try expand_var_at_least_once aliases t
+  with Not_found -> t
+
+let expand_var aliases x =
+  try expand_var_at_least_once aliases x with Not_found -> x
+
+let expand_var_opt aliases x =
+  try Some (expand_var_at_least_once aliases x) with Not_found -> None
+
+let extend_alias (_,b,_) (var_aliases,rel_aliases) =
+  let rel_aliases =
+    Intmap.fold (fun n c -> Intmap.add (n+1) (lift 1 c))
+      rel_aliases Intmap.empty in
+  let rel_aliases =
+    match b with
+    | Some t when isRel t or isVar t -> Intmap.add 1 (lift 1 t) rel_aliases
+    | _ -> rel_aliases in
+  (var_aliases, rel_aliases)
+
+let rec expand_vars_in_term_using aliases t = match kind_of_term t with
+  | Rel _ | Var _ ->
+      expand_var aliases t
+  | _ ->
+      map_constr_with_full_binders
+	extend_alias expand_vars_in_term_using aliases t
+
+let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env)
+
+let rec expansions_of_var aliases x =
+  try
+    let t = expand_var_once aliases x in
+    t :: expansions_of_var aliases t
+  with Not_found ->
+    [x]
+
+let expand_full_opt aliases y =
+  try Some (expand_var aliases y) with Not_found -> None
+
 (* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
  * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
  * If a variable and an alias of it are bound to the same instance, we skip
@@ -189,20 +247,28 @@ let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter insta
  * useful to ensure the uniqueness of a projection.
 *)
 
-let make_projectable_subst sigma evi args =
+let make_projectable_subst aliases sigma evi args =
   let sign = evar_filtered_context evi in
-  let rec alias_of_var id = 
-    match pi2 (Sign.lookup_named id sign) with
-    | Some t when isVar t -> alias_of_var (destVar t)
-    | _ -> id in
+  let evar_aliases = compute_aliases sign in
   snd (List.fold_right
     (fun (id,b,c) (args,l) ->
       match b,args with
-	| Some c, a::rest when
-	    isVar c & (try eq_constr a (snd (List.assoc (destVar c) l)) with Not_found -> false) -> (rest,l)
-	| _, a::rest -> (rest, (id, (alias_of_var id,whd_evar sigma a))::l)
+	| None, a::rest ->
+	    let a = whd_evar sigma a in
+	    (rest,Idmap.add id [a,expand_full_opt aliases a,id] l)
+	| Some c, a::rest ->
+	    let a = whd_evar sigma a in
+	    (match kind_of_term c with
+	    | Var id' ->
+		let idc = alias_of_var id' evar_aliases in
+		let sub = try Idmap.find idc l with Not_found -> [] in
+		if List.exists (fun (c,_,_) -> eq_constr a c) sub then (rest,l)
+		else
+		  (rest,Idmap.add idc ((a,expand_full_opt aliases a,id)::sub) l)
+	    | _ ->
+		(rest,Idmap.add id [a,expand_full_opt aliases a,id] l))
 	| _ -> anomaly "Instance does not match its signature")
-    sign (List.rev (Array.to_list args),[]))
+    sign (array_rev_to_list args,Idmap.empty))
 
 let make_pure_subst evi args =
   snd (List.fold_right
@@ -210,16 +276,16 @@ let make_pure_subst evi args =
       match args with
 	| a::rest -> (rest, (id,a)::l)
 	| _ -> anomaly "Instance does not match its signature")
-    (evar_filtered_context evi) (List.rev (Array.to_list args),[]))
+    (evar_filtered_context evi) (array_rev_to_list args,[]))
 
 (* [push_rel_context_to_named_context] builds the defining context and the
  * initial instance of an evar. If the evar is to be used in context
- * 
+ *
  * Gamma =  a1     ...    an xp      ...       x1
  *          \- named part -/ \- de Bruijn part -/
- * 
+ *
  * then the x1...xp are turned into variables so that the evar is declared in
- * context 
+ * context
  *
  *          a1     ...    an xp      ...       x1
  *          \----------- named part ------------/
@@ -227,16 +293,17 @@ let make_pure_subst evi args =
  * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)"
  * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed
  * in context Gamma.
- * 
+ *
  * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first)
  * Remark 2: If some of the ai or xj are definitions, we keep them in the
  *   instance. This is necessary so that no unfolding of local definitions
  *   happens when inferring implicit arguments (consider e.g. the problem
- *   "x:nat; x':=x; f:forall x, x=x -> Prop |- f _ (refl_equal x')"
- *   we want the hole to be instantiated by x', not by x (which would have the
- *   case in [invert_instance] if x' had disappear of the instance).
+ *   "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which
+ *   produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want
+ *   the hole to be instantiated by x', not by x (which would have been
+ *   the case in [invert_definition] if x' had disappeared from the instance).
  *   Note that at any time, if, in some context env, the instance of
- *   declaration x:A is t and the instance of definition x':=phi(x) is u, then 
+ *   declaration x:A is t and the instance of definition x':=phi(x) is u, then
  *   we have the property that u and phi(t) are convertible in env.
  *)
 
@@ -256,7 +323,7 @@ let push_rel_context_to_named_context env typ =
 	(mkVar id :: subst, id::avoid, push_named d env))
       (rel_context env) ~init:([], ids, env) in
   (named_context_val env, substl subst typ, inst_rels@inst_vars)
-      
+
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
 
@@ -274,10 +341,6 @@ let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ty =
  * operations on the evar constraints *
  *------------------------------------*)
 
-let is_pattern inst =
-  array_for_all (fun a -> isRel a || isVar a) inst &&
-  array_distinct inst
-
 (* Pb: defined Rels and Vars should not be considered as a pattern... *)
 (*
 let is_pattern inst =
@@ -288,23 +351,10 @@ let is_pattern inst =
   is_hopat [] (Array.to_list inst)
 *)
 
-let evar_well_typed_body evd ev evi body =
-  try
-    let env = evar_unfiltered_env evi in
-    let ty = evi.evar_concl in
-    Typing.check env (evars_of evd) body ty;
-    true
-  with e ->
-    pperrnl
-      (str "Ill-typed evar instantiation: " ++ fnl() ++
-       pr_evar_defs evd ++ fnl() ++
-       str "----> " ++ int ev ++ str " := " ++
-       print_constr body);
-    false
-
-(* We have x1..xq |- ?e1 and had to solve something like 
- * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some 
- * ?e2[v1..vn], hence flexible. We had to go through k binders and now 
+
+(* We have x1..xq |- ?e1 and had to solve something like
+ * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some
+ * ?e2[v1..vn], hence flexible. We had to go through k binders and now
  * virtually have x1..xq, y1..yk | ?e1' and the equation
  * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c.
  * What we do is to formally introduce ?e1' in context x1..xq, Γ, y1..yk,
@@ -313,10 +363,10 @@ let evar_well_typed_body evd ev evi body =
  *
  * In fact, we optimize a little and try to compute a maximum
  * common subpart of x1..xq and Γ. This is done by detecting the
- * longest subcontext x1..xp such that Γ = x1'..xp' z1..zm and 
+ * longest subcontext x1..xp such that Γ = x1'..xp' z1..zm and
  * u1..up = x1'..xp'.
  *
- * At the end, we return ?e1'[x1..xn z1..zm y1..yk] so that ?e1 can be 
+ * At the end, we return ?e1'[x1..xn z1..zm y1..yk] so that ?e1 can be
  * instantiated by (...\y1 ... \yk ... ?e1[x1..xn z1..zm y1..yk]) and the
  * new problem is Σ; Γ, y1..yk |- ?e1'[u1..un z1..zm y1..yk] = c,
  * making the z1..zm unavailable.
@@ -330,10 +380,10 @@ let shrink_context env subst ty =
   (* We merge the contexts (optimization) *)
   let rec shrink_rel i subst rel_subst rev_rel_sign =
     match subst,rev_rel_sign with
-    | (id,c)::subst,_::rev_rel_sign when c = mkRel i -> 
+    | (id,c)::subst,_::rev_rel_sign when c = mkRel i ->
 	shrink_rel (i-1) subst (mkVar id::rel_subst) rev_rel_sign
     | _ ->
-	substl_rel_context rel_subst (List.rev rev_rel_sign), 
+	substl_rel_context rel_subst (List.rev rev_rel_sign),
 	substl rel_subst ty
   in
   let rec shrink_named subst named_subst rev_named_sign =
@@ -352,13 +402,13 @@ let shrink_context env subst ty =
   shrink_named subst [] rev_named_sign
 
 let extend_evar env evdref k (evk1,args1) c =
-  let ty = get_type_of env (evars_of !evdref) c in
+  let ty = get_type_of env !evdref c in
   let overwrite_first v1 v2 =
     let v = Array.copy v1 in
     let n = Array.length v - Array.length v2 in
     for i = 0 to Array.length v2 - 1 do v.(n+i) <- v2.(i) done;
     v in
-  let evi1 = Evd.find (evars_of !evdref) evk1 in
+  let evi1 = Evd.find !evdref evk1 in
   let named_sign',rel_sign',ty =
     if k = 0 then [], [], ty
     else shrink_context env (List.rev (make_pure_subst evi1 args1)) ty in
@@ -378,7 +428,7 @@ let extend_evar env evdref k (evk1,args1) c =
 let subfilter p filter l =
   let (filter,_,l) =
     List.fold_left (fun (filter,l,newl) b ->
-      if b then 
+      if b then
 	let a,l' = match l with a::args -> a,args | _ -> assert false in
 	if p a then (true::filter,l',a::newl) else (false::filter,l',newl)
       else (false::filter,l,newl))
@@ -391,7 +441,7 @@ let restrict_upon_filter evd evi evk p args =
   if newfilter <> filter then
     let (evd,newev) = new_evar evd (evar_unfiltered_env evi) ~src:(evar_source evk evd)
 	~filter:newfilter evi.evar_concl in
-    let evd = Evd.evar_define evk newev evd in
+    let evd = Evd.define evk newev evd in
     evd,fst (destEvar newev),newargs
   else
     evd,evk,args
@@ -414,10 +464,10 @@ let rec check_and_clear_in_constr evdref err ids c =
   (* returns a new constr where all the evars have been 'cleaned'
      (ie the hypotheses ids have been removed from the contexts of
      evars) *)
-  let check id' = 
+  let check id' =
     if List.mem id' ids then
       raise (ClearDependencyError (id',err))
-  in 
+  in
     match kind_of_term c with
       | Var id' ->
 	  check id'; c
@@ -426,25 +476,25 @@ let rec check_and_clear_in_constr evdref err ids c =
           let vars = Environ.vars_of_global (Global.env()) c in
             List.iter check vars; c
 
-      | Evar (evk,l as ev) -> 
+      | Evar (evk,l as ev) ->
 	  if Evd.is_defined_evar !evdref ev then
 	    (* If evk is already defined we replace it by its definition *)
-	    let nc = whd_evar (evars_of !evdref) c in 
+	    let nc = whd_evar !evdref c in
 	      (check_and_clear_in_constr evdref err ids nc)
-	  else 
+	  else
 	    (* We check for dependencies to elements of ids in the
 	       evar_info corresponding to e and in the instance of
 	       arguments. Concurrently, we build a new evar
 	       corresponding to e where hypotheses of ids have been
 	       removed *)
-	    let evi = Evd.find (evars_of !evdref) evk in
+	    let evi = Evd.find !evdref evk in
 	    let ctxt = Evd.evar_filtered_context evi in
 	    let (nhyps,nargs,rids) =
-	      List.fold_right2 
+	      List.fold_right2
 		(fun (rid,ob,c as h) a (hy,ar,ri) ->
 		  (* Check if some id to clear occurs in the instance
 		     a of rid in ev and remember the dependency *)
-		  match 
+		  match
 		    List.filter (fun id -> List.mem id ids) (collect_vars a)
 		  with
 		  | id :: _ -> (hy,ar,(rid,id)::ri)
@@ -462,15 +512,17 @@ let rec check_and_clear_in_constr evdref err ids c =
 	       in the type of ev and adjust the source of the dependency *)
 	    let nconcl =
 	      try check_and_clear_in_constr evdref (EvarTypingBreak ev)
-		    (List.map fst rids) (evar_concl evi) 
-	      with ClearDependencyError (rid,err) -> 
+		    (List.map fst rids) (evar_concl evi)
+	      with ClearDependencyError (rid,err) ->
 		raise (ClearDependencyError (List.assoc rid rids,err)) in
 
-	    let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
-	    let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in
-	      evdref := Evd.evar_define evk ev' !evdref;
+            if rids = [] then c else begin
+	      let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
+	      let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in
+	      evdref := Evd.define evk ev' !evdref;
 	      let (evk',_) = destEvar ev' in
-		mkEvar(evk', Array.of_list nargs)
+	      mkEvar(evk', Array.of_list nargs)
+            end
 
       | _ -> map_constr (check_and_clear_in_constr evdref err ids) c
 
@@ -480,7 +532,7 @@ let clear_hyps_in_evi evdref hyps concl ids =
      the contexts of the evars occuring in evi *)
   let nconcl =
     check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in
-  let nhyps = 
+  let nhyps =
     let check_context (id,ob,c) =
       let err = OccurHypInSimpleClause (Some id) in
       (id, Option.map (check_and_clear_in_constr evdref err ids) ob,
@@ -502,53 +554,13 @@ let clear_hyps_in_evi evdref hyps concl ids =
   (nhyps,nconcl)
 
 
-(* Expand rels and vars that are bound to other rels or vars so that 
-   dependencies in variables are canonically associated to the most ancient
-   variable in its family of aliased variables *)
-
-let expand_var_once env x = match kind_of_term x with
-  | Rel n ->
-      begin match pi2 (lookup_rel n env) with
-      | Some t when isRel t or isVar t -> lift n t
-      | _ -> raise Not_found
-      end
-  | Var id ->
-      begin match pi2 (lookup_named id env) with
-      | Some t when isVar t -> t
-      | _ -> raise Not_found
-      end
-  | _ ->
-      raise Not_found
-
-let rec expand_var_at_least_once env x =
-  let t = expand_var_once env x in
-  try expand_var_at_least_once env t
-  with Not_found -> t
-
-let expand_var env x =
-  try expand_var_at_least_once env x with Not_found -> x
-  
-let expand_var_opt env x =
-  try Some (expand_var_at_least_once env x) with Not_found -> None
-
-let rec expand_vars_in_term env t = match kind_of_term t with
-  | Rel _ | Var _ -> expand_var env t
-  | _ -> map_constr_with_full_binders push_rel expand_vars_in_term env t
-
-let rec expansions_of_var env x =
-  try 
-    let t = expand_var_once env x in
-    t :: expansions_of_var env t
-  with Not_found ->
-    [x]
-
 (* [find_projectable_vars env sigma y subst] finds all vars of [subst]
  * that project on [y]. It is able to find solutions to the following
  * two kinds of problems:
  *
  * - ?n[...;x:=y;...] = y
  * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable
- *   
+ *
  * (see test-suite/success/Fixpoint.v for an example of application of
  * the second kind of problem).
  *
@@ -577,29 +589,51 @@ let rec expansions_of_var env x =
 exception NotUnique
 exception NotUniqueInType of types
 
-type evar_projection = 
-| ProjectVar 
+type evar_projection =
+| ProjectVar
 | ProjectEvar of existential * evar_info * identifier * evar_projection
 
-let rec find_projectable_vars with_evars env sigma y subst =
-  let is_projectable (id,(idc,y')) =
-    let y' = whd_evar sigma y' in
-    if y = y' or expand_var env y = expand_var env y'
-    then (idc,(y'=y,(id,ProjectVar)))
-    else if with_evars & isEvar y' then
-      (* TODO: infer conditions for being of unifiable types *)
-      let (evk,argsv as t) = destEvar y' in
-      let evi = Evd.find sigma evk in
-      let subst = make_projectable_subst sigma evi argsv in
-      let l = find_projectable_vars with_evars env sigma y subst in
-      match l with 
-      | [id',p] -> (idc,(true,(id,ProjectEvar(t,evi,id',p))))
-      | _ -> failwith ""
-    else failwith "" in
-  let l = map_succeed is_projectable subst in
-  let l = list_partition_by (fun (idc,_) (idc',_) -> idc = idc') l in
-  let l = List.map (List.map snd) l in
-  List.map (fun l -> try List.assoc true l with Not_found -> snd (List.hd l)) l
+let rec assoc_up_to_alias sigma aliases y yc = function
+  | [] -> raise Not_found
+  | (c,cc,id)::l ->
+      let c' = whd_evar sigma c in
+      if y = c' then id
+      else
+	if l <> [] then assoc_up_to_alias sigma aliases y yc l
+	else
+	  (* Last chance, we reason up to alias conversion *)
+	  match (if c == c' then cc else expand_full_opt aliases c') with
+	  | Some cc when yc = cc -> id
+	  | _ -> raise Not_found
+
+let rec find_projectable_vars with_evars aliases sigma y subst =
+  let yc = expand_var aliases y in
+  let is_projectable idc idcl subst' =
+    (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *)
+    try
+      let id = assoc_up_to_alias sigma aliases y yc idcl in
+      (id,ProjectVar)::subst'
+    with Not_found ->
+    (* Then test if [idc] is (indirectly) bound in [subst] to some evar *)
+    (* projectable on [y] *)
+      if with_evars then
+	let idcl' = List.filter (fun (c,_,id) -> isEvar c) idcl in
+	match idcl' with
+	| [c,_,id] ->
+	  begin
+	    let (evk,argsv as t) = destEvar c in
+	    let evi = Evd.find sigma evk in
+	    let subst = make_projectable_subst aliases sigma evi argsv in
+	    let l = find_projectable_vars with_evars aliases sigma y subst in
+	    match l with
+	    | [id',p] -> (id,ProjectEvar (t,evi,id',p))::subst'
+	    | _ -> subst'
+	  end
+	| [] -> subst'
+	| _ -> anomaly "More than one non var in aliases class of evar instance"
+      else
+	subst' in
+  Idmap.fold is_projectable subst []
 
 (* [filter_solution] checks if one and only one possible projection exists
  * among a set of solutions to a projection problem *)
@@ -609,8 +643,9 @@ let filter_solution = function
   | (id,p)::_::_ -> raise NotUnique
   | [id,p] -> (mkVar id, p)
 
-let project_with_effects env sigma effects t subst =
-  let c, p = filter_solution (find_projectable_vars false env sigma t subst) in
+let project_with_effects aliases sigma effects t subst =
+  let c, p =
+    filter_solution (find_projectable_vars false aliases sigma t subst) in
   effects := p :: !effects;
   c
 
@@ -626,17 +661,17 @@ let rec find_solution_type evarenv = function
  * type is an evar too.
  *
  * Note: typing creates new evar problems, which induces a recursive dependency
- * with [evar_define]. To avoid a too large set of recursive functions, we
- * pass [evar_define] to [do_projection_effects] as a parameter.
+ * with [define]. To avoid a too large set of recursive functions, we
+ * pass [define] to [do_projection_effects] as a parameter.
  *)
 
 let rec do_projection_effects define_fun env ty evd = function
   | ProjectVar -> evd
   | ProjectEvar ((evk,argsv),evi,id,p) ->
-      let evd = Evd.evar_define evk (mkVar id) evd in
+      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 (evars_of evd) (Lazy.force ty) in
+      let ty = whd_betadeltaiota env evd (Lazy.force ty) in
       if not (isSort ty) then
 	(* Don't try to instantiate if a sort because if evar_concl is an
            evar it may commit to a univ level which is not the right
@@ -644,13 +679,13 @@ let rec do_projection_effects define_fun env ty evd = function
            unif, we know that no coercion can be inserted) *)
 	let subst = make_pure_subst evi argsv in
 	let ty' = replace_vars subst evi.evar_concl in
-	let ty' = whd_evar (evars_of evd) ty' in
+	let ty' = whd_evar evd ty' in
 	if isEvar ty' then define_fun env (destEvar ty') ty evd else evd
       else
 	evd
 
-(* Assuming Σ; Γ, y1..yk |- c, [invert_subst Γ k Σ [x1:=u1;...;xn:=un] c]
- * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid. 
+(* Assuming Σ; Γ, y1..yk |- c, [invert_arg_from_subst Γ k Σ [x1:=u1..xn:=un] c]
+ * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid.
  * The strategy is to imitate the structure of c and then to invert
  * the variables of c (i.e. rels or vars of Γ) using the algorithm
  * implemented by project_with_effects/find_projectable_vars.
@@ -658,15 +693,15 @@ let rec do_projection_effects define_fun env ty evd = function
  * 1 solutions is found.
  *
  * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
- * Postcondition: if φ(x1..xn) is returned then 
+ * Postcondition: if φ(x1..xn) is returned then
  *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
  *
  * The effects correspond to evars instantiated while trying to project.
  *
- * [invert_subst] is used on instances of evars. Since the evars are flexible,
- * these instances are potentially erasable. This is why we don't investigate
- * whether evars in the instances of evars are unifiable, to the contrary of 
- * [invert_definition].
+ * [invert_arg_from_subst] is used on instances of evars. Since the
+ * evars are flexible, these instances are potentially erasable. This
+ * is why we don't investigate whether evars in the instances of evars
+ * are unifiable, to the contrary of [invert_definition].
  *)
 
 type projectibility_kind =
@@ -677,27 +712,26 @@ type projectibility_status =
   | CannotInvert
   | Invertible of projectibility_kind
 
-let invert_arg_from_subst env k sigma subst_in_env c_in_env_extended_with_k_binders =
+let invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders =
   let effects = ref [] in
   let rec aux k t =
     let t = whd_evar sigma t in
     match kind_of_term t with
     | Rel i when i>k ->
-	project_with_effects env sigma effects (mkRel (i-k)) subst_in_env
+	project_with_effects aliases sigma effects (mkRel (i-k)) subst_in_env
     | Var id ->
-	project_with_effects env sigma effects t subst_in_env
+	project_with_effects aliases sigma effects t subst_in_env
     | _ ->
 	map_constr_with_binders succ aux k t in
-  try 
+  try
     let c = aux k c_in_env_extended_with_k_binders in
     Invertible (UniqueProjection (c,!effects))
   with
     | Not_found -> CannotInvert
     | NotUnique -> Invertible NoUniqueProjection
 
-let invert_arg env k sigma (evk,args_in_env) c_in_env_extended_with_k_binders =
-  let subst_in_env = make_projectable_subst sigma (Evd.find sigma evk) args_in_env in
-  let res = invert_arg_from_subst env k sigma subst_in_env c_in_env_extended_with_k_binders in
+let invert_arg aliases k sigma evk subst_in_env c_in_env_extended_with_k_binders =
+  let res = invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders in
   match res with
   | Invertible (UniqueProjection (c,_)) when occur_evar evk c -> CannotInvert
   | _ -> res
@@ -707,7 +741,7 @@ let effective_projections =
   map_succeed (function Invertible c -> c | _ -> failwith"")
 
 let instance_of_projection f env t evd projs =
-  let ty = lazy (Retyping.get_type_of env (evars_of evd) t) in
+  let ty = lazy (Retyping.get_type_of env evd t) in
   match projs with
   | NoUniqueProjection -> raise NotUnique
   | UniqueProjection (c,effects) ->
@@ -740,11 +774,11 @@ let restrict_hyps evd evk filter =
          occurrence of x in the hnf of C), then z should be removed too.
        - If y is in a non-erasable position in T(x,y,z) then the problem is
          unsolvable.
-       Computing whether y is erasable or not may be costly and the 
+       Computing whether y is erasable or not may be costly and the
        interest for this early detection in practice is not obvious. We let
        it for future work. In any case, thanks to the use of filters, the whole
        (unrestricted) context remains consistent. *)
-    let evi = Evd.find (evars_of evd) evk in
+    let evi = Evd.find evd evk in
     let env = evar_unfiltered_env evi in
     let oldfilter = evar_filter evi in
     let filter,_ = List.fold_right (fun oldb (l,filter) ->
@@ -759,7 +793,7 @@ let do_restrict_hyps evd evk projs =
   else
     let env,src,filter,ccl = restrict_hyps evd evk filter in
     let evd,nc = new_evar evd env ~src ~filter ccl in
-    let evd = Evd.evar_define evk nc evd in
+    let evd = Evd.define evk nc evd in
     let evk',_ = destEvar nc in
     evd,evk'
 
@@ -767,7 +801,7 @@ let do_restrict_hyps evd evk projs =
 
 let postpone_evar_term env evd (evk,argsv) rhs =
   let rhs = expand_vars_in_term env rhs in
-  let evi = Evd.find (evars_of evd) evk in
+  let evi = Evd.find evd evk in
   let evd,evk,args =
     restrict_upon_filter evd evi evk
       (* Keep only variables that depends in rhs *)
@@ -794,13 +828,13 @@ let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) =
   let pb = (Reduction.CONV,env,mkEvar(evk1',args1'),mkEvar (evk2',args2')) in
   add_conv_pb pb evd
 
-(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic 
+(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic
  * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]:
- * - if there are at most one φj for each vj s.t. vj = φj(u1..un), 
- *   we first restrict ?2 to the subset v_k1..v_kq of the vj that are 
+ * - if there are at most one φj for each vj s.t. vj = φj(u1..un),
+ *   we first restrict ?2 to the subset v_k1..v_kq of the vj that are
  *   inversible and we set ?1[x1..xn] := ?2[φk1(x1..xn)..φkp(x1..xn)]
- * - symmetrically if there are at most one ψj for each uj s.t. 
- *   uj = ψj(v1..vp), 
+ * - symmetrically if there are at most one ψj for each uj s.t.
+ *   uj = ψj(v1..vp),
  * - otherwise, each position i s.t. ui does not occur in v1..vp has to
  *   be restricted and similarly for the vi, and we leave the equation
  *   as an open equation (performed by [postpone_evar])
@@ -811,17 +845,40 @@ let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) =
  * 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 && args1.(n) = mkVar id && args1.(n) = args2.(n) ->
+	aux (n+1) sign
+    | [] ->
+	let rec aux2 n =
+	  n = n1 ||
+	  (args1.(n) = mkRel (n1-n) && args2.(n) = mkRel (n1-n) && aux2 (n+1))
+	in aux2 n
+    | _ -> false in
+  n1 = n2 & aux 0 (named_context env)
+
 exception CannotProject of projectibility_status list
 
-let solve_evar_evar_l2r f env evd (evk1,args1) (evk2,_ as ev2) =
-  let proj1 = array_map_to_list (invert_arg env 0 (evars_of evd) ev2) args1 in
+let solve_evar_evar_l2r f env evd (evk1,args1) (evk2,args2 as ev2) =
+  let aliases = make_alias_map env in
+  let subst = make_projectable_subst aliases evd (Evd.find evd evk2) args2 in
+  if are_canonical_instances args1 args2 env then
+    (* If instances are canonical, we solve the problem in linear time *)
+    let sign = evar_filtered_context (Evd.find evd evk2) in
+    let subst = List.map (fun (id,_,_) -> mkVar id) sign in
+    Evd.define evk2 (mkEvar(evk1,Array.of_list subst)) evd
+  else
+  let proj1 = array_map_to_list (invert_arg aliases 0 evd evk2 subst) args1 in
   try
     (* Instantiate ev2 with (a restriction of) ev1 if uniquely projectable *)
     let proj1' = effective_projections proj1 in
     let evd,args1' =
       list_fold_map (instance_of_projection f env (mkEvar ev2)) evd proj1' in
     let evd,evk1' = do_restrict_hyps evd evk1 proj1 in
-    Evd.evar_define evk2 (mkEvar(evk1',Array.of_list args1')) evd
+    Evd.define evk2 (mkEvar(evk1',Array.of_list args1')) evd
   with NotUnique ->
     raise (CannotProject proj1)
 
@@ -832,20 +889,33 @@ let solve_evar_evar f env evd ev1 ev2 =
   with CannotProject projs2 ->
   postpone_evar_evar env evd projs1 ev1 projs2 ev2
 
-let expand_rhs env sigma subst rhs =
-  let d = (named_hd env rhs Anonymous,Some rhs,get_type_of env sigma rhs) in
-  let rhs' = lift 1 rhs in
-  let f (id,(idc,t)) = (id,(idc,replace_term rhs' (mkRel 1) (lift 1 t))) in
-  push_rel d env, List.map f subst, mkRel 1
+(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
+ * definitions. We try to unify the xi with the yi pairwise. The pairs
+ * that don't unify are discarded (i.e. ?i is redefined so that it does not
+ * depend on these args). *)
+
+let solve_refl conv_algo env evd evk argsv1 argsv2 =
+  if argsv1 = argsv2 then evd else
+  let evi = Evd.find evd evk in
+  (* Filter and restrict if needed *)
+  let evd,evk,args =
+    restrict_upon_filter evd evi evk
+      (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2))
+      (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in
+  (* Leave a unification problem *)
+  let args1,args2 = List.split args in
+  let argsv1 = Array.of_list args1 and argsv2 = Array.of_list args2 in
+  let pb = (Reduction.CONV,env,mkEvar(evk,argsv1),mkEvar(evk,argsv2)) in
+  Evd.add_conv_pb pb evd
 
 (* We try to instantiate the evar assuming the body won't depend
  * on arguments that are not Rels or Vars, or appearing several times
- * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) 
+ * (i.e. we tackle a generalization of Miller-Pfenning patterns unification)
  *
  * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem
  * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs"
  *    where only Rel's and Var's are relevant in subst
- * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is 
+ * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is
  *    not in the scope of ?ev. For instance, the problem
  *    "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because
  *    ?1 would be instantiated by y which is not in the scope of ?1.
@@ -855,26 +925,28 @@ let expand_rhs env sigma subst rhs =
  * Note: we don't assume rhs in normal form, it may fail while it would
  * have succeeded after some reductions.
  *
- * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] 
+ * This is the work of [invert_definition Γ Σ ?ev[hyps:=args]
  * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
- * Postcondition: if φ(x1..xn) is returned then 
+ * Postcondition: if φ(x1..xn) is returned then
  *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
  *)
 
 exception NotInvertibleUsingOurAlgorithm of constr
 exception NotEnoughInformationToProgress
+exception OccurCheckIn of evar_map * constr
 
 let rec invert_definition choose env evd (evk,argsv as ev) rhs =
+  let aliases = make_alias_map env in
   let evdref = ref evd in
   let progress = ref false in
-  let evi = Evd.find (evars_of evd) evk in
-  let subst = make_projectable_subst (evars_of evd) evi argsv in
+  let evi = Evd.find evd evk in
+  let subst = make_projectable_subst aliases evd evi argsv in
 
   (* Projection *)
   let project_variable t =
     (* Evar/Var problem: unifiable iff variable projectable from ev subst *)
-    try 
-      let sols = find_projectable_vars true env (evars_of !evdref) t subst in
+    try
+      let sols = find_projectable_vars true aliases !evdref t subst in
       let c, p = match sols with
 	| [] -> raise Not_found
 	| [id,p] -> (mkVar id, p)
@@ -882,7 +954,7 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
 	    if choose then (mkVar id, p)
 	    else raise (NotUniqueInType(find_solution_type (evar_env evi) sols))
       in
-      let ty = lazy (Retyping.get_type_of env (evars_of !evdref) t) in
+      let ty = lazy (Retyping.get_type_of env !evdref t) in
       let evd = do_projection_effects evar_define env ty !evdref p in
       evdref := evd;
       c
@@ -891,7 +963,7 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
       | NotUniqueInType ty ->
 	  if not !progress then raise NotEnoughInformationToProgress;
 	  (* No unique projection but still restrict to where it is possible *)
-	  let ts = expansions_of_var env t in
+	  let ts = expansions_of_var aliases t in
 	  let test c = isEvar c or List.mem c ts in
 	  let filter = array_map_to_list test argsv in
 	  let args' = filter_along (fun x -> x) filter argsv in
@@ -903,21 +975,21 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
 	  evar in
 
   let rec imitate (env',k as envk) t =
-    let t = whd_evar (evars_of !evdref) t in
+    let t = whd_evar !evdref t in
     match kind_of_term t with
     | Rel i when i>k -> project_variable (mkRel (i-k))
     | Var id -> project_variable t
     | Evar (evk',args' as ev') ->
-        if evk = evk' then error_occur_check env (evars_of evd) evk rhs;
+        if evk = evk' then raise (OccurCheckIn (evd,rhs));
 	(* Evar/Evar problem (but left evar is virtual) *)
 	let projs' =
 	  array_map_to_list
-	    (invert_arg_from_subst env k (evars_of !evdref) subst) args'
+	    (invert_arg_from_subst aliases k !evdref subst) args'
 	in
 	(try
 	  (* Try to project (a restriction of) the right evar *)
 	  let eprojs' = effective_projections projs' in
-	  let evd,args' = 
+	  let evd,args' =
 	    list_fold_map (instance_of_projection evar_define env' t)
 	      !evdref eprojs' in
 	  let evd,evk' = do_restrict_hyps evd evk' projs' in
@@ -941,13 +1013,13 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
 	map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
 	  imitate envk t in
 
-  let rhs = whd_beta (evars_of evd) rhs (* heuristic *) in
+  let rhs = whd_beta evd rhs (* heuristic *) in
   let body = imitate (env,0) rhs in
   (!evdref,body)
 
-(* [evar_define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
+(* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
  * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said,
- * [evar_define] tries to find an instance lhs such that
+ * [define] tries to find an instance lhs such that
  * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in
  * context "hyps" and not referring to itself.
  *)
@@ -958,58 +1030,68 @@ and occur_existential evm c =
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur -> true
 
-and evar_define ?(choose=false) env (evk,_ as ev) rhs evd =
+and evar_define ?(choose=false) env (evk,argsv as ev) rhs evd =
   try
     let (evd',body) = invert_definition choose env evd ev rhs in
     if occur_meta body then error "Meta cannot occur in evar body.";
     (* invert_definition may have instantiate some evars of rhs with evk *)
     (* so we recheck acyclicity *)
-    if occur_evar evk body then error_occur_check env (evars_of evd) evk body;
+    if occur_evar evk body then raise (OccurCheckIn (evd',body));
     (* needed only if an inferred type *)
     let body = refresh_universes body in
 (* Cannot strictly type instantiations since the unification algorithm
  * does not unify applications from left to right.
- * e.g problem f x == g y yields x==y and f==g (in that order) 
+ * e.g problem f x == g y yields x==y and f==g (in that order)
  * Another problem is that type variables are evars of type Type
    let _ =
       try
         let env = evar_env evi in
         let ty = evi.evar_concl in
-        Typing.check env (evars_of evd') body ty
+        Typing.check env evd' body ty
       with e ->
         pperrnl
           (str "Ill-typed evar instantiation: " ++ fnl() ++
-           pr_evar_defs evd' ++ fnl() ++
+           pr_evar_map evd' ++ fnl() ++
            str "----> " ++ int ev ++ str " := " ++
            print_constr body);
         raise e in*)
-    Evd.evar_define evk body evd'
+    Evd.define evk body evd'
   with
     | NotEnoughInformationToProgress ->
 	postpone_evar_term env evd ev rhs
-    | NotInvertibleUsingOurAlgorithm t -> 
-	error_not_clean env (evars_of evd) evk t (evar_source evk evd)
+    | NotInvertibleUsingOurAlgorithm t ->
+	error_not_clean env evd evk t (evar_source evk evd)
+    | OccurCheckIn (evd,rhs) ->
+	(* last chance: rhs actually reduces to ev *)
+	let c = whd_betadeltaiota env evd rhs in
+	match kind_of_term c with
+	| Evar (evk',argsv2) when evk = evk' ->
+	    solve_refl
+	      (fun env sigma pb c c' -> (evd,is_fconv pb env sigma c c'))
+	      env evd evk argsv argsv2
+	| _ ->
+	    error_occur_check env evd evk rhs
 
 (*-------------------*)
 (* Auxiliary functions for the conversion algorithms modulo evars
  *)
 
-let has_undefined_evars evd t =
-  let evm = evars_of evd in
+let has_undefined_evars_or_sorts evd t =
   let rec has_ev t =
     match kind_of_term t with
-        Evar (ev,args) ->
-          (match evar_body (Evd.find evm ev) with
-            | Evar_defined c ->
-                has_ev c; Array.iter has_ev args
-            | Evar_empty ->
-	        raise NotInstantiatedEvar)
-      | _ -> iter_constr has_ev t in
+    | Evar (ev,args) ->
+        (match evar_body (Evd.find evd ev) with
+        | Evar_defined c ->
+            has_ev c; Array.iter has_ev args
+        | Evar_empty ->
+	    raise NotInstantiatedEvar)
+    | Sort s when is_sort_variable evd s -> raise Not_found
+    | _ -> iter_constr has_ev t in
   try let _ = has_ev t in false
   with (Not_found | NotInstantiatedEvar) -> true
 
 let is_ground_term evd t =
-  not (has_undefined_evars evd t)
+  not (has_undefined_evars_or_sorts evd t)
 
 let is_ground_env evd env =
   let is_ground_decl = function
@@ -1021,15 +1103,35 @@ let is_ground_env evd env =
    structures *)
 let is_ground_env = memo1_2 is_ground_env
 
-let head_evar = 
+(* Return the head evar if any *)
+
+exception NoHeadEvar
+
+let head_evar =
   let rec hrec c = match kind_of_term c with
     | Evar (evk,_)   -> evk
     | Case (_,_,c,_) -> hrec c
     | App (c,_)      -> hrec c
     | Cast (c,_,_)   -> hrec c
-    | _              -> failwith "headconstant"
-  in 
-  hrec 
+    | _              -> raise NoHeadEvar
+  in
+  hrec
+
+(* Expand head evar if any (currently consider only applications but I
+   guess it should consider Case too) *)
+
+let whd_head_evar_stack sigma c =
+  let rec whrec (c, l as s) =
+    match kind_of_term c with
+      | Evar (evk,args as ev) when Evd.is_defined sigma evk
+	  -> whrec (existential_value sigma ev, l)
+      | Cast (c,_,_) -> whrec (c, l)
+      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
+      | _ -> s
+  in
+  whrec (c, [])
+
+let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c)
 
 (* Check if an applied evar "?X[args] l" is a Miller's pattern; note
    that we don't care whether args itself contains Rel's or even Rel's
@@ -1050,8 +1152,9 @@ let rec expand_and_check_vars env = function
 let is_unification_pattern_evar env (_,args) l t =
   List.for_all (fun x -> isRel x || isVar x) l (* common failure case *)
   &&
+    let aliases = make_alias_map env in
     let l' = Array.to_list args @ l in
-    let l'' = try Some (expand_and_check_vars env l') with Exit -> None in
+    let l'' = try Some (expand_and_check_vars aliases l') with Exit -> None in
     match l'' with
     | Some l ->
 	let deps =
@@ -1060,7 +1163,7 @@ let is_unification_pattern_evar env (_,args) l t =
 	    l
 	  else
 	    (* Probably strong restrictions coming from t being evar-closed *)
-	    let t = expand_vars_in_term env t in
+	    let t = expand_vars_in_term_using aliases t in
 	    let fv_rels = free_rels t in
 	    let fv_ids = global_vars env t in
 	    List.filter (fun c ->
@@ -1083,16 +1186,19 @@ let is_unification_pattern (env,nb) f l t =
 
 (* From a unification problem "?X l1 = term1 l2" such that l1 is made
    of distinct rel's, build "\x1...xn.(term1 l2)" (patterns unification) *)
-
+(* NB: does not work when (term1 l2) contains metas because metas
+   *implicitly* depend on Vars but lambda abstraction will not reflect this
+   dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
+   return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
 let solve_pattern_eqn env l1 c =
-  let l1 = List.map (expand_var env) l1 in
+  let l1 = List.map (expand_var (make_alias_map env)) l1 in
   let c' = List.fold_right (fun a c ->
     let c' = subst_term (lift 1 a) (lift 1 c) in
     match kind_of_term a with
       (* Rem: if [a] links to a let-in, do as if it were an assumption *)
       | Rel n -> let (na,_,t) = lookup_rel n env in mkLambda (na,lift n t,c')
       | Var id -> let (id,_,t) = lookup_named id env in mkNamedLambda id t c'
-      | _ -> assert false) 
+      | _ -> assert false)
     l1 c in
   (* Warning: we may miss some opportunity to eta-reduce more since c'
      is not in normal form *)
@@ -1111,7 +1217,7 @@ let solve_pattern_eqn env l1 c =
  * hyps of the existential, to do a "pop" for each Rel which is
  * not an argument of the existential, and a subst1 for each which
  * is, again, with the corresponding variable. This is done by
- * evar_define
+ * define
  *
  * Thus, we take the arguments of the existential which we are about
  * to assign, and zip them with the identifiers in the hypotheses.
@@ -1125,43 +1231,22 @@ let solve_pattern_eqn env l1 c =
  *)
 
 let status_changed lev (pbty,_,t1,t2) =
-  try 
-    List.mem (head_evar t1) lev or List.mem (head_evar t2) lev
-  with Failure _ ->
-    try List.mem (head_evar t2) lev with Failure _ -> false
-
-(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
- * definitions. We try to unify the xi with the yi pairwise. The pairs
- * that don't unify are discarded (i.e. ?i is redefined so that it does not
- * depend on these args). *)
-
-let solve_refl conv_algo env evd evk argsv1 argsv2 =
-  if argsv1 = argsv2 then evd else
-  let evi = Evd.find (evars_of evd) evk in
-  (* Filter and restrict if needed *)
-  let evd,evk,args =
-    restrict_upon_filter evd evi evk
-      (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2))
-      (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in
-  (* Leave a unification problem *)
-  let args1,args2 = List.split args in
-  let argsv1 = Array.of_list args1 and argsv2 = Array.of_list args2 in
-  let pb = (Reduction.CONV,env,mkEvar(evk,argsv1),mkEvar(evk,argsv2)) in
-  Evd.add_conv_pb pb evd
+  (try ExistentialSet.mem (head_evar t1) lev with NoHeadEvar -> false) or
+  (try ExistentialSet.mem (head_evar t2) lev with NoHeadEvar -> false)
 
 (* Util *)
 
 let check_instance_type conv_algo env evd ev1 t2 =
-  let t2 = nf_evar (evars_of evd) t2 in
-  if has_undefined_evars evd t2 then
+  let t2 = nf_evar evd t2 in
+  if has_undefined_evars_or_sorts evd t2 then
     (* May contain larger constraints than needed: don't want to
        commit to an equal solution while only subtyping is requested *)
     evd
   else
-    let typ2 = Retyping.get_type_of env (evars_of evd) (refresh_universes t2) in
+    let typ2 = Retyping.get_type_of env evd (refresh_universes t2) in
     if isEvar typ2 then (* Don't want to commit too early too *) evd
     else
-      let typ1 = existential_type (evars_of evd) ev1 in
+      let typ1 = existential_type evd ev1 in
       let evd,b = conv_algo env evd Reduction.CUMUL typ2 typ1 in
       if b then evd else
 	user_err_loc (fst (evar_source (fst ev1) evd),"",
@@ -1175,7 +1260,7 @@ let check_instance_type conv_algo env evd ev1 t2 =
 (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *)
 let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) =
   try
-    let t2 = whd_evar (evars_of evd) t2 in
+    let t2 = whd_betaiota evd t2 in (* includes whd_evar *)
     let evd = match kind_of_term t2 with
       | Evar (evk2,args2 as ev2) ->
 	  if evk1 = evk2 then
@@ -1190,20 +1275,19 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1)
       | _ ->
 	  let evd =
 	    if pbty = Some false then
-	      check_instance_type conv_algo env evd ev1 t2 
+	      check_instance_type conv_algo env evd ev1 t2
 	    else
 	      evd in
 	  let evd = evar_define ~choose env ev1 t2 evd in
-	  let evm = evars_of evd in
-	  let evi = Evd.find evm evk1 in
-	    if occur_existential evm evi.evar_concl then
+	  let evi = Evd.find evd evk1 in
+	    if occur_existential evd evi.evar_concl then
 	      let evenv = evar_unfiltered_env evi in
-	      let evc = nf_isevar evd evi.evar_concl in
-		match evi.evar_body with 
-		| Evar_defined body -> 
-		    let ty = nf_isevar evd (Retyping.get_type_of_with_meta evenv evm (metas_of evd) body) in
+	      let evc = nf_evar evd evi.evar_concl in
+		match evi.evar_body with
+		| Evar_defined body ->
+		    let ty = nf_evar evd (Retyping.get_type_of evenv evd body) in
 		      add_conv_pb (Reduction.CUMUL,evenv,ty,evc) evd
-		| Evar_empty -> (* Resulted in a constraint *) 
+		| Evar_empty -> (* Resulted in a constraint *)
 		    evd
 	    else evd
     in
@@ -1215,45 +1299,58 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1)
   with e when precatchable_exception e ->
     (evd,false)
 
-let evars_of_term c = 
+let evars_of_term c =
   let rec evrec acc c =
     match kind_of_term c with
     | Evar (n, _) -> Intset.add n acc
     | _ -> fold_constr evrec acc c
-  in 
+  in
     evrec Intset.empty c
 
 let evars_of_named_context nc =
   List.fold_right (fun (_, b, t) s ->
-    Option.fold_left (fun s t -> 
+    Option.fold_left (fun s t ->
       Intset.union s (evars_of_term t))
-      s b) nc Intset.empty
+      (Intset.union s (evars_of_term t)) b)
+    nc Intset.empty
 
 let evars_of_evar_info evi =
   Intset.union (evars_of_term evi.evar_concl)
-    (Intset.union 
-	(match evi.evar_body with 
+    (Intset.union
+	(match evi.evar_body with
 	| Evar_empty -> Intset.empty
 	| Evar_defined b -> evars_of_term b)
 	(evars_of_named_context (named_context_of_val evi.evar_hyps)))
-    
+
 (* [check_evars] fails if some unresolved evar remains *)
 (* it assumes that the defined existentials have already been substituted *)
 
 let check_evars env initial_sigma evd c =
-  let sigma = evars_of evd in
+  let sigma =  evd in
   let c = nf_evar sigma c in
   let rec proc_rec c =
     match kind_of_term c with
       | Evar (evk,args) ->
           assert (Evd.mem sigma evk);
 	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk evd in
-	    let evi = nf_evar_info sigma (Evd.find sigma evk) in
-	    error_unsolvable_implicit loc env sigma evi k None
+            let (loc,k) = evar_source evk sigma in
+	      (match k with
+	      | ImplicitArg (gr, (i, id), false) -> ()
+	      | _ ->
+		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
+		    error_unsolvable_implicit loc env sigma evi k None)
       | _ -> iter_constr proc_rec c
   in proc_rec c
 
+(* This returns the evars of [sigma] that are not in [sigma0] and
+   [sigma] minus these evars *)
+
+let subtract_evars sigma0 sigma =
+  Evd.fold (fun evk ev (sigma,sigma' as acc) ->
+    if Evd.mem sigma0 evk || Evd.mem sigma' evk then acc else
+      (Evd.remove sigma evk,Evd.add sigma' evk ev))
+    sigma (sigma,Evd.empty)
+
 (* Operations on value/type constraints *)
 
 type type_constraint_type = (int * int) option * constr
@@ -1299,7 +1396,7 @@ let mk_valcon c = Some c
    cumulativity now includes Prop and Set in Type...
    It is, but that's not too bad *)
 let define_evar_as_abstraction abs evd (ev,args) =
-  let evi = Evd.find (evars_of evd) ev in
+  let evi = Evd.find evd ev in
   let evenv = evar_unfiltered_env evi in
   let (evd1,dom) = new_evar evd evenv (new_Type()) ~filter:(evar_filter evi) in
   let nvar =
@@ -1307,16 +1404,16 @@ let define_evar_as_abstraction abs evd (ev,args) =
       (ids_of_named_context (evar_context evi)) in
   let newenv = push_named (nvar, None, dom) evenv in
   let (evd2,rng) =
-    new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) 
+    new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type())
       ~filter:(true::evar_filter evi) in
   let prod = abs (Name nvar, dom, subst_var nvar rng) in
-  let evd3 = Evd.evar_define ev prod evd2 in
+  let evd3 = Evd.define ev prod evd2 in
   let evdom = fst (destEvar dom), args in
   let evrng =
     fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in
   let prod' = abs (Name nvar, mkEvar evdom, mkEvar evrng) in
     (evd3,prod')
-      
+
 let define_evar_as_product evd (ev,args) =
   define_evar_as_abstraction (fun t -> mkProd t) evd (ev,args)
 
@@ -1325,7 +1422,7 @@ let define_evar_as_lambda evd (ev,args) =
 
 let define_evar_as_sort evd (ev,args) =
   let s = new_Type () in
-  Evd.evar_define ev s evd, destSort s
+  Evd.define ev s evd, destSort 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... *)
@@ -1337,44 +1434,44 @@ let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
    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.evars_of evd) c in
+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 when not (Evd.is_defined_evar evd ev) ->
 	    let (evd',prod) = define_evar_as_product evd ev in
 	    let (_,dom,rng) = destProd prod in
 	      evd',(Anonymous, dom, rng)
-	| _ -> error_not_product_loc loc env (Evd.evars_of evd) c
+	| _ -> error_not_product_loc loc env evd c
   in
     match tycon with
       | None -> evd,(Anonymous,None,None)
       | Some (abs, c) ->
 	  (match abs with
-	       None -> 
+	       None ->
 		 let evd', (n, dom, rng) = real_split evd c in
 		   evd', (n, mk_tycon dom, mk_tycon rng)
 	     | Some (init, cur) ->
-		 if cur = 0 then 
+		 if cur = 0 then
 		   let evd', (x, dom, rng) = real_split evd c in
-		     evd, (Anonymous, 
-			  Some (None, dom), 
+		     evd, (Anonymous,
+			  Some (None, dom),
 			  Some (None, rng))
 		 else
-		   evd, (Anonymous, None, 
+		   evd, (Anonymous, None,
 			Some (if cur = 1 then None,c else Some (init, pred cur), c)))
-	    
-let valcon_of_tycon x = 
+
+let valcon_of_tycon x =
   match x with
     | Some (None, t) -> Some t
     | _ -> None
-	
+
 let lift_abstr_tycon_type n (abs, t) =
-  match abs with 
+  match abs with
       None -> raise (Invalid_argument "lift_abstr_tycon_type: not an abstraction")
     | Some (init, abs) ->
-	let abs' = abs + n in 
+	let abs' = abs + n in
 	  if abs' < 0 then raise (Invalid_argument "lift_abstr_tycon_type")
 	  else (Some (init, abs'), t)
 
@@ -1382,11 +1479,10 @@ let lift_tycon_type n (abs, t) = (abs, lift n t)
 let lift_tycon n = Option.map (lift_tycon_type n)
 
 let pr_tycon_type env (abs, t) =
-  match abs with 
+  match abs with
       None -> Termops.print_constr_env env t
     | Some (init, cur) -> str "Abstract (" ++ int init ++ str ","  ++ int cur ++ str ") " ++ Termops.print_constr_env env t
-	
+
 let pr_tycon env = function
     None -> str "None"
   | Some t -> pr_tycon_type env t
-
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index eef41da3..283867e8 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarutil.mli 12268 2009-08-11 09:02:16Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -34,19 +34,19 @@ val new_untyped_evar : unit -> existential_key
 (***********************************************************)
 (* Creating a fresh evar given their type and context *)
 val new_evar :
-  evar_defs -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> evar_defs * constr
+  evar_map -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> evar_map * constr
 (* the same with side-effects *)
 val e_new_evar :
-  evar_defs ref -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> constr
+  evar_map ref -> env -> ?src:loc * hole_kind -> ?filter:bool list -> types -> constr
 
 (* Create a fresh evar in a context different from its definition context:
    [new_evar_instance sign evd ty inst] creates a new evar of context
    [sign] and type [ty], [inst] is a mapping of the evar context to
-   the context where the evar should occur. This means that the terms 
+   the context where the evar should occur. This means that the terms
    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_defs -> types -> ?src:loc * hole_kind -> ?filter:bool list -> constr list -> evar_defs * constr
+ named_context_val -> evar_map -> types -> ?src:loc * hole_kind -> ?filter:bool list -> constr list -> evar_map * constr
 
 val make_pure_subst : evar_info -> constr array -> (identifier * constr) list
 
@@ -57,7 +57,7 @@ val make_pure_subst : evar_info -> constr array -> (identifier * constr) list
    possibly solving related unification problems, possibly leaving open
    some problems that cannot be solved in a unique way (except if choose is
    true); fails if the instance is not valid for the given [ev] *)
-val evar_define : ?choose:bool -> env -> existential -> constr -> evar_defs -> evar_defs
+val evar_define : ?choose:bool -> env -> existential -> constr -> evar_map -> evar_map
 
 (***********************************************************)
 (* Evars/Metas switching... *)
@@ -72,26 +72,33 @@ val non_instantiated : evar_map -> (evar * evar_info) list
 (***********************************************************)
 (* Unification utils *)
 
-val is_ground_term :  evar_defs -> constr -> bool
-val is_ground_env  :  evar_defs -> env -> bool
-val solve_refl : 
-  (env ->  evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool)
-  -> env ->  evar_defs -> existential_key -> constr array -> constr array ->
-    evar_defs
+exception NoHeadEvar
+val head_evar : constr -> existential_key (* may raise NoHeadEvar *)
+
+(* Expand head evar if any *)
+val whd_head_evar :  evar_map -> constr -> constr
+
+val is_ground_term :  evar_map -> constr -> bool
+val is_ground_env  :  evar_map -> env -> bool
+val solve_refl :
+  (env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool)
+  -> env ->  evar_map -> existential_key -> constr array -> constr array ->
+    evar_map
 val solve_simple_eqn :
-  (env ->  evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool)
-  -> ?choose:bool -> env ->  evar_defs -> bool option * existential * constr ->
-    evar_defs * bool
+  (env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool)
+  -> ?choose:bool -> env ->  evar_map -> bool option * existential * constr ->
+    evar_map * bool
 
 (* [check_evars env initial_sigma extended_sigma c] fails if some
    new unresolved evar remains in [c] *)
-val check_evars : env -> evar_map -> evar_defs -> constr -> unit
+val check_evars : env -> evar_map -> evar_map -> constr -> unit
 
-val define_evar_as_product : evar_defs -> existential -> evar_defs * types
-val define_evar_as_lambda : evar_defs -> existential -> evar_defs * types
-val define_evar_as_sort : evar_defs -> existential -> evar_defs * sorts
+val subtract_evars : evar_map -> evar_map -> evar_map * evar_map 
+val define_evar_as_product : evar_map -> existential -> evar_map * types
+val define_evar_as_lambda : evar_map -> existential -> evar_map * types
+val define_evar_as_sort : evar_map -> existential -> evar_map * sorts
 
-val is_unification_pattern_evar : env -> existential -> constr list -> 
+val is_unification_pattern_evar : env -> existential -> constr list ->
   constr -> bool
 val is_unification_pattern : env * int -> constr -> constr array ->
   constr -> bool
@@ -120,8 +127,8 @@ val empty_valcon : val_constraint
 val mk_valcon : constr -> val_constraint
 
 val split_tycon :
-  loc -> env ->  evar_defs -> type_constraint -> 
-    evar_defs * (name * type_constraint * type_constraint)
+  loc -> env ->  evar_map -> type_constraint ->
+    evar_map * (name * type_constraint * type_constraint)
 
 val valcon_of_tycon : type_constraint -> val_constraint
 
@@ -132,8 +139,8 @@ val lift_tycon : int -> type_constraint -> type_constraint
 
 (***********************************************************)
 
-(* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *)
-(* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *)
+(* [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains *)
+(* uninstantiated; [nf_evar] leave uninstantiated evars as is *)
 
 val nf_evar :  evar_map -> constr -> constr
 val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
@@ -151,26 +158,16 @@ val nf_named_context_evar : evar_map -> named_context -> named_context
 val nf_rel_context_evar : evar_map -> rel_context -> rel_context
 val nf_env_evar : evar_map -> env -> env
 
-(* Same for evar defs *)
-val nf_isevar :  evar_defs -> constr -> constr
-val j_nf_isevar :  evar_defs -> unsafe_judgment -> unsafe_judgment
-val jl_nf_isevar :
-   evar_defs -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_isevar :
-   evar_defs -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_isevar :
-   evar_defs -> unsafe_type_judgment -> unsafe_type_judgment
+val nf_evar_map : evar_map -> evar_map
 
-val nf_evar_defs : evar_defs -> evar_defs
-
-(* Replacing all evars *)
+(* Replacing all evars, possibly raising [Uninstantiated_evar] *)
+(* exception Uninstantiated_evar of existential_key *)
 exception Uninstantiated_evar of existential_key
-val whd_ise :  evar_map -> constr -> constr
-val whd_castappevar :  evar_map -> constr -> constr
+val flush_and_check_evars :  evar_map -> constr -> constr
 
 (* Replace the vars and rels that are aliases to other vars and rels by *)
 (* their representative that is most ancient in the context *)
-val expand_vars_in_term : env -> constr -> constr 
+val expand_vars_in_term : env -> constr -> constr
 
 (*********************************************************************)
 (* debug pretty-printer: *)
@@ -189,5 +186,8 @@ type clear_dependency_error =
 
 exception ClearDependencyError of identifier * clear_dependency_error
 
-val clear_hyps_in_evi : evar_defs ref -> named_context_val -> types ->
+val clear_hyps_in_evi : evar_map ref -> named_context_val -> types ->
   identifier list -> named_context_val * types
+
+val push_rel_context_to_named_context : Environ.env -> types -> 
+  named_context_val * types * constr list
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index af070d7e..21753d3a 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evd.ml 11865 2009-01-28 17:34:30Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -19,12 +19,30 @@ open Environ
 open Libnames
 open Mod_subst
 
+(* The kinds of existential variable *)
+
+type obligation_definition_status = Define of bool | Expand
+
+type hole_kind =
+  | ImplicitArg of global_reference * (int * identifier option) * bool
+  | BinderType of name
+  | QuestionMark of obligation_definition_status
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+  | GoalEvar
+  | ImpossibleCase
+  | MatchingVar of bool * identifier
+
 (* The type of mappings for existential variables *)
 
 type evar = existential_key
 
+let string_of_existential evk = "?" ^ string_of_int evk
+let existential_of_int evk = evk
+
 type evar_body =
-  | Evar_empty 
+  | Evar_empty
   | Evar_defined of constr
 
 type evar_info = {
@@ -32,6 +50,7 @@ type evar_info = {
   evar_hyps : named_context_val;
   evar_body : evar_body;
   evar_filter : bool list;
+  evar_source : hole_kind located;
   evar_extra : Dyn.t option}
 
 let make_evar hyps ccl = {
@@ -39,6 +58,7 @@ let make_evar hyps ccl = {
   evar_hyps = hyps;
   evar_body = Evar_empty;
   evar_filter = List.map (fun _ -> true) (named_context_of_val hyps);
+  evar_source = (dummy_loc,InternalHole);
   evar_extra = None
 }
 
@@ -48,109 +68,121 @@ let evar_context evi = named_context_of_val evi.evar_hyps
 let evar_body evi = evi.evar_body
 let evar_filter evi = evi.evar_filter
 let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps
-let evar_filtered_context evi = 
+let evar_filtered_context evi =
   snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi))
-let evar_env evi = 
+let evar_env evi =
   List.fold_right push_named (evar_filtered_context evi)
     (reset_context (Global.env()))
 
 let eq_evar_info ei1 ei2 =
-  ei1 == ei2 || 
-    eq_constr ei1.evar_concl ei2.evar_concl && 
+  ei1 == ei2 ||
+    eq_constr ei1.evar_concl ei2.evar_concl &&
     eq_named_context_val (ei1.evar_hyps) (ei2.evar_hyps) &&
     ei1.evar_body = ei2.evar_body
 
-module Evarmap = Intmap
-
-type evar_map1 = evar_info Evarmap.t
-
-let empty = Evarmap.empty
-
-let to_list evc = (* Workaround for change in Map.fold behavior *)
-  let l = ref [] in 
-  Evarmap.iter (fun evk x -> l := (evk,x)::!l) evc;
-  !l
-
-let dom evc = Evarmap.fold (fun evk _ acc -> evk::acc) evc []
-let find evc k = Evarmap.find k evc
-let remove evc k = Evarmap.remove k evc
-let mem evc k = Evarmap.mem k evc
-let fold = Evarmap.fold
-
-let add evd evk newinfo =  Evarmap.add evk newinfo evd
-
-let define evd evk body = 
-  let oldinfo =
-    try find evd evk
-    with Not_found -> error "Evd.define: cannot define undeclared evar" in
-  let newinfo =
-    { oldinfo with
-      evar_body = Evar_defined body } in
-  match oldinfo.evar_body with
-    | Evar_empty -> Evarmap.add evk newinfo evd
-    | _ -> anomaly "Evd.define: cannot define an evar twice"
-
-let is_evar sigma evk = mem sigma evk
-
-let is_defined sigma evk =
-  let info = find sigma evk in 
-  not (info.evar_body = Evar_empty)
-
-let string_of_existential evk = "?" ^ string_of_int evk
-
-let existential_of_int evk = evk
-
-(*******************************************************************)
-(* Formerly Instantiate module *)
-
-let is_id_inst inst =
-  let is_id (id,c) = match kind_of_term c with
-    | Var id' -> id = id'
-    | _ -> false
-  in
-  List.for_all is_id inst
-
-(* Vérifier que les instances des let-in sont compatibles ?? *)
-let instantiate_sign_including_let sign args =
-  let rec instrec = function
-    | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
-    | ([],[])                        -> []
-    | ([],_) | (_,[]) ->
-    anomaly "Signature and its instance do not match"
-  in 
-  instrec (sign,args)
-
-let instantiate_evar sign c args =
-  let inst = instantiate_sign_including_let sign args in
-  if is_id_inst inst then
-    c
-  else
-    replace_vars inst c
-
-(* Existentials. *)
+(* spiwack: Revised hierarchy :
+      - ExistentialMap ( Maps of existential_keys )
+      - EvarInfoMap ( .t = evar_info ExistentialMap.t )
+      - EvarMap ( .t = EvarInfoMap.t * sort_constraints )
+      - evar_map (exported)
+*)
 
-let existential_type sigma (n,args) =
-  let info =
-    try find sigma n
-    with Not_found ->
-      anomaly ("Evar "^(string_of_existential n)^" was not declared") in
-  let hyps = evar_filtered_context info in
-  instantiate_evar hyps info.evar_concl (Array.to_list args)
+module ExistentialMap = Intmap
+module ExistentialSet = Intset
 
+(* This exception is raised by *.existential_value *)
 exception NotInstantiatedEvar
 
-let existential_value sigma (n,args) =
-  let info = find sigma n in
-  let hyps = evar_filtered_context info in
-  match evar_body info with
-    | Evar_defined c ->
-	instantiate_evar hyps c (Array.to_list args)
-    | Evar_empty ->
-	raise NotInstantiatedEvar
+module EvarInfoMap = struct
+  type t = evar_info ExistentialMap.t
+
+  let empty = ExistentialMap.empty
+
+  let to_list evc = (* Workaround for change in Map.fold behavior *)
+    let l = ref [] in
+    ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) evc;
+    !l
+
+  let dom evc = ExistentialMap.fold (fun evk _ acc -> evk::acc) evc []
+  let find evc k = ExistentialMap.find k evc
+  let remove evc k = ExistentialMap.remove k evc
+  let mem evc k = ExistentialMap.mem k evc
+  let fold = ExistentialMap.fold
+  let exists evc f = ExistentialMap.fold (fun k v b -> b || f k v) evc false
+
+  let add evd evk newinfo =  ExistentialMap.add evk newinfo evd
+
+  let equal = ExistentialMap.equal
+
+  let define evd evk body =
+    let oldinfo =
+      try find evd evk
+      with Not_found -> error "Evd.define: cannot define undeclared evar" in
+    let newinfo =
+      { oldinfo with
+	  evar_body = Evar_defined body } in
+      match oldinfo.evar_body with
+	| Evar_empty -> ExistentialMap.add evk newinfo evd
+	| _ -> anomaly "Evd.define: cannot define an evar twice"
+
+  let is_evar sigma evk = mem sigma evk
+
+  let is_defined sigma evk =
+    let info = find sigma evk in
+      not (info.evar_body = Evar_empty)
+
+
+  (*******************************************************************)
+  (* Formerly Instantiate module *)
+
+  let is_id_inst inst =
+    let is_id (id,c) = match kind_of_term c with
+      | Var id' -> id = id'
+      | _ -> false
+    in
+      List.for_all is_id inst
+
+  (* Vérifier que les instances des let-in sont compatibles ?? *)
+  let instantiate_sign_including_let sign args =
+    let rec instrec = function
+      | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
+      | ([],[])                        -> []
+      | ([],_) | (_,[]) ->
+	  anomaly "Signature and its instance do not match"
+    in
+      instrec (sign,args)
+
+  let instantiate_evar sign c args =
+    let inst = instantiate_sign_including_let sign args in
+      if is_id_inst inst then
+	c
+      else
+	replace_vars inst c
+
+  (* Existentials. *)
+
+  let existential_type sigma (n,args) =
+    let info =
+      try find sigma n
+      with Not_found ->
+	anomaly ("Evar "^(string_of_existential n)^" was not declared") in
+    let hyps = evar_filtered_context info in
+      instantiate_evar hyps info.evar_concl (Array.to_list args)
+
+  let existential_value sigma (n,args) =
+    let info = find sigma n in
+    let hyps = evar_filtered_context info in
+      match evar_body info with
+	| Evar_defined c ->
+	    instantiate_evar hyps c (Array.to_list args)
+	| Evar_empty ->
+	    raise NotInstantiatedEvar
+
+  let existential_opt_value sigma ev =
+    try Some (existential_value sigma ev)
+    with NotInstantiatedEvar -> None
 
-let existential_opt_value sigma ev =
-  try Some (existential_value sigma ev)
-  with NotInstantiatedEvar -> None
+end
 
 (*******************************************************************)
 (*                Constraints for sort variables                   *)
@@ -163,11 +195,8 @@ type sort_constraint =
   | SortVar of sort_var list * sort_var list (* (leq,geq) *)
   | EqSort of sort_var
 
-module UniverseOrdered = struct
-  type t = Univ.universe
-  let compare = Pervasives.compare
-end
-module UniverseMap = Map.Make(UniverseOrdered)
+module UniverseMap =
+  Map.Make (struct type t = Univ.universe let compare = compare end)
 
 type sort_constraints = sort_constraint UniverseMap.t
 
@@ -236,7 +265,7 @@ let set_leq_sort (u1,(leq1,geq1)) (u2,(leq2,geq2)) scstr =
       match UniverseMap.find u1 scstr with
           EqSort u1' -> search_rec (is_b,betw,not_betw) u1'
         | SortVar(leq,_) ->
-            let (is_b',betw',not_betw') = 
+            let (is_b',betw',not_betw') =
               List.fold_left search_rec (false,betw,not_betw) leq in
             if is_b' then (true, u1::betw', not_betw')
             else (false, betw', not_betw')
@@ -285,41 +314,33 @@ let pr_sort_cstrs g =
           hov 0 (prlist_with_sep spc Univ.pr_uni leq) ++ str"]")
     l
 
-type evar_map = evar_map1 * sort_constraints
-let empty = empty, UniverseMap.empty
-let add (sigma,sm) k v = (add sigma k v, sm)
-let dom (sigma,_) = dom sigma
-let find (sigma,_) = find sigma
-let remove (sigma,sm) k = (remove sigma k, sm)
-let mem (sigma,_) = mem sigma
-let to_list (sigma,_) = to_list sigma
-let fold f (sigma,_) = fold f sigma
-let define (sigma,sm) k v = (define sigma k v, sm)
-let is_evar (sigma,_) = is_evar sigma
-let is_defined (sigma,_) = is_defined sigma
-let existential_value (sigma,_) = existential_value sigma
-let existential_type (sigma,_) = existential_type sigma
-let existential_opt_value (sigma,_) = existential_opt_value sigma
-let eq_evar_map x y = x == y ||
-  (Evarmap.equal eq_evar_info (fst x) (fst y) &&
-      UniverseMap.equal (=) (snd x) (snd y))
-
-let merge e e' = fold (fun n v sigma -> add sigma n v) e' e
+module EvarMap = struct
+  type t = EvarInfoMap.t * sort_constraints
+  let empty = EvarInfoMap.empty, UniverseMap.empty
+  let add (sigma,sm) k v = (EvarInfoMap.add sigma k v, sm)
+  let dom (sigma,_) = EvarInfoMap.dom sigma
+  let find (sigma,_) = EvarInfoMap.find sigma
+  let remove (sigma,sm) k = (EvarInfoMap.remove sigma k, sm)
+  let mem (sigma,_) = EvarInfoMap.mem sigma
+  let to_list (sigma,_) = EvarInfoMap.to_list sigma
+  let fold f (sigma,_) = EvarInfoMap.fold f sigma
+  let define (sigma,sm) k v = (EvarInfoMap.define sigma k v, sm)
+  let is_evar (sigma,_) = EvarInfoMap.is_evar sigma
+  let is_defined (sigma,_) = EvarInfoMap.is_defined sigma
+  let existential_value (sigma,_) = EvarInfoMap.existential_value sigma
+  let existential_type (sigma,_) = EvarInfoMap.existential_type sigma
+  let existential_opt_value (sigma,_) = EvarInfoMap.existential_opt_value sigma
+  let progress_evar_map (sigma1,sm1 as x) (sigma2,sm2 as y) = not (x == y) &&
+    (EvarInfoMap.exists sigma1
+      (fun k v -> v.evar_body = Evar_empty &&
+        (EvarInfoMap.find sigma2 k).evar_body <> Evar_empty)
+    || not (UniverseMap.equal (=) sm1 sm2))
+
+  let merge e e' = fold (fun n v sigma -> add sigma n v) e' e
 
-(*******************************************************************)
-type open_constr = evar_map * constr
+end
 
 (*******************************************************************)
-(* The type constructor ['a sigma] adds an evar map to an object of
-  type ['a] *)
-type 'a sigma = {
-  it : 'a ;
-  sigma : evar_map}
- 
-let sig_it x = x.it
-let sig_sig x = x.sigma
- 
-(*******************************************************************)
 (* Metamaps *)
 
 (*******************************************************************)
@@ -390,65 +411,113 @@ let clb_name = function
   | Clval (na,_,_) -> (na,true)
 
 (***********************)
-                                                                               
+
 module Metaset = Intset
-                                                                               
+
 let meta_exists p s = Metaset.fold (fun x b -> b || (p x)) s false
 
 module Metamap = Intmap
 
 let metamap_to_list m =
   Metamap.fold (fun n v l -> (n,v)::l) m []
- 
+
 (*************************)
 (* Unification state *)
 
-type obligation_definition_status = Define of bool | Expand
-
-type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option)
-  | BinderType of name
-  | QuestionMark of obligation_definition_status
-  | CasesType
-  | InternalHole
-  | TomatchTypeParameter of inductive * int
-  | GoalEvar
-  | ImpossibleCase
-
 type conv_pb = Reduction.conv_pb
 type evar_constraint = conv_pb * Environ.env * constr * constr
-type evar_defs =
-    { evars : evar_map;
+type evar_map =
+    { evars : EvarMap.t;
       conv_pbs : evar_constraint list;
-      last_mods : existential_key list;
-      history : (existential_key * (loc * hole_kind)) list;
+      last_mods : ExistentialSet.t;
       metas : clbinding Metamap.t }
 
+(*** Lifting primitive from EvarMap. ***)
+
+(* HH: The progress tactical now uses this function. *)
+let progress_evar_map d1 d2 =
+  EvarMap.progress_evar_map d1.evars d2.evars
+
+(* spiwack: tentative. It might very well not be the semantics we want
+     for merging evar_map *)
+let merge d1 d2 = {
+(* d1 with evars = EvarMap.merge d1.evars d2.evars*)
+  evars = EvarMap.merge d1.evars d2.evars ;
+  conv_pbs = List.rev_append d1.conv_pbs d2.conv_pbs ;
+  last_mods = ExistentialSet.union d1.last_mods d2.last_mods ;
+  metas = Metamap.fold (fun k m r -> Metamap.add k m r) d2.metas d1.metas
+}
+let add d e i = { d with evars=EvarMap.add d.evars e i }
+let remove d e = { d with evars=EvarMap.remove d.evars e }
+let dom d = EvarMap.dom d.evars
+let find d e = EvarMap.find d.evars e
+let mem d e = EvarMap.mem d.evars e
+(* spiwack: this function loses information from the original evar_map
+   it might be an idea not to export it. *)
+let to_list d = EvarMap.to_list d.evars
+(* spiwack: not clear what folding over an evar_map, for now we shall
+    simply fold over the inner evar_map. *)
+let fold f d a = EvarMap.fold f d.evars a
+let is_evar d e = EvarMap.is_evar d.evars e
+let is_defined d e = EvarMap.is_defined d.evars e
+
+let existential_value d e = EvarMap.existential_value d.evars e
+let existential_type d e = EvarMap.existential_type d.evars e
+let existential_opt_value d e = EvarMap.existential_opt_value d.evars e
+
+(*** /Lifting... ***)
+
+(* evar_map are considered empty disregarding histories *)
+let is_empty d =
+  d.evars = EvarMap.empty &&
+  d.conv_pbs = [] &&
+  Metamap.is_empty d.metas
+
+let subst_named_context_val s = map_named_val (subst_mps s)
+
+let subst_evar_info s evi =
+  let subst_evb = function Evar_empty -> Evar_empty
+    | Evar_defined c -> Evar_defined (subst_mps s c) in
+  { evi with
+      evar_concl = subst_mps s evi.evar_concl;
+      evar_hyps = subst_named_context_val s evi.evar_hyps;
+      evar_body = subst_evb evi.evar_body }
+
 let subst_evar_defs_light sub evd =
-  assert (evd.evars = (Evarmap.empty,UniverseMap.empty));
+  assert (UniverseMap.is_empty (snd evd.evars));
   assert (evd.conv_pbs = []);
   { evd with
-    metas = Metamap.map (map_clb (subst_mps sub)) evd.metas }
-
-let create_evar_defs sigma =
-  { evars=sigma; conv_pbs=[]; last_mods = []; history=[]; metas=Metamap.empty }
-let create_goal_evar_defs sigma =
-  let h = fold (fun mv _ l -> (mv,(dummy_loc,GoalEvar))::l) sigma [] in
-  { evars=sigma; conv_pbs=[]; last_mods = []; history=h; metas=Metamap.empty }
-let empty_evar_defs = create_evar_defs empty
-let evars_of d = d.evars
-let evars_reset_evd evd d = {d with evars = evd}
-let reset_evd (sigma,mmap) d = {d with evars = sigma; metas=mmap}
+      metas = Metamap.map (map_clb (subst_mps sub)) evd.metas;
+      evars = ExistentialMap.map (subst_evar_info sub)  (fst evd.evars), snd evd.evars
+  }
+
+let subst_evar_map = subst_evar_defs_light
+
+(* spiwack: deprecated *)
+let create_evar_defs sigma = { sigma with
+  conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty }
+(* spiwack: tentatively deprecated *)
+let create_goal_evar_defs sigma = { sigma with
+   conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty }
+let empty =  {
+  evars=EvarMap.empty;
+  conv_pbs=[];
+  last_mods = ExistentialSet.empty;
+  metas=Metamap.empty
+}
+
+let evars_reset_evd evd d = {d with evars = evd.evars}
 let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs}
-let evar_source evk d =
-  try List.assoc evk d.history
-  with Not_found -> (dummy_loc, InternalHole)
+let evar_source evk d = (EvarMap.find d.evars evk).evar_source
 
 (* define the existential of section path sp as the constr body *)
-let evar_define evk body evd =
+let define evk body evd =
   { evd with
-    evars = define evd.evars evk body;
-    last_mods = evk :: evd.last_mods }
+    evars = EvarMap.define evd.evars evk body;
+    last_mods =
+        match evd.conv_pbs with
+	| [] ->  evd.last_mods
+        | _ -> ExistentialSet.add evk evd.last_mods }
 
 let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter evd =
   let filter =
@@ -460,43 +529,43 @@ let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter evd =
       filter)
   in
   { evd with
-    evars = add evd.evars evk
+    evars = EvarMap.add evd.evars evk
       {evar_hyps = hyps;
        evar_concl = ty;
        evar_body = Evar_empty;
        evar_filter = filter;
-       evar_extra = None};
-    history = (evk,src)::evd.history }
+       evar_source = src;
+       evar_extra = None} }
 
-let is_defined_evar evd (evk,_) = is_defined evd.evars evk
+let is_defined_evar evd (evk,_) = EvarMap.is_defined evd.evars evk
 
 (* Does k corresponds to an (un)defined existential ? *)
 let is_undefined_evar evd c = match kind_of_term c with
   | Evar ev -> not (is_defined_evar evd ev)
   | _ -> false
 
-let undefined_evars evd = 
-  let evars = 
-    fold (fun evk evi sigma -> if evi.evar_body = Evar_empty then 
-	    add sigma evk evi else sigma) 
-      evd.evars empty
-  in 
+let undefined_evars evd =
+  let evars =
+    EvarMap.fold (fun evk evi sigma -> if evi.evar_body = Evar_empty then
+	    EvarMap.add sigma evk evi else sigma)
+      evd.evars EvarMap.empty
+  in
     { evd with evars = evars }
 
 (* extracts conversion problems that satisfy predicate p *)
 (* Note: conv_pbs not satisying p are stored back in reverse order *)
 let extract_conv_pbs evd p =
-  let (pbs,pbs1) = 
+  let (pbs,pbs1) =
     List.fold_left
       (fun (pbs,pbs1) pb ->
-    	 if p pb then 
+    	 if p pb then
 	   (pb::pbs,pbs1)
-         else 
+         else
 	   (pbs,pb::pbs1))
       ([],[])
       evd.conv_pbs
   in
-  {evd with conv_pbs = pbs1; last_mods = []},
+  {evd with conv_pbs = pbs1; last_mods = ExistentialSet.empty},
   pbs
 
 let extract_changed_conv_pbs evd p =
@@ -505,23 +574,31 @@ let extract_changed_conv_pbs evd p =
 let extract_all_conv_pbs evd =
   extract_conv_pbs evd (fun _ -> true)
 
+(* spiwack: should it be replaced by Evd.merge? *)
 let evar_merge evd evars =
-  { evd with evars = merge evd.evars evars }
+  { evd with evars = EvarMap.merge evd.evars evars.evars }
+
+let evar_list evd c =
+  let rec evrec acc c =
+    match kind_of_term c with
+    | Evar (evk, _ as ev) when mem evd evk -> ev :: acc
+    | _ -> fold_constr evrec acc c in
+  evrec [] c
 
 (**********************************************************)
 (* Sort variables *)
 
-let new_sort_variable (sigma,sm) =
+let new_sort_variable ({ evars = (sigma,sm) } as d)=
   let (u,scstr) = new_sort_var sm in
-  (Type u,(sigma,scstr))
-let is_sort_variable (_,sm) s =
+  (Type u,{ d with evars = (sigma,scstr) } )
+let is_sort_variable {evars=(_,sm)} s =
   is_sort_var s sm
-let whd_sort_variable (_,sm) t = whd_sort_var sm t
-let set_leq_sort_variable (sigma,sm) u1 u2 =
-  (sigma, set_leq u1 u2 sm)
-let define_sort_variable (sigma,sm) u s =
-  (sigma, set_sort_variable u s sm)
-let pr_sort_constraints (_,sm) = pr_sort_cstrs sm
+let whd_sort_variable {evars=(_,sm)} t = whd_sort_var sm t
+let set_leq_sort_variable ({evars=(sigma,sm)}as d) u1 u2 =
+  { d with evars = (sigma, set_leq u1 u2 sm) }
+let define_sort_variable ({evars=(sigma,sm)}as d) u s =
+  { d with evars = (sigma, set_sort_variable u s sm) }
+let pr_sort_constraints {evars=(_,sm)} = pr_sort_cstrs sm
 
 (**********************************************************)
 (* Accessing metas *)
@@ -536,7 +613,7 @@ let undefined_metas evd =
     | (n,Cltyp (_,typ))  -> n)
     (meta_list evd))
 
-let metas_of evd = 
+let metas_of evd =
   List.map (function
     | (n,Clval(_,_,typ)) -> (n,typ.rebus)
     | (n,Cltyp (_,typ))  -> (n,typ.rebus))
@@ -544,8 +621,8 @@ let metas_of evd =
 
 let map_metas_fvalue f evd =
   { evd with metas =
-      Metamap.map 
-        (function 
+      Metamap.map
+        (function
           | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ)
           | x -> x) evd.metas }
 
@@ -559,19 +636,28 @@ let meta_defined evd mv =
     | Clval _ -> true
     | Cltyp _ -> false
 
-let meta_fvalue evd mv =
+let try_meta_fvalue evd mv =
   match Metamap.find mv evd.metas with
     | Clval(_,b,_) -> b
-    | Cltyp _ -> anomaly "meta_fvalue: meta has no value"
-           
+    | Cltyp _ -> raise Not_found
+
+let meta_fvalue evd mv =
+  try try_meta_fvalue evd mv
+  with Not_found -> anomaly "meta_fvalue: meta has no value"
+
+let meta_value evd mv =
+  (fst (try_meta_fvalue evd mv)).rebus
+
 let meta_ftype evd mv =
   match Metamap.find mv evd.metas with
     | Cltyp (_,b) -> b
     | Clval(_,_,b) -> b
- 
+
+let meta_type evd mv = (meta_ftype evd mv).rebus
+
 let meta_declare mv v ?(name=Anonymous) evd =
   { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas }
-  
+
 let meta_assign mv (v,pb) evd =
   match Metamap.find mv evd.metas with
   | Cltyp(na,ty) ->
@@ -588,10 +674,7 @@ let meta_reassign mv (v,pb) evd =
 
 (* If the meta is defined then forget its name *)
 let meta_name evd mv =
-  try
-    let (na,def) = clb_name (Metamap.find mv evd.metas) in
-    if def then Anonymous else na
-  with Not_found -> Anonymous
+  try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous
 
 let meta_with_name evd id =
   let na = Name id in
@@ -603,27 +686,28 @@ let meta_with_name evd id =
         else l)
       evd.metas ([],[]) in
   match mvnodef, mvl with
-    | _,[]  -> 
+    | _,[]  ->
 	errorlabstrm "Evd.meta_with_name"
           (str"No such bound variable " ++ pr_id id ++ str".")
-    | ([n],_|_,[n]) -> 
+    | ([n],_|_,[n]) ->
 	n
-    | _  -> 
+    | _  ->
 	errorlabstrm "Evd.meta_with_name"
           (str "Binder name \"" ++ pr_id id ++
            strbrk "\" occurs more than once in clause.")
 
 
+(* spiwack: we should try and replace this List.fold_left by a Metamap.fold.  *)
 let meta_merge evd1 evd2 =
   {evd2 with
-    metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) 
+    metas = List.fold_left (fun m (n,v) -> Metamap.add n v m)
       evd2.metas (metamap_to_list evd1.metas) }
 
 type metabinding = metavariable * constr * instance_status
 
 let retract_coercible_metas evd =
-  let mc,ml = 
-    Metamap.fold (fun n v (mc,ml) -> 
+  let mc,ml =
+    Metamap.fold (fun n v (mc,ml) ->
       match v with
 	| Clval (na,(b,(UserGiven,CoerceToType as s)),typ) ->
 	    (n,b.rebus,s)::mc, Metamap.add n (Cltyp (na,typ)) ml
@@ -636,12 +720,25 @@ let rec list_assoc_in_triple x = function
     [] -> raise Not_found
   | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l
 
-let subst_defined_metas bl c = 
+let subst_defined_metas bl c =
   let rec substrec c = match kind_of_term c with
     | Meta i -> substrec (list_assoc_in_triple i bl)
     | _ -> map_constr substrec c
   in try Some (substrec c) with Not_found -> None
 
+(*******************************************************************)
+type open_constr = evar_map * constr
+
+(*******************************************************************)
+(* The type constructor ['a sigma] adds an evar map to an object of
+  type ['a] *)
+type 'a sigma = {
+  it : 'a ;
+  sigma : evar_map}
+
+let sig_it x = x.it
+let sig_sig x = x.sigma
+
 (**********************************************************)
 (* Failure explanation *)
 
@@ -670,20 +767,22 @@ let pr_meta_map mmap =
     | _ -> mt() in
   let pr_meta_binding = function
     | (mv,Cltyp (na,b)) ->
-      	hov 0 
+      	hov 0
 	  (pr_meta mv ++ pr_name na ++ str " : " ++
            print_constr b.rebus ++ fnl ())
-    | (mv,Clval(na,(b,s),_)) ->
-      	hov 0 
+    | (mv,Clval(na,(b,s),t)) ->
+      	hov 0
 	  (pr_meta mv ++ pr_name na ++ str " := " ++
-           print_constr b.rebus ++ spc () ++ pr_instance_status s ++ fnl ())
+           print_constr b.rebus ++
+	   str " : " ++ print_constr t.rebus ++
+	   spc () ++ pr_instance_status s ++ fnl ())
   in
   prlist pr_meta_binding (metamap_to_list mmap)
 
 let pr_decl ((id,b,_),ok) =
   match b 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 ":=" ++ 
+  | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
       print_constr c ++ str (if ok then ")" else "}")
 
 let pr_evar_info evi =
@@ -697,12 +796,19 @@ let pr_evar_info evi =
   in
   hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
 
-let pr_evar_map sigma =
-  h 0 
-    (prlist_with_sep pr_fnl
-      (fun (ev,evi) ->
-        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
-      (to_list sigma))
+let pr_evar_map_t (evars,cstrs as sigma) =
+  let evs =
+    if evars = EvarInfoMap.empty then mt ()
+    else
+      str"EVARS:"++brk(0,1)++
+	h 0 (prlist_with_sep pr_fnl
+		(fun (ev,evi) ->
+		  h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
+		(EvarMap.to_list sigma))++fnl()
+  and cs =
+    if cstrs = UniverseMap.empty then mt ()
+    else pr_sort_cstrs cstrs++fnl()
+  in evs ++ cs
 
 let pr_constraints pbs =
   h 0
@@ -710,19 +816,20 @@ let pr_constraints pbs =
       print_constr t1 ++ spc() ++
       str (match pbty with
 	| Reduction.CONV -> "=="
-	| Reduction.CUMUL -> "<=") ++ 
+	| Reduction.CUMUL -> "<=") ++
       spc() ++ print_constr t2) pbs)
 
-let pr_evar_defs evd =
+let pr_evar_map evd =
   let pp_evm =
-    if evd.evars = empty then mt() else
-      str"EVARS:"++brk(0,1)++pr_evar_map evd.evars++fnl() in
+    if evd.evars = EvarMap.empty then mt() else
+      pr_evar_map_t evd.evars++fnl() in
   let cstrs =
+    if evd.conv_pbs = [] then mt() else
     str"CONSTRAINTS:"++brk(0,1)++pr_constraints evd.conv_pbs++fnl() in
   let pp_met =
     if evd.metas = Metamap.empty then mt() else
       str"METAS:"++brk(0,1)++pr_meta_map evd.metas in
   v 0 (pp_evm ++ cstrs ++ pp_met)
 
-let pr_metaset metas = 
+let pr_metaset metas =
   str "[" ++ prlist_with_sep spc pr_meta (Metaset.elements metas) ++ str "]"
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index b9cb2142..46f13d5f 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evd.mli 11865 2009-01-28 17:34:30Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -20,84 +20,6 @@ open Mod_subst
 open Termops
 (*i*)
 
-(* The type of mappings for existential variables.
-   The keys are integers and the associated information is a record
-   containing the type of the evar ([evar_concl]), the context under which 
-   it was introduced ([evar_hyps]) and its definition ([evar_body]). 
-   [evar_info] is used to add any other kind of information. *)
-
-type evar = existential_key
-
-type evar_body =
-  | Evar_empty 
-  | Evar_defined of constr
-
-type evar_info = {
-  evar_concl : constr;
-  evar_hyps : named_context_val;
-  evar_body : evar_body;
-  evar_filter : bool list;
-  evar_extra : Dyn.t option}
-
-val eq_evar_info : evar_info -> evar_info -> bool
-
-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_hyps : evar_info -> named_context_val
-val evar_body : evar_info -> evar_body
-val evar_filter : evar_info -> bool list
-val evar_unfiltered_env :  evar_info -> env
-val evar_env :  evar_info -> env
-
-type evar_map
-val eq_evar_map : evar_map -> evar_map -> bool
-
-val empty : evar_map
-
-val add : evar_map -> evar -> evar_info -> evar_map
-
-val dom : evar_map -> evar list
-val find : evar_map -> evar -> evar_info
-val remove : evar_map -> evar -> evar_map
-val mem : evar_map -> evar -> bool
-val to_list : evar_map -> (evar * evar_info) list
-val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-
-val merge : evar_map -> evar_map -> evar_map
-
-val define : evar_map -> evar -> constr -> evar_map
-
-val is_evar : evar_map -> evar -> bool
-
-val is_defined : evar_map -> evar -> bool
-
-val string_of_existential : evar -> string
-val existential_of_int : int -> evar
-
-(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
-    no body and [Not_found] if it does not exist in [sigma] *)
-
-exception NotInstantiatedEvar
-val existential_value : evar_map -> existential -> constr
-val existential_type : evar_map -> existential -> types
-val existential_opt_value : evar_map -> existential -> constr option
-
-(*********************************************************************)
-(* constr with holes *)
-type open_constr = evar_map * constr
-
-(*********************************************************************)
-(* The type constructor ['a sigma] adds an evar map to an object of
-  type ['a] *)
-type 'a sigma = {
-  it : 'a ;
-  sigma : evar_map}
-
-val sig_it  : 'a sigma -> 'a
-val sig_sig : 'a sigma -> evar_map
-
 (*********************************************************************)
 (* Meta map *)
 
@@ -122,7 +44,7 @@ val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
     (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
 *)
 
-type instance_constraint = 
+type instance_constraint =
     IsSuperType | IsSubType | ConvUpToEta of int | UserGiven
 
 (* Status of the unification of the type of an instance against the type of
@@ -153,19 +75,9 @@ type clbinding =
 
 val map_clb : (constr -> constr) -> clbinding -> clbinding
 
-(*********************************************************************)
-(* Unification state *)
-type evar_defs
-
-(* Assume empty [evar_map] and [conv_pbs] *)
-val subst_evar_defs_light : substitution -> evar_defs -> evar_defs
 
-(* create an [evar_defs] with empty meta map: *)
-val create_evar_defs      : evar_map -> evar_defs
-val create_goal_evar_defs : evar_map -> evar_defs
-val empty_evar_defs : evar_defs
-val evars_of         : evar_defs -> evar_map
-val evars_reset_evd  : evar_map ->  evar_defs -> evar_defs
+(*********************************************************************)
+(*** Kinds of existential variables ***)
 
 (* Should the obligation be defined (opaque or transparent (default)) or
    defined transparent and expanded in the term? *)
@@ -174,7 +86,7 @@ type obligation_definition_status = Define of bool | Expand
 
 (* Evars *)
 type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option)
+  | ImplicitArg of global_reference * (int * identifier option) * bool (* Force inference *)
   | BinderType of name
   | QuestionMark of obligation_definition_status
   | CasesType
@@ -182,54 +94,148 @@ type hole_kind =
   | TomatchTypeParameter of inductive * int
   | GoalEvar
   | ImpossibleCase
-val is_defined_evar :  evar_defs -> existential -> bool
-val is_undefined_evar :  evar_defs -> constr -> bool
-val undefined_evars : evar_defs -> evar_defs
+  | MatchingVar of bool * identifier
+
+(*********************************************************************)
+(*** Existential variables and unification states ***)
+
+(* A unification state (of type [evar_map]) is primarily a finite mapping
+    from existential variables to records containing the type of the evar
+   ([evar_concl]), the context under which it was introduced ([evar_hyps])
+   and its definition ([evar_body]). [evar_extra] is used to add any other
+   kind of information.
+   It also contains conversion constraints, debugging information and
+   information about meta variables. *)
+
+(* Information about existential variables. *)
+type evar = existential_key
+
+val string_of_existential : evar -> string
+val existential_of_int : int -> evar
+
+type evar_body =
+  | Evar_empty
+  | Evar_defined of constr
+
+type evar_info = {
+  evar_concl : constr;
+  evar_hyps : named_context_val;
+  evar_body : evar_body;
+  evar_filter : bool list;
+  evar_source : hole_kind located;
+  evar_extra : Dyn.t option}
+
+val eq_evar_info : evar_info -> evar_info -> bool
+
+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_hyps : evar_info -> named_context_val
+val evar_body : evar_info -> evar_body
+val evar_filter : evar_info -> bool list
+val evar_unfiltered_env :  evar_info -> env
+val evar_env :  evar_info -> env
+
+(*** Unification state ***)
+type evar_map
+
+(* Unification state and existential variables *)
+
+(* Assuming that the second map extends the first one, this says if
+   some existing evar has been refined *)
+val progress_evar_map : evar_map -> evar_map -> bool
+
+val empty : evar_map
+val is_empty : evar_map -> bool
+
+val add : evar_map -> evar -> evar_info -> evar_map
+
+val dom : evar_map -> evar list
+val find : evar_map -> evar -> evar_info
+val remove : evar_map -> evar -> evar_map
+val mem : evar_map -> evar -> bool
+val to_list : evar_map -> (evar * evar_info) list
+val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
+
+val merge : evar_map -> evar_map -> evar_map
+
+val define : evar -> constr -> evar_map -> evar_map
+
+val is_evar : evar_map -> evar -> bool
+
+val is_defined : evar_map -> evar -> bool
+
+(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
+    no body and [Not_found] if it does not exist in [sigma] *)
+
+exception NotInstantiatedEvar
+val existential_value : evar_map -> existential -> constr
+val existential_type : evar_map -> existential -> types
+val existential_opt_value : evar_map -> existential -> constr option
+
+(* Assume empty universe constraints in [evar_map] and [conv_pbs] *)
+val subst_evar_defs_light : substitution -> evar_map -> evar_map
+
+(* spiwack: this function seems to somewhat break the abstraction. *)
+val evars_reset_evd  : evar_map ->  evar_map -> evar_map
+
+
+(* spiwack: [is_undefined_evar] should be considered a candidate
+                   for moving to evarutils *)
+val is_undefined_evar :  evar_map -> constr -> bool
+val undefined_evars : evar_map -> evar_map
 val evar_declare :
   named_context_val -> evar -> types -> ?src:loc * hole_kind ->
-      ?filter:bool list -> evar_defs -> evar_defs
-val evar_define : evar -> constr -> evar_defs -> evar_defs
-val evar_source : existential_key -> evar_defs -> loc * hole_kind
+      ?filter:bool list -> evar_map -> evar_map
+val evar_source : existential_key -> evar_map -> loc * hole_kind
+
+(* spiwack: this function seems to somewhat break the abstraction. *)
+(* [evar_merge evd ev1] extends the evars of [evd] with [evd1] *)
+val evar_merge : evar_map -> evar_map -> evar_map
 
-(* [evar_merge evd evars] extends the evars of [evd] with [evars] *)
-val evar_merge : evar_defs -> evar_map -> evar_defs
+val evar_list : evar_map -> constr -> existential list
 
 (* Unification constraints *)
 type conv_pb = Reduction.conv_pb
 type evar_constraint = conv_pb * env * constr * constr
-val add_conv_pb :  evar_constraint -> evar_defs -> evar_defs
-val extract_changed_conv_pbs : evar_defs -> 
-      (existential_key list -> evar_constraint -> bool) ->
-      evar_defs * evar_constraint list
-val extract_all_conv_pbs : evar_defs -> evar_defs * evar_constraint list
+val add_conv_pb :  evar_constraint -> evar_map -> evar_map
+
+module ExistentialSet : Set.S with type elt = existential_key
+val extract_changed_conv_pbs : evar_map ->
+      (ExistentialSet.t -> evar_constraint -> bool) ->
+      evar_map * evar_constraint list
+val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list
 
 
 (* Metas *)
-val find_meta : evar_defs -> metavariable -> clbinding
-val meta_list : evar_defs -> (metavariable * clbinding) list
-val meta_defined : evar_defs -> metavariable -> bool
+val find_meta : evar_map -> metavariable -> clbinding
+val meta_list : evar_map -> (metavariable * clbinding) list
+val meta_defined : evar_map -> metavariable -> bool
 (* [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
-   meta has no value *)  
-val meta_fvalue    : evar_defs -> metavariable -> constr freelisted * instance_status
-val meta_opt_fvalue : evar_defs -> metavariable -> (constr freelisted * instance_status) option
-val meta_ftype     : evar_defs -> metavariable -> constr freelisted
-val meta_name      : evar_defs -> metavariable -> name
-val meta_with_name : evar_defs -> identifier -> metavariable
+   meta has no value *)
+val meta_value     : evar_map -> metavariable -> constr
+val meta_fvalue    : evar_map -> metavariable -> constr freelisted * instance_status
+val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option
+val meta_type      : evar_map -> metavariable -> types
+val meta_ftype     : evar_map -> metavariable -> types freelisted
+val meta_name      : evar_map -> metavariable -> name
+val meta_with_name : evar_map -> identifier -> metavariable
 val meta_declare   :
-  metavariable -> types -> ?name:name -> evar_defs -> evar_defs
-val meta_assign    : metavariable -> constr * instance_status -> evar_defs -> evar_defs
-val meta_reassign  : metavariable -> constr * instance_status -> evar_defs -> evar_defs
+  metavariable -> types -> ?name:name -> evar_map -> evar_map
+val meta_assign    : metavariable -> constr * instance_status -> evar_map -> evar_map
+val meta_reassign  : metavariable -> constr * instance_status -> evar_map -> evar_map
 
 (* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
-val meta_merge : evar_defs -> evar_defs -> evar_defs
+val meta_merge : evar_map -> evar_map -> evar_map
 
-val undefined_metas : evar_defs -> metavariable list
-val metas_of : evar_defs -> metamap
-val map_metas_fvalue : (constr -> constr) -> evar_defs -> evar_defs
+val undefined_metas : evar_map -> metavariable list
+val metas_of : evar_map -> meta_type_map
+val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
 
 type metabinding = metavariable * constr * instance_status
 
-val retract_coercible_metas : evar_defs -> metabinding list * evar_defs
+val retract_coercible_metas : evar_map -> metabinding list * evar_map
 val subst_defined_metas : metabinding list -> constr -> constr option
 
 (**********************************************************)
@@ -241,6 +247,20 @@ val whd_sort_variable : evar_map -> constr -> constr
 val set_leq_sort_variable : evar_map -> sorts -> sorts -> evar_map
 val define_sort_variable : evar_map -> sorts -> sorts -> evar_map
 
+(*********************************************************************)
+(* constr with holes *)
+type open_constr = evar_map * constr
+
+(*********************************************************************)
+(* The type constructor ['a sigma] adds an evar map to an object of
+  type ['a] *)
+type 'a sigma = {
+  it : 'a ;
+  sigma : evar_map}
+
+val sig_it  : 'a sigma -> 'a
+val sig_sig : 'a sigma -> evar_map
+
 (**********************************************************)
 (* Failure explanation *)
 
@@ -250,7 +270,15 @@ type unsolvability_explanation = SeveralInstancesFound of int
 (* debug pretty-printer: *)
 
 val pr_evar_info : evar_info -> Pp.std_ppcmds
-val pr_evar_map  : evar_map -> Pp.std_ppcmds
-val pr_evar_defs : evar_defs -> Pp.std_ppcmds
+val pr_evar_map : evar_map -> Pp.std_ppcmds
 val pr_sort_constraints : evar_map -> Pp.std_ppcmds
 val pr_metaset : Metaset.t -> Pp.std_ppcmds
+
+
+(*** /!\Deprecated /!\ ***)
+(* create an [evar_map] with empty meta map: *)
+val create_evar_defs      : evar_map -> evar_map
+val create_goal_evar_defs : evar_map -> evar_map
+val is_defined_evar :  evar_map -> existential -> bool
+val subst_evar_map : substitution -> evar_map -> evar_map
+(*** /Deprecaded ***)
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 88a0c2a6..1352b383 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -6,7 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indrec.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
+
+(* File initially created by Christine Paulin, 1996 *)
+
+(* This file builds various inductive schemes *)
 
 open Pp
 open Util
@@ -15,6 +19,7 @@ open Libnames
 open Nameops
 open Term
 open Termops
+open Namegen
 open Declarations
 open Entries
 open Inductive
@@ -27,6 +32,8 @@ open Safe_typing
 open Nametab
 open Sign
 
+type dep_flag = bool
+
 (* Errors related to recursors building *)
 type recursion_scheme_error =
   | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive
@@ -34,7 +41,7 @@ type recursion_scheme_error =
 
 exception RecursionSchemeError of recursion_scheme_error
 
-let make_prod_dep dep env = if dep then prod_name env else mkProd
+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)
 
 (*******************************************)
@@ -43,22 +50,16 @@ let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
 
 (**********************************************************************)
 (* Building case analysis schemes *)
-(* Nouvelle version, plus concise mais plus coûteuse à cause de
-   lift_constructor et lift_inductive_family qui ne se contentent pas de 
-   lifter les paramètres globaux *)
+(* Christine Paulin, 1996 *)
 
-let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind =
+let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
   let lnamespar = mib.mind_params_ctxt in
-  let dep = match depopt with 
-    | None -> inductive_sort_family mip <> InProp
-    | Some d -> d
-  in
   if not (List.mem kind (elim_sorts specif)) then
     raise
       (RecursionSchemeError
 	 (NotAllowedCaseAnalysis (false,new_sort_in_family kind,ind)));
 
-  let ndepar = mip.mind_nrealargs + 1 in
+  let ndepar = mip.mind_nrealargs_ctxt + 1 in
 
   (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *)
   (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
@@ -67,7 +68,7 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind =
   let indf = make_ind_family(ind, extended_rel_list 0 lnamespar) in
   let constrs = get_constructors env indf in
 
-  let rec add_branch env k = 
+  let rec add_branch env k =
     if k = Array.length mip.mind_consnames then
       let nbprod = k+1 in
 
@@ -82,7 +83,7 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind =
           (mkRel (ndepar + nbprod),
            if dep then extended_rel_vect 0 deparsign
            else extended_rel_vect 1 arsign) in
-      let p = 
+      let p =
 	it_mkLambda_or_LetIn_name env'
 	  ((if dep then mkLambda_name env' else mkLambda)
 	   (Anonymous,depind,pbody))
@@ -100,27 +101,28 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind =
 	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
   in
   let typP = make_arity env' dep indf (new_sort_in_family kind) in
-  it_mkLambda_or_LetIn_name env 
+  it_mkLambda_or_LetIn_name env
     (mkLambda_string "P" typP
        (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
-    
+
 (* check if the type depends recursively on one of the inductive scheme *)
 
 (**********************************************************************)
 (* Building the recursive elimination *)
+(* Christine Paulin, 1996 *)
 
 (*
- * t is the type of the constructor co and recargs is the information on 
+ * t is the type of the constructor co and recargs is the information on
  * the recursive calls. (It is assumed to be in form given by the user).
  * build the type of the corresponding branch of the recurrence principle
- * assuming f has this type, branch_rec gives also the term 
- *   [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of 
+ * assuming f has this type, branch_rec gives also the term
+ *   [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of
  * the case operation
- * FPvect gives for each inductive definition if we want an elimination 
- * on it with which predicate and which recursive function. 
+ * FPvect gives for each inductive definition if we want an elimination
+ * on it with which predicate and which recursive function.
  *)
 
-let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = 
+let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
   let make_prod = make_prod_dep dep in
   let nparams = List.length vargs in
   let process_pos env depK pk =
@@ -136,39 +138,39 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
      	| Ind (_,_) ->
 	    let realargs = list_skipn nparams largs in
 	    let base = applist (lift i pk,realargs) in
-            if depK then 
+            if depK then
 	      Reduction.beta_appvect
                 base [|applist (mkRel (i+1),extended_rel_list 0 sign)|]
-            else 
+            else
 	      base
-      	| _ -> assert false 
+      	| _ -> assert false
     in
     prec env 0 []
   in
   let rec process_constr env i c recargs nhyps li =
-    if nhyps > 0 then match kind_of_term c with 
+    if nhyps > 0 then match kind_of_term c with
       | Prod (n,t,c_0) ->
-          let (optionpos,rest) = 
-	    match recargs with 
+          let (optionpos,rest) =
+	    match recargs with
 	      | [] -> None,[]
               | ra::rest ->
-                  (match dest_recarg ra with 
+                  (match dest_recarg ra with
 	            | Mrec j when is_rec -> (depPvect.(j),rest)
-	            | Imbr _  -> 
-		        Flags.if_verbose warning "Ignoring recursive call"; 
-		        (None,rest) 
+	            | Imbr _  ->
+		        Flags.if_verbose warning "Ignoring recursive call";
+		        (None,rest)
                     | _ -> (None, rest))
-	  in 
-          (match optionpos with 
-	     | None -> 
+	  in
+          (match optionpos with
+	     | None ->
 		 make_prod env
 		   (n,t,
 		    process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
 		      (nhyps-1) (i::li))
-             | Some(dep',p) -> 
+             | Some(dep',p) ->
 		 let nP = lift (i+1+decP) p in
                  let env' = push_rel (n,None,t) env in
-		 let t_0 = process_pos env' dep' nP (lift 1 t) in 
+		 let t_0 = process_pos env' dep' nP (lift 1 t) in
 		 make_prod_dep (dep or dep') env
                    (n,t,
 		    mkArrow t_0
@@ -190,27 +192,27 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
       else c
   in
   let nhyps = List.length cs.cs_args in
-  let nP = match depPvect.(tyi) with 
+  let nP = match depPvect.(tyi) with
     | Some(_,p) -> lift (nhyps+decP) p
     | _ -> assert false in
   let base = appvect (nP,cs.cs_concl_realargs) in
   let c = it_mkProd_or_LetIn base cs.cs_args in
   process_constr env 0 c recargs nhyps []
 
-let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr 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
       match kind_of_term p' with
 	| Prod (n,t,c) ->
 	    let d = (n,None,t) in
-	    lambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
+	    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
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
-     	| Ind _ -> 
+     	| Ind _ ->
             let realargs = list_skipn nparrec largs
-            and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in 
+            and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
      	| _ -> assert false
     in
@@ -218,24 +220,24 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
   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 -> 
-        let optionpos = 
-	  match dest_recarg recarg with 
+    | (n,None,t as d)::cprest, recarg::rest ->
+        let optionpos =
+	  match dest_recarg recarg with
             | Norec   -> None
             | Imbr _  -> None
             | Mrec i  -> fvect.(i)
-	in 
-        (match optionpos with 
+	in
+        (match optionpos with
            | None ->
-	       lambda_name env
+	       mkLambda_name env
 		 (n,t,process_constr (push_rel d env) (i+1)
 		    (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1)])))
 		    (cprest,rest))
-           | Some(_,f_0) -> 
+           | Some(_,f_0) ->
 	       let nF = lift (i+1+decF) f_0 in
                let env' = push_rel d env in
-	       let arg = process_pos env' nF (lift 1 t) in 
-               lambda_name env
+	       let arg = process_pos env' nF (lift 1 t) in
+               mkLambda_name env
 		 (n,t,process_constr env' (i+1)
 		    (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg])))
 		    (cprest,rest)))
@@ -251,9 +253,9 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
   process_constr env 0 f (List.rev cstr.cs_args, recargs)
 
 
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k 
+(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
    variables *)
-let context_chop k ctx = 
+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)
@@ -266,24 +268,24 @@ let context_chop k ctx =
 let mis_make_indrec env sigma listdepkind mib =
   let nparams = mib.mind_nparams in
   let nparrec = mib. mind_nparams_rec in
-  let lnonparrec,lnamesparrec = 
+  let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
   let nrec = List.length listdepkind in
   let depPvec =
-    Array.create mib.mind_ntypes (None : (bool * constr) option) in 
-  let _ = 
-    let rec 
-	assign k = function 
+    Array.create mib.mind_ntypes (None : (bool * constr) option) in
+  let _ =
+    let rec
+	assign k = function
 	  | [] -> ()
-          | (indi,mibi,mipi,dep,_)::rest -> 
+          | (indi,mibi,mipi,dep,_)::rest ->
               (Array.set depPvec (snd indi) (Some(dep,mkRel k));
                assign (k-1) rest)
-    in 
-      assign nrec listdepkind in 
+    in
+      assign nrec listdepkind in
   let recargsvec =
     Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
   (* recarg information for non recursive parameters *)
-  let rec recargparn l n = 
+  let rec recargparn l n =
     if n = 0 then l else recargparn (mk_norec::l) (n-1) in
   let recargpar = recargparn [] (nparams-nparrec) in
   let make_one_rec p =
@@ -293,80 +295,80 @@ let mis_make_indrec env sigma listdepkind mib =
 	    let tyi = snd indi in
 	    let nctyi =
               Array.length mipi.mind_consnames in (* nb constructeurs du type*)
-	      
+
             (* arity in the context of the fixpoint, i.e.
                P1..P_nrec f1..f_nbconstruct *)
 	    let args = extended_rel_list (nrec+nbconstruct) lnamesparrec in
 	    let indf = make_ind_family(indi,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 nonrecpar = rel_context_length lnonparrec in
 	    let larsign = rel_context_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' = extended_rel_list (dect+nrec) lnamesparrec in
 	    let args'' = extended_rel_list ndepar lnonparrec in
             let indf' = make_ind_family(indi,args'@args'') in
-	      
-	    let branches = 
+
+	    let branches =
 	      let constrs = get_constructors env indf' in
 	      let fi = rel_vect (dect-i-nctyi) nctyi in
-	      let vecfi = Array.map 
+	      let vecfi = Array.map
 		(fun f -> appvect (f,extended_rel_vect ndepar lnonparrec))
-		fi 
+		fi
 	      in
 		array_map3
-		  (make_rec_branch_arg env sigma 
+		  (make_rec_branch_arg env sigma
 		      (nparrec,depPvec,larsign))
-                  vecfi constrs (dest_subterms recargsvec.(tyi)) 
+                  vecfi constrs (dest_subterms recargsvec.(tyi))
 	    in
-	      
-	    let j = (match depPvec.(tyi) with 
-	      | Some (_,c) when isRel c -> destRel c 
-	      | _ -> assert false) 
+
+	    let j = (match depPvec.(tyi) with
+	      | Some (_,c) when isRel c -> destRel c
+	      | _ -> assert false)
 	    in
-	      
+
 	    (* Predicate in the context of the case *)
-	      
+
 	    let depind' = build_dependent_inductive env indf' in
 	    let arsign',_ = get_arity env indf' in
 	    let deparsign' = (Anonymous,None,depind')::arsign' in
-	      
+
 	    let pargs =
-	      let nrpar = extended_rel_list (2*ndepar) lnonparrec 
+	      let nrpar = extended_rel_list (2*ndepar) lnonparrec
 	      and nrar = if dep then extended_rel_list 0 deparsign'
 		else extended_rel_list 1 arsign'
 	      in nrpar@nrar
-		
+
 	    in
 
 	    (* body of i-th component of the mutual fixpoint *)
-	    let deftyi = 
+	    let deftyi =
 	      let ci = make_case_info env indi RegularStyle in
-	      let concl = applist (mkRel (dect+j+ndepar),pargs) in 
+	      let concl = applist (mkRel (dect+j+ndepar),pargs) in
 	      let pred =
-		it_mkLambda_or_LetIn_name env 
+		it_mkLambda_or_LetIn_name env
 		  ((if dep then mkLambda_name env else mkLambda)
 		      (Anonymous,depind',concl))
 		  arsign'
 	      in
 		it_mkLambda_or_LetIn_name env
-		  (mkCase (ci, pred, 
+		  (mkCase (ci, pred,
 		          mkRel 1,
 			  branches))
 		  (lift_rel_context nrec deparsign)
 	    in
-	      
+
 	    (* type of i-th component of the mutual fixpoint *)
-	      
+
 	    let typtyi =
-	      let concl = 
+	      let concl =
 		let pargs = if dep then extended_rel_vect 0 deparsign
 		  else extended_rel_vect 1 arsign
 		in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
@@ -374,25 +376,25 @@ let mis_make_indrec env sigma listdepkind mib =
 		concl
 		deparsign
 	    in
-	      mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) 
+	      mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp)
                 (deftyi::ldef) rest
-        | [] -> 
+        | [] ->
 	    let fixn = Array.of_list (List.rev ln) in
             let fixtyi = Array.of_list (List.rev ltyp) in
-            let fixdef = Array.of_list (List.rev ldef) in 
+            let fixdef = Array.of_list (List.rev ldef) in
             let names = Array.create nrec (Name(id_of_string "F")) in
 	      mkFix ((fixn,p),(names,fixtyi,fixdef))
-      in 
-	mrec 0 [] [] [] 
-    in 
-    let rec make_branch env i = function 
+      in
+	mrec 0 [] [] []
+    in
+    let rec make_branch env i = function
       | (indi,mibi,mipi,dep,_)::rest ->
           let tyi = snd indi in
 	  let nconstr = Array.length mipi.mind_consnames in
-	  let rec onerec env j = 
-	    if j = nconstr then 
-	      make_branch env (i+j) rest 
-	    else 
+	  let rec onerec env j =
+	    if j = nconstr then
+	      make_branch env (i+j) rest
+	    else
 	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
 	      let recarg = recargpar@recarg in
 	      let vargs = extended_rel_list (nrec+i+j) lnamesparrec in
@@ -400,106 +402,107 @@ let mis_make_indrec env sigma listdepkind mib =
 	      let p_0 =
 		type_rec_branch
                   true dep env sigma (vargs,depPvec,i+j) tyi cs recarg
-	      in 
+	      in
 		mkLambda_string "f" p_0
 		  (onerec (push_rel (Anonymous,None,p_0) env) (j+1))
 	  in onerec env 0
-      | [] -> 
+      | [] ->
 	  makefix i listdepkind
     in
-    let rec put_arity env i = function 
-      | (indi,_,_,dep,kinds)::rest -> 
+    let rec put_arity env i = function
+      | (indi,_,_,dep,kinds)::rest ->
 	  let indf = make_ind_family (indi,extended_rel_list i lnamesparrec) in
 	  let typP = make_arity env dep indf (new_sort_in_family kinds) in
 	    mkLambda_string "P" typP
 	      (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
-      | [] -> 
-	  make_branch env 0 listdepkind 
+      | [] ->
+	  make_branch env 0 listdepkind
     in
-      
+
     (* Body on make_one_rec *)
     let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in
-      
+
       if (mis_is_recursive_subset
 	(List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
-	mipi.mind_recargs) 
-      then 
+	mipi.mind_recargs)
+      then
 	let env' = push_rel_context lnamesparrec env in
-	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) 
+	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
 	    lnamesparrec
-      else 
-	mis_make_case_com (Some dep) env sigma indi (mibi,mipi) kind 
-  in 
+      else
+	mis_make_case_com dep env sigma indi (mibi,mipi) kind
+  in
     (* Body of mis_make_indrec *)
     list_tabulate make_one_rec nrec
 
 (**********************************************************************)
 (* This builds elimination predicate for Case tactic *)
 
-let make_case_com depopt env sigma ity kind =
-  let (mib,mip) = lookup_mind_specif env ity in 
-    mis_make_case_com depopt env sigma ity (mib,mip) kind
+let build_case_analysis_scheme env sigma ity dep kind =
+  let (mib,mip) = lookup_mind_specif env ity in
+  mis_make_case_com dep env sigma ity (mib,mip) kind
 
-let make_case_dep env   = make_case_com (Some true) env
-let make_case_nodep env = make_case_com (Some false) env 
-let make_case_gen env   = make_case_com None env
+let build_case_analysis_scheme_default env sigma ity kind =
+  let (mib,mip) = lookup_mind_specif env ity in
+  let dep = inductive_sort_family mip <> InProp in
+  mis_make_case_com dep env sigma ity (mib,mip) kind
 
 
 (**********************************************************************)
-(* [instantiate_indrec_scheme s rec] replace the sort of the scheme
+(* [modify_sort_scheme s rec] replaces the sort of the scheme
    [rec] by [s] *)
 
-let change_sort_arity sort = 
+let change_sort_arity sort =
   let rec drec a = match kind_of_term a with
-    | Cast (c,_,_) -> drec c 
+    | Cast (c,_,_) -> drec c
     | Prod (n,t,c) -> mkProd (n, t, drec c)
     | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c)
     | Sort _ -> mkSort sort
     | _ -> assert false
-  in 
-    drec 
+  in
+    drec
 
 (* [npar] is the number of expected arguments (then excluding letin's) *)
-let instantiate_indrec_scheme sort =
+let modify_sort_scheme sort =
   let rec drec npar elim =
     match kind_of_term elim with
-      | Lambda (n,t,c) -> 
-	  if npar = 0 then 
+      | Lambda (n,t,c) ->
+	  if npar = 0 then
 	    mkLambda (n, change_sort_arity sort t, c)
-	  else 
+	  else
 	    mkLambda (n, t, drec (npar-1) c)
       | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c)
-      | _ -> anomaly "instantiate_indrec_scheme: wrong elimination type"
+      | _ -> anomaly "modify_sort_scheme: wrong elimination type"
   in
   drec
 
 (* Change the sort in the type of an inductive definition, builds the
    corresponding eta-expanded term *)
-let instantiate_type_indrec_scheme sort npars term =
+let weaken_sort_scheme sort npars term =
   let rec drec np elim =
     match kind_of_term elim with
-      | Prod (n,t,c) -> 
-	  if np = 0 then 
+      | Prod (n,t,c) ->
+	  if np = 0 then
             let t' = change_sort_arity sort t in
             mkProd (n, t', c),
             mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1)))
-	  else 
+	  else
             let c',term' = drec (np-1) c in
 	    mkProd (n, t, c'), mkLambda (n, t, term')
       | LetIn (n,b,t,c) -> let c',term' = drec np c in
-           mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') 
-      | _ -> anomaly "instantiate_type_indrec_scheme: wrong elimination type"
+           mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term')
+      | _ -> anomaly "weaken_sort_scheme: wrong elimination type"
   in
   drec npars
 
 (**********************************************************************)
 (* Interface to build complex Scheme *)
-(* Check inductive types only occurs once 
+(* Check inductive types only occurs once
 (otherwise we obtain a meaning less scheme) *)
 
-let check_arities listdepkind = 
+let check_arities listdepkind =
   let _ = List.fold_left
-    (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> 
+    (fun ln ((_,ni as mind),mibi,mipi,dep,kind) ->
        let kelim = elim_sorts (mibi,mipi) in
        if not (List.exists ((=) kind) kelim) then raise
 	 (RecursionSchemeError
@@ -510,56 +513,29 @@ let check_arities listdepkind =
 	    [] listdepkind
   in true
 
-let build_mutual_indrec env sigma = function 
-  | (mind,mib,mip,dep,s)::lrecspec ->
+let build_mutual_induction_scheme env sigma = function
+  | (mind,dep,s)::lrecspec ->
+      let (mib,mip) = Global.lookup_inductive mind in
       let (sp,tyi) = mind in
-      let listdepkind = 
-    	(mind,mib,mip, dep,s)::
+      let listdepkind =
+	(mind,mib,mip,dep,s)::
     	(List.map
-	   (function (mind',mibi',mipi',dep',s') ->
+	   (function (mind',dep',s') ->
 	      let (sp',_) = mind' in
 	      if sp=sp' then
                 let (mibi',mipi') = lookup_mind_specif env mind' in
 		(mind',mibi',mipi',dep',s')
 	      else
-		  raise (RecursionSchemeError (NotMutualInScheme (mind,mind'))))
+		raise (RecursionSchemeError (NotMutualInScheme (mind,mind'))))
 	   lrecspec)
       in
-      let _ = check_arities listdepkind in 
+      let _ = check_arities listdepkind in
       mis_make_indrec env sigma listdepkind mib
-  | _ -> anomaly "build_indrec expects a non empty list of inductive types"
+  | _ -> anomaly "build_induction_scheme expects a non empty list of inductive types"
 
-let build_indrec env sigma ind =
+let build_induction_scheme env sigma ind dep kind =
   let (mib,mip) = lookup_mind_specif env ind in
-  let kind = inductive_sort_family mip in
-  let dep = kind <> InProp in
-    List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
-
-(**********************************************************************)
-(* To handle old Case/Match syntax in Pretyping                       *)
-
-(*****************************************)
-(* To interpret Case and Match operators *)
-(* Expects a dependent predicate *)
-
-let type_rec_branches recursive env sigma indt p c = 
-  let IndType (indf,realargs) = indt in
-  let (ind,params) = dest_ind_family indf in
-  let (mib,mip) = lookup_mind_specif env ind in
-  let recargs = mip.mind_recargs in
-  let tyi = snd ind in
-  let init_depPvec i = if i = tyi then Some(true,p) else None in
-  let depPvec = Array.init mib.mind_ntypes init_depPvec in
-  let constructors = get_constructors env indf in
-  let lft =
-    array_map2
-      (type_rec_branch recursive true env sigma (params,depPvec,0) tyi)
-      constructors (dest_subterms recargs) in
-  (lft,Reduction.beta_appvect p (Array.of_list (realargs@[c])))
-(* Non recursive case. Pb: does not deal with unification
-    let (p,ra,_) = type_case_branches env (ind,params@realargs) pj c in
-    (p,ra)
-*)
+  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
 
 (*s Eliminations. *)
 
@@ -568,51 +544,32 @@ let elimination_suffix = function
   | InSet  -> "_rec"
   | InType -> "_rect"
 
+let case_suffix = "_case"
+
 let make_elimination_ident id s = add_suffix id (elimination_suffix s)
 
 (* Look up function for the default elimination constant *)
 
 let lookup_eliminator ind_sp s =
   let kn,i = ind_sp in
-  let mp,dp,l = repr_kn kn in
+  let mp,dp,l = repr_mind 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 *)
   (* inductive type *)
-  let ref = ConstRef (make_con mp dp (label_of_id id)) in
-  try 
-    let _ = sp_of_global ref in
-    constr_of_global ref
+  try
+    let cst =Global.constant_of_delta
+      (make_con mp dp (label_of_id id)) in
+    let _ = Global.lookup_constant cst in
+      mkConst cst
   with Not_found ->
   (* Then try to get a user-defined eliminator in some other places *)
   (* using short name (e.g. for "eq_rec") *)
-  try constr_of_global (Nametab.locate (make_short_qualid id))
+  try constr_of_global (Nametab.locate (qualid_of_ident id))
   with Not_found ->
     errorlabstrm "default_elim"
       (strbrk "Cannot find the elimination combinator " ++
        pr_id id ++ strbrk ", the elimination of the inductive definition " ++
-       pr_global_env Idset.empty (IndRef ind_sp) ++ 
+       pr_global_env Idset.empty (IndRef ind_sp) ++
        strbrk " on sort " ++ pr_sort_family s ++
        strbrk " is probably not allowed.")
-
-
-(*  let env = Global.env() in
-  let path = sp_of_global None (IndRef ind_sp) in
-  let dir, base = repr_path path in
-  let id = add_suffix base (elimination_suffix s) in
-  (* Try first to get an eliminator defined in the same section as the *)
-  (* inductive type *)
-  try construct_absolute_reference (Names.make_path dir id)
-  with Not_found ->
-  (* Then try to get a user-defined eliminator in some other places *)
-  (* using short name (e.g. for "eq_rec") *)
-    try constr_of_global (Nametab.locate (make_short_qualid id))
-    with Not_found ->
-      errorlabstrm "default_elim"
-	(str "Cannot find the elimination combinator " ++
-           pr_id id ++ spc () ++
-	   str "The elimination of the inductive definition " ++
-           pr_id base ++ spc () ++ str "on sort " ++ 
-           spc () ++ pr_sort_family s ++
-	   str " is probably not allowed")
-*)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index 102c7c7f..91d559e1 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indrec.mli 11562 2008-11-09 11:30:10Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -27,36 +27,41 @@ exception RecursionSchemeError of recursion_scheme_error
 
 (** Eliminations *)
 
-(* These functions build elimination predicate for Case tactic *)
+type dep_flag = bool
 
-val make_case_dep : env -> evar_map -> inductive -> sorts_family -> constr
-val make_case_nodep : env -> evar_map -> inductive -> sorts_family -> constr
-val make_case_gen : env -> evar_map -> inductive -> sorts_family -> constr
+(* Build a case analysis elimination scheme in some sort family *)
 
-(* This builds an elimination scheme associated (using the own arity
-   of the inductive) *)
+val build_case_analysis_scheme : env -> evar_map -> inductive ->
+      dep_flag -> sorts_family -> constr
 
-val build_indrec : env -> evar_map -> inductive -> constr
-val instantiate_indrec_scheme : sorts -> int -> constr -> constr
-val instantiate_type_indrec_scheme : sorts -> int -> constr -> types ->
-  constr * types
+(* Build a dependent case elimination predicate unless type is in Prop *)
 
-(** Complex recursion schemes [Scheme] *)
+val build_case_analysis_scheme_default : env -> evar_map -> inductive ->
+      sorts_family -> constr
 
-val build_mutual_indrec : 
-  env -> evar_map ->
-    (inductive * mutual_inductive_body * one_inductive_body
-    * bool * sorts_family) list
-    -> constr list
+(* Builds a recursive induction scheme (Peano-induction style) in the same
+   sort family as the inductive family; it is dependent if not in Prop *)
 
-(** Old Case/Match typing *)
+val build_induction_scheme : env -> evar_map -> inductive ->
+      dep_flag -> sorts_family -> constr
 
-val type_rec_branches : bool -> env -> evar_map -> inductive_type
-  -> constr -> constr -> constr array * constr
-val make_rec_branch_arg : 
-  env -> evar_map ->
-    int * ('b * constr) option array * int ->
-    constr -> constructor_summary -> wf_paths list -> constr
+(* Builds mutual (recursive) induction schemes *)
+
+val build_mutual_induction_scheme :
+  env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list
+
+(** Scheme combinators *)
+
+(* [modify_sort_scheme s n c] modifies the quantification sort of
+   scheme c whose predicate is abstracted at position [n] of [c] *)
+
+val modify_sort_scheme : sorts -> int -> constr -> constr
+
+(* [weaken_sort_scheme s n c t] derives by subtyping from [c:t]
+   whose conclusion is quantified on [Type] at position [n] of [t] a
+   scheme quantified on sort [s] *)
+
+val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types
 
 (** Recursor names utilities *)
 
@@ -64,5 +69,4 @@ val lookup_eliminator : inductive -> sorts_family -> constr
 val elimination_suffix : sorts_family -> string
 val make_elimination_ident : identifier -> sorts_family -> identifier
 
-
-
+val case_suffix : string
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 9f8c06da..636f8622 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductiveops.ml 11436 2008-10-07 13:56:55Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Names
 open Univ
 open Term
 open Termops
+open Namegen
 open Sign
 open Declarations
 open Environ
@@ -71,16 +72,15 @@ let substnl_ind_type l n = map_inductive_type (substnl l n)
 let mkAppliedInd (IndType ((ind,params), realargs)) =
   applist (mkInd ind,params@realargs)
 
-
-(* Does not consider imbricated or mutually recursive types *) 
-let mis_is_recursive_subset listind rarg = 
-  let rec one_is_rec rvec = 
+(* Does not consider imbricated or mutually recursive types *)
+let mis_is_recursive_subset listind rarg =
+  let rec one_is_rec rvec =
     List.exists
       (fun ra ->
         match dest_recarg ra with
-	  | Mrec i -> List.mem i listind 
+	  | Mrec i -> List.mem i listind
           | _ -> false) rvec
-  in 
+  in
   array_exists one_is_rec (dest_subterms rarg)
 
 let mis_is_recursive (ind,mib,mip) =
@@ -91,7 +91,7 @@ let mis_nf_constructor_type (ind,mib,mip) j =
   let specif = mip.mind_nf_lc
   and ntypes = mib.mind_ntypes
   and nconstr = Array.length mip.mind_consnames in
-  let make_Ik k = mkInd ((fst ind),ntypes-k-1) in 
+  let make_Ik k = mkInd ((fst ind),ntypes-k-1) in
   if j > nconstr then error "Not enough constructors in the type.";
   substl (list_tabulate make_Ik ntypes) specif.(j-1)
 
@@ -102,15 +102,15 @@ let mis_constr_nargs indsp =
   let recargs = dest_subterms mip.mind_recargs in
   Array.map List.length recargs
 
-let mis_constr_nargs_env env (kn,i) = 
+let mis_constr_nargs_env env (kn,i) =
   let mib = Environ.lookup_mind kn env in
-  let mip = mib.mind_packets.(i) in 
+  let mip = mib.mind_packets.(i) in
   let recargs = dest_subterms mip.mind_recargs in
   Array.map List.length recargs
 
 let mis_constructor_nargs_env env ((kn,i),j) =
   let mib = Environ.lookup_mind kn env in
-  let mip = mib.mind_packets.(i) in 
+  let mip = mib.mind_packets.(i) in
   recarg_length mip.mind_recargs j + mib.mind_nparams
 
 let constructor_nrealargs env (ind,j) =
@@ -125,11 +125,15 @@ let get_full_arity_sign env ind =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   mip.mind_arity_ctxt
 
+let nconstructors ind =
+  let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
+  Array.length mip.mind_consnames
+
 (* Length of arity (w/o local defs) *)
 
 let inductive_nargs env ind =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  mib.mind_nparams, mip.mind_nrealargs
+  (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt)
 
 let allowed_sorts env (kn,i as ind) =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
@@ -138,7 +142,7 @@ let allowed_sorts env (kn,i as ind) =
 (* Annotation for cases *)
 let make_case_info env ind style =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let print_info = { ind_nargs = mip.mind_nrealargs; style = style } in
+  let print_info = { ind_nargs = mip.mind_nrealargs_ctxt; style = style } in
   { ci_ind     = ind;
     ci_npar    = mib.mind_nparams;
     ci_cstr_nargs = mip.mind_consnrealdecls;
@@ -172,7 +176,7 @@ let instantiate_params t args sign =
 	(match kind_of_term t with
 	   | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
 	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
-    | ((_,(Some b),_)::ctxt,args) -> 
+    | ((_,(Some b),_)::ctxt,args) ->
 	(match kind_of_term t with
 	   | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
 	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
@@ -249,7 +253,7 @@ let build_dependent_constructor cs =
 let build_dependent_inductive env ((ind, params) as indf) =
   let arsign,_ = get_arity env indf in
   let nrealargs = List.length arsign in
-  applist 
+  applist
     (mkInd ind,
      (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
 
@@ -322,7 +326,7 @@ let find_coinductive env sigma c =
 (* find appropriate names for pattern variables. Useful in the Case
    and Inversion (case_then_using et case_nodep_then_using) tactics. *)
 
-let is_predicate_explicitly_dep env pred arsign = 
+let is_predicate_explicitly_dep env pred arsign =
   let rec srec env pval arsign =
     let pv' = whd_betadeltaiota env Evd.empty pval in
     match kind_of_term pv', arsign with
@@ -330,7 +334,7 @@ let is_predicate_explicitly_dep env pred arsign =
 	  srec (push_rel_assum (na,t) env) b arsign
       | Lambda (na,_,_), _ ->
 
-       (* The following code has impact on the introduction names
+       (* The following code has an impact on the introduction names
 	  given by the tactics "case" and "inversion": when the
 	  elimination is not dependent, "case" uses Anonymous for
 	  inductive types in Prop and names created by mkProd_name for
@@ -370,18 +374,21 @@ let set_pattern_names env ind brv =
   let arities =
     Array.map
       (fun c ->
-        rel_context_length (fst (decompose_prod_assum c)) -
+        rel_context_length ((prod_assum c)) -
         mib.mind_nparams)
       mip.mind_nf_lc in
   array_map2 (set_names env) arities brv
 
-
-let type_case_branches_with_names env indspec pj c =
+let type_case_branches_with_names env indspec p c =
   let (ind,args) = indspec in
-  let (lbrty,conclty,_) = Inductive.type_case_branches env indspec pj c in
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let params = list_firstn mib.mind_nparams args in
-  if is_elim_predicate_explicitly_dependent env pj.uj_val (ind,params) then
+  let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in
+  let nparams = mib.mind_nparams in
+  let (params,realargs) = list_chop nparams args in
+  let lbrty = Inductive.build_branches_type ind specif params p in
+  (* Build case type *)
+  let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in
+  (* Adjust names *)
+  if is_elim_predicate_explicitly_dependent env p (ind,params) then
     (set_pattern_names env ind lbrty, conclty)
   else (lbrty, conclty)
 
@@ -399,7 +406,7 @@ let arity_of_case_predicate env (ind,params) dep k =
 (* Check if u (sort of a parameter) appears in the sort of the
    inductive (is). This is done by trying to enforce u > u' >= is
    in the empty univ graph. If an inconsistency appears, then
-   is depends on u. *)  
+   is depends on u. *)
 let is_constrained is u =
   try
     let u' = fresh_local_univ() in
@@ -450,7 +457,7 @@ let type_of_inductive_knowing_conclusion env mip conclty =
 (* A function which checks that a term well typed verifies both
    syntactic conditions *)
 
-let control_only_guard env c = 
+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
@@ -458,12 +465,12 @@ let control_only_guard env c =
 	Inductive.check_fix e fix
     | _ -> ()
   in
-  let rec iter env c = 
-    check_fix_cofix env c; 
+  let rec iter env c =
+    check_fix_cofix env c;
     iter_constr_with_full_binders push_rel iter env c
   in
   iter env c
 
-let subst_inductive subst (kn,i as ind) = 
-  let kn' = Mod_subst.subst_kn subst kn in
+let subst_inductive subst (kn,i as ind) =
+  let kn' = Mod_subst.subst_ind subst kn in
   if kn == kn' then ind else (kn',i)
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 1cf940cb..a9a51d9a 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductiveops.mli 11436 2008-10-07 13:56:55Z barras $ i*)
+(*i $Id$ i*)
 
 open Names
 open Term
@@ -58,7 +58,9 @@ val mis_nf_constructor_type :
 val mis_constr_nargs : inductive -> int array
 val mis_constr_nargs_env : env -> inductive -> int array
 
-(* Return number of expected parameters and of expected real arguments *)
+val nconstructors : inductive -> int
+
+(* Return the lengths of parameters signature and real arguments signature *)
 val inductive_nargs : env -> inductive -> int * int
 
 val mis_constructor_nargs_env : env -> constructor -> int
@@ -75,7 +77,7 @@ type constructor_summary = {
   cs_cstr : constructor;
   cs_params : constr list;
   cs_nargs : int;
-  cs_args : Sign.rel_context;
+  cs_args : rel_context;
   cs_concl_realargs : constr array;
 }
 val lift_constructor : int -> constructor_summary -> constructor_summary
@@ -86,7 +88,7 @@ val get_arity        : env -> inductive_family -> rel_context * sorts_family
 val get_constructors : env -> inductive_family -> constructor_summary array
 val build_dependent_constructor : constructor_summary -> constr
 val build_dependent_inductive   : env -> inductive_family -> constr
-val make_arity_signature : env -> bool -> inductive_family -> Sign.rel_context
+val make_arity_signature : env -> bool -> inductive_family -> rel_context
 val make_arity : env -> bool -> inductive_family -> sorts -> types
 val build_branch_type : env -> bool -> constr -> constructor_summary -> types
 
@@ -104,11 +106,11 @@ val arity_of_case_predicate :
   env -> inductive_family -> bool -> sorts -> types
 
 val type_case_branches_with_names :
-  env -> inductive * constr list -> unsafe_judgment -> constr ->
+  env -> inductive * constr list -> constr -> constr ->
     types array * types
 val make_case_info : env -> inductive -> case_style -> case_info
 
-(*i Compatibility 
+(*i Compatibility
 val make_default_case_info : env -> case_style -> inductive -> case_info
 i*)
 
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
index 93bac98e..45432ec0 100644
--- a/pretyping/matching.ml
+++ b/pretyping/matching.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: matching.ml 11735 2009-01-02 17:22:31Z herbelin $ *)
+(* $Id$ *)
 
 (*i*)
 open Util
@@ -48,9 +48,10 @@ type bound_ident_map = (identifier * identifier) list
 
 exception PatternMatchingFailure
 
-let constrain (n,m) (names,terms as subst) =
+let constrain (n,(ids,m as x)) (names,terms as subst) =
   try
-    if eq_constr m (List.assoc n terms) then subst
+    let (ids',m') = List.assoc n terms in
+    if ids = ids' && eq_constr m m' then subst
     else raise PatternMatchingFailure
   with
       Not_found ->
@@ -58,14 +59,14 @@ let constrain (n,m) (names,terms as subst) =
           Flags.if_verbose Pp.warning
               ("Collision between bound variable "^string_of_id n^
                  " and a metavariable of same name.");
-        (names,(n,m)::terms)
+        (names,(n,x)::terms)
 
 let add_binders na1 na2 (names,terms as subst) =
   match na1, na2 with
   | Name id1, Name id2 ->
       if List.mem_assoc id1 names then
         (Flags.if_verbose Pp.warning
-          ("Collision between bound variables of name"^string_of_id id1);
+          ("Collision between bound variables of name "^string_of_id id1);
          (names,terms))
       else
         (if List.mem_assoc id1 terms then
@@ -75,15 +76,15 @@ let add_binders na1 na2 (names,terms as subst) =
          ((id1,id2)::names,terms));
   | _ -> subst
 
-let build_lambda toabstract stk (m : constr) = 
-  let rec buildrec m p_0 p_1 = match p_0,p_1 with 
+let build_lambda toabstract stk (m : constr) =
+  let rec buildrec m p_0 p_1 = match p_0,p_1 with
     | (_, []) -> m
-    | (n, (na,t)::tl) -> 
+    | (n, (_,na,t)::tl) ->
 	if List.mem n toabstract then
           buildrec (mkLambda (na,t,m)) (n+1) tl
-        else 
+        else
 	  buildrec (lift (-1) m) (n+1) tl
-  in 
+  in
   buildrec m 1 stk
 
 let memb_metavars m n =
@@ -98,7 +99,58 @@ let same_case_structure (_,cs1,ind,_) ci2 br1 br2 =
   | Some ind -> ind = ci2.ci_ind
   | None -> cs1 = ci2.ci_cstr_nargs
 
-let matches_core convert allow_partial_app pat c = 
+let rec list_insert f a = function
+  | [] -> [a]
+  | b::l when f a b -> a::b::l
+  | b::l when a = b -> raise PatternMatchingFailure
+  | b::l -> b :: list_insert f a l
+
+let extract_bound_vars =
+  let rec aux k = function
+  | ([],_) -> []
+  | (n::l,(na1,na2,_)::stk) when k = n ->
+      begin match na1,na2 with
+      | Name id1,Name _ -> list_insert (<) id1 (aux (k+1) (l,stk))
+      | Name _,Anonymous -> anomaly "Unnamed bound variable"
+      | Anonymous,_ -> raise PatternMatchingFailure
+      end
+  | (l,_::stk) -> aux (k+1) (l,stk)
+  | (_,[]) -> assert false
+  in aux 1
+
+let dummy_constr = mkProp
+
+let rec make_renaming ids = function
+  | (Name id,Name _,_)::stk ->
+      let renaming = make_renaming ids stk in
+      (try mkRel (list_index id ids) :: renaming
+       with Not_found -> dummy_constr :: renaming)
+  | (_,_,_)::stk ->
+      dummy_constr :: make_renaming ids stk
+  | [] ->
+      []
+
+let merge_binding allow_bound_rels stk n cT subst =
+  let depth = List.length stk in
+  let c =
+    if depth = 0 then
+      (* Optimization *)
+      ([],cT)
+    else
+      let frels = Intset.elements (free_rels cT) in
+      let frels = List.filter (fun i -> i <= depth) frels in
+      if allow_bound_rels then
+	let frels = Sort.list (<) frels in
+	let canonically_ordered_vars = extract_bound_vars (frels,stk) in
+	let renaming = make_renaming canonically_ordered_vars stk in
+	(canonically_ordered_vars, substl renaming cT)
+      else if frels = [] then
+	([],lift (-depth) cT)
+      else
+	raise PatternMatchingFailure in
+  constrain (n,c) subst
+
+let matches_core convert allow_partial_app allow_bound_rels pat c =
   let conv = match convert with
     | None -> eq_constr
     | Some (env,sigma) -> is_conv env sigma in
@@ -114,21 +166,11 @@ let matches_core convert allow_partial_app pat c =
 	      args in
 	  let frels = Intset.elements (free_rels cT) in
 	  if list_subset frels relargs then
-	    constrain (n,build_lambda relargs stk cT) subst
+	    constrain (n,([],build_lambda relargs stk cT)) subst
 	  else
 	    raise PatternMatchingFailure
 
-      | PMeta (Some n), m ->
-	  let depth = List.length stk in
-          if depth = 0 then
-            (* Optimisation *)
-            constrain (n,cT) subst
-          else
-	    let frels = Intset.elements (free_rels cT) in
-            if List.for_all (fun i -> i > depth) frels then
-	      constrain (n,lift (-depth) cT) subst
-            else 
-	      raise PatternMatchingFailure
+      | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst
 
       | PMeta None, m -> subst
 
@@ -153,14 +195,8 @@ let matches_core convert allow_partial_app pat c =
           let p = Array.length args2 - Array.length args1 in
           if p>=0 then
             let args21, args22 = array_chop p args2 in
-            let subst =
-	      let depth = List.length stk in
-              let c = mkApp(c2,args21) in
-	      let frels = Intset.elements (free_rels c) in
-              if List.for_all (fun i -> i > depth) frels then
-	        constrain (n,lift (-depth) c) subst
-              else
-	        raise PatternMatchingFailure in
+	    let c = mkApp(c2,args21) in
+            let subst = merge_binding allow_bound_rels stk n c subst in
             array_fold_left2 (sorec stk) subst args1 args22
           else raise PatternMatchingFailure
 
@@ -169,15 +205,15 @@ let matches_core convert allow_partial_app pat c =
          with Invalid_argument _ -> raise PatternMatchingFailure)
 
       | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
-	  sorec ((na2,c2)::stk)
+	  sorec ((na1,na2,c2)::stk)
             (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
 
       | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
-	  sorec ((na2,c2)::stk)
+	  sorec ((na1,na2,c2)::stk)
             (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
 
       | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
-	  sorec ((na2,t2)::stk)
+	  sorec ((na1,na2,t2)::stk)
             (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
 
       | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
@@ -186,8 +222,10 @@ let matches_core convert allow_partial_app pat c =
 	  let n = rel_context_length ctx in
           let n' = rel_context_length ctx' in
 	  if noccur_between 1 n b2 & noccur_between 1 n' b2' then
-	    let s = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx in
-	    let s' = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx' in
+	    let s =
+	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in
+	    let s' =
+	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in
 	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
   	    sorec s' (sorec s (sorec stk subst a1 a2) b1 b2) b1' b2'
           else
@@ -195,7 +233,7 @@ let matches_core convert allow_partial_app pat c =
 
       | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) ->
 	  if same_case_structure ci1 ci2 br1 br2 then
-  	    array_fold_left2 (sorec stk) 
+  	    array_fold_left2 (sorec stk)
 	      (sorec stk (sorec stk subst a1 a2) p1 p2) br1 br2
           else
             raise PatternMatchingFailure
@@ -208,16 +246,20 @@ let matches_core convert allow_partial_app pat c =
   let names,terms = sorec [] ([],[]) pat c in
   (names,Sort.list (fun (a,_) (b,_) -> a<b) terms)
 
-let extended_matches = matches_core None true
+let matches_core_closed convert allow_partial_app pat c =
+  let names,subst = matches_core convert allow_partial_app false pat c in
+  (names, List.map (fun (a,(_,b)) -> (a,b)) subst)
+
+let extended_matches = matches_core None true true
 
-let matches c p = snd (matches_core None true c p)
+let matches c p = snd (matches_core_closed None true c p)
 
 let special_meta = (-1)
 
 (* Tells if it is an authorized occurrence and if the instance is closed *)
 let authorized_occ partial_app closed pat c mk_ctx next =
-  try 
-    let sigma = matches_core None partial_app pat c in
+  try
+    let sigma = matches_core_closed None partial_app pat c in
     if closed && not (List.for_all (fun (_,c) -> closed0 c) (snd sigma))
     then next ()
     else sigma, mk_ctx (mkMeta special_meta), next
@@ -251,7 +293,7 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c =
           if topdown then
             let lc1 = Array.sub lc 0 (Array.length lc - 1) in
             let app = mkApp (c1,lc1) in
-            let mk_ctx = function 
+            let mk_ctx = function
               | [app';c] -> mk_ctx (mkApp (app',[|c|]))
               | _ -> assert false in
 	    try_aux [app;array_last lc] mk_ctx next
@@ -274,7 +316,7 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c =
 	  try_aux (c1::Array.to_list lc) mk_ctx next)
   | Case (ci,hd,c1,lc) ->
       authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let mk_ctx le = 
+        let mk_ctx le =
           mk_ctx (mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) in
         try_aux (c1::Array.to_list lc) mk_ctx next)
   | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _
@@ -310,7 +352,7 @@ let is_matching_appsubterm ?(closed=true) pat c =
   with PatternMatchingFailure -> false
 
 let matches_conv env sigma c p =
-  snd (matches_core (Some (env,sigma)) false c p)
+  snd (matches_core_closed (Some (env,sigma)) false c p)
 
 let is_matching_conv env sigma pat n =
   try let _ = matches_conv env sigma pat n in true
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
index b54a17b7..e8f23b1f 100644
--- a/pretyping/matching.mli
+++ b/pretyping/matching.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: matching.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -34,8 +34,8 @@ val matches : constr_pattern -> constr -> patvar_map
    in [c] that matches the bound variables in [pat]; if several bound
    variables or metavariables have the same name, the metavariable,
    or else the rightmost bound variable, takes precedence *)
-val extended_matches : 
-  constr_pattern -> constr -> bound_ident_map * patvar_map
+val extended_matches :
+  constr_pattern -> constr -> bound_ident_map * extended_patvar_map
 
 (* [is_matching pat c] just tells if [c] matches against [pat] *)
 val is_matching : constr_pattern -> constr -> bool
@@ -59,14 +59,14 @@ type subterm_matching_result =
 val match_subterm : constr_pattern -> constr -> subterm_matching_result
 
 (* [match_appsubterm pat c] returns the substitution and the context
-   corresponding to the first **closed** subterm of [c] matching [pat], 
+   corresponding to the first **closed** subterm of [c] matching [pat],
    considering application contexts as well. It also returns a
    continuation that looks for the next matching subterm.
    It raises PatternMatchingFailure if no subterm matches the pattern *)
 val match_appsubterm : constr_pattern -> constr -> subterm_matching_result
 
 (* [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
-val match_subterm_gen : bool (* true = with app context *) -> 
+val match_subterm_gen : bool (* true = with app context *) ->
    constr_pattern -> constr -> subterm_matching_result
 
 (* [is_matching_appsubterm pat c] tells if a subterm of [c] matches
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
new file mode 100644
index 00000000..7d141faf
--- /dev/null
+++ b/pretyping/namegen.ml
@@ -0,0 +1,312 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Created from contents that was formerly in termops.ml and
+   nameops.ml, Nov 2009 *)
+
+(* This file is about generating new or fresh names and dealing with
+   alpha-renaming *)
+
+open Util
+open Names
+open Term
+open Nametab
+open Nameops
+open Libnames
+open Environ
+open Termops
+
+(**********************************************************************)
+(* Globality of identifiers *)
+
+let rec is_imported_modpath mp =
+  let current_mp,_ = Lib.current_prefix() in
+    match mp with
+      | MPfile dp ->
+	  let rec find_prefix = function
+	    |MPfile dp1 -> not (dp1=dp)
+	    |MPdot(mp,_) -> find_prefix mp
+	    |MPbound(_) -> false
+	  in find_prefix current_mp
+      | p -> false
+
+let is_imported_ref = function
+  | VarRef _ -> false
+  | IndRef (kn,_)
+  | ConstructRef ((kn,_),_) ->
+      let (mp,_,_) = repr_mind kn in is_imported_modpath mp
+  | ConstRef kn ->
+      let (mp,_,_) = repr_con kn in is_imported_modpath mp
+
+let is_global id =
+  try
+    let ref = locate (qualid_of_ident id) in
+    not (is_imported_ref ref)
+  with Not_found ->
+    false
+
+let is_constructor id =
+  try
+    match locate (qualid_of_ident id) with
+      | ConstructRef _ as ref -> not (is_imported_ref ref)
+      | _ -> false
+  with Not_found ->
+    false
+
+(**********************************************************************)
+(* Generating "intuitive" names from its type *)
+
+let lowercase_first_char id = (* First character of a constr *)
+  lowercase_first_char_utf8 (string_of_id id)
+
+let sort_hdchar = function
+  | Prop(_) -> "P"
+  | Type(_) -> "T"
+
+let hdchar env c =
+  let rec hdrec k c =
+    match kind_of_term c with
+    | Prod (_,_,c)    -> hdrec (k+1) c
+    | Lambda (_,_,c)  -> hdrec (k+1) c
+    | LetIn (_,_,_,c) -> hdrec (k+1) c
+    | Cast (c,_,_)    -> hdrec k c
+    | App (f,l)       -> hdrec k f
+    | Const kn -> lowercase_first_char (id_of_label (con_label kn))
+    | Ind x -> lowercase_first_char (basename_of_global (IndRef x))
+    | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x))
+    | Var id  -> lowercase_first_char id
+    | Sort s -> sort_hdchar s
+    | Rel n ->
+	(if n<=k then "p" (* the initial term is flexible product/function *)
+	 else
+	   try match Environ.lookup_rel (n-k) env with
+	     | (Name id,_,_)   -> lowercase_first_char id
+	     | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
+	   with Not_found -> "y")
+    | Fix ((_,i),(lna,_,_)) ->
+	let id = match lna.(i) with Name id -> id | _ -> assert false in
+	lowercase_first_char id
+    | CoFix (i,(lna,_,_)) ->
+	let id = match lna.(i) with Name id -> id | _ -> assert false in
+	lowercase_first_char id
+    | Meta _|Evar _|Case (_, _, _, _) -> "y"
+  in
+  hdrec 0 c
+
+let id_of_name_using_hdchar env a = function
+  | Anonymous -> id_of_string (hdchar env a)
+  | Name id   -> id
+
+let named_hd env a = function
+  | Anonymous -> Name (id_of_string (hdchar env a))
+  | x         -> x
+
+let mkProd_name   env (n,a,b) = mkProd (named_hd env a n, a, b)
+let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b)
+
+let lambda_name = mkLambda_name
+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_context env hyps =
+  snd
+    (List.fold_left
+       (fun (env,hyps) d ->
+	  let d' = name_assumption env d in (push_rel d' env, d' :: hyps))
+       (env,[]) (List.rev hyps))
+
+let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b
+let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b
+
+let it_mkProd_or_LetIn_name env b hyps =
+  it_mkProd_or_LetIn ~init:b (name_context env hyps)
+let it_mkLambda_or_LetIn_name env b hyps =
+  it_mkLambda_or_LetIn ~init:b (name_context env hyps)
+
+(**********************************************************************)
+(* Fresh names *)
+
+let default_x = id_of_string "x"
+
+(* Looks for next "good" name by lifting subscript *)
+
+let next_ident_away_from id bad =
+  let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in
+  name_rec id
+
+(* Restart subscript from x0 if name starts with xN, or x00 if name
+   starts with x0N, etc *)
+
+let restart_subscript id =
+  if not (has_subscript id) then id else
+    (* Ce serait sans doute mieux avec quelque chose inspiré de
+     *** make_ident id (Some 0) *** mais ça brise la compatibilité... *)
+    forget_subscript id
+
+(* Now, there are different renaming strategies... *)
+
+(* 1- Looks for a fresh name for printing in cases pattern *)
+
+let next_name_away_in_cases_pattern na avoid =
+  let id = match na with Name id -> id | Anonymous -> default_x in
+  next_ident_away_from id (fun id -> List.mem id avoid or is_constructor id)
+
+(* 2- Looks for a fresh name for introduction in goal *)
+
+(* The legacy strategy for renaming introduction variables is not very uniform:
+   - if the name to use is fresh in the context but used as a global
+     name, then a fresh name is taken by finding a free subscript
+     starting from the current subscript;
+   - but if the name to use is not fresh in the current context, the fresh
+     name is taken by finding a free subscript starting from 0 *)
+
+let next_ident_away_in_goal id avoid =
+  let id = if List.mem id avoid then restart_subscript id else id in
+  let bad id = List.mem id avoid || (is_global id & not (is_section_variable id)) in
+  next_ident_away_from id bad
+
+let next_name_away_in_goal na avoid =
+  let id = match na with Name id -> id | Anonymous -> id_of_string "H" in
+  next_ident_away_in_goal id avoid
+
+(* 3- Looks for next fresh name outside a list that is moreover valid
+   as a global identifier; the legacy algorithm is that if the name is
+   already used in the list, one looks for a name of same base with
+   lower available subscript; if the name is not in the list but is
+   used globally, one looks for a name of same base with lower subscript
+   beyond the current subscript *)
+
+let next_global_ident_away id avoid =
+  let id = if List.mem id avoid then restart_subscript id else id in
+  let bad id = List.mem id avoid || is_global id in
+  next_ident_away_from id bad
+
+(* 4- Looks for next fresh name outside a list; if name already used,
+   looks for same name with lower available subscript *)
+
+let next_ident_away id avoid =
+  if List.mem id avoid then
+    next_ident_away_from (restart_subscript id) (fun id -> List.mem id avoid)
+  else id
+
+let next_name_away_with_default default na avoid =
+  let id = match na with Name id -> id | Anonymous -> id_of_string default in
+  next_ident_away id avoid
+
+let next_name_away = next_name_away_with_default "H"
+
+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 ->
+       let id = next_name_away na !avoid in
+       avoid := id::!avoid;
+       push_rel (Name id,c,t) newenv)
+    env
+
+(* 5- Looks for next fresh name outside a list; avoids also to use names that
+   would clash with short name of global references; if name is already used,
+   looks for name of same base with lower available subscript beyond current
+   subscript *)
+
+let visibly_occur_id id c =
+  let rec occur c = match kind_of_term c with
+    | Const _ | Ind _ | Construct _ | Var _
+	  when shortest_qualid_of_global Idset.empty (global_of_constr c)
+	    = qualid_of_ident id -> raise Occur
+    | _ -> iter_constr occur c
+  in
+  try occur c; false
+  with Occur -> true
+    | Not_found -> false (* Happens when a global is not in the env *)
+
+let next_ident_away_for_default_printing t id avoid =
+  let bad id = List.mem id avoid or visibly_occur_id id t in
+  next_ident_away_from id bad
+
+let next_name_away_for_default_printing t na avoid =
+  let id = match na with
+  | Name id   -> id
+  | Anonymous ->
+      (* In principle, an anonymous name is not dependent and will not be *)
+      (* taken into account by the function compute_displayed_name_in; *)
+      (* just in case, invent a valid name *)
+      id_of_string "H" in
+  next_ident_away_for_default_printing t id avoid
+
+(**********************************************************************)
+(* Displaying terms avoiding bound variables clashes *)
+
+(* Renaming strategy introduced in December 1998:
+
+   - Rule number 1: all names, even if unbound and not displayed, contribute
+     to the list of names to avoid
+   - Rule number 2: only the dependency status is used for deciding if
+     a name is displayed or not
+
+   Example:
+   bool_ind: "forall (P:bool->Prop)(f:(P true))(f:(P false))(b:bool), P b" is
+   displayed "forall P:bool->Prop, P true -> P false -> forall b:bool, P b"
+   but f and f0 contribute to the list of variables to avoid (knowing
+   that f and f0 are how the f's would be named if introduced, assuming
+   no other f and f0 are already used).
+*)
+
+type renaming_flags =
+  | RenamingForCasesPattern
+  | RenamingForGoal
+  | RenamingElsewhereFor of constr
+
+let next_name_for_display flags =
+  match flags with
+  | RenamingForCasesPattern -> next_name_away_in_cases_pattern
+  | RenamingForGoal -> next_name_away_in_goal
+  | RenamingElsewhereFor t -> next_name_away_for_default_printing t
+
+(* Remark: Anonymous var may be dependent in Evar's contexts *)
+let compute_displayed_name_in flags avoid na c =
+  if na = Anonymous & noccurn 1 c then
+    (Anonymous,avoid)
+  else
+    let fresh_id = next_name_for_display flags na avoid in
+    let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
+    (idopt, fresh_id::avoid)
+
+let compute_and_force_displayed_name_in flags avoid na c =
+  if na = Anonymous & noccurn 1 c then
+    (Anonymous,avoid)
+  else
+    let fresh_id = next_name_for_display flags na avoid in
+    (Name fresh_id, fresh_id::avoid)
+
+let compute_displayed_let_name_in flags avoid na c =
+  let fresh_id = next_name_for_display flags na avoid in
+  (Name fresh_id, fresh_id::avoid)
+
+let rec rename_bound_vars_as_displayed avoid c =
+  let rec rename avoid c =
+    match kind_of_term c with
+    | Prod (na,c1,c2)  ->
+	let na',avoid' = compute_displayed_name_in (RenamingElsewhereFor c2) avoid na c2 in
+	mkProd (na', c1, rename avoid' c2)
+    | LetIn (na,c1,t,c2) ->
+	let na',avoid' = compute_displayed_let_name_in (RenamingElsewhereFor c2) avoid na c2 in
+	mkLetIn (na',c1,t, rename avoid' c2)
+    | Cast (c,k,t) -> mkCast (rename avoid c, k,t)
+    | _ -> c
+  in
+  rename avoid c
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
new file mode 100644
index 00000000..096c09b5
--- /dev/null
+++ b/pretyping/namegen.mli
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Names
+open Term
+open Environ
+
+(**********************************************************************)
+(* Generating "intuitive" names from their type *)
+
+val lowercase_first_char : identifier -> string
+val sort_hdchar : sorts -> string
+val hdchar : env -> types -> string
+val id_of_name_using_hdchar : env -> types -> name -> identifier
+val named_hd : env -> types -> name -> name
+
+val mkProd_name : env -> name * types * types -> types
+val mkLambda_name : env -> name * types * constr -> constr
+
+(* Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
+val prod_name : env -> name * types * types -> types
+val lambda_name : env -> name * types * constr -> constr
+
+val prod_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 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
+
+(**********************************************************************)
+(* Fresh names *)
+
+(* Avoid clashing with a name of the given list *)
+val next_ident_away : identifier -> identifier list -> identifier
+
+(* Avoid clashing with a name already used in current module *)
+val next_ident_away_in_goal : identifier -> identifier list -> identifier
+
+(* Avoid clashing with a name already used in current module *)
+(* but tolerate overwriting section variables, as in goals *)
+val next_global_ident_away : identifier -> identifier list -> identifier
+
+(* Avoid clashing with a constructor name already used in current module *)
+val next_name_away_in_cases_pattern : name -> identifier list -> identifier
+
+val next_name_away  : name -> identifier list -> identifier (* default is "H" *)
+val next_name_away_with_default : string -> name -> identifier list ->
+  identifier
+
+(**********************************************************************)
+(* Making name distinct for displaying *)
+
+type renaming_flags =
+  | RenamingForCasesPattern (* avoid only global constructors *)
+  | RenamingForGoal (* avoid all globals (as in intro) *)
+  | RenamingElsewhereFor of constr
+
+val make_all_name_different : env -> env
+
+val compute_displayed_name_in :
+  renaming_flags -> identifier list -> name -> constr -> name * identifier list
+val compute_and_force_displayed_name_in :
+  renaming_flags -> identifier list -> name -> constr -> name * identifier list
+val compute_displayed_let_name_in :
+  renaming_flags -> identifier list -> name -> constr -> name * identifier list
+val rename_bound_vars_as_displayed : identifier list -> types -> types
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index 057f9d1c..38da0a71 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/pattern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pattern.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -21,8 +21,10 @@ open Mod_subst
 
 (* Metavariables *)
 
+type constr_under_binders = identifier list * constr
+
 type patvar_map = (patvar * constr) list
-let pr_patvar = pr_id
+type extended_patvar_map = (patvar * constr_under_binders) list
 
 (* Patterns *)
 
@@ -69,8 +71,8 @@ exception BoundPattern;;
 
 let rec head_pattern_bound t =
   match t with
-    | PProd (_,_,b)  -> head_pattern_bound b 
-    | PLetIn (_,_,b) -> head_pattern_bound b 
+    | PProd (_,_,b)  -> head_pattern_bound b
+    | PLetIn (_,_,b) -> head_pattern_bound b
     | PApp (c,args)  -> head_pattern_bound c
     | PIf (c,_,_)  -> head_pattern_bound c
     | PCase (_,p,c,br) -> head_pattern_bound c
@@ -89,7 +91,11 @@ let head_of_constr_reference c = match kind_of_term c with
   | Var id -> VarRef id
   | _ -> anomaly "Not a rigid reference"
 
-let rec pattern_of_constr t =
+open Evd
+
+let pattern_of_constr sigma t =
+  let ctx = ref [] in
+  let rec pattern_of_constr t =
   match kind_of_term t with
     | Rel n  -> PRel n
     | Meta n -> PMeta (Some (id_of_string ("META" ^ string_of_int n)))
@@ -100,11 +106,29 @@ let rec pattern_of_constr t =
     | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b)
     | Prod (na,c,b)   -> PProd (na,pattern_of_constr c,pattern_of_constr b)
     | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b)
-    | App (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a)
-    | Const sp         -> PRef (ConstRef sp)
-    | Ind sp        -> PRef (IndRef sp)
-    | Construct sp -> PRef (ConstructRef sp)
-    | Evar (n,ctxt) -> PEvar (n,Array.map pattern_of_constr ctxt)
+    | App (f,a) ->
+        (match 
+          match kind_of_term f with
+            Evar (evk,args as ev) ->
+              (match snd (Evd.evar_source evk sigma) with
+                  MatchingVar (true,id) ->
+                    ctx := (id,None,existential_type sigma ev)::!ctx;
+                    Some id
+                | _ -> None)
+            | _ -> None
+          with
+            | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a))
+            | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a))
+    | Const sp         -> PRef (ConstRef (constant_of_kn(canonical_con sp)))
+    | Ind sp        -> PRef (canonical_gr (IndRef sp))
+    | Construct sp -> PRef (canonical_gr (ConstructRef sp))
+    | Evar (evk,ctxt as ev) ->
+        (match snd (Evd.evar_source evk sigma) with
+          | MatchingVar (b,id) ->
+              ctx := (id,None,existential_type sigma ev)::!ctx;
+              assert (not b); PMeta (Some id)
+          | GoalEvar -> PEvar (evk,Array.map pattern_of_constr ctxt)
+          | _ -> PMeta None)
     | Case (ci,p,a,br) ->
 	let cip = ci.ci_pp_info in
 	let no = Some (ci.ci_npar,cip.ind_nargs) in
@@ -112,16 +136,20 @@ let rec pattern_of_constr t =
 	       pattern_of_constr p,pattern_of_constr a,
 	       Array.map pattern_of_constr br)
     | Fix f -> PFix f
-    | CoFix f -> PCoFix f
+    | CoFix f -> PCoFix f in
+  let p = pattern_of_constr t in
+  (* side-effect *)
+  (* Warning: the order of dependencies in ctx is not ensured *)
+  (!ctx,p)
 
 (* To process patterns, we need a translation without typing at all. *)
 
 let map_pattern_with_binders g f l = function
   | PApp (p,pl) -> PApp (f l p, Array.map (f l) pl)
   | PSoApp (n,pl) -> PSoApp (n, List.map (f l) pl)
-  | PLambda (n,a,b) -> PLambda (n,f l a,f (g l) b)
-  | PProd (n,a,b) -> PProd (n,f l a,f (g l) b)
-  | PLetIn (n,a,b) -> PLetIn (n,f l a,f (g l) b)
+  | PLambda (n,a,b) -> PLambda (n,f l a,f (g n l) b)
+  | PProd (n,a,b) -> PProd (n,f l a,f (g n l) b)
+  | PLetIn (n,a,b) -> PLetIn (n,f l a,f (g n l) b)
   | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2)
   | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p,Array.map (f l) pl)
   (* Non recursive *)
@@ -129,31 +157,54 @@ let map_pattern_with_binders g f l = function
   (* Bound to terms *)
   | PFix _ | PCoFix _ as x) -> x
 
-let map_pattern f = map_pattern_with_binders (fun () -> ()) (fun () -> f) ()
+let map_pattern f = map_pattern_with_binders (fun _ () -> ()) (fun () -> f) ()
 
-let rec instantiate_pattern lvar = function
-  | PVar id as x -> (try Lazy.force(List.assoc id lvar) with Not_found -> x)
+let error_instantiate_pattern id l =
+  let is = if List.length l = 1 then "is" else "are" in
+  errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id
+    ++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l
+    ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.")
+
+let instantiate_pattern sigma lvar c =
+  let rec aux vars = function
+  | PVar id as x ->
+      (try
+	let ctx,c = List.assoc id lvar in
+	try
+	  let inst =
+	    List.map (fun id -> mkRel (list_index (Name id) vars)) ctx in
+	  let c = substl inst c in
+	  snd (pattern_of_constr sigma c)
+	with Not_found (* list_index failed *) ->
+	  let vars =
+	    list_map_filter (function Name id -> Some id | _ -> None) vars in
+	  error_instantiate_pattern id (list_subtract ctx vars)
+       with Not_found (* List.assoc failed *) ->
+	 x)
   | (PFix _ | PCoFix _) -> error ("Non instantiable pattern.")
-  | c -> map_pattern (instantiate_pattern lvar) c
+  | c ->
+      map_pattern_with_binders (fun id vars -> id::vars) aux vars c in
+  aux [] c
 
 let rec liftn_pattern k n = function
   | PRel i as x -> if i >= n then PRel (i+k) else x
   | PFix x -> PFix (destFix (liftn k n (mkFix x)))
   | PCoFix x -> PCoFix (destCoFix (liftn k n (mkCoFix x)))
-  | c -> map_pattern_with_binders succ (liftn_pattern k) n c
+  | c -> map_pattern_with_binders (fun _ -> succ) (liftn_pattern k) n c
 
 let lift_pattern k = liftn_pattern k 1
 
-let rec subst_pattern subst pat = match pat with
+let rec subst_pattern subst pat =
+  match pat with
   | PRef ref ->
       let ref',t = subst_global subst ref in
 	if ref' == ref then pat else
-	 pattern_of_constr t
-  | PVar _ 
+	 snd (pattern_of_constr Evd.empty t)
+  | PVar _
   | PEvar _
   | PRel _ -> pat
   | PApp (f,args) ->
-      let f' = subst_pattern subst f in 
+      let f' = subst_pattern subst f in
       let args' = array_smartmap (subst_pattern subst) args in
 	if f' == f && args' == args then pat else
 	  PApp (f',args')
@@ -176,7 +227,7 @@ let rec subst_pattern subst pat = match pat with
       let c2' = subst_pattern subst c2 in
 	if c1' == c1 && c2' == c2 then pat else
 	  PLetIn (name,c1',c2')
-  | PSort _ 
+  | PSort _
   | PMeta _ -> pat
   | PIf (c,c1,c2) ->
       let c' = subst_pattern subst c in
@@ -186,12 +237,12 @@ let rec subst_pattern subst pat = match pat with
 	  PIf (c',c1',c2')
   | PCase ((a,b,ind,n as cs),typ,c,branches) ->
       let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in
-      let typ' = subst_pattern subst typ in 
+      let typ' = subst_pattern subst typ in
       let c' = subst_pattern subst c in
       let branches' = array_smartmap (subst_pattern subst) branches in
       let cs' = if ind == ind' then cs else (a,b,ind',n) in
 	if typ' == typ && c' == c && branches' == branches then pat else
-	  PCase(cs',typ', c', branches') 
+	  PCase(cs',typ', c', branches')
   | PFix fixpoint ->
       let cstr = mkFix fixpoint in
       let fixpoint' = destFix (subst_mps subst cstr) in
@@ -204,7 +255,7 @@ let rec subst_pattern subst pat = match pat with
 	  PCoFix cofixpoint'
 
 let mkPLambda na b = PLambda(na,PMeta None,b)
-let rev_it_mkPLambda = List.fold_right mkPLambda 
+let rev_it_mkPLambda = List.fold_right mkPLambda
 
 let rec pat_of_raw metas vars = function
   | RVar (_,id) ->
@@ -212,21 +263,24 @@ let rec pat_of_raw metas vars = function
        with Not_found -> PVar id)
   | RPatVar (_,(false,n)) ->
       metas := n::!metas; PMeta (Some n)
-  | RRef (_,r) ->
-      PRef r
+  | RRef (_,gr) ->
+      PRef (canonical_gr gr)
   (* Hack pour ne pas réécrire une interprétation complète des patterns*)
   | RApp (_, RPatVar (_,(true,n)), cl) ->
       metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
-  | RApp (_,c,cl) -> 
+  | RApp (_,c,cl) ->
       PApp (pat_of_raw metas vars c,
 	    Array.of_list (List.map (pat_of_raw metas vars) cl))
   | RLambda (_,na,bk,c1,c2) ->
+      name_iter (fun n -> metas := n::!metas) na;
       PLambda (na, pat_of_raw metas vars c1,
 	       pat_of_raw metas (na::vars) c2)
   | RProd (_,na,bk,c1,c2) ->
+      name_iter (fun n -> metas := n::!metas) na;
       PProd (na, pat_of_raw metas vars c1,
 	       pat_of_raw metas (na::vars) c2)
   | RLetIn (_,na,c1,c2) ->
+      name_iter (fun n -> metas := n::!metas) na;
       PLetIn (na, pat_of_raw metas vars c1,
 	       pat_of_raw metas (na::vars) c2)
   | RSort (_,s) ->
@@ -261,7 +315,7 @@ let rec pat_of_raw metas vars = function
       let cstr_nargs,brs = (Array.map fst cbrs, Array.map snd cbrs) in
       PCase ((sty,cstr_nargs,ind,ind_nargs), pred,
              pat_of_raw metas vars c, brs)
-             
+
   | r ->
       let loc = loc_of_rawconstr r in
       user_err_loc (loc,"pattern_of_rawconstr", Pp.str"Non supported pattern.")
@@ -284,7 +338,7 @@ and pat_of_raw_branch loc metas vars ind brs i =
               | PatCstr(loc,_,_,_) ->
                   user_err_loc (loc,"pattern_of_rawconstr",
                                 Pp.str "Non supported pattern.")) lv in
-        let vars' = List.rev lna @ vars in 
+        let vars' = List.rev lna @ vars in
 	List.length lv, rev_it_mkPLambda lna (pat_of_raw metas vars' br)
     | _ -> user_err_loc (loc,"pattern_of_rawconstr",
                          str "No unique branch for " ++ int (i+1) ++
@@ -292,5 +346,5 @@ and pat_of_raw_branch loc metas vars ind brs i =
 
 let pattern_of_rawconstr c =
   let metas = ref [] in
-  let p = pat_of_raw metas [] c in
+  let p = pat_of_raw metas [] c in	
   (!metas,p)
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
index 4102db9e..6beb996b 100644
--- a/pretyping/pattern.mli
+++ b/pretyping/pattern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pattern.mli 8963 2006-06-19 18:54:49Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -20,10 +20,11 @@ open Rawterm
 open Mod_subst
 (*i*)
 
-(* Pattern variables *)
+(* Types of substitutions with or w/o bound variables *)
 
+type constr_under_binders = identifier list * constr
 type patvar_map = (patvar * constr) list
-val pr_patvar : patvar -> std_ppcmds
+type extended_patvar_map = (patvar * constr_under_binders) list
 
 (* Patterns *)
 
@@ -45,6 +46,8 @@ type constr_pattern =
   | PFix of fixpoint
   | PCoFix of cofixpoint
 
+(** {5 Functions on patterns} *)
+
 val occur_meta_pattern : constr_pattern -> bool
 
 val subst_pattern : substitution -> constr_pattern -> constr_pattern
@@ -66,16 +69,17 @@ val head_of_constr_reference : Term.constr -> global_reference
    a pattern; currently, no destructor (Cases, Fix, Cofix) and no
    existential variable are allowed in [c] *)
 
-val pattern_of_constr : constr -> constr_pattern
+val pattern_of_constr : Evd.evar_map -> constr -> named_context * constr_pattern
 
 (* [pattern_of_rawconstr l c] translates a term [c] with metavariables into
    a pattern; variables bound in [l] are replaced by the pattern to which they
     are bound *)
 
-val pattern_of_rawconstr : rawconstr -> 
+val pattern_of_rawconstr : rawconstr ->
       patvar list * constr_pattern
 
 val instantiate_pattern :
-  (identifier * constr_pattern Lazy.t) list -> constr_pattern -> constr_pattern
+  Evd.evar_map -> (identifier * (identifier list * constr)) list ->
+  constr_pattern -> constr_pattern
 
 val lift_pattern : int -> constr_pattern -> constr_pattern
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index a513d558..02d0a11f 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretype_errors.ml 10860 2008-04-27 21:39:08Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Stdpp
@@ -14,6 +14,7 @@ open Names
 open Sign
 open Term
 open Termops
+open Namegen
 open Environ
 open Type_errors
 open Rawterm
@@ -25,7 +26,7 @@ type pretype_error =
   (* Unification *)
   | OccurCheck of existential_key * constr
   | NotClean of existential_key * constr * Evd.hole_kind
-  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * 
+  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind *
       Evd.unsolvability_explanation option
   | CannotUnify of constr * constr
   | CannotUnifyLocal of constr * constr * constr
@@ -33,6 +34,8 @@ type pretype_error =
   | CannotGeneralize of constr
   | NoOccurrenceFound of constr * identifier option
   | CannotFindWellTypedAbstraction of constr * constr list
+  | AbstractionOverMeta of name * name
+  | NonLinearUnification of name * constr
   (* Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
@@ -47,10 +50,15 @@ let precatchable_exception = function
   | _ -> false
 
 let nf_evar = Reductionops.nf_evar
-let j_nf_evar sigma j = 
+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 jl_nf_betaiotaevar sigma jl =
+  List.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}
@@ -76,7 +84,7 @@ let contract env lc =
       | Some c' when isRel c' ->
 	  l := (substl !l c') :: !l;
 	  env
-      | _ -> 
+      | _ ->
 	  let t' = substl !l t in
 	  let c' = Option.map (substl !l) c in
 	  let na' = named_hd env t' na in
@@ -111,11 +119,11 @@ let error_cant_apply_not_functional_loc loc env sigma rator randl =
     CantApplyNonFunctional (j_nf_evar sigma rator, ja))
 
 let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl =
-  let ja = Array.of_list (jl_nf_evar sigma randl) in
+  let ja = Array.of_list (jl_nf_betaiotaevar sigma randl) in
   raise_located_type_error
     (loc, env, sigma,
      CantApplyBadType
-       ((n,nf_evar sigma c, nf_evar sigma t),
+       ((n,nf_evar sigma c, Reductionops.nf_betaiota sigma t),
         j_nf_evar sigma rator, ja))
 
 let error_ill_formed_branch_loc loc env sigma c i actty expty =
@@ -161,7 +169,7 @@ let error_unsolvable_implicit loc env sigma evi e explain =
 let error_cannot_unify env sigma (m,n) =
   raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
 
-let error_cannot_unify_local env sigma (m,n,sn) = 
+let error_cannot_unify_local env sigma (m,n,sn) =
   raise (PretypeError (env_ise sigma env,CannotUnifyLocal (m,n,sn)))
 
 let error_cannot_coerce env sigma (m,n) =
@@ -170,6 +178,14 @@ let error_cannot_coerce env sigma (m,n) =
 let error_cannot_find_well_typed_abstraction env sigma p l =
   raise (PretypeError (env_ise sigma env,CannotFindWellTypedAbstraction (p,l)))
 
+let error_abstraction_over_meta env sigma hdmeta metaarg =
+  let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in
+  raise (PretypeError (env_ise sigma env,AbstractionOverMeta (m,n)))
+
+let error_non_linear_unification env sigma hdmeta t =
+  let m = Evd.meta_name sigma hdmeta in
+  raise (PretypeError (env_ise sigma env,NonLinearUnification (m,t)))
+
 (*s Ml Case errors *)
 
 let error_cant_find_case_type_loc loc env sigma expr =
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index 6ad2793f..537bc386 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretype_errors.mli 10860 2008-04-27 21:39:08Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -27,7 +27,7 @@ type pretype_error =
   (* Unification *)
   | OccurCheck of existential_key * constr
   | NotClean of existential_key * constr * Evd.hole_kind
-  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * 
+  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind *
       Evd.unsolvability_explanation option
   | CannotUnify of constr * constr
   | CannotUnifyLocal of constr * constr * constr
@@ -35,6 +35,8 @@ type pretype_error =
   | CannotGeneralize of constr
   | NoOccurrenceFound of constr * identifier option
   | CannotFindWellTypedAbstraction of constr * constr list
+  | AbstractionOverMeta of name * name
+  | NonLinearUnification of name * constr
   (* Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
@@ -59,22 +61,22 @@ val tj_nf_evar :
 val error_actual_type_loc :
   loc -> env ->  Evd.evar_map -> unsafe_judgment -> constr -> 'b
 
-val error_cant_apply_not_functional_loc : 
+val error_cant_apply_not_functional_loc :
   loc -> env ->  Evd.evar_map ->
       unsafe_judgment -> unsafe_judgment list -> 'b
 
-val error_cant_apply_bad_type_loc : 
-  loc -> env ->  Evd.evar_map -> int * constr * constr -> 
+val error_cant_apply_bad_type_loc :
+  loc -> env ->  Evd.evar_map -> int * constr * constr ->
       unsafe_judgment -> unsafe_judgment list -> 'b
 
 val error_case_not_inductive_loc :
   loc -> env ->  Evd.evar_map -> unsafe_judgment -> 'b
 
-val error_ill_formed_branch_loc : 
+val error_ill_formed_branch_loc :
   loc -> env ->  Evd.evar_map ->
       constr -> int -> constr -> constr -> 'b
 
-val error_number_branches_loc : 
+val error_number_branches_loc :
   loc -> env ->  Evd.evar_map ->
       unsafe_judgment -> int -> 'b
 
@@ -95,7 +97,7 @@ val error_not_clean :
   env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b
 
 val error_unsolvable_implicit :
-  loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind -> 
+  loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind ->
       Evd.unsolvability_explanation option -> 'b
 
 val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b
@@ -105,6 +107,12 @@ val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -
 val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map ->
       constr -> constr list -> 'b
 
+val error_abstraction_over_meta : env -> Evd.evar_map ->
+  metavariable -> metavariable -> 'b
+
+val error_non_linear_unification : env -> Evd.evar_map ->
+  metavariable -> constr -> 'b
+
 (*s Ml Case errors *)
 
 val error_cant_find_case_type_loc :
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index c0f820a2..e11811ec 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretyping.ml 12053 2009-04-06 16:20:42Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -23,17 +23,18 @@ open Libnames
 open Nameops
 open Classops
 open List
-open Recordops 
+open Recordops
 open Evarutil
 open Pretype_errors
 open Rawterm
 open Evarconv
 open Pattern
-open Dyn
 
 type typing_constraint = OfType of types option | IsType
-type var_map = (identifier * unsafe_judgment) list
+type var_map = (identifier * constr_under_binders) list
 type unbound_ltac_var_map = (identifier * identifier option) list
+type ltac_var_map = var_map * unbound_ltac_var_map
+type rawconstr_ltac_closure = ltac_var_map * rawconstr
 
 (************************************************************************)
 (* This concerns Cases *)
@@ -47,119 +48,117 @@ open Inductiveops
 
 exception Found of int array
 
-let search_guard loc env possible_indexes fixdefs = 
+let search_guard loc env possible_indexes fixdefs =
   (* Standard situation with only one possibility for each fix. *)
   (* We treat it separately in order to get proper error msg. *)
-  if List.for_all (fun l->1=List.length l) possible_indexes then 
-    let indexes = Array.of_list (List.map List.hd possible_indexes) in 
+  if List.for_all (fun l->1=List.length l) possible_indexes then
+    let indexes = Array.of_list (List.map List.hd possible_indexes) in
     let fix = ((indexes, 0),fixdefs) in
-    (try check_fix env fix with 
+    (try check_fix env fix with
        | e -> if loc = dummy_loc then raise e else Stdpp.raise_with_loc loc e);
     indexes
   else
     (* we now search recursively amoungst all combinations *)
-    (try     
-       List.iter 
-	 (fun l -> 
-	    let indexes = Array.of_list l in 
+    (try
+       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) 
+	    try check_fix env fix; raise (Found indexes)
 	    with TypeError _ -> ())
-	 (list_combinations possible_indexes); 
-       let errmsg = "Cannot guess decreasing argument of fix." in 
-       if loc = dummy_loc then error errmsg else 
+	 (list_combinations possible_indexes);
+       let errmsg = "Cannot guess decreasing argument of fix." in
+       if loc = dummy_loc then error errmsg else
 	 user_err_loc (loc,"search_guard", Pp.str errmsg)
      with Found indexes -> indexes)
 
 (* To embed constr in rawconstr *)
 let ((constr_in : constr -> Dyn.t),
-     (constr_out : Dyn.t -> constr)) = create "constr"
+     (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
 
 (** Miscellaneous interpretation functions *)
-  
+
 let interp_sort = function
   | RProp c -> Prop c
   | RType _ -> new_Type_sort ()
-      
+
 let interp_elimination_sort = function
   | RProp Null -> InProp
   | RProp Pos  -> InSet
   | RType _ -> InType
 
-module type S = 
+module type S =
 sig
 
   module Cases : Cases.S
-  
+
   (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
   val allow_anonymous_refs : bool ref
 
   (* Generic call to the interpreter from rawconstr to open_constr, leaving
      unresolved holes as evars and returning the typing contexts of
      these evars. Work as [understand_gen] for the rest. *)
-  
+
   val understand_tcc : ?resolve_classes:bool ->
     evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
 
-  val understand_tcc_evars :
-    evar_defs ref -> env -> typing_constraint -> rawconstr -> constr
-    
+  val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool ->
+    evar_map ref -> env -> typing_constraint -> rawconstr -> constr
+
   (* More general entry point with evars from ltac *)
-    
+
   (* Generic call to the interpreter from rawconstr to constr, failing
      unresolved holes in the rawterm cannot be instantiated.
-     
-     In [understand_ltac sigma env ltac_env constraint c],
-     
+
+     In [understand_ltac expand_evars sigma env ltac_env constraint c],
+
+     expand_evars : expand inferred evars by their value if any
      sigma : initial set of existential variables (typically dependent subgoals)
      ltac_env : partial substitution of variables (used for the tactic language)
-     constraint : tell if interpreted as a possibly constrained term or a type 
+     constraint : tell if interpreted as a possibly constrained term or a type
   *)
-    
+
   val understand_ltac :
-    evar_map -> env -> var_map * unbound_ltac_var_map ->
-    typing_constraint -> rawconstr -> evar_defs * constr
-    
+    bool -> evar_map -> env -> ltac_var_map ->
+    typing_constraint -> rawconstr -> evar_map * constr
+
   (* Standard call to get a constr from a rawconstr, resolving implicit args *)
-    
+
   val understand : evar_map -> env -> ?expected_type:Term.types ->
     rawconstr -> constr
-    
+
   (* Idem but the rawconstr is intended to be a type *)
-    
+
   val understand_type : evar_map -> env -> rawconstr -> constr
-    
+
   (* A generalization of the two previous case *)
-    
-  val understand_gen : typing_constraint -> evar_map -> env -> 
+
+  val understand_gen : typing_constraint -> evar_map -> env ->
     rawconstr -> constr
-    
+
   (* Idem but returns the judgment of the understood term *)
-    
+
   val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
 
   (* Idem but do not fail on unresolved evars *)
 
-  val understand_judgment_tcc : evar_defs ref -> env -> rawconstr -> unsafe_judgment
+  val understand_judgment_tcc : evar_map ref -> env -> rawconstr -> unsafe_judgment
 
   (*i*)
   (* Internal of Pretyping...
    * Unused outside, but useful for debugging
    *)
-  val pretype : 
-    type_constraint -> env -> evar_defs ref -> 
-    var_map * (identifier * identifier option) list ->
-    rawconstr -> unsafe_judgment
-    
-  val pretype_type : 
-    val_constraint -> env -> evar_defs ref ->
-    var_map * (identifier * identifier option) list ->
-    rawconstr -> unsafe_type_judgment
+  val pretype :
+    type_constraint -> env -> evar_map ref ->
+    ltac_var_map -> rawconstr -> unsafe_judgment
+
+  val pretype_type :
+    val_constraint -> env -> evar_map ref ->
+    ltac_var_map -> rawconstr -> unsafe_type_judgment
 
   val pretype_gen :
-    evar_defs ref -> env ->
-    var_map * (identifier * identifier option) list ->
-    typing_constraint -> rawconstr -> constr
+    bool -> bool -> bool -> evar_map ref -> env ->
+    ltac_var_map -> typing_constraint -> rawconstr -> constr
 
     (*i*)
 end
@@ -190,28 +189,28 @@ module Pretyping_F (Coercion : Coercion.S) = struct
     let (evd',t) = f !evdref x y z in
       evdref := evd';
       t
-	
+
   let mt_evd = Evd.empty
-    
+
   (* Utilisé pour inférer le prédicat des Cases *)
   (* Semble exagérement fort *)
   (* Faudra préférer une unification entre les types de toutes les clauses *)
   (* et autoriser des ? à rester dans le résultat de l'unification *)
-  
+
   let evar_type_fixpoint loc env evdref lna lar vdefj =
-    let lt = Array.length vdefj in 
-      if Array.length lar = lt then 
-	for i = 0 to lt-1 do 
+    let lt = Array.length vdefj in
+      if Array.length lar = lt then
+	for i = 0 to lt-1 do
           if not (e_cumul env evdref (vdefj.(i)).uj_type
 		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env (evars_of !evdref)
+            error_ill_typed_rec_body_loc loc env !evdref
               i lna vdefj lar
 	done
 
-  let check_branches_message loc env evdref c (explft,lft) = 
+  let check_branches_message loc env evdref c (explft,lft) =
     for i = 0 to Array.length explft - 1 do
-      if not (e_cumul env evdref lft.(i) explft.(i)) then 
-	let sigma = evars_of !evdref in
+      if not (e_cumul env evdref lft.(i) explft.(i)) then
+	let sigma = !evdref in
 	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
     done
 
@@ -229,13 +228,23 @@ module Pretyping_F (Coercion : Coercion.S) = struct
     | Anonymous -> name'
     | _ -> name
 
-  let pretype_id loc env (lvar,unbndltacvars) id =
+  let invert_ltac_bound_name env id0 id =
+    try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+    with Not_found ->
+      errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
+	str " depends on pattern variable name " ++ pr_id id ++
+	str " which is not bound in current context.")
+
+  let pretype_id loc env sigma (lvar,unbndltacvars) id =
     try
-      let (n,typ) = lookup_rel_id id (rel_context env) in
+      let (n,_,typ) = lookup_rel_id id (rel_context env) in
       { uj_val  = mkRel n; uj_type = lift n typ }
     with Not_found ->
     try
-      List.assoc id lvar
+      let (ids,c) = List.assoc id lvar in
+      let subst = List.map (invert_ltac_bound_name env id) ids in
+      let c = substl subst c in
+      { uj_val = c; uj_type = Retyping.get_type_of env sigma c }
     with Not_found ->
     try
       let (_,_,typ) = lookup_named id env in
@@ -257,22 +266,22 @@ module Pretyping_F (Coercion : Coercion.S) = struct
       if n=0 then p else
 	match kind_of_term p with
 	  | Lambda (_,_,c) -> decomp (n-1) c
-	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
+	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
     in
     let sign,s = decompose_prod_n n pj.uj_type in
     let ind = build_dependent_inductive env indf in
     let s' = mkProd (Anonymous, ind, s) in
     let ccl = lift 1 (decomp n pj.uj_val) in
     let ccl' = mkLambda (Anonymous, ind, ccl) in
-      {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
+      {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign}
 
   let evar_kind_of_term sigma c =
-    kind_of_term (whd_evar (Evd.evars_of sigma) c)
+    kind_of_term (whd_evar sigma c)
 
   (*************************************************************************)
   (* Main pretyping function                                               *)
 
-  let pretype_ref evdref env ref = 
+  let pretype_ref evdref env ref =
     let c = constr_of_global ref in
       make_judge c (Retyping.get_type_of env Evd.empty c)
 
@@ -293,26 +302,32 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 
     | RVar (loc, id) ->
 	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_id loc env lvar id)
+	  (pretype_id loc env !evdref lvar id)
 	  tycon
 
     | REvar (loc, evk, instopt) ->
 	(* Ne faudrait-il pas s'assurer que hyps est bien un
 	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_filtered_context (Evd.find (evars_of !evdref) evk) in
+	let hyps = evar_filtered_context (Evd.find !evdref evk) in
 	let args = match instopt with
           | None -> instance_from_named_context hyps
           | Some inst -> failwith "Evar subtitutions not implemented" in
 	let c = mkEvar (evk, args) in
-	let j = (Retyping.get_judgment_of env (evars_of !evdref) c) in
+	let j = (Retyping.get_judgment_of env !evdref c) in
 	  inh_conv_coerce_to_tycon loc env evdref j tycon
 
-    | RPatVar (loc,(someta,n)) -> 
-	anomaly "Found a pattern variable in a rawterm to type"
-	  
+    | RPatVar (loc,(someta,n)) ->
+	let ty =
+          match tycon with
+            | Some (None, ty) -> ty
+            | None | Some _ ->
+		e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+        let k = MatchingVar (someta,n) in
+	{ uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
+
     | RHole (loc,k) ->
 	let ty =
-          match tycon with 
+          match tycon with
             | Some (None, ty) -> ty
             | None | Some _ ->
 		e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
@@ -343,7 +358,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
 	let newenv = push_rec_types (names,ftys,[||]) env in
 	let vdefj =
-	  array_map2_i 
+	  array_map2_i
 	    (fun i ctxt def ->
                (* we lift nbfix times the type in tycon, because of
 		* the nbfix variables pushed to newenv *)
@@ -356,24 +371,24 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		   uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
             ctxtv vdef in
 	evar_type_fixpoint loc env evdref names ftys vdefj;
-	let ftys = Array.map (nf_evar (evars_of !evdref)) ftys in
-	let fdefs = Array.map (fun x -> nf_evar (evars_of !evdref) (j_val x)) vdefj in
+	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
 	  | RFix (vn,i) ->
 	      (* First, let's find the guard indexes. *)
 	      (* If recursive argument was not given by user, we try all args.
 	         An earlier approach was to look only for inductive arguments,
-		 but doing it properly involves delta-reduction, and it finally 
-                 doesn't seem worth the effort (except for huge mutual 
+		 but doing it properly involves delta-reduction, and it finally
+                 doesn't seem worth the effort (except for huge mutual
 		 fixpoints ?) *)
-	      let possible_indexes = Array.to_list (Array.mapi 
-		(fun i (n,_) -> match n with 
+	      let possible_indexes = Array.to_list (Array.mapi
+		(fun i (n,_) -> match n with
 		   | Some n -> [n]
 		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
 		vn)
-	      in 
-	      let fixdecls = (names,ftys,fdefs) in 
-	      let indexes = search_guard loc env possible_indexes fixdecls in 
+	      in
+	      let fixdecls = (names,ftys,fdefs) in
+	      let indexes = search_guard loc env possible_indexes fixdecls in
 	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
 	  | RCoFix i ->
 	      let cofix = (i,(names,ftys,fdefs)) in
@@ -384,7 +399,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
     | RSort (loc,s) ->
 	inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon
 
-    | RApp (loc,f,args) -> 
+    | RApp (loc,f,args) ->
 	let fj = pretype empty_tycon env evdref lvar f in
  	let floc = loc_of_rawconstr f in
 	let rec apply_rec env n resj = function
@@ -392,34 +407,34 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	  | c::rest ->
 	      let argloc = loc_of_rawconstr c in
 	      let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in
-              let resty = whd_betadeltaiota env (evars_of !evdref) resj.uj_type in
+              let resty = whd_betadeltaiota env !evdref resj.uj_type in
       		match kind_of_term resty with
 		  | Prod (na,c1,c2) ->
 		      let hj = pretype (mk_tycon c1) env evdref lvar c in
 		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-			apply_rec env (n+1) 
+			apply_rec env (n+1)
 			  { uj_val = value;
 			    uj_type = typ }
 			  rest
 		  | _ ->
 		      let hj = pretype empty_tycon env evdref lvar c in
-			error_cant_apply_not_functional_loc 
-			  (join_loc floc argloc) env (evars_of !evdref)
+			error_cant_apply_not_functional_loc
+			  (join_loc floc argloc) env !evdref
 	      		  resj [hj]
 	in
 	let resj = apply_rec env 1 fj args in
 	let resj =
 	  match evar_kind_of_term !evdref resj.uj_val with
 	  | App (f,args) ->
-              let f = whd_evar (Evd.evars_of !evdref) f in
+              let f = whd_evar !evdref f in
               begin match kind_of_term f with
               | Ind _ | Const _
 		  when isInd f or has_polymorphic_type (destConst f)
 		    ->
-	          let sigma = evars_of !evdref in
+	          let sigma =  !evdref in
 		  let c = mkApp (f,Array.map (whd_evar sigma) args) in
 	          let t = Retyping.get_type_of env sigma c in
-		  make_judge c t
+		  make_judge c (* use this for keeping evars: resj.uj_val *) t
               | _ -> resj end
 	  | _ -> resj in
 	inh_conv_coerce_to_tycon loc env evdref resj tycon
@@ -429,24 +444,30 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	let dom_valcon = valcon_of_tycon dom in
 	let j = pretype_type dom_valcon env evdref lvar c1 in
 	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) evdref lvar c2 in 
+	let j' = pretype rng (push_rel var env) evdref lvar c2 in
 	  judge_of_abstraction env (orelse_name name name') j j'
 
     | RProd(loc,name,bk,c1,c2)        ->
 	let j = pretype_type empty_valcon env evdref lvar c1 in
-	let var = (name,j.utj_val) in
-	let env' = push_rel_assum var env in
-	let j' = pretype_type empty_valcon env' evdref lvar c2 in
+	let j' =
+	  if name = Anonymous then
+	    let j = pretype_type empty_valcon env evdref lvar c2 in
+	      { j with utj_val = lift 1 j.utj_val }
+	  else
+	    let var = (name,j.utj_val) in
+	    let env' = push_rel_assum var env in
+	      pretype_type empty_valcon env' evdref lvar c2
+	in
 	let resj =
 	  try judge_of_product env name j j'
 	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
 	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-	    
+
     | RLetIn(loc,name,c1,c2)      ->
-	let j = 
+	let j =
 	  match c1 with
 	  | RCast (loc, c, CastConv (DEFAULTcast, t)) ->
-	      let tj = pretype_type empty_valcon env evdref lvar t in		
+	      let tj = pretype_type empty_valcon env evdref lvar t in
 		pretype (mk_tycon tj.utj_val) env evdref lvar c
 	  | _ -> pretype empty_tycon env evdref lvar c1
 	in
@@ -459,11 +480,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 
     | RLetTuple (loc,nal,(na,po),c,d) ->
 	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !evdref) cj.uj_type
+	let (IndType (indf,realargs)) =
+	  try find_rectype env !evdref cj.uj_type
 	  with Not_found ->
 	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !evdref) cj 
+	      error_case_not_inductive_loc cloc env !evdref cj
 	in
 	let cstrs = get_constructors env indf in
 	  if Array.length cstrs <> 1 then
@@ -487,59 +508,59 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		 | Some p ->
 		     let env_p = push_rels psign env in
 		     let pj = pretype_type empty_valcon env_p evdref lvar p in
-		     let ccl = nf_isevar !evdref pj.utj_val in
+		     let ccl = nf_evar !evdref pj.utj_val in
 		     let psign = make_arity_signature env true indf in (* with names *)
 		     let p = it_mkLambda_or_LetIn ccl psign in
-		     let inst = 
+		     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 (evars_of !evdref) lp inst in
+		     let fty = hnf_lam_applist env !evdref lp inst in
 		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
 		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|]) in 
+			 mkCase (ci, p, cj.uj_val,[|f|]) in
 		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
 
-		 | None -> 
+		 | None ->
 		     let tycon = lift_tycon cs.cs_nargs tycon in
 		     let fj = pretype tycon env_f evdref lvar d in
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_isevar !evdref fj.uj_type in
+		     let ccl = nf_evar !evdref fj.uj_type in
 		     let ccl =
 		       if noccur_between 1 cs.cs_nargs ccl then
-			 lift (- cs.cs_nargs) ccl 
+			 lift (- cs.cs_nargs) ccl
 		       else
-			 error_cant_find_case_type_loc loc env (evars_of !evdref) 
+			 error_cant_find_case_type_loc loc env !evdref
 			   cj.uj_val in
 		     let ccl = refresh_universes ccl in
 		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
 		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|] ) 
+			 mkCase (ci, p, cj.uj_val,[|f|] )
 		     in
 		       { uj_val = v; uj_type = ccl })
 
     | RIf (loc,c,(na,po),b1,b2) ->
 	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !evdref) cj.uj_type
+	let (IndType (indf,realargs)) =
+	  try find_rectype env !evdref cj.uj_type
 	  with Not_found ->
 	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !evdref) cj in
-	let cstrs = get_constructors env indf in 
+	      error_case_not_inductive_loc cloc env !evdref cj in
+	let cstrs = get_constructors env indf in
 	  if Array.length cstrs <> 2 then
             user_err_loc (loc,"",
 			  str "If is only for inductive types with two constructors.");
 
-	  let arsgn = 
+	  let arsgn =
 	    let arsgn,_ = get_arity env indf in
 	      if not !allow_anonymous_refs then
 		(* Make dependencies from arity signature impossible *)
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn 
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
 	      else arsgn
 	  in
 	  let nar = List.length arsgn in
@@ -548,40 +569,38 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	    | Some p ->
 		let env_p = push_rels psign env in
 		let pj = pretype_type empty_valcon env_p evdref lvar p in
-		let ccl = nf_evar (evars_of !evdref) pj.utj_val in
+		let ccl = nf_evar !evdref pj.utj_val in
 		let pred = it_mkLambda_or_LetIn ccl psign in
 		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
 		let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred;
-								     uj_type = typ} tycon 
+								     uj_type = typ} tycon
 		in
 		  jtyp.uj_val, jtyp.uj_type
-	    | None -> 
+	    | None ->
 		let p = match tycon with
 		  | Some (None, ty) -> ty
 		  | None | Some _ ->
                       e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ())
 		in
 		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar (evars_of !evdref) pred in
-	  let p = nf_evar (evars_of !evdref) p in
-	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
+	  let pred = nf_evar !evdref pred in
+	  let p = nf_evar !evdref p in
 	  let f cs b =
 	    let n = rel_context_length cs.cs_args in
 	    let pi = lift n pred in (* liftn n 2 pred ? *)
 	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	    let csgn = 
+	    let csgn =
 	      if not !allow_anonymous_refs then
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args 
-	      else 
-		List.map 
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+	      else
+		List.map
 		  (fun (n, b, t) ->
 		     match n with
                          Name _ -> (n, b, t)
                        | Anonymous -> (Name (id_of_string "H"), b, t))
 		cs.cs_args
 	    in
-	    let env_c = push_rels csgn env in 
-(* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
+	    let env_c = push_rels csgn env in
 	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
 	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
 	  let b1 = f cstrs.(0) b1 in
@@ -592,7 +611,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
 	  in
 	    { uj_val = v; uj_type = p }
-	  
+
     | RCases (loc,sty,po,tml,eqns) ->
 	Cases.compile_cases loc sty
 	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
@@ -606,17 +625,21 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
 	    | CastConv (k,t) ->
 		let tj = pretype_type empty_valcon env evdref lvar t in
-		let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
-		  (* User Casts are for helping pretyping, experimentally not to be kept*)
-		  (* ... except for Correctness *)
-		let v = mkCast (cj.uj_val, k, tj.utj_val) in
-		  { uj_val = v; uj_type = tj.utj_val }
+ 		let cj = pretype empty_tycon env evdref lvar c in
+		let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+		let cj = match k with
+		  | VMcast when not (occur_existential cty || occur_existential tval) ->
+		      ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
+		  | _ -> inh_conv_coerce_to_tycon loc env evdref cj (mk_tycon tval)
+		in
+		let v = mkCast (cj.uj_val, k, tval) in
+		  { uj_val = v; uj_type = tval }
 	in inh_conv_coerce_to_tycon loc env evdref cj tycon
 
     | RDynamic (loc,d) ->
-	if (tag d) = "constr" then
+	if (Dyn.tag d) = "constr" then
 	  let c = constr_out d in
-	  let j = (Retyping.get_judgment_of env (evars_of !evdref) c) in
+	  let j = (Retyping.get_judgment_of env !evdref c) in
 	    j
 	      (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
 	else
@@ -628,11 +651,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 	(match valcon with
 	   | Some v ->
                let s =
-		 let sigma = evars_of !evdref in
+		 let sigma =  !evdref in
 		 let t = Retyping.get_type_of env sigma v in
 		   match kind_of_term (whd_betadeltaiota env sigma t) with
                      | Sort s -> s
-                     | Evar ev when is_Type (existential_type sigma ev) -> 
+                     | Evar ev when is_Type (existential_type sigma ev) ->
 			 evd_comb1 (define_evar_as_sort) evdref ev
                      | _ -> anomaly "Found a type constraint which is not a type"
                in
@@ -652,24 +675,24 @@ module Pretyping_F (Coercion : Coercion.S) = struct
 		if e_cumul env evdref v tj.utj_val then tj
 		else
 		  error_unexpected_type_loc
-                    (loc_of_rawconstr c) env (evars_of !evdref) tj.utj_val v
+                    (loc_of_rawconstr c) env !evdref tj.utj_val v
 
-  let pretype_gen_aux evdref env lvar kind c =
+  let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
     let c' = match kind with
       | OfType exptyp ->
 	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-	    (pretype tycon env evdref lvar c).uj_val
+	  (pretype tycon env evdref lvar c).uj_val
       | IsType ->
 	  (pretype_type empty_valcon env evdref lvar c).utj_val in
-    let evd,_ = consider_remaining_unif_problems env !evdref in
-      evdref := evd; 
-      nf_isevar !evdref c'
-	
-  let pretype_gen evdref env lvar kind c =
-    let c = pretype_gen_aux evdref env lvar kind c in
-      evdref := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !evdref;
-      nf_isevar !evdref c
-	
+    evdref := fst (consider_remaining_unif_problems env !evdref);
+    if resolve_classes then
+      evdref :=
+        Typeclasses.resolve_typeclasses ~onlyargs:false
+	  ~split:true ~fail:fail_evar env !evdref;
+    let c = if expand_evar then nf_evar !evdref c' else c' in
+    if fail_evar then check_evars env Evd.empty !evdref c;
+    c
+
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
      retourne aussi le nouveau sigma...
@@ -679,59 +702,45 @@ module Pretyping_F (Coercion : Coercion.S) = struct
     let evdref = ref (create_evar_defs sigma) in
     let j = pretype empty_tycon env evdref ([],[]) c in
     let evd,_ = consider_remaining_unif_problems env !evdref in
-    let j = j_nf_evar (evars_of evd) j in
-    let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env evd in
-    let j = j_nf_evar (evars_of evd) j in
+    let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:false
+      ~fail:true env evd
+    in
+    let j = j_nf_evar evd j in
     check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
     j
 
   let understand_judgment_tcc evdref env c =
     let j = pretype empty_tycon env evdref ([],[]) c in
-    let sigma = evars_of !evdref in
-    let j = j_nf_evar sigma j in
-    j
+    j_nf_evar !evdref j
 
   (* Raw calls to the unsafe inference machine: boolean says if we must
      fail on unresolved evars; the unsafe_judgment list allows us to
      extend env with some bindings *)
 
-  let ise_pretype_gen fail_evar sigma env lvar kind c =
+  let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
     let evdref = ref (Evd.create_evar_defs sigma) in
-    let c = pretype_gen_aux evdref env lvar kind c in
-      if fail_evar then 
-	let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env !evdref in
-	let c = Evarutil.nf_isevar evd c in
-	  check_evars env Evd.empty evd c;
-	  evd, c
-      else !evdref, c
+    let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
+    !evdref, c
 
   (** Entry points of the high-level type synthesis algorithm *)
 
   let understand_gen kind sigma env c =
-    snd (ise_pretype_gen true sigma env ([],[]) kind c)
+    snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
 
   let understand sigma env ?expected_type:exptyp c =
-    snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
+    snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
 
   let understand_type sigma env c =
-    snd (ise_pretype_gen true sigma env ([],[]) IsType c)
-
-  let understand_ltac sigma env lvar kind c =
-    ise_pretype_gen false sigma env lvar kind c
-      
-  let understand_tcc_evars evdref env kind c =
-    pretype_gen evdref env ([],[]) kind c
-      
+    snd (ise_pretype_gen true true true sigma env ([],[]) IsType c)
+
+  let understand_ltac expand_evar sigma env lvar kind c =
+    ise_pretype_gen expand_evar false false sigma env lvar kind c
+
   let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
-    let evd, t =
-      let evdref = ref (Evd.create_evar_defs sigma) in
-      let c = 
-	if resolve_classes then
-	  pretype_gen evdref env ([],[]) (OfType exptyp) c 
-	else
-	  pretype_gen_aux evdref env ([],[]) (OfType exptyp) c
-      in !evdref, c
-    in Evd.evars_of evd, t
+    ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
+
+  let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
+    pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
 end
-  
+
 module Default : S = Pretyping_F(Coercion.Default)
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 4f116053..d28b076d 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretyping.mli 11047 2008-06-03 23:08:00Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -20,99 +20,99 @@ open Evarutil
 
 (* An auxiliary function for searching for fixpoint guard indexes *)
 
-val search_guard : 
+val search_guard :
     Util.loc -> env -> int list list -> rec_declaration -> int array
 
 type typing_constraint = OfType of types option | IsType
 
-type var_map = (identifier * unsafe_judgment) list
+type var_map = (identifier * Pattern.constr_under_binders) list
 type unbound_ltac_var_map = (identifier * identifier option) list
+type ltac_var_map = var_map * unbound_ltac_var_map
+type rawconstr_ltac_closure = ltac_var_map * rawconstr
 
-module type S = 
+module type S =
 sig
 
   module Cases : Cases.S
-    
+
   (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
   val allow_anonymous_refs : bool ref
 
   (* Generic call to the interpreter from rawconstr to open_constr, leaving
      unresolved holes as evars and returning the typing contexts of
      these evars. Work as [understand_gen] for the rest. *)
-  
+
   val understand_tcc : ?resolve_classes:bool ->
     evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
-    
-  val understand_tcc_evars :
-    evar_defs ref -> env -> typing_constraint -> rawconstr -> constr
+
+  val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool ->
+    evar_map ref -> env -> typing_constraint -> rawconstr -> constr
 
   (* More general entry point with evars from ltac *)
-    
+
   (* Generic call to the interpreter from rawconstr to constr, failing
      unresolved holes in the rawterm cannot be instantiated.
-     
-     In [understand_ltac sigma env ltac_env constraint c],
-     
+
+     In [understand_ltac expand_evars sigma env ltac_env constraint c],
+
+     expand_evars : expand inferred evars by their value if any
      sigma : initial set of existential variables (typically dependent subgoals)
      ltac_env : partial substitution of variables (used for the tactic language)
-     constraint : tell if interpreted as a possibly constrained term or a type 
+     constraint : tell if interpreted as a possibly constrained term or a type
   *)
-    
+
   val understand_ltac :
-    evar_map -> env -> var_map * unbound_ltac_var_map ->
-    typing_constraint -> rawconstr -> evar_defs * constr
-    
+    bool -> evar_map -> env -> ltac_var_map ->
+    typing_constraint -> rawconstr -> evar_map * constr
+
   (* Standard call to get a constr from a rawconstr, resolving implicit args *)
-    
+
   val understand : evar_map -> env -> ?expected_type:Term.types ->
     rawconstr -> constr
-    
+
   (* Idem but the rawconstr is intended to be a type *)
-    
+
   val understand_type : evar_map -> env -> rawconstr -> constr
-    
+
   (* A generalization of the two previous case *)
-    
-  val understand_gen : typing_constraint -> evar_map -> env -> 
+
+  val understand_gen : typing_constraint -> evar_map -> env ->
     rawconstr -> constr
-    
+
   (* Idem but returns the judgment of the understood term *)
-    
+
   val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
 
   (* Idem but do not fail on unresolved evars *)
-  val understand_judgment_tcc : evar_defs ref -> env -> rawconstr -> unsafe_judgment
+  val understand_judgment_tcc : evar_map ref -> env -> rawconstr -> unsafe_judgment
 
   (*i*)
   (* Internal of Pretyping...
    *)
-  val pretype : 
-    type_constraint -> env -> evar_defs ref -> 
-    var_map * (identifier * identifier option) list ->
-    rawconstr -> unsafe_judgment
-    
-  val pretype_type : 
-    val_constraint -> env -> evar_defs ref ->
-    var_map * (identifier * identifier option) list ->
-    rawconstr -> unsafe_type_judgment
+  val pretype :
+    type_constraint -> env -> evar_map ref ->
+    ltac_var_map -> rawconstr -> unsafe_judgment
+
+  val pretype_type :
+    val_constraint -> env -> evar_map ref ->
+    ltac_var_map -> rawconstr -> unsafe_type_judgment
 
   val pretype_gen :
-    evar_defs ref -> env -> 
-    var_map * (identifier * identifier option) list ->
-    typing_constraint -> rawconstr -> constr
+    bool -> bool -> bool -> evar_map ref -> env ->
+    ltac_var_map -> typing_constraint -> rawconstr -> constr
 
   (*i*)
-    
+
 end
 
 module Pretyping_F (C : Coercion.S) : S
 module Default : S
 
 (* To embed constr in rawconstr *)
-  
+
 val constr_in : constr -> Dyn.t
 val constr_out : Dyn.t -> constr
 
-val interp_sort : rawsort -> sorts  
+val interp_sort : rawsort -> sorts
 val interp_elimination_sort : rawsort -> sorts_family
 
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
new file mode 100644
index 00000000..cea33c1e
--- /dev/null
+++ b/pretyping/pretyping.mllib
@@ -0,0 +1,29 @@
+Termops
+Evd
+Reductionops
+Vnorm
+Namegen
+Inductiveops
+Retyping
+Cbv
+Pretype_errors
+Evarutil
+Term_dnet
+Recordops
+Evarconv
+Typing
+Rawterm
+Pattern
+Matching
+Tacred
+Typeclasses_errors
+Typeclasses
+Classops
+Coercion
+Unification
+Clenv
+Detyping
+Indrec
+Cases
+Pretyping
+
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
index 30b62ea8..ba523402 100644
--- a/pretyping/rawterm.ml
+++ b/pretyping/rawterm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rawterm.ml 11576 2008-11-10 19:13:15Z msozeau $ *)
+(* $Id$ *)
 
 (*i*)
 open Util
@@ -42,7 +42,7 @@ type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
 
 type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
 
-type 'a bindings = 
+type 'a bindings =
   | ImplicitBindings of 'a list
   | ExplicitBindings of 'a explicit_bindings
   | NoBindings
@@ -53,7 +53,7 @@ type 'a cast_type =
   | CastConv of cast_kind * 'a
   | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
 
-type rawconstr = 
+type rawconstr =
   | RRef of (loc * global_reference)
   | RVar of (loc * identifier)
   | REvar of loc * existential_key * rawconstr list option
@@ -63,7 +63,7 @@ type rawconstr =
   | RProd of loc * name * binding_kind * rawconstr * rawconstr
   | RLetIn of loc * name * rawconstr * rawconstr
   | RCases of loc * case_style * rawconstr option * tomatch_tuples * cases_clauses
-  | RLetTuple of loc * name list * (name * rawconstr option) * 
+  | RLetTuple of loc * name list * (name * rawconstr option) *
       rawconstr * rawconstr
   | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
   | RRec of loc * fix_kind * identifier array * rawdecl list array *
@@ -75,7 +75,7 @@ type rawconstr =
 
 and rawdecl = name * binding_kind * rawconstr option * rawconstr
 
-and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
+and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr * rawconstr option
 
 and fix_kind =
   | RFix of ((int option * fix_recursion_order) array * int)
@@ -97,37 +97,55 @@ let cases_predicate_names tml =
     | (tm,(na,None)) -> [na]
     | (tm,(na,Some (_,_,_,nal))) -> na::nal) tml)
 
-(*i - if PRec (_, names, arities, bodies) is in env then arities are
-   typed in env too and bodies are typed in env enriched by the
-   arities incrementally lifted 
-
-  [On pourrait plutot mettre les arités aves le type qu'elles auront
-   dans le contexte servant à typer les body ???]
-
-   - boolean in POldCase means it is recursive
-i*)
-let map_rawdecl f (na,k,obd,ty) = (na,k,Option.map f obd,f ty)
-
-let map_rawconstr f = function
-  | RVar (loc,id) -> RVar (loc,id)
-  | RApp (loc,g,args) -> RApp (loc,f g, List.map f args)
-  | RLambda (loc,na,bk,ty,c) -> RLambda (loc,na,bk,f ty,f c)
-  | RProd (loc,na,bk,ty,c) -> RProd (loc,na,bk,f ty,f c)
-  | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c)
+let map_rawdecl_left_to_right f (na,k,obd,ty) = 
+  let comp1 = Option.map f obd in
+  let comp2 = f ty in
+  (na,k,comp1,comp2)
+
+let map_rawconstr_left_to_right f = function
+  | RApp (loc,g,args) -> 
+      let comp1 = f g in 
+      let comp2 = Util.list_map_left f args in 
+      RApp (loc,comp1,comp2)
+  | RLambda (loc,na,bk,ty,c) -> 
+      let comp1 = f ty in 
+      let comp2 = f c in 
+      RLambda (loc,na,bk,comp1,comp2)
+  | RProd (loc,na,bk,ty,c) -> 
+      let comp1 = f ty in 
+      let comp2 = f c in 
+      RProd (loc,na,bk,comp1,comp2)
+  | RLetIn (loc,na,b,c) -> 
+      let comp1 = f b in 
+      let comp2 = f c in 
+      RLetIn (loc,na,comp1,comp2)
   | RCases (loc,sty,rtntypopt,tml,pl) ->
-      RCases (loc,sty,Option.map f rtntypopt,
-        List.map (fun (tm,x) -> (f tm,x)) tml,
-        List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl)
+      let comp1 = Option.map f rtntypopt in 
+      let comp2 = Util.list_map_left (fun (tm,x) -> (f tm,x)) tml in
+      let comp3 = Util.list_map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in
+      RCases (loc,sty,comp1,comp2,comp3)
   | RLetTuple (loc,nal,(na,po),b,c) ->
-      RLetTuple (loc,nal,(na,Option.map f po),f b,f c)
+      let comp1 = Option.map f po in
+      let comp2 = f b in
+      let comp3 = f c in 
+      RLetTuple (loc,nal,(na,comp1),comp2,comp3)
   | RIf (loc,c,(na,po),b1,b2) ->
-      RIf (loc,f c,(na,Option.map f po),f b1,f b2)
+      let comp1 = Option.map f po in
+      let comp2 = f b1 in
+      let comp3 = f b2 in
+      RIf (loc,f c,(na,comp1),comp2,comp3)
   | RRec (loc,fk,idl,bl,tyl,bv) ->
-      RRec (loc,fk,idl,Array.map (List.map (map_rawdecl f)) bl,
-            Array.map f tyl,Array.map f bv)
-  | RCast (loc,c,k) -> RCast (loc,f c, match k with CastConv (k,t) -> CastConv (k, f t) | x -> x)
-  | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
-  
+      let comp1 = Array.map (Util.list_map_left (map_rawdecl_left_to_right f)) bl in
+      let comp2 = Array.map f tyl in
+      let comp3 = Array.map f bv in
+      RRec (loc,fk,idl,comp1,comp2,comp3)
+  | RCast (loc,c,k) -> 
+      let comp1 = f c in
+      let comp2 = match k with CastConv (k,t) -> CastConv (k, f t) | x -> x in
+      RCast (loc,comp1,comp2)
+  | (RVar _ | RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
+
+let map_rawconstr = map_rawconstr_left_to_right
 
 (*
 let name_app f e = function
@@ -178,10 +196,10 @@ let occur_rawconstr id =
 	(occur_option rtntypopt)
         or (List.exists (fun (tm,_) -> occur tm) tml)
 	or (List.exists occur_pattern pl)
-    | RLetTuple (loc,nal,rtntyp,b,c) -> 
+    | RLetTuple (loc,nal,rtntyp,b,c) ->
 	occur_return_type rtntyp id
         or (occur b) or (not (List.mem (Name id) nal) & (occur c))
-    | RIf (loc,c,rtntyp,b1,b2) -> 
+    | RIf (loc,c,rtntyp,b1,b2) ->
 	occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2)
     | RRec (loc,fk,idl,bl,tyl,bv) ->
         not (array_for_all4 (fun fid bl ty bd ->
@@ -207,67 +225,67 @@ let occur_rawconstr id =
   in occur
 
 
-let add_name_to_ids set na = 
-  match na with 
-    | Anonymous -> set 
-    | Name id -> Idset.add id set 
+let add_name_to_ids set na =
+  match na with
+    | Anonymous -> set
+    | Name id -> Idset.add id set
 
 let free_rawvars  =
   let rec vars bounded vs = function
     | RVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs
     | RApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
-    | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> 
-	let vs' = vars bounded vs ty in 
-	let bounded' = add_name_to_ids bounded na in 
+    | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) ->
+	let vs' = vars bounded vs ty in
+	let bounded' = add_name_to_ids bounded na in
        vars bounded' vs' c
     | RCases (loc,sty,rtntypopt,tml,pl) ->
-	let vs1 = vars_option bounded vs rtntypopt in 
-	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in 
+	let vs1 = vars_option bounded vs rtntypopt in
+	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in
 	List.fold_left (vars_pattern bounded) vs2 pl
     | RLetTuple (loc,nal,rtntyp,b,c) ->
-	let vs1 = vars_return_type bounded vs rtntyp in 
-	let vs2 = vars bounded vs1 b in 
+	let vs1 = vars_return_type bounded vs rtntyp in
+	let vs2 = vars bounded vs1 b in
 	let bounded' = List.fold_left add_name_to_ids bounded nal in
 	vars bounded' vs2 c
-    | RIf (loc,c,rtntyp,b1,b2) -> 
-	let vs1 = vars_return_type bounded vs rtntyp in 
-	let vs2 = vars bounded vs1 c in 
-	let vs3 = vars bounded vs2 b1 in 
+    | RIf (loc,c,rtntyp,b1,b2) ->
+	let vs1 = vars_return_type bounded vs rtntyp in
+	let vs2 = vars bounded vs1 c in
+	let vs3 = vars bounded vs2 b1 in
 	vars bounded vs3 b2
     | RRec (loc,fk,idl,bl,tyl,bv) ->
-	let bounded' = Array.fold_right Idset.add idl bounded in 
-	let vars_fix i vs fid = 
-	  let vs1,bounded1 = 
-	    List.fold_left 
-	      (fun (vs,bounded) (na,k,bbd,bty) -> 
-		 let vs' = vars_option bounded vs bbd in 
+	let bounded' = Array.fold_right Idset.add idl bounded in
+	let vars_fix i vs fid =
+	  let vs1,bounded1 =
+	    List.fold_left
+	      (fun (vs,bounded) (na,k,bbd,bty) ->
+		 let vs' = vars_option bounded vs bbd in
 		 let vs'' = vars bounded vs' bty in
-		 let bounded' = add_name_to_ids bounded na in 
+		 let bounded' = add_name_to_ids bounded na in
 		 (vs'',bounded')
 	      )
 	      (vs,bounded')
 	      bl.(i)
 	  in
-	  let vs2 = vars bounded1 vs1 tyl.(i) in 
+	  let vs2 = vars bounded1 vs1 tyl.(i) in
 	  vars bounded1 vs2 bv.(i)
 	in
 	array_fold_left_i vars_fix vs idl
-    | RCast (loc,c,k) -> let v = vars bounded vs c in 
+    | RCast (loc,c,k) -> let v = vars bounded vs c in
 	(match k with CastConv (_,t) -> vars bounded v t | _ -> v)
     | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs
 
-  and vars_pattern bounded vs (loc,idl,p,c) = 
-    let bounded' = List.fold_right Idset.add idl bounded  in 
+  and vars_pattern bounded vs (loc,idl,p,c) =
+    let bounded' = List.fold_right Idset.add idl bounded  in
     vars bounded' vs c
 
   and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p
 
-  and vars_return_type bounded vs (na,tyopt) = 
-    let bounded' = add_name_to_ids bounded na in 
+  and vars_return_type bounded vs (na,tyopt) =
+    let bounded' = add_name_to_ids bounded na in
     vars_option bounded' vs tyopt
-  in 
-  fun rt -> 
-    let vs = vars Idset.empty Idset.empty rt in 
+  in
+  fun rt ->
+    let vs = vars Idset.empty Idset.empty rt in
     Idset.elements vs
 
 
@@ -344,10 +362,10 @@ let no_occurrences_expr = (true,[])
 
 type 'a with_occurrences = occurrences_expr * 'a
 
-type ('a,'b) red_expr_gen =
+type ('a,'b,'c) red_expr_gen =
   | Red of bool
   | Hnf
-  | Simpl of 'a with_occurrences option
+  | Simpl of 'c with_occurrences option
   | Cbv of 'b raw_red_flag
   | Lazy of 'b raw_red_flag
   | Unfold of 'b with_occurrences list
@@ -356,8 +374,8 @@ type ('a,'b) red_expr_gen =
   | ExtraRedExpr of string
   | CbvVm
 
-type ('a,'b) may_eval =
+type ('a,'b,'c) may_eval =
   | ConstrTerm of 'a
-  | ConstrEval of ('a,'b) red_expr_gen * 'a
+  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
   | ConstrContext of (loc * identifier) * 'a
   | ConstrTypeOf of 'a
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
index eecee8b0..b2b70bc9 100644
--- a/pretyping/rawterm.mli
+++ b/pretyping/rawterm.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rawterm.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -46,7 +46,7 @@ type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
 
 type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
 
-type 'a bindings = 
+type 'a bindings =
   | ImplicitBindings of 'a list
   | ExplicitBindings of 'a explicit_bindings
   | NoBindings
@@ -57,7 +57,7 @@ type 'a cast_type =
   | CastConv of cast_kind * 'a
   | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
 
-type rawconstr = 
+type rawconstr =
   | RRef of (loc * global_reference)
   | RVar of (loc * identifier)
   | REvar of loc * existential_key * rawconstr list option
@@ -67,7 +67,7 @@ type rawconstr =
   | RProd of loc * name * binding_kind * rawconstr * rawconstr
   | RLetIn of loc * name * rawconstr * rawconstr
   | RCases of loc * case_style * rawconstr option * tomatch_tuples * cases_clauses
-  | RLetTuple of loc * name list * (name * rawconstr option) * 
+  | RLetTuple of loc * name list * (name * rawconstr option) *
       rawconstr * rawconstr
   | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
   | RRec of loc * fix_kind * identifier array * rawdecl list array *
@@ -79,7 +79,7 @@ type rawconstr =
 
 and rawdecl = name * binding_kind * rawconstr option * rawconstr
 
-and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
+and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr * rawconstr option
 
 and fix_kind =
   | RFix of ((int option * fix_recursion_order) array * int)
@@ -98,21 +98,14 @@ and cases_clauses = cases_clause list
 
 val cases_predicate_names : tomatch_tuples -> name list
 
-(*i - if PRec (_, names, arities, bodies) is in env then arities are
-   typed in env too and bodies are typed in env enriched by the
-   arities incrementally lifted 
-
-  [On pourrait plutot mettre les arités aves le type qu'elles auront
-   dans le contexte servant à typer les body ???]
-
-   - boolean in POldCase means it is recursive
-   - option in PHole tell if the "?" was apparent or has been implicitely added
-i*)
-
 val map_rawconstr : (rawconstr -> rawconstr) -> rawconstr -> rawconstr
 
+(** Ensure traversal from left to right *)
+val map_rawconstr_left_to_right :
+  (rawconstr -> rawconstr) -> rawconstr -> rawconstr
+
 (*i
-val map_rawconstr_with_binders_loc : loc -> 
+val map_rawconstr_with_binders_loc : loc ->
   (identifier -> 'a -> identifier * 'a) ->
   ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr
 i*)
@@ -155,10 +148,10 @@ val no_occurrences_expr : occurrences_expr
 
 type 'a with_occurrences = occurrences_expr * 'a
 
-type ('a,'b) red_expr_gen =
+type ('a,'b,'c) red_expr_gen =
   | Red of bool
   | Hnf
-  | Simpl of 'a with_occurrences option
+  | Simpl of 'c with_occurrences option
   | Cbv of 'b raw_red_flag
   | Lazy of 'b raw_red_flag
   | Unfold of 'b with_occurrences list
@@ -167,8 +160,8 @@ type ('a,'b) red_expr_gen =
   | ExtraRedExpr of string
   | CbvVm
 
-type ('a,'b) may_eval =
+type ('a,'b,'c) may_eval =
   | ConstrTerm of 'a
-  | ConstrEval of ('a,'b) red_expr_gen * 'a
+  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
   | ConstrContext of (loc * identifier) * 'a
   | ConstrTypeOf of 'a
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 711f332e..6c903238 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: recordops.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -18,7 +18,6 @@ open Termops
 open Typeops
 open Libobject
 open Library
-open Classops
 open Mod_subst
 open Reductionops
 
@@ -32,7 +31,7 @@ open Reductionops
    projection ou bien une fonction constante (associée à un LetIn) *)
 
 type struc_typ = {
-  s_CONST : constructor; 
+  s_CONST : constructor;
   s_EXPECTEDPARAM : int;
   s_PROJKIND : (name * bool) list;
   s_PROJ : constant option list }
@@ -45,19 +44,19 @@ let load_structure i (_,(ind,id,kl,projs)) =
   let struc =
     { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in
   structure_table := Indmap.add ind struc !structure_table;
-  projection_table := 
+  projection_table :=
     List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc))
       projs !projection_table
 
 let cache_structure o =
   load_structure 1 o
 
-let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = 
-  let kn' = subst_kn subst kn in
+let subst_structure (subst,((kn,i),id,kl,projs as obj)) = 
+  let kn' = subst_ind subst kn in
   let projs' =
    (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *)
    (* the first component of subst_con.                                   *)
-   list_smartmap 
+   list_smartmap
      (Option.smartmap (fun kn -> fst (subst_con subst kn)))
     projs
   in
@@ -65,7 +64,7 @@ let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) =
     if projs' == projs && kn' == kn && id' == id then obj else
       ((kn',i),id',kl,projs')
 
-let discharge_constructor (ind, n) = 
+let discharge_constructor (ind, n) =
   (Lib.discharge_inductive ind, n)
 
 let discharge_structure (_,(ind,id,kl,projs)) =
@@ -73,15 +72,14 @@ let discharge_structure (_,(ind,id,kl,projs)) =
         List.map (Option.map Lib.discharge_con) projs)
 
 let (inStruc,outStruc) =
-  declare_object {(default_object "STRUCTURE") with 
+  declare_object {(default_object "STRUCTURE") with
     cache_function = cache_structure;
     load_function = load_structure;
     subst_function = subst_structure;
-    classify_function = (fun (_,x) -> Substitute x);
-    discharge_function = discharge_structure;
-    export_function = (function x -> Some x) }
+    classify_function = (fun x -> Substitute x);
+    discharge_function = discharge_structure }
 
-let declare_structure (s,c,kl,pl) = 
+let declare_structure (s,c,kl,pl) =
   Lib.add_anonymous_leaf (inStruc (s,c,kl,pl))
 
 let lookup_structure indsp = Indmap.find indsp !structure_table
@@ -96,6 +94,55 @@ let find_projection = function
   | ConstRef cst -> Cmap.find cst !projection_table
   | _ -> raise Not_found
 
+(* Management of a field store : each field + argument of the inferred
+ * records are stored in a discrimination tree *)
+
+let subst_id s (gr,ev,evm) =
+  (fst(subst_global s gr),ev,Evd.subst_evar_map s evm)
+
+module MethodsDnet : Term_dnet.S
+  with type ident = global_reference * Evd.evar * Evd.evar_map
+  = Term_dnet.Make
+  (struct
+     type t = global_reference * Evd.evar * Evd.evar_map
+     let compare = Pervasives.compare
+     let subst = subst_id
+     let constr_of (_,ev,evm) = Evd.evar_concl (Evd.find evm ev)
+   end)
+  (struct
+     let reduce c = Reductionops.head_unfold_under_prod
+       Names.full_transparent_state (Global.env()) Evd.empty c
+     let direction = true
+   end)
+
+let meth_dnet = ref MethodsDnet.empty
+
+open Summary
+
+let _ =
+  declare_summary "record-methods-state"
+    { freeze_function = (fun () -> !meth_dnet);
+      unfreeze_function = (fun m -> meth_dnet := m);
+      init_function = (fun () -> meth_dnet := MethodsDnet.empty) }
+
+open Libobject
+
+let load_method (_,(ty,id)) =
+  meth_dnet := MethodsDnet.add ty id !meth_dnet
+
+let (in_method,out_method) =
+  declare_object
+    { (default_object "RECMETHODS") with
+	load_function = (fun _ -> load_method);
+	cache_function = load_method;
+	subst_function = (fun (s,(ty,id)) -> Mod_subst.subst_mps s ty,subst_id s id);
+	classify_function = (fun x -> Substitute x)
+    }
+
+let methods_matching c = MethodsDnet.search_pattern !meth_dnet c
+
+let declare_method cons ev sign =
+  Lib.add_anonymous_leaf (in_method ((Evd.evar_concl (Evd.find sign ev)),(cons,ev,sign)))
 
 (************************************************************************)
 (*s A canonical structure declares "canonical" conversion hints between *)
@@ -138,7 +185,7 @@ type cs_pattern =
 
 let object_table = ref (Refmap.empty : (cs_pattern * obj_typ) list Refmap.t)
 
-let canonical_projections () = 
+let canonical_projections () =
   Refmap.fold (fun x -> List.fold_right (fun (y,c) acc -> ((x,y),c)::acc))
     !object_table []
 
@@ -148,28 +195,28 @@ let keep_true_projections projs kinds =
 
 let cs_pattern_of_constr t =
   match kind_of_term t with
-      App (f,vargs) -> 
-	begin 
+      App (f,vargs) ->
+	begin
 	  try  Const_cs (global_of_constr f) , -1, Array.to_list vargs with
-	      _ -> raise Not_found 
-	end 
+	      _ -> raise Not_found
+	end
     | Rel n -> Default_cs, pred n, []
     | Prod (_,a,b) when not (dependent (mkRel 1) b) -> Prod_cs, -1, [a;pop b]
     | Sort s -> Sort_cs (family_of_sort s), -1, []
-    | _ -> 
-	begin 
+    | _ ->
+	begin
 	  try  Const_cs (global_of_constr t) , -1, [] with
-	      _ -> raise Not_found 
-	end 
+	      _ -> raise Not_found
+	end
 
 (* Intended to always succeed *)
 let compute_canonical_projections (con,ind) =
   let v = mkConst con in
   let c = Environ.constant_value (Global.env()) con in
-  let lt,t = Reductionops.splay_lambda (Global.env()) Evd.empty c in
+  let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in
   let lt = List.rev (List.map snd lt) in
   let args = snd (decompose_app t) in
-  let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = 
+  let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } =
     lookup_structure ind in
   let params, projs = list_chop p args in
   let lpj = keep_true_projections lpj kl in
@@ -180,31 +227,55 @@ let compute_canonical_projections (con,ind) =
 	 match spopt with
            | Some proji_sp ->
 	       begin
-		 try 
+		 try
 		   let patt, n , args = cs_pattern_of_constr t in
 		     ((ConstRef proji_sp, patt, n, args) :: l)
-		 with Not_found -> l 
+		 with Not_found ->
+                   if Flags.is_verbose () then
+                     (let con_pp = Nametab.pr_global_env Idset.empty (ConstRef con)
+                      and proji_sp_pp = Nametab.pr_global_env Idset.empty (ConstRef proji_sp) in
+		      msg_warning (str "No global reference exists for projection value"
+                                   ++ print_constr t ++ str " in instance "  
+                                   ++ con_pp ++ str " of " ++ proji_sp_pp ++ str ", ignoring it."));
+		   l
 	       end
 	   | _ -> l)
       [] lps in
   List.map (fun (refi,c,inj,argj) ->
     (refi,c),
-    {o_DEF=v; o_INJ=inj; o_TABS=lt; 
+    {o_DEF=v; o_INJ=inj; o_TABS=lt;
      o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj})
     comp
 
+let pr_cs_pattern = function
+    Const_cs c -> Nametab.pr_global_env Idset.empty c
+  | Prod_cs -> str "_ -> _"
+  | Default_cs -> str "_"
+  | Sort_cs s -> Termops.pr_sort_family s
+
 let open_canonical_structure i (_,o) =
   if i=1 then
     let lo = compute_canonical_projections o in
     List.iter (fun ((proj,cs_pat),s) ->
       let l = try Refmap.find proj !object_table with Not_found -> [] in
-      if not (List.mem_assoc cs_pat l) then
-        object_table := Refmap.add proj ((cs_pat,s)::l) !object_table) lo
+      let ocs = try Some (List.assoc cs_pat l)
+      with Not_found -> None
+      in match ocs with
+        | None -> object_table := Refmap.add proj ((cs_pat,s)::l) !object_table;
+        | Some cs ->
+            if Flags.is_verbose () then
+              let old_can_s = (Termops.print_constr cs.o_DEF)
+              and new_can_s = (Termops.print_constr s.o_DEF) in
+              let prj = (Nametab.pr_global_env Idset.empty proj)
+              and hd_val = (pr_cs_pattern cs_pat) in
+              msg_warning (str "Ignoring canonical projection to " ++ hd_val
+                             ++ str " by " ++ prj ++ str " in "
+                             ++ new_can_s ++ str ": redundant with " ++ old_can_s)) lo
 
 let cache_canonical_structure o =
   open_canonical_structure 1 o
 
-let subst_canonical_structure (_,subst,(cst,ind as obj)) =
+let subst_canonical_structure (subst,(cst,ind as obj)) =
   (* invariant: cst is an evaluable reference. Thus we can take *)
   (* the first component of subst_con.                                   *)
   let cst' = fst (subst_con subst cst) in
@@ -215,13 +286,12 @@ let discharge_canonical_structure (_,(cst,ind)) =
   Some (Lib.discharge_con cst,Lib.discharge_inductive ind)
 
 let (inCanonStruc,outCanonStruct) =
-  declare_object {(default_object "CANONICAL-STRUCTURE") with 
+  declare_object {(default_object "CANONICAL-STRUCTURE") with
     open_function = open_canonical_structure;
     cache_function = cache_canonical_structure;
     subst_function = subst_canonical_structure;
-    classify_function = (fun (_,x) -> Substitute x);
-    discharge_function = discharge_canonical_structure;
-    export_function = (function x -> Some x) }
+    classify_function = (fun x -> Substitute x);
+    discharge_function = discharge_canonical_structure }
 
 let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x)
 
@@ -229,7 +299,7 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x)
 
 let error_not_structure ref =
   errorlabstrm "object_declare"
-    (Nameops.pr_id (id_of_global ref) ++ str" is not a structure object.")
+    (Nameops.pr_id (basename_of_global ref) ++ str" is not a structure object.")
 
 let check_and_decompose_canonical_structure ref =
   let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in
@@ -237,7 +307,7 @@ let check_and_decompose_canonical_structure ref =
   let vc = match Environ.constant_opt_value env sp with
     | Some vc -> vc
     | None -> error_not_structure ref in
-  let body = snd (splay_lambda (Global.env()) Evd.empty vc) in
+  let body = snd (splay_lam (Global.env()) Evd.empty vc) in
   let f,args = match kind_of_term body with
     | App (f,args) -> f,args
     | _ -> error_not_structure ref in
@@ -259,16 +329,16 @@ let lookup_canonical_conversion (proj,pat) =
   List.assoc pat (Refmap.find proj !object_table)
 
 let is_open_canonical_projection sigma (c,args) =
-  try 
+  try
     let l = Refmap.find (global_of_constr c) !object_table in
     let n = (snd (List.hd l)).o_NPARAMS in
-    try isEvar (whd_evar sigma (List.nth args n)) with Failure _ -> false
+    try isEvar_or_Meta (whd_evar sigma (List.nth args n)) with Failure _ -> false
   with Not_found -> false
 
 let freeze () =
   !structure_table, !projection_table, !object_table
 
-let unfreeze (s,p,o) = 
+let unfreeze (s,p,o) =
   structure_table := s; projection_table := p; object_table := o
 
 let init () =
@@ -277,10 +347,8 @@ let init () =
 
 let _ = init()
 
-let _ = 
+let _ =
   Summary.declare_summary "objdefs"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index ea960aa9..8fc430ae 100755
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: recordops.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -22,14 +22,19 @@ open Library
    constructor (the name of which defaults to Build_S) *)
 
 type struc_typ = {
-  s_CONST : constructor; 
+  s_CONST : constructor;
   s_EXPECTEDPARAM : int;
   s_PROJKIND : (name * bool) list;
   s_PROJ : constant option list }
 
-val declare_structure : 
+val declare_structure :
   inductive * constructor * (name * bool) list * constant option list -> unit
 
+(* [lookup_structure isp] returns the struc_typ associated to the
+   inductive path [isp] if it corresponds to a structure, otherwise
+   it fails with [Not_found] *)
+val lookup_structure : inductive -> struc_typ
+
 (* [lookup_projections isp] returns the projections associated to the
    inductive path [isp] if it corresponds to a structure, otherwise
    it fails with [Not_found] *)
@@ -41,13 +46,22 @@ val find_projection_nparams : global_reference -> int
 (* raise [Not_found] if not a projection *)
 val find_projection : global_reference -> struc_typ
 
+(* we keep an index (dnet) of record's arguments + fields
+   (=methods). Here is how to declare them: *)
+val declare_method :
+  global_reference -> Evd.evar -> Evd.evar_map -> unit
+  (* and here is how to search for methods matched by a given term: *)
+val methods_matching : constr ->
+  ((global_reference*Evd.evar*Evd.evar_map) *
+     (constr*existential_key)*Termops.subst) list
+
 (*s A canonical structure declares "canonical" conversion hints between *)
 (*  the effective components of a structure and the projections of the  *)
 (*  structure *)
 
 type cs_pattern =
     Const_cs of global_reference
-  | Prod_cs 
+  | Prod_cs
   | Sort_cs of sorts_family
   | Default_cs
 
@@ -60,10 +74,11 @@ type obj_typ = {
   o_TCOMPS : constr list } (* ordered *)
 
 val cs_pattern_of_constr : constr -> cs_pattern * int * constr list
- 
+val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds
+
 val lookup_canonical_conversion : (global_reference * cs_pattern) -> obj_typ
 val declare_canonical_structure : global_reference -> unit
 val is_open_canonical_projection :
   Evd.evar_map -> (constr * constr list) -> bool
-val canonical_projections : unit -> 
+val canonical_projections : unit ->
   ((global_reference * cs_pattern) * obj_typ) list
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 33928f67..1a69b633 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reductionops.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -25,7 +25,7 @@ exception Elimconst
 
 
 (**********************************************************************)
-(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *)
 
 type 'a stack_member =
   | Zapp of 'a list
@@ -80,12 +80,12 @@ let rec list_of_stack = function
 let rec app_stack = function
   | f, [] -> f
   | f, (Zapp [] :: s) -> app_stack (f, s)
-  | f, (Zapp args :: s) -> 
+  | f, (Zapp args :: s) ->
       app_stack (applist (f, args), s)
   | _ -> assert false
 let rec stack_assign s p c = match s with
   | Zapp args :: s ->
-      let q = List.length args in 
+      let q = List.length args in
       if p >= q then
 	Zapp args :: stack_assign s (p-q) c
       else
@@ -109,20 +109,20 @@ let rec stack_nth s p = match s with
   | _ -> raise Not_found
 
 (**************************************************************)
-(* The type of (machine) states (= lambda-bar-calculus' cuts) *) 
+(* The type of (machine) states (= lambda-bar-calculus' cuts) *)
 type state = constr * constr stack
 
 type  contextual_reduction_function = env ->  evar_map -> constr -> constr
 type  reduction_function =  contextual_reduction_function
 type local_reduction_function = evar_map -> constr -> constr
 
-type  contextual_stack_reduction_function = 
+type  contextual_stack_reduction_function =
     env ->  evar_map -> constr -> constr * constr list
 type  stack_reduction_function =  contextual_stack_reduction_function
 type local_stack_reduction_function =
     evar_map -> constr -> constr * constr list
 
-type  contextual_state_reduction_function = 
+type  contextual_state_reduction_function =
     env ->  evar_map -> state -> state
 type  state_reduction_function =  contextual_state_reduction_function
 type local_state_reduction_function = evar_map -> state -> state
@@ -135,36 +135,40 @@ let safe_evar_value sigma ev =
   try Some (Evd.existential_value sigma ev)
   with NotInstantiatedEvar | Not_found -> None
 
-let rec whd_state sigma (x, stack as s) =
+let rec whd_app_state sigma (x, stack as s) =
   match kind_of_term x with
-    | App (f,cl) -> whd_state sigma (f, append_stack cl stack)
-    | Cast (c,_,_)  -> whd_state sigma (c, stack)
+    | App (f,cl) -> whd_app_state sigma (f, append_stack cl stack)
+    | Cast (c,_,_)  -> whd_app_state sigma (c, stack)
     | Evar ev ->
         (match safe_evar_value sigma ev with
-            Some c -> whd_state sigma (c,stack)
+            Some c -> whd_app_state sigma (c,stack)
           | _ -> s)
     | _             -> s
 
+let safe_meta_value sigma ev =
+  try Some (Evd.meta_value sigma ev)
+  with Not_found -> None
+
 let appterm_of_stack (f,s) = (f,list_of_stack s)
 
 let whd_stack sigma x =
-  appterm_of_stack (whd_state sigma (x, empty_stack))
+  appterm_of_stack (whd_app_state sigma (x, empty_stack))
 let whd_castapp_stack = whd_stack
 
 let stack_reduction_of_reduction red_fun env sigma s =
   let t = red_fun env sigma (app_stack s) in
   whd_stack t
 
-let strong whdfun env sigma t = 
+let strong whdfun env sigma t =
   let rec strongrec env t =
     map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in
   strongrec env t
 
-let local_strong whdfun sigma = 
+let local_strong whdfun sigma =
   let rec strongrec t = map_constr strongrec (whdfun sigma t) in
   strongrec
 
-let rec strong_prodspine redfun sigma c = 
+let rec strong_prodspine redfun sigma c =
   let x = redfun sigma c in
   match kind_of_term x with
     | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b)
@@ -193,33 +197,13 @@ module type RedFlagsSig = sig
   val red_zeta : flags -> bool
 end
 
-(* Naive Implementation 
-module RedFlags = (struct
-  type flag = BETA | DELTA | EVAR | IOTA | ZETA | ETA
-  type flags = flag list
-  let fbeta = BETA 
-  let fdelta = DELTA
-  let fevar = EVAR
-  let fiota = IOTA
-  let fzeta = ZETA
-  let feta = ETA
-  let mkflags l = l
-  let red_beta = List.mem BETA
-  let red_delta = List.mem DELTA
-  let red_evar = List.mem EVAR
-  let red_eta = List.mem ETA
-  let red_iota = List.mem IOTA
-  let red_zeta = List.mem ZETA
-end : RedFlagsSig)
-*)
-
 (* Compact Implementation *)
 module RedFlags = (struct
   type flag = int
   type flags = int
   let fbeta = 1
   let fdelta = 2
-  let feta = 8 
+  let feta = 8
   let fiota = 16
   let fzeta = 32
   let mkflags = List.fold_left (lor) 0
@@ -235,6 +219,7 @@ open RedFlags
 (* Local *)
 let beta = mkflags [fbeta]
 let eta = mkflags [feta]
+let zeta = mkflags [fzeta]
 let betaiota = mkflags [fiota; fbeta]
 let betaiotazeta = mkflags [fiota; fbeta;fzeta]
 
@@ -298,7 +283,7 @@ let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) =
 let fix_recarg ((recindices,bodynum),_) stack =
   assert (0 <= bodynum & bodynum < Array.length recindices);
   let recargnum = Array.get recindices bodynum in
-  try 
+  try
     Some (recargnum, stack_nth stack recargnum)
   with Not_found ->
     None
@@ -319,12 +304,12 @@ let reduce_fix whdfun sigma fix stack =
 
 (* Y avait un commentaire pour whd_betadeltaiota :
 
-   NB : Cette fonction alloue peu c'est l'appel 
+   NB : Cette fonction alloue peu c'est l'appel
      ``let (c,cargs) = whfun (recarg, empty_stack)''
                               -------------------
    qui coute cher *)
 
-let rec whd_state_gen flags env sigma = 
+let rec whd_state_gen flags env sigma =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | Rel n when red_delta flags ->
@@ -339,6 +324,10 @@ let rec whd_state_gen flags env sigma =
 	  (match safe_evar_value sigma ev with
 	     | Some body -> whrec (body, stack)
 	     | None -> s)
+      | Meta ev ->
+	  (match safe_meta_value sigma ev with
+	     | Some body -> whrec (body, stack)
+	     | None -> s)
       | Const const when red_delta flags ->
 	  (match constant_opt_value env const with
 	     | Some  body -> whrec (body, stack)
@@ -373,19 +362,19 @@ let rec whd_state_gen flags env sigma =
             whrec (reduce_mind_case
                      {mP=p; mconstr=c; mcargs=list_of_stack cargs;
 		      mci=ci; mlf=lf}, stack)
-          else 
+          else
 	    (mkCase (ci, p, app_stack (c,cargs), lf), stack)
-            
+
       | Fix fix when red_iota flags ->
 	  (match reduce_fix (fun _ -> whrec) sigma fix stack with
              | Reduced s' -> whrec s'
 	     | NotReducible -> s)
 
       | x -> s
-  in 
+  in
   whrec
 
-let local_whd_state_gen flags sigma = 
+let local_whd_state_gen flags sigma =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
@@ -395,7 +384,7 @@ let local_whd_state_gen flags sigma =
           (match decomp_stack stack with
              | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
              | None when red_eta flags ->
-                 (match kind_of_term (app_stack (whrec (c, empty_stack))) with 
+                 (match kind_of_term (app_stack (whrec (c, empty_stack))) with
                     | App (f,cl) ->
 			let napp = Array.length cl in
 			if napp > 0 then
@@ -416,9 +405,9 @@ let local_whd_state_gen flags sigma =
             whrec (reduce_mind_case
                      {mP=p; mconstr=c; mcargs=list_of_stack cargs;
 		      mci=ci; mlf=lf}, stack)
-          else 
+          else
 	    (mkCase (ci, p, app_stack (c,cargs), lf), stack)
-            
+
       | Fix fix when red_iota flags ->
 	  (match reduce_fix (fun _ ->whrec) sigma fix stack with
              | Reduced s' -> whrec s'
@@ -429,8 +418,13 @@ let local_whd_state_gen flags sigma =
               Some c -> whrec (c,stack)
             | None -> s)
 
+      | Meta ev ->
+          (match safe_meta_value sigma ev with
+              Some c -> whrec (c,stack)
+            | None -> s)
+
       | x -> s
-  in 
+  in
   whrec
 
 
@@ -471,7 +465,7 @@ let whd_betadelta env =
 let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e
 let whd_betadeltaeta_stack env =
   stack_red_of_state_red (whd_betadeltaeta_state env)
-let whd_betadeltaeta env = 
+let whd_betadeltaeta env =
   red_of_state_red (whd_betadeltaeta_state env)
 
 (* 3. Iota reduction Functions *)
@@ -487,25 +481,29 @@ let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state
 let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e
 let whd_betadeltaiota_stack env =
   stack_red_of_state_red (whd_betadeltaiota_state env)
-let whd_betadeltaiota env = 
+let whd_betadeltaiota env =
   red_of_state_red (whd_betadeltaiota_state env)
 
 let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e
 let whd_betadeltaiotaeta_stack env =
   stack_red_of_state_red (whd_betadeltaiotaeta_state env)
-let whd_betadeltaiotaeta env = 
+let whd_betadeltaiotaeta env =
   red_of_state_red (whd_betadeltaiotaeta_state env)
 
 let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e
 let whd_betadeltaiota_nolet_stack env =
   stack_red_of_state_red (whd_betadeltaiota_nolet_state env)
-let whd_betadeltaiota_nolet env = 
+let whd_betadeltaiota_nolet env =
   red_of_state_red (whd_betadeltaiota_nolet_state env)
 
-(* 3. Eta reduction Functions *)
+(* 4. Eta reduction Functions *)
 
 let whd_eta c = app_stack (local_whd_state_gen eta Evd.empty (c,empty_stack))
 
+(* 5. Zeta Reduction Functions *)
+
+let whd_zeta c = app_stack (local_whd_state_gen zeta Evd.empty (c,empty_stack))
+
 (****************************************************************************)
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
@@ -517,8 +515,8 @@ let rec whd_evar sigma c =
         (match safe_evar_value sigma ev with
             Some c -> whd_evar sigma c
           | None -> c)
-    | Sort s when is_sort_variable sigma s -> whd_sort_variable sigma c
-    | _ -> collapse_appl c
+    | Sort s -> whd_sort_variable sigma c
+    | _ -> c
 
 let nf_evar =
   local_strong whd_evar
@@ -537,53 +535,53 @@ let nf_betadeltaiota env sigma =
   clos_norm_flags Closure.betadeltaiota env sigma
 
 
-(* Attention reduire un beta-redexe avec un argument qui n'est pas 
+(* Attention reduire un beta-redexe avec un argument qui n'est pas
    une variable, peut changer enormement le temps de conversion lors
    du type checking :
      (fun x => x + x) M
 *)
-let rec whd_betaiota_preserving_vm_cast env sigma t = 	 
-   let rec stacklam_var subst t stack = 	 
-     match (decomp_stack stack,kind_of_term t) with 	 
-     | Some (h,stacktl), Lambda (_,_,c) -> 	 
-         begin match kind_of_term h with 	 
-         | Rel i when not (evaluable_rel i env) -> 	 
-             stacklam_var (h::subst) c stacktl 	 
-         | Var id when  not (evaluable_named id env)-> 	 
-             stacklam_var (h::subst) c stacktl 	 
-         | _ -> whrec (substl subst t, stack) 	 
-         end 	 
-     | _ -> whrec (substl subst t, stack) 	 
-   and whrec (x, stack as s) = 	 
-     match kind_of_term x with 	 
-       | Evar ev -> 	 
-           (match safe_evar_value sigma ev with 	 
-              | Some body -> whrec (body, stack) 	 
-              | None -> s) 	 
-       | Cast (c,VMcast,t) -> 	 
-           let c = app_stack (whrec (c,empty_stack)) in 	 
-           let t = app_stack (whrec (t,empty_stack)) in 	 
-           (mkCast(c,VMcast,t),stack) 	 
-       | Cast (c,DEFAULTcast,_) -> 	 
-           whrec (c, stack) 	 
-       | App (f,cl)  -> whrec (f, append_stack cl stack) 	 
-       | Lambda (na,t,c) -> 	 
-           (match decomp_stack stack with 	 
-            | Some (a,m) -> stacklam_var [a] c m 	 
-            | _ -> s) 	 
-       | Case (ci,p,d,lf) -> 	 
-           let (c,cargs) = whrec (d, empty_stack) in 	 
-           if reducible_mind_case c then 	 
-             whrec (reduce_mind_case 	 
-                      {mP=p; mconstr=c; mcargs=list_of_stack cargs; 	 
-                       mci=ci; mlf=lf}, stack) 	 
-           else 	 
-             (mkCase (ci, p, app_stack (c,cargs), lf), stack) 	 
-       | x -> s 	 
-   in 	 
+let rec whd_betaiota_preserving_vm_cast env sigma t =
+   let rec stacklam_var subst t stack =
+     match (decomp_stack stack,kind_of_term t) with
+     | Some (h,stacktl), Lambda (_,_,c) ->
+         begin match kind_of_term h with
+         | Rel i when not (evaluable_rel i env) ->
+             stacklam_var (h::subst) c stacktl
+         | Var id when  not (evaluable_named id env)->
+             stacklam_var (h::subst) c stacktl
+         | _ -> whrec (substl subst t, stack)
+         end
+     | _ -> whrec (substl subst t, stack)
+   and whrec (x, stack as s) =
+     match kind_of_term x with
+       | Evar ev ->
+           (match safe_evar_value sigma ev with
+              | Some body -> whrec (body, stack)
+              | None -> s)
+       | Cast (c,VMcast,t) ->
+           let c = app_stack (whrec (c,empty_stack)) in
+           let t = app_stack (whrec (t,empty_stack)) in
+           (mkCast(c,VMcast,t),stack)
+       | Cast (c,DEFAULTcast,_) ->
+           whrec (c, stack)
+       | App (f,cl)  -> whrec (f, append_stack cl stack)
+       | Lambda (na,t,c) ->
+           (match decomp_stack stack with
+            | Some (a,m) -> stacklam_var [a] c m
+            | _ -> s)
+       | Case (ci,p,d,lf) ->
+           let (c,cargs) = whrec (d, empty_stack) in
+           if reducible_mind_case c then
+             whrec (reduce_mind_case
+                      {mP=p; mconstr=c; mcargs=list_of_stack cargs;
+                       mci=ci; mlf=lf}, stack)
+           else
+             (mkCase (ci, p, app_stack (c,cargs), lf), stack)
+       | x -> s
+   in
    app_stack (whrec (t,empty_stack))
 
-let nf_betaiota_preserving_vm_cast = 
+let nf_betaiota_preserving_vm_cast =
   strong whd_betaiota_preserving_vm_cast
 
 (* lazy weak head reduction functions *)
@@ -631,26 +629,26 @@ let test_trans_conversion f reds env sigma x y =
   try let _ = f reds env (nf_evar sigma x) (nf_evar sigma y) in true
   with NotConvertible -> false
 
-let is_trans_conv env sigma = test_trans_conversion Reduction.trans_conv env sigma
-let is_trans_conv_leq env sigma = test_trans_conversion Reduction.trans_conv_leq env sigma
+let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma
+let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma
 let is_trans_fconv = function | CONV -> is_trans_conv | CUMUL -> is_trans_conv_leq
 
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
 
-let whd_meta metamap c = match kind_of_term c with
-  | Meta p -> (try List.assoc p metamap with Not_found -> c)
+let whd_meta sigma c = match kind_of_term c with
+  | Meta p -> (try meta_value sigma p with Not_found -> c)
   | _ -> c
 
 (* Try to replace all metas. Does not replace metas in the metas' values
  * Differs from (strong whd_meta). *)
-let plain_instance s c = 
+let plain_instance s c =
   let rec irec n u = match kind_of_term u with
     | Meta p -> (try lift n (List.assoc p s) with Not_found -> u)
     | App (f,l) when isCast f ->
         let (f,_,t) = destCast f in
-        let l' = Array.map (irec n) l in 
+        let l' = Array.map (irec n) l in
         (match kind_of_term f with
         | Meta p ->
 	    (* Don't flatten application nodes: this is used to extract a
@@ -658,21 +656,21 @@ let plain_instance s c =
                of the proof-tree *)
 	    (try let g = List.assoc p s in
 	    match kind_of_term g with
-            | App _ -> 
+            | App _ ->
                 let h = id_of_string "H" in
                 mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
             | _ -> mkApp (g,l')
 	    with Not_found -> mkApp (f,l'))
-        | _ -> mkApp (irec n f,l'))	
+        | _ -> mkApp (irec n f,l'))
     | Cast (m,_,_) when isMeta m ->
 	(try lift n (List.assoc (destMeta m) s) with Not_found -> u)
     | _ ->
 	map_constr_with_binders succ irec n u
-  in 
+  in
   if s = [] then c else irec 0 c
 
 (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota]
-   has (unfortunately) different subtle side effects: 
+   has (unfortunately) different subtle side effects:
 
    - ** Order of subgoals **
      If the lemma is a case analysis with parameters, it will move the
@@ -689,7 +687,7 @@ let plain_instance s c =
      been contracted). A goal to rewrite may then fail or succeed
      differently.
 
-   - ** Naming of hypotheses ** 
+   - ** Naming of hypotheses **
      If a lemma is a function of the form "fun H:(forall a:A, P a)
      => .. F H .." where the expected type of H is "forall b:A, P b",
      then, without reduction, the application of the lemma will
@@ -705,9 +703,9 @@ let plain_instance s c =
      empty map).
  *)
 
-let instance s c =
+let instance sigma s c =
   (* if s = [] then c else *)
-  local_strong whd_betaiota Evd.empty (plain_instance s c)
+  local_strong whd_betaiota sigma (plain_instance s c)
 
 (* pseudo-reduction rule:
  * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
@@ -720,24 +718,24 @@ let hnf_prod_app env sigma t n =
     | Prod (_,_,b) -> subst1 n b
     | _ -> anomaly "hnf_prod_app: Need a product"
 
-let hnf_prod_appvect env sigma t nl = 
+let hnf_prod_appvect env sigma t nl =
   Array.fold_left (hnf_prod_app env sigma) t nl
 
-let hnf_prod_applist env sigma t nl = 
+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
     | Lambda (_,_,b) -> subst1 n b
     | _ -> anomaly "hnf_lam_app: Need an abstraction"
 
-let hnf_lam_appvect env sigma t nl = 
+let hnf_lam_appvect env sigma t nl =
   Array.fold_left (hnf_lam_app env sigma) t nl
 
-let hnf_lam_applist env sigma t nl = 
+let hnf_lam_applist env sigma t nl =
   List.fold_left (hnf_lam_app env sigma) t nl
 
-let splay_prod env sigma = 
+let splay_prod env sigma =
   let rec decrec env m c =
     let t = whd_betadeltaiota env sigma c in
     match kind_of_term t with
@@ -745,10 +743,10 @@ let splay_prod env sigma =
 	  decrec (push_rel (n,None,a) env)
 	    ((n,a)::m) c0
       | _ -> m,t
-  in 
+  in
   decrec env []
 
-let splay_lambda env sigma = 
+let splay_lam env sigma =
   let rec decrec env m c =
     let t = whd_betadeltaiota env sigma c in
     match kind_of_term t with
@@ -756,23 +754,23 @@ let splay_lambda env sigma =
 	  decrec (push_rel (n,None,a) env)
 	    ((n,a)::m) c0
       | _ -> m,t
-  in 
+  in
   decrec env []
 
-let splay_prod_assum env sigma = 
+let splay_prod_assum env sigma =
   let rec prodec_rec env l c =
     let t = whd_betadeltaiota_nolet env sigma c in
     match kind_of_term t with
     | Prod (x,t,c)  ->
 	prodec_rec (push_rel (x,None,t) env)
-	  (Sign.add_rel_decl (x, None, t) l) c
+	  (add_rel_decl (x, None, t) l) c
     | LetIn (x,b,t,c) ->
 	prodec_rec (push_rel (x, Some b, t) env)
-	  (Sign.add_rel_decl (x, Some b, t) l) c
+	  (add_rel_decl (x, Some b, t) l) c
     | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> l,t
   in
-  prodec_rec env Sign.empty_rel_context
+  prodec_rec env empty_rel_context
 
 let splay_arity env sigma c =
   let l, c = splay_prod env sigma c in
@@ -782,15 +780,25 @@ let splay_arity env sigma c =
 
 let sort_of_arity env c = snd (splay_arity env Evd.empty c)
 
-let decomp_n_prod env sigma n = 
-  let rec decrec env m ln c = if m = 0 then (ln,c) else 
+let splay_prod_n env sigma n =
+  let rec decrec env m ln c = if m = 0 then (ln,c) else
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Prod (n,a,c0) ->
 	  decrec (push_rel (n,None,a) env)
-	    (m-1) (Sign.add_rel_decl (n,None,a) ln) c0
-      | _                      -> invalid_arg "decomp_n_prod"
-  in 
-  decrec env n Sign.empty_rel_context
+	    (m-1) (add_rel_decl (n,None,a) ln) c0
+      | _                      -> invalid_arg "splay_prod_n"
+  in
+  decrec env n empty_rel_context
+
+let splay_lam_n env sigma n =
+  let rec decrec env m ln c = if m = 0 then (ln,c) else
+    match kind_of_term (whd_betadeltaiota 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
+      | _                      -> invalid_arg "splay_lam_n"
+  in
+  decrec env n empty_rel_context
 
 exception NotASort
 
@@ -800,22 +808,22 @@ let decomp_sort env sigma t =
   | _ -> raise NotASort
 
 let is_sort env sigma arity =
-  try let _ = decomp_sort env sigma arity in true 
+  try let _ = decomp_sort env sigma arity in true
   with NotASort -> false
 
 (* reduction to head-normal-form allowing delta/zeta only in argument
    of case/fix (heuristic used by evar_conv) *)
 
 let whd_betaiota_deltazeta_for_iota_state env sigma s =
-  let rec whrec s = 
+  let rec whrec s =
     let (t, stack as s) = whd_betaiota_state sigma s in
     match kind_of_term t with
     | Case (ci,p,d,lf) ->
         let (cr,crargs) = whd_betadeltaiota_stack env sigma d in
         let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
-        if reducible_mind_case cr then 
+        if reducible_mind_case cr then
 	  whrec (rslt, stack)
-        else 
+        else
 	  s
     | Fix fix ->
 	  (match reduce_fix (whd_betadeltaiota_state env) sigma fix stack with
@@ -829,15 +837,15 @@ let whd_betaiota_deltazeta_for_iota_state env sigma s =
  * Used in Correctness.
  * Added by JCF, 29/1/98. *)
 
-let whd_programs_stack env sigma = 
+let whd_programs_stack env sigma =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | App (f,cl) ->
 	  let n = Array.length cl - 1 in
 	  let c = cl.(n) in
-	  if occur_existential c then 
-	    s 
-	  else 
+	  if occur_existential c then
+	    s
+	  else
 	    whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack)
       | LetIn (_,b,_,c) ->
 	  if occur_existential b then
@@ -864,7 +872,7 @@ let whd_programs_stack env sigma =
              | Reduced s' -> whrec s'
 	     | NotReducible -> s)
       | _ -> s
-  in 
+  in
   whrec
 
 let whd_programs env sigma x =
@@ -879,7 +887,7 @@ let find_conclusion env sigma =
       | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
       | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
       | t -> t
-  in 
+  in
   decrec env
 
 let is_arity env sigma c =
@@ -890,44 +898,44 @@ let is_arity env sigma c =
 (*************************************)
 (* Metas *)
 
-let meta_value evd mv = 
+let meta_value evd mv =
   let rec valrec mv =
     match meta_opt_fvalue evd mv with
-    | Some (b,_) -> 
-      instance
+    | Some (b,_) ->
+      instance evd
         (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
         b.rebus
     | None -> mkMeta mv
-  in 
+  in
   valrec mv
 
-let meta_instance env b =
+let meta_instance sigma b =
   let c_sigma =
-    List.map 
-      (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
-  in 
-  if c_sigma = [] then b.rebus else instance c_sigma b.rebus
+    List.map
+      (fun mv -> (mv,meta_value sigma mv)) (Metaset.elements b.freemetas)
+  in
+  if c_sigma = [] then b.rebus else instance sigma c_sigma b.rebus
 
-let nf_meta env c = meta_instance env (mk_freelisted c)
+let nf_meta sigma c = meta_instance sigma (mk_freelisted c)
 
 (* Instantiate metas that create beta/iota redexes *)
 
-let meta_value evd mv = 
+let meta_value evd mv =
   let rec valrec mv =
     match meta_opt_fvalue evd mv with
     | Some (b,_) ->
-      instance
+      instance evd
         (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
         b.rebus
     | None -> mkMeta mv
-  in 
+  in
   valrec mv
 
 let meta_reducible_instance evd b =
   let fm = Metaset.elements b.freemetas in
-  let metas = List.fold_left (fun l mv -> 
+  let metas = List.fold_left (fun l mv ->
     match (try meta_opt_fvalue evd mv with Not_found -> None) with
-    | Some (g,(_,s)) -> (mv,(g.rebus,s))::l 
+    | Some (g,(_,s)) -> (mv,(g.rebus,s))::l
     | None -> l) [] fm in
   let rec irec u =
     let u = whd_betaiota Evd.empty u in
@@ -956,5 +964,23 @@ let meta_reducible_instance evd b =
 	(try let g,s = List.assoc m metas in if s<>CoerceToType then irec g else u
 	 with Not_found -> u)
     | _ -> map_constr irec u
-  in 
+  in
   if fm = [] then (* nf_betaiota? *) b.rebus else irec b.rebus
+
+
+let head_unfold_under_prod ts env _ c =
+  let unfold cst =
+    if Cpred.mem cst (snd ts) then
+      match constant_opt_value env cst with
+	| Some c -> c
+	| None -> mkConst cst
+    else mkConst cst in
+  let rec aux c =
+    match kind_of_term c with
+      | Prod (n,t,c) -> mkProd (n,aux t, aux c)
+      | _ ->
+	  let (h,l) = decompose_app c in
+	  match kind_of_term h with
+	    | Const cst -> beta_applist (unfold cst,l)
+	    | _ -> c in
+  aux c
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 8b3657c7..127dbe6b 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reductionops.mli 11897 2009-02-09 19:28:02Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -56,13 +56,13 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr
 type reduction_function = contextual_reduction_function
 type local_reduction_function = evar_map -> constr -> constr
 
-type contextual_stack_reduction_function = 
+type contextual_stack_reduction_function =
     env -> evar_map -> constr -> constr * constr list
 type stack_reduction_function = contextual_stack_reduction_function
 type local_stack_reduction_function =
     evar_map -> constr -> constr * constr list
 
-type contextual_state_reduction_function = 
+type contextual_state_reduction_function =
     env -> evar_map -> state -> state
 type state_reduction_function = contextual_state_reduction_function
 type local_state_reduction_function = evar_map -> state -> state
@@ -79,15 +79,15 @@ val strong : reduction_function -> reduction_function
 val local_strong : local_reduction_function -> local_reduction_function
 val strong_prodspine : local_reduction_function -> local_reduction_function
 (*i
-val stack_reduction_of_reduction : 
+val stack_reduction_of_reduction :
   'a reduction_function -> 'a state_reduction_function
 i*)
-val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a 
+val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a
 
 (*s Generic Optimized Reduction Function using Closures *)
 
 val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
-(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) 
+(* 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_betadeltaiota : reduction_function
@@ -136,6 +136,7 @@ val whd_betadeltaiotaeta_state :  state_reduction_function
 val whd_betadeltaiotaeta :  reduction_function
 
 val whd_eta : constr -> constr
+val whd_zeta : constr -> constr
 
 (* Various reduction functions *)
 
@@ -151,13 +152,13 @@ val hnf_lam_appvect  : env ->  evar_map -> constr -> constr array -> constr
 val hnf_lam_applist  : env ->  evar_map -> constr -> constr list -> constr
 
 val splay_prod : env ->  evar_map -> constr -> (name * constr) list * constr
-val splay_lambda : env ->  evar_map -> constr -> (name * constr) list * constr
+val splay_lam : env ->  evar_map -> constr -> (name * constr) list * constr
 val splay_arity : env ->  evar_map -> constr -> (name * constr) list * sorts
 val sort_of_arity : env -> constr -> sorts
-val decomp_n_prod : 
-  env ->  evar_map -> int -> constr -> Sign.rel_context * constr
+val splay_prod_n : env ->  evar_map -> int -> constr -> rel_context * constr
+val splay_lam_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_prod_assum :
-  env ->  evar_map -> constr -> Sign.rel_context * constr
+  env ->  evar_map -> constr -> rel_context * constr
 val decomp_sort : env -> evar_map -> types -> sorts
 val is_sort : env -> evar_map -> types -> bool
 
@@ -207,15 +208,16 @@ val is_trans_fconv : conv_pb -> transparent_state -> env ->  evar_map -> constr
 
 (*s Special-Purpose Reduction Functions *)
 
-val whd_meta : (metavariable * constr) list -> constr -> constr
+val whd_meta : evar_map -> constr -> constr
 val plain_instance : (metavariable * constr) list -> constr -> constr
-val instance : (metavariable * constr) list -> constr -> constr
+val instance :evar_map -> (metavariable * constr) list -> constr -> constr
+val head_unfold_under_prod : transparent_state -> reduction_function
 
 (*s Heuristic for Conversion with Evar *)
 
 val whd_betaiota_deltazeta_for_iota_state :  state_reduction_function
 
 (*s Meta-related reduction functions *)
-val meta_instance : evar_defs -> constr freelisted -> constr
-val nf_meta       : evar_defs -> constr -> constr
-val meta_reducible_instance : evar_defs -> constr freelisted -> constr
+val meta_instance : evar_map -> constr freelisted -> constr
+val nf_meta       : evar_map -> constr -> constr
+val meta_reducible_instance : evar_map -> constr freelisted -> constr
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index 19e46a47..1e0649da 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retyping.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Util
 open Term
@@ -44,11 +44,11 @@ let type_of_var env id =
   with Not_found ->
     anomaly ("type_of: variable "^(string_of_id id)^" unbound")
 
-let retype sigma metamap =
+let retype sigma =
   let rec type_of env cstr=
     match kind_of_term cstr with
     | Meta n ->
-          (try strip_outer_cast (List.assoc n metamap)
+          (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus
            with Not_found -> anomaly ("type_of: unknown meta " ^ string_of_int n))
     | Rel n ->
         let (_,_,ty) = lookup_rel n env in
@@ -81,7 +81,7 @@ let retype sigma metamap =
     | Cast (c,_, t) -> t
     | Sort _ | Prod _ -> mkSort (sort_of env cstr)
 
-  and sort_of env t = 
+  and sort_of env t =
     match kind_of_term t with
     | Cast (c,_, s) when isSort s -> destSort s
     | Sort (Prop c) -> type1_sort
@@ -111,14 +111,14 @@ let retype sigma metamap =
     | Cast (c,_, s) when isSort s -> family_of_sort (destSort s)
     | Sort (Prop c) -> InType
     | Sort (Type u) -> InType
-    | Prod (name,t,c2) -> 
+    | Prod (name,t,c2) ->
 	let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
 	if Environ.engagement env <> Some ImpredicativeSet &&
 	   s2 = InSet & sort_family_of env t = InType then InType else s2
     | App(f,args) when isGlobalRef f ->
 	let t = type_of_global_reference_knowing_parameters env f args in
         family_of_sort (sort_of_atomic_type env sigma t args)
-    | App(f,args) -> 
+    | App(f,args) ->
 	family_of_sort (sort_of_atomic_type env sigma (type_of env f) args)
     | Lambda _ | Fix _ | Construct _ ->
         anomaly "sort_of: Not a type (1)"
@@ -140,10 +140,10 @@ let retype sigma metamap =
   in type_of, sort_of, sort_family_of,
      type_of_global_reference_knowing_parameters
 
-let get_sort_of env sigma t = let _,f,_,_ = retype sigma [] in f env t
-let get_sort_family_of env sigma c = let _,_,f,_ = retype sigma [] in f env c
+let get_sort_of env sigma t = let _,f,_,_ = retype sigma in f env t
+let get_sort_family_of env sigma c = let _,_,f,_ = retype sigma in f env c
 let type_of_global_reference_knowing_parameters env sigma c args =
-  let _,_,_,f = retype sigma [] in f env c args
+  let _,_,_,f = retype sigma in f env c args
 
 let type_of_global_reference_knowing_conclusion env sigma c conclty =
   let conclty = nf_evar sigma conclty in
@@ -161,11 +161,10 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty =
 
 (* We are outside the kernel: we take fresh universes *)
 (* to avoid tactics and co to refresh universes themselves *)
-let get_type_of env sigma c =
-  let f,_,_,_ = retype sigma [] in refresh_universes (f env c)
-
-let get_type_of_with_meta env sigma metamap c =
-  let f,_,_,_ = retype sigma metamap in refresh_universes (f env c)
+let get_type_of ?(refresh=true) env sigma c =
+  let f,_,_,_ = retype sigma in
+  let t = f env c in
+    if refresh then refresh_universes t else t
 
 (* Makes an assumption from a constr *)
 let get_assumption_of env evc c = c
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index ec1fc827..8576d5ba 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: retyping.mli 11436 2008-10-07 13:56:55Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -21,21 +21,18 @@ open Environ
    either produces a wrong result or raise an anomaly. Use with care.
    It doesn't handle predicative universes too. *)
 
-val get_type_of : env -> evar_map -> constr -> types
+val get_type_of : ?refresh:bool -> env -> evar_map -> constr -> types
 val get_sort_of : env -> evar_map -> types -> sorts
 val get_sort_family_of : env -> evar_map -> types -> sorts_family
 
-val get_type_of_with_meta :
-  env -> evar_map -> Termops.metamap -> constr -> types
-
 (* Makes an assumption from a constr *)
 val get_assumption_of : env -> evar_map -> constr -> types
 
 (* Makes an unsafe judgment from a constr *)
 val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment
 
-val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> 
+val type_of_global_reference_knowing_parameters : env -> evar_map -> constr ->
   constr array -> types
- 
+
 val type_of_global_reference_knowing_conclusion :
   env -> evar_map -> constr -> types -> types
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index f579afa6..a103c49b 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacred.ml 12233 2009-07-08 22:50:56Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,6 +15,7 @@ open Nameops
 open Term
 open Libnames
 open Termops
+open Namegen
 open Declarations
 open Inductive
 open Environ
@@ -22,10 +23,12 @@ open Closure
 open Reductionops
 open Cbv
 open Rawterm
+open Pattern
+open Matching
 
 (* Errors *)
 
-type reduction_tactic_error = 
+type reduction_tactic_error =
     InvalidAbstraction of env * constr * (env * Type_errors.type_error)
 
 exception ReductionTacticError of reduction_tactic_error
@@ -35,15 +38,20 @@ exception ReductionTacticError of reduction_tactic_error
 exception Elimconst
 exception Redelimination
 
+let error_not_evaluable r =
+  errorlabstrm "error_not_evaluable"
+    (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Idset.empty r ++
+     spc () ++ str "to an evaluable reference.")
+
+let is_evaluable_const env cst =
+  is_transparent (ConstKey cst) && evaluable_constant cst env
+
+let is_evaluable_var env id =
+  is_transparent (VarKey id) && evaluable_named id env
+
 let is_evaluable env = function
-  | EvalConstRef kn ->
-      is_transparent (ConstKey kn) &&
-      let cb = Environ.lookup_constant kn env in
-      cb.const_body <> None & not cb.const_opaque
-  | EvalVarRef id ->
-      is_transparent (VarKey id) &&
-      let (_,value,_) = Environ.lookup_named id env in
-      value <> None
+  | EvalConstRef cst -> is_evaluable_const env cst
+  | EvalVarRef id -> is_evaluable_var env id
 
 let value_of_evaluable_ref env = function
   | EvalConstRef con -> constant_value env con
@@ -53,6 +61,15 @@ let constr_of_evaluable_ref = function
   | EvalConstRef con -> mkConst con
   | EvalVarRef id -> mkVar id
 
+let evaluable_of_global_reference env = function
+  | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst
+  | VarRef id when is_evaluable_var env id -> EvalVarRef id
+  | r -> error_not_evaluable r
+
+let global_of_evaluable_reference = function
+  | EvalConstRef cst -> ConstRef cst
+  | EvalVarRef id -> VarRef id
+
 type evaluable_reference =
   | EvalConst of constant
   | EvalVar of identifier
@@ -98,7 +115,7 @@ let reference_value sigma env c =
 (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic).  *)
 (* One reuses the name of the function after reduction of the fixpoint  *)
 
-type constant_evaluation = 
+type constant_evaluation =
   | EliminationFix of int * int * (int * (int * constr) list * int)
   | EliminationMutualFix of
       int * evaluable_reference *
@@ -109,19 +126,12 @@ type constant_evaluation =
 
 (* We use a cache registered as a global table *)
 
-module CstOrdered =
-  struct
-    type t = constant
-    let compare = Pervasives.compare
-  end
-module Cstmap = Map.Make(CstOrdered)
-
-let eval_table = ref Cstmap.empty
+let eval_table = ref Cmap.empty
 
-type frozen = (int * constant_evaluation) Cstmap.t
+type frozen = (int * constant_evaluation) Cmap.t
 
 let init () =
-  eval_table := Cstmap.empty
+  eval_table := Cmap.empty
 
 let freeze () =
   !eval_table
@@ -129,22 +139,20 @@ let freeze () =
 let unfreeze ct =
   eval_table := ct
 
-let _ = 
+let _ =
   Summary.declare_summary "evaluation"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
 
 (* [compute_consteval] determines whether c is an "elimination constant"
 
    either [yn:Tn]..[y1:T1](match yi with f1..fk end g1 ..gp)
 
    or     [yn:Tn]..[y1:T1](Fix(f|t) yi1..yip)
-          with yi1..yip distinct variables among the yi, not occurring in t 
+          with yi1..yip distinct variables among the yi, not occurring in t
 
-   In the second case, [check_fix_reversibility [T1;...;Tn] args fix] 
+   In the second case, [check_fix_reversibility [T1;...;Tn] args fix]
    checks that [args] is a subset of disjoint variables in y1..yn (a necessary
    condition for reversibility). It also returns the relevant
    information ([i1,Ti1;..;ip,Tip],n) in order to compute an
@@ -153,7 +161,7 @@ let _ =
    g := [xp:Tip']..[x1:Ti1'](f a1..an)
      == [xp:Tip']..[x1:Ti1'](Fix(f|t) yi1..yip)
 
-   with a_k:=y_k if k<>i_j, a_k:=args_k otherwise, and 
+   with a_k:=y_k if k<>i_j, a_k:=args_k otherwise, and
    Tij':=Tij[x1..xi(j-1) <- a1..ai(j-1)]
 
    Note that the types Tk, when no i_j=k, must not be dependent on
@@ -172,15 +180,15 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
              if
 	       array_for_all (noccurn k) tys
 	       && array_for_all (noccurn (k+nbfix)) bds
-	     then 
-	       (k, List.nth labs (k-1)) 
-	     else 
+	     then
+	       (k, List.nth labs (k-1))
+	     else
 	       raise Elimconst
-         | _ -> 
+         | _ ->
 	     raise Elimconst) args
   in
   let reversible_rels = List.map fst li in
-  if not (list_distinct reversible_rels) then 
+  if not (list_distinct reversible_rels) then
     raise Elimconst;
   list_iter_i (fun i t_i ->
     if not (List.mem_assoc (i+1) li) then
@@ -189,8 +197,8 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
     labs;
   let k = lv.(i) in
   if k < nargs then
-(*  Such an optimisation would need eta-expansion 
-      let p = destRel (List.nth args k) in 
+(*  Such an optimisation would need eta-expansion
+      let p = destRel (List.nth args k) in
       EliminationFix (n-p+1,(nbfix,li,n))
 *)
     EliminationFix (n,nargs,(nbfix,li,n))
@@ -201,7 +209,7 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
    components of a mutual fixpoint *)
 
 let invert_name labs l na0 env sigma ref = function
-  | Name id -> 
+  | Name id ->
       let minfxargs = List.length l in
       if na0 <> Name id then
 	let refi = match ref with
@@ -215,7 +223,7 @@ let invert_name labs l na0 env sigma ref = function
 	  | Some ref ->
 	      try match reference_opt_value sigma env ref with
 		| None -> None
-		| Some c -> 
+		| Some c ->
 		    let labs',ccl = decompose_lam c in
 		    let _, l' = whd_betalet_stack sigma ccl in
 		    let labs' = List.map snd labs' in
@@ -236,11 +244,11 @@ let compute_consteval_direct sigma env ref =
       | Lambda (id,t,g) when l=[] ->
 	  srec (push_rel (id,None,t) env) (n+1) (t::labs) g
       | Fix fix ->
-	  (try check_fix_reversibility labs l fix 
+	  (try check_fix_reversibility labs l fix
 	  with Elimconst -> NotAnElimination)
       | Case (_,_,d,_) when isRel d -> EliminationCases n
       | _ -> NotAnElimination
-  in 
+  in
   match reference_opt_value sigma env ref with
     | None -> NotAnElimination
     | Some c -> srec env 0 [] c
@@ -271,7 +279,7 @@ let compute_consteval_mutual_fix sigma env ref =
 	    | None -> anomaly "Should have been trapped by compute_direct"
 	    | Some c -> srec env (minarg-nargs) [] ref c)
       | _ -> (* Should not occur *) NotAnElimination
-  in 
+  in
   match reference_opt_value sigma env ref with
     | None -> (* Should not occur *) NotAnElimination
     | Some c -> srec env 0 [] ref c
@@ -281,27 +289,27 @@ let compute_consteval sigma env ref =
     | EliminationFix (_,_,(nbfix,_,_)) when nbfix <> 1 ->
 	compute_consteval_mutual_fix sigma env ref
     | elim -> elim
-	
+
 let reference_eval sigma env = function
-  | EvalConst cst as ref -> 
+  | EvalConst cst as ref ->
       (try
-	 Cstmap.find cst !eval_table
+	 Cmap.find cst !eval_table
        with Not_found -> begin
 	 let v = compute_consteval sigma env ref in
-	 eval_table := Cstmap.add cst v !eval_table;
+	 eval_table := Cmap.add cst v !eval_table;
 	 v
        end)
   | ref -> compute_consteval sigma env ref
 
-let rev_firstn_liftn fn ln = 
-  let rec rfprec p res l = 
-    if p = 0 then 
-      res 
+let rev_firstn_liftn fn ln =
+  let rec rfprec p res l =
+    if p = 0 then
+      res
     else
       match l with
         | [] -> invalid_arg "Reduction.rev_firstn_liftn"
         | a::rest -> rfprec (p-1) ((lift ln a)::res) rest
-  in 
+  in
   rfprec fn []
 
 (* If f is bound to EliminationFix (n',infos), then n' is the minimal
@@ -318,7 +326,7 @@ let rev_firstn_liftn fn ln =
 
    s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up)
 
-   This is made possible by setting 
+   This is made possible by setting
       a_k:=x_j    if k=i_j for some j
       a_k:=arg_k  otherwise
 
@@ -332,30 +340,30 @@ let make_elim_fun (names,(nbfix,lv,n)) largs =
   let p = List.length lv in
   let lyi = List.map fst lv in
   let la =
-    list_map_i (fun q aq -> 
-      (* k from the comment is q+1 *) 
+    list_map_i (fun q aq ->
+      (* k from the comment is q+1 *)
       try mkRel (p+1-(list_index (n-q) lyi))
       with Not_found -> aq)
-      0 (List.map (lift p) lu) 
-  in 
+      0 (List.map (lift p) lu)
+  in
   fun i ->
     match names.(i) with
       | None -> None
       | Some (minargs,ref) ->
           let body = applistc (mkEvalRef ref) la in
-          let g = 
+          let g =
             list_fold_left_i (fun q (* j = n+1-q *) c (ij,tij) ->
               let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in
               let tij' = substl (List.rev subst) tij in
 	      mkLambda (x,tij',c)) 1 body (List.rev lv)
           in Some (minargs,g)
 
-(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: 
+(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]:
    do so that the reduction uses this extra information *)
 
 let dummy = mkProp
 let vfx = id_of_string"_expanded_fix_"
-let vfun = id_of_string"_elimminator_function_"
+let vfun = id_of_string"_eliminator_function_"
 
 (* Mark every occurrence of substituted vars (associated to a function)
    as a problem variable: an evar that can be instantiated either by
@@ -392,7 +400,7 @@ exception Partial
    reduction is solved by the expanded fix term. *)
 let solve_arity_problem env sigma fxminargs c =
   let evm = ref sigma in
-  let set_fix i = evm := Evd.define !evm i (mkVar vfx) in
+  let set_fix i = evm := Evd.define i (mkVar vfx) !evm in
   let rec check strict c =
     let c' = whd_betaiotazeta sigma c in
     let (h,rcargs) = decompose_app c' in
@@ -448,7 +456,7 @@ let reduce_fix_use_function env sigma f whfun fix stack =
         let (recarg'hd,_ as recarg') =
 	  if isRel recarg then
 	    (* The recarg cannot be a local def, no worry about the right env *)
-	    (recarg, empty_stack) 
+	    (recarg, empty_stack)
 	  else
 	    whfun (recarg, empty_stack) in
         let stack' = stack_assign stack recargnum (app_stack recarg') in
@@ -466,7 +474,7 @@ let contract_cofix_use_function env sigma f
     (nf_beta sigma bodies.(bodynum))
 
 let reduce_mind_case_use_function func env sigma mia =
-  match kind_of_term mia.mconstr with 
+  match kind_of_term mia.mconstr with
     | Construct(ind_sp,i) ->
 	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
 	applist (mia.mlf.(i-1), real_cargs)
@@ -480,9 +488,9 @@ let reduce_mind_case_use_function func env sigma mia =
 	      else match names.(i) with
 		| Anonymous -> None
 		| Name id ->
-		    (* In case of a call to another component of a block of 
+		    (* In case of a call to another component of a block of
 		       mutual inductive, try to reuse the global name if
-		       the block was indeed initially built as a global 
+		       the block was indeed initially built as a global
 		       definition *)
 		    let kn = make_con mp dp (label_of_id id) in
 		    try match constant_opt_value env kn with
@@ -498,8 +506,8 @@ let reduce_mind_case_use_function func env sigma mia =
     | _ -> assert false
 
 let special_red_case env sigma whfun (ci, p, c, lf)  =
-  let rec redrec s = 
-    let (constr, cargs) = whfun s in 
+  let rec redrec s =
+    let (constr, cargs) = whfun s in
     if isEvalRef env constr then
       let ref = destEvalRef constr in
       match reference_opt_value sigma env ref with
@@ -516,9 +524,9 @@ let special_red_case env sigma whfun (ci, p, c, lf)  =
         reduce_mind_case
 	  {mP=p; mconstr=constr; mcargs=list_of_stack cargs;
 	  mci=ci; mlf=lf}
-      else 
+      else
 	raise Redelimination
-  in 
+  in
   redrec (c, empty_stack)
 
 (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind
@@ -565,14 +573,14 @@ and whd_simpl_state env sigma s =
   let rec redrec (x, stack as s) =
     match kind_of_term x with
       | Lambda (na,t,c) ->
-          (match decomp_stack stack with 
+          (match decomp_stack stack with
              | None -> s
              | Some (a,rest) -> stacklam redrec [a] c rest)
       | LetIn (n,b,t,c) -> stacklam redrec [b] c stack
       | App (f,cl) -> redrec (f, append_stack cl stack)
       | Cast (c,_,_) -> redrec (c, stack)
       | Case (ci,p,c,lf) ->
-          (try 
+          (try
 	    redrec (special_red_case env sigma redrec (ci,p,c,lf), stack)
 	  with
 	      Redelimination -> s)
@@ -588,13 +596,13 @@ and whd_simpl_state env sigma s =
            with Redelimination ->
 	     s)
       | _ -> s
-  in 
+  in
   redrec s
 
 (* reduce until finding an applied constructor or fail *)
 
 and whd_construct_state env sigma s =
-  let (constr, cargs as s') = whd_simpl_state env sigma s in 
+  let (constr, cargs as s') = whd_simpl_state env sigma s in
   if reducible_mind_case constr then s'
   else if isEvalRef env constr then
     let ref = destEvalRef constr in
@@ -612,11 +620,11 @@ and whd_construct_state env sigma s =
    sequence of products; fails if no delta redex is around
 *)
 
-let try_red_product env sigma c = 
+let try_red_product env sigma c =
   let simpfun = clos_norm_flags betaiotazeta env sigma in
   let rec redrec env x =
     match kind_of_term x with
-      | App (f,l) -> 
+      | App (f,l) ->
           (match kind_of_term f with
              | Fix fix ->
                  let stack = append_stack l empty_stack in
@@ -631,7 +639,7 @@ let try_red_product env sigma c =
       | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
       | LetIn (x,a,b,t) -> redrec env (subst1 a t)
       | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
-      | _ when isEvalRef env x -> 
+      | _ when isEvalRef env x ->
           (* TO DO: re-fold fixpoints after expansion *)
           (* to get true one-step reductions *)
           let ref = destEvalRef x in
@@ -641,17 +649,17 @@ let try_red_product env sigma c =
       | _ -> raise Redelimination
   in redrec env c
 
-let red_product env sigma c = 
+let red_product env sigma c =
   try try_red_product env sigma c
   with Redelimination -> error "Not reducible."
 
 (*
-(* This old version of hnf uses betadeltaiota instead of itself (resp 
+(* This old version of hnf uses betadeltaiota instead of itself (resp
    whd_construct_state) to reduce the argument of Case (resp Fix);
    The new version uses the "simpl" strategy instead. For instance,
 
    Variable n:nat.
-   Eval hnf in match (plus (S n) O) with S n => n | _ => O end.  
+   Eval hnf in match (plus (S n) O) with S n => n | _ => O end.
 
    returned
 
@@ -678,7 +686,7 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
       | Case (ci,p,d,lf) ->
           (try
              redrec (special_red_case env sigma whd_all (ci,p,d,lf), stack)
-           with Redelimination -> 
+           with Redelimination ->
 	     s)
       | Fix fix ->
 	  (match reduce_fix whd_all fix stack with
@@ -691,7 +699,7 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
            with Redelimination ->
              match reference_opt_value sigma env ref with
 	       | Some c ->
-		   (match kind_of_term (snd (decompose_lam c)) with 
+		   (match kind_of_term ((strip_lam c)) with
                      | CoFix _ | Fix _ -> s
 		     | _ -> redrec (c, stack))
 	       | None -> s)
@@ -705,11 +713,11 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
 
 let whd_simpl_orelse_delta_but_fix env sigma c =
   let rec redrec s =
-    let (constr, stack as s') = whd_simpl_state env sigma s in 
+    let (constr, stack as s') = whd_simpl_state env sigma s in
     if isEvalRef env constr then
       match reference_opt_value sigma env (destEvalRef constr) with
 	| Some c ->
-	    (match kind_of_term (snd (decompose_lam c)) with 
+	    (match kind_of_term ((strip_lam c)) with
               | CoFix _ | Fix _ -> s'
 	      | _ -> redrec (c, stack))
 	| None -> s'
@@ -725,14 +733,12 @@ let whd_simpl env sigma c =
 
 let simpl env sigma c = strong whd_simpl env sigma c
 
-let nf = simpl (* Compatibility *)
-
 (* Reduction at specific subterms *)
 
-let is_head c t =
+let matches_head c t =
   match kind_of_term t with
-    | App (f,_) -> f = c
-    | _ -> false
+    | App (f,_) -> matches c f
+    | _ -> raise PatternMatchingFailure
 
 let contextually byhead ((nowhere_except_in,locs),c) f env sigma t =
   let maxocc = List.fold_right max locs 0 in
@@ -740,22 +746,23 @@ let contextually byhead ((nowhere_except_in,locs),c) f env sigma t =
   let rec traverse (env,c as envc) t =
     if nowhere_except_in & (!pos > maxocc) then t
     else
-    if (not byhead & eq_constr c t) or (byhead & is_head c t) then
-      let ok = 
+    try
+      let subst = if byhead then matches_head c t else matches c t in
+      let ok =
 	if nowhere_except_in then List.mem !pos locs
 	else not (List.mem !pos locs) in
       incr pos;
       if ok then
-	f env sigma t
+	f subst env sigma t
       else if byhead then
 	(* find other occurrences of c in t; TODO: ensure left-to-right *)
         let (f,l) = destApp t in
 	mkApp (f, array_map_left (traverse envc) l)
       else
 	t
-    else
+    with PatternMatchingFailure ->
       map_constr_with_binders_left_to_right
-	(fun d (env,c) -> (push_rel d env,lift 1 c))
+	(fun d (env,c) -> (push_rel d env,lift_pattern 1 c))
         traverse envc t
   in
   let t' = traverse (env,c) t in
@@ -775,7 +782,7 @@ let substlin env evalref n (nowhere_except_in,locs) c =
   let rec substrec () c =
     if nowhere_except_in & !pos > maxocc then c
     else if c = term then
-      let ok = 
+      let ok =
 	if nowhere_except_in then List.mem !pos locs
 	else not (List.mem !pos locs) in
       incr pos;
@@ -791,7 +798,7 @@ let substlin env evalref n (nowhere_except_in,locs) c =
 let string_of_evaluable_ref env = function
   | EvalVarRef id -> string_of_id id
   | EvalConstRef kn ->
-      string_of_qualid 
+      string_of_qualid
         (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn))
 
 let unfold env sigma name =
@@ -800,7 +807,7 @@ let unfold env sigma name =
   else
     error (string_of_evaluable_ref env name^" is opaque.")
 
-(* [unfoldoccs : (readable_constraints -> (int list * section_path) -> constr -> constr)]
+(* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)]
  * Unfolds the constant name in a term c following a list of occurrences occl.
  * at the occurrences of occ_list. If occ_list is empty, unfold all occurences.
  * Performs a betaiota reduction after unfolding. *)
@@ -808,14 +815,14 @@ let unfoldoccs env sigma ((nowhere_except_in,locs as plocs),name) c =
   if locs = [] then if nowhere_except_in then c else unfold env sigma name c
   else
     let (nbocc,uc) = substlin env name 1 plocs c in
-    if nbocc = 1 then 
+    if nbocc = 1 then
       error ((string_of_evaluable_ref env name)^" does not occur.");
     let rest = List.filter (fun o -> o >= nbocc) locs in
     if rest <> [] then error_invalid_occurrence rest;
     nf_betaiota sigma uc
 
 (* Unfold reduction tactic: *)
-let unfoldn loccname env sigma c = 
+let unfoldn loccname env sigma c =
   List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname
 
 (* Re-folding constants tactics: refold com in term c *)
@@ -858,9 +865,9 @@ let abstract_scheme env sigma (locc,a) c =
   let ta = Retyping.get_type_of env sigma a in
   let na = named_hd env ta Anonymous in
   if occur_meta ta then error "Cannot find a type for the generalisation.";
-  if occur_meta a then 
+  if occur_meta a then
     mkLambda (na,ta,c)
-  else 
+  else
     mkLambda (na,ta,subst_term_occ locc a c)
 
 let pattern_occs loccs_trm env sigma c =
@@ -876,7 +883,7 @@ let pattern_occs loccs_trm env sigma c =
 (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name
    return name, B and t' *)
 
-let reduce_to_ind_gen allow_product env sigma t = 
+let reduce_to_ind_gen allow_product env sigma t =
   let rec elimrec env t l =
     let t = hnf_constr env sigma t in
     match kind_of_term (fst (decompose_app t)) with
@@ -904,7 +911,7 @@ let reduce_to_atomic_ind x = reduce_to_ind_gen false x
 
 exception NotStepReducible
 
-let one_step_reduce env sigma c = 
+let one_step_reduce env sigma c =
   let rec redrec (x, stack) =
     match kind_of_term x with
       | Lambda (n,t,c)  ->
@@ -933,7 +940,7 @@ let one_step_reduce env sigma c =
 	       | None -> raise NotStepReducible)
 
       | _ -> raise NotStepReducible
-  in 
+  in
   app_stack (redrec (c, empty_stack))
 
 let isIndRef = function IndRef _ -> true | _ -> false
@@ -942,34 +949,34 @@ let reduce_to_ref_gen allow_product env sigma ref t =
   if isIndRef ref then
     let (mind,t) = reduce_to_ind_gen allow_product env sigma t in
     if IndRef mind <> ref then
-      errorlabstrm "" (str "Cannot recognize a statement based on " ++ 
+      errorlabstrm "" (str "Cannot recognize a statement based on " ++
         Nametab.pr_global_env Idset.empty ref ++ str".")
     else
       t
   else
   (* lazily reduces to match the head of [t] with the expected [ref] *)
-  let rec elimrec env t l = 
+  let rec elimrec env t l =
     let c, _ = Reductionops.whd_stack sigma t in
     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)
-	  else 
-	     errorlabstrm "" 
-	       (str "Cannot recognize an atomic statement based on " ++ 
+	  else
+	     errorlabstrm ""
+	       (str "Cannot recognize an atomic statement based on " ++
 	        Nametab.pr_global_env Idset.empty ref ++ str".")
       | _ ->
-	  try 
-	    if global_of_constr c = ref 
+	  try
+	    if global_of_constr c = ref
 	    then it_mkProd_or_LetIn t l
 	    else raise Not_found
 	  with Not_found ->
-          try 
-	    let t' = nf_betaiota sigma (one_step_reduce env sigma t) in 
+          try
+	    let t' = nf_betaiota sigma (one_step_reduce env sigma t) in
 	    elimrec env t' l
           with NotStepReducible ->
 	    errorlabstrm ""
-	      (str "Cannot recognize a statement based on " ++ 
+	      (str "Cannot recognize a statement based on " ++
 	       Nametab.pr_global_env Idset.empty ref ++ str".")
   in
   elimrec env t []
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index e12d6ad2..2bba87a7 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacred.mli 11094 2008-06-10 19:35:23Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -17,16 +17,27 @@ open Reductionops
 open Closure
 open Rawterm
 open Termops
+open Pattern
 (*i*)
 
-type reduction_tactic_error = 
+type reduction_tactic_error =
     InvalidAbstraction of env * constr * (env * Type_errors.type_error)
 
 exception ReductionTacticError of reduction_tactic_error
 
 (*s Reduction functions associated to tactics. \label{tacred} *)
 
-val is_evaluable : env -> evaluable_global_reference -> bool
+(* Evaluable global reference *)
+
+val is_evaluable : Environ.env -> evaluable_global_reference -> bool
+
+val error_not_evaluable : Libnames.global_reference -> 'a
+
+val evaluable_of_global_reference :
+  Environ.env -> Libnames.global_reference -> evaluable_global_reference
+
+val global_of_evaluable_reference :
+  evaluable_global_reference -> Libnames.global_reference
 
 exception Redelimination
 
@@ -37,7 +48,7 @@ val red_product : reduction_function
 val try_red_product : reduction_function
 
 (* Simpl *)
-val simpl : reduction_function 
+val simpl : reduction_function
 
 (* Simpl only at the head *)
 val whd_simpl : reduction_function
@@ -47,7 +58,7 @@ val whd_simpl : reduction_function
 val hnf_constr : reduction_function
 
 (* Unfold *)
-val unfoldn : 
+val unfoldn :
   (occurrences * evaluable_global_reference) list ->  reduction_function
 
 (* Fold *)
@@ -75,17 +86,12 @@ val reduce_to_atomic_ind : env ->  evar_map -> types -> inductive * types
 val reduce_to_quantified_ind : env ->  evar_map -> types -> inductive * types
 
 (* [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form
-   [t'=(x1:A1)..(xn:An)(ref args)] and raise [Not_found] if not possible *)
+   [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *)
 val reduce_to_quantified_ref :
   env ->  evar_map -> Libnames.global_reference -> types -> types
 
 val reduce_to_atomic_ref :
   env ->  evar_map -> Libnames.global_reference -> types -> types
 
-val contextually : bool -> occurrences * constr -> reduction_function
-  -> reduction_function
-
-(* Compatibility *)
-(* use [simpl] instead of [nf] *)
-val nf :  reduction_function
-
+val contextually : bool -> occurrences * constr_pattern ->
+  (patvar_map -> reduction_function) -> reduction_function
diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml
new file mode 100644
index 00000000..04e328cb
--- /dev/null
+++ b/pretyping/term_dnet.ml
@@ -0,0 +1,404 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(*i*)
+open Util
+open Term
+open Sign
+open Names
+open Libnames
+open Mod_subst
+open Pp (* debug *)
+(*i*)
+
+
+(* Representation/approximation of terms to use in the dnet:
+ *
+ * - no meta or evar (use ['a pattern] for that)
+ *
+ * - [Rel]s and [Sort]s are not taken into account (that's why we need
+ *   a second pass of linear filterin on the results - it's not a perfect
+ *   term indexing structure)
+
+ * - Foralls and LetIns are represented by a context DCtx (a list of
+ *   generalization, similar to rel_context, and coded with DCons and
+ *   DNil). This allows for matching under an unfinished context
+ *)
+
+module DTerm =
+struct
+
+  type 't t =
+    | DRel
+    | DSort
+    | DRef    of global_reference
+    | DCtx    of 't * 't (* (binding list, subterm) = Prods and LetIns *)
+    | DLambda of 't * 't
+    | DApp    of 't * 't (* binary app *)
+    | DCase   of case_info * 't * 't * 't array
+    | DFix    of int array * int * 't array * 't array
+    | DCoFix  of int * 't array * 't array
+
+    (* special constructors only inside the left-hand side of DCtx or
+       DApp. Used to encode lists of foralls/letins/apps as contexts *)
+    | DCons   of ('t * 't option) * 't
+    | DNil
+
+  type dconstr = dconstr t
+
+  (* debug *)
+  let rec pr_dconstr f : 'a t -> std_ppcmds = function
+    | DRel -> str "*"
+    | DSort -> str "Sort"
+    | DRef _ -> str "Ref"
+    | DCtx (ctx,t) -> f ctx ++ spc() ++ str "|-" ++ spc () ++ f t
+    | DLambda (t1,t2) -> str "fun"++ spc() ++ f t1 ++ spc() ++ str"->" ++ spc() ++ f t2
+    | DApp (t1,t2) -> f t1 ++ spc() ++ f t2
+    | DCase (_,t1,t2,ta) -> str "case"
+    | DFix _ -> str "fix"
+    | DCoFix _ -> str "cofix"
+    | DCons ((t,dopt),tl) -> f t ++ (match dopt with
+	  Some t' -> str ":=" ++ f t'
+	| None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl
+    | DNil -> str "[]"
+
+  (*
+   * Functional iterators for the t datatype
+   * a.k.a boring and error-prone boilerplate code
+   *)
+
+  let map f = function
+    | (DRel | DSort | DNil | DRef _) as c -> c
+    | DCtx (ctx,c) -> DCtx (f ctx, f c)
+    | DLambda (t,c) -> DLambda (f t, f c)
+    | DApp (t,u) -> DApp (f t,f u)
+    | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl)
+    | DFix (ia,i,ta,ca) ->
+	DFix (ia,i,Array.map f ta,Array.map f ca)
+    | DCoFix(i,ta,ca) ->
+	DCoFix (i,Array.map f ta,Array.map f ca)
+    | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u)
+
+  let compare x y =
+    let make_name n =
+      match n with
+	| DRef(ConstRef con) ->
+	    DRef(ConstRef(constant_of_kn(canonical_con con)))
+	| DRef(IndRef (kn,i)) ->
+	    DRef(IndRef(mind_of_kn(canonical_mind kn),i))
+	| DRef(ConstructRef ((kn,i),j ))->
+	    DRef(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
+	| k -> k in
+    Pervasives.compare (make_name x) (make_name y)
+
+  let fold f acc = function
+    | (DRel | DNil | DSort | DRef _) -> acc
+    | DCtx (ctx,c) -> f (f acc ctx) c
+    | DLambda (t,c) -> f (f acc t) c
+    | DApp (t,u) -> f (f acc t) u
+    | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
+    | DFix (ia,i,ta,ca) ->
+	Array.fold_left f (Array.fold_left f acc ta) ca
+    | DCoFix(i,ta,ca) ->
+	Array.fold_left f (Array.fold_left f acc ta) ca
+    | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u
+
+  let choose f = function
+    | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose"
+    | DCtx (ctx,c) -> f ctx
+    | DLambda (t,c) -> f t
+    | DApp (t,u) -> f u
+    | DCase (ci,p,c,bl) -> f c
+    | DFix (ia,i,ta,ca) -> f ta.(0)
+    | DCoFix (i,ta,ca) -> f ta.(0)
+    | DCons ((t,topt),u) -> f u
+
+  let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a =
+    let head w = map (fun _ -> ()) w in
+    if compare (head c1) (head c2) <> 0
+    then invalid_arg "fold2:compare" else
+      match c1,c2 with
+	| (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc
+	| (DCtx (c1,t1), DCtx (c2,t2)
+	  | DApp (c1,t1), DApp (c2,t2)
+	  | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2
+	| DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) ->
+	    array_fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2
+	| DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) ->
+	    array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2
+	| DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) ->
+	    array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2
+	| DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) ->
+	    f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2
+	| _ -> assert false
+
+  let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t =
+    let head w = map (fun _ -> ()) w in
+    if compare (head c1) (head c2) <> 0
+    then invalid_arg "map2_t:compare" else
+      match c1,c2 with
+	| (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc ->
+	    let (c,_) = cc in c
+	| DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2)
+	| DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2)
+	| DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2)
+	| DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) ->
+	    DCase (ci, f p1 p2, f c1 c2, array_map2 f bl1 bl2)
+	| DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) ->
+	    DFix (ia,i,array_map2 f ta1 ta2,array_map2 f ca1 ca2)
+	| DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) ->
+	    DCoFix (i,array_map2 f ta1 ta2,array_map2 f ca1 ca2)
+	| DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) ->
+	    DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2)
+	| _ -> assert false
+
+  let terminal = function
+    | (DRel | DSort | DNil | DRef _) -> true
+    | _ -> false
+end
+
+(*
+ * Terms discrimination nets
+ * Uses the general dnet datatype on DTerm.t
+ * (here you can restart reading)
+ *)
+
+(*
+ * Construction of the module
+ *)
+
+module type IDENT =
+sig
+  type t
+  val compare : t -> t -> int
+  val subst : substitution -> t -> t
+  val constr_of : t -> constr
+end
+
+module type OPT =
+sig
+  val reduce : constr -> constr
+  val direction : bool
+end
+
+module Make =
+  functor (Ident : IDENT) ->
+  functor (Opt : OPT) ->
+struct
+
+  module TDnet : Dnet.S with type ident=Ident.t
+			and  type 'a structure = 'a DTerm.t
+			and  type meta = metavariable
+    = Dnet.Make(DTerm)(Ident)
+    (struct
+       type t = metavariable
+       let compare = Pervasives.compare
+     end)
+
+  type t = TDnet.t
+
+  type ident = TDnet.ident
+
+  type 'a pattern = 'a TDnet.pattern
+  type term_pattern = term_pattern DTerm.t pattern
+
+  type idset = TDnet.Idset.t
+
+  type result = ident * (constr*existential_key) * Termops.subst
+
+  open DTerm
+  open TDnet
+
+  let rec pat_of_constr c : term_pattern =
+    match kind_of_term c with
+      | Rel _          -> Term DRel
+      | Sort _         -> Term DSort
+      | Var i          -> Term (DRef (VarRef i))
+      | Const c        -> Term (DRef (ConstRef c))
+      | Ind i          -> Term (DRef (IndRef i))
+      | Construct c    -> Term (DRef (ConstructRef c))
+      | Term.Meta _    -> assert false
+      | Evar (i,_)     -> Meta i
+      | Case (ci,c1,c2,ca)     ->
+	  Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca))
+      | Fix ((ia,i),(_,ta,ca)) ->
+	  Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca))
+      | CoFix (i,(_,ta,ca))    ->
+	  Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca))
+      | Cast (c,_,_)   -> pat_of_constr c
+      | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c))
+      | (Prod (_,_,_) | LetIn(_,_,_,_))   ->
+	  let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c))
+      | App (f,ca)     ->
+	  Array.fold_left (fun c a -> Term (DApp (c,a)))
+	    (pat_of_constr f) (Array.map pat_of_constr ca)
+
+  and ctx_of_constr ctx c : term_pattern * term_pattern =
+    match kind_of_term c with
+      | Prod (_,t,c)   -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c
+      | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c
+      | _ -> ctx,pat_of_constr c
+
+  let empty_ctx : term_pattern -> term_pattern = function
+    | Meta _ as c -> c
+    | Term (DCtx(_,_)) as c -> c
+    | c -> Term (DCtx (Term DNil, c))
+
+  (*
+   * Basic primitives
+   *)
+
+  let empty = TDnet.empty
+
+  let subst s t =
+    let sleaf id = Ident.subst s id in
+    let snode = function
+      | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr))
+      | n -> n in
+    TDnet.map sleaf snode t
+
+  let union = TDnet.union
+
+  let add (c:constr) (id:Ident.t) (dn:t) =
+    let c = Opt.reduce c in
+    let c = empty_ctx (pat_of_constr c) in
+    TDnet.add dn c id
+
+  let new_meta_no =
+    let ctr = ref 0 in
+    fun () -> decr ctr; !ctr
+
+  let new_meta_no = Evarutil.new_untyped_evar
+
+  let neutral_meta = new_meta_no()
+
+  let new_meta () = Meta (new_meta_no())
+  let new_evar () = mkEvar(new_meta_no(),[||])
+
+  let rec remove_cap : term_pattern -> term_pattern = function
+    | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u))
+    | Term DNil -> new_meta()
+    | Meta _ as m -> m
+    | _ -> assert false
+
+  let under_prod : term_pattern -> term_pattern = function
+    | Term (DCtx (t,u)) -> Term (DCtx (remove_cap t,u))
+    | Meta m -> Term (DCtx(new_meta(), Meta m))
+    | _ -> assert false
+
+  let init = let e = new_meta_no() in (mkEvar (e,[||]),e)
+
+  let rec e_subst_evar i (t:unit->constr) c =
+    match kind_of_term c with
+    | Evar (j,_) when i=j -> t()
+    | _ -> map_constr (e_subst_evar i t) c
+
+  let subst_evar i c = e_subst_evar i (fun _ -> c)
+
+  (* debug *)
+  let rec pr_term_pattern p =
+    (fun pr_t -> function
+       | Term t -> pr_t t
+       | Meta m -> str"["++Util.pr_int (Obj.magic m)++str"]"
+    ) (pr_dconstr pr_term_pattern) p
+
+  let search_pat cpat dpat dn (up,plug) =
+    let whole_c = subst_evar plug cpat up in
+    (* if we are at the root, add an empty context *)
+    let dpat = if isEvar_or_Meta up then under_prod (empty_ctx dpat) else dpat in
+    TDnet.Idset.fold
+      (fun id acc ->
+	 let c_id = Opt.reduce (Ident.constr_of id) in
+	 let (ctx,wc) =
+	   try Termops.align_prod_letin whole_c c_id
+	   with Invalid_argument _ -> [],c_id in
+	 let up = it_mkProd_or_LetIn up ctx in
+	 let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in
+	 try (id,(up,plug),Termops.filtering ctx Reduction.CUMUL wc whole_c)::acc
+	 with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc
+      ) (TDnet.find_match dpat dn) []
+
+  let fold_pattern_neutral f =
+    fold_pattern (fun acc (mset,m,dn) -> if m=neutral_meta then acc else f m dn acc)
+
+  let fold_pattern_nonlin f =
+    let defined = ref Gmap.empty in
+    fold_pattern_neutral
+      ( fun m dn acc ->
+	 let dn = try TDnet.inter dn (Gmap.find m !defined) with Not_found -> dn in
+	 defined := Gmap.add m dn !defined;
+	 f m dn acc )
+
+  let fold_pattern_up f acc dpat cpat dn (up,plug) =
+    fold_pattern_nonlin
+      ( fun m dn acc ->
+	  f dn (subst_evar plug (e_subst_evar neutral_meta new_evar cpat) up, m) acc
+      ) acc dpat dn
+
+  let possibly_under pat k dn (up,plug) =
+    let rec aux fst dn (up,plug) acc =
+      let cpat = pat() in
+      let dpat = pat_of_constr cpat in
+      let dpat = if fst then under_prod (empty_ctx dpat) else dpat in
+	(k dn (up,plug)) @
+	  snd (fold_pattern_up (aux false) acc dpat cpat dn (up,plug)) in
+      aux true dn (up,plug) []
+
+  let eq_pat eq () = mkApp(eq,[|mkEvar(neutral_meta,[||]);new_evar();new_evar()|])
+  let app_pat () = mkApp(new_evar(),[|mkEvar(neutral_meta,[||])|])
+
+  (*
+   * High-level primitives describing specific search problems
+   *)
+
+  let search_pattern dn pat =
+    let pat = Opt.reduce pat in
+    search_pat pat (empty_ctx (pat_of_constr pat)) dn init
+
+  let search_concl dn pat =
+    let pat = Opt.reduce pat in
+    search_pat pat (under_prod (empty_ctx (pat_of_constr pat))) dn init
+
+  let search_eq_concl dn eq pat =
+    let pat = Opt.reduce pat in
+    let eq_pat = eq_pat eq () in
+    let eq_dpat = under_prod (empty_ctx (pat_of_constr eq_pat)) in
+    snd (fold_pattern_up
+      (fun dn up acc ->
+	 search_pat pat (pat_of_constr pat) dn up @ acc
+      ) [] eq_dpat eq_pat dn init)
+
+   let search_head_concl dn pat =
+    let pat = Opt.reduce pat in
+    possibly_under app_pat (search_pat pat (pat_of_constr pat)) dn init
+
+  let find_all dn = Idset.elements (TDnet.find_all dn)
+
+  let map f dn = TDnet.map f (fun x -> x) dn
+end
+
+module type S =
+sig
+  type t
+  type ident
+
+  type result = ident * (constr*existential_key) * Termops.subst
+
+  val empty : t
+  val add : constr -> ident -> t -> t
+  val union : t -> t -> t
+  val subst : substitution -> t -> t
+  val search_pattern : t -> constr -> result list
+  val search_concl : t -> constr -> result list
+  val search_head_concl : t -> constr -> result list
+  val search_eq_concl : t -> constr -> constr -> result list
+  val find_all : t -> ident list
+  val map : (ident -> ident) -> t -> t
+end
diff --git a/pretyping/term_dnet.mli b/pretyping/term_dnet.mli
new file mode 100644
index 00000000..0e7fdb82
--- /dev/null
+++ b/pretyping/term_dnet.mli
@@ -0,0 +1,112 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(*i*)
+open Term
+open Sign
+open Libnames
+open Mod_subst
+(*i*)
+
+(* Dnets on constr terms.
+
+   An instantiation of Dnet on (an approximation of) constr. It
+   associates a term (possibly with Evar) with an
+   identifier. Identifiers must be unique (no two terms sharing the
+   same ident), and there must be a way to recover the full term from
+   the identifier (function constr_of).
+
+   Optionally, a pre-treatment on terms can be performed before adding
+   or searching (reduce). Practically, it is used to do some kind of
+   delta-reduction on terms before indexing them.
+
+   The results returned here are perfect, since post-filtering is done
+   inside here.
+
+   See lib/dnet.mli for more details.
+*)
+
+(* Identifiers to store (right hand side of the association) *)
+module type IDENT = sig
+  type t
+  val compare : t -> t -> int
+
+  (* how to substitute them for storage *)
+  val subst : substitution -> t -> t
+
+  (* how to recover the term from the identifier *)
+  val constr_of : t -> constr
+end
+
+(* Options : *)
+module type OPT = sig
+
+  (* pre-treatment to terms before adding or searching *)
+  val reduce : constr -> constr
+
+  (* direction of post-filtering w.r.t sort subtyping :
+     - true means query <= terms in the structure
+     - false means terms <= query
+ *)
+  val direction : bool
+end
+
+module type S =
+sig
+  type t
+  type ident
+
+  (* results of filtering : identifier, a context (term with Evar
+     hole) and the substitution in that context*)
+  type result = ident * (constr*existential_key) * Termops.subst
+
+  val empty : t
+
+  (* [add c i dn] adds the binding [(c,i)] to [dn]. [c] can be a
+     closed term or a pattern (with untyped Evars). No Metas accepted *)
+  val add : constr -> ident -> t -> t
+
+  (* merge of dnets. Faster than re-adding all terms *)
+  val union : t -> t -> t
+
+  val subst : substitution -> t -> t
+
+  (*
+   * High-level primitives describing specific search problems
+   *)
+
+  (* [search_pattern dn c] returns all terms/patterns in dn
+     matching/matched by c *)
+  val search_pattern : t -> constr -> result list
+
+  (* [search_concl dn c] returns all matches under products and
+     letins, i.e. it finds subterms whose conclusion matches c. The
+     complexity depends only on c ! *)
+  val search_concl : t -> constr -> result list
+
+  (* [search_head_concl dn c] matches under products and applications
+     heads. Finds terms of the form [forall H_1...H_n, C t_1...t_n]
+     where C matches c *)
+  val search_head_concl : t -> constr -> result list
+
+  (* [search_eq_concl dn eq c] searches terms of the form [forall
+     H1...Hn, eq _ X1 X2] where either X1 or X2 matches c *)
+  val search_eq_concl : t -> constr -> constr -> result list
+
+  (* [find_all dn] returns all idents contained in dn *)
+  val find_all : t -> ident list
+
+  val map : (ident -> ident) -> t -> t
+end
+
+module Make :
+  functor (Ident : IDENT) ->
+  functor (Opt : OPT) ->
+    S with type ident = Ident.t
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 4f38fbb3..3e4c5ae5 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termops.ml 12058 2009-04-08 10:54:59Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -34,7 +34,7 @@ let pr_name = function
   | Name id -> pr_id id
   | Anonymous -> str "_"
 
-let pr_sp sp = str(string_of_kn sp)
+let pr_path sp = str(string_of_kn sp)
 let pr_con sp = str(string_of_con sp)
 
 let rec pr_constr c = match kind_of_term c with
@@ -42,7 +42,7 @@ let rec pr_constr c = match kind_of_term c with
   | Meta n -> str "Meta(" ++ int n ++ str ")"
   | Var id -> pr_id id
   | Sort s -> print_sort s
-  | Cast (c,_, t) -> hov 1 
+  | Cast (c,_, t) -> hov 1
       (str"(" ++ pr_constr c ++ cut() ++
        str":" ++ pr_constr t ++ str")")
   | Prod (Name(id),t,c) -> hov 1
@@ -65,9 +65,9 @@ let rec pr_constr c = match kind_of_term c with
       (str"Evar#" ++ int e ++ str"{" ++
        prlist_with_sep spc pr_constr (Array.to_list l) ++str"}")
   | Const c -> str"Cst(" ++ pr_con c ++ str")"
-  | Ind (sp,i) -> str"Ind(" ++ pr_sp sp ++ str"," ++ int i ++ str")"
+  | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")"
   | Construct ((sp,i),j) ->
-      str"Constr(" ++ pr_sp sp ++ str"," ++ int i ++ str"," ++ int j ++ str")"
+      str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")"
   | Case (ci,p,c,bl) -> v 0
       (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++
              pr_constr c ++ str"of") ++ cut() ++
@@ -99,7 +99,7 @@ let pr_var_decl env (id,c,typ) =
   let pbody = match c with
     | None ->  (mt ())
     | Some c ->
-	(* Force evaluation *) 
+	(* Force evaluation *)
 	let pb = print_constr_env env c in
 	  (str" := " ++ pb ++ cut () ) in
   let pt = print_constr_env env typ in
@@ -110,7 +110,7 @@ let pr_rel_decl env (na,c,typ) =
   let pbody = match c with
     | None -> mt ()
     | Some c ->
-	(* Force evaluation *) 
+	(* Force evaluation *)
 	let pb = print_constr_env env c in
 	  (str":=" ++ spc () ++ pb ++ spc ()) in
   let ptyp = print_constr_env env typ in
@@ -120,39 +120,39 @@ let pr_rel_decl env (na,c,typ) =
 
 let print_named_context env =
   hv 0 (fold_named_context
-	  (fun env d pps -> 
+	  (fun env d pps ->
 	    pps ++ ws 2 ++ pr_var_decl env d)
           env ~init:(mt ()))
 
-let print_rel_context env = 
+let print_rel_context env =
   hv 0 (fold_rel_context
 	  (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d)
           env ~init:(mt ()))
-    
+
 let print_env env =
   let sign_env =
     fold_named_context
       (fun env d pps ->
          let pidt =  pr_var_decl env d in
 	 (pps ++ fnl () ++ pidt))
-      env ~init:(mt ()) 
+      env ~init:(mt ())
   in
   let db_env =
     fold_rel_context
       (fun env d pps ->
          let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
       env ~init:(mt ())
-  in 
+  in
     (sign_env ++ db_env)
-    
+
 (*let current_module = ref empty_dirpath
 
 let set_module m = current_module := m*)
 
-let new_univ = 
+let new_univ =
   let univ_gen = ref 0 in
   (fun sp ->
-    incr univ_gen; 
+    incr univ_gen;
     Univ.make_univ (Lib.library_dp(),!univ_gen))
 let new_Type () = mkType (new_univ ())
 let new_Type_sort () = Type (new_univ ())
@@ -173,26 +173,20 @@ let refresh_universes_gen strict t =
 let refresh_universes = refresh_universes_gen false
 let refresh_universes_strict = refresh_universes_gen true
 
-let new_sort_in_family = function 
+let new_sort_in_family = function
   | InProp -> prop_sort
   | InSet -> set_sort
   | InType -> Type (new_univ ())
 
 
 
-(* prod_it b [xn:Tn;..;x1:T1] = (x1:T1)..(xn:Tn)b *)
-let prod_it ~init = List.fold_left (fun c (n,t)  -> mkProd (n, t, c)) init
-
-(* lam_it b [xn:Tn;..;x1:T1] = [x1:T1]..[xn:Tn]b *)
-let lam_it ~init = List.fold_left (fun c (n,t)  -> mkLambda (n, t, c)) init
-
 (* [Rel (n+m);...;Rel(n+1)] *)
 let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
 
-let rel_list n m = 
-  let rec reln l p = 
+let rel_list n m =
+  let rec reln l p =
     if p>m then l else reln (mkRel(n+p)::l) (p+1)
-  in 
+  in
   reln [] 1
 
 (* Same as [rel_list] but takes a context as argument and skips let-ins *)
@@ -201,7 +195,7 @@ let extended_rel_list n hyps =
     | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
     | (_,Some _,_) :: hyps -> reln l (p+1) hyps
     | [] -> l
-  in 
+  in
   reln [] 1 hyps
 
 let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps)
@@ -224,53 +218,49 @@ let push_named_rec_types (lna,typarray,_) env =
   Array.fold_left
     (fun e assum -> push_named assum e) env ctxt
 
-let rec lookup_rel_id id sign = 
+let rec lookup_rel_id id sign =
   let rec lookrec = function
     | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l)
-    | (n, (Name id',_,t)::l)  -> if id' = id then (n,t) else lookrec (n+1,l)
+    | (n, (Name id',b,t)::l)  -> if id' = id then (n,b,t) else lookrec (n+1,l)
     | (_, [])                 -> raise Not_found
-  in 
+  in
   lookrec (1,sign)
 
-(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+(* 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)
 
-(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
+(* 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 it_mkProd_wo_LetIn ~init = 
-  List.fold_left (fun c d -> mkProd_wo_LetIn d c) init
-
-let it_mkProd_or_LetIn ~init = 
-  List.fold_left (fun c d -> mkProd_or_LetIn d c) init
-
-let it_mkLambda_or_LetIn ~init =
-  List.fold_left (fun c d -> mkLambda_or_LetIn d c) init
+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
 
-let it_named_context_quantifier f ~init = 
+let it_named_context_quantifier f ~init =
   List.fold_left (fun c d -> f d c) init
 
+let it_mkProd_or_LetIn = it_named_context_quantifier mkProd_or_LetIn
+let it_mkProd_wo_LetIn = it_named_context_quantifier mkProd_wo_LetIn
+let it_mkLambda_or_LetIn = it_named_context_quantifier mkLambda_or_LetIn
 let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn
-let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn
-
 let it_mkNamedProd_wo_LetIn = it_named_context_quantifier mkNamedProd_wo_LetIn
+let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn
 
 (* *)
 
 (* strips head casts and flattens head applications *)
 let rec strip_head_cast c = match kind_of_term c with
-  | App (f,cl) -> 
+  | App (f,cl) ->
       let rec collapse_rec f cl2 = match kind_of_term f with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
 	| Cast (c,_,_) -> collapse_rec c cl2
 	| _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
-      in 
+      in
       collapse_rec f cl
   | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
@@ -358,7 +348,7 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
 let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> cstr
-  | Cast (c,k, t) -> 
+  | Cast (c,k, t) ->
       let c' = f l c in
       let t' = f l t in
       if c==c' && t==t' then cstr else mkCast (c', k, t')
@@ -422,7 +412,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with
   | App (c,l) -> Array.fold_left (f n) (f n acc c) l
   | 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)) -> 
+  | Fix (_,(lna,tl,bl)) ->
       let n' = iterate g (Array.length tl) n in
       let fd = array_map2 (fun t b -> (t,b)) tl bl in
       Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
@@ -446,7 +436,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with
   | App (c,args) -> f l c; Array.iter (f l) args
   | 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)) -> 
+  | Fix (_,(lna,tl,bl)) ->
       let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
       Array.iter (f l) tl;
       Array.iter (f l') bl
@@ -456,7 +446,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with
       Array.iter (f l') bl
 
 (***************************)
-(* occurs check functions  *)                         
+(* occurs check functions  *)
 (***************************)
 
 exception Occur
@@ -467,42 +457,43 @@ let occur_meta c =
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur -> true
 
-let occur_existential c = 
+let occur_existential c =
   let rec occrec c = match kind_of_term c with
     | Evar _ -> raise Occur
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur -> true
 
-let occur_meta_or_existential c = 
+let occur_meta_or_existential c =
   let rec occrec c = match kind_of_term c with
     | Evar _ -> raise Occur
     | Meta _ -> raise Occur
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur -> true
 
-let occur_const s c = 
+let occur_const s c =
   let rec occur_rec c = match kind_of_term c with
     | Const sp when sp=s -> raise Occur
     | _ -> iter_constr occur_rec c
-  in 
+  in
   try occur_rec c; false with Occur -> true
 
-let occur_evar n c = 
+let occur_evar n c =
   let rec occur_rec c = match kind_of_term c with
     | Evar (sp,_) when sp=n -> raise Occur
     | _ -> iter_constr occur_rec c
-  in 
+  in
   try occur_rec c; false with Occur -> true
 
 let occur_in_global env id constr =
   let vars = vars_of_global env constr in
   if List.mem id vars then raise Occur
 
-let occur_var env s c = 
+let occur_var env id c =
   let rec occur_rec c =
-    occur_in_global env s c;
-    iter_constr occur_rec c
-  in 
+    match kind_of_term c with
+    | Var _ | Const _ | Ind _ | Construct _ -> occur_in_global env id c
+    | _ -> iter_constr occur_rec c
+  in
   try occur_rec c; false with Occur -> true
 
 let occur_var_in_decl env hyp (_,c,typ) =
@@ -512,25 +503,19 @@ let occur_var_in_decl env hyp (_,c,typ) =
         occur_var env hyp typ ||
         occur_var env hyp body
 
-(* Tests that t is a subterm of c *)
-let occur_term t c = 
-  let eq_constr_fail c = if eq_constr t c then raise Occur
-  in let rec occur_rec c = eq_constr_fail c; iter_constr occur_rec c
-  in try occur_rec c; false with Occur -> true
-
 (* returns the list of free debruijn indices in a term *)
 
-let free_rels m = 
+let free_rels m =
   let rec frec depth acc c = match kind_of_term c with
     | Rel n       -> if n >= depth then Intset.add (n-depth+1) acc else acc
     | _ -> fold_constr_with_binders succ frec depth acc c
-  in 
+  in
   frec 1 Intset.empty m
 
 (* collects all metavar occurences, in left-to-right order, preserving
  * repetitions and all. *)
 
-let collect_metas c = 
+let collect_metas c =
   let rec collrec acc c =
     match kind_of_term c with
       | Meta mv -> list_add_set mv acc
@@ -538,10 +523,10 @@ let collect_metas c =
   in
   List.rev (collrec [] c)
 
-(* (dependent M N) is true iff M is eq_term with a subterm of N 
-   M is appropriately lifted through abstractions of N *)
+(* Tests whether [m] is a subterm of [t]:
+   [m] is appropriately lifted through abstractions of [t] *)
 
-let dependent m t =
+let dependent_main noevar m t =
   let rec deprec m t =
     if eq_constr m t then
       raise Occur
@@ -550,28 +535,38 @@ let dependent m t =
 	| App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
 	    deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
 	    Array.iter (deprec m)
-	      (Array.sub lt 
+	      (Array.sub lt
 		(Array.length lm) ((Array.length lt) - (Array.length lm)))
+	| _, Cast (c,_,_) when noevar & isMeta c -> ()
+	| _, Evar _ when noevar -> ()
 	| _ -> iter_constr_with_binders (lift 1) deprec m t
-  in 
+  in
   try deprec m t; false with Occur -> true
 
+let dependent = dependent_main false
+let dependent_no_evar = dependent_main true
+
+(* Synonymous *)
+let occur_term = dependent
+
 let pop t = lift (-1) t
 
 (***************************)
-(*  bindings functions *)                         
+(*  bindings functions *)
 (***************************)
 
-type metamap = (metavariable * constr) list 
+type meta_type_map = (metavariable * types) list
+
+type meta_value_map = (metavariable * constr) list
 
-let rec subst_meta bl c = 
+let rec subst_meta bl c =
   match kind_of_term c with
     | Meta i -> (try List.assoc i bl with Not_found -> c)
     | _ -> map_constr (subst_meta bl) c
 
 (* First utilities for avoiding telescope computation for subst_term *)
 
-let prefix_application eq_fun (k,c) (t : constr) = 
+let prefix_application eq_fun (k,c) (t : constr) =
   let c' = collapse_appl c and t' = collapse_appl t in
   match kind_of_term c', kind_of_term t' with
     | App (f1,cl1), App (f2,cl2) ->
@@ -580,11 +575,11 @@ let prefix_application eq_fun (k,c) (t : constr) =
 	if l1 <= l2
 	   && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
 	  Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1)))
-	else 
+	else
 	  None
     | _ -> None
 
-let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = 
+let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) =
   let c' = collapse_appl c and t' = collapse_appl t in
   match kind_of_term c', kind_of_term t' with
     | App (f1,cl1), App (f2,cl2) ->
@@ -593,7 +588,7 @@ let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) =
 	if l1 <= l2
 	   && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
 	  Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1)))
-	else 
+	else
 	  None
     | _ -> None
 
@@ -602,7 +597,7 @@ let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) =
    term [c] in a term [t] *)
 (*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*)
 
-let subst_term_gen eq_fun c t = 
+let subst_term_gen eq_fun c t =
   let rec substrec (k,c as kc) t =
     match prefix_application eq_fun kc t with
       | Some x -> x
@@ -610,7 +605,7 @@ let subst_term_gen eq_fun c t =
     if eq_fun c t then mkRel k
     else
       map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t
-  in 
+  in
   substrec (1,c) t
 
 (* Recognizing occurrences of a given (closed) subterm in a term :
@@ -618,7 +613,7 @@ let subst_term_gen eq_fun c t =
    term [c1] in a term [t] *)
 (*i Meme remarque : a priori [c] n'est pas forcement clos i*)
 
-let replace_term_gen eq_fun c by_c in_t = 
+let replace_term_gen eq_fun c by_c in_t =
   let rec substrec (k,c as kc) t =
     match my_prefix_application eq_fun kc by_c t with
       | Some x -> x
@@ -626,7 +621,7 @@ let replace_term_gen eq_fun c by_c in_t =
     (if eq_fun c t then (lift k by_c) else
       map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c))
 	substrec kc t)
-  in 
+  in
   substrec (0,c) in_t
 
 let subst_term = subst_term_gen eq_constr
@@ -645,7 +640,7 @@ let no_occurrences_in_set = (true,[])
 let error_invalid_occurrence l =
   let l = list_uniquize (List.sort Pervasives.compare l) in
   errorlabstrm ""
-    (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++ 
+    (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++
      prlist_with_sep spc int l ++ str ".")
 
 let subst_term_occ_gen (nowhere_except_in,locs) occ c t =
@@ -656,10 +651,10 @@ let subst_term_occ_gen (nowhere_except_in,locs) occ c t =
     if nowhere_except_in & !pos > maxocc then t
     else
     if eq_constr c t then
-      let r = 
+      let r =
 	if nowhere_except_in then
 	  if List.mem !pos locs then (mkRel k) else t
-	else 
+	else
 	  if List.mem !pos locs then t else (mkRel k)
       in incr pos; r
     else
@@ -670,9 +665,9 @@ let subst_term_occ_gen (nowhere_except_in,locs) occ c t =
   let t' = substrec (1,c) t in
   (!pos, t')
 
-let subst_term_occ (nowhere_except_in,locs as plocs) c t = 
+let subst_term_occ (nowhere_except_in,locs as plocs) c t =
   if locs = [] then if nowhere_except_in then t else subst_term c t
-  else 
+  else
     let (nbocc,t') = subst_term_occ_gen plocs 1 c t in
     let rest = List.filter (fun o -> o >= nbocc) locs in
     if rest <> [] then error_invalid_occurrence rest;
@@ -693,20 +688,15 @@ let subst_term_occ_decl ((nowhere_except_in,locs as plocs),hloc) c (id,bodyopt,t
 	if locs = [] then
 	  if nowhere_except_in then d
 	  else (id,Some (subst_term c body),subst_term c typ)
-	else 
+	else
 	  let (nbocc,body') = subst_term_occ_gen plocs 1 c body in
 	  let (nbocc',t') = subst_term_occ_gen plocs nbocc c typ in
 	  let rest = List.filter (fun o -> o >= nbocc') locs in
 	  if rest <> [] then error_invalid_occurrence rest;
 	  (id,Some body',t')
 
-(* First character of a constr *)
-
-let lowercase_first_char id =
-  lowercase_first_char_utf8 (string_of_id id)
-
 let vars_of_env env =
-  let s = 
+  let s =
     Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s)
       (named_context env) ~init:Idset.empty in
   Sign.fold_rel_context
@@ -717,85 +707,6 @@ let add_vname vars = function
     Name id -> Idset.add id vars
   | _ -> vars
 
-let id_of_global = Nametab.id_of_global
-
-let sort_hdchar = function
-  | Prop(_) -> "P"
-  | Type(_) -> "T"
-
-let hdchar env c = 
-  let rec hdrec k c =
-    match kind_of_term c with
-    | Prod (_,_,c)       -> hdrec (k+1) c
-    | Lambda (_,_,c)     -> hdrec (k+1) c
-    | LetIn (_,_,_,c)    -> hdrec (k+1) c
-    | Cast (c,_,_)         -> hdrec k c
-    | App (f,l)         -> hdrec k f
-    | Const kn       ->
-	lowercase_first_char (id_of_label (con_label kn))
-    | Ind ((kn,i) as x) ->
-	if i=0 then 
-	  lowercase_first_char (id_of_label (label kn))
-	else 
-	  lowercase_first_char (id_of_global (IndRef x))
-    | Construct ((sp,i) as x) ->
-	lowercase_first_char (id_of_global (ConstructRef x))
-    | Var id  -> lowercase_first_char id
-    | Sort s -> sort_hdchar s
-    | Rel n ->
-	(if n<=k then "p" (* the initial term is flexible product/function *)
-	 else
-	   try match Environ.lookup_rel (n-k) env with
-	     | (Name id,_,_)   -> lowercase_first_char id
-	     | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
-	   with Not_found -> "y")
-    | Fix ((_,i),(lna,_,_)) -> 
-	let id = match lna.(i) with Name id -> id | _ -> assert false in
-	lowercase_first_char id
-    | CoFix (i,(lna,_,_)) -> 
-	let id = match lna.(i) with Name id -> id | _ -> assert false in
-	lowercase_first_char id
-    | Meta _|Evar _|Case (_, _, _, _) -> "y"
-  in 
-  hdrec 0 c
-
-let id_of_name_using_hdchar env a = function
-  | Anonymous -> id_of_string (hdchar env a) 
-  | Name id   -> id
-
-let named_hd env a = function
-  | Anonymous -> Name (id_of_string (hdchar env a)) 
-  | x         -> x
-
-let mkProd_name   env (n,a,b) = mkProd (named_hd env a n, a, b)
-let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b)
-
-let lambda_name = mkLambda_name
-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_context env hyps =
-  snd
-    (List.fold_left
-       (fun (env,hyps) d -> 
-	  let d' = name_assumption env d in (push_rel d' env, d' :: hyps))
-       (env,[]) (List.rev hyps))
-
-let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b 
-let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b
-
-let it_mkProd_or_LetIn_name env b hyps =
-  it_mkProd_or_LetIn b (name_context env hyps)
-let it_mkLambda_or_LetIn_name env b hyps =
-  it_mkLambda_or_LetIn b (name_context env hyps)
-
 (*************************)
 (*   Names environments  *)
 (*************************)
@@ -804,12 +715,12 @@ let add_name n nl = n::nl
 let lookup_name_of_rel p names =
   try List.nth names (p-1)
   with Invalid_argument _ | Failure _ -> raise Not_found
-let rec lookup_rel_of_name id names = 
+let rec lookup_rel_of_name id names =
   let rec lookrec n = function
     | Anonymous :: l  -> lookrec (n+1) l
     | (Name id') :: l -> if id' = id then n else lookrec (n+1) l
     | []            -> raise Not_found
-  in 
+  in
   lookrec 1 names
 let empty_names_context = []
 
@@ -821,7 +732,7 @@ let ids_of_rel_context sign =
 let ids_of_named_context sign =
   Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
 
-let ids_of_context env = 
+let ids_of_context env =
   (ids_of_rel_context (rel_context env))
   @ (ids_of_named_context (named_context env))
 
@@ -829,57 +740,11 @@ let ids_of_context env =
 let names_of_rel_context env =
   List.map (fun (na,_,_) -> na) (rel_context env)
 
-(**** Globality of identifiers *)
-
-let rec is_imported_modpath = function
-  | MPfile dp -> true
-  | p -> false
-
-let is_imported_ref = function
-  | VarRef _ -> false
-  | IndRef (kn,_)
-  | ConstructRef ((kn,_),_) ->
-      let (mp,_,_) = repr_kn kn in is_imported_modpath mp
-  | ConstRef kn ->
-      let (mp,_,_) = repr_con kn in is_imported_modpath mp
-
-let is_global id =
-  try 
-    let ref = locate (make_short_qualid id) in
-    not (is_imported_ref ref)
-  with Not_found -> 
-    false
-
-let is_constructor id =
-  try 
-    match locate (make_short_qualid id) with 
-      | ConstructRef _ as ref -> not (is_imported_ref ref)
-      | _ -> false
-  with Not_found -> 
-    false
-
 let is_section_variable id =
   try let _ = Global.lookup_named id in true
   with Not_found -> false
 
-let next_global_ident_from allow_secvar id avoid = 
-  let rec next_rec id =
-    let id = next_ident_away_from id avoid in
-    if (allow_secvar && is_section_variable id) || not (is_global id) then
-      id
-    else  
-      next_rec (lift_ident id)
-  in 
-  next_rec id
-
-let next_global_ident_away allow_secvar id avoid =
-  let id  = next_ident_away id avoid in
-  if (allow_secvar && is_section_variable id) || not (is_global id) then
-    id
-  else  
-    next_global_ident_from allow_secvar (lift_ident id) avoid
-
-let isGlobalRef c = 
+let isGlobalRef c =
   match kind_of_term c with
   | Const _ | Ind _ | Construct _ | Var _ -> true
   | _ -> false
@@ -889,68 +754,6 @@ let has_polymorphic_type c =
   | Declarations.PolymorphicArity _ -> true
   | _ -> false
 
-(* nouvelle version de renommage des variables (DEC 98) *)
-(* This is the algorithm to display distinct bound variables 
-
-    - Règle 1 : un nom non anonyme, même non affiché, contribue à la liste
-      des noms à éviter 
-    - Règle 2 : c'est la dépendance qui décide si on affiche ou pas
-
-    Exemple : 
-    si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors
-    il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b)
-    mais f et f0 contribue à la liste des variables à éviter (en supposant 
-    que les noms f et f0 ne sont pas déjà pris)
-    Intérêt : noms homogènes dans un but avant et après Intro
-*)
-
-type used_idents = identifier list
-
-let occur_rel p env id = 
-  try lookup_name_of_rel p env = Name id
-  with Not_found -> false (* Unbound indice : may happen in debug *)
-
-let occur_id nenv id0 c =
-  let rec occur n c = match kind_of_term c with
-    | Var id when  id=id0 -> raise Occur
-    | Const kn when id_of_global (ConstRef kn) = id0 -> raise Occur
-    | Ind ind_sp
-	when id_of_global (IndRef ind_sp) = id0 ->
-        raise Occur
-    | Construct cstr_sp
-	when id_of_global (ConstructRef cstr_sp) = id0 ->
-        raise Occur
-    | Rel p when p>n & occur_rel (p-n) nenv id0 -> raise Occur
-    | _ -> iter_constr_with_binders succ occur n c
-  in 
-  try occur 1 c; false
-  with Occur -> true
-    | Not_found -> false (* Case when a global is not in the env *)
-
-type avoid_flags = bool option
-
-let next_name_not_occuring avoid_flags name l env_names t =
-  let rec next id =
-    if List.mem id l or occur_id env_names id t or 
-      (* Further restrictions ? *)
-      match avoid_flags with None -> false | Some not_only_cstr ->
-      (if not_only_cstr then
-	(* To be consistent with the intro mechanism *)
-	is_global id & not (is_section_variable id)
-      else
-	(* To avoid constructors in pattern-matchings *)
-	is_constructor id)
-    then next (lift_ident id)
-    else id
-  in 
-  match name with
-    | Name id   -> next id
-    | Anonymous -> 
-        (* Normally, an anonymous name is not dependent and will not be *)
-        (* taken into account by the function concrete_name; just in case *)
-        (* invent a valid name *)
-        next (id_of_string "H")
-
 let base_sort_cmp pb s0 s1 =
   match (s0,s1) with
     | (Prop c1, Prop c2) -> c1 = Null or c2 = Pos  (* Prop <= Set *)
@@ -959,14 +762,77 @@ let base_sort_cmp pb s0 s1 =
     | _ -> false
 
 (* eq_constr extended with universe erasure *)
-let rec constr_cmp cv_pb t1 t2 =
-  (match kind_of_term t1, kind_of_term t2 with
+let compare_constr_univ f cv_pb t1 t2 =
+  match kind_of_term t1, kind_of_term t2 with
       Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2
-    | _ -> false)
-  || compare_constr (constr_cmp cv_pb) t1 t2
+    | Prod (_,t1,c1), Prod (_,t2,c2) ->
+	f Reduction.CONV t1 t2 & f cv_pb c1 c2
+    | _ -> compare_constr (f Reduction.CONV) t1 t2
+
+let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2
 
 let eq_constr = constr_cmp Reduction.CONV
 
+(* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn)
+   App(c,[||]) -> ([],c) *)
+let split_app c = match kind_of_term c with
+    App(c,l) ->
+      let len = Array.length l in
+      if len=0 then ([],c) else
+	let last = Array.get l (len-1) in
+	let prev = Array.sub l 0 (len-1) in
+	c::(Array.to_list prev), last
+  | _ -> assert false
+
+let hdtl l = List.hd l, List.tl l
+
+type subst = (rel_context*constr) Intmap.t
+
+exception CannotFilter
+
+let filtering env cv_pb c1 c2 =
+  let evm = ref Intmap.empty in
+  let define cv_pb e1 ev c1 =
+    try let (e2,c2) = Intmap.find ev !evm in
+    let shift = List.length e1 - List.length e2 in
+    if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter
+    with Not_found ->
+      evm := Intmap.add ev (e1,c1) !evm
+  in
+  let rec aux env cv_pb c1 c2 =
+    match kind_of_term c1, kind_of_term c2 with
+      | App _, App _ ->
+	  let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in
+	  aux env cv_pb l1 l2; if p1=[] & p2=[] then () else
+	      aux env cv_pb (applist (hdtl p1)) (applist (hdtl p2))
+      | Prod (n,t1,c1), Prod (_,t2,c2) ->
+	  aux env cv_pb t1 t2;
+	  aux ((n,None,t1)::env) cv_pb c1 c2
+      | _, Evar (ev,_) -> define cv_pb env ev c1
+      | Evar (ev,_), _ -> define cv_pb env ev c2
+      | _ ->
+	  if compare_constr_univ
+	  (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then ()
+	  else raise CannotFilter
+	  (* TODO: le reste des binders *)
+  in
+  aux env cv_pb c1 c2; !evm
+
+let decompose_prod_letin : constr -> int * rel_context * 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
+    | Cast (c,_,_)    -> prodec_rec i l c
+    | _               -> i,l,c in
+  prodec_rec 0 []
+
+let align_prod_letin c a : rel_context * constr =
+  let (lc,_,_) = decompose_prod_letin c in
+  let (la,l,a) = decompose_prod_letin a in
+  if not (la >= lc) then invalid_arg "align_prod_letin";
+  let (l1,l2) = Util.list_chop lc l in
+  l2,it_mkProd_or_LetIn a l1
+
 (* On reduit une serie d'eta-redex de tete ou rien du tout  *)
 (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *)
 (* Remplace 2 versions précédentes buggées                  *)
@@ -976,7 +842,7 @@ let rec eta_reduce_head c =
     | Lambda (_,c1,c') ->
 	(match kind_of_term (eta_reduce_head c') with
            | App (f,cl) ->
-               let lastn = (Array.length cl) - 1 in 
+               let lastn = (Array.length cl) - 1 in
                if lastn < 1 then anomaly "application without arguments"
                else
                  (match kind_of_term cl.(lastn) with
@@ -1017,7 +883,7 @@ let assums_of_rel_context sign =
         | None -> (na, t)::l)
     sign ~init:[]
 
-let fold_map_rel_context f env sign =
+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
@@ -1039,6 +905,25 @@ let substl_rel_context l =
 let lift_rel_context n =
   map_rel_context_with_binders (liftn n)
 
+let smash_rel_context sign =
+  let rec aux acc = function
+  | [] -> acc
+  | (_,None,_ as d) :: l -> aux (d::acc) l
+  | (_,Some 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 (List.rev subst) c :: subst) sign' args'
+    | [], [] -> List.rev subst
+    | _ -> anomaly "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
@@ -1046,14 +931,11 @@ let rec mem_named_context id = function
   | _ :: sign -> mem_named_context id sign
   | [] -> false
 
-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 -> 
-       let id = next_name_away na !avoid in
-       avoid := id::!avoid;
-       push_rel (Name id,c,t) newenv)
-    env
+let clear_named_body id env =
+  let rec aux _ = function
+  | (id',Some c,t) when id = id' -> push_named (id,None,t)
+  | d -> push_named d in
+  fold_named_context aux env ~init:(reset_context env)
 
 let global_vars env ids = Idset.elements (global_vars_set env ids)
 
@@ -1076,50 +958,13 @@ let dependency_closure env sign hyps =
         sign in
     List.rev lh
 
-let default_x = id_of_string "x"
-
-let rec next_name_away_in_cases_pattern id avoid =
-  let id = match id with Name id -> id | Anonymous -> default_x in
-  let rec next id =
-    if List.mem id avoid or is_constructor id then next (lift_ident id)
-    else id in
-  next id
-
-(* Remark: Anonymous var may be dependent in Evar's contexts *)
-let concrete_name avoid_flags l env_names n c =
-  if n = Anonymous & noccurn 1 c then
-    (Anonymous,l)
-  else
-    let fresh_id = next_name_not_occuring avoid_flags n l env_names c in
-    let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
-    (idopt, fresh_id::l)
-
-let concrete_let_name avoid_flags l env_names n c =
-  let fresh_id = next_name_not_occuring avoid_flags n l env_names c in
-  (Name fresh_id, fresh_id::l)
-
-let rec rename_bound_var env avoid c =
-  let env_names = names_of_rel_context env in
-  let rec rename avoid c =
-    match kind_of_term c with
-    | Prod (na,c1,c2)  ->
-	let na',avoid' = concrete_name None avoid env_names na c2 in
-	mkProd (na', c1, rename avoid' c2)
-    | LetIn (na,c1,t,c2) ->
-	let na',avoid' = concrete_let_name None avoid env_names na c2 in
-	mkLetIn (na',c1,t, rename avoid' c2)
-    | Cast (c,k,t) -> mkCast (rename avoid c, k,t)
-    | _ -> c
-  in
-  rename avoid c
-
 (* Combinators on judgments *)
 
 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 
+(* 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
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index e0bbe7b5..f9ea7b22 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termops.mli 12058 2009-04-08 10:54:59Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Util
 open Pp
@@ -35,27 +35,32 @@ val pr_rel_decl : env -> rel_declaration -> std_ppcmds
 val print_rel_context : env -> std_ppcmds
 val print_env : env -> std_ppcmds
 
-(* iterators on terms *)
-val prod_it : init:types -> (name * types) list -> types
-val lam_it : init:constr -> (name * types) list -> constr
+(* about contexts *)
+val push_rel_assum : name * types -> env -> env
+val push_rels_assum : (name * types) list -> env -> env
+val push_named_rec_types : name array * types array * 'a -> env -> env
+val lookup_rel_id : identifier -> rel_context -> int * constr option * types
+
+(* builds argument lists matching a block of binders or a context *)
 val 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
-val push_rel_assum : name * types -> env -> env
-val push_rels_assum : (name * types) list -> env -> env
-val push_named_rec_types : name array * types array * 'a -> env -> env
-val lookup_rel_id : identifier -> rel_context -> int * types
+
+(* iterators/destructors on terms *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
 val mkProd_wo_LetIn : rel_declaration -> types -> types
-val it_mkProd_wo_LetIn : init:types -> rel_context -> types
+val it_mkProd : init:types -> (name * types) list -> types
+val it_mkLambda : init:constr -> (name * types) list -> constr
 val it_mkProd_or_LetIn   : init:types -> rel_context -> types
+val it_mkProd_wo_LetIn : init:types -> rel_context -> types
 val it_mkLambda_or_LetIn : init:constr -> rel_context -> constr
-val it_named_context_quantifier :
-  (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
 val it_mkNamedProd_or_LetIn   : init:types -> named_context -> types
-val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr
 val it_mkNamedProd_wo_LetIn   : init:types -> named_context -> types
+val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr
+
+val it_named_context_quantifier :
+  (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
 
 (**********************************************************************)
 (* Generic iterators on constr                                        *)
@@ -64,7 +69,7 @@ val map_constr_with_named_binders :
   (name -> 'a -> 'a) ->
   ('a -> constr -> constr) -> 'a -> constr -> constr
 val map_constr_with_binders_left_to_right :
-  (rel_declaration -> 'a -> 'a) -> 
+  (rel_declaration -> 'a -> 'a) ->
   ('a -> constr -> constr) ->
     'a -> constr -> constr
 val map_constr_with_full_binders :
@@ -82,7 +87,7 @@ val fold_constr_with_binders :
   ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b
 
 val iter_constr_with_full_binders :
-  (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> 
+  (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a ->
     constr -> unit
 
 (**********************************************************************)
@@ -96,18 +101,22 @@ val occur_existential : types -> bool
 val occur_meta_or_existential : types -> bool
 val occur_const : constant -> types -> bool
 val occur_evar : existential_key -> types -> bool
-val occur_in_global : env -> identifier -> constr -> unit
 val occur_var : env -> identifier -> types -> bool
 val occur_var_in_decl :
   env ->
   identifier -> 'a * types option * types -> bool
-val occur_term : constr -> constr -> bool
 val free_rels : constr -> Intset.t
 val dependent : constr -> constr -> bool
+val dependent_no_evar : constr -> constr -> bool
 val collect_metas : constr -> int list
+val occur_term : constr -> constr -> bool (* Synonymous
+ of dependent *)
 (* Substitution of metavariables *)
-type metamap = (metavariable * constr) list 
-val subst_meta : metamap -> constr -> constr
+type meta_value_map = (metavariable * constr) list
+val subst_meta : meta_value_map -> constr -> constr
+
+(* Type assignment for metavariables *)
+type meta_type_map = (metavariable * types) list
 
 (* [pop c] lifts by -1 the positive indexes in [c] *)
 val pop : constr -> constr
@@ -139,7 +148,7 @@ val no_occurrences_in_set : occurrences
 
 (* [subst_term_occ_gen occl n c d] replaces occurrences of [c] at
    positions [occl], counting from [n], by [Rel 1] in [d] *)
-val subst_term_occ_gen : 
+val subst_term_occ_gen :
   occurrences -> int -> constr -> types -> int * types
 
 (* [subst_term_occ occl c d] replaces occurrences of [c] at
@@ -155,43 +164,34 @@ type hyp_location_flag = (* To distinguish body and type of local defs *)
   | InHypValueOnly
 
 val subst_term_occ_decl :
-  occurrences * hyp_location_flag -> constr -> named_declaration -> 
+  occurrences * hyp_location_flag -> constr -> named_declaration ->
       named_declaration
 
 val error_invalid_occurrence : int list -> 'a
 
 (* Alternative term equalities *)
 val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool
+val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) ->
+  Reduction.conv_pb -> constr -> constr -> bool
 val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool
 val eq_constr : constr -> constr -> bool
 
 val eta_reduce_head : constr -> constr
 val eta_eq_constr : constr -> constr -> bool
 
-(* finding "intuitive" names to hypotheses *)
-val lowercase_first_char : identifier -> string
-val sort_hdchar : sorts -> string
-val hdchar : env -> types -> string
-val id_of_name_using_hdchar :
-  env -> types -> name -> identifier
-val named_hd : env -> types -> name -> name
-
-val mkProd_name : env -> name * types * types -> types
-val mkLambda_name : env -> name * types * constr -> constr
-
-(* Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
-val prod_name : env -> name * types * types -> types
-val lambda_name : env -> name * types * constr -> constr
+exception CannotFilter
 
-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
+(* Lightweight first-order filtering procedure. Unification
+   variables ar represented by (untyped) Evars.
+   [filtering c1 c2] returns the substitution n'th evar ->
+   (context,term), or raises [CannotFilter].
+   Warning: Outer-kernel sort subtyping are taken into account: c1 has
+   to be smaller than c2 wrt. sorts. *)
+type subst = (rel_context*constr) Intmap.t
+val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst
 
-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 decompose_prod_letin : constr -> int * rel_context * constr
+val align_prod_letin : constr -> constr -> rel_context * constr
 
 (* Get the last arg of a constr intended to be an application *)
 val last_arg : constr -> constr
@@ -213,43 +213,23 @@ val context_chop : int -> rel_context -> (rel_context*rel_context)
 val vars_of_env: env -> Idset.t
 val add_vname : Idset.t -> name -> Idset.t
 
-(* sets of free identifiers *)
-type used_idents = identifier list
-val occur_rel : int -> name list -> identifier -> bool
-val occur_id : name list -> identifier -> constr -> bool
-
-type avoid_flags = bool option
- (* Some true = avoid all globals (as in intro); 
-    Some false = avoid only global constructors; None = don't avoid globals *)
-
-val next_name_away_in_cases_pattern : 
-  name -> identifier list -> identifier
-val next_global_ident_away : 
-  (*allow section vars:*) bool -> identifier -> identifier list -> identifier
-val next_name_not_occuring :
-  avoid_flags -> name -> identifier list -> name list -> constr -> identifier
-val concrete_name :
-  avoid_flags -> identifier list -> name list -> name -> constr -> 
-    name * identifier list
-val concrete_let_name :
-  avoid_flags -> identifier list -> name list -> name -> constr -> 
-    name * identifier list
-val rename_bound_var : env -> identifier list -> types -> types
-
 (* other signature iterators *)
 val process_rel_context : (rel_declaration -> env -> env) -> env -> env
 val assums_of_rel_context : rel_context -> (name * constr) list
 val lift_rel_context : int -> rel_context -> rel_context
 val substl_rel_context : constr list -> rel_context -> rel_context
-val fold_map_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 map_rel_context_in_env :
   (env -> constr -> constr) -> env -> rel_context -> rel_context
-val map_rel_context_with_binders : 
+val map_rel_context_with_binders :
   (int -> constr -> constr) -> rel_context -> rel_context
 val fold_named_context_both_sides :
   ('a -> named_declaration -> named_declaration list -> 'a) ->
     named_context -> init:'a -> 'a
 val mem_named_context : identifier -> named_context -> bool
-val make_all_name_different : env -> env
+
+val clear_named_body : identifier -> env -> env
 
 val global_vars : env -> constr -> identifier list
 val global_vars_set_of_decl : env -> named_declaration -> Idset.t
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 216a0611..b85c6721 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses.ml 12189 2009-06-15 05:08:44Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -21,8 +21,20 @@ open Nametab
 open Mod_subst
 open Util
 open Typeclasses_errors
+open Libobject
 (*i*)
 
+
+let add_instance_hint_ref = ref (fun id pri -> assert false)
+let register_add_instance_hint =
+  (:=) add_instance_hint_ref
+let add_instance_hint id = !add_instance_hint_ref id
+
+let set_typeclass_transparency_ref = ref (fun id pri -> assert false)
+let register_set_typeclass_transparency =
+  (:=) set_typeclass_transparency_ref
+let set_typeclass_transparency gr c = !set_typeclass_transparency_ref gr c
+
 let mismatched_params env n m = mismatched_ctx_inst env Parameters n m
 (* let mismatched_defs env n m = mismatched_ctx_inst env Definitions n m *)
 let mismatched_props env n m = mismatched_ctx_inst env Properties n m
@@ -32,284 +44,265 @@ type rels = constr list
 (* This module defines type-classes *)
 type typeclass = {
   (* The class implementation *)
-  cl_impl : global_reference; 
+  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 * rel_context;
 
   (* Context of definitions and properties on defs, will not be shared *)
   cl_props : rel_context;
-  
+
   (* The method implementaions as projections. *)
   cl_projs : (identifier * constant option) list;
 }
+module Gmap = Fmap.Make(RefOrdered)
 
-type typeclasses = (global_reference, typeclass) Gmap.t
+type typeclasses = typeclass Gmap.t
 
 type instance = {
   is_class: global_reference;
   is_pri: int option;
-  (* Sections where the instance should be redeclared, 
-     -1 for discard, 0 for none, mutable to avoid redeclarations 
+  (* Sections where the instance should be redeclared,
+     -1 for discard, 0 for none, mutable to avoid redeclarations
      when multiple rebuild_object happen. *)
-  is_global: int ref;
-  is_impl: constant; 
+  is_global: int;
+  is_impl: global_reference; 
 }
 
-type instances = (global_reference, instance Cmap.t) Gmap.t
+type instances = (instance Gmap.t) Gmap.t
 
 let instance_impl is = is.is_impl
 
-let new_instance cl pri glob impl = 
+let new_instance cl pri glob impl =
   let global =
-    if Lib.sections_are_opened () then 
-      if glob then Lib.sections_depth ()
-      else -1
-    else 0
+    if glob then Lib.sections_depth ()
+    else -1
   in
     { is_class = cl.cl_impl;
       is_pri = pri ;
-      is_global = ref global ;
+      is_global = global ;
       is_impl = impl }
-	
+
+(*
+ * states management
+ *)
+
 let classes : typeclasses ref = ref Gmap.empty
 
-let methods : (constant, global_reference) Gmap.t ref = ref Gmap.empty
-  
 let instances : instances ref = ref Gmap.empty
-  
-let freeze () = !classes, !methods, !instances
 
-let unfreeze (cl,m,is) = 
+let freeze () = !classes, !instances
+
+let unfreeze (cl,is) =
   classes:=cl;
-  methods:=m;
   instances:=is
-    
+
 let init () =
-  classes:= Gmap.empty; 
-  methods:= Gmap.empty;
+  classes:= Gmap.empty;
   instances:= Gmap.empty
-    
-let _ = 
+
+let _ =
   Summary.declare_summary "classes_and_instances"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = true }
-
-let gmap_merge old ne =
-  Gmap.fold (fun k v acc -> Gmap.add k v acc) old ne
+      Summary.init_function = init }
 
-let cmap_union = Cmap.fold Cmap.add
+(*
+ * classes persistent object
+ *)
 
-let gmap_cmap_merge old ne =
-  let ne' = 
-    Gmap.fold (fun cl insts acc -> 
-      let oldinsts = try Gmap.find cl old with Not_found -> Cmap.empty in
-	Gmap.add cl (cmap_union oldinsts insts) acc)
-      ne Gmap.empty
-  in
-    Gmap.fold (fun cl insts acc -> 
-      if Gmap.mem cl acc then acc
-      else Gmap.add cl insts acc)
-      old ne'
+let load_class (_, cl) =
+  classes := Gmap.add cl.cl_impl cl !classes
 
-let add_instance_hint_ref = ref (fun id pri -> assert false)
-let register_add_instance_hint =
-  (:=) add_instance_hint_ref
-let add_instance_hint id = !add_instance_hint_ref id
+let cache_class = load_class
 
-let cache (_, (cl, m, inst)) =
-  classes := cl;
-  methods := m;
-  instances := inst
-    
-let load (_, (cl, m, inst)) =
-  classes := gmap_merge !classes cl;
-  methods := gmap_merge !methods m;
-  instances := gmap_cmap_merge !instances inst
-
-open Libobject
-
-let subst (_,subst,(cl,m,inst)) = 
+let subst_class (subst,cl) =
   let do_subst_con c = fst (Mod_subst.subst_con 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_context (grs,ctx) = 
+  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_context (grs,ctx) =
     list_smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
-    do_subst_ctx ctx
-  in
+    do_subst_ctx ctx in
   let do_subst_projs projs = list_smartmap (fun (x, y) -> (x, Option.smartmap do_subst_con y)) projs in
-  let subst_class k cl classes = 
-    let k = do_subst_gr k in
-    let cl' = { cl_impl = k;
-		cl_context = do_subst_context cl.cl_context;
-		cl_props = do_subst_ctx cl.cl_props;
-		cl_projs = do_subst_projs cl.cl_projs; }
-    in 
-    let cl' = if cl' = cl then cl else cl' in
-      Gmap.add k cl' classes
-  in
-  let classes = Gmap.fold subst_class cl Gmap.empty in
-  let subst_inst k insts instances =
-    let k = do_subst_gr k in
-    let insts' = 
-      Cmap.fold (fun cst is acc -> 
-	let cst = do_subst_con cst in
-	let is' = { is with is_class = k; is_impl = cst } in
-	  Cmap.add cst (if is' = is then is else is') acc) insts Cmap.empty
-    in Gmap.add k insts' instances
-  in
-  let instances = Gmap.fold subst_inst inst Gmap.empty in
-    (classes, m, instances)
-
-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
-      (decl :: ctx', n :: subst)) ctx ([], [])
-    
-let discharge (_,(cl,m,inst)) =
+  { cl_impl = do_subst_gr cl.cl_impl;
+    cl_context = do_subst_context cl.cl_context;
+    cl_props = do_subst_ctx cl.cl_props;
+    cl_projs = do_subst_projs cl.cl_projs; }
+
+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
+	(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 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 (id, b, t) (ctx, k) ->
+	   (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k)
 	rel ([], n)
     in ctx
   in
   let abs_context cl =
     match cl.cl_impl with
-    | VarRef _ | ConstructRef _ -> assert false
-    | ConstRef cst -> Lib.section_segment_of_constant cst
-    | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind
-  in
+      | VarRef _ | ConstructRef _ -> assert false
+      | 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' = List.map (fun _ -> None) subst @ 
+    let grs' = List.map (fun _ -> None) subst @
       list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
-    in grs', discharge_rel_context subst 1 ctx @ ctx'
-  in
-  let subst_class k cl acc = 
-    let cl_impl' = Lib.discharge_global cl.cl_impl in
-    let cl' =
-      if cl_impl' == cl.cl_impl then cl
-      else
-	let ctx = abs_context cl in
-	let ctx', subst = rel_of_variable_context ctx in
-	  { cl_impl = cl_impl';
-	    cl_context = discharge_context ctx' subst cl.cl_context;
-	    cl_props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props;
-	    cl_projs = list_smartmap (fun (x, y) -> x, Option.smartmap Lib.discharge_con y) cl.cl_projs }
-    in Gmap.add cl_impl' cl' acc
-  in
-  let classes = Gmap.fold subst_class cl Gmap.empty in
-  let subst_inst k insts acc =
-    let k' = Lib.discharge_global k in
-    let insts' =
-      Cmap.fold (fun k is acc ->
-	let impl = Lib.discharge_con is.is_impl in
-	let is = { is with is_class = k'; is_impl = impl } in
-	  Cmap.add impl is acc)
-	insts Cmap.empty
-    in Gmap.add k' insts' acc
-  in
-  let instances = Gmap.fold subst_inst inst Gmap.empty in
-    Some (classes, m, instances)
-      
-let rebuild (cl,m,inst) =
-  let inst = 
-    Gmap.map (fun insts -> 
-      Cmap.fold (fun k is insts -> 
-	match !(is.is_global) with
-	  | -1 -> insts
-	  | 0 -> Cmap.add k is insts
-	  | n -> 
-	      add_instance_hint is.is_impl is.is_pri;
-	      is.is_global := pred n;
-	      Cmap.add k is insts) insts Cmap.empty)
-      inst
-  in (cl, m, inst)
-
-let (input,output) = 
+    in grs', discharge_rel_context subst 1 ctx @ ctx' in
+  let cl_impl' = Lib.discharge_global cl.cl_impl in
+  if cl_impl' == cl.cl_impl then cl else
+    let ctx = abs_context cl in
+    let ctx, subst = rel_of_variable_context ctx in
+    let context = discharge_context ctx subst cl.cl_context in
+    let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in
+    { cl_impl = cl_impl';
+      cl_context = context;
+      cl_props = props;
+      cl_projs = list_smartmap (fun (x, y) -> x, Option.smartmap Lib.discharge_con y) cl.cl_projs }
+
+let rebuild_class cl = cl
+
+let (class_input,class_output) =
   declare_object
     { (default_object "type classes state") with
-      cache_function = cache;
-      load_function = (fun _ -> load);
-      open_function = (fun _ -> load);
-      classify_function = (fun (_,x) -> Substitute x);
-      discharge_function = discharge;
-      rebuild_function = rebuild;
-      subst_function = subst;
-      export_function = (fun x -> Some x) }
-
-let update () = 
-  Lib.add_anonymous_leaf (input (!classes, !methods, !instances))
-
-let add_class c = 
-  classes := Gmap.add c.cl_impl c !classes;
-  methods := List.fold_left (fun acc x -> 
-    match snd x with
-    | Some m -> Gmap.add m c.cl_impl acc
-    | None -> acc) !methods c.cl_projs;
-  update ()
+      cache_function = cache_class;
+      load_function = (fun _ -> load_class);
+      open_function = (fun _ -> load_class);
+      classify_function = (fun x -> Substitute x);
+      discharge_function = (fun a -> Some (discharge_class a));
+      rebuild_function = rebuild_class;
+      subst_function = subst_class }
+
+let add_class cl =
+  Lib.add_anonymous_leaf (class_input cl)
+
+
+(*
+ * instances persistent object
+ *)
+
+let load_instance (_,inst) = 
+  let insts = 
+    try Gmap.find inst.is_class !instances 
+    with Not_found -> Gmap.empty in
+  let insts = Gmap.add inst.is_impl inst insts in
+  instances := Gmap.add inst.is_class insts !instances
+
+let cache_instance = load_instance
+
+let subst_instance (subst,inst) = 
+  { inst with 
+      is_class = fst (subst_global subst inst.is_class);
+      is_impl = fst (subst_global subst inst.is_impl) }
+
+let discharge_instance (_,inst) =
+  if inst.is_global <= 0 then None
+  else Some 
+    { inst with 
+      is_global = pred inst.is_global;
+      is_class = Lib.discharge_global inst.is_class;
+      is_impl = Lib.discharge_global inst.is_impl }
     
-let class_info c = 
+let rebuild_instance inst =
+  add_instance_hint inst.is_impl inst.is_pri;
+  inst
+
+let classify_instance inst =
+  if inst.is_global = -1 then Dispose
+  else Substitute inst
+
+let (instance_input,instance_output) =
+  declare_object
+    { (default_object "type classes instances state") with
+      cache_function = cache_instance;
+      load_function = (fun _ -> load_instance);
+      open_function = (fun _ -> load_instance);
+      classify_function = classify_instance;
+      discharge_function = discharge_instance;
+      rebuild_function = rebuild_instance;
+      subst_function = subst_instance }
+
+let add_instance i =
+  Lib.add_anonymous_leaf (instance_input i);
+  add_instance_hint i.is_impl i.is_pri
+
+open Declarations
+
+let add_constant_class cst =
+  let ty = Typeops.type_of_constant (Global.env ()) cst in
+  let ctx, arity = decompose_prod_assum ty in
+  let tc = 
+    { cl_impl = ConstRef cst;
+      cl_context = (List.map (const None) ctx, ctx);
+      cl_props = [(Anonymous, None, arity)];
+      cl_projs = []
+    }
+  in add_class tc;
+    set_typeclass_transparency (EvalConstRef cst) false
+      
+let add_inductive_class ind =
+  let mind, oneind = Global.lookup_inductive ind in
+  let k =
+    let ctx = oneind.mind_arity_ctxt in
+    let ty = Inductive.type_of_inductive_knowing_parameters
+      (push_rel_context ctx (Global.env ()))
+	  oneind (Termops.extended_rel_vect 0 ctx)
+    in
+      { cl_impl = IndRef ind;
+	cl_context = List.map (const None) ctx, ctx;
+	cl_props = [Anonymous, None, ty];
+	cl_projs = [] }
+  in add_class k
+      
+(*
+ * interface functions
+ *)
+
+let class_info c =
   try Gmap.find c !classes
   with _ -> not_a_class (Global.env()) (constr_of_global c)
 
-let instance_constructor cl args = 
-  let pars = fst (list_chop (List.length (fst cl.cl_context)) args) in
+let instance_constructor cl args =
+  let lenpars = List.length (List.filter (fun (na, b, t) -> b = None) (snd cl.cl_context)) in
+  let pars = fst (list_chop lenpars args) in
     match cl.cl_impl with
       | IndRef ind -> applistc (mkConstruct (ind, 1)) args,
 	  applistc (mkInd ind) pars
       | ConstRef cst -> list_last args, applistc (mkConst cst) pars
       | _ -> assert false
-	  
+
 let typeclasses () = Gmap.fold (fun _ l c -> l :: c) !classes []
 
 let cmapl_add x y m =
   try
     let l = Gmap.find x m in
-    Gmap.add x (Cmap.add y.is_impl y l) m
+    Gmap.add x (Gmap.add y.is_impl y l) m
   with Not_found ->
-    Gmap.add x (Cmap.add y.is_impl y Cmap.empty) m
+    Gmap.add x (Gmap.add y.is_impl y Gmap.empty) m
 
-let cmap_elements c = Cmap.fold (fun k v acc -> v :: acc) c []
+let cmap_elements c = Gmap.fold (fun k v acc -> v :: acc) c []
 
-let instances_of c = 
+let instances_of c =
   try cmap_elements (Gmap.find c.cl_impl !instances) with Not_found -> []
 
-let add_instance i =
-  let cl = class_info i.is_class in
-  instances := cmapl_add cl.cl_impl i !instances;
-  add_instance_hint i.is_impl i.is_pri;
-  update ()
-
 let all_instances () = 
   Gmap.fold (fun k v acc -> 
-    Cmap.fold (fun k v acc -> v :: acc) v acc)
+    Gmap.fold (fun k v acc -> v :: acc) v acc)
     !instances []
 
 let instances r = 
-  let cl = class_info r in instances_of cl
-    
-let method_typeclass ref = 
-  match ref with 
-    | ConstRef c -> 
-	class_info (Gmap.find c !methods)
-    | _ -> raise Not_found
+  let cl = class_info r in instances_of cl    
       
 let is_class gr = 
   Gmap.fold (fun k v acc -> acc || v.cl_impl = gr) !classes false
-  
-let is_method c =
-  Gmap.mem c !methods
 
 let is_instance = function
   | ConstRef c ->
@@ -320,18 +313,20 @@ let is_instance = function
       (match Decls.variable_kind v with
       | IsDefinition Instance -> true
       | _ -> false)
+  | ConstructRef (ind,_) -> 
+      is_class (IndRef ind)
   | _ -> false
 
-let is_implicit_arg k = 
+let is_implicit_arg k =
   match k with
-      ImplicitArg (ref, (n, id)) -> true
+      ImplicitArg (ref, (n, id), b) -> true
     | InternalHole -> true
     | _ -> false
 
-let global_class_of_constr env c = 
+let global_class_of_constr env c =
   try class_info (global_of_constr c)
   with Not_found -> not_a_class env c
-      
+
 let dest_class_app env c =
   let cl, args = decompose_app c in
     global_class_of_constr env cl, args
@@ -339,49 +334,49 @@ let dest_class_app env c =
 let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None
 
 (* To embed a boolean for resolvability status.
-   This is essentially a hack to mark which evars correspond to 
-   goals and do not need to be resolved when we have nested [resolve_all_evars] 
+   This is essentially a hack to mark which evars correspond to
+   goals and do not need to be resolved when we have nested [resolve_all_evars]
    calls (e.g. when doing apply in an External hint in typeclass_instances).
    Would be solved by having real evars-as-goals. *)
 
 let ((bool_in : bool -> Dyn.t),
     (bool_out : Dyn.t -> bool)) = Dyn.create "bool"
-  
+
 let bool_false = bool_in false
 
 let is_resolvable evi =
   match evi.evar_extra with
       Some t -> if Dyn.tag t = "bool" then bool_out t else true
     | None -> true
-	
-let mark_unresolvable evi = 
+
+let mark_unresolvable evi =
   { evi with evar_extra = Some bool_false }
-    
+
 let mark_unresolvables sigma =
   Evd.fold (fun ev evi evs ->
     Evd.add evs ev (mark_unresolvable evi))
     sigma Evd.empty
-    
-let rec is_class_type c =
+
+let rec is_class_type evd c =
   match kind_of_term c with
-  | Prod (_, _, t) -> is_class_type t
+  | Prod (_, _, t) -> is_class_type evd t
+  | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c)
   | _ -> class_of_constr c <> None
 
-let is_class_evar evi = 
-  is_class_type evi.Evd.evar_concl
-    
+let is_class_evar evd evi =
+  is_class_type evd evi.Evd.evar_concl
+
 let has_typeclasses evd =
-  Evd.fold (fun ev evi has -> has || 
-    (evi.evar_body = Evar_empty && is_class_evar evi && is_resolvable evi))
+  Evd.fold (fun ev evi has -> has ||
+    (evi.evar_body = Evar_empty && is_class_evar evd evi && is_resolvable evi))
     evd false
 
 let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false)
 let solve_instanciation_problem = ref (fun _ _ _ -> assert false)
 
 let resolve_typeclasses ?(onlyargs=false) ?(split=true) ?(fail=true) env evd =
-  if not (has_typeclasses (Evd.evars_of evd)) then evd
-  else
-    !solve_instanciations_problem env evd onlyargs split fail
+  if not (has_typeclasses evd) then evd
+  else !solve_instanciations_problem env evd onlyargs split fail
 
 let resolve_one_typeclass env evm t =
   !solve_instanciation_problem env evm t
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index d8e15895..997b28c1 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,19 +24,19 @@ open Util
 
 (* This module defines type-classes *)
 type typeclass = {
-  (* The class implementation: a record parameterized by the context with defs in it or a definition if 
+  (* The class implementation: a record parameterized by the context with defs in it or a definition if
      the class is a singleton. This acts as the class' global identifier. *)
-  cl_impl : global_reference; 
+  cl_impl : global_reference;
 
-  (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. 
+  (* 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 * rel_context;
 
   (* Context of definitions and properties on defs, will not be shared *)
   cl_props : rel_context;
 
-  (* The methods implementations of the typeclass as projections. Some may be undefinable due to 
+  (* The methods implementations of the typeclass as projections. Some may be undefinable due to
      sorting restrictions. *)
   cl_projs : (identifier * constant option) list;
 }
@@ -49,7 +49,11 @@ val all_instances : unit -> instance list
 
 val add_class : typeclass -> unit
 
-val new_instance : typeclass -> int option -> bool -> constant -> instance
+val add_constant_class : constant -> unit
+
+val add_inductive_class : inductive -> unit
+
+val new_instance : typeclass -> int option -> bool -> global_reference -> instance
 val add_instance : instance -> unit
 
 val class_info : global_reference -> typeclass (* raises a UserError if not a class *)
@@ -61,11 +65,10 @@ val dest_class_app : env -> constr -> typeclass * constr list
 (* Just return None if not a class *)
 val class_of_constr : constr -> typeclass option
   
-val instance_impl : instance -> constant
+val instance_impl : instance -> global_reference
 
 val is_class : global_reference -> bool
 val is_instance : global_reference -> bool
-val is_method : constant -> bool
 
 val is_implicit_arg : hole_kind -> bool
 
@@ -81,15 +84,17 @@ val bool_out : Dyn.t -> bool
 val is_resolvable : evar_info -> bool
 val mark_unresolvable : evar_info -> evar_info
 val mark_unresolvables : evar_map -> evar_map
-val is_class_evar : evar_info -> bool
+val is_class_evar : evar_map -> evar_info -> bool
 
-val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> 
-  env -> evar_defs -> evar_defs
-val resolve_one_typeclass : env -> evar_map -> types -> constr
+val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool ->
+  env -> evar_map -> evar_map
+val resolve_one_typeclass : env -> evar_map -> types -> open_constr
 
-val register_add_instance_hint : (constant -> int option -> unit) -> unit
-val add_instance_hint : constant -> int option -> unit
+val register_set_typeclass_transparency : (evaluable_global_reference -> bool -> unit) -> unit
+val set_typeclass_transparency : evaluable_global_reference -> bool -> unit
 
-val solve_instanciations_problem : (env -> evar_defs -> bool -> bool -> bool -> evar_defs) ref
-val solve_instanciation_problem : (env -> evar_map -> types -> constr) ref
+val register_add_instance_hint : (global_reference -> int option -> unit) -> unit
+val add_instance_hint : global_reference -> int option -> unit
 
+val solve_instanciations_problem : (env -> evar_map -> bool -> bool -> bool -> evar_map) ref
+val solve_instanciation_problem : (env -> evar_map -> types -> open_constr) ref
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index 8844baab..1de8b7a5 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses_errors.ml 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,11 +24,11 @@ open Libnames
 
 type contexts = Parameters | Properties
 
-type typeclass_error = 
+type typeclass_error =
     | NotAClass of constr
     | UnboundMethod of global_reference * identifier located (* Class name, method *)
     | NoInstance of identifier located * constr list
-    | UnsatisfiableConstraints of evar_defs * (evar_info * hole_kind) option
+    | UnsatisfiableConstraints of evar_map * (existential_key * hole_kind) option
     | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
@@ -41,15 +41,19 @@ let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id))
 
 let no_instance env id args = typeclass_error env (NoInstance (id, args))
 
-let unsatisfiable_constraints env evd ev = 
-  let evd = Evd.undefined_evars evd in
-    match ev with
-    | None ->
-	raise (TypeClassError (env, UnsatisfiableConstraints (evd, None)))
-    | Some ev ->
-	let evi = Evd.find (Evd.evars_of evd) ev in
-	let loc, kind = Evd.evar_source ev evd in
-	  raise (Stdpp.Exc_located (loc, TypeClassError
-	    (env, UnsatisfiableConstraints (evd, Some (evi, kind)))))
-	    
+let unsatisfiable_constraints env evd ev =
+  match ev with
+  | None ->
+      raise (TypeClassError (env, UnsatisfiableConstraints (evd, None)))
+  | Some ev ->
+      let loc, kind = Evd.evar_source ev evd in
+	raise (Stdpp.Exc_located (loc, TypeClassError
+	  (env, UnsatisfiableConstraints (evd, Some (ev, kind)))))
+
 let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m))
+
+let rec unsatisfiable_exception exn =
+  match exn with
+  | TypeClassError (_, UnsatisfiableConstraints _) -> true
+  | Stdpp.Exc_located(_, e) -> unsatisfiable_exception e
+  | _ -> false
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index a79307d0..7fd04e22 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses_errors.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,12 +24,12 @@ open Libnames
 
 type contexts = Parameters | Properties
 
-type typeclass_error = 
-    | NotAClass of constr
-    | UnboundMethod of global_reference * identifier located (* Class name, method *)
-    | NoInstance of identifier located * constr list
-    | UnsatisfiableConstraints of evar_defs * (evar_info * hole_kind) option
-    | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
+type typeclass_error =
+  | NotAClass of constr
+  | UnboundMethod of global_reference * identifier located (* Class name, method *)
+  | NoInstance of identifier located * constr list
+  | UnsatisfiableConstraints of evar_map * (existential_key * hole_kind) option
+  | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
@@ -39,6 +39,8 @@ val unbound_method : env -> global_reference -> identifier located -> 'a
 
 val no_instance : env -> identifier located -> constr list -> 'a
 
-val unsatisfiable_constraints : env -> evar_defs -> evar option -> 'a
+val unsatisfiable_constraints : env -> evar_map -> evar option -> 'a
 
 val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a
+
+val unsatisfiable_exception : exn -> bool
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 43e19ca7..831787a0 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typing.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -35,155 +35,191 @@ let inductive_type_knowing_parameters env ind jl =
   let paramstyp = Array.map (fun j -> j.uj_type) jl in
   Inductive.type_of_inductive_knowing_parameters env mip paramstyp
 
+let e_judge_of_apply env evdref funj argjv =
+  let rec apply_rec n typ = function
+  | [] ->
+      { 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
+      | 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
+      | _ ->
+	  error_cant_apply_not_functional env funj argjv
+  in
+  apply_rec 1 funj.uj_type (Array.to_list argjv)
+
+let check_branch_types env evdref cj (lfj,explft) =
+  if Array.length lfj <> Array.length explft then
+    error_number_branches env cj (Array.length explft);
+  for i = 0 to Array.length explft - 1 do
+    if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then
+      error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i)
+  done
+
+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) = type_case_branches env indspec pj cj.uj_val in
+  check_branch_types env evdref cj (lfj,bty);
+  { uj_val  = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj);
+    uj_type = rslty }
+
+let e_judge_of_cast env evdref cj k tj =
+  let expected_type = tj.utj_val in
+  if not (Evarconv.e_cumul env evdref cj.uj_type expected_type) then
+    error_actual_type env cj expected_type;
+  { uj_val = mkCast (cj.uj_val, k, expected_type);
+    uj_type = expected_type }
+
 (* The typing machine without information, without universes but with
    existential variables. *)
 
 (* cstr must be in n.f. w.r.t. evars and execute returns a judgement
    where both the term and type are in n.f. *)
-let rec execute env evd cstr =
+let rec execute env evdref cstr =
   match kind_of_term cstr with
     | Meta n ->
-        { uj_val = cstr; uj_type = nf_evar (evars_of evd) (meta_type evd n) }
+        { uj_val = cstr; uj_type = meta_type !evdref n }
 
     | Evar ev ->
-        let sigma = Evd.evars_of evd in
-	let ty = Evd.existential_type sigma ev in
-	let jty = execute env evd (nf_evar (evars_of evd) ty) in
+	let ty = Evd.existential_type !evdref ev in
+	let jty = execute env evdref (whd_evar !evdref ty) in
 	let jty = assumption_of_judgment env jty in
 	{ uj_val = cstr; uj_type = jty }
-	
-    | Rel n -> 
-	j_nf_evar (evars_of evd) (judge_of_relative env n)
 
-    | Var id -> 
-        j_nf_evar (evars_of evd) (judge_of_variable env id)
-	  
+    | Rel n ->
+	judge_of_relative env n
+
+    | Var id ->
+        judge_of_variable env id
+
     | Const c ->
-        make_judge cstr (nf_evar (evars_of evd) (type_of_constant env c))
-	  
+        make_judge cstr (type_of_constant env c)
+
     | Ind ind ->
-	make_judge cstr (nf_evar (evars_of evd) (type_of_inductive env ind))
-	  
-    | Construct cstruct -> 
-	make_judge cstr
-          (nf_evar (evars_of evd) (type_of_constructor env cstruct))
+	make_judge cstr (type_of_inductive env ind)
+
+    | Construct cstruct ->
+	make_judge cstr (type_of_constructor env cstruct)
 
     | Case (ci,p,c,lf) ->
-        let cj = execute env evd c in
-        let pj = execute env evd p in
-        let lfj = execute_array env evd lf in
-        let (j,_) = judge_of_case env ci pj cj lfj in
-        j
-  
+        let cj = execute env evdref c in
+        let pj = execute env evdref p in
+        let lfj = execute_array env evdref lf in
+        e_judge_of_case env evdref ci pj cj lfj
+
     | Fix ((vn,i as vni),recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env evd recdef in
+        let (_,tys,_ as recdef') = execute_recdef env evdref recdef in
 	let fix = (vni,recdef') in
         check_fix env fix;
 	make_judge (mkFix fix) tys.(i)
-	  
+
     | CoFix (i,recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env evd recdef in
+        let (_,tys,_ as recdef') = execute_recdef env evdref recdef in
         let cofix = (i,recdef') in
         check_cofix env cofix;
 	make_judge (mkCoFix cofix) tys.(i)
-	  
-    | Sort (Prop c) -> 
+
+    | Sort (Prop c) ->
 	judge_of_prop_contents c
 
     | Sort (Type u) ->
 	judge_of_type u
-	  
+
     | App (f,args) ->
-        let jl = execute_array env evd args in
+        let jl = execute_array env evdref args in
 	let j =
 	  match kind_of_term f with
 	    | Ind ind ->
 		(* Sort-polymorphism of inductive types *)
 		make_judge f
 		  (inductive_type_knowing_parameters env ind
-		    (jv_nf_evar (evars_of evd) jl))
-	    | Const cst -> 
+		    (jv_nf_evar !evdref jl))
+	    | Const cst ->
 		(* Sort-polymorphism of inductive types *)
 		make_judge f
 		  (constant_type_knowing_parameters env cst
-		    (jv_nf_evar (evars_of evd) jl))
-	    | _ -> 
-		execute env evd f
+		    (jv_nf_evar !evdref jl))
+	    | _ ->
+		execute env evdref f
 	in
-	fst (judge_of_apply env j jl)
-	    
-    | Lambda (name,c1,c2) -> 
-        let j = execute env evd c1 in
+	e_judge_of_apply env evdref j jl
+
+    | Lambda (name,c1,c2) ->
+        let j = execute env evdref c1 in
 	let var = type_judgment env j in
 	let env1 = push_rel (name,None,var.utj_val) env in
-        let j' = execute env1 evd c2 in 
+        let j' = execute env1 evdref c2 in
         judge_of_abstraction env1 name var j'
-	  
+
     | Prod (name,c1,c2) ->
-        let j = execute env evd c1 in
+        let j = execute env evdref c1 in
         let varj = type_judgment env j in
 	let env1 = push_rel (name,None,varj.utj_val) env in
-        let j' = execute env1 evd c2 in
+        let j' = execute env1 evdref c2 in
         let varj' = type_judgment env1 j' in
 	judge_of_product env name varj varj'
 
      | LetIn (name,c1,c2,c3) ->
-        let j1 = execute env evd c1 in
-        let j2 = execute env evd c2 in
+        let j1 = execute env evdref c1 in
+        let j2 = execute env evdref c2 in
         let j2 = type_judgment env j2 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 j3 = execute env1 evd c3 in
+        let j3 = execute env1 evdref c3 in
         judge_of_letin env name j1 j2 j3
-  
+
     | Cast (c,k,t) ->
-        let cj = execute env evd c in
-        let tj = execute env evd t in
+        let cj = execute env evdref c in
+        let tj = execute env evdref t in
 	let tj = type_judgment env tj in
-        let j, _ = judge_of_cast env cj k tj in
-	j
+        e_judge_of_cast env evdref cj k tj
 
-and execute_recdef env evd (names,lar,vdef) =
-  let larj = execute_array env evd lar in
+and execute_recdef env evdref (names,lar,vdef) =
+  let larj = execute_array env evdref lar in
   let lara = Array.map (assumption_of_judgment env) larj in
   let env1 = push_rec_types (names,lara,vdef) env in
-  let vdefj = execute_array env1 evd vdef 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
   (names,lara,vdefv)
 
-and execute_array env evd = Array.map (execute env evd)
+and execute_array env evdref = Array.map (execute env evdref)
 
-and execute_list env evd = List.map (execute env evd)
+and execute_list env evdref = List.map (execute env evdref)
 
-let mcheck env evd c t =
-  let sigma = Evd.evars_of evd in
-  let j = execute env evd (nf_evar sigma c) in
-  if not (is_conv_leq env sigma j.uj_type t) then
-    error_actual_type env j (nf_evar sigma t)
+let check env evd c t =
+  let evdref = ref evd in
+  let j = execute env evdref c in
+  if not (Evarconv.e_cumul env evdref j.uj_type t) then
+    error_actual_type env j (nf_evar evd t)
 
 (* Type of a constr *)
- 
-let mtype_of env evd c =
-  let j = execute env evd (nf_evar (evars_of evd) c) in
+
+let type_of env evd c =
+  let j = execute env (ref evd) c in
   (* We are outside the kernel: we take fresh universes *)
   (* to avoid tactics and co to refresh universes themselves *)
   Termops.refresh_universes j.uj_type
 
-let msort_of env evd c =
-  let j = execute env evd (nf_evar (evars_of evd) c) in
+(* Sort of a type *)
+
+let sort_of env evd c =
+  let j = execute env (ref evd) c in
   let a = type_judgment env j in
   a.utj_type
 
-let type_of env sigma c =
-  mtype_of env (Evd.create_evar_defs sigma) c
-let sort_of env sigma c =
-  msort_of env (Evd.create_evar_defs sigma) c
-let check env sigma c   =
-  mcheck env (Evd.create_evar_defs sigma) c
+(* Try to solve the existential variables by typing *)
 
-(* The typed type of a judgment. *)
-
-let mtype_of_type env evd constr =
-  let j = execute env evd (nf_evar (evars_of evd) constr) in
-  assumption_of_judgment env j
+let solve_evars env evd c =
+  let evdref = ref evd in
+  let c = (execute env evdref c).uj_val in
+  (* side-effect on evdref *)
+  nf_evar !evdref c
+  
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index c9d7d572..e3b3e948 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typing.mli 6113 2004-09-17 20:28:19Z barras $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -21,14 +21,11 @@ open Evd
 val type_of : env -> evar_map -> constr -> types
 (* Typecheck a type and return its sort *)
 val sort_of : env -> evar_map -> types -> sorts
-(* Typecheck a term has a given type (assuming the type is OK *)
+(* Typecheck a term has a given type (assuming the type is OK) *)
 val check   : env -> evar_map -> constr -> types -> unit
- 
-(* The same but with metas... *)
-val mtype_of : env -> evar_defs -> constr -> types
-val msort_of : env -> evar_defs -> types -> sorts
-val mcheck   : env -> evar_defs -> constr -> types -> unit
-val meta_type : evar_defs -> metavariable -> types
- 
-(* unused typing function... *)
-val mtype_of_type : env -> evar_defs -> types -> types
+
+(* Returns the instantiated type of a metavariable *)
+val meta_type : evar_map -> metavariable -> types
+
+(* Solve existential variables using typing *)
+val solve_evars : env -> evar_map -> constr -> constr
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index c92f1fc6..a2841ec6 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: unification.ml 12268 2009-08-11 09:02:16Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -14,6 +14,7 @@ open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Sign
 open Environ
 open Evd
@@ -25,32 +26,45 @@ open Evarutil
 open Pretype_errors
 open Retyping
 open Coercion.Default
+open Recordops
+
+let occur_meta_or_undefined_evar evd c =
+  let rec occrec c = match kind_of_term c with
+    | Meta _ -> raise Occur
+    | Evar (ev,args) ->
+        (match evar_body (Evd.find evd ev) with
+        | Evar_defined c ->
+            occrec c; Array.iter occrec args
+        | Evar_empty -> raise Occur)
+    | Sort s when is_sort_variable evd s -> raise Occur
+    | _ -> iter_constr occrec c
+  in try occrec c; false with Occur | Not_found -> true
 
 (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
    gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
 
 let abstract_scheme env c l lname_typ =
-  List.fold_left2 
+  List.fold_left2
     (fun t (locc,a) (na,_,ta) ->
        let na = match kind_of_term a with Var id -> Name id | _ -> na in
 (* [occur_meta ta] test removed for support of eelim/ecase but consequences
    are unclear...
        if occur_meta ta then error "cannot find a type for the generalisation"
-       else *) if occur_meta a then lambda_name env (na,ta,t)
-       else lambda_name env (na,ta,subst_term_occ locc a t))
+       else *) if occur_meta a then mkLambda_name env (na,ta,t)
+       else mkLambda_name env (na,ta,subst_term_occ locc a t))
     c
     (List.rev l)
     lname_typ
 
 let abstract_list_all env evd typ c l =
-  let ctxt,_ = decomp_n_prod env (evars_of evd) (List.length l) typ in
+  let ctxt,_ = splay_prod_n env evd (List.length l) typ in
   let l_with_all_occs = List.map (function a -> (all_occurrences,a)) l in
-  let p = abstract_scheme env c l_with_all_occs ctxt in 
-  try 
-    if is_conv_leq env (evars_of evd) (Typing.mtype_of env evd p) typ then p
+  let p = abstract_scheme env c l_with_all_occs ctxt in
+  try
+    if is_conv_leq env evd (Typing.type_of env evd p) typ then p
     else error "abstract_list_all"
   with UserError _ | Type_errors.TypeError _ ->
-    error_cannot_find_well_typed_abstraction env (evars_of evd) p l
+    error_cannot_find_well_typed_abstraction env evd p l
 
 (**)
 
@@ -86,32 +100,50 @@ let rec subst_meta_instances bl c =
     | Meta i -> (try assoc_pair i bl with Not_found -> c)
     | _ -> map_constr (subst_meta_instances bl) c
 
-let solve_pattern_eqn_array (env,nb) sigma f l c (metasubst,evarsubst) =
+let pose_all_metas_as_evars env evd t =
+  let evdref = ref evd in
+  let rec aux t = match kind_of_term t with
+  | Meta mv ->
+      (match Evd.meta_opt_fvalue !evdref mv with
+       | Some ({rebus=c},_) -> c
+       | None ->
+        let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in
+        let ty = if mvs = Evd.Metaset.empty then ty else aux ty in
+        let ev = Evarutil.e_new_evar evdref env ~src:(dummy_loc,GoalEvar) ty in
+        evdref := meta_assign mv (ev,(ConvUpToEta 0,TypeNotProcessed)) !evdref;
+        ev)
+  | _ ->
+      map_constr aux t in
+  let c = aux t in
+  (* side-effect *)
+  (!evdref, c)
+
+let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) =
   match kind_of_term f with
-    | Meta k -> 
+    | Meta k ->
 	let c = solve_pattern_eqn env (Array.to_list l) c in
 	let n = Array.length l - List.length (fst (decompose_lam c)) in
 	let pb = (ConvUpToEta n,TypeNotProcessed) in
 	  if noccur_between 1 nb c then
-            (k,lift (-nb) c,pb)::metasubst,evarsubst
+            sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst
 	  else error_cannot_unify_local env sigma (mkApp (f, l),c,c)
     | Evar ev ->
-      (* Currently unused: incompatible with eauto/eassumption backtracking *)
-	metasubst,(ev,solve_pattern_eqn env (Array.to_list l) c)::evarsubst
+	let sigma,c = pose_all_metas_as_evars env sigma c in
+	sigma,metasubst,(ev,solve_pattern_eqn env (Array.to_list l) c)::evarsubst
     | _ -> assert false
 
 let push d (env,n) = (push_rel_assum d env,n+1)
 
 (*******************************)
 
-(* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n]
+(* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n]
    renvoie deux listes:
 
-   metasubst:(int*constr)list    récolte les instances des (Meta k)
-   evarsubst:(constr*constr)list récolte les instances des (Const "?k")
+   metasubst:(int*constr)list    récolte les instances des (Meta k)
+   evarsubst:(constr*constr)list récolte les instances des (Const "?k")
 
-   Attention : pas d'unification entre les différences instances d'une
-   même meta ou evar, il peut rester des doublons *)
+   Attention : pas d'unification entre les différences instances d'une
+   même meta ou evar, il peut rester des doublons *)
 
 (* Unification order: *)
 (* Left to right: unifies first argument and then the other arguments *)
@@ -122,93 +154,104 @@ let unify_r2l x = x
 let sort_eqns = unify_r2l
 *)
 
-type unify_flags = { 
+(* Option introduced and activated in Coq 8.3 *)
+let global_evars_pattern_unification_flag = ref true
+
+open Goptions
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "pattern-unification for existential variables in tactics";
+      optkey   = ["Tactic";"Evars";"Pattern";"Unification"];
+      optread  = (fun () -> !global_evars_pattern_unification_flag);
+      optwrite = (:=) global_evars_pattern_unification_flag }
+
+type unify_flags = {
   modulo_conv_on_closed_terms : Names.transparent_state option;
   use_metas_eagerly : bool;
   modulo_delta : Names.transparent_state;
+  resolve_evars : bool;
+  use_evars_pattern_unification : bool
 }
 
 let default_unify_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly = true;
   modulo_delta = full_transparent_state;
+  resolve_evars = false;
+  use_evars_pattern_unification = true;
 }
 
 let default_no_delta_unify_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly = true;
   modulo_delta = empty_transparent_state;
+  resolve_evars = false;
+  use_evars_pattern_unification = false;
 }
 
+let use_evars_pattern_unification flags =
+  !global_evars_pattern_unification_flag && flags.use_evars_pattern_unification
+  && Flags.version_strictly_greater Flags.V8_2
+
 let expand_key env = function
   | Some (ConstKey cst) -> constant_opt_value env cst
-  | Some (VarKey id) -> named_body id env
+  | Some (VarKey id) -> (try named_body id env with Not_found -> None)
   | Some (RelKey _) -> None
   | None -> None
-      
+
 let key_of flags f =
   match kind_of_term f with
   | Const cst when is_transparent (ConstKey cst) &&
         Cpred.mem cst (snd flags.modulo_delta) ->
-      Some (ConstKey cst) 
+      Some (ConstKey cst)
   | Var id when is_transparent (VarKey id) &&
         Idpred.mem id (fst flags.modulo_delta) ->
       Some (VarKey id)
   | _ -> None
-      
+
 let oracle_order env cf1 cf2 =
   match cf1 with
   | None ->
-      (match cf2 with 
+      (match cf2 with
       | None -> None
       | Some k2 -> Some false)
-  | Some k1 -> 
+  | Some k1 ->
       match cf2 with
       | None -> Some true
       | Some k2 -> Some (Conv_oracle.oracle_order k1 k2)
-	    
-let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n =
-  let trivial_unify curenv pb (metasubst,_) m n =
-    let subst = if flags.use_metas_eagerly then metasubst else fst subst in
-    match subst_defined_metas subst m with
-    | Some m1 ->
-	if (match flags.modulo_conv_on_closed_terms with
-	    Some flags ->
-	      is_trans_fconv (conv_pb_of pb) flags env sigma m1 n
-	  | None -> false) then true else
-        if (not (is_ground_term (create_evar_defs sigma) m1))
-            || occur_meta_or_existential n then false else
-               error_cannot_unify curenv sigma (m, n)
-    | _ -> false in
-  let rec unirec_rec (curenv,nb as curenvnb) pb b ((metasubst,evarsubst) as substn) curm curn =
-    let cM = Evarutil.whd_castappevar sigma curm
-    and cN = Evarutil.whd_castappevar sigma curn in 
+
+let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n =
+  let rec unirec_rec (curenv,nb as curenvnb) pb b ((sigma,metasubst,evarsubst) as substn) curm curn =
+    let cM = Evarutil.whd_head_evar sigma curm
+    and cN = Evarutil.whd_head_evar sigma curn in
       match (kind_of_term cM,kind_of_term cN) with
 	| Meta k1, Meta k2 ->
 	    let stM,stN = extract_instance_status pb in
-	    if k1 < k2 
-	    then (k1,cN,stN)::metasubst,evarsubst
+	    if k2 < k1
+	    then sigma,(k1,cN,stN)::metasubst,evarsubst
 	    else if k1 = k2 then substn
-	    else (k2,cM,stM)::metasubst,evarsubst
-	| Meta k, _ when not (dependent cM cN) -> 
+	    else sigma,(k2,cM,stM)::metasubst,evarsubst
+	| Meta k, _ when not (dependent cM cN) ->
 	    (* Here we check that [cN] does not contain any local variables *)
 	    if nb = 0 then
-              (k,cN,snd (extract_instance_status pb))::metasubst,evarsubst
+              sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst
             else if noccur_between 1 nb cN then
-              (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst,
-              evarsubst
+              (sigma,
+	      (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst,
+              evarsubst)
 	    else error_cannot_unify_local curenv sigma (m,n,cN)
-	| _, Meta k when not (dependent cN cM) -> 
+	| _, Meta k when not (dependent cN cM) ->
 	    (* Here we check that [cM] does not contain any local variables *)
 	    if nb = 0 then
-              (k,cM,snd (extract_instance_status pb))::metasubst,evarsubst
+              (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst)
 	    else if noccur_between 1 nb cM
 	    then
-              (k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst,
-              evarsubst
+              (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst,
+              evarsubst)
 	    else error_cannot_unify_local curenv sigma (m,n,cM)
-	| Evar ev, _ -> metasubst,((ev,cN)::evarsubst)
-	| _, Evar ev -> metasubst,((ev,cM)::evarsubst)
+	| Evar ev, _ -> sigma,metasubst,((ev,cN)::evarsubst)
+	| _, Evar ev -> sigma,metasubst,((ev,cM)::evarsubst)
 	| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
 	    unirec_rec (push (na,t1) curenvnb) topconv true
 	      (unirec_rec curenvnb topconv true substn t1 t2) c1 c2
@@ -217,55 +260,93 @@ let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n =
 	      (unirec_rec curenvnb topconv true substn t1 t2) c1 c2
 	| LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb b substn (subst1 a c) cN
 	| _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb b substn cM (subst1 a c)
-	    
+
 	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
             array_fold_left2 (unirec_rec curenvnb topconv true)
 	      (unirec_rec curenvnb topconv true
 		  (unirec_rec curenvnb topconv true substn p1 p2) c1 c2) cl1 cl2
 
 	| App (f1,l1), _ when
-	    isMeta f1 & is_unification_pattern curenvnb f1 l1 cN &
+	    (isMeta f1 || use_evars_pattern_unification flags && isEvar f1) &
+	    is_unification_pattern curenvnb f1 l1 cN &
 	    not (dependent f1 cN) ->
-	      solve_pattern_eqn_array curenvnb sigma f1 l1 cN substn
+	      solve_pattern_eqn_array curenvnb f1 l1 cN substn
 
 	| _, App (f2,l2) when
-	    isMeta f2 & is_unification_pattern curenvnb f2 l2 cM &
+	    (isMeta f2 || use_evars_pattern_unification flags && isEvar f2) &
+	    is_unification_pattern curenvnb f2 l2 cM &
 	    not (dependent f2 cM) ->
-	      solve_pattern_eqn_array curenvnb sigma f2 l2 cM substn
+	      solve_pattern_eqn_array curenvnb f2 l2 cM substn
 
 	| App (f1,l1), App (f2,l2) ->
-	      let len1 = Array.length l1
-	      and len2 = Array.length l2 in
+	    let len1 = Array.length l1
+	    and len2 = Array.length l2 in
 	      (try
 		  let (f1,l1,f2,l2) =
 		    if len1 = len2 then (f1,l1,f2,l2)
 		    else if len1 < len2 then
-		      let extras,restl2 = array_chop (len2-len1) l2 in 
+		      let extras,restl2 = array_chop (len2-len1) l2 in
 		      (f1, l1, appvect (f2,extras), restl2)
-		    else 
-		      let extras,restl1 = array_chop (len1-len2) l1 in 
+		    else
+		      let extras,restl1 = array_chop (len1-len2) l1 in
 		      (appvect (f1,extras), restl1, f2, l2) in
 		  let pb = ConvUnderApp (len1,len2) in
 		  array_fold_left2 (unirec_rec curenvnb topconv true)
 		    (unirec_rec curenvnb pb true substn f1 f2) l1 l2
 		with ex when precatchable_exception ex ->
-		  expand curenvnb pb b substn cM f1 l1 cN f2 l2)
-		
+		  try expand curenvnb pb b substn cM f1 l1 cN f2 l2
+		  with ex when precatchable_exception ex ->
+		    canonical_projections curenvnb pb b cM cN substn)
+
 	| _ ->
-            if constr_cmp (conv_pb_of cv_pb) cM cN then substn else
-	    let (f1,l1) = 
-	      match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
-	    let (f2,l2) =
-	      match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
-	    expand curenvnb pb b substn cM f1 l1 cN f2 l2
-
-  and expand (curenv,_ as curenvnb) pb b substn cM f1 l1 cN f2 l2 =
-    if trivial_unify curenv pb substn cM cN then substn
-    else if b then
+	    try canonical_projections curenvnb pb b cM cN substn
+	    with ex when precatchable_exception ex ->
+              if constr_cmp (conv_pb_of cv_pb) cM cN then substn else
+		let (f1,l1) =
+		  match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
+		let (f2,l2) =
+		  match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
+		  expand curenvnb pb b substn cM f1 l1 cN f2 l2
+
+  and expand (curenv,_ as curenvnb) pb b (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 =
+
+    if
+      (* Try full conversion on meta-free terms. *)
+      (* Back to 1995 (later on called trivial_unify in 2002), the
+	 heuristic was to apply conversion on meta-free (but not
+	 evar-free!) terms in all cases (i.e. for apply but also for
+	 auto and rewrite, even though auto and rewrite did not use
+	 modulo conversion in the rest of the unification
+	 algorithm). By compatibility we need to support this
+	 separately from the main unification algorithm *)
+      (* The exploitation of known metas has been added in May 2007
+	 (it is used by apply and rewrite); it might now be redundant
+	 with the support for delta-expansion (which is used
+	 essentially for apply)... *)
+      match flags.modulo_conv_on_closed_terms with
+      | None -> false
+      | Some convflags ->
+      let subst = if flags.use_metas_eagerly then metasubst else ms in
+      match subst_defined_metas subst cM with
+      | None -> (* some undefined Metas in cM *) false
+      | Some m1 ->
+      match subst_defined_metas subst cN with
+      | None -> (* some undefined Metas in cN *) false
+      | Some n1 ->
+	  if is_trans_fconv (conv_pb_of pb) convflags env sigma m1 n1
+	  then true else
+	    if is_ground_term sigma m1 && is_ground_term sigma n1 then
+	      error_cannot_unify curenv sigma (cM,cN)
+	    else false
+    then
+      substn
+    else
+      if b then
+      (* Try delta-expansion if in subterms or if asked to conv at top *)
       let cf1 = key_of flags f1 and cf2 = key_of flags f2 in
 	match oracle_order curenv cf1 cf2 with
 	| None -> error_cannot_unify curenv sigma (cM,cN)
-	| Some true -> 
+	| Some true ->
 	    (match expand_key curenv cf1 with
 	    | Some c ->
 		unirec_rec curenvnb pb b substn
@@ -292,26 +373,70 @@ let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n =
     else
       error_cannot_unify curenv sigma (cM,cN)
 
+  and canonical_projections curenvnb pb b cM cN (sigma,_,_ as substn) =
+    let f1 () =
+      if isApp cM then
+	let f1l1 = decompose_app cM in
+	  if is_open_canonical_projection sigma f1l1 then
+	    let f2l2 = decompose_app cN in
+	      solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 substn
+	  else error_cannot_unify (fst curenvnb) sigma (cM,cN)
+      else error_cannot_unify (fst curenvnb) sigma (cM,cN)
+    in
+      if flags.modulo_conv_on_closed_terms = None then
+	error_cannot_unify (fst curenvnb) sigma (cM,cN)
+      else
+	try f1 () with e when precatchable_exception e ->
+	  if isApp cN then
+	    let f2l2 = decompose_app cN in
+	      if is_open_canonical_projection sigma f2l2 then
+		let f1l1 = decompose_app cM in
+		  solve_canonical_projection curenvnb pb b cN f2l2 cM f1l1 substn
+	      else error_cannot_unify (fst curenvnb) sigma (cM,cN)
+	  else error_cannot_unify (fst curenvnb) sigma (cM,cN)
+
+  and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) =
+    let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
+      try Evarconv.check_conv_record f1l1 f2l2
+      with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN)
+    in
+    let (evd,ks,_) =
+      List.fold_left
+	(fun (evd,ks,m) b ->
+	  if m=n then (evd,t2::ks, m-1) else
+            let mv = new_meta () in
+	    let evd' = meta_declare mv (substl ks b) evd in
+	      (evd', mkMeta mv :: ks, m - 1))
+	(sigma,[],List.length bs - 1) bs
+    in
+    let unilist2 f substn l l' =
+      try List.fold_left2 f substn l l'
+      with Invalid_argument "List.fold_left2" -> error_cannot_unify (fst curenvnb) sigma (cM,cN)
+    in
+    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u))
+      (evd,ms,es) us2 us in
+    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u))
+      substn params1 params in
+    let substn = unilist2 (unirec_rec curenvnb pb b) substn ts ts1 in
+      unirec_rec curenvnb pb b substn c1 (applist (c,(List.rev ks)))
+
   in
-    if (if occur_meta m then false else
-       if (match flags.modulo_conv_on_closed_terms with
-	  Some flags ->
-	    is_trans_fconv (conv_pb_of cv_pb) flags env sigma m n
-	| None -> constr_cmp (conv_pb_of cv_pb) m n) then true else
-      if (not (is_ground_term (create_evar_defs sigma) m))
-          || occur_meta_or_existential n then false else
-      if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with
+  let evd = create_evar_defs sigma in
+    if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n then false 
+      else if (match flags.modulo_conv_on_closed_terms with
+      | Some flags ->
+	  is_trans_fconv (conv_pb_of cv_pb) flags env sigma m n
+      | None -> constr_cmp (conv_pb_of cv_pb) m n) then true 
+      else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with
             | Some (cv_id, cv_k), (dl_id, dl_k) ->
                 Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k
             | None,(dl_id, dl_k) ->
                 Idpred.is_empty dl_id && Cpred.is_empty dl_k)
-      then error_cannot_unify env sigma (m, n) else false) 
-    then
-      subst
-    else 
-      unirec_rec (env,0) cv_pb conv_at_top subst m n
+      then error_cannot_unify env sigma (m, n) else false)
+    then subst
+    else unirec_rec (env,0) cv_pb conv_at_top subst m n
 
-let unify_0 = unify_0_with_initial_metas ([],[]) true
+let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
 
 let left = true
 let right = false
@@ -324,19 +449,19 @@ let rec unify_with_eta keptside flags env sigma k1 k2 c1 c2 =
   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
-      let metas,evars = unify_0 env sigma topconv flags t1 t2 in
-      let side,status,(metas',evars') =
+      let sigma,metas,evars = unify_0 env sigma topconv flags t1 t2 in
+      let side,status,(sigma,metas',evars') =
 	unify_with_eta keptside flags env' sigma (pop k1) (pop k2) c1' c2'
-      in (side,status,(metas@metas',evars@evars'))
+      in (side,status,(sigma,metas@metas',evars@evars'))
   | (Lambda (na,t,c1'),_) when k2 > 0 ->
       let env' = push_rel_assum (na,t) env in
       let side = left in (* expansion on the right: we keep the left side *)
-      unify_with_eta side flags env' sigma (pop k1) (k2-1) 
+      unify_with_eta side flags env' sigma (pop k1) (k2-1)
 	c1' (mkApp (lift 1 c2,[|mkRel 1|]))
   | (_,Lambda (na,t,c2')) when k1 > 0 ->
       let env' = push_rel_assum (na,t) env in
       let side = right in (* expansion on the left: we keep the right side *)
-      unify_with_eta side flags env' sigma (k1-1) (pop k2) 
+      unify_with_eta side flags env' sigma (k1-1) (pop k2)
 	(mkApp (lift 1 c1,[|mkRel 1|])) c2'
   | _ ->
       (keptside,ConvUpToEta(min k1 k2),
@@ -426,49 +551,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 applyHead env evd n c  =
   let rec apprec n c cty evd =
-    if n = 0 then 
+    if n = 0 then
       (evd, c)
-    else 
-      match kind_of_term (whd_betadeltaiota env (evars_of evd) cty) with
+    else
+      match kind_of_term (whd_betadeltaiota env evd cty) with
         | Prod (_,c1,c2) ->
-            let (evd',evar) = 
+            let (evd',evar) =
 	      Evarutil.new_evar evd env ~src:(dummy_loc,GoalEvar) c1 in
 	    apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
 	| _ -> error "Apply_Head_Then"
-  in 
-  apprec n c (Typing.type_of env (evars_of evd) c) evd
+  in
+  apprec n c (Typing.type_of env evd c) evd
 
 let is_mimick_head f =
   match kind_of_term f with
       (Const _|Var _|Rel _|Construct _|Ind _) -> true
     | _ -> false
 
-let pose_all_metas_as_evars env evd t =
-  let evdref = ref evd in
-  let rec aux t = match kind_of_term t with
-  | Meta mv ->
-      (match Evd.meta_opt_fvalue !evdref mv with
-       | Some ({rebus=c},_) -> c
-       | None ->
-        let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in
-        let ty = if mvs = Evd.Metaset.empty then ty else aux ty in
-        let ev = Evarutil.e_new_evar evdref env ~src:(dummy_loc,GoalEvar) ty in
-        evdref := meta_assign mv (ev,(ConvUpToEta 0,TypeNotProcessed)) !evdref;
-        ev)
-  | _ ->
-      map_constr aux t in
-  let c = aux t in
-  (* side-effect *)
-  (!evdref, c)
-
 let try_to_coerce env evd c cty tycon =
   let j = make_judge c cty in
   let (evd',j') = inh_conv_coerce_rigid_to dummy_loc env evd j tycon in
   let (evd',b) = Evarconv.consider_remaining_unif_problems env evd' in
   if b then
-    let evd' = Evd.map_metas_fvalue (nf_evar (evars_of evd')) evd' in
+    let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
     (evd',j'.uj_val)
   else
     error "Cannot solve unification constraints"
@@ -478,31 +585,39 @@ let w_coerce_to_type env evd c cty mvty =
   let tycon = mk_tycon_type mvty in
   try try_to_coerce env evd c cty tycon
   with e when precatchable_exception e ->
-    (* inh_conv_coerce_rigid_to should have reasoned modulo reduction 
+    (* inh_conv_coerce_rigid_to should have reasoned modulo reduction
        but there are cases where it though it was not rigid (like in
        fst (nat,nat)) and stops while it could have seen that it is rigid *)
-    let cty = Tacred.hnf_constr env (evars_of evd) cty in
+    let cty = Tacred.hnf_constr env evd cty in
     try_to_coerce env evd c cty tycon
 
 let w_coerce env evd mv c =
-  let cty = get_type_of_with_meta env (evars_of evd) (metas_of evd) c in
+  let cty = get_type_of env evd c in
   let mvty = Typing.meta_type evd mv in
   w_coerce_to_type env evd c cty mvty
 
-let unify_to_type env evd flags c u =
-  let sigma = evars_of evd in
+let unify_to_type env sigma flags c status u =
   let c = refresh_universes c in
-  let t = get_type_of_with_meta env sigma (List.map (on_snd (nf_meta evd)) (metas_of evd)) (nf_meta evd c) in
-  let t = Tacred.hnf_constr env sigma (nf_betaiota sigma (nf_meta evd t)) in
+  let t = get_type_of env sigma c in
+  let t = Tacred.hnf_constr env sigma (nf_betaiota sigma (nf_meta sigma t)) in
   let u = Tacred.hnf_constr env sigma u in
-  try unify_0 env sigma Cumul flags t u
-  with e when precatchable_exception e -> ([],[])
-
-let unify_type env evd flags mv c =
-  let mvty = Typing.meta_type evd mv in
-  if occur_meta_or_existential mvty or is_arity env (evars_of evd) mvty then
-    unify_to_type env evd flags c mvty
-  else ([],[])
+    try
+      if status = IsSuperType then
+	unify_0 env sigma Cumul flags u t
+      else if status = IsSubType then
+	unify_0 env sigma Cumul flags t u
+      else
+	try unify_0 env sigma Cumul flags t u
+	with e when precatchable_exception e ->
+	  unify_0 env sigma Cumul flags u t
+    with e when precatchable_exception e ->
+      (sigma,[],[])
+
+let unify_type env sigma flags mv status c =
+  let mvty = Typing.meta_type sigma mv in
+  if occur_meta_or_existential mvty or is_arity env sigma mvty then
+    unify_to_type env sigma flags c status mvty
+  else (sigma,[],[])
 
 (* Move metas that may need coercion at the end of the list of instances *)
 
@@ -518,7 +633,7 @@ let order_metas metas =
 
 let solve_simple_evar_eqn env evd ev rhs =
   let evd,b = solve_simple_eqn Evarconv.evar_conv_x env evd (None,ev,rhs) in
-  if not b then error_cannot_unify env (evars_of evd) (mkEvar ev,rhs);
+  if not b then error_cannot_unify env evd (mkEvar ev,rhs);
   let (evd,b) = Evarconv.consider_remaining_unif_problems env evd in
   if not b then error "Cannot solve unification constraints";
   evd
@@ -527,30 +642,30 @@ let solve_simple_evar_eqn env evd ev rhs =
    or in evars, possibly generating new unification problems; if [b]
    is true, unification of types of metas is required *)
 
-let w_merge env with_types flags (metas,evars) evd =
+let w_merge env with_types flags (evd,metas,evars) =
   let rec w_merge_rec evd metas evars eqns =
 
     (* Process evars *)
     match evars with
     | ((evn,_ as ev),rhs)::evars' ->
     	if is_defined_evar evd ev then
-	  let v = Evd.existential_value (evars_of evd) ev in
-	  let (metas',evars'') =
-	    unify_0 env (evars_of evd) topconv flags rhs v in
+	  let v = Evd.existential_value evd ev in
+	  let (evd,metas',evars'') =
+	    unify_0 env evd topconv flags rhs v in
 	  w_merge_rec evd (metas'@metas) (evars''@evars') eqns
     	else begin
           let rhs' = subst_meta_instances metas rhs in
           match kind_of_term rhs with
 	  | App (f,cl) when is_mimick_head f & occur_meta rhs' ->
 	      if occur_evar evn rhs' then
-                error_occur_check env (evars_of evd) evn rhs';
+                error_occur_check env evd evn rhs';
 	      let evd' = mimick_evar evd flags f (Array.length cl) evn in
 	      w_merge_rec evd' metas evars eqns
           | _ ->
 	      w_merge_rec (solve_simple_evar_eqn env evd ev rhs')
 		metas evars' eqns
 	end
-    | [] -> 
+    | [] ->
 
     (* Process metas *)
     match metas with
@@ -559,52 +674,52 @@ let w_merge env with_types flags (metas,evars) evd =
 	  if with_types & to_type <> TypeProcessed then
 	    if to_type = CoerceToType then
               (* Some coercion may have to be inserted *)
-	      (w_coerce env evd mv c,([],[])),[]
+	      (w_coerce env evd mv c,([],[])),eqns
 	    else
               (* No coercion needed: delay the unification of types *)
-	      ((evd,c),([],[])),(mv,c)::eqns
-	  else 
+	      ((evd,c),([],[])),(mv,status,c)::eqns
+	  else
 	    ((evd,c),([],[])),eqns in
-    	if meta_defined evd mv then
-	  let {rebus=c'},(status',_) = meta_fvalue evd mv in
-          let (take_left,st,(metas',evars')) =
-	    merge_instances env (evars_of evd) flags status' status c' c
-	  in
-	  let evd' = 
-            if take_left then evd 
-            else meta_reassign mv (c,(st,TypeProcessed)) evd 
-	  in
-          w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns
-    	else
-	  let evd' = meta_assign mv (c,(status,TypeProcessed)) evd in
-	  w_merge_rec evd' (metas@metas'') evars'' eqns
-    | [] -> 
+	  if meta_defined evd mv then
+	    let {rebus=c'},(status',_) = meta_fvalue evd mv in
+            let (take_left,st,(evd,metas',evars')) =
+	      merge_instances env evd flags status' status c' c
+	    in
+	    let evd' =
+              if take_left then evd
+              else meta_reassign mv (c,(st,TypeProcessed)) evd
+	    in
+              w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns
+    	  else
+	    let evd' = meta_assign mv (c,(status,TypeProcessed)) evd in
+	      w_merge_rec evd' (metas@metas'') evars'' eqns
+    | [] ->
 
     (* Process type eqns *)
     match eqns with
-    | (mv,c)::eqns ->
-        let (metas,evars) = unify_type env evd flags mv c in 
+    | (mv,status,c)::eqns ->
+        let (evd,metas,evars) = unify_type env evd flags mv status c in
         w_merge_rec evd metas evars eqns
     | [] -> evd
-		
+
   and mimick_evar evd flags hdc nargs sp =
-    let ev = Evd.find (evars_of evd) sp in
+    let ev = Evd.find 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 (mc,ec) =
-      unify_0 sp_env (evars_of evd') Cumul flags
-        (Retyping.get_type_of_with_meta sp_env (evars_of evd') (metas_of evd') c) ev.evar_concl in
-    let evd'' = w_merge_rec evd' mc ec [] in
-    if (evars_of evd') == (evars_of evd'')
-    then Evd.evar_define sp c evd''
-    else Evd.evar_define sp (Evarutil.nf_evar (evars_of evd'') c) evd'' in
+    let (evd'',mc,ec) =
+      unify_0 sp_env evd' Cumul flags
+        (Retyping.get_type_of sp_env evd' c) ev.evar_concl in
+    let evd''' = w_merge_rec evd'' mc ec [] in
+    if evd' == evd'''
+    then Evd.define sp c evd'''
+    else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in
 
   (* merge constraints *)
   w_merge_rec evd (order_metas metas) evars []
 
 let w_unify_meta_types env ?(flags=default_unify_flags) evd =
   let metas,evd = retract_coercible_metas evd in
-  w_merge env true flags (metas,[]) evd
+  w_merge env true flags (evd,metas,[])
 
 (* [w_unify env evd M N]
    performs a unification of M and N, generating a bunch of
@@ -616,38 +731,46 @@ let w_unify_meta_types env ?(flags=default_unify_flags) evd =
    [clenv_typed_unify M N clenv] expects in addition that expected
    types of metavars are unifiable with the types of their instances    *)
 
-let check_types env evd flags subst m n =
-  let sigma = evars_of evd in
-  if isEvar (fst (whd_stack sigma m)) or isEvar (fst (whd_stack sigma n)) then
-    unify_0_with_initial_metas subst true env (evars_of evd) topconv 
+let check_types env flags (sigma,_,_ as subst) m n =
+  if isEvar_or_Meta (fst (whd_stack sigma m)) then
+    unify_0_with_initial_metas subst true env Cumul
       flags
-      (Retyping.get_type_of_with_meta env sigma (metas_of evd) m)
-      (Retyping.get_type_of_with_meta env sigma (metas_of evd) n)
-  else
-    subst
+      (Retyping.get_type_of env sigma n)
+      (Retyping.get_type_of env sigma m)
+  else if isEvar_or_Meta (fst (whd_stack sigma n)) then
+    unify_0_with_initial_metas subst true env Cumul
+      flags
+      (Retyping.get_type_of env sigma m)
+      (Retyping.get_type_of env sigma n)
+  else subst
 
 let w_unify_core_0 env with_types cv_pb flags m n evd =
   let (mc1,evd') = retract_coercible_metas evd in
-  let subst1 = check_types env evd flags (mc1,[]) m n in
+  let (sigma,ms,es) = check_types env flags (evd,mc1,[]) m n in
   let subst2 =
-     unify_0_with_initial_metas subst1 true env (evars_of evd') cv_pb flags m n
-  in 
-  w_merge env with_types flags subst2 evd'
+     unify_0_with_initial_metas (evd',ms,es) true env cv_pb flags m n
+  in
+  let evd = w_merge env with_types flags subst2 in
+    if flags.resolve_evars then
+      try Typeclasses.resolve_typeclasses ~onlyargs:false ~split:false
+	~fail:true env evd
+      with e when Typeclasses_errors.unsatisfiable_exception e ->
+	error_cannot_unify env evd (m, n)
+    else evd
 
 let w_unify_0 env = w_unify_core_0 env false
 let w_typed_unify env = w_unify_core_0 env true
 
-
 (* 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
    FAIL because we cannot find a binding *)
 
 let iter_fail f a =
-  let n = Array.length a in 
+  let n = Array.length a in
   let rec ffail i =
-    if i = n then error "iter_fail" 
+    if i = n then error "iter_fail"
     else
-      try f a.(i) 
+      try f a.(i)
       with ex when precatchable_exception ex -> ffail (i+1)
   in ffail 0
 
@@ -657,105 +780,173 @@ let iter_fail f a =
 let w_unify_to_subterm env ?(flags=default_unify_flags) (op,cl) evd =
   let rec matchrec cl =
     let cl = strip_outer_cast cl in
-    (try 
-       if closed0 cl 
-       then w_unify_0 env topconv flags op cl evd,cl
+    (try
+       if closed0 cl && not (isEvar cl)
+       then w_typed_unify env topconv flags op cl evd,cl
        else error "Bound 1"
      with ex when precatchable_exception ex ->
-       (match kind_of_term cl with 
+       (match kind_of_term cl with
 	  | App (f,args) ->
 	      let n = Array.length args in
 	      assert (n>0);
 	      let c1 = mkApp (f,Array.sub args 0 (n-1)) in
 	      let c2 = args.(n-1) in
-	      (try 
+	      (try
 		 matchrec c1
-	       with ex when precatchable_exception ex -> 
+	       with ex when precatchable_exception ex ->
 		 matchrec c2)
           | Case(_,_,c,lf) -> (* does not search in the predicate *)
-	       (try 
+	       (try
 		 matchrec c
-	       with ex when precatchable_exception ex -> 
+	       with ex when precatchable_exception ex ->
 		 iter_fail matchrec lf)
-	  | LetIn(_,c1,_,c2) -> 
-	       (try 
+	  | LetIn(_,c1,_,c2) ->
+	       (try
 		 matchrec c1
-	       with ex when precatchable_exception ex -> 
+	       with ex when precatchable_exception ex ->
 		 matchrec c2)
 
-	  | Fix(_,(_,types,terms)) -> 
-	       (try 
+	  | Fix(_,(_,types,terms)) ->
+	       (try
 		 iter_fail matchrec types
-	       with ex when precatchable_exception ex -> 
+	       with ex when precatchable_exception ex ->
 		 iter_fail matchrec terms)
-	
-	  | CoFix(_,(_,types,terms)) -> 
-	       (try 
+
+	  | CoFix(_,(_,types,terms)) ->
+	       (try
 		 iter_fail matchrec types
-	       with ex when precatchable_exception ex -> 
+	       with ex when precatchable_exception ex ->
 		 iter_fail matchrec terms)
 
           | Prod (_,t,c) ->
-	      (try 
-		 matchrec t 
-	       with ex when precatchable_exception ex -> 
+	      (try
+		 matchrec t
+	       with ex when precatchable_exception ex ->
 		 matchrec c)
           | Lambda (_,t,c) ->
-	      (try 
-		 matchrec t 
-	       with ex when precatchable_exception ex -> 
+	      (try
+		 matchrec t
+	       with ex when precatchable_exception ex ->
 		 matchrec c)
-          | _ -> error "Match_subterm")) 
-  in 
+          | _ -> error "Match_subterm"))
+  in
   try matchrec cl
   with ex when precatchable_exception ex ->
     raise (PretypeError (env,NoOccurrenceFound (op, None)))
 
-let w_unify_to_subterm_list env flags allow_K oplist t evd = 
-  List.fold_right 
+(* Tries to find all instances of term [cl] in term [op].
+   Unifies [cl] to every subterm of [op] and return all the matches.
+   Fails if no match is found *)
+let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd =
+  let return a b =
+    let (evd,c as a) = a () in
+      if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b
+  in
+  let fail str _ = error str in
+  let bind f g a =
+    let a1 = try f a
+             with ex
+             when precatchable_exception ex -> a
+    in try g a1
+       with ex
+       when precatchable_exception ex -> a1
+  in
+  let bind_iter f a =
+    let n = Array.length a in
+    let rec ffail i =
+      if i = n then fun a -> a
+      else bind (f a.(i)) (ffail (i+1))
+    in ffail 0
+  in
+  let rec matchrec cl =
+    let cl = strip_outer_cast cl in
+      (bind
+	  (if closed0 cl
+	  then return (fun () -> w_typed_unify env topconv flags op cl evd,cl)
+            else fail "Bound 1")
+          (match kind_of_term cl with
+	    | App (f,args) ->
+		let n = Array.length args in
+		assert (n>0);
+		let c1 = mkApp (f,Array.sub args 0 (n-1)) in
+		let c2 = args.(n-1) in
+		bind (matchrec c1) (matchrec c2)
+
+            | Case(_,_,c,lf) -> (* does not search in the predicate *)
+		bind (matchrec c) (bind_iter matchrec lf)
+
+	    | LetIn(_,c1,_,c2) ->
+		bind (matchrec c1) (matchrec c2)
+
+	    | Fix(_,(_,types,terms)) ->
+		bind (bind_iter matchrec types) (bind_iter matchrec terms)
+
+	    | CoFix(_,(_,types,terms)) ->
+		bind (bind_iter matchrec types) (bind_iter matchrec terms)
+
+            | Prod (_,t,c) ->
+		bind (matchrec t) (matchrec c)
+
+            | Lambda (_,t,c) ->
+		bind (matchrec t) (matchrec c)
+
+            | _ -> fail "Match_subterm"))
+  in
+  let res = matchrec cl [] in
+  if res = [] then
+    raise (PretypeError (env,NoOccurrenceFound (op, None)))
+  else
+    res
+
+let w_unify_to_subterm_list env flags allow_K hdmeta oplist t evd =
+  List.fold_right
     (fun op (evd,l) ->
+      let op = whd_meta evd op in
       if isMeta op then
 	if allow_K then (evd,op::l)
-	else error "Match_subterm"
+	else error_abstraction_over_meta env evd hdmeta (destMeta op)
       else if occur_meta_or_existential op then
         let (evd',cl) =
-          try 
+          try
 	    (* This is up to delta for subterms w/o metas ... *)
 	    w_unify_to_subterm env ~flags (strip_outer_cast op,t) evd
-          with PretypeError (env,NoOccurrenceFound _) when allow_K -> (evd,op)
-        in 
-	(evd',cl::l)
+	  with PretypeError (env,NoOccurrenceFound _) when allow_K -> (evd,op)
+        in
+	  if not allow_K && (* ensure we found a different instance *)
+	    List.exists (fun op -> eq_constr op cl) l
+	  then error_non_linear_unification env evd hdmeta cl
+	  else (evd',cl::l)
       else if allow_K or dependent op t then
 	(evd,op::l)
       else
 	(* This is not up to delta ... *)
 	raise (PretypeError (env,NoOccurrenceFound (op, None))))
-    oplist 
+    oplist
     (evd,[])
 
 let secondOrderAbstraction env flags allow_K typ (p, oplist) evd =
   (* Remove delta when looking for a subterm *)
   let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in
   let (evd',cllist) =
-    w_unify_to_subterm_list env flags allow_K oplist typ evd in
+    w_unify_to_subterm_list env flags allow_K p oplist typ evd in
   let typp = Typing.meta_type evd' p in
   let pred = abstract_list_all env evd' typp typ cllist in
-  w_merge env false flags ([p,pred,(ConvUpToEta 0,TypeProcessed)],[]) evd'
+  w_merge env false flags (evd',[p,pred,(ConvUpToEta 0,TypeProcessed)],[])
 
 let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =
-  let c1, oplist1 = whd_stack (evars_of evd) ty1 in
-  let c2, oplist2 = whd_stack (evars_of evd) ty2 in
+  let c1, oplist1 = whd_stack evd ty1 in
+  let c2, oplist2 = whd_stack evd ty2 in
   match kind_of_term c1, kind_of_term c2 with
     | Meta p1, _ ->
         (* Find the predicate *)
 	let evd' =
-          secondOrderAbstraction env flags allow_K ty2 (p1,oplist1) evd in 
+          secondOrderAbstraction env flags allow_K ty2 (p1,oplist1) evd in
         (* Resume first order unification *)
 	w_unify_0 env cv_pb flags (nf_meta evd' ty1) ty2 evd'
     | _, Meta p2 ->
         (* Find the predicate *)
 	let evd' =
-          secondOrderAbstraction env flags allow_K ty1 (p2, oplist2) evd in 
+          secondOrderAbstraction env flags allow_K ty1 (p2, oplist2) evd in
         (* Resume first order unification *)
 	w_unify_0 env cv_pb flags ty1 (nf_meta evd' ty2) evd'
     | _ -> error "w_unify2"
@@ -782,29 +973,29 @@ let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =
    Meta(1) had meta-variables in it. *)
 let w_unify allow_K env cv_pb ?(flags=default_unify_flags) ty1 ty2 evd =
   let cv_pb = of_conv_pb cv_pb in
-  let hd1,l1 = whd_stack (evars_of evd) ty1 in
-  let hd2,l2 = whd_stack (evars_of evd) ty2 in
+  let hd1,l1 = whd_stack evd ty1 in
+  let hd2,l2 = whd_stack evd ty2 in
     match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
       (* Pattern case *)
       | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
 	  when List.length l1 = List.length l2 ->
-	  (try 
+	  (try
 	      w_typed_unify env cv_pb flags ty1 ty2 evd
-	    with ex when precatchable_exception ex -> 
-	      try 
+	    with ex when precatchable_exception ex ->
+	      try
 		w_unify2 env flags allow_K cv_pb ty1 ty2 evd
 	      with PretypeError (env,NoOccurrenceFound _) as e -> raise e)
-	    
+
       (* Second order case *)
-      | (Meta _, true, _, _ | _, _, Meta _, true) -> 
-	  (try 
+      | (Meta _, true, _, _ | _, _, Meta _, true) ->
+	  (try
 	      w_unify2 env flags allow_K cv_pb ty1 ty2 evd
 	    with PretypeError (env,NoOccurrenceFound _) as e -> raise e
-	      | ex when precatchable_exception ex -> 
-		  try 
+	      | ex when precatchable_exception ex ->
+		  try
 		    w_typed_unify env cv_pb flags ty1 ty2 evd
 		  with ex' when precatchable_exception ex' ->
 		    raise ex)
-	    
+
       (* General case: try first order *)
       | _ -> w_typed_unify env cv_pb flags ty1 ty2 evd
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 89280631..cc62a9bb 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: unification.mli 10856 2008-04-27 16:15:34Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -14,10 +14,12 @@ open Environ
 open Evd
 (*i*)
 
-type unify_flags = { 
-  modulo_conv_on_closed_terms : Names.transparent_state option; 
+type unify_flags = {
+  modulo_conv_on_closed_terms : Names.transparent_state option;
   use_metas_eagerly : bool;
   modulo_delta : Names.transparent_state;
+  resolve_evars : bool;
+  use_evars_pattern_unification : bool
 }
 
 val default_unify_flags : unify_flags
@@ -25,20 +27,23 @@ val default_no_delta_unify_flags : unify_flags
 
 (* The "unique" unification fonction *)
 val w_unify :
-  bool -> env -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_defs -> evar_defs
+  bool -> env -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map -> evar_map
 
 (* [w_unify_to_subterm env (c,t) m] performs unification of [c] with a
    subterm of [t]. Constraints are added to [m] and the matched
    subterm of [t] is also returned. *)
 val w_unify_to_subterm :
-  env -> ?flags:unify_flags -> constr * constr -> evar_defs -> evar_defs * constr
+  env -> ?flags:unify_flags -> constr * constr -> evar_map -> evar_map * constr
 
-val w_unify_meta_types : env -> ?flags:unify_flags -> evar_defs -> evar_defs
+val w_unify_to_subterm_all :
+  env -> ?flags:unify_flags -> constr * constr -> evar_map -> (evar_map * constr) list
+
+val w_unify_meta_types : env -> ?flags:unify_flags -> evar_map -> evar_map
 
 (* [w_coerce_to_type env evd c ctyp typ] tries to coerce [c] of type
    [ctyp] so that its gets type [typ]; [typ] may contain metavariables *)
-val w_coerce_to_type : env -> evar_defs -> constr -> types -> types ->
-  evar_defs * constr
+val w_coerce_to_type : env -> evar_map -> constr -> types -> types ->
+  evar_map * constr
 
 (*i This should be in another module i*)
 
@@ -46,4 +51,4 @@ val w_coerce_to_type : env -> evar_defs -> constr -> types -> types ->
 (* abstracts the terms in l over c to get a term of type t *)
 (* (exported for inv.ml) *)
 val abstract_list_all :
-  env -> evar_defs -> constr -> constr -> constr list -> constr
+  env -> evar_map -> constr -> constr -> constr list -> constr
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 5d09570e..c894d2b5 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -6,21 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vnorm.ml 11424 2008-09-30 12:10:28Z jforest $ i*)
+(*i $Id$ i*)
 
 open Names
 open Declarations
 open Term
 open Environ
 open Inductive
-open Reduction 
+open Reduction
 open Vm
 
 (*******************************************)
 (* Calcul de la forme normal d'un terme    *)
 (*******************************************)
 
-let crazy_type =  mkSet 
+let crazy_type =  mkSet
 
 let decompose_prod env t =
   let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
@@ -33,18 +33,18 @@ exception Find_at of int
    [cst] = true si c'est un constructeur constant *)
 
 let invert_tag cst tag reloc_tbl =
-  try 
+  try
     for j = 0 to Array.length reloc_tbl - 1 do
       let tagj,arity = reloc_tbl.(j) in
       if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then
 	raise (Find_at j)
       else ()
-    done;raise Not_found 
-  with Find_at j -> (j+1)   
+    done;raise Not_found
+  with Find_at j -> (j+1)
              (* Argggg, ces constructeurs de ... qui commencent a 1*)
 
 let find_rectype_a env c =
-  let (t, l) = 
+  let (t, l) =
     let t = whd_betadeltaiota env c in
     try destApp t with _ -> (t,[||]) in
   match kind_of_term t with
@@ -53,13 +53,13 @@ let find_rectype_a env c =
 
 (* Instantiate inductives and parameters in constructor type *)
 
-let type_constructor mind mib typ params = 
+let type_constructor mind mib typ params =
   let s = ind_subst mind mib in
   let ctyp = substl s typ in
   let nparams = Array.length params in
   if nparams = 0 then ctyp
   else
-    let _,ctyp = decompose_prod_n nparams ctyp in   
+    let _,ctyp = decompose_prod_n nparams ctyp in
     substl (List.rev (Array.to_list params)) ctyp
 
 
@@ -85,7 +85,7 @@ let construct_of_constr const env tag typ =
     let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
       (mkApp(mkConstruct(ind,i), params), ctyp)
 
-let construct_of_constr_const env tag typ = 
+let construct_of_constr_const env tag typ =
   fst (construct_of_constr true env tag typ)
 
 let construct_of_constr_block = construct_of_constr false
@@ -94,15 +94,15 @@ let constr_type_of_idkey env idkey =
   match idkey with
   | ConstKey cst ->
       mkConst cst, Typeops.type_of_constant env cst
-  | VarKey id -> 
-      let (_,_,ty) = lookup_named id env in 
+  | VarKey id ->
+      let (_,_,ty) = lookup_named id env in
       mkVar id, ty
-  | RelKey i -> 
+  | RelKey i ->
       let n = (nb_rel env - i) in
       let (_,_,ty) = lookup_rel n env in
       mkRel n, lift n ty
 
-let type_of_ind env ind = 
+let type_of_ind env ind =
   type_of_inductive env (Inductive.lookup_mind_specif env ind)
 
 let build_branches_type env (mind,_ as _ind) mib mip params dep p =
@@ -116,7 +116,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p =
     let nparams = Array.length params in
     let carity = snd (rtbl.(i)) in
     let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in
-    let codom = 
+    let codom =
       let papp = mkApp(p,crealargs) in
       if dep then
 	let cstr = ith_constructor_of_inductive ind (i+1) in
@@ -124,17 +124,17 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p =
 	let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in
 	mkApp(papp,[|dep_cstr|])
       else papp
-    in 
+    in
     decl, codom
   in Array.mapi build_one_branch mip.mind_nf_lc
 
-let build_case_type dep p realargs c = 
+let build_case_type dep p realargs c =
   if dep then mkApp(mkApp(p, realargs), [|c|])
   else mkApp(p, realargs)
 
 (* La fonction de normalisation *)
 
-let rec nf_val env v t = nf_whd env (whd_val v) t 
+let rec nf_val env v t = nf_whd env (whd_val v) t
 
 and nf_vtype env v =  nf_val env v crazy_type
 
@@ -145,18 +145,18 @@ 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      
-      mkProd(name,dom,codom)	  
+      let codom = nf_vtype (push_rel (name,None,dom) env) vc  in
+      mkProd(name,dom,codom)
   | Vfun f -> nf_fun env f typ
   | Vfix(f,None) -> nf_fix env f
   | Vfix(f,Some vargs) -> fst (nf_fix_app env f vargs)
-  | Vcofix(cf,_,None) -> nf_cofix env cf 
-  | Vcofix(cf,_,Some vargs) -> 
+  | Vcofix(cf,_,None) -> nf_cofix env cf
+  | Vcofix(cf,_,Some vargs) ->
       let cfd = nf_cofix env cf in
       let i,(_,ta,_) = destCoFix cfd in
       let t = ta.(i) in
       let _, args = nf_args env vargs t in
-      mkApp(cfd,args) 
+      mkApp(cfd,args)
   | Vconstr_const n -> construct_of_constr_const env n typ
   | Vconstr_block b ->
       let capp,ctyp = construct_of_constr_block env (btag b) typ in
@@ -168,24 +168,24 @@ and nf_whd env whd typ =
   | Vatom_stk(Aiddef(idkey,v), stk) ->
       nf_whd env (whd_stack v stk) typ
   | Vatom_stk(Aind ind, stk) ->
-      nf_stk env (mkInd ind) (type_of_ind env ind) stk 
-	
+      nf_stk env (mkInd ind) (type_of_ind env ind) stk
+
 and nf_stk env c t stk  =
   match stk with
   | [] -> c
   | Zapp vargs :: stk ->
       let t, args = nf_args env vargs t in
-      nf_stk env (mkApp(c,args)) t stk 
-  | Zfix (f,vargs) :: stk ->  
+      nf_stk env (mkApp(c,args)) t stk
+  | Zfix (f,vargs) :: stk ->
       let fa, typ = nf_fix_app env f vargs in
       let _,_,codom = try decompose_prod env typ with _ -> exit 120 in
       nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk
-  | Zswitch sw :: stk -> 
+  | Zswitch sw :: stk ->
       let (mind,_ as ind),allargs = find_rectype_a env t in
       let (mib,mip) = Inductive.lookup_mind_specif env ind in
       let nparams = mib.mind_nparams in
       let params,realargs = Util.array_chop nparams allargs in
-      let pT = 
+      let pT =
 	hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in
       let pT = whd_betadeltaiota env pT in
       let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in
@@ -195,12 +195,12 @@ and nf_stk env c t stk  =
       let bsw = branch_of_switch (nb_rel env) sw in
       let mkbranch i (n,v) =
 	let decl,codom = btypes.(i) in
-	let env = 
-	  List.fold_right 
+	let env =
+	  List.fold_right
 	    (fun (name,t) env -> push_rel (name,None,t) env) decl env in
 	let b = nf_val env v codom in
-	compose_lam decl b 
-      in 
+	compose_lam decl b
+      in
       let branchs = Array.mapi mkbranch bsw in
       let tcase = build_case_type dep p realargs c in
       let ci = case_info sw in
@@ -212,10 +212,10 @@ and nf_predicate env ind mip params v pT =
       let k = nb_rel env in
       let vb = body_of_vfun k f in
       let name,dom,codom = try decompose_prod env pT with _ -> exit 121 in
-      let dep,body = 
+      let dep,body =
 	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
-  | Vfun f, _ -> 
+  | Vfun f, _ ->
       let k = nb_rel env in
       let vb = body_of_vfun k f in
       let name = Name (id_of_string "c") in
@@ -226,12 +226,12 @@ and nf_predicate env ind mip params v pT =
       let body = nf_vtype (push_rel (name,None,dom) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_val env v crazy_type
-	
+
 and nf_args env vargs t =
   let t = ref t in
   let len = nargs vargs in
-  let args = 
-    Array.init len 
+  let args =
+    Array.init len
       (fun i ->
 	let _,dom,codom = try decompose_prod env !t with _ -> exit 123 in
 	let c = nf_val env (arg vargs i) dom in
@@ -242,8 +242,8 @@ and nf_bargs env b t =
   let t = ref t in
   let len = bsize b in
   let args =
-    Array.init len 
-      (fun i -> 
+    Array.init len
+      (fun i ->
 	let _,dom,codom = try decompose_prod env !t with _ -> exit 124 in
 	let c = nf_val env (bfield b i) dom in
 	t := subst1 c codom; c) in
@@ -252,7 +252,7 @@ and nf_bargs env b t =
 and nf_fun env f typ =
   let k = nb_rel env in
   let vb = body_of_vfun k f in
-  let name,dom,codom = 
+  let name,dom,codom =
     try decompose_prod env typ
     with _ ->
       raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ))
@@ -268,17 +268,17 @@ and nf_fix env f =
   let ndef = Array.length vt in
   let ft = Array.map (fun v -> nf_val env v crazy_type) vt in
   let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in
-  let env = push_rec_types (name,ft,ft) env in 
+  let env = push_rec_types (name,ft,ft) env in
   let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in
   mkFix ((rec_args,init),(name,ft,fb))
-      
+
 and nf_fix_app env f vargs =
   let fd = nf_fix env f in
   let (_,i),(_,ta,_) = destFix fd in
   let t = ta.(i) in
   let t, args = nf_args env vargs t in
   mkApp(fd,args),t
-  
+
 and nf_cofix env cf =
   let init = current_cofix cf in
   let k = nb_rel env in
@@ -286,15 +286,15 @@ and nf_cofix env cf =
   let ndef = Array.length vt in
   let cft = Array.map (fun v -> nf_val env v crazy_type) vt in
   let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in
-  let env = push_rec_types (name,cft,cft) env in 
+  let env = push_rec_types (name,cft,cft) env in
   let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in
   mkCoFix (init,(name,cft,cfb))
-  
+
 let cbv_vm env c t  =
   let transp = transp_values () in
-  if not transp then set_transp_values true; 
+  if not transp then set_transp_values true;
   let v = Vconv.val_of_constr env c in
   let c = nf_val env v t in
-  if not transp then set_transp_values false; 
+  if not transp then set_transp_values false;
   c
-  
+
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index 769a9572..9bc818e8 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: clenvtac.ml 12102 2009-04-24 10:48:11Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -30,34 +30,34 @@ open Pattern
 open Tacexpr
 open Clenv
 
-    
+
 (* This function put casts around metavariables whose type could not be
  * infered by the refiner, that is head of applications, predicates and
  * subject of Cases.
  * Does check that the casted type is closed. Anyway, the refiner would
  * fail in this case... *)
 
-let clenv_cast_meta clenv = 
+let clenv_cast_meta clenv =
   let rec crec u =
     match kind_of_term u with
       | App _ | Case _ -> crec_hd u
       | Cast (c,_,_) when isMeta c -> u
       | _  -> map_constr crec u
-	    
+
   and crec_hd u =
     match kind_of_term (strip_outer_cast u) with
-    | Meta mv ->
-	(try 
+      | Meta mv ->
+	  (try
             let b = Typing.meta_type clenv.evd mv in
-	      if occur_meta b then
-		raise (RefinerError (MetaInType b));
-	      mkCast (mkMeta mv, DEFAULTcast, b)
+	    assert (not (occur_meta b));
+	    if occur_meta b then u
+            else mkCast (mkMeta mv, DEFAULTcast, b)
 	  with Not_found -> u)
-    | App(f,args) -> mkApp (crec_hd f, Array.map crec args)
-    | Case(ci,p,c,br) ->
-	mkCase (ci, crec_hd p, crec_hd c, Array.map crec br)
-    | _ -> u
-  in 
+      | App(f,args) -> mkApp (crec_hd f, Array.map crec args)
+      | Case(ci,p,c,br) ->
+	  mkCase (ci, crec_hd p, crec_hd c, Array.map crec br)
+      | _ -> u
+  in
   crec
 
 let clenv_value_cast_meta clenv =
@@ -70,16 +70,17 @@ 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
 
-
 let clenv_refine with_evars ?(with_classes=true) clenv gls =
   let clenv = clenv_pose_dependent_evars with_evars clenv in
-  let evd' = 
-    if with_classes then 
-      Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd 
+  let evd' =
+    if with_classes then
+      Typeclasses.resolve_typeclasses ~fail:(not with_evars)
+	clenv.env clenv.evd
     else clenv.evd
   in
+  let clenv = { clenv with evd = evd' } in
   tclTHEN
-    (tclEVARS (evars_of evd')) 
+    (tclEVARS evd')
     (refine (clenv_cast_meta clenv (clenv_value clenv)))
     gls
 
@@ -104,17 +105,19 @@ let e_res_pf clenv = res_pf clenv ~with_evars:true ~allow_K:false ~flags:dft
 open Unification
 
 let fail_quick_unif_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state; 
+  modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly = false;
   modulo_delta = empty_transparent_state;
+  resolve_evars = false;
+  use_evars_pattern_unification = false;
 }
 
 (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
-let unifyTerms ?(flags=fail_quick_unif_flags) m n gls = 
+let unifyTerms ?(flags=fail_quick_unif_flags) m n gls =
   let env = pf_env gls in
   let evd = create_goal_evar_defs (project gls) in
   let evd' = w_unify false env CONV ~flags m n evd in
-  tclIDTAC {it = gls.it; sigma = evars_of evd'}
+  tclIDTAC {it = gls.it; sigma =  evd'}
 
 let unify ?(flags=fail_quick_unif_flags) m gls =
   let n = pf_concl gls in unifyTerms ~flags m n gls
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 04a5eb57..96fb262a 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: clenvtac.mli 11709 2008-12-20 11:42:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
diff --git a/proofs/decl_expr.mli b/proofs/decl_expr.mli
index 22752eda..bf5fa2e9 100644
--- a/proofs/decl_expr.mli
+++ b/proofs/decl_expr.mli
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_expr.mli 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id$ *)
 
 open Names
 open Util
 open Tacexpr
 
-type 'it statement = 
+type 'it statement =
     {st_label:name;
      st_it:'it}
 
@@ -41,12 +41,12 @@ type ('it,'constr,'tac) cut =
      cut_by: 'constr list option;
      cut_using: 'tac option}
 
-type ('var,'constr) hyp = 
-    Hvar of 'var 
+type ('var,'constr) hyp =
+    Hvar of 'var
   | Hprop of 'constr statement
 
-type ('constr,'tac) casee = 
-    Real of 'constr 
+type ('constr,'tac) casee =
+    Real of 'constr
   | Virtual of ('constr statement,'constr,'tac) cut
 
 type ('hyp,'constr,'pat,'tac) bare_proof_instr =
@@ -64,9 +64,9 @@ type ('hyp,'constr,'pat,'tac) bare_proof_instr =
   | Pfocus of 'constr statement
   | Pdefine of identifier * 'hyp list * 'constr
   | Pcast of identifier or_thesis * 'constr
-  | Psuppose of ('hyp,'constr) hyp list 
-  | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) 
-  | Ptake of 'constr list 
+  | Psuppose of ('hyp,'constr) hyp list
+  | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list)
+  | Ptake of 'constr list
   | Pper of elim_type * ('constr,'tac) casee
   | Pend of block_type
   | Pescape
@@ -86,11 +86,11 @@ type raw_proof_instr =
 
 type glob_proof_instr =
     ((identifier*(Genarg.rawconstr_and_expr option)) located,
-     Genarg.rawconstr_and_expr,  
+     Genarg.rawconstr_and_expr,
      Topconstr.cases_pattern_expr,
      Tacexpr.glob_tactic_expr) gen_proof_instr
 
-type proof_pattern = 
+type proof_pattern =
     {pat_vars: Term.types statement list;
      pat_aliases: (Term.constr*Term.types) statement list;
      pat_constr: Term.constr;
@@ -100,6 +100,6 @@ type proof_pattern =
 
 type proof_instr =
     (Term.constr statement,
-     Term.constr, 
+     Term.constr,
      proof_pattern,
      Tacexpr.glob_tactic_expr) gen_proof_instr
diff --git a/proofs/decl_mode.ml b/proofs/decl_mode.ml
index 134a4d8b..8be5f355 100644
--- a/proofs/decl_mode.ml
+++ b/proofs/decl_mode.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: decl_mode.ml 12422 2009-10-27 08:42:49Z corbinea $ i*)
+(*i $Id$ i*)
 
 open Names
 open Term
@@ -15,9 +15,9 @@ open Util
 
 let daimon_flag = ref false
 
-let set_daimon_flag () = daimon_flag:=true 
+let set_daimon_flag () = daimon_flag:=true
 let clear_daimon_flag () = daimon_flag:=false
-let get_daimon_flag () = !daimon_flag 
+let get_daimon_flag () = !daimon_flag
 
 type command_mode =
     Mode_tactic
@@ -27,12 +27,12 @@ type command_mode =
 let mode_of_pftreestate pts =
   let goal = sig_it (Refiner.top_goal_of_pftreestate pts) in
     if goal.evar_extra = None then
-      Mode_tactic 
+      Mode_tactic
     else
       Mode_proof
-	  
+
 let get_current_mode () =
-  try 
+  try
     mode_of_pftreestate (Pfedit.get_pftreestate ())
   with _ -> Mode_none
 
@@ -42,7 +42,7 @@ let check_not_proof_mode str =
 
 type split_tree=
     Skip_patt of Idset.t * split_tree
-  | Split_patt of Idset.t * inductive * 
+  | Split_patt of Idset.t * inductive *
 		(bool array * (Idset.t * split_tree) option) array
   | Close_patt of split_tree
   | End_patt of (identifier * (int * int))
@@ -54,7 +54,7 @@ type elim_kind =
 
 type recpath = int option*Declarations.wf_paths
 
-type per_info = 
+type per_info =
     {per_casee:constr;
      per_ctype:types;
      per_ind:inductive;
@@ -64,7 +64,7 @@ type per_info =
      per_nparams:int;
      per_wf:recpath}
 
-type stack_info = 
+type stack_info =
     Per of Decl_expr.elim_type * per_info * elim_kind * identifier list
   | Suppose_case
   | Claim
@@ -73,7 +73,7 @@ type stack_info =
 type pm_info =
     { pm_stack : stack_info list}
 
-let pm_in,pm_out = Dyn.create "pm_info" 
+let pm_in,pm_out = Dyn.create "pm_info"
 
 let get_info gl=
   match gl.evar_extra with
@@ -81,30 +81,30 @@ let get_info gl=
     | Some extra ->
 	try pm_out extra with _ -> invalid_arg "get_info"
 
-let get_stack pts = 
+let get_stack pts =
   let info = get_info (sig_it (Refiner.nth_goal_of_pftreestate 1 pts)) in
     info.pm_stack
 
-let get_top_stack pts = 
+let get_top_stack pts =
   let info = get_info (sig_it (Refiner.top_goal_of_pftreestate pts)) in
     info.pm_stack
 
 let get_end_command pts =
-  match mode_of_pftreestate pts with 
+  match mode_of_pftreestate pts with
       Mode_proof ->
-	Some 
+	Some
 	  begin
 	    match get_top_stack pts with
 		[] -> "\"end proof\""
 	      | Claim::_ -> "\"end claim\""
 	      | Focus_claim::_-> "\"end focus\""
-	      | (Suppose_case :: Per (et,_,_,_) :: _ 
-		| Per (et,_,_,_) :: _ ) -> 
+	      | (Suppose_case :: Per (et,_,_,_) :: _
+		| Per (et,_,_,_) :: _ ) ->
 		  begin
 		    match et with
-			Decl_expr.ET_Case_analysis -> 
+			Decl_expr.ET_Case_analysis ->
 			  "\"end cases\" or start a new case"
-		      | Decl_expr.ET_Induction -> 
+		      | Decl_expr.ET_Induction ->
 			  "\"end induction\" or start a new case"
 		  end
 	      | _ -> anomaly "lonely suppose"
@@ -112,7 +112,7 @@ let get_end_command pts =
     | Mode_tactic ->
 	begin
 	  try
-	    ignore 
+	    ignore
 	      (Refiner.up_until_matching_rule Proof_trees.is_proof_instr pts);
 	    Some "\"return\""
 	  with Not_found -> None
@@ -120,8 +120,8 @@ let get_end_command pts =
     | Mode_none ->
         error "no proof in progress"
 
-let get_last env =  
-  try 
+let get_last env =
+  try
     let (id,_,_) =  List.hd (Environ.named_context env) in id
   with Invalid_argument _ -> error "no previous statement to use"
 
diff --git a/proofs/decl_mode.mli b/proofs/decl_mode.mli
index bcfd6a96..1ecd4d3a 100644
--- a/proofs/decl_mode.mli
+++ b/proofs/decl_mode.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_mode.mli 12422 2009-10-27 08:42:49Z corbinea $ *)
+(* $Id$ *)
 
 open Names
 open Term
@@ -23,7 +23,7 @@ type command_mode =
   | Mode_none
 
 val mode_of_pftreestate : pftreestate -> command_mode
-    
+
 val get_current_mode : unit -> command_mode
 
 val check_not_proof_mode : string -> unit
@@ -42,7 +42,7 @@ type elim_kind =
 
 type recpath = int option*Declarations.wf_paths
 
-type per_info = 
+type per_info =
     {per_casee:constr;
      per_ctype:types;
      per_ind:inductive;
@@ -52,7 +52,7 @@ type per_info =
      per_nparams:int;
      per_wf:recpath}
 
-type stack_info = 
+type stack_info =
     Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list
   | Suppose_case
   | Claim
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index f4613f8d..e4fab3f2 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -6,45 +6,59 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_refiner.ml 12102 2009-04-24 10:48:11Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
 open Term
 open Evd
+open Evarutil
 open Sign
 open Proof_trees
 open Refiner
-open Pretyping
 
 (******************************************)
 (* Instantiation of existential variables *)
 (******************************************)
 
-(* w_tactic pour instantiate *) 
+let depends_on_evar evk _ (pbty,_,t1,t2) =
+  try head_evar t1 = evk
+  with NoHeadEvar ->
+  try head_evar t2 = evk
+  with NoHeadEvar -> false
 
-let w_refine evk (ltac_vars,rawc) evd =
-  if Evd.is_defined (evars_of evd) evk then 
+let define_and_solve_constraints evk c evd =
+  try
+    let evd = define evk c evd in
+    let (evd,pbs) = extract_changed_conv_pbs evd (depends_on_evar evk) in
+    fst (List.fold_left
+      (fun (evd,b as p) (pbty,env,t1,t2) ->
+	if b then Evarconv.evar_conv_x env evd pbty t1 t2 else p) (evd,true)
+      pbs)
+  with e when Pretype_errors.precatchable_exception e ->
+    error "Instance does not satisfy constraints."
+
+let w_refine (evk,evi) (ltac_var,rawc) sigma =
+  if Evd.is_defined sigma evk then
     error "Instantiate called on already-defined evar";
-  let e_info = Evd.find (evars_of evd) evk in
-  let env = Evd.evar_env e_info in
-  let evd',typed_c =
-    try Pretyping.Default.understand_ltac 
-      (evars_of evd) env ltac_vars (OfType (Some e_info.evar_concl)) rawc
+  let env = Evd.evar_env evi in
+  let sigma',typed_c =
+    try Pretyping.Default.understand_ltac true sigma env ltac_var
+	  (Pretyping.OfType (Some evi.evar_concl)) rawc
     with _ ->
       let loc = Rawterm.loc_of_rawconstr rawc in
-      user_err_loc 
+      user_err_loc
         (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^
 			string_of_existential evk))
   in
-    evar_define evk typed_c (evars_reset_evd (evars_of evd') evd)
+  define_and_solve_constraints evk typed_c (evars_reset_evd sigma' sigma)
 
 (* vernac command Existential *)
 
-let instantiate_pf_com n com pfts = 
+let instantiate_pf_com n com pfts =
   let gls = top_goal_of_pftreestate pfts in
-  let sigma = gls.sigma in 
-  let (evk,evi) = 
+  let sigma = gls.sigma in
+  let (evk,evi) =
     let evl = Evarutil.non_instantiated sigma in
       if (n <= 0) then
 	error "incorrect existential variable index"
@@ -52,9 +66,8 @@ let instantiate_pf_com n com pfts =
 	  error "not so many uninstantiated existential variables"
       else
 	List.nth evl (n-1)
-  in 
+  in
   let env = Evd.evar_env evi in
-  let rawc = Constrintern.intern_constr sigma env com in 
-  let evd = create_goal_evar_defs sigma in
-  let evd' = w_refine evk (([],[]),rawc) evd in
-    change_constraints_pftreestate (evars_of evd') pfts
+  let rawc = Constrintern.intern_constr sigma env com in
+  let sigma' = w_refine (evk,evi) (([],[]),rawc) sigma in
+  change_constraints_pftreestate sigma' pfts
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
index a42b11a4..30e702a0 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evar_refiner.mli 12102 2009-04-24 10:48:11Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -20,10 +20,10 @@ open Rawterm
 
 (* Refinement of existential variables. *)
 
-val w_refine : evar -> (var_map * unbound_ltac_var_map) * rawconstr -> 
-  evar_defs -> evar_defs
+val w_refine : evar * evar_info ->
+  rawconstr_ltac_closure -> evar_map -> evar_map
 
 val instantiate_pf_com :
   int -> Topconstr.constr_expr -> pftreestate -> pftreestate
 
-(* the instantiate tactic was moved to [tactics/evar_tactics.ml] *) 
+(* the instantiate tactic was moved to [tactics/evar_tactics.ml] *)
diff --git a/proofs/logic.ml b/proofs/logic.ml
index c019d45f..9cab6a05 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: logic.ml 12240 2009-07-15 09:52:52Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -28,7 +28,7 @@ open Type_errors
 open Retyping
 open Evarutil
 open Tacexpr
- 
+
 type refiner_error =
 
   (* Errors raised by the refiner *)
@@ -50,15 +50,17 @@ open Pretype_errors
 let rec catchable_exception = function
   | Stdpp.Exc_located(_,e) -> catchable_exception e
   | LtacLocated(_,e) -> catchable_exception e
-  | Util.UserError _ | TypeError _ 
+  | Util.UserError _ | TypeError _
   | RefinerError _ | Indrec.RecursionSchemeError _
   | Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _)
+  (* reduction errors *)
+  | Tacred.ReductionTacticError _ 
   (* unification errors *)
   | PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
 		   |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
 		   |CannotFindWellTypedAbstraction _
 		   |UnsolvableImplicit _)) -> true
-  | Typeclasses_errors.TypeClassError 
+  | Typeclasses_errors.TypeClassError
       (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
   | _ -> false
 
@@ -73,19 +75,19 @@ 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 =
-  try apply_to_hyp sign id f 
-  with Hyp_not_found -> 
+  try apply_to_hyp sign id f
+  with Hyp_not_found ->
     if !check then error "No such assumption."
     else sign
 
 let apply_to_hyp_and_dependent_on sign id f g =
-  try apply_to_hyp_and_dependent_on sign id f g 
-  with Hyp_not_found -> 
+  try apply_to_hyp_and_dependent_on sign id f g
+  with Hyp_not_found ->
     if !check then error "No such assumption."
     else sign
 
 let check_typability env sigma c =
-  if !check then let _ = type_of env sigma c in () 
+  if !check then let _ = type_of env sigma c in ()
 
 (************************************************************************)
 (************************************************************************)
@@ -99,7 +101,7 @@ let check_typability env sigma c =
 let clear_hyps sigma ids sign cl =
   let evdref = ref (Evd.create_goal_evar_defs sigma) in
   let (hyps,concl) = Evarutil.clear_hyps_in_evi evdref sign cl ids in
-  (hyps,concl,evars_of !evdref)
+  (hyps,concl, !evdref)
 
 (* The ClearBody tactic *)
 
@@ -111,7 +113,7 @@ let recheck_typability (what,id) env sigma t =
       | Some id -> "hypothesis "^(string_of_id id) in
     error
       ("The correctness of "^s^" relies on the body of "^(string_of_id id))
-  
+
 let remove_hyp_body env sigma id =
   let sign =
     apply_to_hyp_and_dependent_on (named_context_val env) id
@@ -121,7 +123,7 @@ let remove_hyp_body env sigma id =
 	| Some c ->(id,None,t))
       (fun (id',c,t as d) sign ->
 	(if !check then
-	  begin 
+	  begin
 	    let env = reset_with_named_context sign env in
 	    match c with
 	    | None ->  recheck_typability (Some id',id) env sigma t
@@ -130,7 +132,7 @@ let remove_hyp_body env sigma id =
 		recheck_typability (Some id',id) env sigma b'
 	  end;d))
   in
-  reset_with_named_context sign env 
+  reset_with_named_context sign env
 
 (* Reordering of the context *)
 
@@ -138,7 +140,7 @@ let remove_hyp_body env sigma id =
 (* sous-ordre du resultat. Par exemple, 2 hyps non mentionnee ne sont *)
 (* pas echangees. Choix: les hyps mentionnees ne peuvent qu'etre *)
 (* reculees par rapport aux autres (faire le contraire!) *)
- 
+
 let mt_q = (Idmap.empty,[])
 let push_val y = function
     (_,[] as q) -> q
@@ -211,8 +213,8 @@ let check_decl_position env sign (x,_,_ as d) =
 (* Auxiliary functions for primitive MOVE tactic
  *
  * [move_hyp with_dep toleft (left,(hfrom,typfrom),right) hto] moves
- * hyp [hfrom] at location [hto] which belongs to the hyps on the 
- * left side [left] of the full signature if [toleft=true] or to the hyps 
+ * hyp [hfrom] at location [hto] which belongs to the hyps on the
+ * left side [left] of the full signature if [toleft=true] or to the hyps
  * on the right side [right] if [toleft=false].
  * If [with_dep] then dependent hypotheses are moved accordingly. *)
 
@@ -228,17 +230,17 @@ let split_sign hfrom hto l =
   let rec splitrec left toleft = function
     | [] -> error_no_such_hypothesis hfrom
     | (hyp,c,typ) as d :: right ->
-      	if hyp = hfrom then 
+      	if hyp = hfrom then
 	  (left,right,d, toleft or hto = MoveToEnd true)
       	else
-	  splitrec (d::left) 
+	  splitrec (d::left)
 	    (toleft or hto = MoveAfter hyp or hto = MoveBefore hyp)
 	    right
-  in 
+  in
     splitrec [] false l
 
 let hyp_of_move_location = function
-  | MoveAfter id -> id 
+  | MoveAfter id -> id
   | MoveBefore id -> id
   | _ -> assert false
 
@@ -258,12 +260,12 @@ let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
 	List.rev first @ List.rev middle @ right
     | (hyp,_,_) as d :: right ->
 	let (first',middle') =
-      	  if List.exists (test_dep d) middle then 
-	    if with_dep & hto <> MoveAfter hyp then 
+      	  if List.exists (test_dep d) middle then
+	    if with_dep & hto <> MoveAfter hyp then
 	      (first, d::middle)
-            else 
-	      errorlabstrm "" (str "Cannot move " ++ pr_id idfrom ++
-	        pr_move_location pr_id hto ++ 
+            else
+	      errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++
+	        pr_move_location pr_id hto ++
 	        str (if toleft then ": it occurs in " else ": it depends on ")
 	        ++ pr_id hyp ++ str ".")
           else
@@ -271,16 +273,16 @@ let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
 	in
       	if hto = MoveAfter hyp then
 	  List.rev first' @ List.rev middle' @ right
-      	else 
+      	else
 	  moverec first' middle' right
   in
-  if toleft then 
-    let right = 
+  if toleft then
+    let right =
       List.fold_right push_named_context_val right empty_named_context_val in
     List.fold_left (fun sign d -> push_named_context_val d sign)
-      right (moverec [] [declfrom] left) 
-  else 
-    let right = 
+      right (moverec [] [declfrom] left)
+  else
+    let right =
       List.fold_right push_named_context_val
 	(moverec [] [declfrom] right) empty_named_context_val in
     List.fold_left (fun sign d -> push_named_context_val d sign)
@@ -295,7 +297,7 @@ let rename_hyp id1 id2 sign =
 (************************************************************************)
 (* Implementation of the logical rules *)
 
-(* Will only be used on terms given to the Refine rule which have meta 
+(* Will only be used on terms given to the Refine rule which have meta
 variables only in Application and Case *)
 
 let error_unsupported_deep_meta c =
@@ -303,7 +305,7 @@ let error_unsupported_deep_meta c =
     strbrk "form contains metavariables deep inside the term is not " ++
     strbrk "supported; try \"refine\" instead.")
 
-let collect_meta_variables c = 
+let collect_meta_variables c =
   let rec collrec deep acc c = match kind_of_term c with
     | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc
     | Cast(c,_,_) -> collrec deep acc c
@@ -312,16 +314,16 @@ let collect_meta_variables c =
   in
   List.rev (collrec false [] c)
 
-let check_meta_variables c = 
+let check_meta_variables c =
   if not (list_distinct (collect_meta_variables c)) then
     raise (RefinerError (NonLinearProof c))
 
 let check_conv_leq_goal env sigma arg ty conclty =
-  if !check & not (is_conv_leq env sigma ty conclty) then 
+  if !check & not (is_conv_leq env sigma ty conclty) then
     raise (RefinerError (BadType (arg,ty,conclty)))
 
 let goal_type_of env sigma c =
-  (if !check then type_of else Retyping.get_type_of) env sigma c
+  (if !check then type_of else Retyping.get_type_of ~refresh:true) env sigma c
 
 let rec mk_refgoals sigma goal goalacc conclty trm =
   let env = evar_env goal in
@@ -329,7 +331,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
   let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in
 (*
    if  not (occur_meta trm) then
-    let t'ty = (unsafe_machine env sigma trm).uj_type in 	
+    let t'ty = (unsafe_machine env sigma trm).uj_type in
     let _ = conv_leq_goal env sigma trm t'ty conclty in
       (goalacc,t'ty)
   else
@@ -352,9 +354,9 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
 	    | Ind _ | Const _
 		when (isInd f or has_polymorphic_type (destConst f)) ->
 		(* Sort-polymorphism of definition and inductive types *)
-		goalacc, 
+		goalacc,
                 type_of_global_reference_knowing_conclusion env sigma f conclty
-	    | _ -> 
+	    | _ ->
 		mk_hdgoals sigma goal goalacc f
 	in
 	let (acc'',conclty') =
@@ -365,14 +367,14 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
     | Case (_,p,c,lf) ->
 	let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in
 	check_conv_leq_goal env sigma trm conclty' conclty;
-	let acc'' = 
+	let acc'' =
 	  array_fold_left2
             (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi))
-            acc' lbrty lf 
+            acc' lbrty lf
 	in
 	(acc'',conclty')
 
-    | _ -> 
+    | _ ->
 	if occur_meta trm then
 	  anomaly "refiner called with a meta in non app/case subterm";
 
@@ -397,8 +399,8 @@ and mk_hdgoals sigma goal goalacc trm =
 	mk_refgoals sigma goal goalacc ty t
 
     | App (f,l) ->
-	let (acc',hdty) = 
-	  if isInd f or isConst f 
+	let (acc',hdty) =
+	  if isInd f or isConst f
 	     & not (array_exists occur_meta l) (* we could be finer *)
 	  then
 	    (goalacc,type_of_global_reference_knowing_parameters env sigma f l)
@@ -408,16 +410,16 @@ and mk_hdgoals sigma goal goalacc trm =
 
     | Case (_,p,c,lf) ->
 	let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in
-	let acc'' = 
+	let acc'' =
 	  array_fold_left2
             (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi))
-            acc' lbrty lf 
+            acc' lbrty lf
 	in
 	(acc'',conclty')
 
     | _ ->
 	if !check && occur_meta trm then
-	  anomaly "refined called with a dependent meta";
+	  anomaly "refine called with a dependent meta";
 	goalacc, goal_type_of env sigma trm
 
 and mk_arggoals sigma goal goalacc funty = function
@@ -434,14 +436,13 @@ and mk_arggoals sigma goal goalacc funty = function
 
 and mk_casegoals sigma goal goalacc p c =
   let env = evar_env goal in
-  let (acc',ct) = mk_hdgoals sigma goal goalacc c in 
+  let (acc',ct) = mk_hdgoals sigma goal goalacc c in
   let (acc'',pt) = mk_hdgoals sigma goal acc' p in
-  let pj = {uj_val=p; uj_type=pt} in 
   let indspec =
-    try find_mrectype env sigma (nf_evar sigma ct)
+    try find_mrectype env sigma ct
     with Not_found -> anomaly "mk_casegoals" in
   let (lbrty,conclty) =
-    type_case_branches_with_names env indspec pj c in
+    type_case_branches_with_names env indspec p c in
   (acc'',lbrty,conclty)
 
 
@@ -467,7 +468,7 @@ let norm_goal sigma gl =
   let red_fun = Evarutil.nf_evar sigma in
   let ncl = red_fun gl.evar_concl in
   let ngl =
-    { gl with 
+    { gl with
 	evar_concl = ncl;
 	evar_hyps = map_named_val red_fun gl.evar_hyps } in
     if Evd.eq_evar_info ngl gl then None else Some ngl
@@ -487,7 +488,7 @@ let prim_refiner r sigma goal =
     (* Logical rules *)
     | Intro id ->
     	if !check && mem_named_context id (named_context_of_val sign) then
-	  error "New variable is already declared";
+	  error ("Variable " ^ string_of_id id ^ " is already declared.");
         (match kind_of_term (strip_outer_cast cl) with
 	   | Prod (_,c1,b) ->
 	       let sg = mk_goal (push_named_context_val (id,None,c1) sign)
@@ -500,7 +501,7 @@ let prim_refiner r sigma goal =
 	       ([sg], sigma)
 	   | _ ->
 	       raise (RefinerError IntroNeedsProduct))
-	
+
     | Cut (b,replace,id,t) ->
         let sg1 = mk_goal sign (nf_betaiota sigma t) in
 	let sign,cl,sigma =
@@ -512,58 +513,58 @@ let prim_refiner r sigma goal =
 	      cl,sigma
 	  else
             (if !check && mem_named_context id (named_context_of_val sign) then
-                error "New variable is already declared";
+	      error ("Variable " ^ string_of_id id ^ " is already declared.");
 	     push_named_context_val (id,None,t) sign,cl,sigma) in
         let sg2 = mk_goal sign cl in
         if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma)
 
     | FixRule (f,n,rest,j) ->
-     	let rec check_ind env k cl = 
-          match kind_of_term (strip_outer_cast cl) with 
-            | Prod (na,c1,b) -> 
-            	if k = 1 then 
-		  try 
+     	let rec check_ind env k cl =
+          match kind_of_term (strip_outer_cast cl) with
+            | Prod (na,c1,b) ->
+            	if k = 1 then
+		  try
 		    fst (find_inductive env sigma c1)
-		  with Not_found -> 
+		  with Not_found ->
 		    error "Cannot do a fixpoint on a non inductive type."
-            	else 
+            	else
 		  check_ind (push_rel (na,None,c1) env) (k-1) b
             | _ -> error "Not enough products."
 	in
 	let (sp,_) = check_ind env n cl in
 	let firsts,lasts = list_chop j rest in
 	let all = firsts@(f,n,cl)::lasts in
-     	let rec mk_sign sign = function 
+     	let rec mk_sign sign = function
 	  | (f,n,ar)::oth ->
-	      let (sp',_)  = check_ind env n ar in 
-	      if not (sp=sp') then 
-		error ("Fixpoints should be on the same " ^ 
+	      let (sp',_)  = check_ind env n ar in
+	      if not (sp=sp') then
+		error ("Fixpoints should be on the same " ^
 		       "mutual inductive declaration.");
 	      if !check && mem_named_context f (named_context_of_val sign) then
 		error
 		  ("Name "^string_of_id f^" already used in the environment");
 	      mk_sign (push_named_context_val (f,None,ar) sign) oth
-	  | [] -> 
+	  | [] ->
 	      List.map (fun (_,_,c) -> mk_goal sign c) all
-	in 
+	in
 	  (mk_sign sign all, sigma)
-	
+
     | Cofix (f,others,j) ->
-     	let rec check_is_coind env cl = 
+     	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 
+            | _ ->
+		try
 		  let _ = find_coinductive env sigma b in ()
-                with Not_found -> 
+                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 
+        let rec mk_sign sign = function
           | (f,ar)::oth ->
 	      (try
                 (let _ = lookup_named_val f sign in
@@ -572,7 +573,7 @@ let prim_refiner r sigma goal =
               |	Not_found ->
                   mk_sign (push_named_context_val (f,None,ar) sign) oth)
 	  | [] -> List.map (fun (_,c) -> mk_goal sign c) all
-     	in 
+     	in
 	  (mk_sign sign all, sigma)
 
     | Refine c ->
@@ -587,17 +588,17 @@ let prim_refiner r sigma goal =
 	if (not !check) || is_conv_leq env sigma cl' cl then
           let sg = mk_goal sign cl' in
           ([sg], sigma)
-	else 
+	else
 	  error "convert-concl rule passed non-converting term"
 
     | Convert_hyp (id,copt,ty) ->
 	([mk_goal (convert_hyp sign sigma (id,copt,ty)) cl], sigma)
 
     (* And now the structural rules *)
-    | Thin ids -> 
+    | Thin ids ->
 	let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in
 	  ([mk_goal hyps concl], nsigma)
-	
+
     | ThinBody ids ->
 	let clear_aux env id =
           let env' = remove_hyp_body env sigma id in
@@ -609,9 +610,9 @@ let prim_refiner r sigma goal =
      	  ([sg], sigma)
 
     | Move (withdep, hfrom, hto) ->
-  	let (left,right,declfrom,toleft) = 
+  	let (left,right,declfrom,toleft) =
 	  split_sign hfrom hto (named_context_of_val sign) in
-  	let hyps' = 
+  	let hyps' =
 	  move_hyp withdep toleft (left,declfrom,right) hto in
   	  ([mk_goal hyps' cl], sigma)
 
@@ -642,7 +643,7 @@ type variable_proof_status = ProofVar | SectionVar of identifier
 
 type proof_variable = name * variable_proof_status
 
-let subst_proof_vars = 
+let subst_proof_vars =
   let rec aux p vars =
     let _,subst =
       List.fold_left (fun (n,l) var ->
@@ -653,22 +654,22 @@ let subst_proof_vars =
         (n+1,t)) (p,[]) vars
     in replace_vars (List.rev subst)
   in aux 1
-         
+
 let rec rebind id1 id2 = function
   | [] -> [Name id2,SectionVar id1]
-  | (na,k as x)::l -> 
+  | (na,k as x)::l ->
       if na = Name id1 then (Name id2,k)::l else
         let l' = rebind id1 id2 l in
         if na = Name id2 then (Anonymous,k)::l' else x::l'
 
 let add_proof_var id vl = (Name id,ProofVar)::vl
 
-let proof_variable_index x = 
+let proof_variable_index x =
   let rec aux n = function
     | (Name id,ProofVar)::l when x = id -> n
     | _::l ->  aux (n+1) l
     | [] -> raise Not_found
-  in 
+  in
   aux 1
 
 let prim_extractor subfun vl pft =
@@ -684,7 +685,7 @@ let prim_extractor subfun vl pft =
 		let cty = subst_proof_vars vl ty in
 		  mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf)
 	    | _ -> error "Incomplete proof!")
-	    
+
       | Some (Prim (Cut (b,_,id,t)),[spf1;spf2]) ->
           let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in
 	    mkLetIn (Name id,subfun vl spf1,subst_proof_vars vl t,
@@ -699,7 +700,7 @@ let prim_extractor subfun vl pft =
 	  let newvl = List.fold_left (fun vl (id,_,_) -> add_proof_var id vl)
             (add_proof_var f vl) others in
 	  let lfix = Array.map (subfun newvl) (Array.of_list spfl) in
-	    mkFix ((vn,j),(names,lcty,lfix))	
+	    mkFix ((vn,j),(names,lcty,lfix))
 
       | Some (Prim (Cofix (f,others,j)),spfl) ->
 	  let firsts,lasts = list_chop j others in
@@ -707,14 +708,14 @@ let prim_extractor subfun vl pft =
 	  let lcty = Array.map (fun (_,ar) -> subst_proof_vars vl ar) all in
 	  let names  = Array.map (fun (f,_) -> Name f) all in
 	  let newvl = List.fold_left (fun vl (id,_)-> add_proof_var id vl)
-            (add_proof_var f vl) others in 
+            (add_proof_var f vl) others in
 	  let lfix = Array.map (subfun newvl) (Array.of_list spfl) in
 	    mkCoFix (j,(names,lcty,lfix))
-	      
+
       | Some (Prim (Refine c),spfl) ->
 	  let mvl = collect_meta_variables c in
 	  let metamap = List.combine mvl (List.map (subfun vl) spfl) in
-	  let cc = subst_proof_vars vl c in 
+	  let cc = subst_proof_vars vl c in
 	    plain_instance metamap cc
 
       (* Structural and conversion rules do not produce any proof *)
@@ -727,10 +728,10 @@ let prim_extractor subfun vl pft =
       | Some (Prim (Thin _),[pf]) ->
 	  (* No need to make ids Anon in vl: subst_proof_vars take the most recent*)
 	  subfun vl pf
-	    
+
       | Some (Prim (ThinBody _),[pf]) ->
 	  subfun vl pf
-	    
+
       | Some (Prim (Move _|Order _),[pf]) ->
 	  subfun vl pf
 
@@ -743,4 +744,4 @@ let prim_extractor subfun vl pft =
       | Some _ -> anomaly "prim_extractor"
 
       | None-> error "prim_extractor handed incomplete proof"
-	  
+
diff --git a/proofs/logic.mli b/proofs/logic.mli
index 2f3a0d89..0d56da38 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: logic.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -26,9 +26,9 @@ val with_check    : tactic -> tactic
   [Intro]: no check that the name does not exist\\
   [Intro_after]: no check that the name does not exist and that variables in
      its type does not escape their scope\\
-  [Intro_replacing]: no check that the name does not exist and that 
+  [Intro_replacing]: no check that the name does not exist and that
      variables in its type does not escape their scope\\
-  [Convert_hyp]: 
+  [Convert_hyp]:
   no check that the name exist and that its type is convertible\\
 *)
 
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 0aba9f5f..f3658ad4 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pfedit.ml 11745 2009-01-04 18:43:08Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -31,10 +31,12 @@ open Safe_typing
 (* Mainly contributed by C. Murthy                                   *)
 (*********************************************************************)
 
+type lemma_possible_guards = int list list
+
 type proof_topstate = {
   mutable top_end_tac : tactic option;
   top_init_tac : tactic option;
-  top_compute_guard : bool;
+  top_compute_guard : lemma_possible_guards;
   top_goal : goal;
   top_strength : Decl_kinds.goal_kind;
   top_hook : declaration_hook }
@@ -81,26 +83,26 @@ let get_current_goal_context () = get_goal_context 1
 
 let set_current_proof = Edit.focus proof_edits
 
-let resume_proof (loc,id) = 
-  try 
+let resume_proof (loc,id) =
+  try
     Edit.focus proof_edits id
   with Invalid_argument "Edit.focus" ->
     user_err_loc(loc,"Pfedit.set_proof",str"No such proof" ++ msg_proofs false)
 
 let suspend_proof () =
-  try 
+  try
     Edit.unfocus proof_edits
   with Invalid_argument "Edit.unfocus" ->
     errorlabstrm "Pfedit.suspend_current_proof"
       (str"No active proof" ++ (msg_proofs true))
-      
+
 let resume_last_proof () =
   match (Edit.last_focused proof_edits) with
     | None ->
         errorlabstrm "resume_last" (str"No proof-editing in progress.")
-    | Some p -> 
+    | Some p ->
 	Edit.focus proof_edits p
-	  
+
 let get_current_proof_name () =
   match Edit.read proof_edits with
     | None ->
@@ -114,14 +116,14 @@ let add_proof (na,pfs,ts) =
 let delete_proof_gen = Edit.delete proof_edits
 
 let delete_proof (loc,id) =
-  try 
+  try
     delete_proof_gen id
   with (UserError ("Edit.delete",_)) ->
     user_err_loc
       (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false)
-      
+
 let mutate f =
-  try 
+  try
     Edit.mutate proof_edits (fun _ pfs -> f pfs)
   with Invalid_argument "Edit.mutate" ->
     errorlabstrm "Pfedit.mutate"
@@ -131,31 +133,31 @@ let start (na,ts) =
   let pfs = mk_pftreestate ts.top_goal in
   let pfs = Option.fold_right solve_pftreestate ts.top_init_tac pfs in
   add_proof(na,pfs,ts)
-    
+
 let restart_proof () =
   match Edit.read proof_edits with
-    | None -> 
+    | None ->
 	errorlabstrm "Pfedit.restart"
           (str"No focused proof to restart" ++ msg_proofs true)
-    | Some(na,_,ts) -> 
+    | Some(na,_,ts) ->
 	delete_proof_gen na;
         start (na,ts);
         set_current_proof na
 
 let proof_term () =
   extract_pftreestate (get_pftreestate())
-    
+
 (* Detect is one has completed a subtree of the initial goal *)
-let subtree_solved () = 
+let subtree_solved () =
   let pts = get_pftreestate () in
-  is_complete_proof (proof_of_pftreestate pts) & 
+  is_complete_proof (proof_of_pftreestate pts) &
   not (is_top_pftreestate pts)
 
-let tree_solved () = 
+let tree_solved () =
   let pts = get_pftreestate () in
   is_complete_proof (proof_of_pftreestate pts)
 
-let top_tree_solved () = 
+let top_tree_solved () =
   let pts = get_pftreestate () in
   is_complete_proof (proof_of_pftreestate (top_of_tree pts))
 
@@ -165,19 +167,19 @@ let top_tree_solved () =
 
 let set_undo = function
   | None -> undo_limit := undo_default
-  | Some n -> 
-      if n>=0 then 
+  | Some n ->
+      if n>=0 then
 	undo_limit := n
-      else 
+      else
 	error "Cannot set a negative undo limit"
 
 let get_undo () = Some !undo_limit
 
 let undo n =
-  try 
-    Edit.undo proof_edits n; 
-       (* needed because the resolution of a subtree is done in 2 steps 
-       then a sequence of undo can lead to a focus on a completely solved 
+  try
+    Edit.undo proof_edits n;
+       (* needed because the resolution of a subtree is done in 2 steps
+       then a sequence of undo can lead to a focus on a completely solved
        subtree - this solution only works properly if undoing one step *)
     if subtree_solved() then  Edit.undo proof_edits 1
   with (Invalid_argument "Edit.undo") ->
@@ -186,14 +188,14 @@ let undo n =
 (* Undo current focused proof to reach depth [n]. This is used in
    [vernac_backtrack]. *)
 let undo_todepth n =
-  try 
+  try
     Edit.undo_todepth proof_edits n
   with (Invalid_argument "Edit.undo") ->
     errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true)
 
 (* Return the depth of the current focused proof stack, this is used
    to put informations in coq prompt (in emacs mode). *)
-let current_proof_depth() = 
+let current_proof_depth() =
   try
     Edit.depth proof_edits
   with (Invalid_argument "Edit.depth") -> -1
@@ -206,7 +208,7 @@ let xml_cook_proof = ref (fun _ -> ())
 let set_xml_cook_proof f = xml_cook_proof := f
 
 let cook_proof k =
-  let (pfs,ts) = get_state() 
+  let (pfs,ts) = get_state()
   and ident = get_current_proof_name () in
   let {evar_concl=concl} = ts.top_goal
   and strength = ts.top_strength in
@@ -220,19 +222,19 @@ let cook_proof k =
       const_entry_boxed = false},
     ts.top_compute_guard, strength, ts.top_hook))
 
-let current_proof_statement () = 
+let current_proof_statement () =
   let ts = get_topstate() in
-  (get_current_proof_name (), ts.top_strength, 
+  (get_current_proof_name (), ts.top_strength,
    ts.top_goal.evar_concl, ts.top_hook)
 
 (*********************************************************************)
 (*              Abort   functions                                    *)
 (*********************************************************************)
- 
+
 let refining () = [] <> (Edit.dom proof_edits)
 
 let check_no_pending_proofs () =
-  if refining () then 
+  if refining () then
     errorlabstrm "check_no_pending_proofs"
       (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++
          str"Use \"Abort All\" first or complete proof(s).")
@@ -252,9 +254,9 @@ let set_end_tac tac =
 (*              Modifying the current prooftree                      *)
 (*********************************************************************)
 
-let start_proof na str sign concl ?init_tac ?(compute_guard=false) hook =
+let start_proof na str sign concl ?init_tac ?(compute_guard=[]) hook =
   let top_goal = mk_goal sign concl None in
-  let ts = { 
+  let ts = {
     top_end_tac = None;
     top_init_tac = init_tac;
     top_compute_guard = compute_guard;
@@ -269,7 +271,7 @@ let solve_nth k tac =
   let pft = get_pftreestate () in
   if not (List.mem (-1) (cursor_of_pftreestate pft)) then
     mutate (solve_nth_pftreestate k tac)
-  else 
+  else
     error "cannot apply a tactic when we are descended behind a tactic-node"
 
 let by tac = mutate (solve_pftreestate tac)
@@ -278,7 +280,7 @@ let instantiate_nth_evar_com n c =
   mutate (Evar_refiner.instantiate_pf_com n c)
 
 let traverse n = mutate (traverse n)
- 
+
 (* [traverse_to path]
 
    Traverses the current proof to get to the location specified by
@@ -296,7 +298,7 @@ let common_ancestor l1 l2 =
       | _, _ -> List.rev l1, List.length l2
   in
   common_aux (List.rev l1) (List.rev l2)
-      
+
 let rec traverse_up = function
   | 0 -> (function pf -> pf)
   | n -> (function pf -> Refiner.traverse 0 (traverse_up (n - 1) pf))
@@ -326,12 +328,34 @@ let make_focus n = focus_n := n
 let focus () = !focus_n
 let focused_goal () = let n = !focus_n in if n=0 then 1 else n
 
-let reset_top_of_tree () = 
+let reset_top_of_tree () =
   mutate top_of_tree
- 
-let reset_top_of_script () = 
-  mutate (fun pts -> 
+
+let reset_top_of_script () =
+  mutate (fun pts ->
 	try
 	 up_until_matching_rule is_proof_instr pts
 	with Not_found -> top_of_tree pts)
 
+(**********************************************************************)
+(* Shortcut to build a term using tactics *)
+
+open Decl_kinds
+
+let next = let n = ref 0 in fun () -> incr n; !n
+
+let build_constant_by_tactic sign typ tac =
+  let id = id_of_string ("temporary_proof"^string_of_int (next())) in
+  start_proof id (Global,Proof Theorem) sign typ (fun _ _ -> ());
+  try
+    by tac;
+    let _,(const,_,_,_) = cook_proof (fun _ -> ()) in
+    delete_current_proof ();
+    const
+  with e ->
+    delete_current_proof ();
+    raise e
+
+let build_by_tactic typ tac =
+  let sign = Decls.clear_proofs (Global.named_context ()) in
+  (build_constant_by_tactic sign typ tac).const_entry_body
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index 464f6286..acb85247 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pfedit.mli 11745 2009-01-04 18:43:08Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -78,9 +78,12 @@ val get_undo : unit -> int option
     systematically apply at initialization time (e.g. to start the
     proof of mutually dependent theorems) *)
 
-val start_proof : 
+type lemma_possible_guards = int list list
+
+val start_proof :
   identifier -> goal_kind -> named_context_val -> constr ->
-    ?init_tac:tactic -> ?compute_guard:bool -> declaration_hook -> unit
+  ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> 
+  declaration_hook -> unit
 
 (* [restart_proof ()] restarts the current focused proof from the beginning
    or fails if no proof is focused *)
@@ -107,8 +110,10 @@ val suspend_proof : unit -> unit
     it fails if there is no current proof of if it is not completed;
     it also tells if the guardness condition has to be inferred. *)
 
-val cook_proof : (Refiner.pftreestate -> unit) -> 
-  identifier * (Entries.definition_entry * bool * goal_kind * declaration_hook)
+val cook_proof : (Refiner.pftreestate -> unit) ->
+  identifier *
+  (Entries.definition_entry * lemma_possible_guards * goal_kind * 
+   declaration_hook)
 
 (* To export completed proofs to xml *)
 val set_xml_cook_proof : (goal_kind * pftreestate -> unit) -> unit
@@ -190,5 +195,13 @@ val traverse_prev_unproven : unit -> unit
 
 (* These two functions make it possible to implement more elaborate
    proof and goal management, as it is done, for instance in pcoq *)
+
 val traverse_to : int list -> unit
 val mutate : (pftreestate -> pftreestate) -> unit
+
+
+(* [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *)
+
+val build_constant_by_tactic : named_context_val -> types -> tactic ->
+  Entries.definition_entry
+val build_by_tactic : types -> tactic -> constr
diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml
index 99a1e506..a5bd073a 100644
--- a/proofs/proof_trees.ml
+++ b/proofs/proof_trees.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: proof_trees.ml 10124 2007-09-17 18:40:21Z herbelin $ *)
+(* $Id$ *)
 
 open Closure
 open Util
@@ -33,10 +33,11 @@ let is_bind = function
 
 (* Functions on goals *)
 
-let mk_goal hyps cl extra = 
-  { evar_hyps = hyps; evar_concl = cl; 
+let mk_goal hyps cl extra =
+  { evar_hyps = hyps; evar_concl = cl;
     evar_filter = List.map (fun _ -> true) (named_context_of_val hyps);
-    evar_body = Evar_empty; evar_extra = extra }
+    evar_body = Evar_empty; evar_source = (dummy_loc,GoalEvar); 
+    evar_extra = extra }
 
 (* Functions on proof trees *)
 
@@ -48,9 +49,9 @@ let ref_of_proof pf =
 let rule_of_proof pf =
   let (r,_) = ref_of_proof pf in r
 
-let children_of_proof pf = 
+let children_of_proof pf =
   let (_,cl) = ref_of_proof pf in cl
-				    
+
 let goal_of_proof pf = pf.goal
 
 let subproof_of_proof pf = match pf.ref with
@@ -68,13 +69,13 @@ let is_tactic_proof pf = match pf.ref with
   | _ -> false
 
 
-let pf_lookup_name_as_renamed env ccl s =
-  Detyping.lookup_name_as_renamed env ccl s
+let pf_lookup_name_as_displayed env ccl s =
+  Detyping.lookup_name_as_displayed env ccl s
 
 let pf_lookup_index_as_renamed env ccl n =
   Detyping.lookup_index_as_renamed env ccl n
 
-(* Functions on rules (Proof mode) *) 
+(* Functions on rules (Proof mode) *)
 
 let is_dem_rule  = function
     Decl_proof _  -> true
@@ -85,9 +86,9 @@ let is_proof_instr = function
   | _ -> false
 
 let is_focussing_command = function
-    Decl_proof b -> b 
-  | Nested (Proof_instr (b,_),_) -> b 
-  | _ -> false   
+    Decl_proof b -> b
+  | Nested (Proof_instr (b,_),_) -> b
+  | _ -> false
 
 
 (*********************************************************************)
diff --git a/proofs/proof_trees.mli b/proofs/proof_trees.mli
index f9b64f41..6d1fc143 100644
--- a/proofs/proof_trees.mli
+++ b/proofs/proof_trees.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_trees.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -33,7 +33,7 @@ val is_complete_proof : proof_tree -> bool
 val is_leaf_proof     : proof_tree -> bool
 val is_tactic_proof   : proof_tree -> bool
 
-val pf_lookup_name_as_renamed  : env -> constr -> identifier -> int option
+val pf_lookup_name_as_displayed  : env -> constr -> identifier -> int option
 val pf_lookup_index_as_renamed : env -> constr -> int -> int option
 
 val is_proof_instr : rule -> bool
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
index 150fb89f..1daddde9 100644
--- a/proofs/proof_type.ml
+++ b/proofs/proof_type.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_type.ml 12168 2009-06-06 21:34:37Z herbelin $ *)
+(*i $Id$ *)
 
 (*i*)
 open Environ
@@ -48,11 +48,11 @@ type proof_tree = {
 
 and rule =
   | Prim of prim_rule
-  | Nested of compound_rule * proof_tree 
+  | Nested of compound_rule * proof_tree
   | Decl_proof of bool
   | Daimon
 
-and compound_rule=  
+and compound_rule=
   | Tactic of tactic_expr * bool
   | Proof_instr of bool*proof_instr (* the boolean is for focus restrictions *)
 
@@ -63,47 +63,48 @@ and tactic = goal sigma -> (goal list sigma * validation)
 and validation = (proof_tree list -> proof_tree)
 
 and tactic_expr =
-  (open_constr,
+  (constr,
    constr_pattern,
    evaluable_global_reference,
    inductive,
    ltac_constant,
    identifier,
-   glob_tactic_expr)
+   glob_tactic_expr,
+   tlevel)
      Tacexpr.gen_tactic_expr
 
 and atomic_tactic_expr =
-  (open_constr,
+  (constr,
    constr_pattern,
    evaluable_global_reference,
    inductive,
    ltac_constant,
    identifier,
-   glob_tactic_expr)
+   glob_tactic_expr,
+   tlevel)
      Tacexpr.gen_atomic_tactic_expr
 
 and tactic_arg =
-  (open_constr,
+  (constr,
    constr_pattern,
    evaluable_global_reference,
    inductive,
    ltac_constant,
    identifier,
-   glob_tactic_expr)
+   glob_tactic_expr,
+   tlevel)
      Tacexpr.gen_tactic_arg
 
-type hyp_location = identifier Tacexpr.raw_hyp_location
-
-type ltac_call_kind = 
+type ltac_call_kind =
   | LtacNotationCall of string
   | LtacNameCall of ltac_constant
   | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref
   | LtacVarCall of identifier * glob_tactic_expr
   | LtacConstrInterp of rawconstr *
-      ((identifier * constr) list * (identifier * identifier option) list)
+      (extended_patvar_map * (identifier * identifier option) list)
 
-type ltac_trace = (loc * ltac_call_kind) list
+type ltac_trace = (int * loc * ltac_call_kind) list
 
-exception LtacLocated of (ltac_call_kind * ltac_trace * loc) * exn
+exception LtacLocated of (int * ltac_call_kind * ltac_trace * loc) * exn
 
 let abstract_tactic_box = ref (ref None)
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index c80e126f..c4a48c3c 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_type.mli 12168 2009-06-06 21:34:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Environ
@@ -32,7 +32,7 @@ type prim_rule =
   | FixRule of identifier * int * (identifier * int * constr) list * int
   | Cofix of identifier * (identifier * constr) list * int
   | Refine of constr
-  | Convert_concl of types * cast_kind 
+  | Convert_concl of types * cast_kind
   | Convert_hyp of named_declaration
   | Thin of identifier list
   | ThinBody of identifier list
@@ -58,7 +58,7 @@ type prim_rule =
                                     lc     : [Set of evars occurring
                                               in the type of evar] } };
                ...
-               number of last 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]
@@ -69,11 +69,11 @@ type prim_rule =
 \end{verbatim}
 *)
 
-(*s Proof trees. 
-  [ref] = [None] if the goal has still to be proved, 
+(*s Proof trees.
+  [ref] = [None] if the goal has still to be proved,
   and [Some (r,l)] if the rule [r] was applied to the goal
-  and gave [l] as subproofs to be completed. 
-  if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof 
+  and gave [l] as subproofs to be completed.
+  if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof
   that the goal can be proven if the goals in [l] are solved. *)
 type proof_tree = {
   open_subgoals : int;
@@ -82,11 +82,11 @@ type proof_tree = {
 
 and rule =
   | Prim of prim_rule
-  | Nested of compound_rule * proof_tree 
+  | Nested of compound_rule * proof_tree
   | Decl_proof of bool
   | Daimon
 
-and compound_rule= 
+and compound_rule=
   (* the boolean of Tactic tells if the default tactic is used *)
   | Tactic of tactic_expr * bool
   | Proof_instr of bool * proof_instr
@@ -98,47 +98,48 @@ and tactic = goal sigma -> (goal list sigma * validation)
 and validation = (proof_tree list -> proof_tree)
 
 and tactic_expr =
-  (open_constr,
+  (constr,
    constr_pattern,
    evaluable_global_reference,
    inductive,
    ltac_constant,
    identifier,
-   glob_tactic_expr)
+   glob_tactic_expr,
+   tlevel)
      Tacexpr.gen_tactic_expr
 
 and atomic_tactic_expr =
-  (open_constr,
+  (constr,
    constr_pattern,
    evaluable_global_reference,
    inductive,
    ltac_constant,
    identifier,
-   glob_tactic_expr)
+   glob_tactic_expr,
+   tlevel)
      Tacexpr.gen_atomic_tactic_expr
 
 and tactic_arg =
-  (open_constr,
+  (constr,
    constr_pattern,
    evaluable_global_reference,
    inductive,
    ltac_constant,
    identifier,
-   glob_tactic_expr)
+   glob_tactic_expr,
+   tlevel)
      Tacexpr.gen_tactic_arg
 
-type hyp_location = identifier Tacexpr.raw_hyp_location
-
-type ltac_call_kind = 
+type ltac_call_kind =
   | LtacNotationCall of string
   | LtacNameCall of ltac_constant
   | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref
   | LtacVarCall of identifier * glob_tactic_expr
   | LtacConstrInterp of rawconstr *
-      ((identifier * constr) list * (identifier * identifier option) list)
+      (extended_patvar_map * (identifier * identifier option) list)
 
-type ltac_trace = (loc * ltac_call_kind) list
+type ltac_trace = (int * loc * ltac_call_kind) list
 
-exception LtacLocated of (ltac_call_kind * ltac_trace * loc) * exn
+exception LtacLocated of (int * ltac_call_kind * ltac_trace * loc) * exn
 
 val abstract_tactic_box : atomic_tactic_expr option ref ref
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
new file mode 100644
index 00000000..05b86b1a
--- /dev/null
+++ b/proofs/proofs.mllib
@@ -0,0 +1,12 @@
+Tacexpr
+Proof_type
+Redexpr
+Proof_trees
+Logic
+Refiner
+Evar_refiner
+Tacmach
+Pfedit
+Tactic_debug
+Clenvtac
+Decl_mode
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index ad8ee3a2..b0a01caa 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: redexpr.ml 11481 2008-10-20 19:23:51Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,11 +15,13 @@ open Term
 open Declarations
 open Libnames
 open Rawterm
+open Pattern
 open Reductionops
 open Tacred
 open Closure
 open RedFlags
 open Libobject
+open Summary
 
 (* call by value normalisation function using the virtual machine *)
 let cbv_vm env _ c =
@@ -40,18 +42,18 @@ let set_strategy_one ref l  =
         let cb = Global.lookup_constant sp in
         if cb.const_body <> None & cb.const_opaque then
           errorlabstrm "set_transparent_const"
-            (str "Cannot make" ++ spc () ++ 
+            (str "Cannot make" ++ spc () ++
             Nametab.pr_global_env Idset.empty (ConstRef sp) ++
             spc () ++ str "transparent because it was declared opaque.");
         Csymtable.set_transparent_const sp
     | _ -> ()
 
 let cache_strategy (_,str) =
-  List.iter 
+  List.iter
     (fun (lev,ql) -> List.iter (fun q -> set_strategy_one q lev) ql)
     str
 
-let subst_strategy (_,subs,(local,obj)) =
+let subst_strategy (subs,(local,obj)) =
   local,
   list_smartmap
     (fun (k,ql as entry) ->
@@ -62,7 +64,7 @@ let subst_strategy (_,subs,(local,obj)) =
 
 let map_strategy f l =
   let l'  = List.fold_right
-    (fun (lev,ql) str -> 
+    (fun (lev,ql) str ->
       let ql' = List.fold_right
         (fun q ql ->
           match f q with
@@ -71,21 +73,15 @@ let map_strategy f l =
       if ql'=[] then str else (lev,ql')::str) l [] in
   if l'=[] then None else Some (false,l')
 
-let export_strategy (local,obj) =
-  if local then None else
-  map_strategy (function
-      EvalVarRef _ -> None
-    | EvalConstRef _ as q -> Some q) obj
-
-let classify_strategy (_,(local,_ as obj)) = 
+let classify_strategy (local,_ as obj) =
   if local then Dispose else Substitute obj
 
 let disch_ref ref =
   match ref with
-      EvalConstRef c -> 
+      EvalConstRef c ->
         let c' = Lib.discharge_con c in
         if c==c' then Some ref else Some (EvalConstRef c')
-    | _ -> Some ref
+    | EvalVarRef id -> if Lib.is_in_section (VarRef id) then None else Some ref
 
 let discharge_strategy (_,(local,obj)) =
   if local then None else
@@ -97,26 +93,22 @@ let (inStrategy,outStrategy) =
 		    load_function = (fun _ (_,obj) -> cache_strategy obj);
 		    subst_function = subst_strategy;
                     discharge_function = discharge_strategy;
-		    classify_function = classify_strategy;
-                    export_function = export_strategy }
+		    classify_function = classify_strategy }
 
 
 let set_strategy local str =
   Lib.add_anonymous_leaf (inStrategy (local,str))
 
-let _ = 
-  Summary.declare_summary "Transparent constants and variables"
-    { Summary.freeze_function = Conv_oracle.freeze;
-      Summary.unfreeze_function = Conv_oracle.unfreeze;
-      Summary.init_function = Conv_oracle.init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+let _ = declare_summary "Transparent constants and variables"
+    { freeze_function = Conv_oracle.freeze;
+      unfreeze_function = Conv_oracle.unfreeze;
+      init_function = Conv_oracle.init }
 
 
 (* Generic reduction: reduction functions used in reduction tactics *)
 
-type red_expr = (constr, evaluable_global_reference) red_expr_gen
-
+type red_expr =
+    (constr, evaluable_global_reference, constr_pattern) red_expr_gen
 
 let make_flag_constant = function
   | EvalVarRef id -> fVAR id
@@ -141,17 +133,34 @@ let make_flag f =
 	  f.rConst red
   in red
 
-let is_reference c = 
-  try let _ref = global_of_constr c in true with _ -> false
+let is_reference = function PRef _ | PVar _ -> true | _ -> false
+
+(* table of custom reductino fonctions, not synchronized,
+   filled via ML calls to [declare_reduction] *)
+let reduction_tab = ref Stringmap.empty
 
+(* table of custom reduction expressions, synchronized,
+   filled by command Declare Reduction *)
 let red_expr_tab = ref Stringmap.empty
 
-let declare_red_expr s f =
-  try 
-    let _ = Stringmap.find s !red_expr_tab in
-    error ("There is already a reduction expression of name "^s)
-  with Not_found ->
-    red_expr_tab := Stringmap.add s f !red_expr_tab
+let declare_reduction s f =
+  if Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab
+  then error ("There is already a reduction expression of name "^s)
+  else reduction_tab := Stringmap.add s f !reduction_tab
+
+let check_custom = function
+  | ExtraRedExpr s ->
+      if not (Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab)
+      then error ("Reference to undefined reduction expression "^s)
+  |_ -> ()
+
+let decl_red_expr s e =
+  if Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab
+  then error ("There is already a reduction expression of name "^s)
+  else begin
+    check_custom e;
+    red_expr_tab := Stringmap.add s e !red_expr_tab
+  end
 
 let out_arg = function
   | ArgVar _ -> anomaly "Unevaluated or_var variable"
@@ -160,13 +169,14 @@ let out_arg = function
 let out_with_occurrences ((b,l),c) =
   ((b,List.map out_arg l), c)
 
-let reduction_of_red_expr = function
-  | Red internal -> 
-      if internal then (try_red_product,DEFAULTcast) 
+let rec reduction_of_red_expr = function
+  | Red internal ->
+      if internal then (try_red_product,DEFAULTcast)
       else (red_product,DEFAULTcast)
   | Hnf -> (hnf_constr,DEFAULTcast)
   | Simpl (Some (_,c as lp)) ->
-    (contextually (is_reference c) (out_with_occurrences lp) simpl,DEFAULTcast)
+    (contextually (is_reference c) (out_with_occurrences lp)
+      (fun _ -> simpl),DEFAULTcast)
   | Simpl None -> (simpl,DEFAULTcast)
   | Cbv f -> (cbv_norm_flags (make_flag f),DEFAULTcast)
   | Lazy f -> (clos_norm_flags (make_flag f),DEFAULTcast)
@@ -174,6 +184,49 @@ let reduction_of_red_expr = function
   | Fold cl -> (fold_commands cl,DEFAULTcast)
   | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast)
   | ExtraRedExpr s ->
-      (try (Stringmap.find s !red_expr_tab,DEFAULTcast)
-      with Not_found -> error("unknown user-defined reduction \""^s^"\""))
+      (try (Stringmap.find s !reduction_tab,DEFAULTcast)
+      with Not_found ->
+	(try reduction_of_red_expr (Stringmap.find s !red_expr_tab)
+	 with Not_found ->
+	   error("unknown user-defined reduction \""^s^"\"")))
   | CbvVm -> (cbv_vm ,VMcast)
+
+
+let subst_flags subs flags =
+  { flags with rConst = List.map subs flags.rConst }
+
+let subst_occs subs (occ,e) = (occ,subs e)
+
+let subst_gen_red_expr subs_a subs_b subs_c = function
+  | Fold l -> Fold (List.map subs_a l)
+  | Pattern occs_l -> Pattern (List.map (subst_occs subs_a) occs_l)
+  | Simpl occs_o -> Simpl (Option.map (subst_occs subs_c) occs_o)
+  | Unfold occs_l -> Unfold (List.map (subst_occs subs_b) occs_l)
+  | Cbv flags -> Cbv (subst_flags subs_b flags)
+  | Lazy flags -> Lazy (subst_flags subs_b flags)
+  | e -> e
+
+let subst_red_expr subs e =
+  subst_gen_red_expr
+    (Mod_subst.subst_mps subs)
+    (Mod_subst.subst_evaluable_reference subs)
+    (Pattern.subst_pattern subs)
+    e
+
+let (inReduction,_) =
+  declare_object
+    {(default_object "REDUCTION") with
+       cache_function = (fun (_,(_,s,e)) -> decl_red_expr s e);
+       load_function = (fun _ (_,(_,s,e)) -> decl_red_expr s e);
+       subst_function =
+	(fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e);
+       classify_function =
+	(fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) }
+
+let declare_red_expr locality s expr =
+    Lib.add_anonymous_leaf (inReduction (locality,s,expr))
+
+let _ = declare_summary "Declare Reduction"
+  { freeze_function = (fun () -> !red_expr_tab);
+    unfreeze_function = ((:=) red_expr_tab);
+    init_function = (fun () -> red_expr_tab := Stringmap.empty) }
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index d72ff182..03d97ce3 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -6,24 +6,31 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: redexpr.mli 11094 2008-06-10 19:35:23Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Names
 open Term
 open Closure
+open Pattern
 open Rawterm
 open Reductionops
 open Termops
 
-
-type red_expr = (constr, evaluable_global_reference) red_expr_gen
+type red_expr =
+    (constr, evaluable_global_reference, constr_pattern) red_expr_gen
 
 val out_with_occurrences : 'a with_occurrences -> occurrences * 'a
 
 val reduction_of_red_expr : red_expr -> reduction_function * cast_kind
 (* [true] if we should use the vm to verify the reduction *)
 
-val declare_red_expr : string -> reduction_function -> unit
+(* Adding a custom reduction (function to be use at the ML level)
+   NB: the effect is permanent. *)
+val declare_reduction : string -> reduction_function -> unit
+
+(* Adding a custom reduction (function to be called a vernac command).
+   The boolean flag is the locality. *)
+val declare_red_expr : bool -> string -> red_expr -> unit
 
 (* Opaque and Transparent commands. *)
 
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 7ce256bf..a320b67c 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refiner.ml 11897 2009-02-09 19:28:02Z barras $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -49,23 +49,20 @@ let descend n p =
     | None        -> error "It is a leaf."
     | Some(r,pfl) ->
     	if List.length pfl >= n then
-	  (match list_chop (n-1) pfl with 
+	  (match list_chop (n-1) pfl with
 	     | left,(wanted::right) ->
 		 (wanted,
 		  (fun pfl' ->
-                     if (List.length pfl' = 1) 
-		       & (List.hd pfl').goal = wanted.goal 
-		     then
-                       let pf'       = List.hd pfl' in
-                       let spfl      = left@(pf'::right) in
-                       let newstatus = and_status (List.map pf_status spfl) in
-                       { p with 
-			   open_subgoals = newstatus;
-			   ref           = Some(r,spfl) }
-                     else 
-		       error "descend: validation"))
+		    if false (* debug *) then assert
+		      (List.length pfl'=1 & (List.hd pfl').goal = wanted.goal);
+                    let pf'       = List.hd pfl' in
+                    let spfl      = left@(pf'::right) in
+                    let newstatus = and_status (List.map pf_status spfl) in
+                    { p with
+			open_subgoals = newstatus;
+			ref           = Some(r,spfl) }))
 	     | _ -> assert false)
-    	else 
+    	else
 	  error "Too few subproofs"
 
 
@@ -75,28 +72,28 @@ let descend n p =
    (vk [ p_(l1+...+l(k-1)+1) ... p_(l1+...lk) ]) ]
  *)
 
-let rec mapshape nl (fl : (proof_tree list -> proof_tree) list) 
+let rec mapshape nl (fl : (proof_tree list -> proof_tree) list)
                     (l : proof_tree list) =
   match nl with
     | [] -> []
     | h::t ->
-	let m,l = list_chop h l in 
+	let m,l = list_chop h l in
 	(List.hd fl m) :: (mapshape t (List.tl fl) l)
 
 (* [frontier : proof_tree -> goal list * validation]
    given a proof [p], [frontier p] gives [(l,v)] where [l] is the list of goals
-   to be solved to complete the proof, and [v] is the corresponding 
+   to be solved to complete the proof, and [v] is the corresponding
    validation *)
-   
+
 let rec frontier p =
   match p.ref with
-    | None -> 
+    | None ->
 	([p.goal],
-	 (fun lp' -> 
+	 (fun lp' ->
 	    let p' = List.hd lp' in
-            if Evd.eq_evar_info p'.goal p.goal then 
+            if Evd.eq_evar_info p'.goal p.goal then
 	      p'
-            else 
+            else
 	      errorlabstrm "Refiner.frontier"
                 (str"frontier was handed back a ill-formed proof.")))
     | Some(r,pfl) ->
@@ -118,14 +115,14 @@ let set_solve_hook = (:=) solve_hook
 let rec frontier_map_rec f n p =
   if n < 1 || n > p.open_subgoals then p else
   match p.ref with
-    | None -> 
+    | None ->
         let p' = f p in
         if Evd.eq_evar_info p'.goal p.goal then
 	  begin
 	    !solve_hook p';
 	    p'
 	  end
-        else 
+        else
 	  errorlabstrm "Refiner.frontier_map"
             (str"frontier_map was handed back a ill-formed proof.")
     | Some(r,pfl) ->
@@ -142,20 +139,20 @@ let frontier_map f n p =
   let nmax = p.open_subgoals in
   let n = if n < 0 then nmax + n + 1 else n in
   if n < 1 || n > nmax then
-    errorlabstrm "Refiner.frontier_map" (str "No such subgoal"); 
+    errorlabstrm "Refiner.frontier_map" (str "No such subgoal");
   frontier_map_rec f n p
 
 let rec frontier_mapi_rec f i p =
   if p.open_subgoals = 0 then p else
   match p.ref with
-    | None -> 
+    | None ->
         let p' = f i p in
         if Evd.eq_evar_info p'.goal p.goal then
 	  begin
 	    !solve_hook p';
 	    p'
 	  end
-        else 
+        else
 	  errorlabstrm "Refiner.frontier_mapi"
             (str"frontier_mapi was handed back a ill-formed proof.")
     | Some(r,pfl) ->
@@ -164,7 +161,7 @@ let rec frontier_mapi_rec f i p =
             (fun (n,acc) p -> (n+p.open_subgoals,frontier_mapi_rec f n p::acc))
             (i,[]) pfl in
         let pfl' = List.rev rpfl' in
-        { p with 
+        { p with
 	    open_subgoals = and_status (List.map pf_status pfl');
             ref = Some(r,pfl')}
 
@@ -179,7 +176,7 @@ let rec nb_unsolved_goals pf = pf.open_subgoals
 
 (* leaf g is the canonical incomplete proof of a goal g *)
 
-let leaf g = 
+let leaf g =
   { open_subgoals = 1;
     goal = g;
     ref = None }
@@ -200,20 +197,20 @@ let abstract_operation syntax semantics gls =
       ref = Some(Nested(syntax,hidden_proof),spfl)})
 
 let abstract_tactic_expr ?(dflt=false) te tacfun gls =
-  abstract_operation (Tactic(te,dflt)) tacfun gls	
+  abstract_operation (Tactic(te,dflt)) tacfun gls
 
 let abstract_tactic ?(dflt=false) te =
   !abstract_tactic_box := Some te;
   abstract_tactic_expr ~dflt (Tacexpr.TacAtom (dummy_loc,te))
 
-let abstract_extended_tactic ?(dflt=false) s args = 
+let abstract_extended_tactic ?(dflt=false) s args =
   abstract_tactic ~dflt (Tacexpr.TacExtend (dummy_loc, s, args))
 
 let refiner = function
   | Prim pr as r ->
       let prim_fun = prim_refiner pr in
 	(fun goal_sigma ->
-          let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in 
+          let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in
 	    ({it=sgl; sigma = sigma'},
             (fun spfl ->
 	      assert (check_subproof_connection sgl spfl);
@@ -222,15 +219,15 @@ let refiner = function
 		ref = Some(r,spfl) })))
 
 
-  | Nested (_,_) | Decl_proof _ -> 
+  | Nested (_,_) | Decl_proof _ ->
       failwith "Refiner: should not occur"
-      
+
 	(* Daimon is a canonical unfinished proof *)
 
-  | Daimon -> 
-      fun gls -> 
-	({it=[];sigma=gls.sigma},  
-	 fun spfl -> 
+  | Daimon ->
+      fun gls ->
+	({it=[];sigma=gls.sigma},
+	 fun spfl ->
 	   assert (spfl=[]);
 	   { open_subgoals = 0;
              goal = gls.it;
@@ -253,10 +250,10 @@ let norm_evar_proof sigma pf =
    Their proof should be completed in order to complete the initial proof *)
 
 let extract_open_proof sigma pf =
-  let next_meta = 
+  let next_meta =
     let meta_cnt = ref 0 in
     let rec f () =
-      incr meta_cnt; 
+      incr meta_cnt;
       if Evd.mem sigma (existential_of_int !meta_cnt) then f ()
       else !meta_cnt
     in f
@@ -264,14 +261,14 @@ let extract_open_proof sigma pf =
   let open_obligations = ref [] in
   let rec proof_extractor vl = function
     | {ref=Some(Prim _,_)} as pf -> prim_extractor proof_extractor vl pf
-	  
+
     | {ref=Some(Nested(_,hidden_proof),spfl)} ->
 	let sgl,v = frontier hidden_proof in
 	let flat_proof = v spfl in
 	proof_extractor vl flat_proof
- 
+
     | {ref=Some(Decl_proof _,[pf])} -> (proof_extractor vl) pf
-	  
+
     | {ref=(None|Some(Daimon,[]));goal=goal} ->
 	let visible_rels =
           map_succeed
@@ -290,13 +287,13 @@ let extract_open_proof sigma pf =
         let inst = List.filter (fun (_,(_,b,_)) -> b = None) sorted_env in
         let meta = next_meta () in
 	open_obligations := (meta,abs_concl):: !open_obligations;
-	applist (mkMeta meta, List.map (fun (n,_) -> mkRel n) inst) 
-	  
+	applist (mkMeta meta, List.map (fun (n,_) -> mkRel n) inst)
+
     | _ -> anomaly "Bug: a case has been forgotten in proof_extractor"
   in
   let pfterm = proof_extractor [] pf in
   (pfterm, List.rev !open_obligations)
-  
+
 (*********************)
 (*   Tacticals       *)
 (*********************)
@@ -304,7 +301,7 @@ let extract_open_proof sigma pf =
 (* unTAC : tactic -> goal sigma -> proof sigma *)
 
 let unTAC tac g =
-  let (gl_sigma,v) = tac g in 
+  let (gl_sigma,v) = tac g in
   { it = v (List.map leaf gl_sigma.it); sigma = gl_sigma.sigma }
 
 let unpackage glsig = (ref (glsig.sigma)),glsig.it
@@ -312,8 +309,8 @@ let unpackage glsig = (ref (glsig.sigma)),glsig.it
 let repackage r v = {it=v;sigma = !r}
 
 let apply_sig_tac r tac g =
-  check_for_interrupt (); (* Breakpoint *) 
-  let glsigma,v = tac (repackage r g) in 
+  check_for_interrupt (); (* Breakpoint *)
+  let glsigma,v = tac (repackage r g) in
   r := glsigma.sigma;
   (glsigma.it,v)
 
@@ -331,17 +328,19 @@ let tclNORMEVAR = norm_evar_tac
 let tclIDTAC gls = (goal_goal_list gls, idtac_valid)
 
 (* the message printing identity tactic *)
-let tclIDTAC_MESSAGE s gls = 
+let tclIDTAC_MESSAGE s gls =
   msg (hov 0 s); tclIDTAC gls
 
 (* General failure tactic *)
 let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s)
 
 (* A special exception for levels for the Fail tactic *)
-exception FailError of int * std_ppcmds
+exception FailError of int * std_ppcmds Lazy.t
 
 (* The Fail tactic *)
-let tclFAIL lvl s g = raise (FailError (lvl,s))
+let tclFAIL lvl s g = raise (FailError (lvl,lazy s))
+
+let tclFAIL_lazy lvl s g = raise (FailError (lvl,s))
 
 let start_tac gls =
   let (sigr,g) = unpackage gls in
@@ -357,7 +356,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs,p) =
   if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
   let gll,pl =
     List.split
-      (list_map_i (fun i -> 
+      (list_map_i (fun i ->
         apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac))
 	0 gs) in
   (sigr, List.flatten gll,
@@ -391,7 +390,7 @@ let theni_tac i tac ((_,gl,_) as subgoals) =
     thensf_tac
       (Array.init k (fun i -> if i+1 = k then tac else tclIDTAC)) tclIDTAC
       subgoals
-  else non_existent_goal k 
+  else non_existent_goal k
 
 (* [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls]
    applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to
@@ -448,21 +447,22 @@ let rec tclTHENLIST = function
     [] -> tclIDTAC
   | t1::tacl -> tclTHEN t1 (tclTHENLIST tacl)
 
-
-
+(* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+let tclMAP tacfun l =
+  List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC
 
 (* various progress criterions *)
-let same_goal gl subgoal = 
+let same_goal gl subgoal =
   eq_constr (conclusion subgoal) (conclusion gl) &&
   eq_named_context_val (hypotheses subgoal) (hypotheses gl)
 
 
 let weak_progress gls ptree =
-  (List.length gls.it <> 1) || 
+  (List.length gls.it <> 1) ||
   (not (same_goal (List.hd gls.it) ptree.it))
 
 let progress gls ptree =
-  (not (eq_evar_map ptree.sigma gls.sigma)) ||
+  (progress_evar_map ptree.sigma gls.sigma) ||
   (weak_progress gls ptree)
 
 
@@ -473,7 +473,7 @@ let tclPROGRESS tac ptree =
   if progress (fst rslt) ptree then rslt
   else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.")
 
-(* weak_PROGRESS tac ptree applies tac to the goal ptree and fails 
+(* weak_PROGRESS tac ptree applies tac to the goal ptree and fails
    if tac leaves the goal unchanged, possibly modifying sigma *)
 let tclWEAK_PROGRESS tac ptree =
   let rslt = tac ptree in
@@ -487,14 +487,14 @@ let tclNOTSAMEGOAL (tac : tactic) goal =
   let rslt = tac goal in
   let gls = (fst rslt).it in
   if List.exists (same_goal goal.it) gls
-  then errorlabstrm "Refiner.tclNOTSAMEGOAL" 
+  then errorlabstrm "Refiner.tclNOTSAMEGOAL"
       (str"Tactic generated a subgoal identical to the original goal.")
   else rslt
 
 let catch_failerror e =
   if catchable_exception e then check_for_interrupt ()
   else match e with
-  | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_)) 
+  | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_))
   | Stdpp.Exc_located(_, LtacLocated (_,FailError (0,_)))  ->
       check_for_interrupt ()
   | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
@@ -507,18 +507,18 @@ let catch_failerror e =
 
 (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *)
 let tclORELSE0 t1 t2 g =
-  try 
+  try
     t1 g
   with (* Breakpoint *)
     | e -> catch_failerror e; t2 g
 
-(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, 
+(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress,
    then applies t2 *)
 let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2
 
 (* applies t1;t2then if t1 succeeds or t2else if t1 fails
    t2* are called in terminal position (unless t1 produces more than
-   1 subgoal!) *) 
+   1 subgoal!) *)
 let tclORELSE_THEN t1 t2then t2else gls =
   match
     try Some(tclPROGRESS t1 gls)
@@ -526,7 +526,7 @@ let tclORELSE_THEN t1 t2then t2else gls =
   with
     | None -> t2else gls
     | Some (sgl,v) ->
-        let (sigr,gl) = unpackage sgl in 
+        let (sigr,gl) = unpackage sgl in
         finish_tac (then_tac t2then  (sigr,gl,v))
 
 (* TRY f tries to apply f, and if it fails, leave the goal unchanged *)
@@ -546,16 +546,16 @@ let ite_gen tcal tac_if continue tac_else gl=
     let result=tac_if gl in
       success:=true;result in
   let tac_else0 e gl=
-    if !success then 
-      raise e 
-    else 
+    if !success then
+      raise e
+    else
       tac_else gl in
-    try 
+    try
       tcal tac_if0 continue gl
     with (* Breakpoint *)
       | e -> catch_failerror e; tac_else0 e gl
 
-(* Try the first tactic and, if it succeeds, continue with 
+(* Try the first tactic and, if it succeeds, continue with
    the second one, and if it fails, use the third one *)
 
 let tclIFTHENELSE=ite_gen tclTHEN
@@ -566,7 +566,7 @@ let tclIFTHENSELSE=ite_gen tclTHENS
 
 let tclIFTHENSVELSE=ite_gen tclTHENSV
 
-let tclIFTHENTRYELSEMUST tac1 tac2 gl = 
+let tclIFTHENTRYELSEMUST tac1 tac2 gl =
   tclIFTHENELSE tac1 (tclTRY tac2) tac2 gl
 
 (* Fails if a tactic did not solve the goal *)
@@ -575,17 +575,17 @@ let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.")
 (* Try the first thats solves the current goal *)
 let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl)
 
-			   
+
 (* Iteration tacticals *)
 
-let tclDO n t = 
-  let rec dorec k = 
+let tclDO n t =
+  let rec dorec k =
     if k < 0 then errorlabstrm "Refiner.tclDO"
       (str"Wrong argument : Do needs a positive integer.");
     if k = 0 then tclIDTAC
     else if k = 1 then t else (tclTHEN t (dorec (k-1)))
-  in 
-  dorec n 
+  in
+  dorec n
 
 
 (* Beware: call by need of CAML, g is needed *)
@@ -612,52 +612,52 @@ let tclIDTAC_list gls = (gls, fun x -> x)
 
 (* first_goal : goal list sigma -> goal sigma *)
 
-let first_goal gls = 
-  let gl = gls.it and sig_0 = gls.sigma in 
-  if gl = [] then error "first_goal"; 
+let first_goal gls =
+  let gl = gls.it and sig_0 = gls.sigma in
+  if gl = [] then error "first_goal";
   { it = List.hd gl; sigma = sig_0 }
 
 (* goal_goal_list : goal sigma -> goal list sigma *)
 
-let goal_goal_list gls = 
+let goal_goal_list gls =
   let gl = gls.it and sig_0 = gls.sigma in { it = [gl]; sigma = sig_0 }
 
 (* tactic -> tactic_list : Apply a tactic to the first goal in the list *)
 
-let apply_tac_list tac glls = 
+let apply_tac_list tac glls =
   let (sigr,lg) = unpackage glls in
   match lg with
   | (g1::rest) ->
       let (gl,p) = apply_sig_tac sigr tac g1 in
-      let n = List.length gl in 
-      (repackage sigr (gl@rest), 
+      let n = List.length gl in
+      (repackage sigr (gl@rest),
        fun pfl -> let (pfg,pfrest) = list_chop n pfl in (p pfg)::pfrest)
   | _ -> error "apply_tac_list"
-	  
-let then_tactic_list tacl1 tacl2 glls = 
+
+let then_tactic_list tacl1 tacl2 glls =
   let (glls1,pl1) = tacl1 glls in
   let (glls2,pl2) = tacl2 glls1 in
   (glls2, compose pl1 pl2)
 
 (* Transform a tactic_list into a tactic *)
 
-let tactic_list_tactic tac gls = 
+let tactic_list_tactic tac gls =
     let (glres,vl) = tac (goal_goal_list gls) in
     (glres, compose idtac_valid vl)
 
 
 
-(* The type of proof-trees state and a few utilities 
+(* The type of proof-trees state and a few utilities
    A proof-tree state is built from a proof-tree, a set of global
    constraints, and a stack which allows to navigate inside the
    proof-tree remembering how to rebuild the global proof-tree
    possibly after modification of one of the focused children proof-tree.
-   The number in the stack corresponds to 
+   The number in the stack corresponds to
    either the selected subtree and the validation is a function from a
    proof-tree list consisting only of one proof-tree to the global
-   proof-tree 
+   proof-tree
    or -1 when the move is done behind a registered tactic in which
-   case the validation corresponds to a constant function giving back 
+   case the validation corresponds to a constant function giving back
    the original proof-tree. *)
 
 type pftreestate = {
@@ -666,11 +666,11 @@ type pftreestate = {
   tstack   : (int * validation) list }
 
 let proof_of_pftreestate pts = pts.tpf
-let is_top_pftreestate pts = pts.tstack = [] 
+let is_top_pftreestate pts = pts.tstack = []
 let cursor_of_pftreestate pts = List.map fst pts.tstack
 let evc_of_pftreestate pts = pts.tpfsigma
 
-let top_goal_of_pftreestate pts = 
+let top_goal_of_pftreestate pts =
   { it = goal_of_proof pts.tpf; sigma = pts.tpfsigma }
 
 let nth_goal_of_pftreestate n pts =
@@ -678,7 +678,7 @@ let nth_goal_of_pftreestate n pts =
   try {it = List.nth goals (n-1); sigma = pts.tpfsigma }
   with Invalid_argument _ | Failure _ -> non_existent_goal n
 
-let traverse n pts = match n with 
+let traverse n pts = match n with
   | 0 -> (* go to the parent *)
       (match  pts.tstack with
 	 | [] -> error "traverse: no ancestors"
@@ -691,13 +691,13 @@ let traverse n pts = match n with
   | -1 -> (* go to the hidden tactic-proof, if any, otherwise fail *)
       (match pts.tpf.ref with
 	 | Some (Nested (_,spf),_) ->
-	     let v = (fun pfl -> pts.tpf) in 
+	     let v = (fun pfl -> pts.tpf) in
 	     { tpf = spf;
                tstack = (-1,v)::pts.tstack;
                tpfsigma = pts.tpfsigma }
 	 | _ -> error "traverse: not a tactic-node")
   | n -> (* when n>0, go to the nth child *)
-      let (npf,v) = descend n pts.tpf in 
+      let (npf,v) = descend n pts.tpf in
       { tpf = npf;
         tpfsigma = pts.tpfsigma;
         tstack = (n,v):: pts.tstack }
@@ -723,9 +723,9 @@ let map_pftreestate f pts =
 (* solve the nth subgoal with tactic tac *)
 
 let solve_nth_pftreestate n tac =
-  map_pftreestate 
+  map_pftreestate
     (fun sigr pt -> frontier_map (app_tac sigr tac) n pt)
- 
+
 let solve_pftreestate = solve_nth_pftreestate 1
 
 (* This function implements a poor man's undo at the current goal.
@@ -771,78 +771,78 @@ let extract_pftreestate pts =
 (* Focus on the first leaf proof in a proof-tree state *)
 
 let rec first_unproven pts =
-  let pf = (proof_of_pftreestate pts) in 
+  let pf = (proof_of_pftreestate pts) in
   if is_complete_proof pf then
     errorlabstrm "first_unproven" (str"No unproven subgoals");
   if is_leaf_proof pf then
     pts
   else
     let childnum =
-      list_try_find_i 
-	(fun n pf -> 
+      list_try_find_i
+	(fun n pf ->
 	   if not(is_complete_proof pf) then n else failwith "caught")
 	1 (children_of_proof pf)
-    in 
+    in
     first_unproven (traverse childnum pts)
 
 (* Focus on the last leaf proof in a proof-tree state *)
 
 let rec last_unproven pts =
-  let pf = proof_of_pftreestate pts in 
+  let pf = proof_of_pftreestate pts in
   if is_complete_proof pf then
     errorlabstrm "last_unproven" (str"No unproven subgoals");
   if is_leaf_proof pf then
     pts
-  else 
+  else
     let children = (children_of_proof pf) in
     let nchilds = List.length children in
     let childnum =
-      list_try_find_i 
+      list_try_find_i
         (fun n pf ->
            if not(is_complete_proof pf) then n else failwith "caught")
         1 (List.rev children)
-    in 
+    in
     last_unproven (traverse (nchilds-childnum+1) pts)
-      
+
 let rec nth_unproven n pts =
-  let pf = proof_of_pftreestate pts in 
+  let pf = proof_of_pftreestate pts in
   if is_complete_proof pf then
     errorlabstrm "nth_unproven" (str"No unproven subgoals");
   if is_leaf_proof pf then
-    if n = 1 then 
-      pts 
+    if n = 1 then
+      pts
     else
       errorlabstrm "nth_unproven" (str"Not enough unproven subgoals")
-  else 
+  else
     let children = children_of_proof pf in
     let rec process i k = function
-      | [] -> 
+      | [] ->
 	  errorlabstrm "nth_unproven" (str"Not enough unproven subgoals")
-      | pf1::rest -> 
-	  let k1 = nb_unsolved_goals pf1 in 
-	  if k1 < k then 
+      | pf1::rest ->
+	  let k1 = nb_unsolved_goals pf1 in
+	  if k1 < k then
 	    process (i+1) (k-k1) rest
-	  else 
+	  else
 	    nth_unproven k (traverse i pts)
-    in 
+    in
     process 1 n children
 
 let rec node_prev_unproven loc pts =
-  let pf = proof_of_pftreestate pts in 
+  let pf = proof_of_pftreestate pts in
   match cursor_of_pftreestate pts with
     | [] -> last_unproven pts
     | n::l ->
 	if is_complete_proof pf or loc = 1 then
           node_prev_unproven n (traverse 0 pts)
-	else 
+	else
 	  let child = List.nth (children_of_proof pf) (loc - 2) in
 	  if is_complete_proof child then
 	    node_prev_unproven (loc - 1) pts
-	  else 
+	  else
 	    first_unproven (traverse (loc - 1) pts)
 
 let rec node_next_unproven loc pts =
-  let pf = proof_of_pftreestate pts in 
+  let pf = proof_of_pftreestate pts in
   match cursor_of_pftreestate pts with
     | [] -> first_unproven pts
     | n::l ->
@@ -851,35 +851,35 @@ let rec node_next_unproven loc pts =
              node_next_unproven n (traverse 0 pts)
 	else if is_complete_proof (List.nth (children_of_proof pf) loc) then
 	  node_next_unproven (loc + 1) pts
-	else 
+	else
 	  last_unproven(traverse (loc + 1) pts)
 
 let next_unproven pts =
-  let pf = proof_of_pftreestate pts in 
+  let pf = proof_of_pftreestate pts in
   if is_leaf_proof pf then
     match cursor_of_pftreestate pts with
       | [] -> error "next_unproven"
       | n::_ -> node_next_unproven n (traverse 0 pts)
-  else 
+  else
     node_next_unproven (List.length (children_of_proof pf)) pts
 
 let prev_unproven pts =
-  let pf = proof_of_pftreestate pts in 
+  let pf = proof_of_pftreestate pts in
   if is_leaf_proof pf then
     match cursor_of_pftreestate pts with
       | [] -> error "prev_unproven"
       | n::_ -> node_prev_unproven n (traverse 0 pts)
-  else 
+  else
     node_prev_unproven 1 pts
 
-let rec top_of_tree pts = 
+let rec top_of_tree pts =
   if is_top_pftreestate pts then pts else top_of_tree(traverse 0 pts)
 
 (* FIXME: cette fonction n'est (as of October 2007) appelée nulle part *)
 let change_rule f pts =
   let mark_top _ pt =
     match pt.ref with
-	Some (oldrule,l) -> 
+	Some (oldrule,l) ->
 	  {pt with ref=Some (f oldrule,l)}
       | _ -> invalid_arg "change_rule" in
     map_pftreestate mark_top pts
@@ -889,21 +889,21 @@ let match_rule p pts =
       Some (r,_) -> p r
     | None -> false
 
-let rec up_until_matching_rule p pts = 
-  if is_top_pftreestate pts then 
+let rec up_until_matching_rule p pts =
+  if is_top_pftreestate pts then
     raise Not_found
   else
     let one_up = traverse 0 pts in
-      if match_rule p one_up then 
+      if match_rule p one_up then
 	pts
       else
 	up_until_matching_rule p one_up
 
-let rec up_to_matching_rule p pts = 
-  if match_rule p pts then 
+let rec up_to_matching_rule p pts =
+  if match_rule p pts then
     pts
   else
-    if is_top_pftreestate pts then 
+    if is_top_pftreestate pts then
       raise Not_found
     else
       let one_up = traverse 0 pts in
@@ -917,14 +917,50 @@ let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma}
 let pp_info = ref (fun _ _ _ -> assert false)
 let set_info_printer f = pp_info := f
 
-let tclINFO (tac : tactic) gls = 
-  let (sgl,v) as res = tac gls in 
-  begin try 
+let tclINFO (tac : tactic) gls =
+  let (sgl,v) as res = tac gls in
+  begin try
     let pf = v (List.map leaf (sig_it sgl)) in
     let sign = named_context_of_val (sig_it gls).evar_hyps in
     msgnl (hov 0 (str" == " ++
                   !pp_info (project gls) sign pf))
-  with e when catchable_exception e -> 
+  with e when catchable_exception e ->
     msgnl (hov 0 (str "Info failed to apply validation"))
   end;
   res
+
+let pp_proof = ref (fun _ _ _ -> assert false)
+let set_proof_printer f = pp_proof := f
+
+let print_pftreestate {tpf = pf; tpfsigma = sigma; tstack = stack } =
+  (if stack = []
+   then str "Rooted proof tree is:"
+   else (str "Proof tree at occurrence [" ++
+         prlist_with_sep (fun () -> str ";") (fun (n,_) -> int n)
+           (List.rev stack) ++ str "] is:")) ++ fnl() ++
+  !pp_proof sigma (Global.named_context()) pf ++
+  Evd.pr_evar_map sigma
+
+(* Check that holes in arguments have been resolved *)
+
+let check_evars env sigma evm gl =
+  let origsigma = gl.sigma in
+  let rest =
+    Evd.fold (fun ev evi acc ->
+      if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev)
+      then Evd.add acc ev evi else acc)
+      evm Evd.empty
+  in
+  if rest <> Evd.empty then
+    let (evk,evi) = List.hd (Evd.to_list rest) in
+    let (loc,k) = evar_source evk rest in
+    let evi = Evarutil.nf_evar_info sigma evi in
+    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None
+
+let tclWITHHOLES accept_unresolved_holes tac sigma c gl =
+  if sigma == project gl then tac c gl
+  else
+    let res = tclTHEN (tclEVARS sigma) (tac c) gl in
+    if not accept_unresolved_holes then
+      check_evars (pf_env gl) (fst res).sigma sigma gl;
+    res
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index a6ba3af5..e853c12b 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: refiner.mli 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -80,6 +80,9 @@ val tclTHEN          : tactic -> tactic -> tactic
    convenient than [tclTHEN] when [n] is large *)
 val tclTHENLIST      : tactic list -> tactic
 
+(* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+val tclMAP           : ('a -> tactic) -> 'a list -> tactic
+
 (* [tclTHEN_i tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
    [(tac2 i)] to the [i]$^{th}$ resulting subgoal (starting from 1) *)
 val tclTHEN_i        : tactic -> (int -> tactic) -> tactic
@@ -131,7 +134,7 @@ val tclTHENLASTn    : tactic -> tactic array -> tactic
 val tclTHENFIRSTn   : tactic -> tactic array -> tactic
 
 (* A special exception for levels for the Fail tactic *)
-exception FailError of int * Pp.std_ppcmds
+exception FailError of int * Pp.std_ppcmds Lazy.t
 
 (* Takes an exception and either raise it at the next
    level or do nothing. *)
@@ -148,6 +151,7 @@ val tclTHENTRY       : tactic -> tactic -> tactic
 val tclCOMPLETE      : tactic -> tactic
 val tclAT_LEAST_ONCE : tactic -> tactic
 val tclFAIL          : int -> Pp.std_ppcmds -> tactic
+val tclFAIL_lazy     : int -> Pp.std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
@@ -155,14 +159,14 @@ val tclNOTSAMEGOAL   : tactic -> tactic
 val tclINFO          : tactic -> tactic
 
 (* [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then,
-   if it succeeds, applies [tac2] to the resulting subgoals, 
+   if it succeeds, applies [tac2] to the resulting subgoals,
    and if not applies [tac3] to the initial goal [gls] *)
 val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
 val tclIFTHENSELSE   : tactic -> tactic list -> tactic ->tactic
 val tclIFTHENSVELSE   : tactic -> tactic array -> tactic ->tactic
 
 (* [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1]
-   has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. 
+   has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed.
    Equivalent to [(tac1;try tac2)||tac2] *)
 
 val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
@@ -181,6 +185,11 @@ val then_tactic_list   : tactic_list -> tactic_list -> tactic_list
 val tactic_list_tactic : tactic_list -> tactic
 val goal_goal_list     : 'a sigma -> 'a list sigma
 
+(* [tclWITHHOLES solve_holes tac (sigma,c)] applies [tac] to [c] which
+   may have unresolved holes; if [solve_holes] these holes must be
+   resolved after application of the tactic; [sigma] must be an
+   extension of the sigma of the goal *)
+val tclWITHHOLES : bool -> ('a -> tactic) -> evar_map -> 'a -> tactic
 
 (*s Functions for handling the state of the proof editor. *)
 
@@ -195,7 +204,7 @@ val top_goal_of_pftreestate : pftreestate -> goal sigma
 val nth_goal_of_pftreestate : int -> pftreestate -> goal sigma
 
 val traverse : int -> pftreestate -> pftreestate
-val map_pftreestate : 
+val map_pftreestate :
   (evar_map ref -> proof_tree -> proof_tree) -> pftreestate -> pftreestate
 val solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate
 val solve_pftreestate : tactic -> pftreestate -> pftreestate
@@ -206,7 +215,7 @@ val weak_undo_pftreestate : pftreestate -> pftreestate
 
 val mk_pftreestate : goal -> pftreestate
 val extract_open_proof : evar_map -> proof_tree -> constr * (int * types) list
-val extract_open_pftreestate : pftreestate -> constr * Termops.metamap
+val extract_open_pftreestate : pftreestate -> constr * Termops.meta_type_map
 val extract_pftreestate : pftreestate -> constr
 val first_unproven : pftreestate -> pftreestate
 val last_unproven : pftreestate -> pftreestate
@@ -217,12 +226,12 @@ val next_unproven : pftreestate -> pftreestate
 val prev_unproven : pftreestate -> pftreestate
 val top_of_tree : pftreestate -> pftreestate
 val match_rule : (rule -> bool) -> pftreestate -> bool
-val up_until_matching_rule : (rule -> bool) -> 
+val up_until_matching_rule : (rule -> bool) ->
   pftreestate -> pftreestate
-val up_to_matching_rule : (rule -> bool) -> 
+val up_to_matching_rule : (rule -> bool) ->
   pftreestate -> pftreestate
 val change_rule : (rule -> rule) -> pftreestate -> pftreestate
-val change_constraints_pftreestate 
+val change_constraints_pftreestate
   : evar_map -> pftreestate -> pftreestate
 
 
@@ -233,3 +242,6 @@ open Pp
 (*i*)
 val set_info_printer :
   (evar_map -> named_context -> proof_tree -> Pp.std_ppcmds) -> unit
+val set_proof_printer :
+  (evar_map -> named_context -> proof_tree -> Pp.std_ppcmds) -> unit
+val print_pftreestate : pftreestate -> Pp.std_ppcmds
diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml
index 66136afa..b56e5184 100644
--- a/proofs/tacexpr.ml
+++ b/proofs/tacexpr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacexpr.ml 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Names
 open Topconstr
@@ -51,12 +51,12 @@ let make_red_flag =
 	if red.rConst <> [] & not red.rDelta then
 	  error
 	    "Cannot set both constants to unfold and constants not to unfold";
-        add_flag 
+        add_flag
 	  { red with rConst = list_union red.rConst l; rDelta = true }
 	  lf
   in
   add_flag
-    {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []} 
+    {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []}
 
 type 'a raw_hyp_location = 'a with_occurrences * Termops.hyp_location_flag
 
@@ -85,7 +85,7 @@ type inversion_kind =
   | FullInversionClear
 
 type ('c,'id) inversion_strength =
-  | NonDepInversion of 
+  | NonDepInversion of
       inversion_kind * 'id list * intro_pattern_expr located option
   | DepInversion of
       inversion_kind * 'c option * intro_pattern_expr located option
@@ -98,30 +98,31 @@ type 'id message_token =
   | MsgInt of int
   | MsgIdent of 'id
 
-type 'id gsimple_clause = ('id raw_hyp_location) option
 (* onhyps:
      [None] means *on every hypothesis*
      [Some l] means on hypothesis belonging to l *)
 type 'id gclause =
   { onhyps : 'id raw_hyp_location list option;
-    concl_occs : bool * int or_var list }
+    concl_occs : occurrences_expr }
 
 let nowhere = {onhyps=Some[]; concl_occs=no_occurrences_expr}
 
-let simple_clause_of = function
+let goal_location_of = function
 | { onhyps = Some [scl]; concl_occs = occs } when occs = no_occurrences_expr ->
       Some scl
 | { onhyps = Some []; concl_occs = occs } when occs = all_occurrences_expr ->
     None
 | _ ->
-    error "not a simple clause (one hypothesis or conclusion)"
+    error "Not a simple \"in\" clause (one hypothesis or the conclusion)"
 
-type ('constr,'id) induction_clause = 
-    ('constr with_bindings induction_arg list * 'constr with_bindings option * 
-     (intro_pattern_expr located option * intro_pattern_expr located option) *
-     'id gclause option)
+type 'constr induction_clause =
+  ('constr with_bindings induction_arg list * 'constr with_bindings option *
+   (intro_pattern_expr located option * intro_pattern_expr located option))
 
-type multi = 
+type ('constr,'id) induction_clause_list =
+    'constr induction_clause list * 'id gclause option
+
+type multi =
   | Precisely of int
   | UpTo of int
   | RepeatStar
@@ -142,7 +143,7 @@ type ('a,'t) match_rule =
   | Pat of 'a match_context_hyps list * 'a match_pattern * 't
   | All of 't
 
-type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
+type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr =
   (* Basic tactics *)
   | TacIntroPattern of intro_pattern_expr located list
   | TacIntrosUntil of quantified_hypothesis
@@ -151,15 +152,15 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   | TacExact of 'constr
   | TacExactNoCheck of 'constr
   | TacVmCastNoCheck of 'constr
-  | TacApply of advanced_flag * evars_flag * 'constr with_bindings list * 
+  | TacApply of advanced_flag * evars_flag * 'constr with_bindings list *
       ('id * intro_pattern_expr located option) option
-  | TacElim of evars_flag * 'constr with_bindings * 
+  | TacElim of evars_flag * 'constr with_bindings *
       'constr with_bindings option
   | TacElimType of 'constr
   | TacCase of evars_flag * 'constr with_bindings
   | TacCaseType of 'constr
   | TacFix of identifier option * int
-  | TacMutualFix of hidden_flag * identifier * int * (identifier * int * 
+  | TacMutualFix of hidden_flag * identifier * int * (identifier * int *
       'constr) list
   | TacCofix of identifier option
   | TacMutualCofix of hidden_flag * identifier * (identifier * 'constr) list
@@ -171,7 +172,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct of rec_flag * quantified_hypothesis
-  | TacInductionDestruct of rec_flag * evars_flag * ('constr,'id) induction_clause list
+  | TacInductionDestruct of rec_flag * evars_flag * ('constr,'id) induction_clause_list
   | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis
   | TacDecomposeAnd of 'constr
   | TacDecomposeOr of 'constr
@@ -198,86 +199,87 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   (* Constructors *)
   | TacLeft of evars_flag * 'constr bindings
   | TacRight of evars_flag * 'constr bindings
-  | TacSplit of evars_flag * split_flag * 'constr bindings
+  | TacSplit of evars_flag * split_flag * 'constr bindings list
   | TacAnyConstructor of evars_flag * 'tac option
   | TacConstructor of evars_flag * int or_metaid * 'constr bindings
 
   (* Conversion *)
-  | TacReduce of ('constr,'cst) red_expr_gen * 'id gclause
-  | TacChange of 'constr with_occurrences option * 'constr * 'id gclause
+  | TacReduce of ('constr,'cst,'pat) red_expr_gen * 'id gclause
+  | TacChange of 'pat option * 'constr * 'id gclause
 
   (* Equivalence relations *)
   | TacReflexivity
   | TacSymmetry of 'id gclause
-  | TacTransitivity of 'constr 
+  | TacTransitivity of 'constr option
 
   (* Equality and inversion *)
-  | TacRewrite of 
+  | TacRewrite of
       evars_flag * (bool * multi * 'constr with_bindings) list * 'id gclause * 'tac option
   | TacInversion of ('constr,'id) inversion_strength * quantified_hypothesis
-      
+
   (* For ML extensions *)
-  | TacExtend of loc * string * 'constr generic_argument list
+  | TacExtend of loc * string * 'lev generic_argument list
 
   (* For syntax extensions *)
   | TacAlias of loc * string *
-      (identifier * 'constr generic_argument) list
+      (identifier * 'lev generic_argument) list
       * (dir_path * glob_tactic_expr)
 
-and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr =
-  | TacAtom of loc * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr
-  | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * 
-	('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr array *
-	('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr *
-	('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr array
-  | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * 
-	('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list
-  | TacFirst of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list
-  | TacComplete of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacSolve of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list
-  | TacTry of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacOrelse of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacDo of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacRepeat of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacProgress of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacAbstract of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * identifier option
+and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr =
+  | TacAtom of loc * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr
+  | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr *
+	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr array *
+	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr *
+	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr array
+  | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr *
+	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list
+  | TacFirst of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list
+  | TacComplete of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacSolve of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list
+  | TacTry of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacOrelse of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacDo of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacRepeat of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacProgress of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacAbstract of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * identifier option
   | TacId of 'id message_token list
   | TacFail of int or_var * 'id message_token list
-  | TacInfo of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacLetIn of rec_flag * (identifier located * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg) list * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacMatch of lazy_flag * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr) match_rule list
-  | TacMatchGoal of lazy_flag * direction_flag * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr) match_rule list
-  | TacFun of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_fun_ast
-  | TacArg of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg
+  | TacInfo of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacLetIn of rec_flag * (identifier located * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg) list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
+  | TacMatch of lazy_flag * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr) match_rule list
+  | TacMatchGoal of lazy_flag * direction_flag * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr) match_rule list
+  | TacFun of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast
+  | TacArg of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg
 
-and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_fun_ast =
-  identifier option list * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
+and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast =
+  identifier option list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
 
   (* These are the possible arguments of a tactic definition *)
-and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg =
+and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg =
   | TacDynamic     of loc * Dyn.t
   | TacVoid
   | MetaIdArg      of loc * bool * string
-  | ConstrMayEval  of ('constr,'cst) may_eval
+  | ConstrMayEval  of ('constr,'cst,'pat) may_eval
   | IntroPattern   of intro_pattern_expr located
   | Reference      of 'ref
   | Integer        of int
   | TacCall        of loc *
-      'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list
-  | TacExternal of loc * string * string * 
-      ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list
+      'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg list
+  | TacExternal of loc * string * string *
+      ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg list
   | TacFreshId     of string or_var list
   | Tacexp of 'tac
 
 (* Globalized tactics *)
 and glob_tactic_expr =
     (rawconstr_and_expr,
-     constr_pattern,
+     rawconstr_and_expr * constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
      ltac_constant located or_var,
      identifier located,
-     glob_tactic_expr) gen_tactic_expr
+     glob_tactic_expr,
+     glevel) gen_tactic_expr
 
 type raw_tactic_expr =
     (constr_expr,
@@ -286,7 +288,8 @@ type raw_tactic_expr =
      reference or_by_notation,
      reference,
      identifier located or_metaid,
-     raw_tactic_expr) gen_tactic_expr
+     raw_tactic_expr,
+     rlevel) gen_tactic_expr
 
 type raw_atomic_tactic_expr =
     (constr_expr,                  (* constr *)
@@ -295,7 +298,8 @@ type raw_atomic_tactic_expr =
      reference or_by_notation,     (* inductive *)
      reference,                    (* ltac reference *)
      identifier located or_metaid, (* identifier *)
-     raw_tactic_expr) gen_atomic_tactic_expr
+     raw_tactic_expr,
+     rlevel) gen_atomic_tactic_expr
 
 type raw_tactic_arg =
     (constr_expr,
@@ -304,36 +308,41 @@ type raw_tactic_arg =
      reference or_by_notation,
      reference,
      identifier located or_metaid,
-     raw_tactic_expr) gen_tactic_arg
+     raw_tactic_expr,
+     rlevel) gen_tactic_arg
 
-type raw_generic_argument = constr_expr generic_argument
+type raw_generic_argument = rlevel generic_argument
 
-type raw_red_expr = (constr_expr, reference or_by_notation) red_expr_gen
+type raw_red_expr =
+    (constr_expr, reference or_by_notation, constr_expr) red_expr_gen
 
 type glob_atomic_tactic_expr =
     (rawconstr_and_expr,
-     constr_pattern,
+     rawconstr_and_expr * constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
      ltac_constant located or_var,
      identifier located,
-     glob_tactic_expr) gen_atomic_tactic_expr
+     glob_tactic_expr,
+     glevel) gen_atomic_tactic_expr
 
 type glob_tactic_arg =
     (rawconstr_and_expr,
-     constr_pattern,
+     rawconstr_and_expr * constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
      ltac_constant located or_var,
      identifier located,
-     glob_tactic_expr) gen_tactic_arg
+     glob_tactic_expr,
+     glevel) gen_tactic_arg
 
-type glob_generic_argument = rawconstr_and_expr generic_argument
+type glob_generic_argument = glevel generic_argument
 
 type glob_red_expr =
-    (rawconstr_and_expr, evaluable_global_reference or_var) red_expr_gen
+    (rawconstr_and_expr, evaluable_global_reference or_var, constr_pattern)
+    red_expr_gen
 
-type typed_generic_argument = Evd.open_constr generic_argument
+type typed_generic_argument = tlevel generic_argument
 
 type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type
 
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index b740baa8..9e35abfc 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacmach.ml 12168 2009-06-06 21:34:37Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Names
-open Nameops
+open Namegen
 open Sign
 open Term
 open Termops
@@ -55,10 +55,10 @@ let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id
 
 let pf_last_hyp gl = List.hd (pf_hyps gl)
 
-let pf_get_hyp gls id = 
-  try 
+let pf_get_hyp gls id =
+  try
     Sign.lookup_named id (pf_hyps gls)
-  with Not_found -> 
+  with Not_found ->
     error ("No such hypothesis: " ^ (string_of_id id))
 
 let pf_get_hyp_typ gls id =
@@ -67,7 +67,7 @@ let pf_get_hyp_typ gls id =
 
 let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls)
 
-let pf_get_new_id id gls = 
+let pf_get_new_id id gls =
   next_ident_away id (pf_ids_of_hyps gls)
 
 let pf_get_new_ids ids gls =
@@ -77,19 +77,19 @@ let pf_get_new_ids ids gls =
     ids []
 
 let pf_interp_constr gls c =
-  let evc = project gls in 
+  let evc = project gls in
   Constrintern.interp_constr evc (pf_env gls) c
 
 let pf_interp_type gls c =
-  let evc = project gls in 
+  let evc = project gls in
   Constrintern.interp_type evc (pf_env gls) c
 
 let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
 
 let pf_parse_const gls = compose (pf_global gls) id_of_string
 
-let pf_reduction_of_red_expr gls re c = 
-  (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c 
+let pf_reduction_of_red_expr gls re c =
+  (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c
 
 let pf_apply f gls = f (pf_env gls) (project gls)
 let pf_reduce = pf_apply
@@ -98,7 +98,7 @@ let pf_whd_betadeltaiota         = pf_reduce whd_betadeltaiota
 let pf_whd_betadeltaiota_stack   = pf_reduce whd_betadeltaiota_stack
 let pf_hnf_constr                = pf_reduce hnf_constr
 let pf_red_product               = pf_reduce red_product
-let pf_nf                        = pf_reduce nf
+let pf_nf                        = pf_reduce simpl
 let pf_nf_betaiota               = pf_reduce (fun _ -> nf_betaiota)
 let pf_compute                   = pf_reduce compute
 let pf_unfoldn ubinds            = pf_reduce (unfoldn ubinds)
@@ -111,11 +111,14 @@ let pf_const_value              = pf_reduce (fun env _ -> constant_value 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 hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls)
+let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls)
 
-let pf_check_type gls c1 c2 = 
+let pf_check_type gls c1 c2 =
   ignore (pf_type_of gls (mkCast (c1, DEFAULTcast, c2)))
 
+let pf_is_matching              = pf_apply Matching.is_matching_conv
+let pf_matches                  = pf_apply Matching.matches_conv
+
 (************************************)
 (* Tactics handling a list of goals *)
 (************************************)
@@ -176,16 +179,16 @@ let refiner = refiner
 let introduction_no_check id =
   refiner (Prim (Intro id))
 
-let internal_cut_no_check replace id t gl = 
+let internal_cut_no_check replace id t gl =
   refiner (Prim (Cut (true,replace,id,t))) gl
 
-let internal_cut_rev_no_check replace id t gl = 
+let internal_cut_rev_no_check replace id t gl =
   refiner (Prim (Cut (false,replace,id,t))) gl
 
-let refine_no_check c gl = 
+let refine_no_check c gl =
   refiner (Prim (Refine c)) gl
 
-let convert_concl_no_check c sty gl = 
+let convert_concl_no_check c sty gl =
   refiner (Prim (Convert_concl (c,sty))) gl
 
 let convert_hyp_no_check d gl =
@@ -199,31 +202,27 @@ let thin_no_check ids gl =
 let thin_body_no_check ids gl =
   if ids = [] then tclIDTAC gl else refiner (Prim (ThinBody ids)) gl
 
-let move_hyp_no_check with_dep id1 id2 gl = 
+let move_hyp_no_check with_dep id1 id2 gl =
   refiner (Prim (Move (with_dep,id1,id2))) gl
 
 let order_hyps idl gl =
   refiner (Prim (Order idl)) gl
 
-let rec rename_hyp_no_check l gl = match l with 
-  | [] -> tclIDTAC gl 
-  | (id1,id2)::l -> 
-      tclTHEN (refiner (Prim (Rename (id1,id2)))) 
+let rec rename_hyp_no_check l gl = match l with
+  | [] -> tclIDTAC gl
+  | (id1,id2)::l ->
+      tclTHEN (refiner (Prim (Rename (id1,id2))))
 	(rename_hyp_no_check l) gl
 
-let mutual_fix_with_index f n others j gl =
+let mutual_fix f n others j gl =
   with_check (refiner (Prim (FixRule (f,n,others,j)))) gl
 
-let mutual_fix f n others = mutual_fix_with_index f n others 0
-
-let mutual_cofix_with_index f others j gl =
+let mutual_cofix f others j gl =
   with_check (refiner (Prim (Cofix (f,others,j)))) gl
 
-let mutual_cofix f others = mutual_cofix_with_index f others 0
-    
 (* Versions with consistency checks *)
 
-let introduction id    = with_check (introduction_no_check id) 
+let introduction id    = with_check (introduction_no_check id)
 let internal_cut b d t = with_check (internal_cut_no_check b d t)
 let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t)
 let refine c           = with_check (refine_no_check c)
@@ -231,7 +230,7 @@ let convert_concl d sty = with_check (convert_concl_no_check d sty)
 let convert_hyp d      = with_check (convert_hyp_no_check d)
 let thin c             = with_check (thin_no_check c)
 let thin_body c        = with_check (thin_body_no_check c)
-let move_hyp b id id'  = with_check (move_hyp_no_check b id id') 
+let move_hyp b id id'  = with_check (move_hyp_no_check b id id')
 let rename_hyp l       = with_check (rename_hyp_no_check l)
 
 (* Pretty-printers *)
@@ -250,4 +249,4 @@ let pr_gls gls =
 let pr_glls glls =
   hov 0 (pr_evar_map (sig_sig glls) ++ fnl () ++
          prlist_with_sep pr_fnl db_pr_goal (sig_it glls))
-  
+
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 37acf850..a808ca41 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacmach.mli 12168 2009-06-06 21:34:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -21,6 +21,7 @@ open Refiner
 open Redexpr
 open Tacexpr
 open Rawterm
+open Pattern
 (*i*)
 
 (* Operations for handling terms under a local typing context. *)
@@ -51,7 +52,7 @@ val pf_global             : goal sigma -> identifier -> constr
 val pf_parse_const        : goal sigma -> string -> constr
 val pf_type_of            : goal sigma -> constr -> types
 val pf_check_type         : goal sigma -> constr -> types -> unit
-val hnf_type_of           : goal sigma -> constr -> types
+val pf_hnf_type_of        : goal sigma -> constr -> types
 
 val pf_interp_constr      : goal sigma -> Topconstr.constr_expr -> constr
 val pf_interp_type        : goal sigma -> Topconstr.constr_expr -> types
@@ -66,12 +67,12 @@ val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> constr
 
 
 val pf_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a
-val pf_reduce : 
+val pf_reduce :
   (env -> evar_map -> constr -> constr) ->
     goal sigma -> constr -> constr
 
 val pf_whd_betadeltaiota       : goal sigma -> constr -> constr
-val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list 
+val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list
 val pf_hnf_constr              : goal sigma -> constr -> constr
 val pf_red_product             : goal sigma -> constr -> constr
 val pf_nf                      : goal sigma -> constr -> constr
@@ -86,6 +87,9 @@ val pf_const_value : goal sigma -> constant -> constr
 val pf_conv_x      : goal sigma -> constr -> constr -> bool
 val pf_conv_x_leq  : goal sigma -> constr -> constr -> bool
 
+val pf_matches     : goal sigma -> constr_pattern -> constr -> patvar_map
+val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
+
 type transformation_tactic = proof_tree -> (goal list * validation)
 
 val frontier : transformation_tactic
@@ -106,7 +110,7 @@ val weak_undo_pftreestate   : pftreestate -> pftreestate
 val solve_nth_pftreestate   : int -> tactic -> pftreestate -> pftreestate
 val solve_pftreestate       : tactic -> pftreestate -> pftreestate
 val mk_pftreestate          : goal -> pftreestate
-val extract_open_pftreestate : pftreestate -> constr * Termops.metamap
+val extract_open_pftreestate : pftreestate -> constr * Termops.meta_type_map
 val extract_pftreestate     : pftreestate -> constr
 val first_unproven          : pftreestate -> pftreestate
 val last_unproven           : pftreestate -> pftreestate
@@ -135,12 +139,8 @@ val move_hyp_no_check         :
 val rename_hyp_no_check       : (identifier*identifier) list -> tactic
 val order_hyps : identifier list -> tactic
 val mutual_fix      :
-  identifier -> int -> (identifier * int * constr) list -> tactic
-val mutual_cofix    : identifier -> (identifier * constr) list -> tactic
-val mutual_fix_with_index :
   identifier -> int -> (identifier * int * constr) list -> int -> tactic
-val mutual_cofix_with_index : 
-  identifier -> (identifier * constr) list -> int -> tactic
+val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
 
 (*s The most primitive tactics with consistency and type checking *)
 
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
index 7aa57d9b..ea8ab5b6 100644
--- a/proofs/tactic_debug.ml
+++ b/proofs/tactic_debug.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_debug.ml 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Names
 open Constrextern
@@ -68,11 +68,11 @@ let skip = ref 0
 
 (* Prints the run counter *)
 let run ini =
-  if not ini then 
+  if not ini then
     for i=1 to 2 do
       print_char (Char.chr 8);print_char (Char.chr 13)
     done;
-  msg (str "Executed expressions: " ++ int (!allskip - !skip) ++ 
+  msg (str "Executed expressions: " ++ int (!allskip - !skip) ++
        fnl() ++ fnl())
 
 (* Prints the prompt *)
@@ -168,7 +168,7 @@ let db_matching_failure debug =
 let db_eval_failure debug s =
   if debug <> DebugOff & !skip = 0 then
     let s = str "message \"" ++ s ++ str "\"" in
-    msgnl 
+    msgnl
       (str "This rule has failed due to \"Fail\" tactic (" ++
        s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...")
 
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
index 63c89547..0a5e6087 100644
--- a/proofs/tactic_debug.mli
+++ b/proofs/tactic_debug.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_debug.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Environ
 open Pattern
@@ -24,7 +24,7 @@ val set_tactic_printer : (glob_tactic_expr ->Pp.std_ppcmds) -> unit
 val set_match_pattern_printer :
   (env -> constr_pattern match_pattern -> Pp.std_ppcmds) -> unit
 val set_match_rule_printer :
-  ((constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) ->
+  ((Genarg.rawconstr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) ->
     unit
 
 (* Debug information *)
@@ -41,7 +41,7 @@ val db_constr : debug_info -> env -> constr -> unit
 
 (* Prints the pattern rule *)
 val db_pattern_rule :
-  debug_info -> int -> (constr_pattern,glob_tactic_expr) match_rule -> unit
+  debug_info -> int -> (Genarg.rawconstr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit
 
 (* Prints a matched hypothesis *)
 val db_matched_hyp :
diff --git a/scripts/coqc.ml b/scripts/coqc.ml
index 69357b2f..61f13d4d 100644
--- a/scripts/coqc.ml
+++ b/scripts/coqc.ml
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqc.ml 12911 2010-04-09 10:08:37Z herbelin $ *)
+(* $Id$ *)
 
 (* Afin de rendre Coq plus portable, ce programme Caml remplace le script
-   coqc. 
+   coqc.
 
    Ici, on trie la ligne de commande pour en extraire les fichiers à compiler,
    puis on les compile un par un en passant le reste de la ligne de commande
@@ -24,7 +24,8 @@
 
 let environment = Unix.environment ()
 
-let binary = ref ("coqtop." ^ Coq_config.best)
+let best = if Coq_config.arch = "win32" then "" else ("."^Coq_config.best)
+let binary = ref ("coqtop" ^ best)
 let image = ref ""
 
 (* coqc options *)
@@ -46,12 +47,12 @@ let check_module_name s =
     else
       (output_string stderr"'"; output_char stderr c; output_string stderr"'");
     output_string stderr " is not allowed in module names\n";
-    exit 1 
+    exit 1
   in
-  match String.get s 0 with 
-    | 'a' .. 'z' | 'A' .. 'Z' -> 
+  match String.get s 0 with
+    | 'a' .. 'z' | 'A' .. 'Z' ->
 	for i = 1 to (String.length s)-1 do
-	  match String.get s i with 
+	  match String.get s i with
 	    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_'  -> ()
 	    | c -> err c
 	done
@@ -59,7 +60,7 @@ let check_module_name s =
 
 let rec make_compilation_args = function
   | [] -> []
-  | file :: fl -> 
+  | file :: fl ->
       let dirname = Filename.dirname file in
       let basename = Filename.basename file in
       let modulename =
@@ -78,14 +79,14 @@ let rec make_compilation_args = function
 let compile command args files =
   let args' = command :: args @ (make_compilation_args files) in
   match Sys.os_type with
-  | "Win32" -> 
-     let pid = 
+  | "Win32" ->
+     let pid =
         Unix.create_process_env command (Array.of_list args') environment
-        Unix.stdin Unix.stdout Unix.stderr 
+        Unix.stdin Unix.stdout Unix.stderr
      in
      ignore (Unix.waitpid [] pid)
   | _ ->
-     Unix.execvpe command (Array.of_list args') environment 
+     Unix.execvpe command (Array.of_list args') environment
 
 (* parsing of the command line
  *
@@ -99,13 +100,13 @@ let usage () =
 
 let parse_args () =
   let rec parse (cfiles,args) = function
-    | [] -> 
+    | [] ->
 	List.rev cfiles, List.rev args
-    | "-i" :: rem -> 
+    | "-i" :: rem ->
 	specification := true ; parse (cfiles,args) rem
-    | "-t" :: rem -> 
+    | "-t" :: rem ->
 	keep := true ; parse (cfiles,args) rem
-    | ("-verbose" | "--verbose") :: rem -> 
+    | ("-verbose" | "--verbose") :: rem ->
 	verbose := true ; parse (cfiles,args) rem
     | "-boot" :: rem ->
 	Flags.boot := true;
@@ -129,7 +130,7 @@ let parse_args () =
     | ("-outputstate"|"-inputstate"|"-is"
       |"-load-vernac-source"|"-l"|"-load-vernac-object"
       |"-load-ml-source"|"-require"|"-load-ml-object"|"-user"
-      |"-init-file" | "-dump-glob" | "-coqlib" as o) :: rem ->
+      |"-init-file"|"-dump-glob"|"-compat"|"-coqlib" as o) :: rem ->
 	begin
 	  match rem with
 	    | s :: rem' -> parse (cfiles,s::o::args) rem'
@@ -149,15 +150,14 @@ let parse_args () =
 
     | ("-notactics"|"-debug"|"-nolib"
       |"-debugVM"|"-alltransp"|"-VMno"
-      |"-batch"|"-nois"
+      |"-batch"|"-nois"|"-noglob"|"-no-glob"
       |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet"
       |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit"
       |"-dont-load-proofs"|"-impredicative-set"|"-vm"
-      |"-unboxed-values"|"-unboxed-definitions"|"-draw-vm-instr"
-      |"-no-glob"|"-noglob" as o) :: rem ->
+      |"-unboxed-values"|"-unboxed-definitions"|"-draw-vm-instr" as o) :: rem ->
 	parse (cfiles,o::args) rem
-	    
-    | ("-where") :: _ -> 
+
+    | ("-where") :: _ ->
 	(try print_endline (Envars.coqlib ())
 	 with Util.UserError(_,pps) -> Pp.msgerrnl (Pp.hov 0 pps));
 	exit 0
@@ -166,10 +166,10 @@ let parse_args () =
 
     | ("-v"|"--version") :: _ ->
         Usage.version ()
-    | f :: rem -> 
+    | f :: rem ->
 	if Sys.file_exists f then
 	  parse (f::cfiles,args) rem
-	else 
+	else
 	  let fv = f ^ ".v" in
 	  if Sys.file_exists fv then
 	    parse (fv::cfiles,args) rem
@@ -189,11 +189,11 @@ let main () =
       prerr_endline "coqc: too few arguments" ;
       usage ()
     end;
-    let coqtopname = 
-      if !image <> "" then !image 
+    let coqtopname =
+      if !image <> "" then !image
       else Filename.concat (Envars.coqbin ()) (!binary ^ Coq_config.exec_extension)
     in
       (*  List.iter (compile coqtopname args) cfiles*)
       Unix.handle_unix_error (compile coqtopname args) cfiles
-    
+
 let _ = Printexc.print main (); exit 0
diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml
index ee8ef1d9..bd21c1c5 100644
--- a/scripts/coqmktop.ml
+++ b/scripts/coqmktop.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqmktop.ml 12874 2010-03-19 23:15:52Z herbelin $ *)
+(* $Id$ *)
 
 (* coqmktop is a script to link Coq, analogous to ocamlmktop.
    The command line contains options specific to coqmktop, options for the
@@ -28,7 +28,7 @@ let split_list l = Str.split spaces l
 let copts     = split_list Tolink.copts
 let core_objs = split_list Tolink.core_objs
 let core_libs = split_list Tolink.core_libs
-let ide       = split_list Tolink.ide 
+let ide       = split_list Tolink.ide
 
 (* 3. Toplevel objects *)
 let camlp4topobjs =
@@ -51,28 +51,28 @@ let searchisos = ref false
 let coqide     = ref false
 let echo       = ref false
 
-let src_dirs () = 
+let src_dirs () =
   [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] @
   if !coqide then [[ "ide" ]] else []
 
-let includes () = 
+let includes () =
   let coqlib = Envars.coqlib () in
   let camlp4lib = Envars.camlp4lib () in
     List.fold_right
       (fun d l -> "-I" :: ("\"" ^ List.fold_left Filename.concat coqlib d ^ "\"") :: l)
       (src_dirs ())
-      (["-I"; "\"" ^ camlp4lib ^ "\""] @ 
+      (["-I"; "\"" ^ camlp4lib ^ "\""] @
 	 ["-I"; "\"" ^ coqlib ^ "\""] @
 	 (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
 
 (* Transform bytecode object file names in native object file names *)
 let native_suffix f =
-  if Filename.check_suffix f ".cmo" then 
+  if Filename.check_suffix f ".cmo" then
     (Filename.chop_suffix f ".cmo") ^ ".cmx"
-  else if Filename.check_suffix f ".cma" then 
+  else if Filename.check_suffix f ".cma" then
     (Filename.chop_suffix f ".cma") ^ ".cmxa"
-  else  
-    if Filename.check_suffix f ".a" then f 
+  else
+    if Filename.check_suffix f ".a" then f
     else
       failwith ("File "^f^" has not extension .cmo, .cma or .a")
 
@@ -89,25 +89,21 @@ let files_to_link userfiles =
     if not !opt || Coq_config.has_natdynlink then dynobjs else [] in
   let toplevel_objs =
     if !top then topobjs else if !opt then notopobjs else [] in
-  let ide_objs = if !coqide then 
-    "threads.cma"::"lablgtk.cma"::"gtkThread.cmo"::ide 
-  else [] 
+  let ide_objs =
+    if !coqide then "Threads"::"Lablgtk"::"GtkThread"::ide else []
+  in
+  let ide_libs =
+    if !coqide then
+      ["threads.cma" ; "lablgtk.cma" ; "gtkThread.cmo" ; "ide/ide.cma" ]
+    else []
   in
-  let ide_libs = if !coqide then 
-    ["threads.cma" ; "lablgtk.cma" ; "gtkThread.cmo" ;
-     "ide/ide.cma" ]
-  else [] 
+  let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs @ ide_objs in
+  let modules = List.map module_of_file (objs @ userfiles)
   in
-  let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs @ ide_objs
-  and libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs @ ide_libs in
-  let objstolink,libstolink =
-    if !opt then 
-      ((List.map native_suffix objs) @ userfiles,
-       (List.map native_suffix libs) @ userfiles)
-    else 
-      (objs @ userfiles, libs @ userfiles )
+  let libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs @ ide_libs in
+  let libstolink =
+    (if !opt then List.map native_suffix libs else libs) @ userfiles
   in
-  let modules = List.map module_of_file objstolink in
   (modules, libstolink)
 
 (* Gives the list of all the directories under [dir].
@@ -116,8 +112,8 @@ let all_subdirs dir =
   let l = ref [dir] in
   let add f = l := f :: !l in
   let rec traverse dir =
-    let dirh = 
-      try opendir dir with Unix_error _ -> invalid_arg "all_subdirs" 
+    let dirh =
+      try opendir dir with Unix_error _ -> invalid_arg "all_subdirs"
     in
     try
       while true do
@@ -137,17 +133,18 @@ let all_subdirs dir =
 (* usage *)
 let usage () =
   prerr_endline "Usage: coqmktop <options> <ocaml options> files
-Flags.are:
+Flags are:
   -coqlib dir    Specify where the Coq object files are
   -camlbin dir   Specify where the OCaml binaries are
   -camlp4bin dir Specify where the CAmp4/5 binaries are
   -o exec-file   Specify the name of the resulting toplevel
   -boot          Run in boot mode
-  -opt           Compile in native code
+  -echo          Print calls to external commands
+  -ide           Build a toplevel for the Coq IDE
   -full          Link high level tactics
-  -top           Build Coq on a ocaml toplevel (incompatible with -opt)
+  -opt           Compile in native code
   -searchisos    Build a toplevel for SearchIsos
-  -ide           Build a toplevel for the Coq IDE
+  -top           Build Coq on a OCaml toplevel (incompatible with -opt)
   -R dir         Specify recursively directories for Ocaml\n";
   exit 1
 
@@ -155,13 +152,13 @@ Flags.are:
 let parse_args () =
   let rec parse (op,fl) = function
     | [] -> List.rev op, List.rev fl
-    | "-coqlib" :: d :: rem -> 
+    | "-coqlib" :: d :: rem ->
 	Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem
     | "-coqlib" :: _        -> usage ()
-    | "-camlbin" :: d :: rem -> 
+    | "-camlbin" :: d :: rem ->
 	Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem
     | "-camlbin" :: _        -> usage ()
-    | "-camlp4bin" :: d :: rem -> 
+    | "-camlp4bin" :: d :: rem ->
 	Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem
     | "-camlp4bin" :: _        -> usage ()
     | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem
@@ -170,7 +167,7 @@ let parse_args () =
     | "-top" :: rem -> top := true ; parse (op,fl) rem
     | "-ide" :: rem ->
         coqide := true; parse (op,fl) rem
-    | "-v8" :: rem -> 
+    | "-v8" :: rem ->
 	Printf.eprintf "warning: option -v8 deprecated";
 	parse (op,fl) rem
     | "-echo" :: rem -> echo := true ; parse (op,fl) rem
@@ -188,8 +185,8 @@ let parse_args () =
         parse (o::op,fl) rem
     | ("-h"|"--help") :: _ -> usage ()
     | f :: rem ->
-	if Filename.check_suffix f ".ml" 
-	  or Filename.check_suffix f ".cmx" 
+	if Filename.check_suffix f ".ml"
+	  or Filename.check_suffix f ".cmx"
 	  or Filename.check_suffix f ".cmo"
 	  or Filename.check_suffix f ".cmxa"
 	  or Filename.check_suffix f ".cma" then
@@ -223,9 +220,20 @@ let declare_loading_string () =
   if not !top then
     "Mltop.remove ();;"
   else
-    "let ppf = Format.std_formatter;;
+    "begin try
+       (* Enable rectypes in the toplevel if it has the directive #rectypes *)
+       begin match Hashtbl.find Toploop.directive_table \"rectypes\" with
+         | Toploop.Directive_none f -> f ()
+         | _ -> ()
+       end
+     with
+       | Not_found -> ()
+     end;;
+
+     let ppf = Format.std_formatter;;
      Mltop.set_top
-       {Mltop.load_obj=Topdirs.dir_load ppf;
+       {Mltop.load_obj=
+         (fun f -> if not (Topdirs.load_file ppf f) then failwith \"error\");
         Mltop.use_file=Topdirs.dir_use ppf;
         Mltop.add_dir=Topdirs.dir_directory;
         Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\n"
@@ -235,14 +243,14 @@ let create_tmp_main_file modules =
   let main_name = Filename.temp_file "coqmain" ".ml" in
   let oc = open_out main_name in
   try
-    (* Add the pre-linked modules *)    
+    (* Add the pre-linked modules *)
     output_string oc "List.iter Mltop.add_known_module [\"";
     output_string oc (String.concat "\";\"" modules);
     output_string oc "\"];;\n";
     (* Initializes the kind of loading *)
     output_string oc (declare_loading_string());
     (* Start the right toplevel loop: Coq or Coq_searchisos *)
-    if !searchisos then 
+    if !searchisos then
       output_string oc "Cmd_searchisos_line.start();;\n"
     else if !coqide then
       output_string oc "Coqide.start();;\n"
@@ -250,7 +258,7 @@ let create_tmp_main_file modules =
       output_string oc "Coqtop.start();;\n";
     close_out oc;
     main_name
-  with e -> 
+  with e ->
     clean main_name; raise e
 
 (* main part *)
@@ -290,19 +298,19 @@ let main () =
     let args = if !top then args @ [ "topstart.cmo" ] else args in
       (* Now, with the .cma, we MUST use the -linkall option *)
     let command = String.concat " " (prog::"-rectypes"::args) in
-      if !echo then 
-	begin 
-	  print_endline command; 
-	  print_endline 
-	    ("(command length is " ^ 
+      if !echo then
+	begin
+	  print_endline command;
+	  print_endline
+	    ("(command length is " ^
 	       (string_of_int (String.length command)) ^ " characters)");
-	  flush Pervasives.stdout 
+	  flush Pervasives.stdout
 	end;
       let retcode = Sys.command command in
 	clean main_file;
 	(* command gives the exit code in HSB, and signal in LSB !!! *)
-	if retcode > 255 then retcode lsr 8 else retcode 
-  with e -> 
+	if retcode > 255 then retcode lsr 8 else retcode
+  with e ->
     clean main_file; raise e
 
 let retcode =
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 36136a6c..99630417 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -6,14 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: auto.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Names
 open Nameops
+open Namegen
 open Term
 open Termops
+open Inductiveops
 open Sign
 open Environ
 open Inductive
@@ -34,6 +36,7 @@ open Clenv
 open Hiddentac
 open Libnames
 open Nametab
+open Smartlocate
 open Libobject
 open Library
 open Printer
@@ -45,15 +48,15 @@ open Mod_subst
 (*            The Type of Constructions Autotactic Hints                    *)
 (****************************************************************************)
 
-type auto_tactic = 
+type auto_tactic =
   | Res_pf     of constr * clausenv (* Hint Apply *)
   | ERes_pf    of constr * clausenv (* Hint EApply *)
-  | Give_exact of constr                  
+  | Give_exact of constr
   | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
   | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
-  | Extern     of glob_tactic_expr       (* Hint Extern *) 
+  | Extern     of glob_tactic_expr       (* Hint Extern *)
 
-type pri_auto_tactic = { 
+type pri_auto_tactic = {
   pri  : int;            (* A number between 0 and 4, 4 = lower priority *)
   pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
   code : auto_tactic     (* the tactic to apply when the concl matches pat *)
@@ -61,19 +64,17 @@ type pri_auto_tactic = {
 
 type hint_entry = global_reference option * pri_auto_tactic
 
-let pri_ord {pri=pri1} {pri=pri2} = pri1 - pri2
-
 let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2
 
-let insert v l = 
+let insert v l =
   let rec insrec = function
     | [] -> [v]
     | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl)
-  in 
+  in
   insrec l
 
 (* Nov 98 -- Papageno *)
-(* Les Hints sont ré-organisés en plusieurs databases. 
+(* Les Hints sont ré-organisés en plusieurs databases.
 
   La table impérative "searchtable", de type "hint_db_table",
    associe une database (hint_db) à chaque nom.
@@ -89,150 +90,162 @@ let insert v l =
 
 type stored_data = pri_auto_tactic
 
-type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
-
-let empty_se = ([],[],Btermdn.create ())
+module Bounded_net = Btermdn.Make(struct
+				    type t = stored_data
+				    let compare = Pervasives.compare
+				  end)
+
+type search_entry = stored_data list * stored_data list * Bounded_net.t
+
+let empty_se = ([],[],Bounded_net.create ())
+
+let eq_pri_auto_tactic x y =
+  if x.pri = y.pri && x.pat = y.pat then
+    match x.code,y.code with
+      | Res_pf(cstr,_),Res_pf(cstr1,_) -> 
+	   eq_constr cstr cstr1
+      | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> 
+	  eq_constr cstr cstr1
+      | Give_exact cstr,Give_exact cstr1  -> 
+	  eq_constr cstr cstr1
+      | Res_pf_THEN_trivial_fail(cstr,_)
+	  ,Res_pf_THEN_trivial_fail(cstr1,_) -> 
+	  eq_constr cstr cstr1
+      | _,_ -> false
+  else
+    false
 
 let add_tac pat t st (l,l',dn) =
   match pat with
-  | None -> if not (List.mem t l) then (insert t l, l', dn) else (l, l', dn)
-  | Some pat -> if not (List.mem t l') then (l, insert t l', Btermdn.add st dn (pat,t)) else (l, l', dn)
+  | None -> if not (List.exists (eq_pri_auto_tactic t) l) then (insert t l, l', dn) else (l, l', dn)
+  | Some pat -> if not (List.exists (eq_pri_auto_tactic t) l') then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn)
 
 let rebuild_dn st (l,l',dn) =
-  (l, l', List.fold_left (fun dn t -> Btermdn.add (Some st) dn (Option.get t.pat, t))
-    (Btermdn.create ()) l')
-    
+  (l, l', List.fold_left (fun dn t -> Bounded_net.add (Some st) dn (Option.get t.pat, t))
+    (Bounded_net.create ()) l')
+
 let lookup_tacs (hdc,c) st (l,l',dn) =
-  let l'  = List.map snd (Btermdn.lookup st dn c) in
+  let l'  = List.map snd (Bounded_net.lookup st dn c) in
   let sl' = Sort.list pri_order l' in
     Sort.merge pri_order l sl'
 
-module Constr_map = Map.Make(struct 
-			       type t = global_reference
-			       let compare = Pervasives.compare 
-			     end)
+module Constr_map = Map.Make(RefOrdered)
 
 let is_transparent_gr (ids, csts) = function
   | VarRef id -> Idpred.mem id ids
   | ConstRef cst -> Cpred.mem cst csts
   | IndRef _ | ConstructRef _ -> false
-      
-let fmt_autotactic =
-  function
-  | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c)
-  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c)
-  | Give_exact c -> (str"exact " ++ pr_lconstr c)
-  | Res_pf_THEN_trivial_fail (c,clenv) -> 
-      (str"apply " ++ pr_lconstr c ++ str" ; trivial")
-  | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
-  | Extern tac -> 
-      (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
-
-let pr_autotactic = fmt_autotactic
 
 module Hint_db = struct
 
-  type t = { 
+  type t = {
     hintdb_state : Names.transparent_state;
+    hintdb_unfolds : Idset.t * Cset.t;
     use_dn : bool;
     hintdb_map : search_entry Constr_map.t;
     (* A list of unindexed entries starting with an unfoldable constant
        or with no associated pattern. *)
-    hintdb_nopat : stored_data list
+    hintdb_nopat : (global_reference option * stored_data) list
   }
 
   let empty st use_dn = { hintdb_state = st;
+			  hintdb_unfolds = (Idset.empty, Cset.empty);
 			  use_dn = use_dn;
 			  hintdb_map = Constr_map.empty;
 			  hintdb_nopat = [] }
-    
+
   let find key db =
     try Constr_map.find key db.hintdb_map
     with Not_found -> empty_se
-      
-  let map_none db = 
-    Sort.merge pri_order db.hintdb_nopat []
-      
+
+  let map_none db =
+    Sort.merge pri_order (List.map snd db.hintdb_nopat) []
+
   let map_all k db =
     let (l,l',_) = find k db in
-      Sort.merge pri_order (db.hintdb_nopat @ l) l'
+      Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l'
 
   let map_auto (k,c) db =
     let st = if db.use_dn then Some db.hintdb_state else None in
     let l' = lookup_tacs (k,c) st (find k db) in
-      Sort.merge pri_order db.hintdb_nopat l'
-	
-  let is_exact = function 
+      Sort.merge pri_order (List.map snd db.hintdb_nopat) l'
+
+  let is_exact = function
     | Give_exact _ -> true
     | _ -> false
 
-  let rebuild_db st' db = 
-    { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map }
-
-  let add_one (k,v) db =
-    let st',rebuild =
-      match v.code with
-      | Unfold_nth egr ->
-	  let (ids,csts) = db.hintdb_state in
-	    (match egr with
-	    | EvalVarRef id -> (Idpred.add id ids, csts)
-	    | EvalConstRef cst -> (ids, Cpred.add cst csts)), true
-      | _ -> db.hintdb_state, false
-    in
-    let dnst, db, k =
-      if db.use_dn then
-	let db', k' = 
-	  if rebuild then rebuild_db st' db, k
-	  else (* not an unfold *)
-	    (match k with
-	    | Some gr -> db, if is_transparent_gr st' gr then None else k
-	    | None -> db, None)
-	in
-	  (Some st', db', k')
-      else None, db, k
+  let addkv gr v db =
+    let k = match gr with
+      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr then None else Some gr
+      | None -> None
     in
+    let dnst = if db.use_dn then Some db.hintdb_state else None in
     let pat = if not db.use_dn && is_exact v.code then None else v.pat in
       match k with
       | None ->
-	  if not (List.mem v db.hintdb_nopat) then
-	    { db with hintdb_nopat = v :: db.hintdb_nopat }
+	  if not (List.exists (fun (_, v') -> v = v') db.hintdb_nopat) then
+	    { db with hintdb_nopat = (gr,v) :: db.hintdb_nopat }
 	  else db
       | Some gr ->
 	  let oval = find gr db in
-	    { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map;
-	      hintdb_state = st' }
-	
+	    { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map }
+
+  let rebuild_db st' db =
+    let db' =
+      { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map;
+	hintdb_state = st'; hintdb_nopat = [] }
+    in
+      List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat
+
+  let add_one (k,v) db =
+    let st',db,rebuild =
+      match v.code with
+      | Unfold_nth egr ->
+	  let addunf (ids,csts) (ids',csts') =
+	    match egr with
+	    | EvalVarRef id -> (Idpred.add id ids, csts), (Idset.add id ids', csts')
+	    | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts')
+	  in 
+	  let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in
+	    state, { db with hintdb_unfolds = unfs }, true
+      | _ -> db.hintdb_state, db, false
+    in
+    let db = if db.use_dn && rebuild then rebuild_db st' db else db
+    in addkv k v db
+
   let add_list l db = List.fold_right add_one l db
-    
-  let iter f db = 
-    f None db.hintdb_nopat;
+
+  let iter f db =
+    f None (List.map snd db.hintdb_nopat);
     Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map
-    
+
   let transparent_state db = db.hintdb_state
 
   let set_transparent_state db st =
-    let db = if db.use_dn then rebuild_db st db else db in
-      { db with hintdb_state = st }
+    if db.use_dn then rebuild_db st db
+    else { db with hintdb_state = st }
+
+  let unfolds db = db.hintdb_unfolds
 
   let use_dn db = db.use_dn
-	
+
 end
 
 module Hintdbmap = Gmap
 
 type hint_db = Hint_db.t
 
-type frozen_hint_db_table = (string,hint_db) Hintdbmap.t 
+type frozen_hint_db_table = (string,hint_db) Hintdbmap.t
 
 type hint_db_table = (string,hint_db) Hintdbmap.t ref
 
 type hint_db_name = string
 
 let searchtable = (ref Hintdbmap.empty : hint_db_table)
-  
-let searchtable_map name = 
+
+let searchtable_map name =
   Hintdbmap.find name !searchtable
-let searchtable_add (name,db) = 
+let searchtable_add (name,db) =
   searchtable := Hintdbmap.add name db !searchtable
 let current_db_names () =
   Hintdbmap.dom !searchtable
@@ -242,7 +255,7 @@ let current_db_names () =
 (**************************************************************************)
 
 let auto_init : (unit -> unit) ref = ref (fun () -> ())
-  
+
 let init     () = searchtable := Hintdbmap.empty; !auto_init ()
 let freeze   () = !searchtable
 let unfreeze fs = searchtable := fs
@@ -250,52 +263,51 @@ let unfreeze fs = searchtable := fs
 let _ = Summary.declare_summary "search"
 	  { Summary.freeze_function   = freeze;
 	    Summary.unfreeze_function = unfreeze;
-	    Summary.init_function     = init;
-	    Summary.survive_module = false;
-	    Summary.survive_section   = false }
+	    Summary.init_function     = init }
+
 
- 
 (**************************************************************************)
 (*             Auxiliary functions to prepare AUTOHINT objects            *)
 (**************************************************************************)
 
 let rec nb_hyp c = match kind_of_term c with
   | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
-  | _ -> 0 
+  | _ -> 0
 
 (* adding and removing tactics in the search table *)
 
-let try_head_pattern c = 
+let try_head_pattern c =
   try head_pattern_bound c
   with BoundPattern -> error "Bound head variable."
 
-let dummy_goal = 
+let dummy_goal =
   {it = make_evar empty_named_context_val mkProp;
    sigma = empty}
 
-let make_exact_entry pri (c,cty) =
+let make_exact_entry sigma pri (c,cty) =
   let cty = strip_outer_cast cty in
-  match kind_of_term cty with
-    | Prod (_,_,_) -> 
-	failwith "make_exact_entry"
+    match kind_of_term cty with
+    | Prod _ -> failwith "make_exact_entry"
     | _ ->
-        let ce = mk_clenv_from dummy_goal (c,cty) in
-	let c' = clenv_type ce in
-	let pat = Pattern.pattern_of_constr c' in
-	(Some (head_of_constr_reference (fst (head_constr cty))),
-	   { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c })
+	let pat = snd (Pattern.pattern_of_constr sigma cty) in
+	let head = 
+	  try head_of_constr_reference (fst (head_constr cty)) 
+	  with _ -> failwith "make_exact_entry" 
+	in
+          (Some head,
+	  { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c })
 
 let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) =
   let cty = if hnf then hnf_constr env sigma cty else cty in
     match kind_of_term cty with
     | Prod _ ->
         let ce = mk_clenv_from dummy_goal (c,cty) in
-	let c' = clenv_type ce in
-	let pat = Pattern.pattern_of_constr c' in
+	let c' = clenv_type (* ~reduce:false *) ce in
+	let pat = snd (Pattern.pattern_of_constr sigma c') in
         let hd = (try head_pattern_bound pat
           with BoundPattern -> failwith "make_apply_entry") in
         let nmiss = List.length (clenv_missing ce) in
-	if nmiss = 0 then 
+	if nmiss = 0 then
 	  (Some hd,
           { pri = (match pri with None -> nb_hyp cty | Some p -> p);
             pat = Some pat;
@@ -311,43 +323,43 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) =
               code = ERes_pf(c,{ce with env=empty_env}) })
         end
     | _ -> failwith "make_apply_entry"
- 
-(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose 
+
+(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose
    c is a constr
    cty is the type of constr *)
 
 let make_resolves env sigma flags pri c =
   let cty = type_of env sigma c in
-  let ents = 
-    map_succeed 
-      (fun f -> f (c,cty)) 
-      [make_exact_entry pri; make_apply_entry env sigma flags pri]
-  in 
+  let ents =
+    map_succeed
+      (fun f -> f (c,cty))
+      [make_exact_entry sigma pri; make_apply_entry env sigma flags pri]
+  in
   if ents = [] then
-    errorlabstrm "Hint" 
-      (pr_lconstr c ++ spc() ++ 
+    errorlabstrm "Hint"
+      (pr_lconstr c ++ spc() ++
         (if pi1 flags then str"cannot be used as a hint."
 	else str "can be used as a hint only for eauto."));
   ents
 
 (* used to add an hypothesis to the local hint database *)
-let make_resolve_hyp env sigma (hname,_,htyp) = 
+let make_resolve_hyp env sigma (hname,_,htyp) =
   try
     [make_apply_entry env sigma (true, true, false) None
        (mkVar hname, htyp)]
-  with 
+  with
     | Failure _ -> []
     | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp"
 
 (* REM : in most cases hintname = id *)
-let make_unfold (ref, eref) =
-  (Some ref,
+let make_unfold eref =
+  (Some (global_of_evaluable_reference eref),
    { pri = 4;
      pat = None;
      code = Unfold_nth eref })
 
-let make_extern pri pat tacast = 
-  let hdconstr = Option.map try_head_pattern pat in 
+let make_extern pri pat tacast =
+  let hdconstr = Option.map try_head_pattern pat in
   (hdconstr,
    { pri=pri;
      pat = pat;
@@ -358,7 +370,7 @@ let make_trivial env sigma c =
   let hd = head_of_constr_reference (fst (head_constr t)) in
   let ce = mk_clenv_from dummy_goal (c,t) in
   (Some hd, { pri=1;
-         pat = Some (Pattern.pattern_of_constr (clenv_type ce));
+         pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce)));
          code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) })
 
 open Vernacexpr
@@ -369,52 +381,47 @@ open Vernacexpr
 
 (* If the database does not exist, it is created *)
 (* TODO: should a warning be printed in this case ?? *)
+
+let get_db dbname =
+  try searchtable_map dbname
+  with Not_found -> Hint_db.empty empty_transparent_state false
+
 let add_hint dbname hintlist = 
-  try 
-    let db = searchtable_map dbname in
-    let db' = Hint_db.add_list hintlist db in
+  let db = get_db dbname in
+  let db' = Hint_db.add_list hintlist db in
     searchtable_add (dbname,db')
-  with Not_found -> 
-    let db = Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false) in
-    searchtable_add (dbname,db)
 
 let add_transparency dbname grs b =
-  let db = searchtable_map dbname in
+  let db = get_db dbname in
   let st = Hint_db.transparent_state db in
-  let st' = 
-    List.fold_left (fun (ids, csts) gr -> 
+  let st' =
+    List.fold_left (fun (ids, csts) gr ->
       match gr with
       | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts)
       | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts)
       st grs
   in searchtable_add (dbname, Hint_db.set_transparent_state db st')
-    
+
 type hint_action = | CreateDB of bool * transparent_state
 		   | AddTransparency of evaluable_global_reference list * bool
 		   | AddTactic of (global_reference option * pri_auto_tactic) list
 
-let cache_autohint (_,(local,name,hints)) = 
+let cache_autohint (_,(local,name,hints)) =
   match hints with
   | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b)
   | AddTransparency (grs, b) -> add_transparency name grs b
   | AddTactic hints -> add_hint name hints
 
-let forward_subst_tactic = 
+let forward_subst_tactic =
   ref (fun _ -> failwith "subst_tactic is not installed for auto")
 
 let set_extern_subst_tactic f = forward_subst_tactic := f
 
-let subst_autohint (_,subst,(local,name,hintlist as obj)) = 
+let subst_autohint (subst,(local,name,hintlist as obj)) = 
   let trans_clenv clenv = Clenv.subst_clenv subst clenv in
-  let trans_data data code = 	      
-    { data with
-	pat = Option.smartmap (subst_pattern subst) data.pat ;
-	code = code ;
-    }
-  in
   let subst_key gr =
     let (lab'', elab') = subst_global subst gr in
-    let gr' = 
+    let gr' =
       (try head_of_constr_reference (fst (head_constr_bound elab'))
        with Tactics.Bound -> lab'')
     in if gr' == gr then gr else gr'
@@ -424,61 +431,87 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) =
     let data' = match data.code with
       | Res_pf (c, clenv) ->
 	  let c' = subst_mps subst c in
-	    if c==c' then data else
-	      trans_data data (Res_pf (c', trans_clenv clenv))
+	  let clenv' = trans_clenv clenv in
+	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
+	    if c==c' && clenv'==clenv && pat'==data.pat then data else
+	      {data with
+		 pat=pat';
+		 code=Res_pf (c', clenv')}
       | ERes_pf (c, clenv) ->
 	  let c' = subst_mps subst c in
-	    if c==c' then data else
-	      trans_data data (ERes_pf (c', trans_clenv clenv))
+	  let clenv' = trans_clenv clenv in
+	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
+	    if c==c' && clenv'==clenv && pat'==data.pat then data else
+	      {data with
+		 pat=pat';
+		 code=ERes_pf (c', clenv')}
       | Give_exact c ->
 	  let c' = subst_mps subst c in
-	    if c==c' then data else
-	      trans_data data (Give_exact c')
+	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
+	    if c==c' && pat'==data.pat then data else
+	      {data with
+		 pat=pat';
+		 code=(Give_exact c')}
       | Res_pf_THEN_trivial_fail (c, clenv) ->
 	  let c' = subst_mps subst c in
-	    if c==c' then data else
-	      let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in
-		trans_data data code'
-      | Unfold_nth ref -> 
+	  let clenv' = trans_clenv clenv in
+	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
+	    if c==c' && clenv'==clenv && pat'==data.pat then data else
+	      {data with
+		 pat=pat';
+		 code=Res_pf_THEN_trivial_fail (c',clenv')}
+      | Unfold_nth ref ->
           let ref' = subst_evaluable_reference subst ref in
-           if ref==ref' then data else
-	    trans_data data (Unfold_nth ref')
+	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
+           if ref==ref' && pat'==data.pat then data else
+	     {data with
+		pat=pat';
+		code=(Unfold_nth ref')}
       | Extern tac ->
 	  let tac' = !forward_subst_tactic subst tac in
-	    if tac==tac' then data else
-	      trans_data data (Extern tac')
+	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
+	    if tac==tac' && pat'==data.pat then data else
+	      {data with
+		 pat=pat';
+		 code=(Extern tac')}
     in
       if k' == k && data' == data then hint else
 	(k',data')
   in
     match hintlist with
     | CreateDB _ -> obj
-    | AddTransparency (grs, b) -> 
+    | AddTransparency (grs, b) ->
 	let grs' = list_smartmap (subst_evaluable_reference subst) grs in
 	  if grs==grs' then obj else (local, name, AddTransparency (grs', b))
     | AddTactic hintlist ->
 	let hintlist' = list_smartmap subst_hint hintlist in
 	  if hintlist' == hintlist then obj else
 	    (local,name,AddTactic hintlist')
-	      
-let classify_autohint (_,((local,name,hintlist) as obj)) =
-  if local or hintlist = (AddTactic []) then Dispose else Substitute obj
 
-let export_autohint ((local,name,hintlist) as obj) =
-  if local then None else Some obj
+let classify_autohint ((local,name,hintlist) as obj) =
+  if local or hintlist = (AddTactic []) then Dispose else Substitute obj
 
-let (inAutoHint,outAutoHint) =
+let discharge_autohint (_,(local,name,hintlist as obj)) =
+  if local then None else
+    match hintlist with
+    | CreateDB _ ->
+	(* We assume that the transparent state is either empty or full *)
+	Some obj
+    | AddTransparency _ | AddTactic _ ->
+	(* Needs the adequate code here to support Global Hints in sections *)
+	None
+
+let (inAutoHint,_) =
   declare_object {(default_object "AUTOHINT") with
                     cache_function = cache_autohint;
 		    load_function = (fun _ -> cache_autohint);
 		    subst_function = subst_autohint;
-		    classify_function = classify_autohint;
-                    export_function = export_autohint }
+		    classify_function = classify_autohint }
 
 
-let create_hint_db l n st b = 
+let create_hint_db l n st b =
   Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st)))
-      
+
 (**************************************************************************)
 (*                     The "Hint" vernacular command                      *)
 (**************************************************************************)
@@ -494,14 +527,14 @@ let add_resolves env sigma clist local dbnames =
 
 
 let add_unfolds l local dbnames =
-  List.iter 
-    (fun dbname -> Lib.add_anonymous_leaf 
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
        (inAutoHint (local,dbname, AddTactic (List.map make_unfold l))))
     dbnames
 
 let add_transparency l b local dbnames =
-  List.iter 
-    (fun dbname -> Lib.add_anonymous_leaf 
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
        (inAutoHint (local,dbname, AddTransparency (l, b))))
     dbnames
 
@@ -513,16 +546,16 @@ let add_extern pri pat tacast local dbname =
     | Some (patmetas,pat) ->
 	(match (list_subtract tacmetas patmetas) with
 	| i::_ ->
-	    errorlabstrm "add_extern" 
-	      (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.")
+	    errorlabstrm "add_extern"
+	      (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.")
 	| []  ->
 	    Lib.add_anonymous_leaf
 	      (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast])))
-    | None -> 
+    | None ->
 	Lib.add_anonymous_leaf
 	  (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast]))
 
-let add_externs pri pat tacast local dbnames = 
+let add_externs pri pat tacast local dbnames =
   List.iter (add_extern pri pat tacast local) dbnames
 
 let add_trivials env sigma l local dbnames =
@@ -532,62 +565,61 @@ let add_trivials env sigma l local dbnames =
 	 inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l))))
     dbnames
 
-let forward_intern_tac = 
+let forward_intern_tac =
   ref (fun _ -> failwith "intern_tac is not installed for auto")
 
 let set_extern_intern_tac f = forward_intern_tac := f
 
-let add_hints local dbnames0 h =
-  let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
-  let env = Global.env() and sigma = Evd.empty in
-  let f = Constrintern.interp_constr sigma env in
+type hints_entry =
+  | HintsResolveEntry of (int option * bool * constr) list
+  | HintsImmediateEntry of constr list
+  | HintsUnfoldEntry of evaluable_global_reference list
+  | HintsTransparencyEntry of evaluable_global_reference list * bool
+  | HintsExternEntry of
+      int * (patvar list * constr_pattern) option * glob_tactic_expr
+  | HintsDestructEntry of identifier * int * (bool,unit) location *
+      (patvar list * constr_pattern) * glob_tactic_expr
+
+let interp_hints h =
+  let f = Constrintern.interp_constr Evd.empty (Global.env()) in
+  let fr r =
+    let gr = global_with_alias r in
+    let r' = evaluable_of_global_reference (Global.env()) gr in
+    Dumpglob.add_glob (loc_of_reference r) gr;
+    r' in
+  let fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in
   match h with
-  | HintsResolve lhints ->	
-      add_resolves env sigma (List.map (fun (pri, b, x) -> pri, b, f x) lhints) local dbnames
-  | HintsImmediate lhints ->
-      add_trivials env sigma (List.map f lhints) local dbnames
-  | HintsUnfold lhints ->
-      let f r =
-	let gr = Syntax_def.global_with_alias r in
-        let r' = match gr with
-         | ConstRef c -> EvalConstRef c
-         | VarRef c -> EvalVarRef c
-         | _ -> 
-           errorlabstrm "evalref_of_ref"
-            (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++
-             str "to an evaluable reference.")
-        in
-	  Dumpglob.add_glob (loc_of_reference r) gr;
-	 (gr,r') in
-      add_unfolds (List.map f lhints) local dbnames
- | HintsTransparency (lhints, b) ->
-      let f r =
-	let gr = Syntax_def.global_with_alias r in
-        let r' = match gr with
-         | ConstRef c -> EvalConstRef c
-         | VarRef c -> EvalVarRef c
-         | _ -> 
-           errorlabstrm "evalref_of_ref"
-            (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++
-             str "to an evaluable reference.")
-        in
-	  Dumpglob.add_glob (loc_of_reference r) gr;
-	  r' in
-      add_transparency (List.map f lhints) b local dbnames
+  | HintsResolve lhints -> HintsResolveEntry (List.map (on_pi3 f) lhints)
+  | HintsImmediate lhints -> HintsImmediateEntry (List.map f lhints)
+  | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints)
+  | HintsTransparency (lhints, b) ->
+      HintsTransparencyEntry (List.map fr lhints, b)
   | HintsConstructors lqid ->
-      let add_one qid =
-        let env = Global.env() and sigma = Evd.empty in
-        let isp = inductive_of_reference qid in
-        let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in
-        let lcons = list_tabulate
-          (fun i -> None, true, mkConstruct (isp,i+1)) (Array.length consnames) in
-        add_resolves env sigma lcons local dbnames in
-      List.iter add_one lqid
+      let constr_hints_of_ind qid =
+        let ind = global_inductive_with_alias qid in
+        list_tabulate (fun i -> None, true, mkConstruct (ind,i+1))
+	  (nconstructors ind) in
+	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
   | HintsExtern (pri, patcom, tacexp) ->
-      let pat =	Option.map (Constrintern.intern_constr_pattern Evd.empty (Global.env())) patcom in
+      let pat =	Option.map fp patcom in
       let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in
-      add_externs pri pat tacexp local dbnames
+      HintsExternEntry (pri, pat, tacexp)
   | HintsDestruct(na,pri,loc,pat,code) ->
+      let (l,_ as pat) = fp pat in
+      HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code)
+
+let add_hints local dbnames0 h =
+  let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
+  let env = Global.env() and sigma = Evd.empty in
+  match h with
+  | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
+  | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
+  | 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
+  | HintsDestructEntry (na,pri,loc,pat,code) ->
       if dbnames0<>[] then
         warn (str"Database selection not implemented for destruct hints");
       Dhyp.add_destructor_hint local na loc pat pri code
@@ -601,10 +633,10 @@ let pr_autotactic =
   | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c)
   | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c)
   | Give_exact c -> (str"exact " ++ pr_lconstr c)
-  | Res_pf_THEN_trivial_fail (c,clenv) -> 
+  | Res_pf_THEN_trivial_fail (c,clenv) ->
       (str"apply " ++ pr_lconstr c ++ str" ; trivial")
   | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
-  | Extern tac -> 
+  | Extern tac ->
       (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
 
 let pr_hint v =
@@ -619,17 +651,17 @@ let pr_hints_db (name,db,hintlist) =
      else (fnl () ++ pr_hint_list hintlist))
 
 (* Print all hints associated to head c in any database *)
-let pr_hint_list_for_head c = 
+let pr_hint_list_for_head c =
   let dbs = Hintdbmap.to_list !searchtable in
-  let valid_dbs = 
-    map_succeed 
-      (fun (name,db) -> (name,db,Hint_db.map_all c db)) 
-      dbs 
+  let valid_dbs =
+    map_succeed
+      (fun (name,db) -> (name,db,Hint_db.map_all c db))
+      dbs
   in
-  if valid_dbs = [] then 
+  if valid_dbs = [] then
     (str "No hint declared for :" ++ pr_global c)
-  else 
-    hov 0 
+  else
+    hov 0
       (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++
 	 hov 0 (prlist pr_hints_db valid_dbs))
 
@@ -638,11 +670,11 @@ let pr_hint_ref ref = pr_hint_list_for_head ref
 (* Print all hints associated to head id in any database *)
 let print_hint_ref ref =  ppnl(pr_hint_ref ref)
 
-let pr_hint_term cl = 
-  try 
+let pr_hint_term cl =
+  try
     let dbs = Hintdbmap.to_list !searchtable in
-    let valid_dbs = 
-      let fn = try 
+    let valid_dbs =
+      let fn = try
 	  let (hdc,args) = head_constr_bound cl in
 	  let hd = head_of_constr_reference hdc in
 	    if occur_existential cl then
@@ -652,50 +684,53 @@ let pr_hint_term cl =
       in
 	map_succeed (fun (name, db) -> (name, db, fn db)) dbs
     in
-      if valid_dbs = [] then 
+      if valid_dbs = [] then
 	(str "No hint applicable for current goal")
       else
 	(str "Applicable Hints :" ++ fnl () ++
 	    hov 0 (prlist pr_hints_db valid_dbs))
-  with Match_failure _ | Failure _ -> 
+  with Match_failure _ | Failure _ ->
     (str "No hint applicable for current goal")
 
 let error_no_such_hint_database x =
   error ("No such Hint database: "^x^".")
-	  
+
 let print_hint_term cl = ppnl (pr_hint_term cl)
 
 (* print all hints that apply to the concl of the current goal *)
-let print_applicable_hint () = 
-  let pts = get_pftreestate () in 
-  let gl = nth_goal_of_pftreestate 1 pts in 
+let print_applicable_hint () =
+  let pts = get_pftreestate () in
+  let gl = nth_goal_of_pftreestate 1 pts in
   print_hint_term (pf_concl gl)
-    
+
 (* displays the whole hint database db *)
 let print_hint_db db =
   let (ids, csts) = Hint_db.transparent_state db in
   msg (hov 0
+	  ((if Hint_db.use_dn db then str"Discriminated database"
+	    else str"Non-discriminated database") ++ fnl ()));
+  msg (hov 0
 	  (str"Unfoldable variable definitions: " ++ pr_idpred ids ++ fnl () ++
 	   str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ()));
-  Hint_db.iter 
+  Hint_db.iter
     (fun head hintlist ->
       match head with
       | Some head ->
-	  msg (hov 0 
+	  msg (hov 0
 		  (str "For " ++ pr_global head ++ str " -> " ++
 		      pr_hint_list hintlist))
       | None ->
-	  msg (hov 0 
+	  msg (hov 0
 		  (str "For any goal -> " ++
 		      pr_hint_list hintlist)))
     db
 
 let print_hint_db_by_name dbname =
-  try 
+  try
     let db = searchtable_map dbname in print_hint_db db
-  with Not_found -> 
+  with Not_found ->
     error_no_such_hint_database dbname
-  
+
 (* displays all the hints of all databases *)
 let print_searchtable () =
   Hintdbmap.iter
@@ -714,41 +749,55 @@ let print_searchtable () =
 
 let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l
 
-let select_unfold_extern =
-  List.filter (function (_,{code = (Unfold_nth _ | Extern _)}) -> true | _ -> false)
-
 (* tell auto not to reuse already instantiated metas in unification (for
    compatibility, since otherwise, apply succeeds oftener) *)
 
 open Unification
 
 let auto_unif_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state; 
+  modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly = false;
   modulo_delta = empty_transparent_state;
+  resolve_evars = true;
+  use_evars_pattern_unification = false;
 }
 
 (* Try unification with the precompiled clause, then use registered Apply *)
 
-let unify_resolve_nodelta (c,clenv) gl = 
+let h_clenv_refine ev c clenv =
+  Refiner.abstract_tactic (TacApply (true,ev,[c,NoBindings],None))
+    (Clenvtac.clenv_refine ev clenv)
+
+let unify_resolve_nodelta (c,clenv) gl =
   let clenv' = connect_clenv gl clenv in
-  let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in  
-  h_simplest_apply c gl
+  let clenv'' = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in
+  h_clenv_refine false c clenv'' gl
 
-let unify_resolve flags (c,clenv) gl = 
+let unify_resolve flags (c,clenv) gl =
   let clenv' = connect_clenv gl clenv in
-  let _ = clenv_unique_resolver false ~flags clenv' gl in  
-  h_apply true false [inj_open c,NoBindings] gl
+  let clenv'' = clenv_unique_resolver false ~flags clenv' gl in
+  h_clenv_refine false c clenv'' gl
 
 let unify_resolve_gen = function
   | None -> unify_resolve_nodelta
   | Some flags -> unify_resolve flags
 
+(* Util *)
+
+let expand_constructor_hints lems =
+  list_map_append (fun lem ->
+    match kind_of_term lem with
+    | Ind ind ->
+	list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind)
+    | _ ->
+	[lem]) lems
+
 (* builds a hint database from a constr signature *)
 (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
 
 let add_hint_lemmas eapply lems hint_db gl =
-  let hintlist' = 
+  let lems = expand_constructor_hints lems in
+  let hintlist' =
     list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in
   Hint_db.add_list hintlist' hint_db
 
@@ -763,21 +812,21 @@ let make_local_hint_db eapply lems gl =
    terme pour l'affichage ? (HH) *)
 
 (* Si on enlève le dernier argument (gl) conclPattern est calculé une
-fois pour toutes : en particulier si Pattern.somatch produit une UserError 
+fois pour toutes : en particulier si Pattern.somatch produit une UserError
 Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même
 si après Intros la conclusion matche le pattern.
 *)
 
 (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
 
-let forward_interp_tactic = 
+let forward_interp_tactic =
   ref (fun _ -> failwith "interp_tactic is not installed for auto")
 
 let set_extern_interp f = forward_interp_tactic := f
 
 let conclPattern concl pat tac gl =
-  let constr_bindings = 
-    match pat with 
+  let constr_bindings =
+    match pat with
     | None -> []
     | Some pat ->
 	try matches pat concl
@@ -793,7 +842,7 @@ let conclPattern concl pat tac gl =
   de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
 
 let flags_of_state st =
-  {auto_unif_flags with 
+  {auto_unif_flags with
     modulo_conv_on_closed_terms = Some st; modulo_delta = st}
 
 let hintmap_of hdc concl =
@@ -802,34 +851,38 @@ let hintmap_of hdc concl =
   | Some hdc ->
       if occur_existential concl then Hint_db.map_all hdc
       else Hint_db.map_auto (hdc,concl)
-	
+
+let exists_evaluable_reference env = function
+  | EvalConstRef _ -> true
+  | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false
+
 let rec trivial_fail_db mod_delta db_list local_db gl =
-  let intro_tac = 
-    tclTHEN intro 
+  let intro_tac =
+    tclTHEN intro
       (fun g'->
 	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
 	 in trivial_fail_db mod_delta db_list (Hint_db.add_list hintl local_db) g')
   in
-  tclFIRST 
+  tclFIRST
     (assumption::intro_tac::
-     (List.map tclCOMPLETE 
+     (List.map tclCOMPLETE
        (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
 
 and my_find_search_nodelta db_list local_db hdc concl =
-  List.map (fun hint -> (None,hint)) 
+  List.map (fun hint -> (None,hint))
     (list_map_append (hintmap_of hdc concl) (local_db::db_list))
 
 and my_find_search mod_delta =
   if mod_delta then my_find_search_delta
   else my_find_search_nodelta
-    
+
 and my_find_search_delta db_list local_db hdc concl =
   let flags = {auto_unif_flags with use_metas_eagerly = true} in
   let f = hintmap_of hdc concl in
-    if occur_existential concl then 
+    if occur_existential concl then
       list_map_append
-	(fun db -> 
-	  if Hint_db.use_dn db then 
+	(fun db ->
+	  if Hint_db.use_dn db then
 	    let flags = flags_of_state (Hint_db.transparent_state db) in
 	      List.map (fun x -> (Some flags,x)) (f db)
 	  else
@@ -837,8 +890,8 @@ and my_find_search_delta db_list local_db hdc concl =
 	      List.map (fun x -> (Some flags,x)) (f db))
 	(local_db::db_list)
     else
-      list_map_append (fun db -> 
-	if Hint_db.use_dn db then 
+      list_map_append (fun db ->
+	if Hint_db.use_dn db then
 	  let flags = flags_of_state (Hint_db.transparent_state db) in
 	    List.map (fun x -> (Some flags, x)) (f db)
 	else
@@ -859,37 +912,40 @@ and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) =
   | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl)
   | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
   | Give_exact c  -> exact_check c
-  | Res_pf_THEN_trivial_fail (term,cl) -> 
-      tclTHEN 
+  | Res_pf_THEN_trivial_fail (term,cl) ->
+      tclTHEN
         (unify_resolve_gen flags (term,cl))
         (trivial_fail_db (flags <> None) db_list local_db)
-  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
+  | Unfold_nth c -> (fun gl ->
+      if exists_evaluable_reference (pf_env gl) c then
+	tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl
+      else tclFAIL 0 (str"Unbound reference") gl)
   | Extern tacast -> conclPattern concl p tacast
-      
-and trivial_resolve mod_delta db_list local_db cl = 
-  try 
-    let head = 
+
+and trivial_resolve mod_delta db_list local_db cl =
+  try
+    let head =
       try let hdconstr,_ = head_constr_bound cl in
 	    Some (head_of_constr_reference hdconstr)
       with Bound -> None
     in
       List.map (tac_of_hint db_list local_db cl)
-	(priority 
+	(priority
 	    (my_find_search mod_delta db_list local_db head cl))
   with Not_found -> []
 
 let trivial lems dbnames gl =
-  let db_list = 
+  let db_list =
     List.map
-      (fun x -> 
-	 try 
+      (fun x ->
+	 try
 	   searchtable_map x
-	 with Not_found -> 
+	 with Not_found ->
 	   error_no_such_hint_database x)
-      ("core"::dbnames) 
+      ("core"::dbnames)
   in
-  tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl 
-    
+  tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
+
 let full_trivial lems gl =
   let dbnames = Hintdbmap.dom !searchtable in
   let dbnames = list_subtract dbnames ["v62"] in
@@ -903,7 +959,7 @@ let gen_trivial lems = function
 let inj_open c = (Evd.empty,c)
 
 let h_trivial lems l =
-  Refiner.abstract_tactic (TacTrivial (List.map inj_open lems,l))
+  Refiner.abstract_tactic (TacTrivial (lems,l))
     (gen_trivial lems l)
 
 (**************************************************************************)
@@ -911,8 +967,8 @@ let h_trivial lems l =
 (**************************************************************************)
 
 let possible_resolve mod_delta db_list local_db cl =
-  try 
-    let head = 
+  try
+    let head =
       try let hdconstr,_ = head_constr_bound cl in
 	    Some (head_of_constr_reference hdconstr)
       with Bound -> None
@@ -931,19 +987,19 @@ let decomp_unary_term_then (id,_,typc) kont1 kont2 gl =
 	kont2 gl
   with UserError _ -> kont2 gl
 
-let decomp_empty_term (id,_,typc) gl = 
-  if Hipattern.is_empty_type typc then 
-    simplest_case (mkVar id) gl 
-  else 
+let decomp_empty_term (id,_,typc) gl =
+  if Hipattern.is_empty_type typc then
+    simplest_case (mkVar id) gl
+  else
     errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.")
 
 let extend_local_db gl decl db =
   Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db
 
-(* Try to decompose hypothesis [decl] into atomic components of a 
-   conjunction with maximum depth [p] (or solve the goal from an 
-   empty type) then call the continuation tactic with hint db extended 
-   with the obtappined not-further-decomposable hypotheses *)
+(* Try to decompose hypothesis [decl] into atomic components of a
+   conjunction with maximum depth [p] (or solve the goal from an
+   empty type) then call the continuation tactic with hint db extended
+   with the obtained not-further-decomposable hypotheses *)
 
 let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl =
   if p = 0 then
@@ -962,7 +1018,7 @@ and intros_decomp p kont decls db n =
   if n = 0 then
     decomp_and_register_decls p kont decls db
   else
-    tclTHEN intro (tclLAST_DECL (fun d ->
+    tclTHEN intro (onLastDecl (fun d ->
       (intros_decomp p kont (d::decls) db (n-1))))
 
 (* Decompose hypotheses [hyps] with maximum depth [p] and
@@ -973,21 +1029,21 @@ and decomp_and_register_decls p kont decls =
   List.fold_left (decomp_and_register_decl p) kont decls
 
 
-(* decomp is an natural number giving an indication on decomposition 
+(* decomp is an natural number giving an indication on decomposition
    of conjunction in hypotheses, 0 corresponds to no decomposition *)
 (* n is the max depth of search *)
 (* local_db contains the local Hypotheses *)
 
 exception Uplift of tactic list
 
-let rec search_gen p n mod_delta db_list local_db =
-  let rec search n local_db gl =
-    if n=0 then error "BOUND 2";
-    tclFIRST
-      (assumption ::
-       intros_decomp p (search n) [] local_db 1 ::
-       List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) 
-	(possible_resolve mod_delta db_list local_db (pf_concl gl))) gl
+let search_gen p n mod_delta db_list local_db =
+  let rec search n local_db =
+    if n=0 then (fun gl -> error "BOUND 2") else
+      tclORELSE0 assumption
+	(tclORELSE0 (intros_decomp p (search n) [] local_db 1)
+	   (fun gl -> tclFIRST
+	      (List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db))
+		 (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl))
   in
   search n local_db
 
@@ -996,14 +1052,14 @@ let search = search_gen 0
 let default_search_depth = ref 5
 
 let delta_auto mod_delta n lems dbnames gl =
-  let db_list = 
+  let db_list =
     List.map
-      (fun x -> 
-	 try 
+      (fun x ->
+	 try
 	   searchtable_map x
-	 with Not_found -> 
+	 with Not_found ->
 	   error_no_such_hint_database x)
-      ("core"::dbnames) 
+      ("core"::dbnames)
   in
   tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
@@ -1013,7 +1069,7 @@ let new_auto = delta_auto true
 
 let default_auto = auto !default_search_depth [] []
 
-let delta_full_auto mod_delta n lems gl = 
+let delta_full_auto mod_delta n lems gl =
   let dbnames = Hintdbmap.dom !searchtable in
   let dbnames = list_subtract dbnames ["v62"] in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
@@ -1033,25 +1089,25 @@ let gen_auto n lems dbnames =
 let inj_or_var = Option.map (fun n -> ArgArg n)
 
 let h_auto n lems l =
-  Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map inj_open lems,l))
+  Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l))
     (gen_auto n lems l)
 
 (**************************************************************************)
 (*                  The "destructing Auto" from Eduardo                   *)
 (**************************************************************************)
 
-(* Depth of search after decomposition of hypothesis, by default 
-   one look for an immediate solution *) 
+(* Depth of search after decomposition of hypothesis, by default
+   one look for an immediate solution *)
 let default_search_decomp = ref 20
 
-let destruct_auto p lems n gl = 
+let destruct_auto p lems n gl =
   decomp_and_register_decls p (fun local_db gl ->
     search_gen p n false (List.map searchtable_map ["core";"extcore"])
       (add_hint_lemmas false lems local_db gl) gl)
     (pf_hyps gl)
     (Hint_db.empty empty_transparent_state false)
     gl
-    
+
 let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n)
 
 let dauto (n,p) lems =
@@ -1062,7 +1118,7 @@ let dauto (n,p) lems =
 let default_dauto = dauto (None,None) []
 
 let h_dauto (n,p) lems =
-  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map inj_open lems))
+  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,lems))
     (dauto (n,p) lems)
 
 (***************************************)
@@ -1070,41 +1126,37 @@ let h_dauto (n,p) lems =
 (***************************************)
 
 let make_resolve_any_hyp env sigma (id,_,ty) =
-  let ents = 
+  let ents =
     map_succeed
-      (fun f -> f (mkVar id,ty)) 
-      [make_exact_entry None; make_apply_entry env sigma (true,true,false) None]
-  in 
+      (fun f -> f (mkVar id,ty))
+      [make_exact_entry sigma None; make_apply_entry env sigma (true,true,false) None]
+  in
   ents
 
 type autoArguments =
-  | UsingTDB       
-  | Destructing   
-
-let keepAfter tac1 tac2 = 
-  (tclTHEN tac1 
-     (function g -> tac2 [pf_last_hyp g] g))
+  | UsingTDB
+  | Destructing
 
 let compileAutoArg contac = function
-  | Destructing -> 
-      (function g -> 
-         let ctx = pf_hyps g in  
-	 tclFIRST 
-           (List.map 
-              (fun (id,_,typ) -> 
-                let cl = snd (decompose_prod typ) in
+  | Destructing ->
+      (function g ->
+         let ctx = pf_hyps g in
+	 tclFIRST
+           (List.map
+              (fun (id,_,typ) ->
+                let cl = (strip_prod_assum typ) in
                  if Hipattern.is_conjunction cl
-		 then 
-		   tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] 
-                 else 
+		 then
+		   tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac]
+                 else
 		   tclFAIL 0 (pr_id id ++ str" is not a conjunction"))
 	     ctx) g)
-  | UsingTDB ->  
-      (tclTHEN  
-         (Tacticals.tryAllClauses 
-            (function 
-               | Some ((_,id),_) -> Dhyp.h_destructHyp false id
-               | None          -> Dhyp.h_destructConcl))
+  | UsingTDB ->
+      (tclTHEN
+         (Tacticals.tryAllHypsAndConcl
+            (function
+               | Some id -> Dhyp.h_destructHyp false id
+               | None    -> Dhyp.h_destructConcl))
          contac)
 
 let compileAutoArgList contac = List.map (compileAutoArg contac)
@@ -1114,20 +1166,20 @@ let rec super_search n db_list local_db argl gl =
   tclFIRST
     (assumption
      ::
-     tclTHEN intro 
-        (fun g -> 
+     tclTHEN intro
+        (fun g ->
 	   let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in
 	   super_search n db_list (Hint_db.add_list hintl local_db)
 	     argl g)
      ::
-     List.map (fun ntac -> 
-            tclTHEN ntac 
+     List.map (fun ntac ->
+            tclTHEN ntac
               (super_search (n-1) db_list local_db argl))
          (possible_resolve false db_list local_db (pf_concl gl))
       @
       compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl
 
-let search_superauto n to_add argl g = 
+let search_superauto n to_add argl g =
   let sigma =
     List.fold_right
       (fun (id,c) -> add_named_decl (id, None, pf_type_of g c))
@@ -1136,14 +1188,12 @@ let search_superauto n to_add argl g =
   let db = Hint_db.add_list db0 (make_local_hint_db false [] g) in
   super_search n [Hintdbmap.find "core" !searchtable] db argl g
 
-let superauto n to_add argl  = 
+let superauto n to_add argl  =
   tclTRY (tclCOMPLETE (search_superauto n to_add argl))
 
-let default_superauto g = superauto !default_search_depth [] [] g
-
 let interp_to_add gl r =
-  let r = Syntax_def.locate_global_with_alias (qualid_of_reference r) in
-  let id = id_of_global r in
+  let r = locate_global_with_alias (qualid_of_reference r) in
+  let id = basename_of_global r in
   (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r)
 
 let gen_superauto nopt l a b gl =
diff --git a/tactics/auto.mli b/tactics/auto.mli
index 132b9063..072e0298 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -23,26 +23,26 @@ open Libnames
 open Vernacexpr
 open Mod_subst
 (*i*)
-  
-type auto_tactic = 
+
+type auto_tactic =
   | Res_pf     of constr * clausenv    (* Hint Apply *)
   | ERes_pf    of constr * clausenv    (* Hint EApply *)
-  | Give_exact of constr                  
+  | Give_exact of constr
   | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
   | Unfold_nth of evaluable_global_reference          (* Hint Unfold *)
   | Extern     of Tacexpr.glob_tactic_expr   (* Hint Extern *)
 
 open Rawterm
 
-type pri_auto_tactic = { 
+type pri_auto_tactic = {
   pri   : int;            (* A number between 0 and 4, 4 = lower priority *)
   pat   : constr_pattern option; (* A pattern for the concl of the Goal *)
   code  : auto_tactic;    (* the tactic to apply when the concl matches pat *)
 }
 
-type stored_data = pri_auto_tactic 
+type stored_data = pri_auto_tactic
 
-type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
+type search_entry
 
 (* The head may not be bound. *)
 
@@ -63,26 +63,40 @@ module Hint_db :
     val use_dn : t -> bool
     val transparent_state : t -> transparent_state
     val set_transparent_state : t -> transparent_state -> t
+
+    val unfolds : t -> Idset.t * Cset.t
   end
 
 type hint_db_name = string
 
 type hint_db = Hint_db.t
 
+type hints_entry =
+  | HintsResolveEntry of (int option * bool * constr) list
+  | HintsImmediateEntry of constr list
+  | HintsUnfoldEntry of evaluable_global_reference list
+  | HintsTransparencyEntry of evaluable_global_reference list * bool
+  | HintsExternEntry of
+      int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
+  | HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location *
+      (patvar list * constr_pattern) * Tacexpr.glob_tactic_expr
+
 val searchtable_map : hint_db_name -> hint_db
 
 val searchtable_add : (hint_db_name * hint_db) -> unit
 
-(* [create_hint_db local name st use_dn]. 
+(* [create_hint_db local name st use_dn].
    [st] is a transparency state for unification using this db
-   [use_dn] switches the use of the discrimination net for all hints 
+   [use_dn] switches the use of the discrimination net for all hints
    and patterns. *)
 
 val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit
 
 val current_db_names : unit -> hint_db_name list
 
-val add_hints : locality_flag -> hint_db_name list -> hints -> unit
+val interp_hints : hints_expr -> hints_entry
+
+val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
 
 val print_searchtable : unit -> unit
 
@@ -92,19 +106,21 @@ val print_hint_ref : global_reference -> unit
 
 val print_hint_db_by_name : hint_db_name -> unit
 
-(* [make_exact_entry pri (c, ctyp)]. 
+val print_hint_db : Hint_db.t -> unit
+
+(* [make_exact_entry pri (c, ctyp)].
    [c] is the term given as an exact proof to solve the goal;
    [ctyp] is the type of [c]. *)
 
-val make_exact_entry : int option -> constr * constr -> hint_entry
+val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry
 
 (* [make_apply_entry (eapply,verbose) pri (c,cty)].
    [eapply] is true if this hint will be used only with EApply;
-   [hnf] should be true if we should expand the head of cty before searching for 
+   [hnf] should be true if we should expand the head of cty before searching for
    products;
    [c] is the term given as an exact proof to solve the goal;
    [cty] is the type of [c]. *)
-  
+
 val make_apply_entry :
   env -> evar_map -> bool * bool * bool -> int option -> constr * constr
       -> hint_entry
@@ -117,7 +133,7 @@ val make_apply_entry :
        has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> bool * bool * bool -> int option -> constr -> 
+  env -> evar_map -> bool * bool * bool -> int option -> constr ->
       hint_entry list
 
 (* [make_resolve_hyp hname htyp].
@@ -125,7 +141,7 @@ val make_resolves :
    Never raises a user exception;
    If the hyp cannot be used as a Hint, the empty list is returned. *)
 
-val make_resolve_hyp : 
+val make_resolve_hyp :
   env -> evar_map -> named_declaration -> hint_entry list
 
 (* [make_extern pri pattern tactic_expr] *)
@@ -163,7 +179,7 @@ val unify_resolve_nodelta : (constr * clausenv) -> tactic
 val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
 
 (* [ConclPattern concl pat tacast]:
-   if the term concl matches the pattern pat, (in sense of 
+   if the term concl matches the pattern pat, (in sense of
    [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
    right values to build a tactic *)
 
@@ -187,7 +203,7 @@ val full_auto : int -> constr list -> tactic
    and doing delta *)
 val new_full_auto : int -> constr list -> tactic
 
-(* auto with default search depth and with all hint databases 
+(* auto with default search depth and with all hint databases
    except the "v62" compatibility database *)
 val default_full_auto : tactic
 
@@ -216,8 +232,8 @@ val h_dauto : int option * int option -> constr list -> tactic
 (* SuperAuto *)
 
 type autoArguments =
-  | UsingTDB       
-  | Destructing   
+  | UsingTDB
+  | Destructing
 
 (*
 val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 4759b6da..b0645744 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: autorewrite.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Equality
 open Hipattern
@@ -25,83 +25,119 @@ open Tacexpr
 open Mod_subst
 
 (* Rewriting rules *)
-(* the type is the statement of the lemma constr. Used to elim duplicates. *)
-type rew_rule = constr * types * bool * glob_tactic_expr
+type rew_rule = { rew_lemma: constr;
+		  rew_type: types;
+		  rew_pat: constr;
+		  rew_l2r: bool;
+		  rew_tac: glob_tactic_expr }
+
+let subst_hint subst hint =
+  let cst' = subst_mps subst hint.rew_lemma in
+  let typ' = subst_mps subst hint.rew_type in
+  let pat' = subst_mps subst hint.rew_pat in
+  let t' = Tacinterp.subst_tactic subst hint.rew_tac in
+    if hint.rew_lemma == cst' && hint.rew_tac == t' then hint else
+      { hint with
+	rew_lemma = cst'; rew_type = typ';
+	rew_pat = pat';	rew_tac = t' }
+
+module HintIdent =
+struct
+  type t = int * rew_rule
+
+  let compare (i,t) (i',t') =
+    Pervasives.compare i i'
+(*     Pervasives.compare t.rew_lemma t'.rew_lemma *)
+
+  let subst s (i,t) = (i,subst_hint s t)
+
+  let constr_of (i,t) = t.rew_pat
+end
+
+module HintOpt =
+struct
+  let reduce c = c
+  let direction = true
+end
+
+module HintDN = Term_dnet.Make(HintIdent)(HintOpt)
 
 (* Summary and Object declaration *)
 let rewtab =
-  ref (Stringmap.empty : rew_rule list Stringmap.t)
+  ref (Stringmap.empty : HintDN.t Stringmap.t)
 
-let _ = 
+let _ =
   let init () = rewtab := Stringmap.empty in
   let freeze () = !rewtab in
   let unfreeze fs = rewtab := fs in
   Summary.declare_summary "autorewrite"
     { Summary.freeze_function   = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init;
-      Summary.survive_module = false;
-      Summary.survive_section   = false }
+      Summary.init_function     = init }
 
-let print_rewrite_hintdb bas =
- try
-  let hints = Stringmap.find bas !rewtab in
-   ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++
-    prlist_with_sep Pp.cut
-     (fun (c,typ,d,t) ->
-       str (if d then "rewrite -> " else "rewrite <- ") ++
-       Printer.pr_lconstr c ++ str " of type " ++ Printer.pr_lconstr typ ++
-       str " then use tactic " ++ 
-       Pptactic.pr_glob_tactic (Global.env()) t) hints)
+let find_base bas =
+ try Stringmap.find bas !rewtab
  with
-  Not_found -> 
-   errorlabstrm "AutoRewrite" 
+  Not_found ->
+   errorlabstrm "AutoRewrite"
      (str ("Rewriting base "^(bas)^" does not exist."))
 
-type raw_rew_rule = constr * bool * raw_tactic_expr
+let find_rewrites bas =
+  List.rev_map snd (HintDN.find_all (find_base bas))
+
+let find_matches bas pat =
+  let base = find_base bas in
+  let res = HintDN.search_pattern base pat in
+    List.map (fun ((_,rew), esubst, subst) -> rew) res
+
+let print_rewrite_hintdb bas =
+  ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++
+	   prlist_with_sep Pp.cut
+	   (fun h ->
+	     str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++
+	       Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++
+	       str " then use tactic " ++
+	       Pptactic.pr_glob_tactic (Global.env()) h.rew_tac)
+	   (find_rewrites bas))
+
+type raw_rew_rule = loc * constr * bool * raw_tactic_expr
 
 (* Applies all the rules of one base *)
 let one_base general_rewrite_maybe_in tac_main bas =
-  let lrul =
-    try
-      Stringmap.find bas !rewtab
-    with Not_found ->
-      errorlabstrm "AutoRewrite"
-        (str ("Rewriting base "^(bas)^" does not exist."))
-  in
-  let lrul = List.map (fun (c,_,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrul in
+  let lrul = find_rewrites bas in
+  let lrul = List.map (fun h -> (h.rew_lemma,h.rew_l2r,Tacinterp.eval_tactic h.rew_tac)) lrul in
     tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
       tclTHEN tac
-        (tclREPEAT_MAIN 
-	  (tclTHENSFIRSTn (general_rewrite_maybe_in dir csr) [|tac_main|] tc)))
+        (tclREPEAT_MAIN
+	    (tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main)))
       tclIDTAC lrul))
 
-
-
 (* The AutoRewrite tactic *)
-let autorewrite tac_main lbas =
+let autorewrite ?(conds=Naive) tac_main lbas =
   tclREPEAT_MAIN (tclPROGRESS
-    (List.fold_left (fun tac bas -> 
+    (List.fold_left (fun tac bas ->
        tclTHEN tac
-        (one_base (fun dir -> general_rewrite dir all_occurrences)
+        (one_base (fun dir c tac ->
+	  let tac = tac, conds in
+	    general_rewrite dir all_occurrences false ~tac c)
 	  tac_main bas))
       tclIDTAC lbas))
 
-let autorewrite_multi_in idl tac_main lbas : tactic =
-  fun gl -> 
+let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
+  fun gl ->
  (* let's check at once if id exists (to raise the appropriate error) *)
  let _ = List.map (Tacmach.pf_get_hyp gl) idl in
  let general_rewrite_in id =
   let id = ref id in
   let to_be_cleared = ref false in
-   fun dir cstr gl ->
+   fun dir cstr tac gl ->
     let last_hyp_id =
      match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with
         (last_hyp_id,_,_)::_ -> last_hyp_id
       | _ -> (* even the hypothesis id is missing *)
              error ("No such hypothesis: " ^ (string_of_id !id) ^".")
     in
-    let gl' = general_rewrite_in dir all_occurrences !id cstr false gl in
+    let gl' = general_rewrite_in dir all_occurrences ~tac:(tac, conds) false !id cstr false gl in
     let gls = (fst gl').Evd.it in
     match gls with
        g::_ ->
@@ -125,109 +161,152 @@ let autorewrite_multi_in idl tac_main lbas : tactic =
           | _ -> assert false) (* there must be at least an hypothesis *)
      | _ -> assert false (* rewriting cannot complete a proof *)
  in
- tclMAP (fun id -> 
+ tclMAP (fun id ->
   tclREPEAT_MAIN (tclPROGRESS
-    (List.fold_left (fun tac bas -> 
+    (List.fold_left (fun tac bas ->
        tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas)))
    idl gl
 
-let autorewrite_in id = autorewrite_multi_in [id]
+let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id]
 
-let gen_auto_multi_rewrite tac_main lbas cl = 
-  let try_do_hyps treat_id l = 
-    autorewrite_multi_in (List.map treat_id l) tac_main lbas
-  in 
+let gen_auto_multi_rewrite conds tac_main lbas cl =
+  let try_do_hyps treat_id l =
+    autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas
+  in
   if cl.concl_occs <> all_occurrences_expr &
      cl.concl_occs <> no_occurrences_expr
-  then 
+  then
     error "The \"at\" syntax isn't available yet for the autorewrite tactic."
-  else 
-    let compose_tac t1 t2 = 
-      match cl.onhyps with 
-	| Some [] -> t1 
+  else
+    let compose_tac t1 t2 =
+      match cl.onhyps with
+	| Some [] -> t1
 	| _ ->      tclTHENFIRST t1 t2
     in
     compose_tac
-	(if cl.concl_occs <> no_occurrences_expr then autorewrite tac_main lbas else tclIDTAC)
-	(match cl.onhyps with 
+	(if cl.concl_occs <> no_occurrences_expr then autorewrite ~conds tac_main lbas else tclIDTAC)
+	(match cl.onhyps with
 	   | Some l -> try_do_hyps (fun ((_,id),_) -> id) l
-	   | None -> 
-	       fun gl -> 
-		 (* try to rewrite in all hypothesis 
+	   | None ->
+	       fun gl ->
+		 (* try to rewrite in all hypothesis
 		    (except maybe the rewritten one) *)
 		 let ids =  Tacmach.pf_ids_of_hyps gl
 		 in try_do_hyps (fun id -> id)  ids gl)
 
-let auto_multi_rewrite = gen_auto_multi_rewrite Refiner.tclIDTAC
+let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds Refiner.tclIDTAC
 
-let auto_multi_rewrite_with tac_main lbas cl gl =
+let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl =
   let onconcl = cl.Tacexpr.concl_occs <> no_occurrences_expr in
-  match onconcl,cl.Tacexpr.onhyps with 
-    | false,Some [_] | true,Some [] | false,Some [] ->   
-	(* autorewrite with .... in clause using tac n'est sur que 
-	   si clause represente soit le but soit UNE hypothese 
+  match onconcl,cl.Tacexpr.onhyps with
+    | false,Some [_] | true,Some [] | false,Some [] ->
+	(* autorewrite with .... in clause using tac n'est sur que
+	   si clause represente soit le but soit UNE hypothese
 	*)
-	gen_auto_multi_rewrite tac_main  lbas cl gl
-    | _ -> 
-	    Util.errorlabstrm "autorewrite" 
+	gen_auto_multi_rewrite conds tac_main lbas cl gl
+    | _ ->
+	    Util.errorlabstrm "autorewrite"
 	      (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.")
 
-
 (* Functions necessary to the library object declaration *)
 let cache_hintrewrite (_,(rbase,lrl)) =
-  let l = 
-    try 
-      let oldl = Stringmap.find rbase !rewtab in
-      let lrl =
-       List.map
-        (fun (c,dummy,b,t) ->
-          (* here we substitute the dummy value with the right one *)
-          c,Typing.type_of (Global.env ()) Evd.empty c,b,t) lrl in
-      (List.filter
-          (fun (_,typ,_,_) ->
-            not (List.exists (fun (_,typ',_,_) -> Term.eq_constr typ typ') oldl)
-          ) lrl) @ oldl
-    with
-      | Not_found -> lrl
-  in
-    rewtab:=Stringmap.add rbase l !rewtab
-
-let export_hintrewrite x = Some x
-
-let subst_hintrewrite (_,subst,(rbase,list as node)) = 
-  let subst_first (cst,typ,b,t as pair) = 
-    let cst' = subst_mps subst cst in
-    let typ' =
-     (* here we do not have the environment and Global.env () is not the
-        one where cst' lives in. Thus we can just put a dummy value and
-        override it in cache_hintrewrite *)
-     typ (* dummy value, it will be recomputed by cache_hintrewrite *) in
-    let t' = Tacinterp.subst_tactic subst t in
-      if cst == cst' && t == t' then pair else
-	(cst',typ',b,t')
-  in
-  let list' = list_smartmap subst_first list in
+  let base = try find_base rbase with _ -> HintDN.empty in
+  let max = try fst (Util.list_last (HintDN.find_all base)) with _ -> 0 in
+  let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in
+    rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab
+
+
+let subst_hintrewrite (subst,(rbase,list as node)) =
+  let list' = HintDN.subst subst list in
     if list' == list then node else
       (rbase,list')
-      
-let classify_hintrewrite (_,x) = Libobject.Substitute x
+
+let classify_hintrewrite x = Libobject.Substitute x
 
 
 (* Declaration of the Hint Rewrite library object *)
-let (inHintRewrite,outHintRewrite)=
+let (inHintRewrite,_)=
   Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with
-       Libobject.cache_function = cache_hintrewrite;
-       Libobject.load_function = (fun _ -> cache_hintrewrite);
-       Libobject.subst_function = subst_hintrewrite;
-       Libobject.classify_function = classify_hintrewrite;
-       Libobject.export_function = export_hintrewrite }
+    Libobject.cache_function = cache_hintrewrite;
+    Libobject.load_function = (fun _ -> cache_hintrewrite);
+    Libobject.subst_function = subst_hintrewrite;
+    Libobject.classify_function = classify_hintrewrite }
+
+
+open Clenv
+
+type hypinfo = {
+  hyp_cl : clausenv;
+  hyp_prf : constr;
+  hyp_ty : types;
+  hyp_car : constr;
+  hyp_rel : constr;
+  hyp_l2r : bool;
+  hyp_left : constr;
+  hyp_right : constr;
+}
+
+let evd_convertible env evd x y =
+  try
+    ignore(Unification.w_unify true env Reduction.CONV x y evd); true 
+  (* try ignore(Evarconv.the_conv_x env x y evd); true *)
+  with _ -> false
+
+let decompose_applied_relation metas env sigma c ctype left2right =
+  let find_rel ty =
+    let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in
+    let eqclause =
+      if metas then eqclause
+      else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd)
+    in
+    let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
+    let rec split_last_two = function
+      | [c1;c2] -> [],(c1, c2)
+      | x::y::z ->
+	  let l,res = split_last_two (y::z) in x::l, res
+      | _ -> raise Not_found
+    in
+      try
+	let others,(c1,c2) = split_last_two args in
+	let ty1, ty2 =
+	  Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
+	in
+(* 	  if not (evd_convertible env eqclause.evd ty1 ty2) then None *)
+(* 	  else *)
+	    Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty;
+		   hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others);
+		   hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; }
+      with Not_found -> None
+  in
+    match find_rel ctype with
+    | Some c -> Some c
+    | None ->
+	let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *)
+	match find_rel (it_mkProd_or_LetIn t' ctx) with
+	| Some c -> Some c
+	| None -> None
+
+let find_applied_relation metas loc env sigma c left2right =
+  let ctype = Typing.type_of env sigma c in
+    match decompose_applied_relation metas env sigma c ctype left2right with
+    | Some c -> c
+    | None ->
+	user_err_loc (loc, "decompose_applied_relation",
+		     str"The type" ++ spc () ++ Printer.pr_constr_env env ctype ++
+		       spc () ++ str"of this term does not end with an applied relation.")
 
 (* To add rewriting rules to a base *)
 let add_rew_rules base lrul =
+  let counter = ref 0 in
   let lrul =
-   List.rev_map
-    (fun (c,b,t) ->
-      (c,mkProp (* dummy value *), b,Tacinterp.glob_tactic t)
-    ) lrul
-  in
-   Lib.add_anonymous_leaf (inHintRewrite (base,lrul))
+    List.fold_left
+      (fun dn (loc,c,b,t) ->
+	let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in
+	let pat = if b then info.hyp_left else info.hyp_right in
+	let rul = { rew_lemma = c; rew_type = info.hyp_ty;
+		    rew_pat = pat; rew_l2r = b;
+		    rew_tac = Tacinterp.glob_tactic t}
+	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 f402a35d..cf0d58cc 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -6,25 +6,60 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: autorewrite.mli 9073 2006-08-22 08:54:29Z jforest $ i*)
+(*i $Id$ i*)
 
 (*i*)
+open Term
+open Tacexpr
 open Tacmach
+open Equality
 (*i*)
 
 (* Rewriting rules before tactic interpretation *)
-type raw_rew_rule = Term.constr * bool * Tacexpr.raw_tactic_expr
+type raw_rew_rule = Util.loc * Term.constr * bool * Tacexpr.raw_tactic_expr
 
 (* To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
 
-(* The AutoRewrite tactic *)
-val autorewrite : tactic -> string list -> tactic
-val autorewrite_in : Names.identifier -> tactic -> string list -> tactic
+(* The AutoRewrite tactic.
+   The optional conditions tell rewrite how to handle matching and side-condition solving.
+   Default is Naive: first match in the clause, don't look at the side-conditions to
+   tell if the rewrite succeeded. *)
+val autorewrite : ?conds:conditions -> tactic -> string list -> tactic
+val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic
 
+(* Rewriting rules *)
+type rew_rule = { rew_lemma: constr;
+		  rew_type: types;
+		  rew_pat: constr;
+		  rew_l2r: bool;
+		  rew_tac: glob_tactic_expr }
 
-val auto_multi_rewrite : string list -> Tacticals.clause -> tactic
+val find_rewrites : string -> rew_rule list
 
-val auto_multi_rewrite_with : tactic -> string list -> Tacticals.clause -> tactic
+val find_matches : string -> constr -> rew_rule list
+
+val auto_multi_rewrite : ?conds:conditions -> string list -> Tacticals.clause -> tactic
+
+val auto_multi_rewrite_with : ?conds:conditions -> tactic -> string list -> Tacticals.clause -> tactic
 
 val print_rewrite_hintdb : string -> unit
+
+open Clenv
+
+
+type hypinfo = {
+  hyp_cl : clausenv;
+  hyp_prf : constr;
+  hyp_ty : types;
+  hyp_car : constr;
+  hyp_rel : constr;
+  hyp_l2r : bool;
+  hyp_left : constr;
+  hyp_right : constr;
+}
+
+val find_applied_relation : bool ->
+  Util.loc ->
+  Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo
+
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index a0aecbbc..bcb9a411 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: btermdn.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
+(* $Id$ *)
 
 open Term
 open Names
@@ -19,72 +19,135 @@ open Libnames
    Eduardo (5/8/97). *)
 
 let dnet_depth = ref 8
-		   
-let bounded_constr_pat_discr_st st (t,depth) =
-  if depth = 0 then 
-    None 
-  else
-    match constr_pat_discr_st st t with
-      | None -> None
-      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
-	    
-let bounded_constr_val_discr_st st (t,depth) =
-  if depth = 0 then 
-    Dn.Nothing 
-  else
-    match constr_val_discr_st st t with
-      | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
-      | Dn.Nothing -> Dn.Nothing
-      | Dn.Everything -> Dn.Everything
 
-let bounded_constr_pat_discr (t,depth) =
-  if depth = 0 then 
-    None 
-  else
-    match constr_pat_discr t with
-      | None -> None
-      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
-	    
-let bounded_constr_val_discr (t,depth) =
-  if depth = 0 then 
-    Dn.Nothing 
-  else
-    match constr_val_discr t with
-      | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
-      | Dn.Nothing -> Dn.Nothing
-      | Dn.Everything -> Dn.Everything
 
-type 'a t = (global_reference,constr_pattern * int,'a) Dn.t
-  
-let create = Dn.create
+module Make =
+  functor (Z : Map.OrderedType) ->
+struct
+  module Term_dn = Termdn.Make(Z)
+
+  module X = struct
+    type t = constr_pattern*int
+    let compare = Pervasives.compare 
+  end
+
+ module Y = struct 
+     type t = Term_dn.term_label
+     let compare x y = 
+       let make_name n =
+	 match n with
+	 | Term_dn.GRLabel(ConstRef con) -> 
+	     Term_dn.GRLabel(ConstRef(constant_of_kn(canonical_con con)))
+	 | Term_dn.GRLabel(IndRef (kn,i)) ->
+	     Term_dn.GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
+	 | Term_dn.GRLabel(ConstructRef ((kn,i),j ))->
+	     Term_dn.GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
+	 | k -> k
+       in
+	 Pervasives.compare (make_name x) (make_name y)
+ end
+ 
+ module Dn = Dn.Make(X)(Y)(Z)
   
-let add = function
-  | None -> 
-      (fun dn (c,v) -> 
-	Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v))
-  | Some st -> 
-      (fun dn (c,v) -> 
-	Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
+ type t = Dn.t
 
-let rmv = function
-  | None -> 
-      (fun dn (c,v) -> 
-	Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v))
-  | Some st -> 
-      (fun dn (c,v) -> 
-	Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
+  let create = Dn.create
 
-let lookup = function
-  | None -> 
-      (fun dn t ->
-	List.map 
-	  (fun ((c,_),v) -> (c,v)) 
-	  (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)))
-  | Some st -> 
-      (fun dn t ->
-	List.map 
-	  (fun ((c,_),v) -> (c,v)) 
-	  (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)))
+  let decomp = 
+    let rec decrec acc c = match kind_of_term c with
+      | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+      | Cast (c1,_,_) -> decrec acc c1
+      | _ -> (c,acc)
+    in 
+      decrec []
 
-let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn
+  let constr_val_discr t =
+    let c, l = decomp t in
+      match kind_of_term c with
+      | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+      | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+      | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+      | Const _ -> Dn.Everything
+      | _ -> Dn.Nothing
+	
+  let constr_val_discr_st (idpred,cpred) t =
+    let c, l = decomp t in
+      match kind_of_term c with
+      | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
+      | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+      | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+      | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+      | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
+      | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
+      | Sort s when is_small s -> Dn.Label(Term_dn.SortLabel (Some s), [])
+      | Sort _ -> Dn.Label(Term_dn.SortLabel None, [])
+      | Evar _ -> Dn.Everything
+      | _ -> Dn.Nothing
 
+  let bounded_constr_pat_discr_st st (t,depth) =
+    if depth = 0 then 
+      None 
+    else
+      match Term_dn.constr_pat_discr_st st t with
+	| None -> None
+	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+	    
+  let bounded_constr_val_discr_st st (t,depth) =
+    if depth = 0 then 
+      Dn.Nothing 
+    else
+      match constr_val_discr_st st t with
+	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
+	| Dn.Nothing -> Dn.Nothing
+	| Dn.Everything -> Dn.Everything
+
+  let bounded_constr_pat_discr (t,depth) =
+    if depth = 0 then 
+      None 
+    else
+      match Term_dn.constr_pat_discr t with
+	| None -> None
+	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+	    
+  let bounded_constr_val_discr (t,depth) =
+    if depth = 0 then 
+      Dn.Nothing 
+    else
+      match constr_val_discr t with
+	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
+	| Dn.Nothing -> Dn.Nothing
+	| Dn.Everything -> Dn.Everything
+	    
+	    
+  let add = function
+    | None -> 
+	(fun dn (c,v) -> 
+	   Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v))
+    | Some st -> 
+	(fun dn (c,v) -> 
+	   Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
+	  
+  let rmv = function
+    | None -> 
+	(fun dn (c,v) -> 
+	   Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v))
+    | Some st -> 
+	(fun dn (c,v) -> 
+	 Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
+	  
+  let lookup = function
+    | None -> 
+	(fun dn t ->
+	   List.map 
+	     (fun ((c,_),v) -> (c,v)) 
+	     (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)))
+    | Some st -> 
+	(fun dn t ->
+	   List.map 
+	     (fun ((c,_),v) -> (c,v)) 
+	     (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)))
+	  
+  let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn
+    
+end
+    
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index 959f7d10..ebded23a 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: btermdn.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -15,15 +15,19 @@ open Names
 (*i*)
 
 (* Discrimination nets with bounded depth. *)
+module Make :
+  functor (Z : Map.OrderedType) ->
+sig
+  type t
 
-type 'a t
+  val create : unit ->  t
 
-val create : unit -> 'a t
-
-val add : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t
-val rmv : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t
-  
-val lookup : transparent_state option -> 'a t -> constr -> (constr_pattern * 'a) list
-val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
+  val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t
+  val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t
 
+  val lookup : transparent_state option -> t -> constr -> (constr_pattern * Z.t) list
+  val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
+end
+    
 val dnet_depth : int ref
+
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
index b7eb3620..55558764 100644
--- a/tactics/class_tactics.ml4
+++ b/tactics/class_tactics.ml4
@@ -9,7 +9,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: class_tactics.ml4 12189 2009-06-15 05:08:44Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -43,21 +43,50 @@ open Evd
 let default_eauto_depth = 100
 let typeclasses_db = "typeclass_instances"
 
-let _ = Auto.auto_init := (fun () -> 
+let _ = Auto.auto_init := (fun () ->
   Auto.create_hint_db false typeclasses_db full_transparent_state true)
 
-let check_required_library d =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-  if not (Library.library_is_loaded dir) then
-    error ("Library "^(list_last d)^" has to be required first.")
+exception Found of evar_map
+
+let is_dependent ev evm =
+  Evd.fold (fun ev' evi dep ->
+    if ev = ev' then dep
+    else dep || occur_evar ev evi.evar_concl)
+    evm false
+
+let valid goals p res_sigma l =
+  let evm =
+    List.fold_left2
+      (fun sigma (ev, evi) prf ->
+	let cstr, obls = Refiner.extract_open_proof !res_sigma prf in
+	  if not (Evd.is_defined sigma ev) then
+	    Evd.define ev cstr sigma
+	  else sigma)
+      !res_sigma goals l
+  in raise (Found evm)
+
+let evar_filter evi =
+  let hyps' = evar_filtered_context evi in
+    { evi with 
+      evar_hyps = Environ.val_of_named_context hyps';
+      evar_filter = List.map (fun _ -> true) hyps' }
       
-let classes_dirpath =
-  make_dirpath (List.map id_of_string ["Classes";"Coq"])
-  
-let init_setoid () =
-  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
-  else check_required_library ["Coq";"Setoids";"Setoid"]
+let evars_to_goals p evm =
+  let goals, evm' =
+    Evd.fold
+      (fun ev evi (gls, evm') ->
+	if evi.evar_body = Evar_empty then
+	  let evi', goal = p evm ev evi in
+	    if goal then
+	      ((ev, evi') :: gls, Evd.add evm' ev evi')
+	    else (gls, Evd.add evm' ev evi')
+	else (gls, Evd.add evm' ev evi))
+      evm ([], Evd.empty)
+  in
+    if goals = [] then None
+    else
+      let goals = List.rev goals in
+	Some (goals, evm')
 
 (** Typeclasses instance search tactic / eauto *)
 
@@ -67,13 +96,9 @@ let intersects s t =
 open Auto
 
 let e_give_exact flags c gl = 
-  let t1 = (pf_type_of gl c) and t2 = pf_concl gl in 
-    if occur_existential t1 or occur_existential t2 then 
-      tclTHEN (Clenvtac.unify (* ~flags *) t1) (exact_no_check c) gl
-    else exact_check c gl
-(*   let t1 = (pf_type_of gl c) in *)
-(*     tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl *)
-      
+  let t1 = (pf_type_of gl c) in
+    tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl
+
 let assumption flags id = e_give_exact flags (mkVar id)
 
 open Unification
@@ -82,95 +107,116 @@ let auto_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly = true;
   modulo_delta = var_full_transparent_state;
+  resolve_evars = false;
+  use_evars_pattern_unification = true;
 }
 
-let unify_e_resolve flags (c,clenv) gls = 
+let rec eq_constr_mod_evars x y =
+  match kind_of_term x, kind_of_term y with
+  | Evar (e1, l1), Evar (e2, l2) when e1 <> e2 -> true
+  | _, _ -> compare_constr eq_constr_mod_evars x y
+
+let progress_evars t gl =
+  let concl = pf_concl gl in
+  let check gl' = 
+    let newconcl = pf_concl gl' in
+      if eq_constr_mod_evars concl newconcl 
+      then tclFAIL 0 (str"No progress made (modulo evars)") gl'
+      else tclIDTAC gl'
+  in tclTHEN t check gl
+
+TACTIC EXTEND progress_evars
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (snd t) ]
+END
+
+let unify_e_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver false ~flags clenv' gls 
-  in
-    Clenvtac.clenv_refine true ~with_classes:false clenv' gls
-      
-let unify_resolve flags (c,clenv) gls = 
+  let clenv' = clenv_unique_resolver false ~flags clenv' gls in
+    tclPROGRESS (Clenvtac.clenv_refine true ~with_classes:false clenv') gls
+
+let unify_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver false ~flags clenv' gls 
-  in
-    Clenvtac.clenv_refine false ~with_classes:false clenv' gls
+  let clenv' = clenv_unique_resolver false ~flags clenv' gls in
+    tclPROGRESS (Clenvtac.clenv_refine false ~with_classes:false clenv') gls
+
+let clenv_of_prods nprods (c, clenv) gls =
+  if nprods = 0 then Some clenv
+  else 
+    let ty = pf_type_of gls c in
+    let diff = nb_prod ty - nprods in
+      if diff >= 0 then
+	Some (mk_clenv_from_n gls (Some diff) (c,ty))
+      else None
+
+let with_prods nprods (c, clenv) f gls =
+  match clenv_of_prods nprods (c, clenv) gls with
+  | None -> tclFAIL 0 (str"Not enough premisses") gls
+  | Some clenv' -> f (c, clenv') gls
+
+(** Hack to properly solve dependent evars that are typeclasses *)
 
 let flags_of_state st =
-  {auto_unif_flags with 
+  {auto_unif_flags with
     modulo_conv_on_closed_terms = Some st; modulo_delta = st}
 
 let rec e_trivial_fail_db db_list local_db goal =
-  let tacl = 
+  let tacl =
     Eauto.registered_e_assumption ::
-    (tclTHEN Tactics.intro 
+    (tclTHEN Tactics.intro
        (function g'->
 	  let d = pf_last_hyp g' in
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
           (e_trivial_fail_db db_list
 	      (Hint_db.add_list hintl local_db) g'))) ::
-    (List.map pi1 (e_trivial_resolve db_list local_db (pf_concl goal)) )
+    (List.map (fun (x,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal)))
   in 
   tclFIRST (List.map tclCOMPLETE tacl) goal 
 
-and e_my_find_search db_list local_db hdc concl = 
+and e_my_find_search db_list local_db hdc concl =
   let hdc = head_of_constr_reference hdc in
+  let prods, concl = decompose_prod_assum concl in
+  let nprods = List.length prods in
   let hintl =
     list_map_append
-      (fun db -> 
-	if Hint_db.use_dn db then 
+      (fun db ->
+	if Hint_db.use_dn db then
 	  let flags = flags_of_state (Hint_db.transparent_state db) in
 	    List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db)
 	else
 	  let flags = flags_of_state (Hint_db.transparent_state db) in
 	    List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db))
       (local_db::db_list)
-  in 
-  let tac_of_hint = 
-    fun (flags, {pri=b; pat = p; code=t}) -> 
+  in
+  let tac_of_hint =
+    fun (flags, {pri=b; pat = p; code=t}) ->
       let tac =
 	match t with
-	  | Res_pf (term,cl) -> unify_resolve flags (term,cl)
-	  | ERes_pf (term,cl) -> unify_e_resolve flags (term,cl)
+	  | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags)
+	  | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags)
 	  | Give_exact (c) -> e_give_exact flags c
 	  | Res_pf_THEN_trivial_fail (term,cl) ->
-              tclTHEN (unify_e_resolve flags (term,cl)) 
+              tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags))
 		(e_trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
+	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [all_occurrences,c])
 	  | Extern tacast -> conclPattern concl p tacast
-      in 
-	(tac,b,pr_autotactic t)
-  in 
-    List.map tac_of_hint hintl
+      in
+	match t with
+	| Extern _ -> (tac,b,true,lazy (pr_autotactic t))
+	| _ -> (tac,b,false,lazy (pr_autotactic t))
+  in List.map tac_of_hint hintl
 
-and e_trivial_resolve db_list local_db gl = 
-  try 
-    e_my_find_search db_list local_db 
+and e_trivial_resolve db_list local_db gl =
+  try
+    e_my_find_search db_list local_db
       (fst (head_constr_bound gl)) gl
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
-  try 
-    e_my_find_search db_list local_db 
+  try
+    e_my_find_search db_list local_db
       (fst (head_constr_bound gl)) gl
   with Bound | Not_found -> []
 
-let find_first_goal gls = 
-  try first_goal gls with UserError _ -> assert false
-    
-type search_state = { 
-  depth : int; (*r depth of search before failing *)
-  tacres : goal list sigma * validation;
-  pri : int;
-  last_tactic : std_ppcmds;
-  dblist : Auto.hint_db list;
-  localdb : (bool ref * bool ref option * Auto.hint_db) list }
-    
-let filter_hyp t = 
-  match kind_of_term t with
-    | Evar _ | Meta _ | Sort _ -> false
-    | _ -> true
-
 let rec catchable = function
   | Refiner.FailError _ -> true
   | Stdpp.Exc_located (_, e) -> catchable e
@@ -181,275 +227,339 @@ let is_dep gl gls =
     if evs = Intset.empty then false
     else
       List.fold_left
-	(fun b gl -> 
-	  if b then b 
+	(fun b gl ->
+	  if b then b
 	  else
 	    let evs' = Evarutil.evars_of_term gl.evar_concl in
 	      intersects evs evs')
 	false gls
 
-module SearchProblem = struct
-    
-  type state = search_state
-
-  let debug = ref false
-
-  let success s = sig_it (fst s.tacres) = []
-
-  let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
-    
-  let pr_goals gls =
-    let evars = Evarutil.nf_evars (Refiner.project gls) in
-      prlist (pr_ev evars) (sig_it gls)
-	
-  let filter_tactics (glls,v) l =
-    let glls,nv = apply_tac_list Refiner.tclNORMEVAR glls in
-    let v p = v (nv p) in
-    let rec aux = function
-      | [] -> []
-      | (tac,pri,pptac) :: tacl -> 
-	  try 
-	    let (lgls,ptl) = apply_tac_list tac glls in 
-	    let v' p = v (ptl p) in
-	      ((lgls,v'),pri,pptac) :: aux tacl
-	  with e when catchable e -> aux tacl
-    in aux l
-      
-  let nb_empty_evars s = 
-    Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0
-
-  (* Ordering of states is lexicographic on depth (greatest first) then
-     priority (lowest pri means higher priority), then number of remaining goals. *)
-  let compare s s' =
-    let d = s'.depth - s.depth in
-    let nbgoals s = 
-      List.length (sig_it (fst s.tacres)) + 
-	nb_empty_evars (sig_sig (fst s.tacres))
-    in
-      if d <> 0 then d else
-	let pri = s.pri - s'.pri in
-	  if pri <> 0 then pri
-	  else nbgoals s - nbgoals s'
-	  
-  let branching s = 
-    if s.depth = 0 then 
-      []
-    else      
-      let (cut, do_cut, ldb as hdldb) = List.hd s.localdb in
-	if !cut then
-(* 	  let {it=gls; sigma=sigma} = fst s.tacres in *)
-(* 	    msg (str"cut:" ++ pr_ev sigma (List.hd gls) ++ str"\n"); *)
-	    []
-	else begin
-	  let {it=gl; sigma=sigma} = fst s.tacres in 
-	    Option.iter (fun r ->
-(*  	      msg (str"do cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *)
-	      r := true) do_cut;
-	  let gl = List.map (Evarutil.nf_evar_info sigma) gl in
-	  let nbgl = List.length gl in
-(* 	  let gl' = { it = gl ; sigma = sigma } in *)
-(* 	  let tacres' = gl', snd s.tacres in *)
-	  let new_db, localdb = 
-	    let tl = List.tl s.localdb in
-	      match tl with
-	      | [] -> hdldb, tl
-	      | (cut', do', ldb') :: rest ->
-		  if not (is_dep (List.hd gl) (List.tl gl)) then
-		    let fresh = ref false in
-		      if do' = None then (
-(*  			msg (str"adding a cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *)
-			(fresh, None, ldb), (cut', Some fresh, ldb') :: rest
-		      ) else (
-(* 			msg (str"keeping the previous cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *)
-			(cut', None, ldb), tl )
-		  else hdldb, tl
-	  in let localdb = new_db :: localdb in
-	  let intro_tac =
-	    List.map
-	      (fun ((lgls,_) as res,pri,pp) ->
-		let g' = first_goal lgls in
-		let hintl =
-		  make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-		in
-		let ldb = Hint_db.add_list hintl ldb in
-		  { s with tacres = res;
-		    last_tactic = pp;
-		    pri = pri;
-		    localdb = (cut, None, ldb) :: List.tl s.localdb })
-	      (filter_tactics s.tacres [Tactics.intro,1,(str "intro")])
-	  in
-	  let possible_resolve ((lgls,_) as res, pri, pp) =
-	    let nbgl' = List.length (sig_it lgls) in
-	      if nbgl' < nbgl then
-		{ s with 
-		  depth = pred s.depth;
-		  tacres = res; last_tactic = pp; pri = pri;
-		  localdb = List.tl localdb }
-	      else 
-		{ s with depth = pred s.depth; tacres = res; 
-		  last_tactic = pp; pri = pri;
-		  localdb = list_tabulate (fun _ -> new_db) (nbgl'-nbgl) @ localdb }
-	  in
-	  let rec_tacs = 
-	    let l = 
-	      filter_tactics s.tacres (e_possible_resolve s.dblist ldb (List.hd gl).evar_concl)
-	    in
-	      List.map possible_resolve l
-	  in
-	    List.sort compare (intro_tac @ rec_tacs)
-	end
-	  
-  let pp s = 
-    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ 
-		  s.last_tactic ++ str "\n"))
-
-end
-
-module Search = Explore.Make(SearchProblem)
-
-let make_initial_state n gls dblist localdbs =
-  { depth = n;
-    tacres = gls;
-    pri = 0;
-    last_tactic = (mt ());
-    dblist = dblist;
-    localdb = localdbs }
-
-let e_depth_search debug s =
-  let tac = if debug then
-    (SearchProblem.debug := true; Search.debug_depth_first) else Search.depth_first in
-  let s = tac s in
-    s.tacres
-
-let e_breadth_search debug s =
-  try
-    let tac = 
-      if debug then Search.debug_breadth_first else Search.breadth_first 
-    in let s = tac s in s.tacres
-  with Not_found -> error "eauto: breadth first search failed."
+let is_ground gl =
+  Evarutil.is_ground_term (project gl) (pf_concl gl)
+
+let nb_empty_evars s =
+  Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0
+
+let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
+
+let typeclasses_debug = ref false
 
+type validation = evar_map -> proof_tree list -> proof_tree
 
-(* A special one for getting everything into a dnet. *)
+let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l)
 
-let is_transparent_gr (ids, csts) = function
-  | VarRef id -> Idpred.mem id ids
-  | ConstRef cst -> Cpred.mem cst csts
-  | IndRef _ | ConstructRef _ -> false
+type autoinfo = { hints : Auto.hint_db; is_evar: existential_key option;
+		  only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t}
+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 }
 
-let make_resolve_hyp env sigma st flags pri (id, _, cty) =
+type auto_result = autogoal list sigma * validation
+
+type atac = auto_result tac
+
+let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
   let cty = Evarutil.nf_evar sigma cty in
-  let ctx, ar = decompose_prod cty in
-  let keep = 
-    match kind_of_term (fst (decompose_app ar)) with
-    | Const c -> is_class (ConstRef c)
-    | Ind i -> is_class (IndRef i)
-    | _ -> false
+  let rec iscl env ty = 
+    let ctx, ar = decompose_prod_assum ty in
+      match kind_of_term (fst (decompose_app ar)) with
+      | Const c -> is_class (ConstRef c)
+      | Ind i -> is_class (IndRef i)
+      | _ -> 
+	  let env' = Environ.push_rel_context ctx env in
+	  let ty' = whd_betadeltaiota env' ar in
+	       if not (eq_constr ty' ar) then iscl env' ty'
+	       else false
   in
+  let keep = not only_classes || iscl env cty in
     if keep then let c = mkVar id in
       map_succeed 
-	(fun f -> f (c,cty)) 
-	[make_exact_entry pri; make_apply_entry env sigma flags pri]
+	(fun f -> try f (c,cty) with UserError _ -> failwith "") 
+	[make_exact_entry sigma pri; make_apply_entry env sigma flags pri]
     else []
 
-let make_local_hint_db st eapply lems g =
-  let sign = pf_hyps g in
-  let hintlist = list_map_append (pf_apply make_resolve_hyp g st (eapply,false,false) None) sign in
-  let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false,false) None) lems in
-    Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty st true))
-
-let e_search_auto debug (in_depth,p) lems st db_list gls = 
-  let sigma = Evd.sig_sig (fst gls) and gls' = Evd.sig_it (fst gls) in
-  let local_dbs = List.map (fun gl -> 
-    let db = make_local_hint_db st true lems ({it = gl; sigma = sigma}) in
-      (ref false, None, db)) gls' in
-  let state = make_initial_state p gls db_list local_dbs in
-  if in_depth then 
-    e_depth_search debug state
-  else
-    e_breadth_search debug state
-
-let full_eauto debug n lems gls = 
-  let dbnames = current_db_names () in
-  let dbnames =  list_subtract dbnames ["v62"] in
-  let db_list = List.map searchtable_map dbnames in
-  let db = searchtable_map typeclasses_db in
-    e_search_auto debug n lems (Hint_db.transparent_state db) db_list gls
+let pf_filtered_hyps gls = 
+  evar_filtered_context (sig_it gls)
 
-let nf_goal (gl, valid) =
-  { gl with sigma = Evarutil.nf_evars gl.sigma }, valid
+let make_autogoal_hints only_classes ?(st=full_transparent_state) g =
+  let sign = pf_filtered_hyps g in
+  let hintlist = list_map_append (pf_apply make_resolve_hyp g st (true,false,false) only_classes None) sign in
+    Hint_db.add_list hintlist (Hint_db.empty st true)
+  
+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,v) -> sk (f gls hints, fun _ -> v) fk
+      | None -> fk () }
+
+let intro_tac : atac =
+  lift_tactic Tactics.intro
+    (fun {it = gls; sigma = s} info ->
+      let gls' =
+	List.map (fun g' ->
+	  let env = evar_env g' in
+	  let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) 
+	    (true,false,false) info.only_classes None (List.hd (evar_context g')) in
+	  let ldb = Hint_db.add_list hint info.hints in
+	    (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls
+      in {it = gls'; sigma = s})
+
+let normevars_tac : atac = 
+  lift_tactic tclNORMEVAR
+    (fun {it = gls; sigma = s} info ->
+      let gls' =
+	List.map (fun g' ->
+	  (g', { info with auto_last_tac = lazy (str"NORMEVAR") })) gls
+      in {it = gls'; sigma = s})
+
+
+let id_tac : atac =
+  { skft = fun sk fk {it = gl; sigma = s} ->
+    sk ({it = [gl]; sigma = s}, fun _ pfs -> List.hd pfs) fk }
+
+(* Ordering of states is lexicographic on the number of remaining goals. *)
+let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) =
+  let nbgoals s =
+    List.length (sig_it s) + nb_empty_evars (sig_sig s)
+  in
+  let pri = pri - pri' in
+    if pri <> 0 then pri
+    else nbgoals res - nbgoals res'
 
-let typeclasses_eauto debug n lems gls =
-  let db = searchtable_map typeclasses_db in
-    e_search_auto debug n lems (Hint_db.transparent_state db) [db] gls
+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 }
 
-exception Found of evar_map
+let solve_tac (x : 'a tac) : 'a tac =
+  { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> if gls = [] then sk res fk else fk ()) fk gls }
 
-let valid goals p res_sigma l = 
-  let evm = 
-    List.fold_left2 
-      (fun sigma (ev, evi) prf ->
-	let cstr, obls = Refiner.extract_open_proof !res_sigma prf in
-	  if not (Evd.is_defined sigma ev) then
-	    Evd.define sigma ev cstr
-	  else sigma)
-      !res_sigma goals l
-  in raise (Found evm)
+let hints_tac hints =
+  { skft = fun sk fk {it = gl,info; sigma = s} ->
+    let possible_resolve ((lgls,v) as res, pri, b, pp) =
+      (pri, pp, b, res)
+    in
+    let tacs =
+      let concl = gl.evar_concl in
+      let poss = e_possible_resolve hints info.hints concl in
+      let l =
+	let tacgl = {it = gl; sigma = s} in
+	Util.list_map_append (fun (tac, pri, b, pptac) ->
+	  try [tac tacgl, pri, b, pptac] with e when catchable e -> [])
+	  poss
+      in
+	if l = [] && !typeclasses_debug then
+	  msgnl (pr_depth info.auto_depth ++ str": no match for " ++
+		    Printer.pr_constr_env (Evd.evar_env gl) concl ++
+		    spc () ++ int (List.length poss) ++ str" possibilities");
+	List.map possible_resolve l
+    in
+    let tacs = List.sort compare tacs in
+    let rec aux i = function
+      | (_, pp, b, ({it = gls; sigma = s}, v)) :: tl ->
+	  if !typeclasses_debug then msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
+					       ++ str" on" ++ spc () ++ pr_ev s gl);
+	  let fk =
+	    (fun () -> (* if !typeclasses_debug then msgnl (str"backtracked after " ++ pp); *)
+	    aux (succ i) tl)
+	  in
+	  let sgls = evars_to_goals (fun evm ev evi ->
+	    if Typeclasses.is_resolvable evi && 
+	      (not info.only_classes || Typeclasses.is_class_evar evm evi) then
+	      Typeclasses.mark_unresolvable evi, true
+	    else evi, false) s
+	  in
+	  let nbgls, newgls, s' =
+	    let gls' = List.map (fun g -> (None, g)) gls in
+	    match sgls with
+	    | None -> List.length gls', gls', s
+	    | Some (evgls, s') ->
+		(List.length gls', gls' @ List.map (fun (ev, x) -> (Some ev, x)) evgls, s')
+	  in
+	  let gls' = list_map_i (fun j (evar, g) -> 
+	    let info = 
+	      { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp;
+		is_evar = evar;
+		hints = 
+		  if b && g.evar_hyps <> gl.evar_hyps 
+		  then make_autogoal_hints info.only_classes
+		    ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'}
+		  else info.hints }
+	    in g, info) 1 newgls in
+	  let glsv = {it = gls'; sigma = s'}, (fun _ pfl -> v (list_firstn nbgls pfl)) in
+	    sk glsv fk
+      | [] -> fk ()
+    in aux 1 tacs }
+
+let evars_of_term c =
+  let rec evrec acc c =
+    match kind_of_term c with
+    | Evar (n, _) -> Intset.add n acc
+    | _ -> fold_constr evrec acc c
+  in evrec Intset.empty c
 
-let is_dependent ev evm = 
-  Evd.fold (fun ev' evi dep -> 
-    if ev = ev' then dep
-    else dep || occur_evar ev evi.evar_concl)
-    evm false
-    
-let resolve_all_evars_once debug (mode, depth) env p evd =
-  let evm = Evd.evars_of evd in
-  let goals, evm' = 
-    Evd.fold
-      (fun ev evi (gls, evm') ->
-	if evi.evar_body = Evar_empty 
-	  && Typeclasses.is_resolvable evi
-(* 	  && not (is_dependent ev evm) *)
-	  && p ev evi then ((ev,evi) :: gls, Evd.add evm' ev (Typeclasses.mark_unresolvable evi)) else 
-	  (gls, Evd.add evm' ev evi))
-      evm ([], Evd.empty)
-  in
-  let goals = List.rev goals in
-  let gls = { it = List.map snd goals; sigma = evm' } in
-  let res_sigma = ref evm' in
-  let gls', valid' = typeclasses_eauto debug (mode, depth) [] (gls, valid goals p res_sigma) in
-    res_sigma := Evarutil.nf_evars (sig_sig gls');
-    try ignore(valid' []); assert(false) 
-    with Found evm' -> Evarutil.nf_evar_defs (Evd.evars_reset_evd evm' evd)
+exception Found_evar of int
+
+let occur_evars evars c =
+  try
+    let rec evrec c =
+      match kind_of_term c with
+      | Evar (n, _) -> if Intset.mem n evars then raise (Found_evar n) else ()
+      | _ -> iter_constr evrec c
+    in evrec c; false
+  with Found_evar _ -> true
+
+let dependent only_classes evd oev concl =
+  let concl_evars = Intset.union (evars_of_term concl)
+    (Option.cata Intset.singleton Intset.empty oev)
+  in not (Intset.is_empty concl_evars) 
+
+let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
+  let rec aux s (acc : (autogoal list * validation) list) fk = function
+    | (gl,info) :: gls ->
+	second.skft (fun ({it=gls';sigma=s'},v') fk' ->
+	  let s', needs_backtrack = 
+	    if gls' = [] then
+	      match info.is_evar with
+	      | Some ev -> 
+		  let s' = 
+		    if Evd.is_defined s' ev then s' 
+		    else
+		      let prf = v' s' [] in
+		      let term, _ = Refiner.extract_open_proof s' prf in
+			Evd.define ev term s' 
+		  in s', dependent info.only_classes s' (Some ev) gl.evar_concl
+	      | None -> s', dependent info.only_classes s' None gl.evar_concl
+	    else s', true
+	  in
+	  let fk'' = if not needs_backtrack then
+	    (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl); fk) else fk' 
+	  in aux s' ((gls',v')::acc) fk'' gls)
+	  fk {it = (gl,info); sigma = s}
+    | [] -> Some (List.rev acc, s, fk)
+  in fun ({it = gls; sigma = s},v) fk ->
+    let rec aux' = function
+      | None -> fk ()
+      | Some (res, s', fk') ->
+	  let goals' = List.concat (List.map (fun (gls,v) -> gls) res) in
+	  let v' s' pfs' : proof_tree =
+	    let (newpfs, rest) = List.fold_left (fun (newpfs,pfs') (gls,v) ->
+	      let before, after = list_split_at (List.length gls) pfs' in
+		(v s' before :: newpfs, after))
+	      ([], pfs') res
+	    in assert(rest = []); v s' (List.rev newpfs)
+	  in sk ({it = goals'; sigma = s'}, v') (fun () -> aux' (fk' ()))
+    in aux' (aux s [] (fun () -> None) gls)
+
+let then_tac (first : atac) (second : atac) : atac =
+  { skft = fun sk fk -> first.skft (then_list second sk) fk }
+
+let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
+  t.skft (fun x _ -> Some x) (fun _ -> None) gl
+
+
+type run_list_res = (auto_result * run_list_res fk) option
+
+let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
+  (then_list t (fun x fk -> Some (x, fk)))
+    (gl, fun s pfs -> valid goals p (ref s) pfs)
+    (fun _ -> None)
+
+let rec fix (t : 'a tac) : 'a tac =
+  then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
+
+let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) ev g =
+  let hints = make_autogoal_hints only_classes ~st g in
+    (g.it, { hints = hints ; is_evar = ev; 
+	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (mt()) })
+      
+let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) gs evm' =
+  { it = list_map_i (fun i g -> 
+    let (gl, auto) = make_autogoal ~only_classes ~st (Some (fst g)) {it = snd g; sigma = evm'} in
+      (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' }
+
+let get_result r = 
+  match r with
+  | None -> None
+  | Some ((gls, v), fk) ->
+      try ignore(v (sig_sig gls) []); assert(false)
+      with Found evm' -> Some (evm', fk)
+
+let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) 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 res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in
+	match get_result res with
+	| None -> raise Not_found
+	| Some (evm', fk) -> Some (Evd.evars_reset_evd evm' evm, fk)
+	    
+let eauto_tac hints = 
+  fix (or_tac (then_tac normevars_tac (hints_tac hints)) intro_tac)
+  
+let eauto ?(only_classes=true) ?st hints g =
+  let gl = { it = make_autogoal ~only_classes ?st None g; sigma = project g } in
+    match run_tac (eauto_tac hints) gl with
+    | None -> raise Not_found
+    | Some ({it = goals; sigma = s}, valid) ->
+	{it = List.map fst goals; sigma = s}, valid s
+
+let real_eauto st hints p evd =
+  let rec aux evd fails =
+    let res, fails =
+      try run_on_evars ~st p evd (eauto_tac hints), fails
+      with Not_found ->
+	List.fold_right (fun fk (res, fails) ->
+	  match res with
+	  | Some r -> res, fk :: fails
+	  | None -> get_result (fk ()), fails)
+	  fails (None, [])
+    in
+      match res with
+      | None -> evd
+      | Some (evd', fk) -> aux evd' (fk :: fails)
+  in aux evd []
+
+let resolve_all_evars_once debug (mode, depth) p evd =
+  let db = searchtable_map typeclasses_db in
+    real_eauto (Hint_db.transparent_state db) [db] p evd
 
 exception FoundTerm of constr
 
 let resolve_one_typeclass env ?(sigma=Evd.empty) gl =
-  let gls = { it = [ Evd.make_evar (Environ.named_context_val env) gl ] ; sigma = sigma } in
-  let valid x = raise (FoundTerm (fst (Refiner.extract_open_proof sigma (List.hd x)))) in
-  let gls', valid' = typeclasses_eauto false (true, default_eauto_depth) [] (gls, valid) in
-    try ignore(valid' []); assert false with FoundTerm t -> 
-      let term = Evarutil.nf_evar (sig_sig gls') t in
-	if occur_existential term then raise Not_found else term
-
-let _ = 
+  let gls = { it = Evd.make_evar (Environ.named_context_val env) gl; sigma = sigma } in
+  let hints = searchtable_map typeclasses_db in
+  let gls', v = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in
+  let term = v [] in
+  let evd = sig_sig gls' in
+  let term = fst (Refiner.extract_open_proof evd term) in
+  let term = Evarutil.nf_evar evd term in
+    evd, term
+
+let _ =
   Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z)
 
 let has_undefined p oevd evd =
   Evd.fold (fun ev evi has -> has ||
-    (evi.evar_body = Evar_empty && p ev evi && 
-	(try Typeclasses.is_resolvable (Evd.find oevd ev) with _ -> true)))
-    (Evd.evars_of evd) false
+    (evi.evar_body = Evar_empty && snd (p oevd ev evi)))
+    evd false
 
 let rec merge_deps deps = function
   | [] -> [deps]
-  | hd :: tl -> 
-      if intersects deps hd then 
+  | hd :: tl ->
+      if intersects deps hd then
 	merge_deps (Intset.union deps hd) tl
       else hd :: merge_deps deps tl
-	
+
+let evars_of_evi evi =
+  Intset.union (Evarutil.evars_of_term evi.evar_concl)
+    (match evi.evar_body with
+    | Evar_defined b -> Evarutil.evars_of_term b
+    | Evar_empty -> Intset.empty)
+
 let split_evars evm =
   Evd.fold (fun ev evi acc ->
-    let deps = Intset.union (Intset.singleton ev) (Evarutil.evars_of_term evi.evar_concl) in
+    let deps = Intset.union (Intset.singleton ev) (evars_of_evi evi) in
       merge_deps deps acc)
     evm []
 
@@ -458,685 +568,113 @@ let select_evars evs evm =
     if Intset.mem ev evs then Evd.add acc ev evi else acc)
     evm Evd.empty
 
+let is_inference_forced p ev evd =
+  try
+    let evi = Evd.find evd ev in
+      if evi.evar_body = Evar_empty then
+	if Typeclasses.is_resolvable evi
+	  && snd (p ev evi)
+	then
+	  let (loc, k) = evar_source ev evd in
+	    match k with
+	    | ImplicitArg (_, _, b) -> b
+	    | QuestionMark _ -> false
+	    | _ -> true
+	else true
+      else false
+  with Not_found -> true
+
+let is_optional p comp evd =
+  Intset.fold (fun ev acc ->
+    acc && not (is_inference_forced p ev evd))
+    comp true
+
 let resolve_all_evars debug m env p oevd do_split fail =
-  let oevm = Evd.evars_of oevd in
-  let split = if do_split then split_evars (Evd.evars_of (Evd.undefined_evars oevd)) else [Intset.empty] in
-  let p = if do_split then 
-    fun comp ev evi -> (Intset.mem ev comp || not (Evd.mem oevm ev)) && p ev evi
-    else fun _ -> p 
+  let split = if do_split then split_evars oevd else [Intset.empty] in
+  let p = if do_split then
+    fun comp evd ev evi -> 
+      if evi.evar_body = Evar_empty then
+	(try let oevi = Evd.find oevd ev in
+	       if Typeclasses.is_resolvable oevi then
+		 Typeclasses.mark_unresolvable evi, (Intset.mem ev comp &&
+							p evd ev evi)
+	       else evi, false
+	  with Not_found ->
+	    Typeclasses.mark_unresolvable evi, p evd ev evi)
+      else evi, false
+    else fun _ evd ev evi -> 
+      if evi.evar_body = Evar_empty then
+	try let oevi = Evd.find oevd ev in
+	      if Typeclasses.is_resolvable oevi then
+		Typeclasses.mark_unresolvable evi, p evd ev evi
+	      else evi, false
+	with Not_found ->
+	  Typeclasses.mark_unresolvable evi, p evd ev evi
+      else evi, false
+  in
+  let rec aux p evd =
+    let evd' = resolve_all_evars_once debug m p evd in
+      if has_undefined p oevd evd' then None
+      else Some evd'
   in
-  let rec aux n p evd =
-    if has_undefined p oevm evd then
-      if n > 0 then
-	let evd' = resolve_all_evars_once debug m env p evd in
-	  aux (pred n) p evd'
-      else None
-    else Some evd
-  in 
   let rec docomp evd = function
     | [] -> evd
     | comp :: comps ->
-	let res = try aux 3 (p comp) evd with Not_found -> None in
+	let res = try aux (p comp) evd with Not_found -> None in
 	  match res with
 	  | None -> 
-	      if fail then 
-		(* Unable to satisfy the constraints. *)
-		let evm = Evd.evars_of evd in
-		let evm = if do_split then select_evars comp evm else evm in
-		let _, ev = Evd.fold 
-		  (fun ev evi (b,acc) -> 
+	      if fail && (not do_split || not (is_optional (p comp evd) comp evd)) then
+		(* Unable to satisfy the constraints. *)		
+		let evd = Evarutil.nf_evars evd in
+		let evm = if do_split then select_evars comp evd else evd in
+		let _, ev = Evd.fold
+		  (fun ev evi (b,acc) ->
 		    (* focus on one instance if only one was searched for *)
 		    if class_of_constr evi.evar_concl <> None then
 		      if not b (* || do_split *) then
-			true, Some ev 
+			true, Some ev
 		      else b, None
 		    else b, acc) evm (false, None)
 		in
-		  Typeclasses_errors.unsatisfiable_constraints env (Evd.evars_reset_evd evm evd) ev
+		  Typeclasses_errors.unsatisfiable_constraints (Evarutil.nf_env_evar evm env) evm ev
 	      else (* Best effort: do nothing *) oevd
 	  | Some evd' -> docomp evd' comps
   in docomp oevd split
 
 let resolve_typeclass_evars d p env evd onlyargs split fail =
-  let pred = 
-    if onlyargs then 
-      (fun ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) &&
-	Typeclasses.is_class_evar evi)
-    else (fun ev evi -> Typeclasses.is_class_evar evi)
+  let pred =
+    if onlyargs then
+      (fun evd ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) &&
+	Typeclasses.is_class_evar evd evi)
+    else (fun evd ev evi -> Typeclasses.is_class_evar evd evi)
   in resolve_all_evars d p env pred evd split fail
-    
+
 let solve_inst debug mode depth env evd onlyargs split fail =
   resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail
 
-let _ = 
+let _ =
   Typeclasses.solve_instanciations_problem :=
     solve_inst false true default_eauto_depth
 
-    
+let set_transparency cl b =
+  List.iter (fun r -> 
+    let gr = Smartlocate.global_with_alias r in
+    let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in
+      Classes.set_typeclass_transparency ev b) cl
+
 VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
 | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
-    add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, true))
-  ]
+    set_transparency cl true ]
 END
-	
+
 VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings
 | [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
-    add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, false))
-  ]
+    set_transparency cl false ]
 END
 
-(** Typeclass-based rewriting. *)
-
-let morphism_class = 
-  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism"))))
-
-let morphism_proxy_class = 
-  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy"))))
-
-let respect_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force morphism_class).cl_projs))))
-
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-
-let try_find_global_reference dir s =
-  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in
-    Nametab.absolute_reference sp
-      
-let try_find_reference dir s =
-  constr_of_global (try_find_global_reference dir s)
-    
-let gen_constant dir s = Coqlib.gen_constant "Class_setoid" dir s
-let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
-let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
-let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
-let iff = lazy (gen_constant ["Init"; "Logic"] "iff")
-let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
-let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
-let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
-let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id")
-
-let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive")
-let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity")
-let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity")
-
-let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric")
-let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry")
-let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry")
-
-let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive")
-let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity")
-let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity")
-
-let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *)
-			   ["Program"; "Basics"] "flip")
-
-let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |])
-(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *)
-
-let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement")
-let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation")
-let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation")
-
-let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep")
-let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
-
-let equivalence = lazy (gen_constant ["Classes"; "RelationClasses"] "Equivalence")
-let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
-
-let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation")
-let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
-(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *)
-
-let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT")
-
-let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
-
-let setoid_equiv = lazy (gen_constant ["Classes"; "SetoidClass"] "equiv")
-let setoid_morphism = lazy (gen_constant ["Classes"; "SetoidClass"] "setoid_morphism")
-let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
-
-let setoid_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "SetoidRelation")
-  
-let arrow_morphism a b = 
-  if isprop a && isprop b then
-    Lazy.force impl
-  else
-    mkApp(Lazy.force arrow, [|a;b|])
-
-let setoid_refl pars x = 
-  applistc (Lazy.force setoid_refl_proj) (pars @ [x])
-      
-let morphism_type = lazy (constr_of_global (Lazy.force morphism_class).cl_impl)
-
-let morphism_proxy_type = lazy (constr_of_global (Lazy.force morphism_proxy_class).cl_impl)
-
-let is_applied_setoid_relation t =
-  match kind_of_term t with
-  | App (c, args) when Array.length args >= 2 ->
-      let head = if isApp c then fst (destApp c) else c in 
-	if eq_constr (Lazy.force coq_eq) head then false
-	else (try      
-	    let evd, evar = Evarutil.new_evar (Evd.create_evar_defs Evd.empty) (Global.env()) (new_Type ()) in
-	    let inst = mkApp (Lazy.force setoid_relation, [| evar; c |]) in
-	      ignore(Typeclasses.resolve_one_typeclass (Global.env()) (Evd.evars_of evd) inst);
-	      true
-	  with _ -> false)
-  | _ -> false
-      
-let _ = 
-  Equality.register_is_applied_setoid_relation is_applied_setoid_relation
-
-let split_head = function
-    hd :: tl -> hd, tl
-  | [] -> assert(false)
-
-let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy.t option) (f : 'a -> constr) =
-  let new_evar isevars env t =
-    Evarutil.e_new_evar isevars env
-      (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
-  in
-  let mk_relty ty obj =
-    match obj with
-      | None -> 
-	  let relty = mk_relation ty in
-	    new_evar isevars env relty
-      | Some x -> f x
-  in
-  let rec aux env ty l =
-    let t = Reductionops.whd_betadeltaiota env (Evd.evars_of !isevars) ty in
-      match kind_of_term t, l with
-      | Prod (na, ty, b), obj :: cstrs -> 
-	  if dependent (mkRel 1) b then
-	    let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in
-	    let ty = Reductionops.nf_betaiota (Evd.evars_of !isevars) ty in
-	    let pred = mkLambda (na, ty, b) in
-	    let liftarg = mkLambda (na, ty, arg) in
-	    let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in
-	      mkProd(na, ty, b), arg', (ty, None) :: evars
-	  else
-	    let (b', arg, evars) = aux env (subst1 mkProp b) cstrs in
-	    let ty = Reductionops.nf_betaiota(Evd.evars_of !isevars) ty in
-	    let relty = mk_relty ty obj in
-	    let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in
-	      mkProd(na, ty, b), newarg, (ty, Some relty) :: evars
-      | _, obj :: _ -> anomaly "build_signature: not enough products"
-      | _, [] -> 
-	  (match finalcstr with
-	      None -> 
-		let t = Reductionops.nf_betaiota(Evd.evars_of !isevars) ty in
-		let rel = mk_relty t None in 
-		  t, rel, [t, Some rel]
-	    | Some codom -> let (t, rel) = Lazy.force codom in
-			      t, rel, [t, Some rel])
-  in aux env m cstrs
-
-let morphism_proof env evars carrier relation x =
-  let goal =
-    mkApp (Lazy.force morphism_proxy_type, [| carrier ; relation; x |])
-  in Evarutil.e_new_evar evars env goal
-
-let find_class_proof proof_type proof_method env evars carrier relation =
-  try 
-    let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in
-      Typeclasses.resolve_one_typeclass env evars goal
-  with e when Logic.catchable_exception e -> raise Not_found
-
-let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
-let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
-let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
-
-exception FoundInt of int
-
-let array_find (arr: 'a array) (pred: int -> 'a -> bool): int = 
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done;
-    raise Not_found
-  with FoundInt i -> i
-
-let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars =
-  let morph_instance, proj, sigargs, m', args, args' = 
-    let first = try (array_find args' (fun i b -> b <> None)) with Not_found -> raise (Invalid_argument "resolve_morphism") in
-    let morphargs, morphobjs = array_chop first args in
-    let morphargs', morphobjs' = array_chop first args' in
-    let appm = mkApp(m, morphargs) in
-    let appmtype = Typing.type_of env sigma appm in
-    let cstrs = List.map (function None -> None | Some (_, (a, r, _, _)) -> Some (a, r)) (Array.to_list morphobjs') in
-    let appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a, r) -> r) in
-    let cl_args = [| appmtype' ; signature ; appm |] in
-    let app = mkApp (Lazy.force morphism_type, cl_args) in
-    let morph = Evarutil.e_new_evar evars env app in
-      morph, morph, sigargs, appm, morphobjs, morphobjs'
-  in 
-  let projargs, respars, typeargs = 
-    array_fold_left2 
-      (fun (acc, sigargs, typeargs') x y -> 
-	let (carrier, relation), sigargs = split_head sigargs in
-	  match relation with
-	  | Some relation ->
-	      (match y with
-	      | None ->
-		  let proof = morphism_proof env evars carrier relation x in
-		    [ proof ; x ; x ] @ acc, sigargs, x :: typeargs'
-	      | Some (p, (_, _, _, t')) ->
-		  [ p ; t'; x ] @ acc, sigargs, t' :: typeargs')
-	  | None -> 
-	      if y <> None then error "Cannot rewrite the argument of a dependent function";
-	      x :: acc, sigargs, x :: typeargs')
-      ([], sigargs, []) args args'
-  in
-  let proof = applistc proj (List.rev projargs) in
-  let newt = applistc m' (List.rev typeargs) in
-    match respars with
-	[ a, Some r ] -> (proof, (a, r, oldt, fnewt newt))
-      | _ -> assert(false)
-
-(* Adapted from setoid_replace. *)
-
-type hypinfo = {
-  cl : clausenv;
-  prf : constr;
-  car : constr;
-  rel : constr;
-  l2r : bool;
-  c1 : constr;
-  c2 : constr;
-  c  : constr option;
-  abs : (constr * types) option;
-}
-
-let evd_convertible env evd x y =
-  try ignore(Evarconv.the_conv_x env x y evd); true 
-  with _ -> false
-  
-let decompose_setoid_eqhyp env sigma c left2right =
-  let ctype = Typing.type_of env sigma c in
-  let find_rel ty = 
-    let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in
-    let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
-    let rec split_last_two = function
-      | [c1;c2] -> [],(c1, c2)
-      | x::y::z ->
-	  let l,res = split_last_two (y::z) in x::l, res
-      | _ -> error "The term provided is not an applied relation." in
-    let others,(c1,c2) = split_last_two args in
-    let ty1, ty2 = 
-      Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2
-    in
-      if not (evd_convertible env eqclause.evd ty1 ty2) then None
-      else
-	Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
-	       car=ty1; rel=mkApp (equiv, Array.of_list others);
-	       l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None }
-  in
-    match find_rel ctype with
-    | Some c -> c
-    | None -> 
-	let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *)
-	match find_rel (it_mkProd_or_LetIn t' ctx) with
-	| Some c -> c
-	| None -> error "The term does not end with an applied homogeneous relation."
-	    
-let rewrite_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly = true;
-  Unification.modulo_delta = empty_transparent_state;
-}
-
-let conv_transparent_state = (Idpred.empty, Cpred.full)
-
-let rewrite2_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
-  Unification.use_metas_eagerly = true;
-  Unification.modulo_delta = empty_transparent_state;
-}
-
-let convertible env evd x y =
-  Reductionops.is_conv env (Evd.evars_of evd) x y
-  
-let allowK = true
-
-let refresh_hypinfo env sigma hypinfo = 
-  if !hypinfo.abs = None then
-    let {l2r=l2r; c = c;cl=cl} = !hypinfo in
-      match c with 
-	| Some c ->
-	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
-	    hypinfo := decompose_setoid_eqhyp env (Evd.evars_of cl.evd) c l2r;
-	| _ -> ()
-  else ()
-
-let unify_eqn env sigma hypinfo t = 
-  if isEvar t then None
-  else try 
-    let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in
-    let env', prf, c1, c2, car, rel =
-      let left = if l2r then c1 else c2 in
-	match abs with
-	    Some (absprf, absprfty) -> 
-	      let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in
-		env', prf, c1, c2, car, rel
-	  | None ->
-	      let env' =
-		try clenv_unify allowK ~flags:rewrite_unif_flags
-		  CONV left t cl
-		with Pretype_errors.PretypeError _ ->
-		  (* For Ring essentially, only when doing setoid_rewrite *)
-		  clenv_unify allowK ~flags:rewrite2_unif_flags
-		    CONV left t cl
-	      in
-	      let env' = 
-		let mvs = clenv_dependent false env' in
-		  clenv_pose_metas_as_evars env' mvs
-	      in
-	      let evd' = Typeclasses.resolve_typeclasses ~fail:false env'.env env'.evd in
-	      let env' = { env' with evd = evd' } in
-	      let nf c = Evarutil.nf_evar (Evd.evars_of evd') (Clenv.clenv_nf_meta env' c) in
-	      let c1 = nf c1 and c2 = nf c2
-	      and car = nf car and rel = nf rel 
-	      and prf = nf (Clenv.clenv_value env') in
-	      let ty1 = Typing.mtype_of env'.env env'.evd c1 
-	      and ty2 = Typing.mtype_of env'.env env'.evd c2
-	      in
-		if convertible env env'.evd ty1 ty2 then (
-		  if occur_meta prf then refresh_hypinfo env sigma hypinfo;
-		  env', prf, c1, c2, car, rel)
-		else raise Reduction.NotConvertible
-    in
-    let res =
-      if l2r then (prf, (car, rel, c1, c2))
-      else
-	try (mkApp (get_symmetric_proof env Evd.empty car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1))
-	with Not_found ->
-	  (prf, (car, inverse car rel, c2, c1))
-    in Some (env', res)
-  with e when catchable e -> None
-
-let unfold_impl t =
-  match kind_of_term t with
-    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) -> 
-	mkProd (Anonymous, a, lift 1 b)
-    | _ -> assert false
-
-let unfold_id t = 
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b
-    | _ -> assert false
-
-let unfold_all t = 
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let decomp_prod env evm n c = 
-  snd (Reductionops.decomp_n_prod env evm n c)
-
-let rec decomp_pointwise n c =
-  if n = 0 then c
-  else
-    match kind_of_term c with
-      | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb
-      | _ -> raise Not_found
-	  
-let lift_cstr env sigma evars args cstr =
-  let cstr () =
-    let start = 
-      match cstr with
-	| Some codom -> Lazy.force codom
-	| None -> let car = Evarutil.e_new_evar evars env (new_Type ()) in
-	  let rel = Evarutil.e_new_evar evars env (mk_relation car) in
-	    (car, rel)
-    in
-      Array.fold_right
-	(fun arg (car, rel) -> 
-	  let ty = Typing.type_of env sigma arg in
-	  let car' = mkProd (Anonymous, ty, car) in
-	  let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in
-	    (car', rel'))
-	args start
-  in Some (Lazy.lazy_from_fun cstr)
-
-let unlift_cstr env sigma = function
-  | None -> None
-  | Some codom -> 
-      let cstr () =
-	let car, rel = Lazy.force codom in
-	  decomp_prod env sigma 1 car, decomp_pointwise 1 rel
-      in Some (Lazy.lazy_from_fun cstr)
-
-type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
-
-let default_flags = { under_lambdas = true; on_morphisms = true; }
-
-let build_new gl env sigma flags loccs hypinfo concl cstr evars =
-  let (nowhere_except_in,occs) = loccs in
-  let is_occ occ = 
-    if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in
-  let rec aux env t occ cstr =
-    let unif = unify_eqn env sigma hypinfo t in
-    let occ = if unif = None then occ else succ occ in
-      match unif with
-      | Some (env', (prf, hypinfo as x)) when is_occ occ -> 
-	  begin 
-	    evars := Evd.evar_merge !evars 
-	      (Evd.evars_of (Evd.undefined_evars (Evarutil.nf_evar_defs env'.evd)));
-	    match cstr with
-	    | None -> Some x, occ
-	    | Some _ ->
-		let (car, r, orig, dest) = hypinfo in
-		let res = 
-		  resolve_morphism env sigma t ~fnewt:unfold_id
-		    (mkApp (Lazy.force coq_id, [| car |]))
-		    [| orig |] [| Some x |] cstr evars
-		in Some res, occ
-	  end
-      | _ -> 
-	  match kind_of_term t with
-	  | App (m, args) ->
-	      let rewrite_args occ = 
-		let args', occ = 
-		  Array.fold_left 
-		    (fun (acc, occ) arg -> let res, occ = aux env arg occ None in (res :: acc, occ))
-		    ([], occ) args
-		in
-		let res =
-		  if List.for_all (fun x -> x = None) args' then None
-		  else 
-		    let args' = Array.of_list (List.rev args') in
-		      (Some (resolve_morphism env sigma t m args args' cstr evars))
-		in res, occ
-	      in
-		if flags.on_morphisms then
-		  let m', occ = aux env m occ (lift_cstr env sigma evars args cstr) in
-		    match m' with
-		    | None -> rewrite_args occ (* Standard path, try rewrite on arguments *)
-		    | Some (prf, (car, rel, c1, c2)) -> 
-			(* We rewrote the function and get a proof of pointwise rel for the arguments.
-			   We just apply it. *)
-			let nargs = Array.length args in
-			let res = 
-			  mkApp (prf, args),
-			  (decomp_prod env (Evd.evars_of !evars) nargs car, 
-			  decomp_pointwise nargs rel, mkApp(c1, args), mkApp(c2, args))
-			in Some res, occ
-		else rewrite_args occ
-		
-	  | Prod (n, x, b) when not (dependent (mkRel 1) b) -> 
-	      let x', occ = aux env x occ None in
-(* 		if x' = None && flags.under_lambdas then *)
-(* 		  let lam = mkLambda (n, x, b) in *)
-(* 		  let lam', occ = aux env lam occ None in *)
-(* 		  let res =  *)
-(* 		    match lam' with *)
-(* 		    | None -> None *)
-(* 		    | Some (prf, (car, rel, c1, c2)) -> *)
-(* 			Some (resolve_morphism env sigma t *)
-(* 				 ~fnewt:unfold_all *)
-(* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
-(* 				 cstr evars) *)
-(* 		  in res, occ *)
-(* 		else *)
-		  let b = subst1 mkProp b in
-		  let b', occ = aux env b occ None in
-		  let res = 
-		    if x' = None && b' = None then None
-		    else 
-		      Some (resolve_morphism env sigma t
-			       ~fnewt:unfold_impl
-			       (arrow_morphism (Typing.type_of env sigma x) (Typing.type_of env sigma b))
-			       [| x ; b |] [| x' ; b' |]
-			       cstr evars)
-		  in res, occ
-		    
-	  | Prod (n, ty, b) ->
-	      let lam = mkLambda (n, ty, b) in
-	      let lam', occ = aux env lam occ None in
-	      let res = 
-		match lam' with
-		| None -> None
-		| Some (prf, (car, rel, c1, c2)) ->
-		    Some (resolve_morphism env sigma t
-			     ~fnewt:unfold_all
-			     (Lazy.force coq_all) [| ty ; lam |] [| None; lam' |]
-			     cstr evars)
-	      in res, occ
-		
-	  | Lambda (n, t, b) when flags.under_lambdas ->
-	      let env' = Environ.push_rel (n, None, t) env in
-		refresh_hypinfo env' sigma hypinfo;
-		let b', occ = aux env' b occ (unlift_cstr env sigma cstr) in
-		let res =
-		  match b' with
-		  | None -> None
-		  | Some (prf, (car, rel, c1, c2)) ->
-		      let prf' = mkLambda (n, t, prf) in
-		      let car' = mkProd (n, t, car) in
-		      let rel' = mkApp (Lazy.force pointwise_relation, [| t; car; rel |]) in
-		      let c1' = mkLambda(n, t, c1) and c2' = mkLambda (n, t, c2) in
-			Some (prf', (car', rel', c1', c2'))
-		in res, occ
-	  | _ -> None, occ
-  in
-  let eq,nbocc_min_1 = aux env concl 0 cstr in
-  let rest = List.filter (fun o -> o > nbocc_min_1) occs in
-  if rest <> [] then error_invalid_occurrence rest;
-  eq
-          
-let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl =
-  let concl, is_hyp = 
-    match clause with
-	Some ((_, id), _) -> pf_get_hyp_typ gl id, Some id
-      | None -> pf_concl gl, None
-  in
-  let cstr = 
-    let sort = mkProp in
-    let impl = Lazy.force impl in
-      match is_hyp with
-      | None -> (sort, inverse sort impl)
-      | Some _ -> (sort, impl)
-  in
-  let sigma = project gl in
-  let evars = ref (Evd.create_evar_defs sigma) in
-  let env = pf_env gl in
-  let eq = build_new gl env sigma flags occs hypinfo concl (Some (Lazy.lazy_from_val cstr)) evars 
-  in
-    match eq with
-    | Some (p, (_, _, oldt, newt)) -> 
-	(try 
-	  evars := Typeclasses.resolve_typeclasses env ~split:false ~fail:true !evars;
-	  let p = Evarutil.nf_isevar !evars p in
-	  let newt = Evarutil.nf_isevar !evars newt in
-	  let undef = Evd.undefined_evars !evars in
-	  let abs = Option.map (fun (x, y) -> Evarutil.nf_isevar !evars x,
-	    Evarutil.nf_isevar !evars y) !hypinfo.abs in
-	  let rewtac = 
-	    match is_hyp with
-	    | Some id -> 
-		let term = 
-		  match abs with
-		  | None -> p
-		  | Some (t, ty) -> 
-		      mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
-		in
-		  cut_replacing id newt 
-		    (fun x -> Tacmach.refine_no_check (mkApp (term, [| mkVar id |])))
-	    | None -> 
-		(match abs with
-		| None -> 
-		    let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
-		      tclTHENLAST
-			(Tacmach.internal_cut_no_check false name newt)
-			(tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p))
-		| Some (t, ty) -> 
-		    Tacmach.refine_no_check
-		      (mkApp (mkLambda (Name (id_of_string "newt"), newt,
-				       mkLambda (Name (id_of_string "lemma"), ty,
-						mkApp (p, [| mkRel 2 |]))),
-			     [| mkMeta goal_meta; t |])))
-	  in
-	  let evartac =
-	    let evd = Evd.evars_of undef in
-	      if not (evd = Evd.empty) then Refiner.tclEVARS (Evd.merge sigma evd)
-	      else tclIDTAC
-	  in tclTHENLIST [evartac; rewtac] gl
-	  with 
-	  | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
-	  | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
-	      tclFAIL 0 (str" setoid rewrite failed: unable to satisfy the rewriting constraints." 
-			  ++ fnl () ++ Himsg.explain_typeclass_error env e) gl)
-	  (* 	      | Not_found -> *)
-	  (* 		  tclFAIL 0 (str" setoid rewrite failed: unable to satisfy the rewriting constraints.") gl) *)
-    | None -> 
-	let {l2r=l2r; c1=x; c2=y} = !hypinfo in
-	  raise (Pretype_errors.PretypeError 
-		    (pf_env gl, 
-		    Pretype_errors.NoOccurrenceFound ((if l2r then x else y), is_hyp)))
-	    (* tclFAIL 1 (str"setoid rewrite failed") gl *)
-	  
-let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl =
-  cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl
-
-let cl_rewrite_clause (evm,c) left2right occs clause gl =
-  init_setoid ();
-  let meta = Evarutil.new_meta() in
-  let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in
-  let env = pf_env gl in
-  let evars = Evd.merge (project gl) evm in
-  let hypinfo = ref (decompose_setoid_eqhyp env evars c left2right) in
-    cl_rewrite_clause_aux hypinfo meta occs clause gl
-
 open Genarg
 open Extraargs
 
-let occurrences_of = function
-  | n::_ as nl when n < 0 -> (false,List.map abs nl)
-  | nl -> 
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true,nl)
-
-TACTIC EXTEND class_rewrite
-| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), [])) ]
-| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), [])) ]
-| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some (([],id), [])) ]
-| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
-| [ "clrewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ]
-END
-
-
-let clsubstitute o c =
-  let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in
-    Tacticals.onAllClauses 
-      (fun cl -> 
-	match cl with
-	  | Some ((_,id),_) when is_tac id -> tclIDTAC
-	  | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl))
-
-TACTIC EXTEND substitute
-| [ "substitute" orient(o) open_constr(c) ] -> [ clsubstitute o c ]
-END
-
 let pr_debug _prc _prlc _prt b =
   if b then Pp.str "debug" else Pp.mt()
 
@@ -1148,9 +686,9 @@ END
 let pr_mode _prc _prlc _prt m =
   match m with
       Some b ->
-	if b then Pp.str "depth-first" else Pp.str "breadth-fist" 
+	if b then Pp.str "depth-first" else Pp.str "breadth-fist"
     | None -> Pp.mt()
-	
+
 ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode
 | [ "dfs" ] -> [ Some true ]
 | [ "bfs" ] -> [ Some false ]
@@ -1160,13 +698,14 @@ END
 let pr_depth _prc _prlc _prt = function
     Some i -> Util.pr_int i
   | None -> Pp.mt()
-	
+
 ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth
 | [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ]
 END
-      
+
 VERNAC COMMAND EXTEND Typeclasses_Settings
- | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ 
+ | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [
+     typeclasses_debug := d;
      let mode = match s with Some t -> t | None -> true in
      let depth = match depth with Some i -> i | None -> default_eauto_depth in
        Typeclasses.solve_instanciations_problem :=
@@ -1174,661 +713,31 @@ VERNAC COMMAND EXTEND Typeclasses_Settings
    ]
 END
 
+let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl =
+  try 
+    let dbs = list_map_filter (fun db -> try Some (Auto.searchtable_map db) with _ -> None) dbs in
+    let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
+      eauto ~only_classes ~st dbs gl
+   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed") gl
+ 
 TACTIC EXTEND typeclasses_eauto
-| [ "typeclasses" "eauto" debug(d) search_mode(s) depth(depth) ] -> [ 
-    let mode = match s with Some t -> t | None -> true in
-    let depth = match depth with Some i -> i | None -> default_eauto_depth in
-      fun gl -> 
-	let gls = {it = [sig_it gl]; sigma = project gl} in
-	let vals v = List.hd v in
-	  try typeclasses_eauto d (mode, depth) [] (gls, vals) 
-	  with Not_found -> tclFAIL 0 (str" typeclasses eauto failed") gl ]
-END
-
-
-(*     fun gl -> *)
-(*     let env = pf_env gl in *)
-(*     let sigma = project gl in *)
-(*     let proj = sig_it gl in *)
-(*     let evd = Evd.create_evar_defs (Evd.add Evd.empty 1 proj) in *)
-(*     let mode = match s with Some t -> t | None -> true in *)
-(*     let depth = match depth with Some i -> i | None -> default_eauto_depth in *)
-(*       match resolve_typeclass_evars d (mode, depth) env evd false with *)
-(*       | Some evd' ->  *)
-(* 	  let goal = Evd.find (Evd.evars_of evd') 1 in *)
-(* 	    (match goal.evar_body with *)
-(* 	    | Evar_empty -> tclIDTAC gl *)
-(* 	    | Evar_defined b -> refine b gl) *)
-(*       | None -> tclIDTAC gl *)
-(*   ] *)
-
-let _ = 
-  Classes.refine_ref := Refine.refine
-
-(* Compatibility with old Setoids *)
-  
-TACTIC EXTEND setoid_rewrite
-   [ "setoid_rewrite" orient(o) open_constr(c) ]
-   -> [ cl_rewrite_clause c o all_occurrences None ]
- | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) ] ->
-      [ cl_rewrite_clause c o all_occurrences (Some (([],id), []))]
- | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) ] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) None]
- | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id)] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), []))]
- | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ)] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), []))]
+| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ typeclasses_eauto l ]
+| [ "typeclasses" "eauto" ] -> [ typeclasses_eauto ~only_classes:true [typeclasses_db] ]
 END
 
-(* let solve_obligation lemma =  *)
-(*   tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *)
-(*     (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *)
-
-let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l)
-
-let declare_an_instance n s args =
-  ((dummy_loc,Name n), Explicit,
-  CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)), 
-	   args))
-
-let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
-
-let anew_instance binders instance fields = 
-  new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None
-
-let require_library dirpath =
-  let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in
-    Library.require_library [qualid] (Some false)
-
-let declare_instance_refl binders a aeq n lemma = 
-  let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" 
-  in anew_instance binders instance 
-       [((dummy_loc,id_of_string "reflexivity"),lemma)]
-
-let declare_instance_sym binders a aeq n lemma = 
-  let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
-  in anew_instance binders instance 
-       [((dummy_loc,id_of_string "symmetry"),lemma)]
-
-let declare_instance_trans binders a aeq n lemma = 
-  let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" 
-  in anew_instance binders instance 
-       [((dummy_loc,id_of_string "transitivity"),lemma)]
-
-let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None)))
-
-let declare_relation ?(binders=[]) a aeq n refl symm trans = 
-  init_setoid ();
-  let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.SetoidTactics.SetoidRelation"
-  in ignore(anew_instance binders instance []);
-  match (refl,symm,trans) with 
-      (None, None, None) -> ()
-    | (Some lemma1, None, None) -> 
-	ignore (declare_instance_refl binders a aeq n lemma1)
-    | (None, Some lemma2, None) -> 
-	ignore (declare_instance_sym binders a aeq n lemma2)
-    | (None, None, Some lemma3) -> 
-	ignore (declare_instance_trans binders a aeq n lemma3)
-    | (Some lemma1, Some lemma2, None) -> 
-	ignore (declare_instance_refl binders a aeq n lemma1); 
-	ignore (declare_instance_sym binders a aeq n lemma2)
-    | (Some lemma1, None, Some lemma3) -> 
-	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
-	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" 
-	in ignore(
-	    anew_instance binders instance 
-	      [((dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1);
-	       ((dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)])
-    | (None, Some lemma2, Some lemma3) -> 
-	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
-	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" 
-	in ignore(
-	    anew_instance binders instance 
-	      [((dummy_loc,id_of_string "PER_Symmetric"), lemma2);
-	       ((dummy_loc,id_of_string "PER_Transitive"),lemma3)])
-     | (Some lemma1, Some lemma2, Some lemma3) -> 
-	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in 
-	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
-	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" 
-	in ignore(
-	  anew_instance binders instance 
-	    [((dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1);
-	     ((dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2);
-	     ((dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)])
-
-type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
-
-let (wit_binders_let : Genarg.tlevel binders_let_argtype),
-  (globwit_binders_let : Genarg.glevel binders_let_argtype),
-  (rawwit_binders_let : Genarg.rlevel binders_let_argtype) =
-  Genarg.create_arg "binders_let"
-
-open Pcoq.Constr
-
-VERNAC COMMAND EXTEND AddRelation
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) 
-	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
-
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)  
-	"as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) None None ]
-  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] -> 
-      [ declare_relation a aeq n None None None ]
-END
+let _ = Classes.refine_ref := Refine.refine
 
-VERNAC COMMAND EXTEND AddRelation2
-    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) 
-      "as" ident(n) ] ->
-      [ declare_relation a aeq n None (Some lemma2) None ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
-      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddRelation3
-    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) 
-      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) 
-      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) 
-      "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] 
-  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
-	"as" ident(n) ] ->  
-      [ declare_relation a aeq n None None (Some lemma3) ] 
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation
-  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)
-	"reflexivity" "proved" "by" constr(lemma1) 
-	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
-  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)
-	"reflexivity" "proved" "by" constr(lemma1)  
-	"as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
-  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)  "as" ident(n) ] -> 
-      [ declare_relation ~binders:b a aeq n None None None ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation2
-    [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) 
-      "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
-  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation3
-    [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) 
-      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
-  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) 
-      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) 
-      "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] 
-  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
-	"as" ident(n) ] ->  
-      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] 
-END
-
-let mk_qualid s =
-  Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s)
-
-let cHole = CHole (dummy_loc, None)
-
-open Entries
-open Libnames
-
-let respect_projection r ty =
-  let ctx, inst = Sign.decompose_prod_assum ty in
-  let mor, args = destApp inst in
-  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
-  let app = mkApp (Lazy.force respect_proj, 
-		  Array.append args [| instarg |]) in
-    it_mkLambda_or_LetIn app ctx
-      
-let declare_projection n instance_id r =
-  let ty = Global.type_of_global r in
-  let c = constr_of_global r in
-  let term = respect_projection c ty in
-  let typ = Typing.type_of (Global.env ()) Evd.empty term in
-  let ctx, typ = Sign.decompose_prod_assum typ in
-  let typ =
-    let n = 
-      let rec aux t = 
-	match kind_of_term t with
-	    App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> 
-	      succ (aux rel')
-	  | _ -> 0
-      in
-      let init = 
-	match kind_of_term typ with
-	    App (f, args) when eq_constr f (Lazy.force respectful) -> 
-	      mkApp (f, fst (array_chop (Array.length args - 2) args))
-	  | _ -> typ
-      in aux init
-    in
-    let ctx,ccl = Reductionops.decomp_n_prod (Global.env()) Evd.empty (3 * n) typ
-    in it_mkProd_or_LetIn ccl ctx 
-  in
-  let typ = it_mkProd_or_LetIn typ ctx in
-  let cst = 
-    { const_entry_body = term;
-      const_entry_type = Some typ;
-      const_entry_opaque = false;
-      const_entry_boxed = false }
-  in
-    ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
-          
-let build_morphism_signature m =
-  let env = Global.env () in
-  let m = Constrintern.interp_constr Evd.empty env m in
-  let t = Typing.type_of env Evd.empty m in
-  let isevars = ref (Evd.create_evar_defs Evd.empty) in
-  let cstrs = 
-    let rec aux t = 
-      match kind_of_term t with
-	| Prod (na, a, b) -> 
-	    None :: aux b
-	| _ -> []
-    in aux t
-  in
-  let t', sig_, evars = build_signature isevars env t cstrs None snd in
-  let _ = List.iter
-    (fun (ty, rel) -> 
-      Option.iter (fun rel ->
-	let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
-	  ignore (Evarutil.e_new_evar isevars env default)) 
-	rel)
-    evars
-  in
-  let morph = 
-    mkApp (Lazy.force morphism_type, [| t; sig_; m |])
-  in
-  let evd = 
-    Typeclasses.resolve_typeclasses ~fail:true ~onlyargs:false env !isevars in
-  let m = Evarutil.nf_isevar evd morph in
-    Evarutil.check_evars env Evd.empty evd m; m
-	
-let default_morphism sign m =
-  let env = Global.env () in
-  let isevars = ref (Evd.create_evar_defs Evd.empty) in
-  let t = Typing.type_of env Evd.empty m in
-  let _, sign, evars =
-    build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel)
-  in
-  let morph =
-    mkApp (Lazy.force morphism_type, [| t; sign; m |])
-  in
-  let mor = resolve_one_typeclass env morph in
-    mor, respect_projection mor morph
-    	  
-let add_setoid binders a aeq t n =
-  init_setoid ();
-  let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in 
-  let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
-  let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t])  in
-  let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
-  in ignore(
-    anew_instance binders instance
-      [((dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
-       ((dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
-       ((dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
-
-let add_morphism_infer m n =
-  init_setoid ();
-  let instance_id = add_suffix n "_Morphism" in
-  let instance = build_morphism_signature m in
-    if Lib.is_modtype () then 
-      let cst = Declare.declare_internal_constant instance_id
-	(Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical)
-      in
-	add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false cst);
-	declare_projection n instance_id (ConstRef cst)
-    else
-      let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
-	Flags.silently 
-	  (fun () ->
-	    Command.start_proof instance_id kind instance 
-	      (fun _ -> function
-		  Libnames.ConstRef cst -> 
-		    add_instance (Typeclasses.new_instance 
-				     (Lazy.force morphism_class) None false cst);
-		    declare_projection n instance_id (ConstRef cst)
-		| _ -> assert false);
-	    Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) ();
-	Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) () 
-
-let add_morphism binders m s n =
-  init_setoid ();
-  let instance_id = add_suffix n "_Morphism" in
-  let instance = 
-    ((dummy_loc,Name instance_id), Explicit,
-    CAppExpl (dummy_loc, 
-	     (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Morphism")), 
-	     [cHole; s; m]))
-  in	  
-  let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
-    ignore(new_instance binders instance (CRecord (dummy_loc,None,[]))
-	      ~generalize:false ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) None)
-
-VERNAC COMMAND EXTEND AddSetoid1
-   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [ add_setoid [] a aeq t n ]
-  | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [	add_setoid binders a aeq t n ]
-  | [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
-      [ add_morphism_infer m n ]
-  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
-      [ add_morphism [] m s n ]
-  | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
-      [ add_morphism binders m s n ]
-END
-
-(** Bind to "rewrite" too *)
-
-(** Taken from original setoid_replace, to emulate the old rewrite semantics where
-    lemmas are first instantiated and then rewrite proceeds. *)
-
-let check_evar_map_of_evars_defs evd =
- let metas = Evd.meta_list evd in
- let check_freemetas_is_empty rebus =
-  Evd.Metaset.iter
-   (fun m ->
-     if Evd.meta_defined evd m then () else
-      raise
-	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
- in
-  List.iter
-   (fun (_,binding) ->
-     match binding with
-        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
-         check_freemetas_is_empty rebus freemetas
-      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
-                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
-         check_freemetas_is_empty rebus1 freemetas1 ;
-         check_freemetas_is_empty rebus2 freemetas2
-   ) metas
-
-let unification_rewrite l2r c1 c2 cl car rel but gl = 
-  let env = pf_env gl in
-  let (evd',c') =
-    try
-      (* ~flags:(false,true) to allow to mark occurrences that must not be
-         rewritten simply by replacing them with let-defined definitions
-         in the context *)
-      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd
-    with
-	Pretype_errors.PretypeError _ ->
-	  (* ~flags:(true,true) to make Ring work (since it really
-             exploits conversion) *)
-	  Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags
-	    env ((if l2r then c1 else c2),but) cl.evd
-  in
-  let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in
-  let cl' = {cl with evd = evd'} in
-  let cl' =
-    let mvs = clenv_dependent false cl' in
-      clenv_pose_metas_as_evars cl' mvs
-  in
-  let nf c = Evarutil.nf_evar (Evd.evars_of cl'.evd) (Clenv.clenv_nf_meta cl' c) in
-  let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel in
-  check_evar_map_of_evars_defs cl'.evd;
-  let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in
-  let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in
-    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)}
-
-let get_hyp gl (evm,c) clause l2r = 
-  let evars = Evd.merge (project gl) evm in
-  let hi = decompose_setoid_eqhyp (pf_env gl) evars c l2r in
-  let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in
-    unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl
-	
-let general_rewrite_flags = { under_lambdas = false; on_morphisms = false }
-
-let general_s_rewrite cl l2r occs c ~new_goals gl =
-  let meta = Evarutil.new_meta() in
-  let hypinfo = ref (get_hyp gl c cl l2r) in
-  let cl' = Option.map (fun id -> (([],id), [])) cl in
-    cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs cl' gl
-(*     if fst c = Evd.empty || fst c == project gl then tac gl *)
-(*     else *)
-(*       let evars = Evd.merge (fst c) (project gl) in *)
-(* 	tclTHEN (Refiner.tclEVARS evars) tac gl *)
-
-let general_s_rewrite_clause x =
-  init_setoid ();
-  match x with
-    | None -> general_s_rewrite None
-    | Some id -> general_s_rewrite (Some id)
-	
-let _ = Equality.register_general_setoid_rewrite_clause general_s_rewrite_clause
-
-let is_loaded d =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-    Library.library_is_loaded dir
-
-let try_loaded f gl =
-  if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl
-  else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl
-
-let try_classes t gls = 
-  try t gls
-  with (Pretype_errors.PretypeError _) as e -> raise e
-
-TACTIC EXTEND try_classes
-  [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ]
-END
-
-open Rawterm
-open Environ
-open Refiner
-
-let typeclass_app evm gl ?(bindings=NoBindings) c ty =
-  let nprod = nb_prod (pf_concl gl) in
-  let n = nb_prod ty - nprod in
-    if n<0 then error "Apply_tc: theorem has not enough premisses.";
-    Refiner.tclTHEN (Refiner.tclEVARS evm)
-      (fun gl ->
-	let clause = make_clenv_binding_apply gl (Some n) (c,ty) bindings in
-	let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in
-	let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in
-	  tclTHEN (Clenvtac.clenv_refine true {cl' with evd = evd'})
-	    tclNORMEVAR gl) gl
-
-open Tacinterp
-open Pretyping
-
-let my_ist =
-  { lfun = [];
-    avoid_ids = [];
-    debug = Tactic_debug.DebugOff;
-    trace = [] }
-
-let rawconstr_and_expr (evd, c) = c
-  
-let rawconstr_and_expr_of_rawconstr_bindings = function
-  | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map rawconstr_and_expr l)
-  | ExplicitBindings l -> ExplicitBindings (List.map (fun (l,b,c) -> (l,b,rawconstr_and_expr c)) l)
-      
-let my_glob_sign sigma env = {
-  ltacvars = [], [] ;
-  ltacrecvars = [];
-  gsigma = sigma ;
-  genv = env }
-
-let typeclass_app_constrexpr t ?(bindings=NoBindings) gl =
-  let env = pf_env gl in
-  let evars = ref (create_evar_defs (project gl)) in
-  let gs = my_glob_sign (project gl) env in
-  let t', bl = Tacinterp.intern_constr_with_bindings gs (t,bindings) in
-  let j = Pretyping.Default.understand_judgment_tcc evars env (fst t') in
-  let bindings = Tacinterp.interp_bindings my_ist gl bl in
-    typeclass_app (Evd.evars_of !evars) gl ~bindings:bindings j.uj_val j.uj_type
-
-let typeclass_app_raw (_,t) gl =
-  let env = pf_env gl in
-  let evars = ref (create_evar_defs (project gl)) in
-  let j = Pretyping.Default.understand_judgment_tcc evars env t in
-    typeclass_app (Evd.evars_of !evars) gl j.uj_val j.uj_type
-
-let pr_gen prc _prlc _prtac c = prc c
-
-let pr_ceb _prc _prlc _prtac raw = mt ()
-
-let interp_constr_expr_bindings _ _ t = t
-
-let intern_constr_expr_bindings ist t = t
-
-open Pcoq.Tactic
-
-type constr_expr_bindings = constr_expr with_bindings
-
-ARGUMENT EXTEND constr_expr_bindings
-    TYPED AS constr_expr_bindings
-    PRINTED BY pr_ceb
-     
-     INTERPRETED BY interp_constr_expr_bindings	
-    GLOBALIZED BY intern_constr_expr_bindings
-
-     
-  [ constr_with_bindings(c) ] -> [ c ]
-END
-
-TACTIC EXTEND apply_typeclasses
-[ "typeclass_app" constr_expr_bindings(t) ] -> [ typeclass_app_constrexpr (fst t) ~bindings:(snd t) ]
-END
-TACTIC EXTEND apply_typeclasses_abbrev
-[ "tcapp" raw(t) ] -> [ typeclass_app_raw t ]
-END
-
-(* [setoid_]{reflexivity,symmetry,transitivity} tactics *)
-
-let not_declared env ty rel =
-  tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ 
-		str ty ++ str" relation. Maybe you need to require the Setoid library")
-
-let relation_of_constr env c = 
-  match kind_of_term c with
-    | App (f, args) when Array.length args >= 2 -> 
-	let relargs, args = array_chop (Array.length args - 2) args in
-	  mkApp (f, relargs), args
-    | _ -> errorlabstrm "relation_of_constr" 
-	(str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.")
-	
-let setoid_proof gl ty fn fallback =
-  let env = pf_env gl in
-    try 
-      let rel, args = relation_of_constr env (pf_concl gl) in
-      let evm, car = project gl, pf_type_of gl args.(0) in
-	fn env evm car rel gl
-    with e -> 
-      match fallback gl with
-      | Some tac -> tac gl
-      | None -> 
-	  match e with
-	  | Not_found ->
-	      let rel, args = relation_of_constr env (pf_concl gl) in
-		not_declared env ty rel gl
-	  | _ -> raise e
-	      
-let setoid_reflexivity gl =
-  setoid_proof gl "reflexive" 
-    (fun env evm car rel -> apply (get_reflexive_proof env evm car rel))
-    (reflexivity_red true)
-	  
-let setoid_symmetry gl =
-  setoid_proof gl "symmetric" 
-    (fun env evm car rel -> apply (get_symmetric_proof env evm car rel))
-    (symmetry_red true)
-    
-let setoid_transitivity c gl =
-  setoid_proof gl "transitive" 
-    (fun env evm car rel ->
-      apply_with_bindings
-	((get_transitive_proof env evm car rel),
-	Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]))
-    (transitivity_red true c)
-    
-(*
-  let setoid_proof gl ty ?(bindings=NoBindings) meth fallback =
-  try
-  typeclass_app_constrexpr 
-  (CRef (Qualid (dummy_loc, Nametab.shortest_qualid_of_global Idset.empty
-  (Lazy.force meth)))) ~bindings gl
-  with Not_found | Typeclasses_errors.TypeClassError (_, _) |
-      Stdpp.Exc_located (_, Typeclasses_errors.TypeClassError (_, _)) -> 
-	match fallback gl with 
-	| Some tac -> tac gl
-	| None ->
-	    let env = pf_env gl in
-	    let rel, args = relation_of_constr env (pf_concl gl) in
-	      not_declared env ty rel gl
-      
-let setoid_reflexivity gl =
-  setoid_proof gl "reflexive" reflexive_proof_global (reflexivity_red true)
-    
-let setoid_symmetry gl =
-  setoid_proof gl "symmetric" symmetric_proof_global (symmetry_red true)
-    
-let setoid_transitivity c gl =
-  let binding_name = 
-    next_ident_away (id_of_string "y") (ids_of_named_context (named_context (pf_env gl))) 
-  in
-    setoid_proof gl "transitive" 
-      ~bindings:(Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp binding_name, constrIn c ])
-      transitive_proof_global (transitivity_red true c)
-*)
-let setoid_symmetry_in id gl =
-  let ctype = pf_type_of gl (mkVar id) in
-  let binders,concl = Sign.decompose_prod_assum ctype in
-  let (equiv, args) = decompose_app concl in
-  let rec split_last_two = function
-    | [c1;c2] -> [],(c1, c2)
-    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
-    | _ -> error "The term provided is not an equivalence."
-  in
-  let others,(c1,c2) = split_last_two args in
-  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
-  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
-  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
-    tclTHENS (cut new_hyp)
-      [ intro_replacing id;
-	tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ]
-      gl
-
-let _ = Tactics.register_setoid_reflexivity setoid_reflexivity
-let _ = Tactics.register_setoid_symmetry setoid_symmetry
-let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in
-let _ = Tactics.register_setoid_transitivity setoid_transitivity
-
-TACTIC EXTEND setoid_symmetry
-   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
- | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
-END
-
-TACTIC EXTEND setoid_reflexivity
-[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
-END
-
-TACTIC EXTEND setoid_transitivity
-[ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ]
-END
+(** Take the head of the arity of a constr.
+    Used in the partial application tactic. *)
 
 let rec head_of_constr t =
   let t = strip_outer_cast(collapse_appl t) in
     match kind_of_term t with
-    | Prod (_,_,c2)  -> head_of_constr c2 
+    | Prod (_,_,c2)  -> head_of_constr c2
     | LetIn (_,_,_,c2) -> head_of_constr c2
     | App (f,args)  -> head_of_constr f
     | _      -> t
-      
+
 TACTIC EXTEND head_of_constr
   [ "head_of_constr" ident(h) constr(c) ] -> [
     let c = head_of_constr c in
@@ -1836,101 +745,23 @@ TACTIC EXTEND head_of_constr
   ]
 END
 
-
-let coq_List_nth =  lazy (gen_constant ["Lists"; "List"] "nth")
-let coq_List_cons =  lazy (gen_constant ["Lists"; "List"] "cons")
-let coq_List_nil =  lazy (gen_constant ["Lists"; "List"] "nil")
-
-let freevars c =
-  let rec frec acc c = match kind_of_term c with
-    | Var id       -> Idset.add id acc
-    | _ -> fold_constr frec acc c
-  in 
-  frec Idset.empty c
-
-let coq_zero =  lazy (gen_constant ["Init"; "Datatypes"] "O")
-let coq_succ =  lazy (gen_constant ["Init"; "Datatypes"] "S")
-let coq_nat =  lazy (gen_constant ["Init"; "Datatypes"] "nat")
-
-let rec coq_nat_of_int = function
-  | 0 -> Lazy.force coq_zero
-  | n -> mkApp (Lazy.force coq_succ, [| coq_nat_of_int (pred n) |])
-
-let varify_constr_list ty def varh c =
-  let vars = Idset.elements (freevars c) in
-  let mkaccess i = 
-    mkApp (Lazy.force coq_List_nth,
-	  [| ty; coq_nat_of_int i; varh; def |])
-  in
-  let l = List.fold_right (fun id acc -> 
-    mkApp (Lazy.force coq_List_cons, [| ty ; mkVar id; acc |]))
-    vars (mkApp (Lazy.force coq_List_nil, [| ty |]))
-  in
-  let subst = 
-    list_map_i (fun i id -> (id, mkaccess i)) 0 vars
-  in
-    l, replace_vars subst c
-
-let coq_varmap_empty =  lazy (gen_constant ["ring"; "Quote"] "Empty_vm")
-let coq_varmap_node =  lazy (gen_constant ["ring"; "Quote"] "Node_vm")
-(*  | Node_vm : A -> varmap -> varmap -> varmap. *)
-  
-let coq_varmap_lookup =  lazy (gen_constant ["ring"; "Quote"] "varmap_find")
-
-let coq_index_left =  lazy (gen_constant ["ring"; "Quote"] "Left_idx")
-let coq_index_right =  lazy (gen_constant ["ring"; "Quote"] "Right_idx")
-let coq_index_end =  lazy (gen_constant ["ring"; "Quote"] "End_idx")
-
-let rec split_interleaved l r = function
-  | hd :: hd' :: tl' ->
-      split_interleaved (hd :: l) (hd' :: r) tl'
-  | hd :: [] -> (List.rev (hd :: l), List.rev r)
-  | [] -> (List.rev l, List.rev r)
-      
-(* let rec mkidx i acc = *)
-(*   if i mod 2 = 0 then *)
-(*     let acc' = mkApp (Lazy.force coq_index_left, [|acc|]) in *)
-(*       if i = 0 then acc' *)
-(*       else mkidx (i / 2) acc' *)
-(*   else *)
-(*     let acc' = mkApp (Lazy.force coq_index_right, [|acc|]) in *)
-(*       if i = 1 then acc' *)
-(*       else mkidx (i / 2) acc' *)
-
-let rec mkidx i p =
-  if i mod 2 = 0 then
-    if i = 0 then mkApp (Lazy.force coq_index_left, [|Lazy.force coq_index_end|])
-    else mkApp (Lazy.force coq_index_left, [|mkidx (i - p) (2 * p)|])
-  else if i = 1 then mkApp (Lazy.force coq_index_right, [|Lazy.force coq_index_end|])
-  else mkApp (Lazy.force coq_index_right, [|mkidx (i - p) (2 * p)|])
-	
-let varify_constr_varmap ty def varh c =
-  let vars = Idset.elements (freevars c) in
-  let mkaccess i = 
-    mkApp (Lazy.force coq_varmap_lookup,
-	  [| ty; def; i; varh |])
-  in
-  let rec vmap_aux l cont = 
-    match l with 
-    | [] -> [], mkApp (Lazy.force coq_varmap_empty, [| ty |])
-    | hd :: tl -> 
-	let left, right = split_interleaved [] [] tl in
-	let leftvars, leftmap = vmap_aux left (fun x -> cont (mkApp (Lazy.force coq_index_left, [| x |]))) in
-	let rightvars, rightmap = vmap_aux right (fun x -> cont (mkApp (Lazy.force coq_index_right, [| x |]))) in
-	  (hd, cont (Lazy.force coq_index_end)) :: leftvars @ rightvars, 
-	mkApp (Lazy.force coq_varmap_node, [| ty; hd; leftmap ; rightmap |])
-  in
-  let subst, vmap = vmap_aux (def :: List.map (fun x -> mkVar x) vars) (fun x -> x) in
-  let subst = List.map (fun (id, x) -> (destVar id, mkaccess x)) (List.tl subst) in
-    vmap, replace_vars subst c
-  
-
-TACTIC EXTEND varify
-  [ "varify" ident(varh) ident(h') constr(ty) constr(def) constr(c) ] -> [
-    let vars, c' = varify_constr_varmap ty def (mkVar varh) c in
-      tclTHEN (letin_tac None (Name varh) vars None allHyps)
-	(letin_tac None (Name h') c' None allHyps)
-  ]
+TACTIC EXTEND not_evar
+  [ "not_evar" constr(ty) ] -> [
+    match kind_of_term ty with
+    | Evar _ -> tclFAIL 0 (str"Evar")
+    | _ -> tclIDTAC ]
 END
 
+TACTIC EXTEND is_ground
+  [ "is_ground" constr(ty) ] -> [ fun gl ->
+    if Evarutil.is_ground_term (project gl) ty then tclIDTAC gl
+    else tclFAIL 0 (str"Not ground") gl ]
+END
 
+TACTIC EXTEND autoapply
+  [ "autoapply" constr(c) "using" preident(i) ] -> [ fun gl ->
+    let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in
+    let cty = pf_type_of gl c in
+    let ce = mk_clenv_from gl (c,cty) in
+      unify_e_resolve flags (c,ce) gl ]
+END
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 313d74a1..46ed2134 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: contradiction.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Term
@@ -27,9 +27,9 @@ let absurd c gls =
     (Evd.create_goal_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in
   let c = j.Environ.utj_val in
   (tclTHENS
-     (tclTHEN (elim_type (build_coq_False ())) (cut c)) 
+     (tclTHEN (elim_type (build_coq_False ())) (cut c))
      ([(tclTHENS
-          (cut (applist(build_coq_not (),[c]))) 
+          (cut (applist(build_coq_not (),[c])))
 	  ([(tclTHEN intros
 	       ((fun gl ->
 		   let ida = pf_nth_hyp_id gl 1
@@ -59,7 +59,7 @@ let contradiction_context gl =
 	else match kind_of_term typ with
 	  | Prod (na,t,u) when is_empty_type u ->
 	      (try
-		filter_hyp (fun typ -> pf_conv_x_leq gl typ t) 
+		filter_hyp (fun typ -> pf_conv_x_leq gl typ t)
 		  (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
 		  gl
 	      with Not_found -> seek_neg rest gl)
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index e417f500..9c38362a 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: contradiction.mli 9842 2007-05-20 17:44:23Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -17,4 +17,4 @@ open Genarg
 (*i*)
 
 val absurd                      : constr -> tactic
-val contradiction               : constr with_ebindings option -> tactic
+val contradiction               : constr with_bindings option -> tactic
diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml
index 62824670..2b583af4 100644
--- a/tactics/decl_interp.ml
+++ b/tactics/decl_interp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: decl_interp.ml 12422 2009-10-27 08:42:49Z corbinea $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
@@ -22,18 +22,18 @@ open Pp
 
 (* INTERN *)
 
-let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) 
+let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args)
 
-let intern_justification_items globs = 
+let intern_justification_items globs =
   Option.map (List.map (intern_constr globs))
 
-let intern_justification_method globs = 
+let intern_justification_method globs =
   Option.map (intern_tactic globs)
 
 let intern_statement intern_it globs st =
   {st_label=st.st_label;
    st_it=intern_it globs st.st_it}
-    
+
 let intern_no_bind intern_it globs x =
   globs,intern_it globs x
 
@@ -41,22 +41,22 @@ let intern_constr_or_thesis globs = function
     Thesis n -> Thesis n
   | This c -> This (intern_constr globs c)
 
-let add_var id globs= 
+let add_var id globs=
   let l1,l2=globs.ltacvars in
     {globs with ltacvars= (id::l1),(id::l2)}
 
 let add_name nam globs=
- match nam with 
+ match nam with
      Anonymous -> globs
    | Name id -> add_var id globs
 
-let intern_hyp iconstr globs = function 
+let intern_hyp iconstr globs = function
     Hvar (loc,(id,topt)) -> add_var id globs,
       Hvar (loc,(id,Option.map (intern_constr globs) topt))
   | Hprop st -> add_name st.st_label globs,
       Hprop (intern_statement iconstr globs st)
 
-let intern_hyps iconstr globs hyps = 
+let intern_hyps iconstr globs hyps =
   snd (list_fold_map (intern_hyp iconstr) globs hyps)
 
 let intern_cut intern_it globs cut=
@@ -65,32 +65,32 @@ let intern_cut intern_it globs cut=
      cut_by=intern_justification_items nglobs cut.cut_by;
      cut_using=intern_justification_method nglobs cut.cut_using}
 
-let intern_casee globs = function 
+let intern_casee globs = function
     Real c -> Real (intern_constr globs c)
-  | Virtual cut -> Virtual 
-      (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) 
+  | Virtual cut -> Virtual
+      (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut)
 
 let intern_hyp_list args globs =
   let intern_one globs (loc,(id,opttyp)) =
     (add_var id globs),
     (loc,(id,Option.map (intern_constr globs) opttyp)) in
-  list_fold_map intern_one globs args 
+  list_fold_map intern_one globs args
 
-let intern_suffices_clause globs (hyps,c) = 
+let intern_suffices_clause globs (hyps,c) =
   let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in
-    nglobs,(nhyps,intern_constr_or_thesis nglobs c) 
+    nglobs,(nhyps,intern_constr_or_thesis nglobs c)
 
-let intern_fundecl args body globs= 
+let intern_fundecl args body globs=
   let nglobs,nargs = intern_hyp_list args globs in
     nargs,intern_constr nglobs body
-          
+
 let rec add_vars_of_simple_pattern globs = function
     CPatAlias (loc,p,id) ->
       add_vars_of_simple_pattern (add_var id globs) p
-(*      Stdpp.raise_with_loc loc 
+(*      Stdpp.raise_with_loc loc
 	(UserError ("simple_pattern",str "\"as\" is not allowed here"))*)
   | CPatOr (loc, _)->
-      Stdpp.raise_with_loc loc 
+      Stdpp.raise_with_loc loc
 	(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
   | CPatDelimiters (_,_,p) ->
       add_vars_of_simple_pattern globs p
@@ -99,26 +99,26 @@ let rec add_vars_of_simple_pattern globs = function
   | CPatNotation(_,_,(pl,pll)) ->
       List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll))
   | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
-  |  _  -> globs 
+  |  _  -> globs
 
 let rec intern_bare_proof_instr globs = function
     Pthus i -> Pthus (intern_bare_proof_instr globs i)
   | Pthen i -> Pthen (intern_bare_proof_instr globs i)
   | Phence i -> Phence (intern_bare_proof_instr globs i)
-  | Pcut c -> Pcut 
-      (intern_cut 
+  | Pcut c -> Pcut
+      (intern_cut
 	 (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c)
-  | Psuffices c -> 
+  | Psuffices c ->
       Psuffices (intern_cut intern_suffices_clause globs c)
-  | Prew (s,c) -> Prew 
-      (s,intern_cut 
-	 (intern_no_bind  (intern_statement intern_constr)) globs c) 
+  | Prew (s,c) -> Prew
+      (s,intern_cut
+	 (intern_no_bind  (intern_statement intern_constr)) globs c)
   | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps)
-  | Pcase (params,pat,hyps) -> 
+  | Pcase (params,pat,hyps) ->
       let nglobs,nparams = intern_hyp_list params globs in
       let nnglobs= add_vars_of_simple_pattern nglobs pat in
       let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in
-	Pcase (nparams,pat,nhyps) 
+	Pcase (nparams,pat,nhyps)
   | Ptake witl -> Ptake (List.map (intern_constr globs) witl)
   | Pconsider (c,hyps) -> Pconsider (intern_constr globs c,
 				      intern_hyps intern_constr globs hyps)
@@ -130,7 +130,7 @@ let rec intern_bare_proof_instr globs = function
   | Plet hyps -> Plet (intern_hyps intern_constr globs hyps)
   | Pclaim st -> Pclaim (intern_statement intern_constr globs st)
   | Pfocus st -> Pfocus (intern_statement intern_constr globs st)
-  | Pdefine (id,args,body) -> 
+  | Pdefine (id,args,body) ->
       let nargs,nbody = intern_fundecl args body globs in
 	Pdefine (id,nargs,nbody)
   | Pcast (id,typ) ->
@@ -145,10 +145,10 @@ let rec intern_proof_instr globs instr=
 let interp_justification_items sigma env =
     Option.map (List.map (fun c ->understand sigma env (fst c)))
 
-let interp_constr check_sort sigma env c = 
-  if check_sort then 
-    understand_type sigma env (fst c) 
-  else 
+let interp_constr check_sort sigma env c =
+  if check_sort then
+    understand_type sigma env (fst c)
+  else
     understand sigma env (fst c)
 
 let special_whd env =
@@ -162,13 +162,13 @@ let decompose_eq env id =
   let whd = special_whd env typ in
     match kind_of_term whd with
 	App (f,args)->
-	  if eq_constr f _eq && (Array.length args)=3 
+	  if eq_constr f _eq && (Array.length args)=3
 	  then args.(0)
 	  else error "Previous step is not an equality."
       | _ -> error "Previous step is not an equality."
 
 let get_eq_typ info env =
-  let typ = decompose_eq env (get_last env) in  
+  let typ = decompose_eq env (get_last env) in
     typ
 
 let interp_constr_in_type typ sigma env c =
@@ -177,33 +177,28 @@ let interp_constr_in_type typ sigma env c =
 let interp_statement interp_it sigma env st =
   {st_label=st.st_label;
    st_it=interp_it sigma env st.st_it}
-	
+
 let interp_constr_or_thesis check_sort sigma env = function
     Thesis n -> Thesis n
   | This c -> This (interp_constr check_sort sigma env c)
 
-let type_tester_var body typ = 
-  raw_app(dummy_loc,
-       RLambda(dummy_loc,Anonymous,Explicit,typ,
-	       RSort (dummy_loc,RProp Null)),body)
-
-let abstract_one_hyp inject h raw = 
-  match h with 
-      Hvar (loc,(id,None)) ->  
+let abstract_one_hyp inject h raw =
+  match h with
+      Hvar (loc,(id,None)) ->
 	RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)
-    | Hvar (loc,(id,Some typ)) ->  
+    | Hvar (loc,(id,Some typ)) ->
 	RProd (dummy_loc,Name id, Explicit, fst typ, raw)
-    | Hprop st -> 
+    | Hprop st ->
 	RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw)
 
-let rawconstr_of_hyps inject hyps head = 
+let rawconstr_of_hyps inject hyps head =
   List.fold_right (abstract_one_hyp inject) hyps head
 
 let raw_prop = RSort (dummy_loc,RProp Null)
-  
-let rec match_hyps blend names constr = function 
+
+let rec match_hyps blend names constr = function
     [] -> [],substl names constr
-  | hyp::q -> 
+  | hyp::q ->
       let (name,typ,body)=destProd constr in
       let st= {st_label=name;st_it=substl names typ} in
       let qnames=
@@ -216,7 +211,7 @@ let rec match_hyps blend names constr = function
       let rhyps,head = match_hyps blend qnames body q in
 	qhyp::rhyps,head
 
-let interp_hyps_gen inject blend sigma env hyps head = 
+let interp_hyps_gen inject blend sigma env hyps head =
   let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in
     match_hyps blend [] constr hyps
 
@@ -224,42 +219,42 @@ let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma e
 
 let dummy_prefix= id_of_string "__"
 
-let rec deanonymize ids = 
-  function 
-      PatVar (loc,Anonymous) -> 
+let rec deanonymize ids =
+  function
+      PatVar (loc,Anonymous) ->
 	let (found,known) = !ids in
-	let new_id=Nameops.next_ident_away dummy_prefix known in
+	let new_id=Namegen.next_ident_away dummy_prefix known in
 	let _= ids:= (loc,new_id) :: found , new_id :: known in
 	  PatVar (loc,Name new_id)
-    | PatVar (loc,Name id) as pat -> 
+    | PatVar (loc,Name id) as pat ->
 	let (found,known) = !ids in
 	let _= ids:= (loc,id) :: found , known in
 	  pat
-    | PatCstr(loc,cstr,lpat,nam) -> 
+    | PatCstr(loc,cstr,lpat,nam) ->
 	PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam)
 
 let rec raw_of_pat =
-  function 
-      PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" 
-    | PatVar (loc,Name id) -> 
+  function
+      PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable"
+    | PatVar (loc,Name id) ->
 	  RVar (loc,id)
-    | PatCstr(loc,((ind,_) as cstr),lpat,_) -> 
+    | PatCstr(loc,((ind,_) as cstr),lpat,_) ->
 	let mind= fst (Global.lookup_inductive ind) in
 	let rec add_params n q =
 	  if n<=0 then q else
 	    add_params (pred n) (RHole(dummy_loc,
 				       Evd.TomatchTypeParameter(ind,n))::q) in
-	    let args = List.map raw_of_pat lpat in 
+	    let args = List.map raw_of_pat lpat in
 	      raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr),
-		   add_params mind.Declarations.mind_nparams args) 
-			 
+		   add_params mind.Declarations.mind_nparams args)
+
 let prod_one_hyp = function
     (loc,(id,None)) ->
-      (fun raw ->  
+      (fun raw ->
 	 RProd (dummy_loc,Name id, Explicit,
 		RHole (loc,Evd.BinderType (Name id)), raw))
-  | (loc,(id,Some typ)) -> 
-      (fun raw ->  
+  | (loc,(id,Some typ)) ->
+      (fun raw ->
 	 RProd (dummy_loc,Name id, Explicit, fst typ, raw))
 
 let prod_one_id (loc,id) raw =
@@ -270,13 +265,13 @@ let let_in_one_alias (id,pat) raw =
   RLetIn (dummy_loc,Name id, raw_of_pat pat, raw)
 
 let rec bind_primary_aliases map pat =
-  match pat with 
+  match pat with
       PatVar (_,_) -> map
     | PatCstr(loc,_,lpat,nam) ->
 	let map1 =
-	  match nam with 
+	  match nam with
 	      Anonymous -> map
-	    | Name id -> (id,pat)::map 
+	    | Name id -> (id,pat)::map
 	in
 	  List.fold_left bind_primary_aliases map1 lpat
 
@@ -288,17 +283,17 @@ let bind_aliases patvars subst patt =
   let map1 = bind_secondary_aliases map subst in
   List.rev map1
 
-let interp_pattern env pat_expr = 
+let interp_pattern env pat_expr =
   let patvars,pats = Constrintern.intern_pattern env pat_expr in
-    match pats with 
+    match pats with
 	[] -> anomaly "empty pattern list"
       | [subst,patt] ->
 	  (patvars,bind_aliases patvars subst patt,patt)
       | _  -> anomaly "undetected disjunctive pattern"
 
-let rec match_args dest names constr = function 
+let rec match_args dest names constr = function
     [] -> [],names,substl names constr
-  | _::q -> 
+  | _::q ->
       let (name,typ,body)=dest constr in
       let st={st_label=name;st_it=substl names typ} in
       let qnames=
@@ -308,9 +303,9 @@ let rec match_args dest names constr = function
       let args,bnames,body = match_args dest qnames body q in
 	st::args,bnames,body
 
-let rec match_aliases names constr = function 
+let rec match_aliases names constr = function
     [] -> [],names,substl names constr
-  | _::q -> 
+  | _::q ->
       let (name,c,typ,body)=destLetIn constr in
       let st={st_label=name;st_it=(substl names c,substl names typ)} in
       let qnames=
@@ -329,7 +324,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
       | _ -> error "No proof per cases/induction/inversion in progress." in
   let mib,oib=Global.lookup_inductive  pinfo.per_ind in
   let num_params = pinfo.per_nparams in
-  let _ = 
+  let _ =
     let expected = mib.Declarations.mind_nparams - num_params in
       if List.length params <> expected then
 	errorlabstrm "suppose it is" 
@@ -338,12 +333,12 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
 	     str "expected.") in
   let app_ind =
     let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
-    let rparams = List.map detype_ground pinfo.per_params in 
-    let rparams_rec = 
-      List.map 
-	(fun (loc,(id,_)) -> 
-	   RVar (loc,id)) params in 
-    let dum_args= 
+    let rparams = List.map detype_ground pinfo.per_params in
+    let rparams_rec =
+      List.map
+	(fun (loc,(id,_)) ->
+	   RVar (loc,id)) params in
+    let dum_args=
       list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
 	oib.Declarations.mind_nrealargs in
       raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
@@ -351,22 +346,22 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
   let inject = function
       Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null)
     | Thesis (For rec_occ) ->
-	if not (List.mem rec_occ pat_vars) then 
-	  errorlabstrm "suppose it is" 
-	    (str "Variable " ++ Nameops.pr_id rec_occ ++ 
+	if not (List.mem rec_occ pat_vars) then
+	  errorlabstrm "suppose it is"
+	    (str "Variable " ++ Nameops.pr_id rec_occ ++
 	       str " does not occur in pattern.");
 	Rawterm.RSort(dummy_loc,RProp Null)
     | This (c,_) -> c in
   let term1 = rawconstr_of_hyps inject hyps raw_prop in
   let loc_ids,npatt =
     let rids=ref ([],pat_vars) in
-    let npatt= deanonymize rids patt in 
+    let npatt= deanonymize rids patt in
       List.rev (fst !rids),npatt in
   let term2 =
     RLetIn(dummy_loc,Anonymous,
 	   RCast(dummy_loc,raw_of_pat npatt,
 		 CastConv (DEFAULTcast,app_ind)),term1) in
-  let term3=List.fold_right let_in_one_alias aliases term2 in  
+  let term3=List.fold_right let_in_one_alias aliases term2 in
   let term4=List.fold_right prod_one_id loc_ids term3 in
   let term5=List.fold_right prod_one_hyp params term4 in
   let constr = understand  sigma env term5 in
@@ -375,8 +370,8 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
   let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in
   let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in
   let blend st st' =
-    match st'.st_it with 
-	Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} 
+    match st'.st_it with
+	Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label}
       | This _ -> {st_it = This st.st_it;st_label=st.st_label} in
   let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in
     tparams,{pat_vars=tpatvars;
@@ -388,7 +383,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
 
 let interp_cut interp_it sigma env cut=
   let nenv,nstat = interp_it sigma env cut.cut_stat in
-    {cut with 
+    {cut with
        cut_stat=nstat;
        cut_by=interp_justification_items sigma nenv cut.cut_by}
 
@@ -398,7 +393,7 @@ let interp_no_bind interp_it sigma env x =
 let interp_suffices_clause sigma env (hyps,cot)=
   let (locvars,_) as res =
     match cot with
-	This (c,_) -> 
+	This (c,_) ->
 	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in
 	  nhyps,This nc
       | Thesis Plain as th  -> interp_hyps sigma env hyps,th
@@ -409,26 +404,26 @@ let interp_suffices_clause sigma env (hyps,cot)=
 	  match st.st_label with
 	      Name id -> Environ.push_named (id,None,st.st_it) env0
 	    | _ -> env in
-  let nenv = List.fold_right push_one locvars env in 
-    nenv,res 
-	  
-let interp_casee sigma env = function 
+  let nenv = List.fold_right push_one locvars env in
+    nenv,res
+
+let interp_casee sigma env = function
     Real c -> Real (understand sigma env (fst c))
-  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) 
+  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut)
 
 let abstract_one_arg = function
     (loc,(id,None)) ->
-      (fun raw ->  
-	 RLambda (dummy_loc,Name id, Explicit, 
+      (fun raw ->
+	 RLambda (dummy_loc,Name id, Explicit,
 		RHole (loc,Evd.BinderType (Name id)), raw))
-  | (loc,(id,Some typ)) -> 
-      (fun raw ->  
+  | (loc,(id,Some typ)) ->
+      (fun raw ->
 	 RLambda (dummy_loc,Name id, Explicit, fst typ, raw))
 
-let rawconstr_of_fun args body = 
+let rawconstr_of_fun args body =
   List.fold_right abstract_one_arg args (fst body)
 
-let interp_fun sigma env args body = 
+let interp_fun sigma env args body =
   let constr=understand sigma env (rawconstr_of_fun args body) in
     match_args destLambda [] constr args
 
@@ -436,22 +431,22 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu
     Pthus i -> Pthus (interp_bare_proof_instr info sigma env i)
   | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i)
   | Phence i -> Phence (interp_bare_proof_instr info sigma env i)
-  | Pcut c -> Pcut (interp_cut 
-		      (interp_no_bind (interp_statement 
-					 (interp_constr_or_thesis true))) 
-		      sigma env c) 
-  | Psuffices c ->  
+  | Pcut c -> Pcut (interp_cut
+		      (interp_no_bind (interp_statement
+					 (interp_constr_or_thesis true)))
+		      sigma env c)
+  | Psuffices c ->
       Psuffices (interp_cut interp_suffices_clause sigma env c)
-  | Prew (s,c) -> Prew (s,interp_cut 
-			  (interp_no_bind (interp_statement 
+  | Prew (s,c) -> Prew (s,interp_cut
+			  (interp_no_bind (interp_statement
 			     (interp_constr_in_type (get_eq_typ info env))))
-			  sigma env c) 
+			  sigma env c)
 
   | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps)
-  | Pcase (params,pat,hyps) -> 
-      let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in 
+  | Pcase (params,pat,hyps) ->
+      let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in
 	Pcase (tparams,tpat,thyps)
-  | Ptake witl -> 
+  | Ptake witl ->
       Ptake (List.map (fun c -> understand sigma env (fst c)) witl)
   | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c,
 				     interp_hyps sigma env hyps)
@@ -463,15 +458,15 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu
   | Plet hyps -> Plet (interp_hyps sigma env hyps)
   | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st)
   | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st)
-  | Pdefine (id,args,body) -> 
+  | Pdefine (id,args,body) ->
       let nargs,_,nbody = interp_fun sigma env args body in
 	Pdefine (id,nargs,nbody)
-  | Pcast (id,typ) -> 
+  | Pcast (id,typ) ->
       Pcast(id,interp_constr true sigma env typ)
 
 let rec interp_proof_instr info sigma env instr=
   {emph = instr.emph;
    instr = interp_bare_proof_instr info sigma env instr.instr}
- 
+
 
 
diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli
index 59b3b530..bd085938 100644
--- a/tactics/decl_interp.mli
+++ b/tactics/decl_interp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_interp.mli 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id$ *)
 
 open Tacinterp
 open Decl_expr
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
index 67d1d41a..9c58f06e 100644
--- a/tactics/decl_proof_instr.ml
+++ b/tactics/decl_proof_instr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_proof_instr.ml 12422 2009-10-27 08:42:49Z corbinea $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -28,6 +28,7 @@ open Tactics
 open Tacticals
 open Term
 open Termops
+open Namegen
 open Reductionops
 open Goptions
 
@@ -36,27 +37,27 @@ open Goptions
 
 let get_its_info gls = get_info gls.it
 
-let get_strictness,set_strictness = 
+let get_strictness,set_strictness =
   let strictness = ref false in
     (fun () -> (!strictness)),(fun b -> strictness:=b)
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "strict mode";
-      optkey   = (SecondaryTable ("Strict","Proofs"));
+      optkey   = ["Strict";"Proofs"];
       optread  = get_strictness;
       optwrite = set_strictness }
 
-let tcl_change_info_gen info_gen = 
+let tcl_change_info_gen info_gen =
   (fun gls ->
-  let gl =sig_it gls in  
-    {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, 
-  function 
+  let gl =sig_it gls in
+    {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls},
+  function
       [pftree] ->
 	{pftree with
 	   goal=gl;
-	   ref=Some (Prim Change_evars,[pftree])} 
+	   ref=Some (Prim Change_evars,[pftree])}
     | _ -> anomaly "change_info : Wrong number of subtrees")
 
 let tcl_change_info info gls =  tcl_change_info_gen (Some (pm_in info)) gls
@@ -78,27 +79,27 @@ let is_good_inductive env ind =
 let check_not_per pts =
   if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then
     match get_stack pts with
-	Per (_,_,_,_)::_ -> 
+	Per (_,_,_,_)::_ ->
 	  error "You are inside a proof per cases/induction.\n\
 Please \"suppose\" something or \"end\" it now."
       | _ -> ()
 
 let mk_evd metalist gls =
   let evd0= create_goal_evar_defs (sig_sig gls) in
-  let add_one (meta,typ) evd = 
+  let add_one (meta,typ) evd =
     meta_declare meta typ evd in
     List.fold_right add_one metalist evd0
 
-let is_tmp id = (string_of_id id).[0] = '_'    
+let is_tmp id = (string_of_id id).[0] = '_'
 
-let tmp_ids gls = 
+let tmp_ids gls =
   let ctx = pf_hyps gls in
-    match ctx with 
+    match ctx with
 	[] -> []
-      | _::q -> List.filter is_tmp (ids_of_named_context q) 
+      | _::q -> List.filter is_tmp (ids_of_named_context q)
 
-let clean_tmp gls = 
-  let clean_id id0 gls0 = 
+let clean_tmp gls =
+  let clean_id id0 gls0 =
       tclTRY (clear [id0]) gls0 in
   let rec clean_all = function
       [] -> tclIDTAC
@@ -114,30 +115,30 @@ let assert_postpone id t =
 let start_proof_tac gls=
   let gl=sig_it gls in
   let info={pm_stack=[]} in
-    {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, 
-  function 
+    {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls},
+  function
       [pftree] ->
 	{pftree with
 	   goal=gl;
-	   ref=Some (Decl_proof true,[pftree])} 
+	   ref=Some (Decl_proof true,[pftree])}
     | _ -> anomaly "Dem : Wrong number of subtrees"
 
-let go_to_proof_mode () = 
-  Pfedit.mutate 
+let go_to_proof_mode () =
+  Pfedit.mutate
     (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts))
 
 (* closing gaps *)
 
 let daimon_tac gls =
   set_daimon_flag ();
-  ({it=[];sigma=sig_sig gls}, 
-   function 
+  ({it=[];sigma=sig_sig gls},
+   function
        [] ->
 	 {open_subgoals=0;
 	    goal=sig_it gls;
-	    ref=Some (Daimon,[])} 
+	    ref=Some (Daimon,[])}
      | _ -> anomaly "Daimon: Wrong number of subtrees")
-    
+
 let daimon _ pftree =
   set_daimon_flag ();
   {pftree with
@@ -150,7 +151,7 @@ let daimon_subtree = map_pftreestate (fun _ ->  frontier_mapi daimon )
 
 let rec is_focussing_instr = function
     Pthus i | Pthen i | Phence i -> is_focussing_instr i
-  | Pescape | Pper _ | Pclaim _ | Pfocus _ 
+  | Pescape | Pper _ | Pclaim _ | Pfocus _
   | Psuppose _ | Pcase (_,_,_)  -> true
   | _ -> false
 
@@ -158,7 +159,7 @@ let mark_rule_as_done = function
     Decl_proof true -> Decl_proof false
   | Decl_proof false ->
       anomaly "already marked as done"
-  | Nested(Proof_instr (lock_focus,instr),spfl) -> 
+  | Nested(Proof_instr (lock_focus,instr),spfl) ->
       if lock_focus then
 	Nested(Proof_instr (false,instr),spfl)
       else
@@ -168,34 +169,34 @@ let mark_rule_as_done = function
 let mark_proof_tree_as_done pt =
   match pt.ref with
       None -> anomaly "mark_proof_tree_as_done"
-    | Some (r,spfl) -> 
+    | Some (r,spfl) ->
 	{pt with ref= Some (mark_rule_as_done r,spfl)}
 
-let mark_as_done pts = 
-  map_pftreestate 
-    (fun _ -> mark_proof_tree_as_done) 
-    (up_to_matching_rule is_focussing_command pts) 
+let mark_as_done pts =
+  map_pftreestate
+    (fun _ -> mark_proof_tree_as_done)
+    (up_to_matching_rule is_focussing_command pts)
 
 (* post-instruction focus management *)
 
 let goto_current_focus pts = up_until_matching_rule is_focussing_command pts
 
-let goto_current_focus_or_top pts = 
-  try 
+let goto_current_focus_or_top pts =
+  try
     up_until_matching_rule is_focussing_command pts
   with Not_found -> top_of_tree pts
 
 (* return *)
 
 let close_tactic_mode pts =
-    let pts1=  
-      try goto_current_focus pts 
-      with Not_found -> 
+    let pts1=
+      try goto_current_focus pts
+      with Not_found ->
 	error "\"return\" cannot be used outside of Declarative Proof Mode." in
     let pts2 = daimon_subtree pts1 in
-    let pts3 = mark_as_done pts2 in 
-      goto_current_focus pts3 
-	  
+    let pts3 = mark_as_done pts2 in
+      goto_current_focus pts3
+
 let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode
 
 (* end proof/claim *)
@@ -207,11 +208,11 @@ let close_block bt pts =
     else
       get_stack pts in
     match bt,stack with
-	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> 
+	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] ->
 	  daimon_subtree (goto_current_focus pts)
-      | _, Claim::_ -> 
+      | _, Claim::_ ->
 	  error "\"end claim\" expected."
-      | _, Focus_claim::_ -> 
+      | _, Focus_claim::_ ->
 	  error "\"end focus\" expected."
       | _, [] ->
  	  error "\"end proof\" expected."
@@ -225,18 +226,18 @@ let close_block bt pts =
 
 (* utility for suppose / suppose it is *)
 
-let close_previous_case pts = 
-  if 
-    Proof_trees.is_complete_proof (proof_of_pftreestate pts) 
+let close_previous_case pts =
+  if
+    Proof_trees.is_complete_proof (proof_of_pftreestate pts)
   then
     match get_top_stack pts with
-	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."  
-      | Suppose_case :: Per (et,_,_,_) :: _ -> 
+	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."
+      | Suppose_case :: Per (et,_,_,_) :: _ ->
 	  goto_current_focus (mark_as_done pts)
-      | _ -> error "Not inside a proof per cases or induction."   
+      | _ -> error "Not inside a proof per cases or induction."
   else
     match get_stack pts with
-	Per (et,_,_,_) :: _ -> pts 
+	Per (et,_,_,_) :: _ -> pts
       | Suppose_case :: Per (et,_,_,_) :: _ ->
 	  goto_current_focus (mark_as_done (daimon_subtree pts))
       | _ -> error "Not inside a proof per cases or induction."
@@ -246,10 +247,10 @@ let close_previous_case pts =
 (* automation *)
 
 let filter_hyps f gls =
-  let filter_aux (id,_,_) = 
-    if f id then 
+  let filter_aux (id,_,_) =
+    if f id then
       tclIDTAC
-    else 
+    else
       tclTRY (clear [id])  in
     tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls
 
@@ -257,16 +258,16 @@ let local_hyp_prefix = id_of_string "___"
 
 let add_justification_hyps keep items gls =
   let add_aux c gls=
-    match kind_of_term c with 
-	Var id -> 
+    match kind_of_term c with
+	Var id ->
 	  keep:=Idset.add id !keep;
-	  tclIDTAC gls 
-      | _ -> 
-	  let id=pf_get_new_id local_hyp_prefix gls in 
-	    keep:=Idset.add id !keep; 
+	  tclIDTAC gls
+      | _ ->
+	  let id=pf_get_new_id local_hyp_prefix gls in
+	    keep:=Idset.add id !keep;
 	    tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere)
-              (thin_body [id]) gls in 
-    tclMAP add_aux items gls   
+              (thin_body [id]) gls in
+    tclMAP add_aux items gls
 
 let prepare_goal items gls =
   let tokeep = ref Idset.empty in
@@ -275,18 +276,18 @@ let prepare_goal items gls =
      [ (fun _ -> auxres);
        filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls
 
-let my_automation_tac = ref 
+let my_automation_tac = ref
   (fun gls -> anomaly "No automation registered")
 
 let register_automation_tac tac = my_automation_tac:= tac
 
 let automation_tac gls = !my_automation_tac gls
 
-let justification tac gls= 
-    tclORELSE 
-      (tclSOLVE [tclTHEN tac assumption]) 
-      (fun gls -> 
-	 if get_strictness () then 
+let justification tac gls=
+    tclORELSE
+      (tclSOLVE [tclTHEN tac assumption])
+      (fun gls ->
+	 if get_strictness () then
 	   error "Insufficient justification."
 	 else
 	   begin
@@ -326,7 +327,7 @@ type stackd_elt =
  se_type:types;
  se_last_meta:metavariable;
  se_meta_list:(metavariable*types) list;
- se_evd: evar_defs}
+ se_evd: evar_map}
 
 let rec replace_in_list m l = function
     [] -> raise Not_found
@@ -340,44 +341,44 @@ let enstack_subsubgoals env se stack gls=
 	    Inductive.lookup_mind_specif env ind in
           let gentypes=
             Inductive.arities_of_constructors ind (mib,oib) in
-	  let process i gentyp = 
-	    let constructor = mkConstruct(ind,succ i) 
+	  let process i gentyp =
+	    let constructor = mkConstruct(ind,succ i)
 	      (* constructors numbering*) in
 	    let appterm = applist (constructor,params) in
 	    let apptype = Term.prod_applist gentyp params in
 	    let rc,_ = Reduction.dest_prod env apptype in
-	    let rec meta_aux last lenv = function 
+	    let rec meta_aux last lenv = function
 		[] -> (last,lenv,[])
 	      | (nam,_,typ)::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 (nlast,holes,nmetas) = 
+	    let (nlast,holes,nmetas) =
 		meta_aux se.se_last_meta [] (List.rev rc) in
 	    let refiner = applist (appterm,List.rev holes) in
-	    let evd = meta_assign se.se_meta 
+	    let evd = meta_assign se.se_meta
               (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in
-	    let ncreated = replace_in_list 
+	    let ncreated = replace_in_list
 	      se.se_meta nmetas se.se_meta_list in
-	    let evd0 = List.fold_left 
-	      (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in  
-	      List.iter (fun (m,typ) -> 
-			   Stack.push 
+	    let evd0 = List.fold_left
+	      (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in
+	      List.iter (fun (m,typ) ->
+			   Stack.push
 			     {se_meta=m;
 			      se_type=typ;
 			      se_evd=evd0;
 			      se_meta_list=ncreated;
-			      se_last_meta=nlast} stack) (List.rev nmetas) 
+			      se_last_meta=nlast} stack) (List.rev nmetas)
 	  in
 	    Array.iteri process gentypes
       | _ -> ()
 
-let rec nf_list evd = 
+let rec nf_list evd =
   function
-      [] -> []  
-    | (m,typ)::others -> 
-	if meta_defined evd m then 
+      [] -> []
+    | (m,typ)::others ->
+	if meta_defined evd m then
 	    nf_list evd others
 	else
 	  (m,nf_meta evd typ)::nf_list evd others
@@ -387,29 +388,29 @@ let find_subsubgoal c ctyp skip submetas gls =
   let concl = pf_concl gls in
   let evd = mk_evd ((0,concl)::submetas) gls in
   let stack = Stack.create () in
-  let max_meta = 
+  let max_meta =
       List.fold_left (fun a (m,_) -> max a m) 0 submetas in
-  let _ = Stack.push 
+  let _ = Stack.push
 		{se_meta=0;
 		 se_type=concl;
 		 se_last_meta=max_meta;
 		 se_meta_list=[0,concl];
 		 se_evd=evd} stack  in
-  let rec dfs n = 
+  let rec dfs n =
     let se = Stack.pop stack in
-      try 
-	let unifier = 
-	  Unification.w_unify true env Reduction.CUMUL 
+      try
+	let unifier =
+	  Unification.w_unify true env Reduction.CUMUL
 	    ctyp se.se_type se.se_evd in
-	  if n <= 0 then 
-	      {se with 
+	  if n <= 0 then
+	      {se with
 		 se_evd=meta_assign se.se_meta
                   (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier;
-	         se_meta_list=replace_in_list 
+	         se_meta_list=replace_in_list
 		  se.se_meta submetas se.se_meta_list}
 	  else
 	      dfs (pred n)
-      with _ -> 
+      with _ ->
 	begin
 	  enstack_subsubgoals env se stack gls;
 	  dfs n
@@ -421,20 +422,20 @@ let concl_refiner metas body gls =
   let concl = pf_concl gls in
   let evd = sig_sig gls in
   let env = pf_env gls in
-  let sort = family_of_sort (Typing.sort_of env evd concl) in  
+  let sort = family_of_sort (Typing.sort_of env evd concl) in
   let rec aux env avoid subst = function
       [] -> anomaly "concl_refiner: cannot happen"
     | (n,typ)::rest ->
-	let _A = subst_meta subst typ in 
-	let x = id_of_name_using_hdchar env _A Anonymous in 
+	let _A = subst_meta subst typ in
+	let x = id_of_name_using_hdchar env _A Anonymous in
 	let _x = fresh_id avoid x gls in
 	let nenv = Environ.push_named (_x,None,_A) env in
 	let asort = family_of_sort (Typing.sort_of nenv evd _A) in
 	let nsubst = (n,mkVar _x)::subst in
-	  if rest = [] then 
+	  if rest = [] then
 	    asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
 	  else
-	    let bsort,_B,nbody = 
+	    let bsort,_B,nbody =
 	      aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in
 	    let body = mkNamedLambda _x _A nbody in
 	      if occur_term (mkVar _x) _B then
@@ -450,7 +451,7 @@ let concl_refiner metas body gls =
 			let _P0 = mkLambda(Anonymous,_AxB,concl) in
 			  InType,_AxB,
 			mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|])
-		    | _,_ -> 
+		    | _,_ ->
 			let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in
 			let _P0 = mkLambda(Anonymous,_AxB,concl) in
 			  InType,_AxB,
@@ -473,26 +474,23 @@ let concl_refiner metas body gls =
   let (_,_,prf) = aux env [] [] metas in
     mkApp(prf,[|mkMeta 1|])
 
-let thus_tac c ctyp submetas gls =  
-  let list,proof = 
+let thus_tac c ctyp submetas gls =
+  let list,proof =
     try
       find_subsubgoal c ctyp 0 submetas gls
-    with Not_found -> 
+    with Not_found ->
       error "I could not relate this statement to the thesis." in
   if list = [] then
-    exact_check proof gls 
+    exact_check proof gls
   else
     let refiner = concl_refiner list proof gls in
       Tactics.refine refiner gls
 
 (* general forward step *)
 
-
-let anon_id_base = id_of_string "__" 
-
-let mk_stat_or_thesis info gls = function  
+let mk_stat_or_thesis info gls = function
     This c -> c
-  | Thesis (For _ ) -> 
+  | Thesis (For _ ) ->
       error "\"thesis for ...\" is not applicable here."
   | Thesis Plain -> pf_concl gls
 
@@ -500,34 +498,34 @@ let just_tac _then cut info gls0 =
   let items_tac gls =
     match cut.cut_by with
 	None -> tclIDTAC gls
-      | Some items -> 
-	  let items_ = 
-	    if _then then 
+      | Some items ->
+	  let items_ =
+	    if _then then
 	      let last_id = get_last (pf_env gls) in
 		(mkVar last_id)::items
-	    else items 
+	    else items
 	  in prepare_goal items_ gls in
-  let method_tac gls = 
+  let method_tac gls =
     match cut.cut_using with
-        None ->	
+        None ->
 	  automation_tac gls
-      | Some tac -> 
+      | Some tac ->
 	  (Tacinterp.eval_tactic tac) gls in
     justification (tclTHEN items_tac method_tac) gls0
-			
-let instr_cut mkstat _thus _then cut gls0 = 
-  let info = get_its_info gls0 in 
+
+let instr_cut mkstat _thus _then cut gls0 =
+  let info = get_its_info gls0 in
   let stat = cut.cut_stat in
-  let (c_id,_) = match stat.st_label with 
-      Anonymous -> 
-	pf_get_new_id (id_of_string "_fact") gls0,false 
+  let (c_id,_) = match stat.st_label with
+      Anonymous ->
+	pf_get_new_id (id_of_string "_fact") gls0,false
     | Name id -> id,true in
   let c_stat = mkstat info gls0 stat.st_it in
-  let thus_tac gls= 
-    if _thus then 
+  let thus_tac gls=
+    if _thus then
       thus_tac (mkVar c_id) c_stat [] gls
     else tclIDTAC gls in
-    tclTHENS (assert_postpone c_id c_stat) 
+    tclTHENS (assert_postpone c_id c_stat)
       [tclTHEN tcl_erase_info (just_tac _then cut info);
        thus_tac] gls0
 
@@ -541,162 +539,162 @@ let decompose_eq id gls =
   let whd =  (special_whd gls typ) in
     match kind_of_term whd with
 	App (f,args)->
-	  if eq_constr f _eq && (Array.length args)=3 
+	  if eq_constr f _eq && (Array.length args)=3
 	  then (args.(0),
-		args.(1), 
-		args.(2)) 
+		args.(1),
+		args.(2))
 	  else error "Previous step is not an equality."
       | _ -> error "Previous step is not an equality."
-	  
-let instr_rew _thus rew_side cut gls0 = 
-  let last_id = 
+
+let instr_rew _thus rew_side cut gls0 =
+  let last_id =
     try get_last (pf_env gls0) with _ -> error "No previous equality." in
-  let typ,lhs,rhs = decompose_eq last_id gls0 in  
+  let typ,lhs,rhs = decompose_eq last_id gls0 in
   let items_tac gls =
     match cut.cut_by with
 	None -> tclIDTAC gls
       | Some items -> prepare_goal items gls in
-  let method_tac gls = 
+  let method_tac gls =
     match cut.cut_using with
-        None ->	
+        None ->
 	  automation_tac gls
-      | Some tac -> 
+      | Some tac ->
 	  (Tacinterp.eval_tactic tac) gls in
   let just_tac gls =
     justification (tclTHEN items_tac method_tac) gls in
-  let (c_id,_) = match cut.cut_stat.st_label with 
-      Anonymous -> 
-	pf_get_new_id (id_of_string "_eq") gls0,false 
+  let (c_id,_) = match cut.cut_stat.st_label with
+      Anonymous ->
+	pf_get_new_id (id_of_string "_eq") gls0,false
     | Name id -> id,true in
-  let thus_tac new_eq gls= 
-    if _thus then 
+  let thus_tac new_eq gls=
+    if _thus then
       thus_tac (mkVar c_id) new_eq [] gls
     else tclIDTAC gls in
-    match rew_side with 
+    match rew_side with
 	Lhs ->
 	  let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in
-	    tclTHENS (assert_postpone c_id new_eq) 
-	      [tclTHEN tcl_erase_info 
-		 (tclTHENS (transitivity lhs) 
+	    tclTHENS (assert_postpone c_id new_eq)
+	      [tclTHEN tcl_erase_info
+		 (tclTHENS (transitivity lhs)
 		    [just_tac;exact_check (mkVar last_id)]);
 	       thus_tac new_eq] gls0
       | Rhs ->
 	  let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
-	    tclTHENS (assert_postpone c_id new_eq) 
-	      [tclTHEN tcl_erase_info 
-		 (tclTHENS (transitivity rhs) 
+	    tclTHENS (assert_postpone c_id new_eq)
+	      [tclTHEN tcl_erase_info
+		 (tclTHENS (transitivity rhs)
 		    [exact_check (mkVar last_id);just_tac]);
 	       thus_tac new_eq] gls0
-	      
+
 
 
 (* tactics for claim/focus *)
 
-let instr_claim _thus st gls0 = 
-  let info = get_its_info gls0 in  
-  let (id,_) = match st.st_label with 
-      Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false 
+let instr_claim _thus st gls0 =
+  let info = get_its_info gls0 in
+  let (id,_) = match st.st_label with
+      Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false
     | Name id -> id,true in
-  let thus_tac gls= 
-    if _thus then 
+  let thus_tac gls=
+    if _thus then
       thus_tac (mkVar id) st.st_it [] gls
     else tclIDTAC gls in
   let ninfo1 = {pm_stack=
       (if _thus then Focus_claim else Claim)::info.pm_stack} in
-    tclTHENS (assert_postpone id st.st_it) 
+    tclTHENS (assert_postpone id st.st_it)
       [tcl_change_info ninfo1;
        thus_tac] gls0
 
 (* tactics for assume *)
 
-let push_intro_tac coerce nam gls = 
+let push_intro_tac coerce nam gls =
       let (hid,_) =
-	match nam with 
-	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false 
+	match nam with
+	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false
 	  | Name id -> id,true in
-	tclTHENLIST 
+	tclTHENLIST
 	  [intro_mustbe_force hid;
 	   coerce hid]
-	  gls 
-
-let assume_tac hyps gls = 
-  List.fold_right 
-    (fun (Hvar st | Hprop st) -> 
-       tclTHEN 
-	 (push_intro_tac 
-	    (fun id -> 
+	  gls
+
+let assume_tac hyps gls =
+  List.fold_right
+    (fun (Hvar st | Hprop st) ->
+       tclTHEN
+	 (push_intro_tac
+	    (fun id ->
 	       convert_hyp (id,None,st.st_it)) st.st_label))
-	 hyps tclIDTAC gls 
-
-let assume_hyps_or_theses hyps gls = 
-  List.fold_right 
-    (function 
-	 (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> 
-	   tclTHEN 
-	     (push_intro_tac 
-		(fun id -> 
+	 hyps tclIDTAC gls
+
+let assume_hyps_or_theses hyps gls =
+  List.fold_right
+    (function
+	 (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) ->
+	   tclTHEN
+	     (push_intro_tac
+		(fun id ->
 		   convert_hyp (id,None,c)) nam)
-       | Hprop {st_label=nam;st_it=Thesis (tk)} -> 
-	   tclTHEN 
-	     (push_intro_tac 
+       | Hprop {st_label=nam;st_it=Thesis (tk)} ->
+	   tclTHEN
+	     (push_intro_tac
 		(fun id -> tclIDTAC) nam))
-    hyps tclIDTAC gls 
+    hyps tclIDTAC gls
 
-let assume_st hyps gls = 
-  List.fold_right 
-    (fun st -> 
-       tclTHEN 
-	 (push_intro_tac 
+let assume_st hyps gls =
+  List.fold_right
+    (fun st ->
+       tclTHEN
+	 (push_intro_tac
 	    (fun id -> convert_hyp (id,None,st.st_it)) st.st_label))
-	 hyps tclIDTAC gls 
-
-let assume_st_letin hyps gls = 
-  List.fold_right 
-    (fun st -> 
-       tclTHEN 
-	 (push_intro_tac 
-	    (fun id -> 
+	 hyps tclIDTAC gls
+
+let assume_st_letin hyps gls =
+  List.fold_right
+    (fun st ->
+       tclTHEN
+	 (push_intro_tac
+	    (fun id ->
 	       convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label))
-	 hyps tclIDTAC gls 
+	 hyps tclIDTAC gls
 
 (* suffices *)
 
-let rec metas_from n hyps = 
+let rec metas_from n hyps =
   match hyps with
       _ :: q -> n :: metas_from (succ n) q
     | [] -> []
- 
+
 let rec build_product args body =
-  match args with 
-      (Hprop st| Hvar st )::rest -> 
+  match args with
+      (Hprop st| Hvar st )::rest ->
 	let pprod= lift 1 (build_product rest body) in
 	let lbody =
 	  match st.st_label with
 	      Anonymous -> pprod
 	    | Name id -> subst_term (mkVar id) pprod in
 	  mkProd (st.st_label, st.st_it, lbody)
-    | [] -> body 
+    | [] -> body
 
 let rec build_applist prod = function
     [] -> [],prod
-  | n::q -> 
+  | n::q ->
       let (_,typ,_) = destProd prod in
       let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in
 	(n,typ)::ctx,head
 
-let instr_suffices _then cut gls0 = 
-  let info = get_its_info gls0 in 
-  let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in 
+let instr_suffices _then cut gls0 =
+  let info = get_its_info gls0 in
+  let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in
   let ctx,hd = cut.cut_stat in
   let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in
   let metas = metas_from 1 ctx in
   let c_ctx,c_head = build_applist c_stat metas in
-  let c_term = applist (mkVar c_id,List.map mkMeta metas) in  
-  let thus_tac gls= 
+  let c_term = applist (mkVar c_id,List.map mkMeta metas) in
+  let thus_tac gls=
     thus_tac c_term c_head c_ctx gls in
-   tclTHENS (assert_postpone c_id c_stat) 
-     [tclTHENLIST 
-	 [ assume_tac ctx;   
+   tclTHENS (assert_postpone c_id c_stat)
+     [tclTHENLIST
+	 [ assume_tac ctx;
 	   tcl_erase_info;
 	   just_tac _then cut info];
       thus_tac] gls0
@@ -706,7 +704,7 @@ let instr_suffices _then cut gls0 =
 let conjunction_arity id gls =
   let typ = pf_get_hyp_typ gls id  in
   let hd,params = decompose_app (special_whd gls typ) in
-  let env =pf_env gls in 
+  let env =pf_env gls in
     match kind_of_term hd with
 	Ind ind when is_good_inductive env ind ->
 	  let mib,oib=
@@ -719,70 +717,70 @@ let conjunction_arity id gls =
 	    List.length rc
       | _ -> raise Not_found
 
-let rec intron_then n ids ltac gls = 
-  if n<=0 then 
+let rec intron_then n ids ltac gls =
+  if n<=0 then
     ltac ids gls
-  else  
-    let id = pf_get_new_id (id_of_string "_tmp") gls in 
-      tclTHEN 
-	(intro_mustbe_force id) 
-	(intron_then (pred n) (id::ids) ltac) gls 
+  else
+    let id = pf_get_new_id (id_of_string "_tmp") gls in
+      tclTHEN
+	(intro_mustbe_force id)
+	(intron_then (pred n) (id::ids) ltac) gls
 
 
 let rec consider_match may_intro introduced available expected gls =
-  match available,expected with 
+  match available,expected with
       [],[] ->
 	  tclIDTAC gls
     | _,[] -> error "Last statements do not match a complete hypothesis."
 	(* should tell which ones *)
-    | [],hyps -> 
+    | [],hyps ->
 	if may_intro then
 	  begin
  	    let id = pf_get_new_id (id_of_string "_tmp") gls in
-	      tclIFTHENELSE 
+	      tclIFTHENELSE
 		(intro_mustbe_force id)
-		(consider_match true [] [id] hyps) 
-		(fun _ -> 
+		(consider_match true [] [id] hyps)
+		(fun _ ->
 		   error "Not enough sub-hypotheses to match statements.")
-		gls 
-          end 
+		gls
+          end
 	else
 	  error "Not enough sub-hypotheses to match statements."
 	    (* should tell which ones *)
     | id::rest_ids,(Hvar st | Hprop st)::rest ->
 	tclIFTHENELSE (convert_hyp (id,None,st.st_it))
 	  begin
-	    match st.st_label with 
-		Anonymous -> 
+	    match st.st_label with
+		Anonymous ->
 		  consider_match may_intro ((id,false)::introduced) rest_ids rest
-	      | Name hid -> 
-		  tclTHENLIST 
+	      | Name hid ->
+		  tclTHENLIST
 		    [rename_hyp [id,hid];
 		     consider_match may_intro ((hid,true)::introduced) rest_ids rest]
 	  end
 	  begin
-	    (fun gls -> 
+	    (fun gls ->
 	       let nhyps =
-		 try conjunction_arity id gls with 
-		     Not_found -> error "Matching hypothesis not found." in 
-		 tclTHENLIST 
+		 try conjunction_arity id gls with
+		     Not_found -> error "Matching hypothesis not found." in
+		 tclTHENLIST
 		   [general_case_analysis false (mkVar id,NoBindings);
 		    intron_then nhyps []
-		      (fun l -> consider_match may_intro introduced 
+		      (fun l -> consider_match may_intro introduced
 			 (List.rev_append l rest_ids) expected)] gls)
 	  end
 	  gls
-	  
+
 let consider_tac c hyps gls =
   match kind_of_term (strip_outer_cast c) with
       Var id ->
-	consider_match false [] [id] hyps gls 
-    | _ -> 
+	consider_match false [] [id] hyps gls
+    | _ ->
 	let id = pf_get_new_id (id_of_string "_tmp") gls in
-	tclTHEN 
+	tclTHEN
 	  (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c)
- 	  (consider_match false [] [id] hyps) gls 
-	  
+ 	  (consider_match false [] [id] hyps) gls
+
 
 let given_tac hyps gls =
   consider_match true [] [] hyps gls
@@ -792,22 +790,22 @@ let given_tac hyps gls =
 let rec take_tac wits gls =
   match wits with
       [] -> tclIDTAC gls
-    | wit::rest ->  
-	let typ = pf_type_of gls wit in  
+    | wit::rest ->
+	let typ = pf_type_of gls wit in
 	  tclTHEN (thus_tac wit typ []) (take_tac rest)  gls
 
 
 (* tactics for define *)
 
 let rec build_function args body =
-  match args with 
-      st::rest -> 
+  match args with
+      st::rest ->
 	let pfun= lift 1 (build_function rest body) in
 	let id = match st.st_label with
 	    Anonymous -> assert false
 	  | Name id -> id in
 	  mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun)
-    | [] -> body 
+    | [] -> body
 
 let define_tac id args body gls =
   let t = build_function args body in
@@ -815,43 +813,37 @@ let define_tac id args body gls =
 
 (* tactics for reconsider *)
 
-let cast_tac id_or_thesis typ gls = 
+let cast_tac id_or_thesis typ gls =
   match id_or_thesis with
       This id ->
 	let (_,body,_) = pf_get_hyp gls id in
 	  convert_hyp (id,body,typ) gls
-    | Thesis (For _ ) -> 
+    | Thesis (For _ ) ->
 	error "\"thesis for ...\" is not applicable here."
-    | Thesis Plain ->    
+    | Thesis Plain ->
           convert_concl typ DEFAULTcast gls
-      
+
 (* per cases *)
 
 let is_rec_pos (main_ind,wft) =
   match main_ind with
       None -> false
-    | Some index -> 
+    | Some index ->
 	match fst (Rtree.dest_node wft) with
 	    Mrec i when i = index -> true
 	  | _ -> false
 
 let rec constr_trees (main_ind,wft) ind =
     match Rtree.dest_node wft with
-      Norec,_ -> 
-	let itree = 
-	  (snd (Global.lookup_inductive ind)).mind_recargs in 
+      Norec,_ ->
+	let itree =
+	  (snd (Global.lookup_inductive ind)).mind_recargs in
 	  constr_trees (None,itree) ind
     | _,constrs -> main_ind,constrs
 
-let constr_args rp constr =
-  let main_ind,constrs = constr_trees rp (fst constr) in
-  let ctree = constrs.(pred (snd constr)) in
-    array_map_to_list (fun t -> main_ind,t) 
-      (snd (Rtree.dest_node ctree))
-
 let ind_args rp ind =
     let main_ind,constrs = constr_trees rp ind in
-    let args ctree =     
+    let args ctree =
       Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in
       Array.map args constrs
 
@@ -862,7 +854,7 @@ let init_tree ids ind rp nexti =
 
 let map_tree_rp rp id_fun mapi = function
     Split_patt (ids,ind,branches) ->
-  let indargs = ind_args rp ind in 
+  let indargs = ind_args rp ind in
   let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in
     Split_patt (id_fun ids,ind,Array.mapi do_i branches)
   | _ -> failwith "map_tree_rp: not a splitting node"
@@ -874,19 +866,19 @@ let map_tree id_fun mapi = function
   | _ -> failwith "map_tree: not a splitting node"
 
 
-let start_tree env ind rp = 
+let start_tree env ind rp =
   init_tree Idset.empty ind rp (fun _ _ -> None)
 
-let build_per_info etype casee gls = 
+let build_per_info etype casee gls =
   let concl=pf_concl gls in
   let env=pf_env gls in
   let ctyp=pf_type_of gls casee in
-  let is_dep = dependent casee concl in 
+  let is_dep = dependent casee concl in
   let hd,args = decompose_app (special_whd gls ctyp) in
-  let ind = 
+  let ind =
     try
-      destInd hd 
-    with _ -> 
+      destInd hd
+    with _ ->
       error "Case analysis must be done on an inductive object." in
   let mind,oind = Global.lookup_inductive ind in
   let nparams,index =
@@ -894,10 +886,10 @@ let build_per_info etype casee gls =
 	ET_Induction -> mind.mind_nparams_rec,Some (snd ind)
       | _ -> mind.mind_nparams,None in
   let params,real_args = list_chop nparams args in
-  let abstract_obj c body = 
-    let typ=pf_type_of gls c in 
+  let abstract_obj c body =
+    let typ=pf_type_of gls c in
       lambda_create env (typ,subst_term c body) in
-  let pred= List.fold_right abstract_obj    
+  let pred= List.fold_right abstract_obj
     real_args (lambda_create env (ctyp,subst_term casee concl)) in
     is_dep,
   {per_casee=casee;
@@ -906,7 +898,7 @@ let build_per_info etype casee gls =
    per_pred=pred;
    per_args=real_args;
    per_params=params;
-   per_nparams=nparams;   
+   per_nparams=nparams;
    per_wf=index,oind.mind_recargs}
 
 let per_tac etype casee gls=
@@ -915,25 +907,25 @@ let per_tac etype casee gls=
     match casee with
 	Real c ->
 	  let is_dep,per_info = build_per_info etype c gls in
-	  let ek = 
+	  let ek =
 	    if is_dep then
 	      EK_dep (start_tree env per_info.per_ind per_info.per_wf)
 	    else EK_unknown in
-	    tcl_change_info 
+	    tcl_change_info
 	      {pm_stack=
 		  Per(etype,per_info,ek,[])::info.pm_stack} gls
       | Virtual cut ->
 	  assert (cut.cut_stat.st_label=Anonymous);
 	  let id = pf_get_new_id (id_of_string "anonymous_matched") gls in
 	  let c = mkVar id in
-	  let modified_cut = 
+	  let modified_cut =
 	    {cut with cut_stat={cut.cut_stat with st_label=Name id}} in
-	    tclTHEN 
+	    tclTHEN
 	      (instr_cut (fun _ _ c -> c) false false modified_cut)
 	      (fun gls0 ->
 		 let is_dep,per_info = build_per_info etype c gls0 in
 		   assert (not is_dep);
-		   tcl_change_info 
+		   tcl_change_info
 		     {pm_stack=
 			 Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0)
 	      gls
@@ -950,7 +942,7 @@ let register_nodep_subcase id= function
       end
   | _ -> anomaly "wrong stack state"
 
-let suppose_tac hyps gls0 = 
+let suppose_tac hyps gls0 =
   let info = get_its_info gls0 in
   let thesis = pf_concl gls0 in
   let id = pf_get_new_id (id_of_string "subcase_") gls0 in
@@ -958,13 +950,13 @@ let suppose_tac hyps gls0 =
   let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let old_clauses,stack = register_nodep_subcase id info.pm_stack in
   let ninfo2 = {pm_stack=stack} in
-    tclTHENS (assert_postpone id clause) 
+    tclTHENS (assert_postpone id clause)
       [tclTHENLIST [tcl_change_info ninfo1;
 		    assume_tac hyps;
 		    clear old_clauses];
        tcl_change_info ninfo2] gls0
 
-(* suppose it is ... *) 
+(* suppose it is ... *)
 
 (* pattern matching compiling *)
 
@@ -975,20 +967,20 @@ let rec skip_args rest ids n =
     Skip_patt (ids,skip_args rest ids (pred n))
 
 let rec tree_of_pats ((id,_) as cpl) pats =
-  match pats with 
+  match pats with
       [] -> End_patt cpl
     | args::stack ->
 	match args with
 	    [] -> Close_patt (tree_of_pats cpl stack)
 	  | (patt,rp) :: rest_args ->
 	      match patt with
-		  PatVar (_,v) -> 
+		  PatVar (_,v) ->
 		    Skip_patt (Idset.singleton id,
 			       tree_of_pats cpl (rest_args::stack))
 		| PatCstr (_,(ind,cnum),args,nam) ->
 		    let nexti i ati =
-		      if i = pred cnum then 
-			let nargs = 
+		      if i = pred cnum then
+			let nargs =
 			  list_map_i (fun j a -> (a,ati.(j))) 0 args in
 			  Some (Idset.singleton id,
 				tree_of_pats cpl (nargs::rest_args::stack))
@@ -996,49 +988,49 @@ let rec tree_of_pats ((id,_) as cpl) pats =
 		      in init_tree Idset.empty ind rp nexti
 
 let rec add_branch ((id,_) as cpl) pats tree=
-  match pats with 
-      [] -> 
+  match pats with
+      [] ->
 	begin
 	  match tree with
-	      End_patt cpl0 -> End_patt cpl0 
-		(* this ensures precedence for overlapping patterns *) 
+	      End_patt cpl0 -> End_patt cpl0
+		(* this ensures precedence for overlapping patterns *)
 	    | _ -> anomaly "tree is expected to end here"
 	end
     | args::stack ->
-	match args with 
+	match args with
 	    [] ->
 	      begin
 		match tree with
-		   Close_patt t -> 
+		   Close_patt t ->
 		     Close_patt (add_branch cpl stack t)
-		  | _ -> anomaly "we should pop here" 
+		  | _ -> anomaly "we should pop here"
 	      end
 	  | (patt,rp) :: rest_args ->
 	      match patt with
 		  PatVar (_,v) ->
 		    begin
-		      match tree with 
-			  Skip_patt (ids,t) -> 
+		      match tree with
+			  Skip_patt (ids,t) ->
 			    Skip_patt (Idset.add id ids,
 				       add_branch cpl (rest_args::stack) t)
 			| Split_patt (_,_,_) ->
 			    map_tree (Idset.add id)
-			      (fun i bri ->  
-				 append_branch cpl 1 (rest_args::stack) bri) 
+			      (fun i bri ->
+				 append_branch cpl 1 (rest_args::stack) bri)
 			      tree
-			| _ -> anomaly "No pop/stop expected here"  
+			| _ -> anomaly "No pop/stop expected here"
 		    end
 		| PatCstr (_,(ind,cnum),args,nam) ->
 		      match tree with
 			Skip_patt (ids,t) ->
 			  let nexti i ati =
-			    if i = pred cnum then 
-			      let nargs = 
+			    if i = pred cnum then
+			      let nargs =
 				list_map_i (fun j a -> (a,ati.(j))) 0 args in
 				Some (Idset.add id ids,
 				      add_branch cpl (nargs::rest_args::stack)
 					(skip_args t ids (Array.length ati)))
-			    else 
+			    else
 			      Some (ids,
 				    skip_args t ids (Array.length ati))
 			  in init_tree ids ind rp nexti
@@ -1047,30 +1039,30 @@ let rec add_branch ((id,_) as cpl) pats tree=
 			    (* this can happen with coercions *)
 	                    "Case pattern belongs to wrong inductive type.";
 			  let mapi i ati bri =
-			    if i = pred cnum then 
-			      let nargs = 
+			    if i = pred cnum then
+			      let nargs =
 				list_map_i (fun j a -> (a,ati.(j))) 0 args in
-				append_branch cpl 0 
+				append_branch cpl 0
 				  (nargs::rest_args::stack) bri
 			    else bri in
 			    map_tree_rp rp (fun ids -> ids) mapi tree
 		      | _ -> anomaly "No pop/stop expected here"
 and append_branch ((id,_) as cpl) depth pats = function
-    Some (ids,tree) -> 
+    Some (ids,tree) ->
       Some (Idset.add id ids,append_tree cpl depth pats tree)
   | None ->
       Some (Idset.singleton id,tree_of_pats cpl pats)
 and append_tree ((id,_) as cpl) depth pats tree =
   if depth<=0 then add_branch cpl pats tree
   else match tree with
-      Close_patt t -> 
+      Close_patt t ->
 	Close_patt (append_tree cpl (pred depth) pats t)
-    | Skip_patt (ids,t) -> 
+    | Skip_patt (ids,t) ->
 	Skip_patt (Idset.add id ids,append_tree cpl depth pats t)
     | End_patt _ -> anomaly "Premature end of branch"
-    | Split_patt (_,_,_) -> 
-	map_tree (Idset.add id) 
-	  (fun i bri -> append_branch cpl (succ depth) pats bri) tree 
+    | Split_patt (_,_,_) ->
+	map_tree (Idset.add id)
+	  (fun i bri -> append_branch cpl (succ depth) pats bri) tree
 
 (* suppose it is *)
 
@@ -1084,22 +1076,22 @@ let thesis_for obj typ per_info env=
   let cind,all_args=decompose_app typ in
   let ind = destInd cind in
   let _ = if ind <> per_info.per_ind then
-    errorlabstrm "thesis_for" 
-      ((Printer.pr_constr_env env obj) ++ spc () ++ 
-	 str"cannot give an induction hypothesis (wrong inductive type).") in  
+    errorlabstrm "thesis_for"
+      ((Printer.pr_constr_env env obj) ++ spc () ++
+	 str"cannot give an induction hypothesis (wrong inductive type).") in
   let params,args = list_chop per_info.per_nparams all_args in
   let _ = if not (List.for_all2 eq_constr params per_info.per_params) then
-    errorlabstrm "thesis_for" 
-      ((Printer.pr_constr_env env obj) ++ spc () ++ 
+    errorlabstrm "thesis_for"
+      ((Printer.pr_constr_env env obj) ++ spc () ++
 	 str "cannot give an induction hypothesis (wrong parameters).") in
   let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in
     compose_prod rc (whd_beta Evd.empty hd2)
 
 let rec build_product_dep pat_info per_info args body gls =
-  match args with 
-      (Hprop {st_label=nam;st_it=This c} 
-      | Hvar {st_label=nam;st_it=c})::rest -> 
-	let pprod= 
+  match args with
+      (Hprop {st_label=nam;st_it=This c}
+      | Hvar {st_label=nam;st_it=c})::rest ->
+	let pprod=
 	  lift 1 (build_product_dep pat_info per_info rest body gls) in
 	let lbody =
 	  match nam with
@@ -1107,7 +1099,7 @@ let rec build_product_dep pat_info per_info args body gls =
 	    | Name id -> subst_var id pprod in
 	  mkProd (nam,c,lbody)
     | Hprop ({st_it=Thesis tk} as st)::rest ->
-	let pprod= 
+	let pprod=
 	  lift 1 (build_product_dep pat_info per_info rest body gls) in
 	let lbody =
 	  match st.st_label with
@@ -1117,14 +1109,14 @@ let rec build_product_dep pat_info per_info args body gls =
 	  match tk with
 	      For id ->
 		let obj = mkVar id in
-		let typ = 
-		  try st_assoc (Name id) pat_info.pat_vars 
-		  with Not_found -> 
+		let typ =
+		  try st_assoc (Name id) pat_info.pat_vars
+		  with Not_found ->
 		    snd (st_assoc (Name id) pat_info.pat_aliases) in
 		  thesis_for obj typ per_info (pf_env gls)
 	    | Plain -> pf_concl gls in
 	  mkProd (st.st_label,ptyp,lbody)
-    | [] -> body 
+    | [] -> body
 
 let build_dep_clause params pat_info per_info hyps gls =
   let concl=
@@ -1138,35 +1130,35 @@ let build_dep_clause params pat_info per_info hyps gls =
   let let_one_in st body =
     match st.st_label with
 	Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body)
-      | Name id -> 
+      | Name id ->
 	  mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in
-  let aliased_clause = 
+  let aliased_clause =
     List.fold_right let_one_in pat_info.pat_aliases open_clause in
     List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause
 
 let rec register_dep_subcase id env per_info pat = function
     EK_nodep -> error  "Only \"suppose it is\" can be used here."
-  | EK_unknown -> 
+  | EK_unknown ->
       register_dep_subcase id env per_info pat
 	(EK_dep (start_tree env per_info.per_ind per_info.per_wf))
   | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree)
-  
+
 let case_tac params pat_info hyps gls0 =
   let info = get_its_info gls0 in
   let id = pf_get_new_id (id_of_string "subcase_") gls0 in
   let et,per_info,ek,old_clauses,rest =
     match info.pm_stack with
-	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) 
+	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest)
       | _ -> anomaly "wrong place for cases" in
   let clause = build_dep_clause params pat_info per_info hyps gls0 in
   let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let nek = 
-    register_dep_subcase (id,(List.length params,List.length hyps)) (pf_env gls0) per_info 
-      pat_info.pat_pat ek in  
+    register_dep_subcase (id,(List.length params,List.length hyps)) 
+      (pf_env gls0) per_info pat_info.pat_pat ek in  
   let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
-    tclTHENS (assert_postpone id clause) 
-      [tclTHENLIST 
-	 [tcl_change_info ninfo1; 
+    tclTHENS (assert_postpone id clause)
+      [tclTHENLIST
+	 [tcl_change_info ninfo1;
 	  assume_st (params@pat_info.pat_vars);
 	  assume_st_letin pat_info.pat_aliases;
 	  assume_hyps_or_theses hyps;
@@ -1181,23 +1173,23 @@ type instance_stack =
 let initial_instance_stack ids =
   List.map (fun id -> id,[None,[]]) ids
 
-let push_one_arg arg = function 
+let push_one_arg arg = function
     [] -> anomaly "impossible"
-  | (head,args) :: ctx -> 
+  | (head,args) :: ctx ->
       ((head,(arg::args)) :: ctx)
 
 let push_arg arg stacks =
   List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks
-  
 
-let push_one_head c ids (id,stack) = 
+
+let push_one_head c ids (id,stack) =
   let head = if Idset.mem id ids then Some c else None in
     id,(head,[]) :: stack
 
 let push_head c ids stacks =
   List.map (push_one_head c ids) stacks
 
-let pop_one (id,stack) =  
+let pop_one (id,stack) =
   let nstack=
     match stack with
 	[] -> anomaly "impossible"
@@ -1212,28 +1204,26 @@ let pop_one (id,stack) =
 let pop_stacks stacks =
   List.map pop_one stacks
 
-let patvar_base = id_of_string "__"
-
 let hrec_for fix_id per_info gls obj_id =
   let obj=mkVar obj_id in
   let typ=pf_get_hyp_typ gls obj_id in
   let rc,hd1=decompose_prod typ in
   let cind,all_args=decompose_app typ in
   let ind = destInd cind in assert (ind=per_info.per_ind);
-  let params,args= list_chop per_info.per_nparams all_args in 
+  let params,args= list_chop per_info.per_nparams all_args in
   assert begin
-    try List.for_all2 eq_constr params per_info.per_params with 
+    try List.for_all2 eq_constr params per_info.per_params with
         Invalid_argument _ -> false end;
-  let hd2 = applist (mkVar fix_id,args@[obj]) in 
+  let hd2 = applist (mkVar fix_id,args@[obj]) in
     compose_lam rc (whd_beta gls.sigma hd2)
 
 
 let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
   match tree, objs  with
-      Close_patt t,_ ->  
-	let args0 = pop_stacks args in	
+      Close_patt t,_ ->
+	let args0 = pop_stacks args in
 	  execute_cases fix_name per_info tacnext args0 objs nhrec t gls
-    | Skip_patt (_,t),skipped::next_objs -> 
+    | Skip_patt (_,t),skipped::next_objs ->
 	let args0 = push_arg skipped args in
 	  execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls
     | End_patt (id,(nparams,nhyps)),[] -> 
@@ -1260,66 +1250,66 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	let hd,all_args = decompose_app (special_whd gls ctyp) in
 	let _ = assert (destInd hd = ind) in (* just in case *)
 	let params,real_args = list_chop nparams all_args in
-	let abstract_obj c body = 
-	  let typ=pf_type_of gls c in 
+	let abstract_obj c body =
+	  let typ=pf_type_of gls c in
 	    lambda_create env (typ,subst_term c body) in
-	let elim_pred = List.fold_right abstract_obj    
+	let elim_pred = List.fold_right abstract_obj
 	  real_args (lambda_create env (ctyp,subst_term casee concl)) in
 	let case_info = Inductiveops.make_case_info env ind RegularStyle in
 	let gen_arities = Inductive.arities_of_constructors ind spec in
-	let f_ids typ = 
-	  let sign = 
-	    fst (Sign.decompose_prod_assum (Term.prod_applist typ params)) in
+	let f_ids typ =
+	  let sign =
+	    (prod_assum (Term.prod_applist typ params)) in
 	    find_intro_names sign gls in
 	let constr_args_ids = Array.map f_ids gen_arities in
-	let case_term =	 
+	let case_term =
 	  mkCase(case_info,elim_pred,casee,
 		 Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in
 	let branch_tac i (recargs,bro) gls0 =
 	  let args_ids = constr_args_ids.(i) in
 	  let rec aux n = function
-	      [] -> 
-		assert (n=Array.length recargs); 
+	      [] ->
+		assert (n=Array.length recargs);
 		next_objs,[],nhrec
-	    | id :: q -> 
+	    | id :: q ->
 		let objs,recs,nrec = aux (succ n) q in
-		  if recargs.(n) 
-		  then (mkVar id::objs),(id::recs),succ nrec 
+		  if recargs.(n)
+		  then (mkVar id::objs),(id::recs),succ nrec
 		  else (mkVar id::objs),recs,nrec in
 	  let objs,recs,nhrec = aux 0 args_ids in
 	    tclTHENLIST
 	      [tclMAP intro_mustbe_force args_ids;
 	       begin
-		 fun gls1 -> 
-		   let hrecs = 
-		     List.map 
-		       (fun id -> 
-			  hrec_for (out_name fix_name) per_info gls1 id) 
+		 fun gls1 ->
+		   let hrecs =
+		     List.map
+		       (fun id ->
+			  hrec_for (out_name fix_name) per_info gls1 id)
 		       recs in
 		     generalize hrecs gls1
 	       end;
 	       match bro with
-		   None -> 
+		   None ->
 		     msg_warning (str "missing case");
 		     tacnext (mkMeta 1)
 		 | Some (sub_ids,tree) ->
 		     let br_args =
-		       List.filter 
-			 (fun (id,_) -> Idset.mem id sub_ids) args in 
-		     let construct = 
+		       List.filter
+			 (fun (id,_) -> Idset.mem id sub_ids) args in
+		     let construct =
 		       applist (mkConstruct(ind,succ i),params) in
-		     let p_args = 
+		     let p_args =
 		       push_head construct ids br_args in
-		       execute_cases fix_name per_info tacnext 
+		       execute_cases fix_name per_info tacnext
 			 p_args objs nhrec tree] gls0 in
-	  tclTHENSV 
+	  tclTHENSV
 	    (refine case_term)
 	    (Array.mapi branch_tac br) gls
-    | Split_patt (_, _, _) , [] -> 
+    | Split_patt (_, _, _) , [] ->
 	anomaly "execute_cases : Nothing to split"
-    | Skip_patt _ , [] -> 
+    | Skip_patt _ , [] ->
 	anomaly "execute_cases : Nothing to skip"
-    | End_patt (_,_) , _ :: _  -> 
+    | End_patt (_,_) , _ :: _  ->
 	anomaly "execute_cases : End of branch with garbage left"
 
 let understand_my_constr c gls =
@@ -1337,41 +1327,41 @@ let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in
      !refine oc gls))
 
 (* end focus/claim *)
-		
+
 let end_tac et2 gls =
   let info = get_its_info gls in
-  let et1,pi,ek,clauses = 
+  let et1,pi,ek,clauses =
     match info.pm_stack with
-	Suppose_case::_ -> 
+	Suppose_case::_ ->
 	  anomaly "This case should already be trapped"
-      | Claim::_ ->  
+      | Claim::_ ->
 	  error "\"end claim\" expected."
       | Focus_claim::_ ->
 	  error "\"end focus\" expected."
-      | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) 
-      | [] -> 
+      | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses)
+      | [] ->
 	  anomaly "This case should already be trapped" in
-  let et = 
+  let et =
     if et1 <> et2 then
-      match et1 with 
-	  ET_Case_analysis -> 
+      match et1 with
+	  ET_Case_analysis ->
 	    error "\"end cases\" expected."
 	| ET_Induction ->
 	    error "\"end induction\" expected."
     else et1 in
-    tclTHEN 
+    tclTHEN
       tcl_erase_info
       begin
 	match et,ek with
-	    _,EK_unknown -> 
-	      tclSOLVE [simplest_elim pi.per_casee]	
+	    _,EK_unknown ->
+	      tclSOLVE [simplest_elim pi.per_casee]
 	  | ET_Case_analysis,EK_nodep ->
-	      tclTHEN 
+	      tclTHEN
 		(general_case_analysis false (pi.per_casee,NoBindings))
 		(default_justification (List.map mkVar clauses))
 	  | ET_Induction,EK_nodep ->
 	      tclTHENLIST
-		[generalize (pi.per_args@[pi.per_casee]); 
+		[generalize (pi.per_args@[pi.per_casee]);
 		 simple_induct (AnonHyp (succ (List.length pi.per_args)));
 		 default_justification (List.map mkVar clauses)]
 	  | ET_Case_analysis,EK_dep tree ->
@@ -1385,57 +1375,48 @@ let end_tac et2 gls =
 	      let nargs = (List.length pi.per_args) in
 		tclTHEN (generalize (pi.per_args@[pi.per_casee]))
 		  begin
-		    fun gls0 -> 
-		      let fix_id = 
+		    fun gls0 ->
+		      let fix_id =
 			pf_get_new_id (id_of_string "_fix") gls0 in
-		      let c_id = 
+		      let c_id =
 			pf_get_new_id (id_of_string "_main_arg") gls0 in
 			tclTHENLIST
 			  [fix (Some fix_id) (succ nargs);
 			   tclDO nargs introf;
 			   intro_mustbe_force c_id;
-			   execute_cases (Name fix_id) pi 
+			   execute_cases (Name fix_id) pi
 			     (fun c ->
-				tclTHENLIST 
+				tclTHENLIST
 				  [clear [fix_id];
 				   my_refine c;
 				   clear clauses;
 				   justification assumption])
-			     (initial_instance_stack clauses) 
+			     (initial_instance_stack clauses)
 			     [mkVar c_id]  0 tree] gls0
-		  end	
+		  end
       end gls
 
 (* escape *)
 
-let rec abstract_metas n avoid head = function
-    [] -> 1,head,[]
-  | (meta,typ)::rest -> 
-      let id = next_ident_away (id_of_string "_sbgl") avoid in
-      let p,term,args = abstract_metas (succ n) (id::avoid) head rest in 
-	succ p,mkLambda(Name id,typ,subst_meta [meta,mkRel p] term),
-      (mkMeta n)::args 
-
-    
 let escape_tac gls =  tcl_erase_info gls
 
 (* General instruction engine *)
 
-let rec do_proof_instr_gen _thus _then instr = 
-  match instr with 
-      Pthus i -> 
+let rec do_proof_instr_gen _thus _then instr =
+  match instr with
+      Pthus i ->
 	assert (not _thus);
 	do_proof_instr_gen true _then i
-    | Pthen i -> 	
+    | Pthen i ->
 	assert (not _then);
 	do_proof_instr_gen _thus true i
-    | Phence i -> 
+    | Phence i ->
 	assert (not (_then || _thus));
 	do_proof_instr_gen true true i
     | Pcut c ->
 	instr_cut mk_stat_or_thesis _thus _then c
     | Psuffices c ->
-	instr_suffices _then c 
+	instr_suffices _then c
     | Prew (s,c) ->
 	assert (not _then);
 	instr_rew _thus s c
@@ -1443,75 +1424,75 @@ let rec do_proof_instr_gen _thus _then instr =
     | Pgiven hyps            -> given_tac hyps
     | Passume hyps           -> assume_tac hyps
     | Plet hyps              -> assume_tac hyps
-    | Pclaim st              -> instr_claim false st 
+    | Pclaim st              -> instr_claim false st
     | Pfocus st              -> instr_claim true st
     | Ptake witl             -> take_tac witl
     | Pdefine (id,args,body) -> define_tac id args body
-    | Pcast (id,typ)         -> cast_tac id typ 
-    | Pper (et,cs)           -> per_tac et cs 
+    | Pcast (id,typ)         -> cast_tac id typ
+    | Pper (et,cs)           -> per_tac et cs
     | Psuppose hyps      -> suppose_tac hyps
     | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps
     | Pend (B_elim et) -> end_tac et
     | Pend _ -> anomaly "Not applicable"
     | Pescape -> escape_tac
- 
+
 let eval_instr {instr=instr} =
-  do_proof_instr_gen false false instr   
+  do_proof_instr_gen false false instr
 
 let rec preprocess pts instr =
   match instr with
     Phence i |Pthus i | Pthen i -> preprocess pts i
-  | Psuffices _ | Pcut _ |  Passume _ | Plet _ | Pclaim _ | Pfocus _ 
-  | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ 
+  | Psuffices _ | Pcut _ |  Passume _ | Plet _ | Pclaim _ | Pfocus _
+  | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _
   | Pdefine (_,_,_) | Pper _ | Prew _ ->
       check_not_per pts;
       true,pts
-  | Pescape -> 
+  | Pescape ->
       check_not_per pts;
       true,pts
-  | Pcase _ | Psuppose _ | Pend (B_elim _) -> 
+  | Pcase _ | Psuppose _ | Pend (B_elim _) ->
       true,close_previous_case pts
-  | Pend bt -> 
-      false,close_block bt pts 
-      
-let rec postprocess pts instr = 
+  | Pend bt ->
+      false,close_block bt pts
+
+let rec postprocess pts instr =
   match instr with
       Phence i | Pthus i | Pthen i -> postprocess pts i
     | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_)
     | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts
-    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ 
+    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _
     | Pescape -> nth_unproven 1 pts
     | Pend (B_elim ET_Induction) ->
   	begin
 	  let pf = proof_of_pftreestate pts in
 	  let (pfterm,_) = extract_open_pftreestate pts in
 	  let env =  Evd.evar_env (goal_of_proof pf) in
-	    try 
+	    try
 	      Inductiveops.control_only_guard env pfterm;
 	      goto_current_focus_or_top (mark_as_done pts)
- 	    with 
+ 	    with
 		Type_errors.TypeError(env,
 				      Type_errors.IllFormedRecBody(_,_,_,_,_)) ->
 		  anomaly "\"end induction\" generated an ill-formed fixpoint"
 	end
-    | Pend _ -> 
+    | Pend _ ->
 	goto_current_focus_or_top (mark_as_done pts)
 
 let do_instr raw_instr pts =
   let has_tactic,pts1 = preprocess pts raw_instr.instr in
-  let pts2 = 
+  let pts2 =
     if has_tactic then
       let gl = nth_goal_of_pftreestate 1 pts1 in
       let env=  pf_env gl in
       let sigma= project gl in
-      let ist = {ltacvars = ([],[]); ltacrecvars = []; 
+      let ist = {ltacvars = ([],[]); ltacrecvars = [];
 		 gsigma = sigma; genv = env} in
       let glob_instr = intern_proof_instr ist raw_instr in
-      let instr = 
+      let instr =
 	interp_proof_instr (get_its_info gl) sigma env glob_instr in
       let lock_focus = is_focussing_instr instr.instr in
       let marker= Proof_instr (lock_focus,instr) in
-	solve_nth_pftreestate 1 
+	solve_nth_pftreestate 1
 	  (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1
     else pts1 in
       postprocess pts2 raw_instr.instr
@@ -1522,8 +1503,8 @@ let proof_instr raw_instr =
 (*
 
 (* STUFF FOR ITERATED RELATIONS *)
-let decompose_bin_app t= 
-  let hd,args = destApp 
+let decompose_bin_app t=
+  let hd,args = destApp
 
 let identify_transitivity_lemma c =
   let varx,tx,c1 = destProd c in
@@ -1534,4 +1515,4 @@ let identify_transitivity_lemma c =
   let p2=pop lp2 in
   let p3=pop lp3 in
 *)
-    
+
diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli
index 5f4a0485..1cfcfedf 100644
--- a/tactics/decl_proof_instr.mli
+++ b/tactics/decl_proof_instr.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_proof_instr.mli 12422 2009-10-27 08:42:49Z corbinea $ *)
+(* $Id$ *)
 
 open Refiner
 open Names
@@ -23,7 +23,8 @@ val automation_tac : tactic
 
 val daimon_subtree: pftreestate -> pftreestate
 
-val concl_refiner: Termops.metamap -> constr -> Proof_type.goal sigma -> constr
+val concl_refiner:
+  Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr
 
 val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate
 val proof_instr: Decl_expr.raw_proof_instr -> unit
@@ -76,27 +77,27 @@ val thesis_for :     Term.constr ->
 val close_previous_case : pftreestate -> pftreestate
 
 val pop_stacks :
-  (Names.identifier * 
-     (Term.constr option * Term.constr list) list) list -> 
-  (Names.identifier * 
+  (Names.identifier *
+     (Term.constr option * Term.constr list) list) list ->
+  (Names.identifier *
      (Term.constr option * Term.constr list) list) list
 
 val push_head :   Term.constr ->
   Names.Idset.t ->
-  (Names.identifier * 
+  (Names.identifier *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier * 
+  (Names.identifier *
      (Term.constr option * Term.constr list) list) list
 
 val push_arg : Term.constr ->
-  (Names.identifier * 
+  (Names.identifier *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier * 
+  (Names.identifier *
      (Term.constr option * Term.constr list) list) list
 
-val hrec_for: 
+val hrec_for:
     Names.identifier ->
-    Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> 
+    Decl_mode.per_info -> Proof_type.goal Tacmach.sigma ->
     Names.identifier -> Term.constr
 
 val consider_match :
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index f3e1559f..96d83b97 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dhyp.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 (* Chet's comments about this tactic :
- 
+
  Programmable destruction of hypotheses and conclusions.
 
    The idea here is that we are going to store patterns.  These
@@ -136,7 +136,7 @@ open Libnames
 
 (* two patterns - one for the type, and one for the type of the type *)
 type destructor_pattern = {
-  d_typ: constr_pattern; 
+  d_typ: constr_pattern;
   d_sort: constr_pattern }
 
 let subst_destructor_pattern subst { d_typ = t; d_sort = s } =
@@ -151,96 +151,88 @@ type located_destructor_pattern =
    destructor_pattern) location
 
 let subst_located_destructor_pattern subst = function
-  | HypLocation (b,d,d') -> 
+  | HypLocation (b,d,d') ->
       HypLocation
         (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d')
   | ConclLocation d ->
       ConclLocation (subst_destructor_pattern subst d)
 
+
 type destructor_data = {
   d_pat : located_destructor_pattern;
   d_pri : int;
   d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *)
 }
 
-type t = (identifier,destructor_data) Nbtermdn.t
-type frozen_t = (identifier,destructor_data) Nbtermdn.frozen_t
+module Dest_data = struct 
+  type t = destructor_data
+  let compare = Pervasives.compare
+    end
+
+module Nbterm_net = Nbtermdn.Make(Dest_data)
+
+type t = identifier Nbterm_net.t
+type frozen_t = identifier Nbterm_net.frozen_t
 
-let tactab = (Nbtermdn.create () : t)
+let tactab = (Nbterm_net.create () : t)
 
-let lookup pat = Nbtermdn.lookup tactab pat
+let lookup pat = Nbterm_net.lookup tactab pat
 
-let init () = Nbtermdn.empty tactab
 
-let freeze () = Nbtermdn.freeze tactab
-let unfreeze fs = Nbtermdn.unfreeze fs tactab
+let init () = Nbterm_net.empty tactab
 
-let rollback f x =
-  let fs = freeze() in 
-  try f x with e -> (unfreeze fs; raise e)
+let freeze () = Nbterm_net.freeze tactab
+let unfreeze fs = Nbterm_net.unfreeze fs tactab
 
 let add (na,dd) =
   let pat = match dd.d_pat with
     | HypLocation(_,p,_) -> p.d_typ
     | ConclLocation p -> p.d_typ
-  in 
-  if Nbtermdn.in_dn tactab na then begin
-    msgnl (str "Warning [Overriding Destructor Entry " ++ 
+  in
+  if Nbterm_net.in_dn tactab na then begin
+    msgnl (str "Warning [Overriding Destructor Entry " ++
              str (string_of_id na) ++ str"]");
-    Nbtermdn.remap tactab na (pat,dd)
-  end else 
-    Nbtermdn.add tactab (na,(pat,dd))
+    Nbterm_net.remap tactab na (pat,dd)
+  end else
+    Nbterm_net.add tactab (na,(pat,dd))
 
-let _ = 
+let _ =
   Summary.declare_summary "destruct-hyp-concl"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+      Summary.init_function = init }
 
-let forward_subst_tactic = 
+let forward_subst_tactic =
   ref (fun _ -> failwith "subst_tactic is not installed for DHyp")
 
-let set_extern_subst_tactic f = forward_subst_tactic := f
-
 let cache_dd (_,(_,na,dd)) =
-  try 
+  try
     add (na,dd)
-  with _ -> 
+  with _ ->
     anomalylabstrm "Dhyp.add"
-      (str"The code which adds destructor hints broke;" ++ spc () ++ 
+      (str"The code which adds destructor hints broke;" ++ spc () ++
 	 str"this is not supposed to happen")
 
-let classify_dd (_,(local,_,_ as o)) =
+let classify_dd (local,_,_ as o) =
   if local then Dispose else Substitute o
 
-let export_dd (local,_,_ as x) = if local then None else Some x
-
-let subst_dd (_,subst,(local,na,dd)) =
+let subst_dd (subst,(local,na,dd)) =
   (local,na,
   { d_pat = subst_located_destructor_pattern subst dd.d_pat;
-    d_pri = dd.d_pri; 
+    d_pri = dd.d_pri;
     d_code = !forward_subst_tactic subst dd.d_code })
 
-let (inDD,outDD) =
+let (inDD,_) =
   declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with
                     cache_function = cache_dd;
 		    open_function = (fun i o -> if i=1 then cache_dd o);
                     subst_function = subst_dd;
-		    classify_function = classify_dd;
-                    export_function = export_dd }
-
-let forward_intern_tac = 
-  ref (fun _ -> failwith "intern_tac is not installed for DHyp")
-
-let set_extern_intern_tac f = forward_intern_tac := f
+		    classify_function = classify_dd }
 
 let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT"))
 let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE"))
-    
-let add_destructor_hint local na loc pat pri code =
-  let code = !forward_intern_tac code in
+
+let add_destructor_hint local na loc (_,pat) pri code =
   let code =
     begin match loc, code with
       | HypLocation _, TacFun ([id],body) -> (id,body)
@@ -249,8 +241,6 @@ let add_destructor_hint local na loc pat pri code =
 	  errorlabstrm "add_destructor_hint"
           (str "The tactic should be a function of the hypothesis name.") end
   in
-  let (_,pat) = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat
-  in
   let pat = match loc with
     | HypLocation b ->
 	HypLocation
@@ -289,18 +279,18 @@ let match_dpat dp cls gls =
         then error "No match."
     | _ -> error "ApplyDestructor"
 
-let forward_interp_tactic = 
+let forward_interp_tactic =
   ref (fun _ -> failwith "interp_tactic is not installed for DHyp")
 
 let set_extern_interp f = forward_interp_tactic := f
 
 let applyDestructor cls discard dd gls =
   match_dpat dd.d_pat cls gls;
-  let cll = simple_clause_list_of cls gls in
+  let cll = simple_clause_of cls gls in
   let tacl =
     List.map (fun cl ->
       match cl, dd.d_code with
-        | Some ((_,id),_), (Some x, tac) -> 
+        | Some id, (Some x, tac) ->
 	    let arg =
               ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
             TacLetIn (false, [(dummy_loc, x), arg], tac)
@@ -311,7 +301,7 @@ let applyDestructor cls discard dd gls =
   let discard_0 =
     List.map (fun cl ->
       match (cl,dd.d_pat) with
-        | (Some ((_,id),_),HypLocation(discardable,_,_)) ->
+        | (Some id,HypLocation(discardable,_,_)) ->
             if discard & discardable then thin [id] else tclIDTAC
         | (None,ConclLocation _) -> tclIDTAC
         | _ -> error "ApplyDestructor" ) cll in
@@ -330,7 +320,6 @@ let destructHyp discard id gls =
   let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
   tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls
 
-let cDHyp id gls = destructHyp true id gls
 let dHyp id gls = destructHyp false id gls
 
 let h_destructHyp b id =
@@ -349,22 +338,20 @@ let dConcl gls =
 
 let h_destructConcl = abstract_tactic TacDestructConcl dConcl
 
-let to2Lists (table : t) = Nbtermdn.to2lists table
-
 let rec search n =
   if n=0 then error "Search has reached zero.";
   tclFIRST
     [intros;
      assumption;
-     (tclTHEN  
-        (Tacticals.tryAllClauses 
-           (function 
-              | Some ((_,id),_) -> (dHyp id)
+     (tclTHEN
+        (Tacticals.tryAllHypsAndConcl
+           (function
+              | Some id -> (dHyp id)
               | None    ->  dConcl ))
         (search (n-1)))]
-    
+
 let auto_tdb n = tclTRY (tclCOMPLETE (search n))
-   
+
 let search_depth_tdb = ref(5)
 
 let depth_tdb = function
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
index 630092f0..41fd497f 100644
--- a/tactics/dhyp.mli
+++ b/tactics/dhyp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dhyp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -17,7 +17,6 @@ open Tacexpr
 (* Programmable destruction of hypotheses and conclusions. *)
 
 val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
-val set_extern_intern_tac : (raw_tactic_expr -> glob_tactic_expr) -> unit
 
 (*
 val dHyp : identifier -> tactic
@@ -29,4 +28,5 @@ val h_auto_tdb : int option -> tactic
 
 val add_destructor_hint :
   Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location ->
-    Topconstr.constr_expr -> int -> raw_tactic_expr -> unit
+    Rawterm.patvar list * Pattern.constr_pattern -> int ->
+      glob_tactic_expr -> unit
diff --git a/tactics/dn.ml b/tactics/dn.ml
index 2a8166dc..a0889ab8 100644
--- a/tactics/dn.ml
+++ b/tactics/dn.ml
@@ -1,100 +1,103 @@
-(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *)
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
 
-(* $Id: dn.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
 
-(* This file implements the basic structure of what Chet called
-   ``discrimination nets''. If my understanding is right, it serves
-   to associate actions (for example, tactics) with a priority to term
-   patterns, so that if a hypothesis matches a pattern in the net,
-   then the associated tactic is applied. Discrimination nets are used
-   (only) to implement the tactics Auto, DHyp and Point.
 
-   A discrimination net is a tries structure, that is, a tree structure 
-   specially conceived for searching patterns, like for example strings
-   --see the file Tlm.ml in the directory lib/util--. Here the tries
-   structure are used for looking for term patterns.
 
-   This module is then used in :
-     - termdn.ml   (discrimination nets of terms);
-     - btermdn.ml  (discrimination nets of terms with bounded depth,
-                    used in the tactic auto);
-     - nbtermdn.ml (named discrimination nets with bounded depth, used
-                    in the tactics Dhyp and Point).
-  Eduardo (4/8/97) *)
 
-(* Definition of the basic structure *)
+module Make = 
+  functor (X : Set.OrderedType) ->
+    functor (Y : Map.OrderedType) ->
+      functor (Z : Map.OrderedType) ->
+struct
+  
+  module Y_tries = struct
+    type t = (Y.t * int) option
+    let compare x y = 
+      match x,y with
+	  None,None -> 0
+	| Some (l,n),Some (l',n') -> 
+	    let m = Y.compare l l' in
+	    if m = 0 then
+	      n-n' 
+	    else m
+	| Some(l,n),None -> 1
+	| None, Some(l,n) -> -1
+  end
+  module X_tries = struct
+    type t = X.t * Z.t
+    let compare (x1,x2) (y1,y2) = 
+      let m = (X.compare x1 y1) in
+      if m = 0 then (Z.compare x2 y2) else 
+	m
+  end
 
-type ('lbl,'pat) decompose_fun = 'pat -> ('lbl * 'pat list) option
-
-type 'res lookup_res = Label of 'res | Nothing | Everything
+  module T = Tries.Make(X_tries)(Y_tries)
+    
+  type  decompose_fun = X.t -> (Y.t * X.t list) option
     
-type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res
+  type 'res lookup_res = Label of 'res | Nothing | Everything
+    
+  type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
 
-type ('lbl,'pat,'inf) t = (('lbl * int) option,'pat * 'inf) Tlm.t
+  type  t = T.t
 
-let create () = Tlm.empty
+  let create () = T.empty
 
 (* [path_of dna pat] returns the list of nodes of the pattern [pat] read in 
 prefix ordering, [dna] is the function returning the main node of a pattern *)
 
-let path_of dna =
-  let rec path_of_deferred = function
-    | [] -> []
-    | h::tl -> pathrec tl h
-	    
-  and pathrec deferred t =
-    match dna t with
-    | None -> 
-	None :: (path_of_deferred deferred)
-    | Some (lbl,[]) ->
-	(Some (lbl,0))::(path_of_deferred deferred)
-    | Some (lbl,(h::def_subl as v)) ->
-	(Some (lbl,List.length v))::(pathrec (def_subl@deferred) h)
-  in 
-  pathrec []
-    
-let tm_of tm lbl =
-  try [Tlm.map tm lbl, true] with Not_found -> []
-    
-let rec skip_arg n tm =
-  if n = 0 then [tm,true]
-  else
-    List.flatten 
-      (List.map 
-	  (fun a -> match a with
-	  | None -> skip_arg (pred n) (Tlm.map tm a)
-	  | Some (lbl,m) -> 
-	      skip_arg (pred n + m) (Tlm.map tm a)) 
-	  (Tlm.dom tm))
+  let path_of dna =
+    let rec path_of_deferred = function
+      | [] -> []
+      | h::tl -> pathrec tl h
+	  
+    and pathrec deferred t =
+      match dna t with
+	| None -> 
+	    None :: (path_of_deferred deferred)
+	| Some (lbl,[]) ->
+	    (Some (lbl,0))::(path_of_deferred deferred)
+	| Some (lbl,(h::def_subl as v)) ->
+	    (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h)
+    in 
+      pathrec []
+	
+  let tm_of tm lbl =
+    try [T.map tm lbl, true] with Not_found -> []
       
-let lookup tm dna t =
-  let rec lookrec t tm =
-    match dna t with
-    | Nothing -> tm_of tm None
-    | Label(lbl,v) ->
-	tm_of tm None@
-	  (List.fold_left 
-	      (fun l c -> 
+  let rec skip_arg n tm =
+    if n = 0 then [tm,true]
+    else
+      List.flatten 
+	(List.map 
+	   (fun a -> match a with
+	      | None -> skip_arg (pred n) (T.map tm a)
+	      | Some (lbl,m) -> 
+		  skip_arg (pred n + m) (T.map tm a)) 
+	   (T.dom tm))
+	
+  let lookup tm dna t =
+    let rec lookrec t tm =
+      match dna t with
+	| Nothing -> tm_of tm None
+	| Label(lbl,v) ->
+	    tm_of tm None@
+	      (List.fold_left 
+		 (fun l c -> 
 		List.flatten(List.map (fun (tm, b) ->
-		  if b then lookrec c tm
-		  else [tm,b]) l))
-              (tm_of tm (Some(lbl,List.length v))) v)
-    | Everything -> skip_arg 1 tm
-  in 
-    List.flatten (List.map (fun (tm,b) -> Tlm.xtract tm) (lookrec t tm))
-
-let add tm dna (pat,inf) =
-  let p = path_of dna pat in Tlm.add tm (p,(pat,inf))
+					 if b then lookrec c tm
+					 else [tm,b]) l))
+		 (tm_of tm (Some(lbl,List.length v))) v)
+	| Everything -> skip_arg 1 tm
+    in 
+      List.flatten (List.map (fun (tm,b) -> T.xtract tm) (lookrec t tm))
+	
+  let add tm dna (pat,inf) =
+    let p = path_of dna pat in T.add tm (p,(pat,inf))
+				 
+  let rmv tm dna (pat,inf) =
+  let p = path_of dna pat in T.rmv tm (p,(pat,inf))
+			       
+  let app f tm = T.app (fun (_,p) -> f p) tm
     
-let rmv tm dna (pat,inf) =
-  let p = path_of dna pat in Tlm.rmv tm (p,(pat,inf))
-    
-let app f tm = Tlm.app (fun (_,p) -> f p) tm
-
+end
+  
diff --git a/tactics/dn.mli b/tactics/dn.mli
index 62e37a73..3cb52a56 100644
--- a/tactics/dn.mli
+++ b/tactics/dn.mli
@@ -1,46 +1,47 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
 
-(*i $Id: dn.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
 
-(* Discrimination nets. *)
 
-type ('lbl,'tree) decompose_fun = 'tree -> ('lbl * 'tree list) option
 
-type ('lbl,'pat,'inf) t (* = (('lbl * int) option,'pat * 'inf) Tlm.t *)
 
-val create : unit -> ('lbl,'pat,'inf) t
 
-(* [add t f (tree,inf)] adds a structured object [tree] together with
-   the associated information [inf] to the table [t]; the function
-   [f] is used to translated [tree] into its prefix decomposition: [f]
-   must decompose any tree into a label characterizing its root node and
-   the list of its subtree *)
 
-val add : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf
-  -> ('lbl,'pat,'inf) t
+module Make : 
+  functor (X : Set.OrderedType) ->
+    functor (Y : Map.OrderedType) ->
+      functor (Z : Map.OrderedType) ->
+sig
 
-val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf 
-  -> ('lbl,'pat,'inf) t
-
-type 'res lookup_res = Label of 'res | Nothing | Everything
+  type decompose_fun = X.t -> (Y.t * X.t list) option
     
-type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res
+  type t
 
+  val create : unit -> t
+    
+  (* [add t f (tree,inf)] adds a structured object [tree] together with
+     the associated information [inf] to the table [t]; the function
+     [f] is used to translated [tree] into its prefix decomposition: [f]
+     must decompose any tree into a label characterizing its root node and
+     the list of its subtree *)
+    
+  val add : t -> decompose_fun -> X.t * Z.t -> t
+    
+  val rmv : t -> decompose_fun -> X.t * Z.t -> t
+    
+  type 'res lookup_res = Label of 'res | Nothing | Everything
+      
+  type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
+    
 (* [lookup t f tree] looks for trees (and their associated
    information) in table [t] such that the structured object [tree]
    matches against them; [f] is used to translated [tree] into its
    prefix decomposition: [f] must decompose any tree into a label
    characterizing its root node and the list of its subtree *)
-
-val lookup : ('lbl,'pat,'inf) t -> ('lbl,'term) lookup_fun -> 'term
-  -> ('pat * 'inf) list
-
-val app : (('pat * 'inf) -> unit) -> ('lbl,'pat,'inf) t -> unit
-
-val skip_arg : int -> ('lbl,'pat,'inf) t -> (('lbl,'pat,'inf) t * bool) list
+    
+  val lookup : t -> 'term lookup_fun -> 'term
+    -> (X.t * Z.t) list
+    
+  val app : ((X.t * Z.t) -> unit) -> t -> unit
+    
+  val skip_arg : int -> t -> (t * bool) list
+    
+end
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 67bdeb46..89f8d72f 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eauto.ml4 11735 2009-01-02 17:22:31Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -31,14 +31,16 @@ open Auto
 open Rawterm
 open Hiddentac
 
-let e_give_exact ?(flags=Unification.default_unify_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in 
-  if occur_existential t1 or occur_existential t2 then 
+let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
+
+let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in
+  if occur_existential t1 or occur_existential t2 then
      tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl
   else exact_check c gl
 
 let assumption id = e_give_exact (mkVar id)
-        
-let e_assumption gl = 
+
+let e_assumption gl =
   tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
 
 TACTIC EXTEND eassumption
@@ -49,10 +51,8 @@ TACTIC EXTEND eexact
 | [ "eexact" constr(c) ] -> [ e_give_exact c ]
 END
 
-let e_give_exact_constr = h_eexact
-
-let registered_e_assumption gl = 
-  tclFIRST (List.map (fun id gl -> e_give_exact_constr (mkVar id) gl) 
+let registered_e_assumption gl =
+  tclFIRST (List.map (fun id gl -> e_give_exact (mkVar id) gl)
               (pf_ids_of_hyps gl)) gl
 
 (************************************************************************)
@@ -93,163 +93,116 @@ open Unification
 
 let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
 
-(* no delta yet *)
-
-let unify_e_resolve flags (c,clenv) gls = 
+let unify_e_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
   let _ = clenv_unique_resolver false ~flags clenv' gls in
   h_simplest_eapply c gls
 
-let unify_e_resolve_nodelta (c,clenv) gls = 
-  let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver false clenv' gls in
-  h_simplest_eapply c gls
-
-let rec e_trivial_fail_db mod_delta db_list local_db goal =
-  let tacl = 
+let rec e_trivial_fail_db db_list local_db goal =
+  let tacl =
     registered_e_assumption ::
-    (tclTHEN Tactics.intro 
+    (tclTHEN Tactics.intro
        (function g'->
 	  let d = pf_last_hyp g' in
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
-          (e_trivial_fail_db mod_delta db_list
+          (e_trivial_fail_db db_list
 	      (Hint_db.add_list hintl local_db) g'))) ::
-    (List.map fst (e_trivial_resolve mod_delta db_list local_db (pf_concl goal)) )
-  in 
-  tclFIRST (List.map tclCOMPLETE tacl) goal 
-
-and e_my_find_search mod_delta =
-  if mod_delta then e_my_find_search_delta
-  else e_my_find_search_nodelta
-
-and e_my_find_search_nodelta db_list local_db hdc concl = 
-  let hdc = head_of_constr_reference hdc in
-  let hintl =
-    if occur_existential concl then 
-      list_map_append (Hint_db.map_all hdc) (local_db::db_list)
-    else 
-      list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
-  in 
-  let tac_of_hint = 
-    fun {pri=b; pat = p; code=t} -> 
-      (b, 
-       let tac =
-	 match t with
-	   | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl)
-	   | ERes_pf (term,cl) -> unify_e_resolve_nodelta (term,cl)
-	   | Give_exact (c) -> e_give_exact_constr c
-	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve_nodelta (term,cl)) 
-		 (e_trivial_fail_db false db_list local_db)
-	   | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
-	   | Extern tacast -> conclPattern concl p tacast
-       in 
-       (tac,pr_autotactic t))
-       (*i
-	 fun gls -> pPNL (pr_autotactic t); Format.print_flush (); 
-                     try tac gls
-		     with e when Logic.catchable_exception(e) -> 
-                            (Format.print_string "Fail\n"; 
-			     Format.print_flush (); 
-			     raise e)
-       i*)
-  in 
-  List.map tac_of_hint hintl
+    (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+  in
+  tclFIRST (List.map tclCOMPLETE tacl) goal
 
-and e_my_find_search_delta db_list local_db hdc concl = 
+and e_my_find_search db_list local_db hdc concl =
   let hdc = head_of_constr_reference hdc in
   let hintl =
-    if occur_existential concl then 
-      list_map_append (fun db -> 
+    if occur_existential concl then
+      list_map_append (fun db ->
 	let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in
 	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
-    else 
-      list_map_append (fun db -> 
+    else
+      list_map_append (fun db ->
 	let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in
 	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
-  in 
-  let tac_of_hint = 
-    fun (st, {pri=b; pat = p; code=t}) -> 
-      (b, 
+  in
+  let tac_of_hint =
+    fun (st, {pri=b; pat = p; code=t}) ->
+      (b,
        let tac =
 	 match t with
 	   | Res_pf (term,cl) -> unify_resolve st (term,cl)
 	   | ERes_pf (term,cl) -> unify_e_resolve st (term,cl)
-	   | Give_exact (c) -> e_give_exact ~flags:st c
+	   | Give_exact (c) -> e_give_exact c
 	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve st (term,cl)) 
-		 (e_trivial_fail_db true db_list local_db)
-	   | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
+               tclTHEN (unify_e_resolve st (term,cl))
+		 (e_trivial_fail_db db_list local_db)
+	   | Unfold_nth c -> h_reduce (Unfold [all_occurrences_expr,c]) onConcl
 	   | Extern tacast -> conclPattern concl p tacast
-       in 
-       (tac,pr_autotactic t))
+       in
+       (tac,lazy (pr_autotactic t)))
        (*i
-	 fun gls -> pPNL (pr_autotactic t); Format.print_flush (); 
+	 fun gls -> pPNL (pr_autotactic t); Format.print_flush ();
                      try tac gls
-		     with e when Logic.catchable_exception(e) -> 
-                            (Format.print_string "Fail\n"; 
-			     Format.print_flush (); 
+		     with e when Logic.catchable_exception(e) ->
+                            (Format.print_string "Fail\n";
+			     Format.print_flush ();
 			     raise e)
        i*)
-  in 
+  in
   List.map tac_of_hint hintl
-    
-and e_trivial_resolve mod_delta db_list local_db gl = 
-  try 
-    priority 
-      (e_my_find_search mod_delta db_list local_db 
+
+and e_trivial_resolve db_list local_db gl =
+  try
+    priority
+      (e_my_find_search db_list local_db
 	 (fst (head_constr_bound gl)) gl)
   with Bound | Not_found -> []
 
-let e_possible_resolve mod_delta db_list local_db gl =
-  try List.map snd 
-    (e_my_find_search mod_delta db_list local_db 
+let e_possible_resolve db_list local_db gl =
+  try List.map snd
+    (e_my_find_search db_list local_db
 	(fst (head_constr_bound gl)) gl)
   with Bound | Not_found -> []
 
-let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
-
-let find_first_goal gls = 
+let find_first_goal gls =
   try first_goal gls with UserError _ -> assert false
 
 (*s The following module [SearchProblem] is used to instantiate the generic
     exploration functor [Explore.Make]. *)
 
-type search_state = { 
+type search_state = {
   depth : int; (*r depth of search before failing *)
   tacres : goal list sigma * validation;
-  last_tactic : std_ppcmds;
+  last_tactic : std_ppcmds Lazy.t;
   dblist : Auto.hint_db list;
   localdb :  Auto.hint_db list }
-    
+
 module SearchProblem = struct
-    
+
   type state = search_state
 
   let success s = (sig_it (fst s.tacres)) = []
 
   let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
-    
+
   let pr_goals gls =
     let evars = Evarutil.nf_evars (Refiner.project gls) in
       prlist (pr_ev evars) (sig_it gls)
-	
+
   let filter_tactics (glls,v) l =
 (*     let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
 (*     let evars = Evarutil.nf_evars (Refiner.project glls) in *)
 (*     msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *)
     let rec aux = function
       | [] -> []
-      | (tac,pptac) :: tacl -> 
-	  try 
-	    let (lgls,ptl) = apply_tac_list tac glls in 
+      | (tac,pptac) :: tacl ->
+	  try
+	    let (lgls,ptl) = apply_tac_list tac glls in
 	    let v' p = v (ptl p) 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,v'),pptac) :: aux tacl
 	  with e -> Refiner.catch_failerror e; aux tacl
     in aux l
-      
+
   (* Ordering of states is lexicographic on depth (greatest first) then
      number of remaining goals. *)
   let compare s s' =
@@ -257,61 +210,61 @@ module SearchProblem = struct
     let nbgoals s = List.length (sig_it (fst s.tacres)) in
     if d <> 0 then d else nbgoals s - nbgoals s'
 
-  let branching s = 
-    if s.depth = 0 then 
+  let branching s =
+    if s.depth = 0 then
       []
-    else      
+    else
       let lg = fst s.tacres in
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
       let g = find_first_goal lg in
-      let assumption_tacs = 
-	let l = 
+      let assumption_tacs =
+	let l =
 	  filter_tactics s.tacres
-	    (List.map 
-	       (fun id -> (e_give_exact_constr (mkVar id),
-			   (str "exact" ++ spc () ++ pr_id id)))
+	    (List.map
+	       (fun id -> (e_give_exact (mkVar id),
+			   lazy (str "exact" ++ spc () ++ pr_id id)))
 	       (pf_ids_of_hyps g))
 	in
 	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
 				    last_tactic = pp; dblist = s.dblist;
 				    localdb = List.tl s.localdb }) l
       in
-      let intro_tac = 
-	List.map 
-	  (fun ((lgls,_) as res,pp) -> 
-	     let g' = first_goal lgls in 
-	     let hintl = 
+      let intro_tac =
+	List.map
+	  (fun ((lgls,_) as res,pp) ->
+	     let g' = first_goal lgls in
+	     let hintl =
 	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
 	     in
              let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
-	     { depth = s.depth; tacres = res; 
+	     { depth = s.depth; tacres = res;
 	       last_tactic = pp; dblist = s.dblist;
 	       localdb = ldb :: List.tl s.localdb })
-	  (filter_tactics s.tacres [Tactics.intro,(str "intro")])
+	  (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")])
       in
-      let rec_tacs = 
-	let l = 
-	  filter_tactics s.tacres (e_possible_resolve false s.dblist (List.hd s.localdb) (pf_concl g))
+      let rec_tacs =
+	let l =
+	  filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
 	in
-	List.map 
-	  (fun ((lgls,_) as res, pp) -> 
+	List.map
+	  (fun ((lgls,_) as res, pp) ->
 	     let nbgl' = List.length (sig_it lgls) in
 	     if nbgl' < nbgl then
 	       { depth = s.depth; tacres = res; last_tactic = pp;
 		 dblist = s.dblist; localdb = List.tl s.localdb }
-	     else 
-	       { depth = pred s.depth; tacres = res; 
+	     else
+	       { depth = pred s.depth; tacres = res;
 		 dblist = s.dblist; last_tactic = pp;
-		 localdb = 
+		 localdb =
 		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
 	  l
       in
       List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
 
-  let pp s = 
-    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ 
-		  s.last_tactic ++ str "\n"))
+  let pp s =
+    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++
+		  (Lazy.force s.last_tactic) ++ str "\n"))
 
 end
 
@@ -320,12 +273,10 @@ module Search = Explore.Make(SearchProblem)
 let make_initial_state n gl dblist localdb =
   { depth = n;
     tacres = tclIDTAC gl;
-    last_tactic = (mt ());
+    last_tactic = lazy (mt());
     dblist = dblist;
     localdb = [localdb] }
 
-let debug_depth_first = Search.debug_depth_first
-
 let e_depth_search debug p db_list local_db gl =
   try
     let tac = if debug then Search.debug_depth_first else Search.depth_first in
@@ -335,36 +286,36 @@ let e_depth_search debug p db_list local_db gl =
 
 let e_breadth_search debug n db_list local_db gl =
   try
-    let tac = 
-      if debug then Search.debug_breadth_first else Search.breadth_first 
+    let tac =
+      if debug then Search.debug_breadth_first else Search.breadth_first
     in
     let s = tac (make_initial_state n gl db_list local_db) in
     s.tacres
   with Not_found -> error "eauto: breadth first search failed."
 
-let e_search_auto debug (in_depth,p) lems db_list gl = 
-  let local_db = make_local_hint_db true lems gl in 
-  if in_depth then 
+let e_search_auto debug (in_depth,p) lems db_list gl =
+  let local_db = make_local_hint_db true lems gl in
+  if in_depth then
     e_depth_search debug p db_list local_db gl
-  else 
+  else
     e_breadth_search debug p db_list local_db gl
 
 open Evd
 
-let eauto_with_bases debug np lems db_list = 
+let eauto_with_bases debug np lems db_list =
   tclTRY (e_search_auto debug np lems db_list)
 
-let eauto debug np lems dbnames = 
+let eauto debug np lems dbnames =
   let db_list =
     List.map
-      (fun x -> 
+      (fun x ->
 	 try searchtable_map x
 	 with Not_found -> error ("No such Hint database: "^x^"."))
-      ("core"::dbnames) 
+      ("core"::dbnames)
   in
   tclTRY (e_search_auto debug np lems db_list)
-  
-let full_eauto debug n lems gl = 
+
+let full_eauto debug n lems gl =
   let dbnames = current_db_names () in
   let dbnames =  list_subtract dbnames ["v62"] in
   let db_list = List.map searchtable_map dbnames in
@@ -375,7 +326,7 @@ let gen_eauto d np lems = function
   | Some l -> eauto d np lems l
 
 let make_depth = function
-  | None -> !default_search_depth 
+  | None -> !default_search_depth
   | Some (ArgArg d) -> d
   | _ -> error "eauto called with a non closed argument."
 
@@ -398,7 +349,7 @@ ARGUMENT EXTEND hintbases
 | [ ] -> [ Some [] ]
 END
 
-let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_coma prc
+let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
 
 ARGUMENT EXTEND constr_coma_sequence
   TYPED AS constr_list
@@ -417,52 +368,146 @@ ARGUMENT EXTEND auto_using
 END
 
 TACTIC EXTEND eauto
-| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) 
+| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
     [ gen_eauto false (make_dimension n p) lems db ]
 END
 
 TACTIC EXTEND new_eauto
-| [ "new" "auto" int_or_var_opt(n) auto_using(lems) 
+| [ "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) 
+| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
     [ gen_eauto true (make_dimension n p) lems db ]
 END
 
 TACTIC EXTEND dfs_eauto
-| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) 
+| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
       hintbases(db) ] ->
     [ gen_eauto false (true, make_depth p) lems db ]
 END
 
+let cons a l = a :: l
+
+let autounfold db cl =
+  let unfolds = List.concat (List.map (fun dbname -> 
+    let db = try searchtable_map dbname 
+      with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
+    in
+    let (ids, csts) = Hint_db.unfolds db in
+      Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts
+	(Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db)
+  in unfold_option unfolds cl
+
 let autosimpl db cl =
   let unfold_of_elts constr (b, elts) =
-    if not b then 
+    if not b then
       List.map (fun c -> all_occurrences, constr c) elts
     else []
   in
-  let unfolds = List.concat (List.map (fun dbname -> 
+  let unfolds = List.concat (List.map (fun dbname ->
     let db = searchtable_map dbname in
     let (ids, csts) = Hint_db.transparent_state db in
       unfold_of_elts (fun x -> EvalConstRef x) (Cpred.elements csts) @
       unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db)
   in unfold_option unfolds cl
 
-TACTIC EXTEND autosimpl
-| [ "autosimpl" hintbases(db) ] ->
-    [ autosimpl (match db with None -> ["core"] | Some x -> "core"::x) None ]
+TACTIC EXTEND autounfold
+| [ "autounfold" hintbases(db) "in" hyp(id) ] ->
+    [ autounfold (match db with None -> ["core"] | Some x -> x) (Some (id, InHyp)) ]
+| [ "autounfold" hintbases(db) ] ->
+    [ autounfold (match db with None -> ["core"] | Some x -> x) None ]
+      END
+
+let unfold_head env (ids, csts) c = 
+  let rec aux c = 
+    match kind_of_term c with
+    | Var id when Idset.mem id ids ->
+	(match Environ.named_body id env with
+	| Some b -> true, b
+	| None -> false, c)
+    | Const cst when Cset.mem cst csts ->
+	true, Environ.constant_value env cst
+    | App (f, args) ->
+	(match aux f with
+	| true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args))
+	| false, _ -> 
+	    let done_, args' = 
+	      array_fold_left_i (fun i (done_, acc) arg -> 
+		if done_ then done_, arg :: acc 
+		else match aux arg with
+		| true, arg' -> true, arg' :: acc
+		| false, arg' -> false, arg :: acc)
+		(false, []) args
+	    in 
+	      if done_ then true, mkApp (f, Array.of_list (List.rev args'))
+	      else false, c)
+    | _ -> 
+	let done_ = ref false in
+	let c' = map_constr (fun c -> 
+	  if !done_ then c else 
+	    let x, c' = aux c in
+	      done_ := x; c') c
+	in !done_, c'
+  in aux c
+
+let autounfold_one db cl gl =
+  let st =
+    List.fold_left (fun (i,c) dbname -> 
+      let db = try searchtable_map dbname 
+	with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
+      in
+      let (ids, csts) = Hint_db.unfolds db in
+	(Idset.union ids i, Cset.union csts c)) (Idset.empty, Cset.empty) db
+  in
+  let did, c' = unfold_head (pf_env gl) st (match cl with Some (id, _) -> pf_get_hyp_typ gl id | None -> pf_concl gl) in
+    if did then
+      match cl with
+      | Some hyp -> change_in_hyp None c' hyp gl
+      | None -> convert_concl_no_check c' DEFAULTcast gl
+    else tclFAIL 0 (str "Nothing to unfold") gl
+
+(* 	  Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *)
+(* 	    (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
+(*       in unfold_option unfolds 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 *)
+(* 	  (Idset.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) ] -> [
+    let db = match kind_of_term x with
+      | Const c -> string_of_label (con_label c)
+      | _ -> assert false
+    in autounfold ["core";db] None ]
 END
 
 TACTIC EXTEND unify
 | ["unify" constr(x) constr(y) ] -> [ unify x y ]
-| ["unify" constr(x) constr(y) "with" preident(base)  ] -> [ 
+| ["unify" constr(x) constr(y) "with" preident(base)  ] -> [
     unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ]
 END
+
+
+TACTIC EXTEND convert_concl_no_check
+| ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ]
+END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index 1c6f9920..b708949e 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -25,9 +25,9 @@ val e_assumption : tactic
 
 val registered_e_assumption : tactic
 
-val e_give_exact_constr : constr -> tactic
+val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic
 
-val gen_eauto : bool -> bool * int -> constr list -> 
+val gen_eauto : bool -> bool * int -> constr list ->
   hint_db_name list option -> tactic
 
 
@@ -35,3 +35,5 @@ val eauto_with_bases :
   bool ->
   bool * int ->
   Term.constr list -> Auto.hint_db list -> Proof_type.tactic
+
+val autounfold : hint_db_name list -> Tacticals.goal_location -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index fa4a7caa..cac200f5 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elim.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -28,12 +28,12 @@ open Genarg
 open Tacexpr
 
 let introElimAssumsThen tac ba =
-  let nassums = 
-    List.fold_left 
-      (fun acc b -> if b then acc+2 else acc+1) 
-      0 ba.branchsign 
-  in 
-  let introElimAssums = tclDO nassums intro in 
+  let nassums =
+    List.fold_left
+      (fun acc b -> if b then acc+2 else acc+1)
+      0 ba.branchsign
+  in
+  let introElimAssums = tclDO nassums intro in
   (tclTHEN introElimAssums (elim_on_ba tac ba))
 
 let introCaseAssumsThen tac ba =
@@ -41,12 +41,12 @@ let introCaseAssumsThen tac ba =
     List.flatten
       (List.map (function b -> if b then [false;true] else [false])
 	ba.branchsign)
-  in 
+  in
   let n1 = List.length case_thin_sign in
   let n2 = List.length ba.branchnames in
   let (l1,l2),l3 =
     if n1 < n2 then list_chop n1 ba.branchnames, []
-    else 
+    else
       (ba.branchnames, []),
        if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in
   let introCaseAssums =
@@ -75,9 +75,9 @@ let elimHypThen tac id gl =
   elimination_then tac ([],[]) (mkVar id) gl
 
 let rec general_decompose_on_hyp recognizer =
-  ifOnHyp recognizer (general_decompose recognizer) (fun _ -> tclIDTAC)
+  ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> tclIDTAC)
 
-and general_decompose recognizer id =
+and general_decompose_aux recognizer id =
   elimHypThen
     (introElimAssumsThen
        (fun bas ->
@@ -93,12 +93,12 @@ and general_decompose recognizer id =
 let tmphyp_name = id_of_string "_TmpHyp"
 let up_to_delta = ref false (* true *)
 
-let general_decompose recognizer c gl = 
-  let typc = pf_type_of gl c in  
-  tclTHENSV (cut typc) 
+let general_decompose recognizer c gl =
+  let typc = pf_type_of gl c in
+  tclTHENSV (cut typc)
     [| tclTHEN (intro_using tmphyp_name)
-         (onLastHyp
-	    (ifOnHyp recognizer (general_decompose recognizer)
+         (onLastHypId
+	    (ifOnHyp recognizer (general_decompose_aux recognizer)
 	      (fun id -> clear [id])));
        exact_no_check c |] gl
 
@@ -110,7 +110,7 @@ let head_in gls indl t =
       else extract_mrectype t
     in List.mem ity indl
   with Not_found -> false
-       
+
 let inductive_of = function
   | IndRef ity -> ity
   | r ->
@@ -118,34 +118,34 @@ let inductive_of = function
         (Printer.pr_global r ++ str " is not an inductive type.")
 
 let decompose_these c l gls =
-  let indl = (*List.map inductive_of*) l in 
+  let indl = (*List.map inductive_of*) l in
   general_decompose (fun (_,t) -> head_in gls indl t) c gls
 
 let decompose_nonrec c gls =
-  general_decompose 
+  general_decompose
     (fun (_,t) -> is_non_recursive_type t)
     c gls
 
-let decompose_and c gls = 
-  general_decompose 
+let decompose_and c gls =
+  general_decompose
     (fun (_,t) -> is_record t)
     c gls
 
-let decompose_or c gls = 
-  general_decompose 
+let decompose_or c gls =
+  general_decompose
     (fun (_,t) -> is_disjunction t)
     c gls
 
 let inj_open c = (Evd.empty,c)
 
 let h_decompose l c =
-  Refiner.abstract_tactic (TacDecompose (l,inj_open c)) (decompose_these c l)
+  Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
 
 let h_decompose_or c =
-  Refiner.abstract_tactic (TacDecomposeOr (inj_open c)) (decompose_or c)
+  Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c)
 
 let h_decompose_and c =
-  Refiner.abstract_tactic (TacDecomposeAnd (inj_open c)) (decompose_and c)
+  Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c)
 
 (* The tactic Double performs a double induction *)
 
@@ -153,17 +153,17 @@ let simple_elimination c gls =
   simple_elimination_then (fun _ -> tclIDTAC) c gls
 
 let induction_trailer abs_i abs_j bargs =
-  tclTHEN 
+  tclTHEN
     (tclDO (abs_j - abs_i) intro)
-    (onLastHyp
+    (onLastHypId
        (fun id gls ->
 	  let idty = pf_type_of gls (mkVar id) in
 	  let fvty = global_vars (pf_env gls) idty in
 	  let possible_bring_hyps =
-	    (List.tl (nLastHyps (abs_j - abs_i) gls)) @ bargs.assums
+	    (List.tl (nLastDecls (abs_j - abs_i) gls)) @ bargs.assums
           in
 	  let (hyps,_) =
-            List.fold_left 
+            List.fold_left
 	      (fun (bring_ids,leave_ids) (cid,_,cidty as d) ->
                  if not (List.mem cid leave_ids)
                  then (d::bring_ids,leave_ids)
@@ -172,7 +172,7 @@ let induction_trailer abs_i abs_j bargs =
 	  in
           let ids = List.rev (ids_of_named_context hyps) in
 	  (tclTHENSEQ
-            [bring_hyps hyps; tclTRY (clear ids); 
+            [bring_hyps hyps; tclTRY (clear ids);
 	     simple_elimination (mkVar id)])
           gls))
 
@@ -184,7 +184,7 @@ let double_ind h1 h2 gls =
     if abs_i > abs_j then (abs_j,abs_i) else
       error "Both hypotheses are the same." in
   (tclTHEN (tclDO abs_i intro)
-     (onLastHyp
+     (onLastHypId
        	(fun id ->
            elimination_then
              (introElimAssumsThen (induction_trailer abs_i abs_j))
diff --git a/tactics/elim.mli b/tactics/elim.mli
index cbbf2f83..25ae0700 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: elim.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -23,7 +23,7 @@ val introElimAssumsThen :
   (branch_assumptions -> tactic) -> branch_args -> tactic
 
 val introCaseAssumsThen :
-  (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> 
+  (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) ->
     branch_args -> tactic
 
 val general_decompose : (identifier * constr -> bool) -> constr -> tactic
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
new file mode 100644
index 00000000..e3f29fe5
--- /dev/null
+++ b/tactics/elimschemes.ml
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Created by Hugo Herbelin from contents related to inductive schemes
+   initially developed by Christine Paulin (induction schemes), Vincent
+   Siles (decidable equality and boolean equality) and Matthieu Sozeau
+   (combined scheme) in file command.ml, Sep 2009 *)
+
+(* This file builds schemes related to case analysis and recursion schemes *)
+
+open Term
+open Indrec
+open Declarations
+open Typeops
+open Termops
+open Ind_tables
+
+(* Induction/recursion schemes *)
+
+let optimize_non_type_induction_scheme kind dep sort ind =
+  if check_scheme kind ind then
+    (* in case the inductive has a type elimination, generates only one
+       induction scheme, the other ones share the same code with the
+       apropriate type *)
+    let cte = find_scheme kind ind in
+    let c = mkConst cte in
+    let t = type_of_constant (Global.env()) cte in
+    let (mib,mip) = Global.lookup_inductive ind in
+    let npars =
+      (* if a constructor of [ind] contains a recursive call, the scheme
+	 is generalized only wrt recursively uniform parameters *)
+      if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs)
+      then
+	mib.mind_nparams_rec
+      else
+	mib.mind_nparams in
+    snd (weaken_sort_scheme (new_sort_in_family sort) npars c t)
+  else
+    build_induction_scheme (Global.env()) Evd.empty ind dep sort
+
+let build_induction_scheme_in_type dep sort ind =
+  build_induction_scheme (Global.env()) Evd.empty ind dep sort
+
+let rect_scheme_kind_from_type =
+  declare_individual_scheme_object "_rect_nodep"
+    (build_induction_scheme_in_type false InType)
+
+let rect_scheme_kind_from_prop =
+  declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop"
+    (build_induction_scheme_in_type false InType)
+
+let rect_dep_scheme_kind_from_type =
+  declare_individual_scheme_object "_rect" ~aux:"_rect_from_type"
+    (build_induction_scheme_in_type true InType)
+
+let rect_dep_scheme_kind_from_prop =
+  declare_individual_scheme_object "_rect_dep"
+    (build_induction_scheme_in_type true InType)
+
+let ind_scheme_kind_from_type =
+  declare_individual_scheme_object "_ind_nodep"
+  (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InProp)
+
+let ind_scheme_kind_from_prop =
+  declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop"
+  (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InProp)
+
+let ind_dep_scheme_kind_from_type =
+  declare_individual_scheme_object "_ind" ~aux:"_ind_from_type"
+  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp)
+
+let ind_dep_scheme_kind_from_prop =
+  declare_individual_scheme_object "_ind_dep"
+  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InProp)
+
+let rec_scheme_kind_from_type =
+  declare_individual_scheme_object "_rec_nodep"
+  (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet)
+
+let rec_scheme_kind_from_prop =
+  declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop"
+  (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet)
+
+let rec_dep_scheme_kind_from_type =
+  declare_individual_scheme_object "_rec" ~aux:"_rec_from_type"
+  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet)
+
+let rec_dep_scheme_kind_from_prop =
+  declare_individual_scheme_object "_rec_dep"
+  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InSet)
+
+(* Case analysis *)
+
+let build_case_analysis_scheme_in_type dep sort ind =
+  build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort
+
+let case_scheme_kind_from_type =
+  declare_individual_scheme_object "_case_nodep"
+  (build_case_analysis_scheme_in_type false InType)
+
+let case_scheme_kind_from_prop =
+  declare_individual_scheme_object "_case" ~aux:"_case_from_prop"
+  (build_case_analysis_scheme_in_type false InType)
+
+let case_dep_scheme_kind_from_type =
+  declare_individual_scheme_object "_case" ~aux:"_case_from_type"
+  (build_case_analysis_scheme_in_type true InType)
+
+let case_dep_scheme_kind_from_type_in_prop =
+  declare_individual_scheme_object "_casep_dep"
+  (build_case_analysis_scheme_in_type true InProp)
+
+let case_dep_scheme_kind_from_prop =
+  declare_individual_scheme_object "_case_dep"
+  (build_case_analysis_scheme_in_type true InType)
+
+let case_dep_scheme_kind_from_prop_in_prop =
+  declare_individual_scheme_object "_casep"
+  (build_case_analysis_scheme_in_type true InProp)
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
new file mode 100644
index 00000000..fecf3e60
--- /dev/null
+++ b/tactics/elimschemes.mli
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Ind_tables
+
+(* Induction/recursion schemes *)
+
+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_dep_scheme_kind_from_type : individual scheme_kind
+val ind_dep_scheme_kind_from_type : individual scheme_kind
+val rec_dep_scheme_kind_from_type : individual scheme_kind
+
+
+(* Case analysis schemes *)
+
+val case_scheme_kind_from_type : individual scheme_kind
+val case_scheme_kind_from_prop : individual scheme_kind
+val case_dep_scheme_kind_from_type : individual scheme_kind
+val case_dep_scheme_kind_from_type_in_prop : individual scheme_kind
+val case_dep_scheme_kind_from_prop : individual scheme_kind
+val case_dep_scheme_kind_from_prop_in_prop : individual scheme_kind
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
index 41f85fa3..0d1699b1 100644
--- a/tactics/eqdecide.ml4
+++ b/tactics/eqdecide.ml4
@@ -14,11 +14,11 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eqdecide.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
-open Nameops
+open Namegen
 open Term
 open Declarations
 open Tactics
@@ -49,41 +49,41 @@ open Coqlib
       then analyse one by one the corresponding pairs of arguments.
       If they are equal, rewrite one into the other. If they are
       not, derive a contradiction from the injectiveness of the
-      constructor. 
-   4. Once all the arguments have been rewritten, solve the remaining half 
+      constructor.
+   4. Once all the arguments have been rewritten, solve the remaining half
       of the disjunction by reflexivity.
 
    Eduardo Gimenez (30/3/98).
 *)
 
-let clear_last = (tclLAST_HYP (fun c -> (clear [destVar c])))
+let clear_last = (onLastHyp (fun c -> (clear [destVar c])))
 
-let choose_eq eqonleft = 
+let choose_eq eqonleft =
   if eqonleft then h_simplest_left else h_simplest_right
 let choose_noteq eqonleft =
   if eqonleft then h_simplest_right else h_simplest_left
 
-let mkBranches c1 c2 = 
+let mkBranches c1 c2 =
   tclTHENSEQ
     [generalize [c2];
      h_simplest_elim c1;
      intros;
-     tclLAST_HYP h_simplest_case;
+     onLastHyp h_simplest_case;
      clear_last;
      intros]
 
-let solveNoteqBranch side = 
+let solveNoteqBranch side =
   tclTHEN (choose_noteq side)
-    (tclTHEN (intro_force true)
-      (onLastHyp (fun id -> Extratactics.h_discrHyp id)))
+    (tclTHEN introf
+      (onLastHypId (fun id -> Extratactics.h_discrHyp id)))
 
 let h_solveNoteqBranch side =
-  Refiner.abstract_extended_tactic "solveNoteqBranch" [] 
+  Refiner.abstract_extended_tactic "solveNoteqBranch" []
     (solveNoteqBranch side)
 
 (* Constructs the type {c1=c2}+{~c1=c2} *)
 
-let mkDecideEqGoal eqonleft op rectype c1 c2 g = 
+let mkDecideEqGoal eqonleft op rectype c1 c2 g =
   let equality    = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in
   let disequality = mkApp(build_coq_not (), [|equality|]) in
   if eqonleft then mkApp(op, [|equality; disequality |])
@@ -92,24 +92,24 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 g =
 
 (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
 
-let mkGenDecideEqGoal rectype g = 
-  let hypnames = pf_ids_of_hyps g in 
+let mkGenDecideEqGoal rectype g =
+  let hypnames = pf_ids_of_hyps g in
   let xname    = next_ident_away (id_of_string "x") hypnames
   and yname    = next_ident_away (id_of_string "y") hypnames in
-  (mkNamedProd xname rectype 
-     (mkNamedProd yname rectype 
+  (mkNamedProd xname rectype
+     (mkNamedProd yname rectype
         (mkDecideEqGoal true (build_coq_sumbool ())
           rectype (mkVar xname) (mkVar yname) g)))
 
-let eqCase tac = 
-  (tclTHEN intro  
-  (tclTHEN (tclLAST_HYP Equality.rewriteLR)
-  (tclTHEN clear_last 
+let eqCase tac =
+  (tclTHEN intro
+  (tclTHEN (onLastHyp Equality.rewriteLR)
+  (tclTHEN clear_last
   tac)))
 
 let diseqCase eqonleft =
   let diseq  = id_of_string "diseq" in
-  let absurd = id_of_string "absurd" in 
+  let absurd = id_of_string "absurd" in
   (tclTHEN (intro_using diseq)
   (tclTHEN (choose_noteq eqonleft)
   (tclTHEN  red_in_concl
@@ -118,11 +118,11 @@ let diseqCase eqonleft =
   (tclTHEN  (Extratactics.h_injHyp absurd)
             (full_trivial [])))))))
 
-let solveArg eqonleft op a1 a2 tac g = 
+let solveArg eqonleft op a1 a2 tac g =
   let rectype = pf_type_of g a1 in
   let decide  = mkDecideEqGoal eqonleft op rectype a1 a2 g in
-  let subtacs = 
-    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] 
+  let subtacs =
+    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto]
     else [diseqCase eqonleft;eqCase tac;default_auto] in
   (tclTHENS (h_elim_type decide) subtacs) g
 
@@ -133,8 +133,8 @@ let solveEqBranch rectype g =
     let nparams   = mib.mind_nparams in
     let getargs l = list_skipn nparams (snd (decompose_app l)) in
     let rargs   = getargs rhs
-    and largs   = getargs lhs in 
-    List.fold_right2 
+    and largs   = getargs lhs in
+    List.fold_right2
       (solveArg eqonleft op) largs rargs
       (tclTHEN (choose_eq eqonleft) h_reflexivity) g
   with PatternMatchingFailure -> error "Unexpected conclusion!"
@@ -163,20 +163,20 @@ let decideGralEquality g =
 
 let decideEqualityGoal = tclTHEN intros decideGralEquality
 
-let decideEquality c1 c2 g = 
-  let rectype = (pf_type_of g c1) in     
-  let decide  = mkGenDecideEqGoal rectype g in  
+let decideEquality c1 c2 g =
+  let rectype = (pf_type_of g c1) in
+  let decide  = mkGenDecideEqGoal rectype g in
   (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g
 
 
 (* The tactic Compare *)
 
-let compare c1 c2 g = 
+let compare c1 c2 g =
   let rectype = pf_type_of g c1 in
-  let decide  = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in  
-  (tclTHENS (cut decide) 
-            [(tclTHEN  intro 
-             (tclTHEN (tclLAST_HYP simplest_case)
+  let decide  = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in
+  (tclTHENS (cut decide)
+            [(tclTHEN  intro
+             (tclTHEN (onLastHyp simplest_case)
                        clear_last));
              decideEquality c1 c2]) g
 
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
new file mode 100644
index 00000000..236eff72
--- /dev/null
+++ b/tactics/eqschemes.ml
@@ -0,0 +1,741 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* File created by Hugo Herbelin, Nov 2009 *)
+
+(* This file builds schemes related to equality inductive types,
+   especially for dependent rewrite, rewriting on arbitrary equality
+   types and congruence on arbitrary equality types *)
+
+(* However, the choices made lack uniformity, as we have to make a
+   compromise between several constraints and ideal requirements:
+
+   - Having the extended schemes working conservatively over the
+     existing non-dependent schemes eq_rect and eq_rect_r. There is in
+     particular a problem with the dependent rewriting schemes in
+     hypotheses for which the inductive types cannot be in last
+     position of the scheme as it is the general rule in Coq. This has
+     an effect on the order of generated goals (side-conditions of the
+     lemma after or before the main goal). The non-dependent case can be
+     fixed but to the price of a lost of uniformity wrt side-conditions
+     in the dependent and non-dependent cases.
+
+   - Having schemes general enough to support non-symmetric equality
+     type like eq_true.
+
+   - Having schemes that avoid introducing beta-expansions blocked by
+     "match" so as to please the guard condition, but this introduces
+     some tricky things involving involutivity of symmetry that I
+     don't how to avoid. The result below is a compromise with
+     dependent left-to-right rewriting in conclusion (l2r_dep) using
+     the tricky involutivity of symmetry and dependent left-to-right
+     rewriting in hypotheses (r2l_forward_dep), that one wants to be
+     used for non-symmetric equality and that introduces blocked
+     beta-expansions.
+
+   One may wonder whether these extensions are worth to be done
+   regarding the price we have to pay and regarding the rare
+   situations where they are needed. However, I believe it meets a 
+   natural expectation of the user.
+*)
+
+open Util
+open Names
+open Term
+open Declarations
+open Environ
+open Inductive
+open Termops
+open Namegen
+open Inductiveops
+open Ind_tables
+open Indrec
+
+let hid = id_of_string "H"
+let xid = id_of_string "X"
+let default_id_of_sort = function InProp | InSet -> hid | InType -> xid
+let fresh env id = next_global_ident_away id []
+
+let build_dependent_inductive ind (mib,mip) =
+  let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  applist
+    (mkInd ind,
+       extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt
+       @ extended_rel_list 0 realargs)
+
+let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn ~init:c s
+let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn ~init:c s
+let my_it_mkLambda_or_LetIn_name s c =
+  it_mkLambda_or_LetIn_name (Global.env()) c s
+
+let get_coq_eq () =
+  try
+    let eq = Libnames.destIndRef Coqlib.glob_eq in
+    let _ = Global.lookup_inductive eq in
+    (* Do not force the lazy if they are not defined *)
+    mkInd eq, Coqlib.build_coq_eq_refl ()
+  with Not_found ->
+    error "eq not found."
+
+(**********************************************************************)
+(* Check if an inductive type [ind] has the form                      *)
+(*                                                                    *)
+(*   I q1..qm,p1..pn a1..an with one constructor                      *)
+(*   C : I q1..qm,p1..pn p1..pn                                       *)
+(*                                                                    *)
+(* in which case, a symmetry lemma is definable                       *)
+(**********************************************************************)
+
+let get_sym_eq_data env ind =
+  let (mib,mip as specif) = lookup_mind_specif env ind in
+  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+    error "Not an inductive type with a single constructor.";
+  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  if List.exists (fun (_,b,_) -> b <> None) realsign then
+    error "Inductive equalities with local definitions in arity not supported.";
+  let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
+  let _,constrargs = decompose_app ccl in
+  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+    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
+    error "Constructors arguments must repeat the parameters.";
+  let _,params2 = list_chop (mib.mind_nparams-mip.mind_nrealargs) params in
+  let paramsctxt1,_ =
+    list_chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in
+  if params2 <> constrargs then
+    error "Constructors arguments must repeat the parameters.";
+  (* nrealargs_ctxt and nrealargs are the same here *)
+  (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1)
+
+(**********************************************************************)
+(* Check if an inductive type [ind] has the form                      *)
+(*                                                                    *)
+(*   I q1..qm a1..an with one constructor                             *)
+(*   C : I q1..qm b1..bn                                              *)
+(*                                                                    *)
+(* in which case it expresses the equalities ai=bi, but not in a way  *)
+(* such that symmetry is a priori definable                           *)
+(**********************************************************************)
+
+let get_non_sym_eq_data env ind =
+  let (mib,mip as specif) = lookup_mind_specif env ind in
+  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+    error "Not an inductive type with a single constructor.";
+  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  if List.exists (fun (_,b,_) -> b <> None) realsign then
+    error "Inductive equalities with local definitions in arity not supported";
+  let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
+  let _,constrargs = decompose_app ccl in
+  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+    error "Constructor must have no arguments";
+  let _,constrargs = list_chop mib.mind_nparams constrargs in
+  (specif,constrargs,realsign,mip.mind_nrealargs)
+
+(**********************************************************************)
+(* Build the symmetry lemma associated to an inductive type           *)
+(* I q1..qm,p1..pn a1..an with one constructor                        *)
+(* C : I q1..qm,p1..pn p1..pn                                         *)
+(*                                                                    *)
+(* sym := fun q1..qn p1..pn a1..an (H:I q1..qm p1..pn a1..an) =>      *)
+(*        match H in I _.._ a1..an return I q1..qm a1..an p1..pn with *)
+(*            C => C                                                  *)
+(*        end                                                         *)
+(*      : forall q1..qm p1..pn a1..an I q1..qm p1..pn a1..an ->       *)
+(*          I q1..qm a1..an p1..pn                                    *)
+(*                                                                    *)
+(**********************************************************************)
+
+let build_sym_scheme env ind =
+  let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
+    get_sym_eq_data env ind in
+  let cstr n =
+    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+  let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
+  let applied_ind = build_dependent_inductive ind specif in
+  let realsign_ind =
+    name_context env ((Name varH,None,applied_ind)::realsign) in
+  let ci = make_case_info (Global.env()) ind RegularStyle in
+  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  (my_it_mkLambda_or_LetIn_name realsign_ind
+  (mkCase (ci,
+     my_it_mkLambda_or_LetIn_name
+       (lift_rel_context (nrealargs+1) realsign_ind)
+       (mkApp (mkInd ind,Array.concat
+	  [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+	   rel_vect 1 nrealargs;
+	   rel_vect (2*nrealargs+2) nrealargs])),
+     mkRel 1 (* varH *),
+       [|cstr (nrealargs+1)|]))))
+
+let sym_scheme_kind =
+  declare_individual_scheme_object "_sym"
+  (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind)
+
+(**********************************************************************)
+(* Build the involutivity of symmetry for an inductive type           *)
+(* I q1..qm,p1..pn a1..an with one constructor                        *)
+(* C : I q1..qm,p1..pn p1..pn                                         *)
+(*                                                                    *)
+(* inv := fun q1..qn p1..pn a1..an (H:I q1..qm p1..pn a1..an) =>      *)
+(*        match H in I _.._ a1..an return                             *)
+(*          sym q1..qm p1..pn a1..an (sym q1..qm a1..an p1..pn H) = H *)
+(*        with                                                        *)
+(*          C => refl_equal C                                         *)
+(*        end                                                         *)
+(*      : forall q1..qm p1..pn a1..an (H:I q1..qm a1..an p1..pn),     *)
+(*          sym q1..qm p1..pn a1..an (sym q1..qm a1..an p1..pn H) = H *)
+(*                                                                    *)
+(**********************************************************************)
+
+let build_sym_involutive_scheme env ind =
+  let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
+    get_sym_eq_data env ind in
+  let sym = mkConst (find_scheme sym_scheme_kind ind) in
+  let (eq,eqrefl) = get_coq_eq () in
+  let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in
+  let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
+  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind_C =
+    mkApp
+      (mkInd ind, Array.append
+         (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt)
+         (rel_vect (nrealargs+1) nrealargs)) in
+  let realsign_ind =
+    name_context env ((Name varH,None,applied_ind)::realsign) in
+  let ci = make_case_info (Global.env()) ind RegularStyle in
+  (my_it_mkLambda_or_LetIn paramsctxt
+  (my_it_mkLambda_or_LetIn_name realsign_ind
+  (mkCase (ci,
+     my_it_mkLambda_or_LetIn_name
+       (lift_rel_context (nrealargs+1) realsign_ind)
+       (mkApp (eq,[|
+	 mkApp
+	   (mkInd ind, Array.concat
+	     [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+	      rel_vect (2*nrealargs+2) nrealargs;
+	      rel_vect 1 nrealargs]);
+         mkApp (sym,Array.concat
+	   [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+            rel_vect 1 nrealargs;
+            rel_vect (2*nrealargs+2) nrealargs;
+            [|mkApp (sym,Array.concat
+	      [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+	       rel_vect (2*nrealargs+2) nrealargs;
+	       rel_vect 1 nrealargs;
+	       [|mkRel 1|]])|]]);
+	 mkRel 1|])),
+     mkRel 1 (* varH *),
+       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
+
+let sym_involutive_scheme_kind =
+  declare_individual_scheme_object "_sym_involutive"
+  (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
+
+(**********************************************************************)
+(* Build the left-to-right rewriting lemma for conclusion associated  *)
+(* to an inductive type I q1..qm,p1..pn a1..an with one constructor   *)
+(* C : I q1..qm,p1..pn p1..pn                                         *)
+(* (symmetric equality in non-dependent and dependent cases)          *)
+(*                                                                    *)
+(* We could have defined the scheme in one match over a generalized   *)
+(* type but this behaves badly wrt the guard condition, so we use     *)
+(* symmetry instead; with commutative-cuts-aware guard condition a    *)
+(* proof in the style of l2r_forward is also possible (see below)     *)
+(*                                                                    *)
+(* rew := fun q1..qm p1..pn a1..an                                    *)
+(*          (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind)         *)
+(*          (HC:P a1..an C)                                           *)
+(*          (H:I q1..qm p1..pn a1..an)  =>                            *)
+(*          match sym_involutive q1..qm p1..pn a1..an H as Heq        *)
+(*                in _ = H return P p1..pn H                          *)
+(*          with                                                      *)
+(*            refl =>                                                 *)
+(*              match sym q1..qm p1..pn a1..an H as H                 *)
+(*                     in I _.._ p1..pn                               *)
+(*                    return P p1..pn (sym q1..qm a1..an p1..pn H)    *)
+(*              with                                                  *)
+(*                C => HC                                             *)
+(*              end                                                   *)
+(*          end                                                       *)
+(*      : forall q1..qn p1..pn a1..an                                 *)
+(*          (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind),        *)
+(*          P a1..an C ->                                             *)
+(*          forall (H:I q1..qm p1..pn a1..an), P p1..pn H             *)
+(*                                                                    *)
+(* where A1..An are the common types of p1..pn and a1..an             *)
+(*                                                                    *)
+(* Note: the symmetry is needed in the dependent case since the       *)
+(* dependency is on the inner arguments (the indices in C) and these  *)
+(* inner arguments need to be visible as parameters to be able to     *)
+(* abstract over them in P.                                           *)
+(**********************************************************************)
+
+(**********************************************************************)
+(* For information, the alternative proof of dependent l2r_rew scheme *)
+(* that would use commutative cuts is the following                   *)
+(*                                                                    *)
+(* rew := fun q1..qm p1..pn a1..an                                    *)
+(*          (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind)         *)
+(*          (HC:P a1..an C)                                           *)
+(*          (H:I q1..qm p1..pn a1..an)  =>                            *)
+(*          match H in I .._.. a1..an return                          *)
+(*             forall p1..pn, I q1..qm p1..pn a1..an -> kind),        *)
+(*             P a1..an C -> P p1..pn H                               *)
+(*          with                                                      *)
+(*            C => fun P HC => HC                                     *)
+(*          end P HC                                                  *)
+(*      : forall q1..qn p1..pn a1..an                                 *)
+(*          (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind),        *)
+(*          P a1..an C ->                                             *)
+(*          forall (H:I q1..qm p1..pn a1..an), P p1..pn H             *)
+(*                                                                    *)
+(**********************************************************************)
+
+let build_l2r_rew_scheme dep env ind kind =
+  let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
+    get_sym_eq_data env ind in
+  let sym = mkConst (find_scheme sym_scheme_kind ind) in
+  let sym_involutive = mkConst (find_scheme sym_involutive_scheme_kind ind) in
+  let (eq,eqrefl) = get_coq_eq () in
+  let cstr n p =
+    mkApp (mkConstruct(ind,1),
+      Array.concat [extended_rel_vect n paramsctxt1;
+                    rel_vect p nrealargs]) in
+  let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
+  let varHC = fresh env (id_of_string "HC") in
+  let varP = fresh env (id_of_string "P") in
+  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind_P =
+    mkApp (mkInd ind, Array.concat
+       [extended_rel_vect (3*nrealargs) paramsctxt1;
+        rel_vect 0 nrealargs;
+        rel_vect nrealargs nrealargs]) in
+  let applied_ind_G =
+    mkApp (mkInd ind, Array.concat
+       [extended_rel_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
+  let realsign_ind_G =
+    name_context env ((Name varH,None,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
+  let applied_sym_G =
+     mkApp(sym,
+       Array.concat [extended_rel_vect (nrealargs*3+4) paramsctxt1;
+                     rel_vect (nrealargs+4) nrealargs;
+                     rel_vect 1 nrealargs;
+		     [|mkRel 1|]]) in
+  let s = mkSort (new_sort_in_family kind) in
+  let ci = make_case_info (Global.env()) ind RegularStyle in
+  let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in
+  let applied_PC =
+    mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign)
+           (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in
+  let applied_PG =
+    mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs)
+           (if dep then [|applied_sym_G|] else [||])) in
+  let applied_PR =
+    mkApp (mkVar varP,Array.append (rel_vect (nrealargs+5) nrealargs)
+           (if dep then [|mkRel 2|] else [||])) in
+  let applied_sym_sym =
+         mkApp (sym,Array.concat
+	   [extended_rel_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;
+	       rel_vect (nrealargs+4) nrealargs;
+	       rel_vect 4 nrealargs;
+	       [|mkRel 2|]])|]]) in
+  let main_body =
+    mkCase (ci,
+      my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG,
+      applied_sym_C 3,
+      [|mkVar varHC|]) in
+  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  (my_it_mkLambda_or_LetIn_name realsign
+  (mkNamedLambda varP
+    (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s)
+  (mkNamedLambda varHC applied_PC
+  (mkNamedLambda varH (lift 2 applied_ind)
+  (if dep then (* we need a coercion *)
+     mkCase (cieq,
+       mkLambda (Name varH,lift 3 applied_ind,
+         mkLambda (Anonymous,
+                   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|]),
+       [|main_body|])
+   else
+     main_body))))))
+
+(**********************************************************************)
+(* Build the left-to-right rewriting lemma for hypotheses associated  *)
+(* to an inductive type I q1..qm,p1..pn a1..an with one constructor   *)
+(* C : I q1..qm,p1..pn p1..pn                                         *)
+(* (symmetric equality in non dependent and dependent cases)          *)
+(*                                                                    *)
+(* rew := fun q1..qm p1..pn a1..an (H:I q1..qm p1..pn a1..an)         *)
+(*          match H in I _.._ a1..an                                  *)
+(*                 return forall                                      *)
+(*                  (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *)
+(*                  (HC:P p1..pn H) =>                                *)
+(*                  P a1..an C                                        *)
+(*          with                                                      *)
+(*             C => fun P HC => HC                                    *)
+(*          end                                                       *)
+(*      : forall q1..qm p1..pn a1..an                                 *)
+(*          (H:I q1..qm p1..pn a1..an)                                *)
+(*          (P:forall p1..pn, I q1..qm p1..pn a1..an ->kind),         *)
+(*          P p1..pn H -> P a1..an C                                  *)
+(*                                                                    *)
+(* Note: the symmetry is needed in the dependent case since the       *)
+(* dependency is on the inner arguments (the indices in C) and these  *)
+(* inner arguments need to be visible as parameters to be able to     *)
+(* abstract over them in P.                                           *)
+(**********************************************************************)
+
+let build_l2r_forward_rew_scheme dep env ind kind =
+  let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
+    get_sym_eq_data env ind in
+  let cstr n p =
+    mkApp (mkConstruct(ind,1),
+      Array.concat [extended_rel_vect n paramsctxt1;
+                    rel_vect p nrealargs]) in
+  let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
+  let varHC = fresh env (id_of_string "HC") in
+  let varP = fresh env (id_of_string "P") in
+  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind_P =
+    mkApp (mkInd ind, Array.concat
+       [extended_rel_vect (4*nrealargs+2) paramsctxt1;
+        rel_vect 0 nrealargs;
+        rel_vect (nrealargs+1) nrealargs]) in
+  let applied_ind_P' =
+    mkApp (mkInd ind, Array.concat
+       [extended_rel_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
+  let realsign_ind_P n aP =
+    name_context env ((Name varH,None,aP)::realsign_P n) in
+  let s = mkSort (new_sort_in_family kind) in
+  let ci = make_case_info (Global.env()) ind RegularStyle in
+  let applied_PC =
+    mkApp (mkVar varP,Array.append
+           (rel_vect (nrealargs*2+3) nrealargs)
+           (if dep then [|mkRel 2|] else [||])) in
+  let applied_PC' =
+    mkApp (mkVar varP,Array.append
+           (rel_vect (nrealargs+2) nrealargs)
+           (if dep then [|cstr (2*nrealargs+2) (nrealargs+2)|]
+	    else [||])) in
+  let applied_PG =
+    mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs)
+           (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in
+  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  (my_it_mkLambda_or_LetIn_name realsign
+  (mkNamedLambda varH applied_ind
+  (mkCase (ci,
+     my_it_mkLambda_or_LetIn_name
+       (lift_rel_context (nrealargs+1) realsign_ind)
+       (mkNamedProd varP
+         (my_it_mkProd_or_LetIn
+	   (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s)
+       (mkNamedProd varHC applied_PC applied_PG)),
+     (mkVar varH),
+     [|mkNamedLambda varP
+        (my_it_mkProd_or_LetIn
+	  (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s)
+      (mkNamedLambda varHC applied_PC'
+	(mkVar varHC))|])))))
+
+(**********************************************************************)
+(* Build the right-to-left rewriting lemma for hypotheses associated  *)
+(* to an inductive type I q1..qm a1..an with one constructor          *)
+(* C : I q1..qm b1..bn                                                *)
+(* (arbitrary equality in non-dependent and dependent cases)          *)
+(*                                                                    *)
+(* rew := fun q1..qm a1..an (H:I q1..qm a1..an)                       *)
+(*          (P:forall a1..an, I q1..qm a1..an -> kind)                *)
+(*          (HC:P a1..an H) =>                                        *)
+(*          match H in I _.._ a1..an return P a1..an H -> P b1..bn C  *)
+(*          with                                                      *)
+(*            C => fun x => x                                         *)
+(*          end HC                                                    *)
+(*      : forall q1..pm a1..an (H:I q1..qm a1..an)                    *)
+(*          (P:forall a1..an, I q1..qm a1..an -> kind),               *)
+(*          P a1..an H -> P b1..bn C                                  *)
+(*                                                                    *)
+(* Note that the dependent elimination here is not a dependency       *)
+(* in the conclusion of the scheme but a dependency in the premise of *)
+(* the scheme. This is unfortunately incompatible with the standard   *)
+(* pattern for schemes in Coq which expects that the eliminated       *)
+(* object is the last premise of the scheme. We then have no choice   *)
+(* than following the more liberal pattern of having the eliminated   *)
+(* object coming before the premises.                                 *)
+(*                                                                    *)
+(* Note that in the non-dependent case, this scheme (up to the order  *)
+(* of premises) generalizes the (backward) l2r scheme above: same     *)
+(* statement but no need for symmetry of the equality.                *)
+(**********************************************************************)
+
+let build_r2l_forward_rew_scheme dep env ind kind =
+  let ((mib,mip as specif),constrargs,realsign,nrealargs) =
+    get_non_sym_eq_data env ind in
+  let cstr n =
+    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+  let constrargs_cstr = constrargs@[cstr 0] in
+  let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
+  let varHC = fresh env (id_of_string "HC") in
+  let varP = fresh env (id_of_string "P") in
+  let applied_ind = build_dependent_inductive ind specif in
+  let realsign_ind =
+    name_context env ((Name varH,None,applied_ind)::realsign) in
+  let s = mkSort (new_sort_in_family kind) in
+  let ci = make_case_info (Global.env()) ind RegularStyle in
+  let applied_PC =
+    applist (mkVar varP,if dep then constrargs_cstr else constrargs) in
+  let applied_PG =
+    mkApp (mkVar varP,
+           if dep then extended_rel_vect 0 realsign_ind
+	   else extended_rel_vect 1 realsign) in
+  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  (my_it_mkLambda_or_LetIn_name realsign_ind
+  (mkNamedLambda varP
+    (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1)
+                             (if dep then realsign_ind else realsign)) s)
+  (mkNamedLambda varHC (lift 1 applied_PG)
+  (mkApp
+    (mkCase (ci,
+       my_it_mkLambda_or_LetIn_name
+         (lift_rel_context (nrealargs+3) realsign_ind)
+         (mkArrow applied_PG (lift (2*nrealargs+5) applied_PC)),
+       mkRel 3 (* varH *),
+       [|mkLambda
+          (Name varHC,
+	   lift (nrealargs+3) applied_PC,
+	   mkRel 1)|]),
+    [|mkVar varHC|]))))))
+
+(**********************************************************************)
+(* This function "repairs" the non-dependent r2l forward rewriting    *)
+(* scheme by making it comply with the standard pattern of schemes    *)
+(* in Coq. Otherwise said, it turns a scheme of type                  *)
+(*                                                                    *)
+(*  forall q1..pm a1..an, I q1..qm a1..an ->                          *)
+(*  forall (P: forall a1..an, kind),                                  *)
+(*         P a1..an -> P b1..bn                                       *)
+(*                                                                    *)
+(* into a scheme of type                                              *)
+(*                                                                    *)
+(*  forall q1..pm (P:forall a1..an, kind),                            *)
+(*         P a1..an -> forall a1..an, I q1..qm a1..an -> P b1..bn     *)
+(*                                                                    *)
+(**********************************************************************)
+
+let fix_r2l_forward_rew_scheme c =
+  let t = Retyping.get_type_of (Global.env()) Evd.empty c in
+  let ctx,_ = decompose_prod_assum t in
+  match ctx with
+  | hp :: p :: ind :: indargs ->
+      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)
+	      (Reductionops.whd_beta Evd.empty
+		(applist (c,
+	          extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))
+  | _ -> anomaly "Ill-formed non-dependent left-to-right rewriting scheme"
+
+(**********************************************************************)
+(* Build the right-to-left rewriting lemma for conclusion associated  *)
+(* to an inductive type I q1..qm a1..an with one constructor          *)
+(* C : I q1..qm b1..bn                                                *)
+(* (arbitrary equality in non-dependent and dependent case)           *)
+(*                                                                    *)
+(* This is actually the standard case analysis scheme                 *)
+(*                                                                    *)
+(* rew := fun q1..qm a1..an                                           *)
+(*          (P:forall a1..an, I q1..qm a1..an -> kind)                *)
+(*          (H:I q1..qm a1..an)                                       *)
+(*          (HC:P b1..bn C) =>                                        *)
+(*          match H in I _.._ a1..an return P a1..an H with           *)
+(*            C => HC                                                 *)
+(*          end                                                       *)
+(*      : forall q1..pm a1..an                                        *)
+(*          (P:forall a1..an, I q1..qm a1..an -> kind)                *)
+(*          (H:I q1..qm a1..an),                                      *)
+(*          P b1..bn C -> P a1..an H                                  *)
+(**********************************************************************)
+
+let build_r2l_rew_scheme dep env ind k =
+  build_case_analysis_scheme env Evd.empty ind dep k
+
+(**********************************************************************)
+(* Register the rewriting schemes                                     *)
+(**********************************************************************)
+
+(**********************************************************************)
+(* Dependent rewrite from left-to-right in conclusion                 *)
+(* (symmetrical equality type only)                                   *)
+(* Gamma |- P p1..pn H   ==>   Gamma |- P a1..an C                    *)
+(* with H:I p1..pn a1..an in Gamma                                    *)
+(**********************************************************************)
+let rew_l2r_dep_scheme_kind =
+  declare_individual_scheme_object "_rew_r_dep"
+  (fun ind -> build_l2r_rew_scheme true (Global.env()) ind InType)
+
+(**********************************************************************)
+(* Dependent rewrite from right-to-left in conclusion                 *)
+(* Gamma |- P a1..an H   ==>   Gamma |- P b1..bn C                    *)
+(* with H:I a1..an in Gamma (non symmetric case)                      *)
+(* or   H:I b1..bn a1..an in Gamma (symmetric case)                   *)
+(**********************************************************************)
+let rew_r2l_dep_scheme_kind =
+  declare_individual_scheme_object "_rew_dep"
+  (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType)
+
+(**********************************************************************)
+(* Dependent rewrite from right-to-left in hypotheses                 *)
+(* Gamma, P a1..an H |- D   ==>   Gamma, P b1..bn C |- D              *)
+(* with H:I a1..an in Gamma (non symmetric case)                      *)
+(* or   H:I b1..bn a1..an in Gamma (symmetric case)                   *)
+(**********************************************************************)
+let rew_r2l_forward_dep_scheme_kind =
+  declare_individual_scheme_object "_rew_fwd_dep"
+  (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType)
+
+(**********************************************************************)
+(* Dependent rewrite from left-to-right in hypotheses                 *)
+(* (symmetrical equality type only)                                   *)
+(* Gamma, P p1..pn H |- D   ==>   Gamma, P a1..an C |- D              *)
+(* with H:I p1..pn a1..an in Gamma                                    *)
+(**********************************************************************)
+let rew_l2r_forward_dep_scheme_kind =
+  declare_individual_scheme_object "_rew_fwd_r_dep"
+  (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType)
+
+(**********************************************************************)
+(* Non-dependent rewrite from either left-to-right in conclusion or   *)
+(* right-to-left in hypotheses: both l2r_rew and r2l_forward_rew are  *)
+(* potential candidates. However r2l_forward_rew introduces a blocked *)
+(* beta-expansion that blocks in turn the guard condition if this     *)
+(* one does not support commutative cuts while l2r_rew does not       *)
+(* support non symmetrical equalities, so...                          *)
+(**********************************************************************)
+
+(**********************************************************************)
+(* ... we use l2r_rew for the symmetrical case:                       *)
+(**********************************************************************)
+let rew_l2r_scheme_kind =
+  declare_individual_scheme_object "_rew_r"
+  (fun ind -> build_l2r_rew_scheme false (Global.env()) ind InType)
+
+(**********************************************************************)
+(* ... and r2l_forward_rew for the non-symmetrical case, even though  *)
+(* it may break the guard condition. Moreover, its standard form      *)
+(* needs the inductive hypothesis not in last position what breaks    *)
+(* the order of goals and need a fix:                                 *)
+(**********************************************************************)
+let rew_asym_scheme_kind =
+  declare_individual_scheme_object "_rew_r_asym"
+  (fun ind -> fix_r2l_forward_rew_scheme
+      (build_r2l_forward_rew_scheme false (Global.env()) ind InType))
+
+(**********************************************************************)
+(* Non-dependent rewrite from either right-to-left in conclusion or   *)
+(* left-to-right in hypotheses: both r2l_rew and l2r_forward_rew but  *)
+(* since r2l_rew works in the non-symmetric case as well as without   *)
+(* introducing commutative cuts, we adopt it                          *)
+(**********************************************************************)
+let rew_r2l_scheme_kind =
+  declare_individual_scheme_object "_rew"
+  (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType)
+
+(* End of rewriting schemes *)
+
+(**********************************************************************)
+(* Build the congruence lemma associated to an inductive type         *)
+(* I p1..pn a with one constructor C : I q1..qn b                     *)
+(*                                                                    *)
+(* congr := fun p1..pn (B:Type) (f:A->B) a (H:I p1..pn a) =>          *)
+(*          match H in I _.._ a' return f b = f a' with               *)
+(*            C => eq_refl (f b)                                      *)
+(*          end                                                       *)
+(*       : forall p1..pn (B:Type) (f:A->B) a, I p1..pn a -> f b = f a *)
+(*                                                                    *)
+(* where A is the common type of a and b                              *)
+(**********************************************************************)
+
+(* TODO: extend it to types with more than one index *)
+
+let build_congr env (eq,refl) ind =
+  let (mib,mip) = lookup_mind_specif env ind in
+  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+    error "Not an inductive type with a single constructor.";
+  if mip.mind_nrealargs <> 1 then
+    error "Expect an inductive type with one predicate parameter.";
+  let i = 1 in
+  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  if List.exists (fun (_,b,_) -> b <> None) realsign then
+    error "Inductive equalities with local definitions in arity not supported.";
+  let env_with_arity = push_rel_context mip.mind_arity_ctxt env in
+  let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in
+  let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
+  let _,constrargs = decompose_app ccl in
+  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+    error "Constructor must have no arguments";
+  let b = List.nth constrargs (i + mib.mind_nparams - 1) in
+  let varB = fresh env (id_of_string "B") in
+  let varH = fresh env (id_of_string "H") in
+  let varf = fresh env (id_of_string "f") in
+  let ci = make_case_info (Global.env()) ind RegularStyle in
+  my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+     (mkNamedLambda varB (new_Type ())
+     (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB))
+     (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign)
+     (mkNamedLambda varH
+        (applist
+           (mkInd ind,
+	    extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @
+	    extended_rel_list 0 realsign))
+     (mkCase (ci,
+       my_it_mkLambda_or_LetIn_name
+	 (lift_rel_context (mip.mind_nrealargs+3) realsign)
+         (mkLambda
+           (Anonymous,
+            applist
+             (mkInd ind,
+	        extended_rel_list (2*mip.mind_nrealargs_ctxt+3)
+		  mib.mind_params_ctxt
+	        @ extended_rel_list 0 realsign),
+            mkApp (eq,
+	      [|mkVar varB;
+                mkApp (mkVar varf, [|lift (2*mip.mind_nrealargs_ctxt+4) b|]);
+		mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))),
+       mkVar varH,
+       [|mkApp (refl,
+          [|mkVar varB;
+	    mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))
+
+let congr_scheme_kind = declare_individual_scheme_object "_congr"
+  (fun ind ->
+    (* May fail if equality is not defined *)
+    build_congr (Global.env()) (get_coq_eq ()) ind)
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
new file mode 100644
index 00000000..96196ac3
--- /dev/null
+++ b/tactics/eqschemes.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(* This file builds schemes relative to equality inductive types *)
+
+open Names
+open Term
+open Environ
+open Ind_tables
+
+(* Builds a left-to-right rewriting scheme for an equality type *)
+
+val rew_l2r_dep_scheme_kind : individual scheme_kind
+val rew_l2r_scheme_kind : individual scheme_kind
+val rew_r2l_forward_dep_scheme_kind : individual scheme_kind
+val rew_l2r_forward_dep_scheme_kind : individual scheme_kind
+val rew_r2l_dep_scheme_kind : individual scheme_kind
+val rew_r2l_scheme_kind : individual scheme_kind
+val rew_asym_scheme_kind : individual scheme_kind
+
+val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
+val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
+val build_r2l_forward_rew_scheme :
+  bool -> env -> inductive -> sorts_family -> constr
+val build_l2r_forward_rew_scheme :
+  bool -> env -> inductive -> sorts_family -> constr
+
+(* Builds a symmetry scheme for a symmetrical equality type *)
+
+val build_sym_scheme : env -> inductive -> constr
+val sym_scheme_kind : individual scheme_kind
+
+val build_sym_involutive_scheme : env -> inductive -> constr
+val sym_involutive_scheme_kind : individual scheme_kind
+
+(* Builds a congruence scheme for an equality type *)
+
+val congr_scheme_kind : individual scheme_kind
+val build_congr : env -> constr * constr -> inductive -> constr
diff --git a/tactics/equality.ml b/tactics/equality.ml
index bf199379..6522361e 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: equality.ml 12886 2010-03-27 14:22:00Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,6 +15,7 @@ open Nameops
 open Univ
 open Term
 open Termops
+open Namegen
 open Inductive
 open Inductiveops
 open Environ
@@ -43,9 +44,36 @@ open Printer
 open Clenv
 open Clenvtac
 open Evd
+open Ind_tables
+open Eqschemes
+
+(* Options *)
+
+let discriminate_introduction = ref true
+
+let discr_do_intro () =
+  !discriminate_introduction && Flags.version_strictly_greater Flags.V8_2
+
+open Goptions
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic introduction of hypotheses by discriminate";
+      optkey   = ["Discriminate";"Introduction"];
+      optread  = (fun () -> !discriminate_introduction);
+      optwrite = (:=) discriminate_introduction }
 
 (* Rewriting tactics *)
 
+type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
+
+type orientation = bool
+
+type conditions =
+  | Naive (* Only try the first occurence of the lemma (default) *)
+  | FirstSolved (* Use the first match whose side-conditions are solved *)
+  | AllMatches (* Rewrite all matches whose side-conditions are solved *)
+
 (* Warning : rewriting from left to right only works
    if there exists in the context a theorem named <eqname>_<suffsort>_r
    with type (A:<sort>)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y).
@@ -54,161 +82,264 @@ open Evd
    -- Eduardo (19/8/97)
 *)
 
+let rewrite_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly = true;
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.resolve_evars = true;
+  Unification.use_evars_pattern_unification = true;
+}
+
+let side_tac tac sidetac =
+  match sidetac with
+  | None -> tac
+  | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac
+
+let instantiate_lemma_all env sigma gl c ty l l2r concl =
+  let eqclause = Clenv.make_clenv_binding { gl with sigma = sigma } (c,ty) l in
+  let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
+  let rec split_last_two = function
+      | [c1;c2] -> [],(c1, c2)
+      | x::y::z ->
+	  let l,res = split_last_two (y::z) in x::l, res
+      | _ -> error "The term provided is not an applied relation." in
+  let others,(c1,c2) = split_last_two args in
+  let try_occ (evd', c') =
+    let cl' = {eqclause with evd = evd'} in
+    let mvs = clenv_dependent false cl' in
+      clenv_pose_metas_as_evars cl' mvs
+  in
+  let occs =
+    Unification.w_unify_to_subterm_all ~flags:rewrite_unif_flags env
+      ((if l2r then c1 else c2),concl) eqclause.evd
+  in List.map try_occ occs
+
+let instantiate_lemma env sigma gl c ty l l2r concl =
+  let gl = { gl with sigma = sigma } in
+  let ct = pf_type_of gl c in
+  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
+  let eqclause = Clenv.make_clenv_binding gl (c,t) l in
+   [eqclause]
+
+let rewrite_elim with_evars c e ?(allow_K=true) =
+  general_elim_clause_gen (elimination_clause_scheme with_evars allow_K) c e
+
+let rewrite_elim_in with_evars id c e =
+  general_elim_clause_gen (elimination_in_clause_scheme with_evars id) c e
+
 (* Ad hoc asymmetric general_elim_clause *)
-let general_elim_clause with_evars cls sigma c l elim = 
-  try 
+let general_elim_clause with_evars cls rew elim =
+  try
     (match cls with
       | None ->
-	  (* was tclWEAK_PROGRESS which only fails for tactics generating one 
+	  (* was tclWEAK_PROGRESS which only fails for tactics generating one
              subgoal and did not fail for useless conditional rewritings generating
              an extra condition *)
-	  tclNOTSAMEGOAL (tclTHEN (Refiner.tclEVARS sigma)
-			     (general_elim with_evars (c,l) elim ~allow_K:false))
-      | Some id ->
-	  tclTHEN (Refiner.tclEVARS sigma) (general_elim_in with_evars id (c,l) elim))
+	  tclNOTSAMEGOAL (rewrite_elim with_evars rew elim ~allow_K:false)
+      | Some id -> rewrite_elim_in with_evars id rew elim)
   with Pretype_errors.PretypeError (env,
 				   (Pretype_errors.NoOccurrenceFound (c', _))) ->
     raise (Pretype_errors.PretypeError
 	      (env, (Pretype_errors.NoOccurrenceFound (c', cls))))
-      
-(* The next function decides in particular whether to try a regular 
-  rewrite or a setoid rewrite. 
-  Approach is to break everything, if [eq] appears in head position 
-  then regular rewrite else try setoid rewrite. 
-  If occurrences are set, use setoid_rewrite.
-*)
 
-let general_setoid_rewrite_clause = ref (fun _ -> assert false)
-let register_general_setoid_rewrite_clause = (:=) general_setoid_rewrite_clause
+let general_elim_clause with_evars tac cls sigma c t l l2r elim gl =
+  let all, firstonly, tac =
+    match tac with
+    | None -> false, false, None
+    | Some (tac, Naive) -> false, false, Some tac
+    | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac)
+    | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac)
+  in
+  let cs =
+    (if not all then instantiate_lemma else instantiate_lemma_all)
+      (pf_env gl) sigma gl c t l l2r
+      (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id)
+  in
+  let try_clause c =
+    side_tac (tclTHEN (Refiner.tclEVARS c.evd) (general_elim_clause with_evars cls c elim)) tac
+  in
+    if firstonly then
+      tclFIRST (List.map try_clause cs) gl
+    else tclMAP try_clause cs gl
+
+(* The next function decides in particular whether to try a regular
+  rewrite or a generalized rewrite.
+  Approach is to break everything, if [eq] appears in head position
+  then regular rewrite else try general rewrite.
+  If occurrences are set, use general rewrite.
+*)
 
-let is_applied_setoid_relation = ref (fun _ -> false)
-let register_is_applied_setoid_relation = (:=) is_applied_setoid_relation
+let general_rewrite_clause = ref (fun _ -> assert false)
+let register_general_rewrite_clause = (:=) general_rewrite_clause
 
-let is_applied_relation t =
-  match kind_of_term t with
-  | App (c, args) when Array.length args >= 2 -> true
-  | _ -> false
+let is_applied_rewrite_relation = ref (fun _ _ _ _ -> None)
+let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation
 
 (* find_elim determines which elimination principle is necessary to
    eliminate lbeq on sort_of_gl. *)
 
-let find_elim hdcncl lft2rgt cls gl =
-  let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in
-  let hdcncls = string_of_inductive hdcncl ^ suffix in 
-  let rwr_thm = if lft2rgt = (cls = None) then hdcncls^"_r" else hdcncls in
-  try pf_global gl (id_of_string rwr_thm)
-  with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".")
-
-let leibniz_rewrite_ebindings_clause cls lft2rgt sigma c l with_evars gl hdcncl =
-  let elim = find_elim hdcncl lft2rgt cls gl in
-  general_elim_clause with_evars cls sigma c l (elim,NoBindings) gl
+let find_elim hdcncl lft2rgt dep cls args gl =
+  let inccl = (cls = None) in
+  if (hdcncl = constr_of_reference (Coqlib.glob_eq) ||
+      hdcncl = constr_of_reference (Coqlib.glob_jmeq) &&
+      pf_conv_x gl (List.nth args 0) (List.nth args 2)) && not dep
+    || Flags.version_less_or_equal Flags.V8_2
+  then
+    (* use eq_rect, eq_rect_r, JMeq_rect, etc for compatibility *)
+    let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in
+    let hdcncls = string_of_inductive hdcncl ^ suffix in
+    let rwr_thm = if lft2rgt = Some (cls=None) then hdcncls^"_r" else hdcncls in
+    try pf_global gl (id_of_string rwr_thm)
+    with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".")
+  else
+  let scheme_name = match dep, lft2rgt, inccl with
+    (* Non dependent case with symmetric equality *)
+    | false, Some true, true | false, Some false, false -> rew_l2r_scheme_kind
+    | false, Some false, true | false, Some true, false -> rew_r2l_scheme_kind
+    (* Dependent case with symmetric equality *)
+    | true, Some true, true -> rew_l2r_dep_scheme_kind
+    | true, Some true, false -> rew_l2r_forward_dep_scheme_kind
+    | true, Some false, true -> rew_r2l_dep_scheme_kind
+    | true, Some false, false -> rew_r2l_forward_dep_scheme_kind
+    (* Non dependent case with non-symmetric rewriting lemma *)
+    | false, None, true -> rew_r2l_scheme_kind
+    | false, None, false -> rew_asym_scheme_kind
+    (* Dependent case with non-symmetric rewriting lemma *)
+    | true, None, true -> rew_r2l_dep_scheme_kind
+    | true, None, false -> rew_r2l_forward_dep_scheme_kind
+  in
+  match kind_of_term hdcncl with
+  | Ind ind -> mkConst (find_scheme scheme_name ind)
+  | _ -> assert false
+
+let type_of_clause gl = function
+  | None -> pf_concl gl
+  | Some id -> pf_get_hyp_typ gl id
+
+let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars dep_proof_ok gl hdcncl =
+  let isatomic = isProd (whd_zeta hdcncl) in
+  let dep_fun = if isatomic then dependent else dependent_no_evar in
+  let dep = dep_proof_ok && dep_fun c (type_of_clause gl cls) in
+  let elim = find_elim hdcncl lft2rgt dep cls (snd (decompose_app t)) gl in
+  general_elim_clause with_evars tac cls sigma c t l
+    (match lft2rgt with None -> false | Some b -> b)
+    {elimindex = None; elimbody = (elim,NoBindings)} gl
 
 let adjust_rewriting_direction args lft2rgt =
-  if List.length args = 1 then
+  if List.length args = 1 then begin
     (* equality to a constant, like in eq_true *)
     (* more natural to see -> as the rewriting to the constant *)
-    not lft2rgt
+    if not lft2rgt then
+      error "Rewriting non-symmetric equality not allowed from right-to-left.";
+    None
+  end
   else
     (* other equality *)
-    lft2rgt
+    Some lft2rgt
+
+let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac)
 
-let general_rewrite_ebindings_clause cls lft2rgt occs ((c,l) : open_constr with_bindings) with_evars gl =
+(* Main function for dispatching which kind of rewriting it is about *)
+
+let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
+    ((c,l) : constr with_bindings) with_evars gl =
   if occs <> all_occurrences then (
-    !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl)
+    rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl)
   else
     let env = pf_env gl in
-    let sigma, c' = c in
-    let sigma = Evd.merge sigma (project gl) in
-    let ctype = get_type_of env sigma c' in 
-    let rels, t = decompose_prod (whd_betaiotazeta sigma ctype) in
+    let sigma = project gl in
+    let ctype = get_type_of env sigma c in
+    let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in
       match match_with_equality_type t with
-      | Some (hdcncl,args) -> (* Fast path: direct leibniz rewrite *)
+      | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *)
 	  let lft2rgt = adjust_rewriting_direction args lft2rgt in
-	  leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl
+          leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels)
+	    l with_evars dep_proof_ok gl hdcncl
       | None ->
-	  let env' = List.fold_left (fun env (n,t) -> push_rel (n, None, t) env) env rels in
-	  let _,t' = splay_prod env' sigma t in (* Search for underlying eq *)
-	    match match_with_equality_type t' with
-	    | Some (hdcncl,args) -> (* Maybe a setoid relation with eq inside *)
-		let lft2rgt = adjust_rewriting_direction args lft2rgt in
-		if l = NoBindings && !is_applied_setoid_relation t then
-		  !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl
-		else
-		  (try leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl
-		    with e -> 
-		      try !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl
-		      with _ -> raise e)
-	    | None -> (* Can't be leibniz, try setoid *)
-		if l = NoBindings
-		then !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl
-		else error "The term provided does not end with an equation."
-
-let general_rewrite_ebindings = 
+	  try
+	    rewrite_side_tac (!general_rewrite_clause cls
+				 lft2rgt occs (c,l) ~new_goals:[]) tac gl
+	  with e -> (* Try to see if there's an equality hidden *)
+	    let env' = push_rel_context rels env in
+	    let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *)
+	      match match_with_equality_type t' with
+	      | Some (hdcncl,args) ->
+		  let lft2rgt = adjust_rewriting_direction args lft2rgt in
+		    leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c
+		      (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars dep_proof_ok gl hdcncl
+	      | None -> raise e
+		  (* error "The provided term does not end with an equality or a declared rewrite relation." *)
+
+let general_rewrite_ebindings =
   general_rewrite_ebindings_clause None
-let general_rewrite_bindings l2r occs (c,bl) = 
-  general_rewrite_ebindings_clause None l2r occs (inj_open c,inj_ebindings bl)
 
-let general_rewrite l2r occs c =
-  general_rewrite_bindings l2r occs (c,NoBindings) false
+let general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,bl) =
+  general_rewrite_ebindings_clause None l2r occs dep_proof_ok ?tac (c,bl)
+
+let general_rewrite l2r occs dep_proof_ok ?tac c =
+  general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,NoBindings) false
+
+let general_rewrite_ebindings_in l2r occs dep_proof_ok ?tac id =
+  general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac
+
+let general_rewrite_bindings_in l2r occs dep_proof_ok ?tac id (c,bl) =
+  general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,bl)
 
-let general_rewrite_ebindings_in l2r occs id =
-  general_rewrite_ebindings_clause (Some id) l2r occs
-let general_rewrite_bindings_in l2r occs id (c,bl) =
-  general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,inj_ebindings bl)
-let general_rewrite_in l2r occs id c = 
-  general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,NoBindings)
+let general_rewrite_in l2r occs dep_proof_ok ?tac id c =
+  general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,NoBindings)
 
-let general_multi_rewrite l2r with_evars c cl = 
-  let occs_of = on_snd (List.fold_left 
+let general_multi_rewrite l2r with_evars ?tac c cl =
+  let occs_of = on_snd (List.fold_left
     (fun acc ->
       function ArgArg x -> x :: acc | ArgVar _ -> acc)
     [])
   in
-  match cl.onhyps with 
-    | Some l -> 
+  match cl.onhyps with
+    | Some l ->
 	(* If a precise list of locations is given, success is mandatory for
 	   each of these locations. *)
-	let rec do_hyps = function 
+	let rec do_hyps = function
 	  | [] -> tclIDTAC
-	  | ((occs,id),_) :: l -> 
+	  | ((occs,id),_) :: l ->
 	    tclTHENFIRST
-	      (general_rewrite_ebindings_in l2r (occs_of occs) id c with_evars)
+	      (general_rewrite_ebindings_in l2r (occs_of occs) true ?tac id c with_evars)
 	      (do_hyps l)
-	in 
+	in
 	if cl.concl_occs = no_occurrences_expr then do_hyps l else
 	  tclTHENFIRST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) c with_evars)
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars)
 	   (do_hyps l)
-    | None -> 
-	(* Otherwise, if we are told to rewrite in all hypothesis via the 
-           syntax "* |-", we fail iff all the different rewrites fail *) 
-	let rec do_hyps_atleastonce = function 
+    | None ->
+	(* Otherwise, if we are told to rewrite in all hypothesis via the
+           syntax "* |-", we fail iff all the different rewrites fail *)
+	let rec do_hyps_atleastonce = function
 	  | [] -> (fun gl -> error "Nothing to rewrite.")
-	  | id :: l -> 
-	    tclIFTHENTRYELSEMUST 
-	     (general_rewrite_ebindings_in l2r all_occurrences id c with_evars)
+	  | id :: l ->
+	    tclIFTHENTRYELSEMUST
+	     (general_rewrite_ebindings_in l2r all_occurrences true ?tac id c with_evars)
 	     (do_hyps_atleastonce l)
-	in 
-	let do_hyps gl = 
+	in
+	let do_hyps gl =
 	  (* If the term to rewrite uses an hypothesis H, don't rewrite in H *)
-	  let ids = 
-	    let ids_in_c = Environ.global_vars_set (Global.env()) (snd (fst c)) in
+	  let ids =
+	    let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in
 	      Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl)
 	  in do_hyps_atleastonce ids gl
-	in 
+	in
 	if cl.concl_occs = no_occurrences_expr then do_hyps else
-	  tclIFTHENTRYELSEMUST 
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) c with_evars)
+	  tclIFTHENTRYELSEMUST
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars)
 	   do_hyps
 
-let general_multi_multi_rewrite with_evars l cl tac = 
-  let do1 l2r c = 
-    match tac with
-	None -> general_multi_rewrite l2r with_evars c cl
-      | Some tac -> tclTHENSFIRSTn (general_multi_rewrite l2r with_evars c cl)
-	  [|tclIDTAC|] (tclCOMPLETE tac)
-  in
-  let rec doN l2r c = function 
+type delayed_open_constr_with_bindings =
+    env -> evar_map -> evar_map * constr with_bindings
+
+let general_multi_multi_rewrite with_evars l cl tac =
+  let do1 l2r f gl =
+    let sigma,c = f (pf_env gl) (project gl) in
+    Refiner.tclWITHHOLES with_evars
+      (general_multi_rewrite l2r with_evars ?tac c) sigma cl gl in
+  let rec doN l2r c = function
     | Precisely n when n <= 0 -> tclIDTAC
     | Precisely 1 -> do1 l2r c
     | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1)))
@@ -216,62 +347,39 @@ let general_multi_multi_rewrite with_evars l cl tac =
     | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar)
     | UpTo n when n<=0 -> tclIDTAC
     | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1)))
-  in 
+  in
   let rec loop = function
     | [] -> tclIDTAC
     | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l)
   in loop l
 
-(* Conditional rewriting, the success of a rewriting is related 
-   to the resolution of the conditions by a given tactic *)
-
-let conditional_rewrite lft2rgt tac (c,bl) = 
-  tclTHENSFIRSTn
-    (general_rewrite_ebindings lft2rgt all_occurrences (c,bl) false)
-    [|tclIDTAC|] (tclCOMPLETE tac)
-
-let rewriteLR_bindings = general_rewrite_bindings true all_occurrences
-let rewriteRL_bindings = general_rewrite_bindings false all_occurrences
-
-let rewriteLR = general_rewrite true all_occurrences
-let rewriteRL = general_rewrite false all_occurrences
-
-let rewriteLRin_bindings = general_rewrite_bindings_in true all_occurrences
-let rewriteRLin_bindings = general_rewrite_bindings_in false all_occurrences
-
-let conditional_rewrite_in lft2rgt id tac (c,bl) = 
-  tclTHENSFIRSTn
-    (general_rewrite_ebindings_in lft2rgt all_occurrences id (c,bl) false)
-    [|tclIDTAC|] (tclCOMPLETE tac)
-
-let rewriteRL_clause = function
-  | None -> rewriteRL_bindings
-  | Some id -> rewriteRLin_bindings id
+let rewriteLR = general_rewrite true all_occurrences true
+let rewriteRL = general_rewrite false all_occurrences true
 
 (* Replacing tactics *)
 
 (* eq,sym_eq : equality on Type and its symmetry theorem
    c2 c1 : c1 is to be replaced by c2
    unsafe : If true, do not check that c1 and c2 are convertible
-   tac : Used to prove the equality c1 = c2 
+   tac : Used to prove the equality c1 = c2
    gl : goal *)
 
-let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = 
-  let try_prove_eq = 
-    match try_prove_eq_opt with 
+let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
+  let try_prove_eq =
+    match try_prove_eq_opt with
       | None -> tclIDTAC
       | Some tac ->  tclCOMPLETE tac
   in
-  let t1 = pf_apply get_type_of gl c1 
+  let t1 = pf_apply get_type_of gl c1
   and t2 = pf_apply get_type_of gl c2 in
   if unsafe or (pf_conv_x gl t1 t2) then
     let e = build_coq_eq () in
-    let sym = build_coq_sym_eq () in
+    let sym = build_coq_eq_sym () in
     let eq = applist (e, [t1;c1;c2]) in
     tclTHENS (assert_as false None eq)
-      [onLastHyp (fun id -> 
-	tclTHEN 
-	  (tclTRY (general_multi_rewrite false false (inj_open (mkVar id),NoBindings) clause))
+      [onLastHypId (fun id ->
+	tclTHEN
+	  (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
 	  (clear [id]));
        tclFIRST
 	 [assumption;
@@ -281,7 +389,7 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
       ] gl
   else
     error "Terms do not have convertible types."
-  
+
 
 let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl
 
@@ -291,7 +399,7 @@ let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl
 
 let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl
 
-let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = 
+let replace_in_clause_maybe_by c2 c1 cl tac_opt gl =
   multi_replace cl c2 c1 false tac_opt gl
 
 (* End of Eduardo's code. The rest of this file could be improved
@@ -346,8 +454,8 @@ let find_positions env sigma t1 t2 =
     let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in
     let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in
     match (kind_of_term hd1, kind_of_term hd2) with
-  	
-      | Construct sp1, Construct sp2 
+
+      | Construct sp1, Construct sp2
           when List.length args1 = mis_constructor_nargs_env env sp1
             ->
 	  let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in
@@ -365,14 +473,14 @@ let find_positions env sigma t1 t2 =
 	  else []
 
       | _ ->
-	  let t1_0 = applist (hd1,args1) 
+	  let t1_0 = applist (hd1,args1)
           and t2_0 = applist (hd2,args2) in
-          if is_conv env sigma t1_0 t2_0 then 
+          if is_conv env sigma t1_0 t2_0 then
 	    []
           else
 	    let ty1_0 = get_type_of env sigma t1_0 in
 	    let s = get_sort_family_of env sigma ty1_0 in
-	    if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in 
+	    if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in
   try
     (* Rem: to allow injection on proofs objects, just add InProp *)
     Inr (findrec [InSet;InType] [] t1 t2)
@@ -384,7 +492,7 @@ let discriminable env sigma t1 t2 =
     | Inl _ -> true
     | _ -> false
 
-let injectable env sigma t1 t2 = 
+let injectable env sigma t1 t2 =
     match find_positions env sigma t1 t2 with
     | Inl _ | Inr [] -> false
     | Inr _ -> true
@@ -458,7 +566,7 @@ let descend_then sigma env head dirn =
     try find_rectype env sigma (get_type_of env sigma head)
     with Not_found ->
       error "Cannot project on an inductive type derived from a dependency." in
-  let ind,_ = dest_ind_family indf in
+   let ind,_ = dest_ind_family indf in
   let (mib,mip) = lookup_mind_specif env ind in
   let cstr = get_constructors env indf in
   let dirn_nlams = cstr.(dirn-1).cs_nargs in
@@ -499,13 +607,13 @@ let construct_discriminator sigma env dirn c sort =
   let IndType(indf,_) =
     try find_rectype env sigma (get_type_of env sigma c)
     with Not_found ->
-       (* one can find Rel(k) in case of dependent constructors 
-          like T := c : (A:Set)A->T and a discrimination 
+       (* one can find Rel(k) in case of dependent constructors
+          like T := c : (A:Set)A->T and a discrimination
           on (c bool true) = (c bool false)
           CP : changed assert false in a more informative error
        *)
       errorlabstrm "Equality.construct_discriminator"
-	(str "Cannot discriminate on inductive constructors with 
+	(str "Cannot discriminate on inductive constructors with
 		 dependent types.") in
   let (ind,_) = dest_ind_family indf in
   let (mib,mip) = lookup_mind_specif env ind in
@@ -520,7 +628,7 @@ let construct_discriminator sigma env dirn c sort =
     List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in
   let ci = make_case_info env ind RegularStyle in
   mkCase (ci, p, c, Array.of_list brl)
-    
+
 let rec build_discriminator sigma env dirn c sort = function
   | [] -> construct_discriminator sigma env dirn c sort
   | ((sp,cnum),argnum)::l ->
@@ -541,17 +649,17 @@ let rec build_discriminator sigma env dirn c sort = function
 *)
 
 let gen_absurdity id gl =
-  if is_empty_type (clause_type (onHyp id) gl)
+  if is_empty_type (pf_get_hyp_typ gl id)
   then
     simplest_elim (mkVar id) gl
   else
-    errorlabstrm "Equality.gen_absurdity" 
+    errorlabstrm "Equality.gen_absurdity"
       (str "Not the negation of an equality.")
 
 (* Precondition: eq is leibniz equality
- 
+
    returns ((eq_elim t t1 P i t2), absurd_term)
-   where  P=[e:t]discriminator 
+   where  P=[e:t]discriminator
           absurd_term=False
 *)
 
@@ -566,18 +674,17 @@ exception NotDiscriminable
 let eq_baseid = id_of_string "e"
 
 let apply_on_clause (f,t) clause =
-  let sigma = Evd.evars_of clause.evd in
+  let sigma =  clause.evd in
   let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in
-  let argmv = 
+  let argmv =
     (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with
      | Meta mv -> mv
      | _  -> errorlabstrm "" (str "Ill-formed clause applicator.")) in
   clenv_fchain argmv f_clause clause
 
-let discr_positions env sigma (lbeq,(t,t1,t2)) eq_clause cpath dirn sort =
+let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
   let e = next_ident_away eq_baseid (ids_of_context env) in
   let e_env = push_named (e,None,t) env in
-  let eqn = mkApp(lbeq.eq,[|t;t1;t2|]) in
   let discriminator =
     build_discriminator sigma e_env dirn (mkVar e) sort cpath in
   let (pf, absurd_term) = discrimination_pf e (t,t1,t2) discriminator lbeq in
@@ -585,16 +692,16 @@ let discr_positions env sigma (lbeq,(t,t1,t2)) eq_clause cpath dirn sort =
   let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in
   let pf = clenv_value_cast_meta absurd_clause in
   tclTHENS (cut_intro absurd_term)
-    [onLastHyp gen_absurdity; refine pf]
+    [onLastHypId gen_absurdity; refine pf]
 
-let discrEq (lbeq,(t,t1,t2) as u) eq_clause gls =
-  let sigma = Evd.evars_of eq_clause.evd in
+let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls =
+  let sigma = eq_clause.evd in
   let env = pf_env gls in
   match find_positions env sigma t1 t2 with
     | Inr _ ->
 	errorlabstrm "discr" (str"Not a discriminable equality.")
     | Inl (cpath, (_,dirn), _) ->
-	let sort = pf_apply get_type_of gls (pf_concl gls) in 
+	let sort = pf_apply get_type_of gls (pf_concl gls) in
 	discr_positions env sigma u eq_clause cpath dirn sort gls
 
 let onEquality with_evars tac (c,lbindc) gls =
@@ -603,39 +710,43 @@ let onEquality with_evars tac (c,lbindc) gls =
   let eq_clause = make_clenv_binding gls (c,t') lbindc in
   let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in
   let eqn = clenv_type eq_clause' in
-  let eq =
-    try find_eq_data_decompose eqn
-    with PatternMatchingFailure ->
-      errorlabstrm "" (str"No primitive equality found.") in
+  let eq,eq_args = find_this_eq_data_decompose gls eqn in
   tclTHEN
-    (Refiner.tclEVARS (Evd.evars_of eq_clause'.evd)) 
-    (tac eq eq_clause') gls
+    (Refiner.tclEVARS eq_clause'.evd)
+    (tac (eq,eqn,eq_args) eq_clause') gls
 
 let onNegatedEquality with_evars tac gls =
   let ccl = pf_concl gls in
   match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with
   | Prod (_,t,u) when is_empty_type u ->
       tclTHEN introf
-        (onLastHyp (fun id -> 
+        (onLastHypId (fun id ->
           onEquality with_evars tac (mkVar id,NoBindings))) gls
-  | _ -> 
+  | _ ->
       errorlabstrm "" (str "Not a negated primitive equality.")
 
 let discrSimpleClause with_evars = function
   | None -> onNegatedEquality with_evars discrEq
-  | Some ((_,id),_) -> onEquality with_evars discrEq (mkVar id,NoBindings)
+  | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings)
 
 let discr with_evars = onEquality with_evars discrEq
 
-let discrClause with_evars = onClauses (discrSimpleClause with_evars)
+let discrClause with_evars = onClause (discrSimpleClause with_evars)
 
-let discrEverywhere with_evars = 
+let discrEverywhere with_evars =
+(*
   tclORELSE
-    (Tacticals.tryAllClauses
-      (fun cl -> tclCOMPLETE (discrSimpleClause with_evars cl)))
-    (fun gls -> 
+*)
+    (if discr_do_intro () then
+      (tclTHEN
+	(tclREPEAT introf)
+	(Tacticals.tryAllHyps
+          (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings)))))
+     else (* <= 8.2 compat *)
+       Tacticals.tryAllHypsAndConcl (discrSimpleClause with_evars))
+(*    (fun gls ->
        errorlabstrm "DiscrEverywhere" (str"No discriminable equalities."))
-
+*)
 let discr_tac with_evars = function
   | None -> discrEverywhere with_evars
   | Some c -> onInductionArg (discr with_evars) c
@@ -645,8 +756,8 @@ let discrHyp id gls = discrClause false (onHyp id) gls
 
 (* returns the sigma type (sigS, sigT) with the respective
     constructor depending on the sort *)
-(* J.F.: correction du bug #1167 en accord avec Hugo. *) 
-   
+(* J.F.: correction du bug #1167 en accord avec Hugo. *)
+
 let find_sigma_data s = build_sigma_type ()
 
 (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
@@ -699,8 +810,8 @@ let minimal_free_rels_rec env sigma =
   in minimalrec_free_rels_rec Intset.empty
 
 (* [sig_clausal_form siglen ty]
-    
-   Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the 
+
+   Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the
    type of ty), and return:
 
    (1) a pattern, with meta-variables in it for various arguments,
@@ -714,9 +825,9 @@ let minimal_free_rels_rec env sigma =
 
    (4) a typing for each patvar
 
-   WARNING: No checking is done to make sure that the 
+   WARNING: No checking is done to make sure that the
             sigS(or sigT)'s are actually there.
-          - Only homogeneous pairs are built i.e. pairs where all the 
+          - Only homogeneous pairs are built i.e. pairs where all the
    dependencies are of the same sort
 
    [sig_clausal_form] proceed as follows: the default tuple is
@@ -735,7 +846,7 @@ let minimal_free_rels_rec env sigma =
  *)
 
 let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
-  let { intro = exist_term } = find_sigma_data sort_of_ty in 
+  let { intro = exist_term } = find_sigma_data sort_of_ty in
   let evdref = ref (Evd.create_goal_evar_defs sigma) in
   let rec sigrec_clausal_form siglen p_i =
     if siglen = 0 then
@@ -745,17 +856,17 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 	(* the_conv_x had a side-effect on evdref *)
 	dflt
       else
-	error "Cannot solve an unification problem."
+	error "Cannot solve a unification problem."
     else
-      let (a,p_i_minus_1) = match whd_beta_stack (evars_of !evdref) p_i with
+      let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with
 	| (_sigS,[a;p]) -> (a,p)
  	| _ -> anomaly "sig_clausal_form: should be a sigma type" in
       let ev = Evarutil.e_new_evar evdref env a in
       let rty = beta_applist(p_i_minus_1,[ev]) in
       let tuple_tail = sigrec_clausal_form (siglen-1) rty in
       match
-	Evd.existential_opt_value (Evd.evars_of !evdref) 
-	(destEvar ev)
+  	Evd.existential_opt_value !evdref
+ 	  (destEvar ev)
       with
 	| Some w ->
             let w_type = type_of env sigma w in
@@ -766,7 +877,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 	| None -> anomaly "Not enough components to build the dependent tuple"
   in
   let scf = sigrec_clausal_form siglen ty in
-  Evarutil.nf_evar (Evd.evars_of !evdref) scf
+  Evarutil.nf_evar !evdref scf
 
 (* The problem is to build a destructor (a generalization of the
    predecessor) which, when applied to a term made of constructors
@@ -831,7 +942,7 @@ let make_iterated_tuple env sigma dflt (z,zty) =
   let sort_of_zty = get_sort_of env sigma zty in
   let sorted_rels = Sort.list (<) (Intset.elements rels) in
   let (tuple,tuplety) =
-    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels 
+    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels
   in
   assert (closed0 tuplety);
   let n = List.length sorted_rels in
@@ -856,29 +967,29 @@ let build_injector sigma env dflt c cpath =
 
 (*
 let try_delta_expand env sigma t =
-  let whdt = whd_betadeltaiota env sigma t  in 
+  let whdt = whd_betadeltaiota env sigma t  in
   let rec hd_rec c  =
     match kind_of_term c with
       | Construct _ -> whdt
       | App (f,_)  -> hd_rec f
       | Cast (c,_,_) -> hd_rec c
       | _  -> t
-  in 
-  hd_rec whdt 
+  in
+  hd_rec whdt
 *)
 
-(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it 
+(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it
    expands then only when the whdnf has a constructor of an inductive type
    in hd position, otherwise delta expansion is not done *)
 
-let simplify_args env sigma t = 
+let simplify_args env sigma t =
   (* Quick hack to reduce in arguments of eq only *)
   match decompose_app t with
-    | eq, [t;c1;c2] -> applist (eq,[t;nf env sigma c1;nf env sigma c2])
-    | eq, [t1;c1;t2;c2] -> applist (eq,[t1;nf env sigma c1;t2;nf env sigma c2])
+    | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2])
+    | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2])
     | _ -> t
 
-let inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns =
+let inject_at_positions env sigma (eq,_,(t,t1,t2)) eq_clause posns tac =
   let e = next_ident_away eq_baseid (ids_of_context env) in
   let e_env = push_named (e,None,t) env in
   let injectors =
@@ -896,25 +1007,29 @@ let inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns =
       posns in
   if injectors = [] then
     errorlabstrm "Equality.inj" (str "Failed to decompose the equality.");
-  tclMAP
-    (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf])
-    injectors
+  tclTHEN
+    (tclMAP
+      (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf])
+      injectors)
+    (tac (List.length injectors))
 
 exception Not_dep_pair
 
+let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined")
+let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k)
 
-let injEq ipats (eq,(t,t1,t2)) eq_clause =
-  let sigma = Evd.evars_of eq_clause.evd in
+let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause =
+  let sigma = eq_clause.evd in
   let env = eq_clause.env in
   match find_positions env sigma t1 t2 with
     | Inl _ ->
 	errorlabstrm "Inj"
 	  (str"Not a projectable equality but a discriminable one.")
     | Inr [] ->
-	errorlabstrm "Equality.inj" 
+	errorlabstrm "Equality.inj"
 	   (str"Nothing to do, it is an equality between convertible terms.")
     | Inr posns ->
-(* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ?
+(* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ?
 	let t1 = try_delta_expand env sigma t1 in
 	let t2 = try_delta_expand env sigma t2 in
 *)
@@ -922,7 +1037,7 @@ let injEq ipats (eq,(t,t1,t2)) eq_clause =
 (* fetch the informations of the  pair *)
         let ceq = constr_of_global Coqlib.glob_eq in
         let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
-        let eqTypeDest = fst (destApp t) in 
+        let eqTypeDest = fst (destApp t) in
         let _,ar1 = destApp t1 and
             _,ar2 = destApp t2 in
         let ind = destInd ar1.(0) in
@@ -933,27 +1048,26 @@ let injEq ipats (eq,(t,t1,t2)) eq_clause =
 (* and compare the fst arguments of the dep pair *)
         let new_eq_args = [|type_of env sigma (ar1.(3));ar1.(3);ar2.(3)|] in
         if ( (eqTypeDest = sigTconstr()) &&
-             (Ind_tables.check_dec_proof ind=true) &&
+             (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind=true) &&
              (is_conv env sigma (ar1.(2)) (ar2.(2)) = true))
-              then ( 
+              then (
 (* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*)
-              let qidl = qualid_of_reference 
+              let qidl = qualid_of_reference
                 (Ident (dummy_loc,id_of_string "Eqdep_dec")) in
-              Library.require_library [qidl] (Some false); 
+              Library.require_library [qidl] (Some false);
 (* cut with the good equality and prove the requested goal *)
               tclTHENS (cut (mkApp (ceq,new_eq_args)) )
                [tclIDTAC; tclTHEN (apply (
                   mkApp(inj2,
-                        [|ar1.(0);Ind_tables.find_eq_dec_proof ind;
+                        [|ar1.(0);mkConst (find_scheme (!eq_dec_scheme_kind_name()) ind);
                           ar1.(1);ar1.(2);ar1.(3);ar2.(3)|])
                   )) (Auto.trivial [] [])
                 ]
 (* not a dep eq or no decidable type found *)
-            ) else (raise Not_dep_pair) 
+            ) else (raise Not_dep_pair)
         ) with _ ->
-	tclTHEN
-	  (inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns)
-	  (intros_pattern no_move ipats)
+	  inject_at_positions env sigma u eq_clause posns
+	    (fun _ -> intros_pattern no_move ipats)
 
 let inj ipats with_evars = onEquality with_evars (injEq ipats)
 
@@ -964,21 +1078,17 @@ let injClause ipats with_evars = function
 let injConcl gls  = injClause [] false None gls
 let injHyp id gls = injClause [] false (Some (ElimOnIdent (dummy_loc,id))) gls
 
-let decompEqThen ntac (lbeq,(t,t1,t2) as u) clause gls =
-  let sort = pf_apply get_type_of gls (pf_concl gls) in 
-  let sigma = Evd.evars_of clause.evd in
-  let env = pf_env gls in 
+let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause gls =
+  let sort = pf_apply get_type_of gls (pf_concl gls) in
+  let sigma =  clause.evd in
+  let env = pf_env gls in
   match find_positions env sigma t1 t2 with
     | Inl (cpath, (_,dirn), _) ->
 	discr_positions env sigma u clause cpath dirn sort gls
     | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
         ntac 0 gls
     | Inr posns ->
-	tclTHEN
-	  (inject_at_positions env sigma (lbeq,(t,t1,t2)) clause
-	    (List.rev posns))
-	  (ntac (List.length posns))
-	  gls
+	inject_at_positions env sigma u clause (List.rev posns) ntac gls
 
 let dEqThen with_evars ntac = function
   | None -> onNegatedEquality with_evars (decompEqThen ntac)
@@ -986,28 +1096,27 @@ let dEqThen with_evars ntac = function
 
 let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC)
 
-let rewrite_msg = function 
-  | None -> str "passed term is not a primitive equality" 
-  | Some id -> pr_id id ++ str "does not satisfy preconditions "
+let swap_equality_args = function
+  | MonomorphicLeibnizEq (e1,e2) -> [e2;e1]
+  | PolymorphicLeibnizEq (t,e1,e2) -> [t;e2;e1]
+  | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1]
 
 let swap_equands gls eqn =
-  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in 
-  applist(lbeq.eq,[t;e2;e1])
+  let (lbeq,eq_args) = find_eq_data eqn in
+  applist(lbeq.eq,swap_equality_args eq_args)
 
 let swapEquandsInConcl gls =
-  let (lbeq,(t,e1,e2)) = find_eq_data_decompose (pf_concl gls) in
+  let (lbeq,eq_args) = find_eq_data (pf_concl gls) in
   let sym_equal = lbeq.sym in
-  refine (applist(sym_equal,[t;e2;e1;Evarutil.mk_new_meta()])) gls
-
-let swapEquandsInHyp id gls =
-  cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id))
-    (tclTHEN swapEquandsInConcl) gls
+  refine
+    (applist(sym_equal,(swap_equality_args eq_args@[Evarutil.mk_new_meta()])))
+    gls
 
 (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *)
 
 let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
   (* find substitution scheme *)
-  let eq_elim = find_elim lbeq.eq false None gls in
+  let eq_elim = find_elim lbeq.eq (Some false) false None [e1;e2] gls in
   (* build substitution predicate *)
   let p = lambda_create (pf_env gls) (t,body) in
   (* apply substitution scheme *)
@@ -1020,17 +1129,22 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
 
    (existT e1 (existT e2 ... (existT en en+1) ... ))
 
+   of type {x1:T1 & {x2:T2(x1) & ... {xn:Tn(x1..xn-1) & en+1 } } }
+
    and B might contain instances of the ei, we will return the term:
 
-   ([x1:ty(e1)]...[xn:ty(en)]B
-    (projS1 (mkRel 1))
-    (projS1 (projS2 (mkRel 1)))
-    ... etc ...)
+   ([x1:ty1]...[xn+1:tyn+1]B
+    (projT1 (mkRel 1))
+    (projT1 (projT2 (mkRel 1)))
+    ...
+    (projT1 (projT2^n (mkRel 1)))
+    (projT2 (projT2^n (mkRel 1)))
 
-   That is, we will abstract out the terms e1...en+1 as usual, but
+   That is, we will abstract out the terms e1...en+1 of types
+   t1 (=_beta T1), ..., tn+1 (=_beta Tn+1(e1..en)) as usual, but
    will then produce a term in which the abstraction is on a single
    term - the debruijn index [mkRel 1], which will be of the same type
-   as dep_pair.
+   as dep_pair (note that the abstracted body may not be typable!).
 
    ALGORITHM for abstraction:
 
@@ -1041,7 +1155,7 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
 
  *)
 
-let decomp_tuple_term env c t = 
+let decomp_tuple_term env c t =
   let rec decomprec inner_code ex exty =
     try
       let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in
@@ -1054,23 +1168,32 @@ let decomp_tuple_term env c t =
   in
   List.split (decomprec (mkRel 1) c t)
 
-let subst_tuple_term env sigma dep_pair b =
-  let typ = get_type_of env sigma dep_pair in
-  let e_list,proj_list = decomp_tuple_term env dep_pair typ in
+let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
+  let typ = get_type_of env sigma dep_pair1 in
+  (* We rewrite dep_pair1 ... *)
+  let e1_list,proj_list = decomp_tuple_term env dep_pair1 typ in
   let abst_B =
     List.fold_right
-      (fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in
-  beta_applist(abst_B,proj_list)
+      (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in
+  (* ... and use dep_pair2 to compute the expected goal *)
+  let e2_list,_ = decomp_tuple_term env dep_pair2 typ in
+  let pred_body = beta_applist(abst_B,proj_list) in
+  let expected_goal = beta_applist (abst_B,List.map fst e2_list) in
+  (* Simulate now the normalisation treatment made by Logic.mk_refgoals *)
+  let expected_goal = nf_betaiota sigma expected_goal in
+  pred_body,expected_goal
 
-(* Comme "replace" mais decompose les egalites dependantes *)
+(* Like "replace" but decompose dependent equalities *)
 
 exception NothingToRewrite
 
 let cutSubstInConcl_RL eqn gls =
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in
-  let body = pf_apply subst_tuple_term gls e2 (pf_concl gls) in
+  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in
+  let body,expected_goal = pf_apply subst_tuple_term gls e2 e1 (pf_concl gls) in
   if not (dependent (mkRel 1) body) then raise NothingToRewrite;
-  bareRevSubstInConcl lbeq body eq gls
+  tclTHENFIRST
+    (bareRevSubstInConcl lbeq body eq)
+    (convert_concl expected_goal DEFAULTcast) gls
 
 (* |- (P e1)
      BY CutSubstInConcl_LR (eq T e1 e2)
@@ -1085,11 +1208,14 @@ let cutSubstInConcl_LR eqn gls =
 let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL
 
 let cutSubstInHyp_LR eqn id gls =
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in 
-  let body = pf_apply subst_tuple_term gls e1 (pf_get_hyp_typ gls id) in
+  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in
+  let idtyp = pf_get_hyp_typ gls id in
+  let body,expected_goal = pf_apply subst_tuple_term gls e1 e2 idtyp in
   if not (dependent (mkRel 1) body) then raise NothingToRewrite;
-  cut_replacing id (subst1 e2 body)
-    (tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls
+  cut_replacing id expected_goal
+    (tclTHENFIRST
+      (bareRevSubstInConcl lbeq body eq)
+      (refine_no_check (mkVar id))) gls
 
 let cutSubstInHyp_RL eqn id gls =
   (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id)
@@ -1099,12 +1225,12 @@ let cutSubstInHyp_RL eqn id gls =
 let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL
 
 let try_rewrite tac gls =
-  try 
+  try
     tac gls
-  with 
+  with
     | PatternMatchingFailure ->
 	errorlabstrm "try_rewrite" (str "Not a primitive equality here.")
-    | e when catchable_exception e -> 
+    | e when catchable_exception e ->
 	errorlabstrm "try_rewrite"
           (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.")
     | NothingToRewrite ->
@@ -1122,7 +1248,8 @@ let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None
 
 let substClause l2r c cls gls =
   let eq = pf_apply get_type_of gls c in
-  tclTHENS (cutSubstClause l2r eq cls) [tclIDTAC; exact_no_check c] gls
+  tclTHENS (cutSubstClause l2r eq cls)
+    [tclIDTAC; exact_no_check c] gls
 
 let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls)
 let rewriteInHyp l2r c id = rewriteClause l2r c (Some id)
@@ -1155,8 +1282,7 @@ let unfold_body x gl =
       | _ -> 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 -> ((all_occurrences_expr,y),InHyp) :: cl) aft [] 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
@@ -1165,19 +1291,22 @@ let unfold_body x gl =
 
 
 
+let restrict_to_eq_and_identity eq = (* compatibility *)
+  if eq <> constr_of_global glob_eq && eq <> constr_of_global glob_identity then
+    raise PatternMatchingFailure
 
 exception FoundHyp of (identifier * constr * bool)
 
 (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *)
-let is_eq_x x (id,_,c) =
+let is_eq_x gl x (id,_,c) =
   try
-    let (_,lhs,rhs) = snd (find_eq_data_decompose c) in
+    let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in
     if (x = lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
     if (x = rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
   with PatternMatchingFailure ->
     ()
 
-let subst_one x gl = 
+let subst_one dep_proof_ok x gl =
   let hyps = pf_hyps gl in
   let (_,xval,_) = pf_get_hyp gl x in
   (* If x has a body, simply replace x with body and clear x *)
@@ -1185,9 +1314,9 @@ let subst_one x gl =
   (* x is a variable: *)
   let varx = mkVar x in
   (* Find a non-recursive definition for x *)
-  let (hyp,rhs,dir) = 
+  let (hyp,rhs,dir) =
     try
-      let test hyp _ = is_eq_x varx hyp in
+      let test hyp _ = is_eq_x gl varx hyp in
       Sign.fold_named_context test ~init:() hyps;
       errorlabstrm "Subst"
         (str "Cannot find any non-recursive equality over " ++ pr_id x ++
@@ -1195,8 +1324,8 @@ let subst_one x gl =
     with FoundHyp res -> res
   in
   (* The set of hypotheses using x *)
-  let depdecls = 
-    let test (id,_,c as dcl) = 
+  let depdecls =
+    let test (id,_,c as dcl) =
       if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl
       else failwith "caught" in
     List.rev (map_succeed test hyps) in
@@ -1219,10 +1348,10 @@ let subst_one x gl =
 	  (Some (replace_term varx rhs htyp)) nowhere
   in
   let need_rewrite = dephyps <> [] || depconcl in
-  tclTHENLIST 
+  tclTHENLIST
     ((if need_rewrite then
       [generalize abshyps;
-       (if dir then rewriteLR else rewriteRL) (mkVar hyp);
+       general_rewrite dir all_occurrences dep_proof_ok (mkVar hyp);
        thin dephyps;
        tclMAP introtac depdecls]
     else
@@ -1230,111 +1359,81 @@ let subst_one x gl =
        tclMAP introtac depdecls]) @
      [tclTRY (clear [x;hyp])]) gl
 
-let subst ids = tclTHEN tclNORMEVAR (tclMAP subst_one ids)
+let subst_gen dep_proof_ok ids =
+  tclTHEN tclNORMEVAR (tclMAP (subst_one dep_proof_ok) ids)
+
+let subst = subst_gen true
 
-let subst_all gl =
+type subst_tactic_flags = {
+  only_leibniz : bool;
+  rewrite_dependent_proof : bool
+}
+
+let default_subst_tactic_flags () =
+  if Flags.version_strictly_greater Flags.V8_2 then
+    { only_leibniz = false; rewrite_dependent_proof = true }
+  else
+    { only_leibniz = true; rewrite_dependent_proof = false }
+
+let subst_all ?(flags=default_subst_tactic_flags ()) gl =
   let test (_,c) =
     try
-      let (_,x,y) = snd (find_eq_data_decompose c) in
+      let lbeq,(_,x,y) = find_eq_data_decompose gl c in
+      if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq;
       (* J.F.: added to prevent failure on goal containing x=x as an hyp *)
       if eq_constr x y then failwith "caught";
-      match kind_of_term x with Var x -> x | _ -> 
+      match kind_of_term x with Var x -> x | _ ->
       match kind_of_term y with Var y -> y | _ -> failwith "caught"
     with PatternMatchingFailure -> failwith "caught"
   in
   let ids = map_succeed test (pf_hyps_types gl) in
   let ids = list_uniquize ids in
-  subst ids gl
-
+  subst_gen flags.rewrite_dependent_proof ids gl
 
-(* Rewrite the first assumption for which the condition faildir does not fail 
+(* Rewrite the first assumption for which the condition faildir does not fail
    and gives the direction of the rewrite *)
 
 let cond_eq_term_left c t gl =
   try
-    let (_,x,_) = snd (find_eq_data_decompose t) in
+    let (_,x,_) = snd (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true else failwith "not convertible"
   with PatternMatchingFailure -> failwith "not an equality"
 
-let cond_eq_term_right c t gl = 
+let cond_eq_term_right c t gl =
   try
-    let (_,_,x) = snd (find_eq_data_decompose t) in
+    let (_,_,x) = snd (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then false else failwith "not convertible"
   with PatternMatchingFailure -> failwith "not an equality"
 
-let cond_eq_term c t gl = 
+let cond_eq_term c t gl =
   try
-    let (_,x,y) = snd (find_eq_data_decompose t) in
-    if pf_conv_x gl c x then true 
+    let (_,x,y) = snd (find_eq_data_decompose gl t) in
+    if pf_conv_x gl c x then true
     else if pf_conv_x gl c y then false
     else failwith "not convertible"
   with PatternMatchingFailure -> failwith "not an equality"
 
-let rewrite_multi_assumption_cond cond_eq_term cl gl = 
-  let rec arec = function 
+let rewrite_multi_assumption_cond cond_eq_term cl gl =
+  let rec arec = function
     | [] -> error "No such assumption."
-    | (id,_,t) ::rest -> 
-	begin 
-	  try 
-	    let dir = cond_eq_term t gl in 
-	    general_multi_rewrite dir false (inj_open (mkVar id),NoBindings) cl gl
+    | (id,_,t) ::rest ->
+	begin
+	  try
+	    let dir = cond_eq_term t gl in
+	    general_multi_rewrite dir false (mkVar id,NoBindings) cl gl
 	  with | Failure _ | UserError _ -> arec rest
 	end
-  in 
+  in
   arec (pf_hyps gl)
 
-let replace_multi_term dir_opt c  = 
-  let cond_eq_fun = 
-    match dir_opt with 
+let replace_multi_term dir_opt c  =
+  let cond_eq_fun =
+    match dir_opt with
       | None -> cond_eq_term c
       | Some true -> cond_eq_term_left c
       | Some false -> cond_eq_term_right c
-  in 
-  rewrite_multi_assumption_cond cond_eq_fun 
-
-(* JF. old version 
-let rewrite_assumption_cond faildir gl =
-   let rec arec = function
-      | [] -> error "No such assumption."
-      | (id,_,t)::rest ->
-	  (try let dir = faildir t gl in
-	       general_rewrite dir (mkVar id) gl
-	   with Failure _ | UserError _  ->  arec rest)
-   in arec (pf_hyps gl)
-
-
-let rewrite_assumption_cond_in faildir hyp gl =
-   let rec arec = function
-      | [] -> error "No such assumption."
-      | (id,_,t)::rest ->
-	  (try let dir = faildir t gl in
-	       general_rewrite_in dir hyp (mkVar id) gl
-	   with Failure _ | UserError _ ->  arec rest)
-   in arec (pf_hyps gl)
-
-let replace_term_left t = rewrite_assumption_cond (cond_eq_term_left t)
-
-let replace_term_right t = rewrite_assumption_cond (cond_eq_term_right t)
-   
-let replace_term t = rewrite_assumption_cond (cond_eq_term t)
-   
-let replace_term_in_left t = rewrite_assumption_cond_in (cond_eq_term_left t)
-
-let replace_term_in_right t = rewrite_assumption_cond_in (cond_eq_term_right t)
-   
-let replace_term_in t = rewrite_assumption_cond_in (cond_eq_term t)
-*)
-
-let replace_term_left t = replace_multi_term (Some true) t Tacticals.onConcl
-
-let replace_term_right t = replace_multi_term (Some false) t Tacticals.onConcl
-
-let replace_term t = replace_multi_term None t Tacticals.onConcl
-
-let replace_term_in_left t hyp = replace_multi_term (Some true) t (Tacticals.onHyp hyp)
-
-let replace_term_in_right t hyp = replace_multi_term (Some false) t (Tacticals.onHyp hyp)
-
-let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp)
+  in
+  rewrite_multi_assumption_cond cond_eq_fun
 
-let _ = Tactics.register_general_multi_rewrite general_multi_rewrite
+let _ = Tactics.register_general_multi_rewrite
+  (fun b evars t cls -> general_multi_rewrite b evars t cls)
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 86ad3293..b5c14739 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: equality.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -25,43 +25,56 @@ open Tacexpr
 open Termops
 open Rawterm
 open Genarg
+open Ind_tables
 (*i*)
 
-val general_rewrite_bindings : 
-  bool -> occurrences -> constr with_bindings -> evars_flag -> tactic
-val general_rewrite : 
-  bool -> occurrences -> constr -> tactic
+type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
 
-(* Obsolete, use [general_rewrite_bindings l2r]
-[val rewriteLR_bindings       : constr with_bindings -> tactic]
-[val rewriteRL_bindings       : constr with_bindings -> tactic]
-*)
+type orientation = bool
+
+type conditions =
+  | Naive (* Only try the first occurence of the lemma (default) *)
+  | FirstSolved (* Use the first match whose side-conditions are solved *)
+  | AllMatches (* Rewrite all matches whose side-conditions are solved *)
+
+val general_rewrite_bindings :
+  orientation -> occurrences -> dep_proof_flag ->
+  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
+val general_rewrite :
+  orientation -> occurrences -> dep_proof_flag ->
+  ?tac:(tactic * conditions) -> constr -> tactic
 
 (* Equivalent to [general_rewrite l2r] *)
-val rewriteLR   : constr -> tactic
-val rewriteRL   : constr  -> tactic
+val rewriteLR : ?tac:(tactic * conditions) -> constr -> tactic
+val rewriteRL : ?tac:(tactic * conditions) -> constr  -> tactic
 
 (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *)
 
-val register_general_setoid_rewrite_clause :
-  (identifier option -> bool ->
-    occurrences -> open_constr -> new_goals:constr list -> tactic) -> unit
-val register_is_applied_setoid_relation : (constr -> bool) -> unit
+val register_general_rewrite_clause :
+  (identifier option -> orientation ->
+    occurrences -> constr with_bindings -> new_goals:constr list -> tactic) -> unit
+val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit
+
+val general_rewrite_ebindings_clause : identifier option ->
+  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
+  constr with_bindings -> evars_flag -> tactic
 
 val general_rewrite_bindings_in :
-  bool -> occurrences -> identifier -> constr with_bindings -> evars_flag -> tactic
+  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
+  identifier -> constr with_bindings -> evars_flag -> tactic
 val general_rewrite_in          :
-  bool -> occurrences -> identifier -> constr -> evars_flag -> tactic
+  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
+  identifier -> constr -> evars_flag -> tactic
+
+val general_multi_rewrite :
+  orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic
 
-val general_multi_rewrite : 
-  bool -> evars_flag -> open_constr with_bindings -> clause -> tactic
-val general_multi_multi_rewrite : 
-  evars_flag -> (bool * multi * open_constr with_bindings) list -> clause -> 
-  tactic option -> tactic
+type delayed_open_constr_with_bindings =
+    env -> evar_map -> evar_map * constr with_bindings
 
-val conditional_rewrite : bool -> tactic -> open_constr with_bindings -> tactic
-val conditional_rewrite_in :
-  bool -> identifier -> tactic -> open_constr with_bindings -> tactic
+val general_multi_multi_rewrite :
+  evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list -> 
+    clause -> (tactic * conditions) option -> tactic
 
 val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
 val replace    : constr -> constr -> tactic
@@ -69,24 +82,24 @@ val replace_in : identifier -> constr -> constr -> tactic
 val replace_by : constr -> constr -> tactic -> tactic
 val replace_in_by : identifier -> constr -> constr -> tactic -> tactic
 
-val discr        : evars_flag -> constr with_ebindings -> tactic
+val discr        : evars_flag -> constr with_bindings -> tactic
 val discrConcl   : tactic
 val discrClause  : evars_flag -> clause -> tactic
 val discrHyp     : identifier -> tactic
 val discrEverywhere : evars_flag -> tactic
-val discr_tac    : evars_flag -> 
-  constr with_ebindings induction_arg option -> tactic
+val discr_tac    : evars_flag ->
+  constr with_bindings induction_arg option -> tactic
 val inj          : intro_pattern_expr located list -> evars_flag ->
-  constr with_ebindings -> tactic
-val injClause    : intro_pattern_expr located list -> evars_flag -> 
-  constr with_ebindings induction_arg option -> tactic
+  constr with_bindings -> tactic
+val injClause    : intro_pattern_expr located list -> evars_flag ->
+  constr with_bindings induction_arg option -> tactic
 val injHyp       : identifier -> tactic
 val injConcl     : tactic
 
-val dEq : evars_flag -> constr with_ebindings induction_arg option -> tactic
-val dEqThen : evars_flag -> (int -> tactic) -> constr with_ebindings induction_arg option -> tactic
+val dEq : evars_flag -> constr with_bindings induction_arg option -> tactic
+val dEqThen : evars_flag -> (int -> tactic) -> constr with_bindings induction_arg option -> tactic
 
-val make_iterated_tuple : 
+val make_iterated_tuple :
   env -> evar_map -> constr -> (constr * types) -> constr * constr * constr
 
 (* The family cutRewriteIn expect an equality statement *)
@@ -100,26 +113,6 @@ val rewriteInConcl : bool -> constr -> tactic
 (* Expect the proof of an equality; fails with raw internal errors *)
 val substClause : bool -> constr -> identifier option -> tactic
 
-(*
-(* [substHypInConcl l2r id] is obsolete: use [rewriteInConcl l2r (mkVar id)] *)
-val substHypInConcl : bool -> identifier -> tactic
-
-(* [substConcl] is an obsolete synonym for [cutRewriteInConcl] *)
-val substConcl : bool -> constr -> tactic
-
-(* [substHyp] is an obsolete synonym of [cutRewriteInHyp] *)
-val substHyp : bool -> types -> identifier -> tactic
-*)
-
-(* Obsolete, use [rewriteInConcl lr (mkVar id)] in concl
-              or [rewriteInHyp lr (mkVar id) (Some hyp)] in hyp
-   (which, if they fail, raise only UserError, not PatternMatchingFailure)
-   or [substClause lr (mkVar id) None]
-   or [substClause lr (mkVar id) (Some hyp)]
-[val hypSubst_LR : identifier -> clause -> tactic]
-[val hypSubst_RL : identifier -> clause -> tactic]
-*)
-
 val discriminable : env -> evar_map -> constr -> constr -> bool
 val injectable : env -> evar_map -> constr -> constr -> bool
 
@@ -127,12 +120,19 @@ val injectable : env -> evar_map -> constr -> constr -> bool
 
 val unfold_body : identifier -> tactic
 
+type subst_tactic_flags = {
+  only_leibniz : bool;
+  rewrite_dependent_proof : bool
+}
+val subst_gen : bool -> identifier list -> tactic
 val subst : identifier list -> tactic
-val subst_all : tactic
+val subst_all : ?flags:subst_tactic_flags -> tactic
 
 (* Replace term *)
-(* [replace_multi_term dir_opt c cl] 
+(* [replace_multi_term dir_opt c cl]
    perfoms replacement of [c] by the first value found in context
    (according to [dir] if given to get the rewrite direction)  in the clause [cl]
 *)
 val replace_multi_term : bool option -> constr -> clause -> tactic
+
+val set_eq_dec_scheme_kind : mutual scheme_kind -> unit
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index 67b89888..c8550ff5 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_tactics.ml 12102 2009-04-24 10:48:11Z herbelin $ *)
+(* $Id$ *)
 
 open Term
 open Util
@@ -21,61 +21,39 @@ open Termops
 
 (* The instantiate tactic *)
 
-let evar_list evc c = 
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, _) when Evd.mem evc n -> c :: acc
-    | _ -> fold_constr evrec acc c
-  in 
-    evrec [] c
-
-let instantiate n (ist,rawc) ido gl = 
+let instantiate n (ist,rawc) ido gl =
   let sigma = gl.sigma in
-  let evl = 
+  let evl =
     match ido with
-	ConclLocation () -> evar_list sigma gl.it.evar_concl 
+	ConclLocation () -> evar_list sigma gl.it.evar_concl
       | HypLocation (id,hloc) ->
 	  let decl = Environ.lookup_named_val id gl.it.evar_hyps in
 	    match hloc with
-		InHyp ->  
-		  (match decl with 
+		InHyp ->
+		  (match decl with
 		      (_,None,typ) -> evar_list sigma typ
-		    | _ -> error 
+		    | _ -> error
 			"Please be more specific: in type or value?")
 	      | InHypTypeOnly ->
 		  let (_, _, typ) = decl in evar_list sigma typ
 	      | InHypValueOnly ->
-		  (match decl with 
+		  (match decl with
 		      (_,Some body,_) -> evar_list sigma body
 		    | _ -> error "Not a defined hypothesis.") in
     if List.length evl < n then
-      error "not enough uninstantiated existential variables";
+      error "Not enough uninstantiated existential variables.";
     if n <= 0 then error "Incorrect existential variable index.";
-    let ev,_ =  destEvar (List.nth evl (n-1)) in
-    let env = Evd.evar_env (Evd.find sigma ev) in
-    let ltac_vars = Tacinterp.extract_ltac_vars ist sigma env in
-    let evd' = w_refine ev (ltac_vars,rawc) (create_goal_evar_defs sigma) in
+    let evk,_ = List.nth evl (n-1) in
+    let evi = Evd.find sigma evk in
+    let ltac_vars = Tacinterp.extract_ltac_constr_values ist (Evd.evar_env evi) in
+    let sigma' = w_refine (evk,evi) (ltac_vars,rawc) sigma in
       tclTHEN
-        (tclEVARS (evars_of evd'))
+        (tclEVARS sigma')
         tclNORMEVAR
         gl
-	
-(*
-let pfic gls c =
-  let evc = gls.sigma in 
-  Constrintern.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c
-
-let instantiate_tac = function
-  | [Integer n; Command com] ->
-      (fun gl -> instantiate n (pfic gl com) gl)
-  | [Integer n; Constr c] ->
-      (fun gl -> instantiate n c gl)
-  | _ -> invalid_arg "Instantiate called with bad arguments"
-*)
 
 let let_evar name typ gls =
-  let evd = Evd.create_goal_evar_defs gls.sigma in
-  let evd',evar = Evarutil.new_evar evd (pf_env gls) typ in
-  Refiner.tclTHEN (Refiner.tclEVARS (evars_of evd'))
+  let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) typ in
+  Refiner.tclTHEN (Refiner.tclEVARS sigma')
     (Tactics.letin_tac None name evar None nowhere) gls
- 
+
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index f577b338..2e30cdfb 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.mli
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evar_tactics.mli 12102 2009-04-24 10:48:11Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Tacmach
 open Names
 open Tacexpr
 open Termops
 
-val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr -> 
+val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr ->
   (identifier * hyp_location_flag, unit) location -> tactic
 
 (*i
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 5eb333a0..adf8275e 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extraargs.ml4 12102 2009-04-24 10:48:11Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Pcoq
@@ -41,9 +41,9 @@ let pr_int_list _prc _prlc _prt l =
   in aux l
 
 ARGUMENT EXTEND int_nelist
-  TYPED AS int list 
+  TYPED AS int list
   PRINTED BY pr_int_list
-  RAW_TYPED AS int list 
+  RAW_TYPED AS int list
   RAW_PRINTED BY pr_int_list
   GLOB_TYPED AS int list
   GLOB_PRINTED BY pr_int_list
@@ -65,11 +65,11 @@ let coerce_to_int = function
 let int_list_of_VList = function
   | VList l -> List.map (fun n -> coerce_to_int n) l
   | _ -> raise Not_found
-      
-let interp_occs ist gl l = 
+
+let interp_occs ist gl l =
   match l with
     | ArgArg x -> x
-    | ArgVar (_,id as locid) -> 
+    | ArgVar (_,id as locid) ->
 	(try int_list_of_VList (List.assoc id ist.lfun)
 	  with Not_found | CannotCoerceTo _ -> [interp_int ist locid])
 
@@ -111,14 +111,14 @@ let subst_raw = Tacinterp.subst_rawconstr_and_expr
 ARGUMENT EXTEND raw
     TYPED AS rawconstr
     PRINTED BY pr_rawc
-     
-     INTERPRETED BY interp_raw	
+
+     INTERPRETED BY interp_raw
      GLOBALIZED BY glob_raw
      SUBSTITUTED BY subst_raw
-     
+
      RAW_TYPED AS constr_expr
      RAW_PRINTED BY pr_gen
-     
+
      GLOB_TYPED AS rawconstr_and_expr
      GLOB_PRINTED BY pr_gen
   [ lconstr(c) ] -> [ c ]
@@ -132,9 +132,9 @@ type place = identifier gen_place
 let pr_gen_place pr_id = function
     ConclLocation () -> Pp.mt ()
   | HypLocation (id,InHyp) -> str "in " ++ pr_id id
-  | HypLocation (id,InHypTypeOnly) -> 
+  | HypLocation (id,InHypTypeOnly) ->
       str "in (Type of " ++ pr_id id ++ str ")"
-  | HypLocation (id,InHypValueOnly) -> 
+  | HypLocation (id,InHypValueOnly) ->
       str "in (Value of " ++ pr_id id ++ str ")"
 
 let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id)
@@ -148,7 +148,7 @@ let interp_place ist gl = function
     ConclLocation () -> ConclLocation ()
   | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
 
-let subst_place subst pl = pl 
+let subst_place subst pl = pl
 
 ARGUMENT EXTEND hloc
     TYPED AS place
@@ -160,17 +160,17 @@ ARGUMENT EXTEND hloc
     RAW_PRINTED BY pr_loc_place
     GLOB_TYPED AS loc_place
     GLOB_PRINTED BY pr_loc_place
-  [ ] -> 
+  [ ] ->
     [ ConclLocation () ]
-  |  [ "in" "|-" "*" ] -> 
+  |  [ "in" "|-" "*" ] ->
     [ ConclLocation () ]
 | [ "in" ident(id) ] ->
     [ HypLocation ((Util.dummy_loc,id),InHyp) ]
-| [ "in" "(" "Type" "of" ident(id) ")" ] -> 
+| [ "in" "(" "Type" "of" ident(id) ")" ] ->
     [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ]
-| [ "in" "(" "Value" "of" ident(id) ")" ] -> 
+| [ "in" "(" "Value" "of" ident(id) ")" ] ->
     [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ]
-   
+
  END
 
 
@@ -181,10 +181,10 @@ ARGUMENT EXTEND hloc
 
 (* Julien: Mise en commun des differentes version de replace with in by *)
 
-let pr_by_arg_tac _prc _prlc prtac opt_c = 
-  match opt_c with 
+let pr_by_arg_tac _prc _prlc prtac opt_c =
+  match opt_c with
     | None -> mt ()
-    | Some t -> spc () ++ hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t)
+    | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t)
 
 ARGUMENT EXTEND by_arg_tac
   TYPED AS tactic_opt
@@ -192,37 +192,37 @@ ARGUMENT EXTEND by_arg_tac
 | [ "by" tactic3(c) ] -> [ Some c ]
 | [ ] -> [ None ]
 END
- 
 
-let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds = 
-  match lo,concl with 
+
+let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds =
+  match lo,concl with
     | Some [],true -> mt ()
     | None,true -> str "in" ++ spc () ++ str "*"
-    | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" 
-    | Some l,_ -> 
-	str "in" ++ spc () ++ 
-	  Util.prlist_with_sep spc pr_id l ++ 
-	  match concl with 
+    | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-"
+    | Some l,_ ->
+	str "in" ++
+	  Util.prlist (fun id -> spc () ++ pr_id id) l ++
+	  match concl with
 	    | true -> spc () ++ str "|-" ++ spc () ++ str "*"
 	    | _ -> mt ()
 
 
 let pr_in_arg_hyp _ _ _ = pr_in_hyp (fun (_,id) -> Ppconstr.pr_id id)
 
-let pr_in_arg_hyp_typed  _ _  _  = pr_in_hyp Ppconstr.pr_id 
+let pr_in_arg_hyp_typed  _ _  _  = pr_in_hyp Ppconstr.pr_id
 
 
-let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id 
+let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id
 
-let pr_var_list_typed _ _ _ =  pr_var_list_gen Ppconstr.pr_id 
+let pr_var_list_typed _ _ _ =  pr_var_list_gen Ppconstr.pr_id
 
 let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id)
 
 
-ARGUMENT EXTEND comma_var_lne 
-  TYPED AS var list 
+ARGUMENT EXTEND comma_var_lne
+  TYPED AS var list
   PRINTED BY pr_var_list_typed
-  RAW_TYPED AS var list 
+  RAW_TYPED AS var list
   RAW_PRINTED BY pr_var_list
   GLOB_TYPED AS var list
   GLOB_PRINTED BY pr_var_list
@@ -230,10 +230,10 @@ ARGUMENT EXTEND comma_var_lne
 | [ var(x) "," comma_var_lne(l) ] -> [x::l]
 END
 
-ARGUMENT EXTEND comma_var_l 
-  TYPED AS var list 
+ARGUMENT EXTEND comma_var_l
+  TYPED AS var list
   PRINTED BY pr_var_list_typed
-  RAW_TYPED AS var list 
+  RAW_TYPED AS var list
   RAW_PRINTED BY pr_var_list
   GLOB_TYPED AS var list
   GLOB_PRINTED BY pr_var_list
@@ -241,10 +241,10 @@ ARGUMENT EXTEND comma_var_l
 | [] -> [ [] ]
 END
 
-let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" 
+let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-"
 
-ARGUMENT EXTEND inconcl  
-  TYPED AS bool 
+ARGUMENT EXTEND inconcl
+  TYPED AS bool
   PRINTED BY pr_in_concl
 | [ "|-" "*" ] -> [ true ]
 | [ "|-" ] -> [ false ]
@@ -255,24 +255,24 @@ END
 ARGUMENT EXTEND in_arg_hyp
   TYPED AS var list option * bool
   PRINTED BY pr_in_arg_hyp_typed
-  RAW_TYPED AS var list option * bool 
+  RAW_TYPED AS var list option * bool
   RAW_PRINTED BY pr_in_arg_hyp
   GLOB_TYPED AS var list option * bool
   GLOB_PRINTED BY pr_in_arg_hyp
 | [ "in" "*" ] -> [(None,true)]
 | [ "in" "*" inconcl_opt(b) ] -> [let onconcl = match b with Some b -> b | None -> true in (None,onconcl)]
-| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in 
+| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in
 					      Some l, onconcl
 					   ]
 | [ ] -> [ (Some [],true) ]
 END
 
 
-let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = 
+let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause =
   {Tacexpr.onhyps=
-   Option.map 
-     (fun l -> 
-	List.map 
+   Option.map
+     (fun l ->
+	List.map
 	  (fun id -> ( (all_occurrences_expr,trad_id id),InHyp))
 	  l
      )
@@ -280,8 +280,8 @@ let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause =
    Tacexpr.concl_occs = if concl then all_occurrences_expr else no_occurrences_expr}
 
 
-let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd 
-let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) 
+let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd
+let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x)
 
 
 (* spiwack argument for the commands of the retroknowledge *)
@@ -297,7 +297,7 @@ let (wit_r_field, globwit_r_field, rawwit_r_field) =
 
 (* spiwack: the print functions are incomplete, but I don't know what they are
 	used for *)
-let pr_r_nat_field _ _ _ natf = 
+let pr_r_nat_field _ _ _ natf =
   str "nat " ++
   match natf with
     | Retroknowledge.NatType -> str "type"
@@ -327,7 +327,7 @@ let pr_r_int31_field _ _ _ i31f =
     | Retroknowledge.Int31PhiInv -> str "phi inv"
     | Retroknowledge.Int31Plus -> str "plus"
     | Retroknowledge.Int31Times -> str "times"
-    | _ -> assert false	
+    | _ -> assert false
 
 let pr_retroknowledge_field _ _ _ f =
   match f with
@@ -335,7 +335,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 
+                                           str "in " ++ str group
 
 ARGUMENT EXTEND retroknowledge_nat
 TYPED AS r_nat_field
@@ -347,7 +347,7 @@ END
 
 
 ARGUMENT EXTEND retroknowledge_binary_n
-TYPED AS r_n_field 
+TYPED AS r_n_field
 PRINTED BY pr_r_n_field
 | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ]
 | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ]
@@ -360,7 +360,7 @@ PRINTED BY pr_r_n_field
 END
 
 ARGUMENT EXTEND retroknowledge_int31
-TYPED AS r_int31_field 
+TYPED AS r_int31_field
 PRINTED BY pr_r_int31_field
 | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ]
 | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ]
@@ -385,8 +385,8 @@ PRINTED BY pr_r_int31_field
 
 END
 
-ARGUMENT EXTEND retroknowledge_field 
-TYPED AS r_field 
+ARGUMENT EXTEND retroknowledge_field
+TYPED AS r_field
 PRINTED BY pr_retroknowledge_field
 (*| [ "equality" ] -> [ Retroknowledge.KEq ]
 | [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ]
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index b64adf24..4492fd84 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraargs.mli 12102 2009-04-24 10:48:11Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Tacexpr
 open Term
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index ee01f839..0bb6ce96 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extratactics.ml4 11800 2009-01-18 18:34:15Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Pcoq
@@ -19,29 +19,45 @@ open Names
 open Tacexpr
 open Rawterm
 open Tactics
-
-(* Equality *)
+open Util
+open Termops
+open Evd
 open Equality
 
+(**********************************************************************)
+(* replace, discriminate, injection, simplify_eq                      *)
+(* cutrewrite, dependent rewrite                                      *)
+
+let replace_in_clause_maybe_by (sigma1,c1) c2 in_hyp tac =
+  Refiner.tclWITHHOLES false
+    (replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp))
+    sigma1
+    (Option.map Tacinterp.eval_tactic tac)
+
+let replace_multi_term dir_opt (sigma,c) in_hyp =
+  Refiner.tclWITHHOLES false
+    (replace_multi_term dir_opt c)
+    sigma
+    (glob_in_arg_hyp_to_clause in_hyp)
 
-TACTIC EXTEND replace 
-   ["replace" constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ]
--> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) (Option.map Tacinterp.eval_tactic tac) ]
+TACTIC EXTEND replace
+   ["replace" open_constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ]
+-> [ replace_in_clause_maybe_by c1 c2 in_hyp tac ]
 END
 
 TACTIC EXTEND replace_term_left
-  [ "replace"  "->" constr(c) in_arg_hyp(in_hyp) ]
-  -> [ replace_multi_term (Some true) c (glob_in_arg_hyp_to_clause in_hyp)]
+  [ "replace"  "->" open_constr(c) in_arg_hyp(in_hyp) ]
+  -> [ replace_multi_term (Some true) c in_hyp]
 END
 
 TACTIC EXTEND replace_term_right
-  [ "replace"  "<-" constr(c) in_arg_hyp(in_hyp) ]
-  -> [replace_multi_term (Some false) c (glob_in_arg_hyp_to_clause in_hyp)]
+  [ "replace"  "<-" open_constr(c) in_arg_hyp(in_hyp) ]
+  -> [replace_multi_term (Some false) c in_hyp]
 END
 
 TACTIC EXTEND replace_term
-  [ "replace" constr(c) in_arg_hyp(in_hyp) ]
-  -> [ replace_multi_term None c (glob_in_arg_hyp_to_clause in_hyp) ]
+  [ "replace" open_constr(c) in_arg_hyp(in_hyp) ]
+  -> [ replace_multi_term None c in_hyp ]
 END
 
 let induction_arg_of_quantified_hyp = function
@@ -52,9 +68,13 @@ 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 elimOnConstrWithHoles tac with_evars c =
+  Refiner.tclWITHHOLES with_evars (tac with_evars) 
+    c.sigma (Some (ElimOnConstr c.it))
+
 TACTIC EXTEND simplify_eq_main
 | [ "simplify_eq" constr_with_bindings(c) ] ->
-    [ dEq false (Some (ElimOnConstr c)) ]
+    [ elimOnConstrWithHoles dEq false c ]
 END
 TACTIC EXTEND simplify_eq
   [ "simplify_eq" ] -> [ dEq false None ]
@@ -63,7 +83,7 @@ TACTIC EXTEND simplify_eq
 END
 TACTIC EXTEND esimplify_eq_main
 | [ "esimplify_eq" constr_with_bindings(c) ] ->
-    [ dEq true (Some (ElimOnConstr c)) ]
+    [ elimOnConstrWithHoles dEq true c ]
 END
 TACTIC EXTEND esimplify_eq
 | [ "esimplify_eq" ] -> [ dEq true None ]
@@ -73,7 +93,7 @@ END
 
 TACTIC EXTEND discriminate_main
 | [ "discriminate" constr_with_bindings(c) ] ->
-    [ discr_tac false (Some (ElimOnConstr c)) ]
+    [ elimOnConstrWithHoles discr_tac false c ]
 END
 TACTIC EXTEND discriminate
 | [ "discriminate" ] -> [ discr_tac false None ]
@@ -82,7 +102,7 @@ TACTIC EXTEND discriminate
 END
 TACTIC EXTEND ediscriminate_main
 | [ "ediscriminate" constr_with_bindings(c) ] ->
-    [ discr_tac true (Some (ElimOnConstr c)) ]
+    [ elimOnConstrWithHoles discr_tac true c ]
 END
 TACTIC EXTEND ediscriminate
 | [ "ediscriminate" ] -> [ discr_tac true None ]
@@ -90,39 +110,40 @@ TACTIC EXTEND ediscriminate
     [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_discrHyp id = h_discriminate_main (Term.mkVar id,NoBindings)
+let h_discrHyp id gl =
+  h_discriminate_main {it = Term.mkVar id,NoBindings; sigma = Refiner.project gl} gl
 
 TACTIC EXTEND injection_main
 | [ "injection" constr_with_bindings(c) ] ->
-    [ injClause [] false (Some (ElimOnConstr c)) ]
-END 
+    [ elimOnConstrWithHoles (injClause []) false c ]
+END
 TACTIC EXTEND injection
 | [ "injection" ] -> [ injClause [] false None ]
-| [ "injection" quantified_hypothesis(h) ] -> 
+| [ "injection" quantified_hypothesis(h) ] ->
     [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND einjection_main
 | [ "einjection" constr_with_bindings(c) ] ->
-    [ injClause [] true (Some (ElimOnConstr c)) ]
+    [ elimOnConstrWithHoles (injClause []) true c ]
 END
 TACTIC EXTEND einjection
 | [ "einjection" ] -> [ injClause [] true None ]
 | [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ]
-END 
+END
 TACTIC EXTEND injection_as_main
 | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
-    [ injClause ipat false (Some (ElimOnConstr c)) ]
-END 
+    [ elimOnConstrWithHoles (injClause ipat) false c ]
+END
 TACTIC EXTEND injection_as
 | [ "injection" "as" simple_intropattern_list(ipat)] ->
     [ injClause ipat false None ]
 | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
     [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ]
-END 
+END
 TACTIC EXTEND einjection_as_main
 | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
-    [ injClause ipat true (Some (ElimOnConstr c)) ]
-END 
+    [ elimOnConstrWithHoles (injClause ipat) true c ]
+END
 TACTIC EXTEND einjection_as
 | [ "einjection" "as" simple_intropattern_list(ipat)] ->
     [ injClause ipat true None ]
@@ -130,15 +151,8 @@ TACTIC EXTEND einjection_as
     [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_injHyp id = h_injection_main (Term.mkVar id,NoBindings)
-
-TACTIC EXTEND conditional_rewrite
-| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ]
-    -> [ conditional_rewrite b (snd tac) (inj_open (fst c), snd c) ]
-| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c)
-    "in" hyp(h) ]
-    -> [ conditional_rewrite_in b h (snd tac) (inj_open (fst c), snd c) ]
-END
+let h_injHyp id gl =
+  h_injection_main { it = Term.mkVar id,NoBindings; sigma = Refiner.project gl } gl
 
 TACTIC EXTEND dependent_rewrite
 | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ]
@@ -152,50 +166,82 @@ TACTIC EXTEND cut_rewrite
     -> [ cutRewriteInHyp b eqn id ]
 END
 
-(* Contradiction *)
+(**********************************************************************)
+(* Contradiction                                                      *)
+
 open Contradiction
 
 TACTIC EXTEND absurd
  [ "absurd" constr(c) ] -> [ absurd c ]
 END
 
+let onSomeWithHoles tac = function
+  | None -> tac None
+  | Some c -> Refiner.tclWITHHOLES false tac c.sigma (Some c.it)
+
 TACTIC EXTEND contradiction
- [ "contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ]
+ [ "contradiction" constr_with_bindings_opt(c) ] ->
+    [ onSomeWithHoles contradiction c ]
 END
 
-(* AutoRewrite *)
+(**********************************************************************)
+(* AutoRewrite                                                        *)
 
 open Autorewrite
-(* J.F : old version 
-TACTIC EXTEND autorewrite
-  [ "autorewrite" "with" ne_preident_list(l) ] ->
-    [ autorewrite Refiner.tclIDTAC l ]
-| [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] ->
-    [ autorewrite (snd t) l ]
-| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) ] ->
-    [ autorewrite_in id Refiner.tclIDTAC l ]
-| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) "using" tactic(t) ] ->
-    [ autorewrite_in id (snd t) l ]
-END
-*)
 
 TACTIC EXTEND autorewrite
 | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
     [ auto_multi_rewrite  l (glob_in_arg_hyp_to_clause  cl) ]
 | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
-    [ 
-      let cl =  glob_in_arg_hyp_to_clause cl in 
+    [
+      let cl =  glob_in_arg_hyp_to_clause cl in
       auto_multi_rewrite_with (snd t) l cl
 
     ]
 END
 
+TACTIC EXTEND autorewrite_star
+| [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
+    [ auto_multi_rewrite ~conds:AllMatches l (glob_in_arg_hyp_to_clause  cl) ]
+| [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
+    [ let cl =  glob_in_arg_hyp_to_clause cl in
+	auto_multi_rewrite_with ~conds:AllMatches (snd 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
+  Refiner. tclWITHHOLES false
+    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true (c,NoBindings)) sigma true
+
+let occurrences_of = function
+  | n::_ as nl when n < 0 -> (false,List.map abs nl)
+  | nl ->
+      if List.exists (fun n -> n < 0) nl then
+	error "Illegal negative occurrence number.";
+      (true,nl)
+
+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 all_occurrences 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 all_occurrences c tac ]
+    END
 
-
+(**********************************************************************)
+(* Hint Rewrite                                                       *)
 
 let add_rewrite_hint name ort t lcsr =
   let env = Global.env() and sigma = Evd.empty in
-  let f c = Constrintern.interp_constr sigma env c, ort, t in
+  let f c = Topconstr.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in
   add_rew_rules name (List.map f lcsr)
 
 VERNAC COMMAND EXTEND HintRewrite
@@ -204,10 +250,56 @@ VERNAC COMMAND EXTEND HintRewrite
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
     ":" preident(b) ] ->
   [ add_rewrite_hint b o t l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] ->
+  [ add_rewrite_hint "core" o (Tacexpr.TacId []) l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] ->
+  [ add_rewrite_hint "core" o t l ]
 END
 
+(**********************************************************************)
+(* Hint Resolve                                                       *)
 
-(* Refine *)
+open Term
+open Coqlib
+
+let project_hint pri l2r c =
+  let env = Global.env() in
+  let c = Constrintern.interp_constr Evd.empty env c in
+  let t = Retyping.get_type_of env Evd.empty c in
+  let t =
+    Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in
+  let sign,ccl = decompose_prod_assum t in
+  let (a,b) = match snd (decompose_app ccl) with
+    | [a;b] -> (a,b)
+    | _ -> 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 = it_mkLambda_or_LetIn
+    (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
+  (pri,true,c)
+
+let add_hints_iff l2r lc n bl =
+  Auto.add_hints true bl
+    (Auto.HintsResolveEntry (List.map (project_hint n l2r) lc))
+
+VERNAC COMMAND EXTEND HintResolveIffLR
+  [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n)
+    ":" preident_list(bl) ] ->
+  [ add_hints_iff true lc n bl ]
+| [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) ] ->
+  [ add_hints_iff true lc n ["core"] ]
+END
+VERNAC COMMAND EXTEND HintResolveIffRL
+  [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n)
+    ":" preident_list(bl) ] ->
+  [ add_hints_iff false lc n bl ]
+| [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ] ->
+  [ add_hints_iff false lc n ["core"] ]
+END
+
+(**********************************************************************)
+(* Refine                                                             *)
 
 open Refine
 
@@ -217,7 +309,8 @@ END
 
 let refine_tac = h_refine
 
-(* Inversion lemmas (Leminv) *)
+(**********************************************************************)
+(* Inversion lemmas (Leminv)                                          *)
 
 open Inv
 open Leminv
@@ -263,16 +356,25 @@ VERNAC COMMAND EXTEND DeriveDependentInversionClear
   -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
 END
 
-(* Subst *)
+(**********************************************************************)
+(* Subst                                                              *)
 
 TACTIC EXTEND subst
 | [ "subst" ne_var_list(l) ] -> [ subst l ]
-| [ "subst" ] -> [ subst_all ]
+| [ "subst" ] -> [ fun gl -> subst_all gl ]
+END
+
+let simple_subst_tactic_flags =
+  { only_leibniz = true; rewrite_dependent_proof = false }
+
+TACTIC EXTEND simple_subst
+| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags ]
 END
 
 open Evar_tactics
 
-(* evar creation *)
+(**********************************************************************)
+(* Evar creation                                                      *)
 
 TACTIC EXTEND evar
   [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ]
@@ -289,7 +391,8 @@ TACTIC EXTEND instantiate
 END
 
 
-(** Nijmegen "step" tactic for setoid rewriting *)
+(**********************************************************************)
+(** Nijmegen "step" tactic for setoid rewriting                       *)
 
 open Tactics
 open Tactics
@@ -323,40 +426,37 @@ let step left x tac =
 (* Main function to push lemmas in persistent environment *)
 
 let cache_transitivity_lemma (_,(left,lem)) =
-  if left then  
+  if left then
     transitivity_left_table  := lem :: !transitivity_left_table
   else
     transitivity_right_table := lem :: !transitivity_right_table
-  
-let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_mps subst ref)
+
+let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref)
 
 let (inTransitivity,_) =
   declare_object {(default_object "TRANSITIVITY-STEPS") with
     cache_function = cache_transitivity_lemma;
     open_function = (fun i o -> if i=1 then cache_transitivity_lemma o);
     subst_function = subst_transitivity_lemma;
-    classify_function = (fun (_,o) -> Substitute o);       
-    export_function = (fun x -> Some x) }
+    classify_function = (fun o -> Substitute o) }
 
 (* Synchronisation with reset *)
 
 let freeze () = !transitivity_left_table, !transitivity_right_table
 
-let unfreeze (l,r) = 
+let unfreeze (l,r) =
   transitivity_left_table := l;
   transitivity_right_table := r
 
-let init () = 
+let init () =
   transitivity_left_table := [];
   transitivity_right_table := []
 
-let _ = 
+let _ =
   declare_summary "transitivity-steps"
     { freeze_function = freeze;
       unfreeze_function = unfreeze;
-      init_function = init;
-      survive_module = false; 
-      survive_section = false }
+      init_function = init }
 
 (* Main entry points *)
 
@@ -394,10 +494,11 @@ END
 
 
 
-(*spiwack : Vernac commands for retroknowledge *)
+(**********************************************************************)
+(*spiwack : Vernac commands for retroknowledge                        *)
 
 VERNAC COMMAND EXTEND RetroknowledgeRegister
- | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> 
+ | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] ->
            [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in
              let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in
              Global.register f tc tb ]
@@ -405,19 +506,121 @@ END
 
 
 
-(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as 
+(**********************************************************************)
+(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as
   defined by Conor McBride *)
 TACTIC EXTEND generalize_eqs
-| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:false ]
+| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ]
 END
-TACTIC EXTEND generalize_eqs_vars
-| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:true ]
+TACTIC EXTEND dep_generalize_eqs
+| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ]
 END
+TACTIC EXTEND generalize_eqs_vars
+| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ]
+END
+TACTIC EXTEND dep_generalize_eqs_vars
+| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ]
+END
+
+(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] 
+    where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated
+    during dependent induction. For internal use. *)
+
+TACTIC EXTEND specialize_eqs
+[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ]
+END
+
+(**********************************************************************)
+(* A tactic that considers a given occurrence of [c] in [t] and       *)
+(* abstract the minimal set of all the occurrences of [c] so that the *)
+(* abstraction [fun x -> t[x/c]] is well-typed                        *)
+(*                                                                    *)
+(* Contributed by Chung-Kil Hur (Winter 2009)                         *)
+(**********************************************************************)
+
+let subst_var_with_hole occ tid t = 
+  let occref = if occ > 0 then ref occ else error_invalid_occurrence [occ] in
+  let locref = ref 0 in
+  let rec substrec = function
+    | RVar (_,id) as x -> 
+        if id = tid 
+        then (decr occref; if !occref = 0 then x
+                           else (incr locref; RHole (Ploc.make !locref 0 (0,0),Evd.QuestionMark(Evd.Define true))))
+        else x
+    | c -> map_rawconstr_left_to_right substrec c in
+  let t' = substrec t
+  in
+  if !occref > 0 then error_invalid_occurrence [occ] else t'
+
+let subst_hole_with_term occ tc t =
+  let locref = ref 0 in
+  let occref = ref occ in
+  let rec substrec = function
+    | RHole (_,Evd.QuestionMark(Evd.Define true)) -> 
+        decr occref; if !occref = 0 then tc
+                     else (incr locref; RHole (Ploc.make !locref 0 (0,0),Evd.QuestionMark(Evd.Define true)))
+    | c -> map_rawconstr_left_to_right substrec c
+  in
+  substrec t
+
+open Tacmach
+
+let out_arg = function
+  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgArg x -> x
+
+let hResolve id c occ t gl = 
+  let sigma = project gl in 
+  let env = clear_named_body id (pf_env gl) in
+  let env_ids = ids_of_context env in
+  let env_names = names_of_rel_context env in
+  let c_raw = Detyping.detype true env_ids env_names c in 
+  let t_raw = Detyping.detype true env_ids env_names t in 
+  let rec resolve_hole t_hole =
+    try 
+      Pretyping.Default.understand sigma env t_hole
+    with 
+    | Ploc.Exc (loc,Pretype_errors.PretypeError (_, Pretype_errors.UnsolvableImplicit _)) -> 
+        resolve_hole (subst_hole_with_term (Ploc.line_nb loc) c_raw t_hole)
+  in
+  let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let t_constr_type = Retyping.get_type_of env sigma t_constr in
+  change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl
+
+let hResolve_auto id c t gl =
+  let rec resolve_auto n = 
+    try
+      hResolve id c n t gl
+    with
+    | UserError _ as e -> raise e
+    | _ -> resolve_auto (n+1)
+  in
+  resolve_auto 1
 
-TACTIC EXTEND dependent_pattern
-| ["dependent_pattern" constr(c) ] -> [ dependent_pattern c ]
+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) ")" "in" constr(t) ] -> [ hResolve_auto id c t ]
 END
 
-TACTIC EXTEND resolve_classes
-| ["resolve_classes" ] -> [ resolve_classes ]
+(**
+   hget_evar
+*)
+
+open Evar_refiner
+open Sign
+
+let hget_evar n gl =
+  let sigma = project gl in
+  let evl = evar_list sigma (pf_concl gl) in
+  if List.length evl < n then
+    error "Not enough uninstantiated existential variables.";
+  if n <= 0 then error "Incorrect existential variable index.";
+  let ev = List.nth evl (n-1) in
+  let ev_type = existential_type sigma ev in
+  change_in_concl None (mkLetIn (Anonymous,mkEvar ev,ev_type,pf_concl gl)) gl
+
+TACTIC EXTEND hget_evar
+| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ]
 END
+
+(**********************************************************************)
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index d43e4581..82006f60 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extratactics.mli 11166 2008-06-22 13:23:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Proof_type
 
@@ -15,3 +15,4 @@ val h_injHyp : Names.identifier -> tactic
 
 val refine_tac : Evd.open_constr -> tactic
 
+val onSomeWithHoles : ('a option -> tactic) -> 'a Evd.sigma option -> tactic
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 4ab40acb..5cc729f1 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hiddentac.ml 13124 2010-06-13 11:09:38Z herbelin $ *)
+(* $Id$ *)
 
 open Term
 open Proof_type
@@ -19,79 +19,69 @@ open Tacexpr
 open Tactics
 open Util
 
-let inj_id id = (dummy_loc,id)
-let inj_open c = (Evd.empty,c)
-let inj_open_wb (c,b) = ((Evd.empty,c),b)
-let inj_ia = function
-  | ElimOnConstr c -> ElimOnConstr (inj_open_wb c)
-  | ElimOnIdent id -> ElimOnIdent id
-  | ElimOnAnonHyp n -> ElimOnAnonHyp n
-let inj_occ (occ,c) = (occ,inj_open c)
-
 (* Basic tactics *)
 let h_intro_move x y =
   abstract_tactic (TacIntroMove (x, y)) (intro_move x y)
 let h_intro x        = h_intro_move (Some x) no_move
 let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x)
 let h_assumption     = abstract_tactic TacAssumption assumption
-let h_exact c        = abstract_tactic (TacExact (inj_open c)) (exact_check c)
+let h_exact c        = abstract_tactic (TacExact c) (exact_check c)
 let h_exact_no_check c =
-  abstract_tactic (TacExactNoCheck (inj_open c)) (exact_no_check c)
-let h_vm_cast_no_check c = 
-  abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c)
+  abstract_tactic (TacExactNoCheck c) (exact_no_check c)
+let h_vm_cast_no_check c =
+  abstract_tactic (TacVmCastNoCheck c) (vm_cast_no_check c)
 let h_apply simple ev cb =
-  abstract_tactic (TacApply (simple,ev,cb,None))
-    (apply_with_ebindings_gen simple ev cb)
+  abstract_tactic (TacApply (simple,ev,List.map snd cb,None))
+    (apply_with_bindings_gen simple ev cb)
 let h_apply_in simple ev cb (id,ipat as inhyp) =
-  abstract_tactic (TacApply (simple,ev,cb,Some inhyp))
+  abstract_tactic (TacApply (simple,ev,List.map snd cb,Some inhyp))
     (apply_in simple ev id cb ipat)
 let h_elim ev cb cbo    =
-  abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo))
+  abstract_tactic (TacElim (ev,cb,cbo))
     (elim ev cb cbo)
-let h_elim_type c    = abstract_tactic (TacElimType (inj_open c)) (elim_type c)
-let h_case ev cb     = abstract_tactic (TacCase (ev,inj_open_wb cb)) (general_case_analysis ev cb)
-let h_case_type c    = abstract_tactic (TacCaseType (inj_open c)) (case_type c)
+let h_elim_type c    = abstract_tactic (TacElimType c) (elim_type c)
+let h_case ev cb     = abstract_tactic (TacCase (ev,cb)) (general_case_analysis ev cb)
+let h_case_type c    = abstract_tactic (TacCaseType c) (case_type c)
 let h_fix ido n      = abstract_tactic (TacFix (ido,n)) (fix ido n)
 let h_mutual_fix b id n l =
   abstract_tactic
-    (TacMutualFix (b,id,n,List.map (fun (id,n,c) -> (id,n,inj_open c)) l))
-    (mutual_fix id n l)
+    (TacMutualFix (b,id,n,l))
+    (mutual_fix id n l 0)
 
 let h_cofix ido      = abstract_tactic (TacCofix ido) (cofix ido)
 let h_mutual_cofix b id l =
   abstract_tactic
-    (TacMutualCofix (b,id,List.map (fun (id,c) -> (id,inj_open c)) l)) 
-    (mutual_cofix id l)
+    (TacMutualCofix (b,id,l))
+    (mutual_cofix id l 0)
 
-let h_cut c          = abstract_tactic (TacCut (inj_open c)) (cut c)
+let h_cut c          = abstract_tactic (TacCut c) (cut c)
 let h_generalize_gen cl =
-  abstract_tactic (TacGeneralize (List.map (on_fst inj_occ) cl))
+  abstract_tactic (TacGeneralize cl)
     (generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl))
 let h_generalize cl =
   h_generalize_gen (List.map (fun c -> ((all_occurrences_expr,c),Names.Anonymous))
     cl)
 let h_generalize_dep c =
-  abstract_tactic (TacGeneralizeDep (inj_open c))(generalize_dep c)
+  abstract_tactic (TacGeneralizeDep c) (generalize_dep c)
 let h_let_tac b na c cl =
   let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in
-  abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c None cl)
+  abstract_tactic (TacLetTac (na,c,cl,b)) (letin_tac with_eq na c None cl)
 
 (* Derived basic tactics *)
 let h_simple_induction_destruct isrec h =
-  abstract_tactic (TacSimpleInductionDestruct (isrec,h)) 
+  abstract_tactic (TacSimpleInductionDestruct (isrec,h))
     (if isrec then (simple_induct h) else (simple_destruct h))
 let h_simple_induction = h_simple_induction_destruct true
 let h_simple_destruct = h_simple_induction_destruct false
 
-let h_induction_destruct ev isrec l =
-  abstract_tactic (TacInductionDestruct (isrec,ev,List.map (fun (c,e,idl,cl) -> 
-    List.map inj_ia c,Option.map inj_open_wb e,idl,cl) l))
-    (induction_destruct isrec ev l)
-let h_new_induction ev c e idl cl = h_induction_destruct ev true [c,e,idl,cl]
-let h_new_destruct ev c e idl cl = h_induction_destruct ev false [c,e,idl,cl]
+let h_induction_destruct isrec ev lcl =
+  abstract_tactic (TacInductionDestruct (isrec,ev,lcl))
+    (induction_destruct isrec ev lcl)
+let h_new_induction ev c e idl cl = h_induction_destruct true ev ([c,e,idl],cl)
+let h_new_destruct ev c e idl cl = h_induction_destruct false ev ([c,e,idl],cl)
 
-let h_specialize n d = abstract_tactic (TacSpecialize (n,inj_open_wb d)) (specialize n d)
-let h_lapply c = abstract_tactic (TacLApply (inj_open c)) (cut_and_apply c)
+let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d)
+let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
 
 (* Context management *)
 let h_clear b l = abstract_tactic (TacClear (b,l))
@@ -104,34 +94,35 @@ let h_rename l =
 let h_revert l = abstract_tactic (TacRevert l) (revert l)
 
 (* Constructors *)
-let h_left ev l  = abstract_tactic (TacLeft (ev,l)) (left_with_ebindings ev l)
-let h_right ev l = abstract_tactic (TacRight (ev,l)) (right_with_ebindings ev l)
-let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_ebindings ev l)
+let h_left ev l  = abstract_tactic (TacLeft (ev,l)) (left_with_bindings ev l)
+let h_right ev l = abstract_tactic (TacRight (ev,l)) (right_with_bindings ev l)
+let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_bindings ev l)
 (* Moved to tacinterp because of dependencies in Tacinterp.interp
 let h_any_constructor t =
   abstract_tactic (TacAnyConstructor t) (any_constructor t)
 *)
 let h_constructor ev n l =
   abstract_tactic (TacConstructor(ev,AI n,l))(constructor_tac ev None n l)
-let h_one_constructor n = h_constructor false n NoBindings
+let h_one_constructor n =
+  abstract_tactic (TacConstructor(false,AI n,NoBindings)) (one_constructor n NoBindings)
 let h_simplest_left   = h_left false NoBindings
 let h_simplest_right  = h_right false NoBindings
 
 (* Conversion *)
-let h_reduce r cl  = 
-  abstract_tactic (TacReduce (inj_red_expr r,cl)) (reduce r cl)
-let h_change oc c cl =
-  abstract_tactic (TacChange (Option.map inj_occ oc,inj_open c,cl))
-    (change (Option.map Redexpr.out_with_occurrences oc) c cl)
+let h_reduce r cl  =
+  abstract_tactic (TacReduce (r,cl)) (reduce r cl)
+let h_change op c cl =
+  abstract_tactic (TacChange (op,c,cl)) (change op c cl)
 
 (* Equivalence relations *)
 let h_reflexivity    = abstract_tactic TacReflexivity intros_reflexivity
 let h_symmetry c     = abstract_tactic (TacSymmetry c) (intros_symmetry c)
 let h_transitivity c =
-  abstract_tactic (TacTransitivity (inj_open c)) (intros_transitivity c)
+  abstract_tactic (TacTransitivity c)
+    (intros_transitivity c)
 
-let h_simplest_apply c  = h_apply false false [inj_open c,NoBindings]
-let h_simplest_eapply c = h_apply false true [inj_open c,NoBindings]
+let h_simplest_apply c = h_apply false false [dummy_loc,(c,NoBindings)]
+let h_simplest_eapply c = h_apply false true [dummy_loc,(c,NoBindings)]
 let h_simplest_elim c   = h_elim false (c,NoBindings) None
 let h_simplest_case   c = h_case false (c,NoBindings)
 
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
index 9270411a..36b0830d 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hiddentac.mli 12102 2009-04-24 10:48:11Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -37,30 +37,30 @@ val h_exact           : constr -> tactic
 val h_exact_no_check  : constr -> tactic
 val h_vm_cast_no_check  : constr -> tactic
 
-val h_apply           : advanced_flag -> evars_flag -> 
-  open_constr with_bindings list -> tactic
-val h_apply_in        : advanced_flag -> evars_flag -> 
-  open_constr with_bindings list -> 
+val h_apply           : advanced_flag -> evars_flag ->
+  constr with_bindings located list -> tactic
+val h_apply_in        : advanced_flag -> evars_flag ->
+  constr with_bindings located list ->
   identifier * intro_pattern_expr located option -> tactic
 
-val h_elim            : evars_flag -> constr with_ebindings ->
-                        constr with_ebindings option -> tactic
+val h_elim            : evars_flag -> constr with_bindings ->
+                        constr with_bindings option -> tactic
 val h_elim_type       : constr -> tactic
-val h_case            : evars_flag -> constr with_ebindings -> tactic
+val h_case            : evars_flag -> constr with_bindings -> tactic
 val h_case_type       : constr -> tactic
 
 val h_mutual_fix      : hidden_flag -> identifier -> int ->
                         (identifier * int * constr) list -> tactic
 val h_fix             : identifier option -> int -> tactic
-val h_mutual_cofix    : hidden_flag -> identifier -> 
+val h_mutual_cofix    : hidden_flag -> identifier ->
                         (identifier * constr) list -> tactic
 val h_cofix           : identifier option -> tactic
 
-val h_cut             : constr -> tactic 
-val h_generalize      : constr list -> tactic 
-val h_generalize_gen  : (constr with_occurrences * name) list -> tactic 
-val h_generalize_dep  : constr -> tactic 
-val h_let_tac         : letin_flag -> name -> constr -> 
+val h_cut             : constr -> tactic
+val h_generalize      : constr list -> tactic
+val h_generalize_gen  : (constr with_occurrences * name) list -> tactic
+val h_generalize_dep  : constr -> tactic
+val h_let_tac         : letin_flag -> name -> constr ->
                         Tacticals.clause -> tactic
 
 (* Derived basic tactics *)
@@ -68,20 +68,20 @@ val h_let_tac         : letin_flag -> name -> constr ->
 val h_simple_induction   : quantified_hypothesis -> tactic
 val h_simple_destruct    : quantified_hypothesis -> tactic
 val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic
-val h_new_induction   : evars_flag -> 
-  constr with_ebindings induction_arg list -> constr with_ebindings option ->
+val h_new_induction   : evars_flag ->
+  constr with_bindings induction_arg list -> constr with_bindings option ->
   intro_pattern_expr located option * intro_pattern_expr located option ->
   Tacticals.clause option -> tactic
-val h_new_destruct    : evars_flag -> 
-  constr with_ebindings induction_arg list -> constr with_ebindings option -> 
+val h_new_destruct    : evars_flag ->
+  constr with_bindings induction_arg list -> constr with_bindings option ->
   intro_pattern_expr located option * intro_pattern_expr located option ->
   Tacticals.clause option -> tactic
 val h_induction_destruct : rec_flag -> evars_flag ->
-  (constr with_ebindings induction_arg list * constr with_ebindings option * 
-   (intro_pattern_expr located option * intro_pattern_expr located option) *
-   Tacticals.clause option) list -> tactic
+  (constr with_bindings induction_arg list * constr with_bindings option *
+   (intro_pattern_expr located option * intro_pattern_expr located option)) list
+    * Tacticals.clause option -> tactic
 
-val h_specialize      : int option -> constr with_ebindings -> tactic
+val h_specialize      : int option -> constr with_bindings -> tactic
 val h_lapply          : constr -> tactic
 
 (* Automation tactic : see Auto *)
@@ -95,10 +95,10 @@ val h_rename          : (identifier*identifier) list -> tactic
 val h_revert          : identifier list -> tactic
 
 (* Constructors *)
-val h_constructor     : evars_flag -> int -> open_constr bindings -> tactic
-val h_left            : evars_flag -> open_constr bindings -> tactic
-val h_right           : evars_flag -> open_constr bindings -> tactic
-val h_split           : evars_flag -> open_constr bindings -> tactic
+val h_constructor     : evars_flag -> int -> constr bindings -> tactic
+val h_left            : evars_flag -> constr bindings -> tactic
+val h_right           : evars_flag -> constr bindings -> tactic
+val h_split           : evars_flag -> constr bindings list -> tactic
 
 val h_one_constructor : int -> tactic
 val h_simplest_left   : tactic
@@ -108,15 +108,15 @@ val h_simplest_right  : tactic
 (* Conversion *)
 val h_reduce          : Redexpr.red_expr -> Tacticals.clause -> tactic
 val h_change          :
-  constr with_occurrences option -> constr -> Tacticals.clause -> tactic
+  Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic
 
 (* Equivalence relations *)
 val h_reflexivity     : tactic
 val h_symmetry        : Tacticals.clause -> tactic
-val h_transitivity    : constr -> tactic
+val h_transitivity    : constr option -> tactic
 
-val h_simplest_apply  : constr -> tactic 
-val h_simplest_eapply : constr -> tactic 
+val h_simplest_apply  : constr -> tactic
+val h_simplest_eapply : constr -> tactic
 val h_simplest_elim   : constr -> tactic
 val h_simplest_case   : constr -> tactic
 
diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib
new file mode 100644
index 00000000..7d12f9d0
--- /dev/null
+++ b/tactics/hightactics.mllib
@@ -0,0 +1,8 @@
+Refine
+Extraargs
+Extratactics
+Eauto
+Class_tactics
+Rewrite
+Tauto
+Eqdecide
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index 2e83ac70..9aec0e09 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
 
-(* $Id: hipattern.ml4 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -32,10 +32,10 @@ open Declarations
    is an inductive but non-recursive type, a general conjuction, a
    general disjunction, or a type with no constructors.
 
-   They are more general than matching with or_term, and_term, etc, 
-   since they do not depend on the name of the type. Hence, they 
+   They are more general than matching with or_term, and_term, etc,
+   since they do not depend on the name of the type. Hence, they
    also work on ad-hoc disjunctions introduced by the user.
-  
+
   -- Eduardo (6/8/97). *)
 
 type 'a matching_function = constr -> 'a option
@@ -50,16 +50,16 @@ let meta4 = mkmeta 4
 
 let op2bool = function Some _ -> true | None -> false
 
-let match_with_non_recursive_type t = 
-  match kind_of_term t with 
-    | App _ -> 
+let match_with_non_recursive_type t =
+  match kind_of_term t with
+    | App _ ->
         let (hdapp,args) = decompose_app t in
         (match kind_of_term hdapp with
-           | Ind ind -> 
-               if not (Global.lookup_mind (fst ind)).mind_finite then 
-		 Some (hdapp,args) 
-	       else 
-		 None 
+           | Ind ind ->
+               if not (Global.lookup_mind (fst ind)).mind_finite then
+		 Some (hdapp,args)
+	       else
+		 None
            | _ -> None)
     | _ -> None
 
@@ -69,34 +69,34 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t)
 
 let rec has_nodep_prod_after n c =
   match kind_of_term c with
-    | Prod (_,_,b) -> 
-	( n>0 || not (dependent (mkRel 1) b)) 
+    | Prod (_,_,b) ->
+	( n>0 || not (dependent (mkRel 1) b))
 	&& (has_nodep_prod_after (n-1) b)
     | _            -> true
-	  
+
 let has_nodep_prod = has_nodep_prod_after 0
 
-(* A general conjunctive type is a non-recursive with-no-indices inductive 
+(* A general conjunctive type is a non-recursive with-no-indices inductive
    type with only one constructor and no dependencies between argument;
-   it is strict if it has the form 
+   it is strict if it has the form
    "Inductive I A1 ... An := C (_:A1) ... (_:An)" *)
 
 (* style: None = record; Some false = conjunction; Some true = strict conj *)
 
-let match_with_one_constructor style t =
-  let (hdapp,args) = decompose_app t in 
+let match_with_one_constructor style allow_rec t =
+  let (hdapp,args) = decompose_app t in
   match kind_of_term hdapp with
-  | Ind ind -> 
+  | Ind ind ->
       let (mib,mip) = Global.lookup_inductive ind in
       if (Array.length mip.mind_consnames = 1)
-	&& (not (mis_is_recursive (ind,mib,mip)))
+	&& (allow_rec or not (mis_is_recursive (ind,mib,mip)))
         && (mip.mind_nrealargs = 0)
       then
 	if style = Some true (* strict conjunction *) then
-	  let ctx = 
-	    fst (decompose_prod_assum (snd 
+	  let ctx =
+	    (prod_assum (snd
 	      (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
-	  if 
+	  if
 	    List.for_all
 	      (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx
 	  then
@@ -104,7 +104,7 @@ let match_with_one_constructor style t =
 	  else None
 	else
 	  let ctyp = prod_applist mip.mind_nf_lc.(0) args in
-	  let cargs = List.map pi3 (fst (decompose_prod_assum ctyp)) in
+	  let cargs = List.map pi3 ((prod_assum ctyp)) in
 	  if style <> Some false || has_nodep_prod ctyp then
 	    (* Record or non strict conjunction *)
 	    Some (hdapp,List.rev cargs)
@@ -115,10 +115,10 @@ let match_with_one_constructor style t =
   | _ -> None
 
 let match_with_conjunction ?(strict=false) t =
-  match_with_one_constructor (Some strict) t
+  match_with_one_constructor (Some strict) false t
 
-let match_with_record t = 
-  match_with_one_constructor None t
+let match_with_record t =
+  match_with_one_constructor None false t
 
 let is_conjunction ?(strict=false) t =
   op2bool (match_with_conjunction ~strict t)
@@ -126,20 +126,30 @@ let is_conjunction ?(strict=false) t =
 let is_record t =
   op2bool (match_with_record t)
 
+let match_with_tuple t =
+  let t = match_with_one_constructor None true t in
+  Option.map (fun (hd,l) ->
+    let ind = destInd hd in
+    let (mib,mip) = Global.lookup_inductive ind in
+    let isrec = mis_is_recursive (ind,mib,mip) in
+    (hd,l,isrec)) t
+
+let is_tuple t =
+  op2bool (match_with_tuple t)
 
-(* A general disjunction type is a non-recursive with-no-indices inductive 
+(* A general disjunction type is a non-recursive with-no-indices inductive
    type with of which all constructors have a single argument;
-   it is strict if it has the form 
+   it is strict if it has the form
    "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *)
 
 let test_strict_disjunction n lc =
   array_for_all_i (fun i c ->
-    match fst (decompose_prod_assum (snd (decompose_prod_n_assum n c))) with
+    match (prod_assum (snd (decompose_prod_n_assum n c))) with
     | [_,None,c] -> c = mkRel (n - i)
     | _ -> false) 0 lc
 
 let match_with_disjunction ?(strict=false) t =
-  let (hdapp,args) = decompose_app t in 
+  let (hdapp,args) = decompose_app t in
   match kind_of_term hdapp with
   | Ind ind  ->
       let car = mis_constr_nargs ind in
@@ -157,7 +167,7 @@ let match_with_disjunction ?(strict=false) t =
 	    Array.map (fun ar -> pi2 (destProd (prod_applist ar args)))
 	      mip.mind_nf_lc in
 	  Some (hdapp,Array.to_list cargs)
-      else 
+      else
 	None
   | _ -> None
 
@@ -170,12 +180,12 @@ let is_disjunction ?(strict=false) t =
 let match_with_empty_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-    | Ind ind -> 
+    | Ind ind ->
         let (mib,mip) = Global.lookup_inductive ind in
-        let nconstr = Array.length mip.mind_consnames in  
+        let nconstr = Array.length mip.mind_consnames in
 	if nconstr = 0 then Some hdapp else None
     | _ ->  None
-	  
+
 let is_empty_type t = op2bool (match_with_empty_type t)
 
 (* This filters inductive types with one constructor with no arguments;
@@ -184,21 +194,22 @@ let is_empty_type t = op2bool (match_with_empty_type t)
 let match_with_unit_or_eq_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-    | Ind ind  -> 
+    | Ind ind  ->
         let (mib,mip) = Global.lookup_inductive ind in
-        let constr_types = mip.mind_nf_lc in 
+        let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
-        let zero_args c = nb_prod c = mib.mind_nparams in  
-	if nconstr = 1 && zero_args constr_types.(0) then 
+        let zero_args c = nb_prod c = mib.mind_nparams in
+	if nconstr = 1 && zero_args constr_types.(0) then
 	  Some hdapp
-	else 
+	else
 	  None
     | _ -> None
 
 let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t)
 
 (* A unit type is an inductive type with no indices but possibly
-   (useless) parameters, and that has no constructors *)
+   (useless) parameters, and that has no arguments in its unique
+   constructor *)
 
 let is_unit_type t =
   match match_with_conjunction t with
@@ -209,75 +220,94 @@ let is_unit_type t =
    inductive binary relation R, so that R has only one constructor
    establishing its reflexivity.  *)
 
-let coq_refl_rel1_pattern  = PATTERN [ forall A:_, forall x:A, _ A x x ]
-let coq_refl_rel2_pattern  = PATTERN [ forall x:_, _ x x ]
-let coq_refl_reljm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ]
+type equation_kind =
+  | MonomorphicLeibnizEq of constr * constr
+  | PolymorphicLeibnizEq of constr * constr * constr
+  | HeterogenousEq of constr * constr * constr * constr
+
+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 Libnames
 
 let match_with_equation t =
-  let (hdapp,args) = decompose_app t in
-  match (kind_of_term hdapp) with
-    | Ind ind -> 
+  if not (isApp t) then raise NoEquationFound;
+  let (hdapp,args) = destApp t in
+  match kind_of_term hdapp with
+  | Ind ind ->
+      if IndRef ind = glob_eq then
+	Some (build_coq_eq_data()),hdapp,
+	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
+      else if IndRef ind = glob_identity then
+	Some (build_coq_identity_data()),hdapp,
+	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
+      else if IndRef ind = glob_jmeq then
+	Some (build_coq_jmeq_data()),hdapp,
+	HeterogenousEq(args.(0),args.(1),args.(2),args.(3))
+      else
         let (mib,mip) = Global.lookup_inductive ind in
-        let constr_types = mip.mind_nf_lc in 
+        let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
-	if nconstr = 1 &&
-           (is_matching coq_refl_rel1_pattern constr_types.(0) ||
-            is_matching coq_refl_rel2_pattern constr_types.(0) ||
-            is_matching coq_refl_reljm_pattern constr_types.(0)) 
-        then 
-	  Some (hdapp,args)
-        else 
-	  None
-    | _ -> None
-
-let is_equation t = op2bool (match_with_equation  t)
+	if nconstr = 1 then
+          if is_matching coq_refl_leibniz1_pattern constr_types.(0) then
+	    None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1))
+	  else if is_matching coq_refl_leibniz2_pattern constr_types.(0) then
+	    None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
+	  else if is_matching coq_refl_jm_pattern constr_types.(0) then
+	    None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3))
+	  else raise NoEquationFound
+        else raise NoEquationFound
+    | _ -> raise NoEquationFound
+
+let is_inductive_equality ind =
+  let (mib,mip) = Global.lookup_inductive ind in
+  let nconstr = Array.length mip.mind_consnames in
+  nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0
 
 let match_with_equality_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-    | Ind ind when args <> [] -> 
-        let (mib,mip) = Global.lookup_inductive ind in
-        let nconstr = Array.length mip.mind_consnames in
-	if nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0
-        then 
-	  Some (hdapp,args)
-        else 
-	  None
-    | _ -> None
+  | Ind ind when is_inductive_equality ind -> Some (hdapp,args)
+  | _ -> None
+
+let is_equality_type t = op2bool (match_with_equality_type t)
 
 let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ]
 
 let match_arrow_pattern t =
   match matches coq_arrow_pattern t with
     | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind)
-    | _ -> anomaly "Incorrect pattern matching" 
+    | _ -> anomaly "Incorrect pattern matching"
 
 let match_with_nottype t =
   try
     let (arg,mind) = match_arrow_pattern t in
     if is_empty_type mind then Some (mind,arg) else None
-  with PatternMatchingFailure -> None  
+  with PatternMatchingFailure -> None
 
 let is_nottype t = op2bool (match_with_nottype t)
-		     
+
 let match_with_forall_term c=
   match kind_of_term c with
     | Prod (nam,a,b) -> Some (nam,a,b)
     | _            -> None
 
-let is_forall_term c = op2bool (match_with_forall_term c) 
+let is_forall_term c = op2bool (match_with_forall_term c)
 
 let match_with_imp_term c=
   match kind_of_term c with
     | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
     | _              -> None
 
-let is_imp_term c = op2bool (match_with_imp_term c) 
+let is_imp_term c = op2bool (match_with_imp_term c)
 
 let match_with_nodep_ind t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-      | Ind ind  -> 
+      | Ind ind  ->
           let (mib,mip) = Global.lookup_inductive ind in
 	    if Array.length (mib.mind_packets)>1 then None else
 	      let nodep_constr = has_nodep_prod_after mib.mind_nparams in
@@ -286,24 +316,24 @@ let match_with_nodep_ind t =
 		    if mip.mind_nrealargs=0 then args else
 		      fst (list_chop mib.mind_nparams args) in
 		    Some (hdapp,params,mip.mind_nrealargs)
-		else 
+		else
 		  None
       | _ -> None
-	  
+
 let is_nodep_ind t=op2bool (match_with_nodep_ind t)
 
 let match_with_sigma_type t=
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-    | Ind ind  -> 
+    | Ind ind  ->
         let (mib,mip) = Global.lookup_inductive ind in
           if (Array.length (mib.mind_packets)=1) &&
 	    (mip.mind_nrealargs=0) &&
 	    (Array.length mip.mind_consnames=1) &&
 	    has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then
-	      (*allowing only 1 existential*) 
+	      (*allowing only 1 existential*)
 	      Some (hdapp,args)
-	  else 
+	  else
 	    None
     | _ -> None
 
@@ -323,21 +353,58 @@ let rec first_match matcher = function
 let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ]
 let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref
 let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref
+let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ]
+let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ]
 
 let match_eq eqn eq_pat =
-  match matches (Lazy.force eq_pat) eqn with
+  let pat = try Lazy.force eq_pat with _ -> raise PatternMatchingFailure in
+  match matches pat eqn with
     | [(m1,t);(m2,x);(m3,y)] ->
 	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
-	(t,x,y)
-    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+	PolymorphicLeibnizEq (t,x,y)
+    | [(m1,t);(m2,x);(m3,t');(m4,x')] ->
+	assert (m1 = meta1 & m2 = meta2 & m3 = meta3 & m4 = meta4);
+	HeterogenousEq (t,x,t',x')
+    | _ -> anomaly "match_eq: an eq pattern should match 3 or 4 terms"
 
 let equalities =
   [coq_eq_pattern, build_coq_eq_data;
+   coq_jmeq_pattern, build_coq_jmeq_data;
    coq_identity_pattern, build_coq_identity_data]
 
-let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *)
+let find_eq_data eqn = (* fails with PatternMatchingFailure *)
   first_match (match_eq eqn) equalities
 
+let extract_eq_args gl = function
+  | MonomorphicLeibnizEq (e1,e2) ->
+      let t = Tacmach.pf_type_of gl e1 in (t,e1,e2)
+  | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2)
+  | HeterogenousEq (t1,e1,t2,e2) ->
+      if Tacmach.pf_conv_x gl t1 t2 then (t1,e1,e2)
+      else raise PatternMatchingFailure
+
+let find_eq_data_decompose gl eqn =
+  let (lbeq,eq_args) = find_eq_data eqn in
+  (lbeq,extract_eq_args gl eq_args)
+
+let inversible_equalities =
+  [coq_eq_pattern, build_coq_inversion_eq_data;
+   coq_jmeq_pattern, build_coq_inversion_jmeq_data;
+   coq_identity_pattern, build_coq_inversion_identity_data;
+   coq_eq_true_pattern, build_coq_inversion_eq_true_data]
+
+let find_this_eq_data_decompose gl eqn =
+  let (lbeq,eq_args) =
+    try (*first_match (match_eq eqn) inversible_equalities*)
+      find_eq_data eqn
+    with PatternMatchingFailure ->
+      errorlabstrm "" (str "No primitive equality found.") in
+  let eq_args =
+    try extract_eq_args gl eq_args
+    with PatternMatchingFailure ->
+      error "Don't know what to do with JMeq on arguments not of same type." in
+  (lbeq,eq_args)
+
 open Tacmach
 open Tacticals
 
@@ -369,7 +436,7 @@ let match_sigma ex ex_pat =
 	anomaly "match_sigma: a successful sigma pattern should match 4 terms"
 
 let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
-  first_match (match_sigma ex) 
+  first_match (match_sigma ex)
     [coq_existT_pattern, build_sigma_type]
 
 (* Pattern "(sig ?1 ?2)" *)
@@ -407,14 +474,14 @@ let op_sum = coq_sumbool_ref
 let match_eqdec t =
   let eqonleft,op,subst =
     try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t
-    with PatternMatchingFailure -> 
+    with PatternMatchingFailure ->
     try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t
-    with PatternMatchingFailure -> 
+    with PatternMatchingFailure ->
     try true,op_or,matches (Lazy.force coq_eqdec_pattern) t
-    with PatternMatchingFailure -> 
+    with PatternMatchingFailure ->
         false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in
   match subst with
-  | [(_,typ);(_,c1);(_,c2)] -> 
+  | [(_,typ);(_,c1);(_,c2)] ->
       eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ
   | _ -> anomaly "Unexpected pattern"
 
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 3c423202..d98d2a2b 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hipattern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -16,6 +16,7 @@ open Sign
 open Evd
 open Pattern
 open Proof_trees
+open Coqlib
 (*i*)
 
 (*s Given a term with second-order variables in it,
@@ -41,8 +42,8 @@ open Proof_trees
    is an inductive but non-recursive type, a general conjuction, a
    general disjunction, or a type with no constructors.
 
-   They are more general than matching with [or_term], [and_term], etc, 
-   since they do not depend on the name of the type. Hence, they 
+   They are more general than matching with [or_term], [and_term], etc,
+   since they do not depend on the name of the type. Hence, they
    also work on ad-hoc disjunctions introduced by the user.
    (Eduardo, 6/8/97). *)
 
@@ -50,41 +51,50 @@ type 'a matching_function = constr -> 'a option
 type testing_function = constr -> bool
 
 val match_with_non_recursive_type : (constr * constr list) matching_function
-val is_non_recursive_type         : testing_function 
+val is_non_recursive_type         : testing_function
 
+(* Non recursive type with no indices and exactly one argument for each
+   constructor; canonical definition of n-ary disjunction if strict *)
 val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function
-val is_disjunction         : ?strict:bool -> testing_function 
+val is_disjunction         : ?strict:bool -> testing_function
 
+(* Non recursive tuple (one constructor and no indices) with no inner
+   dependencies; canonical definition of n-ary conjunction if strict *)
 val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function
-val is_conjunction         : ?strict:bool -> testing_function 
+val is_conjunction         : ?strict:bool -> testing_function
 
+(* Non recursive tuple, possibly with inner dependencies *)
 val match_with_record      : (constr * constr list) matching_function
-val is_record              : testing_function 
+val is_record              : testing_function
+
+(* Like record but supports and tells if recursive (e.g. Acc) *)
+val match_with_tuple       : (constr * constr list * bool) matching_function
+val is_tuple               : testing_function
 
+(* No constructor, possibly with indices *)
 val match_with_empty_type  : constr matching_function
-val is_empty_type          : testing_function 
+val is_empty_type          : testing_function
 
 (* type with only one constructor and no arguments, possibly with indices *)
 val match_with_unit_or_eq_type : constr matching_function
-val is_unit_or_eq_type     : testing_function 
+val is_unit_or_eq_type     : testing_function
 
 (* type with only one constructor and no arguments, no indices *)
-val is_unit_type           : testing_function 
-
-val match_with_equation    : (constr * constr list) matching_function
-val is_equation            : testing_function 
+val is_unit_type           : testing_function
 
 (* type with only one constructor, no arguments and at least one dependency *)
+val is_inductive_equality  : inductive -> bool
 val match_with_equality_type : (constr * constr list) matching_function
+val is_equality_type       : testing_function
 
 val match_with_nottype     : (constr * constr) matching_function
-val is_nottype             : testing_function 
+val is_nottype             : testing_function
 
 val match_with_forall_term    : (name * constr * constr) matching_function
-val is_forall_term            : testing_function 
+val is_forall_term            : testing_function
 
 val match_with_imp_term    : (constr * constr) matching_function
-val is_imp_term            : testing_function 
+val is_imp_term            : testing_function
 
 (* I added these functions to test whether a type contains dependent
   products or not, and if an inductive has constructors with dependent types
@@ -94,24 +104,41 @@ val is_imp_term            : testing_function
 val has_nodep_prod_after   : int -> testing_function
 val has_nodep_prod         : testing_function
 
-val match_with_nodep_ind   : (constr * constr list * int) matching_function  
-val is_nodep_ind           : testing_function 
+val match_with_nodep_ind   : (constr * constr list * int) matching_function
+val is_nodep_ind           : testing_function
+
+val match_with_sigma_type   : (constr * constr list) matching_function
+val is_sigma_type           : testing_function
+
+(* Recongnize inductive relation defined by reflexivity *)
 
-val match_with_sigma_type   : (constr * constr list) matching_function	  
-val is_sigma_type           : testing_function 
+type equation_kind =
+  | MonomorphicLeibnizEq of constr * constr
+  | PolymorphicLeibnizEq of constr * constr * constr
+  | HeterogenousEq of constr * constr * constr * constr
+
+exception NoEquationFound
+
+val match_with_equation:
+  constr -> coq_eq_data option * constr * equation_kind
 
 (***** Destructing patterns bound to some theory *)
 
-open Coqlib
+(* Match terms [eq A t u], [identity A t u] or [JMeq A t A u] *)
+(* Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
+val find_eq_data_decompose : Proof_type.goal sigma -> constr ->
+      coq_eq_data * (types * constr * constr)
+
+(* Idem but fails with an error message instead of PatternMatchingFailure *)
+val find_this_eq_data_decompose : Proof_type.goal sigma -> constr ->
+      coq_eq_data * (types * constr * constr)
 
-(* Match terms [(eq A t u)] or [(identity A t u)] *)
-(* Returns associated lemmas and [A,t,u] *)
-val find_eq_data_decompose : constr -> 
-  coq_leibniz_eq_data * (constr * constr * constr)
+(* A variant that returns more informative structure on the equality found *)
+val find_eq_data : constr -> coq_eq_data * equation_kind
 
 (* Match a term of the form [(existT A P t p)] *)
 (* Returns associated lemmas and [A,P,t,p] *)
-val find_sigma_data_decompose : constr -> 
+val find_sigma_data_decompose : constr ->
   coq_sigma_data * (constr * constr * constr * constr)
 
 (* Match a term of the form [{x:A|P}], returns [A] and [P] *)
diff --git a/tactics/inv.ml b/tactics/inv.ml
index af204e77..86641114 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inv.ml 12410 2009-10-24 17:23:39Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -14,6 +14,7 @@ open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Global
 open Sign
 open Environ
@@ -37,21 +38,22 @@ open Rawterm
 open Genarg
 open Tacexpr
 
-let collect_meta_variables c = 
+let collect_meta_variables c =
   let rec collrec acc c = match kind_of_term c with
     | Meta mv -> mv::acc
     | _ -> fold_constr collrec acc c
-  in 
+  in
   collrec [] c
 
 let check_no_metas clenv ccl =
   if occur_meta ccl then
-    let metas = List.filter (fun na -> na<>Anonymous)
-      (List.map (Evd.meta_name clenv.evd) (collect_meta_variables ccl)) in
-    errorlabstrm "inversion" 
+    let metas = List.filter (fun m -> not (Evd.meta_defined clenv.evd m))
+      (collect_meta_variables ccl) in
+    let metas = List.map (Evd.meta_name clenv.evd) metas in
+    errorlabstrm "inversion"
       (str ("Cannot find an instantiation for variable"^
 	       (if List.length metas = 1 then " " else "s ")) ++
-	 prlist_with_sep pr_coma pr_name metas
+	 prlist_with_sep pr_comma pr_name metas
 	 (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *))
 
 let var_occurs_in_pf gl id =
@@ -60,7 +62,7 @@ let var_occurs_in_pf gl id =
   List.exists (occur_var_in_decl env id) (pf_hyps gl)
 
 (* [make_inv_predicate (ity,args) C]
-  
+
    is given the inductive type, its arguments, both the global
    parameters and its local arguments, and is expected to produce a
    predicate P such that if largs is the "local" part of the
@@ -127,16 +129,16 @@ let make_inv_predicate env sigma indf realargs id status concl =
      push <Ai>(mkRel k)=ai (when   Ai is closed).
    In any case, we carry along the rest of pairs *)
   let rec build_concl eqns n = function
-    | [] -> (prod_it concl eqns,n)
+    | [] -> (it_mkProd concl eqns,n)
     | (ai,(xi,ti))::restlist ->
         let (lhs,eqnty,rhs) =
-          if closed0 ti then 
+          if closed0 ti then
 	    (xi,ti,ai)
-          else 
+          else
 	    make_iterated_tuple env' sigma ai (xi,ti)
 	in
         let eq_term = Coqlib.build_coq_eq () in
-        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in 
+        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in
 	build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist
   in
   let (newconcl,neqns) = build_concl [] 0 pairs in
@@ -188,21 +190,21 @@ let make_inv_predicate env sigma indf realargs id status concl =
    it generalizes them, applies tac to rewrite all occurrencies of t,
    and introduces generalized hypotheis.
    Precondition: t=(mkVar id) *)
-    
-let rec dependent_hyps id idlist gl = 
+
+let rec dependent_hyps id idlist gl =
   let rec dep_rec =function
     | [] -> []
-    | (id1,_,_)::l -> 
+    | (id1,_,_)::l ->
 	(* Update the type of id1: it may have been subject to rewriting *)
 	let d = pf_get_hyp gl id1 in
 	if occur_var_in_decl (Global.env()) id d
         then d :: dep_rec l
         else dep_rec l
-  in 
-  dep_rec idlist 
+  in
+  dep_rec idlist
 
 let split_dep_and_nodep hyps gl =
-  List.fold_right 
+  List.fold_right
     (fun (id,_,_ as d) (l1,l2) ->
        if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2))
     hyps ([],[])
@@ -280,17 +282,17 @@ Summary: nine useless hypotheses!
 Nota: with Inversion_clear, only four useless hypotheses
 *)
 
-let generalizeRewriteIntros tac depids id gls = 
+let generalizeRewriteIntros tac depids id gls =
   let dids = dependent_hyps id depids gls in
   (tclTHENSEQ
-    [bring_hyps dids; tac; 
+    [bring_hyps dids; tac;
      (* may actually fail to replace if dependent in a previous eq *)
      intros_replacing (ids_of_named_context dids)])
   gls
 
 let rec tclMAP_i n tacfun = function
   | [] -> tclDO n (tacfun None)
-  | a::l -> 
+  | a::l ->
       if n=0 then error "Too many names."
       else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l)
 
@@ -317,14 +319,14 @@ let projectAndApply thin id eqname names depids gls =
     | _ -> tac id gls
   in
   let deq_trailer id neqns =
-    tclTHENSEQ 
+    tclTHENSEQ
       [(if names <> [] then clear [id] else tclIDTAC);
        (tclMAP_i neqns (fun idopt ->
-	 tclTHEN
+	 tclTRY (tclTHEN
 	   (intro_move idopt no_move)
 	   (* try again to substitute and if still not a variable after *)
 	   (* decomposition, arbitrarily try to rewrite RL !? *)
-	   (tclTRY (onLastHyp (substHypIfVariable (subst_hyp false)))))
+	   (tclTRY (onLastHypId (substHypIfVariable (subst_hyp false))))))
 	 names);
        (if names = [] then clear [id] else tclIDTAC)]
   in
@@ -342,14 +344,14 @@ let rewrite_equations_gene othin neqns ba gl =
   let rewrite_eqns =
     match othin with
       | Some thin ->
-          onLastHyp
+          onLastHypId
             (fun last ->
               tclTHENSEQ
                 [tclDO neqns
                      (tclTHEN intro
-                        (onLastHyp
+                        (onLastHypId
                            (fun id ->
-                              tclTRY 
+                              tclTRY
 			        (projectAndApply thin id (ref no_move)
 				  [] depids))));
                  onHyps (compose List.rev (afterHyp last)) bring_hyps;
@@ -361,8 +363,8 @@ let rewrite_equations_gene othin neqns ba gl =
     [tclDO neqns intro;
      bring_hyps nodepids;
      clear (ids_of_named_context nodepids);
-     onHyps (compose List.rev (nLastHyps neqns)) bring_hyps;
-     onHyps (nLastHyps neqns) (compose clear ids_of_named_context);
+     onHyps (compose List.rev (nLastDecls neqns)) bring_hyps;
+     onHyps (nLastDecls neqns) (compose clear ids_of_named_context);
      rewrite_eqns;
      tclMAP (fun (id,_,_ as d) ->
                (tclORELSE (clear [id])
@@ -378,13 +380,13 @@ let rewrite_equations_gene othin neqns ba gl =
 let rec get_names allow_conj (loc,pat) = match pat with
   | IntroWildcard ->
       error "Discarding pattern not allowed for inversion equations."
-  | IntroAnonymous ->
+  | IntroAnonymous | IntroForthcoming _ ->
       error "Anonymous pattern not allowed for inversion equations."
   | IntroFresh _ ->
       error "Fresh pattern not allowed for inversion equations."
   | IntroRewrite _->
       error "Rewriting pattern not allowed for inversion equations."
-  | IntroOrAndPattern [l] -> 
+  | IntroOrAndPattern [l] ->
       if allow_conj then
 	if l = [] then (None,[]) else
 	  let l = List.map (fun id -> Option.get (fst (get_names false id))) l in
@@ -408,13 +410,13 @@ let rewrite_equations othin neqns names ba gl =
     match othin with
       | Some thin ->
           tclTHENSEQ
-            [onHyps (compose List.rev (nLastHyps neqns)) bring_hyps;
-             onHyps (nLastHyps neqns) (compose clear ids_of_named_context);
+            [onHyps (compose List.rev (nLastDecls neqns)) bring_hyps;
+             onHyps (nLastDecls neqns) (compose clear ids_of_named_context);
 	     tclMAP_i neqns (fun o ->
 	       let idopt,names = extract_eqn_names o in
                (tclTHEN
 		 (intro_move idopt no_move)
-		 (onLastHyp (fun id ->
+		 (onLastHypId (fun id ->
 		   tclTRY (projectAndApply thin id first_eq names depids)))))
 	       names;
 	     tclMAP (fun (id,_,_) gl ->
@@ -440,18 +442,18 @@ let rewrite_equations_tac (gene, othin) id neqns names ba =
   let tac =
     if gene then rewrite_equations_gene othin neqns ba
     else rewrite_equations othin neqns names ba in
-  if othin = Some true (* if Inversion_clear, clear the hypothesis *) then 
+  if othin = Some true (* if Inversion_clear, clear the hypothesis *) then
     tclTHEN tac (tclTRY (clear [id]))
-  else 
+  else
     tac
 
 
 let raw_inversion inv_kind id status names gl =
   let env = pf_env gl and sigma = project gl in
   let c = mkVar id in
-  let (ind,t) = 
+  let (ind,t) =
     try pf_reduce_to_atomic_ind gl (pf_type_of gl c)
-    with UserError _ -> 
+    with UserError _ ->
       errorlabstrm "raw_inversion"
 	(str ("The type of "^(string_of_id id)^" is not inductive.")) in
   let indclause = mk_clenv_from gl (c,t) in
@@ -461,19 +463,19 @@ let raw_inversion inv_kind id status names gl =
   let (elim_predicate,neqns) =
     make_inv_predicate env sigma indf realargs id status (pf_concl gl) in
   let (cut_concl,case_tac) =
-    if status <> NoDep & (dependent c (pf_concl gl)) then 
+    if status <> NoDep & (dependent c (pf_concl gl)) then
       Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
-      case_then_using 
-    else 
+      case_then_using
+    else
       Reduction.beta_appvect elim_predicate (Array.of_list realargs),
-      case_nodep_then_using 
+      case_nodep_then_using
   in
   (tclTHENS
      (assert_tac Anonymous cut_concl)
-     [case_tac names 
+     [case_tac names
        (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
        (Some elim_predicate) ([],[]) ind indclause;
-      onLastHyp
+      onLastHypId
         (fun id ->
            (tclTHEN
               (apply_term (mkVar id)
@@ -487,7 +489,7 @@ let wrap_inv_error id = function
       (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) ->
       errorlabstrm ""
 	(strbrk "Inversion would require case analysis on sort " ++
-	pr_sort k ++ 
+	pr_sort k ++
 	strbrk " which is not allowed for inductive definition " ++
 	pr_inductive (Global.env()) i ++ str ".")
   | e -> raise e
@@ -526,16 +528,16 @@ let invIn k names ids id gls =
   let intros_replace_ids gls =
     let nb_of_new_hyp =
       nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init)
-    in 
-    if nb_of_new_hyp < 1 then 
+    in
+    if nb_of_new_hyp < 1 then
       intros_replacing ids gls
-    else 
+    else
       tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls
   in
-  try 
+  try
     (tclTHENSEQ
       [bring_hyps hyps;
-       inversion (false,k) NoDep names id; 
+       inversion (false,k) NoDep names id;
        intros_replace_ids])
     gls
   with e -> wrap_inv_error id e
diff --git a/tactics/inv.mli b/tactics/inv.mli
index bbb2a322..8ec0e2db 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inv.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -24,7 +24,7 @@ val inv_gen :
   bool -> inversion_kind -> inversion_status ->
     intro_pattern_expr located option -> quantified_hypothesis -> tactic
 val invIn_gen :
-  inversion_kind -> intro_pattern_expr located option -> identifier list -> 
+  inversion_kind -> intro_pattern_expr located option -> identifier list ->
     quantified_hypothesis -> tactic
 
 val inv_clause :
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 4cbfa6c2..1f08969f 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: leminv.ml 13126 2010-06-13 11:09:51Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -14,6 +14,7 @@ open Names
 open Nameops
 open Term
 open Termops
+open Namegen
 open Sign
 open Evd
 open Printer
@@ -39,7 +40,7 @@ open Decl_kinds
 let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments"
 
 let no_inductive_inconstr env constr =
-  (str "Cannot recognize an inductive predicate in " ++ 
+  (str "Cannot recognize an inductive predicate in " ++
      pr_lconstr_env env constr ++
      str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++
      spc () ++ str "or of the type of constructors" ++ spc () ++
@@ -87,7 +88,7 @@ let no_inductive_inconstr env constr =
    the respective assumption in each subgoal.
 
  *)
- 
+
 let thin_ids env (hyps,vars) =
   fst
     (List.fold_left
@@ -106,16 +107,16 @@ let thin_ids env (hyps,vars) =
 let get_local_sign sign =
   let lid = ids_of_sign sign in
   let globsign = Global.named_context() in
-  let add_local id res_sign = 
-    if not (mem_sign globsign id) then 
+  let add_local id res_sign =
+    if not (mem_sign globsign id) then
       add_sign (lookup_sign id sign) res_sign
-    else 
+    else
       res_sign
-  in 
+  in
   List.fold_right add_local lid nil_sign
 *)
 (* returs the identifier of lid that was the latest declared in sign.
- * (i.e. is the identifier id of lid such that 
+ * (i.e. is the identifier id of lid such that
  * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) >
  * for any id'<>id in lid).
  * it returns both the pair (id,(sign_prefix id sign)) *)
@@ -123,14 +124,14 @@ let get_local_sign sign =
 let max_prefix_sign lid sign =
   let rec max_rec (resid,prefix) = function
     | [] -> (resid,prefix)
-    | (id::l) -> 
-	let pre = sign_prefix id sign in  
-	if sign_length pre > sign_length prefix then 
+    | (id::l) ->
+	let pre = sign_prefix id sign in
+	if sign_length pre > sign_length prefix then
           max_rec (id,pre) l
-        else 
+        else
 	  max_rec (resid,prefix) l
   in
-  match lid with 
+  match lid with
     | [] -> nil_sign
     | id::l -> snd (max_rec (id, sign_prefix id sign) l)
 *)
@@ -148,14 +149,14 @@ let rec add_prods_sign env sigma t =
 
 (* [dep_option] indicates wether the inversion lemma is dependent or not.
    If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then
-   the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) 
+   the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H)
    where P:(x_bar:T_bar)(H:(I x_bar))[sort].
    The generalisation of such a goal at the moment of the dependent case should
    be easy.
 
    If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the
    variables occurring in [I], then the stated goal will be:
-    (x_bar:T_bar)(I t_bar)->(P x_bar) 
+    (x_bar:T_bar)(I t_bar)->(P x_bar)
    where P: P:(x_bar:T_bar)[sort].
 *)
 
@@ -166,7 +167,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
   let pty,goal =
     if dep_option  then
       let pty = make_arity env true indf sort in
-      let goal = 
+      let goal =
 	mkProd
 	  (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1]))
       in
@@ -177,11 +178,11 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
       let revargs,ownsign =
 	fold_named_context
 	  (fun env (id,_,_ as d) (revargs,hyps) ->
-             if List.mem id ivars then 
+             if List.mem id ivars then
 	       ((mkVar id)::revargs,add_named_decl d hyps)
-	     else 
+	     else
 	       (revargs,hyps))
-          env ~init:([],[]) 
+          env ~init:([],[])
       in
       let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in
       let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in
@@ -191,6 +192,10 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
   let extenv = push_named (p,None,npty) env in
   extenv, goal
 
+let whd_meta_from_map metamap c = match kind_of_term c with
+  | Meta p -> (try List.assoc p metamap with Not_found -> c)
+  | _ -> c
+
 (* [inversion_scheme sign I]
 
    Given a local signature, [sign], and an instance of an inductive
@@ -203,14 +208,14 @@ let inversion_scheme env sigma t sort dep_option inv_op =
   let ind =
     try find_rectype env sigma i
     with Not_found ->
-      errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) 
+      errorlabstrm "inversion_scheme" (no_inductive_inconstr env i)
   in
   let (invEnv,invGoal) =
-    compute_first_inversion_scheme env sigma ind sort dep_option 
+    compute_first_inversion_scheme env sigma ind sort dep_option
   in
-  assert 
-    (list_subset 
-       (global_vars env invGoal) 
+  assert
+    (list_subset
+       (global_vars env invGoal)
        (ids_of_named_context (named_context invEnv)));
   (*
     errorlabstrm "lemma_inversion"
@@ -218,7 +223,7 @@ let inversion_scheme env sigma t sort dep_option inv_op =
   *)
   let invSign = named_context_val invEnv in
   let pfs = mk_pftreestate (mk_goal invSign invGoal None) in
-  let pfs = solve_pftreestate (tclTHEN intro (onLastHyp inv_op)) pfs in
+  let pfs = solve_pftreestate (tclTHEN intro (onLastHypId inv_op)) pfs in
   let (pfterm,meta_types) = extract_open_pftreestate pfs in
   let global_named_context = Global.named_context () in
   let ownSign =
@@ -226,7 +231,7 @@ let inversion_scheme env sigma t sort dep_option inv_op =
       (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 
+      invEnv ~init:empty_named_context
   in
   let (_,ownSign,mvb) =
     List.fold_left
@@ -234,23 +239,23 @@ let inversion_scheme env sigma t sort dep_option inv_op =
          let h = next_ident_away (id_of_string "H") avoid in
 	 (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb))
       (ids_of_context invEnv, ownSign, [])
-      meta_types 
+      meta_types
   in
-  let invProof = 
+  let invProof =
     it_mkNamedLambda_or_LetIn
-      (local_strong (fun _ -> whd_meta mvb) Evd.empty pfterm) ownSign 
+      (local_strong (fun _ -> whd_meta_from_map mvb) Evd.empty pfterm) ownSign
   in
   invProof
 
 let add_inversion_lemma name env sigma t sort dep inv_op =
   let invProof = inversion_scheme env sigma t sort dep inv_op in
-  let _ = 
+  let _ =
     declare_constant name
-    (DefinitionEntry 
+    (DefinitionEntry
        { const_entry_body = invProof;
          const_entry_type = None;
          const_entry_opaque = false;
-	 const_entry_boxed = true && (Flags.boxed_definitions())}, 
+	 const_entry_boxed = true && (Flags.boxed_definitions())},
      IsProof Lemma)
   in ()
 
@@ -262,11 +267,11 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
 let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op =
   let pts = get_pftreestate() in
   let gl = nth_goal_of_pftreestate n pts in
-  let t = 
+  let t =
     try pf_get_hyp_typ gl id
     with Not_found -> Pretype_errors.error_var_not_found_loc loc id in
   let env = pf_env gl and sigma = project gl in
-(* Pourquoi ??? 
+(* Pourquoi ???
   let fv = global_vars env t in
   let thin_ids = thin_ids (hyps,fv) in
   if not(list_subset thin_ids fv) then
@@ -275,14 +280,14 @@ let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op =
 	 str"free variables in the types of an inductive" ++ spc () ++
 	 str"which are not free in its instance."); *)
   add_inversion_lemma na env sigma t sort dep_option inv_op
-   
+
 let add_inversion_lemma_exn na com comsort bool tac =
   let env = Global.env () and sigma = Evd.empty in
   let c = Constrintern.interp_type sigma env com in
   let sort = Pretyping.interp_sort comsort in
   try
     add_inversion_lemma na env sigma c sort bool tac
-  with 
+  with
     |   UserError ("Case analysis",s) -> (* référence à Indrec *)
 	  errorlabstrm "Inv needs Nodep Prop Set" s
 
@@ -296,26 +301,26 @@ let lemInv id c gls =
     let clause = mk_clenv_type_of gls c in
     let clause = clenv_constrain_last_binding (mkVar id) clause in
     Clenvtac.res_pf clause ~allow_K:true gls
-  with 
+  with
     | NoSuchBinding ->
 	errorlabstrm ""
 	  (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma."))
-    |  UserError (a,b) -> 
-	 errorlabstrm "LemInv" 
-	   (str "Cannot refine current goal with the lemma " ++ 
-	      pr_lconstr_env (Global.env()) c) 
+    | UserError (a,b) ->
+	 errorlabstrm "LemInv"
+	   (str "Cannot refine current goal with the lemma " ++
+	      pr_lconstr_env (Global.env()) c)
 
 let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
 
 let lemInvIn id c ids gls =
   let hyps = List.map (pf_get_hyp gls) ids in
   let intros_replace_ids gls =
-    let nb_of_new_hyp  = nb_prod (pf_concl gls) - List.length ids in 
-    if nb_of_new_hyp < 1  then 
+    let nb_of_new_hyp  = nb_prod (pf_concl gls) - List.length ids in
+    if nb_of_new_hyp < 1  then
       intros_replacing ids gls
-    else 
+    else
       (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls
-  in 
+  in
   ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c))
     (intros_replace_ids)) gls)
 
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
index 3e12f770..b4b5737b 100644
--- a/tactics/leminv.mli
+++ b/tactics/leminv.mli
@@ -8,7 +8,7 @@ open Topconstr
 val lemInv_gen : quantified_hypothesis -> constr -> tactic
 val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic
 
-val lemInv_clause : 
+val lemInv_clause :
   quantified_hypothesis -> constr -> identifier list -> tactic
 
 val inversion_lemma_from_goal :
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
index b94ae2dd..7d6e1c4c 100644
--- a/tactics/nbtermdn.ml
+++ b/tactics/nbtermdn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nbtermdn.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -26,63 +26,123 @@ open Libnames
 (* The former comments are from Chet.
    See the module dn.ml for further explanations.
    Eduardo (5/8/97) *)
+module Make = 
+  functor (Y:Map.OrderedType) ->
+struct
+  module X = struct
+    type t = constr_pattern*int
+    let compare = Pervasives.compare
+  end
+
+  module Term_dn = Termdn.Make(Y)
+  open Term_dn
+  module Z = struct 
+     type t = Term_dn.term_label
+     let compare x y =  
+       let make_name n =
+	 match n with
+	 | GRLabel(ConstRef con) -> 
+	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
+	 | GRLabel(IndRef (kn,i)) ->
+	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
+	 | GRLabel(ConstructRef ((kn,i),j ))->
+	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
+	 | k -> k
+       in
+	 Pervasives.compare (make_name x) (make_name y)
+  end
+
+  module Dn = Dn.Make(X)(Z)(Y)
+  module Bounded_net = Btermdn.Make(Y)
+
+    
+type 'na t = {
+  mutable table : ('na,constr_pattern * Y.t) Gmap.t;
+  mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t }
 
-type ('na,'a) t = {
-  mutable table : ('na,constr_pattern * 'a) Gmap.t;
-  mutable patterns : (global_reference option,'a Btermdn.t) Gmap.t }
 
-type ('na,'a) frozen_t = 
-    ('na,constr_pattern * 'a) Gmap.t
-    * (global_reference option,'a Btermdn.t) Gmap.t
+type 'na frozen_t = 
+    ('na,constr_pattern * Y.t) Gmap.t
+    * (Term_dn.term_label option, Bounded_net.t) Gmap.t
 
 let create () =
   { table = Gmap.empty;
     patterns = Gmap.empty }
 
 let get_dn dnm hkey =
-  try Gmap.find hkey dnm with Not_found -> Btermdn.create ()
+  try Gmap.find hkey dnm with Not_found -> Bounded_net.create ()
 
 let add dn (na,(pat,valu)) =
-  let hkey = Option.map fst (Termdn.constr_pat_discr pat) in 
+  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
   dn.table <- Gmap.add na (pat,valu) dn.table;
   let dnm = dn.patterns in
-  dn.patterns <- Gmap.add hkey (Btermdn.add None (get_dn dnm hkey) (pat,valu)) dnm
-    
+  dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm
+
 let rmv dn na =
   let (pat,valu) = Gmap.find na dn.table in
-  let hkey = Option.map fst (Termdn.constr_pat_discr pat) in 
+  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
   dn.table <- Gmap.remove na dn.table;
   let dnm = dn.patterns in
-  dn.patterns <- Gmap.add hkey (Btermdn.rmv None (get_dn dnm hkey) (pat,valu)) dnm
+  dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm
 
 let in_dn dn na = Gmap.mem na dn.table
-			  
+
 let remap ndn na (pat,valu) =
   rmv ndn na;
   add ndn (na,(pat,valu))
 
+let decomp = 
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Cast (c1,_,_) -> decrec acc c1
+    | _ -> (c,acc)
+  in 
+  decrec []
+
+  let constr_val_discr t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+    | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+    | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+    | Const _ -> Dn.Everything
+    | _ -> Dn.Nothing
+
+let constr_val_discr_st (idpred,cpred) t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
+    | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+    | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+    | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+    | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
+    | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
+    | Sort s -> Dn.Label(Term_dn.SortLabel (Some s), [])
+    | Evar _ -> Dn.Everything
+    | _ -> Dn.Nothing
+
 let lookup dn valu =
-  let hkey = 
-    match (Termdn.constr_val_discr valu) with 
+  let hkey =
+    match (constr_val_discr valu) with
     | Dn.Label(l,_) -> Some l
     | _ -> None
-  in 
-  try Btermdn.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> []
+  in
+  try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> []
 
 let app f dn = Gmap.iter f dn.table
-		       
+
 let dnet_depth = Btermdn.dnet_depth
-		   
+
 let freeze dn = (dn.table, dn.patterns)
 
 let unfreeze (fnm,fdnm) dn =
   dn.table <- fnm;
   dn.patterns <- fdnm
 
-let empty dn = 
+let empty dn =
   dn.table <- Gmap.empty;
   dn.patterns <- Gmap.empty
 
-let to2lists dn = 
+let to2lists dn =
   (Gmap.to_list dn.table, Gmap.to_list dn.patterns)
-
+end
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
index 579b24d4..027ea573 100644
--- a/tactics/nbtermdn.mli
+++ b/tactics/nbtermdn.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nbtermdn.mli 6427 2004-12-07 17:41:10Z sacerdot $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -15,24 +15,37 @@ open Libnames
 (*i*)
 
 (* Named, bounded-depth, term-discrimination nets. *)
-
-type ('na,'a) t
-type ('na,'a) frozen_t
-
-val create : unit -> ('na,'a) t
-
-val add : ('na,'a) t -> ('na * (constr_pattern * 'a)) -> unit
-val rmv : ('na,'a) t -> 'na -> unit
-val in_dn : ('na,'a) t -> 'na -> bool
-val remap : ('na,'a) t -> 'na -> (constr_pattern * 'a) -> unit
-
-val lookup : ('na,'a) t -> constr -> (constr_pattern * 'a) list
-val app : ('na -> (constr_pattern * 'a) -> unit) -> ('na,'a) t -> unit
-
-val dnet_depth : int ref
-
-val freeze : ('na,'a) t -> ('na,'a) frozen_t
-val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit
-val empty : ('na,'a) t -> unit
-val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * 
-                             (global_reference option * 'a Btermdn.t) list
+module Make :
+  functor (Y:Map.OrderedType) ->
+sig
+  
+  module Term_dn : sig     
+    type term_label = 
+      | GRLabel of global_reference
+      | ProdLabel 
+      | LambdaLabel
+      | SortLabel of sorts option
+  end 
+    
+  type 'na t
+  type 'na frozen_t
+    
+  val create : unit -> 'na t
+    
+  val add : 'na t -> ('na * (constr_pattern * Y.t)) -> unit
+  val rmv : 'na t -> 'na -> unit
+  val in_dn : 'na t -> 'na -> bool
+  val remap : 'na t -> 'na -> (constr_pattern * Y.t) -> unit
+    
+  val lookup : 'na t -> constr -> (constr_pattern * Y.t) list
+  val app : ('na -> (constr_pattern * Y.t) -> unit) -> 'na t -> unit
+    
+  val dnet_depth : int ref
+    
+
+  val freeze : 'na t -> 'na frozen_t
+  val unfreeze : 'na frozen_t -> 'na t -> unit
+  val empty : 'na t -> unit
+  val to2lists : 'na t -> ('na * (constr_pattern * Y.t)) list * 
+    (Term_dn.term_label option * Btermdn.Make(Y).t) list
+end
diff --git a/tactics/refine.ml b/tactics/refine.ml
index ff3f0887..cbca38d0 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refine.ml 13129 2010-06-13 14:23:55Z herbelin $ *)
+(* $Id$ *)
 
 (* JCF -- 6 janvier 1998  EXPERIMENTAL *)
 
@@ -16,19 +16,19 @@
  *  où les trous sont typés -- et que les sous-buts correspondants
  *  soient engendrés pour finir la preuve.
  *
- *  Exemple : 
+ *  Exemple :
  *    J'ai le but
- *        (x:nat) { y:nat | (minus y x) = x }
+ *        forall (x:nat), { y:nat | (minus y x) = x }
  *    et je donne la preuve incomplète
- *        [x:nat](exist nat [y:nat]((minus y x)=x) (plus x x) ?)
+ *        fun (x:nat) => exist nat [y:nat]((minus y x)=x) (plus x x) ?
  *    ce qui engendre le but
- *        (minus (plus x x) x)=x
+ *        (minus (plus x x) x) = x
  *)
 
 (*  Pour cela, on procède de la manière suivante :
  *
  *  1. Un terme de preuve incomplet est un terme contenant des variables
- *     existentielles Evar i.e. "?" en syntaxe concrète.
+ *     existentielles Evar i.e. "_" en syntaxe concrète.
  *     La résolution de ces variables n'est plus nécessairement totale
  *     (ise_resolve called with fail_evar=false) et les variables
  *     existentielles restantes sont remplacées par des méta-variables
@@ -38,8 +38,10 @@
  *  2. On met ensuite le terme "à plat" i.e. on n'autorise des MV qu'au
  *     permier niveau et pour chacune d'elles, si nécessaire, on donne
  *     à son tour un terme de preuve incomplet pour la résoudre.
- *     Exemple: le terme (f a ? [x:nat](e ?)) donne
- *         (f a ?1 ?2) avec ?2 => [x:nat]?3 et ?3 => (e ?4)
+ *     Exemple: le terme (f a _ (fun (x:nat) => e _)) donne
+ *         (f a ?1 ?2) avec:
+ *           - ?2 := fun (x:nat) => ?3
+ *           - ?3 := e ?4
  *         ?1 et ?4 donneront des buts
  *
  *  3. On écrit ensuite une tactique tcc qui engendre les sous-buts
@@ -51,6 +53,7 @@ open Util
 open Names
 open Term
 open Termops
+open Namegen
 open Tacmach
 open Sign
 open Environ
@@ -60,7 +63,7 @@ open Tactics
 open Tacticals
 open Printer
 
-type term_with_holes = TH of constr * metamap * sg_proofs
+type term_with_holes = TH of constr * meta_type_map * sg_proofs
 and  sg_proofs       = (term_with_holes option) list
 
 (* pour debugger *)
@@ -70,12 +73,12 @@ let rec pp_th (TH(c,mm,sg)) =
 			      (* pp_mm mm ++ fnl () ++ *)
 			   pp_sg sg) ++ str "]")
 and pp_mm l =
-  hov 0 (prlist_with_sep (fun _ -> (fnl ())) 
+  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
 	   (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l)
 and pp_sg sg =
   hov 0 (prlist_with_sep (fun _ -> (fnl ()))
 	   (function None -> (str"None") | Some th -> (pp_th th)) sg)
-     
+
 (*  compute_metamap : constr -> 'a evar_map -> term_with_holes
  *  réalise le 2. ci-dessus
  *
@@ -84,7 +87,7 @@ and pp_sg sg =
  *  par un terme de preuve incomplet (Some c).
  *
  *  On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1"
- *  -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y 
+ *  -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y
  *  a de meta-variables dans c. On suppose de plus que l'ordre dans la
  *  meta_map correspond à celui des buts qui seront engendrés par le refine.
  *)
@@ -101,11 +104,14 @@ let replace_by_meta env sigma = function
 	| Lambda (Anonymous,c1,c2) when isCast c2 ->
 	    let _,_,t = destCast c2 in mkArrow c1 t
 	| _ -> (* (App _ | Case _) -> *)
-	    Retyping.get_type_of_with_meta env sigma mm c
+	    let sigma' =
+	      List.fold_right (fun (m,t) sigma -> Evd.meta_declare m t sigma)
+		mm sigma in
+	    Retyping.get_type_of env sigma' c
 	(*
 	| Fix ((_,j),(v,_,_)) ->
 	    v.(j) (* en pleine confiance ! *)
-	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" 
+	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)"
         *)
       in
       if occur_meta ty then
@@ -119,28 +125,28 @@ let replace_in_array keep_length env sigma a =
     raise NoMeta;
   let a' = Array.map (function
 			| (TH (c,mm,[])) when not keep_length -> c,mm,[]
-			| th -> replace_by_meta env sigma th) a 
+			| th -> replace_by_meta env sigma th) a
   in
   let v' = Array.map pi1 a' in
   let mm = Array.fold_left (@) [] (Array.map pi2 a') in
   let sgp = Array.fold_left (@) [] (Array.map pi3 a') in
   v',mm,sgp
-    
+
 let fresh env n =
   let id = match n with Name x -> x | _ -> id_of_string "_H" in
-  next_global_ident_away true id (ids_of_named_context (named_context env))
+  next_ident_away_in_goal id (ids_of_named_context (named_context env))
 
 let rec compute_metamap env sigma c = match kind_of_term c with
   (* le terme est directement une preuve *)
   | (Const _ | Evar _ | Ind _ | Construct _ |
-    Sort _ | Var _ | Rel _) -> 
+    Sort _ | Var _ | Rel _) ->
       TH (c,[],[])
 
   (* le terme est une mv => un but *)
   | Meta n ->
       TH (c,[],[None])
 
-  | Cast (m,_, ty) when isMeta m -> 
+  | Cast (m,_, ty) when isMeta m ->
       TH (c,[destMeta m,ty],[None])
 
 
@@ -153,7 +159,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with
 	(* terme de preuve complet *)
 	| TH (_,_,[]) -> TH (c,[],[])
-	(* terme de preuve incomplet *)    
+	(* terme de preuve incomplet *)
 	| th ->
 	    let m,mm,sgp = replace_by_meta env' sigma th in
 	    TH (mkLambda (Name v,c1,m), mm, sgp)
@@ -167,13 +173,13 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       begin match th1,th2 with
 	(* terme de preuve complet *)
 	| TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[])
-	(* terme de preuve incomplet *)    
+	(* terme de preuve incomplet *)
 	| TH (c1,mm1,sgp1), TH (c2,mm2,sgp2) ->
 	    let m1,mm1,sgp1 =
-              if sgp1=[] then (c1,mm1,[]) 
+              if sgp1=[] then (c1,mm1,[])
               else replace_by_meta env sigma th1 in
 	    let m2,mm2,sgp2 =
-              if sgp2=[] then (c2,mm2,[]) 
+              if sgp2=[] then (c2,mm2,[])
               else replace_by_meta env' sigma th2 in
 	    TH (mkNamedLetIn v m1 t1 m2, mm1@mm2, sgp1@sgp2)
       end
@@ -214,7 +220,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       let env' = push_named_rec_types (fi',ai,v) env in
       let a = Array.map
 		(compute_metamap env' sigma)
-		(Array.map (substl (List.map mkVar (Array.to_list vi))) v) 
+		(Array.map (substl (List.map mkVar (Array.to_list vi))) v)
       in
       begin
 	try
@@ -224,12 +230,12 @@ let rec compute_metamap env sigma c = match kind_of_term c with
 	with NoMeta ->
 	  TH (c,[],[])
       end
-	      
+
   (* Cast. Est-ce bien exact ? *)
   | Cast (c,_,t) -> compute_metamap env sigma c
       (*let TH (c',mm,sgp) = compute_metamap sign c in
 	TH (mkCast (c',t),mm,sgp) *)
-      
+
   (* Produit. Est-ce bien exact ? *)
   | Prod (_,_,_) ->
       if occur_meta c then
@@ -244,7 +250,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       let env' = push_named_rec_types (fi',ai,v) env in
       let a = Array.map
 		(compute_metamap env' sigma)
-		(Array.map (substl (List.map mkVar (Array.to_list vi))) v) 
+		(Array.map (substl (List.map mkVar (Array.to_list vi))) v)
       in
       begin
 	try
@@ -257,7 +263,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with
 
 
 (*  tcc_aux : term_with_holes -> tactic
- * 
+ *
  *  Réalise le 3. ci-dessus
  *)
 
@@ -270,11 +276,11 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 
     | Cast (c,_,_), _ when isMeta c ->
 	tclIDTAC gl
-	  
+
     (* terme pur => refine *)
     | _,[] ->
 	refine c gl
-	
+
     (* abstraction => intro *)
     | Lambda (Name id,_,m), _ ->
 	assert (isMeta (strip_outer_cast m));
@@ -282,18 +288,18 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 	  | [None] -> intro_mustbe_force id gl
 	  | [Some th] ->
               tclTHEN (introduction id)
-                (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl
+                (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) gl
 	  | _ -> assert false
 	end
 
     | Lambda (Anonymous,_,m), _ -> (* if anon vars are allowed in evars *)
         assert (isMeta (strip_outer_cast m));
 	begin match sgp with
-	  | [None] -> tclTHEN intro (onLastHyp (fun id -> clear [id])) gl
+	  | [None] -> tclTHEN intro (onLastHypId (fun id -> clear [id])) gl
 	  | [Some th] ->
               tclTHEN
                 intro
-                (onLastHyp (fun id -> 
+                (onLastHypId (fun id ->
                   tclTHEN
                     (clear [id])
                     (tcc_aux (mkVar (*dummy*) id::subst) th))) gl
@@ -304,29 +310,29 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
     | LetIn (Name id,c1,t1,c2), _ when not (isMeta (strip_outer_cast c1)) ->
 	let c = pf_concl gl in
 	let newc = mkNamedLetIn id c1 t1 c in
-	tclTHEN 
-	  (change_in_concl None newc) 
-	  (match sgp with 
+	tclTHEN
+	  (change_in_concl None newc)
+	  (match sgp with
 	     | [None] -> introduction id
 	     | [Some th] ->
                  tclTHEN (introduction id)
-                   (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th))
-	     | _ -> assert false) 
+                   (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th))
+	     | _ -> assert false)
 	  gl
 
     (* let in with holes in the body => unable to handle dependency
        because of evars limitation, use non dependent assert instead *)
     | LetIn (Name id,c1,t1,c2), _ ->
 	tclTHENS
-          (assert_tac (Name id) t1) 
-	  [(match List.hd sgp with 
+          (assert_tac (Name id) t1)
+	  [(match List.hd sgp with
 	     | None -> tclIDTAC
-	     | Some th -> onLastHyp (fun id -> tcc_aux (mkVar id::subst) th));
-           (match List.tl sgp with 
+	     | Some th -> onLastHypId (fun id -> tcc_aux (mkVar id::subst) th));
+           (match List.tl sgp with
 	     | [] -> refine (subst1 (mkVar id) c2)  (* a complete proof *)
 	     | [None] -> tclIDTAC                   (* a meta *)
 	     | [Some th] ->                         (* a partial proof *)
-                 onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)
+                 onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)
              | _ -> assert false)]
           gl
 
@@ -339,10 +345,9 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 	let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in
 	let firsts,lasts = list_chop j (Array.to_list fixes) in
 	tclTHENS
-	  (mutual_fix_with_index 
-	    (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j)
+	  (mutual_fix (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j)
 	  (List.map (function
-		       | None -> tclIDTAC 
+		       | None -> tclIDTAC
 		       | Some th -> tcc_aux subst th) sgp)
 	  gl
 
@@ -355,9 +360,9 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 	let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in
 	let firsts,lasts = list_chop j (Array.to_list cofixes) in
 	tclTHENS
-	  (mutual_cofix_with_index (out_name fi.(j)) (firsts@List.tl lasts) j)
+	  (mutual_cofix (out_name fi.(j)) (firsts@List.tl lasts) j)
 	  (List.map (function
-		       | None -> tclIDTAC 
+		       | None -> tclIDTAC
 		       | Some th -> tcc_aux subst th) sgp)
 	  gl
 
@@ -374,13 +379,10 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 
 let refine (evd,c) gl =
   let sigma = project gl in
-  let evd = Evd.evars_of (Typeclasses.resolve_typeclasses
-			     ~onlyargs:true ~fail:false (pf_env gl) 
-			     (Evd.create_evar_defs evd)) 
-  in
+  let evd = Typeclasses.resolve_typeclasses ~onlyargs:true (pf_env gl) evd in
   let c = Evarutil.nf_evar evd c in
   let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in
-  (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise 
+  (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise
      complicated to update meta types when passing through a binder *)
   let th = compute_metamap (pf_env gl) evd c in
   tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl
diff --git a/tactics/refine.mli b/tactics/refine.mli
index aae1f5e1..89e53167 100644
--- a/tactics/refine.mli
+++ b/tactics/refine.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: refine.mli 6099 2004-09-12 11:38:09Z barras $ i*)
+(*i $Id$ i*)
 
 open Tacmach
 
diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4
new file mode 100644
index 00000000..3447f607
--- /dev/null
+++ b/tactics/rewrite.ml4
@@ -0,0 +1,1542 @@
+(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: rewrite.ml4 11981 2009-03-16 08:18:53Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Namegen
+open Term
+open Termops
+open Sign
+open Reduction
+open Proof_type
+open Proof_trees
+open Declarations
+open Tacticals
+open Tacmach
+open Evar_refiner
+open Tactics
+open Pattern
+open Clenv
+open Auto
+open Rawterm
+open Hiddentac
+open Typeclasses
+open Typeclasses_errors
+open Classes
+open Topconstr
+open Pfedit
+open Command
+open Libnames
+open Evd
+
+(** Typeclass-based generalized rewriting. *)
+
+let check_required_library d =
+  let d' = List.map id_of_string d in
+  let dir = make_dirpath (List.rev d') in
+  if not (Library.library_is_loaded dir) then
+    error ("Library "^(list_last d)^" has to be required first.")
+
+let classes_dirpath =
+  make_dirpath (List.map id_of_string ["Classes";"Coq"])
+
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else check_required_library ["Coq";"Setoids";"Setoid"]
+
+let proper_class =
+  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Proper"))))
+
+let proper_proxy_class =
+  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.ProperProxy"))))
+
+let proper_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force proper_class).cl_projs))))
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+
+let try_find_global_reference dir s =
+  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in
+    Nametab.global_of_path sp
+
+let try_find_reference dir s =
+  constr_of_global (try_find_global_reference dir s)
+
+let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s
+let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
+let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
+let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
+let coq_eq_rect = lazy (gen_constant ["Init"; "Logic"] "eq_rect")
+let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal")
+let iff = lazy (gen_constant ["Init"; "Logic"] "iff")
+let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
+let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
+let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
+let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id")
+
+let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive")
+let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity")
+let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity")
+
+let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric")
+let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry")
+let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry")
+
+let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive")
+let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity")
+let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity")
+
+let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *)
+			   ["Program"; "Basics"] "flip")
+
+let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |])
+(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *)
+
+let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement")
+let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation")
+let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation")
+
+let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep")
+let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
+
+let equivalence = lazy (gen_constant ["Classes"; "RelationClasses"] "Equivalence")
+let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
+
+let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation")
+let is_subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "is_subrelation")
+let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation")
+let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation")
+
+let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation")
+let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
+(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *)
+
+let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT")
+
+let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
+
+let setoid_equiv = lazy (gen_constant ["Classes"; "SetoidClass"] "equiv")
+let setoid_proper = lazy (gen_constant ["Classes"; "SetoidClass"] "setoid_proper")
+let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
+
+let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation")
+let rewrite_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "rewrite_relation")
+
+let arrow_morphism a b =
+  if isprop a && isprop b then
+    Lazy.force impl
+  else
+    mkApp(Lazy.force arrow, [|a;b|])
+
+let setoid_refl pars x =
+  applistc (Lazy.force setoid_refl_proj) (pars @ [x])
+
+let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl)
+
+let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl)
+
+let is_applied_rewrite_relation env sigma rels t =
+  match kind_of_term t with
+  | App (c, args) when Array.length args >= 2 ->
+      let head = if isApp c then fst (destApp c) else c in
+	if eq_constr (Lazy.force coq_eq) head then None
+	else
+	  (try
+	      let params, args = array_chop (Array.length args - 2) args in
+	      let env' = Environ.push_rel_context rels env in
+	      let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in
+	      let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in
+	      let _ = Typeclasses.resolve_one_typeclass env' evd inst in
+		Some (it_mkProd_or_LetIn t rels)
+	  with _ -> None)
+  | _ -> None
+
+let _ =
+  Equality.register_is_applied_rewrite_relation is_applied_rewrite_relation
+
+let split_head = function
+    hd :: tl -> hd, tl
+  | [] -> assert(false)
+
+let new_goal_evar (goal,cstr) env t =
+  let goal', t = Evarutil.new_evar goal env t in
+    (goal', cstr), t
+
+let new_cstr_evar (goal,cstr) env t =
+  let cstr', t = Evarutil.new_evar cstr env t in
+    (goal, cstr'), t
+
+let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) (f : 'a -> constr) =
+  let new_evar evars env t =
+    new_cstr_evar evars env
+      (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
+  in
+  let mk_relty evars env ty obj =
+    match obj with
+      | None ->
+	  let relty = mk_relation ty in
+	    new_evar evars env relty
+      | Some x -> evars, f x
+  in
+  let rec aux env evars ty l =
+    let t = Reductionops.whd_betadeltaiota env (fst evars) ty in
+      match kind_of_term t, l with
+      | Prod (na, ty, b), obj :: cstrs ->
+	  if noccurn 1 b (* non-dependent product *) then
+	    let ty = Reductionops.nf_betaiota (fst evars) ty in
+	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
+	    let evars, relty = mk_relty evars env ty obj in
+	    let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in
+	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
+	  else
+	    let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in
+	    let ty = Reductionops.nf_betaiota (fst evars) ty in
+	    let pred = mkLambda (na, ty, b) in
+	    let liftarg = mkLambda (na, ty, arg) in
+	    let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in
+	      if obj = None then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
+	      else error "build_signature: no constraint can apply on a dependent argument"
+      | _, obj :: _ -> anomaly "build_signature: not enough products"
+      | _, [] ->
+	  (match finalcstr with
+	  | None ->
+	      let t = Reductionops.nf_betaiota (fst evars) ty in
+	      let evars, rel = mk_relty evars env t None in
+		evars, t, rel, [t, Some rel]
+	  | Some codom -> let (t, rel) = codom in
+			    evars, t, rel, [t, Some rel])
+  in aux env evars m cstrs
+
+let proper_proof env evars carrier relation x =
+  let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |])
+  in new_cstr_evar evars env goal
+
+let find_class_proof proof_type proof_method env evars carrier relation =
+  try
+    let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in
+    let evars, c = Typeclasses.resolve_one_typeclass env evars goal in
+      mkApp (Lazy.force proof_method, [| carrier; relation; c |])
+  with e when Logic.catchable_exception e -> raise Not_found
+
+let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
+let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
+let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
+
+exception FoundInt of int
+
+let array_find (arr: 'a array) (pred: int -> 'a -> bool): int =
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done;
+    raise Not_found
+  with FoundInt i -> i
+
+type hypinfo = {
+  cl : clausenv;
+  prf : constr;
+  car : constr;
+  rel : constr;
+  l2r : bool;
+  c1 : constr;
+  c2 : constr;
+  c  : constr option;
+  abs : (constr * types) option;
+}
+
+let evd_convertible env evd x y =
+  try ignore(Evarconv.the_conv_x env x y evd); true
+  with _ -> false
+
+let decompose_applied_relation env sigma c left2right =
+  let ctype = Typing.type_of env sigma c in
+  let find_rel ty =
+    let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in
+    let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
+    let rec split_last_two = function
+      | [c1;c2] -> [],(c1, c2)
+      | x::y::z ->
+	  let l,res = split_last_two (y::z) in x::l, res
+      | _ -> error "The term provided is not an applied relation." in
+    let others,(c1,c2) = split_last_two args in
+    let ty1, ty2 =
+      Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
+    in
+      if not (evd_convertible env eqclause.evd ty1 ty2) then None
+      else
+	Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
+	       car=ty1; rel=mkApp (equiv, Array.of_list others);
+	       l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None }
+  in
+    match find_rel ctype with
+    | Some c -> c
+    | None ->
+	let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *)
+	match find_rel (it_mkProd_or_LetIn t' ctx) with
+	| Some c -> c
+	| None -> error "The term does not end with an applied homogeneous relation."
+
+let rewrite_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly = true;
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.resolve_evars = true;
+  Unification.use_evars_pattern_unification = true;
+}
+
+let conv_transparent_state = (Idpred.empty, Cpred.full)
+
+let rewrite2_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+  Unification.use_metas_eagerly = true;
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.resolve_evars = true;
+  Unification.use_evars_pattern_unification = true;
+}
+
+let setoid_rewrite_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+  Unification.use_metas_eagerly = true;
+  Unification.modulo_delta = conv_transparent_state;
+  Unification.resolve_evars = true;
+  Unification.use_evars_pattern_unification = true;
+}
+
+let convertible env evd x y =
+  Reductionops.is_conv env evd x y
+
+let allowK = true
+
+let refresh_hypinfo env sigma hypinfo =
+  if hypinfo.abs = None then
+    let {l2r=l2r; c=c;cl=cl} = hypinfo in
+      match c with
+	| Some c ->
+	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
+	    decompose_applied_relation env cl.evd c l2r;
+	| _ -> hypinfo
+  else hypinfo
+
+let unify_eqn env sigma hypinfo t =
+  if isEvar t then None
+  else try
+    let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in
+    let left = if l2r then c1 else c2 in
+    let env', prf, c1, c2, car, rel =
+      match abs with
+      | Some (absprf, absprfty) ->
+	  let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in
+	    env', prf, c1, c2, car, rel
+      | None ->
+	  let env' =
+	    try clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl
+	    with Pretype_errors.PretypeError _ ->
+	      (* For Ring essentially, only when doing setoid_rewrite *)
+	      clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl
+	  in
+	  let env' =
+	    let mvs = clenv_dependent false env' in
+	      clenv_pose_metas_as_evars env' mvs
+	  in
+	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in
+	  let env' = { env' with evd = evd' } in
+	  let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in
+	  let c1 = nf c1 and c2 = nf c2
+	  and car = nf car and rel = nf rel
+	  and prf = nf (Clenv.clenv_value env') in
+	  let ty1 = Typing.type_of env'.env env'.evd c1
+	  and ty2 = Typing.type_of env'.env env'.evd c2
+	  in
+	    if convertible env env'.evd ty1 ty2 then (
+	      if occur_meta prf then
+		hypinfo := refresh_hypinfo env sigma !hypinfo;
+	      env', prf, c1, c2, car, rel)
+	    else raise Reduction.NotConvertible
+    in
+    let res =
+      if l2r then (prf, (car, rel, c1, c2))
+      else
+	try (mkApp (get_symmetric_proof env Evd.empty car rel,
+		   [| c1 ; c2 ; prf |]),
+	    (car, rel, c2, c1))
+	with Not_found ->
+	  (prf, (car, inverse car rel, c2, c1))
+    in Some (env', res)
+  with e when Class_tactics.catchable e -> None
+
+let unfold_impl t =
+  match kind_of_term t with
+    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
+	mkProd (Anonymous, a, lift 1 b)
+    | _ -> assert false
+
+let unfold_id t =
+  match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b
+    | _ -> assert false
+
+let unfold_all t =
+  match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+	(match kind_of_term b with
+	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
+	  | _ -> assert false)
+    | _ -> assert false
+
+let decomp_prod env evm n c =
+  snd (Reductionops.splay_prod_n env evm n c)
+
+let rec decomp_pointwise n c =
+  if n = 0 then c
+  else
+    match kind_of_term c with
+      | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb
+      | _ -> raise Not_found
+
+let lift_cstr env sigma evars args cstr =
+  let cstr =
+    let start =
+      match cstr with
+      | Some codom -> codom
+      | None ->
+	  let car = Evarutil.e_new_evar evars env (new_Type ()) in
+	  let rel = Evarutil.e_new_evar evars env (mk_relation car) in
+	    (car, rel)
+    in
+      Array.fold_right
+	(fun arg (car, rel) ->
+	  let ty = Typing.type_of env sigma arg in
+	  let car' = mkProd (Anonymous, ty, car) in
+	  let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in
+	    (car', rel'))
+	args start
+  in Some cstr
+
+let unlift_cstr env sigma = function
+  | None -> None
+  | Some codom -> Some (decomp_pointwise 1 codom)
+
+type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
+
+let default_flags = { under_lambdas = true; on_morphisms = true; }
+
+type evars = evar_map * evar_map (* goal evars, constraint evars *)
+
+type rewrite_result_info = {
+  rew_car : constr;
+  rew_rel : constr;
+  rew_from : constr;
+  rew_to : constr;
+  rew_prf : constr;
+  rew_evars : evars;
+}
+
+type rewrite_result = rewrite_result_info option
+
+type strategy = Environ.env -> evar_map -> constr -> types ->
+  constr option -> evars -> rewrite_result option
+
+let resolve_subrelation env sigma car rel rel' res =
+  if eq_constr rel rel' then res
+  else
+(*   try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *)
+(* 	{ res with rew_evars = evd' } *)
+(*   with NotConvertible -> *)
+    let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in
+    let evars, subrel = new_cstr_evar res.rew_evars env app in
+      { res with
+	rew_prf = mkApp (subrel, [| res.rew_from ; res.rew_to ; res.rew_prf |]);
+	rew_rel = rel';
+	rew_evars = evars }
+
+
+let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars =
+  let evars, morph_instance, proj, sigargs, m', args, args' =
+    let first = try (array_find args' (fun i b -> b <> None)) 
+      with Not_found -> raise (Invalid_argument "resolve_morphism") in
+    let morphargs, morphobjs = array_chop first args in
+    let morphargs', morphobjs' = array_chop first args' in
+    let appm = mkApp(m, morphargs) in
+    let appmtype = Typing.type_of env sigma appm in
+    let cstrs = List.map (Option.map (fun r -> r.rew_car, r.rew_rel)) (Array.to_list morphobjs') in
+      (* Desired signature *)
+    let evars, appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a,r) -> r) in
+      (* Actual signature found *)
+    let cl_args = [| appmtype' ; signature ; appm |] in
+    let app = mkApp (Lazy.force proper_type, cl_args) in
+    let env' = Environ.push_named
+      (id_of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation)
+      env
+    in
+    let evars, morph = new_cstr_evar evars env' app in
+      evars, morph, morph, sigargs, appm, morphobjs, morphobjs'
+  in
+  let projargs, subst, evars, respars, typeargs =
+    array_fold_left2
+      (fun (acc, subst, evars, sigargs, typeargs') x y ->
+	let (carrier, relation), sigargs = split_head sigargs in
+	  match relation with
+	  | Some relation ->
+	      let carrier = substl subst carrier
+	      and relation = substl subst relation in
+	      (match y with
+	      | None ->
+		  let evars, proof = proper_proof env evars carrier relation x in
+		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
+	      | Some r ->
+		  [ r.rew_prf; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
+	  | None ->
+	      if y <> None then error "Cannot rewrite the argument of a dependent function";
+	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
+      ([], [], evars, sigargs, []) args args'
+  in
+  let proof = applistc proj (List.rev projargs) in
+  let newt = applistc m' (List.rev typeargs) in
+    match respars with
+	[ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt
+      | _ -> assert(false)
+
+let apply_constraint env sigma car rel cstr res =
+  match cstr with
+  | None -> res
+  | Some r -> resolve_subrelation env sigma car rel r res
+
+let eq_env x y = x == y
+
+let apply_rule hypinfo loccs : strategy =
+  let (nowhere_except_in,occs) = loccs in
+  let is_occ occ =
+    if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in
+  let occ = ref 0 in
+    fun env sigma t ty cstr evars ->
+      if not (eq_env !hypinfo.cl.env env) then hypinfo := refresh_hypinfo env sigma !hypinfo;
+      let unif = unify_eqn env sigma hypinfo t in
+	if unif <> None then incr occ;
+	match unif with
+	| Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ ->
+	    begin
+	      let goalevars = Evd.evar_merge (fst evars)
+		(Evd.undefined_evars (Evarutil.nf_evar_map env'.evd))
+	      in
+	      let res = { rew_car = ty; rew_rel = rel; rew_from = c1;
+			  rew_to = c2; rew_prf = prf; rew_evars = goalevars, snd evars }
+	      in Some (Some (apply_constraint env sigma car rel cstr res))
+	    end
+	| _ -> None
+
+let apply_lemma (evm,c) left2right loccs : strategy =
+  fun env sigma ->
+    let evars = Evd.merge sigma evm in
+    let hypinfo = ref (decompose_applied_relation env evars c left2right) in
+      apply_rule hypinfo loccs env sigma
+
+let make_leibniz_proof c ty r =
+  let prf = mkApp (Lazy.force coq_f_equal,
+		  [| r.rew_car; ty;
+		     mkLambda (Anonymous, r.rew_car, c (mkRel 1));
+		     r.rew_from; r.rew_to; r.rew_prf |])
+  in
+    { r with rew_car = ty; rew_rel = mkApp (Lazy.force coq_eq, [| ty |]);
+      rew_from = c r.rew_from; rew_to = c r.rew_to; rew_prf = prf }
+
+let pointwise_or_dep_relation n t car rel =
+  if noccurn 1 car then
+    mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
+  else
+    mkApp (Lazy.force forall_relation, 
+	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
+
+let subterm all flags (s : strategy) : strategy =
+  let rec aux env sigma t ty cstr evars =
+    let cstr' = Option.map (fun c -> (ty, c)) cstr in
+      match kind_of_term t with
+      | App (m, args) ->
+	  let rewrite_args success =
+	    let args', evars', progress =
+	      Array.fold_left
+		(fun (acc, evars, progress) arg ->
+		  if progress <> None && not all then (None :: acc, evars, progress)
+		  else
+		    let res = s env sigma arg (Typing.type_of env sigma arg) None evars in
+		      match res with
+		      | Some None -> (None :: acc, evars, if progress = None then Some false else progress)
+		      | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true)
+		      | None -> (None :: acc, evars, progress))
+		([], evars, success) args
+	    in
+	      match progress with
+	      | None -> None
+	      | Some false -> Some None
+	      | Some true ->
+		  let args' = Array.of_list (List.rev args') in
+		  let evars', prf, car, rel, c1, c2 = resolve_morphism env sigma t m args args' cstr' evars' in
+		  let res = { rew_car = ty; rew_rel = rel; rew_from = c1;
+			      rew_to = c2; rew_prf = prf; rew_evars = evars' } in
+		    Some (Some res)
+	  in
+	    if flags.on_morphisms then
+	      let evarsref = ref (snd evars) in
+	      let cstr' = lift_cstr env sigma evarsref args cstr' in
+	      let m' = s env sigma m (Typing.type_of env sigma m)
+		(Option.map snd cstr') (fst evars, !evarsref)
+	      in
+		match m' with
+		| None -> rewrite_args None (* Standard path, try rewrite on arguments *)
+		| Some None -> rewrite_args (Some false)
+		| Some (Some r) ->
+		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
+		       We just apply it. *)
+		    let nargs = Array.length args in
+		    let res =
+		      { rew_car = decomp_prod env (fst r.rew_evars) nargs r.rew_car;
+			rew_rel = decomp_pointwise nargs r.rew_rel;
+			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
+			rew_prf = mkApp (r.rew_prf, args); rew_evars = r.rew_evars }
+		    in Some (Some res)
+	    else rewrite_args None
+
+      | Prod (n, x, b) when noccurn 1 b ->
+	  let b = subst1 mkProp b in
+	  let tx = Typing.type_of env sigma x and tb = Typing.type_of env sigma b in
+	  let res = aux env sigma (mkApp (arrow_morphism tx tb, [| x; b |])) ty cstr evars in
+	    (match res with
+	    | Some (Some r) -> Some (Some { r with rew_to = unfold_impl r.rew_to })
+	    | _ -> res)
+
+      (* 		if x' = None && flags.under_lambdas then *)
+      (* 		  let lam = mkLambda (n, x, b) in *)
+      (* 		  let lam', occ = aux env lam occ None in *)
+      (* 		  let res =  *)
+      (* 		    match lam' with *)
+      (* 		    | None -> None *)
+      (* 		    | Some (prf, (car, rel, c1, c2)) -> *)
+      (* 			Some (resolve_morphism env sigma t *)
+      (* 				 ~fnewt:unfold_all *)
+      (* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
+      (* 				 cstr evars) *)
+      (* 		  in res, occ *)
+      (* 		else *)
+
+      | Prod (n, dom, codom) when eq_constr ty mkProp ->
+	  let lam = mkLambda (n, dom, codom) in
+	  let res = aux env sigma (mkApp (Lazy.force coq_all, [| dom; lam |])) ty cstr evars in
+	    (match res with
+	    | Some (Some r) -> Some (Some { r with rew_to = unfold_all r.rew_to })
+	    | _ -> res)
+
+      | Lambda (n, t, b) when flags.under_lambdas ->
+	  let env' = Environ.push_rel (n, None, t) env in
+	  let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in
+	    (match b' with
+	    | Some (Some r) ->
+		Some (Some { r with
+		  rew_prf = mkLambda (n, t, r.rew_prf);
+		  rew_car = mkProd (n, t, r.rew_car);
+		  rew_rel = pointwise_or_dep_relation n t r.rew_car r.rew_rel;
+		  rew_from = mkLambda(n, t, r.rew_from);
+		  rew_to = mkLambda (n, t, r.rew_to) })
+	    | _ -> b')
+
+      | Case (ci, p, c, brs) ->
+	  let cty = Typing.type_of env sigma c in
+	  let cstr = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
+	  let c' = s env sigma c cty cstr evars in
+	    (match c' with
+	    | Some (Some r) ->
+		Some (Some (make_leibniz_proof (fun x -> mkCase (ci, p, x, brs)) ty r))
+	    | x ->
+		if array_for_all ((=) 0) ci.ci_cstr_nargs then
+		  let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in
+		  let found, brs' = Array.fold_left (fun (found, acc) br ->
+		    if found <> None then (found, fun x -> br :: acc x)
+		    else
+		      match s env sigma br ty cstr evars with
+		      | Some (Some r) -> (Some r, fun x -> x :: acc x)
+		      | _ -> (None, fun x -> br :: acc x))
+		    (None, fun x -> []) brs
+		  in
+		    match found with
+		    | Some r ->
+			let ctxc x = mkCase (ci, p, c, Array.of_list (List.rev (brs' x))) in
+			  Some (Some (make_leibniz_proof ctxc ty r))
+		    | None -> x
+		else x)
+
+      | _ -> if all then Some None else None
+  in aux
+
+let all_subterms = subterm true default_flags
+let one_subterm = subterm false default_flags
+
+(** Requires transitivity of the rewrite step, not tail-recursive. *)
+
+let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewrite_result option =
+  match next env sigma res.rew_to res.rew_car (Some res.rew_rel) res.rew_evars with
+  | None -> None
+  | Some None -> Some (Some res)
+  | Some (Some res') ->
+      let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car ; res.rew_rel |]) in
+      let evars, prf = new_cstr_evar res'.rew_evars env prfty in
+      let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
+			      res.rew_prf; res'.rew_prf |])
+      in Some (Some { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = prf })
+
+(** Rewriting strategies.
+
+    Inspired by ELAN's rewriting strategies:
+    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049
+*)
+
+module Strategies =
+  struct
+
+    let fail : strategy =
+      fun env sigma t ty cstr evars -> None
+
+    let id : strategy =
+      fun env sigma t ty cstr evars -> Some None
+
+    let refl : strategy =
+      fun env sigma t ty cstr evars ->
+	let evars, rel = match cstr with
+	  | None -> new_cstr_evar evars env (mk_relation ty)
+	  | Some r -> evars, r
+	in
+	let evars, proof =
+	  let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in
+	    new_cstr_evar evars env mty
+	in
+	  Some (Some { rew_car = ty; rew_rel = rel; rew_from = t; rew_to = t;
+		       rew_prf = proof; rew_evars = evars })
+
+    let progress (s : strategy) : strategy =
+      fun env sigma t ty cstr evars ->
+	match s env sigma t ty cstr evars with
+	| None -> None
+	| Some None -> None
+	| r -> r
+
+    let seq fst snd : strategy =
+      fun env sigma t ty cstr evars ->
+	match fst env sigma t ty cstr evars with
+	| None -> None
+	| Some None -> snd env sigma t ty cstr evars
+	| Some (Some res) -> transitivity env sigma res snd
+
+    let choice fst snd : strategy =
+      fun env sigma t ty cstr evars ->
+	match fst env sigma t ty cstr evars with
+	| None -> snd env sigma t ty cstr evars
+	| res -> res
+
+    let try_ str : strategy = choice str id
+
+    let fix (f : strategy -> strategy) : strategy =
+      let rec aux env = f (fun env -> aux env) env in aux
+
+    let any (s : strategy) : strategy =
+      fix (fun any -> try_ (seq s any))
+
+    let repeat (s : strategy) : strategy =
+      seq s (any s)
+
+    let bu (s : strategy) : strategy =
+      fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
+
+    let td (s : strategy) : strategy =
+      fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
+
+    let innermost (s : strategy) : strategy =
+      fix (fun ins -> choice (one_subterm ins) s)
+
+    let outermost (s : strategy) : strategy =
+      fix (fun out -> choice s (one_subterm out))
+
+    let lemmas cs : strategy =
+      List.fold_left (fun tac (l,l2r) ->
+	choice tac (apply_lemma l l2r (false,[])))
+	fail cs
+
+    let inj_open c = (Evd.empty,c)
+
+    let old_hints (db : string) : strategy =
+      let rules = Autorewrite.find_rewrites db in
+	lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules)
+
+    let hints (db : string) : strategy =
+      fun env sigma t ty cstr evars ->
+	let rules = Autorewrite.find_matches db t in
+	  lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules)
+	    env sigma t ty cstr evars
+
+end
+
+(** The strategy for a single rewrite, dealing with occurences. *)
+
+let rewrite_strat flags occs hyp =
+  let app = apply_rule hyp occs in
+  let rec aux () =
+    Strategies.choice app (subterm true flags (fun env -> aux () env))
+  in aux ()
+
+let rewrite_with (evm,c) left2right loccs : strategy =
+  fun env sigma ->
+    let evars = Evd.merge sigma evm in
+    let hypinfo = ref (decompose_applied_relation env evars c left2right) in
+      rewrite_strat default_flags loccs hypinfo env sigma
+
+let apply_strategy (s : strategy) env sigma concl cstr evars =
+  let res =
+    s env sigma concl (Typing.type_of env sigma concl)
+      (Option.map snd cstr) !evars
+  in
+    match res with
+    | None -> None
+    | Some None -> Some None
+    | Some (Some res) ->
+	evars := res.rew_evars;
+	Some (Some (res.rew_prf, (res.rew_car, res.rew_rel, res.rew_from, res.rew_to)))
+
+let split_evars_once sigma evd =
+  Evd.fold (fun ev evi deps ->
+    if Intset.mem ev deps then
+      Intset.union (Class_tactics.evars_of_evi evi) deps
+    else deps) evd sigma
+
+let existentials_of_evd evd =
+  Evd.fold (fun ev evi acc -> Intset.add ev acc) evd Intset.empty
+
+let evd_of_existentials evd exs =
+  Intset.fold (fun i acc ->
+    let evi = Evd.find evd i in
+      Evd.add acc i evi) exs Evd.empty
+
+let split_evars sigma evd =
+  let rec aux deps =
+    let deps' = split_evars_once deps evd in
+      if Intset.equal deps' deps then
+	evd_of_existentials evd deps
+      else aux deps'
+  in aux (existentials_of_evd sigma)
+
+let merge_evars (goal,cstr) = Evd.merge goal cstr
+let solve_constraints env evars =
+  Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars)
+
+let nf_zeta =
+  Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+
+let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
+  let concl, is_hyp =
+    match clause with
+	Some id -> pf_get_hyp_typ gl id, Some id
+      | None -> pf_concl gl, None
+  in
+  let cstr =
+    let sort = mkProp in
+    let impl = Lazy.force impl in
+      match is_hyp with
+      | None -> (sort, inverse sort impl)
+      | Some _ -> (sort, impl)
+  in
+  let sigma = project gl in
+  let evars = ref (Evd.create_evar_defs sigma, Evd.empty) in
+  let env = pf_env gl in
+  let eq = apply_strategy strat env sigma concl (Some cstr) evars in
+    match eq with
+    | Some (Some (p, (_, _, oldt, newt))) ->
+	(try
+	    let cstrevars = !evars in
+	    let evars = solve_constraints env cstrevars in
+	    let p = Evarutil.nf_evar evars p in
+	    let p = nf_zeta env evars p in
+	    let newt = Evarutil.nf_evar evars newt in
+	    let abs = Option.map (fun (x, y) ->
+	      Evarutil.nf_evar evars x, Evarutil.nf_evar evars y) abs in
+	    let undef = split_evars (fst cstrevars) evars in
+	    let rewtac =
+	      match is_hyp with
+	      | Some id ->
+		  let term =
+		    match abs with
+		    | None -> p
+		    | Some (t, ty) ->
+			mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
+		  in
+		    cut_replacing id newt
+		      (Tacmach.refine_no_check (mkApp (term, [| mkVar id |])))
+	      | None ->
+		  (match abs with
+		  | None ->
+		      let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+			tclTHENLAST
+			  (Tacmach.internal_cut_no_check false name newt)
+			  (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p))
+		  | Some (t, ty) ->
+		      Tacmach.refine_no_check
+			(mkApp (mkLambda (Name (id_of_string "newt"), newt,
+					 mkLambda (Name (id_of_string "lemma"), ty,
+						  mkApp (p, [| mkRel 2 |]))),
+			       [| mkMeta goal_meta; t |])))
+	    in
+	    let evartac =
+	      if not (undef = Evd.empty) then
+		Refiner.tclEVARS undef
+	      else tclIDTAC
+	    in tclTHENLIST [evartac; rewtac] gl
+	  with
+	  | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+	  | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	      Refiner.tclFAIL_lazy 0
+		(lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
+			++ fnl () ++ Himsg.explain_typeclass_error env e)) gl)
+    | Some None ->
+	tclFAIL 0 (str"setoid rewrite failed: no progress made") gl
+    | None -> raise Not_found
+
+let cl_rewrite_clause_strat strat clause gl =
+  init_setoid ();
+  let meta = Evarutil.new_meta() in
+  let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in
+    try cl_rewrite_clause_aux strat meta clause gl
+    with Not_found ->
+      tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl
+
+let cl_rewrite_clause l left2right occs clause gl =
+  cl_rewrite_clause_strat (rewrite_with l left2right occs) clause gl
+
+open Pp
+open Pcoq
+open Names
+open Tacexpr
+open Tacinterp
+open Termops
+open Genarg
+open Extraargs
+
+let occurrences_of = function
+  | n::_ as nl when n < 0 -> (false,List.map abs nl)
+  | nl ->
+      if List.exists (fun n -> n < 0) nl then
+	error "Illegal negative occurrence number.";
+      (true,nl)
+
+let pr_gen_strategy pr_id = Pp.mt ()
+let pr_loc_strategy _ _ _ = Pp.mt ()
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+
+let intern_strategy ist gl c = c
+let interp_strategy ist gl c = c
+let glob_strategy ist l = l
+let subst_strategy evm l = l
+
+let apply_constr_expr c l2r occs = fun env sigma ->
+  let c = Constrintern.interp_open_constr sigma env c in
+    apply_lemma c l2r occs env sigma
+
+let interp_constr_list env sigma cs =
+  List.map (fun c -> Constrintern.interp_open_constr sigma env c, true) cs
+
+open Pcoq
+
+let (wit_strategy, globwit_strategy, rawwit_strategy) =
+  (Genarg.create_arg "strategy" :
+      ((strategy, Genarg.tlevel) Genarg.abstract_argument_type *
+	  (strategy, Genarg.glevel) Genarg.abstract_argument_type *
+	  (strategy, Genarg.rlevel) Genarg.abstract_argument_type))
+
+
+ARGUMENT EXTEND rewstrategy TYPED AS strategy
+    PRINTED BY pr_strategy
+    INTERPRETED BY interp_strategy
+    GLOBALIZED BY glob_strategy
+    SUBSTITUTED BY subst_strategy
+
+    [ constr(c) ] -> [ apply_constr_expr c true all_occurrences ]
+  | [ "<-" constr(c) ] -> [ apply_constr_expr c false all_occurrences ]
+  | [ "subterms" rewstrategy(h) ] -> [ all_subterms h ]
+  | [ "subterm" rewstrategy(h) ] -> [ one_subterm h ]
+  | [ "innermost" rewstrategy(h) ] -> [ Strategies.innermost h ]
+  | [ "outermost" rewstrategy(h) ] -> [ Strategies.outermost h ]
+  | [ "bottomup" rewstrategy(h) ] -> [ Strategies.bu h ]
+  | [ "topdown" rewstrategy(h) ] -> [ Strategies.td h ]
+  | [ "id" ] -> [ Strategies.id ]
+  | [ "refl" ] -> [ Strategies.refl ]
+  | [ "progress" rewstrategy(h) ] -> [ Strategies.progress h ]
+  | [ "fail" ] -> [ Strategies.fail ]
+  | [ "try" rewstrategy(h) ] -> [ Strategies.try_ h ]
+  | [ "any" rewstrategy(h) ] -> [ Strategies.any h ]
+  | [ "repeat" rewstrategy(h) ] -> [ Strategies.repeat h ]
+  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ Strategies.seq h h' ]
+  | [ "(" rewstrategy(h) ")" ] -> [ h ]
+  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ]
+  | [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ]
+  | [ "hints" preident(h) ] -> [ Strategies.hints h ]
+  | [ "terms" constr_list(h) ] -> [ fun env sigma -> Strategies.lemmas (interp_constr_list env sigma h) env sigma ]
+END
+
+TACTIC EXTEND class_rewrite
+| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
+| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
+| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ]
+| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
+| [ "clrewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ]
+    END
+
+TACTIC EXTEND class_rewrite_strat
+| [ "clrewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
+(* | [ "clrewrite_strat" strategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] *)
+END
+
+
+let clsubstitute o c =
+  let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in
+    Tacticals.onAllHypsAndConcl
+      (fun cl ->
+	match cl with
+	  | Some id when is_tac id -> tclIDTAC
+	  | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl))
+
+TACTIC EXTEND substitute
+| [ "substitute" orient(o) open_constr(c) ] -> [ clsubstitute o c ]
+END
+
+
+(* Compatibility with old Setoids *)
+
+TACTIC EXTEND setoid_rewrite
+   [ "setoid_rewrite" orient(o) open_constr(c) ]
+   -> [ cl_rewrite_clause c o all_occurrences None ]
+ | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) ] ->
+      [ cl_rewrite_clause c o all_occurrences (Some id)]
+ | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) ] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) None]
+ | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id)] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
+ | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ)] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
+END
+
+(* let solve_obligation lemma =  *)
+(*   tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *)
+(*     (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *)
+
+let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l)
+
+let declare_an_instance n s args =
+  ((dummy_loc,Name n), Explicit,
+  CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)),
+	   args))
+
+let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
+
+let anew_instance binders instance fields =
+  new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None
+
+let require_library dirpath =
+  let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in
+    Library.require_library [qualid] (Some false)
+
+let declare_instance_refl binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
+  in anew_instance binders instance
+       [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)]
+
+let declare_instance_sym binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
+  in anew_instance binders instance
+       [(Ident (dummy_loc,id_of_string "symmetry"),lemma)]
+
+let declare_instance_trans binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive"
+  in anew_instance binders instance
+       [(Ident (dummy_loc,id_of_string "transitivity"),lemma)]
+
+let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None)))
+
+let declare_relation ?(binders=[]) a aeq n refl symm trans =
+  init_setoid ();
+  let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
+  in ignore(anew_instance binders instance []);
+  match (refl,symm,trans) with
+      (None, None, None) -> ()
+    | (Some lemma1, None, None) ->
+	ignore (declare_instance_refl binders a aeq n lemma1)
+    | (None, Some lemma2, None) ->
+	ignore (declare_instance_sym binders a aeq n lemma2)
+    | (None, None, Some lemma3) ->
+	ignore (declare_instance_trans binders a aeq n lemma3)
+    | (Some lemma1, Some lemma2, None) ->
+	ignore (declare_instance_refl binders a aeq n lemma1);
+	ignore (declare_instance_sym binders a aeq n lemma2)
+    | (Some lemma1, None, Some lemma3) ->
+	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
+	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder"
+	in ignore(
+	    anew_instance binders instance
+	      [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1);
+	       (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)])
+    | (None, Some lemma2, Some lemma3) ->
+	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER"
+	in ignore(
+	    anew_instance binders instance
+	      [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2);
+	       (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)])
+     | (Some lemma1, Some lemma2, Some lemma3) ->
+	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
+	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+	in ignore(
+	  anew_instance binders instance
+	    [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1);
+	     (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2);
+	     (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)])
+
+type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
+
+let (wit_binders_let : Genarg.tlevel binders_let_argtype),
+  (globwit_binders_let : Genarg.glevel binders_let_argtype),
+  (rawwit_binders_let : Genarg.rlevel binders_let_argtype) =
+  Genarg.create_arg "binders_let"
+
+open Pcoq.Constr
+
+VERNAC COMMAND EXTEND AddRelation
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
+
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+	"as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None None ]
+  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddRelation2
+    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) None ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddRelation3
+    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+	"as" ident(n) ] ->
+      [ declare_relation a aeq n None None (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation
+  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)
+	"reflexivity" "proved" "by" constr(lemma1)
+	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)
+	"reflexivity" "proved" "by" constr(lemma1)
+	"as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
+  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation2
+    [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation3
+    [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+	"as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
+END
+
+let mk_qualid s =
+  Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s)
+
+let cHole = CHole (dummy_loc, None)
+
+open Entries
+open Libnames
+
+let proper_projection r ty =
+  let ctx, inst = decompose_prod_assum ty in
+  let mor, args = destApp inst in
+  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
+  let app = mkApp (Lazy.force proper_proj,
+		  Array.append args [| instarg |]) in
+    it_mkLambda_or_LetIn app ctx
+
+let declare_projection n instance_id r =
+  let ty = Global.type_of_global r in
+  let c = constr_of_global r in
+  let term = proper_projection c ty in
+  let typ = Typing.type_of (Global.env ()) Evd.empty term in
+  let ctx, typ = decompose_prod_assum typ in
+  let typ =
+    let n =
+      let rec aux t =
+	match kind_of_term t with
+	    App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) ->
+	      succ (aux rel')
+	  | _ -> 0
+      in
+      let init =
+	match kind_of_term typ with
+	    App (f, args) when eq_constr f (Lazy.force respectful) ->
+	      mkApp (f, fst (array_chop (Array.length args - 2) args))
+	  | _ -> typ
+      in aux init
+    in
+    let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ
+    in it_mkProd_or_LetIn ccl ctx
+  in
+  let typ = it_mkProd_or_LetIn typ ctx in
+  let cst =
+    { const_entry_body = term;
+      const_entry_type = Some typ;
+      const_entry_opaque = false;
+      const_entry_boxed = false }
+  in
+    ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
+
+let build_morphism_signature m =
+  let env = Global.env () in
+  let m = Constrintern.interp_constr Evd.empty env m in
+  let t = Typing.type_of env Evd.empty m in
+  let isevars = ref (Evd.empty, Evd.empty) in
+  let cstrs =
+    let rec aux t =
+      match kind_of_term t with
+	| Prod (na, a, b) ->
+	    None :: aux b
+	| _ -> []
+    in aux t
+  in
+  let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None snd in
+  let _ = isevars := evars in
+  let _ = List.iter
+    (fun (ty, rel) ->
+      Option.iter (fun rel ->
+	let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
+	let evars,c = new_cstr_evar !isevars env default in
+	  isevars := evars)
+	rel)
+    cstrs
+  in
+  let morph =
+    mkApp (Lazy.force proper_type, [| t; sig_; m |])
+  in
+  let evd = solve_constraints env !isevars in
+  let m = Evarutil.nf_evar evd morph in
+    Evarutil.check_evars env Evd.empty evd m; m
+
+let default_morphism sign m =
+  let env = Global.env () in
+  let t = Typing.type_of env Evd.empty m in
+  let evars, _, sign, cstrs =
+    build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign) (fun (ty, rel) -> rel)
+  in
+  let morph =
+    mkApp (Lazy.force proper_type, [| t; sign; m |])
+  in
+  let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in
+    mor, proper_projection mor morph
+
+let add_setoid binders a aeq t n =
+  init_setoid ();
+  let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
+  let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
+  let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
+  let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+  in ignore(
+    anew_instance binders instance
+      [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
+       (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
+       (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
+
+let add_morphism_infer glob m n =
+  init_setoid ();
+  let instance_id = add_suffix n "_Proper" in
+  let instance = build_morphism_signature m in
+    if Lib.is_modtype () then
+      let cst = Declare.declare_internal_constant instance_id
+				(Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical)
+      in
+	add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst));
+	declare_projection n instance_id (ConstRef cst)
+    else
+      let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
+	Flags.silently
+	  (fun () ->
+	    Lemmas.start_proof instance_id kind instance
+	      (fun _ -> function
+		Libnames.ConstRef cst ->
+		  add_instance (Typeclasses.new_instance (Lazy.force proper_class) None
+				   glob (ConstRef cst));
+		  declare_projection n instance_id (ConstRef cst)
+		| _ -> assert false);
+	    Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) ();
+	Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) ()
+
+let add_morphism glob binders m s n =
+  init_setoid ();
+  let instance_id = add_suffix n "_Proper" in
+  let instance =
+    ((dummy_loc,Name instance_id), Explicit,
+    CAppExpl (dummy_loc,
+	     (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")),
+	     [cHole; s; m]))
+  in
+  let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
+    ignore(new_instance ~global:glob binders instance (CRecord (dummy_loc,None,[]))
+	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
+
+VERNAC COMMAND EXTEND AddSetoid1
+   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [ add_setoid [] a aeq t n ]
+  | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [	add_setoid binders a aeq t n ]
+  | [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
+      [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ]
+  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
+      [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ]
+  | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m)
+	"with" "signature" lconstr(s) "as" ident(n) ] ->
+      [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ]
+END
+
+(** Bind to "rewrite" too *)
+
+(** Taken from original setoid_replace, to emulate the old rewrite semantics where
+    lemmas are first instantiated and then rewrite proceeds. *)
+
+let check_evar_map_of_evars_defs evd =
+ let metas = Evd.meta_list evd in
+ let check_freemetas_is_empty rebus =
+  Evd.Metaset.iter
+   (fun m ->
+     if Evd.meta_defined evd m then () else
+      raise
+	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
+ in
+  List.iter
+   (fun (_,binding) ->
+     match binding with
+        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
+         check_freemetas_is_empty rebus freemetas
+      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
+                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
+         check_freemetas_is_empty rebus1 freemetas1 ;
+         check_freemetas_is_empty rebus2 freemetas2
+   ) metas
+
+let unification_rewrite l2r c1 c2 cl car rel but gl =
+  let env = pf_env gl in
+  let (evd',c') =
+    try
+      (* ~flags:(false,true) to allow to mark occurrences that must not be
+         rewritten simply by replacing them with let-defined definitions
+         in the context *)
+      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd
+    with
+	Pretype_errors.PretypeError _ ->
+	  (* ~flags:(true,true) to make Ring work (since it really
+             exploits conversion) *)
+	  Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags
+	    env ((if l2r then c1 else c2),but) cl.evd
+  in
+  let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in
+  let cl' = {cl with evd = evd'} in
+  let cl' =
+    let mvs = clenv_dependent false cl' in
+      clenv_pose_metas_as_evars cl' mvs
+  in
+  let nf c = Evarutil.nf_evar ( cl'.evd) (Clenv.clenv_nf_meta cl' c) in
+  let c1 = if l2r then nf c' else nf c1
+  and c2 = if l2r then nf c2 else nf c'
+  and car = nf car and rel = nf rel in
+  check_evar_map_of_evars_defs cl'.evd;
+  let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in
+  let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in
+    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)}
+
+let get_hyp gl evars c clause l2r =
+  let hi = decompose_applied_relation (pf_env gl) evars c l2r in
+  let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in
+    unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl
+
+let general_rewrite_flags = { under_lambdas = false; on_morphisms = false }
+
+let apply_lemma gl c cl l2r occs =
+  let sigma = project gl in
+  let hypinfo = ref (get_hyp gl sigma c cl l2r) in
+  let app = apply_rule hypinfo occs in
+  let rec aux () =
+    Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env))
+  in !hypinfo, aux ()
+
+let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
+  let meta = Evarutil.new_meta() in
+  let hypinfo, strat = apply_lemma gl c cl l2r occs in
+    try
+      tclTHEN
+        (Refiner.tclEVARS hypinfo.cl.evd)
+        (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl
+    with Not_found ->
+      let {l2r=l2r; c1=x; c2=y} = hypinfo in
+	raise (Pretype_errors.PretypeError
+		  (pf_env gl,
+		  Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl)))
+
+let general_s_rewrite_clause x =
+  init_setoid ();
+  match x with
+    | None -> general_s_rewrite None
+    | Some id -> general_s_rewrite (Some id)
+
+let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause
+
+let is_loaded d =
+  let d' = List.map id_of_string d in
+  let dir = make_dirpath (List.rev d') in
+    Library.library_is_loaded dir
+
+let try_loaded f gl =
+  if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl
+  else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl
+
+(** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
+
+let not_declared env ty rel =
+  tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++
+		str ty ++ str" relation. Maybe you need to require the Setoid library")
+
+let relation_of_constr env c =
+  match kind_of_term c with
+    | App (f, args) when Array.length args >= 2 ->
+	let relargs, args = array_chop (Array.length args - 2) args in
+	  mkApp (f, relargs), args
+    | _ -> errorlabstrm "relation_of_constr"
+	(str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.")
+
+let setoid_proof gl ty fn fallback =
+  let env = pf_env gl in
+    try
+      let rel, args = relation_of_constr env (pf_concl gl) in
+      let evm, car = project gl, pf_type_of gl args.(0) in
+	fn env evm car rel gl
+    with e ->
+      try fallback gl
+      with Hipattern.NoEquationFound ->
+	  match e with
+	  | Not_found ->
+	      let rel, args = relation_of_constr env (pf_concl gl) in
+		not_declared env ty rel gl
+	  | _ -> raise e
+
+let setoid_reflexivity gl =
+  setoid_proof gl "reflexive"
+    (fun env evm car rel -> apply (get_reflexive_proof env evm car rel))
+    (reflexivity_red true)
+
+let setoid_symmetry gl =
+  setoid_proof gl "symmetric"
+    (fun env evm car rel -> apply (get_symmetric_proof env evm car rel))
+    (symmetry_red true)
+
+let setoid_transitivity c gl =
+  setoid_proof gl "transitive"
+    (fun env evm car rel ->
+      let proof = get_transitive_proof env evm car rel in
+      match c with
+      | None -> eapply proof
+      | Some c ->
+	  apply_with_bindings (proof,Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]))
+    (transitivity_red true c)
+
+let setoid_symmetry_in id gl =
+  let ctype = pf_type_of gl (mkVar id) in
+  let binders,concl = decompose_prod_assum ctype in
+  let (equiv, args) = decompose_app concl in
+  let rec split_last_two = function
+    | [c1;c2] -> [],(c1, c2)
+    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
+    | _ -> error "The term provided is not an equivalence."
+  in
+  let others,(c1,c2) = split_last_two args in
+  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
+  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
+  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
+    tclTHENS (Tactics.cut new_hyp)
+      [ intro_replacing id;
+	tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ]
+      gl
+
+let _ = Tactics.register_setoid_reflexivity setoid_reflexivity
+let _ = Tactics.register_setoid_symmetry setoid_symmetry
+let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in
+let _ = Tactics.register_setoid_transitivity setoid_transitivity
+
+TACTIC EXTEND setoid_symmetry
+   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
+ | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
+END
+
+TACTIC EXTEND setoid_reflexivity
+[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
+END
+
+TACTIC EXTEND setoid_transitivity
+  [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
+| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
+END
+
+let implify id gl =
+  let (_, b, ctype) = pf_get_hyp gl id in
+  let binders,concl = decompose_prod_assum ctype in
+  let ctype' =
+    match binders with
+    | (_, None, ty as hd) :: tl when noccurn 1 concl ->
+	let env = Environ.push_rel_context tl (pf_env gl) in
+	let sigma = project gl in
+	let tyhd = Typing.type_of env sigma ty
+	and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in
+	let app = mkApp (arrow_morphism tyhd (subst1 mkProp tyconcl), [| ty; (subst1 mkProp concl) |]) in
+	  it_mkProd_or_LetIn app tl
+    | _ -> ctype
+  in convert_hyp_no_check (id, b, ctype') gl
+
+TACTIC EXTEND implify
+[ "implify" hyp(n) ] -> [ implify n ]
+END
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 5c891c58..87c88b9d 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -6,14 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacinterp.ml 13130 2010-06-13 18:45:09Z herbelin $ *)
+(* $Id$ *)
 
 open Constrintern
 open Closure
 open RedFlags
 open Declarations
 open Entries
-open Dyn
 open Libobject
 open Pattern
 open Matching
@@ -26,6 +25,7 @@ open Names
 open Nameops
 open Libnames
 open Nametab
+open Smartlocate
 open Pfedit
 open Proof_type
 open Refiner
@@ -46,16 +46,17 @@ open Inductiveops
 open Syntax_def
 open Pretyping
 open Pretyping.Default
+open Extrawit
 open Pcoq
 
 let safe_msgnl s =
-    try msgnl s with e -> 
-      msgnl 
+    try msgnl s with e ->
+      msgnl
 	(str "bug in the debugger: " ++
          str "an exception is raised while printing debug information")
 
 let error_syntactic_metavariables_not_allowed loc =
-  user_err_loc 
+  user_err_loc
     (loc,"out_ident",
      str "Syntactic metavariables allowed only in quotations.")
 
@@ -74,14 +75,15 @@ type ltac_type =
 type value =
   | VRTactic of (goal list sigma * validation) (* For Match results *)
                                                (* Not a true value *)
-  | VFun of ltac_trace * (identifier*value) list * 
+  | VFun of ltac_trace * (identifier*value) list *
       identifier option list * glob_tactic_expr
   | VVoid
   | VInteger of int
   | VIntroPattern of intro_pattern_expr (* includes idents which are not *)
                         (* bound as in "Intro H" but which may be bound *)
                         (* later, as in "tac" in "Intro H; tac" *)
-  | VConstr of constr   (* includes idents known to be bound and references *)
+  | VConstr of constr_under_binders
+                        (* includes idents known to be bound and references *)
   | VConstr_context of constr
   | VList of value list
   | VRec of (identifier*value) list ref * glob_tactic_expr
@@ -93,13 +95,13 @@ let catch_error call_trace tac g =
   | LtacLocated _ as e -> raise e
   | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e
   | e ->
-    let (loc',c),tail = list_sep_last call_trace in
+    let (nrep,loc',c),tail = list_sep_last call_trace in
     let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
     if tail = [] then
       let loc = if loc = dloc then loc' else loc in
       raise (Stdpp.Exc_located(loc,e'))
     else
-      raise (Stdpp.Exc_located(loc',LtacLocated((c,tail,loc),e')))
+      raise (Stdpp.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
 
 (* Signature for interpretation: val_interp and interpretation functions *)
 type interp_sign =
@@ -114,9 +116,6 @@ let check_is_value = function
    error "Immediate match producing tactics not allowed in local definitions."
   | _ -> ()
 
-(* For tactic_of_value *)
-exception NotTactic
-
 (* Gives the constr corresponding to a Constr_context tactic_arg *)
 let constr_of_VConstr_context = function
   | VConstr_context c -> c
@@ -128,7 +127,10 @@ let rec pr_value env = function
   | VVoid -> str "()"
   | VInteger n -> int n
   | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
-  | VConstr c | VConstr_context c ->
+  | VConstr c ->
+      (match env with Some env ->
+	pr_lconstr_under_binders_env env c | _ -> str "a term")
+  | VConstr_context c ->
       (match env with Some env -> pr_lconstr_env env c | _ -> str "a term")
   | (VRTactic _ | VFun _ | VRec _) -> str "a tactic"
   | VList [] -> str "an empty list"
@@ -136,21 +138,21 @@ let rec pr_value env = function
       str "a list (first element is " ++ pr_value env a ++ str")"
 
 (* Transforms an id into a constr if possible, or fails *)
-let constr_of_id env id = 
+let constr_of_id env id =
   construct_reference (Environ.named_context env) id
 
 (* To embed tactics *)
 let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
      (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) =
-  create "tactic"
+  Dyn.create "tactic"
 
 let ((value_in : value -> Dyn.t),
-     (value_out : Dyn.t -> value)) = create "value"
+     (value_out : Dyn.t -> value)) = Dyn.create "value"
 
 let valueIn t = TacDynamic (dummy_loc,value_in t)
 let valueOut = function
   | TacDynamic (_,d) ->
-    if (tag d) = "value" then
+    if (Dyn.tag d) = "value" then
       value_out d
     else
       anomalylabstrm "valueOut" (str "Dynamic tag should be value")
@@ -176,11 +178,6 @@ let find_reference env qid =
 	-> VarRef id
     | _ -> Nametab.locate qid
 
-let error_not_evaluable s =
-  errorlabstrm "evalref_of_ref" 
-    (str "Cannot coerce" ++ spc ()  ++ s ++ spc () ++
-     str "to an evaluable reference.")
-
 (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
 let atomic_mactab = ref Idmap.empty
 let add_primitive_tactic s tac =
@@ -205,8 +202,8 @@ let _ =
         "eleft", TacLeft(true,NoBindings);
         "right", TacRight(false,NoBindings);
         "eright", TacRight(true,NoBindings);
-        "split", TacSplit(false,false,NoBindings);
-        "esplit", TacSplit(true,false,NoBindings);
+        "split", TacSplit(false,false,[NoBindings]);
+        "esplit", TacSplit(true,false,[NoBindings]);
         "constructor", TacAnyConstructor (false,None);
         "econstructor", TacAnyConstructor (true,None);
         "reflexivity", TacReflexivity;
@@ -218,7 +215,7 @@ let _ =
         "fail", TacFail(ArgArg 0,[]);
         "fresh", TacArg(TacFreshId [])
       ]
- 
+
 let lookup_atomic id = Idmap.find id !atomic_mactab
 let is_atomic_kn kn =
   let (_,_,l) = repr_kn kn in
@@ -236,9 +233,7 @@ let _ =
   Summary.declare_summary "tactic-definition"
     { Summary.freeze_function   = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init;
-      Summary.survive_module = false;
-      Summary.survive_section   = false }
+      Summary.init_function     = init }
 
 (* Tactics table (TacExtend). *)
 
@@ -246,7 +241,7 @@ let tac_tab = Hashtbl.create 17
 
 let add_tactic s t =
   if Hashtbl.mem tac_tab s then
-    errorlabstrm ("Refiner.add_tactic: ") 
+    errorlabstrm ("Refiner.add_tactic: ")
       (str ("Cannot redeclare tactic "^s^"."));
   Hashtbl.add tac_tab s t
 
@@ -258,9 +253,9 @@ let overwriting_add_tactic s t =
   Hashtbl.add tac_tab s t
 
 let lookup_tactic s =
-  try 
+  try
     Hashtbl.find tac_tab s
-  with Not_found -> 
+  with Not_found ->
     errorlabstrm "Refiner.lookup_tactic"
       (str"The tactic " ++ str s ++ str" is not installed.")
 (*
@@ -279,7 +274,7 @@ type glob_sign = {
 
 type interp_genarg_type =
   (glob_sign -> raw_generic_argument -> glob_generic_argument) *
-  (interp_sign -> goal sigma -> glob_generic_argument -> 
+  (interp_sign -> goal sigma -> glob_generic_argument ->
     typed_generic_argument) *
   (substitution -> glob_generic_argument -> glob_generic_argument)
 
@@ -287,24 +282,34 @@ let extragenargtab =
   ref (Gmap.empty : (string,interp_genarg_type) Gmap.t)
 let add_interp_genarg id f =
   extragenargtab := Gmap.add id f !extragenargtab
-let lookup_genarg id = 
+let lookup_genarg id =
   try Gmap.find id !extragenargtab
-  with Not_found -> failwith ("No interpretation function found for entry "^id)
+  with Not_found ->
+    let msg = "No interpretation function found for entry " ^ id in
+    warning msg;
+    let f = (fun _ _ -> failwith msg), (fun _ _ _ -> failwith msg), (fun _ a -> a) in
+    add_interp_genarg id f;
+    f
+
 
 let lookup_genarg_glob   id = let (f,_,_) = lookup_genarg id in f
 let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f
 let lookup_genarg_subst  id = let (_,_,f) = lookup_genarg id in f
 
+let push_trace (loc,ck) = function
+  | (n,loc',ck')::trl when ck=ck' -> (n+1,loc,ck)::trl
+  | trl -> (1,loc,ck)::trl
+
 let propagate_trace ist loc id = function
   | VFun (_,lfun,it,b) ->
       let t = if it=[] then b else TacFun (it,b) in
-      VFun ((loc,LtacVarCall (id,t))::ist.trace,lfun,it,b)
+      VFun (push_trace(loc,LtacVarCall (id,t)) ist.trace,lfun,it,b)
   | x -> x
 
 (* Dynamically check that an argument is a tactic *)
 let coerce_to_tactic loc id = function
   | VFun _ | VRTactic _ as a -> a
-  | _ -> user_err_loc 
+  | _ -> user_err_loc
   (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
 
 (*****************)
@@ -313,23 +318,23 @@ let coerce_to_tactic loc id = function
 
 (* We have identifier <| global_reference <| constr *)
 
-let find_ident id sign = 
-  List.mem id (fst sign.ltacvars) or 
-  List.mem id (ids_of_named_context (Environ.named_context sign.genv))
+let find_ident id ist =
+  List.mem id (fst ist.ltacvars) or
+  List.mem id (ids_of_named_context (Environ.named_context ist.genv))
 
-let find_recvar qid sign = List.assoc qid sign.ltacrecvars
+let find_recvar qid ist = List.assoc qid ist.ltacrecvars
 
 (* a "var" is a ltac var or a var introduced by an intro tactic *)
-let find_var id sign = List.mem id (fst sign.ltacvars)
+let find_var id ist = List.mem id (fst ist.ltacvars)
 
 (* a "ctxvar" is a var introduced by an intro tactic (Intro/LetTac/...) *)
-let find_ctxvar id sign = List.mem id (snd sign.ltacvars)
+let find_ctxvar id ist = List.mem id (snd ist.ltacvars)
 
 (* a "ltacvar" is an ltac var (Let-In/Fun/...) *)
-let find_ltacvar id sign = find_var id sign & not (find_ctxvar id sign)
+let find_ltacvar id ist = find_var id ist & not (find_ctxvar id ist)
 
-let find_hyp id sign =
-  List.mem id (ids_of_named_context (Environ.named_context sign.genv))
+let find_hyp id ist =
+  List.mem id (ids_of_named_context (Environ.named_context ist.genv))
 
 (* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
 (* be fresh in which case it is binding later on *)
@@ -348,7 +353,7 @@ let vars_of_ist (lfun,_,_,env) =
 
 let get_current_context () =
     try Pfedit.get_current_goal_context ()
-    with e when Logic.catchable_exception e -> 
+    with e when Logic.catchable_exception e ->
       (Evd.empty, Global.env())
 
 let strict_check = ref false
@@ -370,17 +375,7 @@ let intern_or_var ist = function
   | ArgVar locid -> ArgVar (intern_hyp ist locid)
   | ArgArg _ as x -> x
 
-let loc_of_by_notation f = function
-  | AN c -> f c
-  | ByNotation (loc,s,_) -> loc
-
-let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef"
-
-let intern_inductive_or_by_notation = function
-  | AN r -> Nametab.inductive_of_reference r
-  | ByNotation (loc,ntn,sc) ->
-      destIndRef (Notation.interp_notation_as_global_reference loc
-        (function IndRef ind -> true | _ -> false) ntn sc)
+let intern_inductive_or_by_notation = smart_global_inductive
 
 let intern_inductive ist = function
   | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
@@ -388,10 +383,10 @@ let intern_inductive ist = function
 
 let intern_global_reference ist = function
   | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
-  | r -> 
+  | r ->
       let loc,_ as lqid = qualid_of_reference r in
       try ArgArg (loc,locate_global_with_alias lqid)
-      with Not_found -> 
+      with Not_found ->
 	error_global_not_found_loc lqid
 
 let intern_ltac_variable ist = function
@@ -486,7 +481,9 @@ let rec intern_intro_pattern lf ist = function
       loc, IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
   | loc, IntroIdentifier id ->
       loc, IntroIdentifier (intern_ident lf ist id)
-  | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)
+  | loc, IntroFresh id ->
+      loc, IntroFresh (intern_ident lf ist id)
+  | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _)
       as x -> x
 
 and intern_or_and_intro_pattern lf ist =
@@ -497,22 +494,22 @@ let intern_quantified_hypothesis ist = function
   | NamedHyp id ->
       (* Uncomment to disallow "intros until n" in ltac when n is not bound *)
       NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
-      
+
 let intern_binding_name ist x =
   (* We use identifier both for variables and binding names *)
-  (* Todo: consider the body of the lemma to which the binding refer 
+  (* Todo: consider the body of the lemma to which the binding refer
      and if a term w/o ltac vars, check the name is indeed quantified *)
   x
 
-let intern_constr_gen isarity {ltacvars=lfun; gsigma=sigma; genv=env} c =
+let intern_constr_gen allow_patvar isarity {ltacvars=lfun; gsigma=sigma; genv=env} c =
   let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
-  let c' = 
-    warn (Constrintern.intern_gen isarity ~ltacvars:(fst lfun,[]) sigma env) c
+  let c' =
+    warn (Constrintern.intern_gen isarity ~allow_patvar ~ltacvars:(fst lfun,[]) sigma env) c
   in
   (c',if !strict_check then None else Some c)
 
-let intern_constr = intern_constr_gen false
-let intern_type = intern_constr_gen true
+let intern_constr = intern_constr_gen false false
+let intern_type = intern_constr_gen false true
 
 (* Globalize bindings *)
 let intern_binding ist (loc,b,c) =
@@ -545,38 +542,33 @@ let intern_induction_arg ist = function
       else
 	ElimOnIdent (loc,id)
 
-let evaluable_of_global_reference = function
-  | ConstRef c -> EvalConstRef c
-  | VarRef c -> EvalVarRef c
-  | r -> error_not_evaluable (pr_global r)
-
 let short_name = function
   | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
   | _ -> None
 
-let interp_global_reference r =
+let intern_evaluable_global_reference ist r =
   let lqid = qualid_of_reference r in
-  try locate_global_with_alias lqid
+  try evaluable_of_global_reference ist.genv (locate_global_with_alias lqid)
   with Not_found ->
-  match r with 
-  | Ident (loc,id) when not !strict_check -> VarRef id
+  match r with
+  | Ident (loc,id) when not !strict_check -> EvalVarRef id
   | _ -> error_global_not_found_loc lqid
 
-let intern_evaluable_reference_or_by_notation = function
-  | AN r -> evaluable_of_global_reference (interp_global_reference r)
+let intern_evaluable_reference_or_by_notation ist = function
+  | AN r -> intern_evaluable_global_reference ist r
   | ByNotation (loc,ntn,sc) ->
-      evaluable_of_global_reference
+      evaluable_of_global_reference ist.genv
       (Notation.interp_notation_as_global_reference loc
         (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
 
-(* Globalizes a reduction expression *)
+(* Globalize a reduction expression *)
 let intern_evaluable ist = function
   | AN (Ident (loc,id)) when find_ltacvar id ist -> ArgVar (loc,id)
   | AN (Ident (_,id)) when
       (not !strict_check & find_hyp id ist) or find_ctxvar id ist ->
       ArgArg (EvalVarRef id, None)
   | r ->
-      let e = intern_evaluable_reference_or_by_notation r in
+      let e = intern_evaluable_reference_or_by_notation ist r in
       let na = short_name r in
       ArgArg (e,na)
 
@@ -587,15 +579,31 @@ let intern_flag ist red =
 
 let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
 
+let intern_constr_pattern ist ltacvars pc =
+  let metas,pat =
+    Constrintern.intern_constr_pattern ist.gsigma ist.genv ~ltacvars pc in
+  let c = intern_constr_gen true false ist pc in
+  metas,(c,pat)
+
+let intern_typed_pattern ist p =
+  let dummy_pat = PRel 0 in
+  (* we cannot ensure in non strict mode that the pattern is closed *)
+  (* keeping a constr_expr copy is too complicated and we want anyway to *)
+  (* type it, so we remember the pattern as a rawconstr only *)
+  (intern_constr_gen true false ist p,dummy_pat)
+
+let intern_typed_pattern_with_occurrences ist (l,p) =
+  (l,intern_typed_pattern ist p)
+
 let intern_red_expr ist = function
   | Unfold l -> Unfold (List.map (intern_unfold ist) l)
   | Fold l -> Fold (List.map (intern_constr ist) l)
   | Cbv f -> Cbv (intern_flag ist f)
   | Lazy f -> Lazy (intern_flag ist f)
   | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
-  | Simpl o -> Simpl (Option.map (intern_constr_with_occurrences ist) o)
+  | Simpl o -> Simpl (Option.map (intern_typed_pattern_with_occurrences ist) o)
   | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r
-  
+
 let intern_in_hyp_as ist lf (id,ipat) =
   (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat)
 
@@ -616,15 +624,15 @@ let intern_hyp_location ist (((b,occs),id),hl) =
   (((b,List.map (intern_or_var ist) occs),intern_hyp_or_metaid ist id), hl)
 
 (* Reads a pattern *)
-let intern_pattern sigma env ?(as_type=false) lfun = function
+let intern_pattern ist ?(as_type=false) lfun = function
   | Subterm (b,ido,pc) ->
       let ltacvars = (lfun,[]) in
-      let (metas,pat) = intern_constr_pattern sigma env ~ltacvars pc in
-      ido, metas, Subterm (b,ido,pat)
+      let (metas,pc) = intern_constr_pattern ist ltacvars pc in
+      ido, metas, Subterm (b,ido,pc)
   | Term pc ->
       let ltacvars = (lfun,[]) in
-      let (metas,pat) = intern_constr_pattern sigma env ~as_type ~ltacvars pc in
-      None, metas, Term pat
+      let (metas,pc) = intern_constr_pattern ist ltacvars pc in
+      None, metas, Term pc
 
 let intern_constr_may_eval ist = function
   | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
@@ -640,10 +648,10 @@ let declare_xml_printer f = print_xml_term := f
 let internalise_tacarg ch = G_xml.parse_tactic_arg ch
 
 let extern_tacarg ch env sigma = function
-  | VConstr c -> !print_xml_term ch env sigma c
+  | VConstr ([],c) -> !print_xml_term ch env sigma c
   | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _
-  | VIntroPattern _  | VRec _ | VList _ ->
-      error "Only externing of terms is implemented."
+  | VIntroPattern _  | VRec _ | VList _ | VConstr _ ->
+      error "Only externing of closed terms is implemented."
 
 let extern_request ch req gl la =
   output_string ch "<REQUEST req=\""; output_string ch req;
@@ -651,24 +659,33 @@ let extern_request ch req gl la =
   List.iter (pf_apply (extern_tacarg ch) gl) la;
   output_string ch "</REQUEST>\n"
 
+let value_of_ident id = VIntroPattern (IntroIdentifier id)
+
+let extend_values_with_bindings (ln,lm) lfun =
+  let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in
+  let lmatch = List.map (fun (id,(ids,c)) -> (id,VConstr (ids,c))) lm in
+  (* For compatibility, bound variables are visible only if no other
+     binding of the same name exists *)
+  lmatch@lfun@lnames
+
 (* Reads the hypotheses of a "match goal" rule *)
-let rec intern_match_goal_hyps sigma env lfun = function
+let rec intern_match_goal_hyps ist lfun = function
   | (Hyp ((_,na) as locna,mp))::tl ->
-      let ido, metas1, pat = intern_pattern sigma env ~as_type:true lfun mp in
-      let lfun, metas2, hyps = intern_match_goal_hyps sigma env lfun tl in
+      let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
       let lfun' = name_cons na (Option.List.cons ido lfun) in
       lfun', metas1@metas2, Hyp (locna,pat)::hyps
   | (Def ((_,na) as locna,mv,mp))::tl ->
-      let ido, metas1, patv = intern_pattern sigma env ~as_type:false lfun mv in
-      let ido', metas2, patt = intern_pattern sigma env ~as_type:true lfun mp in
-      let lfun, metas3, hyps = intern_match_goal_hyps sigma env lfun tl in
+      let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
+      let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in
       let lfun' = name_cons na (Option.List.cons ido' (Option.List.cons ido lfun)) in
       lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
   | [] -> lfun, [], []
 
 (* Utilities *)
 let extract_let_names lrc =
-  List.fold_right 
+  List.fold_right
     (fun ((loc,name),_) l ->
       if List.mem name l then
 	user_err_loc
@@ -684,7 +701,7 @@ let clause_app f = function
 
 (* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
 let rec intern_atomic lf ist x =
-  match (x:raw_atomic_tactic_expr) with 
+  match (x:raw_atomic_tactic_expr) with
   (* Basic tactics *)
   | TacIntroPattern l ->
       TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
@@ -717,7 +734,7 @@ let rec intern_atomic lf ist x =
   | TacAssert (otac,ipat,c) ->
       TacAssert (Option.map (intern_tactic ist) otac,
                  Option.map (intern_intro_pattern lf ist) ipat,
-                 intern_constr_gen (otac<>None) ist c)
+                 intern_constr_gen false (otac<>None) ist c)
   | TacGeneralize cl ->
       TacGeneralize (List.map (fun (c,na) ->
 	               intern_constr_with_occurrences ist c,
@@ -744,13 +761,13 @@ let rec intern_atomic lf ist x =
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
       TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h)
-  | TacInductionDestruct (ev,isrec,l) ->
-      TacInductionDestruct (ev,isrec,List.map (fun (lc,cbo,(ipato,ipats),cls) ->
+  | TacInductionDestruct (ev,isrec,(l,cls)) ->
+      TacInductionDestruct (ev,isrec,(List.map (fun (lc,cbo,(ipato,ipats)) ->
 	      (List.map (intern_induction_arg ist) lc,
                Option.map (intern_constr_with_bindings ist) cbo,
                (Option.map (intern_intro_pattern lf ist) ipato,
-	        Option.map (intern_intro_pattern lf ist) ipats),
-               Option.map (clause_app (intern_hyp_location ist)) cls)) l)
+	        Option.map (intern_intro_pattern lf ist) ipats))) l,
+               Option.map (clause_app (intern_hyp_location ist)) cls))
   | TacDoubleInduction (h1,h2) ->
       let h1 = intern_quantified_hypothesis ist h1 in
       let h2 = intern_quantified_hypothesis ist h2 in
@@ -767,40 +784,43 @@ let rec intern_atomic lf ist x =
   | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
   | TacMove (dep,id1,id2) ->
     TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2)
-  | TacRename l -> 
-      TacRename (List.map (fun (id1,id2) -> 
-			     intern_hyp_or_metaid ist id1, 
+  | TacRename l ->
+      TacRename (List.map (fun (id1,id2) ->
+			     intern_hyp_or_metaid ist id1,
 			     intern_hyp_or_metaid ist id2) l)
   | TacRevert l -> TacRevert (List.map (intern_hyp_or_metaid ist) l)
-	
+
   (* Constructors *)
   | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl)
   | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl)
-  | TacSplit (ev,b,bl) -> TacSplit (ev,b,intern_bindings ist bl)
+  | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (intern_bindings ist) bll)
   | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_tactic ist) t)
   | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,intern_bindings ist bl)
 
   (* Conversion *)
   | TacReduce (r,cl) ->
       TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
-  | TacChange (occl,c,cl) ->
-      TacChange (Option.map (intern_constr_with_occurrences ist) occl,
-        (if occl = None & (cl.onhyps = None or cl.onhyps = Some []) &
+  | TacChange (None,c,cl) ->
+      TacChange (None,
+        (if (cl.onhyps = None or cl.onhyps = Some []) &
 	    (cl.concl_occs = all_occurrences_expr or
 	     cl.concl_occs = no_occurrences_expr)
          then intern_type ist c else intern_constr ist c),
 	clause_app (intern_hyp_location ist) cl)
+  | TacChange (Some p,c,cl) ->
+      TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
+	clause_app (intern_hyp_location ist) cl)
 
   (* Equivalence relations *)
   | TacReflexivity -> TacReflexivity
-  | TacSymmetry idopt -> 
+  | TacSymmetry idopt ->
       TacSymmetry (clause_app (intern_hyp_location ist) idopt)
-  | TacTransitivity c -> TacTransitivity (intern_constr ist c)
+  | TacTransitivity c -> TacTransitivity (Option.map (intern_constr ist) c)
 
   (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) -> 
-      TacRewrite 
-	(ev, 
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite
+	(ev,
 	List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings ist c)) l,
 	clause_app (intern_hyp_location ist) cl,
 	Option.map (intern_tactic ist) by)
@@ -827,7 +847,7 @@ and intern_tactic_seq ist = function
   | TacLetIn (isrec,l,u) ->
       let (l1,l2) = ist.ltacvars in
       let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in
-      let l = List.map (fun (n,b) -> 
+      let l = List.map (fun (n,b) ->
 	  (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in
       ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u)
   | TacMatchGoal (lz,lr,lmr) ->
@@ -835,7 +855,7 @@ and intern_tactic_seq ist = function
   | TacMatch (lz,c,lmr) ->
       ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr)
   | TacId l -> ist.ltacvars, TacId (intern_message ist l)
-  | TacFail (n,l) -> 
+  | TacFail (n,l) ->
       ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l)
   | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
   | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
@@ -854,7 +874,7 @@ and intern_tactic_seq ist = function
       let ist' = { ist with ltacvars = lfun' } in
       (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
       lfun', TacThens (t, List.map (intern_tactic ist') tl)
-  | TacDo (n,tac) -> 
+  | TacDo (n,tac) ->
       ist.ltacvars, TacDo (intern_or_var ist n,intern_tactic ist tac)
   | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac)
   | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac)
@@ -866,7 +886,7 @@ and intern_tactic_seq ist = function
   | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac)
   | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a)
 
-and intern_tactic_fun ist (var,body) = 
+and intern_tactic_fun ist (var,body) =
   let (l1,l2) = ist.ltacvars in
   let lfun' = List.rev_append (Option.List.flatten var) l1 in
   (var,intern_tactic { ist with ltacvars = (lfun',l2) } body)
@@ -874,7 +894,7 @@ and intern_tactic_fun ist (var,body) =
 and intern_tacarg strict ist = function
   | TacVoid -> TacVoid
   | Reference r -> intern_non_tactic_reference strict ist r
-  | IntroPattern ipat -> 
+  | IntroPattern ipat ->
       let lf = ref([],[]) in (*How to know what names the intropattern binds?*)
       IntroPattern (intern_intro_pattern lf ist ipat)
   | Integer n -> Integer n
@@ -891,12 +911,12 @@ and intern_tacarg strict ist = function
       TacCall (loc,
         intern_applied_tactic_reference ist f,
         List.map (intern_tacarg !strict_check ist) l)
-  | TacExternal (loc,com,req,la) -> 
+  | TacExternal (loc,com,req,la) ->
       TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la)
   | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x)
   | Tacexp t -> Tacexp (intern_tactic ist t)
   | TacDynamic(loc,t) as x ->
-      (match tag t with
+      (match Dyn.tag t with
 	| "tactic" | "value" | "constr" -> x
 	| s -> anomaly_loc (loc, "",
                  str "Unknown dynamic: <" ++ str s ++ str ">"))
@@ -907,8 +927,8 @@ and intern_match_rule ist = function
       All (intern_tactic ist tc) :: (intern_match_rule ist tl)
   | (Pat (rl,mp,tc))::tl ->
       let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in
-      let lfun',metas1,hyps = intern_match_goal_hyps sigma env lfun rl in
-      let ido,metas2,pat = intern_pattern sigma env lfun mp in
+      let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in
+      let ido,metas2,pat = intern_pattern ist lfun mp in
       let metas = list_uniquize (metas1@metas2) in
       let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in
       Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl)
@@ -932,7 +952,7 @@ and intern_genarg ist x =
         (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x))
   | IdentArgType b ->
       let lf = ref ([],[]) in
-      in_gen (globwit_ident_gen b) 
+      in_gen (globwit_ident_gen b)
 	(intern_ident lf ist (out_gen (rawwit_ident_gen b) x))
   | VarArgType ->
       in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x))
@@ -943,7 +963,7 @@ and intern_genarg ist x =
   | ConstrArgType ->
       in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x))
   | ConstrMayEvalArgType ->
-      in_gen globwit_constr_may_eval 
+      in_gen globwit_constr_may_eval
         (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x))
   | QuantHypArgType ->
       in_gen globwit_quant_hyp
@@ -965,7 +985,7 @@ and intern_genarg ist x =
   | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x
   | ExtraArgType s ->
       match tactic_genarg_level s with
-      | Some n -> 
+      | Some n ->
           (* Special treatment of tactic arguments *)
           in_gen (globwit_tactic n) (intern_tactic ist
 	    (out_gen (rawwit_tactic n) x))
@@ -977,159 +997,8 @@ and intern_genarg ist x =
 (***************************************************************************)
 (* Evaluation/interpretation *)
 
-(* Associates variables with values and gives the remaining variables and
-   values *)
-let head_with_value (lvar,lval) =
-  let rec head_with_value_rec lacc = function
-    | ([],[]) -> (lacc,[],[])
-    | (vr::tvr,ve::tve) ->
-      (match vr with
-      |	None -> head_with_value_rec lacc (tvr,tve)
-      | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
-    | (vr,[]) -> (lacc,vr,[])
-    | ([],ve) -> (lacc,[],ve)
-  in
-    head_with_value_rec [] (lvar,lval)
-
-(* Gives a context couple if there is a context identifier *)
-let give_context ctxt = function
-  | None -> []
-  | Some id -> [id,VConstr_context ctxt]
-
-(* Reads a pattern by substituting vars of lfun *)
-let eval_pattern lfun c = 
-  let lvar = List.map (fun (id,c) -> (id,lazy(pattern_of_constr c))) lfun in
-  instantiate_pattern lvar c
-
-let read_pattern lfun = function
-  | Subterm (b,ido,pc) -> Subterm (b,ido,eval_pattern lfun pc)
-  | Term pc -> Term (eval_pattern lfun pc)
-
-let value_of_ident id = VIntroPattern (IntroIdentifier id)
-
-let extend_values_with_bindings (ln,lm) lfun =
-  let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in
-  let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lm in
-  (* For compatibility, bound variables are visible only if no other
-     binding of the same name exists *)
-  lmatch@lfun@lnames
-
-(* Reads the hypotheses of a Match Context rule *)
-let cons_and_check_name id l =
-  if List.mem id l then
-    user_err_loc (dloc,"read_match_goal_hyps",
-      strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^
-      " used twice in the same pattern."))
-  else id::l
-
-let rec read_match_goal_hyps lfun lidh = function
-  | (Hyp ((loc,na) as locna,mp))::tl ->
-      let lidh' = name_fold cons_and_check_name na lidh in
-      Hyp (locna,read_pattern lfun mp)::
-	(read_match_goal_hyps lfun lidh' tl)
-  | (Def ((loc,na) as locna,mv,mp))::tl ->
-      let lidh' = name_fold cons_and_check_name na lidh in
-      Def (locna,read_pattern lfun mv, read_pattern lfun mp)::
-	(read_match_goal_hyps lfun lidh' tl)
-  | [] -> []
-
-(* Reads the rules of a Match Context or a Match *)
-let rec read_match_rule lfun = function
-  | (All tc)::tl -> (All tc)::(read_match_rule lfun tl)
-  | (Pat (rl,mp,tc))::tl ->
-      Pat (read_match_goal_hyps lfun [] rl, read_pattern lfun mp,tc)
-      :: read_match_rule lfun tl
-  | [] -> []
-
-(* For Match Context and Match *)
-exception Not_coherent_metas
-exception Eval_fail of std_ppcmds
-
-let is_match_catchable = function
-  | PatternMatchingFailure | Eval_fail _ -> true
-  | e -> Logic.catchable_exception e
-
-(* Verifies if the matched list is coherent with respect to lcm *)
-(* While non-linear matching is modulo eq_constr in matches, merge of *)
-(* different instances of the same metavars is here modulo conversion... *)
-let verify_metas_coherence gl (ln1,lcm) (ln,lm) =
-  let rec aux = function
-  | (num,csr)::tl ->
-    if (List.for_all (fun (a,b) -> a<>num or pf_conv_x gl b csr) lcm) then
-      (num,csr)::aux tl
-    else
-      raise Not_coherent_metas
-  | [] -> lcm in
-  (ln@ln1,aux lm)
-
-(* Tries to match one hypothesis pattern with a list of hypotheses *)
-let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps =
-  let get_id_couple id = function
-    | Name idpat -> [idpat,VConstr (mkVar id)]
-    | Anonymous -> [] in
-  let match_pat lmatch hyp pat =
-    match pat with
-    | Term t ->
-        let lmeta = extended_matches t hyp in
-        (try
-            let lmeta = verify_metas_coherence gl lmatch lmeta in
-            ([],lmeta,(fun () -> raise PatternMatchingFailure))
-          with
-            | Not_coherent_metas -> raise PatternMatchingFailure);
-    | Subterm (b,ic,t) ->
-        let rec match_next_pattern find_next () =
-          let (lmeta,ctxt,find_next') = find_next () in
-          try 
-            let lmeta = verify_metas_coherence gl lmatch lmeta in
-            (give_context ctxt ic,lmeta,match_next_pattern find_next')
-          with
-            | Not_coherent_metas -> match_next_pattern find_next' () in
-        match_next_pattern(fun () -> match_subterm_gen b t hyp) () in
-  let rec apply_one_mhyp_context_rec = function
-    | (id,b,hyp as hd)::tl ->
-	(match patv with
-	| None ->
-            let rec match_next_pattern find_next () =
-              try
-                let (ids, lmeta, find_next') = find_next () in
-		(get_id_couple id hypname@ids, lmeta, hd, 
-                 match_next_pattern find_next')
-              with
-                | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in
-            match_next_pattern (fun () ->
-	      let hyp = if b<>None then refresh_universes_strict hyp else hyp in
-	      match_pat lmatch hyp pat) ()
-	| Some patv -> 
-	    match b with
-	    | Some body -> 
-                let rec match_next_pattern_in_body next_in_body () =
-                  try
-                    let (ids,lmeta,next_in_body') = next_in_body() in
-                    let rec match_next_pattern_in_typ next_in_typ () =
-                      try
-                        let (ids',lmeta',next_in_typ') = next_in_typ() in
-		        (get_id_couple id hypname@ids@ids', lmeta', hd, 
-                         match_next_pattern_in_typ next_in_typ')
-                      with
-                        | PatternMatchingFailure ->
-                            match_next_pattern_in_body next_in_body' () in
-                    match_next_pattern_in_typ 
-                      (fun () ->
-			let hyp = refresh_universes_strict hyp in
-			match_pat lmeta hyp pat) ()
-                  with PatternMatchingFailure -> apply_one_mhyp_context_rec tl
-                in
-                match_next_pattern_in_body 
-                  (fun () -> match_pat lmatch body patv) ()
-            | None -> apply_one_mhyp_context_rec tl)
-    | [] ->
-        db_hyp_pattern_failure ist.debug env (hypname,pat);
-        raise PatternMatchingFailure
-  in
-    apply_one_mhyp_context_rec lhyps
-
 let constr_to_id loc = function
-  | VConstr c when isVar c -> destVar c
+  | VConstr ([],c) when isVar c -> destVar c
   | _ -> invalid_arg_loc (loc, "Not an identifier")
 
 let constr_to_qid loc c =
@@ -1158,12 +1027,12 @@ let debugging_exception_step ist signal_anomaly e pp =
   let explain_exc =
     if signal_anomaly then explain_logic_error
     else explain_logic_error_no_anomaly in
-  debugging_step ist (fun () -> 
+  debugging_step ist (fun () ->
     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 ++ 
-   strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ 
+   user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++
+   strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
    strbrk "which cannot be coerced to " ++ str s ++ str".")
 
 exception CannotCoerceTo of string
@@ -1180,27 +1049,28 @@ let interp_ltac_var coerce ist env locid =
 (* Interprets an identifier which must be fresh *)
 let coerce_to_ident fresh env = function
   | VIntroPattern (IntroIdentifier id) -> id
-  | VConstr c when isVar c & not (fresh & is_variable env (destVar c)) ->
+  | VConstr ([],c) when isVar c & not (fresh & is_variable env (destVar c)) ->
       (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *)
       destVar c
   | v -> raise (CannotCoerceTo "a fresh identifier")
 
-let interp_ident_gen fresh ist gl id =
-  let env = pf_env gl in
+let interp_ident_gen fresh ist env id =
   try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some env) (dloc,id)
   with Not_found -> id
 
-let interp_ident = interp_ident_gen false 
+let interp_ident = interp_ident_gen false
 let interp_fresh_ident = interp_ident_gen true
+let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl)
+let pf_interp_fresh_ident id gl = interp_ident_gen true id (pf_env gl)
 
 (* Interprets an optional identifier which must be fresh *)
-let interp_fresh_name ist gl = function
+let interp_fresh_name ist env = function
   | Anonymous -> Anonymous
-  | Name id -> Name (interp_fresh_ident ist gl id)
+  | Name id -> Name (interp_fresh_ident ist env id)
 
 let coerce_to_intro_pattern env = function
   | VIntroPattern ipat -> ipat
-  | VConstr c when isVar c ->
+  | VConstr ([],c) when isVar c ->
       (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
       (* but also in "destruct H as (H,H')" *)
       IntroIdentifier (destVar c)
@@ -1237,7 +1107,7 @@ let int_or_var_list_of_VList = function
   | _ -> raise Not_found
 
 let interp_int_or_var_as_list ist = function
-  | ArgVar (_,id as locid) -> 
+  | ArgVar (_,id as locid) ->
       (try int_or_var_list_of_VList (List.assoc id ist.lfun)
        with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)])
   | ArgArg n as x -> [x]
@@ -1247,11 +1117,16 @@ let interp_int_or_var_list ist l =
 
 let constr_of_value env = function
   | VConstr csr -> csr
-  | VIntroPattern (IntroIdentifier id) -> constr_of_id env id
+  | VIntroPattern (IntroIdentifier id) -> ([],constr_of_id env id)
   | _ -> raise Not_found
 
+let closed_constr_of_value env v =
+  let ids,c = constr_of_value env v in
+  if ids <> [] then raise Not_found;
+  c
+
 let coerce_to_hyp env = function
-  | VConstr c when isVar c -> destVar c
+  | VConstr ([],c) when isVar c -> destVar c
   | VIntroPattern (IntroIdentifier id) when is_variable env id -> id
   | _ -> raise (CannotCoerceTo "a variable")
 
@@ -1260,7 +1135,7 @@ let interp_hyp ist gl (loc,id as locid) =
   let env = pf_env gl in
   (* Look first in lfun for a value coercible to a variable *)
   try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid
-  with Not_found -> 
+  with Not_found ->
   (* Then look if bound in the proof context at calling time *)
   if is_variable env id then id
   else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found.")
@@ -1294,19 +1169,19 @@ let interp_move_location ist gl = function
 (* Interprets a qualified name *)
 let coerce_to_reference env v =
   try match v with
-  | VConstr c -> global_of_constr c (* may raise Not_found *)
+  | VConstr ([],c) -> global_of_constr c (* may raise Not_found *)
   | _ -> raise Not_found
   with Not_found -> raise (CannotCoerceTo "a reference")
 
 let interp_reference ist env = function
   | ArgArg (_,r) -> r
-  | ArgVar locid -> 
+  | ArgVar locid ->
       interp_ltac_var (coerce_to_reference env) ist (Some env) locid
 
 let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
 
 let coerce_to_inductive = function
-  | VConstr c when isInd c -> destInd c
+  | VConstr ([],c) when isInd c -> destInd c
   | _ -> raise (CannotCoerceTo "an inductive type")
 
 let interp_inductive ist = function
@@ -1315,9 +1190,9 @@ let interp_inductive ist = function
 
 let coerce_to_evaluable_ref env v =
   let ev = match v with
-    | VConstr c when isConst c -> EvalConstRef (destConst c)
-    | VConstr c when isVar c -> EvalVarRef (destVar c)
-    | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) 
+    | VConstr ([],c) when isConst c -> EvalConstRef (destConst c)
+    | VConstr ([],c) when isVar c -> EvalVarRef (destVar c)
+    | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env)
 	-> EvalVarRef id
     | _ -> raise (CannotCoerceTo "an evaluable reference")
   in
@@ -1331,13 +1206,13 @@ let interp_evaluable ist env = function
       (* Maybe [id] has been introduced by Intro-like tactics *)
       (try match Environ.lookup_named id env with
        | (_,Some _,_) -> EvalVarRef id
-       | _ -> error_not_evaluable (pr_id id)
+       | _ -> error_not_evaluable (VarRef id)
        with Not_found ->
        match r with
        | EvalConstRef _ -> r
        | _ -> Pretype_errors.error_var_not_found_loc loc id)
   | ArgArg (r,None) -> r
-  | ArgVar locid -> 
+  | ArgVar locid ->
       interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid
 
 (* Interprets an hypothesis name *)
@@ -1354,25 +1229,26 @@ let interp_clause ist gl { onhyps=ol; concl_occs=occs } =
 (* Interpretation of constructions *)
 
 (* Extract the constr list from lfun *)
-let rec constr_list_aux env = function
-  | (id,v)::tl -> 
-      let (l1,l2) = constr_list_aux env tl in
+let extract_ltac_constr_values ist env =
+  let rec aux = function
+  | (id,v)::tl ->
+      let (l1,l2) = aux tl in
       (try ((id,constr_of_value env v)::l1,l2)
-       with Not_found -> 
+       with Not_found ->
 	 let ido = match v with
 	   | VIntroPattern (IntroIdentifier id0) -> Some id0
 	   | _ -> None in
 	 (l1,(id,ido)::l2))
-  | [] -> ([],[])
-
-let constr_list ist env = constr_list_aux env ist.lfun
+  | [] -> ([],[]) in
+  aux ist.lfun
 
 (* Extract the identifier list from lfun: join all branches (what to do else?)*)
 let rec intropattern_ids (loc,pat) = match pat with
   | IntroIdentifier id -> [id]
-  | IntroOrAndPattern ll -> 
+  | IntroOrAndPattern ll ->
       List.flatten (List.map intropattern_ids (List.flatten ll))
-  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> []
+  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _
+  | IntroForthcoming _ -> []
 
 let rec extract_ids ids = function
   | (id,VIntroPattern ipat)::tl when not (List.mem id ids) ->
@@ -1382,33 +1258,21 @@ let rec extract_ids ids = function
 
 let default_fresh_id = id_of_string "H"
 
-let interp_fresh_id ist gl l =
+let interp_fresh_id ist env l =
   let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in
   let avoid = (extract_ids ids ist.lfun) @ ist.avoid_ids in
-  let id = 
-    if l = [] then default_fresh_id 
+  let id =
+    if l = [] then default_fresh_id
     else
       let s =
 	String.concat "" (List.map (function
 	  | ArgArg s -> s
-	  | ArgVar (_,id) -> string_of_id (interp_ident ist gl id)) l) in
+	  | ArgVar (_,id) -> string_of_id (interp_ident ist env id)) l) in
       let s = if Lexer.is_keyword s then s^"0" else s in
       id_of_string s in
-  Tactics.fresh_id avoid id gl
-
-(* To retype a list of key*constr with undefined key *)
-let retype_list sigma env lst =
-  List.fold_right (fun (x,csr) a ->
-    try (x,Retyping.get_judgment_of env sigma csr)::a with
-    | Anomaly _ -> a) lst []
+  Tactics.fresh_id_in_env avoid id env
 
-let extract_ltac_vars_data ist sigma env =
-  let (ltacvars,_ as vars) = constr_list ist env in
-  vars, retype_list sigma env ltacvars
-
-let extract_ltac_vars ist sigma env =
-  let (_,unbndltacvars),typs = extract_ltac_vars_data ist sigma env in
-  typs,unbndltacvars
+let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl)
 
 let implicit_tactic = ref None
 
@@ -1416,11 +1280,11 @@ let declare_implicit_tactic tac = implicit_tactic := Some tac
 
 open Evd
 
-let solvable_by_tactic env evi (ev,args) src = 
+let solvable_by_tactic env evi (ev,args) src =
   match (!implicit_tactic, src) with
   | Some tac, (ImplicitArg _ | QuestionMark _)
-      when 
-	Environ.named_context_of_val evi.evar_hyps = 
+      when
+	Environ.named_context_of_val evi.evar_hyps =
 	Environ.named_context env ->
       let id = id_of_string "H" in
       start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl
@@ -1428,35 +1292,42 @@ let solvable_by_tactic env evi (ev,args) src =
       begin
 	try
 	  by (tclCOMPLETE tac);
-	  let _,(const,_,_,_) = cook_proof ignore in 
+	  let _,(const,_,_,_) = cook_proof ignore in
 	  delete_current_proof (); const.const_entry_body
-	with e when Logic.catchable_exception e -> 
+	with e when Logic.catchable_exception e ->
 	  delete_current_proof();
 	  raise Exit
       end
   | _ -> raise Exit
 
-let solve_remaining_evars env initial_sigma evd c =
-  let evdref = ref (Typeclasses.resolve_typeclasses ~fail:true env evd) in
+let solve_remaining_evars fail_evar use_classes env initial_sigma evd c =
+  let evdref =
+    if use_classes then ref (Typeclasses.resolve_typeclasses ~fail:true env evd)
+    else ref evd in
   let rec proc_rec c =
-    match kind_of_term (Reductionops.whd_evar (evars_of !evdref) c) with
+    let c = Reductionops.whd_evar !evdref c in
+    match kind_of_term c with
       | Evar (ev,args as k) when not (Evd.mem initial_sigma ev) ->
             let (loc,src) = evar_source ev !evdref in
-	    let sigma = evars_of !evdref in
+	    let sigma =  !evdref in
 	    let evi = Evd.find sigma ev in
-	    (try 
+	    (try
 	      let c = solvable_by_tactic env evi k src in
-	      evdref := Evd.evar_define ev c !evdref;
+	      evdref := Evd.define ev c !evdref;
 	      c
 	    with Exit ->
-	      Pretype_errors.error_unsolvable_implicit loc env sigma evi src None)
-      | _ -> map_constr proc_rec c      
+              if fail_evar then
+	        Pretype_errors.error_unsolvable_implicit loc env sigma evi src None
+              else
+                c)
+      | _ -> map_constr proc_rec c
   in
-  proc_rec (Evarutil.nf_isevar !evdref c)
+  let c = proc_rec c in
+  (* Side-effect *)
+  !evdref,c
 
-let interp_gen kind ist sigma env (c,ce) =
-  let (ltacvars,unbndltacvars as vars),typs =
-    extract_ltac_vars_data ist sigma env in
+let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma (c,ce) =
+  let (ltacvars,unbndltacvars as vars) = extract_ltac_constr_values ist env in
   let c = match ce with
   | None -> c
     (* If at toplevel (ce<>None), the error can be due to an incorrect
@@ -1464,100 +1335,78 @@ let interp_gen kind ist sigma env (c,ce) =
        intros/lettac/inversion hypothesis names *)
   | Some c ->
       let ltacdata = (List.map fst ltacvars,unbndltacvars) in
-      intern_gen (kind = IsType) ~ltacvars:ltacdata sigma env c in
-  let trace = (dloc,LtacConstrInterp (c,vars))::ist.trace in
-  catch_error trace (understand_ltac sigma env (typs,unbndltacvars) kind) c
+      intern_gen (kind = IsType) ~allow_patvar ~ltacvars:ltacdata sigma env c
+  in
+  let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in
+  let evd,c =
+    catch_error trace (understand_ltac expand_evar sigma env vars kind) c in
+  let evd,c =
+    if expand_evar then
+      solve_remaining_evars fail_evar use_classes env sigma evd c
+    else
+      evd,c in
+  db_constr ist.debug env c;
+  (evd,c)
 
-(* Interprets a constr and solve remaining evars with default tactic *)
-let interp_econstr kind ist sigma env cc =
-  let evars,c = interp_gen kind ist sigma env cc in
-  let csr = solve_remaining_evars env sigma evars c in
-  db_constr ist.debug env csr;
-  csr
+(* Interprets a constr; expects evars to be solved *)
+let interp_constr_gen kind ist env sigma c =
+  snd (interp_gen kind ist false true true true env sigma c)
 
-(* Interprets an open constr *)
-let interp_open_constr ccl ist sigma env cc =
-  let evd,c = interp_gen (OfType ccl) ist sigma env cc in
-  (evars_of evd,c)
+let interp_constr = interp_constr_gen (OfType None)
+
+let interp_type = interp_constr_gen IsType
 
-let interp_open_type ccl ist sigma env cc =
-  let evd,c = interp_gen IsType ist sigma env cc in
-  (evars_of evd,c)
+(* Interprets an open constr *)
+let interp_open_constr_gen kind ist =
+  interp_gen kind ist false true false false
 
-let interp_constr = interp_econstr (OfType None)
+let interp_open_constr ccl =
+  interp_open_constr_gen (OfType ccl)
 
-let interp_type = interp_econstr IsType
+let interp_typed_pattern ist env sigma (c,_) =
+  let sigma, c =
+    interp_gen (OfType None) ist true false false false env sigma c in
+  pattern_of_constr sigma c
 
 (* Interprets a constr expression casted by the current goal *)
-let pf_interp_casted_constr ist gl cc =
-  interp_econstr (OfType (Some (pf_concl gl))) ist (project gl) (pf_env gl) cc
-
-(* Interprets an open constr expression *)
-let pf_interp_open_constr casted ist gl cc =
-  let cl = if casted then Some (pf_concl gl) else None in
-  interp_open_constr cl ist (project gl) (pf_env gl) cc
+let pf_interp_casted_constr ist gl c =
+  interp_constr_gen (OfType (Some (pf_concl gl))) ist (pf_env gl) (project gl) c
 
 (* Interprets a constr expression *)
 let pf_interp_constr ist gl =
-  interp_constr ist (project gl) (pf_env gl)
+  interp_constr ist (pf_env gl) (project gl)
 
 let constr_list_of_VList env = function
-  | VList l -> List.map (constr_of_value env) l
+  | VList l -> List.map (closed_constr_of_value env) l
   | _ -> raise Not_found
 
-let pf_interp_constr_in_compound_list inj_fun dest_fun interp_fun ist gl l =
-  let env = pf_env gl in
-  let try_expand_ltac_var x =
+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
-    | RVar (_,id), _ ->
-	List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
+    | RVar (_,id), _ ->	
+        sigma,
+        List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
     | _ ->
-	raise Not_found
+        raise Not_found
     with Not_found ->
       (*all of dest_fun, List.assoc, constr_list_of_VList may raise Not_found*)
-      [interp_fun ist gl x] in
-  List.flatten (List.map try_expand_ltac_var l)
+      let sigma, c = interp_fun ist env sigma x in
+      sigma, [c] in
+  let sigma, l = list_fold_map try_expand_ltac_var sigma l in
+  sigma, List.flatten l
 
-let pf_interp_constr_list =
-  pf_interp_constr_in_compound_list (fun x -> x) (fun x -> x)
-    (fun ist gl -> interp_constr ist (project gl) (pf_env gl))
-
-(*
-let pf_interp_constr_list_as_list ist gl (c,_ as x) =
-  match c with
-    | RVar (_,id) ->
-        (try constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun)
-        with Not_found -> [])
-    | _ -> [interp_constr ist (project gl) (pf_env gl) x]
-
-let pf_interp_constr_list ist gl l =
-  List.flatten (List.map (pf_interp_constr_list_as_list ist gl) l)
-*)
+let interp_constr_list ist env sigma c =
+  snd (interp_constr_in_compound_list (fun x -> x) (fun x -> x) (fun ist env sigma c -> (Evd.empty, interp_constr ist env sigma c)) ist env sigma c)
 
 let inj_open c = (Evd.empty,c)
 
-let pf_interp_open_constr_list =
-  pf_interp_constr_in_compound_list inj_open (fun x -> x)
-    (fun ist gl -> interp_open_constr None ist (project gl) (pf_env gl))
-
-(*
-let pf_interp_open_constr_list_as_list ist gl (c,_ as x) =
-  match c with
-    | RVar (_,id) ->
-        (try List.map inj_open 
-	       (constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun))
-        with Not_found ->
-	  [interp_open_constr None ist (project gl) (pf_env gl) x])
-    | _ ->
-	[interp_open_constr None ist (project gl) (pf_env gl) x]
-
-let pf_interp_open_constr_list ist gl l =
-  List.flatten (List.map (pf_interp_open_constr_list_as_list ist gl) l)
-*)
+let interp_open_constr_list =
+  interp_constr_in_compound_list (fun x -> x) (fun x -> x)
+    (interp_open_constr None)
 
 (* Interprets a type expression *)
 let pf_interp_type ist gl =
-  interp_type ist (project gl) (pf_env gl)
+  interp_type ist (pf_env gl) (project gl)
 
 (* Interprets a reduction expression *)
 let interp_unfold ist env (occs,qid) =
@@ -1566,28 +1415,34 @@ let interp_unfold ist env (occs,qid) =
 let interp_flag ist env red =
   { red with rConst = List.map (interp_evaluable ist env) red.rConst }
 
-let interp_pattern ist sigma env (occs,c) = 
+let interp_constr_with_occurrences ist sigma env (occs,c) =
   (interp_occurrences ist occs, interp_constr ist sigma env c)
 
-let pf_interp_constr_with_occurrences ist gl =
-  interp_pattern ist (project gl) (pf_env gl)
+let interp_typed_pattern_with_occurrences ist env sigma (occs,c) =
+  let sign,p = interp_typed_pattern ist env sigma c in
+  sign, (interp_occurrences ist occs, p)
 
-let pf_interp_constr_with_occurrences_and_name_as_list = 
-  pf_interp_constr_in_compound_list
+let interp_closed_typed_pattern_with_occurrences ist env sigma occl =
+  snd (interp_typed_pattern_with_occurrences ist env sigma occl)
+
+let interp_constr_with_occurrences_and_name_as_list =
+  interp_constr_in_compound_list
     (fun c -> ((all_occurrences_expr,c),Anonymous))
-    (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c 
+    (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c
       | _ -> raise Not_found)
-    (fun ist gl (occ_c,na) ->
-      (interp_pattern ist (project gl) (pf_env gl) occ_c,
-       interp_fresh_name ist gl na))
+    (fun ist env sigma (occ_c,na) ->
+      sigma, (interp_constr_with_occurrences ist env sigma occ_c,
+       interp_fresh_name ist env na))
 
 let interp_red_expr ist sigma env = function
   | Unfold l -> Unfold (List.map (interp_unfold ist env) l)
-  | Fold l -> Fold (List.map (interp_constr ist sigma env) l)
+  | Fold l -> Fold (List.map (interp_constr ist env sigma) l)
   | Cbv f -> Cbv (interp_flag ist env f)
   | Lazy f -> Lazy (interp_flag ist env f)
-  | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l)
-  | Simpl o -> Simpl (Option.map (interp_pattern ist sigma env) o)
+  | Pattern l ->
+      Pattern (List.map (interp_constr_with_occurrences ist env sigma) l)
+  | Simpl o ->
+      Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
   | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
@@ -1606,17 +1461,17 @@ let interp_may_eval f ist gl = function
 	    user_err_loc (loc, "interp_may_eval",
 	    str "Unbound context identifier" ++ pr_id s ++ str"."))
   | ConstrTypeOf c -> pf_type_of gl (f ist gl c)
-  | ConstrTerm c -> 
-     try 
+  | ConstrTerm c ->
+     try
 	f ist gl c
      with e ->
        debugging_exception_step ist false e (fun () ->
          str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c));
-       raise e  
+       raise e
 
 (* Interprets a constr expression possibly to first evaluate *)
 let interp_constr_may_eval ist gl c =
-  let csr = 
+  let csr =
     try
       interp_may_eval pf_interp_constr ist gl c
     with e ->
@@ -1628,48 +1483,56 @@ let interp_constr_may_eval ist gl c =
     csr
   end
 
-let inj_may_eval = function
-  | ConstrTerm c -> ConstrTerm (inj_open c)
-  | ConstrEval (r,c) -> ConstrEval (Tactics.inj_red_expr r,inj_open c)
-  | ConstrContext (id,c) -> ConstrContext (id,inj_open c)
-  | ConstrTypeOf c -> ConstrTypeOf (inj_open c)
-
-let message_of_value = function
+let rec message_of_value gl = function
   | VVoid -> str "()"
   | VInteger n -> int n
   | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
-  | VConstr_context c | VConstr c -> pr_constr c
+  | VConstr_context c -> pr_constr_env (pf_env gl) c
+  | VConstr c -> pr_constr_under_binders_env (pf_env gl) c
   | VRec _ | VRTactic _ | VFun _ -> str "<tactic>"
-  | VList _ -> str "<list>"
+  | VList l -> prlist_with_sep spc (message_of_value gl) l
 
-let rec interp_message_token ist = function
+let rec interp_message_token ist gl = function
   | MsgString s -> str s
   | MsgInt n -> int n
   | MsgIdent (loc,id) ->
       let v =
 	try List.assoc id ist.lfun
 	with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found.") in
-      message_of_value v
+      message_of_value gl v
 
-let rec interp_message_nl ist = function
+let rec interp_message_nl ist gl = function
   | [] -> mt()
-  | l -> prlist_with_sep spc (interp_message_token ist) l ++ fnl()
+  | l -> prlist_with_sep spc (interp_message_token ist gl) l ++ fnl()
 
-let interp_message ist l =
-  (* Force evaluation of interp_message_token so that potential errors 
+let interp_message ist gl l =
+  (* Force evaluation of interp_message_token so that potential errors
      are raised now and not at printing time *)
-  prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist) l)
+  prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist gl) l)
+
+let intro_pattern_list_of_Vlist loc env = function
+  | VList l -> List.map (fun a -> loc,coerce_to_intro_pattern env a) l
+  | _ -> raise Not_found
 
 let rec interp_intro_pattern ist gl = function
   | loc, IntroOrAndPattern l ->
       loc, IntroOrAndPattern (interp_or_and_intro_pattern ist gl l)
   | loc, IntroIdentifier id ->
       loc, interp_intro_pattern_var loc ist (pf_env gl) id
-  | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)
+  | loc, IntroFresh id ->
+      loc, IntroFresh (interp_fresh_ident ist (pf_env gl) id)
+  | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _)
       as x -> x
 
 and interp_or_and_intro_pattern ist gl =
-  List.map (List.map (interp_intro_pattern ist gl))
+  List.map (interp_intro_pattern_list_as_list ist gl)
+
+and interp_intro_pattern_list_as_list ist gl = function
+  | [loc,IntroIdentifier id] as l ->
+      (try intro_pattern_list_of_Vlist loc (pf_env gl) (List.assoc id ist.lfun)
+       with Not_found | CannotCoerceTo _ ->
+	List.map (interp_intro_pattern ist gl) l)
+  | l -> List.map (interp_intro_pattern ist gl) l
 
 let interp_in_hyp_as ist gl (id,ipat) =
   (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat)
@@ -1700,56 +1563,249 @@ let interp_binding_name ist = function
 (* (as in Inversion) *)
 let coerce_to_decl_or_quant_hyp env = function
   | VInteger n -> AnonHyp n
-  | v -> 
+  | v ->
       try NamedHyp (coerce_to_hyp env v)
-      with CannotCoerceTo _ -> 
+      with CannotCoerceTo _ ->
 	raise (CannotCoerceTo "a declared or quantified hypothesis")
 
 let interp_declared_or_quantified_hypothesis ist gl = function
   | AnonHyp n -> AnonHyp n
   | NamedHyp id ->
       let env = pf_env gl in
-      try try_interp_ltac_var 
+      try try_interp_ltac_var
 	    (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id)
       with Not_found -> NamedHyp id
 
-let interp_binding ist gl (loc,b,c) =
-  (loc,interp_binding_name ist b,pf_interp_open_constr false ist gl c)
-
-let interp_bindings ist gl = function
-| NoBindings -> NoBindings
-| ImplicitBindings l -> ImplicitBindings (pf_interp_open_constr_list ist gl l)
-| ExplicitBindings l -> ExplicitBindings (List.map (interp_binding ist gl) l)
-
-let interp_constr_with_bindings ist gl (c,bl) =
-  (pf_interp_constr ist gl c, interp_bindings ist gl bl)
-
-let interp_open_constr_with_bindings ist gl (c,bl) =
-  (pf_interp_open_constr false ist gl c, interp_bindings ist gl bl)
-
-let interp_induction_arg ist gl = function
-  | ElimOnConstr c -> ElimOnConstr (interp_constr_with_bindings ist gl c)
-  | ElimOnAnonHyp n as x -> x
+let interp_binding ist env sigma (loc,b,c) =
+  let sigma, c = interp_open_constr None ist env sigma c in
+  sigma, (loc,interp_binding_name ist b,c)
+
+let interp_bindings ist env sigma = function
+| NoBindings ->
+    sigma, NoBindings
+| ImplicitBindings l ->
+    let sigma, l = interp_open_constr_list ist env sigma l in   
+    sigma, ImplicitBindings l
+| ExplicitBindings l ->
+    let sigma, l = list_fold_map (interp_binding ist env) sigma l in
+    sigma, ExplicitBindings l
+
+let interp_constr_with_bindings ist env sigma (c,bl) =
+  let sigma, bl = interp_bindings ist env sigma bl in
+  let sigma, c = interp_open_constr None ist env sigma c in
+  sigma, (c,bl)
+
+let interp_open_constr_with_bindings ist env sigma (c,bl) =
+  let sigma, bl = interp_bindings ist env sigma bl in
+  let sigma, c = interp_open_constr None ist env sigma c in
+  sigma, (c, bl)
+
+let loc_of_bindings = function
+| NoBindings -> dummy_loc
+| ImplicitBindings l -> loc_of_rawconstr (fst (list_last l))
+| ExplicitBindings l -> pi1 (list_last l)
+
+let interp_open_constr_with_bindings_loc ist env sigma ((c,_),bl as cb) =
+  let loc1 = loc_of_rawconstr c in
+  let loc2 = loc_of_bindings bl in
+  let loc = if loc2 = dummy_loc then loc1 else join_loc loc1 loc2 in
+  let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in
+  sigma, (loc,cb)
+
+let interp_induction_arg ist gl sigma arg =
+  let env = pf_env gl in
+  match arg with
+  | ElimOnConstr c ->
+      let sigma, c = interp_constr_with_bindings ist env sigma c in
+      sigma, ElimOnConstr c
+  | ElimOnAnonHyp n as x -> sigma, x
   | ElimOnIdent (loc,id) ->
       try
-	match List.assoc id ist.lfun with
+	sigma,
+        match List.assoc id ist.lfun with
 	| VInteger n -> ElimOnAnonHyp n
 	| VIntroPattern (IntroIdentifier id) -> ElimOnIdent (loc,id)
-	| VConstr c -> ElimOnConstr (c,NoBindings)
+	| VConstr ([],c) -> ElimOnConstr (c,NoBindings)
 	| _ -> user_err_loc (loc,"",
 	      strbrk "Cannot coerce " ++ pr_id id ++
 	      strbrk " neither to a quantified hypothesis nor to a term.")
       with Not_found ->
 	(* Interactive mode *)
-	if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id)
-	else ElimOnConstr
-	  (pf_interp_constr ist gl (RVar (loc,id),Some (CRef (Ident (loc,id)))),
-	  NoBindings)
+	if Tactics.is_quantified_hypothesis id gl then
+          sigma, ElimOnIdent (loc,id)
+	else
+          let c = interp_constr ist env sigma (RVar (loc,id),Some (CRef (Ident (loc,id)))) in
+          sigma, ElimOnConstr (c,NoBindings)
+
+(* Associates variables with values and gives the remaining variables and
+   values *)
+let head_with_value (lvar,lval) =
+  let rec head_with_value_rec lacc = function
+    | ([],[]) -> (lacc,[],[])
+    | (vr::tvr,ve::tve) ->
+      (match vr with
+      |	None -> head_with_value_rec lacc (tvr,tve)
+      | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
+    | (vr,[]) -> (lacc,vr,[])
+    | ([],ve) -> (lacc,[],ve)
+  in
+    head_with_value_rec [] (lvar,lval)
+
+(* Gives a context couple if there is a context identifier *)
+let give_context ctxt = function
+  | None -> []
+  | Some id -> [id,VConstr_context ctxt]
+
+(* Reads a pattern by substituting vars of lfun *)
+let use_types = false
 
-let mk_constr_value ist gl c = VConstr (pf_interp_constr ist gl c)
-let mk_hyp_value ist gl c = VConstr (mkVar (interp_hyp ist gl c))
+let eval_pattern lfun ist env sigma (_,pat as c) =
+  if use_types then
+    snd (interp_typed_pattern ist env sigma c)
+  else
+    instantiate_pattern sigma lfun pat
+
+let read_pattern lfun ist env sigma = function
+  | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c)
+  | Term c -> Term (eval_pattern lfun ist env sigma c)
+
+(* Reads the hypotheses of a Match Context rule *)
+let cons_and_check_name id l =
+  if List.mem id l then
+    user_err_loc (dloc,"read_match_goal_hyps",
+      strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^
+      " used twice in the same pattern."))
+  else id::l
+
+let rec read_match_goal_hyps lfun ist env sigma lidh = function
+  | (Hyp ((loc,na) as locna,mp))::tl ->
+      let lidh' = name_fold cons_and_check_name na lidh in
+      Hyp (locna,read_pattern lfun ist env sigma mp)::
+	(read_match_goal_hyps lfun ist env sigma lidh' tl)
+  | (Def ((loc,na) as locna,mv,mp))::tl ->
+      let lidh' = name_fold cons_and_check_name na lidh in
+      Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp)::
+	(read_match_goal_hyps lfun ist env sigma lidh' tl)
+  | [] -> []
+
+(* Reads the rules of a Match Context or a Match *)
+let rec read_match_rule lfun ist env sigma = function
+  | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl)
+  | (Pat (rl,mp,tc))::tl ->
+      Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc)
+      :: read_match_rule lfun ist env sigma tl
+  | [] -> []
+
+(* For Match Context and Match *)
+exception Not_coherent_metas
+exception Eval_fail of std_ppcmds
+
+let is_match_catchable = function
+  | PatternMatchingFailure | Eval_fail _ -> true
+  | e -> Logic.catchable_exception e
+
+let equal_instances gl (ctx',c') (ctx,c) =
+  (* How to compare instances? Do we want the terms to be convertible?
+     unifiable? Do we want the universe levels to be relevant? 
+     (historically, conv_x is used) *)
+  ctx = ctx' & pf_conv_x gl c' c
+
+(* Verifies if the matched list is coherent with respect to lcm *)
+(* While non-linear matching is modulo eq_constr in matches, merge of *)
+(* different instances of the same metavars is here modulo conversion... *)
+let verify_metas_coherence gl (ln1,lcm) (ln,lm) =
+  let rec aux = function
+  | (id,c as x)::tl ->
+      if List.for_all (fun (id',c') -> id'<>id or equal_instances gl c' c) lcm
+      then
+	x :: aux tl
+      else
+	raise Not_coherent_metas
+  | [] -> lcm in
+  (ln@ln1,aux lm)
+
+let adjust (l,lc) = (l,List.map (fun (id,c) -> (id,([],c))) lc)
+
+(* Tries to match one hypothesis pattern with a list of hypotheses *)
+let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps =
+  let get_id_couple id = function
+    | Name idpat -> [idpat,VConstr ([],mkVar id)]
+    | Anonymous -> [] in
+  let match_pat lmatch hyp pat =
+    match pat with
+    | Term t ->
+        let lmeta = extended_matches t hyp in
+        (try
+            let lmeta = verify_metas_coherence gl lmatch lmeta in
+            ([],lmeta,(fun () -> raise PatternMatchingFailure))
+          with
+            | Not_coherent_metas -> raise PatternMatchingFailure);
+    | Subterm (b,ic,t) ->
+        let rec match_next_pattern find_next () =
+          let (lmeta,ctxt,find_next') = find_next () in
+          try
+            let lmeta = verify_metas_coherence gl lmatch (adjust lmeta) in
+            (give_context ctxt ic,lmeta,match_next_pattern find_next')
+          with
+            | Not_coherent_metas -> match_next_pattern find_next' () in
+        match_next_pattern (fun () -> match_subterm_gen b t hyp) () in
+  let rec apply_one_mhyp_context_rec = function
+    | (id,b,hyp as hd)::tl ->
+	(match patv with
+	| None ->
+            let rec match_next_pattern find_next () =
+              try
+                let (ids, lmeta, find_next') = find_next () in
+		(get_id_couple id hypname@ids, lmeta, hd,
+                 match_next_pattern find_next')
+              with
+                | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in
+            match_next_pattern (fun () ->
+	      let hyp = if b<>None then refresh_universes_strict hyp else hyp in
+	      match_pat lmatch hyp pat) ()
+	| Some patv ->
+	    match b with
+	    | Some body ->
+                let rec match_next_pattern_in_body next_in_body () =
+                  try
+                    let (ids,lmeta,next_in_body') = next_in_body() in
+                    let rec match_next_pattern_in_typ next_in_typ () =
+                      try
+                        let (ids',lmeta',next_in_typ') = next_in_typ() in
+		        (get_id_couple id hypname@ids@ids', lmeta', hd,
+                         match_next_pattern_in_typ next_in_typ')
+                      with
+                        | PatternMatchingFailure ->
+                            match_next_pattern_in_body next_in_body' () in
+                    match_next_pattern_in_typ
+                      (fun () ->
+			let hyp = refresh_universes_strict hyp in
+			match_pat lmeta hyp pat) ()
+                  with PatternMatchingFailure -> apply_one_mhyp_context_rec tl
+                in
+                match_next_pattern_in_body
+                  (fun () -> match_pat lmatch body patv) ()
+            | None -> apply_one_mhyp_context_rec tl)
+    | [] ->
+        db_hyp_pattern_failure ist.debug env (hypname,pat);
+        raise PatternMatchingFailure
+  in
+    apply_one_mhyp_context_rec lhyps
+
+(* misc *)
+
+let mk_constr_value ist gl c = VConstr ([],pf_interp_constr ist gl c)
+let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c))
 let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
 
+let pack_sigma (sigma,c) = {it=c;sigma=sigma}
+
+let extend_gl_hyps gl sign =
+ { gl with
+   it = { gl.it with
+     evar_hyps = 
+     List.fold_right Environ.push_named_context_val sign gl.it.evar_hyps } }
+
 (* Interprets an l-tac expression into a value *)
 let rec val_interp ist gl (tac:glob_tactic_expr) =
 
@@ -1758,13 +1814,13 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
   | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body)
   | TacLetIn (true,l,u) -> interp_letrec ist gl l u
   | TacLetIn (false,l,u) -> interp_letin ist gl l u
-  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr 
+  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
   | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
   | TacArg a -> interp_tacarg ist gl a
   (* Delayed evaluation *)
   | t -> VFun (ist.trace,ist.lfun,[],t)
 
-  in check_for_interrupt (); 
+  in check_for_interrupt ();
     match ist.debug with
     | DebugOn lev ->
 	debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v})
@@ -1776,26 +1832,27 @@ and eval_tactic ist = function
 	let box = ref None in abstract_tactic_box := box;
 	let call = LtacAtomCall (t,box) in
 	let tac = (* catch error in the interpretation *)
-	  catch_error ((dloc,call)::ist.trace) (interp_atomic ist gl) t	in
+	  catch_error (push_trace(dloc,call)ist.trace)
+	    (interp_atomic ist gl) t	in
 	(* catch error in the evaluation *)
-	catch_error ((loc,call)::ist.trace) tac gl
+	catch_error (push_trace(loc,call)ist.trace) tac gl
   | TacFun _ | TacLetIn _ -> assert false
   | TacMatchGoal _ | TacMatch _ -> assert false
-  | TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s)
-  | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) (interp_message ist s)
+  | TacId s -> fun gl -> tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl
+  | TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl
   | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
   | TacAbstract (tac,ido) ->
       fun gl -> Tactics.tclABSTRACT
-        (Option.map (interp_ident ist gl) ido) (interp_tactic ist tac) gl
-  | TacThen (t1,tf,t,tl) -> 
+        (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) gl
+  | TacThen (t1,tf,t,tl) ->
       tclTHENS3PARTS (interp_tactic ist t1)
 	(Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl)
   | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
   | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
   | TacTry tac -> tclTRY (interp_tactic ist tac)
-  | TacInfo tac -> 
+  | TacInfo tac ->
       let t = (interp_tactic ist tac) in
-	tclINFO 
+	tclINFO
 	  begin
 	    match tac with
 		TacAtom (_,_) -> t
@@ -1807,7 +1864,7 @@ and eval_tactic ist = function
   | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l)
   | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
   | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
-  | TacArg a -> assert false
+  | TacArg a -> interp_tactic ist (TacArg a)
 
 and force_vrec ist gl = function
   | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
@@ -1822,9 +1879,9 @@ and interp_ltac_reference loc' mustbetac ist gl = function
   | ArgArg (loc,r) ->
       let ids = extract_ids [] ist.lfun in
       let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in
-      let ist = 
+      let ist =
         { lfun=[]; debug=ist.debug; avoid_ids=ids;
-          trace = loc_info::ist.trace } in
+          trace = push_trace loc_info ist.trace } in
       val_interp ist gl (lookup r)
 
 and interp_tacarg ist gl = function
@@ -1832,7 +1889,7 @@ and interp_tacarg ist gl = function
   | Reference r -> interp_ltac_reference dloc false ist gl r
   | Integer n -> VInteger n
   | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
-  | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
+  | ConstrMayEval c -> VConstr ([],interp_constr_may_eval ist gl c)
   | MetaIdArg (loc,_,id) -> assert false
   | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r
   | TacCall (loc,f,l) ->
@@ -1842,18 +1899,18 @@ and interp_tacarg ist gl = function
       interp_app loc ist gl fv largs
   | TacExternal (loc,com,req,la) ->
       interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la)
-  | TacFreshId l -> 
-      let id = interp_fresh_id ist gl l in
+  | TacFreshId l ->
+      let id = pf_interp_fresh_id ist gl l in
       VIntroPattern (IntroIdentifier id)
   | Tacexp t -> val_interp ist gl t
   | TacDynamic(_,t) ->
-      let tg = (tag t) in
+      let tg = (Dyn.tag t) in
       if tg = "tactic" then
         val_interp ist gl (tactic_out t ist)
       else if tg = "value" then
         value_out t
       else if tg = "constr" then
-        VConstr (constr_out t)
+        VConstr ([],constr_out t)
       else
         anomaly_loc (dloc, "Tacinterp.val_interp",
           (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
@@ -1861,21 +1918,28 @@ and interp_tacarg ist gl = function
 (* Interprets an application node *)
 and interp_app loc ist gl fv largs =
   match fv with
-    | VFun(trace,olfun,var,body) ->
-      let (newlfun,lvar,lval)=head_with_value (var,largs) in
-      if lvar=[] then
-	let v = 
-	  try
-	    catch_error trace
-	      (val_interp { ist with lfun=newlfun@olfun; trace=trace } gl) body
-	  with e ->
-            debugging_exception_step ist false e (fun () -> str "evaluation");
-	    raise e in
-        debugging_step ist (fun () ->
-	  str "evaluation returns" ++ fnl() ++ pr_value (Some (pf_env gl)) v);
-        if lval=[] then v else interp_app loc ist gl v lval
-      else
-        VFun(trace,newlfun@olfun,lvar,body)
+     (* if var=[] and body has been delayed by val_interp, then body
+         is not a tactic that expects arguments.
+         Otherwise Ltac goes into an infinite loop (val_interp puts
+         a VFun back on body, and then interp_app is called again...) *)
+    | (VFun(trace,olfun,(_::_ as var),body)
+      |VFun(trace,olfun,([] as var),
+         (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) ->
+	let (newlfun,lvar,lval)=head_with_value (var,largs) in
+	if lvar=[] then
+	  let v =
+	    try
+	      catch_error trace
+		(val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body
+	    with e ->
+              debugging_exception_step ist false e (fun () -> str "evaluation");
+	      raise e in
+          debugging_step ist
+	    (fun () ->
+	       str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v);
+          if lval=[] then v else interp_app loc ist gl v lval
+	else
+          VFun(trace,newlfun@olfun,lvar,body)
     | _ ->
 	user_err_loc (loc, "Tacinterp.interp_app",
           (str"Illegal tactic application."))
@@ -1887,8 +1951,13 @@ and tactic_of_value ist vle g =
   | VFun (trace,lfun,[],t) ->
       let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
       catch_error trace tac g
-  | VFun _ -> error "A fully applied tactic is expected."
-  | _ -> raise NotTactic
+  | (VFun _|VRec _) -> error "A fully applied tactic is expected."
+  | VConstr _ -> errorlabstrm "" (str"Value is a term. Expected a tactic.")
+  | VConstr_context _ ->
+      errorlabstrm "" (str"Value is a term context. Expected a tactic.")
+  | VIntroPattern _ ->
+      errorlabstrm "" (str"Value is an intro pattern. Expected a tactic.")
+  | _ -> errorlabstrm "" (str"Expression does not evaluate to a tactic.")
 
 (* Evaluation with FailError catching *)
 and eval_with_fail ist is_lazy goal tac =
@@ -1899,9 +1968,9 @@ and eval_with_fail ist is_lazy goal tac =
 	VRTactic (catch_error trace tac goal)
     | a -> a)
   with
-    | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) 
+    | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s))
     | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
-	raise (Eval_fail s)
+	raise (Eval_fail (Lazy.force s))
     | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
     | Stdpp.Exc_located(s,FailError (lvl,s')) ->
 	raise (Stdpp.Exc_located(s,FailError (lvl - 1, s')))
@@ -1933,10 +2002,10 @@ and interp_match_goal ist goal lz lr lmr =
     let rec match_next_pattern find_next () =
       let (lgoal,ctxt,find_next') = find_next () in
       let lctxt = give_context ctxt id in
-      try apply_hyps_context ist env lz goal mt lctxt lgoal mhyps hyps
+      try apply_hyps_context ist env lz goal mt lctxt (adjust lgoal) mhyps hyps
       with e when is_match_catchable e -> match_next_pattern find_next' () in
     match_next_pattern (fun () -> match_subterm_gen app c csr) () in
-  let rec apply_match_goal ist env goal nrs lex lpt = 
+  let rec apply_match_goal ist env goal nrs lex lpt =
     begin
       if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex);
       match lpt with
@@ -1974,7 +2043,8 @@ and interp_match_goal ist goal lz lr lmr =
 		       else mt()) ++ str"."))
     end in
     apply_match_goal ist env goal 0 lmr
-      (read_match_rule (fst (constr_list ist env)) lmr)
+      (read_match_rule (fst (extract_ltac_constr_values ist env))
+	ist env (project goal) lmr)
 
 (* Tries to match the hypotheses in a Match Context *)
 and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps =
@@ -1992,7 +2062,7 @@ and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps =
             let id_match = pi1 hyp_match in
             let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in
             apply_hyps_context_rec (lfun@lids) lm nextlhyps tl
-          with e when is_match_catchable e -> 
+          with e when is_match_catchable e ->
 	    match_next_pattern find_next' in
         let init_match_pattern () =
           apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in
@@ -2026,15 +2096,15 @@ and interp_genarg ist gl x =
         (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
   | IdentArgType b ->
       in_gen (wit_ident_gen b)
-        (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))
+        (pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))
   | VarArgType ->
       in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
   | RefArgType ->
       in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x))
   | SortArgType ->
       in_gen wit_sort
-        (destSort 
-	  (pf_interp_constr ist gl 
+        (destSort
+	  (pf_interp_constr ist gl
 	    (RSort (dloc,out_gen globwit_sort x), None)))
   | ConstrArgType ->
       in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x))
@@ -2047,15 +2117,17 @@ and interp_genarg ist gl x =
   | RedExprArgType ->
       in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x))
   | OpenConstrArgType casted ->
-      in_gen (wit_open_constr_gen casted) 
-        (pf_interp_open_constr casted ist gl 
+      in_gen (wit_open_constr_gen casted)
+        (interp_open_constr (if casted then Some (pf_concl gl) else None)
+          ist (pf_env gl) (project gl)
           (snd (out_gen (globwit_open_constr_gen casted) x)))
   | ConstrWithBindingsArgType ->
       in_gen wit_constr_with_bindings
-        (interp_constr_with_bindings ist gl (out_gen globwit_constr_with_bindings x))
+        (pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl)
+          (out_gen globwit_constr_with_bindings x)))
   | BindingsArgType ->
       in_gen wit_bindings
-        (interp_bindings ist gl (out_gen globwit_bindings x))
+        (pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x)))
   | List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x
   | List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x
   | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
@@ -2064,22 +2136,24 @@ and interp_genarg ist gl x =
   | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
   | OptArgType _ -> app_opt (interp_genarg ist gl) x
   | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
-  | ExtraArgType s -> 
+  | ExtraArgType s ->
       match tactic_genarg_level s with
-      | Some n -> 
+      | Some n ->
           (* Special treatment of tactic arguments *)
-          in_gen (wit_tactic n) (out_gen (globwit_tactic n) x)
-      | None -> 
+          in_gen (wit_tactic n)
+	    (TacArg(valueIn(VFun(ist.trace,ist.lfun,[],
+				 out_gen (globwit_tactic n) x))))
+      | None ->
           lookup_interp_genarg s ist gl x
 
 and interp_genarg_constr_list0 ist gl x =
   let lc = out_gen (wit_list0 globwit_constr) x in
-  let lc = pf_interp_constr_list ist gl lc in
+  let lc = pf_apply (interp_constr_list ist) gl lc in
   in_gen (wit_list0 wit_constr) lc
 
 and interp_genarg_constr_list1 ist gl x =
   let lc = out_gen (wit_list1 globwit_constr) x in
-  let lc = pf_interp_constr_list ist gl lc in
+  let lc = pf_apply (interp_constr_list ist) gl lc in
   in_gen (wit_list1 wit_constr) lc
 
 and interp_genarg_var_list0 ist gl x =
@@ -2098,7 +2172,7 @@ and interp_match ist g lz constr lmr =
     let rec match_next_pattern find_next () =
       let (lmatch,ctxt,find_next') = find_next () in
       let lctxt = give_context ctxt id in
-      let lfun = extend_values_with_bindings lmatch (lctxt@ist.lfun) in
+      let lfun = extend_values_with_bindings (adjust lmatch) (lctxt@ist.lfun) in
       try eval_with_fail {ist with lfun=lfun} lz g mt
       with e when is_match_catchable e ->
         match_next_pattern find_next' () in
@@ -2109,7 +2183,7 @@ and interp_match ist g lz constr lmr =
          with e when is_match_catchable e -> apply_match ist csr [])
     | (Pat ([],Term c,mt))::tl ->
         (try
-            let lmatch = 
+            let lmatch =
               try extended_matches c csr
               with e ->
                 debugging_exception_step ist false e (fun () ->
@@ -2134,14 +2208,14 @@ and interp_match ist g lz constr lmr =
     | _ ->
       errorlabstrm "Tacinterp.apply_match" (str
         "No matching clauses for match.") in
-  let csr = 
+  let csr =
       try interp_ltac_constr ist g constr with e ->
         debugging_exception_step ist true e
           (fun () -> str "evaluation of the matched expression");
         raise e in
-  let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in
-  let res = 
-     try apply_match ist csr ilr with e -> 
+  let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) (project g) lmr in
+  let res =
+     try apply_match ist csr ilr with e ->
        debugging_exception_step ist true e (fun () -> str "match expression");
        raise e in
   debugging_step ist (fun () ->
@@ -2150,8 +2224,8 @@ and interp_match ist g lz constr lmr =
 
 (* Interprets tactic expressions : returns a "constr" *)
 and interp_ltac_constr ist gl e =
-  let result = 
-  try val_interp ist gl e with Not_found -> 
+  let result =
+  try val_interp ist gl e with Not_found ->
     debugging_step ist (fun () ->
       str "evaluation failed for" ++ fnl() ++
       Pptactic.pr_glob_tactic (pf_env gl) e);
@@ -2160,11 +2234,13 @@ and interp_ltac_constr ist gl e =
     let cresult = constr_of_value (pf_env gl) result in
     debugging_step ist (fun () ->
       Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++
-      str " has value " ++ fnl() ++ print_constr_env (pf_env gl) cresult);
-    cresult
+      str " has value " ++ fnl() ++
+      pr_constr_under_binders_env (pf_env gl) cresult);
+    if fst cresult <> [] then raise Not_found;
+    snd cresult
   with Not_found ->
     errorlabstrm ""
-      (str "Must evaluate to a term" ++ fnl() ++ 
+      (str "Must evaluate to a closed term" ++ fnl() ++
 	  str "offending expression: " ++ fnl() ++
           Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++
           (match result with
@@ -2173,7 +2249,7 @@ and interp_ltac_constr ist gl e =
                 (str "VFun with body " ++ fnl() ++
                     Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++
 		    str "instantiated arguments " ++ fnl() ++
-                    List.fold_right 
+                    List.fold_right
                     (fun p s ->
                       let (i,v) = p in str (string_of_id i) ++ str ", " ++ s)
                     il (str "") ++
@@ -2194,63 +2270,71 @@ and interp_ltac_constr ist gl e =
 
 (* Interprets tactic expressions : returns a "tactic" *)
 and interp_tactic ist tac gl =
-  try tactic_of_value ist (val_interp ist gl tac) gl
-  with NotTactic -> errorlabstrm "" (str "Not a tactic.")
+  tactic_of_value ist (val_interp ist gl tac) gl
 
 (* Interprets a primitive tactic *)
-and interp_atomic ist gl = function
+and interp_atomic ist gl tac =
+  let env = pf_env gl and sigma = project gl in
+  match tac with
   (* Basic tactics *)
   | TacIntroPattern l ->
-      h_intro_patterns (List.map (interp_intro_pattern ist gl) l)
+      h_intro_patterns (interp_intro_pattern_list_as_list ist gl l)
   | TacIntrosUntil hyp ->
       h_intros_until (interp_quantified_hypothesis ist hyp)
   | TacIntroMove (ido,hto) ->
-      h_intro_move (Option.map (interp_fresh_ident ist gl) ido)
+      h_intro_move (Option.map (interp_fresh_ident ist env) ido)
                    (interp_move_location ist gl hto)
   | TacAssumption -> h_assumption
   | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
   | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c)
   | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c)
-  | TacApply (a,ev,cb,None) ->
-      h_apply a ev (List.map (interp_open_constr_with_bindings ist gl) cb)
-  | TacApply (a,ev,cb,Some cl) ->
-      h_apply_in a ev (List.map (interp_open_constr_with_bindings ist gl) cb)
-        (interp_in_hyp_as ist gl cl)
+  | TacApply (a,ev,cb,cl) ->
+      let sigma, l =
+        list_fold_map (interp_open_constr_with_bindings_loc ist env) sigma cb
+      in
+      let tac = match cl with
+        | None -> h_apply a ev
+        | Some cl ->
+            (fun l -> h_apply_in a ev l (interp_in_hyp_as ist gl cl)) in
+      tclWITHHOLES ev tac sigma l
   | TacElim (ev,cb,cbo) ->
-      h_elim ev (interp_constr_with_bindings ist gl cb)
-                (Option.map (interp_constr_with_bindings ist gl) cbo)
+      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+      let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
+      tclWITHHOLES ev (h_elim ev cb) sigma cbo
   | TacElimType c -> h_elim_type (pf_interp_type ist gl c)
-  | TacCase (ev,cb) -> h_case ev (interp_constr_with_bindings ist gl cb)
+  | TacCase (ev,cb) ->
+      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+      tclWITHHOLES ev (h_case ev) sigma cb
   | TacCaseType c -> h_case_type (pf_interp_type ist gl c)
-  | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist gl) idopt) n
+  | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n
   | TacMutualFix (b,id,n,l) ->
-      let f (id,n,c) = (interp_fresh_ident ist gl id,n,pf_interp_type ist gl c)
-      in h_mutual_fix b (interp_fresh_ident ist gl id) n (List.map f l)
-  | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist gl) idopt)
+      let f (id,n,c) = (interp_fresh_ident ist env id,n,pf_interp_type ist gl c)
+      in h_mutual_fix b (interp_fresh_ident ist env id) n (List.map f l)
+  | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt)
   | TacMutualCofix (b,id,l) ->
-      let f (id,c) = (interp_fresh_ident ist gl id,pf_interp_type ist gl c) in
-      h_mutual_cofix b (interp_fresh_ident ist gl id) (List.map f l)
+      let f (id,c) = (interp_fresh_ident ist env id,pf_interp_type ist gl c) in
+      h_mutual_cofix b (interp_fresh_ident ist env id) (List.map f l)
   | TacCut c -> h_cut (pf_interp_type ist gl c)
   | TacAssert (t,ipat,c) ->
-      let c = (if t=None then interp_constr else interp_type) ist (project gl) (pf_env gl) c in
-      abstract_tactic (TacAssert (t,ipat,inj_open c))
+      let c = (if t=None then interp_constr else interp_type) ist env sigma c in
+      abstract_tactic (TacAssert (t,ipat,c))
         (Tactics.forward (Option.map (interp_tactic ist) t)
 	  (Option.map (interp_intro_pattern ist gl) ipat) c)
   | TacGeneralize cl ->
-      h_generalize_gen
-        (pf_interp_constr_with_occurrences_and_name_as_list ist gl cl)
+      let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
+      tclWITHHOLES false (h_generalize_gen) sigma cl
   | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
   | TacLetTac (na,c,clp,b) ->
       let clp = interp_clause ist gl clp in
-      h_let_tac b (interp_fresh_name ist gl na) (pf_interp_constr ist gl c) clp
+      h_let_tac b (interp_fresh_name ist env na) (pf_interp_constr ist gl c) clp
 
   (* Automation tactics *)
-  | TacTrivial (lems,l) -> 
-      Auto.h_trivial (pf_interp_constr_list ist gl lems)
+  | TacTrivial (lems,l) ->
+      Auto.h_trivial (interp_constr_list ist env sigma lems)
 	(Option.map (List.map (interp_hint_base ist)) l)
   | TacAuto (n,lems,l) ->
       Auto.h_auto (Option.map (interp_int_or_var ist) n)
-      (pf_interp_constr_list ist gl lems)
+      (interp_constr_list ist env sigma lems)
       (Option.map (List.map (interp_hint_base ist)) l)
   | TacAutoTDB n -> Dhyp.h_auto_tdb n
   | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id)
@@ -2258,19 +2342,23 @@ and interp_atomic ist gl = function
   | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2
   | TacDAuto (n,p,lems) ->
       Auto.h_dauto (Option.map (interp_int_or_var ist) n,p)
-      (pf_interp_constr_list ist gl lems)
+      (interp_constr_list ist env sigma lems)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
       h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h)
-  | TacInductionDestruct (isrec,ev,l) ->
-      h_induction_destruct ev isrec
-      (List.map (fun (lc,cbo,(ipato,ipats),cls) ->
-	(List.map (interp_induction_arg ist gl) lc,
-         Option.map (interp_constr_with_bindings ist gl) cbo,
-         (Option.map (interp_intro_pattern ist gl) ipato,
-	  Option.map (interp_intro_pattern ist gl) ipats),
-         Option.map (interp_clause ist gl) cls)) l)
+  | TacInductionDestruct (isrec,ev,(l,cls)) ->
+      let sigma, l =
+        list_fold_map (fun sigma (lc,cbo,(ipato,ipats)) ->
+          let sigma,lc =
+            list_fold_map (interp_induction_arg ist gl) sigma lc in
+	  let sigma,cbo =
+            Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
+          (sigma,(lc,cbo,
+            (Option.map (interp_intro_pattern ist gl) ipato,
+	     Option.map (interp_intro_pattern ist gl) ipats)))) sigma l in
+      let cls = Option.map (interp_clause ist gl) cls in
+      tclWITHHOLES ev (h_induction_destruct isrec ev) sigma (l,cls)
   | TacDoubleInduction (h1,h2) ->
       let h1 = interp_quantified_hypothesis ist h1 in
       let h2 = interp_quantified_hypothesis ist h2 in
@@ -2280,8 +2368,9 @@ and interp_atomic ist gl = function
   | TacDecompose (l,c) ->
       let l = List.map (interp_inductive ist) l in
       Elim.h_decompose l (pf_interp_constr ist gl c)
-  | TacSpecialize (n,l) ->
-      h_specialize n (interp_constr_with_bindings ist gl l)
+  | TacSpecialize (n,cb) ->
+      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+      tclWITHHOLES false (h_specialize n) sigma cb
   | TacLApply c -> h_lapply (pf_interp_constr ist gl c)
 
   (* Context management *)
@@ -2290,50 +2379,64 @@ and interp_atomic ist gl = function
   | TacMove (dep,id1,id2) ->
       h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2)
   | TacRename l ->
-      h_rename (List.map (fun (id1,id2) -> 
-			    interp_hyp ist gl id1, 
-			    interp_fresh_ident ist gl (snd id2)) l)
+      h_rename (List.map (fun (id1,id2) ->
+			    interp_hyp ist gl id1,
+			    interp_fresh_ident ist env (snd id2)) l)
   | TacRevert l -> h_revert (interp_hyp_list ist gl l)
 
   (* Constructors *)
-  | TacLeft (ev,bl) -> h_left ev (interp_bindings ist gl bl)
-  | TacRight (ev,bl) -> h_right ev (interp_bindings ist gl bl)
-  | TacSplit (ev,_,bl) -> h_split ev (interp_bindings ist gl bl)
+  | TacLeft (ev,bl) ->
+      let sigma, bl = interp_bindings ist env sigma bl in
+      tclWITHHOLES ev (h_left ev) sigma bl
+  | TacRight (ev,bl) ->
+      let sigma, bl = interp_bindings ist env sigma bl in
+      tclWITHHOLES ev (h_right ev) sigma bl
+  | TacSplit (ev,_,bll) ->
+      let sigma, bll = list_fold_map (interp_bindings ist env) sigma bll in
+      tclWITHHOLES ev (h_split ev) sigma bll
   | TacAnyConstructor (ev,t) ->
       abstract_tactic (TacAnyConstructor (ev,t))
         (Tactics.any_constructor ev (Option.map (interp_tactic ist) t))
   | TacConstructor (ev,n,bl) ->
-      h_constructor ev (skip_metaid n) (interp_bindings ist gl bl)
+      let sigma, bl = interp_bindings ist env sigma bl in
+      tclWITHHOLES ev (h_constructor ev (skip_metaid n)) sigma bl
 
   (* Conversion *)
   | TacReduce (r,cl) ->
       h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl)
-  | TacChange (occl,c,cl) ->
-      h_change (Option.map (pf_interp_constr_with_occurrences ist gl) occl)
-        (if occl = None & (cl.onhyps = None or cl.onhyps = Some []) &
+  | TacChange (None,c,cl) ->
+      h_change None
+        (if (cl.onhyps = None or cl.onhyps = Some []) &
 	    (cl.concl_occs = all_occurrences_expr or
 	     cl.concl_occs = no_occurrences_expr)
-	 then pf_interp_type ist gl c 
+	 then pf_interp_type ist gl c
 	 else pf_interp_constr ist gl c)
         (interp_clause ist gl cl)
+  | TacChange (Some op,c,cl) ->
+      let sign,op = interp_typed_pattern ist env sigma op in
+      h_change (Some op)
+        (pf_interp_constr ist (extend_gl_hyps gl sign) c)
+        (interp_clause ist gl cl)
 
   (* Equivalence relations *)
   | TacReflexivity -> h_reflexivity
   | TacSymmetry c -> h_symmetry (interp_clause ist gl c)
-  | TacTransitivity c -> h_transitivity (pf_interp_constr ist gl c)
+  | TacTransitivity c -> h_transitivity (Option.map (pf_interp_constr ist gl) c)
 
   (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) -> 
-      Equality.general_multi_multi_rewrite ev
-	(List.map (fun (b,m,c) -> (b,m,interp_open_constr_with_bindings ist gl c)) l)
-	(interp_clause ist gl cl)
-	(Option.map (interp_tactic ist) by)
+  | TacRewrite (ev,l,cl,by) ->
+      let l = List.map (fun (b,m,c) ->
+        let f env sigma = interp_open_constr_with_bindings ist env sigma c in
+	(b,m,f)) l in
+      let cl = interp_clause ist gl cl in
+      Equality.general_multi_multi_rewrite ev l cl
+        (Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)
   | TacInversion (DepInversion (k,c,ids),hyp) ->
       Inv.dinv k (Option.map (pf_interp_constr ist gl) c)
         (Option.map (interp_intro_pattern ist gl) ids)
         (interp_declared_or_quantified_hypothesis ist gl hyp)
   | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
-      Inv.inv_clause k 
+      Inv.inv_clause k
         (Option.map (interp_intro_pattern ist gl) ids)
         (interp_hyp_list ist gl idl)
         (interp_declared_or_quantified_hypothesis ist gl hyp)
@@ -2349,79 +2452,94 @@ and interp_atomic ist gl = function
       abstract_extended_tactic opn args (tac args)
   | TacAlias (loc,s,l,(_,body)) -> fun gl ->
     let rec f x = match genarg_tag x with
-    | IntArgType -> 
+    | IntArgType ->
         VInteger (out_gen globwit_int x)
     | IntOrVarArgType ->
         mk_int_or_var_value ist (out_gen globwit_int_or_var x)
     | PreIdentArgType ->
 	failwith "pre-identifiers cannot be bound"
     | IntroPatternArgType ->
-	VIntroPattern 
+	VIntroPattern
 	  (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)))
     | IdentArgType b ->
-        VIntroPattern 
-	  (IntroIdentifier
-              (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)))
+	value_of_ident (interp_fresh_ident ist env
+	  (out_gen (globwit_ident_gen b) x))
     | VarArgType ->
         mk_hyp_value ist gl (out_gen globwit_var x)
-    | RefArgType -> 
-        VConstr (constr_of_global 
+    | RefArgType ->
+        VConstr ([],constr_of_global
           (pf_interp_reference ist gl (out_gen globwit_ref x)))
-    | SortArgType -> 
-        VConstr (mkSort (interp_sort (out_gen globwit_sort x)))
+    | SortArgType ->
+        VConstr ([],mkSort (interp_sort (out_gen globwit_sort x)))
     | ConstrArgType ->
         mk_constr_value ist gl (out_gen globwit_constr x)
     | ConstrMayEvalArgType ->
 	VConstr
-          (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
+          ([],interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
     | ExtraArgType s when tactic_genarg_level s <> None ->
           (* Special treatment of tactic arguments *)
-	val_interp ist gl 
+	val_interp ist gl
           (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x)
-    | List0ArgType ConstrArgType -> 
+    | List0ArgType ConstrArgType ->
         let wit = wit_list0 globwit_constr in
         VList (List.map (mk_constr_value ist gl) (out_gen wit x))
-    | List0ArgType VarArgType -> 
+    | List0ArgType VarArgType ->
         let wit = wit_list0 globwit_var in
         VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
-    | List0ArgType IntArgType -> 
+    | List0ArgType IntArgType ->
         let wit = wit_list0 globwit_int in
         VList (List.map (fun x -> VInteger x) (out_gen wit x))
-    | List0ArgType IntOrVarArgType -> 
+    | List0ArgType IntOrVarArgType ->
         let wit = wit_list0 globwit_int_or_var in
         VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
-    | List1ArgType ConstrArgType -> 
+    | List0ArgType (IdentArgType b) ->
+        let wit = wit_list0 (globwit_ident_gen b) in
+	let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in
+        VList (List.map mk_ident (out_gen wit x))
+    | List0ArgType IntroPatternArgType ->
+        let wit = wit_list0 globwit_intro_pattern in
+	let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in
+        VList (List.map mk_ipat (out_gen wit x))
+    | List1ArgType ConstrArgType ->
         let wit = wit_list1 globwit_constr in
         VList (List.map (mk_constr_value ist gl) (out_gen wit x))
-    | List1ArgType VarArgType -> 
+    | List1ArgType VarArgType ->
         let wit = wit_list1 globwit_var in
         VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
-    | List1ArgType IntArgType -> 
+    | List1ArgType IntArgType ->
         let wit = wit_list1 globwit_int in
         VList (List.map (fun x -> VInteger x) (out_gen wit x))
-    | List1ArgType IntOrVarArgType -> 
+    | List1ArgType IntOrVarArgType ->
         let wit = wit_list1 globwit_int_or_var in
         VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
+    | List1ArgType (IdentArgType b) ->
+        let wit = wit_list1 (globwit_ident_gen b) in
+	let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in
+        VList (List.map mk_ident (out_gen wit x))
+    | List1ArgType IntroPatternArgType ->
+        let wit = wit_list1 globwit_intro_pattern in
+	let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in
+        VList (List.map mk_ipat (out_gen wit x))
     | StringArgType | BoolArgType
-    | QuantHypArgType | RedExprArgType 
-    | OpenConstrArgType _ | ConstrWithBindingsArgType 
-    | ExtraArgType _ | BindingsArgType 
-    | OptArgType _ | PairArgType _ 
-    | List0ArgType _ | List1ArgType _ 
+    | QuantHypArgType | RedExprArgType
+    | OpenConstrArgType _ | ConstrWithBindingsArgType
+    | ExtraArgType _ | BindingsArgType
+    | OptArgType _ | PairArgType _
+    | List0ArgType _ | List1ArgType _
 	-> error "This generic type is not supported in alias."
-        
+
     in
     let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
-    let trace = (loc,LtacNotationCall s)::ist.trace in
+    let trace = push_trace (loc,LtacNotationCall s) ist.trace in
     interp_tactic { ist with lfun=lfun; trace=trace } body gl
 
 let make_empty_glob_sign () =
-  { ltacvars = ([],[]); ltacrecvars = []; 
+  { ltacvars = ([],[]); ltacrecvars = [];
     gsigma = Evd.empty; genv = Global.env() }
 
 (* Initial call for interpretation *)
-let interp_tac_gen lfun avoid_ids debug t gl = 
-  interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } 
+let interp_tac_gen lfun avoid_ids debug t gl =
+  interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] }
     (intern_tactic {
       ltacvars = (List.map fst lfun, []); ltacrecvars = [];
       gsigma = project gl; genv = pf_env gl } t) gl
@@ -2433,17 +2551,17 @@ let eval_tactic t gls =
 let interp t = interp_tac_gen [] [] (get_debug()) t
 
 let eval_ltac_constr gl t =
-  interp_ltac_constr 
+  interp_ltac_constr
     { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl
     (intern_tactic (make_empty_glob_sign ()) t )
 
 (* Hides interpretation for pretty-print *)
 let hide_interp t ot gl =
-  let ist = { ltacvars = ([],[]); ltacrecvars = []; 
+  let ist = { ltacvars = ([],[]); ltacrecvars = [];
             gsigma = project gl; genv = pf_env gl } in
   let te = intern_tactic ist t in
   let t = eval_tactic te in
-  match ot with 
+  match ot with
   | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl
   | Some t' ->
       abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl
@@ -2487,13 +2605,13 @@ let subst_or_var f =  function
 
 let subst_located f (_loc,id) = (dloc,f id)
 
-let subst_reference subst = 
+let subst_reference subst =
   subst_or_var (subst_located (subst_kn subst))
 
 (*CSC: subst_global_reference is used "only" for RefArgType, that propagates
   to the syntactic non-terminals "global", used in commands such as
-  Print. It is also used for non-evaluable references. *) 
-let subst_global_reference subst = 
+  Print. It is also used for non-evaluable references. *)
+let subst_global_reference subst =
  let subst_global ref =
   let ref',t' = subst_global subst ref in
    if not (eq_constr (constr_of_global ref') t') then
@@ -2508,7 +2626,7 @@ let subst_evaluable subst =
   let subst_eval_ref = subst_evaluable_reference subst in
     subst_or_var (subst_and_short_name subst_eval_ref)
 
-let subst_unfold subst (l,e) = 
+let subst_unfold subst (l,e) =
   (l,subst_evaluable subst e)
 
 let subst_flag subst red =
@@ -2516,13 +2634,19 @@ let subst_flag subst red =
 
 let subst_constr_with_occurrences subst (l,c) = (l,subst_rawconstr subst c)
 
+let subst_rawconstr_or_pattern subst (c,p) =
+  (subst_rawconstr subst c,subst_pattern subst p)
+
+let subst_pattern_with_occurrences subst (l,p) =
+  (l,subst_rawconstr_or_pattern subst p)
+
 let subst_redexp subst = function
   | Unfold l -> Unfold (List.map (subst_unfold subst) l)
   | Fold l -> Fold (List.map (subst_rawconstr subst) l)
   | Cbv f -> Cbv (subst_flag subst f)
   | Lazy f -> Lazy (subst_flag subst f)
   | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l)
-  | Simpl o -> Simpl (Option.map (subst_constr_with_occurrences subst) o)
+  | Simpl o -> Simpl (Option.map (subst_pattern_with_occurrences subst) o)
   | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let subst_raw_may_eval subst = function
@@ -2532,8 +2656,8 @@ let subst_raw_may_eval subst = function
   | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c)
 
 let subst_match_pattern subst = function
-  | Subterm (b,ido,pc) -> Subterm (b,ido,subst_pattern subst pc)
-  | Term pc -> Term (subst_pattern subst pc)
+  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_rawconstr_or_pattern subst pc))
+  | Term pc -> Term (subst_rawconstr_or_pattern subst pc)
 
 let rec subst_match_goal_hyps subst = function
   | Hyp (locs,mp) :: tl ->
@@ -2584,10 +2708,10 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) as x -> x
-  | TacInductionDestruct (isrec,ev,l) ->
-      TacInductionDestruct (isrec,ev,List.map (fun (lc,cbo,ids,cls) ->
+  | TacInductionDestruct (isrec,ev,(l,cls)) ->
+      TacInductionDestruct (isrec,ev,(List.map (fun (lc,cbo,ids) ->
 	List.map (subst_induction_arg subst) lc,
-        Option.map (subst_raw_with_bindings subst) cbo, ids, cls) l)
+        Option.map (subst_raw_with_bindings subst) cbo, ids) l, cls))
   | TacDoubleInduction (h1,h2) as x -> x
   | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c)
   | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c)
@@ -2607,23 +2731,23 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   (* Constructors *)
   | TacLeft (ev,bl) -> TacLeft (ev,subst_bindings subst bl)
   | TacRight (ev,bl) -> TacRight (ev,subst_bindings subst bl)
-  | TacSplit (ev,b,bl) -> TacSplit (ev,b,subst_bindings subst bl)
+  | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (subst_bindings subst) bll)
   | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (subst_tactic subst) t)
   | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,subst_bindings subst bl)
 
   (* Conversion *)
   | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
-  | TacChange (occl,c,cl) ->
-      TacChange (Option.map (subst_constr_with_occurrences subst) occl,
+  | TacChange (op,c,cl) ->
+      TacChange (Option.map (subst_rawconstr_or_pattern subst) op,
         subst_rawconstr subst c, cl)
 
   (* Equivalence relations *)
   | TacReflexivity | TacSymmetry _ as x -> x
-  | TacTransitivity c -> TacTransitivity (subst_rawconstr subst c)
+  | TacTransitivity c -> TacTransitivity (Option.map (subst_rawconstr subst) c)
 
   (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) -> 
-      TacRewrite (ev, 
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite (ev,
 		  List.map (fun (b,m,c) ->
 			      b,m,subst_raw_with_bindings subst c) l,
 		 cl,Option.map (subst_tactic subst) by)
@@ -2677,14 +2801,14 @@ and subst_tacarg subst = function
   | MetaIdArg (_loc,_,_) -> assert false
   | TacCall (_loc,f,l) ->
       TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
-  | TacExternal (_loc,com,req,la) -> 
+  | TacExternal (_loc,com,req,la) ->
       TacExternal (_loc,com,req,List.map (subst_tacarg subst) la)
   | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x
   | Tacexp t -> Tacexp (subst_tactic subst t)
   | TacDynamic(the_loc,t) as x ->
-      (match tag t with
+      (match Dyn.tag t with
 	| "tactic" | "value" -> x
-        | "constr" -> 
+        | "constr" ->
           TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t)))
 	| s -> anomaly_loc (dloc, "Tacinterp.val_interp",
                  str "Unknown dynamic: <" ++ str s ++ str ">"))
@@ -2709,11 +2833,11 @@ and subst_genarg subst (x:glob_generic_argument) =
   | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x)
   | IntroPatternArgType ->
       in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x)
-  | IdentArgType b -> 
+  | IdentArgType b ->
       in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x)
   | VarArgType -> in_gen globwit_var (out_gen globwit_var x)
   | RefArgType ->
-      in_gen globwit_ref (subst_global_reference subst 
+      in_gen globwit_ref (subst_global_reference subst
 	(out_gen globwit_ref x))
   | SortArgType ->
       in_gen globwit_sort (out_gen globwit_sort x)
@@ -2723,7 +2847,7 @@ and subst_genarg subst (x:glob_generic_argument) =
       in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x))
   | QuantHypArgType ->
       in_gen globwit_quant_hyp
-        (subst_declared_or_quantified_hypothesis subst 
+        (subst_declared_or_quantified_hypothesis subst
           (out_gen globwit_quant_hyp x))
   | RedExprArgType ->
       in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
@@ -2742,11 +2866,11 @@ and subst_genarg subst (x:glob_generic_argument) =
   | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x
   | ExtraArgType s ->
       match tactic_genarg_level s with
-      | Some n -> 
+      | Some n ->
           (* Special treatment of tactic arguments *)
           in_gen (globwit_tactic n)
             (subst_tactic subst (out_gen (globwit_tactic n) x))
-      | None -> 
+      | None ->
           lookup_genarg_subst s subst x
 
 (***************************************************************************)
@@ -2764,10 +2888,10 @@ let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab)
 type tacdef_kind = | NewTac of identifier
 		   | UpdateTac of ltac_constant
 
-let load_md i ((sp,kn),defs) =
+let load_md i ((sp,kn),(local,defs)) =
   let dp,_ = repr_path sp in
   let mp,dir,_ = repr_kn kn in
-  List.iter (fun (id,t) -> 
+  List.iter (fun (id,t) ->
     match id with
 	NewTac id ->
 	  let sp = Libnames.make_path dp id in
@@ -2775,11 +2899,11 @@ let load_md i ((sp,kn),defs) =
 	    Nametab.push_tactic (Until i) sp kn;
 	    add (kn,t)
       | UpdateTac kn -> replace (kn,t)) defs
-    
-let open_md i((sp,kn),defs) =
+
+let open_md i ((sp,kn),(local,defs)) =
   let dp,_ = repr_path sp in
   let mp,dir,_ = repr_kn kn in
-  List.iter (fun (id,t) -> 
+  List.iter (fun (id,t) ->
     match id with
 	NewTac id ->
 	  let sp = Libnames.make_path dp id in
@@ -2789,13 +2913,17 @@ let open_md i((sp,kn),defs) =
 
 let cache_md x = load_md 1 x
 
-let subst_kind subst id = 
+let subst_kind subst id =
   match id with
     | NewTac _ -> id
-    | UpdateTac kn -> UpdateTac (Mod_subst.subst_kn subst kn)
+    | UpdateTac kn -> UpdateTac (subst_kn subst kn)
+
+let subst_md (subst,(local,defs)) =
+  (local,
+   List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs)
 
-let subst_md (_,subst,defs) =
-  List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs
+let classify_md (local,defs as o) =
+  if local then Dispose else Substitute o
 
 let (inMD,outMD) =
   declare_object {(default_object "TAC-DEFINITION") with
@@ -2803,8 +2931,7 @@ let (inMD,outMD) =
      load_function   = load_md;
      open_function   = open_md;
      subst_function = subst_md;
-     classify_function = (fun (_,o) -> Substitute o);       
-     export_function = (fun x -> Some x)}
+     classify_function = classify_md}
 
 let print_ltac id =
  try
@@ -2822,18 +2949,18 @@ open Libnames
 (* Adds a definition for tactics in the table *)
 let make_absolute_name ident repl =
   let loc = loc_of_reference ident in
-  try 
-    let id, kn = 
+  try
+    let id, kn =
       if repl then None, Nametab.locate_tactic (snd (qualid_of_reference ident))
-      else let id = Pcoq.coerce_global_to_id ident in
-	     Some id, Lib.make_kn id 
+      else let id = coerce_reference_to_id ident in
+	     Some id, Lib.make_kn id
     in
       if Gmap.mem kn !mactab then
 	if repl then id, kn
 	else
 	  user_err_loc (loc,"Tacinterp.add_tacdef",
 		       str "There is already an Ltac named " ++ pr_reference ident ++ str".")
-      else if is_atomic_kn kn then 
+      else if is_atomic_kn kn then
 	user_err_loc (loc,"Tacinterp.add_tacdef",
 		     str "Reserved Ltac name " ++ pr_reference ident ++ str".")
       else id, kn
@@ -2841,21 +2968,12 @@ let make_absolute_name ident repl =
     user_err_loc (loc,"Tacinterp.add_tacdef",
 		 str "There is no Ltac named " ++ pr_reference ident ++ str".")
 
-let rec filter_map f l = 
-  let rec aux acc = function
-      [] -> acc
-    | hd :: tl -> 
-	match f hd with
-	    Some x -> aux (x :: acc) tl
-	  | None -> aux acc tl
-  in aux [] l
-      
-let add_tacdef isrec tacl =
+let add_tacdef local isrec tacl =
   let rfun = List.map (fun (ident, b, _) -> make_absolute_name ident b) tacl in
   let ist =
-    {(make_empty_glob_sign()) with ltacrecvars = 
-	if isrec then filter_map 
-	  (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun 
+    {(make_empty_glob_sign()) with ltacrecvars =
+	if isrec then list_map_filter
+	  (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun
 	else []} in
   let gtacl =
     List.map2 (fun (_,b,def) (id, qid) ->
@@ -2864,11 +2982,12 @@ let add_tacdef isrec tacl =
 	(k, t))
       tacl rfun in
   let id0 = fst (List.hd rfun) in
-  let _ = match id0 with Some id0 -> ignore(Lib.add_leaf id0 (inMD gtacl))
-    | _ -> Lib.add_anonymous_leaf (inMD gtacl) in
+  let _ = match id0 with
+    | Some id0 -> ignore(Lib.add_leaf id0 (inMD (local,gtacl)))
+    | _ -> Lib.add_anonymous_leaf (inMD (local,gtacl)) in
   List.iter
-    (fun (id,b,_) -> 
-      Flags.if_verbose msgnl (Libnames.pr_reference id ++ 
+    (fun (id,b,_) ->
+      Flags.if_verbose msgnl (Libnames.pr_reference id ++
 				 (if b then str " is redefined"
 				   else str " is defined")))
     tacl
@@ -2879,13 +2998,13 @@ let add_tacdef isrec tacl =
 let glob_tactic x =
   Flags.with_option strict_check (intern_tactic (make_empty_glob_sign ())) x
 
-let glob_tactic_env l env x = 
+let glob_tactic_env l env x =
   Flags.with_option strict_check
   (intern_tactic
     { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
     x
 
-let interp_redexp env sigma r = 
+let interp_redexp env sigma r =
   let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in
   let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
   interp_red_expr ist sigma env (intern_red_expr gist r)
@@ -2894,11 +3013,14 @@ let interp_redexp env sigma r =
 (* Embed tactics in raw or glob tactic expr *)
 
 let globTacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t))
-let tacticIn t = globTacticIn (fun ist -> glob_tactic (t ist))
+let tacticIn t =
+  globTacticIn (fun ist ->
+    try glob_tactic (t ist)
+    with e -> raise (AnomalyOnError ("Incorrect tactic expression", e)))
 
 let tacticOut = function
   | TacArg (TacDynamic (_,d)) ->
-    if (tag d) = "tactic" then
+    if (Dyn.tag d) = "tactic" then
       tactic_out d
     else
       anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
@@ -2910,14 +3032,12 @@ let tacticOut = function
 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
 
 let _ = Auto.set_extern_interp
-  (fun l -> 
-    let l = List.map (fun (id,c) -> (id,VConstr c)) l in
+  (fun l ->
+    let l = List.map (fun (id,c) -> (id,VConstr ([],c))) l in
     interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]})
-let _ = Auto.set_extern_intern_tac 
+let _ = Auto.set_extern_intern_tac
   (fun l ->
     Flags.with_option strict_check
     (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
 let _ = Auto.set_extern_subst_tactic subst_tactic
 let _ = Dhyp.set_extern_interp eval_tactic
-let _ = Dhyp.set_extern_intern_tac
-  (fun t -> intern_tactic (make_empty_glob_sign()) t)
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index b66bdb85..f1cdef7f 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -6,10 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacinterp.mli 12102 2009-04-24 10:48:11Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
-open Dyn
 open Pp
 open Util
 open Names
@@ -27,12 +26,12 @@ open Redexpr
 (* Values for interpretation *)
 type value =
   | VRTactic of (goal list sigma * validation)
-  | VFun of ltac_trace * (identifier*value) list * 
+  | VFun of ltac_trace * (identifier*value) list *
       identifier option list * glob_tactic_expr
   | VVoid
   | VInteger of int
   | VIntroPattern of intro_pattern_expr
-  | VConstr of constr
+  | VConstr of Pattern.constr_under_binders
   | VConstr_context of constr
   | VList of value list
   | VRec of (identifier*value) list ref * glob_tactic_expr
@@ -44,8 +43,8 @@ and interp_sign =
     debug : debug_info;
     trace : ltac_trace }
 
-val extract_ltac_vars : interp_sign -> Evd.evar_map -> Environ.env -> 
-  Pretyping.var_map * Pretyping.unbound_ltac_var_map
+val extract_ltac_constr_values : interp_sign -> Environ.env ->
+  Pretyping.ltac_var_map
 
 (* Transforms an id into a constr if possible *)
 val constr_of_id : Environ.env -> identifier -> constr
@@ -53,7 +52,7 @@ val constr_of_id : Environ.env -> identifier -> 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
@@ -67,7 +66,8 @@ val get_debug : unit -> debug_info
 
 (* Adds a definition for tactics in the table *)
 val add_tacdef :
-  bool -> (Libnames.reference * bool * raw_tactic_expr) list -> unit
+  Vernacexpr.locality_flag -> bool ->
+  (Libnames.reference * bool * raw_tactic_expr) list -> unit
 val add_primitive_tactic : string -> glob_tactic_expr -> unit
 
 (* Tactic extensions *)
@@ -88,7 +88,7 @@ type glob_sign = {
 val add_interp_genarg :
   string ->
     (glob_sign -> raw_generic_argument -> glob_generic_argument) *
-    (interp_sign -> goal sigma -> glob_generic_argument -> 
+    (interp_sign -> goal sigma -> glob_generic_argument ->
       typed_generic_argument) *
     (substitution -> glob_generic_argument -> glob_generic_argument)
     -> unit
@@ -99,14 +99,14 @@ val interp_genarg :
 val intern_genarg :
   glob_sign -> raw_generic_argument -> glob_generic_argument
 
-val intern_tactic : 
+val intern_tactic :
   glob_sign -> raw_tactic_expr -> glob_tactic_expr
 
 val intern_constr :
   glob_sign -> constr_expr -> rawconstr_and_expr
 
 val intern_constr_with_bindings :
-  glob_sign -> constr_expr * constr_expr Rawterm.bindings -> 
+  glob_sign -> constr_expr * constr_expr Rawterm.bindings ->
   rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings
 
 val intern_hyp :
@@ -122,7 +122,7 @@ val subst_rawconstr_and_expr :
 val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
 
 (* Interprets an expression that evaluates to a constr *)
-val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> 
+val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
   constr
 
 (* Interprets redexp arguments *)
@@ -134,8 +134,7 @@ val interp_tac_gen : (identifier * value) list -> identifier list ->
 
 val interp_hyp :  interp_sign -> goal sigma -> identifier located -> identifier
 
-val interp_bindings : interp_sign -> goal sigma -> rawconstr_and_expr Rawterm.bindings -> 
-  Evd.open_constr Rawterm.bindings
+val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> rawconstr_and_expr Rawterm.bindings -> Evd.evar_map * constr Rawterm.bindings
 
 (* Initial call for interpretation *)
 val glob_tactic : raw_tactic_expr -> glob_tactic_expr
@@ -158,7 +157,7 @@ val hide_interp : raw_tactic_expr -> tactic option -> tactic
 val declare_implicit_tactic : tactic -> unit
 
 (* Declare the xml printer *)
-val declare_xml_printer : 
+val declare_xml_printer :
   (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit
 
 (* printing *)
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 3db6bcef..33285505 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacticals.ml 12102 2009-04-24 10:48:11Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -29,32 +29,29 @@ open Matching
 open Genarg
 open Tacexpr
 
-(******************************************)
-(*         Basic Tacticals                *)
-(******************************************)
-
-(*************************************************)
-(* Tacticals re-exported from the Refiner module.*)
-(*************************************************)
-
-let tclNORMEVAR      = tclNORMEVAR
-let tclIDTAC         = tclIDTAC
-let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE
-let tclORELSE0       = tclORELSE0
-let tclORELSE        = tclORELSE
-let tclTHEN          = tclTHEN
-let tclTHENLIST      = tclTHENLIST
-let tclTHEN_i        = tclTHEN_i
-let tclTHENFIRST     = tclTHENFIRST
-let tclTHENLAST      = tclTHENLAST
-let tclTHENS         = tclTHENS
+(************************************************************************)
+(* Tacticals re-exported from the Refiner module                        *)
+(************************************************************************)
+
+let tclNORMEVAR      = Refiner.tclNORMEVAR
+let tclIDTAC         = Refiner.tclIDTAC
+let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE
+let tclORELSE0       = Refiner.tclORELSE0
+let tclORELSE        = Refiner.tclORELSE
+let tclTHEN          = Refiner.tclTHEN
+let tclTHENLIST      = Refiner.tclTHENLIST
+let tclMAP           = Refiner.tclMAP
+let tclTHEN_i        = Refiner.tclTHEN_i
+let tclTHENFIRST     = Refiner.tclTHENFIRST
+let tclTHENLAST      = Refiner.tclTHENLAST
+let tclTHENS         = Refiner.tclTHENS
 let tclTHENSV        = Refiner.tclTHENSV
 let tclTHENSFIRSTn   = Refiner.tclTHENSFIRSTn
 let tclTHENSLASTn    = Refiner.tclTHENSLASTn
 let tclTHENFIRSTn    = Refiner.tclTHENFIRSTn
 let tclTHENLASTn     = Refiner.tclTHENLASTn
 let tclREPEAT        = Refiner.tclREPEAT
-let tclREPEAT_MAIN   = tclREPEAT_MAIN
+let tclREPEAT_MAIN   = Refiner.tclREPEAT_MAIN
 let tclFIRST         = Refiner.tclFIRST
 let tclSOLVE         = Refiner.tclSOLVE
 let tclTRY           = Refiner.tclTRY
@@ -62,56 +59,66 @@ let tclINFO          = Refiner.tclINFO
 let tclCOMPLETE      = Refiner.tclCOMPLETE
 let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
 let tclFAIL          = Refiner.tclFAIL
+let tclFAIL_lazy     = Refiner.tclFAIL_lazy
 let tclDO            = Refiner.tclDO
 let tclPROGRESS      = Refiner.tclPROGRESS
 let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
 let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
-let tclTHENTRY       = tclTHENTRY
-let tclIFTHENELSE    = tclIFTHENELSE
-let tclIFTHENSELSE   = tclIFTHENSELSE
-let tclIFTHENSVELSE   = tclIFTHENSVELSE
-let tclIFTHENTRYELSEMUST = tclIFTHENTRYELSEMUST
+let tclTHENTRY       = Refiner.tclTHENTRY
+let tclIFTHENELSE    = Refiner.tclIFTHENELSE
+let tclIFTHENSELSE   = Refiner.tclIFTHENSELSE
+let tclIFTHENSVELSE   = Refiner.tclIFTHENSVELSE
+let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST
+
+(* Synonyms *)
 
-let unTAC            = unTAC
+let tclTHENSEQ       = tclTHENLIST
 
-(* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *)
-let tclTHENSEQ = tclTHENLIST
+(* Experimental *)
 
-(* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *)
-(* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *)
-let tclMAP tacfun l = 
-  List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC
+let rec tclFIRST_PROGRESS_ON tac = function
+  | []    -> tclFAIL 0 (str "No applicable tactic")
+  | [a]   -> tac a (* so that returned failure is the one from last item *)
+  | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl)
 
-(* apply a tactic to the nth element of the signature  *)
+(************************************************************************)
+(* Tacticals applying on hypotheses                                     *)
+(************************************************************************)
 
-let tclNTH_HYP m (tac : constr->tactic) gl =
-  tac (try mkVar(let (id,_,_) = List.nth (pf_hyps gl) (m-1) in id) 
-       with Failure _ -> error "No such assumption.") gl
+let nthDecl m gl =
+  try List.nth (pf_hyps gl) (m-1)
+  with Failure _ -> error "No such assumption."
 
-let tclNTH_DECL m tac gl =
-  tac (try List.nth (pf_hyps gl) (m-1) 
-       with Failure _ -> error "No such assumption.") gl
+let nthHypId m gl = pi1 (nthDecl m gl)
+let nthHyp m gl   = mkVar (nthHypId m gl)
 
-(* apply a tactic to the last element of the signature  *)
+let lastDecl gl   = nthDecl 1 gl
+let lastHypId gl  = nthHypId 1 gl
+let lastHyp gl    = nthHyp 1 gl
 
-let tclLAST_HYP = tclNTH_HYP 1
+let nLastDecls n gl =
+  try list_firstn n (pf_hyps gl)
+  with Failure _ -> error "Not enough hypotheses in the goal."
 
-let tclLAST_DECL = tclNTH_DECL 1
+let nLastHypsId n gl = List.map pi1 (nLastDecls n gl)
+let nLastHyps n gl   = List.map mkVar (nLastHypsId n gl)
 
-let tclLAST_NHYPS n tac gl =
-  tac (try list_firstn n (pf_ids_of_hyps gl)
-       with Failure _ -> error "No such assumptions.") gl
+let onNthDecl m tac gl  = tac (nthDecl m gl) gl
+let onNthHypId m tac gl = tac (nthHypId m gl) gl
+let onNthHyp m tac gl   = tac (nthHyp m gl) gl
 
-let tclTRY_sign (tac : constr->tactic) sign gl =
-  let rec arec = function
-    | []      -> tclFAIL 0 (str "No applicable hypothesis.")
-    | [s]     -> tac (mkVar s) (*added in order to get useful error messages *)
-    | (s::sl) -> tclORELSE (tac (mkVar s)) (arec sl) 
-  in 
-  arec (ids_of_named_context sign) gl
+let onLastDecl  = onNthDecl 1
+let onLastHypId = onNthHypId 1
+let onLastHyp   = onNthHyp 1
 
-let tclTRY_HYPS (tac : constr->tactic) gl = 
-  tclTRY_sign tac (pf_hyps gl) gl
+let onHyps find tac gl = tac (find gl) gl
+
+let onNLastDecls n tac  = onHyps (nLastDecls n) tac
+let onNLastHypsId n tac = onHyps (nLastHypsId n) tac
+let onNLastHyps n tac   = onHyps (nLastHyps n) tac
+
+let afterHyp id gl =
+  fst (list_split_when (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
 
 (***************************************)
 (*           Clause Tacticals          *)
@@ -122,150 +129,122 @@ let tclTRY_HYPS (tac : constr->tactic) gl =
    or (Some id), where id is an identifier. This type is useful for
    defining tactics that may be used either to transform the
    conclusion (None) or to transform a hypothesis id (Some id).  --
-   --Eduardo (8/8/97) 
+   --Eduardo (8/8/97)
 *)
 
-(* The type of clauses *)
+(* A [simple_clause] is a set of hypotheses, possibly extended with
+   the conclusion (conclusion is represented by None) *)
+
+type simple_clause = identifier option list
+
+(* An [clause] is the algebraic form of a
+   [concrete_clause]; it may refer to all hypotheses
+   independently of the effective contents of the current goal *)
 
-type simple_clause = identifier gsimple_clause
 type clause = identifier gclause
 
-let allClauses = { onhyps=None; concl_occs=all_occurrences_expr }
+let allHypsAndConcl = { onhyps=None; concl_occs=all_occurrences_expr }
 let allHyps = { onhyps=None; concl_occs=no_occurrences_expr }
 let onConcl = { onhyps=Some[]; concl_occs=all_occurrences_expr }
 let onHyp id =
-  { onhyps=Some[((all_occurrences_expr,id),InHyp)]; concl_occs=no_occurrences_expr }
-
-let simple_clause_list_of cl gls =
+  { onhyps=Some[((all_occurrences_expr,id),InHyp)];
+    concl_occs=no_occurrences_expr }
+
+let simple_clause_of cl gls =
+  let error_occurrences () =
+    error "This tactic does not support occurrences selection" in
+  let error_body_selection () =
+    error "This tactic does not support body selection" in
   let hyps =
-    match cl.onhyps with 
+    match cl.onhyps with
     | None ->
-	let f id = Some((all_occurrences_expr,id),InHyp) in
-	List.map f (pf_ids_of_hyps gls)
+	List.map Option.make (pf_ids_of_hyps gls)
     | Some l ->
-	List.map (fun h -> Some h) l in
-  if cl.concl_occs = all_occurrences_expr then None::hyps else hyps
-
-
-(* OR-branch *)
-let tryClauses tac cl gls = 
-  let rec firstrec = function
-    | []      -> tclFAIL 0 (str "no applicable hypothesis")
-    | [cls]   -> tac cls (* added in order to get a useful error message *)
-    | cls::tl -> (tclORELSE (tac cls) (firstrec tl))
-  in
-  let hyps = simple_clause_list_of cl gls in
-  firstrec hyps gls
-
-(* AND-branch *)
-let onClauses tac cl gls = 
-  let hyps = simple_clause_list_of cl gls in
-  tclMAP tac hyps gls
-
-(* AND-branch reverse order*)
-let onClausesLR tac cl gls = 
-  let hyps = simple_clause_list_of cl gls in
-  tclMAP tac (List.rev hyps) gls
-
-(* A clause corresponding to the |n|-th hypothesis or None *)
-
-let nth_clause n gl =
-  if n = 0 then 
-    onConcl
-  else if n < 0 then 
-    let id = List.nth (List.rev (pf_ids_of_hyps gl)) (-n-1) in 
-    onHyp id
-  else 
-    let id = List.nth (pf_ids_of_hyps gl) (n-1) in 
-    onHyp id
-
-(* Gets the conclusion or the type of a given hypothesis *)
-
-let clause_type cls gl =
-  match simple_clause_of cls with
-    | None    -> pf_concl gl
-    | Some ((_,id),_) -> pf_get_hyp_typ gl id
-
-(* Functions concerning matching of clausal environments *)
-
-let pf_is_matching gls pat n =
-  is_matching_conv (pf_env gls) (project gls) pat n
-
-let pf_matches gls pat n =
-  matches_conv (pf_env gls) (project gls) pat n
-
-(* [OnCL clausefinder clausetac]
- * executes the clausefinder to find the clauses, and then executes the
- * clausetac on the clause so obtained. *)
-
-let onCL cfind cltac gl = cltac (cfind gl) gl
+	List.map (fun ((occs,id),w) ->
+	  if occs <> all_occurrences_expr then error_occurrences ();
+	  if w = InHypValueOnly then error_body_selection ();
+	  Some id) l in
+  if cl.concl_occs = no_occurrences_expr then hyps
+  else
+    if cl.concl_occs <> all_occurrences_expr then error_occurrences ()
+    else None :: hyps
 
+let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl)
 
-(* [OnHyps hypsfinder hypstac]
- * idem [OnCL] but only for hypotheses, not for conclusion *)
-
-let onHyps find tac gl = tac (find gl) gl
+let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl
+let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl
+let onAllHypsAndConclLR tac gl = tclMAP tac (List.rev (fullGoal gl)) gl
 
+let tryAllHyps tac gl = tclFIRST_PROGRESS_ON tac (pf_ids_of_hyps gl) gl
+let tryAllHypsAndConcl tac gl = tclFIRST_PROGRESS_ON tac (fullGoal gl) gl
+let tryAllHypsAndConclLR tac gl =
+  tclFIRST_PROGRESS_ON tac (List.rev (fullGoal gl)) gl
 
+let onClause tac cl gls = tclMAP tac (simple_clause_of cl gls) gls
+let onClauseLR tac cl gls = tclMAP tac (List.rev (simple_clause_of cl gls)) gls
 
-(* Create a clause list with all the hypotheses from the context, occuring
-   after id *)
-
-let afterHyp id gl =
-  fst (list_split_at (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
-    
+let ifOnHyp pred tac1 tac2 id gl =
+  if pred (id,pf_get_hyp_typ gl id) then
+    tac1 id gl
+  else
+    tac2 id gl
 
-(* Create a singleton clause list with the last hypothesis from then context *)
 
-let lastHyp gl = List.hd (pf_ids_of_hyps gl)
+(************************************************************************)
+(* An intermediate form of occurrence clause that select components     *)
+(* of a definition, hypotheses and possibly the goal                    *)
+(* (used for reduction tactics)                                         *)
+(************************************************************************)
 
+(* A [hyp_location] is an hypothesis together with a position, in
+   body if any, in type or in both *)
 
-(* Create a clause list with the n last hypothesis from then context *)
+type hyp_location = identifier * hyp_location_flag
 
-let nLastHyps n gl =
-  try list_firstn n (pf_hyps gl)
-  with Failure "firstn" -> error "Not enough hypotheses in the goal."
+(* A [goal_location] is either an hypothesis (together with a position, in
+   body if any, in type or in both) or the goal *)
 
+type goal_location = hyp_location option
 
-let onClause t cls gl  = t cls gl
-let tryAllClauses  tac = tryClauses tac allClauses
-let onAllClauses   tac = onClauses tac allClauses
-let onAllClausesLR tac = onClausesLR tac allClauses
-let onNthLastHyp n tac gls = tac (nth_clause n gls) gls
+(************************************************************************)
+(* An intermediate structure for dealing with occurrence clauses        *)
+(************************************************************************)
 
-let tryAllHyps     tac =
-  tryClauses (function Some((_,id),_) -> tac id | _ -> assert false) allHyps
-let onNLastHyps n  tac     = onHyps (nLastHyps n) (tclMAP tac)
-let onLastHyp      tac gls = tac (lastHyp gls) gls
+(* [clause_atom] refers either to an hypothesis location (i.e. an
+   hypothesis with occurrences and a position, in body if any, in type
+   or in both) or to some occurrences of the conclusion *)
 
-let clauseTacThen tac continuation =
-  (fun cls -> (tclTHEN (tac cls) continuation))
+type clause_atom =
+  | OnHyp of identifier * occurrences_expr * hyp_location_flag
+  | OnConcl of occurrences_expr
 
-let if_tac pred tac1 tac2 gl =
-  if pred gl then tac1 gl else tac2 gl
+(* A [concrete_clause] is an effective collection of
+  occurrences in the hypotheses and the conclusion *)
 
-let ifOnClause pred tac1 tac2 cls gl =
-  if pred (cls,clause_type cls gl) then
-    tac1 cls gl
-  else 
-    tac2 cls gl
+type concrete_clause = clause_atom list
 
-let ifOnHyp pred tac1 tac2 id gl =
-  if pred (id,pf_get_hyp_typ gl id) then
-    tac1 id gl
-  else 
-    tac2 id gl
+let concrete_clause_of cl gls =
+  let hyps =
+    match cl.onhyps with
+    | None ->
+	let f id = OnHyp (id,all_occurrences_expr,InHyp) in
+	List.map f (pf_ids_of_hyps gls)
+    | Some l ->
+	List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in
+  if cl.concl_occs = no_occurrences_expr then hyps
+  else
+    OnConcl cl.concl_occs :: hyps
 
-(***************************************)
-(*         Elimination Tacticals       *)
-(***************************************)
+(************************************************************************)
+(* Elimination Tacticals                                                *)
+(************************************************************************)
 
 (* The following tacticals allow to apply a tactic to the
    branches generated by the application of an elimination
-  tactic. 
+  tactic.
 
   Two auxiliary types --branch_args and branch_assumptions-- are
-  used to keep track of some information about the ``branches'' of 
+  used to keep track of some information about the ``branches'' of
   the elimination. *)
 
 type branch_args = {
@@ -283,18 +262,18 @@ type branch_assumptions = {
   assums    : named_context}   (* the list of assumptions introduced *)
 
 let fix_empty_or_and_pattern nv l =
-  (* 1- The syntax does not distinguish between "[ ]" for one clause with no 
+  (* 1- The syntax does not distinguish between "[ ]" for one clause with no
      names and "[ ]" for no clause at all *)
-  (* 2- More generally, we admit "[ ]" for any disjunctive pattern of 
+  (* 2- More generally, we admit "[ ]" for any disjunctive pattern of
      arbitrary length *)
   if l = [[]] then list_make nv [] else l
 
 let check_or_and_pattern_size loc names n =
   if List.length names <> n then
-    if n = 1 then 
+    if 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 
+    else
+      user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n
 	++ str " branches.")
 
 let compute_induction_names n = function
@@ -309,7 +288,7 @@ let compute_induction_names n = function
 
 let compute_construtor_signatures isrec (_,k as ity) =
   let rec analrec c recargs =
-    match kind_of_term c, recargs with 
+    match kind_of_term c, recargs with
     | Prod (_,_,c), recarg::rest ->
 	let b = match dest_recarg recarg with
 	  | Norec | Imbr _  -> false
@@ -318,7 +297,7 @@ let compute_construtor_signatures isrec (_,k as ity) =
     | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
     | _, [] -> []
     | _ -> anomaly "compute_construtor_signatures"
-  in 
+  in
   let (mib,mip) = Global.lookup_inductive ity in
   let n = mib.mind_nparams in
   let lc =
@@ -326,27 +305,27 @@ let compute_construtor_signatures isrec (_,k as ity) =
   let lrecargs = dest_subterms mip.mind_recargs in
   array_map2 analrec lc lrecargs
 
-let elimination_sort_of_goal gl = 
+let elimination_sort_of_goal gl =
   pf_apply Retyping.get_sort_family_of gl (pf_concl gl)
 
-let elimination_sort_of_hyp id gl = 
+let elimination_sort_of_hyp id gl =
   pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id)
 
 let elimination_sort_of_clause = function
-  | None -> elimination_sort_of_goal 
+  | None -> elimination_sort_of_goal
   | Some id -> elimination_sort_of_hyp id
 
 (* Find the right elimination suffix corresponding to the sort of the goal *)
 (* c should be of type A1->.. An->B with B an inductive definition *)
 
-let general_elim_then_using mk_elim 
-  isrec allnames tac predicate (indbindings,elimbindings) 
+let general_elim_then_using mk_elim
+  isrec allnames tac predicate (indbindings,elimbindings)
   ind indclause gl =
   let elim = mk_elim ind gl in
   (* applying elimination_scheme just a little modified *)
   let indclause' = clenv_match_args indbindings indclause in
   let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in
-  let indmv = 
+  let indmv =
     match kind_of_term (last_arg elimclause.templval.Evd.rebus) with
       | Meta mv -> mv
       | _         -> anomaly "elimination"
@@ -362,7 +341,7 @@ let general_elim_then_using mk_elim
 	      | Var id -> string_of_id id
 	      | _ -> "\b"
 	  in
-	  error ("The elimination combinator " ^ name_elim ^ " is unknown.") 
+	  error ("The elimination combinator " ^ name_elim ^ " is unknown.")
   in
   let elimclause' = clenv_fchain indmv elimclause indclause' in
   let elimclause' = clenv_match_args elimbindings elimclause' in
@@ -372,15 +351,15 @@ let general_elim_then_using mk_elim
     let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in
     let ba = { branchsign = branchsigns.(i);
                branchnames = brnames.(i);
-               nassums = 
-		 List.fold_left 
+               nassums =
+		 List.fold_left
                    (fun acc b -> if b then acc+2 else acc+1)
                    0 branchsigns.(i);
                branchnum = i+1;
                ity = ind;
                largs = List.map (clenv_nf_meta ce) largs;
                pred = clenv_nf_meta ce hd }
-    in 
+    in
     tac ba gl
   in
   let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in
@@ -389,7 +368,7 @@ let general_elim_then_using mk_elim
        | None   -> elimclause'
        | Some p ->
            clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause'
-  in 
+  in
   elim_res_pf_THEN_i elimclause' branchtacs gl
 
 (* computing the case/elim combinators *)
@@ -398,12 +377,14 @@ let gl_make_elim ind gl =
   Indrec.lookup_eliminator ind (elimination_sort_of_goal gl)
 
 let gl_make_case_dep ind gl =
-  pf_apply Indrec.make_case_dep gl ind (elimination_sort_of_goal gl)
+  pf_apply Indrec.build_case_analysis_scheme gl ind true
+    (elimination_sort_of_goal gl)
 
 let gl_make_case_nodep ind gl =
-  pf_apply Indrec.make_case_nodep gl ind (elimination_sort_of_goal gl)
+  pf_apply Indrec.build_case_analysis_scheme gl ind false
+    (elimination_sort_of_goal gl)
 
-let elimination_then_using tac predicate bindings c gl = 
+let elimination_then_using tac predicate bindings c gl =
   let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
   let indclause  = mk_clenv_from gl (c,t) in
   general_elim_then_using gl_make_elim
@@ -415,14 +396,14 @@ let case_then_using =
 let case_nodep_then_using =
   general_elim_then_using gl_make_case_nodep false
 
-let elimination_then tac        = elimination_then_using tac None 
+let elimination_then tac        = elimination_then_using tac None
 let simple_elimination_then tac = elimination_then tac ([],[])
 
 
-let make_elim_branch_assumptions ba gl =   
+let make_elim_branch_assumptions ba gl =
   let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
-    match lb,lc with 
-      | ([], _) -> 
+    match lb,lc with
+      | ([], _) ->
           { ba = ba;
             assums    = assums}
       | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) ->
@@ -438,7 +419,7 @@ let make_elim_branch_assumptions ba gl =
 		   recargs,
 		   indargs) tl idtl
       | (_, _) -> anomaly "make_elim_branch_assumptions"
-  in 
+  in
   makerec ([],[],[],[],[]) ba.branchsign
     (try list_firstn ba.nassums (pf_hyps gl)
      with Failure _ -> anomaly "make_elim_branch_assumptions")
@@ -447,8 +428,8 @@ 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 
-      | ([], _) -> 
+    match p_0,p_1 with
+      | ([], _) ->
           { ba = ba;
             assums    = assums}
       | ((true::tl), ((idrec,_,_ as recarg)::idtl)) ->
@@ -462,7 +443,7 @@ let make_case_branch_assumptions ba gl =
 		   recargs,
 		   id::constargs) tl idtl
       | (_, _) -> anomaly "make_case_branch_assumptions"
-  in 
+  in
   makerec ([],[],[],[]) ba.branchsign
     (try list_firstn ba.nassums (pf_hyps gl)
      with Failure _ -> anomaly "make_case_branch_assumptions")
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 25a0d897..b9c8ab92 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacticals.mli 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -21,6 +21,8 @@ open Reduction
 open Pattern
 open Genarg
 open Tacexpr
+open Termops
+open Rawterm
 (*i*)
 
 (* Tacticals i.e. functions from tactics to tactics. *)
@@ -51,76 +53,112 @@ val tclINFO          : tactic -> tactic
 val tclCOMPLETE      : tactic -> tactic
 val tclAT_LEAST_ONCE : tactic -> tactic
 val tclFAIL          : int -> std_ppcmds -> tactic
+val tclFAIL_lazy     : int -> std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
-
-val tclNTH_HYP       : int -> (constr -> tactic) -> tactic
-val tclNTH_DECL      : int -> (named_declaration -> tactic) -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
-val tclLAST_HYP      : (constr -> tactic) -> tactic
-val tclLAST_DECL     : (named_declaration -> tactic) -> tactic
-val tclLAST_NHYPS    : int -> (identifier list -> tactic) -> tactic
-val tclTRY_sign      : (constr -> tactic) -> named_context -> tactic
-val tclTRY_HYPS      : (constr -> tactic) -> tactic
-
-val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
-val tclIFTHENSELSE   : tactic -> tactic list -> tactic -> tactic
-val tclIFTHENSVELSE  : tactic -> tactic array -> tactic -> tactic
 
+val tclIFTHENELSE        : tactic -> tactic -> tactic -> tactic
+val tclIFTHENSELSE       : tactic -> tactic list -> tactic -> tactic
+val tclIFTHENSVELSE      : tactic -> tactic array -> tactic -> tactic
 val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
-val unTAC            : tactic -> goal sigma -> proof_tree sigma
+val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic
+
+(*s Tacticals applying to hypotheses *)
+
+val onNthHypId       : int -> (identifier -> tactic) -> tactic
+val onNthHyp         : int -> (constr -> tactic) -> tactic
+val onNthDecl        : int -> (named_declaration -> tactic) -> tactic
+val onLastHypId      : (identifier -> tactic) -> tactic
+val onLastHyp        : (constr -> tactic) -> tactic
+val onLastDecl       : (named_declaration -> tactic) -> tactic
+val onNLastHypsId    : int -> (identifier list -> tactic) -> tactic
+val onNLastHyps      : int -> (constr list -> tactic) -> tactic
+val onNLastDecls     : int -> (named_context -> tactic) -> tactic
+
+val lastHypId   : goal sigma -> identifier
+val lastHyp     : goal sigma -> constr
+val lastDecl    : goal sigma -> named_declaration
+val nLastHypsId : int -> goal sigma -> identifier list
+val nLastHyps   : int -> goal sigma -> constr list
+val nLastDecls  : int -> goal sigma -> named_context
+
+val afterHyp    : identifier -> goal sigma -> named_context
+
+val ifOnHyp     : (identifier * types -> bool) ->
+                  (identifier -> tactic) -> (identifier -> tactic) ->
+		   identifier -> tactic
 
-(*s Clause tacticals. *)
+val onHyps      : (goal sigma -> named_context) ->
+                  (named_context -> tactic) -> tactic
+
+(*s Tacticals applying to goal components *)
+
+(* A [simple_clause] is a set of hypotheses, possibly extended with
+   the conclusion (conclusion is represented by None) *)
+
+type simple_clause = identifier option list
+
+(* A [clause] denotes occurrences and hypotheses in a
+   goal; in particular, it can abstractly refer to the set of
+   hypotheses independently of the effective contents of the current goal *)
 
-type simple_clause = identifier gsimple_clause
 type clause = identifier gclause
 
-val allClauses : 'a gclause
-val allHyps : clause
-val onHyp : identifier -> clause
-val onConcl : 'a gclause
-
-val nth_clause  : int -> goal sigma -> clause
-val clause_type : clause -> goal sigma -> constr
-val simple_clause_list_of : clause -> goal sigma -> simple_clause list
-
-val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map
-val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
-
-val afterHyp   : identifier -> goal sigma -> named_context
-val lastHyp    : goal sigma -> identifier
-val nLastHyps  : int -> goal sigma -> named_context
-
-val onCL           : (goal sigma -> clause) -> 
-                     (clause -> tactic) -> tactic
-val tryAllClauses  : (simple_clause -> tactic) -> tactic
-val onAllClauses   : (simple_clause -> tactic) -> tactic
-val onClause       : (clause -> tactic) -> clause -> tactic
-val onClauses      : (simple_clause -> tactic) -> clause -> tactic
-val onAllClausesLR : (simple_clause -> tactic) -> tactic
-val onNthLastHyp   : int -> (clause -> tactic) -> tactic
-val clauseTacThen  : (clause -> tactic) -> tactic -> clause -> tactic
-val if_tac         : (goal sigma -> bool) -> tactic -> (tactic) -> tactic
-val ifOnClause     : 
-  (clause * types -> bool) ->
-    (clause -> tactic) -> (clause -> tactic) -> clause -> tactic
-val ifOnHyp        : 
-  (identifier * types -> bool) ->
-    (identifier -> tactic) -> (identifier -> tactic) -> identifier -> tactic
-
-val onHyps         : (goal sigma -> named_context) -> 
-                     (named_context -> tactic) -> tactic
-val tryAllHyps     : (identifier -> tactic) -> tactic
-val onNLastHyps    : int -> (named_declaration -> tactic) -> tactic
-val onLastHyp      : (identifier -> tactic) -> tactic
+val simple_clause_of : clause -> goal sigma -> simple_clause
+
+val allHypsAndConcl : clause
+val allHyps         : clause
+val onHyp           : identifier -> clause
+val onConcl         : clause
+
+val tryAllHyps          : (identifier -> tactic) -> tactic
+val tryAllHypsAndConcl  : (identifier option -> tactic) -> tactic
+
+val onAllHyps           : (identifier -> tactic) -> tactic
+val onAllHypsAndConcl   : (identifier option -> tactic) -> tactic
+val onAllHypsAndConclLR : (identifier option -> tactic) -> tactic
+
+val onClause   : (identifier option -> tactic) -> clause -> tactic
+val onClauseLR : (identifier option -> tactic) -> clause -> tactic
+
+(*s An intermediate form of occurrence clause with no mention of occurrences *)
+
+(* A [hyp_location] is an hypothesis together with a position, in
+   body if any, in type or in both *)
+
+type hyp_location = identifier * hyp_location_flag
+
+(* A [goal_location] is either an hypothesis (together with a position, in
+   body if any, in type or in both) or the goal *)
+
+type goal_location = hyp_location option
+
+(*s A concrete view of occurrence clauses *)
+
+(* [clause_atom] refers either to an hypothesis location (i.e. an
+   hypothesis with occurrences and a position, in body if any, in type
+   or in both) or to some occurrences of the conclusion *)
+
+type clause_atom =
+  | OnHyp of identifier * occurrences_expr * hyp_location_flag
+  | OnConcl of occurrences_expr
+
+(* A [concrete_clause] is an effective collection of
+  occurrences in the hypotheses and the conclusion *)
+
+type concrete_clause = clause_atom list
+
+(* This interprets an [clause] in a given [goal] context *)
+val concrete_clause_of : clause -> goal sigma -> concrete_clause
 
 (*s Elimination tacticals. *)
 
-type branch_args = { 
+type branch_args = {
   ity        : inductive;   (* the type we were eliminating on *)
   largs      : constr list; (* its arguments *)
   branchnum  : int;         (* the branch number *)
@@ -137,15 +175,15 @@ type branch_assumptions = {
 (* [check_disjunctive_pattern_size loc pats n] returns an appropriate *)
 (* error message if |pats| <> n *)
 val check_or_and_pattern_size :
-  Util.loc -> or_and_intro_pattern_expr -> int -> unit 
+  Util.loc -> or_and_intro_pattern_expr -> int -> unit
 
 (* Tolerate "[]" to mean a disjunctive pattern of any length *)
-val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> 
+val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr ->
   or_and_intro_pattern_expr
 
 (* Useful for [as intro_pattern] modifier *)
-val compute_induction_names : 
-  int -> intro_pattern_expr located option -> 
+val compute_induction_names :
+  int -> intro_pattern_expr located option ->
     intro_pattern_expr located list array
 
 val elimination_sort_of_goal : goal sigma -> sorts_family
@@ -154,30 +192,30 @@ val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family
 
 val general_elim_then_using :
   (inductive -> goal sigma -> constr) -> rec_flag ->
-  intro_pattern_expr located option -> (branch_args -> tactic) -> 
+  intro_pattern_expr located option -> (branch_args -> tactic) ->
     constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv ->
     tactic
-	  
+
 val elimination_then_using :
-  (branch_args -> tactic) -> constr option -> 
+  (branch_args -> tactic) -> constr option ->
     (arg_bindings * arg_bindings) -> constr -> tactic
 
 val elimination_then :
-  (branch_args -> tactic) -> 
+  (branch_args -> tactic) ->
     (arg_bindings * arg_bindings) -> constr -> tactic
 
 val case_then_using :
-  intro_pattern_expr located option -> (branch_args -> tactic) -> 
+  intro_pattern_expr located option -> (branch_args -> tactic) ->
     constr option -> (arg_bindings * arg_bindings) ->
       inductive -> clausenv -> tactic
 
 val case_nodep_then_using :
-  intro_pattern_expr located option -> (branch_args -> tactic) -> 
-    constr option -> (arg_bindings * arg_bindings) -> 
+  intro_pattern_expr located option -> (branch_args -> tactic) ->
+    constr option -> (arg_bindings * arg_bindings) ->
       inductive -> clausenv -> tactic
 
 val simple_elimination_then :
   (branch_args -> tactic) -> constr -> tactic
 
-val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic 
-val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic 
+val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
+val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 0a4c0fbe..69bc0653 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactics.ml 12956 2010-04-20 08:49:15Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,6 +15,7 @@ open Nameops
 open Sign
 open Term
 open Termops
+open Namegen
 open Declarations
 open Inductive
 open Inductiveops
@@ -58,24 +59,38 @@ let rec nb_prod x =
 
 let inj_with_occurrences e = (all_occurrences_expr,e)
 
-let inj_open c = (Evd.empty,c)
+let dloc = dummy_loc
 
-let inj_occ (occ,c) = (occ,inj_open c)
+(* Option for 8.2 compatibility *)
+open Goptions
+let dependent_propositions_elimination = ref true
 
-let inj_red_expr = function
-  | Simpl lo -> Simpl (Option.map inj_occ lo)
-  | Fold l -> Fold (List.map inj_open l)
-  | Pattern l -> Pattern (List.map inj_occ l)
-  | (ExtraRedExpr _ | CbvVm | Red _ | Hnf | Cbv _ | Lazy _ | Unfold _ as c)
-    -> c
+let use_dependent_propositions_elimination () =
+  !dependent_propositions_elimination
+  && Flags.version_strictly_greater Flags.V8_2
 
-let inj_ebindings = function
-  | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map inj_open l)
-  | ExplicitBindings l -> 
-      ExplicitBindings (List.map (fun (l,id,c) -> (l,id,inj_open c)) l)
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "dependent-propositions-elimination tactic";
+      optkey   = ["Dependent";"Propositions";"Elimination"];
+      optread  = (fun () -> !dependent_propositions_elimination) ;
+      optwrite = (fun b -> dependent_propositions_elimination := b) }
+
+let apply_in_side_conditions_come_first = ref true
+
+let use_apply_in_side_conditions_come_first () =
+  !apply_in_side_conditions_come_first
+  && Flags.version_strictly_greater Flags.V8_2
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "apply-in side-conditions coming first";
+      optkey   = ["Side";"Conditions";"First";"For";"apply";"in"];
+      optread  = (fun () -> !dependent_propositions_elimination) ;
+      optwrite = (fun b -> dependent_propositions_elimination := b) }
 
-let dloc = dummy_loc
 
 (*********************************************)
 (*                 Tactics                   *)
@@ -85,10 +100,10 @@ let dloc = dummy_loc
 (* General functions                    *)
 (****************************************)
 
-let string_of_inductive c = 
+let string_of_inductive c =
   try match kind_of_term c with
-  | Ind ind_sp -> 
-      let (mib,mip) = Global.lookup_inductive ind_sp in 
+  | Ind ind_sp ->
+      let (mib,mip) = Global.lookup_inductive ind_sp in
       string_of_id mip.mind_typename
   | _ -> raise Bound
   with Bound -> error "Bound head variable."
@@ -101,14 +116,14 @@ let rec head_constr_bound t =
     | Const _ | Ind _ | Construct _ | Var _ -> (hd,args)
     | _ -> raise Bound
 
-let head_constr c = 
+let head_constr c =
   try head_constr_bound c with Bound -> error "Bound head variable."
 
 (******************************************)
 (*           Primitive tactics            *)
 (******************************************)
 
-let introduction    = Tacmach.introduction 
+let introduction    = Tacmach.introduction
 let refine          = Tacmach.refine
 let convert_concl   = Tacmach.convert_concl
 let convert_hyp     = Tacmach.convert_hyp
@@ -117,16 +132,16 @@ let thin_body       = Tacmach.thin_body
 let error_clear_dependency env id = function
   | Evarutil.OccurHypInSimpleClause None ->
       errorlabstrm "" (pr_id id ++ str " is used in conclusion.")
-  | Evarutil.OccurHypInSimpleClause (Some id') -> 
+  | Evarutil.OccurHypInSimpleClause (Some id') ->
       errorlabstrm ""
         (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".")
   | Evarutil.EvarTypingBreak ev ->
       errorlabstrm ""
-        (str "Cannot remove " ++ pr_id id ++ 
-	 strbrk " without breaking the typing of " ++ 
+        (str "Cannot remove " ++ pr_id id ++
+	 strbrk " without breaking the typing of " ++
 	 Printer.pr_existential env ev ++ str".")
 
-let thin l gl = 
+let thin l gl =
   try thin l gl
   with Evarutil.ClearDependencyError (id,err) ->
     error_clear_dependency (pf_env gl) id err
@@ -148,7 +163,7 @@ let internal_cut_rev = internal_cut_rev_gen false
 let internal_cut_rev_replace = internal_cut_rev_gen true
 
 (* Moving hypotheses *)
-let move_hyp        = Tacmach.move_hyp 
+let move_hyp        = Tacmach.move_hyp
 
 let order_hyps      = Tacmach.order_hyps
 
@@ -159,11 +174,11 @@ let rename_hyp      = Tacmach.rename_hyp
 (*          Fresh names                                       *)
 (**************************************************************)
 
-let fresh_id_avoid avoid id =
-  next_global_ident_away true id avoid
+let fresh_id_in_env avoid id env =
+  next_ident_away_in_goal id (avoid@ids_of_named_context (named_context env))
 
 let fresh_id avoid id gl =
-  fresh_id_avoid (avoid@(pf_ids_of_hyps gl)) id
+  fresh_id_in_env avoid id (pf_env gl)
 
 (**************************************************************)
 (*          Fixpoints and CoFixpoints                         *)
@@ -173,19 +188,19 @@ let fresh_id avoid id gl =
 let mutual_fix = Tacmach.mutual_fix
 
 let fix ido n gl = match ido with
-  | None -> 
-      mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] gl
+  | None ->
+      mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] 0 gl
   | Some id ->
-      mutual_fix id n [] gl
+      mutual_fix id n [] 0 gl
 
 (* Refine as a cofixpoint *)
 let mutual_cofix = Tacmach.mutual_cofix
 
 let cofix ido gl = match ido with
-  | None -> 
-      mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] gl
+  | None ->
+      mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] 0 gl
   | Some id ->
-      mutual_cofix id [] gl
+      mutual_cofix id [] 0 gl
 
 (**************************************************************)
 (*          Reduction and conversion tactics                  *)
@@ -196,7 +211,7 @@ 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 -> 
+  | None ->
       if where = InHypValueOnly then
 	errorlabstrm "" (pr_id id ++ str "has no value.");
       (id,None,redfun' ty)
@@ -205,39 +220,88 @@ let pf_reduce_decl redfun where (id,c,ty) gl =
       let ty' =	if where <> InHypValueOnly then redfun' ty else ty in
       (id,Some b',ty')
 
+(* Possibly equip a reduction with the occurrences mentioned in an
+   occurrence clause *)
+
+let error_illegal_clause () =
+  error "\"at\" clause not supported in presence of an occurrence clause."
+
+let error_illegal_non_atomic_clause () =
+  error "\"at\" clause not supported in presence of a non atomic \"in\" clause."
+
+let error_occurrences_not_unsupported () =
+  error "Occurrences not supported for this reduction tactic."
+
+let bind_change_occurrences occs = function
+  | None -> None
+  | Some c -> Some (Redexpr.out_with_occurrences (occs,c))
+
+let bind_red_expr_occurrences occs nbcl redexp =
+  let has_at_clause = function
+    | Unfold l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l
+    | Pattern l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l
+    | Simpl (Some (occl,_)) -> occl <> all_occurrences_expr
+    | _ -> false in
+  if occs = all_occurrences_expr then
+    if nbcl > 1 && has_at_clause redexp then
+      error_illegal_non_atomic_clause ()
+    else
+      redexp
+  else
+    match redexp with
+    | Unfold (_::_::_) ->
+	error_illegal_clause ()
+    | Unfold [(occl,c)] ->
+	if occl <> all_occurrences_expr then
+	  error_illegal_clause ()
+	else
+	  Unfold [(occs,c)]
+    | Pattern (_::_::_) ->
+	error_illegal_clause ()
+    | Pattern [(occl,c)] ->
+	if occl <> all_occurrences_expr then
+	  error_illegal_clause ()
+	else
+	  Pattern [(occs,c)]
+    | Simpl (Some (occl,c)) ->
+	if occl <> all_occurrences_expr then
+	  error_illegal_clause ()
+	else
+	  Simpl (Some (occs,c))
+    | Red _ | Hnf | Cbv _ | Lazy _
+    | ExtraRedExpr _ | CbvVm | Fold _ | Simpl None ->
+	error_occurrences_not_unsupported ()
+    | Unfold [] | Pattern [] ->
+	assert false
+
 (* The following two tactics apply an arbitrary
-   reduction function either to the conclusion or to a 
+   reduction function either to the conclusion or to a
    certain hypothesis *)
 
-let reduct_in_concl (redfun,sty) gl = 
+let reduct_in_concl (redfun,sty) gl =
   convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl
 
-let reduct_in_hyp redfun ((_,id),where) gl =
+let reduct_in_hyp redfun (id,where) gl =
   convert_hyp_no_check
-    (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl 
+    (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl
 
 let reduct_option redfun = function
-  | Some id -> reduct_in_hyp (fst redfun) id 
-  | None    -> reduct_in_concl redfun 
-
-(* The following tactic determines whether the reduction
-   function has to be applied to the conclusion or
-   to the hypotheses. *) 
-
-let redin_combinator redfun =
-  onClauses (reduct_option redfun)
+  | Some id -> reduct_in_hyp (fst redfun) id
+  | None    -> reduct_in_concl redfun
 
 (* Now we introduce different instances of the previous tacticals *)
 let change_and_check cv_pb t env sigma c =
-  if is_fconv cv_pb env sigma t c then 
+  if is_fconv cv_pb env sigma t c then
     t
-  else 
+  else
     errorlabstrm "convert-check-hyp" (str "Not convertible.")
 
-(* Use cumulutavity only if changing the conclusion not a subterm *)
+(* Use cumulativity only if changing the conclusion not a subterm *)
 let change_on_subterm cv_pb t = function
   | None -> change_and_check cv_pb t
-  | Some occl -> contextually false occl (change_and_check Reduction.CONV t) 
+  | Some occl ->
+      contextually false occl
+        (fun subst -> change_and_check Reduction.CONV (replace_vars subst t))
 
 let change_in_concl occl t =
   reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
@@ -246,56 +310,20 @@ let change_in_hyp occl t id  =
   with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id)
 
 let change_option occl t = function
-    Some id -> change_in_hyp occl t id
+  | Some id -> change_in_hyp occl t id
   | None -> change_in_concl occl t
 
-let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
-  | ArgArg x -> x
-
-let adjust_clause occl cls =
-  (* warn as much as possible on loss of occurrence information *)
-  (match cls, occl with
-      ({onhyps=(Some(_::_::_)|None)}
-      |{onhyps=Some(_::_);concl_occs=((false,_)|(true,_::_))}),
-      Some _ ->
-	error "No occurrences expected when changing several hypotheses."
-    | _ -> ());
-  (* get at clause from cls if only goal or one hyp specified *)
-  let occl,cls = match occl with
-    | None -> None,cls
-    | Some (occs,c) ->
-	if cls.onhyps=Some[] && occs=all_occurrences then
-	  Some (on_snd (List.map out_arg) cls.concl_occs,c),
-	  {cls with concl_occs=all_occurrences_expr}
-	else
-	  match cls.onhyps with
-	  | Some[(occs',id),l] when 
-	      cls.concl_occs=no_occurrences_expr && occs=all_occurrences -> 
-	      Some (on_snd (List.map out_arg) occs',c),
-	      {cls with onhyps=Some[(all_occurrences_expr,id),l]}
-	  | _ ->
-	      occl,cls in
-  (* check if cls has still specified occs *)
-  if cls.onhyps <> None && 
-    List.exists (fun ((occs,_),_) -> occs <> all_occurrences_expr)
-    (Option.get cls.onhyps)
-    || cls.concl_occs <> all_occurrences_expr && 
-       cls.concl_occs <> no_occurrences_expr
-  then
-    Flags.if_verbose Pp.msg_warning
-      (if cls.onhyps=Some[] then
-	str "Trailing \"at\" modifier not taken into account."
-      else
-	str "\"at\" modifier in clause \"in\" not taken into account.");
-  (* Anticipate on onClauses which removes concl if not at all occs *)
-  if cls.concl_occs=no_occurrences_expr then cls
-  else {cls with concl_occs=all_occurrences_expr}
-
-let change occl c cls =
-  onClauses (change_option occl c) (adjust_clause occl cls)
+let change chg c cls gl =
+  let cls = concrete_clause_of cls gl in
+  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
 
 (* Pour usage interne (le niveau User est pris en compte par reduce) *)
+let try_red_in_concl    = reduct_in_concl (try_red_product,DEFAULTcast)
 let red_in_concl        = reduct_in_concl (red_product,DEFAULTcast)
 let red_in_hyp          = reduct_in_hyp   red_product
 let red_option          = reduct_option   (red_product,DEFAULTcast)
@@ -310,8 +338,8 @@ let normalise_in_hyp    = reduct_in_hyp   compute
 let normalise_option    = reduct_option   (compute,DEFAULTcast)
 let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast)
 let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast)
-let unfold_in_hyp   loccname = reduct_in_hyp   (unfoldn loccname) 
-let unfold_option   loccname = reduct_option (unfoldn loccname,DEFAULTcast) 
+let unfold_in_hyp   loccname = reduct_in_hyp   (unfoldn loccname)
+let unfold_option   loccname = reduct_option (unfoldn loccname,DEFAULTcast)
 let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast)
 
 (* A function which reduces accordingly to a reduction expression,
@@ -324,15 +352,28 @@ let checking_fun = function
   | Pattern _ -> with_check
   | _ -> (fun x -> x)
 
+(* The main reduction function *)
+
+let reduction_clause redexp cl =
+  let nbcl = List.length cl in
+  List.map (function
+    | OnHyp (id,occs,where) ->
+	(Some (id,where), bind_red_expr_occurrences occs nbcl redexp)
+    | OnConcl occs ->
+	(None, bind_red_expr_occurrences occs nbcl redexp)) cl
+
 let reduce redexp cl goal =
-  let red = Redexpr.reduction_of_red_expr redexp in
+  let cl = concrete_clause_of cl goal in
+  let redexps = reduction_clause redexp cl in
+  let tac = tclMAP (fun (where,redexp) ->
+    reduct_option (Redexpr.reduction_of_red_expr redexp) where) redexps in
   match redexp with
-      (Fold _|Pattern _) -> with_check (redin_combinator red cl) goal
-    | _ -> redin_combinator red cl goal
+  | Fold _ | Pattern _ -> with_check tac goal
+  | _ -> tac goal
 
 (* Unfolding occurrences of a constant *)
 
-let unfold_constr = function 
+let unfold_constr = function
   | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp]
   | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id]
   | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.")
@@ -357,7 +398,7 @@ let default_id env sigma = function
   | (name,Some b,_) -> id_of_name_using_hdchar env b name
 
 (* Non primitive introduction tactics are treated by central_intro
-   There is possibly renaming, with possibly names to avoid and 
+   There is possibly renaming, with possibly names to avoid and
    possibly a move to do after the introduction *)
 
 type intro_name_flag =
@@ -366,12 +407,13 @@ type intro_name_flag =
   | IntroMustBe of identifier
 
 let find_name loc decl gl = function
-  | IntroAvoid idl -> 
+  | IntroAvoid idl ->
       (* this case must be compatible with [find_intro_names] below. *)
       let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id
   | IntroBasedOn (id,idl) -> fresh_id idl id gl
-  | IntroMustBe id -> 
-      let id' = fresh_id [] id gl in
+  | IntroMustBe id ->
+      (* When name is given, we allow to hide a global name *)
+      let id' = next_ident_away id (pf_ids_of_hyps gl) in
       if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used.");
       id'
 
@@ -380,46 +422,42 @@ let find_name loc decl gl = function
    iteration of [find_name] above. As [default_id] checks the sort of
    the type to build hyp names, we maintain an environment to be able
    to type dependent hyps. *)
-let find_intro_names ctxt gl = 
-  let _, res = List.fold_right 
-    (fun decl acc -> 
+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
       (newenv,(name::idl)))
     ctxt (pf_env gl , []) in
-  List.rev res 
+  List.rev res
 
 let build_intro_tac id = function
   | MoveToEnd true -> introduction id
   | dest -> tclTHEN (introduction id) (move_hyp true id dest)
 
-let rec intro_gen loc name_flag move_flag force_flag gl =
+let rec intro_gen loc name_flag move_flag force_flag dep_flag gl =
   match kind_of_term (pf_concl gl) with
-    | Prod (name,t,_) -> 
+    | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
 	build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl
-    | LetIn (name,b,t,_) ->
+    | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
 	build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag
 	  gl
-    | _ -> 
+    | _ ->
 	if not force_flag then raise (RefinerError IntroNeedsProduct);
 	try
-	  tclTHEN
-	    (reduce (Red true) onConcl)
-	    (intro_gen loc name_flag move_flag force_flag) gl
+	  tclTHEN try_red_in_concl
+	    (intro_gen loc name_flag move_flag force_flag dep_flag) gl
 	with Redelimination ->
 	  user_err_loc(loc,"Intro",str "No product even after head-reduction.")
 
-let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true
-let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false
-let intro_force force_flag = intro_gen dloc (IntroAvoid []) no_move force_flag
-let intro = intro_force false
-let introf = intro_force true
-
-let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false 
-
-let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true
+let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false
+let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false
+let intro = intro_gen dloc (IntroAvoid []) no_move false false
+let introf = intro_gen dloc (IntroAvoid []) no_move true false
+let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false
+let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true false
 
 (**** Multiple introduction tactics ****)
 
@@ -427,10 +465,13 @@ let rec intros_using = function
   | []     -> tclIDTAC
   | str::l -> tclTHEN (intro_using str) (intros_using l)
 
-let intros = tclREPEAT (intro_force false)
+let intros = tclREPEAT intro
 
 let intro_erasing id = tclTHEN (thin [id]) (introduction id)
 
+let intro_forthcoming_gen loc name_flag move_flag dep_flag =
+    tclREPEAT (intro_gen loc name_flag  move_flag false dep_flag)
+
 let rec get_next_hyp_position id = function
   | [] -> error ("No such hypothesis: " ^ string_of_id id)
   | (hyp,_,_) :: right ->
@@ -445,14 +486,14 @@ let thin_for_replacing l gl =
   | Evarutil.OccurHypInSimpleClause None ->
       errorlabstrm ""
       (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.")
-  | Evarutil.OccurHypInSimpleClause (Some id') -> 
+  | Evarutil.OccurHypInSimpleClause (Some id') ->
       errorlabstrm ""
-        (str "Cannot change " ++ pr_id id ++ 
+        (str "Cannot change " ++ pr_id id ++
 	 strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".")
   | Evarutil.EvarTypingBreak ev ->
       errorlabstrm ""
-        (str "Cannot change " ++ pr_id id ++ 
-	 strbrk " without breaking the typing of " ++ 
+        (str "Cannot change " ++ pr_id id ++
+	 strbrk " without breaking the typing of " ++
 	 Printer.pr_existential (pf_env gl) ev ++ str".")
 
 let intro_replacing id gl =
@@ -460,32 +501,32 @@ let intro_replacing id gl =
   tclTHENLIST
     [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl
 
-let intros_replacing ids gl = 
+let intros_replacing ids gl =
   let rec introrec = function
     | [] -> tclIDTAC
     | id::tl ->
 	tclTHEN (tclORELSE (intro_replacing id) (intro_using id))
            (introrec tl)
-  in 
+  in
   introrec ids gl
 
 (* User-level introduction tactics *)
 
 let intro_move idopt hto = match idopt with
-  | None -> intro_gen dloc (IntroAvoid []) hto true
-  | Some id -> intro_gen dloc (IntroMustBe id) hto true
+  | None -> intro_gen dloc (IntroAvoid []) hto true false
+  | Some id -> intro_gen dloc (IntroMustBe id) hto true false
 
 let pf_lookup_hypothesis_as_renamed env ccl = function
   | AnonHyp n -> pf_lookup_index_as_renamed env ccl n
-  | NamedHyp id -> pf_lookup_name_as_renamed env ccl id
+  | NamedHyp id -> pf_lookup_name_as_displayed env ccl id
 
 let pf_lookup_hypothesis_as_renamed_gen red h gl =
   let env = pf_env gl in
   let rec aux ccl =
     match pf_lookup_hypothesis_as_renamed env ccl h with
       | None when red ->
-          aux 
-	    ((fst (Redexpr.reduction_of_red_expr (Red true))) 
+          aux
+	    ((fst (Redexpr.reduction_of_red_expr (Red true)))
 	       env (project gl) ccl)
       | x -> x
   in
@@ -498,7 +539,7 @@ let is_quantified_hypothesis id g =
     | None -> false
 
 let msg_quantified_hypothesis = function
-  | NamedHyp id -> 
+  | NamedHyp id ->
       str "quantified hypothesis named " ++ pr_id id
   | AnonHyp n ->
       int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++
@@ -508,7 +549,7 @@ let depth_of_quantified_hypothesis red h gl =
   match pf_lookup_hypothesis_as_renamed_gen red h gl with
     | Some depth -> depth
     | None ->
-        errorlabstrm "lookup_quantified_hypothesis" 
+        errorlabstrm "lookup_quantified_hypothesis"
           (str "No " ++ msg_quantified_hypothesis h ++
 	  strbrk " in current goal" ++
 	  (if red then strbrk " even after head-reduction" else mt ()) ++
@@ -526,12 +567,12 @@ let intros_until_n_wored = intros_until_n_gen false
 
 let try_intros_until tac = function
   | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id)
-  | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp tac)
+  | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac)
 
 let rec intros_move = function
   | [] -> tclIDTAC
   | (hyp,destopt) :: rest ->
-      tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false)
+      tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false false)
 	(intros_move rest)
 
 let dependent_in_decl a (_,c,t) =
@@ -543,13 +584,13 @@ let dependent_in_decl a (_,c,t) =
    or a term with bindings *)
 
 let onInductionArg tac = function
-  | ElimOnConstr (c,lbindc as cbl) -> 
-      if isVar c & lbindc = NoBindings then 
+  | ElimOnConstr (c,lbindc as cbl) ->
+      if isVar c & lbindc = NoBindings then
 	tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl)
       else
 	tac cbl
   | ElimOnAnonHyp n ->
-      tclTHEN (intros_until_n n) (tclLAST_HYP (fun c -> tac (c,NoBindings)))
+      tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings)))
   | ElimOnIdent (_,id) ->
       (*Identifier apart because id can be quantified in goal and not typable*)
       tclTHEN (tclTRY (intros_until_id id)) (tac (mkVar id,NoBindings))
@@ -560,11 +601,11 @@ let onInductionArg tac = function
 
 let apply_type hdcty argl gl =
   refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl
-    
+
 let apply_term hdc argl gl =
   refine (applist (hdc,argl)) gl
 
-let bring_hyps hyps = 
+let bring_hyps hyps =
   if hyps = [] then Refiner.tclIDTAC
   else
     (fun gl ->
@@ -577,14 +618,14 @@ let resolve_classes gl =
     if evd = Evd.empty then tclIDTAC gl
     else
       let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in
-	(tclTHEN (tclEVARS (Evd.evars_of evd')) tclNORMEVAR) gl
+	(tclTHEN (tclEVARS evd') tclNORMEVAR) gl
 
 (**************************)
 (*     Cut tactics        *)
 (**************************)
 
 let cut c gl =
-  match kind_of_term (hnf_type_of gl c) with
+  match kind_of_term (pf_hnf_type_of gl c) with
     | Sort _ ->
         let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
         let t = mkProd (Anonymous, c, pf_concl gl) in
@@ -596,17 +637,37 @@ let cut c gl =
 
 let cut_intro t = tclTHENFIRST (cut t) intro
 
-(* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le
-   but, ou dans une autre hypothèse *)
-let cut_replacing id t tac = 
-  tclTHENLAST (internal_cut_rev_replace id t)
-    (tac (refine_no_check (mkVar id)))
+(* [assert_replacing id T tac] adds the subgoals of the proof of [T]
+   before the current goal
+
+   id:T0                 id:T0    id:T     
+   =====   ------>   tac(=====) + ==== 
+    G                     T        G
+
+   It fails if the hypothesis to replace appears in the goal or in
+   another hypothesis.
+*) 
+
+let assert_replacing id t tac = tclTHENFIRST (internal_cut_replace id t) tac
 
-let cut_in_parallel l = 
+(* [cut_replacing id T tac] adds the subgoals of the proof of [T]
+   after the current goal
+
+   id:T0             id:T       id:T0
+   =====   ------>   ==== + tac(=====)
+    G                 G          T
+
+   It fails if the hypothesis to replace appears in the goal or in
+   another hypothesis.
+*)
+
+let cut_replacing id t tac = tclTHENLAST (internal_cut_rev_replace id t) tac
+
+let cut_in_parallel l =
   let rec prec = function
-    | [] -> tclIDTAC 
+    | [] -> tclIDTAC
     | h::t -> tclTHENFIRST (cut h) (prec t)
-  in 
+  in
     prec (List.rev l)
 
 let error_uninstantiated_metas t clenv =
@@ -614,86 +675,118 @@ let error_uninstantiated_metas t clenv =
   let id = match na with Name id -> id | _ -> anomaly "unnamed dependent meta"
   in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".")
 
-let clenv_refine_in with_evars ?(with_classes=true) id clenv gl =
+(* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some
+   goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last
+   ones (resp [n] first ones if [sidecond_first] is [true]) being the
+   [Ti] and the first one (resp last one) being [G] whose hypothesis
+   [id] is replaced by P using the proof given by [tac] *)
+
+let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id clenv gl =
   let clenv = clenv_pose_dependent_evars with_evars clenv in
-  let clenv = 
-    if with_classes then 
+  let clenv =
+    if with_classes then
       { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd }
     else clenv
   in
   let new_hyp_typ = clenv_type clenv in
-  if not with_evars & occur_meta new_hyp_typ then 
+  if not with_evars & occur_meta new_hyp_typ then
     error_uninstantiated_metas new_hyp_typ clenv;
-  let new_hyp_prf  = clenv_value clenv in
+  let new_hyp_prf = clenv_value clenv in
   tclTHEN
-    (tclEVARS (evars_of clenv.evd))
-    (cut_replacing id new_hyp_typ
-      (fun x gl -> refine_no_check new_hyp_prf gl)) gl
-
+    (tclEVARS clenv.evd)
+    ((if sidecond_first then assert_replacing else cut_replacing)
+      id new_hyp_typ (refine_no_check new_hyp_prf)) gl
 
 (********************************************)
 (*       Elimination tactics                *)
 (********************************************)
 
 let last_arg c = match kind_of_term c with
-  | App (f,cl) ->  
+  | App (f,cl) ->
       array_last cl
   | _ -> anomaly "last_arg"
 
+let nth_arg i c =
+  if i = -1 then last_arg c else
+  match kind_of_term c with
+  | App (f,cl) -> cl.(i)
+  | _ -> anomaly "nth_arg"
+
+let index_of_ind_arg t =
+  let rec aux i j t = match kind_of_term t with
+  | Prod (_,t,u) ->
+      (* heuristic *)
+      if isInd (fst (decompose_app t)) then aux (Some j) (j+1) u
+      else aux i (j+1) u
+  | _ -> match i with
+      | Some i -> i
+      | None -> error "Could not find inductive argument of elimination scheme."
+  in aux None 0 t
+
 let elim_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state; 
+  modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly = true;
   modulo_delta = empty_transparent_state;
+  resolve_evars = false;
+  use_evars_pattern_unification = true;
 }
 
-let elimination_clause_scheme with_evars allow_K elimclause indclause gl = 
-  let indmv = 
-    (match kind_of_term (last_arg elimclause.templval.rebus) with
+let elimination_clause_scheme with_evars allow_K i elimclause indclause gl =
+  let indmv =
+    (match kind_of_term (nth_arg i elimclause.templval.rebus) with
        | Meta mv -> mv
        | _  -> errorlabstrm "elimination_clause"
-             (str "The type of elimination clause is not well-formed.")) 
+             (str "The type of elimination clause is not well-formed."))
   in
-  let elimclause' = clenv_fchain indmv elimclause indclause in 
+  let elimclause' = clenv_fchain ~flags:elim_flags indmv elimclause indclause in
   res_pf elimclause' ~with_evars:with_evars ~allow_K:allow_K ~flags:elim_flags
     gl
 
-(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and 
- * refine fails *)
-
-let type_clenv_binding wc (c,t) lbind = 
-  clenv_type (make_clenv_binding wc (c,t) lbind)
-
-(* 
- * Elimination tactic with bindings and using an arbitrary 
- * elimination constant called elimc. This constant should end 
+(*
+ * Elimination tactic with bindings and using an arbitrary
+ * elimination constant called elimc. This constant should end
  * with a clause (x:I)(P .. ), where P is a bound variable.
- * The term c is of type t, which is a product ending with a type 
- * matching I, lbindc are the expected terms for c arguments 
+ * The term c is of type t, which is a product ending with a type
+ * matching I, lbindc are the expected terms for c arguments
  *)
 
-let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) gl =
+type eliminator = {
+  elimindex : int option;  (* None = find it automatically *)
+  elimbody : constr with_bindings
+}
+
+let general_elim_clause_gen elimtac indclause elim gl =
+  let (elimc,lbindelimc) = elim.elimbody in
+  let elimt = pf_type_of gl elimc in
+  let i =
+    match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in
+  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in
+  elimtac i elimclause indclause gl
+
+let general_elim_clause elimtac (c,lbindc) elim gl =
   let ct = pf_type_of gl c in
   let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
   let indclause  = make_clenv_binding gl (c,t) lbindc  in
-  let elimt      = pf_type_of gl elimc in
-  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in 
-    elimtac elimclause indclause gl
+    general_elim_clause_gen elimtac indclause elim gl
 
 let general_elim with_evars c e ?(allow_K=true) =
   general_elim_clause (elimination_clause_scheme with_evars allow_K) c e
 
-(* Elimination tactic with bindings but using the default elimination 
+(* Elimination tactic with bindings but using the default elimination
  * constant associated with the type. *)
 
 let find_eliminator c gl =
   let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  lookup_eliminator ind (elimination_sort_of_goal gl)
+  let c = lookup_eliminator ind (elimination_sort_of_goal gl) in
+  {elimindex = None; elimbody = (c,NoBindings)}
 
-let default_elim with_evars (c,_ as cx) gl = 
-  general_elim with_evars cx (find_eliminator c gl,NoBindings) gl
+let default_elim with_evars (c,_ as cx) gl =
+  general_elim with_evars cx (find_eliminator c gl) gl
 
 let elim_in_context with_evars c = function
-  | Some elim -> general_elim with_evars c elim ~allow_K:true
+  | Some elim ->
+      general_elim with_evars c {elimindex = Some (-1); elimbody = elim}
+	~allow_K:true
   | None -> default_elim with_evars c
 
 let elim with_evars (c,lbindc as cx) elim =
@@ -723,21 +816,23 @@ let clenv_fchain_in id elim_flags mv elimclause hypclause =
     (* Set the hypothesis name in the message *)
     raise (PretypeError (env,NoOccurrenceFound (op,Some id)))
 
-let elimination_in_clause_scheme with_evars id elimclause indclause gl =
-  let (hypmv,indmv) = 
-    match clenv_independent elimclause with
-        [k1;k2] -> (k1,k2)
-      | _  -> errorlabstrm "elimination_clause"
+let elimination_in_clause_scheme with_evars id i elimclause indclause gl =
+  let indmv = destMeta (nth_arg i elimclause.templval.rebus) in
+  let hypmv =
+    try match list_remove indmv (clenv_independent elimclause) with
+      | [a] -> a
+      | _ -> failwith ""
+    with Failure _ -> errorlabstrm "elimination_clause"
           (str "The type of elimination clause is not well-formed.") in
-  let elimclause'  = clenv_fchain indmv elimclause indclause in 
+  let elimclause'  = clenv_fchain indmv elimclause indclause in
   let hyp = mkVar id in
   let hyp_typ = pf_type_of gl hyp in
   let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
-  let elimclause'' = 
+  let elimclause'' =
     clenv_fchain_in id elim_flags hypmv elimclause' hypclause in
   let new_hyp_typ  = clenv_type elimclause'' in
   if eq_constr hyp_typ new_hyp_typ then
-    errorlabstrm "general_rewrite_in" 
+    errorlabstrm "general_rewrite_in"
       (str "Nothing to rewrite in " ++ pr_id id ++ str".");
   clenv_refine_in with_evars id elimclause'' gl
 
@@ -748,11 +843,14 @@ let general_elim_in with_evars id =
 
 let general_case_analysis_in_context with_evars (c,lbindc) gl =
   let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let sort     = elimination_sort_of_goal gl in
-  let case = 
-    if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in
-  let elim     = pf_apply case gl mind sort in 
-  general_elim with_evars (c,lbindc) (elim,NoBindings) gl
+  let sort = elimination_sort_of_goal gl in
+  let elim =
+    if occur_term c (pf_concl gl) then
+      pf_apply build_case_analysis_scheme gl mind true sort
+    else
+      pf_apply build_case_analysis_scheme_default gl mind sort in
+  general_elim with_evars (c,lbindc)
+    {elimindex = None; elimbody = (elim,NoBindings)} gl
 
 let general_case_analysis with_evars (c,lbindc as cx) =
   match kind_of_term c with
@@ -764,24 +862,60 @@ let general_case_analysis with_evars (c,lbindc as cx) =
 
 let simplest_case c = general_case_analysis false (c,NoBindings)
 
-(* Apply a tactic below the products of the conclusion of a lemma *) 
-
-let descend_in_conjunctions with_evars tac exit c gl =
+(* Apply a tactic below the products of the conclusion of a lemma *)
+
+type conjunction_status =
+  | DefinedRecord of constant option list
+  | NotADefinedRecordUseScheme of constr
+
+let make_projection params cstr sign elim i n c =
+  let elim = match elim with
+  | NotADefinedRecordUseScheme elim ->
+      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 branch = it_mkLambda_or_LetIn b cstr.cs_args in
+      if noccur_between 1 (n-i-1) t then
+        let t = lift (i+1-n) t in
+	Some (beta_applist (elim,params@[t;branch]),t)
+      else
+	None
+  | DefinedRecord l ->
+      match List.nth l i with
+      | Some proj ->
+	  let t = Typeops.type_of_constant (Global.env()) proj in
+	  Some (beta_applist (mkConst proj,params),prod_applist t (params@[c]))
+      | None -> None
+  in Option.map (fun (abselim,elimt) -> 
+    let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in
+    (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim
+
+let descend_in_conjunctions tac exit c gl =
   try
-    let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-    match match_with_record (snd (decompose_prod t)) with
-    | Some _ ->
-	let n = (mis_constr_nargs mind).(0) in
+    let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let sign,ccl = decompose_prod_assum t in
+    match match_with_tuple ccl with
+    | Some (_,_,isrec) ->
+	let n = (mis_constr_nargs ind).(0) in
 	let sort = elimination_sort_of_goal gl in
-	let elim = pf_apply make_case_gen gl mind sort in
-	tclTHENLAST
-	  (general_elim with_evars (c,NoBindings) (elim,NoBindings))
-	  (tclTHENLIST [
-	    tclDO n intro;
-	    tclLAST_NHYPS n (fun l ->
-	      tclFIRST
-		(List.map (fun id -> tclTHEN (tac (mkVar id)) (thin l)) l))])
-          gl
+	let id = fresh_id [] (id_of_string "H") gl in
+	let IndType (indf,_) = pf_apply find_rectype gl ccl in
+	let params = snd (dest_ind_family indf) in
+	let cstr = (get_constructors (pf_env gl) indf).(0) in
+	let elim =
+	  try DefinedRecord (Recordops.lookup_projections ind)
+	  with Not_found ->
+	    let elim = pf_apply build_case_analysis_scheme gl ind false sort in
+	    NotADefinedRecordUseScheme elim in
+	tclFIRST
+	  (list_tabulate (fun i gl ->
+	    match make_projection params cstr sign elim i n c with
+	    | None -> tclFAIL 0 (mt()) gl
+	    | Some (p,pt) ->
+	    tclTHENS
+	      (internal_cut id pt)
+	      [refine_no_check p;
+	       tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n)
+	  gl
     | None ->
 	raise Exit
   with RefinerError _|UserError _|Exit -> exit ()
@@ -790,93 +924,62 @@ let descend_in_conjunctions with_evars tac exit c gl =
 (*            Resolution tactics                    *)
 (****************************************************)
 
-(* Resolution with missing arguments *)
-
-let check_evars sigma evm gl =
-  let origsigma = gl.sigma in
-  let rest = 
-    Evd.fold (fun ev evi acc -> 
-      if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev) 
-      then Evd.add acc ev evi else acc)
-      evm Evd.empty
-  in 
-  if rest <> Evd.empty then
-    errorlabstrm "apply" (str"Uninstantiated existential variables: " ++ 
-      fnl () ++ pr_evar_map rest)
-
-let general_apply with_delta with_destruct with_evars (c,lbind) gl0 =
-  let flags = 
+let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 =
+  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 (pf_concl gl0) in
-  let evm, c = c in
-  let rec try_main_apply c gl =
+  let rec try_main_apply with_destruct c gl =
     let thm_ty0 = nf_betaiota (project gl) (pf_type_of gl c) in
     let try_apply thm_ty nprod =
       let n = nb_prod thm_ty - nprod in
 	if n<0 then error "Applied theorem has not enough premisses.";
 	let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in
-	let res = Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in
-	  if not with_evars then check_evars (fst res).sigma evm gl0;
-	  res
+	Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl
     in
       try try_apply thm_ty0 concl_nprod
       with PretypeError _|RefinerError _|UserError _|Failure _ as exn ->
 	let rec try_red_apply thm_ty =
-	  try 
+	  try
             (* Try to head-reduce the conclusion of the theorem *)
             let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in
               try try_apply red_thm concl_nprod
               with PretypeError _|RefinerError _|UserError _|Failure _ ->
 		try_red_apply red_thm
-	  with Redelimination -> 
+	  with Redelimination ->
             (* Last chance: if the head is a variable, apply may try
 	       second order unification *)
 	    try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit
 	    with PretypeError _|RefinerError _|UserError _|Failure _|Exit ->
 	      if with_destruct then
-                descend_in_conjunctions with_evars
-                  try_main_apply (fun _ -> raise exn) c gl
+                descend_in_conjunctions
+                  try_main_apply (fun _ -> Stdpp.raise_with_loc loc exn) c gl
 	      else
-		raise exn
-	in try_red_apply thm_ty0 
+		Stdpp.raise_with_loc loc exn
+	in try_red_apply thm_ty0
   in
-    if evm = Evd.empty then try_main_apply c gl0
-    else
-      tclTHEN (tclEVARS (Evd.merge gl0.sigma evm)) (try_main_apply c) gl0
+  try_main_apply with_destruct c gl0
 
-let rec apply_with_ebindings_gen b e = function
-  | [] ->
-      tclIDTAC
-  | [cb] ->
-      general_apply b b e cb
-  | cb::cbl -> 
-      tclTHENLAST (general_apply b b e cb) (apply_with_ebindings_gen b e cbl)
+let rec apply_with_bindings_gen b e = function
+  | [] -> tclIDTAC
+  | [cb] -> general_apply b b e cb
+  | cb::cbl ->
+      tclTHENLAST (general_apply b b e cb) (apply_with_bindings_gen b e cbl)
 
-let apply_with_ebindings cb = apply_with_ebindings_gen false false [cb]
-let eapply_with_ebindings cb = apply_with_ebindings_gen false true [cb]
+let apply_with_bindings cb = apply_with_bindings_gen false false [dloc,cb]
 
-let apply_with_bindings (c,bl) =
-  apply_with_ebindings (inj_open c,inj_ebindings bl)
+let eapply_with_bindings cb = apply_with_bindings_gen false true [dloc,cb]
 
-let eapply_with_bindings (c,bl) =
-  apply_with_ebindings_gen false true [inj_open c,inj_ebindings bl]
+let apply c = apply_with_bindings_gen false false [dloc,(c,NoBindings)]
 
-let apply c =
-  apply_with_ebindings (inj_open c,NoBindings)
+let eapply c = apply_with_bindings_gen false true [dloc,(c,NoBindings)]
 
-let apply_list = function 
+let apply_list = function
   | c::l -> apply_with_bindings (c,ImplicitBindings l)
   | _ -> assert false
 
-(* Resolution with no reduction on the type (used ?) *)
-
-let apply_without_reduce c gl = 
-  let clause = mk_clenv_type_of gl c in 
-  res_pf clause gl
-
 (* [apply_in hyp c] replaces
 
    hyp : forall y1, ti -> t             hyp : rho(u)
@@ -909,29 +1012,23 @@ let apply_in_once_main flags innerclause (d,lbind) gl =
     try progress_with_clause flags innerclause clause
     with err ->
     try aux (clenv_push_prod clause)
-    with NotExtensibleClause -> raise err in 
+    with NotExtensibleClause -> raise err in
   aux (make_clenv_binding gl (d,thm) lbind)
 
-let apply_in_once with_delta with_destruct with_evars id ((sigma,d),lbind) gl0 =
-  let flags = 
+let apply_in_once sidecond_first with_delta with_destruct with_evars id
+  (loc,(d,lbind)) gl0 =
+  let flags =
     if with_delta then default_unify_flags else default_no_delta_unify_flags in
   let t' = pf_get_hyp_typ gl0 id in
   let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in
-  let rec aux c gl =
+  let rec aux with_destruct c gl =
     try
       let clause = apply_in_once_main flags innerclause (c,lbind) gl in
-      let res = clenv_refine_in with_evars id clause gl in
-      if not with_evars then check_evars (fst res).sigma sigma gl0;
-      res
+      clenv_refine_in ~sidecond_first with_evars id clause gl
     with exn when with_destruct ->
-      descend_in_conjunctions true aux (fun _ -> raise exn) c gl
+      descend_in_conjunctions aux (fun _ -> raise exn) c gl
   in
-    if sigma = Evd.empty then aux d gl0
-    else
-      tclTHEN (tclEVARS (Evd.merge gl0.sigma sigma)) (aux d) gl0
-
-
-
+  aux with_destruct d gl0
 
 (* A useful resolution tactic which, if c:A->B, transforms |- C into
    |- B -> C and |- A
@@ -951,7 +1048,7 @@ let apply_in_once with_delta with_destruct with_evars id ((sigma,d),lbind) gl0 =
 *)
 
 let cut_and_apply c gl =
-  let goal_constr = pf_concl gl in 
+  let goal_constr = pf_concl gl in
     match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with
       | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
 	  tclTHENLAST
@@ -966,14 +1063,14 @@ let cut_and_apply c gl =
 let exact_check c gl =
   let concl = (pf_concl gl) in
   let ct = pf_type_of gl c in
-  if pf_conv_x_leq gl ct concl then  
-    refine_no_check c gl 
-  else 
+  if pf_conv_x_leq gl ct concl then
+    refine_no_check c gl
+  else
     error "Not an exact proof."
 
 let exact_no_check = refine_no_check
 
-let vm_cast_no_check c gl = 
+let vm_cast_no_check c gl =
   let concl = pf_concl gl in
   refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl
 
@@ -981,16 +1078,16 @@ let vm_cast_no_check c gl =
 let exact_proof c gl =
   (* on experimente la synthese d'ise dans exact *)
   let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
-  in refine_no_check c gl 
+  in refine_no_check c gl
 
 let (assumption : tactic) = fun gl ->
-  let concl =  pf_concl gl in 
+  let concl =  pf_concl gl in
   let hyps = pf_hyps gl in
   let rec arec only_eq = function
-    | [] -> 
+    | [] ->
         if only_eq then arec false hyps else error "No such assumption."
-    | (id,c,t)::rest -> 
-	if (only_eq & eq_constr t concl) 
+    | (id,c,t)::rest ->
+	if (only_eq & eq_constr t concl)
           or (not only_eq & pf_conv_x_leq gl t concl)
         then refine_no_check (mkVar id) gl
 	else arec only_eq rest
@@ -1002,9 +1099,9 @@ let (assumption : tactic) = fun gl ->
 (*****************************************************************)
 
 (* 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. *)                                                               
+ * 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 ids=[] then tclIDTAC else thin ids
@@ -1020,7 +1117,7 @@ let clear_wildcards ids =
         (error_clear_dependency (pf_env gl) (id_of_string "_") err))
     ids
 
-(*   Takes a list of booleans, and introduces all the variables 
+(*   Takes a list of booleans, and introduces all the variables
  *  quantified in the goal which are associated with a value
  *  true  in the boolean list. *)
 
@@ -1029,46 +1126,42 @@ let rec intros_clearing = function
   | (false::tl) -> tclTHEN intro (intros_clearing tl)
   | (true::tl)  ->
       tclTHENLIST
-        [ intro; onLastHyp (fun id -> clear [id]); intros_clearing tl]
+        [ intro; onLastHypId (fun id -> clear [id]); intros_clearing tl]
 
 (* Modifying/Adding an hypothesis  *)
 
 let specialize mopt (c,lbind) g =
-  let evars, term = 
-    if lbind = NoBindings then None, c 
-    else 
+  let term =
+    if lbind = NoBindings then c
+    else
       let clause = make_clenv_binding g (c,pf_type_of g c) lbind in
       let clause = clenv_unify_meta_types clause in
-      let (thd,tstack) =
-        whd_stack (evars_of clause.evd) (clenv_value clause) in
+      let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in
       let nargs = List.length tstack in
-      let tstack = match mopt with 
-	| Some m -> 
+      let tstack = match mopt with
+	| Some m ->
 	    if m < nargs then list_firstn m tstack else tstack
-	| None -> 
-	    let rec chk = function 
+	| None ->
+	    let rec chk = function
 	      | [] -> []
 	      | t::l -> if occur_meta t then [] else t :: chk l
 	    in chk tstack
-      in 
-      let term = applist(thd,tstack) in 
+      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 ".");
-      Some (evars_of clause.evd), term
+      term
   in
-  tclTHEN 
-    (match evars with Some e -> tclEVARS e | _ -> tclIDTAC)
-    (match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
+  match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
        | Var id when List.mem id (pf_ids_of_hyps g) ->
 	     tclTHENFIRST
 	       (fun g -> internal_cut_replace id (pf_type_of g term) g)
-	       (exact_no_check term)
-       | _ -> tclTHENLAST 
+	       (exact_no_check term) g
+       | _ -> tclTHENLAST
                  (fun g -> cut (pf_type_of g term) g)
-                 (exact_no_check term))
-    g
+                 (exact_no_check term) g
 
 (* Keeping only a few hypotheses *)
 
@@ -1091,7 +1184,7 @@ let keep hyps gl =
 
 let check_number_of_constructors expctdnumopt i nconstr =
   if i=0 then error "The constructors are numbered starting from 1.";
-  begin match expctdnumopt with 
+  begin match expctdnumopt with
     | Some n when n <> nconstr ->
 	error ("Not an inductive goal with "^
 	       string_of_int n^plural n " constructor"^".")
@@ -1100,19 +1193,19 @@ let check_number_of_constructors expctdnumopt i nconstr =
   if i > nconstr then error "Not enough constructors."
 
 let constructor_tac with_evars expctdnumopt i lbind gl =
-  let cl = pf_concl gl in 
-  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in 
+  let cl = pf_concl gl in
+  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in
   let nconstr =
     Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
   check_number_of_constructors expctdnumopt i nconstr;
   let cons = mkConstruct (ith_constructor_of_inductive mind i) in
-  let apply_tac = general_apply true false with_evars (inj_open cons,lbind) in
-  (tclTHENLIST 
+  let apply_tac = general_apply true false with_evars (dloc,(cons,lbind)) in
+  (tclTHENLIST
      [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl
 
-let one_constructor i = constructor_tac false None i
+let one_constructor i lbind = constructor_tac false None i lbind
 
-(* Try to apply the constructor of the inductive definition followed by 
+(* Try to apply the constructor of the inductive definition followed by
    a tactic t given as an argument.
    Should be generalize in Constructor (Fun c : I -> tactic)
  *)
@@ -1125,22 +1218,22 @@ let any_constructor with_evars tacopt gl =
   if nconstr = 0 then error "The type has no constructors.";
   tclFIRST
     (List.map
-      (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) 
+      (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t)
       (interval 1 nconstr)) gl
 
-let left_with_ebindings  with_evars = constructor_tac with_evars (Some 2) 1
-let right_with_ebindings with_evars = constructor_tac with_evars (Some 2) 2
-let split_with_ebindings with_evars = constructor_tac with_evars (Some 1) 1
-
-let left l             = left_with_ebindings false (inj_ebindings l)
-let simplest_left      = left NoBindings
+let left_with_bindings  with_evars = constructor_tac with_evars (Some 2) 1
+let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2
+let split_with_bindings with_evars l =
+  tclMAP (constructor_tac with_evars (Some 1) 1) l
 
-let right l            = right_with_ebindings false (inj_ebindings l)
-let simplest_right     = right NoBindings
+let left           = left_with_bindings false
+let simplest_left  = left NoBindings
 
-let split l            = split_with_ebindings false (inj_ebindings l)
-let simplest_split     = split NoBindings
+let right          = right_with_bindings false
+let simplest_right = right NoBindings
 
+let split          = constructor_tac false (Some 1) 1
+let simplest_split = split NoBindings
 
 (*****************************)
 (* Decomposing introductions *)
@@ -1184,7 +1277,7 @@ let intro_or_and_pattern loc b ll l' tac id gl =
 
 let rewrite_hyp l2r id gl =
   let rew_on l2r =
-    !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) in
+    !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in
   let clear_var_and_eq c =
     tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in
   let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in
@@ -1192,15 +1285,15 @@ let rewrite_hyp l2r id gl =
   match match_with_equality_type t with
   | Some (hdcncl,[_;lhs;rhs]) ->
       if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then
-	tclTHEN (rew_on l2r allClauses) (clear_var_and_eq lhs) gl
+	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq lhs) gl
       else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then
-	tclTHEN (rew_on l2r allClauses) (clear_var_and_eq rhs) gl
+	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq rhs) gl
       else
 	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
   | Some (hdcncl,[c]) ->
       let l2r = not l2r in (* equality of the form eq_true *)
       if isVar c then
-	tclTHEN (rew_on l2r allClauses) (clear_var_and_eq c) gl
+	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq c) gl
       else
 	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
   | _ ->
@@ -1209,9 +1302,9 @@ let rewrite_hyp l2r id gl =
 let rec explicit_intro_names = function
 | (_, IntroIdentifier id) :: l ->
     id :: explicit_intro_names l
-| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)) :: l ->
-    explicit_intro_names l
-| (_, IntroOrAndPattern ll) :: l' -> 
+| (_, (IntroWildcard | IntroAnonymous | IntroFresh _
+      | IntroRewrite _ | IntroForthcoming _)) :: l -> explicit_intro_names l
+| (_, IntroOrAndPattern ll) :: l' ->
     List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
 | [] ->
     []
@@ -1222,37 +1315,44 @@ let rec explicit_intro_names = function
      the tactic, for the hyps to clear *)
 let rec intros_patterns b avoid thin destopt = function
   | (loc, IntroWildcard) :: l ->
-      tclTHEN 
-        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true)
-        (onLastHyp (fun id ->
+      tclTHEN
+        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l))
+	  no_move true false)
+        (onLastHypId (fun id ->
 	  tclORELSE
 	    (tclTHEN (clear [id]) (intros_patterns b avoid thin destopt l))
 	    (intros_patterns b avoid ((loc,id)::thin) destopt l)))
   | (loc, IntroIdentifier id) :: l ->
       tclTHEN
-        (intro_gen loc (IntroMustBe id) destopt true)
+        (intro_gen loc (IntroMustBe id) destopt true false)
         (intros_patterns b avoid thin destopt l)
   | (loc, IntroAnonymous) :: l ->
       tclTHEN
         (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l))
-	  destopt true)
+	  destopt true false)
         (intros_patterns b avoid thin destopt l)
   | (loc, IntroFresh id) :: l ->
       tclTHEN
         (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
-	  destopt true)
+	  destopt true false)
+        (intros_patterns b avoid thin destopt l)
+  | (loc, IntroForthcoming onlydeps) :: l ->
+      tclTHEN
+        (intro_forthcoming_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+	  destopt onlydeps)
         (intros_patterns b avoid thin destopt l)
   | (loc, IntroOrAndPattern ll) :: l' ->
       tclTHEN
         introf
-        (onLastHyp
+        (onLastHypId
 	  (intro_or_and_pattern loc b ll l'
 	    (intros_patterns b avoid thin destopt)))
   | (loc, IntroRewrite l2r) :: l ->
-      tclTHEN 
-        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true)
-        (onLastHyp (fun id ->
-	  tclTHEN
+      tclTHEN
+        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l))
+	  no_move true false)
+        (onLastHypId (fun id ->
+	  tclTHENLAST (* Skip the side conditions of the rewriting step *)
 	    (rewrite_hyp l2r id)
 	    (intros_patterns b avoid thin destopt l)))
   | [] -> clear_wildcards thin
@@ -1261,7 +1361,7 @@ let intros_pattern = intros_patterns false [] []
 
 let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat]
 
-let intro_patterns = function 
+let intro_patterns = function
   | [] -> tclREPEAT intro
   | l  -> intros_pattern no_move l
 
@@ -1278,13 +1378,15 @@ let prepare_intros s ipat gl = match ipat with
   | IntroAnonymous -> make_id s gl, tclIDTAC
   | IntroFresh id -> fresh_id [] id gl, tclIDTAC
   | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id]
-  | IntroRewrite l2r -> 
+  | IntroRewrite l2r ->
       let id = make_id s gl in
-      id, !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses
+      id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
   | IntroOrAndPattern ll -> make_id s gl,
-      onLastHyp
-	(intro_or_and_pattern loc true ll [] 
+      onLastHypId
+	(intro_or_and_pattern loc true ll []
 	  (intros_patterns true [] [] no_move))
+  | IntroForthcoming _ -> user_err_loc
+      (loc,"",str "Introduction pattern for one hypothesis expected")
 
 let ipat_of_name = function
   | Anonymous -> None
@@ -1292,12 +1394,12 @@ let ipat_of_name = function
 
 let allow_replace c gl = function (* A rather arbitrary condition... *)
   | Some (_, IntroIdentifier id) ->
-      fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id
+      fst (decompose_app ((strip_lam_assum c))) = mkVar id
   | _ ->
       false
 
 let assert_as first ipat c gl =
-  match kind_of_term (hnf_type_of gl c) with
+  match kind_of_term (pf_hnf_type_of gl c) with
   | Sort s ->
       let id,tac = prepare_intros s ipat gl in
       let repl = allow_replace c gl ipat in
@@ -1311,23 +1413,44 @@ let assert_tac na = assert_as true (ipat_of_name na)
 (* apply in as *)
 
 let as_tac id ipat = match ipat with
-  | Some (loc,IntroRewrite l2r) -> 
-      !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses
+  | Some (loc,IntroRewrite l2r) ->
+      !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
   | Some (loc,IntroOrAndPattern ll) ->
       intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)
         id
   | Some (loc,
-      (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard)) ->
+      (IntroIdentifier _ | IntroAnonymous | IntroFresh _ |
+       IntroWildcard | IntroForthcoming _)) ->
       user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected")
   | None -> tclIDTAC
 
-let general_apply_in with_delta with_destruct with_evars id lemmas ipat gl =
-  tclTHEN
-    (tclMAP (apply_in_once with_delta with_destruct with_evars id) lemmas)
-    (as_tac id ipat)
-    gl
+let tclMAPLAST tacfun l =
+  List.fold_right (fun x -> tclTHENLAST (tacfun x)) l tclIDTAC
+
+let tclMAPFIRST tacfun l =
+  List.fold_right (fun x -> tclTHENFIRST (tacfun x)) l tclIDTAC
+
+let general_apply_in sidecond_first with_delta with_destruct with_evars 
+    id lemmas ipat =
+  if sidecond_first then
+    (* Skip the side conditions of the applied lemma *)
+    tclTHENLAST
+      (tclMAPLAST
+	(apply_in_once sidecond_first with_delta with_destruct with_evars id) 
+	lemmas)
+      (as_tac id ipat)
+  else 
+    tclTHENFIRST
+      (tclMAPFIRST
+	(apply_in_once sidecond_first with_delta with_destruct with_evars id) 
+	lemmas)
+      (as_tac id ipat)
 
-let apply_in simple with_evars = general_apply_in simple simple with_evars
+let apply_in simple with_evars id lemmas ipat =
+  general_apply_in false simple simple with_evars id lemmas ipat
+
+let simple_apply_in id c =
+  general_apply_in false false false false id [dloc,(c,NoBindings)] None
 
 (**************************)
 (*   Generalize tactics   *)
@@ -1336,38 +1459,38 @@ let apply_in simple with_evars = general_apply_in simple simple with_evars
 let generalized_name c t ids cl = function
   | Name id as na ->
       if List.mem id ids then
-	errorlabstrm "" (pr_id id ++ str " is already used"); 
+	errorlabstrm "" (pr_id id ++ str " is already used");
       na
-  | Anonymous -> 
+  | Anonymous ->
       match kind_of_term c with
       | Var id ->
 	 (* Keep the name even if not occurring: may be used by intros later *)
 	  Name id
       | _ ->
 	  if noccurn 1 cl then Anonymous else
-	    (* On ne s'etait pas casse la tete : on avait pris pour nom de 
+	    (* On ne s'etait pas casse la tete : on avait pris pour nom de
                variable la premiere lettre du type, meme si "c" avait ete une
                constante dont on aurait pu prendre directement le nom *)
 	    named_hd (Global.env()) t Anonymous
 
-let generalize_goal gl i ((occs,c),na) cl =
+let generalize_goal gl i ((occs,c,b),na) cl =
   let t = pf_type_of gl c 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 c dummy_prod) in
   let cl' = subst_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
   let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in
-  mkProd (na,t,cl')
+    mkProd_or_LetIn (na,b,t) cl'
 
-let generalize_dep c gl =
+let generalize_dep ?(with_let=false) c gl =
   let env = pf_env gl in
   let sign = pf_hyps gl in
   let init_ids = ids_of_named_context (Global.named_context()) in
   let rec seek d toquant =
     if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant
-      or dependent_in_decl c d then 
+      or dependent_in_decl c d then
       d::toquant
-    else 
+    else
       toquant in
   let to_quantify = Sign.fold_named_context seek sign ~init:[] in
   let to_quantify_rev = List.rev to_quantify in
@@ -1380,39 +1503,58 @@ let generalize_dep c gl =
       | _ -> tothin
   in
   let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
-  let cl'' = generalize_goal gl 0 ((all_occurrences,c),Anonymous) cl' in
+  let body = 
+    if with_let then
+      match kind_of_term c with 
+      | Var id -> pi2 (pf_get_hyp gl id)
+      | _ -> None
+    else None
+  in
+  let cl'' = generalize_goal gl 0 ((all_occurrences,c,body),Anonymous) cl' in
   let args = Array.to_list (instance_from_named_context to_quantify_rev) in
   tclTHEN
-    (apply_type cl'' (c::args))
+    (apply_type cl'' (if body = None then c::args else args))
     (thin (List.rev tothin'))
     gl
 
-let generalize_gen lconstr gl =
+let generalize_gen_let lconstr gl =
   let newcl =
     list_fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in
-  apply_type newcl (List.map (fun ((_,c),_) -> c) lconstr) gl
+  apply_type newcl (list_map_filter (fun ((_,c,b),_) -> 
+    if b = None then Some c else None) lconstr) gl
 
+let generalize_gen lconstr =
+  generalize_gen_let (List.map (fun ((occs,c),na) ->
+    (occs,c,None),na) lconstr)
+    
 let generalize l =
-  generalize_gen (List.map (fun c -> ((all_occurrences,c),Anonymous)) l)
+  generalize_gen_let (List.map (fun c -> ((all_occurrences,c,None),Anonymous)) l)
+
+let pf_get_hyp_val gl id =
+  let (_, b, _) = pf_get_hyp gl id in
+    b
 
 let revert hyps gl = 
-  tclTHEN (generalize (List.map mkVar hyps)) (clear hyps) gl
+  let lconstr = List.map (fun id -> 
+    ((all_occurrences, mkVar id, pf_get_hyp_val gl id), Anonymous)) 
+    hyps 
+  in tclTHEN (generalize_gen_let lconstr) (clear hyps) gl
 
 (* Faudra-t-il une version avec plusieurs args de generalize_dep ?
-Cela peut-être troublant de faire "Generalize Dependent H n" dans
-"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la
-généralisation dépendante par n.
+Cela peut-être troublant de faire "Generalize Dependent H n" dans
+"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la
+généralisation dépendante par n.
 
 let quantify lconstr =
- List.fold_right 
+ List.fold_right
    (fun com tac -> tclTHEN tac (tactic_com generalize_dep c))
    lconstr
    tclIDTAC
 *)
 
-(* A dependent cut rule à la sequent calculus
+(* A dependent cut rule à la sequent calculus
    ------------------------------------------
-   Sera simplifiable le jour où il y aura un let in primitif dans constr
+   Sera simplifiable le jour où il y aura un let in primitif dans constr
 
    [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms
    [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
@@ -1434,6 +1576,10 @@ let quantify lconstr =
    the left of each x1, ...).
 *)
 
+let out_arg = function
+  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgArg x -> x
+
 let occurrences_of_hyp id cls =
   let rec hyp_occ = function
       [] -> None
@@ -1466,13 +1612,13 @@ let letin_abstract id c occs gl =
 		if not (in_every_hyp occs)
 		then raise (RefinerError (DoesNotOccurIn (c,hyp)))
 		else raise Not_found
-              else 
+              else
 		(subst1_named_decl (mkVar id) newdecl, true)
-	with Not_found -> 
+	with Not_found ->
 	  (d,List.exists
 	      (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt)
     in d'::ctxt
-  in 
+  in
   let ctxt' = fold_named_context compute_dependency env ~init:[] in
   let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) =
     if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp)
@@ -1490,7 +1636,7 @@ let letin_tac with_eq name c occs gl =
     if name = Anonymous then fresh_id [] x gl else
       if not (mem_named_context x (pf_hyps gl)) then x else
 	error ("The variable "^(string_of_id x)^" is already declared") in
-  let (depdecls,marks,ccl)= letin_abstract id c occs gl in 
+  let (depdecls,marks,ccl)= letin_abstract id c occs gl in
   let t = pf_type_of gl c in
   let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in
   let args = Array.to_list (instance_from_named_context depdecls) in
@@ -1515,11 +1661,11 @@ let letin_abstract id c (occs,check_occs) gl =
       | Some occ ->
           let newdecl = subst_term_occ_decl occ c d in
           if occ = (all_occurrences,InHyp) & d = newdecl then
-	    if check_occs & not (in_every_hyp occs) 
+	    if check_occs & not (in_every_hyp occs)
 	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
 	    else depdecls
-          else 
-	    (subst1_named_decl (mkVar id) newdecl)::depdecls in 
+          else
+	    (subst1_named_decl (mkVar id) newdecl)::depdecls in
   let depdecls = fold_named_context compute_dependency env ~init:[] in
   let ccl = match occurrences_of_goal occs with
     | None -> pf_concl gl
@@ -1534,7 +1680,7 @@ let letin_tac_gen with_eq name c ty occs gl =
     if name = Anonymous then fresh_id [] x gl else
       if not (mem_named_context x (pf_hyps gl)) then x else
 	error ("The variable "^(string_of_id x)^" is already declared.") in
-  let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in 
+  let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in
   let t = match ty with Some t -> t | None -> pf_type_of gl c in
   let newcl,eq_tac = match with_eq with
     | Some (lr,(loc,ido)) ->
@@ -1549,13 +1695,13 @@ let letin_tac_gen with_eq name c ty occs gl =
       let refl = applist (eqdata.refl, [t;mkVar id]) in
       mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)),
       tclTHEN
-	(intro_gen loc (IntroMustBe heq) lastlhyp true)
+	(intro_gen loc (IntroMustBe heq) lastlhyp true false)
 	(thin_body [heq;id])
     | None ->
 	mkNamedLetIn id c t ccl, tclIDTAC in
   tclTHENLIST
     [ convert_concl_no_check newcl DEFAULTcast;
-      intro_gen dloc (IntroMustBe id) lastlhyp true;
+      intro_gen dloc (IntroMustBe id) lastlhyp true false;
       eq_tac;
       tclMAP convert_hyp_no_check depdecls ] gl
 
@@ -1565,10 +1711,10 @@ let letin_tac with_eq name c ty occs =
 (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
 let forward usetac ipat c gl =
   match usetac with
-  | None -> 
+  | None ->
       let t = pf_type_of gl c in
       tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl
-  | Some tac -> 
+  | Some tac ->
       tclTHENFIRST (assert_as true ipat c) tac gl
 
 let pose_proof na c = forward None (ipat_of_name na) c
@@ -1588,7 +1734,7 @@ let unfold_body x gl =
       | _ -> 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 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
@@ -1609,7 +1755,7 @@ let unfold_all x gl =
 
 (*
  * A "natural" induction tactic
- * 
+ *
   - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal
   - [hyp0] is the induction hypothesis
   - we extract from [args] the variables which are not rigid parameters
@@ -1641,31 +1787,36 @@ let unfold_all x gl =
 
 let check_unused_names names =
   if names <> [] & Flags.is_verbose () then
-    msg_warning 
+    msg_warning
       (str"Unused introduction " ++ str (plural (List.length names) "pattern")
        ++ str": " ++ prlist_with_sep spc pr_intro_pattern names)
 
 let rec first_name_buggy avoid gl (loc,pat) = match pat with
   | IntroOrAndPattern [] -> no_move
-  | IntroOrAndPattern ([]::l) -> 
+  | IntroOrAndPattern ([]::l) ->
       first_name_buggy avoid gl (loc,IntroOrAndPattern l)
   | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p
   | IntroWildcard -> no_move
   | IntroRewrite _ -> no_move
   | IntroIdentifier id -> MoveAfter id
-  | IntroAnonymous | IntroFresh _ -> (* buggy *) no_move
+  | IntroAnonymous | IntroFresh _ | IntroForthcoming _ -> (* buggy *) no_move
 
-let consume_pattern avoid id gl = function
+let rec consume_pattern avoid id isdep gl = function
   | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
   | (loc,IntroAnonymous)::names ->
       let avoid = avoid@explicit_intro_names names in
       ((loc,IntroIdentifier (fresh_id avoid id gl)), names)
+  | (loc,IntroForthcoming true)::names when not isdep ->
+      consume_pattern avoid id isdep gl names
+  | (loc,IntroForthcoming _)::names as fullpat ->
+      let avoid = avoid@explicit_intro_names names in
+      ((loc,IntroIdentifier (fresh_id avoid id gl)), fullpat)
   | (loc,IntroFresh id')::names ->
       let avoid = avoid@explicit_intro_names names in
       ((loc,IntroIdentifier (fresh_id avoid id' gl)), names)
   | pat::names -> (pat,names)
 
-let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) =
+let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp =
   let newlstatus = (* if some IH has taken place at the top of hyps *)
     List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus
   in
@@ -1675,20 +1826,29 @@ let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) =
 
 let update destopt tophyp = if destopt = no_move then tophyp else destopt
 
+let safe_dest_intros_patterns avoid dest pat gl =
+  try intros_patterns true avoid [] dest pat gl
+  with UserError ("move_hyp",_) ->
+    (* May happen if the lemma has dependent arguments that has resolved
+       only after cook_sign is called, e.g. as in 
+       "dec:forall x, {x=0}+{x<>0};  a:A  |- if dec a then True else False"
+       for argument a of dec which will be found only lately *)
+    intros_patterns true avoid [] no_move pat gl
+
 type elim_arg_kind = RecArg | IndArg | OtherArg
 
-let induct_discharge statuslists destopt avoid' (avoid,ra) names gl =
+let induct_discharge destopt avoid' tac (avoid,ra) names gl =
   let avoid = avoid @ avoid' in
   let rec peel_tac ra names tophyp gl =
     match ra with
-    | (RecArg,recvarname) ::
-        (IndArg,hyprecname) :: ra' ->
+    | (RecArg,deprec,recvarname) ::
+        (IndArg,depind,hyprecname) :: ra' ->
         let recpat,names = match names with
           | [loc,IntroIdentifier id as pat] ->
               let id' = next_ident_away (add_prefix "IH" id) avoid in
 	      (pat, [dloc, IntroIdentifier id'])
-          | _ -> consume_pattern avoid recvarname gl names in
-        let hyprec,names = consume_pattern avoid hyprecname gl names in
+          | _ -> consume_pattern avoid recvarname deprec gl names in
+        let hyprec,names = consume_pattern avoid hyprecname depind gl names in
         (* IH stays at top: we need to update tophyp *)
         (* This is buggy for intro-or-patterns with different first hypnames *)
         (* Would need to pass peel_tac as a continuation of intros_patterns *)
@@ -1697,43 +1857,43 @@ let induct_discharge statuslists destopt avoid' (avoid,ra) names gl =
 	  if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp
 	in
         tclTHENLIST
-	  [ intros_patterns true avoid [] (update destopt tophyp) [recpat];
-	    intros_patterns true avoid [] no_move [hyprec];
+	  [ safe_dest_intros_patterns avoid (update destopt tophyp) [recpat];
+	    safe_dest_intros_patterns avoid no_move [hyprec];
 	    peel_tac ra' names newtophyp] gl
-    | (IndArg,hyprecname) :: ra' ->
+    | (IndArg,dep,hyprecname) :: ra' ->
 	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
-        let pat,names = consume_pattern avoid hyprecname gl names in
-	tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat])
+        let pat,names = consume_pattern avoid hyprecname dep gl names in
+	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
           (peel_tac ra' names tophyp) gl
-    | (RecArg,recvarname) :: ra' ->
-        let pat,names = consume_pattern avoid recvarname gl names in
-	tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) 
+    | (RecArg,dep,recvarname) :: ra' ->
+        let pat,names = consume_pattern avoid recvarname dep gl names in
+	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
           (peel_tac ra' names tophyp) gl
-    | (OtherArg,_) :: ra' ->
+    | (OtherArg,_,_) :: ra' ->
         let pat,names = match names with
           | [] -> (dloc, IntroAnonymous), []
           | pat::names -> pat,names in
-	tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat])
+	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
           (peel_tac ra' names tophyp) gl
     | [] ->
         check_unused_names names;
-        re_intro_dependent_hypotheses tophyp statuslists gl
+        tac tophyp gl
   in
   peel_tac ra names no_move gl
 
-(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
-     s'embêter à regarder si un letin_tac ne fait pas des
+(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
+     s'embêter à regarder si un letin_tac ne fait pas des
      substitutions aussi sur l'argument voisin *)
 
-(* Marche pas... faut prendre en compte l'occurrence précise... *)
+(* Marche pas... faut prendre en compte l'occurrence précise... *)
 
-let atomize_param_of_ind (indref,nparams) hyp0 gl =
+let atomize_param_of_ind (indref,nparams,_) hyp0 gl =
   let tmptyp0 = pf_get_hyp_typ gl hyp0 in
   let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
   let prods, indtyp = decompose_prod typ0 in
   let argl = snd (decompose_app indtyp) in
   let params = list_firstn nparams argl in
-  (* le gl est important pour ne pas préévaluer *)
+  (* le gl est important pour ne pas préévaluer *)
   let rec atomize_one i avoid gl =
     if i<>nparams then
       let tmptyp0 = pf_get_hyp_typ gl hyp0 in
@@ -1748,16 +1908,16 @@ let atomize_param_of_ind (indref,nparams) hyp0 gl =
 	| Var id ->
 	    let x = fresh_id [] id gl in
 	    tclTHEN
-	      (letin_tac None (Name x) (mkVar id) None allClauses)
+	      (letin_tac None (Name x) (mkVar id) None allHypsAndConcl)
 	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
 	| _ ->
 	    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
 		       Anonymous in
 	    let x = fresh_id [] id gl in
 	    tclTHEN
-	      (letin_tac None (Name x) c None allClauses)
+	      (letin_tac None (Name x) c None allHypsAndConcl)
 	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
-    else 
+    else
       tclIDTAC gl
   in
   atomize_one (List.length argl) params gl
@@ -1775,7 +1935,7 @@ let find_atomic_param_of_ind nparams indtyp =
       | _ -> ()
   done;
   Idset.elements !indvars;
-  
+
 
 (* [cook_sign] builds the lists [indhyps] of hyps that must be
    erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the
@@ -1794,7 +1954,7 @@ let find_atomic_param_of_ind nparams indtyp =
    To summarize, the situation looks like this
 
    Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat
-                Left                                                    Right 
+                Left                                                    Right
 
    Induction hypothesis is H4 ([hyp0])
    Variable parameters of (le O n) is the singleton list with "n" ([indvars])
@@ -1828,7 +1988,7 @@ let find_atomic_param_of_ind nparams indtyp =
    would have posed no problem. But for uniformity, we decided to use
    the right hyp for all hyps on the right of H4.
 
-   Others solutions are welcome 
+   Others solutions are welcome
 
    PC 9 fev 06: Adapted to accept multi argument principle with no
    main arg hyp. hyp0 is now optional, meaning that it is possible
@@ -1858,15 +2018,15 @@ let cook_sign hyp0_opt indvars env =
   let before = ref true in
   let seek_deps env (hyp,_,_ as decl) rhyp =
     if hyp = hyp0 then begin
-      before:=false; 
+      before:=false;
       (* If there was no main induction hypotheses, then hyp is one of
          indvars too, so add it to indhyps. *)
-      (if hyp0_opt=None then indhyps := hyp::!indhyps); 
+      (if hyp0_opt=None then indhyps := hyp::!indhyps);
       MoveToEnd false (* fake value *)
     end else if List.mem hyp indvars then begin
       (* warning: hyp can still occur after induction *)
       (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *)
-      indhyps := hyp::!indhyps; 
+      indhyps := hyp::!indhyps;
       rhyp
     end else
       if inhyps <> [] && List.mem hyp inhyps || inhyps = [] &&
@@ -1874,9 +2034,9 @@ let cook_sign hyp0_opt indvars env =
          List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps)
       then begin
 	decldeps := decl::!decldeps;
-	if !before then 
+	if !before then
 	  rstatus := (hyp,rhyp)::!rstatus
-	else 
+	else
 	  ldeps := hyp::!ldeps; (* status computed in 2nd phase *)
 	MoveBefore hyp end
       else
@@ -1892,8 +2052,8 @@ let cook_sign hyp0_opt indvars env =
     end else
       if List.mem hyp !indhyps then lhyp else MoveAfter hyp
   in
-  try 
-    let _ = 
+  try
+    let _ =
       fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in
     raise (Shunt (MoveToEnd true)) (* ?? FIXME *)
   with Shunt lhyp0 ->
@@ -1904,7 +2064,7 @@ let cook_sign hyp0_opt indvars env =
 
 (*
    The general form of an induction principle is the following:
-   
+
    forall prm1 prm2 ... prmp,                          (induction parameters)
    forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates)
    branch1, branch2, ... , branchr,                    (branches of the principle)
@@ -1913,7 +2073,7 @@ let cook_sign hyp0_opt indvars env =
    -> (Qi x1...xni HI        (f prm1...prmp x1...xni)).(conclusion)
                    ^^        ^^^^^^^^^^^^^^^^^^^^^^^^
                optional        optional argument added if
-               even if HI    principle generated by functional 
+               even if HI    principle generated by functional
              present above   induction, only if HI does not exist
              [indarg]                  [farg]
 
@@ -1926,31 +2086,33 @@ let cook_sign hyp0_opt indvars env =
 
 (* [rel_contexts] and [rel_declaration] actually contain triples, and
    lists are actually in reverse order to fit [compose_prod]. *)
-type elim_scheme = { 
-  elimc: constr with_ebindings option;
+type elim_scheme = {
+  elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
+  index: int;              (* index of the elimination type in the scheme *)
   params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
   nparams: int;            (* number of parameters *)
   predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
   npredicates: int;        (* Number of predicates *)
   branches: rel_context;   (* branchr,...,branch1 *)
-  nbranches: int;          (* Number of branches *) 
+  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) 
+  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...) 
+  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 = 
-  { 
+let empty_scheme =
+  {
     elimc = None;
     elimt = mkProp;
     indref = None;
+    index = -1;
     params = [];
     nparams = 0;
     predicates = [];
@@ -1965,19 +2127,6 @@ let empty_scheme =
     farg_in_concl = false;
   }
 
-
-(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the
-   hypothesis on which the induction is made *)
-let induction_tac with_evars (varname,lbind) typ scheme gl =
-  let elimc,lbindelimc = 
-    match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in
-  let elimt = scheme.elimt in
-  let indclause = make_clenv_binding gl (mkVar varname,typ) lbind  in
-  let elimclause =
-    make_clenv_binding gl 
-      (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
-  elimination_clause_scheme with_evars true elimclause indclause gl
-
 let make_base n id =
   if n=0 or n=1 then id
   else
@@ -1988,15 +2137,15 @@ let make_base n id =
 (* Builds two different names from an optional inductive type and a
    number, also deals with a list of names to avoid. If the inductive
    type is None, then hyprecname is IHi where i is a number. *)
-let make_up_names n ind_opt cname = 
+let make_up_names n ind_opt cname =
   let is_hyp = atompart_of_id cname = "H" in
   let base = string_of_id (make_base n cname) in
   let ind_prefix = "IH" in
-  let base_ind = 
-    if is_hyp then 
+  let base_ind =
+    if is_hyp then
       match ind_opt with
 	| None -> id_of_string ind_prefix
-	| Some ind_id -> add_prefix ind_prefix (Nametab.id_of_global ind_id)
+	| Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id)
     else add_prefix ind_prefix cname in
   let hyprecname = make_base n base_ind in
   let avoid =
@@ -2014,53 +2163,44 @@ let make_up_names n ind_opt cname =
 
 let is_indhyp p n t =
   let l, c = decompose_prod t in
-  let c,_ = decompose_app c in 
+  let c,_ = decompose_app c in
   let p = p + List.length l in
   match kind_of_term c with
     | Rel k when p < k & k <= p + n -> true
     | _ -> false
 
-let chop_context n l = 
+let chop_context n l =
   let rec chop_aux acc = function
     | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t)
     | 0, l2 -> (List.rev acc, l2)
     | n, (h::t) -> chop_aux (h::acc) (n-1, t)
     | _, [] -> anomaly "chop_context"
-  in 
+  in
   chop_aux [] (n,l)
 
 let error_ind_scheme s =
   let s = if s <> "" then s^" " else s in
   error ("Cannot recognize "^s^"an induction scheme.")
 
+let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq
+let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
+
+let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
+let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
+
 let mkEq t x y = 
-  mkApp (build_coq_eq (), [| t; x; y |])
+  mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |])
     
 let mkRefl t x = 
-  mkApp ((build_coq_eq_data ()).refl, [| t; x |])
+  mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |])
 
 let mkHEq t x u y =
-  mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq",
-	[| t; x; u; y |])
+  mkApp (Lazy.force coq_heq,
+	[| refresh_universes_strict t; x; refresh_universes_strict u; y |])
     
 let mkHRefl t x =
-  mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl",
-	[| t; x |])
-
-(* let id = lazy (coq_constant "mkHEq" ["Init";"Datatypes"] "id") *)
-
-(* let mkHEq t x u y =  *)
-(*   let ty = new_Type () in *)
-(*   mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep", *)
-(* 	[| ty; mkApp (Lazy.force id, [|ty|]); t; x; u; y |]) *)
-    
-(* let mkHRefl t x =  *)
-(*   let ty = new_Type () in *)
-(*   mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep_intro", *)
-(* 	[| ty; mkApp (Lazy.force id, [|ty|]); t; x |]) *)
-
-let mkCoe a x p px y eq = 
-  mkApp (Option.get (build_coq_eq_data ()).rect, [| a; x; p; px; y; eq |])
+  mkApp (Lazy.force coq_heq_refl,
+	[| refresh_universes_strict t; x |])
 
 let lift_togethern n l =
   let l', _ =
@@ -2069,161 +2209,279 @@ let lift_togethern n l =
 	(lift n x :: acc, succ n))
       l ([], n)
   in l'
-      
+
 let lift_together l = lift_togethern 0 l
 
 let lift_list l = List.map (lift 1) l
 
-let ids_of_constr vars c = 
-  let rec aux vars c = 
+let ids_of_constr ?(all=false) vars c =
+  let rec aux vars c =
     match kind_of_term c with
-    | Var id -> if List.mem id vars then vars else id :: vars
+    | Var id -> Idset.add id vars
     | App (f, args) -> 
 	(match kind_of_term f with
-	| Construct (ind,_) 
+	| Construct (ind,_)
 	| Ind ind ->
             let (mib,mip) = Global.lookup_inductive ind in
-	      array_fold_left_from mib.Declarations.mind_nparams 
+	      array_fold_left_from
+		(if all then 0 else mib.Declarations.mind_nparams)
 		aux vars args
 	| _ -> fold_constr aux vars c)
     | _ -> fold_constr aux vars c
   in aux vars c
+    
+let decompose_indapp f args =
+  match kind_of_term f with
+  | Construct (ind,_) 
+  | Ind ind ->
+      let (mib,mip) = Global.lookup_inductive ind in
+      let first = mib.Declarations.mind_nparams_rec in
+      let pars, args = array_chop first args in
+	mkApp (f, pars), args
+  | _ -> f, args
+
+let mk_term_eq env sigma ty t ty' t' =
+  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 c eqs args refls = 
+let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
   let meta = Evarutil.new_meta() in
-  let term, typ = mkVar id, pf_get_hyp_typ gl id in
   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 = 
-    if dep then 
-      mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 concl)
-    else concl
+  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
+	mkProd (Anonymous, eq, lift 1 concl), [| refl |]
+    else concl, [||]
   in
     (* Abstract by equalitites *)
   let eqs = lift_togethern 1 eqs in (* lift together and past genarg *)
   let abseqs = it_mkProd_or_LetIn ~init:(lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in
     (* Abstract by the "generalized" hypothesis. *)
-  let genarg = mkProd (Name id, c, abseqs) in
+  let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in
     (* Abstract by the extension of the context *)
   let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in
     (* The goal will become this product. *)
-  let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in      
+  let genc = mkCast (mkMeta meta, DEFAULTcast, 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 instanciated hyp. *)
-  let instc = mkApp (instc, [| mkVar id |]) in
+  let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in
     (* Apply the reflexivity proofs on the indices. *)
   let appeqs = mkApp (instc, Array.of_list refls) in
     (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *)
-  let newc = if dep then mkApp (appeqs, [| mkHRefl typ term |]) else appeqs in
-    newc
+    mkApp (appeqs, abshypt)
       
-let abstract_args gl id = 
-  let c = pf_get_hyp_typ gl id in
+let deps_of_var id env =
+  Environ.fold_named_context
+    (fun _ (n,b,t) (acc : Idset.t) -> 
+      if Option.cata (occur_var env id) false b || occur_var env id t then
+	Idset.add n acc
+      else acc)
+    env ~init:Idset.empty
+    
+let idset_of_list =
+  List.fold_left (fun s x -> Idset.add x s) Idset.empty
+
+let hyps_of_vars env sign nogen hyps =
+  if Idset.is_empty hyps then [] 
+  else
+    let (_,lh) =
+      Sign.fold_named_context_reverse
+        (fun (hs,hl) (x,_,_ as d) ->
+	  if Idset.mem x nogen then (hs,hl)
+	  else if Idset.mem x hs then (hs,x::hl)
+	  else
+	    let xvars = global_vars_set_of_decl env d in
+	      if not (Idset.equal (Idset.diff xvars hs) Idset.empty) then
+		(Idset.add x hs, x :: hl)
+	      else (hs, hl))
+        ~init:(hyps,[])
+        sign 
+    in lh
+
+exception Seen
+
+let linear vars args = 
+  let seen = ref vars in
+    try 
+      Array.iter (fun i -> 
+	let rels = ids_of_constr ~all:true Idset.empty i in
+	let seen' = 
+	  Idset.fold (fun id acc ->
+	    if Idset.mem id acc then raise Seen
+	    else Idset.add id acc)
+	    rels !seen
+	in seen := seen')
+	args;
+      true
+    with Seen -> false
+
+let abstract_args gl generalize_vars dep id defined f args =
   let sigma = project gl in
   let env = pf_env gl in
   let concl = pf_concl gl in
-  let dep = dependent (mkVar id) concl in
+  let dep = dep || dependent (mkVar id) concl in
   let avoid = ref [] in
-  let get_id name = 
-    let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in 
+  let get_id name =
+    let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in
       avoid := id :: !avoid; id
   in
-  match kind_of_term c with
-      App (f, args) -> 
-	(* Build application generalized w.r.t. the argument plus the necessary eqs.
-	   From env |- c : forall G, T and args : G we build
-	   (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize)
-
-	   eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *)
-	*)
-	let aux (prod, ctx, ctxenv, c, args, eqs, refls, vars, env) arg =
-	  let (name, _, ty), arity = 
-	    let rel, c = Reductionops.decomp_n_prod env sigma 1 prod in
-	      List.hd rel, c
+    (* Build application generalized w.r.t. the argument plus the necessary eqs.
+       From env |- c : forall G, T and args : G we build
+       (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize)
+       
+       eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *)
+    *)
+  let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg =
+    let (name, _, ty), arity =
+      let rel, c = Reductionops.splay_prod_n env sigma 1 prod in
+	List.hd rel, c
+    in
+    let argty = pf_type_of gl arg in
+    let argty = refresh_universes_strict argty in 
+    let lenctx = List.length ctx in
+    let liftargty = lift lenctx argty in
+    let leq = constr_cmp Reduction.CUMUL liftargty ty in
+      match kind_of_term arg with
+      | Var id when leq && not (Idset.mem id nongenvars) ->
+      	  (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls,
+      	  Idset.add id nongenvars, Idset.remove id vars, env)
+      | _ ->
+	  let name = get_id name in
+	  let decl = (Name name, None, ty) in
+	  let ctx = decl :: ctx in
+	  let c' = mkApp (lift 1 c, [|mkRel 1|]) in
+	  let args = arg :: args in
+	  let liftarg = lift (List.length ctx) arg in
+	  let eq, refl =
+	    if leq then
+	      mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg
+	    else
+	      mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg
 	  in
-	  let argty = pf_type_of gl arg in
-	  let liftargty = lift (List.length ctx) argty in
-	  let convertible = Reductionops.is_conv_leq ctxenv sigma liftargty ty in
-	    match kind_of_term arg with
-	    | Var _ | Rel _ | Ind _ when convertible -> 
-		(subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env)
-	    | _ ->
-		let name = get_id name in
-		let decl = (Name name, None, ty) in
-		let ctx = decl :: ctx in
-		let c' = mkApp (lift 1 c, [|mkRel 1|]) in
-		let args = arg :: args in
-		let liftarg = lift (List.length ctx) arg in
-		let eq, refl = 
-		  if convertible then
-		    mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg
-		  else
-		    mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg
-		in
-		let eqs = eq :: lift_list eqs in
-		let refls = refl :: refls in
-		let vars = ids_of_constr vars arg in
-		  (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env)
-	in 
-	let f, args =
-	  match kind_of_term f with
-	  | Construct (ind,_) 
-	  | Ind ind ->
-              let (mib,mip) = Global.lookup_inductive ind in
-	      let first = mib.Declarations.mind_nparams in
-	      let pars, args = array_chop first args in
-		mkApp (f, pars), args
-	  | _ -> f, args
-	in
-	let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = 
-	  Array.fold_left aux (pf_type_of gl f,[],env,f,[],[],[],[],env) args
-	in
-	let args, refls = List.rev args, List.rev refls in
-	  Some (make_abstract_generalize gl id concl dep ctx c' eqs args refls,
-	       dep, succ (List.length ctx), vars)
-    | _ -> None
-
-let abstract_generalize id ?(generalize_vars=true) gl =
+	  let eqs = eq :: lift_list eqs in
+	  let refls = refl :: refls in
+	  let argvars = ids_of_constr vars arg in
+	    (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, 
+	    nongenvars, Idset.union argvars vars, env)
+  in 
+  let f', args' = decompose_indapp f args in
+  let dogen, f', args' =
+    let parvars = ids_of_constr ~all:true Idset.empty f' in
+      if not (linear parvars args') then true, f, args
+      else
+	match array_find_i (fun i x -> not (isVar x)) args' with
+	| None -> false, f', args'
+	| Some nonvar ->
+	    let before, after = array_chop nonvar args' in
+	      true, mkApp (f', before), after
+  in
+    if dogen then
+      let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = 
+	Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args'
+      in
+      let args, refls = List.rev args, List.rev refls in
+      let vars = 
+	if generalize_vars then
+	  let nogen = Idset.add id nogen in
+	    hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars
+	else []
+      in
+      let body, c' = if defined then Some c', Retyping.get_type_of ctxenv Evd.empty c' else None, c' in
+	Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls,
+	     dep, succ (List.length ctx), vars)
+    else None
+      
+let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl =
   Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-  let oldid = pf_get_new_id id gl in
-  let newc = abstract_args gl id in
-    match newc with
+  let f, args, def, id, oldid = 
+    let oldid = pf_get_new_id id gl in
+    let (_, b, t) = pf_get_hyp gl id in
+      match b with
+      | None -> let f, args = decompose_app t in
+		  f, args, false, id, oldid
+      | Some t -> 
+	  let f, args = decompose_app t in
+	    f, args, true, id, oldid
+  in
+  if args = [] then tclIDTAC gl
+  else 
+    let args = Array.of_list args in
+    let newc = abstract_args gl generalize_vars force_dep id def f args in
+      match newc with
       | None -> tclIDTAC gl
       | Some (newc, dep, n, vars) -> 
 	  let tac =
 	    if dep then
 	      tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; 
-			   generalize_dep (mkVar oldid)]	      
+			   generalize_dep ~with_let:true (mkVar oldid)]	      
 	    else
 	      tclTHENLIST [refine newc; clear [id]; tclDO n intro]
 	  in 
-	    if generalize_vars then tclTHEN tac 
-	      (tclFIRST [revert (List.rev vars) ;
-			 tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]) gl
-	    else tac gl
-	      
-let dependent_pattern c gl =
-  let cty = pf_type_of gl c in
-  let deps = 
-    match kind_of_term cty with
-    | App (f, args) -> Array.to_list args
-    | _ -> []
-  in
-  let varname c = match kind_of_term c with
-    | Var id -> id
-    | _ -> id_of_string (hdchar (pf_env gl) c)
-  in
-  let mklambda ty (c, id, cty) =
-    let conclvar = subst_term_occ all_occurrences c ty in
-      mkNamedLambda id cty conclvar
+	    if vars = [] then tac gl
+	    else tclTHEN tac 
+	      (fun gl -> tclFIRST [revert vars ;
+				   tclMAP (fun id -> 
+				     tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl
+
+let specialize_eqs id gl =
+  let env = pf_env gl in
+  let ty = pf_get_hyp_typ gl id in
+  let evars = ref (create_evar_defs (project gl)) in
+  let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in
+  let rec aux in_eqs ctx acc ty =
+    match kind_of_term ty with
+    | Prod (na, t, b) -> 
+	(match kind_of_term t with
+	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
+	    let c = if noccur_between 1 (List.length ctx) x then y else x in
+	    let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in
+	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in
+	      if unif (push_rel_context ctx env) evars pt t then
+		aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
+	      else acc, in_eqs, ctx, ty
+	| App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) ->
+	    let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in
+	    let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in
+	    let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in
+	      if unif (push_rel_context ctx env) evars pt t then
+		aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
+	      else acc, in_eqs, ctx, ty
+	| _ -> 
+	    if in_eqs then acc, in_eqs, ctx, ty
+	    else 
+	      let e = e_new_evar evars (push_rel_context ctx env) t in
+		aux false ((na, Some 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'
   in
-  let subst = (c, varname c, cty) :: List.rev_map (fun c -> (c, varname c, pf_type_of gl c)) deps in
-  let concllda = List.fold_left mklambda (pf_concl gl) subst in 
-  let conclapp = applistc concllda (List.rev_map pi1 subst) in
-    convert_concl_no_check conclapp DEFAULTcast gl
+  let ty' = it_mkProd_or_LetIn ty ctx'' in
+  let acc' = it_mkLambda_or_LetIn acc ctx'' in
+  let ty' = Tacred.whd_simpl env !evars ty' 
+  and acc' = Tacred.whd_simpl env !evars acc' in
+  let ty' = Evarutil.nf_evar !evars ty' in
+    if worked then
+      tclTHENFIRST (Tacmach.internal_cut true id ty')
+	(exact_no_check (refresh_universes_strict acc')) gl
+    else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl
       
-let occur_rel n c = 
+
+let specialize_eqs id gl =
+  if try ignore(clear [id] gl); false with _ -> true then
+    tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl 
+  else specialize_eqs id gl
+
+let occur_rel n c =
   let res = not (noccurn n c) in
   res
 
@@ -2266,19 +2524,19 @@ let cut_list n l =
 
 
 (* This function splits the products of the induction scheme [elimt] into four
-   parts: 
+   parts:
    - branches, easily detectable (they are not referred by rels in the subterm)
    - what was found before branches (acc1) that is: parameters and predicates
    - what was found after branches (acc3) that is: args and indarg if any
    if there is no branch, we try to fill in acc3 with args/indargs.
    We also return the conclusion.
 *)
-let decompose_paramspred_branch_args elimt = 
+let decompose_paramspred_branch_args elimt =
   let rec cut_noccur elimt acc2 : rel_context * rel_context * types =
     match kind_of_term elimt with
-      | Prod(nme,tpe,elimt') -> 
-	  let hd_tpe,_ = decompose_app (snd (decompose_prod_assum tpe)) in
-	  if not (occur_rel 1 elimt') && isRel hd_tpe	    
+      | 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)
 	  else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl
       | App(_, _) | Rel _ -> acc2 , [] , elimt
@@ -2297,7 +2555,7 @@ let decompose_paramspred_branch_args elimt =
      we must find the predicate of the conclusion to separate params_pred from
      args. We suppose there is only one predicate here. *)
   if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl
-  else 
+  else
     let hyps,ccl = decompose_prod_assum elimt in
     let hd_ccl_pred,_ = decompose_app ccl in
     match kind_of_term hd_ccl_pred with
@@ -2315,7 +2573,7 @@ let exchange_hd_app subst_hd t =
    eliminator by modifying their scheme_info, then rebuild the
    eliminator type, then prove it (with tactics). *)
 let rebuild_elimtype_from_scheme (scheme:elim_scheme): types =
-  let hiconcl = 
+  let hiconcl =
     match scheme.indarg with
       | None -> scheme.concl
       | Some x -> mkProd_or_LetIn x scheme.concl in
@@ -2333,8 +2591,8 @@ exception NoLastArgCcl
    first separate branches.  We obtain branches, hyps before (params + preds),
    hyps after (args <+ indarg if present>) and conclusion.  Then we proceed as
    follows:
-   
-   - separate parameters and predicates in params_preds. For that we build: 
+
+   - separate parameters and predicates in params_preds. For that we build:
  forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg
                              ^^^^^^^^^^^^^^^^^^^^^^^^^                  ^^^^^^^
                                        optional                           opt
@@ -2346,28 +2604,28 @@ exception NoLastArgCcl
 
    - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *)
 let compute_elim_sig ?elimc elimt =
-  let params_preds,branches,args_indargs,conclusion = 
+  let params_preds,branches,args_indargs,conclusion =
     decompose_paramspred_branch_args elimt in
-  
+
   let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in
-  let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in  
+  let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in
   let nparams = Intset.cardinal (free_rels concl_with_args) in
   let preds,params = cut_list (List.length params_preds - nparams) params_preds in
-  
+
   (* A first approximation, further analysis will tweak it *)
   let res = ref { empty_scheme with
     (* This fields are ok: *)
     elimc = elimc; elimt = elimt; concl = conclusion;
-    predicates = preds; npredicates = List.length preds; 
-    branches = branches; nbranches = List.length branches; 
+    predicates = preds; npredicates = List.length preds;
+    branches = branches; nbranches = List.length branches;
     farg_in_concl = isApp ccl && isApp (last_arg ccl);
-    params = params; nparams = nparams; 
+    params = params; nparams = nparams;
     (* all other fields are unsure at this point. Including these:*)
     args = args_indargs; nargs = List.length args_indargs; } in
-  try 
+  try
     (* Order of tests below is important. Each of them exits if successful. *)
     (* 1- First see if (f x...) is in the conclusion. *)
-    if !res.farg_in_concl 
+    if !res.farg_in_concl
     then begin
       res := { !res with
 	indarg = None;
@@ -2375,19 +2633,19 @@ let compute_elim_sig ?elimc elimt =
       raise Exit
     end;
     (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *)
-    if !res.nargs=0 then raise Exit; 
+    if !res.nargs=0 then raise Exit;
     (* 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 -> 
+	| hiname,None,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
-		| Ind (mind,_)  -> true 
-		| Var _ -> true 
-		| Const _ -> true 
-		| Construct _ -> true 
+		| Ind (mind,_)  -> true
+		| Var _ -> true
+		| Const _ -> true
+		| Construct _ -> true
 		| _ -> false in
 	    let hi_args_enough = (* hi a le bon nbre d'arguments *)
 	      List.length hi_args = List.length params + !res.nargs -1 in
@@ -2405,78 +2663,75 @@ let compute_elim_sig ?elimc elimt =
     match !res.indarg with
       | None -> !res (* No indref *)
       | Some ( _,Some _,_) -> error_ind_scheme ""
-      | Some ( _,None,ind) -> 
+      | Some ( _,None,ind) ->
 	  let indhd,indargs = decompose_app ind in
 	  try {!res with indref = Some (global_of_constr indhd) }
 	  with _ -> error "Cannot find the inductive type of the inductive scheme.";;
 
-(* Check that the elimination scheme has a form similar to the 
-   elimination schemes built by Coq. Schemes may have the standard
-   form computed from an inductive type OR (feb. 2006) a non standard
-   form. That is: with no main induction argument and with an optional
-   extra final argument of the form (f x y ...) in the conclusion. In
-   the non standard case, naming of generated hypos is slightly
-   different. *)
-let compute_elim_signature elimc elimt names_info ind_type_guess =
-  let scheme = compute_elim_sig ~elimc:elimc elimt in
+let compute_scheme_signature scheme names_info ind_type_guess =
   let f,l = decompose_app scheme.concl in
-  (* Vérifier que les arguments de Qi sont bien les xi. *)
+  (* Vérifier que les arguments de Qi sont bien les xi. *)
   match scheme.indarg with
     | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme."
     | None -> (* Non standard scheme *)
-	let is_pred n c = 
+	let is_pred n c =
 	  let hd = fst (decompose_app c) in match kind_of_term hd with
 	    | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
 	    | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg
-	    | _ -> OtherArg in 
-	let rec check_branch p c = 
+	    | _ -> OtherArg in
+	let rec check_branch p c =
 	  match kind_of_term c with
-	    | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c
-	    | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c
+	    | Prod (_,t,c) ->
+		(is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
+	    | LetIn (_,_,_,c) ->
+		(OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
 	    | _ when is_pred p c = IndArg -> []
-	    | _ -> raise Exit in 
-	let rec find_branches p lbrch = 
+	    | _ -> raise Exit in
+	let rec find_branches p lbrch =
 	  match lbrch with
 	    | (_,None,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
-		  let recvarname, hyprecname, avoid = 
+		  let n = List.fold_left
+		    (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 -> (b,if b=IndArg then hyprecname else recvarname))
+		  let namesign =
+		    List.map (fun (b,dep) ->
+		      (b,dep,if b=IndArg then hyprecname else recvarname))
 		      lchck_brch in
 		  (avoid,namesign) :: find_branches (p+1) brs
 		with Exit-> error_ind_scheme "the branches of")
 	    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
 	    | [] -> [] in
-	let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in
-	indsign,scheme	
-	
+	Array.of_list (find_branches 0 (List.rev scheme.branches))
+
     | Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
 	let indhd,indargs = decompose_app ind in
-	let is_pred n c = 
+	let is_pred n c =
 	  let hd = fst (decompose_app c) in match kind_of_term hd with
 	    | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
 	    | _ when hd = indhd -> RecArg
 	    | _ -> OtherArg in
 	let rec check_branch p c = match kind_of_term c with
-	  | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c
-	  | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c
+	  | Prod (_,t,c) ->
+	      (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
+	  | LetIn (_,_,_,c) ->
+	      (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
 	  | _ when is_pred p c = IndArg -> []
-	  | _ -> raise Exit in 
+	  | _ -> raise Exit in
 	let rec find_branches p lbrch =
 	  match lbrch with
 	    | (_,None,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
-		  let recvarname, hyprecname, avoid = 
+		  let n = List.fold_left
+		    (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 -> (b,if b=IndArg then hyprecname else recvarname))
+		  let namesign =
+		    List.map (fun (b,dep) ->
+		      (b,dep,if b=IndArg then hyprecname else recvarname))
 		      lchck_brch in
 		  (avoid,namesign) :: find_branches (p+1) brs
 		with Exit -> error_ind_scheme "the branches of")
@@ -2485,67 +2740,126 @@ let compute_elim_signature elimc elimt names_info ind_type_guess =
 		(* Check again conclusion *)
 
 		let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in
-		let ind_is_ok = 
-		  list_lastn scheme.nargs indargs 
+		let ind_is_ok =
+		  list_lastn scheme.nargs indargs
 		  = extended_rel_list 0 scheme.args in
 		if not (ccl_arg_ok & ind_is_ok) then
 		  error_ind_scheme "the conclusion of";
-		[] 
+		[]
 	in
-	let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in
-	indsign,scheme
+	Array.of_list (find_branches 0 (List.rev scheme.branches))
 
+(* Check that the elimination scheme has a form similar to the
+   elimination schemes built by Coq. Schemes may have the standard
+   form computed from an inductive type OR (feb. 2006) a non standard
+   form. That is: with no main induction argument and with an optional
+   extra final argument of the form (f x y ...) in the conclusion. In
+   the non standard case, naming of generated hypos is slightly
+   different. *)
+let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info =
+  let scheme = compute_elim_sig ~elimc:elimc elimt in
+  compute_scheme_signature scheme names_info ind_type_guess, scheme
 
-let find_elim_signature isrec elim hyp0 gl =
+let guess_elim isrec hyp0 gl =
   let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
-  let (elimc,elimt),ind = match elim with
+  let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
+  let s = elimination_sort_of_goal gl in
+  let elimc =
+    if isrec then lookup_eliminator mind s
+    else
+      if use_dependent_propositions_elimination () &&
+	dependent_no_evar (mkVar hyp0) (pf_concl gl)
+      then
+	pf_apply build_case_analysis_scheme gl mind true s
+      else
+	pf_apply build_case_analysis_scheme_default gl mind s in
+  let elimt = pf_type_of gl elimc in
+  ((elimc, NoBindings), elimt), mkInd mind
+
+let given_elim hyp0 (elimc,lbind as e) gl =
+  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+  let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in
+  (e, pf_type_of gl elimc), ind_type_guess
+
+let find_elim isrec elim hyp0 gl =
+  match elim with
+    | None -> guess_elim isrec hyp0 gl
+    | Some e -> given_elim hyp0 e gl
+
+type scheme_signature =
+    (identifier list * (elim_arg_kind * bool * identifier) list) array
+
+type eliminator_source =
+  | ElimUsing of (eliminator * types) * scheme_signature
+  | ElimOver of bool * identifier
+
+let find_induction_type isrec elim hyp0 gl =
+  let scheme,elim =
+    match elim with
     | None ->
-	let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
-	let s = elimination_sort_of_goal gl in
-	let elimc =
-	  if isrec then lookup_eliminator mind s
-	  else pf_apply make_case_gen gl mind s in
-	let elimt = pf_type_of gl elimc in
-	((elimc, NoBindings), elimt), mkInd mind
-    | Some (elimc,lbind as e) ->
-	let ind_type_guess,_ = decompose_app (snd (decompose_prod tmptyp0)) in
-	(e, pf_type_of gl elimc), ind_type_guess in
-  let indsign,elim_scheme =
-    compute_elim_signature elimc elimt hyp0 ind in
-  (indsign,elim_scheme)
+	let (elimc,elimt),_ = guess_elim isrec hyp0 gl in
+	let scheme = compute_elim_sig ~elimc elimt in
+	(* We drop the scheme waiting to know if it is dependent *)
+	scheme, ElimOver (isrec,hyp0)
+    | Some e ->
+	let (elimc,elimt),ind_guess = given_elim hyp0 e gl in
+	let scheme = compute_elim_sig ~elimc elimt in
+	if scheme.indarg = None then error "Cannot find induction type";
+	let indsign = compute_scheme_signature scheme hyp0 ind_guess in
+	let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in
+	scheme, ElimUsing (elim,indsign) in
+  Option.get scheme.indref,scheme.nparams, elim
 
+let find_elim_signature isrec elim hyp0 gl =
+  compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0
+
+let is_functional_induction elim gl =
+  match elim with
+  | Some elimc ->
+      let scheme = compute_elim_sig ~elimc (pf_type_of gl (fst elimc)) in
+      (* The test is not safe: with non-functional induction on non-standard
+         induction scheme, this may fail *)
+      scheme.indarg = None
+  | None ->
+      false
+
+(* Wait the last moment to guess the eliminator so as to know if we
+   need a dependent one or not *)
+
+let get_eliminator elim gl = match elim with
+  | ElimUsing (elim,indsign) ->
+      (* bugged, should be computed *) true, elim, indsign
+  | ElimOver (isrec,id) ->
+      let (elimc,elimt),_ as elims = guess_elim isrec id gl in
+      isrec, ({elimindex = None; elimbody = elimc}, elimt),
+      fst (compute_elim_signature elims id)
 
 (* Instantiate all meta variables of elimclause using lid, some elts
    of lid are parameters (first ones), the other are
    arguments. Returns the clause obtained.  *)
-let recolle_clenv scheme lid elimclause gl = 
+let recolle_clenv nparams lid elimclause gl =
   let _,arr = destApp elimclause.templval.rebus in
-  let lindmv = 
+  let lindmv =
     Array.map
-      (fun x -> 
+      (fun x ->
 	match kind_of_term x with
 	  | Meta mv -> mv
 	  | _  -> errorlabstrm "elimination_clause"
               (str "The type of the elimination clause is not well-formed."))
       arr in
   let nmv = Array.length lindmv in
-  let lidparams,lidargs = cut_list (scheme.nparams) lid in
+  let lidparams,lidargs = cut_list nparams lid in
   let nidargs = List.length lidargs in
   (* parameters correspond to first elts of lid. *)
-  let clauses_params = 
+  let clauses_params =
     list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i))
       0 lidparams in
   (* arguments correspond to last elts of lid. *)
-  let clauses_args = 
-    list_map_i 
+  let clauses_args =
+    list_map_i
       (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i))
       0 lidargs in
-  let clause_indarg = 
-    match scheme.indarg with
-      | None -> []
-      | Some (x,_,typx) -> []
-  in
-  let clauses = clauses_params@clauses_args@clause_indarg in
+  let clauses = clauses_params@clauses_args in
   (* iteration of clenv_fchain with all infos we have. *)
   List.fold_right
     (fun e acc ->
@@ -2563,119 +2877,129 @@ let recolle_clenv scheme lid elimclause gl =
    (elimc ?i ?j ?k...?l). This solves partly meta variables (and may
     produce new ones). Then refine with the resulting term with holes.
 *)
-let induction_tac_felim with_evars indvars scheme gl = 
-  let elimt = scheme.elimt in
-  let elimc,lbindelimc = 
-    match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in
+let induction_tac_felim with_evars indvars nparams elim gl =
+  let {elimbody=(elimc,lbindelimc)},elimt = elim in
   (* elimclause contains this: (elimc ?i ?j ?k...?l) *)
   let elimclause =
     make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
   (* elimclause' is built from elimclause by instanciating all args and params. *)
-  let elimclause' = recolle_clenv scheme indvars elimclause gl in
+  let elimclause' = recolle_clenv nparams indvars elimclause gl in
   (* one last resolution (useless?) *)
   let resolved = clenv_unique_resolver true elimclause' gl in
   clenv_refine with_evars resolved gl
 
-let apply_induction_in_context isrec hyp0 indsign indvars names induct_tac gl =
+(* Apply induction "in place" replacing the hypothesis on which
+   induction applies with the induction hypotheses *)
+
+let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac gl =
+  let isrec, elim, indsign = get_eliminator elim gl in
+  let names = compute_induction_names (Array.length indsign) names in
+  (if isrec then tclTHENFIRSTn else tclTHENLASTn)
+    (tclTHEN (induct_tac elim) (tclTRY (thin indhyps)))
+    (array_map2 (induct_discharge destopt avoid tac) indsign names) gl
+
+(* Apply induction "in place" taking into account dependent
+   hypotheses from the context *)
+
+let apply_induction_in_context hyp0 elim indvars names induct_tac gl =
   let env = pf_env gl in
-  let statlists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in
-  let deps = List.map (fun (id,c,t)-> (id,c,refresh_universes_strict t)) deps in
+  let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in
+  let deps = List.map (on_pi3 refresh_universes_strict) deps in
   let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
-  let names = compute_induction_names (Array.length indsign) names in
   let dephyps = List.map (fun (id,_,_) -> id) deps in
   let deps_cstr =
     List.fold_left
       (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
   tclTHENLIST
-    [ 
+    [
       (* Generalize dependent hyps (but not args) *)
       if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
       (* clear dependent hyps *)
       thin dephyps;
       (* side-conditions in elim (resp case) schemes come last (resp first) *)
-      (if isrec then tclTHENFIRSTn else tclTHENLASTn)
-        (tclTHEN induct_tac (tclTRY (thin (List.rev indhyps))))
-	(array_map2 
-	  (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
+      apply_induction_with_discharge
+	induct_tac elim (List.rev indhyps) lhyp0 (List.rev dephyps) names
+        (re_intro_dependent_hypotheses statuslists)
     ]
     gl
 
 (* Induction with several induction arguments, main differences with
    induction_from_context is that there is no main induction argument,
-   so we chose one to be the positioning reference. On the other hand,
+   so we choose one to be the positioning reference. On the other hand,
    all args and params must be given, so we help a bit the unifier by
    making the "pattern" by hand before calling induction_tac_felim
    FIXME: REUNIF AVEC induction_tac_felim? *)
-let induction_from_context_l isrec with_evars elim_info lid names gl =
+let induction_from_context_l with_evars elim_info lid names gl =
   let indsign,scheme = elim_info in
   (* number of all args, counting farg and indarg if present. *)
   let nargs_indarg_farg = scheme.nargs
-    + (if scheme.farg_in_concl then 1 else 0) 
+    + (if scheme.farg_in_concl then 1 else 0)
     + (if scheme.indarg <> None then 1 else 0) in
   (* Number of given induction args must be exact. *)
-  if List.length lid <> nargs_indarg_farg + scheme.nparams then 
+  if List.length lid <> nargs_indarg_farg + scheme.nparams then
       error "Not the right number of arguments given to induction scheme.";
   (* hyp0 is used for re-introducing hyps at the right place afterward.
      We chose the first element of the list of variables on which to
      induct. It is probably the first of them appearing in the
      context. *)
-  let hyp0,indvars,lid_params = 
+  let hyp0,indvars,lid_params =
     match lid with
       | []  -> anomaly "induction_from_context_l"
-      | e::l -> 
+      | e::l ->
 	  let nargs_without_first = nargs_indarg_farg - 1 in
 	  let ivs,lp = cut_list nargs_without_first l in
 	  e, ivs, lp in
   (* terms to patternify we must patternify indarg or farg if present in concl *)
-  let lid_in_pattern = 
+  let lid_in_pattern =
     if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars
     else List.rev (hyp0::indvars) in
   let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in
   let realindvars = (* hyp0 is a real induction arg if it is not the
 		       farg in the conclusion of the induction scheme *)
     List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in
-  let induct_tac = tclTHENLIST [
+  let induct_tac elim = tclTHENLIST [
     (* pattern to make the predicate appear. *)
     reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl;
     (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
        possible holes using arguments given by the user (but the
        functional one). *)
     (* FIXME: Tester ca avec un principe dependant et non-dependant *)
-    induction_tac_felim with_evars realindvars scheme
+    induction_tac_felim with_evars realindvars scheme.nparams elim
   ] in
-  apply_induction_in_context isrec
-    None indsign (hyp0::indvars) names induct_tac gl
+  let elim = ElimUsing (({elimindex = Some scheme.index; elimbody = Option.get scheme.elimc}, scheme.elimt), indsign) in
+  apply_induction_in_context
+    None elim (hyp0::indvars) names induct_tac gl
+
+(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the
+   hypothesis on which the induction is made *)
+let induction_tac with_evars elim (varname,lbind) typ gl =
+  let ({elimindex=i;elimbody=(elimc,lbindelimc)},elimt) = elim in
+  let indclause = make_clenv_binding gl (mkVar varname,typ) lbind  in
+  let i = match i with None -> index_of_ind_arg elimt | Some i -> i in
+  let elimclause =
+    make_clenv_binding gl
+      (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in
+  elimination_clause_scheme with_evars true i elimclause indclause gl
 
-let induction_from_context isrec with_evars elim_info (hyp0,lbind) names
+let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names
   inhyps gl =
-  let indsign,scheme = elim_info in
-  let indref = match scheme.indref with | None -> assert false | Some x -> x in
   let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
   let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
-  let indvars =
-    find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in
-  let induct_tac = tclTHENLIST [
-    induction_tac with_evars (hyp0,lbind) typ0 scheme;
+  let indvars = find_atomic_param_of_ind nparams ((strip_prod typ0)) in
+  let induct_tac elim = tclTHENLIST [
+    induction_tac with_evars elim (hyp0,lbind) typ0;
     tclTRY (unfold_body hyp0);
     thin [hyp0]
   ] in
-  apply_induction_in_context isrec
-    (Some (hyp0,inhyps)) indsign indvars names induct_tac gl
-
-exception TryNewInduct of exn
+  apply_induction_in_context
+    (Some (hyp0,inhyps)) elim indvars names induct_tac gl
 
 let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps gl =
-  let (indsign,scheme as elim_info) = find_elim_signature isrec elim hyp0 gl in
-  if scheme.indarg = None then (* This is not a standard induction scheme (the
-				  argument is probably a parameter) So try the
-				  more general induction mechanism. *)
-    induction_from_context_l isrec with_evars elim_info [hyp0] names gl
-  else
-    let indref = match scheme.indref with | None -> assert false | Some x -> x in
-    tclTHEN
-      (atomize_param_of_ind (indref,scheme.nparams) hyp0)
-      (induction_from_context isrec with_evars elim_info 
-	(hyp0,lbind) names inhyps) gl
+  let elim_info = find_induction_type isrec elim hyp0 gl in
+  tclTHEN
+    (atomize_param_of_ind elim_info hyp0)
+    (induction_from_context isrec with_evars elim_info
+      (hyp0,lbind) names inhyps) gl
 
 (* Induction on a list of induction arguments. Analyse the elim
    scheme (which is mandatory for multiple ind args), check that all
@@ -2683,15 +3007,15 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin
 let induction_without_atomization isrec with_evars elim names lid gl =
   let (indsign,scheme as elim_info) =
     find_elim_signature isrec elim (List.hd lid) gl in
-  let awaited_nargs = 
-    scheme.nparams + scheme.nargs 
+  let awaited_nargs =
+    scheme.nparams + scheme.nargs
     + (if scheme.farg_in_concl then 1 else 0)
     + (if scheme.indarg <> None then 1 else 0)
   in
   let nlid = List.length lid in
   if nlid <> awaited_nargs
   then error "Not the right number of induction arguments."
-  else induction_from_context_l isrec with_evars elim_info lid names gl
+  else induction_from_context_l with_evars elim_info lid names gl
 
 let enforce_eq_name id gl = function
   | (b,(loc,IntroAnonymous)) ->
@@ -2714,7 +3038,7 @@ let clear_unselected_context id inhyps cls gl =
   | None -> tclIDTAC gl
   | Some cls ->
       if occur_var (pf_env gl) id (pf_concl gl) &&
-	 cls.concl_occs = no_occurrences_expr 
+	 cls.concl_occs = no_occurrences_expr
       then errorlabstrm ""
 	    (str "Conclusion must be mentioned: it depends on " ++ pr_id id
 	     ++ str ".");
@@ -2736,21 +3060,21 @@ let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
   | _ -> [] in
   match kind_of_term c with
     | Var id when not (mem_named_context id (Global.named_context()))
-	        & lbind = NoBindings & not with_evars & eqname = None 
+	        & lbind = NoBindings & not with_evars & eqname = None
                 & not (has_selected_occurrences cls) ->
 	tclTHEN
           (clear_unselected_context id inhyps cls)
 	  (induction_with_atomization_of_ind_arg
 	    isrec with_evars elim names (id,lbind) inhyps) gl
     | _        ->
-	let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) 
+	let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
 		  Anonymous in
 	let id = fresh_id [] x gl in
 	(* We need the equality name now *)
 	let with_eq = Option.map (fun eq -> (false,eq)) eqname in
 	(* TODO: if ind has predicate parameters, use JMeq instead of eq *)
 	tclTHEN
-	  (letin_tac_gen with_eq (Name id) c None (Option.default allClauses cls,false))
+	  (letin_tac_gen with_eq (Name id) c None (Option.default allHypsAndConcl cls,false))
 	  (induction_with_atomization_of_ind_arg
 	     isrec with_evars elim names (id,lbind) inhyps) gl
 
@@ -2771,22 +3095,22 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl =
       | c::l' ->
 	  match kind_of_term c with
 	    | Var id when not (mem_named_context id (Global.named_context()))
-		& not with_evars -> 
+		& not with_evars ->
 		let _ = newlc:= id::!newlc in
 		atomize_list l' gl
 
 	    | _ ->
-		let x = 
+		let x =
 		  id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in
-		
+
 		let id = fresh_id [] x gl in
 		let newl' = List.map (replace_term c (mkVar id)) l' in
 		let _ = newlc:=id::!newlc in
 		let _ = letids:=id::!letids in
-		tclTHEN 
-		  (letin_tac None (Name id) c None allClauses)
+		tclTHEN
+		  (letin_tac None (Name id) c None allHypsAndConcl)
 		  (atomize_list newl') gl in
-  tclTHENLIST 
+  tclTHENLIST
     [
       (atomize_list lc);
       (fun gl' -> (* recompute each time to have the new value of newlc *)
@@ -2798,64 +3122,65 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl =
     ]
     gl
 
-
-let induct_destruct_l isrec with_evars lc elim names cls = 
-  (* Several induction hyps: induction scheme is mandatory *)
-  let _ = 
-    if elim = None
-    then 
-      errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypothesis are given.\n" ++ 
-      str "Example: induction x1 x2 x3 using my_scheme.") in
-  let newlc = 
-    List.map
-      (fun x -> 
-	match x with (* FIXME: should we deal with ElimOnIdent? *)
-	  | ElimOnConstr (x,NoBindings) -> x
-	  | _ -> error "Don't know where to find some argument.")
-      lc in
-  if cls <> None then
-    error
-      "'in' clause not supported when several induction hypothesis are given.";
-  new_induct_gen_l isrec with_evars elim names newlc
-
 (* Induction either over a term, over a quantified premisse, or over
    several quantified premisses (like with functional induction
-   principles). 
+   principles).
    TODO: really unify induction with one and induction with several
    args *)
-let induct_destruct isrec with_evars (lc,elim,names,cls) =
+let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
   assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
-  if List.length lc = 1 then (* induction on one arg: use old mechanism *)
-    try
+  if List.length lc = 1 && not (is_functional_induction elim gl) then
+    (* standard induction *)
+    onInductionArg
+      (fun c -> new_induct_gen isrec with_evars elim names c cls)
+      (List.hd lc) gl
+  else begin
+    (* functional induction *)
+    (* Several induction hyps: induction scheme is mandatory *)
+    if elim = None
+    then
+      errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypotheses are given.\n" ++
+      str "Example: induction x1 x2 x3 using my_scheme.");
+    if cls <> None then
+      error "'in' clause not supported here.";
+    if List.length lc = 1 then
+      (* Hook to recover standard induction on non-standard induction schemes *)
+      (* will be removable when is_functional_induction will be more clever *)
       onInductionArg
-	(fun c -> new_induct_gen isrec with_evars elim names c cls)
-	(List.hd lc)
-    with (* If this fails, try with new mechanism but if it fails too,
-	    then the exception is the first one. *)
-      | x ->
-	  (try induct_destruct_l isrec with_evars lc elim names cls
-	   with _  -> raise x)
-  else induct_destruct_l isrec with_evars lc elim names cls
+	(fun (c,lbind) ->
+	  if lbind <> NoBindings then
+	    error "'with' clause not supported here.";
+	  new_induct_gen_l isrec with_evars elim names [c])
+	(List.hd lc) gl
+    else
+      let newlc =
+	List.map (fun x ->
+	  match x with (* FIXME: should we deal with ElimOnIdent? *)
+	  | ElimOnConstr (x,NoBindings) -> x
+	  | _ -> error "Don't know where to find some argument.")
+	  lc in
+      new_induct_gen_l isrec with_evars elim names newlc gl
+  end
 
 let induction_destruct isrec with_evars = function
-  | [] -> tclIDTAC
-  | [a] -> induct_destruct isrec with_evars a
-  | a::l ->
+  | [],_ -> tclIDTAC
+  | [a,b,c],cl -> induct_destruct isrec with_evars (a,b,c,cl)
+  | (a,b,c)::l,cl ->
       tclTHEN
-        (induct_destruct isrec with_evars a)
-        (tclMAP (induct_destruct false with_evars) l)
+        (induct_destruct isrec with_evars (a,b,c,cl))
+        (tclMAP (fun (a,b,c) -> induct_destruct false with_evars (a,b,c,cl)) l)
 
 let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls)
 let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
 
 (* The registered tactic, which calls the default elimination
  * if no elimination constant is provided. *)
-	
+
 (* Induction tactics *)
 
 (* This was Induction before 6.3 (induction only in quantified premisses) *)
-let raw_induct s = tclTHEN (intros_until_id s) (tclLAST_HYP simplest_elim)
-let raw_induct_nodep n = tclTHEN (intros_until_n n) (tclLAST_HYP simplest_elim)
+let raw_induct s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim)
+let raw_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim)
 
 let simple_induct_id hyp = raw_induct hyp
 let simple_induct_nodep = raw_induct_nodep
@@ -2867,9 +3192,9 @@ let simple_induct = function
 (* Destruction tactics *)
 
 let simple_destruct_id s    =
-  (tclTHEN (intros_until_id s) (tclLAST_HYP simplest_case))
+  (tclTHEN (intros_until_id s) (onLastHyp simplest_case))
 let simple_destruct_nodep n =
-  (tclTHEN (intros_until_n n)    (tclLAST_HYP simplest_case))
+  (tclTHEN (intros_until_n n)    (onLastHyp simplest_case))
 
 let simple_destruct = function
   | NamedHyp id -> simple_destruct_id id
@@ -2878,7 +3203,7 @@ let simple_destruct = function
 (*
  *  Eliminations giving the type instead of the proof.
  * These tactics use the default elimination constant and
- * no substitutions at all. 
+ * no substitutions at all.
  * May be they should be integrated into Elim ...
  *)
 
@@ -2900,8 +3225,7 @@ let elim_type t gl =
 
 let case_type t gl =
   let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let env = pf_env gl in
-  let elimc = make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in 
+  let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in
   elim_scheme_type elimc t gl
 
 
@@ -2910,10 +3234,10 @@ let case_type t gl =
 (* These elimination tactics are particularly adapted for sequent
    calculus.  They take a clause as argument, and yield the
    elimination rule if the clause is of the form (Some id) and a
-   suitable introduction rule otherwise. They do not depend on 
-   the name of the eliminated constant, so they can be also 
+   suitable introduction rule otherwise. They do not depend on
+   the name of the eliminated constant, so they can be also
    used on ad-hoc disjunctions and conjunctions introduced by
-   the user. 
+   the user.
    -- Eduardo Gimenez (11/8/97)
 
    HH (29/5/99) replaces failures by specific error messages
@@ -2921,51 +3245,51 @@ let case_type t gl =
 
 let andE id gl =
   let t = pf_get_hyp_typ gl id in
-  if is_conjunction (pf_hnf_constr gl t) then 
+  if is_conjunction (pf_hnf_constr gl t) then
     (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl
-  else 
-    errorlabstrm "andE" 
+  else
+    errorlabstrm "andE"
       (str("Tactic andE expects "^(string_of_id id)^" is a conjunction."))
 
 let dAnd cls =
-  onClauses
+  onClause
     (function
       | None    -> simplest_split
-      | Some ((_,id),_) -> andE id)
+      | Some id -> andE id)
     cls
 
 let orE id gl =
   let t = pf_get_hyp_typ gl id in
-  if is_disjunction (pf_hnf_constr gl t) then 
+  if is_disjunction (pf_hnf_constr gl t) then
     (tclTHEN (simplest_elim (mkVar id)) intro) gl
-  else 
-    errorlabstrm "orE" 
+  else
+    errorlabstrm "orE"
       (str("Tactic orE expects "^(string_of_id id)^" is a disjunction."))
 
 let dorE b cls =
-  onClauses
+  onClause
     (function
-      | (Some ((_,id),_)) -> orE id
-      |  None     -> (if b then right else left) NoBindings)
+      | Some id -> orE id
+      | None    -> (if b then right else left) NoBindings)
     cls
 
 let impE id gl =
   let t = pf_get_hyp_typ gl id in
-  if is_imp_term (pf_hnf_constr gl t) then 
-    let (dom, _, rng) = destProd (pf_hnf_constr gl t) in 
+  if is_imp_term (pf_hnf_constr gl t) then
+    let (dom, _, rng) = destProd (pf_hnf_constr gl t) in
     tclTHENLAST
-      (cut_intro rng) 
+      (cut_intro rng)
       (apply_term (mkVar id) [mkMeta (new_meta())]) gl
-  else 
+  else
     errorlabstrm "impE"
       (str("Tactic impE expects "^(string_of_id id)^
 	      " is a an implication."))
-                        
+
 let dImp cls =
-  onClauses
+  onClause
     (function
       | None    -> intro
-      | Some ((_,id),_) -> impE id)
+      | Some id -> impE id)
     cls
 
 (************************************************)
@@ -2978,21 +3302,19 @@ let setoid_reflexivity = ref (fun _ -> assert false)
 let register_setoid_reflexivity f = setoid_reflexivity := f
 
 let reflexivity_red allowred 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 
+  (* PL: usual reflexivity don't perform any reduction when searching
+     for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
   let concl = if not allowred then pf_concl gl
-  else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) 
-  in 
+  else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl)
+  in
     match match_with_equality_type concl with
-    | None -> None
-    | Some _ -> Some (one_constructor 1 NoBindings)
+    | None -> raise NoEquationFound
+    | Some _ -> one_constructor 1 NoBindings gl
+
+let reflexivity gl =
+  try reflexivity_red false gl with NoEquationFound -> !setoid_reflexivity gl
 
-let reflexivity gl = 
-  match reflexivity_red false gl with
-  | None -> !setoid_reflexivity gl
-  | Some tac -> tac gl
-      
 let intros_reflexivity  = (tclTHEN intros reflexivity)
 
 (* Symmetry tactics *)
@@ -3005,74 +3327,67 @@ let intros_reflexivity  = (tclTHEN intros reflexivity)
 let setoid_symmetry = ref (fun _ -> assert false)
 let register_setoid_symmetry f = setoid_symmetry := f
 
+(* This is probably not very useful any longer *)
+let prove_symmetry hdcncl eq_kind =
+  let symc =
+    match eq_kind with
+    | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|])
+    | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|])
+    | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in
+  tclTHENFIRST (cut symc)
+    (tclTHENLIST
+      [ intro;
+        onLastHyp simplest_case;
+	one_constructor 1 NoBindings ])
+
 let symmetry_red allowred 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 
+  (* PL: usual symmetry don't perform any reduction when searching
+     for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl = if not allowred then pf_concl gl
-  else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) 
-  in 
-    match match_with_equation concl with
-    | None -> None
-    | Some (hdcncl,args) -> Some (fun gl ->
-        let hdcncls = string_of_inductive hdcncl in
-        begin 
-	  try 
-            tclTHEN
-              (convert_concl_no_check concl DEFAULTcast)
-	      (apply (pf_parse_const gl ("sym_"^hdcncls))) gl
-          with  _ ->
-            let symc = match args with 
-	      | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
-              | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |])
-              | [c1;c2]     -> mkApp (hdcncl, [| c2; c1 |])
-	      | _ -> assert false 
-	    in 
-	    tclTHENFIRST (cut symc)
-              (tclTHENLIST 
-		[ intro;
-		  tclLAST_HYP simplest_case;
-		  one_constructor 1 NoBindings ])
-	      gl
-	end)
-
-let symmetry gl = 
-  match symmetry_red false gl with
-  | None -> !setoid_symmetry gl
-  | Some tac -> tac gl
+  let concl =
+    if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl)
+  in
+  match match_with_equation concl with
+  | Some eq_data,_,_ ->
+      tclTHEN
+        (convert_concl_no_check concl DEFAULTcast)
+      (apply eq_data.sym) gl
+  | None,eq,eq_kind -> prove_symmetry eq eq_kind gl
+
+let symmetry gl =
+  try symmetry_red false gl with NoEquationFound -> !setoid_symmetry gl
 
 let setoid_symmetry_in = ref (fun _ _ -> assert false)
 let register_setoid_symmetry_in f = setoid_symmetry_in := f
 
-let symmetry_in id gl = 
-  let ctype = pf_type_of gl (mkVar id) in 
+let symmetry_in id gl =
+  let ctype = pf_type_of gl (mkVar id) in
   let sign,t = decompose_prod_assum ctype in
-  match match_with_equation t with
-    | None -> !setoid_symmetry_in id gl
-    | Some (hdcncl,args) -> 
-        let symccl = match args with 
-	  | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
-          | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |])
-          | [c1;c2]     -> mkApp (hdcncl, [| c2; c1 |])
-	  | _ -> assert false in
-	tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
-	  [ intro_replacing id;
-            tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
-	  gl
+  try
+    let _,hdcncl,eq = match_with_equation t in
+    let symccl = match eq with
+      | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |])
+      | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |])
+      | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in
+    tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
+      [ intro_replacing id;
+        tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
+      gl
+  with NoEquationFound -> !setoid_symmetry_in id gl
 
 let intros_symmetry =
-  onClauses
+  onClause
     (function
       | None -> tclTHEN intros symmetry
-      | Some ((_,id),_) -> symmetry_in id)
+      | Some id -> symmetry_in id)
 
 (* Transitivity tactics *)
 
 (* This tactic first tries to apply a constant named trans_eq, where eq
    is the name of the equality predicate. If this constant is not
-   defined and the conclusion is a=b, it solves the goal doing 
-   Cut x1=x2; 
-       [Cut x2=x3; [Intros e1 e2; Case e2;Assumption 
+   defined and the conclusion is a=b, it solves the goal doing
+   Cut x1=x2;
+       [Cut x2=x3; [Intros e1 e2; Case e2;Assumption
                     | Idtac]
        | Idtac]
    --Eduardo (19/8/97)
@@ -3081,50 +3396,55 @@ let intros_symmetry =
 let setoid_transitivity = ref (fun _ _ -> assert false)
 let register_setoid_transitivity f = setoid_transitivity := f
 
+(* This is probably not very useful any longer *)
+let prove_transitivity hdcncl eq_kind t gl =
+  let eq1,eq2 =
+    match eq_kind with
+    | MonomorphicLeibnizEq (c1,c2) ->
+      (mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]))
+  | PolymorphicLeibnizEq (typ,c1,c2) ->
+      (mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]))
+  | HeterogenousEq (typ1,c1,typ2,c2) ->
+      let typt = pf_type_of gl t in
+      (mkApp(hdcncl, [| typ1; c1; typt ;t |]),
+       mkApp(hdcncl, [| typt; t; typ2; c2 |])) in
+  tclTHENFIRST (cut eq2)
+    (tclTHENFIRST (cut eq1)
+      (tclTHENLIST
+	[ tclDO 2 intro;
+	  onLastHyp simplest_case;
+	  assumption ])) gl
+
 let transitivity_red allowred t gl =
-  (* PL: usual transitivity don't perform any reduction when searching 
-     for an equality, but we may need to do some when called back from 
+  (* PL: usual transitivity don't perform any reduction when searching
+     for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl = if not allowred then pf_concl gl
-  else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) 
-  in 
+  let concl =
+    if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl)
+  in
   match match_with_equation concl with
-    | None -> None
-    | Some (hdcncl,args) -> Some (fun gl ->
-        let hdcncls = string_of_inductive hdcncl in
-        begin
-	  try 
-	    apply_list [(pf_parse_const gl ("trans_"^hdcncls));t] gl 
-          with  _ -> 
-            let eq1, eq2 = match args with 
-	      | [typ1;c1;typ2;c2] -> let typt = pf_type_of gl t in
-                  ( mkApp(hdcncl, [| typ1; c1; typt ;t |]),
-		    mkApp(hdcncl, [| typt; t; typ2; c2 |]) )
-              | [typ;c1;c2] ->
-		  ( mkApp (hdcncl, [| typ; c1; t |]),
-		    mkApp (hdcncl, [| typ; t; c2 |]) )
-	      | [c1;c2]     ->
-		  ( mkApp (hdcncl, [| c1; t|]),
-		    mkApp (hdcncl, [| t; c2 |]) )
-	      | _ -> assert false 
-	    in
-            tclTHENFIRST (cut eq2)
-	      (tclTHENFIRST (cut eq1)
-                (tclTHENLIST
-		  [ tclDO 2 intro;
-		    tclLAST_HYP simplest_case;
-		    assumption ])) gl
-        end)
-
-let transitivity t gl =
-  match transitivity_red false t gl with
-  | None -> !setoid_transitivity t gl
-  | Some tac -> tac gl
-      
-let intros_transitivity  n  = tclTHEN intros (transitivity n)
-
-(* tactical to save as name a subproof such that the generalisation of 
-   the current goal, abstracted with respect to the local signature, 
+  | Some eq_data,_,_ ->
+      tclTHEN
+        (convert_concl_no_check concl DEFAULTcast)
+        (match t with
+	 | None -> eapply eq_data.trans
+	 | Some t -> apply_list [eq_data.trans;t]) gl
+  | None,eq,eq_kind ->
+      match t with
+      | None -> error "etransitivity not supported for this relation."
+      | Some t -> prove_transitivity eq eq_kind t gl
+
+let transitivity_gen t gl =
+  try transitivity_red false t gl
+  with NoEquationFound -> !setoid_transitivity t gl
+
+let etransitivity = transitivity_gen None
+let transitivity t = transitivity_gen (Some t)
+
+let intros_transitivity  n  = tclTHEN intros (transitivity_gen n)
+
+(* tactical to save as name a subproof such that the generalisation of
+   the current goal, abstracted with respect to the local signature,
    is solved by tac *)
 
 let interpretable_as_section_decl d1 d2 = match d1,d2 with
@@ -3132,62 +3452,52 @@ let interpretable_as_section_decl d1 d2 = match d1,d2 with
   | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2
   | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
 
-let abstract_subproof name tac gl = 
+let abstract_subproof id tac gl =
   let current_sign = Global.named_context()
   and global_sign = pf_hyps gl in
-  let sign,secsign = 
+  let sign,secsign =
     List.fold_right
-      (fun (id,_,_ as d) (s1,s2) -> 
+      (fun (id,_,_ as d) (s1,s2) ->
 	if mem_named_context id current_sign &
           interpretable_as_section_decl (Sign.lookup_named id current_sign) d
         then (s1,push_named_context_val d s2)
-	else (add_named_decl d s1,s2)) 
+	else (add_named_decl d s1,s2))
       global_sign (empty_named_context,empty_named_context_val) in
-  let na = next_global_ident_away false name (pf_ids_of_hyps gl) in
+  let id = next_global_ident_away id (pf_ids_of_hyps gl) in
   let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
-    if occur_existential concl then
-      error "\"abstract\" cannot handle existentials.";
-    let lemme =
-      start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ());
-      let _,(const,_,kind,_) =
-	try
-	  by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); 
-	  let r = cook_proof ignore in 
-	    delete_current_proof (); r
-	with 
-	    e ->
-	      (delete_current_proof(); raise e)
-      in   (* Faudrait un peu fonctionnaliser cela *)
-      let cd = Entries.DefinitionEntry const in
-      let con = Declare.declare_internal_constant na (cd,IsProof Lemma) in
-	constr_of_global (ConstRef con)
-    in
-      exact_no_check 
-	(applist (lemme, 
-		 List.rev (Array.to_list (instance_from_named_context sign))))
-	gl
-
-let tclABSTRACT name_op tac gl = 
-  let s = match name_op with 
-    | Some s -> s 
-    | None   -> add_suffix (get_current_proof_name ()) "_subproof" 
-  in  
+  let concl =
+    try flush_and_check_evars (project gl) concl
+    with Uninstantiated_evar _ ->
+      error "\"abstract\" cannot handle existentials." in
+  let const = Pfedit.build_constant_by_tactic secsign concl
+    (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in
+  let cd = Entries.DefinitionEntry const in
+  let lem = mkConst (Declare.declare_internal_constant id (cd,IsProof Lemma)) in
+  exact_no_check
+    (applist (lem,List.rev (Array.to_list (instance_from_named_context sign))))
+    gl
+
+let tclABSTRACT name_op tac gl =
+  let s = match name_op with
+    | Some s -> s
+    | None   -> add_suffix (get_current_proof_name ()) "_subproof"
+  in
   abstract_subproof s tac gl
 
 
 let admit_as_an_axiom gl =
   let current_sign = Global.named_context()
   and global_sign = pf_hyps gl in
-  let sign,secsign = 
+  let sign,secsign =
     List.fold_right
-      (fun (id,_,_ as d) (s1,s2) -> 
+      (fun (id,_,_ as d) (s1,s2) ->
 	 if mem_named_context id current_sign &
            interpretable_as_section_decl (Sign.lookup_named id current_sign) d
          then (s1,add_named_decl d s2)
-	 else (add_named_decl d s1,s2)) 
+	 else (add_named_decl d s1,s2))
       global_sign (empty_named_context,empty_named_context) in
   let name = add_suffix (get_current_proof_name ()) "_admitted" in
-  let na = next_global_ident_away false name (pf_ids_of_hyps gl) in
+  let na = next_global_ident_away name (pf_ids_of_hyps gl) in
   let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
   if occur_existential concl then error"\"admit\" cannot handle existentials.";
   let axiom =
@@ -3195,19 +3505,19 @@ let admit_as_an_axiom gl =
     let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in
     constr_of_global (ConstRef con)
   in
-  exact_no_check 
-    (applist (axiom, 
+  exact_no_check
+    (applist (axiom,
               List.rev (Array.to_list (instance_from_named_context sign))))
     gl
 
 let unify ?(state=full_transparent_state) x y gl =
-  try 
-    let flags = 
-      {default_unify_flags with 
+  try
+    let flags =
+      {default_unify_flags with
 	modulo_delta = state;
 	modulo_conv_on_closed_terms = Some state}
     in
-    let evd = w_unify false (pf_env gl) Reduction.CONV 
+    let evd = w_unify false (pf_env gl) Reduction.CONV
       ~flags x y (Evd.create_evar_defs (project gl))
-    in tclEVARS (Evd.evars_of evd) gl
+    in tclEVARS evd gl
   with _ -> tclFAIL 0 (str"Not unifiable") gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index fb5c0efd..0e552bd4 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactics.mli 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
@@ -27,20 +27,14 @@ open Genarg
 open Tacexpr
 open Nametab
 open Rawterm
+open Pattern
 open Termops
 (*i*)
 
-val inj_open : constr -> open_constr
-val inj_red_expr : red_expr -> (open_constr, evaluable_global_reference) red_expr_gen
-val inj_ebindings : constr bindings -> open_constr bindings
-
 (* Main tactics. *)
 
 (*s General functions. *)
 
-val type_clenv_binding : goal sigma ->
-  constr * constr -> open_constr bindings  -> constr
-
 val string_of_inductive : constr -> string
 val head_constr       : constr -> constr * constr list
 val head_constr_bound : constr -> constr * constr list
@@ -56,19 +50,19 @@ val convert_concl   : constr -> cast_kind -> tactic
 val convert_hyp     : named_declaration -> tactic
 val thin            : identifier list -> tactic
 val mutual_fix      :
-  identifier -> int -> (identifier * int * constr) list -> tactic
+  identifier -> int -> (identifier * int * constr) list -> int -> tactic
 val fix             : identifier option -> int -> tactic
-val mutual_cofix    : identifier -> (identifier * constr) list -> tactic
+val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
 val cofix           : identifier option -> tactic
 
 (*s Introduction tactics. *)
 
+val fresh_id_in_env : identifier list -> identifier -> env -> identifier
 val fresh_id : identifier list -> identifier -> goal sigma -> identifier
 val find_intro_names : rel_context -> goal sigma -> identifier list
 
 val intro                : tactic
 val introf               : tactic
-val intro_force          : bool -> tactic
 val intro_move        : identifier option -> identifier move_location -> tactic
 
   (* [intro_avoiding idl] acts as intro but prevents the new identifier
@@ -106,9 +100,9 @@ val try_intros_until :
 (* Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
-val onInductionArg : 
-  (constr with_ebindings -> tactic) ->
-    constr with_ebindings induction_arg -> tactic
+val onInductionArg :
+  (constr with_bindings -> tactic) ->
+    constr with_bindings induction_arg -> tactic
 
 (*s Introduction tactics with eliminations. *)
 
@@ -130,35 +124,35 @@ val exact_proof      : Topconstr.constr_expr -> tactic
 type tactic_reduction = env -> evar_map -> constr -> constr
 
 val reduct_in_hyp     : tactic_reduction -> hyp_location -> tactic
-val reduct_option     : tactic_reduction * cast_kind -> simple_clause -> tactic
+val reduct_option     : tactic_reduction * cast_kind -> goal_location -> tactic
 val reduct_in_concl   : tactic_reduction * cast_kind -> tactic
-val change_in_concl   : (occurrences * constr) option -> constr -> tactic
-val change_in_hyp     : (occurrences * constr) option -> constr -> 
+val change_in_concl   : (occurrences * constr_pattern) option -> constr -> 
+                        tactic
+val change_in_hyp     : (occurrences * constr_pattern) option -> constr ->
                         hyp_location -> tactic
 val red_in_concl      : tactic
-val red_in_hyp        : hyp_location        -> tactic
-val red_option        : simple_clause -> 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        : simple_clause -> 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      : simple_clause -> 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  : simple_clause -> tactic
+val normalise_in_hyp  : hyp_location -> tactic
+val normalise_option  : goal_location -> tactic
 val normalise_vm_in_concl : tactic
 val unfold_in_concl   :
   (occurrences * evaluable_global_reference) list -> tactic
-val unfold_in_hyp     : 
+val unfold_in_hyp     :
   (occurrences * evaluable_global_reference) list -> hyp_location -> tactic
-val unfold_option     : 
-  (occurrences * evaluable_global_reference) list -> simple_clause
-    -> tactic
+val unfold_option     :
+  (occurrences * evaluable_global_reference) list -> goal_location -> tactic
 val change            :
-  (occurrences * constr) option -> constr -> clause -> tactic
-val pattern_option    : 
-  (occurrences * constr) list -> simple_clause -> tactic
+  constr_pattern option -> constr -> clause -> tactic
+val pattern_option    :
+  (occurrences * constr) list -> goal_location -> tactic
 val reduce            : red_expr -> clause -> tactic
 val unfold_constr     : global_reference -> tactic
 
@@ -168,7 +162,7 @@ val clear         : identifier list -> tactic
 val clear_body    : identifier list -> tactic
 val keep          : identifier list -> tactic
 
-val specialize    : int option -> constr with_ebindings -> tactic
+val specialize    : int option -> constr with_bindings -> tactic
 
 val move_hyp      : bool -> identifier -> identifier move_location -> tactic
 val rename_hyp    : (identifier * identifier) list -> tactic
@@ -181,32 +175,30 @@ val apply_type : constr -> constr list -> tactic
 val apply_term : constr -> constr list -> tactic
 val bring_hyps : named_context -> tactic
 
-val apply                 : constr      -> tactic
-val apply_without_reduce  : constr      -> tactic
-val apply_list            : constr list -> tactic
-  
-val apply_with_ebindings_gen : 
-  advanced_flag -> evars_flag -> open_constr with_ebindings list -> tactic
+val apply                 : constr -> tactic
+val eapply                : constr -> tactic
+
+val apply_with_bindings_gen :
+  advanced_flag -> evars_flag -> constr with_bindings located list -> tactic
 
 val apply_with_bindings   : constr with_bindings -> tactic
 val eapply_with_bindings  : constr with_bindings -> tactic
 
-val apply_with_ebindings  : open_constr with_ebindings -> tactic
-val eapply_with_ebindings : open_constr with_ebindings -> tactic
-
 val cut_and_apply         : constr -> tactic
 
-val apply_in : 
+val apply_in :
   advanced_flag -> evars_flag -> identifier -> 
-  open_constr with_ebindings list ->
-  intro_pattern_expr located option -> tactic
+    constr with_bindings located list ->
+    intro_pattern_expr located option -> tactic
+
+val simple_apply_in : identifier -> constr -> tactic
 
 (*s Elimination tactics. *)
 
 
 (*
    The general form of an induction principle is the following:
-   
+
    forall prm1 prm2 ... prmp,                          (induction parameters)
    forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates)
    branch1, branch2, ... , branchr,                    (branches of the principle)
@@ -229,66 +221,82 @@ val apply_in :
 
 (* [rel_contexts] and [rel_declaration] actually contain triples, and
    lists are actually in reverse order to fit [compose_prod]. *)
-type elim_scheme = { 
-  elimc: constr with_ebindings option;
+type elim_scheme = {
+  elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
+  index: int;              (* index of the elimination type in the scheme *)
   params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
   nparams: int;            (* number of parameters *)
   predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
   npredicates: int;        (* Number of predicates *)
   branches: rel_context;   (* branchr,...,branch1 *)
-  nbranches: int;          (* Number of branches *) 
+  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) 
+  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...) 
+  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_ebindings -> types -> elim_scheme
+val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme
 val rebuild_elimtype_from_scheme: elim_scheme -> types
 
+(* elim principle with the index of its inductive arg *)
+type eliminator = {
+  elimindex : int option;  (* None = find it automatically *)
+  elimbody : constr with_bindings
+}
+
+val elimination_clause_scheme : evars_flag ->
+  bool -> int -> clausenv -> clausenv -> tactic
+
+val elimination_in_clause_scheme : evars_flag -> identifier -> int ->
+  clausenv -> clausenv -> tactic
+
+val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) ->
+  'a -> eliminator -> tactic
+
 val general_elim  : evars_flag ->
-  constr with_ebindings -> constr with_ebindings -> ?allow_K:bool -> tactic
-val general_elim_in : evars_flag -> 
-  identifier -> constr with_ebindings -> constr with_ebindings -> tactic
+  constr with_bindings -> eliminator -> ?allow_K:bool -> tactic
+val general_elim_in : evars_flag ->
+  identifier -> constr with_bindings -> eliminator -> tactic
 
-val default_elim  : evars_flag -> constr with_ebindings -> tactic
+val default_elim  : evars_flag -> constr with_bindings -> tactic
 val simplest_elim : constr -> tactic
-val elim : 
-  evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic
+val elim :
+  evars_flag -> constr with_bindings -> constr with_bindings option -> tactic
 
 val simple_induct : quantified_hypothesis -> tactic
 
-val new_induct : evars_flag -> constr with_ebindings induction_arg list -> 
-  constr with_ebindings option -> 
-  intro_pattern_expr located option * intro_pattern_expr located option ->
-  clause option -> tactic
+val new_induct : evars_flag -> constr with_bindings induction_arg list ->
+  constr with_bindings option ->
+    intro_pattern_expr located option * intro_pattern_expr located option ->
+      clause option -> tactic
 
 (*s Case analysis tactics. *)
 
-val general_case_analysis : evars_flag -> constr with_ebindings ->  tactic
+val general_case_analysis : evars_flag -> constr with_bindings ->  tactic
 val simplest_case         : constr -> tactic
 
 val simple_destruct          : quantified_hypothesis -> tactic
-val new_destruct : evars_flag -> constr with_ebindings induction_arg list -> 
-  constr with_ebindings option -> 
-  intro_pattern_expr located option * intro_pattern_expr located option ->
-  clause option -> tactic
+val new_destruct : evars_flag -> constr with_bindings induction_arg list ->
+  constr with_bindings option ->
+    intro_pattern_expr located option * intro_pattern_expr located option ->
+      clause option -> tactic
 
 (*s Generic case analysis / induction tactics. *)
 
-val induction_destruct : evars_flag -> rec_flag -> 
-  (constr with_ebindings induction_arg list *
-   constr with_ebindings option *
-   (intro_pattern_expr located option * intro_pattern_expr located option) *
-   clause option) list ->
-    tactic
+val induction_destruct : rec_flag -> evars_flag ->
+  (constr with_bindings induction_arg list *
+  constr with_bindings option *
+  (intro_pattern_expr located option * intro_pattern_expr located option))
+  list *
+  clause option -> tactic
 
 (*s Eliminations giving the type instead of the proof. *)
 
@@ -307,18 +315,18 @@ val dorE : bool -> clause ->tactic
 
 (*s Introduction tactics. *)
 
-val constructor_tac      : evars_flag -> int option -> int -> 
-                           open_constr bindings  -> tactic
+val constructor_tac      : evars_flag -> int option -> int ->
+  constr bindings -> tactic
 val any_constructor      : evars_flag -> tactic option -> tactic
-val one_constructor      : int -> open_constr bindings  -> tactic
+val one_constructor      : int -> constr bindings  -> tactic
 
 val left                 : constr bindings -> tactic
 val right                : constr bindings -> tactic
 val split                : constr bindings -> tactic
 
-val left_with_ebindings  : evars_flag -> open_constr bindings -> tactic
-val right_with_ebindings : evars_flag -> open_constr bindings -> tactic
-val split_with_ebindings : evars_flag -> open_constr bindings -> tactic
+val left_with_bindings  : evars_flag -> constr bindings -> tactic
+val right_with_bindings : evars_flag -> constr bindings -> tactic
+val split_with_bindings : evars_flag -> constr bindings list -> tactic
 
 val simplest_left        : tactic
 val simplest_right       : tactic
@@ -327,31 +335,32 @@ val simplest_split       : tactic
 (*s Logical connective tactics. *)
 
 val register_setoid_reflexivity : tactic -> unit
-val reflexivity_red             : bool -> goal sigma -> tactic option
+val reflexivity_red             : bool -> tactic
 val reflexivity                 : tactic
 val intros_reflexivity          : tactic
 
 val register_setoid_symmetry : tactic -> unit
-val symmetry_red                : bool -> goal sigma -> tactic option
+val symmetry_red                : bool -> tactic
 val symmetry                    : tactic
 val register_setoid_symmetry_in : (identifier -> tactic) -> unit
 val symmetry_in                 : identifier -> tactic
 val intros_symmetry             : clause -> tactic
 
-val register_setoid_transitivity : (constr -> tactic) -> unit
-val transitivity_red            : bool -> constr -> goal sigma -> tactic option
+val register_setoid_transitivity : (constr option -> tactic) -> unit
+val transitivity_red            : bool -> constr option -> tactic
 val transitivity                : constr -> tactic
-val intros_transitivity         : constr -> tactic
+val etransitivity               : tactic
+val intros_transitivity         : constr option -> tactic
 
 val cut                         : constr -> tactic
 val cut_intro                   : constr -> tactic
-val cut_replacing               : 
-  identifier -> constr -> (tactic -> tactic) -> tactic
+val assert_replacing            : identifier -> types -> tactic -> tactic
+val cut_replacing               : identifier -> types -> tactic -> tactic
 val cut_in_parallel             : constr list -> tactic
 
 val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic
 val forward   : tactic option -> intro_pattern_expr located option -> constr -> tactic
-val letin_tac : (bool * intro_pattern_expr located) option -> name -> 
+val letin_tac : (bool * intro_pattern_expr located) option -> name ->
   constr -> types option -> clause -> tactic
 val assert_tac : name -> types -> tactic
 val assert_by  : name -> types -> tactic -> tactic
@@ -359,7 +368,7 @@ val pose_proof : name -> constr -> tactic
 
 val generalize      : constr list -> tactic
 val generalize_gen  : ((occurrences * constr) * name) list -> tactic
-val generalize_dep  : constr  -> tactic
+val generalize_dep  : ?with_let:bool (* Don't lose let bindings *) -> constr  -> tactic
 
 val unify           : ?state:Names.transparent_state -> constr -> constr -> tactic
 val resolve_classes : tactic
@@ -368,9 +377,8 @@ val tclABSTRACT : identifier option -> tactic -> tactic
 
 val admit_as_an_axiom : tactic
 
-val abstract_generalize : identifier -> ?generalize_vars:bool -> tactic
-
-val dependent_pattern : constr -> tactic
+val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> identifier -> tactic
+val specialize_eqs : identifier -> tactic
 
-val register_general_multi_rewrite : 
-  (bool -> evars_flag -> open_constr with_bindings -> clause -> tactic) -> unit
+val register_general_multi_rewrite :
+  (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
new file mode 100644
index 00000000..0a634138
--- /dev/null
+++ b/tactics/tactics.mllib
@@ -0,0 +1,23 @@
+Dn
+Termdn
+Btermdn
+Nbtermdn
+Tacticals
+Hipattern
+Ind_tables
+Eqschemes
+Elimschemes
+Tactics
+Hiddentac
+Elim
+Dhyp
+Auto
+Equality
+Contradiction
+Inv
+Leminv
+Tacinterp
+Evar_tactics
+Autorewrite
+Decl_interp
+Decl_proof_instr
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index d3e7da6a..3e7266d7 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: tauto.ml4 12955 2010-04-20 08:10:14Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Term
 open Hipattern
@@ -24,7 +24,7 @@ open Genarg
 
 let assoc_var s ist =
   match List.assoc (Names.id_of_string s) ist.lfun with
-    | VConstr c -> c
+    | VConstr ([],c) -> c
     | _ -> failwith "tauto: anomaly"
 
 (** Parametrization of tauto *)
@@ -46,6 +46,19 @@ let strict_in_hyp_and_ccl = false
 (* Whether unit type includes equality types *)
 let strict_unit = false
 
+(* 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;
+      optname  = "unfolding of iff and not in intuition";
+      optkey   = ["Intuition";"Iff";"Unfolding"];
+      optread  = (fun () -> !iff_unfolding);
+      optwrite = (:=) iff_unfolding }
 
 (** Test *)
 
@@ -67,7 +80,7 @@ let is_unit_or_eq ist =
 let is_record t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-      | Ind ind  -> 
+      | Ind ind  ->
           let (mib,mip) = Global.lookup_inductive ind in
 	    mib.Declarations.mind_record
       | _ -> false
@@ -76,13 +89,13 @@ let is_binary t =
   isApp t &&
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-    | Ind ind  -> 
+    | Ind ind  ->
         let (mib,mip) = Global.lookup_inductive ind in
 	  mib.Declarations.mind_nparams = 2
     | _ -> false
 
 let iter_tac tacl =
-  List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl 
+  List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl
 
 (** Dealing with conjunction *)
 
@@ -102,17 +115,17 @@ let flatten_contravariant_conj ist =
   match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with
   | Some (_,args) ->
       let i = List.length args in
-      if not binary_mode || i = 2 then 
-	let newtyp = valueIn (VConstr (List.fold_right mkArrow args c)) in
-        let hyp = valueIn (VConstr hyp) in
+      if not binary_mode || i = 2 then
+	let newtyp = valueIn (VConstr ([],List.fold_right mkArrow args c)) in
+	let hyp = valueIn (VConstr ([],hyp)) in
 	let intros =
-	  iter_tac (List.map (fun _ -> <:tactic< intro >>) args) 
+	  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
+	  assert newtyp by ($intros; apply hyp; split; assumption);
+	  clear hyp
 	>>
       else
 	<:tactic<fail>>
@@ -137,15 +150,15 @@ let flatten_contravariant_disj ist =
   match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with
   | Some (_,args) ->
       let i = List.length args in
-      if not binary_mode || i = 2 then 
-	let hyp = valueIn (VConstr hyp) in
+      if not binary_mode || i = 2 then
+	let hyp = valueIn (VConstr ([],hyp)) in
 	iter_tac (list_map_i (fun i arg ->
-	  let typ = valueIn (VConstr (mkArrow arg c)) in
-	  <:tactic< 
+	  let typ = valueIn (VConstr ([],mkArrow arg c)) in
+	  <:tactic<
             let typ := $typ in
             let hyp := $hyp in
-            assert typ by (intro; apply hyp; constructor $i; assumption)
-          >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
+	    assert typ by (intro; apply hyp; constructor $i; assumption)
+	  >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
       else
 	<:tactic<fail>>
   | _ ->
@@ -162,7 +175,7 @@ let not_dep_intros ist =
   | H:(Coq.Init.Logic.not _)|-_    => unfold Coq.Init.Logic.not at 1 in H
   | H:(Coq.Init.Logic.not _)->_|-_    => unfold Coq.Init.Logic.not at 1 in H
   end >>
-				      
+
 let axioms ist =
   let t_is_unit_or_eq = tacticIn is_unit_or_eq
   and t_is_empty = tacticIn is_empty in
@@ -187,8 +200,9 @@ let simplif ist =
        (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: ?X1-> ?X2, id1: ?X1|- _ =>
+        | id0: ?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. *)
@@ -208,9 +222,10 @@ let simplif ist =
             clear id
         | id: ?X1 -> ?X2|- _ =>
           $t_flatten_contravariant_disj
-	  (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2|-" and "?B->?X2|-" *)
+	  (* 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) >>
 
@@ -223,9 +238,9 @@ let rec tauto_intuit t_reduce solver ist =
   <:tactic<
    ($t_simplif;$t_axioms
    || match reverse goal with
-      | id:(?X1-> ?X2)-> ?X3|- _ =>
+      | id:(?X1 -> ?X2)-> ?X3|- _ =>
 	  cut X3;
-	    [ intro; clear id; $t_tauto_intuit 
+	    [ intro; clear id; $t_tauto_intuit
 	    | cut (X1 -> X2);
 		[ exact id
 		| generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id;
@@ -242,22 +257,42 @@ let rec tauto_intuit t_reduce solver ist =
     $t_solver
    ) >>
 
-let reduction_not_iff _ist =
- <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
+let reduction_not _ist =
+  if unfold_iff () then
+    <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
+  else
+    <:tactic< unfold Coq.Init.Logic.not in * >>
 
-let t_reduction_not_iff = tacticIn reduction_not_iff
+let t_reduction_not = tacticIn reduction_not
 
 let intuition_gen tac =
-  interp (tacticIn (tauto_intuit t_reduction_not_iff tac))
+  interp (tacticIn (tauto_intuit t_reduction_not tac))
 
 let simplif_gen = interp (tacticIn simplif)
 
-let tauto g =
+let tauto_intuitionistic g =
   try intuition_gen <:tactic<fail>> g
   with
     Refiner.FailError _ | UserError _ ->
       errorlabstrm "tauto" (str "tauto failed.")
 
+let coq_nnpp_path =
+  let dir = List.map id_of_string ["Classical_Prop";"Logic";"Coq"] in
+  Libnames.make_path (make_dirpath dir) (id_of_string "NNPP")
+
+let tauto_classical nnpp g =
+  try tclTHEN (apply nnpp) tauto_intuitionistic g
+  with UserError _ -> errorlabstrm "tauto" (str "Classical tauto failed.")
+
+let tauto g =
+  try
+    let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in
+    (* try intuitionistic version first to avoid an axiom if possible *)
+    tclORELSE tauto_intuitionistic (tauto_classical nnpp) g
+  with Not_found ->
+    tauto_intuitionistic g
+
+
 let default_intuition_tac = <:tactic< auto with * >>
 
 TACTIC EXTEND tauto
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
index bd439fb4..7b6d3ea7 100644
--- a/tactics/termdn.ml
+++ b/tactics/termdn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termdn.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -20,25 +20,60 @@ open Nametab
 (* Discrimination nets of terms.
    See the module dn.ml for further explanations.
    Eduardo (5/8/97) *)
+module Make =
+  functor (Z : Map.OrderedType) ->
+struct
 
-type 'a t = (global_reference,constr_pattern,'a) Dn.t
+  module X = struct
+    type t = constr_pattern
+    let compare = Pervasives.compare
+  end
+
+  type term_label = 
+    | GRLabel of global_reference
+    | ProdLabel 
+    | LambdaLabel
+    | SortLabel of sorts option
+	
+  module Y =  struct 
+     type t = term_label
+        let compare x y = 
+       let make_name n =
+	 match n with
+	 | GRLabel(ConstRef con) -> 
+	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
+	 | GRLabel(IndRef (kn,i)) ->
+	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
+	 | GRLabel(ConstructRef ((kn,i),j ))->
+	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
+	 | k -> k
+       in
+	 Pervasives.compare (make_name x) (make_name y)
+  end
+       
+      
+  module Dn = Dn.Make(X)(Y)(Z)
+      
+  type t = Dn.t
+
+  type 'a lookup_res = 'a Dn.lookup_res
 
 (*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
 
-let decomp = 
+let decomp =
   let rec decrec acc c = match kind_of_term c with
     | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
     | Cast (c1,_,_) -> decrec acc c1
     | _ -> (c,acc)
-  in 
+  in
   decrec []
 
-let decomp_pat = 
+let decomp_pat =
   let rec decrec acc = function
     | PApp (f,args) -> decrec (Array.to_list args @ acc) f
     | c -> (c,acc)
-  in 
-  decrec []   
+  in
+  decrec []
 
 let constr_pat_discr t =
   if not (occur_meta_pattern t) then
@@ -46,49 +81,63 @@ let constr_pat_discr t =
   else
     match decomp_pat t with
     | PRef ((IndRef _) as ref), args
-    | PRef ((ConstructRef _ ) as ref), args -> Some (ref,args)
-    | PRef ((VarRef v) as ref), args -> Some(ref,args)
+    | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+    | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
     | _ -> None
 
 let constr_pat_discr_st (idpred,cpred) t =
   match decomp_pat t with
   | PRef ((IndRef _) as ref), args
-  | PRef ((ConstructRef _ ) as ref), args -> Some (ref,args)
-  | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) -> 
-      Some(ref,args)
+  | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+  | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) ->
+      Some(GRLabel ref,args)
   | PVar v, args when not (Idpred.mem v idpred) ->
-      Some(VarRef v,args)
+      Some(GRLabel (VarRef v),args)
   | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
-      Some (ref, args)
+      Some (GRLabel ref, args)
+  | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
+  | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l)
+  | PSort s, [] -> 
+      let s' = match s with
+	| RProp c -> Some (Prop c)
+	| RType _ -> None 
+	    (* Don't try to be clever about type levels here *)
+      in Some (SortLabel s', [])
   | _ -> None
 
 open Dn
 
-let constr_val_discr t =  
+let constr_val_discr t =
   let c, l = decomp t in
     match kind_of_term c with
-    | Ind ind_sp -> Label(IndRef ind_sp,l)
-    | Construct cstr_sp -> Label((ConstructRef cstr_sp),l)
-    | Var id -> Label(VarRef id,l)
+    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id -> Label(GRLabel (VarRef id),l)
     | Const _ -> Everything
     | _ -> Nothing
-	
-let constr_val_discr_st (idpred,cpred) t =  
+
+let constr_val_discr_st (idpred,cpred) t =
   let c, l = decomp t in
     match kind_of_term c with
-    | Const c -> if Cpred.mem c cpred then Everything else Label(ConstRef c,l)
-    | Ind ind_sp -> Label(IndRef ind_sp,l)
-    | Construct cstr_sp -> Label((ConstructRef cstr_sp),l)
-    | Var id when not (Idpred.mem id idpred) -> Label(VarRef id,l)
+    | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
+    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l)
+    | Prod (n, d, c) -> Label(ProdLabel, [d; c])
+    | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
+    | Sort s when is_small s -> Label(SortLabel (Some s), [])
+    | Sort _ -> Label (SortLabel None, [])
     | Evar _ -> Everything
     | _ -> Nothing
 
-let create = Dn.create 
+let create = Dn.create
 
 let add dn st = Dn.add dn (constr_pat_discr_st st)
 
 let rmv dn st = Dn.rmv dn (constr_pat_discr_st st)
 
 let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t
-  
+
 let app f dn = Dn.app f dn
+
+end
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
index 79efd8eb..aea49b07 100644
--- a/tactics/termdn.mli
+++ b/tactics/termdn.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termdn.mli 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Term
@@ -14,7 +14,7 @@ open Pattern
 open Libnames
 open Names
 (*i*)
-  
+
 (* Discrimination nets of terms. *)
 
 (* This module registers actions (typically tactics) mapped to patterns *)
@@ -23,37 +23,50 @@ open Names
 order in such a way patterns having the same prefix have this common
 prefix shared and the seek for the action associated to the patterns
 that a term matches are found in time proportional to the maximal
-number of nodes of the patterns matching the term. The [transparent_state] 
+number of nodes of the patterns matching the term. The [transparent_state]
 indicates which constants and variables can be considered as rigid.
 These dnets are able to cope with existential variables as well, which match
 [Everything]. *)
 
-type 'a t
-
-val create : unit -> 'a t
-
-(* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
-
-val add : 'a t -> transparent_state -> (constr_pattern * 'a) -> 'a t
-
-val rmv : 'a t -> transparent_state -> (constr_pattern * 'a) -> 'a t
-
-(* [lookup t c] looks for patterns (with their action) matching term [c] *)
-
-val lookup : 'a t -> transparent_state -> constr -> (constr_pattern * 'a) list
-
-val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
-
-
-(*i*)
-(* These are for Nbtermdn *)
-
-val constr_pat_discr_st : transparent_state ->
-  constr_pattern -> (global_reference * constr_pattern list) option
-val constr_val_discr_st : transparent_state ->
-  constr -> (global_reference * constr list) Dn.lookup_res
-
-val constr_pat_discr : constr_pattern -> (global_reference * constr_pattern list) option
-val constr_val_discr : constr -> (global_reference * constr list) Dn.lookup_res
-
+module Make :
+  functor (Z : Map.OrderedType) ->
+sig
+  
+  type t
+    
+  type 'a lookup_res
+    
+  val create : unit -> t
+    
+  (* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
+    
+  val add : t -> transparent_state -> (constr_pattern * Z.t) -> t
+    
+  val rmv : t -> transparent_state -> (constr_pattern * Z.t) -> t
+    
+  (* [lookup t c] looks for patterns (with their action) matching term [c] *)
+    
+  val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list
+    
+  val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
+
+    
+  (*i*)
+  (* These are for Nbtermdn *)
+ 
+  type term_label = 
+    | GRLabel of global_reference
+    | ProdLabel 
+    | LambdaLabel
+    | SortLabel of sorts option
+	
+  val constr_pat_discr_st : transparent_state ->
+    constr_pattern -> (term_label * constr_pattern list) option
+  val constr_val_discr_st : transparent_state ->
+    constr -> (term_label * constr list) lookup_res
+    
+  val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option
+  val constr_val_discr : constr -> (term_label * constr list) lookup_res
+    
 (*i*)
+end
diff --git a/test-suite/Makefile b/test-suite/Makefile
new file mode 100644
index 00000000..2503368f
--- /dev/null
+++ b/test-suite/Makefile
@@ -0,0 +1,373 @@
+#######################################################################
+#  v      #   The Coq Proof Assistant  /  The Coq Development Team    #
+# <O___,, #     INRIA-Rocquencourt  &  CNRS-Universite Paris Diderot  #
+#   \VV/  #############################################################
+#    //   #      This file is distributed under the terms of the      #
+#         #       GNU Lesser General Public License Version 2.1       #
+#######################################################################
+
+# This is a standalone Makefile to run the test-suite. It can be used
+# outside of the Coq source tree (if BIN is overridden).
+
+# There is one %.v.log target per %.v test file. The target will be
+# filled with the output, timings and status of the test. There is
+# also one target per directory containing %.v files, that runs all
+# the tests in it. As convenience, there is also the "bugs" target
+# that runs all bug-related tests.
+
+# The "summary" target outputs a summary of all tests that were run
+# (but doesn't run them)
+
+# The "run" target runs all tests that have not been run yet. To force
+# all tests to be run, use the "clean" target.
+
+#######################################################################
+# Variables
+#######################################################################
+
+# Default value when called from a freshly compiled Coq, but can be
+# easily overridden
+BIN := ../bin/
+LIB := ..
+
+ifeq ($(BEST),byte)
+  coqtop := $(BIN)coqtop.byte -boot -q -batch -I prerequisite
+  bincoqc := $(BIN)coqc -coqlib $(LIB) -byte -I prerequisite
+else
+  coqtop := $(BIN)coqtop -boot -q -batch -I prerequisite
+  bincoqc := $(BIN)coqc -coqlib $(LIB) -I prerequisite
+endif
+
+command := $(coqtop) -top Top -load-vernac-source
+coqc := $(coqtop) -compile
+
+SHOW := $(if $(VERBOSE),@true,@echo)
+HIDE := $(if $(VERBOSE),,@)
+REDIR := $(if $(VERBOSE),,> /dev/null 2>&1)
+
+ifneq (,$(wildcard /proc/cpuinfo))
+  sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc
+  sedbogo += -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" # sparc
+  sedbogo += -e "s/BogoMIPS.*: \([0-9]*\).*/\1/p" # alpha
+  bogomips := $(shell sed -n $(sedbogo) /proc/cpuinfo | head -1)
+endif
+
+ifeq (,$(bogomips))
+  $(warning cannot run complexity tests (no bogomips found))
+endif
+
+log_success = "==========> SUCCESS <=========="
+log_failure = "==========> FAILURE <=========="
+log_intro = "==========> TESTING $(1) <=========="
+
+#######################################################################
+# Testing subsystems
+#######################################################################
+
+# Apart so that it can be easily skipped with overriding
+COMPLEXITY := $(if $(bogomips),complexity)
+
+BUGS := bugs/opened/shouldnotfail bugs/opened/shouldnotsucceed \
+  bugs/closed/shouldsucceed bugs/closed/shouldfail
+
+VSUBSYSTEMS := prerequisite success failure $(BUGS) output \
+  interactive micromega $(COMPLEXITY) modules
+
+# All subsystems
+SUBSYSTEMS := $(VSUBSYSTEMS) xml bugs
+
+#######################################################################
+# Phony targets
+#######################################################################
+
+.DELETE_ON_ERROR:
+.PHONY: all run clean $(SUBSYSTEMS)
+
+all: run
+	$(MAKE) --quiet summary.log
+
+run: $(SUBSYSTEMS)
+bugs: $(BUGS)
+
+clean:
+	rm -f trace lia.cache
+	$(SHOW) "RM        <**/*.stamp> <**/*.vo> <**/*.log>"
+	$(HIDE)find . \( \
+	  -name '*.stamp' -o -name '*.vo' -o -name '*.v.log' \
+	\) -print0 | xargs -0 rm -f
+
+distclean: clean
+	$(HIDE)find . -name '*.log' -print0 | xargs -0 rm -f
+
+#######################################################################
+# Per-subsystem targets
+#######################################################################
+
+define mkstamp
+$(1): $(1).stamp ; @true
+$(1).stamp: $(patsubst %.v,%.v.log,$(wildcard $(1)/*.v)) ; \
+	$(HIDE)touch $$@
+endef
+$(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S))))
+
+#######################################################################
+# Summary
+#######################################################################
+
+summary_one = echo $(1); if [ -f $(2).log ]; then tail -n1 $(2).log; fi | sort -g
+summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 tail -q -n1 | sort -g
+
+.PHONY: summary summary.log
+
+summary:
+	@{ \
+	  $(call summary_dir, "Preparing tests", prerequisite); \
+	  $(call summary_dir, "Success tests", success); \
+	  $(call summary_dir, "Failure tests", failure); \
+	  $(call summary_dir, "Bugs tests", bugs); \
+	  $(call summary_dir, "Output tests", output); \
+	  $(call summary_dir, "Interactive tests", interactive); \
+	  $(call summary_dir, "Micromega tests", micromega); \
+	  $(call summary_one, "Miscellaneous tests", xml); \
+	  $(call summary_dir, "Complexity tests", complexity); \
+	  $(call summary_dir, "Module tests", modules); \
+	  nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \
+	  nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \
+	  nb_tests=`expr $$nb_success + $$nb_failure`; \
+	  pourcentage=`expr 100 \* $$nb_success / $$nb_tests`; \
+	  echo; \
+	  echo "$$nb_success tests passed over $$nb_tests, i.e. $$pourcentage %"; \
+	}
+
+summary.log:
+	$(SHOW) SUMMARY
+	$(HIDE)$(MAKE) --quiet summary > "$@"
+
+#######################################################################
+# Regression (and progression) tests
+#######################################################################
+
+# Process verifications concerning submitted bugs. A message is
+# printed for all opened bugs (still active or seems to be closed).
+# For closed bugs that behave as expected, no message is printed
+
+# All files are assumed to have <# of the bug>.v as a name
+
+# Opened bugs that should not succeed (FIXME: there were no such tests
+# at the time of writing this Makefile, but the possibility was in the
+# original shellscript... so left it here, but untested)
+$(addsuffix .log,$(wildcard bugs/opened/shouldnotsucceed/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  $(call test_intro,$<); \
+	  $(command) "$<" 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...still active"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (bug seems to be closed, please check)";
+	  fi;
+	} > "$@"
+
+# Opened bugs that should not fail
+$(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" 2>&1; R=$$?; times; \
+	  if [ $$R != 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...still active"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (bug seems to be closed, please check)"; \
+	  fi; \
+	} > "$@"
+
+# Closed bugs that should succeed
+$(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (bug seems to be opened, please check)"; \
+	  fi; \
+	} > "$@"
+
+# Closed bugs that should fail
+$(addsuffix .log,$(wildcard bugs/closed/shouldfail/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" 2>&1; R=$$?; times; \
+	  if [ $$R != 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (bug seems to be opened, please check)"; \
+	  fi; \
+	} > "$@"
+
+#######################################################################
+# Other generic tests
+#######################################################################
+
+$(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(coqc) "$*" 2>&1; R=$$?; times; \
+	  if [ $$R != 0 ]; then \
+	    echo $(log_failure); \
+	    echo "    $<...could not be prepared" ; \
+	  else \
+	    echo $(log_success); \
+	    echo "    $<...correctly prepared" ; \
+	  fi; \
+	} > "$@"
+
+$(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  opts="$(if $(findstring modules/,$<),-I modules -impredicative-set)"; \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" $$opts 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (should be accepted)"; \
+	  fi; \
+	} > "$@"
+
+$(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" 2>&1; R=$$?; times; \
+	  if [ $$R != 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (should be rejected)"; \
+	  fi; \
+	} > "$@"
+
+$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \
+	  $(command) "$<" 2>&1 \
+	    | grep -v "Welcome to Coq" \
+	    | grep -v "Skipping rcfile loading" \
+	    > $$tmpoutput; \
+	  diff $$tmpoutput $*.out 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (unexpected output)"; \
+	  fi; \
+	  rm $$tmpoutput; \
+	} > "$@"
+
+$(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(coqtop) < "$<" 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (should be accepted)"; \
+	  fi; \
+	} > "$@"
+
+# Complexity test. Expects a line "(* Expected time < XXX.YYs *)" in
+# 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
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  true "extract effective user time"; \
+	  res=`$(command) "$<" 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \
+	  R=$$?; times; \
+	  if [ $$R != 0 ]; then \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (should be accepted)" ; \
+	  elif [ "$$res" = "" ]; then \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (couldn't find a time measure)"; \
+	  else \
+	    true "express effective time in centiseconds"; \
+	    res=`echo "$$res"00 | sed -n -e "s/\([0-9]*\)\.\([0-9][0-9]\).*/\1\2/p"`; \
+	    true "find expected time * 100"; \
+	    exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" "$<"`; \
+	    ok=`expr \( $$res \* $(bogomips) \) "<" \( $$exp \* 6120 \)`; \
+	    if [ "$$ok" = 1 ]; then \
+	      echo $(log_success); \
+	      echo "    $<...Ok"; \
+	    else \
+	      echo $(log_failure); \
+	      echo "    $<...Error! (should run faster)"; \
+	    fi; \
+	  fi; \
+	} > "$@"
+endif
+
+# Ideal-features tests
+$(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" 2>&1; R=$$?; times; \
+	  if [ $$R != 0 ]; then \
+	      echo $(log_success); \
+	      echo "    $<...still wished"; \
+          else \
+	      echo $(log_failure); \
+	      echo "    $<...Good news! (wish seems to be granted, please check)"; \
+          fi; \
+	} > "$@"
+
+# Additionnal dependencies for module tests
+$(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo
+%.vo: %.v
+	$(HIDE)$(coqtop) -compile $*
+
+#######################################################################
+# Miscellaneous tests
+#######################################################################
+
+# Test xml compilation
+xml: xml.log
+xml.log:
+	@echo "TEST      xml"
+	$(HIDE){ \
+	  echo $(call log_intro,xml); \
+	  rm -rf misc/xml; \
+	  COQ_XML_LIBRARY_ROOT=misc/xml \
+	  $(bincoqc) -xml misc/berardi_test 2>&1; times; \
+	  if [ ! -d misc/xml ]; then \
+	    echo $(log_failure); \
+	    echo "    xml... failed"; \
+	  else \
+	    echo $(log_success); \
+	    echo "    xml...apparently ok"; \
+	  fi; rm -r misc/xml; \
+	} > "$@"
diff --git a/test-suite/bugs/closed/1519.v b/test-suite/bugs/closed/1519.v
index 98e3e214..de60de59 100644
--- a/test-suite/bugs/closed/1519.v
+++ b/test-suite/bugs/closed/1519.v
@@ -2,7 +2,7 @@ Section S.
 
   Variable A:Prop.
   Variable W:A.
-  
+
   Remark T: A -> A.
     intro Z.
     rename W into Z_.
diff --git a/test-suite/bugs/closed/1780.v b/test-suite/bugs/closed/1780.v
index 3929fbae..ade4462a 100644
--- a/test-suite/bugs/closed/1780.v
+++ b/test-suite/bugs/closed/1780.v
@@ -1,12 +1,12 @@
 
 Definition bug := Eval vm_compute in eq_rect.
 (* bug:
-Error: Illegal application (Type Error): 
+Error: Illegal application (Type Error):
 The term "eq" of type "forall A : Type, A -> A -> Prop"
 cannot be applied to the terms
  "x" : "A"
  "P" : "A -> Type"
  "x0" : "A"
-The 1st term has type "A" which should be coercible to 
+The 1st term has type "A" which should be coercible to
 "Type".
 *)
diff --git a/test-suite/bugs/closed/shouldfail/2006.v b/test-suite/bugs/closed/shouldfail/2006.v
new file mode 100644
index 00000000..91a16f95
--- /dev/null
+++ b/test-suite/bugs/closed/shouldfail/2006.v
@@ -0,0 +1,23 @@
+(* Take the type constraint on Record into account *)
+
+Definition Type1 := Type.
+Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *)
+
+(*
+Remarks:
+
+- The behaviour was inconsistent with the one of Inductive, e.g.
+
+  Inductive R : Type1 := Build_R : Type1 -> R.
+
+  was correctly refused.
+
+- CoRN makes some use of the following configuration:
+
+  Definition CProp := Type.
+  Record R : CProp := { ... }.
+
+  CoRN may have to change the CProp definition into a notation if the
+  preservation of the former semantics of Record type constraints
+  turns to be required.
+*)
diff --git a/test-suite/bugs/closed/shouldfail/2251.v b/test-suite/bugs/closed/shouldfail/2251.v
new file mode 100644
index 00000000..642717f4
--- /dev/null
+++ b/test-suite/bugs/closed/shouldfail/2251.v
@@ -0,0 +1,5 @@
+(* Check that rewrite does not apply to single evars *)
+
+Lemma evar_rewrite : (forall a : nat, a = 0 -> True) -> True.
+intros; eapply H.  (* goal is  ?30 = nil  *)
+rewrite plus_n_Sm.
diff --git a/test-suite/bugs/closed/shouldsucceed/1100.v b/test-suite/bugs/closed/shouldsucceed/1100.v
index 6d619c74..32c78b4b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1100.v
+++ b/test-suite/bugs/closed/shouldsucceed/1100.v
@@ -6,7 +6,7 @@ Parameter PQ : forall n, P n <-> Q n.
 
 Lemma PQ2 : forall n, P n -> Q n.
   intros.
-  rewrite PQ in H. 
+  rewrite PQ in H.
   trivial.
 Qed.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1322.v b/test-suite/bugs/closed/shouldsucceed/1322.v
index 7e21aa7c..1ec7d452 100644
--- a/test-suite/bugs/closed/shouldsucceed/1322.v
+++ b/test-suite/bugs/closed/shouldsucceed/1322.v
@@ -7,7 +7,7 @@ Variable I_eq :I -> I -> Prop.
 Variable I_eq_equiv : Setoid_Theory I I_eq.
 
 (* Add Relation I I_eq
-  reflexivity proved by I_eq_equiv.(Seq_refl I I_eq) 
+  reflexivity proved by I_eq_equiv.(Seq_refl I I_eq)
   symmetry proved by I_eq_equiv.(Seq_sym I I_eq)
   transitivity proved by I_eq_equiv.(Seq_trans I I_eq)
 as I_eq_relation. *)
diff --git a/test-suite/bugs/closed/shouldsucceed/1411.v b/test-suite/bugs/closed/shouldsucceed/1411.v
index e330d46f..a1a7b288 100644
--- a/test-suite/bugs/closed/shouldsucceed/1411.v
+++ b/test-suite/bugs/closed/shouldsucceed/1411.v
@@ -23,7 +23,7 @@ Program Fixpoint fetch t p (x:Exact t p) {struct t} :=
    match t, p with
    | No p' , nil      => p'
    | No p' , _::_     => unreachable nat _
-   | Br l r, nil      => unreachable nat _ 
+   | Br l r, nil      => unreachable nat _
    | Br l r, true::t  => fetch l t _
    | Br l r, false::t => fetch r t _
    end.
diff --git a/test-suite/bugs/closed/shouldsucceed/1414.v b/test-suite/bugs/closed/shouldsucceed/1414.v
index d3c00808..495a16bc 100644
--- a/test-suite/bugs/closed/shouldsucceed/1414.v
+++ b/test-suite/bugs/closed/shouldsucceed/1414.v
@@ -7,8 +7,8 @@ Inductive t : Set :=
   | Node : t -> data -> t -> Z -> t.
 
 Parameter avl : t -> Prop.
-Parameter bst : t -> Prop. 
-Parameter In : data -> t -> Prop. 
+Parameter bst : t -> Prop.
+Parameter In : data -> t -> Prop.
 Parameter cardinal : t -> nat.
 Definition card2 (s:t*t) := let (s1,s2) := s in cardinal s1 + cardinal s2.
 
@@ -16,26 +16,25 @@ Parameter split : data -> t -> t*(bool*t).
 Parameter join : t -> data -> t -> t.
 Parameter add : data -> t -> t.
 
-Program Fixpoint union 
-  (s:t*t)
-  (hb1: bst (fst s))(ha1: avl (fst s))(hb2: bst (snd s))(hb2: avl (snd s)) 
-  { measure card2 s } : 
-  {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x (fst s) \/ In x (snd
-s)} := 
-  match s with 
-    | (Leaf,t2) => t2
-    | (t1,Leaf) => t1
-    | (Node l1 v1 r1 h1, Node l2 v2 r2 h2) =>        
+Program Fixpoint union
+  (s u:t)
+  (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u)
+  { measure (cardinal s + cardinal u) } :
+  {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} :=
+  match s, u with
+    | Leaf,t2 => t2
+    | t1,Leaf => t1
+    | Node l1 v1 r1 h1, Node l2 v2 r2 h2 =>
         if (Z_ge_lt_dec h1 h2) then
-          if (Z_eq_dec h2 1) 
-          then add v2 (fst s)
+          if (Z_eq_dec h2 1)
+          then add v2 s
           else
-            let (l2', r2') := split v1 (snd s) in
-            join (union (l1,l2') _ _ _ _) v1 (union (r1,snd r2') _ _ _ _)
+            let (l2', r2') := split v1 u in
+            join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _)
         else
-          if (Z_eq_dec h1 1) 
-          then add v1 (snd s) 
+          if (Z_eq_dec h1 1)
+          then add v1 s
           else
-            let (l1', r1') := split v2 (fst s) in
-            join (union (l1',l2) _ _ _ _) v2 (union (snd r1',r2) _ _ _ _)
-  end. 
+            let (l1', r1') := split v2 u in
+            join (union l1' l2 _ _ _ _) v2 (union (snd r1') r2 _ _ _ _)
+  end.
diff --git a/test-suite/bugs/opened/shouldnotfail/1416.v b/test-suite/bugs/closed/shouldsucceed/1416.v
index c6f4302d..da67d9b0 100644
--- a/test-suite/bugs/opened/shouldnotfail/1416.v
+++ b/test-suite/bugs/closed/shouldsucceed/1416.v
@@ -4,12 +4,12 @@ Record Place (Env A: Type) : Type := {
   read: Env -> A ;
   write: Env -> A -> Env ;
   write_read: forall (e:Env), (write e (read e))=e
-}. 
+}.
 
 Hint Rewrite -> write_read: placeeq.
 
 Record sumPl (Env A B: Type) (vL:(Place Env A)) (vR:(Place Env B)) : Type :=
- { 
+ {
    mkEnv: A -> B -> Env ;
    mkEnv2writeL: forall (e:Env) (x:A), (mkEnv x (read vR e))=(write vL e x)
  }.
diff --git a/test-suite/bugs/closed/shouldsucceed/1425.v b/test-suite/bugs/closed/shouldsucceed/1425.v
index 8e26209a..6be30174 100644
--- a/test-suite/bugs/closed/shouldsucceed/1425.v
+++ b/test-suite/bugs/closed/shouldsucceed/1425.v
@@ -1,4 +1,4 @@
-Require Import Setoid. 
+Require Import Setoid.
 
 Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1446.v b/test-suite/bugs/closed/shouldsucceed/1446.v
index d4e7cea8..8cb2d653 100644
--- a/test-suite/bugs/closed/shouldsucceed/1446.v
+++ b/test-suite/bugs/closed/shouldsucceed/1446.v
@@ -1,8 +1,8 @@
 Lemma not_true_eq_false : forall (b:bool), b <> true -> b = false.
 Proof.
- destruct b;intros;trivial. 
- elim H. 
- exact (refl_equal true). 
+ destruct b;intros;trivial.
+ elim H.
+ exact (refl_equal true).
 Qed.
 
 Section BUG.
@@ -13,7 +13,7 @@ Section BUG.
  Hypothesis H1 : b <> true.
 
  Goal False.
-  rewrite (not_true_eq_false _ H) in * |-. 
+  rewrite (not_true_eq_false _ H) in * |-.
   contradiction.
  Qed.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/shouldsucceed/1507.v
index b484c7dc..f1872a2b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1507.v
+++ b/test-suite/bugs/closed/shouldsucceed/1507.v
@@ -2,16 +2,16 @@
    Implementing reals a la Stolzenberg
 
    Danko Ilik, March 2007
-   svn revision: $Id: 1507.v 10068 2007-08-10 12:06:59Z notin $
+   svn revision: $Id$
 
    XField.v -- (unfinished) axiomatisation of the theories of real and
                rational intervals.
 *)
 
-Definition associative (A:Type)(op:A->A->A) := 
+Definition associative (A:Type)(op:A->A->A) :=
   forall x y z:A, op (op x y) z = op x (op y z).
 
-Definition commutative (A:Type)(op:A->A->A) := 
+Definition commutative (A:Type)(op:A->A->A) :=
   forall x y:A, op x y = op y x.
 
 Definition trichotomous (A:Type)(R:A->A->Prop) :=
@@ -19,7 +19,7 @@ Definition trichotomous (A:Type)(R:A->A->Prop) :=
 
 Definition relation (A:Type) := A -> A -> Prop.
 Definition reflexive (A:Type)(R:relation A) := forall x:A, R x x.
-Definition transitive (A:Type)(R:relation A) := 
+Definition transitive (A:Type)(R:relation A) :=
   forall x y z:A, R x y -> R y z -> R x z.
 Definition symmetric (A:Type)(R:relation A) := forall x y:A, R x y -> R y x.
 
@@ -52,7 +52,7 @@ Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake {
   Iplus_opp_r    : forall x:Icar, Ic (Iplus x (Iopp x)) (Izero);
   Imult_inv_r    : forall x:Icar, ~(Ic x Izero) -> Ic (Imult x (Iinv x)) Ione;
   (* distributive laws *)
-  Imult_plus_distr_l : forall x x' y y' z z' z'', 
+  Imult_plus_distr_l : forall x x' y y' z z' z'',
     Ic x x' -> Ic y y' -> Ic z z' -> Ic z z'' ->
     Ic (Imult (Iplus x y) z) (Iplus (Imult x' z') (Imult y' z''));
   (* order and lattice structure *)
@@ -70,7 +70,7 @@ Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake {
   Ic_sym    : symmetric _ Ic
 }.
 
-Definition interval_set (X:Set)(le:X->X->Prop) := 
+Definition interval_set (X:Set)(le:X->X->Prop) :=
   (interval X le) -> Prop. (* can be Set as well *)
 Check interval_set.
 Check Ic.
@@ -101,7 +101,7 @@ Record N (grnd:Set)(le:grnd->grnd->Prop)(grndI:I grnd le) : Type := Nmake {
   Nplus_opp_r    : forall x:Ncar, Nc (Nplus x (Nopp x)) (Nzero);
   Nmult_inv_r    : forall x:Ncar, ~(Nc x Nzero) -> Nc (Nmult x (Ninv x)) None;
   (* distributive laws *)
-  Nmult_plus_distr_l : forall x x' y y' z z' z'', 
+  Nmult_plus_distr_l : forall x x' y y' z z' z'',
     Nc x x' -> Nc y y' -> Nc z z' -> Nc z z'' ->
     Nc (Nmult (Nplus x y) z) (Nplus (Nmult x' z') (Nmult y' z''));
   (* order and lattice structure *)
diff --git a/test-suite/bugs/closed/shouldsucceed/1568.v b/test-suite/bugs/closed/shouldsucceed/1568.v
index 9f10f749..3609e9c8 100644
--- a/test-suite/bugs/closed/shouldsucceed/1568.v
+++ b/test-suite/bugs/closed/shouldsucceed/1568.v
@@ -3,7 +3,7 @@ CoInductive A: Set :=
 with B: Set :=
   mk_B: A -> B.
 
-CoFixpoint a:A := mk_A b 
+CoFixpoint a:A := mk_A b
 with b:B := mk_B a.
 
 Goal b = match a with mk_A a1 => a1 end.
diff --git a/test-suite/bugs/closed/shouldsucceed/1576.v b/test-suite/bugs/closed/shouldsucceed/1576.v
index c9ebbd14..3621f7a1 100644
--- a/test-suite/bugs/closed/shouldsucceed/1576.v
+++ b/test-suite/bugs/closed/shouldsucceed/1576.v
@@ -13,8 +13,8 @@ End TC.
 Module Type TD.
 
 Declare Module B: TB .
-Declare Module C: TC 
-    with Module B := B  . 
+Declare Module C: TC
+    with Module B := B  .
 End TD.
 
 Module Type TE.
@@ -25,7 +25,7 @@ Module Type TF.
 Declare Module E:  TE.
 End TF.
 
-Module G (D: TD). 
+Module G (D: TD).
 Module B' := D.C.B.
 End G.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1582.v b/test-suite/bugs/closed/shouldsucceed/1582.v
index 47953a66..be5d3dd2 100644
--- a/test-suite/bugs/closed/shouldsucceed/1582.v
+++ b/test-suite/bugs/closed/shouldsucceed/1582.v
@@ -1,12 +1,12 @@
 Require Import Peano_dec.
 
-Definition fact_F : 
+Definition fact_F :
   forall (n:nat),
   (forall m, m<n -> nat) ->
   nat.
-refine 
+refine
   (fun n fact_rec =>
-     if eq_nat_dec n 0 then 
+     if eq_nat_dec n 0 then
         1
      else
         let fn := fact_rec (n-1) _ in
diff --git a/test-suite/bugs/closed/shouldsucceed/1618.v b/test-suite/bugs/closed/shouldsucceed/1618.v
index a90290bf..a9b067ce 100644
--- a/test-suite/bugs/closed/shouldsucceed/1618.v
+++ b/test-suite/bugs/closed/shouldsucceed/1618.v
@@ -6,7 +6,7 @@ Definition A_size (a: A) : nat :=
     | A1 n => 0
   end.
 
-Require Import Recdef. 
+Require Import Recdef.
 
 Function n3 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {struct a} : P a :=
   match a  return (P a) with
diff --git a/test-suite/bugs/closed/shouldsucceed/1634.v b/test-suite/bugs/closed/shouldsucceed/1634.v
index e0c540f3..0150c250 100644
--- a/test-suite/bugs/closed/shouldsucceed/1634.v
+++ b/test-suite/bugs/closed/shouldsucceed/1634.v
@@ -18,7 +18,7 @@ Add Parametric Relation a : (S a) Seq
 
 Goal forall (a : A) (x y : S a), Seq x y -> Seq x y.
   intros a x y H.
-  setoid_replace x with y. 
+  setoid_replace x with y.
   reflexivity.
   trivial.
 Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/1643.v b/test-suite/bugs/closed/shouldsucceed/1643.v
index 4114987d..879a65b1 100644
--- a/test-suite/bugs/closed/shouldsucceed/1643.v
+++ b/test-suite/bugs/closed/shouldsucceed/1643.v
@@ -10,7 +10,6 @@ Definition decomp_func (s:Str) :=
 
 Theorem decomp s: s = decomp_func s.
 Proof.
-  intros s.
   case s; simpl; reflexivity.
 Qed.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1683.v b/test-suite/bugs/closed/shouldsucceed/1683.v
index 1571ee20..3e99694b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1683.v
+++ b/test-suite/bugs/closed/shouldsucceed/1683.v
@@ -30,7 +30,7 @@ Add Parametric Relation A : (ms_type A) (ms_eq A)
 Hypothesis foobar : forall n, ms_eq CR (IRasCR (foo IR n)) (foo CRasCRing n).
 
 Goal forall (b:ms_type CR),
- ms_eq CR (IRasCR (foo IR O)) b -> 
+ ms_eq CR (IRasCR (foo IR O)) b ->
  ms_eq CR (IRasCR (foo IR O)) b.
 intros b H.
 rewrite foobar.
diff --git a/test-suite/bugs/closed/shouldsucceed/1711.v b/test-suite/bugs/closed/shouldsucceed/1711.v
new file mode 100644
index 00000000..e16612e3
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1711.v
@@ -0,0 +1,34 @@
+(* Test for evar map consistency - was failing at some point and was *)
+(* assumed to be solved from revision 10151 (but using a bad fix) *)
+
+Require Import List.
+Set Implicit Arguments.
+
+Inductive rose : Set := Rose : nat -> list rose -> rose.
+
+Section RoseRec.
+Variables (P: rose -> Set)(L: list rose -> Set).
+Hypothesis
+  (R: forall n rs, L rs -> P (Rose n rs))
+  (Lnil: L nil)
+  (Lcons: forall r rs, P r -> L rs -> L (cons r rs)).
+
+Fixpoint rose_rec2 (t:rose) {struct t} : P t :=
+  match t as x return P x with
+  | Rose n rs =>
+    R n ((fix rs_ind (l' : list rose): L l' :=
+         match l' as x return L x with
+         | nil => Lnil
+         | cons t tl => Lcons (rose_rec2 t) (rs_ind tl)
+         end)
+         rs)
+  end.
+End RoseRec.
+
+Lemma rose_map : rose -> rose.
+Proof. intro H; elim H using rose_rec2 with
+    (L:=fun _ => list rose); (* was assumed to fail here *)
+(*  (L:=fun (_:list rose) => list rose); *)
+  clear H; simpl; intros.
+  exact (Rose n rs). exact nil. exact (H::H0).
+Defined.
diff --git a/test-suite/bugs/closed/shouldsucceed/1738.v b/test-suite/bugs/closed/shouldsucceed/1738.v
index 0deed366..c2926a2b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1738.v
+++ b/test-suite/bugs/closed/shouldsucceed/1738.v
@@ -5,10 +5,10 @@ Module SomeSetoids (Import M:FSetInterface.S).
 Lemma Equal_refl : forall s, s[=]s.
 Proof. red; split; auto. Qed.
 
-Add Relation t Equal 
- reflexivity proved by Equal_refl 
+Add Relation t Equal
+ reflexivity proved by Equal_refl
  symmetry proved by eq_sym
- transitivity proved by eq_trans 
+ transitivity proved by eq_trans
  as EqualSetoid.
 
 Add Morphism Empty with signature Equal ==> iff as Empty_m.
diff --git a/test-suite/bugs/closed/shouldsucceed/1740.v b/test-suite/bugs/closed/shouldsucceed/1740.v
index d9ce546a..ec4a7a6b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1740.v
+++ b/test-suite/bugs/closed/shouldsucceed/1740.v
@@ -17,7 +17,7 @@ Goal f =
       | n, O => n
       | _, _ => O
     end.
-  unfold f. 
+  unfold f.
   reflexivity.
 Qed.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1775.v b/test-suite/bugs/closed/shouldsucceed/1775.v
index dab4120b..932949a3 100644
--- a/test-suite/bugs/closed/shouldsucceed/1775.v
+++ b/test-suite/bugs/closed/shouldsucceed/1775.v
@@ -13,7 +13,7 @@ Goal forall s k k' m,
   (pl k' (nexists (fun w => (nexists (fun b => pl (pair w w)
     (pl (pair s b)
     (nexists (fun w0 => (nexists (fun a => pl (pair b w0)
-      (nexists (fun w1 => (nexists (fun c => pl 
+      (nexists (fun w1 => (nexists (fun c => pl
         (pair a w1) (pl (pair a c) k))))))))))))))) m.
 intros.
 eapply plImp; [ | eauto | intros ].
diff --git a/test-suite/bugs/closed/shouldsucceed/1776.v b/test-suite/bugs/closed/shouldsucceed/1776.v
index abf85455..58491f9d 100644
--- a/test-suite/bugs/closed/shouldsucceed/1776.v
+++ b/test-suite/bugs/closed/shouldsucceed/1776.v
@@ -10,7 +10,7 @@ Definition nexists (P:nat -> nat -> Prop) : nat -> Prop :=
 
 Goal forall a A m,
   True ->
-  (pl A (nexists (fun x => (nexists 
+  (pl A (nexists (fun x => (nexists
     (fun y => pl (pair a (S x)) (pair a (S y))))))) m.
 Proof.
   intros.
diff --git a/test-suite/bugs/closed/shouldsucceed/1784.v b/test-suite/bugs/closed/shouldsucceed/1784.v
index 5855b168..718b0e86 100644
--- a/test-suite/bugs/closed/shouldsucceed/1784.v
+++ b/test-suite/bugs/closed/shouldsucceed/1784.v
@@ -56,16 +56,16 @@ Require Import Program.
 
 Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} :=
   match x with
-    | I x => 
+    | I x =>
       match y with
         | I y => if (Z_eq_dec x y) then in_left else in_right
         | S ys => in_right
       end
-    | S xs => 
+    | S xs =>
       match y with
         | I y => in_right
         | S ys =>
-          let fix list_in (xs ys:list sv) {struct xs} : 
+          let fix list_in (xs ys:list sv) {struct xs} :
             {slist_in xs ys} + {~slist_in xs ys} :=
             match xs with
               | nil => in_left
@@ -76,8 +76,8 @@ Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} :=
                     | y::ys => if lt_dec x y then in_left else if elem_in
                       ys then in_left else in_right
                   end
-                in 
-                if elem_in ys then 
+                in
+                if elem_in ys then
                   if list_in xs ys then in_left else in_right
                 else in_right
             end
@@ -90,12 +90,12 @@ Next Obligation. intro H; inversion H. Defined.
 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. 
+  intro H1; contradict H. inversion H1; subst. assumption.
   contradict H0; assumption. Defined.
 Next Obligation.
   intro H1; contradict H0. inversion H1; subst. assumption. Defined.
 Next Obligation.
-  intro H0; contradict H. inversion H0; subst. assumption. Defined.
+  intro H1; contradict H. inversion H1; subst. assumption. Defined.
 Next Obligation.
   intro H0; contradict H. inversion H0; subst; auto. Defined.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1791.v b/test-suite/bugs/closed/shouldsucceed/1791.v
index 694f056e..be0e8ae8 100644
--- a/test-suite/bugs/closed/shouldsucceed/1791.v
+++ b/test-suite/bugs/closed/shouldsucceed/1791.v
@@ -9,7 +9,7 @@ Definition k1 := k0 -> k0.
 (** iterating X n times *)
 Fixpoint Pow (X:k1)(k:nat){struct k}:k1:=
   match k with 0 => fun X => X
-             |  S k' => fun A => X (Pow X k' A)   
+             |  S k' => fun A => X (Pow X k' A)
   end.
 
 Parameter Bush: k1.
diff --git a/test-suite/bugs/closed/shouldsucceed/1844.v b/test-suite/bugs/closed/shouldsucceed/1844.v
index 545f2615..5627612f 100644
--- a/test-suite/bugs/closed/shouldsucceed/1844.v
+++ b/test-suite/bugs/closed/shouldsucceed/1844.v
@@ -188,7 +188,7 @@ with exec_finish: function -> outcome -> store -> value -> store -> Prop :=
 
 with exec_function: function -> store -> value -> store -> Prop :=
  | exec_function_intro: forall f st out st1 v st',
-     exec f.(fn_body) st out st1 -> 
+     exec f.(fn_body) st out st1 ->
      exec_finish f out st1 v st' ->
      exec_function f st v st'.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1891.v b/test-suite/bugs/closed/shouldsucceed/1891.v
index 11124cdd..2d90a2f1 100644
--- a/test-suite/bugs/closed/shouldsucceed/1891.v
+++ b/test-suite/bugs/closed/shouldsucceed/1891.v
@@ -7,7 +7,7 @@
 
   Lemma L (x: T unit): (unit -> T unit) -> unit.
   Proof.
-    refine (fun x => match x return _ with mkT n => fun g => f (g _) end).
+    refine (match x return _ with mkT n => fun g => f (g _) end).
     trivial.
   Qed.
 
diff --git a/test-suite/bugs/closed/shouldsucceed/1901.v b/test-suite/bugs/closed/shouldsucceed/1901.v
index 598db366..7d86adbf 100644
--- a/test-suite/bugs/closed/shouldsucceed/1901.v
+++ b/test-suite/bugs/closed/shouldsucceed/1901.v
@@ -2,9 +2,9 @@ Require Import Relations.
 
 Record Poset{A:Type}(Le : relation A) : Type :=
   Build_Poset
-  { 
-    Le_refl : forall x : A, Le x x; 
-    Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; 
+  {
+    Le_refl : forall x : A, Le x x;
+    Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z;
     Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }.
 
 Definition nat_Poset : Poset Peano.le.
diff --git a/test-suite/bugs/closed/shouldsucceed/1905.v b/test-suite/bugs/closed/shouldsucceed/1905.v
index fb2725c9..8c81d751 100644
--- a/test-suite/bugs/closed/shouldsucceed/1905.v
+++ b/test-suite/bugs/closed/shouldsucceed/1905.v
@@ -5,7 +5,7 @@ Axiom t : Set.
 Axiom In : nat -> t -> Prop.
 Axiom InE : forall (x : nat) (s:t), impl (In x s) True.
 
-Goal forall a s, 
+Goal forall a s,
  In a s -> False.
 Proof.
  intros a s Ia.
diff --git a/test-suite/bugs/closed/shouldsucceed/1918.v b/test-suite/bugs/closed/shouldsucceed/1918.v
index 9d4a3e04..9d92fe12 100644
--- a/test-suite/bugs/closed/shouldsucceed/1918.v
+++ b/test-suite/bugs/closed/shouldsucceed/1918.v
@@ -35,7 +35,7 @@ Definition mon (X:k1) : Type := forall (A B:Set), (A -> B) -> X A -> X B.
 
 (** extensionality *)
 Definition ext (X:k1)(h: mon X): Prop :=
-  forall (A B:Set)(f g:A -> B), 
+  forall (A B:Set)(f g:A -> B),
         (forall a, f a = g a) -> forall r, h _ _ f r = h _ _ g r.
 
 (** first functor law *)
@@ -44,7 +44,7 @@ Definition fct1 (X:k1)(m: mon X) : Prop :=
 
 (** second functor law *)
 Definition fct2 (X:k1)(m: mon X) : Prop :=
- forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), 
+ forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A),
        m _ _ (g o f) x = m _ _ g (m _ _ f x).
 
 (** pack up the good properties of the approximation into
@@ -60,20 +60,20 @@ Definition pEFct (F:k2) : Type :=
   forall (X:k1), EFct X -> EFct (F X).
 
 
-(** we show some closure properties of pEFct, depending on such properties 
+(** we show some closure properties of pEFct, depending on such properties
       for EFct *)
 
 Definition moncomp (X Y:k1)(mX:mon X)(mY:mon Y): mon (fun A => X(Y A)).
 Proof.
   red.
-  intros X Y mX mY A B f x.
+  intros A B f x.
   exact (mX (Y A)(Y B) (mY A B f) x).
 Defined.
 
 (** closure under composition *)
 Lemma compEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X(Y A)).
 Proof.
-  intros X Y ef1 ef2.
+  intros ef1 ef2.
   apply (mkEFct(m:=moncomp (m ef1) (m ef2))); red; intros; unfold moncomp.
 (* prove ext *)
   apply (e ef1).
@@ -92,7 +92,7 @@ Proof.
   apply (f2 ef2).
 Defined.
 
-Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> 
+Corollary comppEFct (F G:k2): pEFct F -> pEFct G ->
       pEFct (fun X A => F X (G X A)).
 Proof.
   red.
@@ -103,8 +103,8 @@ Defined.
 (** closure under sums *)
 Lemma sumEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A + Y A)%type.
 Proof.
-  intros X Y ef1 ef2.
-  set (m12:=fun (A B:Set)(f:A->B) x => match x with 
+  intros ef1 ef2.
+  set (m12:=fun (A B:Set)(f:A->B) x => match x with
     | inl y => inl _ (m ef1 f y)
     | inr y => inr _ (m ef2 f y)
   end).
@@ -133,7 +133,7 @@ Proof.
   rewrite (f2 ef2); reflexivity.
 Defined.
 
-Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> 
+Corollary sumpEFct (F G:k2): pEFct F -> pEFct G ->
       pEFct (fun X A => F X A + G X A)%type.
 Proof.
   red.
@@ -144,8 +144,8 @@ Defined.
 (** closure under products *)
 Lemma prodEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A * Y A)%type.
 Proof.
-  intros X Y ef1 ef2.
-  set (m12:=fun (A B:Set)(f:A->B) x => match x with 
+  intros ef1 ef2.
+  set (m12:=fun (A B:Set)(f:A->B) x => match x with
     (x1,x2) => (m ef1 f x1, m ef2 f x2) end).
   apply (mkEFct(m:=m12)); red; intros.
 (* prove ext *)
@@ -168,7 +168,7 @@ Proof.
   apply (f2 ef2).
 Defined.
 
-Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> 
+Corollary prodpEFct (F G:k2): pEFct F -> pEFct G ->
       pEFct (fun X A => F X A * G X A)%type.
 Proof.
   red.
@@ -220,7 +220,6 @@ Defined.
 (** constants in k1 *)
 Lemma constEFct (C:Set): EFct (fun _ => C).
 Proof.
-  intro.
   set (mC:=fun A B (f:A->B)(x:C) => x).
   apply (mkEFct(m:=mC)); red; intros; unfold mC; reflexivity.
 Defined.
@@ -248,19 +247,19 @@ Module Type LNMIt_Type.
 
 Parameter F:k2.
 Parameter FpEFct: pEFct F.
-Parameter mu20: k1. 
+Parameter mu20: k1.
 Definition  mu2: k1:= fun A => mu20 A.
 Parameter mapmu2: mon mu2.
 Definition MItType: Type :=
   forall G : k1, (forall X : k1, X c_k1 G -> F X c_k1 G) -> mu2 c_k1 G.
 Parameter MIt0 : MItType.
-Definition MIt : MItType:= fun G s A t => MIt0 s t. 
-Definition InType : Type := 
-    forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), 
+Definition MIt : MItType:= fun G s A t => MIt0 s t.
+Definition InType : Type :=
+    forall (X:k1)(ef:EFct X)(j: X c_k1 mu2),
         NAT j (m ef) mapmu2 -> F X c_k1 mu2.
 Parameter In : InType.
 Axiom mapmu2Red : forall (A:Set)(X:k1)(ef:EFct X)(j: X c_k1 mu2)
-    (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), 
+    (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B),
             mapmu2 f (In ef n t) = In ef n (m (FpEFct ef) f t).
 Axiom MItRed : forall (G : k1)
   (s : forall X : k1, X c_k1 G -> F X c_k1 G)(X : k1)(ef:EFct X)(j: X c_k1 mu2)
@@ -327,8 +326,8 @@ Fixpoint Pow (X:k1)(k:nat){struct k}:k1:=
 
 Fixpoint POW  (k:nat)(X:k1)(m:mon X){struct k} : mon (Pow X k) :=
   match k return mon (Pow X k)
-      with 0 => fun _ _ f  => f 
-     |  S k' => fun _ _ f  => m _ _ (POW k' m f) 
+      with 0 => fun _ _ f  => f
+     |  S k' => fun _ _ f  => m _ _ (POW k' m f)
    end.
 
 Module Type BushkToList_Type.
diff --git a/test-suite/bugs/closed/shouldsucceed/1925.v b/test-suite/bugs/closed/shouldsucceed/1925.v
index 17eb721a..4caee1c3 100644
--- a/test-suite/bugs/closed/shouldsucceed/1925.v
+++ b/test-suite/bugs/closed/shouldsucceed/1925.v
@@ -3,14 +3,14 @@
 
 Require Import List.
 
-Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := 
+Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C :=
   fun x : A => g(f x).
 
-Definition map_fuse' : 
-  forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), 
-    (map g (map f xs)) = map (compose _ _ _ g f) xs 
+Definition map_fuse' :
+  forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A),
+    (map g (map f xs)) = map (compose _ _ _ g f) xs
     :=
-    fun A B C g f => 
+    fun A B C g f =>
       (fix loop (ys : list A) {struct ys} :=
         match ys as ys return (map g (map f ys)) = map (compose _ _ _ g f) ys
         with
diff --git a/test-suite/bugs/closed/shouldsucceed/1931.v b/test-suite/bugs/closed/shouldsucceed/1931.v
index bc8be78f..930ace1d 100644
--- a/test-suite/bugs/closed/shouldsucceed/1931.v
+++ b/test-suite/bugs/closed/shouldsucceed/1931.v
@@ -8,7 +8,7 @@ Inductive T (A:Set) : Set :=
 Fixpoint map (A B:Set)(f:A->B)(t:T A) : T B :=
  match t with
    app t1 t2 => app (map f t1)(map f t2)
- end. 
+ end.
 
 Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B :=
  match t with
@@ -19,7 +19,7 @@ Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B :=
 Definition k0:=Set.
 
 (** interaction of subst with map *)
-Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): 
+Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A):
  subst g (map f t) = subst (fun x => g (f x)) t.
 Proof.
  intros.
diff --git a/test-suite/bugs/closed/shouldsucceed/1935.v b/test-suite/bugs/closed/shouldsucceed/1935.v
index 641dcb7a..72396d49 100644
--- a/test-suite/bugs/closed/shouldsucceed/1935.v
+++ b/test-suite/bugs/closed/shouldsucceed/1935.v
@@ -1,14 +1,14 @@
 Definition f  (n:nat) := n = n.
 
 Lemma f_refl : forall n , f n.
-intros. reflexivity. 
+intros. reflexivity.
 Qed.
 
 Definition f'  (x:nat) (n:nat) := n = n.
 
 Lemma f_refl' : forall n , f' n n.
 Proof.
- intros. reflexivity. 
+ intros. reflexivity.
 Qed.
 
 Require Import ZArith.
diff --git a/test-suite/bugs/closed/shouldsucceed/1939.v b/test-suite/bugs/closed/shouldsucceed/1939.v
new file mode 100644
index 00000000..5e61529b
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1939.v
@@ -0,0 +1,19 @@
+Require Import Setoid Program.Basics.
+
+ Parameter P : nat -> Prop.
+ Parameter R : nat -> nat -> Prop.
+
+ Add Parametric Morphism : P
+   with signature R ++> impl as PM1.
+ Admitted.
+
+ Add Parametric Morphism : P
+   with signature R --> impl as PM2.
+ Admitted.
+
+ Goal forall x y, R x y -> P y -> P x.
+ Proof.
+   intros x y H1 H2.
+   rewrite H1.
+   auto.
+ Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/1944.v b/test-suite/bugs/closed/shouldsucceed/1944.v
new file mode 100644
index 00000000..ee2918c6
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1944.v
@@ -0,0 +1,9 @@
+(* Test some uses of ? in introduction patterns *)
+
+Inductive J : nat -> Prop :=
+  | K : forall p, J p -> (True /\ True)  -> J (S p).
+
+Lemma bug : forall n, J n -> J (S n).
+Proof.
+  intros ? H.
+  induction H as [? ? [? ?]].
diff --git a/test-suite/bugs/closed/shouldsucceed/1951.v b/test-suite/bugs/closed/shouldsucceed/1951.v
new file mode 100644
index 00000000..12c0ef9b
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/1951.v
@@ -0,0 +1,63 @@
+
+(* First a simplification of the bug *)
+
+Set Printing Universes.
+
+Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A.
+
+Definition id (X:Type(*5*)) (x:X) := x.
+
+Lemma test : let S := Type(*6 : 7*) in enc S -> S.
+simpl; intros.
+apply enc.
+apply id.
+apply Prop.
+Defined.
+
+(* Then the original bug *)
+
+Require Import List.
+
+Inductive a : Set := (* some dummy inductive *)
+b : (list a) -> a.   (* i don't know if this *)
+                     (* happens for smaller  *)
+                     (* ones                 *)
+
+Inductive sg : Type := Sg. (* single *)
+
+Definition ipl2 (P : a -> Type) :=   (* in Prop, that means P is true forall *)
+fold_right (fun x => prod (P x)) sg. (* the elements of a given list         *)
+
+Definition ind
+     : forall S : a -> Type,
+       (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s :=
+fun (S : a -> Type)
+  (X : forall ls : list a, ipl2 S ls -> S (b ls)) =>
+fix ind2 (s : a) :=
+match s as a return (S a) with
+| b l =>
+    X l
+      (list_rect (fun l0 : list a => ipl2 S l0) Sg
+         (fun (a0 : a) (l0 : list a) (IHl : ipl2 S l0) =>
+          pair (ind2 a0) IHl) l)
+end. (* some induction principle *)
+
+Implicit Arguments ind [S].
+
+Lemma k : a -> Type. (* some ininteresting lemma *)
+intro;pattern H;apply ind;intros.
+  assert (K : Type).
+    induction ls.
+      exact sg.
+      exact sg.
+  exact (prod K sg).
+Defined.
+
+Lemma k' : a -> Type. (* same lemma but with our bug *)
+intro;pattern H;apply ind;intros.
+  apply prod.
+    induction ls.
+      exact sg.
+      exact sg.
+    exact sg. (* Proof complete *)
+Defined. (* bug *)
diff --git a/test-suite/bugs/closed/shouldsucceed/1981.v b/test-suite/bugs/closed/shouldsucceed/1981.v
index 0c3b96da..99952682 100644
--- a/test-suite/bugs/closed/shouldsucceed/1981.v
+++ b/test-suite/bugs/closed/shouldsucceed/1981.v
@@ -1,5 +1,5 @@
 Implicit Arguments ex_intro [A].
 
 Goal exists n : nat, True.
-  eapply ex_intro. exact 0. exact I. 
+  eapply ex_intro. exact 0. exact I.
 Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/2001.v b/test-suite/bugs/closed/shouldsucceed/2001.v
index 323021de..d0b3bf17 100644
--- a/test-suite/bugs/closed/shouldsucceed/2001.v
+++ b/test-suite/bugs/closed/shouldsucceed/2001.v
@@ -1,8 +1,10 @@
 (* Automatic computing of guard in "Theorem with"; check that guard is not
    computed when the user explicitly indicated it *)
 
+Unset Automatic Introduction.
+
 Inductive T : Set :=
-| v : T. 
+| v : T.
 
 Definition f (s:nat) (t:T) : nat.
 fix 2.
@@ -12,9 +14,9 @@ refine
   | v => s
   end.
 Defined.
-           
+
 Lemma test :
   forall s, f s v = s.
-Proof.    
+Proof.
 reflexivity.
-Qed.        
+Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/2017.v b/test-suite/bugs/closed/shouldsucceed/2017.v
index 948cea3e..df666148 100644
--- a/test-suite/bugs/closed/shouldsucceed/2017.v
+++ b/test-suite/bugs/closed/shouldsucceed/2017.v
@@ -8,8 +8,8 @@ Set Implicit Arguments.
 Variable choose : forall(P : bool -> Prop)(H : exists x, P x), bool.
 
 Variable H : exists x : bool, True.
- 
+
 Definition coef :=
 match Some true	with
-  Some _ => @choose _ H |_ => true 
-end .      
+  Some _ => @choose _ H |_ => true
+end .
diff --git a/test-suite/bugs/closed/shouldsucceed/2083.v b/test-suite/bugs/closed/shouldsucceed/2083.v
new file mode 100644
index 00000000..a6ce4de0
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2083.v
@@ -0,0 +1,27 @@
+Require Import Program Arith.
+
+Program Fixpoint check_n  (n : nat) (P : { i | i < n } -> bool) (p : nat)
+  (H : forall (i : { i | i < n }), i < p -> P i = true)
+  {measure (n - p)} :
+  Exc (forall (p : { i | i < n}), P p = true) :=
+  match le_lt_dec n p with
+  | left _ => value _
+  | right cmp =>
+      if dec (P p) then
+        check_n n P (S p) _
+      else
+        error
+  end.
+
+Require Import Omega.
+
+Solve Obligations using program_simpl ; auto with *; try omega.
+
+Next Obligation.
+  apply H. simpl. omega.
+Defined.
+
+Next Obligation. 
+  case (le_lt_dec p i) ; intros. assert(i = p) by omega. subst.
+  revert H0. clear_subset_proofs. auto.
+  apply H. simpl. assumption. Defined.
diff --git a/test-suite/bugs/closed/shouldsucceed/2095.v b/test-suite/bugs/closed/shouldsucceed/2095.v
new file mode 100644
index 00000000..28ea99df
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2095.v
@@ -0,0 +1,19 @@
+(* Classes and sections *)
+
+Section OPT.
+  Variable A: Type.
+
+  Inductive MyOption: Type :=
+  | MyNone: MyOption
+  | MySome: A -> MyOption.
+
+  Class Opt: Type := {
+    f_opt: A -> MyOption
+  }.
+End OPT.
+
+Definition f_nat (n: nat):  MyOption nat := MySome _ n.
+
+Instance Nat_Opt: Opt nat := {
+  f_opt := f_nat
+}.
diff --git a/test-suite/bugs/closed/shouldsucceed/2108.v b/test-suite/bugs/closed/shouldsucceed/2108.v
new file mode 100644
index 00000000..cad8baa9
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2108.v
@@ -0,0 +1,22 @@
+(* Declare Module in Module Type *)
+Module Type A.
+Record t : Set := { something : unit }.
+End A.
+
+
+Module Type B.
+Declare Module BA : A.
+End B.
+
+
+Module Type C.
+Declare Module CA  : A.
+Declare Module CB : B with Module BA := CA.
+End C.
+
+
+Module Type D.
+Declare Module DA : A.
+(* Next line gives: "Anomaly: uncaught exception Not_found. Please report." *)
+Declare Module DC : C with Module CA := DA.
+End D.
diff --git a/test-suite/bugs/closed/shouldsucceed/2117.v b/test-suite/bugs/closed/shouldsucceed/2117.v
new file mode 100644
index 00000000..6377a8b7
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2117.v
@@ -0,0 +1,56 @@
+(* Check pattern-unification on evars in apply unification *)
+
+Axiom app : forall tau tau':Type, (tau -> tau') -> tau -> tau'.
+
+Axiom copy : forall tau:Type, tau -> tau -> Prop.
+Axiom copyr : forall tau:Type, tau -> tau -> Prop.
+Axiom copyf : forall tau:Type, tau -> tau -> Prop.
+Axiom eq : forall tau:Type, tau -> tau -> Prop.
+Axiom subst : forall tau tau':Type, (tau -> tau') -> tau -> tau' -> Prop.
+
+Axiom copy_atom : forall tau:Type, forall t t':tau, eq tau t t' -> copy tau t t'.
+Axiom copy_fun: forall tau tau':Type, forall t t':(tau->tau'),
+(forall x:tau, copyr tau x x->copy tau' (t x) (t' x))
+->copy (tau->tau') t t'.
+
+Axiom copyr_atom : forall tau:Type, forall t t':tau, copyr tau t t' -> eq tau t t'.
+Axiom copyr_fun: forall tau tau':Type, forall t t':(tau->tau'),
+copyr (tau->tau') t t'
+->(forall x y:tau, copy tau x y->copyr tau' (t x) (t' y)).
+
+Axiom copyf_atom : forall tau:Type, forall t t':tau, copyf tau t t' -> eq tau t t'.
+Axiom copyf_fun: forall tau tau':Type, forall t t':(tau->tau'),
+copyr (tau->tau') t t'
+->(forall x y:tau, forall z1 z2:tau',
+(copy tau x y)->
+(subst tau tau' t x z1)->
+(subst tau tau' t' y z2)->
+copyf tau' z1 z2).
+
+Axiom eqappg: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',forall t':tau',
+( ((subst tau tau' t q t') /\ (eq tau' t' r))
+->eq tau' (app tau tau' t q) r).
+
+Axiom eqappd: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',
+forall t':tau', ((subst tau tau' t q t') /\ (eq tau' r t'))
+->eq tau' r (app tau tau' t q).
+
+Axiom substcopy: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',
+(forall x:tau, (copyf tau x q) -> (copy tau' (t x) r))
+->subst tau tau' t q r.
+
+Ltac EtaLong := (apply copy_fun;intros;EtaLong)|| apply copy_atom.

+Ltac Subst := apply substcopy;intros;EtaLong.
+Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A).
+Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A.
+
+Theorem church0: forall i:Type, exists X:(i->i)->i->i,
+copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)).
+intros.
+esplit.
+EtaLong.
+eapply eqappd;split.
+Subst.
+apply copyf_atom.
+Show Existentials.
+apply H1.
diff --git a/test-suite/bugs/closed/shouldsucceed/2123.v b/test-suite/bugs/closed/shouldsucceed/2123.v
new file mode 100644
index 00000000..422a2c12
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2123.v
@@ -0,0 +1,11 @@
+(* About the detection of non-dependent metas by the refine tactic *)
+
+(* The following is a simplification of bug #2123 *)
+
+Parameter fset : nat -> Set.
+Parameter widen : forall (n : nat) (s : fset n), { x : fset (S n) | s=s }.
+Goal forall i, fset (S i).
+intro.
+refine (proj1_sig (widen i _)).
+
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2127.v b/test-suite/bugs/closed/shouldsucceed/2127.v
new file mode 100644
index 00000000..20ea4603
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2127.v
@@ -0,0 +1,11 @@
+(* Check that "apply refl_equal" is not exported as an interactive
+   tactic but as a statically globalized one *)
+
+(* (this is a simplification of the original bug report) *)
+
+Module A.
+Hint Rewrite sym_equal using apply refl_equal : foo.
+End A.
+
+
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2135.v b/test-suite/bugs/closed/shouldsucceed/2135.v
new file mode 100644
index 00000000..61882176
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2135.v
@@ -0,0 +1,9 @@
+(* Check that metas are whd-normalized before trying 2nd-order unification *)
+Lemma test : 
+  forall (D:Type) (T : forall C, option C) (Q:forall D, option D -> Prop),
+  (forall (A : Type) (P : forall B:Type, option B -> Prop), P A (T A))
+  -> Q D (T D).
+Proof.
+  intros D T Q H.
+  pattern (T D). apply H.
+Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/2136.v b/test-suite/bugs/closed/shouldsucceed/2136.v
new file mode 100644
index 00000000..d2b926f3
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2136.v
@@ -0,0 +1,61 @@
+(* Bug #2136
+
+The fsetdec tactic seems to get confused by hypotheses like
+    HeqH1 : H1 = MkEquality s0 s1 b
+If I clear them then it is able to solve my goal; otherwise it is not.
+I would expect it to be able to solve the goal even without this hypothesis
+being cleared. A small, self-contained example is below.
+
+I have coq r12238.
+
+
+Thanks
+Ian
+*)
+
+
+Require Import FSets.
+Require Import Arith.
+Require Import FSetWeakList.
+
+Module DecidableNat.
+Definition t := nat.
+Definition eq := @eq nat.
+Definition eq_refl := @refl_equal nat.
+Definition eq_sym := @sym_eq nat.
+Definition eq_trans := @trans_eq nat.
+Definition eq_dec := eq_nat_dec.
+End DecidableNat.
+
+Module NatSet := Make(DecidableNat).
+
+Module Export Dec := WDecide (NatSet).
+Import FSetDecideAuxiliary.
+
+Parameter MkEquality : forall ( s0 s1 : NatSet.t )
+                              ( x : nat ),
+                       NatSet.Equal s1 (NatSet.add x s0).
+
+Lemma ThisLemmaWorks : forall ( s0 s1 : NatSet.t )
+                              ( a b : nat ),
+                       NatSet.In a s0
+                    -> NatSet.In a s1.
+Proof.
+intros.
+remember (MkEquality s0 s1 b) as H1.
+clear HeqH1.
+fsetdec.
+Qed.
+
+Lemma ThisLemmaWasFailing : forall ( s0 s1 : NatSet.t )
+                              ( a b : nat ),
+                       NatSet.In a s0
+                    -> NatSet.In a s1.
+Proof.
+intros.
+remember (MkEquality s0 s1 b) as H1.
+fsetdec.
+(*
+Error: Tactic failure: because the goal is beyond the scope of this tactic.
+*)
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2137.v b/test-suite/bugs/closed/shouldsucceed/2137.v
new file mode 100644
index 00000000..6c2023ab
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2137.v
@@ -0,0 +1,52 @@
+(* Bug #2137
+
+The fsetdec tactic is sensitive to which way round the arguments to <> are.
+In the small, self-contained example below, it is able to solve the goal
+if it knows that "b <> a", but not if it knows that "a <> b". I would expect
+it to be able to solve hte goal in either case.
+
+I have coq r12238.
+
+
+Thanks
+Ian
+
+*)
+
+Require Import Arith FSets FSetWeakList.
+
+Module DecidableNat.
+Definition t := nat.
+Definition eq := @eq nat.
+Definition eq_refl := @refl_equal nat.
+Definition eq_sym := @sym_eq nat.
+Definition eq_trans := @trans_eq nat.
+Definition eq_dec := eq_nat_dec.
+End DecidableNat.
+
+Module NatSet := Make(DecidableNat).
+
+Module Export NameSetDec := WDecide (NatSet).
+
+Lemma ThisLemmaWorks : forall ( s0 : NatSet.t )
+                              ( a b : nat ),
+                       b <> a
+                    -> ~(NatSet.In a s0)
+                    -> ~(NatSet.In a (NatSet.add b s0)).
+Proof.
+intros.
+fsetdec.
+Qed.
+
+Lemma ThisLemmaWasFailing : forall ( s0 : NatSet.t )
+                              ( a b : nat ),
+                       a <> b
+                    -> ~(NatSet.In a s0)
+                    -> ~(NatSet.In a (NatSet.add b s0)).
+Proof.
+intros.
+fsetdec.
+(*
+Error: Tactic failure: because the goal is beyond the scope of this tactic.
+*)
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2139.v b/test-suite/bugs/closed/shouldsucceed/2139.v
new file mode 100644
index 00000000..a7f35508
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2139.v
@@ -0,0 +1,24 @@
+(* Call of apply on <-> failed because of evars in elimination predicate *)
+Generalizable Variables patch.
+
+Class Patch (patch : Type) := {
+    commute : patch -> patch -> Prop
+}.
+
+Parameter flip : forall	`{patchInstance	: Patch	patch}
+                       	 {a b : patch},
+                 commute a b <-> commute b a.
+
+Lemma Foo : forall `{patchInstance : Patch patch}
+                    {a b : patch},
+            (commute a b)
+         -> True.
+Proof.
+intros.
+apply flip in H.
+
+(* failed in well-formed arity check because elimination predicate of
+   iff in (@flip _ _ _ _) had normalized evars while the ones in the
+   type of (@flip _ _ _ _) itself had non-normalized evars *)
+
+(* By the way, is the check necessary ? *)
diff --git a/test-suite/bugs/closed/shouldsucceed/2145.v b/test-suite/bugs/closed/shouldsucceed/2145.v
new file mode 100644
index 00000000..b6c5da65
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2145.v
@@ -0,0 +1,20 @@
+(* Test robustness of Groebner tactic in presence of disequalities *)
+
+Require Export Reals.
+Require Export NsatzR.
+
+Open Scope R_scope.
+
+Lemma essai :
+ forall yb xb m1 m2 xa ya,
+  xa <> xb ->
+ yb - 2 * m2 * xb = ya - m2 * xa -> 
+ yb - m1 * xb = ya - m1 * xa ->
+ yb - ya = (2 * xb - xa) * m2 -> 
+ yb - ya = (xb - xa) * m1.
+Proof.
+intros.
+(* clear H. groebner used not to work when H was not cleared *)
+nsatzR.
+Qed.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2193.v b/test-suite/bugs/closed/shouldsucceed/2193.v
new file mode 100644
index 00000000..fe258867
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2193.v
@@ -0,0 +1,31 @@
+(* Computation of dependencies in the "match" return predicate was incomplete *)
+(* Submitted by R. O'Connor, Nov 2009 *)
+
+Inductive Symbol : Set :=
+ | VAR : Symbol.
+
+Inductive SExpression :=
+ | atomic : Symbol -> SExpression.
+
+Inductive ProperExpr : SExpression -> SExpression -> Type :=
+ | pe_3 : forall (x : Symbol) (alpha : SExpression),
+    ProperExpr alpha (atomic VAR) ->
+    ProperExpr (atomic x) alpha.
+
+Definition A (P : forall s : SExpression, Type)
+ (x alpha alpha1 : SExpression)
+ (t : ProperExpr (x) alpha1) : option (x = atomic VAR) :=
+ match t as pe in ProperExpr a b return option (a = atomic VAR) with
+ | pe_3 x0 alpha3 tye' => 
+      (fun (x:Symbol) (alpha : SExpression) => @None (atomic x = atomic VAR))
+       x0 alpha3
+ end.
+
+Definition B (P : forall s : SExpression, Type)
+ (x alpha alpha1 : SExpression)
+ (t : ProperExpr (x) alpha1) : option (x = atomic VAR) :=
+ match t as pe in ProperExpr a b return option (a = atomic VAR) with
+ | pe_3 x0 alpha3 tye' => 
+      (fun (x:Symbol) (alpha : SExpression) (t:ProperExpr alpha (atomic VAR)) => @None (atomic x = atomic VAR))
+       x0 alpha3 tye'
+ end.
diff --git a/test-suite/bugs/closed/shouldsucceed/2231.v b/test-suite/bugs/closed/shouldsucceed/2231.v
new file mode 100644
index 00000000..03e2c9bb
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2231.v
@@ -0,0 +1,3 @@
+Inductive unit2 : Type := U : unit -> unit2.
+Inductive dummy (u: unit2) : unit -> Type :=
+          V: dummy u (let (tt) := u in tt).
diff --git a/test-suite/bugs/closed/shouldsucceed/2244.v b/test-suite/bugs/closed/shouldsucceed/2244.v
new file mode 100644
index 00000000..d499e515
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2244.v
@@ -0,0 +1,19 @@
+(* 1st-order unification did not work when in competition with pattern unif. *)
+
+Set Implicit Arguments.
+Lemma test : forall
+  (A : Type)
+  (B : Type)
+  (f : A -> B)
+  (S : B -> Prop)
+  (EV : forall y (f':A->B), (forall x', S (f' x')) -> S (f y))
+  (HS : forall x', S (f x'))
+  (x : A),
+  S (f x).
+Proof.
+  intros. eapply EV. intros. 
+  (* worked in v8.2 but not in v8.3beta, fixed in r12898 *)
+  apply HS.
+
+  (* still not compatible with 8.2 because an evar can be solved in
+     two different ways and is left open *)
diff --git a/test-suite/bugs/closed/shouldsucceed/2255.v b/test-suite/bugs/closed/shouldsucceed/2255.v
new file mode 100644
index 00000000..bf80ff66
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2255.v
@@ -0,0 +1,21 @@
+(* Check injection in presence of dependencies hidden in applicative terms *)
+
+Inductive TupleT : nat -> Type :=
+  nilT : TupleT 0
+| consT {n} A : (A -> TupleT n) -> TupleT (S n).
+
+Inductive Tuple : forall n, TupleT n -> Type :=
+  nil : Tuple _ nilT
+| cons {n} A (x : A) (F : A -> TupleT n) : Tuple _ (F x) -> Tuple _ (consT A F).
+
+Goal forall n A F x X n0 A0 x0 F0 H0 (H : existT (fun n0 : nat => {H0 : TupleT
+n0 & Tuple n0 H0}) 
+         (S n0)
+         (existT (fun H0 : TupleT (S n0) => Tuple (S n0) H0) 
+            (consT A0 F0) (cons A0 x0 F0 H0)) =
+       existT (fun n0 : nat => {H0 : TupleT n0 & Tuple n0 H0}) 
+         (S n)
+         (existT (fun H0 : TupleT (S n) => Tuple (S n) H0) 
+            (consT A F) (cons A x F X))), False.
+intros.
+injection H.
diff --git a/test-suite/bugs/closed/shouldsucceed/2281.v b/test-suite/bugs/closed/shouldsucceed/2281.v
new file mode 100644
index 00000000..40948d90
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2281.v
@@ -0,0 +1,50 @@
+(** Bug #2281
+
+In the code below, coq is confused by an equality unless it is first 'subst'ed
+away, yet http://coq.inria.fr/stdlib/Coq.FSets.FSetDecide.html says
+
+    fsetdec will first perform any necessary zeta and beta reductions and will
+invoke subst to eliminate any Coq equalities between finite sets or their
+elements.
+
+I have coq r12851.
+
+*)
+
+Require Import Arith.
+Require Import FSets.
+Require Import FSetWeakList.
+
+Module DecidableNat.
+Definition t := nat.
+Definition eq := @eq nat.
+Definition eq_refl := @refl_equal nat.
+Definition eq_sym := @sym_eq nat.
+Definition eq_trans := @trans_eq nat.
+Definition eq_dec := eq_nat_dec.
+End DecidableNat.
+
+Module NatSet := Make(DecidableNat).
+
+Module Export NameSetDec := WDecide (NatSet).
+
+Lemma ThisLemmaWorks : forall ( s1 s2 : NatSet.t )
+                              ( H : s1 = s2 ),
+                       NatSet.Equal s1 s2.
+Proof.
+intros.
+subst.
+fsetdec.
+Qed.
+
+Import FSetDecideAuxiliary.
+
+Lemma ThisLemmaWasFailing : forall ( s1 s2 : NatSet.t )
+                              ( H : s1 = s2 ),
+                       NatSet.Equal s1 s2.
+Proof.
+intros.
+fsetdec.
+(* Error: Tactic failure: because the goal is beyond the scope of this tactic.
+*)
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2295.v b/test-suite/bugs/closed/shouldsucceed/2295.v
new file mode 100644
index 00000000..f5ca28dc
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2295.v
@@ -0,0 +1,11 @@
+(* Check if omission of "as" in return clause works w/ section variables too *)
+
+Section sec.
+
+Variable b: bool.
+
+Definition d' :=
+  (match b return b = true \/ b = false with
+  | true => or_introl _ (refl_equal true)
+  | false => or_intror _ (refl_equal false)
+  end).
diff --git a/test-suite/bugs/closed/shouldsucceed/2299.v b/test-suite/bugs/closed/shouldsucceed/2299.v
new file mode 100644
index 00000000..c0552ca7
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2299.v
@@ -0,0 +1,13 @@
+(* Check that destruct refreshes universes in what it generalizes *)
+
+Section test.
+
+Variable A: Type.
+
+Inductive T: unit -> Type := C: A -> unit -> T tt.
+
+Let unused := T tt.
+
+Goal T tt -> False.
+ intro X.
+ destruct X.
diff --git a/test-suite/bugs/closed/shouldsucceed/2300.v b/test-suite/bugs/closed/shouldsucceed/2300.v
new file mode 100644
index 00000000..4e587cbb
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2300.v
@@ -0,0 +1,15 @@
+(* Check some behavior of Ltac pattern-matching wrt universe levels *)
+
+Section contents.
+
+Variables (A: Type) (B: (unit -> Type) -> Type).
+
+Inductive C := c: A -> unit -> C.
+
+Let unused2 (x: unit) := C.
+
+Goal True.
+intuition.
+Qed.
+
+End contents.
diff --git a/test-suite/bugs/closed/shouldsucceed/335.v b/test-suite/bugs/closed/shouldsucceed/335.v
new file mode 100644
index 00000000..166fa7a9
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/335.v
@@ -0,0 +1,5 @@
+(* Compatibility of Require with backtracking at interactive module end *)
+
+Module A.
+Require List.
+End A.
diff --git a/test-suite/bugs/closed/shouldsucceed/38.v b/test-suite/bugs/closed/shouldsucceed/38.v
index 7bc04b1f..4fc8d7c9 100644
--- a/test-suite/bugs/closed/shouldsucceed/38.v
+++ b/test-suite/bugs/closed/shouldsucceed/38.v
@@ -6,7 +6,7 @@ Inductive liste : Set :=
 | vide : liste
 | c : A -> liste -> liste.
 
-Inductive e : A -> liste -> Prop := 
+Inductive e : A -> liste -> Prop :=
 | ec : forall (x : A) (l : liste), e x (c x l)
 | ee : forall (x y : A) (l : liste), e x l -> e x (c y l).
 
diff --git a/test-suite/bugs/closed/shouldsucceed/846.v b/test-suite/bugs/closed/shouldsucceed/846.v
index a963b225..ee5ec1fa 100644
--- a/test-suite/bugs/closed/shouldsucceed/846.v
+++ b/test-suite/bugs/closed/shouldsucceed/846.v
@@ -27,7 +27,7 @@ Definition index := list bool.
 
 Inductive L (A:Set) : index -> Set :=
   initL: A -> L A nil
-  | pluslL: forall l:index, One -> L A (false::l) 
+  | pluslL: forall l:index, One -> L A (false::l)
   | plusrL: forall l:index, L A l -> L A (false::l)
   | varL: forall l:index, L A l -> L A (true::l)
   | appL: forall l:index, L A (true::l) -> L A (true::l) -> L A (true::l)
@@ -109,7 +109,7 @@ Proof.
   exact (monL (fun x:One + A =>
     (match (maybe (fun a:A => initL a) x) with
        | inl u => pluslL _ _ u
-       | inr t' => plusrL t' end)) r). 
+       | inr t' => plusrL t' end)) r).
 Defined.
 
 Section minimal.
@@ -119,11 +119,11 @@ Hypothesis G: Set -> Set.
 Hypothesis step: sub1 (LamF' G) G.
 
 Fixpoint L'(A:Set)(i:index){struct i} : Set :=
-  match i with 
+  match i with
     nil => A
     | false::l => One + L' A l
     | true::l => G (L' A l)
-  end. 
+  end.
 
 Definition LinL': forall (A:Set)(i:index), L A i -> L' A i.
 Proof.
@@ -177,7 +177,7 @@ Proof.
   assumption.
   induction a.
   simpl L' in t.
-  apply (aczelapp (l1:=true::nil) (l2:=i)). 
+  apply (aczelapp (l1:=true::nil) (l2:=i)).
   exact (lam' IHi t).
   simpl L' in t.
   induction t.
diff --git a/test-suite/bugs/opened/shouldnotfail/1501.v b/test-suite/bugs/opened/shouldnotfail/1501.v
index 85c09dbd..1845dd1f 100644
--- a/test-suite/bugs/opened/shouldnotfail/1501.v
+++ b/test-suite/bugs/opened/shouldnotfail/1501.v
@@ -8,7 +8,7 @@ Require Export Setoid.
 Section Essais.
 
 (* Parametrized Setoid *)
-Parameter K : Type -> Type. 
+Parameter K : Type -> Type.
 Parameter equiv : forall A : Type, K A -> K A -> Prop.
 Parameter equiv_refl : forall (A : Type) (x : K A), equiv x x.
 Parameter equiv_sym : forall (A : Type) (x y : K A), equiv x y -> equiv y x.
@@ -40,7 +40,7 @@ Parameter
 
 Hint Resolve equiv_refl equiv_sym equiv_trans: monad.
 
-Add Relation K equiv 
+Add Relation K equiv
  reflexivity proved by (@equiv_refl)
  symmetry proved by (@equiv_sym)
  transitivity proved by (@equiv_trans)
@@ -67,7 +67,7 @@ Proof.
   unfold fequiv; intros; eapply equiv_trans; auto with monad.
 Qed.
 
-Add Relation (fun (A B:Type) => A -> K B) fequiv 
+Add Relation (fun (A B:Type) => A -> K B) fequiv
  reflexivity proved by (@fequiv_refl)
  symmetry proved by (@fequiv_sym)
  transitivity proved by (@fequiv_trans)
@@ -82,12 +82,12 @@ Qed.
 
 Lemma test:
   forall (A B: Type) (m1 m2 m3: K A) (f: A -> A -> K B),
- (equiv m1 m2) -> (equiv m2 m3) -> 
+ (equiv m1 m2) -> (equiv m2 m3) ->
    equiv (bind m1 (fun a => bind m2 (fun a' => f a a')))
          (bind m2 (fun a => bind m3 (fun a' => f a a'))).
 Proof.
-  intros A B m1 m2 m3 f H1 H2. 
+  intros A B m1 m2 m3 f H1 H2.
   setoid_rewrite H1. (* this works *)
   setoid_rewrite H2.
   trivial by equiv_refl.
-Qed. 
+Qed.
diff --git a/test-suite/bugs/opened/shouldnotfail/1596.v b/test-suite/bugs/opened/shouldnotfail/1596.v
index 766bf524..de77e35d 100644
--- a/test-suite/bugs/opened/shouldnotfail/1596.v
+++ b/test-suite/bugs/opened/shouldnotfail/1596.v
@@ -11,12 +11,12 @@ Module OrderedPair (X:OrderedType) (Y:OrderedType) <: OrderedType with
 Definition t := (X.t * Y.t)%type.
   Definition t := (X.t * Y.t)%type.
 
-  Definition eq (xy1:t) (xy2:t) := 
+  Definition eq (xy1:t) (xy2:t) :=
     let (x1,y1) := xy1 in
       let (x2,y2) := xy2 in
         (X.eq x1 x2) /\ (Y.eq y1 y2).
 
-  Definition lt (xy1:t) (xy2:t) := 
+  Definition lt (xy1:t) (xy2:t) :=
     let (x1,y1) := xy1 in
       let (x2,y2) := xy2 in
         (X.lt x1 x2) \/ ((X.eq x1 x2) /\ (Y.lt y1 y2)).
@@ -101,7 +101,7 @@ Definition t := (X.t * Y.t)%type.
   Defined.
 
   Hint Immediate eq_sym.
-  Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. 
+  Hint Resolve eq_refl eq_trans lt_not_eq lt_trans.
 End OrderedPair.
 
 Module MessageSpi.
@@ -189,8 +189,8 @@ n)->(hedge_synthesis_relation h m n).
 
   Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.message)
 (n:MessageSpi.message) {struct m} : bool :=
-    if H.mem (m,n) h 
-      then true 
+    if H.mem (m,n) h
+      then true
       else false.
 
   Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation
@@ -221,8 +221,8 @@ n).
 
   Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.t) (n:MessageSpi.t)
 {struct m} : bool :=
-    if H.mem (m,n) h 
-      then true 
+    if H.mem (m,n) h
+      then true
       else false.
 
   Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation
@@ -235,7 +235,7 @@ n).
     induction m;simpl;intro.
     elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros.
     apply SynInc;apply H.mem_2;trivial.
-    
+
     rewrite H in H0. (* !! impossible here !! *)
     discriminate H0.
   Qed.
diff --git a/test-suite/bugs/opened/shouldnotfail/1671.v b/test-suite/bugs/opened/shouldnotfail/1671.v
index 800c431e..d95c2108 100644
--- a/test-suite/bugs/opened/shouldnotfail/1671.v
+++ b/test-suite/bugs/opened/shouldnotfail/1671.v
@@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type :=
 Variable P : forall bo, hdlist bo -> Prop.
 Variable all : forall bo l, P bo l.
 
-Definition F (l:hdlist tt) : P tt l := 
+Definition F (l:hdlist tt) : P tt l :=
 match l in hdlist u return P u l with
 | cons (cons l') => all tt _
 end.
diff --git a/test-suite/check b/test-suite/check
index bed86c41..48a67449 100755
--- a/test-suite/check
+++ b/test-suite/check
@@ -1,272 +1,11 @@
 #!/bin/sh
 
-# Automatic test of Coq
+MAKE="${MAKE:=make}"
 
 if [ "$1" = -byte ]; then
-  coqtop="../bin/coqtop.byte -boot -q -batch"
-else
-  coqtop="../bin/coqtop -boot -q -batch"
+  export BEST=byte
 fi
 
-command="$coqtop -top Top -load-vernac-source"
-
-# on compte le nombre de tests et de succès
-nbtests=0
-nbtestsok=0
-
-# La fonction suivante teste le compilateur sur des fichiers qu'il doit
-# accepter
-test_success() {
-    for f in $1/*.v; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f $2 > /dev/null 2>&1 
-	if [ $? = 0 ]; then
-	    echo "Ok"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (should be accepted)"
-        fi 
-    done
-}
-
-# La fonction suivante teste le compilateur sur des fichiers qu'il doit
-# refuser
-test_failure() {
-    for f in $1/*.v; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f > /dev/null 2>&1
-	if [ $? != 0 ]; then 
-	    echo "Ok"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (should be rejected)"
-        fi 
-    done
-}
-
-# La fonction suivante teste la sortie des fichiers qu'elle exécute 
-test_output() {
-    for f in $1/*.v; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-        tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`
-	$command $f 2>&1 | grep -v "Welcome to Coq" | grep -v "Skipping rcfile loading" > $tmpoutput
-        foutput=`dirname $f`/`basename $f .v`.out
-        diff $tmpoutput $foutput > /dev/null 2>&1
-	if [ $? = 0 ]; then 
-	    echo "Ok"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (unexpected output)"
-        fi 
-        rm $tmpoutput
-    done
-}
-
-# La fonction suivante teste l'analyseur syntaxique fournit par "coq-parser"
-# Elle fonctionne comme test_output
-test_parser() {
-    if [ -d $1 ]; then
-    for f in $1/*.v; do
-        nbtests=`expr $nbtests + 1`
-        printf "    "$f"..."
-        tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`
-        foutput=`dirname $f`/`basename $f .v`.out
-        echo "parse_file 1 \"$f\"" | ../bin/coq-parser > $tmpoutput 2>&1
-        perl -ne 'if(/Starting.*Parser Loop/){$printit = 1};print if $printit' \
-            $tmpoutput 2>&1 | grep -i error > /dev/null
-        if [ $? = 0 ] ; then
-            echo "Error! (unexpected output)"
-        else
-            echo "Ok"
-            nbtestsok=`expr $nbtestsok + 1`
-        fi
-        rm $tmpoutput
-    done
-    fi
-}
-
-# La fonction suivante teste en interactif 
-test_interactive() {
-    for f in $1/*.v; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$coqtop < $f > /dev/null 2>&1
-	if [ $? = 0 ]; then 
-	    echo "Ok"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (should be accepted)"
-        fi 
-    done
-}
-
-# La fonction suivante teste en interactif 
-# It expects a line "(* Expected time < XXX.YYs *)" in the .v file 
-# with exactly two digits after the dot
-# The reference for time is a 6120 bogomips cpu
-test_complexity() {
-    if [ -f /proc/cpuinfo ]; then
-	if grep -q bogomips /proc/cpuinfo; then # i386, ppc
-	    bogomips=`sed -n -e "s/bogomips.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1`
-	elif grep -q Cpu0Bogo /proc/cpuinfo; then # sparc
-	    bogomips=`sed -n -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1`
-	elif grep -q BogoMIPS /proc/cpuinfo; then # alpha
-	    bogomips=`sed -n -e "s/BogoMIPS.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1`
-	fi
-    fi
-    if [ "$bogomips" = "" ]; then
-	echo "    cannot run complexity tests (no bogomips found)"
-    else
-      for f in $1/*.v; do 
-        nbtests=`expr $nbtests + 1`
-        printf "    "$f"..."
-        # extract effective user time
-        res=`$command $f 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`
-        if [ $? != 0 ]; then
-	  echo "Error! (should be accepted)"
-        elif [ "$res" = "" ]; then
-          echo "Error! (couldn't find a time measure)"
-        else
-          # express effective time in centiseconds
-          res=`echo "$res"00 | sed -n -e "s/\([0-9]*\)\.\([0-9][0-9]\).*/\1\2/p"`
-          # find expected time * 100
-          exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" $f`
-          ok=`expr \( $res \* $bogomips \) "<" \( $exp \* 6120 \)`
-          if [ "$ok" = 1 ]; then
-              echo "Ok"
-              nbtestsok=`expr $nbtestsok + 1`
-          else
-              echo "Error! (should run faster)"
-          fi
-        fi
-      done
-    fi
-}
-
-test_bugs () {
-    # Process verifications concerning submitted bugs. A message is
-    # printed for all opened bugs (still active or seems to be closed).
-    # For closed bugs that behave as expected, no message is printed
-
-    # All files are assumed to have <# of the bug>.v as a name
-
-    echo "Testing opened bugs..."
-    # We first test opened bugs that should not succeed
-    files=`/bin/ls -1 $1/opened/shoulnotsucceed/*.v 2> /dev/null`
-    for f in $files; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f $2 > /dev/null 2>&1 
-	if [ $? = 0 ]; then
-	    echo "still active"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (bug seems to be closed, please check)"
-        fi 
-    done
-
-    # And opened bugs that should not fail
-    files=`/bin/ls -1 $1/opened/shouldnotfail/*.v 2> /dev/null`
-    for f in $files; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f > /dev/null 2>&1
-	if [ $? != 0 ]; then 
-	    echo "still active"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (bug seems to be closed, please check)"
-        fi 
-    done
-
-    echo "Testing closed bugs..."
-    # Then closed bugs that should succeed
-    files=`/bin/ls -1 $1/closed/shouldsucceed/*.v 2> /dev/null`
-    for f in $files; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f $2 > /dev/null 2>&1 
-	if [ $? = 0 ]; then
-	    echo "Ok"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (bug seems to be opened, please check)"
-        fi 
-    done
-
-
-    # At last, we test closed bugs that should fail
-    files=`/bin/ls -1 $1/closed/shouldfail/*.v 2> /dev/null`
-    for f in $files; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f > /dev/null 2>&1
-	if [ $? != 0 ]; then 
-	    echo "Ok"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Error! (bug seems to be opened, please check)"
-        fi 
-    done
-    
-}
-
-test_features () {
-    # Process verifications concerning submitted bugs. A message is
-    # printed for all opened bugs (still active or seem to be closed.
-    # For closed bugs that behave as expected, no message is printed
-
-    echo "Testing wishes..."
-    files=`/bin/ls -1 $1/*.v 2> /dev/null`
-    for f in $files; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-	$command $f $2 > /dev/null 2>&1 
-	if [ $? != 0 ]; then
-	    echo "still wished"
-	    nbtestsok=`expr $nbtestsok + 1`
-        else 
-	    echo "Good news! (wish seems to be granted, please check)"
-        fi
-    done
-}
-
-# Programme principal
-
-echo "Success tests"
-test_success success
-echo "Failure tests"
-test_failure failure
-echo "Bugs tests"
-test_bugs bugs
-echo "Output tests"
-test_output output
-echo "Parser tests"
-test_parser parser
-echo "Interactive tests"
-test_interactive interactive
-echo "Micromega tests"
-test_success micromega
-
-# We give a chance to disable the complexity tests which may cause
-# random build failures on build farms
-if [ -z "$COQTEST_SKIPCOMPLEXITY" ]; then
-  echo "Complexity tests"
-  test_complexity complexity
-else
-  echo "Skipping complexity tests"
-fi
-
-echo "Module tests"
-$coqtop -compile modules/Nat
-$coqtop -compile modules/plik
-test_success modules "-I modules -impredicative-set"
-#echo "Ideal-features tests"
-#test_features ideal-features
-
-pourcentage=`expr 100 \* $nbtestsok / $nbtests`
-echo
-echo "$nbtestsok tests passed over $nbtests, i.e. $pourcentage %"
+${MAKE} clean > /dev/null 2>&1
+${MAKE} all > /dev/null 2>&1
+cat summary.log
diff --git a/test-suite/complexity/autodecomp.v b/test-suite/complexity/autodecomp.v
index 8916b104..85589ff7 100644
--- a/test-suite/complexity/autodecomp.v
+++ b/test-suite/complexity/autodecomp.v
@@ -8,4 +8,4 @@ True/\True->
 True/\True->
 False/\False.
 
-Time auto decomp.
+Timeout 5 Time auto decomp.
diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v
index eb01133e..335996c2 100644
--- a/test-suite/complexity/injection.v
+++ b/test-suite/complexity/injection.v
@@ -43,11 +43,11 @@ Record joinmap (key: Type) (t: Type) (j : joinable t) : Type
             exists s2, jm_j.(join) s1 s2 s3
 }.
 
-Parameter mkJoinmap :   forall (key: Type) (t: Type) (j: joinable t), 
+Parameter mkJoinmap :   forall (key: Type) (t: Type) (j: joinable t),
 joinmap key j.
 
 Parameter ADMIT: forall p: Prop, p.
-Implicit Arguments ADMIT [p].    
+Implicit Arguments ADMIT [p].
 
 Module Share.
 Parameter jb : joinable bool.
@@ -90,7 +90,7 @@ Definition jown : joinable own :=
   Joinable own_is_empty own_join
      ADMIT ADMIT  ADMIT  ADMIT  ADMIT  ADMIT  ADMIT  ADMIT .
 End Own.
-  
+
 Fixpoint sinv (n: nat) : Type :=
   match n with
    | O => unit
@@ -110,4 +110,4 @@ Lemma test: forall n1 w1 n2 w2, mk_world n1 w1 = mk_world n2 w2 ->
          n1 = n2.
 Proof.
 intros.
-Time injection H.
+Timeout 10 Time injection H.
diff --git a/test-suite/complexity/lettuple.v b/test-suite/complexity/lettuple.v
new file mode 100644
index 00000000..0690459f
--- /dev/null
+++ b/test-suite/complexity/lettuple.v
@@ -0,0 +1,29 @@
+(* This example checks if printing nested let-in's stays in linear time *)
+(* Expected time < 1.00s *)
+
+Definition f (x : nat * nat) :=
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  let (a,b) := x in
+  0.
+
+Timeout 5 Time Print f.
diff --git a/test-suite/complexity/pretyping.v b/test-suite/complexity/pretyping.v
index c271fb50..a884ea19 100644
--- a/test-suite/complexity/pretyping.v
+++ b/test-suite/complexity/pretyping.v
@@ -6,7 +6,7 @@ Require Import Ring_tac.
 
 Open Scope R_scope.
 
-Time Goal forall x1 x2 x3 y1 y2 y3 e1 e2 e3 e4 e5 e6 e7: R,
+Timeout 5 Time Goal forall x1 x2 x3 y1 y2 y3 e1 e2 e3 e4 e5 e6 e7: R,
 (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) *
 ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1) *
 ((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) -
diff --git a/test-suite/complexity/ring.v b/test-suite/complexity/ring.v
index 5a541bc2..51f7c4da 100644
--- a/test-suite/complexity/ring.v
+++ b/test-suite/complexity/ring.v
@@ -4,4 +4,4 @@
 Require Import ZArith.
 Open Scope Z_scope.
 Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13.
-Time intro; ring.
+Timeout 5 Time intro; ring.
diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v
index e1a799f0..ab57afdb 100644
--- a/test-suite/complexity/ring2.v
+++ b/test-suite/complexity/ring2.v
@@ -1,4 +1,4 @@
-(* This example, checks the efficiency of the abstract machine used by ring *)
+(* This example checks the efficiency of the abstract machine used by ring *)
 (* Expected time < 1.00s *)
 
 Require Import BinInt Zbool.
@@ -48,4 +48,4 @@ Open Scope Z_scope.
 Infix "+" := Zplus : Z_scope.
 
 Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13.
-Time intro; ring.
+Timeout 5 Time intro; ring.
diff --git a/test-suite/complexity/setoid_rewrite.v b/test-suite/complexity/setoid_rewrite.v
index 3b5a0de7..2e3b006e 100644
--- a/test-suite/complexity/setoid_rewrite.v
+++ b/test-suite/complexity/setoid_rewrite.v
@@ -7,4 +7,4 @@ Variable f : nat -> Prop.
 
 Goal forall U:Prop, f 100 <-> U.
 intros U.
-Time setoid_replace U with False.
+Timeout 5 Time setoid_replace U with False.
diff --git a/test-suite/complexity/unification.v b/test-suite/complexity/unification.v
index 0e1ec00d..d2ea5275 100644
--- a/test-suite/complexity/unification.v
+++ b/test-suite/complexity/unification.v
@@ -48,4 +48,4 @@ Goal
    ))))
    ))))
 .
-Time try refine (refl_equal _).
+Timeout 2 Time try refine (refl_equal _).
diff --git a/test-suite/coqdoc/links.v b/test-suite/coqdoc/links.v
new file mode 100644
index 00000000..581029bd
--- /dev/null
+++ b/test-suite/coqdoc/links.v
@@ -0,0 +1,104 @@
+(** Various checks for coqdoc
+
+- symbols should not be inlined in string g
+- links to both kinds of notations in a' should work to the right notation
+- with utf8 option, forall must be unicode
+- splitting between symbols and ident should be correct in a' and c
+- ".." should be rendered correctly
+*)
+
+Require Import String.
+
+Definition g := "dfjkh""sdfhj forall <> * ~"%string.
+
+Definition a (b: nat) := b.
+
+Definition f := forall C:Prop, C.
+
+Notation "n ++ m" := (plus n m).
+
+Notation "n ++ m" := (mult n m). (* redefinition *)
+
+Notation "n ** m" := (plus n m) (at level 60).
+
+Notation "n â–µ m" := (plus n m) (at level 60).
+
+Notation "n '_' ++ 'x' m" := (plus n m) (at level 3).
+
+Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : x = x :>A
+
+where "x = y :> A" := (@eq A x y) : type_scope.
+
+Definition eq0 := 0 = 0 :> nat.
+
+Notation "( x # y ; .. ; z )" := (pair .. (pair x y) .. z).
+
+Definition b_α := ((0#0;0) , (0 ** 0)).
+
+Notation h := a.
+
+  Section test.
+
+    Variables b' b2: nat.
+
+    Notation "n + m" := (n â–µ m) : my_scope.
+
+    Delimit Scope my_scope with my.
+
+    Notation l := 0.
+
+    Definition α := (0 + l)%my.
+
+    Definition a' b := b'++0++b2 _ ++x b.
+
+    Definition c := {True}+{True}.
+
+    Definition d := (1+2)%nat.
+
+    Lemma e : nat + nat.
+    Admitted.
+
+  End test.
+
+  Section test2.
+
+    Variables b': nat.
+
+    Section test.
+
+      Variables b2: nat.
+
+      Definition a'' b := b' ++ O ++ b2 _ ++ x b + h 0.
+
+    End test.
+
+  End test2.
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
+(** skip *)
+
diff --git a/test-suite/csdp.cache b/test-suite/csdp.cache
index 6620e52c..645de69c 100644
--- a/test-suite/csdp.cache
+++ b/test-suite/csdp.cache
diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v
index 29996fd4..494443f1 100644
--- a/test-suite/failure/Case5.v
+++ b/test-suite/failure/Case5.v
@@ -1,7 +1,7 @@
 Inductive MS : Set :=
   | X : MS -> MS
   | Y : MS -> MS.
- 
+
 Type (fun p : MS => match p return nat with
                     | X x => 0
                     end).
diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v
index a3b99f63..d63c4940 100644
--- a/test-suite/failure/Case9.v
+++ b/test-suite/failure/Case9.v
@@ -1,7 +1,7 @@
 Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}.
 Type
   match compare 0 0 return nat with
-  
+
       (* k<i *) | left _ _ (left _ _ _) => 0
    (* k=i *) | left _ _ _ => 0
    (* k>i *) | right _ _ _ => 0
diff --git a/test-suite/failure/ImportedCoercion.v b/test-suite/failure/ImportedCoercion.v
new file mode 100644
index 00000000..0a69b851
--- /dev/null
+++ b/test-suite/failure/ImportedCoercion.v
@@ -0,0 +1,7 @@
+(* Test visibility of coercions *)
+
+Require Import make_local.
+
+(* Local coercion must not be used *)
+
+Check (0 = true).
diff --git a/test-suite/failure/Sections.v b/test-suite/failure/Sections.v
new file mode 100644
index 00000000..9b3b35c1
--- /dev/null
+++ b/test-suite/failure/Sections.v
@@ -0,0 +1,4 @@
+Module A.
+Section	B.
+End A.
+End A.
diff --git a/test-suite/failure/evar1.v b/test-suite/failure/evar1.v
new file mode 100644
index 00000000..1a4e42a8
--- /dev/null
+++ b/test-suite/failure/evar1.v
@@ -0,0 +1,3 @@
+(* This used to succeed by producing an ill-typed term in v8.2 *)
+
+Lemma u: forall A : Prop, (exist _ A A) = (exist _ A A).
diff --git a/test-suite/failure/evarlemma.v b/test-suite/failure/evarlemma.v
new file mode 100644
index 00000000..ea753e79
--- /dev/null
+++ b/test-suite/failure/evarlemma.v
@@ -0,0 +1,3 @@
+(* Check success of inference of evars in the context of lemmas *)
+
+Lemma foo x : True.
diff --git a/test-suite/failure/fixpoint3.v b/test-suite/failure/fixpoint3.v
new file mode 100644
index 00000000..42f06916
--- /dev/null
+++ b/test-suite/failure/fixpoint3.v
@@ -0,0 +1,13 @@
+(* Check that arguments of impredicative types are not considered
+   subterms for the guard condition (an example by Thierry Coquand) *)
+
+Inductive I : Prop :=
+| C: (forall P:Prop, P->P) -> I.
+
+Definition i0 := C (fun _ x => x).
+
+Definition Paradox : False :=
+ (fix ni i : False :=
+  match i with
+  | C f => ni (f _ i)
+  end) i0.
diff --git a/test-suite/failure/fixpoint4.v b/test-suite/failure/fixpoint4.v
new file mode 100644
index 00000000..fd956373
--- /dev/null
+++ b/test-suite/failure/fixpoint4.v
@@ -0,0 +1,19 @@
+(* Check that arguments of impredicative types are not considered
+   subterms even through commutative cuts on functional arguments
+   (example prepared by Bruno) *)
+
+Inductive IMP : Prop :=
+  CIMP : (forall A:Prop, A->A) -> IMP
+| LIMP : (nat->IMP)->IMP.
+
+Definition i0 := (LIMP (fun _ => CIMP (fun _ x => x))).
+
+Definition Paradox : False :=
+ (fix F y o {struct o} : False :=
+  match y with
+  | tt => fun f =>
+     match f 0 with
+     | CIMP h => F y (h _ o)
+     | _ => F y (f 0)
+     end
+  end match o with LIMP f => f | _ => fun _ => o end) tt i0.
diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v
index 7e07a905..75e51138 100644
--- a/test-suite/failure/guard.v
+++ b/test-suite/failure/guard.v
@@ -18,4 +18,4 @@ Definition f :=
   let h := f in (* h = Rel 4 *)
   fix F (n:nat) : nat :=
   h F S n. (* here Rel 4 = g *)
-  
+
diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v
index e5a4e1b6..cf035edf 100644
--- a/test-suite/failure/inductive3.v
+++ b/test-suite/failure/inductive3.v
@@ -1,4 +1,4 @@
-(* Check that the nested inductive types positivity check avoids recursively 
+(* Check that the nested inductive types positivity check avoids recursively
    non uniform parameters (at least if these parameters break positivity) *)
 
 Inductive t (A:Type) : Type := c : t (A -> A) -> t A.
diff --git a/test-suite/failure/proofirrelevance.v b/test-suite/failure/proofirrelevance.v
index eedf2612..93e159e8 100644
--- a/test-suite/failure/proofirrelevance.v
+++ b/test-suite/failure/proofirrelevance.v
@@ -1,5 +1,5 @@
 (* This was working in version 8.1beta (bug in the Sort-polymorphism
-   of inductive types), but this is inconsistent with classical logic 
+   of inductive types), but this is inconsistent with classical logic
    in Prop *)
 
 Inductive bool_in_prop : Type := hide : bool -> bool_in_prop
diff --git a/test-suite/failure/rewrite_in_hyp2.v b/test-suite/failure/rewrite_in_hyp2.v
index a32037a2..1533966e 100644
--- a/test-suite/failure/rewrite_in_hyp2.v
+++ b/test-suite/failure/rewrite_in_hyp2.v
@@ -1,4 +1,4 @@
-(* Until revision 10221, rewriting in hypotheses of the form 
+(* Until revision 10221, rewriting in hypotheses of the form
    "(fun x => phi(x)) t" with "t" not rewritable used to behave as a
    beta-normalization tactic instead of raising the expected message
    "nothing to rewrite" *)
diff --git a/test-suite/failure/subtyping.v b/test-suite/failure/subtyping.v
index 35fd2036..127da851 100644
--- a/test-suite/failure/subtyping.v
+++ b/test-suite/failure/subtyping.v
@@ -4,17 +4,17 @@ Module Type T.
 
  Parameter A : Type.
 
- Inductive L : Prop := 
+ Inductive L : Prop :=
  | L0
  | L1 :  (A -> Prop) -> L.
 
 End T.
 
-Module TT : T. 
+Module TT : T.
 
  Parameter A : Type.
 
- Inductive L : Type := 
+ Inductive L : Type :=
  | L0
  | L1 :  (A -> Prop) -> L.
 
diff --git a/test-suite/failure/subtyping2.v b/test-suite/failure/subtyping2.v
index 0a75ae45..addd3b45 100644
--- a/test-suite/failure/subtyping2.v
+++ b/test-suite/failure/subtyping2.v
@@ -61,7 +61,7 @@ End Inverse_Image.
 
 Section Burali_Forti_Paradox.
 
-  Definition morphism (A : Type) (R : A -> A -> Prop) 
+  Definition morphism (A : Type) (R : A -> A -> Prop)
     (B : Type) (S : B -> B -> Prop) (f : A -> B) :=
     forall x y : A, R x y -> S (f x) (f y).
 
@@ -69,7 +69,7 @@ Section Burali_Forti_Paradox.
      assumes there exists an universal system of notations, i.e:
       - A type A0
       - An injection i0 from relations on any type into A0
-      - The proof that i0 is injective modulo morphism 
+      - The proof that i0 is injective modulo morphism
    *)
   Variable A0 : Type.                     (* Type_i *)
   Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *)
@@ -82,7 +82,7 @@ Section Burali_Forti_Paradox.
   (* Embedding of x in y: x and y are images of 2 well founded relations
      R1 and R2, the ordinal of R2 being strictly greater than that of R1.
    *)
-  Record emb (x y : A0) : Prop := 
+  Record emb (x y : A0) : Prop :=
     {X1 : Type;
      R1 : X1 -> X1 -> Prop;
      eqx : x = i0 X1 R1;
@@ -166,7 +166,7 @@ Defined.
 End Subsets.
 
 
-  Definition fsub (a b : A0) (H : emb a b) (x : sub a) : 
+  Definition fsub (a b : A0) (H : emb a b) (x : sub a) :
     sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H).
 
   (* F is a morphism: a < b => F(a) < F(b)
diff --git a/test-suite/failure/univ_include.v b/test-suite/failure/univ_include.v
index 4be70d88..56f04f9d 100644
--- a/test-suite/failure/univ_include.v
+++ b/test-suite/failure/univ_include.v
@@ -1,9 +1,9 @@
 Definition T := Type.
 Definition U := Type.
 
-Module Type MT. 
+Module Type MT.
   Parameter t : T.
-End MT. 
+End MT.
 
 Module Type MU.
   Parameter t : U.
diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v
index 049f97f2..034b7f09 100644
--- a/test-suite/failure/universes-buraliforti-redef.v
+++ b/test-suite/failure/universes-buraliforti-redef.v
@@ -64,7 +64,7 @@ End Inverse_Image.
 
 Section Burali_Forti_Paradox.
 
-  Definition morphism (A : Type) (R : A -> A -> Prop) 
+  Definition morphism (A : Type) (R : A -> A -> Prop)
     (B : Type) (S : B -> B -> Prop) (f : A -> B) :=
     forall x y : A, R x y -> S (f x) (f y).
 
@@ -72,7 +72,7 @@ Section Burali_Forti_Paradox.
      assumes there exists an universal system of notations, i.e:
       - A type A0
       - An injection i0 from relations on any type into A0
-      - The proof that i0 is injective modulo morphism 
+      - The proof that i0 is injective modulo morphism
    *)
   Variable A0 : Type.                     (* Type_i *)
   Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *)
@@ -85,7 +85,7 @@ Section Burali_Forti_Paradox.
   (* Embedding of x in y: x and y are images of 2 well founded relations
      R1 and R2, the ordinal of R2 being strictly greater than that of R1.
    *)
-  Record emb (x y : A0) : Prop := 
+  Record emb (x y : A0) : Prop :=
     {X1 : Type;
      R1 : X1 -> X1 -> Prop;
      eqx : x = i0 X1 R1;
@@ -168,7 +168,7 @@ Defined.
 End Subsets.
 
 
-  Definition fsub (a b : A0) (H : emb a b) (x : sub a) : 
+  Definition fsub (a b : A0) (H : emb a b) (x : sub a) :
     sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H).
 
   (* F is a morphism: a < b => F(a) < F(b)
diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v
index d18d2119..1f96ab34 100644
--- a/test-suite/failure/universes-buraliforti.v
+++ b/test-suite/failure/universes-buraliforti.v
@@ -47,7 +47,7 @@ End Inverse_Image.
 
 Section Burali_Forti_Paradox.
 
-  Definition morphism (A : Type) (R : A -> A -> Prop) 
+  Definition morphism (A : Type) (R : A -> A -> Prop)
     (B : Type) (S : B -> B -> Prop) (f : A -> B) :=
     forall x y : A, R x y -> S (f x) (f y).
 
@@ -55,7 +55,7 @@ Section Burali_Forti_Paradox.
      assumes there exists an universal system of notations, i.e:
       - A type A0
       - An injection i0 from relations on any type into A0
-      - The proof that i0 is injective modulo morphism 
+      - The proof that i0 is injective modulo morphism
    *)
   Variable A0 : Type.                     (* Type_i *)
   Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *)
@@ -68,7 +68,7 @@ Section Burali_Forti_Paradox.
   (* Embedding of x in y: x and y are images of 2 well founded relations
      R1 and R2, the ordinal of R2 being strictly greater than that of R1.
    *)
-  Record emb (x y : A0) : Prop := 
+  Record emb (x y : A0) : Prop :=
     {X1 : Type;
      R1 : X1 -> X1 -> Prop;
      eqx : x = i0 X1 R1;
@@ -152,7 +152,7 @@ Defined.
 End Subsets.
 
 
-  Definition fsub (a b : A0) (H : emb a b) (x : sub a) : 
+  Definition fsub (a b : A0) (H : emb a b) (x : sub a) :
     sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H).
 
   (* F is a morphism: a < b => F(a) < F(b)
diff --git a/test-suite/failure/universes3.v b/test-suite/failure/universes3.v
new file mode 100644
index 00000000..8fb414d5
--- /dev/null
+++ b/test-suite/failure/universes3.v
@@ -0,0 +1,25 @@
+(* This example (found by coqchk) checks that an inductive cannot be
+   polymorphic if its constructors induce upper universe constraints.
+   Here: I cannot be polymorphic because its type is less than the
+   type of the argument of impl. *)
+
+Definition Type1 := Type.
+Definition Type3 : Type1 := Type.                       (* Type3 < Type1 *)
+Definition Type4 := Type.
+Definition impl (A B:Type3) : Type4 := A->B.           (* Type3 <= Type4 *)
+Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B).
+    (* Type(6) <= Type(7)     because I contains, via C, elements in B
+       Type(7) <=  Type3      because (I B) is argument of impl
+       Type(4) <=  Type(7)    because type of C less than I (see remark below)
+
+       where Type(7) is the auxiliary level used to infer the type of I
+*)
+
+(* We cannot enforce Type1 < Type(6) while we already have
+   Type(6) <= Type(7) < Type3 < Type1 *)
+Definition J := I Type1.
+
+(* Open question: should the type of an inductive be the max of the
+   types of the _arguments_ of its constructors (here B and Prop,
+   after unfolding of impl), or of the max of types of the
+   constructors itself (here B -> impl Prop (I B)), as done above. *)
diff --git a/test-suite/ide/undo.v b/test-suite/ide/undo.v
index 60c2e657..d5e9ee5e 100644
--- a/test-suite/ide/undo.v
+++ b/test-suite/ide/undo.v
@@ -77,3 +77,26 @@ Qed.
 
 Definition q := O.
 Definition r := O.
+
+(* Bug 2082 : Follow the numbers *)
+
+Variable A : Prop.
+Variable B : Prop.
+
+Axiom OR : A \/ B.
+
+Lemma MyLemma2 : True.
+proof.
+per cases of (A \/ B) by OR.
+suppose A.
+    then (1 = 1).
+    then H1 : thesis. (* 4 *)
+    thus thesis by H1. (* 2 *)
+suppose B. (* 1 *) (* 3 *)
+    then (1 = 1).
+    then H2 : thesis.
+    thus thesis by H2.
+end cases.
+end proof.
+Qed. (* 5 if you made it here, there is no regression *)
+
diff --git a/test-suite/ideal-features/Case9.v b/test-suite/ideal-features/Case9.v
index 800c431e..d95c2108 100644
--- a/test-suite/ideal-features/Case9.v
+++ b/test-suite/ideal-features/Case9.v
@@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type :=
 Variable P : forall bo, hdlist bo -> Prop.
 Variable all : forall bo l, P bo l.
 
-Definition F (l:hdlist tt) : P tt l := 
+Definition F (l:hdlist tt) : P tt l :=
 match l in hdlist u return P u l with
 | cons (cons l') => all tt _
 end.
diff --git a/test-suite/ideal-features/complexity/evars_subst.v b/test-suite/ideal-features/complexity/evars_subst.v
index 6f9f86a9..b3dfb33c 100644
--- a/test-suite/ideal-features/complexity/evars_subst.v
+++ b/test-suite/ideal-features/complexity/evars_subst.v
@@ -3,12 +3,12 @@
 
 (* Let n be the number of let-in. The complexity comes from the fact
    that each implicit arguments of f was in a larger and larger
-   context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", 
+   context. To compute the type of "let _ := f ?Tn 0 in f ?T 0",
    "f ?Tn 0" is substituted in the type of "f ?T 0" which is ?T. This
    type is an evar instantiated on the n variables denoting the "f ?Ti 0".
    One obtain "?T[1;...;n-1;f ?Tn[1;...;n-1] 0]". To compute the
    type of "let _ := f ?Tn-1 0 in let _ := f ?Tn 0 in f ?T 0", another
-   substitution is done leading to 
+   substitution is done leading to
    "?T[1;...;n-2;f ?Tn[1;...;n-2] 0;f ?Tn[1;...;n-2;f ?Tn[1;...;n-2] 0] 0]"
    and so on. At the end, we get a term of exponential size *)
 
@@ -25,7 +25,7 @@ Time Check
   let _ := f _ 0 in
   let _ := f _ 0 in
   let _ := f _ 0 in
- 
+
   let _ := f _ 0 in
   let _ := f _ 0 in
   let _ := f _ 0 in
diff --git a/test-suite/ideal-features/eapply_evar.v b/test-suite/ideal-features/eapply_evar.v
new file mode 100644
index 00000000..547860bf
--- /dev/null
+++ b/test-suite/ideal-features/eapply_evar.v
@@ -0,0 +1,9 @@
+(* Test propagation of evars from subgoal to brother subgoals *)
+
+(* This does not work (oct 2008) because "match goal" sees "?evar = O"
+   and not "O = O" *)
+
+Lemma eapply_evar : O=O -> 0=O.
+intro H; eapply trans_equal;
+  [apply H | match goal with |- ?x = ?x => reflexivity end].
+Qed.
diff --git a/test-suite/ideal-features/evars_subst.v b/test-suite/ideal-features/evars_subst.v
index 6f9f86a9..b3dfb33c 100644
--- a/test-suite/ideal-features/evars_subst.v
+++ b/test-suite/ideal-features/evars_subst.v
@@ -3,12 +3,12 @@
 
 (* Let n be the number of let-in. The complexity comes from the fact
    that each implicit arguments of f was in a larger and larger
-   context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", 
+   context. To compute the type of "let _ := f ?Tn 0 in f ?T 0",
    "f ?Tn 0" is substituted in the type of "f ?T 0" which is ?T. This
    type is an evar instantiated on the n variables denoting the "f ?Ti 0".
    One obtain "?T[1;...;n-1;f ?Tn[1;...;n-1] 0]". To compute the
    type of "let _ := f ?Tn-1 0 in let _ := f ?Tn 0 in f ?T 0", another
-   substitution is done leading to 
+   substitution is done leading to
    "?T[1;...;n-2;f ?Tn[1;...;n-2] 0;f ?Tn[1;...;n-2;f ?Tn[1;...;n-2] 0] 0]"
    and so on. At the end, we get a term of exponential size *)
 
@@ -25,7 +25,7 @@ Time Check
   let _ := f _ 0 in
   let _ := f _ 0 in
   let _ := f _ 0 in
- 
+
   let _ := f _ 0 in
   let _ := f _ 0 in
   let _ := f _ 0 in
diff --git a/test-suite/ideal-features/implicit_binders.v b/test-suite/ideal-features/implicit_binders.v
new file mode 100644
index 00000000..2ec72780
--- /dev/null
+++ b/test-suite/ideal-features/implicit_binders.v
@@ -0,0 +1,124 @@
+(** * Questions de syntaxe autour de la généralisation implicite
+
+   ** Lieurs de classes
+   Aujourd'hui, les lieurs de classe [ ] et les
+   lieurs {{ }} sont équivalents et on a toutes les combinaisons de { et ( pour
+   les lieurs de classes (où la variable liée peut être anonyme):
+   *)
+
+Class Foo (A : Type) := foo : A -> nat.
+
+Definition bar [ Foo A ] (x y : A) := foo x + foo y.
+
+Definition barâ‚€ {{ Foo A }} (x y : A) := foo x + foo y.
+
+Definition bar� {( Foo A )} (x y : A) := foo x + foo y.
+
+Definition barâ‚‚ ({ Foo A }) (x y : A) := foo x + foo y.
+
+Definition bar₃ (( Foo A )) (x y : A) := foo x + foo y.
+
+Definition barâ‚„ {( F : Foo A )} (x y : A) := foo x + foo y.
+
+(** Les lieurs sont généralisés à tous les termes, pas seulement aux classes: *)
+
+Definition relation A := A -> A -> Prop.
+
+Definition inverse {( R : relation A )} := fun x y => R y x.
+
+(** Autres propositions:
+   [Definition inverse ..(R : relation A) := fun x y => R y x] et
+
+   [Definition inverse ..[R : relation A] := fun x y => R y x] ou
+   [Definition inverse ..{R : relation A} := fun x y => R y x]
+   pour lier [R] implicitement.
+
+   MS: Le .. empêche d'utiliser electric-terminator dans Proof General. Cependant, il existe
+   aussi les caractères utf8 ‥ (two dot leader) et … (horizontal ellipsis) qui permettraient
+   d'éviter ce souci moyennant l'utilisation d'unicode.
+
+   [Definition inverse _(R : relation A) := fun x y => R y x] et
+
+   [Definition inverse _[R : relation A] := fun x y => R y x] ou
+   [Definition inverse _{R : relation A} := fun x y => R y x]
+
+   [Definition inverse `(R : relation A) := fun x y => R y x] et
+
+   [Definition inverse `[R : relation A] := fun x y => R y x] ou
+   [Definition inverse `{R : relation A} := fun x y => R y x]
+
+
+   Toujours avec la possibilité de ne pas donner le nom de la variable:
+*)
+
+Definition div (x : nat) ({ y <> 0 }) := 0.
+
+(** Un choix à faire pour les inductifs: accepter ou non de ne pas donner de nom à
+   l'argument. Manque de variables anonymes pour l'utilisateur mais pas pour le système... *)
+
+Inductive bla [ Foo A ] : Type :=.
+
+(** *** Les autres syntaxes ne supportent pas de pouvoir spécifier séparément les statuts
+   des variables généralisées et celui de la variable liée. Ca peut être utile pour les
+   classes où l'on a les cas de figure: *)
+
+(** Trouve [A] et l'instance par unification du type de [x]. *)
+Definition allimpl {{ Foo A }} (x : A) : A := x.
+
+(** Trouve l'instance à partir de l'index explicite *)
+
+Class SomeStruct (a : nat) := non_zero : a <> 0.
+
+Definition instimpl ({ SomeStruct a }) : nat := a + a.
+
+(** Donne l'instance explicitement (façon foncteur). *)
+
+Definition foo_prod {( Foo A, Foo B )} : Foo (A * B) :=
+  fun x => let (l, r) := x in foo l + foo r.
+
+(** *** Questions:
+   - Gardez les crochets [ ] pour {{ }} ?
+   - Quelle syntaxe pour la généralisation ?
+   - Veut-on toutes les combinaisons de statut pour les variables généralisées et la variable liée ?
+   *)
+
+(** ** Constructeur de généralisation implicite
+
+   Permet de faire une généralisation n'importe où dans le terme: on
+   utilise un produit ou un lambda suivant le scope (fragile ?).
+   *)
+
+Goal `(x + y + z = x + (y + z)).
+Admitted.
+
+(** La généralisation donne un statut implicite aux variables si l'on utilise
+   `{ }. *)
+
+Definition baz := `{x + y + z = x + (y + z)}.
+Print baz.
+
+(** Proposition d'Arthur C.: déclarer les noms de variables généralisables à la [Implicit Types]
+   pour plus de robustesse (cela vaudrait aussi pour les lieurs). Les typos du genre de l'exemple suivant
+   ne sont plus silencieuses: *)
+
+Check `(foob 0 + x).
+
+(** Utilisé pour généraliser l'implémentation de la généralisation implicite dans
+   les déclarations d'instances (i.e. les deux defs suivantes sont équivalentes). *)
+
+Instance fooa : Foo A.
+Admitted.
+Definition fooa' : `(Foo A).
+Admitted.
+
+(** Un peu différent de la généralisation des lieurs qui "explosent" les variables
+   libres en les liant au même niveau que l'objet. Dans la deuxième defs [a] n'est pas lié dans
+   la définition mais [F : Π a, SomeStruct a]. *)
+
+Definition qux {( F : SomeStruct a )} : nat := a.
+Definition qux� {( F : `(SomeStruct a) )} : nat := 0.
+
+(** *** Questions
+   - Autres propositions de syntaxe ?
+   - Réactions sur la construction ?
+   *)
\ No newline at end of file
diff --git a/test-suite/ideal-features/universes.v b/test-suite/ideal-features/universes.v
index 6db4cfe1..49530ebc 100644
--- a/test-suite/ideal-features/universes.v
+++ b/test-suite/ideal-features/universes.v
@@ -7,7 +7,7 @@ Definition Ty := Type (* Top.1 *).
 
 Inductive Q (A:Type (* Top.2 *)) : Prop := q : A -> Q A.
 Inductive T (B:Type (* Top.3 *)) := t : B -> Q (T B) -> T B.
-(* ajoute Top.4 <= Top.2 inutilement: 
+(* ajoute Top.4 <= Top.2 inutilement:
    4 est l'univers utilisé dans le calcul du type polymorphe de T *)
 Definition C := T Ty.
 (* ajoute Top.1 < Top.3 :
@@ -23,7 +23,7 @@ Definition C := T Ty.
 
 Definition f (A:Type (* Top.1 *)) := True.
 Inductive R := r : f R -> R.
-(* ajoute Top.3 <= Top.1 inutilement: 
+(* ajoute Top.3 <= Top.1 inutilement:
    Top.3 est l'univers utilisé dans le calcul du type polymorphe de R *)
 
 (* mais il manque la contrainte que l'univers de R est plus petit que Top.1
diff --git a/test-suite/interactive/Evar.v b/test-suite/interactive/Evar.v
index 1bc1f71d..50c5bba0 100644
--- a/test-suite/interactive/Evar.v
+++ b/test-suite/interactive/Evar.v
@@ -1,6 +1,6 @@
 (* Check that no toplevel "unresolved evar" flees through Declare
    Implicit Tactic support (bug #1229) *)
 
-Goal True. 
+Goal True.
 (* should raise an error, not an anomaly *)
 set (x := _).
diff --git a/test-suite/micromega/csdp.cache b/test-suite/micromega/csdp.cache
new file mode 100644
index 00000000..645de69c
--- /dev/null
+++ b/test-suite/micromega/csdp.cache
diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v
index 751fe91e..f424f0fc 100644
--- a/test-suite/micromega/example.v
+++ b/test-suite/micromega/example.v
@@ -19,7 +19,7 @@ Lemma not_so_easy : forall x n : Z,
   2*x + 1 <= 2 *n -> x <= n-1.
 Proof.
   intros.
-  lia. 
+  lia.
 Qed.
 
 
@@ -27,19 +27,19 @@ Qed.
 
 Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0.
 Proof.
-  intros. 
-  psatz Z 2. 
+  intros.
+  psatz Z 2.
 Qed.
 
 
-Lemma Zdiscr: forall a b c x, 
+Lemma Zdiscr: forall a b c x,
   a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0.
 Proof.
   intros ; psatz Z 4.
 Qed.
 
 
-Lemma plus_minus : forall x y, 
+Lemma plus_minus : forall x y,
   0 = x + y -> 0 =  x -y -> 0 = x /\ 0 = y.
 Proof.
   intros.
@@ -48,20 +48,20 @@ Qed.
 
 
 
-Lemma mplus_minus : forall x y, 
+Lemma mplus_minus : forall x y,
   x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0.
 Proof.
   intros; psatz Z 2.
 Qed.
 
-Lemma pol3: forall x y, 0 <= x + y ->  
+Lemma pol3: forall x y, 0 <= x + y ->
   x^3 + 3*x^2*y + 3*x* y^2 + y^3 >= 0.
 Proof.
   intros; psatz Z 4.
 Qed.
 
 
-(* Motivating example from: Expressiveness + Automation + Soundness: 
+(* Motivating example from: Expressiveness + Automation + Soundness:
    Towards COmbining SMT Solvers and Interactive Proof Assistants *)
 Parameter rho : Z.
 Parameter rho_ge : rho >= 0.
@@ -76,7 +76,7 @@ Definition rbound2 (C:Z -> Z -> Z) : Prop :=
 
 
 Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t  /\ correct q t /\
-  rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D  -> 
+  rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D  ->
   Zabs (C p t - D q t) <= Zabs (C p s - D q s) + 2 * rho * (t- s).
 Proof.
   intros.
@@ -194,8 +194,8 @@ Qed.
 (* from hol_light/Examples/sos.ml *)
 
 Lemma hol_light1 : forall a1 a2 b1 b2,
-  a1 >= 0 -> a2 >= 0 -> 
-   (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> 
+  a1 >= 0 -> a2 >= 0 ->
+   (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) ->
    (a1 * b1 + a2 * b2 = 0) -> a1 * a2 - b1 * b2 >= 0.
 Proof.
   intros ; psatz Z 4.
@@ -323,7 +323,7 @@ Proof.
 Qed.
 
 
-Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> 
+Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 ->
   ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1)
                 -> (x1 + y1 = x2 + y2).
 Proof.
@@ -333,7 +333,8 @@ Qed.
 
 Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0.
 Proof.
-  intros ; psatz Z.
+  intros.
+  psatz Z 1.
 Qed.
 
 
diff --git a/test-suite/micromega/heap3_vcgen_25.v b/test-suite/micromega/heap3_vcgen_25.v
index 0298303f..efb5c7fd 100644
--- a/test-suite/micromega/heap3_vcgen_25.v
+++ b/test-suite/micromega/heap3_vcgen_25.v
@@ -11,7 +11,7 @@ Require Import Psatz.
 
 Open Scope Z_scope.
 
-Lemma vcgen_25 : forall   
+Lemma vcgen_25 : forall
   (n : Z)
   (m : Z)
   (jt : Z)
diff --git a/test-suite/micromega/qexample.v b/test-suite/micromega/qexample.v
index 1fa250e0..76dc52e6 100644
--- a/test-suite/micromega/qexample.v
+++ b/test-suite/micromega/qexample.v
@@ -10,7 +10,7 @@ Require Import Psatz.
 Require Import QArith.
 Require Import Ring_normalize.
 
-Lemma plus_minus : forall x y, 
+Lemma plus_minus : forall x y,
   0 == x + y -> 0 ==  x -y -> 0 == x /\ 0 == y.
 Proof.
   intros.
@@ -37,7 +37,7 @@ Qed.
 Open Scope Z_scope.
 Open Scope Q_scope.
 
-Lemma vcgen_25 : forall   
+Lemma vcgen_25 : forall
   (n : Q)
   (m : Q)
   (jt : Q)
@@ -67,12 +67,12 @@ Qed.
 Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False.
 Proof.
   intros.
-  psatz Q 2.
+  psatz Q 3.
 Qed.
 
 Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 # 1) *x^2*y^2) >= 0.
 Proof.
-  intros ; psatz Q.
+  intros ; psatz Q 3.
 Qed.
 
 
diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v
index d7386a4e..9bb9dacc 100644
--- a/test-suite/micromega/rexample.v
+++ b/test-suite/micromega/rexample.v
@@ -12,7 +12,7 @@ Require Import Ring_normalize.
 
 Open Scope R_scope.
 
-Lemma yplus_minus : forall x y, 
+Lemma yplus_minus : forall x y,
   0 = x + y -> 0 =  x -y -> 0 = x /\ 0 = y.
 Proof.
   intros.
@@ -34,7 +34,7 @@ Proof.
 Qed.
 
 
-Lemma vcgen_25 : forall   
+Lemma vcgen_25 : forall
   (n : R)
   (m : R)
   (jt : R)
@@ -64,12 +64,12 @@ Qed.
 Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False.
 Proof.
   intros.
-  psatz R 2.
+  psatz R 3.
 Qed.
 
 Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 ) *x^2*y^2) >= 0.
 Proof.
-  intros ; psatz R.
+  intros ; psatz R 2.
 Qed.
 
 Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z).
diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v
index b78bba25..4c00ffe4 100644
--- a/test-suite/micromega/square.v
+++ b/test-suite/micromega/square.v
@@ -20,7 +20,7 @@ Proof.
 intros [n [p [Heq Hnz]]]; pose (n' := Zabs n); pose (p':=Zabs p).
 assert (facts : 0 <= Zabs n /\ 0 <= Zabs p /\ Zabs n^2=n^2
          /\ Zabs p^2 = p^2) by auto.
-assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by 
+assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by
   (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; psatz Z 2).
 generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear.
 intros n IHn p [Hn [Hp Heq]].
@@ -55,7 +55,7 @@ Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1.
 Proof.
  unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Zmult_1_r.
  intros HQeq.
- assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by 
+ 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)
  by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq).
diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v
index 2b40f6c9..3b246023 100644
--- a/test-suite/micromega/zomicron.v
+++ b/test-suite/micromega/zomicron.v
@@ -20,8 +20,17 @@ Proof.
   lia.
 Qed.
 
-Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 -> 7 * x - 9 * y = 4 -> -10 <= 7 * x - 9 * y <= 4 -> False.
+Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 ->  -10 <= 7 * x - 9 * y <= 4 -> False.
 Proof.
   intros ; intuition auto.
   lia.
-Qed.  
+Qed.
+
+Lemma compact_proof : forall z,
+ (z < 0) ->
+ (z >= 0) ->
+  (0 >= z \/ 0 < z) -> False.
+Proof.
+ intros.
+ lia.
+Qed.
\ No newline at end of file
diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v
new file mode 100644
index 00000000..5b2f5063
--- /dev/null
+++ b/test-suite/misc/berardi_test.v
@@ -0,0 +1,155 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(** This file formalizes Berardi's paradox which says that in
+   the calculus of constructions, excluded middle (EM) and axiom of
+   choice (AC) imply proof irrelevance (PI).
+   Here, the axiom of choice is not necessary because of the use
+   of inductive types.
+<<
+@article{Barbanera-Berardi:JFP96,
+   author    = {F. Barbanera and S. Berardi},
+   title     = {Proof-irrelevance out of Excluded-middle and Choice
+                in the Calculus of Constructions},
+   journal   = {Journal of Functional Programming},
+   year      = {1996},
+   volume    = {6},
+   number    = {3},
+   pages     = {519-525}
+}
+>> *)
+
+Set Implicit Arguments.
+
+Section Berardis_paradox.
+
+(** Excluded middle *)
+Hypothesis EM : forall P:Prop, P \/ ~ P.
+
+(** Conditional on any proposition. *)
+Definition IFProp (P B:Prop) (e1 e2:P) :=
+  match EM B with
+  | or_introl _ => e1
+  | or_intror _ => e2
+  end.
+
+(** Axiom of choice applied to disjunction.
+    Provable in Coq because of dependent elimination. *)
+Lemma AC_IF :
+ forall (P B:Prop) (e1 e2:P) (Q:P -> Prop),
+   (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2).
+Proof.
+intros P B e1 e2 Q p1 p2.
+unfold IFProp in |- *.
+case (EM B); assumption.
+Qed.
+
+
+(** We assume a type with two elements. They play the role of booleans.
+    The main theorem under the current assumptions is that [T=F] *)
+Variable Bool : Prop.
+Variable T : Bool.
+Variable F : Bool.
+
+(** The powerset operator *)
+Definition pow (P:Prop) := P -> Bool.
+
+
+(** A piece of theory about retracts *)
+Section Retracts.
+
+Variables A B : Prop.
+
+Record retract : Prop :=
+  {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.
+
+Record retract_cond : Prop :=
+  {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.
+
+
+(** The dependent elimination above implies the axiom of choice: *)
+Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
+Proof.
+intros r.
+case r; simpl in |- *.
+trivial.
+Qed.
+
+End Retracts.
+
+(** This lemma is basically a commutation of implication and existential
+    quantification:  (EX x | A -> P(x))  <=> (A -> EX x | P(x))
+    which is provable in classical logic ( => is already provable in
+    intuitionnistic logic). *)
+
+Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B).
+Proof.
+intros A B.
+destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf].
+  exists f0 g0; trivial.
+  exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros;
+    destruct hf; auto.
+Qed.
+
+
+(** The paradoxical set *)
+Definition U := forall P:Prop, pow P.
+
+(** Bijection between [U] and [(pow U)] *)
+Definition f (u:U) : pow U := u U.
+
+Definition g (h:pow U) : U :=
+  fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h).
+
+(** We deduce that the powerset of [U] is a retract of [U].
+    This lemma is stated in Berardi's article, but is not used
+    afterwards. *)
+Lemma retract_pow_U_U : retract (pow U) U.
+Proof.
+exists g f.
+intro a.
+unfold f, g in |- *; simpl in |- *.
+apply AC.
+exists (fun x:pow U => x) (fun x:pow U => x).
+trivial.
+Qed.
+
+(** Encoding of Russel's paradox *)
+
+(** The boolean negation. *)
+Definition Not_b (b:Bool) := IFProp (b = T) F T.
+
+(** the set of elements not belonging to itself *)
+Definition R : U := g (fun u:U => Not_b (u U u)).
+
+
+Lemma not_has_fixpoint : R R = Not_b (R R).
+Proof.
+unfold R at 1 in |- *.
+unfold g in |- *.
+rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
+trivial.
+exists (fun x:pow U => x) (fun x:pow U => x); trivial.
+Qed.
+
+
+Theorem classical_proof_irrelevence : T = F.
+Proof.
+generalize not_has_fixpoint.
+unfold Not_b in |- *.
+apply AC_IF.
+intros is_true is_false.
+elim is_true; elim is_false; trivial.
+
+intros not_true is_true.
+elim not_true; trivial.
+Qed.
+
+End Berardis_paradox.
diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v
index 354c3957..71d33177 100644
--- a/test-suite/modules/PO.v
+++ b/test-suite/modules/PO.v
@@ -7,11 +7,11 @@ Implicit Arguments snd.
 Module Type PO.
   Parameter T : Set.
   Parameter le : T -> T -> Prop.
-  
+
   Axiom le_refl : forall x : T, le x x.
   Axiom le_trans : forall x y z : T, le x y -> le y z -> le x z.
   Axiom le_antis : forall x y : T, le x y -> le y x -> x = y.
-  
+
   Hint Resolve le_refl le_trans le_antis.
 End PO.
 
@@ -28,10 +28,10 @@ Module Pair (X: PO) (Y: PO) <: PO.
 
   Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3.
     unfold le in |- *;  intuition; info  eauto.
-  Qed.    
+  Qed.
 
   Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2.
-    destruct p1.  
+    destruct p1.
     destruct p2.
     unfold le in |- *.
      intuition.
diff --git a/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v
index 014f6c60..e3694b81 100644
--- a/test-suite/modules/Przyklad.v
+++ b/test-suite/modules/Przyklad.v
@@ -1,4 +1,4 @@
-Definition ifte (T : Set) (A B : Prop) (s : {A} + {B}) 
+Definition ifte (T : Set) (A B : Prop) (s : {A} + {B})
   (th el : T) := if s then th else el.
 
 Implicit Arguments ifte.
@@ -33,7 +33,7 @@ Module Type ELEM.
   Parameter T : Set.
   Parameter eq_dec : forall a a' : T, {a = a'} + {a <> a'}.
 End ELEM.
-                                        
+
 Module Type SET (Elt: ELEM).
   Parameter T : Set.
   Parameter empty : T.
@@ -104,11 +104,11 @@ Module Nat.
 End Nat.
 
 
-Module SetNat := F Nat. 
+Module SetNat := F Nat.
 
 
-Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false. 
-apply SetNat.find_empty_false. 
+Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false.
+apply SetNat.find_empty_false.
 Qed.
 
 (***************************************************************************)
@@ -120,8 +120,8 @@ Module Lemmas (G: SET) (E: ELEM).
    forall (S : ESet.T) (a1 a2 : E.T),
    let S1 := ESet.add a1 (ESet.add a2 S) in
    let S2 := ESet.add a2 (ESet.add a1 S) in
-   forall a : E.T, ESet.find a S1 = ESet.find a S2. 
-  
+   forall a : E.T, ESet.find a S1 = ESet.find a S2.
+
     intros.
     unfold S1, S2 in |- *.
     elim (E.eq_dec a a1); elim (E.eq_dec a a2); intros H1 H2;
@@ -137,10 +137,10 @@ Inductive list (A : Set) : Set :=
   | nil : list A
   | cons : A -> list A -> list A.
 
-Module ListDict (E: ELEM). 
+Module ListDict (E: ELEM).
   Definition T := list E.T.
   Definition elt := E.T.
-   
+
   Definition empty := nil elt.
   Definition add (e : elt) (s : T) := cons elt e s.
   Fixpoint find (e : elt) (s : T) {struct s} : bool :=
@@ -160,7 +160,7 @@ Module ListDict (E: ELEM).
     auto.
 
   Qed.
-  
+
 
   Lemma find_add_false :
    forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
@@ -171,8 +171,8 @@ Module ListDict (E: ELEM).
      rewrite H0.
     simpl in |- *.
     reflexivity.
-  Qed.    
-  
+  Qed.
+
 
 End ListDict.
 
diff --git a/test-suite/modules/Tescik.v b/test-suite/modules/Tescik.v
index 8dadace7..1d1b1e0a 100644
--- a/test-suite/modules/Tescik.v
+++ b/test-suite/modules/Tescik.v
@@ -7,20 +7,20 @@ End ELEM.
 Module Nat.
     Definition A := nat.
     Definition x := 0.
-End Nat. 
+End Nat.
 
 Module List (X: ELEM).
   Inductive list : Set :=
     | nil : list
     | cons : X.A -> list -> list.
- 
+
   Definition head (l : list) := match l with
                                 | nil => X.x
                                 | cons x _ => x
                                 end.
 
   Definition singl (x : X.A) := cons x nil.
-  
+
   Lemma head_singl : forall x : X.A, head (singl x) = x.
   auto.
   Qed.
diff --git a/test-suite/modules/fun_objects.v b/test-suite/modules/fun_objects.v
index f4dc19b3..dce2ffd5 100644
--- a/test-suite/modules/fun_objects.v
+++ b/test-suite/modules/fun_objects.v
@@ -4,7 +4,7 @@ Unset Strict Implicit.
 Module Type SIG.
   Parameter id : forall A : Set, A -> A.
 End SIG.
- 
+
 Module M (X: SIG).
   Definition idid := X.id X.id.
   Definition id := idid X.id.
diff --git a/test-suite/modules/injection_discriminate_inversion.v b/test-suite/modules/injection_discriminate_inversion.v
index 88c19cb1..d4ac7b3a 100644
--- a/test-suite/modules/injection_discriminate_inversion.v
+++ b/test-suite/modules/injection_discriminate_inversion.v
@@ -7,18 +7,18 @@ Module M1 := M.
 
 Goal forall x, M.C x = M1.C 0 -> x = 0 .
   intros x H.
-  (* 
-     injection sur deux constructeurs egaux mais appeles 
-     par des modules differents 
+  (*
+     injection sur deux constructeurs egaux mais appeles
+     par des modules differents
      *)
-  injection H. 
+  injection H.
   tauto.
 Qed.
 
 Goal  M.C 0 <> M1.C 1.
-  (* 
-     Discriminate sur deux constructeurs egaux mais appeles 
-     par des modules differents 
+  (*
+     Discriminate sur deux constructeurs egaux mais appeles
+     par des modules differents
      *)
   intro H;discriminate H.
 Qed.
@@ -26,9 +26,9 @@ Qed.
 
 Goal forall x,  M.C x = M1.C 0 -> x = 0.
   intros x H.
-  (* 
-     inversion sur deux constructeurs egaux mais appeles 
-     par des modules differents 
+  (*
+     inversion sur deux constructeurs egaux mais appeles
+     par des modules differents
      *)
   inversion H. reflexivity.
 Qed.
\ No newline at end of file
diff --git a/test-suite/modules/mod_decl.v b/test-suite/modules/mod_decl.v
index b886eb59..8b40213a 100644
--- a/test-suite/modules/mod_decl.v
+++ b/test-suite/modules/mod_decl.v
@@ -31,17 +31,17 @@ Module Type T.
   Module M0.
     Axiom A : Set.
   End M0.
-  
+
   Declare Module M1: SIG.
-  
+
   Module M2 <: SIG.
     Definition A := nat.
   End M2.
-  
+
   Module M3 := M0.
-  
+
   Module M4 : SIG := M0.
-  
+
   Module M5 <: SIG := M0.
 
   Module M6 := F M0.
diff --git a/test-suite/modules/modeq.v b/test-suite/modules/modeq.v
index 45cf9f12..1238ee9d 100644
--- a/test-suite/modules/modeq.v
+++ b/test-suite/modules/modeq.v
@@ -19,4 +19,4 @@ Module Z.
   Module N := M.
 End Z.
 
-Module A : SIG := Z.  
\ No newline at end of file
+Module A : SIG := Z.
\ No newline at end of file
diff --git a/test-suite/modules/modul.v b/test-suite/modules/modul.v
index 9d24d6ce..36a542ef 100644
--- a/test-suite/modules/modul.v
+++ b/test-suite/modules/modul.v
@@ -6,7 +6,7 @@ Module M.
   Hint Resolve w.
 
   (* <Warning> : Grammar is replaced by Notation *)
-  
+
   Print Hint *.
 
   Lemma w1 : rel 0 1.
diff --git a/test-suite/modules/obj.v b/test-suite/modules/obj.v
index 97337a12..fda1a074 100644
--- a/test-suite/modules/obj.v
+++ b/test-suite/modules/obj.v
@@ -1,7 +1,7 @@
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-Module M. 
+Module M.
   Definition a (s : Set) := s.
   Print a.
 End M.
diff --git a/test-suite/modules/objects.v b/test-suite/modules/objects.v
index 070f859e..d3a4c0b0 100644
--- a/test-suite/modules/objects.v
+++ b/test-suite/modules/objects.v
@@ -2,7 +2,7 @@ Module Type SET.
   Axiom T : Set.
   Axiom x : T.
 End SET.
- 
+
 Set Implicit Arguments.
 Unset Strict Implicit.
 
diff --git a/test-suite/modules/objects2.v b/test-suite/modules/objects2.v
index e286609e..220e2b36 100644
--- a/test-suite/modules/objects2.v
+++ b/test-suite/modules/objects2.v
@@ -4,7 +4,7 @@
 
 (* Bug #1118 (simplified version), submitted by Evelyne Contejean
   (used to failed in pre-V8.1 trunk because of a call to lookup_mind
-   for structure objects) 
+   for structure objects)
 *)
 
 Module Type S. Record t : Set := { a : nat; b : nat }. End S.
diff --git a/test-suite/modules/sig.v b/test-suite/modules/sig.v
index 4cb6291d..da5d25fa 100644
--- a/test-suite/modules/sig.v
+++ b/test-suite/modules/sig.v
@@ -18,8 +18,8 @@ Module Type SPRYT.
   End N.
 End SPRYT.
 
-Module K : SPRYT := N.  
-Module K' : SPRYT := M.  
+Module K : SPRYT := N.
+Module K' : SPRYT := M.
 
 Module Type SIG.
   Definition T : Set := M.N.T.
diff --git a/test-suite/modules/sub_objects.v b/test-suite/modules/sub_objects.v
index 5eec0775..fdfd09f8 100644
--- a/test-suite/modules/sub_objects.v
+++ b/test-suite/modules/sub_objects.v
@@ -12,7 +12,7 @@ Module M.
   Module N.
     Definition idid (A : Set) (x : A) := id x.
     (* <Warning> : Grammar is replaced by Notation *)
-    Notation inc := (plus 1). 
+    Notation inc := (plus 1).
   End N.
 
   Definition zero := N.idid 0.
diff --git a/test-suite/modules/subtyping.v b/test-suite/modules/subtyping.v
index 2df8e84e..dd7daf42 100644
--- a/test-suite/modules/subtyping.v
+++ b/test-suite/modules/subtyping.v
@@ -15,7 +15,7 @@ Module Type T.
 
  Parameter A : Type (* Top.1 *) .
 
- Inductive L : Type (* max(Top.1,1) *) := 
+ Inductive L : Type (* max(Top.1,1) *) :=
  | L0
  | L1 :  (A -> Prop) -> L.
 
@@ -23,17 +23,17 @@ End T.
 
 Axiom Tp : Type (* Top.5 *) .
 
-Module TT : T. 
+Module TT : T.
 
  Definition A : Type (* Top.6 *) := Tp. (* generates Top.5 <= Top.6 *)
 
- Inductive L : Type (* max(Top.6,1) *) := 
+ Inductive L : Type (* max(Top.6,1) *) :=
  | L0
  | L1 :  (A -> Prop) -> L.
 
 End TT. (* Generates Top.6 <= Top.1 (+ auxiliary constraints for L_rect) *)
 
-(* Note: Top.6 <= Top.1 is generated by subtyping on A; 
+(* Note: Top.6 <= Top.1 is generated by subtyping on A;
    subtyping of L follows and has not to be checked *)
 
 
diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out
index 1f0e12d3..1ec02c56 100644
--- a/test-suite/output/Cases.out
+++ b/test-suite/output/Cases.out
@@ -9,10 +9,9 @@ fix F (t : t) : P t :=
 proj = 
 fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) =>
 match eq_nat_dec x y with
-| left eqprf =>
-    match eqprf in (_ = z) return (P z) with
-    | refl_equal => def
-    end
+| left eqprf => match eqprf in (_ = z) return (P z) with
+                | eq_refl => def
+                end
 | right _ => prf
 end
      : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y
diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v
index 37ee71e9..b6337586 100644
--- a/test-suite/output/Cases.v
+++ b/test-suite/output/Cases.v
@@ -12,7 +12,7 @@ Require Import Arith.
 
 Definition proj (x y:nat) (P:nat -> Type) (def:P x) (prf:P y) : P y :=
   match eq_nat_dec x y return P y with
-  | left eqprf => 
+  | left eqprf =>
     match eqprf in (_ = z) return (P z) with
     | refl_equal => def
     end
diff --git a/test-suite/output/Coercions.out b/test-suite/output/Coercions.out
index 4b8aa355..6edc9e09 100644
--- a/test-suite/output/Coercions.out
+++ b/test-suite/output/Coercions.out
@@ -4,3 +4,5 @@ R x x
      : Prop
 fun (x : foo) (n : nat) => x n
      : foo -> nat -> nat
+"1" 0
+     : PAIR
diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v
index c88b143f..0e84bf39 100644
--- a/test-suite/output/Coercions.v
+++ b/test-suite/output/Coercions.v
@@ -13,3 +13,12 @@ End testSection.
 
 Record foo : Type :=  {D :> nat -> nat}.
 Check (fun (x : foo) (n : nat) => x n).
+
+(* Check both removal of coercions with target Funclass and mixing
+   string and numeral scopes *)
+
+Require Import String.
+Open Scope string_scope.
+Inductive PAIR := P (s:string) (n:nat).
+Coercion P : string >-> Funclass.
+Check ("1" 0).
diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out
new file mode 100644
index 00000000..ca79ba69
--- /dev/null
+++ b/test-suite/output/Existentials.out
@@ -0,0 +1 @@
+Existential 1 = ?9 : [n : nat  m : nat |- nat] 
diff --git a/test-suite/output/Existentials.v b/test-suite/output/Existentials.v
new file mode 100644
index 00000000..73884683
--- /dev/null
+++ b/test-suite/output/Existentials.v
@@ -0,0 +1,14 @@
+(* Test propagation of clear/clearbody in existential variables *)
+
+Section Test.
+
+Variable p:nat.
+Let q := S p.
+
+Goal forall n m:nat, n = m.
+intros.
+eapply eq_trans.
+clearbody q.
+clear p. (* Error ... *)
+
+Show Existentials.
diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v
index 2b13c204..af5f05f6 100644
--- a/test-suite/output/Fixpoint.v
+++ b/test-suite/output/Fixpoint.v
@@ -1,7 +1,7 @@
 Require Import List.
 
 Check
-  (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : 
+  (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} :
    list B := match l with
              | nil => nil
              | a :: l => f a :: F _ _ f l
diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out
new file mode 100644
index 00000000..105940a4
--- /dev/null
+++ b/test-suite/output/Naming.out
@@ -0,0 +1,83 @@
+1 subgoal
+  
+  x3 : nat
+  ============================
+   forall x x1 x4 x0 : nat,
+   (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0
+1 subgoal
+  
+  x3 : nat
+  x : nat
+  x1 : nat
+  x4 : nat
+  x0 : nat
+  H : forall x x3 : nat, x + x1 = x4 + x3
+  ============================
+   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)
+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
+1 subgoal
+  
+  x3 : nat
+  x : nat
+  x1 : nat
+  x4 : nat
+  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 : nat
+  x : nat
+  x1 : nat
+  x4 : nat
+  x0 : nat
+  H : forall x x3 : nat,
+      x + x1 = x4 + x3 ->
+      forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1)
+  H0 : x + x1 = x4 + x0
+  ============================
+   forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
+1 subgoal
+  
+  x3 : nat
+  x : nat
+  x1 : nat
+  x4 : nat
+  x0 : nat
+  H : forall x x3 : nat,
+      x + x1 = x4 + x3 ->
+      forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1)
+  H0 : x + x1 = x4 + x0
+  x5 : nat
+  x6 : nat
+  x7 : nat
+  S : nat
+  ============================
+   x5 + S = x6 + x7 + Datatypes.S x
+1 subgoal
+  
+  x3 : nat
+  a : nat
+  H : a = 0 -> forall a : nat, a = 0
+  ============================
+   a = 0
diff --git a/test-suite/output/Naming.v b/test-suite/output/Naming.v
new file mode 100644
index 00000000..327643dc
--- /dev/null
+++ b/test-suite/output/Naming.v
@@ -0,0 +1,91 @@
+(* This file checks the compatibility of naming strategy *)
+(* This does not mean that the given naming strategy is good *)
+
+Parameter x2:nat.
+Definition foo y := forall x x3 x4 S, x + S = x3 + x4 + y.
+Section A.
+Variable x3:nat.
+Goal forall x x1 x2 x3:nat,
+  (forall x x3:nat, x+x1 = x2+x3) -> x+x1 = x2+x3.
+Show.
+intros.
+Show.
+
+(* Remark: in V8.2, this used to be printed
+
+  x3 : nat
+  ============================
+   forall x x1 x4 x5 : nat,
+   (forall x0 x6 : nat, x0 + x1 = x4 + x6) -> x + x1 = x4 + x5
+
+before intro and
+
+  x3 : nat
+  x : nat
+  x1 : nat
+  x4 : nat
+  x0 : nat
+  H : forall x x3 : nat, x + x1 = x4 + x3
+  ============================
+   x + x1 = x4 + x0
+
+after. From V8.3, the quantified hypotheses are printed the sames as
+they would be intro. However the hypothesis H remains printed
+differently to avoid using the same name in autonomous but nested
+subterms *)
+
+Abort.
+
+Goal forall x x1 x2 x3:nat,
+  (forall x x3:nat, x+x1 = x2+x3 -> foo (S x + x1)) ->
+   x+x1 = x2+x3 -> foo (S x).
+Show.
+unfold foo.
+Show.
+do 4 intro. (* --> x, x1, x4, x0, ... *)
+Show.
+do 2 intro.
+Show.
+do 4 intro.
+Show.
+
+(* Remark: in V8.2, this used to be printed
+
+  x3 : nat
+  ============================
+   forall x x1 x4 x5 : nat,
+   (forall x0 x6 : nat,
+    x0 + x1 = x4 + x6 ->
+    forall x7 x8 x9 S0 : nat, x7 + S0 = x8 + x9 + (S x0 + x1)) ->
+   x + x1 = x4 + x5 -> forall x0 x6 x7 S0 : nat, x0 + S0 = x6 + x7 + S x
+
+before the intros and
+
+  x3 : nat
+  x : nat
+  x1 : nat
+  x4 : nat
+  x0 : nat
+  H : forall x x3 : nat,
+      x + x1 = x4 + x3 ->
+      forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1)
+  H0 : x + x1 = x4 + x0
+  x5 : nat
+  x6 : nat
+  x7 : nat
+  S : nat
+  ============================
+   x5 + S = x6 + x7 + Datatypes.S x
+
+after (note the x5/x0 and the S0/S) *)
+
+Abort.
+
+(* Check naming in hypotheses *)
+
+Goal forall a, (a = 0 -> forall a, a = 0) -> a = 0.
+intros.
+Show.
+apply H with (a:=a). (* test compliance with printing *)
+Abort.
+
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index 42858304..924030ba 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -1,7 +1,7 @@
 true ? 0; 1
      : nat
 if true as x return (x ? nat; bool) then 0 else true
-     : true ? nat; bool
+     : nat
 Defining 'proj1' as keyword
 fun e : nat * nat => proj1 e
      : nat * nat -> nat
@@ -46,6 +46,10 @@ fun x : nat => ifn x is succ n then n else 0
      : bool
 -4
      : Z
+SUM (nat * nat) nat
+     : Set
+FST (0; 1)
+     : Z
 Nil
      : forall A : Type, list A
 NIL:list nat
@@ -57,3 +61,34 @@ Defining 'I' as keyword
      : Z * Z * Z * (Z * Z * Z)
 fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z
      : (Z -> Z -> Z -> Z) -> Z
+plus
+     : nat -> nat -> nat
+S
+     : nat -> nat
+mult
+     : nat -> nat -> nat
+le
+     : nat -> nat -> Prop
+plus
+     : nat -> nat -> nat
+succ
+     : nat -> nat
+mult
+     : nat -> nat -> nat
+le
+     : nat -> nat -> Prop
+fun x : option Z => match x with
+                    | SOME x0 => x0
+                    | NONE => 0
+                    end
+     : option Z -> Z
+fun x : option Z => match x with
+                    | SOME2 x0 => x0
+                    | NONE2 => 0
+                    end
+     : option Z -> Z
+fun x : option Z => match x with
+                    | SOME3 x0 => x0
+                    | NONE3 => 0
+                    end
+     : option Z -> Z
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
index b37c3638..f041b9b7 100644
--- a/test-suite/output/Notations.v
+++ b/test-suite/output/Notations.v
@@ -64,26 +64,26 @@ Open Scope nat_scope.
 
 Inductive znat : Set := Zpos (n : nat) | Zneg (m : nat).
 Coercion Zpos: nat >-> znat.
- 
+
 Delimit Scope znat_scope with znat.
 Open Scope znat_scope.
- 
+
 Variable addz : znat -> znat -> znat.
 Notation "z1 + z2" := (addz z1 z2) : znat_scope.
 
   (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit,
-     is printed the same way, and not "S 2 + S 2" as if numeral printing was 
+     is printed the same way, and not "S 2 + S 2" as if numeral printing was
      only tested with coercion still present *)
 
 Check (3+3).
 
 (**********************************************************************)
 (* Check recursive notations                                          *)
- 
+
 Require Import List.
 Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
 Check [1;2;4].
-  
+
 Reserved Notation "( x ; y , .. , z )" (at level 0).
 Notation "( x ; y , .. , z )" := (pair .. (pair x y) .. z).
 Check (1;2,4).
@@ -102,7 +102,7 @@ Check (pred 3).
 Check (fun n => match n with 0 => 0 | S n => n end).
 Check (fun n => match n with S p as x => p | y => 0 end).
 
-Notation "'ifn' x 'is' 'succ' n 'then' t 'else' u" := 
+Notation "'ifn' x 'is' 'succ' n 'then' t 'else' u" :=
   (match x with O => u | S n => t end) (at level 0, u at level 0).
 Check fun x => ifn x is succ n then n else 0.
 
@@ -121,6 +121,18 @@ Notation "- 4" := (-2 + -2).
 Check -4.
 
 (**********************************************************************)
+(* Check preservation of scopes at printing time *)
+
+Notation SUM := sum.
+Check SUM (nat*nat) nat.
+
+(**********************************************************************)
+(* Check preservation of implicit arguments at printing time *)
+
+Notation FST := fst.
+Check FST (0;1).
+
+(**********************************************************************)
 (* Check notations for references with activated or deactivated       *)
 (* implicit arguments                                                 *)
 
@@ -159,3 +171,38 @@ Check [|1,2,3;4,5,6|].
 
 Notation "{| f ; x ; .. ; y |}" := ( .. (f x) .. y).
 Check fun f => {| f; 0; 1; 2 |} : Z.
+
+(**********************************************************************)
+(* Check printing of notations from other modules *)
+
+(* 1- Non imported case *)
+
+Require make_notation.
+
+Check plus.
+Check S.
+Check mult.
+Check le.
+
+(* 2- Imported case *)
+
+Import make_notation.
+
+Check plus.
+Check S.
+Check mult.
+Check le.
+
+(* Check notations in cases patterns *)
+
+Notation SOME := Some.
+Notation NONE := None.
+Check (fun x => match x with SOME x => x | NONE => 0 end).
+
+Notation NONE2 := (@None _).
+Notation SOME2 := (@Some _).     
+Check (fun x => match x with SOME2 x => x | NONE2 => 0 end).
+
+Notation NONE3 := @None.
+Notation SOME3 := @Some.     
+Check (fun x => match x with SOME3 x => x | NONE3 => 0 end).
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
new file mode 100644
index 00000000..20d20d82
--- /dev/null
+++ b/test-suite/output/Notations2.out
@@ -0,0 +1,12 @@
+2 3
+     : PAIR
+2[+]3
+     : nat
+forall (A : Set) (le : A -> A -> Prop) (x y : A), le x y \/ le y x
+     : Prop
+match (0, 0, 0) with
+| (x, y, z) => x + y + z
+end
+     : nat
+let '(a, _, _) := (2, 3, 4) in a
+     : nat
diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v
new file mode 100644
index 00000000..2e136edf
--- /dev/null
+++ b/test-suite/output/Notations2.v
@@ -0,0 +1,26 @@
+(**********************************************************************)
+(* Test call to primitive printers in presence of coercion to         *)
+(* functions (cf bug #2044)                                           *)
+
+Inductive PAIR := P (n1:nat) (n2:nat).
+Coercion P : nat >-> Funclass.
+Check (2 3).
+
+(* Check that notations with coercions to functions inserted still work *)
+(* (were not working from revision 11886 to 12951) *)
+
+Record Binop := { binop :> nat -> nat -> nat }.
+Class Plusop := { plusop : Binop; zero : nat }.
+Infix "[+]" := plusop (at level 40).
+Instance Plus : Plusop := {| plusop := {| binop := plus |} ; zero := 0 |}.
+Check 2[+]3.
+
+(* Test bug #2091 (variable le was printed using <= !) *)
+
+Check forall (A: Set) (le: A -> A -> Prop) (x y: A), le x y \/ le y x.
+
+(* Test recursive notations in cases pattern *)
+
+Remove Printing Let prod.
+Check match (0,0,0) with (x,y,z) => x+y+z end.
+Check let '(a,b,c) := ((2,3),4) in a.
diff --git a/test-suite/output/NumbersSyntax.out b/test-suite/output/NumbersSyntax.out
new file mode 100644
index 00000000..b2a44fb7
--- /dev/null
+++ b/test-suite/output/NumbersSyntax.out
@@ -0,0 +1,67 @@
+I31
+     : digits31 int31
+2
+     : int31
+660865024
+     : int31
+2 + 2
+     : int31
+2 + 2
+     : int31
+     = 4
+     : int31
+     = 710436486
+     : int31
+2
+     : BigN.t_
+1000000000000000000
+     : BigN.t_
+2 + 2
+     : BigN.t_
+2 + 2
+     : BigN.t_
+     = 4
+     : BigN.t_
+     = 37151199385380486
+     : BigN.t_
+     = 1267650600228229401496703205376
+     : BigN.t_
+2
+     : BigZ.t_
+-1000000000000000000
+     : BigZ.t_
+2 + 2
+     : BigZ.t_
+2 + 2
+     : BigZ.t_
+     = 4
+     : BigZ.t_
+     = 37151199385380486
+     : BigZ.t_
+     = 1267650600228229401496703205376
+     : BigZ.t_
+2
+     : BigQ.t_
+-1000000000000000000
+     : BigQ.t_
+2 + 2
+     : bigQ
+2 + 2
+     : bigQ
+     = 4
+     : bigQ
+     = 37151199385380486
+     : bigQ
+6562 # 456
+     : BigQ.t_
+     = 3281 # 228
+     : bigQ
+     = -1 # 10000
+     : bigQ
+     = 100
+     : bigQ
+     = 515377520732011331036461129765621272702107522001
+       # 1267650600228229401496703205376
+     : bigQ
+     = 1
+     : bigQ
diff --git a/test-suite/output/NumbersSyntax.v b/test-suite/output/NumbersSyntax.v
new file mode 100644
index 00000000..4fbf56ab
--- /dev/null
+++ b/test-suite/output/NumbersSyntax.v
@@ -0,0 +1,50 @@
+
+Require Import BigQ.
+
+Open Scope int31_scope.
+Check I31. (* Would be nice to have I31 : digits->digits->...->int31
+              For the moment, I31 : digits31 int31, which is better
+	      than (fix nfun .....) size int31 *)
+Check 2.
+Check 1000000000000000000. (* = 660865024, after modulo 2^31 *)
+Check (add31 2 2).
+Check (2+2).
+Eval vm_compute in 2+2.
+Eval vm_compute in 65675757 * 565675998.
+Close Scope int31_scope.
+
+Open Scope bigN_scope.
+Check 2.
+Check 1000000000000000000.
+Check (BigN.add 2 2).
+Check (2+2).
+Eval vm_compute in 2+2.
+Eval vm_compute in 65675757 * 565675998.
+Eval vm_compute in 2^100.
+Close Scope bigN_scope.
+
+Open Scope bigZ_scope.
+Check 2.
+Check -1000000000000000000.
+Check (BigZ.add 2 2).
+Check (2+2).
+Eval vm_compute in 2+2.
+Eval vm_compute in 65675757 * 565675998.
+Eval vm_compute in (-2)^100.
+Close Scope bigZ_scope.
+
+Open Scope bigQ_scope.
+Check 2.
+Check -1000000000000000000.
+Check (BigQ.add 2 2).
+Check (2+2).
+Eval vm_compute in 2+2.
+Eval vm_compute in 65675757 * 565675998.
+(* fractions *)
+Check (6562 # 456). (* Nota: # is BigQ.Qq i.e. base fractions *)
+Eval vm_compute in (BigQ.red (6562 # 456)).
+Eval vm_compute in (1/-10000).
+Eval vm_compute in (BigQ.red (1/(1/100))). (* back to integers... *)
+Eval vm_compute in ((2/3)^(-100)).
+Eval vm_compute in BigQ.red ((2/3)^(-1000) * (2/3)^(1000)).
+Close Scope bigQ_scope.
diff --git a/test-suite/output/Quote.out b/test-suite/output/Quote.out
new file mode 100644
index 00000000..ca7fc362
--- /dev/null
+++ b/test-suite/output/Quote.out
@@ -0,0 +1,24 @@
+(interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (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))))))
+1 subgoal
+  
+  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)))))
+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)))))
diff --git a/test-suite/output/Quote.v b/test-suite/output/Quote.v
new file mode 100644
index 00000000..2c373d50
--- /dev/null
+++ b/test-suite/output/Quote.v
@@ -0,0 +1,36 @@
+Require Import Quote.
+
+Parameter A B : Prop.
+
+Inductive formula : Type :=
+  | f_and : formula -> formula -> formula
+  | f_or : formula -> formula -> formula
+  | f_not : formula -> formula
+  | f_true : formula
+  | f_atom : index -> formula
+  | f_const : Prop -> formula.
+
+Fixpoint interp_f (vm:
+                    varmap Prop) (f:formula) {struct f} : Prop :=
+  match f with
+  | f_and f1 f2 => interp_f vm f1 /\ interp_f vm f2
+  | f_or f1 f2 => interp_f vm f1 \/ interp_f vm f2
+  | f_not f1 => ~ interp_f vm f1
+  | f_true => True
+  | f_atom i => varmap_find True i vm
+  | f_const c => c
+  end.
+
+Goal A \/ B -> A /\ (B \/ A) /\ (A \/ ~ B).
+intro H.
+match goal with
+  | H : ?a \/ ?b |- _ => quote interp_f in a using (fun x => idtac x; change (x \/ b) in H)
+end.
+match goal with
+  |- ?g => quote interp_f [ A ] in g using (fun x => idtac x)
+end.
+quote interp_f.
+Show.
+simpl; quote interp_f [ A ].
+Show.
+Admitted.
diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out
new file mode 100644
index 00000000..99e736dd
--- /dev/null
+++ b/test-suite/output/Search.out
@@ -0,0 +1,36 @@
+le_S: forall n m : nat, n <= m -> n <= S m
+le_n: forall n : nat, n <= n
+false: bool
+true: bool
+sumor_beq:
+  forall (A : Type) (B : Prop),
+  (A -> A -> bool) -> (B -> B -> bool) -> A + {B} -> A + {B} -> bool
+sumbool_beq:
+  forall A B : Prop,
+  (A -> A -> bool) -> (B -> B -> bool) -> {A} + {B} -> {A} + {B} -> bool
+xorb: bool -> bool -> bool
+sum_beq:
+  forall A B : Type,
+  (A -> A -> bool) -> (B -> B -> bool) -> A + B -> A + B -> bool
+prod_beq:
+  forall A B : Type,
+  (A -> A -> bool) -> (B -> B -> bool) -> A * B -> A * B -> bool
+orb: bool -> bool -> bool
+option_beq: forall A : Type, (A -> A -> bool) -> option A -> option A -> bool
+negb: bool -> bool
+nat_beq: nat -> nat -> bool
+list_beq: forall A : Type, (A -> A -> bool) -> list A -> list A -> bool
+implb: bool -> bool -> bool
+comparison_beq: comparison -> comparison -> bool
+bool_beq: bool -> bool -> bool
+andb: bool -> bool -> bool
+Empty_set_beq: Empty_set -> Empty_set -> bool
+pred_Sn: forall n : nat, n = pred (S n)
+plus_n_Sm: forall n m : nat, S (n + m) = n + S m
+plus_n_O: forall n : nat, n = n + 0
+plus_Sn_m: forall n m : nat, S n + m = S (n + m)
+plus_O_n: forall n : nat, 0 + n = n
+mult_n_Sm: forall n m : nat, n * m + n = n * S m
+mult_n_O: forall n : nat, 0 = n * 0
+eq_add_S: forall n m : nat, S n = S m -> n = m
+eq_S: forall x y : nat, x = y -> S x = S y
diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v
new file mode 100644
index 00000000..f1489f22
--- /dev/null
+++ b/test-suite/output/Search.v
@@ -0,0 +1,5 @@
+(* Some tests of the Search command *)
+
+Search le.				(* app nodes *)
+Search bool. 				(* no apps *)
+Search (@eq nat).			(* complex pattern *)
diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out
new file mode 100644
index 00000000..1a87f4cc
--- /dev/null
+++ b/test-suite/output/SearchPattern.out
@@ -0,0 +1,44 @@
+false: bool
+true: bool
+sumor_beq:
+  forall (A : Type) (B : Prop),
+  (A -> A -> bool) -> (B -> B -> bool) -> A + {B} -> A + {B} -> bool
+sumbool_beq:
+  forall A B : Prop,
+  (A -> A -> bool) -> (B -> B -> bool) -> {A} + {B} -> {A} + {B} -> bool
+xorb: bool -> bool -> bool
+sum_beq:
+  forall A B : Type,
+  (A -> A -> bool) -> (B -> B -> bool) -> A + B -> A + B -> bool
+prod_beq:
+  forall A B : Type,
+  (A -> A -> bool) -> (B -> B -> bool) -> A * B -> A * B -> bool
+orb: bool -> bool -> bool
+option_beq: forall A : Type, (A -> A -> bool) -> option A -> option A -> bool
+negb: bool -> bool
+nat_beq: nat -> nat -> bool
+list_beq: forall A : Type, (A -> A -> bool) -> list A -> list A -> bool
+implb: bool -> bool -> bool
+comparison_beq: comparison -> comparison -> bool
+bool_beq: bool -> bool -> bool
+andb: bool -> bool -> bool
+Empty_set_beq: Empty_set -> Empty_set -> bool
+S: nat -> nat
+O: nat
+pred: nat -> nat
+plus: nat -> nat -> nat
+mult: nat -> nat -> nat
+minus: nat -> nat -> nat
+length: forall A : Type, list A -> nat
+S: nat -> nat
+pred: nat -> nat
+plus: nat -> nat -> nat
+mult: nat -> nat -> nat
+minus: nat -> nat -> nat
+mult_n_Sm: forall n m : nat, n * m + n = n * S m
+le_n: forall n : nat, n <= n
+eq_refl: forall (A : Type) (x : A), x = x
+identity_refl: forall (A : Type) (a : A), identity a a
+iff_refl: forall A : Prop, A <-> A
+conj: forall A B : Prop, A -> B -> A /\ B
+pair: forall A B : Type, A -> B -> A * B
diff --git a/test-suite/output/SearchPattern.v b/test-suite/output/SearchPattern.v
new file mode 100644
index 00000000..802d8c97
--- /dev/null
+++ b/test-suite/output/SearchPattern.v
@@ -0,0 +1,19 @@
+(* Some tests of the SearchPattern command *)
+
+(* Simple, random tests *)
+SearchPattern bool.
+SearchPattern nat.
+SearchPattern le.
+
+(* With some hypothesis *)
+SearchPattern (nat -> nat).
+SearchPattern (?n * ?m + ?n = ?n * S ?m).
+
+(* Non-linearity *)
+SearchPattern (_ ?X ?X).
+
+(* Non-linearity with hypothesis *)
+SearchPattern (forall (x:?A) (y:?B), _ ?A ?B).
+
+(* No delta-reduction *)
+SearchPattern (Exc _).
diff --git a/test-suite/output/SearchRewrite.out b/test-suite/output/SearchRewrite.out
new file mode 100644
index 00000000..f87aea1c
--- /dev/null
+++ b/test-suite/output/SearchRewrite.out
@@ -0,0 +1,2 @@
+plus_n_O: forall n : nat, n = n + 0
+plus_O_n: forall n : nat, 0 + n = n
diff --git a/test-suite/output/SearchRewrite.v b/test-suite/output/SearchRewrite.v
new file mode 100644
index 00000000..171a7363
--- /dev/null
+++ b/test-suite/output/SearchRewrite.v
@@ -0,0 +1,4 @@
+(* Some tests of the SearchRewrite command *)
+
+SearchRewrite (_+0). 			(* left *)
+SearchRewrite (0+_). 			(* right *)
diff --git a/test-suite/output/reduction.v b/test-suite/output/reduction.v
index 4a460a83..c4592369 100644
--- a/test-suite/output/reduction.v
+++ b/test-suite/output/reduction.v
@@ -9,5 +9,5 @@ Eval simpl in (fix plus (n m : nat) {struct n} : nat :=
   | S p => S (p + m)
   end) a a.
 
-Eval hnf in match (plus (S n) O) with S n => n | _ => O end.  
+Eval hnf in match (plus (S n) O) with S n => n | _ => O end.
 
diff --git a/test-suite/output/set.out b/test-suite/output/set.out
new file mode 100644
index 00000000..333fbb86
--- /dev/null
+++ b/test-suite/output/set.out
@@ -0,0 +1,21 @@
+1 subgoal
+  
+  y1 := 0 : nat
+  x := 0 + 0 : nat
+  ============================
+   x = x
+1 subgoal
+  
+  y1 := 0 : nat
+  y2 := 0 : nat
+  x := y2 + 0 : nat
+  ============================
+   x = x
+1 subgoal
+  
+  y1 := 0 : nat
+  y2 := 0 : nat
+  y3 := 0 : nat
+  x := y2 + y3 : nat
+  ============================
+   x = x
diff --git a/test-suite/output/set.v b/test-suite/output/set.v
new file mode 100644
index 00000000..0e745354
--- /dev/null
+++ b/test-suite/output/set.v
@@ -0,0 +1,10 @@
+Goal let x:=O+O in x=x.
+intro.
+set (y1:=O) in (type of x).
+Show.
+set (y2:=O) in (value of x) at 1.
+Show.
+set (y3:=O) in (value of x).
+Show.
+trivial.
+Qed.
diff --git a/test-suite/output/simpl.out b/test-suite/output/simpl.out
new file mode 100644
index 00000000..73888da9
--- /dev/null
+++ b/test-suite/output/simpl.out
@@ -0,0 +1,15 @@
+1 subgoal
+  
+  x : nat
+  ============================
+   x = S x
+1 subgoal
+  
+  x : nat
+  ============================
+   0 + x = S x
+1 subgoal
+  
+  x : nat
+  ============================
+   x = 1 + x
diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v
new file mode 100644
index 00000000..5f1926f1
--- /dev/null
+++ b/test-suite/output/simpl.v
@@ -0,0 +1,13 @@
+(* Simpl with patterns *)
+
+Goal forall x, 0+x = 1+x.
+intro x.
+simpl (_ + x).
+Show.
+Undo.
+simpl (_ + x) at 2.
+Show.
+Undo.
+simpl (0 + _).
+Show.
+Undo.
diff --git a/test-suite/prerequisite/make_local.v b/test-suite/prerequisite/make_local.v
new file mode 100644
index 00000000..8700a6c4
--- /dev/null
+++ b/test-suite/prerequisite/make_local.v
@@ -0,0 +1,10 @@
+(* Used in Import.v to test the locality flag *)
+
+Definition f (A:Type) (a:A) := a.
+
+Local Arguments Scope f [type_scope type_scope].
+Local Implicit Arguments f [A].
+
+(* Used in ImportedCoercion.v to test the locality flag *)
+
+Local Coercion g (b:bool) := if b then 0 else 1.
diff --git a/test-suite/prerequisite/make_notation.v b/test-suite/prerequisite/make_notation.v
new file mode 100644
index 00000000..3878e396
--- /dev/null
+++ b/test-suite/prerequisite/make_notation.v
@@ -0,0 +1,15 @@
+(* Used in Notation.v to test import of notations from files in sections *)
+
+Notation "'Z'" := O (at level 9).
+Notation plus := plus.
+Notation succ := S.
+Notation mult := mult (only parsing).
+Notation less := le (only parsing).
+
+(* Test bug 2168: ending section of some name was removing objects of the
+   same name *)
+
+Notation add2 n:=(S n).
+Section add2.
+End add2.
+
diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v
index fc8800a5..ffd50f6e 100644
--- a/test-suite/success/Abstract.v
+++ b/test-suite/success/Abstract.v
@@ -18,7 +18,7 @@ Proof.
 induction n.
  simpl ; apply Dummy0.
  replace (2 * S n0) with (2*n0 + 2) ; auto with arith.
-  apply DummyApp. 
+  apply DummyApp.
    2:exact Dummy2.
    apply IHn0 ; abstract omega.
 Defined.
diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v
index 8e613dca..b533db6e 100644
--- a/test-suite/success/AdvancedCanonicalStructure.v
+++ b/test-suite/success/AdvancedCanonicalStructure.v
@@ -21,7 +21,6 @@ Parameter eq_img : forall (i1:img) (i2:img),
   eqB (ib i1) (ib i2) -> eqA (ia i1) (ia i2).
 
 Lemma phi_img (a:A) : img.
-  intro a.
   exists  a (phi a).
   refine ( refl_equal _).
 Defined.
@@ -54,7 +53,7 @@ Open Scope type_scope.
 
 Section type_reification.
 
-Inductive term :Type := 
+Inductive term :Type :=
    Fun : term -> term -> term
  | Prod : term -> term -> term
  | Bool : term
@@ -63,18 +62,18 @@ Inductive term :Type :=
  | TYPE :term
  | Var : Type -> term.
 
-Fixpoint interp (t:term) := 
-  match t with 
+Fixpoint interp (t:term) :=
+  match t with
     Bool => bool
   | SET => Set
   | PROP => Prop
-  | TYPE => Type   
+  | TYPE => Type
   | Fun a b => interp a -> interp b
   | Prod a b => interp a * interp b
   | Var x => x
 end.
 
-Record interp_pair :Type := 
+Record interp_pair :Type :=
   { repr:>term;
     abs:>Type;
     link: abs = interp repr }.
@@ -95,25 +94,25 @@ thus thesis using rewrite (link a);rewrite (link b);reflexivity.
 end proof.
 Qed.
 
-Canonical Structure ProdCan (a b:interp_pair) := 
+Canonical Structure ProdCan (a b:interp_pair) :=
   Build_interp_pair (Prod a b) (a * b) (prod_interp a b).
 
-Canonical Structure FunCan (a b:interp_pair) := 
+Canonical Structure FunCan (a b:interp_pair) :=
   Build_interp_pair (Fun a b) (a -> b) (fun_interp a b).
 
-Canonical Structure BoolCan := 
+Canonical Structure BoolCan :=
   Build_interp_pair Bool bool (refl_equal _).
 
-Canonical Structure VarCan (x:Type) := 
+Canonical Structure VarCan (x:Type) :=
   Build_interp_pair (Var x) x (refl_equal _).
 
-Canonical Structure SetCan := 
+Canonical Structure SetCan :=
   Build_interp_pair SET Set (refl_equal _).
 
-Canonical Structure PropCan := 
+Canonical Structure PropCan :=
   Build_interp_pair PROP Prop (refl_equal _).
 
-Canonical Structure TypeCan := 
+Canonical Structure TypeCan :=
   Build_interp_pair TYPE Type (refl_equal _).
 
 (* Print Canonical Projections. *)
@@ -140,5 +139,5 @@ End type_reification.
 
 
 
- 
+
 
diff --git a/test-suite/success/AdvancedTypeClasses.v b/test-suite/success/AdvancedTypeClasses.v
new file mode 100644
index 00000000..b4efa7ed
--- /dev/null
+++ b/test-suite/success/AdvancedTypeClasses.v
@@ -0,0 +1,78 @@
+Generalizable All Variables.
+
+Open Scope type_scope.
+
+Section type_reification.
+
+Inductive term :Type :=
+   Fun : term -> term -> term
+ | Prod : term -> term -> term
+ | Bool : term
+ | SET :term
+ | PROP :term
+ | TYPE :term
+ | Var : Type -> term.
+
+Fixpoint interp (t:term) :=
+  match t with
+    Bool => bool
+  | SET => Set
+  | PROP => Prop
+  | TYPE => Type
+  | Fun a b => interp a -> interp b
+  | Prod a b => interp a * interp b
+  | Var x => x
+end.
+
+Class interp_pair (abs : Type) :=
+ { repr : term;
+  link: abs = interp repr }.
+
+Implicit Arguments repr [[interp_pair]].
+Implicit Arguments link [[interp_pair]].
+
+Lemma prod_interp `{interp_pair a, interp_pair b} : a * b = interp (Prod (repr a) (repr b)).
+  simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity.
+Qed.
+
+Lemma fun_interp :forall `{interp_pair a, interp_pair b}, (a -> b) = interp (Fun (repr a) (repr b)).
+  simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity.
+Qed.
+
+Coercion repr : interp_pair >-> term.
+
+Definition abs `{interp_pair a} : Type := a.
+Coercion abs : interp_pair >-> Sortclass.
+
+Lemma fun_interp' :forall `{ia : interp_pair, ib : interp_pair}, (ia -> ib) = interp (Fun ia ib).
+  simpl. intros a ia b ib. rewrite <- link. rewrite <- (link b). reflexivity.
+Qed.
+
+Instance ProdCan `(interp_pair a, interp_pair b) : interp_pair (a * b) :=
+  { repr := Prod (repr a) (repr b) ; link := prod_interp }.
+
+Instance FunCan `(interp_pair a, interp_pair b) : interp_pair (a -> b) :=
+  { link := fun_interp }.
+
+Instance BoolCan : interp_pair bool :=
+  { repr := Bool ; link := refl_equal _ }.
+
+Instance VarCan x : interp_pair x | 10 := { repr := Var x ; link := refl_equal _ }.
+Instance SetCan : interp_pair Set := { repr := SET ; link := refl_equal _ }.
+Instance PropCan : interp_pair Prop := { repr := PROP ; link := refl_equal _ }.
+Instance TypeCan : interp_pair Type := { repr := TYPE ; link := refl_equal _ }.
+
+(* Print Canonical Projections. *)
+
+Variable A:Type.
+
+Variable Inhabited: term -> Prop.
+
+Variable Inhabited_correct: forall `{interp_pair p}, Inhabited (repr p) -> p.
+
+Lemma L : Prop * A -> bool * (Type -> Set) .
+apply (Inhabited_correct _ _).
+change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))).
+Admitted.
+
+End type_reification.
diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v
index f6a0d578..729ab824 100644
--- a/test-suite/success/Case12.v
+++ b/test-suite/success/Case12.v
@@ -62,10 +62,10 @@ Check
 
 Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set :=
   | nil''' : list''' A a (a,a)
-  | cons''' : 
+  | cons''' :
      forall a' : A, let m := (a',a) in list''' A a m -> list''' A a (a,a).
 
-Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) 
+Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m)
   {struct l} : nat :=
   match l with
   | nil''' => 0
diff --git a/test-suite/success/Case15.v b/test-suite/success/Case15.v
index 8431880d..69fca48e 100644
--- a/test-suite/success/Case15.v
+++ b/test-suite/success/Case15.v
@@ -12,7 +12,7 @@ Check
 
 (* Suggested by Pierre Letouzey (PR#207) *)
 Inductive Boite : Set :=
-    boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite. 
+    boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite.
 
 Definition test (B : Boite) :=
   match B return nat with
@@ -30,7 +30,7 @@ Check [x]
   end.
 
 Check [x]
-  Cases x of 
+  Cases x of
     (c true true) => true
   | (c false O) => true
   | _ => false
@@ -40,7 +40,7 @@ Check [x]
 Check
   [x:I]
    Cases x of
-     (c b y) => 
+     (c b y) =>
       (<[b:bool](if b then bool else nat)->bool>if b
        then [y](if y then true else false)
        else [y]Cases y of
diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v
index 061e136e..66af9e0d 100644
--- a/test-suite/success/Case17.v
+++ b/test-suite/success/Case17.v
@@ -11,7 +11,7 @@ Variables (l0 : list bool)
   (rec :
      forall l' : list bool,
      length l' <= S (length l0) ->
-     {l'' : list bool & 
+     {l'' : list bool &
      {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} +
      {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}).
 
@@ -25,17 +25,17 @@ Check
    | inleft (existS _ _) => inright _ (HHH _)
    | inright Hnp => inright _ (HHH _)
    end
-   :{l'' : list bool & 
+   :{l'' : list bool &
     {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} +
     {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}).
- 
+
 (* The same but with relative links to l0 and rec *)
- 
+
 Check
   (fun (l0 : list bool)
      (rec : forall l' : list bool,
             length l' <= S (length l0) ->
-            {l'' : list bool & 
+            {l'' : list bool &
             {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} +
             {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) =>
    match rec l0 (HHH _) with
@@ -45,6 +45,6 @@ Check
    | inleft (existS _ _) => inright _ (HHH _)
    | inright Hnp => inright _ (HHH _)
    end
-   :{l'' : list bool & 
+   :{l'' : list bool &
     {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} +
     {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}).
diff --git a/test-suite/ideal-features/Case3.v b/test-suite/success/Case3.v
index de7784ae..de7784ae 100644
--- a/test-suite/ideal-features/Case3.v
+++ b/test-suite/success/Case3.v
diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v
index 499c0660..e63972ce 100644
--- a/test-suite/success/Cases.v
+++ b/test-suite/success/Cases.v
@@ -31,10 +31,11 @@ Type
 (* Interaction with coercions *)
 Parameter bool2nat : bool -> nat.
 Coercion bool2nat : bool >-> nat.
-Check (fun x => match x with
-                | O => true
-                | S _ => 0
-                end:nat).
+Definition foo : nat -> nat :=
+  fun x => match x with
+             | O => true
+             | S _ => 0
+           end.
 
 (****************************************************************************)
 (* All remaining examples come from Cristina Cornes' V6 TESTS/MultCases.v   *)
@@ -255,7 +256,7 @@ Type match 0, 1 return nat with
 Type match 0, 1 with
      | x, y => x + y
      end.
- 
+
 Type match 0, 1 return nat with
      | O, y => y
      | S x, y => x + y
@@ -522,7 +523,7 @@ Type
    | O, _ => 0
    | S _, _ => c
    end).
-         
+
 
 (* Rows of pattern variables: some tricky cases *)
 Axioms (P : nat -> Prop) (f : forall n : nat, P n).
@@ -612,14 +613,14 @@ Type
 
 (*
 Type [A:Set][n:nat][l:(Listn A n)]
-                   <[_:nat](Listn A O)>Cases l of 
+                   <[_:nat](Listn A O)>Cases l of
                          (Niln  as b) => b
                       | (Consn  n a (Niln  as b))=> (Niln A)
                       | (Consn  n a (Consn m b l)) => (Niln A)
                       end.
 
 Type [A:Set][n:nat][l:(Listn A n)]
-                    Cases l of 
+                    Cases l of
                          (Niln  as b) => b
                       | (Consn  n a (Niln  as b))=> (Niln A)
                       | (Consn  n a (Consn m b l)) => (Niln A)
@@ -627,9 +628,9 @@ Type [A:Set][n:nat][l:(Listn A n)]
 *)
 (******** This example rises an error unconstrained_variables!
 Type [A:Set][n:nat][l:(Listn A n)]
-                    Cases l of 
+                    Cases l of
                          (Niln  as b) => (Consn A O O b)
-                      | ((Consn  n a Niln) as L) =>  L 
+                      | ((Consn  n a Niln) as L) =>  L
                       | (Consn  n a _)  =>  (Consn A O O (Niln A))
                       end.
 **********)
@@ -956,7 +957,7 @@ Definition length3 (n : nat) (l : listn n) :=
   | _ => 0
   end.
 
- 
+
 Type match LeO 0 return nat with
      | LeS n m h => n + m
      | x => 0
@@ -1071,10 +1072,10 @@ Type
    | Consn _ _ _ as b => b
    end).
 
-(** Horrible error message! 
+(** Horrible error message!
 
 Type [A:Set][n:nat][l:(Listn A n)]
-                        Cases l of 
+                        Cases l of
                         (Niln as b) => b
                       | ((Consn _ _ _ ) as b)=>  b
                       end.
@@ -1179,7 +1180,7 @@ Type (fun n : nat => match test n with
 Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}.
 Type
   match compare 0 0 return nat with
-  
+
       (* k<i *) | inleft (left _) => 0
    (* k=i *) | inleft _ => 0
    (* k>i *) | inright _ => 0
@@ -1187,7 +1188,7 @@ Type
 
 Type
   match compare 0 0 with
-  
+
       (* k<i *) | inleft (left _) => 0
    (* k=i *) | inleft _ => 0
    (* k>i *) | inright _ => 0
@@ -1374,7 +1375,7 @@ Type
   | var, var => True
   | oper op1 l1, oper op2 l2 => False
   | _, _ => False
-  end. 
+  end.
 Reset LTERM.
 
 
@@ -1660,7 +1661,7 @@ Type
    | Cons a x, Cons b y => V4 a x b y
    end).
 
- 
+
 (* ===================================== *)
 
 Inductive Eqlong :
@@ -1724,7 +1725,7 @@ Parameter
 
 
 
-Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat) 
+Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat)
  (y : listn m) {struct x} : Eqlong n x m y \/ ~ Eqlong n x m y :=
   match
     x in (listn n), y in (listn m)
diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v
index 49bd77fc..29721843 100644
--- a/test-suite/success/CasesDep.v
+++ b/test-suite/success/CasesDep.v
@@ -38,29 +38,29 @@ Require Import Logic_Type.
 
 Section Orderings.
    Variable U : Type.
-   
+
    Definition Relation := U -> U -> Prop.
 
    Variable R : Relation.
-   
+
    Definition Reflexive : Prop := forall x : U, R x x.
-   
+
    Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z.
-   
+
    Definition Symmetric : Prop := forall x y : U, R x y -> R y x.
-   
+
    Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y.
-   
+
    Definition contains (R R' : Relation) : Prop :=
      forall x y : U, R' x y -> R x y.
   Definition same_relation (R R' : Relation) : Prop :=
     contains R R' /\ contains R' R.
 Inductive Equivalence : Prop :=
     Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence.
-   
+
    Inductive PER : Prop :=
        Build_PER : Symmetric -> Transitive -> PER.
-   
+
 End Orderings.
 
 (***** Setoid  *******)
@@ -105,7 +105,7 @@ Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq.
 
 End Maps.
 
-Notation ap := (explicit_ap _ _). 
+Notation ap := (explicit_ap _ _).
 
 (* <Warning> : Grammar is replaced by Notation *)
 
@@ -128,8 +128,8 @@ Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m.
 
 Definition pred (n : posint) : posint :=
   match n return posint with
-  | Z => (* Z *)  Z 
-      (* Suc u *) 
+  | Z => (* Z *)  Z
+      (* Suc u *)
   | Suc u => u
   end.
 
@@ -141,7 +141,7 @@ Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m.
 Definition IsSuc (n : posint) : Prop :=
   match n return Prop with
   | Z => (* Z *)  False
-      (* Suc p *) 
+      (* Suc p *)
   | Suc p => True
   end.
 Definition IsZero (n : posint) : Prop :=
@@ -163,7 +163,7 @@ Definition Decidable (A : Type) (R : Relation A) :=
   forall x y : A, R x y \/ ~ R x y.
 
 
-Record DSetoid : Type := 
+Record DSetoid : Type :=
   {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}.
 
 (* example de Dsetoide d'entiers *)
@@ -190,7 +190,7 @@ Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci.
 
 Section Sig.
 
-Record Signature : Type := 
+Record Signature : Type :=
   {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}.
 
 Variable S : Signature.
@@ -268,8 +268,8 @@ Reset equalT.
 
 Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
   match t1 return (TERM -> Prop) with
-  | var v1 => 
-      (*var*) 
+  | var v1 =>
+      (*var*)
       fun t2 : TERM =>
       match t2 return Prop with
       | var v2 =>
@@ -289,12 +289,12 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
           EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
       end
   end
- 
+
  with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
  forall n2 : posint, LTERM n2 -> Prop :=
   match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with
   | nil =>
-      (*nil*) 
+      (*nil*)
       fun (n2 : posint) (l2 : LTERM n2) =>
       match l2 in (LTERM _) return Prop with
       | nil =>
@@ -336,7 +336,7 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
           EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
       end
   end
- 
+
  with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
  forall n2 : posint, LTERM n2 -> Prop :=
   match l1 return (forall n2 : posint, LTERM n2 -> Prop) with
@@ -374,8 +374,8 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
           EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
       end
   end
- 
- with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) 
+
+ with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
  (l2 : LTERM n2) {struct l1} : Prop :=
   match l1 with
   | nil => match l2 with
@@ -401,8 +401,8 @@ Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
       equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
   | _, _ => False
   end
- 
- with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) 
+
+ with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
  (l2 : LTERM n2) {struct l1} : Prop :=
   match l1, l2 with
   | nil, nil => True
@@ -433,16 +433,16 @@ Inductive I : unit -> Type :=
 | C : forall a, I a -> I tt.
 
 (*
-Definition F (l:I tt) : l = l := 
+Definition F (l:I tt) : l = l :=
 match l return l = l with
 | C tt (C _ l')  => refl_equal (C tt (C _ l'))
 end.
 
 one would expect that the compilation of F (this involves
-some kind of pattern-unification) would produce: 
+some kind of pattern-unification) would produce:
 *)
 
-Definition F (l:I tt) : l = l := 
+Definition F (l:I tt) : l = l :=
 match l return l = l with
 | C tt l' => match l' return C _ l' = C _ l' with C _ l''  => refl_equal (C tt (C _ l'')) end
 end.
@@ -451,7 +451,7 @@ Inductive J : nat -> Type :=
 | D : forall a, J (S a) -> J a.
 
 (*
-Definition G (l:J O) : l = l := 
+Definition G (l:J O) : l = l :=
 match l return l = l with
 | D O (D 1 l')  => refl_equal (D O (D 1 l'))
 | D _ _  => refl_equal _
@@ -461,7 +461,7 @@ one would expect that the compilation of G (this involves inversion)
 would produce:
 *)
 
-Definition G (l:J O) : l = l := 
+Definition G (l:J O) : l = l :=
 match l return l = l with
 | D 0 l'' =>
     match l'' as _l'' in J n return
@@ -480,3 +480,29 @@ Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) :=
     | niln => w
     | consn a n' v' => consn _ a _ (app v' w)
   end.
+
+(* Testing regression of bug 2106 *)
+
+Set Implicit Arguments.
+Require Import List.
+
+Inductive nt := E.
+Definition root := E.
+Inductive ctor : list nt -> nt -> Type :=
+ Plus : ctor (cons E (cons E nil)) E.
+
+Inductive term : nt -> Type :=
+| Term : forall s n, ctor s n -> spine s -> term n
+with spine : list nt -> Type :=
+| EmptySpine : spine nil
+| ConsSpine : forall n s, term n -> spine s -> spine (n :: s).
+
+Inductive step : nt -> nt -> Type :=
+  | Step : forall l n r n' (c:ctor (l++n::r) n'), spine l -> spine r -> step n
+n'.
+
+Definition test (s:step E E) :=
+  match s with
+    | Step nil _ (cons E nil) _ Plus l l' => true
+    | _ => false
+  end.
diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v
index b57c5478..dffad323 100644
--- a/test-suite/success/Discriminate.v
+++ b/test-suite/success/Discriminate.v
@@ -2,11 +2,11 @@
 
 (* Check that Discriminate tries Intro until *)
 
-Lemma l1 : 0 = 1 -> False.   
+Lemma l1 : 0 = 1 -> False.
  discriminate 1.
 Qed.
 
-Lemma l2 : forall H : 0 = 1, H = H.   
+Lemma l2 : forall H : 0 = 1, H = H.
  discriminate H.
 Qed.
 
diff --git a/test-suite/success/Equations.v b/test-suite/success/Equations.v
deleted file mode 100644
index e31135c2..00000000
--- a/test-suite/success/Equations.v
+++ /dev/null
@@ -1,321 +0,0 @@
-Require Import Program.
-
-Equations neg (b : bool) : bool :=
-neg true := false ;
-neg false := true.
- 
-Eval compute in neg.
-
-Require Import Coq.Lists.List.
-
-Equations head A (default : A) (l : list A) : A :=
-head A default nil := default ;
-head A default (cons a v) := a.
-
-Eval compute in head.
-
-Equations tail {A} (l : list A) : (list A) :=
-tail A nil := nil ;
-tail A (cons a v) := v.
-
-Eval compute in @tail.
-
-Eval compute in (tail (cons 1 nil)).
-
-Reserved Notation " x ++ y " (at level 60, right associativity).
-
-Equations app' {A} (l l' : list A) : (list A) :=
-app' A nil l := l ;
-app' A (cons a v) l := cons a (app' v l).
-
-Equations app (l l' : list nat) : list nat :=
-  [] ++ l       := l ;
-  (a :: v) ++ l := a :: (v ++ l) 
-
-where " x ++ y " := (app x y).
-
-Eval compute in @app'.
-
-Equations zip' {A} (f : A -> A -> A) (l l' : list A) : (list A) :=
-zip' A f nil nil := nil ;
-zip' A f (cons a v) (cons b w) := cons (f a b) (zip' f v w) ;
-zip' A f nil (cons b w) := nil ;
-zip' A f (cons a v) nil := nil.
-
-
-Eval compute in @zip'.
-
-Equations zip'' {A} (f : A -> A -> A) (l l' : list A) (def : list A) : (list A) :=
-zip'' A f nil nil def := nil ;
-zip'' A f (cons a v) (cons b w) def := cons (f a b) (zip'' f v w def) ;
-zip'' A f nil (cons b w) def := def ;
-zip'' A f (cons a v) nil def := def.
-
-Eval compute in @zip''.
-
-Inductive fin : nat -> Set :=
-| fz : Π {n}, fin (S n)
-| fs : Π {n}, fin n -> fin (S n).
-
-Inductive finle : Π (n : nat) (x : fin n) (y : fin n), Prop :=
-| leqz : Π {n j}, finle (S n) fz j
-| leqs : Π {n i j}, finle n i j -> finle (S n) (fs i) (fs j).
-
-Scheme finle_ind_dep := Induction for finle Sort Prop.
-
-Instance finle_ind_pack n x y : DependentEliminationPackage (finle n x y) :=
-  { elim_type := _ ; elim := finle_ind_dep }.
-
-Implicit Arguments finle [[n]].
-
-Require Import Bvector.
-
-Implicit Arguments Vnil [[A]].
-Implicit Arguments Vcons [[A] [n]].
-
-Equations vhead {A n} (v : vector A (S n)) : A := 
-vhead A n (Vcons a v) := a.
-
-Equations vmap {A B} (f : A -> B) {n} (v : vector A n) : (vector B n) :=
-vmap A B f 0 Vnil := Vnil ;
-vmap A B f (S n) (Vcons a v) := Vcons (f a) (vmap f v).
-
-Eval compute in (vmap id (@Vnil nat)).
-Eval compute in (vmap id (@Vcons nat 2 _ Vnil)).
-Eval compute in @vmap.
-
-Equations Below_nat (P : nat -> Type) (n : nat) : Type :=
-Below_nat P 0 := unit ;
-Below_nat P (S n) := prod (P n) (Below_nat P n).
-
-Equations below_nat (P : nat -> Type) n (step : Π (n : nat), Below_nat P n -> P n) : Below_nat P n :=
-below_nat P 0 step := tt ;
-below_nat P (S n) step := let rest := below_nat P n step in
-  (step n rest, rest).
-
-Class BelowPack (A : Type) :=
-  { Below : Type ; below : Below }.
-
-Instance nat_BelowPack : BelowPack nat :=
-  { Below := Π P n step, Below_nat P n ;
-    below := λ P n step, below_nat P n (step P) }.
-
-Definition rec_nat (P : nat -> Type) n (step : Π n, Below_nat P n -> P n) : P n :=
-  step n (below_nat P n step).
-
-Fixpoint Below_vector (P : Π A n, vector A n -> Type) A n (v : vector A n) : Type :=
-  match v with Vnil => unit | Vcons a n' v' => prod (P A n' v') (Below_vector P A n' v') end.
-
-Equations below_vector (P : Π A n, vector A n -> Type) A n (v : vector A n)
-  (step : Π A n (v : vector A n), Below_vector P A n v -> P A n v) : Below_vector P A n v :=
-below_vector P A ?(0) Vnil step := tt ;
-below_vector P A ?(S n) (Vcons a v) step := 
-  let rest := below_vector P A n v step in
-    (step A n v rest, rest).
-
-Instance vector_BelowPack : BelowPack (Π A n, vector A n) :=
-  { Below := Π P A n v step, Below_vector P A n v ;
-    below := λ P A n v step, below_vector P A n v (step P) }.
-
-Instance vector_noargs_BelowPack A n : BelowPack (vector A n) :=
-  { Below := Π P v step, Below_vector P A n v ;
-    below := λ P v step, below_vector P A n v (step P) }.
-
-Definition rec_vector (P : Π A n, vector A n -> Type) A n v
-  (step : Π A n (v : vector A n), Below_vector P A n v -> P A n v) : P A n v :=
-  step A n v (below_vector P A n v step).
-
-Class Recursor (A : Type) (BP : BelowPack A) := 
-  { rec_type : Π x : A, Type ; rec : Π x : A, rec_type x }.
-
-Instance nat_Recursor : Recursor nat nat_BelowPack :=
-  { rec_type := λ n, Π P step, P n ;
-    rec := λ n P step, rec_nat P n (step P) }.
-
-(* Instance vect_Recursor : Recursor (Π A n, vector A n) vector_BelowPack := *)
-(*   rec_type := Π (P : Π A n, vector A n -> Type) step A n v, P A n v; *)
-(*   rec := λ P step A n v, rec_vector P A n v step. *)
-
-Instance vect_Recursor_noargs A n : Recursor (vector A n) (vector_noargs_BelowPack A n) :=
-  { rec_type := λ v, Π (P : Π A n, vector A n -> Type) step, P A n v;
-    rec := λ v P step, rec_vector P A n v step }.
-
-Implicit Arguments Below_vector [P A n].
-
-Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity).
-
-(** Won't pass the guardness check which diverges anyway. *)
-
-(* Equations trans {n} {i j k : fin n} (p : finle i j) (q : finle j k) : finle i k := *)
-(* trans ?(S n) ?(fz) ?(j) ?(k) leqz q := leqz ; *)
-(* trans ?(S n) ?(fs i) ?(fs j) ?(fs k) (leqs p) (leqs q) := leqs (trans p q). *)
-
-(* Lemma trans_eq1 n (j k : fin (S n)) (q : finle j k) : trans leqz q = leqz. *)
-(* Proof. intros. simplify_equations ; reflexivity. Qed. *)
-
-(* Lemma trans_eq2 n i j k p q : @trans (S n) (fs i) (fs j) (fs k) (leqs p) (leqs q) = leqs (trans p q). *)
-(* Proof. intros. simplify_equations ; reflexivity. Qed. *)
-
-Section Image.
-  Context {S T : Type}.
-  Variable f : S -> T.
-  
-  Inductive Imf : T -> Type := imf (s : S) : Imf (f s).
-
-  Equations inv (t : T) (im : Imf t) : S :=
-  inv (f s) (imf s) := s.
-
-End Image.
-
-Section Univ.
-
-  Inductive univ : Set :=
-  | ubool | unat | uarrow (from:univ) (to:univ).
-
-  Equations interp (u : univ) : Type :=
-  interp ubool := bool ; interp unat := nat ; 
-  interp (uarrow from to) := interp from -> interp to.
-
-  Equations foo (u : univ) (el : interp u) : interp u :=
-  foo ubool true := false ;
-  foo ubool false := true ;
-  foo unat t := t ;
-  foo (uarrow from to) f := id ∘ f.
-
-  Eval lazy beta delta [ foo foo_obligation_1 foo_obligation_2 ] iota zeta in foo.
-
-End Univ.
-
-Eval compute in (foo ubool false).
-Eval compute in (foo (uarrow ubool ubool) negb).
-Eval compute in (foo (uarrow ubool ubool) id).
-
-Inductive foobar : Set := bar | baz.
-
-Equations bla (f : foobar) : bool :=
-bla bar := true ;
-bla baz := false.
-
-Eval simpl in bla.
-Print refl_equal.
-
-Notation "'refl'" := (@refl_equal _ _).
-
-Equations K {A} (x : A) (P : x = x -> Type) (p : P (refl_equal x)) (p : x = x) : P p :=
-K A x P p refl := p.
-
-Equations eq_sym {A} (x y : A) (H : x = y) : y = x :=
-eq_sym A x x refl := refl.
-
-Equations eq_trans {A} (x y z : A) (p : x = y) (q : y = z) : x = z :=
-eq_trans A x x x refl refl := refl.
-
-Lemma eq_trans_eq A x : @eq_trans A x x x refl refl = refl.
-Proof. reflexivity. Qed.
-
-Equations nth {A} {n} (v : vector A n) (f : fin n) : A :=
-nth A (S n) (Vcons a v) fz := a ;
-nth A (S n) (Vcons a v) (fs f) := nth v f.
-
-Equations tabulate {A} {n} (f : fin n -> A) : vector A n :=
-tabulate A 0 f := Vnil ;
-tabulate A (S n) f := Vcons (f fz) (tabulate (f ∘ fs)).
-
-Equations vlast {A} {n} (v : vector A (S n)) : A :=
-vlast A 0 (Vcons a Vnil) := a ;
-vlast A (S n) (Vcons a (n:=S n) v) := vlast v.
-
-Print Assumptions vlast.
-
-Equations vlast' {A} {n} (v : vector A (S n)) : A :=
-vlast' A ?(0) (Vcons a Vnil) := a ;
-vlast' A ?(S n) (Vcons a (n:=S n) v) := vlast' v.
-
-Lemma vlast_equation1 A (a : A) : vlast' (Vcons a Vnil) = a.
-Proof. intros. simplify_equations. reflexivity. Qed.
-
-Lemma vlast_equation2 A n a v : @vlast' A (S n) (Vcons a v) = vlast' v.
-Proof. intros. simplify_equations ; reflexivity. Qed.
-
-Print Assumptions vlast'.
-Print Assumptions nth. 
-Print Assumptions tabulate.
-
-Extraction vlast.
-Extraction vlast'.
-
-Equations vliat {A} {n} (v : vector A (S n)) : vector A n :=
-vliat A 0 (Vcons a Vnil) := Vnil ;
-vliat A (S n) (Vcons a v) := Vcons a (vliat v).
-
-Eval compute in (vliat (Vcons 2 (Vcons 5 (Vcons 4 Vnil)))).
-
-Equations vapp' {A} {n m} (v : vector A n) (w : vector A m) : vector A (n + m) :=
-vapp' A ?(0) m Vnil w := w ;
-vapp' A ?(S n) m (Vcons a v) w := Vcons a (vapp' v w).
-
-Eval compute in @vapp'.
-
-Fixpoint vapp {A n m} (v : vector A n) (w : vector A m) : vector A (n + m) :=
-  match v with
-    | Vnil => w
-    | Vcons a n' v' => Vcons a (vapp v' w)
-  end.
-
-Lemma JMeq_Vcons_inj A n m a (x : vector A n) (y : vector A m) : n = m -> JMeq x y -> JMeq (Vcons a x) (Vcons a y).
-Proof. intros until y. simplify_dep_elim. reflexivity. Qed.
-
-Equations NoConfusion_fin (P : Prop) {n : nat} (x y : fin n) : Prop :=
-NoConfusion_fin P (S n) fz fz := P -> P ;
-NoConfusion_fin P (S n) fz (fs y) := P ;
-NoConfusion_fin P (S n) (fs x) fz := P ;
-NoConfusion_fin P (S n) (fs x) (fs y) := (x = y -> P) -> P.
-
-Eval compute in NoConfusion_fin.
-Eval compute in NoConfusion_fin_comp.
-
-Print Assumptions NoConfusion_fin.
-
-Eval compute in (fun P n => NoConfusion_fin P (n:=S n) fz fz).
-
-(* Equations noConfusion_fin P (n : nat) (x y : fin n) (H : x = y) : NoConfusion_fin P x y := *)
-(* noConfusion_fin P (S n) fz fz refl := λ p _, p ; *)
-(* noConfusion_fin P (S n) (fs x) (fs x) refl := λ p : x = x -> P, p refl. *)
-
-Equations_nocomp NoConfusion_vect (P : Prop) {A n} (x y : vector A n) : Prop :=
-NoConfusion_vect P A 0 Vnil Vnil := P -> P ;
-NoConfusion_vect P A (S n) (Vcons a x) (Vcons b y) := (a = b -> x = y -> P) -> P.
-
-Equations noConfusion_vect (P : Prop) A n (x y : vector A n) (H : x = y) : NoConfusion_vect P x y :=
-noConfusion_vect P A 0 Vnil Vnil refl := λ p, p ;
-noConfusion_vect P A (S n) (Vcons a v) (Vcons a v) refl := λ p : a = a -> v = v -> P, p refl refl.
-
-(* Instance fin_noconf n : NoConfusionPackage (fin n) := *)
-(*   NoConfusion := λ P, Π x y, x = y -> NoConfusion_fin P x y ; *)
-(*   noConfusion := λ P x y, noConfusion_fin P n x y. *)
-
-Instance vect_noconf A n : NoConfusionPackage (vector A n) :=
-  { NoConfusion := λ P, Π x y, x = y -> NoConfusion_vect P x y ;
-    noConfusion := λ P x y, noConfusion_vect P A n x y }.
-
-Equations fog {n} (f : fin n) : nat :=
-fog (S n) fz := 0 ; fog (S n) (fs f) := S (fog f).
-
-Inductive Split {X : Set}{m n : nat} : vector X (m + n) -> Set :=
-  append : Π (xs : vector X m)(ys : vector X n), Split (vapp xs ys).
-
-Implicit Arguments Split [[X]].
-
-Equations_nocomp split {X : Set}(m n : nat) (xs : vector X (m + n)) : Split m n xs :=
-split X 0    n xs := append Vnil xs ;
-split X (S m) n (Vcons x xs) :=
- let 'append xs' ys' in Split _ _ vec := split m n xs return Split (S m) n (Vcons x vec) in
-    append (Vcons x xs') ys'.
-
-Eval compute in (split 0 1 (vapp Vnil (Vcons 2 Vnil))).
-Eval compute in (split _ _ (vapp (Vcons 3 Vnil) (Vcons 2 Vnil))).
-
-Extraction Inline split_obligation_1 split_obligation_2.
-Recursive Extraction split.
-
-Eval compute in @split.
diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v
index b4c06c7b..dd82036e 100644
--- a/test-suite/success/Field.v
+++ b/test-suite/success/Field.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v 9197 2006-10-02 15:55:52Z barras $ *)
+(* $Id$ *)
 
 (**** Tests of Field with real numbers ****)
 
@@ -31,7 +31,7 @@ Proof.
   intros.
    field.
 Abort.
- 
+
 (* Example 3 *)
 Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a.
 Proof.
@@ -44,7 +44,7 @@ Proof.
   intros.
    field_simplify_eq.
 Abort.
- 
+
 Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
 Proof.
   intros.
@@ -58,21 +58,21 @@ Proof.
   intros.
    field; auto.
 Qed.
- 
+
 (* Example 5 *)
 Goal forall a : R, 1 = 1 * (1 / a) * a.
 Proof.
   intros.
    field.
 Abort.
- 
+
 (* Example 6 *)
 Goal forall a b : R, b = b * / a * a.
 Proof.
   intros.
    field.
 Abort.
- 
+
 (* Example 7 *)
 Goal forall a b : R, b = b * (1 / a) * a.
 Proof.
@@ -81,11 +81,17 @@ Proof.
 Abort.
 
 (* Example 8 *)
-Goal
-forall x y : R,
-x * (1 / x + x / (x + y)) =
-- (1 / y) * y * (- (x * (x / (x + y))) - 1).
+Goal forall x y : R,
+  x * (1 / x + x / (x + y)) =
+  - (1 / y) * y * (- (x * (x / (x + y))) - 1).
 Proof.
   intros.
    field.
 Abort.
+
+(* Example 9 *)
+Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a -> False.
+Proof.
+intros.
+field_simplify_eq in H.
+Abort.
diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v
index cf821073..3a4f8899 100644
--- a/test-suite/success/Fixpoint.v
+++ b/test-suite/success/Fixpoint.v
@@ -5,7 +5,7 @@ Inductive listn : nat -> Set :=
 | consn : forall n:nat, nat -> listn n -> listn (S n).
 
 Fixpoint f (n:nat) (m:=pred n) (l:listn m) (p:=S n) {struct l} : nat :=
-   match n with O => p | _ => 
+   match n with O => p | _ =>
      match l with niln => p | consn q _ l => f (S q) l end
    end.
 
@@ -48,3 +48,46 @@ Fixpoint foldrn n bs :=
 
 End folding.
 
+(* Check definition by tactics *)
+
+Set Automatic Introduction.
+
+Inductive even : nat -> Type :=
+  | even_O : even 0
+  | even_S : forall n, odd n -> even (S n)
+with odd : nat -> Type :=
+    odd_S : forall n, even n -> odd (S n).
+
+Fixpoint even_div2 n (H:even n) : nat :=
+  match H with
+  | even_O => 0
+  | even_S n H => S (odd_div2 n H)
+  end
+with odd_div2 n H : nat.
+destruct H.
+apply even_div2 with n.
+assumption.
+Qed.
+
+Fixpoint even_div2' n (H:even n) : nat with odd_div2' n (H:odd n) : nat.
+destruct H.
+exact 0.
+apply odd_div2' with n.
+assumption.
+destruct H.
+apply even_div2' with n.
+assumption.
+Qed.
+
+CoInductive Stream1 (A B:Type) := Cons1 : A -> Stream2 A B -> Stream1 A B
+with Stream2 (A B:Type) := Cons2 : B -> Stream1 A B -> Stream2 A B.
+
+CoFixpoint ex1 (n:nat) (b:bool) : Stream1 nat bool
+with ex2 (n:nat) (b:bool) : Stream2 nat bool.
+apply Cons1.
+exact n.
+apply (ex2 n b).
+apply Cons2.
+exact b.
+apply (ex1 (S n) (negb b)).
+Defined.
diff --git a/test-suite/success/Fourier.v b/test-suite/success/Fourier.v
index 2d184fef..b63bead4 100644
--- a/test-suite/success/Fourier.v
+++ b/test-suite/success/Fourier.v
@@ -1,10 +1,10 @@
 Require Import Rfunctions.
 Require Import Fourier.
- 
+
 Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z).
 intros; split_Rabs; fourier.
 Qed.
- 
+
 Lemma l2 :
  forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1.
 intros.
diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v
index 1c3e56f2..b17adef6 100644
--- a/test-suite/success/Funind.v
+++ b/test-suite/success/Funind.v
@@ -6,7 +6,7 @@ Definition iszero (n : nat) : bool :=
   end.
 
 Functional Scheme iszero_ind := Induction for iszero Sort Prop.
- 
+
 Lemma toto : forall n : nat, n = 0 -> iszero n = true.
 intros x eg.
  functional induction iszero x; simpl in |- *.
@@ -14,7 +14,7 @@ trivial.
 inversion eg.
 Qed.
 
- 
+
 Function ftest (n m : nat) : nat :=
   match n with
   | O => match m with
@@ -30,7 +30,7 @@ intros n m.
 Qed.
 
 Lemma test2 : forall m n, ~ 2 = ftest n m.
-Proof. 
+Proof.
 intros n m;intro H.
 functional inversion H ftest.
 Qed.
@@ -45,9 +45,9 @@ Require Import Arith.
 Lemma test11 : forall m : nat, ftest 0 m <= 2.
 intros m.
  functional induction ftest 0 m.
-auto. 
 auto.
-auto with *. 
+auto.
+auto with *.
 Qed.
 
 Function lamfix (m n : nat) {struct n } : nat :=
@@ -92,7 +92,7 @@ Function trivfun (n : nat) : nat :=
   end.
 
 
-(* essaie de parametre variables non locaux:*) 
+(* essaie de parametre variables non locaux:*)
 
 Parameter varessai : nat.
 
@@ -101,7 +101,7 @@ Lemma first_try : trivfun varessai = 0.
 trivial.
 assumption.
 Defined.
- 
+
 
  Functional Scheme triv_ind := Induction for trivfun Sort Prop.
 
@@ -134,7 +134,7 @@ Function funex (n : nat) : nat :=
              | S r => funex r
              end
   end.
- 
+
 
 Function nat_equal_bool (n m : nat) {struct n} : bool :=
   match n with
@@ -150,7 +150,7 @@ Function nat_equal_bool (n m : nat) {struct n} : bool :=
 
 
 Require Export Div2.
- 
+
 Functional Scheme div2_ind := Induction for div2 Sort Prop.
 Lemma div2_inf : forall n : nat, div2 n <= n.
 intros n.
@@ -177,7 +177,7 @@ intros n m.
  functional induction nested_lam n m; simpl;auto.
 Qed.
 
- 
+
 Function essai (x : nat) (p : nat * nat) {struct x} : nat :=
   let (n, m) := (p: nat*nat) in
   match n with
@@ -187,7 +187,7 @@ Function essai (x : nat) (p : nat * nat) {struct x} : nat :=
            | S r => S (essai r (q, m))
            end
   end.
- 
+
 Lemma essai_essai :
  forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p.
 intros x p.
@@ -209,30 +209,30 @@ Function plus_x_not_five'' (n m : nat) {struct n} : nat :=
       | false => S recapp
       end
   end.
- 
+
 Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x.
 intros a b.
  functional induction plus_x_not_five'' a b; intros hyp; simpl in |- *; auto.
 Qed.
- 
+
 Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true.
 intros n m.
  functional induction nat_equal_bool n m; simpl in |- *; intros hyp; auto.
-rewrite <- hyp in y; simpl in y;tauto. 
+rewrite <- hyp in y; simpl in y;tauto.
 inversion hyp.
 Qed.
- 
+
 Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m.
 intros n m.
  functional induction nat_equal_bool n m; simpl in |- *; intros eg; auto.
 inversion eg.
 inversion eg.
 Qed.
- 
- 
+
+
 Inductive istrue : bool -> Prop :=
     istrue0 : istrue true.
- 
+
 Functional Scheme plus_ind := Induction for plus Sort Prop.
 
 Lemma inf_x_plusxy' : forall x y : nat, x <= x + y.
@@ -242,7 +242,7 @@ auto with arith.
 auto with arith.
 Qed.
 
- 
+
 Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0.
 intros n.
 unfold plus in |- *.
@@ -251,7 +251,7 @@ auto with arith.
 apply le_n_S.
 assumption.
 Qed.
- 
+
 Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x.
 intros n.
  functional induction plus 0 n; intros; auto with arith.
@@ -263,25 +263,25 @@ Function mod2 (n : nat) : nat :=
   | S (S m) => S (mod2 m)
   | _ => 0
   end.
- 
+
 Lemma princ_mod2 : forall n : nat, mod2 n <= n.
 intros n.
  functional induction mod2 n; simpl in |- *; auto with arith.
 Qed.
- 
+
 Function isfour (n : nat) : bool :=
   match n with
   | S (S (S (S O))) => true
   | _ => false
   end.
- 
+
 Function isononeorfour (n : nat) : bool :=
   match n with
   | S O => true
   | S (S (S (S O))) => true
   | _ => false
   end.
- 
+
 Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n).
 intros n.
  functional induction isononeorfour n; intros istr; simpl in |- *;
@@ -294,14 +294,14 @@ destruct n. inversion istr.
 destruct n. tauto.
 simpl in *. inversion H0.
 Qed.
- 
+
 Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n).
 intros n.
  functional induction isononeorfour n; intros m istr; inversion istr.
 apply istrue0.
 rewrite H in y; simpl in y;tauto.
 Qed.
- 
+
 Function ftest4 (n m : nat) : nat :=
   match n with
   | O => match m with
@@ -313,12 +313,12 @@ Function ftest4 (n m : nat) : nat :=
            | S r => 1
            end
   end.
- 
+
 Lemma test4 : forall n m : nat, ftest n m <= 2.
 intros n m.
  functional induction ftest n m; auto with arith.
 Qed.
- 
+
 Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2.
 intros n m.
 assert ({n0 | n0 = S n}).
@@ -332,7 +332,7 @@ inversion 1.
 auto with arith.
 auto with arith.
 Qed.
- 
+
 Function ftest44 (x : nat * nat) (n m : nat) : nat :=
   let (p, q) := (x: nat*nat) in
   match n with
@@ -345,7 +345,7 @@ Function ftest44 (x : nat * nat) (n m : nat) : nat :=
            | S r => 1
            end
   end.
- 
+
 Lemma test44 :
  forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2.
 intros pq n m o r s.
@@ -355,7 +355,7 @@ auto with arith.
 auto with arith.
 auto with arith.
 Qed.
- 
+
 Function ftest2 (n m : nat) {struct n} : nat :=
   match n with
   | O => match m with
@@ -364,12 +364,12 @@ Function ftest2 (n m : nat) {struct n} : nat :=
          end
   | S p => ftest2 p m
   end.
- 
+
 Lemma test2' : forall n m : nat, ftest2 n m <= 2.
 intros n m.
  functional induction ftest2 n m; simpl in |- *; intros; auto.
 Qed.
- 
+
 Function ftest3 (n m : nat) {struct n} : nat :=
   match n with
   | O => 0
@@ -378,7 +378,7 @@ Function ftest3 (n m : nat) {struct n} : nat :=
            | S r => 0
            end
   end.
- 
+
 Lemma test3' : forall n m : nat, ftest3 n m <= 2.
 intros n m.
  functional induction ftest3 n m.
@@ -390,7 +390,7 @@ intros.
 simpl in |- *.
 auto.
 Qed.
- 
+
 Function ftest5 (n m : nat) {struct n} : nat :=
   match n with
   | O => 0
@@ -399,7 +399,7 @@ Function ftest5 (n m : nat) {struct n} : nat :=
            | S r => ftest5 p r
            end
   end.
- 
+
 Lemma test5 : forall n m : nat, ftest5 n m <= 2.
 intros n m.
  functional induction ftest5 n m.
@@ -411,21 +411,21 @@ intros.
 simpl in |- *.
 auto.
 Qed.
- 
+
 Function ftest7 (n : nat) : nat :=
   match ftest5 n 0 with
   | O => 0
   | S r => 0
   end.
- 
+
 Lemma essai7 :
  forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2)
-   (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) 
+   (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2)
    (n : nat), ftest7 n <= 2.
 intros hyp1 hyp2 n.
  functional induction ftest7 n; auto.
 Qed.
- 
+
 Function ftest6 (n m : nat) {struct n} : nat :=
   match n with
   | O => 0
@@ -435,7 +435,7 @@ Function ftest6 (n m : nat) {struct n} : nat :=
            end
   end.
 
- 
+
 Lemma princ6 :
  (forall n m : nat, n = 0 -> ftest6 0 m <= 2) ->
  (forall n m p : nat,
@@ -448,16 +448,16 @@ generalize hyp1 hyp2 hyp3.
 clear hyp1 hyp2 hyp3.
  functional induction ftest6 n m; auto.
 Qed.
- 
+
 Lemma essai6 : forall n m : nat, ftest6 n m <= 2.
 intros n m.
  functional induction ftest6 n m; simpl in |- *; auto.
 Qed.
 
-(* Some tests with modules *) 
+(* Some tests with modules *)
 Module M.
-Function test_m (n:nat) : nat := 
-  match n with 
+Function test_m (n:nat) : nat :=
+  match n with
     | 0 => 0
     | S n =>  S (S (test_m n))
   end.
@@ -470,14 +470,14 @@ reflexivity.
 simpl;rewrite IHn0;reflexivity.
 Qed.
 End M.
-(* We redefine a new Function with the same name *) 
-Function test_m (n:nat) : nat := 
+(* We redefine a new Function with the same name *)
+Function test_m (n:nat) : nat :=
   pred n.
 
 Lemma test_m_is_pred : forall n, test_m n = pred n.
-Proof. 
+Proof.
 intro n.
-functional induction (test_m n). (* the test_m_ind to use is the last defined  saying that test_m = pred*) 
+functional induction (test_m n). (* the test_m_ind to use is the last defined  saying that test_m = pred*)
 reflexivity.
 Qed.
 
diff --git a/test-suite/success/Generalization.v b/test-suite/success/Generalization.v
index 6b503e95..de34e007 100644
--- a/test-suite/success/Generalization.v
+++ b/test-suite/success/Generalization.v
@@ -1,3 +1,4 @@
+Generalizable All Variables.
 
 Check `(a = 0).
 Check `(a = 0)%type.
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
index e1c74048..4aa00e68 100644
--- a/test-suite/success/Hints.v
+++ b/test-suite/success/Hints.v
@@ -23,11 +23,11 @@ Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H.
 
 (* Checks that local names are accepted *)
 Section A.
-  Remark Refl : forall (A : Set) (x : A), x = x. 
-  Proof refl_equal.
+  Remark Refl : forall (A : Set) (x : A), x = x.
+  Proof. exact refl_equal. Defined.
   Definition Sym := sym_equal.
   Let Trans := trans_equal.
- 
+
   Hint Resolve Refl: foo.
   Hint Resolve Sym: bar.
   Hint Resolve Trans: foo2.
@@ -46,3 +46,24 @@ Section A.
 
 End A.
 
+Axiom a : forall n, n=0 <-> n<=0.
+
+Hint Resolve -> a.
+Goal forall n, n=0 -> n<=0.
+auto.
+Qed.
+
+
+(* This example comes from Chlipala's ltamer *)
+(* It used to fail from r12902 to r13112 since type_of started to call *)
+(* e_cumul (instead of conv_leq) which was not able to unify "?id" and *)
+(* "(fun x => x) ?id" *)
+
+Notation "e :? pf" := (eq_rect _ (fun X : Set => X) e _ pf)
+  (no associativity, at level 90).
+
+Axiom cast_coalesce :
+  forall (T1 T2 T3 : Set) (e : T1) (pf1 : T1 = T2) (pf2 : T2 = T3),
+  ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2).
+
+Hint Rewrite cast_coalesce : ltamer.
diff --git a/test-suite/success/Import.v b/test-suite/success/Import.v
new file mode 100644
index 00000000..ff5c1ed7
--- /dev/null
+++ b/test-suite/success/Import.v
@@ -0,0 +1,11 @@
+(* Test visibility of imported objects *)
+
+Require Import make_local.
+
+(* Check local implicit arguments are not imported *)
+
+Check (f nat 0).
+
+(* Check local arguments scopes are not imported *)
+
+Check (f nat (0*0)).
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index 1adcbd39..203fbbb7 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -1,4 +1,32 @@
-(* Check local definitions in context of inductive types *)
+(* Test des definitions inductives imbriquees *)
+
+Require Import List.
+
+Inductive X : Set :=
+    cons1 : list X -> X.
+
+Inductive Y : Set :=
+    cons2 : list (Y * Y) -> Y.
+
+(* Test inductive types with local definitions (arity) *)
+
+Inductive eq1 : forall A:Type, let B:=A in A -> Prop :=
+  refl1 : eq1 True I.
+
+Check
+ fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
+   let B := A in
+     fun (a : A) (e : eq1 A a) =>
+       match e in (eq1 A0 B0 a0) return (P A0 a0) with
+       | refl1 => f
+       end.
+
+Inductive eq2 (A:Type) (a:A)
+  : forall B C:Type, let D:=(A*B*C)%type in D -> Prop :=
+  refl2 : eq2 A a unit bool (a,tt,true).
+
+(* Check inductive types with local definitions (parameters) *)
+
 Inductive A (C D : Prop) (E:=C) (F:=D) (x y : E -> F) : E -> Set :=
     I : forall z : E, A C D x y z.
 
@@ -7,9 +35,9 @@ Check
    let E := C in
    let F := D in
    fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type)
-     (f : forall z : C, P z (I C D x y z)) (y0 : C) 
+     (f : forall z : C, P z (I C D x y z)) (y0 : C)
      (a : A C D x y y0) =>
-   match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with
+   match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with
    | I x0 => f x0
    end).
 
@@ -20,7 +48,7 @@ Check
    let E := C in
    let F := D in
    fun (x y : E -> F) (P : B C D x y -> Type)
-     (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) 
+     (f : forall p0 q0 : C, P (Build_B C D x y p0 q0))
      (b : B C D x y) =>
    match b as b0 return (P b0) with
    | Build_B x0 x1 => f x0 x1
diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v
index 867d7374..c5cd7380 100644
--- a/test-suite/success/Injection.v
+++ b/test-suite/success/Injection.v
@@ -17,7 +17,7 @@ Qed.
 Lemma l3 :
  forall x y : nat,
  existS (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) =
- existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> 
+ existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) ->
  x = y.
 intros x y H.
  injection H.
diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v
index b08ffcc3..5091b44c 100644
--- a/test-suite/success/Inversion.v
+++ b/test-suite/success/Inversion.v
@@ -5,13 +5,13 @@ Fixpoint T (n : nat) : Type :=
   match n with
   | O => nat -> Prop
   | S n' => T n'
-  end. 
+  end.
 Inductive R : forall n : nat, T n -> nat -> Prop :=
   | RO : forall (Psi : T 0) (l : nat), Psi l -> R 0 Psi l
   | RS :
-      forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l. 
-Definition Psi00 (n : nat) : Prop := False. 
-Definition Psi0 : T 0 := Psi00. 
+      forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l.
+Definition Psi00 (n : nat) : Prop := False.
+Definition Psi0 : T 0 := Psi00.
 Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l.
 inversion 1.
 Abort.
@@ -39,14 +39,14 @@ extension I -> Type :=
   | super_add :
       forall r (e' : extension I),
       in_extension r e ->
-      super_extension e e' -> super_extension e (add_rule r e'). 
+      super_extension e e' -> super_extension e (add_rule r e').
 
 
 
 Lemma super_def :
  forall (I : Set) (e1 e2 : extension I),
  super_extension e2 e1 -> forall ru, in_extension ru e1 -> in_extension ru e2.
-Proof.                 
+Proof.
  simple induction 1.
  inversion 1; auto.
  elim magic.
@@ -105,5 +105,27 @@ Abort.
 Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t).
 Goal forall o, foo2 o -> 0 = 1.
 intros.
-eapply trans_eq. 
+eapply trans_eq.
 inversion H.
+
+(* Check that the part of "injection" that is called by "inversion"
+   does the same number of intros as the number of equations
+   introduced, even in presence of dependent equalities that
+   "injection" renounces to split *)
+
+Fixpoint prodn (n : nat) :=
+  match n with
+  | O => unit
+  | (S m) => prod (prodn m) nat
+  end.
+
+Inductive U : forall n : nat, prodn n -> bool -> Prop :=
+| U_intro : U 0 tt true.
+
+Lemma foo3 : forall n (t : prodn n), U n t true -> False.
+Proof.
+(* used to fail because dEqThen thought there were 2 new equations but
+   inject_at_positions actually introduced only one; leading then to
+   an inconsistent state that disturbed "inversion" *)
+intros. inversion H.
+Abort.
diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v
index d53e4010..fada3bd5 100644
--- a/test-suite/success/LegacyField.v
+++ b/test-suite/success/LegacyField.v
@@ -30,14 +30,14 @@ Proof.
   intros.
    legacy field.
 Abort.
- 
+
 (* Example 3 *)
 Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R.
 Proof.
   intros.
    legacy field.
 Abort.
- 
+
 (* Example 4 *)
 Goal
 forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R.
@@ -45,21 +45,21 @@ Proof.
   intros.
    legacy field.
 Abort.
- 
+
 (* Example 5 *)
 Goal forall a : R, 1%R = (1 * (1 / a) * a)%R.
 Proof.
   intros.
    legacy field.
 Abort.
- 
+
 (* Example 6 *)
 Goal forall a b : R, b = (b * / a * a)%R.
 Proof.
   intros.
    legacy field.
 Abort.
- 
+
 (* Example 7 *)
 Goal forall a b : R, b = (b * (1 / a) * a)%R.
 Proof.
diff --git a/test-suite/success/LetPat.v b/test-suite/success/LetPat.v
index 545b8aeb..4c790680 100644
--- a/test-suite/success/LetPat.v
+++ b/test-suite/success/LetPat.v
@@ -13,16 +13,16 @@ Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x.
 Print l4.
 Print sigT.
 
-Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := 
+Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
   let 'existT x y := t return B (projT1 t) in y.
 
-Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := 
+Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
   let 'existT x y as t' := t return B (projT1 t') in y.
 
-Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := 
+Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
   let 'existT x y as t' in sigT _ := t return B (projT1 t') in y.
 
-Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := 
+Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
   match t with
     existT x y => y
   end.
@@ -47,9 +47,9 @@ Definition identity_functor (c : category) : functor c c :=
   let 'A :& homA :& CA := c in
     fun x => x.
 
-Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c := 
+Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c :=
   let 'A :& homA :& CA := a in
   let 'B :& homB :& CB := b in
   let 'C :& homB :& CB := c in
-    fun f g => 
+    fun f g =>
       fun x => g (f x).
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
index 4bdd579a..661a8757 100644
--- a/test-suite/success/Notations.v
+++ b/test-suite/success/Notations.v
@@ -14,7 +14,7 @@ Parameter P : Type -> Type -> Type -> Type.
 Notation "e |= t --> v" := (P e t v)     (at level 100, t at level 54).
 Check (nat |= nat --> nat).
 
-(* Check that first non empty definition at an empty level can be of any 
+(* Check that first non empty definition at an empty level can be of any
    associativity *)
 
 Definition marker := O.
@@ -30,4 +30,32 @@ Notation "' 'C_' G ( A )" := (A,G) (at level 8, G at level 2).
 (* Check import of notations from within a section *)
 
 Notation "+1 x" := (S x) (at level 25, x at level 9).
-Section A. Global Notation "'Z'" := O (at level 9). End A.
+Section A. Require Import make_notation. End A.
+
+(* Check use of "$" (see bug #1961) *)
+
+Notation "$ x" := (id x) (at level 30).
+Check ($ 5).
+
+(* Check regression of bug #2087 *)
+
+Notation "'exists' x , P" := (x, P)
+   (at level 200, x ident, right associativity,	only parsing).
+
+Definition foo P := let '(exists x, Q) := P in x = Q :> nat.
+
+(* Check empty levels when extending binder_constr *)
+
+Notation "'exists' x >= y , P" := (exists x, x >= y /\ P)%nat
+   (at level 200, x ident, right associativity, y at level 69).
+
+(* This used to loop at some time before r12491 *)
+
+Notation R x := (@pair _ _ x).
+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) ..).   
+Check [ 0 ].
+Check [ 0 # ; 1 ].
diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v
new file mode 100644
index 00000000..fde9f470
--- /dev/null
+++ b/test-suite/success/Nsatz.v
@@ -0,0 +1,216 @@
+Require Import NsatzR ZArith Reals List Ring_polynom.
+
+Section Examples.
+
+Delimit Scope PE_scope with PE.
+Infix "+" := PEadd : PE_scope.
+Infix "*" := PEmul : PE_scope.
+Infix "-" := PEsub : PE_scope.
+Infix "^" := PEpow : PE_scope.
+Notation "[ n ]" := (@PEc Z n) (at level 0).
+
+Open Scope R_scope.
+
+Lemma example1 : forall x y,
+  x+y=0 ->
+  x*y=0 ->
+  x^2=0.
+Proof.
+ nsatzR.
+Qed.
+
+Lemma example2 : forall x, x^2=0 -> x=0.
+Proof.
+ nsatzR.
+Qed.
+
+(*
+Notation X  := (PEX Z 3).
+Notation Y  := (PEX Z 2).
+Notation Z_ := (PEX Z 1).
+*)
+Lemma example3 : forall x y z,
+  x+y+z=0 ->
+  x*y+x*z+y*z=0->
+  x*y*z=0 -> x^3=0.
+Proof.
+Time nsatzR.
+Qed.
+
+(*
+Notation X  := (PEX Z 4).
+Notation Y  := (PEX Z 3).
+Notation Z_ := (PEX Z 2).
+Notation U  := (PEX Z 1).
+*)
+Lemma example4 : forall x y z u,
+  x+y+z+u=0 ->
+  x*y+x*z+x*u+y*z+y*u+z*u=0->
+  x*y*z+x*y*u+x*z*u+y*z*u=0->
+  x*y*z*u=0 -> x^4=0.
+Proof.
+Time nsatzR.
+Qed.
+
+(*
+Notation x_ := (PEX Z 5).
+Notation y_ := (PEX Z 4).
+Notation z_ := (PEX Z 3).
+Notation u_ := (PEX Z 2).
+Notation v_ := (PEX Z 1).
+Notation "x :: y" := (List.cons x y)
+(at level 60, right associativity, format "'[hv' x  ::  '/' y ']'").
+Notation "x :: y" := (List.app x y)
+(at level 60, right associativity, format "x :: y").
+*)
+
+Lemma example5 : forall x y z u v,
+  x+y+z+u+v=0 ->
+  x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v=0->
+  x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v=0->
+  x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z=0 ->
+  x*y*z*u*v=0 -> x^5=0.
+Proof.
+Time nsatzR.
+Qed.
+
+End Examples.
+
+Section Geometry.
+Require Export Reals NsatzR.
+Open Scope R_scope.
+
+Record point:Type:={
+ X:R;
+ Y:R}.
+
+Definition collinear(A B C:point):=
+  (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0.
+
+Definition parallel (A B C D:point):=
+  ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)).
+
+Definition notparallel (A B C D:point)(x:R):=
+  x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1.
+
+Definition orthogonal (A B C D:point):=
+  ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0.
+
+Definition equal2(A B:point):=
+  (X A)=(X B) /\ (Y A)=(Y B).
+
+Definition equal3(A B:point):=
+  ((X A)-(X B))^2+((Y A)-(Y B))^2 = 0.
+
+Definition nequal2(A B:point):=
+  (X A)<>(X B) \/ (Y A)<>(Y B).
+
+Definition nequal3(A B:point):=
+  not (((X A)-(X B))^2+((Y A)-(Y B))^2 = 0).
+
+Definition middle(A B I:point):=
+  2*(X I)=(X A)+(X B) /\ 2*(Y I)=(Y A)+(Y B).
+
+Definition distance2(A B:point):=
+  (X B - X A)^2 + (Y B - Y A)^2.
+
+(* AB = CD *)
+Definition samedistance2(A B C D:point):=
+  (X B - X A)^2 + (Y B - Y A)^2 = (X D - X C)^2 + (Y D - Y C)^2.
+Definition determinant(A O B:point):=
+  (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O).
+Definition scalarproduct(A O B:point):=
+  (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O).
+Definition norm2(A O B:point):=
+  ((X A - X O)^2+(Y A - Y O)^2)*((X B - X O)^2+(Y B - Y O)^2).
+
+
+Lemma a1:forall A B C:Prop, ((A\/B)/\(A\/C)) -> (A\/(B/\C)).
+intuition.
+Qed.
+ 
+Lemma a2:forall A B C:Prop, ((A\/C)/\(B\/C)) -> ((A/\B)\/C).
+intuition.
+Qed.
+
+Lemma a3:forall a b c d:R, (a-b)*(c-d)=0 -> (a=b \/ c=d).
+intros.
+assert ( (a-b = 0) \/ (c-d = 0)).
+apply Rmult_integral.
+trivial.
+destruct H0.
+left; nsatz.
+right; nsatz.
+Qed.
+
+Ltac geo_unfold :=
+  unfold collinear; unfold parallel; unfold notparallel; unfold orthogonal;
+  unfold equal2; unfold equal3; unfold nequal2; unfold nequal3; 
+  unfold middle; unfold samedistance2; 
+  unfold determinant; unfold scalarproduct; unfold norm2; unfold distance2.
+
+Ltac geo_end :=
+  repeat (
+  repeat (match goal with h:_/\_ |- _ => decompose [and] h; clear h end);
+  repeat (apply a1 || apply a2 || apply a3);
+  repeat split).
+
+Ltac geo_rewrite_hyps:=
+  repeat (match goal with
+           | h:X _ = _ |- _ => rewrite h in *; clear h
+           | h:Y _ = _ |- _ => rewrite h in *; clear h
+          end).
+
+Ltac geo_begin:=
+  geo_unfold;
+  intros;
+  geo_rewrite_hyps;
+  geo_end.
+
+(* Examples *)
+
+Lemma Thales: forall O A B C D:point,
+  collinear O A C -> collinear O B D ->
+  parallel A B C D ->
+  (distance2 O B * distance2 O C = distance2 O D * distance2 O A
+  /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B)
+ \/ collinear O A B.
+repeat geo_begin.
+(*
+Time nsatz.
+*)
+Time nsatz without sugar.
+(*
+Time nsatz with lexico sugar.
+Time nsatz with lexico.
+*)
+(*
+Time nsatzRpv 1%N 1%Z (@nil R) (@nil R). (* revlex, sugar, no div *)
+(*Finished transaction in 1. secs (0.479927u,0.s)*)
+Time nsatzRpv 1%N 0%Z (@nil R) (@nil R). (* revlex, no sugar, no div *)
+(*Finished transaction in 0. secs (0.543917u,0.s)*)
+Time nsatzRpv 1%N 2%Z (@nil R) (@nil R). (* lex, no sugar, no div *)
+(*Finished transaction in 0. secs (0.586911u,0.s)*)
+Time nsatzRpv 1%N 3%Z (@nil R) (@nil R). (* lex, sugar, no div *)
+(*Finished transaction in 0. secs (0.481927u,0.s)*)
+Time nsatzRpv 1%N 5%Z (@nil R) (@nil R). (* revlex, sugar, div *)
+(*Finished transaction in 1. secs (0.601909u,0.s)*)
+*)
+Time nsatz.
+Qed.
+
+Lemma hauteurs:forall A B C A1 B1 C1 H:point,
+  collinear B C A1 ->  orthogonal A A1 B C ->
+  collinear A C B1 -> orthogonal B B1 A C -> 
+  collinear A B C1 -> orthogonal C C1 A B ->
+  collinear A A1 H -> collinear B B1 H -> 
+  
+  collinear C C1 H
+  \/ collinear A B C.
+
+geo_begin.
+Time nsatz.
+(*Finished transaction in 3. secs (2.43263u,0.010998s)*)
+Qed.
+
+End Geometry.
diff --git a/test-suite/success/Nsatz_domain.v b/test-suite/success/Nsatz_domain.v
new file mode 100644
index 00000000..8a30b47f
--- /dev/null
+++ b/test-suite/success/Nsatz_domain.v
@@ -0,0 +1,274 @@
+Require Import Nsatz_domain ZArith Reals List Ring_polynom.
+
+Variable A: Type.
+Variable Ad: Domain A.
+
+Add Ring Ar1: (@ring_ring A (@domain_ring _ Ad)).
+
+Instance Ari : Ring A := {
+  ring0 := @ring0 A (@domain_ring _ Ad);
+  ring1 := @ring1 A (@domain_ring _ Ad);
+  ring_plus := @ring_plus A (@domain_ring _ Ad);
+  ring_mult := @ring_mult A (@domain_ring _ Ad);
+  ring_sub := @ring_sub A (@domain_ring _ Ad);
+  ring_opp := @ring_opp A (@domain_ring _ Ad);
+  ring_ring := @ring_ring A (@domain_ring _ Ad)}.
+
+Instance Adi : Domain A := {
+  domain_ring := Ari;
+  domain_axiom_product := @domain_axiom_product A Ad;
+  domain_axiom_one_zero := @domain_axiom_one_zero A Ad}.
+
+Instance zero_ring2 : Zero A := {zero := ring0}.
+Instance one_ring2 : One A := {one := ring1}.
+Instance addition_ring2 : Addition A := {addition x y := ring_plus x y}.
+Instance multiplication_ring2 : Multiplication A := {multiplication x y := ring_mult x y}.
+Instance subtraction_ring2 : Subtraction A := {subtraction x y := ring_sub x y}.
+Instance opposite_ring2 : Opposite A := {opposite x := ring_opp x}.
+
+Goal forall x y:A,  x = y -> x+0 = y*1+0.
+nsatz_domain.
+Qed.
+
+Goal forall a b c:A, a = b -> b = c -> c = a.
+nsatz_domain.
+Qed.
+
+Goal forall a b c:A, a = b -> b = c -> a = c.
+nsatz_domain.
+Qed.
+
+Goal forall a b c x:A, a = b -> b = c -> a*a = c*c.
+nsatz_domain.
+Qed.
+
+Goal forall x y:Z,  x = y -> (x+0)%Z = (y*1+0)%Z.
+nsatz_domainZ.
+Qed.
+
+Goal forall x y:R,  x = y -> (x+0)%R = (y*1+0)%R.
+nsatz_domainR.
+Qed.
+
+Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R.
+nsatz_domainR.
+Qed.
+
+Section Examples.
+
+Delimit Scope PE_scope with PE.
+Infix "+" := PEadd : PE_scope.
+Infix "*" := PEmul : PE_scope.
+Infix "-" := PEsub : PE_scope.
+Infix "^" := PEpow : PE_scope.
+Notation "[ n ]" := (@PEc Z n) (at level 0).
+
+Open Scope R_scope.
+
+Lemma example1 : forall x y,
+  x+y=0 ->
+  x*y=0 ->
+  x^2=0.
+Proof.
+ nsatz_domainR.
+Qed.
+
+Lemma example2 : forall x, x^2=0 -> x=0.
+Proof.
+ nsatz_domainR.
+Qed.
+
+(*
+Notation X  := (PEX Z 3).
+Notation Y  := (PEX Z 2).
+Notation Z_ := (PEX Z 1).
+*)
+Lemma example3 : forall x y z,
+  x+y+z=0 ->
+  x*y+x*z+y*z=0->
+  x*y*z=0 -> x^3=0.
+Proof.
+Time nsatz_domainR.
+simpl.
+discrR.
+Qed.
+
+(*
+Notation X  := (PEX Z 4).
+Notation Y  := (PEX Z 3).
+Notation Z_ := (PEX Z 2).
+Notation U  := (PEX Z 1).
+*)
+Lemma example4 : forall x y z u,
+  x+y+z+u=0 ->
+  x*y+x*z+x*u+y*z+y*u+z*u=0->
+  x*y*z+x*y*u+x*z*u+y*z*u=0->
+  x*y*z*u=0 -> x^4=0.
+Proof.
+Time nsatz_domainR.
+Qed.
+
+(*
+Notation x_ := (PEX Z 5).
+Notation y_ := (PEX Z 4).
+Notation z_ := (PEX Z 3).
+Notation u_ := (PEX Z 2).
+Notation v_ := (PEX Z 1).
+Notation "x :: y" := (List.cons x y)
+(at level 60, right associativity, format "'[hv' x  ::  '/' y ']'").
+Notation "x :: y" := (List.app x y)
+(at level 60, right associativity, format "x :: y").
+*)
+
+Lemma example5 : forall x y z u v,
+  x+y+z+u+v=0 ->
+  x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v=0->
+  x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v=0->
+  x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z=0 ->
+  x*y*z*u*v=0 -> x^5=0.
+Proof.
+Time nsatz_domainR.
+Qed.
+
+End Examples.
+
+Section Geometry.
+
+Open Scope R_scope.
+
+Record point:Type:={
+ X:R;
+ Y:R}.
+
+Definition collinear(A B C:point):=
+  (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0.
+
+Definition parallel (A B C D:point):=
+  ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)).
+
+Definition notparallel (A B C D:point)(x:R):=
+  x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1.
+
+Definition orthogonal (A B C D:point):=
+  ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0.
+
+Definition equal2(A B:point):=
+  (X A)=(X B) /\ (Y A)=(Y B).
+
+Definition equal3(A B:point):=
+  ((X A)-(X B))^2+((Y A)-(Y B))^2 = 0.
+
+Definition nequal2(A B:point):=
+  (X A)<>(X B) \/ (Y A)<>(Y B).
+
+Definition nequal3(A B:point):=
+  not (((X A)-(X B))^2+((Y A)-(Y B))^2 = 0).
+
+Definition middle(A B I:point):=
+  2*(X I)=(X A)+(X B) /\ 2*(Y I)=(Y A)+(Y B).
+
+Definition distance2(A B:point):=
+  (X B - X A)^2 + (Y B - Y A)^2.
+
+(* AB = CD *)
+Definition samedistance2(A B C D:point):=
+  (X B - X A)^2 + (Y B - Y A)^2 = (X D - X C)^2 + (Y D - Y C)^2.
+Definition determinant(A O B:point):=
+  (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O).
+Definition scalarproduct(A O B:point):=
+  (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O).
+Definition norm2(A O B:point):=
+  ((X A - X O)^2+(Y A - Y O)^2)*((X B - X O)^2+(Y B - Y O)^2).
+
+
+Lemma a1:forall A B C:Prop, ((A\/B)/\(A\/C)) -> (A\/(B/\C)).
+intuition.
+Qed.
+
+Lemma a2:forall A B C:Prop, ((A\/C)/\(B\/C)) -> ((A/\B)\/C).
+intuition.
+Qed.
+
+Lemma a3:forall a b c d:R, (a-b)*(c-d)=0 -> (a=b \/ c=d).
+intros.
+assert ( (a-b = 0) \/ (c-d = 0)).
+apply Rmult_integral.
+trivial.
+destruct H0.
+left; nsatz_domainR.
+right; nsatz_domainR.
+Qed.
+
+Ltac geo_unfold :=
+  unfold collinear; unfold parallel; unfold notparallel; unfold orthogonal;
+  unfold equal2; unfold equal3; unfold nequal2; unfold nequal3;
+  unfold middle; unfold samedistance2;
+  unfold determinant; unfold scalarproduct; unfold norm2; unfold distance2.
+
+Ltac geo_end :=
+  repeat (
+  repeat (match goal with h:_/\_ |- _ => decompose [and] h; clear h end);
+  repeat (apply a1 || apply a2 || apply a3);
+  repeat split).
+
+Ltac geo_rewrite_hyps:=
+  repeat (match goal with
+           | h:X _ = _ |- _ => rewrite h in *; clear h
+           | h:Y _ = _ |- _ => rewrite h in *; clear h
+          end).
+
+Ltac geo_begin:=
+  geo_unfold;
+  intros;
+  geo_rewrite_hyps;
+  geo_end.
+
+(* Examples *)
+
+Lemma Thales: forall O A B C D:point,
+  collinear O A C -> collinear O B D ->
+  parallel A B C D ->
+  (distance2 O B * distance2 O C = distance2 O D * distance2 O A
+  /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B)
+ \/ collinear O A B.
+repeat geo_begin.
+
+Time nsatz_domainR.
+simpl;discrR.
+Time nsatz_domainR.
+simpl;discrR.
+Qed.
+
+Require Import NsatzR.
+
+Lemma hauteurs:forall A B C A1 B1 C1 H:point,
+  collinear B C A1 ->  orthogonal A A1 B C ->
+  collinear A C B1 -> orthogonal B B1 A C ->
+  collinear A B C1 -> orthogonal C C1 A B ->
+  collinear A A1 H -> collinear B B1 H ->
+
+  collinear C C1 H
+  \/ collinear A B C.
+
+geo_begin.
+(* Time nsatzRpv 2%N 1%Z (@nil R) (@nil R).*)
+(*Finished transaction in 3. secs (2.363641u,0.s)*)
+(*Time nsatz_domainR. trop long! *)
+(* en fait nsatz_domain ne tient pas encore compte de la liste des variables! ;-) *)
+Time
+ let lv := constr:(Y A1
+ :: X A1
+    :: Y B1
+       :: X B1
+          :: Y A0
+             :: Y B
+                :: X B
+                   :: X A0
+                      :: X H
+                         :: Y C
+                            :: Y C1 :: Y H :: X C1 :: X C ::nil) in
+ nsatz_domainpv 2%N 1%Z (@List.nil R) lv ltac:simplR Rdi.
+(* Finished transaction in 6. secs (5.579152u,0.001s) *)
+Qed.
+
+End Geometry.
diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v
index accaec41..b8f8660e 100644
--- a/test-suite/success/Omega0.v
+++ b/test-suite/success/Omega0.v
@@ -3,24 +3,24 @@ Open Scope Z_scope.
 
 (* Pierre L: examples gathered while debugging romega. *)
 
-Lemma test_romega_0 : 
- forall m m', 
+Lemma test_romega_0 :
+ forall m m',
   0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
 Proof.
 intros.
 omega.
 Qed.
 
-Lemma test_romega_0b : 
- forall m m', 
+Lemma test_romega_0b :
+ forall m m',
   0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
 Proof.
 intros m m'.
 omega.
 Qed.
 
-Lemma test_romega_1 : 
- forall (z z1 z2 : Z), 
+Lemma test_romega_1 :
+ forall (z z1 z2 : Z),
     z2 <= z1 ->
     z1 <= z2 ->
     z1 >= 0 ->
@@ -32,8 +32,8 @@ intros.
 omega.
 Qed.
 
-Lemma test_romega_1b : 
- forall (z z1 z2 : Z), 
+Lemma test_romega_1b :
+ forall (z z1 z2 : Z),
     z2 <= z1 ->
     z1 <= z2 ->
     z1 >= 0 ->
@@ -45,42 +45,42 @@ intros z z1 z2.
 omega.
 Qed.
 
-Lemma test_romega_2 : forall a b c:Z, 
+Lemma test_romega_2 : forall a b c:Z,
  0<=a-b<=1 -> b-c<=2 -> a-c<=3.
 Proof.
 intros.
 omega.
 Qed.
 
-Lemma test_romega_2b : forall a b c:Z, 
+Lemma test_romega_2b : forall a b c:Z,
  0<=a-b<=1 -> b-c<=2 -> a-c<=3.
 Proof.
 intros a b c.
 omega.
 Qed.
 
-Lemma test_romega_3 : forall a b h hl hr ha hb, 
- 0 <= ha - hl <= 1 -> 
+Lemma test_romega_3 : forall a b h hl hr ha hb,
+ 0 <= ha - hl <= 1 ->
  -2 <= hl - hr <= 2 ->
  h =b+1 ->
  (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
  (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
  (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
- (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ (-2 <= ha-hr <=2 -> hb = a  + 1) ->
  0 <= hb - h <= 1.
 Proof.
 intros.
 omega.
 Qed.
 
-Lemma test_romega_3b : forall a b h hl hr ha hb, 
- 0 <= ha - hl <= 1 -> 
+Lemma test_romega_3b : forall a b h hl hr ha hb,
+ 0 <= ha - hl <= 1 ->
  -2 <= hl - hr <= 2 ->
  h =b+1 ->
  (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
  (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
  (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
- (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ (-2 <= ha-hr <=2 -> hb = a  + 1) ->
  0 <= hb - h <= 1.
 Proof.
 intros a b h hl hr ha hb.
@@ -88,18 +88,18 @@ omega.
 Qed.
 
 
-Lemma test_romega_4 : forall hr ha, 
+Lemma test_romega_4 : forall hr ha,
  ha = 0 ->
- (ha = 0 -> hr =0) -> 
+ (ha = 0 -> hr =0) ->
  hr = 0.
 Proof.
 intros hr ha.
 omega.
 Qed.
 
-Lemma test_romega_5 : forall hr ha, 
+Lemma test_romega_5 : forall hr ha,
  ha = 0 ->
- (~ha = 0 \/ hr =0) -> 
+ (~ha = 0 \/ hr =0) ->
  hr = 0.
 Proof.
 intros hr ha.
@@ -118,14 +118,14 @@ intros z.
 omega.
 Qed.
 
-Lemma test_romega_7 : forall z, 
+Lemma test_romega_7 : forall z,
   0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
 Proof.
 intros.
 omega.
 Qed.
 
-Lemma test_romega_7b : forall z, 
+Lemma test_romega_7b : forall z,
   0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
 Proof.
 intros.
diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v
index 54b13702..c4d086a3 100644
--- a/test-suite/success/Omega2.v
+++ b/test-suite/success/Omega2.v
@@ -4,7 +4,7 @@ Require Import ZArith Omega.
 
 Open Scope Z_scope.
 
-Lemma Test46 : 
+Lemma Test46 :
 forall v1 v2 v3 v4 v5 : Z,
 ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) ->
 9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) ->
diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v
index bb800b7a..f4996734 100644
--- a/test-suite/success/OmegaPre.v
+++ b/test-suite/success/OmegaPre.v
@@ -4,7 +4,7 @@ Open Scope Z_scope.
 (** Test of the zify preprocessor for (R)Omega *)
 
 (* More details in file PreOmega.v
- 
+
    (r)omega with Z        : starts with zify_op
    (r)omega with nat      : starts with zify_nat
    (r)omega with positive : starts with zify_positive
diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v
new file mode 100644
index 00000000..81bdbc29
--- /dev/null
+++ b/test-suite/success/ProgramWf.v
@@ -0,0 +1,99 @@
+Require Import Arith Program.
+Require Import ZArith Zwf.
+
+Set Implicit Arguments.
+(* Set Printing All. *)
+Print sigT_rect.
+Obligation Tactic := program_simplify ; auto with *.
+About MR.
+
+Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat :=
+  match n with
+    | 0 => 0
+    | S n' => merge n' m
+  end.
+
+Print merge.
+
+
+Print Zlt.
+Print Zwf.
+
+Open Local Scope Z_scope.
+
+Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z :=
+  match n ?= m with
+    | Lt => Zwfrec n (Zpred m)
+    | _ => 0
+  end.
+
+Next Obligation.
+  red. Admitted.
+
+Close Scope Z_scope.
+
+Program Fixpoint merge_wf (n m : nat) {wf lt m} : nat :=
+  match n with
+    | 0 => 0
+    | S n' => merge n' m
+  end.
+
+Print merge_wf.
+
+Program Fixpoint merge_one (n : nat) {measure n} : nat :=
+  match n with
+    | 0 => 0
+    | S n' => merge_one n'
+  end.
+
+Print Hint well_founded.
+Print merge_one. Eval cbv delta [merge_one] beta zeta in merge_one.
+
+Import WfExtensionality.
+
+Lemma merge_unfold n m : merge n m =
+  match n with
+    | 0 => 0
+    | S n' => merge n' m
+  end.
+Proof. intros. unfold merge at 1. unfold merge_func. 
+  unfold_sub merge (merge n m).
+  simpl. destruct n ; reflexivity. 
+Qed.
+
+Print merge.
+
+Require Import Arith.
+Unset Implicit Arguments.
+
+Time Program Fixpoint check_n  (n : nat) (P : { i | i < n } -> bool) (p : nat)
+  (H : forall (i : { i | i < n }), i < p -> P i = true)
+  {measure (n - p)} :
+  Exc (forall (p : { i | i < n}), P p = true) :=
+  match le_lt_dec n p with
+  | left _ => value _
+  | right cmp =>
+      if dec (P p) then
+        check_n n P (S p) _
+      else
+        error
+  end.
+
+Require Import Omega Setoid.
+
+Next Obligation.
+  intros ; simpl in *. apply H.
+  simpl in * ; omega.
+Qed.
+
+Next Obligation. simpl in *; intros.
+  revert H0 ; clear_subset_proofs. intros.
+  case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst.
+  revert H0 ; clear_subset_proofs ; tauto.
+
+  apply H. simpl. omega.
+Qed.
+
+Program Fixpoint check_n'  (n : nat) (m : nat | m = n) (p : nat) (q : nat | q = p)
+  {measure (p - n) p} : nat :=
+  _.
diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v
index 88da6013..d8faa88a 100644
--- a/test-suite/success/Projection.v
+++ b/test-suite/success/Projection.v
@@ -12,7 +12,7 @@ Check fun (s:S) (a b:s.(Dom)) => s.(Op) a b.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
-Unset Strict Implicit. 
+Unset Strict Implicit.
 
 Structure S' (A : Set) : Type :=  {Dom' : Type; Op' : A -> Dom' -> Dom'}.
 
@@ -29,9 +29,9 @@ Check fun (s:S') (a b:s.(Dom')) => _.(Op') a b.
 Check fun (s:S') (a b:s.(Dom')) => s.(Op') a b.
 
 Set Implicit Arguments.
-Unset Strict Implicits. 
+Unset Strict Implicits.
 
-Structure S' (A:Set) : Type := 
+Structure S' (A:Set) : Type :=
  {Dom'     : Type;
   Op'      : A -> Dom' -> Dom'}.
 
diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v
index 0c37c59a..801ece9e 100644
--- a/test-suite/success/ROmega.v
+++ b/test-suite/success/ROmega.v
@@ -22,7 +22,7 @@ Qed.
 Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
 Proof.
 intros.
-romega. 
+romega.
 Qed.
 
 (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v
index 86cf49cb..1348bb62 100644
--- a/test-suite/success/ROmega0.v
+++ b/test-suite/success/ROmega0.v
@@ -3,24 +3,24 @@ Open Scope Z_scope.
 
 (* Pierre L: examples gathered while debugging romega. *)
 
-Lemma test_romega_0 : 
- forall m m', 
+Lemma test_romega_0 :
+ forall m m',
   0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
 Proof.
 intros.
 romega.
 Qed.
 
-Lemma test_romega_0b : 
- forall m m', 
+Lemma test_romega_0b :
+ forall m m',
   0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
 Proof.
 intros m m'.
 romega.
 Qed.
 
-Lemma test_romega_1 : 
- forall (z z1 z2 : Z), 
+Lemma test_romega_1 :
+ forall (z z1 z2 : Z),
     z2 <= z1 ->
     z1 <= z2 ->
     z1 >= 0 ->
@@ -32,8 +32,8 @@ intros.
 romega.
 Qed.
 
-Lemma test_romega_1b : 
- forall (z z1 z2 : Z), 
+Lemma test_romega_1b :
+ forall (z z1 z2 : Z),
     z2 <= z1 ->
     z1 <= z2 ->
     z1 >= 0 ->
@@ -45,42 +45,42 @@ intros z z1 z2.
 romega.
 Qed.
 
-Lemma test_romega_2 : forall a b c:Z, 
+Lemma test_romega_2 : forall a b c:Z,
  0<=a-b<=1 -> b-c<=2 -> a-c<=3.
 Proof.
 intros.
 romega.
 Qed.
 
-Lemma test_romega_2b : forall a b c:Z, 
+Lemma test_romega_2b : forall a b c:Z,
  0<=a-b<=1 -> b-c<=2 -> a-c<=3.
 Proof.
 intros a b c.
 romega.
 Qed.
 
-Lemma test_romega_3 : forall a b h hl hr ha hb, 
- 0 <= ha - hl <= 1 -> 
+Lemma test_romega_3 : forall a b h hl hr ha hb,
+ 0 <= ha - hl <= 1 ->
  -2 <= hl - hr <= 2 ->
  h =b+1 ->
  (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
  (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
  (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
- (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ (-2 <= ha-hr <=2 -> hb = a  + 1) ->
  0 <= hb - h <= 1.
 Proof.
 intros.
 romega.
 Qed.
 
-Lemma test_romega_3b : forall a b h hl hr ha hb, 
- 0 <= ha - hl <= 1 -> 
+Lemma test_romega_3b : forall a b h hl hr ha hb,
+ 0 <= ha - hl <= 1 ->
  -2 <= hl - hr <= 2 ->
  h =b+1 ->
  (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
  (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
  (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
- (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ (-2 <= ha-hr <=2 -> hb = a  + 1) ->
  0 <= hb - h <= 1.
 Proof.
 intros a b h hl hr ha hb.
@@ -88,18 +88,18 @@ romega.
 Qed.
 
 
-Lemma test_romega_4 : forall hr ha, 
+Lemma test_romega_4 : forall hr ha,
  ha = 0 ->
- (ha = 0 -> hr =0) -> 
+ (ha = 0 -> hr =0) ->
  hr = 0.
 Proof.
 intros hr ha.
 romega.
 Qed.
 
-Lemma test_romega_5 : forall hr ha, 
+Lemma test_romega_5 : forall hr ha,
  ha = 0 ->
- (~ha = 0 \/ hr =0) -> 
+ (~ha = 0 \/ hr =0) ->
  hr = 0.
 Proof.
 intros hr ha.
@@ -118,14 +118,14 @@ intros z.
 romega.
 Qed.
 
-Lemma test_romega_7 : forall z, 
+Lemma test_romega_7 : forall z,
   0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
 Proof.
 intros.
 romega.
 Qed.
 
-Lemma test_romega_7b : forall z, 
+Lemma test_romega_7b : forall z,
   0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
 Proof.
 intros.
diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v
index a3be2898..87e8c8e3 100644
--- a/test-suite/success/ROmega2.v
+++ b/test-suite/success/ROmega2.v
@@ -6,7 +6,7 @@ Open Scope Z_scope.
 
 
 (* First a simplified version used during debug of romega on Test46 *)
-Lemma Test46_simplified : 
+Lemma Test46_simplified :
 forall v1 v2 v5 : Z,
 0 = v2 + v5 ->
 0 < v5 ->
@@ -18,7 +18,7 @@ Qed.
 
 
 (* The complete problem *)
-Lemma Test46 : 
+Lemma Test46 :
 forall v1 v2 v3 v4 v5 : Z,
 ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) ->
 9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) ->
diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v
index 550edca5..bd473fa6 100644
--- a/test-suite/success/ROmegaPre.v
+++ b/test-suite/success/ROmegaPre.v
@@ -4,7 +4,7 @@ Open Scope Z_scope.
 (** Test of the zify preprocessor for (R)Omega *)
 
 (* More details in file PreOmega.v
- 
+
    (r)omega with Z        : starts with zify_op
    (r)omega with nat      : starts with zify_nat
    (r)omega with positive : starts with zify_positive
diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v
index 60e170e4..d4e6a82e 100644
--- a/test-suite/success/RecTutorial.v
+++ b/test-suite/success/RecTutorial.v
@@ -1,5 +1,5 @@
-Inductive nat : Set := 
- | O : nat 
+Inductive nat : Set :=
+ | O : nat
  | S : nat->nat.
 Check nat.
 Check O.
@@ -14,8 +14,8 @@ Print le.
 Theorem zero_leq_three: 0 <= 3.
 
 Proof.
- constructor 2. 
- constructor 2.  
+ constructor 2.
+ constructor 2.
  constructor 2.
  constructor 1.
 
@@ -32,7 +32,7 @@ Qed.
 Lemma zero_lt_three : 0 < 3.
 Proof.
  unfold lt.
- repeat constructor. 
+ repeat constructor.
 Qed.
 
 
@@ -132,7 +132,7 @@ Require Import Compare_dec.
 
 Check le_lt_dec.
 
-Definition max (n p :nat) := match le_lt_dec n p with 
+Definition max (n p :nat) := match le_lt_dec n p with
                              | left _ => p
                              | right _ => n
                              end.
@@ -152,9 +152,9 @@ Extraction max.
 
 
 Inductive tree(A:Set)   : Set :=
-    node : A -> forest A -> tree A 
+    node : A -> forest A -> tree A
 with
-  forest (A: Set)    : Set := 
+  forest (A: Set)    : Set :=
     nochild  : forest A |
     addchild : tree A -> forest A -> forest A.
 
@@ -162,7 +162,7 @@ with
 
 
 
-Inductive 
+Inductive
   even    : nat->Prop :=
     evenO : even  O |
     evenS : forall n, odd n -> even (S n)
@@ -176,11 +176,11 @@ Qed.
 
 
 
-Definition nat_case := 
+Definition nat_case :=
  fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) =>
     match n return Q with
-    | 0 => g0 
-    | S p => g1 p 
+    | 0 => g0
+    | S p => g1 p
     end.
 
 Eval simpl in (nat_case nat 0 (fun p => p) 34).
@@ -200,7 +200,7 @@ Eval simpl in fun p => pred (S p).
 
 
 Definition xorb (b1 b2:bool) :=
-match b1, b2 with 
+match b1, b2 with
  | false, true => true
  | true, false => true
  | _ , _       => false
@@ -208,7 +208,7 @@ end.
 
 
  Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0  \/ n = S m}.
-  
+
 
  Definition predecessor : forall n:nat, pred_spec n.
   intro n;case n.
@@ -220,7 +220,7 @@ Print predecessor.
 
 Extraction predecessor.
 
-Theorem nat_expand : 
+Theorem nat_expand :
   forall n:nat, n = match n with 0 => 0 | S p => S p end.
  intro n;case n;simpl;auto.
 Qed.
@@ -228,7 +228,7 @@ Qed.
 Check (fun p:False => match p return 2=3 with end).
 
 Theorem fromFalse : False -> 0=1.
- intro absurd. 
+ intro absurd.
  contradiction.
 Qed.
 
@@ -244,12 +244,12 @@ Section equality_elimination.
 
 End equality_elimination.
 
-           
+
 Theorem trans : forall n m p:nat, n=m -> m=p -> n=p.
 Proof.
- intros n m p eqnm.  
+ intros n m p eqnm.
  case eqnm.
- trivial.        
+ trivial.
 Qed.
 
 Lemma Rw :  forall x y: nat, y = y * x -> y * x * x = y.
@@ -282,7 +282,7 @@ Lemma four_n : forall n:nat, n+n+n+n = 4*n.
 
  Undo.
  intro n; pattern n at 1.
- 
+
 
  rewrite <- mult_1_l.
  repeat rewrite   mult_distr_S.
@@ -314,7 +314,7 @@ Proof.
  intros m Hm; exists m;trivial.
 Qed.
 
-Definition Vtail_total 
+Definition Vtail_total
    (A : Set) (n : nat) (v : vector A n) : vector A (pred n):=
 match v in (vector _ n0) return (vector A (pred n0)) with
 | Vnil => Vnil A
@@ -322,7 +322,7 @@ match v in (vector _ n0) return (vector A (pred n0)) with
 end.
 
 Definition Vtail' (A:Set)(n:nat)(v:vector A n) : vector A (pred n).
- intros A n v; case v.  
+ case v.
  simpl.
  exact (Vnil A).
  simpl.
@@ -331,7 +331,7 @@ Defined.
 
 (*
 Inductive Lambda : Set :=
-  lambda : (Lambda -> False) -> Lambda. 
+  lambda : (Lambda -> False) -> Lambda.
 
 
 Error: Non strictly positive occurrence of "Lambda" in
@@ -347,7 +347,7 @@ Section Paradox.
  (*
   understand matchL Q l (fun h : Lambda -> False => t)
 
-  as match l return Q with lambda h => t end 
+  as match l return Q with lambda h => t end
  *)
 
  Definition application (f x: Lambda) :False :=
@@ -377,26 +377,26 @@ Definition isingle l := inode l (fun i => ileaf).
 
 Definition t1 := inode 0 (fun n => isingle (Z_of_nat (2*n))).
 
-Definition t2 := inode 0 
-                      (fun n : nat => 
+Definition t2 := inode 0
+                      (fun n : nat =>
                                inode (Z_of_nat n)
                                      (fun p => isingle (Z_of_nat (n*p)))).
 
 
 Inductive itree_le : itree-> itree -> Prop :=
   | le_leaf : forall t, itree_le  ileaf t
-  | le_node  : forall l l' s s', 
-                       Zle l l' -> 
-                      (forall i, exists j:nat, itree_le (s i) (s' j)) -> 
+  | le_node  : forall l l' s s',
+                       Zle l l' ->
+                      (forall i, exists j:nat, itree_le (s i) (s' j)) ->
                       itree_le  (inode  l s) (inode  l' s').
 
 
-Theorem itree_le_trans : 
+Theorem itree_le_trans :
   forall t t', itree_le t t' ->
                forall t'', itree_le t' t'' -> itree_le t t''.
  induction t.
  constructor 1.
- 
+
  intros t'; case t'.
  inversion 1.
  intros z0 i0 H0.
@@ -409,20 +409,20 @@ Theorem itree_le_trans :
  inversion_clear H0.
  intro i2; case (H4 i2).
  intros.
- generalize (H i2 _ H0). 
+ generalize (H i2 _ H0).
  intros.
  case (H3 x);intros.
  generalize (H5 _ H6).
  exists x0;auto.
 Qed.
 
- 
+
 
 Inductive itree_le' : itree-> itree -> Prop :=
   | le_leaf' : forall t, itree_le'  ileaf t
-  | le_node' : forall l l' s s' g, 
-                       Zle l l' ->  
-                      (forall i, itree_le' (s i) (s' (g i))) -> 
+  | le_node' : forall l l' s s' g,
+                       Zle l l' ->
+                      (forall i, itree_le' (s i) (s' (g i))) ->
                        itree_le'  (inode  l s) (inode  l' s').
 
 
@@ -434,7 +434,7 @@ Lemma t1_le_t2 : itree_le t1 t2.
  constructor.
  auto with zarith.
  intro i; exists (2 * i).
- unfold isingle. 
+ unfold isingle.
  constructor.
  auto with zarith.
  exists i;constructor.
@@ -455,7 +455,7 @@ Qed.
 
 Require Import List.
 
-Inductive ltree  (A:Set) : Set :=  
+Inductive ltree  (A:Set) : Set :=
           lnode   : A -> list (ltree A) -> ltree A.
 
 Inductive prop : Prop :=
@@ -482,8 +482,8 @@ Qed.
 Check (fun (P:Prop->Prop)(p: ex_Prop P) =>
       match p with exP_intro X HX => X end).
 Error:
-Incorrect elimination of "p" in the inductive type  
-"ex_Prop", the return type has sort "Type" while it should be 
+Incorrect elimination of "p" in the inductive type
+"ex_Prop", the return type has sort "Type" while it should be
 "Prop"
 
 Elimination of an inductive object of sort "Prop"
@@ -496,8 +496,8 @@ because proofs can be eliminated only to build proofs
 Check (match prop_inject with (prop_intro P p) => P end).
 
 Error:
-Incorrect elimination of "prop_inject" in the inductive type  
-"prop", the return type has sort "Type" while it should be 
+Incorrect elimination of "prop_inject" in the inductive type
+"prop", the return type has sort "Type" while it should be
 "Prop"
 
 Elimination of an inductive object of sort "Prop"
@@ -508,17 +508,17 @@ because proofs can be eliminated only to build proofs
 Print prop_inject.
 
 (*
-prop_inject = 
+prop_inject =
 prop_inject = prop_intro prop (fun H : prop => H)
      : prop
 *)
 
 
-Inductive  typ : Type := 
-  typ_intro : Type -> typ. 
+Inductive  typ : Type :=
+  typ_intro : Type -> typ.
 
 Definition typ_inject: typ.
-split. 
+split.
 exact typ.
 (*
 Defined.
@@ -564,13 +564,13 @@ Reset comes_from_the_left.
 
  Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop :=
   match H with
-         |  or_introl p => True 
+         |  or_introl p => True
          |  or_intror q => False
   end.
 
 Error:
-Incorrect elimination of "H" in the inductive type  
-"or", the return type has sort "Type" while it should be 
+Incorrect elimination of "H" in the inductive type
+"or", the return type has sort "Type" while it should be
 "Prop"
 
 Elimination of an inductive object of sort "Prop"
@@ -582,41 +582,41 @@ because proofs can be eliminated only to build proofs
 Definition comes_from_the_left_sumbool
             (P Q:Prop)(x:{P}+{Q}): Prop :=
   match x with
-         |  left  p => True 
+         |  left  p => True
          |  right q => False
   end.
 
 
 
-                    
+
 Close Scope Z_scope.
 
 
 
 
 
-Theorem S_is_not_O : forall n, S n <> 0. 
+Theorem S_is_not_O : forall n, S n <> 0.
 
-Definition Is_zero (x:nat):= match x with 
-                                     | 0 => True  
+Definition Is_zero (x:nat):= match x with
+                                     | 0 => True
                                      | _ => False
                              end.
  Lemma O_is_zero : forall m, m = 0 -> Is_zero m.
  Proof.
   intros m H; subst m.
-  (*  
+  (*
   ============================
    Is_zero 0
   *)
   simpl;trivial.
  Qed.
- 
+
  red; intros n Hn.
  apply O_is_zero with (m := S n).
  assumption.
 Qed.
 
-Theorem disc2 : forall n, S (S n) <> 1. 
+Theorem disc2 : forall n, S (S n) <> 1.
 Proof.
  intros n Hn; discriminate.
 Qed.
@@ -632,7 +632,7 @@ Qed.
 
 Theorem inj_succ  : forall n m, S n = S m -> n = m.
 Proof.
- 
+
 
 Lemma inj_pred : forall n m, n = m -> pred n = pred m.
 Proof.
@@ -666,9 +666,9 @@ Proof.
  intros n p H; case H ;
    intros; discriminate.
 Qed.
-   
+
 eapply not_le_Sn_0_with_constraints; eauto.
-Qed. 
+Qed.
 
 
 Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0).
@@ -681,7 +681,7 @@ Check le_Sn_0_inv.
 
 Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 .
 Proof.
- intros n p H; 
+ intros n p H;
  inversion H using le_Sn_0_inv.
 Qed.
 
@@ -689,9 +689,9 @@ Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <=  0).
 Check le_Sn_0_inv'.
 
 
-Theorem le_reverse_rules : 
- forall n m:nat, n <= m -> 
-                   n = m \/  
+Theorem le_reverse_rules :
+ forall n m:nat, n <= m ->
+                   n = m \/
                    exists p, n <=  p /\ m = S p.
 Proof.
   intros n m H; inversion H.
@@ -704,21 +704,21 @@ Restart.
 Qed.
 
 Inductive ArithExp : Set :=
-     Zero : ArithExp 
+     Zero : ArithExp
    | Succ : ArithExp -> ArithExp
    | Plus : ArithExp -> ArithExp -> ArithExp.
 
 Inductive RewriteRel : ArithExp -> ArithExp -> Prop :=
      RewSucc  : forall e1 e2 :ArithExp,
-                  RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) 
+                  RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2)
   |  RewPlus0 : forall e:ArithExp,
-                  RewriteRel (Plus Zero e) e 
+                  RewriteRel (Plus Zero e) e
   |  RewPlusS : forall e1 e2:ArithExp,
                   RewriteRel e1 e2 ->
                   RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)).
 
 
-  
+
 Fixpoint plus (n p:nat) {struct n} : nat :=
   match n with
           | 0 => p
@@ -739,7 +739,7 @@ Fixpoint plus'' (n p:nat) {struct n} : nat :=
 
 
 Fixpoint even_test (n:nat) : bool :=
-  match n 
+  match n
   with 0 =>  true
      | 1 =>  false
      | S (S p) => even_test p
@@ -749,20 +749,20 @@ Fixpoint even_test (n:nat) : bool :=
 Reset even_test.
 
 Fixpoint even_test (n:nat) : bool :=
-  match n 
-  with 
+  match n
+  with
       | 0 =>  true
       | S p => odd_test p
   end
 with odd_test (n:nat) : bool :=
   match n
-  with 
+  with
      | 0 => false
      | S p => even_test p
  end.
 
 
-  
+
 Eval simpl in even_test.
 
 
@@ -779,11 +779,11 @@ Section Principle_of_Induction.
 Variable    P               : nat -> Prop.
 Hypothesis  base_case       : P 0.
 Hypothesis  inductive_step   : forall n:nat, P n -> P (S n).
-Fixpoint nat_ind  (n:nat)    : (P n) := 
+Fixpoint nat_ind  (n:nat)    : (P n) :=
    match n return P n with
           | 0 => base_case
           | S m => inductive_step m (nat_ind m)
-   end. 
+   end.
 
 End Principle_of_Induction.
 
@@ -803,9 +803,9 @@ Variable    P               : nat -> nat ->Prop.
 Hypothesis  base_case1      : forall x:nat, P 0 x.
 Hypothesis  base_case2      : forall x:nat, P (S x) 0.
 Hypothesis  inductive_step   : forall n m:nat, P n m -> P (S n) (S m).
-Fixpoint nat_double_ind (n m:nat){struct n} : P n m := 
-  match n, m return P n m with 
-         |  0 ,     x    =>  base_case1 x 
+Fixpoint nat_double_ind (n m:nat){struct n} : P n m :=
+  match n, m return P n m with
+         |  0 ,     x    =>  base_case1 x
          |  (S x),    0  =>  base_case2 x
          |  (S x), (S y) =>  inductive_step x y (nat_double_ind x y)
      end.
@@ -816,15 +816,15 @@ Variable    P               : nat -> nat -> Set.
 Hypothesis  base_case1      : forall x:nat, P 0 x.
 Hypothesis  base_case2      : forall x:nat, P (S x) 0.
 Hypothesis  inductive_step   : forall n m:nat, P n m -> P (S n) (S m).
-Fixpoint nat_double_rec (n m:nat){struct n} : P n m := 
-  match n, m return P n m with 
-         |   0 ,     x    =>  base_case1 x 
+Fixpoint nat_double_rec (n m:nat){struct n} : P n m :=
+  match n, m return P n m with
+         |   0 ,     x    =>  base_case1 x
          |  (S x),    0   => base_case2 x
          |  (S x), (S y)  => inductive_step x y (nat_double_rec x y)
      end.
 End Principle_of_Double_Recursion.
 
-Definition min : nat -> nat -> nat  := 
+Definition min : nat -> nat -> nat  :=
   nat_double_rec (fun (x y:nat) => nat)
                  (fun (x:nat) => 0)
                  (fun (y:nat) => 0)
@@ -868,7 +868,7 @@ Require Import Minus.
 
 (*
 Fixpoint div (x y:nat){struct x}: nat :=
- if eq_nat_dec x 0 
+ if eq_nat_dec x 0
   then 0
   else if eq_nat_dec y 0
        then x
@@ -901,18 +901,18 @@ Qed.
 Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 ->
                                      x - y < x.
 Proof.
- destruct x; destruct y; 
- ( simpl;intros; apply minus_smaller_S || 
+ destruct x; destruct y;
+ ( simpl;intros; apply minus_smaller_S ||
    intros; absurd (0=0); auto).
 Qed.
 
-Definition minus_decrease : forall x y:nat, Acc lt x -> 
-                                         x <> 0 -> 
+Definition minus_decrease : forall x y:nat, Acc lt x ->
+                                         x <> 0 ->
                                          y <> 0 ->
                                          Acc lt (x-y).
 Proof.
  intros x y H; case H.
- intros Hz posz posy. 
+ intros Hz posz posy.
  apply Hz; apply minus_smaller_positive; assumption.
 Defined.
 
@@ -920,21 +920,19 @@ Print minus_decrease.
 
 
 
-Definition div_aux (x y:nat)(H: Acc lt x):nat.
- fix 3.
- intros.
-  refine (if eq_nat_dec x 0 
-         then 0 
-         else if eq_nat_dec y 0 
+Fixpoint div_aux (x y:nat)(H: Acc lt x):nat.
+  refine (if eq_nat_dec x 0
+         then 0
+         else if eq_nat_dec y 0
               then y
               else div_aux (x-y) y _).
- apply (minus_decrease x y H);assumption. 
+ apply (minus_decrease x y H);assumption.
 Defined.
 
 
 Print div_aux.
 (*
-div_aux = 
+div_aux =
 (fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat :=
    match eq_nat_dec x 0 with
    | left _ => 0
@@ -948,7 +946,7 @@ div_aux =
 *)
 
 Require Import Wf_nat.
-Definition div x y := div_aux x y (lt_wf x). 
+Definition div x y := div_aux x y (lt_wf x).
 
 Extraction div.
 (*
@@ -974,7 +972,7 @@ Proof.
 Abort.
 
 (*
- Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), 
+ Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n),
                                   n= 0 -> v = Vnil A.
 
 Toplevel input, characters 40281-40287
@@ -990,7 +988,7 @@ The term "Vnil A" has type "vector A 0" while it is expected to have type
 *)
  Require Import JMeq.
 
-Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), 
+Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n),
                                   n= 0 -> JMeq v (Vnil A).
 Proof.
  destruct v.
@@ -1026,7 +1024,7 @@ Eval simpl in (fun (A:Set)(v:vector A 0) => v).
 
 Lemma Vid_eq : forall (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v).
 Proof.
- destruct v. 
+ destruct v.
  reflexivity.
  reflexivity.
 Defined.
@@ -1034,7 +1032,7 @@ Defined.
 Theorem zero_nil : forall A (v:vector A 0), v = Vnil.
 Proof.
  intros.
- change (Vnil (A:=A)) with (Vid _ 0 v). 
+ change (Vnil (A:=A)) with (Vid _ 0 v).
  apply Vid_eq.
 Defined.
 
@@ -1050,7 +1048,7 @@ Defined.
 
 
 
-Definition vector_double_rect : 
+Definition vector_double_rect :
     forall (A:Set) (P: forall (n:nat),(vector A n)->(vector A n) -> Type),
         P 0 Vnil Vnil ->
         (forall n (v1 v2 : vector A n) a b, P n v1 v2 ->
@@ -1105,7 +1103,7 @@ Qed.
  |  LCons : A -> LList A -> LList A.
 
 
- 
+
 
 
  Definition head (A:Set)(s : Stream A) := match s with Cons a s' => a end.
@@ -1144,7 +1142,7 @@ Hypothesis  bisim2 : forall s1 s2:Stream A, R s1 s2 ->
 CoFixpoint park_ppl     : forall s1 s2:Stream A, R s1 s2 ->
                                                EqSt s1 s2 :=
  fun s1 s2 (p : R s1 s2) =>
-      eqst s1 s2 (bisim1  p) 
+      eqst s1 s2 (bisim1  p)
                  (park_ppl  (bisim2  p)).
 End Parks_Principle.
 
@@ -1154,7 +1152,7 @@ Theorem map_iterate : forall (A:Set)(f:A->A)(x:A),
 Proof.
  intros A f x.
  apply park_ppl with
-   (R:=  fun s1 s2 => exists x: A, 
+   (R:=  fun s1 s2 => exists x: A,
                       s1 = iterate f (f x) /\ s2 = map f (iterate f x)).
 
  intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity.
diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v
index 885fff48..8334322c 100644
--- a/test-suite/success/Record.v
+++ b/test-suite/success/Record.v
@@ -17,34 +17,34 @@ Obligation Tactic := crush.
 
 Program Definition vnil {A} : vector A 0 := {| vec_list := [] |}.
 
-Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := 
+Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) :=
   {| vec_list := cons a (vec_list v) |}.
 
 Hint Rewrite map_length rev_length : datatypes.
 
-Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := 
+Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n :=
   {| vec_list := map f v |}.
 
-Program Definition vreverse {A n} (v : vector A n) : vector A n := 
+Program Definition vreverse {A n} (v : vector A n) : vector A n :=
   {| vec_list := rev v |}.
 
-Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := 
+Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B :=
   match v, w with
     | nil, nil => nil
     | cons f fs, cons x xs => cons (f x) (va_list fs xs)
     | _, _ => nil
   end.
 
-Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := 
+Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n :=
   {| vec_list := va_list v w |}.
 
-Next Obligation. 
+Next Obligation.
   destruct v as [v Hv]; destruct w as [w Hw] ; simpl.
-  subst n. revert w Hw. induction v ; destruct w ; crush. 
+  subst n. revert w Hw. induction v ; destruct w ; crush.
   rewrite IHv ; auto.
 Qed.
 
-(* Correct type inference of record notation. Initial example by Spiwack. *) 
+(* Correct type inference of record notation. Initial example by Spiwack. *)
 
 Inductive Machin := {
  Bazar : option Machin
@@ -80,3 +80,10 @@ Record DecidableOrder : Type :=
 ; le_trans : transitive _ le
 ; le_total : forall x y, {x <= y}+{y <= x}
 }.
+
+(* Test syntactic sugar suggested by wish report #2138 *)
+
+Record R : Type := {
+  P (A : Type) : Prop := exists x : A -> A, x = x;
+  Q A : P A -> P A
+}.
diff --git a/test-suite/success/Section.v b/test-suite/success/Section.v
new file mode 100644
index 00000000..8e9e79b3
--- /dev/null
+++ b/test-suite/success/Section.v
@@ -0,0 +1,6 @@
+(* Test bug 2168: ending section of some name was removing objects of the
+   same name *)
+
+Require Import make_notation.
+
+Check add2 3.
diff --git a/test-suite/success/Simplify_eq.v b/test-suite/success/Simplify_eq.v
index 5b856e3d..d9abdbf5 100644
--- a/test-suite/success/Simplify_eq.v
+++ b/test-suite/success/Simplify_eq.v
@@ -2,11 +2,11 @@
 
 (* Check that Simplify_eq tries Intro until *)
 
-Lemma l1 : 0 = 1 -> False.   
+Lemma l1 : 0 = 1 -> False.
  simplify_eq 1.
 Qed.
 
-Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False.   
+Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False.
  simplify_eq H.
 intros.
 apply (n_Sn x H0).
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
index f0809839..42898b8d 100644
--- a/test-suite/success/Tauto.v
+++ b/test-suite/success/Tauto.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Tauto.v 7693 2005-12-21 23:50:17Z herbelin $ *)
+(* $Id$ *)
 
 (**** Tactics Tauto and Intuition ****)
 
diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v
index 82c5cf2e..5f44c752 100644
--- a/test-suite/success/TestRefine.v
+++ b/test-suite/success/TestRefine.v
@@ -9,13 +9,11 @@
 (************************************************************************)
 
 Lemma essai : forall x : nat, x = x.
-
  refine
  ((fun x0 : nat => match x0 with
                    | O => _
                    | S p => _
-                   end)
-  :forall x : nat, x = x).  (* x0=x0 et x0=x0 *)
+                   end)).
 
 Restart.
 
@@ -44,7 +42,7 @@ Abort.
 
 (************************************************************************)
 
-Lemma T : nat. 
+Lemma T : nat.
 
  refine (S _).
 
@@ -97,7 +95,7 @@ Abort.
 
 
 (************************************************************************)
-Parameter f : nat * nat -> nat -> nat. 
+Parameter f : nat * nat -> nat -> nat.
 
 Lemma essai : nat.
 
@@ -145,11 +143,10 @@ Lemma essai : forall n : nat, {x : nat | x = S n}.
 Restart.
 
  refine
- ((fun n : nat => match n with
+   (fun n : nat => match n with
                   | O => _
                   | S p => _
-                  end)
-  :forall n : nat, {x : nat | x = S n}).
+                  end).
 
 Restart.
 
@@ -178,10 +175,10 @@ Restart.
     | S p => _
     end).
 
-exists 1. trivial. 
+exists 1. trivial.
 elim (f0 p).
  refine
- (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). 
+ (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _).
  rewrite h. auto.
 Qed.
 
diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v
new file mode 100644
index 00000000..55351a47
--- /dev/null
+++ b/test-suite/success/Typeclasses.v
@@ -0,0 +1,60 @@
+Generalizable All Variables.
+
+Module mon.
+
+Reserved Notation "'return' t" (at level 0).
+Reserved Notation "x >>= y" (at level 65, left associativity).
+
+
+
+Record Monad {m : Type -> Type} := {
+  unit : Π {α}, α -> m α where "'return' t" := (unit t) ;
+  bind : Π {α β}, m α -> (α -> m β) -> m β where "x >>= y" := (bind x y) ;
+  bind_unit_left : Π {α β} (a : α) (f : α -> m β), return a >>= f = f a }.
+
+Print Visibility.
+Print unit.
+Implicit Arguments unit [[m] [m0] [α]].
+Implicit Arguments Monad [].
+Notation "'return' t" := (unit t).
+
+(* Test correct handling of existentials and defined fields. *)
+
+Class A `(e: T) := { a := True }.
+Class B `(e_: T) := { e := e_; sg_ass :> A e }.
+
+Goal forall `{B T}, a.
+  intros. exact I.
+Defined.
+
+Class B' `(e_: T) := { e' := e_; sg_ass' :> A e_ }.
+
+Goal forall `{B' T}, a.
+  intros. exact I.
+Defined.
+
+End mon.
+
+(* Correct treatment of dependent goals *) 
+
+(* First some preliminaries: *)
+
+Section sec.
+  Context {N: Type}.
+  Class C (f: N->N) := {}.
+  Class E := { e: N -> N }.
+  Context
+    (g: N -> N) `(E) `(C e)
+    `(forall (f: N -> N), C f -> C (fun x => f x))
+    (U: forall f: N -> N, C f -> False).
+
+(* Now consider the following: *)
+
+  Let foo := U (fun x => e x).
+  Check foo _.
+
+(* This type checks fine, so far so good. But now
+ 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
diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v
index 952890ee..a6f9fa23 100644
--- a/test-suite/success/apply.v
+++ b/test-suite/success/apply.v
@@ -135,7 +135,7 @@ Qed.
 Definition apply (f:nat->Prop) := forall x, f x.
 Goal apply (fun n => n=0) -> 1=0.
 intro H.
-auto. 
+auto.
 Qed.
 
 (* The following fails if the coercion Zpos is not introduced around p
@@ -157,10 +157,10 @@ Qed.
 
 Definition succ x := S x.
 Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop),
-  (forall x y, P x -> Q x y) -> 
+  (forall x y, P x -> Q x y) ->
   (forall x, P (S x)) -> forall y: I (S 0), Q (succ 0) y.
 intros.
-apply H with (y:=y). 
+apply H with (y:=y).
 (* [x] had two possible instances: [S 0], coming from unifying the
    type of [y] with [I ?n] and [succ 0] coming from the unification with
    the goal; only the first one allows to make the next apply (which
@@ -171,14 +171,14 @@ Qed.
 (* A similar example with a arbitrary long conversion between the two
    possible instances *)
 
-Fixpoint compute_succ x := 
+Fixpoint compute_succ x :=
   match x with O => S 0 | S n => S (compute_succ n) end.
 
 Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop),
-  (forall x y, P x -> Q x y) -> 
+  (forall x y, P x -> Q x y) ->
   (forall x, P (S x)) -> forall y: I (S 100), Q (compute_succ 100) y.
 intros.
-apply H with (y:=y). 
+apply H with (y:=y).
 apply H0.
 Qed.
 
@@ -187,10 +187,10 @@ Qed.
    subgoal which precisely fails) *)
 
 Definition ID (A:Type) := A.
-Goal forall f:Type -> Type, 
-  forall (P : forall A:Type, A -> Prop), 
-  (forall (B:Type) x, P (f B) x -> P (f B) x) -> 
-  (forall (A:Type) x, P (f (f A)) x) -> 
+Goal forall f:Type -> Type,
+  forall (P : forall A:Type, A -> Prop),
+  (forall (B:Type) x, P (f B) x -> P (f B) x) ->
+  (forall (A:Type) x, P (f (f A)) x) ->
   forall (A:Type) (x:f (f A)), P (f (ID (f A))) x.
 intros.
 apply H.
@@ -239,6 +239,28 @@ Axiom silly_axiom : forall v : exp, v = v -> False.
 Lemma silly_lemma : forall x : atom, False.
 intros x.
 apply silly_axiom with (v := x).  (* fails *)
+reflexivity.
+Qed.
+
+(* Check that unification does not commit too early to a representative
+   of an eta-equivalence class that would be incompatible with other
+   unification constraints *)
+
+Lemma eta : forall f : (forall P, P 1),
+  (forall P, f P = f P) ->
+   forall Q, f (fun x => Q x) = f (fun x => Q x).
+intros.
+apply H.
+Qed.
+
+(* Test propagation of evars from subgoal to brother subgoals *)
+
+  (* This works because unfold calls clos_norm_flags which calls nf_evar *)
+
+Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O.
+intros x H; eapply trans_equal;
+[apply H | unfold x;match goal with |- ?x = ?x => reflexivity end].
+Qed.
 
 (* Test non-regression of (temporary) bug 1981 *)
 
@@ -248,9 +270,124 @@ exact O.
 trivial.
 Qed.
 
-(* Test non-regression of (temporary) bug 1980 *)
+(* Check pattern-unification on evars in apply unification *)
+
+Lemma evar : exists f : nat -> nat, forall x, f x = 0 -> x = 0.
+Proof.
+eexists; intros x H.
+apply H.
+Qed.
+
+(* Check that "as" clause applies to main premise only and leave the
+   side conditions away *)
+
+Lemma side_condition : 
+  forall (A:Type) (B:Prop) x, (True -> B -> x=0) -> B -> x=x.
+Proof.
+intros.
+apply H in H0 as ->.
+reflexivity.
+exact I.
+Qed.
+
+(* Check that "apply" is chained on the last subgoal of each lemma and
+   that side conditions come first (as it is the case since 8.2) *)
+
+Lemma chaining : 
+  forall A B C : Prop,
+  (1=1 -> (2=2 -> A -> B) /\ True) ->
+  (3=3 -> (True /\ (4=4 -> C -> A))) -> C -> B.
+Proof.
+intros.
+apply H, H0.
+exact (refl_equal 1).
+exact (refl_equal 2).
+exact (refl_equal 3).
+exact (refl_equal 4).
+assumption.
+Qed.
+
+(* Check that the side conditions of "apply in", even when chained and
+   used through conjunctions, come last (as it is the case for single
+   calls to "apply in" w/o destruction of conjunction since 8.2) *)
+
+Lemma chaining_in :
+  forall A B C : Prop, 
+  (1=1 -> True /\ (B -> 2=2 -> 5=0)) ->
+  (3=3 -> (A -> 4=4 -> B) /\ True) -> A -> 0=5.
+Proof.
+intros.
+apply H0, H in H1 as ->.
+exact (refl_equal 0).
+exact (refl_equal 1).
+exact (refl_equal 2).
+exact (refl_equal 3).
+exact (refl_equal 4).
+Qed.
+
+(* From 12612, descent in conjunctions is more powerful *)
+(* The following, which was failing badly in bug 1980, is now accepted
+   (even if somehow surprising) *)
 
 Goal True.
-try eapply ex_intro.
-trivial.
+eapply ex_intro.
+instantiate (2:=fun _ :True => True).
+instantiate (1:=I).
+exact I.
 Qed.
+
+(* The following, which were not accepted, are now accepted as
+    expected by descent in conjunctions *)
+
+Goal True.
+eapply (ex_intro (fun _ => True) I).    
+exact I.
+Qed.
+
+Goal True.
+eapply (fun (A:Prop) (x:A) => conj I x).
+exact I.
+Qed.
+
+(* The following was not accepted from r12612 to r12657 *)
+
+Record sig0 := { p1 : nat; p2 : p1 = 0 }.
+
+Goal forall x : sig0, p1 x = 0.
+intro x;
+apply x.
+Qed.
+
+(* The following worked in 8.2 but was not accepted from r12229 to
+   r12926 because "simple apply" started to use pattern unification of
+   evars. Evars pattern unification for simple (e)apply was disabled
+   in 12927 but "simple eapply" below worked from 12898 to 12926
+   because pattern-unification also started supporting abstraction
+   over Metas. However it did not find the "simple" solution and hence
+   the subsequent "assumption" failed. *)
+
+Goal exists f:nat->nat, forall x y, x = y -> f x = f y.
+intros; eexists; intros.
+simple eapply (@f_equal nat).
+assumption.
+Existential 1 := fun x => x.
+Qed.
+
+(* The following worked in 8.2 but was not accepted from r12229 to
+   r12897 for the same reason because eauto uses "simple apply". It
+   worked from 12898 to 12926 because eauto uses eassumption and not
+   assumption. *)
+
+Goal exists f:nat->nat, forall x y, x = y -> f x = f y.
+intros; eexists; intros.
+eauto.
+Existential 1 := fun x => x.
+Qed.
+
+(* The following was accepted before r12612 but is still not accepted in r12658
+
+Goal forall x : { x:nat | x = 0}, proj1_sig x = 0.
+intro x;
+apply x.
+
+*)
diff --git a/test-suite/success/autointros.v b/test-suite/success/autointros.v
new file mode 100644
index 00000000..0a081271
--- /dev/null
+++ b/test-suite/success/autointros.v
@@ -0,0 +1,15 @@
+Set Automatic Introduction.
+
+Inductive even : nat -> Prop :=
+| even_0 : even 0
+| even_odd : forall n, odd n -> even (S n)
+with odd : nat -> Prop :=
+| odd_1 : odd 1
+| odd_even : forall n, even n -> odd (S n).
+
+Lemma foo {n : nat} (E : even n) : even (S (S n))
+with bar {n : nat} (O : odd n) : odd (S (S n)).
+Proof. destruct E. constructor. constructor. apply even_odd. apply (bar _ H).
+  destruct O. repeat constructor. apply odd_even. apply (foo _ H).
+Defined.
+
diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v
index 94d827fd..b565183b 100644
--- a/test-suite/success/cc.v
+++ b/test-suite/success/cc.v
@@ -22,12 +22,12 @@ intros.
  congruence.
 Qed.
 
-(* Examples that fail due to dependencies *) 
+(* Examples that fail due to dependencies *)
 
 (* yields transitivity problem *)
 
 Theorem dep :
- forall (A : Set) (P : A -> Set) (f g : forall x : A, P x) 
+ forall (A : Set) (P : A -> Set) (f g : forall x : A, P x)
    (x y : A) (e : x = y) (e0 : f y = g y), f x = g x.
 intros;  dependent rewrite e; exact e0.
 Qed.
@@ -42,12 +42,12 @@ intros;  rewrite e; reflexivity.
 Qed.
 
 
-(* example that Congruence. can solve 	
-	(dependent function applied to the same argument)*) 
+(* example that Congruence. can solve
+	(dependent function applied to the same argument)*)
 
 Theorem dep3 :
  forall (A : Set) (P : A -> Set) (f g : forall x : A, P x),
- f = g -> forall x : A, f x = g x.		intros.	
+ f = g -> forall x : A, f x = g x.		intros.
  congruence.
 Qed.
 
@@ -61,7 +61,7 @@ Qed.
 
 Theorem inj2 :
  forall (A : Set) (a c d : A) (f : A -> A * A),
- f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d.                             
+ f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d.
 intros.
  congruence.
 Qed.
@@ -80,7 +80,7 @@ Qed.
 
 (* example with implications *)
 
-Theorem arrow : forall (A B: Prop) (C D:Set) , A=B -> C=D  -> 
+Theorem arrow : forall (A B: Prop) (C D:Set) , A=B -> C=D  ->
 (A -> C) = (B -> D).
 congruence.
 Qed.
@@ -101,7 +101,6 @@ Proof.
   congruence.
   auto.
 Qed.
-            
 
-            
-            
\ No newline at end of file
+
+
diff --git a/test-suite/success/change.v b/test-suite/success/change.v
index cea01712..5ac6ce82 100644
--- a/test-suite/success/change.v
+++ b/test-suite/success/change.v
@@ -4,3 +4,29 @@ Goal let a := 0+0 in a=a.
 intro.
 change 0 in (value of a).
 change ((fun A:Type => A) nat) in (type of a).
+Abort.
+
+Goal forall x, 2 + S x = 1 + S x.
+intro. 
+change (?u + S x) with (S (u + x)). 
+Abort.
+
+(* Check the combination of at, with and in (see bug #2146) *)
+
+Goal 3=3 -> 3=3. intro H.
+change 3 at 2 with (1+2) in |- *.
+change 3 at 2 with (1+2) in H |-.
+change 3 with (1+2) in H at 1 |- * at 1.
+(* Now check that there are no more 3's *)
+change 3 with (1+2) in * || reflexivity.
+Qed.
+
+(* Note: the following is invalid and must fail
+change 3 at 1 with (1+2) at 3.
+change 3 at 1 with (1+2) in *.
+change 3 at 1 with (1+2) in H at 2 |-.
+change 3 at 1 with (1+2) in |- * at 3.
+change 3 at 1 with (1+2) in H |- *.
+change 3 at 1 with (1+2) in H, H|-.
+change 3 in |- * at 1.
+ *)
diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v
index 8169361c..976bec73 100644
--- a/test-suite/success/clear.v
+++ b/test-suite/success/clear.v
@@ -1,7 +1,7 @@
 Goal forall x:nat, (forall x, x=0 -> True)->True.
   intros; eapply H.
   instantiate (1:=(fun y => _) (S x)).
-  simpl. 
+  simpl.
   clear x. trivial.
 Qed.
 
diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v
index 525348de..908b5f77 100644
--- a/test-suite/success/coercions.v
+++ b/test-suite/success/coercions.v
@@ -24,7 +24,7 @@ Coercion C : nat >-> Funclass.
 
 (* Remark: in the following example, it cannot be decided whether C is
    from nat to Funclass or from A to nat. An explicit Coercion command is
-   expected 
+   expected
 
 Parameter A : nat -> Prop.
 Parameter C:> forall n:nat, A n -> nat.
@@ -71,7 +71,6 @@ Record Morphism (X Y:Setoid) : Type :=
 {evalMorphism :> X -> Y}.
 
 Definition extSetoid (X Y:Setoid) : Setoid.
-intros X Y.
 constructor.
 exact (Morphism X Y).
 Defined.
diff --git a/test-suite/success/conv_pbs.v b/test-suite/success/conv_pbs.v
index 062c3ee5..f6ebacae 100644
--- a/test-suite/success/conv_pbs.v
+++ b/test-suite/success/conv_pbs.v
@@ -30,7 +30,7 @@ Fixpoint remove_assoc (A:Set)(x:variable)(rho: substitution A){struct rho}
                       : substitution A :=
   match rho with
     | nil => rho
-    | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho 
+    | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho
                       else (y,t) :: remove_assoc A x rho
   end.
 
@@ -38,7 +38,7 @@ Fixpoint assoc (A:Set)(x:variable)(rho:substitution A){struct rho}
                : option A :=
   match rho with
     | nil => None
-    | (y,t) :: rho => if var_eq_dec x y then Some t 
+    | (y,t) :: rho => if var_eq_dec x y then Some t
                       else assoc A x rho
   end.
 
@@ -126,34 +126,34 @@ Inductive in_context (A:formula) : list formula -> Prop :=
   | OmWeak : forall Gamma B, in_context A Gamma -> in_context A (cons B Gamma).
 
 Inductive prove : list formula -> formula -> Type :=
-  | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B 
+  | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B
     -> prove Gamma (A --> B)
-  | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma) 
+  | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma)
     -> prove Gamma (subst A x (Var y))) -> prove Gamma (Forall x A)
-  | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma' 
+  | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma'
     -> (prove_stoup Gamma' A C) -> (Gamma' |- C)
 
 where "Gamma |- A" := (prove Gamma A)
 
   with prove_stoup : list formula -> formula -> formula -> Type :=
   | ProofAxiom Gamma C: Gamma ; C |- C
-  | ProofImplyL Gamma C : forall A B, (Gamma |- A) 
+  | ProofImplyL Gamma C : forall A B, (Gamma |- A)
     -> (prove_stoup Gamma B C) -> (prove_stoup Gamma (A --> B) C)
-  | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C) 
+  | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C)
     -> (prove_stoup Gamma (Forall x A) C)
 
 where " Gamma ; B |- A " := (prove_stoup Gamma B A).
 
-Axiom context_prefix_trans : 
+Axiom context_prefix_trans :
   forall Gamma Gamma' Gamma'',
-    context_prefix Gamma Gamma' 
+    context_prefix Gamma Gamma'
       -> context_prefix Gamma' Gamma''
         -> context_prefix Gamma Gamma''.
 
-Axiom Weakening : 
+Axiom Weakening :
   forall Gamma Gamma' A,
     context_prefix Gamma Gamma' -> Gamma |- A -> Gamma' |- A.
-    
+
 Axiom universal_weakening :
   forall Gamma Gamma', context_prefix Gamma Gamma'
     -> forall P, Gamma |- Atom P -> Gamma' |- Atom P.
@@ -170,20 +170,20 @@ Canonical Structure Universal := Build_Kripke
   universal_weakening.
 
 Axiom subst_commute :
-  forall A rho x t, 
+  forall A rho x t,
     subst_formula ((x,t)::rho) A = subst (subst_formula rho A) x t.
 
 Axiom subst_formula_atom :
-  forall rho p t, 
+  forall rho p t,
     Atom (p, sem _ rho t) = subst_formula rho (Atom (p,t)).
 
 Fixpoint universal_completeness (Gamma:context)(A:formula){struct A}
-  : forall rho:substitution term, 
+  : forall rho:substitution term,
       force _ rho Gamma A -> Gamma |- subst_formula rho A
   :=
-  match A 
-    return forall rho, force _ rho Gamma A 
-      -> Gamma |- subst_formula rho A 
+  match A
+    return forall rho, force _ rho Gamma A
+      -> Gamma |- subst_formula rho A
   with
   | Atom (p,t) => fun rho H => eq_rect _ (fun A => Gamma |- A) H _ (subst_formula_atom rho p t)
   | A --> B => fun rho HImplyAB =>
@@ -192,21 +192,21 @@ Fixpoint universal_completeness (Gamma:context)(A:formula){struct A}
      (HImplyAB (A'::Gamma)(CtxPrefixTrans A' (CtxPrefixRefl Gamma))
        (universal_completeness_stoup A rho (fun C Gamma' Hle p
          => ProofCont Hle p))))
-  | Forall x A => fun rho HForallA 
-    => ProofForallR x (fun y Hfresh 
-      => eq_rect _ _ (universal_completeness Gamma A _ 
+  | Forall x A => fun rho HForallA
+    => ProofForallR x (fun y Hfresh
+      => eq_rect _ _ (universal_completeness Gamma A _
         (HForallA Gamma (CtxPrefixRefl Gamma)(Var y))) _ (subst_commute _ _ _ _ ))
   end
 with universal_completeness_stoup (Gamma:context)(A:formula){struct A}
   : forall rho, (forall C Gamma', context_prefix Gamma Gamma'
     -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C)
       -> force _ rho Gamma A
-  := 
-  match A return forall rho, 
-    (forall C Gamma', context_prefix Gamma Gamma' 
+  :=
+  match A return forall rho,
+    (forall C Gamma', context_prefix Gamma Gamma'
      -> Gamma' ; subst_formula rho A |- C
      -> Gamma' |- C)
-       -> force _ rho Gamma A 
+       -> force _ rho Gamma A
   with
   | Atom (p,t) as C => fun rho H
     => H _ Gamma (CtxPrefixRefl Gamma)(ProofAxiom _ _)
diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v
index fede31a8..bc1757fd 100644
--- a/test-suite/success/decl_mode.v
+++ b/test-suite/success/decl_mode.v
@@ -8,10 +8,10 @@ proof.
   assume n:nat.
   per induction on n.
     suppose it is 0.
-     suffices (0=0) to show thesis. 
+     suffices (0=0) to show thesis.
      thus thesis.
     suppose it is (S m) and Hrec:thesis for m.
-      have (div2 (double (S m))= div2 (S (S (double m)))). 
+      have (div2 (double (S m))= div2 (S (S (double m)))).
            ~= (S (div2 (double m))).
       thus ~= (S m) by Hrec.
   end induction.
@@ -56,12 +56,12 @@ proof.
 end proof.
 Qed.
 
-Lemma main_thm_aux: forall n,even n -> 
+Lemma main_thm_aux: forall n,even n ->
 double (double (div2 n *div2 n))=n*n.
 proof.
   given n such that H:(even n).
- *** have (double (double (div2 n * div2 n)) 
-        = double (div2 n) * double (div2 n)) 
+ *** have (double (double (div2 n * div2 n))
+        = double (div2 n) * double (div2 n))
         by double_mult_l,double_mult_r.
   thus ~= (n*n) by H,even_double.
 end proof.
@@ -75,14 +75,14 @@ proof.
   per induction on m.
     suppose it is 0.
       thus thesis.
-    suppose it is (S mm) and thesis for mm. 
+    suppose it is (S mm) and thesis for mm.
       then H:(even (S (S (mm+mm)))).
       have (S (S (mm + mm)) = S mm + S mm)  using omega.
       hence (even (S mm +S mm)) by H.
   end induction.
 end proof.
 Qed.
- 
+
 Theorem main_theorem: forall n p, n*n=double (p*p) -> p=0.
 proof.
   assume n0:nat.
@@ -95,7 +95,7 @@ proof.
           suppose it is (S p').
             assume (n * n = double (S p' * S p')).
               =~ 0 by H1,mult_n_O.
-              ~= (S (  p' + p' * S p' + S p'* S p')) 
+              ~= (S (  p' + p' * S p' + S p'* S p'))
                 by plus_n_Sm.
             hence thesis .
           suppose it is 0.
@@ -106,19 +106,19 @@ proof.
         have (even (double (p*p))) by even_double_n .
         then (even (n*n)) by H0.
         then H2:(even n) by even_is_even_times_even.
-        then (double (double (div2 n *div2 n))=n*n) 
+        then (double (double (div2 n *div2 n))=n*n)
           by main_thm_aux.
           ~= (double (p*p)) by H0.
-        then H':(double (div2 n *div2 n)= p*p) by double_inv. 
+        then H':(double (div2 n *div2 n)= p*p) by double_inv.
         have (even (double (div2 n *div2 n))) by even_double_n.
         then (even (p*p)) by even_double_n,H'.
         then H3:(even p) by even_is_even_times_even.
-        have (double(double (div2 n * div2 n)) = n*n) 
+        have (double(double (div2 n * div2 n)) = n*n)
           by H2,main_thm_aux.
           ~= (double (p*p)) by H0.
-          ~= (double(double (double (div2 p * div2 p)))) 
+          ~= (double(double (double (div2 p * div2 p))))
             by H3,main_thm_aux.
-        then H'':(div2 n * div2 n = double (div2 p * div2 p)) 
+        then H'':(div2 n * div2 n = double (div2 p * div2 p))
           by double_inv.
         then (div2 n < n) by lt_div2,neq_O_lt,H1.
         then H4:(div2 p=0) by  (H (div2 n)),H''.
@@ -137,8 +137,8 @@ Coercion IZR: Z >->R.*)
 
 Open Scope R_scope.
 
-Lemma square_abs_square: 
-  forall p,(INR (Zabs_nat p) * INR (Zabs_nat p)) = (IZR p * IZR p). 
+Lemma square_abs_square:
+  forall p,(INR (Zabs_nat p) * INR (Zabs_nat p)) = (IZR p * IZR p).
 proof.
   assume p:Z.
   per cases on p.
@@ -147,7 +147,7 @@ proof.
     suppose it is (Zpos z).
       thus thesis.
     suppose it is (Zneg z).
-      have ((INR (Zabs_nat (Zneg z)) * INR (Zabs_nat (Zneg z))) = 
+      have ((INR (Zabs_nat (Zneg z)) * INR (Zabs_nat (Zneg z))) =
       (IZR (Zpos z) * IZR (Zpos z))).
            ~= ((- IZR (Zpos z)) * (- IZR (Zpos z))).
       thus ~= (IZR (Zneg z) * IZR (Zneg z)).
@@ -160,19 +160,19 @@ Definition irrational (x:R):Prop :=
 
 Theorem irrationnal_sqrt_2: irrational (sqrt (INR 2%nat)).
 proof.
-  let p:Z,q:nat be such that H:(q<>0%nat) 
+  let p:Z,q:nat be such that H:(q<>0%nat)
                          and H0:(sqrt (INR 2%nat)=(IZR p/INR q)).
   have H_in_R:(INR q<>0:>R) by H.
   have triv:((IZR p/INR q* INR q) =IZR p :>R) by * using field.
   have sqrt2:((sqrt (INR 2%nat) * sqrt (INR 2%nat))= INR 2%nat:>R) by sqrt_def.
-  have (INR (Zabs_nat p * Zabs_nat p) 
-     = (INR (Zabs_nat p) * INR (Zabs_nat p))) 
+  have (INR (Zabs_nat p * Zabs_nat p)
+     = (INR (Zabs_nat p) * INR (Zabs_nat p)))
     by mult_INR.
     ~=  (IZR p* IZR p) by square_abs_square.
     ~=  ((IZR p/INR q*INR q)*(IZR p/INR q*INR q)) by triv. (* we have to factor because field is too weak *)
     ~=  ((IZR p/INR q)*(IZR p/INR q)*(INR q*INR q)) using ring.
     ~=  (sqrt (INR 2%nat) * sqrt (INR 2%nat)*(INR q*INR q)) by H0.
-    ~= (INR (2%nat * (q*q)))  by sqrt2,mult_INR. 
+    ~= (INR (2%nat * (q*q)))  by sqrt2,mult_INR.
   then  (Zabs_nat p * Zabs_nat p = 2* (q * q))%nat.
     ~= ((q*q)+(q*q))%nat.
     ~= (Div2.double (q*q)).
diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v
index 46dd0cb6..fe0165d0 100644
--- a/test-suite/success/dependentind.v
+++ b/test-suite/success/dependentind.v
@@ -1,5 +1,4 @@
-Require Import Coq.Program.Program.
-
+Require Import Coq.Program.Program Coq.Program.Equality.
 
 Variable A : Set.
 
@@ -39,7 +38,7 @@ Delimit Scope context_scope with ctx.
 
 Arguments Scope snoc [context_scope].
 
-Notation " Γ ,, τ " := (snoc Γ τ) (at level 25, t at next level, left associativity).
+Notation " Γ , τ " := (snoc Γ τ) (at level 25, τ at next level, left associativity) : context_scope.
 
 Fixpoint conc (Δ Γ : ctx) : ctx :=
   match Δ with
@@ -47,60 +46,64 @@ Fixpoint conc (Δ Γ : ctx) : ctx :=
     | snoc Δ' x => snoc (conc Δ' Γ) x
   end.
 
-Notation " Γ ;; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope.
+Notation " Γ  ; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope.
+
+Reserved Notation " Γ ⊢ τ " (at level 30, no associativity).
+
+Generalizable All Variables.
 
 Inductive term : ctx -> type -> Type :=
-| ax : forall Γ τ, term (snoc Γ τ) τ
-| weak : forall Γ τ, term Γ τ -> forall τ', term (Γ ,, τ') τ
-| abs : forall Γ τ τ', term (snoc Γ τ) τ' -> term Γ (τ --> τ')
-| app : forall Γ τ τ', term Γ (τ --> τ') -> term Γ τ -> term Γ τ'.
+| ax : `(Γ, τ ⊢ τ)
+| weak : `{Γ ⊢ τ -> Γ, τ' ⊢ τ}
+| abs : `{Γ, τ ⊢ τ' -> Γ ⊢ τ --> τ'}
+| app : `{Γ ⊢ τ --> τ' -> Γ ⊢ τ -> Γ ⊢ τ'}
+
+where " Γ ⊢ τ " := (term Γ τ) : type_scope.
 
 Hint Constructors term : lambda.
 
 Open Local Scope context_scope.
 
-Notation " Γ |-- τ " := (term Γ τ) (at level 0) : type_scope.
+Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps.
 
-Lemma weakening : forall Γ Δ τ, term (Γ ;; Δ) τ -> 
-  forall τ', term (Γ ,, τ' ;; Δ) τ.
-Proof with simpl in * ; reverse ; simplify_dep_elim ; simplify_IH_hyps ; eauto with lambda.
+Lemma weakening : forall Γ Δ τ, Γ ; Δ ⊢ τ ->
+  forall τ', Γ , τ' ; Δ ⊢ τ.
+Proof with simpl in * ; eqns ; eauto with lambda.
   intros Γ Δ τ H.
 
   dependent induction H.
 
-  destruct Δ...
+  destruct Δ as [|Δ τ'']...
 
-  destruct Δ...
+  destruct Δ as [|Δ τ'']...
 
-  destruct Δ...
-    apply abs...
-    
-    specialize (IHterm (Δ,, t,, τ)%ctx Γ0)...
+  destruct Δ as [|Δ τ'']...
+    apply abs.
+    specialize (IHterm Γ (Δ, τ'', τ))...
 
-  intro.
-  apply app with Ï„...
-Qed.
+  intro. eapply app...
+Defined.
 
-Lemma exchange : forall Γ Δ α β τ, term (Γ,, α,, β ;; Δ) τ -> term (Γ,, β,, α ;; Δ) τ.
-Proof with simpl in * ; subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps ; auto.
+Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ.
+Proof with simpl in * ; eqns ; eauto.
   intros until 1.
   dependent induction H.
 
-  destruct Δ...
+  destruct Δ ; eqns.
     apply weak ; apply ax.
 
     apply ax.
 
   destruct Δ...
-    pose (weakening Γ0 (empty,, α))...
+    pose (weakening Γ (empty, α))...
 
     apply weak...
 
-  apply abs... 
-  specialize (IHterm (Δ ,, τ))...
+  apply abs...
+    specialize (IHterm Γ (Δ, τ))...
 
-  eapply app with Ï„...
-Save.
+  eapply app...
+Defined.
 
 (** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *)
 
@@ -124,5 +127,5 @@ Inductive Ev : forall t, Exp t -> Exp t -> Prop :=
                Ev (Fst e) e1.
 
 Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2).
-intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption. 
+intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption.
 Qed.
diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v
index 5aa78816..8013e1d3 100644
--- a/test-suite/success/destruct.v
+++ b/test-suite/success/destruct.v
@@ -1,11 +1,11 @@
 (* Submitted by Robert Schneck *)
 
-Parameter A B C D : Prop.
+Parameters A B C D : Prop.
 Axiom X : A -> B -> C /\ D.
 
 Lemma foo : A -> B -> C.
 Proof.
-intros. 
+intros.
 destruct X. (* Should find axiom X and should handle arguments of X *)
 assumption.
 assumption.
@@ -45,9 +45,9 @@ Require Import List.
 Definition alist R := list (nat * R)%type.
 
 Section Properties.
-  Variables A : Type.
-  Variables a : A.
-  Variables E : alist A.
+  Variable A : Type.
+  Variable a : A.
+  Variable E : alist A.
 
   Lemma silly : E = E.
   Proof.
@@ -55,3 +55,22 @@ Section Properties.
   Abort.
 
 End Properties.
+
+(* This used not to work before revision 11944 *)
+
+Goal forall P:(forall n, 0=n -> Prop), forall H: 0=0, P 0 H.
+destruct H.
+Abort.
+
+(* The calls to "destruct" below did not work before revision 12356 *)
+
+Variable A0:Type.
+Variable P:A0->Type.
+Require Import JMeq.
+Goal forall a b (p:P a) (q:P b),
+  forall H:a = b, eq_rect a P p b H = q -> JMeq (existT _ a p) (existT _ b q).
+intros.
+destruct H.
+destruct H0.
+reflexivity.
+Qed.
diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v
index 26339d51..c7a2a6c9 100644
--- a/test-suite/success/eauto.v
+++ b/test-suite/success/eauto.v
@@ -56,5 +56,5 @@ Lemma simpl_plus_l_rr1 :
  (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 *) 
+ eauto. (* does EApply H *)
 Qed.
diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v
index 082cbfbe..6423ad14 100644
--- a/test-suite/success/evars.v
+++ b/test-suite/success/evars.v
@@ -10,7 +10,7 @@ Definition c A (Q : (nat * A -> Prop) -> Prop) P :=
 
 (* What does this test ? *)
 Require Import List.
-Definition list_forall_bool (A : Set) (p : A -> bool) 
+Definition list_forall_bool (A : Set) (p : A -> bool)
   (l : list A) : bool :=
   fold_right (fun a r => if p a then r else false) true l.
 
@@ -109,21 +109,21 @@ Parameter map_avl: forall (elt elt' : Set) (f : elt -> elt') (m : t elt),
    avl m -> avl (map f m).
 Parameter map_bst: forall (elt elt' : Set) (f : elt -> elt') (m : t elt),
    bst m -> bst (map f m).
-Record bbst (elt:Set) : Set := 
+Record bbst (elt:Set) : Set :=
   Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}.
 Definition t' := bbst.
 Section B.
 Variables elt elt': Set.
-Definition map' f (m:t' elt) : t' elt' := 
+Definition map' f (m:t' elt) : t' elt' :=
   Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
 End B.
 Unset Implicit Arguments.
 
-(* An example from Lexicographic_Exponentiation that tests the 
+(* An example from Lexicographic_Exponentiation that tests the
    contraction of reducible fixpoints in type inference *)
 
 Require Import List.
-Check (fun (A:Set) (a b x:A) (l:list A) 
+Check (fun (A:Set) (a b x:A) (l:list A)
   (H : l ++ cons x nil = cons b (cons a nil)) =>
   app_inj_tail l (cons b nil) _ _ H).
 
@@ -133,14 +133,14 @@ Parameter h:(nat->nat)->(nat->nat).
 Fixpoint G p cont {struct p} :=
   h (fun n => match p with O => cont | S p => G p cont end n).
 
-(* An example from Bordeaux/Cantor that applies evar restriction 
+(* An example from Bordeaux/Cantor that applies evar restriction
    below  a binder *)
 
 Require Import Relations.
 Parameter lex : forall (A B : Set), (forall (a1 a2:A), {a1=a2}+{a1<>a2})
 -> relation A -> relation B -> A * B -> A * B -> Prop.
-Check 
- forall (A B : Set) eq_A_dec o1 o2, 
+Check
+ forall (A B : Set) eq_A_dec o1 o2,
  antisymmetric A o1 -> transitive A o1 -> transitive B o2 ->
  transitive _ (lex _ _ eq_A_dec o1 o2).
 
@@ -198,10 +198,26 @@ Goal forall x : nat, F1 x -> G1 x.
 refine (fun x H => proj2 (_ x H) _).
 Abort.
 
-(* Remark: the following example does not succeed any longer in 8.2 because,
-   the algorithm is more general and does exclude a solution that it should
-   exclude for typing reason. Handling of types and backtracking is still to
-   be done
+(* An example from y-not that was failing in 8.2rc1 *)
+
+Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) :=
+  match l with
+  | nil => nil
+  | (existT k v)::l' => (existT _ k v):: (filter A l')
+  end.
+
+(* Bug #2000: used to raise Out of memory in 8.2 while it should fail by
+   lack of information on the conclusion of the type of j *)
+
+Goal True.
+set (p:=fun j => j (or_intror _ (fun a:True => j (or_introl _ a)))) || idtac.
+Abort.
+
+(* Remark: the following example stopped succeeding at some time in
+   the development of 8.2 but it works again (this was because 8.2
+   algorithm was more general and did not exclude a solution that it
+   should have excluded for typing reason; handling of types and
+   backtracking is still to be done) *)
 
 Section S.
 Variables A B : nat -> Prop.
@@ -209,4 +225,16 @@ Goal forall x : nat, A x -> B x.
 refine (fun x H => proj2 (_ x H) _).
 Abort.
 End S.
-*)
+
+(* Check that constraints are taken into account by tactics that instantiate *)
+
+Lemma inj : forall n m, S n = S m -> n = m.
+intros n m H.
+eapply f_equal with (* should fail because ill-typed *)
+  (f := fun n =>
+        match n return match n with S _ => nat | _ => unit end with
+        | S n => n
+        | _ => tt
+        end) in H
+|| injection H.
+Abort.
diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v
index 74d87ffa..d3bdb1b6 100644
--- a/test-suite/success/extraction.v
+++ b/test-suite/success/extraction.v
@@ -9,10 +9,10 @@
 Require Import Arith.
 Require Import List.
 
-(**** A few tests for the extraction mechanism ****) 
+(**** A few tests for the extraction mechanism ****)
 
-(* Ideally, we should monitor the extracted output 
-   for changes, but this is painful. For the moment, 
+(* Ideally, we should monitor the extracted output
+   for changes, but this is painful. For the moment,
    we just check for failures of this script. *)
 
 (*** STANDARD EXAMPLES *)
@@ -23,7 +23,7 @@ Definition idnat (x:nat) := x.
 Extraction idnat.
 (* let idnat x = x *)
 
-Definition id (X:Type) (x:X) := x.      
+Definition id (X:Type) (x:X) := x.
 Extraction id. (* let id x = x *)
 Definition id' := id Set nat.
 Extraction id'. (* type id' = nat *)
@@ -47,7 +47,7 @@ Extraction test5.
 Definition cf (x:nat) (_:x <= 0) := S x.
 Extraction NoInline cf.
 Definition test6 := cf 0 (le_n 0).
-Extraction test6.  
+Extraction test6.
 (* let test6 = cf O *)
 
 Definition test7 := (fun (X:Set) (x:X) => x) nat.
@@ -60,9 +60,9 @@ Definition d2 := d Set.
 Extraction d2. (* type d2 = __ d *)
 Definition d3 (x:d Set) := 0.
 Extraction d3. (* let d3 _ = O *)
-Definition d4 := d nat. 
+Definition d4 := d nat.
 Extraction d4. (* type d4 = nat d *)
-Definition d5 := (fun x:d Type => 0) Type.  
+Definition d5 := (fun x:d Type => 0) Type.
 Extraction d5.  (* let d5 = O *)
 Definition d6 (x:d Type) := x.
 Extraction d6.  (* type 'x d6 = 'x *)
@@ -80,7 +80,7 @@ Definition test11 := let n := 0 in let p := S n in S p.
 Extraction test11. (* let test11 = S (S O) *)
 
 Definition test12 := forall x:forall X:Type, X -> X, x Type Type.
-Extraction test12. 
+Extraction test12.
 (* type test12 = (__ -> __ -> __) -> __ *)
 
 
@@ -115,14 +115,14 @@ Extraction test20.
 (** Simple inductive type and recursor. *)
 
 Extraction nat.
-(* 
-type nat = 
-  | O 
-  | S of nat 
+(*
+type nat =
+  | O
+  | S of nat
 *)
 
 Extraction sumbool_rect.
-(* 
+(*
 let sumbool_rect f f0 = function
   |  Left -> f __
   | Right -> f0 __
@@ -134,7 +134,7 @@ Inductive c (x:nat) : nat -> Set :=
   | refl : c x x
   | trans : forall y z:nat, c x y -> y <= z -> c x z.
 Extraction c.
-(* 
+(*
 type c =
   | Refl
   | Trans of nat * nat * c
@@ -150,7 +150,7 @@ Inductive Finite (U:Type) : Ensemble U -> Type :=
       forall A:Ensemble U,
         Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x).
 Extraction Finite.
-(* 
+(*
 type 'u finite =
   | Empty_is_finite
   | Union_is_finite of 'u finite * 'u
@@ -166,7 +166,7 @@ with forest : Set :=
   | Cons : tree -> forest -> forest.
 
 Extraction tree.
-(* 
+(*
 type tree =
   | Node of nat * forest
 and forest =
@@ -178,7 +178,7 @@ Fixpoint tree_size (t:tree) : nat :=
   match t with
   | Node a f => S (forest_size f)
   end
- 
+
  with forest_size (f:forest) : nat :=
   match f with
   | Leaf b => 1
@@ -186,7 +186,7 @@ Fixpoint tree_size (t:tree) : nat :=
   end.
 
 Extraction tree_size.
-(* 
+(*
 let rec tree_size = function
   | Node (a, f) -> S (forest_size f)
 and forest_size = function
@@ -203,13 +203,13 @@ Definition test14 := tata 0.
 Extraction test14.
 (* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
 Definition test15 := tata 0 1.
-Extraction test15. 
+Extraction test15.
 (* let test15 x x0 = Tata (O, (S O), x, x0) *)
 
 Inductive eta : Type :=
     eta_c : nat -> Prop -> nat -> Prop -> eta.
 Extraction eta_c.
-(* 
+(*
 type eta =
   | Eta_c of nat * nat
 *)
@@ -220,15 +220,15 @@ Definition test17 := eta_c 0 True.
 Extraction test17.
 (* let test17 x = Eta_c (O, x) *)
 Definition test18 := eta_c 0 True 0.
-Extraction test18. 
+Extraction test18.
 (* let test18 _ = Eta_c (O, O) *)
 
 
 (** Example of singleton inductive type *)
 
 Inductive bidon (A:Prop) (B:Type) : Type :=
-    tb : forall (x:A) (y:B), bidon A B. 
-Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) 
+    tb : forall (x:A) (y:B), bidon A B.
+Definition fbidon (A B:Type) (f:A -> B -> bidon True nat)
   (x:A) (y:B) := f x y.
 Extraction bidon.
 (* type 'b bidon = 'b *)
@@ -252,11 +252,11 @@ Extraction fbidon2.
 Inductive test_0 : Prop :=
     ctest0 : test_0
 with test_1 : Set :=
-    ctest1 : test_0 -> test_1.  
+    ctest1 : test_0 -> test_1.
 Extraction test_0.
 (* test0 : logical inductive *)
-Extraction test_1. 
-(* 
+Extraction test_1.
+(*
 type test1 =
   | Ctest1
 *)
@@ -277,19 +277,19 @@ Inductive tp1 : Type :=
 with tp2 : Type :=
     T' : tp1 -> tp2.
 Extraction tp1.
-(* 
+(*
 type tp1 =
   | T of __ * tp2
 and tp2 =
   | T' of tp1
-*) 
+*)
 
 Inductive tp1bis : Type :=
     Tbis : tp2bis -> tp1bis
 with tp2bis : Type :=
     T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis.
 Extraction tp1bis.
-(* 
+(*
 type tp1bis =
   | Tbis of tp2bis
 and tp2bis =
@@ -344,8 +344,8 @@ intros.
 exact n.
 Qed.
 Extraction oups.
-(* 
-let oups h0 = 
+(*
+let oups h0 =
   match Obj.magic h0 with
     | Nil -> h0
     | Cons0 (n, l) -> n
@@ -357,7 +357,7 @@ let oups h0 =
 Definition horibilis (b:bool) :=
   if b as b return (if b then Type else nat) then Set else 0.
 Extraction horibilis.
-(* 
+(*
 let horibilis = function
   | True -> Obj.magic __
   | False -> Obj.magic O
@@ -370,8 +370,8 @@ Definition natbool (b:bool) := if b then nat else bool.
 Extraction natbool. (* type natbool = __ *)
 
 Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true.
-Extraction zerotrue. 
-(* 
+Extraction zerotrue.
+(*
 let zerotrue = function
   | True -> Obj.magic O
   | False -> Obj.magic True
@@ -383,7 +383,7 @@ Definition natTrue (b:bool) := if b return Type then nat else True.
 
 Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True.
 Extraction zeroTrue.
-(* 
+(*
 let zeroTrue = function
   | True -> Obj.magic O
   | False -> Obj.magic __
@@ -393,7 +393,7 @@ Definition natTrue2 (b:bool) := if b return Type then nat else True.
 
 Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I.
 Extraction zeroprop.
-(* 
+(*
 let zeroprop = function
   | True -> Obj.magic O
   | False -> Obj.magic __
@@ -410,8 +410,8 @@ Extraction test21.
 Definition test22 :=
   (fun f:forall X:Type, X -> X => (f nat 0, f bool true))
     (fun (X:Type) (x:X) => x).
-Extraction test22. 
-(* let test22 = 
+Extraction test22.
+(* let test22 =
   let f = fun x -> x in Pair ((f O), (f True)) *)
 
 (* still ok via optim beta -> let *)
@@ -461,8 +461,8 @@ Extraction f_normal.
 (* inductive with magic needed *)
 
 Inductive Boite : Set :=
-    boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. 
-Extraction Boite. 
+    boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite.
+Extraction Boite.
 (*
 type boite =
   | Boite of bool * __
@@ -482,8 +482,8 @@ Definition test_boite (B:Boite) :=
   | boite true n => n
   | boite false n => fst n + snd n
   end.
-Extraction test_boite. 
-(* 
+Extraction test_boite.
+(*
 let test_boite = function
   | Boite (b0, n) ->
       (match b0 with
@@ -494,23 +494,23 @@ let test_boite = function
 (* singleton inductive with magic needed *)
 
 Inductive Box : Type :=
-    box : forall A:Set, A -> Box. 
+    box : forall A:Set, A -> Box.
 Extraction Box.
 (* type box = __ *)
 
-Definition box1 := box nat 0. 
+Definition box1 := box nat 0.
 Extraction box1. (* let box1 = Obj.magic O *)
 
 (* applied constant, magic needed *)
 
 Definition idzarb (b:bool) (x:if b then nat else bool) := x.
 Definition zarb := idzarb true 0.
-Extraction NoInline idzarb. 
-Extraction zarb. 
+Extraction NoInline idzarb.
+Extraction zarb.
 (* let zarb = Obj.magic idzarb True (Obj.magic O) *)
 
 (** function of variable arity. *)
-(** Fun n = nat -> nat -> ... -> nat *)  
+(** Fun n = nat -> nat -> ... -> nat *)
 
 Fixpoint Fun (n:nat) : Set :=
   match n with
@@ -532,20 +532,20 @@ Fixpoint proj (k n:nat) {struct n} : Fun n :=
       | O => fun x => Const x n
       | S k => fun x => proj k n
       end
-  end. 
+  end.
 
 Definition test_proj := proj 2 4 0 1 2 3.
 
-Eval compute in test_proj. 
+Eval compute in test_proj.
 
-Recursive Extraction test_proj. 
+Recursive Extraction test_proj.
 
 
 
-(*** TO SUM UP: ***) 
+(*** TO SUM UP: ***)
 
 (* Was previously producing a "test_extraction.ml" *)
-Recursive Extraction 
+Recursive Extraction
   idnat id id' test2 test3 test4 test5 test6 test7 d d2
   d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
   test13 test19 test20 nat sumbool_rect c Finite tree
@@ -581,7 +581,7 @@ Recursive Extraction
  zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
  f_arity f_normal Boite boite1 boite2 test_boite Box box1
  zarb test_proj.
-                     
+
 
 (*** Finally, a test more focused on everyday's life situations ***)
 
diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v
index 78b01f3e..be4e0684 100644
--- a/test-suite/success/fix.v
+++ b/test-suite/success/fix.v
@@ -47,10 +47,10 @@ Fixpoint maxVar (e : rExpr) : rNat :=
 
 Require Import Streams.
 
-Definition decomp (s:Stream nat) : Stream nat := 
+Definition decomp (s:Stream nat) : Stream nat :=
   match s with Cons _ s => s end.
 
-CoFixpoint bx0 : Stream nat := Cons 0 bx1 
+CoFixpoint bx0 : Stream nat := Cons 0 bx1
 with bx1 : Stream nat := Cons 1 bx0.
 
 Lemma bx0bx : decomp bx0 = bx1.
diff --git a/test-suite/success/hyps_inclusion.v b/test-suite/success/hyps_inclusion.v
index 21bfc075..af81e53d 100644
--- a/test-suite/success/hyps_inclusion.v
+++ b/test-suite/success/hyps_inclusion.v
@@ -8,7 +8,7 @@
    tactics were using Typing.type_of and not Typeops.typing; the former
    was not checking hyps inclusion so that the discrepancy in the types
    of section variables seen as goal variables was not a problem (at the
-   end, when the proof is completed, the section variable recovers its 
+   end, when the proof is completed, the section variable recovers its
    original type and all is correct for Typeops) *)
 
 Section A.
@@ -16,9 +16,9 @@ Variable H:not True.
 Lemma f:nat->nat. destruct H. exact I. Defined.
 Goal f 0=f 1.
 red in H.
-(* next tactic was failing wrt bug #1325 because type-checking the goal 
+(* next tactic was failing wrt bug #1325 because type-checking the goal
    detected a syntactically different type for the section variable H *)
-case 0. 
+case 0.
 Reset A.
 
 (* Variant with polymorphic inductive types for bug #1325 *)
diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v
index 9034d6a6..59e1a935 100644
--- a/test-suite/success/implicit.v
+++ b/test-suite/success/implicit.v
@@ -1,3 +1,5 @@
+(* Testing the behavior of implicit arguments *)
+
 (* Implicit on section variables *)
 
 Set Implicit Arguments.
@@ -12,15 +14,53 @@ Infix "#" := op (at level 70).
 Check (forall x : A, x # x).
 
 (* Example submitted by Christine *)
-Record stack : Type := 
+
+Record stack : Type :=
   {type : Set; elt : type; empty : type -> bool; proof : empty elt = true}.
 
 Check
   (forall (type : Set) (elt : type) (empty : type -> bool),
    empty elt = true -> stack).
 
+(* Nested sections and manual/automatic implicit arguments *)
+
+Variable op' : forall A : Set, A -> A -> Set.
+Variable op'' : forall A : Set, A -> A -> Set.
+
+Section B.
+
+Definition eq1 := fun (A:Type) (x y:A) => x=y.
+Definition eq2 := fun (A:Type) (x y:A) => x=y.
+Definition eq3 := fun (A:Type) (x y:A) => x=y.
+
+Implicit Arguments op' [].
+Global Implicit Arguments op'' [].
+
+Implicit Arguments eq2 [].
+Global Implicit Arguments eq3 [].
+
+Check (op 0 0).
+Check (op' nat 0 0).
+Check (op'' nat 0 0).
+Check (eq1 0 0).
+Check (eq2 nat 0 0).
+Check (eq3 nat 0 0).
+
+End B.
+
+Check (op 0 0).
+Check (op' 0 0).
+Check (op'' nat 0 0).
+Check (eq1 0 0).
+Check (eq2 0 0).
+Check (eq3 nat 0 0).
+
 End Spec.
 
+Check (eq1 0 0).
+Check (eq2 0 0).
+Check (eq3 nat 0 0).
+
 (* Example submitted by Frédéric (interesting in v8 syntax) *)
 
 Parameter f : nat -> nat * nat.
@@ -42,7 +82,7 @@ Inductive P n : nat -> Prop := c : P n n.
 Require Import List.
 
 Fixpoint plus n m {struct n} :=
-  match n with 
+  match n with
   | 0 => m
   | S p => S (plus p m)
   end.
diff --git a/test-suite/success/import_lib.v b/test-suite/success/import_lib.v
index c3dc2fc6..fcedb2b1 100644
--- a/test-suite/success/import_lib.v
+++ b/test-suite/success/import_lib.v
@@ -1,8 +1,8 @@
 Definition le_trans := 0.
 
 
-Module Test_Read.     
-  Module M.  
+Module Test_Read.
+  Module M.
     Require Le.        (* Reading without importing *)
 
     Check Le.le_trans.
@@ -12,7 +12,7 @@ Module Test_Read.
     Qed.
   End M.
 
-  Check Le.le_trans. 
+  Check Le.le_trans.
 
   Lemma th0 : le_trans = 0.
     reflexivity.
@@ -32,84 +32,84 @@ Definition le_decide := 1.  (* from Arith/Compare *)
 Definition min := 0.            (* from Arith/Min *)
 
 Module Test_Require.
-  
+
   Module M.
     Require Import Compare.              (* Imports Min as well *)
-  
+
     Lemma th1 : le_decide = le_decide.
       reflexivity.
     Qed.
-  
+
     Lemma th2 : min = min.
       reflexivity.
     Qed.
-  
+
   End M.
-  
+
   (* Checks that Compare and List are loaded *)
   Check Compare.le_decide.
   Check Min.min.
-  
-  
+
+
   (* Checks that Compare and List are _not_ imported *)
   Lemma th1 : le_decide = 1.
     reflexivity.
   Qed.
-  
+
   Lemma th2 : min = 0.
     reflexivity.
   Qed.
-  
+
   (* It should still be the case after Import M *)
   Import M.
-  
+
   Lemma th3 : le_decide = 1.
     reflexivity.
   Qed.
-  
+
   Lemma th4 : min = 0.
     reflexivity.
   Qed.
 
-End Test_Require.  
+End Test_Require.
 
 (****************************************************************)
 
 Module Test_Import.
   Module M.
     Import Compare.              (* Imports Min as well *)
-  
+
     Lemma th1 : le_decide = le_decide.
       reflexivity.
     Qed.
-  
+
     Lemma th2 : min = min.
       reflexivity.
     Qed.
-  
+
   End M.
-  
+
   (* Checks that Compare and List are loaded *)
   Check Compare.le_decide.
   Check Min.min.
-  
-  
+
+
   (* Checks that Compare and List are _not_ imported *)
   Lemma th1 : le_decide = 1.
     reflexivity.
   Qed.
-  
+
   Lemma th2 : min = 0.
     reflexivity.
   Qed.
-  
+
   (* It should still be the case after Import M *)
   Import M.
-  
+
   Lemma th3 : le_decide = 1.
     reflexivity.
   Qed.
-  
+
   Lemma th4 : min = 0.
     reflexivity.
   Qed.
diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v
index 2aec6e9b..8e1a8d18 100644
--- a/test-suite/success/induct.v
+++ b/test-suite/success/induct.v
@@ -5,7 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* Teste des definitions inductives imbriquees *)
+
+(* Test des definitions inductives imbriquees *)
 
 Require Import List.
 
@@ -15,3 +16,28 @@ Inductive X : Set :=
 Inductive Y : Set :=
     cons2 : list (Y * Y) -> Y.
 
+(* Test inductive types with local definitions *)
+
+Inductive eq1 : forall A:Type, let B:=A in A -> Prop :=
+  refl1 : eq1 True I.
+
+Check
+ fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
+   let B := A in
+     fun (a : A) (e : eq1 A a) =>
+       match e in (eq1 A0 B0 a0) return (P A0 a0) with
+       | refl1 => f
+       end.
+
+Inductive eq2 (A:Type) (a:A)
+  : forall B C:Type, let D:=(A*B*C)%type in D -> Prop :=
+  refl2 : eq2 A a unit bool (a,tt,true).
+
+(* Check that induction variables are cleared even with in clause *)
+
+Lemma foo : forall n m : nat, n + m = n + m.
+Proof.
+  intros; induction m as [|m] in n |- *.
+  auto.
+  auto.
+Qed.
diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v
index 757cf6a4..dfa41c82 100644
--- a/test-suite/success/ltac.v
+++ b/test-suite/success/ltac.v
@@ -3,7 +3,7 @@
 (* Submitted by Pierre Crégut *)
 (* Checks substitution of x *)
 Ltac f x := unfold x in |- *; idtac.
- 
+
 Lemma lem1 : 0 + 0 = 0.
 f plus.
 reflexivity.
@@ -25,7 +25,7 @@ U.
 Qed.
 
 (* Check that Match giving non-tactic arguments are evaluated at Let-time *)
- 
+
 Ltac B := let y := (match goal with
                     | z:_ |- _ => z
                     end) in
@@ -152,6 +152,7 @@ Abort.
 Ltac afi tac := intros; tac.
 Goal 1 = 2.
 afi ltac:auto.
+Abort.
 
 (* Tactic Notation avec listes *)
 
@@ -179,8 +180,8 @@ Abort.
 (* Check second-order pattern unification *)
 
 Ltac to_exist :=
-  match goal with 
-  |- forall x y, @?P x y => 
+  match goal with
+  |- forall x y, @?P x y =>
     let Q := eval lazy beta in (exists x, forall y, P x y) in
     assert (Q->Q)
   end.
@@ -201,7 +202,7 @@ Abort.
 
 (* Utilisation de let rec sans arguments *)
 
-Ltac is := 
+Ltac is :=
   let rec i := match goal with |- ?A -> ?B => intro; i | _ => idtac end in
   i.
 
@@ -220,3 +221,25 @@ Z1 O.
 Z2 ltac:O.
 exact I.
 Qed.
+
+(* Illegal application used to make Ltac loop. *)
+
+Section LtacLoopTest.
+  Ltac f x := idtac.
+  Goal True.
+  Timeout 1 try f()().
+  Abort.
+End LtacLoopTest.
+
+(* Test binding of open terms *)
+
+Ltac test_open_match z :=
+  match z with
+    (forall y x, ?h = 0) => assert (forall x y, h = x + y)
+  end.
+
+Goal True.
+test_open_match (forall z y, y + z  = 0).
+reflexivity.
+apply I.
+Qed.
diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v
index 463efed3..f63dfc38 100644
--- a/test-suite/success/mutual_ind.v
+++ b/test-suite/success/mutual_ind.v
@@ -9,7 +9,7 @@
 
 Require Export List.
 
- Record signature : Type := 
+ Record signature : Type :=
    {sort : Set;
     sort_beq : sort -> sort -> bool;
     sort_beq_refl : forall f : sort, true = sort_beq f f;
@@ -20,14 +20,14 @@ Require Export List.
     fsym_beq_refl : forall f : fsym, true = fsym_beq f f;
     fsym_beq_eq : forall f1 f2 : fsym, true = fsym_beq f1 f2 -> f1 = f2}.
 
- 
+
  Variable F : signature.
 
   Definition vsym := (sort F * nat)%type.
 
   Definition vsym_sort := fst (A:=sort F) (B:=nat).
   Definition vsym_nat := snd (A:=sort F) (B:=nat).
- 
+
 
   Inductive term : sort F -> Set :=
     | term_var : forall v : vsym, term (vsym_sort v)
diff --git a/test-suite/success/parsing.v b/test-suite/success/parsing.v
index d1b679d5..3d06d1d0 100644
--- a/test-suite/success/parsing.v
+++ b/test-suite/success/parsing.v
@@ -2,7 +2,7 @@ Section A.
 Notation "*" := O (at level 8).
 Notation "**" := O (at level 99).
 Notation "***" := O (at level 9).
-End A.                         
+End A.
 Notation "*" := O (at level 8).
 Notation "**" := O (at level 99).
 Notation "***" := O (at level 9).
diff --git a/test-suite/success/pattern.v b/test-suite/success/pattern.v
index 28d0bd55..72f84052 100644
--- a/test-suite/success/pattern.v
+++ b/test-suite/success/pattern.v
@@ -5,3 +5,45 @@
 
 Goal (id true,id false)=(id true,id true).
 generalize bool at 2 4 6 8 10 as B, true at 3 as tt, false as ff.
+Abort.
+
+(* Check use of occurrences in hypotheses for a reduction tactic such
+   as pattern *)
+
+(* Did not work in 8.2 *)
+Goal 0=0->True.
+intro H.
+pattern 0 in H at 2.
+set (f n := 0 = n) in H.  (* check pattern worked correctly *)
+Abort.
+
+(* Syntactic variant which was working in 8.2 *)
+Goal 0=0->True.
+intro H.
+pattern 0 at 2 in H.
+set (f n := 0 = n) in H.  (* check pattern worked correctly *)
+Abort.
+
+(* Ambiguous occurrence selection *)
+Goal 0=0->True.
+intro H.
+pattern 0 at 1 in H at 2 || exact I.  (* check pattern fails *)
+Qed.
+
+(* Ambiguous occurrence selection *)
+Goal 0=1->True.
+intro H.
+pattern 0, 1 in H at 1 2 || exact I.  (* check pattern fails *)
+Qed.
+
+(* Occurrence selection shared over hypotheses is difficult to advocate and
+   hence no longer allowed *)
+Goal 0=1->1=0->True.
+intros H1 H2.
+pattern 0 at 1, 1 in H1, H2 || exact I.  (* check pattern fails *)
+Qed.
+
+(* Test catching of reduction tactics errors (was not the case in 8.2) *)
+Goal eq_refl 0 = eq_refl 0.
+pattern 0 at 1 || reflexivity.
+Qed.
diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v
index b654277c..4d743a6d 100644
--- a/test-suite/success/refine.v
+++ b/test-suite/success/refine.v
@@ -7,7 +7,7 @@ exists y; auto.
 Save test1.
 
 Goal exists x : nat, x = 0.
- refine (let y := 0 + 0 in ex_intro _ (y + y) _).  
+ refine (let y := 0 + 0 in ex_intro _ (y + y) _).
 auto.
 Save test2.
 
@@ -79,7 +79,7 @@ Abort.
 (* Used to failed with error not clean *)
 
 Definition div :
-  forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) -> 
+  forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) ->
      forall n:nat, {q:nat | x = q*n}.
 refine
   (fun m div_rec n =>
@@ -94,7 +94,7 @@ Abort.
 
 Goal
   forall f : forall a (H:a=a), Prop,
- (forall a (H:a = a :> nat), f a H -> True /\ True) -> 
+ (forall a (H:a = a :> nat), f a H -> True /\ True) ->
   True.
 intros.
 refine (@proj1 _ _ (H 0 _ _)).
@@ -105,13 +105,13 @@ Abort.
 
 Require Import Peano_dec.
 
-Definition fact_F : 
+Definition fact_F :
   forall (n:nat),
   (forall m, m<n -> nat) ->
   nat.
-refine 
+refine
   (fun n fact_rec =>
-     if eq_nat_dec n 0 then 
+     if eq_nat_dec n 0 then
         1
      else
 	let fn := fact_rec (n-1) _ in
diff --git a/test-suite/success/replace.v b/test-suite/success/replace.v
index 94b75c7f..0b112937 100644
--- a/test-suite/success/replace.v
+++ b/test-suite/success/replace.v
@@ -5,7 +5,7 @@ Undo.
 intros x H H0.
 replace x with 0.
 Undo.
-replace x with 0 in  |- *. 
+replace x with 0 in  |- *.
 Undo.
 replace x with 1 in *.
 Undo.
@@ -22,3 +22,11 @@ replace x with 0 in H,H0 |- * .
 Undo.
 Admitted.
 
+(* This failed at some point when "replace" started to support arguments
+   with evars but "abstract" did not supported any evars even defined ones *)
+
+Class U.
+Lemma l (u : U) (f : U -> nat) (H : 0 = f u) : f u = 0.
+replace (f _) with 0 by abstract apply H.
+reflexivity.
+Qed.
diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v
index 86e55922..3bce52fe 100644
--- a/test-suite/success/rewrite.v
+++ b/test-suite/success/rewrite.v
@@ -38,3 +38,73 @@ Goal forall n, 0 + n = n -> True.
 intros n H.
 rewrite plus_0_l in H.
 Abort.
+
+(* Rewrite dependent proofs from left-to-right *)
+
+Lemma l1 :
+  forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H.
+intros x y H P H0.
+rewrite H.
+rewrite H in H0.
+assumption.
+Qed.
+
+(* Rewrite dependent proofs from right-to-left *)
+
+Lemma l2 :
+  forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H.
+intros x y H P H0.
+rewrite <- H.
+rewrite <- H in H0.
+assumption.
+Qed.
+
+(* Check rewriting dependent proofs with non-symmetric equalities *)
+
+Lemma l3:forall x (H:eq_true x) (P:forall x, eq_true x -> Type), P x H -> P x H.
+intros x H P H0.
+rewrite H.
+rewrite H in H0.
+assumption.
+Qed.
+
+(* Dependent rewrite *)
+
+Require Import JMeq.
+
+Goal forall A B (a:A) (b:B), JMeq a b -> JMeq b a -> True.  
+inversion 1; (* Goal is now [JMeq a a -> True] *) dependent rewrite H3.
+Undo.
+intros; inversion H; dependent rewrite H4 in H0.
+Undo.
+intros; inversion H; dependent rewrite <- H4 in H0.
+Abort.
+
+(* Test conversion between terms with evars that both occur in K-redexes and
+   are elsewhere solvable.
+
+   This is quite an artificial example, but it used to work in 8.2.
+
+   Since rewrite supports conversion on terms without metas, it
+   was successively unifying (id 0 ?y) and 0 where ?y was not a
+   meta but, because coming from a "_", an evar.
+
+   After commit r12440 which unified the treatment of metas and
+   evars, it stopped to work. Chung-Kil Hur's Heq package used
+   this feature. Solved in r13...
+*)
+
+Parameter g : nat -> nat -> nat.
+Definition K (x y:nat) := x.
+
+Goal (forall y, g y (K 0 y) = 0) -> g 0 0 = 0.
+intros.
+rewrite (H _).
+reflexivity.
+Qed.
+
+Goal (forall y, g (K 0 y) y = 0) -> g 0 0 = 0.
+intros.
+rewrite (H _).
+reflexivity.
+Qed.
diff --git a/test-suite/success/setoid_ring_module.v b/test-suite/success/setoid_ring_module.v
index e947c6d9..2d9e85b5 100644
--- a/test-suite/success/setoid_ring_module.v
+++ b/test-suite/success/setoid_ring_module.v
@@ -11,11 +11,11 @@ Parameters (Coef:Set)(c0 c1 : Coef)
 (ceq_refl : forall x, ceq x x).
 
 
-Add Relation Coef ceq 
+Add Relation Coef ceq
   reflexivity proved by ceq_refl symmetry proved by ceq_sym
   transitivity proved by ceq_trans
   as ceq_relation.
-  
+
 Add Morphism cadd with signature ceq ==> ceq ==> ceq as cadd_Morphism.
 Admitted.
 
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index be5999df..033b3f48 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -124,7 +124,7 @@ Goal forall
   (f : Prop -> Prop)
   (Q : (nat -> Prop) -> Prop)
   (H : forall (h : nat -> Prop), Q (fun x : nat => f (h x)) <-> True)
-  (h:nat -> Prop), 
+  (h:nat -> Prop),
   Q (fun x : nat => f (Q (fun b : nat => f (h x)))) <-> True.
 intros f0 Q H.
 setoid_rewrite H.
diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v
index b89787bb..6baf7970 100644
--- a/test-suite/success/setoid_test2.v
+++ b/test-suite/success/setoid_test2.v
@@ -205,7 +205,7 @@ Theorem test6:
  rewrite  H.
  assumption.
 Qed.
-  
+
 Theorem test7:
  forall E1 E2 y y', (eqS1 E1 E2) -> (eqS2 y y') ->
   (f_test6 (g_test6 (h_test6 E2))) ->
@@ -228,7 +228,7 @@ Add Morphism f_test8 : f_compat_test8. Admitted.
 Axiom eqS1_test8': S1_test8 -> S1_test8 -> Prop.
 Axiom SetoidS1_test8' : Setoid_Theory S1_test8 eqS1_test8'.
 Add Setoid S1_test8 eqS1_test8' SetoidS1_test8' as S1_test8setoid'.
-    
+
 (*CSC: for test8 to be significant I want to choose the setoid
   (S1_test8, eqS1_test8'). However this does not happen and
   there is still no syntax for it ;-( *)
diff --git a/test-suite/success/setoid_test_function_space.v b/test-suite/success/setoid_test_function_space.v
index ead93d91..381cda2c 100644
--- a/test-suite/success/setoid_test_function_space.v
+++ b/test-suite/success/setoid_test_function_space.v
@@ -9,11 +9,11 @@ Hint Unfold feq.
 Lemma feq_refl: forall f, f =f f.
 intuition.
 Qed.
-                                                                                
+
 Lemma feq_sym: forall f g, f =f g-> g =f f.
 intuition.
 Qed.
-                                                                                
+
 Lemma feq_trans: forall f g h, f =f g-> g =f h -> f  =f h.
 unfold feq. intuition.
 rewrite H.
@@ -22,7 +22,7 @@ Qed.
 End feq.
 Infix "=f":= feq  (at level 80, right associativity).
 Hint Unfold feq. Hint Resolve feq_refl feq_sym feq_trans.
-                                                                                
+
 Variable K:(nat -> nat)->Prop.
 Variable K_ext:forall a b, (K a)->(a =f b)->(K b).
 
@@ -30,7 +30,7 @@ Add Parametric Relation (A B : Type) : (A -> B) (@feq A B)
  reflexivity proved by (@feq_refl A B)
  symmetry proved by (@feq_sym A B)
  transitivity proved by (@feq_trans A B) as funsetoid.
-                                                                             
+
 Add Morphism K with signature (@feq nat nat) ==> iff as K_ext1.
 intuition. apply (K_ext H0 H).
 intuition. assert (y =f x);auto.  apply (K_ext H0 H1).
diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v
index b4de4932..271e6ef7 100644
--- a/test-suite/success/simpl.v
+++ b/test-suite/success/simpl.v
@@ -2,12 +2,12 @@
 (* (cf bug #1031) *)
 
 Inductive tree : Set :=
-| node : nat -> forest -> tree  
+| node : nat -> forest -> tree
 with forest    : Set :=
-| leaf : forest  
-| cons : tree    -> forest   -> forest  
+| leaf : forest
+| cons : tree    -> forest   -> forest
     .
-Definition copy_of_compute_size_forest := 
+Definition copy_of_compute_size_forest :=
 fix copy_of_compute_size_forest (f:forest) : nat :=
   match f with
   | leaf => 1
diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v
index 4929ae4c..57837321 100644
--- a/test-suite/success/specialize.v
+++ b/test-suite/success/specialize.v
@@ -2,7 +2,7 @@
 Goal forall a b c : nat,  a = b -> b = c -> forall d, a+d=c+d.
 intros.
 
-(* "compatibility" mode: specializing a global name 
+(* "compatibility" mode: specializing a global name
    means a kind of generalize *)
 
 specialize trans_equal. intros _.
diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v
index 35910011..0a1d4657 100644
--- a/test-suite/success/unfold.v
+++ b/test-suite/success/unfold.v
@@ -8,7 +8,7 @@
 (* Test le Hint Unfold sur des var locales *)
 
 Section toto.
-Let EQ := eq.
+Let EQ := @eq.
 Goal EQ nat 0 0.
 Hint Unfold EQ.
 auto.
diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v
index 91ee18ea..ddf122e8 100644
--- a/test-suite/success/unification.v
+++ b/test-suite/success/unification.v
@@ -1,15 +1,15 @@
 (* Test patterns unification *)
 
-Lemma l1 : (forall P, (exists x:nat, P x) -> False) 
+Lemma l1 : (forall P, (exists x:nat, P x) -> False)
          -> forall P, (exists x:nat, P x /\ P x) -> False.
 Proof.
 intros; apply (H _ H0).
 Qed.
 
 Lemma l2 :  forall A:Set, forall Q:A->Set,
-           (forall (P: forall x:A, Q x -> Prop), 
-                   (exists x:A, exists y:Q x, P x y) -> False) 
-         -> forall (P: forall x:A, Q x -> Prop), 
+           (forall (P: forall x:A, Q x -> Prop),
+                   (exists x:A, exists y:Q x, P x y) -> False)
+         -> forall (P: forall x:A, Q x -> Prop),
                    (exists x:A, exists y:Q x, P x y /\ P x y) -> False.
 Proof.
 intros; apply (H _ H0).
@@ -43,7 +43,7 @@ Check (fun _h1 => (zenon_notall nat _ (fun _T_0 =>
 
    Note that the example originally came from a non re-typable
    pretty-printed term (the checked term is actually re-printed the
-   same form it is checked).  
+   same form it is checked).
 *)
 
 Set Implicit Arguments.
@@ -73,10 +73,10 @@ Qed.
 
 (* Test unification modulo eta-expansion (if possible) *)
 
-(* In this example, two instances for ?P (argument of hypothesis H) can be 
+(* In this example, two instances for ?P (argument of hypothesis H) can be
    inferred (one is by unifying the type [Q true] and [?P true] of the
    goal and type of [H]; the other is by unifying the argument of [f]);
-   we need to unify both instances up to allowed eta-expansions of the 
+   we need to unify both instances up to allowed eta-expansions of the
    instances (eta is allowed if the meta was applied to arguments)
 
    This used to fail before revision 9389 in trunk
@@ -92,7 +92,7 @@ Qed.
 
 (* Test instanciation of evars by unification *)
 
-Goal (forall x, 0 * x = 0 -> True) -> True.    
+Goal (forall x, 0 + x = 0 -> True) -> True.
 intros; eapply H.
 rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *)
 Abort.
@@ -126,3 +126,13 @@ intros.
 exists (fun n => match n with O => a | S n' => f' n' end).
 constructor.
 Qed.
+
+(* Check use of types in unification (see Andrej Bauer's mail on
+   coq-club, June 1 2009; it did not work in 8.2, probably started to
+   work after Sozeau improved support for the use of types in unification) *)
+
+Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) ->
+ forall (A B C : Set) (g : (A -> B) -> C) (f : A -> B), g (fun x => f x) = g f.
+Proof.
+  intros.
+  rewrite H.
diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v
index 3c2c0883..469cbeb7 100644
--- a/test-suite/success/univers.v
+++ b/test-suite/success/univers.v
@@ -29,9 +29,9 @@ Inductive dep_eq : forall X : Type, X -> X -> Prop :=
       forall (A : Type) (B : A -> Type),
       let T := forall x : A, B x in
       forall (f g : T) (x : A), dep_eq (B x) (f x) (g x) -> dep_eq T f g.
-                                                                                
+
 Require Import Relations.
-                                                                                
+
 Theorem dep_eq_trans : forall X : Type, transitive X (dep_eq X).
 Proof.
   unfold transitive in |- *.
@@ -51,7 +51,7 @@ Abort.
 
    Especially, universe refreshing was not done for "set/pose" *)
 
-Lemma ind_unsec : forall Q : nat -> Type, True. 
+Lemma ind_unsec : forall Q : nat -> Type, True.
 intro.
 set (C := forall m, Q m -> Q m).
 exact I.
diff --git a/test-suite/typeclasses/clrewrite.v b/test-suite/typeclasses/clrewrite.v
index 2978fda2..f21acd4c 100644
--- a/test-suite/typeclasses/clrewrite.v
+++ b/test-suite/typeclasses/clrewrite.v
@@ -15,7 +15,7 @@ Section Equiv.
   Qed.
 
   Tactic Notation "simpl" "*" := auto || relation_tac.
-  
+
   Goal eqA x y -> eqA y x /\ True.
     intros H ; clrewrite H.
     split ; simpl*.
@@ -27,13 +27,13 @@ Section Equiv.
   Qed.
 
   Goal eqA x y -> eqA y z -> eqA x y.
-    intros H. 
+    intros H.
     clrewrite H.
     intro. refl.
   Qed.
-        
+
   Goal eqA x y -> eqA z y -> eqA x y.
-    intros H. 
+    intros H.
     clrewrite <- H at 2.
     clrewrite <- H at 1.
     intro. refl.
@@ -54,7 +54,7 @@ Section Equiv.
     clrewrite <- H.
     refl.
   Qed.
-  
+
   Goal eqA x y -> True /\ True /\ False /\ eqA x x -> True /\ True /\ False /\ eqA x y.
   Proof.
     intros.
@@ -70,12 +70,12 @@ Section Trans.
   Variables x y z w : A.
 
   Tactic Notation "simpl" "*" := auto || relation_tac.
-  
+
 (*   Typeclasses eauto := debug. *)
 
   Goal R x y -> R y x -> R y y -> R x x.
   Proof with auto.
-    intros H H' H''. 
+    intros H H' H''.
 
     clrewrite <- H' at 2.
     clrewrite H at 1...
@@ -86,11 +86,11 @@ Section Trans.
     clrewrite H.
     refl.
   Qed.
-        
+
   Goal R x y -> R z y -> R x y.
-    intros H. 
+    intros H.
     clrewrite <- H at 2.
-    intro. 
+    intro.
     clrewrite H at 1.
   Abort.
 
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
index be065f1d..18dbd27f 100644
--- a/theories/Arith/Arith.v
+++ b/theories/Arith/Arith.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Arith.v 9302 2006-10-27 21:21:17Z barras $ i*)
+(*i $Id$ i*)
 
 Require Export Arith_base.
 Require Export ArithRing.
diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v
index fbdf2a41..2d54f0e8 100644
--- a/theories/Arith/Arith_base.v
+++ b/theories/Arith/Arith_base.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Arith_base.v 11072 2008-06-08 16:13:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Le.
 Require Export Lt.
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index 2e9472c4..208c2578 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Between.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Le.
 Require Import Lt.
@@ -17,11 +17,11 @@ Implicit Types k l p q r : nat.
 
 Section Between.
   Variables P Q : nat -> Prop.
-  
+
   Inductive between k : nat -> Prop :=
     | bet_emp : between k k
     | bet_S : forall l, between k l -> P l -> between k (S l).
-  
+
   Hint Constructors between: arith v62.
 
   Lemma bet_eq : forall k l, l = k -> between k l.
@@ -185,5 +185,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. 
+  in_int_S in_int_intro: arith v62.
 Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
index fed650ab..9fd59e10 100644
--- a/theories/Arith/Bool_nat.v
+++ b/theories/Arith/Bool_nat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Bool_nat.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 Require Export Compare_dec.
 Require Export Peano_dec.
diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v
index 06898658..0f2595b2 100644
--- a/theories/Arith/Compare.v
+++ b/theories/Arith/Compare.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare.v 9302 2006-10-27 21:21:17Z barras $ i*)
+(*i $Id$ i*)
 
 (** Equality is decidable on [nat] *)
 
@@ -52,4 +52,4 @@ Qed.
 
 Require Export Wf_nat.
 
-Require Export Min.
+Require Export Min Max.
\ No newline at end of file
diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
index e6cb5be4..8fc92579 100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare_dec.v 10295 2007-11-06 22:46:21Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import Le.
 Require Import Lt.
@@ -18,20 +18,24 @@ Open Local Scope nat_scope.
 Implicit Types m n x y : nat.
 
 Definition zerop n : {n = 0} + {0 < n}.
+Proof.
   destruct n; auto with arith.
 Defined.
 
-Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}.
-  induction n; simple destruct m; auto with arith.
-  intros m0; elim (IHn m0); auto with arith.
-  induction 1; auto with arith.
+Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}.
+Proof.
+  induction n; destruct m; auto with arith.
+  destruct (IHn m) as [H|H]; auto with arith.
+  destruct H; auto with arith.
 Defined.
 
-Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}.
-  exact lt_eq_lt_dec.
+Definition gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}.
+Proof.
+  intros; apply lt_eq_lt_dec; assumption.
 Defined.
 
-Definition le_lt_dec n m : {n <= m} + {m < n}.
+Definition le_lt_dec : forall n m, {n <= m} + {m < n}.
+Proof.
   induction n.
   auto with arith.
   destruct m.
@@ -40,43 +44,68 @@ Definition le_lt_dec n m : {n <= m} + {m < n}.
 Defined.
 
 Definition le_le_S_dec n m : {n <= m} + {S m <= n}.
-  exact le_lt_dec.
+Proof.
+  intros; exact (le_lt_dec n m).
 Defined.
 
 Definition le_ge_dec n m : {n <= m} + {n >= m}.
+Proof.
   intros; elim (le_lt_dec n m); auto with arith.
 Defined.
 
 Definition le_gt_dec n m : {n <= m} + {n > m}.
-  exact le_lt_dec.
+Proof.
+  intros; exact (le_lt_dec n m).
 Defined.
 
 Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}.
-  intros; elim (lt_eq_lt_dec n m); auto with arith.
+Proof.
+  intros; destruct (lt_eq_lt_dec n m); auto with arith.
   intros; absurd (m < n); auto with arith.
 Defined.
 
+Theorem le_dec : forall n m, {n <= m} + {~ n <= m}.
+Proof.
+  intros n m. destruct (le_gt_dec n m).
+   auto with arith.
+   right. apply gt_not_le. assumption.
+Defined.
+
+Theorem lt_dec : forall n m, {n < m} + {~ n < m}.
+Proof.
+  intros; apply le_dec.
+Defined.
+
+Theorem gt_dec : forall n m, {n > m} + {~ n > m}.
+Proof.
+  intros; apply lt_dec.
+Defined.
+
+Theorem ge_dec : forall n m, {n >= m} + {~ n >= m}.
+Proof.
+  intros; apply le_dec.
+Defined.
+
 (** Proofs of decidability *)
 
 Theorem dec_le : forall n m, decidable (n <= m).
 Proof.
-  intros x y; unfold decidable in |- *; elim (le_gt_dec x y);
-    [ auto with arith | intro; right; apply gt_not_le; assumption ].
+  intros n m; destruct (le_dec n m); unfold decidable; auto.
 Qed.
 
 Theorem dec_lt : forall n m, decidable (n < m).
 Proof.
-  intros x y; unfold lt in |- *; apply dec_le.
+  intros; apply dec_le.
 Qed.
 
 Theorem dec_gt : forall n m, decidable (n > m).
 Proof.
-  intros x y; unfold gt in |- *; apply dec_lt.
+  intros; apply dec_lt.
 Qed.
 
 Theorem dec_ge : forall n m, decidable (n >= m).
 Proof.
-  intros x y; unfold ge in |- *; apply dec_le.
+  intros; apply dec_le.
 Qed.
 
 Theorem not_eq : forall n m, n <> m -> n < m \/ m < n.
@@ -107,86 +136,111 @@ Qed.
 
 Theorem not_lt : forall n m, ~ n < m -> n >= m.
 Proof.
-  intros x y H; exact (not_gt y x H). 
+  intros x y H; exact (not_gt y x H).
 Qed.
 
 
 (** A ternary comparison function in the spirit of [Zcompare]. *)
 
-Definition nat_compare (n m:nat) :=
-  match lt_eq_lt_dec n m with 
-    | inleft (left _) => Lt
-    | inleft (right _) => Eq
-    | inright _ => Gt
+Fixpoint nat_compare n m :=
+  match n, m with
+   | O, O => Eq
+   | O, S _ => Lt
+   | S _, O => Gt
+   | S n', S m' => nat_compare n' m'
   end.
 
 Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m.
 Proof.
-  unfold nat_compare; intros.
-  simpl; destruct (lt_eq_lt_dec n m) as [[H|H]|H]; simpl; auto.
+ reflexivity.
+Qed.
+
+Lemma nat_compare_eq_iff : forall n m, nat_compare n m = Eq <-> n = m.
+Proof.
+  induction n; destruct m; simpl; split; auto; try discriminate;
+   destruct (IHn m); auto.
 Qed.
 
 Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m.
 Proof.
-  induction n; destruct m; simpl; auto.
-  unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
-    auto; intros; try discriminate.
-  unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
-    auto; intros; try discriminate.
-  rewrite nat_compare_S; auto.
+  intros; apply -> nat_compare_eq_iff; auto.
 Qed.
 
 Lemma nat_compare_lt : forall n m, n<m <-> nat_compare n m = Lt.
 Proof.
-  induction n; destruct m; simpl.
-  unfold nat_compare; simpl; intuition; [inversion H | discriminate H].
-  split; auto with arith.
-  split; [inversion 1 |].
-  unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
-    auto; intros; try discriminate.
-  rewrite nat_compare_S.
-  generalize (IHn m); clear IHn; intuition.
+  induction n; destruct m; simpl; split; auto with arith;
+   try solve [inversion 1].
+  destruct (IHn m); auto with arith.
+  destruct (IHn m); auto with arith.
 Qed.
 
 Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt.
 Proof.
-  induction n; destruct m; simpl.
-  unfold nat_compare; simpl; intuition; [inversion H | discriminate H].
-  split; [inversion 1 |].
-  unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
-    auto; intros; try discriminate.
-  split; auto with arith.
-  rewrite nat_compare_S.
-  generalize (IHn m); clear IHn; intuition.
+  induction n; destruct m; simpl; split; auto with arith;
+   try solve [inversion 1].
+  destruct (IHn m); auto with arith.
+  destruct (IHn m); auto with arith.
 Qed.
 
 Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt.
 Proof.
   split.
-  intros.
-  intro.
-  destruct (nat_compare_gt n m).
-  generalize (le_lt_trans _ _ _ H (H2 H0)).
-  exact (lt_irrefl n).
-  intros.
-  apply not_gt.
-  contradict H.
-  destruct (nat_compare_gt n m); auto.
-Qed.  
+  intros LE; contradict LE.
+   apply lt_not_le. apply <- nat_compare_gt; auto.
+  intros NGT. apply not_lt. contradict NGT.
+   apply -> nat_compare_gt; auto.
+Qed.
 
 Lemma nat_compare_ge : forall n m, n>=m <-> nat_compare n m <> Lt.
 Proof.
   split.
-  intros.
-  intro.
-  destruct (nat_compare_lt n m).
-  generalize (le_lt_trans _ _ _ H (H2 H0)).
-  exact (lt_irrefl m).
-  intros.
-  apply not_lt.
-  contradict H.
-  destruct (nat_compare_lt n m); auto.
-Qed.  
+  intros GE; contradict GE.
+   apply lt_not_le. apply <- nat_compare_lt; auto.
+  intros NLT. apply not_lt. contradict NLT.
+   apply -> nat_compare_lt; auto.
+Qed.
+
+Lemma nat_compare_spec : forall x y, CompSpec eq lt x y (nat_compare x y).
+Proof.
+ intros.
+ destruct (nat_compare x y) as [ ]_eqn; constructor.
+ apply nat_compare_eq; auto.
+ apply <- nat_compare_lt; auto.
+ apply <- nat_compare_gt; auto.
+Qed.
+
+
+(** Some projections of the above equivalences. *)
+
+Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n<m.
+Proof.
+  intros; apply <- nat_compare_lt; auto.
+Qed.
+
+Lemma nat_compare_Gt_gt : forall n m, nat_compare n m = Gt -> n>m.
+Proof.
+  intros; apply <- nat_compare_gt; auto.
+Qed.
+
+(** A previous definition of [nat_compare] in terms of [lt_eq_lt_dec].
+    The new version avoids the creation of proof parts. *)
+
+Definition nat_compare_alt (n m:nat) :=
+  match lt_eq_lt_dec n m with
+    | inleft (left _) => Lt
+    | inleft (right _) => Eq
+    | inright _ => Gt
+  end.
+
+Lemma nat_compare_equiv: forall n m,
+ nat_compare n m = nat_compare_alt n m.
+Proof.
+  intros; unfold nat_compare_alt; destruct lt_eq_lt_dec as [[LT|EQ]|GT].
+  apply -> nat_compare_lt; auto.
+  apply <- nat_compare_eq_iff; auto.
+  apply -> nat_compare_gt; auto.
+Qed.
+
 
 (** A boolean version of [le] over [nat]. *)
 
@@ -200,48 +254,48 @@ Fixpoint leb (m:nat) : nat -> bool :=
                    end
   end.
 
-Lemma leb_correct : forall m n:nat, m <= n -> leb m n = true.
+Lemma leb_correct : forall m n, m <= n -> leb m n = true.
 Proof.
   induction m as [| m IHm]. trivial.
   destruct n. intro H. elim (le_Sn_O _ H).
   intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
 Qed.
 
-Lemma leb_complete : forall m n:nat, leb m n = true -> m <= n.
+Lemma leb_complete : forall m n, leb m n = true -> m <= n.
 Proof.
   induction m. trivial with arith.
   destruct n. intro H. discriminate H.
   auto with arith.
 Qed.
 
-Lemma leb_correct_conv : forall m n:nat, m < n -> leb n m = false.
+Lemma leb_iff : forall m n, leb m n = true <-> m <= n.
 Proof.
-  intros. 
+  split; auto using leb_correct, leb_complete.
+Qed.
+
+Lemma leb_correct_conv : forall m n, m < n -> leb n m = false.
+Proof.
+  intros.
   generalize (leb_complete n m).
   destruct (leb n m); auto.
-  intros.
-  elim (lt_irrefl _ (lt_le_trans _ _ _ H (H0 (refl_equal true)))).
+  intros; elim (lt_not_le m n); auto.
 Qed.
 
-Lemma leb_complete_conv : forall m n:nat, leb n m = false -> m < n.
+Lemma leb_complete_conv : forall m n, leb n m = false -> m < n.
 Proof.
-  intros. elim (le_or_lt n m). intro. conditional trivial rewrite leb_correct in H. discriminate H.
-  trivial.
+  intros m n EQ. apply not_le.
+  intro LE. apply leb_correct in LE. rewrite LE in EQ; discriminate.
+Qed.
+
+Lemma leb_iff_conv : forall m n, leb n m = false <-> m < n.
+Proof.
+  split; auto using leb_complete_conv, leb_correct_conv.
 Qed.
 
 Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt.
 Proof.
- induction n; destruct m; simpl.
- unfold nat_compare; simpl.
- intuition; discriminate.
- split; auto with arith.
- unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
-  intuition; try discriminate.
- inversion H.
- split; try (intros; discriminate).
- unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
-  intuition; try discriminate.
- inversion H.
- rewrite nat_compare_S; auto.
-Qed. 
+ split; intros.
+ apply -> nat_compare_le. auto using leb_complete.
+ apply leb_correct. apply <- nat_compare_le; auto.
+Qed.
 
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index 7cab976f..999a6454 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Div2.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Lt.
 Require Import Plus.
@@ -36,7 +36,7 @@ Proof.
   intros P H0 H1 Hn.
   cut (forall n, P n /\ P (S n)).
   intros H'n n. elim (H'n n). auto with arith.
-  
+
   induction n. auto with arith.
   intros. elim IHn; auto with arith.
 Qed.
@@ -150,7 +150,7 @@ Proof fun n => proj2 (proj2 (even_odd_double n)).
 
 Hint Resolve even_double double_even odd_double double_odd: arith.
 
-(** Application: 
+(** Application:
     - if [n] is even then there is a [p] such that [n = 2p]
     - if [n] is odd  then there is a [p] such that [n = 2p+1]
 
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index a9244455..312b76e9 100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: EqNat.v 9966 2007-07-10 23:54:53Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** Equality on natural numbers *)
 
@@ -16,7 +16,7 @@ Implicit Types m n x y : nat.
 
 (** * Propositional equality  *)
 
-Fixpoint eq_nat n m {struct n} : Prop :=
+Fixpoint eq_nat n m : Prop :=
   match n, m with
     | O, O => True
     | O, S _ => False
@@ -68,7 +68,7 @@ Defined.
 
 (** * Boolean equality on [nat] *)
 
-Fixpoint beq_nat n m {struct n} : bool :=
+Fixpoint beq_nat n m : bool :=
   match n, m with
     | O, O => true
     | O, S _ => false
@@ -99,3 +99,18 @@ Lemma beq_nat_false : forall x y, beq_nat x y = false -> x<>y.
 Proof.
  induction x; destruct y; simpl; auto; intros; discriminate.
 Qed.
+
+Lemma beq_nat_true_iff : forall x y, beq_nat x y = true <-> x=y.
+Proof.
+ split. apply beq_nat_true.
+ intros; subst; symmetry; apply beq_nat_refl.
+Qed.
+
+Lemma beq_nat_false_iff : forall x y, beq_nat x y = false <-> x<>y.
+Proof.
+ intros x y.
+ split. apply beq_nat_false.
+ generalize (beq_nat_true_iff x y).
+ destruct beq_nat; auto.
+ intros IFF NEQ. elim NEQ. apply IFF; auto.
+Qed.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
index 3d6f1af5..f50dcc84 100644
--- a/theories/Arith/Euclid.v
+++ b/theories/Arith/Euclid.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Euclid.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Mult.
 Require Import Compare_dec.
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
index 59209370..eaa1bb2d 100644
--- a/theories/Arith/Even.v
+++ b/theories/Arith/Even.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Even.v 11512 2008-10-27 12:28:36Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Here we define the predicates [even] and [odd] by mutual induction
     and we prove the decidability and the exclusion of those predicates.
@@ -17,7 +17,7 @@ Open Local Scope nat_scope.
 Implicit Types m n : nat.
 
 
-(** * Definition of [even] and [odd], and basic facts *) 
+(** * Definition of [even] and [odd], and basic facts *)
 
 Inductive even : nat -> Prop :=
   | even_O : even 0
@@ -52,9 +52,9 @@ Qed.
 
 (** * Facts about [even] & [odd] wrt. [plus] *)
 
-Lemma even_plus_split : forall n m, 
+Lemma even_plus_split : forall n m,
   (even (n + m) -> even n /\ even m \/ odd n /\ odd m)
-with odd_plus_split : forall n m, 
+with odd_plus_split : forall n m,
   odd (n + m) -> odd n /\ even m \/ even n /\ odd m.
 Proof.
 intros. clear even_plus_split. destruct n; simpl in *.
@@ -95,7 +95,7 @@ Proof.
   intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto.
   intro; destruct (not_even_and_odd n); auto.
 Qed.
- 
+
 Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n.
 Proof.
   intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto.
@@ -120,13 +120,13 @@ Proof.
   intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
   intro; destruct (not_even_and_odd m); auto.
 Qed.
- 
+
 Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m.
 Proof.
   intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
   intro; destruct (not_even_and_odd n); auto.
 Qed.
- 
+
 Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n.
 Proof.
   intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
@@ -203,7 +203,7 @@ Proof.
   intros n m; case (even_mult_aux n m); auto.
   intros H H0; case H0; auto.
 Qed.
- 
+
 Lemma even_mult_r : forall n m, even m -> even (n * m).
 Proof.
   intros n m; case (even_mult_aux n m); auto.
@@ -219,7 +219,7 @@ Proof.
   intros H'3; elim H'3; auto.
   intros H; case (not_even_and_odd n); auto.
 Qed.
- 
+
 Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n.
 Proof.
   intros n m H' H'0.
@@ -228,13 +228,13 @@ Proof.
   intros H'3; elim H'3; auto.
   intros H; case (not_even_and_odd m); auto.
 Qed.
- 
+
 Lemma odd_mult : forall n m, odd n -> odd m -> odd (n * m).
 Proof.
   intros n m; case (even_mult_aux n m); intros H; case H; auto.
 Qed.
 Hint Resolve even_mult_l even_mult_r odd_mult: arith.
- 
+
 Lemma odd_mult_inv_l : forall n m, odd (n * m) -> odd n.
 Proof.
   intros n m H'.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
index 5e2f491a..8c531562 100644
--- a/theories/Arith/Factorial.v
+++ b/theories/Arith/Factorial.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Factorial.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Plus.
 Require Import Mult.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index 5b1ee1b2..70169f52 100644
--- a/theories/Arith/Gt.v
+++ b/theories/Arith/Gt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Gt.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as:
 <<
@@ -135,7 +135,7 @@ Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
 
 (** * Comparison to 0 *)
 
-Theorem gt_O_eq : forall n, n > 0 \/ 0 = n.
+Theorem gt_0_eq : forall n, n > 0 \/ 0 = n.
 Proof.
   intro n; apply gt_S; auto with arith.
 Qed.
@@ -151,4 +151,8 @@ Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m.
 Proof.
   auto with arith.
 Qed.
-Hint Resolve plus_gt_compat_l: arith v62.
\ No newline at end of file
+Hint Resolve plus_gt_compat_l: arith v62.
+
+(* begin hide *)
+Notation gt_O_eq := gt_0_eq (only parsing).
+(* end hide *)
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index e8b9e6be..d85178de 100644
--- a/theories/Arith/Le.v
+++ b/theories/Arith/Le.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Le.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (** Order on natural numbers. [le] is defined in [Init/Peano.v] as:
 <<
@@ -41,25 +41,25 @@ Hint Resolve le_trans: arith v62.
 
 (** Comparison to 0 *)
 
-Theorem le_O_n : forall n, 0 <= n.
+Theorem le_0_n : forall n, 0 <= n.
 Proof.
   induction n; auto.
 Qed.
 
-Theorem le_Sn_O : forall n, ~ S n <= 0.
+Theorem le_Sn_0 : forall n, ~ S n <= 0.
 Proof.
   red in |- *; intros n H.
   change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith.
 Qed.
 
-Hint Resolve le_O_n le_Sn_O: arith v62.
+Hint Resolve le_0_n le_Sn_0: arith v62.
 
-Theorem le_n_O_eq : forall n, n <= 0 -> 0 = n.
+Theorem le_n_0_eq : forall n, n <= 0 -> 0 = n.
 Proof.
   induction n; auto with arith.
-  intro; contradiction le_Sn_O with n.
+  intro; contradiction le_Sn_0 with n.
 Qed.
-Hint Immediate le_n_O_eq: arith v62.
+Hint Immediate le_n_0_eq: arith v62.
 
 
 (** [le] and successor *)
@@ -135,3 +135,9 @@ Proof.
   intros m Le.
   elim Le; auto with arith.
 Qed.
+
+(* begin hide *)
+Notation le_O_n := le_0_n (only parsing).
+Notation le_Sn_O := le_Sn_0 (only parsing).
+Notation le_n_O_eq := le_n_0_eq (only parsing).
+(* end hide *)
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
index 94cf3793..af435e54 100644
--- a/theories/Arith/Lt.v
+++ b/theories/Arith/Lt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lt.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as:
 <<
@@ -26,7 +26,7 @@ Theorem lt_irrefl : forall n, ~ n < n.
 Proof le_Sn_n.
 Hint Resolve lt_irrefl: arith v62.
 
-(** * Relationship between [le] and [lt] *) 
+(** * Relationship between [le] and [lt] *)
 
 Theorem lt_le_S : forall n m, n < m -> S n <= m.
 Proof.
@@ -90,11 +90,11 @@ Proof.
 Qed.
 Hint Immediate lt_S_n: arith v62.
 
-Theorem lt_O_Sn : forall n, 0 < S n.
+Theorem lt_0_Sn : forall n, 0 < S n.
 Proof.
   auto with arith.
 Qed.
-Hint Resolve lt_O_Sn: arith v62.
+Hint Resolve lt_0_Sn: arith v62.
 
 Theorem lt_n_O : forall n, ~ n < 0.
 Proof le_Sn_O.
@@ -144,6 +144,13 @@ Proof.
   induction 1; auto with arith.
 Qed.
 
+Theorem le_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
+Proof.
+  split.
+  intros; apply le_lt_or_eq; auto.
+  destruct 1; subst; auto with arith.
+Qed.
+
 Theorem lt_le_weak : forall n m, n < m -> n <= m.
 Proof.
   auto with arith.
@@ -168,15 +175,21 @@ Qed.
 
 (** * Comparison to 0 *)
 
-Theorem neq_O_lt : forall n, 0 <> n -> 0 < n.
+Theorem neq_0_lt : forall n, 0 <> n -> 0 < n.
 Proof.
   induction n; auto with arith.
   intros; absurd (0 = 0); trivial with arith.
 Qed.
-Hint Immediate neq_O_lt: arith v62.
+Hint Immediate neq_0_lt: arith v62.
 
-Theorem lt_O_neq : forall n, 0 < n -> 0 <> n.
+Theorem lt_0_neq : forall n, 0 < n -> 0 <> n.
 Proof.
   induction 1; auto with arith.
 Qed.
-Hint Immediate lt_O_neq: arith v62.
\ No newline at end of file
+Hint Immediate lt_0_neq: arith v62.
+
+(* begin hide *)
+Notation lt_O_Sn := lt_0_Sn (only parsing).
+Notation neq_O_lt := neq_0_lt (only parsing).
+Notation lt_O_neq := lt_0_neq (only parsing).
+(* end hide *)
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
index 5de2298d..3d7fe9fc 100644
--- a/theories/Arith/Max.v
+++ b/theories/Arith/Max.v
@@ -6,81 +6,39 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Max.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
-
-Require Import Le.
-
-Open Local Scope nat_scope.
-
-Implicit Types m n : nat.
-
-(** * maximum of two natural numbers *)
-
-Fixpoint max n m {struct n} : nat :=
-  match n, m with
-    | O, _ => m
-    | S n', O => n
-    | S n', S m' => S (max n' m')
-  end.
-
-(** * Simplifications of [max] *)
-
-Lemma max_SS : forall n m, S (max n m) = max (S n) (S m).
-Proof.
-  auto with arith.
-Qed.
-
-Theorem max_assoc : forall m n p : nat, max m (max n p) = max (max m n) p.
-Proof.
-  induction m; destruct n; destruct p; trivial.
-  simpl.
-  auto using IHm.
-Qed.
-
-Lemma max_comm : forall n m, max n m = max m n.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-Qed.
-
-(** * [max] and [le] *)
-
-Lemma max_l : forall n m, m <= n -> max n m = n.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-Qed.
-
-Lemma max_r : forall n m, n <= m -> max n m = m.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-Qed.
-
-Lemma le_max_l : forall n m, n <= max n m.
-Proof.
-  induction n; intros; simpl in |- *; auto with arith.
-  elim m; intros; simpl in |- *; auto with arith.
-Qed.
-
-Lemma le_max_r : forall n m, m <= max n m.
-Proof.
-  induction n; simpl in |- *; auto with arith.
-  induction m; simpl in |- *; auto with arith.
-Qed.
-Hint Resolve max_r max_l le_max_l le_max_r: arith v62.
-
-
-(** * [max n m] is equal to [n] or [m] *)
-
-Lemma max_dec : forall n m, {max n m = n} + {max n m = m}.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-  elim (IHn m); intro H; elim H; auto.
-Defined.
-
-Lemma max_case : forall n m (P:nat -> Type), P n -> P m -> P (max n m).
-Proof.
-  induction n; simpl in |- *; auto with arith.
-  induction m; intros; simpl in |- *; auto with arith.
-  pattern (max n m) in |- *; apply IHn; auto with arith.
-Defined.
-
+(*i $Id$ i*)
+
+(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *)
+
+Require Export MinMax.
+
+Local Open Scope nat_scope.
+Implicit Types m n p : nat.
+
+Notation max := MinMax.max (only parsing).
+
+Definition max_0_l := max_0_l.
+Definition max_0_r := max_0_r.
+Definition succ_max_distr := succ_max_distr.
+Definition plus_max_distr_l := plus_max_distr_l.
+Definition plus_max_distr_r := plus_max_distr_r.
+Definition max_case_strong := max_case_strong.
+Definition max_spec := max_spec.
+Definition max_dec := max_dec.
+Definition max_case := max_case.
+Definition max_idempotent := max_id.
+Definition max_assoc := max_assoc.
+Definition max_comm := max_comm.
+Definition max_l := max_l.
+Definition max_r := max_r.
+Definition le_max_l := le_max_l.
+Definition le_max_r := le_max_r.
+Definition max_lub_l := max_lub_l.
+Definition max_lub_r := max_lub_r.
+Definition max_lub := max_lub.
+
+(* begin hide *)
+(* Compatibility *)
 Notation max_case2 := max_case (only parsing).
+Notation max_SS := succ_max_distr (only parsing).
+(* end hide *)
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
index aa009963..c52fc0dd 100644
--- a/theories/Arith/Min.v
+++ b/theories/Arith/Min.v
@@ -6,91 +6,39 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Min.v 9660 2007-02-19 11:36:30Z notin $ i*)
+(*i $Id$ i*)
 
-Require Import Le.
+(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *)
 
-Open Local Scope nat_scope.
-
-Implicit Types m n : nat.
-
-(** * minimum of two natural numbers *)
-
-Fixpoint min n m {struct n} : nat :=
-  match n, m with
-    | O, _ => 0
-    | S n', O => 0
-    | S n', S m' => S (min n' m')
-  end.
-
-(** * Simplifications of [min] *)
-
-Lemma min_0_l : forall n : nat, min 0 n = 0.
-Proof.
-  trivial. 
-Qed.
-
-Lemma min_0_r : forall n : nat, min n 0 = 0.
-Proof.
-  destruct n; trivial.
-Qed.
-
-Lemma min_SS : forall n m, S (min n m) = min (S n) (S m).
-Proof.
-  auto with arith.
-Qed.
-
-Lemma min_assoc : forall m n p : nat, min m (min n p) = min (min m n) p.
-Proof.
-  induction m; destruct n; destruct p; trivial.
-  simpl.
-  auto using (IHm n p).
-Qed.
-
-Lemma min_comm : forall n m, min n m = min m n.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-Qed.
-
-(** * [min] and [le] *)
-
-Lemma min_l : forall n m, n <= m -> min n m = n.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-Qed.
-
-Lemma min_r : forall n m, m <= n -> min n m = m.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-Qed.
-
-Lemma le_min_l : forall n m, min n m <= n.
-Proof.
-  induction n; intros; simpl in |- *; auto with arith.
-  elim m; intros; simpl in |- *; auto with arith.
-Qed.
-
-Lemma le_min_r : forall n m, min n m <= m.
-Proof.
-  induction n; simpl in |- *; auto with arith.
-  induction m; simpl in |- *; auto with arith.
-Qed.
-Hint Resolve min_l min_r le_min_l le_min_r: arith v62.
-
-(** * [min n m] is equal to [n] or [m] *)
-
-Lemma min_dec : forall n m, {min n m = n} + {min n m = m}.
-Proof.
-  induction n; induction m; simpl in |- *; auto with arith.
-  elim (IHn m); intro H; elim H; auto.
-Qed.
-
-Lemma min_case : forall n m (P:nat -> Type), P n -> P m -> P (min n m).
-Proof.
-  induction n; simpl in |- *; auto with arith.
-  induction m; intros; simpl in |- *; auto with arith.
-  pattern (min n m) in |- *; apply IHn; auto with arith.
-Qed.
+Require Export MinMax.
 
+Open Local Scope nat_scope.
+Implicit Types m n p : nat.
+
+Notation min := MinMax.min (only parsing).
+
+Definition min_0_l := min_0_l.
+Definition min_0_r := min_0_r.
+Definition succ_min_distr := succ_min_distr.
+Definition plus_min_distr_l := plus_min_distr_l.
+Definition plus_min_distr_r := plus_min_distr_r.
+Definition min_case_strong := min_case_strong.
+Definition min_spec := min_spec.
+Definition min_dec := min_dec.
+Definition min_case := min_case.
+Definition min_idempotent := min_id.
+Definition min_assoc := min_assoc.
+Definition min_comm := min_comm.
+Definition min_l := min_l.
+Definition min_r := min_r.
+Definition le_min_l := le_min_l.
+Definition le_min_r := le_min_r.
+Definition min_glb_l := min_glb_l.
+Definition min_glb_r := min_glb_r.
+Definition min_glb := min_glb.
+
+(* begin hide *)
+(* Compatibility *)
 Notation min_case2 := min_case (only parsing).
-
+Notation min_SS := succ_min_distr (only parsing).
+(* end hide *)
\ No newline at end of file
diff --git a/theories/Arith/MinMax.v b/theories/Arith/MinMax.v
new file mode 100644
index 00000000..6e86a88c
--- /dev/null
+++ b/theories/Arith/MinMax.v
@@ -0,0 +1,113 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Orders NatOrderedType GenericMinMax.
+
+(** * Maximum and Minimum of two natural numbers *)
+
+Fixpoint max n m : nat :=
+  match n, m with
+    | O, _ => m
+    | S n', O => n
+    | S n', S m' => S (max n' m')
+  end.
+
+Fixpoint min n m : nat :=
+  match n, m with
+    | O, _ => 0
+    | S n', O => 0
+    | S n', S m' => S (min n' m')
+  end.
+
+(** These functions implement indeed a maximum and a minimum *)
+
+Lemma max_l : forall x y, y<=x -> max x y = x.
+Proof.
+ induction x; destruct y; simpl; auto with arith.
+Qed.
+
+Lemma max_r : forall x y, x<=y -> max x y = y.
+Proof.
+ induction x; destruct y; simpl; auto with arith.
+Qed.
+
+Lemma min_l : forall x y, x<=y -> min x y = x.
+Proof.
+ induction x; destruct y; simpl; auto with arith.
+Qed.
+
+Lemma min_r : forall x y, y<=x -> min x y = y.
+Proof.
+ induction x; destruct y; simpl; auto with arith.
+Qed.
+
+
+Module NatHasMinMax <: HasMinMax Nat_as_OT.
+ Definition max := max.
+ Definition min := min.
+ Definition max_l := max_l.
+ Definition max_r := max_r.
+ Definition min_l := min_l.
+ Definition min_r := min_r.
+End NatHasMinMax.
+
+(** We obtain hence all the generic properties of [max] and [min],
+    see file [GenericMinMax] or use SearchAbout. *)
+
+Module Export MMP := UsualMinMaxProperties Nat_as_OT NatHasMinMax.
+
+
+(** * Properties specific to the [nat] domain *)
+
+(** Simplifications *)
+
+Lemma max_0_l : forall n, max 0 n = n.
+Proof. reflexivity. Qed.
+
+Lemma max_0_r : forall n, max n 0 = n.
+Proof. destruct n; auto. Qed.
+
+Lemma min_0_l : forall n, min 0 n = 0.
+Proof. reflexivity. Qed.
+
+Lemma min_0_r : forall n, min n 0 = 0.
+Proof. destruct n; auto. Qed.
+
+(** Compatibilities (consequences of monotonicity) *)
+
+Lemma succ_max_distr : forall n m, S (max n m) = max (S n) (S m).
+Proof. auto. Qed.
+
+Lemma succ_min_distr : forall n m, S (min n m) = min (S n) (S m).
+Proof. auto. Qed.
+
+Lemma plus_max_distr_l : forall n m p, max (p + n) (p + m) = p + max n m.
+Proof.
+intros. apply max_monotone. repeat red; auto with arith.
+Qed.
+
+Lemma plus_max_distr_r : forall n m p, max (n + p) (m + p) = max n m + p.
+Proof.
+intros. apply max_monotone with (f:=fun x => x + p).
+repeat red; auto with arith.
+Qed.
+
+Lemma plus_min_distr_l : forall n m p, min (p + n) (p + m) = p + min n m.
+Proof.
+intros. apply min_monotone. repeat red; auto with arith.
+Qed.
+
+Lemma plus_min_distr_r : forall n m p, min (n + p) (m + p) = min n m + p.
+Proof.
+intros. apply min_monotone with (f:=fun x => x + p).
+repeat red; auto with arith.
+Qed.
+
+Hint Resolve
+ max_l max_r le_max_l le_max_r
+ min_l min_r le_min_l le_min_r : arith v62.
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
index b961886d..cd6c0a29 100644
--- a/theories/Arith/Minus.v
+++ b/theories/Arith/Minus.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Minus.v 11072 2008-06-08 16:13:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as:
 <<
-Fixpoint minus (n m:nat) {struct n} : nat :=
+Fixpoint minus (n m:nat) : nat :=
   match n, m with
   | O, _ => n
   | S k, O => S k
@@ -120,10 +120,10 @@ Proof.
 
     intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); trivial.
       intros q; destruct q; auto with arith.
-        simpl. 
+        simpl.
         apply le_trans with (m := p - 0); [apply HI | rewrite <- minus_n_O];
           auto with arith.
-        
+
       intros q r Hqr _. simpl. auto using HI.
 Qed.
 
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index a43579f9..8346cae3 100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Mult.v 11015 2008-05-28 20:06:42Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Plus.
 Require Export Minus.
@@ -43,7 +43,7 @@ Hint Resolve mult_1_l: arith v62.
 
 Lemma mult_1_r : forall n, n * 1 = n.
 Proof.
-  induction n; [ trivial | 
+  induction n; [ trivial |
     simpl; rewrite IHn; reflexivity].
 Qed.
 Hint Resolve mult_1_r: arith v62.
@@ -52,9 +52,9 @@ Hint Resolve mult_1_r: arith v62.
 
 Lemma mult_comm : forall n m, n * m = m * n.
 Proof.
-intros; elim n; intros; simpl in |- *; auto with arith.
-elim mult_n_Sm.
-elim H; apply plus_comm.
+intros; induction n; simpl; auto with arith.
+rewrite <- mult_n_Sm.
+rewrite IHn; apply plus_comm.
 Qed.
 Hint Resolve mult_comm: arith v62.
 
@@ -62,29 +62,28 @@ Hint Resolve mult_comm: arith v62.
 
 Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p.
 Proof.
-  intros; elim n; simpl in |- *; intros; auto with arith.
-  elim plus_assoc; elim H; auto with arith.
+  intros; induction n; simpl; auto with arith.
+  rewrite <- plus_assoc, IHn; auto with arith.
 Qed.
 Hint Resolve mult_plus_distr_r: arith v62.
 
 Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
 Proof.
   induction n. trivial.
-  intros. simpl in |- *. rewrite (IHn m p). apply sym_eq. apply plus_permute_2_in_4.
+  intros. simpl in |- *. rewrite IHn. symmetry. apply plus_permute_2_in_4.
 Qed.
 
 Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p.
 Proof.
-  intros; pattern n, m in |- *; apply nat_double_ind; simpl in |- *; intros;
-    auto with arith.
-  elim minus_plus_simpl_l_reverse; auto with arith.
+  intros; induction n m using nat_double_ind; simpl; auto with arith.
+  rewrite <- minus_plus_simpl_l_reverse; auto with arith.
 Qed.
 Hint Resolve mult_minus_distr_r: arith v62.
 
 Lemma mult_minus_distr_l : forall n m p, n * (m - p) = n * m - n * p.
 Proof.
-  intros n m p. rewrite mult_comm. rewrite mult_minus_distr_r. 
-  rewrite (mult_comm m n); rewrite (mult_comm p n); reflexivity.
+  intros n m p.
+  rewrite mult_comm, mult_minus_distr_r, (mult_comm m n), (mult_comm p n); reflexivity.
 Qed.
 Hint Resolve mult_minus_distr_l: arith v62.
 
@@ -92,9 +91,9 @@ Hint Resolve mult_minus_distr_l: arith v62.
 
 Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
 Proof.
-  intros; elim n; intros; simpl in |- *; auto with arith.
+  intros; induction n; simpl; auto with arith.
   rewrite mult_plus_distr_r.
-  elim H; auto with arith.
+  induction IHn; auto with arith.
 Qed.
 Hint Resolve mult_assoc_reverse: arith v62.
 
@@ -108,23 +107,18 @@ Hint Resolve mult_assoc: arith v62.
 
 Lemma mult_is_O : forall n m, n * m = 0 -> n = 0 \/ m = 0.
 Proof.
-  destruct n as [| n]. 
-    intros; left; trivial.
-
-    simpl; intros m H; right. 
-    assert (H':m = 0 /\ n * m = 0) by apply (plus_is_O _ _ H).
-    destruct H'; trivial.
+  destruct n as [| n]; simpl; intros m H.
+    left; trivial.
+    right; apply plus_is_O in H; destruct H; trivial.
 Qed.
 
 Lemma mult_is_one : forall n m, n * m = 1 -> n = 1 /\ m = 1.
 Proof.
-  destruct n as [|n].
-    simpl; intros m H; elim (O_S _ H).
-
-    simpl; intros m H.
-    destruct (plus_is_one _ _ H) as [[Hm Hnm] | [Hm Hnm]].
-      rewrite Hm in H; simpl in H; rewrite mult_0_r in H; elim (O_S _ H).
-      rewrite Hm in Hnm; rewrite mult_1_r in Hnm; auto. 
+  destruct n as [|n]; simpl; intros m H.
+    edestruct O_S; eauto.
+    destruct plus_is_one with (1:=H) as [[-> Hnm] | [-> Hnm]].
+      simpl in H; rewrite mult_0_r in H; elim (O_S _ H).
+      rewrite mult_1_r in Hnm; auto.
 Qed.
 
 (** ** Multiplication and successor *)
@@ -151,18 +145,16 @@ Hint Resolve mult_O_le: arith v62.
 
 Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m.
 Proof.
-  induction p as [| p IHp]. intros. simpl in |- *. apply le_n.
-  intros. simpl in |- *. apply plus_le_compat. assumption.
-  apply IHp. assumption.
+  induction p as [| p IHp]; intros; simpl in |- *.
+  apply le_n.
+  auto using plus_le_compat.
 Qed.
 Hint Resolve mult_le_compat_l: arith.
 
 
 Lemma mult_le_compat_r : forall n m p, n <= m -> n * p <= m * p.
 Proof.
-  intros m n p H.
-  rewrite mult_comm. rewrite (mult_comm n).
-  auto with arith.
+  intros m n p H; rewrite mult_comm, (mult_comm n); auto with arith.
 Qed.
 
 Lemma mult_le_compat :
@@ -184,8 +176,9 @@ Qed.
 
 Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p.
 Proof.
-  intro m; induction m. intros. simpl in |- *. rewrite <- plus_n_O. rewrite <- plus_n_O. assumption.
-  intros. exact (plus_lt_compat _ _ _ _ H (IHm _ _ H)).
+  induction n; intros; simpl in *.
+    rewrite <- 2! plus_n_O; assumption.
+    auto using plus_lt_compat.
 Qed.
 
 Hint Resolve mult_S_lt_compat_l: arith.
@@ -201,40 +194,36 @@ Qed.
 
 Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p.
 Proof.
-  intros m n p H. elim (le_or_lt n p). trivial.
-  intro H0. cut (S m * n < S m * n). intro. elim (lt_irrefl _ H1).
-  apply le_lt_trans with (m := S m * p). assumption.
-  apply mult_S_lt_compat_l. assumption.
+  intros m n p H; destruct (le_or_lt n p). trivial.
+  assert (H1:S m * n < S m * n).
+    apply le_lt_trans with (m := S m * p). assumption.
+    apply mult_S_lt_compat_l. assumption.
+  elim (lt_irrefl _ H1).
 Qed.
 
 (** * n|->2*n and n|->2n+1 have disjoint image *)
 
 Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q.
 Proof.
-  intros p; elim p; auto.
-  intros q; case q; simpl in |- *.
-  red in |- *; intros; discriminate.
-  intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *;
-    intros; discriminate.
-  intros p' H q; case q.
-  simpl in |- *; red in |- *; intros; discriminate.
-  intros q'; red in |- *; intros H0; case (H q').
-  replace (2 * q') with (2 * S q' - 2).
-  rewrite <- H0; simpl in |- *; auto.
-  repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto.
-  simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *;
-    auto.
-  case q'; simpl in |- *; auto.
+  induction p; destruct q.
+    discriminate.
+    simpl; rewrite plus_comm. discriminate.
+    discriminate.
+    intro H0; destruct (IHp q).
+    replace (2 * q) with (2 * S q - 2).
+      rewrite <- H0; simpl.
+      repeat rewrite (fun x y => plus_comm x (S y)); simpl;  auto.
+    simpl; rewrite (fun y => plus_comm q (S y)); destruct q; simpl; auto.
 Qed.
 
 
 (** * Tail-recursive mult *)
 
-(** [tail_mult] is an alternative definition for [mult] which is 
-    tail-recursive, whereas [mult] is not. This can be useful 
+(** [tail_mult] is an alternative definition for [mult] which is
+    tail-recursive, whereas [mult] is not. This can be useful
     when extracting programs. *)
 
-Fixpoint mult_acc (s:nat) m n {struct n} : nat :=
+Fixpoint mult_acc (s:nat) m n : nat :=
   match n with
     | O => s
     | S p => mult_acc (tail_plus m s) m p
@@ -244,7 +233,7 @@ Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n.
 Proof.
   induction n as [| p IHp]; simpl in |- *; auto.
   intros s m; rewrite <- plus_tail_plus; rewrite <- IHp.
-  rewrite <- plus_assoc_reverse; apply (f_equal2 (A1:=nat) (A2:=nat)); auto.
+  rewrite <- plus_assoc_reverse; apply f_equal2; auto.
   rewrite plus_comm; auto.
 Qed.
 
@@ -255,7 +244,7 @@ Proof.
   intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto.
 Qed.
 
-(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] 
+(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus]
     and [mult] and simplify *)
 
 Ltac tail_simpl :=
diff --git a/theories/Arith/NatOrderedType.v b/theories/Arith/NatOrderedType.v
new file mode 100644
index 00000000..df5b37e0
--- /dev/null
+++ b/theories/Arith/NatOrderedType.v
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Lt Peano_dec Compare_dec EqNat
+ Equalities Orders OrdersTac.
+
+
+(** * DecidableType structure for Peano numbers *)
+
+Module Nat_as_UBE <: UsualBoolEq.
+ Definition t := nat.
+ Definition eq := @eq nat.
+ Definition eqb := beq_nat.
+ Definition eqb_eq := beq_nat_true_iff.
+End Nat_as_UBE.
+
+Module Nat_as_DT <: UsualDecidableTypeFull := Make_UDTF Nat_as_UBE.
+
+(** Note that the last module fulfills by subtyping many other
+    interfaces, such as [DecidableType] or [EqualityType]. *)
+
+
+
+(** * OrderedType structure for Peano numbers *)
+
+Module Nat_as_OT <: OrderedTypeFull.
+ Include Nat_as_DT.
+ Definition lt := lt.
+ Definition le := le.
+ Definition compare := nat_compare.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof. split; [ exact lt_irrefl | exact lt_trans ]. Qed.
+
+ Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) lt.
+ Proof. repeat red; intros; subst; auto. Qed.
+
+ Definition le_lteq := le_lt_or_eq_iff.
+ Definition compare_spec := nat_compare_spec.
+
+End Nat_as_OT.
+
+(** Note that [Nat_as_OT] can also be seen as a [UsualOrderedType]
+   and a [OrderedType] (and also as a [DecidableType]). *)
+
+
+
+(** * An [order] tactic for Peano numbers *)
+
+Module NatOrder := OTF_to_OrderTac Nat_as_OT.
+Ltac nat_order := NatOrder.order.
+
+(** Note that [nat_order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
+
+Section Test.
+Let test : forall x y : nat, x<=y -> y<=x -> x=y.
+Proof. nat_order. Qed.
+End Test.
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
index cc970ae4..42335f98 100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Peano_dec.v 9698 2007-03-12 17:11:32Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import Decidable.
 
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
index 6d510447..9b7c6261 100644
--- a/theories/Arith/Plus.v
+++ b/theories/Arith/Plus.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Plus.v 9750 2007-04-06 00:58:14Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** Properties of addition. [add] is defined in [Init/Peano.v] as:
 <<
-Fixpoint plus (n m:nat) {struct n} : nat :=
+Fixpoint plus (n m:nat) : nat :=
   match n with
   | O => m
   | S p => S (p + m)
@@ -65,7 +65,7 @@ Qed.
 Hint Resolve plus_assoc: arith v62.
 
 Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p).
-Proof. 
+Proof.
   intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith.
 Qed.
 
@@ -179,7 +179,7 @@ Definition plus_is_one :
 Proof.
   intro m; destruct m as [| n]; auto.
   destruct n; auto.
-  intros. 
+  intros.
   simpl in H. discriminate H.
 Defined.
 
@@ -187,18 +187,18 @@ Defined.
 
 Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q).
 Proof.
-  intros m n p q. 
+  intros m n p q.
   rewrite <- (plus_assoc m n (p + q)). rewrite (plus_assoc n p q).
   rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc.
 Qed.
 
 (** * Tail-recursive plus *)
 
-(** [tail_plus] is an alternative definition for [plus] which is 
+(** [tail_plus] is an alternative definition for [plus] which is
     tail-recursive, whereas [plus] is not. This can be useful
     when extracting programs. *)
 
-Fixpoint tail_plus n m {struct n} : nat :=
+Fixpoint tail_plus n m : nat :=
   match n with
     | O => m
     | S n => tail_plus n (S m)
@@ -215,7 +215,7 @@ Lemma succ_plus_discr : forall n m, n <> S (plus m n).
 Proof.
   intros n m; induction n as [|n IHn].
   discriminate.
-  intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; 
+  intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm;
     reflexivity.
 Qed.
 
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
index 6ad640eb..5bc5d2a5 100644
--- a/theories/Arith/Wf_nat.v
+++ b/theories/Arith/Wf_nat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf_nat.v 11072 2008-06-08 16:13:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Well-founded relations and natural numbers *)
 
@@ -46,9 +46,9 @@ Defined.
 (** It is possible to directly prove the induction principle going
    back to primitive recursion on natural numbers ([induction_ltof1])
    or to use the previous lemmas to extract a program with a fixpoint
-   ([induction_ltof2]) 
+   ([induction_ltof2])
 
-the ML-like program for [induction_ltof1] is : 
+the ML-like program for [induction_ltof1] is :
 [[
 let induction_ltof1 f F a =
   let rec indrec n k =
@@ -58,7 +58,7 @@ let induction_ltof1 f F a =
   in indrec (f a + 1) a
 ]]
 
-the ML-like program for [induction_ltof2] is : 
+the ML-like program for [induction_ltof2] is :
 [[
    let induction_ltof2 F a = indrec a
    where rec indrec a = F a indrec;;
@@ -78,7 +78,7 @@ Proof.
   unfold ltof in |- *; intros b ltfafb.
   apply IHn.
   apply lt_le_trans with (f a); auto with arith.
-Defined. 
+Defined.
 
 Theorem induction_gtof1 :
   forall P:A -> Set,
@@ -262,7 +262,7 @@ Unset Implicit Arguments.
 
 (** [n]th iteration of the function [f] *)
 
-Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) {struct n} : A :=
+Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) : A :=
   match n with
     | O => x
     | S n' => f (iter_nat n' A f x)
@@ -271,8 +271,8 @@ Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) {struct n} : A :=
 Theorem iter_nat_plus :
   forall (n m:nat) (A:Type) (f:A -> A) (x:A),
     iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x).
-Proof.    
+Proof.
   simple induction n;
     [ simpl in |- *; auto with arith
-      | intros; simpl in |- *; apply f_equal with (f := f); apply H ].  
+      | intros; simpl in |- *; apply f_equal with (f := f); apply H ].
 Qed.
diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget
new file mode 100644
index 00000000..c3f29d21
--- /dev/null
+++ b/theories/Arith/vo.itarget
@@ -0,0 +1,23 @@
+Arith_base.vo
+Arith.vo
+Between.vo
+Bool_nat.vo
+Compare_dec.vo
+Compare.vo
+Div2.vo
+EqNat.vo
+Euclid.vo
+Even.vo
+Factorial.vo
+Gt.vo
+Le.vo
+Lt.vo
+Max.vo
+Minus.vo
+Min.vo
+Mult.vo
+Peano_dec.vo
+Plus.vo
+Wf_nat.vo
+NatOrderedType.vo
+MinMax.vo
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
index 47b9fc83..7f54efa3 100644
--- a/theories/Bool/Bool.v
+++ b/theories/Bool/Bool.v
@@ -6,12 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bool.v 10812 2008-04-17 16:42:37Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** The type [bool] is defined in the prelude as
     [Inductive bool : Set := true : bool | false : bool] *)
 
+(** Most of the lemmas in this file are trivial after breaking all booleans *)
+
+Ltac destr_bool :=
+ intros; destruct_all bool; simpl in *; trivial; try discriminate.
+
 (** Interpretation of booleans as propositions *)
+
 Definition Is_true (b:bool) :=
   match b with
     | true => True
@@ -33,42 +39,40 @@ Defined.
 
 Lemma diff_true_false : true <> false.
 Proof.
-  unfold not in |- *; intro contr; change (Is_true false) in |- *.
-  elim contr; simpl in |- *; trivial.
+  discriminate.
 Qed.
 Hint Resolve diff_true_false : bool v62.
 
 Lemma diff_false_true : false <> true.
-Proof. 
-  red in |- *; intros H; apply diff_true_false.
-  symmetry  in |- *.
-assumption.
+Proof.
+  discriminate.
 Qed.
 Hint Resolve diff_false_true : bool v62.
 Hint Extern 1 (false <> true) => exact diff_false_true.
 
 Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False.
 Proof.
-  intros b H; rewrite H; auto with bool.
+  destr_bool.
 Qed.
 
 Lemma not_true_is_false : forall b:bool, b <> true -> b = false.
 Proof.
-  destruct b.
-  intros.
-  red in H; elim H.
-  reflexivity.
-  intros abs.
-  reflexivity.
+  destr_bool; intuition.
 Qed.
 
 Lemma not_false_is_true : forall b:bool, b <> false -> b = true.
 Proof.
-  destruct b.
-  intros.
-  reflexivity.
-  intro H; red in H; elim H.
-  reflexivity.
+  destr_bool; intuition.
+Qed.
+
+Lemma not_true_iff_false : forall b, b <> true <-> b = false.
+Proof.
+  destr_bool; intuition.
+Qed.
+
+Lemma not_false_iff_true : forall b, b <> false <-> b = true.
+Proof.
+  destr_bool; intuition.
 Qed.
 
 (**********************)
@@ -82,6 +86,11 @@ Definition leb (b1 b2:bool) :=
   end.
 Hint Unfold leb: bool v62.
 
+Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true.
+Proof.
+  destr_bool; intuition.
+Qed.
+
 (* Infix "<=" := leb : bool_scope. *)
 
 (*************)
@@ -99,37 +108,33 @@ Definition eqb (b1 b2:bool) : bool :=
 Lemma eqb_subst :
   forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2.
 Proof.
-  unfold eqb in |- *.
-  intros P b1.
-  intros b2.
-  case b1.
-  case b2.
-  trivial with bool.
-  intros H.
-  inversion_clear H.
-  case b2.
-  intros H.
-  inversion_clear H.
-  trivial with bool.
+  destr_bool.
 Qed.
 
 Lemma eqb_reflx : forall b:bool, eqb b b = true.
 Proof.
-  intro b.
-  case b.
-  trivial with bool.
-  trivial with bool.
+  destr_bool.
 Qed.
 
 Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b.
 Proof.
-  destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity.
+  destr_bool.
+Qed.
+
+Lemma eqb_true_iff : forall a b:bool, eqb a b = true <-> a = b.
+Proof.
+  destr_bool; intuition.
+Qed.
+
+Lemma eqb_false_iff : forall a b:bool, eqb a b = false <-> a <> b.
+Proof.
+  destr_bool; intuition.
 Qed.
 
 (************************)
 (** * A synonym of [if] on [bool] *)
 (************************)
- 
+
 Definition ifb (b1 b2 b3:bool) : bool :=
   match b1 with
     | true => b2
@@ -144,12 +149,12 @@ Open Scope bool_scope.
 
 Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destr_bool.
 Qed.
 
 Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destr_bool.
 Qed.
 
 (********************************)
@@ -158,12 +163,12 @@ Qed.
 
 Lemma negb_involutive : forall b:bool, negb (negb b) = b.
 Proof.
-  destruct b; reflexivity.
+  destr_bool.
 Qed.
 
 Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b).
 Proof.
-  destruct b; reflexivity.
+  destr_bool.
 Qed.
 
 Notation negb_elim := negb_involutive (only parsing).
@@ -171,35 +176,39 @@ Notation negb_intro := negb_involutive_reverse (only parsing).
 
 Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'.
 Proof.
-  destruct b; destruct b'; intros; simpl in |- *; trivial with bool.
+  destr_bool.
 Qed.
 
 Lemma no_fixpoint_negb : forall b:bool, negb b <> b.
 Proof.
-  destruct b; simpl in |- *; intro; apply diff_true_false;
-    auto with bool.
+  destr_bool.
 Qed.
 
 Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false.
 Proof.
-  destruct b.
-  trivial with bool.
-  trivial with bool.
+  destr_bool.
 Qed.
- 
+
 Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false.
 Proof.
-  destruct b.
-  trivial with bool.
-  trivial with bool.
+  destr_bool.
 Qed.
 
-
 Lemma if_negb :
   forall (A:Type) (b:bool) (x y:A),
     (if negb b then x else y) = (if b then y else x).
 Proof.
-  destruct b; trivial.
+  destr_bool.
+Qed.
+
+Lemma negb_true_iff : forall b, negb b = true <-> b = false.
+Proof.
+  destr_bool; intuition.
+Qed.
+
+Lemma negb_false_iff : forall b, negb b = false <-> b = true.
+Proof.
+  destr_bool; intuition.
 Qed.
 
 
@@ -207,46 +216,60 @@ Qed.
 (** * Properties of [orb]     *)
 (********************************)
 
+Lemma orb_true_iff :
+  forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true.
+Proof.
+  destr_bool; intuition.
+Qed.
+
+Lemma orb_false_iff :
+  forall b1 b2, b1 || b2 = false <-> b1 = false /\ b2 = false.
+Proof.
+  destr_bool; intuition.
+Qed.
+
 Lemma orb_true_elim :
   forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}.
 Proof.
-  destruct b1; simpl in |- *; auto with bool.
+  destruct b1; simpl; auto.
 Defined.
 
 Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true.
 Proof.
-  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
-    auto with bool.
+ intros; apply orb_true_iff; trivial.
 Qed.
 
 Lemma orb_true_intro :
   forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true.
 Proof.
-  destruct b1; auto with bool.
-  destruct 1; intros.
-  elim diff_true_false; auto with bool.
-  rewrite H; trivial with bool.
+ intros; apply orb_true_iff; trivial.
 Qed.
 Hint Resolve orb_true_intro: bool v62.
 
 Lemma orb_false_intro :
   forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false.
 Proof.
-  intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool.
+ intros. subst. reflexivity.
 Qed.
 Hint Resolve orb_false_intro: bool v62.
 
+Lemma orb_false_elim :
+  forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
+Proof.
+  intros. apply orb_false_iff; trivial.
+Qed.
+
 (** [true] is a zero for [orb] *)
 
 Lemma orb_true_r : forall b:bool, b || true = true.
 Proof.
-  auto with bool.
+  destr_bool.
 Qed.
 Hint Resolve orb_true_r: bool v62.
 
 Lemma orb_true_l : forall b:bool, true || b = true.
 Proof.
-  trivial with bool.
+  reflexivity.
 Qed.
 
 Notation orb_b_true := orb_true_r (only parsing).
@@ -256,34 +279,24 @@ Notation orb_true_b := orb_true_l (only parsing).
 
 Lemma orb_false_r : forall b:bool, b || false = b.
 Proof.
-  destruct b; trivial with bool.
+  destr_bool.
 Qed.
 Hint Resolve orb_false_r: bool v62.
 
 Lemma orb_false_l : forall b:bool, false || b = b.
 Proof.
-  destruct b; trivial with bool.
+  destr_bool.
 Qed.
 Hint Resolve orb_false_l: bool v62.
 
 Notation orb_b_false := orb_false_r (only parsing).
 Notation orb_false_b := orb_false_l (only parsing).
 
-Lemma orb_false_elim :
-  forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
-Proof.
-  destruct b1.
-  intros; elim diff_true_false; auto with bool.
-  destruct b2.
-  intros; elim diff_true_false; auto with bool.
-  auto with bool.
-Qed.
-
 (** Complementation *)
 
 Lemma orb_negb_r : forall b:bool, b || negb b = true.
 Proof.
-  destruct b; reflexivity.
+  destr_bool.
 Qed.
 Hint Resolve orb_negb_r: bool v62.
 
@@ -293,14 +306,14 @@ Notation orb_neg_b := orb_negb_r (only parsing).
 
 Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1.
 Proof.
-  destruct b1; destruct b2; reflexivity.
+  destr_bool.
 Qed.
 
 (** Associativity *)
 
 Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3.
 Proof.
-  destruct b1; destruct b2; destruct b3; reflexivity.
+  destr_bool.
 Qed.
 Hint Resolve orb_comm orb_assoc: bool v62.
 
@@ -308,38 +321,44 @@ Hint Resolve orb_comm orb_assoc: bool v62.
 (** * Properties of [andb]     *)
 (*******************************)
 
-Lemma andb_true_iff : 
+Lemma andb_true_iff :
   forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true.
 Proof.
- destruct b1; destruct b2; intuition.
+  destr_bool; intuition.
+Qed.
+
+Lemma andb_false_iff :
+  forall b1 b2:bool, b1 && b2 = false <-> b1 = false \/ b2 = false.
+Proof.
+  destr_bool; intuition.
 Qed.
 
 Lemma andb_true_eq :
   forall a b:bool, true = a && b -> true = a /\ true = b.
 Proof.
-  destruct a; destruct b; auto.
+  destr_bool. auto.
 Defined.
 
 Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+  intros. apply andb_false_iff. auto.
 Qed.
 
 Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+  intros. apply andb_false_iff. auto.
 Qed.
 
 (** [false] is a zero for [andb] *)
 
 Lemma andb_false_r : forall b:bool, b && false = false.
 Proof.
-  destruct b; auto with bool.
+  destr_bool.
 Qed.
 
 Lemma andb_false_l : forall b:bool, false && b = false.
 Proof.
-  trivial with bool.
+  reflexivity.
 Qed.
 
 Notation andb_b_false := andb_false_r (only parsing).
@@ -349,12 +368,12 @@ Notation andb_false_b := andb_false_l (only parsing).
 
 Lemma andb_true_r : forall b:bool, b && true = b.
 Proof.
-  destruct b; auto with bool.
+  destr_bool.
 Qed.
 
 Lemma andb_true_l : forall b:bool, true && b = b.
 Proof.
-  trivial with bool.
+  reflexivity.
 Qed.
 
 Notation andb_b_true := andb_true_r (only parsing).
@@ -363,7 +382,7 @@ Notation andb_true_b := andb_true_l (only parsing).
 Lemma andb_false_elim :
   forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}.
 Proof.
-  destruct b1; simpl in |- *; auto with bool.
+  destruct b1; simpl; auto.
 Defined.
 Hint Resolve andb_false_elim: bool v62.
 
@@ -371,8 +390,8 @@ Hint Resolve andb_false_elim: bool v62.
 
 Lemma andb_negb_r : forall b:bool, b && negb b = false.
 Proof.
-  destruct b; reflexivity.
-Qed.   
+  destr_bool.
+Qed.
 Hint Resolve andb_negb_r: bool v62.
 
 Notation andb_neg_b := andb_negb_r (only parsing).
@@ -381,14 +400,14 @@ Notation andb_neg_b := andb_negb_r (only parsing).
 
 Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1.
 Proof.
-  destruct b1; destruct b2; reflexivity.
+  destr_bool.
 Qed.
 
 (** Associativity *)
 
 Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3.
 Proof.
-  destruct b1; destruct b2; destruct b3; reflexivity.
+  destr_bool.
 Qed.
 
 Hint Resolve andb_comm andb_assoc: bool v62.
@@ -402,25 +421,25 @@ Hint Resolve andb_comm andb_assoc: bool v62.
 Lemma andb_orb_distrib_r :
   forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3.
 Proof.
-  destruct b1; destruct b2; destruct b3; reflexivity.
+  destr_bool.
 Qed.
 
 Lemma andb_orb_distrib_l :
  forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3.
 Proof.
-  destruct b1; destruct b2; destruct b3; reflexivity.
+  destr_bool.
 Qed.
 
 Lemma orb_andb_distrib_r :
   forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3).
 Proof.
-  destruct b1; destruct b2; destruct b3; reflexivity.
+  destr_bool.
 Qed.
 
 Lemma orb_andb_distrib_l :
   forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3).
 Proof.
-  destruct b1; destruct b2; destruct b3; reflexivity.
+  destr_bool.
 Qed.
 
 (* Compatibility *)
@@ -433,12 +452,12 @@ Notation demorgan4 := orb_andb_distrib_l (only parsing).
 
 Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destr_bool.
 Qed.
 
 Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destr_bool.
 Qed.
 
 (*********************************)
@@ -449,12 +468,12 @@ Qed.
 
 Lemma xorb_false_r : forall b:bool, xorb b false = b.
 Proof.
-  destruct b; trivial.
+  destr_bool.
 Qed.
 
 Lemma xorb_false_l : forall b:bool, xorb false b = b.
 Proof.
-  destruct b; trivial.
+  destr_bool.
 Qed.
 
 Notation xorb_false := xorb_false_r (only parsing).
@@ -464,12 +483,12 @@ Notation false_xorb := xorb_false_l (only parsing).
 
 Lemma xorb_true_r : forall b:bool, xorb b true = negb b.
 Proof.
-  trivial.
+  reflexivity.
 Qed.
 
 Lemma xorb_true_l : forall b:bool, xorb true b = negb b.
 Proof.
-  destruct b; trivial.
+  reflexivity.
 Qed.
 
 Notation xorb_true := xorb_true_r (only parsing).
@@ -479,14 +498,14 @@ Notation true_xorb := xorb_true_l (only parsing).
 
 Lemma xorb_nilpotent : forall b:bool, xorb b b = false.
 Proof.
-  destruct b; trivial.
+  destr_bool.
 Qed.
 
 (** Commutativity *)
 
 Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b.
 Proof.
-  destruct b; destruct b'; trivial.
+  destr_bool.
 Qed.
 
 (** Associativity *)
@@ -494,61 +513,64 @@ Qed.
 Lemma xorb_assoc_reverse :
   forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b'').
 Proof.
-  destruct b; destruct b'; destruct b''; trivial.
+  destr_bool.
 Qed.
 
 Notation xorb_assoc := xorb_assoc_reverse (only parsing). (* Compatibility *)
 
 Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'.
 Proof.
-  destruct b; destruct b'; trivial.
-  unfold xorb in |- *. intros. rewrite H. reflexivity.
+  destr_bool.
 Qed.
 
 Lemma xorb_move_l_r_1 :
   forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''.
 Proof.
-  intros. rewrite <- (false_xorb b'). rewrite <- (xorb_nilpotent b). rewrite xorb_assoc.
-  rewrite H. reflexivity.
+  destr_bool.
 Qed.
 
 Lemma xorb_move_l_r_2 :
   forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'.
 Proof.
-  intros. rewrite xorb_comm in H. rewrite (xorb_move_l_r_1 b' b b'' H). apply xorb_comm.
+  destr_bool.
 Qed.
 
 Lemma xorb_move_r_l_1 :
   forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''.
 Proof.
-  intros. rewrite H. rewrite <- xorb_assoc. rewrite xorb_nilpotent. apply false_xorb.
+  destr_bool.
 Qed.
 
 Lemma xorb_move_r_l_2 :
   forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'.
 Proof.
-  intros. rewrite H. rewrite xorb_assoc. rewrite xorb_nilpotent. apply xorb_false.
+  destr_bool.
 Qed.
 
 (** Lemmas about the [b = true] embedding of [bool] to [Prop] *)
 
-Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. 
-Proof. 
-  intros b1 b2; case b1; case b2; intuition.
+Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true).
+Proof.
+  destr_bool; intuition.
+Qed.
+
+Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2.
+Proof.
+  apply eq_iff_eq_true.
 Qed.
 
 Notation bool_1 := eq_true_iff_eq (only parsing). (* Compatibility *)
 
 Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true.
 Proof.
-  destruct b; intuition.
+  destr_bool; intuition.
 Qed.
 
 Notation bool_3 := eq_true_negb_classical (only parsing). (* Compatibility *)
 
-Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true.  
+Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true.
 Proof.
-  destruct b; intuition.
+  destr_bool; intuition.
 Qed.
 
 Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *)
@@ -589,17 +611,17 @@ Hint Unfold Is_true: bool.
 
 Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true.
 Proof.
-  destruct x; simpl in |- *; tauto.
+  destr_bool; tauto.
 Qed.
 
 Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x.
 Proof.
-  intros; rewrite H; auto with bool.
+  intros; subst; auto with bool.
 Qed.
 
 Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x.
 Proof.
-  intros; rewrite <- H; auto with bool.
+  intros; subst; auto with bool.
 Qed.
 
 Notation Is_true_eq_true2 := Is_true_eq_right (only parsing).
@@ -608,34 +630,34 @@ Hint Immediate Is_true_eq_right Is_true_eq_left: bool.
 
 Lemma eqb_refl : forall x:bool, Is_true (eqb x x).
 Proof.
-  destruct x; simpl; auto with bool.
+  destr_bool.
 Qed.
 
 Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y.
 Proof.
-  destruct x; destruct y; simpl; tauto.
+  destr_bool; tauto.
 Qed.
 
 (** [Is_true] and connectives *)
 
-Lemma orb_prop_elim : 
+Lemma orb_prop_elim :
   forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b.
 Proof.
-  destruct a; destruct b; simpl; tauto.
+  destr_bool; tauto.
 Qed.
 
 Notation orb_prop2 := orb_prop_elim (only parsing).
 
-Lemma orb_prop_intro : 
+Lemma orb_prop_intro :
   forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b).
 Proof.
-  destruct a; destruct b; simpl; tauto.
+  destr_bool; tauto.
 Qed.
 
 Lemma andb_prop_intro :
   forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2).
 Proof.
-  destruct b1; destruct b2; simpl in |- *; tauto.
+  destr_bool; tauto.
 Qed.
 Hint Resolve andb_prop_intro: bool v62.
 
@@ -646,66 +668,65 @@ Notation andb_true_intro2 :=
 Lemma andb_prop_elim :
   forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b.
 Proof.
-  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
-    auto with bool.
+  destr_bool; auto.
 Qed.
 Hint Resolve andb_prop_elim: bool v62.
 
 Notation andb_prop2 := andb_prop_elim (only parsing).
 
-Lemma eq_bool_prop_intro : 
-  forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. 
-Proof. 
-  destruct b1; destruct b2; simpl in *; intuition.
+Lemma eq_bool_prop_intro :
+  forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2.
+Proof.
+  destr_bool; tauto.
 Qed.
 
 Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2).
-Proof. 
-  intros b1 b2; case b1; case b2; intuition.
-Qed. 
+Proof.
+  destr_bool; tauto.
+Qed.
 
 Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b.
 Proof.
-  destruct b; intuition.
+  destr_bool; tauto.
 Qed.
 
 Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b).
 Proof.
-  destruct b; simpl in *; intuition.
+  destr_bool; tauto.
 Qed.
 
 Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b.
 Proof.
-  destruct b; intuition.
+  destr_bool; tauto.
 Qed.
 
 Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b).
 Proof.
-  destruct b; intuition.
+  destr_bool; tauto.
 Qed.
 
 (** Rewrite rules about andb, orb and if (used in romega) *)
 
-Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), 
-  (if b && b' then a else a') = 
+Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool),
+  (if b && b' then a else a') =
   (if b then if b' then a else a' else a').
 Proof.
- destruct b; destruct b'; auto.
+  destr_bool.
 Qed.
 
-Lemma negb_if : forall (A:Type)(a a':A)(b:bool), 
- (if negb b then a else a') = 
+Lemma negb_if : forall (A:Type)(a a':A)(b:bool),
+ (if negb b then a else a') =
  (if b then a' else a).
 Proof.
- destruct b; auto.
+  destr_bool.
 Qed.
 
 (*****************************************)
-(** * Alternative versions of [andb] and [orb] 
+(** * Alternative versions of [andb] and [orb]
     with lazy behavior (for vm_compute)  *)
 (*****************************************)
 
-Notation "a &&& b" := (if a then b else false) 
+Notation "a &&& b" := (if a then b else false)
  (at level 40, left associativity) : lazy_bool_scope.
 Notation "a ||| b" := (if a then true else b)
  (at level 50, left associativity) : lazy_bool_scope.
@@ -714,12 +735,51 @@ Open Local Scope lazy_bool_scope.
 
 Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b.
 Proof.
- unfold andb; auto.
+  reflexivity.
 Qed.
 
 Lemma orb_lazy_alt : forall a b : bool, a || b = a ||| b.
 Proof.
- unfold orb; auto.
+  reflexivity.
+Qed.
+
+(*****************************************)
+(** * Reflect: a specialized inductive type for
+    relating propositions and booleans,
+    as popularized by the Ssreflect library. *)
+(*****************************************)
+
+Inductive reflect (P : Prop) : bool -> Set :=
+  | ReflectT : P -> reflect P true
+  | ReflectF : ~ P -> reflect P false.
+Hint Constructors reflect : bool.
+
+(** Interest: a case on a reflect lemma or hyp performs clever
+    unification, and leave the goal in a convenient shape
+    (a bit like case_eq). *)
+
+(** Relation with iff : *)
+
+Lemma reflect_iff : forall P b, reflect P b -> (P<->b=true).
+Proof.
+ destruct 1; intuition; discriminate.
+Qed.
+
+Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b.
+Proof.
+ destr_bool; intuition.
 Qed.
 
+(** It would be nice to join [reflect_iff] and [iff_reflect]
+    in a unique [iff] statement, but this isn't allowed since
+    [iff] is in Prop. *)
+
+(** Reflect implies decidability of the proposition *)
+
+Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}.
+Proof.
+ destruct 1; auto.
+Qed.
 
+(** Reciprocally, from a decidability, we could state a
+    [reflect] as soon as we have a [bool_of_sumbool]. *)
diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v
index 806ac70f..625cbd19 100644
--- a/theories/Bool/BoolEq.v
+++ b/theories/Bool/BoolEq.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BoolEq.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 (* Cuihtlauac Alvarado - octobre 2000 *)
 
 (** Properties of a boolean equality   *)
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index 0e8ea33c..7ecfa43f 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bvector.v 11004 2008-05-28 09:09:12Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
 
@@ -16,34 +16,34 @@ Require Import Arith.
 
 Open Local Scope nat_scope.
 
-(** 
-On s'inspire de List.v pour fabriquer les vecteurs de bits.
-La dimension du vecteur est un paramètre trop important pour
-se contenter de la fonction "length".
-La première idée est de faire un record avec la liste et la longueur.
-Malheureusement, cette verification a posteriori amene a faire
-de nombreux lemmes pour gerer les longueurs.
-La seconde idée est de faire un type dépendant dans lequel la
-longueur est un paramètre de construction. Cela complique un
-peu les inductions structurelles et dans certains cas on
-utilisera un terme de preuve comme définition, car le
-mécanisme d'inférence du type du filtrage n'est pas toujours 
-aussi puissant que celui implanté par les tactiques d'élimination.
+(**
+We build bit vectors in the spirit of List.v.
+The size of the vector is a parameter which is too important
+to be accessible only via function "length".
+The first idea is to build a record with both the list and the length.
+Unfortunately, this a posteriori verification leads to
+numerous lemmas for handling lengths.
+The second idea is to use a dependent type in which the length
+is a building parameter. This leads to structural induction that
+are slightly more complex and in some cases we will use a proof-term
+as definition, since the type inference mechanism for pattern-matching
+is sometimes weaker that the one implemented for elimination tactiques.
 *)
 
 Section VECTORS.
 
-(** 
-Un vecteur est une liste de taille n d'éléments d'un ensemble A.
-Si la taille est non nulle, on peut extraire la première composante et 
-le reste du vecteur, la dernière composante ou rajouter ou enlever 
-une composante (carry) ou repeter la dernière composante en fin de vecteur.
-On peut aussi tronquer le vecteur de ses p dernières composantes ou
-au contraire l'étendre (concaténer) d'un vecteur de longueur p.
-Une fonction unaire sur A génère une fonction des vecteurs de taille n
-dans les vecteurs de taille n en appliquant f terme à terme.
-Une fonction binaire sur A génère une fonction des couples de vecteurs 
-de taille n dans les vecteurs de taille n en appliquant f terme à terme.
+(**
+A vector is a list of size n whose elements belongs to a set A.
+If the size is non-zero, we can extract the first component and the
+rest of the vector, as well as the last component, or adding or
+removing a component (carry) or repeating the last component at the
+end of the vector.
+We can also truncate the vector and remove its p last components or
+reciprocally extend the vector by concatenation.
+A unary function over A generates a function on vectors of size n by
+applying f pointwise.
+A binary function over A generates a function on pairs of vectors of
+size n by applying f pointwise.
 *)
 
 Variable A : Type.
@@ -93,7 +93,7 @@ Lemma Vshiftin : forall n:nat, A -> vector n -> vector (S n).
 Proof.
   induction n as [| n f]; intros a v.
   exact (Vcons a 0 v).
-  
+
   inversion v as [| a0 n0 H0 H1 ].
   exact (Vcons a (S n) (f a H0)).
 Defined.
@@ -103,7 +103,7 @@ Proof.
   induction n as [| n f]; intro v.
   inversion v.
   exact (Vcons a 1 v).
-  
+
   inversion v as [| a n0 H0 H1 ].
   exact (Vcons a (S (S n)) (f H0)).
 Defined.
@@ -113,9 +113,9 @@ Proof.
   induction p as [| p f]; intros H v.
   rewrite <- minus_n_O.
   exact v.
-  
+
   apply (Vshiftout (n - S p)).
-  
+
   rewrite minus_Sn_m.
   apply f.
   auto with *.
@@ -147,7 +147,7 @@ Lemma Vbinary : forall n:nat, vector n -> vector n -> vector n.
 Proof.
   induction n as [| n h]; intros v v0.
   exact Vnil.
-  
+
   inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3].
   exact (Vcons (g a a0) n (h H0 H2)).
 Defined.
@@ -180,7 +180,7 @@ Qed.
 
 End VECTORS.
 
-(* suppressed: incompatible with Coq-Art book 
+(* suppressed: incompatible with Coq-Art book
 Implicit Arguments Vnil [A].
 Implicit Arguments Vcons [A n].
 *)
@@ -188,15 +188,16 @@ Implicit Arguments Vcons [A n].
 Section BOOLEAN_VECTORS.
 
 (**
-Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. 
-ATTENTION : le stockage s'effectue poids FAIBLE en tête.
-On en extrait le bit  de poids faible (head) et la fin du vecteur (tail).
-On calcule la négation d'un vecteur, le et, le ou et le xor bit à bit de 2 vecteurs.
-On calcule les décalages d'une position vers la gauche (vers les poids forts, on
-utilise donc Vshiftout, vers la droite (vers les poids faibles, on utilise Vshiftin) en 
-insérant un bit 'carry' (logique) ou en répétant le bit de poids fort (arithmétique).
-ATTENTION : Tous les décalages prennent la taille moins un comme paramètre
-(ils ne travaillent que sur des vecteurs au moins de longueur un).
+A bit vector is a vector over booleans.
+Notice that the LEAST significant bit comes first (little-endian representation).
+We extract the least significant bit (head) and the rest of the vector (tail).
+We compute bitwise operation on vector: negation, and, or, xor.
+We compute size-preserving shifts: to the left (towards most significant bits,
+we hence use Vshiftout) and to the right (towards least significant bits,
+we use Vshiftin) by inserting a 'carry' bit (logical shift) or by repeating
+the most significant bit (arithmetical shift).
+NOTA BENE: all shift operations expect predecessor of size as parameter
+(they only work on non-empty vectors).
 *)
 
 Definition Bvector := vector bool.
@@ -232,22 +233,19 @@ Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) :=
 Definition BshiftRa (n:nat) (bv:Bvector (S n)) :=
   Bhigh (S n) (Vshiftrepeat bool n bv).
 
-Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
-  Bvector (S n) :=
+Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
   match p with
     | O => bv
     | S p' => BshiftL n (BshiftL_iter n bv p') false
   end.
 
-Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
-  Bvector (S n) :=
+Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
   match p with
     | O => bv
     | S p' => BshiftRl n (BshiftRl_iter n bv p') false
   end.
 
-Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
-  Bvector (S n) :=
+Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
   match p with
     | O => bv
     | S p' => BshiftRa n (BshiftRa_iter n bv p')
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
index af9acea1..90f7ee66 100644
--- a/theories/Bool/DecBool.v
+++ b/theories/Bool/DecBool.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: DecBool.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
index 0a98c32a..c2b5ed79 100644
--- a/theories/Bool/IfProp.v
+++ b/theories/Bool/IfProp.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: IfProp.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Bool.
 
diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
index 0da72f56..06ab77cf 100644
--- a/theories/Bool/Sumbool.v
+++ b/theories/Bool/Sumbool.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sumbool.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (** Here are collected some results about the type sumbool (see INIT/Specif.v)
    [sumbool A B], which is written [{A}+{B}], is the informative
@@ -39,18 +39,18 @@ Defined.
 Section connectives.
 
   Variables A B C D : Prop.
-  
+
   Hypothesis H1 : {A} + {B}.
   Hypothesis H2 : {C} + {D}.
-  
+
   Definition sumbool_and : {A /\ C} + {B \/ D}.
     case H1; case H2; auto.
   Defined.
-  
+
   Definition sumbool_or : {A \/ C} + {B /\ D}.
     case H1; case H2; auto.
   Defined.
-  
+
   Definition sumbool_not : {B} + {A}.
     case H1; auto.
   Defined.
diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
index fe656777..5e9d4afa 100644
--- a/theories/Bool/Zerob.v
+++ b/theories/Bool/Zerob.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zerob.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Arith.
 Require Import Bool.
diff --git a/theories/Bool/vo.itarget b/theories/Bool/vo.itarget
new file mode 100644
index 00000000..24cbf4ed
--- /dev/null
+++ b/theories/Bool/vo.itarget
@@ -0,0 +1,7 @@
+BoolEq.vo
+Bool.vo
+Bvector.vo
+DecBool.vo
+IfProp.vo
+Sumbool.vo
+Zerob.vo
diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v
index 15cabf81..0a35ef45 100644
--- a/theories/Classes/EquivDec.v
+++ b/theories/Classes/EquivDec.v
@@ -6,46 +6,51 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Decidable equivalences.
- *
- * Author: Matthieu Sozeau
- * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
- *              91405 Orsay, France *)
+(** * Decidable equivalences.
 
-(* $Id: EquivDec.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+   Author: Matthieu Sozeau
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
+
+(* $Id$ *)
 
 (** Export notations. *)
 
 Require Export Coq.Classes.Equivalence.
 
-(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more 
-   classically. *)
+(** The [DecidableSetoid] class asserts decidability of a [Setoid].
+   It can be useful in proofs to reason more classically. *)
 
 Require Import Coq.Logic.Decidable.
+Require Import Coq.Bool.Bool.
+Require Import Coq.Arith.Peano_dec.
+Require Import Coq.Program.Program.
+
+Generalizable Variables A B R.
 
 Open Scope equiv_scope.
 
 Class DecidableEquivalence `(equiv : Equivalence A) :=
   setoid_decidable : forall x y : A, decidable (x === y).
 
-(** The [EqDec] class gives a decision procedure for a particular setoid equality. *)
+(** The [EqDec] class gives a decision procedure for a particular
+   setoid equality. *)
 
 Class EqDec A R {equiv : Equivalence R} :=
   equiv_dec : forall x y : A, { x === y } + { x =/= y }.
 
-(** We define the [==] overloaded notation for deciding equality. It does not take precedence
-   of [==] defined in the type scope, hence we can have both at the same time. *)
+(** We define the [==] overloaded notation for deciding equality. It does not
+   take precedence of [==] defined in the type scope, hence we can have both
+   at the same time. *)
 
 Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) : equiv_scope.
 
 Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
   match x with
-    | left H => @right _ _ H 
-    | right H => @left _ _ H 
+    | left H => @right _ _ H
+    | right H => @left _ _ H
   end.
 
-Require Import Coq.Program.Program.
-
 Open Local Scope program_scope.
 
 (** Invert the branches. *)
@@ -69,17 +74,14 @@ Infix "<>b" := nequiv_decb (no associativity, at level 70).
 
 (** Decidable leibniz equality instances. *)
 
-Require Import Coq.Arith.Peano_dec.
-
-(** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *)
+(** The equiv is burried inside the setoid, but we can recover it by specifying
+   which setoid we're talking about. *)
 
 Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec.
 
-Require Import Coq.Bool.Bool.
-
 Program Instance bool_eqdec : EqDec bool eq := bool_dec.
 
-Program Instance unit_eqdec : EqDec unit eq := λ x y, in_left.
+Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left.
 
   Next Obligation.
   Proof.
@@ -87,41 +89,37 @@ Program Instance unit_eqdec : EqDec unit eq := λ x y, in_left.
     reflexivity.
   Qed.
 
+Obligation Tactic := unfold complement, equiv ; program_simpl.
+
 Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) :
   ! EqDec (prod A B) eq :=
   { equiv_dec x y :=
-    let '(x1, x2) := x in 
-    let '(y1, y2) := y in 
-    if x1 == y1 then 
+    let '(x1, x2) := x in
+    let '(y1, y2) := y in
+    if x1 == y1 then
       if x2 == y2 then in_left
       else in_right
     else in_right }.
 
-  Solve Obligations using unfold complement, equiv ; program_simpl.
-
 Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) :
   EqDec (sum A B) eq := {
-  equiv_dec x y := 
+  equiv_dec x y :=
     match x, y with
       | inl a, inl b => if a == b then in_left else in_right
       | inr a, inr b => if a == b then in_left else in_right
       | inl _, inr _ | inr _, inl _ => in_right
     end }.
 
-  Solve Obligations using unfold complement, equiv ; program_simpl.
-
-(** Objects of function spaces with countable domains like bool have decidable equality. 
-   Proving the reflection requires functional extensionality though. *)
+(** Objects of function spaces with countable domains like bool have decidable
+  equality. Proving the reflection requires functional extensionality though. *)
 
 Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq :=
-  { equiv_dec f g := 
+  { equiv_dec f g :=
     if f true == g true then
       if f false == g false then in_left
       else in_right
     else in_right }.
 
-  Solve Obligations using try red ; unfold equiv, complement ; program_simpl.
-
   Next Obligation.
   Proof.
     extensionality x.
@@ -131,21 +129,19 @@ Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq :=
 Require Import List.
 
 Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq :=
-  { equiv_dec := 
-    fix aux (x : list A) y { struct x } :=
+  { equiv_dec :=
+    fix aux (x y : list A) :=
     match x, y with
       | nil, nil => in_left
-      | cons hd tl, cons hd' tl' => 
+      | cons hd tl, cons hd' tl' =>
         if hd == hd' then
           if aux tl tl' then in_left else in_right
           else in_right
       | _, _ => in_right
     end }.
 
-  Solve Obligations using unfold equiv, complement in *; program_simpl;
-    intuition (discriminate || eauto).
+  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).
 
-  Next Obligation. destruct x ; destruct y ; intuition eauto. Defined.
+  Next Obligation. destruct y ; intuition eauto. Defined.
 
-  Solve Obligations using unfold equiv, complement in *; program_simpl;
-    intuition (discriminate || eauto).
+  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).
diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v
index 7068bc6b..d0f24347 100644
--- a/theories/Classes/Equivalence.v
+++ b/theories/Classes/Equivalence.v
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Typeclass-based setoids. Definitions on [Equivalence].
- 
+(** * Typeclass-based setoids. Definitions on [Equivalence].
+
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *) 
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
-(* $Id: Equivalence.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
@@ -25,16 +25,20 @@ Require Import Coq.Classes.Morphisms.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+Generalizable Variables A R eqA B S eqB.
+Local Obligation Tactic := simpl_relation.
+
 Open Local Scope signature_scope.
 
 Definition equiv `{Equivalence A R} : relation A := R.
 
-(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *)
+(** Overloaded notations for setoid equivalence and inequivalence.
+    Not to be confused with [eq] and [=]. *)
 
 Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope.
 
 Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope.
-  
+
 Open Local Scope equiv_scope.
 
 (** Overloading for [PER]. *)
@@ -60,7 +64,7 @@ Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv.
 
 (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *)
 
-Ltac setoid_subst H := 
+Ltac setoid_subst H :=
   match type of H with
     ?x === ?y => substitute H ; clear H x
   end.
@@ -70,7 +74,7 @@ Ltac setoid_subst_nofail :=
     | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail
     | _ => idtac
   end.
-  
+
 (** [subst*] will try its best at substituting every equality in the goal. *)
 
 Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail.
@@ -100,19 +104,19 @@ Ltac equivify := repeat equivify_tac.
 
 Section Respecting.
 
-  (** Here we build an equivalence instance for functions which relates respectful ones only, 
+  (** Here we build an equivalence instance for functions which relates respectful ones only,
      we do not export it. *)
 
-  Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type := 
+  Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type :=
     { morph : A -> B | respectful R R' morph morph }.
-  
+
   Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') :
     Equivalence (fun (f g : respecting eqa eqb) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)).
-  
+
   Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl.
 
   Next Obligation.
-  Proof. 
+  Proof.
     unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity.
   Qed.
 
diff --git a/theories/Classes/Functions.v b/theories/Classes/Functions.v
deleted file mode 100644
index 998f8cb7..00000000
--- a/theories/Classes/Functions.v
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Functional morphisms.
- 
-   Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
-
-(* $Id: Functions.v 11709 2008-12-20 11:42:15Z msozeau $ *)
-
-Require Import Coq.Classes.RelationClasses.
-Require Import Coq.Classes.Morphisms.
-
-Set Implicit Arguments.
-Unset Strict Implicit.
-
-Class Injective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop :=
-  injective : forall x y : A, RB (f x) (f y) -> RA x y.
-
-Class Surjective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop :=
-  surjective : forall y, exists x : A, RB y (f x).
-
-Definition Bijective `(m : Morphism (A -> B) (RA ++> RB) (f : A -> B)) :=
-  Injective m /\ Surjective m.
-
-Class MonoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) :=
-  monic :> Injective m.
-
-Class EpiMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) :=
-  epic :> Surjective m.
-
-Class IsoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) :=
-  { monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m }.
-
-Class AutoMorphism `(m : Morphism (A -> A) (eqA ++> eqA)) {I : IsoMorphism m}.
diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v
index 762cc5c1..f6e51018 100644
--- a/theories/Classes/Init.v
+++ b/theories/Classes/Init.v
@@ -6,22 +6,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Initialization code for typeclasses, setting up the default tactic 
+(** * Initialization code for typeclasses, setting up the default tactic
    for instance search.
 
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
-(* $Id: Init.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 (** Hints for the proof search: these combinators should be considered rigid. *)
 
 Require Import Coq.Program.Basics.
 
-Typeclasses Opaque id const flip compose arrow impl iff.
+Typeclasses Opaque id const flip compose arrow impl iff not all.
 
-(** The unconvertible typeclass, to test that two objects of the same type are 
+(** Apply using the same opacity information as typeclass proof search. *)
+
+Ltac class_apply c := autoapply c using typeclass_instances.
+
+(** The unconvertible typeclass, to test that two objects of the same type are
    actually different. *)
 
 Class Unconvertible (A : Type) (a b : A) := unconvertible : unit.
diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v
index 2b653e27..370321c0 100644
--- a/theories/Classes/Morphisms.v
+++ b/theories/Classes/Morphisms.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,41 +7,44 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Typeclass-based morphism definition and standard, minimal instances.
- 
+(** * Typeclass-based morphism definition and standard, minimal instances
+
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
-(* $Id: Morphisms.v 12189 2009-06-15 05:08:44Z msozeau $ *)
+(* $Id$ *)
 
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
 Require Import Coq.Relations.Relation_Definitions.
 Require Export Coq.Classes.RelationClasses.
 
+Generalizable All Variables.
+Local Obligation Tactic := simpl_relation.
+
 (** * Morphisms.
 
-   We now turn to the definition of [Morphism] and declare standard instances. 
+   We now turn to the definition of [Proper] and declare standard instances.
    These will be used by the [setoid_rewrite] tactic later. *)
 
-(** A morphism on a relation [R] is an object respecting the relation (in its kernel). 
-   The relation [R] will be instantiated by [respectful] and [A] by an arrow type 
-   for usual morphisms. *)
+(** A morphism for a relation [R] is a proper element of the relation.
+   The relation [R] will be instantiated by [respectful] and [A] by an arrow
+   type for usual morphisms. *)
 
-Class Morphism {A} (R : relation A) (m : A) : Prop :=
-  respect : R m m.
+Class Proper {A} (R : relation A) (m : A) : Prop :=
+  proper_prf : R m m.
 
 (** Respectful morphisms. *)
 
 (** The fully dependent version, not used yet. *)
 
-Definition respectful_hetero 
-  (A B : Type) 
-  (C : A -> Type) (D : B -> Type) 
-  (R : A -> B -> Prop) 
-  (R' : forall (x : A) (y : B), C x -> D y -> Prop) : 
-    (forall x : A, C x) -> (forall x : B, D x) -> Prop := 
+Definition respectful_hetero
+  (A B : Type)
+  (C : A -> Type) (D : B -> Type)
+  (R : A -> B -> Prop)
+  (R' : forall (x : A) (y : B), C x -> D y -> Prop) :
+    (forall x : A, C x) -> (forall x : B, D x) -> Prop :=
     fun f g => forall x y, R x y -> R' x y (f x) (g y).
 
 (** The non-dependent version is an instance where we forget dependencies. *)
@@ -53,27 +57,27 @@ Definition respectful {A B : Type}
 
 Delimit Scope signature_scope with signature.
 
-Arguments Scope Morphism [type_scope signature_scope].
+Arguments Scope Proper [type_scope signature_scope].
 Arguments Scope respectful [type_scope type_scope signature_scope signature_scope].
 
-Module MorphismNotations.
+Module ProperNotations.
 
-  Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) 
+  Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature))
     (right associativity, at level 55) : signature_scope.
-  
+
   Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature))
     (right associativity, at level 55) : signature_scope.
-  
+
   Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature))
     (right associativity, at level 55) : signature_scope.
 
-End MorphismNotations.
+End ProperNotations.
 
-Export MorphismNotations.
+Export ProperNotations.
 
 Open Local Scope signature_scope.
 
-(** Dependent pointwise lifting of a relation on the range. *) 
+(** Dependent pointwise lifting of a relation on the range. *)
 
 Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) :=
   λ f g, Π a : A, sig a (f a) (g a).
@@ -82,10 +86,10 @@ Arguments Scope forall_relation [type_scope type_scope signature_scope].
 
 (** Non-dependent pointwise lifting *)
 
-Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := 
+Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) :=
   Eval compute in forall_relation (B:=λ _, B) (λ _, R).
 
-Lemma pointwise_pointwise A B (R : relation B) : 
+Lemma pointwise_pointwise A B (R : relation B) :
   relation_equivalence (pointwise_relation A R) (@eq A ==> R).
 Proof. intros. split. simpl_relation. firstorder. Qed.
 
@@ -98,8 +102,7 @@ Hint Unfold Transitive : core.
 
 Typeclasses Opaque respectful pointwise_relation forall_relation.
 
-Program Instance respectful_per `(PER A (R : relation A), PER B (R' : relation B)) : 
-  PER (R ==> R').
+Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R').
 
   Next Obligation.
   Proof with auto.
@@ -110,47 +113,46 @@ Program Instance respectful_per `(PER A (R : relation A), PER B (R' : relation B
 
 (** Subrelations induce a morphism on the identity. *)
 
-Instance subrelation_id_morphism `(subrelation A R� R₂) : Morphism (R� ==> R₂) id.
+Instance subrelation_id_proper `(subrelation A R� R₂) : Proper (R� ==> R₂) id.
 Proof. firstorder. Qed.
 
 (** The subrelation property goes through products as usual. *)
 
-Instance morphisms_subrelation_respectful `(subl : subrelation A R₂ R�, subr : subrelation B S� S₂) :
+Lemma subrelation_respectful `(subl : subrelation A R₂ R�, subr : subrelation B S� S₂) :
   subrelation (R� ==> S�) (R₂ ==> S₂).
 Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed.
 
 (** And of course it is reflexive. *)
 
-Instance morphisms_subrelation_refl : ! subrelation A R R.
+Lemma subrelation_refl A R : @subrelation A R R.
 Proof. simpl_relation. Qed.
 
-(** [Morphism] is itself a covariant morphism for [subrelation]. *)
+Ltac subrelation_tac T U :=
+  (is_ground T ; is_ground U ; class_apply @subrelation_refl) ||
+    class_apply @subrelation_respectful || class_apply @subrelation_refl.
+
+Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances.
 
-Lemma subrelation_morphism `(mor : Morphism A R� m, unc : Unconvertible (relation A) R� R₂,
-  sub : subrelation A R� R₂) : Morphism R₂ m.
+(** [Proper] is itself a covariant morphism for [subrelation]. *)
+
+Lemma subrelation_proper `(mor : Proper A R� m, unc : Unconvertible (relation A) R� R₂,
+  sub : subrelation A R� R₂) : Proper R₂ m.
 Proof.
   intros. apply sub. apply mor.
 Qed.
 
-Instance morphism_subrelation_morphism : 
-  Morphism (subrelation ++> @eq _ ==> impl) (@Morphism A).
-Proof. reduce. subst. firstorder. Qed.
-
-(** We use an external tactic to manage the application of subrelation, which is otherwise
-   always applicable. We allow its use only once per branch. *)
-
-Inductive subrelation_done : Prop := did_subrelation : subrelation_done.
+CoInductive apply_subrelation : Prop := do_subrelation.
 
-Inductive normalization_done : Prop := did_normalization.
-
-Ltac subrelation_tac := 
+Ltac proper_subrelation :=
   match goal with
-    | [ _ : subrelation_done |- _ ] => fail 1
-    | [ |- @Morphism _ _ _ ] => let H := fresh "H" in
-      set(H:=did_subrelation) ; eapply @subrelation_morphism
+    [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper
   end.
 
-Hint Extern 5 (@Morphism _ _ _) => subrelation_tac : typeclass_instances.
+Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances.
+
+Instance proper_subrelation_proper :
+  Proper (subrelation ++> eq ==> impl) (@Proper A).
+Proof. reduce. subst. firstorder. Qed.
 
 (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *)
 
@@ -164,11 +166,29 @@ Instance pointwise_subrelation {A} `(sub : subrelation B R R') :
   subrelation (pointwise_relation A R) (pointwise_relation A R') | 4.
 Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed.
 
-(** The complement of a relation conserves its morphisms. *)
+(** For dependent function types. *)
+Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) :
+  (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S).
+Proof. reduce. apply H. apply H0. Qed.
+
+(** We use an extern hint to help unification. *)
+
+Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) =>
+  apply (@forall_subrelation A B R S) ; intro : typeclass_instances.
+
+(** Any symmetric relation is equal to its inverse. *)
+
+Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R.
+Proof. reduce. red in H0. symmetry. assumption. Qed.
+
+Hint Extern 4 (subrelation (inverse _) _) => 
+  class_apply @subrelation_symmetric : typeclass_instances.
 
-Program Instance complement_morphism
-  `(mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R) :
-  Morphism (RA ==> RA ==> iff) (complement R).
+(** The complement of a relation conserves its proper elements. *)
+
+Program Instance complement_proper
+  `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
+  Proper (RA ==> RA ==> iff) (complement R).
 
   Next Obligation.
   Proof.
@@ -177,22 +197,22 @@ Program Instance complement_morphism
     intuition.
   Qed.
 
-(** The [inverse] too, actually the [flip] instance is a bit more general. *) 
+(** The [inverse] too, actually the [flip] instance is a bit more general. *)
 
-Program Instance flip_morphism
-  `(mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f) :
-  Morphism (RB ==> RA ==> RC) (flip f).
+Program Instance flip_proper
+  `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
+  Proper (RB ==> RA ==> RC) (flip f).
 
   Next Obligation.
   Proof.
     apply mor ; auto.
   Qed.
 
-(** Every Transitive relation gives rise to a binary morphism on [impl], 
+(** Every Transitive relation gives rise to a binary morphism on [impl],
    contravariant in the first argument, covariant in the second. *)
 
 Program Instance trans_contra_co_morphism
-  `(Transitive A R) : Morphism (R --> R ++> impl) R.
+  `(Transitive A R) : Proper (R --> R ++> impl) R.
 
   Next Obligation.
   Proof with auto.
@@ -200,10 +220,10 @@ Program Instance trans_contra_co_morphism
     transitivity x0...
   Qed.
 
-(** Morphism declarations for partial applications. *)
+(** Proper declarations for partial applications. *)
 
 Program Instance trans_contra_inv_impl_morphism
-  `(Transitive A R) : Morphism (R --> inverse impl) (R x) | 3.
+  `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
@@ -211,7 +231,7 @@ Program Instance trans_contra_inv_impl_morphism
   Qed.
 
 Program Instance trans_co_impl_morphism
-  `(Transitive A R) : Morphism (R ==> impl) (R x) | 3.
+  `(Transitive A R) : Proper (R ++> impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
@@ -219,7 +239,7 @@ Program Instance trans_co_impl_morphism
   Qed.
 
 Program Instance trans_sym_co_inv_impl_morphism
-  `(PER A R) : Morphism (R ==> inverse impl) (R x) | 2.
+  `(PER A R) : Proper (R ++> inverse impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
@@ -227,7 +247,7 @@ Program Instance trans_sym_co_inv_impl_morphism
   Qed.
 
 Program Instance trans_sym_contra_impl_morphism
-  `(PER A R) : Morphism (R --> impl) (R x) | 2.
+  `(PER A R) : Proper (R --> impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
@@ -235,7 +255,7 @@ Program Instance trans_sym_contra_impl_morphism
   Qed.
 
 Program Instance per_partial_app_morphism
-  `(PER A R) : Morphism (R ==> iff) (R x) | 1.
+  `(PER A R) : Proper (R ==> iff) (R x) | 2.
 
   Next Obligation.
   Proof with auto.
@@ -249,7 +269,7 @@ Program Instance per_partial_app_morphism
    to get an [R y z] goal. *)
 
 Program Instance trans_co_eq_inv_impl_morphism
-  `(Transitive A R) : Morphism (R ==> (@eq A) ==> inverse impl) R | 2.
+  `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2.
 
   Next Obligation.
   Proof with auto.
@@ -258,21 +278,21 @@ Program Instance trans_co_eq_inv_impl_morphism
 
 (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *)
 
-Program Instance PER_morphism `(PER A R) : Morphism (R ==> R ==> iff) R | 1.
+Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1.
 
   Next Obligation.
   Proof with auto.
     split ; intros.
     transitivity x0... transitivity x... symmetry...
-  
+
     transitivity y... transitivity y0... symmetry...
   Qed.
 
 Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R).
 Proof. firstorder. Qed.
-  
-Program Instance compose_morphism A B C R₀ R� R₂ :
-  Morphism ((R� ==> R₂) ==> (R₀ ==> R�) ==> (R₀ ==> R₂)) (@compose A B C).
+
+Program Instance compose_proper A B C R₀ R� R₂ :
+  Proper ((R� ==> R₂) ==> (R₀ ==> R�) ==> (R₀ ==> R₂)) (@compose A B C).
 
   Next Obligation.
   Proof.
@@ -280,7 +300,7 @@ Program Instance compose_morphism A B C R₀ R� R₂ :
     unfold compose. apply H. apply H0. apply H1.
   Qed.
 
-(** Coq functions are morphisms for leibniz equality, 
+(** Coq functions are morphisms for Leibniz equality,
    applied only if really needed. *)
 
 Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') :
@@ -289,13 +309,13 @@ Proof. simpl_relation. Qed.
 
 (** [respectful] is a morphism for relation equivalence. *)
 
-Instance respectful_morphism : 
-  Morphism (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B).
+Instance respectful_morphism :
+  Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B).
 Proof.
   reduce.
   unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *.
   split ; intros.
-  
+
     rewrite <- H0.
     apply H1.
     rewrite H.
@@ -309,43 +329,50 @@ Qed.
 
 (** Every element in the carrier of a reflexive relation is a morphism for this relation.
    We use a proxy class for this case which is used internally to discharge reflexivity constraints.
-   The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of 
-   [Morphism (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able
+   The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of
+   [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able
    to set different priorities in different hint bases and select a particular hint database for
-   resolution of a type class constraint.*) 
+   resolution of a type class constraint.*)
 
-Class MorphismProxy {A} (R : relation A) (m : A) : Prop :=
-  respect_proxy : R m m.
+Class ProperProxy {A} (R : relation A) (m : A) : Prop :=
+  proper_proxy : R m m.
 
-Instance reflexive_morphism_proxy
-  `(Reflexive A R) (x : A) : MorphismProxy R x | 1.
+Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x.
 Proof. firstorder. Qed.
 
-Instance morphism_morphism_proxy
-  `(Morphism A R x) : MorphismProxy R x | 2.
+Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x.
 Proof. firstorder. Qed.
 
+Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x.
+Proof. firstorder. Qed.
+
+Hint Extern 1 (ProperProxy _ _) => 
+  class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances.
+Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances.
+
 (** [R] is Reflexive, hence we can build the needed proof. *)
 
-Lemma Reflexive_partial_app_morphism `(Morphism (A -> B) (R ==> R') m, MorphismProxy A R x) :
-   Morphism R' (m x).
+Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) :
+   Proper R' (m x).
 Proof. simpl_relation. Qed.
 
 Class Params {A : Type} (of : A) (arity : nat).
 
 Class PartialApplication.
 
-Ltac partial_application_tactic := 
+CoInductive normalization_done : Prop := did_normalization.
+
+Ltac partial_application_tactic :=
   let rec do_partial_apps H m :=
     match m with
-      | ?m' ?x => eapply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H]
+      | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H]
       | _ => idtac
     end
   in
   let rec do_partial H ar m :=
     match ar with
       | 0 => do_partial_apps H m
-      | S ?n' => 
+      | S ?n' =>
         match m with
           ?m' ?x => do_partial H n' m'
         end
@@ -357,25 +384,24 @@ Ltac partial_application_tactic :=
     let v := eval compute in n in clear n ;
     let H := fresh in
       assert(H:Params m' v) by typeclasses eauto ;
-      let v' := eval compute in v in 
+      let v' := eval compute in v in subst m';
       do_partial H v' m
  in
   match goal with
-    | [ _ : subrelation_done |- _ ] => fail 1
     | [ _ : normalization_done |- _ ] => fail 1
     | [ _ : @Params _ _ _ |- _ ] => fail 1
-    | [ |- @Morphism ?T _ (?m ?x) ] => 
-      match goal with 
-        | [ _ : PartialApplication |- _ ] => 
-          eapply @Reflexive_partial_app_morphism
-        | _ => 
-          on_morphism (m x) || 
-            (eapply @Reflexive_partial_app_morphism ;
+    | [ |- @Proper ?T _ (?m ?x) ] =>
+      match goal with
+        | [ _ : PartialApplication |- _ ] =>
+          class_apply @Reflexive_partial_app_morphism
+        | _ =>
+          on_morphism (m x) ||
+            (class_apply @Reflexive_partial_app_morphism ;
               [ pose Build_PartialApplication | idtac ])
       end
   end.
 
-Hint Extern 4 (@Morphism _ _ _) => partial_application_tactic : typeclass_instances.
+Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances.
 
 Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B),
   relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R').
@@ -387,7 +413,7 @@ Qed.
 
 (** Special-purpose class to do normalization of signatures w.r.t. inverse. *)
 
-Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := 
+Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop :=
   normalizes : relation_equivalence m m'.
 
 (** Current strategy: add [inverse] everywhere and reduce using [subrelation]
@@ -400,19 +426,19 @@ Qed.
 
 Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) :
   Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature).
-Proof. unfold Normalizes. intros.
+Proof. unfold Normalizes in *. intros.
   rewrite NA, NB. firstorder.
 Qed.
 
-Ltac inverse :=   
+Ltac inverse :=
   match goal with
-    | [ |- Normalizes _ (respectful _ _) _ ] => eapply @inverse_arrow
-    | _ => eapply @inverse_atom
+    | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow
+    | _ => class_apply @inverse_atom
   end.
 
 Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances.
 
-(** Treating inverse: can't make them direct instances as we 
+(** Treating inverse: can't make them direct instances as we
    need at least a [flip] present in the goal. *)
 
 Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R.
@@ -421,18 +447,25 @@ Proof. firstorder. Qed.
 Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')).
 Proof. firstorder. Qed.
 
-Hint Extern 1 (subrelation (flip _) _) => eapply @inverse1 : typeclass_instances.
-Hint Extern 1 (subrelation _ (flip _)) => eapply @inverse2 : typeclass_instances.
+Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances.
+Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances.
+
+(** That's if and only if *)
+
+Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R.
+Proof. simpl_relation. Qed.
+
+(* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *)
 
 (** Once we have normalized, we will apply this instance to simplify the problem. *)
 
-Definition morphism_inverse_morphism `(mor : Morphism A R m) : Morphism (inverse R) m := mor.
+Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor.
 
-Hint Extern 2 (@Morphism _ (flip _) _) => eapply @morphism_inverse_morphism : typeclass_instances.
+Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances.
 
 (** Bootstrap !!! *)
 
-Instance morphism_morphism : Morphism (relation_equivalence ==> @eq _ ==> iff) (@Morphism A).
+Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A).
 Proof.
   simpl_relation.
   reduce in H.
@@ -443,37 +476,139 @@ Proof.
   apply H0.
 Qed.
 
-Lemma morphism_releq_morphism `(Normalizes A R R', Morphism _ R' m) : Morphism R m.
+Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m.
 Proof.
-  intros.
-
-  pose respect as r.
-  pose normalizes as norm.
-  setoid_rewrite norm.
+  red in H, H0.
+  setoid_rewrite H.
   assumption.
 Qed.
 
-Ltac morphism_normalization := 
+Ltac proper_normalization :=
   match goal with
-    | [ _ : subrelation_done |- _ ] => fail 1
     | [ _ : normalization_done |- _ ] => fail 1
-    | [ |- @Morphism _ _ _ ] => let H := fresh "H" in
-      set(H:=did_normalization) ; eapply @morphism_releq_morphism
+    | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in
+      set(H:=did_normalization) ; class_apply @proper_normalizes_proper
   end.
 
-Hint Extern 6 (@Morphism _ _ _) => morphism_normalization : typeclass_instances.
+Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances.
 
 (** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *)
 
-Lemma reflexive_morphism `{Reflexive A R} (x : A)
-   : Morphism R x.
+Lemma reflexive_proper `{Reflexive A R} (x : A)
+   : Proper R x.
 Proof. firstorder. Qed.
 
-Ltac morphism_reflexive :=
+Lemma proper_eq A (x : A) : Proper (@eq A) x.
+Proof. intros. apply reflexive_proper. Qed.
+
+Ltac proper_reflexive :=
   match goal with
     | [ _ : normalization_done |- _ ] => fail 1
-    | [ _ : subrelation_done |- _ ] => fail 1
-    | [ |- @Morphism _ _ _ ] => eapply @reflexive_morphism
+    | _ => class_apply proper_eq || class_apply @reflexive_proper
   end.
 
-Hint Extern 7 (@Morphism _ _ _) => morphism_reflexive : typeclass_instances.
+Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances.
+
+
+(** When the relation on the domain is symmetric, we can
+    inverse the relation on the codomain. Same for binary functions. *)
+
+Lemma proper_sym_flip :
+ forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f),
+ Proper (R1==>inverse R2) f.
+Proof.
+intros A R1 Sym B R2 f Hf.
+intros x x' Hxx'. apply Hf, Sym, Hxx'.
+Qed.
+
+Lemma proper_sym_flip_2 :
+ forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f),
+ Proper (R1==>R2==>inverse R3) f.
+Proof.
+intros A R1 Sym1 B R2 Sym2 C R3 f Hf.
+intros x x' Hxx' y y' Hyy'. apply Hf; auto.
+Qed.
+
+(** When the relation on the domain is symmetric, a predicate is
+  compatible with [iff] as soon as it is compatible with [impl].
+  Same with a binary relation. *)
+
+Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f),
+ Proper (R==>iff) f.
+Proof.
+intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto.
+Qed.
+
+Lemma proper_sym_impl_iff_2 :
+ forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f),
+ Proper (R==>R'==>iff) f.
+Proof.
+intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'.
+repeat red in Hf. split; eauto.
+Qed.
+
+(** A [PartialOrder] is compatible with its underlying equivalence. *)
+
+Instance PartialOrder_proper `(PartialOrder A eqA R) :
+  Proper (eqA==>eqA==>iff) R.
+Proof.
+intros.
+apply proper_sym_impl_iff_2; auto with *.
+intros x x' Hx y y' Hy Hr.
+transitivity x.
+generalize (partial_order_equivalence x x'); compute; intuition.
+transitivity y; auto.
+generalize (partial_order_equivalence y y'); compute; intuition.
+Qed.
+
+(** From a [PartialOrder] to the corresponding [StrictOrder]:
+     [lt = le /\ ~eq].
+    If the order is total, we could also say [gt = ~le]. *)
+
+Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) :
+  StrictOrder (relation_conjunction R (complement eqA)).
+Proof.
+split; compute.
+intros x (_,Hx). apply Hx, Equivalence_Reflexive.
+intros x y z (Hxy,Hxy') (Hyz,Hyz'). split.
+apply PreOrder_Transitive with y; assumption.
+intro Hxz.
+apply Hxy'.
+apply partial_order_antisym; auto.
+rewrite Hxz; auto.
+Qed.
+
+Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => 
+  class_apply PartialOrder_StrictOrder : typeclass_instances.
+
+(** From a [StrictOrder] to the corresponding [PartialOrder]:
+     [le = lt \/ eq].
+    If the order is total, we could also say [ge = ~lt]. *)
+
+Lemma StrictOrder_PreOrder
+ `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) :
+ PreOrder (relation_disjunction R eqA).
+Proof.
+split.
+intros x. right. reflexivity.
+intros x y z [Hxy|Hxy] [Hyz|Hyz].
+left. transitivity y; auto.
+left. rewrite <- Hyz; auto.
+left. rewrite Hxy; auto.
+right. transitivity y; auto.
+Qed.
+
+Hint Extern 4 (PreOrder (relation_disjunction _ _)) => 
+  class_apply StrictOrder_PreOrder : typeclass_instances.
+
+Lemma StrictOrder_PartialOrder
+  `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) :
+  PartialOrder eqA (relation_disjunction R eqA).
+Proof.
+intros. intros x y. compute. intuition.
+elim (StrictOrder_Irreflexive x).
+transitivity y; auto.
+Qed.
+
+Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => 
+  class_apply StrictOrder_PartialOrder : typeclass_instances.
diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v
index 3bbd56cf..2dc033d2 100644
--- a/theories/Classes/Morphisms_Prop.v
+++ b/theories/Classes/Morphisms_Prop.v
@@ -6,81 +6,83 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Morphism instances for propositional connectives.
- 
+(** * [Proper] instances for propositional connectives.
+
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
 Require Import Coq.Classes.Morphisms.
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
 
+Local Obligation Tactic := simpl_relation.
+
 (** Standard instances for [not], [iff] and [impl]. *)
 
 (** Logical negation. *)
 
 Program Instance not_impl_morphism :
-  Morphism (impl --> impl) not.
+  Proper (impl --> impl) not | 1.
 
-Program Instance not_iff_morphism : 
-  Morphism (iff ++> iff) not.
+Program Instance not_iff_morphism :
+  Proper (iff ++> iff) not.
 
 (** Logical conjunction. *)
 
 Program Instance and_impl_morphism :
-  Morphism (impl ==> impl ==> impl) and.
+  Proper (impl ==> impl ==> impl) and | 1.
 
-Program Instance and_iff_morphism : 
-  Morphism (iff ==> iff ==> iff) and.
+Program Instance and_iff_morphism :
+  Proper (iff ==> iff ==> iff) and.
 
 (** Logical disjunction. *)
 
-Program Instance or_impl_morphism : 
-  Morphism (impl ==> impl ==> impl) or.
+Program Instance or_impl_morphism :
+  Proper (impl ==> impl ==> impl) or | 1.
 
-Program Instance or_iff_morphism : 
-  Morphism (iff ==> iff ==> iff) or.
+Program Instance or_iff_morphism :
+  Proper (iff ==> iff ==> iff) or.
 
 (** Logical implication [impl] is a morphism for logical equivalence. *)
 
-Program Instance iff_iff_iff_impl_morphism : Morphism (iff ==> iff ==> iff) impl.
+Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl.
 
 (** Morphisms for quantifiers *)
 
-Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation A iff ==> iff) (@ex A).
+Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A).
 
   Next Obligation.
   Proof.
-    unfold pointwise_relation in H.     
+    unfold pointwise_relation in H.
     split ; intros.
-    destruct H0 as [x� H�].
-    exists x�. rewrite H in H�. assumption.
-    
-    destruct H0 as [x� H�].
-    exists x�. rewrite H. assumption.
+    destruct H0 as [x1 H1].
+    exists x1. rewrite H in H1. assumption.
+
+    destruct H0 as [x1 H1].
+    exists x1. rewrite H. assumption.
   Qed.
 
 Program Instance ex_impl_morphism {A : Type} :
-  Morphism (pointwise_relation A impl ==> impl) (@ex A).
+  Proper (pointwise_relation A impl ==> impl) (@ex A) | 1.
 
   Next Obligation.
   Proof.
-    unfold pointwise_relation in H.  
+    unfold pointwise_relation in H.
     exists H0. apply H. assumption.
   Qed.
 
-Program Instance ex_inverse_impl_morphism {A : Type} : 
-  Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A).
+Program Instance ex_inverse_impl_morphism {A : Type} :
+  Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1.
 
   Next Obligation.
   Proof.
-    unfold pointwise_relation in H.  
+    unfold pointwise_relation in H.
     exists H0. apply H. assumption.
   Qed.
 
-Program Instance all_iff_morphism {A : Type} : 
-  Morphism (pointwise_relation A iff ==> iff) (@all A).
+Program Instance all_iff_morphism {A : Type} :
+  Proper (pointwise_relation A iff ==> iff) (@all A).
 
   Next Obligation.
   Proof.
@@ -88,18 +90,18 @@ Program Instance all_iff_morphism {A : Type} :
     intuition ; specialize (H x0) ; intuition.
   Qed.
 
-Program Instance all_impl_morphism {A : Type} : 
-  Morphism (pointwise_relation A impl ==> impl) (@all A).
-  
+Program Instance all_impl_morphism {A : Type} :
+  Proper (pointwise_relation A impl ==> impl) (@all A) | 1.
+
   Next Obligation.
   Proof.
     unfold pointwise_relation, all in *.
     intuition ; specialize (H x0) ; intuition.
   Qed.
 
-Program Instance all_inverse_impl_morphism {A : Type} : 
-  Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@all A).
-  
+Program Instance all_inverse_impl_morphism {A : Type} :
+  Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1.
+
   Next Obligation.
   Proof.
     unfold pointwise_relation, all in *.
diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v
index 4654e654..d8365abc 100644
--- a/theories/Classes/Morphisms_Relations.v
+++ b/theories/Classes/Morphisms_Relations.v
@@ -6,23 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Morphism instances for relations.
- 
+(** * Morphism instances for relations.
+
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
 Require Import Relation_Definitions.
 Require Import Coq.Classes.Morphisms.
 Require Import Coq.Program.Program.
 
+Generalizable Variables A l.
+
 (** Morphisms for relations *)
 
-Instance relation_conjunction_morphism : Morphism (relation_equivalence (A:=A) ==>
+Instance relation_conjunction_morphism : Proper (relation_equivalence (A:=A) ==>
   relation_equivalence ==> relation_equivalence) relation_conjunction.
   Proof. firstorder. Qed.
 
-Instance relation_disjunction_morphism : Morphism (relation_equivalence (A:=A) ==>
+Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==>
   relation_equivalence ==> relation_equivalence) relation_disjunction.
   Proof. firstorder. Qed.
 
@@ -31,25 +33,25 @@ Instance relation_disjunction_morphism : Morphism (relation_equivalence (A:=A) =
 Require Import List.
 
 Lemma predicate_equivalence_pointwise (l : list Type) :
-  Morphism (@predicate_equivalence l ==> pointwise_lifting iff l) id.
+  Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id.
 Proof. do 2 red. unfold predicate_equivalence. auto. Qed.
 
 Lemma predicate_implication_pointwise (l : list Type) :
-  Morphism (@predicate_implication l ==> pointwise_lifting impl l) id.
+  Proper (@predicate_implication l ==> pointwise_lifting impl l) id.
 Proof. do 2 red. unfold predicate_implication. auto. Qed.
 
-(** The instanciation at relation allows to rewrite applications of relations [R x y] to [R' x y] *)
-(*    when [R] and [R'] are in [relation_equivalence]. *)
+(** The instanciation at relation allows to rewrite applications of relations
+    [R x y] to [R' x y]  when [R] and [R'] are in [relation_equivalence]. *)
 
 Instance relation_equivalence_pointwise :
-  Morphism (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id.
+  Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id.
 Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed.
 
 Instance subrelation_pointwise :
-  Morphism (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id.
+  Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id.
 Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed.
 
 
-Lemma inverse_pointwise_relation A (R : relation A) : 
+Lemma inverse_pointwise_relation A (R : relation A) :
   relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)).
 Proof. intros. split; firstorder. Qed.
diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v
index e1de9ee9..9b848551 100644
--- a/theories/Classes/RelationClasses.v
+++ b/theories/Classes/RelationClasses.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,14 +7,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Typeclass-based relations, tactics and standard instances.
+(** *  Typeclass-based relations, tactics and standard instances
+
    This is the basic theory needed to formalize morphisms and setoids.
- 
+
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
-(* $Id: RelationClasses.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 Require Export Coq.Classes.Init.
 Require Import Coq.Program.Basics.
@@ -42,16 +44,18 @@ Unset Strict Implicit.
 Class Reflexive {A} (R : relation A) :=
   reflexivity : forall x, R x x.
 
-Class Irreflexive {A} (R : relation A) := 
-  irreflexivity :> Reflexive (complement R).
+Class Irreflexive {A} (R : relation A) :=
+  irreflexivity : Reflexive (complement R).
 
-Class Symmetric {A} (R : relation A) := 
+Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.
+
+Class Symmetric {A} (R : relation A) :=
   symmetry : forall x y, R x y -> R y x.
 
-Class Asymmetric {A} (R : relation A) := 
+Class Asymmetric {A} (R : relation A) :=
   asymmetry : forall x y, R x y -> R y x -> False.
 
-Class Transitive {A} (R : relation A) := 
+Class Transitive {A} (R : relation A) :=
   transitivity : forall x y z, R x y -> R y z -> R x z.
 
 Hint Resolve @irreflexivity : ord.
@@ -61,7 +65,7 @@ Unset Implicit Arguments.
 (** A HintDb for relations. *)
 
 Ltac solve_relation :=
-  match goal with 
+  match goal with
   | [ |- ?R ?x ?x ] => reflexivity
   | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H
   end.
@@ -70,34 +74,39 @@ Hint Extern 4 => solve_relation : relations.
 
 (** We can already dualize all these properties. *)
 
-Program Instance flip_Reflexive `(Reflexive A R) : Reflexive (flip R) :=
-  reflexivity (R:=R).
+Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.
 
-Program Instance flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) :=
-  irreflexivity (R:=R).
+Program Lemma flip_Reflexive `(Reflexive A R) : Reflexive (flip R).
+Proof. tauto. Qed.
+
+Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
 
-Program Instance flip_Symmetric `(Symmetric A R) : Symmetric (flip R).
+Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) :=
+  irreflexivity (R:=R).
 
-  Solve Obligations using unfold flip ; intros ; tcapp symmetry ; assumption.
+Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) :=
+  fun x y H => symmetry (R:=R) H.
 
-Program Instance flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R).
-  
-  Solve Obligations using program_simpl ; unfold flip in * ; intros ; typeclass_app asymmetry ; eauto.
+Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) :=
+  fun x y H H' => asymmetry (R:=R) H H'.
 
-Program Instance flip_Transitive `(Transitive A R) : Transitive (flip R).
+Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) :=
+  fun x y z H H' => transitivity (R:=R) H' H.
 
-  Solve Obligations using unfold flip ; program_simpl ; typeclass_app transitivity ; eauto.
+Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
+Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
+Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
+Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.
 
-Program Instance Reflexive_complement_Irreflexive `(Reflexive A (R : relation A))
+Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A))
    : Irreflexive (complement R).
+Proof. firstorder. Qed.
 
-  Next Obligation. 
-  Proof. firstorder. Qed.
-
-Program Instance complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R).
+Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R).
+Proof. firstorder. Qed.
 
-  Next Obligation.
-  Proof. firstorder. Qed.
+Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
+Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances.
 
 (** * Standard instances. *)
 
@@ -117,7 +126,7 @@ Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid.
 
 Ltac reduce := reduce_goal.
 
-Tactic Notation "apply" "*" constr(t) := 
+Tactic Notation "apply" "*" constr(t) :=
   first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) |
     refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ].
 
@@ -125,7 +134,7 @@ Ltac simpl_relation :=
   unfold flip, impl, arrow ; try reduce ; program_simpl ;
     try ( solve [ intuition ]).
 
-Ltac obligation_tactic ::= simpl_relation.
+Local Obligation Tactic := simpl_relation.
 
 (** Logical implication. *)
 
@@ -174,13 +183,14 @@ Instance Equivalence_PER `(Equivalence A R) : PER R | 10 :=
 (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *)
 
 Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) :=
-  antisymmetry : forall x y, R x y -> R y x -> eqA x y.
+  antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.
 
-Program Instance flip_antiSymmetric `(Antisymmetric A eqA R) :
-  ! Antisymmetric A eqA (flip R).
+Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) :
+  Antisymmetric A eqA (flip R).
+Proof. firstorder. Qed.
 
 (** Leibinz equality [eq] is an equivalence relation.
-   The instance has low priority as it is always applicable 
+   The instance has low priority as it is always applicable
    if only the type is constrained. *)
 
 Program Instance eq_equivalence : Equivalence (@eq A) | 10.
@@ -193,26 +203,24 @@ Program Instance iff_equivalence : Equivalence iff.
    The resulting theory can be applied to homogeneous binary relations but also to
    arbitrary n-ary predicates. *)
 
-Require Import Coq.Lists.List.
+Local Open Scope list_scope.
 
 (* Notation " [ ] " := nil : list_scope. *)
 (* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *)
 
-(* Open Local Scope list_scope. *)
-
 (** A compact representation of non-dependent arities, with the codomain singled-out. *)
 
-Fixpoint arrows (l : list Type) (r : Type) : Type := 
-  match l with 
+Fixpoint arrows (l : list Type) (r : Type) : Type :=
+  match l with
     | nil => r
     | A :: l' => A -> arrows l' r
   end.
 
 (** We can define abbreviations for operation and relation types based on [arrows]. *)
 
-Definition unary_operation A := arrows (cons A nil) A.
-Definition binary_operation A := arrows (cons A (cons A nil)) A.
-Definition ternary_operation A := arrows (cons A (cons A (cons A nil))) A.
+Definition unary_operation A := arrows (A::nil) A.
+Definition binary_operation A := arrows (A::A::nil) A.
+Definition ternary_operation A := arrows (A::A::A::nil) A.
 
 (** We define n-ary [predicate]s as functions into [Prop]. *)
 
@@ -220,13 +228,13 @@ Notation predicate l := (arrows l Prop).
 
 (** Unary predicates, or sets. *)
 
-Definition unary_predicate A := predicate (cons A nil).
+Definition unary_predicate A := predicate (A::nil).
 
 (** Homogeneous binary relations, equivalent to [relation A]. *)
 
-Definition binary_relation A := predicate (cons A (cons A nil)).
+Definition binary_relation A := predicate (A::A::nil).
 
-(** We can close a predicate by universal or existential quantification. *) 
+(** We can close a predicate by universal or existential quantification. *)
 
 Fixpoint predicate_all (l : list Type) : predicate l -> Prop :=
   match l with
@@ -240,7 +248,7 @@ Fixpoint predicate_exists (l : list Type) : predicate l -> Prop :=
     | A :: tl => fun f => exists x : A, predicate_exists tl (f x)
   end.
 
-(** Pointwise extension of a binary operation on [T] to a binary operation 
+(** Pointwise extension of a binary operation on [T] to a binary operation
    on functions whose codomain is [T].
    For an operator on [Prop] this lifts the operator to a binary operation. *)
 
@@ -248,7 +256,7 @@ Fixpoint pointwise_extension {T : Type} (op : binary_operation T)
   (l : list Type) : binary_operation (arrows l T) :=
   match l with
     | nil => fun R R' => op R R'
-    | A :: tl => fun R R' => 
+    | A :: tl => fun R R' =>
       fun x => pointwise_extension op tl (R x) (R' x)
   end.
 
@@ -257,7 +265,7 @@ Fixpoint pointwise_extension {T : Type} (op : binary_operation T)
 Fixpoint pointwise_lifting (op : binary_relation Prop)  (l : list Type) : binary_relation (predicate l) :=
   match l with
     | nil => fun R R' => op R R'
-    | A :: tl => fun R R' => 
+    | A :: tl => fun R R' =>
       forall x, pointwise_lifting op tl (R x) (R' x)
   end.
 
@@ -289,7 +297,7 @@ Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_
 
 (** The always [True] and always [False] predicates. *)
 
-Fixpoint true_predicate {l : list Type} : predicate l := 
+Fixpoint true_predicate {l : list Type} : predicate l :=
   match l with
     | nil => True
     | A :: tl => fun _ => @true_predicate tl
@@ -306,17 +314,13 @@ Notation "∙⊥∙" := false_predicate : predicate_scope.
 
 (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *)
 
-Program Instance predicate_equivalence_equivalence :
-  Equivalence (@predicate_equivalence l).
-
+Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l).
   Next Obligation.
     induction l ; firstorder.
   Qed.
-
   Next Obligation.
     induction l ; firstorder.
   Qed.
-  
   Next Obligation.
     fold pointwise_lifting.
     induction l. firstorder.
@@ -326,59 +330,59 @@ Program Instance predicate_equivalence_equivalence :
 
 Program Instance predicate_implication_preorder :
   PreOrder (@predicate_implication l).
-
   Next Obligation.
     induction l ; firstorder.
   Qed.
-
   Next Obligation.
     induction l. firstorder.
-    unfold predicate_implication in *. simpl in *. 
+    unfold predicate_implication in *. simpl in *.
     intro. pose (IHl (x x0) (y x0) (z x0)). firstorder.
   Qed.
 
-(** We define the various operations which define the algebra on binary relations, 
+(** We define the various operations which define the algebra on binary relations,
    from the general ones. *)
 
 Definition relation_equivalence {A : Type} : relation (relation A) :=
-  @predicate_equivalence (cons _ (cons _ nil)).
+  @predicate_equivalence (_::_::nil).
 
 Class subrelation {A:Type} (R R' : relation A) : Prop :=
-  is_subrelation : @predicate_implication (cons A (cons A nil)) R R'.
+  is_subrelation : @predicate_implication (A::A::nil) R R'.
 
 Implicit Arguments subrelation [[A]].
 
 Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A :=
-  @predicate_intersection (cons A (cons A nil)) R R'.
+  @predicate_intersection (A::A::nil) R R'.
 
 Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A :=
-  @predicate_union (cons A (cons A nil)) R R'.
+  @predicate_union (A::A::nil) R R'.
 
 (** Relation equivalence is an equivalence, and subrelation defines a partial order. *)
 
+Set Automatic Introduction.
+
 Instance relation_equivalence_equivalence (A : Type) :
   Equivalence (@relation_equivalence A).
-Proof. intro A. exact (@predicate_equivalence_equivalence (cons A (cons A nil))). Qed.
+Proof. exact (@predicate_equivalence_equivalence (A::A::nil)). Qed.
 
-Instance relation_implication_preorder : PreOrder (@subrelation A).
-Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Qed.
+Instance relation_implication_preorder A : PreOrder (@subrelation A).
+Proof. exact (@predicate_implication_preorder (A::A::nil)). Qed.
 
 (** *** Partial Order.
    A partial order is a preorder which is additionally antisymmetric.
-   We give an equivalent definition, up-to an equivalence relation 
+   We give an equivalent definition, up-to an equivalence relation
    on the carrier. *)
 
 Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
   partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)).
 
-(** The equivalence proof is sufficient for proving that [R] must be a morphism 
+(** The equivalence proof is sufficient for proving that [R] must be a morphism
    for equivalence (see Morphisms).
    It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *)
 
 Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R.
 Proof with auto.
-  reduce_goal. 
-  pose proof partial_order_equivalence as poe. do 3 red in poe. 
+  reduce_goal.
+  pose proof partial_order_equivalence as poe. do 3 red in poe.
   apply <- poe. firstorder.
 Qed.
 
@@ -392,5 +396,52 @@ Program Instance subrelation_partial_order :
     unfold relation_equivalence in *. firstorder.
   Qed.
 
-Typeclasses Opaque arrows predicate_implication predicate_equivalence 
+Typeclasses Opaque arrows predicate_implication predicate_equivalence
   relation_equivalence pointwise_lifting.
+
+(** Rewrite relation on a given support: declares a relation as a rewrite
+   relation for use by the generalized rewriting tactic.
+   It helps choosing if a rewrite should be handled
+   by the generalized or the regular rewriting tactic using leibniz equality.
+   Users can declare an [RewriteRelation A RA] anywhere to declare default
+   relations. This is also done automatically by the [Declare Relation A RA]
+   commands. *)
+
+Class RewriteRelation {A : Type} (RA : relation A).
+
+Instance: RewriteRelation impl.
+Instance: RewriteRelation iff.
+Instance: RewriteRelation (@relation_equivalence A).
+
+(** Any [Equivalence] declared in the context is automatically considered
+   a rewrite relation. *)
+
+Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA.
+
+(** Strict Order *)
+
+Class StrictOrder {A : Type} (R : relation A) := {
+  StrictOrder_Irreflexive :> Irreflexive R ;
+  StrictOrder_Transitive :> Transitive R
+}.
+
+Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R.
+Proof. firstorder. Qed.
+
+(** Inversing a [StrictOrder] gives another [StrictOrder] *)
+
+Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R).
+Proof. firstorder. Qed.
+
+(** Same for [PartialOrder]. *)
+
+Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R).
+Proof. firstorder. Qed.
+
+Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances.
+Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances.
+
+Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R).
+Proof. firstorder. Qed.
+
+Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances.
diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v
new file mode 100644
index 00000000..7972c96c
--- /dev/null
+++ b/theories/Classes/RelationPairs.v
@@ -0,0 +1,153 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** * Relations over pairs *)
+
+
+Require Import Relations Morphisms.
+
+(* NB: This should be system-wide someday, but for that we need to
+    fix the simpl tactic, since "simpl fst" would be refused for
+    the moment.
+
+Implicit Arguments fst [[A] [B]].
+Implicit Arguments snd [[A] [B]].
+Implicit Arguments pair [[A] [B]].
+
+/NB *)
+
+Local Notation Fst := (@fst _ _).
+Local Notation Snd := (@snd _ _).
+
+Arguments Scope relation_conjunction
+ [type_scope signature_scope signature_scope].
+Arguments Scope relation_equivalence
+ [type_scope signature_scope signature_scope].
+Arguments Scope subrelation [type_scope signature_scope signature_scope].
+Arguments Scope Reflexive [type_scope signature_scope].
+Arguments Scope Irreflexive [type_scope signature_scope].
+Arguments Scope Symmetric [type_scope signature_scope].
+Arguments Scope Transitive [type_scope signature_scope].
+Arguments Scope PER [type_scope signature_scope].
+Arguments Scope Equivalence [type_scope signature_scope].
+Arguments Scope StrictOrder [type_scope signature_scope].
+
+Generalizable Variables A B RA RB Ri Ro f.
+
+(** Any function from [A] to [B] allow to obtain a relation over [A]
+    out of a relation over [B]. *)
+
+Definition RelCompFun {A B}(R:relation B)(f:A->B) : relation A :=
+ fun a a' => R (f a) (f a').
+
+Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope.
+
+Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope.
+Notation "R @@2" := (R @@ Snd)%signature (at level 30) : signature_scope.
+
+(** We declare measures to the system using the [Measure] class.
+   Otherwise the instances would easily introduce loops,
+   never instantiating the [f] function.  *)
+
+Class Measure {A B} (f : A -> B).
+
+(** Standard measures. *)
+
+Instance fst_measure : @Measure (A * B) A Fst.
+Instance snd_measure : @Measure (A * B) B Snd.
+
+(** We define a product relation over [A*B]: each components should
+    satisfy the corresponding initial relation. *)
+
+Definition RelProd {A B}(RA:relation A)(RB:relation B) : relation (A*B) :=
+ relation_conjunction (RA @@1) (RB @@2).
+
+Infix "*" := RelProd : signature_scope.
+
+Section RelCompFun_Instances.
+  Context {A B : Type} (R : relation B).
+
+  Global Instance RelCompFun_Reflexive
+    `(Measure A B f, Reflexive _ R) : Reflexive (R@@f).
+  Proof. firstorder. Qed.
+
+  Global Instance RelCompFun_Symmetric
+    `(Measure A B f, Symmetric _ R) : Symmetric (R@@f).
+  Proof. firstorder. Qed.
+
+  Global Instance RelCompFun_Transitive
+    `(Measure A B f, Transitive _ R) : Transitive (R@@f).
+  Proof. firstorder. Qed.
+
+  Global Instance RelCompFun_Irreflexive
+    `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f).
+  Proof. firstorder. Qed.
+
+  Global Instance RelCompFun_Equivalence
+    `(Measure A B f, Equivalence _ R) : Equivalence (R@@f).
+
+  Global Instance RelCompFun_StrictOrder
+    `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f).
+
+End RelCompFun_Instances.
+
+Instance RelProd_Reflexive {A B}(RA:relation A)(RB:relation B)
+ `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB).
+Proof. firstorder. Qed.
+
+Instance RelProd_Symmetric {A B}(RA:relation A)(RB:relation B)
+ `(Symmetric _ RA, Symmetric _ RB) : Symmetric (RA*RB).
+Proof. firstorder. Qed.
+
+Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B)
+ `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB).
+Proof. firstorder. Qed.
+
+Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B)
+ `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).
+
+Lemma FstRel_ProdRel {A B}(RA:relation A) :
+ relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)).
+Proof. firstorder. Qed.
+
+Lemma SndRel_ProdRel {A B}(RB:relation B) :
+ relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB).
+Proof. firstorder. Qed.
+
+Instance FstRel_sub {A B} (RA:relation A)(RB:relation B):
+ subrelation (RA*RB) (RA @@1).
+Proof. firstorder. Qed.
+
+Instance SndRel_sub {A B} (RA:relation A)(RB:relation B):
+ subrelation (RA*RB) (RB @@2).
+Proof. firstorder. Qed.
+
+Instance pair_compat { A B } (RA:relation A)(RB:relation B) :
+ Proper (RA==>RB==> RA*RB) (@pair _ _).
+Proof. firstorder. Qed.
+
+Instance fst_compat { A B } (RA:relation A)(RB:relation B) :
+ Proper (RA*RB ==> RA) Fst.
+Proof.
+intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
+Qed.
+
+Instance snd_compat { A B } (RA:relation A)(RB:relation B) :
+ Proper (RA*RB ==> RB) Snd.
+Proof.
+intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
+Qed.
+
+Instance RelCompFun_compat {A B}(f:A->B)(R : relation B)
+ `(Proper _ (Ri==>Ri==>Ro) R) :
+ Proper (Ri@@f==>Ri@@f==>Ro) (R@@f)%signature.
+Proof. unfold RelCompFun; firstorder. Qed.
+
+Hint Unfold RelProd RelCompFun.
+Hint Extern 2 (RelProd _ _ _ _) => split.
+
diff --git a/theories/Classes/SetoidAxioms.v b/theories/Classes/SetoidAxioms.v
deleted file mode 100644
index 03bb9a80..00000000
--- a/theories/Classes/SetoidAxioms.v
+++ /dev/null
@@ -1,34 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Extensionality axioms that can be used when reasoning with setoids.
- *
- * Author: Matthieu Sozeau
- * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
- *              91405 Orsay, France *)
-
-(* $Id: SetoidAxioms.v 12083 2009-04-14 07:22:18Z herbelin $ *)
-
-Require Import Coq.Program.Program.
-
-Set Implicit Arguments.
-Unset Strict Implicit.
-
-Require Export Coq.Classes.SetoidClass.
-
-(* Application of the extensionality axiom to turn a goal on 
-   Leibniz equality to a setoid equivalence (use with care!). *)
-
-Axiom setoideq_eq : forall `{sa : Setoid a} (x y : a), x == y -> x = y.
-
-(** Application of the extensionality principle for setoids. *)
-
-Ltac setoid_extensionality :=
-  match goal with
-    [ |- @eq ?A ?X ?Y ] => apply (setoideq_eq (a:=A) (x:=X) (y:=Y))
-  end.
diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v
index d3da7d5a..c41c5769 100644
--- a/theories/Classes/SetoidClass.v
+++ b/theories/Classes/SetoidClass.v
@@ -6,23 +6,24 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Typeclass-based setoids, tactics and standard instances.
- 
+(** * Typeclass-based setoids, tactics and standard instances.
+
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
-(* $Id: SetoidClass.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+Generalizable Variables A.
+
 Require Import Coq.Program.Program.
 
 Require Import Relation_Definitions.
 Require Export Coq.Classes.RelationClasses.
 Require Export Coq.Classes.Morphisms.
-Require Import Coq.Classes.Functions.
 
 (** A setoid wraps an equivalence. *)
 
@@ -55,7 +56,7 @@ Existing Instance setoid_trans.
 (* Program Instance eq_setoid : Setoid A := *)
 (*   equiv := eq ; setoid_equiv := eq_equivalence. *)
 
-Program Instance iff_setoid : Setoid Prop := 
+Program Instance iff_setoid : Setoid Prop :=
   { equiv := iff ; setoid_equiv := iff_equivalence }.
 
 (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *)
@@ -69,7 +70,7 @@ Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) :
 
 (** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *)
 
-Ltac clsubst H := 
+Ltac clsubst H :=
   match type of H with
     ?x == ?y => substitute H ; clear H x
   end.
@@ -79,7 +80,7 @@ Ltac clsubst_nofail :=
     | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail
     | _ => idtac
   end.
-  
+
 (** [subst*] will try its best at substituting every equality in the goal. *)
 
 Tactic Notation "clsubst" "*" := clsubst_nofail.
@@ -94,7 +95,7 @@ Qed.
 
 Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z.
 Proof.
-  intros; intro. 
+  intros; intro.
   assert(y == x) by (symmetry ; auto).
   assert(y == z) by (transitivity x ; eauto).
   contradiction.
@@ -119,25 +120,15 @@ Ltac setoidify := repeat setoidify_tac.
 
 (** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *)
 
-Program Instance setoid_morphism `(sa : Setoid A) : Morphism (equiv ++> equiv ++> iff) equiv :=
-  respect.
-
-Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Morphism (equiv ++> iff) (equiv x) :=
-  respect.
-
-Ltac morphism_tac := try red ; unfold arrow ; intros ; program_simpl ; try tauto.
-
-Ltac obligation_tactic ::= morphism_tac.
-
-(** These are morphisms used to rewrite at the top level of a proof, 
-   using [iff_impl_id_morphism] if the proof is in [Prop] and
-   [eq_arrow_id_morphism] if it is in Type. *)
+Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv :=
+  proper_prf.
 
-Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) id.
+Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) :=
+  proper_prf.
 
 (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *)
 
-Class PartialSetoid (A : Type) := 
+Class PartialSetoid (A : Type) :=
   { pequiv : relation A ; pequiv_prf :> PER pequiv }.
 
 (** Overloaded notation for partial setoid equivalence. *)
@@ -146,4 +137,4 @@ Infix "=~=" := pequiv (at level 70, no associativity) : type_scope.
 
 (** Reset the default Program tactic. *)
 
-Ltac obligation_tactic ::= program_simpl.
+Obligation Tactic := program_simpl.
diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v
index bac64724..33b4350f 100644
--- a/theories/Classes/SetoidDec.v
+++ b/theories/Classes/SetoidDec.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,43 +7,47 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Decidable setoid equality theory.
- *
- * Author: Matthieu Sozeau
- * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
- *              91405 Orsay, France *)
+(** * Decidable setoid equality theory.
 
-(* $Id: SetoidDec.v 11800 2009-01-18 18:34:15Z msozeau $ *)
+   Author: Matthieu Sozeau
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
+
+(* $Id$ *)
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+Generalizable Variables A B .
+
 (** Export notations. *)
 
 Require Export Coq.Classes.SetoidClass.
 
-(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more 
-   classically. *)
+(** The [DecidableSetoid] class asserts decidability of a [Setoid].
+   It can be useful in proofs to reason more classically. *)
 
 Require Import Coq.Logic.Decidable.
 
 Class DecidableSetoid `(S : Setoid A) :=
   setoid_decidable : forall x y : A, decidable (x == y).
 
-(** The [EqDec] class gives a decision procedure for a particular setoid equality. *)
+(** The [EqDec] class gives a decision procedure for a particular setoid
+   equality. *)
 
 Class EqDec `(S : Setoid A) :=
   equiv_dec : forall x y : A, { x == y } + { x =/= y }.
 
-(** We define the [==] overloaded notation for deciding equality. It does not take precedence
-   of [==] defined in the type scope, hence we can have both at the same time. *)
+(** We define the [==] overloaded notation for deciding equality. It does not
+   take precedence of [==] defined in the type scope, hence we can have both
+   at the same time. *)
 
 Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70).
 
 Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
   match x with
-    | left H => @right _ _ H 
-    | right H => @left _ _ H 
+    | left H => @right _ _ H
+    | right H => @left _ _ H
   end.
 
 Require Import Coq.Program.Program.
@@ -72,7 +77,8 @@ Infix "<>b" := nequiv_decb (no associativity, at level 70).
 
 Require Import Coq.Arith.Arith.
 
-(** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *)
+(** The equiv is burried inside the setoid, but we can recover
+  it by specifying which setoid we're talking about. *)
 
 Program Instance eq_setoid A : Setoid A | 10 :=
   { equiv := eq ; setoid_equiv := eq_equivalence }.
@@ -96,16 +102,17 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) :=
 
 Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) :=
   λ x y,
-    let '(x1, x2) := x in 
-    let '(y1, y2) := y in 
-    if x1 == y1 then 
+    let '(x1, x2) := x in
+    let '(y1, y2) := y in
+    if x1 == y1 then
       if x2 == y2 then in_left
       else in_right
     else in_right.
 
   Solve Obligations using unfold complement ; program_simpl.
 
-(** Objects of function spaces with countable domains like bool have decidable equality. *)
+(** Objects of function spaces with countable domains like bool
+  have decidable equality. *)
 
 Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) : EqDec (eq_setoid (bool -> A)) :=
   λ f g,
diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v
index 36f05e31..669be8b0 100644
--- a/theories/Classes/SetoidTactics.v
+++ b/theories/Classes/SetoidTactics.v
@@ -1,4 +1,3 @@
-(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.SetoidTactics") -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -7,38 +6,28 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Tactics for typeclass-based setoids.
- *
- * Author: Matthieu Sozeau
- * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
- *              91405 Orsay, France *)
+(** * Tactics for typeclass-based setoids.
 
-(* $Id: SetoidTactics.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+   Author: Matthieu Sozeau
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
+
+(* $Id$ *)
 
 Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop.
 Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions.
 Require Import Coq.Classes.Equivalence Coq.Program.Basics.
 
-Export MorphismNotations.
+Generalizable Variables A R.
+
+Export ProperNotations.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** Setoid relation on a given support: declares a relation as a setoid
-   for use with rewrite. It helps choosing if a rewrite should be handled
-   by setoid_rewrite or the regular rewrite using leibniz equality.
-   Users can declare an [SetoidRelation A RA] anywhere to declare default 
-   relations. This is also done automatically by the [Declare Relation A RA]
-   commands. *)
-
-Class SetoidRelation A (R : relation A).
-
-Instance impl_setoid_relation : SetoidRelation impl.
-Instance iff_setoid_relation : SetoidRelation iff.
-
 (** Default relation on a given support. Can be used by tactics
-   to find a sensible default relation on any carrier. Users can 
-   declare an [Instance def : DefaultRelation A RA] anywhere to 
+   to find a sensible default relation on any carrier. Users can
+   declare an [Instance def : DefaultRelation A RA] anywhere to
    declare default relations. *)
 
 Class DefaultRelation A (R : relation A).
@@ -47,12 +36,13 @@ Class DefaultRelation A (R : relation A).
 
 Definition default_relation `{DefaultRelation A R} := R.
 
-(** Every [Equivalence] gives a default relation, if no other is given (lowest priority). *)
+(** Every [Equivalence] gives a default relation, if no other is given
+  (lowest priority). *)
 
 Instance equivalence_default `(Equivalence A R) : DefaultRelation R | 4.
 
-(** The setoid_replace tactics in Ltac, defined in terms of default relations and
-   the setoid_rewrite tactic. *)
+(** The setoid_replace tactics in Ltac, defined in terms of default relations
+  and the setoid_rewrite tactic. *)
 
 Ltac setoidreplace H t :=
   let Heq := fresh "Heq" in
@@ -73,86 +63,88 @@ Ltac setoidreplaceat H t occs :=
 Tactic Notation "setoid_replace" constr(x) "with" constr(y) :=
   setoidreplace (default_relation x y) idtac.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "at" int_or_var_list(o) :=
   setoidreplaceat (default_relation x y) idtac o.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "in" hyp(id) :=
   setoidreplacein (default_relation x y) id idtac.
 
 Tactic Notation "setoid_replace" constr(x) "with" constr(y)
-  "in" hyp(id) 
+  "in" hyp(id)
   "at" int_or_var_list(o) :=
   setoidreplaceinat (default_relation x y) id idtac o.
 
-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.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
-  "at" int_or_var_list(o) 
+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.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
-  "in" hyp(id) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
+  "in" hyp(id)
   "by" tactic3(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) 
+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.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel) :=
   setoidreplace (rel x y) idtac.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
   "at" int_or_var_list(o) :=
   setoidreplaceat (rel x y) idtac o.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
-  "using" "relation" constr(rel) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
+  "using" "relation" constr(rel)
   "by" tactic3(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)  
+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.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
   "in" hyp(id) :=
   setoidreplacein (rel x y) id idtac.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
   "using" "relation" constr(rel)
-  "in" hyp(id) 
+  "in" hyp(id)
   "at" int_or_var_list(o) :=
   setoidreplaceinat (rel x y) id idtac o.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
+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.
 
-Tactic Notation "setoid_replace" constr(x) "with" constr(y) 
-  "using" "relation" constr(rel) 
+Tactic Notation "setoid_replace" constr(x) "with" constr(y)
+  "using" "relation" constr(rel)
   "in" hyp(id)
-  "at" int_or_var_list(o)  
+  "at" int_or_var_list(o)
   "by" tactic3(t) :=
   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 proof. It essentially amounts to unfold the right amount of [respectful] calls
-   and substitute leibniz equalities. One can redefine it using [Ltac add_morphism_tactic ::= t]. *)
+(** The [add_morphism_tactic] tactic is run at each [Add Morphism]
+   command before giving the hand back to the user to discharge the
+   proof. It essentially amounts to unfold the right amount of
+   [respectful] calls and substitute leibniz equalities. One can
+   redefine it using [Ltac add_morphism_tactic ::= t]. *)
 
 Require Import Coq.Program.Tactics.
 
@@ -165,9 +157,9 @@ Ltac red_subst_eq_morphism concl :=
     | _ => idtac
   end.
 
-Ltac destruct_morphism :=
+Ltac destruct_proper :=
   match goal with
-    | [ |- @Morphism ?A ?R ?m ] => red
+    | [ |- @Proper ?A ?R ?m ] => red
   end.
 
 Ltac reverse_arrows x :=
@@ -179,11 +171,13 @@ Ltac reverse_arrows x :=
 
 Ltac default_add_morphism_tactic :=
   unfold flip ; intros ;
-  (try destruct_morphism) ;
+  (try destruct_proper) ;
   match goal with
     | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y)
   end.
 
 Ltac add_morphism_tactic := default_add_morphism_tactic.
 
-Ltac obligation_tactic ::= program_simpl.
+Obligation Tactic := program_simpl.
+
+(* Notation "'Morphism' s t " := (@Proper _ (s%signature) t) (at level 10, s at next level, t at next level). *)
diff --git a/theories/Classes/vo.itarget b/theories/Classes/vo.itarget
new file mode 100644
index 00000000..9daf133b
--- /dev/null
+++ b/theories/Classes/vo.itarget
@@ -0,0 +1,11 @@
+Equivalence.vo
+EquivDec.vo
+Init.vo
+Morphisms_Prop.vo
+Morphisms_Relations.vo
+Morphisms.vo
+RelationClasses.vo
+SetoidClass.vo
+SetoidDec.vo
+SetoidTactics.vo
+RelationPairs.vo
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
index 8cb1236e..8158324e 100644
--- a/theories/FSets/FMapAVL.v
+++ b/theories/FSets/FMapAVL.v
@@ -1,4 +1,3 @@
-
 (***********************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
 (* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
@@ -9,13 +8,13 @@
 
 (* Finite map library.  *)
 
-(* $Id: FMapAVL.v 11033 2008-06-01 22:56:50Z letouzey $ *)
+(* $Id$ *)
 
 (** * FMapAVL *)
 
 (** This module implements maps using AVL trees.
-    It follows the implementation from Ocaml's standard library. 
-    
+    It follows the implementation from Ocaml's standard library.
+
     See the comments at the beginning of FSetAVL for more details.
 *)
 
@@ -30,8 +29,8 @@ Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
 Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
 
 (** * The Raw functor
-   
-   Functor of pure functions + separate proofs of invariant 
+
+   Functor of pure functions + separate proofs of invariant
    preservation *)
 
 Module Raw (Import I:Int)(X: OrderedType).
@@ -85,20 +84,20 @@ Definition is_empty m := match m with Leaf => true | _ => false end.
     to achieve logarithmic complexity. *)
 
 Fixpoint mem x m : bool :=
-   match m with 
-     |  Leaf => false 
-     |  Node l y _ r _ => match X.compare x y with 
-             | LT _ => mem x l 
+   match m with
+     |  Leaf => false
+     |  Node l y _ r _ => match X.compare x y with
+             | LT _ => mem x l
              | EQ _ => true
              | GT _ => mem x r
          end
    end.
 
-Fixpoint find x m : option elt := 
-   match m with 
-     |  Leaf => None 
-     |  Node l y d r _ => match X.compare x y with 
-             | LT _ => find x l 
+Fixpoint find x m : option elt :=
+   match m with
+     |  Leaf => None
+     |  Node l y d r _ => match X.compare x y with
+             | LT _ => find x l
              | EQ _ => Some d
              | GT _ => find x r
          end
@@ -109,7 +108,7 @@ Fixpoint find x m : option elt :=
 (** [create l x r] creates a node, assuming [l] and [r]
     to be balanced and [|height l - height r| <= 2]. *)
 
-Definition create l x e r := 
+Definition create l x e r :=
    Node l x e r (max (height l) (height r) + 1).
 
 (** [bal l x e r] acts as [create], but performs one step of
@@ -117,45 +116,45 @@ Definition create l x e r :=
 
 Definition assert_false := create.
 
-Fixpoint bal l x d r := 
-  let hl := height l in 
+Fixpoint bal l x d r :=
+  let hl := height l in
   let hr := height r in
-  if gt_le_dec hl (hr+2) then 
-    match l with 
+  if gt_le_dec hl (hr+2) then
+    match l with
      | Leaf => assert_false l x d r
-     | Node ll lx ld lr _ => 
-       if ge_lt_dec (height ll) (height lr) then 
+     | Node ll lx ld lr _ =>
+       if ge_lt_dec (height ll) (height lr) then
          create ll lx ld (create lr x d r)
-       else 
-         match lr with 
+       else
+         match lr with
           | Leaf => assert_false l x d r
-          | Node lrl lrx lrd lrr _ => 
+          | Node lrl lrx lrd lrr _ =>
               create (create ll lx ld lrl) lrx lrd (create lrr x d r)
          end
     end
-  else 
-    if gt_le_dec hr (hl+2) then 
+  else
+    if gt_le_dec hr (hl+2) then
       match r with
        | Leaf => assert_false l x d r
        | Node rl rx rd rr _ =>
-         if ge_lt_dec (height rr) (height rl) then 
+         if ge_lt_dec (height rr) (height rl) then
             create (create l x d rl) rx rd rr
-         else 
+         else
            match rl with
             | Leaf => assert_false l x d r
-            | Node rll rlx rld rlr _ => 
-                create (create l x d rll) rlx rld (create rlr rx rd rr) 
+            | Node rll rlx rld rlr _ =>
+                create (create l x d rll) rlx rld (create rlr rx rd rr)
            end
       end
-    else 
+    else
       create l x d r.
 
 (** * Insertion *)
 
-Fixpoint add x d m := 
-  match m with 
+Fixpoint add x d m :=
+  match m with
    | Leaf => Node Leaf x d Leaf 1
-   | Node l y d' r h => 
+   | Node l y d' r h =>
       match X.compare x y with
          | LT _ => bal (add x d l) y d' r
          | EQ _ => Node l y d r h
@@ -165,16 +164,16 @@ Fixpoint add x d m :=
 
 (** * Extraction of minimum binding
 
-  Morally, [remove_min] is to be applied to a non-empty tree 
-  [t = Node l x e r h]. Since we can't deal here with [assert false] 
-  for [t=Leaf], we pre-unpack [t] (and forget about [h]). 
+  Morally, [remove_min] is to be applied to a non-empty tree
+  [t = Node l x e r h]. Since we can't deal here with [assert false]
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
 *)
- 
-Fixpoint remove_min l x d r : t*(key*elt) := 
+
+Fixpoint remove_min l x d r : t*(key*elt) :=
   match l with
     | Leaf => (r,(x,d))
-    | Node ll lx ld lr lh => 
-       let (l',m) := remove_min ll lx ld lr in 
+    | Node ll lx ld lr lh =>
+       let (l',m) := remove_min ll lx ld lr in
        (bal l' x d r, m)
   end.
 
@@ -185,18 +184,18 @@ Fixpoint remove_min l x d r : t*(key*elt) :=
   [|height t1 - height t2| <= 2].
 *)
 
-Fixpoint merge s1 s2 :=  match s1,s2 with 
-  | Leaf, _ => s2 
+Fixpoint merge s1 s2 :=  match s1,s2 with
+  | Leaf, _ => s2
   | _, Leaf => s1
-  | _, Node l2 x2 d2 r2 h2 => 
-    match remove_min l2 x2 d2 r2 with 
+  | _, Node l2 x2 d2 r2 h2 =>
+    match remove_min l2 x2 d2 r2 with
       (s2',(x,d)) => bal s1 x d s2'
     end
 end.
 
 (** * Deletion *)
 
-Fixpoint remove x m := match m with 
+Fixpoint remove x m := match m with
   | Leaf => Leaf
   | Node l y d r h =>
       match X.compare x y with
@@ -206,26 +205,26 @@ Fixpoint remove x m := match m with
       end
    end.
 
-(** * join 
-    
-    Same as [bal] but does not assume anything regarding heights of [l] 
+(** * join
+
+    Same as [bal] but does not assume anything regarding heights of [l]
     and [r].
 *)
 
 Fixpoint join l : key -> elt -> t -> t :=
   match l with
     | Leaf => add
-    | Node ll lx ld lr lh => fun x d => 
-       fix join_aux (r:t) : t := match r with 
+    | Node ll lx ld lr lh => fun x d =>
+       fix join_aux (r:t) : t := match r with
           | Leaf =>  add x d l
-          | Node rl rx rd rr rh =>  
+          | Node rl rx rd rr rh =>
                if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r)
-               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr 
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr
                else create l x d r
           end
   end.
 
-(** * Splitting 
+(** * Splitting
 
     [split x m] returns a triple [(l, o, r)] where
     - [l] is the set of elements of [m] that are [< x]
@@ -236,17 +235,17 @@ Fixpoint join l : key -> elt -> t -> t :=
 Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.
 Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
 
-Fixpoint split x m : triple := match m with 
+Fixpoint split x m : triple := match m with
   | Leaf => << Leaf, None, Leaf >>
-  | Node l y d r h => 
-     match X.compare x y with 
+  | Node l y d r h =>
+     match X.compare x y with
       | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >>
       | EQ _ => << l, Some d, r >>
       | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >>
      end
  end.
 
-(** * Concatenation 
+(** * Concatenation
 
    Same as [merge] but does not assume anything about heights.
 *)
@@ -256,7 +255,7 @@ Definition concat m1 m2 :=
       | Leaf, _ => m2
       | _ , Leaf => m1
       | _, Node l2 x2 d2 r2 _ =>
-            let (m2',xd) := remove_min l2 x2 d2 r2 in 
+            let (m2',xd) := remove_min l2 x2 d2 r2 in
             join m1 xd#1 xd#2 m2'
    end.
 
@@ -277,7 +276,7 @@ Definition elements := elements_aux nil.
 
 (** * Fold *)
 
-Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := 
+Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A :=
  fun a => match m with
   | Leaf => a
   | Node l x d r _ => fold f r (f x d (fold f l a))
@@ -293,11 +292,11 @@ Inductive enumeration :=
  | End : enumeration
  | More : key -> elt -> t -> enumeration -> enumeration.
 
-(** [cons m e] adds the elements of tree [m] on the head of 
+(** [cons m e] adds the elements of tree [m] on the head of
     enumeration [e]. *)
 
-Fixpoint cons m e : enumeration := 
- match m with 
+Fixpoint cons m e : enumeration :=
+ match m with
   | Leaf => e
   | Node l x d r h => cons l (More x d r e)
  end.
@@ -316,7 +315,7 @@ Definition equal_more x1 d1 (cont:enumeration->bool) e2 :=
 
 (** Comparison of left tree, middle element, then right tree *)
 
-Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := 
+Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
  match m1 with
   | Leaf => cont e2
   | Node l1 x1 d1 r1 _ =>
@@ -341,8 +340,8 @@ Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
 
 (** * Map *)
 
-Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := 
-  match m with 
+Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
+  match m with
    | Leaf   => Leaf _
    | Node l x d r h => Node (map f l) x (f d) (map f r) h
   end.
@@ -350,7 +349,7 @@ Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
 (* * Mapi *)
 
 Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
-  match m with 
+  match m with
    | Leaf   => Leaf _
    | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
   end.
@@ -358,28 +357,28 @@ Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
 (** * Map with removal *)
 
 Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
-  : t elt' := 
-  match m with 
+  : t elt' :=
+  match m with
    | Leaf => Leaf _
-   | Node l x d r h => 
-      match f x d with 
+   | Node l x d r h =>
+      match f x d with
        | Some d' => join (map_option f l) x d' (map_option f r)
        | None => concat (map_option f l) (map_option f r)
       end
   end.
 
 (** * Optimized map2
-  
-  Suggestion by B. Gregoire: a [map2] function with specialized 
-  arguments allowing to bypass some tree traversal. Instead of one 
-  [f0] of type [key -> option elt -> option elt' -> option elt''], 
-  we ask here for: 
+
+  Suggestion by B. Gregoire: a [map2] function with specialized
+  arguments allowing to bypass some tree traversal. Instead of one
+  [f0] of type [key -> option elt -> option elt' -> option elt''],
+  we ask here for:
   - [f] which is a specialisation of [f0] when first option isn't [None]
   - [mapl] treats a [tree elt] with [f0] when second option is [None]
   - [mapr] treats a [tree elt'] with [f0] when first option is [None]
 
-  The idea is that [mapl] and [mapr] can be instantaneous (e.g. 
-  the identity or some constant function). 
+  The idea is that [mapl] and [mapr] can be instantaneous (e.g.
+  the identity or some constant function).
 *)
 
 Section Map2_opt.
@@ -388,13 +387,13 @@ Variable f : key -> elt -> option elt' -> option elt''.
 Variable mapl : t elt -> t elt''.
 Variable mapr : t elt' -> t elt''.
 
-Fixpoint map2_opt m1 m2 := 
- match m1, m2 with 
-  | Leaf, _ => mapr m2 
+Fixpoint map2_opt m1 m2 :=
+ match m1, m2 with
+  | Leaf, _ => mapr m2
   | _, Leaf => mapl m1
-  | Node l1 x1 d1 r1 h1, _ => 
+  | Node l1 x1 d1 r1 h1, _ =>
      let (l2',o2,r2') := split x1 m2 in
-     match f x1 d1 o2 with 
+     match f x1 d1 o2 with
       | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2')
       | None => concat (map2_opt l1 l2') (map2_opt r1 r2')
      end
@@ -403,8 +402,8 @@ Fixpoint map2_opt m1 m2 :=
 End Map2_opt.
 
 (** * Map2
-    
-    The [map2] function of the Map interface can be implemented 
+
+    The [map2] function of the Map interface can be implemented
     via [map2_opt] and [map_option].
 *)
 
@@ -412,8 +411,8 @@ Section Map2.
 Variable elt elt' elt'' : Type.
 Variable f : option elt -> option elt' -> option elt''.
 
-Definition map2 : t elt -> t elt' -> t elt'' := 
- map2_opt 
+Definition map2 : t elt -> t elt' -> t elt'' :=
+ map2_opt
    (fun _ d o => f (Some d) o)
    (map_option (fun _ d => f (Some d) None))
    (map_option (fun _ d' => f None (Some d'))).
@@ -432,24 +431,24 @@ Variable elt : Type.
 Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
   | MapsRoot : forall l r h y,
       X.eq x y -> MapsTo x e (Node l y e r h)
-  | MapsLeft : forall l r h y e', 
+  | MapsLeft : forall l r h y e',
       MapsTo x e l -> MapsTo x e (Node l y e' r h)
-  | MapsRight : forall l r h y e', 
+  | MapsRight : forall l r h y e',
       MapsTo x e r -> MapsTo x e (Node l y e' r h).
 
 Inductive In (x : key) : t elt -> Prop :=
   | InRoot : forall l r h y e,
       X.eq x y -> In x (Node l y e r h)
-  | InLeft : forall l r h y e', 
+  | InLeft : forall l r h y e',
       In x l -> In x (Node l y e' r h)
-  | InRight : forall l r h y e', 
+  | InRight : forall l r h y e',
       In x r -> In x (Node l y e' r h).
 
 Definition In0 k m := exists e:elt, MapsTo k e m.
 
 (** ** Binary search trees *)
 
-(** [lt_tree x s]: all elements in [s] are smaller than [x] 
+(** [lt_tree x s]: all elements in [s] are smaller than [x]
    (resp. greater for [gt_tree]) *)
 
 Definition lt_tree x m := forall y, In y m -> X.lt y x.
@@ -459,7 +458,7 @@ Definition gt_tree x m := forall y, In y m -> X.lt x y.
 
 Inductive bst : t elt -> Prop :=
   | BSLeaf : bst (Leaf _)
-  | BSNode : forall x e l r h, bst l -> bst r -> 
+  | BSNode : forall x e l r h, bst l -> bst r ->
      lt_tree x l -> gt_tree x r -> bst (Node l x e r h).
 
 End Invariants.
@@ -474,10 +473,10 @@ Module Proofs.
 
 Functional Scheme mem_ind := Induction for mem Sort Prop.
 Functional Scheme find_ind := Induction for find Sort Prop.
-Functional Scheme bal_ind := Induction for bal Sort Prop. 
+Functional Scheme bal_ind := Induction for bal Sort Prop.
 Functional Scheme add_ind := Induction for add Sort Prop.
 Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
-Functional Scheme merge_ind := Induction for merge Sort Prop. 
+Functional Scheme merge_ind := Induction for merge Sort Prop.
 Functional Scheme remove_ind := Induction for remove Sort Prop.
 Functional Scheme concat_ind := Induction for concat Sort Prop.
 Functional Scheme split_ind := Induction for split Sort Prop.
@@ -489,24 +488,24 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop.
 Hint Constructors tree MapsTo In bst.
 Hint Unfold lt_tree gt_tree.
 
-Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) 
- "as" ident(s) :=  
+Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h)
+ "as" ident(s) :=
  set (s:=Node l x d r h) in *; clearbody s; clear l x d r h.
 
 (** A tactic for cleaning hypothesis after use of functional induction. *)
 
 Ltac clearf :=
- match goal with 
+ match goal with
   | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf
   | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf
   | _ => idtac
  end.
 
-(** A tactic to repeat [inversion_clear] on all hyps of the 
+(** A tactic to repeat [inversion_clear] on all hyps of the
     form [(f (Node ...))] *)
 
 Ltac inv f :=
-  match goal with 
+  match goal with
      | H:f (Leaf _) |- _ => inversion_clear H; inv f
      | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
      | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
@@ -518,8 +517,8 @@ Ltac inv f :=
      | _ => idtac
   end.
 
-Ltac inv_all f := 
-  match goal with 
+Ltac inv_all f :=
+  match goal with
    | H: f _ |- _ => inversion_clear H; inv f
    | H: f _ _ |- _ => inversion_clear H; inv f
    | H: f _ _ _ |- _ => inversion_clear H; inv f
@@ -529,7 +528,7 @@ Ltac inv_all f :=
 
 (** Helper tactic concerning order of elements. *)
 
-Ltac order := match goal with 
+Ltac order := match goal with
  | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
  | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
  | _ => MX.order
@@ -537,21 +536,21 @@ end.
 
 Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo).
 
-(* Function/Functional Scheme can't deal with internal fix. 
+(* Function/Functional Scheme can't deal with internal fix.
    Let's do its job by hand: *)
 
-Ltac join_tac := 
- intros l; induction l as [| ll _ lx ld lr Hlr lh]; 
+Ltac join_tac :=
+ intros l; induction l as [| ll _ lx ld lr Hlr lh];
    [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join;
-     [ | destruct (gt_le_dec lh (rh+2)); 
+     [ | destruct (gt_le_dec lh (rh+2));
        [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
-           replace (bal u v w z) 
+           replace (bal u v w z)
            with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto]
-         end 
-       | destruct (gt_le_dec rh (lh+2)); 
-         [ match goal with |- context [ bal ?u ?v ?w ?z ] => 
-             replace (bal u v w z) 
-             with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] 
+         end
+       | destruct (gt_le_dec rh (lh+2));
+         [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+             replace (bal u v w z)
+             with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto]
            end
          | ] ] ] ]; intros.
 
@@ -575,7 +574,7 @@ Proof.
 Qed.
 
 Lemma In_alt : forall k m, In0 k m <-> In k m.
-Proof. 
+Proof.
  split.
  intros (e,H); eauto.
  unfold In0; apply In_MapsTo; auto.
@@ -588,14 +587,14 @@ Proof.
 Qed.
 Hint Immediate MapsTo_1.
 
-Lemma In_1 : 
+Lemma In_1 :
  forall m x y, X.eq x y -> In x m -> In y m.
 Proof.
  intros m x y; induction m; simpl; intuition_in; eauto.
 Qed.
 
-Lemma In_node_iff : 
- forall l x e r h y, 
+Lemma In_node_iff :
+ forall l x e r h y,
   In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r.
 Proof.
  intuition_in.
@@ -613,7 +612,7 @@ Proof.
   unfold gt_tree in |- *; intros; intuition_in.
 Qed.
 
-Lemma lt_tree_node : forall x y l r e h, 
+Lemma lt_tree_node : forall x y l r e h,
  lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h).
 Proof.
  unfold lt_tree in *; intuition_in; order.
@@ -627,25 +626,25 @@ Qed.
 
 Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
 
-Lemma lt_left : forall x y l r e h, 
+Lemma lt_left : forall x y l r e h,
  lt_tree x (Node l y e r h) -> lt_tree x l.
 Proof.
  intuition_in.
 Qed.
 
-Lemma lt_right : forall x y l r e h, 
+Lemma lt_right : forall x y l r e h,
  lt_tree x (Node l y e r h) -> lt_tree x r.
 Proof.
  intuition_in.
 Qed.
 
-Lemma gt_left : forall x y l r e h, 
+Lemma gt_left : forall x y l r e h,
  gt_tree x (Node l y e r h) -> gt_tree x l.
 Proof.
  intuition_in.
 Qed.
 
-Lemma gt_right : forall x y l r e h, 
+Lemma gt_right : forall x y l r e h,
  gt_tree x (Node l y e r h) -> gt_tree x r.
 Proof.
  intuition_in.
@@ -695,39 +694,39 @@ Qed.
 
 (** * Emptyness test *)
 
-Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. 
+Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
 Proof.
  destruct m as [|r x e l h]; simpl; auto.
  intro H; elim (H x e); auto.
 Qed.
 
 Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
-Proof. 
+Proof.
  destruct m; simpl; intros; try discriminate; red; intuition_in.
 Qed.
 
 (** * Appartness *)
 
 Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true.
-Proof. 
+Proof.
  intros m x; functional induction (mem x m); auto; intros; clearf;
   inv bst; intuition_in; order.
 Qed.
 
-Lemma mem_2 : forall m x, mem x m = true -> In x m. 
-Proof. 
+Lemma mem_2 : forall m x, mem x m = true -> In x m.
+Proof.
  intros m x; functional induction (mem x m); auto; intros; discriminate.
 Qed.
 
 Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e.
-Proof. 
+Proof.
  intros m x; functional induction (find x m); auto; intros; clearf;
-  inv bst; intuition_in; simpl; auto; 
+  inv bst; intuition_in; simpl; auto;
  try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto].
 Qed.
 
 Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
-Proof. 
+Proof.
  intros m x; functional induction (find x m); subst; intros; clearf;
   try discriminate.
  constructor 2; auto.
@@ -735,7 +734,7 @@ Proof.
  constructor 3; auto.
 Qed.
 
-Lemma find_iff : forall m x e, bst m -> 
+Lemma find_iff : forall m x e, bst m ->
  (find x m = Some e <-> MapsTo x e m).
 Proof.
  split; auto using find_1, find_2.
@@ -745,7 +744,7 @@ Lemma find_in : forall m x, find x m <> None -> In x m.
 Proof.
  intros.
  case_eq (find x m); [intros|congruence].
- apply MapsTo_In with e; apply find_2; auto. 
+ apply MapsTo_In with e; apply find_2; auto.
 Qed.
 
 Lemma in_find : forall m x, bst m -> In x m -> find x m <> None.
@@ -755,7 +754,7 @@ Proof.
  rewrite (find_1 H Hd); discriminate.
 Qed.
 
-Lemma find_in_iff : forall m x, bst m -> 
+Lemma find_in_iff : forall m x, bst m ->
  (find x m <> None <-> In x m).
 Proof.
  split; auto using find_in, in_find.
@@ -771,11 +770,11 @@ Proof.
  elim H0; apply find_in; congruence.
 Qed.
 
-Lemma find_find : forall m m' x, 
- find x m = find x m' <-> 
+Lemma find_find : forall m m' x,
+ find x m = find x m' <->
  (forall d, find x m = Some d <-> find x m' = Some d).
 Proof.
- intros; destruct (find x m); destruct (find x m'); split; intros; 
+ intros; destruct (find x m); destruct (find x m'); split; intros;
   try split; try congruence.
  rewrite H; auto.
  symmetry; rewrite <- H; auto.
@@ -783,7 +782,7 @@ Proof.
 Qed.
 
 Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' ->
- (find x m = find x m' <-> 
+ (find x m = find x m' <->
   (forall d, MapsTo x d m <-> MapsTo x d m')).
 Proof.
  intros m m' x Hm Hm'.
@@ -793,8 +792,8 @@ Proof.
  rewrite 2 find_iff; auto.
 Qed.
 
-Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> 
- find x m = find x m' -> 
+Lemma find_in_equiv : forall m m' x, bst m -> bst m' ->
+ find x m = find x m' ->
  (In x m <-> In x m').
 Proof.
  split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ];
@@ -803,27 +802,27 @@ Qed.
 
 (** * Helper functions *)
 
-Lemma create_bst : 
- forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+Lemma create_bst :
+ forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r ->
  bst (create l x e r).
 Proof.
  unfold create; auto.
 Qed.
 Hint Resolve create_bst.
 
-Lemma create_in : 
- forall l x e r y,  
+Lemma create_in :
+ forall l x e r y,
   In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r.
 Proof.
  unfold create; split; [ inversion_clear 1 | ]; intuition.
 Qed.
 
-Lemma bal_bst : forall l x e r, bst l -> bst r -> 
+Lemma bal_bst : forall l x e r, bst l -> bst r ->
  lt_tree x l -> gt_tree x r -> bst (bal l x e r).
 Proof.
  intros l x e r; functional induction (bal l x e r); intros; clearf;
  inv bst; repeat apply create_bst; auto; unfold create; try constructor;
- (apply lt_tree_node || apply gt_tree_node); auto; 
+ (apply lt_tree_node || apply gt_tree_node); auto;
  (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
 Qed.
 Hint Resolve bal_bst.
@@ -842,7 +841,7 @@ Proof.
  unfold assert_false, create; intuition_in.
 Qed.
 
-Lemma bal_find : forall l x e r y, 
+Lemma bal_find : forall l x e r y,
  bst l -> bst r -> lt_tree x l -> gt_tree x r ->
  find y (bal l x e r) = find y (create l x e r).
 Proof.
@@ -870,32 +869,32 @@ Qed.
 Hint Resolve add_bst.
 
 Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
-Proof. 
- intros m x y e; functional induction (add x e m); 
+Proof.
+ intros m x y e; functional induction (add x e m);
    intros; inv bst; try rewrite bal_mapsto; unfold create; eauto.
 Qed.
 
-Lemma add_2 : forall m x y e e', ~X.eq x y -> 
+Lemma add_2 : forall m x y e e', ~X.eq x y ->
  MapsTo y e m -> MapsTo y e (add x e' m).
 Proof.
  intros m x y e e'; induction m; simpl; auto.
  destruct (X.compare x k);
- intros; inv bst; try rewrite bal_mapsto; unfold create; auto; 
+ intros; inv bst; try rewrite bal_mapsto; unfold create; auto;
    inv MapsTo; auto; order.
 Qed.
 
-Lemma add_3 : forall m x y e e', ~X.eq x y -> 
+Lemma add_3 : forall m x y e e', ~X.eq x y ->
  MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof.
- intros m x y e e'; induction m; simpl; auto. 
+ intros m x y e e'; induction m; simpl; auto.
  intros; inv MapsTo; auto; order.
- destruct (X.compare x k); intro; 
-  try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; 
+ destruct (X.compare x k); intro;
+  try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto;
   order.
 Qed.
 
-Lemma add_find : forall m x y e, bst m -> 
- find y (add x e m) = 
+Lemma add_find : forall m x y e, bst m ->
+ find y (add x e m) =
   match X.compare y x with EQ _ => Some e | _ => find y m end.
 Proof.
  intros.
@@ -909,7 +908,7 @@ Qed.
 (** * Extraction of minimum binding *)
 
 Lemma remove_min_in : forall l x e r h y,
- In y (Node l x e r h) <-> 
+ In y (Node l x e r h) <->
   X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1.
 Proof.
  intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
@@ -919,7 +918,7 @@ Proof.
 Qed.
 
 Lemma remove_min_mapsto : forall l x e r h y e',
-  MapsTo y e' (Node l x e r h) <-> 
+  MapsTo y e' (Node l x e r h) <->
    ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2)
     \/ MapsTo y e' (remove_min l x e r)#1.
 Proof.
@@ -933,7 +932,7 @@ Proof.
  inversion_clear H3; intuition.
 Qed.
 
-Lemma remove_min_bst : forall l x e r h, 
+Lemma remove_min_bst : forall l x e r h,
  bst (Node l x e r h) -> bst (remove_min l x e r)#1.
 Proof.
  intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
@@ -949,8 +948,8 @@ Proof.
 Qed.
 Hint Resolve remove_min_bst.
 
-Lemma remove_min_gt_tree : forall l x e r h, 
- bst (Node l x e r h) -> 
+Lemma remove_min_gt_tree : forall l x e r h,
+ bst (Node l x e r h) ->
  gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1.
 Proof.
  intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
@@ -968,10 +967,10 @@ Proof.
 Qed.
 Hint Resolve remove_min_gt_tree.
 
-Lemma remove_min_find : forall l x e r h y, 
- bst (Node l x e r h) -> 
- find y (Node l x e r h) = 
-   match X.compare y (remove_min l x e r)#2#1 with 
+Lemma remove_min_find : forall l x e r h y,
+ bst (Node l x e r h) ->
+ find y (Node l x e r h) =
+   match X.compare y (remove_min l x e r)#2#1 with
     | LT _ => None
     | EQ _ => Some (remove_min l x e r)#2#2
     | GT _ => find y (remove_min l x e r)#1
@@ -990,9 +989,9 @@ Qed.
 
 (** * Merging two trees *)
 
-Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> 
+Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 ->
  (In y (merge m1 m2) <-> In y m1 \/ In y m2).
-Proof. 
+Proof.
  intros m1 m2; functional induction (merge m1 m2);intros;
   try factornode _x _x0 _x1 _x2 _x3 as m1.
  intuition_in.
@@ -1000,10 +999,10 @@ Proof.
  rewrite bal_in, remove_min_in, e1; simpl; intuition.
 Qed.
 
-Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> 
+Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 ->
   (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2).
 Proof.
- intros m1 m2; functional induction (merge m1 m2); intros; 
+ intros m1 m2; functional induction (merge m1 m2); intros;
   try factornode _x _x0 _x1 _x2 _x3 as m1.
  intuition_in.
  intuition_in.
@@ -1013,12 +1012,12 @@ Proof.
  inversion_clear H1; intuition.
 Qed.
 
-Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> 
- (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> 
- bst (merge m1 m2). 
+Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 ->
+ (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) ->
+ bst (merge m1 m2).
 Proof.
  intros m1 m2; functional induction (merge m1 m2); intros; auto;
- try factornode _x _x0 _x1 _x2 _x3 as m1. 
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
  apply bal_bst; auto.
  generalize (remove_min_bst H0); rewrite e1; simpl in *; auto.
  intro; intro.
@@ -1029,7 +1028,7 @@ Qed.
 
 (** * Deletion *)
 
-Lemma remove_in : forall m x y, bst m -> 
+Lemma remove_in : forall m x y, bst m ->
  (In y (remove x m) <-> ~ X.eq y x /\ In y m).
 Proof.
  intros m x; functional induction (remove x m); simpl; intros.
@@ -1049,7 +1048,7 @@ Proof.
 Qed.
 
 Lemma remove_bst : forall m x, bst m -> bst (remove x m).
-Proof. 
+Proof.
  intros m x; functional induction (remove x m); simpl; intros.
  auto.
  (* LT *)
@@ -1061,7 +1060,7 @@ Proof.
  (* EQ *)
  inv bst.
  apply merge_bst; eauto.
- (* GT *) 
+ (* GT *)
  inv bst.
  apply bal_bst; auto.
  intro; intro.
@@ -1070,16 +1069,16 @@ Proof.
 Qed.
 
 Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m).
-Proof. 
+Proof.
  intros; rewrite remove_in; intuition.
 Qed.
 
-Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> 
+Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y ->
  MapsTo y e m -> MapsTo y e (remove x m).
 Proof.
  intros m x y e; induction m; simpl; auto.
- destruct (X.compare x k); 
-   intros; inv bst; try rewrite bal_mapsto; unfold create; auto; 
+ destruct (X.compare x k);
+   intros; inv bst; try rewrite bal_mapsto; unfold create; auto;
    try solve [inv MapsTo; auto].
  rewrite merge_mapsto; auto.
  inv MapsTo; auto; order.
@@ -1089,7 +1088,7 @@ Lemma remove_3 : forall m x y e, bst m ->
  MapsTo y e (remove x m) -> MapsTo y e m.
 Proof.
  intros m x y e; induction m; simpl; auto.
- destruct (X.compare x k); intros Bs; inv bst; 
+ destruct (X.compare x k); intros Bs; inv bst;
   try rewrite bal_mapsto; auto; unfold create.
   intros; inv MapsTo; auto.
   rewrite merge_mapsto; intuition.
@@ -1098,7 +1097,7 @@ Qed.
 
 (** * join *)
 
-Lemma join_in : forall l x d r y, 
+Lemma join_in : forall l x d r y,
  In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r.
 Proof.
  join_tac.
@@ -1110,23 +1109,23 @@ Proof.
  apply create_in.
 Qed.
 
-Lemma join_bst : forall l x d r, bst l -> bst r -> 
+Lemma join_bst : forall l x d r, bst l -> bst r ->
  lt_tree x l -> gt_tree x r -> bst (join l x d r).
 Proof.
- join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; 
+ join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto;
  clear Hrl Hlr z; intro; intros; rewrite join_in in *.
  intuition; [ apply MX.lt_eq with x | ]; eauto.
  intuition; [ apply MX.eq_lt with x | ]; eauto.
 Qed.
 Hint Resolve join_bst.
 
-Lemma join_find : forall l x d r y, 
- bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+Lemma join_find : forall l x d r y,
+ bst l -> bst r -> lt_tree x l -> gt_tree x r ->
  find y (join l x d r) = find y (create l x d r).
 Proof.
  join_tac; auto; inv bst;
-  simpl (join (Leaf elt)); 
-  try (assert (X.lt lx x) by auto); 
+  simpl (join (Leaf elt));
+  try (assert (X.lt lx x) by auto);
   try (assert (X.lt x rx) by auto);
   rewrite ?add_find, ?bal_find; auto.
 
@@ -1150,10 +1149,10 @@ Qed.
 
 (** * split *)
 
-Lemma split_in_1 : forall m x, bst m -> forall y, 
+Lemma split_in_1 : forall m x, bst m -> forall y,
  (In y (split x m)#l <-> In y m /\ X.lt y x).
 Proof.
- intros m x; functional induction (split x m); simpl; intros; 
+ intros m x; functional induction (split x m); simpl; intros;
   inv bst; try clear e0.
  intuition_in.
  rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
@@ -1162,10 +1161,10 @@ Proof.
  rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 Qed.
 
-Lemma split_in_2 : forall m x, bst m -> forall y, 
+Lemma split_in_2 : forall m x, bst m -> forall y,
  (In y (split x m)#r <-> In y m /\ X.lt x y).
-Proof. 
- intros m x; functional induction (split x m); subst; simpl; intros; 
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; intros;
   inv bst; try clear e0.
  intuition_in.
  rewrite join_in.
@@ -1174,18 +1173,18 @@ Proof.
  rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 Qed.
 
-Lemma split_in_3 : forall m x, bst m -> 
+Lemma split_in_3 : forall m x, bst m ->
  (split x m)#o = find x m.
 Proof.
  intros m x; functional induction (split x m); subst; simpl; auto;
-  intros; inv bst; try clear e0; 
-  destruct X.compare; try (order;fail); rewrite <-IHt, e1; auto.
+  intros; inv bst; try clear e0;
+  destruct X.compare; try order; trivial; rewrite <- IHt, e1; auto.
 Qed.
 
-Lemma split_bst : forall m x, bst m -> 
+Lemma split_bst : forall m x, bst m ->
  bst (split x m)#l /\ bst (split x m)#r.
-Proof. 
- intros m x; functional induction (split x m); subst; simpl; intros; 
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; intros;
   inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition;
   apply join_bst; auto.
  intros y0.
@@ -1204,17 +1203,17 @@ Proof.
  intros m x B y Hy; rewrite split_in_2 in Hy; intuition.
 Qed.
 
-Lemma split_find : forall m x y, bst m -> 
- find y m = match X.compare y x with 
+Lemma split_find : forall m x y, bst m ->
+ find y m = match X.compare y x with
               | LT _ => find y (split x m)#l
               | EQ _ => (split x m)#o
               | GT _ => find y (split x m)#r
             end.
 Proof.
- intros m x; functional induction (split x m); subst; simpl; intros; 
-  inv bst; try clear e0; try rewrite e1 in *; simpl in *; 
+ intros m x; functional induction (split x m); subst; simpl; intros;
+  inv bst; try clear e0; try rewrite e1 in *; simpl in *;
   [ destruct X.compare; auto | .. ];
-  try match goal with E:split ?x ?t = _, B:bst ?t |- _ => 
+  try match goal with E:split ?x ?t = _, B:bst ?t |- _ =>
       generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B);
        rewrite E; simpl; destruct 3 end.
 
@@ -1231,7 +1230,7 @@ Qed.
 
 (** * Concatenation *)
 
-Lemma concat_in : forall m1 m2 y, 
+Lemma concat_in : forall m1 m2 y,
  In y (concat m1 m2) <-> In y m1 \/ In y m2.
 Proof.
  intros m1 m2; functional induction (concat m1 m2); intros;
@@ -1241,11 +1240,11 @@ Proof.
  rewrite join_in, remove_min_in, e1; simpl; intuition.
 Qed.
 
-Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> 
- (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> 
+Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 ->
+ (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) ->
  bst (concat m1 m2).
 Proof.
- intros m1 m2; functional induction (concat m1 m2); intros; auto; 
+ intros m1 m2; functional induction (concat m1 m2); intros; auto;
  try factornode _x _x0 _x1 _x2 _x3 as m1.
  apply join_bst; auto.
  change (bst (m2',xd)#1); rewrite <-e1; eauto.
@@ -1256,19 +1255,19 @@ Proof.
 Qed.
 Hint Resolve concat_bst.
 
-Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> 
- (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> 
- find y (concat m1 m2) = 
+Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 ->
+ (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) ->
+ find y (concat m1 m2) =
   match find y m2 with Some d => Some d | None => find y m1 end.
 Proof.
- intros m1 m2; functional induction (concat m1 m2); intros; auto; 
+ intros m1 m2; functional induction (concat m1 m2); intros; auto;
  try factornode _x _x0 _x1 _x2 _x3 as m1.
  simpl; destruct (find y m2); auto.
 
  generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4)
-  (remove_min_bst H0)(remove_min_gt_tree H0); 
+  (remove_min_bst H0)(remove_min_gt_tree H0);
   rewrite e1; simpl fst; simpl snd; intros.
- 
+
  inv bst.
  rewrite H2, join_find; auto; clear H2.
  simpl; destruct X.compare; simpl; auto.
@@ -1286,7 +1285,7 @@ Notation eqk := (PX.eqk (elt:= elt)).
 Notation eqke := (PX.eqke (elt:= elt)).
 Notation ltk := (PX.ltk (elt:= elt)).
 
-Lemma elements_aux_mapsto : forall (s:t elt) acc x e, 
+Lemma elements_aux_mapsto : forall (s:t elt) acc x e,
  InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc.
 Proof.
  induction s as [ | l Hl x e r Hr h ]; simpl; auto.
@@ -1299,8 +1298,8 @@ Proof.
  destruct H0; simpl in *; subst; intuition.
 Qed.
 
-Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. 
-Proof. 
+Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s.
+Proof.
  intros; generalize (elements_aux_mapsto s nil x e); intuition.
  inversion_clear H0.
 Qed.
@@ -1324,9 +1323,9 @@ Proof.
  induction s as [ | l Hl y e r Hr h]; simpl; intuition.
  inv bst.
  apply Hl; auto.
- constructor. 
+ constructor.
  apply Hr; eauto.
- apply (InA_InfA (PX.eqke_refl (elt:=elt))); intros (y',e') H6.
+ apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6.
  destruct (elements_aux_mapsto r acc y' e'); intuition.
  red; simpl; eauto.
  red; simpl; eauto.
@@ -1382,7 +1381,7 @@ Qed.
 
 (** * Fold *)
 
-Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := 
+Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) :=
   L.fold f (elements s).
 
 Lemma fold_equiv_aux :
@@ -1401,14 +1400,14 @@ Lemma fold_equiv :
  forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A),
  fold f s a = fold' f s a.
 Proof.
- unfold fold', elements in |- *. 
+ unfold fold', elements in |- *.
  simple induction s; simpl in |- *; auto; intros.
  rewrite fold_equiv_aux.
  rewrite H0.
  simpl in |- *; auto.
 Qed.
 
-Lemma fold_1 : 
+Lemma fold_1 :
  forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A),
  fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i.
 Proof.
@@ -1421,9 +1420,9 @@ Qed.
 
 (** * Comparison *)
 
-(** [flatten_e e] returns the list of elements of the enumeration [e] 
+(** [flatten_e e] returns the list of elements of the enumeration [e]
     i.e. the list of elements actually compared *)
- 
+
 Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
   | End => nil
   | More x e t r => (x,e) :: elements t ++ flatten_e r
@@ -1431,13 +1430,13 @@ Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
 
 Lemma flatten_e_elements :
  forall (l:t elt) r x d z e,
- elements l ++ flatten_e (More x d r e) = 
+ elements l ++ flatten_e (More x d r e) =
  elements (Node l x d r z) ++ flatten_e e.
 Proof.
  intros; simpl; apply elements_node.
 Qed.
 
-Lemma cons_1 : forall (s:t elt) e, 
+Lemma cons_1 : forall (s:t elt) e,
   flatten_e (cons s e) = elements s ++ flatten_e e.
 Proof.
   induction s; simpl; auto; intros.
@@ -1450,24 +1449,24 @@ Variable cmp : elt->elt->bool.
 
 Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b.
 
-Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, 
-  X.eq x1 x2 -> cmp d1 d2 = true -> 
-  IfEq b l1 l2 -> 
+Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2,
+  X.eq x1 x2 -> cmp d1 d2 = true ->
+  IfEq b l1 l2 ->
     IfEq b ((x1,d1)::l1) ((x2,d2)::l2).
 Proof.
- unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; 
+ unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl;
   try rewrite H0; auto; order.
 Qed.
 
-Lemma equal_end_IfEq : forall e2, 
+Lemma equal_end_IfEq : forall e2,
   IfEq (equal_end e2) nil (flatten_e e2).
 Proof.
  destruct e2; red; auto.
 Qed.
 
-Lemma equal_more_IfEq : 
- forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, 
-  IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> 
+Lemma equal_more_IfEq :
+ forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l,
+  IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
     IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l)
        (flatten_e (More x2 d2 r2 e2)).
 Proof.
@@ -1475,7 +1474,7 @@ Proof.
  rewrite <-andb_lazy_alt; f_equal; auto.
 Qed.
 
-Lemma equal_cont_IfEq : forall m1 cont e2 l, 
+Lemma equal_cont_IfEq : forall m1 cont e2 l,
   (forall e, IfEq (cont e) l (flatten_e e)) ->
   IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2).
 Proof.
@@ -1493,18 +1492,18 @@ Lemma equal_IfEq : forall (m1 m2:t elt),
 Proof.
  intros; unfold equal.
  rewrite (app_nil_end (elements m1)).
- replace (elements m2) with (flatten_e (cons m2 (End _))) 
+ replace (elements m2) with (flatten_e (cons m2 (End _)))
   by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto).
  apply equal_cont_IfEq.
  intros.
  apply equal_end_IfEq; auto.
 Qed.
 
-Definition Equivb m m' := 
-  (forall k, In k m <-> In k m') /\ 
+Definition Equivb m m' :=
+  (forall k, In k m <-> In k m') /\
   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
 
-Lemma Equivb_elements : forall s s', 
+Lemma Equivb_elements : forall s s',
  Equivb s s' <-> L.Equivb cmp (elements s) (elements s').
 Proof.
 unfold Equivb, L.Equivb; split; split; intros.
@@ -1516,7 +1515,7 @@ destruct H.
 apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
 Qed.
 
-Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> 
+Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' ->
   (equal cmp s s' = true <-> Equivb s s').
 Proof.
  intros s s' B B'.
@@ -1526,17 +1525,17 @@ Qed.
 
 End Elt.
 
-Section Map. 
+Section Map.
 Variable elt elt' : Type.
-Variable f : elt -> elt'. 
+Variable f : elt -> elt'.
 
-Lemma map_1 : forall (m: t elt)(x:key)(e:elt), 
+Lemma map_1 : forall (m: t elt)(x:key)(e:elt),
     MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof.
 induction m; simpl; inversion_clear 1; auto.
 Qed.
 
-Lemma map_2 : forall (m: t elt)(x:key), 
+Lemma map_2 : forall (m: t elt)(x:key),
     In x (map f m) -> In x m.
 Proof.
 induction m; simpl; inversion_clear 1; auto.
@@ -1545,7 +1544,7 @@ Qed.
 Lemma map_bst : forall m, bst m -> bst (map f m).
 Proof.
 induction m; simpl; auto.
-inversion_clear 1; constructor; auto; 
+inversion_clear 1; constructor; auto;
  red; auto using map_2.
 Qed.
 
@@ -1554,7 +1553,7 @@ Section Mapi.
 Variable elt elt' : Type.
 Variable f : key -> elt -> elt'.
 
-Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), 
+Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt),
     MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof.
 induction m; simpl; inversion_clear 1; auto.
@@ -1565,7 +1564,7 @@ destruct (IHm2 _ _ H0).
 exists x0; intuition.
 Qed.
 
-Lemma mapi_2 : forall (m: t elt)(x:key), 
+Lemma mapi_2 : forall (m: t elt)(x:key),
     In x (mapi f m) -> In x m.
 Proof.
 induction m; simpl; inversion_clear 1; auto.
@@ -1574,7 +1573,7 @@ Qed.
 Lemma mapi_bst : forall m, bst m -> bst (mapi f m).
 Proof.
 induction m; simpl; auto.
-inversion_clear 1; constructor; auto; 
+inversion_clear 1; constructor; auto;
  red; auto using mapi_2.
 Qed.
 
@@ -1585,7 +1584,7 @@ Variable elt elt' : Type.
 Variable f : key -> elt -> option elt'.
 Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d.
 
-Lemma map_option_2 : forall (m:t elt)(x:key), 
+Lemma map_option_2 : forall (m:t elt)(x:key),
  In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None.
 Proof.
 intros m; functional induction (map_option f m); simpl; auto; intros.
@@ -1601,9 +1600,9 @@ Qed.
 
 Lemma map_option_bst : forall m, bst m -> bst (map_option f m).
 Proof.
-intros m; functional induction (map_option f m); simpl; auto; intros; 
+intros m; functional induction (map_option f m); simpl; auto; intros;
  inv bst.
-apply join_bst; auto; intros y H; 
+apply join_bst; auto; intros y H;
  destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In.
 apply concat_bst; auto; intros y y' H H'.
 destruct (map_option_2 H) as (d0 & ? & ?).
@@ -1612,22 +1611,22 @@ eapply X.lt_trans with x; eauto using MapsTo_In.
 Qed.
 Hint Resolve map_option_bst.
 
-Ltac nonify e := 
- replace e with (@None elt) by 
+Ltac nonify e :=
+ replace e with (@None elt) by
   (symmetry; rewrite not_find_iff; auto; intro; order).
 
-Lemma map_option_find : forall (m:t elt)(x:key), 
- bst m -> 
- find x (map_option f m) = 
+Lemma map_option_find : forall (m:t elt)(x:key),
+ bst m ->
+ find x (map_option f m) =
   match (find x m) with Some d => f x d | None => None end.
 Proof.
 intros m; functional induction (map_option f m); simpl; auto; intros;
- inv bst; rewrite join_find || rewrite concat_find; auto; simpl; 
+ inv bst; rewrite join_find || rewrite concat_find; auto; simpl;
  try destruct X.compare; simpl; auto.
 rewrite (f_compat d e); auto.
 intros y H;
  destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
-intros y H; 
+intros y H;
  destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
 
 rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto.
@@ -1653,21 +1652,21 @@ Variable mapr : t elt' -> t elt''.
 Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o.
 Hypothesis mapl_bst : forall m, bst m -> bst (mapl m).
 Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m').
-Hypothesis mapl_f0 : forall x m, bst m -> 
- find x (mapl m) = 
+Hypothesis mapl_f0 : forall x m, bst m ->
+ find x (mapl m) =
   match find x m with Some d => f0 x (Some d) None | None => None end.
-Hypothesis mapr_f0 : forall x m', bst m' -> 
- find x (mapr m') = 
+Hypothesis mapr_f0 : forall x m', bst m' ->
+ find x (mapr m') =
   match find x m' with Some d' => f0 x None (Some d') | None => None end.
 Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'.
 
 Notation map2_opt := (map2_opt f mapl mapr).
 
-Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> 
+Lemma map2_opt_2 : forall m m' y, bst m -> bst m' ->
   In y (map2_opt m m') -> In y m \/ In y m'.
 Proof.
 intros m m'; functional induction (map2_opt m m'); intros;
- auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; 
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2;
  try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y)
       (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst).
 
@@ -1689,12 +1688,12 @@ destruct (IHt1 y H6 H4 H'); intuition.
 destruct (IHt0 y H7 H5 H'); intuition.
 Qed.
 
-Lemma map2_opt_bst : forall m m', bst m -> bst m' -> 
+Lemma map2_opt_bst : forall m m', bst m -> bst m' ->
  bst (map2_opt m m').
 Proof.
 intros m m'; functional induction (map2_opt m m'); intros;
- auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; 
- generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); 
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst;
+ generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0);
   rewrite e1; simpl in *; destruct 3.
 
 apply join_bst; auto.
@@ -1711,31 +1710,31 @@ destruct (map2_opt_2 H2 H7 Hy'); intuition.
 Qed.
 Hint Resolve map2_opt_bst.
 
-Ltac map2_aux := 
+Ltac map2_aux :=
  match goal with
-  | H : In ?x _ \/ In ?x ?m, 
-    H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => 
-    destruct H; [ intuition_in; order | 
+  | H : In ?x _ \/ In ?x ?m,
+    H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ =>
+    destruct H; [ intuition_in; order |
                   rewrite <-(find_in_equiv B B' H'); auto ]
  end.
 
-Ltac nonify t := 
- match t with (find ?y (map2_opt ?m ?m')) => 
+Ltac nonify t :=
+ match t with (find ?y (map2_opt ?m ?m')) =>
  replace t with (@None elt'');
  [ | symmetry; rewrite not_find_iff; auto; intro;
      destruct (@map2_opt_2 m m' y); auto; order ]
  end.
 
-Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> 
+Lemma map2_opt_1 : forall m m' y, bst m -> bst m' ->
  In y m \/ In y m' ->
  find y (map2_opt m m') = f0 y (find y m) (find y m').
 Proof.
 intros m m'; functional induction (map2_opt m m'); intros;
- auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; 
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2;
  try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0)
        (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0)
        (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0);
-       rewrite e1; simpl in *; destruct 4; intros; inv bst; 
+       rewrite e1; simpl in *; destruct 4; intros; inv bst;
       subst o2; rewrite H7, ?join_find, ?concat_find; auto).
 
 simpl; destruct H1; [ inversion_clear H1 | ].
@@ -1777,23 +1776,23 @@ Variable f : option elt -> option elt' -> option elt''.
 Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m').
 Proof.
 unfold map2; intros.
-apply map2_opt_bst with (fun _ => f); auto using map_option_bst; 
+apply map2_opt_bst with (fun _ => f); auto using map_option_bst;
  intros; rewrite map_option_find; auto.
 Qed.
 
-Lemma map2_1 : forall m m' y, bst m -> bst m' -> 
+Lemma map2_1 : forall m m' y, bst m -> bst m' ->
   In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m').
 Proof.
 unfold map2; intros.
-rewrite (map2_opt_1 (f0:=fun _ => f)); 
+rewrite (map2_opt_1 (f0:=fun _ => f));
  auto using map_option_bst; intros; rewrite map_option_find; auto.
 Qed.
 
-Lemma map2_2 : forall m m' y, bst m -> bst m' -> 
+Lemma map2_2 : forall m m' y, bst m -> bst m' ->
   In y (map2 f m m') -> In y m \/ In y m'.
 Proof.
 unfold map2; intros.
-eapply map2_opt_2 with (f0:=fun _ => f); eauto; intros.
+eapply map2_opt_2 with (f0:=fun _ => f); try eassumption; trivial; intros.
  apply map_option_bst; auto.
  apply map_option_bst; auto.
  rewrite map_option_find; auto.
@@ -1806,38 +1805,38 @@ End Raw.
 
 (** * Encapsulation
 
-   Now, in order to really provide a functor implementing [S], we 
+   Now, in order to really provide a functor implementing [S], we
    need to encapsulate everything into a type of balanced binary search trees. *)
 
 Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 
  Module E := X.
- Module Raw := Raw I X. 
+ Module Raw := Raw I X.
  Import Raw.Proofs.
 
- Record bst (elt:Type) := 
+ Record bst (elt:Type) :=
   Bst {this :> Raw.tree elt; is_bst : Raw.bst this}.
- 
- Definition t := bst. 
+
+ Definition t := bst.
  Definition key := E.t.
- 
- Section Elt. 
+
+ Section Elt.
  Variable elt elt' elt'': Type.
 
  Implicit Types m : t elt.
- Implicit Types x y : key. 
- Implicit Types e : elt. 
+ Implicit Types x y : key.
+ Implicit Types e : elt.
 
  Definition empty : t elt := Bst (empty_bst elt).
  Definition is_empty m : bool := Raw.is_empty m.(this).
  Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)).
- Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). 
+ Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)).
  Definition mem x m : bool := Raw.mem x m.(this).
  Definition find x m : option elt := Raw.find x m.(this).
  Definition map f m : t elt' := Bst (map_bst f m.(is_bst)).
- Definition mapi (f:key->elt->elt') m : t elt' := 
+ Definition mapi (f:key->elt->elt') m : t elt' :=
   Bst (mapi_bst f m.(is_bst)).
- Definition map2 f m (m':t elt') : t elt'' := 
+ Definition map2 f m (m':t elt') : t elt'' :=
   Bst (map2_bst f m.(is_bst) m'.(is_bst)).
  Definition elements m : list (key*elt) := Raw.elements m.(this).
  Definition cardinal m := Raw.cardinal m.(this).
@@ -1854,14 +1853,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 
  Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed.
- 
+
  Lemma mem_1 : forall m x, In x m -> mem x m = true.
  Proof.
  unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto.
  apply m.(is_bst).
  Qed.
- 
- Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof.
  unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
  Qed.
@@ -1892,7 +1891,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed.
 
 
- Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
  Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed.
  Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
  Proof. intros m; exact (@find_2 elt m.(this)). Qed.
@@ -1901,36 +1900,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
         fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed.
 
- Lemma elements_1 : forall m x e,       
+ Lemma elements_1 : forall m x e,
    MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
  intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto.
  Qed.
 
- Lemma elements_2 : forall m x e,   
+ Lemma elements_2 : forall m x e,
    InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
  intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto.
  Qed.
 
- Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Lemma elements_3 : forall m, sort lt_key (elements m).
  Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed.
 
- Lemma elements_3w : forall m, NoDupA eq_key (elements m).  
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
  Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed.
 
  Lemma cardinal_1 : forall m, cardinal m = length (elements m).
  Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed.
 
  Definition Equal m m' := forall y, find y m = find y m'.
- Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
-   (forall k, In k m <-> In k m') /\ 
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+   (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb cmp := Equiv (Cmp cmp).
 
- Lemma Equivb_Equivb : forall cmp m m', 
+ Lemma Equivb_Equivb : forall cmp m m',
   Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
- Proof. 
+ Proof.
  intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
  generalize (H0 k); do 2 rewrite In_alt; intuition.
  generalize (H0 k); do 2 rewrite In_alt; intuition.
@@ -1938,23 +1937,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  generalize (H0 k); do 2 rewrite <- In_alt; intuition.
  Qed.
 
- Lemma equal_1 : forall m m' cmp, 
-   Equivb cmp m m' -> equal cmp m m' = true. 
- Proof. 
- unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; 
+ Lemma equal_1 : forall m m' cmp,
+   Equivb cmp m m' -> equal cmp m m' = true.
+ Proof.
+ unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb;
   intros; simpl in *; rewrite equal_Equivb; auto.
- Qed. 
+ Qed.
 
- Lemma equal_2 : forall m m' cmp, 
+ Lemma equal_2 : forall m m' cmp,
    equal cmp m m' = true -> Equivb cmp m m'.
- Proof. 
- unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; 
+ Proof.
+ unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb;
   intros; simpl in *; rewrite <-equal_Equivb; auto.
  Qed.
 
  End Elt.
 
- Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
         MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed.
 
@@ -1962,10 +1961,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Proof.
  intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
  apply map_2; auto.
- Qed. 
+ Qed.
 
  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
-        (f:key->elt->elt'), MapsTo x e m -> 
+        (f:key->elt->elt'), MapsTo x e m ->
         exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed.
  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
@@ -1975,10 +1974,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Qed.
 
  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-    (x:key)(f:option elt->option elt'->option elt''), 
-    In x m \/ In x m' -> 
-    find x (map2 f m m') = f (find x m) (find x m'). 
- Proof. 
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x m \/ In x m' ->
+    find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
  unfold find, map2, In; intros elt elt' elt'' m m' x f.
  do 2 rewrite In_alt; intros; simpl; apply map2_1; auto.
  apply m.(is_bst).
@@ -1986,9 +1985,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Qed.
 
  Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-     (x:key)(f:option elt->option elt'->option elt''), 
+     (x:key)(f:option elt->option elt'->option elt''),
      In x (map2 f m m') -> In x m \/ In x m'.
- Proof. 
+ Proof.
  unfold In, map2; intros elt elt' elt'' m m' x f.
  do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
  apply m.(is_bst).
@@ -1998,19 +1997,19 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 End IntMake.
 
 
-Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: 
-    Sord with Module Data := D 
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
+    Sord with Module Data := D
          with Module MapS.E := X.
 
   Module Data := D.
-  Module Import MapS := IntMake(I)(X). 
+  Module Import MapS := IntMake(I)(X).
   Module LO := FMapList.Make_ord(X)(D).
   Module R := Raw.
   Module P := Raw.Proofs.
 
   Definition t := MapS.t D.t.
 
-  Definition cmp e e' := 
+  Definition cmp e e' :=
    match D.compare e e' with EQ _ => true | _ => false end.
 
   (** One step of comparison of elements *)
@@ -2020,9 +2019,9 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
     | R.End => Gt
     | R.More x2 d2 r2 e2 =>
        match X.compare x1 x2 with
-        | EQ _ => match D.compare d1 d2 with 
+        | EQ _ => match D.compare d1 d2 with
                    | EQ _ => cont (R.cons r2 e2)
-                   | LT _ => Lt 
+                   | LT _ => Lt
                    | GT _ => Gt
                   end
         | LT _ => Lt
@@ -2046,7 +2045,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   (** The complete comparison *)
 
-  Definition compare_pure s1 s2 := 
+  Definition compare_pure s1 s2 :=
    compare_cont s1 compare_end (R.cons s2 (Raw.End _)).
 
   (** Correctness of this comparison *)
@@ -2058,7 +2057,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
     | Gt => (fun l1 l2 => LO.lt_list l2 l1)
    end.
 
-  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, 
+  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2,
    X.eq x1 x2 -> D.eq d1 d2 ->
    Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
   Proof.
@@ -2077,10 +2076,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
      Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l)
        (P.flatten_e (R.More x2 d2 r2 e2)).
   Proof.
-   simpl; intros; destruct X.compare; simpl; 
+   simpl; intros; destruct X.compare; simpl;
     try destruct D.compare; simpl; auto; P.MX.elim_comp; auto.
   Qed.
-  
+
   Lemma compare_cont_Cmp : forall s1 cont e2 l,
    (forall e, Cmp (cont e) l (P.flatten_e e)) ->
    Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2).
@@ -2110,14 +2109,14 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Definition compare (s s':t) : Compare lt eq s s'.
   Proof.
-   intros (s,b) (s',b').
+   destruct s as (s,b), s' as (s',b').
    generalize (compare_Cmp s s').
    destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto.
   Defined.
-  
+
   (* Proofs about [eq] and [lt] *)
 
-  Definition selements (m1 : t) := 
+  Definition selements (m1 : t) :=
    LO.MapS.Build_slist (P.elements_sort m1.(is_bst)).
 
   Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
@@ -2154,7 +2153,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
   Qed.
 
   Lemma eq_refl : forall m : t, eq m m.
-  Proof. 
+  Proof.
   intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
   Qed.
 
@@ -2171,13 +2170,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
   Proof.
-  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;  
+  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;
    intros; eapply LO.lt_trans; eauto.
   Qed.
 
   Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
   Proof.
-  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; 
+  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq;
    intros; apply LO.lt_not_eq; auto.
   Qed.
 
@@ -2188,8 +2187,8 @@ End IntMake_ord.
 Module Make (X: OrderedType) <: S with Module E := X
  :=IntMake(Z_as_Int)(X).
 
-Module Make_ord (X: OrderedType)(D: OrderedType) 
- <: Sord with Module Data := D 
+Module Make_ord (X: OrderedType)(D: OrderedType)
+ <: Sord with Module Data := D
             with Module MapS.E := X
  :=IntMake_ord(Z_as_Int)(X)(D).
 
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
index d91eb87a..4c59971c 100644
--- a/theories/FSets/FMapFacts.v
+++ b/theories/FSets/FMapFacts.v
@@ -6,25 +6,22 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapFacts.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 (** * Finite maps library *)
 
 (** This functor derives additional facts from [FMapInterface.S]. These
-  facts are mainly the specifications of [FMapInterface.S] written using 
-  different styles: equivalence and boolean equalities. 
+  facts are mainly the specifications of [FMapInterface.S] written using
+  different styles: equivalence and boolean equalities.
 *)
 
 Require Import Bool DecidableType DecidableTypeEx OrderedType Morphisms.
-Require Export FMapInterface. 
+Require Export FMapInterface.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
 Hint Extern 1 (Equivalence _) => constructor; congruence.
 
-Notation Leibniz := (@eq _) (only parsing).
-
-
 (** * Facts about weak maps *)
 
 Module WFacts_fun (E:DecidableType)(Import M:WSfun E).
@@ -46,7 +43,7 @@ destruct o; destruct o'; try rewrite H; auto.
 symmetry; rewrite <- H; auto.
 Qed.
 
-Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), 
+Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt),
   MapsTo x e m -> MapsTo x e' m -> e=e'.
 Proof.
 intros.
@@ -56,7 +53,7 @@ Qed.
 
 (** ** Specifications written using equivalences *)
 
-Section IffSpec. 
+Section IffSpec.
 Variable elt elt' elt'': Type.
 Implicit Type m: t elt.
 Implicit Type x y z: key.
@@ -101,7 +98,7 @@ Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None.
 Proof.
 split; intros.
 rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff.
-split; intro H'; try discriminate. elim H; exists e; auto.
+split; try discriminate. intro H'; elim H; exists e; auto.
 intros (e,He); rewrite find_mapsto_iff,H in He; discriminate.
 Qed.
 
@@ -112,7 +109,7 @@ destruct mem; intuition.
 Qed.
 
 Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true.
-Proof. 
+Proof.
 split; [apply equal_1|apply equal_2].
 Qed.
 
@@ -127,16 +124,16 @@ unfold In.
 split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition.
 Qed.
 
-Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. 
-Proof. 
+Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true.
+Proof.
 split; [apply is_empty_1|apply is_empty_2].
 Qed.
 
-Lemma add_mapsto_iff : forall m x y e e', 
-  MapsTo y e' (add x e m) <-> 
-     (E.eq x y /\ e=e') \/ 
+Lemma add_mapsto_iff : forall m x y e e',
+  MapsTo y e' (add x e m) <->
+     (E.eq x y /\ e=e') \/
      (~E.eq x y /\ MapsTo y e' m).
-Proof. 
+Proof.
 intros.
 intuition.
 destruct (eq_dec x y); [left|right].
@@ -147,7 +144,7 @@ subst; auto with map.
 Qed.
 
 Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
-Proof. 
+Proof.
 unfold In; split.
 intros (e',H).
 destruct (eq_dec x y) as [E|E]; auto.
@@ -161,13 +158,13 @@ destruct E; auto.
 exists e'; apply add_2; auto.
 Qed.
 
-Lemma add_neq_mapsto_iff : forall m x y e e', 
+Lemma add_neq_mapsto_iff : forall m x y e e',
  ~ E.eq x y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
 Proof.
 split; [apply add_3|apply add_2]; auto.
 Qed.
 
-Lemma add_neq_in_iff : forall m x y e, 
+Lemma add_neq_in_iff : forall m x y e,
  ~ E.eq x y -> (In y (add x e m)  <-> In y m).
 Proof.
 split; intros (e',H0); exists e'.
@@ -175,9 +172,9 @@ apply (add_3 H H0).
 apply add_2; auto.
 Qed.
 
-Lemma remove_mapsto_iff : forall m x y e, 
+Lemma remove_mapsto_iff : forall m x y e,
   MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
-Proof. 
+Proof.
 intros.
 split; intros.
 split.
@@ -188,7 +185,7 @@ apply remove_2; intuition.
 Qed.
 
 Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m.
-Proof. 
+Proof.
 unfold In; split.
 intros (e,H).
 split.
@@ -198,13 +195,13 @@ exists e; apply remove_3 with x; auto.
 intros (H,(e,H0)); exists e; apply remove_2; auto.
 Qed.
 
-Lemma remove_neq_mapsto_iff : forall m x y e, 
+Lemma remove_neq_mapsto_iff : forall m x y e,
  ~ E.eq x y -> (MapsTo y e (remove x m)  <-> MapsTo y e m).
 Proof.
 split; [apply remove_3|apply remove_2]; auto.
 Qed.
 
-Lemma remove_neq_in_iff : forall m x y, 
+Lemma remove_neq_in_iff : forall m x y,
  ~ E.eq x y -> (In y (remove x m)  <-> In y m).
 Proof.
 split; intros (e',H0); exists e'.
@@ -212,19 +209,19 @@ apply (remove_3 H0).
 apply remove_2; auto.
 Qed.
 
-Lemma elements_mapsto_iff : forall m x e, 
+Lemma elements_mapsto_iff : forall m x e,
  MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m).
-Proof. 
+Proof.
 split; [apply elements_1 | apply elements_2].
 Qed.
 
-Lemma elements_in_iff : forall m x, 
+Lemma elements_in_iff : forall m x,
  In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m).
-Proof. 
+Proof.
 unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto.
 Qed.
 
-Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), 
+Lemma map_mapsto_iff : forall m x b (f : elt -> elt'),
  MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
 Proof.
 split.
@@ -240,7 +237,7 @@ intros (a,(H,H0)).
 subst b; auto with map.
 Qed.
 
-Lemma map_in_iff : forall m x (f : elt -> elt'), 
+Lemma map_in_iff : forall m x (f : elt -> elt'),
  In x (map f m) <-> In x m.
 Proof.
 split; intros; eauto with map.
@@ -257,11 +254,11 @@ destruct (mapi_1 f H) as (y,(H0,H1)).
 exists (f y a); auto.
 Qed.
 
-(** Unfortunately, we don't have simple equivalences for [mapi] 
-  and [MapsTo]. The only correct one needs compatibility of [f]. *) 
+(** Unfortunately, we don't have simple equivalences for [mapi]
+  and [MapsTo]. The only correct one needs compatibility of [f]. *)
 
-Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), 
- MapsTo x b (mapi f m) -> 
+Lemma mapi_inv : forall m x b (f : key -> elt -> elt'),
+ MapsTo x b (mapi f m) ->
  exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m.
 Proof.
 intros; case_eq (find x m); intros.
@@ -275,8 +272,8 @@ destruct (mapi_2 H1) as (a,H2).
 rewrite (find_1 H2) in H0; discriminate.
 Qed.
 
-Lemma mapi_1bis : forall m x e (f:key->elt->elt'), 
- (forall x y e, E.eq x y -> f x e = f y e) -> 
+Lemma mapi_1bis : forall m x e (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) ->
  MapsTo x e m -> MapsTo x (f x e) (mapi f m).
 Proof.
 intros.
@@ -286,7 +283,7 @@ auto.
 Qed.
 
 Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'),
- (forall x y e, E.eq x y -> f x e = f y e) -> 
+ (forall x y e, E.eq x y -> f x e = f y e) ->
  (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
 Proof.
 split.
@@ -299,14 +296,14 @@ subst b.
 apply mapi_1bis; auto.
 Qed.
 
-(** Things are even worse for [map2] : we don't try to state any 
+(** Things are even worse for [map2] : we don't try to state any
  equivalence, see instead boolean results below. *)
 
 End IffSpec.
 
 (** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *)
-  
-Ltac map_iff := 
+
+Ltac map_iff :=
  repeat (progress (
   rewrite add_mapsto_iff || rewrite add_in_iff ||
   rewrite remove_mapsto_iff || rewrite remove_in_iff ||
@@ -318,7 +315,7 @@ Ltac map_iff :=
 
 Section BoolSpec.
 
-Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. 
+Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false.
 Proof.
 intros.
 generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In.
@@ -336,7 +333,7 @@ Implicit Types x y z : key.
 Implicit Types e : elt.
 
 Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m.
-Proof. 
+Proof.
 intros.
 generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H).
 destruct (mem x m); destruct (mem y m); intuition.
@@ -362,14 +359,14 @@ generalize (mem_2 H).
 rewrite empty_in_iff; intuition.
 Qed.
 
-Lemma add_eq_o : forall m x y e, 
+Lemma add_eq_o : forall m x y e,
  E.eq x y -> find y (add x e m) = Some e.
 Proof.
 auto with map.
 Qed.
 
-Lemma add_neq_o : forall m x y e, 
- ~ E.eq x y -> find y (add x e m) = find y m. 
+Lemma add_neq_o : forall m x y e,
+ ~ E.eq x y -> find y (add x e m) = find y m.
 Proof.
 intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff.
 apply add_neq_mapsto_iff; auto.
@@ -382,26 +379,26 @@ Proof.
 intros; destruct (eq_dec x y); auto with map.
 Qed.
 
-Lemma add_eq_b : forall m x y e, 
+Lemma add_eq_b : forall m x y e,
  E.eq x y -> mem y (add x e m) = true.
 Proof.
 intros; rewrite mem_find_b; rewrite add_eq_o; auto.
 Qed.
 
-Lemma add_neq_b : forall m x y e, 
+Lemma add_neq_b : forall m x y e,
  ~E.eq x y -> mem y (add x e m) = mem y m.
 Proof.
 intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto.
 Qed.
 
-Lemma add_b : forall m x y e, 
- mem y (add x e m) = eqb x y || mem y m. 
+Lemma add_b : forall m x y e,
+ mem y (add x e m) = eqb x y || mem y m.
 Proof.
 intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb.
 destruct (eq_dec x y); simpl; auto.
 Qed.
 
-Lemma remove_eq_o : forall m x y, 
+Lemma remove_eq_o : forall m x y,
  E.eq x y -> find y (remove x m) = None.
 Proof.
 intros. rewrite eq_option_alt. intro e.
@@ -442,14 +439,14 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
 destruct (eq_dec x y); auto.
 Qed.
 
-Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := 
- match o with 
+Definition option_map (A B:Type)(f:A->B)(o:option A) : option B :=
+ match o with
   | Some a => Some (f a)
   | None => None
  end.
 
-Lemma map_o : forall m x (f:elt->elt'), 
- find x (map f m) = option_map f (find x m). 
+Lemma map_o : forall m x (f:elt->elt'),
+ find x (map f m) = option_map f (find x m).
 Proof.
 intros.
 generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x)
@@ -463,14 +460,14 @@ rewrite H0 in H2; discriminate.
 rewrite <- H; rewrite H1; exists e; rewrite H0; auto.
 Qed.
 
-Lemma map_b : forall m x (f:elt->elt'), 
+Lemma map_b : forall m x (f:elt->elt'),
  mem x (map f m) = mem x m.
 Proof.
 intros; do 2 rewrite mem_find_b; rewrite map_o.
 destruct (find x m); simpl; auto.
 Qed.
 
-Lemma mapi_b : forall m x (f:key->elt->elt'), 
+Lemma mapi_b : forall m x (f:key->elt->elt'),
  mem x (mapi f m) = mem x m.
 Proof.
 intros.
@@ -480,12 +477,12 @@ symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto.
 rewrite <- H; rewrite H1; rewrite H0; auto.
 Qed.
 
-Lemma mapi_o : forall m x (f:key->elt->elt'), 
- (forall x y e, E.eq x y -> f x e = f y e) -> 
+Lemma mapi_o : forall m x (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) ->
  find x (mapi f m) = option_map (f x) (find x m).
 Proof.
 intros.
-generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) 
+generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x)
   (fun b => mapi_mapsto_iff m x b H).
 destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros.
 rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto.
@@ -496,9 +493,9 @@ rewrite H1 in H3; discriminate.
 rewrite <- H0; rewrite H2; exists e; rewrite H1; auto.
 Qed.
 
-Lemma map2_1bis : forall (m: t elt)(m': t elt') x 
- (f:option elt->option elt'->option elt''), 
- f None None = None -> 
+Lemma map2_1bis : forall (m: t elt)(m': t elt') x
+ (f:option elt->option elt'->option elt''),
+ f None None = None ->
  find x (map2 f m m') = f (find x m) (find x m').
 Proof.
 intros.
@@ -574,7 +571,7 @@ Qed.
 (** First, [Equal] is [Equiv] with Leibniz on elements. *)
 
 Lemma Equal_Equiv : forall (m m' : t elt),
-  Equal m m' <-> Equiv (@Logic.eq elt) m m'.
+  Equal m m' <-> Equiv Logic.eq m m'.
 Proof.
 intros. rewrite Equal_mapsto_iff. split; intros.
 split.
@@ -598,7 +595,7 @@ Section Cmp.
 Variable eq_elt : elt->elt->Prop.
 Variable cmp : elt->elt->bool.
 
-Definition compat_cmp := 
+Definition compat_cmp :=
  forall e e', cmp e e' = true <-> eq_elt e e'.
 
 Lemma Equiv_Equivb : compat_cmp ->
@@ -613,17 +610,17 @@ End Cmp.
 (** Composition of the two last results: relation between [Equal]
     and [Equivb]. *)
 
-Lemma Equal_Equivb : forall cmp, 
- (forall e e', cmp e e' = true <-> e = e') -> 
+Lemma Equal_Equivb : forall cmp,
+ (forall e e', cmp e e' = true <-> e = e') ->
  forall (m m':t elt), Equal m m' <-> Equivb cmp m m'.
 Proof.
  intros; rewrite Equal_Equiv.
  apply Equiv_Equivb; auto.
 Qed.
 
-Lemma Equal_Equivb_eqdec : 
+Lemma Equal_Equivb_eqdec :
  forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }),
- let cmp := fun e e' => if eq_elt_dec e e' then true else false in 
+ let cmp := fun e e' => if eq_elt_dec e e' then true else false in
  forall (m m':t elt), Equal m m' <-> Equivb cmp m m'.
 Proof.
 intros; apply Equal_Equivb.
@@ -638,11 +635,11 @@ End Equalities.
 Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m.
 Proof. red; reflexivity. Qed.
 
-Lemma Equal_sym : forall (elt:Type)(m m' : t elt), 
+Lemma Equal_sym : forall (elt:Type)(m m' : t elt),
  Equal m m' -> Equal m' m.
 Proof. unfold Equal; auto. Qed.
 
-Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), 
+Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt),
  Equal m m' -> Equal m' m'' -> Equal m m''.
 Proof. unfold Equal; congruence. Qed.
 
@@ -651,15 +648,15 @@ Proof.
 constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans].
 Qed.
 
-Add Relation key E.eq 
- reflexivity proved by E.eq_refl 
+Add Relation key E.eq
+ reflexivity proved by E.eq_refl
  symmetry proved by E.eq_sym
- transitivity proved by E.eq_trans 
+ transitivity proved by E.eq_trans
  as KeySetoid.
 
 Implicit Arguments Equal [[elt]].
 
-Add Parametric Relation (elt : Type) : (t elt) Equal  
+Add Parametric Relation (elt : Type) : (t elt) Equal
  reflexivity proved by (@Equal_refl elt)
  symmetry proved by (@Equal_sym elt)
  transitivity proved by (@Equal_trans elt)
@@ -673,7 +670,7 @@ rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition.
 Qed.
 
 Add Parametric Morphism elt : (@MapsTo elt)
- with signature E.eq ==> Leibniz ==> Equal ==> iff as MapsTo_m.
+ with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m.
 Proof.
 unfold Equal; intros k k' Hk e m m' Hm.
 rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm;
@@ -689,28 +686,28 @@ rewrite Hm in H0; eauto.
 Qed.
 
 Add Parametric Morphism elt : (@is_empty elt)
- with signature Equal ==> Leibniz as is_empty_m.
+ with signature Equal ==> eq as is_empty_m.
 Proof.
 intros m m' Hm.
 rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition.
 Qed.
 
 Add Parametric Morphism elt : (@mem elt)
- with signature E.eq ==> Equal ==> Leibniz as mem_m.
+ with signature E.eq ==> Equal ==> eq as mem_m.
 Proof.
 intros k k' Hk m m' Hm.
 rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition.
 Qed.
 
 Add Parametric Morphism elt : (@find elt)
- with signature E.eq ==> Equal ==> Leibniz as find_m.
+ with signature E.eq ==> Equal ==> eq as find_m.
 Proof.
 intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e.
 rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto.
 Qed.
 
 Add Parametric Morphism elt : (@add elt)
- with signature E.eq ==> Leibniz ==> Equal ==> Equal as add_m.
+ with signature E.eq ==> eq ==> Equal ==> Equal as add_m.
 Proof.
 intros k k' Hk e m m' Hm y.
 rewrite add_o, add_o; do 2 destruct eq_dec; auto.
@@ -728,7 +725,7 @@ elim n; rewrite Hk; auto.
 Qed.
 
 Add Parametric Morphism elt elt' : (@map elt elt')
- with signature Leibniz ==> Equal ==> Equal as map_m.
+ with signature eq ==> Equal ==> Equal as map_m.
 Proof.
 intros f m m' Hm y.
 rewrite map_o, map_o, Hm; auto.
@@ -763,6 +760,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Notation eqke := (@eq_key_elt elt).
   Notation eqk := (@eq_key elt).
 
+  Instance eqk_equiv : Equivalence eqk.
+  Proof. split; repeat red; eauto. Qed.
+
+  Instance eqke_equiv : Equivalence eqke.
+  Proof.
+   unfold eq_key_elt; split; repeat red; firstorder.
+   eauto with *.
+   congruence.
+  Qed.
+
   (** Complements about InA, NoDupA and findA *)
 
   Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l,
@@ -790,12 +797,12 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   intros. symmetry.
   unfold eqb.
   rewrite <- findA_NoDupA, InA_rev, findA_NoDupA
-   by eauto using NoDupA_rev; eauto.
+   by (eauto using NoDupA_rev with *); eauto.
   case_eq (findA (eqb k) (rev l)); auto.
   intros e.
   unfold eqb.
   rewrite <- findA_NoDupA, InA_rev, findA_NoDupA
-   by eauto using NoDupA_rev.
+   by (eauto using NoDupA_rev with *).
   intro Eq; rewrite Eq; auto.
   Qed.
 
@@ -896,9 +903,10 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' ->
              Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)).
    intros k e a m' m'' H ? ? ?; eapply Hstep; eauto.
-   revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto.
+   revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto with *.
   assert (Hdup : NoDupA eqk l).
-   unfold l. apply NoDupA_rev; try red; eauto. apply elements_3w.
+   unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *.
+   apply elements_3w.
   assert (Hsame : forall k, find k m = findA (eqb k) l).
    intros k. unfold l. rewrite elements_o, findA_rev; auto.
    apply elements_3w.
@@ -979,7 +987,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   set (l:=rev (elements m)).
   assert (Rstep' : forall k e a b, InA eqke (k,e) l ->
     R a b -> R (f k e a) (g k e b)) by
-    (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto).
+    (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto with *).
   clearbody l; clear Rstep m.
   induction l; simpl; auto.
   apply Rstep'; auto.
@@ -1020,7 +1028,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff.
   intro; elim (Heq k' e'); auto.
   intros k e a m' m'' _ _ Hadd Heq k'.
-  rewrite Hadd, 2 add_o, Heq; auto.
+  red in Heq. rewrite Hadd, 2 add_o, Heq; auto.
   Qed.
 
   Section Fold_More.
@@ -1034,8 +1042,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   (** This is more convenient than a [compat_op eqke ...].
       In fact, every [compat_op], [compat_bool], etc, should
-      become a [Morphism] someday. *)
-  Hypothesis Comp : Morphism (E.eq==>Leibniz==>eqA==>eqA) f.
+      become a [Proper] someday. *)
+  Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f.
 
   Lemma fold_init :
    forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i').
@@ -1086,77 +1094,53 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   contradict Hnotin; rewrite <- Hnotin; exists e0; auto.
   Qed.
 
+  Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map.
+
   Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 ->
    eqA (fold f m1 i) (fold f m2 i).
   Proof.
-  assert (eqke_refl : forall p, eqke p p).
-   red; auto.
-  assert (eqke_sym : forall p p', eqke p p' -> eqke p' p).
-   intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition.
-  assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p'').
-   intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl.
-   intuition; eauto; congruence.
   intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
-  apply fold_right_equivlistA_restr with
-    (R:=fun p p' => ~eqk p p') (eqA:=eqke) (eqB:=eqA); auto.
-  intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; simpl in *; apply Comp; auto.
-  unfold eq_key; auto.
-  intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl.
-   intuition eauto.
+  assert (NoDupA eqk (rev (elements m1))) by (auto with *).
+  assert (NoDupA eqk (rev (elements m2))) by (auto with *).
+  apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke);
+   auto with *.
+  intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto.
+  unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto.
   intros (k,e) (k',e'); unfold eq_key; simpl; auto.
-  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
-  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
-  apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto.
-  apply NoDupA_rev; try red; eauto. apply elements_3w.
-  red; intros.
-  do 2 rewrite InA_rev.
-  destruct x; do 2 rewrite <- elements_mapsto_iff.
-  do 2 rewrite find_mapsto_iff.
-  rewrite H; split; auto.
+  rewrite <- NoDupA_altdef; auto.
+  intros (k,e).
+  rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H;
+   auto with *.
   Qed.
 
   Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 ->
    eqA (fold f m2 i) (f k e (fold f m1 i)).
   Proof.
-  assert (eqke_refl : forall p, eqke p p).
-   red; auto.
-  assert (eqke_sym : forall p p', eqke p p' -> eqke p' p).
-   intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition.
-  assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p'').
-   intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl.
-   intuition; eauto; congruence.
   intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
   set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
   change (f k e (fold_right f' i (rev (elements m1))))
    with (f' (k,e) (fold_right f' i (rev (elements m1)))).
+  assert (NoDupA eqk (rev (elements m1))) by (auto with *).
+  assert (NoDupA eqk (rev (elements m2))) by (auto with *).
   apply fold_right_add_restr with
-    (R:=fun p p'=>~eqk p p')(eqA:=eqke)(eqB:=eqA); auto.
-  intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *. apply Comp; auto.
-
-  unfold eq_key; auto.
-  intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl.
-   intuition eauto.
+   (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *.
+  intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto.
+  unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto.
   unfold f'; intros (k1,e1) (k2,e2); unfold eq_key; simpl; auto.
-  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
-  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
-  apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto.
-  apply NoDupA_rev; try red; eauto. apply elements_3w.
-  rewrite InA_rev.
-  contradict H.
-  exists e.
-  rewrite elements_mapsto_iff; auto.
-  intros a.
-  rewrite InA_cons; do 2 rewrite InA_rev;
-  destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff.
-  do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl.
+  rewrite <- NoDupA_altdef; auto.
+  rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder.
+  intros (a,b).
+  rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff,
+   2 find_mapsto_iff by (auto with *).
+  unfold eq_key_elt; simpl.
   rewrite H0.
   rewrite add_o.
-  destruct (eq_dec k a); intuition.
-  inversion H1; auto.
-  f_equal; auto.
-  elim H.
-  exists b; apply MapsTo_1 with a; auto with map.
-  elim n; auto.
+  destruct (eq_dec k a) as [EQ|NEQ]; split; auto.
+  intros EQ'; inversion EQ'; auto.
+  intuition; subst; auto.
+  elim H. exists b; rewrite EQ; auto with map.
+  intuition.
+  elim NEQ; auto.
   Qed.
 
   Lemma fold_add : forall m k e i, ~In k m ->
@@ -1188,7 +1172,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
     Equal m m' -> cardinal m = cardinal m'.
   Proof.
   intros; do 2 rewrite cardinal_fold.
-  apply fold_Equal with (eqA:=Leibniz); compute; auto.
+  apply fold_Equal with (eqA:=eq); compute; auto.
   Qed.
 
   Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0.
@@ -1201,22 +1185,22 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Proof.
   intros; do 2 rewrite cardinal_fold.
   change S with ((fun _ _ => S) x e).
-  apply fold_Add with (eqA:=Leibniz); compute; auto.
+  apply fold_Add with (eqA:=eq); compute; auto.
   Qed.
 
-  Lemma cardinal_inv_1 : forall m : t elt, 
+  Lemma cardinal_inv_1 : forall m : t elt,
    cardinal m = 0 -> Empty m.
   Proof.
-  intros; rewrite cardinal_Empty; auto. 
+  intros; rewrite cardinal_Empty; auto.
   Qed.
   Hint Resolve cardinal_inv_1 : map.
 
   Lemma cardinal_inv_2 :
    forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }.
-  Proof. 
+  Proof.
   intros; rewrite M.cardinal_1 in *.
   generalize (elements_mapsto_iff m).
-  destruct (elements m); try discriminate. 
+  destruct (elements m); try discriminate.
   exists p; auto.
   rewrite H0; destruct p; simpl; auto.
   constructor; red; auto.
@@ -1242,16 +1226,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   (** * Emulation of some functions lacking in the interface *)
 
-  Definition filter (f : key -> elt -> bool)(m : t elt) := 
+  Definition filter (f : key -> elt -> bool)(m : t elt) :=
    fold (fun k e m => if f k e then add k e m else m) m (empty _).
 
-  Definition for_all (f : key -> elt -> bool)(m : t elt) := 
+  Definition for_all (f : key -> elt -> bool)(m : t elt) :=
    fold (fun k e b => if f k e then b else false) m true.
 
-  Definition exists_ (f : key -> elt -> bool)(m : t elt) := 
+  Definition exists_ (f : key -> elt -> bool)(m : t elt) :=
    fold (fun k e b => if f k e then true else b) m false.
 
-  Definition partition (f : key -> elt -> bool)(m : t elt) := 
+  Definition partition (f : key -> elt -> bool)(m : t elt) :=
    (filter f m, filter (fun k e => negb (f k e)) m).
 
   (** [update] adds to [m1] all the bindings of [m2]. It can be seen as
@@ -1272,7 +1256,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   Section Specs.
   Variable f : key -> elt -> bool.
-  Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f.
+  Hypothesis Hf : Proper (E.eq==>eq==>eq) f.
 
   Lemma filter_iff : forall m k e,
    MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true.
@@ -1315,8 +1299,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto.
   contradict Hn; exists e'; rewrite Hn; auto.
   (* f k e = false *)
-  split; intros H; try discriminate.
-  rewrite <- Hfke. apply H.
+  split; try discriminate.
+  intros Hmapsto. rewrite <- Hfke. apply Hmapsto.
   rewrite Hadd, add_mapsto_iff; auto.
   Qed.
 
@@ -1328,7 +1312,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   set (f':=fun k e b => if f k e then true else b).
   intro m. pattern m, (fold f' m false). apply fold_rec.
 
-  intros m' Hm'. split; try (intros; discriminate).
+  intros m' Hm'. split; try discriminate.
   intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto.
 
   intros k e b m1 m2 _ Hn Hadd IH. clear m.
@@ -1365,7 +1349,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   Section Partition.
   Variable f : key -> elt -> bool.
-  Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f.
+  Hypothesis Hf : Proper (E.eq==>eq==>eq) f.
 
   Lemma partition_iff_1 : forall m m1 k e,
    m1 = fst (partition f m) ->
@@ -1494,7 +1478,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
 
   Lemma Partition_fold :
    forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A),
-   Morphism (E.eq==>Leibniz==>eqA==>eqA) f ->
+   Proper (E.eq==>eq==>eqA==>eqA) f ->
    transpose_neqkey eqA f ->
    forall m m1 m2 i,
    Partition m m1 m2 ->
@@ -1547,9 +1531,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   set (f:=fun (_:key)(_:elt)=>S).
   setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)).
   rewrite <- cardinal_fold.
-  intros. apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto.
-  apply Partition_fold with (eqA:=@Logic.eq _); try red; auto.
-  compute; auto.
+  apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto.
+  apply Partition_fold with (eqA:=eq); repeat red; auto.
   Qed.
 
   Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 ->
@@ -1557,7 +1540,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
    Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)).
   Proof.
   intros m m1 m2 Hm f.
-  assert (Hf : Morphism (E.eq==>Leibniz==>Leibniz) f).
+  assert (Hf : Proper (E.eq==>eq==>eq) f).
    intros k k' Hk e e' _; unfold f; rewrite Hk; auto.
   set (m1':= fst (partition f m)).
   set (m2':= snd (partition f m)).
@@ -1673,7 +1656,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
  End Elt.
 
  Add Parametric Morphism elt : (@cardinal elt)
-   with signature Equal ==> Leibniz as cardinal_m.
+   with signature Equal ==> eq as cardinal_m.
  Proof. intros; apply Equal_cardinal; auto. Qed.
 
  Add Parametric Morphism elt : (@Disjoint elt)
@@ -1761,7 +1744,7 @@ Module OrdProperties (M:S).
  Import F.
  Import M.
 
- Section Elt. 
+ Section Elt.
   Variable elt:Type.
 
   Notation eqke := (@eqke elt).
@@ -1779,15 +1762,14 @@ Module OrdProperties (M:S).
   Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt),
    sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'.
   Proof.
-  apply SortA_equivlistA_eqlistA; eauto; 
-  unfold O.eqke, O.ltk; simpl; intuition; eauto.
+  apply SortA_equivlistA_eqlistA; eauto with *.
   Qed.
 
   Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto.
 
   Definition gtb (p p':key*elt) :=
     match E.compare (fst p) (fst p') with GT _ => true | _ => false end.
-  Definition leb p := fun p' => negb (gtb p p'). 
+  Definition leb p := fun p' => negb (gtb p p').
 
   Definition elements_lt p m := List.filter (gtb p) (elements m).
   Definition elements_ge p m := List.filter (leb p) (elements m).
@@ -1804,10 +1786,10 @@ Module OrdProperties (M:S).
    destruct (E.compare x y); intuition; try discriminate; ME.order.
   Qed.
 
-  Lemma gtb_compat : forall p, compat_bool eqke (gtb p).
+  Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p).
   Proof.
    red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H.
-   generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); 
+   generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e''));
     destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto.
    unfold O.ltk in *; simpl in *; intros.
    symmetry; rewrite H2.
@@ -1819,7 +1801,7 @@ Module OrdProperties (M:S).
    rewrite <- H2; auto.
   Qed.
 
-  Lemma leb_compat : forall p, compat_bool eqke (leb p).
+  Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p).
   Proof.
    red; intros x a b H.
    unfold leb; f_equal; apply gtb_compat; auto.
@@ -1827,11 +1809,11 @@ Module OrdProperties (M:S).
 
   Hint Resolve gtb_compat leb_compat elements_3 : map.
 
-  Lemma elements_split : forall p m, 
+  Lemma elements_split : forall p m,
     elements m = elements_lt p m ++ elements_ge p m.
   Proof.
   unfold elements_lt, elements_ge, leb; intros.
-  apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with map.
+  apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *.
   intros; destruct x; destruct y; destruct p.
   rewrite gtb_1 in H; unfold O.ltk in H; simpl in *.
   assert (~ltk (t1,e0) (k,e1)).
@@ -1840,19 +1822,19 @@ Module OrdProperties (M:S).
   unfold O.ltk in *; simpl in *; ME.order.
   Qed.
 
-  Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> 
-    eqlistA eqke (elements m') 
+  Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' ->
+    eqlistA eqke (elements m')
                  (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m).
   Proof.
   intros; unfold elements_lt, elements_ge.
-  apply sort_equivlistA_eqlistA; auto with map.
-  apply (@SortA_app _ eqke); auto with map.
-  apply (@filter_sort _ eqke); auto with map; clean_eauto.
+  apply sort_equivlistA_eqlistA; auto with *.
+  apply (@SortA_app _ eqke); auto with *.
+  apply (@filter_sort _ eqke); auto with *; clean_eauto.
   constructor; auto with map.
-  apply (@filter_sort _ eqke); auto with map; clean_eauto.
-  rewrite (@InfA_alt _ eqke); auto with map; try (clean_eauto; fail).
+  apply (@filter_sort _ eqke); auto with *; clean_eauto.
+  rewrite (@InfA_alt _ eqke); auto with *; try (clean_eauto; fail).
   intros.
-  rewrite filter_InA in H1; auto with map; destruct H1.
+  rewrite filter_InA in H1; auto with *; destruct H1.
   rewrite leb_1 in H2.
   destruct y; unfold O.ltk in *; simpl in *.
   rewrite <- elements_mapsto_iff in H1.
@@ -1860,24 +1842,22 @@ Module OrdProperties (M:S).
    contradict H.
    exists e0; apply MapsTo_1 with t0; auto.
   ME.order.
-  apply (@filter_sort _ eqke); auto with map; clean_eauto.
+  apply (@filter_sort _ eqke); auto with *; clean_eauto.
   intros.
-  rewrite filter_InA in H1; auto with map; destruct H1.
+  rewrite filter_InA in H1; auto with *; destruct H1.
   rewrite gtb_1 in H3.
   destruct y; destruct x0; unfold O.ltk in *; simpl in *.
   inversion_clear H2.
   red in H4; simpl in *; destruct H4.
   ME.order.
-  rewrite filter_InA in H4; auto with map; destruct H4.
+  rewrite filter_InA in H4; auto with *; destruct H4.
   rewrite leb_1 in H4.
   unfold O.ltk in *; simpl in *; ME.order.
   red; intros a; destruct a.
-  rewrite InA_app_iff; rewrite InA_cons.
-  do 2 (rewrite filter_InA; auto with map).
-  do 2 rewrite <- elements_mapsto_iff.
-  rewrite leb_1; rewrite gtb_1.
-  rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff.
-  rewrite add_mapsto_iff.
+  rewrite InA_app_iff, InA_cons, 2 filter_InA,
+    <-2 elements_mapsto_iff, leb_1, gtb_1,
+    find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+    add_mapsto_iff by (auto with *).
   unfold O.eqke, O.ltk; simpl.
   destruct (E.compare t0 x); intuition.
   right; split; auto; ME.order.
@@ -1889,13 +1869,13 @@ Module OrdProperties (M:S).
   right; split; auto; ME.order.
   Qed.
 
-  Lemma elements_Add_Above : forall m m' x e, 
-   Above x m -> Add x e m m' -> 
+  Lemma elements_Add_Above : forall m m' x e,
+   Above x m -> Add x e m m' ->
      eqlistA eqke (elements m') (elements m ++ (x,e)::nil).
   Proof.
   intros.
-  apply sort_equivlistA_eqlistA; auto with map.
-  apply (@SortA_app _ eqke); auto with map.
+  apply sort_equivlistA_eqlistA; auto with *.
+  apply (@SortA_app _ eqke); auto with *.
   intros.
   inversion_clear H2.
   destruct x0; destruct y.
@@ -1905,27 +1885,26 @@ Module OrdProperties (M:S).
   apply H; firstorder.
   inversion H3.
   red; intros a; destruct a.
-  rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil.
-  do 2 rewrite <- elements_mapsto_iff.
-  rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff.
-  rewrite add_mapsto_iff; unfold O.eqke; simpl.
-  intuition.
+  rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff,
+   find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+   add_mapsto_iff by (auto with *).
+  unfold O.eqke; simpl. intuition.
   destruct (E.eq_dec x t0); auto.
-  elimtype False.
+  exfalso.
   assert (In t0 m).
    exists e0; auto.
   generalize (H t0 H1).
   ME.order.
   Qed.
 
-  Lemma elements_Add_Below : forall m m' x e, 
-   Below x m -> Add x e m m' -> 
+  Lemma elements_Add_Below : forall m m' x e,
+   Below x m -> Add x e m m' ->
      eqlistA eqke (elements m') ((x,e)::elements m).
   Proof.
   intros.
-  apply sort_equivlistA_eqlistA; auto with map.
+  apply sort_equivlistA_eqlistA; auto with *.
   change (sort ltk (((x,e)::nil) ++ elements m)).
-  apply (@SortA_app _ eqke); auto with map.
+  apply (@SortA_app _ eqke); auto with *.
   intros.
   inversion_clear H1.
   destruct y; destruct x0.
@@ -1935,24 +1914,23 @@ Module OrdProperties (M:S).
   apply H; firstorder.
   inversion H3.
   red; intros a; destruct a.
-  rewrite InA_cons.
-  do 2 rewrite <- elements_mapsto_iff.
-  rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff.
-  rewrite add_mapsto_iff; unfold O.eqke; simpl.
-  intuition.
+  rewrite InA_cons, <- 2 elements_mapsto_iff,
+    find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+    add_mapsto_iff by (auto with *).
+  unfold O.eqke; simpl. intuition.
   destruct (E.eq_dec x t0); auto.
-  elimtype False.
+  exfalso.
   assert (In t0 m).
    exists e0; auto.
   generalize (H t0 H1).
   ME.order.
   Qed.
 
-  Lemma elements_Equal_eqlistA : forall (m m': t elt), 
+  Lemma elements_Equal_eqlistA : forall (m m': t elt),
    Equal m m' -> eqlistA eqke (elements m) (elements m').
   Proof.
   intros.
-  apply sort_equivlistA_eqlistA; auto with map.
+  apply sort_equivlistA_eqlistA; auto with *.
   red; intros.
   destruct x; do 2 rewrite <- elements_mapsto_iff.
   do 2 rewrite find_mapsto_iff; rewrite H; split; auto.
@@ -1963,15 +1941,15 @@ Module OrdProperties (M:S).
   Section Min_Max_Elt.
 
   (** We emulate two [max_elt] and [min_elt] functions. *)
-  
-  Fixpoint max_elt_aux (l:list (key*elt)) := match l with 
-    | nil => None 
+
+  Fixpoint max_elt_aux (l:list (key*elt)) := match l with
+    | nil => None
     | (x,e)::nil => Some (x,e)
     | (x,e)::l => max_elt_aux l
     end.
   Definition max_elt m := max_elt_aux (elements m).
 
-  Lemma max_elt_Above : 
+  Lemma max_elt_Above :
    forall m x e, max_elt m = Some (x,e) -> Above x (remove x m).
   Proof.
   red; intros.
@@ -2010,8 +1988,8 @@ Module OrdProperties (M:S).
   red; eauto.
   inversion H2; auto.
   Qed.
-  
-  Lemma max_elt_MapsTo : 
+
+  Lemma max_elt_MapsTo :
    forall m x e, max_elt m = Some (x,e) -> MapsTo x e m.
   Proof.
   intros.
@@ -2024,7 +2002,7 @@ Module OrdProperties (M:S).
   constructor 2; auto.
   Qed.
 
-  Lemma max_elt_Empty : 
+  Lemma max_elt_Empty :
    forall m, max_elt m = None -> Empty m.
   Proof.
   intros.
@@ -2035,12 +2013,12 @@ Module OrdProperties (M:S).
   assert (H':=IHl H); discriminate.
   Qed.
 
-  Definition min_elt m : option (key*elt) := match elements m with 
+  Definition min_elt m : option (key*elt) := match elements m with
    | nil => None
    | (x,e)::_ => Some (x,e)
   end.
 
-  Lemma min_elt_Below : 
+  Lemma min_elt_Below :
    forall m x e, min_elt m = Some (x,e) -> Below x (remove x m).
   Proof.
   unfold min_elt, Below; intros.
@@ -2054,14 +2032,11 @@ Module OrdProperties (M:S).
   inversion_clear H1.
   red in H2; destruct H2; simpl in *; ME.order.
   inversion_clear H4.
-  rewrite (@InfA_alt _ eqke) in H3; eauto.
+  rewrite (@InfA_alt _ eqke) in H3; eauto with *.
   apply (H3 (y,x0)); auto.
-  unfold lt_key; simpl; intuition; eauto.
-  intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto.
-  intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto.
   Qed.
-  
-  Lemma min_elt_MapsTo : 
+
+  Lemma min_elt_MapsTo :
    forall m x e, min_elt m = Some (x,e) -> MapsTo x e m.
   Proof.
   intros.
@@ -2073,7 +2048,7 @@ Module OrdProperties (M:S).
   injection H; intros; subst; constructor; red; auto.
   Qed.
 
-  Lemma min_elt_Empty : 
+  Lemma min_elt_Empty :
    forall m, min_elt m = None -> Empty m.
   Proof.
   intros.
@@ -2108,7 +2083,7 @@ Module OrdProperties (M:S).
   assert (S n = S (cardinal (remove k m))).
    rewrite Heqn.
    eapply cardinal_2; eauto with map.
-  inversion H1; auto. 
+  inversion H1; auto.
   eapply max_elt_Above; eauto.
 
   apply X; apply max_elt_Empty; auto.
@@ -2135,7 +2110,7 @@ Module OrdProperties (M:S).
   assert (S n = S (cardinal (remove k m))).
    rewrite Heqn.
    eapply cardinal_2; eauto with map.
-  inversion H1; auto. 
+  inversion H1; auto.
   eapply min_elt_Below; eauto.
 
   apply X; apply min_elt_Empty; auto.
@@ -2150,7 +2125,7 @@ Module OrdProperties (M:S).
 
   Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence  eqA)
    (f:key->elt->A->A)(i:A),
-   Morphism (E.eq==>Leibniz==>eqA==>eqA) f ->
+   Proper (E.eq==>eq==>eqA==>eqA) f ->
    Equal m1 m2 ->
    eqA (fold f m1 i) (fold f m2 i).
   Proof.
@@ -2158,13 +2133,12 @@ Module OrdProperties (M:S).
   do 2 rewrite fold_1.
   do 2 rewrite <- fold_left_rev_right.
   apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
-  intros (k,e) (k',e') a a' (Hk,He) Ha; simpl in *; apply Hf; auto.
+  intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto.
   apply eqlistA_rev. apply elements_Equal_eqlistA. auto.
   Qed.
 
   Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
-   (f:key->elt->A->A)(i:A),
-   Morphism (E.eq==>Leibniz==>eqA==>eqA) f ->
+   (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f),
    Above x m1 -> Add x e m1 m2 ->
    eqA (fold f m2 i) (f x e (fold f m1 i)).
   Proof.
@@ -2172,7 +2146,7 @@ Module OrdProperties (M:S).
   set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
   transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))).
   apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
-  intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto.
+  intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto.
   apply eqlistA_rev.
   apply elements_Add_Above; auto.
   rewrite distr_rev; simpl.
@@ -2180,8 +2154,7 @@ Module OrdProperties (M:S).
   Qed.
 
   Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
-   (f:key->elt->A->A)(i:A),
-   Morphism (E.eq==>Leibniz==>eqA==>eqA) f ->
+   (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f),
    Below x m1 -> Add x e m1 m2 ->
    eqA (fold f m2 i) (fold f m1 (f x e i)).
   Proof.
@@ -2189,7 +2162,7 @@ Module OrdProperties (M:S).
   set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
   transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))).
   apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
-  intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto.
+  intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto.
   apply eqlistA_rev.
   simpl; apply elements_Add_Below; auto.
   rewrite distr_rev; simpl.
diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v
index 57cbbcc4..e4f8b4df 100644
--- a/theories/FSets/FMapFullAVL.v
+++ b/theories/FSets/FMapFullAVL.v
@@ -1,4 +1,3 @@
-
 (***********************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
 (* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
@@ -9,26 +8,26 @@
 
 (* Finite map library.  *)
 
-(* $Id: FMapFullAVL.v 10748 2008-04-03 18:28:26Z letouzey $ *)
+(* $Id$ *)
 
 (** * FMapFullAVL
-   
+
    This file contains some complements to [FMapAVL].
 
-   - Functor [AvlProofs] proves that trees of [FMapAVL] are not only 
+   - Functor [AvlProofs] proves that trees of [FMapAVL] are not only
    binary search trees, but moreover well-balanced ones. This is done
    by proving that all operations preserve the balancing.
-  
-   - We then pack the previous elements in a [IntMake] functor 
+
+   - We then pack the previous elements in a [IntMake] functor
    similar to the one of [FMapAVL], but richer.
 
-   - In final [IntMake_ord] functor, the [compare] function is 
-   different from the one in [FMapAVL]: this non-structural 
+   - In final [IntMake_ord] functor, the [compare] function is
+   different from the one in [FMapAVL]: this non-structural
    version is closer to the original Ocaml code.
 
 *)
 
-Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL.
+Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL ROmega.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
@@ -40,6 +39,8 @@ Import Raw.Proofs.
 Open Local Scope pair_scope.
 Open Local Scope Int_scope.
 
+Ltac omega_max := i2z_refl; romega with Z.
+
 Section Elt.
 Variable elt : Type.
 Implicit Types m r : t elt.
@@ -52,11 +53,11 @@ Implicit Types m r : t elt.
 
 Inductive avl : t elt -> Prop :=
   | RBLeaf : avl (Leaf _)
-  | RBNode : forall x e l r h, 
+  | RBNode : forall x e l r h,
       avl l ->
       avl r ->
       -(2) <= height l - height r <= 2 ->
-      h = max (height l) (height r) + 1 -> 
+      h = max (height l) (height r) + 1 ->
       avl (Node l x e r h).
 
 
@@ -64,28 +65,28 @@ Inductive avl : t elt -> Prop :=
 
 Hint Constructors avl.
 
-Lemma height_non_negative : forall (s : t elt), avl s -> 
+Lemma height_non_negative : forall (s : t elt), avl s ->
  height s >= 0.
 Proof.
  induction s; simpl; intros; auto with zarith.
  inv avl; intuition; omega_max.
 Qed.
 
-Ltac avl_nn_hyp H := 
+Ltac avl_nn_hyp H :=
      let nz := fresh "nz" in assert (nz := height_non_negative H).
 
-Ltac avl_nn h := 
-  let t := type of h in 
-  match type of t with 
+Ltac avl_nn h :=
+  let t := type of h in
+  match type of t with
    | Prop => avl_nn_hyp h
    | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
   end.
 
-(* Repeat the previous tactic. 
+(* Repeat the previous tactic.
    Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
 
 Ltac avl_nns :=
-  match goal with 
+  match goal with
      | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
      | _ => idtac
   end.
@@ -103,49 +104,49 @@ Hint Resolve avl_node.
 
 (** Results about [height] *)
 
-Lemma height_0 : forall l, avl l -> height l = 0 -> 
+Lemma height_0 : forall l, avl l -> height l = 0 ->
  l = Leaf _.
 Proof.
  destruct 1; intuition; simpl in *.
- avl_nns; simpl in *; elimtype False; omega_max.
+ avl_nns; simpl in *; exfalso; omega_max.
 Qed.
 
 
 (** * Empty map *)
 
 Lemma empty_avl : avl (empty elt).
-Proof. 
+Proof.
  unfold empty; auto.
 Qed.
 
 
 (** * Helper functions *)
 
-Lemma create_avl : 
- forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+Lemma create_avl :
+ forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
  avl (create l x e r).
 Proof.
  unfold create; auto.
 Qed.
 
-Lemma create_height : 
- forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+Lemma create_height :
+ forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
  height (create l x e r) = max (height l) (height r) + 1.
 Proof.
  unfold create; intros; auto.
 Qed.
 
-Lemma bal_avl : forall l x e r, avl l -> avl r -> 
+Lemma bal_avl : forall l x e r, avl l -> avl r ->
  -(3) <= height l - height r <= 3 -> avl (bal l x e r).
 Proof.
  intros l x e r; functional induction (bal l x e r); intros; clearf;
- inv avl; simpl in *; 
+ inv avl; simpl in *;
  match goal with |- avl (assert_false _ _ _ _) => avl_nns
   | _ => repeat apply create_avl; simpl in *; auto
  end; omega_max.
 Qed.
 
-Lemma bal_height_1 : forall l x e r, avl l -> avl r -> 
+Lemma bal_height_1 : forall l x e r, avl l -> avl r ->
  -(3) <= height l - height r <= 3 ->
  0 <= height (bal l x e r) - max (height l) (height r) <= 1.
 Proof.
@@ -153,25 +154,25 @@ Proof.
  inv avl; avl_nns; simpl in *; omega_max.
 Qed.
 
-Lemma bal_height_2 : 
- forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> 
+Lemma bal_height_2 :
+ forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 ->
  height (bal l x e r) == max (height l) (height r) +1.
 Proof.
  intros l x e r; functional induction (bal l x e r); intros; clearf;
  inv avl; avl_nns; simpl in *; omega_max.
 Qed.
 
-Ltac omega_bal := match goal with 
-  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => 
-     generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); 
+Ltac omega_bal := match goal with
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] =>
+     generalize (bal_height_1 x e H H') (bal_height_2 x e H H');
      omega_max
   end.
 
 (** * Insertion *)
 
-Lemma add_avl_1 :  forall m x e, avl m -> 
+Lemma add_avl_1 :  forall m x e, avl m ->
  avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
-Proof. 
+Proof.
  intros m x e; functional induction (add x e m); intros; inv avl; simpl in *.
  intuition; try constructor; simpl; auto; try omega_max.
  (* LT *)
@@ -196,8 +197,8 @@ Hint Resolve add_avl.
 
 (** * Extraction of minimum binding *)
 
-Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> 
- avl (remove_min l x e r)#1 /\ 
+Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) ->
+ avl (remove_min l x e r)#1 /\
  0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1.
 Proof.
  intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
@@ -210,20 +211,20 @@ Proof.
  omega_bal.
 Qed.
 
-Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> 
-    avl (remove_min l x e r)#1. 
+Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) ->
+    avl (remove_min l x e r)#1.
 Proof.
  intros; generalize (remove_min_avl_1 H); intuition.
 Qed.
 
 (** * Merging two trees *)
 
-Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> 
- -(2) <= height m1 - height m2 <= 2 -> 
- avl (merge m1 m2) /\ 
+Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 ->
+ -(2) <= height m1 - height m2 <= 2 ->
+ avl (merge m1 m2) /\
  0<= height (merge m1 m2) - max (height m1) (height m2) <=1.
 Proof.
- intros m1 m2; functional induction (merge m1 m2); intros; 
+ intros m1 m2; functional induction (merge m1 m2); intros;
  try factornode _x _x0 _x1 _x2 _x3 as m1.
  simpl; split; auto; avl_nns; omega_max.
  simpl; split; auto; avl_nns; omega_max.
@@ -235,16 +236,16 @@ Proof.
  omega_bal.
 Qed.
 
-Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> 
+Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 ->
   -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2).
-Proof. 
+Proof.
  intros; generalize (merge_avl_1 H H0 H1); intuition.
 Qed.
 
 
 (** * Deletion *)
 
-Lemma remove_avl_1 : forall m x, avl m -> 
+Lemma remove_avl_1 : forall m x, avl m ->
  avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1.
 Proof.
  intros m x; functional induction (remove x m); intros.
@@ -252,25 +253,25 @@ Proof.
  (* LT *)
  inv avl.
  destruct (IHt H0).
- split. 
+ split.
  apply bal_avl; auto.
  omega_max.
  omega_bal.
  (* EQ *)
- inv avl. 
+ inv avl.
  generalize (merge_avl_1 H0 H1 H2).
  intuition omega_max.
  (* GT *)
  inv avl.
  destruct (IHt H1).
- split. 
+ split.
  apply bal_avl; auto.
  omega_max.
  omega_bal.
 Qed.
 
 Lemma remove_avl : forall m x, avl m -> avl (remove x m).
-Proof. 
+Proof.
  intros; generalize (remove_avl_1 x H); intuition.
 Qed.
 Hint Resolve remove_avl.
@@ -278,7 +279,7 @@ Hint Resolve remove_avl.
 
 (** * Join *)
 
-Lemma join_avl_1 : forall l x d r, avl l -> avl r -> 
+Lemma join_avl_1 : forall l x d r, avl l -> avl r ->
  avl (join l x d r) /\
  0<= height (join l x d r) - max (height l) (height r) <= 1.
 Proof.
@@ -344,9 +345,9 @@ Hint Resolve concat_avl.
 
 (** split *)
 
-Lemma split_avl : forall m x, avl m -> 
+Lemma split_avl : forall m x, avl m ->
   avl (split x m)#l /\ avl (split x m)#r.
-Proof. 
+Proof.
  intros m x; functional induction (split x m); simpl; auto.
  rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
  simpl; inversion_clear 1; auto.
@@ -356,12 +357,12 @@ Qed.
 End Elt.
 Hint Constructors avl.
 
-Section Map. 
+Section Map.
 Variable elt elt' : Type.
-Variable f : elt -> elt'. 
+Variable f : elt -> elt'.
 
 Lemma map_height : forall m, height (map f m) = height m.
-Proof. 
+Proof.
 destruct m; simpl; auto.
 Qed.
 
@@ -375,10 +376,10 @@ End Map.
 
 Section Mapi.
 Variable elt elt' : Type.
-Variable f : key -> elt -> elt'. 
+Variable f : key -> elt -> elt'.
 
 Lemma mapi_height : forall m, height (mapi f m) = height m.
-Proof. 
+Proof.
 destruct m; simpl; auto.
 Qed.
 
@@ -390,7 +391,7 @@ Qed.
 
 End Mapi.
 
-Section Map_option. 
+Section Map_option.
 Variable elt elt' : Type.
 Variable f : key -> elt -> option elt'.
 
@@ -412,12 +413,12 @@ Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m').
 
 Notation map2_opt := (map2_opt f mapl mapr).
 
-Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> 
+Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 ->
  avl (map2_opt m1 m2).
 Proof.
-intros m1 m2; functional induction (map2_opt m1 m2); auto; 
-factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; 
-destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; 
+intros m1 m2; functional induction (map2_opt m1 m2); auto;
+factornode _x0 _x1 _x2 _x3 _x4 as r2; intros;
+destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl;
 auto using join_avl, concat_avl.
 Qed.
 
@@ -437,11 +438,11 @@ End AvlProofs.
 
 (** * Encapsulation
 
-   We can implement [S] with balanced binary search trees. 
+   We can implement [S] with balanced binary search trees.
    When compared to [FMapAVL], we maintain here two invariants
    (bst and avl) instead of only bst, which is enough for fulfilling
    the FMap interface.
-*) 
+*)
 
 Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 
@@ -450,32 +451,32 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Import Raw.
  Import Raw.Proofs.
 
- Record bbst (elt:Type) := 
+ Record bbst (elt:Type) :=
   Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}.
- 
+
  Definition t := bbst.
  Definition key := E.t.
- 
+
  Section Elt.
  Variable elt elt' elt'': Type.
 
  Implicit Types m : t elt.
- Implicit Types x y : key. 
- Implicit Types e : elt. 
+ Implicit Types x y : key.
+ Implicit Types e : elt.
 
  Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt).
  Definition is_empty m : bool := is_empty m.(this).
- Definition add x e m : t elt := 
+ Definition add x e m : t elt :=
   Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)).
- Definition remove x m : t elt := 
+ Definition remove x m : t elt :=
   Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)).
  Definition mem x m : bool := mem x m.(this).
  Definition find x m : option elt := find x m.(this).
- Definition map f m : t elt' := 
+ Definition map f m : t elt' :=
   Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
- Definition mapi (f:key->elt->elt') m : t elt' := 
+ Definition mapi (f:key->elt->elt') m : t elt' :=
   Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)).
- Definition map2 f m (m':t elt') : t elt'' := 
+ Definition map2 f m (m':t elt') : t elt'' :=
   Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)).
  Definition elements m : list (key*elt) := elements m.(this).
  Definition cardinal m := cardinal m.(this).
@@ -492,14 +493,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 
  Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed.
- 
+
  Lemma mem_1 : forall m x, In x m -> mem x m = true.
  Proof.
  unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto.
  apply m.(is_bst).
  Qed.
- 
- Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof.
  unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
  Qed.
@@ -530,7 +531,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed.
 
 
- Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
  Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed.
  Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
  Proof. intros m; exact (@find_2 elt m.(this)). Qed.
@@ -539,36 +540,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
         fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed.
 
- Lemma elements_1 : forall m x e,       
+ Lemma elements_1 : forall m x e,
    MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
  intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto.
  Qed.
 
- Lemma elements_2 : forall m x e,   
+ Lemma elements_2 : forall m x e,
    InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
  intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto.
  Qed.
 
- Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Lemma elements_3 : forall m, sort lt_key (elements m).
  Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed.
 
- Lemma elements_3w : forall m, NoDupA eq_key (elements m).  
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
  Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed.
 
  Lemma cardinal_1 : forall m, cardinal m = length (elements m).
  Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed.
 
  Definition Equal m m' := forall y, find y m = find y m'.
- Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
-   (forall k, In k m <-> In k m') /\ 
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+   (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb cmp := Equiv (Cmp cmp).
 
- Lemma Equivb_Equivb : forall cmp m m', 
+ Lemma Equivb_Equivb : forall cmp m m',
   Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
- Proof. 
+ Proof.
  intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
  generalize (H0 k); do 2 rewrite In_alt; intuition.
  generalize (H0 k); do 2 rewrite In_alt; intuition.
@@ -576,23 +577,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  generalize (H0 k); do 2 rewrite <- In_alt; intuition.
  Qed.
 
- Lemma equal_1 : forall m m' cmp, 
-   Equivb cmp m m' -> equal cmp m m' = true. 
- Proof. 
- unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; 
+ Lemma equal_1 : forall m m' cmp,
+   Equivb cmp m m' -> equal cmp m m' = true.
+ Proof.
+ unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
   intros; simpl in *; rewrite equal_Equivb; auto.
- Qed. 
+ Qed.
 
- Lemma equal_2 : forall m m' cmp, 
+ Lemma equal_2 : forall m m' cmp,
    equal cmp m m' = true -> Equivb cmp m m'.
- Proof. 
- unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; 
+ Proof.
+ unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
   intros; simpl in *; rewrite <-equal_Equivb; auto.
  Qed.
 
  End Elt.
 
- Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
         MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed.
 
@@ -600,10 +601,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Proof.
  intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
  apply map_2; auto.
- Qed. 
+ Qed.
 
  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
-        (f:key->elt->elt'), MapsTo x e m -> 
+        (f:key->elt->elt'), MapsTo x e m ->
         exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed.
  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
@@ -613,10 +614,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Qed.
 
  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-    (x:key)(f:option elt->option elt'->option elt''), 
-    In x m \/ In x m' -> 
-    find x (map2 f m m') = f (find x m) (find x m'). 
- Proof. 
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x m \/ In x m' ->
+    find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
  unfold find, map2, In; intros elt elt' elt'' m m' x f.
  do 2 rewrite In_alt; intros; simpl; apply map2_1; auto.
  apply m.(is_bst).
@@ -624,9 +625,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Qed.
 
  Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-     (x:key)(f:option elt->option elt'->option elt''), 
+     (x:key)(f:option elt->option elt'->option elt''),
      In x (map2 f m m') -> In x m \/ In x m'.
- Proof. 
+ Proof.
  unfold In, map2; intros elt elt' elt'' m m' x f.
  do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
  apply m.(is_bst).
@@ -636,54 +637,54 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 End IntMake.
 
 
-Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: 
-    Sord with Module Data := D 
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
+    Sord with Module Data := D
             with Module MapS.E := X.
 
   Module Data := D.
-  Module Import MapS := IntMake(I)(X). 
+  Module Import MapS := IntMake(I)(X).
   Import AvlProofs.
   Import Raw.Proofs.
   Module Import MD := OrderedTypeFacts(D).
   Module LO := FMapList.Make_ord(X)(D).
 
-  Definition t := MapS.t D.t. 
+  Definition t := MapS.t D.t.
 
-  Definition cmp e e' := 
+  Definition cmp e e' :=
    match D.compare e e' with EQ _ => true | _ => false end.
 
-  Definition elements (m:t) := 
+  Definition elements (m:t) :=
     LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)).
 
-  (** * As comparison function, we propose here a non-structural 
-    version faithful to the code of Ocaml's Map library, instead of 
+  (** * As comparison function, we propose here a non-structural
+    version faithful to the code of Ocaml's Map library, instead of
     the structural version of FMapAVL *)
 
-  Fixpoint cardinal_e (e:Raw.enumeration D.t) := 
-    match e with 
+  Fixpoint cardinal_e (e:Raw.enumeration D.t) :=
+    match e with
      | Raw.End => 0%nat
      | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e)
     end.
 
-  Lemma cons_cardinal_e : forall m e, 
+  Lemma cons_cardinal_e : forall m e,
    cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat.
   Proof.
    induction m; simpl; intros; auto.
    rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith.
   Qed.
 
-  Definition cardinal_e_2 ee := 
+  Definition cardinal_e_2 ee :=
    (cardinal_e (fst ee) + cardinal_e (snd ee))%nat.
 
-  Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) 
-   { measure cardinal_e_2 ee } : comparison := 
-  match ee with 
+  Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t)
+   { measure cardinal_e_2 ee } : comparison :=
+  match ee with
   | (Raw.End, Raw.End) => Eq
   | (Raw.End, Raw.More _ _ _ _) => Lt
   | (Raw.More _ _ _ _, Raw.End) => Gt
   | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) =>
       match X.compare x1 x2 with
-      | EQ _ => match D.compare d1 d2 with 
+      | EQ _ => match D.compare d1 d2 with
                 | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2)
                 | LT _ => Lt
                 | GT _ => Gt
@@ -693,10 +694,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
       end
   end.
   Proof.
-  intros; unfold cardinal_e_2; simpl; 
+  intros; unfold cardinal_e_2; simpl;
   abstract (do 2 rewrite cons_cardinal_e; romega with * ).
   Defined.
-  
+
   Definition Cmp c :=
    match c with
     | Eq => LO.eq_list
@@ -704,7 +705,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
     | Gt => (fun l1 l2 => LO.lt_list l2 l1)
    end.
 
-  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, 
+  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2,
    X.eq x1 x2 -> D.eq d1 d2 ->
    Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
   Proof.
@@ -712,23 +713,23 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
   Qed.
   Hint Resolve cons_Cmp.
 
-  Lemma compare_aux_Cmp : forall e, 
+  Lemma compare_aux_Cmp : forall e,
    Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)).
   Proof.
-  intros e; functional induction (compare_aux e); simpl in *; 
+  intros e; functional induction (compare_aux e); simpl in *;
    auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto.
   rewrite 2 cons_1 in IHc; auto.
   Qed.
 
-  Lemma compare_Cmp : forall m1 m2, 
-    Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) 
+  Lemma compare_Cmp : forall m1 m2,
+    Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _)))
      (Raw.elements m1) (Raw.elements m2).
   Proof.
-  intros. 
+  intros.
   assert (H1:=cons_1 m1 (Raw.End _)).
   assert (H2:=cons_1 m2 (Raw.End _)).
   simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2.
-  apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), 
+  apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _),
                            Raw.cons m2 (Raw.End _))).
   Qed.
 
@@ -737,15 +738,15 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Definition compare (s s':t) : Compare lt eq s s'.
   Proof.
-   intros (s,b,a) (s',b',a').
+   destruct s as (s,b,a), s' as (s',b',a').
    generalize (compare_Cmp s s').
    destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto.
   Defined.
 
-    
+
   (* Proofs about [eq] and [lt] *)
 
-  Definition selements (m1 : t) := 
+  Definition selements (m1 : t) :=
    LO.MapS.Build_slist (elements_sort m1.(is_bst)).
 
   Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
@@ -782,7 +783,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
   Qed.
 
   Lemma eq_refl : forall m : t, eq m m.
-  Proof. 
+  Proof.
   intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
   Qed.
 
@@ -799,13 +800,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
   Proof.
-  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;  
+  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;
    intros; eapply LO.lt_trans; eauto.
   Qed.
 
   Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
   Proof.
-  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; 
+  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq;
    intros; apply LO.lt_not_eq; auto.
   Qed.
 
@@ -816,8 +817,8 @@ End IntMake_ord.
 Module Make (X: OrderedType) <: S with Module E := X
  :=IntMake(Z_as_Int)(X).
 
-Module Make_ord (X: OrderedType)(D: OrderedType) 
- <: Sord with Module Data := D 
+Module Make_ord (X: OrderedType)(D: OrderedType)
+ <: Sord with Module Data := D
             with Module MapS.E := X
  :=IntMake_ord(Z_as_Int)(X)(D).
 
diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v
index ebdc9c57..e60cca9d 100644
--- a/theories/FSets/FMapInterface.v
+++ b/theories/FSets/FMapInterface.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapInterface.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(* $Id$ *)
 
-(** * Finite map library *)  
+(** * Finite map library *)
 
 (** This file proposes interfaces for finite maps *)
 
@@ -16,8 +16,8 @@ Require Export Bool DecidableType OrderedType.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** When compared with Ocaml Map, this signature has been split in 
-    several parts : 
+(** When compared with Ocaml Map, this signature has been split in
+    several parts :
 
    - The first parts [WSfun] and [WS] propose signatures for weak
      maps, which are maps with no ordering on the key type nor the
@@ -29,18 +29,18 @@ Unset Strict Implicit.
      (add, find, ...). The only function that asks for more is
      [equal], whose first argument should be a comparison on data.
 
-   - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the 
-     case where the key type is ordered. The main novelty is that 
+   - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the
+     case where the key type is ordered. The main novelty is that
      [elements] is required to produce sorted lists.
 
-   - Finally, [Sord] extends [S] with a complete comparison function. For 
-     that, the data type should have a decidable total ordering as well. 
+   - Finally, [Sord] extends [S] with a complete comparison function. For
+     that, the data type should have a decidable total ordering as well.
 
    If unsure, what you're looking for is probably [S]: apart from [Sord],
-   all other signatures are subsets of [S]. 
+   all other signatures are subsets of [S].
+
+   Some additional differences with Ocaml:
 
-   Some additional differences with Ocaml: 
-    
     - no [iter] function, useless since Coq is purely functional
     - [option] types are used instead of [Not_found] exceptions
     - more functions are provided: [elements] and [cardinal] and [map2]
@@ -51,7 +51,7 @@ Unset Strict Implicit.
 Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.
 
 (** ** Weak signature for maps
-   
+
     No requirements for an ordering on keys nor elements, only decidability
     of equality on keys. First, a functorial signature: *)
 
@@ -61,8 +61,8 @@ Module Type WSfun (E : DecidableType).
 
   Parameter t : Type -> Type.
   (** the abstract type of maps *)
- 
-  Section Types. 
+
+  Section Types.
 
     Variable elt:Type.
 
@@ -73,61 +73,61 @@ Module Type WSfun (E : DecidableType).
     (** Test whether a map is empty or not. *)
 
     Parameter add : key -> elt -> t elt -> t elt.
-    (** [add x y m] returns a map containing the same bindings as [m], 
-	plus a binding of [x] to [y]. If [x] was already bound in [m], 
+    (** [add x y m] returns a map containing the same bindings as [m],
+	plus a binding of [x] to [y]. If [x] was already bound in [m],
 	its previous binding disappears. *)
 
-    Parameter find : key -> t elt -> option elt. 
-    (** [find x m] returns the current binding of [x] in [m], 
+    Parameter find : key -> t elt -> option elt.
+    (** [find x m] returns the current binding of [x] in [m],
 	or [None] if no such binding exists. *)
 
     Parameter remove : key -> t elt -> t elt.
-    (** [remove x m] returns a map containing the same bindings as [m], 
+    (** [remove x m] returns a map containing the same bindings as [m],
 	except for [x] which is unbound in the returned map. *)
 
     Parameter mem : key -> t elt -> bool.
-    (** [mem x m] returns [true] if [m] contains a binding for [x], 
+    (** [mem x m] returns [true] if [m] contains a binding for [x],
 	and [false] otherwise. *)
 
     Variable elt' elt'' : Type.
 
     Parameter map : (elt -> elt') -> t elt -> t elt'.
-    (** [map f m] returns a map with same domain as [m], where the associated 
+    (** [map f m] returns a map with same domain as [m], where the associated
 	value a of all bindings of [m] has been replaced by the result of the
 	application of [f] to [a]. Since Coq is purely functional, the order
         in which the bindings are passed to [f] is irrelevant. *)
 
     Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
-    (** Same as [map], but the function receives as arguments both the 
+    (** Same as [map], but the function receives as arguments both the
 	key and the associated value for each binding of the map. *)
 
-    Parameter map2 : 
+    Parameter map2 :
      (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
-    (** [map2 f m m'] creates a new map whose bindings belong to the ones 
-        of either [m] or [m']. The presence and value for a key [k] is 
-        determined by [f e e'] where [e] and [e'] are the (optional) bindings 
+    (** [map2 f m m'] creates a new map whose bindings belong to the ones
+        of either [m] or [m']. The presence and value for a key [k] is
+        determined by [f e e'] where [e] and [e'] are the (optional) bindings
         of [k] in [m] and [m']. *)
 
     Parameter elements : t elt -> list (key*elt).
-    (** [elements m] returns an assoc list corresponding to the bindings 
+    (** [elements m] returns an assoc list corresponding to the bindings
         of [m], in any order. *)
 
-    Parameter cardinal : t elt -> nat. 
+    Parameter cardinal : t elt -> nat.
     (** [cardinal m] returns the number of bindings in [m]. *)
 
     Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.
-    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 
-	where [k1] ... [kN] are the keys of all bindings in [m] 
+    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
+	where [k1] ... [kN] are the keys of all bindings in [m]
 	(in any order), and [d1] ... [dN] are the associated data. *)
 
     Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
-    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, 
-      that is, contain equal keys and associate them with equal data. 
-      [cmp] is the equality predicate used to compare the data associated 
+    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal,
+      that is, contain equal keys and associate them with equal data.
+      [cmp] is the equality predicate used to compare the data associated
       with the keys. *)
 
-    Section Spec. 
-      
+    Section Spec.
+
       Variable m m' m'' : t elt.
       Variable x y z : key.
       Variable e e' : elt.
@@ -139,24 +139,24 @@ Module Type WSfun (E : DecidableType).
       Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
 
       Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').
-      
-      Definition eq_key_elt (p p':key*elt) := 
+
+      Definition eq_key_elt (p p':key*elt) :=
           E.eq (fst p) (fst p') /\ (snd p) = (snd p').
 
     (** Specification of [MapsTo] *)
       Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
-      
+
     (** Specification of [mem] *)
       Parameter mem_1 : In x m -> mem x m = true.
-      Parameter mem_2 : mem x m = true -> In x m. 
-      
+      Parameter mem_2 : mem x m = true -> In x m.
+
     (** Specification of [empty] *)
       Parameter empty_1 : Empty empty.
 
     (** Specification of [is_empty] *)
-      Parameter is_empty_1 : Empty m -> is_empty m = true. 
+      Parameter is_empty_1 : Empty m -> is_empty m = true.
       Parameter is_empty_2 : is_empty m = true -> Empty m.
-      
+
     (** Specification of [add] *)
       Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
       Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
@@ -168,50 +168,50 @@ Module Type WSfun (E : DecidableType).
       Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
 
     (** Specification of [find] *)
-      Parameter find_1 : MapsTo x e m -> find x m = Some e. 
+      Parameter find_1 : MapsTo x e m -> find x m = Some e.
       Parameter find_2 : find x m = Some e -> MapsTo x e m.
 
     (** Specification of [elements] *)
-      Parameter elements_1 : 
+      Parameter elements_1 :
         MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
-      Parameter elements_2 : 
+      Parameter elements_2 :
         InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
-      (** When compared with ordered maps, here comes the only 
+      (** When compared with ordered maps, here comes the only
          property that is really weaker: *)
-      Parameter elements_3w : NoDupA eq_key (elements m).  
+      Parameter elements_3w : NoDupA eq_key (elements m).
 
     (** Specification of [cardinal] *)
       Parameter cardinal_1 : cardinal m = length (elements m).
 
-    (** Specification of [fold] *)  
+    (** Specification of [fold] *)
       Parameter fold_1 :
 	forall (A : Type) (i : A) (f : key -> elt -> A -> A),
         fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
 
     (** Equality of maps *)
- 
+
     (** Caveat: there are at least three distinct equality predicates on maps.
-      - The simpliest (and maybe most natural) way is to consider keys up to 
-        their equivalence [E.eq], but elements up to Leibniz equality, in 
+      - The simpliest (and maybe most natural) way is to consider keys up to
+        their equivalence [E.eq], but elements up to Leibniz equality, in
         the spirit of [eq_key_elt] above. This leads to predicate [Equal].
       - Unfortunately, this [Equal] predicate can't be used to describe
-        the [equal] function, since this function (for compatibility with 
-        ocaml) expects a boolean comparison [cmp] that may identify more 
-        elements than Leibniz. So logical specification of [equal] is done 
+        the [equal] function, since this function (for compatibility with
+        ocaml) expects a boolean comparison [cmp] that may identify more
+        elements than Leibniz. So logical specification of [equal] is done
         via another predicate [Equivb]
       - This predicate [Equivb] is quite ad-hoc with its boolean [cmp],
         it can be generalized in a [Equiv] expecting a more general
         (possibly non-decidable) equality predicate on elements *)
 
      Definition Equal m m' := forall y, find y m = find y m'.
-     Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
-         (forall k, In k m <-> In k m') /\ 
-         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+     Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+         (forall k, In k m <-> In k m') /\
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
      Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).
 
      (** Specification of [equal] *)
 
-     Variable cmp : elt -> elt -> bool. 
+     Variable cmp : elt -> elt -> bool.
 
      Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
      Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'.
@@ -220,26 +220,26 @@ Module Type WSfun (E : DecidableType).
    End Types.
 
     (** Specification of [map] *)
-      Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+      Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
         MapsTo x e m -> MapsTo x (f e) (map f m).
-      Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), 
+      Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
         In x (map f m) -> In x m.
- 
+
     (** Specification of [mapi] *)
       Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
-        (f:key->elt->elt'), MapsTo x e m -> 
+        (f:key->elt->elt'), MapsTo x e m ->
         exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
       Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
         (f:key->elt->elt'), In x (mapi f m) -> In x m.
 
     (** Specification of [map2] *)
       Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-	(x:key)(f:option elt->option elt'->option elt''), 
-	In x m \/ In x m' -> 
-        find x (map2 f m m') = f (find x m) (find x m').       
+	(x:key)(f:option elt->option elt'->option elt''),
+	In x m \/ In x m' ->
+        find x (map2 f m m') = f (find x m) (find x m').
 
      Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-	(x:key)(f:option elt->option elt'->option elt''), 
+	(x:key)(f:option elt->option elt'->option elt''),
         In x (map2 f m m') -> In x m \/ In x m'.
 
   Hint Immediate MapsTo_1 mem_2 is_empty_2
@@ -252,13 +252,13 @@ Module Type WSfun (E : DecidableType).
 End WSfun.
 
 
-(** ** Static signature for Weak Maps 
+(** ** Static signature for Weak Maps
 
     Similar to [WSfun] but expressed in a self-contained way. *)
 
-Module Type WS. 
+Module Type WS.
   Declare Module E : DecidableType.
-  Include Type WSfun E.
+  Include WSfun E.
 End WS.
 
 
@@ -266,7 +266,7 @@ End WS.
 (** ** Maps on ordered keys, functorial signature *)
 
 Module Type Sfun (E : OrderedType).
-  Include Type WSfun E.
+  Include WSfun E.
   Section elt.
   Variable elt:Type.
    Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
@@ -274,7 +274,7 @@ Module Type Sfun (E : OrderedType).
    Parameter elements_3 : forall m, sort lt_key (elements m).
    (** Remark: since [fold] is specified via [elements], this stronger
    specification of [elements] has an indirect impact on [fold],
-   which can now be proved to receive elements in increasing order. *) 
+   which can now be proved to receive elements in increasing order. *)
   End elt.
 End Sfun.
 
@@ -282,9 +282,9 @@ End Sfun.
 
 (** ** Maps on ordered keys, self-contained signature *)
 
-Module Type S. 
+Module Type S.
   Declare Module E : OrderedType.
-  Include Type Sfun E.
+  Include Sfun E.
 End S.
 
 
@@ -293,28 +293,28 @@ End S.
 
 Module Type Sord.
 
-  Declare Module Data : OrderedType.   
-  Declare Module MapS : S. 
+  Declare Module Data : OrderedType.
+  Declare Module MapS : S.
   Import MapS.
-  
-  Definition t := MapS.t Data.t. 
+
+  Definition t := MapS.t Data.t.
 
   Parameter eq : t -> t -> Prop.
-  Parameter lt : t -> t -> Prop. 
- 
+  Parameter lt : t -> t -> Prop.
+
   Axiom eq_refl : forall m : t, eq m m.
   Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
   Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
   Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
   Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
 
-  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.	
+  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.
 
   Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
   Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
 
   Parameter compare : forall m1 m2, Compare lt eq m1 m2.
-  (** Total ordering between maps. [Data.compare] is a total ordering 
+  (** Total ordering between maps. [Data.compare] is a total ordering
       used to compare data associated with equal keys in the two maps. *)
 
 End Sord.
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index 0ec5ef36..56fc35d8 100644
--- a/theories/FSets/FMapList.v
+++ b/theories/FSets/FMapList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapList.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite map library *)
 
@@ -30,7 +30,7 @@ Definition t (elt:Type) := list (X.t * elt).
 Section Elt.
 Variable elt : Type.
 
-Notation eqk := (eqk (elt:=elt)).   
+Notation eqk := (eqk (elt:=elt)).
 Notation eqke := (eqke (elt:=elt)).
 Notation ltk := (ltk (elt:=elt)).
 Notation MapsTo := (MapsTo (elt:=elt)).
@@ -45,7 +45,7 @@ Definition empty : t elt := nil.
 Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
 
 Lemma empty_1 : Empty empty.
-Proof.  
+Proof.
  unfold Empty,empty.
  intros a e.
  intro abs.
@@ -54,7 +54,7 @@ Qed.
 Hint Resolve empty_1.
 
 Lemma empty_sorted : Sort empty.
-Proof. 
+Proof.
  unfold empty; auto.
 Qed.
 
@@ -62,7 +62,7 @@ Qed.
 
 Definition is_empty (l : t elt) : bool := if l then true else false.
 
-Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. 
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
 Proof.
  unfold Empty, PX.MapsTo.
  intros m.
@@ -72,7 +72,7 @@ Proof.
 Qed.
 
 Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
-Proof.  
+Proof.
  intros m.
  case m;auto.
  intros p l abs.
@@ -93,12 +93,12 @@ Function mem (k : key) (s : t elt) {struct s} : bool :=
  end.
 
 Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
-Proof.  
- intros m Hm x; generalize Hm; clear Hm.      
+Proof.
+ intros m Hm x; generalize Hm; clear Hm.
  functional induction (mem x m);intros sorted belong1;trivial.
- 
+
  inversion belong1. inversion H.
- 
+
  absurd (In x ((k', _x) :: l));try assumption.
  apply Sort_Inf_NotIn with _x;auto.
 
@@ -107,13 +107,13 @@ Proof.
  elim (In_inv belong1);auto.
  intro abs.
  absurd (X.eq x k');auto.
-Qed. 
+Qed.
 
-Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. 
+Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m.
 Proof.
  intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
  functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
- exists _x; auto. 
+ exists _x; auto.
  induction IHb; auto.
  exists x0; auto.
  inversion_clear sorted; auto.
@@ -124,7 +124,7 @@ Qed.
 Function find (k:key) (s: t elt) {struct s} : option elt :=
  match s with
   | nil => None
-  | (k',x)::s' => 
+  | (k',x)::s' =>
      match X.compare k k' with
       | LT _ => None
       | EQ _ => Some x
@@ -138,7 +138,7 @@ Proof.
  functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
 Qed.
 
-Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. 
+Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e.
 Proof.
  intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
  functional induction (find x m);simpl; subst; try clear H_eq_1.
@@ -150,9 +150,9 @@ Proof.
  clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
 
  clear e1;inversion_clear 2.
- compute in H0; destruct H0; intuition congruence. 
+ compute in H0; destruct H0; intuition congruence.
  generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
- 
+
  clear e1; do 2 inversion_clear 1; auto.
  compute in H2; destruct H2; order.
 Qed.
@@ -177,10 +177,10 @@ Proof.
  functional induction (add x e m);simpl;auto.
 Qed.
 
-Lemma add_2 : forall m x y e e', 
+Lemma add_2 : forall m x y e e',
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof.
- intros m x  y e e'. 
+ intros m x  y e e'.
  generalize y e; clear y e; unfold PX.MapsTo.
  functional induction (add x e' m) ;simpl;auto;  clear e0.
  subst;auto.
@@ -191,7 +191,7 @@ Proof.
  auto.
  intros y' e'' eqky'; inversion_clear 1; intuition.
 Qed.
-  
+
 
 Lemma add_3 : forall m x y e e',
   ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
@@ -200,15 +200,15 @@ Proof.
  functional induction (add x e' m);simpl; intros.
  apply (In_inv_3 H0); compute; auto.
  apply (In_inv_3 H0); compute; auto.
- constructor 2; apply (In_inv_3 H0); compute; auto. 
+ constructor 2; apply (In_inv_3 H0); compute; auto.
  inversion_clear H0; auto.
 Qed.
 
 
-Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), 
+Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt),
   Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
 Proof.
- induction m.  
+ induction m.
  simpl; intuition.
  intros.
  destruct a as (x'',e'').
@@ -227,7 +227,7 @@ Proof.
  simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
  constructor; auto.
  apply Inf_eq with (x',e'); auto.
-Qed.  
+Qed.
 
 (** * [remove] *)
 
@@ -240,48 +240,48 @@ Function remove (k : key) (s : t elt) {struct s} : t elt :=
       | EQ _ => l
       | GT _ => (k',x) :: remove k l
      end
- end.  
+ end.
 
 Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
 Proof.
  intros m Hm x y; generalize Hm; clear Hm.
  functional induction (remove x m);simpl;intros;subst.
- 
+
  red; inversion 1; inversion H1.
 
  apply Sort_Inf_NotIn with x0; auto.
  clear e0;constructor; compute; order.
- 
+
  clear e0;inversion_clear Hm.
- apply Sort_Inf_NotIn with x0; auto. 
+ apply Sort_Inf_NotIn with x0; auto.
  apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto.
 
  clear e0;inversion_clear Hm.
  assert (notin:~ In y (remove x l)) by auto.
  intros (x1,abs).
- inversion_clear abs. 
+ inversion_clear abs.
  compute in H2; destruct H2; order.
  apply notin; exists x1; auto.
 Qed.
 
 
-Lemma remove_2 : forall m (Hm:Sort m) x y e, 
+Lemma remove_2 : forall m (Hm:Sort m) x y e,
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction (remove x m);subst;auto; 
-   match goal with 
+ functional induction (remove x m);subst;auto;
+   match goal with
      | [H: X.compare _ _ = _ |- _ ] => clear H
      | _ => idtac
    end.
 
  inversion_clear 3; auto.
  compute in H1; destruct H1; order.
- 
+
  inversion_clear 1; inversion_clear 2; auto.
 Qed.
 
-Lemma remove_3 : forall m (Hm:Sort m) x y e, 
+Lemma remove_3 : forall m (Hm:Sort m) x y e,
   MapsTo y e (remove x m) -> MapsTo y e m.
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
@@ -289,10 +289,10 @@ Proof.
  inversion_clear 1; inversion_clear 1; auto.
 Qed.
 
-Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), 
+Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt),
   Inf (x',e') m -> Inf (x',e') (remove x m).
 Proof.
- induction m.  
+ induction m.
  simpl; intuition.
  intros.
  destruct a as (x'',e'').
@@ -311,31 +311,31 @@ Proof.
  intros.
  destruct a as (x',e').
  simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
-Qed.  
+Qed.
 
 (** * [elements] *)
 
 Definition elements (m: t elt) := m.
 
-Lemma elements_1 : forall m x e, 
+Lemma elements_1 : forall m x e,
   MapsTo x e m -> InA eqke (x,e) (elements m).
 Proof.
  auto.
 Qed.
 
-Lemma elements_2 : forall m x e, 
+Lemma elements_2 : forall m x e,
   InA eqke (x,e) (elements m) -> MapsTo x e m.
-Proof. 
+Proof.
  auto.
 Qed.
 
-Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). 
-Proof. 
+Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m).
+Proof.
  auto.
 Qed.
 
-Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). 
-Proof. 
+Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m).
+Proof.
  intros.
  apply Sort_NoDupA.
  apply elements_3; auto.
@@ -351,30 +351,30 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
 
 Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
   fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
-Proof. 
+Proof.
  intros; functional induction (fold f m i); auto.
 Qed.
 
 (** * [equal] *)
 
-Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := 
-  match m, m' with 
+Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool :=
+  match m, m' with
    | nil, nil => true
-   | (x,e)::l, (x',e')::l' => 
-      match X.compare x x' with 
+   | (x,e)::l, (x',e')::l' =>
+      match X.compare x x' with
        | EQ _ => cmp e e' && equal cmp l l'
        | _    => false
-      end 
-   | _, _ => false 
+      end
+   | _, _ => false
   end.
 
-Definition Equivb cmp m m' := 
-  (forall k, In k m <-> In k m') /\ 
-  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+Definition Equivb cmp m m' :=
+  (forall k, In k m <-> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
 
-Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, 
-  Equivb cmp m m' -> equal cmp m m' = true. 
-Proof. 
+Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
+  Equivb cmp m m' -> equal cmp m m' = true.
+Proof.
  intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
  functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
  intuition; subst.
@@ -407,7 +407,7 @@ Proof.
 
  destruct (X.compare x x'); try contradiction; clear y.
  destruct (H0 x).
- assert (In x ((x',e')::l')). 
+ assert (In x ((x',e')::l')).
   apply H; auto.
   exists e; auto.
  destruct (In_inv H3).
@@ -418,7 +418,7 @@ Proof.
  elim (Sort_Inf_NotIn H5 H7 H4).
 
  destruct (H0 x').
- assert (In x' ((x,e)::l)). 
+ assert (In x' ((x,e)::l)).
   apply H2; auto.
   exists e'; auto.
  destruct (In_inv H3).
@@ -430,7 +430,7 @@ Proof.
 
  destruct m;
  destruct m';try contradiction.
- 
+
  clear H1;destruct p as (k,e).
  destruct (H0 k).
  destruct H1.
@@ -447,18 +447,18 @@ Proof.
 Qed.
 
 
-Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, 
+Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp,
   equal cmp m m' = true -> Equivb cmp m m'.
 Proof.
  intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
- functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; 
-  intuition; try discriminate; subst; 
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
+  intuition; try discriminate; subst;
   try match goal with H: X.compare _ _ = _ |- _ => clear H end.
 
  inversion H0.
 
  inversion_clear Hm;inversion_clear Hm'.
- destruct (andb_prop _ _ H); clear H. 
+ destruct (andb_prop _ _ H); clear H.
  destruct (IHb H1 H3 H6).
  destruct (In_inv H0).
  exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
@@ -467,7 +467,7 @@ Proof.
  exists e''; auto.
 
  inversion_clear Hm;inversion_clear Hm'.
- destruct (andb_prop _ _ H); clear H. 
+ destruct (andb_prop _ _ H); clear H.
  destruct (IHb H1 H3 H6).
  destruct (In_inv H0).
  exists e; constructor; split; trivial; apply X.eq_trans with x'; auto.
@@ -476,15 +476,15 @@ Proof.
  exists e''; auto.
 
  inversion_clear Hm;inversion_clear Hm'.
- destruct (andb_prop _ _ H); clear H. 
+ destruct (andb_prop _ _ H); clear H.
  destruct (IHb H2 H4 H7).
  inversion_clear H0.
  destruct H9; simpl in *; subst.
- inversion_clear H1. 
+ inversion_clear H1.
  destruct H9; simpl in *; subst; auto.
  elim (Sort_Inf_NotIn H4 H5).
  exists e'0; apply MapsTo_eq with k; auto; order.
- inversion_clear H1. 
+ inversion_clear H1.
  destruct H0; simpl in *; subst; auto.
  elim (Sort_Inf_NotIn H2 H3).
  exists e0; apply MapsTo_eq with k; auto; order.
@@ -494,7 +494,7 @@ Qed.
 (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *)
 
 Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
-  eqk x y -> cmp (snd x) (snd y) = true -> 
+  eqk x y -> cmp (snd x) (snd y) = true ->
   (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
 Proof.
  intros.
@@ -517,38 +517,38 @@ Qed.
 Variable elt':Type.
 
 (** * [map] and [mapi] *)
-  
-Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
+
+Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
   match m with
    | nil => nil
    | (k,e)::m' => (k,f e) :: map f m'
   end.
 
-Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
   match m with
    | nil => nil
    | (k,e)::m' => (k,f k e) :: mapi f m'
   end.
 
 End Elt.
-Section Elt2. 
-(* A new section is necessary for previous definitions to work 
+Section Elt2.
+(* A new section is necessary for previous definitions to work
    with different [elt], especially [MapsTo]... *)
-  
+
 Variable elt elt' : Type.
 
 (** Specification of [map] *)
 
-Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), 
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
   MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof.
  intros m x e f.
  (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
  induction m.
  inversion 1.
-    
+
  destruct a as (x',e').
- simpl. 
+ simpl.
  inversion_clear 1.
  constructor 1.
  unfold eqke in *; simpl in *; intuition congruence.
@@ -556,15 +556,15 @@ Proof.
  unfold MapsTo in *; auto.
 Qed.
 
-Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), 
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
   In x (map f m) -> In x m.
 Proof.
- intros m x f. 
+ intros m x f.
  (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
  induction m; simpl.
  intros (e,abs).
  inversion abs.
-  
+
  destruct a as (x',e).
  intros hyp.
  inversion hyp. clear hyp.
@@ -578,9 +578,9 @@ Proof.
 Qed.
 
 Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
-  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt) (x,e) m ->
   lelistA (@ltk elt') (x,e') (map f m).
-Proof. 
+Proof.
  induction m; simpl; auto.
  intros.
  destruct a as (x0,e0).
@@ -589,30 +589,30 @@ Qed.
 
 Hint Resolve map_lelistA.
 
-Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), 
+Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'),
   sort (@ltk elt') (map f m).
-Proof.   
+Proof.
  induction m; simpl; auto.
  intros.
  destruct a as (x',e').
  inversion_clear Hm.
  constructor; auto.
  exact (map_lelistA _ _ H0).
-Qed.      
- 
+Qed.
+
 (** Specification of [mapi] *)
 
-Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), 
-  MapsTo x e m -> 
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  MapsTo x e m ->
   exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof.
  intros m x e f.
  (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
  induction m.
  inversion 1.
-    
+
  destruct a as (x',e').
- simpl. 
+ simpl.
  inversion_clear 1.
  exists x'.
  destruct H0; simpl in *.
@@ -621,18 +621,18 @@ Proof.
  unfold eqke in *; simpl in *; intuition congruence.
  destruct IHm as (y, hyp); auto.
  exists y; intuition.
-Qed.  
+Qed.
 
 
-Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), 
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
   In x (mapi f m) -> In x m.
 Proof.
- intros m x f. 
+ intros m x f.
  (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
  induction m; simpl.
  intros (e,abs).
  inversion abs.
-   
+
  destruct a as (x',e).
  intros hyp.
  inversion hyp. clear hyp.
@@ -646,9 +646,9 @@ Proof.
 Qed.
 
 Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
-  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt) (x,e) m ->
   lelistA (@ltk elt') (x,f x e) (mapi f m).
-Proof. 
+Proof.
  induction m; simpl; auto.
  intros.
  destruct a as (x',e').
@@ -657,7 +657,7 @@ Qed.
 
 Hint Resolve mapi_lelistA.
 
-Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), 
+Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'),
   sort (@ltk elt') (mapi f m).
 Proof.
  induction m; simpl; auto.
@@ -666,7 +666,7 @@ Proof.
  inversion_clear Hm; auto.
 Qed.
 
-End Elt2. 
+End Elt2.
 Section Elt3.
 
 (** * [map2] *)
@@ -674,27 +674,27 @@ Section Elt3.
 Variable elt elt' elt'' : Type.
 Variable f : option elt -> option elt' -> option elt''.
 
-Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := 
-  match o with 
+Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
+  match o with
    | Some e => (k,e)::l
    | None => l
   end.
 
-Fixpoint map2_l (m : t elt) : t elt'' := 
-  match m with 
-   | nil => nil 
+Fixpoint map2_l (m : t elt) : t elt'' :=
+  match m with
+   | nil => nil
    | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
-  end. 
+  end.
 
-Fixpoint map2_r (m' : t elt') : t elt'' := 
-  match m' with 
-   | nil => nil 
+Fixpoint map2_r (m' : t elt') : t elt'' :=
+  match m' with
+   | nil => nil
    | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
-  end. 
+  end.
 
 Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
   match m with
-   | nil => map2_r 
+   | nil => map2_r
    | (k,e) :: l =>
       fix map2_aux (m' : t elt') : t elt'' :=
         match m' with
@@ -706,7 +706,7 @@ Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
              | GT _ => option_cons k' (f None (Some e')) (map2_aux l')
             end
         end
-  end.      
+  end.
 
 Notation oee' := (option elt * option elt')%type.
 
@@ -724,14 +724,14 @@ Fixpoint combine (m : t elt) : t elt' -> t oee' :=
              | GT _ => (k',(None,Some e'))::combine_aux l'
             end
         end
-  end. 
+  end.
 
-Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := 
+Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) :=
   List.fold_right (fun p => f (fst p) (snd p)) i l.
 
-Definition map2_alt m m' := 
-  let m0 : t oee' := combine m m' in 
-  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in 
+Definition map2_alt m m' :=
+  let m0 : t oee' := combine m m' in
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
   fold_right_pair (option_cons (A:=elt'')) m1 nil.
 
 Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
@@ -758,20 +758,20 @@ Proof.
  apply IHm'.
 Qed.
 
-Lemma combine_lelistA : 
-  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), 
-  lelistA (@ltk elt) (x,e) m -> 
-  lelistA (@ltk elt') (x,e') m' -> 
+Lemma combine_lelistA :
+  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
+  lelistA (@ltk elt) (x,e) m ->
+  lelistA (@ltk elt') (x,e') m' ->
   lelistA (@ltk oee') (x,e'') (combine m m').
 Proof.
- induction m. 
+ induction m.
  intros.
  simpl.
  exact (map_lelistA _ _ H0).
- induction m'. 
+ induction m'.
  intros.
  destruct a.
- replace (combine ((t0, e0) :: m) nil) with 
+ replace (combine ((t0, e0) :: m) nil) with
              (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
  exact (map_lelistA _ _ H).
  intros.
@@ -784,18 +784,18 @@ Proof.
 Qed.
 Hint Resolve combine_lelistA.
 
-Lemma combine_sorted : 
-  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), 
+Lemma combine_sorted :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
   sort (@ltk oee') (combine m m').
 Proof.
- induction m. 
+ induction m.
  intros; clear Hm.
  simpl.
  apply map_sorted; auto.
- induction m'. 
+ induction m'.
  intros; clear Hm'.
  destruct a.
- replace (combine ((t0, e) :: m) nil) with 
+ replace (combine ((t0, e) :: m) nil) with
              (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
  apply map_sorted; auto.
  intros.
@@ -805,11 +805,11 @@ Proof.
  inversion_clear Hm.
  constructor; auto.
  assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
- exact (combine_lelistA _ H0 H1). 
+ exact (combine_lelistA _ H0 H1).
  inversion_clear Hm; inversion_clear Hm'.
  constructor; auto.
  assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
- exact (combine_lelistA _ H0 H3). 
+ exact (combine_lelistA _ H0 H3).
  inversion_clear Hm; inversion_clear Hm'.
  constructor; auto.
  change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
@@ -818,8 +818,8 @@ Proof.
  exact (combine_lelistA _  H3 H2).
 Qed.
 
-Lemma map2_sorted : 
-  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), 
+Lemma map2_sorted :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
   sort (@ltk elt'') (map2 m m').
 Proof.
  intros.
@@ -829,7 +829,7 @@ Proof.
  set (l0:=combine m m') in *; clearbody l0.
  set (f':= fun p : oee' => f (fst p) (snd p)).
  assert (H1:=map_sorted (elt' := option elt'') H0 f').
- set (l1:=map f' l0) in *; clearbody l1. 
+ set (l1:=map f' l0) in *; clearbody l1.
  clear f' f H0 l0 Hm Hm' m m'.
  induction l1.
  simpl; auto.
@@ -848,16 +848,16 @@ Proof.
  apply IHl1; auto.
  apply Inf_lt with (t1, None (A:=elt'')); auto.
 Qed.
- 
-Definition at_least_one (o:option elt)(o':option elt') := 
-  match o, o' with 
-   | None, None => None 
+
+Definition at_least_one (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
    | _, _  => Some (o,o')
   end.
 
-Lemma combine_1 : 
-  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), 
-  find x (combine m m') = at_least_one (find x m) (find x m'). 
+Lemma combine_1 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
+  find x (combine m m') = at_least_one (find x m) (find x m').
 Proof.
  induction m.
  intros.
@@ -881,32 +881,32 @@ Proof.
  destruct a as (k,e); destruct a0 as (k',e'); simpl.
  inversion Hm; inversion Hm'; subst.
  destruct (X.compare k k'); simpl;
-  destruct (X.compare x k); 
+  destruct (X.compare x k);
    elim_comp || destruct (X.compare x k'); simpl; auto.
  rewrite IHm; auto; simpl; elim_comp; auto.
  rewrite IHm; auto; simpl; elim_comp; auto.
  rewrite IHm; auto; simpl; elim_comp; auto.
  change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
- rewrite IHm'; auto. 
+ rewrite IHm'; auto.
  simpl find; elim_comp; auto.
  change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
- rewrite IHm'; auto. 
+ rewrite IHm'; auto.
  simpl find; elim_comp; auto.
- change (find x (combine ((k, e) :: m) m') = 
+ change (find x (combine ((k, e) :: m) m') =
          at_least_one (find x m) (find x m')).
- rewrite IHm'; auto. 
+ rewrite IHm'; auto.
  simpl find; elim_comp; auto.
 Qed.
 
-Definition at_least_one_then_f (o:option elt)(o':option elt') := 
-  match o, o' with 
-   | None, None => None 
+Definition at_least_one_then_f (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
    | _, _  => f o o'
   end.
 
-Lemma map2_0 : 
-  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), 
-  find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). 
+Lemma map2_0 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
 Proof.
  intros.
  rewrite <- map2_alt_equiv.
@@ -915,7 +915,7 @@ Proof.
  assert (H2:=combine_sorted Hm Hm').
  set (f':= fun p : oee' => f (fst p) (snd p)).
  set (m0 := combine m m') in *; clearbody m0.
- set (o:=find x m) in *; clearbody o. 
+ set (o:=find x m) in *; clearbody o.
  set (o':=find x m') in *; clearbody o'.
  clear Hm Hm' m m'.
  generalize H; clear H.
@@ -984,10 +984,10 @@ Qed.
 
 (** Specification of [map2] *)
 
-Lemma map2_1 : 
+Lemma map2_1 :
   forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
-  In x m \/ In x m' -> 
-  find x (map2 m m') = f (find x m) (find x m'). 
+  In x m \/ In x m' ->
+  find x (map2 m m') = f (find x m) (find x m').
 Proof.
  intros.
  rewrite map2_0; auto.
@@ -997,10 +997,10 @@ Proof.
  rewrite (find_1 Hm' H).
  destruct (find x m); simpl; auto.
 Qed.
- 
-Lemma map2_2 : 
-  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), 
-  In x (map2 m m') -> In x m \/ In x m'. 
+
+Lemma map2_2 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
+  In x (map2 m m') -> In x m \/ In x m'.
 Proof.
  intros.
  destruct H as (e,H).
@@ -1008,9 +1008,9 @@ Proof.
  rewrite (find_1 (map2_sorted Hm Hm') H).
  generalize (@find_2 _ m x).
  generalize (@find_2 _ m' x).
- destruct (find x m); 
+ destruct (find x m);
    destruct (find x m'); simpl; intros.
- left; exists e0; auto. 
+ left; exists e0; auto.
  left; exists e0; auto.
  right; exists e0; auto.
  discriminate.
@@ -1020,31 +1020,31 @@ End Elt3.
 End Raw.
 
 Module Make (X: OrderedType) <: S with Module E := X.
-Module Raw := Raw X. 
+Module Raw := Raw X.
 Module E := X.
 
 Definition key := E.t.
 
-Record slist (elt:Type) :=  
+Record slist (elt:Type) :=
   {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
-Definition t (elt:Type) : Type := slist elt. 
+Definition t (elt:Type) : Type := slist elt.
 
-Section Elt. 
- Variable elt elt' elt'':Type. 
+Section Elt.
+ Variable elt elt' elt'':Type.
 
  Implicit Types m : t elt.
- Implicit Types x y : key. 
+ Implicit Types x y : key.
  Implicit Types e : elt.
 
  Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
  Definition is_empty m : bool := Raw.is_empty m.(this).
  Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e).
  Definition find x m : option elt := Raw.find x m.(this).
- Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). 
+ Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x).
  Definition mem x m : bool := Raw.mem x m.(this).
  Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f).
  Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
- Definition map2 f m (m':t elt') : t elt'' := 
+ Definition map2 f m (m':t elt') : t elt'' :=
    Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
  Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
  Definition cardinal m := length m.(this).
@@ -1056,9 +1056,9 @@ Section Elt.
  Definition Empty m : Prop := Raw.Empty m.(this).
 
  Definition Equal m m' := forall y, find y m = find y m'.
- Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
-         (forall k, In k m <-> In k m') /\ 
-         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+         (forall k, In k m <-> In k m') /\
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this).
 
  Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
@@ -1095,7 +1095,7 @@ Section Elt.
  Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
  Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed.
 
- Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
  Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed.
  Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
  Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
@@ -1104,9 +1104,9 @@ Section Elt.
  Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
  Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
- Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Lemma elements_3 : forall m, sort lt_key (elements m).
  Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed.
- Lemma elements_3w : forall m, NoDupA eq_key (elements m).  
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
  Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed.
 
  Lemma cardinal_1 : forall m, cardinal m = length (elements m).
@@ -1116,22 +1116,22 @@ Section Elt.
         fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.
 
- Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. 
+ Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
  Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
  Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
  Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
 
  End Elt.
- 
- Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
         MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
- Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), 
-        In x (map f m) -> In x m. 
+ Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
+        In x (map f m) -> In x m.
  Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.
 
  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
-        (f:key->elt->elt'), MapsTo x e m -> 
+        (f:key->elt->elt'), MapsTo x e m ->
         exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
@@ -1139,58 +1139,58 @@ Section Elt.
  Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.
 
  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-	(x:key)(f:option elt->option elt'->option elt''), 
-	In x m \/ In x m' -> 
-        find x (map2 f m m') = f (find x m) (find x m').       
- Proof. 
- intros elt elt' elt'' m m' x f; 
+	(x:key)(f:option elt->option elt'->option elt''),
+	In x m \/ In x m' ->
+        find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
+ intros elt elt' elt'' m m' x f;
  exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
  Qed.
  Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-	(x:key)(f:option elt->option elt'->option elt''), 
+	(x:key)(f:option elt->option elt'->option elt''),
         In x (map2 f m m') -> In x m \/ In x m'.
- Proof. 
- intros elt elt' elt'' m m' x f;  
+ Proof.
+ intros elt elt' elt'' m m' x f;
  exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
  Qed.
 
 End Make.
 
-Module Make_ord (X: OrderedType)(D : OrderedType) <: 
-Sord with Module Data := D 
+Module Make_ord (X: OrderedType)(D : OrderedType) <:
+Sord with Module Data := D
         with Module MapS.E := X.
 
 Module Data := D.
-Module MapS := Make(X). 
+Module MapS := Make(X).
 Import MapS.
 
 Module MD := OrderedTypeFacts(D).
 Import MD.
 
-Definition t := MapS.t D.t. 
+Definition t := MapS.t D.t.
 
 Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.
 
-Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := 
-  match m, m' with 
+Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop :=
+  match m, m' with
    | nil, nil => True
-   | (x,e)::l, (x',e')::l' => 
-      match X.compare x x' with 
+   | (x,e)::l, (x',e')::l' =>
+      match X.compare x x' with
        | EQ _ => D.eq e e' /\ eq_list l l'
        | _       => False
-      end 
+      end
    | _, _ => False
   end.
 
 Definition eq m m' := eq_list m.(this) m'.(this).
 
-Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := 
-  match m, m' with 
+Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop :=
+  match m, m' with
    | nil, nil => False
    | nil, _  => True
    | _, nil  => False
-   | (x,e)::l, (x',e')::l' => 
-      match X.compare x x' with 
+   | (x,e)::l, (x',e')::l' =>
+      match X.compare x x' with
        | LT _ => True
        | GT _ => False
        | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
@@ -1209,9 +1209,9 @@ Proof.
  destruct a; unfold equal; simpl; intuition.
  destruct a as (x,e).
  destruct p as (x',e').
- unfold equal; simpl. 
+ unfold equal; simpl.
  destruct (X.compare x x'); simpl; intuition.
- unfold cmp at 1. 
+ unfold cmp at 1.
  MD.elim_comp; clear H; simpl.
  inversion_clear Hl.
  inversion_clear Hl'.
@@ -1258,7 +1258,7 @@ Qed.
 
 Lemma  eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
 Proof.
- intros (m,Hm); induction m; 
+ intros (m,Hm); induction m;
  intros (m', Hm'); destruct m'; unfold eq; simpl;
  try destruct a as (x,e); try destruct p as (x',e'); auto.
  destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition.
@@ -1267,17 +1267,16 @@ Proof.
 Qed.
 
 Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
-Proof. 
- intros (m1,Hm1); induction m1; 
- intros (m2, Hm2); destruct m2; 
- intros (m3, Hm3); destruct m3; unfold eq; simpl; 
- try destruct a as (x,e); 
- try destruct p as (x',e'); 
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+ intros (m3, Hm3); destruct m3; unfold eq; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
  try destruct p0 as (x'',e''); try contradiction; auto.
- destruct (X.compare x x'); 
-  destruct (X.compare x' x''); 
-   MapS.Raw.MX.elim_comp.
- intuition.
+ destruct (X.compare x x');
+  destruct (X.compare x' x'');
+   MapS.Raw.MX.elim_comp; intuition.
  apply D.eq_trans with e'; auto.
  inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
  apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
@@ -1285,16 +1284,15 @@ Qed.
 
 Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
 Proof.
- intros (m1,Hm1); induction m1; 
- intros (m2, Hm2); destruct m2; 
- intros (m3, Hm3); destruct m3; unfold lt; simpl; 
- try destruct a as (x,e); 
- try destruct p as (x',e'); 
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+ intros (m3, Hm3); destruct m3; unfold lt; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
  try destruct p0 as (x'',e''); try contradiction; auto.
- destruct (X.compare x x'); 
-  destruct (X.compare x' x''); 
-   MapS.Raw.MX.elim_comp; auto.
- intuition.
+ destruct (X.compare x x');
+  destruct (X.compare x' x'');
+   MapS.Raw.MX.elim_comp; intuition.
  left; apply D.lt_trans with e'; auto.
  left; apply lt_eq with e'; auto.
  left; apply eq_lt with e'; auto.
@@ -1307,9 +1305,9 @@ Qed.
 
 Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
 Proof.
- intros (m1,Hm1); induction m1; 
- intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; 
- try destruct a as (x,e); 
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2; unfold eq, lt; simpl;
+ try destruct a as (x,e);
  try destruct p as (x',e'); try contradiction; auto.
  destruct (X.compare x x'); auto.
  intuition.
@@ -1322,20 +1320,20 @@ Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto.
 
 Definition compare : forall m1 m2, Compare lt eq m1 m2.
 Proof.
- intros (m1,Hm1); induction m1; 
- intros (m2, Hm2); destruct m2; 
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
   [ apply EQ | apply LT | apply GT | ]; cmp_solve.
- destruct a as (x,e); destruct p as (x',e'). 
- destruct (X.compare x x'); 
+ destruct a as (x,e); destruct p as (x',e').
+ destruct (X.compare x x');
   [ apply LT | | apply GT ]; cmp_solve.
- destruct (D.compare e e'); 
+ destruct (D.compare e e');
   [ apply LT | | apply GT ]; cmp_solve.
  assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
   inversion_clear Hm1; auto.
  assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
   inversion_clear Hm2; auto.
- destruct (IHm1 Hm11 (Build_slist Hm22)); 
+ destruct (IHm1 Hm11 (Build_slist Hm22));
   [ apply LT | apply EQ | apply GT ]; cmp_solve.
 Qed.
 
-End Make_ord. 
+End Make_ord.
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
index 7fbc3d47..7c5a4fa1 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -6,131 +6,36 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
+(* $Id$ *)
 
-(* $Id: FMapPositive.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(** * FMapPositive : an implementation of FMapInterface for [positive] keys. *)
 
-Require Import Bool.
-Require Import ZArith.
-Require Import OrderedType.
-Require Import OrderedTypeEx.
-Require Import FMapInterface.
+Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface.
 
 Set Implicit Arguments.
-
 Open Local Scope positive_scope.
 
-(** * An implementation of [FMapInterface.S] for positive keys. *)
+Local Unset Elimination Schemes.
+Local Unset Case Analysis Schemes.
 
-(** This file is an adaptation to the [FMap] framework of a work by 
+(** This file is an adaptation to the [FMap] framework of a work by
   Xavier Leroy and Sandrine Blazy (used for building certified compilers).
-  Keys are of type [positive], and maps are binary trees: the sequence 
+  Keys are of type [positive], and maps are binary trees: the sequence
   of binary digits of a positive number corresponds to a path in such a tree.
-  This is quite similar to the [IntMap] library, except that no path compression 
-  is implemented, and that the current file is simple enough to be 
+  This is quite similar to the [IntMap] library, except that no path
+  compression is implemented, and that the current file is simple enough to be
   self-contained. *)
 
-(** Even if [positive] can be seen as an ordered type with respect to the 
-  usual order (see [OrderedTypeEx]), we use here a lexicographic order 
-  over bits, which is more natural here (lower bits are considered first). *)
-
-Module PositiveOrderedTypeBits <: UsualOrderedType.
-  Definition t:=positive.
-  Definition eq:=@eq positive.
-  Definition eq_refl := @refl_equal t.
-  Definition eq_sym := @sym_eq t.
-  Definition eq_trans := @trans_eq t.
-
-  Fixpoint bits_lt (p q:positive) { struct p } : Prop := 
-   match p, q with 
-   | xH, xI _ => True
-   | xH, _ => False
-   | xO p, xO q => bits_lt p q
-   | xO _, _ => True
-   | xI p, xI q => bits_lt p q
-   | xI _, _ => False
-   end.
-
-  Definition lt:=bits_lt.
-
-  Lemma bits_lt_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
-  Proof.
-  induction x.
-  induction y; destruct z; simpl; eauto; intuition.
-  induction y; destruct z; simpl; eauto; intuition.
-  induction y; destruct z; simpl; eauto; intuition.
-  Qed.
- 
-  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
-  Proof. 
-  exact bits_lt_trans.
-  Qed.
-
-  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
-  Proof.
-  induction x; simpl; auto.
-  Qed.
-
-  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
-  Proof.
-  intros; intro.
-  rewrite <- H0 in H; clear H0 y.
-  unfold lt in H.
-  exact (bits_lt_antirefl x H).
-  Qed.
-
-  Definition compare : forall x y : t, Compare lt eq x y.
-  Proof.
-  induction x; destruct y.
-  (* I I *)
-  destruct (IHx y).
-  apply LT; auto.
-  apply EQ; rewrite e; red; auto.
-  apply GT; auto.
-  (* I O *)
-  apply GT; simpl; auto.
-  (* I H *)
-  apply GT; simpl; auto.
-  (* O I *)
-  apply LT; simpl; auto.
-  (* O O *)
-  destruct (IHx y).
-  apply LT; auto.
-  apply EQ; rewrite e; red; auto.
-  apply GT; auto.
-  (* O H *) 
-  apply LT; simpl; auto.
-  (* H I *)
-  apply LT; simpl; auto.
-  (* H O *)
-  apply GT; simpl; auto.
-  (* H H *)
-  apply EQ; red; auto.
-  Qed.
-
-  Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
-  Proof.
-  intros. case_eq ((x ?= y) Eq); intros.
-  left. apply Pcompare_Eq_eq; auto.
-  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
-  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
-  Qed.
+(** First, some stuff about [positive] *)
 
-End PositiveOrderedTypeBits.
-
-(** Other positive stuff *)
- 
-Fixpoint append (i j : positive) {struct i} : positive :=
+Fixpoint append (i j : positive) : positive :=
     match i with
       | xH => j
       | xI ii => xI (append ii j)
       | xO ii => xO (append ii j)
     end.
 
-Lemma append_assoc_0 : 
+Lemma append_assoc_0 :
   forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
 Proof.
  induction i; intros; destruct j; simpl;
@@ -140,7 +45,7 @@ Proof.
  auto.
 Qed.
 
-Lemma append_assoc_1 : 
+Lemma append_assoc_1 :
   forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
 Proof.
  induction i; intros; destruct j; simpl;
@@ -159,7 +64,7 @@ Lemma append_neutral_l : forall (i : positive), append xH i = i.
 Proof.
  simpl; auto.
 Qed.
- 
+
 
 (** The module of maps over positive keys *)
 
@@ -174,6 +79,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     | Leaf : tree A
     | Node : tree A -> option A -> tree A -> tree A.
 
+  Scheme tree_ind := Induction for tree Sort Prop.
+
   Definition t := tree.
 
   Section A.
@@ -182,15 +89,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Implicit Arguments Leaf [A].
 
   Definition empty : t A := Leaf.
- 
-  Fixpoint is_empty (m : t A) {struct m} : bool := 
-   match m with 
+
+  Fixpoint is_empty (m : t A) : bool :=
+   match m with
     | Leaf => true
     | Node l None r => (is_empty l) && (is_empty r)
     | _ => false
    end.
 
-  Fixpoint find (i : positive) (m : t A) {struct i} : option A :=
+  Fixpoint find (i : positive) (m : t A) : option A :=
     match m with
     | Leaf => None
     | Node l o r =>
@@ -201,7 +108,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint mem (i : positive) (m : t A) {struct i} : bool :=
+  Fixpoint mem (i : positive) (m : t A) : bool :=
     match m with
     | Leaf => false
     | Node l o r =>
@@ -212,7 +119,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint add (i : positive) (v : A) (m : t A) {struct i} : t A :=
+  Fixpoint add (i : positive) (v : A) (m : t A) : t A :=
     match m with
     | Leaf =>
         match i with
@@ -228,7 +135,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint remove (i : positive) (m : t A) {struct i} : t A :=
+  Fixpoint remove (i : positive) (m : t A) : t A :=
     match i with
     | xH =>
         match m with
@@ -260,8 +167,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   (** [elements] *)
 
-    Fixpoint xelements (m : t A) (i : positive) {struct m}
-             : list (positive * A) :=
+    Fixpoint xelements (m : t A) (i : positive) : list (positive * A) :=
       match m with
       | Leaf => nil
       | Node l None r =>
@@ -279,8 +185,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   (** [cardinal] *)
 
   Fixpoint cardinal (m : t A) : nat :=
-    match m with 
-      | Leaf => 0%nat 
+    match m with
+      | Leaf => 0%nat
       | Node l None r => (cardinal l + cardinal r)%nat
       | Node l (Some _) r => S (cardinal l + cardinal r)
     end.
@@ -387,7 +293,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     exact (xelements_correct m i xH H).
   Qed.
 
-  Fixpoint xfind (i j : positive) (m : t A) {struct j} : option A :=
+  Fixpoint xfind (i j : positive) (m : t A) : option A :=
       match i, j with
       | _, xH => find i m
       | xO ii, xO jj => xfind ii jj m
@@ -400,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
       xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
     Proof.
       induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
-      destruct i; congruence.
+      destruct i; simpl in *; auto.
     Qed.
 
     Lemma xelements_ii :
@@ -565,7 +471,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     exact (xelements_complete i xH m v H).
   Qed.
 
-  Lemma cardinal_1 : 
+  Lemma cardinal_1 :
    forall (m: t A), cardinal m = length (elements m).
   Proof.
    unfold elements.
@@ -584,13 +490,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m.
 
   Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p').
-      
-  Definition eq_key_elt (p p':positive*A) := 
+
+  Definition eq_key_elt (p p':positive*A) :=
           E.eq (fst p) (fst p') /\ (snd p) = (snd p').
 
   Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p').
 
-  Lemma mem_find : 
+  Global Instance eqk_equiv : Equivalence eq_key.
+  Global Instance eqke_equiv : Equivalence eq_key_elt.
+  Global Instance ltk_strorder : StrictOrder lt_key.
+
+  Lemma mem_find :
     forall m x, mem x m = match find x m with None => false | _ => true end.
   Proof.
   induction m; destruct x; simpl; auto.
@@ -625,7 +535,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   simpl; generalize H0; rewrite Empty_alt; auto.
   Qed.
 
-  Section FMapSpec. 
+  Section FMapSpec.
 
   Lemma mem_1 : forall m x, In x m -> mem x m = true.
   Proof.
@@ -633,7 +543,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   destruct 1 as (e0,H0); rewrite H0; auto.
   Qed.
 
-  Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+  Lemma mem_2 : forall m x, mem x m = true -> In x m.
   Proof.
   unfold In, MapsTo; intros m x; rewrite mem_find.
   destruct (find x m).
@@ -659,7 +569,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   rewrite Empty_alt; apply gempty.
   Qed.
 
-  Lemma is_empty_1 : Empty m -> is_empty m = true. 
+  Lemma is_empty_1 : Empty m -> is_empty m = true.
   Proof.
   induction m; simpl; auto.
   rewrite Empty_Node.
@@ -699,10 +609,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
-  Proof. 
+  Proof.
   intros; intro.
   generalize (mem_1 H0).
   rewrite mem_find.
+  red in H.
   rewrite H.
   rewrite grs.
   intros; discriminate.
@@ -715,15 +626,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
-  Proof. 
+  Proof.
   unfold MapsTo.
   destruct (E.eq_dec x y).
   subst.
   rewrite grs; intros; discriminate.
   rewrite gro; auto.
   Qed.
-  
-  Lemma elements_1 : 
+
+  Lemma elements_1 :
      MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
   Proof.
   unfold MapsTo.
@@ -735,7 +646,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   apply elements_correct; auto.
   Qed.
 
-  Lemma elements_2 : 
+  Lemma elements_2 :
      InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
   Proof.
   unfold MapsTo.
@@ -745,7 +656,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   apply elements_complete; auto.
   Qed.
 
-  Lemma xelements_bits_lt_1 : forall p p0 q m v, 
+  Lemma xelements_bits_lt_1 : forall p p0 q m v,
      List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p.
   Proof.
   intros.
@@ -754,7 +665,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   induction p; destruct p0; simpl; intros; eauto; try discriminate.
   Qed.
 
-  Lemma xelements_bits_lt_2 : forall p p0 q m v, 
+  Lemma xelements_bits_lt_2 : forall p p0 q m v,
      List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0.
   Proof.
   intros.
@@ -769,8 +680,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   simpl; auto.
   destruct o; simpl; intros.
   (* Some *)
-  apply (SortA_app (eqA:=eq_key_elt)); auto.
-  compute; intuition.
+  apply (SortA_app (eqA:=eq_key_elt)); auto with *.
   constructor; auto.
   apply In_InfA; intros.
   destruct y0.
@@ -789,8 +699,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   eapply xelements_bits_lt_1; eauto.
   eapply xelements_bits_lt_2; eauto.
   (* None *)
-  apply (SortA_app (eqA:=eq_key_elt)); auto.
-  compute; intuition.
+  apply (SortA_app (eqA:=eq_key_elt)); auto with *.
   intros x0 y0.
   do 2 rewrite InA_alt.
   intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
@@ -802,7 +711,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   eapply xelements_bits_lt_2; eauto.
   Qed.
 
-  Lemma elements_3 : sort lt_key (elements m). 
+  Lemma elements_3 : sort lt_key (elements m).
   Proof.
   unfold elements.
   apply xelements_sort; auto.
@@ -817,14 +726,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   End FMapSpec.
 
   (** [map] and [mapi] *)
- 
+
   Variable B : Type.
 
   Section Mapi.
 
     Variable f : positive -> A -> B.
 
-    Fixpoint xmapi (m : t A) (i : positive) {struct m} : t B :=
+    Fixpoint xmapi (m : t A) (i : positive) : t B :=
        match m with
         | Leaf => @Leaf B
         | Node l o r => Node (xmapi l (append i (xO xH)))
@@ -861,9 +770,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   rewrite append_neutral_l; auto.
   Qed.
 
-  Lemma mapi_1 : 
-    forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), 
-    MapsTo x e m -> 
+  Lemma mapi_1 :
+    forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
+    MapsTo x e m ->
     exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
   Proof.
   intros.
@@ -876,8 +785,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   simpl; auto.
   Qed.
 
-  Lemma mapi_2 : 
-    forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), 
+  Lemma mapi_2 :
+    forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'),
     In x (mapi f m) -> In x m.
   Proof.
   intros.
@@ -890,14 +799,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   simpl in *; discriminate.
   Qed.
 
-  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
     MapsTo x e m -> MapsTo x (f e) (map f m).
   Proof.
   intros; unfold map.
   destruct (mapi_1 (fun _ => f) H); intuition.
   Qed.
-  
-  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), 
+
+  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
     In x (map f m) -> In x m.
   Proof.
   intros; unfold map in *; eapply mapi_2; eauto.
@@ -906,10 +815,10 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Section map2.
   Variable A B C : Type.
   Variable f : option A -> option B -> option C.
-  
+
   Implicit Arguments Leaf [A].
 
-  Fixpoint xmap2_l (m : t A) {struct m} : t C :=
+  Fixpoint xmap2_l (m : t A) : t C :=
       match m with
       | Leaf => Leaf
       | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
@@ -921,7 +830,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
       induction i; intros; destruct m; simpl; auto.
     Qed.
 
-  Fixpoint xmap2_r (m : t B) {struct m} : t C :=
+  Fixpoint xmap2_r (m : t B) : t C :=
       match m with
       | Leaf => Leaf
       | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
@@ -933,7 +842,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
       induction i; intros; destruct m; simpl; auto.
     Qed.
 
-  Fixpoint _map2 (m1 : t A)(m2 : t B) {struct m1} : t C :=
+  Fixpoint _map2 (m1 : t A)(m2 : t B) : t C :=
     match m1 with
     | Leaf => xmap2_r m2
     | Node l1 o1 r1 =>
@@ -953,14 +862,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   End map2.
 
-  Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := 
+  Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') :=
    _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).
 
   Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-    (x:key)(f:option elt->option elt'->option elt''), 
-    In x m \/ In x m' -> 
-    find x (map2 f m m') = f (find x m) (find x m'). 
-  Proof. 
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x m \/ In x m' ->
+    find x (map2 f m m') = f (find x m) (find x m').
+  Proof.
   intros.
   unfold map2.
   rewrite gmap2; auto.
@@ -973,7 +882,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Lemma  map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-    (x:key)(f:option elt->option elt'->option elt''), 
+    (x:key)(f:option elt->option elt'->option elt''),
     In x (map2 f m m') -> In x m \/ In x m'.
   Proof.
   intros.
@@ -1031,12 +940,12 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     rewrite xfoldi_1; reflexivity.
   Qed.
 
-  Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := 
-    match m1, m2 with 
+  Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
+    match m1, m2 with
       | Leaf, _ => is_empty m2
       | _, Leaf => is_empty m1
-      | Node l1 o1 r1, Node l2 o2 r2 => 
-           (match o1, o2 with 
+      | Node l1 o1 r1, Node l2 o2 r2 =>
+           (match o1, o2 with
              | None, None => true
              | Some v1, Some v2 => cmp v1 v2
              | _, _ => false
@@ -1044,19 +953,19 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
            && equal cmp l1 l2 && equal cmp r1 r2
      end.
 
-  Definition Equal (A:Type)(m m':t A) := 
+  Definition Equal (A:Type)(m m':t A) :=
     forall y, find y m = find y m'.
-  Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := 
-    (forall k, In k m <-> In k m') /\ 
-    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+  Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' :=
+    (forall k, In k m <-> In k m') /\
+    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
   Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).
 
-  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), 
-    Equivb cmp m m' -> equal cmp m m' = true. 
-  Proof. 
+  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+    Equivb cmp m m' -> equal cmp m m' = true.
+  Proof.
   induction m.
   (* m = Leaf *)
-  destruct 1. 
+  destruct 1.
   simpl.
   apply is_empty_1.
   red; red; intros.
@@ -1068,7 +977,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   (* m = Node *)
   destruct m'.
   (* m' = Leaf *)
-  destruct 1. 
+  destruct 1.
   simpl.
   destruct o.
   assert (In xH (Leaf A)).
@@ -1105,9 +1014,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   apply andb_true_intro; split; auto.
   Qed.
 
-  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), 
-    equal cmp m m' = true -> Equivb cmp m m'. 
-  Proof. 
+  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+    equal cmp m m' = true -> Equivb cmp m m'.
+  Proof.
   induction m.
   (* m = Leaf *)
   simpl.
@@ -1181,7 +1090,7 @@ Module PositiveMapAdditionalFacts.
      rewrite (IHi m2 v H); congruence.
      rewrite (IHi m1 v H); congruence.
   Qed.
-  
+
   Lemma xmap2_lr :
       forall (A B : Type)(f g: option A -> option A -> option B)(m : t A),
       (forall (i j : option A), f i j = g j i) ->
@@ -1209,7 +1118,7 @@ Module PositiveMapAdditionalFacts.
       auto.
      rewrite IHm1_1.
      rewrite IHm1_2.
-     auto. 
+     auto.
   Qed.
 
 End PositiveMapAdditionalFacts.
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index be09e41a..38ed172b 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapWeakList.v 10616 2008-03-04 17:33:35Z letouzey $ *)
+(* $Id$ *)
 
-(** * Finite map library *)  
+(** * Finite map library *)
 
 (** This file proposes an implementation of the non-dependant interface
  [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *)
@@ -29,7 +29,7 @@ Section Elt.
 
 Variable elt : Type.
 
-Notation eqk := (eqk (elt:=elt)).   
+Notation eqk := (eqk (elt:=elt)).
 Notation eqke := (eqke (elt:=elt)).
 Notation MapsTo := (MapsTo (elt:=elt)).
 Notation In := (In (elt:=elt)).
@@ -52,7 +52,7 @@ Qed.
 Hint Resolve empty_1.
 
 Lemma empty_NoDup : NoDupA empty.
-Proof. 
+Proof.
  unfold empty; auto.
 Qed.
 
@@ -60,7 +60,7 @@ Qed.
 
 Definition is_empty (l : t elt) : bool := if l then true else false.
 
-Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. 
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
 Proof.
  unfold Empty, PX.MapsTo.
  intros m.
@@ -88,7 +88,7 @@ Function mem (k : key) (s : t elt) {struct s} : bool :=
 
 Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true.
 Proof.
- intros m Hm x; generalize Hm; clear Hm.      
+ intros m Hm x; generalize Hm; clear Hm.
  functional induction (mem x m);intros NoDup belong1;trivial.
  inversion belong1. inversion H.
  inversion_clear NoDup.
@@ -98,13 +98,13 @@ Proof.
  contradiction.
  apply IHb; auto.
  exists x0; auto.
-Qed. 
+Qed.
 
-Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. 
+Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m.
 Proof.
  intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
  functional induction (mem x m); intros NoDup hyp; try discriminate.
- exists _x; auto. 
+ exists _x; auto.
  inversion_clear NoDup.
  destruct IHb; auto.
  exists x0; auto.
@@ -124,8 +124,8 @@ Proof.
  functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
 Qed.
 
-Lemma find_1 : forall m (Hm:NoDupA m) x e, 
-  MapsTo x e m -> find x m = Some e. 
+Lemma find_1 : forall m (Hm:NoDupA m) x e,
+  MapsTo x e m -> find x m = Some e.
 Proof.
  intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
  functional induction (find x m);simpl; subst; try clear H_eq_1.
@@ -142,7 +142,7 @@ Qed.
 
 (* Not part of the exported specifications, used later for [combine]. *)
 
-Lemma find_eq : forall m (Hm:NoDupA m) x x', 
+Lemma find_eq : forall m (Hm:NoDupA m) x x',
    X.eq x x' -> find x m = find x' m.
 Proof.
  induction m; simpl; auto; destruct a; intros.
@@ -167,7 +167,7 @@ Proof.
  functional induction (add x e m);simpl;auto.
 Qed.
 
-Lemma add_2 : forall m x y e e', 
+Lemma add_2 : forall m x y e e',
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof.
  intros m x  y e e'; generalize y e; clear y e; unfold PX.MapsTo.
@@ -178,7 +178,7 @@ Proof.
  auto.
  intros y' e'' eqky'; inversion_clear 1; intuition.
 Qed.
-  
+
 Lemma add_3 : forall m x y e e',
   ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof.
@@ -189,14 +189,14 @@ Proof.
  inversion_clear 2; auto.
 Qed.
 
-Lemma add_3' : forall m x y e e', 
-  ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. 
+Lemma add_3' : forall m x y e e',
+  ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m.
 Proof.
  intros m x y e e'. generalize y e; clear y e.
  functional induction (add x e' m);simpl;auto.
  inversion_clear 2.
  compute in H1; elim H; auto.
- inversion H1. 
+ inversion H1.
  constructor 2; inversion_clear H0; auto.
  compute in H1; elim H; auto.
  inversion_clear 2; auto.
@@ -218,7 +218,7 @@ Qed.
 
 (* Not part of the exported specifications, used later for [combine]. *)
 
-Lemma add_eq : forall m (Hm:NoDupA m) x a e, 
+Lemma add_eq : forall m (Hm:NoDupA m) x a e,
    X.eq x a -> find x (add a e m) = Some e.
 Proof.
  intros.
@@ -227,7 +227,7 @@ Proof.
  apply add_1; auto.
 Qed.
 
-Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, 
+Lemma add_not_eq : forall m (Hm:NoDupA m) x a e,
   ~X.eq x a -> find x (add a e m) = find x m.
 Proof.
  intros.
@@ -250,7 +250,7 @@ Function remove (k : key) (s : t elt) {struct s} : t elt :=
   match s with
    | nil => nil
    | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l
-  end.  
+  end.
 
 Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m).
 Proof.
@@ -265,7 +265,7 @@ Proof.
  destruct H0 as (e,H2); unfold PX.MapsTo in H2.
  apply InA_eqk with (y,e); auto.
  compute; apply X.eq_trans with x; auto.
-  
+
  intro H2.
  destruct H2 as (e,H2); inversion_clear H2.
  compute in H0; destruct H0.
@@ -274,8 +274,8 @@ Proof.
  elim (IHt0 H2 H).
  exists e; auto.
 Qed.
-  
-Lemma remove_2 : forall m (Hm:NoDupA m) x y e, 
+
+Lemma remove_2 : forall m (Hm:NoDupA m) x y e,
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
@@ -283,11 +283,11 @@ Proof.
  inversion_clear 3; auto.
  compute in H1; destruct H1.
  elim H; apply X.eq_trans with k'; auto.
-  
+
  inversion_clear 1; inversion_clear 2; auto.
 Qed.
 
-Lemma remove_3 : forall m (Hm:NoDupA m) x y e, 
+Lemma remove_3 : forall m (Hm:NoDupA m) x y e,
   MapsTo y e (remove x m) -> MapsTo y e m.
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
@@ -295,7 +295,7 @@ Proof.
  do 2 inversion_clear 1; auto.
 Qed.
 
-Lemma remove_3' : forall m (Hm:NoDupA m) x y e, 
+Lemma remove_3' : forall m (Hm:NoDupA m) x y e,
   InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
@@ -313,7 +313,7 @@ Proof.
  simpl; case (X.eq_dec x x'); auto.
  constructor; auto.
  contradict H; apply remove_3' with x; auto.
-Qed.  
+Qed.
 
 (** * [elements] *)
 
@@ -325,12 +325,12 @@ Proof.
 Qed.
 
 Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m.
-Proof. 
+Proof.
 auto.
 Qed.
 
-Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). 
-Proof. 
+Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m).
+Proof.
  auto.
 Qed.
 
@@ -344,34 +344,34 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} :  A :=
 
 Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
   fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
-Proof. 
+Proof.
  intros; functional induction (@fold A f m i); auto.
 Qed.
 
 (** * [equal] *)
 
-Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := 
-  match find k m' with 
+Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) :=
+  match find k m' with
    | None => false
    | Some e' => cmp e e'
   end.
 
-Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := 
-  fold (fun k e b => andb (check cmp k e m') b) m true. 
-   
+Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+  fold (fun k e b => andb (check cmp k e m') b) m true.
+
 Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
   andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m).
 
-Definition Submap cmp m m' := 
-  (forall k, In k m -> In k m') /\ 
-  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+Definition Submap cmp m m' :=
+  (forall k, In k m -> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
 
-Definition Equivb cmp m m' := 
-  (forall k, In k m <-> In k m') /\ 
-  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+Definition Equivb cmp m m' :=
+  (forall k, In k m <-> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
 
-Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
-  Submap cmp m m' -> submap cmp m m' = true. 
+Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+  Submap cmp m m' -> submap cmp m m' = true.
 Proof.
  unfold Submap, submap.
  induction m.
@@ -390,9 +390,9 @@ Proof.
  destruct H5 as (e'',H5); exists e''; auto.
  apply H0 with k; auto.
 Qed.
-   
-Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
-  submap cmp m m' = true -> Submap cmp m m'. 
+
+Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+  submap cmp m m' = true -> Submap cmp m m'.
 Proof.
  unfold Submap, submap.
  induction m.
@@ -400,7 +400,7 @@ Proof.
  intuition.
  destruct H0; inversion H0.
  inversion H0.
- 
+
  destruct a; simpl; intros.
  inversion_clear Hm.
  rewrite andb_b_true in H.
@@ -414,7 +414,7 @@ Proof.
  rewrite H2 in H.
  destruct (IHm H1 m' Hm' cmp H); auto.
  unfold check in H2.
- case_eq (find t0 m'); [intros e' H5 | intros H5]; 
+ case_eq (find t0 m'); [intros e' H5 | intros H5];
   rewrite H5 in H2; try discriminate.
  split; intros.
  destruct H6 as (e0,H6); inversion_clear H6.
@@ -432,15 +432,15 @@ Qed.
 
 (** Specification of [equal] *)
 
-Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
-  Equivb cmp m m' -> equal cmp m m' = true. 
-Proof. 
+Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+  Equivb cmp m m' -> equal cmp m m' = true.
+Proof.
  unfold Equivb, equal.
  intuition.
  apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
 Qed.
 
-Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, 
+Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp,
   equal cmp m m' = true -> Equivb cmp m m'.
 Proof.
  unfold Equivb, equal.
@@ -449,43 +449,43 @@ Proof.
  generalize (submap_2 Hm Hm' H0).
  generalize (submap_2 Hm' Hm H1).
  firstorder.
-Qed. 
+Qed.
 
 Variable elt':Type.
 
 (** * [map] and [mapi] *)
-  
-Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
+
+Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
   match m with
    | nil => nil
    | (k,e)::m' => (k,f e) :: map f m'
   end.
 
-Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
   match m with
    | nil => nil
    | (k,e)::m' => (k,f k e) :: mapi f m'
   end.
 
 End Elt.
-Section Elt2. 
-(* A new section is necessary for previous definitions to work 
+Section Elt2.
+(* A new section is necessary for previous definitions to work
    with different [elt], especially [MapsTo]... *)
-  
+
 Variable elt elt' : Type.
 
 (** Specification of [map] *)
 
-Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), 
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
   MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof.
  intros m x e f.
  (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
  induction m.
  inversion 1.
-    
+
  destruct a as (x',e').
- simpl. 
+ simpl.
  inversion_clear 1.
  constructor 1.
  unfold eqke in *; simpl in *; intuition congruence.
@@ -493,15 +493,15 @@ Proof.
  unfold MapsTo in *; auto.
 Qed.
 
-Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), 
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
   In x (map f m) -> In x m.
 Proof.
- intros m x f. 
+ intros m x f.
  (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
  induction m; simpl.
  intros (e,abs).
  inversion abs.
-    
+
  destruct a as (x',e).
  intros hyp.
  inversion hyp. clear hyp.
@@ -514,9 +514,9 @@ Proof.
  constructor 2; auto.
 Qed.
 
-Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), 
+Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'),
   NoDupA (@eqk elt') (map f m).
-Proof.   
+Proof.
  induction m; simpl; auto.
  intros.
  destruct a as (x',e').
@@ -524,25 +524,25 @@ Proof.
  constructor; auto.
  contradict H.
  (* il faut un map_1 avec eqk au lieu de eqke *)
- clear IHm H0. 
+ clear IHm H0.
  induction m; simpl in *; auto.
  inversion H.
  destruct a; inversion H; auto.
-Qed.      
- 
+Qed.
+
 (** Specification of [mapi] *)
 
-Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), 
-  MapsTo x e m -> 
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  MapsTo x e m ->
   exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof.
  intros m x e f.
  (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
  induction m.
  inversion 1.
-    
+
  destruct a as (x',e').
- simpl. 
+ simpl.
  inversion_clear 1.
  exists x'.
  destruct H0; simpl in *.
@@ -551,17 +551,17 @@ Proof.
  unfold eqke in *; simpl in *; intuition congruence.
  destruct IHm as (y, hyp); auto.
  exists y; intuition.
-Qed.  
+Qed.
 
-Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), 
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
   In x (mapi f m) -> In x m.
 Proof.
- intros m x f. 
+ intros m x f.
  (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
  induction m; simpl.
  intros (e,abs).
  inversion abs.
-    
+
  destruct a as (x',e).
  intros hyp.
  inversion hyp. clear hyp.
@@ -574,7 +574,7 @@ Proof.
  constructor 2; auto.
 Qed.
 
-Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), 
+Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'),
   NoDupA (@eqk elt') (mapi f m).
 Proof.
  induction m; simpl; auto.
@@ -589,30 +589,30 @@ Proof.
  destruct a; inversion_clear H; auto.
 Qed.
 
-End Elt2. 
+End Elt2.
 Section Elt3.
 
 Variable elt elt' elt'' : Type.
 
 Notation oee' := (option elt * option elt')%type.
-	
+
 Definition combine_l (m:t elt)(m':t elt') : t oee' :=
-  mapi (fun k e => (Some e, find k m')) m.	
+  mapi (fun k e => (Some e, find k m')) m.
 
 Definition combine_r (m:t elt)(m':t elt') : t oee' :=
-  mapi (fun k e' => (find k m, Some e')) m'.	
+  mapi (fun k e' => (find k m, Some e')) m'.
 
-Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := 
+Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) :=
   List.fold_right (fun p => f (fst p) (snd p)) i l.
 
-Definition combine (m:t elt)(m':t elt') : t oee' := 
-  let l := combine_l m m' in 
-  let r := combine_r m m' in 
+Definition combine (m:t elt)(m':t elt') : t oee' :=
+  let l := combine_l m m' in
+  let r := combine_r m m' in
   fold_right_pair (add (elt:=oee')) l r.
 
-Lemma fold_right_pair_NoDup : 
-  forall l r (Hl: NoDupA (eqk (elt:=oee')) l) 
-    (Hl: NoDupA (eqk (elt:=oee')) r), 
+Lemma fold_right_pair_NoDup :
+  forall l r (Hl: NoDupA (eqk (elt:=oee')) l)
+    (Hl: NoDupA (eqk (elt:=oee')) r),
     NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r).
 Proof.
  induction l; simpl; auto.
@@ -622,8 +622,8 @@ Proof.
 Qed.
 Hint Resolve fold_right_pair_NoDup.
 
-Lemma combine_NoDup : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), 
+Lemma combine_NoDup :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'),
   NoDupA (@eqk oee') (combine m m').
 Proof.
  unfold combine, combine_r, combine_l.
@@ -637,21 +637,21 @@ Proof.
  auto.
 Qed.
 
-Definition at_least_left (o:option elt)(o':option elt') := 
-  match o with 
-   | None => None 
+Definition at_least_left (o:option elt)(o':option elt') :=
+  match o with
+   | None => None
    | _  => Some (o,o')
   end.
 
-Definition at_least_right (o:option elt)(o':option elt') := 
-  match o' with 
-   | None => None 
+Definition at_least_right (o:option elt)(o':option elt') :=
+  match o' with
+   | None => None
    | _  => Some (o,o')
   end.
 
-Lemma combine_l_1 : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
-  find x (combine_l m m') = at_least_left (find x m) (find x m'). 
+Lemma combine_l_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (combine_l m m') = at_least_left (find x m) (find x m').
 Proof.
  unfold combine_l.
  intros.
@@ -668,9 +668,9 @@ Proof.
  rewrite (find_1 Hm H1) in H; discriminate.
 Qed.
 
-Lemma combine_r_1 : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
-  find x (combine_r m m') = at_least_right (find x m) (find x m'). 
+Lemma combine_r_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (combine_r m m') = at_least_right (find x m) (find x m').
 Proof.
  unfold combine_r.
  intros.
@@ -687,15 +687,15 @@ Proof.
  rewrite (find_1 Hm' H1) in H; discriminate.
 Qed.
 
-Definition at_least_one (o:option elt)(o':option elt') := 
-  match o, o' with 
-   | None, None => None 
+Definition at_least_one (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
    | _, _  => Some (o,o')
   end.
 
-Lemma combine_1 : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
-  find x (combine m m') = at_least_one (find x m) (find x m'). 
+Lemma combine_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (combine m m') = at_least_one (find x m) (find x m').
 Proof.
  unfold combine.
  intros.
@@ -726,19 +726,19 @@ Qed.
 
 Variable f : option elt -> option elt' -> option elt''.
 
-Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := 
+Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
   match o with
    | Some e => (k,e)::l
    | None => l
   end.
 
-Definition map2 m m' := 
-  let m0 : t oee' := combine m m' in 
-  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in 
+Definition map2 m m' :=
+  let m0 : t oee' := combine m m' in
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
   fold_right_pair (option_cons (A:=elt'')) m1 nil.
 
-Lemma map2_NoDup : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), 
+Lemma map2_NoDup :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'),
   NoDupA (@eqk elt'') (map2 m m').
 Proof.
  intros.
@@ -747,7 +747,7 @@ Proof.
  set (l0:=combine m m') in *; clearbody l0.
  set (f':= fun p : oee' => f (fst p) (snd p)).
  assert (H1:=map_NoDup (elt' := option elt'') H0 f').
- set (l1:=map f' l0) in *; clearbody l1. 
+ set (l1:=map f' l0) in *; clearbody l1.
  clear f' f H0 l0 Hm Hm' m m'.
  induction l1.
  simpl; auto.
@@ -763,15 +763,15 @@ Proof.
  inversion_clear H; auto.
 Qed.
 
-Definition at_least_one_then_f (o:option elt)(o':option elt') := 
-  match o, o' with 
-   | None, None => None 
+Definition at_least_one_then_f (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
    | _, _  => f o o'
   end.
 
-Lemma map2_0 : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
-  find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). 
+Lemma map2_0 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
 Proof.
  intros.
  unfold map2.
@@ -779,7 +779,7 @@ Proof.
  assert (H2:=combine_NoDup Hm Hm').
  set (f':= fun p : oee' => f (fst p) (snd p)).
  set (m0 := combine m m') in *; clearbody m0.
- set (o:=find x m) in *; clearbody o. 
+ set (o:=find x m) in *; clearbody o.
  set (o':=find x m') in *; clearbody o'.
  clear Hm Hm' m m'.
  generalize H; clear H.
@@ -795,14 +795,14 @@ Proof.
   destruct o; destruct o'; simpl in *; inversion_clear H; auto.
  rewrite H2.
  unfold f'; simpl.
- destruct (f oo oo'); simpl. 
+ destruct (f oo oo'); simpl.
  destruct (X.eq_dec x k); try contradict n; auto.
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
  case_eq (find x m0); intros; auto.
  elim H0.
  apply InA_eqk with (x,p); auto.
  apply InA_eqke_eqk.
- exact (find_2 H3). 
+ exact (find_2 H3).
  (* k < x *)
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
@@ -826,10 +826,10 @@ Proof.
 Qed.
 
 (** Specification of [map2] *)
-Lemma map2_1 : 
+Lemma map2_1 :
   forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
-  In x m \/ In x m' -> 
-  find x (map2 m m') = f (find x m) (find x m'). 
+  In x m \/ In x m' ->
+  find x (map2 m m') = f (find x m) (find x m').
 Proof.
  intros.
  rewrite map2_0; auto.
@@ -839,10 +839,10 @@ Proof.
  rewrite (find_1 Hm' H).
  destruct (find x m); simpl; auto.
 Qed.
- 
-Lemma map2_2 : 
-  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
-  In x (map2 m m') -> In x m \/ In x m'. 
+
+Lemma map2_2 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  In x (map2 m m') -> In x m \/ In x m'.
 Proof.
  intros.
  destruct H as (e,H).
@@ -850,9 +850,9 @@ Proof.
  rewrite (find_1 (map2_NoDup Hm Hm') H).
  generalize (@find_2 _ m x).
  generalize (@find_2 _ m' x).
- destruct (find x m); 
+ destruct (find x m);
    destruct (find x m'); simpl; intros.
- left; exists e0; auto. 
+ left; exists e0; auto.
  left; exists e0; auto.
  right; exists e0; auto.
  discriminate.
@@ -863,31 +863,31 @@ End Raw.
 
 
 Module Make (X: DecidableType) <: WS with Module E:=X.
- Module Raw := Raw X. 
+ Module Raw := Raw X.
 
  Module E := X.
- Definition key := E.t. 
+ Definition key := E.t.
 
- Record slist (elt:Type) :=  
+ Record slist (elt:Type) :=
   {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}.
- Definition t (elt:Type) := slist elt. 
+ Definition t (elt:Type) := slist elt.
 
-Section Elt. 
- Variable elt elt' elt'':Type. 
+Section Elt.
+ Variable elt elt' elt'':Type.
 
  Implicit Types m : t elt.
- Implicit Types x y : key. 
+ Implicit Types x y : key.
  Implicit Types e : elt.
 
  Definition empty : t elt := Build_slist (Raw.empty_NoDup elt).
  Definition is_empty m : bool := Raw.is_empty m.(this).
  Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e).
  Definition find x m : option elt := Raw.find x m.(this).
- Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). 
+ Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x).
  Definition mem x m : bool := Raw.mem x m.(this).
  Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f).
  Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f).
- Definition map2 f m (m':t elt') : t elt'' := 
+ Definition map2 f m (m':t elt') : t elt'' :=
    Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)).
  Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
  Definition cardinal m := length m.(this).
@@ -898,9 +898,9 @@ Section Elt.
  Definition Empty m : Prop := Raw.Empty m.(this).
 
  Definition Equal m m' := forall y, find y m = find y m'.
- Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
-         (forall k, In k m <-> In k m') /\ 
-         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+         (forall k, In k m <-> In k m') /\
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this).
 
  Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
@@ -936,7 +936,7 @@ Section Elt.
  Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
  Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed.
 
- Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
  Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed.
  Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
  Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
@@ -945,32 +945,32 @@ Section Elt.
  Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
  Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
- Lemma elements_3w : forall m, NoDupA eq_key (elements m).  
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
  Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed.
- 
- Lemma cardinal_1 : forall m, cardinal m = length (elements m). 
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
  Proof. intros; reflexivity. Qed.
 
  Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
         fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.
 
- Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. 
+ Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
  Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
  Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
  Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
 
  End Elt.
- 
- Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
         MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
- Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), 
-        In x (map f m) -> In x m. 
+ Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
+        In x (map f m) -> In x m.
  Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.
 
  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
-        (f:key->elt->elt'), MapsTo x e m -> 
+        (f:key->elt->elt'), MapsTo x e m ->
         exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
@@ -978,18 +978,18 @@ Section Elt.
  Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.
 
  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-	(x:key)(f:option elt->option elt'->option elt''), 
-	In x m \/ In x m' -> 
-        find x (map2 f m m') = f (find x m) (find x m').       
- Proof. 
- intros elt elt' elt'' m m' x f; 
+	(x:key)(f:option elt->option elt'->option elt''),
+	In x m \/ In x m' ->
+        find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
+ intros elt elt' elt'' m m' x f;
  exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x).
  Qed.
  Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
-	(x:key)(f:option elt->option elt'->option elt''), 
+	(x:key)(f:option elt->option elt'->option elt''),
         In x (map2 f m m') -> In x m \/ In x m'.
- Proof. 
- intros elt elt' elt'' m m' x f;  
+ Proof.
+ intros elt elt' elt'' m m' x f;
  exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x).
  Qed.
 
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
index 75904202..6b110240 100644
--- a/theories/FSets/FMaps.v
+++ b/theories/FSets/FMaps.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *)
+(* $Id$ *)
 
 
 Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
index cc1c0a76..bc6c731f 100644
--- a/theories/FSets/FSetAVL.v
+++ b/theories/FSets/FSetAVL.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (***********************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
 (* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
@@ -6,25 +7,20 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
+(* $Id$ *)
 
-(* $Id: FSetAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(** * FSetAVL : Implementation of FSetInterface via AVL trees *)
 
-(** * FSetAVL *)
-
-(** This module implements sets using AVL trees.
+(** This module implements finite sets using AVL trees.
     It follows the implementation from Ocaml's standard library,
-    
+
     All operations given here expect and produce well-balanced trees
     (in the ocaml sense: heigths of subtrees shouldn't differ by more
     than 2), and hence has low complexities (e.g. add is logarithmic
     in the size of the set). But proving these balancing preservations
     is in fact not necessary for ensuring correct operational behavior
     and hence fulfilling the FSet interface. As a consequence,
-    balancing results are not part of this file anymore, they can 
+    balancing results are not part of this file anymore, they can
     now be found in [FSetFullAVL].
 
     Four operations ([union], [subset], [compare] and [equal]) have
@@ -37,2023 +33,20 @@
     code after extraction.
 *)
 
-Require Import FSetInterface FSetList ZArith Int.
+Require Import FSetInterface ZArith Int.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** Notations and helper lemma about pairs *)
-
-Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
-Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
-
-(** * Raw 
-   
-   Functor of pure functions + a posteriori proofs of invariant 
-   preservation *)
-
-Module Raw (Import I:Int)(X:OrderedType).
-Open Local Scope pair_scope.
-Open Local Scope lazy_bool_scope.
-Open Local Scope Int_scope.
-
-Definition elt := X.t.
-
-(** * Trees
-
-   The fourth field of [Node] is the height of the tree *)
-
-Inductive tree :=
-  | Leaf : tree
-  | Node : tree -> X.t -> tree -> int -> tree.
-
-Notation t := tree.
-
-(** * Basic functions on trees: height and cardinal *)
-
-Definition height (s : tree) : int :=
-  match s with
-  | Leaf => 0
-  | Node _ _ _ h => h
-  end.
-
-Fixpoint cardinal (s : tree) : nat :=
-  match s with
-   | Leaf => 0%nat
-   | Node l _ r _ => S (cardinal l + cardinal r)
-  end.
-
-(** * Empty Set *)
-
-Definition empty := Leaf.
-
-(** * Emptyness test *)
-
-Definition is_empty s := 
-  match s with Leaf => true | _ => false end.
-
-(** * Appartness *)
-
-(** The [mem] function is deciding appartness. It exploits the 
-    binary search tree invariant to achieve logarithmic complexity. *)
-
-Fixpoint mem x s := 
-   match s with 
-     |  Leaf => false 
-     |  Node l y r _ => match X.compare x y with 
-             | LT _ => mem x l 
-             | EQ _ => true
-             | GT _ => mem x r
-         end
-   end.
-
-(** * Singleton set *)
-
-Definition singleton x := Node Leaf x Leaf 1.
-
-(** * Helper functions *)
-
-(** [create l x r] creates a node, assuming [l] and [r]
-    to be balanced and [|height l - height r| <= 2]. *)
-
-Definition create l x r := 
-   Node l x r (max (height l) (height r) + 1).
-
-(** [bal l x r] acts as [create], but performs one step of
-    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
-
-Definition assert_false := create.
-
-Definition bal l x r := 
-  let hl := height l in 
-  let hr := height r in
-  if gt_le_dec hl (hr+2) then 
-    match l with 
-     | Leaf => assert_false l x r
-     | Node ll lx lr _ => 
-       if ge_lt_dec (height ll) (height lr) then 
-         create ll lx (create lr x r)
-       else 
-         match lr with 
-          | Leaf => assert_false l x r
-          | Node lrl lrx lrr _ => 
-              create (create ll lx lrl) lrx (create lrr x r)
-         end
-    end
-  else 
-    if gt_le_dec hr (hl+2) then 
-      match r with
-       | Leaf => assert_false l x r
-       | Node rl rx rr _ =>
-         if ge_lt_dec (height rr) (height rl) then 
-            create (create l x rl) rx rr
-         else 
-           match rl with
-            | Leaf => assert_false l x r
-            | Node rll rlx rlr _ => 
-                create (create l x rll) rlx (create rlr rx rr) 
-           end
-      end
-    else 
-      create l x r.
-
-(** * Insertion *)
-
-Fixpoint add x s := match s with 
-   | Leaf => Node Leaf x Leaf 1
-   | Node l y r h => 
-      match X.compare x y with
-         | LT _ => bal (add x l) y r
-         | EQ _ => Node l y r h
-         | GT _ => bal l y (add x r)
-      end
-  end.
-
-(** * Join
-
-    Same as [bal] but does not assume anything regarding heights 
-    of [l] and [r]. 
-*)
-
-Fixpoint join l : elt -> t -> t :=
-  match l with
-    | Leaf => add
-    | Node ll lx lr lh => fun x => 
-       fix join_aux (r:t) : t := match r with 
-          | Leaf =>  add x l
-          | Node rl rx rr rh =>  
-               if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
-               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr 
-               else create l x r
-          end
-  end.
-
-(** * Extraction of minimum element
-
-  Morally, [remove_min] is to be applied to a non-empty tree
-  [t = Node l x r h]. Since we can't deal here with [assert false]
-  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
-*)
- 
-Fixpoint remove_min l x r : t*elt := 
-  match l with 
-    | Leaf => (r,x)
-    | Node ll lx lr lh => 
-       let (l',m) := remove_min ll lx lr in (bal l' x r, m)
-  end.
-
-(** * Merging two trees
-
-  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
-  of [t1] to be smaller than all elements of [t2], and
-  [|height t1 - height t2| <= 2].
-*)
-
-Definition merge s1 s2 :=  match s1,s2 with 
-  | Leaf, _ => s2 
-  | _, Leaf => s1
-  | _, Node l2 x2 r2 h2 => 
-        let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
-end.
-
-(** * Deletion *)
-
-Fixpoint remove x s := match s with 
-  | Leaf => Leaf
-  | Node l y r h =>
-      match X.compare x y with
-         | LT _ => bal (remove x l) y r
-         | EQ _ => merge l r
-         | GT _ => bal l  y (remove x r)
-      end
-   end.
-
-(** * Minimum element *)
-
-Fixpoint min_elt s := match s with 
-   | Leaf => None
-   | Node Leaf y _  _ => Some y
-   | Node l _ _ _ => min_elt l
-end.
-
-(** * Maximum element *)
-
-Fixpoint max_elt s := match s with 
-   | Leaf => None
-   | Node _ y Leaf  _ => Some y
-   | Node _ _ r _ => max_elt r
-end.
-
-(** * Any element *)
-
-Definition choose := min_elt.
-
-(** * Concatenation
-
-    Same as [merge] but does not assume anything about heights.
-*)
-
-Definition concat s1 s2 := 
-   match s1, s2 with 
-      | Leaf, _ => s2 
-      | _, Leaf => s1
-      | _, Node l2 x2 r2 _ => 
-            let (s2',m) := remove_min l2 x2 r2 in 
-            join s1 m s2'
-   end.
-
-(** * Splitting 
-
-    [split x s] returns a triple [(l, present, r)] where
-    - [l] is the set of elements of [s] that are [< x]
-    - [r] is the set of elements of [s] that are [> x]
-    - [present] is [true] if and only if [s] contains  [x].
-*)
-
-Record triple := mktriple { t_left:t; t_in:bool; t_right:t }.
-Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
-Notation "t #l" := (t_left t) (at level 9, format "t '#l'").
-Notation "t #b" := (t_in t) (at level 9, format "t '#b'").
-Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
-
-Fixpoint split x s : triple := match s with
-  | Leaf => << Leaf, false, Leaf >>
-  | Node l y r h => 
-     match X.compare x y with 
-      | LT _ => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
-      | EQ _ => << l, true, r >>
-      | GT _ => let (rl,b,rr) := split x r in << join l y rl, b, rr >>
-     end
- end.
-
-(** * Intersection *)
-
-Fixpoint inter s1 s2 := match s1, s2 with 
-    | Leaf, _ => Leaf
-    | _, Leaf => Leaf
-    | Node l1 x1 r1 h1, _ => 
-            let (l2',pres,r2') := split x1 s2 in 
-            if pres then join (inter l1 l2') x1 (inter r1 r2')
-            else concat (inter l1 l2') (inter r1 r2')
-    end.
-
-(** * Difference *)
-
-Fixpoint diff s1 s2 := match s1, s2 with 
- | Leaf, _ => Leaf
- | _, Leaf => s1
- | Node l1 x1 r1 h1, _ => 
-    let (l2',pres,r2') := split x1 s2 in 
-    if pres then concat (diff l1 l2') (diff r1 r2')
-    else join (diff l1 l2') x1 (diff r1 r2')
-end.
-
-(** * Union *)
-
-(** In ocaml, heights of [s1] and [s2] are compared each time in order
-   to recursively perform the split on the smaller set.
-   Unfortunately, this leads to a non-structural algorithm. The
-   following code is a simplification of the ocaml version: no
-   comparison of heights. It might be slightly slower, but
-   experimentally all the tests I've made in ocaml have shown this
-   potential slowdown to be non-significant. Anyway, the exact code
-   of ocaml has also been formalized thanks to Function+measure, see
-   [ocaml_union] in [FSetFullAVL].  
-*)
-
-Fixpoint union s1 s2 := 
- match s1, s2 with 
-  | Leaf, _ => s2
-  | _, Leaf => s1
-  | Node l1 x1 r1 h1, _ => 
-     let (l2',_,r2') := split x1 s2 in 
-     join (union l1 l2') x1 (union r1 r2')
- end.
-
-(** * Elements *)
-
-(** [elements_tree_aux acc t] catenates the elements of [t] in infix
-    order to the list [acc] *)
-
-Fixpoint elements_aux (acc : list X.t) (t : tree) : list X.t :=
-  match t with
-   | Leaf => acc
-   | Node l x r _ => elements_aux (x :: elements_aux acc r) l
-  end.
-
-(** then [elements] is an instanciation with an empty [acc] *)
-
-Definition elements := elements_aux nil.
-
-(** * Filter *)
-
-Fixpoint filter_acc (f:elt->bool) acc s := match s with 
-  | Leaf => acc
-  | Node l x r h => 
-     filter_acc f (filter_acc f (if f x then add x acc else acc) l) r 
- end.
-
-Definition filter f := filter_acc f Leaf.
-
-
-(** * Partition *)
-
-Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := 
-  match s with 
-   | Leaf => acc
-   | Node l x r _ => 
-      let (acct,accf) := acc in 
-      partition_acc f
-        (partition_acc f
-           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
-  end.
-
-Definition partition f := partition_acc f (Leaf,Leaf).
-
-(** * [for_all] and [exists] *)
-
-Fixpoint for_all (f:elt->bool) s := match s with 
-  | Leaf => true
-  | Node l x r _ => f x &&& for_all f l &&& for_all f r
-end.
-
-Fixpoint exists_ (f:elt->bool) s := match s with 
-  | Leaf => false
-  | Node l x r _ => f x ||| exists_ f l ||| exists_ f r
-end.
-
-(** * Fold *)
-
-Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := 
- fun a => match s with
-  | Leaf => a
-  | Node l x r _ => fold f r (f x (fold f l a))
- end.
-Implicit Arguments fold [A].
-
-
-(** * Subset *)
-
-(** In ocaml, recursive calls are made on "half-trees" such as 
-   (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these
-   non-structural calls, we propose here two specialized functions for
-   these situations. This version should be almost as efficient as 
-   the one of ocaml (closures as arguments may slow things a bit),  
-   it is simply less compact. The exact ocaml version has also been
-   formalized (thanks to Function+measure), see [ocaml_subset] in 
-   [FSetFullAVL].
- *)
-
-Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := 
- match s2 with 
-  | Leaf => false
-  | Node l2 x2 r2 h2 => 
-     match X.compare x1 x2 with 
-      | EQ _ => subset_l1 l2 
-      | LT _ => subsetl subset_l1 x1 l2
-      | GT _ => mem x1 r2 &&& subset_l1 s2
-     end
- end.
-
-Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := 
- match s2 with 
-  | Leaf => false
-  | Node l2 x2 r2 h2 => 
-     match X.compare x1 x2 with 
-      | EQ _ => subset_r1 r2 
-      | LT _ => mem x1 l2 &&& subset_r1 s2
-      | GT _ => subsetr subset_r1 x1 r2
-     end
- end.
-
-Fixpoint subset s1 s2 : bool := match s1, s2 with 
-  | Leaf, _ => true
-  | Node _ _ _ _, Leaf => false
-  | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => 
-     match X.compare x1 x2 with 
-      | EQ _ => subset l1 l2 &&& subset r1 r2
-      | LT _ => subsetl (subset l1) x1 l2 &&& subset r1 s2
-      | GT _ => subsetr (subset r1) x1 r2 &&& subset l1 s2
-     end
- end.
-
-(** * A new comparison algorithm suggested by Xavier Leroy
-
-    Transformation in C.P.S. suggested by Benjamin Grégoire.
-    The original ocaml code (with non-structural recursive calls)
-    has also been formalized (thanks to Function+measure), see
-    [ocaml_compare] in [FSetFullAVL]. The following code with 
-    continuations computes dramatically faster in Coq, and 
-    should be almost as efficient after extraction.
-*)
-
-(** Enumeration of the elements of a tree *)
-
-Inductive enumeration :=
- | End : enumeration
- | More : elt -> tree -> enumeration -> enumeration.
-
-
-(** [cons t e] adds the elements of tree [t] on the head of 
-    enumeration [e]. *)
-
-Fixpoint cons s e : enumeration := 
- match s with 
-  | Leaf => e
-  | Node l x r h => cons l (More x r e)
- end.
-
-(** One step of comparison of elements *)
-
-Definition compare_more x1 (cont:enumeration->comparison) e2 :=
- match e2 with
- | End => Gt
- | More x2 r2 e2 =>
-     match X.compare x1 x2 with
-      | EQ _ => cont (cons r2 e2)
-      | LT _ => Lt
-      | GT _ => Gt
-     end
- end.
-
-(** Comparison of left tree, middle element, then right tree *)
-
-Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := 
- match s1 with
-  | Leaf => cont e2
-  | Node l1 x1 r1 _ =>
-     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
-  end.
-
-(** Initial continuation *)
-
-Definition compare_end e2 := 
- match e2 with End => Eq | _ => Lt end.
-
-(** The complete comparison *)
-
-Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
-
-(** * Equality test *)
-
-Definition equal s1 s2 : bool := 
- match compare s1 s2 with 
-  | Eq => true
-  | _ => false 
- end.
-
-
-
-
-(** * Invariants *)
-
-(** ** Occurrence in a tree *)
-
-Inductive In (x : elt) : tree -> Prop :=
-  | IsRoot : forall l r h y, X.eq x y -> In x (Node l y r h)
-  | InLeft : forall l r h y, In x l -> In x (Node l y r h)
-  | InRight : forall l r h y, In x r -> In x (Node l y r h).
-
-(** ** Binary search trees *)
-
-(** [lt_tree x s]: all elements in [s] are smaller than [x] 
-   (resp. greater for [gt_tree]) *)
-
-Definition lt_tree x s := forall y, In y s -> X.lt y x.
-Definition gt_tree x s := forall y, In y s -> X.lt x y.
-
-(** [bst t] : [t] is a binary search tree *)
-
-Inductive bst : tree -> Prop :=
-  | BSLeaf : bst Leaf
-  | BSNode : forall x l r h, bst l -> bst r -> 
-     lt_tree x l -> gt_tree x r -> bst (Node l x r h).
-
-
-
-
-(** * Some shortcuts *)
-
-Definition Equal s s' := forall a : elt, In a s <-> In a s'.
-Definition Subset s s' := forall a : elt, In a s -> In a s'.
-Definition Empty s := forall a : elt, ~ In a s.
-Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
-Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
-
-
-
-(** * Correctness proofs, isolated in a sub-module *)
-
-Module Proofs.
- Module MX := OrderedTypeFacts X.
- Module L := FSetList.Raw X.
-
-(** * Automation and dedicated tactics *)
-
-Hint Constructors In bst.
-Hint Unfold lt_tree gt_tree.
-
-Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) 
- "as" ident(s) :=  
- set (s:=Node l x r h) in *; clearbody s; clear l x r h.
-
-(** A tactic to repeat [inversion_clear] on all hyps of the 
-    form [(f (Node _ _ _ _))] *)
-
-Ltac inv f :=
-  match goal with 
-     | H:f Leaf |- _ => inversion_clear H; inv f
-     | H:f _ Leaf |- _ => inversion_clear H; inv f
-     | H:f (Node _ _ _ _) |- _ => inversion_clear H; inv f
-     | H:f _ (Node _ _ _ _) |- _ => inversion_clear H; inv f
-     | _ => idtac
-  end.
-
-Ltac intuition_in := repeat progress (intuition; inv In).
-
-(** Helper tactic concerning order of elements. *)
-
-Ltac order := match goal with 
- | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
- | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
- | _ => MX.order
-end.
-
-
-(** * Basic results about [In], [lt_tree], [gt_tree], [height] *)
-
-(** [In] is compatible with [X.eq] *)
-
-Lemma In_1 :
- forall s x y, X.eq x y -> In x s -> In y s.
-Proof.
- induction s; simpl; intuition_in; eauto.
-Qed.
-Hint Immediate In_1.
-
-Lemma In_node_iff : 
- forall l x r h y, 
-  In y (Node l x r h) <-> In y l \/ X.eq y x \/ In y r.
-Proof.
- intuition_in.
-Qed.
-
-(** Results about [lt_tree] and [gt_tree] *)
-
-Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
-Proof.
- red; inversion 1.
-Qed.
-
-Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
-Proof.
- red; inversion 1.
-Qed.
-
-Lemma lt_tree_node :
- forall (x y : elt) (l r : tree) (h : int),
- lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
-Proof.
- unfold lt_tree; intuition_in; order.
-Qed.
-
-Lemma gt_tree_node :
- forall (x y : elt) (l r : tree) (h : int),
- gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
-Proof.
- unfold gt_tree; intuition_in; order.
-Qed.
-
-Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
-
-Lemma lt_tree_not_in :
- forall (x : elt) (t : tree), lt_tree x t -> ~ In x t.
-Proof.
- intros; intro; order.
-Qed.
-
-Lemma lt_tree_trans :
- forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
-Proof.
- eauto.
-Qed.
-
-Lemma gt_tree_not_in :
- forall (x : elt) (t : tree), gt_tree x t -> ~ In x t.
-Proof.
- intros; intro; order.
-Qed.
-
-Lemma gt_tree_trans :
- forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
-Proof.
- eauto.
-Qed.
-
-Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
-
-(** * Inductions principles *)
-
-Functional Scheme mem_ind := Induction for mem Sort Prop.
-Functional Scheme bal_ind := Induction for bal Sort Prop. 
-Functional Scheme add_ind := Induction for add Sort Prop.
-Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
-Functional Scheme merge_ind := Induction for merge Sort Prop. 
-Functional Scheme remove_ind := Induction for remove Sort Prop.
-Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
-Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
-Functional Scheme concat_ind := Induction for concat Sort Prop.
-Functional Scheme split_ind := Induction for split Sort Prop.
-Functional Scheme inter_ind := Induction for inter Sort Prop.
-Functional Scheme diff_ind := Induction for diff Sort Prop.
-Functional Scheme union_ind := Induction for union Sort Prop.
-
-
-(** * Empty set *)
-
-Lemma empty_1 : Empty empty.
-Proof.
- intro; intro.
- inversion H.
-Qed.
-
-Lemma empty_bst : bst empty.
-Proof.
- auto.
-Qed.
-
-(** * Emptyness test *)
-
-Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. 
-Proof.
- destruct s as [|r x l h]; simpl; auto.
- intro H; elim (H x); auto.
-Qed.
-
-Lemma is_empty_2 : forall s, is_empty s = true -> Empty s.
-Proof. 
- destruct s; simpl; intros; try discriminate; red; auto.
-Qed.
-
-
-
-(** * Appartness *)
-
-Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true.
-Proof.
- intros s x; functional induction mem x s; auto; intros; try clear e0; 
-  inv bst; intuition_in; order.
-Qed.
-
-Lemma mem_2 : forall s x, mem x s = true -> In x s. 
-Proof. 
- intros s x; functional induction mem x s; auto; intros; discriminate.
-Qed.
-
-
-
-(** * Singleton set *)
-
-Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. 
-Proof. 
- unfold singleton; intros; inv In; order.
-Qed.
-
-Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). 
-Proof. 
- unfold singleton; auto.
-Qed.
-
-Lemma singleton_bst : forall x : elt, bst (singleton x).
-Proof.
- unfold singleton; auto.
-Qed.
-
-
-
-(** * Helper functions *)
-
-Lemma create_in : 
- forall l x r y,  In y (create l x r) <-> X.eq y x \/ In y l \/ In y r.
-Proof.
- unfold create; split; [ inversion_clear 1 | ]; intuition.
-Qed.
-
-Lemma create_bst : 
- forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
- bst (create l x r).
-Proof.
- unfold create; auto.
-Qed.
-Hint Resolve create_bst.
-
-Lemma bal_in : forall l x r y, 
- In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r.
-Proof.
- intros l x r; functional induction bal l x r; intros; try clear e0; 
- rewrite !create_in; intuition_in.
-Qed.
-
-Lemma bal_bst : forall l x r, bst l -> bst r -> 
- lt_tree x l -> gt_tree x r -> bst (bal l x r).
-Proof.
- intros l x r; functional induction bal l x r; intros;
- inv bst; repeat apply create_bst; auto; unfold create;
- (apply lt_tree_node || apply gt_tree_node); auto; 
- (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
-Qed.
-Hint Resolve bal_bst.
-
-
-
-(** * Insertion *)
-
-Lemma add_in : forall s x y,
- In y (add x s) <-> X.eq y x \/ In y s.
-Proof.
- intros s x; functional induction (add x s); auto; intros; 
- try rewrite bal_in, IHt; intuition_in.
- eapply In_1; eauto.
-Qed.
-
-Lemma add_bst : forall s x, bst s -> bst (add x s).
-Proof. 
- intros s x; functional induction (add x s); auto; intros; 
- inv bst; apply bal_bst; auto.
- (* lt_tree -> lt_tree (add ...) *)
- red; red in H3.
- intros.
- rewrite add_in in H.
- intuition.
- eauto.
- inv bst; auto using bal_bst.
- (* gt_tree -> gt_tree (add ...) *)
- red; red in H3.
- intros.
- rewrite add_in in H.
- intuition.
- apply MX.lt_eq with x; auto.
-Qed.
-Hint Resolve add_bst.
-
-
+(** This is just a compatibility layer, the real implementation
+    is now in [MSetAVL] *)
 
-(** * Join *)
-
-(* Function/Functional Scheme can't deal with internal fix. 
-   Let's do its job by hand: *)
-
-Ltac join_tac := 
- intro l; induction l as [| ll _ lx lr Hlr lh]; 
-   [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join;
-     [ | destruct (gt_le_dec lh (rh+2)); 
-       [ match goal with |- context b [ bal ?a ?b ?c] => 
-           replace (bal a b c) 
-           with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] 
-         end 
-       | destruct (gt_le_dec rh (lh+2)); 
-         [ match goal with |- context b [ bal ?a ?b ?c] => 
-             replace (bal a b c) 
-             with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] 
-           end
-         | ] ] ] ]; intros.
-
-Lemma join_in : forall l x r y, 
- In y (join l x r) <-> X.eq y x \/ In y l \/ In y r.
-Proof.
- join_tac.
- simpl.
- rewrite add_in; intuition_in.
- rewrite add_in; intuition_in.
- rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in.
- rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in.
- apply create_in.
-Qed.
-
-Lemma join_bst : forall l x r, bst l -> bst r -> 
- lt_tree x l -> gt_tree x r -> bst (join l x r).
-Proof.
- join_tac; auto; inv bst; apply bal_bst; auto; 
- clear Hrl Hlr z; intro; intros; rewrite join_in in *.
- intuition; [ apply MX.lt_eq with x | ]; eauto.
- intuition; [ apply MX.eq_lt with x | ]; eauto.
-Qed.
-Hint Resolve join_bst.
-
-
-
-(** * Extraction of minimum element *)
-
-Lemma remove_min_in : forall l x r h y, 
- In y (Node l x r h) <-> 
-  X.eq y (remove_min l x r)#2 \/ In y (remove_min l x r)#1.
-Proof.
- intros l x r; functional induction (remove_min l x r); simpl in *; intros.
- intuition_in.
- rewrite bal_in, In_node_iff, IHp, e0; simpl; intuition.
-Qed.
-
-Lemma remove_min_bst : forall l x r h, 
- bst (Node l x r h) -> bst (remove_min l x r)#1.
-Proof.
- intros l x r; functional induction (remove_min l x r); simpl; intros.
- inv bst; auto.
- inversion_clear H.
- specialize IHp with (1:=H0); rewrite e0 in IHp; auto.
- apply bal_bst; auto.
- intro y; specialize (H2 y).
- rewrite remove_min_in, e0 in H2; simpl in H2; intuition.
-Qed.
-
-Lemma remove_min_gt_tree : forall l x r h, 
- bst (Node l x r h) ->
- gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
-Proof.
- intros l x r; functional induction (remove_min l x r); simpl; intros.
- inv bst; auto.
- inversion_clear H.
- specialize IHp with (1:=H0); rewrite e0 in IHp; simpl in IHp.
- intro y; rewrite bal_in; intuition; 
-  specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; 
-  [ apply MX.lt_eq with x | ]; eauto.
-Qed.
-Hint Resolve remove_min_bst remove_min_gt_tree.
-
-
-
-(** * Merging two trees *)
-
-Lemma merge_in : forall s1 s2 y,
- In y (merge s1 s2) <-> In y s1 \/ In y s2.
-Proof.
- intros s1 s2; functional induction (merge s1 s2); intros; 
- try factornode _x _x0 _x1 _x2 as s1.
- intuition_in.
- intuition_in.
- rewrite bal_in, remove_min_in, e1; simpl; intuition.
-Qed.
-
-Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> 
- (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
- bst (merge s1 s2).
-Proof.
- intros s1 s2; functional induction (merge s1 s2); intros; auto; 
- try factornode _x _x0 _x1 _x2 as s1.
- apply bal_bst; auto.
- change s2' with ((s2',m)#1); rewrite <-e1; eauto.
- intros y Hy.
- apply H1; auto.
- rewrite remove_min_in, e1; simpl; auto.
- change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
-Qed.
-Hint Resolve merge_bst.
-
-
-
-(** * Deletion *)
-
-Lemma remove_in : forall s x y, bst s ->
- (In y (remove x s) <-> ~ X.eq y x /\ In y s).
-Proof.
- intros s x; functional induction (remove x s); intros; inv bst.
- intuition_in.
- rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in].
- rewrite merge_in; clear e0; intuition; [order|order|intuition_in].
- elim H4; eauto.
- rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in].
-Qed.
-
-Lemma remove_bst : forall s x, bst s -> bst (remove x s).
-Proof. 
- intros s x; functional induction (remove x s); intros; inv bst.
- auto.
- (* LT *)
- apply bal_bst; auto.
- intro z; rewrite remove_in; auto; destruct 1; eauto.
- (* EQ *)
- eauto.
- (* GT *) 
- apply bal_bst; auto.
- intro z; rewrite remove_in; auto; destruct 1; eauto.
-Qed.
-Hint Resolve remove_bst.
-
-
-(** * Minimum element *)
-
-Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. 
-Proof. 
- intro s; functional induction (min_elt s); auto; inversion 1; auto.
-Qed.
-
-Lemma min_elt_2 : forall s x y, bst s ->
- min_elt s = Some x -> In y s -> ~ X.lt y x. 
-Proof.
- intro s; functional induction (min_elt s); 
- try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
- inversion_clear 2.
- inversion_clear 1.
- inversion 1; subst.
- inversion_clear 1; auto.
- inversion_clear H5.
- inversion_clear 1.
- simpl.
- destruct l1.
- inversion 1; subst.
- assert (X.lt x y) by (apply H2; auto).
- inversion_clear 1; auto; order.
- assert (X.lt x1 y) by auto.
- inversion_clear 2; auto; 
-   (assert (~ X.lt x1 x) by auto); order.
-Qed.
-
-Lemma min_elt_3 : forall s, min_elt s = None -> Empty s.
-Proof.
- intro s; functional induction (min_elt s).
- red; red; inversion 2.
- inversion 1.
- intro H0.
- destruct (IHo H0 _x2); auto.
-Qed.
-
-
-
-(** * Maximum element *)
-
-Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. 
-Proof. 
- intro s; functional induction (max_elt s); auto; inversion 1; auto.
-Qed.
-
-Lemma max_elt_2 : forall s x y, bst s -> 
- max_elt s = Some x -> In y s -> ~ X.lt x y. 
-Proof.
- intro s; functional induction (max_elt s);
- try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
- inversion_clear 2.
- inversion_clear 1.
- inversion 1; subst.
- inversion_clear 1; auto.
- inversion_clear H5.
- inversion_clear 1.
- assert (X.lt y x1) by auto.
- inversion_clear 2; auto; 
-  (assert (~ X.lt x x1) by auto); order.
-Qed.
-
-Lemma max_elt_3 : forall s, max_elt s = None -> Empty s.
-Proof.
- intro s; functional induction (max_elt s).
- red; auto.
- inversion 1.
- intros H0; destruct (IHo H0 _x2); auto.
-Qed.
-
-
-
-(** * Any element *)
-
-Lemma choose_1 : forall s x, choose s = Some x -> In x s.
-Proof. 
- exact min_elt_1.
-Qed.
-
-Lemma choose_2 : forall s, choose s = None -> Empty s.
-Proof. 
- exact min_elt_3.
-Qed.
-
-Lemma choose_3 : forall s s', bst s -> bst s' -> 
- forall x x', choose s = Some x -> choose s' = Some x' -> 
-  Equal s s' -> X.eq x x'.
-Proof.
- unfold choose, Equal; intros s s' Hb Hb' x x' Hx Hx' H.
- assert (~X.lt x x').
-  apply min_elt_2 with s'; auto.
-  rewrite <-H; auto using min_elt_1.
- assert (~X.lt x' x).
-  apply min_elt_2 with s; auto.
-  rewrite H; auto using min_elt_1.
- destruct (X.compare x x'); intuition.
-Qed.
-
-
-(** * Concatenation *)
-
-Lemma concat_in : forall s1 s2 y, 
- In y (concat s1 s2) <-> In y s1 \/ In y s2.
-Proof.
- intros s1 s2; functional induction (concat s1 s2); intros;
- try factornode _x _x0 _x1 _x2 as s1.
- intuition_in.
- intuition_in.
- rewrite join_in, remove_min_in, e1; simpl; intuition.
-Qed.
- 
-Lemma concat_bst : forall s1 s2, bst s1 -> bst s2 -> 
- (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
- bst (concat s1 s2).
-Proof. 
- intros s1 s2; functional induction (concat s1 s2); intros; auto; 
- try factornode _x _x0 _x1 _x2 as s1.
- apply join_bst; auto.
- change (bst (s2',m)#1); rewrite <-e1; eauto.
- intros y Hy.
- apply H1; auto.
- rewrite remove_min_in, e1; simpl; auto.
- change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
-Qed.
-Hint Resolve concat_bst.
-
-
-(** * Splitting *)
-
-Lemma split_in_1 : forall s x y, bst s -> 
- (In y (split x s)#l <-> In y s /\ X.lt y x).
-Proof.
- intros s x; functional induction (split x s); simpl; intros; 
-  inv bst; try clear e0.
- intuition_in.
- rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
- intuition_in; order.
- rewrite join_in.
- rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
-Qed.
-
-Lemma split_in_2 : forall s x y, bst s -> 
- (In y (split x s)#r <-> In y s /\ X.lt x y).
-Proof. 
- intros s x; functional induction (split x s); subst; simpl; intros; 
-  inv bst; try clear e0.
- intuition_in.
- rewrite join_in.
- rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
- intuition_in; order.
- rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
-Qed.
-
-Lemma split_in_3 : forall s x, bst s -> 
- ((split x s)#b = true <-> In x s).
-Proof. 
- intros s x; functional induction (split x s); subst; simpl; intros; 
-  inv bst; try clear e0.
- intuition_in; try discriminate.
- rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
- intuition.
- rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
-Qed.
-
-Lemma split_bst : forall s x, bst s -> 
- bst (split x s)#l /\ bst (split x s)#r.
-Proof. 
- intros s x; functional induction (split x s); subst; simpl; intros; 
-  inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition;
-  apply join_bst; auto.
- intros y0.
- generalize (split_in_2 x y0 H0); rewrite e1; simpl; intuition.
- intros y0.
- generalize (split_in_1 x y0 H1); rewrite e1; simpl; intuition.
-Qed.
-
-
-
-(** * Intersection *)
-
-Lemma inter_bst_in : forall s1 s2, bst s1 -> bst s2 -> 
- bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2).
-Proof.
- intros s1 s2; functional induction inter s1 s2; intros B1 B2; 
- [intuition_in|intuition_in | | ]; 
- factornode _x0 _x1 _x2 _x3 as s2; 
- generalize (split_bst x1 B2); 
-  rewrite e1; simpl; destruct 1; inv bst;
- destruct IHt as (IHb1,IHi1); auto; 
- destruct IHt0 as (IHb2,IHi2); auto;
- generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)
-  (split_in_3 x1 B2)(split_bst x1 B2);
- rewrite e1; simpl; split; intros.
- (* bst join *)
- apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *)
- rewrite join_in, IHi1, IHi2, H5, H6; intuition_in.
- apply In_1 with x1; auto.
- (* bst concat *)
- apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
- (* In concat *)
- rewrite concat_in, IHi1, IHi2, H5, H6; auto.
- assert (~In x1 s2) by (rewrite <- H7; auto).
- intuition_in.
- elim H9.
- apply In_1 with y; auto.
-Qed.
-
-Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> 
- (In y (inter s1 s2) <-> In y s1 /\ In y s2).
-Proof. 
- intros s1 s2 y B1 B2; destruct (inter_bst_in B1 B2); auto.
-Qed.
-
-Lemma inter_bst : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2).
-Proof. 
- intros s1 s2 B1 B2; destruct (inter_bst_in B1 B2); auto.
-Qed.
-
-
-(** * Difference *)
-
-Lemma diff_bst_in : forall s1 s2, bst s1 -> bst s2 -> 
- bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
-Proof.
- intros s1 s2; functional induction diff s1 s2; intros B1 B2; 
- [intuition_in|intuition_in | | ]; 
- factornode _x0 _x1 _x2 _x3 as s2; 
- generalize (split_bst x1 B2); 
-  rewrite e1; simpl; destruct 1; 
- inv avl; inv bst; 
- destruct IHt as (IHb1,IHi1); auto; 
- destruct IHt0 as (IHb2,IHi2); auto; 
- generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)
-  (split_in_3 x1 B2)(split_bst x1 B2);
- rewrite e1; simpl; split; intros.
- (* bst concat *)
- apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
- (* In concat *)
- rewrite concat_in, IHi1, IHi2, H5, H6; intuition_in.
- elim H13.
- apply In_1 with x1; auto.
- (* bst join *)
- apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *)
- rewrite join_in, IHi1, IHi2, H5, H6; auto.
- assert (~In x1 s2) by (rewrite <- H7; auto).
- intuition_in.
- elim H9.
- apply In_1 with y; auto.
-Qed.
-
-Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> 
- (In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
-Proof. 
- intros s1 s2 y B1 B2; destruct (diff_bst_in B1 B2); auto.
-Qed.
-
-Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). 
-Proof. 
- intros s1 s2 B1 B2; destruct (diff_bst_in B1 B2); auto.
-Qed.
-
-
-(** * Union *)
-
-Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> 
- (In y (union s1 s2) <-> In y s1 \/ In y s2).
-Proof.
- intros s1 s2; functional induction union s1 s2; intros y B1 B2.
- intuition_in.
- intuition_in.
- factornode _x0 _x1 _x2 _x3 as s2.
- generalize (split_in_1 x1 y B2)(split_in_2 x1 y B2)(split_bst x1 B2).
- rewrite e1; simpl.
- destruct 3; inv bst.
- rewrite join_in, IHt, IHt0, H, H0; auto.
- case (X.compare y x1); intuition_in.
-Qed.
-
-Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> 
- bst (union s1 s2).
-Proof.
- intros s1 s2; functional induction union s1 s2; intros B1 B2; auto.
- factornode _x0 _x1 _x2 _x3 as s2.
- generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)(split_bst x1 B2).
- rewrite e1; simpl; destruct 3.
- inv bst.
- apply join_bst; auto.
- intro y; rewrite union_in, H; intuition_in.
- intro y; rewrite union_in, H0; intuition_in.
-Qed.
-
-
-(** * Elements *)
-
-Lemma elements_aux_in : forall s acc x, 
- InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc.
-Proof.
- induction s as [ | l Hl x r Hr h ]; simpl; auto.
- intuition.
- inversion H0.
- intros.
- rewrite Hl.
- destruct (Hr acc x0); clear Hl Hr.
- intuition; inversion_clear H3; intuition.
-Qed.
-
-Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. 
-Proof. 
- intros; generalize (elements_aux_in s nil x); intuition.
- inversion_clear H0.
-Qed.
-
-Lemma elements_aux_sort : forall s acc, bst s -> sort X.lt acc ->
- (forall x y : elt, InA X.eq x acc -> In y s -> X.lt y x) ->
- sort X.lt (elements_aux acc s).
-Proof.
- induction s as [ | l Hl y r Hr h]; simpl; intuition.
- inv bst.
- apply Hl; auto.
- constructor. 
- apply Hr; auto.
- apply MX.In_Inf; intros.
- destruct (elements_aux_in r acc y0); intuition.
- intros.
- inversion_clear H.
- order.
- destruct (elements_aux_in r acc x); intuition eauto.
-Qed.
-
-Lemma elements_sort : forall s : tree, bst s -> sort X.lt (elements s).
-Proof.
- intros; unfold elements; apply elements_aux_sort; auto.
- intros; inversion H0.
-Qed.
-Hint Resolve elements_sort.
-
-Lemma elements_nodup : forall s : tree, bst s -> NoDupA X.eq (elements s).
-Proof.
- auto.
-Qed.
-
-Lemma elements_aux_cardinal :
- forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
-Proof.
- simple induction s; simpl in |- *; intuition.
- rewrite <- H.
- simpl in |- *.
- rewrite <- H0; omega.
-Qed.
-
-Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
-Proof.
- exact (fun s => elements_aux_cardinal s nil).
-Qed.
-
-Lemma elements_app :
- forall s acc, elements_aux acc s = elements s ++ acc.
-Proof.
- induction s; simpl; intros; auto.
- rewrite IHs1, IHs2.
- unfold elements; simpl.
- rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
-Qed.
-
-Lemma elements_node :
- forall l x r h acc,
- elements l ++ x :: elements r ++ acc =
- elements (Node l x r h) ++ acc.
-Proof.
- unfold elements; simpl; intros; auto.
- rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
-Qed.
-
-
-(** * Filter *)
-
-Section F.
-Variable f : elt -> bool.
-
-Lemma filter_acc_in : forall s acc, 
- compat_bool X.eq f -> forall x : elt, 
- In x (filter_acc f acc s) <-> In x acc \/ In x s /\ f x = true.
-Proof.  
- induction s; simpl; intros.
- intuition_in.
- rewrite IHs2, IHs1 by (destruct (f t); auto).
- case_eq (f t); intros.
- rewrite (add_in); auto.
- intuition_in.
- rewrite (H _ _ H2).
- intuition.
- intuition_in.
- rewrite (H _ _ H2) in H3.
- rewrite H0 in H3; discriminate.
-Qed.
-
-Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> 
- bst (filter_acc f acc s).
-Proof.
- induction s; simpl; auto.
- intros.
- inv bst.
- destruct (f t); auto.
-Qed.
-
-Lemma filter_in : forall s,
- compat_bool X.eq f -> forall x : elt, 
- In x (filter f s) <-> In x s /\ f x = true.
-Proof.
- unfold filter; intros; rewrite filter_acc_in; intuition_in.
-Qed.
-
-Lemma filter_bst : forall s, bst s -> bst (filter f s). 
-Proof.
- unfold filter; intros; apply filter_acc_bst; auto.
-Qed.
-
-
-
-(** * Partition *)
-
-Lemma partition_acc_in_1 : forall s acc, 
- compat_bool X.eq f -> forall x : elt, 
- In x (partition_acc f acc s)#1 <-> 
- In x acc#1 \/ In x s /\ f x = true.
-Proof.  
- induction s; simpl; intros.
- intuition_in.
- destruct acc as [acct accf]; simpl in *.
- rewrite IHs2 by 
-  (destruct (f t); auto; apply partition_acc_avl_1; simpl; auto).
- rewrite IHs1 by (destruct (f t); simpl; auto).
- case_eq (f t); simpl; intros.
- rewrite (add_in); auto.
- intuition_in.
- rewrite (H _ _ H2).
- intuition.
- intuition_in.
- rewrite (H _ _ H2) in H3.
- rewrite H0 in H3; discriminate.
-Qed.
-
-Lemma partition_acc_in_2 : forall s acc, 
- compat_bool X.eq f -> forall x : elt, 
- In x (partition_acc f acc s)#2 <-> 
- In x acc#2 \/ In x s /\ f x = false.
-Proof.  
- induction s; simpl; intros.
- intuition_in.
- destruct acc as [acct accf]; simpl in *.
- rewrite IHs2 by 
-  (destruct (f t); auto; apply partition_acc_avl_2; simpl; auto).
- rewrite IHs1 by (destruct (f t); simpl; auto).
- case_eq (f t); simpl; intros.
- intuition.
- intuition_in.
- rewrite (H _ _ H2) in H3.
- rewrite H0 in H3; discriminate.
- rewrite (add_in); auto.
- intuition_in.
- rewrite (H _ _ H2).
- intuition.
-Qed.
-
-Lemma partition_in_1 : forall s, 
- compat_bool X.eq f -> forall x : elt, 
- In x (partition f s)#1 <-> In x s /\ f x = true.
-Proof.
- unfold partition; intros; rewrite partition_acc_in_1; 
- simpl in *; intuition_in.
-Qed. 
-
-Lemma partition_in_2 : forall s,
- compat_bool X.eq f -> forall x : elt, 
- In x (partition f s)#2 <-> In x s /\ f x = false.
-Proof.
- unfold partition; intros; rewrite partition_acc_in_2; 
- simpl in *; intuition_in.
-Qed. 
-
-Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> 
- bst (partition_acc f acc s)#1.
-Proof.
- induction s; simpl; auto.
- destruct acc as [acct accf]; simpl in *.
- intros.
- inv bst.
- destruct (f t); auto.
- apply IHs2; simpl; auto.
- apply IHs1; simpl; auto.
-Qed.
-
-Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> 
- bst (partition_acc f acc s)#2.
-Proof.
- induction s; simpl; auto.
- destruct acc as [acct accf]; simpl in *.
- intros.
- inv bst.
- destruct (f t); auto.
- apply IHs2; simpl; auto.
- apply IHs1; simpl; auto.
-Qed.
-
-Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. 
-Proof.
- unfold partition; intros; apply partition_acc_bst_1; auto.
-Qed.
-
-Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. 
-Proof.
- unfold partition; intros; apply partition_acc_bst_2; auto.
-Qed.
-
-
-
-(** * [for_all] and [exists] *)
-
-Lemma for_all_1 : forall s, compat_bool X.eq f ->
- For_all (fun x => f x = true) s -> for_all f s = true.
-Proof.
- induction s; simpl; auto.
- intros.
- rewrite IHs1; try red; auto.
- rewrite IHs2; try red; auto.
- generalize (H0 t).
- destruct (f t); simpl; auto.
-Qed.
-
-Lemma for_all_2 : forall s, compat_bool X.eq f ->
- for_all f s = true -> For_all (fun x => f x = true) s.
-Proof.
- induction s; simpl; auto; intros; red; intros; inv In.
- destruct (andb_prop _ _ H0); auto.
- destruct (andb_prop _ _ H1); eauto.
- apply IHs1; auto.
- destruct (andb_prop _ _ H0); auto.
- destruct (andb_prop _ _ H1); auto.
- apply IHs2; auto.
- destruct (andb_prop _ _ H0); auto.
-Qed.
-
-Lemma exists_1 : forall s, compat_bool X.eq f ->
- Exists (fun x => f x = true) s -> exists_ f s = true.
-Proof.
- induction s; simpl; destruct 2 as (x,(U,V)); inv In; rewrite <- ?orb_lazy_alt.
- rewrite (H _ _ (X.eq_sym H0)); rewrite V; auto.
- apply orb_true_intro; left.
- apply orb_true_intro; right; apply IHs1; auto; exists x; auto.
- apply orb_true_intro; right; apply IHs2; auto; exists x; auto.
-Qed.
-
-Lemma exists_2 : forall s, compat_bool X.eq f ->
- exists_ f s = true -> Exists (fun x => f x = true) s.
-Proof. 
- induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *.
- discriminate.
- destruct (orb_true_elim _ _ H0) as [H1|H1]. 
- destruct (orb_true_elim _ _ H1) as [H2|H2].
- exists t; auto.
- destruct (IHs1 H H2); auto; exists x; intuition.
- destruct (IHs2 H H1); auto; exists x; intuition.
-Qed.
-
-End F.
-
-
-
-(** * Fold *)
-
-Definition fold' (A : Type) (f : elt -> A -> A)(s : tree) := 
-  L.fold f (elements s).
-Implicit Arguments fold' [A].
-
-Lemma fold_equiv_aux :
- forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt),
- L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
-Proof.
- simple induction s.
- simpl in |- *; intuition.
- simpl in |- *; intros.
- rewrite H.
- simpl.
- apply H0.
-Qed.
-
-Lemma fold_equiv :
- forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A),
- fold f s a = fold' f s a.
-Proof.
- unfold fold', elements in |- *. 
- simple induction s; simpl in |- *; auto; intros.
- rewrite fold_equiv_aux.
- rewrite H0.
- simpl in |- *; auto.
-Qed.
-
-Lemma fold_1 : 
- forall (s:t)(Hs:bst s)(A : Type)(f : elt -> A -> A)(i : A),
- fold f s i = fold_left (fun a e => f e a) (elements s) i.
-Proof.
- intros.
- rewrite fold_equiv.
- unfold fold'.
- rewrite L.fold_1.
- unfold L.elements; auto.
- apply elements_sort; auto.
-Qed.
-
-(** * Subset *)
-
-Lemma subsetl_12 : forall subset_l1 l1 x1 h1 s2,
- bst (Node l1 x1 Leaf h1) -> bst s2 ->
- (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> 
- (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ).
-Proof.
- induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
- unfold Subset; intuition; try discriminate.
- assert (H': In x1 Leaf) by auto; inversion H'.
- inversion_clear H0.
- specialize (IHl2 H H2 H1).
- specialize (IHr2 H H3 H1).
- inv bst. clear H8.
- destruct X.compare.
- 
- rewrite IHl2; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite H1 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (H':=mem_2 H6); apply In_1 with x1; auto.
- apply mem_1; auto.
- assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-
-Lemma subsetr_12 : forall subset_r1 r1 x1 h1 s2,
- bst (Node Leaf x1 r1 h1) -> bst s2 ->
- (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> 
- (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2).
-Proof.
- induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
- unfold Subset; intuition; try discriminate.
- assert (H': In x1 Leaf) by auto; inversion H'.
- inversion_clear H0.
- specialize (IHl2 H H2 H1).
- specialize (IHr2 H H3 H1).
- inv bst. clear H7.
- destruct X.compare.
-
- rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (H':=mem_2 H1); apply In_1 with x1; auto.
- apply mem_1; auto.
- assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite H1 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- 
- rewrite IHr2; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-
-Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> 
- (subset s1 s2 = true <-> Subset s1 s2).
-Proof.
- induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros.
- unfold Subset; intuition_in.
- destruct s2 as [|l2 x2 r2 h2]; simpl; intros.
- unfold Subset; intuition_in; try discriminate.
- assert (H': In x1 Leaf) by auto; inversion H'.
- inv bst.
- destruct X.compare.
-
- rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
- rewrite (@subsetl_12 (subset l1) l1 x1 h1) by auto.
- clear IHl1 IHr1.
- unfold Subset; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
- clear IHl1 IHr1.
- unfold Subset; intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- 
- rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
- rewrite (@subsetr_12 (subset r1) r1 x1 h1) by auto.
- clear IHl1 IHr1.
- unfold Subset; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-
-
-(** * Comparison *)
-
-(** ** Relations [eq] and [lt] over trees *)
-
-Definition eq := Equal.
-Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2).
-
-Lemma eq_refl : forall s : t, Equal s s. 
-Proof.
- unfold Equal; intuition.
-Qed.
-
-Lemma eq_sym : forall s s' : t, Equal s s' -> Equal s' s.
-Proof.
- unfold Equal; intros s s' H x; destruct (H x); split; auto.
-Qed.
-
-Lemma eq_trans : forall s s' s'' : t, 
- Equal s s' -> Equal s' s'' -> Equal s s''.
-Proof.
- unfold Equal; intros s s' s'' H1 H2 x; 
- destruct (H1 x); destruct (H2 x); split; auto.
-Qed.
-
-Lemma eq_L_eq :
- forall s s' : t, Equal s s' -> L.eq (elements s) (elements s').
-Proof.
- unfold Equal, L.eq, L.Equal; intros; do 2 rewrite elements_in; auto.
-Qed.
-
-Lemma L_eq_eq :
- forall s s' : t, L.eq (elements s) (elements s') -> Equal s s'.
-Proof.
- unfold Equal, L.eq, L.Equal; intros; do 2 rewrite <-elements_in; auto.
-Qed.
-Hint Resolve eq_L_eq L_eq_eq.
-
-Definition lt_trans (s s' s'' : t) (h : lt s s') 
-  (h' : lt s' s'') : lt s s'' := L.lt_trans h h'.
-
-Lemma lt_not_eq : forall s s' : t, 
- bst s -> bst s' -> lt s s' -> ~ Equal s s'.
-Proof.
- unfold lt in |- *; intros; intro.
- apply L.lt_not_eq with (s := elements s) (s' := elements s'); auto.
-Qed.
-
-Lemma L_eq_cons :
- forall (l1 l2 : list elt) (x y : elt),
- X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2).
-Proof.
- unfold L.eq, L.Equal in |- *; intuition.
- inversion_clear H1; generalize (H0 a); clear H0; intuition.
- apply InA_eqA with x; eauto.
- inversion_clear H1; generalize (H0 a); clear H0; intuition.
- apply InA_eqA with y; eauto.
-Qed.
-Hint Resolve L_eq_cons.
-
-
-(** * A new comparison algorithm suggested by Xavier Leroy *)
-
-(** [flatten_e e] returns the list of elements of [e] i.e. the list
-    of elements actually compared *)
- 
-Fixpoint flatten_e (e : enumeration) : list elt := match e with
-  | End => nil
-  | More x t r => x :: elements t ++ flatten_e r
- end.
-
-Lemma flatten_e_elements :
- forall l x r h e,
- elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e.
-Proof.
- intros; simpl; apply elements_node.
-Qed.
-
-Lemma cons_1 : forall s e, 
-  flatten_e (cons s e) = elements s ++ flatten_e e.
-Proof.
- induction s; simpl; auto; intros.
- rewrite IHs1; apply flatten_e_elements.
-Qed.
-
-(** Correctness of this comparison *)
-
-Definition Cmp c := 
- match c with 
-  | Eq => L.eq
-  | Lt => L.lt
-  | Gt => (fun l1 l2 => L.lt l2 l1)
- end.
-
-Lemma cons_Cmp : forall c x1 x2 l1 l2, X.eq x1 x2 ->
- Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). 
-Proof.
- destruct c; simpl; auto.
-Qed.
-Hint Resolve cons_Cmp.
-
-Lemma compare_end_Cmp : 
- forall e2, Cmp (compare_end e2) nil (flatten_e e2).
-Proof.
- destruct e2; simpl; auto.
- apply L.eq_refl.
-Qed.
-
-Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, 
-  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> 
-   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) 
-      (flatten_e (More x2 r2 e2)).
-Proof.
- simpl; intros; destruct X.compare; simpl; auto.
-Qed.
-
-Lemma compare_cont_Cmp : forall s1 cont e2 l,
- (forall e, Cmp (cont e) l (flatten_e e)) -> 
- Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
-Proof.
- induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto.
- rewrite <- elements_node; simpl.
- apply Hl1; auto. clear e2. intros [|x2 r2 e2].
- simpl; auto.
- apply compare_more_Cmp.
- rewrite <- cons_1; auto.
-Qed.
-
-Lemma compare_Cmp : forall s1 s2,
- Cmp (compare s1 s2) (elements s1) (elements s2).
-Proof.
- intros; unfold compare.
- rewrite (app_nil_end (elements s1)).
- replace (elements s2) with (flatten_e (cons s2 End)) by 
-  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
- apply compare_cont_Cmp; auto.
- intros.
- apply compare_end_Cmp; auto.
-Qed.
-
-(** * Equality test *)
-
-Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 ->  
- Equal s1 s2 -> equal s1 s2 = true.
-Proof.
-unfold equal; intros s1 s2 B1 B2 E.
-generalize (compare_Cmp s1 s2). 
-destruct (compare s1 s2); simpl in *; auto; intros.
-elim (lt_not_eq B1 B2 H E); auto.
-elim (lt_not_eq B2 B1 H (eq_sym E)); auto.
-Qed.
-
-Lemma equal_2 : forall s1 s2,  
- equal s1 s2 = true -> Equal s1 s2.
-Proof.
-unfold equal; intros s1 s2 E.
-generalize (compare_Cmp s1 s2); 
- destruct compare; auto; discriminate.
-Qed.
-
-End Proofs.
-
-End Raw.
-
-
-
-(** * Encapsulation
-
-   Now, in order to really provide a functor implementing [S], we 
-   need to encapsulate everything into a type of binary search trees. 
-   They also happen to be well-balanced, but this has no influence 
-   on the correctness of operations, so we won't state this here, 
-   see [FSetFullAVL] if you need more than just the FSet interface.
-*)
+Require FSetCompat MSetAVL Orders OrdersAlt.
 
 Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
-
- Module E := X.
- Module Raw := Raw I X.
- Import Raw.Proofs.
-
- Record bst := Bst {this :> Raw.t; is_bst : Raw.bst this}.
- Definition t := bst.
- Definition elt := E.t.
- 
- Definition In (x : elt) (s : t) := Raw.In x s.
- Definition Equal (s s':t) := forall a : elt, In a s <-> In a s'.
- Definition Subset (s s':t) := forall a : elt, In a s -> In a s'.
- Definition Empty (s:t) := forall a : elt, ~ In a s.
- Definition For_all (P : elt -> Prop) (s:t) := forall x, In x s -> P x.
- Definition Exists (P : elt -> Prop) (s:t) := exists x, In x s /\ P x.
-
- Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. 
- Proof. intro s; exact (@In_1 s). Qed.
- 
- Definition mem (x:elt)(s:t) : bool := Raw.mem x s.
-
- Definition empty : t := Bst empty_bst.
- Definition is_empty (s:t) : bool := Raw.is_empty s.
- Definition singleton (x:elt) : t := Bst (singleton_bst x).
- Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). 
- Definition remove (x:elt)(s:t) : t := Bst (remove_bst x (is_bst s)).
- Definition inter (s s':t) : t := Bst (inter_bst (is_bst s) (is_bst s')).
- Definition union (s s':t) : t := Bst (union_bst (is_bst s) (is_bst s')).
- Definition diff (s s':t) : t := Bst (diff_bst (is_bst s) (is_bst s')).
- Definition elements (s:t) : list elt := Raw.elements s.
- Definition min_elt (s:t) : option elt := Raw.min_elt s.
- Definition max_elt (s:t) : option elt := Raw.max_elt s.
- Definition choose (s:t) : option elt := Raw.choose s.
- Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s.
- Definition cardinal (s:t) : nat := Raw.cardinal s.
- Definition filter (f : elt -> bool) (s:t) : t := 
-   Bst (filter_bst f (is_bst s)).
- Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s.
- Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s.
- Definition partition (f : elt -> bool) (s:t) : t * t :=
-   let p := Raw.partition f s in
-   (@Bst (fst p) (partition_bst_1 f (is_bst s)), 
-    @Bst (snd p) (partition_bst_2 f (is_bst s))).
-
- Definition equal (s s':t) : bool := Raw.equal s s'.
- Definition subset (s s':t) : bool := Raw.subset s s'.
-
- Definition eq (s s':t) : Prop := Raw.Equal s s'.
- Definition lt (s s':t) : Prop := Raw.Proofs.lt s s'.
-
- Definition compare (s s':t) : Compare lt eq s s'.
- Proof.
-  intros (s,b) (s',b').
-  generalize (compare_Cmp s s').
-  destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
- Defined.
-
- Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }.
- Proof.
-  intros (s,b) (s',b'); unfold eq; simpl.
-  case_eq (Raw.equal s s'); intro H; [left|right].
-  apply equal_2; auto.
-  intro H'; rewrite equal_1 in H; auto; discriminate.
- Defined.
-
- (* specs *)
- Section Specs. 
- Variable s s' s'': t. 
- Variable x y : elt.
-
- Hint Resolve is_bst.
- 
- Lemma mem_1 : In x s -> mem x s = true. 
- Proof. exact (mem_1 (is_bst s)). Qed.
- Lemma mem_2 : mem x s = true -> In x s.
- Proof. exact (@mem_2 s x). Qed.
-
- Lemma equal_1 : Equal s s' -> equal s s' = true.
- Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed.
- Lemma equal_2 : equal s s' = true -> Equal s s'.
- Proof. exact (@equal_2 s s'). Qed.
-
- Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition.
-
- Lemma subset_1 : Subset s s' -> subset s s' = true.
- Proof. wrap subset subset_12. Qed.
- Lemma subset_2 : subset s s' = true -> Subset s s'.
- Proof. wrap subset subset_12. Qed.
-
- Lemma empty_1 : Empty empty.
- Proof. exact empty_1. Qed.
-
- Lemma is_empty_1 : Empty s -> is_empty s = true.
- Proof. exact (@is_empty_1 s). Qed.
- Lemma is_empty_2 : is_empty s = true -> Empty s. 
- Proof. exact (@is_empty_2 s). Qed.
- 
- Lemma add_1 : E.eq x y -> In y (add x s).
- Proof. wrap add add_in. Qed.
- Lemma add_2 : In y s -> In y (add x s).
- Proof. wrap add add_in. Qed.
- Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
- Proof. wrap add add_in. elim H; auto. Qed.
-
- Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
- Proof. wrap remove remove_in. Qed.
- Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
- Proof. wrap remove remove_in. Qed.
- Lemma remove_3 : In y (remove x s) -> In y s.
- Proof. wrap remove remove_in. Qed.
-
- Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
- Proof. exact (@singleton_1 x y). Qed.
- Lemma singleton_2 : E.eq x y -> In y (singleton x). 
- Proof. exact (@singleton_2 x y). Qed.
-
- Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
- Proof. wrap union union_in. Qed.
- Lemma union_2 : In x s -> In x (union s s'). 
- Proof. wrap union union_in. Qed.
- Lemma union_3 : In x s' -> In x (union s s').
- Proof. wrap union union_in. Qed.
-
- Lemma inter_1 : In x (inter s s') -> In x s.
- Proof. wrap inter inter_in. Qed.
- Lemma inter_2 : In x (inter s s') -> In x s'.
- Proof. wrap inter inter_in. Qed.
- Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
- Proof. wrap inter inter_in. Qed.
- 
- Lemma diff_1 : In x (diff s s') -> In x s. 
- Proof. wrap diff diff_in. Qed.
- Lemma diff_2 : In x (diff s s') -> ~ In x s'.
- Proof. wrap diff diff_in. Qed.
- Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
- Proof. wrap diff diff_in. Qed.
- 
- Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
-      fold f s i = fold_left (fun a e => f e a) (elements s) i.
- Proof. unfold fold, elements; intros; apply fold_1; auto. Qed.
-
- Lemma cardinal_1 : cardinal s = length (elements s).
- Proof. 
- unfold cardinal, elements; intros; apply elements_cardinal; auto.
- Qed.
-
- Section Filter.
- Variable f : elt -> bool.
-
- Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
- Proof. intro. wrap filter filter_in. Qed.
- Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
- Proof. intro. wrap filter filter_in. Qed. 
- Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
- Proof. intro. wrap filter filter_in. Qed.
-
- Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true.
- Proof. exact (@for_all_1 f s). Qed.
- Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s.
- Proof. exact (@for_all_2 f s). Qed.
-
- Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
- Proof. exact (@exists_1 f s). Qed.
- Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
- Proof. exact (@exists_2 f s). Qed.
-
- Lemma partition_1 : compat_bool E.eq f -> 
-  Equal (fst (partition f s)) (filter f s).
- Proof.
- unfold partition, filter, Equal, In; simpl ;intros H a.
- rewrite partition_in_1, filter_in; intuition.
- Qed.
-
- Lemma partition_2 : compat_bool E.eq f -> 
-  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
- Proof.
- unfold partition, filter, Equal, In; simpl ;intros H a.
- rewrite partition_in_2, filter_in; intuition.
- rewrite H2; auto.
- destruct (f a); auto.
- red; intros; f_equal.
- rewrite (H _ _ H0); auto.
- Qed.
-
- End Filter.
-
- Lemma elements_1 : In x s -> InA E.eq x (elements s).
- Proof. wrap elements elements_in. Qed.
- Lemma elements_2 : InA E.eq x (elements s) -> In x s.
- Proof. wrap elements elements_in. Qed.
- Lemma elements_3 : sort E.lt (elements s).
- Proof. exact (elements_sort (is_bst s)). Qed.
- Lemma elements_3w : NoDupA E.eq (elements s).
- Proof. exact (elements_nodup (is_bst s)). Qed.
-
- Lemma min_elt_1 : min_elt s = Some x -> In x s. 
- Proof. exact (@min_elt_1 s x). Qed.
- Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
- Proof. exact (@min_elt_2 s x y (is_bst s)). Qed.
- Lemma min_elt_3 : min_elt s = None -> Empty s.
- Proof. exact (@min_elt_3 s). Qed.
-
- Lemma max_elt_1 : max_elt s = Some x -> In x s. 
- Proof. exact (@max_elt_1 s x). Qed.
- Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
- Proof. exact (@max_elt_2 s x y (is_bst s)). Qed.
- Lemma max_elt_3 : max_elt s = None -> Empty s.
- Proof. exact (@max_elt_3 s). Qed.
-
- Lemma choose_1 : choose s = Some x -> In x s.
- Proof. exact (@choose_1 s x). Qed.
- Lemma choose_2 : choose s = None -> Empty s.
- Proof. exact (@choose_2 s). Qed.
- Lemma choose_3 : choose s = Some x -> choose s' = Some y -> 
-  Equal s s' -> E.eq x y.
- Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed.
-
- Lemma eq_refl : eq s s. 
- Proof. exact (eq_refl s). Qed.
- Lemma eq_sym : eq s s' -> eq s' s.
- Proof. exact (@eq_sym s s'). Qed.
- Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
- Proof. exact (@eq_trans s s' s''). Qed.
-  
- Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
- Proof. exact (@lt_trans s s' s''). Qed.
- Lemma lt_not_eq : lt s s' -> ~eq s s'.
- Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed.
-
- End Specs.
+ Module X' := OrdersAlt.Update_OT X.
+ Module MSet := MSetAVL.IntMake I X'.
+ Include FSetCompat.Backport_Sets X MSet.
 End IntMake.
 
 (* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
index c03fb92e..7f8c51d6 100644
--- a/theories/FSets/FSetBridge.v
+++ b/theories/FSets/FSetBridge.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetBridge.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite sets library *)
 
@@ -23,51 +23,51 @@ Set Firstorder Depth 2.
 Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
 
   Definition empty : {s : t | Empty s}.
-  Proof. 
+  Proof.
     exists empty; auto with set.
   Qed.
 
   Definition is_empty : forall s : t, {Empty s} + {~ Empty s}.
-  Proof. 
+  Proof.
     intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)).
     case (is_empty s); intuition.
   Qed.
 
 
   Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
-  Proof. 
+  Proof.
     intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)).
     case (mem x s); intuition.
   Qed.
- 
+
   Definition Add (x : elt) (s s' : t) :=
     forall y : elt, In y s' <-> E.eq x y \/ In y s.
- 
+
   Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
   Proof.
     intros; exists (add x s); auto.
     unfold Add in |- *; intuition.
     elim (E.eq_dec x y); auto.
-    intros; right. 
+    intros; right.
     eapply add_3; eauto.
-  Qed. 
- 
+  Qed.
+
   Definition singleton :
     forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
-  Proof. 
+  Proof.
     intros; exists (singleton x); intuition.
   Qed.
- 
+
   Definition remove :
     forall (x : elt) (s : t),
     {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
   Proof.
     intros; exists (remove x s); intuition.
     absurd (In x (remove x s)); auto with set.
-    apply In_1 with y; auto. 
+    apply In_1 with y; auto.
     elim (E.eq_dec x y); intros; auto.
     absurd (In x (remove x s)); auto with set.
-    apply In_1 with y; auto. 
+    apply In_1 with y; auto.
     eauto with set.
   Qed.
 
@@ -75,47 +75,47 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
   Proof.
     intros; exists (union s s'); intuition.
-  Qed.    
+  Qed.
 
   Definition inter :
     forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
-  Proof. 
+  Proof.
     intros; exists (inter s s'); intuition; eauto with set.
   Qed.
 
   Definition diff :
     forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
-  Proof. 
-    intros; exists (diff s s'); intuition; eauto with set. 
-    absurd (In x s'); eauto with set. 
-  Qed. 
- 
+  Proof.
+    intros; exists (diff s s'); intuition; eauto with set.
+    absurd (In x s'); eauto with set.
+  Qed.
+
   Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}.
-  Proof. 
-    intros. 
+  Proof.
+    intros.
     generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')).
     case (equal s s'); intuition.
   Qed.
 
   Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}.
-  Proof. 
-    intros. 
+  Proof.
+    intros.
     generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')).
     case (subset s s'); intuition.
-  Qed.   
+  Qed.
 
   Definition elements :
     forall s : t,
     {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
    Proof.
-     intros; exists (elements s); intuition.   
-   Defined. 
+     intros; exists (elements s); intuition.
+   Defined.
 
   Definition fold :
     forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
-    {r : A |   let (l,_) := elements s in 
+    {r : A |   let (l,_) := elements s in
                   r = fold_left (fun a e => f e a) l i}.
-  Proof. 
+  Proof.
   intros; exists (fold (A:=A) f s i); exact (fold_1 s i f).
   Qed.
 
@@ -124,16 +124,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
       {r : nat | let (l,_) := elements s in r = length l }.
   Proof.
     intros; exists (cardinal s); exact (cardinal_1 s).
-  Qed.    
+  Qed.
 
   Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
-    (x : elt) := if Pdec x then true else false. 
+    (x : elt) := if Pdec x then true else false.
 
   Lemma compat_P_aux :
    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}),
    compat_P E.eq P -> compat_bool E.eq (fdec Pdec).
   Proof.
-    unfold compat_P, compat_bool, fdec in |- *; intros.
+    unfold compat_P, compat_bool, Proper, respectful, fdec in |- *; intros.
     generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder.
   Qed.
 
@@ -143,7 +143,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
     {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
   Proof.
-    intros. 
+    intros.
     exists (filter (fdec Pdec) s).
     intro H; assert (compat_bool E.eq (fdec Pdec)); auto.
     intuition.
@@ -160,29 +160,29 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
   Definition for_all :
     forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
     {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
-  Proof. 
-    intros. 
+  Proof.
+    intros.
     generalize (for_all_1 (s:=s) (f:=fdec Pdec))
      (for_all_2 (s:=s) (f:=fdec Pdec)).
     case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ];
      intros.
     assert (compat_bool E.eq (fdec Pdec)); auto.
     generalize (H0 H3 (refl_equal _) _ H2).
-    unfold fdec in |- *. 
+    unfold fdec in |- *.
     case (Pdec x); intuition.
     inversion H4.
-    intuition.    
+    intuition.
     absurd (false = true); [ auto with bool | apply H; auto ].
     intro.
-    unfold fdec in |- *. 
+    unfold fdec in |- *.
     case (Pdec x); intuition.
   Qed.
 
   Definition exists_ :
     forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
     {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
-  Proof. 
-    intros. 
+  Proof.
+    intros.
     generalize (exists_1 (s:=s) (f:=fdec Pdec))
      (exists_2 (s:=s) (f:=fdec Pdec)).
     case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ];
@@ -190,14 +190,14 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     elim H0; auto; intros.
     exists x; intuition.
     generalize H4.
-    unfold fdec in |- *. 
+    unfold fdec in |- *.
     case (Pdec x); intuition.
     inversion H2.
-    intuition. 
-    elim H2; intros.    
+    intuition.
+    elim H2; intros.
     absurd (false = true); [ auto with bool | apply H; auto ].
     exists x; intuition.
-    unfold fdec in |- *. 
+    unfold fdec in |- *.
     case (Pdec x); intuition.
   Qed.
 
@@ -217,7 +217,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     intros s1 s2; simpl in |- *.
     intros; assert (compat_bool E.eq (fdec Pdec)); auto.
     intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))).
-    generalize H2; unfold compat_bool in |- *; intuition;
+    generalize H2; unfold compat_bool, Proper, respectful in |- *; intuition;
      apply (f_equal negb); auto.
     intuition.
     generalize H4; unfold For_all, Equal in |- *; intuition.
@@ -228,12 +228,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     inversion H9.
     generalize H; unfold For_all, Equal in |- *; intuition.
     elim (H0 x); intros.
-    cut ((fun x => negb (fdec Pdec x)) x = true). 
+    cut ((fun x => negb (fdec Pdec x)) x = true).
     unfold fdec in |- *; case (Pdec x); intuition.
       change ((fun x => negb (fdec Pdec x)) x = true) in |- *.
       apply (filter_2 (s:=s) (x:=x)); auto.
     set (b := fdec Pdec x) in *; generalize (refl_equal b);
-     pattern b at -1 in |- *; case b; unfold b in |- *; 
+     pattern b at -1 in |- *; case b; unfold b in |- *;
      [ left | right ].
     elim (H4 x); intros _ B; apply B; auto with set.
     elim (H x); intros _ B; apply B; auto with set.
@@ -242,16 +242,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B;
      auto.
     eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto.
-  Qed. 
+  Qed.
 
-  Definition choose_aux: forall s : t, 
+  Definition choose_aux: forall s : t,
     { x : elt | M.choose s = Some x } + { M.choose s = None }.
   Proof.
    intros.
    destruct (M.choose s); [left | right]; auto.
    exists e; auto.
   Qed.
- 
+
   Definition choose : forall s : t, {x : elt | In x s} + {Empty s}.
   Proof.
    intros; destruct (choose_aux s) as [(x,Hx)|H].
@@ -259,12 +259,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
    right; apply choose_2; auto.
   Defined.
 
-  Lemma choose_ok1 : 
-   forall s x, M.choose s = Some x <-> exists H:In x s, 
+  Lemma choose_ok1 :
+   forall s x, M.choose s = Some x <-> exists H:In x s,
       choose s = inleft _ (exist (fun x => In x s) x H).
   Proof.
     intros s x.
-    unfold choose; split; intros. 
+    unfold choose; split; intros.
     destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
     replace x with y in * by congruence.
     exists (choose_1 Hy); auto.
@@ -272,10 +272,10 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     destruct (choose_aux s) as [(y,Hy)|H']; congruence.
   Qed.
 
-  Lemma choose_ok2 : 
-   forall s, M.choose s = None <-> exists H:Empty s, 
+  Lemma choose_ok2 :
+   forall s, M.choose s = None <-> exists H:Empty s,
       choose s = inright _ H.
-  Proof. 
+  Proof.
     intros s.
     unfold choose; split; intros.
     destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
@@ -284,8 +284,8 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     destruct (choose_aux s) as [(y,Hy)|H']; congruence.
   Qed.
 
-  Lemma choose_equal : forall s s', Equal s s' -> 
-     match choose s, choose s' with 
+  Lemma choose_equal : forall s s', Equal s s' ->
+     match choose s, choose s' with
        | inleft (exist x _), inleft (exist x' _) => E.eq x x'
        | inright _, inright _  => True
        | _, _                        => False
@@ -306,29 +306,27 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
   Definition min_elt :
     forall s : t,
     {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
-  Proof. 
+  Proof.
     intros;
      generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)).
-    case (min_elt s); [ left | right ]; auto.    
+    case (min_elt s); [ left | right ]; auto.
     exists e; unfold For_all in |- *; eauto.
-  Qed. 
+  Qed.
 
   Definition max_elt :
     forall s : t,
     {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
-  Proof. 
+  Proof.
     intros;
      generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)).
-    case (max_elt s); [ left | right ]; auto.    
+    case (max_elt s); [ left | right ]; auto.
     exists e; unfold For_all in |- *; eauto.
-  Qed. 
-
-  Module E := E. 
+  Qed.
 
   Definition elt := elt.
   Definition t := t.
 
-  Definition In := In. 
+  Definition In := In.
   Definition Equal s s' := forall a : elt, In a s <-> In a s'.
   Definition Subset s s' := forall a : elt, In a s -> In a s'.
   Definition Empty s := forall a : elt, ~ In a s.
@@ -336,7 +334,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     forall x : elt, In x s -> P x.
   Definition Exists (P : elt -> Prop) (s : t) :=
     exists x : elt, In x s /\ P x.
-  
+
   Definition eq_In := In_1.
 
   Definition eq := Equal.
@@ -344,10 +342,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
   Definition eq_refl := eq_refl.
   Definition eq_sym := eq_sym.
   Definition eq_trans := eq_trans.
-  Definition lt_trans := lt_trans. 
+  Definition lt_trans := lt_trans.
   Definition lt_not_eq := lt_not_eq.
   Definition compare := compare.
 
+  Module E := E.
+
 End DepOfNodep.
 
 
@@ -386,7 +386,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Proof.
     intros; unfold mem in |- *; case (M.mem x s); auto.
   Qed.
-   
+
   Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
   Proof.
     intros s x; unfold mem in |- *; case (M.mem x s); auto.
@@ -399,26 +399,26 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
     if equal s s' then true else false.
 
   Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true.
-  Proof. 
+  Proof.
     intros; unfold equal in |- *; case M.equal; intuition.
-  Qed.    
- 
+  Qed.
+
   Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
-  Proof. 
+  Proof.
     intros s s'; unfold equal in |- *; case (M.equal s s'); intuition;
      inversion H.
   Qed.
-  
+
   Definition subset (s s' : t) : bool :=
     if subset s s' then true else false.
 
   Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true.
-  Proof. 
+  Proof.
     intros; unfold subset in |- *; case M.subset; intuition.
-  Qed.    
- 
+  Qed.
+
   Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
-  Proof. 
+  Proof.
     intros s s'; unfold subset in |- *; case (M.subset s s'); intuition;
      inversion H.
   Qed.
@@ -441,34 +441,34 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
     intro s; unfold choose in |- *; case (M.choose s); auto.
     simple destruct s0; intros; discriminate H.
   Qed.
- 
-  Lemma choose_3 : forall s s' x x', 
+
+  Lemma choose_3 : forall s s' x x',
    choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'.
   Proof.
   unfold choose; intros.
   generalize (M.choose_equal H1); clear H1.
-  destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; 
+  destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?];
    simpl; auto; congruence.
   Qed.
 
-  Definition elements (s : t) : list elt := let (l, _) := elements s in l. 
- 
+  Definition elements (s : t) : list elt := let (l, _) := elements s in l.
+
   Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s).
-  Proof. 
+  Proof.
     intros; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
 
   Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s.
-  Proof. 
+  Proof.
     intros s x; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
 
-  Lemma elements_3 : forall s : t, sort E.lt (elements s).  
-  Proof. 
+  Lemma elements_3 : forall s : t, sort E.lt (elements s).
+  Proof.
     intros; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
   Hint Resolve elements_3.
- 
+
   Lemma elements_3w : forall s : t, NoDupA E.eq (elements s).
   Proof. auto. Qed.
 
@@ -478,27 +478,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
     | inright _ => None
     end.
 
-  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. 
+  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
   Proof.
     intros s x; unfold min_elt in |- *; case (M.min_elt s).
     simple destruct s0; intros; injection H; intros; subst; intuition.
     intros; discriminate H.
-  Qed. 
+  Qed.
 
   Lemma min_elt_2 :
-   forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. 
+   forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x.
   Proof.
     intros s x y; unfold min_elt in |- *; case (M.min_elt s).
     unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
      subst; firstorder.
     intros; discriminate H.
-  Qed. 
+  Qed.
 
   Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
   Proof.
     intros s; unfold min_elt in |- *; case (M.min_elt s); auto.
     simple destruct s0; intros; discriminate H.
-  Qed. 
+  Qed.
 
   Definition max_elt (s : t) : option elt :=
     match max_elt s with
@@ -506,27 +506,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
     | inright _ => None
     end.
 
-  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. 
+  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
   Proof.
     intros s x; unfold max_elt in |- *; case (M.max_elt s).
     simple destruct s0; intros; injection H; intros; subst; intuition.
     intros; discriminate H.
-  Qed. 
+  Qed.
 
   Lemma max_elt_2 :
-   forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. 
+   forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y.
   Proof.
     intros s x y; unfold max_elt in |- *; case (M.max_elt s).
     unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
      subst; firstorder.
     intros; discriminate H.
-  Qed. 
+  Qed.
 
   Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
   Proof.
     intros s; unfold max_elt in |- *; case (M.max_elt s); auto.
     simple destruct s0; intros; discriminate H.
-  Qed. 
+  Qed.
 
   Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'.
 
@@ -566,70 +566,70 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Proof.
     intros s x y; unfold remove in |- *; case (M.remove x s); firstorder.
   Qed.
-  
-  Definition singleton (x : elt) : t := let (s, _) := singleton x in s. 
- 
-  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. 
+
+  Definition singleton (x : elt) : t := let (s, _) := singleton x in s.
+
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y.
   Proof.
     intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
   Qed.
 
-  Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). 
+  Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x).
   Proof.
     intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
   Qed.
-  
+
   Definition union (s s' : t) : t := let (s'', _) := union s s' in s''.
- 
+
   Lemma union_1 :
    forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'.
-  Proof. 
+  Proof.
     intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
   Qed.
 
-  Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). 
-  Proof. 
+  Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s').
+  Proof.
     intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
   Qed.
 
   Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s').
-  Proof. 
+  Proof.
     intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
   Qed.
 
   Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''.
- 
+
   Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s.
-  Proof. 
+  Proof.
     intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
   Qed.
 
   Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'.
-  Proof. 
+  Proof.
     intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
   Qed.
 
   Lemma inter_3 :
    forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s').
-  Proof. 
+  Proof.
     intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
   Qed.
 
   Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''.
- 
+
   Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s.
-  Proof. 
+  Proof.
     intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
   Qed.
 
   Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'.
-  Proof. 
+  Proof.
     intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
   Qed.
 
   Lemma diff_3 :
    forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s').
-  Proof. 
+  Proof.
     intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
   Qed.
 
@@ -637,36 +637,37 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma cardinal_1 : forall s, cardinal s = length (elements s).
   Proof.
-    intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; 
+    intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *;
     destruct (M.elements s); auto.
   Qed.
 
-  Definition fold (B : Type) (f : elt -> B -> B) (i : t) 
+  Definition fold (B : Type) (f : elt -> B -> B) (i : t)
     (s : B) : B := let (fold, _) := fold f i s in fold.
 
   Lemma fold_1 :
    forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (fun a e => f e a) (elements s) i.
   Proof.
-    intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; 
+    intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *;
     destruct (M.elements s); auto.
-  Qed.  
+  Qed.
 
   Definition f_dec :
     forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}.
   Proof.
     intros; case (f x); auto with bool.
-  Defined. 
+  Defined.
 
   Lemma compat_P_aux :
    forall f : elt -> bool,
    compat_bool E.eq f -> compat_P E.eq (fun x => f x = true).
   Proof.
-     unfold compat_bool, compat_P in |- *; intros; rewrite <- H1; firstorder.
+     unfold compat_bool, compat_P, Proper, respectful, impl; intros;
+      rewrite <- H1; firstorder.
   Qed.
 
   Hint Resolve compat_P_aux.
-    
+
   Definition filter (f : elt -> bool) (s : t) : t :=
     let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'.
 
@@ -680,7 +681,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma filter_2 :
    forall (s : t) (x : elt) (f : elt -> bool),
-   compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+   compat_bool E.eq f -> In x (filter f s) -> f x = true.
   Proof.
     intros s x f; unfold filter in |- *; case M.filter; intuition.
     generalize (i (compat_P_aux H)); firstorder.
@@ -688,7 +689,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma filter_3 :
    forall (s : t) (x : elt) (f : elt -> bool),
-   compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).     
+   compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
   Proof.
     intros s x f; unfold filter in |- *; case M.filter; intuition.
     generalize (i (compat_P_aux H)); firstorder.
@@ -697,98 +698,97 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Definition for_all (f : elt -> bool) (s : t) : bool :=
     if for_all (P:=fun x => f x = true) (f_dec f) s
     then true
-    else false. 
+    else false.
 
   Lemma for_all_1 :
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f ->
    For_all (fun x => f x = true) s -> for_all f s = true.
-  Proof. 
+  Proof.
     intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n;
      auto.
   Qed.
- 
+
   Lemma for_all_2 :
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f ->
    for_all f s = true -> For_all (fun x => f x = true) s.
-  Proof. 
+  Proof.
     intros s f; unfold for_all in |- *; case M.for_all; intuition;
      inversion H0.
   Qed.
-  
+
   Definition exists_ (f : elt -> bool) (s : t) : bool :=
     if exists_ (P:=fun x => f x = true) (f_dec f) s
     then true
-    else false. 
+    else false.
 
   Lemma exists_1 :
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
-  Proof. 
+  Proof.
     intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n;
      auto.
   Qed.
- 
+
   Lemma exists_2 :
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
-  Proof. 
+  Proof.
     intros s f; unfold exists_ in |- *; case M.exists_; intuition;
      inversion H0.
   Qed.
-     
-  Definition partition (f : elt -> bool) (s : t) : 
+
+  Definition partition (f : elt -> bool) (s : t) :
     t * t :=
     let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p.
-  
+
   Lemma partition_1 :
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
   Proof.
-    intros s f; unfold partition in |- *; case M.partition. 
-    intro p; case p; clear p; intros s1 s2 H C. 
+    intros s f; unfold partition in |- *; case M.partition.
+    intro p; case p; clear p; intros s1 s2 H C.
     generalize (H (compat_P_aux C)); clear H; intro H.
     simpl in |- *; unfold Equal in |- *; intuition.
-    apply filter_3; firstorder. 
-    elim (H2 a); intros. 
-    assert (In a s). 
+    apply filter_3; firstorder.
+    elim (H2 a); intros.
+    assert (In a s).
      eapply filter_1; eauto.
     elim H3; intros; auto.
     absurd (f a = true).
     exact (H a H6).
-    eapply filter_2; eauto. 
-  Qed.    
-    
+    eapply filter_2; eauto.
+  Qed.
+
   Lemma partition_2 :
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
   Proof.
-    intros s f; unfold partition in |- *; case M.partition. 
-    intro p; case p; clear p; intros s1 s2 H C. 
+    intros s f; unfold partition in |- *; case M.partition.
+    intro p; case p; clear p; intros s1 s2 H C.
     generalize (H (compat_P_aux C)); clear H; intro H.
     assert (D : compat_bool E.eq (fun x => negb (f x))).
-    generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb);
+    generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb);
      auto.
     simpl in |- *; unfold Equal in |- *; intuition.
     apply filter_3; firstorder.
-    elim (H2 a); intros. 
-    assert (In a s). 
+    elim (H2 a); intros.
+    assert (In a s).
      eapply filter_1; eauto.
     elim H3; intros; auto.
     absurd (f a = true).
     intro.
-    generalize (filter_2 D H1). 
+    generalize (filter_2 D H1).
     rewrite H7; intros H8; inversion H8.
     exact (H0 a H6).
-  Qed. 
+  Qed.
 
 
-  Module E := E. 
   Definition elt := elt.
   Definition t := t.
 
-  Definition In := In. 
+  Definition In := In.
   Definition Equal s s' := forall a : elt, In a s <-> In a s'.
   Definition Subset s s' := forall a : elt, In a s -> In a s'.
   Definition Add (x : elt) (s s' : t) :=
@@ -806,8 +806,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Definition eq_refl := eq_refl.
   Definition eq_sym := eq_sym.
   Definition eq_trans := eq_trans.
-  Definition lt_trans := lt_trans. 
+  Definition lt_trans := lt_trans.
   Definition lt_not_eq := lt_not_eq.
   Definition compare := compare.
 
+  Module E := E.
+
 End NodepOfDep.
diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v
new file mode 100644
index 00000000..c3d614ee
--- /dev/null
+++ b/theories/FSets/FSetCompat.v
@@ -0,0 +1,410 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** * Compatibility functors between FSetInterface and MSetInterface. *)
+
+Require Import FSetInterface FSetFacts MSetInterface MSetFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * From new Weak Sets to old ones *)
+
+Module Backport_WSets
+ (E:DecidableType.DecidableType)
+ (M:MSetInterface.WSets with Definition E.t := E.t
+                        with Definition E.eq := E.eq)
+ <: FSetInterface.WSfun E.
+
+ Definition elt := E.t.
+ Definition t := M.t.
+
+ Implicit Type s : t.
+ Implicit Type x y : elt.
+ Implicit Type f : elt -> bool.
+
+ Definition In : elt -> t -> Prop := M.In.
+ Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+ Definition Subset s s' := forall a : elt, In a s -> In a s'.
+ Definition Empty s := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+ Definition empty : t := M.empty.
+ Definition is_empty : t -> bool := M.is_empty.
+ Definition mem : elt -> t -> bool := M.mem.
+ Definition add : elt -> t -> t := M.add.
+ Definition singleton : elt -> t := M.singleton.
+ Definition remove : elt -> t -> t := M.remove.
+ Definition union : t -> t -> t := M.union.
+ Definition inter : t -> t -> t := M.inter.
+ Definition diff : t -> t -> t := M.diff.
+ Definition eq : t -> t -> Prop := M.eq.
+ Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec.
+ Definition equal : t -> t -> bool := M.equal.
+ Definition subset : t -> t -> bool := M.subset.
+ Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold.
+ Definition for_all : (elt -> bool) -> t -> bool := M.for_all.
+ Definition exists_ : (elt -> bool) -> t -> bool := M.exists_.
+ Definition filter : (elt -> bool) -> t -> t := M.filter.
+ Definition partition : (elt -> bool) -> t -> t * t:= M.partition.
+ Definition cardinal : t -> nat := M.cardinal.
+ Definition elements : t -> list elt := M.elements.
+ Definition choose : t -> option elt := M.choose.
+
+ Module MF := MSetFacts.WFacts M.
+
+ Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s
+  := MF.In_1.
+ Definition eq_refl : forall s, eq s s
+  := @Equivalence_Reflexive _ _ M.eq_equiv.
+ Definition eq_sym : forall s s', eq s s' -> eq s' s
+  := @Equivalence_Symmetric _ _ M.eq_equiv.
+ Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s''
+  := @Equivalence_Transitive _ _ M.eq_equiv.
+ Definition mem_1 : forall s x, In x s -> mem x s = true
+  := MF.mem_1.
+ Definition mem_2 : forall s x, mem x s = true -> In x s
+  := MF.mem_2.
+ Definition equal_1 : forall s s', Equal s s' -> equal s s' = true
+  := MF.equal_1.
+ Definition equal_2 : forall s s', equal s s' = true -> Equal s s'
+  := MF.equal_2.
+ Definition subset_1 : forall s s', Subset s s' -> subset s s' = true
+  := MF.subset_1.
+ Definition subset_2 : forall s s', subset s s' = true -> Subset s s'
+  := MF.subset_2.
+ Definition empty_1 : Empty empty := MF.empty_1.
+ Definition is_empty_1 : forall s, Empty s -> is_empty s = true
+  := MF.is_empty_1.
+ Definition is_empty_2 : forall s, is_empty s = true -> Empty s
+  := MF.is_empty_2.
+ Definition add_1 : forall s x y, E.eq x y -> In y (add x s)
+  := MF.add_1.
+ Definition add_2 : forall s x y, In y s -> In y (add x s)
+  := MF.add_2.
+ Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s
+  := MF.add_3.
+ Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s)
+  := MF.remove_1.
+ Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s)
+  := MF.remove_2.
+ Definition remove_3 : forall s x y, In y (remove x s) -> In y s
+  := MF.remove_3.
+ Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s'
+  := MF.union_1.
+ Definition union_2 : forall s s' x, In x s -> In x (union s s')
+  := MF.union_2.
+ Definition union_3 : forall s s' x, In x s' -> In x (union s s')
+  := MF.union_3.
+ Definition inter_1 : forall s s' x, In x (inter s s') -> In x s
+  := MF.inter_1.
+ Definition inter_2 : forall s s' x, In x (inter s s') -> In x s'
+  := MF.inter_2.
+ Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s')
+  := MF.inter_3.
+ Definition diff_1 : forall s s' x, In x (diff s s') -> In x s
+  := MF.diff_1.
+ Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s'
+  := MF.diff_2.
+ Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s')
+  := MF.diff_3.
+ Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y
+  := MF.singleton_1.
+ Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x)
+  := MF.singleton_2.
+ Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (fun a e => f e a) (elements s) i
+  := MF.fold_1.
+ Definition cardinal_1 : forall s, cardinal s = length (elements s)
+  := MF.cardinal_1.
+ Definition filter_1 : forall s x f, compat_bool E.eq f ->
+  In x (filter f s) -> In x s
+  := MF.filter_1.
+ Definition filter_2 : forall s x f, compat_bool E.eq f ->
+  In x (filter f s) -> f x = true
+  := MF.filter_2.
+ Definition filter_3 : forall s x f, compat_bool E.eq f ->
+  In x s -> f x = true -> In x (filter f s)
+  := MF.filter_3.
+ Definition for_all_1 : forall s f, compat_bool E.eq f ->
+  For_all (fun x => f x = true) s -> for_all f s = true
+  := MF.for_all_1.
+ Definition for_all_2 : forall s f, compat_bool E.eq f ->
+  for_all f s = true -> For_all (fun x => f x = true) s
+  := MF.for_all_2.
+ Definition exists_1 : forall s f, compat_bool E.eq f ->
+  Exists (fun x => f x = true) s -> exists_ f s = true
+  := MF.exists_1.
+ Definition exists_2 : forall s f, compat_bool E.eq f ->
+  exists_ f s = true -> Exists (fun x => f x = true) s
+  := MF.exists_2.
+ Definition partition_1 : forall s f, compat_bool E.eq f ->
+  Equal (fst (partition f s)) (filter f s)
+  := MF.partition_1.
+ Definition partition_2 : forall s f, compat_bool E.eq f ->
+  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
+  := MF.partition_2.
+ Definition choose_1 : forall s x, choose s = Some x -> In x s
+  := MF.choose_1.
+ Definition choose_2 : forall s, choose s = None -> Empty s
+  := MF.choose_2.
+ Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s)
+  := MF.elements_1.
+ Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s
+  := MF.elements_2.
+ Definition elements_3w : forall s, NoDupA E.eq (elements s)
+  := MF.elements_3w.
+
+End Backport_WSets.
+
+
+(** * From new Sets to new ones *)
+
+Module Backport_Sets
+ (E:OrderedType.OrderedType)
+ (M:MSetInterface.Sets with Definition E.t := E.t
+                       with Definition E.eq := E.eq
+                       with Definition E.lt := E.lt)
+ <: FSetInterface.S with Module E:=E.
+
+  Include Backport_WSets E M.
+
+  Implicit Type s : t.
+  Implicit Type x y : elt.
+
+  Definition lt : t -> t -> Prop := M.lt.
+  Definition min_elt : t -> option elt := M.min_elt.
+  Definition max_elt : t -> option elt := M.max_elt.
+  Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s
+   := M.min_elt_spec1.
+  Definition min_elt_2 : forall s x y,
+   min_elt s = Some x -> In y s -> ~ E.lt y x
+   := M.min_elt_spec2.
+  Definition min_elt_3 : forall s, min_elt s = None -> Empty s
+   := M.min_elt_spec3.
+  Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s
+   := M.max_elt_spec1.
+  Definition max_elt_2 : forall s x y,
+   max_elt s = Some x -> In y s -> ~ E.lt x y
+   := M.max_elt_spec2.
+  Definition max_elt_3 : forall s, max_elt s = None -> Empty s
+   := M.max_elt_spec3.
+  Definition elements_3 : forall s, sort E.lt (elements s)
+   := M.elements_spec2.
+  Definition choose_3 : forall s s' x y,
+   choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y
+   := M.choose_spec3.
+  Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s''
+   := @StrictOrder_Transitive _ _ M.lt_strorder.
+  Lemma lt_not_eq : forall s s',  lt s s' -> ~ eq s s'.
+  Proof.
+   unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt.
+   apply (StrictOrder_Irreflexive s'); auto.
+  Qed.
+  Definition compare : forall s s', Compare lt eq s s'.
+  Proof.
+   intros s s'; destruct (CompSpec2Type (M.compare_spec s s'));
+    [ apply EQ | apply LT | apply GT ]; auto.
+  Defined.
+
+  Module E := E.
+
+End Backport_Sets.
+
+
+(** * From old Weak Sets to new ones. *)
+
+Module Update_WSets
+ (E:Equalities.DecidableType)
+ (M:FSetInterface.WS with Definition E.t := E.t
+                     with Definition E.eq := E.eq)
+ <: MSetInterface.WSetsOn E.
+
+ Definition elt := E.t.
+ Definition t := M.t.
+
+ Implicit Type s : t.
+ Implicit Type x y : elt.
+ Implicit Type f : elt -> bool.
+
+ Definition In : elt -> t -> Prop := M.In.
+ Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+ Definition Subset s s' := forall a : elt, In a s -> In a s'.
+ Definition Empty s := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+ Definition empty : t := M.empty.
+ Definition is_empty : t -> bool := M.is_empty.
+ Definition mem : elt -> t -> bool := M.mem.
+ Definition add : elt -> t -> t := M.add.
+ Definition singleton : elt -> t := M.singleton.
+ Definition remove : elt -> t -> t := M.remove.
+ Definition union : t -> t -> t := M.union.
+ Definition inter : t -> t -> t := M.inter.
+ Definition diff : t -> t -> t := M.diff.
+ Definition eq : t -> t -> Prop := M.eq.
+ Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec.
+ Definition equal : t -> t -> bool := M.equal.
+ Definition subset : t -> t -> bool := M.subset.
+ Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold.
+ Definition for_all : (elt -> bool) -> t -> bool := M.for_all.
+ Definition exists_ : (elt -> bool) -> t -> bool := M.exists_.
+ Definition filter : (elt -> bool) -> t -> t := M.filter.
+ Definition partition : (elt -> bool) -> t -> t * t:= M.partition.
+ Definition cardinal : t -> nat := M.cardinal.
+ Definition elements : t -> list elt := M.elements.
+ Definition choose : t -> option elt := M.choose.
+
+ Module MF := FSetFacts.WFacts M.
+
+ Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
+ Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed.
+
+ Instance eq_equiv : Equivalence eq.
+
+ Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+
+  Lemma mem_spec : mem x s = true <-> In x s.
+  Proof. intros; symmetry; apply MF.mem_iff. Qed.
+
+  Lemma equal_spec : equal s s' = true <-> Equal s s'.
+  Proof. intros; symmetry; apply MF.equal_iff. Qed.
+
+  Lemma subset_spec : subset s s' = true <-> Subset s s'.
+  Proof. intros; symmetry; apply MF.subset_iff. Qed.
+
+  Definition empty_spec : Empty empty := M.empty_1.
+
+  Lemma is_empty_spec : is_empty s = true <-> Empty s.
+  Proof. intros; symmetry; apply MF.is_empty_iff. Qed.
+
+  Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
+  Proof. intros. rewrite MF.add_iff. intuition. Qed.
+
+  Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Proof. intros. rewrite MF.remove_iff. intuition. Qed.
+
+  Lemma singleton_spec : In y (singleton x) <-> E.eq y x.
+  Proof. intros; rewrite MF.singleton_iff. intuition. Qed.
+
+  Definition union_spec : In x (union s s') <-> In x s \/ In x s'
+   := @MF.union_iff s s' x.
+  Definition inter_spec : In x (inter s s') <-> In x s /\ In x s'
+   := @MF.inter_iff s s' x.
+  Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s'
+   := @MF.diff_iff s s' x.
+  Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (flip f) (elements s) i
+   := @M.fold_1 s.
+  Definition cardinal_spec : cardinal s = length (elements s)
+   := @M.cardinal_1 s.
+
+  Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  Proof. intros; symmetry; apply MF.elements_iff. Qed.
+
+  Definition elements_spec2w : NoDupA E.eq (elements s)
+   := @M.elements_3w s.
+  Definition choose_spec1 : choose s = Some x -> In x s
+   := @M.choose_1 s x.
+  Definition choose_spec2 : choose s = None -> Empty s
+   := @M.choose_2 s.
+  Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f ->
+   (In x (filter f s) <-> In x s /\ f x = true)
+   := @MF.filter_iff s x.
+  Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f ->
+   Equal (fst (partition f s)) (filter f s)
+   := @M.partition_1 s.
+  Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
+   := @M.partition_2 s.
+
+  Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed.
+
+  Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof. intros; symmetry; apply MF.exists_iff; auto. Qed.
+
+  End Spec.
+
+End Update_WSets.
+
+
+(** * From old Sets to new ones. *)
+
+Module Update_Sets
+ (E:Orders.OrderedType)
+ (M:FSetInterface.S with Definition E.t := E.t
+                    with Definition E.eq := E.eq
+                    with Definition E.lt := E.lt)
+ <: MSetInterface.Sets with Module E:=E.
+
+  Include Update_WSets E M.
+
+  Implicit Type s : t.
+  Implicit Type x y : elt.
+
+  Definition lt : t -> t -> Prop := M.lt.
+  Definition min_elt : t -> option elt := M.min_elt.
+  Definition max_elt : t -> option elt := M.max_elt.
+  Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s
+   := M.min_elt_1.
+  Definition min_elt_spec2 : forall s x y,
+   min_elt s = Some x -> In y s -> ~ E.lt y x
+   := M.min_elt_2.
+  Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s
+   := M.min_elt_3.
+  Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s
+   := M.max_elt_1.
+  Definition max_elt_spec2 : forall s x y,
+   max_elt s = Some x -> In y s -> ~ E.lt x y
+   := M.max_elt_2.
+  Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s
+   := M.max_elt_3.
+  Definition elements_spec2 : forall s, sort E.lt (elements s)
+   := M.elements_3.
+  Definition choose_spec3 : forall s s' x y,
+   choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y
+   := M.choose_3.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+   split.
+   intros x Hx. apply (M.lt_not_eq Hx); auto with *.
+   exact M.lt_trans.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  apply proper_sym_impl_iff_2; auto with *.
+  intros s s' Hs u u' Hu H.
+  assert (H0 : lt s' u).
+   destruct (M.compare s' u) as [H'|H'|H']; auto.
+   elim (M.lt_not_eq H). transitivity s'; auto with *.
+   elim (M.lt_not_eq (M.lt_trans H H')); auto.
+  destruct (M.compare s' u') as [H'|H'|H']; auto.
+  elim (M.lt_not_eq H).
+   transitivity u'; auto with *. transitivity s'; auto with *.
+  elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *.
+  Qed.
+
+  Definition compare s s' :=
+   match M.compare s s' with
+    | EQ _ => Eq
+    | LT _ => Lt
+    | GT _ => Gt
+   end.
+
+  Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s').
+  Proof. intros; unfold compare; destruct M.compare; auto. Qed.
+
+  Module E := E.
+
+End Update_Sets.
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
index f84d8f58..b7d6382e 100644
--- a/theories/FSets/FSetDecide.v
+++ b/theories/FSets/FSetDecide.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetDecide.v 13199 2010-06-25 22:36:22Z letouzey $ *)
+(* $Id$ *)
 
 (**************************************************************)
 (* FSetDecide.v                                               *)
@@ -148,35 +148,35 @@ the above form:
 
         XXX: This tactic and the similar subsequent ones should
         have been defined using [autorewrite]. However, dealing
-        with multiples rewrite sites and side-conditions is 
-        done more cleverly with the following explicit 
+        with multiples rewrite sites and side-conditions is
+        done more cleverly with the following explicit
         analysis of goals. *)
 
-    Ltac or_not_l_iff P Q tac := 
-      (rewrite (or_not_l_iff_1 P Q) by tac) || 
+    Ltac or_not_l_iff P Q tac :=
+      (rewrite (or_not_l_iff_1 P Q) by tac) ||
       (rewrite (or_not_l_iff_2 P Q) by tac).
 
-    Ltac or_not_r_iff P Q tac := 
-      (rewrite (or_not_r_iff_1 P Q) by tac) || 
+    Ltac or_not_r_iff P Q tac :=
+      (rewrite (or_not_r_iff_1 P Q) by tac) ||
       (rewrite (or_not_r_iff_2 P Q) by tac).
 
-    Ltac or_not_l_iff_in P Q H tac := 
-      (rewrite (or_not_l_iff_1 P Q) in H by tac) || 
+    Ltac or_not_l_iff_in P Q H tac :=
+      (rewrite (or_not_l_iff_1 P Q) in H by tac) ||
       (rewrite (or_not_l_iff_2 P Q) in H by tac).
 
-    Ltac or_not_r_iff_in P Q H tac := 
-      (rewrite (or_not_r_iff_1 P Q) in H by tac) || 
+    Ltac or_not_r_iff_in P Q H tac :=
+      (rewrite (or_not_r_iff_1 P Q) in H by tac) ||
       (rewrite (or_not_r_iff_2 P Q) in H by tac).
 
     Tactic Notation "push" "not" "using" ident(db) :=
-      let dec := solve_decidable using db in 
+      let dec := solve_decidable using db in
       unfold not, iff;
       repeat (
         match goal with
         | |- context [True -> False] => rewrite not_true_iff
         | |- context [False -> False] => rewrite not_false_iff
         | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
-        | |- context [(?P -> False) -> (?Q -> False)] => 
+        | |- context [(?P -> False) -> (?Q -> False)] =>
             rewrite (contrapositive P Q) by dec
         | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
         | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
@@ -192,23 +192,23 @@ the above form:
 
     Tactic Notation
       "push" "not" "in" "*" "|-" "using" ident(db) :=
-      let dec := solve_decidable using db in 
+      let dec := solve_decidable using db in
       unfold not, iff in * |-;
       repeat (
         match goal with
         | H: context [True -> False] |- _ => rewrite not_true_iff in H
         | H: context [False -> False] |- _ => rewrite not_false_iff in H
-        | H: context [(?P -> False) -> False] |- _ => 
+        | H: context [(?P -> False) -> False] |- _ =>
           rewrite (not_not_iff P) in H by dec
         | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
           rewrite (contrapositive P Q) in H by dec
         | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
         | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
-        | H: context [(?P -> False) -> ?Q] |- _ => 
+        | H: context [(?P -> False) -> ?Q] |- _ =>
           rewrite (imp_not_l P Q) in H by dec
         | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H
         | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H
-        | H: context [(?P -> ?Q) -> False] |- _ => 
+        | H: context [(?P -> ?Q) -> False] |- _ =>
           rewrite (not_imp_iff P Q) in H by dec
         end);
       fold any not.
@@ -253,7 +253,7 @@ the above form:
         the hypotheses and goal together. *)
 
     Tactic Notation "pull" "not" "using" ident(db) :=
-      let dec := solve_decidable using db in 
+      let dec := solve_decidable using db in
       unfold not, iff;
       repeat (
         match goal with
@@ -269,7 +269,7 @@ the above form:
           rewrite <- (not_or_iff P Q)
         | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q)
         | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec
-        | |- context [(?Q -> False) /\ ?P] => 
+        | |- context [(?Q -> False) /\ ?P] =>
           rewrite <- (not_imp_rev_iff P Q) by dec
         end);
       fold any not.
@@ -279,7 +279,7 @@ the above form:
 
     Tactic Notation
       "pull" "not" "in" "*" "|-" "using" ident(db) :=
-      let dec := solve_decidable using db in 
+      let dec := solve_decidable using db in
       unfold not, iff in * |-;
       repeat (
         match goal with
@@ -294,8 +294,8 @@ the above form:
         | H: context [(?P -> False) -> ?Q] |- _ =>
           rewrite (imp_not_l P Q) in H by dec
         | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
-          rewrite <- (not_or_iff P Q) in H 
-        | H: context [?P -> ?Q -> False] |- _ => 
+          rewrite <- (not_or_iff P Q) in H
+        | H: context [?P -> ?Q -> False] |- _ =>
           rewrite <- (not_and_iff P Q) in H
         | H: context [?P /\ (?Q -> False)] |- _ =>
           rewrite <- (not_imp_iff P Q) in H by dec
@@ -673,13 +673,13 @@ the above form:
   Ltac fsetdec :=
     (** We first unfold any occurrences of [iff]. *)
     unfold iff in *;
-    (** We remove dependencies to logical hypothesis. This way,
-        later "clear" will work nicely (see bug #2136) *)
-    no_logical_interdep;
     (** We fold occurrences of [not] because it is better for
         [intros] to leave us with a goal of [~ P] than a goal of
         [False]. *)
     fold any not; intros;
+    (** We remove dependencies to logical hypothesis. This way,
+        later "clear" will work nicely (see bug #2136) *)
+    no_logical_interdep;
     (** Now we decompose conjunctions, which will allow the
         [discard_nonFSet] and [assert_decidability] tactics to
         do a much better job. *)
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
index 80ab2b2c..ec0c6a55 100644
--- a/theories/FSets/FSetEqProperties.v
+++ b/theories/FSets/FSetEqProperties.v
@@ -6,15 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetEqProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite sets library *)
 
-(** This module proves many properties of finite sets that 
-    are consequences of the axiomatization in [FsetInterface] 
-    Contrary to the functor in [FsetProperties] it uses 
+(** This module proves many properties of finite sets that
+    are consequences of the axiomatization in [FsetInterface]
+    Contrary to the functor in [FsetProperties] it uses
     sets operations instead of predicates over sets, i.e.
-    [mem x s=true] instead of [In x s], 
+    [mem x s=true] instead of [In x s],
     [equal s s'=true] instead of [Equal s s'], etc. *)
 
 Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx.
@@ -26,59 +26,59 @@ Import M.
 
 Definition Add := MP.Add.
 
-Section BasicProperties. 
+Section BasicProperties.
 
-(** Some old specifications written with boolean equalities. *) 
+(** Some old specifications written with boolean equalities. *)
 
 Variable s s' s'': t.
 Variable x y z : elt.
 
-Lemma mem_eq: 
+Lemma mem_eq:
   E.eq x y -> mem x s=mem y s.
-Proof. 
+Proof.
 intro H; rewrite H; auto.
 Qed.
 
-Lemma equal_mem_1: 
+Lemma equal_mem_1:
   (forall a, mem a s=mem a s') -> equal s s'=true.
-Proof. 
+Proof.
 intros; apply equal_1; unfold Equal; intros.
 do 2 rewrite mem_iff; rewrite H; tauto.
 Qed.
 
-Lemma equal_mem_2: 
+Lemma equal_mem_2:
   equal s s'=true -> forall a, mem a s=mem a s'.
-Proof. 
+Proof.
 intros; rewrite (equal_2 H); auto.
 Qed.
 
-Lemma subset_mem_1: 
+Lemma subset_mem_1:
   (forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
-Proof. 
+Proof.
 intros; apply subset_1; unfold Subset; intros a.
 do 2 rewrite mem_iff; auto.
 Qed.
 
-Lemma subset_mem_2: 
+Lemma subset_mem_2:
   subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
-Proof. 
+Proof.
 intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
 Qed.
-  
+
 Lemma empty_mem: mem x empty=false.
-Proof. 
+Proof.
 rewrite <- not_mem_iff; auto with set.
 Qed.
 
 Lemma is_empty_equal_empty: is_empty s = equal s empty.
-Proof. 
+Proof.
 apply bool_1; split; intros.
 auto with set.
 rewrite <- is_empty_iff; auto with set.
 Qed.
-  
+
 Lemma choose_mem_1: choose s=Some x -> mem x s=true.
-Proof.  
+Proof.
 auto with set.
 Qed.
 
@@ -90,44 +90,44 @@ Qed.
 Lemma add_mem_1: mem x (add x s)=true.
 Proof.
 auto with set.
-Qed.  
- 
+Qed.
+
 Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
-Proof. 
+Proof.
 apply add_neq_b.
 Qed.
 
 Lemma remove_mem_1: mem x (remove x s)=false.
-Proof. 
+Proof.
 rewrite <- not_mem_iff; auto with set.
-Qed. 
- 
+Qed.
+
 Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
-Proof. 
+Proof.
 apply remove_neq_b.
 Qed.
 
-Lemma singleton_equal_add: 
+Lemma singleton_equal_add:
   equal (singleton x) (add x empty)=true.
 Proof.
 rewrite (singleton_equal_add x); auto with set.
-Qed.  
+Qed.
 
-Lemma union_mem: 
+Lemma union_mem:
   mem x (union s s')=mem x s || mem x s'.
-Proof. 
+Proof.
 apply union_b.
 Qed.
 
-Lemma inter_mem: 
+Lemma inter_mem:
   mem x (inter s s')=mem x s && mem x s'.
-Proof. 
+Proof.
 apply inter_b.
 Qed.
 
-Lemma diff_mem: 
+Lemma diff_mem:
   mem x (diff s s')=mem x s && negb (mem x s').
-Proof. 
+Proof.
 apply diff_b.
 Qed.
 
@@ -143,7 +143,7 @@ Proof.
 intros; rewrite not_mem_iff; auto.
 Qed.
 
-(** Properties of [equal] *) 
+(** Properties of [equal] *)
 
 Lemma equal_refl: equal s s=true.
 Proof.
@@ -155,19 +155,19 @@ Proof.
 intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
 Qed.
 
-Lemma equal_trans: 
+Lemma equal_trans:
  equal s s'=true -> equal s' s''=true -> equal s s''=true.
 Proof.
 intros; rewrite (equal_2 H); auto.
 Qed.
 
-Lemma equal_equal: 
+Lemma equal_equal:
  equal s s'=true -> equal s s''=equal s' s''.
 Proof.
 intros; rewrite (equal_2 H); auto.
 Qed.
 
-Lemma equal_cardinal: 
+Lemma equal_cardinal:
  equal s s'=true -> cardinal s=cardinal s'.
 Proof.
 auto with set.
@@ -175,25 +175,25 @@ Qed.
 
 (* Properties of [subset] *)
 
-Lemma subset_refl: subset s s=true. 
+Lemma subset_refl: subset s s=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma subset_antisym: 
+Lemma subset_antisym:
  subset s s'=true -> subset s' s=true -> equal s s'=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma subset_trans: 
+Lemma subset_trans:
  subset s s'=true -> subset s' s''=true -> subset s s''=true.
 Proof.
 do 3 rewrite <- subset_iff; intros.
 apply subset_trans with s'; auto.
 Qed.
 
-Lemma subset_equal: 
+Lemma subset_equal:
  equal s s'=true -> subset s s'=true.
 Proof.
 auto with set.
@@ -201,7 +201,7 @@ Qed.
 
 (** Properties of [choose] *)
 
-Lemma choose_mem_3: 
+Lemma choose_mem_3:
  is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
 Proof.
 intros.
@@ -221,13 +221,13 @@ Qed.
 
 (** Properties of [add] *)
 
-Lemma add_mem_3: 
+Lemma add_mem_3:
  mem y s=true -> mem y (add x s)=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma add_equal: 
+Lemma add_equal:
  mem x s=true -> equal (add x s) s=true.
 Proof.
 auto with set.
@@ -235,26 +235,26 @@ Qed.
 
 (** Properties of [remove] *)
 
-Lemma remove_mem_3: 
+Lemma remove_mem_3:
  mem y (remove x s)=true -> mem y s=true.
 Proof.
 rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto.
 Qed.
 
-Lemma remove_equal: 
+Lemma remove_equal:
  mem x s=false -> equal (remove x s) s=true.
 Proof.
 intros; apply equal_1; apply remove_equal.
 rewrite not_mem_iff; auto.
 Qed.
 
-Lemma add_remove: 
+Lemma add_remove:
  mem x s=true -> equal (add x (remove x s)) s=true.
 Proof.
 intros; apply equal_1; apply add_remove; auto with set.
 Qed.
 
-Lemma remove_add: 
+Lemma remove_add:
  mem x s=false -> equal (remove x (add x s)) s=true.
 Proof.
 intros; apply equal_1; apply remove_add; auto.
@@ -297,37 +297,37 @@ Proof.
 auto with set.
 Qed.
 
-Lemma union_subset_equal: 
+Lemma union_subset_equal:
  subset s s'=true -> equal (union s s') s'=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma union_equal_1: 
+Lemma union_equal_1:
  equal s s'=true-> equal (union s s'') (union s' s'')=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma union_equal_2: 
+Lemma union_equal_2:
  equal s' s''=true-> equal (union s s') (union s s'')=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma union_assoc: 
+Lemma union_assoc:
  equal (union (union s s') s'') (union s (union s' s''))=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma add_union_singleton: 
+Lemma add_union_singleton:
  equal (add x s) (union (singleton x) s)=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma union_add: 
+Lemma union_add:
  equal (union (add x s) s') (add x (union s s'))=true.
 Proof.
 auto with set.
@@ -346,62 +346,62 @@ auto with set.
 Qed.
 
 Lemma union_subset_3:
- subset s s''=true -> subset s' s''=true -> 
+ subset s s''=true -> subset s' s''=true ->
   subset (union s s') s''=true.
 Proof.
 intros; apply subset_1; apply union_subset_3; auto with set.
 Qed.
 
-(** Properties of [inter] *) 
+(** Properties of [inter] *)
 
 Lemma inter_sym: equal (inter s s') (inter s' s)=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma inter_subset_equal: 
+Lemma inter_subset_equal:
  subset s s'=true -> equal (inter s s') s=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma inter_equal_1: 
+Lemma inter_equal_1:
  equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma inter_equal_2: 
+Lemma inter_equal_2:
  equal s' s''=true -> equal (inter s s') (inter s s'')=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma inter_assoc: 
+Lemma inter_assoc:
  equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma union_inter_1: 
+Lemma union_inter_1:
  equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma union_inter_2: 
+Lemma union_inter_2:
  equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma inter_add_1: mem x s'=true -> 
+Lemma inter_add_1: mem x s'=true ->
  equal (inter (add x s) s') (add x (inter s s'))=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma inter_add_2: mem x s'=false -> 
+Lemma inter_add_2: mem x s'=false ->
  equal (inter (add x s) s') (inter s s')=true.
 Proof.
 intros; apply equal_1; apply inter_add_2.
@@ -421,7 +421,7 @@ auto with set.
 Qed.
 
 Lemma inter_subset_3:
- subset s'' s=true -> subset s'' s'=true -> 
+ subset s'' s=true -> subset s'' s'=true ->
   subset s'' (inter s s')=true.
 Proof.
 intros; apply subset_1; apply inter_subset_3; auto with set.
@@ -440,19 +440,19 @@ Proof.
 auto with set.
 Qed.
 
-Lemma remove_inter_singleton: 
+Lemma remove_inter_singleton:
  equal (remove x s) (diff s (singleton x))=true.
 Proof.
 auto with set.
 Qed.
 
 Lemma diff_inter_empty:
- equal (inter (diff s s') (inter s s')) empty=true. 
+ equal (inter (diff s s') (inter s s')) empty=true.
 Proof.
 auto with set.
 Qed.
 
-Lemma diff_inter_all: 
+Lemma diff_inter_all:
  equal (union (diff s s') (inter s s')) s=true.
 Proof.
 auto with set.
@@ -462,7 +462,7 @@ End BasicProperties.
 
 Hint Immediate empty_mem is_empty_equal_empty add_mem_1
    remove_mem_1 singleton_equal_add union_mem inter_mem
-   diff_mem equal_sym add_remove remove_add : set. 
+   diff_mem equal_sym add_remove remove_add : set.
 Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
    choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal
    subset_refl subset_equal subset_antisym
@@ -472,8 +472,8 @@ Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
 (** General recursion principle *)
 
 Lemma set_rec:  forall (P:t->Type),
- (forall s s', equal s s'=true -> P s -> P s') -> 
- (forall s x, mem x s=false -> P s -> P (add x s)) -> 
+ (forall s s', equal s s'=true -> P s -> P s') ->
+ (forall s x, mem x s=false -> P s -> P (add x s)) ->
  P empty -> forall s, P s.
 Proof.
 intros.
@@ -493,51 +493,51 @@ intros; do 2 rewrite mem_iff.
 destruct (mem x s); destruct (mem x s'); intuition.
 Qed.
 
-Section Fold. 
+Section Fold.
 Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
 Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
 Variables (i:A).
 Variables (s s':t)(x:elt).
- 
+
 Lemma fold_empty: (fold f empty i) = i.
-Proof. 
+Proof.
 apply fold_empty; auto.
 Qed.
 
-Lemma fold_equal: 
+Lemma fold_equal:
  equal s s'=true -> eqA (fold f s i) (fold f s' i).
-Proof. 
+Proof.
 intros; apply fold_equal with (eqA:=eqA); auto with set.
 Qed.
-   
-Lemma fold_add: 
+
+Lemma fold_add:
  mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
-Proof. 
+Proof.
 intros; apply fold_add with (eqA:=eqA); auto.
 rewrite not_mem_iff; auto.
 Qed.
 
-Lemma add_fold: 
+Lemma add_fold:
   mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
 Proof.
 intros; apply add_fold with (eqA:=eqA); auto with set.
 Qed.
 
-Lemma remove_fold_1: 
+Lemma remove_fold_1:
  mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
 Proof.
 intros; apply remove_fold_1 with (eqA:=eqA); auto with set.
 Qed.
 
-Lemma remove_fold_2: 
+Lemma remove_fold_2:
  mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
 Proof.
 intros; apply remove_fold_2 with (eqA:=eqA); auto.
 rewrite not_mem_iff; auto.
 Qed.
 
-Lemma fold_union: 
- (forall x, mem x s && mem x s'=false) -> 
+Lemma fold_union:
+ (forall x, mem x s && mem x s'=false) ->
  eqA (fold f (union s s') i) (fold f s (fold f s' i)).
 Proof.
 intros; apply fold_union with (eqA:=eqA); auto.
@@ -548,40 +548,40 @@ End Fold.
 
 (** Properties of [cardinal] *)
 
-Lemma add_cardinal_1: 
+Lemma add_cardinal_1:
  forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
 Proof.
 auto with set.
 Qed.
 
-Lemma add_cardinal_2: 
+Lemma add_cardinal_2:
  forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
 Proof.
 intros; apply add_cardinal_2; auto.
 rewrite not_mem_iff; auto.
 Qed.
 
-Lemma remove_cardinal_1: 
+Lemma remove_cardinal_1:
  forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
 Proof.
 intros; apply remove_cardinal_1; auto with set.
 Qed.
 
-Lemma remove_cardinal_2: 
+Lemma remove_cardinal_2:
  forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
 Proof.
 intros; apply Equal_cardinal; apply equal_2; auto with set.
 Qed.
 
-Lemma union_cardinal: 
- forall s s', (forall x, mem x s && mem x s'=false) -> 
+Lemma union_cardinal:
+ forall s s', (forall x, mem x s && mem x s'=false) ->
  cardinal (union s s')=cardinal s+cardinal s'.
 Proof.
 intros; apply union_cardinal; auto; intros.
 rewrite exclusive_set; auto.
 Qed.
 
-Lemma subset_cardinal: 
+Lemma subset_cardinal:
  forall s s', subset s s'=true -> cardinal s<=cardinal s'.
 Proof.
 intros; apply subset_cardinal; auto with set.
@@ -592,24 +592,24 @@ Section Bool.
 (** Properties of [filter] *)
 
 Variable f:elt->bool.
-Variable Comp: compat_bool E.eq f.
+Variable Comp: Proper (E.eq==>Logic.eq) f.
 
-Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
+Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)).
 Proof.
-unfold compat_bool in *; intros; f_equal; auto.
+repeat red; intros; f_equal; auto.
 Qed.
 
 Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x.
-Proof. 
+Proof.
 intros; apply filter_b; auto.
 Qed.
 
-Lemma for_all_filter: 
+Lemma for_all_filter:
  forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
-Proof. 
+Proof.
 intros; apply bool_1; split; intros.
 apply is_empty_1.
-unfold Empty; intros. 
+unfold Empty; intros.
 rewrite filter_iff; auto.
 red; destruct 1.
 rewrite <- (@for_all_iff s f) in H; auto.
@@ -621,10 +621,10 @@ rewrite filter_iff; auto.
 destruct (f x); auto.
 Qed.
 
-Lemma exists_filter : 
+Lemma exists_filter :
  forall s, exists_ f s=negb (is_empty (filter f s)).
-Proof. 
-intros; apply bool_1; split; intros. 
+Proof.
+intros; apply bool_1; split; intros.
 destruct (exists_2 Comp H) as (a,(Ha1,Ha2)).
 apply bool_6.
 red; intros; apply (@is_empty_2 _ H0 a); auto with set.
@@ -636,28 +636,28 @@ intros _ H0.
 rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
 Qed.
 
-Lemma partition_filter_1: 
+Lemma partition_filter_1:
  forall s, equal (fst (partition f s)) (filter f s)=true.
-Proof. 
+Proof.
 auto with set.
 Qed.
 
-Lemma partition_filter_2: 
+Lemma partition_filter_2:
  forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
-Proof. 
+Proof.
 auto with set.
 Qed.
 
-Lemma filter_add_1 : forall s x, f x = true -> 
- filter f (add x s) [=] add x (filter f s). 
+Lemma filter_add_1 : forall s x, f x = true ->
+ filter f (add x s) [=] add x (filter f s).
 Proof.
 red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
 intuition.
 rewrite <- H; apply Comp; auto.
 Qed.
 
-Lemma filter_add_2 : forall s x, f x = false -> 
- filter f (add x s) [=] filter f s. 
+Lemma filter_add_2 : forall s x, f x = false ->
+ filter f (add x s) [=] filter f s.
 Proof.
 red; intros; do 2 (rewrite filter_iff; auto); set_iff.
 intuition.
@@ -665,18 +665,18 @@ assert (f x = f a) by (apply Comp; auto).
 rewrite H in H1; rewrite H2 in H1; discriminate.
 Qed.
 
-Lemma add_filter_1 : forall s s' x, 
+Lemma add_filter_1 : forall s s' x,
  f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
 Proof.
 unfold Add, MP.Add; intros.
 repeat rewrite filter_iff; auto.
 rewrite H0; clear H0.
-assert (E.eq x y -> f y = true) by 
+assert (E.eq x y -> f y = true) by
  (intro H0; rewrite <- (Comp _ _ H0); auto).
 tauto.
 Qed.
 
-Lemma add_filter_2 : forall s s' x, 
+Lemma add_filter_2 : forall s s' x,
  f x=false -> (Add x s s') -> filter f s [=] filter f s'.
 Proof.
 unfold Add, MP.Add, Equal; intros.
@@ -686,7 +686,7 @@ assert (f a = true -> ~E.eq x a).
  intros H0 H1.
  rewrite (Comp _ _ H1) in H.
  rewrite H in H0; discriminate.
-tauto. 
+tauto.
 Qed.
 
 Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) ->
@@ -695,7 +695,7 @@ Proof.
 clear Comp' Comp f.
 intros.
 assert (compat_bool E.eq (fun x => orb (f x) (g x))).
-  unfold compat_bool; intros.
+  unfold compat_bool, Proper, respectful; intros.
   rewrite (H x y H1);  rewrite (H0 x y H1); auto.
 unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
 assert (f a || g a = true <-> f a = true \/ g a = true).
@@ -711,7 +711,7 @@ Qed.
 
 (** Properties of [for_all] *)
 
-Lemma for_all_mem_1: forall s, 
+Lemma for_all_mem_1: forall s,
  (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
 Proof.
 intros.
@@ -724,8 +724,8 @@ generalize (H a); case (mem a s);intros;auto.
 rewrite H0;auto.
 Qed.
 
-Lemma for_all_mem_2: forall s, 
- (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. 
+Lemma for_all_mem_2: forall s,
+ (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true.
 Proof.
 intros.
 rewrite for_all_filter in H; auto.
@@ -734,10 +734,10 @@ generalize (equal_mem_2 _ _ H x).
 rewrite filter_b; auto.
 rewrite empty_mem.
 rewrite H0; simpl;intros.
-replace true with (negb false);auto;apply negb_sym;auto.
+rewrite <- negb_false_iff; auto.
 Qed.
 
-Lemma for_all_mem_3: 
+Lemma for_all_mem_3:
  forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
 Proof.
 intros.
@@ -752,7 +752,7 @@ rewrite H0.
 simpl;auto.
 Qed.
 
-Lemma for_all_mem_4: 
+Lemma for_all_mem_4:
  forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
 Proof.
 intros.
@@ -762,12 +762,12 @@ exists x.
 rewrite filter_b in H1; auto.
 elim (andb_prop _ _ H1).
 split;auto.
-replace false with (negb true);auto;apply negb_sym;auto.
+rewrite <- negb_true_iff; auto.
 Qed.
 
 (** Properties of [exists] *)
 
-Lemma for_all_exists: 
+Lemma for_all_exists:
  forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
 Proof.
 intros.
@@ -785,49 +785,49 @@ Variable Comp: compat_bool E.eq f.
 
 Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
 Proof.
-unfold compat_bool in *; intros; f_equal; auto.
+unfold compat_bool, Proper, respectful in *; intros; f_equal; auto.
 Qed.
 
-Lemma exists_mem_1: 
+Lemma exists_mem_1:
  forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
 Proof.
 intros.
 rewrite for_all_exists; auto.
 rewrite for_all_mem_1;auto with bool.
-intros;generalize (H x H0);intros. 
-symmetry;apply negb_sym;simpl;auto.
+intros;generalize (H x H0);intros.
+rewrite negb_true_iff; auto.
 Qed.
 
-Lemma exists_mem_2: 
- forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. 
+Lemma exists_mem_2:
+ forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false.
 Proof.
 intros.
 rewrite for_all_exists in H; auto.
-replace false with (negb true);auto;apply negb_sym;symmetry.
-rewrite (for_all_mem_2 (fun x => negb (f x)) Comp' s);simpl;auto.
-replace true with (negb false);auto;apply negb_sym;auto.
+rewrite negb_false_iff in H.
+rewrite <- negb_true_iff.
+apply for_all_mem_2 with (2:=H); auto.
 Qed.
 
-Lemma exists_mem_3: 
+Lemma exists_mem_3:
  forall s x, mem x s=true -> f x=true -> exists_ f s=true.
 Proof.
 intros.
 rewrite for_all_exists; auto.
-symmetry;apply negb_sym;simpl.
+rewrite negb_true_iff.
 apply for_all_mem_3 with x;auto.
-rewrite H0;auto.
+rewrite negb_false_iff; auto.
 Qed.
 
-Lemma exists_mem_4: 
+Lemma exists_mem_4:
  forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
 Proof.
 intros.
 rewrite for_all_exists in H; auto.
-elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros.
+rewrite negb_true_iff in H.
+elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto.
 elim p;intros.
 exists x;split;auto.
-replace true with (negb false);auto;apply negb_sym;auto.
-replace false with (negb true);auto;apply negb_sym;auto.
+rewrite <-negb_false_iff; auto.
 Qed.
 
 End Bool'.
@@ -836,21 +836,21 @@ Section Sum.
 
 (** Adding a valuation function on all elements of a set. *)
 
-Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. 
-Notation compat_opL := (compat_op E.eq (@Logic.eq _)).
-Notation transposeL := (transpose (@Logic.eq _)).
+Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0.
+Notation compat_opL := (compat_op E.eq Logic.eq).
+Notation transposeL := (transpose Logic.eq).
 
-Lemma sum_plus : 
-  forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
+Lemma sum_plus :
+  forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
     forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
 Proof.
 unfold sum.
 intros f g Hf Hg.
-assert (fc : compat_opL (fun x:elt =>plus (f x))).  auto.
+assert (fc : compat_opL (fun x:elt =>plus (f x))).  red; auto.
 assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega.
-assert (gc : compat_opL (fun x:elt => plus (g x))). auto.
+assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto.
 assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega.
-assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto.
+assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto.
 assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega.
 assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
 intros s;pattern s; apply set_rec.
@@ -863,14 +863,14 @@ rewrite H0;simpl;omega.
 do 3 rewrite fold_empty;auto.
 Qed.
 
-Lemma sum_filter : forall f, (compat_bool E.eq f) -> 
+Lemma sum_filter : forall f, (compat_bool E.eq f) ->
   forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
 Proof.
 unfold sum; intros f Hf.
 assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
-assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). 
- red; intros.
- rewrite (Hf x x' H); auto.
+assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))).
+ repeat red; intros.
+ rewrite (Hf _ _ H); auto.
 assert (ct : transposeL (fun x => plus (if f x then 1 else 0))).
  red; intros; omega.
 intros s;pattern s; apply set_rec.
@@ -891,12 +891,12 @@ unfold Empty; intros.
 rewrite filter_iff; auto; set_iff; tauto.
 Qed.
 
-Lemma fold_compat : 
+Lemma fold_compat :
   forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
   (f g:elt->A->A),
-  (compat_op E.eq eqA f) -> (transpose eqA f) -> 
-  (compat_op E.eq eqA g) -> (transpose eqA g) -> 
-  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> 
+  (compat_op E.eq eqA f) -> (transpose eqA f) ->
+  (compat_op E.eq eqA g) -> (transpose eqA g) ->
+  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) ->
   (eqA (fold f s i) (fold g s i)).
 Proof.
 intros A eqA st f g fc ft gc gt i.
@@ -912,17 +912,18 @@ transitivity (f x (fold f s0 i)).
 apply fold_add with (eqA:=eqA); auto with set.
 transitivity (g x (fold f s0 i)); auto with set.
 transitivity (g x (fold g s0 i)); auto with set.
+apply gc; auto with *.
 symmetry; apply fold_add with (eqA:=eqA); auto.
 do 2 rewrite fold_empty; reflexivity.
 Qed.
 
-Lemma sum_compat : 
-  forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
+Lemma sum_compat :
+  forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
   forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
 intros.
-unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto.
-red; intros; omega.
-red; intros; omega.
+unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *.
+intros x x' Hx y y' Hy. rewrite Hx, Hy; auto.
+intros x x' Hx y y' Hy. rewrite Hx, Hy; auto.
 Qed.
 
 End Sum.
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
index 674caaac..b750edfc 100644
--- a/theories/FSets/FSetFacts.v
+++ b/theories/FSets/FSetFacts.v
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetFacts.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 (** * Finite sets library *)
 
 (** This functor derives additional facts from [FSetInterface.S]. These
-  facts are mainly the specifications of [FSetInterface.S] written using 
-  different styles: equivalence and boolean equalities. 
+  facts are mainly the specifications of [FSetInterface.S] written using
+  different styles: equivalence and boolean equalities.
   Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
 *)
 
@@ -30,7 +30,7 @@ Definition eqb x y := if eq_dec x y then true else false.
 
 (** * Specifications written using equivalences *)
 
-Section IffSpec. 
+Section IffSpec.
 Variable s s' s'' : t.
 Variable x y z : elt.
 
@@ -50,12 +50,12 @@ rewrite mem_iff; destruct (mem x s); intuition.
 Qed.
 
 Lemma equal_iff : s[=]s' <-> equal s s' = true.
-Proof. 
+Proof.
 split; [apply equal_1|apply equal_2].
 Qed.
 
 Lemma subset_iff : s[<=]s' <-> subset s s' = true.
-Proof. 
+Proof.
 split; [apply subset_1|apply subset_2].
 Qed.
 
@@ -64,8 +64,8 @@ Proof.
 intuition; apply (empty_1 H).
 Qed.
 
-Lemma is_empty_iff : Empty s <-> is_empty s = true. 
-Proof. 
+Lemma is_empty_iff : Empty s <-> is_empty s = true.
+Proof.
 split; [apply is_empty_1|apply is_empty_2].
 Qed.
 
@@ -75,7 +75,7 @@ split; [apply singleton_1|apply singleton_2].
 Qed.
 
 Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
-Proof. 
+Proof.
 split; [ | destruct 1; [apply add_1|apply add_2]]; auto.
 destruct (eq_dec x y) as [E|E]; auto.
 intro H; right; exact (add_3 E H).
@@ -116,8 +116,8 @@ Qed.
 Variable f : elt->bool.
 
 Lemma filter_iff :  compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true).
-Proof. 
-split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. 
+Proof.
+split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto.
 Qed.
 
 Lemma for_all_iff : compat_bool E.eq f ->
@@ -125,7 +125,7 @@ Lemma for_all_iff : compat_bool E.eq f ->
 Proof.
 split; [apply for_all_1 | apply for_all_2]; auto.
 Qed.
- 
+
 Lemma exists_iff : compat_bool E.eq f ->
   (Exists (fun x => f x = true) s <-> exists_ f s = true).
 Proof.
@@ -133,17 +133,17 @@ split; [apply exists_1 | apply exists_2]; auto.
 Qed.
 
 Lemma elements_iff : In x s <-> InA E.eq x (elements s).
-Proof. 
+Proof.
 split; [apply elements_1 | apply elements_2].
 Qed.
 
 End IffSpec.
 
 (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)
-  
-Ltac set_iff := 
+
+Ltac set_iff :=
  repeat (progress (
-  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff 
+  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
   || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
   || rewrite empty_iff)).
 
@@ -154,7 +154,7 @@ Variable s s' s'' : t.
 Variable x y z : elt.
 
 Lemma mem_b : E.eq x y -> mem x s = mem y s.
-Proof. 
+Proof.
 intros.
 generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
 destruct (mem x s); destruct (mem y s); intuition.
@@ -191,7 +191,7 @@ destruct (mem y s); destruct (mem y (remove x s)); intuition.
 Qed.
 
 Lemma singleton_b : mem y (singleton x) = eqb x y.
-Proof. 
+Proof.
 generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
 destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
 Qed.
@@ -236,7 +236,7 @@ Qed.
 Variable f : elt->bool.
 
 Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x.
-Proof. 
+Proof.
 intros.
 generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
 destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
@@ -264,7 +264,7 @@ rewrite H2.
 rewrite InA_alt; eauto.
 Qed.
 
-Lemma exists_b : compat_bool E.eq f -> 
+Lemma exists_b : compat_bool E.eq f ->
   exists_ f s = existsb f (elements s).
 Proof.
 intros.
@@ -291,39 +291,27 @@ End BoolSpec.
 
 (** * [E.eq] and [Equal] are setoid equalities *)
 
-Definition E_ST : Equivalence E.eq.
+Instance E_ST : Equivalence E.eq.
 Proof.
 constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
 Qed.
 
-Definition Equal_ST : Equivalence Equal.
-Proof. 
+Instance Equal_ST : Equivalence Equal.
+Proof.
 constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans].
 Qed.
 
-Add Relation elt E.eq 
- reflexivity proved by E.eq_refl 
- symmetry proved by E.eq_sym
- transitivity proved by E.eq_trans 
- as EltSetoid.
-
-Add Relation t Equal 
- reflexivity proved by eq_refl 
- symmetry proved by eq_sym
- transitivity proved by eq_trans 
- as EqualSetoid.
-
-Add Morphism In with signature E.eq ==> Equal ==> iff as In_m.
+Instance In_m : Proper (E.eq ==> Equal ==> iff) In.
 Proof.
 unfold Equal; intros x y H s s' H0.
 rewrite (In_eq_iff s H); auto.
 Qed.
 
-Add Morphism is_empty : is_empty_m.
+Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty.
 Proof.
 unfold Equal; intros s s' H.
 generalize (is_empty_iff s)(is_empty_iff s').
-destruct (is_empty s); destruct (is_empty s'); 
+destruct (is_empty s); destruct (is_empty s');
  unfold Empty; auto; intros.
 symmetry.
 rewrite <- H1; intros a Ha.
@@ -336,12 +324,12 @@ destruct H1 as (_,H1).
 exact (H1 (refl_equal true) _ Ha).
 Qed.
 
-Add Morphism Empty with signature Equal ==> iff as Empty_m.
+Instance Empty_m : Proper (Equal ==> iff) Empty.
 Proof.
-intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
+repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
 Qed.
 
-Add Morphism mem : mem_m.
+Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem.
 Proof.
 unfold Equal; intros x y H s s' H0.
 generalize (H0 x); clear H0; rewrite (In_eq_iff s' H).
@@ -349,7 +337,7 @@ generalize (mem_iff s x)(mem_iff s' y).
 destruct (mem x s); destruct (mem y s'); intuition.
 Qed.
 
-Add Morphism singleton : singleton_m.
+Instance singleton_m : Proper (E.eq ==> Equal) singleton.
 Proof.
 unfold Equal; intros x y H a.
 do 2 rewrite singleton_iff; split; intros.
@@ -357,51 +345,51 @@ apply E.eq_trans with x; auto.
 apply E.eq_trans with y; auto.
 Qed.
 
-Add Morphism add : add_m.
+Instance add_m : Proper (E.eq==>Equal==>Equal) add.
 Proof.
 unfold Equal; intros x y H s s' H0 a.
 do 2 rewrite add_iff; rewrite H; rewrite H0; intuition.
 Qed.
 
-Add Morphism remove : remove_m.
+Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
 Proof.
 unfold Equal; intros x y H s s' H0 a.
 do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition.
 Qed.
 
-Add Morphism union : union_m.
+Instance union_m : Proper (Equal==>Equal==>Equal) union.
 Proof.
 unfold Equal; intros s s' H s'' s''' H0 a.
 do 2 rewrite union_iff; rewrite H; rewrite H0; intuition.
 Qed.
 
-Add Morphism inter : inter_m.
+Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
 Proof.
 unfold Equal; intros s s' H s'' s''' H0 a.
 do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition.
 Qed.
 
-Add Morphism diff : diff_m.
+Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
 Proof.
 unfold Equal; intros s s' H s'' s''' H0 a.
 do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition.
 Qed.
 
-Add Morphism Subset with signature Equal ==> Equal ==> iff as  Subset_m.
-Proof. 
+Instance Subset_m : Proper (Equal==>Equal==>iff) Subset.
+Proof.
 unfold Equal, Subset; firstorder.
 Qed.
 
-Add Morphism subset : subset_m.
+Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset.
 Proof.
 intros s s' H s'' s''' H0.
-generalize (subset_iff s s'') (subset_iff s' s'''). 
+generalize (subset_iff s s'') (subset_iff s' s''').
 destruct (subset s s''); destruct (subset s' s'''); auto; intros.
 rewrite H in H1; rewrite H0 in H1; intuition.
 rewrite H in H1; rewrite H0 in H1; intuition.
 Qed.
 
-Add Morphism equal : equal_m.
+Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal.
 Proof.
 intros s s' H s'' s''' H0.
 generalize (equal_iff s s'') (equal_iff s' s''').
@@ -424,7 +412,7 @@ Add Relation t Subset
  transitivity proved by Subset_trans
  as SubsetSetoid.
 
-Instance In_s_m : Morphisms.Morphism (E.eq ==> Subset ++> Basics.impl) In | 1.
+Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1.
 Proof.
   simpl_relation. eauto with set.
 Qed.
@@ -467,7 +455,7 @@ Qed.
 (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism
    without additional hypothesis on [f]. For instance: *)
 
-Lemma filter_equal : forall f, compat_bool E.eq f -> 
+Lemma filter_equal : forall f, compat_bool E.eq f ->
   forall s s', s[=]s' -> filter f s [=] filter f s'.
 Proof.
 unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
@@ -478,10 +466,10 @@ Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) ->
 Proof.
 intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto).
 rewrite Hff', Hss'; intuition.
-red; intros; rewrite <- 2 Hff'; auto.
+repeat red; intros; rewrite <- 2 Hff'; auto.
 Qed.
 
-Lemma filter_subset : forall f, compat_bool E.eq f -> 
+Lemma filter_subset : forall f, compat_bool E.eq f ->
   forall s s', s[<=]s' -> filter f s [<=] filter f s'.
 Proof.
 unfold Subset; intros; rewrite filter_iff in *; intuition.
diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v
deleted file mode 100644
index a2d8e681..00000000
--- a/theories/FSets/FSetFullAVL.v
+++ /dev/null
@@ -1,1133 +0,0 @@
-(***********************************************************************)
-(*  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       *)
-(***********************************************************************)
-
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
-
-(* $Id: FSetFullAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *)
-
-(** * FSetFullAVL
-   
-   This file contains some complements to [FSetAVL].
-
-   - Functor [AvlProofs] proves that trees of [FSetAVL] are not only 
-   binary search trees, but moreover well-balanced ones. This is done
-   by proving that all operations preserve the balancing.
-
-   - Functor [OcamlOps] contains variants of [union], [subset], 
-   [compare] and [equal] that are faithful to the original ocaml codes,
-   while the versions in FSetAVL have been adapted to perform only
-   structural recursive code. 
-  
-   - Finally, we pack the previous elements in a [Make] functor 
-   similar to the one of [FSetAVL], but richer.
-*)
-
-Require Import Recdef FSetInterface FSetList ZArith Int FSetAVL.
-
-Set Implicit Arguments.
-Unset Strict Implicit.
-
-Module AvlProofs (Import I:Int)(X:OrderedType).
-Module Import Raw := Raw I X.
-Import Raw.Proofs.
-Module Import II := MoreInt I.
-Open Local Scope pair_scope.
-Open Local Scope Int_scope.
-
-(** * AVL trees *)
-
-(** [avl s] : [s] is a properly balanced AVL tree,
-    i.e. for any node the heights of the two children
-    differ by at most 2 *)
-
-Inductive avl : tree -> Prop :=
-  | RBLeaf : avl Leaf
-  | RBNode : forall x l r h, avl l -> avl r ->
-      -(2) <= height l - height r <= 2 ->
-      h = max (height l) (height r) + 1 -> 
-      avl (Node l x r h).
-
-(** * Automation and dedicated tactics *)
-
-Hint Constructors avl.
-
-(** A tactic for cleaning hypothesis after use of functional induction. *)
-
-Ltac clearf :=
- match goal with 
-  | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf
-  | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf
-  | _ => idtac
- end.
-
-(** Tactics about [avl] *)
-
-Lemma height_non_negative : forall s : tree, avl s -> height s >= 0.
-Proof.
- induction s; simpl; intros; auto with zarith.
- inv avl; intuition; omega_max.
-Qed.
-Implicit Arguments height_non_negative. 
-
-(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *)
-
-Ltac avl_nn_hyp H := 
-     let nz := fresh "nz" in assert (nz := height_non_negative H).
-
-Ltac avl_nn h := 
-  let t := type of h in 
-  match type of t with 
-   | Prop => avl_nn_hyp h
-   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
-  end.
-
-(* Repeat the previous tactic. 
-   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
-
-Ltac avl_nns :=
-  match goal with 
-     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
-     | _ => idtac
-  end.
-
-(** Results about [height] *)
-
-Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf.
-Proof.
- destruct 1; intuition; simpl in *.
- avl_nns; simpl in *; elimtype False; omega_max.
-Qed.
-
-(** * Results about [avl] *)
-
-Lemma avl_node : 
- forall x l r, avl l -> avl r ->
- -(2) <= height l - height r <= 2 ->
- avl (Node l x r (max (height l) (height r) + 1)).
-Proof.
-  intros; auto.
-Qed.
-Hint Resolve avl_node.
-
-
-(** empty *)
-
-Lemma empty_avl : avl empty.
-Proof. 
- auto.
-Qed.
-
-(** singleton *)
-
-Lemma singleton_avl : forall x : elt, avl (singleton x).
-Proof.
- unfold singleton; intro.
- constructor; auto; try red; simpl; omega_max.
-Qed.
-
-(** create *)
-
-Lemma create_avl : 
- forall l x r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
- avl (create l x r).
-Proof.
- unfold create; auto.
-Qed.
-
-Lemma create_height : 
- forall l x r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
- height (create l x r) = max (height l) (height r) + 1.
-Proof.
- unfold create; auto.
-Qed.
-
-(** bal *)
-
-Lemma bal_avl : forall l x r, avl l -> avl r -> 
- -(3) <= height l - height r <= 3 -> avl (bal l x r).
-Proof.
- intros l x r; functional induction bal l x r; intros; clearf;
- inv avl; simpl in *; 
- match goal with |- avl (assert_false _ _ _) => avl_nns
-  | _ => repeat apply create_avl; simpl in *; auto
- end; omega_max.
-Qed.
-
-Lemma bal_height_1 : forall l x r, avl l -> avl r -> 
- -(3) <= height l - height r <= 3 ->
- 0 <= height (bal l x r) - max (height l) (height r) <= 1.
-Proof.
- intros l x r; functional induction bal l x r; intros; clearf;
- inv avl; avl_nns; simpl in *; omega_max.
-Qed.
-
-Lemma bal_height_2 : 
- forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> 
- height (bal l x r) == max (height l) (height r) +1.
-Proof.
- intros l x r; functional induction bal l x r; intros; clearf;
- inv avl; simpl in *; omega_max.
-Qed.
-
-Ltac omega_bal := match goal with 
-  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => 
-     generalize (bal_height_1 x H H') (bal_height_2 x H H'); 
-     omega_max
-  end.
-
-(** add *)
-
-Lemma add_avl_1 :  forall s x, avl s -> 
- avl (add x s) /\ 0 <= height (add x s) - height s <= 1.
-Proof. 
- intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *.
- intuition; try constructor; simpl; auto; try omega_max.
- (* LT *)
- destruct IHt; auto.
- split.
- apply bal_avl; auto; omega_max.
- omega_bal.
- (* EQ *)
- intuition; omega_max.
- (* GT *)
- destruct IHt; auto.
- split.
- apply bal_avl; auto; omega_max.
- omega_bal.
-Qed.
-
-Lemma add_avl : forall s x, avl s -> avl (add x s).
-Proof.
- intros; destruct (add_avl_1 x H); auto.
-Qed.
-Hint Resolve add_avl.
-
-(** join *)
-
-Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\
- 0<= height (join l x r) - max (height l) (height r) <= 1.
-Proof. 
- join_tac.
-
- split; simpl; auto. 
- destruct (add_avl_1 x H0).
- avl_nns; omega_max.
- set (l:=Node ll lx lr lh) in *.
- split; auto.
- destruct (add_avl_1 x H).
- simpl (height Leaf).
- avl_nns; omega_max.
-
- inversion_clear H.
- assert (height (Node rl rx rr rh) = rh); auto.
- set (r := Node rl rx rr rh) in *; clearbody r.
- destruct (Hlr x r H2 H0); clear Hrl Hlr.
- set (j := join lr x r) in *; clearbody j.
- simpl.
- assert (-(3) <= height ll - height j <= 3) by omega_max.
- split.
- apply bal_avl; auto.
- omega_bal.
-
- inversion_clear H0.
- assert (height (Node ll lx lr lh) = lh); auto.
- set (l := Node ll lx lr lh) in *; clearbody l.
- destruct (Hrl H H1); clear Hrl Hlr.
- set (j := join l x rl) in *; clearbody j.
- simpl.
- assert (-(3) <= height j - height rr <= 3) by omega_max.
- split.
- apply bal_avl; auto.
- omega_bal.
-
- clear Hrl Hlr.
- assert (height (Node ll lx lr lh) = lh); auto.
- assert (height (Node rl rx rr rh) = rh); auto.
- set (l := Node ll lx lr lh) in *; clearbody l.
- set (r := Node rl rx rr rh) in *; clearbody r.
- assert (-(2) <= height l - height r <= 2) by omega_max.
- split.
- apply create_avl; auto.
- rewrite create_height; auto; omega_max.
-Qed.
-
-Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r).
-Proof.
- intros; destruct (join_avl_1 x H H0); auto.
-Qed.
-Hint Resolve join_avl.
-
-(** remove_min *)
-
-Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> 
- avl (remove_min l x r)#1 /\ 
- 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 1.
-Proof.
- intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
- inv avl; simpl in *; split; auto.
- avl_nns; omega_max.
- inversion_clear H.
- rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto.
- split; simpl in *. 
- apply bal_avl; auto; omega_max.
- omega_bal.
-Qed.
-
-Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> 
-    avl (remove_min l x r)#1. 
-Proof.
- intros; destruct (remove_min_avl_1 H); auto.
-Qed.
-
-(** merge *)
-
-Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> 
- -(2) <= height s1 - height s2 <= 2 -> 
- avl (merge s1 s2) /\ 
- 0<= height (merge s1 s2) - max (height s1) (height s2) <=1.
-Proof.
- intros s1 s2; functional induction (merge s1 s2); intros; 
- try factornode _x _x0 _x1 _x2 as s1.
- simpl; split; auto; avl_nns; omega_max.
- simpl; split; auto; avl_nns; simpl in *; omega_max.
- generalize (remove_min_avl_1 H0).
- rewrite e1; destruct 1.
- split.
- apply bal_avl; auto.
- simpl; omega_max.
- simpl in *; omega_bal.
-Qed.
-
-Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> 
-  -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2).
-Proof. 
- intros; destruct (merge_avl_1 H H0 H1); auto.
-Qed.
-
-
-(** remove *)
-
-Lemma remove_avl_1 : forall s x, avl s -> 
- avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1.
-Proof.
- intros s x; functional induction (remove x s); intros.
- intuition; omega_max.
- (* LT *)
- inv avl.
- destruct (IHt H0).
- split. 
- apply bal_avl; auto.
- omega_max.
- omega_bal.
- (* EQ *)
- inv avl. 
- generalize (merge_avl_1 H0 H1 H2).
- intuition omega_max.
- (* GT *)
- inv avl.
- destruct (IHt H1).
- split. 
- apply bal_avl; auto.
- omega_max.
- omega_bal.
-Qed.
-
-Lemma remove_avl : forall s x, avl s -> avl (remove x s).
-Proof. 
- intros; destruct (remove_avl_1 x H); auto.
-Qed.
-Hint Resolve remove_avl.
-
-(** concat *)
-
-Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
-Proof.
- intros s1 s2; functional induction (concat s1 s2); auto.
- intros; apply join_avl; auto.
- generalize (remove_min_avl H0); rewrite e1; simpl; auto.
-Qed.
-Hint Resolve concat_avl.
-
-(** split *)
-
-Lemma split_avl : forall s x, avl s -> 
-  avl (split x s)#l /\ avl (split x s)#r.
-Proof. 
- intros s x; functional induction (split x s); simpl; auto.
- rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
- simpl; inversion_clear 1; auto.
- rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
-Qed.
-
-(** inter *)
-
-Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). 
-Proof.
- intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2;
- generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; 
- inv avl; auto.
-Qed.
-
-(** diff *)
-
-Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). 
-Proof. 
- intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2;
- generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; 
- inv avl; auto.
-Qed.
-
-(** union *)
-
-Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2).
-Proof.
- intros s1 s2; functional induction union s1 s2; auto; intros A1 A2;
- generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; 
- inv avl; auto.
-Qed.
-
-(** filter *)
-
-Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> 
- avl (filter_acc f acc s).
-Proof.
- induction s; simpl; auto.
- intros.
- inv avl.
- destruct (f t); auto.
-Qed. 
-Hint Resolve filter_acc_avl.
-
-Lemma filter_avl : forall f s, avl s -> avl (filter f s). 
-Proof.
- unfold filter; intros; apply filter_acc_avl; auto.
-Qed.
-
-(** partition *)
-
-Lemma partition_acc_avl_1 : forall f s acc, avl s -> 
- avl acc#1 -> avl (partition_acc f acc s)#1.
-Proof.
- induction s; simpl; auto.
- destruct acc as [acct accf]; simpl in *.
- intros.
- inv avl.
- apply IHs2; auto.
- apply IHs1; auto.
- destruct (f t); simpl; auto.
-Qed.
-
-Lemma partition_acc_avl_2 : forall f s acc, avl s -> 
- avl acc#2 -> avl (partition_acc f acc s)#2.
-Proof.
- induction s; simpl; auto.
- destruct acc as [acct accf]; simpl in *.
- intros.
- inv avl.
- apply IHs2; auto.
- apply IHs1; auto.
- destruct (f t); simpl; auto.
-Qed. 
-
-Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1. 
-Proof.
- unfold partition; intros; apply partition_acc_avl_1; auto.
-Qed.
-
-Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. 
-Proof.
- unfold partition; intros; apply partition_acc_avl_2; auto.
-Qed.
-
-End AvlProofs.
-
-
-Module OcamlOps (Import I:Int)(X:OrderedType).
-Module Import AvlProofs := AvlProofs I X.
-Import Raw.
-Import Raw.Proofs.
-Import II.
-Open Local Scope pair_scope.
-Open Local Scope nat_scope.
-
-(** Properties of cardinal *)
-
-Lemma bal_cardinal : forall l x r, 
- cardinal (bal l x r) = S (cardinal l + cardinal r).
-Proof.
- intros l x r; functional induction bal l x r; intros; clearf;
- simpl; auto with arith; romega with *.
-Qed.
-
-Lemma add_cardinal : forall x s, 
- cardinal (add x s) <= S (cardinal s).
-Proof.
- intros; functional induction add x s; simpl; auto with arith; 
- rewrite bal_cardinal; romega with *.
-Qed.
-
-Lemma join_cardinal : forall l x r, 
- cardinal (join l x r) <= S (cardinal l + cardinal r).
-Proof.
- join_tac; auto with arith.
- simpl; apply add_cardinal.
- simpl; destruct X.compare; simpl; auto with arith.
- generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); 
-  romega with *.
- generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); 
-  romega with *.
- generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh)))
-  (Hlr x (Node rl rx rr rh)); simpl; romega with *.
- simpl S in *; generalize (bal_cardinal (join (Node ll lx lr lh) x rl) rx rr).
- romega with *.
-Qed.
-
-Lemma split_cardinal_1 : forall x s, 
- (cardinal (split x s)#l <= cardinal s)%nat.
-Proof.
- intros x s; functional induction split x s; simpl; auto.
- rewrite e1 in IHt; simpl in *.
- romega with *.
- romega with *.
- rewrite e1 in IHt; simpl in *.
- generalize (@join_cardinal l y rl); romega with *.
-Qed.
-
-Lemma split_cardinal_2 : forall x s, 
- (cardinal (split x s)#r <= cardinal s)%nat.
-Proof.
- intros x s; functional induction split x s; simpl; auto.
- rewrite e1 in IHt; simpl in *.
- generalize (@join_cardinal rl y r); romega with *.
- romega with *.
- rewrite e1 in IHt; simpl in *; romega with *.
-Qed.
-
-(** * [ocaml_union], an union faithful to the original ocaml code *)
-
-Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat.
-
-Ltac ocaml_union_tac := 
- intros; unfold cardinal2; simpl fst in *; simpl snd in *;
- match goal with H: split ?x ?s = _ |- _ => 
-  generalize (split_cardinal_1 x s) (split_cardinal_2 x s); 
-  rewrite H; simpl; romega with *
- end.
-
-Import Logic. (* Unhide eq, otherwise Function complains. *)
-
-Function ocaml_union (s : t * t) { measure cardinal2 s } : t  :=
- match s with 
-  | (Leaf, Leaf) => s#2
-  | (Leaf, Node _ _ _ _) => s#2
-  | (Node _ _ _ _, Leaf) => s#1
-  | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => 
-        if ge_lt_dec h1 h2 then
-          if eq_dec h2 1%I then add x2 s#1 else
-          let (l2',_,r2') := split x1 s#2 in 
-             join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2'))
-        else
-          if eq_dec h1 1%I then add x1 s#2 else
-          let (l1',_,r1') := split x2 s#1 in 
-             join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2))
- end.
-Proof.
-abstract ocaml_union_tac.
-abstract ocaml_union_tac.
-abstract ocaml_union_tac.
-abstract ocaml_union_tac.
-Defined.
-
-Lemma ocaml_union_in : forall s y, 
- bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 ->
- (In y (ocaml_union s) <-> In y s#1 \/ In y s#2).
-Proof.
- intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; 
-  simpl fst in *; simpl snd in *; try clear e0 e1.
- intuition_in.
- intuition_in.
- intuition_in.
- (* add x2 s#1 *)
- inv avl.
- rewrite (height_0 H); [ | avl_nn l2; omega_max].
- rewrite (height_0 H0); [ | avl_nn r2; omega_max].
- rewrite add_in; intuition_in.
- (* join (union (l1,l2')) x1 (union (r1,r2')) *)
- generalize
-  (split_avl x1 A2) (split_bst x1 B2)
-  (split_in_1 x1 y B2) (split_in_2 x1 y B2).
- rewrite e2; simpl.
- destruct 1; destruct 1; inv avl; inv bst.
- rewrite join_in, IHt, IHt0; auto.
- do 2 (intro Eq; rewrite Eq; clear Eq).
- case (X.compare y x1); intuition_in.
- (* add x1 s#2 *)
- inv avl.
- rewrite (height_0 H3); [ | avl_nn l1; omega_max].
- rewrite (height_0 H4); [ | avl_nn r1; omega_max].
- rewrite add_in; auto; intuition_in.
- (* join (union (l1',l2)) x1 (union (r1',r2)) *)
- generalize 
-  (split_avl x2 A1) (split_bst x2 B1)
-  (split_in_1 x2 y B1) (split_in_2 x2 y B1).
- rewrite e2; simpl.
- destruct 1; destruct 1; inv avl; inv bst.
- rewrite join_in, IHt, IHt0; auto.
- do 2 (intro Eq; rewrite Eq; clear Eq).
- case (X.compare y x2); intuition_in.
-Qed.
-
-Lemma ocaml_union_bst : forall s,
- bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s).
-Proof.
- intros s; functional induction ocaml_union s; intros B1 A1 B2 A2;
-  simpl fst in *; simpl snd in *; try clear e0 e1; 
-  try apply add_bst; auto.
- (* join (union (l1,l2')) x1 (union (r1,r2')) *)
- clear _x _x0; factornode l2 x2 r2 h2 as s2.
- generalize (split_avl x1 A2) (split_bst x1 B2)
-  (@split_in_1 s2 x1)(@split_in_2 s2 x1).
- rewrite e2; simpl.
- destruct 1; destruct 1; intros.
- inv bst; inv avl.
- apply join_bst; auto.
- intro y; rewrite ocaml_union_in, H3; intuition_in.
- intro y; rewrite ocaml_union_in, H4; intuition_in.
- (* join (union (l1',l2)) x1 (union (r1',r2)) *)
- clear _x _x0; factornode l1 x1 r1 h1 as s1.
- generalize (split_avl x2 A1) (split_bst x2 B1)
-  (@split_in_1 s1 x2)(@split_in_2 s1 x2).
- rewrite e2; simpl.
- destruct 1; destruct 1; intros.
- inv bst; inv avl.
- apply join_bst; auto.
- intro y; rewrite ocaml_union_in, H3; intuition_in.
- intro y; rewrite ocaml_union_in, H4; intuition_in.
-Qed.
-
-Lemma ocaml_union_avl : forall s, 
- avl s#1 -> avl s#2 -> avl (ocaml_union s).
-Proof.
- intros s; functional induction ocaml_union s; 
-  simpl fst in *; simpl snd in *; auto.
- intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl.
- inv avl; destruct 1; auto.
- intros A1 A2; generalize (split_avl x2 A1); rewrite e2; simpl.
- inv avl; destruct 1; auto.
-Qed.
-
-Lemma ocaml_union_alt : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 ->
- Equal (ocaml_union s) (union s#1 s#2).
-Proof.
- red; intros; rewrite ocaml_union_in, union_in; simpl; intuition.
-Qed.
-
-
-(** * [ocaml_subset], a subset faithful to the original ocaml code *)
-
-Function ocaml_subset (s:t*t) { measure cardinal2 s } : bool :=
- match s with
-  | (Leaf, _) => true
-  | (Node _ _ _ _, Leaf) => false
-  | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) =>
-     match X.compare x1 x2 with
-      | EQ _ => ocaml_subset (l1,l2) && ocaml_subset (r1,r2)
-      | LT _ => ocaml_subset (Node l1 x1 Leaf 0%I, l2) && ocaml_subset (r1,s#2)
-      | GT _ => ocaml_subset (Node Leaf x1 r1 0%I, r2) && ocaml_subset (l1,s#2)
-     end
- end.
-
-Proof.
- intros; unfold cardinal2; simpl; abstract romega with *.
- intros; unfold cardinal2; simpl; abstract romega with *.
- intros; unfold cardinal2; simpl; abstract romega with *.
- intros; unfold cardinal2; simpl; abstract romega with *.
- intros; unfold cardinal2; simpl; abstract romega with *.
- intros; unfold cardinal2; simpl; abstract romega with *.
-Defined.
-
-Lemma ocaml_subset_12 : forall s, 
- bst s#1 -> bst s#2 ->
- (ocaml_subset s = true <-> Subset s#1 s#2).
-Proof.
- intros s; functional induction ocaml_subset s; simpl;
-  intros B1 B2; try clear e0.
- intuition.
- red; auto; inversion 1.
- split; intros; try discriminate.
- assert (H': In _x0 Leaf) by auto; inversion H'.
- (**)
- simpl in *; inv bst.
- rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
- unfold Subset; intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- (**)
- simpl in *; inv bst.
- rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
- unfold Subset; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- (**)
- simpl in *; inv bst.
- rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
- unfold Subset; intuition_in.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> 
- ocaml_subset s = subset s#1 s#2.
-Proof.
- intros.
- generalize (ocaml_subset_12 H H0); rewrite <-subset_12 by auto.
- destruct ocaml_subset; destruct subset; intuition.
-Qed.
-
-
-
-(** [ocaml_compare], a compare faithful to the original ocaml code *)
-
-(** termination of [compare_aux] *)
-
-Fixpoint cardinal_e e := match e with
-  | End => 0
-  | More _ s r => S (cardinal s + cardinal_e r)
- end.
-
-Lemma cons_cardinal_e : forall s e, 
- cardinal_e (cons s e) = cardinal s + cardinal_e e.
-Proof.
- induction s; simpl; intros; auto.
- rewrite IHs1; simpl; rewrite <- plus_n_Sm; auto with arith.
-Qed.
-
-Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2.
-
-Function ocaml_compare_aux 
- (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := 
- match e with 
- | (End,End) => Eq
- | (End,More _ _ _) => Lt 
- | (More _ _ _, End) => Gt 
- | (More x1 r1 e1, More x2 r2 e2) => 
-       match X.compare x1 x2 with 
-        | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2)
-        | LT _ => Lt 
-        | GT _ => Gt 
-       end
- end.
-
-Proof.
-intros; unfold cardinal_e_2; simpl; 
-abstract (do 2 rewrite cons_cardinal_e; romega with *).
-Defined.
-
-Definition ocaml_compare s1 s2 := 
- ocaml_compare_aux (cons s1 End, cons s2 End).
-
-Lemma ocaml_compare_aux_Cmp : forall e, 
- Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2).
-Proof.
- intros e; functional induction ocaml_compare_aux e; simpl; intros; 
-  auto; try discriminate.
- apply L.eq_refl.
- simpl in *.
- apply cons_Cmp; auto.
- rewrite <- 2 cons_1; auto.
-Qed.
-
-Lemma ocaml_compare_Cmp : forall s1 s2,
- Cmp (ocaml_compare s1 s2) (elements s1) (elements s2).
-Proof.
- unfold ocaml_compare; intros.
- assert (H1:=cons_1 s1 End).
- assert (H2:=cons_1 s2 End).
- simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2.
- apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)).
-Qed.
-
-Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> 
- ocaml_compare s1 s2 = compare s1 s2.
-Proof.
- intros s1 s2 B1 B2.
- generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). 
- unfold Cmp.
- destruct ocaml_compare; destruct compare; auto; intros; elimtype False.
- elim (lt_not_eq B1 B2 H0); auto.
- elim (lt_not_eq B2 B1 H0); auto.
-  apply eq_sym; auto.
- elim (lt_not_eq B1 B2 H); auto.
-  elim (lt_not_eq B1 B1).
-  red; eapply L.lt_trans; eauto.
-  apply eq_refl.
- elim (lt_not_eq B2 B1 H); auto.
-  apply eq_sym; auto.
- elim (lt_not_eq B1 B2 H0); auto.
-  elim (lt_not_eq B1 B1).
-  red; eapply L.lt_trans; eauto.
-  apply eq_refl.
-Qed.
-
-
-(** * Equality test *)
-
-Definition ocaml_equal s1 s2 : bool := 
- match ocaml_compare s1 s2 with 
-  | Eq => true
-  | _ => false 
- end.
-
-Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 ->  
- Equal s1 s2 -> ocaml_equal s1 s2 = true.
-Proof.
-unfold ocaml_equal; intros s1 s2 B1 B2 E.
-generalize (ocaml_compare_Cmp s1 s2).
-destruct (ocaml_compare s1 s2); auto; intros.
-elim (lt_not_eq B1 B2 H E); auto.
-elim (lt_not_eq B2 B1 H (eq_sym E)); auto.
-Qed.
-
-Lemma ocaml_equal_2 : forall s1 s2,
- ocaml_equal s1 s2 = true -> Equal s1 s2.
-Proof.
-unfold ocaml_equal; intros s1 s2 E.
-generalize (ocaml_compare_Cmp s1 s2); 
- destruct ocaml_compare; auto; discriminate.
-Qed.
-
-Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> 
- ocaml_equal s1 s2 = equal s1 s2.
-Proof.
-intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto.
-Qed.
-
-End OcamlOps.
-
-
-
-(** * Encapsulation
-
-   We can implement [S] with balanced binary search trees. 
-   When compared to [FSetAVL], we maintain here two invariants
-   (bst and avl) instead of only bst, which is enough for fulfilling
-   the FSet interface.
-
-   This encapsulation propose the non-structural variants 
-   [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal].
-*) 
-
-Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
-
- Module E := X.
- Module Import OcamlOps := OcamlOps I X.
- Import AvlProofs.
- Import Raw.
- Import Raw.Proofs.
-
- Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}.
- Definition t := bbst.
- Definition elt := E.t.
- 
- Definition In (x : elt) (s : t) : Prop := In x s.
- Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
- Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
- Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
- Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x.
- Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x.
-  
- Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. 
- Proof. intro s; exact (@In_1 s). Qed.
- 
- Definition mem (x:elt)(s:t) : bool := mem x s.
-
- Definition empty : t := Bbst empty_bst empty_avl.
- Definition is_empty (s:t) : bool := is_empty s.
- Definition singleton (x:elt) : t := 
-   Bbst (singleton_bst x) (singleton_avl x).
- Definition add (x:elt)(s:t) : t := 
-   Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). 
- Definition remove (x:elt)(s:t) : t := 
-   Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)).
- Definition inter (s s':t) : t := 
-   Bbst (inter_bst (is_bst s) (is_bst s'))
-        (inter_avl (is_avl s) (is_avl s')).
- Definition union (s s':t) : t :=
-   Bbst (union_bst (is_bst s) (is_bst s'))
-        (union_avl (is_avl s) (is_avl s')).
- Definition ocaml_union (s s':t) : t :=
-   Bbst (@ocaml_union_bst (s.(this),s'.(this)) 
-          (is_bst s) (is_avl s) (is_bst s') (is_avl s'))
-        (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')).
- Definition diff (s s':t) : t := 
-   Bbst (diff_bst (is_bst s) (is_bst s'))
-        (diff_avl (is_avl s) (is_avl s')).
- Definition elements (s:t) : list elt := elements s.
- Definition min_elt (s:t) : option elt := min_elt s.
- Definition max_elt (s:t) : option elt := max_elt s.
- Definition choose (s:t) : option elt := choose s.
- Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. 
- Definition cardinal (s:t) : nat := cardinal s.
- Definition filter (f : elt -> bool) (s:t) : t := 
-   Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)).
- Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s.
- Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s.
- Definition partition (f : elt -> bool) (s:t) : t * t :=
-   let p := partition f s in
-   (@Bbst (fst p) (partition_bst_1 f (is_bst s)) 
-                 (partition_avl_1 f (is_avl s)), 
-    @Bbst (snd p) (partition_bst_2 f (is_bst s))
-                 (partition_avl_2 f (is_avl s))).
-
- Definition equal (s s':t) : bool := equal s s'.
- Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'.
- Definition subset (s s':t) : bool := subset s s'.
- Definition ocaml_subset (s s':t) : bool := 
-  ocaml_subset (s.(this),s'.(this)).
-
- Definition eq (s s':t) : Prop := Equal s s'.
- Definition lt (s s':t) : Prop := lt s s'.
-
- Definition compare (s s':t) : Compare lt eq s s'.
- Proof.
-  intros (s,b,a) (s',b',a').
-  generalize (compare_Cmp s s').
-  destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
-  change (Raw.Equal s s'); auto.
- Defined.
-
- Definition ocaml_compare (s s':t) : Compare lt eq s s'.
- Proof.
-  intros (s,b,a) (s',b',a').
-  generalize (ocaml_compare_Cmp s s').
-  destruct ocaml_compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
-  change (Raw.Equal s s'); auto.
- Defined.
-
- Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }.
- Proof.
-  intros (s,b,a) (s',b',a'); unfold eq; simpl.
-  case_eq (Raw.equal s s'); intro H; [left|right].
-  apply equal_2; auto.
-  intro H'; rewrite equal_1 in H; auto; discriminate.
- Defined.
-
- (* specs *)
- Section Specs. 
- Variable s s' s'': t. 
- Variable x y : elt.
-
- Hint Resolve is_bst is_avl.
- 
- Lemma mem_1 : In x s -> mem x s = true. 
- Proof. exact (mem_1 (is_bst s)). Qed.
- Lemma mem_2 : mem x s = true -> In x s.
- Proof. exact (@mem_2 s x). Qed.
-
- Lemma equal_1 : Equal s s' -> equal s s' = true.
- Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed.
- Lemma equal_2 : equal s s' = true -> Equal s s'.
- Proof. exact (@equal_2 s s'). Qed.
-
- Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'.
- Proof. 
-  destruct s; destruct s'; unfold ocaml_equal, equal; simpl.
-  apply ocaml_equal_alt; auto.
- Qed.
- 
- Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true.
- Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed.
- Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'.
- Proof. exact (@ocaml_equal_2 s s'). Qed. 
-
- Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition.
-
- Lemma subset_1 : Subset s s' -> subset s s' = true.
- Proof. wrap subset subset_12. Qed.
- Lemma subset_2 : subset s s' = true -> Subset s s'.
- Proof. wrap subset subset_12. Qed.
-
- Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'.
- Proof. 
-  destruct s; destruct s'; unfold ocaml_subset, subset; simpl.
-  rewrite ocaml_subset_alt; auto.
- Qed.
-
- Lemma ocaml_subset_1 : Subset s s' -> ocaml_subset s s' = true.
- Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed.
- Lemma ocaml_subset_2 : ocaml_subset s s' = true -> Subset s s'.
- Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed.
-
- Lemma empty_1 : Empty empty.
- Proof. exact empty_1. Qed.
-
- Lemma is_empty_1 : Empty s -> is_empty s = true.
- Proof. exact (@is_empty_1 s). Qed.
- Lemma is_empty_2 : is_empty s = true -> Empty s. 
- Proof. exact (@is_empty_2 s). Qed.
- 
- Lemma add_1 : E.eq x y -> In y (add x s).
- Proof. wrap add add_in. Qed.
- Lemma add_2 : In y s -> In y (add x s).
- Proof. wrap add add_in. Qed.
- Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
- Proof. wrap add add_in. elim H; auto. Qed.
-
- Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
- Proof. wrap remove remove_in. Qed.
- Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
- Proof. wrap remove remove_in. Qed.
- Lemma remove_3 : In y (remove x s) -> In y s.
- Proof. wrap remove remove_in. Qed.
-
- Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
- Proof. exact (@singleton_1 x y). Qed.
- Lemma singleton_2 : E.eq x y -> In y (singleton x). 
- Proof. exact (@singleton_2 x y). Qed.
-
- Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
- Proof. wrap union union_in. Qed.
- Lemma union_2 : In x s -> In x (union s s'). 
- Proof. wrap union union_in. Qed.
- Lemma union_3 : In x s' -> In x (union s s').
- Proof. wrap union union_in. Qed.
-
- Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s').
- Proof. 
-  unfold ocaml_union, union, Equal, In.
-  destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl.
-  exact (@ocaml_union_alt (s0,s0') b a b' a').
- Qed.
-
- Lemma ocaml_union_1 : In x (ocaml_union s s') -> In x s \/ In x s'.
- Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
- Lemma ocaml_union_2 : In x s -> In x (ocaml_union s s').
- Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
- Lemma ocaml_union_3 : In x s' -> In x (ocaml_union s s').
- Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
-
- Lemma inter_1 : In x (inter s s') -> In x s.
- Proof. wrap inter inter_in. Qed.
- Lemma inter_2 : In x (inter s s') -> In x s'.
- Proof. wrap inter inter_in. Qed.
- Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
- Proof. wrap inter inter_in. Qed.
- 
- Lemma diff_1 : In x (diff s s') -> In x s. 
- Proof. wrap diff diff_in. Qed.
- Lemma diff_2 : In x (diff s s') -> ~ In x s'.
- Proof. wrap diff diff_in. Qed.
- Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
- Proof. wrap diff diff_in. Qed.
- 
- Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
-      fold f s i = fold_left (fun a e => f e a) (elements s) i.
- Proof. 
- unfold fold, elements; intros; apply fold_1; auto.
- Qed.
-
- Lemma cardinal_1 : cardinal s = length (elements s).
- Proof. 
- unfold cardinal, elements; intros; apply elements_cardinal; auto.
- Qed.
-
- Section Filter.
- Variable f : elt -> bool.
-
- Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
- Proof. intro. wrap filter filter_in. Qed.
- Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
- Proof. intro. wrap filter filter_in. Qed. 
- Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
- Proof. intro. wrap filter filter_in. Qed.
-
- Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true.
- Proof. exact (@for_all_1 f s). Qed.
- Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s.
- Proof. exact (@for_all_2 f s). Qed.
-
- Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
- Proof. exact (@exists_1 f s). Qed.
- Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
- Proof. exact (@exists_2 f s). Qed.
-
- Lemma partition_1 : compat_bool E.eq f -> 
-  Equal (fst (partition f s)) (filter f s).
- Proof.
- unfold partition, filter, Equal, In; simpl ;intros H a.
- rewrite partition_in_1, filter_in; intuition.
- Qed.
-
- Lemma partition_2 : compat_bool E.eq f -> 
-  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
- Proof.
- unfold partition, filter, Equal, In; simpl ;intros H a.
- rewrite partition_in_2, filter_in; intuition.
- rewrite H2; auto.
- destruct (f a); auto.
- red; intros; f_equal.
- rewrite (H _ _ H0); auto.
- Qed.
-
- End Filter.
-
- Lemma elements_1 : In x s -> InA E.eq x (elements s).
- Proof. wrap elements elements_in. Qed.
- Lemma elements_2 : InA E.eq x (elements s) -> In x s.
- Proof. wrap elements elements_in. Qed.
- Lemma elements_3 : sort E.lt (elements s).
- Proof. exact (elements_sort (is_bst s)). Qed.
- Lemma elements_3w : NoDupA E.eq (elements s).
- Proof. exact (elements_nodup (is_bst s)). Qed.
-
- Lemma min_elt_1 : min_elt s = Some x -> In x s. 
- Proof. exact (@min_elt_1 s x). Qed.
- Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
- Proof. exact (@min_elt_2 s x y (is_bst s)). Qed.
- Lemma min_elt_3 : min_elt s = None -> Empty s.
- Proof. exact (@min_elt_3 s). Qed.
-
- Lemma max_elt_1 : max_elt s = Some x -> In x s. 
- Proof. exact (@max_elt_1 s x). Qed.
- Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
- Proof. exact (@max_elt_2 s x y (is_bst s)). Qed.
- Lemma max_elt_3 : max_elt s = None -> Empty s.
- Proof. exact (@max_elt_3 s). Qed.
-
- Lemma choose_1 : choose s = Some x -> In x s.
- Proof. exact (@choose_1 s x). Qed.
- Lemma choose_2 : choose s = None -> Empty s.
- Proof. exact (@choose_2 s). Qed.
- Lemma choose_3 : choose s = Some x -> choose s' = Some y -> 
-  Equal s s' -> E.eq x y.
- Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed.
-
- Lemma eq_refl : eq s s. 
- Proof. exact (eq_refl s). Qed.
- Lemma eq_sym : eq s s' -> eq s' s.
- Proof. exact (@eq_sym s s'). Qed.
- Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
- Proof. exact (@eq_trans s s' s''). Qed.
-  
- Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
- Proof. exact (@lt_trans s s' s''). Qed.
- Lemma lt_not_eq : lt s s' -> ~eq s s'.
- Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed.
-
- End Specs.
-End IntMake.
-
-(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
-
-Module Make (X: OrderedType) <: S with Module E := X
- :=IntMake(Z_as_Int)(X).
-
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
index 79eea34e..8aede552 100644
--- a/theories/FSets/FSetInterface.v
+++ b/theories/FSets/FSetInterface.v
@@ -6,17 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetInterface.v 11701 2008-12-18 11:49:12Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite set library *)
 
-(** Set interfaces, inspired by the one of Ocaml. When compared with 
-    Ocaml, the main differences are: 
+(** Set interfaces, inspired by the one of Ocaml. When compared with
+    Ocaml, the main differences are:
     - the lack of [iter] function, useless since Coq is purely functional
     - the use of [option] types instead of [Not_found] exceptions
-    - the use of [nat] instead of [int] for the [cardinal] function 
+    - the use of [nat] instead of [int] for the [cardinal] function
 
-    Several variants of the set interfaces are available: 
+    Several variants of the set interfaces are available:
     - [WSfun] : functorial signature for weak sets, non-dependent style
     - [WS]    : self-contained version of [WSfun]
     - [Sfun]  : functorial signature for ordered sets, non-dependent style
@@ -24,7 +24,7 @@
     - [Sdep]  : analog of [S] written using dependent style
 
     If unsure, [S] is probably what you're looking for: other signatures
-    are subsets of it, apart from [Sdep] which is isomorphic to [S] (see 
+    are subsets of it, apart from [Sdep] which is isomorphic to [S] (see
     [FSetBridge]).
 *)
 
@@ -34,14 +34,14 @@ Unset Strict Implicit.
 
 (** * Non-dependent signatures
 
-    The following signatures presents sets as purely informative 
+    The following signatures presents sets as purely informative
     programs together with axioms *)
 
 
 
 (** ** Functorial signature for weak sets
 
-    Weak sets are sets without ordering on base elements, only 
+    Weak sets are sets without ordering on base elements, only
     a decidable equality. *)
 
 Module Type WSfun (E : DecidableType).
@@ -57,7 +57,7 @@ Module Type WSfun (E : DecidableType).
   Definition Empty s := forall a : elt, ~ In a s.
   Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
   Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
-  
+
   Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
   Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
 
@@ -137,7 +137,7 @@ Module Type WSfun (E : DecidableType).
   the set is empty. Which element is chosen is unspecified.
   Equal sets could return different elements. *)
 
-  Section Spec. 
+  Section Spec.
 
   Variable s s' s'': t.
   Variable x y : elt.
@@ -146,15 +146,15 @@ Module Type WSfun (E : DecidableType).
   Parameter In_1 : E.eq x y -> In x s -> In y s.
 
   (** Specification of [eq] *)
-  Parameter eq_refl : eq s s. 
+  Parameter eq_refl : eq s s.
   Parameter eq_sym : eq s s' -> eq s' s.
   Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''.
 
   (** Specification of [mem] *)
   Parameter mem_1 : In x s -> mem x s = true.
-  Parameter mem_2 : mem x s = true -> In x s. 
- 
-  (** Specification of [equal] *) 
+  Parameter mem_2 : mem x s = true -> In x s.
+
+  (** Specification of [equal] *)
   Parameter equal_1 : Equal s s' -> equal s s' = true.
   Parameter equal_2 : equal s s' = true -> Equal s s'.
 
@@ -166,13 +166,13 @@ Module Type WSfun (E : DecidableType).
   Parameter empty_1 : Empty empty.
 
   (** Specification of [is_empty] *)
-  Parameter is_empty_1 : Empty s -> is_empty s = true. 
+  Parameter is_empty_1 : Empty s -> is_empty s = true.
   Parameter is_empty_2 : is_empty s = true -> Empty s.
- 
+
   (** Specification of [add] *)
   Parameter add_1 : E.eq x y -> In y (add x s).
   Parameter add_2 : In y s -> In y (add x s).
-  Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+  Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
 
   (** Specification of [remove] *)
   Parameter remove_1 : E.eq x y -> ~ In y (remove x s).
@@ -180,12 +180,12 @@ Module Type WSfun (E : DecidableType).
   Parameter remove_3 : In y (remove x s) -> In y s.
 
   (** Specification of [singleton] *)
-  Parameter singleton_1 : In y (singleton x) -> E.eq x y. 
-  Parameter singleton_2 : E.eq x y -> In y (singleton x). 
+  Parameter singleton_1 : In y (singleton x) -> E.eq x y.
+  Parameter singleton_2 : E.eq x y -> In y (singleton x).
 
   (** Specification of [union] *)
   Parameter union_1 : In x (union s s') -> In x s \/ In x s'.
-  Parameter union_2 : In x s -> In x (union s s'). 
+  Parameter union_2 : In x s -> In x (union s s').
   Parameter union_3 : In x s' -> In x (union s s').
 
   (** Specification of [inter] *)
@@ -194,24 +194,24 @@ Module Type WSfun (E : DecidableType).
   Parameter inter_3 : In x s -> In x s' -> In x (inter s s').
 
   (** Specification of [diff] *)
-  Parameter diff_1 : In x (diff s s') -> In x s. 
+  Parameter diff_1 : In x (diff s s') -> In x s.
   Parameter diff_2 : In x (diff s s') -> ~ In x s'.
   Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s').
- 
-  (** Specification of [fold] *)  
+
+  (** Specification of [fold] *)
   Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
       fold f s i = fold_left (fun a e => f e a) (elements s) i.
 
-  (** Specification of [cardinal] *)  
+  (** Specification of [cardinal] *)
   Parameter cardinal_1 : cardinal s = length (elements s).
 
   Section Filter.
-  
+
   Variable f : elt -> bool.
 
   (** Specification of [filter] *)
-  Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
-  Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s.
+  Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true.
   Parameter filter_3 :
       compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
 
@@ -243,7 +243,7 @@ Module Type WSfun (E : DecidableType).
   (** Specification of [elements] *)
   Parameter elements_1 : In x s -> InA E.eq x (elements s).
   Parameter elements_2 : InA E.eq x (elements s) -> In x s.
-  (** When compared with ordered sets, here comes the only 
+  (** When compared with ordered sets, here comes the only
       property that is really weaker: *)
   Parameter elements_3w : NoDupA E.eq (elements s).
 
@@ -257,11 +257,11 @@ Module Type WSfun (E : DecidableType).
     is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
     remove_2 singleton_2 union_1 union_2 union_3
     inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
-    partition_1 partition_2 elements_1 elements_3w 
+    partition_1 partition_2 elements_1 elements_3w
     : set.
   Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
     remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
-    filter_1 filter_2 for_all_2 exists_2 elements_2 
+    filter_1 filter_2 for_all_2 exists_2 elements_2
     : set.
 
 End WSfun.
@@ -270,12 +270,12 @@ End WSfun.
 
 (** ** Static signature for weak sets
 
-    Similar to the functorial signature [SW], except that the 
+    Similar to the functorial signature [SW], except that the
     module [E] of base elements is incorporated in the signature. *)
 
 Module Type WS.
   Declare Module E : DecidableType.
-  Include Type WSfun E.
+  Include WSfun E.
 End WS.
 
 
@@ -286,7 +286,7 @@ End WS.
     and some stronger specifications for other functions. *)
 
 Module Type Sfun (E : OrderedType).
-  Include Type WSfun E.
+  Include WSfun E.
 
   Parameter lt : t -> t -> Prop.
   Parameter compare : forall s s' : t, Compare lt eq s s'.
@@ -295,48 +295,48 @@ Module Type Sfun (E : OrderedType).
 
   Parameter min_elt : t -> option elt.
   (** Return the smallest element of the given set
-  (with respect to the [E.compare] ordering), 
+  (with respect to the [E.compare] ordering),
   or [None] if the set is empty. *)
 
   Parameter max_elt : t -> option elt.
   (** Same as [min_elt], but returns the largest element of the
   given set. *)
 
-  Section Spec. 
+  Section Spec.
 
   Variable s s' s'' : t.
   Variable x y : elt.
- 
+
   (** Specification of [lt] *)
   Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''.
   Parameter lt_not_eq : lt s s' -> ~ eq s s'.
 
   (** Additional specification of [elements] *)
-  Parameter elements_3 : sort E.lt (elements s).  
+  Parameter elements_3 : sort E.lt (elements s).
 
   (** Remark: since [fold] is specified via [elements], this stronger
-   specification of [elements] has an indirect impact on [fold], 
+   specification of [elements] has an indirect impact on [fold],
    which can now be proved to receive elements in increasing order.
   *)
 
   (** Specification of [min_elt] *)
-  Parameter min_elt_1 : min_elt s = Some x -> In x s. 
-  Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. 
+  Parameter min_elt_1 : min_elt s = Some x -> In x s.
+  Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
   Parameter min_elt_3 : min_elt s = None -> Empty s.
 
-  (** Specification of [max_elt] *)  
-  Parameter max_elt_1 : max_elt s = Some x -> In x s. 
-  Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. 
+  (** Specification of [max_elt] *)
+  Parameter max_elt_1 : max_elt s = Some x -> In x s.
+  Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
   Parameter max_elt_3 : max_elt s = None -> Empty s.
 
   (** Additional specification of [choose] *)
-  Parameter choose_3 : choose s = Some x -> choose s' = Some y -> 
+  Parameter choose_3 : choose s = Some x -> choose s' = Some y ->
     Equal s s' -> E.eq x y.
 
   End Spec.
 
   Hint Resolve elements_3 : set.
-  Hint Immediate 
+  Hint Immediate
     min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set.
 
 End Sfun.
@@ -344,12 +344,12 @@ End Sfun.
 
 (** ** Static signature for sets on ordered elements
 
-    Similar to the functorial signature [Sfun], except that the 
+    Similar to the functorial signature [Sfun], except that the
     module [E] of base elements is incorporated in the signature. *)
 
 Module Type S.
   Declare Module E : OrderedType.
-  Include Type Sfun E.
+  Include Sfun E.
 End S.
 
 
@@ -411,7 +411,7 @@ Module Type Sdep.
 
   Parameter
     singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
-  
+
   Parameter
     remove :
       forall (x : elt) (s : t),
@@ -433,7 +433,7 @@ Module Type Sdep.
       {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
 
   Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}.
- 
+
   Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}.
 
   Parameter
@@ -447,7 +447,7 @@ Module Type Sdep.
       forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
         (s : t),
       {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
-  
+
   Parameter
     exists_ :
       forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
@@ -474,7 +474,7 @@ Module Type Sdep.
   Parameter
     fold :
       forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
-      {r : A | let (l,_) := elements s in 
+      {r : A | let (l,_) := elements s in
                   r = fold_left (fun a e => f e a) l i}.
 
   Parameter
@@ -494,10 +494,10 @@ Module Type Sdep.
 
   Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}.
 
-  (** The [choose_3] specification of [S] cannot be packed 
+  (** The [choose_3] specification of [S] cannot be packed
         in the dependent version of [choose], so we leave it separate. *)
-  Parameter choose_equal : forall s s', Equal s s' -> 
-     match choose s, choose s' with 
+  Parameter choose_equal : forall s s', Equal s s' ->
+     match choose s, choose s' with
        | inleft (exist x _), inleft (exist x' _) => E.eq x x'
        | inright _, inright _  => True
        | _, _  => False
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
index b009e109..f83259c4 100644
--- a/theories/FSets/FSetList.v
+++ b/theories/FSets/FSetList.v
@@ -6,1271 +6,24 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetList.v 11866 2009-01-28 19:10:15Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite sets library *)
 
-(** This file proposes an implementation of the non-dependant 
+(** This file proposes an implementation of the non-dependant
     interface [FSetInterface.S] using strictly ordered list. *)
 
 Require Export FSetInterface.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** * Functions over lists
+(** This is just a compatibility layer, the real implementation
+    is now in [MSetList] *)
 
-   First, we provide sets as lists which are not necessarily sorted.
-   The specs are proved under the additional condition of being sorted. 
-   And the functions returning sets are proved to preserve this invariant. *)
-
-Module Raw (X: OrderedType).
- 
-  Module MX := OrderedTypeFacts X.
-  Import MX.
-
-  Definition elt := X.t.
-  Definition t := list elt.
-
-  Definition empty : t := nil.
-
-  Definition is_empty (l : t) : bool := if l then true else false.
-
-  (** ** The set operations. *)
-
-  Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
-    match s with
-    | nil => false
-    | y :: l =>
-        match X.compare x y with
-        | LT _ => false
-        | EQ _ => true
-        | GT _ => mem x l
-        end
-    end.
-
-  Fixpoint add (x : elt) (s : t) {struct s} : t :=
-    match s with
-    | nil => x :: nil
-    | y :: l =>
-        match X.compare x y with
-        | LT _ => x :: s
-        | EQ _ => s
-        | GT _ => y :: add x l
-        end
-    end.
-
-  Definition singleton (x : elt) : t := x :: nil. 
-
-  Fixpoint remove (x : elt) (s : t) {struct s} : t :=
-    match s with
-    | nil => nil
-    | y :: l =>
-        match X.compare x y with
-        | LT _ => s
-        | EQ _ => l
-        | GT _ => y :: remove x l
-        end
-    end.  
-  
-  Fixpoint union (s : t) : t -> t :=
-    match s with
-    | nil => fun s' => s'
-    | x :: l =>
-        (fix union_aux (s' : t) : t :=
-           match s' with
-           | nil => s
-           | x' :: l' =>
-               match X.compare x x' with
-               | LT _ => x :: union l s'
-               | EQ _ => x :: union l l'
-               | GT _ => x' :: union_aux l'
-               end
-           end)
-    end.      
-
-  Fixpoint inter (s : t) : t -> t :=
-    match s with
-    | nil => fun _ => nil
-    | x :: l =>
-        (fix inter_aux (s' : t) : t :=
-           match s' with
-           | nil => nil
-           | x' :: l' =>
-               match X.compare x x' with
-               | LT _ => inter l s'
-               | EQ _ => x :: inter l l'
-               | GT _ => inter_aux l'
-               end
-           end)
-    end.  
-  
-  Fixpoint diff (s : t) : t -> t :=
-    match s with
-    | nil => fun _ => nil
-    | x :: l =>
-        (fix diff_aux (s' : t) : t :=
-           match s' with
-           | nil => s
-           | x' :: l' =>
-               match X.compare x x' with
-               | LT _ => x :: diff l s'
-               | EQ _ => diff l l'
-               | GT _ => diff_aux l'
-               end
-           end)
-    end.  
-   
-  Fixpoint equal (s : t) : t -> bool :=
-    fun s' : t =>
-    match s, s' with
-    | nil, nil => true
-    | x :: l, x' :: l' =>
-        match X.compare x x' with
-        | EQ _ => equal l l'
-        | _ => false
-        end
-    | _, _ => false
-    end.
-
-  Fixpoint subset (s s' : t) {struct s'} : bool :=
-    match s, s' with
-    | nil, _ => true
-    | x :: l, x' :: l' =>
-        match X.compare x x' with
-        | LT _ => false
-        | EQ _ => subset l l'
-        | GT _ => subset s l'
-        end
-    | _, _ => false
-    end.
-
-  Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : 
-   B -> B := fun i => match s with
-                      | nil => i
-                      | x :: l => fold f l (f x i)
-                      end.  
-
-  Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
-    match s with
-    | nil => nil
-    | x :: l => if f x then x :: filter f l else filter f l
-    end.  
-
-  Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
-    match s with
-    | nil => true
-    | x :: l => if f x then for_all f l else false
-    end.  
- 
-  Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
-    match s with
-    | nil => false
-    | x :: l => if f x then true else exists_ f l
-    end.
-
-  Fixpoint partition (f : elt -> bool) (s : t) {struct s} : 
-   t * t :=
-    match s with
-    | nil => (nil, nil)
-    | x :: l =>
-        let (s1, s2) := partition f l in
-        if f x then (x :: s1, s2) else (s1, x :: s2)
-    end.
-
-  Definition cardinal (s : t) : nat := length s.
-
-  Definition elements (x : t) : list elt := x.
-
-  Definition min_elt (s : t) : option elt :=
-    match s with
-    | nil => None
-    | x :: _ => Some x
-    end.
-
-  Fixpoint max_elt (s : t) : option elt :=
-    match s with
-    | nil => None
-    | x :: nil => Some x
-    | _ :: l => max_elt l
-    end.
-
-  Definition choose := min_elt.
-
-  (** ** Proofs of set operation specifications. *)
-
-  Section ForNotations.
-
-  Notation Sort := (sort X.lt).
-  Notation Inf := (lelistA X.lt).
-  Notation In := (InA X.eq).
-
-  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
-  Definition Subset s s' := forall a : elt, In a s -> In a s'.
-  Definition Empty s := forall a : elt, ~ In a s.
-  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
-  Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.
-
-  Lemma mem_1 :
-   forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. 
-  Proof.
-  simple induction s; intros.
-  inversion H.
-  inversion_clear Hs.
-  inversion_clear H0.
-  simpl; elim_comp; trivial.
-  simpl; elim_comp_gt x a; auto.
-  apply Sort_Inf_In with l; trivial.
-  Qed.
-
-  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
-  Proof.
-  simple induction s.
-  intros; inversion H.
-  intros a l Hrec x.
-  simpl.
-  case (X.compare x a); intros; try discriminate; auto.
-  Qed.
-
-  Lemma add_Inf :
-   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
-  Proof.
-  simple induction s.  
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); intuition; inversion H0;
-   intuition.
-  Qed.
-  Hint Resolve add_Inf.
-  
-  Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s).
-  Proof.
-  simple induction s.
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs;
-   auto.
-  Qed. 
-
-  Lemma add_1 :
-   forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s).
-  Proof.
-  simple induction s. 
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); inversion_clear Hs; auto.
-  constructor; apply X.eq_trans with x; auto.
-  Qed.
-
-  Lemma add_2 :
-   forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s).
-  Proof.
-  simple induction s. 
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); intuition.
-  inversion_clear Hs; inversion_clear H0; auto.
-  Qed.
-
-  Lemma add_3 :
-   forall (s : t) (Hs : Sort s) (x y : elt),
-   ~ X.eq x y -> In y (add x s) -> In y s.
-  Proof.
-  simple induction s. 
-  simpl; inversion_clear 3; auto; order.
-  simpl; intros a l Hrec Hs x y; case (X.compare x a); intros;
-   inversion_clear H0; inversion_clear Hs; auto.
-  order.
-  constructor 2; apply Hrec with x; auto.
-  Qed.
-
-  Lemma remove_Inf :
-   forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s).
-  Proof.
-  simple induction s.  
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto.
-  inversion_clear Hs; apply Inf_lt with a; auto.
-  Qed.
-  Hint Resolve remove_Inf.
-
-  Lemma remove_sort :
-   forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s).
-  Proof.
-  simple induction s.
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto.
-  Qed. 
-
-  Lemma remove_1 :
-   forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s).
-  Proof.
-  simple induction s. 
-  simpl; red; intros; inversion H0.
-  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. 
-  inversion_clear H1.
-  order.
-  generalize (Sort_Inf_In H2 H3 H4); order.
-  generalize (Sort_Inf_In H2 H3 H1); order.
-  inversion_clear H1.
-  order.
-  apply (H H2 _ _ H0 H4).
-  Qed.
-
-  Lemma remove_2 :
-   forall (s : t) (Hs : Sort s) (x y : elt),
-   ~ X.eq x y -> In y s -> In y (remove x s).
-  Proof.
-  simple induction s. 
-  simpl; intuition.
-  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs;
-   inversion_clear H1; auto. 
-  destruct H0; apply X.eq_trans with a; auto.
-  Qed.
-
-  Lemma remove_3 :
-   forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s.
-  Proof.
-  simple induction s. 
-  simpl; intuition.
-  simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition.
-  inversion_clear Hs; inversion_clear H; auto.
-  constructor 2; apply Hrec with x; auto.
-  Qed.
-  
-  Lemma singleton_sort : forall x : elt, Sort (singleton x).
-  Proof.
-  unfold singleton; simpl; auto.
-  Qed.
-
-  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y.
-  Proof.
-  unfold singleton; simpl; intuition.
-  inversion_clear H; auto; inversion H0.
-  Qed. 
-
-  Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x).
-  Proof.
-  unfold singleton; simpl; auto.
-  Qed. 
-
-  Ltac DoubleInd :=
-    simple induction s;
-     [ simpl; auto; try solve [ intros; inversion H ]
-     | intros x l Hrec; simple induction s';
-        [ simpl; auto; try solve [ intros; inversion H ]
-        | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst;
-           simpl ] ].
-
-  Lemma union_Inf :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
-   Inf a s -> Inf a s' -> Inf a (union s s').
-  Proof.
-  DoubleInd.
-  intros i His His'; inversion_clear His; inversion_clear His'.
-  case (X.compare x x'); auto.
-  Qed.
-  Hint Resolve union_Inf.
- 
-  Lemma union_sort :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s').
-  Proof.
-  DoubleInd; case (X.compare x x'); intuition; constructor; auto.
-  apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto.
-  change (Inf x' (union (x :: l) l')); auto.
-  Qed.  
-  
-  Lemma union_1 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x (union s s') -> In x s \/ In x s'.
-  Proof.
-  DoubleInd; case (X.compare x x'); intuition; inversion_clear H; intuition.
-  elim (Hrec (x' :: l') H1 Hs' x0); intuition.
-  elim (Hrec l' H1 H5 x0); intuition.
-  elim (H0 x0); intuition.
-  Qed.
-
-  Lemma union_2 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x s -> In x (union s s').
-  Proof.
-  DoubleInd. 
-  intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto.
-  Qed.
-
-  Lemma union_3 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x s' -> In x (union s s').
-  Proof.
-  DoubleInd. 
-  intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition.
-  constructor; apply X.eq_trans with x'; auto.  
-  Qed.
-    
-  Lemma inter_Inf :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
-   Inf a s -> Inf a s' -> Inf a (inter s s').
-  Proof.
-  DoubleInd.
-  intros i His His'; inversion His; inversion His'; subst.
-  case (X.compare x x'); intuition. 
-  apply Inf_lt with x; auto.
-  apply H3; auto.
-  apply Inf_lt with x'; auto.
-  Qed.
-  Hint Resolve inter_Inf. 
-
-  Lemma inter_sort :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s').
-  Proof.
-  DoubleInd; case (X.compare x x'); auto.
-  constructor; auto.
-  apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto.
-  Qed.  
-  
-  Lemma inter_1 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x (inter s s') -> In x s.
-  Proof.
-  DoubleInd; case (X.compare x x'); intuition.
-  constructor 2; apply Hrec with (x'::l'); auto.
-  inversion_clear H; auto.
-  constructor 2; apply Hrec with l'; auto.
-  Qed.
-
-  Lemma inter_2 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x (inter s s') -> In x s'.
-  Proof.
-  DoubleInd; case (X.compare x x'); intuition; inversion_clear H.
-  constructor 1; apply X.eq_trans with x; auto.
-  constructor 2; auto.
-  Qed.
-
-  Lemma inter_3 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x s -> In x s' -> In x (inter s s').
-  Proof.
-  DoubleInd.
-  intros i His His'; elim (X.compare x x'); intuition.
-
-  inversion_clear His; auto.
-  generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) His'); order.
-
-  inversion_clear His; auto; inversion_clear His'; auto.
-  constructor; apply X.eq_trans with x'; auto.
-
-  change (In i (inter (x :: l) l')). 
-  inversion_clear His'; auto.
-  generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order.
-  Qed.
-
-  Lemma diff_Inf :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
-   Inf a s -> Inf a s' -> Inf a (diff s s').
-  Proof.
-  DoubleInd.
-  intros i His His'; inversion His; inversion His'.
-  case (X.compare x x'); intuition.
-  apply Hrec; trivial.
-  apply Inf_lt with x; auto.
-  apply Inf_lt with x'; auto.
-  apply H10; trivial.
-  apply Inf_lt with x'; auto.
-  Qed.
-  Hint Resolve diff_Inf. 
-
-  Lemma diff_sort :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s').
-  Proof.
-  DoubleInd; case (X.compare x x'); auto.
-  Qed.  
-  
-  Lemma diff_1 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x (diff s s') -> In x s.
-  Proof.
-  DoubleInd; case (X.compare x x'); intuition.
-  inversion_clear H; auto.
-  constructor 2; apply Hrec with (x'::l'); auto.
-  constructor 2; apply Hrec with l'; auto.
-  Qed.
-
-  Lemma diff_2 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x (diff s s') -> ~ In x s'.
-  Proof.
-  DoubleInd.
-  intros; intro Abs; inversion Abs. 
-  case (X.compare x x'); intuition.
-
-  inversion_clear H.
-  generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order.
-  apply Hrec with (x'::l') x0; auto.
-  
-  inversion_clear H3.
-  generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order.
-  apply Hrec with l' x0; auto.
-  
-  inversion_clear H3. 
-  generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order.
-  apply H0 with x0; auto.
-  Qed.
-
-  Lemma diff_3 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
-   In x s -> ~ In x s' -> In x (diff s s').
-  Proof.
-  DoubleInd.
-  intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto.
-  elim His'; constructor; apply X.eq_trans with x; auto.
-  Qed.  
-
-  Lemma equal_1 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
-   Equal s s' -> equal s s' = true.
-  Proof.
-  simple induction s; unfold Equal.
-  intro s'; case s'; auto.
-  simpl; intuition.
-  elim (H e); intros; assert (A : In e nil); auto; inversion A.
-  intros x l Hrec s'.
-  case s'.
-  intros; elim (H x); intros; assert (A : In x nil); auto; inversion A.
-  intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst.
-  simpl; case (X.compare x); intros; auto.
-
-  elim (H x); intros.
-  assert (A : In x (x' :: l')); auto; inversion_clear A.
-  order.
-  generalize (Sort_Inf_In H5 H6 H4); order.
-  
-  apply Hrec; intuition; elim (H a); intros.
-  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
-  generalize (Sort_Inf_In H1 H2 H0); order.
-  assert (A : In a (x :: l)); auto; inversion_clear A; auto.
-  generalize (Sort_Inf_In H5 H6 H0); order.
-
-  elim (H x'); intros.
-  assert (A : In x' (x :: l)); auto; inversion_clear A.
-  order.
-  generalize (Sort_Inf_In H1 H2 H4); order.
-  Qed.
-
-  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
-  Proof.
-  simple induction s; unfold Equal.
-  intro s'; case s'; intros.
-  intuition.
-  simpl in H; discriminate H.
-  intros x l Hrec s'.
-  case s'.
-  intros; simpl in H; discriminate.
-  intros x' l'; simpl; case (X.compare x); intros; auto; try discriminate.
-  elim (Hrec l' H a); intuition; inversion_clear H2; auto.
-  constructor; apply X.eq_trans with x; auto.
-  constructor; apply X.eq_trans with x'; auto.
-  Qed.  
-  
-  Lemma subset_1 :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
-   Subset s s' -> subset s s' = true.
-  Proof.
-  intros s s'; generalize s' s; clear s s'.
-  simple induction s'; unfold Subset.
-  intro s; case s; auto.
-  intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. 
-  intros x' l' Hrec s; case s.
-  simpl; auto.
-  intros x l Hs Hs'; inversion Hs; inversion Hs'; subst.
-  simpl; case (X.compare x); intros; auto.
-
-  assert (A : In x (x' :: l')); auto; inversion_clear A.
-  order.
-  generalize (Sort_Inf_In H5 H6 H0); order.
-  
-  apply Hrec; intuition.
-  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
-  generalize (Sort_Inf_In H1 H2 H0); order.
-
-  apply Hrec; intuition.
-  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
-  inversion_clear H0. 
-  order.
-  generalize (Sort_Inf_In H1 H2 H4); order.
-  Qed.
-
-  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
-  Proof.
-  intros s s'; generalize s' s; clear s s'.
-  simple induction s'; unfold Subset.
-  intro s; case s; auto.
-  simpl; intros; discriminate H.
-  intros x' l' Hrec s; case s.
-  intros; inversion H0.
-  intros x l; simpl; case (X.compare x); intros; auto.
-  discriminate H.  
-  inversion_clear H0.
-  constructor; apply X.eq_trans with x; auto.
-  constructor 2; apply Hrec with l; auto.
-  constructor 2; apply Hrec with (x::l); auto.
-  Qed.  
-  
-  Lemma empty_sort : Sort empty.
-  Proof.
-  unfold empty; constructor.
-  Qed.
-
-  Lemma empty_1 : Empty empty.
-  Proof.
-  unfold Empty, empty; intuition; inversion H.
-  Qed. 
-
-  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
-  Proof.
-  unfold Empty; intro s; case s; simpl; intuition.
-  elim (H e); auto.
-  Qed.
-  
-  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. 
-  Proof.
-  unfold Empty; intro s; case s; simpl; intuition;
-   inversion H0.
-  Qed.
-
-  Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
-  Proof.
-  unfold elements; auto.
-  Qed.
-
-  Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
-  Proof. 
-  unfold elements; auto.
-  Qed.
- 
-  Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s).  
-  Proof. 
-  unfold elements; auto.
-  Qed.
-
-  Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s).  
-  Proof. 
-  unfold elements; auto.
-  Qed.
-
-  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. 
-  Proof.
-  intro s; case s; simpl; intros; inversion H; auto.
-  Qed.  
-
-  Lemma min_elt_2 :
-   forall (s : t) (Hs : Sort s) (x y : elt),
-   min_elt s = Some x -> In y s -> ~ X.lt y x. 
-  Proof.
-  simple induction s; simpl.
-  intros; inversion H.
-  intros a l; case l; intros; inversion H0; inversion_clear H1; subst. 
-  order.
-  inversion H2.
-  order.
-  inversion_clear Hs.
-  inversion_clear H3.
-  generalize (H H1 e y (refl_equal (Some e)) H2); order.
-  Qed. 
-
-  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
-  Proof.
-  unfold Empty; intro s; case s; simpl; intuition;
-   inversion H; inversion H0.
-  Qed.
-
-  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. 
-  Proof. 
-  simple induction s; simpl.
-  intros; inversion H.
-  intros x l; case l; simpl.
-  intuition.
-  inversion H0; auto.
-  intros.
-  constructor 2; apply (H _ H0).
-  Qed.
- 
-  Lemma max_elt_2 :
-   forall (s : t) (Hs : Sort s) (x y : elt),
-   max_elt s = Some x -> In y s -> ~ X.lt x y. 
-  Proof.
-  simple induction s; simpl.
-  intros; inversion H.
-  intros x l; case l; simpl.
-  intuition.
-  inversion H0; subst.
-  inversion_clear H1.
-  order.
-  inversion H3.
-  intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1.
-  assert (In e (e::l0)) by auto.
-  generalize (H H2 x0 e H0 H1); order.
-  generalize (H H2 x0 y H0 H3); order.
-  Qed. 
-
-  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
-  Proof.
-  unfold Empty; simple induction s; simpl.
-  red; intros; inversion H0.
-  intros x l; case l; simpl; intros.
-  inversion H0.
-  elim (H H0 e); auto.
-  Qed.
-
-  Definition choose_1 :
-    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1.
-
-  Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3.
-
-  Lemma choose_3: forall s s', Sort s -> Sort s' -> forall x x',
-   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
-  Proof.
-   unfold choose, Equal; intros s s' Hs Hs' x x' Hx Hx' H.
-   assert (~X.lt x x').
-    apply min_elt_2 with s'; auto.
-    rewrite <-H; auto using min_elt_1.
-   assert (~X.lt x' x).
-    apply min_elt_2 with s; auto.
-    rewrite H; auto using min_elt_1.
-   destruct (X.compare x x'); intuition.
-  Qed.
-   
-  Lemma fold_1 :
-   forall (s : t) (Hs : Sort s) (A : Type) (i : A) (f : elt -> A -> A),
-   fold f s i = fold_left (fun a e => f e a) (elements s) i.
-  Proof.
-  induction s.
-  simpl; trivial.
-  intros.
-  inversion_clear Hs.
-  simpl; auto.
-  Qed.
-
-  Lemma cardinal_1 :
-   forall (s : t) (Hs : Sort s),
-   cardinal s = length (elements s).
-  Proof.
-  auto.
-  Qed.
-
-  Lemma filter_Inf :
-   forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool),
-   Inf x s -> Inf x (filter f s).
-  Proof.
-  simple induction s; simpl.
-  intuition.  
-  intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha.
-  case (f x). 
-  constructor; auto.
-  apply Hrec; auto.
-  apply Inf_lt with x; auto.
-  Qed.
-
-  Lemma filter_sort :
-   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s).
-  Proof.
-  simple induction s; simpl.
-  auto.
-  intros x l Hrec Hs f; inversion_clear Hs.
-  case (f x); auto.
-  constructor; auto.
-  apply filter_Inf; auto. 
-  Qed.
-
-  Lemma filter_1 :
-   forall (s : t) (x : elt) (f : elt -> bool),
-   compat_bool X.eq f -> In x (filter f s) -> In x s.
-  Proof.
-  simple induction s; simpl.
-  intros; inversion H0.
-  intros x l Hrec a f Hf.
-  case (f x); simpl.
-  inversion_clear 1.
-  constructor; auto.
-  constructor 2; apply (Hrec a f Hf); trivial.
-  constructor 2; apply (Hrec a f Hf); trivial.
-  Qed.
-
-   Lemma filter_2 :
-    forall (s : t) (x : elt) (f : elt -> bool),
-    compat_bool X.eq f -> In x (filter f s) -> f x = true.   
-   Proof.
-  simple induction s; simpl.
-  intros; inversion H0.
-  intros x l Hrec a f Hf.
-  generalize (Hf x); case (f x); simpl; auto.
-  inversion_clear 2; auto.
-  symmetry; auto.
-  Qed.
- 
-  Lemma filter_3 :
-   forall (s : t) (x : elt) (f : elt -> bool),
-   compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s).     
-  Proof.
-  simple induction s; simpl.
-  intros; inversion H0.
-  intros x l Hrec a f Hf.
-  generalize (Hf x); case (f x); simpl.
-  inversion_clear 2; auto.
-  inversion_clear 2; auto.
-  rewrite <- (H a (X.eq_sym H1)); intros; discriminate.
-  Qed.
-
-  Lemma for_all_1 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f ->
-   For_all (fun x => f x = true) s -> for_all f s = true.
-  Proof. 
-  simple induction s; simpl; auto; unfold For_all.
-  intros x l Hrec f Hf. 
-  generalize (Hf x); case (f x); simpl.
-  auto.
-  intros; rewrite (H x); auto.
-  Qed.
-
-  Lemma for_all_2 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f ->
-   for_all f s = true -> For_all (fun x => f x = true) s.
-  Proof. 
-  simple induction s; simpl; auto; unfold For_all.
-  intros; inversion H1.
-  intros x l Hrec f Hf. 
-  intros A a; intros. 
-  assert (f x = true).
-   generalize A; case (f x); auto.
-  rewrite H0 in A; simpl in A.
-  inversion_clear H; auto.
-  rewrite (Hf a x); auto.
-  Qed.
-
-  Lemma exists_1 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
-  Proof.
-  simple induction s; simpl; auto; unfold Exists.
-  intros.
-  elim H0; intuition. 
-  inversion H2.
-  intros x l Hrec f Hf. 
-  generalize (Hf x); case (f x); simpl.
-  auto.
-  destruct 2 as [a (A1,A2)].
-  inversion_clear A1.
-  rewrite <- (H a (X.eq_sym H0)) in A2; discriminate.
-  apply Hrec; auto.
-  exists a; auto.
-  Qed.
-
-  Lemma exists_2 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
-  Proof. 
-  simple induction s; simpl; auto; unfold Exists.
-  intros; discriminate.
-  intros x l Hrec f Hf.
-  case_eq (f x); intros.
-  exists x; auto.
-  destruct (Hrec f Hf H0) as [a (A1,A2)].
-  exists a; auto.
-  Qed.
-
-  Lemma partition_Inf_1 :
-   forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
-   Inf x s -> Inf x (fst (partition f s)).
-  Proof.
-  simple induction s; simpl.
-  intuition.  
-  intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
-  generalize (Hrec H f a).
-  case (f x); case (partition f l); simpl.
-  auto.
-  intros; apply H2; apply Inf_lt with x; auto.
-  Qed.
-
-  Lemma partition_Inf_2 :
-   forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
-   Inf x s -> Inf x (snd (partition f s)).
-  Proof.
-  simple induction s; simpl.
-  intuition.  
-  intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
-  generalize (Hrec H f a).
-  case (f x); case (partition f l); simpl.
-  intros; apply H2; apply Inf_lt with x; auto.
-  auto.
-  Qed.
-
-  Lemma partition_sort_1 :
-   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (fst (partition f s)).
-  Proof.
-  simple induction s; simpl.
-  auto.
-  intros x l Hrec Hs f; inversion_clear Hs.
-  generalize (Hrec H f); generalize (partition_Inf_1 H f).
-  case (f x); case (partition f l); simpl; auto.
-  Qed.
-  
-  Lemma partition_sort_2 :
-   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)).
-  Proof.
-  simple induction s; simpl.
-  auto.
-  intros x l Hrec Hs f; inversion_clear Hs.
-  generalize (Hrec H f); generalize (partition_Inf_2 H f).
-  case (f x); case (partition f l); simpl; auto.
-  Qed.
-
-  Lemma partition_1 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s).
-  Proof.
-  simple induction s; simpl; auto; unfold Equal.
-  split; auto.
-  intros x l Hrec f Hf.
-  generalize (Hrec f Hf); clear Hrec.
-  destruct (partition f l) as [s1 s2]; simpl; intros.
-  case (f x); simpl; auto.
-  split; inversion_clear 1; auto.
-  constructor 2; rewrite <- H; auto.
-  constructor 2; rewrite H; auto.
-  Qed.
-   
-  Lemma partition_2 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f ->
-   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
-  Proof.
-  simple induction s; simpl; auto; unfold Equal.
-  split; auto.
-  intros x l Hrec f Hf. 
-  generalize (Hrec f Hf); clear Hrec.
-  destruct (partition f l) as [s1 s2]; simpl; intros.
-  case (f x); simpl; auto.
-  split; inversion_clear 1; auto.
-  constructor 2; rewrite <- H; auto.
-  constructor 2; rewrite H; auto.
-  Qed.
- 
-  Definition eq : t -> t -> Prop := Equal.
-
-  Lemma eq_refl : forall s : t, eq s s. 
-  Proof. 
-  unfold eq, Equal; intuition.
-  Qed.
-
-  Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
-  Proof. 
-  unfold eq, Equal; intros; destruct (H a); intuition.
-  Qed.
-
-  Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
-  Proof. 
-  unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition.
-  Qed.
-
-  Inductive lt : t -> t -> Prop :=
-    | lt_nil : forall (x : elt) (s : t), lt nil (x :: s)
-    | lt_cons_lt :
-        forall (x y : elt) (s s' : t), X.lt x y -> lt (x :: s) (y :: s')
-    | lt_cons_eq :
-        forall (x y : elt) (s s' : t),
-        X.eq x y -> lt s s' -> lt (x :: s) (y :: s').
-  Hint Constructors lt.
-   
-  Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''.
-  Proof. 
-  intros s s' s'' H; generalize s''; clear s''; elim H.
-  intros x l s'' H'; inversion_clear H'; auto.
-  intros x x' l l' E s'' H'; inversion_clear H'; auto. 
-  constructor; apply X.lt_trans with x'; auto.
-  constructor; apply lt_eq with x'; auto.
-  intros.
-  inversion_clear H3.
-  constructor; apply eq_lt with y; auto.
-  constructor 3; auto; apply X.eq_trans with y; auto.  
-  Qed. 
-
-  Lemma lt_not_eq :
-   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'.
-  Proof. 
-  unfold eq, Equal. 
-  intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro.
-  elim (H0 x); intros.
-  assert (X : In x nil); auto; inversion X.
-  inversion_clear Hs; inversion_clear Hs'.
-  elim (H1 x); intros. 
-  assert (X : In x (y :: s'0)); auto; inversion_clear X.
-  order.
-  generalize (Sort_Inf_In H4 H5 H8); order.
-  inversion_clear Hs; inversion_clear Hs'.
-  elim H2; auto; split; intros.
-  generalize (Sort_Inf_In H4 H5 H8); intros.
-  elim (H3 a); intros.
-  assert (X : In a (y :: s'0)); auto; inversion_clear X; auto.
-  order.
-  generalize (Sort_Inf_In H6 H7 H8); intros.
-  elim (H3 a); intros.
-  assert (X : In a (x :: s0)); auto; inversion_clear X; auto.
-  order.
-  Qed.
-
-  Definition compare :
-    forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'.
-  Proof.
-  simple induction s.
-  intros; case s'. 
-  constructor 2; apply eq_refl. 
-  constructor 1; auto.
-  intros a l Hrec s'; case s'.
-  constructor 3; auto.
-  intros a' l' Hs Hs'.
-  case (X.compare a a'); [ constructor 1 | idtac | constructor 3 ]; auto.
-  elim (Hrec l');
-   [ constructor 1
-   | constructor 2
-   | constructor 3
-   | inversion Hs
-   | inversion Hs' ]; auto.
-  generalize e; unfold eq, Equal; intuition; inversion_clear H.
-  constructor; apply X.eq_trans with a; auto.
-  destruct (e1 a0); auto.
-  constructor; apply X.eq_trans with a'; auto.
-  destruct (e1 a0); auto.
-  Defined.
-
-  End ForNotations. 
-  Hint Constructors lt.
-
-End Raw.
-
-(** * Encapsulation
-
-   Now, in order to really provide a functor implementing [S], we 
-   need to encapsulate everything into a type of strictly ordered lists. *)
+Require FSetCompat MSetList Orders OrdersAlt.
 
 Module Make (X: OrderedType) <: S with Module E := X.
-
- Module Raw := Raw X. 
- Module E := X.
-
- Record slist := {this :> Raw.t; sorted : sort E.lt this}.
- Definition t := slist. 
- Definition elt := E.t.
- 
- Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
- Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
- Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
- Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
- Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x.
- Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x.
-
- Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
- Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_sort (sorted s) x).
- Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_sort (sorted s) x).
- Definition singleton (x : elt) : t  := Build_slist (Raw.singleton_sort x).
- Definition union (s s' : t) : t :=
-   Build_slist (Raw.union_sort (sorted s) (sorted s')). 
- Definition inter (s s' : t) : t :=
-   Build_slist (Raw.inter_sort (sorted s) (sorted s')). 
- Definition diff (s s' : t) : t :=
-   Build_slist (Raw.diff_sort (sorted s) (sorted s')). 
- Definition equal (s s' : t) : bool := Raw.equal s s'. 
- Definition subset (s s' : t) : bool := Raw.subset s s'.
- Definition empty : t := Build_slist Raw.empty_sort.
- Definition is_empty (s : t) : bool := Raw.is_empty s.
- Definition elements (s : t) : list elt := Raw.elements s.
- Definition min_elt (s : t) : option elt := Raw.min_elt s.
- Definition max_elt (s : t) : option elt := Raw.max_elt s.
- Definition choose (s : t) : option elt  := Raw.choose s.
- Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. 
- Definition cardinal (s : t) : nat := Raw.cardinal s.
- Definition filter (f : elt -> bool) (s : t) : t :=
-   Build_slist (Raw.filter_sort (sorted s) f).
- Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
- Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
- Definition partition (f : elt -> bool) (s : t) : t * t :=
-   let p := Raw.partition f s in
-   (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f),
-   Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)).
- Definition eq (s s' : t) : Prop := Raw.eq s s'.
- Definition lt (s s' : t) : Prop := Raw.lt s s'.
-
- Section Spec. 
-  Variable s s' s'': t.
-  Variable x y : elt.
-
-  Lemma In_1 : E.eq x y -> In x s -> In y s. 
-  Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed.
- 
-  Lemma mem_1 : In x s -> mem x s = true.
-  Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed.
-  Lemma mem_2 : mem x s = true -> In x s. 
-  Proof. exact (fun H => Raw.mem_2 H). Qed.
- 
-  Lemma equal_1 : Equal s s' -> equal s s' = true.
-  Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed.
-  Lemma equal_2 : equal s s' = true -> Equal s s'.
-  Proof. exact (fun H => Raw.equal_2 H). Qed.
-
-  Lemma subset_1 : Subset s s' -> subset s s' = true.
-  Proof. exact (Raw.subset_1 s.(sorted) s'.(sorted)). Qed.
-  Lemma subset_2 : subset s s' = true -> Subset s s'.
-  Proof. exact (fun H => Raw.subset_2 H). Qed.
-
-  Lemma empty_1 : Empty empty.
-  Proof. exact Raw.empty_1. Qed.
-
-  Lemma is_empty_1 : Empty s -> is_empty s = true. 
-  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
-  Lemma is_empty_2 : is_empty s = true -> Empty s.
-  Proof. exact (fun H => Raw.is_empty_2 H). Qed.
- 
-  Lemma add_1 : E.eq x y -> In y (add x s).
-  Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed.
-  Lemma add_2 : In y s -> In y (add x s).
-  Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed.
-  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
-  Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed.
-
-  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
-  Proof. exact (fun H => Raw.remove_1 s.(sorted) H). Qed.
-  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
-  Proof. exact (fun H H' => Raw.remove_2 s.(sorted) H H'). Qed.
-  Lemma remove_3 : In y (remove x s) -> In y s.
-  Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed.
-
-  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
-  Proof. exact (fun H => Raw.singleton_1 H). Qed.
-  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
-  Proof. exact (fun H => Raw.singleton_2 H). Qed.
-
-  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
-  Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed.
-  Lemma union_2 : In x s -> In x (union s s'). 
-  Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed.
-  Lemma union_3 : In x s' -> In x (union s s').
-  Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed.
-
-  Lemma inter_1 : In x (inter s s') -> In x s.
-  Proof. exact (fun H => Raw.inter_1 s.(sorted) s'.(sorted) H). Qed.
-  Lemma inter_2 : In x (inter s s') -> In x s'.
-  Proof. exact (fun H => Raw.inter_2 s.(sorted) s'.(sorted) H). Qed.
-  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
-  Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed.
-
-  Lemma diff_1 : In x (diff s s') -> In x s. 
-  Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed.
-  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
-  Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed.
-  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
-  Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed.
- 
-  Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
-      fold f s i = fold_left (fun a e => f e a) (elements s) i.
-  Proof. exact (Raw.fold_1 s.(sorted)). Qed.
-
-  Lemma cardinal_1 : cardinal s = length (elements s).
-  Proof. exact (Raw.cardinal_1 s.(sorted)). Qed.
-
-  Section Filter.
-  
-  Variable f : elt -> bool.
-
-  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
-  Proof. exact (@Raw.filter_1 s x f). Qed.
-  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
-  Proof. exact (@Raw.filter_2 s x f). Qed.
-  Lemma filter_3 :
-      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
-  Proof. exact (@Raw.filter_3 s x f). Qed.
-
-  Lemma for_all_1 :
-      compat_bool E.eq f ->
-      For_all (fun x => f x = true) s -> for_all f s = true.
-  Proof. exact (@Raw.for_all_1 s f). Qed.
-  Lemma for_all_2 :
-      compat_bool E.eq f ->
-      for_all f s = true -> For_all (fun x => f x = true) s.
-  Proof. exact (@Raw.for_all_2 s f). Qed.
-
-  Lemma exists_1 :
-      compat_bool E.eq f ->
-      Exists (fun x => f x = true) s -> exists_ f s = true.
-  Proof. exact (@Raw.exists_1 s f). Qed.
-  Lemma exists_2 :
-      compat_bool E.eq f ->
-      exists_ f s = true -> Exists (fun x => f x = true) s.
-  Proof. exact (@Raw.exists_2 s f). Qed.
-
-  Lemma partition_1 :
-      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
-  Proof. exact (@Raw.partition_1 s f). Qed.
-  Lemma partition_2 :
-      compat_bool E.eq f ->
-      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
-  Proof. exact (@Raw.partition_2 s f). Qed.
-
-  End Filter.
-
-  Lemma elements_1 : In x s -> InA E.eq x (elements s).
-  Proof. exact (fun H => Raw.elements_1 H). Qed.
-  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
-  Proof. exact (fun H => Raw.elements_2 H). Qed.
-  Lemma elements_3 : sort E.lt (elements s).
-  Proof. exact (Raw.elements_3 s.(sorted)). Qed.
-  Lemma elements_3w : NoDupA E.eq (elements s).
-  Proof. exact (Raw.elements_3w s.(sorted)). Qed.
-
-  Lemma min_elt_1 : min_elt s = Some x -> In x s. 
-  Proof. exact (fun H => Raw.min_elt_1 H). Qed.
-  Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. 
-  Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed.
-  Lemma min_elt_3 : min_elt s = None -> Empty s.
-  Proof. exact (fun H => Raw.min_elt_3 H). Qed.
-
-  Lemma max_elt_1 : max_elt s = Some x -> In x s. 
-  Proof. exact (fun H => Raw.max_elt_1 H). Qed.
-  Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. 
-  Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed.
-  Lemma max_elt_3 : max_elt s = None -> Empty s.
-  Proof. exact (fun H => Raw.max_elt_3 H). Qed.
-
-  Lemma choose_1 : choose s = Some x -> In x s.
-  Proof. exact (fun H => Raw.choose_1 H). Qed.
-  Lemma choose_2 : choose s = None -> Empty s.
-  Proof. exact (fun H => Raw.choose_2 H). Qed.
-  Lemma choose_3 : choose s = Some x -> choose s' = Some y -> 
-   Equal s s' -> E.eq x y.
-  Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed.
-
-  Lemma eq_refl : eq s s.
-  Proof. exact (Raw.eq_refl s). Qed.
-  Lemma eq_sym : eq s s' -> eq s' s.
-  Proof. exact (@Raw.eq_sym s s'). Qed.
-  Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
-  Proof. exact (@Raw.eq_trans s s' s''). Qed.
-
-  Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
-  Proof. exact (@Raw.lt_trans s s' s''). Qed.
-  Lemma lt_not_eq : lt s s' -> ~ eq s s'.
-  Proof. exact (Raw.lt_not_eq s.(sorted) s'.(sorted)). Qed.
-
-  Definition compare : Compare lt eq s s'.
-  Proof.
-  elim (Raw.compare s.(sorted) s'.(sorted));
-   [ constructor 1 | constructor 2 | constructor 3 ]; 
-   auto. 
-  Defined.
-
-  Definition eq_dec : { eq s s' } + { ~ eq s s' }.
-  Proof.
-  change eq with Equal.
-  case_eq (equal s s'); intro H; [left | right].
-  apply equal_2; auto.
-  intro H'; rewrite equal_1 in H; auto; discriminate.
-  Defined.
-
- End Spec.
-
+ Module X' := OrdersAlt.Update_OT X.
+ Module MSet := MSetList.Make X'.
+ Include FSetCompat.Backport_Sets X MSet.
 End Make.
diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v
new file mode 100644
index 00000000..e5d55ac5
--- /dev/null
+++ b/theories/FSets/FSetPositive.v
@@ -0,0 +1,1173 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** Efficient implementation of [FSetInterface.S] for positive keys,
+    inspired from the [FMapPositive] module.
+
+   This module was adapted by Alexandre Ren, Damien Pous, and Thomas
+   Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive]
+   module of Pierre Letouzey and Jean-Christophe Filliâtre, which in
+   turn comes from the [FMap] framework of a work by Xavier Leroy and
+   Sandrine Blazy (used for building certified compilers).
+*)
+
+Require Import Bool BinPos OrderedType OrderedTypeEx FSetInterface.
+
+Set Implicit Arguments.
+
+Local Open Scope lazy_bool_scope.
+Local Open Scope positive_scope.
+
+Local Unset Elimination Schemes.
+Local Unset Case Analysis Schemes.
+Local Unset Boolean Equality Schemes.
+
+
+Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
+
+  Module E:=PositiveOrderedTypeBits.
+
+  Definition elt := positive.
+
+  Inductive tree :=
+    | Leaf : tree
+    | Node : tree -> bool -> tree -> tree.
+
+  Scheme tree_ind := Induction for tree Sort Prop.
+
+  Definition t := tree.
+
+  Definition empty := Leaf.
+
+  Fixpoint is_empty (m : t) : bool :=
+   match m with
+    | Leaf => true
+    | Node l b r => negb b &&& is_empty l &&& is_empty r
+   end.
+
+  Fixpoint mem (i : positive) (m : t) : bool :=
+    match m with
+    | Leaf => false
+    | Node l o r =>
+        match i with
+        | 1 => o
+        | i~0 => mem i l
+        | i~1 => mem i r
+        end
+    end.
+
+  Fixpoint add (i : positive) (m : t) : t :=
+    match m with
+    | Leaf =>
+        match i with
+        | 1 => Node Leaf true Leaf
+        | i~0 => Node (add i Leaf) false Leaf
+        | i~1 => Node Leaf false (add i Leaf)
+        end
+    | Node l o r =>
+        match i with
+        | 1 => Node l true r
+        | i~0 => Node (add i l) o r
+        | i~1 => Node l o (add i r)
+        end
+    end.
+
+  Definition singleton i := add i empty.
+
+  (** helper function to avoid creating empty trees that are not leaves *)
+
+  Definition node l (b: bool) r :=
+    if b then Node l b r else
+     match l,r with
+       | Leaf,Leaf => Leaf
+       | _,_ => Node l false r end.
+
+  Fixpoint remove (i : positive) (m : t) : t :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match i with
+          | 1 => node l false r
+          | i~0 => node (remove i l) o r
+          | i~1 => node l o (remove i r)
+        end
+    end.
+
+  Fixpoint union (m m': t) :=
+    match m with
+      | Leaf => m'
+      | Node l o r =>
+        match m' with
+          | Leaf => m
+          | Node l' o' r' => Node (union l l') (o||o') (union r r')
+        end
+    end.
+
+  Fixpoint inter (m m': t) :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match m' with
+          | Leaf => Leaf
+          | Node l' o' r' => node (inter l l') (o&&o') (inter r r')
+        end
+    end.
+
+  Fixpoint diff (m m': t) :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match m' with
+          | Leaf => m
+          | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
+        end
+    end.
+
+  Fixpoint equal (m m': t): bool :=
+    match m with
+      | Leaf => is_empty m'
+      | Node l o r =>
+        match m' with
+          | Leaf => is_empty m
+          | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
+        end
+    end.
+
+  Fixpoint subset (m m': t): bool :=
+    match m with
+      | Leaf => true
+      | Node l o r =>
+        match m' with
+          | Leaf => is_empty m
+          | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
+        end
+    end.
+
+  (** reverses [y] and concatenate it with [x] *)
+
+  Fixpoint rev_append y x :=
+    match y with
+      | 1 => x
+      | y~1 => rev_append y x~1
+      | y~0 => rev_append y x~0
+    end.
+  Infix "@" := rev_append (at level 60).
+  Definition rev x := x@1.
+
+  Section Fold.
+
+    Variables B : Type.
+    Variable f : positive -> B -> B.
+
+    (** the additional argument, [i], records the current path, in
+       reverse order (this should be more efficient: we reverse this argument
+       only at present nodes only, rather than at each node of the tree).
+       we also use this convention in all functions below
+     *)
+
+    Fixpoint xfold (m : t) (v : B) (i : positive) :=
+      match m with
+        | Leaf => v
+        | Node l true r =>
+          xfold r (f (rev i) (xfold l v i~0)) i~1
+        | Node l false r =>
+          xfold r (xfold l v i~0) i~1
+      end.
+    Definition fold m i := xfold m i 1.
+
+  End Fold.
+
+  Section Quantifiers.
+
+    Variable f : positive -> bool.
+
+    Fixpoint xforall (m : t) (i : positive) :=
+      match m with
+        | Leaf => true
+        | Node l o r =>
+          (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
+      end.
+    Definition for_all m := xforall m 1.
+
+    Fixpoint xexists (m : t) (i : positive) :=
+      match m with
+        | Leaf => false
+        | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
+      end.
+    Definition exists_ m := xexists m 1.
+
+    Fixpoint xfilter (m : t) (i : positive) :=
+      match m with
+        | Leaf => Leaf
+        | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
+      end.
+    Definition filter m := xfilter m 1.
+
+    Fixpoint xpartition (m : t) (i : positive) :=
+      match m with
+        | Leaf => (Leaf,Leaf)
+        | Node l o r =>
+          let (lt,lf) := xpartition l i~0 in
+          let (rt,rf) := xpartition r i~1 in
+             if o then
+               let fi := f (rev i) in
+                 (node lt fi rt, node lf (negb fi) rf)
+             else
+                 (node lt false rt, node lf false rf)
+      end.
+    Definition partition m := xpartition m 1.
+
+  End Quantifiers.
+
+  (** uses [a] to accumulate values rather than doing a lot of concatenations *)
+
+  Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
+    match m with
+      | Leaf => a
+      | Node l false r => xelements l i~0 (xelements r i~1 a)
+      | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
+    end.
+
+  Definition elements (m : t) := xelements m 1 nil.
+
+  Fixpoint cardinal (m : t) : nat :=
+    match m with
+      | Leaf => O
+      | Node l false r => (cardinal l + cardinal r)%nat
+      | Node l true r => S (cardinal l + cardinal r)
+    end.
+
+  Definition omap (f: elt -> elt) x :=
+    match x with
+      | None => None
+      | Some i => Some (f i)
+    end.
+
+  (** would it be more efficient to use a path like in the above functions ? *)
+
+  Fixpoint choose (m: t) :=
+    match m with
+      | Leaf => None
+      | Node l o r => if o then Some 1 else
+        match choose l with
+          | None => omap xI (choose r)
+          | Some i => Some i~0
+        end
+    end.
+
+  Fixpoint min_elt (m: t) :=
+    match m with
+      | Leaf => None
+      | Node l o r =>
+        match min_elt l with
+          | None => if o then Some 1 else omap xI (min_elt r)
+          | Some i => Some i~0
+        end
+    end.
+
+  Fixpoint max_elt (m: t) :=
+    match m with
+      | Leaf => None
+      | Node l o r =>
+        match max_elt r with
+          | None => if o then Some 1 else omap xO (max_elt l)
+          | Some i => Some i~1
+        end
+    end.
+
+  (** lexicographic product, defined using a notation to keep things lazy *)
+
+  Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.
+
+  Definition compare_bool a b :=
+    match a,b with
+      | false, true => Lt
+      | true, false => Gt
+      | _,_ => Eq
+    end.
+
+  Fixpoint compare_fun (m m': t): comparison :=
+    match m,m' with
+      | Leaf,_ => if is_empty m' then Eq else Lt
+      | _,Leaf => if is_empty m then Eq else Gt
+      | Node l o r,Node l' o' r' =>
+        lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r'))
+    end.
+
+
+  Definition In i t := mem i t = true.
+  Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
+  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
+
+  Definition eq := Equal.
+  Definition lt m m' := compare_fun m m' = Lt.
+
+  (** Specification of [In] *)
+
+  Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s.
+  Proof. intros s x y ->. trivial. Qed.
+
+  (** Specification of [eq] *)
+
+  Lemma eq_refl: forall s, eq s s.
+  Proof. unfold eq, Equal. reflexivity. Qed.
+
+  Lemma eq_sym: forall s s', eq s s' -> eq s' s.
+  Proof. unfold eq, Equal. intros. symmetry. trivial. Qed.
+
+  Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
+  Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed.
+
+  (** Specification of [mem] *)
+
+  Lemma mem_1: forall s x, In x s -> mem x s = true.
+  Proof. unfold In. trivial. Qed.
+
+  Lemma mem_2: forall s x, mem x s = true -> In x s.
+  Proof. unfold In. trivial. Qed.
+
+  (** Additional lemmas for mem  *)
+
+  Lemma mem_Leaf: forall x, mem x Leaf = false.
+  Proof. destruct x; trivial. Qed.
+
+  (** Specification of [empty] *)
+
+  Lemma empty_1 : Empty empty.
+  Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.
+
+  (** Specification of node  *)
+
+  Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
+  Proof.
+    intros x l o r.
+    case o; trivial.
+    destruct l; trivial.
+    destruct r; trivial.
+    symmetry. destruct x.
+      apply mem_Leaf.
+      apply mem_Leaf.
+      reflexivity.
+  Qed.
+  Local Opaque node.
+
+  (** Specification of [is_empty] *)
+
+  Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true.
+  Proof.
+    unfold Empty, In.
+    induction s as [|l IHl o r IHr]; simpl.
+      setoid_rewrite mem_Leaf. firstorder.
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr.
+      destruct o; simpl; split.
+        intro H. elim (H 1). reflexivity.
+        intuition discriminate.
+        intro H. split. split. reflexivity.
+          intro a. apply (H a~0).
+          intro a. apply (H a~1).
+        intros H [a|a|]; apply H || intro; discriminate.
+  Qed.
+
+  Lemma is_empty_1: forall s, Empty s -> is_empty s = true.
+  Proof. intro. rewrite is_empty_spec. trivial. Qed.
+
+  Lemma is_empty_2: forall s, is_empty s = true -> Empty s.
+  Proof. intro. rewrite is_empty_spec. trivial. Qed.
+
+  (** Specification of [subset] *)
+
+  Lemma subset_Leaf_s: forall s, Leaf [<=] s.
+  Proof. intros s i Hi. elim (empty_1 Hi). Qed.
+
+  Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
+      split; intros. reflexivity. apply subset_Leaf_s.
+
+      split; intros. reflexivity. apply subset_Leaf_s.
+
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec.
+      destruct o; simpl.
+        split.
+          intro H. elim (@empty_1 1). apply H. reflexivity.
+          intuition discriminate.
+        split; intro H.
+          split. split. reflexivity.
+          unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption.
+          unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption.
+          destruct H as [[_ Hl] Hr].
+          intros [i|i|] Hi.
+            elim (Hr i Hi).
+            elim (Hl i Hi).
+            discriminate.
+
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear.
+      destruct o; simpl.
+       split; intro H.
+         split. split.
+          destruct o'; trivial.
+          specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
+          intros i Hi. apply (H i~0). apply Hi.
+          intros i Hi. apply (H i~1). apply Hi.
+         destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
+          intros i Hi. destruct i.
+            apply (Hr i). assumption.
+            apply (Hl i). assumption.
+            assumption.
+       split; intros.
+         split. split. reflexivity.
+           intros i Hi. apply (H i~0). apply Hi.
+           intros i Hi. apply (H i~1). apply Hi.
+           intros i Hi. destruct i; destruct H as [[H Hl] Hr].
+             apply (Hr i). assumption.
+             apply (Hl i). assumption.
+             discriminate Hi.
+  Qed.
+
+
+  Lemma subset_1: forall s s', Subset s s' -> subset s s' = true.
+  Proof. intros s s'. apply -> subset_spec; trivial. Qed.
+
+  Lemma subset_2: forall s s', subset s s' = true -> Subset s s'.
+  Proof. intros s s'. apply <- subset_spec; trivial. Qed.
+
+  (** Specification of [equal] (via subset) *)
+
+  Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
+  Proof.
+    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
+      destruct o. reflexivity. rewrite andb_comm. reflexivity.
+      rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
+       rewrite 7andb_true_iff, eqb_true_iff.
+      rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
+       destruct o'; reflexivity.
+       destruct o'; reflexivity.
+       destruct o; auto. destruct o'; trivial.
+  Qed.
+
+  Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true.
+  Proof.
+    intros. rewrite equal_subset. rewrite andb_true_iff.
+    rewrite <- 2subset_spec. unfold Equal, Subset. firstorder.
+  Qed.
+
+  Lemma equal_1: forall s s', Equal s s' -> equal s s' = true.
+  Proof. intros s s'. apply -> equal_spec; trivial. Qed.
+
+  Lemma equal_2: forall s s', equal s s' = true -> Equal s s'.
+  Proof. intros s s'. apply <- equal_spec; trivial. Qed.
+
+  Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
+  Proof.
+    unfold eq.
+    intros. case_eq (equal s s'); intro H.
+     left. apply equal_2, H.
+     right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate).
+  Defined.
+
+  (** (Specified) definition of [compare] *)
+
+  Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
+    lex u v = CompOpp (lex u' v').
+  Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed.
+
+  Lemma compare_bool_inv: forall b b',
+    compare_bool b b' = CompOpp (compare_bool b' b).
+  Proof. intros [|] [|]; reflexivity. Qed.
+
+  Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s).
+  Proof.
+    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
+    unfold compare_fun. case is_empty; reflexivity.
+    unfold compare_fun. case is_empty; reflexivity.
+    simpl. rewrite compare_bool_inv.
+     case compare_bool; simpl; trivial; apply lex_Opp; auto.
+  Qed.
+
+  Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
+  Proof. intros u v; destruct u; intuition discriminate. Qed.
+
+  Lemma compare_bool_Eq: forall b1 b2,
+    compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
+  Proof. intros [|] [|]; intuition discriminate. Qed.
+
+  Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
+     simpl. tauto.
+     unfold compare_fun, equal. case is_empty; intuition discriminate.
+     unfold compare_fun, equal. case is_empty; intuition discriminate.
+     simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
+     rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
+     rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
+  Qed.
+
+
+  Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s.
+  Proof.
+    unfold lt. intros s s'. rewrite compare_inv.
+     case compare_fun; trivial; intros; discriminate.
+  Qed.
+
+  Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'.
+  Proof.
+    unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
+  Qed.
+
+  Lemma compare : forall s s' : t, Compare lt eq s s'.
+  Proof.
+    intros. case_eq (compare_fun s s'); intro H.
+    apply EQ. apply compare_eq, H.
+    apply LT. assumption.
+    apply GT. apply compare_gt, H.
+  Defined.
+
+  Section lt_spec.
+
+  Inductive ct: comparison -> comparison -> comparison -> Prop :=
+  | ct_xxx: forall x, ct x  x  x
+  | ct_xex: forall x, ct x  Eq x
+  | ct_exx: forall x, ct Eq x  x
+  | ct_glx: forall x, ct Gt Lt x
+  | ct_lgx: forall x, ct Lt Gt x.
+
+  Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_lxl: forall x, ct Lt x Lt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_gxg: forall x, ct Gt x Gt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xll: forall x, ct x Lt Lt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xgg: forall x, ct x Gt Gt.
+  Proof. destruct x; constructor. Qed.
+
+  Local Hint Constructors ct: ct.
+  Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
+  Ltac ct := trivial with ct.
+
+  Lemma ct_lex: forall u v w u' v' w',
+    ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
+  Proof.
+    intros u v w u' v' w' H H'.
+    inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
+  Qed.
+
+  Lemma ct_compare_bool:
+    forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
+  Proof.
+    intros [|] [|] [|]; constructor.
+  Qed.
+
+  Lemma compare_x_Leaf: forall s,
+    compare_fun s Leaf = if is_empty s then Eq else Gt.
+  Proof.
+    intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
+  Qed.
+
+  Lemma compare_empty_x: forall a, is_empty a = true ->
+    forall b, compare_fun a b = if is_empty b then Eq else Lt.
+  Proof.
+    induction a as [|l IHl o r IHr]; trivial.
+    destruct o. intro; discriminate.
+    simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
+    intros [Hl Hr].
+    destruct b as [|l' [|] r']; simpl compare_fun; trivial.
+     rewrite Hl, Hr. trivial.
+     rewrite (IHl Hl), (IHr Hr). simpl.
+     case (is_empty l'); case (is_empty r'); trivial.
+  Qed.
+
+  Lemma compare_x_empty: forall a, is_empty a = true ->
+    forall b, compare_fun b a = if is_empty b then Eq else Gt.
+  Proof.
+    setoid_rewrite <- compare_x_Leaf.
+    intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
+  Qed.
+
+  Lemma ct_compare_fun:
+    forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c).
+  Proof.
+    induction a as [|l IHl o r IHr]; intros s' s''.
+     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
+      rewrite compare_inv. ct.
+      unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'.
+       rewrite (compare_empty_x _ H'). ct.
+       unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
+        rewrite (compare_x_empty _ H''), H'. ct.
+        ct.
+
+     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
+      ct.
+      unfold compare_fun at 2. rewrite compare_x_Leaf.
+      case_eq (is_empty (Node l o r)); intro H.
+       rewrite (compare_empty_x _ H). ct.
+       case_eq (is_empty (Node l'' o'' r'')); intro H''.
+        rewrite (compare_x_empty _ H''), H. ct.
+        ct.
+
+      rewrite 2 compare_x_Leaf.
+      case_eq (is_empty (Node l o r)); intro H.
+       rewrite compare_inv, (compare_x_empty _ H). ct.
+       case_eq (is_empty (Node l' o' r')); intro H'.
+        rewrite (compare_x_empty _ H'), H. ct.
+        ct.
+
+      simpl compare_fun. apply ct_lex. apply ct_compare_bool.
+       apply ct_lex; trivial.
+  Qed.
+
+  End lt_spec.
+
+  Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''.
+  Proof.
+    unfold lt. intros a b c. assert (H := ct_compare_fun a b c).
+    inversion_clear H; trivial; intros; discriminate.
+  Qed.
+
+  Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'.
+  Proof.
+    unfold lt, eq. intros s s' H H'.
+     rewrite equal_spec, <- compare_equal in H'. congruence.
+  Qed.
+
+  (** Specification of [add] *)
+
+  Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s.
+  Proof.
+    unfold In. induction x; intros [y|y|] [|l o r]; simpl mem;
+    try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
+  Qed.
+
+  Lemma add_1: forall s x y, x = y -> In y (add x s).
+  Proof. intros. apply <- add_spec. left. assumption. Qed.
+
+  Lemma add_2: forall s x y, In y s -> In y (add x s).
+  Proof. intros. apply <- add_spec. right. assumption. Qed.
+
+  Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s.
+  Proof.
+    intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial.
+  Qed.
+
+  (** Specification of [remove] *)
+
+  Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s.
+  Proof.
+    unfold In.
+    induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
+     simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
+     intuition congruence.
+  Qed.
+
+  Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s).
+  Proof. intros. rewrite remove_spec. tauto. Qed.
+
+  Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s).
+  Proof. intros. rewrite remove_spec. split; assumption. Qed.
+
+  Lemma remove_3: forall s x y, In y (remove x s) -> In y s.
+  Proof. intros s x y. rewrite remove_spec. tauto. Qed.
+
+  (** Specification of [singleton] *)
+
+  Lemma singleton_1: forall x y, In y (singleton x) -> x=y.
+  Proof.
+    unfold singleton. intros x y. rewrite add_spec.
+    unfold In. rewrite mem_Leaf. intuition discriminate.
+  Qed.
+
+  Lemma singleton_2: forall x y, x = y -> In y (singleton x).
+  Proof.
+    unfold singleton. intros. apply add_1. assumption.
+  Qed.
+
+  (** Specification of [union] *)
+
+  Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+    unfold In.
+    induction x; destruct s; destruct s'; simpl union; simpl mem;
+      try (rewrite IHx; clear IHx); try intuition congruence.
+      apply orb_true_iff.
+  Qed.
+
+  Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'.
+  Proof. intros. apply -> union_spec. assumption. Qed.
+
+  Lemma union_2: forall s s' x, In x s -> In x (union s s').
+  Proof. intros. apply <- union_spec. left. assumption. Qed.
+
+  Lemma union_3: forall s s' x, In x s' -> In x (union s s').
+  Proof. intros. apply <- union_spec. right. assumption. Qed.
+
+  (** Specification of [inter] *)
+
+  Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+    unfold In.
+    induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
+     simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
+     apply andb_true_iff.
+  Qed.
+
+  Lemma inter_1: forall s s' x, In x (inter s s') -> In x s.
+  Proof. intros s s' x. rewrite inter_spec. tauto. Qed.
+
+  Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'.
+  Proof. intros s s' x. rewrite inter_spec. tauto. Qed.
+
+  Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s').
+  Proof. intros. rewrite inter_spec. split; assumption. Qed.
+
+  (** Specification of [diff] *)
+
+  Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'.
+  Proof.
+    unfold In.
+    induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
+     rewrite ?mem_node; simpl mem;
+      try (rewrite IHx; clear IHx); try intuition congruence.
+      rewrite andb_true_iff. destruct o'; intuition discriminate.
+  Qed.
+
+  Lemma diff_1: forall s s' x, In x (diff s s') -> In x s.
+  Proof. intros s s' x. rewrite diff_spec. tauto. Qed.
+
+  Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'.
+  Proof. intros s s' x. rewrite diff_spec. tauto. Qed.
+
+  Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s').
+  Proof. intros. rewrite diff_spec. split; assumption. Qed.
+
+  (** Specification of [fold] *)
+
+  Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+    unfold fold, elements. intros s A i f. revert s i.
+    set (f' := fun a e => f e a).
+    assert (H: forall s i j acc,
+      fold_left f' acc (xfold f s i j) =
+      fold_left f' (xelements s j acc) i).
+
+    induction s as [|l IHl o r IHr]; intros; trivial.
+      destruct o; simpl xelements; simpl xfold.
+        rewrite IHr, <- IHl. reflexivity.
+        rewrite IHr. apply IHl.
+
+    intros. exact (H s i 1 nil).
+  Qed.
+
+  (** Specification of [cardinal] *)
+
+  Lemma cardinal_1: forall s, cardinal s = length (elements s).
+  Proof.
+    unfold elements.
+    assert (H: forall s j acc,
+                (cardinal s + length acc)%nat = length (xelements s j acc)).
+
+    induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
+      rewrite <- IHl. simpl. rewrite <- IHr.
+       rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
+      rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.
+
+    intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
+  Qed.
+
+  (** Specification of [filter] *)
+
+  Lemma xfilter_spec: forall f s x i,
+    In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
+  Proof.
+    intro f. unfold In.
+    induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
+     rewrite mem_Leaf. intuition discriminate.
+     rewrite mem_node. destruct x; simpl.
+       rewrite IHr. reflexivity.
+       rewrite IHl. reflexivity.
+       rewrite <- andb_lazy_alt. apply andb_true_iff.
+  Qed.
+
+  Lemma filter_1 : forall s x f, compat_bool E.eq f ->
+    In x (filter f s) -> In x s.
+  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
+
+  Lemma filter_2 : forall s x f, compat_bool E.eq f ->
+    In x (filter f s) -> f x = true.
+  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
+
+  Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s ->
+    f x = true -> In x (filter f s).
+  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
+
+
+  (** Specification of [for_all] *)
+
+  Lemma xforall_spec: forall f s i,
+    xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
+  Proof.
+    unfold For_all, In. intro f.
+    induction s as [|l IHl o r IHr]; intros i; simpl.
+     setoid_rewrite mem_Leaf. intuition discriminate.
+     rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
+     rewrite IHl, IHr. clear IHl IHr.
+      split.
+       intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
+        apply Hr, H.
+        apply Hl, H.
+        rewrite H in Hi. assumption.
+       intro H; intuition.
+        specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
+        apply H. assumption.
+        apply H. assumption.
+  Qed.
+
+  Lemma for_all_1 : forall s f, compat_bool E.eq f ->
+    For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.
+
+  Lemma for_all_2 : forall s f, compat_bool E.eq f ->
+    for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.
+
+
+  (** Specification of [exists] *)
+
+  Lemma xexists_spec: forall f s i,
+    xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
+  Proof.
+    unfold Exists, In. intro f.
+    induction s as [|l IHl o r IHr]; intros i; simpl.
+     setoid_rewrite mem_Leaf. firstorder.
+     rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
+     rewrite IHl, IHr. clear IHl IHr.
+      split.
+       intros [[Hi|[x Hr]]|[x Hl]].
+        exists 1. exact Hi.
+        exists x~1. exact Hr.
+        exists x~0. exact Hl.
+       intros [[x|x|] H]; eauto.
+  Qed.
+
+  Lemma exists_1 : forall s f, compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.
+
+  Lemma exists_2 : forall s f, compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.
+
+
+  (** Specification of [partition] *)
+
+  Lemma partition_filter : forall s f,
+    partition f s = (filter f s, filter (fun x => negb (f x)) s).
+  Proof.
+    unfold partition, filter. intros s f. generalize 1 as j.
+    induction s as [|l IHl o r IHr]; intro j.
+      reflexivity.
+      destruct o; simpl; rewrite IHl, IHr; reflexivity.
+  Qed.
+
+  Lemma partition_1 : forall s f, compat_bool E.eq f ->
+      Equal (fst (partition f s)) (filter f s).
+  Proof. intros. rewrite partition_filter. apply eq_refl. Qed.
+
+  Lemma partition_2 : forall s f, compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. intros. rewrite partition_filter. apply eq_refl. Qed.
+
+
+  (** Specification of [elements] *)
+
+  Notation InL := (InA E.eq).
+
+  Lemma xelements_spec: forall s j acc y,
+    InL y (xelements s j acc)
+    <->
+    InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; simpl.
+      intros. split; intro H.
+        left. assumption.
+        destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx').
+
+      intros j acc y. case o.
+        rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
+          intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
+            right. exists x~1. auto.
+            right. exists x~0. auto.
+          intros [H|[x [-> H]]].
+            eauto.
+            destruct x.
+              left. right. right. exists x; auto.
+              right. exists x; auto.
+              left. left. reflexivity.
+
+        rewrite IHl, IHr. clear IHl IHr. split.
+          intros [[H|[x [-> H]]]|[x [-> H]]].
+            eauto.
+            right. exists x~1. auto.
+            right. exists x~0. auto.
+          intros [H|[x [-> H]]].
+            eauto.
+            destruct x.
+              left. right.  exists x; auto.
+              right. exists x; auto.
+              discriminate.
+  Qed.
+
+  Lemma elements_1: forall s x, In x s -> InL x (elements s).
+  Proof.
+    unfold elements, In. intros.
+    rewrite xelements_spec. right. exists x. auto.
+  Qed.
+
+  Lemma elements_2: forall s x, InL x (elements s) -> In x s.
+  Proof.
+    unfold elements, In. intros s x H.
+    rewrite xelements_spec in H. destruct H as [H|[y [H H']]].
+      inversion_clear H.
+      rewrite H. assumption.
+  Qed.
+
+  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
+  Proof. induction j; intros; simpl; auto. Qed.
+
+  Lemma elements_3: forall s, sort E.lt (elements s).
+  Proof.
+    unfold elements.
+    assert (H: forall s j acc,
+      sort E.lt acc ->
+      (forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
+      sort E.lt (xelements s j acc)).
+
+    induction s as [|l IHl o r IHr]; simpl; trivial.
+    intros j acc Hacc Hsacc. destruct o.
+      apply IHl. constructor.
+       apply IHr. apply Hacc.
+       intros x y Hx Hy. apply Hsacc; assumption.
+       case_eq (xelements r j~1 acc). constructor.
+       intros z q H. constructor.
+       assert (H': InL z (xelements r j~1 acc)).
+        rewrite H. constructor. reflexivity.
+       clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
+         apply (Hsacc 1 z); trivial. reflexivity.
+         simpl. apply lt_rev_append. exact I.
+       intros x y Hx Hy. inversion_clear Hy.
+         rewrite H. simpl. apply lt_rev_append. exact I.
+         rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
+           apply Hsacc; assumption.
+           simpl. apply lt_rev_append. exact I.
+
+      apply IHl. apply IHr. apply Hacc.
+       intros x y Hx Hy. apply Hsacc; assumption.
+       intros x y Hx Hy. rewrite xelements_spec in Hy.
+        destruct Hy as [Hy|[z [-> Hy]]].
+         apply Hsacc; assumption.
+         simpl. apply lt_rev_append. exact I.
+
+    intros. apply H. constructor.
+      intros x y _ H'. inversion H'.
+  Qed.
+
+  Lemma elements_3w: forall s, NoDupA E.eq (elements s).
+  Proof.
+    intro. apply SortA_NoDupA with E.lt.
+      constructor.
+       intro. apply E.eq_refl.
+       intro. apply E.eq_sym.
+       intro. apply E.eq_trans.
+      constructor.
+       intros x H. apply E.lt_not_eq in H. apply H. reflexivity.
+       intro. apply E.lt_trans.
+      intros ? ? <- ? ? <-. reflexivity.
+      apply elements_3.
+  Qed.
+
+
+  (** Specification of [choose] *)
+
+  Lemma choose_1: forall s x, choose s = Some x -> In x s.
+  Proof.
+    induction s as [| l IHl o r IHr]; simpl.
+      intros. discriminate.
+      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.
+           reflexivity.
+          intros _ x. revert IHr. case choose.
+            intros p Hp H. injection H; intros; subst; clear H. apply Hp.
+            reflexivity.
+            intros. discriminate.
+  Qed.
+
+  Lemma choose_2: forall s, choose s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_1.
+      destruct o.
+        discriminate.
+        simpl in H. destruct (choose l).
+          discriminate.
+          destruct (choose r).
+            discriminate.
+            intros [a|a|].
+              apply IHr. reflexivity.
+              apply IHl. reflexivity.
+              discriminate.
+  Qed.
+
+  Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
+  Proof.
+    intros s Hs. case_eq (choose s); trivial.
+    intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp).
+  Qed.
+
+  Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'.
+  Proof.
+    setoid_rewrite equal_spec.
+    induction s as [|l IHl o r IHr].
+      intros. symmetry. apply choose_empty. assumption.
+
+      destruct s' as [|l' o' r'].
+        generalize (Node l o r) as s. simpl. intros. apply choose_empty.
+        rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H.
+        assumption.
+
+        simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
+        intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
+  Qed.
+
+  Lemma choose_3: forall s s' x y,
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
+  Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed.
+
+
+  (** Specification of [min_elt] *)
+
+  Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s.
+  Proof.
+   unfold In.
+   induction s as [| l IHl o r IHr]; simpl.
+     intros. discriminate.
+     intros x. destruct (min_elt l); intros.
+       injection H. intros <-. apply IHl. reflexivity.
+       destruct o; simpl.
+         injection H. intros <-. reflexivity.
+         destruct (min_elt r); simpl in *.
+           injection H. intros <-. apply IHr. reflexivity.
+           discriminate.
+  Qed.
+
+  Lemma min_elt_3: forall s, min_elt s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_1.
+      intros [a|a|].
+        apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
+          case min_elt; intros; try discriminate. destruct o; discriminate.
+        apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
+         intro; discriminate.
+        revert H. clear. simpl. case min_elt; intros; try discriminate.
+         destruct o; discriminate.
+  Qed.
+
+  Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Proof.
+    unfold In.
+    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 <-.
+        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.
+          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
+
+          destruct (min_elt r).
+            injection H. intros <-. clear H.
+            destruct y as [z|z|].
+              apply (IHr p z); trivial.
+              elim (Hp _ H').
+              discriminate.
+            discriminate.
+  Qed.
+
+
+  (** Specification of [max_elt] *)
+
+  Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s.
+  Proof.
+   unfold In.
+   induction s as [| l IHl o r IHr]; simpl.
+     intros. discriminate.
+     intros x. destruct (max_elt r); intros.
+       injection H. intros <-. apply IHr. reflexivity.
+       destruct o; simpl.
+         injection H. intros <-. reflexivity.
+         destruct (max_elt l); simpl in *.
+           injection H. intros <-. apply IHl. reflexivity.
+           discriminate.
+  Qed.
+
+  Lemma max_elt_3: forall s, max_elt s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_1.
+      intros [a|a|].
+        apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
+         intro; discriminate.
+        apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
+          case max_elt; intros; try discriminate. destruct o; discriminate.
+        revert H. clear. simpl. case max_elt; intros; try discriminate.
+         destruct o; discriminate.
+  Qed.
+
+  Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Proof.
+    unfold In.
+    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 <-.
+        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.
+          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
+
+          destruct (max_elt l).
+            injection H. intros <-. clear H.
+            destruct y as [z|z|].
+              elim (Hp _ H').
+              apply (IHl p z); trivial.
+              discriminate.
+            discriminate.
+  Qed.
+
+End PositiveSet.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
index 8dc7fbd9..84c26dac 100644
--- a/theories/FSets/FSetProperties.v
+++ b/theories/FSets/FSetProperties.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite sets library *)
 
 (** This functor derives additional properties from [FSetInterface.S].
-    Contrary to the functor in [FSetEqProperties] it uses 
+    Contrary to the functor in [FSetEqProperties] it uses
     predicates over sets instead of sets operations, i.e.
-    [In x s] instead of [mem x s=true], 
+    [In x s] instead of [mem x s=true],
     [Equal s s'] instead of [equal s s'=true], etc. *)
 
 Require Export FSetInterface.
@@ -21,7 +21,7 @@ Require Import DecidableTypeEx FSetFacts FSetDecide.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-Hint Unfold transpose compat_op.
+Hint Unfold transpose compat_op Proper respectful.
 Hint Extern 1 (Equivalence _) => constructor; congruence.
 
 (** First, a functor for Weak Sets in functorial version. *)
@@ -47,7 +47,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   fsetdec.
   fsetdec.
   Qed.
-  
+
   Ltac expAdd := repeat rewrite Add_Equal.
 
   Section BasicProperties.
@@ -64,7 +64,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
   Proof. fsetdec. Qed.
 
-  Lemma subset_refl : s[<=]s. 
+  Lemma subset_refl : s[<=]s.
   Proof. fsetdec. Qed.
 
   Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
@@ -84,7 +84,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
 
   Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
   Proof. fsetdec. Qed.
- 
+
   Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
   Proof. fsetdec. Qed.
 
@@ -93,7 +93,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
 
   Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
   Proof. fsetdec. Qed.
- 
+
   Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
   Proof. intuition fsetdec. Qed.
 
@@ -105,7 +105,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
 
   Lemma add_equal : In x s -> add x s [=] s.
   Proof. fsetdec. Qed.
- 
+
   Lemma add_add : add x (add x' s) [=] add x' (add x s).
   Proof. fsetdec. Qed.
 
@@ -149,11 +149,11 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Lemma union_add : union (add x s) s' [=] add x (union s s').
   Proof. fsetdec. Qed.
 
-  Lemma union_remove_add_1 : 
+  Lemma union_remove_add_1 :
    union (remove x s) (add x s') [=] union (add x s) (remove x s').
   Proof. fsetdec. Qed.
 
-  Lemma union_remove_add_2 : In x s -> 
+  Lemma union_remove_add_2 : In x s ->
    union (remove x s) (add x s') [=] union s s'.
   Proof. fsetdec. Qed.
 
@@ -167,10 +167,10 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Proof. fsetdec. Qed.
 
   Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
-  Proof. fsetdec. Qed. 
+  Proof. fsetdec. Qed.
 
   Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
-  Proof. fsetdec. Qed. 
+  Proof. fsetdec. Qed.
 
   Lemma empty_union_1 : Empty s -> union s s' [=] s'.
   Proof. fsetdec. Qed.
@@ -178,7 +178,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Lemma empty_union_2 : Empty s -> union s' s [=] s'.
   Proof. fsetdec. Qed.
 
-  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). 
+  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
   Proof. fsetdec. Qed.
 
   Lemma inter_sym : inter s s' [=] inter s' s.
@@ -224,7 +224,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
    s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
   Proof. fsetdec. Qed.
 
-  Lemma empty_diff_1 : Empty s -> Empty (diff s s'). 
+  Lemma empty_diff_1 : Empty s -> Empty (diff s s').
   Proof. fsetdec. Qed.
 
   Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
@@ -240,7 +240,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
    remove x s [=] diff s (singleton x).
   Proof. fsetdec. Qed.
 
-  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. 
+  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
   Proof. fsetdec. Qed.
 
   Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
@@ -249,19 +249,19 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Lemma Add_add : Add x s (add x s).
   Proof. expAdd; fsetdec. Qed.
 
-  Lemma Add_remove : In x s -> Add x (remove x s) s. 
+  Lemma Add_remove : In x s -> Add x (remove x s) s.
   Proof. expAdd; fsetdec. Qed.
 
   Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
-  Proof. expAdd; fsetdec. Qed. 
+  Proof. expAdd; fsetdec. Qed.
 
   Lemma inter_Add :
    In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
-  Proof. expAdd; fsetdec. Qed. 
+  Proof. expAdd; fsetdec. Qed.
 
   Lemma union_Equal :
    In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
-  Proof. expAdd; fsetdec. Qed. 
+  Proof. expAdd; fsetdec. Qed.
 
   Lemma inter_Add_2 :
    ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
@@ -270,16 +270,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   End BasicProperties.
 
   Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set.
-  Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym 
-    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 
+  Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym
+    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3
     subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
-    remove_equal singleton_equal_add union_subset_equal union_equal_1 
-    union_equal_2 union_assoc add_union_singleton union_add union_subset_1 
+    remove_equal singleton_equal_add union_subset_equal union_equal_1
+    union_equal_2 union_assoc add_union_singleton union_add union_subset_1
     union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
     inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
-    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 
-    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union 
-    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal 
+    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1
+    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union
+    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal
     remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
     Equal_remove add_add : set.
 
@@ -358,9 +358,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
            P s' a -> P s'' (f x a)).
    intros; eapply Pstep; eauto.
-   rewrite elements_iff, <- InA_rev; auto.
+   rewrite elements_iff, <- InA_rev; auto with *.
   assert (Hdup : NoDup l) by
-    (unfold l; eauto using elements_3w, NoDupA_rev).
+    (unfold l; eauto using elements_3w, NoDupA_rev with *).
   assert (Hsame : forall x, In x s <-> InA x l) by
     (unfold l; intros; rewrite elements_iff, InA_rev; intuition).
   clear Pstep; clearbody l; revert s Hsame; induction l.
@@ -429,7 +429,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   do 2 rewrite fold_1, <- fold_left_rev_right.
   set (l:=rev (elements s)).
   assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
-    (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto).
+    (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *).
   clearbody l; clear Rstep s.
   induction l; simpl; auto.
   Qed.
@@ -481,8 +481,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
         fold f s i = fold_right f i l.
   Proof.
   intros; exists (rev (elements s)); split.
-  apply NoDupA_rev; auto with set.
-  exact E.eq_trans.
+  apply NoDupA_rev; auto with *.
   split; intros.
   rewrite elements_iff; do 2 rewrite InA_alt.
   split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
@@ -504,7 +503,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   generalize H H2; clear H H2; case l; simpl; intros.
   reflexivity.
   elim (H e).
-  elim (H2 e); intuition. 
+  elim (H2 e); intuition.
   Qed.
 
   Lemma fold_2 :
@@ -514,17 +513,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
    transpose eqA f ->
    ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
   Proof.
-  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); 
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
     destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
   rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
-  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
-  eauto.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto with *.
   rewrite <- Hl1; auto.
-  intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; 
+  intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
    rewrite (H2 a); intuition.
   Qed.
 
-  (** In fact, [fold] on empty sets is more than equivalent to 
+  (** In fact, [fold] on empty sets is more than equivalent to
       the initial element, it is Leibniz-equal to it. *)
 
   Lemma fold_1b :
@@ -541,26 +539,27 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
   Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
 
-  Lemma fold_commutes : forall i s x, 
+  Lemma fold_commutes : forall i s x,
    eqA (fold f s (f x i)) (f x (fold f s i)).
   Proof.
   intros.
   apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
   reflexivity.
-  transitivity (f x0 (f x b)); auto.
+  transitivity (f x0 (f x b)); auto. apply Comp; auto with *.
   Qed.
 
   (** ** Fold is a morphism *)
 
-  Lemma fold_init : forall i i' s, eqA i i' -> 
+  Lemma fold_init : forall i i' s, eqA i i' ->
    eqA (fold f s i) (fold f s i').
   Proof.
   intros. apply fold_rel with (R:=eqA); auto.
+   intros; apply Comp; auto with *.
   Qed.
 
-  Lemma fold_equal : 
+  Lemma fold_equal :
    forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
-  Proof. 
+  Proof.
   intros i s; pattern s; apply set_induction; clear s; intros.
   transitivity i.
   apply fold_1; auto.
@@ -576,23 +575,23 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   (** ** Fold and other set operators *)
 
   Lemma fold_empty : forall i, fold f empty i = i.
-  Proof. 
+  Proof.
   intros i; apply fold_1b; auto with set.
   Qed.
 
-  Lemma fold_add : forall i s x, ~In x s -> 
+  Lemma fold_add : forall i s x, ~In x s ->
    eqA (fold f (add x s) i) (f x (fold f s i)).
-  Proof. 
+  Proof.
   intros; apply fold_2 with (eqA := eqA); auto with set.
   Qed.
 
-  Lemma add_fold : forall i s x, In x s -> 
+  Lemma add_fold : forall i s x, In x s ->
    eqA (fold f (add x s) i) (fold f s i).
   Proof.
   intros; apply fold_equal; auto with set.
   Qed.
 
-  Lemma remove_fold_1: forall i s x, In x s -> 
+  Lemma remove_fold_1: forall i s x, In x s ->
    eqA (f x (fold f (remove x s) i)) (fold f s i).
   Proof.
   intros.
@@ -600,7 +599,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   apply fold_2 with (eqA:=eqA); auto with set.
   Qed.
 
-  Lemma remove_fold_2: forall i s x, ~In x s -> 
+  Lemma remove_fold_2: forall i s x, ~In x s ->
    eqA (fold f (remove x s) i) (fold f s i).
   Proof.
   intros.
@@ -620,7 +619,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   symmetry; apply fold_1; auto.
   rename s'0 into s''.
   destruct (In_dec x s').
-  (* In x s' *)   
+  (* In x s' *)
   transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
   apply fold_init; auto.
   apply fold_2 with (eqA:=eqA); auto with set.
@@ -646,7 +645,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   symmetry; apply fold_2 with (eqA:=eqA); auto.
   Qed.
 
-  Lemma fold_diff_inter : forall i s s', 
+  Lemma fold_diff_inter : forall i s s',
    eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
   Proof.
   intros.
@@ -659,7 +658,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   apply fold_1; auto with set.
   Qed.
 
-  Lemma fold_union: forall i s s', 
+  Lemma fold_union: forall i s s',
    (forall x, ~(In x s/\In x s')) ->
    eqA (fold f (union s s') i) (fold f s (fold f s' i)).
   Proof.
@@ -696,9 +695,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   Lemma cardinal_0 :
      forall s, exists l : list elt,
         NoDupA E.eq l /\
-        (forall x : elt, In x s <-> InA E.eq x l) /\ 
+        (forall x : elt, In x s <-> InA E.eq x l) /\
         cardinal s = length l.
-  Proof. 
+  Proof.
   intros; exists (elements s); intuition; apply cardinal_1.
   Qed.
 
@@ -724,32 +723,32 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   destruct (elements s); intuition; discriminate.
   Qed.
 
-  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. 
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s.
   Proof.
-  intros; rewrite cardinal_Empty; auto. 
+  intros; rewrite cardinal_Empty; auto.
   Qed.
   Hint Resolve cardinal_inv_1.
- 
+
   Lemma cardinal_inv_2 :
    forall s n, cardinal s = S n -> { x : elt | In x s }.
-  Proof. 
+  Proof.
   intros; rewrite M.cardinal_1 in H.
   generalize (elements_2 (s:=s)).
-  destruct (elements s); try discriminate. 
+  destruct (elements s); try discriminate.
   exists e; auto.
   Qed.
 
   Lemma cardinal_inv_2b :
    forall s, cardinal s <> 0 -> { x : elt | In x s }.
   Proof.
-  intro; generalize (@cardinal_inv_2 s); destruct cardinal; 
+  intro; generalize (@cardinal_inv_2 s); destruct cardinal;
    [intuition|eauto].
   Qed.
 
   (** ** Cardinal is a morphism *)
 
   Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
-  Proof. 
+  Proof.
   symmetry.
   remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
   induction n; intros.
@@ -794,8 +793,8 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   apply fold_diff_inter with (eqA:=@Logic.eq nat); auto.
   Qed.
 
-  Lemma union_cardinal: 
-   forall s s', (forall x, ~(In x s/\In x s')) -> 
+  Lemma union_cardinal:
+   forall s s', (forall x, ~(In x s/\In x s')) ->
    cardinal (union s s')=cardinal s+cardinal s'.
   Proof.
   intros; do 3 rewrite cardinal_fold.
@@ -803,7 +802,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   apply fold_union; auto.
   Qed.
 
-  Lemma subset_cardinal : 
+  Lemma subset_cardinal :
    forall s s', s[<=]s' -> cardinal s <= cardinal s' .
   Proof.
   intros.
@@ -812,9 +811,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   rewrite (inter_subset_equal H); auto with arith.
   Qed.
 
-  Lemma subset_cardinal_lt : 
+  Lemma subset_cardinal_lt :
    forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
-  Proof. 
+  Proof.
   intros.
   rewrite <- (diff_inter_cardinal s' s).
   rewrite (inter_sym s' s).
@@ -826,7 +825,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   intros _.
   change (0 + cardinal s < S n + cardinal s).
   apply Plus.plus_lt_le_compat; auto with arith.
-  Qed. 
+  Qed.
 
   Theorem union_inter_cardinal :
    forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
@@ -837,7 +836,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   apply fold_union_inter with (eqA:=@Logic.eq nat); auto.
   Qed.
 
-  Lemma union_cardinal_inter : 
+  Lemma union_cardinal_inter :
    forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
   Proof.
   intros.
@@ -846,17 +845,17 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   auto with arith.
   Qed.
 
-  Lemma union_cardinal_le : 
+  Lemma union_cardinal_le :
    forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
   Proof.
    intros; generalize (union_inter_cardinal s s').
    intros; rewrite <- H; auto with arith.
   Qed.
 
-  Lemma add_cardinal_1 : 
+  Lemma add_cardinal_1 :
    forall s x, In x s -> cardinal (add x s) = cardinal s.
   Proof.
-  auto with set.  
+  auto with set.
   Qed.
 
   Lemma add_cardinal_2 :
@@ -877,9 +876,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   apply remove_fold_1 with (eqA:=@Logic.eq nat); auto.
   Qed.
 
-  Lemma remove_cardinal_2 : 
+  Lemma remove_cardinal_2 :
    forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
-  Proof. 
+  Proof.
   auto with set.
   Qed.
 
@@ -910,7 +909,7 @@ Module OrdProperties (M:S).
   Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
    sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
   Proof.
-  apply SortA_equivlistA_eqlistA; eauto.
+  apply SortA_equivlistA_eqlistA; eauto with *.
   Qed.
 
   Definition gtb x y := match E.compare x y with GT _ => true | _ => false end.
@@ -929,7 +928,7 @@ Module OrdProperties (M:S).
    intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order.
   Qed.
 
-  Lemma gtb_compat : forall x, compat_bool E.eq (gtb x).
+  Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x).
   Proof.
    red; intros x a b H.
    generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto.
@@ -943,89 +942,88 @@ Module OrdProperties (M:S).
    rewrite <- H1; auto.
   Qed.
 
-  Lemma leb_compat : forall x, compat_bool E.eq (leb x).
+  Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x).
   Proof.
    red; intros x a b H; unfold leb.
    f_equal; apply gtb_compat; auto.
   Qed.
   Hint Resolve gtb_compat leb_compat.
 
-  Lemma elements_split : forall x s, 
+  Lemma elements_split : forall x s,
    elements s = elements_lt x s ++ elements_ge x s.
   Proof.
   unfold elements_lt, elements_ge, leb; intros.
-  eapply (@filter_split _ E.eq); eauto with set. ME.order. ME.order. ME.order.
+  eapply (@filter_split _ E.eq _ E.lt); auto with *.
   intros.
   rewrite gtb_1 in H.
   assert (~E.lt y x).
-   unfold gtb in *; destruct (E.compare x y); intuition; try discriminate; ME.order.
+   unfold gtb in *; destruct (E.compare x y); intuition;
+   try discriminate; ME.order.
   ME.order.
   Qed.
 
-  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> 
-    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). 
+  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' ->
+    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s).
   Proof.
   intros; unfold elements_ge, elements_lt.
   apply sort_equivlistA_eqlistA; auto with set.
-  apply (@SortA_app _ E.eq); auto.
-  apply (@filter_sort _ E.eq); auto with set; eauto with set.
+  apply (@SortA_app _ E.eq); auto with *.
+  apply (@filter_sort _ E.eq); auto with *.
   constructor; auto.
-  apply (@filter_sort _ E.eq); auto with set; eauto with set.
-  rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with set).
+  apply (@filter_sort _ E.eq); auto with *.
+  rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *).
   intros.
-  rewrite filter_InA in H1; auto; destruct H1.
+  rewrite filter_InA in H1; auto with *; destruct H1.
   rewrite leb_1 in H2.
   rewrite <- elements_iff in H1.
   assert (~E.eq x y).
    contradict H; rewrite H; auto.
   ME.order.
   intros.
-  rewrite filter_InA in H1; auto; destruct H1.
+  rewrite filter_InA in H1; auto with *; destruct H1.
   rewrite gtb_1 in H3.
   inversion_clear H2.
   ME.order.
-  rewrite filter_InA in H4; auto; destruct H4.
+  rewrite filter_InA in H4; auto with *; destruct H4.
   rewrite leb_1 in H4.
   ME.order.
   red; intros a.
-  rewrite InA_app_iff; rewrite InA_cons.
-  do 2 (rewrite filter_InA; auto).
-  do 2 rewrite <- elements_iff.
-  rewrite leb_1; rewrite gtb_1.
-  rewrite (H0 a); intuition.
+  rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff,
+   leb_1, gtb_1, (H0 a) by auto with *.
+  intuition.
   destruct (E.compare a x); intuition.
-  right; right; split; auto.
+  right; right; split; auto with *.
   ME.order.
   Qed.
 
   Definition Above x s := forall y, In y s -> E.lt y x.
   Definition Below x s := forall y, In y s -> E.lt x y.
 
-  Lemma elements_Add_Above : forall s s' x, 
-   Above x s -> Add x s s' -> 
+  Lemma elements_Add_Above : forall s s' x,
+   Above x s -> Add x s s' ->
      eqlistA E.eq (elements s') (elements s ++ x::nil).
   Proof.
   intros.
-  apply sort_equivlistA_eqlistA; auto with set.
-  apply (@SortA_app _ E.eq); auto with set.
+  apply sort_equivlistA_eqlistA; auto with *.
+  apply (@SortA_app _ E.eq); auto with *.
   intros.
   inversion_clear H2.
   rewrite <- elements_iff in H1.
   apply ME.lt_eq with x; auto.
   inversion H3.
   red; intros a.
-  rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil.
+  rewrite InA_app_iff, InA_cons, InA_nil by auto with *.
   do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
   Qed.
 
-  Lemma elements_Add_Below : forall s s' x, 
-   Below x s -> Add x s s' -> 
+  Lemma elements_Add_Below : forall s s' x,
+   Below x s -> Add x s s' ->
      eqlistA E.eq (elements s') (x::elements s).
   Proof.
   intros.
-  apply sort_equivlistA_eqlistA; auto with set.
+  apply sort_equivlistA_eqlistA; auto with *.
   change (sort E.lt ((x::nil) ++ elements s)).
-  apply (@SortA_app _ E.eq); auto with set.
+  apply (@SortA_app _ E.eq); auto with *.
   intros.
   inversion_clear H1.
   rewrite <- elements_iff in H2.
@@ -1036,7 +1034,7 @@ Module OrdProperties (M:S).
   do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
   Qed.
 
-  (** Two other induction principles on sets: we can be more restrictive 
+  (** Two other induction principles on sets: we can be more restrictive
       on the element we add at each step.  *)
 
   Lemma set_induction_max :
@@ -1117,15 +1115,15 @@ Module OrdProperties (M:S).
   apply elements_Add_Below; auto.
   Qed.
 
-  (** The following results have already been proved earlier, 
+  (** The following results have already been proved earlier,
     but we can now prove them with one hypothesis less:
     no need for [(transpose eqA f)]. *)
 
-  Section FoldOpt. 
+  Section FoldOpt.
   Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
   Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f).
 
-  Lemma fold_equal : 
+  Lemma fold_equal :
    forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
   Proof.
   intros; do 2 rewrite M.fold_1.
@@ -1136,13 +1134,13 @@ Module OrdProperties (M:S).
   red; intro a; do 2 rewrite <- elements_iff; auto.
   Qed.
 
-  Lemma add_fold : forall i s x, In x s -> 
+  Lemma add_fold : forall i s x, In x s ->
    eqA (fold f (add x s) i) (fold f s i).
   Proof.
   intros; apply fold_equal; auto with set.
   Qed.
 
-  Lemma remove_fold_2: forall i s x, ~In x s -> 
+  Lemma remove_fold_2: forall i s x, ~In x s ->
    eqA (fold f (remove x s) i) (fold f s i).
   Proof.
   intros.
@@ -1153,16 +1151,16 @@ Module OrdProperties (M:S).
 
   (** An alternative version of [choose_3] *)
 
-  Lemma choose_equal : forall s s', Equal s s' -> 
-    match choose s, choose s' with  
+  Lemma choose_equal : forall s s', Equal s s' ->
+    match choose s, choose s' with
       | Some x, Some x' => E.eq x x'
       | None, None => True
       | _, _ => False
      end.
   Proof.
-  intros s s' H; 
+  intros s s' H;
   generalize (@choose_1 s)(@choose_2 s)
-             (@choose_1 s')(@choose_2 s')(@choose_3 s s'); 
+             (@choose_1 s')(@choose_2 s')(@choose_3 s s');
   destruct (choose s); destruct (choose s'); simpl; intuition.
   apply H5 with e; rewrite <-H; auto.
   apply H5 with e; rewrite H; auto.
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
index 56a66261..01138270 100644
--- a/theories/FSets/FSetToFiniteSet.v
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -6,24 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
+(* $Id$ *)
 
-(* $Id: FSetToFiniteSet.v 11735 2009-01-02 17:22:31Z herbelin $ *)
+(** * Finite sets library : conversion to old [Finite_sets] *)
 
 Require Import Ensembles Finite_sets.
 Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx.
 
-(** * Going from [FSets] with usual Leibniz equality 
+(** * Going from [FSets] with usual Leibniz equality
     to the good old [Ensembles] and [Finite_sets] theory. *)
 
 Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
  Module MP:= WProperties_fun U M.
  Import M MP FM Ensembles Finite_sets.
 
- Definition mkEns : M.t -> Ensemble M.elt := 
+ Definition mkEns : M.t -> Ensemble M.elt :=
    fun s x => M.In x s.
 
  Notation " !! " := mkEns.
@@ -115,11 +112,11 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
  Proof.
  intro s; pattern s; apply set_induction; clear s; intros.
  intros; replace (!!s) with (Empty_set elt); auto with sets.
- symmetry; apply Extensionality_Ensembles. 
+ symmetry; apply Extensionality_Ensembles.
  apply Empty_Empty_set; auto.
  replace (!!s') with (Add _ (!!s) x).
  constructor 2; auto.
- symmetry; apply Extensionality_Ensembles. 
+ symmetry; apply Extensionality_Ensembles.
  apply Add_Add; auto.
  Qed.
 
@@ -128,18 +125,18 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
  intro s; pattern s; apply set_induction; clear s; intros.
  intros; replace (!!s) with (Empty_set elt); auto with sets.
  rewrite cardinal_1; auto with sets.
- symmetry; apply Extensionality_Ensembles. 
+ symmetry; apply Extensionality_Ensembles.
  apply Empty_Empty_set; auto.
  replace (!!s') with (Add _ (!!s) x).
- rewrite (cardinal_2 H0 H1); auto with sets. 
- symmetry; apply Extensionality_Ensembles. 
+ rewrite (cardinal_2 H0 H1); auto with sets.
+ symmetry; apply Extensionality_Ensembles.
  apply Add_Add; auto.
  Qed.
 
- (** we can even build a function from Finite Ensemble to FSet 
+ (** we can even build a function from Finite Ensemble to FSet
      ... at least in Prop. *)
 
- Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> 
+ Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e ->
    exists s:M.t, !!s === e.
  Proof.
  induction 1.
@@ -147,7 +144,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
  apply empty_Empty_Set.
  destruct IHFinite as (s,Hs).
  exists (M.add x s).
- apply Extensionality_Ensembles in Hs. 
+ apply Extensionality_Ensembles in Hs.
  rewrite <- Hs.
  apply add_Add.
  Qed.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
index 309016ce..711cbd9a 100644
--- a/theories/FSets/FSetWeakList.v
+++ b/theories/FSets/FSetWeakList.v
@@ -6,952 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeakList.v 11866 2009-01-28 19:10:15Z letouzey $ *)
+(* $Id$ *)
 
 (** * Finite sets library *)
 
-(** This file proposes an implementation of the non-dependant 
-    interface [FSetWeakInterface.S] using lists without redundancy. *)
+(** This file proposes an implementation of the non-dependant
+    interface [FSetInterface.WS] using lists without redundancy. *)
 
 Require Import FSetInterface.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** * Functions over lists
+(** This is just a compatibility layer, the real implementation
+    is now in [MSetWeakList] *)
 
-   First, we provide sets as lists which are (morally) without redundancy.
-   The specs are proved under the additional condition of no redundancy. 
-   And the functions returning sets are proved to preserve this invariant. *)
-
-Module Raw (X: DecidableType).
-
-  Definition elt := X.t.
-  Definition t := list elt.
-
-  Definition empty : t := nil.
-
-  Definition is_empty (l : t) : bool := if l then true else false.
-
-  (** ** The set operations. *)
-
-  Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
-    match s with
-    | nil => false
-    | y :: l =>
-           if X.eq_dec x y then true else mem x l
-    end.
-
-  Fixpoint add (x : elt) (s : t) {struct s} : t :=
-    match s with
-    | nil => x :: nil
-    | y :: l =>
-        if X.eq_dec x y then s else y :: add x l
-    end.
-
-  Definition singleton (x : elt) : t := x :: nil. 
-
-  Fixpoint remove (x : elt) (s : t) {struct s} : t :=
-    match s with
-    | nil => nil
-    | y :: l =>
-        if X.eq_dec x y then l else y :: remove x l
-    end.
-
-  Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : 
-   B -> B := fun i => match s with
-                      | nil => i
-                      | x :: l => fold f l (f x i)
-                      end.  
-
-  Definition union (s : t) : t -> t := fold add s.
-  
-  Definition diff (s s' : t) : t := fold remove s' s.
-
-  Definition inter (s s': t) : t := 
-    fold (fun x s => if mem x s' then add x s else s) s nil.
-
-  Definition subset (s s' : t) : bool := is_empty (diff s s').
-
-  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). 
-
-  Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
-    match s with
-    | nil => nil
-    | x :: l => if f x then x :: filter f l else filter f l
-    end.  
-
-  Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
-    match s with
-    | nil => true
-    | x :: l => if f x then for_all f l else false
-    end.  
- 
-  Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
-    match s with
-    | nil => false
-    | x :: l => if f x then true else exists_ f l
-    end.
-
-  Fixpoint partition (f : elt -> bool) (s : t) {struct s} : 
-   t * t :=
-    match s with
-    | nil => (nil, nil)
-    | x :: l =>
-        let (s1, s2) := partition f l in
-        if f x then (x :: s1, s2) else (s1, x :: s2)
-    end.
-
-  Definition cardinal (s : t) : nat := length s.
-
-  Definition elements (s : t) : list elt := s.
-
-  Definition choose (s : t) : option elt := 
-     match s with 
-      | nil => None
-      | x::_ => Some x
-     end.
-
-  (** ** Proofs of set operation specifications. *)
-  Section ForNotations. 
-  Notation NoDup := (NoDupA X.eq).
-  Notation In := (InA X.eq).
-
-  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
-  Definition Subset s s' := forall a : elt, In a s -> In a s'.
-  Definition Empty s := forall a : elt, ~ In a s.
-  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
-  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
-
-  Lemma In_eq :
-    forall (s : t) (x y : elt), X.eq x y -> In x s -> In y s.
-  Proof.
-  intros s x y; setoid_rewrite InA_alt; firstorder eauto.
-  Qed.
-  Hint Immediate In_eq.
-
-  Lemma mem_1 :
-   forall (s : t)(x : elt), In x s -> mem x s = true. 
-  Proof.
-  induction s; intros.
-  inversion H.
-  simpl; destruct (X.eq_dec x a); trivial.
-  inversion_clear H; auto.
-  Qed.
-
-  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
-  Proof.
-  induction s. 
-  intros; inversion H.
-  intros x; simpl.
-  destruct (X.eq_dec x a); firstorder; discriminate.
-  Qed.
-
-  Lemma add_1 :
-   forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> In y (add x s).
-  Proof.
-  induction s. 
-  simpl; intuition.
-  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
-   firstorder.
-  eauto.
-  Qed.
-
-  Lemma add_2 :
-   forall (s : t) (Hs : NoDup s) (x y : elt), In y s -> In y (add x s).
-  Proof.
-  induction s. 
-  simpl; intuition.
-  simpl; intros; case (X.eq_dec x a); intuition.
-  inversion_clear Hs; eauto; inversion_clear H; intuition.
-  Qed.
-
-  Lemma add_3 :
-   forall (s : t) (Hs : NoDup s) (x y : elt),
-   ~ X.eq x y -> In y (add x s) -> In y s.
-  Proof.
-  induction s. 
-  simpl; intuition.
-  inversion_clear H0; firstorder; absurd (X.eq x y); auto.
-  simpl; intros Hs x y; case (X.eq_dec x a); intros;
-   inversion_clear H0; inversion_clear Hs; firstorder; 
-   absurd (X.eq x y); auto.
-  Qed.
-
-  Lemma add_unique :
-   forall (s : t) (Hs : NoDup s)(x:elt), NoDup (add x s).
-  Proof.
-  induction s.  
-  simpl; intuition.
-  constructor; auto.
-  intro H0; inversion H0.
-  intros.
-  inversion_clear Hs.
-  simpl.
-  destruct (X.eq_dec x a).
-  constructor; auto.
-  constructor; auto.
-  intro H1; apply H.
-  eapply add_3; eauto.
-  Qed.
-
-  Lemma remove_1 :
-   forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> ~ In y (remove x s).
-  Proof.
-  simple induction s. 
-  simpl; red; intros; inversion H0.
-  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. 
-  elim H2.
-  apply In_eq with y; eauto.
-  inversion_clear H1; eauto.
-  Qed.
-
-  Lemma remove_2 :
-   forall (s : t) (Hs : NoDup s) (x y : elt),
-   ~ X.eq x y -> In y s -> In y (remove x s).
-  Proof.
-  simple induction s. 
-  simpl; intuition.
-  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
-   inversion_clear H1; auto. 
-  absurd (X.eq x y); eauto. 
-  Qed.
-
-  Lemma remove_3 :
-   forall (s : t) (Hs : NoDup s) (x y : elt), In y (remove x s) -> In y s.
-  Proof.
-  simple induction s. 
-  simpl; intuition.
-  simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition.
-  inversion_clear Hs; inversion_clear H; firstorder.
-  Qed.
-
-  Lemma remove_unique :
-   forall (s : t) (Hs : NoDup s) (x : elt), NoDup (remove x s).
-  Proof.
-  simple induction s.
-  simpl; intuition.
-  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
-   auto.
-  constructor; auto.
-  intro H2; elim H0.
-  eapply remove_3; eauto.
-  Qed. 
-
-  Lemma singleton_unique : forall x : elt, NoDup (singleton x).
-  Proof.
-  unfold singleton; simpl; constructor; auto; intro H; inversion H.
-  Qed.
-
-  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y.
-  Proof.
-  unfold singleton; simpl; intuition.
-  inversion_clear H; auto; inversion H0.
-  Qed. 
-
-  Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x).
-  Proof.
-  unfold singleton; simpl; intuition.
-  Qed. 
-  
-  Lemma empty_unique : NoDup empty.
-  Proof.
-  unfold empty; constructor.
-  Qed.
-
-  Lemma empty_1 : Empty empty.
-  Proof.
-  unfold Empty, empty; intuition; inversion H.
-  Qed. 
-
-  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
-  Proof.
-  unfold Empty; intro s; case s; simpl; intuition.
-  elim (H e); auto.
-  Qed.
-  
-  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. 
-  Proof.
-  unfold Empty; intro s; case s; simpl; intuition;
-   inversion H0.
-  Qed.
-
-  Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
-  Proof.
-  unfold elements; auto.
-  Qed.
-
-  Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
-  Proof. 
-  unfold elements; auto.
-  Qed.
- 
-  Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s).  
-  Proof. 
-  unfold elements; auto.
-  Qed.
-
-  Lemma fold_1 :
-   forall (s : t) (Hs : NoDup s) (A : Type) (i : A) (f : elt -> A -> A),
-   fold f s i = fold_left (fun a e => f e a) (elements s) i.
-  Proof.
-  induction s; simpl; auto; intros.
-  inversion_clear Hs; auto.
-  Qed.
-
-  Lemma union_unique :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (union s s').
-  Proof.
-  unfold union; induction s; simpl; auto; intros.
-  inversion_clear Hs.
-  apply IHs; auto.
-  apply add_unique; auto.
-  Qed.
-  
-  Lemma union_1 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (union s s') -> In x s \/ In x s'.
-  Proof.
-  unfold union; induction s; simpl; auto; intros.
-  inversion_clear Hs.
-  destruct (X.eq_dec x a).
-  left; auto.
-  destruct (IHs (add a s') H1 (add_unique Hs' a) x); intuition.
-  right; eapply add_3; eauto.
-  Qed.
-
-  Lemma union_0 : 
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x s \/ In x s' -> In x (union s s').
-  Proof.
-  unfold union; induction s; simpl; auto; intros.
-  inversion_clear H; auto.
-  inversion_clear H0.
-  inversion_clear Hs.
-  apply IHs; auto.
-  apply add_unique; auto.
-  destruct H.
-  inversion_clear H; auto.
-  right; apply add_1; auto.
-  right; apply add_2; auto.
-  Qed.
-
-  Lemma union_2 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x s -> In x (union s s').
-  Proof.
-  intros; apply union_0; auto.
-  Qed.
-
-  Lemma union_3 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x s' -> In x (union s s').
-  Proof.
-  intros; apply union_0; auto.
-  Qed.
-
-  Lemma inter_unique :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (inter s s').
-  Proof.
-  unfold inter; intros s.
-  set (acc := nil (A:=elt)).
-  assert (NoDup acc) by (unfold acc; auto).
-  clearbody acc; generalize H; clear H; generalize acc; clear acc. 
-  induction s; simpl; auto; intros.
-  inversion_clear Hs.
-  apply IHs; auto.
-  destruct (mem a s'); intros; auto.
-  apply add_unique; auto.
-  Qed.  
-  
-  Lemma inter_0  :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (inter s s') -> In x s /\ In x s'.
-  Proof.
-  unfold inter; intros.
-  set (acc := nil (A:=elt)) in *.
-  assert (NoDup acc) by (unfold acc; auto).
-  cut ((In x s /\ In x s') \/ In x acc).
-    destruct 1; auto.
-    inversion H1.
-  clearbody acc. 
-  generalize H0 H Hs' Hs; clear H0 H Hs Hs'.
-  generalize acc x s'; clear acc x s'.
-  induction s; simpl; auto; intros.
-  inversion_clear Hs.
-  case_eq (mem a s'); intros H3; rewrite H3 in H; simpl in H.
-  destruct (IHs _ _ _ (add_unique H0 a) H); auto.
-  left; intuition.
-  destruct (X.eq_dec x a); auto.
-  left; intuition.
-  apply In_eq with a; eauto.
-  apply mem_2; auto.
-  right; eapply add_3; eauto.
-  destruct (IHs _ _ _ H0 H); auto.
-  left; intuition.
-  Qed.
-
-  Lemma inter_1  :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (inter s s') -> In x s.
-  Proof.
-  intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ].
-  Qed.
-
-  Lemma inter_2 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (inter s s') -> In x s'.
-  Proof.
-  intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ].
-  Qed.
-
-  Lemma inter_3 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x s -> In x s' -> In x (inter s s').
-  Proof.
-  intros s s' Hs Hs' x.
-  cut (((In x s /\ In x s')\/ In x (nil (A:=elt))) -> In x (inter s s')).
-  intuition.
-  unfold inter.
-  set (acc := nil (A:=elt)) in *.
-  assert (NoDup acc) by (unfold acc; auto).
-  clearbody acc. 
-  generalize H Hs' Hs; clear H Hs Hs'.
-  generalize acc x s'; clear acc x s'.
-  induction s; simpl; auto; intros.
-  destruct H0; auto.
-  destruct H0; inversion H0.
-  inversion_clear Hs.
-  case_eq (mem a s'); intros H3; apply IHs; auto.
-  apply add_unique; auto.
-  destruct H0.
-  destruct H0.
-  inversion_clear H0.
-  right; apply add_1; auto.
-  left; auto.
-  right; apply add_2; auto.
-  destruct H0; auto.
-  destruct H0.
-  inversion_clear H0; auto.
-  absurd (In x s'); auto.
-  red; intros.
-  rewrite (mem_1 (In_eq H5 H0)) in H3.
-  discriminate.
-  Qed.
-
-  Lemma diff_unique :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (diff s s').
-  Proof.
-  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
-  induction s'; simpl; auto; intros.
-  inversion_clear Hs'.
-  apply IHs'; auto.
-  apply remove_unique; auto.
-  Qed.  
-  
-  Lemma diff_0 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (diff s s') -> In x s /\ ~ In x s'.
-  Proof.
-  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
-  induction s'; simpl; auto; intros.
-  inversion_clear Hs'.
-  split; auto; intro H1; inversion H1.
-  inversion_clear Hs'.
-  destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H).
-  split. 
-  eapply remove_3; eauto.
-  red; intros.
-  inversion_clear H4; auto.
-  destruct (remove_1 Hs (X.eq_sym H5) H2).
-  Qed.
-
-  Lemma diff_1 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (diff s s') -> In x s.
-  Proof.
-  intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. 
-  Qed.
-
-  Lemma diff_2 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x (diff s s') -> ~ In x s'.
-  Proof.
-  intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. 
-  Qed.
-
-  Lemma diff_3 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
-   In x s -> ~ In x s' -> In x (diff s s').
-  Proof.
-  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
-  induction s'; simpl; auto; intros.
-  inversion_clear Hs'.
-  apply IHs'; auto.
-  apply remove_unique; auto.
-  apply remove_2; auto.
-  Qed.  
-  
-  Lemma subset_1 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'),
-   Subset s s' -> subset s s' = true.
-  Proof.
-  unfold subset, Subset; intros.
-  apply is_empty_1.
-  unfold Empty; intros.
-  intro.
-  destruct (diff_2 Hs Hs' H0).
-  apply H.
-  eapply diff_1; eauto.
-  Qed.
-
-  Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), 
-     subset s s' = true -> Subset s s'.
-  Proof.
-  unfold subset, Subset; intros.
-  generalize (is_empty_2 H); clear H; unfold Empty; intros.
-  generalize (@mem_1 s' a) (@mem_2 s' a); destruct (mem a s').
-  intuition.
-  intros.
-  destruct (H a).
-  apply diff_3; intuition.
-  Qed.
-
-  Lemma equal_1 :
-   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'),
-   Equal s s' -> equal s s' = true.
-  Proof.
-  unfold Equal, equal; intros.
-  apply andb_true_intro; split; apply subset_1; firstorder.
-  Qed.
-
-  Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'),  
-     equal s s' = true -> Equal s s'.
-  Proof.
-  unfold Equal, equal; intros.
-  destruct (andb_prop _ _ H); clear H.
-  split; apply subset_2; auto.
-  Qed.  
-
-  Definition choose_1 :
-    forall (s : t) (x : elt), choose s = Some x -> In x s.
-  Proof.
-  destruct s; simpl; intros; inversion H; auto.
-  Qed.  
-
-  Definition choose_2 : forall s : t, choose s = None -> Empty s.
-  Proof.
-  destruct s; simpl; intros.
-  intros x H0; inversion H0.
-  inversion H.
-  Qed.  
-
-  Lemma cardinal_1 :
-   forall (s : t) (Hs : NoDup s), cardinal s = length (elements s).
-  Proof.
-  auto.
-  Qed.
-
-  Lemma filter_1 :
-   forall (s : t) (x : elt) (f : elt -> bool),
-   In x (filter f s) -> In x s.
-  Proof.
-  simple induction s; simpl.
-  intros; inversion H.
-  intros x l Hrec a f.
-  case (f x); simpl.
-  inversion_clear 1.
-  constructor; auto.
-  constructor 2; apply (Hrec a f); trivial.
-  constructor 2; apply (Hrec a f); trivial.
-  Qed.
-
-   Lemma filter_2 :
-    forall (s : t) (x : elt) (f : elt -> bool),
-    compat_bool X.eq f -> In x (filter f s) -> f x = true.   
-   Proof.
-  simple induction s; simpl.
-  intros; inversion H0.
-  intros x l Hrec a f Hf.
-  generalize (Hf x); case (f x); simpl; auto.
-  inversion_clear 2; auto.
-  symmetry; auto.
-  Qed.
- 
-  Lemma filter_3 :
-   forall (s : t) (x : elt) (f : elt -> bool),
-   compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s).     
-  Proof.
-  simple induction s; simpl.
-  intros; inversion H0.
-  intros x l Hrec a f Hf.
-  generalize (Hf x); case (f x); simpl.
-  inversion_clear 2; auto.
-  inversion_clear 2; auto.
-  rewrite <- (H a (X.eq_sym H1)); intros; discriminate.
-  Qed.
-
-  Lemma filter_unique :
-   forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (filter f s).
-  Proof.
-  simple induction s; simpl.
-  auto.
-  intros x l Hrec Hs f; inversion_clear Hs.
-  case (f x); auto.
-  constructor; auto.
-  intro H1; apply H.
-  eapply filter_1; eauto.
-  Qed.
-
-
-  Lemma for_all_1 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f ->
-   For_all (fun x => f x = true) s -> for_all f s = true.
-  Proof. 
-  simple induction s; simpl; auto; unfold For_all.
-  intros x l Hrec f Hf. 
-  generalize (Hf x); case (f x); simpl.
-  auto.
-  intros; rewrite (H x); auto.
-  Qed.
-
-  Lemma for_all_2 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f ->
-   for_all f s = true -> For_all (fun x => f x = true) s.
-  Proof. 
-  simple induction s; simpl; auto; unfold For_all.
-  intros; inversion H1.
-  intros x l Hrec f Hf. 
-  intros A a; intros. 
-  assert (f x = true).
-   generalize A; case (f x); auto.
-  rewrite H0 in A; simpl in A.
-  inversion_clear H; auto.
-  rewrite (Hf a x); auto.
-  Qed.
-
-  Lemma exists_1 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
-  Proof.
-  simple induction s; simpl; auto; unfold Exists.
-  intros.
-  elim H0; intuition. 
-  inversion H2.
-  intros x l Hrec f Hf. 
-  generalize (Hf x); case (f x); simpl.
-  auto.
-  destruct 2 as [a (A1,A2)].
-  inversion_clear A1.
-  rewrite <- (H a (X.eq_sym H0)) in A2; discriminate.
-  apply Hrec; auto.
-  exists a; auto.
-  Qed.
-
-  Lemma exists_2 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
-  Proof. 
-  simple induction s; simpl; auto; unfold Exists.
-  intros; discriminate.
-  intros x l Hrec f Hf.
-  case_eq (f x); intros.
-  exists x; auto.
-  destruct (Hrec f Hf H0) as [a (A1,A2)].
-  exists a; auto.
-  Qed.
-
-  Lemma partition_1 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s).
-  Proof.
-  simple induction s; simpl; auto; unfold Equal.
-  firstorder.
-  intros x l Hrec f Hf.
-  generalize (Hrec f Hf); clear Hrec.
-  case (partition f l); intros s1 s2; simpl; intros.
-  case (f x); simpl; firstorder; inversion H0; intros; firstorder. 
-  Qed.
-   
-  Lemma partition_2 :
-   forall (s : t) (f : elt -> bool),
-   compat_bool X.eq f ->
-   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
-  Proof.
-  simple induction s; simpl; auto; unfold Equal.
-  firstorder.
-  intros x l Hrec f Hf. 
-  generalize (Hrec f Hf); clear Hrec.
-  case (partition f l); intros s1 s2; simpl; intros.
-  case (f x); simpl; firstorder; inversion H0; intros; firstorder. 
-  Qed.
-
-  Lemma partition_aux_1 : 
-   forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), 
-    In x (fst (partition f s)) -> In x s.
-  Proof.
-  induction s; simpl; auto; intros.
-  inversion_clear Hs.
-  generalize (IHs H1 f x).
-  destruct (f a); destruct (partition f s); simpl in *; auto.
-  inversion_clear H; auto.
-  Qed. 
-     
-  Lemma partition_aux_2 : 
-   forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), 
-    In x (snd (partition f s)) -> In x s.
-  Proof.
-  induction s; simpl; auto; intros.
-  inversion_clear Hs.
-  generalize (IHs H1 f x).
-  destruct (f a); destruct (partition f s); simpl in *; auto.
-  inversion_clear H; auto.
-  Qed. 
-  
-  Lemma partition_unique_1 :
-   forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (fst (partition f s)).
-  Proof.
-  simple induction s; simpl.
-  auto.
-  intros x l Hrec Hs f; inversion_clear Hs.
-  generalize (@partition_aux_1 _ H0 f x).
-  generalize (Hrec H0 f).
-  case (f x); case (partition f l); simpl; auto.
-  Qed.
-  
-  Lemma partition_unique_2 :
-   forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (snd (partition f s)).
-  Proof.
-  simple induction s; simpl.
-  auto.
-  intros x l Hrec Hs f; inversion_clear Hs.
-  generalize (@partition_aux_2 _ H0 f x).
-  generalize (Hrec H0 f).
-  case (f x); case (partition f l); simpl; auto.
-  Qed.
-
-  Definition eq : t -> t -> Prop := Equal.
-
-  Lemma eq_refl : forall s, eq s s. 
-  Proof. firstorder. Qed.
-
-  Lemma eq_sym : forall s s', eq s s' -> eq s' s.
-  Proof. firstorder. Qed.
-
-  Lemma eq_trans : 
-   forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
-  Proof. firstorder. Qed.
-
-  Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), 
-   { eq s s' }+{ ~eq s s' }.
-  Proof.
-  intros.
-  change eq with Equal.
-  case_eq (equal s s'); intro H; [left | right].
-  apply equal_2; auto.
-  intro H'; rewrite equal_1 in H; auto; discriminate.
-  Defined.
-
-  End ForNotations.
-End Raw.
-
-(** * Encapsulation
-
-   Now, in order to really provide a functor implementing [S], we 
-   need to encapsulate everything into a type of lists without redundancy. *)
+Require Equalities FSetCompat MSetWeakList.
 
 Module Make (X: DecidableType) <: WS with Module E := X.
-
- Module Raw := Raw X. 
  Module E := X.
-
- Record slist := {this :> Raw.t; unique : NoDupA E.eq this}.
- Definition t := slist. 
- Definition elt := E.t.
- 
- Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
- Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
- Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
- Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
- Definition For_all (P : elt -> Prop) (s : t) : Prop :=
-   forall x : elt, In x s -> P x.
- Definition Exists (P : elt -> Prop) (s : t) : Prop := exists x : elt, In x s /\ P x.
-
- Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
- Definition add (x : elt)(s : t) : t  := Build_slist (Raw.add_unique (unique s) x).
- Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_unique (unique s) x).
- Definition singleton (x : elt) : t := Build_slist (Raw.singleton_unique x).
- Definition union (s s' : t) : t :=
-   Build_slist (Raw.union_unique (unique s) (unique s')). 
- Definition inter (s s' : t) : t :=
-   Build_slist (Raw.inter_unique (unique s) (unique s')). 
- Definition diff (s s' : t) : t :=
-   Build_slist (Raw.diff_unique (unique s) (unique s')). 
- Definition equal (s s' : t) : bool := Raw.equal s s'. 
- Definition subset (s s' : t) : bool := Raw.subset s s'.
- Definition empty : t := Build_slist Raw.empty_unique.
- Definition is_empty (s : t) : bool := Raw.is_empty s.
- Definition elements (s : t) : list elt := Raw.elements s.
- Definition choose (s:t) : option elt := Raw.choose s.
- Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. 
- Definition cardinal (s : t) : nat := Raw.cardinal s.
- Definition filter (f : elt -> bool) (s : t) : t :=
-   Build_slist (Raw.filter_unique (unique s) f).
- Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
- Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
- Definition partition (f : elt -> bool) (s : t) : t * t :=
-   let p := Raw.partition f s in
-   (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f),
-   Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)).
-
- Section Spec. 
-  Variable s s' : t.
-  Variable x y : elt.
-
-  Lemma In_1 : E.eq x y -> In x s -> In y s. 
-  Proof. exact (fun H H' => Raw.In_eq H H'). Qed.
- 
-  Lemma mem_1 : In x s -> mem x s = true.
-  Proof. exact (fun H => Raw.mem_1 H). Qed.
-  Lemma mem_2 : mem x s = true -> In x s. 
-  Proof. exact (fun H => Raw.mem_2 H). Qed.
- 
-  Lemma equal_1 : Equal s s' -> equal s s' = true.
-  Proof. exact (Raw.equal_1 s.(unique) s'.(unique)). Qed.
-  Lemma equal_2 : equal s s' = true -> Equal s s'.
-  Proof. exact (Raw.equal_2 s.(unique) s'.(unique)). Qed.
-
-  Lemma subset_1 : Subset s s' -> subset s s' = true.
-  Proof. exact (Raw.subset_1 s.(unique) s'.(unique)). Qed.
-  Lemma subset_2 : subset s s' = true -> Subset s s'.
-  Proof. exact (Raw.subset_2 s.(unique) s'.(unique)). Qed.
-
-  Lemma empty_1 : Empty empty.
-  Proof. exact Raw.empty_1. Qed.
-
-  Lemma is_empty_1 : Empty s -> is_empty s = true. 
-  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
-  Lemma is_empty_2 : is_empty s = true -> Empty s.
-  Proof. exact (fun H => Raw.is_empty_2 H). Qed.
- 
-  Lemma add_1 : E.eq x y -> In y (add x s).
-  Proof. exact (fun H => Raw.add_1 s.(unique) H). Qed.
-  Lemma add_2 : In y s -> In y (add x s).
-  Proof. exact (fun H => Raw.add_2 s.(unique) x H). Qed.
-  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
-  Proof. exact (fun H => Raw.add_3 s.(unique) H). Qed.
-
-  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
-  Proof. exact (fun H => Raw.remove_1 s.(unique) H). Qed.
-  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
-  Proof. exact (fun H H' => Raw.remove_2 s.(unique) H H'). Qed.
-  Lemma remove_3 : In y (remove x s) -> In y s.
-  Proof. exact (fun H => Raw.remove_3 s.(unique) H). Qed.
-
-  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
-  Proof. exact (fun H => Raw.singleton_1 H). Qed.
-  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
-  Proof. exact (fun H => Raw.singleton_2 H). Qed.
-
-  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
-  Proof. exact (fun H => Raw.union_1 s.(unique) s'.(unique) H). Qed.
-  Lemma union_2 : In x s -> In x (union s s'). 
-  Proof. exact (fun H => Raw.union_2 s.(unique) s'.(unique) H). Qed.
-  Lemma union_3 : In x s' -> In x (union s s').
-  Proof. exact (fun H => Raw.union_3 s.(unique) s'.(unique) H). Qed.
-
-  Lemma inter_1 : In x (inter s s') -> In x s.
-  Proof. exact (fun H => Raw.inter_1 s.(unique) s'.(unique) H). Qed.
-  Lemma inter_2 : In x (inter s s') -> In x s'.
-  Proof. exact (fun H => Raw.inter_2 s.(unique) s'.(unique) H). Qed.
-  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
-  Proof. exact (fun H => Raw.inter_3 s.(unique) s'.(unique) H). Qed.
-
-  Lemma diff_1 : In x (diff s s') -> In x s. 
-  Proof. exact (fun H => Raw.diff_1 s.(unique) s'.(unique) H). Qed.
-  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
-  Proof. exact (fun H => Raw.diff_2 s.(unique) s'.(unique) H). Qed.
-  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
-  Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed.
- 
-  Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
-      fold f s i = fold_left (fun a e => f e a) (elements s) i.
-  Proof. exact (Raw.fold_1 s.(unique)). Qed.
-
-  Lemma cardinal_1 : cardinal s = length (elements s).
-  Proof. exact (Raw.cardinal_1 s.(unique)). Qed.
-
-  Section Filter.
-  
-  Variable f : elt -> bool.
-
-  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
-  Proof. exact (fun H => @Raw.filter_1 s x f). Qed.
-  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
-  Proof. exact (@Raw.filter_2 s x f). Qed.
-  Lemma filter_3 :
-      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
-  Proof. exact (@Raw.filter_3 s x f). Qed.
-
-  Lemma for_all_1 :
-      compat_bool E.eq f ->
-      For_all (fun x => f x = true) s -> for_all f s = true.
-  Proof. exact (@Raw.for_all_1 s f). Qed.
-  Lemma for_all_2 :
-      compat_bool E.eq f ->
-      for_all f s = true -> For_all (fun x => f x = true) s.
-  Proof. exact (@Raw.for_all_2 s f). Qed.
-
-  Lemma exists_1 :
-      compat_bool E.eq f ->
-      Exists (fun x => f x = true) s -> exists_ f s = true.
-  Proof. exact (@Raw.exists_1 s f). Qed.
-  Lemma exists_2 :
-      compat_bool E.eq f ->
-      exists_ f s = true -> Exists (fun x => f x = true) s.
-  Proof. exact (@Raw.exists_2 s f). Qed.
-
-  Lemma partition_1 :
-      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
-  Proof. exact (@Raw.partition_1 s f). Qed.
-  Lemma partition_2 :
-      compat_bool E.eq f ->
-      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
-  Proof. exact (@Raw.partition_2 s f). Qed.
-
-  End Filter.
-
-  Lemma elements_1 : In x s -> InA E.eq x (elements s).
-  Proof. exact (fun H => Raw.elements_1 H). Qed.
-  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
-  Proof. exact (fun H => Raw.elements_2 H). Qed.
-  Lemma elements_3w : NoDupA E.eq (elements s).
-  Proof. exact (Raw.elements_3w s.(unique)). Qed.
-
-  Lemma choose_1 : choose s = Some x -> In x s.
-  Proof. exact (fun H => Raw.choose_1 H). Qed.
-  Lemma choose_2 : choose s = None -> Empty s.
-  Proof. exact (fun H => Raw.choose_2 H). Qed.
-
- End Spec.
-
- Definition eq : t -> t -> Prop := Equal.
-
- Lemma eq_refl : forall s, eq s s. 
- Proof. firstorder. Qed.
-
- Lemma eq_sym : forall s s', eq s s' -> eq s' s.
- Proof. firstorder. Qed.
-
- Lemma eq_trans : 
-  forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
- Proof. firstorder. Qed.
-
- Definition eq_dec : forall (s s':t), 
-  { eq s s' }+{ ~eq s s' }.
- Proof. 
-  intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). 
- Defined.
-
+ Module X' := Equalities.Update_DT X.
+ Module MSet := MSetWeakList.Make X'.
+ Include FSetCompat.Backport_WSets X MSet.
 End Make.
diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v
index a73c1da7..62a95734 100644
--- a/theories/FSets/FSets.v
+++ b/theories/FSets/FSets.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSets.v 10699 2008-03-19 20:56:43Z letouzey $ *)
+(* $Id$ *)
 
 Require Export OrderedType.
 Require Export OrderedTypeEx.
@@ -21,4 +21,5 @@ Require Export FSetProperties.
 Require Export FSetEqProperties.
 Require Export FSetWeakList.
 Require Export FSetList.
+Require Export FSetPositive.
 Require Export FSetAVL.
\ No newline at end of file
diff --git a/theories/FSets/vo.itarget b/theories/FSets/vo.itarget
new file mode 100644
index 00000000..0e7c11fb
--- /dev/null
+++ b/theories/FSets/vo.itarget
@@ -0,0 +1,21 @@
+FMapAVL.vo
+FMapFacts.vo
+FMapFullAVL.vo
+FMapInterface.vo
+FMapList.vo
+FMapPositive.vo
+FMaps.vo
+FMapWeakList.vo
+FSetCompat.vo
+FSetAVL.vo
+FSetPositive.vo
+FSetBridge.vo
+FSetDecide.vo
+FSetEqProperties.vo
+FSetFacts.vo
+FSetInterface.vo
+FSetList.vo
+FSetProperties.vo
+FSets.vo
+FSetToFiniteSet.vo
+FSetWeakList.vo
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index 0163c01c..6040f58b 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -6,12 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Datatypes.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
 Require Import Notations.
 Require Import Logic.
+Declare ML Module "nat_syntax_plugin".
+
 
 (** [unit] is a singleton datatype with sole inhabitant [tt] *)
 
@@ -72,6 +74,16 @@ Hint Resolve andb_true_intro: bool.
 
 Inductive eq_true : bool -> Prop := is_eq_true : eq_true true.
 
+Hint Constructors eq_true : eq_true.
+
+(** Another way of interpreting booleans as propositions *)
+
+Definition is_true b := b = true.
+
+(** [is_true] can be activated as a coercion by
+   (Local) Coercion is_true : bool >-> Prop.
+*)
+
 (** Additional rewriting lemmas about [eq_true] *)
 
 Lemma eq_true_ind_r :
@@ -94,7 +106,7 @@ Defined.
 
 (** [nat] is the datatype of natural numbers built from [O] and successor [S];
     note that the constructor name is the letter O.
-    Numbers in [nat] can be denoted using a decimal notation; 
+    Numbers in [nat] can be denoted using a decimal notation;
     e.g. [3%nat] abbreviates [S (S (S O))] *)
 
 Inductive nat : Set :=
@@ -114,8 +126,8 @@ Inductive Empty_set : Set :=.
     sole inhabitant is denoted [refl_identity A a] *)
 
 Inductive identity (A:Type) (a:A) : A -> Type :=
-  refl_identity : identity (A:=A) a a.
-Hint Resolve refl_identity: core.
+  identity_refl : identity a a.
+Hint Resolve identity_refl: core.
 
 Implicit Arguments identity_ind [A].
 Implicit Arguments identity_rec [A].
@@ -162,7 +174,7 @@ Section projections.
   Definition snd (p:A * B) := match p with
 				| (x, y) => y
                               end.
-End projections. 
+End projections.
 
 Hint Resolve pair inl inr: core.
 
@@ -177,13 +189,13 @@ Lemma injective_projections :
     fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
 Proof.
   destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
-  rewrite Hfst; rewrite Hsnd; reflexivity. 
+  rewrite Hfst; rewrite Hsnd; reflexivity.
 Qed.
 
-Definition prod_uncurry (A B C:Type) (f:prod A B -> C) 
+Definition prod_uncurry (A B C:Type) (f:prod A B -> C)
   (x:A) (y:B) : C := f (pair x y).
 
-Definition prod_curry (A B C:Type) (f:A -> B -> C) 
+Definition prod_curry (A B C:Type) (f:A -> B -> C)
   (p:prod A B) : C := match p with
                        | pair x y => f x y
                        end.
@@ -202,11 +214,84 @@ Definition CompOpp (r:comparison) :=
     | Gt => Lt
   end.
 
+Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c.
+Proof.
+  destruct c; reflexivity.
+Qed.
+
+Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'.
+Proof.
+  destruct c; destruct c'; auto; discriminate.
+Qed.
+
+Lemma CompOpp_iff : forall c c', CompOpp c = c' <-> c = CompOpp c'.
+Proof.
+  split; intros; apply CompOpp_inj; rewrite CompOpp_involutive; auto.
+Qed.
+
+(** The [CompSpec] inductive will be used to relate a [compare] function
+    (returning a comparison answer) and some equality and order predicates.
+    Interest: [CompSpec] behave nicely with [case] and [destruct]. *)
+
+Inductive CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop :=
+ | CompEq : eq x y -> CompSpec eq lt x y Eq
+ | CompLt : lt x y -> CompSpec eq lt x y Lt
+ | CompGt : lt y x -> CompSpec eq lt x y Gt.
+Hint Constructors CompSpec.
+
+(** For having clean interfaces after extraction, [CompSpec] is declared
+    in Prop. For some situations, it is nonetheless useful to have a
+    version in Type. Interestingly, these two versions are equivalent.
+*)
+
+Inductive CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type :=
+ | CompEqT : eq x y -> CompSpecT eq lt x y Eq
+ | CompLtT : lt x y -> CompSpecT eq lt x y Lt
+ | CompGtT : lt y x -> CompSpecT eq lt x y Gt.
+Hint Constructors CompSpecT.
+
+Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c,
+ CompSpec eq lt x y c -> CompSpecT eq lt x y c.
+Proof.
+ destruct c; intros H; constructor; inversion_clear H; auto.
+Defined.
+
 (** Identity *)
 
 Definition ID := forall A:Type, A -> A.
 Definition id : ID := fun A x => x.
 
+(** Polymorphic lists and some operations *)
+
+Inductive list (A : Type) : Type :=
+ | nil : list A
+ | cons : A -> list A -> list A.
+
+Implicit Arguments nil [A].
+Infix "::" := cons (at level 60, right associativity) : list_scope.
+Delimit Scope list_scope with list.
+Bind Scope list_scope with list.
+
+Local Open Scope list_scope.
+
+Definition length (A : Type) : list A -> nat :=
+  fix length l :=
+  match l with
+   | nil => O
+   | _ :: l' => S (length l')
+  end.
+
+(** Concatenation of two lists *)
+
+Definition app (A : Type) : list A -> list A -> list A :=
+  fix app l m :=
+  match l with
+   | nil => m
+   | a :: l1 => a :: app l1 m
+  end.
+
+Infix "++" := app (right associativity, at level 60) : list_scope.
+
 (* begin hide *)
 
 (* Compatibility *)
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index ae79744f..4fca1d1d 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -112,6 +112,16 @@ Proof.
 intros; tauto.
 Qed.
 
+Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
+Proof.
+intros; tauto.
+Qed.
+
+Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
+Proof.
+intros; tauto.
+Qed.
+
 Theorem or_cancel_l : forall A B C : Prop,
   (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
 Proof.
@@ -124,6 +134,16 @@ Proof.
 intros; tauto.
 Qed.
 
+Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
+Proof.
+intros; tauto.
+Qed.
+
+Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
+Proof.
+intros; tauto.
+Qed.
+
 (** Backward direction of the equivalences above does not need assumptions *)
 
 Theorem and_iff_compat_l : forall A B C : Prop,
@@ -243,7 +263,7 @@ End universal_quantification.
     [A] which is true of [x] is also true of [y] *)
 
 Inductive eq (A:Type) (x:A) : A -> Prop :=
-    refl_equal : x = x :>A
+    eq_refl : x = x :>A
 
 where "x = y :> A" := (@eq A x y) : type_scope.
 
@@ -251,11 +271,13 @@ Notation "x = y" := (x = y :>_) : type_scope.
 Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
 Notation "x <> y" := (x <> y :>_) : type_scope.
 
+Implicit Arguments eq [ [A] ].
+
 Implicit Arguments eq_ind [A].
 Implicit Arguments eq_rec [A].
 Implicit Arguments eq_rect [A].
 
-Hint Resolve I conj or_introl or_intror refl_equal: core.
+Hint Resolve I conj or_introl or_intror eq_refl: core.
 Hint Resolve ex_intro ex_intro2: core.
 
 Section Logic_lemmas.
@@ -271,17 +293,17 @@ Section Logic_lemmas.
     Variable f : A -> B.
     Variables x y z : A.
 
-    Theorem sym_eq : x = y -> y = x.
+    Theorem eq_sym : x = y -> y = x.
     Proof.
       destruct 1; trivial.
     Defined.
-    Opaque sym_eq.
+    Opaque eq_sym.
 
-    Theorem trans_eq : x = y -> y = z -> x = z.
+    Theorem eq_trans : x = y -> y = z -> x = z.
     Proof.
       destruct 2; trivial.
     Defined.
-    Opaque trans_eq.
+    Opaque eq_trans.
 
     Theorem f_equal : x = y -> f x = f y.
     Proof.
@@ -289,30 +311,26 @@ Section Logic_lemmas.
     Defined.
     Opaque f_equal.
 
-    Theorem sym_not_eq : x <> y -> y <> x.
+    Theorem not_eq_sym : x <> y -> y <> x.
     Proof.
       red in |- *; intros h1 h2; apply h1; destruct h2; trivial.
     Qed.
 
-    Definition sym_equal := sym_eq.
-    Definition sym_not_equal := sym_not_eq.
-    Definition trans_equal := trans_eq.
-
   End equality.
 
   Definition eq_ind_r :
     forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
-    intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
   Defined.
 
   Definition eq_rec_r :
     forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
-    intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
   Defined.
 
   Definition eq_rect_r :
     forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
-    intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
   Defined.
 End Logic_lemmas.
 
@@ -349,7 +367,18 @@ Proof.
   destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
 Qed.
 
-Hint Immediate sym_eq sym_not_eq: core.
+(* Aliases *)
+
+Notation sym_eq := eq_sym (only parsing).
+Notation trans_eq := eq_trans (only parsing).
+Notation sym_not_eq := not_eq_sym (only parsing).
+
+Notation refl_equal := eq_refl (only parsing).
+Notation sym_equal := eq_sym (only parsing).
+Notation trans_equal := eq_trans (only parsing).
+Notation sym_not_equal := not_eq_sym (only parsing).
+
+Hint Immediate eq_sym not_eq_sym: core.
 
 (** Basic definitions about relations and properties *)
 
@@ -411,7 +440,7 @@ intros A x y z H1 H2. rewrite <- H2; exact H1.
 Qed.
 
 Declare Left Step eq_stepl.
-Declare Right Step trans_eq.
+Declare Right Step eq_trans.
 
 Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
 Proof.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index c4e5f6c7..1333f354 100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic_Type.v 10840 2008-04-23 21:29:34Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This module defines type constructors for types in [Type]
     ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)
@@ -28,23 +28,23 @@ Section identity_is_a_congruence.
  Variable f : A -> B.
 
  Variables x y z : A.
- 
- Lemma sym_id : identity x y -> identity y x.
+
+ Lemma identity_sym : identity x y -> identity y x.
  Proof.
   destruct 1; trivial.
  Defined.
 
- Lemma trans_id : identity x y -> identity y z -> identity x z.
+ Lemma identity_trans : identity x y -> identity y z -> identity x z.
  Proof.
   destruct 2; trivial.
  Defined.
 
- Lemma congr_id : identity x y -> identity (f x) (f y).
+ Lemma identity_congr : identity x y -> identity (f x) (f y).
  Proof.
   destruct 1; trivial.
  Defined.
 
- Lemma sym_not_id : notT (identity x y) -> notT (identity y x).
+ Lemma not_identity_sym : notT (identity x y) -> notT (identity y x).
  Proof.
   red in |- *; intros H H'; apply H; destruct H'; trivial.
  Qed.
@@ -53,17 +53,22 @@ End identity_is_a_congruence.
 
 Definition identity_ind_r :
   forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
- intros A x P H y H0; case sym_id with (1 := H0); trivial.
+ intros A x P H y H0; case identity_sym with (1 := H0); trivial.
 Defined.
 
 Definition identity_rec_r :
   forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
- intros A x P H y H0; case sym_id with (1 := H0); trivial.
+ intros A x P H y H0; case identity_sym with (1 := H0); trivial.
 Defined.
 
 Definition identity_rect_r :
   forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
- intros A x P H y H0; case sym_id with (1 := H0); trivial.
+ intros A x P H y H0; case identity_sym with (1 := H0); trivial.
 Defined.
 
-Hint Immediate sym_id sym_not_id: core v62.
+Hint Immediate identity_sym not_identity_sym: core v62.
+
+Notation refl_id := identity_refl (only parsing).
+Notation sym_id := identity_sym (only parsing).
+Notation trans_id := identity_trans (only parsing).
+Notation sym_not_id := not_identity_sym (only parsing).
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 5f18edcd..0c628298 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Notations.v 12271 2009-08-11 10:29:45Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** These are the notations whose level and associativity are imposed by Coq *)
 
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
index 43b1f634..12a8f7a4 100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Peano.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** The type [nat] of Peano natural numbers (built from [O] and [S])
     is defined in [Datatypes.v] *)
@@ -77,8 +77,7 @@ Definition IsSucc (n:nat) : Prop :=
 
 Theorem O_S : forall n:nat, 0 <> S n.
 Proof.
-  unfold not; intros n H.
-  inversion H.
+  discriminate.
 Qed.
 Hint Resolve O_S: core.
 
@@ -90,7 +89,7 @@ Hint Resolve n_Sn: core.
 
 (** Addition *)
 
-Fixpoint plus (n m:nat) {struct n} : nat :=
+Fixpoint plus (n m:nat) : nat :=
   match n with
   | O => m
   | S p => S (p + m)
@@ -130,7 +129,7 @@ Notation plus_succ_r_reverse := plus_n_Sm (only parsing).
 
 (** Multiplication *)
 
-Fixpoint mult (n m:nat) {struct n} : nat :=
+Fixpoint mult (n m:nat) : nat :=
   match n with
   | O => 0
   | S p => m + p * m
@@ -161,7 +160,7 @@ Notation mult_succ_r_reverse := mult_n_Sm (only parsing).
 
 (** Truncated subtraction: [m-n] is [0] if [n>=m] *)
 
-Fixpoint minus (n m:nat) {struct n} : nat :=
+Fixpoint minus (n m:nat) : nat :=
   match n, m with
   | O, _ => n
   | S k, O => n
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 6492c948..685c7247 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Prelude.v 10064 2007-08-08 15:32:36Z msozeau $ i*)
+(*i $Id$ i*)
 
 Require Export Notations.
 Require Export Logic.
@@ -15,3 +15,12 @@ Require Export Specif.
 Require Export Peano.
 Require Export Coq.Init.Wf.
 Require Export Coq.Init.Tactics.
+(* Initially available plugins
+   (+ nat_syntax_plugin loaded in Datatypes) *)
+Declare ML Module "extraction_plugin".
+Declare ML Module "cc_plugin".
+Declare ML Module "ground_plugin".
+Declare ML Module "dp_plugin".
+Declare ML Module "recdef_plugin".
+Declare ML Module "subtac_plugin".
+Declare ML Module "xml_plugin".
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index c0f5c42a..7141f26c 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Specif.v 10923 2008-05-12 18:25:06Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Basic specifications : sets that may contain logical information *)
 
@@ -18,9 +18,9 @@ Require Import Logic.
 
 (** Subsets and Sigma-types *)
 
-(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset 
+(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset
     of elements of the type [A] which satisfy the predicate [P].
-    Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset 
+    Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset
     of elements of the type [A] which satisfy both [P] and [Q]. *)
 
 Inductive sig (A:Type) (P:A -> Prop) : Type :=
@@ -29,7 +29,7 @@ Inductive sig (A:Type) (P:A -> Prop) : Type :=
 Inductive sig2 (A:Type) (P Q:A -> Prop) : Type :=
     exist2 : forall x:A, P x -> Q x -> sig2 P Q.
 
-(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. 
+(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type.
     Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)
 
 Inductive sigT (A:Type) (P:A -> Type) : Type :=
@@ -123,7 +123,7 @@ Coercion sig_of_sigT : sigT >-> sig.
 
 Inductive sumbool (A B:Prop) : Set :=
   | left : A -> {A} + {B}
-  | right : B -> {A} + {B} 
+  | right : B -> {A} + {B}
  where "{ A } + { B }" := (sumbool A B) : type_scope.
 
 Add Printing If sumbool.
@@ -133,7 +133,7 @@ Add Printing If sumbool.
 
 Inductive sumor (A:Type) (B:Prop) : Type :=
   | inleft : A -> A + {B}
-  | inright : B -> A + {B} 
+  | inright : B -> A + {B}
  where "A + { B }" := (sumor A B) : type_scope.
 
 Add Printing If sumor.
@@ -148,50 +148,57 @@ Section Choice_lemmas.
   Variables R1 R2 : S -> Prop.
 
   Lemma Choice :
-   (forall x:S, sig (fun y:S' => R x y)) ->
-   sig (fun f:S -> S' => forall z:S, R z (f z)).
+   (forall x:S, {y:S' | R x y}) -> {f:S -> S' | forall z:S, R z (f z)}.
   Proof.
    intro H.
-   exists (fun z:S => match H z with
-                      | exist y _ => y
-                      end).
+   exists (fun z => proj1_sig (H z)).
    intro z; destruct (H z); trivial.
   Qed.
 
   Lemma Choice2 :
-   (forall x:S, sigT (fun y:S' => R' x y)) ->
-   sigT (fun f:S -> S' => forall z:S, R' z (f z)).
+   (forall x:S, {y:S' & R' x y}) -> {f:S -> S' & forall z:S, R' z (f z)}.
   Proof.
     intro H.
-    exists (fun z:S => match H z with
-                       | existT y _ => y
-                       end).
+    exists (fun z => projT1 (H z)).
     intro z; destruct (H z); trivial.
   Qed.
 
   Lemma bool_choice :
    (forall x:S, {R1 x} + {R2 x}) ->
-   sig
-     (fun f:S -> bool =>
-        forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x).
+     {f:S -> bool | forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x}.
   Proof.
     intro H.
-    exists
-     (fun z:S => match H z with
-                 | left _ => true
-                 | right _ => false
-                 end).
+    exists (fun z:S => if H z then true else false).
     intro z; destruct (H z); auto.
   Qed.
 
 End Choice_lemmas.
 
- (** A result of type [(Exc A)] is either a normal value of type [A] or 
+Section Dependent_choice_lemmas.
+
+  Variables X : Set.
+  Variable R : X -> X -> Prop.
+
+  Lemma dependent_choice :
+    (forall x:X, {y | R x y}) ->
+    forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}.
+  Proof.
+    intros H x0.
+    set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end).
+    exists f.
+    split. reflexivity.
+    induction n; simpl; apply proj2_sig.
+  Qed.
+
+End Dependent_choice_lemmas.
+
+
+ (** A result of type [(Exc A)] is either a normal value of type [A] or
      an [error] :
 
      [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)].
 
-     It is implemented using the option type. *) 
+     It is implemented using the option type. *)
 
 Definition Exc := option.
 Definition value := Some.
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 48b4568d..3e860fd4 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -6,45 +6,52 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Tactics.v 13198 2010-06-25 22:36:20Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import Notations.
 Require Import Logic.
+Require Import Specif.
 
 (** * Useful tactics *)
 
-(** A tactic for proof by contradiction. With contradict H, 
+(** Ex falso quodlibet : a tactic for proving False instead of the current goal.
+    This is just a nicer name for tactics such as [elimtype False]
+    and other [cut False]. *)
+
+Ltac exfalso := elimtype False.
+
+(** A tactic for proof by contradiction. With contradict H,
     -   H:~A |-  B    gives       |-  A
     -   H:~A |- ~B    gives  H: B |-  A
     -   H: A |-  B    gives       |- ~A
     -   H: A |- ~B    gives  H: B |- ~A
     -   H:False leads to a resolved subgoal.
-   Moreover, negations may be in unfolded forms, 
+   Moreover, negations may be in unfolded forms,
    and A or B may live in Type *)
 
 Ltac contradict H :=
   let save tac H := let x:=fresh in intro x; tac H; rename x into H
-  in 
-  let negpos H := case H; clear H 
-  in 
+  in
+  let negpos H := case H; clear H
+  in
   let negneg H := save negpos H
   in
-  let pospos H := 
-    let A := type of H in (elimtype False; revert H; try fold (~A))
+  let pospos H :=
+    let A := type of H in (exfalso; revert H; try fold (~A))
   in
   let posneg H := save pospos H
-  in 
-  let neg H := match goal with 
+  in
+  let neg H := match goal with
    | |- (~_) => negneg H
    | |- (_->False) => negneg H
    | |- _ => negpos H
-  end in 
-  let pos H := match goal with 
+  end in
+  let pos H := match goal with
    | |- (~_) => posneg H
    | |- (_->False) => posneg H
    | |- _ => pospos H
   end in
-  match type of H with 
+  match type of H with
    | (~_) => neg H
    | (_->False) => neg H
    | _ => (elim H;fail) || pos H
@@ -52,20 +59,20 @@ Ltac contradict H :=
 
 (* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*)
 
-Ltac swap H := 
+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 := 
+Ltac absurd_hyp H :=
   idtac "absurd_hyp is OBSOLETE: use contradict instead.";
-  let T := type of H in 
+  let T := type of H in
   absurd T.
 
 (* A useful complement to contradict. Here H:A while G allows to conclude ~A *)
 
-Ltac false_hyp H G := 
+Ltac false_hyp H G :=
   let T := type of H in absurd T; [ apply G | assumption ].
 
 (* A case with no loss of information. *)
@@ -76,13 +83,21 @@ Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x.
 
 Tactic Notation "destruct_with_eqn" constr(x) :=
   destruct x as []_eqn.
-Tactic Notation "destruct_with_eqn" ident(n) := 
+Tactic Notation "destruct_with_eqn" ident(n) :=
   try intros until n; destruct n as []_eqn.
 Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) :=
   destruct x as []_eqn:H.
-Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := 
+Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) :=
   try intros until n; destruct n as []_eqn:H.
 
+(** Break every hypothesis of a certain type *)
+
+Ltac destruct_all t :=
+ match goal with
+  | x : t |- _ => destruct x; destruct_all t
+  | _ => idtac
+ end.
+
 (* Rewriting in all hypothesis several times everywhere *)
 
 Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *.
@@ -148,7 +163,7 @@ bapply lemma ltac:(fun H => destruct H as [_ H]; apply H in J).
 
 (** An experimental tactic simpler than auto that is useful for ending
     proofs "in one step" *)
-  
+
 Ltac easy :=
   let rec use_hyp H :=
     match type of H with
@@ -167,14 +182,42 @@ Ltac easy :=
     solve [reflexivity | symmetry; trivial] ||
     contradiction ||
     (split; do_atom)
-  with do_ccl := trivial; repeat do_intro; do_atom in
+  with do_ccl := trivial with eq_true; repeat do_intro; do_atom in
   (use_hyps; do_ccl) || fail "Cannot solve this goal".
 
 Tactic Notation "now" tactic(t) := t; easy.
 
 (** A tactic to document or check what is proved at some point of a script *)
+
 Ltac now_show c := change c.
 
+(** Support for rewriting decidability statements *)
+
+Set Implicit Arguments.
+
+Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}),
+  C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide.
+Proof.
+intros; destruct decide. apply H0. contradiction.
+Qed.
+
+Lemma decide_right : forall (C:Prop) (decide:{C}+{~C}),
+  ~C -> forall P:{C}+{~C}->Prop, (forall H:~C, P (right _ H)) -> P decide.
+Proof.
+intros; destruct decide. contradiction. apply H0.
+Qed.
+
+Tactic Notation "decide" constr(lemma) "with" constr(H) :=
+  let try_to_merge_hyps H :=
+     try (clear H; intro H) ||
+     (let H' := fresh H "bis" in intro H'; try clear H') ||
+     (let H' := fresh in intro H'; try clear H') in
+  match type of H with
+  | ~ ?C => apply (decide_right lemma H); try_to_merge_hyps H
+  | ?C -> False => apply (decide_right lemma H); try_to_merge_hyps H
+  | _ => apply (decide_left lemma H); try_to_merge_hyps H
+  end.
+
 (** Clear an hypothesis and its dependencies *)
 
 Tactic Notation "clear" "dependent" hyp(h) :=
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
index d3f8f1ab..3209860f 100644
--- a/theories/Init/Wf.v
+++ b/theories/Init/Wf.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf.v 11251 2008-07-24 08:28:40Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** * This module proves the validity of
     - well-founded recursion (also known as course of values)
@@ -65,14 +65,14 @@ Section Well_founded.
   exact (fun P:A -> Prop => well_founded_induction_type P).
  Defined.
 
-(** Well-founded fixpoints *) 
+(** Well-founded fixpoints *)
 
  Section FixPoint.
 
   Variable P : A -> Type.
   Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.
 
-  Fixpoint Fix_F (x:A) (a:Acc x) {struct a} : P x :=
+  Fixpoint Fix_F (x:A) (a:Acc x) : P x :=
     F (fun (y:A) (h:R y x) => Fix_F (Acc_inv a h)).
 
   Scheme Acc_inv_dep := Induction for Acc Sort Prop.
@@ -80,13 +80,13 @@ Section Well_founded.
   Lemma Fix_F_eq :
    forall (x:A) (r:Acc x),
      F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)) = Fix_F (x:=x) r.
-  Proof. 
+  Proof.
    destruct r using Acc_inv_dep; auto.
   Qed.
 
   Definition Fix (x:A) := Fix_F (Rwf x).
 
-  (** Proof that [well_founded_induction] satisfies the fixpoint equation. 
+  (** Proof that [well_founded_induction] satisfies the fixpoint equation.
       It requires an extra property of the functional *)
 
   Hypothesis
@@ -111,7 +111,7 @@ Section Well_founded.
 
  End FixPoint.
 
-End Well_founded. 
+End Well_founded.
 
 (** Well-founded fixpoints over pairs *)
 
@@ -120,7 +120,7 @@ Section Well_founded_2.
   Variables A B : Type.
   Variable R : A * B -> A * B -> Prop.
 
-  Variable P : A -> B -> Type. 
+  Variable P : A -> B -> Type.
 
   Section FixPoint_2.
 
@@ -129,8 +129,7 @@ Section Well_founded_2.
       forall (x:A) (x':B),
         (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x'.
 
-  Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : 
-   P x x' :=
+  Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) : P x x' :=
     F
       (fun (y:A) (y':B) (h:R (y, y') (x, x')) =>
          Fix_F_2 (x:=y) (x':=y') (Acc_inv a (y,y') h)).
diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget
new file mode 100644
index 00000000..f53d55e7
--- /dev/null
+++ b/theories/Init/vo.itarget
@@ -0,0 +1,9 @@
+Datatypes.vo
+Logic_Type.vo
+Logic.vo
+Notations.vo
+Peano.vo
+Prelude.vo
+Specif.vo
+Tactics.vo
+Wf.vo
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index c015854e..f42dc7fa 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: List.v 12446 2009-10-29 21:43:06Z glondu $ i*)
+(*i $Id$ i*)
 
 Require Import Le Gt Minus Min Bool.
 
@@ -17,78 +17,47 @@ Set Implicit Arguments.
 (** * Basics: definition of polymorphic lists and some operations *)
 (******************************************************************)
 
-(** ** Definitions *)
+(** The definition of [list] is now in [Init/Datatypes],
+    as well as the definitions of [length] and [app] *)
+
+Open Scope list_scope.
 
 Section Lists.
 
   Variable A : Type.
 
-  Inductive list : Type :=
-    | nil : list
-    | cons : A -> list -> list.
-
-  Infix "::" := cons (at level 60, right associativity) : list_scope.
+  (** Head and tail *)
 
-  Open Scope list_scope.
+  Definition hd (default:A) (l:list A) :=
+    match l with
+      | nil => default
+      | x :: _ => x
+    end.
 
-  (** Head and tail        *)
-  Definition head (l:list) :=
+  Definition hd_error (l:list A) :=
     match l with
       | nil => error
       | x :: _ => value x
     end.
 
- Definition hd (default:A) (l:list) :=
-   match l with
-     | nil => default
-     | x :: _ => x
-   end. 
-
-  Definition tail (l:list) : list :=
+  Definition tl (l:list A) :=
     match l with
       | nil => nil
       | a :: m => m
     end.
 
-  (** Length of lists                *)
-  Fixpoint length (l:list) : nat :=
-    match l with
-      | nil => 0
-      | _ :: m => S (length m)
-    end.
-
   (** The [In] predicate *)
-  Fixpoint In (a:A) (l:list) {struct l} : Prop :=
+  Fixpoint In (a:A) (l:list A) : Prop :=
     match l with
       | nil => False
       | b :: m => b = a \/ In a m
     end.
 
-
-  (** Concatenation of two lists *)
-  Fixpoint app (l m:list) {struct l} : list :=
-    match l with
-      | nil => m
-      | a :: l1 => a :: app l1 m
-    end.
-  
-  Infix "++" := app (right associativity, at level 60) : list_scope.
-  
 End Lists.
 
-(** Exporting list notations and tactics *)
-
-Implicit Arguments nil [A].
-Infix "::" := cons (at level 60, right associativity) : list_scope.
-Infix "++" := app (right associativity, at level 60) : list_scope.
-
-Open Scope list_scope.
-
-Delimit Scope list_scope with list.
-
-Bind Scope list_scope with list.
-
-Arguments Scope list [type_scope].
+(* Keep these notations local to prevent conflicting notations *)
+Local Notation "[ ]" := nil : list_scope.
+Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : list_scope.
 
 (** ** Facts about lists *)
 
@@ -100,164 +69,172 @@ Section Facts.
   (** *** Genereric facts *)
 
   (** Discrimination *)
-  Theorem nil_cons : forall (x:A) (l:list A), nil <> x :: l.
-  Proof. 
+  Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
+  Proof.
     intros; discriminate.
   Qed.
 
 
   (** Destruction *)
 
-  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = nil}.
+  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = []}.
   Proof.
-    induction l as [|a tl].
+    induction l as [|a tail].
     right; reflexivity.
-    left; exists a; exists tl; reflexivity.
+    left; exists a, tail; reflexivity.
   Qed.
-    
+
   (** *** Head and tail *)
-  
-  Theorem head_nil : head (@nil A) = None.
+
+  Theorem hd_error_nil : hd_error (@nil A) = None.
   Proof.
     simpl; reflexivity.
   Qed.
 
-  Theorem head_cons : forall (l : list A) (x : A), head (x::l) = Some x.
+  Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x.
   Proof.
     intros; simpl; reflexivity.
   Qed.
 
 
   (************************)
-  (** *** Facts about [In] *) 
+  (** *** Facts about [In] *)
   (************************)
 
 
   (** Characterization of [In] *)
-  
+
   Theorem in_eq : forall (a:A) (l:list A), In a (a :: l).
-  Proof. 
-    simpl in |- *; auto.
+  Proof.
+    simpl; auto.
   Qed.
-  
+
   Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
-  Proof. 
-    simpl in |- *; auto.
+  Proof.
+    simpl; auto.
   Qed.
 
-  Theorem in_nil : forall a:A, ~ In a nil.
+  Theorem in_nil : forall a:A, ~ In a [].
   Proof.
-    unfold not in |- *; intros a H; inversion_clear H.
+    unfold not; intros a H; inversion_clear H.
   Qed.
 
-  Lemma In_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2.
+  Theorem in_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2.
   Proof.
   induction l; simpl; destruct 1.
   subst a; auto.
-  exists (@nil A); exists l; auto.
+  exists [], l; auto.
   destruct (IHl H) as (l1,(l2,H0)).
-  exists (a::l1); exists l2; simpl; f_equal; auto.
+  exists (a::l1), l2; simpl; f_equal; auto.
   Qed.
 
   (** Inversion *)
-  Theorem in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
+  Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
   Proof.
     intros a b l H; inversion_clear H; auto.
   Qed.
 
   (** Decidability of [In] *)
-  Theorem In_dec :
+  Theorem in_dec :
     (forall x y:A, {x = y} + {x <> y}) ->
     forall (a:A) (l:list A), {In a l} + {~ In a l}.
   Proof.
     intro H; induction l as [| a0 l IHl].
     right; apply in_nil.
-    destruct (H a0 a); simpl in |- *; auto.
-    destruct IHl; simpl in |- *; auto. 
-    right; unfold not in |- *; intros [Hc1| Hc2]; auto.
+    destruct (H a0 a); simpl; auto.
+    destruct IHl; simpl; auto.
+    right; unfold not; intros [Hc1| Hc2]; auto.
   Defined.
 
 
-  (*************************)
+  (**************************)
   (** *** Facts about [app] *)
-  (*************************)
+  (**************************)
 
   (** Discrimination *)
-  Theorem app_cons_not_nil : forall (x y:list A) (a:A), nil <> x ++ a :: y.
+  Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y.
   Proof.
-    unfold not in |- *.
-    destruct x as [| a l]; simpl in |- *; intros.
+    unfold not.
+    destruct x as [| a l]; simpl; intros.
     discriminate H.
     discriminate H.
   Qed.
 
 
   (** Concat with [nil] *)
+  Theorem app_nil_l : forall l:list A, [] ++ l = l.
+  Proof.
+    reflexivity.
+  Qed.
 
-  Theorem app_nil_end : forall l:list A, l = l ++ nil.
-  Proof. 
-    induction l; simpl in |- *; auto.
-    rewrite <- IHl; auto.
+  Theorem app_nil_r : forall l:list A, l ++ [] = l.
+  Proof.
+    induction l; simpl; f_equal; auto.
   Qed.
 
+  (* begin hide *)
+  (* Deprecated *)
+  Theorem app_nil_end : forall (l:list A), l = l ++ [].
+  Proof. symmetry; apply app_nil_r. Qed.
+  (* end hide *)
+
   (** [app] is associative *)
-  Theorem app_ass : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
-  Proof. 
-    intros. induction l; simpl in |- *; auto.
-    now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n).
-    rewrite <- IHl; auto.
+  Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
+  Proof.
+    intros l m n; induction l; simpl; f_equal; auto.
   Qed.
-  Hint Resolve app_ass.
 
-  Theorem ass_app : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
-  Proof. 
-    auto using app_ass.
+  (* begin hide *)
+  (* Deprecated *)
+  Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
+  Proof.
+     auto using app_assoc.
   Qed.
+  Hint Resolve app_assoc_reverse.
+  (* end hide *)
 
-  (** [app] commutes with [cons] *) 
+  (** [app] commutes with [cons] *)
   Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
   Proof.
     auto.
   Qed.
 
+  (** Facts deduced from the result of a concatenation *)
 
-
-  (** Facts deduced from the result of a concatenation *)  
-
-  Theorem app_eq_nil : forall l l':list A, l ++ l' = nil -> l = nil /\ l' = nil.
+  Theorem app_eq_nil : forall l l':list A, l ++ l' = [] -> l = [] /\ l' = [].
   Proof.
-    destruct l as [| x l]; destruct l' as [| y l']; simpl in |- *; auto.
+    destruct l as [| x l]; destruct l' as [| y l']; simpl; auto.
     intro; discriminate.
     intros H; discriminate H.
   Qed.
 
   Theorem app_eq_unit :
     forall (x y:list A) (a:A),
-      x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil.
+      x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
   Proof.
     destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
-      simpl in |- *.
+      simpl.
     intros a H; discriminate H.
     left; split; auto.
     right; split; auto.
     generalize H.
-    generalize (app_nil_end l); intros E.
-    rewrite <- E; auto.
+    generalize (app_nil_r l); intros E.
+    rewrite -> E; auto.
     intros.
     injection H.
     intro.
-    cut (nil = l ++ a0 :: l0); auto.
+    cut ([] = l ++ a0 :: l0); auto.
     intro.
     generalize (app_cons_not_nil _ _ _ H1); intro.
     elim H2.
   Qed.
 
   Lemma app_inj_tail :
-    forall (x y:list A) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b.
+    forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b.
   Proof.
     induction x as [| x l IHl];
-      [ destruct y as [| a l] | destruct y as [| a l0] ]; 
-      simpl in |- *; auto.
+      [ destruct y as [| a l] | destruct y as [| a l0] ];
+      simpl; auto.
     intros a b H.
     injection H.
     auto.
@@ -266,12 +243,12 @@ Section Facts.
     generalize (app_cons_not_nil _ _ _ H0); destruct 1.
     intros a b H.
     injection H; intros.
-    cut (nil = l ++ a :: nil); auto.
+    cut ([] = l ++ [a]); auto.
     intro.
     generalize (app_cons_not_nil _ _ _ H2); destruct 1.
     intros a0 b H.
     injection H; intros.
-    destruct (IHl l0 a0 b H0). 
+    destruct (IHl l0 a0 b H0).
     split; auto.
     rewrite <- H1; rewrite <- H2; reflexivity.
   Qed.
@@ -285,9 +262,9 @@ Section Facts.
   Qed.
 
   Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m.
-  Proof. 
+  Proof.
     intros l m a.
-    elim l; simpl in |- *; auto.
+    elim l; simpl; auto.
     intros a0 y H H0.
     now_show ((a0 = a \/ In a y) \/ In a m).
     elim H0; auto.
@@ -297,9 +274,9 @@ Section Facts.
   Qed.
 
   Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m).
-  Proof. 
+  Proof.
     intros l m a.
-    elim l; simpl in |- *; intro H.
+    elim l; simpl; intro H.
     now_show (In a m).
     elim H; auto; intro H0.
     now_show (In a m).
@@ -311,18 +288,23 @@ Section Facts.
     now_show (H = a \/ In a (y ++ m)).
     elim H2; auto.
   Qed.
-  
+
+  Lemma in_app_iff : forall l l' (a:A), In a (l++l') <-> In a l \/ In a l'.
+  Proof.
+    split; auto using in_app_or, in_or_app.
+  Qed.
+
   Lemma app_inv_head:
-   forall l l1 l2 : list A, l ++ l1 = l ++ l2 ->  l1 = l2.
+   forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2.
   Proof.
     induction l; simpl; auto; injection 1; auto.
   Qed.
- 
+
   Lemma app_inv_tail:
-    forall l l1 l2 : list A, l1 ++ l = l2 ++ l ->  l1 = l2.
+    forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2.
   Proof.
     intros l l1 l2; revert l1 l2 l.
-    induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; 
+    induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2];
      simpl; auto; intros l H.
     absurd (length (x2 :: l2 ++ l) <= length l).
     simpl; rewrite app_length; auto with arith.
@@ -335,10 +317,10 @@ Section Facts.
 
 End Facts.
 
-Hint Resolve app_nil_end ass_app app_ass: datatypes v62.
+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 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.
 
 
@@ -359,7 +341,7 @@ Section Elts.
     match n, l with
       | O, x :: l' => x
       | O, other => default
-      | S m, nil => default
+      | S m, [] => default
       | S m, x :: t => nth m t default
     end.
 
@@ -367,26 +349,26 @@ Section Elts.
     match n, l with
       | O, x :: l' => true
       | O, other => false
-      | S m, nil => false
+      | S m, [] => false
       | S m, x :: t => nth_ok m t default
     end.
 
   Lemma nth_in_or_default :
     forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
   (* Realizer nth_ok. Program_all. *)
-  Proof. 
+  Proof.
     intros n l d; generalize n; induction l; intro n0.
     right; case n0; trivial.
-    case n0; simpl in |- *.
+    case n0; simpl.
     auto.
-    intro n1; elim (IHl n1); auto.     
+    intro n1; elim (IHl n1); auto.
   Qed.
 
   Lemma nth_S_cons :
     forall (n:nat) (l:list A) (d a:A),
       In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
-  Proof. 
-    simpl in |- *; auto.
+  Proof.
+    simpl; auto.
   Qed.
 
   Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A :=
@@ -402,13 +384,19 @@ Section Elts.
       | None => default
     end.
 
+  Lemma nth_default_eq :
+    forall n l (d:A), nth_default d l n = nth n l d.
+  Proof.
+    unfold nth_default; induction n; intros [ | ] ?; simpl; auto.
+  Qed.
+
   Lemma nth_In :
     forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.
 
   Proof.
-    unfold lt in |- *; induction n as [| n hn]; simpl in |- *.
-    destruct l; simpl in |- *; [ inversion 2 | auto ].
-    destruct l as [| a l hl]; simpl in |- *.
+    unfold lt; induction n as [| n hn]; simpl.
+    destruct l; simpl; [ inversion 2 | auto ].
+    destruct l as [| a l hl]; simpl.
     inversion 2.
     intros d ie; right; apply hn; auto with arith.
   Qed.
@@ -420,7 +408,7 @@ Section Elts.
     apply IHl; auto with arith.
   Qed.
 
-  Lemma nth_indep : 
+  Lemma nth_indep :
     forall l n d d', n < length l -> nth n l d = nth n l d'.
   Proof.
     induction l; simpl; intros; auto.
@@ -428,7 +416,7 @@ Section Elts.
     destruct n; simpl; auto with arith.
   Qed.
 
-  Lemma app_nth1 : 
+  Lemma app_nth1 :
     forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
   Proof.
     induction l.
@@ -439,7 +427,7 @@ Section Elts.
     intros; rewrite IHl; auto with arith.
   Qed.
 
-  Lemma app_nth2 : 
+  Lemma app_nth2 :
     forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
   Proof.
     induction l.
@@ -461,53 +449,49 @@ Section Elts.
   (** ** Remove    *)
   (*****************)
 
-  Section Remove.
+  Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.
 
-    Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.
-    
-    Fixpoint remove (x : A) (l : list A){struct l} : list A :=
-      match l with
-	| nil => nil
-	| y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
-      end.
-    
-    Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l).
-    Proof.
-      induction l as [|x l]; auto.
-      intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. 
-      apply IHl.
-      unfold not; intro HF; simpl in HF; destruct HF; auto.
-      apply (IHl y); assumption. 
-    Qed.
-  
-  End Remove.
+  Fixpoint remove (x : A) (l : list A) : list A :=
+    match l with
+      | [] => []
+      | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
+    end.
+
+  Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l).
+  Proof.
+    induction l as [|x l]; auto.
+    intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx].
+    apply IHl.
+    unfold not; intro HF; simpl in HF; destruct HF; auto.
+    apply (IHl y); assumption.
+  Qed.
 
 
 (******************************)
 (** ** Last element of a list *)
 (******************************)
 
-  (** [last l d] returns the last element of the list [l], 
+  (** [last l d] returns the last element of the list [l],
     or the default value [d] if [l] is empty. *)
 
-  Fixpoint last (l:list A) (d:A)  {struct l} : A := 
-  match l with 
-    | nil => d 
-    | a :: nil => a 
+  Fixpoint last (l:list A) (d:A) : A :=
+  match l with
+    | [] => d
+    | [a] => a
     | a :: l => last l d
   end.
 
   (** [removelast l] remove the last element of [l] *)
 
-  Fixpoint removelast (l:list A) {struct l} : list A := 
-    match l with 
-      | nil =>  nil 
-      | a :: nil => nil 
+  Fixpoint removelast (l:list A) : list A :=
+    match l with
+      | [] =>  []
+      | [a] => []
       | a :: l => a :: removelast l
     end.
-  
-  Lemma app_removelast_last : 
-    forall l d, l<>nil -> l = removelast l ++ (last l d :: nil).
+
+  Lemma app_removelast_last :
+    forall l d, l <> [] -> l = removelast l ++ [last l d].
   Proof.
     induction l.
     destruct 1; auto.
@@ -515,27 +499,27 @@ Section Elts.
     destruct l; auto.
     pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
   Qed.
-  
-  Lemma exists_last : 
-    forall l, l<>nil -> { l' : (list A) & { a : A | l = l'++a::nil}}. 
-  Proof. 
+
+  Lemma exists_last :
+    forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}.
+  Proof.
     induction l.
     destruct 1; auto.
     intros _.
     destruct l.
-    exists (@nil A); exists a; auto.
+    exists [], a; auto.
     destruct IHl as [l' (a',H)]; try discriminate.
     rewrite H.
-    exists (a::l'); exists a'; auto.
+    exists (a::l'), a'; auto.
   Qed.
 
-  Lemma removelast_app : 
-    forall l l', l' <> nil -> removelast (l++l') = l ++ removelast l'.
+  Lemma removelast_app :
+    forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'.
   Proof.
     induction l.
     simpl; auto.
     simpl; intros.
-    assert (l++l' <> nil).
+    assert (l++l' <> []).
     destruct l.
     simpl; auto.
     simpl; discriminate.
@@ -543,32 +527,30 @@ Section Elts.
     destruct (l++l'); [elim H0; auto|f_equal; auto].
   Qed.
 
-  
+
   (****************************************)
   (** ** Counting occurences of a element *)
   (****************************************)
 
-  Hypotheses eqA_dec : forall x y : A, {x = y}+{x <> y}.
-  
-  Fixpoint count_occ (l : list A) (x : A){struct l} : nat :=
-    match l with 
-      | nil => 0
-      | y :: tl => 
-	let n := count_occ tl x in 
-	  if eqA_dec y x then S n else n
+  Fixpoint count_occ (l : list A) (x : A) : nat :=
+    match l with
+      | [] => 0
+      | y :: tl =>
+	let n := count_occ tl x in
+	  if eq_dec y x then S n else n
     end.
-  
+
   (** Compatibility of count_occ with operations on list *)
   Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0.
   Proof.
     induction l as [|y l].
     simpl; intros; split; [destruct 1 | apply gt_irrefl].
-    simpl. intro x; destruct (eqA_dec y x) as [Heq|Hneq].
-    rewrite Heq; intuition. 
+    simpl. intro x; destruct (eq_dec y x) as [Heq|Hneq].
+    rewrite Heq; intuition.
     pose (IHl x). intuition.
   Qed.
-  
-  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = nil.
+
+  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = [].
   Proof.
     split.
     (* Case -> *)
@@ -578,14 +560,14 @@ Section Elts.
     elim (O_S (count_occ l x)).
     apply sym_eq.
     generalize (H x).
-    simpl. destruct (eqA_dec x x) as [|HF].
+    simpl. destruct (eq_dec x x) as [|HF].
     trivial.
     elim HF; reflexivity.
     (* Case <- *)
     intro H; rewrite H; simpl; reflexivity.
   Qed.
-  
-  Lemma count_occ_nil : forall (x : A), count_occ nil x = 0.
+
+  Lemma count_occ_nil : forall (x : A), count_occ [] x = 0.
   Proof.
     intro x; simpl; reflexivity.
   Qed.
@@ -593,13 +575,13 @@ Section Elts.
   Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y).
   Proof.
     intros l x y H; simpl.
-    destruct (eqA_dec x y); [reflexivity | contradiction].
+    destruct (eq_dec x y); [reflexivity | contradiction].
   Qed.
-  
+
   Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y.
   Proof.
     intros l x y H; simpl.
-    destruct (eqA_dec x y); [contradiction | reflexivity]. 
+    destruct (eq_dec x y); [contradiction | reflexivity].
   Qed.
 
 End Elts.
@@ -620,38 +602,38 @@ Section ListOps.
 
   Fixpoint rev (l:list A) : list A :=
     match l with
-      | nil => nil
-      | x :: l' => rev l' ++ x :: nil
+      | [] => []
+      | x :: l' => rev l' ++ [x]
     end.
 
-  Lemma distr_rev : forall x y:list A, rev (x ++ y) = rev y ++ rev x.
+  Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x.
   Proof.
     induction x as [| a l IHl].
     destruct y as [| a l].
-    simpl in |- *.
+    simpl.
     auto.
 
-    simpl in |- *.
-    apply app_nil_end; auto.
+    simpl.
+    rewrite app_nil_r; auto.
 
     intro y.
-    simpl in |- *.
+    simpl.
     rewrite (IHl y).
-    apply (app_ass (rev y) (rev l) (a :: nil)).
+    rewrite app_assoc; trivial.
   Qed.
 
-  Remark rev_unit : forall (l:list A) (a:A), rev (l ++ a :: nil) = a :: rev l.
+  Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l.
   Proof.
     intros.
-    apply (distr_rev l (a :: nil)); simpl in |- *; auto.
+    apply (rev_app_distr l [a]); simpl; auto.
   Qed.
 
   Lemma rev_involutive : forall l:list A, rev (rev l) = l.
   Proof.
     induction l as [| a l IHl].
-    simpl in |- *; auto.
+    simpl; auto.
 
-    simpl in |- *.
+    simpl.
     rewrite (rev_unit (rev l) a).
     rewrite IHl; auto.
   Qed.
@@ -659,7 +641,7 @@ Section ListOps.
 
   (** Compatibility with other operations *)
 
-  Lemma In_rev : forall l x, In x l <-> In x (rev l).
+  Lemma in_rev : forall l x, In x l <-> In x (rev l).
   Proof.
     induction l.
     simpl; intuition.
@@ -681,7 +663,7 @@ Section ListOps.
     elim (length l); simpl; auto.
   Qed.
 
-  Lemma rev_nth : forall l d n,  n < length l ->  
+  Lemma rev_nth : forall l d n,  n < length l ->
     nth n (rev l) d = nth (length l - S n) l d.
   Proof.
     induction l.
@@ -704,309 +686,77 @@ Section ListOps.
   Qed.
 
 
-  (**  An alternative tail-recursive definition for reverse *) 
+  (**  An alternative tail-recursive definition for reverse *)
 
-  Fixpoint rev_append (l l': list A) {struct l} : list A := 
-    match l with 
-      | nil => l' 
+  Fixpoint rev_append (l l': list A) : list A :=
+    match l with
+      | [] => l'
       | a::l => rev_append l (a::l')
     end.
 
-  Definition rev' l : list A := rev_append l nil.
-
-  Notation rev_acc := rev_append (only parsing).
+  Definition rev' l : list A := rev_append l [].
 
-  Lemma rev_append_rev : forall l l', rev_acc l l' = rev l ++ l'.
+  Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'.
   Proof.
     induction l; simpl; auto; intros.
-    rewrite <- ass_app; firstorder.
+    rewrite <- app_assoc; firstorder.
   Qed.
 
-  Notation rev_acc_rev := rev_append_rev (only parsing).
-
-  Lemma rev_alt : forall l, rev l = rev_append l nil.
+  Lemma rev_alt : forall l, rev l = rev_append l [].
   Proof.
     intros; rewrite rev_append_rev.
-    apply app_nil_end.
+    rewrite app_nil_r; trivial.
   Qed.
 
 
 (*********************************************)
 (** Reverse Induction Principle on Lists  *)
 (*********************************************)
-  
+
   Section Reverse_Induction.
-    
-    Unset Implicit Arguments.
-    
+
     Lemma rev_list_ind :
       forall P:list A-> Prop,
-	P nil ->
+	P [] ->
 	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
 	forall l:list A, P (rev l).
     Proof.
       induction l; auto.
     Qed.
-    Set Implicit Arguments.
-    
+
     Theorem rev_ind :
       forall P:list A -> Prop,
-	P nil ->
-	(forall (x:A) (l:list A), P l -> P (l ++ x :: nil)) -> forall l:list A, P l.
+	P [] ->
+	(forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l.
     Proof.
       intros.
       generalize (rev_involutive l).
       intros E; rewrite <- E.
       apply (rev_list_ind P).
       auto.
-      
-      simpl in |- *.
+
+      simpl.
       intros.
       apply (H0 a (rev l0)).
       auto.
     Qed.
-  
-  End Reverse_Induction.
-
-
-
-  (***********************************)
-  (** ** Lists modulo permutation    *)
-  (***********************************)
-  
-  Section Permutation.
-
-    Inductive Permutation : list A -> list A -> Prop :=
-      | perm_nil: Permutation nil nil
-      | perm_skip: forall (x:A) (l l':list A), Permutation l l' -> Permutation (cons x l) (cons x l')
-      | perm_swap: forall (x y:A) (l:list A), Permutation (cons y (cons x l)) (cons x (cons y l))
-      | perm_trans: forall (l l' l'':list A), Permutation l l' -> Permutation l' l'' -> Permutation l l''.
-
-    Hint Constructors Permutation.
-
-  (** Some facts about [Permutation] *)
-
-    Theorem Permutation_nil : forall (l : list A), Permutation nil l -> l = nil.
-    Proof.
-      intros l HF.
-      set (m:=@nil A) in HF; assert (m = nil); [reflexivity|idtac]; clearbody m.
-      induction HF; try elim (nil_cons (sym_eq H)); auto.
-    Qed.
-
-    Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l).
-    Proof.
-      unfold not; intros l x HF.
-      elim (@nil_cons A x l). apply sym_eq. exact (Permutation_nil HF).
-    Qed.
-
-  (** Permutation over lists is a equivalence relation *)
-
-    Theorem Permutation_refl : forall l : list A, Permutation l l.
-    Proof.
-      induction l; constructor. exact IHl. 
-    Qed.
-
-    Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l.
-    Proof.
-      intros l l' Hperm; induction Hperm; auto.
-      apply perm_trans with (l':=l'); assumption.
-    Qed.
-
-    Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''.
-    Proof.
-      exact perm_trans.
-    Qed.
-
-    Hint Resolve Permutation_refl Permutation_sym Permutation_trans.
-
-  (** Compatibility with others operations on lists *)
-
-    Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'.
-    Proof.
-      intros l l' x Hperm; induction Hperm; simpl; tauto. 
-    Qed.
-
-    Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl).
-    Proof.
-      intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
-      eapply Permutation_trans with (l':=l'++tl); trivial.
-    Qed.
-
-    Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl').
-    Proof.
-      intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
-    Qed.
-
-    Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
-    Proof.
-      intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto.
-      apply Permutation_trans with (l' := (x :: y :: l ++ m));
-	[idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
-      apply Permutation_trans with (l' := (l' ++ m')); try assumption.
-      apply Permutation_app_tail; assumption.
-    Qed.
-
-    Theorem Permutation_app_swap : forall (l l' : list A), Permutation (l++l') (l'++l).
-    Proof.
-      induction l as [|x l]. 
-      simpl; intro l'; rewrite <- app_nil_end; trivial.
-      induction l' as [|y l'].
-      simpl; rewrite <- app_nil_end; trivial.
-      simpl; apply Permutation_trans with (l' := x :: y :: l' ++ l).
-      constructor; rewrite app_comm_cons; apply IHl.
-      apply Permutation_trans with (l' := y :: x :: l' ++ l); constructor.
-      apply Permutation_trans with (l' := x :: l ++ l'); auto.
-    Qed.
-  
-    Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
-      Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
-    Proof.
-    intros l l1; revert l.
-    induction l1.
-    simpl.
-    intros; apply perm_skip; auto.
-    simpl; intros.
-    apply perm_trans with (a0::a::l1++l2).
-    apply perm_skip; auto.
-    apply perm_trans with (a::a0::l1++l2).
-    apply perm_swap; auto.
-    apply perm_skip; auto.
-    Qed.
-    Hint Resolve Permutation_cons_app.
-
-    Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'.
-    Proof.
-      intros l l' Hperm; induction Hperm; simpl; auto.
-      apply trans_eq with (y:= (length l')); trivial.
-    Qed.
-
-    Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). 
-    Proof.
-      induction l as [| x l]; simpl; trivial.
-      apply Permutation_trans with (l' := (x::nil)++rev l).
-      simpl; auto.
-      apply Permutation_app_swap.
-    Qed.
-
-    Theorem Permutation_ind_bis : 
-     forall P : list A -> list A -> Prop,
-       P (@nil A) (@nil A) ->
-       (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
-       (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
-       (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
-       forall l l', Permutation l l' -> P l l'.
-    Proof.
-    intros P Hnil Hskip Hswap Htrans.
-    induction 1; auto.
-    apply Htrans with (x::y::l); auto.
-    apply Hswap; auto.
-    induction l; auto.
-    apply Hskip; auto.
-    apply Hskip; auto.
-    induction l; auto.
-    eauto.
-    Qed.
-
-    Ltac break_list l x l' H := 
-     destruct l as [|x l']; simpl in *; 
-     injection H; intros; subst; clear H.
-
-    Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
-      Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
-    Proof.
-    set (P:=fun l l' =>  
-             forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)).
-    cut (forall l l', Permutation l l' -> P l l').
-    intros; apply (H _ _ H0 a); auto.
-    intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto.
-    (* nil *)
-    intros; destruct l1; simpl in *; discriminate.
-    (* skip *)
-    intros x l l' H IH; intros.
-    break_list l1 b l1' H0; break_list l3 c l3' H1.
-    auto.
-    apply perm_trans with (l3'++c::l4); auto.
-    apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app.
-    apply perm_skip.
-    apply (IH a l1' l2 l3' l4); auto.
-    (* contradict *)
-    intros x y l l' Hp IH; intros.
-    break_list l1 b l1' H; break_list l3 c l3' H0.
-    auto.
-    break_list l3' b l3'' H.
-    auto.
-    apply perm_trans with (c::l3''++b::l4); auto.
-    break_list l1' c l1'' H1. 
-    auto.
-    apply perm_trans with (b::l1''++c::l2); auto.
-    break_list l3' d l3'' H; break_list l1' e l1'' H1. 
-    auto.
-    apply perm_trans with (e::a::l1''++l2); auto.
-    apply perm_trans with (e::l1''++a::l2); auto.
-    apply perm_trans with (d::a::l3''++l4); auto.
-    apply perm_trans with (d::l3''++a::l4); auto.
-    apply perm_trans with (e::d::l1''++l2); auto.
-    apply perm_skip; apply perm_skip.
-    apply (IH a l1'' l2 l3'' l4); auto.
-    (*trans*)
-    intros.
-    destruct (In_split a l') as (l'1,(l'2,H6)).
-    apply (Permutation_in a H).
-    subst l.
-    apply in_or_app; right; red; auto.
-    apply perm_trans with (l'1++l'2).
-    apply (H0 _ _ _ _ _ H3 H6).
-    apply (H2 _ _ _ _ _ H6 H4).
-    Qed.
-
-    Theorem Permutation_cons_inv : 
-       forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'.
-    Proof.
-    intros; exact (Permutation_app_inv (@nil _) l (@nil _) l' a H). 
-    Qed.
-
-    Theorem Permutation_cons_app_inv :
-       forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
-    Proof.
-    intros; exact (Permutation_app_inv (@nil _) l l1 l2 a H). 
-    Qed.
-    
-    Theorem Permutation_app_inv_l : 
-        forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
-    Proof.    
-    induction l; simpl; auto.
-    intros.
-    apply IHl.
-    apply Permutation_cons_inv with a; auto.
-    Qed.
-
-    Theorem Permutation_app_inv_r : 
-       forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
-    Proof.
-    induction l.
-    intros l1 l2; do 2 rewrite <- app_nil_end; auto.
-    intros.
-    apply IHl.
-    apply Permutation_app_inv with a; auto.
-    Qed.
-
-  End Permutation.
 
+  End Reverse_Induction.
 
   (***********************************)
   (** ** Decidable equality on lists *)
   (***********************************)
 
-  Hypotheses eqA_dec : forall (x y : A), {x = y}+{x <> y}.
+  Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}.
 
   Lemma list_eq_dec :
     forall l l':list A, {l = l'} + {l <> l'}.
   Proof.
     induction l as [| x l IHl]; destruct l' as [| y l'].
     left; trivial.
-    right; apply nil_cons. 
+    right; apply nil_cons.
     right; unfold not; intro HF; apply (nil_cons (sym_eq HF)).
-    destruct (eqA_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; 
+    destruct (eq_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql'];
       try (right; unfold not; intro HF; injection HF; intros; contradiction).
     rewrite xeqy; rewrite leql'; left; trivial.
   Qed.
@@ -1026,21 +776,19 @@ End ListOps.
 Section Map.
   Variables A B : Type.
   Variable f : A -> B.
-  
+
   Fixpoint map (l:list A) : list B :=
     match l with
       | nil => nil
       | cons a t => cons (f a) (map t)
     end.
-  
+
   Lemma in_map :
     forall (l:list A) (x:A), In x l -> In (f x) (map l).
-  Proof. 
-    induction l as [| a l IHl]; simpl in |- *;
-      [ auto
-	| destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ].
+  Proof.
+    induction l; firstorder (subst; auto).
   Qed.
-  
+
   Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.
   Proof.
     induction l; firstorder (subst; auto).
@@ -1051,45 +799,48 @@ Section Map.
     induction l; simpl; auto.
   Qed.
 
-  Lemma map_nth : forall l d n, 
+  Lemma map_nth : forall l d n,
     nth n (map l) (f d) = f (nth n l d).
   Proof.
     induction l; simpl map; destruct n; firstorder.
   Qed.
-  
-  Lemma map_app : forall l l',  
+
+  Lemma map_nth_error : forall n l d,
+    nth_error l n = Some d -> nth_error (map l) n = Some (f d).
+  Proof.
+    induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto.
+  Qed.
+
+  Lemma map_app : forall l l',
     map (l++l') = (map l)++(map l').
-  Proof. 
+  Proof.
     induction l; simpl; auto.
     intros; rewrite IHl; auto.
   Qed.
-  
+
   Lemma map_rev : forall l, map (rev l) = rev (map l).
-  Proof. 
+  Proof.
     induction l; simpl; auto.
     rewrite map_app.
     rewrite IHl; auto.
   Qed.
 
-  Hint Constructors Permutation.
-
-  Lemma Permutation_map : 
-    forall l l', Permutation l l' -> Permutation (map l) (map l').
-  Proof. 
-  induction 1; simpl; auto; eauto.
+  Lemma map_eq_nil : forall l, map l = [] -> l = [].
+  Proof.
+    destruct l; simpl; reflexivity || discriminate.
   Qed.
 
   (** [flat_map] *)
 
   Definition flat_map (f:A -> list B) :=
-    fix flat_map (l:list A) {struct l} : list B :=
+    fix flat_map (l:list A) : list B :=
     match l with
       | nil => nil
       | cons x t => (f x)++(flat_map t)
     end.
-  
+
   Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
-    In y (flat_map f l) <-> exists x, In x l /\ In y (f x). 
+    In y (flat_map f l) <-> exists x, In x l /\ In y (f x).
   Proof.
     induction l; simpl; split; intros.
     contradiction.
@@ -1105,16 +856,22 @@ Section Map.
     exists x; auto.
   Qed.
 
-End Map. 
+End Map.
+
+Lemma map_id : forall (A :Type) (l : list A),
+  map (fun x => x) l = l.
+Proof.
+  induction l; simpl; auto; rewrite IHl; auto.
+Qed.
 
-Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, 
+Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l,
   map g (map f l) = map (fun x => g (f x)) l.
 Proof.
   induction l; simpl; auto.
   rewrite IHl; auto.
 Qed.
 
-Lemma map_ext : 
+Lemma map_ext :
   forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
 Proof.
   induction l; simpl; auto.
@@ -1129,17 +886,17 @@ Qed.
 Section Fold_Left_Recursor.
   Variables A B : Type.
   Variable f : A -> B -> A.
-  
-  Fixpoint fold_left (l:list B) (a0:A) {struct l} : A :=
+
+  Fixpoint fold_left (l:list B) (a0:A) : A :=
     match l with
       | nil => a0
       | cons b t => fold_left t (f a0 b)
     end.
-  
-  Lemma fold_left_app : forall (l l':list B)(i:A), 
+
+  Lemma fold_left_app : forall (l l':list B)(i:A),
     fold_left (l++l') i = fold_left l' (fold_left l i).
   Proof.
-    induction l. 
+    induction l.
     simpl; auto.
     intros.
     simpl.
@@ -1148,7 +905,7 @@ Section Fold_Left_Recursor.
 
 End Fold_Left_Recursor.
 
-Lemma fold_left_length : 
+Lemma fold_left_length :
   forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
 Proof.
   intro A.
@@ -1168,7 +925,7 @@ Section Fold_Right_Recursor.
   Variables A B : Type.
   Variable f : B -> A -> A.
   Variable a0 : A.
-  
+
   Fixpoint fold_right (l:list B) : A :=
     match l with
       | nil => a0
@@ -1177,7 +934,7 @@ Section Fold_Right_Recursor.
 
 End Fold_Right_Recursor.
 
-  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, 
+  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i,
     fold_right f i (l++l') = fold_right f (fold_right f i l') l.
   Proof.
     induction l.
@@ -1186,7 +943,7 @@ End Fold_Right_Recursor.
     f_equal; auto.
   Qed.
 
-  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, 
+  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i,
     fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
   Proof.
     induction l.
@@ -1204,10 +961,10 @@ End Fold_Right_Recursor.
   Proof.
     destruct l as [| a l].
     reflexivity.
-    simpl in |- *.
+    simpl.
     rewrite <- H0.
     generalize a0 a.
-    induction l as [| a3 l IHl]; simpl in |- *.
+    induction l as [| a3 l IHl]; simpl.
     trivial.
     intros.
     rewrite H.
@@ -1223,7 +980,7 @@ End Fold_Right_Recursor.
   (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
       indexed by elts of [x], sorted in lexicographic order. *)
 
-  Fixpoint list_power (A B:Type)(l:list A) (l':list B) {struct l} :
+  Fixpoint list_power (A B:Type)(l:list A) (l':list B) :
     list (list (A * B)) :=
     match l with
       | nil => cons nil nil
@@ -1237,20 +994,20 @@ End Fold_Right_Recursor.
   (** ** Boolean operations over lists *)
   (*************************************)
 
-  Section Bool. 
+  Section Bool.
     Variable A : Type.
     Variable f : A -> bool.
 
-  (** find whether a boolean function can be satisfied by an 
+  (** find whether a boolean function can be satisfied by an
        elements of the list. *)
 
-    Fixpoint existsb (l:list A) {struct l}: bool := 
-      match l with 
+    Fixpoint existsb (l:list A) : bool :=
+      match l with
 	| nil => false
 	| a::l => f a || existsb l
       end.
 
-    Lemma existsb_exists : 
+    Lemma existsb_exists :
       forall l, existsb l = true <-> exists x, In x l /\ f x = true.
     Proof.
       induction l; simpl; intuition.
@@ -1269,20 +1026,28 @@ End Fold_Right_Recursor.
       inversion 1.
       simpl; intros.
       destruct (orb_false_elim _ _ H0); clear H0; auto.
-      destruct n ; auto. 
+      destruct n ; auto.
       rewrite IHl; auto with arith.
     Qed.
 
-  (** find whether a boolean function is satisfied by 
+    Lemma existsb_app : forall l1 l2,
+      existsb (l1++l2) = existsb l1 || existsb l2.
+    Proof.
+      induction l1; intros l2; simpl.
+        solve[auto].
+      case (f a); simpl; solve[auto].
+    Qed.
+
+  (** find whether a boolean function is satisfied by
     all the elements of a list. *)
 
-    Fixpoint forallb (l:list A) {struct l} : bool := 
-      match l with 
+    Fixpoint forallb (l:list A) : bool :=
+      match l with
 	| nil => true
 	| a::l => f a && forallb l
       end.
 
-    Lemma forallb_forall : 
+    Lemma forallb_forall :
       forall l, forallb l = true <-> (forall x, In x l -> f x = true).
     Proof.
       induction l; simpl; intuition.
@@ -1291,13 +1056,20 @@ End Fold_Right_Recursor.
       destruct (andb_prop _ _ H1); auto.
       assert (forallb l = true).
       apply H0; intuition.
-      rewrite H1; auto. 
+      rewrite H1; auto.
     Qed.
 
+    Lemma forallb_app :
+      forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2.
+    Proof.
+      induction l1; simpl.
+        solve[auto].
+      case (f a); simpl; solve[auto].
+    Qed.
   (** [filter] *)
 
-    Fixpoint filter (l:list A) : list A := 
-      match l with 
+    Fixpoint filter (l:list A) : list A :=
+      match l with
 	| nil => nil
 	| x :: l => if f x then x::(filter l) else filter l
       end.
@@ -1320,10 +1092,10 @@ End Fold_Right_Recursor.
 
   (** [partition] *)
 
-    Fixpoint partition (l:list A) {struct l} : list A * list A := 
+    Fixpoint partition (l:list A) : list A * list A :=
       match l with
 	| nil => (nil, nil)
-	| x :: tl => let (g,d) := partition tl in 
+	| x :: tl => let (g,d) := partition tl in
 	  if f x then (x::g,d) else (g,x::d)
       end.
 
@@ -1338,17 +1110,17 @@ End Fold_Right_Recursor.
 
   Section ListPairs.
     Variables A B : Type.
-    
+
   (** [split] derives two lists from a list of pairs *)
 
-    Fixpoint split  (l:list (A*B)) { struct l }: list A * list B :=
+    Fixpoint split (l:list (A*B)) : list A * list B :=
       match l with
 	| nil => (nil, nil)
 	| (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
       end.
 
-    Lemma in_split_l : forall (l:list (A*B))(p:A*B), 
-      In p l -> In (fst p) (fst (split l)). 
+    Lemma in_split_l : forall (l:list (A*B))(p:A*B),
+      In p l -> In (fst p) (fst (split l)).
     Proof.
       induction l; simpl; intros; auto.
       destruct p; destruct a; destruct (split l); simpl in *.
@@ -1357,8 +1129,8 @@ End Fold_Right_Recursor.
       right; apply (IHl (a0,b) H).
     Qed.
 
-    Lemma in_split_r : forall (l:list (A*B))(p:A*B), 
-      In p l -> In (snd p) (snd (split l)). 
+    Lemma in_split_r : forall (l:list (A*B))(p:A*B),
+      In p l -> In (snd p) (snd (split l)).
     Proof.
       induction l; simpl; intros; auto.
       destruct p; destruct a; destruct (split l); simpl in *.
@@ -1367,7 +1139,7 @@ End Fold_Right_Recursor.
       right; apply (IHl (a0,b) H).
     Qed.
 
-    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), 
+    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B),
       nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
     Proof.
       induction l.
@@ -1379,40 +1151,40 @@ End Fold_Right_Recursor.
     Qed.
 
     Lemma split_length_l : forall (l:list (A*B)),
-      length (fst (split l)) = length l. 
+      length (fst (split l)) = length l.
     Proof.
       induction l; simpl; auto.
       destruct a; destruct (split l); simpl; auto.
     Qed.
 
     Lemma split_length_r : forall (l:list (A*B)),
-      length (snd (split l)) = length l. 
+      length (snd (split l)) = length l.
     Proof.
       induction l; simpl; auto.
       destruct a; destruct (split l); simpl; auto.
     Qed.
 
-  (** [combine] is the opposite of [split]. 
-      Lists given to [combine] are meant to be of same length. 
+  (** [combine] is the opposite of [split].
+      Lists given to [combine] are meant to be of same length.
       If not, [combine] stops on the shorter list *)
 
-    Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) :=
+    Fixpoint combine (l : list A) (l' : list B) : list (A*B) :=
       match l,l' with
 	| x::tl, y::tl' => (x,y)::(combine tl tl')
 	| _, _ => nil
       end.
 
-    Lemma split_combine : forall (l: list (A*B)), 
+    Lemma split_combine : forall (l: list (A*B)),
       let (l1,l2) := split l in combine l1 l2 = l.
     Proof.
       induction l.
       simpl; auto.
-      destruct a; simpl. 
+      destruct a; simpl.
       destruct (split l); simpl in *.
       f_equal; auto.
     Qed.
 
-    Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> 
+    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.
@@ -1420,19 +1192,19 @@ End Fold_Right_Recursor.
       rewrite IHl; auto.
     Qed.
 
-    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), 
+    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B),
       In (x,y) (combine l l') -> In x l.
     Proof.
       induction l.
       simpl; auto.
       destruct l'; simpl; auto; intros.
-      contradiction. 
+      contradiction.
       destruct H.
       injection H; auto.
       right; apply IHl with l' y; auto.
     Qed.
 
-    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), 
+    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B),
       In (x,y) (combine l l') -> In y l'.
     Proof.
       induction l.
@@ -1443,7 +1215,7 @@ End Fold_Right_Recursor.
       right; apply IHl with x; auto.
     Qed.
 
-    Lemma combine_length : forall (l:list A)(l':list B), 
+    Lemma combine_length : forall (l:list A)(l':list B),
       length (combine l l') = min (length l) (length l').
     Proof.
       induction l.
@@ -1451,8 +1223,8 @@ End Fold_Right_Recursor.
       destruct l'; simpl; auto.
     Qed.
 
-    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), 
-      length l = length l' -> 
+    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B),
+      length l = length l' ->
       nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
     Proof.
       induction l; destruct l'; intros; try discriminate.
@@ -1461,10 +1233,10 @@ End Fold_Right_Recursor.
     Qed.
 
   (** [list_prod] has the same signature as [combine], but unlike
-     [combine], it adds every possible pairs, not only those at the 
+     [combine], it adds every possible pairs, not only those at the
      same position. *)
 
-    Fixpoint list_prod (l:list A) (l':list B) {struct l} :
+    Fixpoint list_prod (l:list A) (l':list B) :
       list (A * B) :=
       match l with
 	| nil => nil
@@ -1474,25 +1246,25 @@ End Fold_Right_Recursor.
     Lemma in_prod_aux :
       forall (x:A) (y:B) (l:list B),
 	In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
-    Proof. 
+    Proof.
       induction l;
-	[ simpl in |- *; auto
-	  | simpl in |- *; destruct 1 as [H1| ];
+	[ simpl; auto
+	  | simpl; destruct 1 as [H1| ];
 	    [ left; rewrite H1; trivial | right; auto ] ].
     Qed.
 
     Lemma in_prod :
       forall (l:list A) (l':list B) (x:A) (y:B),
 	In x l -> In y l' -> In (x, y) (list_prod l l').
-    Proof. 
+    Proof.
       induction l;
-	[ simpl in |- *; tauto
-	  | simpl in |- *; intros; apply in_or_app; destruct H;
+	[ simpl; tauto
+	  | simpl; intros; apply in_or_app; destruct H;
 	    [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
     Qed.
 
-    Lemma in_prod_iff : 
-      forall (l:list A)(l':list B)(x:A)(y:B), 
+    Lemma in_prod_iff :
+      forall (l:list A)(l':list B)(x:A)(y:B),
 	In (x,y) (list_prod l l') <-> In x l /\ In y l'.
     Proof.
       split; [ | intros; apply in_prod; intuition ].
@@ -1503,9 +1275,9 @@ End Fold_Right_Recursor.
       destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
       injection H2; clear H2; intros; subst; intuition.
       intuition.
-    Qed. 
+    Qed.
 
-    Lemma prod_length : forall (l:list A)(l':list B), 
+    Lemma prod_length : forall (l:list A)(l':list B),
       length (list_prod l l') = (length l) * (length l').
     Proof.
       induction l; simpl; auto.
@@ -1520,9 +1292,9 @@ End Fold_Right_Recursor.
 
 
 
-(***************************************)
-(** * Miscelenous operations on lists  *)
-(***************************************)
+(*****************************************)
+(** * Miscellaneous operations on lists  *)
+(*****************************************)
 
 
 
@@ -1539,34 +1311,34 @@ Section length_order.
   Variables l m n : list A.
 
   Lemma lel_refl : lel l l.
-  Proof. 
-    unfold lel in |- *; auto with arith.
+  Proof.
+    unfold lel; auto with arith.
   Qed.
 
   Lemma lel_trans : lel l m -> lel m n -> lel l n.
-  Proof. 
-    unfold lel in |- *; intros.
+  Proof.
+    unfold lel; intros.
     now_show (length l <= length n).
     apply le_trans with (length m); auto with arith.
   Qed.
 
   Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
-  Proof. 
-    unfold lel in |- *; simpl in |- *; auto with arith.
+  Proof.
+    unfold lel; simpl; auto with arith.
   Qed.
 
   Lemma lel_cons : lel l m -> lel l (b :: m).
-  Proof. 
-    unfold lel in |- *; simpl in |- *; auto with arith.
+  Proof.
+    unfold lel; simpl; auto with arith.
   Qed.
 
   Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
-  Proof. 
-    unfold lel in |- *; simpl in |- *; auto with arith.
+  Proof.
+    unfold lel; simpl; auto with arith.
   Qed.
 
   Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'.
-  Proof. 
+  Proof.
     intro l'; elim l'; auto with arith.
     intros a' y H H0.
     now_show (nil = a' :: y).
@@ -1588,40 +1360,40 @@ Section SetIncl.
 
   Definition incl (l m:list A) := forall a:A, In a l -> In a m.
   Hint Unfold incl.
-  
+
   Lemma incl_refl : forall l:list A, incl l l.
-  Proof. 
+  Proof.
     auto.
   Qed.
   Hint Resolve incl_refl.
-  
+
   Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m).
-  Proof. 
+  Proof.
     auto with datatypes.
   Qed.
   Hint Immediate incl_tl.
 
   Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n.
-  Proof. 
+  Proof.
     auto.
   Qed.
-  
+
   Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m).
-  Proof. 
+  Proof.
     auto with datatypes.
   Qed.
   Hint Immediate incl_appl.
-  
+
   Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n).
-  Proof. 
+  Proof.
     auto with datatypes.
   Qed.
   Hint Immediate incl_appr.
-  
+
   Lemma incl_cons :
     forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m.
-  Proof. 
-    unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1.
+  Proof.
+    unfold incl; simpl; intros a l m H H0 a0 H1.
     now_show (In a0 m).
     elim H1.
     now_show (a = a0 -> In a0 m).
@@ -1632,15 +1404,15 @@ Section SetIncl.
     auto.
   Qed.
   Hint Resolve incl_cons.
-  
+
   Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n.
-  Proof. 
-    unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1.
+  Proof.
+    unfold incl; simpl; intros l m n H H0 a H1.
     now_show (In a n).
     elim (in_app_or _ _ _ H1); auto.
   Qed.
   Hint Resolve incl_app.
-  
+
 End SetIncl.
 
 Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
@@ -1655,24 +1427,24 @@ Section Cutting.
 
   Variable A : Type.
 
-  Fixpoint firstn (n:nat)(l:list A) {struct n} : list A := 
-    match n with 
-      | 0 => nil 
-      | S n => match l with  
-		 | nil => nil 
+  Fixpoint firstn (n:nat)(l:list A) : list A :=
+    match n with
+      | 0 => nil
+      | S n => match l with
+		 | nil => nil
 		 | a::l => a::(firstn n l)
 	       end
     end.
-  
-  Fixpoint skipn (n:nat)(l:list A) { struct n } : list A := 
-    match n with 
-      | 0 => l 
-      | S n => match l with 
-		 | nil => nil 
+
+  Fixpoint skipn (n:nat)(l:list A) : list A :=
+    match n with
+      | 0 => l
+      | S n => match l with
+		 | nil => nil
 		 | a::l => skipn n l
 	       end
     end.
-  
+
   Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
   Proof.
     induction n.
@@ -1686,7 +1458,7 @@ Section Cutting.
     induction n; destruct l; simpl; auto.
   Qed.
 
-   Lemma removelast_firstn : forall n l, n < length l -> 
+   Lemma removelast_firstn : forall n l, n < length l ->
      removelast (firstn (S n) l) = firstn n l.
    Proof.
      induction n; destruct l.
@@ -1699,13 +1471,13 @@ Section Cutting.
      change (firstn (S n) (a::l)) with (a::firstn n l).
      rewrite removelast_app.
      rewrite IHn; auto with arith.
-     
+
      clear IHn; destruct l; simpl in *; try discriminate.
      inversion_clear H.
      inversion_clear H0.
    Qed.
 
-   Lemma firstn_removelast : forall n l, n < length l -> 
+   Lemma firstn_removelast : forall n l, n < length l ->
      firstn n (removelast l) = firstn n l.
    Proof.
      induction n; destruct l.
@@ -1730,10 +1502,10 @@ End Cutting.
 Section ReDun.
 
   Variable A : Type.
-  
-  Inductive NoDup : list A -> Prop := 
-    | NoDup_nil : NoDup nil 
-    | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). 
+
+  Inductive NoDup : list A -> Prop :=
+    | NoDup_nil : NoDup nil
+    | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l).
 
   Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l').
   Proof.
@@ -1758,34 +1530,6 @@ Section ReDun.
   destruct (IHl _ _ H1); auto.
   Qed.
 
-  Lemma NoDup_Permutation : forall l l', 
-    NoDup l -> NoDup l' -> (forall x, In x l <-> In x l') -> Permutation l l'.
-  Proof.
-  induction l. 
-  destruct l'; simpl; intros.
-  apply perm_nil.
-  destruct (H1 a) as (_,H2); destruct H2; auto.
-  intros.
-  destruct (In_split a l') as (l'1,(l'2,H2)).
-  destruct (H1 a) as (H2,H3); simpl in *; auto.
-  subst l'.
-  apply Permutation_cons_app.
-  inversion_clear H.
-  apply IHl; auto.
-  apply NoDup_remove_1 with a; auto.
-  intro x; split; intros.
-  assert (In x (l'1++a::l'2)).
-   destruct (H1 x); simpl in *; auto.
-  apply in_or_app; destruct (in_app_or _ _ _ H4); auto.
-  destruct H5; auto.
-  subst x; destruct H2; auto.
-  assert (In x (l'1++a::l'2)).
-    apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto.
-  destruct (H1 x) as (_,H5); destruct H5; auto. 
-  subst x.
-  destruct (NoDup_remove_2 _ _ _ H0 H).
-  Qed.
-
 End ReDun.
 
 
@@ -1795,21 +1539,21 @@ End ReDun.
 
 Section NatSeq.
 
-  (** [seq] computes the sequence of [len] contiguous integers 
+  (** [seq] computes the sequence of [len] contiguous integers
       that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *)
-  
-  Fixpoint seq (start len:nat) {struct len} : list nat := 
-    match len with 
+
+  Fixpoint seq (start len:nat) : list nat :=
+    match len with
       | 0 => nil
       | S len => start :: seq (S start) len
-    end. 
-  
+    end.
+
   Lemma seq_length : forall len start, length (seq start len) = len.
   Proof.
     induction len; simpl; auto.
   Qed.
-  
-  Lemma seq_nth : forall len start n d, 
+
+  Lemma seq_nth : forall len start n d,
     n < len -> nth n (seq start len) d = start+n.
   Proof.
     induction len; intros.
@@ -1822,7 +1566,7 @@ Section NatSeq.
 
   Lemma seq_shift : forall len start,
     map S (seq start len) = seq (S start) len.
-  Proof. 
+  Proof.
     induction len; simpl; auto.
     intros.
     rewrite IHlen.
@@ -1832,11 +1576,172 @@ Section NatSeq.
 End NatSeq.
 
 
+(** * Existential and universal predicates over lists *)
+
+Inductive Exists {A} (P:A->Prop) : list A -> Prop :=
+ | Exists_cons_hd : forall x l, P x -> Exists P (x::l)
+ | Exists_cons_tl : forall x l, Exists P l -> Exists P (x::l).
+Hint Constructors Exists.
+
+Lemma Exists_exists : forall A P (l:list A),
+ Exists P l <-> (exists x, In x l /\ P x).
+Proof.
+split.
+induction 1; firstorder.
+induction l; firstorder; subst; auto.
+Qed.
+
+Lemma Exists_nil : forall A (P:A->Prop), Exists P nil <-> False.
+Proof. split; inversion 1. Qed.
+
+Lemma Exists_cons : forall A (P:A->Prop) x l,
+ Exists P (x::l) <-> P x \/ Exists P l.
+Proof. split; inversion 1; auto. Qed.
+
+
+Inductive Forall {A} (P:A->Prop) : list A -> Prop :=
+ | Forall_nil : Forall P nil
+ | Forall_cons : forall x l, P x -> Forall P l -> Forall P (x::l).
+Hint Constructors Forall.
 
-  (** * Exporting hints and tactics *)
+Lemma Forall_forall : forall A P (l:list A),
+ Forall P l <-> (forall x, In x l -> P x).
+Proof.
+split.
+induction 1; firstorder; subst; auto.
+induction l; firstorder.
+Qed.
+
+Lemma Forall_inv : forall A P (a:A) l, Forall P (a :: l) -> P a.
+Proof.
+intros; inversion H; trivial.
+Defined.
+
+Lemma Forall_rect : forall A (P:A->Prop) (Q : list A -> Type),
+     Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall P l -> Q l.
+Proof.
+intros A P Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption.
+Defined.
+
+Lemma Forall_impl : forall A (P Q : A -> Prop), (forall a, P a -> Q a) ->
+  forall l, Forall P l -> Forall Q l.
+Proof.
+  intros A P Q Himp l H.
+  induction H; firstorder.
+Qed.
 
+(** [Forall2]: stating that elements of two lists are pairwise related. *)
 
-Hint Rewrite 
+Inductive Forall2 A B (R:A->B->Prop) : list A -> list B -> Prop :=
+ | Forall2_nil : Forall2 R [] []
+ | Forall2_cons : forall x y l l',
+    R x y -> Forall2 R l l' -> Forall2 R (x::l) (y::l').
+Hint Constructors Forall2.
+
+Theorem Forall2_refl : forall A B (R:A->B->Prop), Forall2 R [] [].
+Proof. exact Forall2_nil. Qed.
+
+Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l',
+  Forall2 R (l1 ++ l2) l' ->
+  exists l1', exists l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'.
+Proof.
+  induction l1; intros.
+    exists [], l'; auto.
+    simpl in H; inversion H; subst; clear H.
+    apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->).
+    exists (y::l1'), l2'; simpl; auto.
+Qed.
+
+Theorem Forall2_app_inv_r : forall A B (R:A->B->Prop) l1' l2' l,
+  Forall2 R l (l1' ++ l2') ->
+  exists l1, exists l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2.
+Proof.
+  induction l1'; intros.
+    exists [], l; auto.
+    simpl in H; inversion H; subst; clear H.
+    apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->).
+    exists (x::l1), l2; simpl; auto.
+Qed.
+
+Theorem Forall2_app : forall A B (R:A->B->Prop) l1 l2 l1' l2',
+  Forall2 R l1 l1' -> Forall2 R l2 l2' -> Forall2 R (l1 ++ l2) (l1' ++ l2').
+Proof.
+  intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
+Qed.
+
+(** [ForallPairs] : specifies that a certain relation should
+    always hold when inspecting all possible pairs of elements of a list. *)
+
+Definition ForallPairs A (R : A -> A -> Prop) l :=
+ forall a b, In a l -> In b l -> R a b.
+
+(** [ForallOrdPairs] : we still check a relation over all pairs
+     of elements of a list, but now the order of elements matters. *)
+
+Inductive ForallOrdPairs A (R : A -> A -> Prop) : list A -> Prop :=
+  | FOP_nil : ForallOrdPairs R nil
+  | FOP_cons : forall a l,
+     Forall (R a) l -> ForallOrdPairs R l -> ForallOrdPairs R (a::l).
+Hint Constructors ForallOrdPairs.
+
+Lemma ForallOrdPairs_In : forall A (R:A->A->Prop) l,
+ ForallOrdPairs R l ->
+ forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x.
+Proof.
+ induction 1.
+ inversion 1.
+ simpl; destruct 1; destruct 1; repeat subst; auto.
+ right; left. apply -> Forall_forall; eauto.
+ right; right. apply -> Forall_forall; eauto.
+Qed.
+
+
+(** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true
+    only when [R] is symmetric and reflexive. *)
+
+Lemma ForallPairs_ForallOrdPairs : forall A (R:A->A->Prop) l,
+ ForallPairs R l -> ForallOrdPairs R l.
+Proof.
+ induction l; auto. intros H.
+ constructor.
+ apply <- Forall_forall. intros; apply H; simpl; auto.
+ apply IHl. red; intros; apply H; simpl; auto.
+Qed.
+
+Lemma ForallOrdPairs_ForallPairs : forall A (R:A->A->Prop),
+ (forall x, R x x) ->
+ (forall x y, R x y -> R y x) ->
+ forall l, ForallOrdPairs R l -> ForallPairs R l.
+Proof.
+ intros A R Refl Sym l Hl x y Hx Hy.
+ destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
+Qed.
+
+(** * Inversion of predicates over lists based on head symbol *)
+
+Ltac is_list_constr c :=
+ match c with
+  | nil => idtac
+  | (_::_) => idtac
+  | _ => fail
+ end.
+
+Ltac invlist f :=
+ match goal with
+  | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | _ => idtac
+ end.
+
+
+
+(** * Exporting hints and tactics *)
+
+
+Hint Rewrite
   rev_involutive (* rev (rev l) = l *)
   rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
   map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
@@ -1844,11 +1749,36 @@ Hint Rewrite
   seq_length (* length (seq start len) = len *)
   app_length (* length (l ++ l') = length l + length l' *)
   rev_length (* length (rev l) = length l *)
-  : list.
-
-Hint Rewrite <- 
-  app_nil_end (* l = l ++ nil *)
+  app_nil_r (* l ++ nil = l *)
   : list.
 
 Ltac simpl_list := autorewrite with list.
 Ltac ssimpl_list := autorewrite with list using simpl.
+
+(* begin hide *)
+(* Compatibility notations after the migration of [list] to [Datatypes] *)
+Notation list := list (only parsing).
+Notation list_rect := list_rect (only parsing).
+Notation list_rec := list_rec (only parsing).
+Notation list_ind := list_ind (only parsing).
+Notation nil := nil (only parsing).
+Notation cons := cons (only parsing).
+Notation length := length (only parsing).
+Notation app := app (only parsing).
+(* Compatibility Names *)
+Notation tail := tl (only parsing).
+Notation head := hd_error (only parsing).
+Notation head_nil := hd_error_nil (only parsing).
+Notation head_cons := hd_error_cons (only parsing).
+Notation ass_app := app_assoc (only parsing).
+Notation app_ass := app_assoc_reverse (only parsing).
+Notation In_split := in_split (only parsing).
+Notation In_rev := in_rev (only parsing).
+Notation In_dec := in_dec (only parsing).
+Notation distr_rev := rev_app_distr (only parsing).
+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.
+(* end hide *)
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index 021a64c1..20c9e7e8 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ListSet.v 10616 2008-03-04 17:33:35Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** A Library for finite sets, implemented as lists *)
 
@@ -27,7 +27,7 @@ Section first_definitions.
 
   Definition empty_set : set := nil.
 
-  Fixpoint set_add (a:A) (x:set) {struct x} : set :=
+  Fixpoint set_add (a:A) (x:set) : set :=
     match x with
     | nil => a :: nil
     | a1 :: x1 =>
@@ -38,7 +38,7 @@ Section first_definitions.
     end.
 
 
-  Fixpoint set_mem (a:A) (x:set) {struct x} : bool :=
+  Fixpoint set_mem (a:A) (x:set) : bool :=
     match x with
     | nil => false
     | a1 :: x1 =>
@@ -47,9 +47,9 @@ Section first_definitions.
         | right _ => set_mem a x1
         end
     end.
- 
+
   (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *)
-  Fixpoint set_remove (a:A) (x:set) {struct x} : set :=
+  Fixpoint set_remove (a:A) (x:set) : set :=
     match x with
     | nil => empty_set
     | a1 :: x1 =>
@@ -67,20 +67,20 @@ Section first_definitions.
           if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y
     end.
 
-  Fixpoint set_union (x y:set) {struct y} : set :=
+  Fixpoint set_union (x y:set) : set :=
     match y with
     | nil => x
     | a1 :: y1 => set_add a1 (set_union x y1)
     end.
-        
+
   (** returns the set of all els of [x] that does not belong to [y] *)
-  Fixpoint set_diff (x y:set) {struct x} : set :=
+  Fixpoint set_diff (x y:set) : set :=
     match x with
     | nil => nil
     | a1 :: x1 =>
         if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y)
     end.
-   
+
 
   Definition set_In : A -> set -> Prop := In (A:=A).
 
@@ -123,7 +123,7 @@ Section first_definitions.
     case H3; auto.
   Qed.
 
- 
+
   Lemma set_mem_correct1 :
    forall (a:A) (x:set), set_mem a x = true -> set_In a x.
   Proof.
@@ -191,11 +191,11 @@ Section first_definitions.
 
   Lemma set_add_intro :
    forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x).
-  
+
   Proof.
     intros a b x [H1| H2]; auto with datatypes.
   Qed.
- 
+
   Lemma set_add_elim :
    forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x.
 
@@ -225,7 +225,7 @@ Section first_definitions.
     simple induction x; simpl in |- *.
     discriminate.
     intros; elim (Aeq_dec a a0); intros; discriminate.
-  Qed.   
+  Qed.
 
 
   Lemma set_union_intro1 :
@@ -289,7 +289,7 @@ Section first_definitions.
     elim (set_mem a y); simpl in |- *; intros.
     auto with datatypes.
     absurd (set_In a y); auto with datatypes.
-    elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ].     
+    elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ].
   Qed.
 
   Lemma set_inter_elim1 :
@@ -324,7 +324,7 @@ Section first_definitions.
      set_In a (set_inter x y) -> set_In a x /\ set_In a y.
   Proof.
     eauto with datatypes.
-  Qed. 
+  Qed.
 
   Lemma set_diff_intro :
    forall (a:A) (x y:set),
@@ -354,7 +354,7 @@ Section first_definitions.
    forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y.
   intros a x y; elim x; simpl in |- *.
   intros; contradiction.
-  intros a0 l Hrec. 
+  intros a0 l Hrec.
   apply set_mem_ind2; auto.
   intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto.
   rewrite H; trivial.
@@ -373,24 +373,23 @@ End first_definitions.
 
 Section other_definitions.
 
-  Variables A B : Type.
-
-  Definition set_prod : set A -> set B -> set (A * B) :=
-    list_prod (A:=A) (B:=B).
+  Definition set_prod : forall {A B:Type}, set A -> set B -> set (A * B) :=
+    list_prod.
 
   (** [B^A], set of applications from [A] to [B] *)
-  Definition set_power : set A -> set B -> set (set (A * B)) :=
-    list_power (A:=A) (B:=B).
+  Definition set_power : forall {A B:Type}, set A -> set B -> set (set (A * B)) :=
+    list_power.
 
-  Definition set_map : (A -> B) -> set A -> set B := map (A:=A) (B:=B).
-
-  Definition set_fold_left : (B -> A -> B) -> set A -> B -> B :=
+  Definition set_fold_left {A B:Type} : (B -> A -> B) -> set A -> B -> B :=
     fold_left (A:=B) (B:=A).
 
-  Definition set_fold_right (f:A -> B -> B) (x:set A) 
+  Definition set_fold_right {A B:Type} (f:A -> B -> B) (x:set A)
     (b:B) : B := fold_right f b x.
 
- 
+  Definition set_map {A B:Type} (Aeq_dec : forall x y:B, {x = y} + {x <> y})
+    (f : A -> B) (x : set A) : set B :=
+    set_fold_right (fun a => set_add Aeq_dec (f a)) x (empty_set B).
+
 End other_definitions.
 
 Unset Implicit Arguments.
diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v
index 515ed138..0a21a9e2 100644
--- a/theories/Lists/ListTactics.v
+++ b/theories/Lists/ListTactics.v
@@ -6,40 +6,44 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ListTactics.v 9427 2006-12-11 18:46:35Z bgregoir $ i*)
+(*i $Id$ i*)
 
 Require Import BinPos.
 Require Import List.
 
 Ltac list_fold_right fcons fnil l :=
   match l with
-  | (cons ?x ?tl) => fcons x ltac:(list_fold_right fcons fnil tl)
+  | ?x :: ?tl => fcons x ltac:(list_fold_right fcons fnil tl)
   | nil => fnil
   end.
 
+(* A variant of list_fold_right, to prevent the match of list_fold_right
+   from catching errors raised by fcons. *)
 Ltac lazy_list_fold_right fcons fnil l :=
-  match l with
-  | (cons ?x ?tl) => 
-       let cont := lazy_list_fold_right fcons fnil in
-       fcons x cont tl
-  | nil => fnil 
-  end.
+  let f :=
+    match l with
+    | ?x :: ?tl =>
+         fun _ =>
+         fcons x ltac:(fun _ => lazy_list_fold_right fcons fnil tl)
+    | nil => fun _ => fnil()
+    end in
+  f().
 
 Ltac list_fold_left fcons fnil l :=
   match l with
-  | (cons ?x ?tl) => list_fold_left fcons ltac:(fcons x fnil) tl
+  | ?x :: ?tl => list_fold_left fcons ltac:(fcons x fnil) tl
   | nil => fnil
   end.
 
 Ltac list_iter f l :=
   match l with
-  | (cons ?x ?tl) => f x; list_iter f tl
+  | ?x :: ?tl => f x; list_iter f tl
   | nil => idtac
   end.
 
 Ltac list_iter_gen seq f l :=
   match l with
-  | (cons ?x ?tl) =>
+  | ?x :: ?tl =>
       let t1 _ := f x in
       let t2 _ := list_iter_gen seq f tl in
       seq t1 t2
@@ -48,30 +52,30 @@ Ltac list_iter_gen seq f l :=
 
 Ltac AddFvTail a l :=
  match l with
- | nil          => constr:(cons a l)
- | (cons a _)   => l
- | (cons ?x ?l) => let l' := AddFvTail a l in constr:(cons x l')
+ | nil      => constr:(a::nil)
+ | a :: _   => l
+ | ?x :: ?l => let l' := AddFvTail a l in constr:(x::l')
  end.
 
 Ltac Find_at a l :=
  let rec find n l :=
    match l with
-   | nil => fail 100 "anomaly: Find_at"
-   | (cons a _) => eval compute in n
-   | (cons _ ?l) => find (Psucc n) l
+   | nil     => fail 100 "anomaly: Find_at"
+   | a :: _  => eval compute in n
+   | _ :: ?l => find (Psucc n) l
    end
  in find 1%positive l.
 
 Ltac check_is_list t :=
   match t with
-  | cons _ ?l => check_is_list l
-  | nil => idtac
-  | _ => fail 100 "anomaly: failed to build a canonical list"
+  | _ :: ?l => check_is_list l
+  | nil     => idtac
+  | _       => fail 100 "anomaly: failed to build a canonical list"
   end.
 
 Ltac check_fv l :=
   check_is_list l;
-  match type of l with 
+  match type of l with
   | list _ => idtac
-  | _ => fail 100 "anomaly: built an ill-typed list"
+  | _      => fail 100 "anomaly: built an ill-typed list"
   end.
diff --git a/theories/Lists/MonoList.v b/theories/Lists/MonoList.v
deleted file mode 100644
index aa2b74dd..00000000
--- a/theories/Lists/MonoList.v
+++ /dev/null
@@ -1,269 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: MonoList.v 8642 2006-03-17 10:09:02Z notin $ i*)
-
-(** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***)
-
-Require Import Le.
-
-Parameter List_Dom : Set.
-Definition A := List_Dom.
-
-Inductive list : Set :=
-  | nil : list
-  | cons : A -> list -> list.
-
-Fixpoint app (l m:list) {struct l} : list :=
-  match l return list with
-  | nil => m
-  | cons a l1 => cons a (app l1 m)
-  end.
-
-
-Lemma app_nil_end : forall l:list, l = app l nil.
-Proof. 
-	intro l; elim l; simpl in |- *; auto.
-        simple induction 1; auto.
-Qed.
-Hint Resolve app_nil_end: list v62.
-
-Lemma app_ass : forall l m n:list, app (app l m) n = app l (app m n).
-Proof. 
-	intros l m n; elim l; simpl in |- *; auto with list.
-	simple induction 1; auto with list.
-Qed.
-Hint Resolve app_ass: list v62.
-
-Lemma ass_app : forall l m n:list, app l (app m n) = app (app l m) n.
-Proof. 
-	auto with list.
-Qed.
-Hint Resolve ass_app: list v62.
-
-Definition tail (l:list) : list :=
-  match l return list with
-  | cons _ m => m
-  | _ => nil
-  end.
-                   
-
-Lemma nil_cons : forall (a:A) (m:list), nil <> cons a m.
-  intros; discriminate.
-Qed.
-
-(****************************************)
-(* Length of lists                      *)
-(****************************************)
-
-Fixpoint length (l:list) : nat :=
-  match l return nat with
-  | cons _ m => S (length m)
-  | _ => 0
-  end.
-
-(******************************)
-(* Length order of lists      *)
-(******************************)
-
-Section length_order.
-Definition lel (l m:list) := length l <= length m.
-
-Hint Unfold lel: list.
-
-Variables a b : A.
-Variables l m n : list.
-
-Lemma lel_refl : lel l l.
-Proof. 
-	unfold lel in |- *; auto with list.
-Qed.
-
-Lemma lel_trans : lel l m -> lel m n -> lel l n.
-Proof. 
-	unfold lel in |- *; intros.
-        apply le_trans with (length m); auto with list.
-Qed.
-
-Lemma lel_cons_cons : lel l m -> lel (cons a l) (cons b m).
-Proof. 
-	unfold lel in |- *; simpl in |- *; auto with list arith.
-Qed.
-
-Lemma lel_cons : lel l m -> lel l (cons b m).
-Proof. 
-	unfold lel in |- *; simpl in |- *; auto with list arith.
-Qed.
-
-Lemma lel_tail : lel (cons a l) (cons b m) -> lel l m.
-Proof. 
-	unfold lel in |- *; simpl in |- *; auto with list arith.
-Qed.
-
-Lemma lel_nil : forall l':list, lel l' nil -> nil = l'.
-Proof. 
-	intro l'; elim l'; auto with list arith.
-	intros a' y H H0.
-	(*  <list>nil=(cons a' y)
-	    ============================
-	      H0 : (lel (cons a' y) nil)
-	      H : (lel y nil)->(<list>nil=y)
-	      y : list
-	      a' : A
-	      l' : list *)
-	absurd (S (length y) <= 0); auto with list arith.
-Qed.
-End length_order.
-
-Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: list
-  v62.
-
-Fixpoint In (a:A) (l:list) {struct l} : Prop :=
-  match l with
-  | nil => False
-  | cons b m => b = a \/ In a m
-  end.
-
-Lemma in_eq : forall (a:A) (l:list), In a (cons a l).
-Proof. 
-	simpl in |- *; auto with list.
-Qed.
-Hint Resolve in_eq: list v62.
-
-Lemma in_cons : forall (a b:A) (l:list), In b l -> In b (cons a l).
-Proof. 
-	simpl in |- *; auto with list.
-Qed.
-Hint Resolve in_cons: list v62.
-
-Lemma in_app_or : forall (l m:list) (a:A), In a (app l m) -> In a l \/ In a m.
-Proof. 
-	intros l m a.
-	elim l; simpl in |- *; auto with list.
-	intros a0 y H H0.
-	(*  ((<A>a0=a)\/(In a y))\/(In a m)
-	    ============================
-	      H0 : (<A>a0=a)\/(In a (app y m))
-	      H : (In a (app y m))->((In a y)\/(In a m))
-	      y : list
-	      a0 : A
-	      a : A
-	      m : list
-	      l : list *)
-	elim H0; auto with list.
-	intro H1.
-	(*  ((<A>a0=a)\/(In a y))\/(In a m)
-	    ============================
-	      H1 : (In a (app y m)) *)
-	elim (H H1); auto with list.
-Qed.
-Hint Immediate in_app_or: list v62.
-
-Lemma in_or_app : forall (l m:list) (a:A), In a l \/ In a m -> In a (app l m).
-Proof. 
-	intros l m a.
-	elim l; simpl in |- *; intro H.
-	(* 1 (In a m)
-	    ============================
-	      H : False\/(In a m)
-	      a : A
-	      m : list
-	      l : list *)
-	elim H; auto with list; intro H0.
-	(*  (In a m)
-	    ============================
-	      H0 : False *)
-	elim H0. (* subProof completed *)
-	intros y H0 H1.
-	(*  2 (<A>H=a)\/(In a (app y m))
-	    ============================
-	      H1 : ((<A>H=a)\/(In a y))\/(In a m)
-	      H0 : ((In a y)\/(In a m))->(In a (app y m))
-	      y : list *)
-	elim H1; auto 4 with list.
-	intro H2.
-	(*  (<A>H=a)\/(In a (app y m))
-	    ============================
-	      H2 : (<A>H=a)\/(In a y) *)
-	elim H2; auto with list.
-Qed.
-Hint Resolve in_or_app: list v62.
-
-Definition incl (l m:list) := forall a:A, In a l -> In a m.
-
-Hint Unfold incl: list v62.
-
-Lemma incl_refl : forall l:list, incl l l.
-Proof. 
-	auto with list.
-Qed.
-Hint Resolve incl_refl: list v62.
-
-Lemma incl_tl : forall (a:A) (l m:list), incl l m -> incl l (cons a m).
-Proof. 
-	auto with list.
-Qed.
-Hint Immediate incl_tl: list v62.
-
-Lemma incl_tran : forall l m n:list, incl l m -> incl m n -> incl l n.
-Proof. 
-	auto with list.
-Qed.
-
-Lemma incl_appl : forall l m n:list, incl l n -> incl l (app n m).
-Proof. 
-	auto with list.
-Qed.
-Hint Immediate incl_appl: list v62.
-
-Lemma incl_appr : forall l m n:list, incl l n -> incl l (app m n).
-Proof. 
-	auto with list.
-Qed.
-Hint Immediate incl_appr: list v62.
-
-Lemma incl_cons :
- forall (a:A) (l m:list), In a m -> incl l m -> incl (cons a l) m.
-Proof. 
-	unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1.
-	(*  (In a0 m)
-	    ============================
-	      H1 : (<A>a=a0)\/(In a0 l)
-	      a0 : A
-	      H0 : (a:A)(In a l)->(In a m)
-	      H : (In a m)
-	      m : list
-	      l : list
-	      a : A *)
-	elim H1.
-	(*  1 (<A>a=a0)->(In a0 m) *)
-	elim H1; auto with list; intro H2.
-	(*  (<A>a=a0)->(In a0 m)
-	    ============================
-	      H2 : <A>a=a0 *)
-	elim H2; auto with list. (* solves subgoal *)
-	(*  2 (In a0 l)->(In a0 m) *)
-	auto with list.
-Qed.
-Hint Resolve incl_cons: list v62.
-
-Lemma incl_app : forall l m n:list, incl l n -> incl m n -> incl (app l m) n.
-Proof. 
-	unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1.
-	(*  (In a n)
-	    ============================
-	      H1 : (In a (app l m))
-	      a : A
-	      H0 : (a:A)(In a m)->(In a n)
-	      H : (a:A)(In a l)->(In a n)
-	      n : list
-	      m : list
-	      l : list *)
-	elim (in_app_or l m a); auto with list.
-Qed.
-Hint Resolve incl_app: list v62.
\ No newline at end of file
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index 2592abb5..d42e71e5 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -6,23 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: SetoidList.v 11800 2009-01-18 18:34:15Z msozeau $ *)
+(* $Id$ *)
 
 Require Export List.
 Require Export Sorting.
-Require Export Setoid.
+Require Export Setoid Basics Morphisms.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** * Logical relations over lists with respect to a setoid equality 
-      or ordering. *) 
+(** * Logical relations over lists with respect to a setoid equality
+      or ordering. *)
 
-(** This can be seen as a complement of predicate [lelistA] and [sort] 
+(** This can be seen as a complement of predicate [lelistA] and [sort]
     found in [Sorting]. *)
 
 Section Type_with_equality.
 Variable A : Type.
-Variable eqA : A -> A -> Prop. 
+Variable eqA : A -> A -> Prop.
 
 (** Being in a list modulo an equality relation over type [A]. *)
 
@@ -32,27 +32,28 @@ Inductive InA (x : A) : list A -> Prop :=
 
 Hint Constructors InA.
 
+(** TODO: it would be nice to have a generic definition instead
+    of the previous one. Having [InA = Exists eqA] raises too
+    many compatibility issues. For now, we only state the equivalence: *)
+
+Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l.
+Proof. split; induction 1; auto. Qed.
+
 Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l.
 Proof.
- intuition.
- inversion H; auto.
+ intuition. invlist InA; auto.
 Qed.
 
 Lemma InA_nil : forall x, InA x nil <-> False.
 Proof.
- intuition.
- inversion H.
+ intuition. invlist InA.
 Qed.
 
 (** An alternative definition of [InA]. *)
 
 Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l.
-Proof. 
- induction l; intuition.
- inversion H.
- firstorder.
- inversion H1; firstorder.
- firstorder; subst; auto.
+Proof.
+ intros; rewrite InA_altdef, Exists_exists; firstorder.
 Qed.
 
 (** A list without redundancy modulo the equality over [A]. *)
@@ -63,8 +64,22 @@ Inductive NoDupA : list A -> Prop :=
 
 Hint Constructors NoDupA.
 
+(** An alternative definition of [NoDupA] based on [ForallOrdPairs] *)
+
+Lemma NoDupA_altdef : forall l,
+ NoDupA l <-> ForallOrdPairs (complement eqA) l.
+Proof.
+ split; induction 1; constructor; auto.
+ rewrite Forall_forall. intros b Hb.
+ intro Eq; elim H. rewrite InA_alt. exists b; auto.
+ rewrite InA_alt; intros (a' & Haa' & Ha').
+ rewrite Forall_forall in H. exact (H a' Ha' Haa').
+Qed.
+
+
 (** lists with same elements modulo [eqA] *)
 
+Definition inclA l l' := forall x, InA x l -> InA x l'.
 Definition equivlistA l l' := forall x, InA x l <-> InA x l'.
 
 (** lists with same elements modulo [eqA] at the same place *)
@@ -76,48 +91,78 @@ Inductive eqlistA : list A -> list A -> Prop :=
 
 Hint Constructors eqlistA.
 
-(** Compatibility of a  boolean function with respect to an equality. *)
+(** We could also have written [eqlistA = Forall2 eqA]. *)
 
-Definition compat_bool (f : A->bool) := forall x y, eqA x y -> f x = f y.
+Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'.
+Proof. split; induction 1; auto. Qed.
 
-(** Compatibility of a function upon natural numbers. *)
+(** Results concerning lists modulo [eqA] *)
 
-Definition compat_nat (f : A->nat) := forall x y, eqA x y -> f x = f y.
+Hypothesis eqA_equiv : Equivalence eqA.
 
-(** Compatibility of a predicate with respect to an equality. *)
+Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv).
+Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv).
+Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv).
 
-Definition compat_P (P : A->Prop) := forall x y, eqA x y -> P x -> P y.
+Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA.
 
-(** Results concerning lists modulo [eqA] *)
+(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *)
 
-Hypothesis eqA_refl : forall x, eqA x x.
-Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x.
-Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+Global Instance equivlist_equiv : Equivalence equivlistA.
+Proof.
+ firstorder.
+Qed.
+
+Global Instance eqlistA_equiv : Equivalence eqlistA.
+Proof.
+ constructor; red.
+ induction x; auto.
+ induction 1; auto.
+ intros x y z H; revert z; induction H; auto.
+ inversion 1; subst; auto. invlist eqlistA; eauto with *.
+Qed.
+
+(** Moreover, [eqlistA] implies [equivlistA]. A reverse result
+    will be proved later for sorted list without duplicates. *)
+
+Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA.
+Proof.
+  intros x x' H. induction H.
+  intuition.
+  red; intros.
+  rewrite 2 InA_cons.
+  rewrite (IHeqlistA x0), H; intuition.
+Qed.
+
+(** InA is compatible with eqA (for its first arg) and with
+    equivlistA (and hence eqlistA) for its second arg *)
+
+Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA.
+Proof.
+ intros x x' Hxx' l l' Hll'. rewrite (Hll' x).
+ rewrite 2 InA_alt; firstorder.
+Qed.
 
-Hint Resolve eqA_refl eqA_trans.
-Hint Immediate eqA_sym.
+(** For compatibility, an immediate consequence of [InA_compat] *)
 
 Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
-Proof. 
- intros s x y.
- do 2 rewrite InA_alt.
- intros H (z,(U,V)).  
- exists z; split; eauto.
+Proof.
+ intros l x y H H'. rewrite <- H; auto.
 Qed.
 Hint Immediate InA_eqA.
 
 Lemma In_InA : forall l x, In x l -> InA x l.
 Proof.
- simple induction l; simpl in |- *; intuition.
- subst; auto.  
+ simple induction l; simpl; intuition.
+ subst; auto.
 Qed.
 Hint Resolve In_InA.
 
-Lemma InA_split : forall l x, InA x l -> 
- exists l1, exists y, exists l2, 
+Lemma InA_split : forall l x, InA x l ->
+ exists l1, exists y, exists l2,
  eqA x y /\ l = l1++y::l2.
 Proof.
-induction l; inversion_clear 1.
+induction l; intros; inv.
 exists (@nil A); exists a; exists l; auto.
 destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
 exists (a::l1); exists y; exists l2; auto.
@@ -128,7 +173,7 @@ Lemma InA_app : forall l1 l2 x,
  InA x (l1 ++ l2) -> InA x l1 \/ InA x l2.
 Proof.
  induction l1; simpl in *; intuition.
- inversion_clear H; auto.
+ inv; auto.
  elim (IHl1 l2 x H0); auto.
 Qed.
 
@@ -144,7 +189,7 @@ Proof.
  apply in_or_app; auto.
 Qed.
 
-Lemma InA_rev : forall p m, 
+Lemma InA_rev : forall p m,
  InA p (rev m) <-> InA p m.
 Proof.
  intros; do 2 rewrite InA_alt.
@@ -153,107 +198,16 @@ Proof.
  rewrite <- In_rev; auto.
 Qed.
 
-(** Results concerning lists modulo [eqA] and [ltA] *)
-
-Variable ltA : A -> A -> Prop.
 
-Hypothesis ltA_trans : forall x y z, ltA x y -> ltA y z -> ltA x z.
-Hypothesis ltA_not_eqA : forall x y, ltA x y -> ~ eqA x y.
-Hypothesis ltA_eqA : forall x y z, ltA x y -> eqA y z -> ltA x z.
-Hypothesis eqA_ltA : forall x y z, eqA x y -> ltA y z -> ltA x z.
-
-Hint Resolve ltA_trans.
-Hint Immediate ltA_eqA eqA_ltA.
-
-Notation InfA:=(lelistA ltA).
-Notation SortA:=(sort ltA).
-
-Hint Constructors lelistA sort.
-
-Lemma InfA_ltA :
- forall l x y, ltA x y -> InfA y l -> InfA x l.
-Proof.
- destruct l; constructor; inversion_clear H0; 
- eapply ltA_trans; eauto.
-Qed.
- 
-Lemma InfA_eqA :
- forall l x y, eqA x y -> InfA y l -> InfA x l.
-Proof.
- intro s; case s; constructor; inversion_clear H0; eauto.
-Qed.
-Hint Immediate InfA_ltA InfA_eqA. 
-
-Lemma SortA_InfA_InA :
- forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
-Proof. 
- simple induction l.
- intros; inversion H1.
- intros.
- inversion_clear H0; inversion_clear H1; inversion_clear H2.
- eapply ltA_eqA; eauto.
- eauto.
-Qed.
-  
-Lemma In_InfA :
- forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
-Proof.
- simple induction l; simpl in |- *; intros; constructor; auto.
-Qed.
- 
-Lemma InA_InfA :
- forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
-Proof.
- simple induction l; simpl in |- *; intros; constructor; auto.
-Qed.
-
-(* In fact, this may be used as an alternative definition for InfA: *)
-
-Lemma InfA_alt : 
- forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
-Proof. 
-split.
-intros; eapply SortA_InfA_InA; eauto.
-apply InA_InfA.
-Qed.
-
-Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
-Proof.
- induction l1; simpl; auto.
- inversion_clear 1; auto.
-Qed.
-
-Lemma SortA_app :
- forall l1 l2, SortA l1 -> SortA l2 ->
- (forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
- SortA (l1 ++ l2).
-Proof.
- induction l1; simpl in *; intuition.
- inversion_clear H.
- constructor; auto.
- apply InfA_app; auto.
- destruct l2; auto.
-Qed.
 
 Section NoDupA.
 
-Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
-Proof.
- simple induction l; auto.
- intros x l' H H0.
- inversion_clear H0.
- constructor; auto.  
- intro.
- assert (ltA x x) by (eapply SortA_InfA_InA; eauto).
- elim (ltA_not_eqA H3); auto.
-Qed.
-
-Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> 
-  (forall x, InA x l -> InA x l' -> False) -> 
+Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' ->
+  (forall x, InA x l -> InA x l' -> False) ->
   NoDupA (l++l').
 Proof.
 induction l; simpl; auto; intros.
-inversion_clear H.
+inv.
 constructor.
 rewrite InA_alt; intros (y,(H4,H5)).
 destruct (in_app_or _ _ _ H5).
@@ -274,35 +228,36 @@ Proof.
 induction l.
 simpl; auto.
 simpl; intros.
-inversion_clear H.
+inv.
 apply NoDupA_app; auto.
 constructor; auto.
-intro H2; inversion H2.
+intro; inv.
 intros x.
 rewrite InA_alt.
 intros (x1,(H2,H3)).
-inversion_clear 1.
+intro; inv.
 destruct H0.
-apply InA_eqA with x1; eauto.
+rewrite <- H4, H2.
 apply In_InA.
 rewrite In_rev; auto.
-inversion H4.
 Qed.
 
 Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l').
 Proof.
- induction l; simpl in *; inversion_clear 1; auto.
+ induction l; simpl in *; intros; inv; auto.
  constructor; eauto.
  contradict H0.
- rewrite InA_app_iff in *; rewrite InA_cons; intuition.
+ rewrite InA_app_iff in *.
+ rewrite InA_cons.
+ intuition.
 Qed.
 
 Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l').
 Proof.
- induction l; simpl in *; inversion_clear 1; auto.
+ induction l; simpl in *; intros; inv; auto.
  constructor; eauto.
  assert (H2:=IHl _ _ H1).
- inversion_clear H2.
+ inv.
  rewrite InA_cons.
  red; destruct 1.
  apply H0.
@@ -314,287 +269,130 @@ Proof.
  eapply NoDupA_split; eauto.
 Qed.
 
-End NoDupA.
-
-(** Some results about [eqlistA] *)
-
-Section EqlistA.
-
-Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'.
-Proof.
-induction 1; auto; simpl; congruence.
-Qed.
-
-Lemma eqlistA_app : forall l1 l1' l2 l2', 
-   eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2').
-Proof.
-intros l1 l1' l2 l2' H; revert l2 l2'; induction H; simpl; auto.
-Qed.
-
-Lemma eqlistA_rev_app : forall l1 l1', 
-   eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> 
-   eqlistA ((rev l1)++l2) ((rev l1')++l2').
-Proof.
-induction 1; auto.
-simpl; intros.
-do 2 rewrite app_ass; simpl; auto.
-Qed.
-
-Lemma eqlistA_rev : forall l1 l1', 
-   eqlistA l1 l1' -> eqlistA (rev l1) (rev l1').
-Proof.
-intros.
-rewrite (app_nil_end (rev l1)).
-rewrite (app_nil_end (rev l1')).
-apply eqlistA_rev_app; auto.
-Qed.
-
-Lemma SortA_equivlistA_eqlistA : forall l l', 
-   SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'.
-Proof.
-induction l; destruct l'; simpl; intros; auto.
-destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4.  
-destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4.  
-inversion_clear H; inversion_clear H0.
-assert (forall y, InA y l -> ltA a y).
-intros; eapply SortA_InfA_InA with (l:=l); eauto.
-assert (forall y, InA y l' -> ltA a0 y).
-intros; eapply SortA_InfA_InA with (l:=l'); eauto.
-clear H3 H4.
-assert (eqA a a0).
- destruct (H1 a).
- destruct (H1 a0).
- assert (InA a (a0::l')) by auto.
- inversion_clear H8; auto.
- assert (InA a0 (a::l)) by auto.
- inversion_clear H8; auto.
- elim (@ltA_not_eqA a a); auto.
- apply ltA_trans with a0; auto.
-constructor; auto.
-apply IHl; auto.
-split; intros.
-destruct (H1 x).
-assert (H8 : InA x (a0::l')) by auto; inversion_clear H8; auto. 
-elim (@ltA_not_eqA a x); eauto.
-destruct (H1 x).
-assert (H8 : InA x (a::l)) by auto; inversion_clear H8; auto. 
-elim (@ltA_not_eqA a0 x); eauto.
-Qed.
-
-End EqlistA.
-
-(** A few things about [filter] *)
-
-Section Filter.
-
-Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l).
+Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y ->
+ NoDupA (x::l) -> NoDupA (l1++y::l2) ->
+ equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
 Proof.
-induction l; simpl; auto.
-inversion_clear 1; auto.
-destruct (f a); auto.
-constructor; auto.
-apply In_InfA; auto.
-intros.
-rewrite filter_In in H; destruct H.
-eapply SortA_InfA_InA; eauto.
+ intros; intro a.
+ generalize (H2 a).
+ rewrite !InA_app_iff, !InA_cons.
+ inv.
+ assert (SW:=NoDupA_swap H1). inv.
+ rewrite InA_app_iff in H0.
+ split; intros.
+ assert (~eqA a x) by (contradict H3; rewrite <- H3; auto).
+ assert (~eqA a y) by (rewrite <- H; auto).
+ tauto.
+ assert (OR : eqA a x \/ InA a l) by intuition. clear H6.
+ destruct OR as [EQN|INA]; auto.
+ elim H0.
+ rewrite <-H,<-EQN; auto.
 Qed.
 
-Lemma filter_InA : forall f, (compat_bool f) -> 
- forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
-Proof.
-intros; do 2 rewrite InA_alt; intuition.
-destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
-destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
-  rewrite (H _ _ H0); auto.
-destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition.
-  rewrite <- (H _ _ H0); auto.
-Qed.
+End NoDupA.
 
-Lemma filter_split : 
- forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> 
- forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l.
-Proof.
-induction l; simpl; intros; auto.
-inversion_clear H0.
-pattern l at 1; rewrite IHl; auto.
-case_eq (f a); simpl; intros; auto.
-assert (forall e, In e l -> f e = false).
-  intros.
-  assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)).
-  case_eq (f e); simpl; intros; auto.
-  elim (@ltA_not_eqA e e); auto.
-  apply ltA_trans with a; eauto.
-replace (List.filter f l) with (@nil A); auto.
-generalize H3; clear; induction l; simpl; auto.
-case_eq (f a); auto; intros.
-rewrite H3 in H; auto; try discriminate.
-Qed.
 
-End Filter.
 
 Section Fold.
 
 Variable B:Type.
 Variable eqB:B->B->Prop.
-
-(** Compatibility of a two-argument function with respect to two equalities. *)
-Definition compat_op (f : A -> B -> B) :=
-  forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y').
-
-(** Two-argument functions that allow to reorder their arguments. *)
-Definition transpose (f : A -> B -> B) :=
-  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). 
-
-(** A version of transpose with restriction on where it should hold *)
-Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) :=
-  forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)).
-
 Variable st:Equivalence eqB.
 Variable f:A->B->B.
 Variable i:B.
-Variable Comp:compat_op f.
+Variable Comp:Proper (eqA==>eqB==>eqB) f.
 
-Lemma fold_right_eqlistA : 
-   forall s s', eqlistA s s' -> 
+Lemma fold_right_eqlistA :
+   forall s s', eqlistA s s' ->
    eqB (fold_right f i s) (fold_right f i s').
 Proof.
-induction 1; simpl; auto.
-reflexivity.
-Qed.
-
-Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> 
- NoDupA (x::l) -> NoDupA (l1++y::l2) -> 
- equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
-Proof.
- intros; intro a.
- generalize (H2 a).
- repeat rewrite InA_app_iff.
- do 2 rewrite InA_cons.
- inversion_clear H0.
- assert (SW:=NoDupA_swap H1).
- inversion_clear SW.
- rewrite InA_app_iff in H0.
- split; intros.
- assert (~eqA a x).
-  contradict H3; apply InA_eqA with a; auto.
- assert (~eqA a y).
-  contradict H8; eauto.
- intuition.
- assert (eqA a x \/ InA a l) by intuition.
- destruct H8; auto.
- elim H0.
- destruct H7; [left|right]; eapply InA_eqA; eauto.
+induction 1; simpl; auto with relations.
+apply Comp; auto.
 Qed.
 
-(** [ForallList2] : specifies that a certain binary predicate should
-    always hold when inspecting two different elements of the list. *)
-
-Inductive ForallList2 (R : A -> A -> Prop) : list A -> Prop :=
-  | ForallNil : ForallList2 R nil
-  | ForallCons : forall a l,
-     (forall b, In b l -> R a b) ->
-     ForallList2 R l -> ForallList2 R (a::l).
-Hint Constructors ForallList2.
+(** Fold with restricted [transpose] hypothesis. *)
 
-(** [NoDupA] can be written in terms of [ForallList2] *)
-
-Lemma ForallList2_NoDupA : forall l,
- ForallList2 (fun a b => ~eqA a b) l <-> NoDupA l.
-Proof.
- induction l; split; intros; auto.
- inversion_clear H. constructor; [ | rewrite <- IHl; auto ].
- rewrite InA_alt; intros (a',(Haa',Ha')).
- exact (H0 a' Ha' Haa').
- inversion_clear H. constructor; [ | rewrite IHl; auto ].
- intros b Hb.
- contradict H0.
- rewrite InA_alt; exists b; auto.
-Qed.
+Section Fold_With_Restriction.
+Variable R : A -> A -> Prop.
+Hypothesis R_sym : Symmetric R.
+Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.
 
-Lemma ForallList2_impl : forall (R R':A->A->Prop),
- (forall a b, R a b -> R' a b) ->
- forall l, ForallList2 R l -> ForallList2 R' l.
-Proof.
- induction 2; auto.
-Qed.
 
-(** The following definition is easier to use than [ForallList2]. *)
+(*
 
-Definition ForallList2_alt (R:A->A->Prop) l :=
- forall a b, InA a l -> InA b l -> ~eqA a b -> R a b.
+(** [ForallOrdPairs R] is compatible with [equivlistA] over the
+    lists without duplicates, as long as the relation [R]
+    is symmetric and compatible with [eqA]. To prove this fact,
+    we use an auxiliary notion: "forall distinct pairs, ...".
+*)
 
-Section Restriction.
-Variable R : A -> A -> Prop.
+Definition ForallNeqPairs :=
+ ForallPairs (fun a b => ~eqA a b -> R a b).
 
-(** [ForallList2] and [ForallList2_alt] are related, but no completely
+(** [ForallOrdPairs] and [ForallNeqPairs] are related, but not completely
     equivalent. For proving one implication, we need to know that the
     list has no duplicated elements... *)
 
-Lemma ForallList2_equiv1 : forall l, NoDupA l ->
- ForallList2_alt R l -> ForallList2 R l.
+Lemma ForallNeqPairs_ForallOrdPairs : forall l, NoDupA l ->
+ ForallNeqPairs l -> ForallOrdPairs R l.
 Proof.
  induction l; auto.
- constructor. intros b Hb.
- inversion_clear H.
- apply H0; auto.
- contradict H1.
- apply InA_eqA with b; auto.
+ constructor. inv.
+ rewrite Forall_forall; intros b Hb.
+ apply H0; simpl; auto.
+ contradict H1; rewrite H1; auto.
  apply IHl.
- inversion_clear H; auto.
+ inv; auto.
  intros b c Hb Hc Hneq.
- apply H0; auto.
+ apply H0; simpl; auto.
 Qed.
 
 (** ... and for proving the other implication, we need to be able
-   to reverse and adapt relation [R] modulo [eqA]. *)
-
-Hypothesis R_sym : forall a b, R a b -> R b a.
-Hypothesis R_compat : forall a, compat_P (R a).
+   to reverse relation [R]. *)
 
-Lemma ForallList2_equiv2 : forall l,
- ForallList2 R l -> ForallList2_alt R l.
+Lemma ForallOrdPairs_ForallNeqPairs : forall l,
+ ForallOrdPairs R l -> ForallNeqPairs l.
 Proof.
- induction l.
- intros _. red. intros a b Ha. inversion Ha.
- inversion_clear 1 as [|? ? H_R Hl].
- intros b c Hb Hc Hneq.
- inversion_clear Hb; inversion_clear Hc.
- (* b,c = a : impossible *)
- elim Hneq; eauto.
- (* b = a, c in l *)
- rewrite InA_alt in H0; destruct H0 as (d,(Hcd,Hd)).
- apply R_compat with d; auto.
- apply R_sym; apply R_compat with a; auto.
- (* b in l, c = a *)
- rewrite InA_alt in H; destruct H as (d,(Hcd,Hd)).
- apply R_compat with a; auto.
- apply R_sym; apply R_compat with d; auto.
- (* b,c in l *)
- apply (IHl Hl); auto.
+ intros l Hl x y Hx Hy N.
+ destruct (ForallOrdPairs_In Hl x y Hx Hy) as [H|[H|H]].
+ subst; elim N; auto.
+ assumption.
+ apply R_sym; assumption.
 Qed.
 
-Lemma ForallList2_equiv : forall l, NoDupA l ->
- (ForallList2 R l <-> ForallList2_alt R l).
-Proof.
-split; [apply ForallList2_equiv2|apply ForallList2_equiv1]; auto.
-Qed.
+*)
+
+(** Compatibility of [ForallOrdPairs] with respect to [inclA]. *)
 
-Lemma ForallList2_equivlistA : forall l l', NoDupA l' ->
- equivlistA l l' -> ForallList2 R l -> ForallList2 R l'.
+Lemma ForallOrdPairs_inclA : forall l l',
+ NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'.
 Proof.
-intros.
-apply ForallList2_equiv1; auto.
-intros a b Ha Hb Hneq.
-red in H0; rewrite <- H0 in Ha,Hb.
-revert a b Ha Hb Hneq.
-change (ForallList2_alt R l).
-apply ForallList2_equiv2; auto.
+induction l' as [|x l' IH].
+constructor.
+intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto.
+rewrite Forall_forall; intros y Hy.
+assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto).
+ apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx').
+assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto).
+ apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy').
+rewrite Hxx', Hyy'.
+destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto.
+absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto.
 Qed.
 
+
+(** Two-argument functions that allow to reorder their arguments. *)
+Definition transpose (f : A -> B -> B) :=
+  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)).
+
+(** A version of transpose with restriction on where it should hold *)
+Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) :=
+  forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)).
+
 Variable TraR :transpose_restr R f.
 
 Lemma fold_right_commutes_restr :
-  forall s1 s2 x, ForallList2 R (s1++x::s2) ->
+  forall s1 s2 x, ForallOrdPairs R (s1++x::s2) ->
   eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
 Proof.
 induction s1; simpl; auto; intros.
@@ -602,15 +400,15 @@ reflexivity.
 transitivity (f a (f x (fold_right f i (s1++s2)))).
 apply Comp; auto.
 apply IHs1.
-inversion_clear H; auto.
+invlist ForallOrdPairs; auto.
 apply TraR.
-inversion_clear H.
-apply H0.
+invlist ForallOrdPairs; auto.
+rewrite Forall_forall in H0; apply H0.
 apply in_or_app; simpl; auto.
 Qed.
 
 Lemma fold_right_equivlistA_restr :
-  forall s s', NoDupA s -> NoDupA s' -> ForallList2 R s ->
+  forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
   equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
 Proof.
  simple induction s.
@@ -618,35 +416,35 @@ Proof.
  intros; reflexivity.
  unfold equivlistA; intros.
  destruct (H2 a).
- assert (X : InA a nil); auto; inversion X.
+ assert (InA a nil) by auto; inv.
  intros x l Hrec s' N N' F E; simpl in *.
- assert (InA x s').
-  rewrite <- (E x); auto.
+ assert (InA x s') by (rewrite <- (E x); auto).
  destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
  subst s'.
  transitivity (f x (fold_right f i (s1++s2))).
  apply Comp; auto.
  apply Hrec; auto.
- inversion_clear N; auto.
+ inv; auto.
  eapply NoDupA_split; eauto.
- inversion_clear F; auto.
+ invlist ForallOrdPairs; auto.
  eapply equivlistA_NoDupA_split; eauto.
  transitivity (f y (fold_right f i (s1++s2))).
  apply Comp; auto. reflexivity.
  symmetry; apply fold_right_commutes_restr.
- apply ForallList2_equivlistA with (x::l); auto.
+ apply ForallOrdPairs_inclA with (x::l); auto.
+  red; intros; rewrite E; auto.
 Qed.
 
 Lemma fold_right_add_restr :
-  forall s' s x, NoDupA s -> NoDupA s' -> ForallList2 R s' -> ~ InA x s ->
+  forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s ->
   equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
 Proof.
  intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto.
 Qed.
 
-End Restriction.
+End Fold_With_Restriction.
 
-(** we know state similar results, but without restriction on transpose. *)
+(** we now state similar results, but without restriction on transpose. *)
 
 Variable Tra :transpose f.
 
@@ -656,6 +454,7 @@ Proof.
 induction s1; simpl; auto; intros.
 reflexivity.
 transitivity (f a (f x (fold_right f i (s1++s2)))); auto.
+apply Comp; auto.
 Qed.
 
 Lemma fold_right_equivlistA :
@@ -663,8 +462,8 @@ Lemma fold_right_equivlistA :
   equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
 Proof.
 intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True);
- try red; auto.
-apply ForallList2_equiv1; try red; auto.
+ repeat red; auto.
+apply ForallPairs_ForallOrdPairs; try red; auto.
 Qed.
 
 Lemma fold_right_add :
@@ -674,6 +473,8 @@ Proof.
  intros; apply (@fold_right_equivlistA s' (x::s)); auto.
 Qed.
 
+End Fold.
+
 Section Remove.
 
 Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
@@ -682,15 +483,15 @@ Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
 Proof.
 induction l.
 right; auto.
-red; inversion 1.
+intro; inv.
 destruct (eqA_dec x a).
 left; auto.
 destruct IHl.
 left; auto.
-right; red; inversion_clear 1; contradiction. 
-Qed.
+right; intro; inv; contradiction.
+Defined.
 
-Fixpoint removeA (x : A) (l : list A){struct l} : list A :=
+Fixpoint removeA (x : A) (l : list A) : list A :=
   match l with
     | nil => nil
     | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl)
@@ -708,21 +509,21 @@ Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y.
 Proof.
 induction l; simpl; auto.
 split.
-inversion_clear 1.
-destruct 1; inversion_clear H.
+intro; inv.
+destruct 1; inv.
 intros.
 destruct (eqA_dec x a); simpl; auto.
 rewrite IHl; split; destruct 1; split; auto.
-inversion_clear H; auto.
-destruct H0; apply eqA_trans with a; auto.
+inv; auto.
+destruct H0; transitivity a; auto.
 split.
-inversion_clear 1.
+intro; inv.
 split; auto.
 contradict n.
-apply eqA_trans with y; auto.
+transitivity y; auto.
 rewrite (IHl x y) in H0; destruct H0; auto.
-destruct 1; inversion_clear H; auto.
-constructor 2; rewrite IHl; auto.
+destruct 1; inv; auto.
+right; rewrite IHl; auto.
 Qed.
 
 Lemma removeA_NoDupA :
@@ -730,17 +531,17 @@ Lemma removeA_NoDupA :
 Proof.
 simple induction s; simpl; intros.
 auto.
-inversion_clear H0.
-destruct (eqA_dec x a); simpl; auto. 
+inv.
+destruct (eqA_dec x a); simpl; auto.
 constructor; auto.
 rewrite removeA_InA.
 intuition.
-Qed. 
+Qed.
 
-Lemma removeA_equivlistA : forall l l' x, 
+Lemma removeA_equivlistA : forall l l' x,
   ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l').
-Proof.  
-unfold equivlistA; intros. 
+Proof.
+unfold equivlistA; intros.
 rewrite removeA_InA.
 split; intros.
 rewrite <- H0; split; auto.
@@ -748,64 +549,306 @@ contradict H.
 apply InA_eqA with x0; auto.
 rewrite <- (H0 x0) in H1.
 destruct H1.
-inversion_clear H1; auto.
+inv; auto.
 elim H2; auto.
 Qed.
 
 End Remove.
 
-End Fold.
 
+
+(** Results concerning lists modulo [eqA] and [ltA] *)
+
+Variable ltA : A -> A -> Prop.
+Hypothesis ltA_strorder : StrictOrder ltA.
+Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA.
+
+Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder).
+
+Notation InfA:=(lelistA ltA).
+Notation SortA:=(sort ltA).
+
+Hint Constructors lelistA sort.
+
+Lemma InfA_ltA :
+ forall l x y, ltA x y -> InfA y l -> InfA x l.
+Proof.
+ destruct l; constructor. inv; eauto.
+Qed.
+
+Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA.
+Proof.
+ intros x x' Hxx' l l' Hll'.
+ inversion_clear Hll'.
+ intuition.
+ split; intro; inv; constructor.
+ rewrite <- Hxx', <- H; auto.
+ rewrite Hxx', H; auto.
+Qed.
+
+(** For compatibility, can be deduced from [InfA_compat] *)
+Lemma InfA_eqA :
+ forall l x y, eqA x y -> InfA y l -> InfA x l.
+Proof.
+ intros l x y H; rewrite H; auto.
+Qed.
+Hint Immediate InfA_ltA InfA_eqA.
+
+Lemma SortA_InfA_InA :
+ forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
+Proof.
+ simple induction l.
+ intros. inv.
+ intros. inv.
+ setoid_replace x with a; auto.
+ eauto.
+Qed.
+
+Lemma In_InfA :
+ forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
+Proof.
+ simple induction l; simpl; intros; constructor; auto.
+Qed.
+
+Lemma InA_InfA :
+ forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
+Proof.
+ simple induction l; simpl; intros; constructor; auto.
+Qed.
+
+(* In fact, this may be used as an alternative definition for InfA: *)
+
+Lemma InfA_alt :
+ forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
+Proof.
+split.
+intros; eapply SortA_InfA_InA; eauto.
+apply InA_InfA.
+Qed.
+
+Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
+Proof.
+ induction l1; simpl; auto.
+ intros; inv; auto.
+Qed.
+
+Lemma SortA_app :
+ forall l1 l2, SortA l1 -> SortA l2 ->
+ (forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
+ SortA (l1 ++ l2).
+Proof.
+ induction l1; simpl in *; intuition.
+ inv.
+ constructor; auto.
+ apply InfA_app; auto.
+ destruct l2; auto.
+Qed.
+
+Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
+Proof.
+ simple induction l; auto.
+ intros x l' H H0.
+ inv.
+ constructor; auto.
+ intro.
+ apply (StrictOrder_Irreflexive x).
+ eapply SortA_InfA_InA; eauto.
+Qed.
+
+
+(** Some results about [eqlistA] *)
+
+Section EqlistA.
+
+Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'.
+Proof.
+induction 1; auto; simpl; congruence.
+Qed.
+
+Global Instance app_eqlistA_compat :
+ Proper (eqlistA==>eqlistA==>eqlistA) (@app A).
+Proof.
+ repeat red; induction 1; simpl; auto.
+Qed.
+
+(** For compatibility, can be deduced from app_eqlistA_compat **)
+Lemma eqlistA_app : forall l1 l1' l2 l2',
+   eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2').
+Proof.
+intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity.
+Qed.
+
+Lemma eqlistA_rev_app : forall l1 l1',
+   eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' ->
+   eqlistA ((rev l1)++l2) ((rev l1')++l2').
+Proof.
+induction 1; auto.
+simpl; intros.
+do 2 rewrite app_ass; simpl; auto.
+Qed.
+
+Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A).
+Proof.
+repeat red. intros.
+rewrite (app_nil_end (rev x)), (app_nil_end (rev y)).
+apply eqlistA_rev_app; auto.
+Qed.
+
+Lemma eqlistA_rev : forall l1 l1',
+   eqlistA l1 l1' -> eqlistA (rev l1) (rev l1').
+Proof.
+apply rev_eqlistA_compat.
+Qed.
+
+Lemma SortA_equivlistA_eqlistA : forall l l',
+   SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'.
+Proof.
+induction l; destruct l'; simpl; intros; auto.
+destruct (H1 a); assert (InA a nil) by auto; inv.
+destruct (H1 a); assert (InA a nil) by auto; inv.
+inv.
+assert (forall y, InA y l -> ltA a y).
+intros; eapply SortA_InfA_InA with (l:=l); eauto.
+assert (forall y, InA y l' -> ltA a0 y).
+intros; eapply SortA_InfA_InA with (l:=l'); eauto.
+clear H3 H4.
+assert (eqA a a0).
+ destruct (H1 a).
+ destruct (H1 a0).
+ assert (InA a (a0::l')) by auto. inv; auto.
+ assert (InA a0 (a::l)) by auto. inv; auto.
+ elim (StrictOrder_Irreflexive a); eauto.
+constructor; auto.
+apply IHl; auto.
+split; intros.
+destruct (H1 x).
+assert (InA x (a0::l')) by auto. inv; auto.
+rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto.
+destruct (H1 x).
+assert (InA x (a::l)) by auto. inv; auto.
+rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto.
+Qed.
+
+End EqlistA.
+
+(** A few things about [filter] *)
+
+Section Filter.
+
+Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l).
+Proof.
+induction l; simpl; auto.
+intros; inv; auto.
+destruct (f a); auto.
+constructor; auto.
+apply In_InfA; auto.
+intros.
+rewrite filter_In in H; destruct H.
+eapply SortA_InfA_InA; eauto.
+Qed.
+
+Implicit Arguments eq [ [A] ].
+
+Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
+ forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
+Proof.
+clear ltA ltA_compat ltA_strorder.
+intros; do 2 rewrite InA_alt; intuition.
+destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
+destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
+  rewrite (H _ _ H0); auto.
+destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition.
+  rewrite <- (H _ _ H0); auto.
+Qed.
+
+Lemma filter_split :
+ forall f, (forall x y, f x = true -> f y = false -> ltA x y) ->
+ forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l.
+Proof.
+induction l; simpl; intros; auto.
+inv.
+rewrite IHl at 1; auto.
+case_eq (f a); simpl; intros; auto.
+assert (forall e, In e l -> f e = false).
+  intros.
+  assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)).
+  case_eq (f e); simpl; intros; auto.
+  elim (StrictOrder_Irreflexive e).
+  transitivity a; auto.
+replace (List.filter f l) with (@nil A); auto.
+generalize H3; clear; induction l; simpl; auto.
+case_eq (f a); auto; intros.
+rewrite H3 in H; auto; try discriminate.
+Qed.
+
+End Filter.
 End Type_with_equality.
 
-Hint Unfold compat_bool compat_nat compat_P.
-Hint Constructors InA NoDupA sort lelistA eqlistA.
 
-Section Find. 
-Variable A B : Type. 
-Variable eqA : A -> A -> Prop. 
-Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x.
-Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+Hint Constructors InA eqlistA NoDupA sort lelistA.
+
+Section Find.
+
+Variable A B : Type.
+Variable eqA : A -> A -> Prop.
+Hypothesis eqA_equiv : Equivalence eqA.
 Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
 
-Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := 
- match l with  
-  | nil => None 
+Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B :=
+ match l with
+  | nil => None
   | (a,b)::l => if f a then Some b else findA f l
  end.
 
-Lemma findA_NoDupA : 
- forall l a b, 
- NoDupA (fun p p' => eqA (fst p) (fst p')) l -> 
+Lemma findA_NoDupA :
+ forall l a b,
+ NoDupA (fun p p' => eqA (fst p) (fst p')) l ->
  (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
   findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
 Proof.
-induction l; simpl; intros.
+set (eqk := fun p p' : A*B => eqA (fst p) (fst p')).
+set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p').
+induction l; intros; simpl.
 split; intros; try discriminate.
-inversion H0.
+invlist InA.
 destruct a as (a',b'); rename a0 into a.
-inversion_clear H.
+invlist NoDupA.
 split; intros.
-inversion_clear H.
-simpl in *; destruct H2; subst b'.
+invlist InA.
+compute in H2; destruct H2. subst b'.
 destruct (eqA_dec a a'); intuition.
 destruct (eqA_dec a a'); simpl.
-destruct H0.
-generalize e H2 eqA_trans eqA_sym; clear.
+contradict H0.
+revert e H2; clear - eqA_equiv.
 induction l.
-inversion 2.
-inversion_clear 2; intros; auto.
+intros; invlist InA.
+intros; invlist InA; auto.
 destruct a0.
 compute in H; destruct H.
 subst b.
-constructor 1; auto.
-simpl.
-apply eqA_trans with a; auto.
+left; auto.
+compute.
+transitivity a; auto. symmetry; auto.
 rewrite <- IHl; auto.
 destruct (eqA_dec a a'); simpl in *.
-inversion H; clear H; intros; subst b'; auto.
-constructor 2.
-rewrite IHl; auto.
+left; split; simpl; congruence.
+right. rewrite IHl; auto.
 Qed.
 
-End Find. 
+End Find.
+
+
+(** Compatibility aliases. [Proper] is rather to be used directly now.*)
+
+Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) :=
+ Proper (eqA==>Logic.eq) f.
+
+Definition compat_nat {A} (eqA:A->A->Prop)(f:A->nat) :=
+ Proper (eqA==>Logic.eq) f.
+
+Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) :=
+ Proper (eqA==>impl) P.
+
+Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) :=
+ Proper (eqA==>eqB==>eqB) f.
+
diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v
index bdbe0ecc..d906cfa4 100644
--- a/theories/Lists/StreamMemo.v
+++ b/theories/Lists/StreamMemo.v
@@ -11,8 +11,8 @@ Require Import Streams.
 
 (** * Memoization *)
 
-(** Successive outputs of a given function [f] are stored in 
-    a stream in order to avoid duplicated computations. *) 
+(** Successive outputs of a given function [f] are stored in
+    a stream in order to avoid duplicated computations. *)
 
 Section MemoFunction.
 
@@ -24,8 +24,8 @@ CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)).
 Definition memo_list := memo_make 0.
 
 Fixpoint memo_get (n:nat) (l:Stream A) : A :=
-  match n with 
-    | O => hd l 
+  match n with
+    | O => hd l
     | S n1 => memo_get n1 (tl l)
   end.
 
@@ -49,7 +49,7 @@ Variable g: A -> A.
 Hypothesis Hg_correct: forall n, f (S n) = g (f n).
 
 CoFixpoint imemo_make (fn:A) : Stream A :=
-  let fn1 := g fn in 
+  let fn1 := g fn in
   Cons fn1 (imemo_make fn1).
 
 Definition imemo_list := let f0 := f 0 in
@@ -68,7 +68,7 @@ Qed.
 
 End MemoFunction.
 
-(** For a dependent function, the previous solution is 
+(** For a dependent function, the previous solution is
     reused thanks to a temporarly hiding of the dependency
     in a "container" [memo_val]. *)
 
@@ -80,7 +80,7 @@ Variable f: forall n, A n.
 Inductive memo_val: Type :=
   memo_mval: forall n, A n -> memo_val.
 
-Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} :=
+Fixpoint is_eq (n m : nat) : {n = m} + {True} :=
   match n, m return {n = m} + {True} with
   | 0, 0 =>left True (refl_equal 0)
   | 0, S m1 => right (0 = S m1) I
@@ -88,7 +88,7 @@ Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} :=
   | S n1, S m1 =>
      match is_eq n1 m1 with
      | left H => left True (f_equal S H)
-     | right _ => right (S n1 = S m1) I 
+     | right _ => right (S n1 = S m1) I
      end
   end.
 
@@ -97,7 +97,7 @@ match v with
 | memo_mval m x =>
     match is_eq n m with
     | left H =>
-       match H in (@eq _ _ y) return (A y -> A n) with
+       match H in (eq _ y) return (A y -> A n) with
         | refl_equal => fun v1 : A n => v1
        end
     | right _ => fun _ : A m => f n
@@ -134,7 +134,7 @@ Variable g: forall n, A n -> A (S n).
 
 Hypothesis Hg_correct: forall n, f (S n) = g n (f n).
 
-Let mg v :=  match v with 
+Let mg v :=  match v with
              memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end.
 
 Definition dimemo_list := imemo_list _ mf mg.
@@ -166,13 +166,13 @@ End DependentMemoFunction.
 Require Import ZArith.
 Open Scope Z_scope.
 
-Fixpoint tfact (n: nat) := 
-  match n with 
-   | O => 1 
-   | S n1 => Z_of_nat n * tfact n1 
+Fixpoint tfact (n: nat) :=
+  match n with
+   | O => 1
+   | S n1 => Z_of_nat n * tfact n1
   end.
 
-Definition lfact_list := 
+Definition lfact_list :=
   dimemo_list _ tfact (fun n z => (Z_of_nat (S  n) * z)).
 
 Definition lfact n := dmemo_get _ tfact n lfact_list.
@@ -183,18 +183,18 @@ intros n; unfold lfact, lfact_list.
 rewrite dimemo_get_correct; auto.
 Qed.
 
-Fixpoint nop p := 
+Fixpoint nop p :=
   match p with
-   | xH => 0 
-   | xI p1 => nop p1 
-   | xO p1 => nop p1 
+   | xH => 0
+   | xI p1 => nop p1
+   | xO p1 => nop p1
   end.
 
-Fixpoint test z := 
+Fixpoint test z :=
   match z with
-   | Z0 => 0 
-   | Zpos p1 => nop p1 
-   | Zneg p1 => nop p1 
+   | Z0 => 0
+   | Zpos p1 => nop p1
+   | Zneg p1 => nop p1
   end.
 
 Time Eval vm_compute in test (lfact 2000).
@@ -202,4 +202,4 @@ Time Eval vm_compute in test (lfact 2000).
 Time Eval vm_compute in test (lfact 1500).
 Time Eval vm_compute in (lfact 1500).
 *)
- 
+
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
index 49990502..3fa053b7 100644
--- a/theories/Lists/Streams.v
+++ b/theories/Lists/Streams.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Streams.v 9967 2007-07-11 15:25:03Z roconnor $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -29,7 +29,7 @@ Definition tl (x:Stream) := match x with
                             end.
 
 
-Fixpoint Str_nth_tl (n:nat) (s:Stream) {struct n} : Stream :=
+Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream :=
   match n with
   | O => s
   | S m => Str_nth_tl m (tl s)
@@ -41,7 +41,7 @@ Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s).
 Lemma unfold_Stream :
  forall x:Stream, x = match x with
                       | Cons a s => Cons a s
-                      end. 
+                      end.
 Proof.
   intro x.
   case x.
@@ -223,7 +223,7 @@ Variable f: A -> B -> C.
 CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C :=
 Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)).
 
-Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), 
+Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B),
  Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b).
 Proof.
 induction n.
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
index 2bfb70fe..7ed9c519 100644
--- a/theories/Lists/TheoryList.v
+++ b/theories/Lists/TheoryList.v
@@ -6,12 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: TheoryList.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Some programs and results about lists following CAML Manual *)
 
 Require Export List.
 Set Implicit Arguments.
+
+Local Notation "[ ]" := nil (at level 0).
+Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0).
+
 Section Lists.
 
 Variable A : Type.
@@ -23,11 +27,13 @@ Variable A : Type.
 Definition Isnil (l:list A) : Prop := nil = l.
 
 Lemma Isnil_nil : Isnil nil.
+Proof.
 red in |- *; auto.
 Qed.
 Hint Resolve Isnil_nil.
 
 Lemma not_Isnil_cons : forall (a:A) (l:list A), ~ Isnil (a :: l).
+Proof.
 unfold Isnil in |- *.
 intros; discriminate.
 Qed.
@@ -35,6 +41,7 @@ Qed.
 Hint Resolve Isnil_nil not_Isnil_cons.
 
 Lemma Isnil_dec : forall l:list A, {Isnil l} + {~ Isnil l}.
+Proof.
 intro l; case l; auto.
 (*
 Realizer (fun l => match l with
@@ -50,6 +57,7 @@ Qed.
 
 Lemma Uncons :
  forall l:list A, {a : A &  {m : list A | a :: m = l}} + {Isnil l}.
+Proof.
 intro l; case l.
 auto.
 intros a m; intros; left; exists a; exists m; reflexivity.
@@ -67,6 +75,7 @@ Qed.
 
 Lemma Hd :
  forall l:list A, {a : A |  exists m : list A, a :: m = l} + {Isnil l}.
+Proof.
 intro l; case l.
 auto.
 intros a m; intros; left; exists a; exists m; reflexivity.
@@ -81,6 +90,7 @@ Qed.
 Lemma Tl :
  forall l:list A,
    {m : list A | (exists a : A, a :: m = l) \/ Isnil l /\ Isnil m}.
+Proof.
 intro l; case l.
 exists (nil (A:=A)); auto.
 intros a m; intros; exists m; left; exists a; reflexivity.
@@ -97,7 +107,7 @@ Qed.
 (****************************************)
 
 (* length is defined in List *)
-Fixpoint Length_l (l:list A) (n:nat) {struct l} : nat :=
+Fixpoint Length_l (l:list A) (n:nat) : nat :=
   match l with
   | nil => n
   | _ :: m => Length_l m (S n)
@@ -105,6 +115,7 @@ Fixpoint Length_l (l:list A) (n:nat) {struct l} : nat :=
 
 (* A tail recursive version *)
 Lemma Length_l_pf : forall (l:list A) (n:nat), {m : nat | n + length l = m}.
+Proof.
 induction l as [| a m lrec].
 intro n; exists n; simpl in |- *; auto.
 intro n; elim (lrec (S n)); simpl in |- *; intros.
@@ -115,6 +126,7 @@ Realizer Length_l.
 Qed.
 
 Lemma Length : forall l:list A, {m : nat | length l = m}.
+Proof.
 intro l. apply (Length_l_pf l 0).
 (*
 Realizer (fun l -> Length_l_pf l O).
@@ -139,14 +151,9 @@ elim l;
 intros; elim H; auto.
 Qed.
 
-Inductive AllS (P:A -> Prop) : list A -> Prop :=
-  | allS_nil : AllS P nil
-  | allS_cons : forall (a:A) (l:list A), P a -> AllS P l -> AllS P (a :: l).
-Hint Resolve allS_nil allS_cons.
-
 Hypothesis eqA_dec : forall a b:A, {a = b} + {a <> b}.
 
-Fixpoint mem (a:A) (l:list A) {struct l} : bool :=
+Fixpoint mem (a:A) (l:list A) : bool :=
   match l with
   | nil => false
   | b :: m => if eqA_dec a b then true else mem a m
@@ -154,7 +161,7 @@ Fixpoint mem (a:A) (l:list A) {struct l} : bool :=
 
 Hint Unfold In.
 Lemma Mem : forall (a:A) (l:list A), {In a l} + {AllS (fun b:A => b <> a) l}.
-intros a l.
+Proof.
 induction l.
 auto.
 elim (eqA_dec a a0).
@@ -188,20 +195,23 @@ Hint Resolve fst_nth_O fst_nth_S.
 
 Lemma fst_nth_nth :
  forall (l:list A) (n:nat) (a:A), fst_nth_spec l n a -> nth_spec l n a.
+Proof.
 induction 1; auto.
 Qed.
 Hint Immediate fst_nth_nth.
 
 Lemma nth_lt_O : forall (l:list A) (n:nat) (a:A), nth_spec l n a -> 0 < n.
+Proof.
 induction 1; auto.
 Qed.
 
 Lemma nth_le_length :
  forall (l:list A) (n:nat) (a:A), nth_spec l n a -> n <= length l.
+Proof.
 induction 1; simpl in |- *; auto with arith.
 Qed.
 
-Fixpoint Nth_func (l:list A) (n:nat) {struct l} : Exc A :=
+Fixpoint Nth_func (l:list A) (n:nat) : Exc A :=
   match l, n with
   | a :: _, S O => value a
   | _ :: l', S (S p) => Nth_func l' (S p)
@@ -211,6 +221,7 @@ Fixpoint Nth_func (l:list A) (n:nat) {struct l} : Exc A :=
 Lemma Nth :
  forall (l:list A) (n:nat),
    {a : A | nth_spec l n a} + {n = 0 \/ length l < n}.
+Proof.
 induction l as [| a l IHl].
 intro n; case n; simpl in |- *; auto with arith.
 intro n; destruct n as [| [| n1]]; simpl in |- *; auto.
@@ -227,6 +238,7 @@ Qed.
 
 Lemma Item :
  forall (l:list A) (n:nat), {a : A | nth_spec l (S n) a} + {length l <= n}.
+Proof.
 intros l n; case (Nth l (S n)); intro.
 case s; intro a; left; exists a; auto.
 right; case o; intro.
@@ -237,7 +249,7 @@ Qed.
 Require Import Minus.
 Require Import DecBool.
 
-Fixpoint index_p (a:A) (l:list A) {struct l} : nat -> Exc nat :=
+Fixpoint index_p (a:A) (l:list A) : nat -> Exc nat :=
   match l with
   | nil => fun p => error
   | b :: m => fun p => ifdec (eqA_dec a b) (value p) (index_p a m (S p))
@@ -246,6 +258,7 @@ Fixpoint index_p (a:A) (l:list A) {struct l} : nat -> Exc nat :=
 Lemma Index_p :
  forall (a:A) (l:list A) (p:nat),
    {n : nat | fst_nth_spec l (S n - p) a} + {AllS (fun b:A => a <> b) l}.
+Proof.
 induction l as [| b m irec].
 auto.
 intro p.
@@ -264,6 +277,7 @@ Lemma Index :
  forall (a:A) (l:list A),
    {n : nat | fst_nth_spec l n a} + {AllS (fun b:A => a <> b) l}.
 
+Proof.
 intros a l; case (Index_p a l 1); auto.
 intros [n P]; left; exists n; auto.
 rewrite (minus_n_O n); trivial.
@@ -287,20 +301,24 @@ Definition InR_inv (l:list A) :=
   end.
 
 Lemma InR_INV : forall l:list A, InR l -> InR_inv l.
+Proof.
 induction 1; simpl in |- *; auto.
 Qed.
 
 Lemma InR_cons_inv : forall (a:A) (l:list A), InR (a :: l) -> R a \/ InR l.
+Proof.
 intros a l H; exact (InR_INV H).
 Qed.
 
 Lemma InR_or_app : forall l m:list A, InR l \/ InR m -> InR (l ++ m).
+Proof.
 intros l m [| ].
 induction 1; simpl in |- *; auto.
 intro. induction l; simpl in |- *; auto.
 Qed.
 
 Lemma InR_app_or : forall l m:list A, InR (l ++ m) -> InR l \/ InR m.
+Proof.
 intros l m; elim l; simpl in |- *; auto.
 intros b l' Hrec IAc; elim (InR_cons_inv IAc); auto.
 intros; elim Hrec; auto.
@@ -315,6 +333,7 @@ Fixpoint find (l:list A) : Exc A :=
   end.
 
 Lemma Find : forall l:list A, {a : A | In a l &  R a} + {AllS P l}.
+Proof.
 induction l as [| a m [[b H1 H2]| H]]; auto.
 left; exists b; auto.
 destruct (RS_dec a).
@@ -342,6 +361,7 @@ Fixpoint try_find (l:list A) : Exc B :=
 
 Lemma Try_find :
  forall l:list A, {c : B |  exists2 a : A, In a l & T a c} + {AllS P l}.
+Proof.
 induction l as [| a m [[b H1]| H]].
 auto.
 left; exists b; destruct H1 as [a' H2 H3]; exists a'; auto.
@@ -349,7 +369,7 @@ destruct (TS_dec a) as [[c H1]| ].
 left; exists c.
 exists a; auto.
 auto.
-(* 
+(*
 Realizer try_find.
 *)
 Qed.
@@ -359,7 +379,7 @@ End Find_sec.
 Section Assoc_sec.
 
 Variable B : Type.
-Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : 
+Fixpoint assoc (a:A) (l:list (A * B)) :
  Exc B :=
   match l with
   | nil => error
@@ -383,6 +403,7 @@ Hint Resolve allS_assoc_nil allS_assoc_cons.
 
 Lemma Assoc :
  forall (a:A) (l:list (A * B)), B + {AllS_assoc (fun a':A => a <> a') l}.
+Proof.
 induction l as [| [a' b] m assrec]. auto.
 destruct (eqA_dec a a').
 left; exact b.
@@ -398,6 +419,5 @@ End Assoc_sec.
 
 End Lists.
 
-Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons allS_nil allS_cons:
-  datatypes.
+Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons : datatypes.
 Hint Immediate fst_nth_nth: datatypes.
diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex
index c45f8803..0051e2c2 100755
--- a/theories/Lists/intro.tex
+++ b/theories/Lists/intro.tex
@@ -21,7 +21,4 @@ This library includes the following files:
   coinductive type. Basic facts are stated and proved. The streams are
   also polymorphic.
 
-\item {\tt MonoList.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY
-  WITH OLDER VERSIONS OF COQ. THE USER SHOULD USE {\tt List.v} INSTEAD.
-
 \end{itemize}
diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget
new file mode 100644
index 00000000..d2a31367
--- /dev/null
+++ b/theories/Lists/vo.itarget
@@ -0,0 +1,7 @@
+ListSet.vo
+ListTactics.vo
+List.vo
+SetoidList.vo
+StreamMemo.vo
+Streams.vo
+TheoryList.vo
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
index 9eaef07a..5b2f5063 100644
--- a/theories/Logic/Berardi.v
+++ b/theories/Logic/Berardi.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Berardi.v 8122 2006-03-04 19:26:40Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file formalizes Berardi's paradox which says that in
    the calculus of constructions, excluded middle (EM) and axiom of
@@ -67,10 +67,10 @@ Section Retracts.
 
 Variables A B : Prop.
 
-Record retract : Prop := 
+Record retract : Prop :=
   {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.
 
-Record retract_cond : Prop := 
+Record retract_cond : Prop :=
   {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.
 
 
@@ -94,7 +94,7 @@ Proof.
 intros A B.
 destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf].
   exists f0 g0; trivial.
-  exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; 
+  exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros;
     destruct hf; auto.
 Qed.
 
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 3d434b37..b2c4a049 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ChoiceFacts.v 10756 2008-04-04 17:10:45Z herbelin $ i*)
+(*i $Id: ChoiceFacts.v 12363 2009-09-28 15:04:07Z letouzey $ i*)
 
 (** Some facts and definitions concerning choice and description in
        intuitionistic logic.
@@ -18,9 +19,11 @@ description principles
             (a "set-theoretic" axiom of choice)
 - AC_fun  = functional form of the (non extensional) axiom of choice
             (a "type-theoretic" axiom of choice)
+- DC_fun  = functional form of the dependent axiom of choice
+- ACw_fun = functional form of the countable axiom of choice
 - AC!     = functional relation reification
             (known as axiom of unique choice in topos theory,
-             sometimes called principle of definite description in 
+             sometimes called principle of definite description in
              the context of constructive type theory)
 
 - GAC_rel = guarded relational form of the (non extensional) axiom of choice
@@ -47,9 +50,9 @@ description principles
 
 We let also
 
-IPL_2   = 2nd-order impredicative minimal predicate logic (with ex. quant.)
-IPL^2   = 2nd-order functional minimal predicate logic (with ex. quant.)
-IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.)
+- IPL_2   = 2nd-order impredicative minimal predicate logic (with ex. quant.)
+- IPL^2   = 2nd-order functional minimal predicate logic (with ex. quant.)
+- IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.)
 
 with no prerequisite on the non-emptyness of domains
 
@@ -73,6 +76,8 @@ Table of contents
 
 7. Definite description transports classical logic to the computational world
 
+8. Choice -> Dependent choice -> Countable choice
+
 References:
 
 [[Bell]] John L. Bell, Choice principles in intuitionistic set theory,
@@ -81,7 +86,7 @@ unpublished.
 [[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic
 Type Theories, Mathematical Logic Quarterly, volume 39, 1993.
 
-[Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in
+[[Carlström05]] Jesper Carlström, Interpreting descriptions in
 intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
 *)
 
@@ -116,6 +121,20 @@ Definition FunctionalChoice_on :=
     (forall x : A, exists y : B, R x y) ->
     (exists f : A->B, forall x : A, R x (f x)).
 
+(** DC_fun *)
+
+Definition FunctionalDependentChoice_on :=
+  forall (R:A->A->Prop),
+    (forall x, exists y, R x y) -> forall x0,
+    (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))).
+
+(** ACw_fun *)
+
+Definition FunctionalCountableChoice_on :=
+  forall (R:nat->A->Prop),
+    (forall n, exists y, R n y) ->
+    (exists f : nat -> A, forall n, R n (f n)).
+
 (** AC! or Functional Relation Reification (known as Axiom of Unique Choice
     in topos theory; also called principle of definite description *)
 
@@ -126,7 +145,7 @@ Definition FunctionalRelReification_on :=
 
 (** ID_epsilon (constructive version of indefinite description;
     combined with proof-irrelevance, it may be connected to
-    Carlstrøm's type theory with a constructive indefinite description
+    Carlström's type theory with a constructive indefinite description
     operator) *)
 
 Definition ConstructiveIndefiniteDescription_on :=
@@ -134,7 +153,7 @@ Definition ConstructiveIndefiniteDescription_on :=
     (exists x, P x) -> { x:A | P x }.
 
 (** ID_iota (constructive version of definite description; combined
-    with proof-irrelevance, it may be connected to Carlstrøm's and
+    with proof-irrelevance, it may be connected to Carlström's and
     Stenlund's type theory with a constructive definite description
     operator) *)
 
@@ -146,16 +165,16 @@ Definition ConstructiveDefiniteDescription_on :=
 
 (** GAC_rel *)
 
-Definition GuardedRelationalChoice_on := 
+Definition GuardedRelationalChoice_on :=
   forall P : A->Prop, forall R : A->B->Prop,
     (forall x : A, P x -> exists y : B, R x y) ->
-    (exists R' : A->B->Prop, 
+    (exists R' : A->B->Prop,
       subrelation R' R /\ forall x, P x -> exists! y, R' x y).
 
 (** GAC_fun *)
 
-Definition GuardedFunctionalChoice_on := 
-  forall P : A->Prop, forall R : A->B->Prop, 
+Definition GuardedFunctionalChoice_on :=
+  forall P : A->Prop, forall R : A->B->Prop,
     inhabited B ->
     (forall x : A, P x -> exists y : B, R x y) ->
     (exists f : A->B, forall x, P x -> R x (f x)).
@@ -163,34 +182,34 @@ Definition GuardedFunctionalChoice_on :=
 (** GFR_fun *)
 
 Definition GuardedFunctionalRelReification_on :=
-  forall P : A->Prop, forall R : A->B->Prop, 
+  forall P : A->Prop, forall R : A->B->Prop,
     inhabited B ->
     (forall x : A, P x -> exists! y : B, R x y) ->
     (exists f : A->B, forall x : A, P x -> R x (f x)).
 
 (** OAC_rel *)
 
-Definition OmniscientRelationalChoice_on := 
+Definition OmniscientRelationalChoice_on :=
   forall R : A->B->Prop,
-    exists R' : A->B->Prop, 
+    exists R' : A->B->Prop,
       subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y.
 
 (** OAC_fun *)
 
-Definition OmniscientFunctionalChoice_on := 
-  forall R : A->B->Prop, 
+Definition OmniscientFunctionalChoice_on :=
+  forall R : A->B->Prop,
     inhabited B ->
     exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x).
 
 (** D_epsilon *)
 
-Definition EpsilonStatement_on := 
+Definition EpsilonStatement_on :=
   forall P:A->Prop,
     inhabited A -> { x:A | (exists x, P x) -> P x }.
 
 (** D_iota *)
 
-Definition IotaStatement_on := 
+Definition IotaStatement_on :=
   forall P:A->Prop,
     inhabited A -> { x:A | (exists! x, P x) -> P x }.
 
@@ -202,12 +221,16 @@ Notation RelationalChoice :=
   (forall A B, RelationalChoice_on A B).
 Notation FunctionalChoice :=
   (forall A B, FunctionalChoice_on A B).
+Definition FunctionalDependentChoice :=
+  (forall A, FunctionalDependentChoice_on A).
+Definition FunctionalCountableChoice :=
+  (forall A, FunctionalCountableChoice_on A).
 Notation FunctionalChoiceOnInhabitedSet :=
   (forall A B, inhabited B -> FunctionalChoice_on A B).
 Notation FunctionalRelReification :=
   (forall A B, FunctionalRelReification_on A B).
 
-Notation GuardedRelationalChoice := 
+Notation GuardedRelationalChoice :=
   (forall A B, GuardedRelationalChoice_on A B).
 Notation GuardedFunctionalChoice :=
   (forall A B, GuardedFunctionalChoice_on A B).
@@ -219,14 +242,14 @@ Notation OmniscientRelationalChoice :=
 Notation OmniscientFunctionalChoice :=
   (forall A B, OmniscientFunctionalChoice_on A B).
 
-Notation ConstructiveDefiniteDescription := 
+Notation ConstructiveDefiniteDescription :=
   (forall A, ConstructiveDefiniteDescription_on A).
-Notation ConstructiveIndefiniteDescription := 
+Notation ConstructiveIndefiniteDescription :=
   (forall A, ConstructiveIndefiniteDescription_on A).
 
-Notation IotaStatement := 
+Notation IotaStatement :=
   (forall A, IotaStatement_on A).
-Notation EpsilonStatement := 
+Notation EpsilonStatement :=
   (forall A, EpsilonStatement_on A).
 
 (** Subclassical schemes *)
@@ -235,7 +258,7 @@ Definition ProofIrrelevance :=
   forall (A:Prop) (a1 a2:A), a1 = a2.
 
 Definition IndependenceOfGeneralPremises :=
-  forall (A:Type) (P:A -> Prop) (Q:Prop), 
+  forall (A:Type) (P:A -> Prop) (Q:Prop),
     inhabited A ->
     (Q -> exists x, P x) -> exists x, Q -> P x.
 
@@ -270,7 +293,7 @@ Proof.
   apply HR'R; assumption.
 Qed.
 
-Lemma funct_choice_imp_rel_choice : 
+Lemma funct_choice_imp_rel_choice :
   forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B.
 Proof.
   intros A B FunCh R H.
@@ -283,7 +306,7 @@ Proof.
     trivial.
 Qed.
 
-Lemma funct_choice_imp_description : 
+Lemma funct_choice_imp_description :
   forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
 Proof.
   intros A B FunCh R H.
@@ -297,7 +320,7 @@ Proof.
 Qed.
 
 Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
-  forall A B, FunctionalChoice_on A B <-> 
+  forall A B, FunctionalChoice_on A B <->
     RelationalChoice_on A B /\ FunctionalRelReification_on A B.
 Proof.
   intros A B; split.
@@ -312,7 +335,7 @@ Qed.
 
 (** We show that the guarded formulations of the axiom of choice
    are equivalent to their "omniscient" variant and comes from the non guarded
-   formulation in presence either of the independance of general premises 
+   formulation in presence either of the independance of general premises
    or subset types (themselves derivable from subtypes thanks to proof-
    irrelevance) *)
 
@@ -341,12 +364,12 @@ Proof.
 Qed.
 
 Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice :
-  forall A B, inhabited B -> RelationalChoice_on A B -> 
+  forall A B, inhabited B -> RelationalChoice_on A B ->
     IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B.
 Proof.
   intros A B Inh AC_rel IndPrem P R H.
   destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)).
-  intro x. apply IndPrem. exact Inh. intro Hx. 
+  intro x. apply IndPrem. exact Inh. intro Hx.
   apply H; assumption.
   exists (fun x y => P x /\ R' x y).
   firstorder.
@@ -385,7 +408,7 @@ Qed.
 (** ** AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *)
 
 (** AC_fun + IGP = GAC_fun *)
- 
+
 Lemma guarded_fun_choice_imp_indep_of_general_premises :
   GuardedFunctionalChoice -> IndependenceOfGeneralPremises.
 Proof.
@@ -446,7 +469,7 @@ Proof.
 Qed.
 
 Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice :
-  FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox 
+  FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox
   -> OmniscientFunctionalChoice.
 Proof.
   intros AC_fun Drinker A B R Inh.
@@ -456,10 +479,10 @@ Proof.
 Qed.
 
 Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice :
-  FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox 
+  FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox
   <-> OmniscientFunctionalChoice.
 Proof.
-  auto decomp using 
+  auto decomp using
     omniscient_fun_choice_imp_small_drinker,
     omniscient_fun_choice_imp_fun_choice,
     fun_choice_and_small_drinker_imp_omniscient_fun_choice.
@@ -510,7 +533,7 @@ Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon :
   SmallDrinker'sParadox -> ConstructiveIndefiniteDescription ->
   EpsilonStatement.
 Proof.
-  intros Drinkers D_epsilon A P Inh; 
+  intros Drinkers D_epsilon A P Inh;
   apply D_epsilon; apply Drinkers; assumption.
 Qed.
 
@@ -542,7 +565,7 @@ Qed.
 
     We show instead that functional relation reification and the
     functional form of the axiom of choice are equivalent on decidable
-    relation with [nat] as codomain 
+    relation with [nat] as codomain
 *)
 
 Require Import Wf_nat.
@@ -552,10 +575,10 @@ Definition FunctionalChoice_on_rel (A B:Type) (R:A->B->Prop) :=
   (forall x:A, exists y : B, R x y) ->
   exists f : A -> B, (forall x:A, R x (f x)).
 
-Lemma classical_denumerable_description_imp_fun_choice : 
-  forall A:Type, 
-    FunctionalRelReification_on A nat -> 
-    forall R:A->nat->Prop, 
+Lemma classical_denumerable_description_imp_fun_choice :
+  forall A:Type,
+    FunctionalRelReification_on A nat ->
+    forall R:A->nat->Prop,
       (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R.
 Proof.
   intros A Descr.
@@ -563,7 +586,7 @@ Proof.
   set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y').
   destruct (Descr R') as (f,Hf).
   intro x.
-  apply (dec_inh_nat_subset_has_unique_least_element (R x)). 
+  apply (dec_inh_nat_subset_has_unique_least_element (R x)).
     apply Rdec.
     apply (H x).
     exists f.
@@ -582,12 +605,12 @@ Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) :=
     (forall x:A, exists y : B x, R x y) ->
     (exists f : (forall x:A, B x), forall x:A, R x (f x)).
 
-Notation DependentFunctionalChoice := 
+Notation DependentFunctionalChoice :=
   (forall A (B:A->Type), DependentFunctionalChoice_on B).
 
 (** The easy part *)
 
-Theorem dep_non_dep_functional_choice : 
+Theorem dep_non_dep_functional_choice :
   DependentFunctionalChoice -> FunctionalChoice.
 Proof.
   intros AC_depfun A B R H.
@@ -606,12 +629,12 @@ Scheme eq_indd := Induction for eq Sort Prop.
 Definition proj1_inf (A B:Prop) (p : A/\B) :=
   let (a,b) := p in a.
 
-Theorem non_dep_dep_functional_choice : 
+Theorem non_dep_dep_functional_choice :
   FunctionalChoice -> DependentFunctionalChoice.
 Proof.
   intros AC_fun A B R H.
-  pose (B' := { x:A & B x }). 
-  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). 
+  pose (B' := { x:A & B x }).
+  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
   destruct (AC_fun A B' R') as (f,Hf).
   intros x. destruct (H x) as (y,Hy).
   exists (existT (fun x => B x) x y). split; trivial.
@@ -633,7 +656,7 @@ Notation DependentFunctionalRelReification :=
 
 (** The easy part *)
 
-Theorem dep_non_dep_functional_rel_reification : 
+Theorem dep_non_dep_functional_rel_reification :
   DependentFunctionalRelReification -> FunctionalRelReification.
 Proof.
   intros DepFunReify A B R H.
@@ -646,12 +669,12 @@ Qed.
     conjunction projections and dependent elimination of conjunction
     and equality *)
 
-Theorem non_dep_dep_functional_rel_reification : 
+Theorem non_dep_dep_functional_rel_reification :
   FunctionalRelReification -> DependentFunctionalRelReification.
 Proof.
   intros AC_fun A B R H.
-  pose (B' := { x:A & B x }). 
-  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). 
+  pose (B' := { x:A & B x }).
+  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
   destruct (AC_fun A B' R') as (f,Hf).
   intros x. destruct (H x) as (y,(Hy,Huni)).
   exists (existT (fun x => B x) x y). repeat split; trivial.
@@ -665,7 +688,7 @@ Proof.
   destruct Heq using eq_indd; trivial.
 Qed.
 
-Corollary dep_iff_non_dep_functional_rel_reification : 
+Corollary dep_iff_non_dep_functional_rel_reification :
   FunctionalRelReification <-> DependentFunctionalRelReification.
 Proof.
   auto decomp using
@@ -764,7 +787,7 @@ be applied on the same Type universes on both sides of the first
     We adapt the proof to show that constructive definite description
     transports excluded-middle from [Prop] to [Set].
 
-    [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos
+    [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos
     Simpson, Mathematical Quotients and Quotient Types in Coq,
     Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
     Springer Verlag.  *)
@@ -786,14 +809,51 @@ Proof.
   intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction.
   left; trivial.
   right; trivial.
-Qed.  
+Qed.
 
 Corollary fun_reification_descr_computational_excluded_middle_in_prop_context :
   FunctionalRelReification ->
-  (forall P:Prop, P \/ ~ P) -> 
+  (forall P:Prop, P \/ ~ P) ->
   forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
 Proof.
   intros FunReify EM C; auto decomp using
     constructive_definite_descr_excluded_middle,
     (relative_non_contradiction_of_definite_descr (C:=C)).
 Qed.
+
+(**********************************************************************)
+(** * Choice => Dependent choice => Countable choice *)
+
+(* The implications below are standard *)
+
+Require Import Arith.
+
+Theorem functional_choice_imp_functional_dependent_choice :
+   FunctionalChoice -> FunctionalDependentChoice.
+Proof.
+  intros FunChoice A R HRfun x0.
+  apply FunChoice in HRfun as (g,Rg).
+  set (f:=fix f n := match n with 0 => x0 | S n' => g (f n') end).
+  exists f; firstorder.
+Qed.
+
+Theorem functional_dependent_choice_imp_functional_countable_choice :
+   FunctionalDependentChoice -> FunctionalCountableChoice.
+Proof.
+  intros H A R H0.
+  set (R' (p q:nat*A) := fst q = S (fst p) /\ R (fst p) (snd q)).
+  destruct (H0 0) as (y0,Hy0).
+  destruct H with (R:=R') (x0:=(0,y0)) as (f,(Hf0,HfS)).
+    intro x; destruct (H0 (fst x)) as (y,Hy).
+    exists (S (fst x),y).
+    red. auto.
+  assert (Heq:forall n, fst (f n) = n).
+    induction n.
+      rewrite Hf0; reflexivity.
+      specialize HfS with n; destruct HfS as (->,_); congruence.
+  exists (fun n => snd (f (S n))).
+  intro n'. specialize HfS with n'.
+  destruct HfS as (_,HR).
+  rewrite Heq in HR.
+  assumption.
+Qed.
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
index 523c9245..1c2b97ce 100644
--- a/theories/Logic/Classical.v
+++ b/theories/Logic/Classical.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 (** Classical Logic *)
 
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
index f9b59a6a..b0301994 100644
--- a/theories/Logic/ClassicalChoice.v
+++ b/theories/Logic/ClassicalChoice.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalChoice.v 10170 2007-10-03 14:41:25Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides classical logic and functional choice; this
     especially provides both indefinite descriptions and choice functions
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
index 31c41120..2b9df6d9 100644
--- a/theories/Logic/ClassicalDescription.v
+++ b/theories/Logic/ClassicalDescription.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalDescription.v 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides classical logic and definite description, which is
     equivalent to providing classical logic and Church's iota operator *)
@@ -30,12 +30,12 @@ Axiom constructive_definite_description :
 
 Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
 Proof.
-apply 
-  (constructive_definite_descr_excluded_middle 
+apply
+  (constructive_definite_descr_excluded_middle
    constructive_definite_description classic).
 Qed.
 
-Theorem classical_definite_description : 
+Theorem classical_definite_description :
   forall (A : Type) (P : A->Prop), inhabited A ->
   { x : A | (exists! x : A, P x) -> P x }.
 Proof.
@@ -54,7 +54,7 @@ Qed.
 Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
   := proj1_sig (classical_definite_description P i).
 
-Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) :
   (exists! x:A, P x) -> P (iota i P)
   := proj2_sig (classical_definite_description P i).
 
diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
index 2a4de511..cee55dc8 100644
--- a/theories/Logic/ClassicalEpsilon.v
+++ b/theories/Logic/ClassicalEpsilon.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalEpsilon.v 10170 2007-10-03 14:41:25Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides classical logic and indefinite description under
     the form of Hilbert's epsilon operator *)
@@ -22,11 +23,11 @@ Require Import ChoiceFacts.
 Set Implicit Arguments.
 
 Axiom constructive_indefinite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists x, P x) -> { x : A | P x }.
 
 Lemma constructive_definite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists! x, P x) -> { x : A | P x }.
 Proof.
   intros; apply constructive_indefinite_description; firstorder.
@@ -34,18 +35,18 @@ Qed.
 
 Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
 Proof.
-  apply 
-    (constructive_definite_descr_excluded_middle 
+  apply
+    (constructive_definite_descr_excluded_middle
       constructive_definite_description classic).
 Qed.
 
-Theorem classical_indefinite_description : 
+Theorem classical_indefinite_description :
   forall (A : Type) (P : A->Prop), inhabited A ->
     { x : A | (exists x, P x) -> P x }.
 Proof.
   intros A P i.
   destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP].
-  apply constructive_indefinite_description 
+  apply constructive_indefinite_description
     with (P:= fun x => (exists x, P x) -> P x).
   destruct Hex as (x,Hx).
     exists x; intros _; exact Hx.
@@ -60,7 +61,7 @@ Defined.
 Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
   := proj1_sig (classical_indefinite_description P i).
 
-Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
   (exists x, P x) -> P (epsilon i P)
   := proj2_sig (classical_indefinite_description P i).
 
@@ -74,9 +75,9 @@ Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
 
 (** A proof that if [P] is inhabited, [epsilon a P] does not depend on
     the actual proof that the domain of [P] is inhabited
-    (proof idea kindly provided by Pierre Castéran) *)
+    (proof idea kindly provided by Pierre Castéran) *)
 
-Lemma epsilon_inh_irrelevance : 
+Lemma epsilon_inh_irrelevance :
    forall (A:Type) (i j : inhabited A) (P:A->Prop),
    (exists x, P x) -> epsilon i P = epsilon j P.
 Proof.
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index db92696b..b22a3a87 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalFacts.v 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Some facts and definitions about classical logic
 
@@ -31,7 +31,7 @@ Table of contents:
 
 3.1. Weak excluded middle
 
-3.2. Gödel-Dummett axiom and right distributivity of implication over
+3.2. Gödel-Dummett axiom and right distributivity of implication over
      disjunction
 
 3 3. Independence of general premises and drinker's paradox
@@ -111,7 +111,7 @@ Qed.
 (** We successively show that:
 
    [prop_extensionality]
-     implies equality of [A] and [A->A] for inhabited [A], which 
+     implies equality of [A] and [A->A] for inhabited [A], which
      implies the existence of a (trivial) retract from [A->A] to [A]
         (just take the identity), which
      implies the existence of a fixpoint operator in [A]
@@ -128,7 +128,7 @@ Proof.
   apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ].
 Qed.
 
-Record retract (A B:Prop) : Prop := 
+Record retract (A B:Prop) : Prop :=
   {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}.
 
 Lemma prop_ext_retract_A_A_imp_A :
@@ -140,7 +140,7 @@ Proof.
   reflexivity.
 Qed.
 
-Record has_fixpoint (A:Prop) : Prop := 
+Record has_fixpoint (A:Prop) : Prop :=
   {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}.
 
 Lemma ext_prop_fixpoint :
@@ -224,7 +224,7 @@ End Proof_irrelevance_gen.
 *)
 
 Section Proof_irrelevance_Prop_Ext_CC.
-  
+
   Definition BoolP := forall C:Prop, C -> C -> C.
   Definition TrueP : BoolP := fun C c1 c2 => c1.
   Definition FalseP : BoolP := fun C c1 c2 => c2.
@@ -233,10 +233,10 @@ Section Proof_irrelevance_Prop_Ext_CC.
     c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1.
   Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
     c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2.
-  
+
   Definition BoolP_dep_induction :=
     forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.
-  
+
   Lemma ext_prop_dep_proof_irrel_cc :
     prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
   Proof.
@@ -248,7 +248,7 @@ End Proof_irrelevance_Prop_Ext_CC.
 
 (** Remark: [prop_extensionality] can be replaced in lemma
     [ext_prop_dep_proof_irrel_gen] by the weakest property
-    [provable_prop_extensionality].  
+    [provable_prop_extensionality].
 *)
 
 (************************************************************************)
@@ -260,7 +260,7 @@ End Proof_irrelevance_Prop_Ext_CC.
 *)
 
 Section Proof_irrelevance_CIC.
-  
+
   Inductive boolP : Prop :=
     | trueP : boolP
     | falseP : boolP.
@@ -269,7 +269,7 @@ Section Proof_irrelevance_CIC.
   Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
     c2 = boolP_ind C c1 c2 falseP := refl_equal c2.
   Scheme boolP_indd := Induction for boolP Sort Prop.
-  
+
   Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
   Proof.
     exact (fun pe =>
@@ -290,7 +290,7 @@ End Proof_irrelevance_CIC.
   cannot be refined.
 
   [[Berardi90]] Stefano Berardi, "Type dependence and constructive
-  mathematics", Ph. D. thesis, Dipartimento Matematica, Università di
+  mathematics", Ph. D. thesis, Dipartimento Matematica, Università di
   Torino, 1990.
 *)
 
@@ -316,7 +316,7 @@ End Proof_irrelevance_CIC.
 Require Import Hurkens.
 
 Section Proof_irrelevance_EM_CC.
-  
+
   Variable or : Prop -> Prop -> Prop.
   Variable or_introl : forall A B:Prop, A -> or A B.
   Variable or_intror : forall A B:Prop, B -> or A B.
@@ -334,11 +334,11 @@ Section Proof_irrelevance_EM_CC.
     forall (A B:Prop) (P:or A B -> Prop),
       (forall a:A, P (or_introl A B a)) ->
       (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.
-  
+
   Hypothesis em : forall A:Prop, or A (~ A).
   Variable B : Prop.
   Variables b1 b2 : B.
-  
+
   (** [p2b] and [b2p] form a retract if [~b1=b2] *)
 
   Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
@@ -392,13 +392,13 @@ End Proof_irrelevance_EM_CC.
 Section Proof_irrelevance_CCI.
 
   Hypothesis em : forall A:Prop, A \/ ~ A.
-  
-  Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) 
+
+  Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C)
     (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a).
-  Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) 
+  Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C)
     (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b).
   Scheme or_indd := Induction for or Sort Prop.
-  
+
   Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
   Proof.
     exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
@@ -417,7 +417,7 @@ End Proof_irrelevance_CCI.
 
 (** We show the following increasing in the strength of axioms:
  - weak excluded-middle
- - right distributivity of implication over disjunction and Gödel-Dummett axiom
+ - right distributivity of implication over disjunction and Gödel-Dummett axiom
  - independence of general premises and drinker's paradox
  - excluded-middle
 *)
@@ -436,20 +436,20 @@ Definition weak_excluded_middle :=
 
 (** The interest in the equivalent variant
     [weak_generalized_excluded_middle] is that it holds even in logic
-    without a primitive [False] connective (like Gödel-Dummett axiom) *)
+    without a primitive [False] connective (like Gödel-Dummett axiom) *)
 
-Definition weak_generalized_excluded_middle := 
+Definition weak_generalized_excluded_middle :=
   forall A B:Prop, ((A -> B) -> B) \/ (A -> B).
 
-(** ** Gödel-Dummett axiom *)
+(** ** Gödel-Dummett axiom *)
 
-(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]].
+(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]].
 
     [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus
     with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol
     24 No. 2(1959), pp 97-103.
 
-    [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül",
+    [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül",
     Ergeb. Math. Koll. 4 (1933), pp. 34-38.
  *)
 
@@ -473,7 +473,7 @@ Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction :
 Proof.
   split.
     intros GD A B C HCAB.
-    destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; 
+    destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC;
       destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption.
     intros Distr A B.
     destruct (Distr A B (A\/B)) as [HABA|HABB].
@@ -484,7 +484,7 @@ Qed.
 
 (** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *)
 
-Lemma Godel_Dummett_weak_excluded_middle : 
+Lemma Godel_Dummett_weak_excluded_middle :
   GodelDummett -> weak_excluded_middle.
 Proof.
   intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA].
@@ -500,13 +500,13 @@ Qed.
 
     It is a generalization to predicate logic of the right
     distributivity of implication over disjunction (hence of
-    Gödel-Dummett axiom) whose own constructive form (obtained by a
+    Gödel-Dummett axiom) whose own constructive form (obtained by a
     restricting the third formula to be negative) is called
     Kreisel-Putnam principle [[KreiselPutnam57]].
 
     [[KreiselPutnam57]], Georg Kreisel and Hilary Putnam. "Eine
-    Unableitsbarkeitsbeweismethode für den intuitionistischen
-    Aussagenkalkül". Archiv für Mathematische Logik und
+    Unableitsbarkeitsbeweismethode für den intuitionistischen
+    Aussagenkalkül". Archiv für Mathematische Logik und
     Graundlagenforschung, 3:74- 78, 1957.
 
     [[Troelstra73]], Anne Troelstra, editor. Metamathematical
@@ -539,10 +539,10 @@ Qed.
 (** Independence of general premises is equivalent to the drinker's paradox *)
 
 Definition DrinkerParadox :=
-  forall (A:Type) (P:A -> Prop), 
+  forall (A:Type) (P:A -> Prop),
     inhabited A -> exists x, (exists x, P x) -> P x.
 
-Lemma independence_general_premises_drinker : 
+Lemma independence_general_premises_drinker :
   IndependenceOfGeneralPremises <-> DrinkerParadox.
 Proof.
   split.
@@ -551,14 +551,14 @@ Proof.
       exists x; intro HQ; apply (Hx (H HQ)).
 Qed.
 
-(** Independence of general premises is weaker than (generalized) 
+(** Independence of general premises is weaker than (generalized)
     excluded middle
 
 Remark: generalized excluded middle is preferred here to avoid relying on
 the "ex falso quodlibet" property (i.e. [False -> forall A, A])
 *)
 
-Definition generalized_excluded_middle := 
+Definition generalized_excluded_middle :=
   forall A B:Prop, A \/ (A -> B).
 
 Lemma excluded_middle_independence_general_premises :
@@ -569,4 +569,4 @@ Proof.
     exists x; intro; exact Hx.
     exists x0; exact Hnot.
 Qed.
- 
+
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
index bb846aa6..f99d65eb 100644
--- a/theories/Logic/ClassicalUniqueChoice.v
+++ b/theories/Logic/ClassicalUniqueChoice.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalUniqueChoice.v 10170 2007-10-03 14:41:25Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides classical logic and unique choice; this is
     weaker than providing iota operator and classical logic as the
@@ -15,11 +16,11 @@
     be used to build functions outside the scope of a theorem proof) *)
 
 (** Classical logic and unique choice, as shown in
-    [ChicliPottierSimpson02], implies the double-negation of
+    [[ChicliPottierSimpson02]], implies the double-negation of
     excluded-middle in [Set], hence it implies a strongly classical
     world. Especially it conflicts with the impredicativity of [Set].
 
-    [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
+    [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos
     Simpson, Mathematical Quotients and Quotient Types in Coq,
     Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
     Springer Verlag.  *)
@@ -43,13 +44,14 @@ intros A B.
 apply (dependent_unique_choice A (fun _ => B)).
 Qed.
 
-(** The following proof comes from [ChicliPottierSimpson02] *)
+(** The following proof comes from [[ChicliPottierSimpson02]] *)
 
 Require Import Setoid.
 
-Theorem classic_set : ((forall P:Prop, {P} + {~ P}) -> False) -> False.
+Theorem classic_set_in_prop_context :
+  forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
 Proof.
-intro HnotEM.
+intros C HnotEM.
 set (R := fun A b => A /\ true = b \/ ~ A /\ false = b).
 assert (H :  exists f : Prop -> bool, (forall A:Prop, R A (f A))).
 apply unique_choice.
@@ -80,4 +82,12 @@ destruct (f P).
     discriminate.
     assumption.
 Qed.
- 
+
+Corollary not_not_classic_set :
+  ((forall P:Prop, {P} + {~ P}) -> False) -> False.
+Proof.
+apply classic_set_in_prop_context.
+Qed.
+
+(* Compatibility *)
+Notation classic_set := not_not_classic_set (only parsing).
diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
index 2a5f03ec..0b0c329b 100644
--- a/theories/Logic/Classical_Pred_Set.v
+++ b/theories/Logic/Classical_Pred_Set.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Pred_Set.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 (** This file is obsolete, use Classical_Pred_Type.v via Classical.v
 instead *)
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
index 56ebf967..b30308af 100644
--- a/theories/Logic/Classical_Pred_Type.v
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Pred_Type.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 (** Classical Predicate Logic on Type *)
 
@@ -44,7 +44,7 @@ Proof. (* Intuitionistic *)
 unfold not in |- *; intros P notex n abs.
 apply notex.
 exists n; trivial.
-Qed. 
+Qed.
 
 Lemma not_ex_not_all :
  forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index ce3e84a7..df732959 100644
--- a/theories/Logic/Classical_Prop.v
+++ b/theories/Logic/Classical_Prop.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Prop.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Classical Propositional Logic *)
 
@@ -22,7 +22,7 @@ unfold not in |- *; intros; elim (classic p); auto.
 intro NP; elim (H NP).
 Qed.
 
-(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. 
+(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P].
     Thanks to [forall P, False -> P], it is equivalent to the
     following form *)
 
@@ -95,11 +95,11 @@ Proof proof_irrelevance_cci classic.
 (* classical_left  transforms |- A \/ B into ~B |- A *)
 (* classical_right transforms |- A \/ B into ~A |- B *)
 
-Ltac classical_right :=  match goal with 
+Ltac classical_right :=  match goal with
  | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right])
 end.
 
-Ltac classical_left := match goal with 
+Ltac classical_left := match goal with
 | _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left])
 end.
 
@@ -107,7 +107,7 @@ Require Export EqdepFacts.
 
 Module Eq_rect_eq.
 
-Lemma eq_rect_eq : 
+Lemma eq_rect_eq :
   forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
 Proof.
 intros; rewrite proof_irrelevance with (p1:=h) (p2:=refl_equal p); reflexivity.
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
index 9b1f4e19..3b91afd0 100644
--- a/theories/Logic/Classical_Type.v
+++ b/theories/Logic/Classical_Type.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Type.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 (** This file is obsolete, use Classical.v instead *)
 
diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v
index ff70c9fb..6d22b1a9 100644
--- a/theories/Logic/ConstructiveEpsilon.v
+++ b/theories/Logic/ConstructiveEpsilon.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ConstructiveEpsilon.v 12112 2009-04-28 15:47:34Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This module proves the constructive description schema, which
 infers the sigma-existence (i.e., [Set]-existence) of a witness to a
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
index 00d63252..c6d32d9b 100644
--- a/theories/Logic/Decidable.v
+++ b/theories/Logic/Decidable.v
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Decidable.v 11735 2009-01-02 17:22:31Z herbelin $	 i*)
+(*i 	$Id$	 i*)
 
 (** Properties of decidable propositions *)
 
@@ -13,7 +13,7 @@ Definition decidable (P:Prop) := P \/ ~ P.
 
 Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P.
 Proof.
-unfold decidable; tauto. 
+unfold decidable; tauto.
 Qed.
 
 Theorem dec_True : decidable True.
@@ -29,27 +29,27 @@ Qed.
 Theorem dec_or :
  forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B).
 Proof.
-unfold decidable; tauto. 
+unfold decidable; tauto.
 Qed.
 
 Theorem dec_and :
  forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B).
 Proof.
-unfold decidable; tauto. 
+unfold decidable; tauto.
 Qed.
 
 Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A).
 Proof.
-unfold decidable; tauto. 
+unfold decidable; tauto.
 Qed.
 
 Theorem dec_imp :
  forall A B:Prop, decidable A -> decidable B -> decidable (A -> B).
 Proof.
-unfold decidable; tauto. 
+unfold decidable; tauto.
 Qed.
 
-Theorem dec_iff : 
+Theorem dec_iff :
  forall A B:Prop, decidable A -> decidable B -> decidable (A<->B).
 Proof.
 unfold decidable; tauto.
@@ -67,7 +67,7 @@ Qed.
 
 Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B.
 Proof.
-unfold decidable; tauto. 
+unfold decidable; tauto.
 Qed.
 
 Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B.
@@ -80,16 +80,16 @@ Proof.
 unfold decidable; tauto.
 Qed.
 
-Theorem not_iff : 
-  forall A B:Prop, decidable A -> decidable B -> 
+Theorem not_iff :
+  forall A B:Prop, decidable A -> decidable B ->
     ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B).
 Proof.
 unfold decidable; tauto.
 Qed.
 
-(** Results formulated with iff, used in FSetDecide. 
-    Negation are expanded since it is unclear whether setoid rewrite 
-    will always perform conversion. *)    
+(** Results formulated with iff, used in FSetDecide.
+    Negation are expanded since it is unclear whether setoid rewrite
+    will always perform conversion. *)
 
 (** We begin with lemmas that, when read from left to right,
     can be understood as ways to eliminate uses of [not]. *)
diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v
index 962f2a2a..a8a56ae7 100644
--- a/theories/Logic/Description.v
+++ b/theories/Logic/Description.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Description.v 10170 2007-10-03 14:41:25Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides a constructive form of definite description; it
     allows to build functions from the proof of their existence in any
@@ -17,5 +17,5 @@ Require Import ChoiceFacts.
 Set Implicit Arguments.
 
 Axiom constructive_definite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists! x, P x) -> { x : A | P x }.
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index b935a676..18f3181b 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Diaconescu.v 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
    in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
@@ -59,7 +59,7 @@ Definition PredicateExtensionality :=
 Require Import ClassicalFacts.
 
 Variable pred_extensionality : PredicateExtensionality.
-  
+
 Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
 Proof.
   intros A B H.
@@ -99,11 +99,11 @@ Lemma AC_bool_subset_to_bool :
       (exists b : bool, P b) ->
        exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
 Proof.
-  destruct (guarded_rel_choice _ _ 
+  destruct (guarded_rel_choice _ _
    (fun Q:bool -> Prop =>  exists y : _, Q y)
    (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
     exact (fun _ H => H).
-  exists R; intros P HP. 
+  exists R; intros P HP.
   destruct (HR P HP) as (y,(Hy,Huni)).
   exists y; firstorder.
 Qed.
@@ -190,7 +190,7 @@ Lemma projT1_injective : a1=a2 -> a1'=a2'.
 Proof.
   intro Heq ; unfold a1', a2', A'.
   rewrite Heq.
-  replace (or_introl (a2=a2) (refl_equal a2)) 
+  replace (or_introl (a2=a2) (refl_equal a2))
      with (or_intror (a2=a2) (refl_equal a2)).
   reflexivity.
   apply proof_irrelevance.
@@ -210,10 +210,10 @@ Qed.
 
 Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
 Proof.
-  destruct 
-    (rel_choice A' bool 
+  destruct
+    (rel_choice A' bool
        (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
-    as (R,(HRsub,HR)). 
+    as (R,(HRsub,HR)).
     apply decide.
   destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
   destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
@@ -235,18 +235,18 @@ Declare Implicit Tactic auto.
 
 Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
 Proof.
-  assert (decide: forall x:A, x=a1 \/ x=a2 -> 
+  assert (decide: forall x:A, x=a1 \/ x=a2 ->
                 exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
     intros a [Ha1|Ha2]; [exists true | exists false]; auto.
-  assert (guarded_rel_choice := 
-          rel_choice_and_proof_irrel_imp_guarded_rel_choice 
-	  rel_choice 
+  assert (guarded_rel_choice :=
+          rel_choice_and_proof_irrel_imp_guarded_rel_choice
+	  rel_choice
 	  proof_irrelevance).
-  destruct 
-    (guarded_rel_choice A bool 
+  destruct
+    (guarded_rel_choice A bool
       (fun x => x=a1 \/ x=a2)
       (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
-      as (R,(HRsub,HR)). 
+      as (R,(HRsub,HR)).
       apply decide.
   destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
   destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
@@ -273,8 +273,8 @@ Section ExtensionalEpsilon_imp_EM.
 
 Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.
 
-Hypothesis epsilon_spec : 
-  forall (A:Type) (i:inhabited A) (P:A->Prop), 
+Hypothesis epsilon_spec :
+  forall (A:Type) (i:inhabited A) (P:A->Prop),
   (exists x, P x) -> P (epsilon A i P).
 
 Hypothesis epsilon_extensionality :
@@ -288,9 +288,9 @@ Proof.
   intro P.
   pose (B := fun y => y=false \/ P).
   pose (C := fun y => y=true  \/ P).
-  assert (B (eps B)) as [Hfalse|HP] 
+  assert (B (eps B)) as [Hfalse|HP]
     by (apply epsilon_spec; exists false; left; reflexivity).
-  assert (C (eps C)) as [Htrue|HP] 
+  assert (C (eps C)) as [Htrue|HP]
     by (apply epsilon_spec; exists true; left; reflexivity).
     right; intro HP.
     assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v
index 65d4d853..d433be94 100644
--- a/theories/Logic/Epsilon.v
+++ b/theories/Logic/Epsilon.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Epsilon.v 10170 2007-10-03 14:41:25Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides indefinite description under the form of
     Hilbert's epsilon operator; it does not assume classical logic. *)
@@ -17,12 +17,12 @@ Set Implicit Arguments.
 
 (** Hilbert's epsilon: operator and specification in one statement *)
 
-Axiom epsilon_statement : 
+Axiom epsilon_statement :
   forall (A : Type) (P : A->Prop), inhabited A ->
     { x : A | (exists x, P x) -> P x }.
 
 Lemma constructive_indefinite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists x, P x) -> { x : A | P x }.
 Proof.
   apply epsilon_imp_constructive_indefinite_description.
@@ -45,7 +45,7 @@ Proof.
 Qed.
 
 Lemma constructive_definite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists! x, P x) -> { x : A | P x }.
 Proof.
   apply iota_imp_constructive_definite_description.
@@ -57,7 +57,7 @@ Qed.
 Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
   := proj1_sig (epsilon_statement P i).
 
-Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
   (exists x, P x) -> P (epsilon i P)
   := proj2_sig (epsilon_statement P i).
 
@@ -66,7 +66,7 @@ Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
 Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
   := proj1_sig (iota_statement P i).
 
-Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) :
   (exists! x:A, P x) -> P (iota i P)
   := proj2_sig (iota_statement P i).
 
diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
index 2fe9d1a6..5c6b4e89 100644
--- a/theories/Logic/Eqdep.v
+++ b/theories/Logic/Eqdep.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Eqdep.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 (** This file axiomatizes the invariance by substitution of reflexive
     equality proofs [[Streicher93]] and exports its consequences, such
diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v
index d5738c82..4689fb46 100644
--- a/theories/Logic/EqdepFacts.v
+++ b/theories/Logic/EqdepFacts.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: EqdepFacts.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file defines dependent equality and shows its equivalence with
     equality on dependent pairs (inhabiting sigma-types). It derives
@@ -25,7 +26,7 @@
   References:
 
   [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
-      Habilitationsschrift, LMU München, 1993.
+      Habilitationsschrift, LMU München, 1993.
   [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
       Proceedings of the meeting Twenty-five years of constructive
       type theory, Venice, Oxford University Press, 1998
@@ -45,7 +46,7 @@ Table of contents:
 (** * Definition of dependent equality and equivalence with equality of dependent pairs *)
 
 Section Dependent_Equality.
-  
+
   Variable U : Type.
   Variable P : U -> Type.
 
@@ -119,7 +120,7 @@ Lemma equiv_eqex_eqdep :
   forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y <-> eq_dep p x q y.
 Proof.
-  split. 
+  split.
   (* -> *)
   apply eq_sigT_eq_dep.
   (* <- *)
@@ -142,27 +143,27 @@ Hint Immediate eq_dep_sym: core.
 (** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K          *)
 
 Section Equivalences.
-  
+
   Variable U:Type.
-  
+
   (** Invariance by Substitution of Reflexive Equality Proofs *)
-  
-  Definition Eq_rect_eq := 
+
+  Definition Eq_rect_eq :=
     forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
-  
+
   (** Injectivity of Dependent Equality *)
-  
-  Definition Eq_dep_eq := 
+
+  Definition Eq_dep_eq :=
     forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
-  
+
   (** Uniqueness of Identity Proofs (UIP) *)
-  
-  Definition UIP_ := 
+
+  Definition UIP_ :=
     forall (x y:U) (p1 p2:x = y), p1 = p2.
-  
+
   (** Uniqueness of Reflexive Identity Proofs *)
 
-  Definition UIP_refl_ := 
+  Definition UIP_refl_ :=
     forall (x:U) (p:x = x), p = refl_equal x.
 
   (** Streicher's axiom K *)
@@ -198,7 +199,7 @@ Section Equivalences.
     elim p1 using eq_indd.
     apply eq_dep_intro.
   Qed.
-  
+
   (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
 
   Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
@@ -216,7 +217,7 @@ Section Equivalences.
 
   (** We finally recover from K the Invariance by Substitution of
       Reflexive Equality Proofs *)
-  
+
   Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
   Proof.
     intro Streicher_K; red; intros.
@@ -233,20 +234,20 @@ Section Equivalences.
     Typically, [eq_rect_eq] allows to prove UIP and Streicher's K what
     does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP]
     requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not
-    in [Set].  
+    in [Set].
 *)
 
 End Equivalences.
 
 Section Corollaries.
-  
+
   Variable U:Type.
-  
+
   (** UIP implies the injectivity of equality on dependent pairs in Type *)
- 
+
  Definition Inj_dep_pair :=
    forall (P:U -> Type) (p:U) (x y:P p), existT P p x = existT P p y -> x = y.
- 
+
  Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
  Proof.
    intro eq_dep_eq; red; intros.
@@ -260,7 +261,7 @@ End Corollaries.
 Notation Inj_dep_pairS := Inj_dep_pair.
 Notation Inj_dep_pairT := Inj_dep_pair.
 Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2.
- 
+
 
 (************************************************************************)
 (** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *)
@@ -274,11 +275,11 @@ Module Type EqdepElimination.
 End EqdepElimination.
 
 Module EqdepTheory (M:EqdepElimination).
-  
+
   Section Axioms.
-    
+
     Variable U:Type.
-    
+
 (** Invariance by Substitution of Reflexive Equality Proofs *)
 
 Lemma eq_rect_eq :
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
index 0281916e..fc1c4a97 100644
--- a/theories/Logic/Eqdep_dec.v
+++ b/theories/Logic/Eqdep_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Eqdep_dec.v 10144 2007-09-26 15:12:17Z vsiles $ i*)
+(*i $Id$ i*)
 
 (** We prove that there is only one proof of [x=x], i.e [refl_equal x].
     This holds if the equality upon the set of [x] is decidable.
@@ -38,7 +38,7 @@ Set Implicit Arguments.
 Section EqdepDec.
 
   Variable A : Type.
-  
+
   Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
     eq_ind _ (fun a => a = y') eq2 _ eq1.
 
@@ -49,7 +49,7 @@ Section EqdepDec.
   Qed.
 
   Variable eq_dec : forall x y:A, x = y \/ x <> y.
-  
+
   Variable x : A.
 
   Let nu (y:A) (u:x = y) : x = y :=
@@ -63,13 +63,13 @@ Section EqdepDec.
     unfold nu in |- *.
     case (eq_dec x y); intros.
     reflexivity.
-  
+
     case n; trivial.
   Qed.
 
 
   Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.
-  
+
 
   Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
   Proof.
@@ -88,7 +88,7 @@ Section EqdepDec.
     reflexivity.
   Qed.
 
-  Theorem K_dec : 
+  Theorem K_dec :
     forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p.
   Proof.
     intros.
@@ -118,10 +118,10 @@ Section EqdepDec.
     case (eq_dec x x).
     intro e.
     elim e using K_dec; trivial.
-    
+
     intros.
     case n; trivial.
-    
+
     case H.
     reflexivity.
   Qed.
@@ -165,6 +165,12 @@ Theorem eq_dep_eq_dec :
      forall (P:A->Type) (p:A) (x y:P p), eq_dep A P p x p y -> x = y.
 Proof (fun A eq_dec => eq_rect_eq__eq_dep_eq A (eq_rect_eq_dec eq_dec)).
 
+Theorem UIP_dec :
+  forall (A:Type),
+    (forall x y:A, {x = y} + {x <> y}) ->
+    forall (x y:A) (p1 p2:x = y), p1 = p2.
+Proof (fun A eq_dec => eq_dep_eq__UIP A (eq_dep_eq_dec eq_dec)).
+
 Unset Implicit Arguments.
 
 (************************************************************************)
@@ -173,13 +179,13 @@ Unset Implicit Arguments.
 (** The signature of decidable sets in [Type] *)
 
 Module Type DecidableType.
-  
+
   Parameter U:Type.
   Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.
 
 End DecidableType.
 
-(** The module [DecidableEqDep] collects equality properties for decidable 
+(** The module [DecidableEqDep] collects equality properties for decidable
     set in [Type] *)
 
 Module DecidableEqDep (M:DecidableType).
@@ -247,7 +253,7 @@ Module Type DecidableSet.
 
 End DecidableSet.
 
-(** The module [DecidableEqDepSet] collects equality properties for decidable 
+(** The module [DecidableEqDepSet] collects equality properties for decidable
     set in [Set] *)
 
 Module DecidableEqDepSet (M:DecidableSet).
@@ -307,11 +313,11 @@ End DecidableEqDepSet.
   (** From decidability to inj_pair2 **)
 Lemma inj_pair2_eq_dec : forall A:Type, (forall x y:A, {x=y}+{x<>y}) ->
    ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ).
-Proof. 
+Proof.
   intros A eq_dec.
   apply eq_dep_eq__inj_pair2.
   apply eq_rect_eq__eq_dep_eq.
-  unfold Eq_rect_eq. 
+  unfold Eq_rect_eq.
   apply eq_rect_eq_dec.
   apply eq_dec.
 Qed.
diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v
index 0dc82907..1678a287 100644
--- a/theories/Logic/FunctionalExtensionality.v
+++ b/theories/Logic/FunctionalExtensionality.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: FunctionalExtensionality.v 11686 2008-12-16 12:57:26Z msozeau $ i*)
+(*i $Id$ i*)
 
 (** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion.
    It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *)
 
 (** The converse of functional extensionality. *)
 
-Lemma equal_f : forall {A B : Type} {f g : A -> B}, 
+Lemma equal_f : forall {A B : Type} {f g : A -> B},
   f = g -> forall x, f x = g x.
 Proof.
   intros.
@@ -23,11 +23,11 @@ Qed.
 
 (** Statements of functional extensionality for simple and dependent functions. *)
 
-Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, 
-  forall (f g : forall x : A, B x), 
+Axiom functional_extensionality_dep : forall {A} {B : A -> Type},
+  forall (f g : forall x : A, B x),
   (forall x, f x = g x) -> f = g.
 
-Lemma functional_extensionality {A B} (f g : A -> B) : 
+Lemma functional_extensionality {A B} (f g : A -> B) :
   (forall x, f x = g x) -> f = g.
 Proof.
   intros ; eauto using @functional_extensionality_dep.
@@ -37,8 +37,8 @@ Qed.
 
 Tactic Notation "extensionality" ident(x) :=
   match goal with
-    [ |- ?X = ?Y ] => 
-    (apply (@functional_extensionality _ _ X Y) || 
+    [ |- ?X = ?Y ] =>
+    (apply (@functional_extensionality _ _ X Y) ||
      apply (@functional_extensionality_dep _ _ X Y)) ; intro x
   end.
 
@@ -51,8 +51,8 @@ Proof.
   extensionality x.
   reflexivity.
 Qed.
-  
+
 Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x.
 Proof.
-  intros A B f. apply (eta_expansion_dep f).
+  apply (eta_expansion_dep f).
 Qed.
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
index 46a57432..71c9af50 100644
--- a/theories/Logic/Hurkens.v
+++ b/theories/Logic/Hurkens.v
@@ -19,7 +19,7 @@
       and Applications (TLCA'95), 1995.
 
     - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001
-      (see www.cs.kun.nl/~herman/note.ps.gz).
+      (see http://www.cs.kun.nl/~herman/note.ps.gz).
 *)
 
 Section Paradox.
diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v
index 740b889a..3651c1b2 100644
--- a/theories/Logic/IndefiniteDescription.v
+++ b/theories/Logic/IndefiniteDescription.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: IndefiniteDescription.v 10170 2007-10-03 14:41:25Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file provides a constructive form of indefinite description that
     allows to build choice functions; this is weaker than Hilbert's
@@ -19,11 +19,11 @@ Require Import ChoiceFacts.
 Set Implicit Arguments.
 
 Axiom constructive_indefinite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists x, P x) -> { x : A | P x }.
 
 Lemma constructive_definite_description :
-  forall (A : Type) (P : A->Prop), 
+  forall (A : Type) (P : A->Prop),
     (exists! x, P x) -> { x : A | P x }.
 Proof.
   intros; apply constructive_indefinite_description; firstorder.
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
index c3573ac3..fc4555a4 100644
--- a/theories/Logic/JMeq.v
+++ b/theories/Logic/JMeq.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: JMeq.v 9849 2007-05-22 20:40:04Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** John Major's Equality as proposed by Conor McBride
 
@@ -28,44 +28,61 @@ Set Elimination Schemes.
 
 Hint Resolve JMeq_refl.
 
-Lemma sym_JMeq : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x.
+Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x.
+Proof.
 destruct 1; trivial.
 Qed.
 
-Hint Immediate sym_JMeq.
+Hint Immediate JMeq_sym.
 
-Lemma trans_JMeq :
+Lemma JMeq_trans :
  forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z.
-destruct 1; trivial.
+Proof.
+destruct 2; trivial.
 Qed.
 
 Axiom JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y.
 
-Lemma JMeq_ind : forall (A:Type) (x y:A) (P:A -> Prop), P x -> JMeq x y -> P y.
-intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
+Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop),
+  P x -> forall y, JMeq x y -> P y.
+Proof.
+intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
 Qed.
 
-Lemma JMeq_rec : forall (A:Type) (x y:A) (P:A -> Set), P x -> JMeq x y -> P y.
-intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
+Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set),
+  P x -> forall y, JMeq x y -> P y.
+Proof.
+intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
 Qed.
 
-Lemma JMeq_rect : forall (A:Type) (x y:A) (P:A->Type), P x -> JMeq x y -> P y.
-intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
+Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type),
+  P x -> forall y, JMeq x y -> P y.
+Proof.
+intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
+Qed.
+
+Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop),
+   P x -> forall y, JMeq y x -> P y.
+Proof.
+intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
 Qed.
 
-Lemma JMeq_ind_r :
- forall (A:Type) (x y:A) (P:A -> Prop), P y -> JMeq x y -> P x.
-intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
+Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set),
+   P x -> forall y, JMeq y x -> P y.
+Proof.
+intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
 Qed.
 
-Lemma JMeq_rec_r :
- forall (A:Type) (x y:A) (P:A -> Set), P y -> JMeq x y -> P x.
-intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
+Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type),
+   P x -> forall y, JMeq y x -> P y.
+Proof.
+intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
 Qed.
 
-Lemma JMeq_rect_r :
- forall (A:Type) (x y:A) (P:A -> Type), P y -> JMeq x y -> P x.
-intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
+Lemma JMeq_congr :
+ forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y.
+Proof.
+intros A x B f y H; case JMeq_eq with (1 := H); trivial.
 Qed.
 
 (** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *)
@@ -107,3 +124,21 @@ intro H.
 assert (true=false) by (destruct H; reflexivity).
 discriminate.
 Qed.
+
+(** However, when the dependencies are equal, [JMeq (P p) x (P q) y]
+    is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *)
+
+Lemma JMeq_eq_dep : 
+  forall U (P:U->Prop) p q (x:P p) (y:P q), 
+  p = q -> JMeq x y -> eq_dep U P p x q y.
+Proof.
+intros.
+destruct H.
+apply JMeq_eq in H0 as ->.
+reflexivity.
+Qed.
+
+
+(* Compatibility *)
+Notation sym_JMeq := JMeq_sym (only parsing).
+Notation trans_JMeq := JMeq_trans (only parsing).
diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v
index dd3178eb..4c48d95c 100644
--- a/theories/Logic/ProofIrrelevanceFacts.v
+++ b/theories/Logic/ProofIrrelevanceFacts.v
@@ -21,8 +21,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance).
   (** Proof-irrelevance implies uniqueness of reflexivity proofs *)
 
   Module Eq_rect_eq.
-    Lemma eq_rect_eq : 
-      forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), 
+    Lemma eq_rect_eq :
+      forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
         x = eq_rect p Q x p h.
     Proof.
       intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p).
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index ec168f09..49fa1222 100644
--- a/theories/Logic/RelationalChoice.v
+++ b/theories/Logic/RelationalChoice.v
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RelationalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** This file axiomatizes the relational form of the axiom of choice *)
 
 Axiom relational_choice :
   forall (A B : Type) (R : A->B->Prop),
    (forall x : A, exists y : B, R x y) ->
-     exists R' : A->B->Prop, 
+     exists R' : A->B->Prop,
        subrelation R' R /\ forall x : A, exists! y : B, R' x y.
diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget
new file mode 100644
index 00000000..46046897
--- /dev/null
+++ b/theories/Logic/vo.itarget
@@ -0,0 +1,28 @@
+Berardi.vo
+ChoiceFacts.vo
+ClassicalChoice.vo
+ClassicalDescription.vo
+ClassicalEpsilon.vo
+ClassicalFacts.vo
+Classical_Pred_Set.vo
+Classical_Pred_Type.vo
+Classical_Prop.vo
+Classical_Type.vo
+ClassicalUniqueChoice.vo
+Classical.vo
+ConstructiveEpsilon.vo
+Decidable.vo
+Description.vo
+Diaconescu.vo
+Epsilon.vo
+Eqdep_dec.vo
+EqdepFacts.vo
+Eqdep.vo
+FunctionalExtensionality.vo
+Hurkens.vo
+IndefiniteDescription.vo
+JMeq.vo
+ProofIrrelevanceFacts.vo
+ProofIrrelevance.vo
+RelationalChoice.vo
+SetIsType.vo
diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v
new file mode 100644
index 00000000..c41df7c2
--- /dev/null
+++ b/theories/MSets/MSetAVL.v
@@ -0,0 +1,1842 @@
+(* -*- coding: utf-8 -*- *)
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * MSetAVL : Implementation of MSetInterface via AVL trees *)
+
+(** This module implements finite sets using AVL trees.
+    It follows the implementation from Ocaml's standard library,
+
+    All operations given here expect and produce well-balanced trees
+    (in the ocaml sense: heigths of subtrees shouldn't differ by more
+    than 2), and hence has low complexities (e.g. add is logarithmic
+    in the size of the set). But proving these balancing preservations
+    is in fact not necessary for ensuring correct operational behavior
+    and hence fulfilling the MSet interface. As a consequence,
+    balancing results are not part of this file anymore, they can
+    now be found in [MSetFullAVL].
+
+    Four operations ([union], [subset], [compare] and [equal]) have
+    been slightly adapted in order to have only structural recursive
+    calls. The precise ocaml versions of these operations have also
+    been formalized (thanks to Function+measure), see [ocaml_union],
+    [ocaml_subset], [ocaml_compare] and [ocaml_equal] in
+    [MSetFullAVL]. The structural variants compute faster in Coq,
+    whereas the other variants produce nicer and/or (slightly) faster
+    code after extraction.
+*)
+
+Require Import MSetInterface ZArith Int.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+(* for nicer extraction, we create only logical inductive principles *)
+Local Unset Elimination Schemes.
+Local Unset Case Analysis Schemes.
+
+(** * Ops : the pure functions *)
+
+Module Ops (Import I:Int)(X:OrderedType) <: WOps X.
+Local Open Scope Int_scope.
+Local Open Scope lazy_bool_scope.
+
+Definition elt := X.t.
+
+(** ** Trees
+
+   The fourth field of [Node] is the height of the tree *)
+
+Inductive tree :=
+  | Leaf : tree
+  | Node : tree -> X.t -> tree -> int -> tree.
+
+Definition t := tree.
+
+(** ** Basic functions on trees: height and cardinal *)
+
+Definition height (s : t) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ h => h
+  end.
+
+Fixpoint cardinal (s : t) : nat :=
+  match s with
+   | Leaf => 0%nat
+   | Node l _ r _ => S (cardinal l + cardinal r)
+  end.
+
+(** ** Empty Set *)
+
+Definition empty := Leaf.
+
+(** ** Emptyness test *)
+
+Definition is_empty s :=
+  match s with Leaf => true | _ => false end.
+
+(** ** Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the
+    binary search tree invariant to achieve logarithmic complexity. *)
+
+Fixpoint mem x s :=
+   match s with
+     |  Leaf => false
+     |  Node l y r _ => match X.compare x y with
+             | Lt => mem x l
+             | Eq => true
+             | Gt => mem x r
+         end
+   end.
+
+(** ** Singleton set *)
+
+Definition singleton x := Node Leaf x Leaf 1.
+
+(** ** Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create l x r :=
+   Node l x r (max (height l) (height r) + 1).
+
+(** [bal l x r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition assert_false := create.
+
+Definition bal l x r :=
+  let hl := height l in
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then
+    match l with
+     | Leaf => assert_false l x r
+     | Node ll lx lr _ =>
+       if ge_lt_dec (height ll) (height lr) then
+         create ll lx (create lr x r)
+       else
+         match lr with
+          | Leaf => assert_false l x r
+          | Node lrl lrx lrr _ =>
+              create (create ll lx lrl) lrx (create lrr x r)
+         end
+    end
+  else
+    if gt_le_dec hr (hl+2) then
+      match r with
+       | Leaf => assert_false l x r
+       | Node rl rx rr _ =>
+         if ge_lt_dec (height rr) (height rl) then
+            create (create l x rl) rx rr
+         else
+           match rl with
+            | Leaf => assert_false l x r
+            | Node rll rlx rlr _ =>
+                create (create l x rll) rlx (create rlr rx rr)
+           end
+      end
+    else
+      create l x r.
+
+(** ** Insertion *)
+
+Fixpoint add x s := match s with
+   | Leaf => Node Leaf x Leaf 1
+   | Node l y r h =>
+      match X.compare x y with
+         | Lt => bal (add x l) y r
+         | Eq => Node l y r h
+         | Gt => bal l y (add x r)
+      end
+  end.
+
+(** ** Join
+
+    Same as [bal] but does not assume anything regarding heights
+    of [l] and [r].
+*)
+
+Fixpoint join l : elt -> t -> t :=
+  match l with
+    | Leaf => add
+    | Node ll lx lr lh => fun x =>
+       fix join_aux (r:t) : t := match r with
+          | Leaf =>  add x l
+          | Node rl rx rr rh =>
+               if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
+               else create l x r
+          end
+  end.
+
+(** ** Extraction of minimum element
+
+  Morally, [remove_min] is to be applied to a non-empty tree
+  [t = Node l x r h]. Since we can't deal here with [assert false]
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
+*)
+
+Fixpoint remove_min l x r : t*elt :=
+  match l with
+    | Leaf => (r,x)
+    | Node ll lx lr lh =>
+       let (l',m) := remove_min ll lx lr in (bal l' x r, m)
+  end.
+
+(** ** Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Definition merge s1 s2 :=  match s1,s2 with
+  | Leaf, _ => s2
+  | _, Leaf => s1
+  | _, Node l2 x2 r2 h2 =>
+        let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
+end.
+
+(** ** Deletion *)
+
+Fixpoint remove x s := match s with
+  | Leaf => Leaf
+  | Node l y r h =>
+      match X.compare x y with
+         | Lt => bal (remove x l) y r
+         | Eq => merge l r
+         | Gt => bal l  y (remove x r)
+      end
+   end.
+
+(** ** Minimum element *)
+
+Fixpoint min_elt s := match s with
+   | Leaf => None
+   | Node Leaf y _  _ => Some y
+   | Node l _ _ _ => min_elt l
+end.
+
+(** ** Maximum element *)
+
+Fixpoint max_elt s := match s with
+   | Leaf => None
+   | Node _ y Leaf  _ => Some y
+   | Node _ _ r _ => max_elt r
+end.
+
+(** ** Any element *)
+
+Definition choose := min_elt.
+
+(** ** Concatenation
+
+    Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat s1 s2 :=
+   match s1, s2 with
+      | Leaf, _ => s2
+      | _, Leaf => s1
+      | _, Node l2 x2 r2 _ =>
+            let (s2',m) := remove_min l2 x2 r2 in
+            join s1 m s2'
+   end.
+
+(** ** Splitting
+
+    [split x s] returns a triple [(l, present, r)] where
+    - [l] is the set of elements of [s] that are [< x]
+    - [r] is the set of elements of [s] that are [> x]
+    - [present] is [true] if and only if [s] contains  [x].
+*)
+
+Record triple := mktriple { t_left:t; t_in:bool; t_right:t }.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+
+Fixpoint split x s : triple := match s with
+  | Leaf => << Leaf, false, Leaf >>
+  | Node l y r h =>
+     match X.compare x y with
+      | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
+      | Eq => << l, true, r >>
+      | Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >>
+     end
+ end.
+
+(** ** Intersection *)
+
+Fixpoint inter s1 s2 := match s1, s2 with
+    | Leaf, _ => Leaf
+    | _, Leaf => Leaf
+    | Node l1 x1 r1 h1, _ =>
+            let (l2',pres,r2') := split x1 s2 in
+            if pres then join (inter l1 l2') x1 (inter r1 r2')
+            else concat (inter l1 l2') (inter r1 r2')
+    end.
+
+(** ** Difference *)
+
+Fixpoint diff s1 s2 := match s1, s2 with
+ | Leaf, _ => Leaf
+ | _, Leaf => s1
+ | Node l1 x1 r1 h1, _ =>
+    let (l2',pres,r2') := split x1 s2 in
+    if pres then concat (diff l1 l2') (diff r1 r2')
+    else join (diff l1 l2') x1 (diff r1 r2')
+end.
+
+(** ** Union *)
+
+(** In ocaml, heights of [s1] and [s2] are compared each time in order
+   to recursively perform the split on the smaller set.
+   Unfortunately, this leads to a non-structural algorithm. The
+   following code is a simplification of the ocaml version: no
+   comparison of heights. It might be slightly slower, but
+   experimentally all the tests I've made in ocaml have shown this
+   potential slowdown to be non-significant. Anyway, the exact code
+   of ocaml has also been formalized thanks to Function+measure, see
+   [ocaml_union] in [MSetFullAVL].
+*)
+
+Fixpoint union s1 s2 :=
+ match s1, s2 with
+  | Leaf, _ => s2
+  | _, Leaf => s1
+  | Node l1 x1 r1 h1, _ =>
+     let (l2',_,r2') := split x1 s2 in
+     join (union l1 l2') x1 (union r1 r2')
+ end.
+
+(** ** Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t :=
+  match s with
+   | Leaf => acc
+   | Node l x r _ => elements_aux (x :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+(** ** Filter *)
+
+Fixpoint filter_acc (f:elt->bool) acc s := match s with
+  | Leaf => acc
+  | Node l x r h =>
+     filter_acc f (filter_acc f (if f x then add x acc else acc) l) r
+ end.
+
+Definition filter f := filter_acc f Leaf.
+
+
+(** ** Partition *)
+
+Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t :=
+  match s with
+   | Leaf => acc
+   | Node l x r _ =>
+      let (acct,accf) := acc in
+      partition_acc f
+        (partition_acc f
+           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
+  end.
+
+Definition partition f := partition_acc f (Leaf,Leaf).
+
+(** ** [for_all] and [exists] *)
+
+Fixpoint for_all (f:elt->bool) s := match s with
+  | Leaf => true
+  | Node l x r _ => f x &&& for_all f l &&& for_all f r
+end.
+
+Fixpoint exists_ (f:elt->bool) s := match s with
+  | Leaf => false
+  | Node l x r _ => f x ||| exists_ f l ||| exists_ f r
+end.
+
+(** ** Fold *)
+
+Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A :=
+ fun a => match s with
+  | Leaf => a
+  | Node l x r _ => fold f r (f x (fold f l a))
+ end.
+Implicit Arguments fold [A].
+
+
+(** ** Subset *)
+
+(** In ocaml, recursive calls are made on "half-trees" such as
+   (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these
+   non-structural calls, we propose here two specialized functions for
+   these situations. This version should be almost as efficient as
+   the one of ocaml (closures as arguments may slow things a bit),
+   it is simply less compact. The exact ocaml version has also been
+   formalized (thanks to Function+measure), see [ocaml_subset] in
+   [MSetFullAVL].
+ *)
+
+Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool :=
+ match s2 with
+  | Leaf => false
+  | Node l2 x2 r2 h2 =>
+     match X.compare x1 x2 with
+      | Eq => subset_l1 l2
+      | Lt => subsetl subset_l1 x1 l2
+      | Gt => mem x1 r2 &&& subset_l1 s2
+     end
+ end.
+
+Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool :=
+ match s2 with
+  | Leaf => false
+  | Node l2 x2 r2 h2 =>
+     match X.compare x1 x2 with
+      | Eq => subset_r1 r2
+      | Lt => mem x1 l2 &&& subset_r1 s2
+      | Gt => subsetr subset_r1 x1 r2
+     end
+ end.
+
+Fixpoint subset s1 s2 : bool := match s1, s2 with
+  | Leaf, _ => true
+  | Node _ _ _ _, Leaf => false
+  | Node l1 x1 r1 h1, Node l2 x2 r2 h2 =>
+     match X.compare x1 x2 with
+      | Eq => subset l1 l2 &&& subset r1 r2
+      | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
+      | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
+     end
+ end.
+
+(** ** A new comparison algorithm suggested by Xavier Leroy
+
+    Transformation in C.P.S. suggested by Benjamin Grégoire.
+    The original ocaml code (with non-structural recursive calls)
+    has also been formalized (thanks to Function+measure), see
+    [ocaml_compare] in [MSetFullAVL]. The following code with
+    continuations computes dramatically faster in Coq, and
+    should be almost as efficient after extraction.
+*)
+
+(** Enumeration of the elements of a tree *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : elt -> t -> enumeration -> enumeration.
+
+
+(** [cons t e] adds the elements of tree [t] on the head of
+    enumeration [e]. *)
+
+Fixpoint cons s e : enumeration :=
+ match s with
+  | Leaf => e
+  | Node l x r h => cons l (More x r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition compare_more x1 (cont:enumeration->comparison) e2 :=
+ match e2 with
+ | End => Gt
+ | More x2 r2 e2 =>
+     match X.compare x1 x2 with
+      | Eq => cont (cons r2 e2)
+      | Lt => Lt
+      | Gt => Gt
+     end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
+ match s1 with
+  | Leaf => cont e2
+  | Node l1 x1 r1 _ =>
+     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
+  end.
+
+(** Initial continuation *)
+
+Definition compare_end e2 :=
+ match e2 with End => Eq | _ => Lt end.
+
+(** The complete comparison *)
+
+Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
+
+(** ** Equality test *)
+
+Definition equal s1 s2 : bool :=
+ match compare s1 s2 with
+  | Eq => true
+  | _ => false
+ end.
+
+End Ops.
+
+
+
+(** * MakeRaw
+
+   Functor of pure functions + a posteriori proofs of invariant
+   preservation *)
+
+Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
+Include Ops I X.
+
+(** * Invariants *)
+
+(** ** Occurrence in a tree *)
+
+Inductive InT (x : elt) : tree -> Prop :=
+  | IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h)
+  | InLeft : forall l r h y, InT x l -> InT x (Node l y r h)
+  | InRight : forall l r h y, InT x r -> InT x (Node l y r h).
+
+Definition In := InT.
+
+(** ** Some shortcuts *)
+
+Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
+Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
+Definition Empty s := forall a : elt, ~ InT a s.
+Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
+Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
+
+(** ** Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x]
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree x s := forall y, InT y s -> X.lt y x.
+Definition gt_tree x s := forall y, InT y s -> X.lt x y.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode : forall x l r h, bst l -> bst r ->
+     lt_tree x l -> gt_tree x r -> bst (Node l x r h).
+
+(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
+
+Definition IsOk := bst.
+
+Class Ok (s:t) : Prop := ok : bst s.
+
+Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.
+
+Fixpoint ltb_tree x s :=
+ match s with
+  | Leaf => true
+  | Node l y r _ =>
+     match X.compare x y with
+      | Gt => ltb_tree x l && ltb_tree x r
+      | _ => false
+     end
+ end.
+
+Fixpoint gtb_tree x s :=
+ match s with
+  | Leaf => true
+  | Node l y r _ =>
+     match X.compare x y with
+      | Lt => gtb_tree x l && gtb_tree x r
+      | _ => false
+     end
+ end.
+
+Fixpoint isok s :=
+ match s with
+  | Leaf => true
+  | Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r
+ end.
+
+
+(** * Correctness proofs *)
+
+Module Import MX := OrderedTypeFacts X.
+
+(** * Automation and dedicated tactics *)
+
+Scheme tree_ind := Induction for tree Sort Prop.
+
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
+Local Hint Immediate MX.eq_sym.
+Local Hint Unfold In lt_tree gt_tree.
+Local Hint Constructors InT bst.
+Local Hint Unfold Ok.
+
+Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h)
+ "as" ident(s) :=
+ set (s:=Node l x r h) in *; clearbody s; clear l x r h.
+
+(** Automatic treatment of [Ok] hypothesis *)
+
+Ltac inv_ok := match goal with
+ | H:Ok (Node _ _ _ _) |- _ => inversion_clear H; inv_ok
+ | H:Ok Leaf |- _ => clear H; inv_ok
+ | H:bst ?x |- _ => change (Ok x) in H; inv_ok
+ | _ => idtac
+end.
+
+(** A tactic to repeat [inversion_clear] on all hyps of the
+    form [(f (Node _ _ _ _))] *)
+
+Ltac is_tree_constr c :=
+  match c with
+   | Leaf => idtac
+   | Node _ _ _ _ => idtac
+   | _ => fail
+  end.
+
+Ltac invtree f :=
+  match goal with
+     | H:f ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
+     | H:f _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
+     | H:f _ _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
+     | _ => idtac
+  end.
+
+Ltac inv := inv_ok; invtree InT.
+
+Ltac intuition_in := repeat progress (intuition; inv).
+
+(** Helper tactic concerning order of elements. *)
+
+Ltac order := match goal with
+ | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
+ | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
+ | _ => MX.order
+end.
+
+
+(** [isok] is indeed a decision procedure for [Ok] *)
+
+Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
+Proof.
+ induction s as [|l IHl y r IHr h]; simpl.
+ unfold lt_tree; intuition_in.
+ elim_compare x y.
+ split; intros; try discriminate. assert (X.lt y x) by auto. order.
+ split; intros; try discriminate. assert (X.lt y x) by auto. order.
+ rewrite !andb_true_iff, <-IHl, <-IHr.
+  unfold lt_tree; intuition_in; order.
+Qed.
+
+Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
+Proof.
+ induction s as [|l IHl y r IHr h]; simpl.
+ unfold gt_tree; intuition_in.
+ elim_compare x y.
+ split; intros; try discriminate. assert (X.lt x y) by auto. order.
+ rewrite !andb_true_iff, <-IHl, <-IHr.
+  unfold gt_tree; intuition_in; order.
+ split; intros; try discriminate. assert (X.lt x y) by auto. order.
+Qed.
+
+Lemma isok_iff : forall s, Ok s <-> isok s = true.
+Proof.
+ induction s as [|l IHl y r IHr h]; simpl.
+ intuition_in.
+ rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
+ intuition_in.
+Qed.
+
+Instance isok_Ok s : isok s = true -> Ok s | 10.
+Proof. intros; apply <- isok_iff; auto. Qed.
+
+
+(** * Basic results about [In], [lt_tree], [gt_tree], [height] *)
+
+(** [In] is compatible with [X.eq] *)
+
+Lemma In_1 :
+ forall s x y, X.eq x y -> InT x s -> InT y s.
+Proof.
+ induction s; simpl; intuition_in; eauto.
+Qed.
+Local Hint Immediate In_1.
+
+Instance In_compat : Proper (X.eq==>eq==>iff) InT.
+Proof.
+apply proper_sym_impl_iff_2; auto with *.
+repeat red; intros; subst. apply In_1 with x; auto.
+Qed.
+
+Lemma In_node_iff :
+ forall l x r h y,
+  InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r.
+Proof.
+ intuition_in.
+Qed.
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
+Proof.
+ red; inversion 1.
+Qed.
+
+Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
+Proof.
+ red; inversion 1.
+Qed.
+
+Lemma lt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
+Proof.
+ unfold lt_tree; intuition_in; order.
+Qed.
+
+Lemma gt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
+Proof.
+ unfold gt_tree; intuition_in; order.
+Qed.
+
+Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_tree_not_in :
+ forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
+Proof.
+ eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
+Proof.
+ eauto.
+Qed.
+
+Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+(** * Inductions principles for some of the set operators *)
+
+Functional Scheme bal_ind := Induction for bal Sort Prop.
+Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
+Functional Scheme merge_ind := Induction for merge Sort Prop.
+Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
+Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
+Functional Scheme concat_ind := Induction for concat Sort Prop.
+Functional Scheme inter_ind := Induction for inter Sort Prop.
+Functional Scheme diff_ind := Induction for diff Sort Prop.
+Functional Scheme union_ind := Induction for union Sort Prop.
+
+Ltac induct s x :=
+ induction s as [|l IHl x' r IHr h]; simpl; intros;
+ [|elim_compare x x'; intros; inv].
+
+
+(** * Notations and helper lemma about pairs and triples *)
+
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope.
+Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.
+
+Open Local Scope pair_scope.
+
+
+(** * Empty set *)
+
+Lemma empty_spec : Empty empty.
+Proof.
+ intro; intro.
+ inversion H.
+Qed.
+
+Instance empty_ok : Ok empty.
+Proof.
+ auto.
+Qed.
+
+(** * Emptyness test *)
+
+Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
+Proof.
+ destruct s as [|r x l h]; simpl; auto.
+ split; auto. red; red; intros; inv.
+ split; auto. try discriminate. intro H; elim (H x); auto.
+Qed.
+
+(** * Appartness *)
+
+Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
+Proof.
+ split.
+ induct s x; auto; try discriminate.
+ induct s x; intuition_in; order.
+Qed.
+
+
+(** * Singleton set *)
+
+Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x.
+Proof.
+ unfold singleton; intuition_in.
+Qed.
+
+Instance singleton_ok x : Ok (singleton x).
+Proof.
+ unfold singleton; auto.
+Qed.
+
+
+
+(** * Helper functions *)
+
+Lemma create_spec :
+ forall l x r y,  InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (create l x r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma bal_spec : forall l x r y,
+ InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ intros l x r; functional induction bal l x r; intros; try clear e0;
+ rewrite !create_spec; intuition_in.
+Qed.
+
+Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (bal l x r).
+Proof.
+ functional induction bal l x r; intros;
+ inv; repeat apply create_ok; auto; unfold create;
+ (apply lt_tree_node || apply gt_tree_node); auto;
+ (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
+Qed.
+
+
+(** * Insertion *)
+
+Lemma add_spec' : forall s x y,
+ InT y (add x s) <-> X.eq y x \/ InT y s.
+Proof.
+ induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in.
+ setoid_replace y with x'; eauto.
+Qed.
+
+Lemma add_spec : forall s x y `{Ok s},
+ InT y (add x s) <-> X.eq y x \/ InT y s.
+Proof. intros; apply add_spec'. Qed.
+
+Instance add_ok s x `(Ok s) : Ok (add x s).
+Proof.
+ induct s x; auto; apply bal_ok; auto;
+  intros y; rewrite add_spec'; intuition; order.
+Qed.
+
+
+Open Scope Int_scope.
+
+(** * Join *)
+
+(* Function/Functional Scheme can't deal with internal fix.
+   Let's do its job by hand: *)
+
+Ltac join_tac :=
+ intro l; induction l as [| ll _ lx lr Hlr lh];
+   [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join;
+     [ | destruct (gt_le_dec lh (rh+2));
+       [ match goal with |- context b [ bal ?a ?b ?c] =>
+           replace (bal a b c)
+           with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto]
+         end
+       | destruct (gt_le_dec rh (lh+2));
+         [ match goal with |- context b [ bal ?a ?b ?c] =>
+             replace (bal a b c)
+             with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto]
+           end
+         | ] ] ] ]; intros.
+
+Lemma join_spec : forall l x r y,
+ InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ join_tac.
+ simpl.
+ rewrite add_spec'; intuition_in.
+ rewrite add_spec'; intuition_in.
+ rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in.
+ rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in.
+ apply create_spec.
+Qed.
+
+Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r),
+ Ok (join l x r).
+Proof.
+ join_tac; auto with *; inv; apply bal_ok; auto;
+ clear Hrl Hlr z; intro; intros; rewrite join_spec in *.
+ intuition; [ setoid_replace y with x | ]; eauto.
+ intuition; [ setoid_replace y with x | ]; eauto.
+Qed.
+
+
+(** * Extraction of minimum element *)
+
+Lemma remove_min_spec : forall l x r h y,
+ InT y (Node l x r h) <->
+  X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl in *; intros.
+ intuition_in.
+ rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition.
+Qed.
+
+Instance remove_min_ok l x r : forall h `(Ok (Node l x r h)),
+ Ok (remove_min l x r)#1.
+Proof.
+ functional induction (remove_min l x r); simpl; intros.
+ inv; auto.
+ assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
+ assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
+ specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *.
+ apply bal_ok; auto.
+ inv; auto.
+ intro y; specialize (L y).
+ rewrite remove_min_spec, e0 in L; simpl in L; intuition.
+ inv; auto.
+Qed.
+
+Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)},
+ gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl; intros.
+ inv; auto.
+ assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
+ assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
+ specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp.
+ intro y; rewrite bal_spec; intuition;
+  specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L;
+   [setoid_replace y with x|inv]; eauto.
+Qed.
+Local Hint Resolve remove_min_gt_tree.
+
+
+
+(** * Merging two trees *)
+
+Lemma merge_spec : forall s1 s2 y,
+ InT y (merge s1 s2) <-> InT y s1 \/ InT y s2.
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); intros;
+ try factornode _x _x0 _x1 _x2 as s1.
+ intuition_in.
+ intuition_in.
+ rewrite bal_spec, remove_min_spec, e1; simpl; intuition.
+Qed.
+
+Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2)
+ `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
+ Ok (merge s1 s2).
+Proof.
+ functional induction (merge s1 s2); intros; auto;
+ try factornode _x _x0 _x1 _x2 as s1.
+ apply bal_ok; auto.
+ change s2' with ((s2',m)#1); rewrite <-e1; eauto with *.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_spec, e1; simpl; auto.
+ change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
+Qed.
+
+
+
+(** * Deletion *)
+
+Lemma remove_spec : forall s x y `{Ok s},
+ (InT y (remove x s) <-> InT y s /\ ~ X.eq y x).
+Proof.
+ induct s x.
+ intuition_in.
+ rewrite merge_spec; intuition; [order|order|intuition_in].
+ elim H6; eauto.
+ rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in].
+ rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in].
+Qed.
+
+Instance remove_ok s x `(Ok s) : Ok (remove x s).
+Proof.
+ induct s x.
+ auto.
+ (* EQ *)
+ apply merge_ok; eauto.
+ (* LT *)
+ apply bal_ok; auto.
+ intro z; rewrite remove_spec; auto; destruct 1; eauto.
+ (* GT *)
+ apply bal_ok; auto.
+ intro z; rewrite remove_spec; auto; destruct 1; eauto.
+Qed.
+
+
+(** * Minimum element *)
+
+Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s.
+Proof.
+ intro s; functional induction (min_elt s); auto; inversion 1; auto.
+Qed.
+
+Lemma min_elt_spec2 : forall s x y `{Ok s},
+ min_elt s = Some x -> InT y s -> ~ X.lt y x.
+Proof.
+ intro s; functional induction (min_elt s);
+ try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
+ discriminate.
+ intros x y0 U V W.
+ inversion V; clear V; subst.
+ inv; order.
+ intros; inv; auto.
+ assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto).
+ order.
+ assert (X.lt x1 y) by auto.
+ assert (~X.lt x1 x) by auto.
+ order.
+Qed.
+
+Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (min_elt s).
+ red; red; inversion 2.
+ inversion 1.
+ intro H0.
+ destruct (IHo H0 _x2); auto.
+Qed.
+
+
+
+(** * Maximum element *)
+
+Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s.
+Proof.
+ intro s; functional induction (max_elt s); auto; inversion 1; auto.
+Qed.
+
+Lemma max_elt_spec2 : forall s x y `{Ok s},
+ max_elt s = Some x -> InT y s -> ~ X.lt x y.
+Proof.
+ intro s; functional induction (max_elt s);
+ try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
+ discriminate.
+ intros x y0 U V W.
+ inversion V; clear V; subst.
+ inv; order.
+ intros; inv; auto.
+ assert (X.lt y x1) by auto.
+ assert (~ X.lt x x1) by auto.
+ order.
+ assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto).
+ order.
+Qed.
+
+Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (max_elt s).
+ red; auto.
+ inversion 1.
+ intros H0; destruct (IHo H0 _x2); auto.
+Qed.
+
+
+
+(** * Any element *)
+
+Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
+Proof.
+ exact min_elt_spec1.
+Qed.
+
+Lemma choose_spec2 : forall s, choose s = None -> Empty s.
+Proof.
+ exact min_elt_spec3.
+Qed.
+
+Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
+  choose s = Some x -> choose s' = Some x' ->
+  Equal s s' -> X.eq x x'.
+Proof.
+ unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
+ assert (~X.lt x x').
+  apply min_elt_spec2 with s'; auto.
+  rewrite <-H; auto using min_elt_spec1.
+ assert (~X.lt x' x).
+  apply min_elt_spec2 with s; auto.
+  rewrite H; auto using min_elt_spec1.
+ elim_compare x x'; intuition.
+Qed.
+
+
+(** * Concatenation *)
+
+Lemma concat_spec : forall s1 s2 y,
+ InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.
+Proof.
+ intros s1 s2; functional induction (concat s1 s2); intros;
+ try factornode _x _x0 _x1 _x2 as s1.
+ intuition_in.
+ intuition_in.
+ rewrite join_spec, remove_min_spec, e1; simpl; intuition.
+Qed.
+
+Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2)
+ `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
+ Ok (concat s1 s2).
+Proof.
+ functional induction (concat s1 s2); intros; auto;
+ try factornode _x _x0 _x1 _x2 as s1.
+ apply join_ok; auto.
+ change (Ok (s2',m)#1); rewrite <-e1; eauto with *.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_spec, e1; simpl; auto.
+ change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
+Qed.
+
+
+
+(** * Splitting *)
+
+Lemma split_spec1 : forall s x y `{Ok s},
+ (InT y (split x s)#l <-> InT y s /\ X.lt y x).
+Proof.
+ induct s x.
+ intuition_in.
+ intuition_in; order.
+ specialize (IHl x y).
+ destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
+ specialize (IHr x y).
+ destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order.
+Qed.
+
+Lemma split_spec2 : forall s x y `{Ok s},
+ (InT y (split x s)#r <-> InT y s /\ X.lt x y).
+Proof.
+ induct s x.
+ intuition_in.
+ intuition_in; order.
+ specialize (IHl x y).
+ destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order.
+ specialize (IHr x y).
+ destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
+Qed.
+
+Lemma split_spec3 : forall s x `{Ok s},
+ ((split x s)#b = true <-> InT x s).
+Proof.
+ induct s x.
+ intuition_in; try discriminate.
+ intuition.
+ specialize (IHl x).
+ destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
+ specialize (IHr x).
+ destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
+Qed.
+
+Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r.
+Proof.
+ induct s x; simpl; auto.
+ specialize (IHl x).
+ generalize (fun y => @split_spec2 _ x y H1).
+ destruct (split x l); simpl in *; intuition. apply join_ok; auto.
+ intros y; rewrite H; intuition.
+ specialize (IHr x).
+ generalize (fun y => @split_spec1 _ x y H2).
+ destruct (split x r); simpl in *; intuition. apply join_ok; auto.
+ intros y; rewrite H; intuition.
+Qed.
+
+Instance split_ok1 s x `(Ok s) : Ok (split x s)#l.
+Proof. intros; destruct (@split_ok s x); auto. Qed.
+
+Instance split_ok2 s x `(Ok s) : Ok (split x s)#r.
+Proof. intros; destruct (@split_ok s x); auto. Qed.
+
+
+(** * Intersection *)
+
+Ltac destruct_split := match goal with
+ | H : split ?x ?s = << ?u, ?v, ?w >> |- _ =>
+   assert ((split x s)#l = u) by (rewrite H; auto);
+   assert ((split x s)#b = v) by (rewrite H; auto);
+   assert ((split x s)#r = w) by (rewrite H; auto);
+   clear H; subst u w
+ end.
+
+Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
+ Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
+Proof.
+ intros s1 s2; functional induction inter s1 s2; intros B1 B2;
+ [intuition_in|intuition_in | | ];
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
+ destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *;
+ split; intros.
+ (* Ok join *)
+ apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
+ (* InT join *)
+ rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
+ setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
+ (* Ok concat *)
+ apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ (* InT concat *)
+ rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
+ intuition_in.
+ absurd (InT x1 s2).
+  rewrite <- split_spec3; auto; congruence.
+  setoid_replace x1 with y; auto.
+Qed.
+
+Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
+Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.
+
+Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
+Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.
+
+
+(** * Difference *)
+
+Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
+ Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
+Proof.
+ intros s1 s2; functional induction diff s1 s2; intros B1 B2;
+ [intuition_in|intuition_in | | ];
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
+ destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *;
+ split; intros.
+ (* Ok concat *)
+ apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ (* InT concat *)
+ rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
+ absurd (InT x1 s2).
+  setoid_replace x1 with y; auto.
+  rewrite <- split_spec3; auto; congruence.
+ (* Ok join *)
+ apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
+ (* InT join *)
+ rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
+ intuition_in.
+ absurd (InT x1 s2); auto.
+  rewrite <- split_spec3; auto; congruence.
+  setoid_replace x1 with y; auto.
+Qed.
+
+Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
+Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.
+
+Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
+Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.
+
+
+(** * Union *)
+
+Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
+Proof.
+ intros s1 s2; functional induction union s1 s2; intros y B1 B2.
+ intuition_in.
+ intuition_in.
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
+ rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *.
+ elim_compare y x1; intuition_in.
+Qed.
+
+Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2).
+Proof.
+ functional induction union s1 s2; intros B1 B2; auto.
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
+ apply join_ok; auto with *.
+ intro y; rewrite union_spec, split_spec1; intuition_in.
+ intro y; rewrite union_spec, split_spec2; intuition_in.
+Qed.
+
+
+(** * Elements *)
+
+Lemma elements_spec1' : forall s acc x,
+ InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
+Proof.
+ induction s as [ | l Hl x r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+Qed.
+
+Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
+Proof.
+ intros; generalize (elements_spec1' s nil x); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
+ (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
+ sort X.lt (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y r Hr h]; simpl; intuition.
+ inv.
+ apply Hl; auto.
+ constructor.
+ apply Hr; auto.
+ eapply InA_InfA; eauto with *.
+ intros.
+ destruct (elements_spec1' r acc y0); intuition.
+ intros.
+ inversion_clear H.
+ order.
+ destruct (elements_spec1' r acc x); intuition eauto.
+Qed.
+
+Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
+Proof.
+ intros; unfold elements; apply elements_spec2'; auto.
+ intros; inversion H0.
+Qed.
+Local Hint Resolve elements_spec2.
+
+Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
+Proof.
+ intros. eapply SortA_NoDupA; eauto with *.
+Qed.
+
+Lemma elements_aux_cardinal :
+ forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite <- H.
+ simpl in |- *.
+ rewrite <- H0; omega.
+Qed.
+
+Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
+Proof.
+ exact (fun s => elements_aux_cardinal s nil).
+Qed.
+
+Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s.
+
+Lemma elements_app :
+ forall s acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold elements; simpl.
+ rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
+Qed.
+
+Lemma elements_node :
+ forall l x r h acc,
+ elements l ++ x :: elements r ++ acc =
+ elements (Node l x r h) ++ acc.
+Proof.
+ unfold elements; simpl; intros; auto.
+ rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
+Qed.
+
+
+(** * Filter *)
+
+Lemma filter_spec' : forall s x acc f,
+ Proper (X.eq==>eq) f ->
+ (InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true).
+Proof.
+ induction s; simpl; intros.
+ intuition_in.
+ rewrite IHs2, IHs1 by (destruct (f t0); auto).
+ case_eq (f t0); intros.
+ rewrite add_spec'; auto.
+ intuition_in.
+ rewrite (H _ _ H2).
+ intuition.
+ intuition_in.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+Qed.
+
+Instance filter_ok' : forall s acc f `(Ok s, Ok acc),
+ Ok (filter_acc f acc s).
+Proof.
+ induction s; simpl; auto.
+ intros. inv.
+ destruct (f t0); auto with *.
+Qed.
+
+Lemma filter_spec : forall s x f,
+ Proper (X.eq==>eq) f ->
+ (InT x (filter f s) <-> InT x s /\ f x = true).
+Proof.
+ unfold filter; intros; rewrite filter_spec'; intuition_in.
+Qed.
+
+Instance filter_ok s f `(Ok s) : Ok (filter f s).
+Proof.
+ unfold filter; intros; apply filter_ok'; auto.
+Qed.
+
+
+(** * Partition *)
+
+Lemma partition_spec1' : forall s acc f,
+ Proper (X.eq==>eq) f -> forall x : elt,
+ InT x (partition_acc f acc s)#1 <->
+ InT x acc#1 \/ InT x s /\ f x = true.
+Proof.
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ rewrite IHs2 by
+  (destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto).
+ rewrite IHs1 by (destruct (f t0); simpl; auto).
+ case_eq (f t0); simpl; intros.
+ rewrite add_spec'; auto.
+ intuition_in.
+ rewrite (H _ _ H2).
+ intuition.
+ intuition_in.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+Qed.
+
+Lemma partition_spec2' : forall s acc f,
+ Proper (X.eq==>eq) f -> forall x : elt,
+ InT x (partition_acc f acc s)#2 <->
+ InT x acc#2 \/ InT x s /\ f x = false.
+Proof.
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ rewrite IHs2 by
+  (destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto).
+ rewrite IHs1 by (destruct (f t0); simpl; auto).
+ case_eq (f t0); simpl; intros.
+ intuition.
+ intuition_in.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+ rewrite add_spec'; auto.
+ intuition_in.
+ rewrite (H _ _ H2).
+ intuition.
+Qed.
+
+Lemma partition_spec1 : forall s f,
+ Proper (X.eq==>eq) f ->
+ Equal (partition f s)#1 (filter f s).
+Proof.
+ unfold partition; intros s f P x.
+ rewrite partition_spec1', filter_spec; simpl; intuition_in.
+Qed.
+
+Lemma partition_spec2 : forall s f,
+ Proper (X.eq==>eq) f ->
+ Equal (partition f s)#2 (filter (fun x => negb (f x)) s).
+Proof.
+ unfold partition; intros s f P x.
+ rewrite partition_spec2', filter_spec; simpl; intuition_in.
+ rewrite H1; auto.
+ right; split; auto.
+ rewrite negb_true_iff in H1; auto.
+ intros u v H; rewrite H; auto.
+Qed.
+
+Instance partition_ok1' : forall s acc f `(Ok s, Ok acc#1),
+ Ok (partition_acc f acc s)#1.
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros. inv.
+ destruct (f t0); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto with *.
+Qed.
+
+Instance partition_ok2' : forall s acc f `(Ok s, Ok acc#2),
+ Ok (partition_acc f acc s)#2.
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros. inv.
+ destruct (f t0); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto with *.
+Qed.
+
+Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1.
+Proof. apply partition_ok1'; auto. Qed.
+
+Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2.
+Proof. apply partition_ok2'; auto. Qed.
+
+
+
+(** * [for_all] and [exists] *)
+
+Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f ->
+ (for_all f s = true <-> For_all (fun x => f x = true) s).
+Proof.
+ split.
+ induction s; simpl; auto; intros; red; intros; inv.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); eauto.
+ apply IHs1; auto.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); auto.
+ apply IHs2; auto.
+ destruct (andb_prop _ _ H0); auto.
+ (* <- *)
+ induction s; simpl; auto.
+ intros. red in H0.
+ rewrite IHs1; try red; auto.
+ rewrite IHs2; try red; auto.
+ generalize (H0 t0).
+ destruct (f t0); simpl; auto.
+Qed.
+
+Lemma exists_spec : forall s f, Proper (X.eq==>eq) f ->
+ (exists_ f s = true <-> Exists (fun x => f x = true) s).
+Proof.
+ split.
+ induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *.
+ discriminate.
+ destruct (orb_true_elim _ _ H0) as [H1|H1].
+ destruct (orb_true_elim _ _ H1) as [H2|H2].
+ exists t0; auto.
+ destruct (IHs1 H2); auto; exists x; intuition.
+ destruct (IHs2 H1); auto; exists x; intuition.
+ (* <- *)
+ induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt.
+ rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto.
+ apply orb_true_intro; left.
+ apply orb_true_intro; right; apply IHs1; auto; exists x; auto.
+ apply orb_true_intro; right; apply IHs2; auto; exists x; auto.
+Qed.
+
+
+(** * Fold *)
+
+Lemma fold_spec' :
+ forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt),
+ fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
+Proof.
+ induction s as [|l IHl x r IHr h]; simpl; intros; auto.
+ rewrite IHl.
+ simpl. unfold flip at 2.
+ apply IHr.
+Qed.
+
+Lemma fold_spec :
+ forall (s:t) (A : Type) (i : A) (f : elt -> A -> A),
+ fold f s i = fold_left (flip f) (elements s) i.
+Proof.
+ unfold elements.
+ induction s as [|l IHl x r IHr h]; simpl; intros; auto.
+ rewrite fold_spec'.
+ rewrite IHr.
+ simpl; auto.
+Qed.
+
+
+(** * Subset *)
+
+Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2
+ `{Ok (Node l1 x1 Leaf h1), Ok s2},
+ (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
+ (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ).
+Proof.
+ induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ specialize (IHl2 H).
+ specialize (IHr2 H).
+ inv.
+ elim_compare x1 x2.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite IHl2 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
+ rewrite mem_spec; auto.
+ assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+
+Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2,
+ bst (Node Leaf x1 r1 h1) -> bst s2 ->
+ (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
+ (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2).
+Proof.
+ induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ specialize (IHl2 H).
+ specialize (IHr2 H).
+ inv.
+ elim_compare x1 x2.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
+ rewrite mem_spec; auto.
+ assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite IHr2 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
+ (subset s1 s2 = true <-> Subset s1 s2).
+Proof.
+ induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros.
+ unfold Subset; intuition_in.
+ destruct s2 as [|l2 x2 r2 h2]; simpl; intros.
+ unfold Subset; intuition_in; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ inv.
+ elim_compare x1 x2.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
+ rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
+ rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+
+(** * Comparison *)
+
+(** ** Relations [eq] and [lt] over trees *)
+
+Module L := MakeListOrdering X.
+
+Definition eq := Equal.
+Instance eq_equiv : Equivalence eq.
+Proof. firstorder. Qed.
+
+Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
+Proof.
+ unfold eq, Equal, L.eq; intros.
+ setoid_rewrite elements_spec1; firstorder.
+Qed.
+
+Definition lt (s1 s2 : t) : Prop :=
+ exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
+   /\ L.lt (elements s1') (elements s2').
+
+Instance lt_strorder : StrictOrder lt.
+Proof.
+ split.
+ intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
+ assert (eqlistA X.eq (elements s1) (elements s2)).
+  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
+  rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
+ rewrite H in L.
+ apply (StrictOrder_Irreflexive (elements s2)); auto.
+ intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
+                 (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
+ exists s1', s3'; do 4 (split; trivial).
+ assert (eqlistA X.eq (elements s2') (elements s2'')).
+  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
+  rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
+ transitivity (elements s2'); auto.
+ rewrite H; auto.
+Qed.
+
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof.
+ intros s1 s2 E12 s3 s4 E34. split.
+ intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+ exists s1', s3'; do 2 (split; trivial).
+  split. transitivity s1; auto. symmetry; auto.
+  split; auto. transitivity s3; auto. symmetry; auto.
+ intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+ exists s1', s3'; do 2 (split; trivial).
+  split. transitivity s2; auto.
+  split; auto. transitivity s4; auto.
+Qed.
+
+
+(** * Proof of the comparison algorithm *)
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+
+Fixpoint flatten_e (e : enumeration) : list elt := match e with
+  | End => nil
+  | More x t r => x :: elements t ++ flatten_e r
+ end.
+
+Lemma flatten_e_elements :
+ forall l x r h e,
+ elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e.
+Proof.
+ intros; simpl; apply elements_node.
+Qed.
+
+Lemma cons_1 : forall s e,
+  flatten_e (cons s e) = elements s ++ flatten_e e.
+Proof.
+ induction s; simpl; auto; intros.
+ rewrite IHs1; apply flatten_e_elements.
+Qed.
+
+(** Correctness of this comparison *)
+
+Definition Cmp c x y := CompSpec L.eq L.lt x y c.
+
+Local Hint Unfold Cmp flip.
+
+Lemma compare_end_Cmp :
+ forall e2, Cmp (compare_end e2) nil (flatten_e e2).
+Proof.
+ destruct e2; simpl; constructor; auto. reflexivity.
+Qed.
+
+Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
+  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
+   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
+      (flatten_e (More x2 r2 e2)).
+Proof.
+ simpl; intros; elim_compare x1 x2; simpl; auto.
+Qed.
+
+Lemma compare_cont_Cmp : forall s1 cont e2 l,
+ (forall e, Cmp (cont e) l (flatten_e e)) ->
+ Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
+Proof.
+ induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto.
+ rewrite <- elements_node; simpl.
+ apply Hl1; auto. clear e2. intros [|x2 r2 e2].
+ simpl; auto.
+ apply compare_more_Cmp.
+ rewrite <- cons_1; auto.
+Qed.
+
+Lemma compare_Cmp : forall s1 s2,
+ Cmp (compare s1 s2) (elements s1) (elements s2).
+Proof.
+ intros; unfold compare.
+ rewrite (app_nil_end (elements s1)).
+ replace (elements s2) with (flatten_e (cons s2 End)) by
+  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
+ apply compare_cont_Cmp; auto.
+ intros.
+ apply compare_end_Cmp; auto.
+Qed.
+
+Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
+ CompSpec eq lt s1 s2 (compare s1 s2).
+Proof.
+ intros.
+ destruct (compare_Cmp s1 s2); constructor.
+ rewrite eq_Leq; auto.
+ intros; exists s1, s2; repeat split; auto.
+ intros; exists s2, s1; repeat split; auto.
+Qed.
+
+
+(** * Equality test *)
+
+Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
+ equal s1 s2 = true <-> eq s1 s2.
+Proof.
+unfold equal; intros s1 s2 B1 B2.
+destruct (@compare_spec s1 s2 B1 B2) as [H|H|H];
+ split; intros H'; auto; try discriminate.
+rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
+rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
+Qed.
+
+End MakeRaw.
+
+
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we
+   need to encapsulate everything into a type of binary search trees.
+   They also happen to be well-balanced, but this has no influence
+   on the correctness of operations, so we won't state this here,
+   see [MSetFullAVL] if you need more than just the MSet interface.
+*)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+ Module Raw := MakeRaw I X.
+ Include Raw2Sets X Raw.
+End IntMake.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v
new file mode 100644
index 00000000..07c9955a
--- /dev/null
+++ b/theories/MSets/MSetDecide.v
@@ -0,0 +1,880 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(**************************************************************)
+(* MSetDecide.v                                               *)
+(*                                                            *)
+(* Author: Aaron Bohannon                                     *)
+(**************************************************************)
+
+(** This file implements a decision procedure for a certain
+    class of propositions involving finite sets.  *)
+
+Require Import Decidable DecidableTypeEx MSetFacts.
+
+(** First, a version for Weak Sets in functorial presentation *)
+
+Module WDecideOn (E : DecidableType)(Import M : WSetsOn E).
+ Module F := MSetFacts.WFactsOn E M.
+
+(** * Overview
+    This functor defines the tactic [fsetdec], which will
+    solve any valid goal of the form
+<<
+    forall s1 ... sn,
+    forall x1 ... xm,
+    P1 -> ... -> Pk -> P
+>>
+    where [P]'s are defined by the grammar:
+<<
+
+P ::=
+| Q
+| Empty F
+| Subset F F'
+| Equal F F'
+
+Q ::=
+| E.eq X X'
+| In X F
+| Q /\ Q'
+| Q \/ Q'
+| Q -> Q'
+| Q <-> Q'
+| ~ Q
+| True
+| False
+
+F ::=
+| S
+| empty
+| singleton X
+| add X F
+| remove X F
+| union F F'
+| inter F F'
+| diff F F'
+
+X ::= x1 | ... | xm
+S ::= s1 | ... | sn
+
+>>
+
+The tactic will also work on some goals that vary slightly from
+the above form:
+- The variables and hypotheses may be mixed in any order and may
+  have already been introduced into the context.  Moreover,
+  there may be additional, unrelated hypotheses mixed in (these
+  will be ignored).
+- A conjunction of hypotheses will be handled as easily as
+  separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff
+  [P1 -> P2 -> P] can be solved.
+- [fsetdec] should solve any goal if the MSet-related hypotheses
+  are contradictory.
+- [fsetdec] will first perform any necessary zeta and beta
+  reductions and will invoke [subst] to eliminate any Coq
+  equalities between finite sets or their elements.
+- If [E.eq] is convertible with Coq's equality, it will not
+  matter which one is used in the hypotheses or conclusion.
+- The tactic can solve goals where the finite sets or set
+  elements are expressed by Coq terms that are more complicated
+  than variables.  However, non-local definitions are not
+  expanded, and Coq equalities between non-variable terms are
+  not used.  For example, this goal will be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g (g x2)) ->
+    In x1 s1 ->
+    In (g (g x2)) (f s2)
+>>
+  This one will not be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g x2) ->
+    In x1 s1 ->
+    g x2 = g (g x2) ->
+    In (g (g x2)) (f s2)
+>>
+*)
+
+  (** * Facts and Tactics for Propositional Logic
+      These lemmas and tactics are in a module so that they do
+      not affect the namespace if you import the enclosing
+      module [Decide]. *)
+  Module MSetLogicalFacts.
+    Require Export Decidable.
+    Require Export Setoid.
+
+    (** ** Lemmas and Tactics About Decidable Propositions *)
+
+    (** ** Propositional Equivalences Involving Negation
+        These are all written with the unfolded form of
+        negation, since I am not sure if setoid rewriting will
+        always perform conversion. *)
+
+    (** ** Tactics for Negations *)
+
+    Tactic Notation "fold" "any" "not" :=
+      repeat (
+        match goal with
+        | H: context [?P -> False] |- _ =>
+          fold (~ P) in H
+        | |- context [?P -> False] =>
+          fold (~ P)
+        end).
+
+    (** [push not using db] will pushes all negations to the
+        leaves of propositions in the goal, using the lemmas in
+        [db] to assist in checking the decidability of the
+        propositions involved.  If [using db] is omitted, then
+        [core] will be used.  Additional versions are provided
+        to manipulate the hypotheses or the hypotheses and goal
+        together.
+
+        XXX: This tactic and the similar subsequent ones should
+        have been defined using [autorewrite]. However, dealing
+        with multiples rewrite sites and side-conditions is
+        done more cleverly with the following explicit
+        analysis of goals. *)
+
+    Ltac or_not_l_iff P Q tac :=
+      (rewrite (or_not_l_iff_1 P Q) by tac) ||
+      (rewrite (or_not_l_iff_2 P Q) by tac).
+
+    Ltac or_not_r_iff P Q tac :=
+      (rewrite (or_not_r_iff_1 P Q) by tac) ||
+      (rewrite (or_not_r_iff_2 P Q) by tac).
+
+    Ltac or_not_l_iff_in P Q H tac :=
+      (rewrite (or_not_l_iff_1 P Q) in H by tac) ||
+      (rewrite (or_not_l_iff_2 P Q) in H by tac).
+
+    Ltac or_not_r_iff_in P Q H tac :=
+      (rewrite (or_not_r_iff_1 P Q) in H by tac) ||
+      (rewrite (or_not_r_iff_2 P Q) in H by tac).
+
+    Tactic Notation "push" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+            rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q)
+        | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q)
+        | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" :=
+      push not using core.
+
+    Tactic Notation
+      "push" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H
+        | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H
+        | H: context [(?P -> ?Q) -> False] |- _ =>
+          rewrite (not_imp_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" "in" "*" "|-"  :=
+      push not in * |- using core.
+
+    Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
+      push not using db; push not in * |- using db.
+    Tactic Notation "push" "not" "in" "*" :=
+      push not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_push : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ ((R -> P) \/ (Q -> R))) ->
+      (~ (P /\ R)) ->
+      (~ (P -> R)) ->
+      True.
+    Proof.
+      intros. push not in *.
+       (* note that ~(R->P) remains (since R isnt decidable) *)
+      tauto.
+    Qed.
+
+    (** [pull not using db] will pull as many negations as
+        possible toward the top of the propositions in the goal,
+        using the lemmas in [db] to assist in checking the
+        decidability of the propositions involved.  If [using
+        db] is omitted, then [core] will be used.  Additional
+        versions are provided to manipulate the hypotheses or
+        the hypotheses and goal together. *)
+
+    Tactic Notation "pull" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+          rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [(?P -> False) /\ (?Q -> False)] =>
+          rewrite <- (not_or_iff P Q)
+        | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q)
+        | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec
+        | |- context [(?Q -> False) /\ ?P] =>
+          rewrite <- (not_imp_rev_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" :=
+      pull not using core.
+
+    Tactic Notation
+      "pull" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_or_iff P Q) in H
+        | H: context [?P -> ?Q -> False] |- _ =>
+          rewrite <- (not_and_iff P Q) in H
+        | H: context [?P /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_imp_iff P Q) in H by dec
+        | H: context [(?Q -> False) /\ ?P] |- _ =>
+          rewrite <- (not_imp_rev_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" "in" "*" "|-"  :=
+      pull not in * |- using core.
+
+    Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
+      pull not using db; pull not in * |- using db.
+    Tactic Notation "pull" "not" "in" "*" :=
+      pull not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_pull : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ (R -> P) /\ ~ (Q -> R)) ->
+      (~ P \/ ~ R) ->
+      (P /\ ~ R) ->
+      (~ R /\ P) ->
+      True.
+    Proof.
+      intros. pull not in *. tauto.
+    Qed.
+
+  End MSetLogicalFacts.
+  Import MSetLogicalFacts.
+
+  (** * Auxiliary Tactics
+      Again, these lemmas and tactics are in a module so that
+      they do not affect the namespace if you import the
+      enclosing module [Decide].  *)
+  Module MSetDecideAuxiliary.
+
+    (** ** Generic Tactics
+        We begin by defining a few generic, useful tactics. *)
+
+    (** remove logical hypothesis inter-dependencies (fix #2136). *)
+
+    Ltac no_logical_interdep :=
+      match goal with
+        | H : ?P |- _ =>
+          match type of P with
+            | Prop =>
+              match goal with H' : context [ H ] |- _ => clear dependent H' end
+            | _ => fail
+          end; no_logical_interdep
+        | _ => 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 ].
+
+    (** [prop P holds by t] succeeds (but does not modify the
+        goal or context) if the proposition [P] can be proved by
+        [t] in the current context.  Otherwise, the tactic
+        fails. *)
+    Tactic Notation "prop" constr(P) "holds" "by" tactic(t) :=
+      let H := fresh in
+      assert P as H by t;
+      clear H.
+
+    (** This tactic acts just like [assert ... by ...] but will
+        fail if the context already contains the proposition. *)
+    Tactic Notation "assert" "new" constr(e) "by" tactic(t) :=
+      match goal with
+      | H: e |- _ => fail 1
+      | _ => assert e by t
+      end.
+
+    (** [subst++] is similar to [subst] except that
+        - it never fails (as [subst] does on recursive
+          equations),
+        - it substitutes locally defined variable for their
+          definitions,
+        - it performs beta reductions everywhere, which may
+          arise after substituting a locally defined function
+          for its definition.
+        *)
+    Tactic Notation "subst" "++" :=
+      repeat (
+        match goal with
+        | x : _ |- _ => subst x
+        end);
+      cbv zeta beta in *.
+
+    (** [decompose records] calls [decompose record H] on every
+        relevant hypothesis [H]. *)
+    Tactic Notation "decompose" "records" :=
+      repeat (
+        match goal with
+        | H: _ |- _ => progress (decompose record H); clear H
+        end).
+
+    (** ** Discarding Irrelevant Hypotheses
+        We will want to clear the context of any
+        non-MSet-related hypotheses in order to increase the
+        speed of the tactic.  To do this, we will need to be
+        able to decide which are relevant.  We do this by making
+        a simple inductive definition classifying the
+        propositions of interest. *)
+
+    Inductive MSet_elt_Prop : Prop -> Prop :=
+    | eq_Prop : forall (S : Type) (x y : S),
+        MSet_elt_Prop (x = y)
+    | eq_elt_prop : forall x y,
+        MSet_elt_Prop (E.eq x y)
+    | In_elt_prop : forall x s,
+        MSet_elt_Prop (In x s)
+    | True_elt_prop :
+        MSet_elt_Prop True
+    | False_elt_prop :
+        MSet_elt_Prop False
+    | conj_elt_prop : forall P Q,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop Q ->
+        MSet_elt_Prop (P /\ Q)
+    | disj_elt_prop : forall P Q,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop Q ->
+        MSet_elt_Prop (P \/ Q)
+    | impl_elt_prop : forall P Q,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop Q ->
+        MSet_elt_Prop (P -> Q)
+    | not_elt_prop : forall P,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop (~ P).
+
+    Inductive MSet_Prop : Prop -> Prop :=
+    | elt_MSet_Prop : forall P,
+        MSet_elt_Prop P ->
+        MSet_Prop P
+    | Empty_MSet_Prop : forall s,
+        MSet_Prop (Empty s)
+    | Subset_MSet_Prop : forall s1 s2,
+        MSet_Prop (Subset s1 s2)
+    | Equal_MSet_Prop : forall s1 s2,
+        MSet_Prop (Equal s1 s2).
+
+    (** Here is the tactic that will throw away hypotheses that
+        are not useful (for the intended scope of the [fsetdec]
+        tactic). *)
+    Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop.
+    Ltac discard_nonMSet :=
+      decompose records;
+      repeat (
+        match goal with
+        | H : ?P |- _ =>
+          if prop (MSet_Prop P) holds by
+            (auto 100 with MSet_Prop)
+          then fail
+          else clear H
+        end).
+
+    (** ** Turning Set Operators into Propositional Connectives
+        The lemmas from [MSetFacts] will be used to break down
+        set operations into propositional formulas built over
+        the predicates [In] and [E.eq] applied only to
+        variables.  We are going to use them with [autorewrite].
+        *)
+
+    Hint Rewrite
+      F.empty_iff F.singleton_iff F.add_iff F.remove_iff
+      F.union_iff F.inter_iff F.diff_iff
+    : set_simpl.
+
+    (** ** Decidability of MSet Propositions *)
+
+    (** [In] is decidable. *)
+    Lemma dec_In : forall x s,
+      decidable (In x s).
+    Proof.
+      red; intros; generalize (F.mem_iff s x); case (mem x s); intuition.
+    Qed.
+
+    (** [E.eq] is decidable. *)
+    Lemma dec_eq : forall (x y : E.t),
+      decidable (E.eq x y).
+    Proof.
+      red; intros x y; destruct (E.eq_dec x y); auto.
+    Qed.
+
+    (** The hint database [MSet_decidability] will be given to
+        the [push_neg] tactic from the module [Negation]. *)
+    Hint Resolve dec_In dec_eq : MSet_decidability.
+
+    (** ** Normalizing Propositions About Equality
+        We have to deal with the fact that [E.eq] may be
+        convertible with Coq's equality.  Thus, we will find the
+        following tactics useful to replace one form with the
+        other everywhere. *)
+
+    (** The next tactic, [Logic_eq_to_E_eq], mentions the term
+        [E.t]; thus, we must ensure that [E.t] is used in favor
+        of any other convertible but syntactically distinct
+        term. *)
+    Ltac change_to_E_t :=
+      repeat (
+        match goal with
+        | H : ?T |- _ =>
+          progress (change T with E.t in H);
+          repeat (
+            match goal with
+            | J : _ |- _ => progress (change T with E.t in J)
+            | |- _ => progress (change T with E.t)
+            end )
+        | H : forall x : ?T, _ |- _ =>
+          progress (change T with E.t in H);
+          repeat (
+            match goal with
+            | J : _ |- _ => progress (change T with E.t in J)
+            | |- _ => progress (change T with E.t)
+            end )
+       end).
+
+    (** These two tactics take us from Coq's built-in equality
+        to [E.eq] (and vice versa) when possible. *)
+
+    Ltac Logic_eq_to_E_eq :=
+      repeat (
+        match goal with
+        | H: _ |- _ =>
+          progress (change (@Logic.eq E.t) with E.eq in H)
+        | |- _ =>
+          progress (change (@Logic.eq E.t) with E.eq)
+        end).
+
+    Ltac E_eq_to_Logic_eq :=
+      repeat (
+        match goal with
+        | H: _ |- _ =>
+          progress (change E.eq with (@Logic.eq E.t) in H)
+        | |- _ =>
+          progress (change E.eq with (@Logic.eq E.t))
+        end).
+
+    (** This tactic works like the built-in tactic [subst], but
+        at the level of set element equality (which may not be
+        the convertible with Coq's equality). *)
+    Ltac substMSet :=
+      repeat (
+        match goal with
+        | H: E.eq ?x ?y |- _ => rewrite H in *; clear H
+        end).
+
+    (** ** Considering Decidability of Base Propositions
+        This tactic adds assertions about the decidability of
+        [E.eq] and [In] to the context.  This is necessary for
+        the completeness of the [fsetdec] tactic.  However, in
+        order to minimize the cost of proof search, we should be
+        careful to not add more than we need.  Once negations
+        have been pushed to the leaves of the propositions, we
+        only need to worry about decidability for those base
+        propositions that appear in a negated form. *)
+    Ltac assert_decidability :=
+      (** We actually don't want these rules to fire if the
+          syntactic context in the patterns below is trivially
+          empty, but we'll just do some clean-up at the
+          afterward.  *)
+      repeat (
+        match goal with
+        | H: context [~ E.eq ?x ?y] |- _ =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | H: context [~ In ?x ?s] |- _ =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        | |- context [~ E.eq ?x ?y] =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | |- context [~ In ?x ?s] =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        end);
+      (** Now we eliminate the useless facts we added (because
+          they would likely be very harmful to performance). *)
+      repeat (
+        match goal with
+        | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H
+        end).
+
+    (** ** Handling [Empty], [Subset], and [Equal]
+        This tactic instantiates universally quantified
+        hypotheses (which arise from the unfolding of [Empty],
+        [Subset], and [Equal]) for each of the set element
+        expressions that is involved in some membership or
+        equality fact.  Then it throws away those hypotheses,
+        which should no longer be needed. *)
+    Ltac inst_MSet_hypotheses :=
+      repeat (
+        match goal with
+        | H : forall a : E.t, _,
+          _ : context [ In ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ In ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq _ ?x ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq _ ?x ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        end);
+      repeat (
+        match goal with
+        | H : forall a : E.t, _ |- _ =>
+          clear H
+        end).
+
+    (** ** The Core [fsetdec] Auxiliary Tactics *)
+
+    (** Here is the crux of the proof search.  Recursion through
+        [intuition]!  (This will terminate if I correctly
+        understand the behavior of [intuition].) *)
+    Ltac fsetdec_rec :=
+      try (match goal with
+      | H: E.eq ?x ?x -> False |- _ => destruct H
+      end);
+      (reflexivity ||
+      contradiction ||
+      (progress substMSet; intuition fsetdec_rec)).
+
+    (** If we add [unfold Empty, Subset, Equal in *; intros;] to
+        the beginning of this tactic, it will satisfy the same
+        specification as the [fsetdec] tactic; however, it will
+        be much slower than necessary without the pre-processing
+        done by the wrapper tactic [fsetdec]. *)
+    Ltac fsetdec_body :=
+      inst_MSet_hypotheses;
+      autorewrite with set_simpl in *;
+      push not in * using MSet_decidability;
+      substMSet;
+      assert_decidability;
+      auto using (@Equivalence_Reflexive _ _ E.eq_equiv);
+      (intuition fsetdec_rec) ||
+      fail 1
+        "because the goal is beyond the scope of this tactic".
+
+  End MSetDecideAuxiliary.
+  Import MSetDecideAuxiliary.
+
+  (** * The [fsetdec] Tactic
+      Here is the top-level tactic (the only one intended for
+      clients of this library).  It's specification is given at
+      the top of the file. *)
+  Ltac fsetdec :=
+    (** We first unfold any occurrences of [iff]. *)
+    unfold iff in *;
+    (** We fold occurrences of [not] because it is better for
+        [intros] to leave us with a goal of [~ P] than a goal of
+        [False]. *)
+    fold any not; intros;
+    (** We remove dependencies to logical hypothesis. This way,
+        later "clear" will work nicely (see bug #2136) *)
+    no_logical_interdep;
+    (** Now we decompose conjunctions, which will allow the
+        [discard_nonMSet] and [assert_decidability] tactics to
+        do a much better job. *)
+    decompose records;
+    discard_nonMSet;
+    (** We unfold these defined propositions on finite sets.  If
+        our goal was one of them, then have one more item to
+        introduce now. *)
+    unfold Empty, Subset, Equal in *; intros;
+    (** We now want to get rid of all uses of [=] in favor of
+        [E.eq].  However, the best way to eliminate a [=] is in
+        the context is with [subst], so we will try that first.
+        In fact, we may as well convert uses of [E.eq] into [=]
+        when possible before we do [subst] so that we can even
+        more mileage out of it.  Then we will convert all
+        remaining uses of [=] back to [E.eq] when possible.  We
+        use [change_to_E_t] to ensure that we have a canonical
+        name for set elements, so that [Logic_eq_to_E_eq] will
+        work properly.  *)
+    change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq;
+    (** The next optimization is to swap a negated goal with a
+        negated hypothesis when possible.  Any swap will improve
+        performance by eliminating the total number of
+        negations, but we will get the maximum benefit if we
+        swap the goal with a hypotheses mentioning the same set
+        element, so we try that first.  If we reach the fourth
+        branch below, we attempt any swap.  However, to maintain
+        completeness of this tactic, we can only perform such a
+        swap with a decidable proposition; hence, we first test
+        whether the hypothesis is an [MSet_elt_Prop], noting
+        that any [MSet_elt_Prop] is decidable. *)
+    pull not using MSet_decidability;
+    unfold not in *;
+    match goal with
+    | H: (In ?x ?r) -> False |- (In ?x ?s) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False =>
+      contradict H; fsetdec_body
+    | 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
+        (auto 100 with MSet_Prop)
+      then (contradict H; fsetdec_body)
+      else fsetdec_body
+    | |- _ =>
+      fsetdec_body
+    end.
+
+  (** * Examples *)
+
+  Module MSetDecideTestCases.
+
+    Lemma test_eq_trans_1 : forall x y z s,
+      E.eq x y ->
+      ~ ~ E.eq z y ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_trans_2 : forall x y z r s,
+      In x (singleton y) ->
+      ~ In z r ->
+      ~ ~ In z (add y r) ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_1 : forall w x y z s,
+      E.eq x w ->
+      ~ ~ E.eq x y ->
+      ~ E.eq y z ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s,
+      In x (singleton w) ->
+      ~ In x r1 ->
+      In x (add y r1) ->
+      In y r2 ->
+      In y (remove z r2) ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_In_singleton : forall x,
+      In x (singleton x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_add_In : forall x y s,
+      In x (add y s) ->
+      ~ E.eq x y ->
+      In x s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_Subset_add_remove : forall x s,
+      s [<=] (add x (remove x s)).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_disjunction : forall w x y z,
+      In w (add x (add y (singleton z))) ->
+      E.eq w x \/ E.eq w y \/ E.eq w z.
+    Proof. fsetdec. Qed.
+
+    Lemma test_not_In_disj : forall x y s1 s2 s3 s4,
+      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
+      ~ (In x s1 \/ In x s4 \/ E.eq y x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_not_In_conj : forall x y s1 s2 s3 s4,
+      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
+      ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x.
+    Proof. fsetdec. Qed.
+
+    Lemma test_iff_conj : forall a x s s',
+    (In a s' <-> E.eq x a \/ In a s) ->
+    (In a s' <-> In a (add x s)).
+    Proof. fsetdec. Qed.
+
+    Lemma test_set_ops_1 : forall x q r s,
+      (singleton x) [<=] s ->
+      Empty (union q r) ->
+      Empty (inter (diff s q) (diff s r)) ->
+      ~ In x s.
+    Proof. fsetdec. Qed.
+
+    Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4,
+      Empty s1 ->
+      In x2 (add x1 s1) ->
+      In x3 s2 ->
+      ~ In x3 (remove x2 s2) ->
+      ~ In x4 s3 ->
+      In x4 (add x3 s3) ->
+      In x1 s4 ->
+      Subset (add x4 s4) s4.
+    Proof. fsetdec. Qed.
+
+    Lemma test_too_complex : forall x y z r s,
+      E.eq x y ->
+      (In x (singleton y) -> r [<=] s) ->
+      In z r ->
+      In z s.
+    Proof.
+      (** [fsetdec] is not intended to solve this directly. *)
+      intros until s; intros Heq H Hr; lapply H; fsetdec.
+    Qed.
+
+    Lemma function_test_1 :
+      forall (f : t -> t),
+      forall (g : elt -> elt),
+      forall (s1 s2 : t),
+      forall (x1 x2 : elt),
+      Equal s1 (f s2) ->
+      E.eq x1 (g (g x2)) ->
+      In x1 s1 ->
+      In (g (g x2)) (f s2).
+    Proof. fsetdec. Qed.
+
+    Lemma function_test_2 :
+      forall (f : t -> t),
+      forall (g : elt -> elt),
+      forall (s1 s2 : t),
+      forall (x1 x2 : elt),
+      Equal s1 (f s2) ->
+      E.eq x1 (g x2) ->
+      In x1 s1 ->
+      g x2 = g (g x2) ->
+      In (g (g x2)) (f s2).
+    Proof.
+      (** [fsetdec] is not intended to solve this directly. *)
+      intros until 3. intros g_eq. rewrite <- g_eq. fsetdec.
+    Qed.
+
+    Lemma test_baydemir :
+      forall (f : t -> t),
+      forall (s : t),
+      forall (x y : elt),
+      In x (add y (f s)) ->
+      ~ E.eq x y ->
+      In x (f s).
+    Proof.
+      fsetdec.
+    Qed.
+
+  End MSetDecideTestCases.
+
+End WDecideOn.
+
+Require Import MSetInterface.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [Decide] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WDecide]. *)
+
+Module WDecide (M:WSets) := WDecideOn M.E M.
+Module Decide := WDecide.
diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v
new file mode 100644
index 00000000..fe6c3c79
--- /dev/null
+++ b/theories/MSets/MSetEqProperties.v
@@ -0,0 +1,936 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite sets library *)
+
+(** This module proves many properties of finite sets that
+    are consequences of the axiomatization in [FsetInterface]
+    Contrary to the functor in [FsetProperties] it uses
+    sets operations instead of predicates over sets, i.e.
+    [mem x s=true] instead of [In x s],
+    [equal s s'=true] instead of [Equal s s'], etc. *)
+
+Require Import MSetProperties Zerob Sumbool Omega DecidableTypeEx.
+
+Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E).
+Module Import MP := WPropertiesOn E M.
+Import FM Dec.F.
+Import M.
+
+Definition Add := MP.Add.
+
+Section BasicProperties.
+
+(** Some old specifications written with boolean equalities. *)
+
+Variable s s' s'': t.
+Variable x y z : elt.
+
+Lemma mem_eq:
+  E.eq x y -> mem x s=mem y s.
+Proof.
+intro H; rewrite H; auto.
+Qed.
+
+Lemma equal_mem_1:
+  (forall a, mem a s=mem a s') -> equal s s'=true.
+Proof.
+intros; apply equal_1; unfold Equal; intros.
+do 2 rewrite mem_iff; rewrite H; tauto.
+Qed.
+
+Lemma equal_mem_2:
+  equal s s'=true -> forall a, mem a s=mem a s'.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma subset_mem_1:
+  (forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
+Proof.
+intros; apply subset_1; unfold Subset; intros a.
+do 2 rewrite mem_iff; auto.
+Qed.
+
+Lemma subset_mem_2:
+  subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
+Proof.
+intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
+Qed.
+
+Lemma empty_mem: mem x empty=false.
+Proof.
+rewrite <- not_mem_iff; auto with set.
+Qed.
+
+Lemma is_empty_equal_empty: is_empty s = equal s empty.
+Proof.
+apply bool_1; split; intros.
+auto with set.
+rewrite <- is_empty_iff; auto with set.
+Qed.
+
+Lemma choose_mem_1: choose s=Some x -> mem x s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma choose_mem_2: choose s=None -> is_empty s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_mem_1: mem x (add x s)=true.
+Proof.
+auto with set relations.
+Qed.
+
+Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
+Proof.
+apply add_neq_b.
+Qed.
+
+Lemma remove_mem_1: mem x (remove x s)=false.
+Proof.
+rewrite <- not_mem_iff; auto with set relations.
+Qed.
+
+Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
+Proof.
+apply remove_neq_b.
+Qed.
+
+Lemma singleton_equal_add:
+  equal (singleton x) (add x empty)=true.
+Proof.
+rewrite (singleton_equal_add x); auto with set.
+Qed.
+
+Lemma union_mem:
+  mem x (union s s')=mem x s || mem x s'.
+Proof.
+apply union_b.
+Qed.
+
+Lemma inter_mem:
+  mem x (inter s s')=mem x s && mem x s'.
+Proof.
+apply inter_b.
+Qed.
+
+Lemma diff_mem:
+  mem x (diff s s')=mem x s && negb (mem x s').
+Proof.
+apply diff_b.
+Qed.
+
+(** properties of [mem] *)
+
+Lemma mem_3 : ~In x s -> mem x s=false.
+Proof.
+intros; rewrite <- not_mem_iff; auto.
+Qed.
+
+Lemma mem_4 : mem x s=false -> ~In x s.
+Proof.
+intros; rewrite not_mem_iff; auto.
+Qed.
+
+(** Properties of [equal] *)
+
+Lemma equal_refl: equal s s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma equal_sym: equal s s'=equal s' s.
+Proof.
+intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
+Qed.
+
+Lemma equal_trans:
+ equal s s'=true -> equal s' s''=true -> equal s s''=true.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma equal_equal:
+ equal s s'=true -> equal s s''=equal s' s''.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma equal_cardinal:
+ equal s s'=true -> cardinal s=cardinal s'.
+Proof.
+auto with set.
+Qed.
+
+(* Properties of [subset] *)
+
+Lemma subset_refl: subset s s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma subset_antisym:
+ subset s s'=true -> subset s' s=true -> equal s s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma subset_trans:
+ subset s s'=true -> subset s' s''=true -> subset s s''=true.
+Proof.
+do 3 rewrite <- subset_iff; intros.
+apply subset_trans with s'; auto.
+Qed.
+
+Lemma subset_equal:
+ equal s s'=true -> subset s s'=true.
+Proof.
+auto with set.
+Qed.
+
+(** Properties of [choose] *)
+
+Lemma choose_mem_3:
+ is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
+Proof.
+intros.
+generalize (@choose_1 s) (@choose_2 s).
+destruct (choose s);intros.
+exists e;auto with set.
+generalize (H1 (refl_equal None)); clear H1.
+intros; rewrite (is_empty_1 H1) in H; discriminate.
+Qed.
+
+Lemma choose_mem_4: choose empty=None.
+Proof.
+generalize (@choose_1 empty).
+case (@choose empty);intros;auto.
+elim (@empty_1 e); auto.
+Qed.
+
+(** Properties of [add] *)
+
+Lemma add_mem_3:
+ mem y s=true -> mem y (add x s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_equal:
+ mem x s=true -> equal (add x s) s=true.
+Proof.
+auto with set.
+Qed.
+
+(** Properties of [remove] *)
+
+Lemma remove_mem_3:
+ mem y (remove x s)=true -> mem y s=true.
+Proof.
+rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto.
+Qed.
+
+Lemma remove_equal:
+ mem x s=false -> equal (remove x s) s=true.
+Proof.
+intros; apply equal_1; apply remove_equal.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma add_remove:
+ mem x s=true -> equal (add x (remove x s)) s=true.
+Proof.
+intros; apply equal_1; apply add_remove; auto with set.
+Qed.
+
+Lemma remove_add:
+ mem x s=false -> equal (remove x (add x s)) s=true.
+Proof.
+intros; apply equal_1; apply remove_add; auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+(** Properties of [is_empty] *)
+
+Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
+Proof.
+intros; apply bool_1; split; intros.
+rewrite MP.cardinal_1; simpl; auto with set.
+assert (cardinal s = 0) by (apply zerob_true_elim; auto).
+auto with set.
+Qed.
+
+(** Properties of [singleton] *)
+
+Lemma singleton_mem_1: mem x (singleton x)=true.
+Proof.
+auto with set relations.
+Qed.
+
+Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false.
+Proof.
+intros; rewrite singleton_b.
+unfold eqb; destruct (E.eq_dec x y); intuition.
+Qed.
+
+Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
+Proof.
+intros; apply singleton_1; auto with set.
+Qed.
+
+(** Properties of [union] *)
+
+Lemma union_sym:
+ equal (union s s') (union s' s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_equal:
+ subset s s'=true -> equal (union s s') s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_equal_1:
+ equal s s'=true-> equal (union s s'') (union s' s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_equal_2:
+ equal s' s''=true-> equal (union s s') (union s s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_assoc:
+ equal (union (union s s') s'') (union s (union s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_union_singleton:
+ equal (add x s) (union (singleton x) s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_add:
+ equal (union (add x s) s') (add x (union s s'))=true.
+Proof.
+auto with set.
+Qed.
+
+(* caracterisation of [union] via [subset] *)
+
+Lemma union_subset_1: subset s (union s s')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_2: subset s' (union s s')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_3:
+ subset s s''=true -> subset s' s''=true ->
+  subset (union s s') s''=true.
+Proof.
+intros; apply subset_1; apply union_subset_3; auto with set.
+Qed.
+
+(** Properties of [inter] *)
+
+Lemma inter_sym: equal (inter s s') (inter s' s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_equal:
+ subset s s'=true -> equal (inter s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_equal_1:
+ equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_equal_2:
+ equal s' s''=true -> equal (inter s s') (inter s s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_assoc:
+ equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_inter_1:
+ equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_inter_2:
+ equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_add_1: mem x s'=true ->
+ equal (inter (add x s) s') (add x (inter s s'))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_add_2: mem x s'=false ->
+ equal (inter (add x s) s') (inter s s')=true.
+Proof.
+intros; apply equal_1; apply inter_add_2.
+rewrite not_mem_iff; auto.
+Qed.
+
+(* caracterisation of [union] via [subset] *)
+
+Lemma inter_subset_1: subset (inter s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_2: subset (inter s s') s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_3:
+ subset s'' s=true -> subset s'' s'=true ->
+  subset s'' (inter s s')=true.
+Proof.
+intros; apply subset_1; apply inter_subset_3; auto with set.
+Qed.
+
+(** Properties of [diff] *)
+
+Lemma diff_subset: subset (diff s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_subset_equal:
+ subset s s'=true -> equal (diff s s') empty=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma remove_inter_singleton:
+ equal (remove x s) (diff s (singleton x))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_inter_empty:
+ equal (inter (diff s s') (inter s s')) empty=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_inter_all:
+ equal (union (diff s s') (inter s s')) s=true.
+Proof.
+auto with set.
+Qed.
+
+End BasicProperties.
+
+Hint Immediate empty_mem is_empty_equal_empty add_mem_1
+   remove_mem_1 singleton_equal_add union_mem inter_mem
+   diff_mem equal_sym add_remove remove_add : set.
+Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
+   choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal
+   subset_refl subset_equal subset_antisym
+   add_mem_3 add_equal remove_mem_3 remove_equal : set.
+
+
+(** General recursion principle *)
+
+Lemma set_rec:  forall (P:t->Type),
+ (forall s s', equal s s'=true -> P s -> P s') ->
+ (forall s x, mem x s=false -> P s -> P (add x s)) ->
+ P empty -> forall s, P s.
+Proof.
+intros.
+apply set_induction; auto; intros.
+apply X with empty; auto with set.
+apply X with (add x s0); auto with set.
+apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto.
+apply X0; auto with set; apply mem_3; auto.
+Qed.
+
+(** Properties of [fold] *)
+
+Lemma exclusive_set : forall s s' x,
+ ~(In x s/\In x s') <-> mem x s && mem x s'=false.
+Proof.
+intros; do 2 rewrite mem_iff.
+destruct (mem x s); destruct (mem x s'); intuition.
+Qed.
+
+Section Fold.
+Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f).
+Variables (i:A).
+Variables (s s':t)(x:elt).
+
+Lemma fold_empty: (fold f empty i) = i.
+Proof.
+apply fold_empty; auto.
+Qed.
+
+Lemma fold_equal:
+ equal s s'=true -> eqA (fold f s i) (fold f s' i).
+Proof.
+intros; apply fold_equal with (eqA:=eqA); auto with set.
+Qed.
+
+Lemma fold_add:
+ mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
+Proof.
+intros; apply fold_add with (eqA:=eqA); auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma add_fold:
+  mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
+Proof.
+intros; apply add_fold with (eqA:=eqA); auto with set.
+Qed.
+
+Lemma remove_fold_1:
+ mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
+Proof.
+intros; apply remove_fold_1 with (eqA:=eqA); auto with set.
+Qed.
+
+Lemma remove_fold_2:
+ mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
+Proof.
+intros; apply remove_fold_2 with (eqA:=eqA); auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma fold_union:
+ (forall x, mem x s && mem x s'=false) ->
+ eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+Proof.
+intros; apply fold_union with (eqA:=eqA); auto.
+intros; rewrite exclusive_set; auto.
+Qed.
+
+End Fold.
+
+(** Properties of [cardinal] *)
+
+Lemma add_cardinal_1:
+ forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_cardinal_2:
+ forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
+Proof.
+intros; apply add_cardinal_2; auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma remove_cardinal_1:
+ forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
+Proof.
+intros; apply remove_cardinal_1; auto with set.
+Qed.
+
+Lemma remove_cardinal_2:
+ forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
+Proof.
+intros; apply Equal_cardinal; apply equal_2; auto with set.
+Qed.
+
+Lemma union_cardinal:
+ forall s s', (forall x, mem x s && mem x s'=false) ->
+ cardinal (union s s')=cardinal s+cardinal s'.
+Proof.
+intros; apply union_cardinal; auto; intros.
+rewrite exclusive_set; auto.
+Qed.
+
+Lemma subset_cardinal:
+ forall s s', subset s s'=true -> cardinal s<=cardinal s'.
+Proof.
+intros; apply subset_cardinal; auto with set.
+Qed.
+
+Section Bool.
+
+(** Properties of [filter] *)
+
+Variable f:elt->bool.
+Variable Comp: Proper (E.eq==>Logic.eq) f.
+
+Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)).
+Proof.
+repeat red; intros; f_equal; auto.
+Qed.
+
+Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x.
+Proof.
+intros; apply filter_b; auto.
+Qed.
+
+Lemma for_all_filter:
+ forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
+Proof.
+intros; apply bool_1; split; intros.
+apply is_empty_1.
+unfold Empty; intros.
+rewrite filter_iff; auto.
+red; destruct 1.
+rewrite <- (@for_all_iff s f) in H; auto.
+rewrite (H a H0) in H1; discriminate.
+apply for_all_1; auto; red; intros.
+revert H; rewrite <- is_empty_iff.
+unfold Empty; intro H; generalize (H x); clear H.
+rewrite filter_iff; auto.
+destruct (f x); auto.
+Qed.
+
+Lemma exists_filter :
+ forall s, exists_ f s=negb (is_empty (filter f s)).
+Proof.
+intros; apply bool_1; split; intros.
+destruct (exists_2 Comp H) as (a,(Ha1,Ha2)).
+apply bool_6.
+red; intros; apply (@is_empty_2 _ H0 a); auto with set.
+generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)).
+destruct (choose (filter f s)).
+intros H0 _; apply exists_1; auto.
+exists e; generalize (H0 e); rewrite filter_iff; auto.
+intros _ H0.
+rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
+Qed.
+
+Lemma partition_filter_1:
+ forall s, equal (fst (partition f s)) (filter f s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma partition_filter_2:
+ forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma filter_add_1 : forall s x, f x = true ->
+ filter f (add x s) [=] add x (filter f s).
+Proof.
+red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
+intuition.
+rewrite <- H; apply Comp; auto with relations.
+Qed.
+
+Lemma filter_add_2 : forall s x, f x = false ->
+ filter f (add x s) [=] filter f s.
+Proof.
+red; intros; do 2 (rewrite filter_iff; auto); set_iff.
+intuition.
+assert (f x = f a) by (apply Comp; auto).
+rewrite H in H1; rewrite H2 in H1; discriminate.
+Qed.
+
+Lemma add_filter_1 : forall s s' x,
+ f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
+Proof.
+unfold Add, MP.Add; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+intuition.
+setoid_replace y with x; auto with relations.
+Qed.
+
+Lemma add_filter_2 : forall s s' x,
+ f x=false -> (Add x s s') -> filter f s [=] filter f s'.
+Proof.
+unfold Add, MP.Add, Equal; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+intuition.
+setoid_replace x with a in H; auto. congruence.
+Qed.
+
+Lemma union_filter: forall f g,
+  Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
+  forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
+Proof.
+clear Comp' Comp f.
+intros.
+assert (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))).
+  repeat red; intros.
+  rewrite (H x y H1);  rewrite (H0 x y H1); auto.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
+assert (f a || g a = true <-> f a = true \/ g a = true).
+  split; auto with bool.
+  intro H3; destruct (orb_prop _ _ H3); auto.
+tauto.
+Qed.
+
+Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
+Proof.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
+(** Properties of [for_all] *)
+
+Lemma for_all_mem_1: forall s,
+ (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
+Proof.
+intros.
+rewrite for_all_filter; auto.
+rewrite is_empty_equal_empty.
+apply equal_mem_1;intros.
+rewrite filter_b; auto.
+rewrite empty_mem.
+generalize (H a); case (mem a s);intros;auto.
+rewrite H0;auto.
+Qed.
+
+Lemma for_all_mem_2: forall s,
+ (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true.
+Proof.
+intros.
+rewrite for_all_filter in H; auto.
+rewrite is_empty_equal_empty in H.
+generalize (equal_mem_2 _ _ H x).
+rewrite filter_b; auto.
+rewrite empty_mem.
+rewrite H0; simpl;intros.
+rewrite <- negb_false_iff; auto.
+Qed.
+
+Lemma for_all_mem_3:
+ forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
+Proof.
+intros.
+apply (bool_eq_ind (for_all f s));intros;auto.
+rewrite for_all_filter in H1; auto.
+rewrite is_empty_equal_empty in H1.
+generalize (equal_mem_2 _ _ H1 x).
+rewrite filter_b; auto.
+rewrite empty_mem.
+rewrite H.
+rewrite H0.
+simpl;auto.
+Qed.
+
+Lemma for_all_mem_4:
+ forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
+Proof.
+intros.
+rewrite for_all_filter in H; auto.
+destruct (choose_mem_3 _ H) as (x,(H0,H1));intros.
+exists x.
+rewrite filter_b in H1; auto.
+elim (andb_prop _ _ H1).
+split;auto.
+rewrite <- negb_true_iff; auto.
+Qed.
+
+(** Properties of [exists] *)
+
+Lemma for_all_exists:
+ forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
+Proof.
+intros.
+rewrite for_all_b; auto.
+rewrite exists_b; auto.
+induction (elements s); simpl; auto.
+destruct (f a); simpl; auto.
+Qed.
+
+End Bool.
+Section Bool'.
+
+Variable f:elt->bool.
+Variable Comp: Proper (E.eq==>Logic.eq) f.
+
+Let Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)).
+Proof.
+repeat red; intros; f_equal; auto.
+Qed.
+
+Lemma exists_mem_1:
+ forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+rewrite for_all_mem_1;auto with bool.
+intros;generalize (H x H0);intros.
+rewrite negb_true_iff; auto.
+Qed.
+
+Lemma exists_mem_2:
+ forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false.
+Proof.
+intros.
+rewrite for_all_exists in H; auto.
+rewrite negb_false_iff in H.
+rewrite <- negb_true_iff.
+apply for_all_mem_2 with (2:=H); auto.
+Qed.
+
+Lemma exists_mem_3:
+ forall s x, mem x s=true -> f x=true -> exists_ f s=true.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+rewrite negb_true_iff.
+apply for_all_mem_3 with x;auto.
+rewrite negb_false_iff; auto.
+Qed.
+
+Lemma exists_mem_4:
+ forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
+Proof.
+intros.
+rewrite for_all_exists in H; auto.
+rewrite negb_true_iff in H.
+elim (@for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto.
+elim p;intros.
+exists x;split;auto.
+rewrite <-negb_false_iff; auto.
+Qed.
+
+End Bool'.
+
+Section Sum.
+
+(** Adding a valuation function on all elements of a set. *)
+
+Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0.
+Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)).
+Notation transposeL := (transpose Logic.eq).
+
+Lemma sum_plus :
+  forall f g,
+  Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
+    forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
+Proof.
+unfold sum.
+intros f g Hf Hg.
+assert (fc : compat_opL (fun x:elt =>plus (f x))) by
+ (repeat red; intros; rewrite Hf; auto).
+assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; omega).
+assert (gc : compat_opL (fun x:elt => plus (g x))) by
+ (repeat red; intros; rewrite Hg; auto).
+assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; omega).
+assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by
+  (repeat red; intros; rewrite Hf,Hg; auto).
+assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; omega).
+intros s;pattern s; apply set_rec.
+intros.
+rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H).
+rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H).
+rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto.
+intros; do 3 (rewrite fold_add; auto with *).
+do 3 rewrite fold_empty;auto.
+Qed.
+
+Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f ->
+  forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
+Proof.
+unfold sum; intros f Hf.
+assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
+assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by
+ (repeat red; intros; rewrite Hf; auto).
+assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by
+ (red; intros; omega).
+intros s;pattern s; apply set_rec.
+intros.
+change elt with E.t.
+rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
+apply equal_2 in H; rewrite <- H, <-H0; auto.
+intros; rewrite (fold_add _ _ st _ cc ct); auto.
+generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) .
+assert (~ In x (filter f s0)).
+ intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
+case (f x); simpl; intros.
+rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto.
+rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto.
+intros; rewrite fold_empty;auto.
+rewrite MP.cardinal_1; auto.
+unfold Empty; intros.
+rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
+Lemma fold_compat :
+  forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+  (f g:elt->A->A),
+  Proper (E.eq==>eqA==>eqA) f -> transpose eqA f ->
+  Proper (E.eq==>eqA==>eqA) g -> transpose eqA g ->
+  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) ->
+  (eqA (fold f s i) (fold g s i)).
+Proof.
+intros A eqA st f g fc ft gc gt i.
+intro s; pattern s; apply set_rec; intros.
+transitivity (fold f s0 i).
+apply fold_equal with (eqA:=eqA); auto.
+rewrite equal_sym; auto.
+transitivity (fold g s0 i).
+apply H0; intros; apply H1; auto with set.
+elim  (equal_2 H x); auto with set; intros.
+apply fold_equal with (eqA:=eqA); auto with set.
+transitivity (f x (fold f s0 i)).
+apply fold_add with (eqA:=eqA); auto with set.
+transitivity (g x (fold f s0 i)); auto with set relations.
+transitivity (g x (fold g s0 i)); auto with set relations.
+apply gc; auto with set relations.
+symmetry; apply fold_add with (eqA:=eqA); auto.
+do 2 rewrite fold_empty; reflexivity.
+Qed.
+
+Lemma sum_compat :
+  forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
+  forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
+intros.
+unfold sum; apply (@fold_compat _ (@Logic.eq nat));
+ repeat red; auto with *.
+Qed.
+
+End Sum.
+
+End WEqPropertiesOn.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [EqProperties] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WEqProperties]. *)
+
+Module WEqProperties (M:WSets) := WEqPropertiesOn M.E M.
+Module EqProperties := WEqProperties.
diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v
new file mode 100644
index 00000000..6d38b696
--- /dev/null
+++ b/theories/MSets/MSetFacts.v
@@ -0,0 +1,528 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional facts from [MSetInterface.S]. These
+  facts are mainly the specifications of [MSetInterface.S] written using
+  different styles: equivalence and boolean equalities.
+  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
+*)
+
+Require Import DecidableTypeEx.
+Require Export MSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** First, a functor for Weak Sets in functorial version. *)
+
+Module WFactsOn (Import E : DecidableType)(Import M : WSetsOn E).
+
+Notation eq_dec := E.eq_dec.
+Definition eqb x y := if eq_dec x y then true else false.
+
+(** * Specifications written using implications :
+      this used to be the default interface. *)
+
+Section ImplSpec.
+Variable s s' : t.
+Variable x y : elt.
+
+Lemma In_1 : E.eq x y -> In x s -> In y s.
+Proof. intros E; rewrite E; auto. Qed.
+
+Lemma mem_1 : In x s -> mem x s = true.
+Proof. intros; apply <- mem_spec; auto. Qed.
+Lemma mem_2 : mem x s = true -> In x s.
+Proof. intros; apply -> mem_spec; auto. Qed.
+
+Lemma equal_1 : Equal s s' -> equal s s' = true.
+Proof. intros; apply <- equal_spec; auto. Qed.
+Lemma equal_2 : equal s s' = true -> Equal s s'.
+Proof. intros; apply -> equal_spec; auto. Qed.
+
+Lemma subset_1 : Subset s s' -> subset s s' = true.
+Proof. intros; apply <- subset_spec; auto. Qed.
+Lemma subset_2 : subset s s' = true -> Subset s s'.
+Proof. intros; apply -> subset_spec; auto. Qed.
+
+Lemma is_empty_1 : Empty s -> is_empty s = true.
+Proof. intros; apply <- is_empty_spec; auto. Qed.
+Lemma is_empty_2 : is_empty s = true -> Empty s.
+Proof. intros; apply -> is_empty_spec; auto. Qed.
+
+Lemma add_1 : E.eq x y -> In y (add x s).
+Proof. intros; apply <- add_spec. auto with relations. Qed.
+Lemma add_2 : In y s -> In y (add x s).
+Proof. intros; apply <- add_spec; auto. Qed.
+Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
+Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed.
+
+Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+Proof. intros; rewrite remove_spec; intuition. Qed.
+Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+Proof. intros; apply <- remove_spec; auto with relations. Qed.
+Lemma remove_3 : In y (remove x s) -> In y s.
+Proof. rewrite remove_spec; intuition. Qed.
+
+Lemma singleton_1 : In y (singleton x) -> E.eq x y.
+Proof. rewrite singleton_spec; auto with relations. Qed.
+Lemma singleton_2 : E.eq x y -> In y (singleton x).
+Proof. rewrite singleton_spec; auto with relations. Qed.
+
+Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+Proof. rewrite union_spec; auto. Qed.
+Lemma union_2 : In x s -> In x (union s s').
+Proof. rewrite union_spec; auto. Qed.
+Lemma union_3 : In x s' -> In x (union s s').
+Proof. rewrite union_spec; auto. Qed.
+
+Lemma inter_1 : In x (inter s s') -> In x s.
+Proof. rewrite inter_spec; intuition. Qed.
+Lemma inter_2 : In x (inter s s') -> In x s'.
+Proof. rewrite inter_spec; intuition. Qed.
+Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+Proof. rewrite inter_spec; intuition. Qed.
+
+Lemma diff_1 : In x (diff s s') -> In x s.
+Proof. rewrite diff_spec; intuition. Qed.
+Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+Proof. rewrite diff_spec; intuition. Qed.
+Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+Proof. rewrite diff_spec; auto. Qed.
+
+Variable f : elt -> bool.
+Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+Lemma filter_1 : compatb f -> In x (filter f s) -> In x s.
+Proof. intros P; rewrite filter_spec; intuition. Qed.
+Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true.
+Proof. intros P; rewrite filter_spec; intuition. Qed.
+Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s).
+Proof. intros P; rewrite filter_spec; intuition. Qed.
+
+Lemma for_all_1 : compatb f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+Proof. intros; apply <- for_all_spec; auto. Qed.
+Lemma for_all_2 : compatb f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+Proof. intros; apply -> for_all_spec; auto. Qed.
+
+Lemma exists_1 : compatb f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+Proof. intros; apply <- exists_spec; auto. Qed.
+
+Lemma exists_2 : compatb f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+Proof. intros; apply -> exists_spec; auto. Qed.
+
+Lemma elements_1 : In x s -> InA E.eq x (elements s).
+Proof. intros; apply <- elements_spec1; auto. Qed.
+Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+Proof. intros; apply -> elements_spec1; auto. Qed.
+
+End ImplSpec.
+
+Notation empty_1 := empty_spec (only parsing).
+Notation fold_1 := fold_spec (only parsing).
+Notation cardinal_1 := cardinal_spec (only parsing).
+Notation partition_1 := partition_spec1 (only parsing).
+Notation partition_2 := partition_spec2 (only parsing).
+Notation choose_1 := choose_spec1 (only parsing).
+Notation choose_2 := choose_spec2 (only parsing).
+Notation elements_3w := elements_spec2w (only parsing).
+
+Hint Resolve mem_1 equal_1 subset_1 empty_1
+    is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
+    remove_2 singleton_2 union_1 union_2 union_3
+    inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
+    partition_1 partition_2 elements_1 elements_3w
+    : set.
+Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
+    remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
+    filter_1 filter_2 for_all_2 exists_2 elements_2
+    : set.
+
+
+(** * Specifications written using equivalences :
+      this is now provided by the default interface. *)
+
+Section IffSpec.
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
+Proof.
+intros E; rewrite E; intuition.
+Qed.
+
+Lemma mem_iff : In x s <-> mem x s = true.
+Proof. apply iff_sym, mem_spec. Qed.
+
+Lemma not_mem_iff : ~In x s <-> mem x s = false.
+Proof.
+rewrite <-mem_spec; destruct (mem x s); intuition.
+Qed.
+
+Lemma equal_iff : s[=]s' <-> equal s s' = true.
+Proof. apply iff_sym, equal_spec. Qed.
+
+Lemma subset_iff : s[<=]s' <-> subset s s' = true.
+Proof. apply iff_sym, subset_spec. Qed.
+
+Lemma empty_iff : In x empty <-> False.
+Proof. intuition; apply (empty_spec H). Qed.
+
+Lemma is_empty_iff : Empty s <-> is_empty s = true.
+Proof. apply iff_sym, is_empty_spec. Qed.
+
+Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
+Proof. rewrite singleton_spec; intuition. Qed.
+
+Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
+Proof. rewrite add_spec; intuition. Qed.
+
+Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
+Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed.
+
+Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
+Proof. rewrite remove_spec; intuition. Qed.
+
+Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
+Proof. rewrite remove_spec; intuition. Qed.
+
+Variable f : elt -> bool.
+
+Lemma for_all_iff : Proper (E.eq==>Logic.eq) f ->
+  (For_all (fun x => f x = true) s <-> for_all f s = true).
+Proof. intros; apply iff_sym, for_all_spec; auto. Qed.
+
+Lemma exists_iff : Proper (E.eq==>Logic.eq) f ->
+  (Exists (fun x => f x = true) s <-> exists_ f s = true).
+Proof. intros; apply iff_sym, exists_spec; auto. Qed.
+
+Lemma elements_iff : In x s <-> InA E.eq x (elements s).
+Proof. apply iff_sym, elements_spec1. Qed.
+
+End IffSpec.
+
+Notation union_iff := union_spec (only parsing).
+Notation inter_iff := inter_spec (only parsing).
+Notation diff_iff := diff_spec (only parsing).
+Notation filter_iff := filter_spec (only parsing).
+
+(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)
+
+Ltac set_iff :=
+ repeat (progress (
+  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
+  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
+  || rewrite empty_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma mem_b : E.eq x y -> mem x s = mem y s.
+Proof.
+intros.
+generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
+destruct (mem x s); destruct (mem y s); intuition.
+Qed.
+
+Lemma empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
+Lemma add_b : mem y (add x s) = eqb x y || mem y s.
+Proof.
+generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
+destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
+Proof.
+generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
+Qed.
+
+Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
+destruct (mem y s); destruct (mem y (remove x s)); intuition.
+Qed.
+
+Lemma singleton_b : mem y (singleton x) = eqb x y.
+Proof.
+generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
+Qed.
+
+Lemma union_b : mem x (union s s') = mem x s || mem x s'.
+Proof.
+generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
+Qed.
+
+Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
+Proof.
+generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
+Qed.
+
+Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
+Proof.
+generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
+Qed.
+
+Lemma elements_b : mem x s = existsb (eqb x) (elements s).
+Proof.
+generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
+rewrite InA_alt.
+destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
+symmetry.
+rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
+exists a; intuition.
+unfold eqb; destruct (eq_dec x a); auto.
+rewrite <- H.
+rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as (a,(Ha1,Ha2)); [intuition|].
+exists a; intuition.
+unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x.
+Proof.
+intros.
+generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
+destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
+Qed.
+
+Lemma for_all_b : Proper (E.eq==>Logic.eq) f ->
+  for_all f s = forallb f (elements s).
+Proof.
+intros.
+generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
+unfold For_all.
+destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+rewrite (H2 x0) in H3.
+rewrite (InA_alt E.eq x0 (elements s)) in H3.
+destruct H3 as (a,(Ha1,Ha2)).
+rewrite (H _ _ Ha1).
+apply H0; auto.
+symmetry.
+rewrite H0; intros.
+destruct H1 as (_,H1).
+apply H1; auto.
+rewrite H2.
+rewrite InA_alt. exists x0; split; auto with relations.
+Qed.
+
+Lemma exists_b : Proper (E.eq==>Logic.eq) f ->
+  exists_ f s = existsb f (elements s).
+Proof.
+intros.
+generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
+unfold Exists.
+destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); auto.
+exists a; split; auto.
+rewrite H2; rewrite InA_alt; exists a; auto with relations.
+symmetry.
+rewrite H0.
+destruct H1 as (_,H1).
+destruct H1 as (a,(Ha1,Ha2)); auto.
+rewrite (H2 a) in Ha1.
+rewrite (InA_alt E.eq a (elements s)) in Ha1.
+destruct Ha1 as (b,(Hb1,Hb2)).
+exists b; auto.
+rewrite <- (H _ _ Hb1); auto.
+Qed.
+
+End BoolSpec.
+
+(** * Declarations of morphisms with respects to [E.eq] and [Equal] *)
+
+Instance In_m : Proper (E.eq==>Equal==>iff) In.
+Proof.
+unfold Equal; intros x y H s s' H0.
+rewrite (In_eq_iff s H); auto.
+Qed.
+
+Instance Empty_m : Proper (Equal==>iff) Empty.
+Proof.
+repeat red; unfold Empty; intros s s' E.
+setoid_rewrite E; auto.
+Qed.
+
+Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty.
+Proof.
+intros s s' H.
+generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff.
+destruct (is_empty s); destruct (is_empty s'); intuition.
+Qed.
+
+Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem.
+Proof.
+intros x x' Hx s s' Hs.
+generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff.
+destruct (mem x s), (mem x' s'); intuition.
+Qed.
+
+Instance singleton_m : Proper (E.eq==>Equal) singleton.
+Proof.
+intros x y H a. rewrite !singleton_iff, H; intuition.
+Qed.
+
+Instance add_m : Proper (E.eq==>Equal==>Equal) add.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition.
+Qed.
+
+Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition.
+Qed.
+
+Instance union_m : Proper (Equal==>Equal==>Equal) union.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance Subset_m : Proper (Equal==>Equal==>iff) Subset.
+Proof.
+unfold Equal, Subset; firstorder.
+Qed.
+
+Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2.
+generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff.
+destruct (subset s1 s2); destruct (subset s1' s2'); intuition.
+Qed.
+
+Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2.
+generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff.
+destruct (equal s1 s2); destruct (equal s1' s2'); intuition.
+Qed.
+
+Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *)
+Proof. firstorder. Qed.
+
+Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid.
+Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid.
+
+Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1.
+Proof.
+  simpl_relation. eauto with set.
+Qed.
+
+Instance Empty_s_m : Proper (Subset-->impl) Empty.
+Proof. firstorder. Qed.
+
+Instance add_s_m : Proper (E.eq==>Subset++>Subset) add.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition.
+Qed.
+
+Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition.
+Qed.
+
+Instance union_s_m : Proper (Subset++>Subset++>Subset) union.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
+Qed.
+
+
+(* [fold], [filter], [for_all], [exists_] and [partition] requires
+  some knowledge on [f] in order to be known as morphisms. *)
+
+Generalizable Variables f.
+
+Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f),
+ Proper (Equal==>Equal) (filter f).
+Proof.
+intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
+Qed.
+
+Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f),
+ Proper (Subset==>Subset) (filter f).
+Proof.
+intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
+Qed.
+
+Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) ->
+ forall s s', s[=]s' -> filter f s [=] filter f' s'.
+Proof.
+intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto.
+rewrite Hff', Hss'; intuition.
+red; red; intros; rewrite <- 2 Hff'; auto.
+Qed.
+
+(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid
+   structures on [list elt] and [option elt]. *)
+
+(* Later:
+Add Morphism cardinal ; cardinal_m.
+*)
+
+End WFactsOn.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [Facts] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WFacts]. *)
+
+Module WFacts (M:WSets) := WFactsOn M.E M.
+Module Facts := WFacts.
diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v
new file mode 100644
index 00000000..194cb904
--- /dev/null
+++ b/theories/MSets/MSetInterface.v
@@ -0,0 +1,732 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite set library *)
+
+(** Set interfaces, inspired by the one of Ocaml. When compared with
+    Ocaml, the main differences are:
+    - the lack of [iter] function, useless since Coq is purely functional
+    - the use of [option] types instead of [Not_found] exceptions
+    - the use of [nat] instead of [int] for the [cardinal] function
+
+    Several variants of the set interfaces are available:
+    - [WSetsOn] : functorial signature for weak sets
+    - [WSets]   : self-contained version of [WSets]
+    - [SetsOn]  : functorial signature for ordered sets
+    - [Sets]    : self-contained version of [Sets]
+    - [WRawSets] : a signature for weak sets that may be ill-formed
+    - [RawSets]  : same for ordered sets
+
+    If unsure, [S = Sets] is probably what you're looking for: most other
+    signatures are subsets of it, while [Sets] can be obtained from
+    [RawSets] via the use of a subset type (see (W)Raw2Sets below).
+*)
+
+Require Export Bool SetoidList RelationClasses Morphisms
+ RelationPairs Equalities Orders OrdersFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Type TypElt.
+ Parameters t elt : Type.
+End TypElt.
+
+Module Type HasWOps (Import T:TypElt).
+
+  Parameter empty : t.
+  (** The empty set. *)
+
+  Parameter is_empty : t -> bool.
+  (** Test whether a set is empty or not. *)
+
+  Parameter mem : elt -> t -> bool.
+  (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+  Parameter add : elt -> t -> t.
+  (** [add x s] returns a set containing all elements of [s],
+  plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+  Parameter singleton : elt -> t.
+  (** [singleton x] returns the one-element set containing only [x]. *)
+
+  Parameter remove : elt -> t -> t.
+  (** [remove x s] returns a set containing all elements of [s],
+  except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+  Parameter union : t -> t -> t.
+  (** Set union. *)
+
+  Parameter inter : t -> t -> t.
+  (** Set intersection. *)
+
+  Parameter diff : t -> t -> t.
+  (** Set difference. *)
+
+  Parameter equal : t -> t -> bool.
+  (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+  equal, that is, contain equal elements. *)
+
+  Parameter subset : t -> t -> bool.
+  (** [subset s1 s2] tests whether the set [s1] is a subset of
+  the set [s2]. *)
+
+  Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A.
+  (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+  where [x1 ... xN] are the elements of [s].
+  The order in which elements of [s] are presented to [f] is
+  unspecified. *)
+
+  Parameter for_all : (elt -> bool) -> t -> bool.
+  (** [for_all p s] checks if all elements of the set
+  satisfy the predicate [p]. *)
+
+  Parameter exists_ : (elt -> bool) -> t -> bool.
+  (** [exists p s] checks if at least one element of
+  the set satisfies the predicate [p]. *)
+
+  Parameter filter : (elt -> bool) -> t -> t.
+  (** [filter p s] returns the set of all elements in [s]
+  that satisfy predicate [p]. *)
+
+  Parameter partition : (elt -> bool) -> t -> t * t.
+  (** [partition p s] returns a pair of sets [(s1, s2)], where
+  [s1] is the set of all the elements of [s] that satisfy the
+  predicate [p], and [s2] is the set of all the elements of
+  [s] that do not satisfy [p]. *)
+
+  Parameter cardinal : t -> nat.
+  (** Return the number of elements of a set. *)
+
+  Parameter elements : t -> list elt.
+  (** Return the list of all elements of the given set, in any order. *)
+
+  Parameter choose : t -> option elt.
+  (** Return one element of the given set, or [None] if
+  the set is empty. Which element is chosen is unspecified.
+  Equal sets could return different elements. *)
+
+End HasWOps.
+
+Module Type WOps (E : DecidableType).
+  Definition elt := E.t.
+  Parameter t : Type. (** the abstract type of sets *)
+  Include HasWOps.
+End WOps.
+
+
+(** ** Functorial signature for weak sets
+
+    Weak sets are sets without ordering on base elements, only
+    a decidable equality. *)
+
+Module Type WSetsOn (E : DecidableType).
+  (** First, we ask for all the functions *)
+  Include WOps E.
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Declare Instance In_compat : Proper (E.eq==>eq==>iff) In.
+
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
+  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Include IsEq. (** [eq] is obviously an equivalence, for subtyping only *)
+  Include HasEqDec.
+
+  (** Specifications of set operators *)
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+  Variable f : elt -> bool.
+  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+  Parameter mem_spec : mem x s = true <-> In x s.
+  Parameter equal_spec : equal s s' = true <-> s[=]s'.
+  Parameter subset_spec : subset s s' = true <-> s[<=]s'.
+  Parameter empty_spec : Empty empty.
+  Parameter is_empty_spec : is_empty s = true <-> Empty s.
+  Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s.
+  Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Parameter singleton_spec : In y (singleton x) <-> E.eq y x.
+  Parameter union_spec : In x (union s s') <-> In x s \/ In x s'.
+  Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'.
+  Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'.
+  Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+    fold f s i = fold_left (flip f) (elements s) i.
+  Parameter cardinal_spec : cardinal s = length (elements s).
+  Parameter filter_spec : compatb f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Parameter for_all_spec : compatb f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Parameter exists_spec : compatb f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Parameter partition_spec1 : compatb f ->
+    fst (partition f s) [=] filter f s.
+  Parameter partition_spec2 : compatb f ->
+    snd (partition f s) [=] filter (fun x => negb (f x)) s.
+  Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  (** When compared with ordered sets, here comes the only
+      property that is really weaker: *)
+  Parameter elements_spec2w : NoDupA E.eq (elements s).
+  Parameter choose_spec1 : choose s = Some x -> In x s.
+  Parameter choose_spec2 : choose s = None -> Empty s.
+
+  End Spec.
+
+End WSetsOn.
+
+(** ** Static signature for weak sets
+
+    Similar to the functorial signature [WSetsOn], except that the
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type WSets.
+  Declare Module E : DecidableType.
+  Include WSetsOn E.
+End WSets.
+
+(** ** Functorial signature for sets on ordered elements
+
+    Based on [WSetsOn], plus ordering on sets and [min_elt] and [max_elt]
+    and some stronger specifications for other functions. *)
+
+Module Type HasOrdOps (Import T:TypElt).
+
+  Parameter compare : t -> t -> comparison.
+  (** Total ordering between sets. Can be used as the ordering function
+  for doing sets of sets. *)
+
+  Parameter min_elt : t -> option elt.
+  (** Return the smallest element of the given set
+  (with respect to the [E.compare] ordering),
+  or [None] if the set is empty. *)
+
+  Parameter max_elt : t -> option elt.
+  (** Same as [min_elt], but returns the largest element of the
+  given set. *)
+
+End HasOrdOps.
+
+Module Type Ops (E : OrderedType) := WOps E <+ HasOrdOps.
+
+
+Module Type SetsOn (E : OrderedType).
+  Include WSetsOn E <+ HasOrdOps <+ HasLt <+ IsStrOrder.
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+
+  Parameter compare_spec : CompSpec eq lt s s' (compare s s').
+
+  (** Additional specification of [elements] *)
+  Parameter elements_spec2 : sort E.lt (elements s).
+
+  (** Remark: since [fold] is specified via [elements], this stronger
+   specification of [elements] has an indirect impact on [fold],
+   which can now be proved to receive elements in increasing order.
+  *)
+
+  Parameter min_elt_spec1 : min_elt s = Some x -> In x s.
+  Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Parameter min_elt_spec3 : min_elt s = None -> Empty s.
+
+  Parameter max_elt_spec1 : max_elt s = Some x -> In x s.
+  Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Parameter max_elt_spec3 : max_elt s = None -> Empty s.
+
+  (** Additional specification of [choose] *)
+  Parameter choose_spec3 : choose s = Some x -> choose s' = Some y ->
+    Equal s s' -> E.eq x y.
+
+  End Spec.
+
+End SetsOn.
+
+
+(** ** Static signature for sets on ordered elements
+
+    Similar to the functorial signature [SetsOn], except that the
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type Sets.
+  Declare Module E : OrderedType.
+  Include SetsOn E.
+End Sets.
+
+Module Type S := Sets.
+
+
+(** ** Some subtyping tests
+<<
+WSetsOn ---> WSets
+ |           |
+ |           |
+ V           V
+SetsOn  ---> Sets
+
+Module S_WS (M : Sets) <: WSets := M.
+Module Sfun_WSfun (E:OrderedType)(M : SetsOn E) <: WSetsOn E := M.
+Module S_Sfun (M : Sets) <: SetsOn M.E := M.
+Module WS_WSfun (M : WSets) <: WSetsOn M.E := M.
+>>
+*)
+
+
+
+(** ** Signatures for set representations with ill-formed values.
+
+   Motivation:
+
+   For many implementation of finite sets (AVL trees, sorted
+   lists, lists without duplicates), we use the same two-layer
+   approach:
+
+   - A first module deals with the datatype (eg. list or tree) without
+   any restriction on the values we consider. In this module (named
+   "Raw" in the past), some results are stated under the assumption
+   that some invariant (e.g. sortedness) holds for the input sets. We
+   also prove that this invariant is preserved by set operators.
+
+   - A second module implements the exact Sets interface by
+   using a subtype, for instance [{ l : list A | sorted l }].
+   This module is a mere wrapper around the first Raw module.
+
+   With the interfaces below, we give some respectability to
+   the "Raw" modules. This allows the interested users to directly
+   access them via the interfaces. Even better, we can build once
+   and for all a functor doing the transition between Raw and usual Sets.
+
+   Description:
+
+   The type [t] of sets may contain ill-formed values on which our
+   set operators may give wrong answers. In particular, [mem]
+   may not see a element in a ill-formed set (think for instance of a
+   unsorted list being given to an optimized [mem] that stops
+   its search as soon as a strictly larger element is encountered).
+
+   Unlike optimized operators, the [In] predicate is supposed to
+   always be correct, even on ill-formed sets. Same for [Equal] and
+   other logical predicates.
+
+   A predicate parameter [Ok] is used to discriminate between
+   well-formed and ill-formed values. Some lemmas hold only on sets
+   validating [Ok]. This predicate [Ok] is required to be
+   preserved by set operators. Moreover, a boolean function [isok]
+   should exist for identifying (at least some of) the well-formed sets.
+
+*)
+
+
+Module Type WRawSets (E : DecidableType).
+  (** First, we ask for all the functions *)
+  Include WOps E.
+
+  (** Is a set well-formed or ill-formed ? *)
+
+  Parameter IsOk : t -> Prop.
+  Class Ok (s:t) : Prop := ok : IsOk s.
+
+  (** In order to be able to validate (at least some) particular sets as
+      well-formed, we ask for a boolean function for (semi-)deciding
+      predicate [Ok]. If [Ok] isn't decidable, [isok] may be the
+      always-false function. *)
+  Parameter isok : t -> bool.
+  Declare Instance isok_Ok s `(isok s = true) : Ok s | 10.
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Declare Instance In_compat : Proper (E.eq==>eq==>iff) In.
+
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
+  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Declare Instance eq_equiv : Equivalence eq.
+
+  (** First, all operations are compatible with the well-formed predicate. *)
+
+  Declare Instance empty_ok : Ok empty.
+  Declare Instance add_ok s x `(Ok s) : Ok (add x s).
+  Declare Instance remove_ok s x `(Ok s) : Ok (remove x s).
+  Declare Instance singleton_ok x : Ok (singleton x).
+  Declare Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s').
+  Declare Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
+  Declare Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s').
+  Declare Instance filter_ok s f `(Ok s) : Ok (filter f s).
+  Declare Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
+  Declare Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).
+
+  (** Now, the specifications, with constraints on the input sets. *)
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+  Variable f : elt -> bool.
+  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+  Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s.
+  Parameter equal_spec : forall `{Ok s, Ok s'},
+    equal s s' = true <-> s[=]s'.
+  Parameter subset_spec : forall `{Ok s, Ok s'},
+    subset s s' = true <-> s[<=]s'.
+  Parameter empty_spec : Empty empty.
+  Parameter is_empty_spec : is_empty s = true <-> Empty s.
+  Parameter add_spec : forall `{Ok s},
+    In y (add x s) <-> E.eq y x \/ In y s.
+  Parameter remove_spec : forall `{Ok s},
+    In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Parameter singleton_spec : In y (singleton x) <-> E.eq y x.
+  Parameter union_spec : forall `{Ok s, Ok s'},
+    In x (union s s') <-> In x s \/ In x s'.
+  Parameter inter_spec : forall `{Ok s, Ok s'},
+    In x (inter s s') <-> In x s /\ In x s'.
+  Parameter diff_spec : forall `{Ok s, Ok s'},
+    In x (diff s s') <-> In x s /\ ~In x s'.
+  Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+    fold f s i = fold_left (flip f) (elements s) i.
+  Parameter cardinal_spec : forall `{Ok s},
+    cardinal s = length (elements s).
+  Parameter filter_spec : compatb f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Parameter for_all_spec : compatb f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Parameter exists_spec : compatb f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Parameter partition_spec1 : compatb f ->
+    fst (partition f s) [=] filter f s.
+  Parameter partition_spec2 : compatb f ->
+    snd (partition f s) [=] filter (fun x => negb (f x)) s.
+  Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s).
+  Parameter choose_spec1 : choose s = Some x -> In x s.
+  Parameter choose_spec2 : choose s = None -> Empty s.
+
+  End Spec.
+
+End WRawSets.
+
+(** From weak raw sets to weak usual sets *)
+
+Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E.
+
+ (** We avoid creating induction principles for the Record *)
+ Local Unset Elimination Schemes.
+ Local Unset Case Analysis Schemes.
+
+ Definition elt := E.t.
+
+ Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}.
+ Definition t := t_.
+ Implicit Arguments Mkt [ [is_ok] ].
+ Hint Resolve is_ok : typeclass_instances.
+
+ Definition In (x : elt)(s : t) := M.In x s.(this).
+ Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'.
+ Definition Empty (s : t) := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop)(s : t) := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop)(s : t) := exists x, In x s /\ P x.
+
+ Definition mem (x : elt)(s : t) := M.mem x s.
+ Definition add (x : elt)(s : t) : t := Mkt (M.add x s).
+ Definition remove (x : elt)(s : t) : t := Mkt (M.remove x s).
+ Definition singleton (x : elt) : t := Mkt (M.singleton x).
+ Definition union (s s' : t) : t := Mkt (M.union s s').
+ Definition inter (s s' : t) : t := Mkt (M.inter s s').
+ Definition diff (s s' : t) : t := Mkt (M.diff s s').
+ Definition equal (s s' : t) := M.equal s s'.
+ Definition subset (s s' : t) := M.subset s s'.
+ Definition empty : t := Mkt M.empty.
+ Definition is_empty (s : t) := M.is_empty s.
+ Definition elements (s : t) : list elt := M.elements s.
+ Definition choose (s : t) : option elt := M.choose s.
+ Definition fold (A : Type)(f : elt -> A -> A)(s : t) : A -> A := M.fold f s.
+ Definition cardinal (s : t) := M.cardinal s.
+ Definition filter (f : elt -> bool)(s : t) : t := Mkt (M.filter f s).
+ Definition for_all (f : elt -> bool)(s : t) := M.for_all f s.
+ Definition exists_ (f : elt -> bool)(s : t) := M.exists_ f s.
+ Definition partition (f : elt -> bool)(s : t) : t * t :=
+   let p := M.partition f s in (Mkt (fst p), Mkt (snd p)).
+
+ Instance In_compat : Proper (E.eq==>eq==>iff) In.
+ Proof. repeat red. intros; apply M.In_compat; congruence. Qed.
+
+ Definition eq : t -> t -> Prop := Equal.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof. firstorder. Qed.
+
+ Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }.
+ Proof.
+  intros (s,Hs) (s',Hs').
+  change ({M.Equal s s'}+{~M.Equal s s'}).
+  destruct (M.equal s s') as [ ]_eqn:H; [left|right];
+   rewrite <- M.equal_spec; congruence.
+ Defined.
+
+
+ Section Spec.
+  Variable s s' : t.
+  Variable x y : elt.
+  Variable f : elt -> bool.
+  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+  Lemma mem_spec : mem x s = true <-> In x s.
+  Proof. exact (@M.mem_spec _ _ _). Qed.
+  Lemma equal_spec : equal s s' = true <-> Equal s s'.
+  Proof. exact (@M.equal_spec _ _ _ _). Qed.
+  Lemma subset_spec : subset s s' = true <-> Subset s s'.
+  Proof. exact (@M.subset_spec _ _ _ _). Qed.
+  Lemma empty_spec : Empty empty.
+  Proof. exact M.empty_spec. Qed.
+  Lemma is_empty_spec : is_empty s = true <-> Empty s.
+  Proof. exact (@M.is_empty_spec _). Qed.
+  Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
+  Proof. exact (@M.add_spec _ _ _ _). Qed.
+  Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Proof. exact (@M.remove_spec _ _ _ _). Qed.
+  Lemma singleton_spec : In y (singleton x) <-> E.eq y x.
+  Proof. exact (@M.singleton_spec _ _). Qed.
+  Lemma union_spec : In x (union s s') <-> In x s \/ In x s'.
+  Proof. exact (@M.union_spec _ _ _ _ _). Qed.
+  Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'.
+  Proof. exact (@M.inter_spec _ _ _ _ _). Qed.
+  Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'.
+  Proof. exact (@M.diff_spec _ _ _ _ _). Qed.
+  Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof. exact (@M.fold_spec _). Qed.
+  Lemma cardinal_spec : cardinal s = length (elements s).
+  Proof. exact (@M.cardinal_spec s _). Qed.
+  Lemma filter_spec : compatb f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Proof. exact (@M.filter_spec _ _ _). Qed.
+  Lemma for_all_spec : compatb f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof. exact (@M.for_all_spec _ _). Qed.
+  Lemma exists_spec : compatb f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof. exact (@M.exists_spec _ _). Qed.
+  Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s).
+  Proof. exact (@M.partition_spec1 _ _). Qed.
+  Lemma partition_spec2 : compatb f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. exact (@M.partition_spec2 _ _). Qed.
+  Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  Proof. exact (@M.elements_spec1 _ _). Qed.
+  Lemma elements_spec2w : NoDupA E.eq (elements s).
+  Proof. exact (@M.elements_spec2w _ _). Qed.
+  Lemma choose_spec1 : choose s = Some x -> In x s.
+  Proof. exact (@M.choose_spec1 _ _). Qed.
+  Lemma choose_spec2 : choose s = None -> Empty s.
+  Proof. exact (@M.choose_spec2 _). Qed.
+
+ End Spec.
+
+End WRaw2SetsOn.
+
+Module WRaw2Sets (D:DecidableType)(M:WRawSets D) <: WSets with Module E := D.
+  Module E := D.
+  Include WRaw2SetsOn D M.
+End WRaw2Sets.
+
+(** Same approach for ordered sets *)
+
+Module Type RawSets (E : OrderedType).
+  Include WRawSets E <+ HasOrdOps <+ HasLt <+ IsStrOrder.
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+
+  (** Specification of [compare] *)
+  Parameter compare_spec : forall `{Ok s, Ok s'}, CompSpec eq lt s s' (compare s s').
+
+  (** Additional specification of [elements] *)
+  Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s).
+
+  (** Specification of [min_elt] *)
+  Parameter min_elt_spec1 : min_elt s = Some x -> In x s.
+  Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Parameter min_elt_spec3 : min_elt s = None -> Empty s.
+
+  (** Specification of [max_elt] *)
+  Parameter max_elt_spec1 : max_elt s = Some x -> In x s.
+  Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Parameter max_elt_spec3 : max_elt s = None -> Empty s.
+
+  (** Additional specification of [choose] *)
+  Parameter choose_spec3 : forall `{Ok s, Ok s'},
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
+
+  End Spec.
+
+End RawSets.
+
+(** From Raw to usual sets *)
+
+Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O.
+  Include WRaw2SetsOn O M.
+
+  Definition compare (s s':t) := M.compare s s'.
+  Definition min_elt (s:t) : option elt := M.min_elt s.
+  Definition max_elt (s:t) : option elt := M.max_elt s.
+  Definition lt (s s':t) := M.lt s s'.
+
+  (** Specification of [lt] *)
+  Instance lt_strorder : StrictOrder lt.
+  Proof. constructor ; unfold lt; red.
+    unfold complement. red. intros. apply (irreflexivity H).
+    intros. transitivity y; auto.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  repeat red. unfold eq, lt.
+  intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl.
+  change (M.eq s1 s2) in E.
+  change (M.eq s1' s2') in E'.
+  rewrite E,E'; intuition.
+  Qed.
+
+  Section Spec.
+  Variable s s' s'' : t.
+  Variable x y : elt.
+
+  Lemma compare_spec : CompSpec eq lt s s' (compare s s').
+  Proof. unfold compare; destruct (@M.compare_spec s s' _ _); auto. Qed.
+
+  (** Additional specification of [elements] *)
+  Lemma elements_spec2 : sort O.lt (elements s).
+  Proof. exact (@M.elements_spec2 _ _). Qed.
+
+  (** Specification of [min_elt] *)
+  Lemma min_elt_spec1 : min_elt s = Some x -> In x s.
+  Proof. exact (@M.min_elt_spec1 _ _). Qed.
+  Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x.
+  Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed.
+  Lemma min_elt_spec3 : min_elt s = None -> Empty s.
+  Proof. exact (@M.min_elt_spec3 _). Qed.
+
+  (** Specification of [max_elt] *)
+  Lemma max_elt_spec1 : max_elt s = Some x -> In x s.
+  Proof. exact (@M.max_elt_spec1 _ _). Qed.
+  Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y.
+  Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed.
+  Lemma max_elt_spec3 : max_elt s = None -> Empty s.
+  Proof. exact (@M.max_elt_spec3 _). Qed.
+
+  (** Additional specification of [choose] *)
+  Lemma choose_spec3 :
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y.
+  Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed.
+
+  End Spec.
+
+End Raw2SetsOn.
+
+Module Raw2Sets (O:OrderedType)(M:RawSets O) <: Sets with Module E := O.
+  Module E := O.
+  Include Raw2SetsOn O M.
+End Raw2Sets.
+
+
+(** We provide an ordering for sets-as-sorted-lists *)
+
+Module MakeListOrdering (O:OrderedType).
+ Module MO:=OrderedTypeFacts O.
+
+ Local Notation t := (list O.t).
+ Local Notation In := (InA O.eq).
+
+ Definition eq s s' := forall x, In x s <-> In x s'.
+
+ Instance eq_equiv : Equivalence eq.
+
+ Inductive lt_list : t -> t -> Prop :=
+    | lt_nil : forall x s, lt_list nil (x :: s)
+    | lt_cons_lt : forall x y s s',
+        O.lt x y -> lt_list (x :: s) (y :: s')
+    | lt_cons_eq : forall x y s s',
+        O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s').
+ Hint Constructors lt_list.
+
+ Definition lt := lt_list.
+ Hint Unfold lt.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split.
+ (* irreflexive *)
+ assert (forall s s', s=s' -> ~lt s s').
+  red; induction 2.
+  discriminate.
+  inversion H; subst.
+  apply (StrictOrder_Irreflexive y); auto.
+  inversion H; subst; auto.
+ intros s Hs; exact (H s s (eq_refl s) Hs).
+ (* transitive *)
+ intros s s' s'' H; generalize s''; clear s''; elim H.
+ intros x l s'' H'; inversion_clear H'; auto.
+ intros x x' l l' E s'' H'; inversion_clear H'; auto.
+ constructor 2. transitivity x'; auto.
+ constructor 2. rewrite <- H0; auto.
+ intros.
+ inversion_clear H3.
+ constructor 2. rewrite H0; auto.
+ constructor 3; auto. transitivity y; auto. unfold lt in *; auto.
+ Qed.
+
+ Instance lt_compat' :
+  Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt.
+ Proof.
+ apply proper_sym_impl_iff_2; auto with *.
+ intros s1 s1' E1 s2 s2' E2 H.
+ revert s1' E1 s2' E2.
+ induction H; intros; inversion_clear E1; inversion_clear E2.
+ constructor 1.
+ constructor 2. MO.order.
+ constructor 3. MO.order. unfold lt in *; auto.
+ Qed.
+
+ Lemma eq_cons :
+  forall l1 l2 x y,
+  O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2).
+ Proof.
+  unfold eq; intros l1 l2 x y Exy E12 z.
+  split; inversion_clear 1.
+  left; MO.order. right; rewrite <- E12; auto.
+  left; MO.order. right; rewrite E12; auto.
+ Qed.
+ Hint Resolve eq_cons.
+
+ Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 ->
+  CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c.
+ Proof.
+  destruct c; simpl; inversion_clear 2; auto with relations.
+ Qed.
+ Hint Resolve cons_CompSpec.
+
+End MakeListOrdering.
diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v
new file mode 100644
index 00000000..48af7e6a
--- /dev/null
+++ b/theories/MSets/MSetList.v
@@ -0,0 +1,899 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant
+    interface [MSetInterface.S] using strictly ordered list. *)
+
+Require Export MSetInterface OrdersFacts OrdersLists.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Functions over lists
+
+   First, we provide sets as lists which are not necessarily sorted.
+   The specs are proved under the additional condition of being sorted.
+   And the functions returning sets are proved to preserve this invariant. *)
+
+Module Ops (X:OrderedType) <: WOps X.
+
+  Definition elt := X.t.
+  Definition t := list elt.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) := if l then true else false.
+
+  (** ** The set operations. *)
+
+  Fixpoint mem x s :=
+    match s with
+    | nil => false
+    | y :: l =>
+        match X.compare x y with
+        | Lt => false
+        | Eq => true
+        | Gt => mem x l
+        end
+    end.
+
+  Fixpoint add x s :=
+    match s with
+    | nil => x :: nil
+    | y :: l =>
+        match X.compare x y with
+        | Lt => x :: s
+        | Eq => s
+        | Gt => y :: add x l
+        end
+    end.
+
+  Definition singleton (x : elt) := x :: nil.
+
+  Fixpoint remove x s :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        match X.compare x y with
+        | Lt => s
+        | Eq => l
+        | Gt => y :: remove x l
+        end
+    end.
+
+  Fixpoint union (s : t) : t -> t :=
+    match s with
+    | nil => fun s' => s'
+    | x :: l =>
+        (fix union_aux (s' : t) : t :=
+           match s' with
+           | nil => s
+           | x' :: l' =>
+               match X.compare x x' with
+               | Lt => x :: union l s'
+               | Eq => x :: union l l'
+               | Gt => x' :: union_aux l'
+               end
+           end)
+    end.
+
+  Fixpoint inter (s : t) : t -> t :=
+    match s with
+    | nil => fun _ => nil
+    | x :: l =>
+        (fix inter_aux (s' : t) : t :=
+           match s' with
+           | nil => nil
+           | x' :: l' =>
+               match X.compare x x' with
+               | Lt => inter l s'
+               | Eq => x :: inter l l'
+               | Gt => inter_aux l'
+               end
+           end)
+    end.
+
+  Fixpoint diff (s : t) : t -> t :=
+    match s with
+    | nil => fun _ => nil
+    | x :: l =>
+        (fix diff_aux (s' : t) : t :=
+           match s' with
+           | nil => s
+           | x' :: l' =>
+               match X.compare x x' with
+               | Lt => x :: diff l s'
+               | Eq => diff l l'
+               | Gt => diff_aux l'
+               end
+           end)
+    end.
+
+  Fixpoint equal (s : t) : t -> bool :=
+    fun s' : t =>
+    match s, s' with
+    | nil, nil => true
+    | x :: l, x' :: l' =>
+        match X.compare x x' with
+        | Eq => equal l l'
+        | _ => false
+        end
+    | _, _ => false
+    end.
+
+  Fixpoint subset s s' :=
+    match s, s' with
+    | nil, _ => true
+    | x :: l, x' :: l' =>
+        match X.compare x x' with
+        | Lt => false
+        | Eq => subset l l'
+        | Gt => subset s l'
+        end
+    | _, _ => false
+    end.
+
+  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
+    fold_left (flip f) s i.
+
+  Fixpoint filter (f : elt -> bool) (s : t) : t :=
+    match s with
+    | nil => nil
+    | x :: l => if f x then x :: filter f l else filter f l
+    end.
+
+  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
+    match s with
+    | nil => true
+    | x :: l => if f x then for_all f l else false
+    end.
+
+  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
+    match s with
+    | nil => false
+    | x :: l => if f x then true else exists_ f l
+    end.
+
+  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
+    match s with
+    | nil => (nil, nil)
+    | x :: l =>
+        let (s1, s2) := partition f l in
+        if f x then (x :: s1, s2) else (s1, x :: s2)
+    end.
+
+  Definition cardinal (s : t) : nat := length s.
+
+  Definition elements (x : t) : list elt := x.
+
+  Definition min_elt (s : t) : option elt :=
+    match s with
+    | nil => None
+    | x :: _ => Some x
+    end.
+
+  Fixpoint max_elt (s : t) : option elt :=
+    match s with
+    | nil => None
+    | x :: nil => Some x
+    | _ :: l => max_elt l
+    end.
+
+  Definition choose := min_elt.
+
+  Fixpoint compare s s' :=
+   match s, s' with
+    | nil, nil => Eq
+    | nil, _ => Lt
+    | _, nil => Gt
+    | x::s, x'::s' =>
+      match X.compare x x' with
+       | Eq => compare s s'
+       | Lt => Lt
+       | Gt => Gt
+      end
+   end.
+
+End Ops.
+
+Module MakeRaw (X: OrderedType) <: RawSets X.
+  Module Import MX := OrderedTypeFacts X.
+  Module Import ML := OrderedTypeLists X.
+
+  Include Ops X.
+
+  (** ** Proofs of set operation specifications. *)
+
+  Section ForNotations.
+
+  Definition inf x l :=
+   match l with
+   | nil => true
+   | y::_ => match X.compare x y with Lt => true | _ => false end
+   end.
+
+  Fixpoint isok l :=
+   match l with
+   | nil => true
+   | x::l => inf x l && isok l
+   end.
+
+  Notation Sort l := (isok l = true).
+  Notation Inf := (lelistA X.lt).
+  Notation In := (InA X.eq).
+
+  (* TODO: modify proofs in order to avoid these hints *)
+  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
+  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
+  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).
+
+  Definition IsOk s := Sort s.
+
+  Class Ok (s:t) : Prop := ok : Sort s.
+
+  Hint Resolve @ok.
+  Hint Unfold Ok.
+
+  Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }.
+
+  Lemma inf_iff : forall x l, Inf x l <-> inf x l = true.
+  Proof.
+    intros x l; split; intro H.
+    (* -> *)
+    destruct H; simpl in *.
+      reflexivity.
+    rewrite <- compare_lt_iff in H; rewrite H; reflexivity.
+    (* <- *)
+    destruct l as [|y ys]; simpl in *.
+      constructor; fail.
+    revert H; case_eq (X.compare x y); try discriminate; [].
+    intros Ha _.
+    rewrite compare_lt_iff in Ha.
+    constructor; assumption.
+  Qed.
+
+  Lemma isok_iff : forall l, sort X.lt l <-> Ok l.
+  Proof.
+    intro l; split; intro H.
+    (* -> *)
+    elim H.
+      constructor; fail.
+    intros y ys Ha Hb Hc.
+    change (inf y ys && isok ys = true).
+    rewrite inf_iff in Hc.
+    rewrite andb_true_iff; tauto.
+    (* <- *)
+    induction l as [|x xs].
+      constructor.
+    change (inf x xs && isok xs = true) in H.
+    rewrite andb_true_iff, <- inf_iff in H.
+    destruct H; constructor; tauto.
+  Qed.
+
+  Hint Extern 1 (Ok _) => rewrite <- isok_iff.
+
+  Ltac inv_ok := match goal with
+   | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok
+   | H:sort X.lt nil |- _ => clear H; inv_ok
+   | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok
+   | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok
+   | |- Ok _ => rewrite <- isok_iff
+   | _ => idtac
+  end.
+
+  Ltac inv := invlist InA; inv_ok; invlist lelistA.
+  Ltac constructors := repeat constructor.
+
+  Ltac sort_inf_in := match goal with
+   | H:Inf ?x ?l, H':In ?y ?l |- _ =>
+     cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto]
+   | _ => fail
+  end.
+
+  Global Instance isok_Ok s `(isok s = true) : Ok s | 10.
+  Proof.
+  intros. assumption.
+  Qed.
+
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.
+
+  Lemma mem_spec :
+   forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s.
+  Proof.
+  induction s; intros x Hs; inv; simpl.
+  intuition. discriminate. inv.
+  elim_compare x a; rewrite InA_cons; intuition; try order.
+  discriminate.
+  sort_inf_in. order.
+  rewrite <- IHs; auto.
+  rewrite IHs; auto.
+  Qed.
+
+  Lemma add_inf :
+   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
+  Proof.
+  simple induction s; simpl.
+  intuition.
+  intros; elim_compare x a; inv; intuition.
+  Qed.
+  Hint Resolve add_inf.
+
+  Global Instance add_ok s x : forall `(Ok s), Ok (add x s).
+  Proof.
+  repeat rewrite <- isok_iff; revert s x.
+  simple induction s; simpl.
+  intuition.
+  intros; elim_compare x a; inv; auto.
+  Qed.
+
+  Lemma add_spec :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+    In y (add x s) <-> X.eq y x \/ In y s.
+  Proof.
+  induction s; simpl; intros.
+  intuition. inv; auto.
+  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition.
+  left; order.
+  Qed.
+
+  Lemma remove_inf :
+   forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s).
+  Proof.
+  induction s; simpl.
+  intuition.
+  intros; elim_compare x a; inv; auto.
+  apply Inf_lt with a; auto.
+  Qed.
+  Hint Resolve remove_inf.
+
+  Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s).
+  Proof.
+  repeat rewrite <- isok_iff; revert s x.
+  induction s; simpl.
+  intuition.
+  intros; elim_compare x a; inv; auto.
+  Qed.
+
+  Lemma remove_spec :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+    In y (remove x s) <-> In y s /\ ~X.eq y x.
+  Proof.
+  induction s; simpl; intros.
+  intuition; inv; auto.
+  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition;
+   try sort_inf_in; try order.
+  Qed.
+
+  Global Instance singleton_ok x : Ok (singleton x).
+  Proof.
+  unfold singleton; simpl; auto.
+  Qed.
+
+  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
+  Proof.
+  unfold singleton; simpl; split; intros; inv; auto.
+  Qed.
+
+  Ltac induction2 :=
+    simple induction s;
+     [ simpl; auto; try solve [ intros; inv ]
+     | intros x l Hrec; simple induction s';
+        [ simpl; auto; try solve [ intros; inv ]
+        | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]].
+
+  Lemma union_inf :
+   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
+   Inf a s -> Inf a s' -> Inf a (union s s').
+  Proof.
+  induction2.
+  Qed.
+  Hint Resolve union_inf.
+
+  Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s').
+  Proof.
+  repeat rewrite <- isok_iff; revert s s'.
+  induction2; constructors; try apply @ok; auto.
+  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto.
+  change (Inf x' (union (x :: l) l')); auto.
+  Qed.
+
+  Lemma union_spec :
+   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
+   In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto.
+  left; order.
+  Qed.
+
+  Lemma inter_inf :
+   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
+   Inf a s -> Inf a s' -> Inf a (inter s s').
+  Proof.
+  induction2.
+  apply Inf_lt with x; auto.
+  apply Hrec'; auto.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve inter_inf.
+
+  Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s').
+  Proof.
+  repeat rewrite <- isok_iff; revert s s'.
+  induction2.
+  constructors; auto.
+  apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto.
+  Qed.
+
+  Lemma inter_spec :
+   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
+   In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
+   try sort_inf_in; try order.
+  left; order.
+  Qed.
+
+  Lemma diff_inf :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (diff s s').
+  Proof.
+  intros s s'; repeat rewrite <- isok_iff; revert s s'.
+  induction2.
+  apply Hrec; trivial.
+  apply Inf_lt with x; auto.
+  apply Inf_lt with x'; auto.
+  apply Hrec'; auto.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve diff_inf.
+
+  Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s').
+  Proof.
+  repeat rewrite <- isok_iff; revert s s'.
+  induction2.
+  Qed.
+
+  Lemma diff_spec :
+   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
+   In x (diff s s') <-> In x s /\ ~In x s'.
+  Proof.
+  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
+   try sort_inf_in; try order.
+  right; intuition; inv; auto.
+  Qed.
+
+  Lemma equal_spec :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
+   equal s s' = true <-> Equal s s'.
+  Proof.
+  induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl.
+  intuition.
+  split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv.
+  split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv.
+  inv.
+  elim_compare x x' as C; try discriminate.
+  (* x=x' *)
+  rewrite IH; auto.
+  split; intros E y; specialize (E y).
+  rewrite !InA_cons, E, C; intuition.
+  rewrite !InA_cons, C in E. intuition; try sort_inf_in; order.
+  (* x<x' *)
+  split; intros E. discriminate.
+  assert (In x (x'::s')) by (rewrite <- E; auto).
+  inv; try sort_inf_in; order.
+  (* x>x' *)
+  split; intros E. discriminate.
+  assert (In x' (x::s)) by (rewrite E; auto).
+  inv; try sort_inf_in; order.
+  Qed.
+
+  Lemma subset_spec :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
+   subset s s' = true <-> Subset s s'.
+  Proof.
+  intros s s'; revert s.
+  induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto.
+  split; try red; intros; auto.
+  split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv.
+  split; try red; intros; auto. inv.
+  inv. elim_compare x x' as C.
+  (* x=x' *)
+  rewrite IH; auto.
+  split; intros S y; specialize (S y).
+  rewrite !InA_cons, C. intuition.
+  rewrite !InA_cons, C in S. intuition; try sort_inf_in; order.
+  (* x<x' *)
+  split; intros S. discriminate.
+  assert (In x (x'::s')) by (apply S; auto).
+  inv; try sort_inf_in; order.
+  (* x>x' *)
+  rewrite IH; auto.
+  split; intros S y; specialize (S y).
+  rewrite !InA_cons. intuition.
+  rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order.
+  Qed.
+
+  Global Instance empty_ok : Ok empty.
+  Proof.
+  constructors.
+  Qed.
+
+  Lemma empty_spec : Empty empty.
+  Proof.
+  unfold Empty, empty; intuition; inv.
+  Qed.
+
+  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
+  Proof.
+  intros [ | x s]; simpl.
+  split; auto. intros _ x H. inv.
+  split. discriminate. intros H. elim (H x); auto.
+  Qed.
+
+  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
+  Proof.
+  intuition.
+  Qed.
+
+  Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s).
+  Proof.
+  intro s; repeat rewrite <- isok_iff; auto.
+  Qed.
+
+  Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s).
+  Proof.
+  intro s; repeat rewrite <- isok_iff; auto.
+  Qed.
+
+  Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
+  Proof.
+  destruct s; simpl; inversion 1; auto.
+  Qed.
+
+  Lemma min_elt_spec2 :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+   min_elt s = Some x -> In y s -> ~ X.lt y x.
+  Proof.
+  induction s as [ | x s IH]; simpl; inversion 2; subst.
+  intros; inv; try sort_inf_in; order.
+  Qed.
+
+  Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+  destruct s; simpl; red; intuition. inv. discriminate.
+  Qed.
+
+  Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
+  Proof.
+  induction s as [ | x s IH]. inversion 1.
+  destruct s as [ | y s]. simpl. inversion 1; subst; auto.
+  right; apply IH; auto.
+  Qed.
+
+  Lemma max_elt_spec2 :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+   max_elt s = Some x -> In y s -> ~ X.lt x y.
+  Proof.
+  induction s as [ | a s IH]. inversion 2.
+  destruct s as [ | b s]. inversion 2; subst. intros; inv; order.
+  intros. inv; auto.
+  assert (~X.lt x b) by (apply IH; auto).
+  assert (X.lt a b) by auto.
+  order.
+  Qed.
+
+  Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+  induction s as [ | a s IH]. red; intuition; inv.
+  destruct s as [ | b s]. inversion 1.
+  intros; elim IH with b; auto.
+  Qed.
+
+  Definition choose_spec1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1.
+
+  Definition choose_spec2 :
+    forall s : t, choose s = None -> Empty s := min_elt_spec3.
+
+  Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' ->
+   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
+  Proof.
+   unfold choose; intros s s' x x' Hs Hs' Hx Hx' H.
+   assert (~X.lt x x').
+    apply min_elt_spec2 with s'; auto.
+    rewrite <-H; auto using min_elt_spec1.
+   assert (~X.lt x' x).
+    apply min_elt_spec2 with s; auto.
+    rewrite H; auto using min_elt_spec1.
+   order.
+  Qed.
+
+  Lemma fold_spec :
+   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (flip f) (elements s) i.
+  Proof.
+  reflexivity.
+  Qed.
+
+  Lemma cardinal_spec :
+   forall (s : t) (Hs : Ok s),
+   cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_inf :
+   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
+   Inf x s -> Inf x (filter f s).
+  Proof.
+  simple induction s; simpl.
+  intuition.
+  intros x l Hrec a f Hs Ha; inv.
+  case (f x); auto.
+  apply Hrec; auto.
+  apply Inf_lt with x; auto.
+  Qed.
+
+  Global Instance filter_ok s f : forall `(Ok s), Ok (filter f s).
+  Proof.
+  repeat rewrite <- isok_iff; revert s f.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  case (f x); auto.
+  constructors; auto.
+  apply filter_inf; auto.
+  Qed.
+
+  Lemma filter_spec :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (In x (filter f s) <-> In x s /\ f x = true).
+  Proof.
+  induction s; simpl; intros.
+  split; intuition; inv.
+  destruct (f a) as [ ]_eqn:F; rewrite !InA_cons, ?IHs; intuition.
+  setoid_replace x with a; auto.
+  setoid_replace a with x in F; auto; congruence.
+  Qed.
+
+  Lemma for_all_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof.
+  unfold For_all; induction s; simpl; intros.
+  split; intros; auto. inv.
+  destruct (f a) as [ ]_eqn:F.
+  rewrite IHs; auto. firstorder. inv; auto.
+  setoid_replace x with a; auto.
+  split; intros H'. discriminate.
+  rewrite H' in F; auto.
+  Qed.
+
+  Lemma exists_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof.
+  unfold Exists; induction s; simpl; intros.
+  firstorder. discriminate. inv.
+  destruct (f a) as [ ]_eqn:F.
+  firstorder.
+  rewrite IHs; auto.
+  firstorder.
+  inv.
+  setoid_replace a with x in F; auto; congruence.
+  exists x; auto.
+  Qed.
+
+  Lemma partition_inf1 :
+   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
+   Inf x s -> Inf x (fst (partition f s)).
+  Proof.
+  intros s f x; repeat rewrite <- isok_iff; revert s f x.
+  simple induction s; simpl.
+  intuition.
+  intros x l Hrec f a Hs Ha; inv.
+  generalize (Hrec f a H).
+  case (f x); case (partition f l); simpl.
+  auto.
+  intros; apply H2; apply Inf_lt with x; auto.
+  Qed.
+
+  Lemma partition_inf2 :
+   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
+   Inf x s -> Inf x (snd (partition f s)).
+  Proof.
+  intros s f x; repeat rewrite <- isok_iff; revert s f x.
+  simple induction s; simpl.
+  intuition.
+  intros x l Hrec f a Hs Ha; inv.
+  generalize (Hrec f a H).
+  case (f x); case (partition f l); simpl.
+  intros; apply H2; apply Inf_lt with x; auto.
+  auto.
+  Qed.
+
+  Global Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)).
+  Proof.
+  repeat rewrite <- isok_iff; revert s f.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (Hrec f H); generalize (@partition_inf1 l f x).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+
+  Global Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)).
+  Proof.
+  repeat rewrite <- isok_iff; revert s f.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (Hrec f H); generalize (@partition_inf2 l f x).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+
+  Lemma partition_spec1 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  split; auto.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  destruct (partition f l) as [s1 s2]; simpl; intros.
+  case (f x); simpl; auto.
+  split; inversion_clear 1; auto.
+  constructor 2; rewrite <- H; auto.
+  constructor 2; rewrite H; auto.
+  Qed.
+
+  Lemma partition_spec2 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  split; auto.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  destruct (partition f l) as [s1 s2]; simpl; intros.
+  case (f x); simpl; auto.
+  split; inversion_clear 1; auto.
+  constructor 2; rewrite <- H; auto.
+  constructor 2; rewrite H; auto.
+  Qed.
+
+  End ForNotations.
+
+  Definition In := InA X.eq.
+  Instance In_compat : Proper (X.eq==>eq==> iff) In.
+  Proof. repeat red; intros; rewrite H, H0; auto. Qed.
+
+  Module L := MakeListOrdering X.
+  Definition eq := L.eq.
+  Definition eq_equiv := L.eq_equiv.
+  Definition lt l1 l2 :=
+    exists l1', exists l2', Ok l1' /\ Ok l2' /\
+      eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  split.
+  intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
+  repeat rewrite <- isok_iff in *.
+  assert (eqlistA X.eq s1 s2).
+   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
+   transitivity s; auto. symmetry; auto.
+  rewrite H in L.
+  apply (StrictOrder_Irreflexive s2); auto.
+  intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
+                  (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
+  exists s1', s3'.
+  repeat rewrite <- isok_iff in *.
+  do 4 (split; trivial).
+  assert (eqlistA X.eq s2' s2'').
+   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
+   transitivity s2; auto. symmetry; auto.
+  transitivity s2'; auto.
+  rewrite H; auto.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  intros s1 s2 E12 s3 s4 E34. split.
+  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+  exists s1', s3'; do 2 (split; trivial).
+   split. transitivity s1; auto. symmetry; auto.
+   split; auto. transitivity s3; auto. symmetry; auto.
+  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+  exists s1', s3'; do 2 (split; trivial).
+   split. transitivity s2; auto.
+   split; auto. transitivity s4; auto.
+  Qed.
+
+  Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s').
+  Proof.
+  induction s as [|x s IH]; intros [|x' s']; simpl; intuition.
+  elim_compare x x'; auto.
+  Qed.
+
+  Lemma compare_spec : forall s s', Ok s -> Ok s' ->
+   CompSpec eq lt s s' (compare s s').
+  Proof.
+  intros s s' Hs Hs'.
+  destruct (compare_spec_aux s s'); constructor; auto.
+  exists s, s'; repeat split; auto using @ok.
+  exists s', s; repeat split; auto using @ok.
+  Qed.
+
+End MakeRaw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we
+   need to encapsulate everything into a type of strictly ordered lists. *)
+
+Module Make (X: OrderedType) <: S with Module E := X.
+ Module Raw := MakeRaw X.
+ Include Raw2Sets X Raw.
+End Make.
+
+(** For this specific implementation, eq coincides with Leibniz equality *)
+
+Require Eqdep_dec.
+
+Module Type OrderedTypeWithLeibniz.
+  Include OrderedType.
+  Parameter eq_leibniz : forall x y, eq x y -> x = y.
+End OrderedTypeWithLeibniz.
+
+Module Type SWithLeibniz.
+  Declare Module E : OrderedTypeWithLeibniz.
+  Include SetsOn E.
+  Parameter eq_leibniz : forall x y, eq x y -> x = y.
+End SWithLeibniz.
+
+Module MakeWithLeibniz (X: OrderedTypeWithLeibniz) <: SWithLeibniz with Module E := X.
+  Module E := X.
+  Module Raw := MakeRaw X.
+  Include Raw2SetsOn X Raw.
+
+  Lemma eq_leibniz_list : forall xs ys, eqlistA X.eq xs ys -> xs = ys.
+  Proof.
+    induction xs as [|x xs]; intros [|y ys] H; inversion H; [ | ].
+    reflexivity.
+    f_equal.
+    apply X.eq_leibniz; congruence.
+    apply IHxs; subst; assumption.
+  Qed.
+
+  Lemma eq_leibniz : forall s s', eq s s' -> s = s'.
+  Proof.
+    intros [xs Hxs] [ys Hys] Heq.
+    change (equivlistA X.eq xs ys) in Heq.
+    assert (H : eqlistA X.eq xs ys).
+      rewrite <- Raw.isok_iff in Hxs, Hys.
+      apply SortA_equivlistA_eqlistA with X.lt; auto with *.
+    apply eq_leibniz_list in H.
+    subst ys.
+    f_equal.
+    apply Eqdep_dec.eq_proofs_unicity.
+    intros x y; destruct (bool_dec x y); tauto.
+  Qed.
+
+End MakeWithLeibniz.
diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v
new file mode 100644
index 00000000..e83ac27d
--- /dev/null
+++ b/theories/MSets/MSetPositive.v
@@ -0,0 +1,1149 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** Efficient implementation of [MSetInterface.S] for positive keys,
+    inspired from the [FMapPositive] module.
+
+   This module was adapted by Alexandre Ren, Damien Pous, and Thomas
+   Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive]
+   module of Pierre Letouzey and Jean-Christophe Filliâtre, which in
+   turn comes from the [FMap] framework of a work by Xavier Leroy and
+   Sandrine Blazy (used for building certified compilers).
+*)
+
+Require Import Bool BinPos Orders MSetInterface.
+
+Set Implicit Arguments.
+
+Local Open Scope lazy_bool_scope.
+Local Open Scope positive_scope.
+
+Local Unset Elimination Schemes.
+Local Unset Case Analysis Schemes.
+Local Unset Boolean Equality Schemes.
+
+
+(** Even if [positive] can be seen as an ordered type with respect to the
+  usual order (see above), we can also use a lexicographic order over bits
+  (lower bits are considered first). This is more natural when using
+  [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)
+
+Module PositiveOrderedTypeBits <: UsualOrderedType.
+  Definition t:=positive.
+  Include HasUsualEq <+ UsualIsEq.
+  Definition eqb := Peqb.
+  Definition eqb_eq := Peqb_eq.
+  Include HasEqBool2Dec.
+
+  Fixpoint bits_lt (p q:positive) : Prop :=
+   match p, q with
+   | xH, xI _ => True
+   | xH, _ => False
+   | xO p, xO q => bits_lt p q
+   | xO _, _ => True
+   | xI p, xI q => bits_lt p q
+   | xI _, _ => False
+   end.
+
+  Definition lt:=bits_lt.
+
+  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
+  Proof.
+   induction x; simpl; auto.
+  Qed.
+
+  Lemma bits_lt_trans :
+    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
+  Proof.
+   induction x; destruct y,z; simpl; eauto; intuition.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+   intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
+  Qed.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+   split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
+  Qed.
+
+  Fixpoint compare x y :=
+    match x, y with
+      | x~1, y~1 => compare x y
+      | x~1, _ => Gt
+      | x~0, y~0 => compare x y
+      | x~0, _ => Lt
+      | 1, y~1 => Lt
+      | 1, 1 => Eq
+      | 1, y~0 => Gt
+    end.
+
+  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+  Proof.
+   unfold eq, lt.
+   induction x; destruct y; try constructor; simpl; auto.
+    destruct (IHx y); subst; auto.
+    destruct (IHx y); subst; auto.
+  Qed.
+
+End PositiveOrderedTypeBits.
+
+Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
+
+  Module E:=PositiveOrderedTypeBits.
+
+  Definition elt := positive.
+
+  Inductive tree :=
+    | Leaf : tree
+    | Node : tree -> bool -> tree -> tree.
+
+  Scheme tree_ind := Induction for tree Sort Prop.
+
+  Definition t := tree.
+
+  Definition empty := Leaf.
+
+  Fixpoint is_empty (m : t) : bool :=
+   match m with
+    | Leaf => true
+    | Node l b r => negb b &&& is_empty l &&& is_empty r
+   end.
+
+  Fixpoint mem (i : positive) (m : t) : bool :=
+    match m with
+    | Leaf => false
+    | Node l o r =>
+        match i with
+        | 1 => o
+        | i~0 => mem i l
+        | i~1 => mem i r
+        end
+    end.
+
+  Fixpoint add (i : positive) (m : t) : t :=
+    match m with
+    | Leaf =>
+        match i with
+        | 1 => Node Leaf true Leaf
+        | i~0 => Node (add i Leaf) false Leaf
+        | i~1 => Node Leaf false (add i Leaf)
+        end
+    | Node l o r =>
+        match i with
+        | 1 => Node l true r
+        | i~0 => Node (add i l) o r
+        | i~1 => Node l o (add i r)
+        end
+    end.
+
+  Definition singleton i := add i empty.
+
+  (** helper function to avoid creating empty trees that are not leaves *)
+
+  Definition node l (b: bool) r :=
+    if b then Node l b r else
+     match l,r with
+       | Leaf,Leaf => Leaf
+       | _,_ => Node l false r end.
+
+  Fixpoint remove (i : positive) (m : t) : t :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match i with
+          | 1 => node l false r
+          | i~0 => node (remove i l) o r
+          | i~1 => node l o (remove i r)
+        end
+    end.
+
+  Fixpoint union (m m': t) :=
+    match m with
+      | Leaf => m'
+      | Node l o r =>
+        match m' with
+          | Leaf => m
+          | Node l' o' r' => Node (union l l') (o||o') (union r r')
+        end
+    end.
+
+  Fixpoint inter (m m': t) :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match m' with
+          | Leaf => Leaf
+          | Node l' o' r' => node (inter l l') (o&&o') (inter r r')
+        end
+    end.
+
+  Fixpoint diff (m m': t) :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match m' with
+          | Leaf => m
+          | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
+        end
+    end.
+
+  Fixpoint equal (m m': t): bool :=
+    match m with
+      | Leaf => is_empty m'
+      | Node l o r =>
+        match m' with
+          | Leaf => is_empty m
+          | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
+        end
+    end.
+
+  Fixpoint subset (m m': t): bool :=
+    match m with
+      | Leaf => true
+      | Node l o r =>
+        match m' with
+          | Leaf => is_empty m
+          | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
+        end
+    end.
+
+  (** reverses [y] and concatenate it with [x] *)
+
+  Fixpoint rev_append y x :=
+    match y with
+      | 1 => x
+      | y~1 => rev_append y x~1
+      | y~0 => rev_append y x~0
+    end.
+  Infix "@" := rev_append (at level 60).
+  Definition rev x := x@1.
+
+  Section Fold.
+
+    Variables B : Type.
+    Variable f : positive -> B -> B.
+
+    (** the additional argument, [i], records the current path, in
+       reverse order (this should be more efficient: we reverse this argument
+       only at present nodes only, rather than at each node of the tree).
+       we also use this convention in all functions below
+     *)
+
+    Fixpoint xfold (m : t) (v : B) (i : positive) :=
+      match m with
+        | Leaf => v
+        | Node l true r =>
+          xfold r (f (rev i) (xfold l v i~0)) i~1
+        | Node l false r =>
+          xfold r (xfold l v i~0) i~1
+      end.
+    Definition fold m i := xfold m i 1.
+
+  End Fold.
+
+  Section Quantifiers.
+
+    Variable f : positive -> bool.
+
+    Fixpoint xforall (m : t) (i : positive) :=
+      match m with
+        | Leaf => true
+        | Node l o r =>
+          (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
+      end.
+    Definition for_all m := xforall m 1.
+
+    Fixpoint xexists (m : t) (i : positive) :=
+      match m with
+        | Leaf => false
+        | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
+      end.
+    Definition exists_ m := xexists m 1.
+
+    Fixpoint xfilter (m : t) (i : positive) :=
+      match m with
+        | Leaf => Leaf
+        | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
+      end.
+    Definition filter m := xfilter m 1.
+
+    Fixpoint xpartition (m : t) (i : positive) :=
+      match m with
+        | Leaf => (Leaf,Leaf)
+        | Node l o r =>
+          let (lt,lf) := xpartition l i~0 in
+          let (rt,rf) := xpartition r i~1 in
+             if o then
+               let fi := f (rev i) in
+                 (node lt fi rt, node lf (negb fi) rf)
+             else
+                 (node lt false rt, node lf false rf)
+      end.
+    Definition partition m := xpartition m 1.
+
+  End Quantifiers.
+
+  (** uses [a] to accumulate values rather than doing a lot of concatenations *)
+
+  Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
+    match m with
+      | Leaf => a
+      | Node l false r => xelements l i~0 (xelements r i~1 a)
+      | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
+    end.
+
+  Definition elements (m : t) := xelements m 1 nil.
+
+  Fixpoint cardinal (m : t) : nat :=
+    match m with
+      | Leaf => O
+      | Node l false r => (cardinal l + cardinal r)%nat
+      | Node l true r => S (cardinal l + cardinal r)
+    end.
+
+  Definition omap (f: elt -> elt) x :=
+    match x with
+      | None => None
+      | Some i => Some (f i)
+    end.
+
+  (** would it be more efficient to use a path like in the above functions ? *)
+
+  Fixpoint choose (m: t) :=
+    match m with
+      | Leaf => None
+      | Node l o r => if o then Some 1 else
+        match choose l with
+          | None => omap xI (choose r)
+          | Some i => Some i~0
+        end
+    end.
+
+  Fixpoint min_elt (m: t) :=
+    match m with
+      | Leaf => None
+      | Node l o r =>
+        match min_elt l with
+          | None => if o then Some 1 else omap xI (min_elt r)
+          | Some i => Some i~0
+        end
+    end.
+
+  Fixpoint max_elt (m: t) :=
+    match m with
+      | Leaf => None
+      | Node l o r =>
+        match max_elt r with
+          | None => if o then Some 1 else omap xO (max_elt l)
+          | Some i => Some i~1
+        end
+    end.
+
+  (** lexicographic product, defined using a notation to keep things lazy *)
+
+  Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.
+
+  Definition compare_bool a b :=
+    match a,b with
+      | false, true => Lt
+      | true, false => Gt
+      | _,_ => Eq
+    end.
+
+  Fixpoint compare (m m': t): comparison :=
+    match m,m' with
+      | Leaf,_ => if is_empty m' then Eq else Lt
+      | _,Leaf => if is_empty m then Eq else Gt
+      | Node l o r,Node l' o' r' =>
+        lex (compare_bool o o') (lex (compare l l') (compare r r'))
+    end.
+
+
+  Definition In i t := mem i t = true.
+  Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
+  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
+
+  Definition eq := Equal.
+  Definition lt m m' := compare m m' = Lt.
+
+  (** Specification of [In] *)
+
+  Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
+  Proof.
+   intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition.
+  Qed.
+
+  (** Specification of [eq] *)
+
+  Local Instance eq_equiv : Equivalence eq.
+  Proof. firstorder. Qed.
+
+  (** Specification of [mem] *)
+
+  Lemma mem_spec: forall s x, mem x s = true <-> In x s.
+  Proof. unfold In. intuition. Qed.
+
+  (** Additional lemmas for mem  *)
+
+  Lemma mem_Leaf: forall x, mem x Leaf = false.
+  Proof. destruct x; trivial. Qed.
+
+  (** Specification of [empty] *)
+
+  Lemma empty_spec : Empty empty.
+  Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.
+
+  (** Specification of node  *)
+
+  Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
+  Proof.
+    intros x l o r.
+    case o; trivial.
+    destruct l; trivial.
+    destruct r; trivial.
+    symmetry. destruct x.
+      apply mem_Leaf.
+      apply mem_Leaf.
+      reflexivity.
+  Qed.
+  Local Opaque node.
+
+  (** Specification of [is_empty] *)
+
+  Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s.
+  Proof.
+    unfold Empty, In.
+    induction s as [|l IHl o r IHr]; simpl.
+      setoid_rewrite mem_Leaf. firstorder.
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr.
+      destruct o; simpl; split.
+        intuition discriminate.
+        intro H. elim (H 1). reflexivity.
+        intros H [a|a|]; apply H || intro; discriminate.
+        intro H. split. split. reflexivity.
+          intro a. apply (H a~0).
+          intro a. apply (H a~1).
+  Qed.
+
+  (** Specification of [subset] *)
+
+  Lemma subset_Leaf_s: forall s, Leaf [<=] s.
+  Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed.
+
+  Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'.
+  Proof.
+    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
+      split; intros. apply subset_Leaf_s. reflexivity.
+
+      split; intros. apply subset_Leaf_s. reflexivity.
+
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec.
+      destruct o; simpl.
+        split.
+          intuition discriminate.
+          intro H. elim (@empty_spec 1). apply H. reflexivity.
+        split; intro H.
+          destruct H as [[_ Hl] Hr].
+          intros [i|i|] Hi.
+            elim (Hr i Hi).
+            elim (Hl i Hi).
+            discriminate.
+          split. split. reflexivity.
+          unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption.
+          unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption.
+
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear.
+      destruct o; simpl.
+       split; intro H.
+         destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
+          intros i Hi. destruct i.
+            apply (Hr i). assumption.
+            apply (Hl i). assumption.
+            assumption.
+         split. split.
+          destruct o'; trivial.
+          specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
+          intros i Hi. apply (H i~0). apply Hi.
+          intros i Hi. apply (H i~1). apply Hi.
+       split; intros.
+         intros i Hi. destruct i; destruct H as [[H Hl] Hr].
+           apply (Hr i). assumption.
+           apply (Hl i). assumption.
+            discriminate Hi.
+         split. split. reflexivity.
+           intros i Hi. apply (H i~0). apply Hi.
+           intros i Hi. apply (H i~1). apply Hi.
+  Qed.
+
+  (** Specification of [equal] (via subset) *)
+
+  Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
+  Proof.
+    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
+      destruct o. reflexivity. rewrite andb_comm. reflexivity.
+      rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
+       rewrite 7andb_true_iff, eqb_true_iff.
+      rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
+       destruct o'; reflexivity.
+       destruct o'; reflexivity.
+       destruct o; auto. destruct o'; trivial.
+  Qed.
+
+  Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'.
+  Proof.
+    intros. rewrite equal_subset. rewrite andb_true_iff.
+    rewrite 2subset_spec. unfold Equal, Subset. firstorder.
+  Qed.
+
+  Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
+  Proof.
+    unfold eq.
+    intros. case_eq (equal s s'); intro H.
+     left. apply equal_spec, H.
+     right. rewrite <- equal_spec. congruence.
+  Defined.
+
+  (** (Specified) definition of [compare] *)
+
+  Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
+    lex u v = CompOpp (lex u' v').
+  Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed.
+
+  Lemma compare_bool_inv: forall b b',
+    compare_bool b b' = CompOpp (compare_bool b' b).
+  Proof. intros [|] [|]; reflexivity. Qed.
+
+  Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s).
+  Proof.
+    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
+    unfold compare. case is_empty; reflexivity.
+    unfold compare. case is_empty; reflexivity.
+    simpl. rewrite compare_bool_inv.
+     case compare_bool; simpl; trivial; apply lex_Opp; auto.
+  Qed.
+
+  Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
+  Proof. intros u v; destruct u; intuition discriminate. Qed.
+
+  Lemma compare_bool_Eq: forall b1 b2,
+    compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
+  Proof. intros [|] [|]; intuition discriminate. Qed.
+
+  Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
+     simpl. tauto.
+     unfold compare, equal. case is_empty; intuition discriminate.
+     unfold compare, equal. case is_empty; intuition discriminate.
+     simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
+     rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
+     rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
+  Qed.
+
+
+  Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s.
+  Proof.
+    unfold lt. intros s s'. rewrite compare_inv.
+     case compare; trivial; intros; discriminate.
+  Qed.
+
+  Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'.
+  Proof.
+    unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
+  Qed.
+
+  Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s').
+  Proof.
+    intros. case_eq (compare s s'); intro H; constructor.
+    apply compare_eq, H.
+    assumption.
+    apply compare_gt, H.
+  Qed.
+
+  Section lt_spec.
+
+  Inductive ct: comparison -> comparison -> comparison -> Prop :=
+  | ct_xxx: forall x, ct x  x  x
+  | ct_xex: forall x, ct x  Eq x
+  | ct_exx: forall x, ct Eq x  x
+  | ct_glx: forall x, ct Gt Lt x
+  | ct_lgx: forall x, ct Lt Gt x.
+
+  Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_lxl: forall x, ct Lt x Lt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_gxg: forall x, ct Gt x Gt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xll: forall x, ct x Lt Lt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xgg: forall x, ct x Gt Gt.
+  Proof. destruct x; constructor. Qed.
+
+  Local Hint Constructors ct: ct.
+  Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
+  Ltac ct := trivial with ct.
+
+  Lemma ct_lex: forall u v w u' v' w',
+    ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
+  Proof.
+    intros u v w u' v' w' H H'.
+    inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
+  Qed.
+
+  Lemma ct_compare_bool:
+    forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
+  Proof.
+    intros [|] [|] [|]; constructor.
+  Qed.
+
+  Lemma compare_x_Leaf: forall s,
+    compare s Leaf = if is_empty s then Eq else Gt.
+  Proof.
+    intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
+  Qed.
+
+  Lemma compare_empty_x: forall a, is_empty a = true ->
+    forall b, compare a b = if is_empty b then Eq else Lt.
+  Proof.
+    induction a as [|l IHl o r IHr]; trivial.
+    destruct o. intro; discriminate.
+    simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
+    intros [Hl Hr].
+    destruct b as [|l' [|] r']; simpl compare; trivial.
+     rewrite Hl, Hr. trivial.
+     rewrite (IHl Hl), (IHr Hr). simpl.
+     case (is_empty l'); case (is_empty r'); trivial.
+  Qed.
+
+  Lemma compare_x_empty: forall a, is_empty a = true ->
+    forall b, compare b a = if is_empty b then Eq else Gt.
+  Proof.
+    setoid_rewrite <- compare_x_Leaf.
+    intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
+  Qed.
+
+  Lemma ct_compare:
+    forall a b c, ct (compare a b) (compare b c) (compare a c).
+  Proof.
+    induction a as [|l IHl o r IHr]; intros s' s''.
+     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
+      rewrite compare_inv. ct.
+      unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'.
+       rewrite (compare_empty_x _ H'). ct.
+       unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
+        rewrite (compare_x_empty _ H''), H'. ct.
+        ct.
+
+     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
+      ct.
+      unfold compare at 2. rewrite compare_x_Leaf.
+      case_eq (is_empty (Node l o r)); intro H.
+       rewrite (compare_empty_x _ H). ct.
+       case_eq (is_empty (Node l'' o'' r'')); intro H''.
+        rewrite (compare_x_empty _ H''), H. ct.
+        ct.
+
+      rewrite 2 compare_x_Leaf.
+      case_eq (is_empty (Node l o r)); intro H.
+       rewrite compare_inv, (compare_x_empty _ H). ct.
+       case_eq (is_empty (Node l' o' r')); intro H'.
+        rewrite (compare_x_empty _ H'), H. ct.
+        ct.
+
+      simpl compare. apply ct_lex. apply ct_compare_bool.
+       apply ct_lex; trivial.
+  Qed.
+
+  End lt_spec.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+   unfold lt. split.
+   intros x H.
+   assert (compare x x = Eq).
+    apply compare_equal, equal_spec. reflexivity.
+   congruence.
+   intros a b c. assert (H := ct_compare a b c).
+    inversion_clear H; trivial; intros; discriminate.
+  Qed.
+
+  Local Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare.
+  Proof.
+   intros x x' Hx y y' Hy. subst y'.
+   unfold eq in *. rewrite <- equal_spec, <- compare_equal in *.
+   assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto.
+  Qed.
+
+  Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
+  Proof.
+   intros x x' Hx y y' Hy. rewrite Hx.
+   rewrite compare_inv, Hy, <- compare_inv. reflexivity.
+  Qed.
+
+  Local Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+   intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition.
+  Qed.
+
+  (** Specification of [add] *)
+
+  Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s.
+  Proof.
+    unfold In. intros s x y; revert x y s.
+    induction x; intros [y|y|] [|l o r]; simpl mem;
+    try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
+  Qed.
+
+  (** Specification of [remove] *)
+
+  Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x.
+  Proof.
+    unfold In. intros s x y; revert x y s.
+    induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
+     simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
+     intuition congruence.
+  Qed.
+
+  (** Specification of [singleton] *)
+
+  Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x.
+  Proof.
+    unfold singleton. intros x y. rewrite add_spec. intuition.
+    unfold In in *. rewrite mem_Leaf in *. discriminate.
+  Qed.
+
+  (** Specification of [union] *)
+
+  Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+    unfold In. intros s s' x; revert x s s'.
+    induction x; destruct s; destruct s'; simpl union; simpl mem;
+      try (rewrite IHx; clear IHx); try intuition congruence.
+      apply orb_true_iff.
+  Qed.
+
+  (** Specification of [inter] *)
+
+  Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+    unfold In. intros s s' x; revert x s s'.
+    induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
+     simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
+     apply andb_true_iff.
+  Qed.
+
+  (** Specification of [diff] *)
+
+  Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'.
+  Proof.
+    unfold In. intros s s' x; revert x s s'.
+    induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
+     rewrite ?mem_node; simpl mem;
+      try (rewrite IHx; clear IHx); try intuition congruence.
+      rewrite andb_true_iff. destruct o'; intuition discriminate.
+  Qed.
+
+  (** Specification of [fold] *)
+
+  Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+    unfold fold, elements. intros s A i f. revert s i.
+    set (f' := fun a e => f e a).
+    assert (H: forall s i j acc,
+      fold_left f' acc (xfold f s i j) =
+      fold_left f' (xelements s j acc) i).
+
+    induction s as [|l IHl o r IHr]; intros; trivial.
+      destruct o; simpl xelements; simpl xfold.
+        rewrite IHr, <- IHl. reflexivity.
+        rewrite IHr. apply IHl.
+
+    intros. exact (H s i 1 nil).
+  Qed.
+
+  (** Specification of [cardinal] *)
+
+  Lemma cardinal_spec: forall s, cardinal s = length (elements s).
+  Proof.
+    unfold elements.
+    assert (H: forall s j acc,
+                (cardinal s + length acc)%nat = length (xelements s j acc)).
+
+    induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
+      rewrite <- IHl. simpl. rewrite <- IHr.
+       rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
+      rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.
+
+    intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
+  Qed.
+
+  (** Specification of [filter] *)
+
+  Lemma xfilter_spec: forall f s x i,
+    In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
+  Proof.
+    intro f. unfold In.
+    induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
+     rewrite mem_Leaf. intuition discriminate.
+     rewrite mem_node. destruct x; simpl.
+       rewrite IHr. reflexivity.
+       rewrite IHl. reflexivity.
+       rewrite <- andb_lazy_alt. apply andb_true_iff.
+  Qed.
+
+  Lemma filter_spec: forall s x f, compat_bool E.eq f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Proof. intros. apply xfilter_spec. Qed.
+
+  (** Specification of [for_all] *)
+
+  Lemma xforall_spec: forall f s i,
+    xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
+  Proof.
+    unfold For_all, In. intro f.
+    induction s as [|l IHl o r IHr]; intros i; simpl.
+     setoid_rewrite mem_Leaf. intuition discriminate.
+     rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
+     rewrite IHl, IHr. clear IHl IHr.
+      split.
+       intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
+        apply Hr, H.
+        apply Hl, H.
+        rewrite H in Hi. assumption.
+       intro H; intuition.
+        specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
+        apply H. assumption.
+        apply H. assumption.
+  Qed.
+
+  Lemma for_all_spec: forall s f, compat_bool E.eq f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof. intros. apply xforall_spec. Qed.
+
+  (** Specification of [exists] *)
+
+  Lemma xexists_spec: forall f s i,
+    xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
+  Proof.
+    unfold Exists, In. intro f.
+    induction s as [|l IHl o r IHr]; intros i; simpl.
+     setoid_rewrite mem_Leaf. firstorder.
+     rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
+     rewrite IHl, IHr. clear IHl IHr.
+      split.
+       intros [[Hi|[x Hr]]|[x Hl]].
+        exists 1. exact Hi.
+        exists x~1. exact Hr.
+        exists x~0. exact Hl.
+       intros [[x|x|] H]; eauto.
+  Qed.
+
+  Lemma exists_spec : forall s f, compat_bool E.eq f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof. intros. apply xexists_spec. Qed.
+
+
+  (** Specification of [partition] *)
+
+  Lemma partition_filter : forall s f,
+    partition f s = (filter f s, filter (fun x => negb (f x)) s).
+  Proof.
+    unfold partition, filter. intros s f. generalize 1 as j.
+    induction s as [|l IHl o r IHr]; intro j.
+      reflexivity.
+      destruct o; simpl; rewrite IHl, IHr; reflexivity.
+  Qed.
+
+  Lemma partition_spec1 : forall s f, compat_bool E.eq f ->
+      Equal (fst (partition f s)) (filter f s).
+  Proof. intros. rewrite partition_filter. reflexivity. Qed.
+
+  Lemma partition_spec2 : forall s f, compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. intros. rewrite partition_filter. reflexivity. Qed.
+
+
+  (** Specification of [elements] *)
+
+  Notation InL := (InA E.eq).
+
+  Lemma xelements_spec: forall s j acc y,
+    InL y (xelements s j acc)
+    <->
+    InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; simpl.
+      intros. split; intro H.
+        left. assumption.
+        destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_spec Hx').
+
+      intros j acc y. case o.
+        rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
+          intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
+            right. exists x~1. auto.
+            right. exists x~0. auto.
+          intros [H|[x [-> H]]].
+            eauto.
+            destruct x.
+              left. right. right. exists x; auto.
+              right. exists x; auto.
+              left. left. reflexivity.
+
+        rewrite IHl, IHr. clear IHl IHr. split.
+          intros [[H|[x [-> H]]]|[x [-> H]]].
+            eauto.
+            right. exists x~1. auto.
+            right. exists x~0. auto.
+          intros [H|[x [-> H]]].
+            eauto.
+            destruct x.
+              left. right.  exists x; auto.
+              right. exists x; auto.
+              discriminate.
+  Qed.
+
+  Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s.
+  Proof.
+   unfold elements. intros. rewrite xelements_spec.
+   split; [ intros [A|(y & B & C)] | intros IN ].
+   inversion A. simpl in *. congruence.
+   right. exists x. auto.
+  Qed.
+
+  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
+  Proof. induction j; intros; simpl; auto. Qed.
+
+  Lemma elements_spec2: forall s, sort E.lt (elements s).
+  Proof.
+    unfold elements.
+    assert (H: forall s j acc,
+      sort E.lt acc ->
+      (forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
+      sort E.lt (xelements s j acc)).
+
+    induction s as [|l IHl o r IHr]; simpl; trivial.
+    intros j acc Hacc Hsacc. destruct o.
+      apply IHl. constructor.
+       apply IHr. apply Hacc.
+       intros x y Hx Hy. apply Hsacc; assumption.
+       case_eq (xelements r j~1 acc). constructor.
+       intros z q H. constructor.
+       assert (H': InL z (xelements r j~1 acc)).
+        rewrite H. constructor. reflexivity.
+       clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
+         apply (Hsacc 1 z); trivial. reflexivity.
+         simpl. apply lt_rev_append. exact I.
+       intros x y Hx Hy. inversion_clear Hy.
+         rewrite H. simpl. apply lt_rev_append. exact I.
+         rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
+           apply Hsacc; assumption.
+           simpl. apply lt_rev_append. exact I.
+
+      apply IHl. apply IHr. apply Hacc.
+       intros x y Hx Hy. apply Hsacc; assumption.
+       intros x y Hx Hy. rewrite xelements_spec in Hy.
+        destruct Hy as [Hy|[z [-> Hy]]].
+         apply Hsacc; assumption.
+         simpl. apply lt_rev_append. exact I.
+
+    intros. apply H. constructor.
+      intros x y _ H'. inversion H'.
+  Qed.
+
+  Lemma elements_spec2w: forall s, NoDupA E.eq (elements s).
+  Proof.
+    intro. apply SortA_NoDupA with E.lt; auto with *.
+    apply E.eq_equiv.
+    apply elements_spec2.
+  Qed.
+
+
+  (** Specification of [choose] *)
+
+  Lemma choose_spec1: forall s x, choose s = Some x -> In x s.
+  Proof.
+    induction s as [| l IHl o r IHr]; simpl.
+      intros. discriminate.
+      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.
+           reflexivity.
+          intros _ x. revert IHr. case choose.
+            intros p Hp H. injection H; intros; subst; clear H. apply Hp.
+            reflexivity.
+            intros. discriminate.
+  Qed.
+
+  Lemma choose_spec2: forall s, choose s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_spec.
+      destruct o.
+        discriminate.
+        simpl in H. destruct (choose l).
+          discriminate.
+          destruct (choose r).
+            discriminate.
+            intros [a|a|].
+              apply IHr. reflexivity.
+              apply IHl. reflexivity.
+              discriminate.
+  Qed.
+
+  Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
+  Proof.
+    intros s Hs. case_eq (choose s); trivial.
+    intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs.
+     elim (Hs _ Hp).
+  Qed.
+
+  Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'.
+  Proof.
+    setoid_rewrite <- equal_spec.
+    induction s as [|l IHl o r IHr].
+      intros. symmetry. apply choose_empty. assumption.
+
+      destruct s' as [|l' o' r'].
+        generalize (Node l o r) as s. simpl. intros. apply choose_empty.
+        rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H.
+        assumption.
+
+        simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
+        intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
+  Qed.
+
+  Lemma choose_spec3: forall s s' x y,
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
+  Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed.
+
+
+  (** Specification of [min_elt] *)
+
+  Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s.
+  Proof.
+   unfold In.
+   induction s as [| l IHl o r IHr]; simpl.
+     intros. discriminate.
+     intros x. destruct (min_elt l); intros.
+       injection H. intros <-. apply IHl. reflexivity.
+       destruct o; simpl.
+         injection H. intros <-. reflexivity.
+         destruct (min_elt r); simpl in *.
+           injection H. intros <-. apply IHr. reflexivity.
+           discriminate.
+  Qed.
+
+  Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_spec.
+      intros [a|a|].
+        apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
+          case min_elt; intros; try discriminate. destruct o; discriminate.
+        apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
+         intro; discriminate.
+        revert H. clear. simpl. case min_elt; intros; try discriminate.
+         destruct o; discriminate.
+  Qed.
+
+  Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Proof.
+    unfold In.
+    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 <-.
+        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.
+          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
+
+          destruct (min_elt r).
+            injection H. intros <-. clear H.
+            destruct y as [z|z|].
+              apply (IHr p z); trivial.
+              elim (Hp _ H').
+              discriminate.
+            discriminate.
+  Qed.
+
+
+  (** Specification of [max_elt] *)
+
+  Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s.
+  Proof.
+   unfold In.
+   induction s as [| l IHl o r IHr]; simpl.
+     intros. discriminate.
+     intros x. destruct (max_elt r); intros.
+       injection H. intros <-. apply IHr. reflexivity.
+       destruct o; simpl.
+         injection H. intros <-. reflexivity.
+         destruct (max_elt l); simpl in *.
+           injection H. intros <-. apply IHl. reflexivity.
+           discriminate.
+  Qed.
+
+  Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_spec.
+      intros [a|a|].
+        apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
+         intro; discriminate.
+        apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
+          case max_elt; intros; try discriminate. destruct o; discriminate.
+        revert H. clear. simpl. case max_elt; intros; try discriminate.
+         destruct o; discriminate.
+  Qed.
+
+  Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Proof.
+    unfold In.
+    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 <-.
+        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.
+          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
+
+          destruct (max_elt l).
+            injection H. intros <-. clear H.
+            destruct y as [z|z|].
+              elim (Hp _ H').
+              apply (IHl p z); trivial.
+              discriminate.
+            discriminate.
+  Qed.
+
+End PositiveSet.
diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v
new file mode 100644
index 00000000..c0038a4f
--- /dev/null
+++ b/theories/MSets/MSetProperties.v
@@ -0,0 +1,1176 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional properties from [MSetInterface.S].
+    Contrary to the functor in [MSetEqProperties] it uses
+    predicates over sets instead of sets operations, i.e.
+    [In x s] instead of [mem x s=true],
+    [Equal s s'] instead of [equal s s'=true], etc. *)
+
+Require Export MSetInterface.
+Require Import DecidableTypeEx OrdersLists MSetFacts MSetDecide.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Unfold transpose.
+
+(** First, a functor for Weak Sets in functorial version. *)
+
+Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
+  Module Import Dec := WDecideOn E M.
+  Module Import FM := Dec.F (* MSetFacts.WFactsOn E M *).
+  Import M.
+
+  Lemma In_dec : forall x s, {In x s} + {~ In x s}.
+  Proof.
+  intros; generalize (mem_iff s x); case (mem x s); intuition.
+  Qed.
+
+  Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.
+
+  Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s.
+  Proof.
+  unfold Add.
+  split; intros.
+  red; intros.
+  rewrite H; clear H.
+  fsetdec.
+  fsetdec.
+  Qed.
+
+  Ltac expAdd := repeat rewrite Add_Equal.
+
+  Section BasicProperties.
+
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x x' : elt.
+
+  Lemma equal_refl : s[=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma equal_sym : s[=]s' -> s'[=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_refl : s[<=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_equal : s[=]s' -> s[<=]s'.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_empty : empty[<=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
+  Proof. fsetdec. Qed.
+
+  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
+  Proof. fsetdec. Qed.
+
+  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
+  Proof. intuition fsetdec. Qed.
+
+  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
+  Proof. fsetdec. Qed.
+
+  Lemma add_equal : In x s -> add x s [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma add_add : add x (add x' s) [=] add x' (add x s).
+  Proof. fsetdec. Qed.
+
+  Lemma remove_equal : ~ In x s -> remove x s [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
+  Proof. fsetdec. Qed.
+
+  Lemma add_remove : In x s -> add x (remove x s) [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma singleton_equal_add : singleton x [=] add x empty.
+  Proof. fsetdec. Qed.
+
+  Lemma remove_singleton_empty :
+   In x s -> remove x s [=] empty -> singleton x [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma union_sym : union s s' [=] union s' s.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma add_union_singleton : add x s [=] union (singleton x) s.
+  Proof. fsetdec. Qed.
+
+  Lemma union_add : union (add x s) s' [=] add x (union s s').
+  Proof. fsetdec. Qed.
+
+  Lemma union_remove_add_1 :
+   union (remove x s) (add x s') [=] union (add x s) (remove x s').
+  Proof. fsetdec. Qed.
+
+  Lemma union_remove_add_2 : In x s ->
+   union (remove x s) (add x s') [=] union s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_1 : s [<=] union s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_2 : s' [<=] union s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_sym : inter s s' [=] inter s' s.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
+  Proof. fsetdec. Qed.
+
+  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_1 : inter s s' [<=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_2 : inter s s' [<=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_3 :
+   s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_diff_1 : Empty s -> Empty (diff s s').
+  Proof. fsetdec. Qed.
+
+  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma diff_subset : diff s s' [<=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
+  Proof. fsetdec. Qed.
+
+  Lemma remove_diff_singleton :
+   remove x s [=] diff s (singleton x).
+  Proof. fsetdec. Qed.
+
+  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
+  Proof. fsetdec. Qed.
+
+  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma Add_add : Add x s (add x s).
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma Add_remove : In x s -> Add x (remove x s) s.
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma inter_Add :
+   In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma union_Equal :
+   In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma inter_Add_2 :
+   ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
+  Proof. expAdd; fsetdec. Qed.
+
+  End BasicProperties.
+
+  Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set.
+  Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym
+    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3
+    subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
+    remove_equal singleton_equal_add union_subset_equal union_equal_1
+    union_equal_2 union_assoc add_union_singleton union_add union_subset_1
+    union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
+    inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
+    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1
+    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union
+    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal
+    remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
+    Equal_remove add_add : set.
+
+  (** * Properties of elements *)
+
+  Lemma elements_Empty : forall s, Empty s <-> elements s = nil.
+  Proof.
+  intros.
+  unfold Empty.
+  split; intros.
+  assert (forall a, ~ List.In a (elements s)).
+   red; intros.
+   apply (H a).
+   rewrite elements_iff.
+   rewrite InA_alt; exists a; auto with relations.
+  destruct (elements s); auto.
+  elim (H0 e); simpl; auto.
+  red; intros.
+  rewrite elements_iff in H0.
+  rewrite InA_alt in H0; destruct H0.
+  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
+  Qed.
+
+  Lemma elements_empty : elements empty = nil.
+  Proof.
+  rewrite <-elements_Empty; auto with set.
+  Qed.
+
+  (** * Conversions between lists and sets *)
+
+  Definition of_list (l : list elt) := List.fold_right add empty l.
+
+  Definition to_list := elements.
+
+  Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l.
+  Proof.
+  induction l; simpl; intro x.
+  rewrite empty_iff, InA_nil. intuition.
+  rewrite add_iff, InA_cons, IHl. intuition.
+  Qed.
+
+  Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l.
+  Proof.
+  unfold to_list; red; intros.
+  rewrite <- elements_iff; apply of_list_1.
+  Qed.
+
+  Lemma of_list_3 : forall s, of_list (to_list s) [=] s.
+  Proof.
+  unfold to_list; red; intros.
+  rewrite of_list_1; symmetry; apply elements_iff.
+  Qed.
+
+  (** * Fold *)
+
+  Section Fold.
+
+  Notation NoDup := (NoDupA E.eq).
+  Notation InA := (InA E.eq).
+
+  (** ** Induction principles for fold (contributed by S. Lescuyer) *)
+
+  (** In the following lemma, the step hypothesis is deliberately restricted
+      to the precise set s we are considering. *)
+
+  Theorem fold_rec :
+    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
+     (forall s', Empty s' -> P s' i) ->
+     (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' ->
+       P s' a -> P s'' (f x a)) ->
+     P s (fold f s i).
+  Proof.
+  intros A P f i s Pempty Pstep.
+  rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right.
+  set (l:=rev (elements s)).
+  assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
+           P s' a -> P s'' (f x a)).
+   intros; eapply Pstep; eauto.
+   rewrite elements_iff, <- InA_rev; auto with *.
+  assert (Hdup : NoDup l) by
+    (unfold l; eauto using elements_3w, NoDupA_rev with *).
+  assert (Hsame : forall x, In x s <-> InA x l) by
+    (unfold l; intros; rewrite elements_iff, InA_rev; intuition).
+  clear Pstep; clearbody l; revert s Hsame; induction l.
+  (* empty *)
+  intros s Hsame; simpl.
+  apply Pempty. intro x. rewrite Hsame, InA_nil; intuition.
+  (* step *)
+  intros s Hsame; simpl.
+  apply Pstep' with (of_list l); auto with relations.
+   inversion_clear Hdup; rewrite of_list_1; auto.
+   red. intros. rewrite Hsame, of_list_1, InA_cons; intuition.
+  apply IHl.
+   intros; eapply Pstep'; eauto.
+   inversion_clear Hdup; auto.
+   exact (of_list_1 l).
+  Qed.
+
+  (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this
+      case, [P] must be compatible with equality of sets *)
+
+  Theorem fold_rec_bis :
+    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
+     (forall s s' a, s[=]s' -> P s a -> P s' a) ->
+     (P empty i) ->
+     (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) ->
+     P s (fold f s i).
+  Proof.
+  intros A P f i s Pmorphism Pempty Pstep.
+  apply fold_rec; intros.
+  apply Pmorphism with empty; auto with set.
+  rewrite Add_Equal in H1; auto with set.
+  apply Pmorphism with (add x s'); auto with set.
+  Qed.
+
+  Lemma fold_rec_nodep :
+    forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t),
+     P i -> (forall x a, In x s -> P a -> P (f x a)) ->
+     P (fold f s i).
+  Proof.
+  intros; apply fold_rec_bis with (P:=fun _ => P); auto.
+  Qed.
+
+  (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] :
+      the step hypothesis must here be applicable to any [x].
+      At the same time, it looks more like an induction principle,
+      and hence can be easier to use. *)
+
+  Lemma fold_rec_weak :
+    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A),
+    (forall s s' a, s[=]s' -> P s a -> P s' a) ->
+    P empty i ->
+    (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) ->
+    forall s, P s (fold f s i).
+  Proof.
+  intros; apply fold_rec_bis; auto.
+  Qed.
+
+  Lemma fold_rel :
+    forall (A B:Type)(R : A -> B -> Type)
+     (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t),
+     R i j ->
+     (forall x a b, In x s -> R a b -> R (f x a) (g x b)) ->
+     R (fold f s i) (fold g s j).
+  Proof.
+  intros A B R f g i j s Rempty Rstep.
+  do 2 (rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right).
+  set (l:=rev (elements s)).
+  assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
+    (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *).
+  clearbody l; clear Rstep s.
+  induction l; simpl; auto with relations.
+  Qed.
+
+  (** From the induction principle on [fold], we can deduce some general
+      induction principles on sets. *)
+
+  Lemma set_induction :
+   forall P : t -> Type,
+   (forall s, Empty s -> P s) ->
+   (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
+   forall s, P s.
+  Proof.
+  intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
+  Qed.
+
+  Lemma set_induction_bis :
+   forall P : t -> Type,
+   (forall s s', s [=] s' -> P s -> P s') ->
+   P empty ->
+   (forall x s, ~In x s -> P s -> P (add x s)) ->
+   forall s, P s.
+  Proof.
+  intros.
+  apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
+  Qed.
+
+  (** [fold] can be used to reconstruct the same initial set. *)
+
+  Lemma fold_identity : forall s, fold add s empty [=] s.
+  Proof.
+  intros.
+  apply fold_rec with (P:=fun s acc => acc[=]s); auto with set.
+  intros. rewrite H2; rewrite Add_Equal in H1; auto with set.
+  Qed.
+
+  (** ** Alternative (weaker) specifications for [fold] *)
+
+  (** When [MSets] was first designed, the order in which Ocaml's [Set.fold]
+      takes the set elements was unspecified. This specification reflects
+      this fact:
+  *)
+
+  Lemma fold_0 :
+      forall s (A : Type) (i : A) (f : elt -> A -> A),
+      exists l : list elt,
+        NoDup l /\
+        (forall x : elt, In x s <-> InA x l) /\
+        fold f s i = fold_right f i l.
+  Proof.
+  intros; exists (rev (elements s)); split.
+  apply NoDupA_rev; auto with *.
+  split; intros.
+  rewrite elements_iff; do 2 rewrite InA_alt.
+  split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
+  rewrite fold_left_rev_right.
+  apply fold_1.
+  Qed.
+
+  (** An alternate (and previous) specification for [fold] was based on
+      the recursive structure of a set. It is now lemmas [fold_1] and
+      [fold_2]. *)
+
+  Lemma fold_1 :
+   forall s (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Empty s -> eqA (fold f s i) i.
+  Proof.
+  unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
+  rewrite H3; clear H3.
+  generalize H H2; clear H H2; case l; simpl; intros.
+  reflexivity.
+  elim (H e).
+  elim (H2 e); intuition.
+  Qed.
+
+  Lemma fold_2 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Proper (E.eq==>eqA==>eqA) f ->
+   transpose eqA f ->
+   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
+    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
+  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
+  eauto with *.
+  rewrite <- Hl1; auto.
+  intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
+   rewrite (H2 a); intuition.
+  Qed.
+
+  (** In fact, [fold] on empty sets is more than equivalent to
+      the initial element, it is Leibniz-equal to it. *)
+
+  Lemma fold_1b :
+   forall s (A : Type)(i : A) (f : elt -> A -> A),
+   Empty s -> (fold f s i) = i.
+  Proof.
+  intros.
+  rewrite FM.fold_1.
+  rewrite elements_Empty in H; rewrite H; simpl; auto.
+  Qed.
+
+  Section Fold_More.
+
+  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+  Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f).
+
+  Lemma fold_commutes : forall i s x,
+   eqA (fold f s (f x i)) (f x (fold f s i)).
+  Proof.
+  intros.
+  apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
+  reflexivity.
+  transitivity (f x0 (f x b)); auto.
+  apply Comp; auto with relations.
+  Qed.
+
+  (** ** Fold is a morphism *)
+
+  Lemma fold_init : forall i i' s, eqA i i' ->
+   eqA (fold f s i) (fold f s i').
+  Proof.
+  intros. apply fold_rel with (R:=eqA); auto.
+  intros; apply Comp; auto with relations.
+  Qed.
+
+  Lemma fold_equal :
+   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof.
+  intros i s; pattern s; apply set_induction; clear s; intros.
+  transitivity i.
+  apply fold_1; auto.
+  symmetry; apply fold_1; auto.
+  rewrite <- H0; auto.
+  transitivity (f x (fold f s i)).
+  apply fold_2 with (eqA := eqA); auto.
+  symmetry; apply fold_2 with (eqA := eqA); auto.
+  unfold Add in *; intros.
+  rewrite <- H2; auto.
+  Qed.
+
+  (** ** Fold and other set operators *)
+
+  Lemma fold_empty : forall i, fold f empty i = i.
+  Proof.
+  intros i; apply fold_1b; auto with set.
+  Qed.
+
+  Lemma fold_add : forall i s x, ~In x s ->
+   eqA (fold f (add x s) i) (f x (fold f s i)).
+  Proof.
+  intros; apply fold_2 with (eqA := eqA); auto with set.
+  Qed.
+
+  Lemma add_fold : forall i s x, In x s ->
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_1: forall i s x, In x s ->
+   eqA (f x (fold f (remove x s) i)) (fold f s i).
+  Proof.
+  intros.
+  symmetry.
+  apply fold_2 with (eqA:=eqA); auto with set relations.
+  Qed.
+
+  Lemma remove_fold_2: forall i s x, ~In x s ->
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  Lemma fold_union_inter : forall i s s',
+   eqA (fold f (union s s') (fold f (inter s s') i))
+       (fold f s (fold f s' i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  transitivity (fold f s' (fold f (inter s s') i)).
+  apply fold_equal; auto with set.
+  transitivity (fold f s' i).
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  symmetry; apply fold_1; auto.
+  rename s'0 into s''.
+  destruct (In_dec x s').
+  (* In x s' *)
+  transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
+  apply fold_init; auto.
+  apply fold_2 with (eqA:=eqA); auto with set.
+  rewrite inter_iff; intuition.
+  transitivity (f x (fold f s (fold f s' i))).
+  transitivity (fold f (union s s') (f x (fold f (inter s s') i))).
+  apply fold_equal; auto.
+  apply equal_sym; apply union_Equal with x; auto with set.
+  transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply fold_commutes; auto.
+  apply Comp; auto with relations.
+  symmetry; apply fold_2 with (eqA:=eqA); auto.
+  (* ~(In x s') *)
+  transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))).
+  apply fold_2 with (eqA:=eqA); auto with set.
+  transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply Comp;auto with relations.
+  apply fold_init;auto.
+  apply fold_equal;auto.
+  apply equal_sym; apply inter_Add_2 with x; auto with set.
+  transitivity (f x (fold f s (fold f s' i))).
+  apply Comp; auto with relations.
+  symmetry; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma fold_diff_inter : forall i s s',
+   eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
+  Proof.
+  intros.
+  transitivity (fold f (union (diff s s') (inter s s'))
+               (fold f (inter (diff s s') (inter s s')) i)).
+  symmetry; apply fold_union_inter; auto.
+  transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)).
+  apply fold_equal; auto with set.
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  Qed.
+
+  Lemma fold_union: forall i s s',
+   (forall x, ~(In x s/\In x s')) ->
+   eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+  Proof.
+  intros.
+  transitivity (fold f (union s s') (fold f (inter s s') i)).
+  apply fold_init; auto.
+  symmetry; apply fold_1; auto with set.
+  unfold Empty; intro a; generalize (H a); set_iff; tauto.
+  apply fold_union_inter; auto.
+  Qed.
+
+  End Fold_More.
+
+  Lemma fold_plus :
+   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
+  Proof.
+  intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto.
+  Qed.
+
+  End Fold.
+
+  (** * Cardinal *)
+
+  (** ** Characterization of cardinal in terms of fold *)
+
+  Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
+  Proof.
+  intros; rewrite cardinal_1; rewrite FM.fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  (** ** Old specifications for [cardinal]. *)
+
+  Lemma cardinal_0 :
+     forall s, exists l : list elt,
+        NoDupA E.eq l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\
+        cardinal s = length l.
+  Proof.
+  intros; exists (elements s); intuition; apply cardinal_1.
+  Qed.
+
+  Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
+  Proof.
+  intros; rewrite cardinal_fold; apply fold_1; auto with *.
+  Qed.
+
+  Lemma cardinal_2 :
+    forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x).
+  apply fold_2; auto.
+  split; congruence.
+  congruence.
+  Qed.
+
+  (** ** Cardinal and (non-)emptiness *)
+
+  Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0.
+  Proof.
+  intros.
+  rewrite elements_Empty, FM.cardinal_1.
+  destruct (elements s); intuition; discriminate.
+  Qed.
+
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s.
+  Proof.
+  intros; rewrite cardinal_Empty; auto.
+  Qed.
+  Hint Resolve cardinal_inv_1.
+
+  Lemma cardinal_inv_2 :
+   forall s n, cardinal s = S n -> { x : elt | In x s }.
+  Proof.
+  intros; rewrite FM.cardinal_1 in H.
+  generalize (elements_2 (s:=s)).
+  destruct (elements s); try discriminate.
+  exists e; auto with relations.
+  Qed.
+
+  Lemma cardinal_inv_2b :
+   forall s, cardinal s <> 0 -> { x : elt | In x s }.
+  Proof.
+  intro; generalize (@cardinal_inv_2 s); destruct cardinal;
+   [intuition|eauto].
+  Qed.
+
+  (** ** Cardinal is a morphism *)
+
+  Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
+  Proof.
+  symmetry.
+  remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
+  induction n; intros.
+  apply cardinal_1; rewrite <- H; auto.
+  destruct (cardinal_inv_2 Heqn) as (x,H2).
+  revert Heqn.
+  rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x));
+   auto with set relations.
+  rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x));
+   eauto with set relations.
+  Qed.
+
+  Instance cardinal_m : Proper (Equal==>Logic.eq) cardinal.
+  Proof.
+  exact Equal_cardinal.
+  Qed.
+
+  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.
+
+  (** ** Cardinal and set operators *)
+
+  Lemma empty_cardinal : cardinal empty = 0.
+  Proof.
+  rewrite cardinal_fold; apply fold_1; auto with *.
+  Qed.
+
+  Hint Immediate empty_cardinal cardinal_1 : set.
+
+  Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1.
+  Proof.
+  intros.
+  rewrite (singleton_equal_add x).
+  replace 0 with (cardinal empty); auto with set.
+  apply cardinal_2 with x; auto with set.
+  Qed.
+
+  Hint Resolve singleton_cardinal: set.
+
+  Lemma diff_inter_cardinal :
+   forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *.
+  congruence.
+  Qed.
+
+  Lemma union_cardinal:
+   forall s s', (forall x, ~(In x s/\In x s')) ->
+   cardinal (union s s')=cardinal s+cardinal s'.
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_union; auto.
+  split; congruence.
+  congruence.
+  Qed.
+
+  Lemma subset_cardinal :
+   forall s s', s[<=]s' -> cardinal s <= cardinal s' .
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H); auto with arith.
+  Qed.
+
+  Lemma subset_cardinal_lt :
+   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H).
+  generalize (@cardinal_inv_1 (diff s' s)).
+  destruct (cardinal (diff s' s)).
+  intro H2; destruct (H2 (refl_equal _) x).
+  set_iff; auto.
+  intros _.
+  change (0 + cardinal s < S n + cardinal s).
+  apply Plus.plus_lt_le_compat; auto with arith.
+  Qed.
+
+  Theorem union_inter_cardinal :
+   forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
+  Proof.
+  intros.
+  do 4 rewrite cardinal_fold.
+  do 2 rewrite <- fold_plus.
+  apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *.
+  congruence.
+  Qed.
+
+  Lemma union_cardinal_inter :
+   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
+  Proof.
+  intros.
+  rewrite <- union_inter_cardinal.
+  rewrite Plus.plus_comm.
+  auto with arith.
+  Qed.
+
+  Lemma union_cardinal_le :
+   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
+  Proof.
+   intros; generalize (union_inter_cardinal s s').
+   intros; rewrite <- H; auto with arith.
+  Qed.
+
+  Lemma add_cardinal_1 :
+   forall s x, In x s -> cardinal (add x s) = cardinal s.
+  Proof.
+  auto with set.
+  Qed.
+
+  Lemma add_cardinal_2 :
+   forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x);
+   apply fold_add with (eqA:=@Logic.eq nat); auto with *.
+  congruence.
+  Qed.
+
+  Lemma remove_cardinal_1 :
+   forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ =>S) x).
+  apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *.
+  congruence.
+  Qed.
+
+  Lemma remove_cardinal_2 :
+   forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
+  Proof.
+  auto with set.
+  Qed.
+
+  Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.
+
+End WPropertiesOn.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [Properties] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WProperties]. *)
+
+Module WProperties (M:WSets) := WPropertiesOn M.E M.
+Module Properties := WProperties.
+
+
+(** Now comes some properties specific to the element ordering,
+    invalid for Weak Sets. *)
+
+Module OrdProperties (M:Sets).
+  Module Import ME:=OrderedTypeFacts(M.E).
+  Module Import ML:=OrderedTypeLists(M.E).
+  Module Import P := Properties M.
+  Import FM.
+  Import M.E.
+  Import M.
+
+  Hint Resolve elements_spec2.
+  Hint Immediate
+    min_elt_spec1 min_elt_spec2 min_elt_spec3
+    max_elt_spec1 max_elt_spec2 max_elt_spec3 : set.
+
+  (** First, a specialized version of SortA_equivlistA_eqlistA: *)
+  Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
+   sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
+  Proof.
+  apply SortA_equivlistA_eqlistA; eauto with *.
+  Qed.
+
+  Definition gtb x y := match E.compare x y with Gt => true | _ => false end.
+  Definition leb x := fun y => negb (gtb x y).
+
+  Definition elements_lt x s := List.filter (gtb x) (elements s).
+  Definition elements_ge x s := List.filter (leb x) (elements s).
+
+  Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x.
+  Proof.
+   intros; rewrite <- compare_gt_iff. unfold gtb.
+   destruct E.compare; intuition; try discriminate.
+  Qed.
+
+  Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x.
+  Proof.
+   intros; rewrite <- compare_gt_iff. unfold leb, gtb.
+   destruct E.compare; intuition; try discriminate.
+  Qed.
+
+  Instance gtb_compat x : Proper (E.eq==>Logic.eq) (gtb x).
+  Proof.
+   intros a b H. unfold gtb. rewrite H; auto.
+  Qed.
+
+  Instance leb_compat x : Proper (E.eq==>Logic.eq) (leb x).
+  Proof.
+   intros a b H; unfold leb. rewrite H; auto.
+  Qed.
+  Hint Resolve gtb_compat leb_compat.
+
+  Lemma elements_split : forall x s,
+   elements s = elements_lt x s ++ elements_ge x s.
+  Proof.
+  unfold elements_lt, elements_ge, leb; intros.
+  eapply (@filter_split _ E.eq); eauto with *.
+  intros.
+  rewrite gtb_1 in H.
+  assert (~E.lt y x).
+   unfold gtb in *; elim_compare x y; intuition;
+   try discriminate; order.
+  order.
+  Qed.
+
+  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' ->
+    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s).
+  Proof.
+  intros; unfold elements_ge, elements_lt.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto with *.
+  apply (@filter_sort _ E.eq); auto with *; eauto with *.
+  constructor; auto.
+  apply (@filter_sort _ E.eq); auto with *; eauto with *.
+  rewrite Inf_alt by (apply (@filter_sort _ E.eq); eauto with *).
+  intros.
+  rewrite filter_InA in H1; auto with *; destruct H1.
+  rewrite leb_1 in H2.
+  rewrite <- elements_iff in H1.
+  assert (~E.eq x y).
+   contradict H; rewrite H; auto.
+  order.
+  intros.
+  rewrite filter_InA in H1; auto with *; destruct H1.
+  rewrite gtb_1 in H3.
+  inversion_clear H2.
+  order.
+  rewrite filter_InA in H4; auto with *; destruct H4.
+  rewrite leb_1 in H4.
+  order.
+  red; intros a.
+  rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff,
+   leb_1, gtb_1, (H0 a) by (auto with *).
+  intuition.
+  elim_compare a x; intuition.
+  right; right; split; auto.
+  order.
+  Qed.
+
+  Definition Above x s := forall y, In y s -> E.lt y x.
+  Definition Below x s := forall y, In y s -> E.lt x y.
+
+  Lemma elements_Add_Above : forall s s' x,
+   Above x s -> Add x s s' ->
+     eqlistA E.eq (elements s') (elements s ++ x::nil).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto with *.
+  intros.
+  invlist InA.
+  rewrite <- elements_iff in H1.
+  setoid_replace y with x; auto.
+  red; intros a.
+  rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a)
+   by (auto with *).
+  intuition.
+  Qed.
+
+  Lemma elements_Add_Below : forall s s' x,
+   Below x s -> Add x s s' ->
+     eqlistA E.eq (elements s') (x::elements s).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with set.
+  change (sort E.lt ((x::nil) ++ elements s)).
+  apply (@SortA_app _ E.eq); auto with *.
+  intros.
+  invlist InA.
+  rewrite <- elements_iff in H2.
+  setoid_replace x0 with x; auto.
+  red; intros a.
+  rewrite InA_cons, <- !elements_iff, (H0 a); intuition.
+  Qed.
+
+  (** Two other induction principles on sets: we can be more restrictive
+      on the element we add at each step.  *)
+
+  Lemma set_induction_max :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  case_eq (max_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set relations.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@max_elt_spec2 s e y H H0); order.
+
+  assert (H0:=max_elt_spec3 H).
+  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  Lemma set_induction_min :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  case_eq (min_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set relations.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@min_elt_spec2 s e y H H0); order.
+
+  assert (H0:=min_elt_spec3 H).
+  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  (** More properties of [fold] : behavior with respect to Above/Below *)
+
+  Lemma fold_3 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Proper (E.eq==>eqA==>eqA) f ->
+   Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros.
+  rewrite !FM.fold_1.
+  unfold flip; rewrite <-!fold_left_rev_right.
+  change (f x (fold_right f i (rev (elements s)))) with
+    (fold_right f i (rev (x::nil)++rev (elements s))).
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *.
+  rewrite <- distr_rev.
+  apply eqlistA_rev.
+  apply elements_Add_Above; auto.
+  Qed.
+
+  Lemma fold_4 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Proper (E.eq==>eqA==>eqA) f ->
+   Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
+  Proof.
+  intros.
+  rewrite !FM.fold_1.
+  change (eqA (fold_left (flip f) (elements s') i)
+              (fold_left (flip f) (x::elements s) i)).
+  unfold flip; rewrite <-!fold_left_rev_right.
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  apply eqlistA_rev.
+  apply elements_Add_Below; auto.
+  Qed.
+
+  (** The following results have already been proved earlier,
+    but we can now prove them with one hypothesis less:
+    no need for [(transpose eqA f)]. *)
+
+  Section FoldOpt.
+  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+  Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f).
+
+  Lemma fold_equal :
+   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof.
+  intros.
+  rewrite !FM.fold_1.
+  unfold flip; rewrite <- !fold_left_rev_right.
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  apply eqlistA_rev.
+  apply sort_equivlistA_eqlistA; auto with set.
+  red; intro a; do 2 rewrite <- elements_iff; auto.
+  Qed.
+
+  Lemma add_fold : forall i s x, In x s ->
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_2: forall i s x, ~In x s ->
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  End FoldOpt.
+
+  (** An alternative version of [choose_3] *)
+
+  Lemma choose_equal : forall s s', Equal s s' ->
+    match choose s, choose s' with
+      | Some x, Some x' => E.eq x x'
+      | None, None => True
+      | _, _ => False
+     end.
+  Proof.
+  intros s s' H;
+  generalize (@choose_spec1 s)(@choose_spec2 s)
+             (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s');
+  destruct (choose s); destruct (choose s'); simpl; intuition.
+  apply H5 with e; rewrite <-H; auto.
+  apply H5 with e; rewrite H; auto.
+  Qed.
+
+End OrdProperties.
diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v
new file mode 100644
index 00000000..f0b964cf
--- /dev/null
+++ b/theories/MSets/MSetToFiniteSet.v
@@ -0,0 +1,158 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite sets library : conversion to old [Finite_sets] *)
+
+Require Import Ensembles Finite_sets.
+Require Import MSetInterface MSetProperties OrdersEx.
+
+(** * Going from [MSets] with usual Leibniz equality
+    to the good old [Ensembles] and [Finite_sets] theory. *)
+
+Module WS_to_Finite_set (U:UsualDecidableType)(M: WSetsOn U).
+ Module MP:= WPropertiesOn U M.
+ Import M MP FM Ensembles Finite_sets.
+
+ Definition mkEns : M.t -> Ensemble M.elt :=
+   fun s x => M.In x s.
+
+ Notation " !! " := mkEns.
+
+ Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
+ Proof.
+ unfold In; compute; auto with extcore.
+ Qed.
+
+ Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
+ Proof.
+ unfold Subset, Included, In, mkEns; intuition.
+ Qed.
+
+ Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).
+
+ Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
+ Proof.
+ intros.
+ rewrite double_inclusion.
+ unfold Subset, Included, Same_set, In, mkEns; intuition.
+ Qed.
+
+ Lemma empty_Empty_Set : !!M.empty === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1.
+ Qed.
+
+ Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ destruct(H x H0).
+ inversion H0.
+ Qed.
+
+ Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
+ Qed.
+
+ Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; auto with sets.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ Qed.
+
+ Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ red in H; rewrite H in H0.
+ destruct H0.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ red in H; rewrite H.
+ inversion H0; auto.
+ inversion H1; auto.
+ Qed.
+
+ Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; auto with sets.
+ split; auto.
+ contradict H1.
+ inversion H1; auto.
+ Qed.
+
+ Lemma mkEns_Finite : forall s, Finite _ (!!s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ symmetry; apply Extensionality_Ensembles.
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ constructor 2; auto.
+ symmetry; apply Extensionality_Ensembles.
+ apply Add_Add; auto.
+ Qed.
+
+ Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ rewrite MP.cardinal_1; auto with sets.
+ symmetry; apply Extensionality_Ensembles.
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ rewrite (cardinal_2 H0 H1); auto with sets.
+ symmetry; apply Extensionality_Ensembles.
+ apply Add_Add; auto.
+ Qed.
+
+ (** we can even build a function from Finite Ensemble to MSet
+     ... at least in Prop. *)
+
+ Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e ->
+   exists s:M.t, !!s === e.
+ Proof.
+ induction 1.
+ exists M.empty.
+ apply empty_Empty_Set.
+ destruct IHFinite as (s,Hs).
+ exists (M.add x s).
+ apply Extensionality_Ensembles in Hs.
+ rewrite <- Hs.
+ apply add_Add.
+ Qed.
+
+End WS_to_Finite_set.
+
+
+Module S_to_Finite_set (U:UsualOrderedType)(M: SetsOn U) :=
+  WS_to_Finite_set U M.
+
+
diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v
new file mode 100644
index 00000000..945cb2dd
--- /dev/null
+++ b/theories/MSets/MSetWeakList.v
@@ -0,0 +1,533 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant
+    interface [MSetWeakInterface.S] using lists without redundancy. *)
+
+Require Import MSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Functions over lists
+
+   First, we provide sets as lists which are (morally) without redundancy.
+   The specs are proved under the additional condition of no redundancy.
+   And the functions returning sets are proved to preserve this invariant. *)
+
+
+(** ** The set operations. *)
+
+Module Ops (X: DecidableType) <: WOps X.
+
+  Definition elt := X.t.
+  Definition t := list elt.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) : bool := if l then true else false.
+
+  Fixpoint mem (x : elt) (s : t) : bool :=
+    match s with
+    | nil => false
+    | y :: l =>
+           if X.eq_dec x y then true else mem x l
+    end.
+
+  Fixpoint add (x : elt) (s : t) : t :=
+    match s with
+    | nil => x :: nil
+    | y :: l =>
+        if X.eq_dec x y then s else y :: add x l
+    end.
+
+  Definition singleton (x : elt) : t := x :: nil.
+
+  Fixpoint remove (x : elt) (s : t) : t :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        if X.eq_dec x y then l else y :: remove x l
+    end.
+
+  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
+    fold_left (flip f) s i.
+
+  Definition union (s : t) : t -> t := fold add s.
+
+  Definition diff (s s' : t) : t := fold remove s' s.
+
+  Definition inter (s s': t) : t :=
+    fold (fun x s => if mem x s' then add x s else s) s nil.
+
+  Definition subset (s s' : t) : bool := is_empty (diff s s').
+
+  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s).
+
+  Fixpoint filter (f : elt -> bool) (s : t) : t :=
+    match s with
+    | nil => nil
+    | x :: l => if f x then x :: filter f l else filter f l
+    end.
+
+  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
+    match s with
+    | nil => true
+    | x :: l => if f x then for_all f l else false
+    end.
+
+  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
+    match s with
+    | nil => false
+    | x :: l => if f x then true else exists_ f l
+    end.
+
+  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
+    match s with
+    | nil => (nil, nil)
+    | x :: l =>
+        let (s1, s2) := partition f l in
+        if f x then (x :: s1, s2) else (s1, x :: s2)
+    end.
+
+  Definition cardinal (s : t) : nat := length s.
+
+  Definition elements (s : t) : list elt := s.
+
+  Definition choose (s : t) : option elt :=
+     match s with
+      | nil => None
+      | x::_ => Some x
+     end.
+
+End Ops.
+
+(** ** Proofs of set operation specifications. *)
+
+Module MakeRaw (X:DecidableType) <: WRawSets X.
+  Include Ops X.
+
+  Section ForNotations.
+  Notation NoDup := (NoDupA X.eq).
+  Notation In := (InA X.eq).
+
+  (* TODO: modify proofs in order to avoid these hints *)
+  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
+  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
+  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).
+
+  Definition IsOk := NoDup.
+
+  Class Ok (s:t) : Prop := ok : NoDup s.
+
+  Hint Unfold Ok.
+  Hint Resolve @ok.
+
+  Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }.
+
+  Ltac inv_ok := match goal with
+   | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok
+   | H:Ok nil |- _ => clear H; inv_ok
+   | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok
+   | _ => idtac
+  end.
+
+  Ltac inv := invlist InA; inv_ok.
+  Ltac constructors := repeat constructor.
+
+  Fixpoint isok l := match l with
+   | nil => true
+   | a::l => negb (mem a l) && isok l
+  end.
+
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Lemma In_compat : Proper (X.eq==>eq==>iff) In.
+  Proof.
+  repeat red; intros. subst. rewrite H; auto.
+  Qed.
+
+  Lemma mem_spec : forall s x `{Ok s},
+   mem x s = true <-> In x s.
+  Proof.
+  induction s; intros.
+  split; intros; inv. discriminate.
+  simpl; destruct (X.eq_dec x a); split; intros; inv; auto.
+  right; rewrite <- IHs; auto.
+  rewrite IHs; auto.
+  Qed.
+
+  Lemma isok_iff : forall l, Ok l <-> isok l = true.
+  Proof.
+  induction l.
+  intuition.
+  simpl.
+  rewrite andb_true_iff.
+  rewrite negb_true_iff.
+  rewrite <- IHl.
+  split; intros H. inv.
+  split; auto.
+  apply not_true_is_false. rewrite mem_spec; auto.
+  destruct H; constructors; auto.
+  rewrite <- mem_spec; auto; congruence.
+  Qed.
+
+  Global Instance isok_Ok l : isok l = true -> Ok l | 10.
+  Proof.
+  intros. apply <- isok_iff; auto.
+  Qed.
+
+  Lemma add_spec :
+   forall (s : t) (x y : elt) {Hs : Ok s},
+     In y (add x s) <-> X.eq y x \/ In y s.
+  Proof.
+  induction s; simpl; intros.
+  intuition; inv; auto.
+  destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition.
+  left; eauto.
+  inv; auto.
+  Qed.
+
+  Global Instance add_ok s x `(Ok s) : Ok (add x s).
+  Proof.
+  induction s.
+  simpl; intuition.
+  intros; inv. simpl.
+  destruct X.eq_dec; auto.
+  constructors; auto.
+  intro; inv; auto.
+  rewrite add_spec in *; intuition.
+  Qed.
+
+  Lemma remove_spec :
+   forall (s : t) (x y : elt) {Hs : Ok s},
+     In y (remove x s) <-> In y s /\ ~X.eq y x.
+  Proof.
+  induction s; simpl; intros.
+  intuition; inv; auto.
+  destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition.
+  elim H. setoid_replace a with y; eauto.
+  elim H3. setoid_replace x with y; eauto.
+  elim n. eauto.
+  Qed.
+
+  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
+  Proof.
+  induction s; simpl; intros.
+  auto.
+  destruct X.eq_dec; inv; auto.
+  constructors; auto.
+  rewrite remove_spec; intuition.
+  Qed.
+
+  Lemma singleton_ok : forall x : elt, Ok (singleton x).
+  Proof.
+  unfold singleton; simpl; constructors; auto. intro; inv.
+  Qed.
+
+  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
+  Proof.
+  unfold singleton; simpl; split; intros. inv; auto. left; auto.
+  Qed.
+
+  Lemma empty_ok : Ok empty.
+  Proof.
+  unfold empty; constructors.
+  Qed.
+
+  Lemma empty_spec : Empty empty.
+  Proof.
+  unfold Empty, empty; red; intros; inv.
+  Qed.
+
+  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
+  Proof.
+  unfold Empty; destruct s; simpl; split; intros; auto.
+  intro; inv.
+  discriminate.
+  elim (H e); auto.
+  Qed.
+
+  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
+  Proof.
+  unfold elements; intuition.
+  Qed.
+
+  Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s).
+  Proof.
+  unfold elements; auto.
+  Qed.
+
+  Lemma fold_spec :
+   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (flip f) (elements s) i.
+  Proof.
+  reflexivity.
+  Qed.
+
+  Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s').
+  Proof.
+  induction s; simpl; auto; intros; inv; unfold flip; auto with *.
+  Qed.
+
+  Lemma union_spec :
+   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
+   In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+  induction s; simpl in *; unfold flip; intros; auto; inv.
+  intuition; inv.
+  rewrite IHs, add_spec, InA_cons; intuition.
+  Qed.
+
+  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
+  Proof.
+  unfold inter, fold, flip.
+  set (acc := nil (A:=elt)).
+  assert (Hacc : Ok acc) by constructors.
+  clearbody acc; revert acc Hacc.
+  induction s; simpl; auto; intros. inv.
+  apply IHs; auto.
+  destruct (mem a s'); auto with *.
+  Qed.
+
+  Lemma inter_spec  :
+   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
+   In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+  unfold inter, fold, flip; intros.
+  set (acc := nil (A:=elt)) in *.
+  assert (Hacc : Ok acc) by constructors.
+  assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc).
+   intuition; unfold acc in *; inv.
+  rewrite IFF; clear IFF. clearbody acc.
+  revert acc Hacc x s' Hs Hs'.
+  induction s; simpl; intros.
+  intuition; inv.
+  inv.
+  case_eq (mem a s'); intros Hm.
+  rewrite IHs, add_spec, InA_cons; intuition.
+  rewrite mem_spec in Hm; auto.
+  left; split; auto. rewrite H1; auto.
+  rewrite IHs, InA_cons; intuition.
+  rewrite H2, <- mem_spec in H3; auto. congruence.
+  Qed.
+
+  Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s').
+  Proof.
+  unfold diff; intros s s'; revert s.
+  induction s'; simpl; unfold flip; auto; intros. inv; auto with *.
+  Qed.
+
+  Lemma diff_spec  :
+   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
+   In x (diff s s') <-> In x s /\ ~In x s'.
+  Proof.
+  unfold diff; intros s s'; revert s.
+  induction s'; simpl; unfold flip.
+  intuition; inv.
+  intros. inv.
+  rewrite IHs', remove_spec, InA_cons; intuition.
+  Qed.
+
+  Lemma subset_spec :
+   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
+   subset s s' = true <-> Subset s s'.
+  Proof.
+  unfold subset, Subset; intros.
+  rewrite is_empty_spec.
+  unfold Empty; intros.
+  intuition.
+  specialize (H a). rewrite diff_spec in H; intuition.
+  rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition.
+  rewrite diff_spec in H0; intuition.
+  Qed.
+
+  Lemma equal_spec :
+   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
+   equal s s' = true <-> Equal s s'.
+  Proof.
+  unfold Equal, equal; intros.
+  rewrite andb_true_iff, !subset_spec.
+  unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto.
+  Qed.
+
+  Definition choose_spec1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+  destruct s; simpl; intros; inversion H; auto.
+  Qed.
+
+  Definition choose_spec2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+  destruct s; simpl; intros.
+  intros x H0; inversion H0.
+  inversion H.
+  Qed.
+
+  Lemma cardinal_spec :
+   forall (s : t) {Hs : Ok s}, cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_spec' : forall s x f,
+   In x (filter f s) -> In x s.
+  Proof.
+  induction s; simpl.
+  intuition; inv.
+  intros; destruct (f a); inv; intuition; right; eauto.
+  Qed.
+
+  Lemma filter_spec :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (In x (filter f s) <-> In x s /\ f x = true).
+  Proof.
+  induction s; simpl.
+  intuition; inv.
+  intros.
+  destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition.
+  setoid_replace x with a; auto.
+  setoid_replace a with x in E; auto. congruence.
+  Qed.
+
+  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
+  Proof.
+  induction s; simpl.
+  auto.
+  intros; inv.
+  case (f a); auto.
+  constructors; auto.
+  contradict H0.
+  eapply filter_spec'; eauto.
+  Qed.
+
+  Lemma for_all_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof.
+  unfold For_all; induction s; simpl.
+  intuition. inv.
+  intros; inv.
+  destruct (f a) as [ ]_eqn:F.
+  rewrite IHs; intuition. inv; auto.
+  setoid_replace x with a; auto.
+  split; intros H'; try discriminate.
+  intros.
+  rewrite <- F, <- (H' a); auto.
+  Qed.
+
+  Lemma exists_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof.
+  unfold Exists; induction s; simpl.
+  split; [discriminate| intros (x & Hx & _); inv].
+  intros.
+  destruct (f a) as [ ]_eqn:F.
+  split; auto.
+  exists a; auto.
+  rewrite IHs; firstorder.
+  inv.
+  setoid_replace a with x in F; auto; congruence.
+  exists x; auto.
+  Qed.
+
+  Lemma partition_spec1 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   Equal (fst (partition f s)) (filter f s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  firstorder.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  case (partition f l); intros s1 s2; simpl; intros.
+  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
+  Qed.
+
+  Lemma partition_spec2 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  firstorder.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  case (partition f l); intros s1 s2; simpl; intros.
+  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
+  Qed.
+
+  Lemma partition_ok1' :
+   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
+    In x (fst (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros. inv.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed.
+
+  Lemma partition_ok2' :
+   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
+    In x (snd (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros. inv.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed.
+
+  Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (@partition_ok1' _ _ f x).
+  generalize (Hrec f H0).
+  case (f x); case (partition f l); simpl; constructors; auto.
+  Qed.
+
+  Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (@partition_ok2' _ _ f x).
+  generalize (Hrec f H0).
+  case (f x); case (partition f l); simpl; constructors; auto.
+  Qed.
+
+  End ForNotations.
+
+  Definition In := InA X.eq.
+  Definition eq := Equal.
+  Instance eq_equiv : Equivalence eq.
+
+End MakeRaw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we
+   need to encapsulate everything into a type of lists without redundancy. *)
+
+Module Make (X: DecidableType) <: WSets with Module E := X.
+ Module Raw := MakeRaw X.
+ Include WRaw2Sets X Raw.
+End Make.
+
diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v
new file mode 100644
index 00000000..958e9861
--- /dev/null
+++ b/theories/MSets/MSets.v
@@ -0,0 +1,23 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Orders.
+Require Export OrdersEx.
+Require Export OrdersAlt.
+Require Export Equalities.
+Require Export MSetInterface.
+Require Export MSetFacts.
+Require Export MSetDecide.
+Require Export MSetProperties.
+Require Export MSetEqProperties.
+Require Export MSetWeakList.
+Require Export MSetList.
+Require Export MSetPositive.
+Require Export MSetAVL.
\ No newline at end of file
diff --git a/theories/MSets/vo.itarget b/theories/MSets/vo.itarget
new file mode 100644
index 00000000..14429b81
--- /dev/null
+++ b/theories/MSets/vo.itarget
@@ -0,0 +1,11 @@
+MSetAVL.vo
+MSetDecide.vo
+MSetEqProperties.vo
+MSetFacts.vo
+MSetInterface.vo
+MSetList.vo
+MSetProperties.vo
+MSets.vo
+MSetToFiniteSet.vo
+MSetWeakList.vo
+MSetPositive.vo
\ No newline at end of file
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index 3752abcc..f0ec2ad6 100644
--- a/theories/NArith/BinNat.v
+++ b/theories/NArith/BinNat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinNat.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import BinPos.
 Unset Boxed Definitions.
@@ -45,7 +45,7 @@ Definition Ndouble_plus_one x :=
 
 (** Operation x -> 2*x *)
 
-Definition Ndouble n := 
+Definition Ndouble n :=
   match n with
   | N0 => N0
   | Npos p => Npos (xO p)
@@ -106,6 +106,15 @@ Definition Nmult n m :=
 
 Infix "*" := Nmult : N_scope.
 
+(** Boolean Equality *)
+
+Definition Neqb n m :=
+ match n, m with
+  | N0, N0 => true
+  | Npos n, Npos m => Peqb n m
+  | _,_ => false
+ end.
+
 (** Order *)
 
 Definition Ncompare n m :=
@@ -130,16 +139,24 @@ Infix ">" := Ngt : N_scope.
 
 (** Min and max *)
 
-Definition Nmin (n n' : N) := match Ncompare n n' with 
+Definition Nmin (n n' : N) := match Ncompare n n' with
  | Lt | Eq => n
  | Gt => n'
  end.
 
-Definition Nmax (n n' : N) := match Ncompare n n' with 
+Definition Nmax (n n' : N) := match Ncompare n n' with
  | Lt | Eq => n'
  | Gt => n
  end.
 
+(** Decidability of equality. *)
+
+Definition N_eq_dec : forall n m : N, { n = m } + { n <> m }.
+Proof.
+ decide equality.
+ apply positive_eq_dec.
+Defined.
+
 (** convenient induction principles *)
 
 Lemma N_ind_double :
@@ -149,7 +166,7 @@ Lemma N_ind_double :
    (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
 Proof.
   intros; elim a. trivial.
-  simple induction p. intros. 
+  simple induction p. intros.
   apply (H1 (Npos p0)); trivial.
   intros; apply (H0 (Npos p0)); trivial.
   intros; apply (H1 N0); assumption.
@@ -162,7 +179,7 @@ Lemma N_rec_double :
    (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
 Proof.
   intros; elim a. trivial.
-  simple induction p. intros. 
+  simple induction p. intros.
   apply (H1 (Npos p0)); trivial.
   intros; apply (H0 (Npos p0)); trivial.
   intros; apply (H1 N0); assumption.
@@ -354,7 +371,16 @@ destruct p; intros Hp H.
 contradiction Hp; reflexivity.
 destruct n; destruct m; reflexivity || (try discriminate H).
 injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity.
-Qed. 
+Qed.
+
+(** Properties of boolean order. *)
+
+Lemma Neqb_eq : forall n m, Neqb n m = true <-> n=m.
+Proof.
+destruct n as [|n], m as [|m]; simpl; split; auto; try discriminate.
+intros; f_equal. apply (Peqb_eq n m); auto.
+intros. apply (Peqb_eq n m). congruence.
+Qed.
 
 (** Properties of comparison *)
 
@@ -373,7 +399,7 @@ Qed.
 
 Theorem Ncompare_eq_correct : forall n m:N, (n ?= m) = Eq <-> n = m.
 Proof.
-split; intros; 
+split; intros;
  [ apply Ncompare_Eq_eq; auto | subst; apply Ncompare_refl ].
 Qed.
 
@@ -383,11 +409,30 @@ destruct n; destruct m; simpl; auto.
 exact (Pcompare_antisym p p0 Eq).
 Qed.
 
+Lemma Ngt_Nlt : forall n m, n > m -> m < n.
+Proof.
+unfold Ngt, Nlt; intros n m GT.
+rewrite <- Ncompare_antisym, GT; reflexivity.
+Qed.
+
 Theorem Nlt_irrefl : forall n : N, ~ n < n.
 Proof.
 intro n; unfold Nlt; now rewrite Ncompare_refl.
 Qed.
 
+Theorem Nlt_trans : forall n m q, n < m -> m < q -> n < q.
+Proof.
+destruct n;
+ destruct m; try discriminate;
+ destruct q; try discriminate; auto.
+eapply Plt_trans; eauto.
+Qed.
+
+Theorem Nlt_not_eq : forall n m, n < m -> ~ n = m.
+Proof.
+ intros n m LT EQ. subst m. elim (Nlt_irrefl n); auto.
+Qed.
+
 Theorem Ncompare_n_Sm :
   forall n m : N, Ncompare n (Nsucc m) = Lt <-> Ncompare n m = Lt \/ n = m.
 Proof.
@@ -400,6 +445,21 @@ pose proof (Pcompare_p_Sq p q) as (_,?);
 assert (p = q <-> Npos p = Npos q); [split; congruence | tauto].
 Qed.
 
+Lemma Nle_lteq : forall x y, x <= y <-> x < y \/ x=y.
+Proof.
+unfold Nle, Nlt; intros.
+generalize (Ncompare_eq_correct x y).
+destruct (x ?= y); intuition; discriminate.
+Qed.
+
+Lemma Ncompare_spec : forall x y, CompSpec eq Nlt x y (Ncompare x y).
+Proof.
+intros.
+destruct (Ncompare x y) as [ ]_eqn; constructor; auto.
+apply Ncompare_Eq_eq; auto.
+apply Ngt_Nlt; auto.
+Qed.
+
 (** 0 is the least natural number *)
 
 Theorem Ncompare_0 : forall n : N, Ncompare n N0 <> Lt.
diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v
index e3293e70..a5f99cc6 100644
--- a/theories/NArith/BinPos.v
+++ b/theories/NArith/BinPos.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,10 +7,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinPos.v 11033 2008-06-01 22:56:50Z letouzey $ i*)
+(*i $Id$ i*)
 
 Unset Boxed Definitions.
 
+Declare ML Module "z_syntax_plugin".
+
 (**********************************************************************)
 (** Binary positive numbers *)
 
@@ -30,15 +33,15 @@ Bind Scope positive_scope with positive.
 Arguments Scope xO [positive_scope].
 Arguments Scope xI [positive_scope].
 
-(** Postfix notation for positive numbers, allowing to mimic 
-    the position of bits in a big-endian representation. 
-    For instance, we can write 1~1~0 instead of (xO (xI xH)) 
+(** Postfix notation for positive numbers, allowing to mimic
+    the position of bits in a big-endian representation.
+    For instance, we can write 1~1~0 instead of (xO (xI xH))
     for the number 6 (which is 110 in binary notation).
 *)
 
-Notation "p ~ 1" := (xI p) 
+Notation "p ~ 1" := (xI p)
  (at level 7, left associativity, format "p '~' '1'") : positive_scope.
-Notation "p ~ 0" := (xO p) 
+Notation "p ~ 0" := (xO p)
  (at level 7, left associativity, format "p '~' '0'") : positive_scope.
 
 Open Local Scope positive_scope.
@@ -74,7 +77,7 @@ Fixpoint Pplus (x y:positive) : positive :=
     | 1, q~0 => q~1
     | 1, 1 => 1~0
   end
-  
+
 with Pplus_carry (x y:positive) : positive :=
   match x, y with
     | p~1, q~1 => (Pplus_carry p q)~1
@@ -176,7 +179,7 @@ Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask :=
     | 1, 1 => IsNul
     | 1, _ => IsNeg
   end
-  
+
 with Pminus_mask_carry (x y:positive) {struct y} : positive_mask :=
   match x, y with
     | p~1, q~1 => Pdouble_plus_one_mask (Pminus_mask_carry p q)
@@ -253,23 +256,41 @@ Notation "x < y < z" := (x < y /\ y < z) : positive_scope.
 Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope.
 
 
-Definition Pmin (p p' : positive) := match Pcompare p p' Eq with 
- | Lt | Eq => p 
+Definition Pmin (p p' : positive) := match Pcompare p p' Eq with
+ | Lt | Eq => p
  | Gt => p'
  end.
 
-Definition Pmax (p p' : positive) := match Pcompare p p' Eq with 
- | Lt | Eq => p' 
+Definition Pmax (p p' : positive) := match Pcompare p p' Eq with
+ | Lt | Eq => p'
  | Gt => p
  end.
 
+(********************************************************************)
+(** Boolean equality *)
+
+Fixpoint Peqb (x y : positive) {struct y} : bool :=
+ match x, y with
+ | 1, 1 => true
+ | p~1, q~1 => Peqb p q
+ | p~0, q~0 => Peqb p q
+ | _, _ => false
+ end.
+
 (**********************************************************************)
-(** Miscellaneous properties of binary positive numbers *)
+(** Decidability of equality on binary positive numbers *)
+
+Lemma positive_eq_dec : forall x y: positive, {x = y} + {x <> y}.
+Proof.
+  decide equality.
+Defined.
 
-Lemma ZL11 : forall p:positive, p = 1 \/ p <> 1.
+(* begin hide *)
+Corollary ZL11 : forall p:positive, p = 1 \/ p <> 1.
 Proof.
-  intros x; case x; intros; (left; reflexivity) || (right; discriminate).
+  intro; edestruct positive_eq_dec; eauto.
 Qed.
+(* end hide *)
 
 (**********************************************************************)
 (** Properties of successor on binary positive numbers *)
@@ -371,14 +392,14 @@ Theorem Pplus_comm : forall p q:positive, p + q = q + p.
 Proof.
   induction p; destruct q; simpl; f_equal; auto.
   rewrite 2 Pplus_carry_spec; f_equal; auto.
-Qed. 
+Qed.
 
 (** Permutation of [Pplus] and [Psucc] *)
 
 Theorem Pplus_succ_permute_r :
   forall p q:positive, p + Psucc q = Psucc (p + q).
 Proof.
-  induction p; destruct q; simpl; f_equal; 
+  induction p; destruct q; simpl; f_equal;
    auto using Pplus_one_succ_r; rewrite Pplus_carry_spec; auto.
 Qed.
 
@@ -423,10 +444,10 @@ Qed.
 Lemma Pplus_reg_r : forall p q r:positive, p + r = q + r -> p = q.
 Proof.
   intros p q r; revert p q; induction r.
-  intros [p|p| ] [q|q| ] H; simpl; destr_eq H; 
-    f_equal; auto using Pplus_carry_plus; 
+  intros [p|p| ] [q|q| ] H; simpl; destr_eq H;
+    f_equal; auto using Pplus_carry_plus;
     contradict H; auto using Pplus_carry_no_neutral.
-  intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; 
+  intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto;
     contradict H; auto using Pplus_no_neutral.
   intros p q H; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption.
 Qed.
@@ -456,11 +477,11 @@ Qed.
 Theorem Pplus_assoc : forall p q r:positive, p + (q + r) = p + q + r.
 Proof.
   induction p.
-  intros [q|q| ] [r|r| ]; simpl; f_equal; auto; 
-    rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, 
+  intros [q|q| ] [r|r| ]; simpl; f_equal; auto;
+    rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r,
      ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto.
   intros [q|q| ] [r|r| ]; simpl; f_equal; auto;
-    rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, 
+    rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r,
      ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto.
   intros p r; rewrite <- 2 Pplus_one_succ_l, Pplus_succ_permute_l; auto.
 Qed.
@@ -484,7 +505,7 @@ Lemma Pplus_xO_double_minus_one :
   forall p q:positive, Pdouble_minus_one (p + q) = p~0 + Pdouble_minus_one q.
 Proof.
   induction p as [p IHp| p IHp| ]; destruct q; simpl;
-  rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI, 
+  rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI,
     ?Pplus_xI_double_minus_one; try reflexivity.
   rewrite IHp; auto.
   rewrite <- Psucc_o_double_minus_one_eq_xO, Pplus_one_succ_l; reflexivity.
@@ -494,7 +515,7 @@ Qed.
 
 Lemma Pplus_diag : forall p:positive, p + p = p~0.
 Proof.
-  induction p as [p IHp| p IHp| ]; simpl; 
+  induction p as [p IHp| p IHp| ]; simpl;
    try rewrite ?Pplus_carry_spec, ?IHp; reflexivity.
 Qed.
 
@@ -525,10 +546,10 @@ Fixpoint peanoView p : PeanoView p :=
     | p~1 => peanoView_xI p (peanoView p)
   end.
 
-Definition PeanoView_iter (P:positive->Type) 
+Definition PeanoView_iter (P:positive->Type)
   (a:P 1) (f:forall p, P p -> P (Psucc p)) :=
   (fix iter p (q:PeanoView p) : P p :=
-    match q in PeanoView p return P p with 
+    match q in PeanoView p return P p with
       | PeanoOne => a
       | PeanoSucc _ q => f _ (iter _ q)
     end).
@@ -536,23 +557,23 @@ Definition PeanoView_iter (P:positive->Type)
 Require Import Eqdep_dec EqdepFacts.
 
 Theorem eq_dep_eq_positive :
-  forall (P:positive->Type) (p:positive) (x y:P p), 
+  forall (P:positive->Type) (p:positive) (x y:P p),
     eq_dep positive P p x p y -> x = y.
 Proof.
   apply eq_dep_eq_dec.
   decide equality.
 Qed.
 
-Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'.  
+Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'.
 Proof.
-  intros. 
+  intros.
   induction q as [ | p q IHq ].
   apply eq_dep_eq_positive.
   cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. trivial.
   destruct p0; intros; discriminate.
   trivial.
   apply eq_dep_eq_positive.
-  cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'. 
+  cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'.
   intro. destruct p; discriminate.
   intro. unfold p0 in H. apply Psucc_inj in H.
   generalize q'. rewrite H. intro.
@@ -561,12 +582,12 @@ Proof.
   trivial.
 Qed.
 
-Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) 
+Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p))
   (p:positive) :=
   PeanoView_iter P a f p (peanoView p).
 
-Theorem Prect_succ : forall (P:positive->Type) (a:P 1) 
-  (f:forall p, P p -> P (Psucc p)) (p:positive), 
+Theorem Prect_succ : forall (P:positive->Type) (a:P 1)
+  (f:forall p, P p -> P (Psucc p)) (p:positive),
   Prect P a f (Psucc p) = f _ (Prect P a f p).
 Proof.
   intros.
@@ -575,7 +596,7 @@ Proof.
   trivial.
 Qed.
 
-Theorem Prect_base : forall (P:positive->Type) (a:P 1) 
+Theorem Prect_base : forall (P:positive->Type) (a:P 1)
   (f:forall p, P p -> P (Psucc p)), Prect P a f 1 = a.
 Proof.
   trivial.
@@ -713,6 +734,29 @@ Proof.
   intros [p|p| ] [q|q| ] H; destr_eq H; auto.
 Qed.
 
+(*********************************************************************)
+(** Properties of boolean equality *)
+
+Theorem Peqb_refl : forall x:positive, Peqb x x = true.
+Proof.
+ induction x; auto.
+Qed.
+
+Theorem Peqb_true_eq : forall x y:positive, Peqb x y = true -> x=y.
+Proof.
+ induction x; destruct y; simpl; intros; try discriminate.
+ f_equal; auto.
+ f_equal; auto.
+ reflexivity.
+Qed.
+
+Theorem Peqb_eq : forall x y : positive, Peqb x y = true <-> x=y.
+Proof.
+ split. apply Peqb_true_eq.
+ intros; subst; apply Peqb_refl.
+Qed.
+
+
 (**********************************************************************)
 (** Properties of comparison on binary positive numbers *)
 
@@ -735,12 +779,19 @@ Qed.
 
 Theorem Pcompare_Eq_eq : forall p q:positive, (p ?= q) Eq = Eq -> p = q.
 Proof.
-  induction p; intros [q| q| ] H; simpl in *; auto; 
+  induction p; intros [q| q| ] H; simpl in *; auto;
    try discriminate H; try (f_equal; auto; fail).
   destruct (Pcompare_not_Eq p q) as (H',_); elim H'; auto.
   destruct (Pcompare_not_Eq p q) as (_,H'); elim H'; auto.
 Qed.
 
+Lemma Pcompare_eq_iff : forall p q:positive, (p ?= q) Eq = Eq <-> p = q.
+Proof.
+  split.
+  apply Pcompare_Eq_eq.
+  intros; subst; apply Pcompare_refl.
+Qed.
+
 Lemma Pcompare_Gt_Lt :
   forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt.
 Proof.
@@ -812,7 +863,7 @@ Lemma Pcompare_antisym :
   forall (p q:positive) (r:comparison),
     CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r).
 Proof.
-  induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto; 
+  induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto;
    rewrite IHp; auto.
 Qed.
 
@@ -840,6 +891,15 @@ Proof.
   symmetry; apply Pcompare_antisym.
 Qed.
 
+Lemma Pcompare_spec : forall p q, CompSpec eq Plt p q ((p ?= q) Eq).
+Proof.
+  intros. destruct ((p ?= q) Eq) as [ ]_eqn; constructor.
+  apply Pcompare_Eq_eq; auto.
+  auto.
+  apply ZC1; auto.
+Qed.
+
+
 (** Comparison and the successor *)
 
 Lemma Pcompare_p_Sp : forall p : positive, (p ?= Psucc p) Eq = Lt.
@@ -915,6 +975,14 @@ Proof.
   destruct (Pcompare_p_Sq n m) as (H',_); destruct (H' H); subst; auto.
 Qed.
 
+Lemma Ple_lteq : forall p q, p <= q <-> p < q \/ p = q.
+Proof.
+  unfold Ple, Plt. intros.
+  generalize (Pcompare_eq_iff p q).
+  destruct ((p ?= q) Eq); intuition; discriminate.
+Qed.
+
+
 (**********************************************************************)
 (** Properties of subtraction on binary positive numbers *)
 
@@ -940,14 +1008,14 @@ Qed.
 Theorem Pminus_mask_carry_spec :
   forall p q : positive, Pminus_mask_carry p q = Ppred_mask (Pminus_mask p q).
 Proof.
-  induction p as [p IHp|p IHp| ]; destruct q; simpl; 
+  induction p as [p IHp|p IHp| ]; destruct q; simpl;
    try reflexivity; try rewrite IHp;
    destruct (Pminus_mask p q) as [|[r|r| ]|] || destruct p; auto.
 Qed.
 
 Theorem Pminus_succ_r : forall p q : positive, p - (Psucc q) = Ppred (p - q).
 Proof.
-  intros p q; unfold Pminus; 
+  intros p q; unfold Pminus;
   rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec.
   destruct (Pminus_mask p q) as [|[r|r| ]|]; auto.
 Qed.
@@ -986,11 +1054,11 @@ Proof.
   induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto.
 Qed.
 
-Lemma Pminus_mask_IsNeg : forall p q:positive, 
+Lemma Pminus_mask_IsNeg : forall p q:positive,
  Pminus_mask p q = IsNeg -> Pminus_mask_carry p q = IsNeg.
 Proof.
-  induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; 
-   try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H; 
+  induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto;
+   try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H;
    specialize IHp with q.
   destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto.
   destruct (Pminus_mask p q); simpl; auto; try discriminate.
@@ -1019,9 +1087,9 @@ Lemma Pminus_mask_Gt :
       Pminus_mask p q = IsPos h /\
       q + h = p /\ (h = 1 \/ Pminus_mask_carry p q = IsPos (Ppred h)).
 Proof.
-  induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *; 
+  induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *;
    try discriminate H.
-  (* p~1, q~1 *) 
+  (* p~1, q~1 *)
   destruct (IHp q H) as (r & U & V & W); exists (r~0); rewrite ?U, ?V; auto.
   repeat split; auto; right.
   destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]].
@@ -1082,10 +1150,10 @@ Qed.
 
 (** Number of digits in a number *)
 
-Fixpoint Psize (p:positive) : nat := 
-  match p with 
+Fixpoint Psize (p:positive) : nat :=
+  match p with
     | 1 => S O
-    | p~1 => S (Psize p) 
+    | p~1 => S (Psize p)
     | p~0 => S (Psize p)
   end.
 
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
index 6ece00d7..53ba50ff 100644
--- a/theories/NArith/NArith.v
+++ b/theories/NArith/NArith.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: NArith.v 10751 2008-04-04 10:23:35Z herbelin $ *)
+(* $Id$ *)
 
 (** Library for binary natural numbers *)
 
diff --git a/theories/NArith/NOrderedType.v b/theories/NArith/NOrderedType.v
new file mode 100644
index 00000000..c5dd395b
--- /dev/null
+++ b/theories/NArith/NOrderedType.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinNat Equalities Orders OrdersTac.
+
+Local Open Scope N_scope.
+
+(** * DecidableType structure for [N] binary natural numbers *)
+
+Module N_as_UBE <: UsualBoolEq.
+ Definition t := N.
+ Definition eq := @eq N.
+ Definition eqb := Neqb.
+ Definition eqb_eq := Neqb_eq.
+End N_as_UBE.
+
+Module N_as_DT <: UsualDecidableTypeFull := Make_UDTF N_as_UBE.
+
+(** Note that the last module fulfills by subtyping many other
+    interfaces, such as [DecidableType] or [EqualityType]. *)
+
+
+
+(** * OrderedType structure for [N] numbers *)
+
+Module N_as_OT <: OrderedTypeFull.
+ Include N_as_DT.
+ Definition lt := Nlt.
+ Definition le := Nle.
+ Definition compare := Ncompare.
+
+ Instance lt_strorder : StrictOrder Nlt.
+ Proof. split; [ exact Nlt_irrefl | exact Nlt_trans ]. Qed.
+
+ Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Nlt.
+ Proof. repeat red; intros; subst; auto. Qed.
+
+ Definition le_lteq := Nle_lteq.
+ Definition compare_spec := Ncompare_spec.
+
+End N_as_OT.
+
+(** Note that [N_as_OT] can also be seen as a [UsualOrderedType]
+   and a [OrderedType] (and also as a [DecidableType]). *)
+
+
+
+(** * An [order] tactic for [N] numbers *)
+
+Module NOrder := OTF_to_OrderTac N_as_OT.
+Ltac n_order := NOrder.order.
+
+(** Note that [n_order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
+
diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v
index 5bd9a378..9540aace 100644
--- a/theories/NArith/Ndec.v
+++ b/theories/NArith/Ndec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ndec.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Bool.
 Require Import Sumbool.
@@ -19,73 +19,49 @@ Require Import Ndigits.
 
 (** A boolean equality over [N] *)
 
-Fixpoint Peqb (p1 p2:positive) {struct p2} : bool :=
-  match p1, p2 with
-  | xH, xH => true
-  | xO p'1, xO p'2 => Peqb p'1 p'2
-  | xI p'1, xI p'2 => Peqb p'1 p'2
-  | _, _ => false
-  end.
+Notation Peqb := Peqb (only parsing). (* Now in [BinPos] *)
+Notation Neqb := Neqb (only parsing). (* Now in [BinNat] *)
 
-Lemma Peqb_correct : forall p, Peqb p p = true.
-Proof.
-induction p; auto.
-Qed.
+Notation Peqb_correct := Peqb_refl (only parsing).
 
-Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
+Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'.
 Proof.
- induction p; destruct p'; simpl; intros; try discriminate; auto.
+  intros. now apply (Peqb_eq p p').
 Qed.
 
-Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'.
+Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
 Proof.
-  intros.
-  apply Pcompare_Eq_eq.
-  apply Peqb_Pcompare; auto.
+  intros. now rewrite Pcompare_eq_iff, <- Peqb_eq.
 Qed.
 
 Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true.
-Proof. 
-intros; rewrite <- (Pcompare_Eq_eq _ _ H).
-apply Peqb_correct.
+Proof.
+  intros; now rewrite Peqb_eq, <- Pcompare_eq_iff.
 Qed.
 
-Definition Neqb (a a':N) :=
-  match a, a' with
-  | N0, N0 => true
-  | Npos p, Npos p' => Peqb p p'
-  | _, _ => false
-  end.
-
 Lemma Neqb_correct : forall n, Neqb n n = true.
 Proof.
-  destruct n; trivial.
-  simpl; apply Peqb_correct.
+  intros; now rewrite Neqb_eq.
 Qed.
 
 Lemma Neqb_Ncompare : forall n n', Neqb n n' = true -> Ncompare n n' = Eq.
 Proof.
- destruct n; destruct n'; simpl; intros; try discriminate; auto; apply Peqb_Pcompare; auto.
+  intros; now rewrite Ncompare_eq_correct, <- Neqb_eq.
 Qed.
 
 Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true.
-Proof. 
-intros; rewrite <- (Ncompare_Eq_eq _ _ H).
-apply Neqb_correct.
+Proof.
+  intros; now rewrite Neqb_eq, <- Ncompare_eq_correct.
 Qed.
 
 Lemma Neqb_complete : forall a a', Neqb a a' = true -> a = a'.
 Proof.
-  intros.
-  apply Ncompare_Eq_eq.
-  apply Neqb_Ncompare; auto.
+  intros; now rewrite <- Neqb_eq.
 Qed.
 
 Lemma Neqb_comm : forall a a', Neqb a a' = Neqb a' a.
 Proof.
-  intros; apply bool_1; split; intros.
-  rewrite (Neqb_complete _ _ H); apply Neqb_correct.
-  rewrite (Neqb_complete _ _ H); apply Neqb_correct.
+  intros; apply eq_true_iff_eq. rewrite 2 Neqb_eq; auto with *.
 Qed.
 
 Lemma Nxor_eq_true :
@@ -98,7 +74,8 @@ Lemma Nxor_eq_false :
  forall a a' p, Nxor a a' = Npos p -> Neqb a a' = false.
 Proof.
   intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
-  rewrite (Neqb_complete a a' H0) in H. rewrite (Nxor_nilpotent a') in H. discriminate H.
+  rewrite (Neqb_complete a a' H0) in H.
+  rewrite (Nxor_nilpotent a') in H. discriminate H.
   trivial.
 Qed.
 
@@ -107,7 +84,7 @@ Lemma Nodd_not_double :
    Nodd a -> forall a0, Neqb (Ndouble a0) a = false.
 Proof.
   intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
-  rewrite <- (Neqb_complete _ _ H0) in H. 
+  rewrite <- (Neqb_complete _ _ H0) in H.
   unfold Nodd in H.
   rewrite (Ndouble_bit0 a0) in H. discriminate H.
   trivial.
@@ -128,7 +105,7 @@ Lemma Neven_not_double_plus_one :
    Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false.
 Proof.
   intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0.
-  rewrite <- (Neqb_complete _ _ H0) in H. 
+  rewrite <- (Neqb_complete _ _ H0) in H.
   unfold Neven in H.
   rewrite (Ndouble_plus_one_bit0 a0) in H.
   discriminate H.
@@ -149,7 +126,8 @@ Lemma Nbit0_neq :
  forall a a',
    Nbit0 a = false -> Nbit0 a' = true -> Neqb a a' = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb a a')). intro H1. rewrite (Neqb_complete _ _ H1) in H.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H1.
+  rewrite (Neqb_complete _ _ H1) in H.
   rewrite H in H0. discriminate H0.
   trivial.
 Qed.
@@ -166,7 +144,8 @@ Lemma Ndiv2_neq :
    Neqb (Ndiv2 a) (Ndiv2 a') = false -> Neqb a a' = false.
 Proof.
   intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
-  rewrite (Neqb_complete _ _ H0) in H. rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H.
+  rewrite (Neqb_complete _ _ H0) in H.
+  rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H.
   trivial.
 Qed.
 
@@ -354,6 +333,35 @@ Proof.
   trivial.
 Qed.
 
+(* Nleb and Ncompare *)
+
+(* NB: No need to prove that Nleb a b = true <-> Ncompare a b <> Gt,
+   this statement is in fact Nleb_Nle! *)
+
+Lemma Nltb_Ncompare : forall a b,
+ Nleb a b = false <-> Ncompare a b = Gt.
+Proof.
+ intros.
+ assert (IFF : forall x:bool, x = false <-> ~ x = true)
+   by (destruct x; intuition).
+ rewrite IFF, Nleb_Nle; unfold Nle.
+ destruct (Ncompare a b); split; intro H; auto;
+  elim H; discriminate.
+Qed.
+
+Lemma Ncompare_Gt_Nltb : forall a b,
+ Ncompare a b = Gt -> Nleb a b = false.
+Proof.
+ intros; apply <- Nltb_Ncompare; auto.
+Qed.
+
+Lemma Ncompare_Lt_Nltb : forall a b,
+ Ncompare a b = Lt -> Nleb b a = false.
+Proof.
+ intros a b H.
+ rewrite Nltb_Ncompare, <- Ncompare_antisym, H; auto.
+Qed.
+
 (* An alternate [min] function over [N] *)
 
 Definition Nmin' (a b:N) := if Nleb a b then a else b.
@@ -362,8 +370,8 @@ Lemma Nmin_Nmin' : forall a b, Nmin a b = Nmin' a b.
 Proof.
  unfold Nmin, Nmin', Nleb; intros.
  rewrite nat_of_Ncompare.
- generalize (leb_compare (nat_of_N a) (nat_of_N b)); 
- destruct (nat_compare (nat_of_N a) (nat_of_N b)); 
+ generalize (leb_compare (nat_of_N a) (nat_of_N b));
+ destruct (nat_compare (nat_of_N a) (nat_of_N b));
  destruct (leb (nat_of_N a) (nat_of_N b)); intuition.
  lapply H1; intros; discriminate.
  lapply H1; intros; discriminate.
@@ -392,7 +400,7 @@ Qed.
 Lemma Nmin_le_3 :
  forall a b c, Nleb a (Nmin b c) = true -> Nleb a b = true.
 Proof.
-  intros; rewrite Nmin_Nmin' in *. 
+  intros; rewrite Nmin_Nmin' in *.
   unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
   assumption.
   intro H0. rewrite H0 in H. apply Nltb_leb_weak. apply Nleb_ltb_trans with (b := c); assumption.
@@ -401,7 +409,7 @@ Qed.
 Lemma Nmin_le_4 :
  forall a b c, Nleb a (Nmin b c) = true -> Nleb a c = true.
 Proof.
-  intros; rewrite Nmin_Nmin' in *. 
+  intros; rewrite Nmin_Nmin' in *.
   unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
   apply Nleb_trans with (b := b); assumption.
   intro H0. rewrite H0 in H. assumption.
@@ -418,7 +426,7 @@ Qed.
 Lemma Nmin_lt_3 :
  forall a b c, Nleb (Nmin b c) a = false -> Nleb b a = false.
 Proof.
-  intros; rewrite Nmin_Nmin' in *. 
+  intros; rewrite Nmin_Nmin' in *.
   unfold Nmin' in *. intros. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
   assumption.
   intro H0. rewrite H0 in H. apply Nltb_trans with (b := c); assumption.
@@ -427,7 +435,7 @@ Qed.
 Lemma Nmin_lt_4 :
  forall a b c, Nleb (Nmin b c) a = false -> Nleb c a = false.
 Proof.
-  intros; rewrite Nmin_Nmin' in *. 
+  intros; rewrite Nmin_Nmin' in *.
   unfold Nmin' in *. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
   apply Nltb_leb_trans with (b := b); assumption.
   intro H0. rewrite H0 in H. assumption.
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
index fb32274e..b6c18e9b 100644
--- a/theories/NArith/Ndigits.v
+++ b/theories/NArith/Ndigits.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ndigits.v 11735 2009-01-02 17:22:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Bool.
 Require Import Bvector.
@@ -17,7 +17,7 @@ Require Import BinNat.
 
 (** [xor] *)
 
-Fixpoint Pxor (p1 p2:positive) {struct p1} : N :=
+Fixpoint Pxor (p1 p2:positive) : N :=
   match p1, p2 with
   | xH, xH => N0
   | xH, xO p2 => Npos (xI p2)
@@ -27,7 +27,7 @@ Fixpoint Pxor (p1 p2:positive) {struct p1} : N :=
   | xO p1, xI p2 => Ndouble_plus_one (Pxor p1 p2)
   | xI p1, xH => Npos (xO p1)
   | xI p1, xO p2 => Ndouble_plus_one (Pxor p1 p2)
-  | xI p1, xI p2 => Ndouble (Pxor p1 p2) 
+  | xI p1, xI p2 => Ndouble (Pxor p1 p2)
   end.
 
 Definition Nxor (n n':N) :=
@@ -65,7 +65,7 @@ Proof.
   simpl. rewrite IHp; reflexivity.
 Qed.
 
-(** Checking whether a particular bit is set on not *) 
+(** Checking whether a particular bit is set on not *)
 
 Fixpoint Pbit (p:positive) : nat -> bool :=
   match p with
@@ -134,13 +134,13 @@ Qed.
 
 (** End of auxilliary results *)
 
-(** This part is aimed at proving that if two numbers produce 
+(** This part is aimed at proving that if two numbers produce
   the same stream of bits, then they are equal. *)
 
 Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a.
 Proof.
   destruct a. trivial.
-  induction p as [p IHp| p IHp| ]; intro H. 
+  induction p as [p IHp| p IHp| ]; intro H.
   absurd (N0 = Npos p). discriminate.
   exact (IHp (fun n => H (S n))).
   absurd (N0 = Npos p). discriminate.
@@ -196,7 +196,7 @@ Proof.
   assert (Npos p = Npos p') by exact (IHp (Npos p') H0).
   inversion H1. reflexivity.
   assumption.
-  intros. apply Nbit_faithful_3. intros. 
+  intros. apply Nbit_faithful_3. intros.
   assert (Npos p = Npos p') by exact (IHp (Npos p') H0).
   inversion H1. reflexivity.
   assumption.
@@ -257,7 +257,7 @@ Proof.
   generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H.
   unfold xorf in *.
   destruct a as [|p]. simpl Nbit; rewrite false_xorb. reflexivity.
-  destruct a' as [|p0]. 
+  destruct a' as [|p0].
   simpl Nbit; rewrite xorb_false. reflexivity.
   destruct p. destruct p0; simpl Nbit in *.
   rewrite <- H; simpl; case (Pxor p p0); trivial.
@@ -273,13 +273,13 @@ Qed.
 Lemma Nxor_semantics :
  forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')).
 Proof.
-  unfold eqf. intros; generalize a, a'. induction n. 
+  unfold eqf. intros; generalize a, a'. induction n.
   apply Nxor_sem_5. apply Nxor_sem_6; assumption.
 Qed.
 
-(** Consequences: 
+(** Consequences:
        - only equal numbers lead to a null xor
-       - xor is associative 
+       - xor is associative
 *)
 
 Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'.
@@ -306,7 +306,7 @@ Proof.
   apply eqf_sym, Nxor_semantics.
 Qed.
 
-(** Checking whether a number is odd, i.e. 
+(** Checking whether a number is odd, i.e.
    if its lower bit is set. *)
 
 Definition Nbit0 (n:N) :=
@@ -380,8 +380,8 @@ Lemma Nneg_bit0 :
  forall a a':N,
    Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a').
 Proof.
-  intros. 
-  rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. 
+  intros.
+  rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false.
   reflexivity.
 Qed.
 
@@ -402,14 +402,14 @@ Lemma Nsame_bit0 :
  forall (a a':N) (p:positive),
    Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'.
 Proof.
-  intros. rewrite <- (xorb_false (Nbit0 a)). 
+  intros. rewrite <- (xorb_false (Nbit0 a)).
   assert (H0: Nbit0 (Npos (xO p)) = false) by reflexivity.
   rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity.
 Qed.
 
 (** a lexicographic order on bits, starting from the lowest bit *)
 
-Fixpoint Nless_aux (a a':N) (p:positive) {struct p} : bool :=
+Fixpoint Nless_aux (a a':N) (p:positive) : bool :=
   match p with
   | xO p' => Nless_aux (Ndiv2 a) (Ndiv2 a') p'
   | _ => andb (negb (Nbit0 a)) (Nbit0 a')
@@ -430,7 +430,7 @@ Proof.
   assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
   simpl. rewrite H, H0. reflexivity.
-  assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). 
+  assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
 Qed.
 
@@ -443,7 +443,7 @@ Proof.
   assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
   simpl. rewrite H, H0. reflexivity.
-  assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). 
+  assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
 Qed.
 
@@ -496,14 +496,14 @@ Qed.
 Lemma N0_less_1 :
  forall a, Nless N0 a = true -> {p : positive | a = Npos p}.
 Proof.
-  destruct a. intros. discriminate.
+  destruct a. discriminate.
   intros. exists p. reflexivity.
 Qed.
 
 Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0.
 Proof.
   induction a as [|p]; intro H. trivial.
-  elimtype False. induction p as [|p IHp|]; discriminate || simpl; auto using IHp.
+  exfalso. induction p as [|p IHp|]; discriminate || simpl; auto using IHp.
 Qed.
 
 Lemma Nless_trans :
@@ -534,7 +534,7 @@ Proof.
         rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H.
           rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0).
 Qed.
- 
+
 Lemma Nless_total :
  forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
 Proof.
@@ -558,7 +558,7 @@ Qed.
 
 (** Number of digits in a number *)
 
-Definition Nsize (n:N) : nat := match n with 
+Definition Nsize (n:N) : nat := match n with
   | N0 => 0%nat
   | Npos p => Psize p
  end.
@@ -566,35 +566,35 @@ Definition Nsize (n:N) : nat := match n with
 
 (** conversions between N and bit vectors. *)
 
-Fixpoint P2Bv (p:positive) : Bvector (Psize p) := 
- match p return Bvector (Psize p) with 
+Fixpoint P2Bv (p:positive) : Bvector (Psize p) :=
+ match p return Bvector (Psize p) with
    | xH => Bvect_true 1%nat
    | xO p => Bcons false (Psize p) (P2Bv p)
    | xI p => Bcons true (Psize p) (P2Bv p)
  end.
 
 Definition N2Bv (n:N) : Bvector (Nsize n) :=
-  match n as n0 return Bvector (Nsize n0) with 
+  match n as n0 return Bvector (Nsize n0) with
     | N0 => Bnil
     | Npos p => P2Bv p
   end.
 
-Fixpoint Bv2N (n:nat)(bv:Bvector n) {struct bv} : N := 
-  match bv with 
+Fixpoint Bv2N (n:nat)(bv:Bvector n) : N :=
+  match bv with
     | Vnil => N0
     | Vcons false n bv => Ndouble (Bv2N n bv)
-    | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) 
+    | Vcons true n bv => Ndouble_plus_one (Bv2N n bv)
   end.
 
 Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
-Proof. 
+Proof.
 destruct n.
 simpl; auto.
 induction p; simpl in *; auto; rewrite IHp; simpl; auto.
 Qed.
 
-(** The opposite composition is not so simple: if the considered 
-  bit vector has some zeros on its right, they will disappear during 
+(** The opposite composition is not so simple: if the considered
+  bit vector has some zeros on its right, they will disappear during
   the return [Bv2N] translation: *)
 
 Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n.
@@ -603,16 +603,16 @@ induction n; intros.
 rewrite (V0_eq _ bv); simpl; auto.
 rewrite (VSn_eq _ _ bv); simpl.
 specialize IHn with (Vtail _ _ bv).
-destruct (Vhead _ _ bv); 
- destruct (Bv2N n (Vtail bool n bv)); 
+destruct (Vhead _ _ bv);
+ destruct (Bv2N n (Vtail bool n bv));
   simpl; auto with arith.
 Qed.
 
 (** In the previous lemma, we can only replace the inequality by
   an equality whenever the highest bit is non-null. *)
 
-Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), 
-  Bsign _ bv = true <-> 
+Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)),
+  Bsign _ bv = true <->
   Nsize (Bv2N _ bv) = (S n).
 Proof.
 induction n; intro.
@@ -621,18 +621,18 @@ rewrite (V0_eq _ (Vtail _ _ bv)); simpl.
 destruct (Vhead _ _ bv); simpl; intuition; try discriminate.
 rewrite (VSn_eq _ _ bv); simpl.
 generalize (IHn (Vtail _ _ bv)); clear IHn.
-destruct (Vhead _ _ bv); 
- destruct (Bv2N (S n) (Vtail bool (S n) bv)); 
+destruct (Vhead _ _ bv);
+ destruct (Bv2N (S n) (Vtail bool (S n) bv));
   simpl; intuition; try discriminate.
 Qed.
 
-(** To state nonetheless a second result about composition of 
- conversions, we define a conversion on a given number of bits : *) 
+(** To state nonetheless a second result about composition of
+ conversions, we define a conversion on a given number of bits : *)
 
-Fixpoint N2Bv_gen (n:nat)(a:N) { struct n } : Bvector n := 
- match n return Bvector n with 
+Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n :=
+ match n return Bvector n with
    | 0 => Bnil
-   | S n => match a with 
+   | S n => match a with
        | N0 => Bvect_false (S n)
        | Npos xH => Bcons true _ (Bvect_false n)
        | Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p))
@@ -649,10 +649,10 @@ auto.
 induction p; simpl; intros; auto; congruence.
 Qed.
 
-(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of 
+(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of
    [a] plus some zeros. *)
 
-Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), 
+Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat),
  N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k).
 Proof.
 destruct a; simpl.
@@ -662,7 +662,7 @@ Qed.
 
 (** Here comes now the second composition result. *)
 
-Lemma N2Bv_Bv2N : forall n (bv:Bvector n), 
+Lemma N2Bv_Bv2N : forall n (bv:Bvector n),
    N2Bv_gen n (Bv2N n bv) = bv.
 Proof.
 induction n; intros.
@@ -670,36 +670,36 @@ rewrite (V0_eq _ bv); simpl; auto.
 rewrite (VSn_eq _ _ bv); simpl.
 generalize (IHn (Vtail _ _ bv)); clear IHn.
 unfold Bcons.
-destruct (Bv2N _ (Vtail _ _ bv)); 
- destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; 
+destruct (Bv2N _ (Vtail _ _ bv));
+ destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial;
   induction n; simpl; auto.
 Qed.
 
 (** accessing some precise bits. *)
 
-Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), 
+Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)),
   Nbit0 (Bv2N _ bv) = Blow _ bv.
 Proof.
 intros.
 unfold Blow.
 rewrite (VSn_eq _ _ bv) at 1.
 simpl.
-destruct (Bv2N n (Vtail bool n bv)); simpl; 
+destruct (Bv2N n (Vtail bool n bv)); simpl;
  destruct (Vhead bool n bv); auto.
 Qed.
 
 Definition Bnth (n:nat)(bv:Bvector n)(p:nat) : p<n -> bool.
 Proof.
- induction 1.
+ induction bv in p |- *.
  intros.
- elimtype False; inversion H.
+ exfalso; inversion H.
  intros.
  destruct p.
  exact a.
  apply (IHbv p); auto with arith.
 Defined.
 
-Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n), 
+Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n),
   Bnth _ bv p H = Nbit (Bv2N _ bv) p.
 Proof.
 induction bv; intros.
@@ -726,7 +726,7 @@ Qed.
 
 (** Xor is the same in the two worlds. *)
 
-Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), 
+Lemma Nxor_BVxor : forall n (bv bv' : Bvector n),
   Bv2N _ (BVxor _ bv bv') = Nxor (Bv2N _ bv) (Bv2N _ bv').
 Proof.
 induction n.
@@ -735,7 +735,7 @@ rewrite (V0_eq _ bv), (V0_eq _ bv'); simpl; auto.
 intros.
 rewrite (VSn_eq _ _ bv), (VSn_eq _ _ bv'); simpl; auto.
 rewrite IHn.
-destruct (Vhead bool n bv); destruct (Vhead bool n bv'); 
+destruct (Vhead bool n bv); destruct (Vhead bool n bv');
  destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto.
 Qed.
 
diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v
index af90b8e7..92559ff6 100644
--- a/theories/NArith/Ndist.v
+++ b/theories/NArith/Ndist.v
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	     $Id: Ndist.v 10739 2008-04-01 14:45:20Z herbelin $	      i*)
+(*i 	     $Id$	      i*)
 
 Require Import Arith.
 Require Import Min.
@@ -34,7 +34,7 @@ Definition Nplength (a:N) :=
 
 Lemma Nplength_infty : forall a:N, Nplength a = infty -> a = N0.
 Proof.
-  simple induction a; trivial. 
+  simple induction a; trivial.
   unfold Nplength in |- *; intros; discriminate H.
 Qed.
 
@@ -42,7 +42,7 @@ Lemma Nplength_zeros :
  forall (a:N) (n:nat),
    Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false.
 Proof.
-  simple induction a; trivial. 
+  simple induction a; trivial.
   simple induction p. simple induction n. intros. inversion H1.
   simple induction k. simpl in H1. discriminate H1.
   intros. simpl in H1. discriminate H1.
@@ -116,11 +116,11 @@ Qed.
 Lemma ni_min_assoc :
  forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d'').
 Proof.
-  simple induction d; trivial. simple induction d'; trivial. 
+  simple induction d; trivial. simple induction d'; trivial.
   simple induction d''; trivial.
   unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
   intro. rewrite H. reflexivity.
-  generalize n0 n1. elim n; trivial. 
+  generalize n0 n1. elim n; trivial.
   simple induction n3; trivial. simple induction n5; trivial.
   intros. simpl in |- *. auto.
 Qed.
@@ -250,10 +250,10 @@ Proof.
 Qed.
 
 
-(** We define an ultrametric distance between [N] numbers: 
-    $d(a,a')=1/2^pd(a,a')$, 
-    where $pd(a,a')$ is the number of identical bits at the beginning 
-    of $a$ and $a'$ (infinity if $a=a'$).  
+(** We define an ultrametric distance between [N] numbers:
+    $d(a,a')=1/2^pd(a,a')$,
+    where $pd(a,a')$ is the number of identical bits at the beginning
+    of $a$ and $a'$ (infinity if $a=a'$).
     Instead of working with $d$, we work with $pd$, namely
     [Npdist]: *)
 
@@ -286,7 +286,7 @@ Qed.
   This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{Nplength}}(a))$
   is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$,
   or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that
-  min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq 
+  min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq
   \texttt{Nplength} (a~\texttt{xor}~ b)$
   (lemma [Nplength_ultra]).
 *)
diff --git a/theories/NArith/Nminmax.v b/theories/NArith/Nminmax.v
new file mode 100644
index 00000000..475b4dfb
--- /dev/null
+++ b/theories/NArith/Nminmax.v
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Orders BinNat Nnat NOrderedType GenericMinMax.
+
+(** * Maximum and Minimum of two [N] numbers *)
+
+Local Open Scope N_scope.
+
+(** The functions [Nmax] and [Nmin] implement indeed
+    a maximum and a minimum *)
+
+Lemma Nmax_l : forall x y, y<=x -> Nmax x y = x.
+Proof.
+ unfold Nle, Nmax. intros x y.
+ generalize (Ncompare_eq_correct x y). rewrite <- (Ncompare_antisym x y).
+ destruct (x ?= y); intuition.
+Qed.
+
+Lemma Nmax_r : forall x y, x<=y -> Nmax x y = y.
+Proof.
+ unfold Nle, Nmax. intros x y. destruct (x ?= y); intuition.
+Qed.
+
+Lemma Nmin_l : forall x y, x<=y -> Nmin x y = x.
+Proof.
+ unfold Nle, Nmin. intros x y. destruct (x ?= y); intuition.
+Qed.
+
+Lemma Nmin_r : forall x y, y<=x -> Nmin x y = y.
+Proof.
+ unfold Nle, Nmin. intros x y.
+ generalize (Ncompare_eq_correct x y). rewrite <- (Ncompare_antisym x y).
+ destruct (x ?= y); intuition.
+Qed.
+
+Module NHasMinMax <: HasMinMax N_as_OT.
+ Definition max := Nmax.
+ Definition min := Nmin.
+ Definition max_l := Nmax_l.
+ Definition max_r := Nmax_r.
+ Definition min_l := Nmin_l.
+ Definition min_r := Nmin_r.
+End NHasMinMax.
+
+Module N.
+
+(** We obtain hence all the generic properties of max and min. *)
+
+Include UsualMinMaxProperties N_as_OT NHasMinMax.
+
+(** * Properties specific to the [positive] domain *)
+
+(** Simplifications *)
+
+Lemma max_0_l : forall n, Nmax 0 n = n.
+Proof.
+ intros. unfold Nmax. rewrite <- Ncompare_antisym. generalize (Ncompare_0 n).
+ destruct (n ?= 0); intuition.
+Qed.
+
+Lemma max_0_r : forall n, Nmax n 0 = n.
+Proof. intros. rewrite N.max_comm. apply max_0_l. Qed.
+
+Lemma min_0_l : forall n, Nmin 0 n = 0.
+Proof.
+ intros. unfold Nmin. rewrite <- Ncompare_antisym. generalize (Ncompare_0 n).
+ destruct (n ?= 0); intuition.
+Qed.
+
+Lemma min_0_r : forall n, Nmin n 0 = 0.
+Proof. intros. rewrite N.min_comm. apply min_0_l. Qed.
+
+(** Compatibilities (consequences of monotonicity) *)
+
+Lemma succ_max_distr :
+ forall n m, Nsucc (Nmax n m) = Nmax (Nsucc n) (Nsucc m).
+Proof.
+ intros. symmetry. apply max_monotone.
+ intros x x'. unfold Nle.
+ rewrite 2 nat_of_Ncompare, 2 nat_of_Nsucc.
+ simpl; auto.
+Qed.
+
+Lemma succ_min_distr : forall n m, Nsucc (Nmin n m) = Nmin (Nsucc n) (Nsucc m).
+Proof.
+ intros. symmetry. apply min_monotone.
+ intros x x'. unfold Nle.
+ rewrite 2 nat_of_Ncompare, 2 nat_of_Nsucc.
+ simpl; auto.
+Qed.
+
+Lemma plus_max_distr_l : forall n m p, Nmax (p + n) (p + m) = p + Nmax n m.
+Proof.
+ intros. apply max_monotone.
+ intros x x'. unfold Nle.
+ rewrite 2 nat_of_Ncompare, 2 nat_of_Nplus.
+ rewrite <- 2 Compare_dec.nat_compare_le. auto with arith.
+Qed.
+
+Lemma plus_max_distr_r : forall n m p, Nmax (n + p) (m + p) = Nmax n m + p.
+Proof.
+ intros. rewrite (Nplus_comm n p), (Nplus_comm m p), (Nplus_comm _ p).
+ apply plus_max_distr_l.
+Qed.
+
+Lemma plus_min_distr_l : forall n m p, Nmin (p + n) (p + m) = p + Nmin n m.
+Proof.
+ intros. apply min_monotone.
+ intros x x'. unfold Nle.
+ rewrite 2 nat_of_Ncompare, 2 nat_of_Nplus.
+ rewrite <- 2 Compare_dec.nat_compare_le. auto with arith.
+Qed.
+
+Lemma plus_min_distr_r : forall n m p, Nmin (n + p) (m + p) = Nmin n m + p.
+Proof.
+ intros. rewrite (Nplus_comm n p), (Nplus_comm m p), (Nplus_comm _ p).
+ apply plus_min_distr_l.
+Qed.
+
+End N.
\ No newline at end of file
diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v
index bc3711ee..0016d035 100644
--- a/theories/NArith/Nnat.v
+++ b/theories/NArith/Nnat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Nnat.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Arith_base.
 Require Import Compare_dec.
@@ -39,7 +39,7 @@ Definition N_of_nat (n:nat) :=
 Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N a) = a.
 Proof.
   destruct a as [| p]. reflexivity.
-  simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. 
+  simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *.
   rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H.
   rewrite nat_of_P_inj with (1 := H). reflexivity.
 Qed.
@@ -66,14 +66,14 @@ Proof.
   apply N_of_nat_of_N.
 Qed.
 
-Lemma nat_of_Ndouble_plus_one : 
+Lemma nat_of_Ndouble_plus_one :
   forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)).
 Proof.
   destruct a; simpl nat_of_N; auto.
   apply nat_of_P_xI.
 Qed.
 
-Lemma N_of_double_plus_one : 
+Lemma N_of_double_plus_one :
   forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n).
 Proof.
   intros.
@@ -97,14 +97,14 @@ Proof.
   apply N_of_nat_of_N.
 Qed.
 
-Lemma nat_of_Nplus : 
+Lemma nat_of_Nplus :
   forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a').
 Proof.
   destruct a; destruct a'; simpl; auto.
   apply nat_of_P_plus_morphism.
 Qed.
 
-Lemma N_of_plus : 
+Lemma N_of_plus :
   forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n').
 Proof.
   intros.
@@ -138,14 +138,14 @@ Proof.
   apply N_of_nat_of_N.
 Qed.
 
-Lemma nat_of_Nmult : 
+Lemma nat_of_Nmult :
   forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a').
 Proof.
   destruct a; destruct a'; simpl; auto.
   apply nat_of_P_mult_morphism.
 Qed.
 
-Lemma N_of_mult : 
+Lemma N_of_mult :
   forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n').
 Proof.
   intros.
@@ -155,7 +155,7 @@ Proof.
   apply N_of_nat_of_N.
 Qed.
 
-Lemma nat_of_Ndiv2 : 
+Lemma nat_of_Ndiv2 :
   forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a).
 Proof.
   destruct a; simpl in *; auto.
@@ -164,9 +164,9 @@ Proof.
   rewrite div2_double_plus_one; auto.
   rewrite nat_of_P_xO.
   rewrite div2_double; auto.
-Qed.  
+Qed.
 
-Lemma N_of_div2 : 
+Lemma N_of_div2 :
   forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n).
 Proof.
   intros.
@@ -175,29 +175,19 @@ Proof.
   apply N_of_nat_of_N.
 Qed.
 
-Lemma nat_of_Ncompare : 
+Lemma nat_of_Ncompare :
  forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a').
 Proof.
   destruct a; destruct a'; simpl.
-  compute; auto.
-  generalize (lt_O_nat_of_P p).
-  unfold nat_compare.
-  destruct (lt_eq_lt_dec 0 (nat_of_P p)) as [[H|H]|H]; auto.
-  rewrite <- H; inversion 1.
-  intros; generalize (lt_trans _ _ _ H0 H); inversion 1.
-  generalize (lt_O_nat_of_P p).
-  unfold nat_compare.
-  destruct (lt_eq_lt_dec (nat_of_P p) 0) as [[H|H]|H]; auto.
-  intros; generalize (lt_trans _ _ _ H0 H); inversion 1.
-  rewrite H; inversion 1.
-  unfold nat_compare.
-  destruct (lt_eq_lt_dec (nat_of_P p) (nat_of_P p0)) as [[H|H]|H]; auto.
-  apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
-  rewrite (nat_of_P_inj _ _ H); apply Pcompare_refl.
-  apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
-Qed.
-
-Lemma N_of_nat_compare : 
+  reflexivity.
+  assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P.
+  destruct nat_of_P; [inversion NZ|auto].
+  assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P.
+  destruct nat_of_P; [inversion NZ|auto].
+  apply nat_of_P_compare_morphism.
+Qed.
+
+Lemma N_of_nat_compare :
  forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n').
 Proof.
   intros.
@@ -210,8 +200,8 @@ Lemma nat_of_Nmin :
   forall a a', nat_of_N (Nmin a a') = min (nat_of_N a) (nat_of_N a').
 Proof.
   intros; unfold Nmin; rewrite nat_of_Ncompare.
-  unfold nat_compare.
-  destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; 
+  rewrite nat_compare_equiv; unfold nat_compare_alt.
+  destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|];
     simpl; intros; symmetry; auto with arith.
   apply min_l; rewrite e; auto with arith.
 Qed.
@@ -230,8 +220,8 @@ Lemma nat_of_Nmax :
   forall a a', nat_of_N (Nmax a a') = max (nat_of_N a) (nat_of_N a').
 Proof.
   intros; unfold Nmax; rewrite nat_of_Ncompare.
-  unfold nat_compare.
-  destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; 
+  rewrite nat_compare_equiv; unfold nat_compare_alt.
+  destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|];
     simpl; intros; symmetry; auto with arith.
   apply max_r; rewrite e; auto with arith.
 Qed.
@@ -331,17 +321,17 @@ Qed.
 Lemma Z_of_N_of_nat : forall n:nat, Z_of_N (N_of_nat n) = Z_of_nat n.
 Proof.
  destruct n; simpl; auto.
-Qed. 
+Qed.
 
 Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p.
 Proof.
  destruct p; simpl; auto.
-Qed. 
+Qed.
 
 Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z.
 Proof.
  destruct z; simpl; auto.
-Qed. 
+Qed.
 
 Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z.
 Proof.
@@ -358,22 +348,22 @@ Proof.
  destruct n; destruct m; auto.
 Qed.
 
-Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m). 
+Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m).
 Proof.
  intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nminus; apply inj_minus.
 Qed.
 
-Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). 
+Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n).
 Proof.
  intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S.
 Qed.
 
-Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m). 
+Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m).
 Proof.
  intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min.
 Qed.
 
-Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m). 
+Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m).
 Proof.
  intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmax; apply inj_max.
 Qed.
diff --git a/theories/NArith/POrderedType.v b/theories/NArith/POrderedType.v
new file mode 100644
index 00000000..9c0f8261
--- /dev/null
+++ b/theories/NArith/POrderedType.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinPos Equalities Orders OrdersTac.
+
+Local Open Scope positive_scope.
+
+(** * DecidableType structure for [positive] numbers *)
+
+Module Positive_as_UBE <: UsualBoolEq.
+ Definition t := positive.
+ Definition eq := @eq positive.
+ Definition eqb := Peqb.
+ Definition eqb_eq := Peqb_eq.
+End Positive_as_UBE.
+
+Module Positive_as_DT <: UsualDecidableTypeFull
+ := Make_UDTF Positive_as_UBE.
+
+(** Note that the last module fulfills by subtyping many other
+    interfaces, such as [DecidableType] or [EqualityType]. *)
+
+
+
+(** * OrderedType structure for [positive] numbers *)
+
+Module Positive_as_OT <: OrderedTypeFull.
+ Include Positive_as_DT.
+ Definition lt := Plt.
+ Definition le := Ple.
+ Definition compare p q := Pcompare p q Eq.
+
+ Instance lt_strorder : StrictOrder Plt.
+ Proof. split; [ exact Plt_irrefl | exact Plt_trans ]. Qed.
+
+ Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Plt.
+ Proof. repeat red; intros; subst; auto. Qed.
+
+ Definition le_lteq := Ple_lteq.
+ Definition compare_spec := Pcompare_spec.
+
+End Positive_as_OT.
+
+(** Note that [Positive_as_OT] can also be seen as a [UsualOrderedType]
+   and a [OrderedType] (and also as a [DecidableType]). *)
+
+
+
+(** * An [order] tactic for positive numbers *)
+
+Module PositiveOrder := OTF_to_OrderTac Positive_as_OT.
+Ltac p_order := PositiveOrder.order.
+
+(** Note that [p_order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
diff --git a/theories/NArith/Pminmax.v b/theories/NArith/Pminmax.v
new file mode 100644
index 00000000..4cc48af6
--- /dev/null
+++ b/theories/NArith/Pminmax.v
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Orders BinPos Pnat POrderedType GenericMinMax.
+
+(** * Maximum and Minimum of two positive numbers *)
+
+Local Open Scope positive_scope.
+
+(** The functions [Pmax] and [Pmin] implement indeed
+    a maximum and a minimum *)
+
+Lemma Pmax_l : forall x y, y<=x -> Pmax x y = x.
+Proof.
+ unfold Ple, Pmax. intros x y.
+ rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y).
+ destruct ((x ?= y) Eq); intuition.
+Qed.
+
+Lemma Pmax_r : forall x y, x<=y -> Pmax x y = y.
+Proof.
+ unfold Ple, Pmax. intros x y. destruct ((x ?= y) Eq); intuition.
+Qed.
+
+Lemma Pmin_l : forall x y, x<=y -> Pmin x y = x.
+Proof.
+ unfold Ple, Pmin. intros x y. destruct ((x ?= y) Eq); intuition.
+Qed.
+
+Lemma Pmin_r : forall x y, y<=x -> Pmin x y = y.
+Proof.
+ unfold Ple, Pmin. intros x y.
+ rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y).
+ destruct ((x ?= y) Eq); intuition.
+Qed.
+
+Module PositiveHasMinMax <: HasMinMax Positive_as_OT.
+ Definition max := Pmax.
+ Definition min := Pmin.
+ Definition max_l := Pmax_l.
+ Definition max_r := Pmax_r.
+ Definition min_l := Pmin_l.
+ Definition min_r := Pmin_r.
+End PositiveHasMinMax.
+
+
+Module P.
+(** We obtain hence all the generic properties of max and min. *)
+
+Include UsualMinMaxProperties Positive_as_OT PositiveHasMinMax.
+
+(** * Properties specific to the [positive] domain *)
+
+(** Simplifications *)
+
+Lemma max_1_l : forall n, Pmax 1 n = n.
+Proof.
+ intros. unfold Pmax. rewrite ZC4. generalize (Pcompare_1 n).
+ destruct (n ?= 1); intuition.
+Qed.
+
+Lemma max_1_r : forall n, Pmax n 1 = n.
+Proof. intros. rewrite P.max_comm. apply max_1_l. Qed.
+
+Lemma min_1_l : forall n, Pmin 1 n = 1.
+Proof.
+ intros. unfold Pmin. rewrite ZC4. generalize (Pcompare_1 n).
+ destruct (n ?= 1); intuition.
+Qed.
+
+Lemma min_1_r : forall n, Pmin n 1 = 1.
+Proof. intros. rewrite P.min_comm. apply min_1_l. Qed.
+
+(** Compatibilities (consequences of monotonicity) *)
+
+Lemma succ_max_distr :
+ forall n m, Psucc (Pmax n m) = Pmax (Psucc n) (Psucc m).
+Proof.
+ intros. symmetry. apply max_monotone.
+ intros x x'. unfold Ple.
+ rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_succ_morphism.
+ simpl; auto.
+Qed.
+
+Lemma succ_min_distr : forall n m, Psucc (Pmin n m) = Pmin (Psucc n) (Psucc m).
+Proof.
+ intros. symmetry. apply min_monotone.
+ intros x x'. unfold Ple.
+ rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_succ_morphism.
+ simpl; auto.
+Qed.
+
+Lemma plus_max_distr_l : forall n m p, Pmax (p + n) (p + m) = p + Pmax n m.
+Proof.
+ intros. apply max_monotone.
+ intros x x'. unfold Ple.
+ rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_plus_morphism.
+ rewrite <- 2 Compare_dec.nat_compare_le. auto with arith.
+Qed.
+
+Lemma plus_max_distr_r : forall n m p, Pmax (n + p) (m + p) = Pmax n m + p.
+Proof.
+ intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p).
+ apply plus_max_distr_l.
+Qed.
+
+Lemma plus_min_distr_l : forall n m p, Pmin (p + n) (p + m) = p + Pmin n m.
+Proof.
+ intros. apply min_monotone.
+ intros x x'. unfold Ple.
+ rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_plus_morphism.
+ rewrite <- 2 Compare_dec.nat_compare_le. auto with arith.
+Qed.
+
+Lemma plus_min_distr_r : forall n m p, Pmin (n + p) (m + p) = Pmin n m + p.
+Proof.
+ intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p).
+ apply plus_min_distr_l.
+Qed.
+
+End P.
\ No newline at end of file
diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v
index 2c007398..0891dea2 100644
--- a/theories/NArith/Pnat.v
+++ b/theories/NArith/Pnat.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,12 +7,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Pnat.v 9883 2007-06-07 18:44:59Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import BinPos.
 
 (**********************************************************************)
-(** Properties of the injection from binary positive numbers to Peano 
+(** Properties of the injection from binary positive numbers to Peano
     natural numbers *)
 
 (** Original development by Pierre Crégut, CNET, Lannion, France *)
@@ -22,6 +23,10 @@ Require Import Gt.
 Require Import Plus.
 Require Import Mult.
 Require Import Minus.
+Require Import Compare_dec.
+
+Local Open Scope positive_scope.
+Local Open Scope nat_scope.
 
 (** [nat_of_P] is a morphism for addition *)
 
@@ -46,7 +51,7 @@ Proof.
 intro x; induction x as [p IHp| p IHp| ]; intro y;
  [ destruct y as [p0| p0| ]
  | destruct y as [p0| p0| ]
- | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; 
+ | destruct y as [p| p| ] ]; simpl in |- *; auto with arith;
  intro m;
  [ rewrite IHp; rewrite plus_assoc; trivial with arith
  | rewrite IHp; rewrite plus_assoc; trivial with arith
@@ -71,11 +76,11 @@ intro x; induction x as [p IHp| p IHp| ]; intro y;
  | destruct y as [p| p| ] ]; simpl in |- *; auto with arith;
  [ intros m; rewrite Pmult_nat_plus_carry_morphism; rewrite IHp;
     rewrite plus_assoc_reverse; rewrite plus_assoc_reverse;
-    rewrite (plus_permute m (Pmult_nat p (m + m))); 
+    rewrite (plus_permute m (Pmult_nat p (m + m)));
     trivial with arith
  | intros m; rewrite IHp; apply plus_assoc
  | intros m; rewrite Pmult_nat_succ_morphism;
-    rewrite (plus_comm (m + Pmult_nat p (m + m))); 
+    rewrite (plus_comm (m + Pmult_nat p (m + m)));
     apply plus_assoc_reverse
  | intros m; rewrite IHp; apply plus_permute
  | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
@@ -106,7 +111,7 @@ Proof.
 intro p; change 2 with (1 + 1) in |- *; rewrite Pmult_nat_r_plus_morphism;
  trivial.
 Qed.
- 
+
 (** [nat_of_P] is a morphism for multiplication *)
 
 Theorem nat_of_P_mult_morphism :
@@ -129,11 +134,11 @@ Proof.
 intro y; induction y as [p H| p H| ];
  [ destruct H as [x H1]; exists (S x + S x); unfold nat_of_P in |- *;
     simpl in |- *; change 2 with (1 + 1) in |- *;
-    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; 
+    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1;
     rewrite H1; auto with arith
  | destruct H as [x H2]; exists (x + S x); unfold nat_of_P in |- *;
     simpl in |- *; change 2 with (1 + 1) in |- *;
-    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; 
+    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2;
     rewrite H2; auto with arith
  | exists 0; auto with arith ].
 Qed.
@@ -161,7 +166,7 @@ Qed.
 *)
 
 Lemma nat_of_P_lt_Lt_compare_morphism :
- forall p q:positive, (p ?= q)%positive Eq = Lt -> nat_of_P p < nat_of_P q.
+ forall p q:positive, (p ?= q) Eq = Lt -> nat_of_P p < nat_of_P q.
 Proof.
 intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ];
  intro H2;
@@ -178,7 +183,7 @@ intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ];
     apply ZL7; apply H; assumption
  | simpl in |- *; discriminate H2
  | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6;
-    elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; 
+    elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *;
     apply lt_O_Sn
  | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q);
     intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
@@ -193,29 +198,35 @@ Qed.
 *)
 
 Lemma nat_of_P_gt_Gt_compare_morphism :
- forall p q:positive, (p ?= q)%positive Eq = Gt -> nat_of_P p > nat_of_P q.
+ forall p q:positive, (p ?= q) Eq = Gt -> nat_of_P p > nat_of_P q.
 Proof.
-unfold gt in |- *; intro x; induction x as [p H| p H| ]; intro y;
- destruct y as [q| q| ]; intro H2;
- [ simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
-    apply lt_n_S; apply ZL7; apply H; assumption
- | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
-    elim (Pcompare_Gt_Gt p q H2);
-    [ intros H3; apply lt_S; apply ZL7; apply H; assumption
-    | intros E; rewrite E; apply lt_n_Sn ]
- | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p);
-    intros h H3; rewrite H3; simpl in |- *; apply lt_n_S; 
-    apply lt_O_Sn
- | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
-    apply ZL8; apply H; apply Pcompare_Lt_Gt; assumption
- | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
-    apply ZL7; apply H; assumption
- | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p);
-    intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
-    apply lt_n_S; apply lt_O_Sn
- | simpl in |- *; discriminate H2
- | simpl in |- *; discriminate H2
- | simpl in |- *; discriminate H2 ].
+intros p q GT. unfold gt.
+apply nat_of_P_lt_Lt_compare_morphism.
+change ((q ?= p) (CompOpp Eq) = CompOpp Gt).
+rewrite <- Pcompare_antisym, GT; auto.
+Qed.
+
+(** [nat_of_P] is a morphism for [Pcompare] and [nat_compare] *)
+
+Lemma nat_of_P_compare_morphism : forall p q,
+ (p ?= q) Eq = nat_compare (nat_of_P p) (nat_of_P q).
+Proof.
+ intros p q; symmetry.
+ destruct ((p ?= q) Eq) as [ | | ]_eqn.
+ rewrite (Pcompare_Eq_eq p q); auto.
+ apply <- nat_compare_eq_iff; auto.
+ apply -> nat_compare_lt. apply nat_of_P_lt_Lt_compare_morphism; auto.
+ apply -> nat_compare_gt. apply nat_of_P_gt_Gt_compare_morphism; auto.
+Qed.
+
+(** [nat_of_P] is hence injective. *)
+
+Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q.
+Proof.
+intros.
+apply Pcompare_Eq_eq.
+rewrite nat_of_P_compare_morphism.
+apply <- nat_compare_eq_iff; auto.
 Qed.
 
 (** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
@@ -225,17 +236,10 @@ Qed.
 *)
 
 Lemma nat_of_P_lt_Lt_compare_complement_morphism :
- forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q)%positive Eq = Lt.
+ forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q) Eq = Lt.
 Proof.
-intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq));
- [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H;
-    absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ]
- | intros H; elim H;
-    [ auto
-    | intros H1 H2; absurd (nat_of_P x < nat_of_P y);
-       [ apply lt_asym; change (nat_of_P x > nat_of_P y) in |- *;
-          apply nat_of_P_gt_Gt_compare_morphism; assumption
-       | assumption ] ] ].
+ intros. rewrite nat_of_P_compare_morphism.
+ apply -> nat_compare_lt; auto.
 Qed.
 
 (** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
@@ -245,18 +249,13 @@ Qed.
 *)
 
 Lemma nat_of_P_gt_Gt_compare_complement_morphism :
- forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q)%positive Eq = Gt.
+ forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q) Eq = Gt.
 Proof.
-intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq));
- [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H;
-    absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ]
- | intros H; elim H;
-    [ intros H1 H2; absurd (nat_of_P y < nat_of_P x);
-       [ apply lt_asym; apply nat_of_P_lt_Lt_compare_morphism; assumption
-       | assumption ]
-    | auto ] ].
+ intros. rewrite nat_of_P_compare_morphism.
+ apply -> nat_compare_gt; auto.
 Qed.
 
+
 (** [nat_of_P] is strictly positive *)
 
 Lemma le_Pmult_nat : forall (p:positive) (n:nat), n <= Pmult_nat p n.
@@ -301,25 +300,22 @@ Qed.
 
 Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p.
 Proof.
-  simple induction p. unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute.
-  rewrite Pmult_nat_4_mult_2_permute. rewrite H. simpl in |- *. rewrite <- plus_Snm_nSm. reflexivity.
-  unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute.
-  rewrite H. reflexivity.
-  reflexivity.
+  intros.
+  change 2 with (nat_of_P 2).
+  rewrite <- nat_of_P_mult_morphism.
+  f_equal.
 Qed.
 
 Lemma nat_of_P_xI : forall p:positive, nat_of_P (xI p) = S (2 * nat_of_P p).
 Proof.
-  simple induction p. unfold nat_of_P in |- *. simpl in |- *. intro p0. intro. rewrite Pmult_nat_2_mult_2_permute.
-  rewrite Pmult_nat_4_mult_2_permute; injection H; intro H1; rewrite H1;
-   rewrite <- plus_Snm_nSm; reflexivity.
-  unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute.
-  injection H; intro H1; rewrite H1; reflexivity.
-  reflexivity.
+  intros.
+  change 2 with (nat_of_P 2).
+  rewrite <- nat_of_P_mult_morphism, <- nat_of_P_succ_morphism.
+  f_equal.
 Qed.
 
 (**********************************************************************)
-(** Properties of the shifted injection from Peano natural numbers to 
+(** Properties of the shifted injection from Peano natural numbers to
     binary positive numbers *)
 
 (** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *)
@@ -327,9 +323,9 @@ Qed.
 Theorem nat_of_P_o_P_of_succ_nat_eq_succ :
  forall n:nat, nat_of_P (P_of_succ_nat n) = S n.
 Proof.
-intro m; induction m as [| n H];
- [ reflexivity
- | simpl in |- *; rewrite nat_of_P_succ_morphism; rewrite H; auto ].
+induction n as [|n H].
+reflexivity.
+simpl; rewrite nat_of_P_succ_morphism, H; auto.
 Qed.
 
 (** Miscellaneous lemmas on [P_of_succ_nat] *)
@@ -337,17 +333,17 @@ Qed.
 Lemma ZL3 :
  forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n).
 Proof.
-intro x; induction x as [| n H];
- [ simpl in |- *; auto with arith
- | simpl in |- *; rewrite plus_comm; simpl in |- *; rewrite H;
+induction n as [| n H]; simpl;
+ [ auto with arith
+ | rewrite plus_comm; simpl; rewrite H;
     rewrite xO_succ_permute; auto with arith ].
 Qed.
 
 Lemma ZL5 : forall n:nat, P_of_succ_nat (S n + S n) = xI (P_of_succ_nat n).
 Proof.
-intro x; induction x as [| n H]; simpl in |- *;
+induction n as [| n H]; simpl;
  [ auto with arith
- | rewrite <- plus_n_Sm; simpl in |- *; simpl in H; rewrite H;
+ | rewrite <- plus_n_Sm; simpl; simpl in H; rewrite H;
     auto with arith ].
 Qed.
 
@@ -356,19 +352,9 @@ Qed.
 Theorem P_of_succ_nat_o_nat_of_P_eq_succ :
  forall p:positive, P_of_succ_nat (nat_of_P p) = Psucc p.
 Proof.
-intro x; induction x as [p H| p H| ];
- [ simpl in |- *; rewrite <- H; change 2 with (1 + 1) in |- *;
-    rewrite Pmult_nat_r_plus_morphism; elim (ZL4 p); 
-    unfold nat_of_P in |- *; intros n H1; rewrite H1; 
-    rewrite ZL3; auto with arith
- | unfold nat_of_P in |- *; simpl in |- *; change 2 with (1 + 1) in |- *;
-    rewrite Pmult_nat_r_plus_morphism;
-    rewrite <- (Ppred_succ (P_of_succ_nat (Pmult_nat p 1 + Pmult_nat p 1)));
-    rewrite <- (Ppred_succ (xI p)); simpl in |- *; 
-    rewrite <- H; elim (ZL4 p); unfold nat_of_P in |- *; 
-    intros n H1; rewrite H1; rewrite ZL5; simpl in |- *; 
-    trivial with arith
- | unfold nat_of_P in |- *; simpl in |- *; auto with arith ].
+intros.
+apply nat_of_P_inj.
+rewrite nat_of_P_o_P_of_succ_nat_eq_succ, nat_of_P_succ_morphism; auto.
 Qed.
 
 (** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity
@@ -377,45 +363,36 @@ Qed.
 Theorem pred_o_P_of_succ_nat_o_nat_of_P_eq_id :
  forall p:positive, Ppred (P_of_succ_nat (nat_of_P p)) = p.
 Proof.
-intros x; rewrite P_of_succ_nat_o_nat_of_P_eq_succ; rewrite Ppred_succ;
- trivial with arith.
+intros; rewrite P_of_succ_nat_o_nat_of_P_eq_succ, Ppred_succ; auto.
 Qed.
 
 (**********************************************************************)
-(** Extra properties of the injection from binary positive numbers to Peano 
+(** Extra properties of the injection from binary positive numbers to Peano
     natural numbers *)
 
 (** [nat_of_P] is a morphism for subtraction on positive numbers *)
 
 Theorem nat_of_P_minus_morphism :
  forall p q:positive,
-   (p ?= q)%positive Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q.
+   (p ?= q) Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q.
 Proof.
 intros x y H; apply plus_reg_l with (nat_of_P y); rewrite le_plus_minus_r;
  [ rewrite <- nat_of_P_plus_morphism; rewrite Pplus_minus; auto with arith
  | apply lt_le_weak; exact (nat_of_P_gt_Gt_compare_morphism x y H) ].
 Qed.
 
-(** [nat_of_P] is injective *)
-
-Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q.
-Proof.
-intros x y H; rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id x);
- rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id y); 
- rewrite H; trivial with arith.
-Qed.
 
 Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p.
 Proof.
 intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1;
- rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; 
+ rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S;
  apply le_minus.
 Qed.
 
 Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q).
 Proof.
 intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q);
- intros k H; rewrite H; rewrite plus_comm; simpl in |- *; 
+ intros k H; rewrite H; rewrite plus_comm; simpl in |- *;
  apply le_n_S; apply le_plus_r.
 Qed.
 
@@ -423,9 +400,9 @@ Qed.
 
 Lemma Pcompare_minus_r :
  forall p q r:positive,
-   (q ?= p)%positive Eq = Lt ->
-   (r ?= p)%positive Eq = Gt ->
-   (r ?= q)%positive Eq = Gt -> (r - p ?= r - q)%positive Eq = Lt.
+   (q ?= p) Eq = Lt ->
+   (r ?= p) Eq = Gt ->
+   (r ?= q) Eq = Gt -> (r - p ?= r - q) Eq = Lt.
 Proof.
 intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
  rewrite nat_of_P_minus_morphism;
@@ -434,7 +411,7 @@ intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
        [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
           rewrite plus_assoc; rewrite le_plus_minus_r;
           [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
-             apply nat_of_P_lt_Lt_compare_morphism; 
+             apply nat_of_P_lt_Lt_compare_morphism;
              assumption
           | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
              apply ZC1; assumption ]
@@ -446,9 +423,9 @@ Qed.
 
 Lemma Pcompare_minus_l :
  forall p q r:positive,
-   (q ?= p)%positive Eq = Lt ->
-   (p ?= r)%positive Eq = Gt ->
-   (q ?= r)%positive Eq = Gt -> (q - r ?= p - r)%positive Eq = Lt.
+   (q ?= p) Eq = Lt ->
+   (p ?= r) Eq = Gt ->
+   (q ?= r) Eq = Gt -> (q - r ?= p - r) Eq = Lt.
 Proof.
 intros p q z; intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
  rewrite nat_of_P_minus_morphism;
@@ -469,8 +446,8 @@ Qed.
 
 Theorem Pmult_minus_distr_l :
  forall p q r:positive,
-   (q ?= r)%positive Eq = Gt ->
-   (p * (q - r))%positive = (p * q - p * r)%positive.
+   (q ?= r) Eq = Gt ->
+   (p * (q - r) = p * q - p * r)%positive.
 Proof.
 intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism;
  rewrite nat_of_P_minus_morphism;
@@ -478,7 +455,7 @@ intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism;
     [ do 2 rewrite nat_of_P_mult_morphism;
        do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r
     | apply nat_of_P_gt_Gt_compare_complement_morphism;
-       do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; 
+       do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *;
        elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l;
        exact (nat_of_P_gt_Gt_compare_morphism y z H) ]
  | assumption ].
diff --git a/theories/NArith/vo.itarget b/theories/NArith/vo.itarget
new file mode 100644
index 00000000..32f94f01
--- /dev/null
+++ b/theories/NArith/vo.itarget
@@ -0,0 +1,12 @@
+BinNat.vo
+BinPos.vo
+NArith.vo
+Ndec.vo
+Ndigits.vo
+Ndist.vo
+Nnat.vo
+Pnat.vo
+POrderedType.vo
+Pminmax.vo
+NOrderedType.vo
+Nminmax.vo
diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v
index 83ecd10d..dd7d9046 100644
--- a/theories/Numbers/BigNumPrelude.v
+++ b/theories/Numbers/BigNumPrelude.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: BigNumPrelude.v 11207 2008-07-04 16:50:32Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** * BigNumPrelude *)
 
@@ -21,6 +21,8 @@ Require Export ZArith.
 Require Export Znumtheory.
 Require Export Zpow_facts.
 
+Declare ML Module "numbers_syntax_plugin".
+
 (* *** Nota Bene ***
    All results that were general enough has been moved in ZArith.
    Only remain here specialized lemmas and compatibility elements.
@@ -28,8 +30,8 @@ Require Export Zpow_facts.
 *)
 
 
-Open Local Scope Z_scope. 
- 
+Local Open Scope Z_scope.
+
 (* For compatibility of scripts, weaker version of some lemmas of Zdiv *)
 
 Lemma Zlt0_not_eq : forall n, 0<n -> n<>0.
@@ -43,14 +45,14 @@ Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H
 
 (* Automation *)
 
-Hint  Extern 2 (Zle _ _) => 
+Hint  Extern 2 (Zle _ _) =>
  (match goal with
    |- Zpos _ <= Zpos _ => exact (refl_equal _)
 |   H: _ <=  ?p |- _ <= ?p => apply Zle_trans with (2 := H)
 |   H: _ <  ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H)
   end).
 
-Hint  Extern 2 (Zlt _ _) => 
+Hint  Extern 2 (Zlt _ _) =>
  (match goal with
    |- Zpos _ < Zpos _ => exact (refl_equal _)
 |      H: _ <=  ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H)
@@ -60,13 +62,13 @@ Hint  Extern 2 (Zlt _ _) =>
 
 Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
 
-(************************************** 
+(**************************************
    Properties of order and product
  **************************************)
 
- Theorem beta_lex: forall a b c d beta, 
-       a * beta + b <= c * beta + d -> 
-       0 <= b < beta -> 0 <= d < beta -> 
+ Theorem beta_lex: forall a b c d beta,
+       a * beta + b <= c * beta + d ->
+       0 <= b < beta -> 0 <= d < beta ->
        a <= c.
  Proof.
   intros a b c d beta H1 (H3, H4) (H5, H6).
@@ -78,15 +80,15 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
 
  Theorem beta_lex_inv: forall a b c d beta,
       a < c -> 0 <= b < beta ->
-      0 <= d < beta -> 
-      a * beta + b < c * beta  + d. 
+      0 <= d < beta ->
+      a * beta + b < c * beta  + d.
  Proof.
   intros a b c d beta H1 (H3, H4) (H5, H6).
   case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith.
   intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto.
  Qed.
 
- Lemma beta_mult : forall h l beta, 
+ Lemma beta_mult : forall h l beta,
    0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2.
  Proof.
   intros h l beta H1 H2;split. auto with zarith.
@@ -94,7 +96,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
    apply beta_lex_inv;auto with zarith.
  Qed.
 
- Lemma Zmult_lt_b : 
+ Lemma Zmult_lt_b :
    forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1.
  Proof.
   intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith.
@@ -104,17 +106,17 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
  Qed.
 
  Lemma sum_mul_carry : forall xh xl yh yl wc cc beta,
-   1 < beta -> 
+   1 < beta ->
    0 <= wc < beta ->
    0 <= xh < beta ->
    0 <= xl < beta ->
    0 <= yh < beta ->
    0 <= yl < beta ->
    0 <= cc < beta^2 ->
-   wc*beta^2 + cc = xh*yl + xl*yh -> 
+   wc*beta^2 + cc = xh*yl + xl*yh ->
    0 <= wc <= 1.
  Proof.
-  intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. 
+  intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7.
   assert (H8 := Zmult_lt_b beta xh yl H2 H5).
   assert (H9 := Zmult_lt_b beta xl yh H3 H4).
   split;auto with zarith.
@@ -132,7 +134,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
   apply Zle_lt_trans with  ((beta-1)*(beta-1)+(beta-1)); auto with zarith.
   apply Zplus_le_compat; auto with zarith.
   apply Zmult_le_compat; auto with zarith.
-  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); 
+  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r);
   rewrite Zpower_2; auto with zarith.
  Qed.
 
@@ -147,7 +149,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
   apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith.
   apply Zplus_le_compat; auto with zarith.
   apply Zmult_le_compat; auto with zarith.
-  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); 
+  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r);
    rewrite Zpower_2; auto with zarith.
  Qed.
 
@@ -199,9 +201,9 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   apply Zplus_le_lt_compat; auto with zarith.
   replace b with ((b - a) + a); try ring.
   rewrite Zpower_exp; auto with zarith.
-  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); 
+  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a));
    try rewrite <- Zmult_minus_distr_r.
-  rewrite (Zmult_comm (2 ^(b - a))); rewrite  Zmult_mod_distr_l; 
+  rewrite (Zmult_comm (2 ^(b - a))); rewrite  Zmult_mod_distr_l;
    auto with zarith.
   rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith.
   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
@@ -222,22 +224,22 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   split; auto with zarith.
   assert (0 <= 2 ^a * r); auto with zarith.
   apply Zplus_le_0_compat; auto with zarith.
-  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; 
+  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
   pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring.
   apply Zplus_le_lt_compat; auto with zarith.
   replace b with ((b - a) + a); try ring.
   rewrite Zpower_exp; auto with zarith.
-  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); 
+  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a));
    try rewrite <- Zmult_minus_distr_r.
   repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l;
    auto with zarith.
   apply Zmult_le_compat_l; auto with zarith.
-  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; 
+  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
  Qed.
 
-  Theorem Zdiv_shift_r: 
+  Theorem Zdiv_shift_r:
     forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a ->
       (r * 2 ^a + t) /  (2 ^ b) = (r * 2 ^a) / (2 ^ b).
   Proof.
@@ -251,7 +253,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
    rewrite <- Zmod_shift_r; auto with zarith.
    rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith.
    rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith.
-   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; 
+   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
     auto with zarith.
   Qed.
 
@@ -262,8 +264,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
      a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n.
  Proof.
   intros n p a H1 H2.
-  pattern (a*2^p) at 1;replace (a*2^p) with 
-     (a*2^p/2^n * 2^n + a*2^p mod 2^n). 
+  pattern (a*2^p) at 1;replace (a*2^p) with
+     (a*2^p/2^n * 2^n + a*2^p mod 2^n).
   2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq.
   replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial.
   replace (2^n) with (2^(n-p)*2^p).
@@ -277,8 +279,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Qed.
 
 
- Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> 
-   ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = 
+ Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n ->
+   ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) =
    a mod 2 ^ p.
  Proof.
  intros.
@@ -310,16 +312,16 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p.
  Proof.
   intros p x Hle;destruct (Z_le_gt_dec 0 p).
-  apply  Zdiv_le_lower_bound;auto with zarith. 
+  apply  Zdiv_le_lower_bound;auto with zarith.
   replace (2^p) with 0.
   destruct x;compute;intro;discriminate.
   destruct p;trivial;discriminate z.
  Qed.
- 
+
  Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y.
  Proof.
   intros p x y H;destruct (Z_le_gt_dec 0 p).
-  apply Zdiv_lt_upper_bound;auto with zarith. 
+  apply Zdiv_lt_upper_bound;auto with zarith.
   apply Zlt_le_trans with y;auto with zarith.
   rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith.
   assert (0 < 2^p);auto with zarith.
@@ -331,7 +333,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Theorem Zgcd_div_pos a b:
    0 < b -> 0 < Zgcd a b -> 0 < b / Zgcd a b.
  Proof.
- intros a b Ha Hg.
+ intros Ha Hg.
  case (Zle_lt_or_eq 0 (b/Zgcd a b)); auto.
  apply Z_div_pos; auto with zarith.
  intros H; generalize Ha.
@@ -343,7 +345,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Theorem Zdiv_neg a b:
    a < 0 -> 0 < b -> a / b < 0.
  Proof.
- intros a b Ha Hb.
+ intros Ha Hb.
  assert (b > 0) by omega.
  generalize (Z_mult_div_ge a _ H); intros.
  assert (b * (a / b) < 0)%Z.
@@ -354,22 +356,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  compute in H1; discriminate.
  compute; auto.
  Qed.
- 
- Lemma Zgcd_Zabs : forall z z', Zgcd (Zabs z) z' = Zgcd z z'.
- Proof.
- destruct z; simpl; auto.
- Qed.
 
- Lemma Zgcd_sym : forall p q, Zgcd p q = Zgcd q p.
- Proof.
- intros.
- apply Zis_gcd_gcd.
- apply Zgcd_is_pos.
- apply Zis_gcd_sym.
- apply Zgcd_is_gcd.
- Qed.
-
- Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 -> 
+ Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 ->
   Zgcd a b = 0.
  Proof.
  intros.
@@ -381,13 +369,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  intros; subst k; simpl in *; subst b; elim H0; auto.
  Qed.
 
- Lemma Zgcd_1 : forall z, Zgcd z 1 = 1.
- Proof.
- intros; apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1.
- Qed.
- Hint Resolve Zgcd_1.
-
- Lemma Zgcd_mult_rel_prime : forall a b c, 
+ Lemma Zgcd_mult_rel_prime : forall a b c,
   Zgcd a c = 1 -> Zgcd b c = 1 -> Zgcd (a*b) c = 1.
  Proof.
  intros.
@@ -396,7 +378,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Qed.
 
  Lemma Zcompare_gt : forall (A:Type)(a a':A)(p q:Z),
-  match (p?=q)%Z with Gt => a | _ => a' end = 
+  match (p?=q)%Z with Gt => a | _ => a' end =
   if Z_le_gt_dec p q then a' else a.
  Proof.
  intros.
diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
index 528d78c3..51df2fa3 100644
--- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
+++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
@@ -8,12 +8,12 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(* $Id: CyclicAxioms.v 11012 2008-05-28 16:34:43Z letouzey $ *)
+(* $Id$ *)
 
 (** * Signature and specification of a bounded integer structure *)
 
-(** This file specifies how to represent [Z/nZ] when [n=2^d], 
-    [d] being the number of digits of these bounded integers. *) 
+(** This file specifies how to represent [Z/nZ] when [n=2^d],
+    [d] being the number of digits of these bounded integers. *)
 
 Set Implicit Arguments.
 
@@ -22,7 +22,7 @@ Require Import Znumtheory.
 Require Import BigNumPrelude.
 Require Import DoubleType.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (** First, a description via an operator record and a spec record. *)
 
@@ -33,7 +33,7 @@ Section Z_nZ_Op.
  Record znz_op := mk_znz_op {
 
     (* Conversion functions with Z *)
-    znz_digits : positive;  
+    znz_digits : positive;
     znz_zdigits: znz;
     znz_to_Z   : znz -> Z;
     znz_of_pos : positive -> N * znz; (* Euclidean division by [2^digits] *)
@@ -78,12 +78,12 @@ Section Z_nZ_Op.
     znz_div         : znz -> znz -> znz * znz;
 
     znz_mod_gt      : znz -> znz -> znz; (* specialized version of [znz_mod] *)
-    znz_mod         : znz -> znz -> znz; 
+    znz_mod         : znz -> znz -> znz;
 
     znz_gcd_gt      : znz -> znz -> znz; (* specialized version of [znz_gcd] *)
-    znz_gcd         : znz -> znz -> znz; 
+    znz_gcd         : znz -> znz -> znz;
     (* [znz_add_mul_div p i j] is a combination of the [(digits-p)]
-       low bits of [i] above the [p] high bits of [j]: 
+       low bits of [i] above the [p] high bits of [j]:
        [znz_add_mul_div p i j = i*2^p+j/2^(digits-p)] *)
     znz_add_mul_div : znz -> znz -> znz -> znz;
     (* [znz_pos_mod p i] is [i mod 2^p] *)
@@ -135,7 +135,7 @@ Section Z_nZ_Spec.
  Let w_mul_c       := w_op.(znz_mul_c).
  Let w_mul         := w_op.(znz_mul).
  Let w_square_c    := w_op.(znz_square_c).
- 
+
  Let w_div21       := w_op.(znz_div21).
  Let w_div_gt      := w_op.(znz_div_gt).
  Let w_div         := w_op.(znz_div).
@@ -229,25 +229,25 @@ Section Z_nZ_Spec.
     spec_div : forall a b, 0 < [|b|] ->
       let (q,r) := w_div a b in
       [|a|] = [|q|] * [|b|] + [|r|] /\
-      0 <= [|r|] < [|b|]; 
-   
+      0 <= [|r|] < [|b|];
+
     spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
       [|w_mod_gt a b|] = [|a|] mod [|b|];
     spec_mod :  forall a b, 0 < [|b|] ->
       [|w_mod a b|] = [|a|] mod [|b|];
-      
+
     spec_gcd_gt : forall a b, [|a|] > [|b|] ->
       Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|];
     spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|w_gcd a b|];
 
- 
+
     (* shift operations *)
     spec_head00:  forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits;
     spec_head0  : forall x,  0 < [|x|] ->
-	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB;  
+	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB;
     spec_tail00:  forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits;
-    spec_tail0  : forall x, 0 < [|x|] -> 
-         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ;  
+    spec_tail0  : forall x, 0 < [|x|] ->
+         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ;
     spec_add_mul_div : forall x y p,
        [|p|] <= Zpos w_digits ->
        [| w_add_mul_div p x y |] =
@@ -272,23 +272,23 @@ End Z_nZ_Spec.
 (** Generic construction of double words *)
 
 Section WW.
- 
+
  Variable w : Type.
  Variable w_op : znz_op w.
  Variable op_spec : znz_spec w_op.
- 
+
  Let wB := base w_op.(znz_digits).
  Let w_to_Z := w_op.(znz_to_Z).
  Let w_eq0 := w_op.(znz_eq0).
  Let w_0 := w_op.(znz_0).
 
- Definition znz_W0 h := 
+ Definition znz_W0 h :=
   if w_eq0 h then W0 else WW h w_0.
 
- Definition znz_0W l := 
+ Definition znz_0W l :=
   if w_eq0 l then W0 else WW w_0 l.
 
- Definition znz_WW h l := 
+ Definition znz_WW h l :=
   if w_eq0 h then znz_0W l else WW h l.
 
  Lemma spec_W0 : forall h,
@@ -300,7 +300,7 @@ Section WW.
  unfold w_0; rewrite op_spec.(spec_0); auto with zarith.
  Qed.
 
- Lemma spec_0W : forall l, 
+ Lemma spec_0W : forall l,
    zn2z_to_Z wB w_to_Z (znz_0W l) = w_to_Z l.
  Proof.
  unfold zn2z_to_Z, znz_0W, w_to_Z; simpl; intros.
@@ -309,7 +309,7 @@ Section WW.
  unfold w_0; rewrite op_spec.(spec_0); auto with zarith.
  Qed.
 
- Lemma spec_WW : forall h l, 
+ Lemma spec_WW : forall h l,
   zn2z_to_Z wB w_to_Z (znz_WW h l) = (w_to_Z h)*wB + w_to_Z l.
  Proof.
  unfold znz_WW, w_to_Z; simpl; intros.
@@ -324,7 +324,7 @@ End WW.
 (** Injecting [Z] numbers into a cyclic structure *)
 
 Section znz_of_pos.
- 
+
  Variable w : Type.
  Variable w_op : znz_op w.
  Variable op_spec : znz_spec w_op.
@@ -349,7 +349,7 @@ Section znz_of_pos.
   apply Zle_trans with X; auto with zarith
  end.
  match goal with |- ?X <= _ =>
-  pattern X at 1; rewrite <- (Zmult_1_l); 
+  pattern X at 1; rewrite <- (Zmult_1_l);
   apply Zmult_le_compat_r; auto with zarith
  end.
  case p1; simpl; intros; red; simpl; intros; discriminate.
@@ -373,3 +373,112 @@ Module Type CyclicType.
  Parameter w_op : znz_op w.
  Parameter w_spec : znz_spec w_op.
 End CyclicType.
+
+
+(** A Cyclic structure can be seen as a ring *)
+
+Module CyclicRing (Import Cyclic : CyclicType).
+
+Definition t := w.
+
+Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99).
+
+Definition eq (n m : t) := [| n |] = [| m |].
+Definition zero : t := w_op.(znz_0).
+Definition one := w_op.(znz_1).
+Definition add := w_op.(znz_add).
+Definition sub := w_op.(znz_sub).
+Definition mul := w_op.(znz_mul).
+Definition opp := w_op.(znz_opp).
+
+Local Infix "=="  := eq (at level 70).
+Local Notation "0" := zero.
+Local Notation "1" := one.
+Local Infix "+" := add.
+Local Infix "-" := sub.
+Local Infix "*" := mul.
+Local Notation "!!" := (base (znz_digits w_op)).
+
+Hint Rewrite
+ w_spec.(spec_0) w_spec.(spec_1)
+ w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_opp) w_spec.(spec_sub)
+ : cyclic.
+
+Ltac zify :=
+ unfold eq, zero, one, add, sub, mul, opp in *; autorewrite with cyclic.
+
+Lemma add_0_l : forall x, 0 + x == x.
+Proof.
+intros. zify. rewrite Zplus_0_l.
+apply Zmod_small. apply w_spec.(spec_to_Z).
+Qed.
+
+Lemma add_comm : forall x y, x + y == y + x.
+Proof.
+intros. zify. now rewrite Zplus_comm.
+Qed.
+
+Lemma add_assoc : forall x y z, x + (y + z) == x + y + z.
+Proof.
+intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Zplus_assoc.
+Qed.
+
+Lemma mul_1_l : forall x, 1 * x == x.
+Proof.
+intros. zify. rewrite Zmult_1_l.
+apply Zmod_small. apply w_spec.(spec_to_Z).
+Qed.
+
+Lemma mul_comm : forall x y, x * y == y * x.
+Proof.
+intros. zify. now rewrite Zmult_comm.
+Qed.
+
+Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z.
+Proof.
+intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Zmult_assoc.
+Qed.
+
+Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z.
+Proof.
+intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Zmult_plus_distr_l.
+Qed.
+
+Lemma add_opp_r : forall x y, x + opp y == x-y.
+Proof.
+intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Zminus.
+destruct (Z_eq_dec ([|y|] mod !!) 0) as [EQ|NEQ].
+rewrite Z_mod_zero_opp_full, EQ, 2 Zplus_0_r; auto.
+rewrite Z_mod_nz_opp_full by auto.
+rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l.
+rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r.
+Qed.
+
+Lemma add_opp_diag_r : forall x, x + opp x == 0.
+Proof.
+intros. red. rewrite add_opp_r. zify. now rewrite Zminus_diag, Zmod_0_l.
+Qed.
+
+Lemma CyclicRing : ring_theory 0 1 add mul sub opp eq.
+Proof.
+constructor.
+exact add_0_l. exact add_comm. exact add_assoc.
+exact mul_1_l. exact mul_comm. exact mul_assoc.
+exact mul_add_distr_r.
+symmetry. apply add_opp_r.
+exact add_opp_diag_r.
+Qed.
+
+Definition eqb x y :=
+ match w_op.(znz_compare) x y with Eq => true | _ => false end.
+
+Lemma eqb_eq : forall x y, eqb x y = true <-> x == y.
+Proof.
+ intros. unfold eqb, eq. generalize (w_spec.(spec_compare) x y).
+ destruct (w_op.(znz_compare) x y); intuition; try discriminate.
+Qed.
+
+Lemma eqb_correct : forall x y, eqb x y = true -> x==y.
+Proof. now apply eqb_eq. Qed.
+
+End CyclicRing.
\ No newline at end of file
diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
index fb3f0cef..517e48ad 100644
--- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v
+++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
@@ -8,7 +8,7 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZCyclic.v 11238 2008-07-19 09:34:03Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export NZAxioms.
 Require Import BigNumPrelude.
@@ -17,89 +17,79 @@ Require Import CyclicAxioms.
 
 (** * From [CyclicType] to [NZAxiomsSig] *)
 
-(** A [Z/nZ] representation given by a module type [CyclicType] 
-    implements [NZAxiomsSig], e.g. the common properties between 
-    N and Z with no ordering. Notice that the [n] in [Z/nZ] is 
+(** A [Z/nZ] representation given by a module type [CyclicType]
+    implements [NZAxiomsSig], e.g. the common properties between
+    N and Z with no ordering. Notice that the [n] in [Z/nZ] is
     a power of 2.
 *)
 
 Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
-Definition NZ := w.
+Definition t := w.
 
-Definition NZ_to_Z : NZ -> Z := znz_to_Z w_op.
-Definition Z_to_NZ : Z -> NZ := znz_of_Z w_op.
-Notation Local wB := (base w_op.(znz_digits)).
+Definition NZ_to_Z : t -> Z := znz_to_Z w_op.
+Definition Z_to_NZ : Z -> t := znz_of_Z w_op.
+Local Notation wB := (base w_op.(znz_digits)).
 
-Notation Local "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99).
+Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99).
 
-Definition NZeq (n m : NZ) := [| n |] = [| m |].
-Definition NZ0 := w_op.(znz_0).
-Definition NZsucc := w_op.(znz_succ).
-Definition NZpred := w_op.(znz_pred).
-Definition NZadd := w_op.(znz_add).
-Definition NZsub := w_op.(znz_sub).
-Definition NZmul := w_op.(znz_mul).
+Definition eq (n m : t) := [| n |] = [| m |].
+Definition zero := w_op.(znz_0).
+Definition succ := w_op.(znz_succ).
+Definition pred := w_op.(znz_pred).
+Definition add := w_op.(znz_add).
+Definition sub := w_op.(znz_sub).
+Definition mul := w_op.(znz_mul).
 
-Theorem NZeq_equiv : equiv NZ NZeq.
-Proof.
-unfold equiv, reflexive, symmetric, transitive, NZeq; repeat split; intros; auto.
-now transitivity [| y |].
-Qed.
+Local Infix "=="  := eq (at level 70).
+Local Notation "0" := zero.
+Local Notation S := succ.
+Local Notation P := pred.
+Local Infix "+" := add.
+Local Infix "-" := sub.
+Local Infix "*" := mul.
 
-Add Relation NZ NZeq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
-as NZeq_rel.
+Hint Rewrite w_spec.(spec_0) w_spec.(spec_succ) w_spec.(spec_pred)
+ w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_sub) : w.
+Ltac wsimpl :=
+ unfold eq, zero, succ, pred, add, sub, mul; autorewrite with w.
+Ltac wcongruence := repeat red; intros; wsimpl; congruence.
 
-Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd.
+Instance eq_equiv : Equivalence eq.
 Proof.
-unfold NZeq; intros n m H. do 2 rewrite w_spec.(spec_succ). now rewrite H.
+unfold eq. firstorder.
 Qed.
 
-Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd.
+Instance succ_wd : Proper (eq ==> eq) succ.
 Proof.
-unfold NZeq; intros n m H. do 2 rewrite w_spec.(spec_pred). now rewrite H.
+wcongruence.
 Qed.
 
-Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd.
+Instance pred_wd : Proper (eq ==> eq) pred.
 Proof.
-unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_add).
-now rewrite H1, H2.
+wcongruence.
 Qed.
 
-Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd.
+Instance add_wd : Proper (eq ==> eq ==> eq) add.
 Proof.
-unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_sub).
-now rewrite H1, H2.
+wcongruence.
 Qed.
 
-Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd.
+Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
 Proof.
-unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_mul).
-now rewrite H1, H2.
+wcongruence.
 Qed.
 
-Delimit Scope IntScope with Int.
-Bind Scope IntScope with NZ.
-Open Local Scope IntScope.
-Notation "x == y"  := (NZeq x y) (at level 70) : IntScope.
-Notation "x ~= y" := (~ NZeq x y) (at level 70) : IntScope.
-Notation "0" := NZ0 : IntScope.
-Notation S x := (NZsucc x).
-Notation P x := (NZpred x).
-(*Notation "1" := (S 0) : IntScope.*)
-Notation "x + y" := (NZadd x y) : IntScope.
-Notation "x - y" := (NZsub x y) : IntScope.
-Notation "x * y" := (NZmul x y) : IntScope.
+Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
+Proof.
+wcongruence.
+Qed.
 
 Theorem gt_wB_1 : 1 < wB.
 Proof.
-unfold base. 
-apply Zpower_gt_1; unfold Zlt; auto with zarith.
+unfold base. apply Zpower_gt_1; unfold Zlt; auto with zarith.
 Qed.
 
 Theorem gt_wB_0 : 0 < wB.
@@ -107,7 +97,7 @@ Proof.
 pose proof gt_wB_1; auto with zarith.
 Qed.
 
-Lemma NZsucc_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB.
+Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB.
 Proof.
 intro n.
 pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zplus_mod.
@@ -115,7 +105,7 @@ reflexivity.
 now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]].
 Qed.
 
-Lemma NZpred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB.
+Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB.
 Proof.
 intro n.
 pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zminus_mod.
@@ -123,34 +113,32 @@ reflexivity.
 now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]].
 Qed.
 
-Lemma NZ_to_Z_mod : forall n : NZ, [| n |] mod wB = [| n |].
+Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |].
 Proof.
 intro n; rewrite Zmod_small. reflexivity. apply w_spec.(spec_to_Z).
 Qed.
 
-Theorem NZpred_succ : forall n : NZ, P (S n) == n.
+Theorem pred_succ : forall n, P (S n) == n.
 Proof.
-intro n; unfold NZsucc, NZpred, NZeq. rewrite w_spec.(spec_pred), w_spec.(spec_succ).
-rewrite <- NZpred_mod_wB.
+intro n. wsimpl.
+rewrite <- pred_mod_wB.
 replace ([| n |] + 1 - 1)%Z with [| n |] by auto with zarith. apply NZ_to_Z_mod.
 Qed.
 
-Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0%Int.
+Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0.
 Proof.
-unfold NZeq, NZ_to_Z, Z_to_NZ. rewrite znz_of_Z_correct.
-symmetry; apply w_spec.(spec_0).
+unfold NZ_to_Z, Z_to_NZ. wsimpl.
+rewrite znz_of_Z_correct; auto.
 exact w_spec. split; [auto with zarith |apply gt_wB_0].
 Qed.
 
 Section Induction.
 
-Variable A : NZ -> Prop.
-Hypothesis A_wd : predicate_wd NZeq A.
+Variable A : t -> Prop.
+Hypothesis A_wd : Proper (eq ==> iff) A.
 Hypothesis A0 : A 0.
-Hypothesis AS : forall n : NZ, A n <-> A (S n). (* Below, we use only -> direction *)
-
-Add Morphism A with signature NZeq ==> iff as A_morph.
-Proof. apply A_wd. Qed.
+Hypothesis AS : forall n, A n <-> A (S n).
+ (* Below, we use only -> direction *)
 
 Let B (n : Z) := A (Z_to_NZ n).
 
@@ -163,8 +151,8 @@ Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1).
 Proof.
 intros n H1 H2 H3.
 unfold B in *. apply -> AS in H3.
-setoid_replace (Z_to_NZ (n + 1)) with (S (Z_to_NZ n)) using relation NZeq. assumption.
-unfold NZeq. rewrite w_spec.(spec_succ).
+setoid_replace (Z_to_NZ (n + 1)) with (S (Z_to_NZ n)). assumption.
+wsimpl.
 unfold NZ_to_Z, Z_to_NZ.
 do 2 (rewrite znz_of_Z_correct; [ | exact w_spec | auto with zarith]).
 symmetry; apply Zmod_small; auto with zarith.
@@ -177,11 +165,11 @@ apply Zbounded_induction with wB.
 apply B0. apply BS. assumption. assumption.
 Qed.
 
-Theorem NZinduction : forall n : NZ, A n.
+Theorem bi_induction : forall n, A n.
 Proof.
-intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)) using relation NZeq.
+intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)).
 apply B_holds. apply w_spec.(spec_to_Z).
-unfold NZeq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct.
+unfold eq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct.
 reflexivity.
 exact w_spec.
 apply w_spec.(spec_to_Z).
@@ -189,47 +177,40 @@ Qed.
 
 End Induction.
 
-Theorem NZadd_0_l : forall n : NZ, 0 + n == n.
+Theorem add_0_l : forall n, 0 + n == n.
 Proof.
-intro n; unfold NZadd, NZ0, NZeq. rewrite w_spec.(spec_add). rewrite w_spec.(spec_0).
+intro n. wsimpl.
 rewrite Zplus_0_l. rewrite Zmod_small; [reflexivity | apply w_spec.(spec_to_Z)].
 Qed.
 
-Theorem NZadd_succ_l : forall n m : NZ, (S n) + m == S (n + m).
+Theorem add_succ_l : forall n m, (S n) + m == S (n + m).
 Proof.
-intros n m; unfold NZadd, NZsucc, NZeq. rewrite w_spec.(spec_add).
-do 2 rewrite w_spec.(spec_succ). rewrite w_spec.(spec_add).
-rewrite NZsucc_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0.
+intros n m. wsimpl.
+rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0.
 rewrite <- (Zplus_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l.
 rewrite (Zplus_comm 1 [| m |]); now rewrite Zplus_assoc.
 Qed.
 
-Theorem NZsub_0_r : forall n : NZ, n - 0 == n.
+Theorem sub_0_r : forall n, n - 0 == n.
 Proof.
-intro n; unfold NZsub, NZ0, NZeq. rewrite w_spec.(spec_sub).
-rewrite w_spec.(spec_0). rewrite Zminus_0_r. apply NZ_to_Z_mod.
+intro n. wsimpl. rewrite Zminus_0_r. apply NZ_to_Z_mod.
 Qed.
 
-Theorem NZsub_succ_r : forall n m : NZ, n - (S m) == P (n - m).
+Theorem sub_succ_r : forall n m, n - (S m) == P (n - m).
 Proof.
-intros n m; unfold NZsub, NZsucc, NZpred, NZeq.
-rewrite w_spec.(spec_pred). do 2 rewrite w_spec.(spec_sub).
-rewrite w_spec.(spec_succ). rewrite Zminus_mod_idemp_r.
-rewrite Zminus_mod_idemp_l.
-now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z by auto with zarith.
+intros n m. wsimpl. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l.
+now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z
+     by auto with zarith.
 Qed.
 
-Theorem NZmul_0_l : forall n : NZ, 0 * n == 0.
+Theorem mul_0_l : forall n, 0 * n == 0.
 Proof.
-intro n; unfold NZmul, NZ0, NZ, NZeq. rewrite w_spec.(spec_mul).
-rewrite w_spec.(spec_0). now rewrite Zmult_0_l.
+intro n. wsimpl. now rewrite Zmult_0_l.
 Qed.
 
-Theorem NZmul_succ_l : forall n m : NZ, (S n) * m == n * m + m.
+Theorem mul_succ_l : forall n m, (S n) * m == n * m + m.
 Proof.
-intros n m; unfold NZmul, NZsucc, NZadd, NZeq. rewrite w_spec.(spec_mul).
-rewrite w_spec.(spec_add), w_spec.(spec_mul), w_spec.(spec_succ).
-rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
+intros n m. wsimpl. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
 now rewrite Zmult_plus_distr_l, Zmult_1_l.
 Qed.
 
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
index 61d8d0fb..aa798e1c 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleAdd.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -17,7 +17,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section DoubleAdd.
  Variable w : Type.
@@ -36,10 +36,10 @@ Section DoubleAdd.
  Definition ww_succ_c x :=
   match x with
   | W0 => C0 ww_1
-  | WW xh xl => 
+  | WW xh xl =>
     match w_succ_c xl with
     | C0 l => C0 (WW xh l)
-    | C1 l => 
+    | C1 l =>
       match w_succ_c xh with
       | C0 h => C0 (WW h w_0)
       | C1 h => C1 W0
@@ -47,13 +47,13 @@ Section DoubleAdd.
     end
   end.
 
- Definition ww_succ x := 
+ Definition ww_succ x :=
   match x with
   | W0 => ww_1
   | WW xh xl =>
     match w_succ_c xl with
     | C0 l => WW xh l
-    | C1 l => w_W0 (w_succ xh) 
+    | C1 l => w_W0 (w_succ xh)
     end
   end.
 
@@ -63,12 +63,12 @@ Section DoubleAdd.
   | _, W0 => C0 x
   | WW xh xl, WW yh yl =>
     match w_add_c xl yl with
-    | C0 l => 
+    | C0 l =>
       match w_add_c xh yh with
       | C0 h => C0 (WW h l)
       | C1 h => C1 (w_WW h l)
-      end 
-    | C1 l => 
+      end
+    | C1 l =>
       match w_add_carry_c xh yh with
       | C0 h => C0 (WW h l)
       | C1 h => C1 (w_WW h l)
@@ -85,12 +85,12 @@ Section DoubleAdd.
   | _, W0 => f0 x
   | WW xh xl, WW yh yl =>
     match w_add_c xl yl with
-    | C0 l => 
+    | C0 l =>
       match w_add_c xh yh with
       | C0 h => f0 (WW h l)
       | C1 h => f1 (w_WW h l)
-      end 
-    | C1 l => 
+      end
+    | C1 l =>
       match w_add_carry_c xh yh with
       | C0 h => f0 (WW h l)
       | C1 h => f1 (w_WW h l)
@@ -118,12 +118,12 @@ Section DoubleAdd.
   | WW xh xl, W0 => ww_succ_c (WW xh xl)
   | WW xh xl, WW yh yl =>
     match w_add_carry_c xl yl with
-    | C0 l => 
+    | C0 l =>
       match w_add_c xh yh with
       | C0 h => C0 (WW h l)
       | C1 h => C1 (WW h l)
       end
-    | C1 l => 
+    | C1 l =>
       match w_add_carry_c xh yh with
       | C0 h => C0 (WW h l)
       | C1 h => C1 (w_WW h l)
@@ -131,7 +131,7 @@ Section DoubleAdd.
     end
   end.
 
- Definition ww_add_carry x y := 
+ Definition ww_add_carry x y :=
   match x, y with
   | W0, W0 => ww_1
   | W0, WW yh yl => ww_succ (WW yh yl)
@@ -146,7 +146,7 @@ Section DoubleAdd.
  (*Section DoubleProof.*)
   Variable w_digits : positive.
   Variable w_to_Z : w -> Z.
- 
+
 
   Notation wB  := (base w_digits).
   Notation wwB := (base (ww_digits w_digits)).
@@ -157,11 +157,11 @@ Section DoubleAdd.
    (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
-  Notation "[+[ c ]]" := 
-   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[+[ c ]]" :=
+   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
-   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[-[ c ]]" :=
+   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
 
   Variable spec_w_0   : [|w_0|] = 0.
@@ -172,7 +172,7 @@ Section DoubleAdd.
   Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
   Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1.
   Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
-  Variable spec_w_add_carry_c : 
+  Variable spec_w_add_carry_c :
          forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1.
   Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB.
   Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
@@ -187,11 +187,11 @@ Section DoubleAdd.
    rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l.
    assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega.
    rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h];
-    intro H1;unfold interp_carry in H1. 
+    intro H1;unfold interp_carry in H1.
    simpl;rewrite H1;rewrite spec_w_0;ring.
    unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB.
    assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega.
-   rewrite H2;ring. 
+   rewrite H2;ring.
   Qed.
 
   Lemma spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
@@ -222,12 +222,12 @@ Section DoubleAdd.
    Proof.
     destruct x as [ |xh xl];simpl;trivial.
     apply spec_f0;trivial.
-    destruct y as [ |yh yl];simpl. 
+    destruct y as [ |yh yl];simpl.
     apply spec_f0;simpl;rewrite Zplus_0_r;trivial.
     generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
      intros H;unfold interp_carry in H.
     generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
-     intros H1;unfold interp_carry in *. 
+     intros H1;unfold interp_carry in *.
     apply spec_f0. simpl;rewrite H;rewrite H1;ring.
     apply spec_f1. simpl;rewrite spec_w_WW;rewrite H.
     rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l.
@@ -236,12 +236,12 @@ Section DoubleAdd.
      as [h|h]; intros H1;unfold interp_carry in *.
     apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l.
     rewrite <- Zplus_assoc;rewrite H;ring.
-    apply spec_f1.  simpl;rewrite spec_w_WW;rewrite wwB_wBwB. 
-    rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. 
+    apply spec_f1.  simpl;rewrite spec_w_WW;rewrite wwB_wBwB.
+    rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l.
     rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l.
     rewrite <- Zplus_assoc;rewrite H;ring.
    Qed.
-  
+
   End Cont.
 
   Lemma spec_ww_add_carry_c :
@@ -251,16 +251,16 @@ Section DoubleAdd.
    exact (spec_ww_succ_c y).
    destruct y as [ |yh yl];simpl.
    rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)).
-   replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) 
+   replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
-   generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) 
+   generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
     as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
    generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
     intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.
    unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring.
    rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
-   generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) 
-    as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.  
+   generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
+    as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.
    unfold interp_carry;rewrite spec_w_WW;
    repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring.
   Qed.
@@ -287,9 +287,9 @@ Section DoubleAdd.
    rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
    destruct y as [ |yh yl].
    change [[W0]] with 0;rewrite Zplus_0_r.
-   rewrite Zmod_small;trivial. 
+   rewrite Zmod_small;trivial.
     exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)).
-   simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) 
+   simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring.
    generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
    unfold interp_carry;intros H;simpl;rewrite <- H.
@@ -305,14 +305,14 @@ Section DoubleAdd.
    exact (spec_ww_succ y).
    destruct y as [ |yh yl].
    change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)).
-   simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) 
+   simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
-   generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) 
+   generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
    as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z.
    rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial.
    rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
    rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial.
-  Qed. 
+  Qed.
 
 (* End DoubleProof. *)
 End DoubleAdd.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
index 952516ac..88c34915 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleBase.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -16,7 +16,7 @@ Require Import ZArith.
 Require Import BigNumPrelude.
 Require Import DoubleType.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section DoubleBase.
  Variable w : Type.
@@ -29,8 +29,8 @@ Section DoubleBase.
  Variable w_zdigits: w.
  Variable w_add: w -> w -> zn2z w.
  Variable w_to_Z   : w -> Z.
- Variable w_compare : w -> w -> comparison. 
- 
+ Variable w_compare : w -> w -> comparison.
+
  Definition ww_digits := xO w_digits.
 
  Definition ww_zdigits := w_add w_zdigits w_zdigits.
@@ -46,7 +46,7 @@ Section DoubleBase.
   | W0, W0 => W0
   | _, _ => WW xh xl
   end.
- 
+
  Definition ww_W0 h : zn2z (zn2z w) :=
   match h with
   | W0 => W0
@@ -58,10 +58,10 @@ Section DoubleBase.
   | W0 => W0
   | _ => WW W0 l
   end.
- 
- Definition double_WW (n:nat) := 
-  match n return word w n -> word w n -> word w (S n) with 
-  | O => w_WW 
+
+ Definition double_WW (n:nat) :=
+  match n return word w n -> word w n -> word w (S n) with
+  | O => w_WW
   | S n =>
     fun (h l : zn2z (word w n)) =>
      match h, l with
@@ -70,8 +70,8 @@ Section DoubleBase.
      end
   end.
 
- Fixpoint double_digits (n:nat) : positive := 
-  match n with 
+ Fixpoint double_digits (n:nat) : positive :=
+  match n with
   | O => w_digits
   | S n => xO (double_digits n)
   end.
@@ -80,7 +80,7 @@ Section DoubleBase.
 
  Fixpoint double_to_Z (n:nat) : word w n -> Z :=
   match n return word w n -> Z with
-  | O => w_to_Z 
+  | O => w_to_Z
   | S n => zn2z_to_Z (double_wB n) (double_to_Z n)
   end.
 
@@ -98,21 +98,21 @@ Section DoubleBase.
   end.
 
  Definition double_0 n : word w n :=
-   match n return word w n with 
+   match n return word w n with
    | O => w_0
    | S _ => W0
    end.
- 
+
  Definition double_split (n:nat) (x:zn2z (word w n)) :=
-  match x with 
-  | W0 => 
-    match n return word w n * word w n with 
+  match x with
+  | W0 =>
+    match n return word w n * word w n with
     | O => (w_0,w_0)
     | S _ => (W0, W0)
     end
   | WW h l => (h,l)
   end.
- 
+
  Definition ww_compare x y :=
   match x, y with
   | W0, W0 => Eq
@@ -148,15 +148,15 @@ Section DoubleBase.
       end
   end.
 
-  
+
  Section DoubleProof.
   Notation wB  := (base w_digits).
   Notation wwB := (base ww_digits).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[[ x ]]" := (ww_to_Z x)  (at level 0, x at level 99).
-  Notation "[+[ c ]]" := 
+  Notation "[+[ c ]]" :=
    (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
+  Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99).
   Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99).
 
@@ -188,7 +188,7 @@ Section DoubleBase.
   Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed.
 
   Lemma lt_0_wB : 0 < wB.
-  Proof. 
+  Proof.
    unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity.
    unfold Zle;intros H;discriminate H.
   Qed.
@@ -197,25 +197,25 @@ Section DoubleBase.
   Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed.
 
   Lemma wB_pos: 1 < wB.
-  Proof. 
+  Proof.
    unfold base;apply Zlt_le_trans with (2^1).  unfold Zlt;reflexivity.
    apply Zpower_le_monotone.  unfold Zlt;reflexivity.
    split;unfold Zle;intros H. discriminate H.
    clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW.
    destruct w_digits; discriminate H.
   Qed.
- 
-  Lemma wwB_pos: 1 < wwB. 
+
+  Lemma wwB_pos: 1 < wwB.
   Proof.
    assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1).
    rewrite Zpower_2.
    apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]).
-   apply Zlt_le_weak;trivial. 
+   apply Zlt_le_weak;trivial.
   Qed.
 
   Theorem wB_div_2:  2 * (wB / 2) = wB.
   Proof.
-   clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W 
+   clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W
     spec_to_Z;unfold base.
    assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))).
    pattern 2 at 2; rewrite <- Zpower_1_r.
@@ -228,7 +228,7 @@ Section DoubleBase.
 
   Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB.
   Proof.
-   clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W 
+   clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W
     spec_to_Z.
    rewrite wwB_wBwB; rewrite Zpower_2.
    pattern wB at 1; rewrite <- wB_div_2; auto.
@@ -236,11 +236,11 @@ Section DoubleBase.
    repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith.
   Qed.
 
-  Lemma mod_wwB : forall z x, 
+  Lemma mod_wwB : forall z x,
    (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|].
   Proof.
    intros z x.
-   rewrite Zplus_mod. 
+   rewrite Zplus_mod.
    pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2.
    rewrite Zmult_mod_distr_r;try apply lt_0_wB.
    rewrite (Zmod_small [|x|]).
@@ -260,8 +260,8 @@ Section DoubleBase.
    destruct (spec_to_Z x);trivial.
   Qed.
 
-  Lemma wB_div_plus : forall x y p, 
-   0 <= p -> 
+  Lemma wB_div_plus : forall x y p,
+   0 <= p ->
    ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p.
   Proof.
    clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
@@ -277,7 +277,7 @@ Section DoubleBase.
    assert (0 < Zpos w_digits). compute;reflexivity.
    unfold ww_digits;rewrite Zpos_xO;auto with zarith.
   Qed.
- 
+
   Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB.
   Proof.
    intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB.
@@ -298,7 +298,7 @@ Section DoubleBase.
   Proof.
    intros n;unfold double_wB;simpl.
    unfold base;rewrite (Zpos_xO (double_digits n)).
-   replace  (2 * Zpos (double_digits n)) with 
+   replace  (2 * Zpos (double_digits n)) with
      (Zpos (double_digits n) + Zpos (double_digits n)).
    symmetry; apply Zpower_exp;intro;discriminate.
    ring.
@@ -327,7 +327,7 @@ Section DoubleBase.
   unfold base; auto with zarith.
   Qed.
 
-  Lemma spec_double_to_Z : 
+  Lemma spec_double_to_Z :
    forall n (x:word w n), 0 <= [!n | x!] < double_wB n.
   Proof.
   clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
@@ -347,7 +347,7 @@ Section DoubleBase.
   Qed.
 
   Lemma spec_get_low:
-  forall n x, 
+  forall n x,
      [!n | x!] < wB ->  [|get_low n x|] = [!n | x!].
   Proof.
   clear spec_w_1 spec_w_Bm1.
@@ -380,19 +380,19 @@ Section DoubleBase.
   Qed.
 
   Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]].
-  Proof. induction n;simpl;trivial. Qed. 
+  Proof. induction n;simpl;trivial. Qed.
 
   Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|].
-  Proof. 
+  Proof.
    intros n x;assert (H:= spec_w_0W x);unfold extend.
-   destruct (w_0W x);simpl;trivial. 
+   destruct (w_0W x);simpl;trivial.
    rewrite <- H;exact (spec_extend_aux n (WW w0 w1)).
   Qed.
 
   Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0.
   Proof. destruct n;trivial. Qed.
 
-  Lemma spec_double_split : forall n x, 
+  Lemma spec_double_split : forall n x,
    let (h,l) := double_split n x in
    [!S n|x!] = [!n|h!] * double_wB n + [!n|l!].
   Proof.
@@ -401,9 +401,9 @@ Section DoubleBase.
    rewrite spec_w_0;trivial.
   Qed.
 
-  Lemma wB_lex_inv: forall a b c d, 
-      a < c -> 
-      a * wB + [|b|] < c  * wB + [|d|]. 
+  Lemma wB_lex_inv: forall a b c d,
+      a < c ->
+      a * wB + [|b|] < c  * wB + [|d|].
   Proof.
    intros a b c d H1; apply beta_lex_inv with (1 := H1); auto.
   Qed.
@@ -420,7 +420,7 @@ Section DoubleBase.
     intros H;rewrite spec_w_0 in H.
    rewrite <- H;simpl;rewrite <- spec_w_0;apply spec_w_compare.
    change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0.
-   apply wB_lex_inv;trivial. 
+   apply wB_lex_inv;trivial.
    absurd (0 <= [|yh|]). apply Zgt_not_le;trivial.
    destruct (spec_to_Z yh);trivial.
    generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0);
@@ -429,8 +429,8 @@ Section DoubleBase.
    absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial.
    destruct (spec_to_Z xh);trivial.
    apply Zlt_gt;change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0.
-   apply wB_lex_inv;apply Zgt_lt;trivial. 
-  
+   apply wB_lex_inv;apply Zgt_lt;trivial.
+
    generalize (spec_w_compare xh yh);destruct (w_compare xh yh);intros H.
    rewrite H;generalize (spec_w_compare xl yl);destruct (w_compare xl yl);
    intros H1;[rewrite H1|apply Zplus_lt_compat_l|apply Zplus_gt_compat_l];
@@ -439,7 +439,7 @@ Section DoubleBase.
    apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial.
   Qed.
 
-   
+
  End DoubleProof.
 
 End DoubleBase.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
index cca32a59..eea29e7c 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleCyclic.v 11012 2008-05-28 16:34:43Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -22,10 +22,10 @@ Require Import DoubleMul.
 Require Import DoubleSqrt.
 Require Import DoubleLift.
 Require Import DoubleDivn1.
-Require Import DoubleDiv. 
+Require Import DoubleDiv.
 Require Import CyclicAxioms.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 
 Section Z_2nZ.
@@ -80,7 +80,7 @@ Section Z_2nZ.
  Let w_gcd_gt      := w_op.(znz_gcd_gt).
  Let w_gcd         := w_op.(znz_gcd).
 
- Let w_add_mul_div := w_op.(znz_add_mul_div). 
+ Let w_add_mul_div := w_op.(znz_add_mul_div).
 
  Let w_pos_mod := w_op.(znz_pos_mod).
 
@@ -93,7 +93,7 @@ Section Z_2nZ.
  Let wB := base w_digits.
 
  Let w_Bm2 := w_pred w_Bm1.
- 
+
  Let ww_1 := ww_1 w_0 w_1.
  Let ww_Bm1 := ww_Bm1 w_Bm1.
 
@@ -112,16 +112,16 @@ Section Z_2nZ.
  Let ww_of_pos p :=
   match w_of_pos p with
   | (N0, l) => (N0, WW w_0 l)
-  | (Npos ph,l) => 
+  | (Npos ph,l) =>
     let (n,h) := w_of_pos ph in (n, w_WW h l)
   end.
 
  Let head0 :=
-  Eval lazy beta delta [ww_head0] in 
+  Eval lazy beta delta [ww_head0] in
   ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits.
 
  Let tail0 :=
-  Eval lazy beta delta [ww_tail0] in 
+  Eval lazy beta delta [ww_tail0] in
   ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits.
 
  Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w).
@@ -132,7 +132,7 @@ Section Z_2nZ.
  Let compare :=
   Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare.
 
- Let eq0 (x:zn2z w) := 
+ Let eq0 (x:zn2z w) :=
   match x with
   | W0 => true
   | _ => false
@@ -147,7 +147,7 @@ Section Z_2nZ.
 
  Let opp_carry :=
   Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry.
-  
+
  (* ** Additions ** *)
 
  Let succ_c :=
@@ -157,16 +157,16 @@ Section Z_2nZ.
   Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c.
 
  Let add_carry_c :=
-  Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in 
+  Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in
   ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c.
 
- Let succ := 
+ Let succ :=
   Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ.
 
  Let add :=
   Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry.
 
- Let add_carry := 
+ Let add_carry :=
   Eval lazy beta iota delta [ww_add_carry ww_succ] in
   ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry.
 
@@ -174,9 +174,9 @@ Section Z_2nZ.
 
  Let pred_c :=
   Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c.
- 
+
  Let sub_c :=
-  Eval lazy beta iota delta [ww_sub_c ww_opp_c] in 
+  Eval lazy beta iota delta [ww_sub_c ww_opp_c] in
   ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c.
 
  Let sub_carry_c :=
@@ -186,8 +186,8 @@ Section Z_2nZ.
  Let pred :=
   Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred.
 
- Let sub := 
-  Eval lazy beta iota delta [ww_sub ww_opp] in 
+ Let sub :=
+  Eval lazy beta iota delta [ww_sub ww_opp] in
   ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry.
 
  Let sub_carry :=
@@ -204,7 +204,7 @@ Section Z_2nZ.
 
  Let karatsuba_c :=
   Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in
-  ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c 
+  ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c
     add_c add add_carry sub_c sub.
 
  Let mul :=
@@ -219,7 +219,7 @@ Section Z_2nZ.
 
  Let div32 :=
    Eval lazy beta iota delta [w_div32] in
-   w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c 
+   w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
    w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c.
 
  Let div21 :=
@@ -234,40 +234,40 @@ Section Z_2nZ.
 
  Let div_gt :=
   Eval lazy beta delta [ww_div_gt] in
-  ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp 
+  ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry
   w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits.
 
  Let div :=
   Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt.
-  
+
  Let mod_gt :=
   Eval lazy beta delta [ww_mod_gt] in
   ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry
   w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits.
 
- Let mod_ := 
+ Let mod_ :=
   Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt.
 
- Let pos_mod := 
-  Eval lazy beta delta [ww_pos_mod] in 
+ Let pos_mod :=
+  Eval lazy beta delta [ww_pos_mod] in
     ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits.
 
- Let is_even := 
+ Let is_even :=
   Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even.
 
- Let sqrt2 := 
+ Let sqrt2 :=
   Eval lazy beta delta [ww_sqrt2] in
     ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c
     w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c
     pred add_c add sub_c add_mul_div.
 
- Let sqrt := 
+ Let sqrt :=
   Eval lazy beta delta [ww_sqrt] in
     ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits
      _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low.
 
- Let gcd_gt_fix := 
+ Let gcd_gt_fix :=
   Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in
   ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry
       w_sub_c w_sub w_sub_carry w_gcd_gt
@@ -278,7 +278,7 @@ Section Z_2nZ.
   Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare.
 
  Let gcd_gt :=
-  Eval lazy beta delta [ww_gcd_gt] in 
+  Eval lazy beta delta [ww_gcd_gt] in
   ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.
 
  Let gcd :=
@@ -286,18 +286,18 @@ Section Z_2nZ.
   ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.
 
  (* ** Record of operators on 2 words *)
-   
- Definition mk_zn2z_op := 
+
+ Definition mk_zn2z_op :=
   mk_znz_op _ww_digits _ww_zdigits
     to_Z ww_of_pos head0 tail0
     W0 ww_1 ww_Bm1
     compare eq0
     opp_c opp opp_carry
-    succ_c add_c add_carry_c 
-    succ add add_carry 
-    pred_c sub_c sub_carry_c 
+    succ_c add_c add_carry_c
+    succ add add_carry
+    pred_c sub_c sub_carry_c
     pred sub sub_carry
-    mul_c mul square_c   
+    mul_c mul square_c
     div21 div_gt div
     mod_gt mod_
     gcd_gt gcd
@@ -307,17 +307,17 @@ Section Z_2nZ.
     sqrt2
     sqrt.
 
- Definition mk_zn2z_op_karatsuba := 
+ Definition mk_zn2z_op_karatsuba :=
    mk_znz_op _ww_digits _ww_zdigits
     to_Z ww_of_pos head0 tail0
     W0 ww_1 ww_Bm1
     compare eq0
     opp_c opp opp_carry
-    succ_c add_c add_carry_c 
-    succ add add_carry 
-    pred_c sub_c sub_carry_c 
+    succ_c add_c add_carry_c
+    succ add add_carry
+    pred_c sub_c sub_carry_c
     pred sub sub_carry
-    karatsuba_c mul square_c   
+    karatsuba_c mul square_c
     div21 div_gt div
     mod_gt mod_
     gcd_gt gcd
@@ -330,7 +330,7 @@ Section Z_2nZ.
  (* Proof *)
  Variable op_spec : znz_spec w_op.
 
- Hint Resolve 
+ Hint Resolve
     (spec_to_Z op_spec)
     (spec_of_pos op_spec)
     (spec_0 op_spec)
@@ -358,13 +358,13 @@ Section Z_2nZ.
     (spec_square_c op_spec)
     (spec_div21 op_spec)
     (spec_div_gt op_spec)
-    (spec_div op_spec)    
+    (spec_div op_spec)
     (spec_mod_gt op_spec)
-    (spec_mod op_spec)      
+    (spec_mod op_spec)
     (spec_gcd_gt op_spec)
-    (spec_gcd op_spec) 
-    (spec_head0 op_spec) 
-    (spec_tail0 op_spec) 
+    (spec_gcd op_spec)
+    (spec_head0 op_spec)
+    (spec_tail0 op_spec)
     (spec_add_mul_div op_spec)
     (spec_pos_mod)
     (spec_is_even)
@@ -417,20 +417,20 @@ Section Z_2nZ.
  Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1.
  Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed.
 
- Let spec_ww_compare : 
+ Let spec_ww_compare :
      forall x y,
        match compare x y with
        | Eq => [|x|] = [|y|]
        | Lt => [|x|] < [|y|]
        | Gt => [|x|] > [|y|]
        end.
- Proof. 
-  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. 
-  exact (spec_compare op_spec). 
+ Proof.
+  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto.
+  exact (spec_compare op_spec).
  Qed.
 
  Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0.
- Proof. destruct x;simpl;intros;trivial;discriminate. Qed. 
+ Proof. destruct x;simpl;intros;trivial;discriminate. Qed.
 
  Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|].
  Proof.
@@ -440,7 +440,7 @@ Section Z_2nZ.
 
  Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB.
  Proof.
-  refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp 
+  refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp
    w_digits w_to_Z _ _ _ _ _);
   auto.
  Qed.
@@ -480,25 +480,25 @@ Section Z_2nZ.
 
  Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB.
  Proof.
-  refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ 
+  refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ
   w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
  Qed.
 
  Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
  Proof.
-  refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z 
+  refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z
    _ _ _ _ _);wwauto.
  Qed.
 
  Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
  Proof.
-  refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c 
+  refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c
    w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
  Qed.
 
  Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1.
  Proof.
-  refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c 
+  refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
    w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
  Qed.
 
@@ -533,17 +533,17 @@ Section Z_2nZ.
           _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
   unfold w_digits; apply spec_more_than_1_digit; auto.
   exact (spec_compare op_spec).
- Qed. 
+ Qed.
 
  Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB.
  Proof.
   refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _);
-  wwauto. 
+  wwauto.
  Qed.
 
  Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|].
  Proof.
-  refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add 
+  refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add
    add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto.
  Qed.
 
@@ -574,7 +574,7 @@ Section Z_2nZ.
       0 <= [|r|] < [|b|].
  Proof.
   refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z
-   _ _ _ _ _ _ _);wwauto. 
+   _ _ _ _ _ _ _);wwauto.
  Qed.
 
  Let spec_add2: forall x y,
@@ -602,7 +602,7 @@ Section Z_2nZ.
   unfold wB, base; auto with zarith.
  Qed.
 
- Let spec_ww_digits: 
+ Let spec_ww_digits:
   [|_ww_zdigits|] = Zpos (xO w_digits).
  Proof.
  unfold w_to_Z, _ww_zdigits.
@@ -615,7 +615,7 @@ Section Z_2nZ.
 
  Let spec_ww_head00  : forall x,  [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits.
  Proof.
- refine (spec_ww_head00 w_0 w_0W 
+ refine (spec_ww_head00 w_0 w_0W
                 w_compare w_head0 w_add2 w_zdigits _ww_zdigits
                 w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto.
  exact (spec_compare op_spec).
@@ -626,8 +626,8 @@ Section Z_2nZ.
  Let spec_ww_head0  : forall x,  0 < [|x|] ->
 	 wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB.
  Proof.
-  refine (spec_ww_head0 w_0 w_0W w_compare w_head0 
-           w_add2 w_zdigits _ww_zdigits 
+  refine (spec_ww_head0 w_0 w_0W w_compare w_head0
+           w_add2 w_zdigits _ww_zdigits
    w_to_Z _ _ _ _ _ _ _);wwauto.
   exact (spec_compare op_spec).
   exact (spec_zdigits op_spec).
@@ -635,7 +635,7 @@ Section Z_2nZ.
 
  Let spec_ww_tail00  : forall x,  [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits.
  Proof.
- refine (spec_ww_tail00 w_0 w_0W 
+ refine (spec_ww_tail00 w_0 w_0W
                 w_compare w_tail0 w_add2 w_zdigits _ww_zdigits
                 w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); wwauto.
  exact (spec_compare op_spec).
@@ -647,7 +647,7 @@ Section Z_2nZ.
  Let spec_ww_tail0  : forall x,  0 < [|x|] ->
   exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|].
  Proof.
-  refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 
+  refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0
            w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto.
   exact (spec_compare op_spec).
   exact (spec_zdigits op_spec).
@@ -659,19 +659,19 @@ Section Z_2nZ.
          ([|x|] * (2 ^ [|p|]) +
           [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB.
  Proof.
- refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div 
+ refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div
               sub w_digits w_zdigits low w_to_Z
            _ _ _ _ _ _ _ _ _ _ _);wwauto.
   exact (spec_zdigits op_spec).
  Qed.
 
- Let spec_ww_div_gt : forall a b, 
+ Let spec_ww_div_gt : forall a b,
       [|a|] > [|b|] -> 0 < [|b|] ->
       let (q,r) := div_gt a b in
       [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|].
  Proof.
-refine 
-(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 
+refine
+(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0
    w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt
    w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
@@ -707,14 +707,14 @@ refine
   refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto.
  Qed.
 
- Let spec_ww_mod_gt : forall a b, 
+ Let spec_ww_mod_gt : forall a b,
       [|a|] > [|b|] -> 0 < [|b|] ->
       [|mod_gt a b|] = [|a|] mod [|b|].
  Proof.
-  refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 
+  refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0
    w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt
-   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div 
-   w_zdigits w_to_Z 
+   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div
+   w_zdigits w_to_Z
    _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _ _ _);wwauto.
   exact (spec_compare op_spec).
   exact (spec_div_gt op_spec).
@@ -731,12 +731,12 @@ refine
  Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] ->
       Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
  Proof.
-  refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ 
+  refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _
     w_0 w_0 w_eq0 w_gcd_gt _ww_digits
   _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
   refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
    w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
-   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z 
+   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
    _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
   exact (spec_compare op_spec).
   exact (spec_div21 op_spec).
@@ -753,7 +753,7 @@ refine
   _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
   refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
    w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
-   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z 
+   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
    _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
   exact (spec_compare op_spec).
   exact (spec_div21 op_spec).
@@ -798,7 +798,7 @@ refine
  Let spec_ww_sqrt : forall x,
        [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
  Proof.
- refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1 
+ refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1
            w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits
                w_sqrt2 pred add_mul_div head0 compare
             _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
@@ -814,7 +814,7 @@ refine
   apply mk_znz_spec;auto.
   exact spec_ww_add_mul_div.
 
-  refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW 
+  refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW
            w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
        _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
   exact (spec_pos_mod op_spec).
@@ -828,7 +828,7 @@ refine
  Proof.
   apply mk_znz_spec;auto.
   exact spec_ww_add_mul_div.
-  refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW 
+  refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW
            w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
        _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
   exact (spec_pos_mod op_spec).
@@ -838,10 +838,10 @@ refine
   rewrite <- Zpos_xO; exact spec_ww_digits.
  Qed.
 
-End Z_2nZ. 
- 
+End Z_2nZ.
+
 Section MulAdd.
- 
+
   Variable w: Type.
   Variable op: znz_op w.
   Variable sop: znz_spec op.
@@ -870,7 +870,7 @@ Section MulAdd.
 End MulAdd.
 
 
-(** Modular versions of DoubleCyclic *) 
+(** Modular versions of DoubleCyclic *)
 
 Module DoubleCyclic (C:CyclicType) <: CyclicType.
  Definition w := zn2z C.w.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
index 075aef59..9204b4e0 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
@@ -8,7 +8,7 @@
 (*         Benjamin Gregoire, Laurent Thery, INRIA, 2007                *)
 (************************************************************************)
 
-(*i $Id: DoubleDiv.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -20,7 +20,7 @@ Require Import DoubleDivn1.
 Require Import DoubleAdd.
 Require Import DoubleSub.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Ltac zarith := auto with zarith.
 
@@ -41,13 +41,13 @@ Section POS_MOD.
  Variable ww_zdigits : zn2z w.
 
 
- Definition ww_pos_mod p x := 
+ Definition ww_pos_mod p x :=
   let zdigits := w_0W w_zdigits in
   match x with
   | W0 => W0
   | WW xh xl =>
     match ww_compare p zdigits with
-    | Eq => w_WW w_0 xl 
+    | Eq => w_WW w_0 xl
     | Lt => w_WW w_0 (w_pos_mod (low p) xl)
     | Gt =>
       match ww_compare p ww_zdigits with
@@ -87,7 +87,7 @@ Section POS_MOD.
        | Lt => [[x]] < [[y]]
        | Gt => [[x]] > [[y]]
        end.
- Variable spec_ww_sub: forall x y, 
+ Variable spec_ww_sub: forall x y,
    [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
 
  Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits.
@@ -106,7 +106,7 @@ Section POS_MOD.
  unfold ww_pos_mod; case w1.
  simpl; rewrite Zmod_small; split; auto with zarith.
  intros xh xl; generalize (spec_ww_compare p (w_0W w_zdigits));
-    case ww_compare; 
+    case ww_compare;
     rewrite spec_w_0W; rewrite spec_zdigits; fold wB;
     intros H1.
    rewrite H1; simpl ww_to_Z.
@@ -135,13 +135,13 @@ Section POS_MOD.
    autorewrite with w_rewrite rm10.
    rewrite Zmod_mod; auto with zarith.
 generalize (spec_ww_compare p ww_zdigits);
-    case ww_compare; rewrite spec_ww_zdigits; 
+    case ww_compare; rewrite spec_ww_zdigits;
                      rewrite spec_zdigits; intros H2.
   replace (2^[[p]]) with wwB.
     rewrite Zmod_small; auto with zarith.
   unfold base; rewrite H2.
   rewrite spec_ww_digits; auto.
-  assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = 
+  assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] =
          [[p]] - Zpos w_digits).
     rewrite spec_low.
     rewrite spec_ww_sub.
@@ -152,11 +152,11 @@ generalize (spec_ww_compare p ww_zdigits);
     apply Zlt_le_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_le_lin; auto with zarith.
     exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith.
-    rewrite spec_ww_digits; 
+    rewrite spec_ww_digits;
       apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith.
    simpl ww_to_Z; autorewrite with w_rewrite.
    rewrite spec_pos_mod; rewrite HH0.
-   pattern [|xh|] at 2; 
+   pattern [|xh|] at 2;
      rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits));
      auto with zarith.
    rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l.
@@ -196,7 +196,7 @@ generalize (spec_ww_compare p ww_zdigits);
   split; auto with zarith.
   rewrite Zpos_xO; auto with zarith.
  Qed.
-   
+
 End POS_MOD.
 
 Section DoubleDiv32.
@@ -222,24 +222,24 @@ Section DoubleDiv32.
   match w_compare a1 b1 with
   | Lt =>
     let (q,r) := w_div21 a1 a2 b1 in
-    match ww_sub_c (w_WW r a3) (w_mul_c q b2) with 
+    match ww_sub_c (w_WW r a3) (w_mul_c q b2) with
     | C0 r1 => (q,r1)
     | C1 r1 =>
       let q := w_pred q in
-      ww_add_c_cont w_WW w_add_c w_add_carry_c 
+      ww_add_c_cont w_WW w_add_c w_add_carry_c
       (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2)))
       (fun r2 => (q,r2))
       r1 (WW b1 b2)
     end
   | Eq =>
-    ww_add_c_cont w_WW w_add_c w_add_carry_c 
+    ww_add_c_cont w_WW w_add_c w_add_carry_c
     (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2)))
     (fun r => (w_Bm1,r))
     (WW (w_sub a2 b2) a3) (WW b1 b2)
   | Gt => (w_0, W0) (* cas absurde *)
   end.
 
- (* Proof *) 
+ (* Proof *)
 
   Variable w_digits      : positive.
   Variable w_to_Z : w -> Z.
@@ -253,8 +253,8 @@ Section DoubleDiv32.
    (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
-   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[-[ c ]]" :=
+   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
 
 
@@ -273,7 +273,7 @@ Section DoubleDiv32.
        | Gt => [|x|] > [|y|]
        end.
   Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
-  Variable spec_w_add_carry_c : 
+  Variable spec_w_add_carry_c :
          forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1.
 
   Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
@@ -315,8 +315,8 @@ Section DoubleDiv32.
      wB/2 <= [|b1|] ->
      [[WW a1 a2]] < [[WW b1 b2]] ->
      let (q,r) := w_div32 a1 a2 a3 b1 b2 in
-     [|a1|] * wwB + [|a2|] * wB  + [|a3|] = 
-        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\ 
+     [|a1|] * wwB + [|a2|] * wB  + [|a3|] =
+        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\
      0 <= [[r]] < [|b1|] * wB + [|b2|].
   Proof.
    intros a1 a2 a3 b1 b2 Hle Hlt.
@@ -327,17 +327,17 @@ Section DoubleDiv32.
     match w_compare a1 b1 with
     | Lt =>
      let (q,r) := w_div21 a1 a2 b1 in
-     match ww_sub_c (w_WW r a3) (w_mul_c q b2) with 
+     match ww_sub_c (w_WW r a3) (w_mul_c q b2) with
      | C0 r1 => (q,r1)
      | C1 r1 =>
       let q := w_pred q in
-      ww_add_c_cont w_WW w_add_c w_add_carry_c 
+      ww_add_c_cont w_WW w_add_c w_add_carry_c
       (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2)))
       (fun r2 => (q,r2))
       r1 (WW b1 b2)
      end
     | Eq =>
-     ww_add_c_cont w_WW w_add_c w_add_carry_c 
+     ww_add_c_cont w_WW w_add_c w_add_carry_c
      (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2)))
      (fun r => (w_Bm1,r))
      (WW (w_sub a2 b2) a3) (WW b1 b2)
@@ -360,7 +360,7 @@ Section DoubleDiv32.
      [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\
      0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto.
    rewrite H0;intros r.
-   repeat 
+   repeat
     (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2);
    simpl ww_to_Z;try rewrite Zmult_1_l;intros H1.
    assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]).
@@ -385,7 +385,7 @@ Section DoubleDiv32.
              1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail).
    split. rewrite H1;rewrite Hcmp;ring. trivial.
    Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith.
-   rewrite H0;intros r;repeat 
+   rewrite H0;intros r;repeat
     (rewrite spec_w_Bm1 || rewrite spec_w_Bm2);
    simpl ww_to_Z;try rewrite Zmult_1_l;intros H1.
    assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith.
@@ -409,7 +409,7 @@ Section DoubleDiv32.
     as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c);
     unfold interp_carry;intros H1.
     rewrite H1.
-   split. ring. split. 
+   split. ring. split.
    rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial.
    apply Zle_lt_trans with ([|r|] * wB + [|a3|]).
    assert ( 0 <= [|q|] * [|b2|]);zarith.
@@ -418,7 +418,7 @@ Section DoubleDiv32.
    rewrite <- H1;ring.
    Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith.
    assert (0 < [|q|] * [|b2|]). zarith.
-   assert (0 < [|q|]). 
+   assert (0 < [|q|]).
     apply Zmult_lt_0_reg_r_2 with [|b2|];zarith.
    eapply spec_ww_add_c_cont with (P :=
      fun (x y:zn2z w) (res:w*zn2z w) =>
@@ -440,18 +440,18 @@ Section DoubleDiv32.
        wwB * 1 +
        ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))).
    rewrite H7;rewrite H2;ring.
-   assert 
-    ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) 
+   assert
+    ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|])
         < [|b1|]*wB + [|b2|]).
    Spec_ww_to_Z r2;omega.
    Spec_ww_to_Z (WW b1 b2). simpl in HH5.
-   assert 
-    (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) 
+   assert
+    (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|])
        < wwB). split;try omega.
    replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring.
    assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB).
    rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega.
-   rewrite <- (Zmod_unique 
+   rewrite <- (Zmod_unique
             ([[r2]] + ([|b1|] * wB + [|b2|]))
             wwB
             1
@@ -486,7 +486,7 @@ Section DoubleDiv21.
 
  Definition ww_div21 a1 a2 b :=
   match a1 with
-  | W0 =>  
+  | W0 =>
     match ww_compare a2 b with
     | Gt => (ww_1, ww_sub a2 b)
     | Eq => (ww_1, W0)
@@ -529,8 +529,8 @@ Section DoubleDiv21.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
-   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[-[ c ]]" :=
+   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
 
   Variable spec_w_0   : [|w_0|] = 0.
@@ -540,8 +540,8 @@ Section DoubleDiv21.
      wB/2 <= [|b1|] ->
      [[WW a1 a2]] < [[WW b1 b2]] ->
      let (q,r) := w_div32 a1 a2 a3 b1 b2 in
-     [|a1|] * wwB + [|a2|] * wB  + [|a3|] = 
-        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\ 
+     [|a1|] * wwB + [|a2|] * wB  + [|a3|] =
+        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\
      0 <= [[r]] < [|b1|] * wB + [|b2|].
   Variable spec_ww_1 : [[ww_1]] = 1.
   Variable spec_ww_compare :  forall x y,
@@ -591,10 +591,10 @@ Section DoubleDiv21.
    intros Hlt H;  match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] =>
      generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U);
      intros q1 r H0
-   end; (assert (Eq1: wB / 2 <= [|b1|]);[ 
+   end; (assert (Eq1: wB / 2 <= [|b1|]);[
     apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith;
     autorewrite with rm10;repeat rewrite (Zmult_comm wB);
-    rewrite <- wwB_div_2; trivial 
+    rewrite <- wwB_div_2; trivial
    | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl;
      try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r;
      intros (H1,H2) ]).
@@ -611,10 +611,10 @@ Section DoubleDiv21.
    rewrite <- wwB_wBwB;rewrite H1.
    rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4.
    repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]).
-   rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. 
+   rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring.
    split;[rewrite wwB_wBwB | split;zarith].
-   replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) 
-   with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). 
+   replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|]))
+   with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]).
    rewrite H1;ring. rewrite wwB_wBwB;ring.
    change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith.
    assert (1 <= wB/2);zarith.
@@ -624,7 +624,7 @@ Section DoubleDiv21.
      intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end.
    split;trivial.
    replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with
-   (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); 
+   (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]);
    [rewrite H1 | rewrite wwB_wBwB;ring].
    replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with
    (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|]));
@@ -666,22 +666,22 @@ Section DoubleDivGt.
   Eval lazy beta iota delta [ww_sub ww_opp] in
     let p := w_head0 bh in
     match w_compare p w_0 with
-    | Gt => 
+    | Gt =>
       let b1 := w_add_mul_div p bh bl in
       let b2 := w_add_mul_div p bl w_0 in
       let a1 := w_add_mul_div p w_0 ah in
       let a2 := w_add_mul_div p ah al in
       let a3 := w_add_mul_div p al w_0 in
       let (q,r) := w_div32 a1 a2 a3 b1 b2 in
-      (WW w_0 q, ww_add_mul_div 
+      (WW w_0 q, ww_add_mul_div
         (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
             w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r)
     | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
             w_opp w_sub w_sub_carry (WW ah al) (WW bh bl))
     end.
 
- Definition ww_div_gt a b := 
-  Eval lazy beta iota delta [ww_div_gt_aux double_divn1 
+ Definition ww_div_gt a b :=
+  Eval lazy beta iota delta [ww_div_gt_aux double_divn1
   double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux
   double_split double_0 double_WW] in
   match a, b with
@@ -691,11 +691,11 @@ Section DoubleDivGt.
     if w_eq0 ah then
      let (q,r) := w_div_gt al bl in
      (WW w_0 q, w_0W r)
-    else 
+    else
      match w_compare w_0 bh with
-     | Eq => 
+     | Eq =>
        let(q,r):=
-        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 
+        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
                   w_compare w_sub 1 a bl in
        (q, w_0W r)
      | Lt => ww_div_gt_aux ah al bh bl
@@ -707,7 +707,7 @@ Section DoubleDivGt.
   Eval lazy beta iota delta [ww_sub ww_opp] in
     let p := w_head0 bh in
     match w_compare p w_0 with
-    | Gt => 
+    | Gt =>
       let b1 := w_add_mul_div p bh bl in
       let b2 := w_add_mul_div p bl w_0 in
       let a1 := w_add_mul_div p w_0 ah in
@@ -716,13 +716,13 @@ Section DoubleDivGt.
       let (q,r) := w_div32 a1 a2 a3 b1 b2 in
       ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
          w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r
-    | _ => 
+    | _ =>
       ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
          w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)
     end.
 
- Definition ww_mod_gt a b := 
-  Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 
+ Definition ww_mod_gt a b :=
+  Eval lazy beta iota delta [ww_mod_gt_aux double_modn1
   double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux
   double_split double_0 double_WW snd] in
   match a, b with
@@ -730,10 +730,10 @@ Section DoubleDivGt.
   | _, W0 => W0
   | WW ah al, WW bh bl =>
     if w_eq0 ah then w_0W (w_mod_gt al bl)
-    else 
+    else
      match w_compare w_0 bh with
-     | Eq => 
-       w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 
+     | Eq =>
+       w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
              w_compare w_sub 1 a bl)
      | Lt => ww_mod_gt_aux ah al bh bl
      | Gt => W0 (* cas absurde *)
@@ -741,14 +741,14 @@ Section DoubleDivGt.
   end.
 
   Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) :=
-   Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 
+   Eval lazy beta iota delta [ww_mod_gt_aux double_modn1
    double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux
    double_split double_0 double_WW snd] in
     match w_compare w_0 bh with
     | Eq =>
       match w_compare w_0 bl with
       | Eq => WW ah al (* normalement n'arrive pas si forme normale *)
-      | Lt => 
+      | Lt =>
 	let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                    w_compare w_sub 1 (WW ah al) bl in
         WW w_0 (w_gcd_gt bl m)
@@ -757,14 +757,14 @@ Section DoubleDivGt.
     | Lt =>
       let m := ww_mod_gt_aux ah al bh bl in
       match m with
-      | W0 => WW bh bl 
+      | W0 => WW bh bl
       | WW mh ml =>
         match w_compare w_0 mh with
         | Eq =>
           match w_compare w_0 ml with
           | Eq => WW bh bl
-          | _  => 
-            let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 
+          | _  =>
+            let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                       w_compare w_sub 1 (WW bh bl) ml in
             WW w_0 (w_gcd_gt ml r)
           end
@@ -779,18 +779,18 @@ Section DoubleDivGt.
       end
     | Gt => W0 (* absurde *)
     end.
- 
-  Fixpoint ww_gcd_gt_aux 
-     (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) 
+
+  Fixpoint ww_gcd_gt_aux
+     (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w)
         {struct p} : zn2z w :=
-    ww_gcd_gt_body 
+    ww_gcd_gt_body
        (fun mh ml rh rl => match p with
         | xH => cont mh ml rh rl
         | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl
         | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl
         end) ah al bh bl.
 
- 
+
   (* Proof *)
 
   Variable w_to_Z : w -> Z.
@@ -816,7 +816,7 @@ Section DoubleDivGt.
        | Gt => [|x|] > [|y|]
        end.
   Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0.
-  
+
   Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|].
   Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB.
   Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1.
@@ -854,8 +854,8 @@ Section DoubleDivGt.
      wB/2 <= [|b1|] ->
      [[WW a1 a2]] < [[WW b1 b2]] ->
      let (q,r) := w_div32 a1 a2 a3 b1 b2 in
-     [|a1|] * wwB + [|a2|] * wB  + [|a3|] = 
-        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\ 
+     [|a1|] * wwB + [|a2|] * wB  + [|a3|] =
+        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\
      0 <= [[r]] < [|b1|] * wB + [|b2|].
 
   Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits.
@@ -899,14 +899,14 @@ Section DoubleDivGt.
    change
    (let (q, r) := let p := w_head0 bh in
     match w_compare p w_0 with
-    | Gt => 
+    | Gt =>
       let b1 := w_add_mul_div p bh bl in
       let b2 := w_add_mul_div p bl w_0 in
       let a1 := w_add_mul_div p w_0 ah in
       let a2 := w_add_mul_div p ah al in
       let a3 := w_add_mul_div p al w_0 in
       let (q,r) := w_div32 a1 a2 a3 b1 b2 in
-      (WW w_0 q, ww_add_mul_div 
+      (WW w_0 q, ww_add_mul_div
         (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
             w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r)
     | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
@@ -931,7 +931,7 @@ Section DoubleDivGt.
    case (spec_to_Z (w_head0 bh)); auto with zarith.
    assert ([|w_head0 bh|] < Zpos w_digits).
     destruct (Z_lt_ge_dec [|w_head0 bh|]  (Zpos w_digits));trivial.
-    elimtype False.
+    exfalso.
     assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith.
     apply Zle_ge; replace wB with (wB * 1);try ring.
     Spec_w_to_Z bh;apply Zmult_le_compat;zarith.
@@ -945,11 +945,11 @@ Section DoubleDivGt.
     (spec_add_mul_div bl w_0  Hb);
    rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l;
    rewrite Zdiv_0_l;repeat rewrite Zplus_0_r.
-   Spec_w_to_Z ah;Spec_w_to_Z bh.    
+   Spec_w_to_Z ah;Spec_w_to_Z bh.
    unfold base;repeat rewrite Zmod_shift_r;zarith.
    assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH);
    assert (H5:=to_Z_div_minus_p bl HHHH).
-   rewrite Zmult_comm in Hh. 
+   rewrite Zmult_comm in Hh.
    assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith.
    unfold base in H0;rewrite Zmod_small;zarith.
    fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith.
@@ -964,15 +964,15 @@ Section DoubleDivGt.
               (w_add_mul_div (w_head0 bh) al w_0)
               (w_add_mul_div (w_head0 bh) bh bl)
               (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r).
-   rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. 
-   rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). 
+   rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l.
+   rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)).
    unfold base;rewrite <- shift_unshift_mod;zarith. fold wB.
    replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with
     ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring.
    fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3.
-   rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. 
+   rewrite Zmult_assoc. rewrite Zmult_plus_distr_l.
    rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)).
-   rewrite <- Zmult_plus_distr_l.  rewrite <- Zplus_assoc. 
+   rewrite <- Zmult_plus_distr_l.  rewrite <- Zplus_assoc.
    unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB.
    replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with
     ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring.
@@ -1027,7 +1027,7 @@ Section DoubleDivGt.
       [[a]] = [[q]] * [[b]] + [[r]] /\
       0 <= [[r]] < [[b]].
   Proof.
-   intros a b Hgt Hpos;unfold ww_div_gt. 
+   intros a b Hgt Hpos;unfold ww_div_gt.
    change (let (q,r) :=   match a, b with
   | W0, _ => (W0,W0)
   | _, W0 => (W0,W0)
@@ -1035,23 +1035,23 @@ Section DoubleDivGt.
     if w_eq0 ah then
      let (q,r) := w_div_gt al bl in
      (WW w_0 q, w_0W r)
-    else 
+    else
      match w_compare w_0 bh with
-     | Eq => 
+     | Eq =>
        let(q,r):=
-        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 
+        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
                   w_compare w_sub 1 a bl in
        (q, w_0W r)
      | Lt => ww_div_gt_aux ah al bh bl
      | Gt => (W0,W0) (* cas absurde *)
      end
-  end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). 
+  end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]).
    destruct a as [ |ah al]. simpl in Hgt;omega.
    destruct b as [ |bh bl]. simpl in Hpos;omega.
    Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl.
    assert (H:=@spec_eq0 ah);destruct (w_eq0 ah).
    simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial.
-   assert ([|bh|] <= 0). 
+   assert ([|bh|] <= 0).
    apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith.
    assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt.
    simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos.
@@ -1066,12 +1066,12 @@ Section DoubleDivGt.
     w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0
     spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos).
    unfold double_to_Z,double_wB,double_digits in H2.
-   destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 
+   destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
               w_compare w_sub 1
              (WW ah al) bl).
    rewrite spec_w_0W;unfold ww_to_Z;trivial.
    apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial.
-   rewrite spec_w_0 in Hcmp;elimtype False;omega.
+   rewrite spec_w_0 in Hcmp;exfalso;omega.
   Qed.
 
   Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl,
@@ -1104,26 +1104,26 @@ Section DoubleDivGt.
    rewrite Zmult_comm in H;destruct H.
    symmetry;apply Zmod_unique with [|q|];trivial.
   Qed.
-  
+
   Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
       [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]].
   Proof.
    intros a b Hgt Hpos.
-   change (ww_mod_gt a b) with 
+   change (ww_mod_gt a b) with
    (match a, b with
   | W0, _ => W0
   | _, W0 => W0
   | WW ah al, WW bh bl =>
     if w_eq0 ah then w_0W (w_mod_gt al bl)
-    else 
+    else
      match w_compare w_0 bh with
-     | Eq => 
-       w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 
+     | Eq =>
+       w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
              w_compare w_sub 1 a bl)
      | Lt => ww_mod_gt_aux ah al bh bl
      | Gt => W0 (* cas absurde *)
      end end).
-   change (ww_div_gt a b) with 
+   change (ww_div_gt a b) with
    (match a, b with
   | W0, _ => (W0,W0)
   | _, W0 => (W0,W0)
@@ -1131,11 +1131,11 @@ Section DoubleDivGt.
     if w_eq0 ah then
      let (q,r) := w_div_gt al bl in
      (WW w_0 q, w_0W r)
-    else 
+    else
      match w_compare w_0 bh with
-     | Eq => 
+     | Eq =>
        let(q,r):=
-        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 
+        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
                   w_compare w_sub 1 a bl in
        (q, w_0W r)
      | Lt => ww_div_gt_aux ah al bh bl
@@ -1147,7 +1147,7 @@ Section DoubleDivGt.
    Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl.
    assert (H:=@spec_eq0 ah);destruct (w_eq0 ah).
    simpl in Hgt;rewrite H in Hgt;trivial.
-   assert ([|bh|] <= 0). 
+   assert ([|bh|] <= 0).
    apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith.
    assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt.
    simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos.
@@ -1155,7 +1155,7 @@ Section DoubleDivGt.
    destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial.
    clear H.
    assert (H2 := spec_compare w_0 bh);destruct (w_compare w_0 bh).
-   rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div 
+   rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div
             w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl).
    destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1
              (WW ah al) bl);simpl;trivial.
@@ -1174,7 +1174,7 @@ Section DoubleDivGt.
    rewrite Zmult_comm;trivial.
   Qed.
 
-  Lemma Zis_gcd_mod : forall a b d, 
+  Lemma Zis_gcd_mod : forall a b d,
    0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d.
   Proof.
    intros a b d H H1; apply Zis_gcd_for_euclid with (a/b).
@@ -1182,12 +1182,12 @@ Section DoubleDivGt.
    ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith.
   Qed.
 
-  Lemma spec_ww_gcd_gt_aux_body : 
+  Lemma spec_ww_gcd_gt_aux_body :
    forall ah al bh bl n cont,
-    [[WW bh bl]] <= 2^n -> 
+    [[WW bh bl]] <= 2^n ->
     [[WW ah al]] > [[WW bh bl]] ->
-    (forall xh xl yh yl, 
-     [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> 
+    (forall xh xl yh yl,
+     [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) ->
      Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) ->
     Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]].
   Proof.
@@ -1196,7 +1196,7 @@ Section DoubleDivGt.
     | Eq =>
       match w_compare w_0 bl with
       | Eq => WW ah al (* normalement n'arrive pas si forme normale *)
-      | Lt => 
+      | Lt =>
 	let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                    w_compare w_sub 1 (WW ah al) bl in
         WW w_0 (w_gcd_gt bl m)
@@ -1205,14 +1205,14 @@ Section DoubleDivGt.
     | Lt =>
       let m := ww_mod_gt_aux ah al bh bl in
       match m with
-      | W0 => WW bh bl 
+      | W0 => WW bh bl
       | WW mh ml =>
         match w_compare w_0 mh with
         | Eq =>
           match w_compare w_0 ml with
           | Eq => WW bh bl
-          | _  => 
-            let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 
+          | _  =>
+            let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                       w_compare w_sub 1 (WW bh bl) ml in
             WW w_0 (w_gcd_gt ml r)
           end
@@ -1227,10 +1227,10 @@ Section DoubleDivGt.
       end
     | Gt => W0 (* absurde *)
     end).
-   assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). 
+   assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh).
    simpl ww_to_Z in *. rewrite spec_w_0 in Hbh;rewrite <- Hbh;
    rewrite Zmult_0_l;rewrite Zplus_0_l.
-   assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). 
+   assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl).
    rewrite spec_w_0 in Hbl;rewrite <- Hbl;apply Zis_gcd_0.
    simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
    rewrite spec_w_0 in Hbl.
@@ -1239,54 +1239,54 @@ Section DoubleDivGt.
    rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div
     w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div
     spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl).
-   apply spec_gcd_gt. 
-   rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.   
-   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => 
+   apply spec_gcd_gt.
+   rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.
+   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
     destruct (Z_mod_lt x y);zarith end.
-   rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;elimtype False;omega.
+   rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;exfalso;omega.
    rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh).
-   assert (H2 : 0 < [[WW bh bl]]). 
+   assert (H2 : 0 < [[WW bh bl]]).
    simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith.
    apply Zmult_lt_0_compat;zarith.
    apply Zis_gcd_mod;trivial. rewrite <- H.
    simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml].
-   simpl;apply Zis_gcd_0;zarith. 
-   assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). 
+   simpl;apply Zis_gcd_0;zarith.
+   assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh).
    simpl;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl.
-   assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). 
+   assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml).
    rewrite <- Hml;rewrite spec_w_0;simpl;apply Zis_gcd_0.
-   simpl;rewrite spec_w_0;simpl. 
+   simpl;rewrite spec_w_0;simpl.
    rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith.
    change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)).
    rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div
    w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div
    spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml).
-   apply spec_gcd_gt. 
-   rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.   
-   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => 
+   apply spec_gcd_gt.
+   rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.
+   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
    destruct (Z_mod_lt x y);zarith end.
-   rewrite spec_w_0 in Hml;Spec_w_to_Z ml;elimtype False;omega.
+   rewrite spec_w_0 in Hml;Spec_w_to_Z ml;exfalso;omega.
    rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]).
-   rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => 
+   rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
    destruct (Z_mod_lt x y);zarith end.
    assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh).
-   assert (H3 : 0 < [[WW mh ml]]). 
+   assert (H3 : 0 < [[WW mh ml]]).
    simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith.
    apply Zmult_lt_0_compat;zarith.
    apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1.
    destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0.
    simpl;apply Hcont. simpl in H1;rewrite H1.
-   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => 
+   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
    destruct (Z_mod_lt x y);zarith end.
-   apply Zle_trans with (2^n/2). 
-   apply Zdiv_le_lower_bound;zarith. 
+   apply Zle_trans with (2^n/2).
+   apply Zdiv_le_lower_bound;zarith.
    apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith.
    assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)).
    assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]).
    apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1.
    pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'.
    destruct (Zle_lt_or_eq _ _ H4').
-   assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = 
+   assert (H6' : [[WW bh bl]] mod [[WW mh ml]] =
                   [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])).
    simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'.
    assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])).
@@ -1300,14 +1300,14 @@ Section DoubleDivGt.
    rewrite Z_div_mult;zarith.
    assert (2^1 <= 2^n). change (2^1) with 2;zarith.
    assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith.
-   rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;elimtype False;zarith.
-   rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;elimtype False;zarith.
+   rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;exfalso;zarith.
+   rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;exfalso;zarith.
   Qed.
 
-  Lemma spec_ww_gcd_gt_aux : 
+  Lemma spec_ww_gcd_gt_aux :
    forall p cont n,
-   (forall xh xl yh yl, 
-     [[WW xh xl]] > [[WW yh yl]] -> 
+   (forall xh xl yh yl,
+     [[WW xh xl]] > [[WW yh yl]] ->
      [[WW yh yl]] <= 2^n ->
       Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) ->
    forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] ->
@@ -1334,7 +1334,7 @@ Section DoubleDivGt.
    apply Zle_trans with (2 ^ (Zpos p + n -1));zarith.
    apply Zpower_le_monotone2;zarith.
    apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith.
-   apply Zpower_le_monotone2;zarith. 
+   apply Zpower_le_monotone2;zarith.
    apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial.
    rewrite Zplus_comm;trivial.
    ring_simplify (n + 1 - 1);trivial.
@@ -1352,16 +1352,16 @@ Section DoubleDiv.
  Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w.
  Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w.
 
- Definition ww_div a b := 
-  match ww_compare a b with 
-  | Gt => ww_div_gt a b 
+ Definition ww_div a b :=
+  match ww_compare a b with
+  | Gt => ww_div_gt a b
   | Eq => (ww_1, W0)
   | Lt => (W0, a)
   end.
 
- Definition ww_mod a b := 
-  match ww_compare a b with 
-  | Gt => ww_mod_gt a b 
+ Definition ww_mod a b :=
+  match ww_compare a b with
+  | Gt => ww_mod_gt a b
   | Eq => W0
   | Lt => a
   end.
@@ -1401,7 +1401,7 @@ Section DoubleDiv.
   Proof.
    intros a b Hpos;unfold ww_div.
    assert (H:=spec_ww_compare a b);destruct (ww_compare a b).
-   simpl;rewrite spec_ww_1;split;zarith. 
+   simpl;rewrite spec_ww_1;split;zarith.
    simpl;split;[ring|Spec_ww_to_Z a;zarith].
    apply spec_ww_div_gt;trivial.
   Qed.
@@ -1409,7 +1409,7 @@ Section DoubleDiv.
   Lemma  spec_ww_mod :  forall a b, 0 < [[b]] ->
       [[ww_mod a b]] = [[a]] mod [[b]].
   Proof.
-   intros a b Hpos;unfold ww_mod. 
+   intros a b Hpos;unfold ww_mod.
    assert (H := spec_ww_compare a b);destruct (ww_compare a b).
    simpl;apply Zmod_unique with 1;try rewrite H;zarith.
    Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith.
@@ -1424,8 +1424,8 @@ Section DoubleDiv.
  Variable w_gcd_gt : w -> w -> w.
  Variable _ww_digits : positive.
  Variable spec_ww_digits_ : _ww_digits = xO w_digits.
- Variable ww_gcd_gt_fix : 
-   positive -> (w -> w -> w -> w -> zn2z w) -> 
+ Variable ww_gcd_gt_fix :
+   positive -> (w -> w -> w -> w -> zn2z w) ->
              w -> w -> w -> w -> zn2z w.
 
   Variable spec_w_0   : [|w_0|] = 0.
@@ -1440,10 +1440,10 @@ Section DoubleDiv.
   Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0.
   Variable spec_gcd_gt : forall a b, [|a|] > [|b|] ->
       Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|].
-  Variable spec_gcd_gt_fix : 
+  Variable spec_gcd_gt_fix :
    forall p cont n,
-   (forall xh xl yh yl, 
-     [[WW xh xl]] > [[WW yh yl]] -> 
+   (forall xh xl yh yl,
+     [[WW xh xl]] > [[WW yh yl]] ->
      [[WW yh yl]] <= 2^n ->
       Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) ->
    forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] ->
@@ -1451,20 +1451,20 @@ Section DoubleDiv.
      Zis_gcd [[WW ah al]] [[WW bh bl]]
         [[ww_gcd_gt_fix p cont ah al bh bl]].
 
- Definition gcd_cont (xh xl yh yl:w) := 
+ Definition gcd_cont (xh xl yh yl:w) :=
   match w_compare w_1 yl with
-  | Eq => ww_1 
+  | Eq => ww_1
   | _ => WW xh xl
   end.
 
-  Lemma spec_gcd_cont : forall xh xl yh yl, 
-     [[WW xh xl]] > [[WW yh yl]] -> 
+  Lemma spec_gcd_cont : forall xh xl yh yl,
+     [[WW xh xl]] > [[WW yh yl]] ->
      [[WW yh yl]] <= 1 ->
       Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]].
   Proof.
    intros xh xl yh yl Hgt' Hle. simpl in Hle.
    assert ([|yh|] = 0).
-    change 1 with (0*wB+1) in Hle. 
+    change 1 with (0*wB+1) in Hle.
     assert (0 <= 1 < wB). split;zarith. apply wB_pos.
     assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H).
     Spec_w_to_Z yh;zarith.
@@ -1473,20 +1473,20 @@ Section DoubleDiv.
    simpl;rewrite H;simpl;destruct (w_compare w_1 yl).
    rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith.
    rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith.
-   rewrite H in Hle; elimtype False;zarith.
+   rewrite H in Hle; exfalso;zarith.
    assert ([|yl|] = 0). Spec_w_to_Z yl;zarith.
    rewrite H0;simpl;apply Zis_gcd_0;trivial.
   Qed.
 
- 
+
   Variable cont : w -> w -> w -> w -> zn2z w.
-  Variable spec_cont : forall xh xl yh yl, 
-     [[WW xh xl]] > [[WW yh yl]] -> 
+  Variable spec_cont : forall xh xl yh yl,
+     [[WW xh xl]] > [[WW yh yl]] ->
      [[WW yh yl]] <= 1 ->
       Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]].
- 
-  Definition ww_gcd_gt a b := 
-   match a, b with 
+
+  Definition ww_gcd_gt a b :=
+   match a, b with
    | W0, _ => b
    | _, W0 => a
    | WW ah al, WW bh bl =>
@@ -1509,8 +1509,8 @@ Section DoubleDiv.
    destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0.
    destruct b as [ |bh bl]. simpl;apply Zis_gcd_0.
    simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros.
-   simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl.  
-   assert ([|bh|] <= 0). 
+   simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl.
+   assert ([|bh|] <= 0).
    apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith.
    Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt.
    rewrite H1;simpl;auto. clear H.
@@ -1522,7 +1522,7 @@ Section DoubleDiv.
   Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]].
   Proof.
    intros a b.
-   change (ww_gcd a b) with  
+   change (ww_gcd a b) with
     (match ww_compare a b with
      | Gt => ww_gcd_gt a b
      | Eq => a
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
index d6f6a05f..386bbb9e 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleDivn1.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -17,7 +17,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section GENDIVN1.
 
@@ -31,19 +31,19 @@ Section GENDIVN1.
  Variable w_div21       : w -> w -> w -> w * w.
  Variable w_compare     : w -> w -> comparison.
  Variable w_sub         : w -> w -> w.
- 
 
- 
+
+
  (* ** For proofs ** *)
  Variable w_to_Z        : w -> Z.
- 
- Notation wB := (base w_digits). 
+
+ Notation wB := (base w_digits).
 
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
- Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) 
+ Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x)
                                       (at level 0, x at level 99).
  Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x)  (at level 0, x at level 99).
- 
+
  Variable spec_to_Z   : forall x, 0 <= [| x |] < wB.
  Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits.
  Variable spec_0   : [|w_0|] = 0.
@@ -68,10 +68,10 @@ Section GENDIVN1.
        | Lt => [|x|] < [|y|]
        | Gt => [|x|] > [|y|]
        end.
- Variable spec_sub: forall x y, 
+ Variable spec_sub: forall x y,
    [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
 
- 
+
 
  Section DIVAUX.
   Variable b2p : w.
@@ -85,10 +85,10 @@ Section GENDIVN1.
 
   Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w :=
    match n return w -> word w n -> word w n * w with
-   | O => fun r x => w_div21 r x b2p 
-   | S n => double_divn1_0_aux n (double_divn1_0 n) 
+   | O => fun r x => w_div21 r x b2p
+   | S n => double_divn1_0_aux n (double_divn1_0 n)
    end.
- 
+
   Lemma spec_split : forall (n : nat) (x : zn2z (word w n)),
        let (h, l) := double_split w_0 n x in
        [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!].
@@ -132,11 +132,11 @@ Section GENDIVN1.
    induction n;simpl;intros;trivial.
    unfold double_modn1_0_aux, double_divn1_0_aux.
    destruct (double_split w_0 n x) as (hh,hl).
-   rewrite (IHn r hh). 
+   rewrite (IHn r hh).
    destruct (double_divn1_0 n r hh) as (qh,rh);simpl.
    rewrite IHn. destruct (double_divn1_0 n rh hl);trivial.
   Qed.
- 
+
   Variable p : w.
   Variable p_bounded : [|p|] <= Zpos w_digits.
 
@@ -148,18 +148,18 @@ Section GENDIVN1.
    intros;apply spec_add_mul_div;auto.
   Qed.
 
-  Definition double_divn1_p_aux n 
-   (divn1 : w -> word w n -> word w n -> word w n * w) r h l := 
+  Definition double_divn1_p_aux n
+   (divn1 : w -> word w n -> word w n -> word w n * w) r h l :=
    let (hh,hl) := double_split w_0 n h in
-   let (lh,ll) := double_split w_0 n l in	
+   let (lh,ll) := double_split w_0 n l in
    let (qh,rh) := divn1 r hh hl in
    let (ql,rl) := divn1 rh hl lh in
    (double_WW w_WW n qh ql, rl).
 
   Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w :=
    match n return w -> word w n -> word w n ->  word w n * w with
-   | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p 
-   | S n => double_divn1_p_aux n (double_divn1_p n)   
+   | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p
+   | S n => double_divn1_p_aux n (double_divn1_p n)
    end.
 
   Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (double_digits w_digits n).
@@ -175,8 +175,8 @@ Section GENDIVN1.
   Lemma spec_double_divn1_p : forall n r h l,
     [|r|] < [|b2p|] ->
     let (q,r') := double_divn1_p n r h l in
-    [|r|] * double_wB w_digits n + 
-      ([!n|h!]*2^[|p|] + 
+    [|r|] * double_wB w_digits n +
+      ([!n|h!]*2^[|p|] +
         [!n|l!] / (2^(Zpos(double_digits w_digits n) - [|p|])))
         mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\
     0 <= [|r'|] < [|b2p|].
@@ -198,26 +198,26 @@ Section GENDIVN1.
     ([!n|lh!] * double_wB w_digits n + [!n|ll!]) /
      2^(Zpos (double_digits w_digits (S n)) - [|p|])) mod
       (double_wB w_digits n * double_wB w_digits n)) with
-    (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + 
+    (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] +
       [!n|hl!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod
                       double_wB w_digits n) * double_wB w_digits n +
-     ([!n|hl!] * 2^[|p|] + 
-      [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod 
+     ([!n|hl!] * 2^[|p|] +
+      [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod
               double_wB w_digits n).
    generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh);
    intros (H3,H4);rewrite H3.
-   assert ([|rh|] < [|b2p|]). omega. 
+   assert ([|rh|] < [|b2p|]). omega.
    replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n +
      ([!n|hl!] * 2 ^ [|p|] +
       [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod
-      double_wB w_digits n)  with  
+      double_wB w_digits n)  with
     ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n +
       ([!n|hl!] * 2 ^ [|p|] +
        [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod
       double_wB w_digits n)). 2:ring.
    generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl);
    intros (H5,H6);rewrite H5.
-   split;[rewrite spec_double_WW;trivial;ring|trivial]. 
+   split;[rewrite spec_double_WW;trivial;ring|trivial].
    assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh);
     unfold double_wB,base in Uhh.
    assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl);
@@ -228,37 +228,37 @@ Section GENDIVN1.
     unfold double_wB,base in Ull.
    unfold double_wB,base.
    assert (UU:=p_lt_double_digits n).
-   rewrite Zdiv_shift_r;auto with zarith. 
-   2:change (Zpos (double_digits w_digits (S n))) 
+   rewrite Zdiv_shift_r;auto with zarith.
+   2:change (Zpos (double_digits w_digits (S n)))
      with (2*Zpos (double_digits w_digits n));auto with zarith.
    replace (2 ^ (Zpos (double_digits w_digits (S n)) - [|p|])) with
     (2^(Zpos (double_digits w_digits n) - [|p|])*2^Zpos (double_digits w_digits n)).
    rewrite Zdiv_mult_cancel_r;auto with zarith.
-   rewrite Zmult_plus_distr_l with (p:=  2^[|p|]). 
+   rewrite Zmult_plus_distr_l with (p:=  2^[|p|]).
    pattern  ([!n|hl!] * 2^[|p|]) at 2;
    rewrite (shift_unshift_mod (Zpos(double_digits w_digits n))([|p|])([!n|hl!]));
     auto with zarith.
-   rewrite Zplus_assoc. 
-   replace 
+   rewrite Zplus_assoc.
+   replace
     ([!n|hh!] * 2^Zpos (double_digits w_digits n)* 2^[|p|] +
       ([!n|hl!] / 2^(Zpos (double_digits w_digits n)-[|p|])*
        2^Zpos(double_digits w_digits n)))
-   with 
-    (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / 
+   with
+    (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl /
        2^(Zpos (double_digits w_digits n)-[|p|]))
       * 2^Zpos(double_digits w_digits n));try (ring;fail).
    rewrite <- Zplus_assoc.
    rewrite <- (Zmod_shift_r ([|p|]));auto with zarith.
-   replace 
+   replace
      (2 ^ Zpos (double_digits w_digits n) * 2 ^ Zpos (double_digits w_digits n)) with
      (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))).
    rewrite (Zmod_shift_r (Zpos (double_digits w_digits n)));auto with zarith.
    replace (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n)))
-   with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)). 
+   with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)).
    rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] +
       [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))).
    rewrite  Zmult_mod_distr_l;auto with zarith.
-   ring. 
+   ring.
    rewrite Zpower_exp;auto with zarith.
    assert (0 < Zpos (double_digits w_digits n)). unfold Zlt;reflexivity.
    auto with zarith.
@@ -267,24 +267,24 @@ Section GENDIVN1.
    split;auto with zarith.
    apply Zdiv_lt_upper_bound;auto with zarith.
    rewrite <- Zpower_exp;auto with zarith.
-   replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with 
+   replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with
      (Zpos(double_digits w_digits n));auto with zarith.
    rewrite <- Zpower_exp;auto with zarith.
-   replace (Zpos (double_digits w_digits (S n)) - [|p|]) with 
-       (Zpos (double_digits w_digits n) - [|p|] + 
+   replace (Zpos (double_digits w_digits (S n)) - [|p|]) with
+       (Zpos (double_digits w_digits n) - [|p|] +
          Zpos (double_digits w_digits n));trivial.
-   change (Zpos (double_digits w_digits (S n))) with 
+   change (Zpos (double_digits w_digits (S n))) with
     (2*Zpos (double_digits w_digits n)). ring.
   Qed.
 
   Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:=
    let (hh,hl) := double_split w_0 n h in
-   let (lh,ll) := double_split w_0 n l in	
+   let (lh,ll) := double_split w_0 n l in
    modn1 (modn1 r hh hl) hl lh.
 
   Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w :=
    match n return w -> word w n -> word w n -> w with
-   | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) 
+   | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p)
    | S n => double_modn1_p_aux n (double_modn1_p n)
    end.
 
@@ -302,8 +302,8 @@ Section GENDIVN1.
 
  Fixpoint high (n:nat) : word w n -> w :=
   match n return word w n -> w with
-  | O => fun a => a 
-  | S n => 
+  | O => fun a => a
+  | S n =>
     fun (a:zn2z (word w n)) =>
      match a with
      | W0 => w_0
@@ -314,20 +314,20 @@ Section GENDIVN1.
  Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits w_digits n).
  Proof.
   induction n;simpl;auto with zarith.
-  change (Zpos (xO (double_digits w_digits n))) with 
+  change (Zpos (xO (double_digits w_digits n))) with
     (2*Zpos (double_digits w_digits n)).
   assert (0 < Zpos w_digits);auto with zarith.
   exact (refl_equal Lt).
  Qed.
 
- Lemma spec_high : forall n (x:word w n), 
+ Lemma spec_high : forall n (x:word w n),
    [|high n x|] = [!n|x!] / 2^(Zpos (double_digits w_digits n) - Zpos w_digits).
  Proof.
   induction n;intros.
   unfold high,double_digits,double_to_Z.
   replace (Zpos w_digits - Zpos w_digits) with 0;try ring.
   simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith.
-  assert (U2 := spec_double_digits n). 
+  assert (U2 := spec_double_digits n).
   assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt).
   destruct x;unfold high;fold high.
   unfold double_to_Z,zn2z_to_Z;rewrite spec_0.
@@ -337,31 +337,31 @@ Section GENDIVN1.
   simpl [!S n|WW w0 w1!].
   unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith.
   replace (2 ^ (Zpos (double_digits w_digits (S n)) - Zpos w_digits)) with
-   (2^(Zpos (double_digits w_digits n) - Zpos w_digits) * 
+   (2^(Zpos (double_digits w_digits n) - Zpos w_digits) *
         2^Zpos (double_digits w_digits n)).
   rewrite Zdiv_mult_cancel_r;auto with zarith.
   rewrite <- Zpower_exp;auto with zarith.
-  replace (Zpos (double_digits w_digits n) - Zpos w_digits + 
+  replace (Zpos (double_digits w_digits n) - Zpos w_digits +
     Zpos (double_digits w_digits n)) with
    (Zpos (double_digits w_digits (S n)) - Zpos w_digits);trivial.
-  change (Zpos (double_digits w_digits (S n))) with 
+  change (Zpos (double_digits w_digits (S n))) with
      (2*Zpos (double_digits w_digits n));ring.
-  change (Zpos (double_digits w_digits (S n))) with 
+  change (Zpos (double_digits w_digits (S n))) with
   (2*Zpos (double_digits w_digits n)); auto with zarith.
  Qed.
- 
- Definition double_divn1 (n:nat) (a:word w n) (b:w) := 
+
+ Definition double_divn1 (n:nat) (a:word w n) (b:w) :=
   let p := w_head0 b in
   match w_compare p w_0 with
   | Gt =>
     let b2p := w_add_mul_div p b w_0 in
     let ha := high n a in
     let k := w_sub w_zdigits p in
-    let lsr_n := w_add_mul_div k w_0 in 
+    let lsr_n := w_add_mul_div k w_0 in
     let r0 := w_add_mul_div p w_0 ha in
     let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in
     (q, lsr_n r)
-  | _ => double_divn1_0 b n w_0 a 
+  | _ => double_divn1_0 b n w_0 a
   end.
 
  Lemma spec_double_divn1 : forall n a b,
@@ -392,21 +392,21 @@ Section GENDIVN1.
      apply Zmult_le_compat;auto with zarith.
      assert (wB <= 2^[|w_head0 b|]).
      unfold base;apply Zpower_le_monotone;auto with zarith. omega.
-   assert ([|w_add_mul_div (w_head0 b) b w_0|] = 
+   assert ([|w_add_mul_div (w_head0 b) b w_0|] =
                2 ^ [|w_head0 b|] * [|b|]).
     rewrite (spec_add_mul_div b w_0); auto with zarith.
     rewrite spec_0;rewrite Zdiv_0_l; try omega.
     rewrite Zplus_0_r; rewrite Zmult_comm.
     rewrite Zmod_small; auto with zarith.
    assert (H5 := spec_to_Z (high n a)).
-   assert 
+   assert
     ([|w_add_mul_div (w_head0 b) w_0 (high n a)|]
           <[|w_add_mul_div (w_head0 b) b w_0|]).
     rewrite H4.
     rewrite spec_add_mul_div;auto with zarith.
     rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
     assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB).
-     apply Zdiv_lt_upper_bound;auto with zarith. 
+     apply Zdiv_lt_upper_bound;auto with zarith.
      apply Zlt_le_trans with wB;auto with zarith.
      pattern wB at 1;replace wB with (wB*1);try ring.
      apply Zmult_le_compat;auto with zarith.
@@ -420,8 +420,8 @@ Section GENDIVN1.
     apply Zmult_le_compat;auto with zarith.
     pattern 2 at 1;rewrite <- Zpower_1_r.
     apply Zpower_le_monotone;split;auto with zarith.
-   rewrite <- H4 in H0. 
-   assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. 
+   rewrite <- H4 in H0.
+   assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith.
    assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6).
    destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n
              (w_add_mul_div (w_head0 b) w_0 (high n a)) a
@@ -436,7 +436,7 @@ Section GENDIVN1.
    rewrite Zmod_small;auto with zarith.
    rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith.
    rewrite <- Zpower_exp;auto with zarith.
-   replace (Zpos (double_digits w_digits n) - Zpos w_digits + 
+   replace (Zpos (double_digits w_digits n) - Zpos w_digits +
                        (Zpos w_digits - [|w_head0 b|]))
     with (Zpos (double_digits w_digits n) - [|w_head0 b|]);trivial;ring.
    assert (H8 := Zpower_gt_0 2  (Zpos w_digits - [|w_head0 b|]));auto with zarith.
@@ -448,11 +448,11 @@ Section GENDIVN1.
    rewrite H8 in H7;unfold double_wB,base in H7.
    rewrite <- shift_unshift_mod in H7;auto with zarith.
    rewrite H4 in H7.
-   assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] 
+   assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|]
                = [|r|]/2^[|w_head0 b|]).
    rewrite spec_add_mul_div.
    rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
-   replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) 
+   replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|])
       with ([|w_head0 b|]).
    rewrite Zmod_small;auto with zarith.
    assert (H9 := spec_to_Z r).
@@ -474,11 +474,11 @@ Section GENDIVN1.
    split.
    rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith.
    rewrite H71;rewrite H9.
-   replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) 
+   replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|]))
       with ([!n|q!] *[|b|] * 2^[|w_head0 b|]);
      try (ring;fail).
    rewrite Z_div_plus_l;auto with zarith.
-   assert (H10 := spec_to_Z 
+   assert (H10 := spec_to_Z
        (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split;
     auto with zarith.
    rewrite H9.
@@ -487,19 +487,19 @@ Section GENDIVN1.
    exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a).
  Qed.
 
- 
- Definition double_modn1 (n:nat) (a:word w n) (b:w) := 
+
+ Definition double_modn1 (n:nat) (a:word w n) (b:w) :=
   let p := w_head0 b in
   match w_compare p w_0 with
   | Gt =>
     let b2p := w_add_mul_div p b w_0 in
     let ha := high n a in
     let k := w_sub w_zdigits p in
-    let lsr_n := w_add_mul_div k w_0 in 
+    let lsr_n := w_add_mul_div k w_0 in
     let r0 := w_add_mul_div p w_0 ha in
     let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in
     lsr_n r
-  | _ => double_modn1_0 b n w_0 a 
+  | _ => double_modn1_0 b n w_0 a
   end.
 
  Lemma spec_double_modn1_aux : forall n a b,
@@ -525,4 +525,4 @@ Section GENDIVN1.
   destruct H1 as (h1,h2);rewrite h1;ring.
  Qed.
 
-End GENDIVN1. 
+End GENDIVN1.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
index 50c72487..21e694e5 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleLift.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -17,7 +17,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section DoubleLift.
  Variable w : Type.
@@ -61,13 +61,13 @@ Section DoubleLift.
 
 
   (* 0 < p < ww_digits *)
- Definition ww_add_mul_div p x y := 
+ Definition ww_add_mul_div p x y :=
   let zdigits := w_0W w_zdigits in
   match x, y with
   | W0, W0 => W0
   | W0, WW yh yl =>
     match ww_compare p zdigits with
-    | Eq => w_0W yh 
+    | Eq => w_0W yh
     | Lt => w_0W (w_add_mul_div (low p) w_0 yh)
     | Gt =>
       let n := low (ww_sub p zdigits) in
@@ -75,15 +75,15 @@ Section DoubleLift.
     end
   | WW xh xl, W0 =>
     match ww_compare p zdigits with
-    | Eq => w_W0 xl 
+    | Eq => w_W0 xl
     | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0)
     | Gt =>
       let n := low (ww_sub p zdigits) in
-      w_W0 (w_add_mul_div n xl w_0) 
+      w_W0 (w_add_mul_div n xl w_0)
     end
   | WW xh xl, WW yh yl =>
     match ww_compare p zdigits with
-    | Eq => w_WW xl yh 
+    | Eq => w_WW xl yh
     | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh)
     | Gt =>
       let n := low (ww_sub p zdigits) in
@@ -93,7 +93,7 @@ Section DoubleLift.
 
  Section DoubleProof.
   Variable w_to_Z : w -> Z.
- 
+
   Notation wB  := (base w_digits).
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
@@ -122,21 +122,21 @@ Section DoubleLift.
   Variable spec_w_head0  : forall x,  0 < [|x|] ->
 	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB.
   Variable spec_w_tail00  : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits.
-  Variable spec_w_tail0 : forall x, 0 < [|x|] -> 
+  Variable spec_w_tail0 : forall x, 0 < [|x|] ->
          exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]).
   Variable spec_w_add_mul_div : forall x y p,
        [|p|] <= Zpos w_digits ->
        [| w_add_mul_div p x y |] =
          ([|x|] * (2 ^ [|p|]) +
           [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB.
- Variable spec_w_add: forall x y, 
+ Variable spec_w_add: forall x y,
    [[w_add x y]] = [|x|] + [|y|].
- Variable spec_ww_sub: forall x y, 
+ Variable spec_ww_sub: forall x y,
    [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
 
  Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits.
  Variable spec_low: forall x, [| low x|] = [[x]] mod wB.
- 
+
  Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits.
 
   Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift.
@@ -168,7 +168,7 @@ Section DoubleLift.
   rewrite spec_w_0; auto with zarith.
   rewrite spec_w_0; auto with zarith.
   Qed.
-   
+
   Lemma spec_ww_head0  : forall x,  0 < [[x]] ->
 	 wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB.
   Proof.
@@ -179,7 +179,7 @@ Section DoubleLift.
    assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0.
    destruct (w_compare w_0 xh).
    rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H.
-   case (spec_to_Z w_zdigits); 
+   case (spec_to_Z w_zdigits);
      case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4.
    rewrite spec_w_add.
    rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
@@ -209,7 +209,7 @@ Section DoubleLift.
    rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith.
    rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith.
    apply Zmult_lt_reg_r with (2 ^ p); zarith.
-   rewrite <- Zpower_exp;zarith. 
+   rewrite <- Zpower_exp;zarith.
    rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith.
    assert (H1 := spec_to_Z xh);zarith.
   Qed.
@@ -293,8 +293,8 @@ Section DoubleLift.
   Qed.
 
   Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r
-    spec_w_W0 spec_w_0W spec_w_WW spec_w_0  
-    (wB_div w_digits w_to_Z spec_to_Z) 
+    spec_w_W0 spec_w_0W spec_w_WW spec_w_0
+    (wB_div w_digits w_to_Z spec_to_Z)
     (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite.
   Ltac w_rewrite := autorewrite with w_rewrite;trivial.
 
@@ -303,12 +303,12 @@ Section DoubleLift.
     [[p]] <= Zpos (xO w_digits) ->
       [[match ww_compare p zdigits with
         | Eq => w_WW xl yh
-        | Lt => w_WW (w_add_mul_div (low p) xh xl) 
+        | Lt => w_WW (w_add_mul_div (low p) xh xl)
                      (w_add_mul_div (low p) xl yh)
         | Gt =>
               let n := low (ww_sub p zdigits) in
             w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
-        end]] =  
+        end]] =
       ([[WW xh xl]] * (2^[[p]]) +
        [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
   Proof.
@@ -317,7 +317,7 @@ Section DoubleLift.
    case (spec_to_w_Z p); intros Hv1 Hv2.
    replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits).
    2 : rewrite Zpos_xO;ring.
-   replace (Zpos w_digits + Zpos w_digits - [[p]]) with 
+   replace (Zpos w_digits + Zpos w_digits - [[p]]) with
      (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring.
    intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl);
    assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl));
@@ -330,7 +330,7 @@ Section DoubleLift.
    fold wB.
    rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc.
    rewrite <- Zpower_2.
-   rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. 
+   rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|].
    exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring.
    simpl ww_to_Z; w_rewrite;zarith.
    assert (HH0: [|low p|] = [[p]]).
@@ -353,7 +353,7 @@ Section DoubleLift.
    rewrite Zmult_plus_distr_l.
    pattern ([|xl|] * 2 ^ [[p]]) at 2;
    rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith.
-   replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. 
+   replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring.
    rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc.
    unfold base at 5;rewrite <- Zmod_shift_r;zarith.
    unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
@@ -387,8 +387,8 @@ Section DoubleLift.
    lazy zeta; simpl ww_to_Z; w_rewrite;zarith.
    repeat rewrite spec_w_add_mul_div;zarith.
    rewrite HH0.
-   pattern wB at 5;replace wB with 
-    (2^(([[p]] - Zpos w_digits) 
+   pattern wB at 5;replace wB with
+    (2^(([[p]] - Zpos w_digits)
          + (Zpos w_digits - ([[p]] - Zpos w_digits)))).
    rewrite Zpower_exp;zarith. rewrite Zmult_assoc.
    rewrite Z_div_plus_l;zarith.
@@ -401,28 +401,28 @@ Section DoubleLift.
    repeat rewrite <- Zplus_assoc.
    unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
    fold wB;fold wwB;zarith.
-   unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) 
+   unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits)
    (b:= Zpos w_digits);fold wB;fold wwB;zarith.
    rewrite wwB_wBwB; rewrite Zpower_2; rewrite  Zmult_mod_distr_r;zarith.
    rewrite Zmult_plus_distr_l.
-   replace ([|xh|] * wB * 2 ^ u) with 
+   replace ([|xh|] * wB * 2 ^ u) with
      ([|xh|]*2^u*wB). 2:ring.
-   repeat rewrite <- Zplus_assoc. 
+   repeat rewrite <- Zplus_assoc.
    rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)).
    rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith.
    unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
-   unfold u; split;zarith. 
+   unfold u; split;zarith.
    split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith.
    rewrite <- Zpower_exp;zarith.
-   fold u. 
-   ring_simplify (u + (Zpos w_digits - u)); fold 
+   fold u.
+   ring_simplify (u + (Zpos w_digits - u)); fold
    wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith.
    unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
    unfold u; split;zarith.
    unfold u; split;zarith.
    apply Zdiv_lt_upper_bound;zarith.
    rewrite <- Zpower_exp;zarith.
-   fold u. 
+   fold u.
    ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
    unfold u;zarith.
    unfold u;zarith.
@@ -446,7 +446,7 @@ Section DoubleLift.
     clear H1;w_rewrite);simpl ww_add_mul_div.
    replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
    intros Heq;rewrite <- Heq;clear Heq; auto.
-   generalize (spec_ww_compare p (w_0W w_zdigits)); 
+   generalize (spec_ww_compare p (w_0W w_zdigits));
      case ww_compare; intros H1; w_rewrite.
    rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
    generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1.
@@ -459,7 +459,7 @@ Section DoubleLift.
    rewrite HH0; auto with zarith.
    replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
    intros Heq;rewrite <- Heq;clear Heq.
-   generalize (spec_ww_compare p (w_0W w_zdigits)); 
+   generalize (spec_ww_compare p (w_0W w_zdigits));
      case ww_compare; intros H1; w_rewrite.
    rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
    rewrite Zpos_xO in H;zarith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
index c7d83acc..7090c76a 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleMul.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -17,7 +17,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section DoubleMul.
  Variable w : Type.
@@ -45,7 +45,7 @@ Section DoubleMul.
  (*   (xh*B+xl) (yh*B + yl)
    xh*yh         = hh  = |hhh|hhl|B2
    xh*yl +xl*yh  = cc  =     |cch|ccl|B
-   xl*yl         = ll  =         |llh|lll 
+   xl*yl         = ll  =         |llh|lll
   *)
 
  Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y :=
@@ -56,7 +56,7 @@ Section DoubleMul.
     let hh := w_mul_c xh yh in
     let ll := w_mul_c xl yl in
     let (wc,cc) := cross xh xl yh yl hh ll in
-    match cc with 
+    match cc with
     | W0 => WW (ww_add hh (w_W0 wc)) ll
     | WW cch ccl =>
       match ww_add_c (w_W0 ccl) ll with
@@ -67,8 +67,8 @@ Section DoubleMul.
   end.
 
  Definition ww_mul_c :=
-  double_mul_c 
-    (fun xh xl yh yl hh ll=> 
+  double_mul_c
+    (fun xh xl yh yl hh ll=>
       match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with
       | C0 cc => (w_0, cc)
       | C1 cc => (w_1, cc)
@@ -77,11 +77,11 @@ Section DoubleMul.
  Definition w_2 := w_add w_1 w_1.
 
  Definition kara_prod xh xl yh yl hh ll :=
-    match ww_add_c hh ll with 
+    match ww_add_c hh ll with
       C0 m =>
          match w_compare xl xh with
            Eq => (w_0, m)
-         | Lt => 
+         | Lt =>
            match w_compare yl yh with
              Eq => (w_0, m)
            | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl)))
@@ -89,7 +89,7 @@ Section DoubleMul.
                       C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1)
                    end
            end
-         | Gt => 
+         | Gt =>
            match w_compare yl yh with
              Eq => (w_0, m)
            | Lt => match ww_add_c m (w_mul_c (w_sub xl xh)  (w_sub yh yl)) with
@@ -101,17 +101,17 @@ Section DoubleMul.
     | C1 m =>
          match w_compare xl xh with
            Eq => (w_1, m)
-         | Lt => 
+         | Lt =>
            match w_compare yl yh with
              Eq => (w_1, m)
            | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with
                     C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1)
-                   end 
+                   end
            | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with
                       C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1)
                    end
            end
-         | Gt => 
+         | Gt =>
            match w_compare yl yh with
              Eq => (w_1, m)
            | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with
@@ -129,8 +129,8 @@ Section DoubleMul.
  Definition ww_mul x y :=
   match x, y with
   | W0, _ => W0
-  | _, W0 => W0  
-  | WW xh xl, WW yh yl => 
+  | _, W0 => W0
+  | WW xh xl, WW yh yl =>
     let ccl := w_add (w_mul xh yl) (w_mul xl yh) in
     ww_add (w_W0 ccl) (w_mul_c xl yl)
   end.
@@ -161,9 +161,9 @@ Section DoubleMul.
   Variable w_mul_add : w -> w -> w -> w * w.
 
   Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n :=
-   match n return word w n -> w -> w -> w * word w n with 
-   | O => w_mul_add 
-   | S n1 => 
+   match n return word w n -> w -> w -> w * word w n with
+   | O => w_mul_add
+   | S n1 =>
      let mul_add := double_mul_add_n1 n1 in
      fun x y r =>
      match x with
@@ -183,11 +183,11 @@ Section DoubleMul.
   Variable wn_0W : wn -> zn2z wn.
   Variable wn_WW : wn -> wn -> zn2z wn.
   Variable w_mul_add_n1 : wn -> w -> w -> w*wn.
-  Fixpoint double_mul_add_mn1 (m:nat) : 
+  Fixpoint double_mul_add_mn1 (m:nat) :
 	word wn m -> w -> w -> w*word wn m :=
-   match m return word wn m -> w -> w -> w*word wn m with 
-   | O => w_mul_add_n1 
-   | S m1 => 
+   match m return word wn m -> w -> w -> w*word wn m with
+   | O => w_mul_add_n1
+   | S m1 =>
      let mul_add := double_mul_add_mn1 m1 in
      fun x y r =>
      match x with
@@ -207,11 +207,11 @@ Section DoubleMul.
   | WW h l =>
     match w_add_c l r with
     | C0 lr => (h,lr)
-    | C1 lr => (w_succ h, lr) 
+    | C1 lr => (w_succ h, lr)
     end
   end.
 
-  
+
  (*Section DoubleProof. *)
   Variable w_digits : positive.
   Variable w_to_Z : w -> Z.
@@ -225,11 +225,11 @@ Section DoubleMul.
    (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
-  Notation "[+[ c ]]" := 
-   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[+[ c ]]" :=
+   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
-   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[-[ c ]]" :=
+   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
 
   Notation "[|| x ||]" :=
@@ -269,8 +269,8 @@ Section DoubleMul.
 	 forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB.
   Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
   Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].
- 
- 
+
+
   Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB.
   Proof. intros x;apply spec_ww_to_Z;auto. Qed.
 
@@ -281,21 +281,21 @@ Section DoubleMul.
   Ltac zarith := auto with zarith mult.
 
   Lemma wBwB_lex: forall a b c d,
-      a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> 
+      a * wB^2 + [[b]] <= c * wB^2 + [[d]] ->
       a <= c.
-  Proof.   
+  Proof.
    intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith.
   Qed.
 
-  Lemma wBwB_lex_inv: forall a b c d, 
-      a < c -> 
-      a * wB^2 + [[b]] < c * wB^2 + [[d]]. 
+  Lemma wBwB_lex_inv: forall a b c d,
+      a < c ->
+      a * wB^2 + [[b]] < c * wB^2 + [[d]].
   Proof.
    intros a b c d H; apply beta_lex_inv; zarith.
   Qed.
 
   Lemma sum_mul_carry : forall xh xl yh yl wc cc,
-   [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> 
+   [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] ->
    0 <= [|wc|] <= 1.
   Proof.
    intros.
@@ -303,14 +303,14 @@ Section DoubleMul.
    apply wB_pos.
   Qed.
 
-  Theorem mult_add_ineq: forall xH yH crossH, 
+  Theorem mult_add_ineq: forall xH yH crossH,
                0 <= [|xH|] * [|yH|] + [|crossH|] < wwB.
   Proof.
    intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith.
   Qed.
- 
+
   Hint Resolve mult_add_ineq : mult.
- 
+
   Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll,
    [[hh]] = [|xh|] * [|yh|] ->
    [[ll]] = [|xl|] * [|yl|] ->
@@ -325,9 +325,9 @@ Section DoubleMul.
       end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]).
   Proof.
    intros;assert (U1 := wB_pos w_digits).
-   replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with 
+   replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with
    ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]).
-   2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0.  
+   2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0.
    assert (H2 := sum_mul_carry _ _ _ _ _ _ H1).
    destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z.
    rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small;
@@ -346,7 +346,7 @@ Section DoubleMul.
      rewrite <- Zmult_plus_distr_l.
     assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB).
      apply Zmult_le_compat;zarith.
-    rewrite Zmult_plus_distr_l in H3. 
+    rewrite Zmult_plus_distr_l in H3.
     intros. assert (U2 := spec_to_Z ccl);omega.
    generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll)
    as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l;
@@ -363,8 +363,8 @@ Section DoubleMul.
      (forall xh xl yh yl hh ll,
         [[hh]] = [|xh|]*[|yh|] ->
         [[ll]] = [|xl|]*[|yl|] ->
-        let (wc,cc) :=  cross xh xl yh yl hh ll in 
-        [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> 
+        let (wc,cc) :=  cross xh xl yh yl hh ll in
+        [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) ->
      forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]].
   Proof.
    intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial.
@@ -376,7 +376,7 @@ Section DoubleMul.
    rewrite <- wwB_wBwB;trivial.
   Qed.
 
-  Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. 
+  Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]].
   Proof.
    intros x y;unfold ww_mul_c;apply spec_double_mul_c.
    intros xh xl yh yl hh ll H1 H2.
@@ -402,9 +402,9 @@ Section DoubleMul.
    let (wc,cc) := kara_prod xh xl yh yl hh ll in
    [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|].
   Proof.
-   intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; 
+   intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux;
      rewrite <- H; rewrite <- H0; unfold kara_prod.
-   assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); 
+   assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl));
      assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)).
    generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll);
      intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)).
@@ -412,7 +412,7 @@ Section DoubleMul.
     try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail).
    generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh.
    rewrite Hylh; rewrite spec_w_0; try (ring; fail).
-   rewrite spec_w_0; try (ring; fail). 
+   rewrite spec_w_0; try (ring; fail).
    repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
    split; auto with zarith.
@@ -508,8 +508,8 @@ Section DoubleMul.
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   Qed.
 
-  Lemma sub_carry : forall xh xl yh yl z, 
-    0 <= z -> 
+  Lemma sub_carry : forall xh xl yh yl z,
+    0 <= z ->
     [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z ->
     z < wwB.
   Proof.
@@ -519,7 +519,7 @@ Section DoubleMul.
    generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)).
    rewrite <- wwB_wBwB;intros H1 H2.
    assert (H3 := wB_pos w_digits).
-   assert (2*wB <= wwB). 
+   assert (2*wB <= wwB).
     rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith.
    omega.
   Qed.
@@ -528,7 +528,7 @@ Section DoubleMul.
    let H:= fresh "H" in
    assert (H:= spec_ww_to_Z x).
 
-  Ltac Zmult_lt_b x y := 
+  Ltac Zmult_lt_b x y :=
    let H := fresh "H" in
    assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)).
 
@@ -582,7 +582,7 @@ Section DoubleMul.
    Variable w_mul_add : w -> w -> w -> w * w.
    Variable spec_w_mul_add : forall x y r,
     let (h,l):= w_mul_add x y r in
-    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. 
+    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|].
 
    Lemma spec_double_mul_add_n1 : forall n x y r,
      let (h,l) := double_mul_add_n1 w_mul_add n x y r in
@@ -590,7 +590,7 @@ Section DoubleMul.
    Proof.
     induction n;intros x y r;trivial.
     exact (spec_w_mul_add x y r).
-    unfold double_mul_add_n1;destruct x as[ |xh xl]; 
+    unfold double_mul_add_n1;destruct x as[ |xh xl];
      fold(double_mul_add_n1 w_mul_add).
     rewrite spec_w_0;rewrite spec_extend;simpl;trivial.
     assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l).
@@ -599,13 +599,13 @@ Section DoubleMul.
     rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H.
     rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
     rewrite U;ring.
-   Qed. 
- 
+   Qed.
+
   End DoubleMulAddn1Proof.
 
-  Lemma spec_w_mul_add : forall x y r, 
+  Lemma spec_w_mul_add : forall x y r,
     let (h,l):= w_mul_add x y r in
-    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. 
+    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|].
   Proof.
    intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y);
    destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
index 043ff351..83a2e717 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleSqrt.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -17,7 +17,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section DoubleSqrt.
  Variable w              : Type.
@@ -52,7 +52,7 @@ Section DoubleSqrt.
 
  Let wwBm1 := ww_Bm1 w_Bm1.
 
- Definition ww_is_even x := 
+ Definition ww_is_even x :=
    match x with
    | W0 => true
    | WW xh xl => w_is_even xl
@@ -62,7 +62,7 @@ Section DoubleSqrt.
    match w_compare x z with
    | Eq =>
       match w_compare y z with
-        Eq => (C1 w_1, w_0) 
+        Eq => (C1 w_1, w_0)
       | Gt => (C1 w_1, w_sub y z)
       | Lt => (C1 w_0, y)
       end
@@ -120,7 +120,7 @@ Section DoubleSqrt.
    let ( q, r)  := w_sqrt2 x1 x2 in
    let (q1, r1) := w_div2s r y1 q in
    match q1 with
-     C0 q1 => 
+     C0 q1 =>
       let q2 := w_square_c q1 in
       let a  := WW q q1 in
         match r1 with
@@ -132,9 +132,9 @@ Section DoubleSqrt.
         | C0 r2 =>
            match ww_sub_c (WW r2 y2) q2 with
              C0 r3 => (a, C0 r3)
-           | C1 r3 => 
+           | C1 r3 =>
               let a2 := ww_add_mul_div (w_0W w_1) a W0 in
-              match ww_pred_c a2 with 
+              match ww_pred_c a2 with
                 C0 a3 =>
                   (ww_pred a, ww_add_c a3 r3)
               | C1 a3 =>
@@ -166,20 +166,20 @@ Section DoubleSqrt.
     | Gt =>
         match ww_add_mul_div p x W0 with
          W0 => W0
-       | WW x1 x2 => 
+       | WW x1 x2 =>
           let (r, _) := w_sqrt2 x1 x2 in
-            WW w_0 (w_add_mul_div 
-                     (w_sub w_zdigits 
+            WW w_0 (w_add_mul_div
+                     (w_sub w_zdigits
                      (low (ww_add_mul_div (ww_pred ww_zdigits)
                               W0 p))) w_0 r)
         end
-     | _ => 
+     | _ =>
         match x with
           W0 => W0
         | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2))
         end
     end.
-          
+
 
   Variable w_to_Z : w -> Z.
 
@@ -192,11 +192,11 @@ Section DoubleSqrt.
    (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
-  Notation "[+[ c ]]" := 
-   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[+[ c ]]" :=
+   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
-   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[-[ c ]]" :=
+   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
 
   Notation "[|| x ||]" :=
@@ -269,14 +269,12 @@ Section DoubleSqrt.
  Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1.
  Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed.
 
- 
- Hint Rewrite spec_w_0 spec_w_1 w_Bm1 spec_w_WW spec_w_sub 
-              spec_w_div21 spec_w_add_mul_div spec_ww_Bm1
-              spec_w_add_c spec_w_sqrt2: w_rewrite.
+ Hint Rewrite spec_w_0 spec_w_1 spec_w_WW spec_w_sub
+   spec_w_add_mul_div spec_ww_Bm1 spec_w_add_c : w_rewrite.
 
  Lemma spec_ww_is_even : forall x,
       if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1.
-clear spec_more_than_1_digit. 
+clear spec_more_than_1_digit.
 intros x; case x; simpl ww_is_even.
  simpl.
  rewrite Zmod_small; auto with zarith.
@@ -379,8 +377,8 @@ intros x; case x; simpl ww_is_even.
  end.
  rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith.
  destruct (spec_to_Z w1) as [H1 H2];auto with zarith.
- split; auto with zarith. 
- apply Zdiv_lt_upper_bound; auto with zarith.  
+ split; auto with zarith.
+ apply Zdiv_lt_upper_bound; auto with zarith.
  rewrite Hp; ring.
  Qed.
 
@@ -402,7 +400,7 @@ intros x; case x; simpl ww_is_even.
  rewrite Zmax_right; auto with zarith.
  rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith.
  destruct (spec_to_Z w1) as [H1 H2];auto with zarith.
- split; auto with zarith. 
+ split; auto with zarith.
  unfold base.
  match goal with |- _ < _ ^ ?X =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
@@ -434,7 +432,7 @@ intros x; case x; simpl ww_is_even.
  intros w1.
  rewrite spec_ww_add_mul_div; auto with zarith.
  autorewrite with w_rewrite rm10.
- rewrite spec_w_0W; rewrite spec_w_1. 
+ rewrite spec_w_0W; rewrite spec_w_1.
  rewrite Zpower_1_r; auto with zarith.
  rewrite Zmult_comm; auto.
  rewrite spec_w_0W; rewrite spec_w_1; auto with zarith.
@@ -458,7 +456,7 @@ intros x; case x; simpl ww_is_even.
  match goal with  |- 0 <= ?X - 1 =>
    assert (0 < X); auto with zarith
  end.
- apply Zpower_gt_0; auto with zarith. 
+ apply Zpower_gt_0; auto with zarith.
  match goal with  |- 0 <= ?X - 1 =>
    assert (0 < X); auto with zarith; red; reflexivity
  end.
@@ -542,7 +540,7 @@ intros x; case x; simpl ww_is_even.
  rewrite add_mult_div_2_plus_1; unfold base.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
-  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; 
+  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
   try rewrite Zpower_1_r; auto with zarith
  end.
  rewrite Zpos_minus; auto with zarith.
@@ -559,7 +557,7 @@ intros x; case x; simpl ww_is_even.
  unfold base.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
-  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; 
+  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
   try rewrite Zpower_1_r; auto with zarith
  end.
  rewrite Zpos_minus; auto with zarith.
@@ -592,7 +590,7 @@ intros x; case x; simpl ww_is_even.
  rewrite H1; unfold base.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
-  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; 
+  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
   try rewrite Zpower_1_r; auto with zarith
  end.
  rewrite Zpos_minus; auto with zarith.
@@ -611,7 +609,7 @@ intros x; case x; simpl ww_is_even.
  rewrite H1; unfold base.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
-  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; 
+  rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
   try rewrite Zpower_1_r; auto with zarith
  end.
  rewrite Zpos_minus; auto with zarith.
@@ -682,7 +680,7 @@ intros x; case x; simpl ww_is_even.
  rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring.
  apply Zmult_le_0_compat; auto with zarith.
  Qed.
- 
+
  Lemma spec_split: forall x,
   [|fst (split x)|] * wB + [|snd (split x)|] = [[x]].
  intros x; case x; simpl; autorewrite with w_rewrite;
@@ -751,7 +749,7 @@ intros x; case x; simpl ww_is_even.
  match goal with |- ?X <= ?Y =>
   replace Y with (2 * (wB/ 2 - 1)); auto with zarith
  end.
- pattern wB at 2; rewrite <- wB_div_2; auto with zarith. 
+ pattern wB at 2; rewrite <- wB_div_2; auto with zarith.
  match type of H1 with ?X = _ =>
   assert (U5: X < wB / 4 * wB)
  end.
@@ -764,9 +762,9 @@ intros x; case x; simpl ww_is_even.
  destruct (spec_to_Z w3);auto with zarith.
  generalize (@spec_w_div2s c w0 w4 U1 H2).
  case (w_div2s c w0 w4).
- intros c0; case c0; intros w5;  
+ intros c0; case c0; intros w5;
    repeat (rewrite C0_id || rewrite C1_plus_wB).
- intros c1; case c1; intros w6;  
+ intros c1; case c1; intros w6;
    repeat (rewrite C0_id || rewrite C1_plus_wB).
  intros (H3, H4).
  match goal with |- context [ww_sub_c ?y ?z] =>
@@ -1038,7 +1036,7 @@ intros x; case x; simpl ww_is_even.
  end.
  apply Zle_not_lt; rewrite <- H3; auto with zarith.
  rewrite Zmult_plus_distr_l.
- apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); 
+ apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0);
   auto with zarith.
  apply beta_lex_inv; auto with zarith.
  destruct (spec_to_Z w0);auto with zarith.
@@ -1119,9 +1117,9 @@ intros x; case x; simpl ww_is_even.
    auto with zarith.
   simpl ww_to_Z.
   assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith.
-  Qed. 
-  
-  Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. 
+  Qed.
+
+  Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2.
   pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2.
   rewrite <- wB_div_2.
   match goal with |- context[(2 * ?X) * (2 * ?Z)] =>
@@ -1134,7 +1132,7 @@ intros x; case x; simpl ww_is_even.
 
 
   Lemma spec_ww_head1
-       : forall x : zn2z w, 
+       : forall x : zn2z w,
          (ww_is_even (ww_head1 x) = true) /\
          (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB).
   assert (U := wB_pos w_digits).
@@ -1167,7 +1165,7 @@ intros x; case x; simpl ww_is_even.
     rewrite Hp.
     rewrite Zminus_mod; auto with zarith.
     rewrite H2; repeat rewrite Zmod_small; auto with zarith.
-  intros H3; rewrite Hp.  
+  intros H3; rewrite Hp.
   case (spec_ww_head0 x); auto; intros Hv3 Hv4.
   assert (Hu: forall u, 0 < u -> 2 *  2 ^ (u - 1) = 2 ^u).
     intros u Hu.
@@ -1189,7 +1187,7 @@ intros x; case x; simpl ww_is_even.
   apply sym_equal; apply Zdiv_unique with 0;
     auto with zarith.
   rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith.
-  rewrite wwB_wBwB; ring. 
+  rewrite wwB_wBwB; ring.
   Qed.
 
   Lemma spec_ww_sqrt : forall x,
@@ -1198,14 +1196,14 @@ intros x; case x; simpl ww_is_even.
   intro x; unfold ww_sqrt.
   generalize (spec_ww_is_zero x); case (ww_is_zero x).
   simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl;
-    auto with zarith. 
+    auto with zarith.
   intros H1.
   generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare;
     simpl ww_to_Z; autorewrite with rm10.
   generalize H1; case x.
   intros HH; contradict HH; simpl ww_to_Z; auto with zarith.
   intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10.
-  intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5.  
+  intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5.
   generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10.
   intros (H4, H5).
   assert (V: wB/4 <= [|w0|]).
@@ -1241,7 +1239,7 @@ intros x; case x; simpl ww_is_even.
     apply Zle_not_lt; unfold base.
     apply Zle_trans with (2 ^ [[ww_head1 x]]).
       apply Zpower_le_monotone; auto with zarith.
-    pattern (2 ^ [[ww_head1 x]]) at 1; 
+    pattern (2 ^ [[ww_head1 x]]) at 1;
       rewrite <- (Zmult_1_r (2 ^ [[ww_head1 x]])).
     apply Zmult_le_compat_l; auto with zarith.
   generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2);
@@ -1283,13 +1281,13 @@ intros x; case x; simpl ww_is_even.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Zlt_le_trans with (Zpos (xO w_digits)); auto with zarith.
-    unfold base; apply Zpower2_le_lin; auto with zarith.  
+    unfold base; apply Zpower2_le_lin; auto with zarith.
   assert (Hv4: [[ww_head1 x]]/2 < wB).
     apply Zle_lt_trans with (Zpos w_digits).
     apply Zmult_le_reg_r with 2; auto with zarith.
     repeat rewrite (fun x => Zmult_comm x 2).
     rewrite <- Hv0;  rewrite <- Zpos_xO; auto.
-    unfold base; apply Zpower2_lt_lin; auto with zarith. 
+    unfold base; apply Zpower2_lt_lin; auto with zarith.
   assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]]
                  = [[ww_head1 x]]/2).
     rewrite spec_ww_add_mul_div.
@@ -1330,14 +1328,14 @@ intros x; case x; simpl ww_is_even.
    rewrite tmp; clear tmp.
   apply Zpower_le_monotone3; auto with zarith.
   split; auto with zarith.
-  pattern [|w2|] at 2; 
+  pattern [|w2|] at 2;
      rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2)));
      auto with zarith.
   match goal with |- ?X <= ?X + ?Y =>
     assert (0 <= Y); auto with zarith
   end.
   case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith.
-  case c; unfold interp_carry; autorewrite with rm10; 
+  case c; unfold interp_carry; autorewrite with rm10;
     intros w3; assert (V3 := spec_to_Z w3);auto with zarith.
   apply Zmult_lt_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith.
   rewrite H4.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
index 269d62bb..a7e55671 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleSub.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
@@ -17,7 +17,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import DoubleBase.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section DoubleSub.
  Variable w : Type.
@@ -39,7 +39,7 @@ Section DoubleSub.
  Definition ww_opp_c x :=
   match x with
   | W0 => C0 W0
-  | WW xh xl => 
+  | WW xh xl =>
     match w_opp_c xl with
     | C0 _ =>
       match w_opp_c xh with
@@ -53,7 +53,7 @@ Section DoubleSub.
  Definition ww_opp x :=
   match x with
   | W0 => W0
-  | WW xh xl => 
+  | WW xh xl =>
     match w_opp_c xl with
     | C0 _ => WW (w_opp xh) w_0
     | C1 l => WW (w_opp_carry xh) l
@@ -72,14 +72,14 @@ Section DoubleSub.
   | WW xh xl =>
     match w_pred_c xl with
     | C0 l => C0 (w_WW xh l)
-    | C1 _ => 
-      match w_pred_c xh with 
+    | C1 _ =>
+      match w_pred_c xh with
       | C0 h => C0 (WW h w_Bm1)
       | C1 _ => C1 ww_Bm1
       end
     end
   end.
- 
+
  Definition ww_pred x :=
   match x with
   | W0 => ww_Bm1
@@ -89,19 +89,19 @@ Section DoubleSub.
     | C1 l => WW (w_pred xh) w_Bm1
     end
   end.
-     
+
  Definition ww_sub_c x y :=
   match y, x with
   | W0, _ => C0 x
   | WW yh yl, W0 => ww_opp_c (WW yh yl)
   | WW yh yl, WW xh xl =>
     match w_sub_c xl yl with
-    | C0 l => 
+    | C0 l =>
       match w_sub_c xh yh with
       | C0 h => C0 (w_WW h l)
       | C1 h => C1 (WW h l)
       end
-    | C1 l => 
+    | C1 l =>
       match w_sub_carry_c xh yh with
       | C0 h => C0 (WW h l)
       | C1 h => C1 (WW h l)
@@ -109,7 +109,7 @@ Section DoubleSub.
     end
   end.
 
- Definition ww_sub x y := 
+ Definition ww_sub x y :=
   match y, x with
   | W0, _ => x
   | WW yh yl, W0 => ww_opp (WW yh yl)
@@ -127,7 +127,7 @@ Section DoubleSub.
   | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl))
   | WW yh yl, WW xh xl =>
     match w_sub_carry_c xl yl with
-    | C0 l => 
+    | C0 l =>
       match w_sub_c xh yh with
       | C0 h => C0 (w_WW h l)
       | C1 h => C1 (WW h l)
@@ -155,7 +155,7 @@ Section DoubleSub.
  (*Section DoubleProof.*)
   Variable w_digits : positive.
   Variable w_to_Z : w -> Z.
- 
+
 
   Notation wB  := (base w_digits).
   Notation wwB := (base (ww_digits w_digits)).
@@ -166,13 +166,13 @@ Section DoubleSub.
    (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
-  Notation "[+[ c ]]" := 
-   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[+[ c ]]" :=
+   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
-  Notation "[-[ c ]]" := 
-   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) 
+  Notation "[-[ c ]]" :=
+   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
    (at level 0, x at level 99).
-  
+
   Variable spec_w_0   : [|w_0|] = 0.
   Variable spec_w_Bm1   : [|w_Bm1|] = wB - 1.
   Variable spec_ww_Bm1   : [[ww_Bm1]] = wwB - 1.
@@ -187,7 +187,7 @@ Section DoubleSub.
   Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|].
   Variable spec_sub_carry_c :
    forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1.
-  
+
   Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB.
   Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
   Variable spec_sub_carry :
@@ -197,12 +197,12 @@ Section DoubleSub.
   Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]].
   Proof.
    destruct x as [ |xh xl];simpl. reflexivity.
-   rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) 
+   rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl)
    as [l|l];intros H;unfold interp_carry in H;rewrite <- H;
-   rewrite Zopp_mult_distr_l. 
+   rewrite Zopp_mult_distr_l.
    assert ([|l|] = 0).
     assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
-   rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) 
+   rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh)
    as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1.
    assert ([|h|] = 0).
     assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega.
@@ -216,7 +216,7 @@ Section DoubleSub.
   Proof.
    destruct x as [ |xh xl];simpl. reflexivity.
    rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l.
-   generalize (spec_opp_c xl);destruct (w_opp_c xl) 
+   generalize (spec_opp_c xl);destruct (w_opp_c xl)
    as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
    rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB.
    assert ([|l|] = 0).
@@ -247,7 +247,7 @@ Section DoubleSub.
      assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
    rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1).
    generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h];
-   intros H1;unfold interp_carry in H1;rewrite <- H1.  
+   intros H1;unfold interp_carry in H1;rewrite <- H1.
    simpl;rewrite spec_w_Bm1;ring.
    assert ([|h|] = wB - 1).
      assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega.
@@ -258,14 +258,14 @@ Section DoubleSub.
   Proof.
    destruct y as [ |yh yl];simpl. ring.
    destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)).
-   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) 
+   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
    with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring.
    generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H;
    unfold interp_carry in H;rewrite <- H.
    generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
    unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
    try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. 
+   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
    change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
    generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
    intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z;
@@ -275,37 +275,37 @@ Section DoubleSub.
   Lemma spec_ww_sub_carry_c :
      forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1.
   Proof.
-   destruct y as [ |yh yl];simpl. 
+   destruct y as [ |yh yl];simpl.
    unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x).
    destruct x as [ |xh xl].
    unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB;
    repeat rewrite spec_opp_carry;ring.
    simpl ww_to_Z.
-   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) 
+   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
    with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring.
-   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) 
+   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)
    as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
    generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
    unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
    try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. 
+   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
    change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
    generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
    intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW;
    simpl ww_to_Z; try rewrite wwB_wBwB;ring.
-  Qed.  
-  
+  Qed.
+
   Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB.
   Proof.
-   destruct x as [ |xh xl];simpl. 
+   destruct x as [ |xh xl];simpl.
    apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial.
    rewrite spec_ww_Bm1;ring.
    replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring.
    generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H;
    unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
-   rewrite Zmod_small. apply spec_w_WW. 
+   rewrite Zmod_small. apply spec_w_WW.
    exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)).
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. 
+   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
    change ([|xh|] + -1) with ([|xh|] - 1).
    assert ([|l|] = wB - 1).
     assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega.
@@ -318,7 +318,7 @@ Section DoubleSub.
    destruct y as [ |yh yl];simpl.
    ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
    destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)).
-   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) 
+   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
    with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring.
    generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H;
    unfold interp_carry in H;rewrite <- H.
@@ -338,7 +338,7 @@ Section DoubleSub.
    apply spec_ww_to_Z;trivial.
    fold (ww_opp_carry (WW yh yl)).
    rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring.
-   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) 
+   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
    with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring.
    generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l];
    intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW.
@@ -354,4 +354,4 @@ End DoubleSub.
 
 
 
- 
+
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
index 28d40094..88cbb484 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
@@ -8,12 +8,12 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: DoubleType.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Set Implicit Arguments.
 
 Require Import ZArith.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Definition base digits := Zpower 2 (Zpos digits).
 
@@ -37,10 +37,10 @@ Section Zn2Z.
 
  Variable znz : Type.
 
- (** From a type [znz] representing a cyclic structure Z/nZ, 
+ (** From a type [znz] representing a cyclic structure Z/nZ,
      we produce a representation of Z/2nZ by pairs of elements of [znz]
-     (plus a special case for zero). High half of the new number comes 
-     first. 
+     (plus a special case for zero). High half of the new number comes
+     first.
  *)
 
  Inductive zn2z :=
@@ -57,10 +57,10 @@ End Zn2Z.
 
 Implicit Arguments W0 [znz].
 
-(** From a cyclic representation [w], we iterate the [zn2z] construct 
-    [n] times, gaining the type of binary trees of depth at most [n], 
-    whose leafs are either W0 (if depth < n) or elements of w 
-    (if depth = n). 
+(** From a cyclic representation [w], we iterate the [zn2z] construct
+    [n] times, gaining the type of binary trees of depth at most [n],
+    whose leafs are either W0 (if depth < n) or elements of w
+    (if depth = n).
 *)
 
 Fixpoint word (w:Type) (n:nat) : Type :=
diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v
index 6da1c6ec..8addf5b9 100644
--- a/theories/Numbers/Cyclic/Int31/Cyclic31.v
+++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Cyclic31.v 11907 2009-02-10 23:54:28Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *)
 
@@ -24,8 +24,8 @@ Require Import BigNumPrelude.
 Require Import CyclicAxioms.
 Require Import ROmega.
 
-Open Scope nat_scope.
-Open Scope int31_scope.
+Local Open Scope nat_scope.
+Local Open Scope int31_scope.
 
 Section Basics.
 
@@ -34,9 +34,9 @@ Section Basics.
  Lemma iszero_eq0 : forall x, iszero x = true -> x=0.
  Proof.
  destruct x; simpl; intros.
- repeat 
-   match goal with H:(if ?d then _ else _) = true |- _ => 
-     destruct d; try discriminate 
+ repeat
+   match goal with H:(if ?d then _ else _) = true |- _ =>
+     destruct d; try discriminate
    end.
  reflexivity.
  Qed.
@@ -46,26 +46,26 @@ Section Basics.
  intros x H Eq; rewrite Eq in H; simpl in *; discriminate.
  Qed.
 
- Lemma sneakl_shiftr : forall x, 
+ Lemma sneakl_shiftr : forall x,
   x = sneakl (firstr x) (shiftr x).
  Proof.
  destruct x; simpl; auto.
  Qed.
 
- Lemma sneakr_shiftl : forall x, 
+ Lemma sneakr_shiftl : forall x,
   x = sneakr (firstl x) (shiftl x).
  Proof.
  destruct x; simpl; auto.
  Qed.
 
- Lemma twice_zero : forall x, 
+ Lemma twice_zero : forall x,
   twice x = 0 <-> twice_plus_one x = 1.
  Proof.
- destruct x; simpl in *; split; 
+ destruct x; simpl in *; split;
  intro H; injection H; intros; subst; auto.
  Qed.
 
- Lemma twice_or_twice_plus_one : forall x, 
+ Lemma twice_or_twice_plus_one : forall x,
   x = twice (shiftr x) \/ x = twice_plus_one (shiftr x).
  Proof.
  intros; case_eq (firstr x); intros.
@@ -79,13 +79,13 @@ Section Basics.
 
  Definition nshiftr n x := iter_nat n _ shiftr x.
 
- Lemma nshiftr_S : 
+ Lemma nshiftr_S :
   forall n x, nshiftr (S n) x = shiftr (nshiftr n x).
  Proof.
  reflexivity.
  Qed.
 
- Lemma nshiftr_S_tail : 
+ Lemma nshiftr_S_tail :
   forall n x, nshiftr (S n) x = nshiftr n (shiftr x).
  Proof.
  induction n; simpl; auto.
@@ -103,7 +103,7 @@ Section Basics.
  destruct x; simpl; auto.
  Qed.
 
- Lemma nshiftr_above_size : forall k x, size<=k -> 
+ Lemma nshiftr_above_size : forall k x, size<=k ->
   nshiftr k x = 0.
  Proof.
  intros.
@@ -117,13 +117,13 @@ Section Basics.
 
  Definition nshiftl n x := iter_nat n _ shiftl x.
 
- Lemma nshiftl_S : 
+ Lemma nshiftl_S :
   forall n x, nshiftl (S n) x = shiftl (nshiftl n x).
  Proof.
  reflexivity.
  Qed.
 
- Lemma nshiftl_S_tail : 
+ Lemma nshiftl_S_tail :
   forall n x, nshiftl (S n) x = nshiftl n (shiftl x).
  Proof.
  induction n; simpl; auto.
@@ -141,7 +141,7 @@ Section Basics.
  destruct x; simpl; auto.
  Qed.
 
- Lemma nshiftl_above_size : forall k x, size<=k -> 
+ Lemma nshiftl_above_size : forall k x, size<=k ->
   nshiftl k x = 0.
  Proof.
  intros.
@@ -151,27 +151,27 @@ Section Basics.
   simpl; rewrite nshiftl_S, IHn; auto.
  Qed.
 
- Lemma firstr_firstl : 
+ Lemma firstr_firstl :
   forall x, firstr x = firstl (nshiftl (pred size) x).
  Proof.
  destruct x; simpl; auto.
  Qed.
 
- Lemma firstl_firstr : 
+ Lemma firstl_firstr :
   forall x, firstl x = firstr (nshiftr (pred size) x).
  Proof.
  destruct x; simpl; auto.
  Qed.
- 
+
  (** More advanced results about [nshiftr] *)
 
- Lemma nshiftr_predsize_0_firstl : forall x, 
+ Lemma nshiftr_predsize_0_firstl : forall x,
   nshiftr (pred size) x = 0 -> firstl x = D0.
  Proof.
  destruct x; compute; intros H; injection H; intros; subst; auto.
  Qed.
 
- Lemma nshiftr_0_propagates : forall n p x, n <= p -> 
+ Lemma nshiftr_0_propagates : forall n p x, n <= p ->
   nshiftr n x = 0 -> nshiftr p x = 0.
  Proof.
  intros.
@@ -181,7 +181,7 @@ Section Basics.
  simpl; rewrite nshiftr_S; rewrite IHn0; auto.
  Qed.
 
- Lemma nshiftr_0_firstl : forall n x, n < size -> 
+ Lemma nshiftr_0_firstl : forall n x, n < size ->
   nshiftr n x = 0 -> firstl x = D0.
  Proof.
  intros.
@@ -194,8 +194,8 @@ Section Basics.
  (** Not used for the moment. Are they really useful ? *)
 
  Lemma int31_ind_sneakl : forall P : int31->Prop,
-  P 0 -> 
-  (forall x d, P x -> P (sneakl d x)) ->  
+  P 0 ->
+  (forall x d, P x -> P (sneakl d x)) ->
   forall x, P x.
  Proof.
  intros.
@@ -210,10 +210,10 @@ Section Basics.
  change x with (nshiftr (size-size) x); auto.
  Qed.
 
- Lemma int31_ind_twice : forall P : int31->Prop, 
-  P 0 -> 
-  (forall x, P x -> P (twice x)) ->  
-  (forall x, P x -> P (twice_plus_one x)) ->  
+ Lemma int31_ind_twice : forall P : int31->Prop,
+  P 0 ->
+  (forall x, P x -> P (twice x)) ->
+  (forall x, P x -> P (twice_plus_one x)) ->
   forall x, P x.
  Proof.
  induction x using int31_ind_sneakl; auto.
@@ -224,21 +224,21 @@ Section Basics.
  (** * Some generic results about [recr] *)
 
  Section Recr.
- 
+
  (** [recr] satisfies the fixpoint equation used for its definition. *)
 
  Variable (A:Type)(case0:A)(caserec:digits->int31->A->A).
- 
- Lemma recr_aux_eqn : forall n x, iszero x = false -> 
-   recr_aux (S n) A case0 caserec x = 
+
+ Lemma recr_aux_eqn : forall n x, iszero x = false ->
+   recr_aux (S n) A case0 caserec x =
    caserec (firstr x) (shiftr x) (recr_aux n A case0 caserec (shiftr x)).
  Proof.
  intros; simpl; rewrite H; auto.
  Qed.
 
- Lemma recr_aux_converges : 
+ Lemma recr_aux_converges :
   forall n p x, n <= size -> n <= p ->
-  recr_aux n A case0 caserec (nshiftr (size - n) x) = 
+  recr_aux n A case0 caserec (nshiftr (size - n) x) =
   recr_aux p A case0 caserec (nshiftr (size - n) x).
  Proof.
  induction n.
@@ -255,8 +255,8 @@ Section Basics.
  apply IHn; auto with arith.
  Qed.
 
- Lemma recr_eqn : forall x, iszero x = false -> 
-  recr A case0 caserec x = 
+ Lemma recr_eqn : forall x, iszero x = false ->
+  recr A case0 caserec x =
   caserec (firstr x) (shiftr x) (recr A case0 caserec (shiftr x)).
  Proof.
  intros.
@@ -265,11 +265,11 @@ Section Basics.
  rewrite (recr_aux_converges size (S size)); auto with arith.
  rewrite recr_aux_eqn; auto.
  Qed.
- 
- (** [recr] is usually equivalent to a variant [recrbis] 
+
+ (** [recr] is usually equivalent to a variant [recrbis]
      written without [iszero] check. *)
 
- Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) 
+ Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
  (i:int31) : A :=
   match n with
   | O => case0
@@ -277,7 +277,7 @@ Section Basics.
       let si := shiftr i in
       caserec (firstr i) si (recrbis_aux next A case0 caserec si)
   end.
- 
+
  Definition recrbis := recrbis_aux size.
 
  Hypothesis case0_caserec : caserec D0 0 case0 = case0.
@@ -291,8 +291,8 @@ Section Basics.
  replace (recrbis_aux n A case0 caserec 0) with case0; auto.
  clear H IHn; induction n; simpl; congruence.
  Qed.
- 
- Lemma recrbis_equiv : forall x, 
+
+ Lemma recrbis_equiv : forall x,
    recrbis A case0 caserec x = recr A case0 caserec x.
  Proof.
  intros; apply recrbis_aux_equiv; auto.
@@ -348,7 +348,7 @@ Section Basics.
  rewrite incr_eqn1; destruct x; simpl; auto.
  Qed.
 
- Lemma incr_twice_plus_one_firstl : 
+ Lemma incr_twice_plus_one_firstl :
   forall x, firstl x = D0 -> incr (twice_plus_one x) = twice (incr x).
  Proof.
  intros.
@@ -356,9 +356,9 @@ Section Basics.
  f_equal; f_equal.
  destruct x; simpl in *; rewrite H; auto.
  Qed.
- 
- (** The previous result is actually true even without the 
-     constraint on [firstl], but this is harder to prove 
+
+ (** The previous result is actually true even without the
+     constraint on [firstl], but this is harder to prove
      (see later). *)
 
  End Incr.
@@ -369,9 +369,9 @@ Section Basics.
 
  (** Variant of [phi] via [recrbis] *)
 
- Let Phi := fun b (_:int31) => 
+ Let Phi := fun b (_:int31) =>
        match b with D0 => Zdouble | D1 => Zdouble_plus_one end.
- 
+
  Definition phibis_aux n x := recrbis_aux n _ Z0 Phi x.
 
  Lemma phibis_aux_equiv : forall x, phibis_aux size x = phi x.
@@ -382,7 +382,7 @@ Section Basics.
 
  (** Recursive equations satisfied by [phi] *)
 
- Lemma phi_eqn1 : forall x, firstr x = D0 -> 
+ Lemma phi_eqn1 : forall x, firstr x = D0 ->
   phi x = Zdouble (phi (shiftr x)).
  Proof.
  intros.
@@ -392,7 +392,7 @@ Section Basics.
  rewrite H; auto.
  Qed.
 
- Lemma phi_eqn2 : forall x, firstr x = D1 -> 
+ Lemma phi_eqn2 : forall x, firstr x = D1 ->
   phi x = Zdouble_plus_one (phi (shiftr x)).
  Proof.
  intros.
@@ -402,7 +402,7 @@ Section Basics.
  rewrite H; auto.
  Qed.
 
- Lemma phi_twice_firstl : forall x, firstl x = D0 -> 
+ Lemma phi_twice_firstl : forall x, firstl x = D0 ->
   phi (twice x) = Zdouble (phi x).
  Proof.
  intros.
@@ -411,7 +411,7 @@ Section Basics.
  destruct x; simpl in *; rewrite H; auto.
  Qed.
 
- Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> 
+ Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 ->
   phi (twice_plus_one x) = Zdouble_plus_one (phi x).
  Proof.
  intros.
@@ -427,23 +427,23 @@ Section Basics.
  Lemma phibis_aux_pos : forall n x, (0 <= phibis_aux n x)%Z.
  Proof.
  induction n.
- simpl; unfold phibis_aux; simpl; auto with zarith. 
+ simpl; unfold phibis_aux; simpl; auto with zarith.
  intros.
- unfold phibis_aux, recrbis_aux; fold recrbis_aux; 
+ unfold phibis_aux, recrbis_aux; fold recrbis_aux;
   fold (phibis_aux n (shiftr x)).
  destruct (firstr x).
  specialize IHn with (shiftr x); rewrite Zdouble_mult; omega.
  specialize IHn with (shiftr x); rewrite Zdouble_plus_one_mult; omega.
  Qed.
 
- Lemma phibis_aux_bounded : 
-  forall n x, n <= size -> 
+ Lemma phibis_aux_bounded :
+  forall n x, n <= size ->
   (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z_of_nat n))%Z.
  Proof.
  induction n.
  simpl; unfold phibis_aux; simpl; auto with zarith.
  intros.
- unfold phibis_aux, recrbis_aux; fold recrbis_aux; 
+ unfold phibis_aux, recrbis_aux; fold recrbis_aux;
   fold (phibis_aux n (shiftr (nshiftr (size - S n) x))).
  assert (shiftr (nshiftr (size - S n) x) =  nshiftr (size-n) x).
   replace (size - n)%nat with (S (size - (S n))) by omega.
@@ -468,8 +468,8 @@ Section Basics.
  apply phibis_aux_bounded; auto.
  Qed.
 
- Lemma phibis_aux_lowerbound : 
-  forall n x, firstr (nshiftr n x) = D1 -> 
+ Lemma phibis_aux_lowerbound :
+  forall n x, firstr (nshiftr n x) = D1 ->
   (2 ^ Z_of_nat n <= phibis_aux (S n) x)%Z.
  Proof.
  induction n.
@@ -480,7 +480,7 @@ Section Basics.
 
  intros.
  remember (S n) as m.
- unfold phibis_aux, recrbis_aux; fold recrbis_aux; 
+ unfold phibis_aux, recrbis_aux; fold recrbis_aux;
   fold (phibis_aux m (shiftr x)).
  subst m.
  rewrite inj_S, Zpower_Zsucc; auto with zarith.
@@ -488,13 +488,13 @@ Section Basics.
   apply IHn.
   rewrite <- nshiftr_S_tail; auto.
  destruct (firstr x).
- change (Zdouble (phibis_aux (S n) (shiftr x))) with 
+ change (Zdouble (phibis_aux (S n) (shiftr x))) with
         (2*(phibis_aux (S n) (shiftr x)))%Z.
  omega.
  rewrite Zdouble_plus_one_mult; omega.
  Qed.
 
- Lemma phi_lowerbound : 
+ Lemma phi_lowerbound :
   forall x, firstl x = D1 -> (2^(Z_of_nat (pred size)) <= phi x)%Z.
  Proof.
  intros.
@@ -508,9 +508,9 @@ Section Basics.
 
  Section EqShiftL.
 
- (** After killing [n] bits at the left, are the numbers equal ?*) 
+ (** After killing [n] bits at the left, are the numbers equal ?*)
 
- Definition EqShiftL n x y :=  
+ Definition EqShiftL n x y :=
   nshiftl n x = nshiftl n y.
 
  Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y.
@@ -523,7 +523,7 @@ Section Basics.
  red; intros; rewrite 2 nshiftl_above_size; auto.
  Qed.
 
- Lemma EqShiftL_le : forall k k' x y, k <= k' -> 
+ Lemma EqShiftL_le : forall k k' x y, k <= k' ->
    EqShiftL k x y -> EqShiftL k' x y.
  Proof.
  unfold EqShiftL; intros.
@@ -534,18 +534,18 @@ Section Basics.
  rewrite 2 nshiftl_S; f_equal; auto.
  Qed.
 
- Lemma EqShiftL_firstr : forall k x y, k < size -> 
+ Lemma EqShiftL_firstr : forall k x y, k < size ->
   EqShiftL k x y -> firstr x = firstr y.
  Proof.
  intros.
  rewrite 2 firstr_firstl.
  f_equal.
- apply EqShiftL_le with k; auto. 
+ apply EqShiftL_le with k; auto.
  unfold size.
  auto with arith.
  Qed.
 
- Lemma EqShiftL_twice : forall k x y, 
+ Lemma EqShiftL_twice : forall k x y,
   EqShiftL k (twice x) (twice y) <-> EqShiftL (S k) x y.
  Proof.
  intros; unfold EqShiftL.
@@ -553,7 +553,7 @@ Section Basics.
  Qed.
 
  (** * From int31 to list of digits. *)
-     
+
  (** Lower (=rightmost) bits comes first. *)
 
  Definition i2l := recrbis _ nil (fun d _ rec => d::rec).
@@ -561,10 +561,10 @@ Section Basics.
  Lemma i2l_length : forall x, length (i2l x) = size.
  Proof.
  intros; reflexivity.
- Qed. 
+ Qed.
 
- Fixpoint lshiftl l x := 
-   match l with 
+ Fixpoint lshiftl l x :=
+   match l with
      | nil => x
      | d::l => sneakl d (lshiftl l x)
    end.
@@ -576,19 +576,19 @@ Section Basics.
  destruct x; compute; auto.
  Qed.
 
- Lemma i2l_sneakr : forall x d, 
+ Lemma i2l_sneakr : forall x d,
    i2l (sneakr d x) = tail (i2l x) ++ d::nil.
  Proof.
  destruct x; compute; auto.
  Qed.
 
- Lemma i2l_sneakl : forall x d, 
+ Lemma i2l_sneakl : forall x d,
    i2l (sneakl d x) = d :: removelast (i2l x).
  Proof.
  destruct x; compute; auto.
  Qed.
 
- Lemma i2l_l2i : forall l, length l = size -> 
+ Lemma i2l_l2i : forall l, length l = size ->
   i2l (l2i l) = l.
  Proof.
  repeat (destruct l as [ |? l]; [intros; discriminate | ]).
@@ -596,9 +596,9 @@ Section Basics.
  intros _; compute; auto.
  Qed.
 
- Fixpoint cstlist (A:Type)(a:A) n := 
-  match n with 
-   | O => nil 
+ Fixpoint cstlist (A:Type)(a:A) n :=
+  match n with
+   | O => nil
    | S n => a::cstlist _ a n
   end.
 
@@ -612,7 +612,7 @@ Section Basics.
   induction (i2l x); simpl; f_equal; auto.
  rewrite H0; clear H0.
  reflexivity.
- 
+
  intros.
  rewrite nshiftl_S.
  unfold shiftl; rewrite i2l_sneakl.
@@ -657,10 +657,10 @@ Section Basics.
  f_equal; auto.
  Qed.
 
- (** This equivalence allows to prove easily the following delicate 
+ (** This equivalence allows to prove easily the following delicate
      result *)
 
- Lemma EqShiftL_twice_plus_one : forall k x y, 
+ Lemma EqShiftL_twice_plus_one : forall k x y,
   EqShiftL k (twice_plus_one x) (twice_plus_one y) <-> EqShiftL (S k) x y.
  Proof.
  intros.
@@ -683,7 +683,7 @@ Section Basics.
  subst lx n; rewrite i2l_length; omega.
  Qed.
 
- Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> 
+ Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y ->
   EqShiftL (S k) (shiftr x) (shiftr y).
  Proof.
  intros.
@@ -704,41 +704,41 @@ Section Basics.
  omega.
  Qed.
 
- Lemma EqShiftL_incrbis : forall n k x y, n<=size -> 
+ Lemma EqShiftL_incrbis : forall n k x y, n<=size ->
   (n+k=S size)%nat ->
-  EqShiftL k x y -> 
+  EqShiftL k x y ->
   EqShiftL k (incrbis_aux n x) (incrbis_aux n y).
  Proof.
  induction n; simpl; intros.
  red; auto.
- destruct (eq_nat_dec k size). 
+ destruct (eq_nat_dec k size).
   subst k; apply EqShiftL_size; auto.
- unfold incrbis_aux; simpl; 
+ unfold incrbis_aux; simpl;
   fold (incrbis_aux n (shiftr x)); fold (incrbis_aux n (shiftr y)).
 
  rewrite (EqShiftL_firstr k x y); auto; try omega.
  case_eq (firstr y); intros.
  rewrite EqShiftL_twice_plus_one.
  apply EqShiftL_shiftr; auto.
- 
+
  rewrite EqShiftL_twice.
  apply IHn; try omega.
  apply EqShiftL_shiftr; auto.
  Qed.
 
- Lemma EqShiftL_incr : forall x y, 
+ Lemma EqShiftL_incr : forall x y,
   EqShiftL 1 x y -> EqShiftL 1 (incr x) (incr y).
  Proof.
  intros.
  rewrite <- 2 incrbis_aux_equiv.
  apply EqShiftL_incrbis; auto.
  Qed.
- 
+
  End EqShiftL.
 
  (** * More equations about [incr] *)
 
- Lemma incr_twice_plus_one : 
+ Lemma incr_twice_plus_one :
   forall x, incr (twice_plus_one x) = twice (incr x).
  Proof.
  intros.
@@ -757,7 +757,7 @@ Section Basics.
  destruct (incr (shiftr x)); simpl; discriminate.
  Qed.
 
- Lemma incr_inv : forall x y, 
+ Lemma incr_inv : forall x y,
   incr x = twice_plus_one y -> x = twice y.
  Proof.
  intros.
@@ -777,7 +777,7 @@ Section Basics.
 
  (** First, recursive equations *)
 
- Lemma phi_inv_double_plus_one : forall z, 
+ Lemma phi_inv_double_plus_one : forall z,
    phi_inv (Zdouble_plus_one z) = twice_plus_one (phi_inv z).
  Proof.
  destruct z; simpl; auto.
@@ -789,14 +789,14 @@ Section Basics.
  auto.
  Qed.
 
- Lemma phi_inv_double : forall z, 
+ Lemma phi_inv_double : forall z,
    phi_inv (Zdouble z) = twice (phi_inv z).
  Proof.
  destruct z; simpl; auto.
  rewrite incr_twice_plus_one; auto.
  Qed.
 
- Lemma phi_inv_incr : forall z, 
+ Lemma phi_inv_incr : forall z,
   phi_inv (Zsucc z) = incr (phi_inv z).
  Proof.
  destruct z.
@@ -816,19 +816,19 @@ Section Basics.
  rewrite incr_twice_plus_one; auto.
  Qed.
 
- (** [phi_inv o inv], the always-exact and easy-to-prove trip : 
+ (** [phi_inv o inv], the always-exact and easy-to-prove trip :
      from int31 to Z and then back to int31. *)
 
- Lemma phi_inv_phi_aux : 
-  forall n x, n <= size -> 
-   phi_inv (phibis_aux n (nshiftr (size-n) x)) = 
+ Lemma phi_inv_phi_aux :
+  forall n x, n <= size ->
+   phi_inv (phibis_aux n (nshiftr (size-n) x)) =
    nshiftr (size-n) x.
  Proof.
  induction n.
  intros; simpl.
  rewrite nshiftr_size; auto.
  intros.
- unfold phibis_aux, recrbis_aux; fold recrbis_aux; 
+ unfold phibis_aux, recrbis_aux; fold recrbis_aux;
   fold (phibis_aux n (shiftr (nshiftr (size-S n) x))).
  assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x).
   replace (size - n)%nat with (S (size - (S n))); auto; omega.
@@ -863,10 +863,10 @@ Section Basics.
 
  (** * [positive_to_int31] *)
 
- (** A variant of [p2i] with [twice] and [twice_plus_one] instead of 
+ (** A variant of [p2i] with [twice] and [twice_plus_one] instead of
      [2*i] and [2*i+1] *)
 
- Fixpoint p2ibis n p : (N*int31)%type := 
+ Fixpoint p2ibis n p : (N*int31)%type :=
   match n with
     | O => (Npos p, On)
     | S n => match p with
@@ -876,7 +876,7 @@ Section Basics.
              end
   end.
 
- Lemma p2ibis_bounded : forall n p,  
+ Lemma p2ibis_bounded : forall n p,
   nshiftr n (snd (p2ibis n p)) = 0.
  Proof.
  induction n.
@@ -906,20 +906,20 @@ Section Basics.
  replace (shiftr In) with 0; auto.
  apply nshiftr_n_0.
  Qed.
- 
+
  Lemma p2ibis_spec : forall n p, n<=size ->
-    Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + 
+    Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) +
              phi (snd (p2ibis n p)))%Z.
  Proof.
  induction n; intros.
  simpl; rewrite Pmult_1_r; auto.
- replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by 
-  (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; 
+ replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by
+  (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat;
    auto with zarith).
  rewrite (Zmult_comm 2).
  assert (n<=size) by omega.
- destruct p; simpl; [ | | auto]; 
-  specialize (IHn p H0); 
+ destruct p; simpl; [ | | auto];
+  specialize (IHn p H0);
   generalize (p2ibis_bounded n p);
   destruct (p2ibis n p) as (r,i); simpl in *; intros.
 
@@ -937,25 +937,25 @@ Section Basics.
 
  (** We now prove that this [p2ibis] is related to [phi_inv_positive] *)
 
- Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> 
+ Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat ->
   EqShiftL (size-n) (phi_inv_positive p) (snd (p2ibis n p)).
  Proof.
  induction n.
  intros.
  apply EqShiftL_size; auto.
  intros.
- simpl p2ibis; destruct p; [ | | red; auto]; 
-  specialize IHn with p; 
-  destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; 
-  rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; 
-  replace (S (size - S n))%nat with (size - n)%nat by omega; 
+ simpl p2ibis; destruct p; [ | | red; auto];
+  specialize IHn with p;
+  destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive;
+  rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice;
+  replace (S (size - S n))%nat with (size - n)%nat by omega;
   apply IHn; omega.
  Qed.
 
  (** This gives the expected result about [phi o phi_inv], at least
      for the positive case. *)
 
- Lemma phi_phi_inv_positive : forall p, 
+ Lemma phi_phi_inv_positive : forall p,
   phi (phi_inv_positive p) = (Zpos p) mod (2^(Z_of_nat size)).
  Proof.
  intros.
@@ -975,12 +975,12 @@ Section Basics.
 
  Lemma double_twice_firstl : forall x, firstl x = D0 -> Twon*x = twice x.
  Proof.
- intros. 
+ intros.
  unfold mul31.
  rewrite <- Zdouble_mult, <- phi_twice_firstl, phi_inv_phi; auto.
  Qed.
 
- Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> 
+ Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 ->
   Twon*x+In = twice_plus_one x.
  Proof.
  intros.
@@ -989,14 +989,14 @@ Section Basics.
  rewrite phi_twice_firstl, <- Zdouble_plus_one_mult,
    <- phi_twice_plus_one_firstl, phi_inv_phi; auto.
  Qed.
- 
- Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> 
+
+ Lemma p2i_p2ibis : forall n p, (n<=size)%nat ->
   p2i n p = p2ibis n p.
  Proof.
  induction n; simpl; auto; intros.
- destruct p; auto; specialize IHn with p; 
-  generalize (p2ibis_bounded n p); 
-  rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; 
+ destruct p; auto; specialize IHn with p;
+  generalize (p2ibis_bounded n p);
+  rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros;
   f_equal; auto.
  apply double_twice_plus_one_firstl.
  apply (nshiftr_0_firstl n); auto; omega.
@@ -1004,7 +1004,7 @@ Section Basics.
  apply (nshiftr_0_firstl n); auto; omega.
  Qed.
 
- Lemma positive_to_int31_phi_inv_positive : forall p, 
+ Lemma positive_to_int31_phi_inv_positive : forall p,
    snd (positive_to_int31 p) = phi_inv_positive p.
  Proof.
  intros; unfold positive_to_int31.
@@ -1014,8 +1014,8 @@ Section Basics.
  apply (phi_inv_positive_p2ibis size); auto.
  Qed.
 
- Lemma positive_to_int31_spec : forall p, 
-    Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + 
+ Lemma positive_to_int31_spec : forall p,
+    Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) +
                phi (snd (positive_to_int31 p)))%Z.
  Proof.
  unfold positive_to_int31.
@@ -1023,11 +1023,11 @@ Section Basics.
  apply p2ibis_spec; auto.
  Qed.
 
- (** Thanks to the result about [phi o phi_inv_positive], we can 
-     now establish easily the most general results about 
+ (** Thanks to the result about [phi o phi_inv_positive], we can
+     now establish easily the most general results about
      [phi o twice] and so one. *)
- 
- Lemma phi_twice : forall x, 
+
+ Lemma phi_twice : forall x,
    phi (twice x) = (Zdouble (phi x)) mod 2^(Z_of_nat size).
  Proof.
  intros.
@@ -1041,7 +1041,7 @@ Section Basics.
  compute in H; elim H; auto.
  Qed.
 
- Lemma phi_twice_plus_one : forall x, 
+ Lemma phi_twice_plus_one : forall x,
    phi (twice_plus_one x) = (Zdouble_plus_one (phi x)) mod 2^(Z_of_nat size).
  Proof.
  intros.
@@ -1055,14 +1055,14 @@ Section Basics.
  compute in H; elim H; auto.
  Qed.
 
- Lemma phi_incr : forall x, 
+ Lemma phi_incr : forall x,
    phi (incr x) = (Zsucc (phi x)) mod 2^(Z_of_nat size).
  Proof.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_incr.
  assert (0 <= Zsucc (phi x))%Z.
-  change (Zsucc (phi x)) with ((phi x)+1)%Z; 
+  change (Zsucc (phi x)) with ((phi x)+1)%Z;
    generalize (phi_bounded x); omega.
  destruct (Zsucc (phi x)).
  simpl; auto.
@@ -1070,10 +1070,10 @@ Section Basics.
  compute in H; elim H; auto.
  Qed.
 
- (** With the previous results, we can deal with [phi o phi_inv] even 
+ (** With the previous results, we can deal with [phi o phi_inv] even
     in the negative case *)
 
- Lemma phi_phi_inv_negative : 
+ Lemma phi_phi_inv_negative :
   forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z_of_nat size).
  Proof.
  induction p.
@@ -1091,11 +1091,11 @@ Section Basics.
  rewrite incr_twice_plus_one, phi_twice.
  remember (phi (incr (complement_negative p))) as q.
  rewrite Zdouble_mult, IHp, Zmult_mod_idemp_r; auto with zarith.
- 
+
  simpl; auto.
  Qed.
 
- Lemma phi_phi_inv : 
+ Lemma phi_phi_inv :
   forall z, phi (phi_inv z) = z mod 2 ^ (Z_of_nat size).
  Proof.
  destruct z.
@@ -1120,7 +1120,7 @@ Let w_pos_mod p i :=
   end.
 
 (** Parity test *)
-Let w_iseven i := 
+Let w_iseven i :=
  let (_,r) := i/2 in
  match r ?= 0 with Eq => true | _ => false end.
 
@@ -1140,7 +1140,7 @@ Definition int31_op := (mk_znz_op
  w_iszero
  (* Basic arithmetic operations *)
  (fun i => 0 -c i)
- (fun i => 0 - i)
+ opp31
  (fun i => 0-i-1)
  (fun i => i +c 1)
  add31c
@@ -1181,14 +1181,14 @@ Definition int31_op := (mk_znz_op
 End Int31_Op.
 
 Section Int31_Spec.
- 
- Open Local Scope Z_scope.
+
+ Local Open Scope Z_scope.
 
  Notation "[| x |]" := (phi x)  (at level 0, x at level 99).
 
- Notation Local wB := (2 ^ (Z_of_nat size)).
- 
- Lemma wB_pos : wB > 0. 
+ Local Notation wB := (2 ^ (Z_of_nat size)).
+
+ Lemma wB_pos : wB > 0.
  Proof.
   auto with zarith.
  Qed.
@@ -1216,12 +1216,12 @@ Section Int31_Spec.
  Proof.
   reflexivity.
  Qed.
- 
+
  Lemma spec_1   : [| 1 |] = 1.
  Proof.
   reflexivity.
  Qed.
-    
+
  Lemma spec_Bm1 : [| Tn |] = wB - 1.
  Proof.
   reflexivity.
@@ -1252,16 +1252,16 @@ Section Int31_Spec.
   destruct (Z_lt_le_dec (X+Y) wB).
   contradict H1; auto using Zmod_small with zarith.
   rewrite <- (Z_mod_plus_full (X+Y) (-1) wB).
-  rewrite Zmod_small; romega. 
+  rewrite Zmod_small; romega.
 
  generalize (Zcompare_Eq_eq ((X+Y) mod wB) (X+Y)); intros Heq.
- destruct Zcompare; intros; 
+ destruct Zcompare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
  Lemma spec_succ_c : forall x, [+|add31c x 1|] = [|x|] + 1.
  Proof.
- intros; apply spec_add_c. 
+ intros; apply spec_add_c.
  Qed.
 
  Lemma spec_add_carry_c : forall x y, [+|add31carryc x y|] = [|x|] + [|y|] + 1.
@@ -1279,7 +1279,7 @@ Section Int31_Spec.
   rewrite Zmod_small; romega.
 
  generalize (Zcompare_Eq_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq.
- destruct Zcompare; intros; 
+ destruct Zcompare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
@@ -1304,7 +1304,7 @@ Section Int31_Spec.
  (** Substraction *)
 
  Lemma spec_sub_c : forall x y, [-|sub31c x y|] = [|x|] - [|y|].
- Proof. 
+ Proof.
  unfold sub31c, sub31, interp_carry; intros.
  rewrite phi_phi_inv.
  generalize (phi_bounded x)(phi_bounded y); intros.
@@ -1337,7 +1337,7 @@ Section Int31_Spec.
   contradict H1; apply Zmod_small; romega.
 
  generalize (Zcompare_Eq_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq.
- destruct Zcompare; intros; 
+ destruct Zcompare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
@@ -1355,7 +1355,7 @@ Section Int31_Spec.
  Qed.
 
  Lemma spec_opp_c : forall x, [-|sub31c 0 x|] = -[|x|].
- Proof. 
+ Proof.
  intros; apply spec_sub_c.
  Qed.
 
@@ -1402,7 +1402,7 @@ Section Int31_Spec.
   change (wB*wB) with (wB^2); ring.
 
  unfold phi_inv2.
- destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; 
+ destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv;
   change base with wB; auto.
  Qed.
 
@@ -1426,7 +1426,7 @@ Section Int31_Spec.
  intros; apply spec_mul_c.
  Qed.
 
- (** Division *) 
+ (** Division *)
 
  Lemma spec_div21 : forall a1 a2 b,
       wB/2 <= [|b|] ->
@@ -1537,7 +1537,7 @@ Section Int31_Spec.
  intros (H,_); compute in H; elim H; auto.
  Qed.
 
- Lemma iter_int31_iter_nat : forall A f i a, 
+ Lemma iter_int31_iter_nat : forall A f i a,
   iter_int31 i A f a = iter_nat (Zabs_nat [|i|]) A f a.
  Proof.
  intros.
@@ -1548,17 +1548,17 @@ Section Int31_Spec.
  revert i a; induction size.
  simpl; auto.
  simpl; intros.
- case_eq (firstr i); intros H; rewrite 2 IHn; 
+ case_eq (firstr i); intros H; rewrite 2 IHn;
   unfold phibis_aux; simpl; rewrite H; fold (phibis_aux n (shiftr i));
-  generalize (phibis_aux_pos n (shiftr i)); intros; 
-  set (z := phibis_aux n (shiftr i)) in *; clearbody z; 
+  generalize (phibis_aux_pos n (shiftr i)); intros;
+  set (z := phibis_aux n (shiftr i)) in *; clearbody z;
   rewrite <- iter_nat_plus.
 
  f_equal.
  rewrite Zdouble_mult, Zmult_comm, <- Zplus_diag_eq_mult_2.
  symmetry; apply Zabs_nat_Zplus; auto with zarith.
 
- change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a = 
+ change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a =
          iter_nat (Zabs_nat (Zdouble_plus_one z)) A f a); f_equal.
  rewrite Zdouble_plus_one_mult, Zmult_comm, <- Zplus_diag_eq_mult_2.
  rewrite Zabs_nat_Zplus; auto with zarith.
@@ -1566,13 +1566,13 @@ Section Int31_Spec.
  change (Zabs_nat 1) with 1%nat; omega.
  Qed.
 
- Fixpoint addmuldiv31_alt n i j := 
-  match n with 
-    | O => i 
+ Fixpoint addmuldiv31_alt n i j :=
+  match n with
+    | O => i
     | S n => addmuldiv31_alt n (sneakl (firstl j) i) (shiftl j)
   end.
 
- Lemma addmuldiv31_equiv : forall p x y, 
+ Lemma addmuldiv31_equiv : forall p x y,
   addmuldiv31 p x y = addmuldiv31_alt (Zabs_nat [|p|]) x y.
  Proof.
  intros.
@@ -1588,7 +1588,7 @@ Section Int31_Spec.
  Qed.
 
  Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 ->
-   [| addmuldiv31 p x y |] = 
+   [| addmuldiv31 p x y |] =
    ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos 31) - [|p|]))) mod wB.
  Proof.
  intros.
@@ -1626,7 +1626,7 @@ Section Int31_Spec.
  replace (31-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring.
  rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith.
  rewrite Zmult_comm, Z_div_mult; auto with zarith.
- 
+
  rewrite phi_twice_plus_one, Zdouble_plus_one_mult.
  rewrite phi_twice; auto.
  change (Zdouble [|y|]) with (2*[|y|]).
@@ -1644,7 +1644,7 @@ Section Int31_Spec.
   unfold wB'. rewrite <- Zpower_Zsucc, <- inj_S by (auto with zarith).
   f_equal.
  rewrite H1.
- replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by  
+ replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by
   (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring).
  unfold Zminus; rewrite Zopp_mult_distr_l.
  rewrite Z_div_plus; auto with zarith.
@@ -1669,8 +1669,8 @@ Section Int31_Spec.
   apply Zlt_le_trans with wB; auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
  intros.
- case_eq ([|p|] ?= 31); intros; 
-  [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | | 
+ case_eq ([|p|] ?= 31); intros;
+  [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | |
     apply H; change ([|p|]>31)%Z in H0; auto with zarith ].
  change ([|p|]<31) in H0.
  rewrite spec_add_mul_div by auto with zarith.
@@ -1701,16 +1701,16 @@ Section Int31_Spec.
   simpl; auto.
  Qed.
 
- Fixpoint head031_alt n x := 
-  match n with 
+ Fixpoint head031_alt n x :=
+  match n with
     | O => 0%nat
-    | S n => match firstl x with 
+    | S n => match firstl x with
                | D0 => S (head031_alt n (shiftl x))
                | D1 => 0%nat
              end
   end.
 
- Lemma head031_equiv : 
+ Lemma head031_equiv :
    forall x, [|head031 x|] = Z_of_nat (head031_alt size x).
  Proof.
  intros.
@@ -1720,10 +1720,10 @@ Section Int31_Spec.
 
  unfold head031, recl.
  change On with (phi_inv (Z_of_nat (31-size))).
- replace (head031_alt size x) with 
+ replace (head031_alt size x) with
    (head031_alt size x + (31 - size))%nat by (apply plus_0_r; auto).
  assert (size <= 31)%nat by auto with arith.
- 
+
  revert x H; induction size; intros.
  simpl; auto.
  unfold recl_aux; fold recl_aux.
@@ -1748,7 +1748,7 @@ Section Int31_Spec.
  change [|In|] with 1.
  replace (31-n)%nat with (S (31 - S n))%nat by omega.
  rewrite inj_S; ring.
- 
+
  clear - H H2.
  rewrite (sneakr_shiftl x) in H.
  rewrite H2 in H.
@@ -1793,7 +1793,7 @@ Section Int31_Spec.
  rewrite (sneakr_shiftl x), H1, H; auto.
 
  rewrite <- nshiftl_S_tail; auto.
- 
+
  change (2^(Z_of_nat 0)) with 1; rewrite Zmult_1_l.
  generalize (phi_bounded x); unfold size; split; auto with zarith.
  change (2^(Z_of_nat 31)/2) with (2^(Z_of_nat (pred size))).
@@ -1809,16 +1809,16 @@ Section Int31_Spec.
   simpl; auto.
  Qed.
 
- Fixpoint tail031_alt n x := 
-  match n with 
+ Fixpoint tail031_alt n x :=
+  match n with
     | O => 0%nat
-    | S n => match firstr x with 
+    | S n => match firstr x with
                | D0 => S (tail031_alt n (shiftr x))
                | D1 => 0%nat
              end
   end.
 
- Lemma tail031_equiv : 
+ Lemma tail031_equiv :
    forall x, [|tail031 x|] = Z_of_nat (tail031_alt size x).
  Proof.
  intros.
@@ -1828,10 +1828,10 @@ Section Int31_Spec.
 
  unfold tail031, recr.
  change On with (phi_inv (Z_of_nat (31-size))).
- replace (tail031_alt size x) with 
+ replace (tail031_alt size x) with
    (tail031_alt size x + (31 - size))%nat by (apply plus_0_r; auto).
  assert (size <= 31)%nat by auto with arith.
- 
+
  revert x H; induction size; intros.
  simpl; auto.
  unfold recr_aux; fold recr_aux.
@@ -1856,7 +1856,7 @@ Section Int31_Spec.
  change [|In|] with 1.
  replace (31-n)%nat with (S (31 - S n))%nat by omega.
  rewrite inj_S; ring.
- 
+
  clear - H H2.
  rewrite (sneakl_shiftr x) in H.
  rewrite H2 in H.
@@ -1864,7 +1864,7 @@ Section Int31_Spec.
  rewrite (iszero_eq0 _ H0) in H; discriminate.
  Qed.
 
- Lemma spec_tail0  : forall x, 0 < [|x|] -> 
+ Lemma spec_tail0  : forall x, 0 < [|x|] ->
          exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail031 x|]).
  Proof.
  intros.
@@ -1882,23 +1882,23 @@ Section Int31_Spec.
  case_eq (firstr x); intros.
  rewrite (inj_S (tail031_alt n (shiftr x))), Zpower_Zsucc; auto with zarith.
  destruct (IHn (shiftr x)) as (y & Hy1 & Hy2).
- 
+
  rewrite phi_nz; rewrite phi_nz in H; contradict H.
  rewrite (sneakl_shiftr x), H1, H; auto.
 
  rewrite <- nshiftr_S_tail; auto.
- 
+
  exists y; split; auto.
  rewrite phi_eqn1; auto.
  rewrite Zdouble_mult, Hy2; ring.
- 
+
  exists [|shiftr x|].
  split.
  generalize (phi_bounded (shiftr x)); auto with zarith.
  rewrite phi_eqn2; auto.
  rewrite Zdouble_plus_one_mult; simpl; ring.
  Qed.
-    
+
  (* Sqrt *)
 
  (* Direct transcription of an old proof
@@ -1906,27 +1906,27 @@ Section Int31_Spec.
 
  Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2).
  Proof.
- intros a; case (Z_mod_lt a 2); auto with zarith.
+ case (Z_mod_lt a 2); auto with zarith.
  intros H1; rewrite Zmod_eq_full; auto with zarith.
  Qed.
 
- Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> 
+ Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k ->
    (j * k) + j <= ((j + k)/2 + 1)  ^ 2.
  Proof.
- intros j k Hj; generalize Hj k; pattern j; apply natlike_ind; 
+ intros Hj; generalize Hj k; pattern j; apply natlike_ind;
    auto; clear k j Hj.
  intros _ k Hk; repeat rewrite Zplus_0_l.
  apply  Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith.
  intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk.
  rewrite Zmult_0_r, Zplus_0_r, Zplus_0_l.
- generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j)); 
+ generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j));
    unfold Zsucc.
  rewrite Zpower_2, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r.
  auto with zarith.
  intros k Hk _.
  replace ((Zsucc j + Zsucc k) / 2) with ((j + k)/2 + 1).
  generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)).
- unfold Zsucc; repeat rewrite Zpower_2; 
+ unfold Zsucc; repeat rewrite Zpower_2;
    repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r.
  repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r.
  auto with zarith.
@@ -1936,7 +1936,7 @@ Section Int31_Spec.
 
  Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2.
  Proof.
- intros i j Hi Hj.
+ intros Hi Hj.
  assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith).
  apply Zlt_le_trans with (2 := sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij).
  pattern i at 1; rewrite (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith.
@@ -1944,7 +1944,7 @@ Section Int31_Spec.
 
  Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2.
  Proof.
- intros i Hi.
+ intros Hi.
  assert (H1: 0 <= i - 2) by auto with zarith.
  assert (H2: 1 <= (i / 2) ^ 2); auto with zarith.
    replace i with (1* 2 + (i - 2)); auto with zarith.
@@ -1962,14 +1962,14 @@ Section Int31_Spec.
 
  Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i.
  Proof.
- intros i j Hi Hj Hd; rewrite Zpower_2.
+ intros Hi Hj Hd; rewrite Zpower_2.
  apply Zle_trans with (j * (i/j)); auto with zarith.
  apply Z_mult_div_ge; auto with zarith.
  Qed.
 
  Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j ->  (j + (i/j))/2 < j.
  Proof.
- intros i j Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto.
+ intros Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto.
  intros H1; contradict H; apply Zle_not_lt.
  assert (2 * j <= j + (i/j)); auto with zarith.
  apply Zle_trans with (2 * ((j + (i/j))/2)); auto with zarith.
@@ -1984,32 +1984,32 @@ Section Int31_Spec.
 
  Lemma Zcompare_spec i j: ZcompareSpec i j (i ?= j).
  Proof.
- intros i j; case_eq (Zcompare i j); intros H.
+ case_eq (Zcompare i j); intros H.
  apply ZcompareSpecEq; apply Zcompare_Eq_eq; auto.
  apply ZcompareSpecLt; auto.
  apply ZcompareSpecGt; apply Zgt_lt; auto.
  Qed.
 
  Lemma sqrt31_step_def rec i j:
-   sqrt31_step rec i j = 
+   sqrt31_step rec i j =
    match (fst (i/j) ?= j)%int31 with
      Lt => rec i (fst ((j + fst(i/j))/2))%int31
    | _ =>  j
    end.
  Proof.
- intros rec i j; unfold sqrt31_step; case div31; intros.
+ unfold sqrt31_step; case div31; intros.
  simpl; case compare31; auto.
  Qed.
 
  Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|].
- intros i j Hj; generalize (spec_div i j Hj).
+ intros Hj; generalize (spec_div i j Hj).
  case div31; intros q r; simpl fst.
  intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith.
  rewrite H1; ring.
  Qed.
 
- Lemma sqrt31_step_correct rec i j: 
-  0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> 
+ Lemma sqrt31_step_correct rec i j:
+  0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 ->
    2 * [|j|] < wB ->
   (forall j1 : int31,
     0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 ->
@@ -2017,15 +2017,15 @@ Section Int31_Spec.
   [|sqrt31_step rec i j|] ^ 2 <= [|i|] < ([|sqrt31_step rec i j|] + 1) ^ 2.
  Proof.
  assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt).
- intros rec i j Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def.
- generalize (spec_compare (fst (i/j)%int31) j); case compare31; 
+ intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def.
+ generalize (spec_compare (fst (i/j)%int31) j); case compare31;
    rewrite div31_phi; auto; intros Hc;
    try (split; auto; apply sqrt_test_true; auto with zarith; fail).
  apply Hrec; repeat rewrite div31_phi; auto with zarith.
  replace [|(j + fst (i / j)%int31)|] with ([|j|] + [|i|] / [|j|]).
  split.
  case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1.
- replace ([|j|] + [|i|]/[|j|]) with 
+ replace ([|j|] + [|i|]/[|j|]) with
         (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring.
  rewrite Z_div_plus_full_l; auto with zarith.
  assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith).
@@ -2048,12 +2048,12 @@ Section Int31_Spec.
 
  Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] ->
   [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z_of_nat size) ->
-  (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] ->  
+  (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] ->
       [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z_of_nat size) ->
        [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) ->
   [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2.
  Proof.
- intros n; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n.
+ revert rec i j; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n.
  intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto with zarith.
  intros; apply Hrec; auto with zarith.
  rewrite Zpower_0_r; auto with zarith.
@@ -2098,7 +2098,7 @@ Section Int31_Spec.
  Qed.
 
  Lemma sqrt312_step_def rec ih il j:
-   sqrt312_step rec ih il j = 
+   sqrt312_step rec ih il j =
    match (ih ?= j)%int31 with
       Eq => j
     | Gt => j
@@ -2112,14 +2112,14 @@ Section Int31_Spec.
        end
    end.
  Proof.
- intros rec ih il j; unfold sqrt312_step; case div3121; intros.
+ unfold sqrt312_step; case div3121; intros.
  simpl; case compare31; auto.
  Qed.
 
- Lemma sqrt312_lower_bound ih il j: 
+ Lemma sqrt312_lower_bound ih il j:
    phi2 ih  il  < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|].
  Proof.
- intros ih il j H1.
+ intros H1.
  case (phi_bounded j); intros Hbj _.
  case (phi_bounded il); intros Hbil _.
  case (phi_bounded ih); intros Hbih Hbih1.
@@ -2133,22 +2133,22 @@ Section Int31_Spec.
  Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] ->
   [|fst (div3121 ih il j)|] = phi2 ih il/[|j|])%Z.
  Proof.
- intros ih il j Hj Hj1.
+ intros Hj Hj1.
  generalize (spec_div21 ih il j Hj Hj1).
  case div3121; intros q r (Hq, Hr).
  apply Zdiv_unique with (phi r); auto with zarith.
  simpl fst; apply trans_equal with (1 := Hq); ring.
  Qed.
 
- Lemma sqrt312_step_correct rec ih il j: 
-  2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> 
+ Lemma sqrt312_step_correct rec ih il j:
+  2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 ->
   (forall j1, 0 < [|j1|] < [|j|] ->  phi2 ih il < ([|j1|] + 1) ^ 2 ->
      [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) ->
-  [|sqrt312_step rec ih il  j|] ^ 2 <= phi2 ih il 
+  [|sqrt312_step rec ih il  j|] ^ 2 <= phi2 ih il
       < ([|sqrt312_step rec ih il j|] + 1) ^  2.
  Proof.
  assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt).
- intros rec ih il j Hih Hj Hij Hrec; rewrite sqrt312_step_def.
+ intros Hih Hj Hij Hrec; rewrite sqrt312_step_def.
  assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt312_lower_bound with il; auto).
  case (phi_bounded ih); intros Hih1 _.
  case (phi_bounded il); intros Hil1 _.
@@ -2174,7 +2174,7 @@ Section Int31_Spec.
  case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2.
  2: contradict Hc; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith.
  assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2).
- replace ([|j|] + phi2 ih il/ [|j|])%Z with 
+ replace ([|j|] + phi2 ih il/ [|j|])%Z with
         (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring.
  rewrite Z_div_plus_full_l; auto with zarith.
  assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; auto with zarith.
@@ -2213,7 +2213,7 @@ Section Int31_Spec.
  rewrite div31_phi; change (phi 2) with 2%Z; auto.
  change (2 ^Z_of_nat size) with (base/2 + phi v30).
  assert (phi r / 2 < base/2); auto with zarith.
- apply Zmult_gt_0_lt_reg_r with 2; auto with zarith. 
+ apply Zmult_gt_0_lt_reg_r with 2; auto with zarith.
  change (base/2 * 2) with base.
  apply Zle_lt_trans with (phi r).
  rewrite Zmult_comm; apply Z_mult_div_ge; auto with zarith.
@@ -2234,15 +2234,15 @@ Section Int31_Spec.
  apply Zge_le; apply Z_div_ge; auto with zarith.
  Qed.
 
- Lemma iter312_sqrt_correct n rec ih il j: 
-  2^29 <= [|ih|] ->  0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> 
-  (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] ->  
-      phi2 ih il < ([|j1|] + 1) ^ 2 -> 
+ Lemma iter312_sqrt_correct n rec ih il j:
+  2^29 <= [|ih|] ->  0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 ->
+  (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] ->
+      phi2 ih il < ([|j1|] + 1) ^ 2 ->
        [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2)  ->
-  [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il 
+  [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il
       < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2.
  Proof.
- intros n; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n.
+ revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n.
  intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith.
  intros; apply Hrec; auto with zarith.
  rewrite Zpower_0_r; auto with zarith.
@@ -2265,7 +2265,7 @@ Section Int31_Spec.
  Proof.
  intros ih il Hih; unfold sqrt312.
  change [||WW ih il||] with (phi2 ih il).
- assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by 
+ assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by
   (intros s; ring).
  assert (Hb: 0 <= base) by (red; intros HH; discriminate).
  assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2).
@@ -2428,9 +2428,9 @@ Section Int31_Spec.
  apply Zcompare_Eq_eq.
  now destruct ([|x|] ?= 0).
  Qed.
-  
+
  (* Even *)
- 
+
  Let w_is_even     := int31_op.(znz_is_even).
 
  Lemma spec_is_even : forall x,
@@ -2460,13 +2460,13 @@ Section Int31_Spec.
   exact spec_more_than_1_digit.
 
   exact spec_0.
-  exact spec_1.  
+  exact spec_1.
   exact spec_Bm1.
 
   exact spec_compare.
   exact spec_eq0.
 
-  exact spec_opp_c. 
+  exact spec_opp_c.
   exact spec_opp.
   exact spec_opp_carry.
 
@@ -2500,7 +2500,7 @@ Section Int31_Spec.
 
   exact spec_head00.
   exact spec_head0.
-  exact spec_tail00. 
+  exact spec_tail00.
   exact spec_tail0.
 
   exact spec_add_mul_div.
diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v
index 154b436b..cc224254 100644
--- a/theories/Numbers/Cyclic/Int31/Int31.v
+++ b/theories/Numbers/Cyclic/Int31/Int31.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: Int31.v 11072 2008-06-08 16:13:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import NaryFunctions.
 Require Import Wf_nat.
@@ -17,7 +17,7 @@ Require Export DoubleType.
 
 Unset Boxed Definitions.
 
-(** * 31-bit integers *) 
+(** * 31-bit integers *)
 
 (** This file contains basic definitions of a 31-bit integer
   arithmetic. In fact it is more general than that. The only reason
@@ -36,11 +36,13 @@ Definition size := 31%nat.
 Inductive digits : Type := D0 | D1.
 
 (** The type of 31-bit integers *)
-  
-(** The type [int31] has a unique constructor [I31] that expects 
+
+(** The type [int31] has a unique constructor [I31] that expects
    31 arguments of type [digits]. *)
 
-Inductive int31 : Type := I31 : nfun digits size int31.
+Definition digits31 t := Eval compute in nfun digits size t.
+
+Inductive int31 : Type := I31 : digits31 int31.
 
 (* spiwack: Registration of the type of integers, so that the matchs in
    the functions below perform dynamic decompilation (otherwise some segfault
@@ -50,7 +52,7 @@ Register int31 as int31 type in "coq_int31" by True.
 
 Delimit Scope int31_scope with int31.
 Bind Scope int31_scope with int31.
-Open Scope int31_scope.
+Local Open Scope int31_scope.
 
 (** * Constants *)
 
@@ -69,26 +71,26 @@ Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D
 (** * Bits manipulation *)
 
 
-(** [sneakr b x] shifts [x] to the right by one bit. 
+(** [sneakr b x] shifts [x] to the right by one bit.
    Rightmost digit is lost while leftmost digit becomes [b].
-   Pseudo-code is 
+   Pseudo-code is
     [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ]
 *)
 
 Definition sneakr : digits -> int31 -> int31 := Eval compute in
  fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)).
 
-(** [sneakl b x] shifts [x] to the left by one bit. 
+(** [sneakl b x] shifts [x] to the left by one bit.
    Leftmost digit is lost while rightmost digit becomes [b].
-   Pseudo-code is 
+   Pseudo-code is
     [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ]
 *)
 
-Definition sneakl : digits -> int31 -> int31 := Eval compute in 
+Definition sneakl : digits -> int31 -> int31 := Eval compute in
  fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31).
 
 
-(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct 
+(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct
     consequences of [sneakl] and [sneakr]. *)
 
 Definition shiftl := sneakl D0.
@@ -96,31 +98,31 @@ Definition shiftr := sneakr D0.
 Definition twice := sneakl D0.
 Definition twice_plus_one := sneakl D1.
 
-(** [firstl x] returns the leftmost digit of number [x]. 
+(** [firstl x] returns the leftmost digit of number [x].
     Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *)
 
-Definition firstl : int31 -> digits := Eval compute in 
+Definition firstl : int31 -> digits := Eval compute in
  int31_rect _ (fun d => napply_discard _ _ d (size-1)).
 
-(** [firstr x] returns the rightmost digit of number [x]. 
+(** [firstr x] returns the rightmost digit of number [x].
     Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *)
 
-Definition firstr : int31 -> digits := Eval compute in 
+Definition firstr : int31 -> digits := Eval compute in
  int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)).
 
-(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is 
+(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is
     [ match x with (I31 D0 ... D0) => true | _ => false end ] *)
 
-Definition iszero : int31 -> bool := Eval compute in 
- let f d b := match d with D0 => b | D1 => false end 
+Definition iszero : int31 -> bool := Eval compute in
+ let f d b := match d with D0 => b | D1 => false end
  in int31_rect _ (nfold_bis _ _ f true size).
 
-(* NB: DO NOT transform the above match in a nicer (if then else). 
+(* NB: DO NOT transform the above match in a nicer (if then else).
    It seems to work, but later "unfold iszero" takes forever. *)
 
 
-(** [base] is [2^31], obtained via iterations of [Zdouble]. 
-   It can also be seen as the smallest b > 0 s.t. phi_inv b = 0  
+(** [base] is [2^31], obtained via iterations of [Zdouble].
+   It can also be seen as the smallest b > 0 s.t. phi_inv b = 0
    (see below) *)
 
 Definition base := Eval compute in
@@ -140,7 +142,7 @@ Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
              caserec (firstl i) si (recl_aux next A case0 caserec si)
   end.
 
-Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) 
+Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
  (i:int31) : A :=
   match n with
   | O => case0
@@ -159,22 +161,22 @@ Definition recr := recr_aux size.
 
 (** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *)
 
-Definition phi : int31 -> Z := 
+Definition phi : int31 -> Z :=
  recr Z (0%Z)
   (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end).
 
-(** From positive to int31. An abstract definition could be :  
-      [ phi_inv (2n) = 2*(phi_inv n) /\ 
+(** From positive to int31. An abstract definition could be :
+      [ phi_inv (2n) = 2*(phi_inv n) /\
         phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *)
 
-Fixpoint phi_inv_positive p := 
+Fixpoint phi_inv_positive p :=
   match p with
     | xI q => twice_plus_one (phi_inv_positive q)
     | xO q => twice (phi_inv_positive q)
     | xH => In
   end.
 
-(** The negative part : 2-complement  *) 
+(** The negative part : 2-complement  *)
 
 Fixpoint complement_negative p :=
   match p with
@@ -186,9 +188,9 @@ Fixpoint complement_negative p :=
 (** A simple incrementation function *)
 
 Definition incr : int31 -> int31 :=
- recr int31 In 
-   (fun b si rec => match b with 
-     | D0 => sneakl D1 si 
+ recr int31 In
+   (fun b si rec => match b with
+     | D0 => sneakl D1 si
      | D1 => sneakl D0 rec end).
 
 (** We can now define the conversion from Z to int31. *)
@@ -196,11 +198,11 @@ Definition incr : int31 -> int31 :=
 Definition phi_inv : Z -> int31 := fun n =>
  match n with
  | Z0 => On
- | Zpos p => phi_inv_positive p 
+ | Zpos p => phi_inv_positive p
  | Zneg p => incr (complement_negative p)
  end.
 
-(** [phi_inv2] is similar to [phi_inv] but returns a double word 
+(** [phi_inv2] is similar to [phi_inv] but returns a double word
     [zn2z int31] *)
 
 Definition phi_inv2 n :=
@@ -211,7 +213,7 @@ Definition phi_inv2 n :=
 
 (** [phi2] is similar to [phi] but takes a double word (two args) *)
 
-Definition phi2 nh nl := 
+Definition phi2 nh nl :=
   ((phi nh)*base+(phi nl))%Z.
 
 (** * Addition *)
@@ -227,11 +229,11 @@ Notation "n + m" := (add31 n m) : int31_scope.
 (* mode, (phi n)+(phi m) is computed twice*)
 (* it may be considered to optimize it *)
 
-Definition add31c (n m : int31) := 
+Definition add31c (n m : int31) :=
   let npm := n+m in
-  match (phi npm ?= (phi n)+(phi m))%Z with 
-  | Eq => C0 npm 
-  | _ => C1 npm                             
+  match (phi npm ?= (phi n)+(phi m))%Z with
+  | Eq => C0 npm
+  | _ => C1 npm
   end.
 Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope.
 
@@ -254,7 +256,7 @@ Notation "n - m" := (sub31 n m) : int31_scope.
 
 (** Subtraction with carry (thus exact) *)
 
-Definition sub31c (n m : int31) := 
+Definition sub31c (n m : int31) :=
   let nmm := n-m in
   match (phi nmm ?= (phi n)-(phi m))%Z with
   | Eq => C0 nmm
@@ -272,6 +274,10 @@ Definition sub31carryc (n m : int31) :=
   | _ => C1 nmmmone
   end.
 
+(** Opposite *)
+
+Definition opp31 x := On - x.
+Notation "- x" := (opp31 x) : int31_scope.
 
 (** Multiplication *)
 
@@ -290,13 +296,13 @@ Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scop
 
 (** Division of a double size word modulo [2^31] *)
 
-Definition div3121 (nh nl m : int31) := 
+Definition div3121 (nh nl m : int31) :=
   let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in
   (phi_inv q, phi_inv r).
 
 (** Division modulo [2^31] *)
 
-Definition div31 (n m : int31) := 
+Definition div31 (n m : int31) :=
   let (q,r) := Zdiv_eucl (phi n) (phi m) in
   (phi_inv q, phi_inv r).
 Notation "n / m" := (div31 n m) : int31_scope.
@@ -307,13 +313,16 @@ Notation "n / m" := (div31 n m) : int31_scope.
 Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z.
 Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope.
 
+Definition eqb31 (n m : int31) :=
+ match n ?= m with Eq => true | _ => false end.
+
 
-(** Computing the [i]-th iterate of a function: 
+(** Computing the [i]-th iterate of a function:
     [iter_int31 i A f = f^i] *)
 
 Definition iter_int31 i A f :=
-  recr (A->A) (fun x => x) 
-   (fun b si rec => match b with 
+  recr (A->A) (fun x => x)
+   (fun b si rec => match b with
       | D0 => fun x => rec (rec x)
       | D1 => fun x => f (rec (rec x))
     end)
@@ -322,9 +331,9 @@ Definition iter_int31 i A f :=
 (** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]:
     [addmuldiv31 p i j = i*2^p+j/2^(31-p)]  (modulo [2^31]) *)
 
-Definition addmuldiv31 p i j := 
- let (res, _ ) := 
- iter_int31 p (int31*int31) 
+Definition addmuldiv31 p i j :=
+ let (res, _ ) :=
+ iter_int31 p (int31*int31)
   (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j))
   (i,j)
  in
@@ -346,7 +355,7 @@ Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True.
 
 Definition gcd31 (i j:int31) :=
   (fix euler (guard:nat) (i j:int31) {struct guard} :=
-   match guard with 
+   match guard with
    | O => In
    | S p => match j ?= On with
             | Eq => i
@@ -370,17 +379,17 @@ Eval lazy delta [Twon] in
   | _ =>  j
   end.
 
-Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) 
+Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31)
           (i j: int31) {struct n} : int31 :=
-  sqrt31_step 
+  sqrt31_step
    (match n with
       O =>  rec
    | S n => (iter31_sqrt n (iter31_sqrt n rec))
    end) i j.
 
-Definition sqrt31 i := 
+Definition sqrt31 i :=
 Eval lazy delta [On In Twon] in
-  match compare31 In i with 
+  match compare31 In i with
     Gt => On
   | Eq => In
   | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon))
@@ -388,7 +397,7 @@ Eval lazy delta [On In Twon] in
 
 Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On).
 
-Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) 
+Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31)
    (ih il j: int31)  :=
 Eval lazy delta [Twon v30] in
   match ih ?= j with Eq => j | Gt => j | _ =>
@@ -401,28 +410,28 @@ Eval lazy delta [Twon v30] in
   | _ =>  j
   end end.
 
-Fixpoint iter312_sqrt (n: nat) 
-          (rec: int31  -> int31 -> int31 -> int31) 
+Fixpoint iter312_sqrt (n: nat)
+          (rec: int31  -> int31 -> int31 -> int31)
           (ih il j: int31) {struct n} : int31 :=
-  sqrt312_step 
+  sqrt312_step
    (match n with
       O =>  rec
    | S n => (iter312_sqrt n (iter312_sqrt n rec))
    end) ih il j.
 
-Definition sqrt312 ih il := 
+Definition sqrt312 ih il :=
 Eval lazy delta [On In] in
   let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in
            match s *c s with
             W0 => (On, C0 On) (* impossible *)
           | WW ih1 il1 =>
              match il -c il1 with
-                C0 il2 => 
+                C0 il2 =>
                   match ih ?= ih1 with
                     Gt => (s, C1 il2)
                   | _  => (s, C0 il2)
                   end
-              | C1 il2 => 
+              | C1 il2 =>
                   match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *)
                     Gt => (s, C1 il2)
                   | _  => (s, C0 il2)
@@ -431,7 +440,7 @@ Eval lazy delta [On In] in
           end.
 
 
-Fixpoint p2i n p : (N*int31)%type := 
+Fixpoint p2i n p : (N*int31)%type :=
   match n with
     | O => (Npos p, On)
     | S n => match p with
@@ -444,26 +453,26 @@ Fixpoint p2i n p : (N*int31)%type :=
 Definition positive_to_int31 (p:positive) := p2i size p.
 
 (** Constant 31 converted into type int31.
-    It is used as default answer for numbers of zeros 
+    It is used as default answer for numbers of zeros
     in [head0] and [tail0] *)
 
 Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size).
 
 Definition head031 (i:int31) :=
-  recl _ (fun _ => T31) 
-   (fun b si rec n => match b with 
+  recl _ (fun _ => T31)
+   (fun b si rec n => match b with
      | D0 => rec (add31 n In)
      | D1 => n
     end)
    i On.
 
 Definition tail031 (i:int31) :=
-  recr _ (fun _ => T31) 
-   (fun b si rec n => match b with 
+  recr _ (fun _ => T31)
+   (fun b si rec n => match b with
      | D0 => rec (add31 n In)
      | D1 => n
     end)
    i On.
 
 Register head031 as int31 head0 in "coq_int31" by True.
-Register tail031 as int31 tail0 in "coq_int31" by True. 
+Register tail031 as int31 tail0 in "coq_int31" by True.
diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v
new file mode 100644
index 00000000..2ec406b0
--- /dev/null
+++ b/theories/Numbers/Cyclic/Int31/Ring31.v
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped
+      with a ring structure and a ring tactic *)
+
+Require Import Int31 Cyclic31 CyclicAxioms.
+
+Local Open Scope int31_scope.
+
+(** Detection of constants *)
+
+Local Open Scope list_scope.
+
+Ltac isInt31cst_lst l :=
+ match l with
+ | nil => constr:true
+ | ?t::?l => match t with
+               | D1 => isInt31cst_lst l
+               | D0 => isInt31cst_lst l
+               | _ => constr:false
+             end
+ | _ => constr:false
+ end.
+
+Ltac isInt31cst t :=
+ match t with
+ | I31 ?i0 ?i1 ?i2 ?i3 ?i4 ?i5 ?i6 ?i7 ?i8 ?i9 ?i10
+       ?i11 ?i12 ?i13 ?i14 ?i15 ?i16 ?i17 ?i18 ?i19 ?i20
+       ?i21 ?i22 ?i23 ?i24 ?i25 ?i26 ?i27 ?i28 ?i29 ?i30 =>
+    let l :=
+      constr:(i0::i1::i2::i3::i4::i5::i6::i7::i8::i9::i10
+      ::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
+ end.
+
+Ltac Int31cst t :=
+ match isInt31cst t with
+ | true => constr:t
+ | false => constr:NotConstant
+ end.
+
+(** The generic ring structure inferred from the Cyclic structure *)
+
+Module Int31ring := CyclicRing Int31Cyclic.
+
+(** Unlike in the generic [CyclicRing], we can use Leibniz here. *)
+
+Lemma Int31_canonic : forall x y, phi x = phi y -> x = y.
+Proof.
+ intros x y EQ.
+ now rewrite <- (phi_inv_phi x), <- (phi_inv_phi y), EQ.
+Qed.
+
+Lemma ring_theory_switch_eq :
+ forall A (R R':A->A->Prop) zero one add mul sub opp,
+  (forall x y : A, R x y -> R' x y) ->
+  ring_theory zero one add mul sub opp R ->
+  ring_theory zero one add mul sub opp R'.
+Proof.
+intros A R R' zero one add mul sub opp Impl Ring.
+constructor; intros; apply Impl; apply Ring.
+Qed.
+
+Lemma Int31Ring : ring_theory 0 1 add31 mul31 sub31 opp31 Logic.eq.
+Proof.
+exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Int31_canonic Int31ring.CyclicRing).
+Qed.
+
+Lemma eqb31_eq : forall x y, eqb31 x y = true <-> x=y.
+Proof.
+unfold eqb31. intros x y.
+generalize (Cyclic31.spec_compare x y).
+destruct (x ?= y); intuition; subst; auto with zarith; try discriminate.
+apply Int31_canonic; auto.
+Qed.
+
+Lemma eqb31_correct : forall x y, eqb31 x y = true -> x=y.
+Proof. now apply eqb31_eq. Qed.
+
+Add Ring Int31Ring : Int31Ring
+ (decidable eqb31_correct,
+  constants [Int31cst]).
+
+Section TestRing.
+Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x.
+intros. ring.
+Qed.
+End TestRing.
+
diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
index 7c770e97..4f0f6c7c 100644
--- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v
+++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZModulo.v 11033 2008-06-01 22:56:50Z letouzey $ *)
+(* $Id$ *)
 
-(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] 
+(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ]
       as defined abstractly in CyclicAxioms. *)
 
-(** Even if the construction provided here is not reused for building 
-  the efficient arbitrary precision numbers, it provides a simple 
+(** Even if the construction provided here is not reused for building
+  the efficient arbitrary precision numbers, it provides a simple
   implementation of CyclicAxioms, hence ensuring its coherence. *)
 
 Set Implicit Arguments.
@@ -24,7 +24,7 @@ Require Import BigNumPrelude.
 Require Import DoubleType.
 Require Import CyclicAxioms.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Section ZModulo.
 
@@ -56,9 +56,9 @@ Section ZModulo.
   destruct 1; auto.
  Qed.
  Let digits_gt_1 := spec_more_than_1_digit.
- 
+
  Lemma wB_pos : wB > 0.
- Proof.  
+ Proof.
   unfold wB, base; auto with zarith.
  Qed.
  Hint Resolve wB_pos.
@@ -79,7 +79,7 @@ Section ZModulo.
   auto.
  Qed.
 
- Definition znz_of_pos x := 
+ Definition znz_of_pos x :=
    let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r).
 
  Lemma spec_of_pos : forall p,
@@ -90,10 +90,10 @@ Section ZModulo.
   destruct (Zdiv_eucl_POS p wB); simpl; destruct 1.
   unfold znz_to_Z; rewrite Zmod_small; auto.
   assert (0 <= z).
-   replace z with (Zpos p / wB) by 
+   replace z with (Zpos p / wB) by
     (symmetry; apply Zdiv_unique with z0; auto).
    apply Z_div_pos; auto with zarith.
-  replace (Z_of_N (N_of_Z z)) with z by 
+  replace (Z_of_N (N_of_Z z)) with z by
     (destruct z; simpl; auto; elim H1; auto).
   rewrite Zmult_comm; auto.
  Qed.
@@ -110,7 +110,7 @@ Section ZModulo.
  Definition znz_0 := 0.
  Definition znz_1 := 1.
  Definition znz_Bm1 := wB - 1.
-  
+
  Lemma spec_0 : [|znz_0|] = 0.
  Proof.
   unfold znz_to_Z, znz_0.
@@ -121,7 +121,7 @@ Section ZModulo.
  Proof.
   unfold znz_to_Z, znz_1.
   apply Zmod_small; split; auto with zarith.
-  unfold wB, base.  
+  unfold wB, base.
   apply Zlt_trans with (Zpos digits); auto.
   apply Zpower2_lt_lin; auto with zarith.
  Qed.
@@ -138,7 +138,7 @@ Section ZModulo.
 
  Definition znz_compare x y := Zcompare [|x|] [|y|].
 
- Lemma spec_compare : forall x y, 
+ Lemma spec_compare : forall x y,
        match znz_compare x y with
        | Eq => [|x|] = [|y|]
        | Lt => [|x|] < [|y|]
@@ -150,19 +150,19 @@ Section ZModulo.
   intros; apply Zcompare_Eq_eq; auto.
  Qed.
 
- Definition znz_eq0 x := 
+ Definition znz_eq0 x :=
    match [|x|] with Z0 => true | _ => false end.
- 
+
  Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0.
  Proof.
   unfold znz_eq0; intros; now destruct [|x|].
  Qed.
 
- Definition znz_opp_c x := 
+ Definition znz_opp_c x :=
    if znz_eq0 x then C0 0 else C1 (- x).
  Definition znz_opp x := - x.
  Definition znz_opp_carry x := - x - 1.
- 
+
  Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|].
  Proof.
  intros; unfold znz_opp_c, znz_to_Z; auto.
@@ -180,7 +180,7 @@ Section ZModulo.
  change ((- x) mod wB = (0 - (x mod wB)) mod wB).
  rewrite Zminus_mod_idemp_r; simpl; auto.
  Qed.
-  
+
  Lemma spec_opp_carry : forall x, [|znz_opp_carry x|] = wB - [|x|] - 1.
  Proof.
  intros; unfold znz_opp_carry, znz_to_Z; auto.
@@ -194,15 +194,15 @@ Section ZModulo.
  generalize (Z_mod_lt x wB wB_pos); omega.
  Qed.
 
- Definition znz_succ_c x := 
-  let y := Zsucc x in 
+ Definition znz_succ_c x :=
+  let y := Zsucc x in
   if znz_eq0 y then C1 0 else C0 y.
 
- Definition znz_add_c x y := 
-  let z := [|x|] + [|y|] in 
+ Definition znz_add_c x y :=
+  let z := [|x|] + [|y|] in
   if Z_lt_le_dec z wB then C0 z else C1 (z-wB).
 
- Definition znz_add_carry_c x y := 
+ Definition znz_add_carry_c x y :=
   let z := [|x|]+[|y|]+1 in
   if Z_lt_le_dec z wB then C0 z else C1 (z-wB).
 
@@ -210,7 +210,7 @@ Section ZModulo.
  Definition znz_add := Zplus.
  Definition znz_add_carry x y := x + y + 1.
 
- Lemma Zmod_equal : 
+ Lemma Zmod_equal :
   forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z.
  Proof.
  intros.
@@ -225,12 +225,12 @@ Section ZModulo.
  Proof.
  intros; unfold znz_succ_c, znz_to_Z, Zsucc.
  case_eq (znz_eq0 (x+1)); intros; unfold interp_carry.
- 
+
  rewrite Zmult_1_l.
  replace (wB + 0 mod wB) with wB by auto with zarith.
  symmetry; rewrite Zeq_plus_swap.
  assert ((x+1) mod wB = 0) by (apply spec_eq0; auto).
- replace (wB-1) with ((wB-1) mod wB) by 
+ replace (wB-1) with ((wB-1) mod wB) by
   (apply Zmod_small; generalize wB_pos; omega).
  rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto.
  apply Zmod_equal; auto.
@@ -289,15 +289,15 @@ Section ZModulo.
  rewrite Zplus_mod_idemp_l; auto.
  Qed.
 
- Definition znz_pred_c x := 
+ Definition znz_pred_c x :=
   if znz_eq0 x then C1 (wB-1) else C0 (x-1).
 
- Definition znz_sub_c x y := 
-  let z := [|x|]-[|y|] in 
+ Definition znz_sub_c x y :=
+  let z := [|x|]-[|y|] in
   if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.
 
- Definition znz_sub_carry_c x y := 
-  let z := [|x|]-[|y|]-1 in 
+ Definition znz_sub_carry_c x y :=
+  let z := [|x|]-[|y|]-1 in
   if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.
 
  Definition znz_pred := Zpred.
@@ -323,7 +323,7 @@ Section ZModulo.
  Proof.
  intros; unfold znz_sub_c, znz_to_Z, interp_carry.
  destruct Z_lt_le_dec.
- replace ((wB + (x mod wB - y mod wB)) mod wB) with 
+ replace ((wB + (x mod wB - y mod wB)) mod wB) with
    (wB + (x mod wB - y mod wB)).
  omega.
  symmetry; apply Zmod_small.
@@ -337,7 +337,7 @@ Section ZModulo.
  Proof.
  intros; unfold znz_sub_carry_c, znz_to_Z, interp_carry.
  destruct Z_lt_le_dec.
- replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with 
+ replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with
    (wB + (x mod wB - y mod wB -1)).
  omega.
  symmetry; apply Zmod_small.
@@ -358,7 +358,7 @@ Section ZModulo.
  intros; unfold znz_sub, znz_to_Z; apply Zminus_mod.
  Qed.
 
- Lemma spec_sub_carry : 
+ Lemma spec_sub_carry :
   forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.
  Proof.
  intros; unfold znz_sub_carry, znz_to_Z.
@@ -367,15 +367,15 @@ Section ZModulo.
  rewrite Zminus_mod_idemp_l.
  auto.
  Qed.
-  
- Definition znz_mul_c x y := 
+
+ Definition znz_mul_c x y :=
   let (h,l) := Zdiv_eucl ([|x|]*[|y|]) wB in
   if znz_eq0 h then if znz_eq0 l then W0 else WW h l else WW h l.
 
  Definition znz_mul := Zmult.
 
  Definition znz_square_c x := znz_mul_c x x.
- 
+
  Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|].
  Proof.
  intros; unfold znz_mul_c, zn2z_to_Z.
@@ -426,7 +426,7 @@ Section ZModulo.
  destruct Zdiv_eucl as (q,r); destruct 1; intros.
  injection H1; clear H1; intros.
  assert ([|r|]=r).
-  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; 
+  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
    auto with zarith.
  assert ([|q|]=q).
   apply Zmod_small.
@@ -453,7 +453,7 @@ Section ZModulo.
 
  Definition znz_mod x y := [|x|] mod [|y|].
  Definition znz_mod_gt x y := [|x|] mod [|y|].
- 
+
  Lemma spec_mod :  forall a b, 0 < [|b|] ->
       [|znz_mod a b|] = [|a|] mod [|b|].
  Proof.
@@ -469,7 +469,7 @@ Section ZModulo.
  Proof.
  intros; apply spec_mod; auto.
  Qed.
- 
+
  Definition znz_gcd x y := Zgcd [|x|] [|y|].
  Definition znz_gcd_gt x y := Zgcd [|x|] [|y|].
 
@@ -516,7 +516,7 @@ Section ZModulo.
   intros. apply spec_gcd; auto.
  Qed.
 
- Definition znz_div21 a1 a2 b := 
+ Definition znz_div21 a1 a2 b :=
   Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|].
 
  Lemma spec_div21 : forall a1 a2 b,
@@ -537,7 +537,7 @@ Section ZModulo.
  destruct Zdiv_eucl as (q,r); destruct 1; intros.
  injection H4; clear H4; intros.
  assert ([|r|]=r).
-  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; 
+  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
    auto with zarith.
  assert ([|q|]=q).
   apply Zmod_small.
@@ -546,7 +546,6 @@ Section ZModulo.
   apply Z_div_pos; auto with zarith.
   subst a; auto with zarith.
   apply Zdiv_lt_upper_bound; auto with zarith.
-  subst a; auto with zarith.
   subst a.
   replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring.
   apply Zlt_le_trans with ([|a1|]*wB+wB); auto with zarith.
@@ -577,7 +576,7 @@ Section ZModulo.
  apply Zmod_le; auto with zarith.
  Qed.
 
- Definition znz_is_even x := 
+ Definition znz_is_even x :=
    if Z_eq_dec ([|x|] mod 2) 0 then true else false.
 
  Lemma spec_is_even : forall x,
@@ -587,7 +586,7 @@ Section ZModulo.
  generalize (Z_mod_lt [|x|] 2); omega.
  Qed.
 
- Definition znz_sqrt x := Zsqrt_plain [|x|]. 
+ Definition znz_sqrt x := Zsqrt_plain [|x|].
  Lemma spec_sqrt : forall x,
        [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2.
  Proof.
@@ -610,12 +609,12 @@ Section ZModulo.
  generalize wB_pos; auto with zarith.
  Qed.
 
- Definition znz_sqrt2 x y := 
-  let z := [|x|]*wB+[|y|] in 
-  match z with 
+ Definition znz_sqrt2 x y :=
+  let z := [|x|]*wB+[|y|] in
+  match z with
    | Z0 => (0, C0 0)
-   | Zpos p => 
-      let (s,r,_,_) := sqrtrempos p in 
+   | Zpos p =>
+      let (s,r,_,_) := sqrtrempos p in
       (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB))
    | Zneg _ => (0, C0 0)
   end.
@@ -652,7 +651,7 @@ Section ZModulo.
  rewrite Zpower_2; auto with zarith.
  replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith).
  rewrite Zpower_2; omega.
- 
+
  assert (0<=Zneg p).
   rewrite Heqz; generalize wB_pos; auto with zarith.
  compute in H0; elim H0; auto.
@@ -666,8 +665,8 @@ Section ZModulo.
  apply two_power_pos_correct.
  Qed.
 
- Definition znz_head0 x := match [|x|] with 
-   | Z0 => znz_zdigits 
+ Definition znz_head0 x := match [|x|] with
+   | Z0 => znz_zdigits
    | Zpos p => znz_zdigits - log_inf p - 1
    | _ => 0
   end.
@@ -696,7 +695,7 @@ Section ZModulo.
  change (Zpos x~0) with (2*(Zpos x)) in H.
  replace p with (Zsucc (p-1)) in H; auto with zarith.
  rewrite Zpower_Zsucc in H; auto with zarith.
- 
+
  simpl; intros; destruct p; compute; auto with zarith.
  Qed.
 
@@ -731,8 +730,8 @@ Section ZModulo.
    by ring.
  unfold wB, base, znz_zdigits; auto with zarith.
  apply Zmult_le_compat; auto with zarith.
- 
- apply Zlt_le_trans 
+
+ apply Zlt_le_trans
    with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))).
  apply Zmult_lt_compat_l; auto with zarith.
  rewrite <- Zpower_exp; auto with zarith.
@@ -741,17 +740,17 @@ Section ZModulo.
  unfold wB, base, znz_zdigits; auto with zarith.
  Qed.
 
- Fixpoint Ptail p := match p with 
+ Fixpoint Ptail p := match p with
   | xO p => (Ptail p)+1
   | _ => 0
- end. 
+ end.
 
  Lemma Ptail_pos : forall p, 0 <= Ptail p.
  Proof.
  induction p; simpl; auto with zarith.
  Qed.
  Hint Resolve Ptail_pos.
- 
+
  Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d.
  Proof.
  induction p; try (compute; auto; fail).
@@ -776,7 +775,7 @@ Section ZModulo.
  Qed.
 
  Definition znz_tail0 x :=
-  match [|x|] with 
+  match [|x|] with
    | Z0 => znz_zdigits
    | Zpos p => Ptail p
    | Zneg _ => 0
@@ -789,7 +788,7 @@ Section ZModulo.
   apply spec_zdigits.
  Qed.
 
- Lemma spec_tail0  : forall x, 0 < [|x|] -> 
+ Lemma spec_tail0  : forall x, 0 < [|x|] ->
          exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|znz_tail0 x|]).
  Proof.
  intros; unfold znz_tail0.
@@ -819,7 +818,7 @@ Section ZModulo.
 
  (** Let's now group everything in two records *)
 
- Definition zmod_op := mk_znz_op 
+ Definition zmod_op := mk_znz_op
     (znz_digits : positive)
     (znz_zdigits: znz)
     (znz_to_Z   : znz -> Z)
@@ -860,11 +859,11 @@ Section ZModulo.
     (znz_div_gt      : znz -> znz -> znz * znz)
     (znz_div         : znz -> znz -> znz * znz)
 
-    (znz_mod_gt      : znz -> znz -> znz) 
-    (znz_mod         : znz -> znz -> znz) 
+    (znz_mod_gt      : znz -> znz -> znz)
+    (znz_mod         : znz -> znz -> znz)
 
     (znz_gcd_gt      : znz -> znz -> znz)
-    (znz_gcd         : znz -> znz -> znz) 
+    (znz_gcd         : znz -> znz -> znz)
     (znz_add_mul_div : znz -> znz -> znz -> znz)
     (znz_pos_mod     : znz -> znz -> znz)
 
@@ -879,54 +878,54 @@ Section ZModulo.
     spec_more_than_1_digit
 
     spec_0
-    spec_1   
-    spec_Bm1 
-
-    spec_compare 
-    spec_eq0 
-
-    spec_opp_c 
-    spec_opp 
-    spec_opp_carry 
-
-    spec_succ_c 
-    spec_add_c  
-    spec_add_carry_c 
-    spec_succ 
-    spec_add 
-    spec_add_carry 
-
-    spec_pred_c 
-    spec_sub_c 
-    spec_sub_carry_c 
-    spec_pred 
-    spec_sub 
-    spec_sub_carry 
-
-    spec_mul_c 
-    spec_mul 
-    spec_square_c 
-
-    spec_div21 
-    spec_div_gt 
-    spec_div 
-   
-    spec_mod_gt 
-    spec_mod 
-      
-    spec_gcd_gt 
-    spec_gcd 
-
-    spec_head00 
-    spec_head0  
-    spec_tail00 
-    spec_tail0  
-
-    spec_add_mul_div 
-    spec_pos_mod 
-
-    spec_is_even 
-    spec_sqrt2 
+    spec_1
+    spec_Bm1
+
+    spec_compare
+    spec_eq0
+
+    spec_opp_c
+    spec_opp
+    spec_opp_carry
+
+    spec_succ_c
+    spec_add_c
+    spec_add_carry_c
+    spec_succ
+    spec_add
+    spec_add_carry
+
+    spec_pred_c
+    spec_sub_c
+    spec_sub_carry_c
+    spec_pred
+    spec_sub
+    spec_sub_carry
+
+    spec_mul_c
+    spec_mul
+    spec_square_c
+
+    spec_div21
+    spec_div_gt
+    spec_div
+
+    spec_mod_gt
+    spec_mod
+
+    spec_gcd_gt
+    spec_gcd
+
+    spec_head00
+    spec_head0
+    spec_tail00
+    spec_tail0
+
+    spec_add_mul_div
+    spec_pos_mod
+
+    spec_is_even
+    spec_sqrt2
     spec_sqrt.
 
 End ZModulo.
@@ -935,7 +934,7 @@ End ZModulo.
 
 Module Type PositiveNotOne.
  Parameter p : positive.
- Axiom not_one : p<> 1%positive. 
+ Axiom not_one : p<> 1%positive.
 End PositiveNotOne.
 
 Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType.
diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v
index df941d90..5663408d 100644
--- a/theories/Numbers/Integer/Abstract/ZAdd.v
+++ b/theories/Numbers/Integer/Abstract/ZAdd.v
@@ -8,338 +8,286 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export ZBase.
 
-Module ZAddPropFunct (Import ZAxiomsMod : ZAxiomsSig).
-Module Export ZBasePropMod := ZBasePropFunct ZAxiomsMod.
-Open Local Scope IntScope.
+Module ZAddPropFunct (Import Z : ZAxiomsSig').
+Include ZBasePropFunct Z.
 
-Theorem Zadd_wd :
-  forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> n1 + m1 == n2 + m2.
-Proof NZadd_wd.
+(** Theorems that are either not valid on N or have different proofs
+    on N and Z *)
 
-Theorem Zadd_0_l : forall n : Z, 0 + n == n.
-Proof NZadd_0_l.
-
-Theorem Zadd_succ_l : forall n m : Z, (S n) + m == S (n + m).
-Proof NZadd_succ_l.
-
-Theorem Zsub_0_r : forall n : Z, n - 0 == n.
-Proof NZsub_0_r.
-
-Theorem Zsub_succ_r : forall n m : Z, n - (S m) == P (n - m).
-Proof NZsub_succ_r.
-
-Theorem Zopp_0 : - 0 == 0.
-Proof Zopp_0.
-
-Theorem Zopp_succ : forall n : Z, - (S n) == P (- n).
-Proof Zopp_succ.
-
-(* Theorems that are valid for both natural numbers and integers *)
-
-Theorem Zadd_0_r : forall n : Z, n + 0 == n.
-Proof NZadd_0_r.
-
-Theorem Zadd_succ_r : forall n m : Z, n + S m == S (n + m).
-Proof NZadd_succ_r.
-
-Theorem Zadd_comm : forall n m : Z, n + m == m + n.
-Proof NZadd_comm.
-
-Theorem Zadd_assoc : forall n m p : Z, n + (m + p) == (n + m) + p.
-Proof NZadd_assoc.
-
-Theorem Zadd_shuffle1 : forall n m p q : Z, (n + m) + (p + q) == (n + p) + (m + q).
-Proof NZadd_shuffle1.
-
-Theorem Zadd_shuffle2 : forall n m p q : Z, (n + m) + (p + q) == (n + q) + (m + p).
-Proof NZadd_shuffle2.
-
-Theorem Zadd_1_l : forall n : Z, 1 + n == S n.
-Proof NZadd_1_l.
-
-Theorem Zadd_1_r : forall n : Z, n + 1 == S n.
-Proof NZadd_1_r.
-
-Theorem Zadd_cancel_l : forall n m p : Z, p + n == p + m <-> n == m.
-Proof NZadd_cancel_l.
-
-Theorem Zadd_cancel_r : forall n m p : Z, n + p == m + p <-> n == m.
-Proof NZadd_cancel_r.
-
-(* Theorems that are either not valid on N or have different proofs on N and Z *)
-
-Theorem Zadd_pred_l : forall n m : Z, P n + m == P (n + m).
+Theorem add_pred_l : forall n m, P n + m == P (n + m).
 Proof.
 intros n m.
-rewrite <- (Zsucc_pred n) at 2.
-rewrite Zadd_succ_l. now rewrite Zpred_succ.
+rewrite <- (succ_pred n) at 2.
+rewrite add_succ_l. now rewrite pred_succ.
 Qed.
 
-Theorem Zadd_pred_r : forall n m : Z, n + P m == P (n + m).
+Theorem add_pred_r : forall n m, n + P m == P (n + m).
 Proof.
-intros n m; rewrite (Zadd_comm n (P m)), (Zadd_comm n m);
-apply Zadd_pred_l.
+intros n m; rewrite (add_comm n (P m)), (add_comm n m);
+apply add_pred_l.
 Qed.
 
-Theorem Zadd_opp_r : forall n m : Z, n + (- m) == n - m.
+Theorem add_opp_r : forall n m, n + (- m) == n - m.
 Proof.
-NZinduct m.
-rewrite Zopp_0; rewrite Zsub_0_r; now rewrite Zadd_0_r.
-intro m. rewrite Zopp_succ, Zsub_succ_r, Zadd_pred_r; now rewrite Zpred_inj_wd.
+nzinduct m.
+rewrite opp_0; rewrite sub_0_r; now rewrite add_0_r.
+intro m. rewrite opp_succ, sub_succ_r, add_pred_r; now rewrite pred_inj_wd.
 Qed.
 
-Theorem Zsub_0_l : forall n : Z, 0 - n == - n.
+Theorem sub_0_l : forall n, 0 - n == - n.
 Proof.
-intro n; rewrite <- Zadd_opp_r; now rewrite Zadd_0_l.
+intro n; rewrite <- add_opp_r; now rewrite add_0_l.
 Qed.
 
-Theorem Zsub_succ_l : forall n m : Z, S n - m == S (n - m).
+Theorem sub_succ_l : forall n m, S n - m == S (n - m).
 Proof.
-intros n m; do 2 rewrite <- Zadd_opp_r; now rewrite Zadd_succ_l.
+intros n m; do 2 rewrite <- add_opp_r; now rewrite add_succ_l.
 Qed.
 
-Theorem Zsub_pred_l : forall n m : Z, P n - m == P (n - m).
+Theorem sub_pred_l : forall n m, P n - m == P (n - m).
 Proof.
-intros n m. rewrite <- (Zsucc_pred n) at 2.
-rewrite Zsub_succ_l; now rewrite Zpred_succ.
+intros n m. rewrite <- (succ_pred n) at 2.
+rewrite sub_succ_l; now rewrite pred_succ.
 Qed.
 
-Theorem Zsub_pred_r : forall n m : Z, n - (P m) == S (n - m).
+Theorem sub_pred_r : forall n m, n - (P m) == S (n - m).
 Proof.
-intros n m. rewrite <- (Zsucc_pred m) at 2.
-rewrite Zsub_succ_r; now rewrite Zsucc_pred.
+intros n m. rewrite <- (succ_pred m) at 2.
+rewrite sub_succ_r; now rewrite succ_pred.
 Qed.
 
-Theorem Zopp_pred : forall n : Z, - (P n) == S (- n).
+Theorem opp_pred : forall n, - (P n) == S (- n).
 Proof.
-intro n. rewrite <- (Zsucc_pred n) at 2.
-rewrite Zopp_succ. now rewrite Zsucc_pred.
+intro n. rewrite <- (succ_pred n) at 2.
+rewrite opp_succ. now rewrite succ_pred.
 Qed.
 
-Theorem Zsub_diag : forall n : Z, n - n == 0.
+Theorem sub_diag : forall n, n - n == 0.
 Proof.
-NZinduct n.
-now rewrite Zsub_0_r.
-intro n. rewrite Zsub_succ_r, Zsub_succ_l; now rewrite Zpred_succ.
+nzinduct n.
+now rewrite sub_0_r.
+intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ.
 Qed.
 
-Theorem Zadd_opp_diag_l : forall n : Z, - n + n == 0.
+Theorem add_opp_diag_l : forall n, - n + n == 0.
 Proof.
-intro n; now rewrite Zadd_comm, Zadd_opp_r, Zsub_diag.
+intro n; now rewrite add_comm, add_opp_r, sub_diag.
 Qed.
 
-Theorem Zadd_opp_diag_r : forall n : Z, n + (- n) == 0.
+Theorem add_opp_diag_r : forall n, n + (- n) == 0.
 Proof.
-intro n; rewrite Zadd_comm; apply Zadd_opp_diag_l.
+intro n; rewrite add_comm; apply add_opp_diag_l.
 Qed.
 
-Theorem Zadd_opp_l : forall n m : Z, - m + n == n - m.
+Theorem add_opp_l : forall n m, - m + n == n - m.
 Proof.
-intros n m; rewrite <- Zadd_opp_r; now rewrite Zadd_comm.
+intros n m; rewrite <- add_opp_r; now rewrite add_comm.
 Qed.
 
-Theorem Zadd_sub_assoc : forall n m p : Z, n + (m - p) == (n + m) - p.
+Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p.
 Proof.
-intros n m p; do 2 rewrite <- Zadd_opp_r; now rewrite Zadd_assoc.
+intros n m p; do 2 rewrite <- add_opp_r; now rewrite add_assoc.
 Qed.
 
-Theorem Zopp_involutive : forall n : Z, - (- n) == n.
+Theorem opp_involutive : forall n, - (- n) == n.
 Proof.
-NZinduct n.
-now do 2 rewrite Zopp_0.
-intro n. rewrite Zopp_succ, Zopp_pred; now rewrite Zsucc_inj_wd.
+nzinduct n.
+now do 2 rewrite opp_0.
+intro n. rewrite opp_succ, opp_pred; now rewrite succ_inj_wd.
 Qed.
 
-Theorem Zopp_add_distr : forall n m : Z, - (n + m) == - n + (- m).
+Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m).
 Proof.
-intros n m; NZinduct n.
-rewrite Zopp_0; now do 2 rewrite Zadd_0_l.
-intro n. rewrite Zadd_succ_l; do 2 rewrite Zopp_succ; rewrite Zadd_pred_l.
-now rewrite Zpred_inj_wd.
+intros n m; nzinduct n.
+rewrite opp_0; now do 2 rewrite add_0_l.
+intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l.
+now rewrite pred_inj_wd.
 Qed.
 
-Theorem Zopp_sub_distr : forall n m : Z, - (n - m) == - n + m.
+Theorem opp_sub_distr : forall n m, - (n - m) == - n + m.
 Proof.
-intros n m; rewrite <- Zadd_opp_r, Zopp_add_distr.
-now rewrite Zopp_involutive.
+intros n m; rewrite <- add_opp_r, opp_add_distr.
+now rewrite opp_involutive.
 Qed.
 
-Theorem Zopp_inj : forall n m : Z, - n == - m -> n == m.
+Theorem opp_inj : forall n m, - n == - m -> n == m.
 Proof.
-intros n m H. apply Zopp_wd in H. now do 2 rewrite Zopp_involutive in H.
+intros n m H. apply opp_wd in H. now do 2 rewrite opp_involutive in H.
 Qed.
 
-Theorem Zopp_inj_wd : forall n m : Z, - n == - m <-> n == m.
+Theorem opp_inj_wd : forall n m, - n == - m <-> n == m.
 Proof.
-intros n m; split; [apply Zopp_inj | apply Zopp_wd].
+intros n m; split; [apply opp_inj | apply opp_wd].
 Qed.
 
-Theorem Zeq_opp_l : forall n m : Z, - n == m <-> n == - m.
+Theorem eq_opp_l : forall n m, - n == m <-> n == - m.
 Proof.
-intros n m. now rewrite <- (Zopp_inj_wd (- n) m), Zopp_involutive.
+intros n m. now rewrite <- (opp_inj_wd (- n) m), opp_involutive.
 Qed.
 
-Theorem Zeq_opp_r : forall n m : Z, n == - m <-> - n == m.
+Theorem eq_opp_r : forall n m, n == - m <-> - n == m.
 Proof.
-symmetry; apply Zeq_opp_l.
+symmetry; apply eq_opp_l.
 Qed.
 
-Theorem Zsub_add_distr : forall n m p : Z, n - (m + p) == (n - m) - p.
+Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p.
 Proof.
-intros n m p; rewrite <- Zadd_opp_r, Zopp_add_distr, Zadd_assoc.
-now do 2 rewrite Zadd_opp_r.
+intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc.
+now do 2 rewrite add_opp_r.
 Qed.
 
-Theorem Zsub_sub_distr : forall n m p : Z, n - (m - p) == (n - m) + p.
+Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p.
 Proof.
-intros n m p; rewrite <- Zadd_opp_r, Zopp_sub_distr, Zadd_assoc.
-now rewrite Zadd_opp_r.
+intros n m p; rewrite <- add_opp_r, opp_sub_distr, add_assoc.
+now rewrite add_opp_r.
 Qed.
 
-Theorem sub_opp_l : forall n m : Z, - n - m == - m - n.
+Theorem sub_opp_l : forall n m, - n - m == - m - n.
 Proof.
-intros n m. do 2 rewrite <- Zadd_opp_r. now rewrite Zadd_comm.
+intros n m. do 2 rewrite <- add_opp_r. now rewrite add_comm.
 Qed.
 
-Theorem Zsub_opp_r : forall n m : Z, n - (- m) == n + m.
+Theorem sub_opp_r : forall n m, n - (- m) == n + m.
 Proof.
-intros n m; rewrite <- Zadd_opp_r; now rewrite Zopp_involutive.
+intros n m; rewrite <- add_opp_r; now rewrite opp_involutive.
 Qed.
 
-Theorem Zadd_sub_swap : forall n m p : Z, n + m - p == n - p + m.
+Theorem add_sub_swap : forall n m p, n + m - p == n - p + m.
 Proof.
-intros n m p. rewrite <- Zadd_sub_assoc, <- (Zadd_opp_r n p), <- Zadd_assoc.
-now rewrite Zadd_opp_l.
+intros n m p. rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc.
+now rewrite add_opp_l.
 Qed.
 
-Theorem Zsub_cancel_l : forall n m p : Z, n - m == n - p <-> m == p.
+Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p.
 Proof.
-intros n m p. rewrite <- (Zadd_cancel_l (n - m) (n - p) (- n)).
-do 2 rewrite Zadd_sub_assoc. rewrite Zadd_opp_diag_l; do 2 rewrite Zsub_0_l.
-apply Zopp_inj_wd.
+intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)).
+do 2 rewrite add_sub_assoc. rewrite add_opp_diag_l; do 2 rewrite sub_0_l.
+apply opp_inj_wd.
 Qed.
 
-Theorem Zsub_cancel_r : forall n m p : Z, n - p == m - p <-> n == m.
+Theorem sub_cancel_r : forall n m p, n - p == m - p <-> n == m.
 Proof.
 intros n m p.
-stepl (n - p + p == m - p + p) by apply Zadd_cancel_r.
-now do 2 rewrite <- Zsub_sub_distr, Zsub_diag, Zsub_0_r.
+stepl (n - p + p == m - p + p) by apply add_cancel_r.
+now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r.
 Qed.
 
-(* The next several theorems are devoted to moving terms from one side of
-an equation to the other. The name contains the operation in the original
-equation (add or sub) and the indication whether the left or right term
-is moved. *)
+(** The next several theorems are devoted to moving terms from one
+    side of an equation to the other. The name contains the operation
+    in the original equation ([add] or [sub]) and the indication
+    whether the left or right term is moved. *)
 
-Theorem Zadd_move_l : forall n m p : Z, n + m == p <-> m == p - n.
+Theorem add_move_l : forall n m p, n + m == p <-> m == p - n.
 Proof.
 intros n m p.
-stepl (n + m - n == p - n) by apply Zsub_cancel_r.
-now rewrite Zadd_comm, <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r.
+stepl (n + m - n == p - n) by apply sub_cancel_r.
+now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r.
 Qed.
 
-Theorem Zadd_move_r : forall n m p : Z, n + m == p <-> n == p - m.
+Theorem add_move_r : forall n m p, n + m == p <-> n == p - m.
 Proof.
-intros n m p; rewrite Zadd_comm; now apply Zadd_move_l.
+intros n m p; rewrite add_comm; now apply add_move_l.
 Qed.
 
-(* The two theorems above do not allow rewriting subformulas of the form
-n - m == p to n == p + m since subtraction is in the right-hand side of
-the equation. Hence the following two theorems. *)
+(** The two theorems above do not allow rewriting subformulas of the
+    form [n - m == p] to [n == p + m] since subtraction is in the
+    right-hand side of the equation. Hence the following two
+    theorems. *)
 
-Theorem Zsub_move_l : forall n m p : Z, n - m == p <-> - m == p - n.
+Theorem sub_move_l : forall n m p, n - m == p <-> - m == p - n.
 Proof.
-intros n m p; rewrite <- (Zadd_opp_r n m); apply Zadd_move_l.
+intros n m p; rewrite <- (add_opp_r n m); apply add_move_l.
 Qed.
 
-Theorem Zsub_move_r : forall n m p : Z, n - m == p <-> n == p + m.
+Theorem sub_move_r : forall n m p, n - m == p <-> n == p + m.
 Proof.
-intros n m p; rewrite <- (Zadd_opp_r n m). now rewrite Zadd_move_r, Zsub_opp_r.
+intros n m p; rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r.
 Qed.
 
-Theorem Zadd_move_0_l : forall n m : Z, n + m == 0 <-> m == - n.
+Theorem add_move_0_l : forall n m, n + m == 0 <-> m == - n.
 Proof.
-intros n m; now rewrite Zadd_move_l, Zsub_0_l.
+intros n m; now rewrite add_move_l, sub_0_l.
 Qed.
 
-Theorem Zadd_move_0_r : forall n m : Z, n + m == 0 <-> n == - m.
+Theorem add_move_0_r : forall n m, n + m == 0 <-> n == - m.
 Proof.
-intros n m; now rewrite Zadd_move_r, Zsub_0_l.
+intros n m; now rewrite add_move_r, sub_0_l.
 Qed.
 
-Theorem Zsub_move_0_l : forall n m : Z, n - m == 0 <-> - m == - n.
+Theorem sub_move_0_l : forall n m, n - m == 0 <-> - m == - n.
 Proof.
-intros n m. now rewrite Zsub_move_l, Zsub_0_l.
+intros n m. now rewrite sub_move_l, sub_0_l.
 Qed.
 
-Theorem Zsub_move_0_r : forall n m : Z, n - m == 0 <-> n == m.
+Theorem sub_move_0_r : forall n m, n - m == 0 <-> n == m.
 Proof.
-intros n m. now rewrite Zsub_move_r, Zadd_0_l.
+intros n m. now rewrite sub_move_r, add_0_l.
 Qed.
 
-(* The following section is devoted to cancellation of like terms. The name
-includes the first operator and the position of the term being canceled. *)
+(** The following section is devoted to cancellation of like
+    terms. The name includes the first operator and the position of
+    the term being canceled. *)
 
-Theorem Zadd_simpl_l : forall n m : Z, n + m - n == m.
+Theorem add_simpl_l : forall n m, n + m - n == m.
 Proof.
-intros; now rewrite Zadd_sub_swap, Zsub_diag, Zadd_0_l.
+intros; now rewrite add_sub_swap, sub_diag, add_0_l.
 Qed.
 
-Theorem Zadd_simpl_r : forall n m : Z, n + m - m == n.
+Theorem add_simpl_r : forall n m, n + m - m == n.
 Proof.
-intros; now rewrite <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r.
+intros; now rewrite <- add_sub_assoc, sub_diag, add_0_r.
 Qed.
 
-Theorem Zsub_simpl_l : forall n m : Z, - n - m + n == - m.
+Theorem sub_simpl_l : forall n m, - n - m + n == - m.
 Proof.
-intros; now rewrite <- Zadd_sub_swap, Zadd_opp_diag_l, Zsub_0_l.
+intros; now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l.
 Qed.
 
-Theorem Zsub_simpl_r : forall n m : Z, n - m + m == n.
+Theorem sub_simpl_r : forall n m, n - m + m == n.
 Proof.
-intros; now rewrite <- Zsub_sub_distr, Zsub_diag, Zsub_0_r.
+intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r.
 Qed.
 
-(* Now we have two sums or differences; the name includes the two operators
-and the position of the terms being canceled *)
+(** Now we have two sums or differences; the name includes the two
+    operators and the position of the terms being canceled *)
 
-Theorem Zadd_add_simpl_l_l : forall n m p : Z, (n + m) - (n + p) == m - p.
+Theorem add_add_simpl_l_l : forall n m p, (n + m) - (n + p) == m - p.
 Proof.
-intros n m p. now rewrite (Zadd_comm n m), <- Zadd_sub_assoc,
-Zsub_add_distr, Zsub_diag, Zsub_0_l, Zadd_opp_r.
+intros n m p. now rewrite (add_comm n m), <- add_sub_assoc,
+sub_add_distr, sub_diag, sub_0_l, add_opp_r.
 Qed.
 
-Theorem Zadd_add_simpl_l_r : forall n m p : Z, (n + m) - (p + n) == m - p.
+Theorem add_add_simpl_l_r : forall n m p, (n + m) - (p + n) == m - p.
 Proof.
-intros n m p. rewrite (Zadd_comm p n); apply Zadd_add_simpl_l_l.
+intros n m p. rewrite (add_comm p n); apply add_add_simpl_l_l.
 Qed.
 
-Theorem Zadd_add_simpl_r_l : forall n m p : Z, (n + m) - (m + p) == n - p.
+Theorem add_add_simpl_r_l : forall n m p, (n + m) - (m + p) == n - p.
 Proof.
-intros n m p. rewrite (Zadd_comm n m); apply Zadd_add_simpl_l_l.
+intros n m p. rewrite (add_comm n m); apply add_add_simpl_l_l.
 Qed.
 
-Theorem Zadd_add_simpl_r_r : forall n m p : Z, (n + m) - (p + m) == n - p.
+Theorem add_add_simpl_r_r : forall n m p, (n + m) - (p + m) == n - p.
 Proof.
-intros n m p. rewrite (Zadd_comm p m); apply Zadd_add_simpl_r_l.
+intros n m p. rewrite (add_comm p m); apply add_add_simpl_r_l.
 Qed.
 
-Theorem Zsub_add_simpl_r_l : forall n m p : Z, (n - m) + (m + p) == n + p.
+Theorem sub_add_simpl_r_l : forall n m p, (n - m) + (m + p) == n + p.
 Proof.
-intros n m p. now rewrite <- Zsub_sub_distr, Zsub_add_distr, Zsub_diag,
-Zsub_0_l, Zsub_opp_r.
+intros n m p. now rewrite <- sub_sub_distr, sub_add_distr, sub_diag,
+sub_0_l, sub_opp_r.
 Qed.
 
-Theorem Zsub_add_simpl_r_r : forall n m p : Z, (n - m) + (p + m) == n + p.
+Theorem sub_add_simpl_r_r : forall n m p, (n - m) + (p + m) == n + p.
 Proof.
-intros n m p. rewrite (Zadd_comm p m); apply Zsub_add_simpl_r_l.
+intros n m p. rewrite (add_comm p m); apply sub_add_simpl_r_l.
 Qed.
 
-(* Of course, there are many other variants *)
+(** Of course, there are many other variants *)
 
 End ZAddPropFunct.
 
diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v
index 101ea634..de12993f 100644
--- a/theories/Numbers/Integer/Abstract/ZAddOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v
@@ -8,365 +8,292 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export ZLt.
 
-Module ZAddOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig).
-Module Export ZOrderPropMod := ZOrderPropFunct ZAxiomsMod.
-Open Local Scope IntScope.
+Module ZAddOrderPropFunct (Import Z : ZAxiomsSig').
+Include ZOrderPropFunct Z.
 
-(* Theorems that are true on both natural numbers and integers *)
+(** Theorems that are either not valid on N or have different proofs
+    on N and Z *)
 
-Theorem Zadd_lt_mono_l : forall n m p : Z, n < m <-> p + n < p + m.
-Proof NZadd_lt_mono_l.
-
-Theorem Zadd_lt_mono_r : forall n m p : Z, n < m <-> n + p < m + p.
-Proof NZadd_lt_mono_r.
-
-Theorem Zadd_lt_mono : forall n m p q : Z, n < m -> p < q -> n + p < m + q.
-Proof NZadd_lt_mono.
-
-Theorem Zadd_le_mono_l : forall n m p : Z, n <= m <-> p + n <= p + m.
-Proof NZadd_le_mono_l.
-
-Theorem Zadd_le_mono_r : forall n m p : Z, n <= m <-> n + p <= m + p.
-Proof NZadd_le_mono_r.
-
-Theorem Zadd_le_mono : forall n m p q : Z, n <= m -> p <= q -> n + p <= m + q.
-Proof NZadd_le_mono.
-
-Theorem Zadd_lt_le_mono : forall n m p q : Z, n < m -> p <= q -> n + p < m + q.
-Proof NZadd_lt_le_mono.
-
-Theorem Zadd_le_lt_mono : forall n m p q : Z, n <= m -> p < q -> n + p < m + q.
-Proof NZadd_le_lt_mono.
-
-Theorem Zadd_pos_pos : forall n m : Z, 0 < n -> 0 < m -> 0 < n + m.
-Proof NZadd_pos_pos.
-
-Theorem Zadd_pos_nonneg : forall n m : Z, 0 < n -> 0 <= m -> 0 < n + m.
-Proof NZadd_pos_nonneg.
-
-Theorem Zadd_nonneg_pos : forall n m : Z, 0 <= n -> 0 < m -> 0 < n + m.
-Proof NZadd_nonneg_pos.
-
-Theorem Zadd_nonneg_nonneg : forall n m : Z, 0 <= n -> 0 <= m -> 0 <= n + m.
-Proof NZadd_nonneg_nonneg.
-
-Theorem Zlt_add_pos_l : forall n m : Z, 0 < n -> m < n + m.
-Proof NZlt_add_pos_l.
-
-Theorem Zlt_add_pos_r : forall n m : Z, 0 < n -> m < m + n.
-Proof NZlt_add_pos_r.
-
-Theorem Zle_lt_add_lt : forall n m p q : Z, n <= m -> p + m < q + n -> p < q.
-Proof NZle_lt_add_lt.
-
-Theorem Zlt_le_add_lt : forall n m p q : Z, n < m -> p + m <= q + n -> p < q.
-Proof NZlt_le_add_lt.
-
-Theorem Zle_le_add_le : forall n m p q : Z, n <= m -> p + m <= q + n -> p <= q.
-Proof NZle_le_add_le.
-
-Theorem Zadd_lt_cases : forall n m p q : Z, n + m < p + q -> n < p \/ m < q.
-Proof NZadd_lt_cases.
-
-Theorem Zadd_le_cases : forall n m p q : Z, n + m <= p + q -> n <= p \/ m <= q.
-Proof NZadd_le_cases.
-
-Theorem Zadd_neg_cases : forall n m : Z, n + m < 0 -> n < 0 \/ m < 0.
-Proof NZadd_neg_cases.
-
-Theorem Zadd_pos_cases : forall n m : Z, 0 < n + m -> 0 < n \/ 0 < m.
-Proof NZadd_pos_cases.
-
-Theorem Zadd_nonpos_cases : forall n m : Z, n + m <= 0 -> n <= 0 \/ m <= 0.
-Proof NZadd_nonpos_cases.
-
-Theorem Zadd_nonneg_cases : forall n m : Z, 0 <= n + m -> 0 <= n \/ 0 <= m.
-Proof NZadd_nonneg_cases.
-
-(* Theorems that are either not valid on N or have different proofs on N and Z *)
-
-Theorem Zadd_neg_neg : forall n m : Z, n < 0 -> m < 0 -> n + m < 0.
+Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_lt_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono.
 Qed.
 
-Theorem Zadd_neg_nonpos : forall n m : Z, n < 0 -> m <= 0 -> n + m < 0.
+Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_lt_le_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
 Qed.
 
-Theorem Zadd_nonpos_neg : forall n m : Z, n <= 0 -> m < 0 -> n + m < 0.
+Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0.
 Proof.
-intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_le_lt_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
 Qed.
 
-Theorem Zadd_nonpos_nonpos : forall n m : Z, n <= 0 -> m <= 0 -> n + m <= 0.
+Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0.
 Proof.
-intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_le_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono.
 Qed.
 
 (** Sub and order *)
 
-Theorem Zlt_0_sub : forall n m : Z, 0 < m - n <-> n < m.
+Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m.
 Proof.
-intros n m. stepl (0 + n < m - n + n) by symmetry; apply Zadd_lt_mono_r.
-rewrite Zadd_0_l; now rewrite Zsub_simpl_r.
+intros n m. stepl (0 + n < m - n + n) by symmetry; apply add_lt_mono_r.
+rewrite add_0_l; now rewrite sub_simpl_r.
 Qed.
 
-Notation Zsub_pos := Zlt_0_sub (only parsing).
+Notation sub_pos := lt_0_sub (only parsing).
 
-Theorem Zle_0_sub : forall n m : Z, 0 <= m - n <-> n <= m.
+Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m.
 Proof.
-intros n m; stepl (0 + n <= m - n + n) by symmetry; apply Zadd_le_mono_r.
-rewrite Zadd_0_l; now rewrite Zsub_simpl_r.
+intros n m; stepl (0 + n <= m - n + n) by symmetry; apply add_le_mono_r.
+rewrite add_0_l; now rewrite sub_simpl_r.
 Qed.
 
-Notation Zsub_nonneg := Zle_0_sub (only parsing).
+Notation sub_nonneg := le_0_sub (only parsing).
 
-Theorem Zlt_sub_0 : forall n m : Z, n - m < 0 <-> n < m.
+Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m.
 Proof.
-intros n m. stepl (n - m + m < 0 + m) by symmetry; apply Zadd_lt_mono_r.
-rewrite Zadd_0_l; now rewrite Zsub_simpl_r.
+intros n m. stepl (n - m + m < 0 + m) by symmetry; apply add_lt_mono_r.
+rewrite add_0_l; now rewrite sub_simpl_r.
 Qed.
 
-Notation Zsub_neg := Zlt_sub_0 (only parsing).
+Notation sub_neg := lt_sub_0 (only parsing).
 
-Theorem Zle_sub_0 : forall n m : Z, n - m <= 0 <-> n <= m.
+Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m.
 Proof.
-intros n m. stepl (n - m + m <= 0 + m) by symmetry; apply Zadd_le_mono_r.
-rewrite Zadd_0_l; now rewrite Zsub_simpl_r.
+intros n m. stepl (n - m + m <= 0 + m) by symmetry; apply add_le_mono_r.
+rewrite add_0_l; now rewrite sub_simpl_r.
 Qed.
 
-Notation Zsub_nonpos := Zle_sub_0 (only parsing).
+Notation sub_nonpos := le_sub_0 (only parsing).
 
-Theorem Zopp_lt_mono : forall n m : Z, n < m <-> - m < - n.
+Theorem opp_lt_mono : forall n m, n < m <-> - m < - n.
 Proof.
-intros n m. stepr (m + - m < m + - n) by symmetry; apply Zadd_lt_mono_l.
-do 2 rewrite Zadd_opp_r. rewrite Zsub_diag. symmetry; apply Zlt_0_sub.
+intros n m. stepr (m + - m < m + - n) by symmetry; apply add_lt_mono_l.
+do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply lt_0_sub.
 Qed.
 
-Theorem Zopp_le_mono : forall n m : Z, n <= m <-> - m <= - n.
+Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n.
 Proof.
-intros n m. stepr (m + - m <= m + - n) by symmetry; apply Zadd_le_mono_l.
-do 2 rewrite Zadd_opp_r. rewrite Zsub_diag. symmetry; apply Zle_0_sub.
+intros n m. stepr (m + - m <= m + - n) by symmetry; apply add_le_mono_l.
+do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply le_0_sub.
 Qed.
 
-Theorem Zopp_pos_neg : forall n : Z, 0 < - n <-> n < 0.
+Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0.
 Proof.
-intro n; rewrite (Zopp_lt_mono n 0); now rewrite Zopp_0.
+intro n; rewrite (opp_lt_mono n 0); now rewrite opp_0.
 Qed.
 
-Theorem Zopp_neg_pos : forall n : Z, - n < 0 <-> 0 < n.
+Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n.
 Proof.
-intro n. rewrite (Zopp_lt_mono 0 n). now rewrite Zopp_0.
+intro n. rewrite (opp_lt_mono 0 n). now rewrite opp_0.
 Qed.
 
-Theorem Zopp_nonneg_nonpos : forall n : Z, 0 <= - n <-> n <= 0.
+Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0.
 Proof.
-intro n; rewrite (Zopp_le_mono n 0); now rewrite Zopp_0.
+intro n; rewrite (opp_le_mono n 0); now rewrite opp_0.
 Qed.
 
-Theorem Zopp_nonpos_nonneg : forall n : Z, - n <= 0 <-> 0 <= n.
+Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n.
 Proof.
-intro n. rewrite (Zopp_le_mono 0 n). now rewrite Zopp_0.
+intro n. rewrite (opp_le_mono 0 n). now rewrite opp_0.
 Qed.
 
-Theorem Zsub_lt_mono_l : forall n m p : Z, n < m <-> p - m < p - n.
+Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n.
 Proof.
-intros n m p. do 2 rewrite <- Zadd_opp_r. rewrite <- Zadd_lt_mono_l.
-apply Zopp_lt_mono.
+intros n m p. do 2 rewrite <- add_opp_r. rewrite <- add_lt_mono_l.
+apply opp_lt_mono.
 Qed.
 
-Theorem Zsub_lt_mono_r : forall n m p : Z, n < m <-> n - p < m - p.
+Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p.
 Proof.
-intros n m p; do 2 rewrite <- Zadd_opp_r; apply Zadd_lt_mono_r.
+intros n m p; do 2 rewrite <- add_opp_r; apply add_lt_mono_r.
 Qed.
 
-Theorem Zsub_lt_mono : forall n m p q : Z, n < m -> q < p -> n - p < m - q.
+Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q.
 Proof.
 intros n m p q H1 H2.
-apply NZlt_trans with (m - p);
-[now apply -> Zsub_lt_mono_r | now apply -> Zsub_lt_mono_l].
+apply lt_trans with (m - p);
+[now apply -> sub_lt_mono_r | now apply -> sub_lt_mono_l].
 Qed.
 
-Theorem Zsub_le_mono_l : forall n m p : Z, n <= m <-> p - m <= p - n.
+Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n.
 Proof.
-intros n m p; do 2 rewrite <- Zadd_opp_r; rewrite <- Zadd_le_mono_l;
-apply Zopp_le_mono.
+intros n m p; do 2 rewrite <- add_opp_r; rewrite <- add_le_mono_l;
+apply opp_le_mono.
 Qed.
 
-Theorem Zsub_le_mono_r : forall n m p : Z, n <= m <-> n - p <= m - p.
+Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p.
 Proof.
-intros n m p; do 2 rewrite <- Zadd_opp_r; apply Zadd_le_mono_r.
+intros n m p; do 2 rewrite <- add_opp_r; apply add_le_mono_r.
 Qed.
 
-Theorem Zsub_le_mono : forall n m p q : Z, n <= m -> q <= p -> n - p <= m - q.
+Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q.
 Proof.
 intros n m p q H1 H2.
-apply NZle_trans with (m - p);
-[now apply -> Zsub_le_mono_r | now apply -> Zsub_le_mono_l].
+apply le_trans with (m - p);
+[now apply -> sub_le_mono_r | now apply -> sub_le_mono_l].
 Qed.
 
-Theorem Zsub_lt_le_mono : forall n m p q : Z, n < m -> q <= p -> n - p < m - q.
+Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q.
 Proof.
 intros n m p q H1 H2.
-apply NZlt_le_trans with (m - p);
-[now apply -> Zsub_lt_mono_r | now apply -> Zsub_le_mono_l].
+apply lt_le_trans with (m - p);
+[now apply -> sub_lt_mono_r | now apply -> sub_le_mono_l].
 Qed.
 
-Theorem Zsub_le_lt_mono : forall n m p q : Z, n <= m -> q < p -> n - p < m - q.
+Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q.
 Proof.
 intros n m p q H1 H2.
-apply NZle_lt_trans with (m - p);
-[now apply -> Zsub_le_mono_r | now apply -> Zsub_lt_mono_l].
+apply le_lt_trans with (m - p);
+[now apply -> sub_le_mono_r | now apply -> sub_lt_mono_l].
 Qed.
 
-Theorem Zle_lt_sub_lt : forall n m p q : Z, n <= m -> p - n < q - m -> p < q.
+Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q.
 Proof.
-intros n m p q H1 H2. apply (Zle_lt_add_lt (- m) (- n));
-[now apply -> Zopp_le_mono | now do 2 rewrite Zadd_opp_r].
+intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n));
+[now apply -> opp_le_mono | now do 2 rewrite add_opp_r].
 Qed.
 
-Theorem Zlt_le_sub_lt : forall n m p q : Z, n < m -> p - n <= q - m -> p < q.
+Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q.
 Proof.
-intros n m p q H1 H2. apply (Zlt_le_add_lt (- m) (- n));
-[now apply -> Zopp_lt_mono | now do 2 rewrite Zadd_opp_r].
+intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n));
+[now apply -> opp_lt_mono | now do 2 rewrite add_opp_r].
 Qed.
 
-Theorem Zle_le_sub_lt : forall n m p q : Z, n <= m -> p - n <= q - m -> p <= q.
+Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q.
 Proof.
-intros n m p q H1 H2. apply (Zle_le_add_le (- m) (- n));
-[now apply -> Zopp_le_mono | now do 2 rewrite Zadd_opp_r].
+intros n m p q H1 H2. apply (le_le_add_le (- m) (- n));
+[now apply -> opp_le_mono | now do 2 rewrite add_opp_r].
 Qed.
 
-Theorem Zlt_add_lt_sub_r : forall n m p : Z, n + p < m <-> n < m - p.
+Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p.
 Proof.
-intros n m p. stepl (n + p - p < m - p) by symmetry; apply Zsub_lt_mono_r.
-now rewrite Zadd_simpl_r.
+intros n m p. stepl (n + p - p < m - p) by symmetry; apply sub_lt_mono_r.
+now rewrite add_simpl_r.
 Qed.
 
-Theorem Zle_add_le_sub_r : forall n m p : Z, n + p <= m <-> n <= m - p.
+Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p.
 Proof.
-intros n m p. stepl (n + p - p <= m - p) by symmetry; apply Zsub_le_mono_r.
-now rewrite Zadd_simpl_r.
+intros n m p. stepl (n + p - p <= m - p) by symmetry; apply sub_le_mono_r.
+now rewrite add_simpl_r.
 Qed.
 
-Theorem Zlt_add_lt_sub_l : forall n m p : Z, n + p < m <-> p < m - n.
+Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n.
 Proof.
-intros n m p. rewrite Zadd_comm; apply Zlt_add_lt_sub_r.
+intros n m p. rewrite add_comm; apply lt_add_lt_sub_r.
 Qed.
 
-Theorem Zle_add_le_sub_l : forall n m p : Z, n + p <= m <-> p <= m - n.
+Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n.
 Proof.
-intros n m p. rewrite Zadd_comm; apply Zle_add_le_sub_r.
+intros n m p. rewrite add_comm; apply le_add_le_sub_r.
 Qed.
 
-Theorem Zlt_sub_lt_add_r : forall n m p : Z, n - p < m <-> n < m + p.
+Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p.
 Proof.
-intros n m p. stepl (n - p + p < m + p) by symmetry; apply Zadd_lt_mono_r.
-now rewrite Zsub_simpl_r.
+intros n m p. stepl (n - p + p < m + p) by symmetry; apply add_lt_mono_r.
+now rewrite sub_simpl_r.
 Qed.
 
-Theorem Zle_sub_le_add_r : forall n m p : Z, n - p <= m <-> n <= m + p.
+Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p.
 Proof.
-intros n m p. stepl (n - p + p <= m + p) by symmetry; apply Zadd_le_mono_r.
-now rewrite Zsub_simpl_r.
+intros n m p. stepl (n - p + p <= m + p) by symmetry; apply add_le_mono_r.
+now rewrite sub_simpl_r.
 Qed.
 
-Theorem Zlt_sub_lt_add_l : forall n m p : Z, n - m < p <-> n < m + p.
+Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p.
 Proof.
-intros n m p. rewrite Zadd_comm; apply Zlt_sub_lt_add_r.
+intros n m p. rewrite add_comm; apply lt_sub_lt_add_r.
 Qed.
 
-Theorem Zle_sub_le_add_l : forall n m p : Z, n - m <= p <-> n <= m + p.
+Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p.
 Proof.
-intros n m p. rewrite Zadd_comm; apply Zle_sub_le_add_r.
+intros n m p. rewrite add_comm; apply le_sub_le_add_r.
 Qed.
 
-Theorem Zlt_sub_lt_add : forall n m p q : Z, n - m < p - q <-> n + q < m + p.
+Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p.
 Proof.
-intros n m p q. rewrite Zlt_sub_lt_add_l. rewrite Zadd_sub_assoc.
-now rewrite <- Zlt_add_lt_sub_r.
+intros n m p q. rewrite lt_sub_lt_add_l. rewrite add_sub_assoc.
+now rewrite <- lt_add_lt_sub_r.
 Qed.
 
-Theorem Zle_sub_le_add : forall n m p q : Z, n - m <= p - q <-> n + q <= m + p.
+Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p.
 Proof.
-intros n m p q. rewrite Zle_sub_le_add_l. rewrite Zadd_sub_assoc.
-now rewrite <- Zle_add_le_sub_r.
+intros n m p q. rewrite le_sub_le_add_l. rewrite add_sub_assoc.
+now rewrite <- le_add_le_sub_r.
 Qed.
 
-Theorem Zlt_sub_pos : forall n m : Z, 0 < m <-> n - m < n.
+Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n.
 Proof.
-intros n m. stepr (n - m < n - 0) by now rewrite Zsub_0_r. apply Zsub_lt_mono_l.
+intros n m. stepr (n - m < n - 0) by now rewrite sub_0_r. apply sub_lt_mono_l.
 Qed.
 
-Theorem Zle_sub_nonneg : forall n m : Z, 0 <= m <-> n - m <= n.
+Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n.
 Proof.
-intros n m. stepr (n - m <= n - 0) by now rewrite Zsub_0_r. apply Zsub_le_mono_l.
+intros n m. stepr (n - m <= n - 0) by now rewrite sub_0_r. apply sub_le_mono_l.
 Qed.
 
-Theorem Zsub_lt_cases : forall n m p q : Z, n - m < p - q -> n < m \/ q < p.
+Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p.
 Proof.
-intros n m p q H. rewrite Zlt_sub_lt_add in H. now apply Zadd_lt_cases.
+intros n m p q H. rewrite lt_sub_lt_add in H. now apply add_lt_cases.
 Qed.
 
-Theorem Zsub_le_cases : forall n m p q : Z, n - m <= p - q -> n <= m \/ q <= p.
+Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p.
 Proof.
-intros n m p q H. rewrite Zle_sub_le_add in H. now apply Zadd_le_cases.
+intros n m p q H. rewrite le_sub_le_add in H. now apply add_le_cases.
 Qed.
 
-Theorem Zsub_neg_cases : forall n m : Z, n - m < 0 -> n < 0 \/ 0 < m.
+Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m.
 Proof.
-intros n m H; rewrite <- Zadd_opp_r in H.
-setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply Zopp_neg_pos).
-now apply Zadd_neg_cases.
+intros n m H; rewrite <- add_opp_r in H.
+setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply opp_neg_pos).
+now apply add_neg_cases.
 Qed.
 
-Theorem Zsub_pos_cases : forall n m : Z, 0 < n - m -> 0 < n \/ m < 0.
+Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0.
 Proof.
-intros n m H; rewrite <- Zadd_opp_r in H.
-setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply Zopp_pos_neg).
-now apply Zadd_pos_cases.
+intros n m H; rewrite <- add_opp_r in H.
+setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply opp_pos_neg).
+now apply add_pos_cases.
 Qed.
 
-Theorem Zsub_nonpos_cases : forall n m : Z, n - m <= 0 -> n <= 0 \/ 0 <= m.
+Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m.
 Proof.
-intros n m H; rewrite <- Zadd_opp_r in H.
-setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply Zopp_nonpos_nonneg).
-now apply Zadd_nonpos_cases.
+intros n m H; rewrite <- add_opp_r in H.
+setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply opp_nonpos_nonneg).
+now apply add_nonpos_cases.
 Qed.
 
-Theorem Zsub_nonneg_cases : forall n m : Z, 0 <= n - m -> 0 <= n \/ m <= 0.
+Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0.
 Proof.
-intros n m H; rewrite <- Zadd_opp_r in H.
-setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply Zopp_nonneg_nonpos).
-now apply Zadd_nonneg_cases.
+intros n m H; rewrite <- add_opp_r in H.
+setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply opp_nonneg_nonpos).
+now apply add_nonneg_cases.
 Qed.
 
 Section PosNeg.
 
-Variable P : Z -> Prop.
-Hypothesis P_wd : predicate_wd Zeq P.
-
-Add Morphism P with signature Zeq ==> iff as P_morph. Proof. exact P_wd. Qed.
+Variable P : Z.t -> Prop.
+Hypothesis P_wd : Proper (Z.eq ==> iff) P.
 
-Theorem Z0_pos_neg :
-  P 0 -> (forall n : Z, 0 < n -> P n /\ P (- n)) -> forall n : Z, P n.
+Theorem zero_pos_neg :
+  P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n.
 Proof.
-intros H1 H2 n. destruct (Zlt_trichotomy n 0) as [H3 | [H3 | H3]].
-apply <- Zopp_pos_neg in H3. apply H2 in H3. destruct H3 as [_ H3].
-now rewrite Zopp_involutive in H3.
+intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]].
+apply <- opp_pos_neg in H3. apply H2 in H3. destruct H3 as [_ H3].
+now rewrite opp_involutive in H3.
 now rewrite H3.
 apply H2 in H3; now destruct H3.
 Qed.
 
 End PosNeg.
 
-Ltac Z0_pos_neg n := induction_maker n ltac:(apply Z0_pos_neg).
+Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg).
 
 End ZAddOrderPropFunct.
 
diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v
index c4a4b6b8..9158a214 100644
--- a/theories/Numbers/Integer/Abstract/ZAxioms.v
+++ b/theories/Numbers/Integer/Abstract/ZAxioms.v
@@ -8,58 +8,31 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export NZAxioms.
 
 Set Implicit Arguments.
 
-Module Type ZAxiomsSig.
-Declare Module Export NZOrdAxiomsMod : NZOrdAxiomsSig.
+Module Type Opp (Import T:Typ).
+ Parameter Inline opp : t -> t.
+End Opp.
 
-Delimit Scope IntScope with Int.
-Notation Z := NZ.
-Notation Zeq := NZeq.
-Notation Z0 := NZ0.
-Notation Z1 := (NZsucc NZ0).
-Notation S := NZsucc.
-Notation P := NZpred.
-Notation Zadd := NZadd.
-Notation Zmul := NZmul.
-Notation Zsub := NZsub.
-Notation Zlt := NZlt.
-Notation Zle := NZle.
-Notation Zmin := NZmin.
-Notation Zmax := NZmax.
-Notation "x == y"  := (NZeq x y) (at level 70) : IntScope.
-Notation "x ~= y" := (~ NZeq x y) (at level 70) : IntScope.
-Notation "0" := NZ0 : IntScope.
-Notation "1" := (NZsucc NZ0) : IntScope.
-Notation "x + y" := (NZadd x y) : IntScope.
-Notation "x - y" := (NZsub x y) : IntScope.
-Notation "x * y" := (NZmul x y) : IntScope.
-Notation "x < y" := (NZlt x y) : IntScope.
-Notation "x <= y" := (NZle x y) : IntScope.
-Notation "x > y" := (NZlt y x) (only parsing) : IntScope.
-Notation "x >= y" := (NZle y x) (only parsing) : IntScope.
+Module Type OppNotation (T:Typ)(Import O : Opp T).
+ Notation "- x" := (opp x) (at level 35, right associativity).
+End OppNotation.
 
-Parameter Zopp : Z -> Z.
+Module Type Opp' (T:Typ) := Opp T <+ OppNotation T.
 
-(*Notation "- 1" := (Zopp 1) : IntScope.
-Check (-1).*)
+(** We obtain integers by postulating that every number has a predecessor. *)
 
-Add Morphism Zopp with signature Zeq ==> Zeq as Zopp_wd.
+Module Type IsOpp (Import Z : NZAxiomsSig')(Import O : Opp' Z).
+ Declare Instance opp_wd : Proper (eq==>eq) opp.
+ Axiom succ_pred : forall n, S (P n) == n.
+ Axiom opp_0 : - 0 == 0.
+ Axiom opp_succ : forall n, - (S n) == P (- n).
+End IsOpp.
 
-Notation "- x" := (Zopp x) (at level 35, right associativity) : IntScope.
-Notation "- 1" := (Zopp (NZsucc NZ0)) : IntScope.
-
-Open Local Scope IntScope.
-
-(* Integers are obtained by postulating that every number has a predecessor *)
-Axiom Zsucc_pred : forall n : Z, S (P n) == n.
-
-Axiom Zopp_0 : - 0 == 0.
-Axiom Zopp_succ : forall n : Z, - (S n) == P (- n).
-
-End ZAxiomsSig.
+Module Type ZAxiomsSig := NZOrdAxiomsSig <+ Opp <+ IsOpp.
+Module Type ZAxiomsSig' := NZOrdAxiomsSig' <+ Opp' <+ IsOpp.
 
diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v
index 0f71f2cc..44bb02ec 100644
--- a/theories/Numbers/Integer/Abstract/ZBase.v
+++ b/theories/Numbers/Integer/Abstract/ZBase.v
@@ -8,78 +8,25 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export Decidable.
 Require Export ZAxioms.
-Require Import NZMulOrder.
+Require Import NZProperties.
 
-Module ZBasePropFunct (Import ZAxiomsMod : ZAxiomsSig).
-
-(* Note: writing "Export" instead of "Import" on the previous line leads to
-some warnings about hiding repeated declarations and results in the loss of
-notations in Zadd and later *)
-
-Open Local Scope IntScope.
-
-Module Export NZMulOrderMod := NZMulOrderPropFunct NZOrdAxiomsMod.
-
-Theorem Zsucc_wd : forall n1 n2 : Z, n1 == n2 -> S n1 == S n2.
-Proof NZsucc_wd.
-
-Theorem Zpred_wd : forall n1 n2 : Z, n1 == n2 -> P n1 == P n2.
-Proof NZpred_wd.
-
-Theorem Zpred_succ : forall n : Z, P (S n) == n.
-Proof NZpred_succ.
-
-Theorem Zeq_refl : forall n : Z, n == n.
-Proof (proj1 NZeq_equiv).
-
-Theorem Zeq_sym : forall n m : Z, n == m -> m == n.
-Proof (proj2 (proj2 NZeq_equiv)).
-
-Theorem Zeq_trans : forall n m p : Z, n == m -> m == p -> n == p.
-Proof (proj1 (proj2 NZeq_equiv)).
-
-Theorem Zneq_sym : forall n m : Z, n ~= m -> m ~= n.
-Proof NZneq_sym.
-
-Theorem Zsucc_inj : forall n1 n2 : Z, S n1 == S n2 -> n1 == n2.
-Proof NZsucc_inj.
-
-Theorem Zsucc_inj_wd : forall n1 n2 : Z, S n1 == S n2 <-> n1 == n2.
-Proof NZsucc_inj_wd.
-
-Theorem Zsucc_inj_wd_neg : forall n m : Z, S n ~= S m <-> n ~= m.
-Proof NZsucc_inj_wd_neg.
-
-(* Decidability and stability of equality was proved only in NZOrder, but
-since it does not mention order, we'll put it here *)
-
-Theorem Zeq_dec : forall n m : Z, decidable (n == m).
-Proof NZeq_dec.
-
-Theorem Zeq_dne : forall n m : Z, ~ ~ n == m <-> n == m.
-Proof NZeq_dne.
-
-Theorem Zcentral_induction :
-forall A : Z -> Prop, predicate_wd Zeq A ->
-  forall z : Z, A z ->
-    (forall n : Z, A n <-> A (S n)) ->
-      forall n : Z, A n.
-Proof NZcentral_induction.
+Module ZBasePropFunct (Import Z : ZAxiomsSig').
+Include NZPropFunct Z.
 
 (* Theorems that are true for integers but not for natural numbers *)
 
-Theorem Zpred_inj : forall n m : Z, P n == P m -> n == m.
+Theorem pred_inj : forall n m, P n == P m -> n == m.
 Proof.
-intros n m H. apply NZsucc_wd in H. now do 2 rewrite Zsucc_pred in H.
+intros n m H. apply succ_wd in H. now do 2 rewrite succ_pred in H.
 Qed.
 
-Theorem Zpred_inj_wd : forall n1 n2 : Z, P n1 == P n2 <-> n1 == n2.
+Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2.
 Proof.
-intros n1 n2; split; [apply Zpred_inj | apply NZpred_wd].
+intros n1 n2; split; [apply pred_inj | apply pred_wd].
 Qed.
 
 End ZBasePropFunct.
diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v
new file mode 100644
index 00000000..bcd16fec
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v
@@ -0,0 +1,605 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Euclidean Division for integers, Euclid convention
+
+    We use here the "usual" formulation of the Euclid Theorem
+    [forall a b, b<>0 -> exists b q, a = b*q+r /\ 0 < r < |b| ]
+
+    The outcome of the modulo function is hence always positive.
+    This corresponds to convention "E" in the following paper:
+
+    R. Boute, "The Euclidean definition of the functions div and mod",
+    ACM Transactions on Programming Languages and Systems,
+    Vol. 14, No.2, pp. 127-144, April 1992.
+
+    See files [ZDivTrunc] and [ZDivFloor] for others conventions.
+*)
+
+Require Import ZAxioms ZProperties NZDiv.
+
+Module Type ZDivSpecific (Import Z : ZAxiomsExtSig')(Import DM : DivMod' Z).
+ Axiom mod_always_pos : forall a b, 0 <= a mod b < abs b.
+End ZDivSpecific.
+
+Module Type ZDiv (Z:ZAxiomsExtSig)
+ := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z.
+
+Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv.
+Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation.
+
+Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z).
+
+(** We benefit from what already exists for NZ *)
+
+ Module ZD <: NZDiv Z.
+  Definition div := div.
+  Definition modulo := modulo.
+  Definition div_wd := div_wd.
+  Definition mod_wd := mod_wd.
+  Definition div_mod := div_mod.
+  Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
+  Proof.
+  intros. rewrite <- (abs_eq b) at 3 by now apply lt_le_incl.
+  apply mod_always_pos.
+  Qed.
+ End ZD.
+ Module Import NZDivP := NZDivPropFunct Z ZP ZD.
+
+(** Another formulation of the main equation *)
+
+Lemma mod_eq :
+ forall a b, b~=0 -> a mod b == a - b*(a/b).
+Proof.
+intros.
+rewrite <- add_move_l.
+symmetry. now apply div_mod.
+Qed.
+
+Ltac pos_or_neg a :=
+ let LT := fresh "LT" in
+ let LE := fresh "LE" in
+ destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].
+
+(** Uniqueness theorems *)
+
+Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
+  0<=r1<abs b -> 0<=r2<abs b ->
+  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
+Proof.
+intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
+pos_or_neg b.
+rewrite abs_eq in * by trivial.
+apply div_mod_unique with b; trivial.
+rewrite abs_neq' in * by auto using lt_le_incl.
+rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial.
+rewrite 2 mul_opp_l.
+rewrite add_move_l, sub_opp_r.
+rewrite <-add_assoc.
+symmetry. rewrite add_move_l, sub_opp_r.
+now rewrite (add_comm r2), (add_comm r1).
+Qed.
+
+Theorem div_unique:
+ forall a b q r, 0<=r<abs b -> a == b*q + r -> q == a/b.
+Proof.
+intros a b q r Hr EQ.
+assert (Hb : b~=0).
+ pos_or_neg b.
+ rewrite abs_eq in Hr; intuition; order.
+ rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
+destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
+now apply mod_always_pos.
+now rewrite <- div_mod.
+Qed.
+
+Theorem mod_unique:
+ forall a b q r, 0<=r<abs b -> a == b*q + r -> r == a mod b.
+Proof.
+intros a b q r Hr EQ.
+assert (Hb : b~=0).
+ pos_or_neg b.
+ rewrite abs_eq in Hr; intuition; order.
+ rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
+destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
+now apply mod_always_pos.
+now rewrite <- div_mod.
+Qed.
+
+(** Sign rules *)
+
+Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b).
+Proof.
+intros. symmetry.
+apply div_unique with (a mod b).
+rewrite abs_opp; apply mod_always_pos.
+rewrite mul_opp_opp; now apply div_mod.
+Qed.
+
+Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b.
+Proof.
+intros. symmetry.
+apply mod_unique with (-(a/b)).
+rewrite abs_opp; apply mod_always_pos.
+rewrite mul_opp_opp; now apply div_mod.
+Qed.
+
+Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
+ (-a)/b == -(a/b).
+Proof.
+intros a b Hb Hab. symmetry.
+apply div_unique with (-(a mod b)).
+rewrite Hab, opp_0. split; [order|].
+pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order.
+now rewrite mul_opp_r, <-opp_add_distr, <-div_mod.
+Qed.
+
+Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
+ (-a)/b == -(a/b)-sgn b.
+Proof.
+intros a b Hb Hab. symmetry.
+apply div_unique with (abs b -(a mod b)).
+rewrite lt_sub_lt_add_l.
+rewrite <- le_add_le_sub_l. nzsimpl.
+rewrite <- (add_0_l (abs b)) at 2.
+rewrite <- add_lt_mono_r.
+destruct (mod_always_pos a b); intuition order.
+rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
+rewrite sgn_abs.
+rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
+rewrite <-opp_add_distr, <-div_mod; order.
+Qed.
+
+Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
+ (-a) mod b == 0.
+Proof.
+intros a b Hb Hab. symmetry.
+apply mod_unique with (-(a/b)).
+split; [order|now rewrite abs_pos].
+now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod.
+Qed.
+
+Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
+ (-a) mod b == abs b - (a mod b).
+Proof.
+intros a b Hb Hab. symmetry.
+apply mod_unique with (-(a/b)-sgn b).
+rewrite lt_sub_lt_add_l.
+rewrite <- le_add_le_sub_l. nzsimpl.
+rewrite <- (add_0_l (abs b)) at 2.
+rewrite <- add_lt_mono_r.
+destruct (mod_always_pos a b); intuition order.
+rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
+rewrite sgn_abs.
+rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
+rewrite <-opp_add_distr, <-div_mod; order.
+Qed.
+
+Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
+ (-a)/(-b) == a/b.
+Proof.
+intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive.
+Qed.
+
+Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
+ (-a)/(-b) == a/b + sgn(b).
+Proof.
+intros. rewrite div_opp_r, div_opp_l_nz by trivial.
+now rewrite opp_sub_distr, opp_involutive.
+Qed.
+
+Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
+ (-a) mod (-b) == 0.
+Proof.
+intros. now rewrite mod_opp_r, mod_opp_l_z.
+Qed.
+
+Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
+ (-a) mod (-b) == abs b - a mod b.
+Proof.
+intros. now rewrite mod_opp_r, mod_opp_l_nz.
+Qed.
+
+(** A division by itself returns 1 *)
+
+Lemma div_same : forall a, a~=0 -> a/a == 1.
+Proof.
+intros. symmetry. apply div_unique with 0.
+split; [order|now rewrite abs_pos].
+now nzsimpl.
+Qed.
+
+Lemma mod_same : forall a, a~=0 -> a mod a == 0.
+Proof.
+intros.
+rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
+Qed.
+
+(** A division of a small number by a bigger one yields zero. *)
+
+Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
+Proof. exact div_small. Qed.
+
+(** Same situation, in term of modulo: *)
+
+Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
+Proof. exact mod_small. Qed.
+
+(** * Basic values of divisions and modulo. *)
+
+Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
+Proof.
+intros. pos_or_neg a. apply div_0_l; order.
+apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l.
+Qed.
+
+Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
+Proof.
+intros; rewrite mod_eq, div_0_l; now nzsimpl.
+Qed.
+
+Lemma div_1_r: forall a, a/1 == a.
+Proof.
+intros. symmetry. apply div_unique with 0.
+assert (H:=lt_0_1); rewrite abs_pos; intuition; order.
+now nzsimpl.
+Qed.
+
+Lemma mod_1_r: forall a, a mod 1 == 0.
+Proof.
+intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
+apply neq_sym, lt_neq; apply lt_0_1.
+Qed.
+
+Lemma div_1_l: forall a, 1<a -> 1/a == 0.
+Proof. exact div_1_l. Qed.
+
+Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
+Proof. exact mod_1_l. Qed.
+
+Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
+Proof.
+intros. symmetry. apply div_unique with 0.
+split; [order|now rewrite abs_pos].
+nzsimpl; apply mul_comm.
+Qed.
+
+Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
+Proof.
+intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
+Qed.
+
+(** * Order results about mod and div *)
+
+(** A modulo cannot grow beyond its starting point. *)
+
+Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a.
+Proof.
+intros. pos_or_neg b. apply mod_le; order.
+rewrite <- mod_opp_r by trivial. apply mod_le; order.
+Qed.
+
+Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
+Proof. exact div_pos. Qed.
+
+Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
+Proof. exact div_str_pos. Qed.
+
+Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<abs b).
+Proof.
+intros a b Hb.
+split.
+intros EQ.
+rewrite (div_mod a b Hb), EQ; nzsimpl.
+apply mod_always_pos.
+intros. pos_or_neg b.
+apply div_small.
+now rewrite <- (abs_eq b).
+apply opp_inj; rewrite opp_0, <- div_opp_r by trivial.
+apply div_small.
+rewrite <- (abs_neq' b) by order. trivial.
+Qed.
+
+Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<abs b).
+Proof.
+intros.
+rewrite <- div_small_iff, mod_eq by trivial.
+rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
+rewrite eq_sym_iff, eq_mul_0. tauto.
+Qed.
+
+(** As soon as the divisor is strictly greater than 1,
+    the division is strictly decreasing. *)
+
+Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
+Proof. exact div_lt. Qed.
+
+(** [le] is compatible with a positive division. *)
+
+Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
+Proof.
+intros a b c Hc Hab.
+rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
+ [|rewrite EQ; order].
+rewrite <- lt_succ_r.
+rewrite (mul_lt_mono_pos_l c) by order.
+nzsimpl.
+rewrite (add_lt_mono_r _ _ (a mod c)).
+rewrite <- div_mod by order.
+apply lt_le_trans with b; trivial.
+rewrite (div_mod b c) at 1 by order.
+rewrite <- add_assoc, <- add_le_mono_l.
+apply le_trans with (c+0).
+nzsimpl; destruct (mod_always_pos b c); try order.
+rewrite abs_eq in *; order.
+rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order.
+Qed.
+
+(** In this convention, [div] performs Rounding-Toward-Bottom
+    when divisor is positive, and Rounding-Toward-Top otherwise.
+
+    Since we cannot speak of rational values here, we express this
+    fact by multiplying back by [b], and this leads to a nice
+    unique statement.
+*)
+
+Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
+Proof.
+intros.
+rewrite (div_mod a b) at 2; trivial.
+rewrite <- (add_0_r (b*(a/b))) at 1.
+rewrite <- add_le_mono_l.
+now destruct (mod_always_pos a b).
+Qed.
+
+(** Giving a reversed bound is slightly more complex *)
+
+Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
+Proof.
+intros.
+nzsimpl.
+rewrite (div_mod a b) at 1; try order.
+rewrite <- add_lt_mono_l.
+destruct (mod_always_pos a b).
+rewrite abs_eq in *; order.
+Qed.
+
+Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)).
+Proof.
+intros a b Hb.
+rewrite mul_pred_r, <- add_opp_r.
+rewrite (div_mod a b) at 1; try order.
+rewrite <- add_lt_mono_l.
+destruct (mod_always_pos a b).
+rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order.
+Qed.
+
+(** NB: The three previous properties could be used as
+    specifications for [div]. *)
+
+(** Inequality [mul_div_le] is exact iff the modulo is zero. *)
+
+Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
+Proof.
+intros.
+rewrite (div_mod a b) at 1; try order.
+rewrite <- (add_0_r (b*(a/b))) at 2.
+apply add_cancel_l.
+Qed.
+
+(** Some additionnal inequalities about div. *)
+
+Theorem div_lt_upper_bound:
+  forall a b q, 0<b -> a < b*q -> a/b < q.
+Proof.
+intros.
+rewrite (mul_lt_mono_pos_l b) by trivial.
+apply le_lt_trans with a; trivial.
+apply mul_div_le; order.
+Qed.
+
+Theorem div_le_upper_bound:
+  forall a b q, 0<b -> a <= b*q -> a/b <= q.
+Proof.
+intros.
+rewrite <- (div_mul q b) by order.
+apply div_le_mono; trivial. now rewrite mul_comm.
+Qed.
+
+Theorem div_le_lower_bound:
+  forall a b q, 0<b -> b*q <= a -> q <= a/b.
+Proof.
+intros.
+rewrite <- (div_mul q b) by order.
+apply div_le_mono; trivial. now rewrite mul_comm.
+Qed.
+
+(** A division respects opposite monotonicity for the divisor *)
+
+Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
+Proof. exact div_le_compat_l. Qed.
+
+(** * Relations between usual operations and mod and div *)
+
+Lemma mod_add : forall a b c, c~=0 ->
+ (a + b * c) mod c == a mod c.
+Proof.
+intros.
+symmetry.
+apply mod_unique with (a/c+b); trivial.
+now apply mod_always_pos.
+rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
+now rewrite mul_comm.
+Qed.
+
+Lemma div_add : forall a b c, c~=0 ->
+ (a + b * c) / c == a / c + b.
+Proof.
+intros.
+apply (mul_cancel_l _ _ c); try order.
+apply (add_cancel_r _ _ ((a+b*c) mod c)).
+rewrite <- div_mod, mod_add by order.
+rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
+now rewrite mul_comm.
+Qed.
+
+Lemma div_add_l: forall a b c, b~=0 ->
+ (a * b + c) / b == a + c / b.
+Proof.
+ intros a b c. rewrite (add_comm _ c), (add_comm a).
+ now apply div_add.
+Qed.
+
+(** Cancellations. *)
+
+(** With the current convention, the following isn't always true
+    when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *)
+
+Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0<c ->
+ (a*c)/(b*c) == a/b.
+Proof.
+intros.
+symmetry.
+apply div_unique with ((a mod b)*c).
+(* ineqs *)
+rewrite abs_mul, (abs_eq c) by order.
+rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial.
+apply mod_always_pos.
+(* equation *)
+rewrite (div_mod a b) at 1 by order.
+rewrite mul_add_distr_r.
+rewrite add_cancel_r.
+rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
+Qed.
+
+Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0<c ->
+ (c*a)/(c*b) == a/b.
+Proof.
+intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
+Qed.
+
+Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0<c ->
+  (c*a) mod (c*b) == c * (a mod b).
+Proof.
+intros.
+rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
+rewrite <- div_mod.
+rewrite div_mul_cancel_l by trivial.
+rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
+apply div_mod; order.
+rewrite <- neq_mul_0; intuition; order.
+Qed.
+
+Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0<c ->
+  (a*c) mod (b*c) == (a mod b) * c.
+Proof.
+ intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
+Qed.
+
+
+(** Operations modulo. *)
+
+Theorem mod_mod: forall a n, n~=0 ->
+ (a mod n) mod n == a mod n.
+Proof.
+intros. rewrite mod_small_iff by trivial.
+now apply mod_always_pos.
+Qed.
+
+Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)*b) mod n == (a*b) mod n.
+Proof.
+ intros a b n Hn. symmetry.
+ rewrite (div_mod a n) at 1 by order.
+ rewrite add_comm, (mul_comm n), (mul_comm _ b).
+ rewrite mul_add_distr_l, mul_assoc.
+ rewrite mod_add by trivial.
+ now rewrite mul_comm.
+Qed.
+
+Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
+ (a*(b mod n)) mod n == (a*b) mod n.
+Proof.
+ intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
+Qed.
+
+Theorem mul_mod: forall a b n, n~=0 ->
+ (a * b) mod n == ((a mod n) * (b mod n)) mod n.
+Proof.
+ intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
+Qed.
+
+Lemma add_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)+b) mod n == (a+b) mod n.
+Proof.
+ intros a b n Hn. symmetry.
+ rewrite (div_mod a n) at 1 by order.
+ rewrite <- add_assoc, add_comm, mul_comm.
+ now rewrite mod_add.
+Qed.
+
+Lemma add_mod_idemp_r : forall a b n, n~=0 ->
+ (a+(b mod n)) mod n == (a+b) mod n.
+Proof.
+ intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
+Qed.
+
+Theorem add_mod: forall a b n, n~=0 ->
+ (a+b) mod n == (a mod n + b mod n) mod n.
+Proof.
+ intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
+Qed.
+
+(** With the current convention, the following result isn't always
+    true for negative divisors. For instance
+    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ]. *)
+
+Lemma div_div : forall a b c, 0<b -> 0<c ->
+ (a/b)/c == a/(b*c).
+Proof.
+ intros a b c Hb Hc.
+ apply div_unique with (b*((a/b) mod c) + a mod b).
+ (* begin 0<= ... <abs(b*c) *)
+ rewrite abs_mul.
+ destruct (mod_always_pos (a/b) c), (mod_always_pos a b).
+ split.
+ apply add_nonneg_nonneg; trivial.
+ apply mul_nonneg_nonneg; order.
+ apply lt_le_trans with (b*((a/b) mod c) + abs b).
+ now rewrite <- add_lt_mono_l.
+ rewrite (abs_eq b) by order.
+ now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.
+ (* end 0<= ... < abs(b*c) *)
+ rewrite (div_mod a b) at 1 by order.
+ rewrite add_assoc, add_cancel_r.
+ rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
+ apply div_mod; order.
+Qed.
+
+(** A last inequality: *)
+
+Theorem div_mul_le:
+ forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
+Proof. exact div_mul_le. Qed.
+
+(** mod is related to divisibility *)
+
+Lemma mod_divides : forall a b, b~=0 ->
+ (a mod b == 0 <-> exists c, a == b*c).
+Proof.
+intros a b Hb. split.
+intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1.
+ rewrite Hab; now nzsimpl.
+intros (c,Hc).
+rewrite Hc, mul_comm.
+now apply mod_mul.
+Qed.
+
+
+End ZDivPropFunct.
+
diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v
new file mode 100644
index 00000000..1e7624ba
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v
@@ -0,0 +1,632 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Euclidean Division for integers (Floor convention)
+
+    We use here the convention known as Floor, or Round-Toward-Bottom,
+    where [a/b] is the closest integer below the exact fraction.
+    It can be summarized by:
+
+    [a = bq+r /\ 0 <= |r| < |b| /\ Sign(r) = Sign(b)]
+
+    This is the convention followed historically by [Zdiv] in Coq, and
+    corresponds to convention "F" in the following paper:
+
+    R. Boute, "The Euclidean definition of the functions div and mod",
+    ACM Transactions on Programming Languages and Systems,
+    Vol. 14, No.2, pp. 127-144, April 1992.
+
+    See files [ZDivTrunc] and [ZDivEucl] for others conventions.
+*)
+
+Require Import ZAxioms ZProperties NZDiv.
+
+Module Type ZDivSpecific (Import Z:ZAxiomsSig')(Import DM : DivMod' Z).
+ Axiom mod_pos_bound : forall a b, 0 < b -> 0 <= a mod b < b.
+ Axiom mod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0.
+End ZDivSpecific.
+
+Module Type ZDiv (Z:ZAxiomsSig)
+ := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z.
+
+Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv.
+Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation.
+
+Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z).
+
+(** We benefit from what already exists for NZ *)
+
+ Module ZD <: NZDiv Z.
+  Definition div := div.
+  Definition modulo := modulo.
+  Definition div_wd := div_wd.
+  Definition mod_wd := mod_wd.
+  Definition div_mod := div_mod.
+  Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
+  Proof. intros. now apply mod_pos_bound. Qed.
+ End ZD.
+ Module Import NZDivP := NZDivPropFunct Z ZP ZD.
+
+(** Another formulation of the main equation *)
+
+Lemma mod_eq :
+ forall a b, b~=0 -> a mod b == a - b*(a/b).
+Proof.
+intros.
+rewrite <- add_move_l.
+symmetry. now apply div_mod.
+Qed.
+
+(** Uniqueness theorems *)
+
+Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
+  (0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) ->
+  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
+Proof.
+intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
+destruct Hr1; destruct Hr2; try (intuition; order).
+apply div_mod_unique with b; trivial.
+rewrite <- (opp_inj_wd r1 r2).
+apply div_mod_unique with (-b); trivial.
+rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
+rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
+now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd.
+Qed.
+
+Theorem div_unique:
+ forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> q == a/b.
+Proof.
+intros a b q r Hr EQ.
+assert (Hb : b~=0) by (destruct Hr; intuition; order).
+destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
+destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound];
+ intuition order.
+now rewrite <- div_mod.
+Qed.
+
+Theorem div_unique_pos:
+ forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b.
+Proof. intros; apply div_unique with r; auto. Qed.
+
+Theorem div_unique_neg:
+ forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b.
+Proof. intros; apply div_unique with r; auto. Qed.
+
+Theorem mod_unique:
+ forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> r == a mod b.
+Proof.
+intros a b q r Hr EQ.
+assert (Hb : b~=0) by (destruct Hr; intuition; order).
+destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
+destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound];
+ intuition order.
+now rewrite <- div_mod.
+Qed.
+
+Theorem mod_unique_pos:
+ forall a b q r, 0<=r<b -> a == b*q + r -> r == a mod b.
+Proof. intros; apply mod_unique with q; auto. Qed.
+
+Theorem mod_unique_neg:
+ forall a b q r, b<r<=0 -> a == b*q + r -> r == a mod b.
+Proof. intros; apply mod_unique with q; auto. Qed.
+
+(** Sign rules *)
+
+Ltac pos_or_neg a :=
+ let LT := fresh "LT" in
+ let LE := fresh "LE" in
+ destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].
+
+Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b<b \/ b<a mod b<=0.
+Proof.
+intros.
+destruct (lt_ge_cases 0 b); [left|right].
+ apply mod_pos_bound; trivial. apply mod_neg_bound; order.
+Qed.
+
+Fact opp_mod_bound_or : forall a b, b~=0 ->
+ 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0.
+Proof.
+intros.
+destruct (lt_ge_cases 0 b); [right|left].
+rewrite <- opp_lt_mono, opp_nonpos_nonneg.
+ destruct (mod_pos_bound a b); intuition; order.
+rewrite <- opp_lt_mono, opp_nonneg_nonpos.
+ destruct (mod_neg_bound a b); intuition; order.
+Qed.
+
+Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b.
+Proof.
+intros. symmetry. apply div_unique with (- (a mod b)).
+now apply opp_mod_bound_or.
+rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order.
+Qed.
+
+Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b).
+Proof.
+intros. symmetry. apply mod_unique with (a/b).
+now apply opp_mod_bound_or.
+rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order.
+Qed.
+
+(** With the current conventions, the other sign rules are rather complex. *)
+
+Lemma div_opp_l_z :
+ forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b).
+Proof.
+intros a b Hb H. symmetry. apply div_unique with 0.
+destruct (lt_ge_cases 0 b); [left|right]; intuition; order.
+rewrite <- opp_0, <- H.
+rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order.
+Qed.
+
+Lemma div_opp_l_nz :
+ forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1.
+Proof.
+intros a b Hb H. symmetry. apply div_unique with (b - a mod b).
+destruct (lt_ge_cases 0 b); [left|right].
+rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l.
+destruct (mod_pos_bound a b); intuition; order.
+rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l.
+destruct (mod_neg_bound a b); intuition; order.
+rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l.
+rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order.
+Qed.
+
+Lemma mod_opp_l_z :
+ forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0.
+Proof.
+intros a b Hb H. symmetry. apply mod_unique with (-(a/b)).
+destruct (lt_ge_cases 0 b); [left|right]; intuition; order.
+rewrite <- opp_0, <- H.
+rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order.
+Qed.
+
+Lemma mod_opp_l_nz :
+ forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b.
+Proof.
+intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1).
+destruct (lt_ge_cases 0 b); [left|right].
+rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l.
+destruct (mod_pos_bound a b); intuition; order.
+rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l.
+destruct (mod_neg_bound a b); intuition; order.
+rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l.
+rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order.
+Qed.
+
+Lemma div_opp_r_z :
+ forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b).
+Proof.
+intros. rewrite <- (opp_involutive a) at 1.
+rewrite div_opp_opp; auto using div_opp_l_z.
+Qed.
+
+Lemma div_opp_r_nz :
+ forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1.
+Proof.
+intros. rewrite <- (opp_involutive a) at 1.
+rewrite div_opp_opp; auto using div_opp_l_nz.
+Qed.
+
+Lemma mod_opp_r_z :
+ forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0.
+Proof.
+intros. rewrite <- (opp_involutive a) at 1.
+now rewrite mod_opp_opp, mod_opp_l_z, opp_0.
+Qed.
+
+Lemma mod_opp_r_nz :
+ forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b.
+Proof.
+intros. rewrite <- (opp_involutive a) at 1.
+rewrite mod_opp_opp, mod_opp_l_nz by trivial.
+now rewrite opp_sub_distr, add_comm, add_opp_r.
+Qed.
+
+(** The sign of [a mod b] is the one of [b] *)
+
+(* TODO: a proper sgn function and theory *)
+
+Lemma mod_sign : forall a b, b~=0 -> (0 <= (a mod b) * b).
+Proof.
+intros. destruct (lt_ge_cases 0 b).
+apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order.
+apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order.
+Qed.
+
+(** A division by itself returns 1 *)
+
+Lemma div_same : forall a, a~=0 -> a/a == 1.
+Proof.
+intros. pos_or_neg a. apply div_same; order.
+rewrite <- div_opp_opp by trivial. now apply div_same.
+Qed.
+
+Lemma mod_same : forall a, a~=0 -> a mod a == 0.
+Proof.
+intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
+Qed.
+
+(** A division of a small number by a bigger one yields zero. *)
+
+Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
+Proof. exact div_small. Qed.
+
+(** Same situation, in term of modulo: *)
+
+Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
+Proof. exact mod_small. Qed.
+
+(** * Basic values of divisions and modulo. *)
+
+Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
+Proof.
+intros. pos_or_neg a. apply div_0_l; order.
+rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l.
+Qed.
+
+Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
+Proof.
+intros; rewrite mod_eq, div_0_l; now nzsimpl.
+Qed.
+
+Lemma div_1_r: forall a, a/1 == a.
+Proof.
+intros. symmetry. apply div_unique with 0. left. split; order || apply lt_0_1.
+now nzsimpl.
+Qed.
+
+Lemma mod_1_r: forall a, a mod 1 == 0.
+Proof.
+intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
+intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1.
+Qed.
+
+Lemma div_1_l: forall a, 1<a -> 1/a == 0.
+Proof. exact div_1_l. Qed.
+
+Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
+Proof. exact mod_1_l. Qed.
+
+Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
+Proof.
+intros. symmetry. apply div_unique with 0.
+destruct (lt_ge_cases 0 b); [left|right]; split; order.
+nzsimpl; apply mul_comm.
+Qed.
+
+Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
+Proof.
+intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
+Qed.
+
+(** * Order results about mod and div *)
+
+(** A modulo cannot grow beyond its starting point. *)
+
+Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
+Proof. exact mod_le. Qed.
+
+Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
+Proof. exact div_pos. Qed.
+
+Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
+Proof. exact div_str_pos. Qed.
+
+Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<b \/ b<a<=0).
+Proof.
+intros a b Hb.
+split.
+intros EQ.
+rewrite (div_mod a b Hb), EQ; nzsimpl.
+now apply mod_bound_or.
+destruct 1. now apply div_small.
+rewrite <- div_opp_opp by trivial. apply div_small; trivial.
+rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
+Qed.
+
+Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<b \/ b<a<=0).
+Proof.
+intros.
+rewrite <- div_small_iff, mod_eq by trivial.
+rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
+rewrite eq_sym_iff, eq_mul_0. tauto.
+Qed.
+
+(** As soon as the divisor is strictly greater than 1,
+    the division is strictly decreasing. *)
+
+Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
+Proof. exact div_lt. Qed.
+
+(** [le] is compatible with a positive division. *)
+
+Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
+Proof.
+intros a b c Hc Hab.
+rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
+ [|rewrite EQ; order].
+rewrite <- lt_succ_r.
+rewrite (mul_lt_mono_pos_l c) by order.
+nzsimpl.
+rewrite (add_lt_mono_r _ _ (a mod c)).
+rewrite <- div_mod by order.
+apply lt_le_trans with b; trivial.
+rewrite (div_mod b c) at 1 by order.
+rewrite <- add_assoc, <- add_le_mono_l.
+apply le_trans with (c+0).
+nzsimpl; destruct (mod_pos_bound b c); order.
+rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order.
+Qed.
+
+(** In this convention, [div] performs Rounding-Toward-Bottom.
+
+    Since we cannot speak of rational values here, we express this
+    fact by multiplying back by [b], and this leads to separates
+    statements according to the sign of [b].
+
+    First, [a/b] is below the exact fraction ...
+*)
+
+Lemma mul_div_le : forall a b, 0<b -> b*(a/b) <= a.
+Proof.
+intros.
+rewrite (div_mod a b) at 2; try order.
+rewrite <- (add_0_r (b*(a/b))) at 1.
+rewrite <- add_le_mono_l.
+now destruct (mod_pos_bound a b).
+Qed.
+
+Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b).
+Proof.
+intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order.
+apply mul_div_le. now rewrite opp_pos_neg.
+Qed.
+
+(** ... and moreover it is the larger such integer, since [S(a/b)]
+    is strictly above the exact fraction.
+*)
+
+Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
+Proof.
+intros.
+nzsimpl.
+rewrite (div_mod a b) at 1; try order.
+rewrite <- add_lt_mono_l.
+destruct (mod_pos_bound a b); order.
+Qed.
+
+Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a.
+Proof.
+intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order.
+apply mul_succ_div_gt. now rewrite opp_pos_neg.
+Qed.
+
+(** NB: The four previous properties could be used as
+    specifications for [div]. *)
+
+(** Inequality [mul_div_le] is exact iff the modulo is zero. *)
+
+Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
+Proof.
+intros.
+rewrite (div_mod a b) at 1; try order.
+rewrite <- (add_0_r (b*(a/b))) at 2.
+apply add_cancel_l.
+Qed.
+
+(** Some additionnal inequalities about div. *)
+
+Theorem div_lt_upper_bound:
+  forall a b q, 0<b -> a < b*q -> a/b < q.
+Proof.
+intros.
+rewrite (mul_lt_mono_pos_l b) by trivial.
+apply le_lt_trans with a; trivial.
+now apply mul_div_le.
+Qed.
+
+Theorem div_le_upper_bound:
+  forall a b q, 0<b -> a <= b*q -> a/b <= q.
+Proof.
+intros.
+rewrite <- (div_mul q b) by order.
+apply div_le_mono; trivial. now rewrite mul_comm.
+Qed.
+
+Theorem div_le_lower_bound:
+  forall a b q, 0<b -> b*q <= a -> q <= a/b.
+Proof.
+intros.
+rewrite <- (div_mul q b) by order.
+apply div_le_mono; trivial. now rewrite mul_comm.
+Qed.
+
+(** A division respects opposite monotonicity for the divisor *)
+
+Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
+Proof. exact div_le_compat_l. Qed.
+
+(** * Relations between usual operations and mod and div *)
+
+Lemma mod_add : forall a b c, c~=0 ->
+ (a + b * c) mod c == a mod c.
+Proof.
+intros.
+symmetry.
+apply mod_unique with (a/c+b); trivial.
+now apply mod_bound_or.
+rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
+now rewrite mul_comm.
+Qed.
+
+Lemma div_add : forall a b c, c~=0 ->
+ (a + b * c) / c == a / c + b.
+Proof.
+intros.
+apply (mul_cancel_l _ _ c); try order.
+apply (add_cancel_r _ _ ((a+b*c) mod c)).
+rewrite <- div_mod, mod_add by order.
+rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
+now rewrite mul_comm.
+Qed.
+
+Lemma div_add_l: forall a b c, b~=0 ->
+ (a * b + c) / b == a + c / b.
+Proof.
+ intros a b c. rewrite (add_comm _ c), (add_comm a).
+ now apply div_add.
+Qed.
+
+(** Cancellations. *)
+
+Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
+ (a*c)/(b*c) == a/b.
+Proof.
+intros.
+symmetry.
+apply div_unique with ((a mod b)*c).
+(* ineqs *)
+destruct (lt_ge_cases 0 c).
+rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial.
+now apply mod_bound_or.
+rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order.
+destruct (mod_bound_or a b); tauto.
+(* equation *)
+rewrite (div_mod a b) at 1 by order.
+rewrite mul_add_distr_r.
+rewrite add_cancel_r.
+rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
+Qed.
+
+Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
+ (c*a)/(c*b) == a/b.
+Proof.
+intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
+Qed.
+
+Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 ->
+  (c*a) mod (c*b) == c * (a mod b).
+Proof.
+intros.
+rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
+rewrite <- div_mod.
+rewrite div_mul_cancel_l by trivial.
+rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
+apply div_mod; order.
+rewrite <- neq_mul_0; auto.
+Qed.
+
+Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 ->
+  (a*c) mod (b*c) == (a mod b) * c.
+Proof.
+ intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
+Qed.
+
+
+(** Operations modulo. *)
+
+Theorem mod_mod: forall a n, n~=0 ->
+ (a mod n) mod n == a mod n.
+Proof.
+intros. rewrite mod_small_iff by trivial.
+now apply mod_bound_or.
+Qed.
+
+Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)*b) mod n == (a*b) mod n.
+Proof.
+ intros a b n Hn. symmetry.
+ rewrite (div_mod a n) at 1 by order.
+ rewrite add_comm, (mul_comm n), (mul_comm _ b).
+ rewrite mul_add_distr_l, mul_assoc.
+ intros. rewrite mod_add by trivial.
+ now rewrite mul_comm.
+Qed.
+
+Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
+ (a*(b mod n)) mod n == (a*b) mod n.
+Proof.
+ intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
+Qed.
+
+Theorem mul_mod: forall a b n, n~=0 ->
+ (a * b) mod n == ((a mod n) * (b mod n)) mod n.
+Proof.
+ intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
+Qed.
+
+Lemma add_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)+b) mod n == (a+b) mod n.
+Proof.
+ intros a b n Hn. symmetry.
+ rewrite (div_mod a n) at 1 by order.
+ rewrite <- add_assoc, add_comm, mul_comm.
+ intros. now rewrite mod_add.
+Qed.
+
+Lemma add_mod_idemp_r : forall a b n, n~=0 ->
+ (a+(b mod n)) mod n == (a+b) mod n.
+Proof.
+ intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
+Qed.
+
+Theorem add_mod: forall a b n, n~=0 ->
+ (a+b) mod n == (a mod n + b mod n) mod n.
+Proof.
+ intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
+Qed.
+
+(** With the current convention, the following result isn't always
+    true for negative divisors. For instance
+    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ]. *)
+
+Lemma div_div : forall a b c, 0<b -> 0<c ->
+ (a/b)/c == a/(b*c).
+Proof.
+ intros a b c Hb Hc.
+ apply div_unique with (b*((a/b) mod c) + a mod b).
+ (* begin 0<= ... <b*c \/ ... *)
+ left.
+ destruct (mod_pos_bound (a/b) c), (mod_pos_bound a b); trivial.
+ split.
+ apply add_nonneg_nonneg; trivial.
+ apply mul_nonneg_nonneg; order.
+ apply lt_le_trans with (b*((a/b) mod c) + b).
+ now rewrite <- add_lt_mono_l.
+ now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.
+ (* end 0<= ... < b*c \/ ... *)
+ rewrite (div_mod a b) at 1 by order.
+ rewrite add_assoc, add_cancel_r.
+ rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
+ apply div_mod; order.
+Qed.
+
+(** A last inequality: *)
+
+Theorem div_mul_le:
+ forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
+Proof. exact div_mul_le. Qed.
+
+(** mod is related to divisibility *)
+
+Lemma mod_divides : forall a b, b~=0 ->
+ (a mod b == 0 <-> exists c, a == b*c).
+Proof.
+intros a b Hb. split.
+intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1.
+ rewrite Hab. now nzsimpl.
+intros (c,Hc).
+rewrite Hc, mul_comm.
+now apply mod_mul.
+Qed.
+
+End ZDivPropFunct.
+
diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v
new file mode 100644
index 00000000..3200ba2a
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v
@@ -0,0 +1,532 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Euclidean Division for integers (Trunc convention)
+
+    We use here the convention known as Trunc, or Round-Toward-Zero,
+    where [a/b] is the integer with the largest absolute value to
+    be between zero and the exact fraction. It can be summarized by:
+
+    [a = bq+r /\ 0 <= |r| < |b| /\ Sign(r) = Sign(a)]
+
+    This is the convention of Ocaml and many other systems (C, ASM, ...).
+    This convention is named "T" in the following paper:
+
+    R. Boute, "The Euclidean definition of the functions div and mod",
+    ACM Transactions on Programming Languages and Systems,
+    Vol. 14, No.2, pp. 127-144, April 1992.
+
+    See files [ZDivFloor] and [ZDivEucl] for others conventions.
+*)
+
+Require Import ZAxioms ZProperties NZDiv.
+
+Module Type ZDivSpecific (Import Z:ZAxiomsSig')(Import DM : DivMod' Z).
+ Axiom mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
+ Axiom mod_opp_l : forall a b, b ~= 0 -> (-a) mod b == - (a mod b).
+ Axiom mod_opp_r : forall a b, b ~= 0 -> a mod (-b) == a mod b.
+End ZDivSpecific.
+
+Module Type ZDiv (Z:ZAxiomsSig)
+ := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z.
+
+Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv.
+Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation.
+
+Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z).
+
+(** We benefit from what already exists for NZ *)
+
+ Module Import NZDivP := NZDivPropFunct Z ZP Z.
+
+Ltac pos_or_neg a :=
+ let LT := fresh "LT" in
+ let LE := fresh "LE" in
+ destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].
+
+(** Another formulation of the main equation *)
+
+Lemma mod_eq :
+ forall a b, b~=0 -> a mod b == a - b*(a/b).
+Proof.
+intros.
+rewrite <- add_move_l.
+symmetry. now apply div_mod.
+Qed.
+
+(** A few sign rules (simple ones) *)
+
+Lemma mod_opp_opp : forall a b, b ~= 0 -> (-a) mod (-b) == - (a mod b).
+Proof. intros. now rewrite mod_opp_r, mod_opp_l. Qed.
+
+Lemma div_opp_l : forall a b, b ~= 0 -> (-a)/b == -(a/b).
+Proof.
+intros.
+rewrite <- (mul_cancel_l _ _ b) by trivial.
+rewrite <- (add_cancel_r _ _ ((-a) mod b)).
+now rewrite <- div_mod, mod_opp_l, mul_opp_r, <- opp_add_distr, <- div_mod.
+Qed.
+
+Lemma div_opp_r : forall a b, b ~= 0 -> a/(-b) == -(a/b).
+Proof.
+intros.
+assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0).
+rewrite <- (mul_cancel_l _ _ (-b)) by trivial.
+rewrite <- (add_cancel_r _ _ (a mod (-b))).
+now rewrite <- div_mod, mod_opp_r, mul_opp_opp, <- div_mod.
+Qed.
+
+Lemma div_opp_opp : forall a b, b ~= 0 -> (-a)/(-b) == a/b.
+Proof. intros. now rewrite div_opp_r, div_opp_l, opp_involutive. Qed.
+
+(** The sign of [a mod b] is the one of [a] *)
+
+(* TODO: a proper sgn function and theory *)
+
+Lemma mod_sign : forall a b, b~=0 -> 0 <= (a mod b) * a.
+Proof.
+assert (Aux : forall a b, 0<b -> 0 <= (a mod b) * a).
+ intros. pos_or_neg a.
+ apply mul_nonneg_nonneg; trivial. now destruct (mod_bound a b).
+ rewrite <- mul_opp_opp, <- mod_opp_l by order.
+ apply mul_nonneg_nonneg; try order. destruct (mod_bound (-a) b); order.
+intros. pos_or_neg b. apply Aux; order.
+rewrite <- mod_opp_r by order. apply Aux; order.
+Qed.
+
+
+(** Uniqueness theorems *)
+
+Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
+  (0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) ->
+  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
+Proof.
+intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
+destruct Hr1; destruct Hr2; try (intuition; order).
+apply div_mod_unique with b; trivial.
+rewrite <- (opp_inj_wd r1 r2).
+apply div_mod_unique with (-b); trivial.
+rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
+rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
+now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd.
+Qed.
+
+Theorem div_unique:
+ forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a/b.
+Proof. intros; now apply div_unique with r. Qed.
+
+Theorem mod_unique:
+ forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a mod b.
+Proof. intros; now apply mod_unique with q. Qed.
+
+(** A division by itself returns 1 *)
+
+Lemma div_same : forall a, a~=0 -> a/a == 1.
+Proof.
+intros. pos_or_neg a. apply div_same; order.
+rewrite <- div_opp_opp by trivial. now apply div_same.
+Qed.
+
+Lemma mod_same : forall a, a~=0 -> a mod a == 0.
+Proof.
+intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
+Qed.
+
+(** A division of a small number by a bigger one yields zero. *)
+
+Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
+Proof. exact div_small. Qed.
+
+(** Same situation, in term of modulo: *)
+
+Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
+Proof. exact mod_small. Qed.
+
+(** * Basic values of divisions and modulo. *)
+
+Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
+Proof.
+intros. pos_or_neg a. apply div_0_l; order.
+rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l.
+Qed.
+
+Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
+Proof.
+intros; rewrite mod_eq, div_0_l; now nzsimpl.
+Qed.
+
+Lemma div_1_r: forall a, a/1 == a.
+Proof.
+intros. pos_or_neg a. now apply div_1_r.
+apply opp_inj. rewrite <- div_opp_l. apply div_1_r; order.
+intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1.
+Qed.
+
+Lemma mod_1_r: forall a, a mod 1 == 0.
+Proof.
+intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
+intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1.
+Qed.
+
+Lemma div_1_l: forall a, 1<a -> 1/a == 0.
+Proof. exact div_1_l. Qed.
+
+Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
+Proof. exact mod_1_l. Qed.
+
+Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
+Proof.
+intros. pos_or_neg a; pos_or_neg b. apply div_mul; order.
+rewrite <- div_opp_opp, <- mul_opp_r by order. apply div_mul; order.
+rewrite <- opp_inj_wd, <- div_opp_l, <- mul_opp_l by order. apply div_mul; order.
+rewrite <- opp_inj_wd, <- div_opp_r, <- mul_opp_opp by order. apply div_mul; order.
+Qed.
+
+Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
+Proof.
+intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
+Qed.
+
+(** * Order results about mod and div *)
+
+(** A modulo cannot grow beyond its starting point. *)
+
+Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
+Proof. exact mod_le. Qed.
+
+Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
+Proof. exact div_pos. Qed.
+
+Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
+Proof. exact div_str_pos. Qed.
+
+Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> abs a < abs b).
+Proof.
+intros. pos_or_neg a; pos_or_neg b.
+rewrite div_small_iff; try order. rewrite 2 abs_eq; intuition; order.
+rewrite <- opp_inj_wd, opp_0, <- div_opp_r, div_small_iff by order.
+ rewrite (abs_eq a), (abs_neq' b); intuition; order.
+rewrite <- opp_inj_wd, opp_0, <- div_opp_l, div_small_iff by order.
+ rewrite (abs_neq' a), (abs_eq b); intuition; order.
+rewrite <- div_opp_opp, div_small_iff by order.
+ rewrite (abs_neq' a), (abs_neq' b); intuition; order.
+Qed.
+
+Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> abs a < abs b).
+Proof.
+intros. rewrite mod_eq, <- div_small_iff by order.
+rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
+rewrite eq_sym_iff, eq_mul_0. tauto.
+Qed.
+
+(** As soon as the divisor is strictly greater than 1,
+    the division is strictly decreasing. *)
+
+Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
+Proof. exact div_lt. Qed.
+
+(** [le] is compatible with a positive division. *)
+
+Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
+Proof.
+intros. pos_or_neg a. apply div_le_mono; auto.
+pos_or_neg b. apply le_trans with 0.
+ rewrite <- opp_nonneg_nonpos, <- div_opp_l by order.
+ apply div_pos; order.
+ apply div_pos; order.
+rewrite opp_le_mono in *. rewrite <- 2 div_opp_l by order.
+ apply div_le_mono; intuition; order.
+Qed.
+
+(** With this choice of division,
+    rounding of div is always done toward zero: *)
+
+Lemma mul_div_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a/b) <= a.
+Proof.
+intros. pos_or_neg b.
+split.
+apply mul_nonneg_nonneg; [|apply div_pos]; order.
+apply mul_div_le; order.
+rewrite <- mul_opp_opp, <- div_opp_r by order.
+split.
+apply mul_nonneg_nonneg; [|apply div_pos]; order.
+apply mul_div_le; order.
+Qed.
+
+Lemma mul_div_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a/b) <= 0.
+Proof.
+intros.
+rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-div_opp_l by order.
+rewrite <- opp_nonneg_nonpos in *.
+destruct (mul_div_le (-a) b); tauto.
+Qed.
+
+(** For positive numbers, considering [S (a/b)] leads to an upper bound for [a] *)
+
+Lemma mul_succ_div_gt: forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
+Proof. exact mul_succ_div_gt. Qed.
+
+(** Similar results with negative numbers *)
+
+Lemma mul_pred_div_lt: forall a b, a<=0 -> 0<b -> b*(P (a/b)) < a.
+Proof.
+intros.
+rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- div_opp_l by order.
+rewrite <- opp_nonneg_nonpos in *.
+now apply mul_succ_div_gt.
+Qed.
+
+Lemma mul_pred_div_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a/b)).
+Proof.
+intros.
+rewrite <- mul_opp_opp, opp_pred, <- div_opp_r by order.
+rewrite <- opp_pos_neg in *.
+now apply mul_succ_div_gt.
+Qed.
+
+Lemma mul_succ_div_lt: forall a b, a<=0 -> b<0 -> b*(S (a/b)) < a.
+Proof.
+intros.
+rewrite opp_lt_mono, <- mul_opp_l, <- div_opp_opp by order.
+rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *.
+now apply mul_succ_div_gt.
+Qed.
+
+(** Inequality [mul_div_le] is exact iff the modulo is zero. *)
+
+Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
+Proof.
+intros. rewrite mod_eq by order. rewrite sub_move_r; nzsimpl; tauto.
+Qed.
+
+(** Some additionnal inequalities about div. *)
+
+Theorem div_lt_upper_bound:
+  forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q.
+Proof. exact div_lt_upper_bound. Qed.
+
+Theorem div_le_upper_bound:
+  forall a b q, 0<b -> a <= b*q -> a/b <= q.
+Proof.
+intros.
+rewrite <- (div_mul q b) by order.
+apply div_le_mono; trivial. now rewrite mul_comm.
+Qed.
+
+Theorem div_le_lower_bound:
+  forall a b q, 0<b -> b*q <= a -> q <= a/b.
+Proof.
+intros.
+rewrite <- (div_mul q b) by order.
+apply div_le_mono; trivial. now rewrite mul_comm.
+Qed.
+
+(** A division respects opposite monotonicity for the divisor *)
+
+Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
+Proof. exact div_le_compat_l. Qed.
+
+(** * Relations between usual operations and mod and div *)
+
+(** Unlike with other division conventions, some results here aren't
+    always valid, and need to be restricted. For instance
+    [(a+b*c) mod c <> a mod c] for [a=9,b=-5,c=2] *)
+
+Lemma mod_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a ->
+ (a + b * c) mod c == a mod c.
+Proof.
+assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) mod c == a mod c).
+ intros. pos_or_neg c. apply mod_add; order.
+ rewrite <- (mod_opp_r a), <- (mod_opp_r (a+b*c)) by order.
+ rewrite <- mul_opp_opp in *.
+ apply mod_add; order.
+intros a b c Hc Habc.
+destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. auto.
+apply opp_inj. revert Ha Habc'.
+rewrite <- 2 opp_nonneg_nonpos.
+rewrite <- 2 mod_opp_l, opp_add_distr, <- mul_opp_l by order. auto.
+Qed.
+
+Lemma div_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a ->
+ (a + b * c) / c == a / c + b.
+Proof.
+intros.
+rewrite <- (mul_cancel_l _ _ c) by trivial.
+rewrite <- (add_cancel_r _ _ ((a+b*c) mod c)).
+rewrite <- div_mod, mod_add by trivial.
+now rewrite mul_add_distr_l, add_shuffle0, <-div_mod, mul_comm.
+Qed.
+
+Lemma div_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c ->
+ (a * b + c) / b == a + c / b.
+Proof.
+ intros a b c. rewrite add_comm, (add_comm a). now apply div_add.
+Qed.
+
+(** Cancellations. *)
+
+Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
+ (a*c)/(b*c) == a/b.
+Proof.
+assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a*c)/(b*c) == a/b).
+ intros. pos_or_neg c. apply div_mul_cancel_r; order.
+ rewrite <- div_opp_opp, <- 2 mul_opp_r. apply div_mul_cancel_r; order.
+ rewrite <- neq_mul_0; intuition order.
+assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)/(b*c) == a/b).
+ intros. pos_or_neg b. apply Aux1; order.
+ apply opp_inj. rewrite <- 2 div_opp_r, <- mul_opp_l; try order. apply Aux1; order.
+ rewrite <- neq_mul_0; intuition order.
+intros. pos_or_neg a. apply Aux2; order.
+apply opp_inj. rewrite <- 2 div_opp_l, <- mul_opp_l; try order. apply Aux2; order.
+rewrite <- neq_mul_0; intuition order.
+Qed.
+
+Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
+ (c*a)/(c*b) == a/b.
+Proof.
+intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
+Qed.
+
+Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 ->
+  (a*c) mod (b*c) == (a mod b) * c.
+Proof.
+intros.
+assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto).
+rewrite ! mod_eq by trivial.
+rewrite div_mul_cancel_r by order.
+now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a/b) c).
+Qed.
+
+Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 ->
+  (c*a) mod (c*b) == c * (a mod b).
+Proof.
+intros; rewrite !(mul_comm c); now apply mul_mod_distr_r.
+Qed.
+
+(** Operations modulo. *)
+
+Theorem mod_mod: forall a n, n~=0 ->
+ (a mod n) mod n == a mod n.
+Proof.
+intros. pos_or_neg a; pos_or_neg n. apply mod_mod; order.
+rewrite <- ! (mod_opp_r _ n) by trivial. apply mod_mod; order.
+apply opp_inj. rewrite <- !mod_opp_l by order. apply mod_mod; order.
+apply opp_inj. rewrite <- !mod_opp_opp by order. apply mod_mod; order.
+Qed.
+
+Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)*b) mod n == (a*b) mod n.
+Proof.
+assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 ->
+         ((a mod n)*b) mod n == (a*b) mod n).
+ intros. pos_or_neg n. apply mul_mod_idemp_l; order.
+ rewrite <- ! (mod_opp_r _ n) by order. apply mul_mod_idemp_l; order.
+assert (Aux2 : forall a b n, 0<=a -> n~=0 ->
+         ((a mod n)*b) mod n == (a*b) mod n).
+ intros. pos_or_neg b. now apply Aux1.
+ apply opp_inj. rewrite <-2 mod_opp_l, <-2 mul_opp_r by order.
+  apply Aux1; order.
+intros a b n Hn. pos_or_neg a. now apply Aux2.
+apply opp_inj. rewrite <-2 mod_opp_l, <-2 mul_opp_l, <-mod_opp_l by order.
+apply Aux2; order.
+Qed.
+
+Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
+ (a*(b mod n)) mod n == (a*b) mod n.
+Proof.
+intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
+Qed.
+
+Theorem mul_mod: forall a b n, n~=0 ->
+ (a * b) mod n == ((a mod n) * (b mod n)) mod n.
+Proof.
+intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
+Qed.
+
+(** addition and modulo
+
+  Generally speaking, unlike with other conventions, we don't have
+       [(a+b) mod n = (a mod n + b mod n) mod n]
+  for any a and b.
+  For instance, take (8 + (-10)) mod 3 = -2 whereas
+  (8 mod 3 + (-10 mod 3)) mod 3 = 1.
+*)
+
+Lemma add_mod_idemp_l : forall a b n, n~=0 -> 0 <= a*b ->
+ ((a mod n)+b) mod n == (a+b) mod n.
+Proof.
+assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 ->
+          ((a mod n)+b) mod n == (a+b) mod n).
+ intros. pos_or_neg n. apply add_mod_idemp_l; order.
+ rewrite <- ! (mod_opp_r _ n) by order. apply add_mod_idemp_l; order.
+intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)].
+now apply Aux.
+apply opp_inj. rewrite <-2 mod_opp_l, 2 opp_add_distr, <-mod_opp_l by order.
+rewrite <- opp_nonneg_nonpos in *.
+now apply Aux.
+Qed.
+
+Lemma add_mod_idemp_r : forall a b n, n~=0 -> 0 <= a*b ->
+ (a+(b mod n)) mod n == (a+b) mod n.
+Proof.
+intros. rewrite !(add_comm a). apply add_mod_idemp_l; trivial.
+now rewrite mul_comm.
+Qed.
+
+Theorem add_mod: forall a b n, n~=0 -> 0 <= a*b ->
+ (a+b) mod n == (a mod n + b mod n) mod n.
+Proof.
+intros a b n Hn Hab. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial.
+reflexivity.
+destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)];
+ destruct (le_0_mul _ _ (mod_sign b n Hn)) as [(Hb',Hm)|(Hb',Hm)];
+ auto using mul_nonneg_nonneg, mul_nonpos_nonpos.
+ setoid_replace b with 0 by order. rewrite mod_0_l by order. nzsimpl; order.
+ setoid_replace b with 0 by order. rewrite mod_0_l by order. nzsimpl; order.
+Qed.
+
+
+(** Conversely, the following result needs less restrictions here. *)
+
+Lemma div_div : forall a b c, b~=0 -> c~=0 ->
+ (a/b)/c == a/(b*c).
+Proof.
+assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a/b)/c == a/(b*c)).
+ intros. pos_or_neg c. apply div_div; order.
+ apply opp_inj. rewrite <- 2 div_opp_r, <- mul_opp_r; trivial.
+ apply div_div; order.
+ rewrite <- neq_mul_0; intuition order.
+assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a/b)/c == a/(b*c)).
+ intros. pos_or_neg b. apply Aux1; order.
+ apply opp_inj. rewrite <- div_opp_l, <- 2 div_opp_r, <- mul_opp_l; trivial.
+ apply Aux1; trivial.
+ rewrite <- neq_mul_0; intuition order.
+intros. pos_or_neg a. apply Aux2; order.
+apply opp_inj. rewrite <- 3 div_opp_l; try order. apply Aux2; order.
+rewrite <- neq_mul_0. tauto.
+Qed.
+
+(** A last inequality: *)
+
+Theorem div_mul_le:
+ forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
+Proof. exact div_mul_le. Qed.
+
+(** mod is related to divisibility *)
+
+Lemma mod_divides : forall a b, b~=0 ->
+ (a mod b == 0 <-> exists c, a == b*c).
+Proof.
+ intros a b Hb. split.
+ intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1.
+  rewrite Hab; now nzsimpl.
+ intros (c,Hc). rewrite Hc, mul_comm. now apply mod_mul.
+Qed.
+
+End ZDivPropFunct.
+
diff --git a/theories/Numbers/Integer/Abstract/ZDomain.v b/theories/Numbers/Integer/Abstract/ZDomain.v
deleted file mode 100644
index 9a17e151..00000000
--- a/theories/Numbers/Integer/Abstract/ZDomain.v
+++ /dev/null
@@ -1,69 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                      Evgeny Makarov, INRIA, 2007                     *)
-(************************************************************************)
-
-(*i $Id: ZDomain.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
-
-Require Export NumPrelude.
-
-Module Type ZDomainSignature.
-
-Parameter Inline Z : Set.
-Parameter Inline Zeq : Z -> Z -> Prop.
-Parameter Inline e : Z -> Z -> bool.
-
-Axiom eq_equiv_e : forall x y : Z, Zeq x y <-> e x y.
-Axiom eq_equiv : equiv Z Zeq.
-
-Add Relation Z Zeq
- reflexivity proved by (proj1 eq_equiv)
- symmetry proved by (proj2 (proj2 eq_equiv))
- transitivity proved by (proj1 (proj2 eq_equiv))
-as eq_rel.
-
-Delimit Scope IntScope with Int.
-Bind Scope IntScope with Z.
-Notation "x == y" := (Zeq x y) (at level 70) : IntScope.
-Notation "x # y" := (~ Zeq x y) (at level 70) : IntScope.
-
-End ZDomainSignature.
-
-Module ZDomainProperties (Import ZDomainModule : ZDomainSignature).
-Open Local Scope IntScope.
-
-Add Morphism e with signature Zeq ==> Zeq ==> eq_bool as e_wd.
-Proof.
-intros x x' Exx' y y' Eyy'.
-case_eq (e x y); case_eq (e x' y'); intros H1 H2; trivial.
-assert (x == y); [apply <- eq_equiv_e; now rewrite H2 |
-assert (x' == y'); [rewrite <- Exx'; now rewrite <- Eyy' |
-rewrite <- H1; assert (H3 : e x' y'); [now apply -> eq_equiv_e | now inversion H3]]].
-assert (x' == y'); [apply <- eq_equiv_e; now rewrite H1 |
-assert (x == y); [rewrite Exx'; now rewrite Eyy' |
-rewrite <- H2; assert (H3 : e x y); [now apply -> eq_equiv_e | now inversion H3]]].
-Qed.
-
-Theorem neq_sym : forall n m, n # m -> m # n.
-Proof.
-intros n m H1 H2; symmetry in H2; false_hyp H2 H1.
-Qed.
-
-Theorem ZE_stepl : forall x y z : Z, x == y -> x == z -> z == y.
-Proof.
-intros x y z H1 H2; now rewrite <- H1.
-Qed.
-
-Declare Left Step ZE_stepl.
-
-(* The right step lemma is just transitivity of Zeq *)
-Declare Right Step (proj1 (proj2 eq_equiv)).
-
-End ZDomainProperties.
-
-
diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v
index 2a88a535..849bf6b4 100644
--- a/theories/Numbers/Integer/Abstract/ZLt.v
+++ b/theories/Numbers/Integer/Abstract/ZLt.v
@@ -8,424 +8,126 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZLt.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export ZMul.
 
-Module ZOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig).
-Module Export ZMulPropMod := ZMulPropFunct ZAxiomsMod.
-Open Local Scope IntScope.
+Module ZOrderPropFunct (Import Z : ZAxiomsSig').
+Include ZMulPropFunct Z.
 
-(* Axioms *)
+(** Instances of earlier theorems for m == 0 *)
 
-Theorem Zlt_wd :
-  forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> (n1 < m1 <-> n2 < m2).
-Proof NZlt_wd.
-
-Theorem Zle_wd :
-  forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> (n1 <= m1 <-> n2 <= m2).
-Proof NZle_wd.
-
-Theorem Zmin_wd :
-  forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> Zmin n1 m1 == Zmin n2 m2.
-Proof NZmin_wd.
-
-Theorem Zmax_wd :
-  forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> Zmax n1 m1 == Zmax n2 m2.
-Proof NZmax_wd.
-
-Theorem Zlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n == m.
-Proof NZlt_eq_cases.
-
-Theorem Zlt_irrefl : forall n : Z, ~ n < n.
-Proof NZlt_irrefl.
-
-Theorem Zlt_succ_r : forall n m : Z, n < S m <-> n <= m.
-Proof NZlt_succ_r.
-
-Theorem Zmin_l : forall n m : Z, n <= m -> Zmin n m == n.
-Proof NZmin_l.
-
-Theorem Zmin_r : forall n m : Z, m <= n -> Zmin n m == m.
-Proof NZmin_r.
-
-Theorem Zmax_l : forall n m : Z, m <= n -> Zmax n m == n.
-Proof NZmax_l.
-
-Theorem Zmax_r : forall n m : Z, n <= m -> Zmax n m == m.
-Proof NZmax_r.
-
-(* Renaming theorems from NZOrder.v *)
-
-Theorem Zlt_le_incl : forall n m : Z, n < m -> n <= m.
-Proof NZlt_le_incl.
-
-Theorem Zlt_neq : forall n m : Z, n < m -> n ~= m.
-Proof NZlt_neq.
-
-Theorem Zle_neq : forall n m : Z, n < m <-> n <= m /\ n ~= m.
-Proof NZle_neq.
-
-Theorem Zle_refl : forall n : Z, n <= n.
-Proof NZle_refl.
-
-Theorem Zlt_succ_diag_r : forall n : Z, n < S n.
-Proof NZlt_succ_diag_r.
-
-Theorem Zle_succ_diag_r : forall n : Z, n <= S n.
-Proof NZle_succ_diag_r.
-
-Theorem Zlt_0_1 : 0 < 1.
-Proof NZlt_0_1.
-
-Theorem Zle_0_1 : 0 <= 1.
-Proof NZle_0_1.
-
-Theorem Zlt_lt_succ_r : forall n m : Z, n < m -> n < S m.
-Proof NZlt_lt_succ_r.
-
-Theorem Zle_le_succ_r : forall n m : Z, n <= m -> n <= S m.
-Proof NZle_le_succ_r.
-
-Theorem Zle_succ_r : forall n m : Z, n <= S m <-> n <= m \/ n == S m.
-Proof NZle_succ_r.
-
-Theorem Zneq_succ_diag_l : forall n : Z, S n ~= n.
-Proof NZneq_succ_diag_l.
-
-Theorem Zneq_succ_diag_r : forall n : Z, n ~= S n.
-Proof NZneq_succ_diag_r.
-
-Theorem Znlt_succ_diag_l : forall n : Z, ~ S n < n.
-Proof NZnlt_succ_diag_l.
-
-Theorem Znle_succ_diag_l : forall n : Z, ~ S n <= n.
-Proof NZnle_succ_diag_l.
-
-Theorem Zle_succ_l : forall n m : Z, S n <= m <-> n < m.
-Proof NZle_succ_l.
-
-Theorem Zlt_succ_l : forall n m : Z, S n < m -> n < m.
-Proof NZlt_succ_l.
-
-Theorem Zsucc_lt_mono : forall n m : Z, n < m <-> S n < S m.
-Proof NZsucc_lt_mono.
-
-Theorem Zsucc_le_mono : forall n m : Z, n <= m <-> S n <= S m.
-Proof NZsucc_le_mono.
-
-Theorem Zlt_asymm : forall n m, n < m -> ~ m < n.
-Proof NZlt_asymm.
-
-Notation Zlt_ngt := Zlt_asymm (only parsing).
-
-Theorem Zlt_trans : forall n m p : Z, n < m -> m < p -> n < p.
-Proof NZlt_trans.
-
-Theorem Zle_trans : forall n m p : Z, n <= m -> m <= p -> n <= p.
-Proof NZle_trans.
-
-Theorem Zle_lt_trans : forall n m p : Z, n <= m -> m < p -> n < p.
-Proof NZle_lt_trans.
-
-Theorem Zlt_le_trans : forall n m p : Z, n < m -> m <= p -> n < p.
-Proof NZlt_le_trans.
-
-Theorem Zle_antisymm : forall n m : Z, n <= m -> m <= n -> n == m.
-Proof NZle_antisymm.
-
-Theorem Zlt_1_l : forall n m : Z, 0 < n -> n < m -> 1 < m.
-Proof NZlt_1_l.
-
-(** Trichotomy, decidability, and double negation elimination *)
-
-Theorem Zlt_trichotomy : forall n m : Z,  n < m \/ n == m \/ m < n.
-Proof NZlt_trichotomy.
-
-Notation Zlt_eq_gt_cases := Zlt_trichotomy (only parsing).
-
-Theorem Zlt_gt_cases : forall n m : Z, n ~= m <-> n < m \/ n > m.
-Proof NZlt_gt_cases.
-
-Theorem Zle_gt_cases : forall n m : Z, n <= m \/ n > m.
-Proof NZle_gt_cases.
-
-Theorem Zlt_ge_cases : forall n m : Z, n < m \/ n >= m.
-Proof NZlt_ge_cases.
-
-Theorem Zle_ge_cases : forall n m : Z, n <= m \/ n >= m.
-Proof NZle_ge_cases.
-
-(** Instances of the previous theorems for m == 0 *)
-
-Theorem Zneg_pos_cases : forall n : Z, n ~= 0 <-> n < 0 \/ n > 0.
+Theorem neg_pos_cases : forall n, n ~= 0 <-> n < 0 \/ n > 0.
 Proof.
-intro; apply Zlt_gt_cases.
+intro; apply lt_gt_cases.
 Qed.
 
-Theorem Znonpos_pos_cases : forall n : Z, n <= 0 \/ n > 0.
+Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0.
 Proof.
-intro; apply Zle_gt_cases.
+intro; apply le_gt_cases.
 Qed.
 
-Theorem Zneg_nonneg_cases : forall n : Z, n < 0 \/ n >= 0.
+Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0.
 Proof.
-intro; apply Zlt_ge_cases.
+intro; apply lt_ge_cases.
 Qed.
 
-Theorem Znonpos_nonneg_cases : forall n : Z, n <= 0 \/ n >= 0.
+Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0.
 Proof.
-intro; apply Zle_ge_cases.
+intro; apply le_ge_cases.
 Qed.
 
-Theorem Zle_ngt : forall n m : Z, n <= m <-> ~ n > m.
-Proof NZle_ngt.
-
-Theorem Znlt_ge : forall n m : Z, ~ n < m <-> n >= m.
-Proof NZnlt_ge.
-
-Theorem Zlt_dec : forall n m : Z, decidable (n < m).
-Proof NZlt_dec.
-
-Theorem Zlt_dne : forall n m, ~ ~ n < m <-> n < m.
-Proof NZlt_dne.
-
-Theorem Znle_gt : forall n m : Z, ~ n <= m <-> n > m.
-Proof NZnle_gt.
-
-Theorem Zlt_nge : forall n m : Z, n < m <-> ~ n >= m.
-Proof NZlt_nge.
-
-Theorem Zle_dec : forall n m : Z, decidable (n <= m).
-Proof NZle_dec.
-
-Theorem Zle_dne : forall n m : Z, ~ ~ n <= m <-> n <= m.
-Proof NZle_dne.
-
-Theorem Znlt_succ_r : forall n m : Z, ~ m < S n <-> n < m.
-Proof NZnlt_succ_r.
-
-Theorem Zlt_exists_pred :
-  forall z n : Z, z < n -> exists k : Z, n == S k /\ z <= k.
-Proof NZlt_exists_pred.
-
-Theorem Zlt_succ_iter_r :
-  forall (n : nat) (m : Z), m < NZsucc_iter (Datatypes.S n) m.
-Proof NZlt_succ_iter_r.
-
-Theorem Zneq_succ_iter_l :
-  forall (n : nat) (m : Z), NZsucc_iter (Datatypes.S n) m ~= m.
-Proof NZneq_succ_iter_l.
-
-(** Stronger variant of induction with assumptions n >= 0 (n < 0)
-in the induction step *)
-
-Theorem Zright_induction :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z, A z ->
-      (forall n : Z, z <= n -> A n -> A (S n)) ->
-        forall n : Z, z <= n -> A n.
-Proof NZright_induction.
-
-Theorem Zleft_induction :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z, A z ->
-      (forall n : Z, n < z -> A (S n) -> A n) ->
-        forall n : Z, n <= z -> A n.
-Proof NZleft_induction.
-
-Theorem Zright_induction' :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z,
-      (forall n : Z, n <= z -> A n) ->
-      (forall n : Z, z <= n -> A n -> A (S n)) ->
-        forall n : Z, A n.
-Proof NZright_induction'.
-
-Theorem Zleft_induction' :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z,
-    (forall n : Z, z <= n -> A n) ->
-    (forall n : Z, n < z -> A (S n) -> A n) ->
-      forall n : Z, A n.
-Proof NZleft_induction'.
-
-Theorem Zstrong_right_induction :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z,
-    (forall n : Z, z <= n -> (forall m : Z, z <= m -> m < n -> A m) -> A n) ->
-       forall n : Z, z <= n -> A n.
-Proof NZstrong_right_induction.
-
-Theorem Zstrong_left_induction :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z,
-      (forall n : Z, n <= z -> (forall m : Z, m <= z -> S n <= m -> A m) -> A n) ->
-        forall n : Z, n <= z -> A n.
-Proof NZstrong_left_induction.
-
-Theorem Zstrong_right_induction' :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z,
-      (forall n : Z, n <= z -> A n) ->
-      (forall n : Z, z <= n -> (forall m : Z, z <= m -> m < n -> A m) -> A n) ->
-        forall n : Z, A n.
-Proof NZstrong_right_induction'.
-
-Theorem Zstrong_left_induction' :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z,
-    (forall n : Z, z <= n -> A n) ->
-    (forall n : Z, n <= z -> (forall m : Z, m <= z -> S n <= m -> A m) -> A n) ->
-      forall n : Z, A n.
-Proof NZstrong_left_induction'.
-
-Theorem Zorder_induction :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z, A z ->
-    (forall n : Z, z <= n -> A n -> A (S n)) ->
-    (forall n : Z, n < z -> A (S n) -> A n) ->
-      forall n : Z, A n.
-Proof NZorder_induction.
-
-Theorem Zorder_induction' :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall z : Z, A z ->
-    (forall n : Z, z <= n -> A n -> A (S n)) ->
-    (forall n : Z, n <= z -> A n -> A (P n)) ->
-      forall n : Z, A n.
-Proof NZorder_induction'.
-
-Theorem Zorder_induction_0 :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    A 0 ->
-    (forall n : Z, 0 <= n -> A n -> A (S n)) ->
-    (forall n : Z, n < 0 -> A (S n) -> A n) ->
-      forall n : Z, A n.
-Proof NZorder_induction_0.
-
-Theorem Zorder_induction'_0 :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    A 0 ->
-    (forall n : Z, 0 <= n -> A n -> A (S n)) ->
-    (forall n : Z, n <= 0 -> A n -> A (P n)) ->
-      forall n : Z, A n.
-Proof NZorder_induction'_0.
-
-Ltac Zinduct n := induction_maker n ltac:(apply Zorder_induction_0).
-
-(** Elimintation principle for < *)
-
-Theorem Zlt_ind :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall n : Z, A (S n) ->
-      (forall m : Z, n < m -> A m -> A (S m)) -> forall m : Z, n < m -> A m.
-Proof NZlt_ind.
-
-(** Elimintation principle for <= *)
-
-Theorem Zle_ind :
-  forall A : Z -> Prop, predicate_wd Zeq A ->
-    forall n : Z, A n ->
-      (forall m : Z, n <= m -> A m -> A (S m)) -> forall m : Z, n <= m -> A m.
-Proof NZle_ind.
-
-(** Well-founded relations *)
-
-Theorem Zlt_wf : forall z : Z, well_founded (fun n m : Z => z <= n /\ n < m).
-Proof NZlt_wf.
-
-Theorem Zgt_wf : forall z : Z, well_founded (fun n m : Z => m < n /\ n <= z).
-Proof NZgt_wf.
+Ltac zinduct n := induction_maker n ltac:(apply order_induction_0).
 
-(* Theorems that are either not valid on N or have different proofs on N and Z *)
+(** Theorems that are either not valid on N or have different proofs
+    on N and Z *)
 
-Theorem Zlt_pred_l : forall n : Z, P n < n.
+Theorem lt_pred_l : forall n, P n < n.
 Proof.
-intro n; rewrite <- (Zsucc_pred n) at 2; apply Zlt_succ_diag_r.
+intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r.
 Qed.
 
-Theorem Zle_pred_l : forall n : Z, P n <= n.
+Theorem le_pred_l : forall n, P n <= n.
 Proof.
-intro; apply Zlt_le_incl; apply Zlt_pred_l.
+intro; apply lt_le_incl; apply lt_pred_l.
 Qed.
 
-Theorem Zlt_le_pred : forall n m : Z, n < m <-> n <= P m.
+Theorem lt_le_pred : forall n m, n < m <-> n <= P m.
 Proof.
-intros n m; rewrite <- (Zsucc_pred m); rewrite Zpred_succ. apply Zlt_succ_r.
+intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r.
 Qed.
 
-Theorem Znle_pred_r : forall n : Z, ~ n <= P n.
+Theorem nle_pred_r : forall n, ~ n <= P n.
 Proof.
-intro; rewrite <- Zlt_le_pred; apply Zlt_irrefl.
+intro; rewrite <- lt_le_pred; apply lt_irrefl.
 Qed.
 
-Theorem Zlt_pred_le : forall n m : Z, P n < m <-> n <= m.
+Theorem lt_pred_le : forall n m, P n < m <-> n <= m.
 Proof.
-intros n m; rewrite <- (Zsucc_pred n) at 2.
-symmetry; apply Zle_succ_l.
+intros n m; rewrite <- (succ_pred n) at 2.
+symmetry; apply le_succ_l.
 Qed.
 
-Theorem Zlt_lt_pred : forall n m : Z, n < m -> P n < m.
+Theorem lt_lt_pred : forall n m, n < m -> P n < m.
 Proof.
-intros; apply <- Zlt_pred_le; now apply Zlt_le_incl.
+intros; apply <- lt_pred_le; now apply lt_le_incl.
 Qed.
 
-Theorem Zle_le_pred : forall n m : Z, n <= m -> P n <= m.
+Theorem le_le_pred : forall n m, n <= m -> P n <= m.
 Proof.
-intros; apply Zlt_le_incl; now apply <- Zlt_pred_le.
+intros; apply lt_le_incl; now apply <- lt_pred_le.
 Qed.
 
-Theorem Zlt_pred_lt : forall n m : Z, n < P m -> n < m.
+Theorem lt_pred_lt : forall n m, n < P m -> n < m.
 Proof.
-intros n m H; apply Zlt_trans with (P m); [assumption | apply Zlt_pred_l].
+intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l].
 Qed.
 
-Theorem Zle_pred_lt : forall n m : Z, n <= P m -> n <= m.
+Theorem le_pred_lt : forall n m, n <= P m -> n <= m.
 Proof.
-intros; apply Zlt_le_incl; now apply <- Zlt_le_pred.
+intros; apply lt_le_incl; now apply <- lt_le_pred.
 Qed.
 
-Theorem Zpred_lt_mono : forall n m : Z, n < m <-> P n < P m.
+Theorem pred_lt_mono : forall n m, n < m <-> P n < P m.
 Proof.
-intros; rewrite Zlt_le_pred; symmetry; apply Zlt_pred_le.
+intros; rewrite lt_le_pred; symmetry; apply lt_pred_le.
 Qed.
 
-Theorem Zpred_le_mono : forall n m : Z, n <= m <-> P n <= P m.
+Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m.
 Proof.
-intros; rewrite <- Zlt_pred_le; now rewrite Zlt_le_pred.
+intros; rewrite <- lt_pred_le; now rewrite lt_le_pred.
 Qed.
 
-Theorem Zlt_succ_lt_pred : forall n m : Z, S n < m <-> n < P m.
+Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m.
 Proof.
-intros n m; now rewrite (Zpred_lt_mono (S n) m), Zpred_succ.
+intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ.
 Qed.
 
-Theorem Zle_succ_le_pred : forall n m : Z, S n <= m <-> n <= P m.
+Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m.
 Proof.
-intros n m; now rewrite (Zpred_le_mono (S n) m), Zpred_succ.
+intros n m; now rewrite (pred_le_mono (S n) m), pred_succ.
 Qed.
 
-Theorem Zlt_pred_lt_succ : forall n m : Z, P n < m <-> n < S m.
+Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m.
 Proof.
-intros; rewrite Zlt_pred_le; symmetry; apply Zlt_succ_r.
+intros; rewrite lt_pred_le; symmetry; apply lt_succ_r.
 Qed.
 
-Theorem Zle_pred_lt_succ : forall n m : Z, P n <= m <-> n <= S m.
+Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m.
 Proof.
-intros n m; now rewrite (Zpred_le_mono n (S m)), Zpred_succ.
+intros n m; now rewrite (pred_le_mono n (S m)), pred_succ.
 Qed.
 
-Theorem Zneq_pred_l : forall n : Z, P n ~= n.
+Theorem neq_pred_l : forall n, P n ~= n.
 Proof.
-intro; apply Zlt_neq; apply Zlt_pred_l.
+intro; apply lt_neq; apply lt_pred_l.
 Qed.
 
-Theorem Zlt_n1_r : forall n m : Z, n < m -> m < 0 -> n < -1.
+Theorem lt_n1_r : forall n m, n < m -> m < 0 -> n < -(1).
 Proof.
-intros n m H1 H2. apply -> Zlt_le_pred in H2.
-setoid_replace (P 0) with (-1) in H2. now apply NZlt_le_trans with m.
-apply <- Zeq_opp_r. now rewrite Zopp_pred, Zopp_0.
+intros n m H1 H2. apply -> lt_le_pred in H2.
+setoid_replace (P 0) with (-(1)) in H2. now apply lt_le_trans with m.
+apply <- eq_opp_r. now rewrite opp_pred, opp_0.
 Qed.
 
 End ZOrderPropFunct.
diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v
index c48d1b4c..84d840ad 100644
--- a/theories/Numbers/Integer/Abstract/ZMul.v
+++ b/theories/Numbers/Integer/Abstract/ZMul.v
@@ -8,106 +8,63 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export ZAdd.
 
-Module ZMulPropFunct (Import ZAxiomsMod : ZAxiomsSig).
-Module Export ZAddPropMod := ZAddPropFunct ZAxiomsMod.
-Open Local Scope IntScope.
+Module ZMulPropFunct (Import Z : ZAxiomsSig').
+Include ZAddPropFunct Z.
 
-Theorem Zmul_wd :
-  forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> n1 * m1 == n2 * m2.
-Proof NZmul_wd.
+(** A note on naming: right (correspondingly, left) distributivity
+    happens when the sum is multiplied by a number on the right
+    (left), not when the sum itself is the right (left) factor in the
+    product (see planetmath.org and mathworld.wolfram.com). In the old
+    library BinInt, distributivity over subtraction was named
+    correctly, but distributivity over addition was named
+    incorrectly. The names in Isabelle/HOL library are also
+    incorrect. *)
 
-Theorem Zmul_0_l : forall n : Z, 0 * n == 0.
-Proof NZmul_0_l.
+(** Theorems that are either not valid on N or have different proofs
+    on N and Z *)
 
-Theorem Zmul_succ_l : forall n m : Z, (S n) * m == n * m + m.
-Proof NZmul_succ_l.
-
-(* Theorems that are valid for both natural numbers and integers *)
-
-Theorem Zmul_0_r : forall n : Z, n * 0 == 0.
-Proof NZmul_0_r.
-
-Theorem Zmul_succ_r : forall n m : Z, n * (S m) == n * m + n.
-Proof NZmul_succ_r.
-
-Theorem Zmul_comm : forall n m : Z, n * m == m * n.
-Proof NZmul_comm.
-
-Theorem Zmul_add_distr_r : forall n m p : Z, (n + m) * p == n * p + m * p.
-Proof NZmul_add_distr_r.
-
-Theorem Zmul_add_distr_l : forall n m p : Z, n * (m + p) == n * m + n * p.
-Proof NZmul_add_distr_l.
-
-(* A note on naming: right (correspondingly, left) distributivity happens
-when the sum is multiplied by a number on the right (left), not when the
-sum itself is the right (left) factor in the product (see planetmath.org
-and mathworld.wolfram.com). In the old library BinInt, distributivity over
-subtraction was named correctly, but distributivity over addition was named
-incorrectly. The names in Isabelle/HOL library are also incorrect. *)
-
-Theorem Zmul_assoc : forall n m p : Z, n * (m * p) == (n * m) * p.
-Proof NZmul_assoc.
-
-Theorem Zmul_1_l : forall n : Z, 1 * n == n.
-Proof NZmul_1_l.
-
-Theorem Zmul_1_r : forall n : Z, n * 1 == n.
-Proof NZmul_1_r.
-
-(* The following two theorems are true in an ordered ring,
-but since they don't mention order, we'll put them here *)
-
-Theorem Zeq_mul_0 : forall n m : Z, n * m == 0 <-> n == 0 \/ m == 0.
-Proof NZeq_mul_0.
-
-Theorem Zneq_mul_0 : forall n m : Z, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
-Proof NZneq_mul_0.
-
-(* Theorems that are either not valid on N or have different proofs on N and Z *)
-
-Theorem Zmul_pred_r : forall n m : Z, n * (P m) == n * m - n.
+Theorem mul_pred_r : forall n m, n * (P m) == n * m - n.
 Proof.
 intros n m.
-rewrite <- (Zsucc_pred m) at 2.
-now rewrite Zmul_succ_r, <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r.
+rewrite <- (succ_pred m) at 2.
+now rewrite mul_succ_r, <- add_sub_assoc, sub_diag, add_0_r.
 Qed.
 
-Theorem Zmul_pred_l : forall n m : Z, (P n) * m == n * m - m.
+Theorem mul_pred_l : forall n m, (P n) * m == n * m - m.
 Proof.
-intros n m; rewrite (Zmul_comm (P n) m), (Zmul_comm n m). apply Zmul_pred_r.
+intros n m; rewrite (mul_comm (P n) m), (mul_comm n m). apply mul_pred_r.
 Qed.
 
-Theorem Zmul_opp_l : forall n m : Z, (- n) * m == - (n * m).
+Theorem mul_opp_l : forall n m, (- n) * m == - (n * m).
 Proof.
-intros n m. apply -> Zadd_move_0_r.
-now rewrite <- Zmul_add_distr_r, Zadd_opp_diag_l, Zmul_0_l.
+intros n m. apply -> add_move_0_r.
+now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l.
 Qed.
 
-Theorem Zmul_opp_r : forall n m : Z, n * (- m) == - (n * m).
+Theorem mul_opp_r : forall n m, n * (- m) == - (n * m).
 Proof.
-intros n m; rewrite (Zmul_comm n (- m)), (Zmul_comm n m); apply Zmul_opp_l.
+intros n m; rewrite (mul_comm n (- m)), (mul_comm n m); apply mul_opp_l.
 Qed.
 
-Theorem Zmul_opp_opp : forall n m : Z, (- n) * (- m) == n * m.
+Theorem mul_opp_opp : forall n m, (- n) * (- m) == n * m.
 Proof.
-intros n m; now rewrite Zmul_opp_l, Zmul_opp_r, Zopp_involutive.
+intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive.
 Qed.
 
-Theorem Zmul_sub_distr_l : forall n m p : Z, n * (m - p) == n * m - n * p.
+Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p.
 Proof.
-intros n m p. do 2 rewrite <- Zadd_opp_r. rewrite Zmul_add_distr_l.
-now rewrite Zmul_opp_r.
+intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l.
+now rewrite mul_opp_r.
 Qed.
 
-Theorem Zmul_sub_distr_r : forall n m p : Z, (n - m) * p == n * p - m * p.
+Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p.
 Proof.
-intros n m p; rewrite (Zmul_comm (n - m) p), (Zmul_comm n p), (Zmul_comm m p);
-now apply Zmul_sub_distr_l.
+intros n m p; rewrite (mul_comm (n - m) p), (mul_comm n p), (mul_comm m p);
+now apply mul_sub_distr_l.
 Qed.
 
 End ZMulPropFunct.
diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v
index c7996ffd..99be58eb 100644
--- a/theories/Numbers/Integer/Abstract/ZMulOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v
@@ -8,335 +8,225 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZMulOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export ZAddOrder.
 
-Module ZMulOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig).
-Module Export ZAddOrderPropMod := ZAddOrderPropFunct ZAxiomsMod.
-Open Local Scope IntScope.
+Module Type ZMulOrderPropFunct (Import Z : ZAxiomsSig').
+Include ZAddOrderPropFunct Z.
 
-Theorem Zmul_lt_pred :
-  forall p q n m : Z, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
-Proof NZmul_lt_pred.
+Local Notation "- 1" := (-(1)).
 
-Theorem Zmul_lt_mono_pos_l : forall p n m : Z, 0 < p -> (n < m <-> p * n < p * m).
-Proof NZmul_lt_mono_pos_l.
-
-Theorem Zmul_lt_mono_pos_r : forall p n m : Z, 0 < p -> (n < m <-> n * p < m * p).
-Proof NZmul_lt_mono_pos_r.
-
-Theorem Zmul_lt_mono_neg_l : forall p n m : Z, p < 0 -> (n < m <-> p * m < p * n).
-Proof NZmul_lt_mono_neg_l.
-
-Theorem Zmul_lt_mono_neg_r : forall p n m : Z, p < 0 -> (n < m <-> m * p < n * p).
-Proof NZmul_lt_mono_neg_r.
-
-Theorem Zmul_le_mono_nonneg_l : forall n m p : Z, 0 <= p -> n <= m -> p * n <= p * m.
-Proof NZmul_le_mono_nonneg_l.
-
-Theorem Zmul_le_mono_nonpos_l : forall n m p : Z, p <= 0 -> n <= m -> p * m <= p * n.
-Proof NZmul_le_mono_nonpos_l.
-
-Theorem Zmul_le_mono_nonneg_r : forall n m p : Z, 0 <= p -> n <= m -> n * p <= m * p.
-Proof NZmul_le_mono_nonneg_r.
-
-Theorem Zmul_le_mono_nonpos_r : forall n m p : Z, p <= 0 -> n <= m -> m * p <= n * p.
-Proof NZmul_le_mono_nonpos_r.
-
-Theorem Zmul_cancel_l : forall n m p : Z, p ~= 0 -> (p * n == p * m <-> n == m).
-Proof NZmul_cancel_l.
-
-Theorem Zmul_cancel_r : forall n m p : Z, p ~= 0 -> (n * p == m * p <-> n == m).
-Proof NZmul_cancel_r.
-
-Theorem Zmul_id_l : forall n m : Z, m ~= 0 -> (n * m == m <-> n == 1).
-Proof NZmul_id_l.
-
-Theorem Zmul_id_r : forall n m : Z, n ~= 0 -> (n * m == n <-> m == 1).
-Proof NZmul_id_r.
-
-Theorem Zmul_le_mono_pos_l : forall n m p : Z, 0 < p -> (n <= m <-> p * n <= p * m).
-Proof NZmul_le_mono_pos_l.
-
-Theorem Zmul_le_mono_pos_r : forall n m p : Z, 0 < p -> (n <= m <-> n * p <= m * p).
-Proof NZmul_le_mono_pos_r.
-
-Theorem Zmul_le_mono_neg_l : forall n m p : Z, p < 0 -> (n <= m <-> p * m <= p * n).
-Proof NZmul_le_mono_neg_l.
-
-Theorem Zmul_le_mono_neg_r : forall n m p : Z, p < 0 -> (n <= m <-> m * p <= n * p).
-Proof NZmul_le_mono_neg_r.
-
-Theorem Zmul_lt_mono_nonneg :
-  forall n m p q : Z, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q.
-Proof NZmul_lt_mono_nonneg.
-
-Theorem Zmul_lt_mono_nonpos :
-  forall n m p q : Z, m <= 0 -> n < m -> q <= 0 -> p < q ->  m * q < n * p.
+Theorem mul_lt_mono_nonpos :
+  forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q ->  m * q < n * p.
 Proof.
 intros n m p q H1 H2 H3 H4.
-apply Zle_lt_trans with (m * p).
-apply Zmul_le_mono_nonpos_l; [assumption | now apply Zlt_le_incl].
-apply -> Zmul_lt_mono_neg_r; [assumption | now apply Zlt_le_trans with q].
+apply le_lt_trans with (m * p).
+apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl].
+apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q].
 Qed.
 
-Theorem Zmul_le_mono_nonneg :
-  forall n m p q : Z, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q.
-Proof NZmul_le_mono_nonneg.
-
-Theorem Zmul_le_mono_nonpos :
-  forall n m p q : Z, m <= 0 -> n <= m -> q <= 0 -> p <= q ->  m * q <= n * p.
+Theorem mul_le_mono_nonpos :
+  forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q ->  m * q <= n * p.
 Proof.
 intros n m p q H1 H2 H3 H4.
-apply Zle_trans with (m * p).
-now apply Zmul_le_mono_nonpos_l.
-apply Zmul_le_mono_nonpos_r; [now apply Zle_trans with q | assumption].
-Qed.
-
-Theorem Zmul_pos_pos : forall n m : Z, 0 < n -> 0 < m -> 0 < n * m.
-Proof NZmul_pos_pos.
-
-Theorem Zmul_neg_neg : forall n m : Z, n < 0 -> m < 0 -> 0 < n * m.
-Proof NZmul_neg_neg.
-
-Theorem Zmul_pos_neg : forall n m : Z, 0 < n -> m < 0 -> n * m < 0.
-Proof NZmul_pos_neg.
-
-Theorem Zmul_neg_pos : forall n m : Z, n < 0 -> 0 < m -> n * m < 0.
-Proof NZmul_neg_pos.
-
-Theorem Zmul_nonneg_nonneg : forall n m : Z, 0 <= n -> 0 <= m -> 0 <= n * m.
-Proof.
-intros n m H1 H2.
-rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonneg_r.
+apply le_trans with (m * p).
+now apply mul_le_mono_nonpos_l.
+apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption].
 Qed.
 
-Theorem Zmul_nonpos_nonpos : forall n m : Z, n <= 0 -> m <= 0 -> 0 <= n * m.
+Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m.
 Proof.
 intros n m H1 H2.
-rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonpos_r.
+rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r.
 Qed.
 
-Theorem Zmul_nonneg_nonpos : forall n m : Z, 0 <= n -> m <= 0 -> n * m <= 0.
+Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0.
 Proof.
 intros n m H1 H2.
-rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonpos_r.
+rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r.
 Qed.
 
-Theorem Zmul_nonpos_nonneg : forall n m : Z, n <= 0 -> 0 <= m -> n * m <= 0.
+Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0.
 Proof.
-intros; rewrite Zmul_comm; now apply Zmul_nonneg_nonpos.
+intros; rewrite mul_comm; now apply mul_nonneg_nonpos.
 Qed.
 
-Theorem Zlt_1_mul_pos : forall n m : Z, 1 < n -> 0 < m -> 1 < n * m.
-Proof NZlt_1_mul_pos.
-
-Theorem Zeq_mul_0 : forall n m : Z, n * m == 0 <-> n == 0 \/ m == 0.
-Proof NZeq_mul_0.
-
-Theorem Zneq_mul_0 : forall n m : Z, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
-Proof NZneq_mul_0.
-
-Theorem Zeq_square_0 : forall n : Z, n * n == 0 <-> n == 0.
-Proof NZeq_square_0.
+Notation mul_pos := lt_0_mul (only parsing).
 
-Theorem Zeq_mul_0_l : forall n m : Z, n * m == 0 -> m ~= 0 -> n == 0.
-Proof NZeq_mul_0_l.
-
-Theorem Zeq_mul_0_r : forall n m : Z, n * m == 0 -> n ~= 0 -> m == 0.
-Proof NZeq_mul_0_r.
-
-Theorem Zlt_0_mul : forall n m : Z, 0 < n * m <-> 0 < n /\ 0 < m \/ m < 0 /\ n < 0.
-Proof NZlt_0_mul.
-
-Notation Zmul_pos := Zlt_0_mul (only parsing).
-
-Theorem Zlt_mul_0 :
-  forall n m : Z, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0.
+Theorem lt_mul_0 :
+  forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0.
 Proof.
 intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]].
-destruct (Zlt_trichotomy n 0) as [H1 | [H1 | H1]];
-[| rewrite H1 in H; rewrite Zmul_0_l in H; false_hyp H Zlt_irrefl |];
-(destruct (Zlt_trichotomy m 0) as [H2 | [H2 | H2]];
-[| rewrite H2 in H; rewrite Zmul_0_r in H; false_hyp H Zlt_irrefl |]);
+destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
+[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |];
+(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
+[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]);
 try (left; now split); try (right; now split).
-assert (H3 : n * m > 0) by now apply Zmul_neg_neg.
-elimtype False; now apply (Zlt_asymm (n * m) 0).
-assert (H3 : n * m > 0) by now apply Zmul_pos_pos.
-elimtype False; now apply (Zlt_asymm (n * m) 0).
-now apply Zmul_neg_pos. now apply Zmul_pos_neg.
+assert (H3 : n * m > 0) by now apply mul_neg_neg.
+exfalso; now apply (lt_asymm (n * m) 0).
+assert (H3 : n * m > 0) by now apply mul_pos_pos.
+exfalso; now apply (lt_asymm (n * m) 0).
+now apply mul_neg_pos. now apply mul_pos_neg.
 Qed.
 
-Notation Zmul_neg := Zlt_mul_0 (only parsing).
+Notation mul_neg := lt_mul_0 (only parsing).
 
-Theorem Zle_0_mul :
-  forall n m : Z, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0.
+Theorem le_0_mul :
+  forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0.
 Proof.
-assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym).
-intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R.
-rewrite Zlt_0_mul, Zeq_mul_0.
-pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto.
+assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym).
+intros n m. repeat rewrite lt_eq_cases. repeat rewrite R.
+rewrite lt_0_mul, eq_mul_0.
+pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto.
 Qed.
 
-Notation Zmul_nonneg := Zle_0_mul (only parsing).
+Notation mul_nonneg := le_0_mul (only parsing).
 
-Theorem Zle_mul_0 :
-  forall n m : Z, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m.
+Theorem le_mul_0 :
+  forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m.
 Proof.
-assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym).
-intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R.
-rewrite Zlt_mul_0, Zeq_mul_0.
-pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto.
+assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym).
+intros n m. repeat rewrite lt_eq_cases. repeat rewrite R.
+rewrite lt_mul_0, eq_mul_0.
+pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto.
 Qed.
 
-Notation Zmul_nonpos := Zle_mul_0 (only parsing).
+Notation mul_nonpos := le_mul_0 (only parsing).
 
-Theorem Zle_0_square : forall n : Z, 0 <= n * n.
+Theorem le_0_square : forall n, 0 <= n * n.
 Proof.
-intro n; destruct (Zneg_nonneg_cases n).
-apply Zlt_le_incl; now apply Zmul_neg_neg.
-now apply Zmul_nonneg_nonneg.
+intro n; destruct (neg_nonneg_cases n).
+apply lt_le_incl; now apply mul_neg_neg.
+now apply mul_nonneg_nonneg.
 Qed.
 
-Notation Zsquare_nonneg := Zle_0_square (only parsing).
+Notation square_nonneg := le_0_square (only parsing).
 
-Theorem Znlt_square_0 : forall n : Z, ~ n * n < 0.
+Theorem nlt_square_0 : forall n, ~ n * n < 0.
 Proof.
-intros n H. apply -> Zlt_nge in H. apply H. apply Zsquare_nonneg.
+intros n H. apply -> lt_nge in H. apply H. apply square_nonneg.
 Qed.
 
-Theorem Zsquare_lt_mono_nonneg : forall n m : Z, 0 <= n -> n < m -> n * n < m * m.
-Proof NZsquare_lt_mono_nonneg.
-
-Theorem Zsquare_lt_mono_nonpos : forall n m : Z, n <= 0 -> m < n -> n * n < m * m.
+Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m.
 Proof.
-intros n m H1 H2. now apply Zmul_lt_mono_nonpos.
+intros n m H1 H2. now apply mul_lt_mono_nonpos.
 Qed.
 
-Theorem Zsquare_le_mono_nonneg : forall n m : Z, 0 <= n -> n <= m -> n * n <= m * m.
-Proof NZsquare_le_mono_nonneg.
-
-Theorem Zsquare_le_mono_nonpos : forall n m : Z, n <= 0 -> m <= n -> n * n <= m * m.
+Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m.
 Proof.
-intros n m H1 H2. now apply Zmul_le_mono_nonpos.
+intros n m H1 H2. now apply mul_le_mono_nonpos.
 Qed.
 
-Theorem Zsquare_lt_simpl_nonneg : forall n m : Z, 0 <= m -> n * n < m * m -> n < m.
-Proof NZsquare_lt_simpl_nonneg.
-
-Theorem Zsquare_le_simpl_nonneg : forall n m : Z, 0 <= m -> n * n <= m * m -> n <= m.
-Proof NZsquare_le_simpl_nonneg.
-
-Theorem Zsquare_lt_simpl_nonpos : forall n m : Z, m <= 0 -> n * n < m * m -> m < n.
+Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n.
 Proof.
-intros n m H1 H2. destruct (Zle_gt_cases n 0).
-destruct (NZlt_ge_cases m n).
-assumption. assert (F : m * m <= n * n) by now apply Zsquare_le_mono_nonpos.
-apply -> NZle_ngt in F. false_hyp H2 F.
-now apply Zle_lt_trans with 0.
+intros n m H1 H2. destruct (le_gt_cases n 0).
+destruct (lt_ge_cases m n).
+assumption. assert (F : m * m <= n * n) by now apply square_le_mono_nonpos.
+apply -> le_ngt in F. false_hyp H2 F.
+now apply le_lt_trans with 0.
 Qed.
 
-Theorem Zsquare_le_simpl_nonpos : forall n m : NZ, m <= 0 -> n * n <= m * m -> m <= n.
+Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n.
 Proof.
-intros n m H1 H2. destruct (NZle_gt_cases n 0).
-destruct (NZle_gt_cases m n).
-assumption. assert (F : m * m < n * n) by now apply Zsquare_lt_mono_nonpos.
-apply -> NZlt_nge in F. false_hyp H2 F.
-apply Zlt_le_incl; now apply NZle_lt_trans with 0.
+intros n m H1 H2. destruct (le_gt_cases n 0).
+destruct (le_gt_cases m n).
+assumption. assert (F : m * m < n * n) by now apply square_lt_mono_nonpos.
+apply -> lt_nge in F. false_hyp H2 F.
+apply lt_le_incl; now apply le_lt_trans with 0.
 Qed.
 
-Theorem Zmul_2_mono_l : forall n m : Z, n < m -> 1 + (1 + 1) * n < (1 + 1) * m.
-Proof NZmul_2_mono_l.
-
-Theorem Zlt_1_mul_neg : forall n m : Z, n < -1 -> m < 0 -> 1 < n * m.
+Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m.
 Proof.
-intros n m H1 H2. apply -> (NZmul_lt_mono_neg_r m) in H1.
-apply <- Zopp_pos_neg in H2. rewrite Zmul_opp_l, Zmul_1_l in H1.
-now apply Zlt_1_l with (- m).
+intros n m H1 H2. apply -> (mul_lt_mono_neg_r m) in H1.
+apply <- opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1.
+now apply lt_1_l with (- m).
 assumption.
 Qed.
 
-Theorem Zlt_mul_n1_neg : forall n m : Z, 1 < n -> m < 0 -> n * m < -1.
+Theorem lt_mul_n1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1.
 Proof.
-intros n m H1 H2. apply -> (NZmul_lt_mono_neg_r m) in H1.
-rewrite Zmul_1_l in H1. now apply Zlt_n1_r with m.
+intros n m H1 H2. apply -> (mul_lt_mono_neg_r m) in H1.
+rewrite mul_1_l in H1. now apply lt_n1_r with m.
 assumption.
 Qed.
 
-Theorem Zlt_mul_n1_pos : forall n m : Z, n < -1 -> 0 < m -> n * m < -1.
+Theorem lt_mul_n1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1.
 Proof.
-intros n m H1 H2. apply -> (NZmul_lt_mono_pos_r m) in H1.
-rewrite Zmul_opp_l, Zmul_1_l in H1.
-apply <- Zopp_neg_pos in H2. now apply Zlt_n1_r with (- m).
+intros n m H1 H2. apply -> (mul_lt_mono_pos_r m) in H1.
+rewrite mul_opp_l, mul_1_l in H1.
+apply <- opp_neg_pos in H2. now apply lt_n1_r with (- m).
 assumption.
 Qed.
 
-Theorem Zlt_1_mul_l : forall n m : Z, 1 < n -> n * m < -1 \/ n * m == 0 \/ 1 < n * m.
+Theorem lt_1_mul_l : forall n m, 1 < n ->
+ n * m < -1 \/ n * m == 0 \/ 1 < n * m.
 Proof.
-intros n m H; destruct (Zlt_trichotomy m 0) as [H1 | [H1 | H1]].
-left. now apply Zlt_mul_n1_neg.
-right; left; now rewrite H1, Zmul_0_r.
-right; right; now apply Zlt_1_mul_pos.
+intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]].
+left. now apply lt_mul_n1_neg.
+right; left; now rewrite H1, mul_0_r.
+right; right; now apply lt_1_mul_pos.
 Qed.
 
-Theorem Zlt_n1_mul_r : forall n m : Z, n < -1 -> n * m < -1 \/ n * m == 0 \/ 1 < n * m.
+Theorem lt_n1_mul_r : forall n m, n < -1 ->
+ n * m < -1 \/ n * m == 0 \/ 1 < n * m.
 Proof.
-intros n m H; destruct (Zlt_trichotomy m 0) as [H1 | [H1 | H1]].
-right; right. now apply Zlt_1_mul_neg.
-right; left; now rewrite H1, Zmul_0_r.
-left. now apply Zlt_mul_n1_pos.
+intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]].
+right; right. now apply lt_1_mul_neg.
+right; left; now rewrite H1, mul_0_r.
+left. now apply lt_mul_n1_pos.
 Qed.
 
-Theorem Zeq_mul_1 : forall n m : Z, n * m == 1 -> n == 1 \/ n == -1.
+Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1.
 Proof.
 assert (F : ~ 1 < -1).
 intro H.
-assert (H1 : -1 < 0). apply <- Zopp_neg_pos. apply Zlt_succ_diag_r.
-assert (H2 : 1 < 0) by now apply Zlt_trans with (-1). false_hyp H2 Znlt_succ_diag_l.
-Z0_pos_neg n.
-intros m H; rewrite Zmul_0_l in H; false_hyp H Zneq_succ_diag_r.
-intros n H; split; apply <- Zle_succ_l in H; le_elim H.
-intros m H1; apply (Zlt_1_mul_l n m) in H.
+assert (H1 : -1 < 0). apply <- opp_neg_pos. apply lt_succ_diag_r.
+assert (H2 : 1 < 0) by now apply lt_trans with (-1).
+false_hyp H2 nlt_succ_diag_l.
+zero_pos_neg n.
+intros m H; rewrite mul_0_l in H; false_hyp H neq_succ_diag_r.
+intros n H; split; apply <- le_succ_l in H; le_elim H.
+intros m H1; apply (lt_1_mul_l n m) in H.
 rewrite H1 in H; destruct H as [H | [H | H]].
-false_hyp H F. false_hyp H Zneq_succ_diag_l. false_hyp H Zlt_irrefl.
+false_hyp H F. false_hyp H neq_succ_diag_l. false_hyp H lt_irrefl.
 intros; now left.
-intros m H1; apply (Zlt_1_mul_l n m) in H. rewrite Zmul_opp_l in H1;
-apply -> Zeq_opp_l in H1. rewrite H1 in H; destruct H as [H | [H | H]].
-false_hyp H Zlt_irrefl. apply -> Zeq_opp_l in H. rewrite Zopp_0 in H.
-false_hyp H Zneq_succ_diag_l. false_hyp H F.
-intros; right; symmetry; now apply Zopp_wd.
+intros m H1; apply (lt_1_mul_l n m) in H. rewrite mul_opp_l in H1;
+apply -> eq_opp_l in H1. rewrite H1 in H; destruct H as [H | [H | H]].
+false_hyp H lt_irrefl. apply -> eq_opp_l in H. rewrite opp_0 in H.
+false_hyp H neq_succ_diag_l. false_hyp H F.
+intros; right; symmetry; now apply opp_wd.
 Qed.
 
-Theorem Zlt_mul_diag_l : forall n m : Z, n < 0 -> (1 < m <-> n * m < n).
+Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n).
 Proof.
-intros n m H. stepr (n * m < n * 1) by now rewrite Zmul_1_r.
-now apply Zmul_lt_mono_neg_l.
+intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r.
+now apply mul_lt_mono_neg_l.
 Qed.
 
-Theorem Zlt_mul_diag_r : forall n m : Z, 0 < n -> (1 < m <-> n < n * m).
+Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m).
 Proof.
-intros n m H. stepr (n * 1 < n * m) by now rewrite Zmul_1_r.
-now apply Zmul_lt_mono_pos_l.
+intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r.
+now apply mul_lt_mono_pos_l.
 Qed.
 
-Theorem Zle_mul_diag_l : forall n m : Z, n < 0 -> (1 <= m <-> n * m <= n).
+Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n).
 Proof.
-intros n m H. stepr (n * m <= n * 1) by now rewrite Zmul_1_r.
-now apply Zmul_le_mono_neg_l.
+intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r.
+now apply mul_le_mono_neg_l.
 Qed.
 
-Theorem Zle_mul_diag_r : forall n m : Z, 0 < n -> (1 <= m <-> n <= n * m).
+Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m).
 Proof.
-intros n m H. stepr (n * 1 <= n * m) by now rewrite Zmul_1_r.
-now apply Zmul_le_mono_pos_l.
+intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r.
+now apply mul_le_mono_pos_l.
 Qed.
 
-Theorem Zlt_mul_r : forall n m p : Z, 0 < n -> 1 < p -> n < m -> n < m * p.
+Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p.
 Proof.
-intros. stepl (n * 1) by now rewrite Zmul_1_r.
-apply Zmul_lt_mono_nonneg.
-now apply Zlt_le_incl. assumption. apply Zle_0_1. assumption.
+intros. stepl (n * 1) by now rewrite mul_1_r.
+apply mul_lt_mono_nonneg.
+now apply lt_le_incl. assumption. apply le_0_1. assumption.
 Qed.
 
 End ZMulOrderPropFunct.
diff --git a/contrib/correctness/Correctness.v b/theories/Numbers/Integer/Abstract/ZProperties.v
index b7513d09..dc46edda 100644
--- a/contrib/correctness/Correctness.v
+++ b/theories/Numbers/Integer/Abstract/ZProperties.v
@@ -6,20 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+(*i $Id$ i*)
 
-(* $Id: Correctness.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+Require Export ZAxioms ZMulOrder ZSgnAbs.
 
-(* Correctness is base on the tactic Refine (developped on purpose) *)
+(** This functor summarizes all known facts about Z.
+    For the moment it is only an alias to [ZMulOrderPropFunct], which
+    subsumes all others, plus properties of [sgn] and [abs].
+*)
 
-Require Export Tuples.
+Module Type ZPropSig (Z:ZAxiomsExtSig) :=
+ ZMulOrderPropFunct Z <+ ZSgnAbsPropSig Z.
 
-Require Export ProgInt.
-Require Export ProgBool.
-Require Export Zwf.
+Module ZPropFunct (Z:ZAxiomsExtSig) <: ZPropSig Z.
+ Include ZPropSig Z.
+End ZPropFunct.
 
-Require Export Arrays.
-
-(*
-Token "'".
-*)
\ No newline at end of file
diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v
new file mode 100644
index 00000000..8b191613
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v
@@ -0,0 +1,348 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export ZMulOrder.
+
+(** An axiomatization of [abs]. *)
+
+Module Type HasAbs(Import Z : ZAxiomsSig').
+ Parameter Inline abs : t -> t.
+ Axiom abs_eq : forall n, 0<=n -> abs n == n.
+ Axiom abs_neq : forall n, n<=0 -> abs n == -n.
+End HasAbs.
+
+(** Since we already have [max], we could have defined [abs]. *)
+
+Module GenericAbs (Import Z : ZAxiomsSig')
+                  (Import ZP : ZMulOrderPropFunct Z) <: HasAbs Z.
+ Definition abs n := max n (-n).
+ Lemma abs_eq : forall n, 0<=n -> abs n == n.
+ Proof.
+  intros. unfold abs. apply max_l.
+  apply le_trans with 0; auto.
+  rewrite opp_nonpos_nonneg; auto.
+ Qed.
+ Lemma abs_neq : forall n, n<=0 -> abs n == -n.
+ Proof.
+  intros. unfold abs. apply max_r.
+  apply le_trans with 0; auto.
+  rewrite opp_nonneg_nonpos; auto.
+ Qed.
+End GenericAbs.
+
+(** An Axiomatization of [sgn]. *)
+
+Module Type HasSgn (Import Z : ZAxiomsSig').
+ Parameter Inline sgn : t -> t.
+ Axiom sgn_null : forall n, n==0 -> sgn n == 0.
+ Axiom sgn_pos : forall n, 0<n -> sgn n == 1.
+ Axiom sgn_neg : forall n, n<0 -> sgn n == -(1).
+End HasSgn.
+
+(** We can deduce a [sgn] function from a [compare] function *)
+
+Module Type ZDecAxiomsSig := ZAxiomsSig <+ HasCompare.
+Module Type ZDecAxiomsSig' := ZAxiomsSig' <+ HasCompare.
+
+Module Type GenericSgn (Import Z : ZDecAxiomsSig')
+                       (Import ZP : ZMulOrderPropFunct Z) <: HasSgn Z.
+ Definition sgn n :=
+  match compare 0 n with Eq => 0 | Lt => 1 | Gt => -(1) end.
+ Lemma sgn_null : forall n, n==0 -> sgn n == 0.
+ Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
+ Lemma sgn_pos : forall n, 0<n -> sgn n == 1.
+ Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
+ Lemma sgn_neg : forall n, n<0 -> sgn n == -(1).
+ Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
+End GenericSgn.
+
+Module Type ZAxiomsExtSig := ZAxiomsSig <+ HasAbs <+ HasSgn.
+Module Type ZAxiomsExtSig' := ZAxiomsSig' <+ HasAbs <+ HasSgn.
+
+Module Type ZSgnAbsPropSig (Import Z : ZAxiomsExtSig')
+                           (Import ZP : ZMulOrderPropFunct Z).
+
+Ltac destruct_max n :=
+ destruct (le_ge_cases 0 n);
+  [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto].
+
+Instance abs_wd : Proper (eq==>eq) abs.
+Proof.
+ intros x y EQ. destruct_max x.
+ rewrite abs_eq; trivial. now rewrite <- EQ.
+ rewrite abs_neq; try order. now rewrite opp_inj_wd.
+Qed.
+
+Lemma abs_max : forall n, abs n == max n (-n).
+Proof.
+ intros n. destruct_max n.
+ rewrite max_l; auto with relations.
+ apply le_trans with 0; auto.
+ rewrite opp_nonpos_nonneg; auto.
+ rewrite max_r; auto with relations.
+ apply le_trans with 0; auto.
+ rewrite opp_nonneg_nonpos; auto.
+Qed.
+
+Lemma abs_neq' : forall n, 0<=-n -> abs n == -n.
+Proof.
+ intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos.
+Qed.
+
+Lemma abs_nonneg : forall n, 0 <= abs n.
+Proof.
+ intros n. destruct_max n; auto.
+ now rewrite opp_nonneg_nonpos.
+Qed.
+
+Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n.
+Proof.
+ split; try apply abs_eq. intros EQ.
+ rewrite <- EQ. apply abs_nonneg.
+Qed.
+
+Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0.
+Proof.
+ split; try apply abs_neq. intros EQ.
+ rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg.
+Qed.
+
+Lemma abs_opp : forall n, abs (-n) == abs n.
+Proof.
+ intros. destruct_max n.
+ rewrite (abs_neq (-n)), opp_involutive. reflexivity.
+ now rewrite opp_nonpos_nonneg.
+ rewrite (abs_eq (-n)). reflexivity.
+ now rewrite opp_nonneg_nonpos.
+Qed.
+
+Lemma abs_0 : abs 0 == 0.
+Proof.
+ apply abs_eq. apply le_refl.
+Qed.
+
+Lemma abs_0_iff : forall n, abs n == 0 <-> n==0.
+Proof.
+ split. destruct_max n; auto.
+ now rewrite eq_opp_l, opp_0.
+ intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl.
+Qed.
+
+Lemma abs_pos : forall n, 0 < abs n <-> n~=0.
+Proof.
+ intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ].
+ intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0).
+ assert (LE : 0 <= abs n) by apply abs_nonneg.
+ rewrite lt_eq_cases in LE; destruct LE; auto.
+ elim NEQ; auto with relations.
+Qed.
+
+Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n.
+Proof.
+ intros. destruct_max n; auto with relations.
+Qed.
+
+Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n.
+Proof.
+ intros. destruct_max n; rewrite ? opp_involutive; auto with relations.
+Qed.
+
+Lemma abs_involutive : forall n, abs (abs n) == abs n.
+Proof.
+ intros. apply abs_eq. apply abs_nonneg.
+Qed.
+
+Lemma abs_spec : forall n,
+  (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n).
+Proof.
+ intros. destruct (le_gt_cases 0 n).
+ left; split; auto. now apply abs_eq.
+ right; split; auto. apply abs_neq. now apply lt_le_incl.
+Qed.
+
+Lemma abs_case_strong :
+  forall (P:t->Prop) n, Proper (eq==>iff) P ->
+    (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n).
+Proof.
+ intros. destruct_max n; auto.
+Qed.
+
+Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P ->
+ P n -> P (-n) -> P (abs n).
+Proof. intros. now apply abs_case_strong. Qed.
+
+Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m.
+Proof.
+ intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn].
+ rewrite EQn, EQ. apply abs_eq_or_opp.
+ rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp.
+Qed.
+
+(** Triangular inequality *)
+
+Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m.
+Proof.
+ intros. destruct_max n; destruct_max m.
+ rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg.
+ destruct_max (n+m); try rewrite opp_add_distr;
+  apply add_le_mono_l || apply add_le_mono_r.
+ apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
+ apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
+ destruct_max (n+m); try rewrite opp_add_distr;
+  apply add_le_mono_l || apply add_le_mono_r.
+ apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
+ apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
+ rewrite abs_neq, opp_add_distr. apply le_refl.
+ now apply add_nonpos_nonpos.
+Qed.
+
+Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m).
+Proof.
+ intros.
+ rewrite le_sub_le_add_l, add_comm.
+ rewrite <- (sub_simpl_r n m) at 1.
+ apply abs_triangle.
+Qed.
+
+(** Absolute value and multiplication *)
+
+Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m.
+Proof.
+ assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m).
+  intros. destruct_max m.
+  rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg.
+  rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos .
+ intros. destruct_max n. now apply H.
+ rewrite <- mul_opp_opp, H, abs_opp. reflexivity.
+ now apply opp_nonneg_nonpos.
+Qed.
+
+Lemma abs_square : forall n, abs n * abs n == n * n.
+Proof.
+ intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square.
+Qed.
+
+(** Some results about the sign function. *)
+
+Ltac destruct_sgn n :=
+ let LT := fresh "LT" in
+ let EQ := fresh "EQ" in
+ let GT := fresh "GT" in
+ destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]];
+ [rewrite (sgn_pos n) by auto|
+  rewrite (sgn_null n) by auto with relations|
+  rewrite (sgn_neg n) by auto].
+
+Instance sgn_wd : Proper (eq==>eq) sgn.
+Proof.
+ intros x y Hxy. destruct_sgn x.
+ rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto.
+ rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations.
+ rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto.
+Qed.
+
+Lemma sgn_spec : forall n,
+  0 < n /\ sgn n == 1 \/
+  0 == n /\ sgn n == 0 \/
+  0 > n /\ sgn n == -(1).
+Proof.
+ intros n.
+ destruct_sgn n; [left|right;left|right;right]; auto with relations.
+Qed.
+
+Lemma sgn_0 : sgn 0 == 0.
+Proof.
+ now apply sgn_null.
+Qed.
+
+Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n.
+Proof.
+ split; try apply sgn_pos. destruct_sgn n; auto.
+ intros. elim (lt_neq 0 1); auto. apply lt_0_1.
+ intros. elim (lt_neq (-(1)) 1); auto.
+ apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
+Qed.
+
+Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0.
+Proof.
+ split; try apply sgn_null. destruct_sgn n; auto with relations.
+ intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1.
+ intros. elim (lt_neq (-(1)) 0); auto.
+ rewrite opp_neg_pos. apply lt_0_1.
+Qed.
+
+Lemma sgn_neg_iff : forall n, sgn n == -(1) <-> n<0.
+Proof.
+ split; try apply sgn_neg. destruct_sgn n; auto with relations.
+ intros. elim (lt_neq (-(1)) 1); auto with relations.
+ apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
+ intros. elim (lt_neq (-(1)) 0); auto with relations.
+ rewrite opp_neg_pos. apply lt_0_1.
+Qed.
+
+Lemma sgn_opp : forall n, sgn (-n) == - sgn n.
+Proof.
+ intros. destruct_sgn n.
+ apply sgn_neg. now rewrite opp_neg_pos.
+ setoid_replace n with 0 by auto with relations.
+  rewrite opp_0. apply sgn_0.
+ rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg.
+Qed.
+
+Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n.
+Proof.
+ split.
+ destruct_sgn n; intros.
+ now apply lt_le_incl.
+ order.
+ elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1.
+  now rewrite <- opp_nonneg_nonpos.
+ rewrite lt_eq_cases; destruct 1.
+ rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1.
+ rewrite sgn_null by auto with relations. apply le_refl.
+Qed.
+
+Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0.
+Proof.
+ intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg.
+Qed.
+
+Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m.
+Proof.
+ intros. destruct_sgn n; nzsimpl.
+ destruct_sgn m.
+  apply sgn_pos. now apply mul_pos_pos.
+  apply sgn_null. rewrite eq_mul_0; auto with relations.
+  apply sgn_neg. now apply mul_pos_neg.
+ apply sgn_null. rewrite eq_mul_0; auto with relations.
+ destruct_sgn m; try rewrite mul_opp_opp; nzsimpl.
+  apply sgn_neg. now apply mul_neg_pos.
+  apply sgn_null. rewrite eq_mul_0; auto with relations.
+  apply sgn_pos. now apply mul_neg_neg.
+Qed.
+
+Lemma sgn_abs : forall n, n * sgn n == abs n.
+Proof.
+ intros. symmetry.
+ destruct_sgn n; try rewrite mul_opp_r; nzsimpl.
+ apply abs_eq. now apply lt_le_incl.
+ rewrite abs_0_iff; auto with relations.
+ apply abs_neq. now apply lt_le_incl.
+Qed.
+
+Lemma abs_sgn : forall n, abs n * sgn n == n.
+Proof.
+ intros.
+ destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto.
+ apply abs_eq. now apply lt_le_incl.
+ rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl.
+Qed.
+
+End ZSgnAbsPropSig.
+
+
diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v
index e5e950ac..4e024c02 100644
--- a/theories/Numbers/Integer/BigZ/BigZ.v
+++ b/theories/Numbers/Integer/BigZ/BigZ.v
@@ -8,20 +8,31 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: BigZ.v 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 Require Export BigN.
-Require Import ZMulOrder.
-Require Import ZSig.
-Require Import ZSigZAxioms.
-Require Import ZMake.
+Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake.
 
-Module BigZ <: ZType := ZMake.Make BigN.
+(** * [BigZ] : arbitrary large efficient integers.
 
-(** Module [BigZ] implements [ZAxiomsSig] *)
+    The following [BigZ] module regroups both the operations and
+    all the abstract properties:
 
-Module Export BigZAxiomsMod := ZSig_ZAxioms BigZ.
-Module Export BigZMulOrderPropMod := ZMulOrderPropFunct BigZAxiomsMod.
+    - [ZMake.Make BigN] provides the operations and basic specs w.r.t. ZArith
+    - [ZTypeIsZAxioms] shows (mainly) that these operations implement
+      the interface [ZAxioms]
+    - [ZPropSig] adds all generic properties derived from [ZAxioms]
+    - [ZDivPropFunct] provides generic properties of [div] and [mod]
+      ("Floor" variant)
+    - [MinMax*Properties] provides properties of [min] and [max]
+
+*)
+
+
+Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder :=
+ ZMake.Make BigN <+ ZTypeIsZAxioms
+ <+ !ZPropSig <+ !ZDivPropFunct <+ HasEqBool2Dec
+ <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
 
 (** Notations about [BigZ] *)
 
@@ -31,26 +42,60 @@ Delimit Scope bigZ_scope with bigZ.
 Bind Scope bigZ_scope with bigZ.
 Bind Scope bigZ_scope with BigZ.t.
 Bind Scope bigZ_scope with BigZ.t_.
-
-Notation Local "0" := BigZ.zero : bigZ_scope.
+(* Bind Scope has no retroactive effect, let's declare scopes by hand. *)
+Arguments Scope BigZ.Pos [bigN_scope].
+Arguments Scope BigZ.Neg [bigN_scope].
+Arguments Scope BigZ.to_Z [bigZ_scope].
+Arguments Scope BigZ.succ [bigZ_scope].
+Arguments Scope BigZ.pred [bigZ_scope].
+Arguments Scope BigZ.opp [bigZ_scope].
+Arguments Scope BigZ.square [bigZ_scope].
+Arguments Scope BigZ.add [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.sub [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.mul [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.div [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.eq [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.lt [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.le [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.eq [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.compare [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.min [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.max [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.eq_bool [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.power_pos [bigZ_scope positive_scope].
+Arguments Scope BigZ.power [bigZ_scope N_scope].
+Arguments Scope BigZ.sqrt [bigZ_scope].
+Arguments Scope BigZ.div_eucl [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.modulo [bigZ_scope bigZ_scope].
+Arguments Scope BigZ.gcd [bigZ_scope bigZ_scope].
+
+Local Notation "0" := BigZ.zero : bigZ_scope.
+Local Notation "1" := BigZ.one : bigZ_scope.
 Infix "+" := BigZ.add : bigZ_scope.
 Infix "-" := BigZ.sub : bigZ_scope.
 Notation "- x" := (BigZ.opp x) : bigZ_scope.
 Infix "*" := BigZ.mul : bigZ_scope.
 Infix "/" := BigZ.div : bigZ_scope.
+Infix "^" := BigZ.power : bigZ_scope.
 Infix "?=" := BigZ.compare : bigZ_scope.
 Infix "==" := BigZ.eq (at level 70, no associativity) : bigZ_scope.
+Notation "x != y" := (~x==y)%bigZ (at level 70, no associativity) : bigZ_scope.
 Infix "<" := BigZ.lt : bigZ_scope.
 Infix "<=" := BigZ.le : bigZ_scope.
 Notation "x > y" := (BigZ.lt y x)(only parsing) : bigZ_scope.
 Notation "x >= y" := (BigZ.le y x)(only parsing) : bigZ_scope.
+Notation "x < y < z" := (x<y /\ y<z)%bigZ : bigZ_scope.
+Notation "x < y <= z" := (x<y /\ y<=z)%bigZ : bigZ_scope.
+Notation "x <= y < z" := (x<=y /\ y<z)%bigZ : bigZ_scope.
+Notation "x <= y <= z" := (x<=y /\ y<=z)%bigZ : bigZ_scope.
 Notation "[ i ]" := (BigZ.to_Z i) : bigZ_scope.
+Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigN_scope.
 
-Open Scope bigZ_scope.
+Local Open Scope bigZ_scope.
 
 (** Some additional results about [BigZ] *)
 
-Theorem spec_to_Z: forall n:bigZ,
+Theorem spec_to_Z: forall n : bigZ,
   BigN.to_Z (BigZ.to_N n) = ((Zsgn [n]) * [n])%Z.
 Proof.
 intros n; case n; simpl; intros p;
@@ -62,7 +107,7 @@ Qed.
 Theorem spec_to_N n:
  ([n] = Zsgn [n] * (BigN.to_Z (BigZ.to_N n)))%Z.
 Proof.
-intros n; case n; simpl; intros p;
+case n; simpl; intros p;
   generalize (BigN.spec_pos p); case (BigN.to_Z p); auto.
 intros p1 H1; case H1; auto.
 intros p1 H1; case H1; auto.
@@ -77,35 +122,97 @@ intros p1 _ H1; case H1; auto.
 intros p1 H1; case H1; auto.
 Qed.
 
-Lemma sub_opp : forall x y : bigZ, x - y == x + (- y).
+(** [BigZ] is a ring *)
+
+Lemma BigZring :
+ ring_theory 0 1 BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq.
 Proof.
-red; intros; zsimpl; auto.
+constructor.
+exact BigZ.add_0_l. exact BigZ.add_comm. exact BigZ.add_assoc.
+exact BigZ.mul_1_l. exact BigZ.mul_comm. exact BigZ.mul_assoc.
+exact BigZ.mul_add_distr_r.
+symmetry. apply BigZ.add_opp_r.
+exact BigZ.add_opp_diag_r.
 Qed.
 
-Lemma add_opp : forall x : bigZ, x + (- x) == 0.
+Lemma BigZeqb_correct : forall x y, BigZ.eq_bool x y = true -> x==y.
+Proof. now apply BigZ.eqb_eq. Qed.
+
+Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq (@id N) BigZ.power.
 Proof.
-red; intros; zsimpl; auto with zarith.
+constructor.
+intros. red. rewrite BigZ.spec_power. unfold id.
+destruct Zpower_theory as [EQ]. rewrite EQ.
+destruct n; simpl. reflexivity.
+induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto.
 Qed.
 
-(** [BigZ] is a ring *)
+Lemma BigZdiv : div_theory BigZ.eq BigZ.add BigZ.mul (@id _)
+ (fun a b => if BigZ.eq_bool b 0 then (0,a) else BigZ.div_eucl a b).
+Proof.
+constructor. unfold id. intros a b.
+BigZ.zify.
+generalize (Zeq_bool_if [b] 0); destruct (Zeq_bool [b] 0).
+BigZ.zify. auto with zarith.
+intros NEQ.
+generalize (BigZ.spec_div_eucl a b).
+generalize (Z_div_mod_full [a] [b] NEQ).
+destruct BigZ.div_eucl as (q,r), Zdiv_eucl as (q',r').
+intros (EQ,_). injection 1. intros EQr EQq.
+BigZ.zify. rewrite EQr, EQq; auto.
+Qed.
 
-Lemma BigZring :
- ring_theory BigZ.zero BigZ.one BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq.
+(** Detection of constants *)
+
+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.minus_one => constr:true
+ | _ => constr:false
+ end.
+
+Ltac BigZcst t :=
+ match isBigZcst t with
+ | true => constr:t
+ | false => constr:NotConstant
+ end.
+
+(** Registration for the "ring" tactic *)
+
+Add Ring BigZr : BigZring
+ (decidable BigZeqb_correct,
+  constants [BigZcst],
+  power_tac BigZpower [Ncst],
+  div BigZdiv).
+
+Section TestRing.
+Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
 Proof.
-constructor.
-exact Zadd_0_l.
-exact Zadd_comm.
-exact Zadd_assoc.
-exact Zmul_1_l.
-exact Zmul_comm.
-exact Zmul_assoc.
-exact Zmul_add_distr_r.
-exact sub_opp.
-exact add_opp.
+intros. ring_simplify. reflexivity.
 Qed.
+Let test' : forall x y, 1 + x*y + x^2 - 1*1 - y*x + 1*(-x)*x == 0.
+Proof.
+intros. ring_simplify. reflexivity.
+Qed.
+End TestRing.
+
+(** [BigZ] also benefits from an "order" tactic *)
+
+Ltac bigZ_order := BigZ.order.
+
+Section TestOrder.
+Let test : forall x y : bigZ, x<=y -> y<=x -> x==y.
+Proof. bigZ_order. Qed.
+End TestOrder.
 
-Add Ring BigZr : BigZring.
+(** We can use at least a bit of (r)omega by translating to [Z]. *)
 
-(** Todo: tactic translating from [BigZ] to [Z] + omega *)
+Section TestOmega.
+Let test : forall x y : bigZ, x<=y -> y<=x -> x==y.
+Proof. intros x y. BigZ.zify. omega. Qed.
+End TestOmega.
 
 (** Todo: micromega *)
diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v
index 98ad4c64..3196f11e 100644
--- a/theories/Numbers/Integer/BigZ/ZMake.v
+++ b/theories/Numbers/Integer/BigZ/ZMake.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: ZMake.v 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith.
 Require Import BigNumPrelude.
@@ -17,31 +17,31 @@ Require Import ZSig.
 
 Open Scope Z_scope.
 
-(** * ZMake 
- 
-  A generic transformation from a structure of natural numbers 
+(** * ZMake
+
+  A generic transformation from a structure of natural numbers
   [NSig.NType] to a structure of integers [ZSig.ZType].
 *)
 
 Module Make (N:NType) <: ZType.
- 
- Inductive t_ := 
+
+ Inductive t_ :=
   | Pos : N.t -> t_
   | Neg : N.t -> t_.
- 
+
  Definition t := t_.
 
  Definition zero := Pos N.zero.
  Definition one  := Pos N.one.
  Definition minus_one := Neg N.one.
 
- Definition of_Z x := 
+ Definition of_Z x :=
   match x with
   | Zpos x => Pos (N.of_N (Npos x))
   | Z0 => zero
   | Zneg x => Neg (N.of_N (Npos x))
   end.
- 
+
  Definition to_Z x :=
   match x with
   | Pos nx => N.to_Z nx
@@ -49,6 +49,7 @@ Module Make (N:NType) <: ZType.
   end.
 
  Theorem spec_of_Z: forall x, to_Z (of_Z x) = x.
+ Proof.
  intros x; case x; unfold to_Z, of_Z, zero.
    exact N.spec_0.
    intros; rewrite N.spec_of_N; auto.
@@ -85,72 +86,52 @@ Module Make (N:NType) <: ZType.
   | Neg nx, Neg ny => N.compare ny nx
   end.
 
- Definition lt n m := compare n m = Lt.
- Definition le n m := compare n m <> Gt.
- Definition min n m := match compare n m with Gt => m | _ => n end.
- Definition max n m := match compare n m with Lt => m | _ => n end.
+ Theorem spec_compare :
+  forall x y, compare x y = Zcompare (to_Z x) (to_Z y).
+ Proof.
+ unfold compare, to_Z.
+ destruct x as [x|x], y as [y|y];
+ rewrite ?N.spec_compare, ?N.spec_0, <-?Zcompare_opp; auto;
+ assert (Hx:=N.spec_pos x); assert (Hy:=N.spec_pos y);
+ set (X:=N.to_Z x) in *; set (Y:=N.to_Z y) in *; clearbody X Y.
+ destruct (Zcompare_spec X 0) as [EQ|LT|GT].
+  rewrite EQ. rewrite <- Zopp_0 at 2. apply Zcompare_opp.
+  exfalso. omega.
+  symmetry. change (X > -Y). omega.
+ destruct (Zcompare_spec 0 X) as [EQ|LT|GT].
+  rewrite <- EQ. rewrite Zopp_0; auto.
+  symmetry. change (-X < Y). omega.
+  exfalso. omega.
+ Qed.
 
- Theorem spec_compare: forall x y,
-    match compare x y with
-      Eq => to_Z x = to_Z y
-    | Lt => to_Z x < to_Z y
-    | Gt => to_Z x > to_Z y
-    end.
-  unfold compare, to_Z; intros x y; case x; case y; clear x y;
-    intros x y; auto; generalize (N.spec_pos x) (N.spec_pos y).
-  generalize (N.spec_compare y x); case N.compare; auto with zarith.
-  generalize (N.spec_compare y N.zero); case N.compare; 
-     try rewrite N.spec_0; auto with zarith.
-  generalize (N.spec_compare x N.zero); case N.compare;
-   rewrite N.spec_0; auto with zarith.
-  generalize (N.spec_compare x N.zero); case N.compare;
-   rewrite N.spec_0; auto with zarith.
-  generalize (N.spec_compare N.zero y); case N.compare; 
-     try rewrite N.spec_0; auto with zarith.
-  generalize (N.spec_compare N.zero x); case N.compare;
-   rewrite N.spec_0; auto with zarith.
-  generalize (N.spec_compare N.zero x); case N.compare;
-   rewrite N.spec_0; auto with zarith.
-  generalize (N.spec_compare x y); case N.compare; auto with zarith.
-  Qed.
-
- Definition eq_bool x y := 
+ Definition eq_bool x y :=
   match compare x y with
   | Eq => true
   | _ => false
   end.
 
- Theorem spec_eq_bool: forall x y,
-    if eq_bool x y then to_Z x = to_Z y else to_Z x <> to_Z y.
- intros x y; unfold eq_bool;
-   generalize (spec_compare x y); case compare; auto with zarith.
+ Theorem spec_eq_bool:
+  forall x y, eq_bool x y = Zeq_bool (to_Z x) (to_Z y).
+ Proof.
+ unfold eq_bool, Zeq_bool; intros; rewrite spec_compare; reflexivity.
  Qed.
 
- Definition cmp_sign x y :=
-  match x, y with
-  | Pos nx, Neg ny => 
-    if N.eq_bool ny N.zero then Eq else Gt 
-  | Neg nx, Pos ny => 
-    if N.eq_bool nx N.zero then Eq else Lt
-  | _, _ => Eq
-  end.
+ Definition lt n m := to_Z n < to_Z m.
+ Definition le n m := to_Z n <= to_Z m.
+
+ Definition min n m := match compare n m with Gt => m | _ => n end.
+ Definition max n m := match compare n m with Lt => m | _ => n end.
+
+ Theorem spec_min : forall n m, to_Z (min n m) = Zmin (to_Z n) (to_Z m).
+ Proof.
+ unfold min, Zmin. intros. rewrite spec_compare. destruct Zcompare; auto.
+ Qed.
+
+ Theorem spec_max : forall n m, to_Z (max n m) = Zmax (to_Z n) (to_Z m).
+ Proof.
+ unfold max, Zmax. intros. rewrite spec_compare. destruct Zcompare; auto.
+ Qed.
 
- Theorem spec_cmp_sign: forall x y,
-  match cmp_sign x y with
-  | Gt => 0 <= to_Z x /\ to_Z y < 0
-  | Lt => to_Z x <  0 /\ 0 <= to_Z y
-  | Eq => True
-  end.
-  Proof.
-  intros [x | x] [y | y]; unfold cmp_sign; auto.
-  generalize (N.spec_eq_bool y N.zero); case N.eq_bool; auto.
-  rewrite N.spec_0; unfold to_Z.
-  generalize (N.spec_pos x) (N.spec_pos y); auto with zarith.
-  generalize (N.spec_eq_bool x N.zero); case N.eq_bool; auto.
-  rewrite N.spec_0; unfold to_Z.
-  generalize (N.spec_pos x) (N.spec_pos y); auto with zarith.
-  Qed.
- 
  Definition to_N x :=
   match x with
   | Pos nx => nx
@@ -160,21 +141,23 @@ Module Make (N:NType) <: ZType.
  Definition abs x := Pos (to_N x).
 
  Theorem spec_abs: forall x, to_Z (abs x) = Zabs (to_Z x).
+ Proof.
  intros x; case x; clear x; intros x; assert (F:=N.spec_pos x).
     simpl; rewrite Zabs_eq; auto.
  simpl; rewrite Zabs_non_eq; simpl; auto with zarith.
  Qed.
- 
- Definition opp x := 
-  match x with 
+
+ Definition opp x :=
+  match x with
   | Pos nx => Neg nx
   | Neg nx => Pos nx
   end.
 
  Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x.
+ Proof.
  intros x; case x; simpl; auto with zarith.
  Qed.
-    
+
  Definition succ x :=
   match x with
   | Pos n => Pos (N.succ n)
@@ -186,12 +169,12 @@ Module Make (N:NType) <: ZType.
   end.
 
  Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1.
+ Proof.
  intros x; case x; clear x; intros x.
    exact (N.spec_succ x).
- simpl; generalize (N.spec_compare N.zero x); case N.compare; 
-   rewrite N.spec_0; simpl.
+ simpl. rewrite N.spec_compare. case Zcompare_spec; rewrite ?N.spec_0; simpl.
   intros HH; rewrite <- HH; rewrite N.spec_1; ring.
-  intros HH; rewrite N.spec_pred; auto with zarith.
+  intros HH; rewrite N.spec_pred, Zmax_r; auto with zarith.
  generalize (N.spec_pos x); auto with zarith.
  Qed.
 
@@ -212,19 +195,13 @@ Module Make (N:NType) <: ZType.
     end
   | Neg nx, Neg ny => Neg (N.add nx ny)
   end.
-  
+
  Theorem spec_add: forall x y, to_Z (add x y) = to_Z x +  to_Z y.
- unfold add, to_Z; intros [x | x] [y | y].
-   exact (N.spec_add x y).
- unfold zero; generalize (N.spec_compare x y); case N.compare.
-   rewrite N.spec_0; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- unfold zero; generalize (N.spec_compare x y); case N.compare.
-   rewrite N.spec_0; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- intros; rewrite N.spec_add; try ring; auto with zarith.
+ Proof.
+ unfold add, to_Z; intros [x | x] [y | y];
+   try (rewrite N.spec_add; auto with zarith);
+ rewrite N.spec_compare; case Zcompare_spec;
+  unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *.
  Qed.
 
  Definition pred x :=
@@ -238,17 +215,17 @@ Module Make (N:NType) <: ZType.
   end.
 
  Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1.
- unfold pred, to_Z, minus_one; intros [x | x].
-   generalize (N.spec_compare N.zero x); case N.compare; 
-     rewrite N.spec_0; try rewrite N.spec_1; auto with zarith.
-   intros H; exact (N.spec_pred _ H).
- generalize (N.spec_pos x); auto with zarith.
- rewrite N.spec_succ; ring.
+ Proof.
+ unfold pred, to_Z, minus_one; intros [x | x];
+   try (rewrite N.spec_succ; ring).
+ rewrite N.spec_compare; case Zcompare_spec;
+  rewrite ?N.spec_0, ?N.spec_1, ?N.spec_pred;
+  generalize (N.spec_pos x); omega with *.
  Qed.
 
  Definition sub x y :=
   match x, y with
-  | Pos nx, Pos ny => 
+  | Pos nx, Pos ny =>
     match N.compare nx ny with
     | Gt => Pos (N.sub nx ny)
     | Eq => zero
@@ -256,7 +233,7 @@ Module Make (N:NType) <: ZType.
     end
   | Pos nx, Neg ny => Pos (N.add nx ny)
   | Neg nx, Pos ny => Neg (N.add nx ny)
-  | Neg nx, Neg ny => 
+  | Neg nx, Neg ny =>
     match N.compare nx ny with
     | Gt => Neg (N.sub nx ny)
     | Eq => zero
@@ -265,20 +242,14 @@ Module Make (N:NType) <: ZType.
   end.
 
  Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y.
- unfold sub, to_Z; intros [x | x] [y | y].
- unfold zero; generalize (N.spec_compare x y); case N.compare.
-   rewrite N.spec_0; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- rewrite N.spec_add; ring.
- rewrite N.spec_add; ring.
- unfold zero; generalize (N.spec_compare x y); case N.compare.
-   rewrite N.spec_0; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
- intros; rewrite N.spec_sub; try ring; auto with zarith.
+ Proof.
+ unfold sub, to_Z; intros [x | x] [y | y];
+  try (rewrite N.spec_add; auto with zarith);
+ rewrite N.spec_compare; case Zcompare_spec;
+  unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *.
  Qed.
 
- Definition mul x y := 
+ Definition mul x y :=
   match x, y with
   | Pos nx, Pos ny => Pos (N.mul nx ny)
   | Pos nx, Neg ny => Neg (N.mul nx ny)
@@ -286,25 +257,26 @@ Module Make (N:NType) <: ZType.
   | Neg nx, Neg ny => Pos (N.mul nx ny)
   end.
 
-
  Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y.
+ Proof.
  unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring.
  Qed.
 
- Definition square x := 
+ Definition square x :=
   match x with
   | Pos nx => Pos (N.square nx)
   | Neg nx => Pos (N.square nx)
   end.
 
  Theorem spec_square: forall x, to_Z (square x) = to_Z x *  to_Z x.
+ Proof.
  unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring.
  Qed.
 
  Definition power_pos x p :=
   match x with
   | Pos nx => Pos (N.power_pos nx p)
-  | Neg nx => 
+  | Neg nx =>
     match p with
     | xH => x
     | xO _ => Pos (N.power_pos nx p)
@@ -313,9 +285,10 @@ Module Make (N:NType) <: ZType.
   end.
 
  Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n.
+ Proof.
  assert (F0: forall x, (-x)^2 = x^2).
    intros x; rewrite Zpower_2; ring.
- unfold power_pos, to_Z; intros [x | x] [p | p |]; 
+ unfold power_pos, to_Z; intros [x | x] [p | p |];
    try rewrite N.spec_power_pos; try ring.
  assert (F: 0 <= 2 * Zpos p).
   assert (0 <= Zpos p); auto with zarith.
@@ -329,15 +302,28 @@ Module Make (N:NType) <: ZType.
  rewrite F0; ring.
  Qed.
 
+ Definition power x n :=
+  match n with
+  | N0 => one
+  | Npos p => power_pos x p
+  end.
+
+ Theorem spec_power: forall x n, to_Z (power x n) = to_Z x ^ Z_of_N n.
+ Proof.
+ destruct n; simpl. rewrite N.spec_1; reflexivity.
+ apply spec_power_pos.
+ Qed.
+
+
  Definition sqrt x :=
   match x with
   | Pos nx => Pos (N.sqrt nx)
   | Neg nx => Neg N.zero
   end.
 
-
- Theorem spec_sqrt: forall x, 0 <= to_Z x -> 
+ Theorem spec_sqrt: forall x, 0 <= to_Z x ->
    to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2.
+ Proof.
  unfold to_Z, sqrt; intros [x | x] H.
    exact (N.spec_sqrt x).
  replace (N.to_Z x) with 0.
@@ -353,113 +339,75 @@ Module Make (N:NType) <: ZType.
     (Pos q, Pos r)
   | Pos nx, Neg ny =>
     let (q, r) := N.div_eucl nx ny in
-    match N.compare N.zero r with
-    | Eq => (Neg q, zero)
-    | _ => (Neg (N.succ q), Neg (N.sub ny r))
-    end
+    if N.eq_bool N.zero r
+    then (Neg q, zero)
+    else (Neg (N.succ q), Neg (N.sub ny r))
   | Neg nx, Pos ny =>
     let (q, r) := N.div_eucl nx ny in
-    match N.compare N.zero r with
-    | Eq => (Neg q, zero)
-    | _ => (Neg (N.succ q), Pos (N.sub ny r))
-    end
+    if N.eq_bool N.zero r
+    then (Neg q, zero)
+    else (Neg (N.succ q), Pos (N.sub ny r))
   | Neg nx, Neg ny =>
     let (q, r) := N.div_eucl nx ny in
     (Pos q, Neg r)
   end.
 
+ Ltac break_nonneg x px EQx :=
+  let H := fresh "H" in
+  assert (H:=N.spec_pos x);
+  destruct (N.to_Z x) as [|px|px]_eqn:EQx;
+   [clear H|clear H|elim H; reflexivity].
 
  Theorem spec_div_eucl: forall x y,
-      to_Z y <> 0 ->
-      let (q,r) := div_eucl x y in
-      (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y).
- unfold div_eucl, to_Z; intros [x | x] [y | y] H.
- assert (H1: 0 < N.to_Z y).
-   generalize (N.spec_pos y); auto with zarith.
- generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto.
- assert (HH: 0 < N.to_Z y).
-   generalize (N.spec_pos y); auto with zarith.
- generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto.
- intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl;
-   case_eq (N.to_Z x); case_eq (N.to_Z y); 
-     try (intros; apply False_ind; auto with zarith; fail).
- intros p He1 He2 _ _ H1; injection H1; intros H2 H3.
- generalize (N.spec_compare N.zero r); case N.compare;
-   unfold zero; rewrite N.spec_0; try rewrite H3; auto.
- rewrite H2; intros; apply False_ind; auto with zarith.
- rewrite H2; intros; apply False_ind; auto with zarith.
- intros p _ _ _ H1; discriminate H1.
- intros p He p1 He1 H1 _.
- generalize (N.spec_compare N.zero r); case N.compare.
- change (- Zpos p) with (Zneg p).
- unfold zero; lazy zeta.
- rewrite N.spec_0; intros H2; rewrite <- H2.
- intros H3; rewrite <- H3; auto.
- rewrite N.spec_0; intros H2.
- change (- Zpos p) with (Zneg p); lazy iota beta.
- intros H3; rewrite <- H3; auto.
- rewrite N.spec_succ; rewrite N.spec_sub.
- generalize H2; case (N.to_Z r).
- intros; apply False_ind; auto with zarith.
- intros p2 _; rewrite He; auto with zarith.
- change (Zneg p) with (- (Zpos p)); apply f_equal2 with (f := @pair Z Z); ring.
- intros p2 H4; discriminate H4.
- assert (N.to_Z r = (Zpos p1 mod (Zpos p))).
-   unfold Zmod, Zdiv_eucl; rewrite <- H3; auto.
- case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith.
- rewrite N.spec_0; intros H2; generalize (N.spec_pos r); 
-   intros; apply False_ind; auto with zarith.
- assert (HH: 0 < N.to_Z y).
-   generalize (N.spec_pos y); auto with zarith.
- generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto.
- intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl;
-   case_eq (N.to_Z x); case_eq (N.to_Z y); 
-     try (intros; apply False_ind; auto with zarith; fail).
- intros p He1 He2 _ _ H1; injection H1; intros H2 H3.
- generalize (N.spec_compare N.zero r); case N.compare;
-   unfold zero; rewrite N.spec_0; try rewrite H3; auto.
- rewrite H2; intros; apply False_ind; auto with zarith.
- rewrite H2; intros; apply False_ind; auto with zarith.
- intros p _ _ _ H1; discriminate H1.
- intros p He p1 He1 H1 _.
- generalize (N.spec_compare N.zero r); case N.compare.
- change (- Zpos p1) with (Zneg p1).
- unfold zero; lazy zeta.
- rewrite N.spec_0; intros H2; rewrite <- H2.
- intros H3; rewrite <- H3; auto.
- rewrite N.spec_0; intros H2.
- change (- Zpos p1) with (Zneg p1); lazy iota beta.
- intros H3; rewrite <- H3; auto.
- rewrite N.spec_succ; rewrite N.spec_sub.
- generalize H2; case (N.to_Z r).
- intros; apply False_ind; auto with zarith.
- intros p2 _; rewrite He; auto with zarith.
- intros p2 H4; discriminate H4.
- assert (N.to_Z r = (Zpos p1 mod (Zpos p))).
-   unfold Zmod, Zdiv_eucl; rewrite <- H3; auto.
- case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith.
- rewrite N.spec_0; generalize (N.spec_pos r); intros; apply False_ind; auto with zarith.
- assert (H1: 0 < N.to_Z y).
-   generalize (N.spec_pos y); auto with zarith.
- generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto.
- intros q r; generalize (N.spec_pos x) H1; unfold Zdiv_eucl;
-   case_eq (N.to_Z x); case_eq (N.to_Z y); 
-     try (intros; apply False_ind; auto with zarith; fail).
- change (-0) with 0; lazy iota beta; auto.
- intros p _ _ _ _ H2; injection H2.
- intros H3 H4; rewrite H3; rewrite H4; auto.
- intros p _ _ _ H2; discriminate H2.
- intros p He p1 He1 _ _  H2.
- change (- Zpos p1) with (Zneg p1); lazy iota beta.
- change (- Zpos p) with (Zneg p); lazy iota beta.
- rewrite <- H2; auto.
+   let (q,r) := div_eucl x y in
+   (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y).
+ Proof.
+ unfold div_eucl, to_Z. intros [x | x] [y | y].
+ (* Pos Pos *)
+ generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y); auto.
+ (* Pos Neg *)
+ generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r).
+ break_nonneg x px EQx; break_nonneg y py EQy;
+ try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr;
+      simpl; rewrite Hq, N.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 Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r').
+ intros (EQ,MOD). injection 1. intros Hr' Hq'.
+ rewrite N.spec_eq_bool, N.spec_0, Hr'.
+ break_nonneg r pr EQr.
+ subst; simpl. rewrite N.spec_0; auto.
+ subst. lazy iota beta delta [Zeq_bool Zcompare].
+ rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *.
+ (* Neg Pos *)
+ generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r).
+ break_nonneg x px EQx; break_nonneg y py EQy;
+ try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr;
+      simpl; rewrite Hq, N.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 Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r').
+ intros (EQ,MOD). injection 1. intros Hr' Hq'.
+ rewrite N.spec_eq_bool, N.spec_0, Hr'.
+ break_nonneg r pr EQr.
+ subst; simpl. rewrite N.spec_0; auto.
+ subst. lazy iota beta delta [Zeq_bool Zcompare].
+ rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *.
+ (* Neg Neg *)
+ generalize (N.spec_div_eucl x y); destruct (N.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).
+ simpl. intros <-; auto.
  Qed.
 
  Definition div x y := fst (div_eucl x y).
 
  Definition spec_div: forall x y,
-     to_Z y <> 0 -> to_Z (div x y) = to_Z x / to_Z y.
- intros x y H1; generalize (spec_div_eucl x y H1); unfold div, Zdiv.
+     to_Z (div x y) = to_Z x / to_Z y.
+ Proof.
+ intros x y; generalize (spec_div_eucl x y); unfold div, Zdiv.
  case div_eucl; case Zdiv_eucl; simpl; auto.
  intros q r q11 r1 H; injection H; auto.
  Qed.
@@ -467,8 +415,9 @@ Module Make (N:NType) <: ZType.
  Definition modulo x y := snd (div_eucl x y).
 
  Theorem spec_modulo:
-   forall x y, to_Z y <> 0  -> to_Z (modulo x y) = to_Z x mod to_Z y.
- intros x y H1; generalize (spec_div_eucl x y H1); unfold modulo, Zmod.
+   forall x y, to_Z (modulo x y) = to_Z x mod to_Z y.
+ Proof.
+ intros x y; generalize (spec_div_eucl x y); unfold modulo, Zmod.
  case div_eucl; case Zdiv_eucl; simpl; auto.
  intros q r q11 r1 H; injection H; auto.
  Qed.
@@ -478,14 +427,30 @@ Module Make (N:NType) <: ZType.
   | Pos nx, Pos ny => Pos (N.gcd nx ny)
   | Pos nx, Neg ny => Pos (N.gcd nx ny)
   | Neg nx, Pos ny => Pos (N.gcd nx ny)
-  | Neg nx, Neg ny => Pos (N.gcd nx ny) 
+  | Neg nx, Neg ny => Pos (N.gcd nx ny)
   end.
 
  Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b).
+ Proof.
  unfold gcd, Zgcd, to_Z; intros [x | x] [y | y]; rewrite N.spec_gcd; unfold Zgcd;
   auto; case N.to_Z; simpl; auto with zarith;
   try rewrite Zabs_Zopp; auto;
   case N.to_Z; simpl; auto with zarith.
  Qed.
 
+ Definition sgn x :=
+  match compare zero x with
+   | Lt => one
+   | Eq => zero
+   | Gt => minus_one
+  end.
+
+ Lemma spec_sgn : forall x, to_Z (sgn x) = Zsgn (to_Z x).
+ Proof.
+ intros. unfold sgn. rewrite spec_compare. case Zcompare_spec.
+ rewrite spec_0. intros <-; auto.
+ rewrite spec_0, spec_1. symmetry. rewrite Zsgn_pos; auto.
+ rewrite spec_0, spec_m1. symmetry. rewrite Zsgn_neg; auto with zarith.
+ Qed.
+
 End Make.
diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v
index 66d2a96a..835f7958 100644
--- a/theories/Numbers/Integer/Binary/ZBinary.v
+++ b/theories/Numbers/Integer/Binary/ZBinary.v
@@ -8,212 +8,103 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZBinary.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import ZMulOrder.
-Require Import ZArith.
 
-Open Local Scope Z_scope.
+Require Import ZAxioms ZProperties.
+Require Import ZArith_base.
 
-Module ZBinAxiomsMod <: ZAxiomsSig.
-Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig.
-Module Export NZAxiomsMod <: NZAxiomsSig.
+Local Open Scope Z_scope.
 
-Definition NZ := Z.
-Definition NZeq := (@eq Z).
-Definition NZ0 := 0.
-Definition NZsucc := Zsucc'.
-Definition NZpred := Zpred'.
-Definition NZadd := Zplus.
-Definition NZsub := Zminus.
-Definition NZmul := Zmult.
+(** * Implementation of [ZAxiomsSig] by [BinInt.Z] *)
 
-Theorem NZeq_equiv : equiv Z NZeq.
-Proof.
-exact (@eq_equiv Z).
-Qed.
-
-Add Relation Z NZeq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
-as NZeq_rel.
-
-Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd.
-Proof.
-congruence.
-Qed.
+Module ZBinAxiomsMod <: ZAxiomsExtSig.
 
-Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd.
-Proof.
-congruence.
-Qed.
+(** Bi-directional induction. *)
 
-Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd.
-Proof.
-congruence.
-Qed.
-
-Theorem NZpred_succ : forall n : Z, NZpred (NZsucc n) = n.
-Proof.
-exact Zpred'_succ'.
-Qed.
-
-Theorem NZinduction :
-  forall A : Z -> Prop, predicate_wd NZeq A ->
-    A 0 -> (forall n : Z, A n <-> A (NZsucc n)) -> forall n : Z, A n.
+Theorem bi_induction :
+  forall A : Z -> Prop, Proper (eq ==> iff) A ->
+    A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n.
 Proof.
 intros A A_wd A0 AS n; apply Zind; clear n.
 assumption.
-intros; now apply -> AS.
-intros n H. rewrite <- (Zsucc'_pred' n) in H. now apply <- AS.
-Qed.
-
-Theorem NZadd_0_l : forall n : Z, 0 + n = n.
-Proof.
-exact Zplus_0_l.
-Qed.
-
-Theorem NZadd_succ_l : forall n m : Z, (NZsucc n) + m = NZsucc (n + m).
-Proof.
-intros; do 2 rewrite <- Zsucc_succ'; apply Zplus_succ_l.
-Qed.
-
-Theorem NZsub_0_r : forall n : Z, n - 0 = n.
-Proof.
-exact Zminus_0_r.
-Qed.
-
-Theorem NZsub_succ_r : forall n m : Z, n - (NZsucc m) = NZpred (n - m).
-Proof.
-intros; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred';
-apply Zminus_succ_r.
-Qed.
-
-Theorem NZmul_0_l : forall n : Z, 0 * n = 0.
-Proof.
-reflexivity.
-Qed.
-
-Theorem NZmul_succ_l : forall n m : Z, (NZsucc n) * m = n * m + m.
-Proof.
-intros; rewrite <- Zsucc_succ'; apply Zmult_succ_l.
-Qed.
-
-End NZAxiomsMod.
-
-Definition NZlt := Zlt.
-Definition NZle := Zle.
-Definition NZmin := Zmin.
-Definition NZmax := Zmax.
-
-Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd.
-Proof.
-unfold NZeq. intros n1 n2 H1 m1 m2 H2; rewrite H1; now rewrite H2.
-Qed.
-
-Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd.
-Proof.
-unfold NZeq. intros n1 n2 H1 m1 m2 H2; rewrite H1; now rewrite H2.
-Qed.
-
-Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd.
-Proof.
-congruence.
-Qed.
-
-Theorem NZlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n = m.
-Proof.
-intros n m; split. apply Zle_lt_or_eq.
-intro H; destruct H as [H | H]. now apply Zlt_le_weak. rewrite H; apply Zle_refl.
-Qed.
-
-Theorem NZlt_irrefl : forall n : Z, ~ n < n.
-Proof.
-exact Zlt_irrefl.
-Qed.
-
-Theorem NZlt_succ_r : forall n m : Z, n < (NZsucc m) <-> n <= m.
-Proof.
-intros; unfold NZsucc; rewrite <- Zsucc_succ'; split;
-[apply Zlt_succ_le | apply Zle_lt_succ].
-Qed.
-
-Theorem NZmin_l : forall n m : NZ, n <= m -> NZmin n m = n.
-Proof.
-unfold NZmin, Zmin, Zle; intros n m H.
-destruct (n ?= m); try reflexivity. now elim H.
-Qed.
-
-Theorem NZmin_r : forall n m : NZ, m <= n -> NZmin n m = m.
-Proof.
-unfold NZmin, Zmin, Zle; intros n m H.
-case_eq (n ?= m); intro H1; try reflexivity.
-now apply Zcompare_Eq_eq.
-apply <- Zcompare_Gt_Lt_antisym in H1. now elim H.
-Qed.
-
-Theorem NZmax_l : forall n m : NZ, m <= n -> NZmax n m = n.
-Proof.
-unfold NZmax, Zmax, Zle; intros n m H.
-case_eq (n ?= m); intro H1; try reflexivity.
-apply <- Zcompare_Gt_Lt_antisym in H1. now elim H.
-Qed.
-
-Theorem NZmax_r : forall n m : NZ, n <= m -> NZmax n m = m.
-Proof.
-unfold NZmax, Zmax, Zle; intros n m H.
-case_eq (n ?= m); intro H1.
-now apply Zcompare_Eq_eq. reflexivity. now elim H.
-Qed.
-
-End NZOrdAxiomsMod.
-
-Definition Zopp (x : Z) :=
-match x with
-| Z0 => Z0
-| Zpos x => Zneg x
-| Zneg x => Zpos x
-end.
-
-Add Morphism Zopp with signature NZeq ==> NZeq as Zopp_wd.
-Proof.
-congruence.
-Qed.
-
-Theorem Zsucc_pred : forall n : Z, NZsucc (NZpred n) = n.
-Proof.
-exact Zsucc'_pred'.
-Qed.
-
-Theorem Zopp_0 : - 0 = 0.
-Proof.
-reflexivity.
-Qed.
-
-Theorem Zopp_succ : forall n : Z, - (NZsucc n) = NZpred (- n).
-Proof.
-intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'. apply Zopp_succ.
-Qed.
+intros; rewrite <- Zsucc_succ'. now apply -> AS.
+intros n H. rewrite <- Zpred_pred'. rewrite Zsucc_pred in H. now apply <- AS.
+Qed.
+
+(** Basic operations. *)
+
+Definition eq_equiv : Equivalence (@eq Z) := eq_equivalence.
+Local Obligation Tactic := simpl_relation.
+Program Instance succ_wd : Proper (eq==>eq) Zsucc.
+Program Instance pred_wd : Proper (eq==>eq) Zpred.
+Program Instance add_wd : Proper (eq==>eq==>eq) Zplus.
+Program Instance sub_wd : Proper (eq==>eq==>eq) Zminus.
+Program Instance mul_wd : Proper (eq==>eq==>eq) Zmult.
+
+Definition pred_succ n := eq_sym (Zpred_succ n).
+Definition add_0_l := Zplus_0_l.
+Definition add_succ_l := Zplus_succ_l.
+Definition sub_0_r := Zminus_0_r.
+Definition sub_succ_r := Zminus_succ_r.
+Definition mul_0_l := Zmult_0_l.
+Definition mul_succ_l := Zmult_succ_l.
+
+(** Order *)
+
+Program Instance lt_wd : Proper (eq==>eq==>iff) Zlt.
+
+Definition lt_eq_cases := Zle_lt_or_eq_iff.
+Definition lt_irrefl := Zlt_irrefl.
+Definition lt_succ_r := Zlt_succ_r.
+
+Definition min_l := Zmin_l.
+Definition min_r := Zmin_r.
+Definition max_l := Zmax_l.
+Definition max_r := Zmax_r.
+
+(** Properties specific to integers, not natural numbers. *)
+
+Program Instance opp_wd : Proper (eq==>eq) Zopp.
+
+Definition succ_pred n := eq_sym (Zsucc_pred n).
+Definition opp_0 := Zopp_0.
+Definition opp_succ := Zopp_succ.
+
+(** Absolute value and sign *)
+
+Definition abs_eq := Zabs_eq.
+Definition abs_neq := Zabs_non_eq.
+
+Lemma sgn_null : forall x, x = 0 -> Zsgn x = 0.
+Proof. intros. apply <- Zsgn_null; auto. Qed.
+Lemma sgn_pos : forall x, 0 < x -> Zsgn x = 1.
+Proof. intros. apply <- Zsgn_pos; auto. Qed.
+Lemma sgn_neg : forall x, x < 0 -> Zsgn x = -1.
+Proof. intros. apply <- Zsgn_neg; auto. Qed.
+
+(** The instantiation of operations.
+    Placing them at the very end avoids having indirections in above lemmas. *)
+
+Definition t := Z.
+Definition eq := (@eq Z).
+Definition zero := 0.
+Definition succ := Zsucc.
+Definition pred := Zpred.
+Definition add := Zplus.
+Definition sub := Zminus.
+Definition mul := Zmult.
+Definition lt := Zlt.
+Definition le := Zle.
+Definition min := Zmin.
+Definition max := Zmax.
+Definition opp := Zopp.
+Definition abs := Zabs.
+Definition sgn := Zsgn.
 
 End ZBinAxiomsMod.
 
-Module Export ZBinMulOrderPropMod := ZMulOrderPropFunct ZBinAxiomsMod.
+Module Export ZBinPropMod := ZPropFunct ZBinAxiomsMod.
 
 (** Z forms a ring *)
 
diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
index 9427b37b..8b5624cd 100644
--- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v
+++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
@@ -8,400 +8,306 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: ZNatPairs.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import NSub. (* The most complete file for natural numbers *)
-Require Export ZMulOrder. (* The most complete file for integers *)
+Require Import NProperties. (* The most complete file for N *)
+Require Export ZProperties. (* The most complete file for Z *)
 Require Export Ring.
 
-Module ZPairsAxiomsMod (Import NAxiomsMod : NAxiomsSig) <: ZAxiomsSig.
-Module Import NPropMod := NSubPropFunct NAxiomsMod. (* Get all properties of natural numbers *)
-
-(* We do not declare ring in Natural/Abstract for two reasons. First, some
-of the properties proved in NAdd and NMul are used in the new BinNat,
-and it is in turn used in Ring. Using ring in Natural/Abstract would be
-circular. It is possible, however, not to make BinNat dependent on
-Numbers/Natural and prove the properties necessary for ring from scratch
-(this is, of course, how it used to be). In addition, if we define semiring
-structures in the implementation subdirectories of Natural, we are able to
-specify binary natural numbers as the type of coefficients. For these
-reasons we define an abstract semiring here. *)
-
-Open Local Scope NatScope.
-
-Lemma Nsemi_ring : semi_ring_theory 0 1 add mul Neq.
-Proof.
-constructor.
-exact add_0_l.
-exact add_comm.
-exact add_assoc.
-exact mul_1_l.
-exact mul_0_l.
-exact mul_comm.
-exact mul_assoc.
-exact mul_add_distr_r.
-Qed.
-
-Add Ring NSR : Nsemi_ring.
-
-(* The definitios of functions (NZadd, NZmul, etc.) will be unfolded by
-the properties functor. Since we don't want Zadd_comm to refer to unfolded
-definitions of equality: fun p1 p2 : NZ => (fst p1 + snd p2) = (fst p2 + snd p1),
-we will provide an extra layer of definitions. *)
-
-Definition Z := (N * N)%type.
-Definition Z0 : Z := (0, 0).
-Definition Zeq (p1 p2 : Z) := ((fst p1) + (snd p2) == (fst p2) + (snd p1)).
-Definition Zsucc (n : Z) : Z := (S (fst n), snd n).
-Definition Zpred (n : Z) : Z := (fst n, S (snd n)).
-
-(* We do not have Zpred (Zsucc n) = n but only Zpred (Zsucc n) == n. It
-could be possible to consider as canonical only pairs where one of the
-elements is 0, and make all operations convert canonical values into other
-canonical values. In that case, we could get rid of setoids and arrive at
-integers as signed natural numbers. *)
-
-Definition Zadd (n m : Z) : Z := ((fst n) + (fst m), (snd n) + (snd m)).
-Definition Zsub (n m : Z) : Z := ((fst n) + (snd m), (snd n) + (fst m)).
-
-(* Unfortunately, the elements of the pair keep increasing, even during
-subtraction *)
-
-Definition Zmul (n m : Z) : Z :=
-  ((fst n) * (fst m) + (snd n) * (snd m), (fst n) * (snd m) + (snd n) * (fst m)).
-Definition Zlt (n m : Z) := (fst n) + (snd m) < (fst m) + (snd n).
-Definition Zle (n m : Z) := (fst n) + (snd m) <= (fst m) + (snd n).
-Definition Zmin (n m : Z) := (min ((fst n) + (snd m)) ((fst m) + (snd n)), (snd n) + (snd m)).
-Definition Zmax (n m : Z) := (max ((fst n) + (snd m)) ((fst m) + (snd n)), (snd n) + (snd m)).
-
-Delimit Scope IntScope with Int.
-Bind Scope IntScope with Z.
-Notation "x == y"  := (Zeq x y) (at level 70) : IntScope.
-Notation "x ~= y" := (~ Zeq x y) (at level 70) : IntScope.
-Notation "0" := Z0 : IntScope.
-Notation "1" := (Zsucc Z0) : IntScope.
-Notation "x + y" := (Zadd x y) : IntScope.
-Notation "x - y" := (Zsub x y) : IntScope.
-Notation "x * y" := (Zmul x y) : IntScope.
-Notation "x < y" := (Zlt x y) : IntScope.
-Notation "x <= y" := (Zle x y) : IntScope.
-Notation "x > y" := (Zlt y x) (only parsing) : IntScope.
-Notation "x >= y" := (Zle y x) (only parsing) : IntScope.
-
-Notation Local N := NZ.
-(* To remember N without having to use a long qualifying name. since NZ will be redefined *)
-Notation Local NE := NZeq (only parsing).
-Notation Local add_wd := NZadd_wd (only parsing).
-
-Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig.
-Module Export NZAxiomsMod <: NZAxiomsSig.
-
-Definition NZ : Type := Z.
-Definition NZeq := Zeq.
-Definition NZ0 := Z0.
-Definition NZsucc := Zsucc.
-Definition NZpred := Zpred.
-Definition NZadd := Zadd.
-Definition NZsub := Zsub.
-Definition NZmul := Zmul.
-
-Theorem ZE_refl : reflexive Z Zeq.
-Proof.
-unfold reflexive, Zeq. reflexivity.
-Qed.
-
-Theorem ZE_sym : symmetric Z Zeq.
-Proof.
-unfold symmetric, Zeq; now symmetry.
-Qed.
-
-Theorem ZE_trans : transitive Z Zeq.
-Proof.
-unfold transitive, Zeq. intros n m p H1 H2.
-assert (H3 : (fst n + snd m) + (fst m + snd p) == (fst m + snd n) + (fst p + snd m))
-by now apply add_wd.
-stepl ((fst n + snd p) + (fst m + snd m)) in H3 by ring.
-stepr ((fst p + snd n) + (fst m + snd m)) in H3 by ring.
-now apply -> add_cancel_r in H3.
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
+Open Local Scope pair_scope.
+
+Module ZPairsAxiomsMod (Import N : NAxiomsSig) <: ZAxiomsSig.
+Module Import NPropMod := NPropFunct N. (* Get all properties of N *)
+
+Delimit Scope NScope with N.
+Bind Scope NScope with N.t.
+Infix "=="  := N.eq (at level 70) : NScope.
+Notation "x ~= y" := (~ N.eq x y) (at level 70) : NScope.
+Notation "0" := N.zero : NScope.
+Notation "1" := (N.succ N.zero) : NScope.
+Infix "+" := N.add : NScope.
+Infix "-" := N.sub : NScope.
+Infix "*" := N.mul : NScope.
+Infix "<" := N.lt : NScope.
+Infix "<=" := N.le : NScope.
+Local Open Scope NScope.
+
+(** The definitions of functions ([add], [mul], etc.) will be unfolded
+    by the properties functor. Since we don't want [add_comm] to refer
+    to unfolded definitions of equality: [fun p1 p2 => (fst p1 +
+    snd p2) = (fst p2 + snd p1)], we will provide an extra layer of
+    definitions. *)
+
+Module Z.
+
+Definition t := (N.t * N.t)%type.
+Definition zero : t := (0, 0).
+Definition eq (p q : t) := (p#1 + q#2 == q#1 + p#2).
+Definition succ (n : t) : t := (N.succ n#1, n#2).
+Definition pred (n : t) : t := (n#1, N.succ n#2).
+Definition opp (n : t) : t := (n#2, n#1).
+Definition add (n m : t) : t := (n#1 + m#1, n#2 + m#2).
+Definition sub (n m : t) : t := (n#1 + m#2, n#2 + m#1).
+Definition mul (n m : t) : t :=
+  (n#1 * m#1 + n#2 * m#2, n#1 * m#2 + n#2 * m#1).
+Definition lt (n m : t) := n#1 + m#2 < m#1 + n#2.
+Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2.
+Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2).
+Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2).
+
+(** NB : We do not have [Zpred (Zsucc n) = n] but only [Zpred (Zsucc n) == n].
+    It could be possible to consider as canonical only pairs where
+    one of the elements is 0, and make all operations convert
+    canonical values into other canonical values. In that case, we
+    could get rid of setoids and arrive at integers as signed natural
+    numbers. *)
+
+(** NB : Unfortunately, the elements of the pair keep increasing during
+    many operations, even during subtraction. *)
+
+End Z.
+
+Delimit Scope ZScope with Z.
+Bind Scope ZScope with Z.t.
+Infix "=="  := Z.eq (at level 70) : ZScope.
+Notation "x ~= y" := (~ Z.eq x y) (at level 70) : ZScope.
+Notation "0" := Z.zero : ZScope.
+Notation "1" := (Z.succ Z.zero) : ZScope.
+Infix "+" := Z.add : ZScope.
+Infix "-" := Z.sub : ZScope.
+Infix "*" := Z.mul : ZScope.
+Notation "- x" := (Z.opp x) : ZScope.
+Infix "<" := Z.lt : ZScope.
+Infix "<=" := Z.le : ZScope.
+Local Open Scope ZScope.
+
+Lemma sub_add_opp : forall n m, Z.sub n m = Z.add n (Z.opp m).
+Proof. reflexivity. Qed.
+
+Instance eq_equiv : Equivalence Z.eq.
+Proof.
+split.
+unfold Reflexive, Z.eq. reflexivity.
+unfold Symmetric, Z.eq; now symmetry.
+unfold Transitive, Z.eq. intros (n1,n2) (m1,m2) (p1,p2) H1 H2; simpl in *.
+apply (add_cancel_r _ _ (m1+m2)%N).
+rewrite add_shuffle2, H1, add_shuffle1, H2.
+now rewrite add_shuffle1, (add_comm m1).
+Qed.
+
+Instance pair_wd : Proper (N.eq==>N.eq==>Z.eq) (@pair N.t N.t).
+Proof.
+intros n1 n2 H1 m1 m2 H2; unfold Z.eq; simpl; now rewrite H1, H2.
+Qed.
+
+Instance succ_wd : Proper (Z.eq ==> Z.eq) Z.succ.
+Proof.
+unfold Z.succ, Z.eq; intros n m H; simpl.
+do 2 rewrite add_succ_l; now rewrite H.
 Qed.
 
-Theorem NZeq_equiv : equiv Z Zeq.
+Instance pred_wd : Proper (Z.eq ==> Z.eq) Z.pred.
 Proof.
-unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_sym].
-Qed.
-
-Add Relation Z Zeq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
-as NZeq_rel.
-
-Add Morphism (@pair N N) with signature NE ==> NE ==> Zeq as Zpair_wd.
-Proof.
-intros n1 n2 H1 m1 m2 H2; unfold Zeq; simpl; rewrite H1; now rewrite H2.
+unfold Z.pred, Z.eq; intros n m H; simpl.
+do 2 rewrite add_succ_r; now rewrite H.
 Qed.
 
-Add Morphism NZsucc with signature Zeq ==> Zeq as NZsucc_wd.
+Instance add_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.add.
 Proof.
-unfold NZsucc, Zeq; intros n m H; simpl.
-do 2 rewrite add_succ_l; now rewrite H.
+unfold Z.eq, Z.add; intros n1 m1 H1 n2 m2 H2; simpl.
+now rewrite add_shuffle1, H1, H2, add_shuffle1.
 Qed.
 
-Add Morphism NZpred with signature Zeq ==> Zeq as NZpred_wd.
+Instance opp_wd : Proper (Z.eq ==> Z.eq) Z.opp.
 Proof.
-unfold NZpred, Zeq; intros n m H; simpl.
-do 2 rewrite add_succ_r; now rewrite H.
+unfold Z.eq, Z.opp; intros (n1,n2) (m1,m2) H; simpl in *.
+now rewrite (add_comm n2), (add_comm m2).
 Qed.
 
-Add Morphism NZadd with signature Zeq ==> Zeq ==> Zeq as NZadd_wd.
+Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub.
 Proof.
-unfold Zeq, NZadd; intros n1 m1 H1 n2 m2 H2; simpl.
-assert (H3 : (fst n1 + snd m1) + (fst n2 + snd m2) == (fst m1 + snd n1) + (fst m2 + snd n2))
-by now apply add_wd.
-stepl (fst n1 + snd m1 + (fst n2 + snd m2)) by ring.
-now stepr (fst m1 + snd n1 + (fst m2 + snd n2)) by ring.
+intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp.
+apply add_wd, opp_wd; auto.
 Qed.
 
-Add Morphism NZsub with signature Zeq ==> Zeq ==> Zeq as NZsub_wd.
+Lemma mul_comm : forall n m, n*m == m*n.
 Proof.
-unfold Zeq, NZsub; intros n1 m1 H1 n2 m2 H2; simpl.
-symmetry in H2.
-assert (H3 : (fst n1 + snd m1) + (fst m2 + snd n2) == (fst m1 + snd n1) + (fst n2 + snd m2))
-by now apply add_wd.
-stepl (fst n1 + snd m1 + (fst m2 + snd n2)) by ring.
-now stepr (fst m1 + snd n1 + (fst n2 + snd m2)) by ring.
+intros (n1,n2) (m1,m2); compute.
+rewrite (add_comm (m1*n2)%N).
+apply N.add_wd; apply N.add_wd; apply mul_comm.
 Qed.
 
-Add Morphism NZmul with signature Zeq ==> Zeq ==> Zeq as NZmul_wd.
+Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul.
 Proof.
-unfold NZmul, Zeq; intros n1 m1 H1 n2 m2 H2; simpl.
-stepl (fst n1 * fst n2 + (snd n1 * snd n2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring.
-stepr (fst n1 * snd n2 + (fst m1 * fst m2 + snd m1 * snd m2 + snd n1 * fst n2)) by ring.
-apply add_mul_repl_pair with (n := fst m2) (m := snd m2); [| now idtac].
-stepl (snd n1 * snd n2 + (fst n1 * fst m2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring.
-stepr (snd n1 * fst n2 + (fst n1 * snd m2 + fst m1 * fst m2 + snd m1 * snd m2)) by ring.
-apply add_mul_repl_pair with (n := snd m2) (m := fst m2);
-[| (stepl (fst n2 + snd m2) by ring); now stepr (fst m2 + snd n2) by ring].
-stepl (snd m2 * snd n1 + (fst n1 * fst m2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring.
-stepr (snd m2 * fst n1 + (snd n1 * fst m2 + fst m1 * fst m2 + snd m1 * snd m2)) by ring.
-apply add_mul_repl_pair with (n := snd m1) (m := fst m1);
-[ | (stepl (fst n1 + snd m1) by ring); now stepr (fst m1 + snd n1) by ring].
-stepl (fst m2 * fst n1 + (snd m2 * snd m1 + fst m1 * snd m2 + snd m1 * fst m2)) by ring.
-stepr (fst m2 * snd n1 + (snd m2 * fst m1 + fst m1 * fst m2 + snd m1 * snd m2)) by ring.
-apply add_mul_repl_pair with (n := fst m1) (m := snd m1); [| now idtac].
-ring.
+assert (forall n, Proper (Z.eq ==> Z.eq) (Z.mul n)).
+ unfold Z.mul, Z.eq. intros (n1,n2) (p1,p2) (q1,q2) H; simpl in *.
+ rewrite add_shuffle1, (add_comm (n1*p1)%N).
+ symmetry. rewrite add_shuffle1.
+ rewrite <- ! mul_add_distr_l.
+ rewrite (add_comm p2), (add_comm q2), H.
+ reflexivity.
+intros n n' Hn m m' Hm.
+rewrite Hm, (mul_comm n), (mul_comm n'), Hn.
+reflexivity.
 Qed.
 
 Section Induction.
-Open Scope NatScope. (* automatically closes at the end of the section *)
-Variable A : Z -> Prop.
-Hypothesis A_wd : predicate_wd Zeq A.
+Variable A : Z.t -> Prop.
+Hypothesis A_wd : Proper (Z.eq==>iff) A.
 
-Add Morphism A with signature Zeq ==> iff as A_morph.
+Theorem bi_induction :
+  A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n.
 Proof.
-exact A_wd.
-Qed.
-
-Theorem NZinduction :
-  A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n. (* 0 is interpreted as in Z due to "Bind" directive *)
-Proof.
-intros A0 AS n; unfold NZ0, Zsucc, predicate_wd, fun_wd, Zeq in *.
+intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *.
 destruct n as [n m].
-cut (forall p : N, A (p, 0)); [intro H1 |].
-cut (forall p : N, A (0, p)); [intro H2 |].
+cut (forall p, A (p, 0%N)); [intro H1 |].
+cut (forall p, A (0%N, p)); [intro H2 |].
 destruct (add_dichotomy n m) as [[p H] | [p H]].
-rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm).
+rewrite (A_wd (n, m) (0%N, p)) by (rewrite add_0_l; now rewrite add_comm).
 apply H2.
-rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1.
+rewrite (A_wd (n, m) (p, 0%N)) by now rewrite add_0_r. apply H1.
 induct p. assumption. intros p IH.
-apply -> (A_wd (0, p) (1, S p)) in IH; [| now rewrite add_0_l, add_1_l].
+apply -> (A_wd (0%N, p) (1%N, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l].
 now apply <- AS.
 induct p. assumption. intros p IH.
-replace 0 with (snd (p, 0)); [| reflexivity].
-replace (S p) with (S (fst (p, 0))); [| reflexivity]. now apply -> AS.
+replace 0%N with (snd (p, 0%N)); [| reflexivity].
+replace (N.succ p) with (N.succ (fst (p, 0%N))); [| reflexivity]. now apply -> AS.
 Qed.
 
 End Induction.
 
 (* Time to prove theorems in the language of Z *)
 
-Open Local Scope IntScope.
-
-Theorem NZpred_succ : forall n : Z, Zpred (Zsucc n) == n.
+Theorem pred_succ : forall n, Z.pred (Z.succ n) == n.
 Proof.
-unfold NZpred, NZsucc, Zeq; intro n; simpl.
-rewrite add_succ_l; now rewrite add_succ_r.
+unfold Z.pred, Z.succ, Z.eq; intro n; simpl; now nzsimpl.
 Qed.
 
-Theorem NZadd_0_l : forall n : Z, 0 + n == n.
+Theorem succ_pred : forall n, Z.succ (Z.pred n) == n.
 Proof.
-intro n; unfold NZadd, Zeq; simpl. now do 2 rewrite add_0_l.
+intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl.
 Qed.
 
-Theorem NZadd_succ_l : forall n m : Z, (Zsucc n) + m == Zsucc (n + m).
+Theorem opp_0 : - 0 == 0.
 Proof.
-intros n m; unfold NZadd, Zeq; simpl. now do 2 rewrite add_succ_l.
+unfold Z.opp, Z.eq; simpl. now nzsimpl.
 Qed.
 
-Theorem NZsub_0_r : forall n : Z, n - 0 == n.
+Theorem opp_succ : forall n, - (Z.succ n) == Z.pred (- n).
 Proof.
-intro n; unfold NZsub, Zeq; simpl. now do 2 rewrite add_0_r.
-Qed.
-
-Theorem NZsub_succ_r : forall n m : Z, n - (Zsucc m) == Zpred (n - m).
-Proof.
-intros n m; unfold NZsub, Zeq; simpl. symmetry; now rewrite add_succ_r.
+reflexivity.
 Qed.
 
-Theorem NZmul_0_l : forall n : Z, 0 * n == 0.
+Theorem add_0_l : forall n, 0 + n == n.
 Proof.
-intro n; unfold NZmul, Zeq; simpl.
-repeat rewrite mul_0_l. now rewrite add_assoc.
+intro n; unfold Z.add, Z.eq; simpl. now nzsimpl.
 Qed.
 
-Theorem NZmul_succ_l : forall n m : Z, (Zsucc n) * m == n * m + m.
+Theorem add_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m).
 Proof.
-intros n m; unfold NZmul, NZsucc, Zeq; simpl.
-do 2 rewrite mul_succ_l. ring.
+intros n m; unfold Z.add, Z.eq; simpl. now nzsimpl.
 Qed.
 
-End NZAxiomsMod.
-
-Definition NZlt := Zlt.
-Definition NZle := Zle.
-Definition NZmin := Zmin.
-Definition NZmax := Zmax.
-
-Add Morphism NZlt with signature Zeq ==> Zeq ==> iff as NZlt_wd.
+Theorem sub_0_r : forall n, n - 0 == n.
 Proof.
-unfold NZlt, Zlt, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. split; intro H.
-stepr (snd m1 + fst m2) by apply add_comm.
-apply (add_lt_repl_pair (fst n1) (snd n1)); [| assumption].
-stepl (snd m2 + fst n1) by apply add_comm.
-stepr (fst m2 + snd n1) by apply add_comm.
-apply (add_lt_repl_pair (snd n2) (fst n2)).
-now stepl (fst n1 + snd n2) by apply add_comm.
-stepl (fst m2 + snd n2) by apply add_comm. now stepr (fst n2 + snd m2) by apply add_comm.
-stepr (snd n1 + fst n2) by apply add_comm.
-apply (add_lt_repl_pair (fst m1) (snd m1)); [| now symmetry].
-stepl (snd n2 + fst m1) by apply add_comm.
-stepr (fst n2 + snd m1) by apply add_comm.
-apply (add_lt_repl_pair (snd m2) (fst m2)).
-now stepl (fst m1 + snd m2) by apply add_comm.
-stepl (fst n2 + snd m2) by apply add_comm. now stepr (fst m2 + snd n2) by apply add_comm.
+intro n; unfold Z.sub, Z.eq; simpl. now nzsimpl.
 Qed.
 
-Add Morphism NZle with signature Zeq ==> Zeq ==> iff as NZle_wd.
+Theorem sub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m).
 Proof.
-unfold NZle, Zle, Zeq; intros n1 m1 H1 n2 m2 H2; simpl.
-do 2 rewrite lt_eq_cases. rewrite (NZlt_wd n1 m1 H1 n2 m2 H2). fold (m1 < m2)%Int.
-fold (n1 == n2)%Int (m1 == m2)%Int; fold (n1 == m1)%Int in H1; fold (n2 == m2)%Int in H2.
-now rewrite H1, H2.
+intros n m; unfold Z.sub, Z.eq; simpl. symmetry; now rewrite add_succ_r.
 Qed.
 
-Add Morphism NZmin with signature Zeq ==> Zeq ==> Zeq as NZmin_wd.
+Theorem mul_0_l : forall n, 0 * n == 0.
 Proof.
-intros n1 m1 H1 n2 m2 H2; unfold NZmin, Zeq; simpl.
-destruct (le_ge_cases (fst n1 + snd n2) (fst n2 + snd n1)) as [H | H].
-rewrite (min_l (fst n1 + snd n2) (fst n2 + snd n1)) by assumption.
-rewrite (min_l (fst m1 + snd m2) (fst m2 + snd m1)) by
-now apply -> (NZle_wd n1 m1 H1 n2 m2 H2).
-stepl ((fst n1 + snd m1) + (snd n2 + snd m2)) by ring.
-unfold Zeq in H1. rewrite H1. ring.
-rewrite (min_r (fst n1 + snd n2) (fst n2 + snd n1)) by assumption.
-rewrite (min_r (fst m1 + snd m2) (fst m2 + snd m1)) by
-now apply -> (NZle_wd n2 m2 H2 n1 m1 H1).
-stepl ((fst n2 + snd m2) + (snd n1 + snd m1)) by ring.
-unfold Zeq in H2. rewrite H2. ring.
+intros (n1,n2); unfold Z.mul, Z.eq; simpl; now nzsimpl.
 Qed.
 
-Add Morphism NZmax with signature Zeq ==> Zeq ==> Zeq as NZmax_wd.
+Theorem mul_succ_l : forall n m, (Z.succ n) * m == n * m + m.
 Proof.
-intros n1 m1 H1 n2 m2 H2; unfold NZmax, Zeq; simpl.
-destruct (le_ge_cases (fst n1 + snd n2) (fst n2 + snd n1)) as [H | H].
-rewrite (max_r (fst n1 + snd n2) (fst n2 + snd n1)) by assumption.
-rewrite (max_r (fst m1 + snd m2) (fst m2 + snd m1)) by
-now apply -> (NZle_wd n1 m1 H1 n2 m2 H2).
-stepl ((fst n2 + snd m2) + (snd n1 + snd m1)) by ring.
-unfold Zeq in H2. rewrite H2. ring.
-rewrite (max_l (fst n1 + snd n2) (fst n2 + snd n1)) by assumption.
-rewrite (max_l (fst m1 + snd m2) (fst m2 + snd m1)) by
-now apply -> (NZle_wd n2 m2 H2 n1 m1 H1).
-stepl ((fst n1 + snd m1) + (snd n2 + snd m2)) by ring.
-unfold Zeq in H1. rewrite H1. ring.
+intros (n1,n2) (m1,m2); unfold Z.mul, Z.succ, Z.eq; simpl; nzsimpl.
+rewrite <- (add_assoc _ m1), (add_comm m1), (add_assoc _ _ m1).
+now rewrite <- (add_assoc _ m2), (add_comm m2), (add_assoc _ (n2*m1)%N m2).
 Qed.
 
-Open Local Scope IntScope.
+(** Order *)
 
-Theorem NZlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n == m.
+Lemma lt_eq_cases : forall n m, n<=m <-> n<m \/ n==m.
 Proof.
-intros n m; unfold Zlt, Zle, Zeq; simpl. apply lt_eq_cases.
+intros; apply N.lt_eq_cases.
 Qed.
 
-Theorem NZlt_irrefl : forall n : Z, ~ (n < n).
+Theorem lt_irrefl : forall n, ~ (n < n).
 Proof.
-intros n; unfold Zlt, Zeq; simpl. apply lt_irrefl.
+intros; apply N.lt_irrefl.
 Qed.
 
-Theorem NZlt_succ_r : forall n m : Z, n < (Zsucc m) <-> n <= m.
+Theorem lt_succ_r : forall n m, n < (Z.succ m) <-> n <= m.
 Proof.
-intros n m; unfold Zlt, Zle, Zeq; simpl. rewrite add_succ_l; apply lt_succ_r.
+intros n m; unfold Z.lt, Z.le, Z.eq; simpl; nzsimpl. apply lt_succ_r.
 Qed.
 
-Theorem NZmin_l : forall n m : Z, n <= m -> Zmin n m == n.
+Theorem min_l : forall n m, n <= m -> Z.min n m == n.
 Proof.
-unfold Zmin, Zle, Zeq; simpl; intros n m H.
-rewrite min_l by assumption. ring.
+unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *.
+rewrite min_l by assumption.
+now rewrite <- add_assoc, (add_comm m2).
 Qed.
 
-Theorem NZmin_r : forall n m : Z, m <= n -> Zmin n m == m.
+Theorem min_r : forall n m, m <= n -> Z.min n m == m.
 Proof.
-unfold Zmin, Zle, Zeq; simpl; intros n m H.
-rewrite min_r by assumption. ring.
+unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *.
+rewrite min_r by assumption.
+now rewrite add_assoc.
 Qed.
 
-Theorem NZmax_l : forall n m : Z, m <= n -> Zmax n m == n.
+Theorem max_l : forall n m, m <= n -> Z.max n m == n.
 Proof.
-unfold Zmax, Zle, Zeq; simpl; intros n m H.
-rewrite max_l by assumption. ring.
+unfold Z.max, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *.
+rewrite max_l by assumption.
+now rewrite <- add_assoc, (add_comm m2).
 Qed.
 
-Theorem NZmax_r : forall n m : Z, n <= m -> Zmax n m == m.
+Theorem max_r : forall n m, n <= m -> Z.max n m == m.
 Proof.
-unfold Zmax, Zle, Zeq; simpl; intros n m H.
-rewrite max_r by assumption. ring.
+unfold Z.max, Z.le, Z.eq; simpl; intros n m H.
+rewrite max_r by assumption.
+now rewrite add_assoc.
 Qed.
 
-End NZOrdAxiomsMod.
-
-Definition Zopp (n : Z) : Z := (snd n, fst n).
-
-Notation "- x" := (Zopp x) : IntScope.
-
-Add Morphism Zopp with signature Zeq ==> Zeq as Zopp_wd.
-Proof.
-unfold Zeq; intros n m H; simpl. symmetry.
-stepl (fst n + snd m) by apply add_comm.
-now stepr (fst m + snd n) by apply add_comm.
-Qed.
-
-Open Local Scope IntScope.
-
-Theorem Zsucc_pred : forall n : Z, Zsucc (Zpred n) == n.
+Theorem lt_nge : forall n m, n < m <-> ~(m<=n).
 Proof.
-intro n; unfold Zsucc, Zpred, Zeq; simpl.
-rewrite add_succ_l; now rewrite add_succ_r.
+intros. apply lt_nge.
 Qed.
 
-Theorem Zopp_0 : - 0 == 0.
+Instance lt_wd : Proper (Z.eq ==> Z.eq ==> iff) Z.lt.
 Proof.
-unfold Zopp, Zeq; simpl. now rewrite add_0_l.
+assert (forall n, Proper (Z.eq==>iff) (Z.lt n)).
+ intros (n1,n2). apply proper_sym_impl_iff; auto with *.
+ unfold Z.lt, Z.eq; intros (r1,r2) (s1,s2) Eq H; simpl in *.
+ apply le_lt_add_lt with (r1+r2)%N (r1+r2)%N; [apply le_refl; auto with *|].
+ rewrite add_shuffle2, (add_comm s2), Eq.
+ rewrite (add_comm s1 n2), (add_shuffle1 n2), (add_comm n2 r1).
+ now rewrite <- add_lt_mono_r.
+intros n n' Hn m m' Hm.
+rewrite Hm. rewrite 2 lt_nge, 2 lt_eq_cases, Hn; auto with *.
 Qed.
 
-Theorem Zopp_succ : forall n, - (Zsucc n) == Zpred (- n).
-Proof.
-reflexivity.
-Qed.
+Definition t := Z.t.
+Definition eq := Z.eq.
+Definition zero := Z.zero.
+Definition succ := Z.succ.
+Definition pred := Z.pred.
+Definition add := Z.add.
+Definition sub := Z.sub.
+Definition mul := Z.mul.
+Definition opp := Z.opp.
+Definition lt := Z.lt.
+Definition le := Z.le.
+Definition min := Z.min.
+Definition max := Z.max.
 
 End ZPairsAxiomsMod.
 
@@ -413,9 +319,7 @@ and get their properties *)
 Require Import NPeano.
 
 Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod NPeanoAxiomsMod.
-Module Export ZPairsMulOrderPropMod := ZMulOrderPropFunct ZPairsPeanoAxiomsMod.
-
-Open Local Scope IntScope.
+Module Export ZPairsPropMod := ZPropFunct ZPairsPeanoAxiomsMod.
 
 Eval compute in (3, 5) * (4, 6).
 *)
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v
index 0af98c74..ffa91706 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSig.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: ZSig.v 11027 2008-06-01 13:28:59Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith Znumtheory.
 
@@ -25,93 +25,77 @@ Module Type ZType.
  Parameter t : Type.
 
  Parameter to_Z : t -> Z.
- Notation "[ x ]" := (to_Z x).
+ Local Notation "[ x ]" := (to_Z x).
 
- Definition eq x y := ([x] = [y]).
+ Definition eq x y := [x] = [y].
+ Definition lt x y := [x] < [y].
+ Definition le x y := [x] <= [y].
 
  Parameter of_Z : Z -> t.
  Parameter spec_of_Z: forall x, to_Z (of_Z x) = x.
 
+ Parameter compare : t -> t -> comparison.
+ Parameter eq_bool : t -> t -> bool.
+ Parameter min : t -> t -> t.
+ Parameter max : t -> t -> t.
  Parameter zero : t.
  Parameter one : t.
  Parameter minus_one : t.
-
- Parameter spec_0: [zero] = 0.
- Parameter spec_1: [one] = 1.
- Parameter spec_m1: [minus_one] = -1.
-
- Parameter compare : t -> t -> comparison.
-
- Parameter spec_compare: forall x y,
-   match compare x y with
-     | Eq => [x] = [y]
-     | Lt => [x] < [y]
-     | Gt => [x] > [y]
-   end.
-
- Definition lt n m := compare n m = Lt.
- Definition le n m := compare n m <> Gt.
- Definition min n m := match compare n m with Gt => m | _ => n end.
- Definition max n m := match compare n m with Lt => m | _ => n end.
-
- Parameter eq_bool : t -> t -> bool.
-
- Parameter spec_eq_bool: forall x y,
-    if eq_bool x y then [x] = [y] else [x] <> [y].
- 
  Parameter succ : t -> t.
-
- Parameter spec_succ: forall n, [succ n] = [n] + 1.
-
  Parameter add  : t -> t -> t.
-
- Parameter spec_add: forall x y, [add x y] = [x] + [y].
-
  Parameter pred : t -> t.
-
- Parameter spec_pred: forall x, [pred x] = [x] - 1.
-
  Parameter sub : t -> t -> t.
-
- Parameter spec_sub: forall x y, [sub x y] = [x] - [y].
-
  Parameter opp : t -> t.
-
- Parameter spec_opp: forall x, [opp x] = - [x].
-
  Parameter mul : t -> t -> t.
-
- Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
-
  Parameter square : t -> t.
-
- Parameter spec_square: forall x, [square x] = [x] *  [x].
-
  Parameter power_pos : t -> positive -> t.
-
- Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
-
+ Parameter power : t -> N -> t.
  Parameter sqrt : t -> t.
-
- Parameter spec_sqrt: forall x, 0 <= [x] -> 
-   [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.
-
  Parameter div_eucl : t -> t -> t * t.
-
- Parameter spec_div_eucl: forall x y, [y] <> 0 ->
-   let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
- 
  Parameter div : t -> t -> t.
-
- Parameter spec_div: forall x y, [y] <> 0 -> [div x y] = [x] / [y].
-
  Parameter modulo : t -> t -> t.
-
- Parameter spec_modulo: forall x y, [y] <> 0 -> 
-   [modulo x y] = [x] mod [y].
-
  Parameter gcd : t -> t -> t.
+ Parameter sgn : t -> t.
+ Parameter abs : t -> t.
 
+ Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y].
+ Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y].
+ Parameter spec_min : forall x y, [min x y] = Zmin [x] [y].
+ Parameter spec_max : forall x y, [max x y] = Zmax [x] [y].
+ Parameter spec_0: [zero] = 0.
+ Parameter spec_1: [one] = 1.
+ Parameter spec_m1: [minus_one] = -1.
+ Parameter spec_succ: forall n, [succ n] = [n] + 1.
+ Parameter spec_add: forall x y, [add x y] = [x] + [y].
+ Parameter spec_pred: forall x, [pred x] = [x] - 1.
+ Parameter spec_sub: forall x y, [sub x y] = [x] - [y].
+ Parameter spec_opp: forall x, [opp x] = - [x].
+ Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
+ Parameter spec_square: forall x, [square x] = [x] *  [x].
+ Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
+ Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n.
+ Parameter spec_sqrt: forall x, 0 <= [x] ->
+   [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.
+ Parameter spec_div_eucl: forall x y,
+   let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
+ Parameter spec_div: forall x y, [div x y] = [x] / [y].
+ Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
  Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b).
+ Parameter spec_sgn : forall x, [sgn x] = Zsgn [x].
+ Parameter spec_abs : forall x, [abs x] = Zabs [x].
 
 End ZType.
+
+Module Type ZType_Notation (Import Z:ZType).
+ Notation "[ x ]" := (to_Z x).
+ Infix "=="  := eq (at level 70).
+ Notation "0" := zero.
+ Infix "+" := add.
+ Infix "-" := sub.
+ Infix "*" := mul.
+ Notation "- x" := (opp x).
+ Infix "<=" := le.
+ Infix "<" := lt.
+End ZType_Notation.
+
+Module Type ZType' := ZType <+ ZType_Notation.
\ No newline at end of file
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
index aceb8984..bcecb6a8 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
@@ -6,119 +6,74 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZSigZAxioms.v 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
-Require Import ZArith.
-Require Import ZAxioms.
-Require Import ZSig.
+Require Import ZArith ZAxioms ZDivFloor ZSig.
 
-(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *)
+(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig]
 
-Module ZSig_ZAxioms (Z:ZType) <: ZAxiomsSig.
+    It also provides [sgn], [abs], [div], [mod]
+*)
 
-Delimit Scope IntScope with Int.
-Bind Scope IntScope with Z.t.
-Open Local Scope IntScope.
-Notation "[ x ]" := (Z.to_Z x) : IntScope.
-Infix "=="  := Z.eq (at level 70) : IntScope.
-Notation "0" := Z.zero : IntScope.
-Infix "+" := Z.add : IntScope.
-Infix "-" := Z.sub : IntScope.
-Infix "*" := Z.mul : IntScope.
-Notation "- x" := (Z.opp x) : IntScope.
 
-Hint Rewrite 
- Z.spec_0 Z.spec_1 Z.spec_add Z.spec_sub Z.spec_pred Z.spec_succ
- Z.spec_mul Z.spec_opp Z.spec_of_Z : Zspec.
+Module ZTypeIsZAxioms (Import Z : ZType').
 
-Ltac zsimpl := unfold Z.eq in *; autorewrite with Zspec.
+Hint Rewrite
+ spec_0 spec_1 spec_add spec_sub spec_pred spec_succ
+ spec_mul spec_opp spec_of_Z spec_div spec_modulo
+ spec_compare spec_eq_bool spec_max spec_min spec_abs spec_sgn
+ : zsimpl.
 
-Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig.
-Module Export NZAxiomsMod <: NZAxiomsSig.
+Ltac zsimpl := autorewrite with zsimpl.
+Ltac zcongruence := repeat red; intros; zsimpl; congruence.
+Ltac zify := unfold eq, lt, le in *; zsimpl.
 
-Definition NZ := Z.t.
-Definition NZeq := Z.eq.
-Definition NZ0 := Z.zero.
-Definition NZsucc := Z.succ.
-Definition NZpred := Z.pred.
-Definition NZadd := Z.add.
-Definition NZsub := Z.sub.
-Definition NZmul := Z.mul.
+Instance eq_equiv : Equivalence eq.
+Proof. unfold eq. firstorder. Qed.
 
-Theorem NZeq_equiv : equiv Z.t Z.eq.
-Proof.
-repeat split; repeat red; intros; auto; congruence.
-Qed.
-
-Add Relation Z.t Z.eq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
- as NZeq_rel.
-
-Add Morphism NZsucc with signature Z.eq ==> Z.eq as NZsucc_wd.
-Proof.
-intros; zsimpl; f_equal; assumption.
-Qed.
-
-Add Morphism NZpred with signature Z.eq ==> Z.eq as NZpred_wd.
-Proof.
-intros; zsimpl; f_equal; assumption.
-Qed.
+Local Obligation Tactic := zcongruence.
 
-Add Morphism NZadd with signature Z.eq ==> Z.eq ==> Z.eq as NZadd_wd.
-Proof.
-intros; zsimpl; f_equal; assumption.
-Qed.
-
-Add Morphism NZsub with signature Z.eq ==> Z.eq ==> Z.eq as NZsub_wd.
-Proof.
-intros; zsimpl; f_equal; assumption.
-Qed.
+Program Instance succ_wd : Proper (eq ==> eq) succ.
+Program Instance pred_wd : Proper (eq ==> eq) pred.
+Program Instance add_wd : Proper (eq ==> eq ==> eq) add.
+Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
+Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
 
-Add Morphism NZmul with signature Z.eq ==> Z.eq ==> Z.eq as NZmul_wd.
+Theorem pred_succ : forall n, pred (succ n) == n.
 Proof.
-intros; zsimpl; f_equal; assumption.
-Qed.
-
-Theorem NZpred_succ : forall n, Z.pred (Z.succ n) == n.
-Proof.
-intros; zsimpl; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
 Section Induction.
 
 Variable A : Z.t -> Prop.
-Hypothesis A_wd : predicate_wd Z.eq A.
+Hypothesis A_wd : Proper (eq==>iff) A.
 Hypothesis A0 : A 0.
-Hypothesis AS : forall n, A n <-> A (Z.succ n). 
-
-Add Morphism A with signature Z.eq ==> iff as A_morph.
-Proof. apply A_wd. Qed.
+Hypothesis AS : forall n, A n <-> A (succ n).
 
-Let B (z : Z) := A (Z.of_Z z).
+Let B (z : Z) := A (of_Z z).
 
 Lemma B0 : B 0.
 Proof.
 unfold B; simpl.
 rewrite <- (A_wd 0); auto.
-zsimpl; auto.
+zify. auto.
 Qed.
 
 Lemma BS : forall z : Z, B z -> B (z + 1).
 Proof.
 intros z H.
 unfold B in *. apply -> AS in H.
-setoid_replace (Z.of_Z (z + 1)) with (Z.succ (Z.of_Z z)); auto.
-zsimpl; auto.
+setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto.
+zify. auto.
 Qed.
 
 Lemma BP : forall z : Z, B z -> B (z - 1).
 Proof.
 intros z H.
 unfold B in *. rewrite AS.
-setoid_replace (Z.succ (Z.of_Z (z - 1))) with (Z.of_Z z); auto.
-zsimpl; auto with zarith.
+setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto.
+zify. auto with zarith.
 Qed.
 
 Lemma B_holds : forall z : Z, B z.
@@ -135,172 +90,170 @@ intros; rewrite Zopp_succ; unfold Zpred; apply BP; auto.
 subst z'; auto with zarith.
 Qed.
 
-Theorem NZinduction : forall n, A n.
+Theorem bi_induction : forall n, A n.
 Proof.
-intro n. setoid_replace n with (Z.of_Z (Z.to_Z n)).
+intro n. setoid_replace n with (of_Z (to_Z n)).
 apply B_holds.
-zsimpl; auto.
+zify. auto.
 Qed.
 
 End Induction.
 
-Theorem NZadd_0_l : forall n, 0 + n == n.
+Theorem add_0_l : forall n, 0 + n == n.
 Proof.
-intros; zsimpl; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZadd_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m).
+Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m).
 Proof.
-intros; zsimpl; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZsub_0_r : forall n, n - 0 == n.
+Theorem sub_0_r : forall n, n - 0 == n.
 Proof.
-intros; zsimpl; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZsub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m).
+Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
 Proof.
-intros; zsimpl; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZmul_0_l : forall n, 0 * n == 0.
+Theorem mul_0_l : forall n, 0 * n == 0.
 Proof.
-intros; zsimpl; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZmul_succ_l : forall n m, (Z.succ n) * m == n * m + m.
+Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m.
 Proof.
-intros; zsimpl; ring.
+intros. zify. ring.
 Qed.
 
-End NZAxiomsMod.
+(** Order *)
 
-Definition NZlt := Z.lt.
-Definition NZle := Z.le.
-Definition NZmin := Z.min.
-Definition NZmax := Z.max.
+Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+Proof.
+ intros. zify. destruct (Zcompare_spec [x] [y]); auto.
+Qed.
 
-Infix "<=" := Z.le : IntScope.
-Infix "<" := Z.lt : IntScope.
+Definition eqb := eq_bool.
 
-Lemma spec_compare_alt : forall x y, Z.compare x y = ([x] ?= [y])%Z.
+Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
 Proof.
- intros; generalize (Z.spec_compare x y).
- destruct (Z.compare x y); auto.
- intros H; rewrite H; symmetry; apply Zcompare_refl.
+ intros. zify. symmetry. apply Zeq_is_eq_bool.
 Qed.
 
-Lemma spec_lt : forall x y, (x<y) <-> ([x]<[y])%Z.
+Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
 Proof.
- intros; unfold Z.lt, Zlt; rewrite spec_compare_alt; intuition.
+intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition.
 Qed.
 
-Lemma spec_le : forall x y, (x<=y) <-> ([x]<=[y])%Z.
+Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
 Proof.
- intros; unfold Z.le, Zle; rewrite spec_compare_alt; intuition.
+intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
 Qed.
 
-Lemma spec_min : forall x y, [Z.min x y] = Zmin [x] [y].
+Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
 Proof.
- intros; unfold Z.min, Zmin.
- rewrite spec_compare_alt; destruct Zcompare; auto.
+intros. zify. omega.
 Qed.
 
-Lemma spec_max : forall x y, [Z.max x y] = Zmax [x] [y].
+Theorem lt_irrefl : forall n, ~ n < n.
 Proof.
- intros; unfold Z.max, Zmax.
- rewrite spec_compare_alt; destruct Zcompare; auto.
+intros. zify. omega.
 Qed.
 
-Add Morphism Z.compare with signature Z.eq ==> Z.eq ==> (@eq comparison) as compare_wd.
-Proof. 
-intros x x' Hx y y' Hy.
-rewrite 2 spec_compare_alt; unfold Z.eq in *; rewrite Hx, Hy; intuition.
+Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
+Proof.
+intros. zify. omega.
 Qed.
 
-Add Morphism Z.lt with signature Z.eq ==> Z.eq ==> iff as NZlt_wd.
+Theorem min_l : forall n m, n <= m -> min n m == n.
 Proof.
-intros x x' Hx y y' Hy; unfold Z.lt; rewrite Hx, Hy; intuition.
+intros n m. zify. omega with *.
 Qed.
 
-Add Morphism Z.le with signature Z.eq ==> Z.eq ==> iff as NZle_wd.
+Theorem min_r : forall n m, m <= n -> min n m == m.
 Proof.
-intros x x' Hx y y' Hy; unfold Z.le; rewrite Hx, Hy; intuition.
+intros n m. zify. omega with *.
 Qed.
 
-Add Morphism Z.min with signature Z.eq ==> Z.eq ==> Z.eq as NZmin_wd.
+Theorem max_l : forall n m, m <= n -> max n m == n.
 Proof.
-intros; red; rewrite 2 spec_min; congruence.
+intros n m. zify. omega with *.
 Qed.
 
-Add Morphism Z.max with signature Z.eq ==> Z.eq ==> Z.eq as NZmax_wd.
+Theorem max_r : forall n m, n <= m -> max n m == m.
 Proof.
-intros; red; rewrite 2 spec_max; congruence.
+intros n m. zify. omega with *.
 Qed.
 
-Theorem NZlt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
+(** Part specific to integers, not natural numbers *)
+
+Program Instance opp_wd : Proper (eq ==> eq) opp.
+
+Theorem succ_pred : forall n, succ (pred n) == n.
 Proof.
-intros.
-unfold Z.eq; rewrite spec_lt, spec_le; omega.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZlt_irrefl : forall n, ~ n < n.
+Theorem opp_0 : - 0 == 0.
 Proof.
-intros; rewrite spec_lt; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZlt_succ_r : forall n m, n < (Z.succ m) <-> n <= m.
+Theorem opp_succ : forall n, - (succ n) == pred (- n).
 Proof.
-intros; rewrite spec_lt, spec_le, Z.spec_succ; omega.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZmin_l : forall n m, n <= m -> Z.min n m == n.
+Theorem abs_eq : forall n, 0 <= n -> abs n == n.
 Proof.
-intros n m; unfold Z.eq; rewrite spec_le, spec_min.
-generalize (Zmin_spec [n] [m]); omega.
+intros n. zify. omega with *.
 Qed.
 
-Theorem NZmin_r : forall n m, m <= n -> Z.min n m == m.
+Theorem abs_neq : forall n, n <= 0 -> abs n == -n.
 Proof.
-intros n m; unfold Z.eq; rewrite spec_le, spec_min.
-generalize (Zmin_spec [n] [m]); omega.
+intros n. zify. omega with *.
 Qed.
 
-Theorem NZmax_l : forall n m, m <= n -> Z.max n m == n.
+Theorem sgn_null : forall n, n==0 -> sgn n == 0.
 Proof.
-intros n m; unfold Z.eq; rewrite spec_le, spec_max.
-generalize (Zmax_spec [n] [m]); omega.
+intros n. zify. omega with *.
 Qed.
 
-Theorem NZmax_r : forall n m, n <= m -> Z.max n m == m.
+Theorem sgn_pos : forall n, 0<n -> sgn n == succ 0.
 Proof.
-intros n m; unfold Z.eq; rewrite spec_le, spec_max.
-generalize (Zmax_spec [n] [m]); omega.
+intros n. zify. omega with *.
 Qed.
 
-End NZOrdAxiomsMod.
-
-Definition Zopp := Z.opp.
-
-Add Morphism Z.opp with signature Z.eq ==> Z.eq as Zopp_wd.
+Theorem sgn_neg : forall n, n<0 -> sgn n == opp (succ 0).
 Proof.
-intros; zsimpl; auto with zarith.
+intros n. zify. omega with *.
 Qed.
 
-Theorem Zsucc_pred : forall n, Z.succ (Z.pred n) == n.
+Program Instance div_wd : Proper (eq==>eq==>eq) div.
+Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
+
+Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
 Proof.
-red; intros; zsimpl; auto with zarith.
+intros a b. zify. intros. apply Z_div_mod_eq_full; auto.
 Qed.
 
-Theorem Zopp_0 : - 0 == 0.
+Theorem mod_pos_bound :
+ forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b.
 Proof.
-red; intros; zsimpl; auto with zarith.
+intros a b. zify. intros. apply Z_mod_lt; auto with zarith.
 Qed.
 
-Theorem Zopp_succ : forall n, - (Z.succ n) == Z.pred (- n).
+Theorem mod_neg_bound :
+ forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0.
 Proof.
-intros; zsimpl; auto with zarith.
+intros a b. zify. intros. apply Z_mod_neg; auto with zarith.
 Qed.
 
-End ZSig_ZAxioms.
+End ZTypeIsZAxioms.
+
+Module ZType_ZAxioms (Z : ZType)
+ <: ZAxiomsSig <: ZDivSig <: HasCompare Z <: HasEqBool Z <: HasMinMax Z
+ := Z <+ ZTypeIsZAxioms.
diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v
index 04a48d51..417463eb 100644
--- a/theories/Numbers/NaryFunctions.v
+++ b/theories/Numbers/NaryFunctions.v
@@ -8,27 +8,27 @@
 (*          Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008        *)
 (************************************************************************)
 
-(*i $Id: NaryFunctions.v 10967 2008-05-22 12:59:38Z letouzey $ i*)
+(*i $Id$ i*)
 
-Open Local Scope type_scope.
+Local Open Scope type_scope.
 
 Require Import List.
 
 (** * Generic dependently-typed operators about [n]-ary functions *)
 
-(** The type of [n]-ary function: [nfun A n B] is 
+(** The type of [n]-ary function: [nfun A n B] is
     [A -> ... -> A -> B] with [n] occurences of [A] in this type. *)
 
-Fixpoint nfun A n B := 
+Fixpoint nfun A n B :=
  match n with
-  | O => B 
+  | O => B
   | S n => A -> (nfun A n B)
- end. 
+ end.
 
 Notation " A ^^ n --> B " := (nfun A n B)
  (at level 50, n at next level) : type_scope.
 
-(** [napply_cst _ _ a n f] iterates [n] times the application of a 
+(** [napply_cst _ _ a n f] iterates [n] times the application of a
     particular constant [a] to the [n]-ary function [f]. *)
 
 Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B :=
@@ -40,47 +40,47 @@ Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B :=
 
 (** A generic transformation from an n-ary function to another one.*)
 
-Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : 
+Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n :
  (A^^n-->B) -> (A^^n-->C) :=
- match n return (A^^n-->B) -> (A^^n-->C) with 
+ match n return (A^^n-->B) -> (A^^n-->C) with
   | O => f
   | S n => fun g a => nfun_to_nfun _ _ _ f n (g a)
  end.
 
-(** [napply_except_last _ _ n f] expects [n] arguments of type [A], 
-    applies [n-1] of them to [f] and discard the last one. *) 
+(** [napply_except_last _ _ n f] expects [n] arguments of type [A],
+    applies [n-1] of them to [f] and discard the last one. *)
 
-Definition napply_except_last (A B:Type) := 
+Definition napply_except_last (A B:Type) :=
  nfun_to_nfun A B (A->B) (fun b a => b).
 
-(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], 
-    applies them to [f] and then apply [a] to the result. *) 
+(** [napply_then_last _ _ a n f] expects [n] arguments of type [A],
+    applies them to [f] and then apply [a] to the result. *)
 
-Definition napply_then_last (A B:Type)(a:A) := 
+Definition napply_then_last (A B:Type)(a:A) :=
  nfun_to_nfun A (A->B) B (fun fab => fab a).
 
-(** [napply_discard _ b n] expects [n] arguments, discards then, 
+(** [napply_discard _ b n] expects [n] arguments, discards then,
     and returns [b]. *)
 
 Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B :=
- match n return A^^n-->B with 
+ match n return A^^n-->B with
   | O => b
   | S n => fun _ => napply_discard _ _ b n
  end.
 
 (** A fold function *)
 
-Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := 
- match n return (A^^n-->B) with 
+Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) :=
+ match n return (A^^n-->B) with
   | O => b
   | S n => fun a => (nfold _ _ f (f a b) n)
  end.
 
 
-(** [n]-ary products : [nprod A n] is [A*...*A*unit], 
+(** [n]-ary products : [nprod A n] is [A*...*A*unit],
   with [n] occurrences of [A] in this type. *)
 
-Fixpoint nprod A n : Type := match n with 
+Fixpoint nprod A n : Type := match n with
  | O => unit
  | S n => (A * nprod A n)%type
 end.
@@ -89,54 +89,54 @@ Notation "A ^ n" := (nprod A n) : type_scope.
 
 (** [n]-ary curryfication / uncurryfication *)
 
-Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := 
-  match n return (A^n -> B) -> (A^^n-->B) with 
+Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) :=
+  match n return (A^n -> B) -> (A^^n-->B) with
   | O => fun x => x tt
   | S n => fun f a => ncurry _ _ n (fun p => f (a,p))
   end.
 
-Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := 
+Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) :=
  match n return (A^^n-->B) -> (A^n -> B) with
   | O => fun x _ => x
   | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p
  end.
 
-(** Earlier functions can also be defined via [ncurry/nuncurry]. 
+(** Earlier functions can also be defined via [ncurry/nuncurry].
     For instance : *)
 
 Definition nfun_to_nfun_bis A B C (f:B->C) n :
- (A^^n-->B) -> (A^^n-->C) := 
+ (A^^n-->B) -> (A^^n-->C) :=
  fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)).
 
-(** We can also us it to obtain another [fold] function, 
+(** We can also us it to obtain another [fold] function,
     equivalent to the previous one, but with a nicer expansion
     (see for instance Int31.iszero). *)
 
-Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := 
- match n return (A^^n-->B) with 
+Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) :=
+ match n return (A^^n-->B) with
   | O => b
-  | S n => fun a => 
+  | S n => fun a =>
       nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n)
  end.
 
 (** From [nprod] to [list] *)
 
-Fixpoint nprod_to_list (A:Type) n : A^n -> list A := 
- match n with 
+Fixpoint nprod_to_list (A:Type) n : A^n -> list A :=
+ match n with
   | O => fun _ => nil
   | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p)
  end.
 
 (** From [list] to [nprod] *)
 
-Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := 
- match l return A^(length l) with 
+Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) :=
+ match l return A^(length l) with
   | nil => tt
   | x::l => (x, nprod_of_list _ l)
  end.
 
 (** This gives an additional way to write the fold *)
 
-Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := 
+Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) :=
   ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)).
 
diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v
index c9bb5c95..9535cfdb 100644
--- a/theories/Numbers/NatInt/NZAdd.v
+++ b/theories/Numbers/NatInt/NZAdd.v
@@ -8,84 +8,83 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import NZAxioms.
-Require Import NZBase.
+Require Import NZAxioms NZBase.
 
-Module NZAddPropFunct (Import NZAxiomsMod : NZAxiomsSig).
-Module Export NZBasePropMod := NZBasePropFunct NZAxiomsMod.
-Open Local Scope NatIntScope.
+Module Type NZAddPropSig
+ (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ).
 
-Theorem NZadd_0_r : forall n : NZ, n + 0 == n.
+Hint Rewrite
+ pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz.
+Ltac nzsimpl := autorewrite with nz.
+
+Theorem add_0_r : forall n, n + 0 == n.
 Proof.
-NZinduct n. now rewrite NZadd_0_l.
-intro. rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd.
+nzinduct n. now nzsimpl.
+intro. nzsimpl. now rewrite succ_inj_wd.
 Qed.
 
-Theorem NZadd_succ_r : forall n m : NZ, n + S m == S (n + m).
+Theorem add_succ_r : forall n m, n + S m == S (n + m).
 Proof.
-intros n m; NZinduct n.
-now do 2 rewrite NZadd_0_l.
-intro. repeat rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd.
+intros n m; nzinduct n. now nzsimpl.
+intro. nzsimpl. now rewrite succ_inj_wd.
 Qed.
 
-Theorem NZadd_comm : forall n m : NZ, n + m == m + n.
+Hint Rewrite add_0_r add_succ_r : nz.
+
+Theorem add_comm : forall n m, n + m == m + n.
 Proof.
-intros n m; NZinduct n.
-rewrite NZadd_0_l; now rewrite NZadd_0_r.
-intros n. rewrite NZadd_succ_l; rewrite NZadd_succ_r. now rewrite NZsucc_inj_wd.
+intros n m; nzinduct n. now nzsimpl.
+intro. nzsimpl. now rewrite succ_inj_wd.
 Qed.
 
-Theorem NZadd_1_l : forall n : NZ, 1 + n == S n.
+Theorem add_1_l : forall n, 1 + n == S n.
 Proof.
-intro n; rewrite NZadd_succ_l; now rewrite NZadd_0_l.
+intro n; now nzsimpl.
 Qed.
 
-Theorem NZadd_1_r : forall n : NZ, n + 1 == S n.
+Theorem add_1_r : forall n, n + 1 == S n.
 Proof.
-intro n; rewrite NZadd_comm; apply NZadd_1_l.
+intro n; now nzsimpl.
 Qed.
 
-Theorem NZadd_assoc : forall n m p : NZ, n + (m + p) == (n + m) + p.
+Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p.
 Proof.
-intros n m p; NZinduct n.
-now do 2 rewrite NZadd_0_l.
-intro. do 3 rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd.
+intros n m p; nzinduct n. now nzsimpl.
+intro. nzsimpl. now rewrite succ_inj_wd.
 Qed.
 
-Theorem NZadd_shuffle1 : forall n m p q : NZ, (n + m) + (p + q) == (n + p) + (m + q).
+Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m.
 Proof.
-intros n m p q.
-rewrite <- (NZadd_assoc n m (p + q)). rewrite (NZadd_comm m (p + q)).
-rewrite <- (NZadd_assoc p q m). rewrite (NZadd_assoc n p (q + m)).
-now rewrite (NZadd_comm q m).
+intros n m p; nzinduct p. now nzsimpl.
+intro p. nzsimpl. now rewrite succ_inj_wd.
 Qed.
 
-Theorem NZadd_shuffle2 : forall n m p q : NZ, (n + m) + (p + q) == (n + q) + (m + p).
+Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m.
 Proof.
-intros n m p q.
-rewrite <- (NZadd_assoc n m (p + q)). rewrite (NZadd_assoc m p q).
-rewrite (NZadd_comm (m + p) q). now rewrite <- (NZadd_assoc n q (m + p)).
+intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l.
 Qed.
 
-Theorem NZadd_cancel_l : forall n m p : NZ, p + n == p + m <-> n == m.
+Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m.
 Proof.
-intros n m p; NZinduct p.
-now do 2 rewrite NZadd_0_l.
-intro p. do 2 rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd.
+intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm.
 Qed.
 
-Theorem NZadd_cancel_r : forall n m p : NZ, n + p == m + p <-> n == m.
+Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q).
 Proof.
-intros n m p. rewrite (NZadd_comm n p); rewrite (NZadd_comm m p).
-apply NZadd_cancel_l.
+intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0.
 Qed.
 
-Theorem NZsub_1_r : forall n : NZ, n - 1 == P n.
+Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p).
 Proof.
-intro n; rewrite NZsub_succ_r; now rewrite NZsub_0_r.
+intros n m p q.
+rewrite 2 add_assoc, add_shuffle0, add_cancel_r. apply add_shuffle0.
 Qed.
 
-End NZAddPropFunct.
+Theorem sub_1_r : forall n, n - 1 == P n.
+Proof.
+intro n; now nzsimpl.
+Qed.
 
+End NZAddPropSig.
diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v
index 50d1c42f..97c12202 100644
--- a/theories/Numbers/NatInt/NZAddOrder.v
+++ b/theories/Numbers/NatInt/NZAddOrder.v
@@ -8,159 +8,146 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import NZAxioms.
-Require Import NZOrder.
+Require Import NZAxioms NZBase NZMul NZOrder.
 
-Module NZAddOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig).
-Module Export NZOrderPropMod := NZOrderPropFunct NZOrdAxiomsMod.
-Open Local Scope NatIntScope.
+Module Type NZAddOrderPropSig (Import NZ : NZOrdAxiomsSig').
+Include NZBasePropSig NZ <+ NZMulPropSig NZ <+ NZOrderPropSig NZ.
 
-Theorem NZadd_lt_mono_l : forall n m p : NZ, n < m <-> p + n < p + m.
+Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m.
 Proof.
-intros n m p; NZinduct p.
-now do 2 rewrite NZadd_0_l.
-intro p. do 2 rewrite NZadd_succ_l. now rewrite <- NZsucc_lt_mono.
+intros n m p; nzinduct p. now nzsimpl.
+intro p. nzsimpl. now rewrite <- succ_lt_mono.
 Qed.
 
-Theorem NZadd_lt_mono_r : forall n m p : NZ, n < m <-> n + p < m + p.
+Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p.
 Proof.
-intros n m p.
-rewrite (NZadd_comm n p); rewrite (NZadd_comm m p); apply NZadd_lt_mono_l.
+intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l.
 Qed.
 
-Theorem NZadd_lt_mono : forall n m p q : NZ, n < m -> p < q -> n + p < m + q.
+Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q.
 Proof.
 intros n m p q H1 H2.
-apply NZlt_trans with (m + p);
-[now apply -> NZadd_lt_mono_r | now apply -> NZadd_lt_mono_l].
+apply lt_trans with (m + p);
+[now apply -> add_lt_mono_r | now apply -> add_lt_mono_l].
 Qed.
 
-Theorem NZadd_le_mono_l : forall n m p : NZ, n <= m <-> p + n <= p + m.
+Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m.
 Proof.
-intros n m p; NZinduct p.
-now do 2 rewrite NZadd_0_l.
-intro p. do 2 rewrite NZadd_succ_l. now rewrite <- NZsucc_le_mono.
+intros n m p; nzinduct p. now nzsimpl.
+intro p. nzsimpl. now rewrite <- succ_le_mono.
 Qed.
 
-Theorem NZadd_le_mono_r : forall n m p : NZ, n <= m <-> n + p <= m + p.
+Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p.
 Proof.
-intros n m p.
-rewrite (NZadd_comm n p); rewrite (NZadd_comm m p); apply NZadd_le_mono_l.
+intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l.
 Qed.
 
-Theorem NZadd_le_mono : forall n m p q : NZ, n <= m -> p <= q -> n + p <= m + q.
+Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
 Proof.
 intros n m p q H1 H2.
-apply NZle_trans with (m + p);
-[now apply -> NZadd_le_mono_r | now apply -> NZadd_le_mono_l].
+apply le_trans with (m + p);
+[now apply -> add_le_mono_r | now apply -> add_le_mono_l].
 Qed.
 
-Theorem NZadd_lt_le_mono : forall n m p q : NZ, n < m -> p <= q -> n + p < m + q.
+Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q.
 Proof.
 intros n m p q H1 H2.
-apply NZlt_le_trans with (m + p);
-[now apply -> NZadd_lt_mono_r | now apply -> NZadd_le_mono_l].
+apply lt_le_trans with (m + p);
+[now apply -> add_lt_mono_r | now apply -> add_le_mono_l].
 Qed.
 
-Theorem NZadd_le_lt_mono : forall n m p q : NZ, n <= m -> p < q -> n + p < m + q.
+Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q.
 Proof.
 intros n m p q H1 H2.
-apply NZle_lt_trans with (m + p);
-[now apply -> NZadd_le_mono_r | now apply -> NZadd_lt_mono_l].
+apply le_lt_trans with (m + p);
+[now apply -> add_le_mono_r | now apply -> add_lt_mono_l].
 Qed.
 
-Theorem NZadd_pos_pos : forall n m : NZ, 0 < n -> 0 < m -> 0 < n + m.
+Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m.
 Proof.
-intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_lt_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono.
 Qed.
 
-Theorem NZadd_pos_nonneg : forall n m : NZ, 0 < n -> 0 <= m -> 0 < n + m.
+Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m.
 Proof.
-intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_lt_le_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
 Qed.
 
-Theorem NZadd_nonneg_pos : forall n m : NZ, 0 <= n -> 0 < m -> 0 < n + m.
+Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m.
 Proof.
-intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_le_lt_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
 Qed.
 
-Theorem NZadd_nonneg_nonneg : forall n m : NZ, 0 <= n -> 0 <= m -> 0 <= n + m.
+Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m.
 Proof.
-intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_le_mono.
+intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono.
 Qed.
 
-Theorem NZlt_add_pos_l : forall n m : NZ, 0 < n -> m < n + m.
+Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m.
 Proof.
-intros n m H. apply -> (NZadd_lt_mono_r 0 n m) in H.
-now rewrite NZadd_0_l in H.
+intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl.
 Qed.
 
-Theorem NZlt_add_pos_r : forall n m : NZ, 0 < n -> m < m + n.
+Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n.
 Proof.
-intros; rewrite NZadd_comm; now apply NZlt_add_pos_l.
+intros; rewrite add_comm; now apply lt_add_pos_l.
 Qed.
 
-Theorem NZle_lt_add_lt : forall n m p q : NZ, n <= m -> p + m < q + n -> p < q.
+Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q.
 Proof.
-intros n m p q H1 H2. destruct (NZle_gt_cases q p); [| assumption].
-pose proof (NZadd_le_mono q p n m H H1) as H3. apply <- NZnle_gt in H2.
-false_hyp H3 H2.
+intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption].
+contradict H2. rewrite nlt_ge. now apply add_le_mono.
 Qed.
 
-Theorem NZlt_le_add_lt : forall n m p q : NZ, n < m -> p + m <= q + n -> p < q.
+Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q.
 Proof.
-intros n m p q H1 H2. destruct (NZle_gt_cases q p); [| assumption].
-pose proof (NZadd_le_lt_mono q p n m H H1) as H3. apply <- NZnle_gt in H3.
-false_hyp H2 H3.
+intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption].
+contradict H2. rewrite nle_gt. now apply add_le_lt_mono.
 Qed.
 
-Theorem NZle_le_add_le : forall n m p q : NZ, n <= m -> p + m <= q + n -> p <= q.
+Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q.
 Proof.
-intros n m p q H1 H2. destruct (NZle_gt_cases p q); [assumption |].
-pose proof (NZadd_lt_le_mono q p n m H H1) as H3. apply <- NZnle_gt in H3.
-false_hyp H2 H3.
+intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |].
+contradict H2. rewrite nle_gt. now apply add_lt_le_mono.
 Qed.
 
-Theorem NZadd_lt_cases : forall n m p q : NZ, n + m < p + q -> n < p \/ m < q.
+Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q.
 Proof.
 intros n m p q H;
-destruct (NZle_gt_cases p n) as [H1 | H1].
-destruct (NZle_gt_cases q m) as [H2 | H2].
-pose proof (NZadd_le_mono p n q m H1 H2) as H3. apply -> NZle_ngt in H3.
-false_hyp H H3.
-now right. now left.
+destruct (le_gt_cases p n) as [H1 | H1]; [| now left].
+destruct (le_gt_cases q m) as [H2 | H2]; [| now right].
+contradict H; rewrite nlt_ge. now apply add_le_mono.
 Qed.
 
-Theorem NZadd_le_cases : forall n m p q : NZ, n + m <= p + q -> n <= p \/ m <= q.
+Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q.
 Proof.
 intros n m p q H.
-destruct (NZle_gt_cases n p) as [H1 | H1]. now left.
-destruct (NZle_gt_cases m q) as [H2 | H2]. now right.
-assert (H3 : p + q < n + m) by now apply NZadd_lt_mono.
-apply -> NZle_ngt in H. false_hyp H3 H.
+destruct (le_gt_cases n p) as [H1 | H1]. now left.
+destruct (le_gt_cases m q) as [H2 | H2]. now right.
+contradict H; rewrite nle_gt. now apply add_lt_mono.
 Qed.
 
-Theorem NZadd_neg_cases : forall n m : NZ, n + m < 0 -> n < 0 \/ m < 0.
+Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0.
 Proof.
-intros n m H; apply NZadd_lt_cases; now rewrite NZadd_0_l.
+intros n m H; apply add_lt_cases; now nzsimpl.
 Qed.
 
-Theorem NZadd_pos_cases : forall n m : NZ, 0 < n + m -> 0 < n \/ 0 < m.
+Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m.
 Proof.
-intros n m H; apply NZadd_lt_cases; now rewrite NZadd_0_l.
+intros n m H; apply add_lt_cases; now nzsimpl.
 Qed.
 
-Theorem NZadd_nonpos_cases : forall n m : NZ, n + m <= 0 -> n <= 0 \/ m <= 0.
+Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0.
 Proof.
-intros n m H; apply NZadd_le_cases; now rewrite NZadd_0_l.
+intros n m H; apply add_le_cases; now nzsimpl.
 Qed.
 
-Theorem NZadd_nonneg_cases : forall n m : NZ, 0 <= n + m -> 0 <= n \/ 0 <= m.
+Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m.
 Proof.
-intros n m H; apply NZadd_le_cases; now rewrite NZadd_0_l.
+intros n m H; apply add_le_cases; now nzsimpl.
 Qed.
 
-End NZAddOrderPropFunct.
+End NZAddOrderPropSig.
 
diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v
index 26933646..ee7ee159 100644
--- a/theories/Numbers/NatInt/NZAxioms.v
+++ b/theories/Numbers/NatInt/NZAxioms.v
@@ -5,95 +5,115 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*                      Evgeny Makarov, INRIA, 2007                     *)
-(************************************************************************)
 
-(*i $Id: NZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
-
-Require Export NumPrelude.
-
-Module Type NZAxiomsSig.
-
-Parameter Inline NZ : Type.
-Parameter Inline NZeq : NZ -> NZ -> Prop.
-Parameter Inline NZ0 : NZ.
-Parameter Inline NZsucc : NZ -> NZ.
-Parameter Inline NZpred : NZ -> NZ.
-Parameter Inline NZadd : NZ -> NZ -> NZ.
-Parameter Inline NZsub : NZ -> NZ -> NZ.
-Parameter Inline NZmul : NZ -> NZ -> NZ.
-
-(* Unary subtraction (opp) is not defined on natural numbers, so we have 
-   it for integers only *)
-
-Axiom NZeq_equiv : equiv NZ NZeq.
-Add Relation NZ NZeq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
-as NZeq_rel.
-
-Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd.
-Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd.
-Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd.
-Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd.
-Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd.
-
-Delimit Scope NatIntScope with NatInt.
-Open Local Scope NatIntScope.
-Notation "x == y"  := (NZeq x y) (at level 70) : NatIntScope.
-Notation "x ~= y" := (~ NZeq x y) (at level 70) : NatIntScope.
-Notation "0" := NZ0 : NatIntScope.
-Notation S := NZsucc.
-Notation P := NZpred.
-Notation "1" := (S 0) : NatIntScope.
-Notation "x + y" := (NZadd x y) : NatIntScope.
-Notation "x - y" := (NZsub x y) : NatIntScope.
-Notation "x * y" := (NZmul x y) : NatIntScope.
-
-Axiom NZpred_succ : forall n : NZ, P (S n) == n.
-
-Axiom NZinduction :
-  forall A : NZ -> Prop, predicate_wd NZeq A ->
-    A 0 -> (forall n : NZ, A n <-> A (S n)) -> forall n : NZ, A n.
-
-Axiom NZadd_0_l : forall n : NZ, 0 + n == n.
-Axiom NZadd_succ_l : forall n m : NZ, (S n) + m == S (n + m).
-
-Axiom NZsub_0_r : forall n : NZ, n - 0 == n.
-Axiom NZsub_succ_r : forall n m : NZ, n - (S m) == P (n - m).
-
-Axiom NZmul_0_l : forall n : NZ, 0 * n == 0.
-Axiom NZmul_succ_l : forall n m : NZ, S n * m == n * m + m.
-
-End NZAxiomsSig.
-
-Module Type NZOrdAxiomsSig.
-Declare Module Export NZAxiomsMod : NZAxiomsSig.
-Open Local Scope NatIntScope.
-
-Parameter Inline NZlt : NZ -> NZ -> Prop.
-Parameter Inline NZle : NZ -> NZ -> Prop.
-Parameter Inline NZmin : NZ -> NZ -> NZ.
-Parameter Inline NZmax : NZ -> NZ -> NZ.
-
-Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd.
-Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd.
-Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd.
-Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd.
-
-Notation "x < y" := (NZlt x y) : NatIntScope.
-Notation "x <= y" := (NZle x y) : NatIntScope.
-Notation "x > y" := (NZlt y x) (only parsing) : NatIntScope.
-Notation "x >= y" := (NZle y x) (only parsing) : NatIntScope.
-
-Axiom NZlt_eq_cases : forall n m : NZ, n <= m <-> n < m \/ n == m.
-Axiom NZlt_irrefl : forall n : NZ, ~ (n < n).
-Axiom NZlt_succ_r : forall n m : NZ, n < S m <-> n <= m.
-
-Axiom NZmin_l : forall n m : NZ, n <= m -> NZmin n m == n.
-Axiom NZmin_r : forall n m : NZ, m <= n -> NZmin n m == m.
-Axiom NZmax_l : forall n m : NZ, m <= n -> NZmax n m == n.
-Axiom NZmax_r : forall n m : NZ, n <= m -> NZmax n m == m.
-
-End NZOrdAxiomsSig.
+(** Initial Author : Evgeny Makarov, INRIA, 2007 *)
+
+(*i $Id$ i*)
+
+Require Export Equalities Orders NumPrelude GenericMinMax.
+
+(** Axiomatization of a domain with zero, successor, predecessor,
+    and a bi-directional induction principle. We require [P (S n) = n]
+    but not the other way around, since this domain is meant
+    to be either N or Z. In fact it can be a few other things,
+    for instance [Z/nZ] (See file [NZDomain] for a study of that).
+*)
+
+Module Type ZeroSuccPred (Import T:Typ).
+ Parameter Inline zero : t.
+ Parameters Inline succ pred : t -> t.
+End ZeroSuccPred.
+
+Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T).
+ Notation "0" := zero.
+ Notation S := succ.
+ Notation P := pred.
+ Notation "1" := (S 0).
+ Notation "2" := (S 1).
+End ZeroSuccPredNotation.
+
+Module Type ZeroSuccPred' (T:Typ) :=
+ ZeroSuccPred T <+ ZeroSuccPredNotation T.
+
+Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E).
+ Declare Instance succ_wd : Proper (eq ==> eq) S.
+ Declare Instance pred_wd : Proper (eq ==> eq) P.
+ Axiom pred_succ : forall n, P (S n) == n.
+ Axiom bi_induction :
+  forall A : t -> Prop, Proper (eq==>iff) A ->
+    A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n.
+End IsNZDomain.
+
+Module Type NZDomainSig := EqualityType <+ ZeroSuccPred <+ IsNZDomain.
+Module Type NZDomainSig' := EqualityType' <+ ZeroSuccPred' <+ IsNZDomain.
+
+
+(** Axiomatization of basic operations : [+] [-] [*] *)
+
+Module Type AddSubMul (Import T:Typ).
+ Parameters Inline add sub mul : t -> t -> t.
+End AddSubMul.
+
+Module Type AddSubMulNotation (T:Typ)(Import NZ:AddSubMul T).
+ Notation "x + y" := (add x y).
+ Notation "x - y" := (sub x y).
+ Notation "x * y" := (mul x y).
+End AddSubMulNotation.
+
+Module Type AddSubMul' (T:Typ) := AddSubMul T <+ AddSubMulNotation T.
+
+Module Type IsAddSubMul (Import E:NZDomainSig')(Import NZ:AddSubMul' E).
+ Declare Instance add_wd : Proper (eq ==> eq ==> eq) add.
+ Declare Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
+ Declare Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
+ Axiom add_0_l : forall n, 0 + n == n.
+ Axiom add_succ_l : forall n m, (S n) + m == S (n + m).
+ Axiom sub_0_r : forall n, n - 0 == n.
+ Axiom sub_succ_r : forall n m, n - (S m) == P (n - m).
+ Axiom mul_0_l : forall n, 0 * n == 0.
+ Axiom mul_succ_l : forall n m, S n * m == n * m + m.
+End IsAddSubMul.
+
+Module Type NZBasicFunsSig := NZDomainSig <+ AddSubMul <+ IsAddSubMul.
+Module Type NZBasicFunsSig' := NZDomainSig' <+ AddSubMul' <+IsAddSubMul.
+
+(** Old name for the same interface: *)
+
+Module Type NZAxiomsSig := NZBasicFunsSig.
+Module Type NZAxiomsSig' := NZBasicFunsSig'.
+
+(** Axiomatization of order *)
+
+Module Type NZOrd := NZDomainSig <+ HasLt <+ HasLe.
+Module Type NZOrd' := NZDomainSig' <+ HasLt <+ HasLe <+
+                      LtNotation <+ LeNotation <+ LtLeNotation.
+
+Module Type IsNZOrd (Import NZ : NZOrd').
+ Declare Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
+ Axiom lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
+ Axiom lt_irrefl : forall n, ~ (n < n).
+ Axiom lt_succ_r : forall n m, n < S m <-> n <= m.
+End IsNZOrd.
+
+(** NB: the compatibility of [le] can be proved later from [lt_wd]
+    and [lt_eq_cases] *)
+
+Module Type NZOrdSig := NZOrd <+ IsNZOrd.
+Module Type NZOrdSig' := NZOrd' <+ IsNZOrd.
+
+(** Everything together : *)
+
+Module Type NZOrdAxiomsSig <: NZBasicFunsSig <: NZOrdSig
+ := NZOrdSig <+ AddSubMul <+ IsAddSubMul <+ HasMinMax.
+Module Type NZOrdAxiomsSig' <: NZOrdAxiomsSig
+ := NZOrdSig' <+ AddSubMul' <+ IsAddSubMul <+ HasMinMax.
+
+
+(** Same, plus a comparison function. *)
+
+Module Type NZDecOrdSig := NZOrdSig <+ HasCompare.
+Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare.
+
+Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare.
+Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare.
+
diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v
index bd4d6232..18e3b9b9 100644
--- a/theories/Numbers/NatInt/NZBase.v
+++ b/theories/Numbers/NatInt/NZBase.v
@@ -8,45 +8,54 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import NZAxioms.
 
-Module NZBasePropFunct (Import NZAxiomsMod : NZAxiomsSig).
-Open Local Scope NatIntScope.
+Module Type NZBasePropSig (Import NZ : NZDomainSig').
 
-Theorem NZneq_sym : forall n m : NZ, n ~= m -> m ~= n.
+Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *)
+
+Lemma eq_sym_iff : forall x y, x==y <-> y==x.
+Proof.
+intros; split; symmetry; auto.
+Qed.
+
+(* TODO: how register ~= (which is just a notation) as a Symmetric relation,
+    hence allowing "symmetry" tac ? *)
+
+Theorem neq_sym : forall n m, n ~= m -> m ~= n.
 Proof.
 intros n m H1 H2; symmetry in H2; false_hyp H2 H1.
 Qed.
 
-Theorem NZE_stepl : forall x y z : NZ, x == y -> x == z -> z == y.
+Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y.
 Proof.
 intros x y z H1 H2; now rewrite <- H1.
 Qed.
 
-Declare Left Step NZE_stepl.
-(* The right step lemma is just the transitivity of NZeq *)
-Declare Right Step (proj1 (proj2 NZeq_equiv)).
+Declare Left Step eq_stepl.
+(* The right step lemma is just the transitivity of eq *)
+Declare Right Step (@Equivalence_Transitive _ _ eq_equiv).
 
-Theorem NZsucc_inj : forall n1 n2 : NZ, S n1 == S n2 -> n1 == n2.
+Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2.
 Proof.
 intros n1 n2 H.
-apply NZpred_wd in H. now do 2 rewrite NZpred_succ in H.
+apply pred_wd in H. now do 2 rewrite pred_succ in H.
 Qed.
 
 (* The following theorem is useful as an equivalence for proving
 bidirectional induction steps *)
-Theorem NZsucc_inj_wd : forall n1 n2 : NZ, S n1 == S n2 <-> n1 == n2.
+Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2.
 Proof.
 intros; split.
-apply NZsucc_inj.
-apply NZsucc_wd.
+apply succ_inj.
+apply succ_wd.
 Qed.
 
-Theorem NZsucc_inj_wd_neg : forall n m : NZ, S n ~= S m <-> n ~= m.
+Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m.
 Proof.
-intros; now rewrite NZsucc_inj_wd.
+intros; now rewrite succ_inj_wd.
 Qed.
 
 (* We cannot prove that the predecessor is injective, nor that it is
@@ -54,31 +63,27 @@ left-inverse to the successor at this point *)
 
 Section CentralInduction.
 
-Variable A : predicate NZ.
-
-Hypothesis A_wd : predicate_wd NZeq A.
-
-Add Morphism A with signature NZeq ==> iff as A_morph.
-Proof. apply A_wd. Qed.
+Variable A : predicate t.
+Hypothesis A_wd : Proper (eq==>iff) A.
 
-Theorem NZcentral_induction :
-  forall z : NZ, A z ->
-    (forall n : NZ, A n <-> A (S n)) ->
-      forall n : NZ, A n.
+Theorem central_induction :
+  forall z, A z ->
+    (forall n, A n <-> A (S n)) ->
+      forall n, A n.
 Proof.
-intros z Base Step; revert Base; pattern z; apply NZinduction.
+intros z Base Step; revert Base; pattern z; apply bi_induction.
 solve_predicate_wd.
-intro; now apply NZinduction.
+intro; now apply bi_induction.
 intro; pose proof (Step n); tauto.
 Qed.
 
 End CentralInduction.
 
-Tactic Notation "NZinduct" ident(n) :=
-  induction_maker n ltac:(apply NZinduction).
+Tactic Notation "nzinduct" ident(n) :=
+  induction_maker n ltac:(apply bi_induction).
 
-Tactic Notation "NZinduct" ident(n) constr(u) :=
-  induction_maker n ltac:(apply NZcentral_induction with (z := u)).
+Tactic Notation "nzinduct" ident(n) constr(u) :=
+  induction_maker n ltac:(apply central_induction with (z := u)).
 
-End NZBasePropFunct.
+End NZBasePropSig.
 
diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v
new file mode 100644
index 00000000..1f6c615b
--- /dev/null
+++ b/theories/Numbers/NatInt/NZDiv.v
@@ -0,0 +1,542 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Euclidean Division *)
+
+Require Import NZAxioms NZMulOrder.
+
+(** The first signatures will be common to all divisions over NZ, N and Z *)
+
+Module Type DivMod (Import T:Typ).
+ Parameters Inline div modulo : t -> t -> t.
+End DivMod.
+
+Module Type DivModNotation (T:Typ)(Import NZ:DivMod T).
+ Infix "/" := div.
+ Infix "mod" := modulo (at level 40, no associativity).
+End DivModNotation.
+
+Module Type DivMod' (T:Typ) := DivMod T <+ DivModNotation T.
+
+Module Type NZDivCommon (Import NZ : NZAxiomsSig')(Import DM : DivMod' NZ).
+ Declare Instance div_wd : Proper (eq==>eq==>eq) div.
+ Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo.
+ Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b).
+End NZDivCommon.
+
+(** The different divisions will only differ in the conditions
+    they impose on [modulo]. For NZ, we only describe behavior
+    on positive numbers.
+
+    NB: This axiom would also be true for N and Z, but redundant.
+*)
+
+Module Type NZDivSpecific (Import NZ : NZOrdAxiomsSig')(Import DM : DivMod' NZ).
+ Axiom mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
+End NZDivSpecific.
+
+Module Type NZDiv (NZ:NZOrdAxiomsSig)
+ := DivMod NZ <+ NZDivCommon NZ <+ NZDivSpecific NZ.
+
+Module Type NZDiv' (NZ:NZOrdAxiomsSig) := NZDiv NZ <+ DivModNotation NZ.
+
+Module NZDivPropFunct
+ (Import NZ : NZOrdAxiomsSig')
+ (Import NZP : NZMulOrderPropSig NZ)
+ (Import NZD : NZDiv' NZ)
+.
+
+(** Uniqueness theorems *)
+
+Theorem div_mod_unique :
+ forall b q1 q2 r1 r2, 0<=r1<b -> 0<=r2<b ->
+  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
+Proof.
+intros b.
+assert (U : forall q1 q2 r1 r2,
+            b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False).
+ intros q1 q2 r1 r2 EQ LT Hr1 Hr2.
+ contradict EQ.
+ apply lt_neq.
+ apply lt_le_trans with (b*q1+b).
+ rewrite <- add_lt_mono_l. tauto.
+ apply le_trans with (b*q2).
+ rewrite mul_comm, <- mul_succ_l, mul_comm.
+ apply mul_le_mono_nonneg_l; intuition; try order.
+ rewrite le_succ_l; auto.
+ rewrite <- (add_0_r (b*q2)) at 1.
+ rewrite <- add_le_mono_l. tauto.
+
+intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]].
+elim (U q1 q2 r1 r2); intuition.
+split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto.
+elim (U q2 q1 r2 r1); intuition.
+Qed.
+
+Theorem div_unique:
+ forall a b q r, 0<=a -> 0<=r<b ->
+   a == b*q + r -> q == a/b.
+Proof.
+intros a b q r Ha (Hb,Hr) EQ.
+destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
+apply mod_bound; order.
+rewrite <- div_mod; order.
+Qed.
+
+Theorem mod_unique:
+ forall a b q r, 0<=a -> 0<=r<b ->
+  a == b*q + r -> r == a mod b.
+Proof.
+intros a b q r Ha (Hb,Hr) EQ.
+destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
+apply mod_bound; order.
+rewrite <- div_mod; order.
+Qed.
+
+
+(** A division by itself returns 1 *)
+
+Lemma div_same : forall a, 0<a -> a/a == 1.
+Proof.
+intros. symmetry.
+apply div_unique with 0; intuition; try order.
+now nzsimpl.
+Qed.
+
+Lemma mod_same : forall a, 0<a -> a mod a == 0.
+Proof.
+intros. symmetry.
+apply mod_unique with 1; intuition; try order.
+now nzsimpl.
+Qed.
+
+(** A division of a small number by a bigger one yields zero. *)
+
+Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
+Proof.
+intros. symmetry.
+apply div_unique with a; intuition; try order.
+now nzsimpl.
+Qed.
+
+(** Same situation, in term of modulo: *)
+
+Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
+Proof.
+intros. symmetry.
+apply mod_unique with 0; intuition; try order.
+now nzsimpl.
+Qed.
+
+(** * Basic values of divisions and modulo. *)
+
+Lemma div_0_l: forall a, 0<a -> 0/a == 0.
+Proof.
+intros; apply div_small; split; order.
+Qed.
+
+Lemma mod_0_l: forall a, 0<a -> 0 mod a == 0.
+Proof.
+intros; apply mod_small; split; order.
+Qed.
+
+Lemma div_1_r: forall a, 0<=a -> a/1 == a.
+Proof.
+intros. symmetry.
+apply div_unique with 0; try split; try order; try apply lt_0_1.
+now nzsimpl.
+Qed.
+
+Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0.
+Proof.
+intros. symmetry.
+apply mod_unique with a; try split; try order; try apply lt_0_1.
+now nzsimpl.
+Qed.
+
+Lemma div_1_l: forall a, 1<a -> 1/a == 0.
+Proof.
+intros; apply div_small; split; auto. apply le_succ_diag_r.
+Qed.
+
+Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
+Proof.
+intros; apply mod_small; split; auto. apply le_succ_diag_r.
+Qed.
+
+Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a.
+Proof.
+intros; symmetry.
+apply div_unique with 0; try split; try order.
+apply mul_nonneg_nonneg; order.
+nzsimpl; apply mul_comm.
+Qed.
+
+Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0.
+Proof.
+intros; symmetry.
+apply mod_unique with a; try split; try order.
+apply mul_nonneg_nonneg; order.
+nzsimpl; apply mul_comm.
+Qed.
+
+
+(** * Order results about mod and div *)
+
+(** A modulo cannot grow beyond its starting point. *)
+
+Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
+Proof.
+intros. destruct (le_gt_cases b a).
+apply le_trans with b; auto.
+apply lt_le_incl. destruct (mod_bound a b); auto.
+rewrite lt_eq_cases; right.
+apply mod_small; auto.
+Qed.
+
+
+(* Division of positive numbers is positive. *)
+
+Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b.
+Proof.
+intros.
+rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl.
+rewrite (add_le_mono_r _ _ (a mod b)).
+rewrite <- div_mod by order.
+nzsimpl.
+apply mod_le; auto.
+Qed.
+
+Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
+Proof.
+intros a b (Hb,Hab).
+assert (LE : 0 <= a/b) by (apply div_pos; order).
+assert (MOD : a mod b < b) by (destruct (mod_bound a b); order).
+rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto.
+exfalso; revert Hab.
+rewrite (div_mod a b), <-EQ; nzsimpl; order.
+Qed.
+
+Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b).
+Proof.
+intros a b Ha Hb; split; intros Hab.
+destruct (lt_ge_cases a b); auto.
+symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto.
+apply div_small; auto.
+Qed.
+
+Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b).
+Proof.
+intros a b Ha Hb. split; intros H; auto using mod_small.
+rewrite <- div_small_iff; auto.
+rewrite <- (mul_cancel_l _ _ b) by order.
+rewrite <- (add_cancel_r _ _ (a mod b)).
+rewrite <- div_mod, H by order. now nzsimpl.
+Qed.
+
+Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a).
+Proof.
+intros a b Ha Hb; split; intros Hab.
+destruct (lt_ge_cases a b) as [LT|LE]; auto.
+rewrite <- div_small_iff in LT; order.
+apply div_str_pos; auto.
+Qed.
+
+
+(** As soon as the divisor is strictly greater than 1,
+    the division is strictly decreasing. *)
+
+Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
+Proof.
+intros.
+assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1).
+destruct (lt_ge_cases a b).
+rewrite div_small; try split; order.
+rewrite (div_mod a b) at 2 by order.
+apply lt_le_trans with (b*(a/b)).
+rewrite <- (mul_1_l (a/b)) at 1.
+rewrite <- mul_lt_mono_pos_r; auto.
+apply div_str_pos; auto.
+rewrite <- (add_0_r (b*(a/b))) at 1.
+rewrite <- add_le_mono_l. destruct (mod_bound a b); order.
+Qed.
+
+(** [le] is compatible with a positive division. *)
+
+Lemma div_le_mono : forall a b c, 0<c -> 0<=a<=b -> a/c <= b/c.
+Proof.
+intros a b c Hc (Ha,Hab).
+rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
+ [|rewrite EQ; order].
+rewrite <- lt_succ_r.
+rewrite (mul_lt_mono_pos_l c) by order.
+nzsimpl.
+rewrite (add_lt_mono_r _ _ (a mod c)).
+rewrite <- div_mod by order.
+apply lt_le_trans with b; auto.
+rewrite (div_mod b c) at 1 by order.
+rewrite <- add_assoc, <- add_le_mono_l.
+apply le_trans with (c+0).
+nzsimpl; destruct (mod_bound b c); order.
+rewrite <- add_le_mono_l. destruct (mod_bound a c); order.
+Qed.
+
+(** The following two properties could be used as specification of div *)
+
+Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a.
+Proof.
+intros.
+rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order.
+rewrite <- (add_0_r a) at 1.
+rewrite <- add_le_mono_l. destruct (mod_bound a b); order.
+Qed.
+
+Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
+Proof.
+intros.
+rewrite (div_mod a b) at 1 by order.
+rewrite (mul_succ_r).
+rewrite <- add_lt_mono_l.
+destruct (mod_bound a b); auto.
+Qed.
+
+
+(** The previous inequality is exact iff the modulo is zero. *)
+
+Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0).
+Proof.
+intros. rewrite (div_mod a b) at 1 by order.
+rewrite <- (add_0_r (b*(a/b))) at 2.
+apply add_cancel_l.
+Qed.
+
+(** Some additionnal inequalities about div. *)
+
+Theorem div_lt_upper_bound:
+  forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q.
+Proof.
+intros.
+rewrite (mul_lt_mono_pos_l b) by order.
+apply le_lt_trans with a; auto.
+apply mul_div_le; auto.
+Qed.
+
+Theorem div_le_upper_bound:
+  forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q.
+Proof.
+intros.
+rewrite (mul_le_mono_pos_l _ _ b) by order.
+apply le_trans with a; auto.
+apply mul_div_le; auto.
+Qed.
+
+Theorem div_le_lower_bound:
+  forall a b q, 0<=a -> 0<b -> b*q <= a -> q <= a/b.
+Proof.
+intros a b q Ha Hb H.
+destruct (lt_ge_cases 0 q).
+rewrite <- (div_mul q b); try order.
+apply div_le_mono; auto.
+rewrite mul_comm; split; auto.
+apply lt_le_incl, mul_pos_pos; auto.
+apply le_trans with 0; auto; apply div_pos; auto.
+Qed.
+
+(** A division respects opposite monotonicity for the divisor *)
+
+Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r ->
+    p/r <= p/q.
+Proof.
+ intros p q r Hp (Hq,Hqr).
+ apply div_le_lower_bound; auto.
+ rewrite (div_mod p r) at 2 by order.
+ apply le_trans with (r*(p/r)).
+ apply mul_le_mono_nonneg_r; try order.
+ apply div_pos; order.
+ rewrite <- (add_0_r (r*(p/r))) at 1.
+ rewrite <- add_le_mono_l. destruct (mod_bound p r); order.
+Qed.
+
+
+(** * Relations between usual operations and mod and div *)
+
+Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
+ (a + b * c) mod c == a mod c.
+Proof.
+ intros.
+ symmetry.
+ apply mod_unique with (a/c+b); auto.
+ apply mod_bound; auto.
+ rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
+ now rewrite mul_comm.
+Qed.
+
+Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
+ (a + b * c) / c == a / c + b.
+Proof.
+ intros.
+ apply (mul_cancel_l _ _ c); try order.
+ apply (add_cancel_r _ _ ((a+b*c) mod c)).
+ rewrite <- div_mod, mod_add by order.
+ rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
+ now rewrite mul_comm.
+Qed.
+
+Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0<b ->
+ (a * b + c) / b == a + c / b.
+Proof.
+ intros a b c. rewrite (add_comm _ c), (add_comm a).
+ intros. apply div_add; auto.
+Qed.
+
+(** Cancellations. *)
+
+Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c ->
+ (a*c)/(b*c) == a/b.
+Proof.
+ intros.
+ symmetry.
+ apply div_unique with ((a mod b)*c).
+ apply mul_nonneg_nonneg; order.
+ split.
+ apply mul_nonneg_nonneg; destruct (mod_bound a b); order.
+ rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound a b); auto.
+ rewrite (div_mod a b) at 1 by order.
+ rewrite mul_add_distr_r.
+ rewrite add_cancel_r.
+ rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
+Qed.
+
+Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c ->
+ (c*a)/(c*b) == a/b.
+Proof.
+ intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto.
+Qed.
+
+Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c ->
+  (c*a) mod (c*b) == c * (a mod b).
+Proof.
+ intros.
+ rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
+ rewrite <- div_mod.
+ rewrite div_mul_cancel_l; auto.
+ rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
+ apply div_mod; order.
+ rewrite <- neq_mul_0; intuition; order.
+Qed.
+
+Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c ->
+  (a*c) mod (b*c) == (a mod b) * c.
+Proof.
+ intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
+Qed.
+
+(** Operations modulo. *)
+
+Theorem mod_mod: forall a n, 0<=a -> 0<n ->
+ (a mod n) mod n == a mod n.
+Proof.
+ intros. destruct (mod_bound a n); auto. now rewrite mod_small_iff.
+Qed.
+
+Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
+ ((a mod n)*b) mod n == (a*b) mod n.
+Proof.
+ intros a b n Ha Hb Hn. symmetry.
+ generalize (mul_nonneg_nonneg _ _ Ha Hb).
+ rewrite (div_mod a n) at 1 2 by order.
+ rewrite add_comm, (mul_comm n), (mul_comm _ b).
+ rewrite mul_add_distr_l, mul_assoc.
+ intros. rewrite mod_add; auto.
+ now rewrite mul_comm.
+ apply mul_nonneg_nonneg; destruct (mod_bound a n); auto.
+Qed.
+
+Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
+ (a*(b mod n)) mod n == (a*b) mod n.
+Proof.
+ intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto.
+Qed.
+
+Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
+ (a * b) mod n == ((a mod n) * (b mod n)) mod n.
+Proof.
+ intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity.
+ now destruct (mod_bound b n).
+Qed.
+
+Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
+ ((a mod n)+b) mod n == (a+b) mod n.
+Proof.
+ intros a b n Ha Hb Hn. symmetry.
+ generalize (add_nonneg_nonneg _ _ Ha Hb).
+ rewrite (div_mod a n) at 1 2 by order.
+ rewrite <- add_assoc, add_comm, mul_comm.
+ intros. rewrite mod_add; trivial. reflexivity.
+ apply add_nonneg_nonneg; auto. destruct (mod_bound a n); auto.
+Qed.
+
+Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
+ (a+(b mod n)) mod n == (a+b) mod n.
+Proof.
+ intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto.
+Qed.
+
+Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
+ (a+b) mod n == (a mod n + b mod n) mod n.
+Proof.
+ intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity.
+ now destruct (mod_bound b n).
+Qed.
+
+Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c ->
+ (a/b)/c == a/(b*c).
+Proof.
+ intros a b c Ha Hb Hc.
+ apply div_unique with (b*((a/b) mod c) + a mod b); trivial.
+ (* begin 0<= ... <b*c *)
+ destruct (mod_bound (a/b) c), (mod_bound a b); auto using div_pos.
+ split.
+ apply add_nonneg_nonneg; auto.
+ apply mul_nonneg_nonneg; order.
+ apply lt_le_trans with (b*((a/b) mod c) + b).
+ rewrite <- add_lt_mono_l; auto.
+ rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto.
+ (* end 0<= ... < b*c *)
+ rewrite (div_mod a b) at 1 by order.
+ rewrite add_assoc, add_cancel_r.
+ rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
+ apply div_mod; order.
+Qed.
+
+(** A last inequality: *)
+
+Theorem div_mul_le:
+ forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
+Proof.
+ intros.
+ apply div_le_lower_bound; auto.
+ apply mul_nonneg_nonneg; auto.
+ rewrite mul_assoc, (mul_comm b c), <- mul_assoc.
+ apply mul_le_mono_nonneg_l; auto.
+ apply mul_div_le; auto.
+Qed.
+
+(** mod is related to divisibility *)
+
+Lemma mod_divides : forall a b, 0<=a -> 0<b ->
+ (a mod b == 0 <-> exists c, a == b*c).
+Proof.
+ split.
+ intros. exists (a/b). rewrite div_exact; auto.
+ intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto.
+ rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order.
+Qed.
+
+End NZDivPropFunct.
+
diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v
new file mode 100644
index 00000000..8c3c7937
--- /dev/null
+++ b/theories/Numbers/NatInt/NZDomain.v
@@ -0,0 +1,417 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+Require Export NumPrelude NZAxioms.
+Require Import NZBase NZOrder NZAddOrder Plus Minus.
+
+(** In this file, we investigate the shape of domains satisfying
+    the [NZDomainSig] interface. In particular, we define a
+    translation from Peano numbers [nat] into NZ.
+*)
+
+(** First, a section about iterating a function. *)
+
+Section Iter.
+Variable A : Type.
+Fixpoint iter (f:A->A)(n:nat) : A -> A := fun a =>
+  match n with
+    | O => a
+    | S n => f (iter f n a)
+  end.
+Infix "^" := iter.
+
+Lemma iter_alt : forall f n m, (f^(Datatypes.S n)) m = (f^n) (f m).
+Proof.
+induction n; simpl; auto.
+intros; rewrite <- IHn; auto.
+Qed.
+
+Lemma iter_plus : forall f n n' m, (f^(n+n')) m = (f^n) ((f^n') m).
+Proof.
+induction n; simpl; auto.
+intros; rewrite IHn; auto.
+Qed.
+
+Lemma iter_plus_bis : forall f n n' m, (f^(n+n')) m = (f^n') ((f^n) m).
+Proof.
+induction n; simpl; auto.
+intros. rewrite <- iter_alt, IHn; auto.
+Qed.
+
+Global Instance iter_wd (R:relation A) : Proper ((R==>R)==>eq==>R==>R) iter.
+Proof.
+intros f f' Hf n n' Hn; subst n'. induction n; simpl; red; auto.
+Qed.
+
+End Iter.
+Implicit Arguments iter [A].
+Local Infix "^" := iter.
+
+
+Module NZDomainProp (Import NZ:NZDomainSig').
+
+(** * Relationship between points thanks to [succ] and [pred]. *)
+
+(** We prove that any points in NZ have a common descendant by [succ] *)
+
+Definition common_descendant n m := exists k, exists l, (S^k) n == (S^l) m.
+
+Instance common_descendant_wd : Proper (eq==>eq==>iff) common_descendant.
+Proof.
+unfold common_descendant. intros n n' Hn m m' Hm.
+setoid_rewrite Hn. setoid_rewrite Hm. auto with *.
+Qed.
+
+Instance common_descendant_equiv : Equivalence common_descendant.
+Proof.
+split; red.
+intros x. exists O; exists O. simpl; auto with *.
+intros x y (p & q & H); exists q; exists p; auto with *.
+intros x y z (p & q & Hpq) (r & s & Hrs).
+exists (r+p)%nat. exists (q+s)%nat.
+rewrite !iter_plus. rewrite Hpq, <-Hrs, <-iter_plus, <- iter_plus_bis.
+auto with *.
+Qed.
+
+Lemma common_descendant_with_0 : forall n, common_descendant n 0.
+Proof.
+apply bi_induction.
+intros n n' Hn. rewrite Hn; auto with *.
+reflexivity.
+split; intros (p & q & H).
+exists p; exists (Datatypes.S q). rewrite <- iter_alt; simpl.
+ apply succ_wd; auto.
+exists (Datatypes.S p); exists q. rewrite iter_alt; auto.
+Qed.
+
+Lemma common_descendant_always : forall n m, common_descendant n m.
+Proof.
+intros. transitivity 0; [|symmetry]; apply common_descendant_with_0.
+Qed.
+
+(** Thanks to [succ] being injective, we can then deduce that for any two
+    points, one is an iterated successor of the other. *)
+
+Lemma itersucc_or_itersucc : forall n m, exists k, n == (S^k) m \/ m == (S^k) n.
+Proof.
+intros n m. destruct (common_descendant_always n m) as (k & l & H).
+revert l H. induction k.
+simpl. intros; exists l; left; auto with *.
+intros. destruct l.
+simpl in *. exists (Datatypes.S k); right; auto with *.
+simpl in *. apply pred_wd in H; rewrite !pred_succ in H. eauto.
+Qed.
+
+(** Generalized version of [pred_succ] when iterating *)
+
+Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n.
+Proof.
+induction k.
+simpl; auto with *.
+simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto.
+rewrite <- iter_alt in H; auto.
+Qed.
+
+(** From a given point, all others are iterated successors
+    or iterated predecessors. *)
+
+Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m.
+Proof.
+intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]).
+exists k; left; auto.
+exists k; right. apply succ_swap_pred; auto.
+Qed.
+
+(** In particular, all points are either iterated successors of [0]
+    or iterated predecessors of [0] (or both). *)
+
+Lemma itersucc0_or_iterpred0 :
+ forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0.
+Proof.
+ intros n. exact (itersucc_or_iterpred n 0).
+Qed.
+
+(** * Study of initial point w.r.t. [succ] (if any). *)
+
+Definition initial n := forall m, n ~= S m.
+
+Lemma initial_alt : forall n, initial n <-> S (P n) ~= n.
+Proof.
+split. intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ).
+intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *.
+Qed.
+
+Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m.
+Proof. firstorder. Qed.
+
+(** First case: let's assume such an initial point exists
+    (i.e. [S] isn't surjective)... *)
+
+Section InitialExists.
+Hypothesis init : t.
+Hypothesis Initial : initial init.
+
+(** ... then we have unicity of this initial point. *)
+
+Lemma initial_unique : forall m, initial m -> m == init.
+Proof.
+intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]).
+destruct p. now simpl in *. destruct (Initial _ H).
+destruct p. now simpl in *. destruct (Im _ H).
+Qed.
+
+(** ... then all other points are descendant of it. *)
+
+Lemma initial_ancestor : forall m, exists p, m == (S^p) init.
+Proof.
+intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]).
+destruct p; simpl in *; auto. exists O; auto with *. destruct (Initial _ H).
+exists p; auto.
+Qed.
+
+(** NB : We would like to have [pred n == n] for the initial element,
+    but nothing forces that. For instance we can have -3 as initial point,
+    and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig].
+    We can hence have [n == (P^k) m] without [exists k', m == (S^k') n].
+*)
+
+(** We need decidability of [eq] (or classical reasoning) for this: *)
+
+Section SuccPred.
+Hypothesis eq_decidable : forall n m, n==m \/ n~=m.
+Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n.
+Proof.
+intros n NB. rewrite initial_alt in NB.
+destruct (eq_decidable (S (P n)) n); auto.
+elim NB; auto.
+Qed.
+End SuccPred.
+End InitialExists.
+
+(** Second case : let's suppose now [S] surjective, i.e. no initial point. *)
+
+Section InitialDontExists.
+
+Hypothesis succ_onto : forall n, exists m, n == S m.
+
+Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n.
+Proof.
+intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *.
+Qed.
+
+Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m.
+Proof.
+intros n m. intros H; apply succ_wd in H.
+rewrite !succ_onto_gives_succ_pred in H; auto.
+Qed.
+
+End InitialDontExists.
+
+
+(** To summarize:
+
+  S is always injective, P is always surjective  (thanks to [pred_succ]).
+
+  I) If S is not surjective, we have an initial point, which is unique.
+     This bottom is below zero: we have N shifted (or not) to the left.
+     P cannot be injective: P init = P (S (P init)).
+     (P init) can be arbitrary.
+
+  II) If S is surjective, we have [forall n, S (P n) = n], S and P are
+     bijective and reciprocal.
+
+     IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ
+     IIb) otherwise, we have Z
+*)
+
+
+(** * An alternative induction principle using [S] and [P]. *)
+
+(** It is weaker than [bi_induction]. For instance it cannot prove that
+    we can go from one point by many [S] _or_ many [P], but only by many
+    [S] mixed with many [P]. Think of a model with two copies of N:
+
+    0,  1=S 0,   2=S 1, ...
+    0', 1'=S 0', 2'=S 1', ...
+
+    and P 0 = 0' and P 0' = 0.
+*)
+
+Lemma bi_induction_pred :
+  forall A : t -> Prop, Proper (eq==>iff) A ->
+    A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) ->
+    forall n, A n.
+Proof.
+intros. apply bi_induction; auto.
+clear n. intros n; split; auto.
+intros G; apply H2 in G. rewrite pred_succ in G; auto.
+Qed.
+
+Lemma central_induction_pred :
+  forall A : t -> Prop, Proper (eq==>iff) A -> forall n0,
+    A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) ->
+    forall n, A n.
+Proof.
+intros.
+assert (A 0).
+destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk.
+ clear H2. induction k; simpl in *; auto.
+ clear H1. induction k; simpl in *; auto.
+apply bi_induction_pred; auto.
+Qed.
+
+End NZDomainProp.
+
+(** We now focus on the translation from [nat] into [NZ].
+    First, relationship with [0], [succ], [pred].
+*)
+
+Module NZOfNat (Import NZ:NZDomainSig').
+
+Definition ofnat (n : nat) : t := (S^n) 0.
+Notation "[ n ]" := (ofnat n) (at level 7) : ofnat.
+Local Open Scope ofnat.
+
+Lemma ofnat_zero : [O] == 0.
+Proof.
+reflexivity.
+Qed.
+
+Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n].
+Proof.
+ now unfold ofnat.
+Qed.
+
+Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n].
+Proof.
+ unfold ofnat. destruct n. destruct 1; auto.
+ intros _. simpl. symmetry. apply pred_succ.
+Qed.
+
+(** Since [P 0] can be anything in NZ (either [-1], [0], or even other
+    numbers, we cannot state previous lemma for [n=O]. *)
+
+End NZOfNat.
+
+
+(** If we require in addition a strict order on NZ, we can prove that
+    [ofnat] is injective, and hence that NZ is infinite
+    (i.e. we ban Z/nZ models) *)
+
+Module NZOfNatOrd (Import NZ:NZOrdSig').
+Include NZOfNat NZ.
+Include NZOrderPropFunct NZ.
+Local Open Scope ofnat.
+
+Theorem ofnat_S_gt_0 :
+  forall n : nat, 0 < [Datatypes.S n].
+Proof.
+unfold ofnat.
+intros n; induction n as [| n IH]; simpl in *.
+apply lt_0_1.
+apply lt_trans with 1. apply lt_0_1. now rewrite <- succ_lt_mono.
+Qed.
+
+Theorem ofnat_S_neq_0 :
+  forall n : nat, 0 ~= [Datatypes.S n].
+Proof.
+intros. apply lt_neq, ofnat_S_gt_0.
+Qed.
+
+Lemma ofnat_injective : forall n m, [n]==[m] -> n = m.
+Proof.
+induction n as [|n IH]; destruct m; auto.
+intros H; elim (ofnat_S_neq_0 _ H).
+intros H; symmetry in H; elim (ofnat_S_neq_0 _ H).
+intros. f_equal. apply IH. now rewrite <- succ_inj_wd.
+Qed.
+
+Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m.
+Proof.
+split. apply ofnat_injective. intros; now subst.
+Qed.
+
+(* In addition, we can prove that [ofnat] preserves order. *)
+
+Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n<m)%nat.
+Proof.
+induction n as [|n IH]; destruct m; repeat rewrite ofnat_zero; split.
+intro H; elim (lt_irrefl _ H).
+inversion 1.
+auto with arith.
+intros; apply ofnat_S_gt_0.
+intro H; elim (lt_asymm _ _ H); apply ofnat_S_gt_0.
+inversion 1.
+rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith.
+rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith.
+Qed.
+
+Lemma ofnat_le : forall n m : nat, [n]<=[m] <-> (n<=m)%nat.
+Proof.
+intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq.
+split.
+destruct 1; subst; auto with arith.
+apply Lt.le_lt_or_eq.
+Qed.
+
+End NZOfNatOrd.
+
+
+(** For basic operations, we can prove correspondance with
+    their counterpart in [nat]. *)
+
+Module NZOfNatOps (Import NZ:NZAxiomsSig').
+Include NZOfNat NZ.
+Local Open Scope ofnat.
+
+Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m.
+Proof.
+ induction n; intros.
+ apply add_0_l.
+ rewrite ofnat_succ, add_succ_l. simpl; apply succ_wd; auto.
+Qed.
+
+Lemma ofnat_add : forall n m, [n+m] == [n]+[m].
+Proof.
+ intros. rewrite ofnat_add_l.
+ induction n; simpl. reflexivity.
+ rewrite ofnat_succ. now apply succ_wd.
+Qed.
+
+Lemma ofnat_mul : forall n m, [n*m] == [n]*[m].
+Proof.
+ induction n; simpl; intros.
+ symmetry. apply mul_0_l.
+ rewrite plus_comm.
+ rewrite ofnat_succ, ofnat_add, mul_succ_l.
+ now apply add_wd.
+Qed.
+
+Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n.
+Proof.
+ induction m; simpl; intros.
+ rewrite ofnat_zero. apply sub_0_r.
+ rewrite ofnat_succ, sub_succ_r. now apply pred_wd.
+Qed.
+
+Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m].
+Proof.
+ intros n m H. rewrite ofnat_sub_r.
+ revert n H. induction m. intros.
+ rewrite <- minus_n_O. now simpl.
+ intros.
+ destruct n.
+ inversion H.
+ rewrite iter_alt.
+ simpl.
+ rewrite ofnat_succ, pred_succ; auto with arith.
+Qed.
+
+End NZOfNatOps.
diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v
index fda8b7a3..296bd095 100644
--- a/theories/Numbers/NatInt/NZMul.v
+++ b/theories/Numbers/NatInt/NZMul.v
@@ -8,73 +8,63 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import NZAxioms.
-Require Import NZAdd.
+Require Import NZAxioms NZBase NZAdd.
 
-Module NZMulPropFunct (Import NZAxiomsMod : NZAxiomsSig).
-Module Export NZAddPropMod := NZAddPropFunct NZAxiomsMod.
-Open Local Scope NatIntScope.
+Module Type NZMulPropSig
+ (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ).
+Include NZAddPropSig NZ NZBase.
 
-Theorem NZmul_0_r : forall n : NZ, n * 0 == 0.
+Theorem mul_0_r : forall n, n * 0 == 0.
 Proof.
-NZinduct n.
-now rewrite NZmul_0_l.
-intro. rewrite NZmul_succ_l. now rewrite NZadd_0_r.
+nzinduct n; intros; now nzsimpl.
 Qed.
 
-Theorem NZmul_succ_r : forall n m : NZ, n * (S m) == n * m + n.
+Theorem mul_succ_r : forall n m, n * (S m) == n * m + n.
 Proof.
-intros n m; NZinduct n.
-do 2 rewrite NZmul_0_l; now rewrite NZadd_0_l.
-intro n. do 2 rewrite NZmul_succ_l. do 2 rewrite NZadd_succ_r.
-rewrite NZsucc_inj_wd. rewrite <- (NZadd_assoc (n * m) m n).
-rewrite (NZadd_comm m n). rewrite NZadd_assoc.
-now rewrite NZadd_cancel_r.
+intros n m; nzinduct n. now nzsimpl.
+intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc.
+now rewrite add_cancel_r.
 Qed.
 
-Theorem NZmul_comm : forall n m : NZ, n * m == m * n.
+Hint Rewrite mul_0_r mul_succ_r : nz.
+
+Theorem mul_comm : forall n m, n * m == m * n.
 Proof.
-intros n m; NZinduct n.
-rewrite NZmul_0_l; now rewrite NZmul_0_r.
-intro. rewrite NZmul_succ_l; rewrite NZmul_succ_r. now rewrite NZadd_cancel_r.
+intros n m; nzinduct n. now nzsimpl.
+intro. nzsimpl. now rewrite add_cancel_r.
 Qed.
 
-Theorem NZmul_add_distr_r : forall n m p : NZ, (n + m) * p == n * p + m * p.
+Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p.
 Proof.
-intros n m p; NZinduct n.
-rewrite NZmul_0_l. now do 2 rewrite NZadd_0_l.
-intro n. rewrite NZadd_succ_l. do 2 rewrite NZmul_succ_l.
-rewrite <- (NZadd_assoc (n * p) p (m * p)).
-rewrite (NZadd_comm p (m * p)). rewrite (NZadd_assoc (n * p) (m * p) p).
-now rewrite NZadd_cancel_r.
+intros n m p; nzinduct n. now nzsimpl.
+intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc.
+now rewrite add_cancel_r.
 Qed.
 
-Theorem NZmul_add_distr_l : forall n m p : NZ, n * (m + p) == n * m + n * p.
+Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p.
 Proof.
 intros n m p.
-rewrite (NZmul_comm n (m + p)). rewrite (NZmul_comm n m).
-rewrite (NZmul_comm n p). apply NZmul_add_distr_r.
+rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p).
+apply mul_add_distr_r.
 Qed.
 
-Theorem NZmul_assoc : forall n m p : NZ, n * (m * p) == (n * m) * p.
+Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p.
 Proof.
-intros n m p; NZinduct n.
-now do 3 rewrite NZmul_0_l.
-intro n. do 2 rewrite NZmul_succ_l. rewrite NZmul_add_distr_r.
-now rewrite NZadd_cancel_r.
+intros n m p; nzinduct n. now nzsimpl.
+intro n. nzsimpl. rewrite mul_add_distr_r.
+now rewrite add_cancel_r.
 Qed.
 
-Theorem NZmul_1_l : forall n : NZ, 1 * n == n.
+Theorem mul_1_l : forall n, 1 * n == n.
 Proof.
-intro n. rewrite NZmul_succ_l; rewrite NZmul_0_l. now rewrite NZadd_0_l.
+intro n. now nzsimpl.
 Qed.
 
-Theorem NZmul_1_r : forall n : NZ, n * 1 == n.
+Theorem mul_1_r : forall n, n * 1 == n.
 Proof.
-intro n; rewrite NZmul_comm; apply NZmul_1_l.
+intro n. now nzsimpl.
 Qed.
 
-End NZMulPropFunct.
-
+End NZMulPropSig.
diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v
index c707bf73..7b64a698 100644
--- a/theories/Numbers/NatInt/NZMulOrder.v
+++ b/theories/Numbers/NatInt/NZMulOrder.v
@@ -8,303 +8,300 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import NZAxioms.
 Require Import NZAddOrder.
 
-Module NZMulOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig).
-Module Export NZAddOrderPropMod := NZAddOrderPropFunct NZOrdAxiomsMod.
-Open Local Scope NatIntScope.
+Module Type NZMulOrderPropSig (Import NZ : NZOrdAxiomsSig').
+Include NZAddOrderPropSig NZ.
 
-Theorem NZmul_lt_pred :
-  forall p q n m : NZ, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
+Theorem mul_lt_pred :
+  forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
 Proof.
-intros p q n m H. rewrite <- H. do 2 rewrite NZmul_succ_l.
-rewrite <- (NZadd_assoc (p * n) n m).
-rewrite <- (NZadd_assoc (p * m) m n).
-rewrite (NZadd_comm n m). now rewrite <- NZadd_lt_mono_r.
+intros p q n m H. rewrite <- H. nzsimpl.
+rewrite <- ! add_assoc, (add_comm n m).
+now rewrite <- add_lt_mono_r.
 Qed.
 
-Theorem NZmul_lt_mono_pos_l : forall p n m : NZ, 0 < p -> (n < m <-> p * n < p * m).
+Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m).
 Proof.
-NZord_induct p.
-intros n m H; false_hyp H NZlt_irrefl.
-intros p H IH n m H1. do 2 rewrite NZmul_succ_l.
-le_elim H. assert (LR : forall n m : NZ, n < m -> p * n + n < p * m + m).
-intros n1 m1 H2. apply NZadd_lt_mono; [now apply -> IH | assumption].
-split; [apply LR |]. intro H2. apply -> NZlt_dne; intro H3.
-apply <- NZle_ngt in H3. le_elim H3.
-apply NZlt_asymm in H2. apply H2. now apply LR.
-rewrite H3 in H2; false_hyp H2 NZlt_irrefl.
-rewrite <- H; do 2 rewrite NZmul_0_l; now do 2 rewrite NZadd_0_l.
-intros p H1 _ n m H2. apply NZlt_asymm in H1. false_hyp H2 H1.
+nzord_induct p.
+intros n m H; false_hyp H lt_irrefl.
+intros p H IH n m H1. nzsimpl.
+le_elim H. assert (LR : forall n m, n < m -> p * n + n < p * m + m).
+intros n1 m1 H2. apply add_lt_mono; [now apply -> IH | assumption].
+split; [apply LR |]. intro H2. apply -> lt_dne; intro H3.
+apply <- le_ngt in H3. le_elim H3.
+apply lt_asymm in H2. apply H2. now apply LR.
+rewrite H3 in H2; false_hyp H2 lt_irrefl.
+rewrite <- H; now nzsimpl.
+intros p H1 _ n m H2. destruct (lt_asymm _ _ H1 H2).
 Qed.
 
-Theorem NZmul_lt_mono_pos_r : forall p n m : NZ, 0 < p -> (n < m <-> n * p < m * p).
+Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p).
 Proof.
 intros p n m.
-rewrite (NZmul_comm n p); rewrite (NZmul_comm m p). now apply NZmul_lt_mono_pos_l.
+rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l.
 Qed.
 
-Theorem NZmul_lt_mono_neg_l : forall p n m : NZ, p < 0 -> (n < m <-> p * m < p * n).
+Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n).
 Proof.
-NZord_induct p.
-intros n m H; false_hyp H NZlt_irrefl.
-intros p H1 _ n m H2. apply NZlt_succ_l in H2. apply <- NZnle_gt in H2. false_hyp H1 H2.
-intros p H IH n m H1. apply <- NZle_succ_l in H.
-le_elim H. assert (LR : forall n m : NZ, n < m -> p * m < p * n).
-intros n1 m1 H2. apply (NZle_lt_add_lt n1 m1).
-now apply NZlt_le_incl. do 2 rewrite <- NZmul_succ_l. now apply -> IH.
-split; [apply LR |]. intro H2. apply -> NZlt_dne; intro H3.
-apply <- NZle_ngt in H3. le_elim H3.
-apply NZlt_asymm in H2. apply H2. now apply LR.
-rewrite H3 in H2; false_hyp H2 NZlt_irrefl.
-rewrite (NZmul_lt_pred p (S p)) by reflexivity.
-rewrite H; do 2 rewrite NZmul_0_l; now do 2 rewrite NZadd_0_l.
+nzord_induct p.
+intros n m H; false_hyp H lt_irrefl.
+intros p H1 _ n m H2. apply lt_succ_l in H2. apply <- nle_gt in H2.
+false_hyp H1 H2.
+intros p H IH n m H1. apply <- le_succ_l in H.
+le_elim H. assert (LR : forall n m, n < m -> p * m < p * n).
+intros n1 m1 H2. apply (le_lt_add_lt n1 m1).
+now apply lt_le_incl. rewrite <- 2 mul_succ_l. now apply -> IH.
+split; [apply LR |]. intro H2. apply -> lt_dne; intro H3.
+apply <- le_ngt in H3. le_elim H3.
+apply lt_asymm in H2. apply H2. now apply LR.
+rewrite H3 in H2; false_hyp H2 lt_irrefl.
+rewrite (mul_lt_pred p (S p)) by reflexivity.
+rewrite H; do 2 rewrite mul_0_l; now do 2 rewrite add_0_l.
 Qed.
 
-Theorem NZmul_lt_mono_neg_r : forall p n m : NZ, p < 0 -> (n < m <-> m * p < n * p).
+Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p).
 Proof.
 intros p n m.
-rewrite (NZmul_comm n p); rewrite (NZmul_comm m p). now apply NZmul_lt_mono_neg_l.
+rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l.
 Qed.
 
-Theorem NZmul_le_mono_nonneg_l : forall n m p : NZ, 0 <= p -> n <= m -> p * n <= p * m.
+Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m.
 Proof.
 intros n m p H1 H2. le_elim H1.
-le_elim H2. apply NZlt_le_incl. now apply -> NZmul_lt_mono_pos_l.
-apply NZeq_le_incl; now rewrite H2.
-apply NZeq_le_incl; rewrite <- H1; now do 2 rewrite NZmul_0_l.
+le_elim H2. apply lt_le_incl. now apply -> mul_lt_mono_pos_l.
+apply eq_le_incl; now rewrite H2.
+apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l.
 Qed.
 
-Theorem NZmul_le_mono_nonpos_l : forall n m p : NZ, p <= 0 -> n <= m -> p * m <= p * n.
+Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n.
 Proof.
 intros n m p H1 H2. le_elim H1.
-le_elim H2. apply NZlt_le_incl. now apply -> NZmul_lt_mono_neg_l.
-apply NZeq_le_incl; now rewrite H2.
-apply NZeq_le_incl; rewrite H1; now do 2 rewrite NZmul_0_l.
+le_elim H2. apply lt_le_incl. now apply -> mul_lt_mono_neg_l.
+apply eq_le_incl; now rewrite H2.
+apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l.
 Qed.
 
-Theorem NZmul_le_mono_nonneg_r : forall n m p : NZ, 0 <= p -> n <= m -> n * p <= m * p.
+Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p.
 Proof.
-intros n m p H1 H2; rewrite (NZmul_comm n p); rewrite (NZmul_comm m p);
-now apply NZmul_le_mono_nonneg_l.
+intros n m p H1 H2;
+rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l.
 Qed.
 
-Theorem NZmul_le_mono_nonpos_r : forall n m p : NZ, p <= 0 -> n <= m -> m * p <= n * p.
+Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p.
 Proof.
-intros n m p H1 H2; rewrite (NZmul_comm n p); rewrite (NZmul_comm m p);
-now apply NZmul_le_mono_nonpos_l.
+intros n m p H1 H2;
+rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l.
 Qed.
 
-Theorem NZmul_cancel_l : forall n m p : NZ, p ~= 0 -> (p * n == p * m <-> n == m).
+Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m).
 Proof.
 intros n m p H; split; intro H1.
-destruct (NZlt_trichotomy p 0) as [H2 | [H2 | H2]].
-apply -> NZeq_dne; intro H3. apply -> NZlt_gt_cases in H3. destruct H3 as [H3 | H3].
-assert (H4 : p * m < p * n); [now apply -> NZmul_lt_mono_neg_l |].
-rewrite H1 in H4; false_hyp H4 NZlt_irrefl.
-assert (H4 : p * n < p * m); [now apply -> NZmul_lt_mono_neg_l |].
-rewrite H1 in H4; false_hyp H4 NZlt_irrefl.
+destruct (lt_trichotomy p 0) as [H2 | [H2 | H2]].
+apply -> eq_dne; intro H3. apply -> lt_gt_cases in H3. destruct H3 as [H3 | H3].
+assert (H4 : p * m < p * n); [now apply -> mul_lt_mono_neg_l |].
+rewrite H1 in H4; false_hyp H4 lt_irrefl.
+assert (H4 : p * n < p * m); [now apply -> mul_lt_mono_neg_l |].
+rewrite H1 in H4; false_hyp H4 lt_irrefl.
 false_hyp H2 H.
-apply -> NZeq_dne; intro H3. apply -> NZlt_gt_cases in H3. destruct H3 as [H3 | H3].
-assert (H4 : p * n < p * m) by (now apply -> NZmul_lt_mono_pos_l).
-rewrite H1 in H4; false_hyp H4 NZlt_irrefl.
-assert (H4 : p * m < p * n) by (now apply -> NZmul_lt_mono_pos_l).
-rewrite H1 in H4; false_hyp H4 NZlt_irrefl.
+apply -> eq_dne; intro H3. apply -> lt_gt_cases in H3. destruct H3 as [H3 | H3].
+assert (H4 : p * n < p * m) by (now apply -> mul_lt_mono_pos_l).
+rewrite H1 in H4; false_hyp H4 lt_irrefl.
+assert (H4 : p * m < p * n) by (now apply -> mul_lt_mono_pos_l).
+rewrite H1 in H4; false_hyp H4 lt_irrefl.
 now rewrite H1.
 Qed.
 
-Theorem NZmul_cancel_r : forall n m p : NZ, p ~= 0 -> (n * p == m * p <-> n == m).
+Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m).
 Proof.
-intros n m p. rewrite (NZmul_comm n p), (NZmul_comm m p); apply NZmul_cancel_l.
+intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l.
 Qed.
 
-Theorem NZmul_id_l : forall n m : NZ, m ~= 0 -> (n * m == m <-> n == 1).
+Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1).
 Proof.
 intros n m H.
-stepl (n * m == 1 * m) by now rewrite NZmul_1_l. now apply NZmul_cancel_r.
+stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r.
 Qed.
 
-Theorem NZmul_id_r : forall n m : NZ, n ~= 0 -> (n * m == n <-> m == 1).
+Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1).
 Proof.
-intros n m; rewrite NZmul_comm; apply NZmul_id_l.
+intros n m; rewrite mul_comm; apply mul_id_l.
 Qed.
 
-Theorem NZmul_le_mono_pos_l : forall n m p : NZ, 0 < p -> (n <= m <-> p * n <= p * m).
+Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m).
 Proof.
-intros n m p H; do 2 rewrite NZlt_eq_cases.
-rewrite (NZmul_lt_mono_pos_l p n m) by assumption.
-now rewrite -> (NZmul_cancel_l n m p) by
-(intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl).
+intros n m p H; do 2 rewrite lt_eq_cases.
+rewrite (mul_lt_mono_pos_l p n m) by assumption.
+now rewrite -> (mul_cancel_l n m p) by
+(intro H1; rewrite H1 in H; false_hyp H lt_irrefl).
 Qed.
 
-Theorem NZmul_le_mono_pos_r : forall n m p : NZ, 0 < p -> (n <= m <-> n * p <= m * p).
+Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p).
 Proof.
-intros n m p. rewrite (NZmul_comm n p); rewrite (NZmul_comm m p);
-apply NZmul_le_mono_pos_l.
+intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l.
 Qed.
 
-Theorem NZmul_le_mono_neg_l : forall n m p : NZ, p < 0 -> (n <= m <-> p * m <= p * n).
+Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n).
 Proof.
-intros n m p H; do 2 rewrite NZlt_eq_cases.
-rewrite (NZmul_lt_mono_neg_l p n m); [| assumption].
-rewrite -> (NZmul_cancel_l m n p) by (intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl).
-now setoid_replace (n == m) with (m == n) using relation iff by (split; now intro).
+intros n m p H; do 2 rewrite lt_eq_cases.
+rewrite (mul_lt_mono_neg_l p n m); [| assumption].
+rewrite -> (mul_cancel_l m n p)
+ by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl).
+now setoid_replace (n == m) with (m == n) by (split; now intro).
 Qed.
 
-Theorem NZmul_le_mono_neg_r : forall n m p : NZ, p < 0 -> (n <= m <-> m * p <= n * p).
+Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p).
 Proof.
-intros n m p. rewrite (NZmul_comm n p); rewrite (NZmul_comm m p);
-apply NZmul_le_mono_neg_l.
+intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l.
 Qed.
 
-Theorem NZmul_lt_mono_nonneg :
-  forall n m p q : NZ, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q.
+Theorem mul_lt_mono_nonneg :
+  forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q.
 Proof.
 intros n m p q H1 H2 H3 H4.
-apply NZle_lt_trans with (m * p).
-apply NZmul_le_mono_nonneg_r; [assumption | now apply NZlt_le_incl].
-apply -> NZmul_lt_mono_pos_l; [assumption | now apply NZle_lt_trans with n].
+apply le_lt_trans with (m * p).
+apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl].
+apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n].
 Qed.
 
 (* There are still many variants of the theorem above. One can assume 0 < n
 or 0 < p or n <= m or p <= q. *)
 
-Theorem NZmul_le_mono_nonneg :
-  forall n m p q : NZ, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q.
+Theorem mul_le_mono_nonneg :
+  forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q.
 Proof.
 intros n m p q H1 H2 H3 H4.
 le_elim H2; le_elim H4.
-apply NZlt_le_incl; now apply NZmul_lt_mono_nonneg.
-rewrite <- H4; apply NZmul_le_mono_nonneg_r; [assumption | now apply NZlt_le_incl].
-rewrite <- H2; apply NZmul_le_mono_nonneg_l; [assumption | now apply NZlt_le_incl].
-rewrite H2; rewrite H4; now apply NZeq_le_incl.
+apply lt_le_incl; now apply mul_lt_mono_nonneg.
+rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl].
+rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl].
+rewrite H2; rewrite H4; now apply eq_le_incl.
 Qed.
 
-Theorem NZmul_pos_pos : forall n m : NZ, 0 < n -> 0 < m -> 0 < n * m.
+Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m.
 Proof.
-intros n m H1 H2.
-rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_pos_r.
+intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_pos_r.
 Qed.
 
-Theorem NZmul_neg_neg : forall n m : NZ, n < 0 -> m < 0 -> 0 < n * m.
+Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m.
 Proof.
-intros n m H1 H2.
-rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_neg_r.
+intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_neg_r.
 Qed.
 
-Theorem NZmul_pos_neg : forall n m : NZ, 0 < n -> m < 0 -> n * m < 0.
+Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0.
 Proof.
-intros n m H1 H2.
-rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_neg_r.
+intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_neg_r.
 Qed.
 
-Theorem NZmul_neg_pos : forall n m : NZ, n < 0 -> 0 < m -> n * m < 0.
+Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0.
 Proof.
-intros; rewrite NZmul_comm; now apply NZmul_pos_neg.
+intros; rewrite mul_comm; now apply mul_pos_neg.
 Qed.
 
-Theorem NZlt_1_mul_pos : forall n m : NZ, 1 < n -> 0 < m -> 1 < n * m.
+Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m.
 Proof.
-intros n m H1 H2. apply -> (NZmul_lt_mono_pos_r m) in H1.
-rewrite NZmul_1_l in H1. now apply NZlt_1_l with m.
+intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order.
+Qed.
+
+Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m.
+Proof.
+intros n m H1 H2. apply -> (mul_lt_mono_pos_r m) in H1.
+rewrite mul_1_l in H1. now apply lt_1_l with m.
 assumption.
 Qed.
 
-Theorem NZeq_mul_0 : forall n m : NZ, n * m == 0 <-> n == 0 \/ m == 0.
+Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0.
 Proof.
 intros n m; split.
-intro H; destruct (NZlt_trichotomy n 0) as [H1 | [H1 | H1]];
-destruct (NZlt_trichotomy m 0) as [H2 | [H2 | H2]];
+intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
+destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
 try (now right); try (now left).
-elimtype False; now apply (NZlt_neq 0 (n * m)); [apply NZmul_neg_neg |].
-elimtype False; now apply (NZlt_neq (n * m) 0); [apply NZmul_neg_pos |].
-elimtype False; now apply (NZlt_neq (n * m) 0); [apply NZmul_pos_neg |].
-elimtype False; now apply (NZlt_neq 0 (n * m)); [apply NZmul_pos_pos |].
-intros [H | H]. now rewrite H, NZmul_0_l. now rewrite H, NZmul_0_r.
+exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |].
+exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |].
+exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |].
+exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |].
+intros [H | H]. now rewrite H, mul_0_l. now rewrite H, mul_0_r.
 Qed.
 
-Theorem NZneq_mul_0 : forall n m : NZ, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
+Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
 Proof.
 intros n m; split; intro H.
-intro H1; apply -> NZeq_mul_0 in H1. tauto.
+intro H1; apply -> eq_mul_0 in H1. tauto.
 split; intro H1; rewrite H1 in H;
-(rewrite NZmul_0_l in H || rewrite NZmul_0_r in H); now apply H.
+(rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H.
 Qed.
 
-Theorem NZeq_square_0 : forall n : NZ, n * n == 0 <-> n == 0.
+Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0.
 Proof.
-intro n; rewrite NZeq_mul_0; tauto.
+intro n; rewrite eq_mul_0; tauto.
 Qed.
 
-Theorem NZeq_mul_0_l : forall n m : NZ, n * m == 0 -> m ~= 0 -> n == 0.
+Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0.
 Proof.
-intros n m H1 H2. apply -> NZeq_mul_0 in H1. destruct H1 as [H1 | H1].
+intros n m H1 H2. apply -> eq_mul_0 in H1. destruct H1 as [H1 | H1].
 assumption. false_hyp H1 H2.
 Qed.
 
-Theorem NZeq_mul_0_r : forall n m : NZ, n * m == 0 -> n ~= 0 -> m == 0.
+Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0.
 Proof.
-intros n m H1 H2; apply -> NZeq_mul_0 in H1. destruct H1 as [H1 | H1].
+intros n m H1 H2; apply -> eq_mul_0 in H1. destruct H1 as [H1 | H1].
 false_hyp H1 H2. assumption.
 Qed.
 
-Theorem NZlt_0_mul : forall n m : NZ, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0).
+Theorem lt_0_mul : forall n m, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0).
 Proof.
 intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]].
-destruct (NZlt_trichotomy n 0) as [H1 | [H1 | H1]];
-[| rewrite H1 in H; rewrite NZmul_0_l in H; false_hyp H NZlt_irrefl |];
-(destruct (NZlt_trichotomy m 0) as [H2 | [H2 | H2]];
-[| rewrite H2 in H; rewrite NZmul_0_r in H; false_hyp H NZlt_irrefl |]);
+destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
+[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |];
+(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
+[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]);
 try (left; now split); try (right; now split).
-assert (H3 : n * m < 0) by now apply NZmul_neg_pos.
-elimtype False; now apply (NZlt_asymm (n * m) 0).
-assert (H3 : n * m < 0) by now apply NZmul_pos_neg.
-elimtype False; now apply (NZlt_asymm (n * m) 0).
-now apply NZmul_pos_pos. now apply NZmul_neg_neg.
+assert (H3 : n * m < 0) by now apply mul_neg_pos.
+exfalso; now apply (lt_asymm (n * m) 0).
+assert (H3 : n * m < 0) by now apply mul_pos_neg.
+exfalso; now apply (lt_asymm (n * m) 0).
+now apply mul_pos_pos. now apply mul_neg_neg.
 Qed.
 
-Theorem NZsquare_lt_mono_nonneg : forall n m : NZ, 0 <= n -> n < m -> n * n < m * m.
+Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m.
 Proof.
-intros n m H1 H2. now apply NZmul_lt_mono_nonneg.
+intros n m H1 H2. now apply mul_lt_mono_nonneg.
 Qed.
 
-Theorem NZsquare_le_mono_nonneg : forall n m : NZ, 0 <= n -> n <= m -> n * n <= m * m.
+Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m.
 Proof.
-intros n m H1 H2. now apply NZmul_le_mono_nonneg.
+intros n m H1 H2. now apply mul_le_mono_nonneg.
 Qed.
 
 (* The converse theorems require nonnegativity (or nonpositivity) of the
 other variable *)
 
-Theorem NZsquare_lt_simpl_nonneg : forall n m : NZ, 0 <= m -> n * n < m * m -> n < m.
+Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m.
 Proof.
-intros n m H1 H2. destruct (NZlt_ge_cases n 0).
-now apply NZlt_le_trans with 0.
-destruct (NZlt_ge_cases n m).
-assumption. assert (F : m * m <= n * n) by now apply NZsquare_le_mono_nonneg.
-apply -> NZle_ngt in F. false_hyp H2 F.
+intros n m H1 H2. destruct (lt_ge_cases n 0).
+now apply lt_le_trans with 0.
+destruct (lt_ge_cases n m).
+assumption. assert (F : m * m <= n * n) by now apply square_le_mono_nonneg.
+apply -> le_ngt in F. false_hyp H2 F.
 Qed.
 
-Theorem NZsquare_le_simpl_nonneg : forall n m : NZ, 0 <= m -> n * n <= m * m -> n <= m.
+Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m.
 Proof.
-intros n m H1 H2. destruct (NZlt_ge_cases n 0).
-apply NZlt_le_incl; now apply NZlt_le_trans with 0.
-destruct (NZle_gt_cases n m).
-assumption. assert (F : m * m < n * n) by now apply NZsquare_lt_mono_nonneg.
-apply -> NZlt_nge in F. false_hyp H2 F.
+intros n m H1 H2. destruct (lt_ge_cases n 0).
+apply lt_le_incl; now apply lt_le_trans with 0.
+destruct (le_gt_cases n m).
+assumption. assert (F : m * m < n * n) by now apply square_lt_mono_nonneg.
+apply -> lt_nge in F. false_hyp H2 F.
 Qed.
 
-Theorem NZmul_2_mono_l : forall n m : NZ, n < m -> 1 + (1 + 1) * n < (1 + 1) * m.
+Theorem mul_2_mono_l : forall n m, n < m -> 1 + (1 + 1) * n < (1 + 1) * m.
 Proof.
-intros n m H. apply <- NZle_succ_l in H.
-apply -> (NZmul_le_mono_pos_l (S n) m (1 + 1)) in H.
-repeat rewrite NZmul_add_distr_r in *; repeat rewrite NZmul_1_l in *.
-repeat rewrite NZadd_succ_r in *. repeat rewrite NZadd_succ_l in *. rewrite NZadd_0_l.
-now apply -> NZle_succ_l.
-apply NZadd_pos_pos; now apply NZlt_succ_diag_r.
+intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m (1 + 1)).
+rewrite !mul_add_distr_r; nzsimpl; now rewrite le_succ_l.
+apply add_pos_pos; now apply lt_0_1.
 Qed.
 
-End NZMulOrderPropFunct.
+End NZMulOrderPropSig.
diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v
index d0e2faf8..14fa0bfd 100644
--- a/theories/Numbers/NatInt/NZOrder.v
+++ b/theories/Numbers/NatInt/NZOrder.v
@@ -8,659 +8,637 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NZOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import NZAxioms.
-Require Import NZMul.
-Require Import Decidable.
+Require Import NZAxioms NZBase Decidable OrdersTac.
 
-Module NZOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig).
-Module Export NZMulPropMod := NZMulPropFunct NZAxiomsMod.
-Open Local Scope NatIntScope.
+Module Type NZOrderPropSig
+ (Import NZ : NZOrdSig')(Import NZBase : NZBasePropSig NZ).
 
-Ltac le_elim H := rewrite NZlt_eq_cases in H; destruct H as [H | H].
-
-Theorem NZlt_le_incl : forall n m : NZ, n < m -> n <= m.
+Instance le_wd : Proper (eq==>eq==>iff) le.
 Proof.
-intros; apply <- NZlt_eq_cases; now left.
+intros n n' Hn m m' Hm. rewrite !lt_eq_cases, !Hn, !Hm; auto with *.
 Qed.
 
-Theorem NZeq_le_incl : forall n m : NZ, n == m -> n <= m.
-Proof.
-intros; apply <- NZlt_eq_cases; now right.
-Qed.
+Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H].
 
-Lemma NZlt_stepl : forall x y z : NZ, x < y -> x == z -> z < y.
+Theorem lt_le_incl : forall n m, n < m -> n <= m.
 Proof.
-intros x y z H1 H2; now rewrite <- H2.
+intros; apply <- lt_eq_cases; now left.
 Qed.
 
-Lemma NZlt_stepr : forall x y z : NZ, x < y -> y == z -> x < z.
+Theorem le_refl : forall n, n <= n.
 Proof.
-intros x y z H1 H2; now rewrite <- H2.
+intro; apply <- lt_eq_cases; now right.
 Qed.
 
-Lemma NZle_stepl : forall x y z : NZ, x <= y -> x == z -> z <= y.
+Theorem lt_succ_diag_r : forall n, n < S n.
 Proof.
-intros x y z H1 H2; now rewrite <- H2.
+intro n. rewrite lt_succ_r. apply le_refl.
 Qed.
 
-Lemma NZle_stepr : forall x y z : NZ, x <= y -> y == z -> x <= z.
+Theorem le_succ_diag_r : forall n, n <= S n.
 Proof.
-intros x y z H1 H2; now rewrite <- H2.
+intro; apply lt_le_incl; apply lt_succ_diag_r.
 Qed.
 
-Declare Left  Step NZlt_stepl.
-Declare Right Step NZlt_stepr.
-Declare Left  Step NZle_stepl.
-Declare Right Step NZle_stepr.
-
-Theorem NZlt_neq : forall n m : NZ, n < m -> n ~= m.
+Theorem neq_succ_diag_l : forall n, S n ~= n.
 Proof.
-intros n m H1 H2; rewrite H2 in H1; false_hyp H1 NZlt_irrefl.
+intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r.
 Qed.
 
-Theorem NZle_neq : forall n m : NZ, n < m <-> n <= m /\ n ~= m.
+Theorem neq_succ_diag_r : forall n, n ~= S n.
 Proof.
-intros n m; split; [intro H | intros [H1 H2]].
-split. now apply NZlt_le_incl. now apply NZlt_neq.
-le_elim H1. assumption. false_hyp H1 H2.
+intro n; apply neq_sym, neq_succ_diag_l.
 Qed.
 
-Theorem NZle_refl : forall n : NZ, n <= n.
+Theorem nlt_succ_diag_l : forall n, ~ S n < n.
 Proof.
-intro; now apply NZeq_le_incl.
+intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl.
 Qed.
 
-Theorem NZlt_succ_diag_r : forall n : NZ, n < S n.
+Theorem nle_succ_diag_l : forall n, ~ S n <= n.
 Proof.
-intro n. rewrite NZlt_succ_r. now apply NZeq_le_incl.
+intros n H; le_elim H.
+false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l.
 Qed.
 
-Theorem NZle_succ_diag_r : forall n : NZ, n <= S n.
+Theorem le_succ_l : forall n m, S n <= m <-> n < m.
 Proof.
-intro; apply NZlt_le_incl; apply NZlt_succ_diag_r.
+intro n; nzinduct m n.
+split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl.
+intro m.
+rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd.
+rewrite or_cancel_r.
+reflexivity.
+intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l.
+intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl.
 Qed.
 
-Theorem NZlt_0_1 : 0 < 1.
-Proof.
-apply NZlt_succ_diag_r.
-Qed.
+(** Trichotomy *)
 
-Theorem NZle_0_1 : 0 <= 1.
+Theorem le_gt_cases : forall n m, n <= m \/ n > m.
 Proof.
-apply NZle_succ_diag_r.
+intros n m; nzinduct n m.
+left; apply le_refl.
+intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition.
 Qed.
 
-Theorem NZlt_lt_succ_r : forall n m : NZ, n < m -> n < S m.
+Theorem lt_trichotomy : forall n m,  n < m \/ n == m \/ m < n.
 Proof.
-intros. rewrite NZlt_succ_r. now apply NZlt_le_incl.
+intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto.
 Qed.
 
-Theorem NZle_le_succ_r : forall n m : NZ, n <= m -> n <= S m.
-Proof.
-intros n m H. rewrite <- NZlt_succ_r in H. now apply NZlt_le_incl.
-Qed.
+Notation lt_eq_gt_cases := lt_trichotomy (only parsing).
 
-Theorem NZle_succ_r : forall n m : NZ, n <= S m <-> n <= m \/ n == S m.
+(** Asymmetry and transitivity. *)
+
+Theorem lt_asymm : forall n m, n < m -> ~ m < n.
 Proof.
-intros n m; rewrite NZlt_eq_cases. now rewrite NZlt_succ_r.
+intros n m; nzinduct n m.
+intros H; false_hyp H lt_irrefl.
+intro n; split; intros H H1 H2.
+apply lt_succ_r in H2. le_elim H2.
+apply H; auto. apply -> le_succ_l. now apply lt_le_incl.
+rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l.
+apply le_succ_l in H1. le_elim H1.
+apply H; auto. rewrite lt_succ_r. now apply lt_le_incl.
+rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l.
 Qed.
 
-(* The following theorem is a special case of neq_succ_iter_l below,
-but we prove it separately *)
+Notation lt_ngt := lt_asymm (only parsing).
 
-Theorem NZneq_succ_diag_l : forall n : NZ, S n ~= n.
+Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
 Proof.
-intros n H. pose proof (NZlt_succ_diag_r n) as H1. rewrite H in H1.
-false_hyp H1 NZlt_irrefl.
+intros n m p; nzinduct p m.
+intros _ H; false_hyp H lt_irrefl.
+intro p. rewrite 2 lt_succ_r.
+split; intros H H1 H2.
+apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1].
+assert (n <= p) as H3 by (auto using lt_le_incl).
+le_elim H3. assumption. rewrite <- H3 in H2.
+elim (lt_asymm n m); auto.
 Qed.
 
-Theorem NZneq_succ_diag_r : forall n : NZ, n ~= S n.
+Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
 Proof.
-intro n; apply NZneq_sym; apply NZneq_succ_diag_l.
+intros n m p. rewrite 3 lt_eq_cases.
+intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ';
+ generalize (lt_trans n m p); auto with relations.
 Qed.
 
-Theorem NZnlt_succ_diag_l : forall n : NZ, ~ S n < n.
-Proof.
-intros n H; apply NZlt_lt_succ_r in H. false_hyp H NZlt_irrefl.
-Qed.
+(** Some type classes about order *)
 
-Theorem NZnle_succ_diag_l : forall n : NZ, ~ S n <= n.
+Instance lt_strorder : StrictOrder lt.
+Proof. split. exact lt_irrefl. exact lt_trans. Qed.
+
+Instance le_preorder : PreOrder le.
+Proof. split. exact le_refl. exact le_trans. Qed.
+
+Instance le_partialorder : PartialOrder _ le.
 Proof.
-intros n H; le_elim H.
-false_hyp H NZnlt_succ_diag_l. false_hyp H NZneq_succ_diag_l.
+intros x y. compute. split.
+intro EQ; now rewrite EQ.
+rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y.
 Qed.
 
-Theorem NZle_succ_l : forall n m : NZ, S n <= m <-> n < m.
+(** We know enough now to benefit from the generic [order] tactic. *)
+
+Definition lt_compat := lt_wd.
+Definition lt_total := lt_trichotomy.
+Definition le_lteq := lt_eq_cases.
+
+Module OrderElts <: TotalOrder.
+ Definition t := t.
+ Definition eq := eq.
+ Definition lt := lt.
+ Definition le := le.
+ Definition eq_equiv := eq_equiv.
+ Definition lt_strorder := lt_strorder.
+ Definition lt_compat := lt_compat.
+ Definition lt_total := lt_total.
+ Definition le_lteq := le_lteq.
+End OrderElts.
+Module OrderTac := !MakeOrderTac OrderElts.
+Ltac order := OrderTac.order.
+
+(** Some direct consequences of [order]. *)
+
+Theorem lt_neq : forall n m, n < m -> n ~= m.
+Proof. order. Qed.
+
+Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m.
+Proof. intuition order. Qed.
+
+Theorem eq_le_incl : forall n m, n == m -> n <= m.
+Proof. order. Qed.
+
+Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y.
+Proof. order. Qed.
+
+Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z.
+Proof. order. Qed.
+
+Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y.
+Proof. order. Qed.
+
+Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z.
+Proof. order. Qed.
+
+Declare Left  Step lt_stepl.
+Declare Right Step lt_stepr.
+Declare Left  Step le_stepl.
+Declare Right Step le_stepr.
+
+Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
+Proof. order. Qed.
+
+Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
+Proof. order. Qed.
+
+Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m.
+Proof. order. Qed.
+
+(** More properties of [<] and [<=] with respect to [S] and [0]. *)
+
+Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m.
 Proof.
-intro n; NZinduct m n.
-setoid_replace (n < n) with False using relation iff by
-  (apply -> neg_false; apply NZlt_irrefl).
-now setoid_replace (S n <= n) with False using relation iff by
-  (apply -> neg_false; apply NZnle_succ_diag_l).
-intro m. rewrite NZlt_succ_r. rewrite NZle_succ_r.
-rewrite NZsucc_inj_wd.
-rewrite (NZlt_eq_cases n m).
-rewrite or_cancel_r.
-reflexivity.
-intros H1 H2; rewrite H2 in H1; false_hyp H1 NZnle_succ_diag_l.
-apply NZlt_neq.
+intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r.
 Qed.
 
-Theorem NZlt_succ_l : forall n m : NZ, S n < m -> n < m.
+Theorem lt_succ_l : forall n m, S n < m -> n < m.
 Proof.
-intros n m H; apply -> NZle_succ_l; now apply NZlt_le_incl.
+intros n m H; apply -> le_succ_l; order.
 Qed.
 
-Theorem NZsucc_lt_mono : forall n m : NZ, n < m <-> S n < S m.
+Theorem le_le_succ_r : forall n m, n <= m -> n <= S m.
 Proof.
-intros n m. rewrite <- NZle_succ_l. symmetry. apply NZlt_succ_r.
+intros n m LE. rewrite <- lt_succ_r in LE. order.
 Qed.
 
-Theorem NZsucc_le_mono : forall n m : NZ, n <= m <-> S n <= S m.
+Theorem lt_lt_succ_r : forall n m, n < m -> n < S m.
 Proof.
-intros n m. do 2 rewrite NZlt_eq_cases.
-rewrite <- NZsucc_lt_mono; now rewrite NZsucc_inj_wd.
+intros. rewrite lt_succ_r. order.
 Qed.
 
-Theorem NZlt_asymm : forall n m, n < m -> ~ m < n.
+Theorem succ_lt_mono : forall n m, n < m <-> S n < S m.
 Proof.
-intros n m; NZinduct n m.
-intros H _; false_hyp H NZlt_irrefl.
-intro n; split; intros H H1 H2.
-apply NZlt_succ_l in H1. apply -> NZlt_succ_r in H2. le_elim H2.
-now apply H. rewrite H2 in H1; false_hyp H1 NZlt_irrefl.
-apply NZlt_lt_succ_r in H2. apply <- NZle_succ_l in H1. le_elim H1.
-now apply H. rewrite H1 in H2; false_hyp H2 NZlt_irrefl.
+intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r.
 Qed.
 
-Theorem NZlt_trans : forall n m p : NZ, n < m -> m < p -> n < p.
+Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m.
 Proof.
-intros n m p; NZinduct p m.
-intros _ H; false_hyp H NZlt_irrefl.
-intro p. do 2 rewrite NZlt_succ_r.
-split; intros H H1 H2.
-apply NZlt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1].
-assert (n <= p) as H3. apply H. assumption. now apply NZlt_le_incl.
-le_elim H3. assumption. rewrite <- H3 in H2.
-elimtype False; now apply (NZlt_asymm n m).
+intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd.
 Qed.
 
-Theorem NZle_trans : forall n m p : NZ, n <= m -> m <= p -> n <= p.
+Theorem lt_0_1 : 0 < 1.
 Proof.
-intros n m p H1 H2; le_elim H1.
-le_elim H2. apply NZlt_le_incl; now apply NZlt_trans with (m := m).
-apply NZlt_le_incl; now rewrite <- H2. now rewrite H1.
+apply lt_succ_diag_r.
 Qed.
 
-Theorem NZle_lt_trans : forall n m p : NZ, n <= m -> m < p -> n < p.
+Theorem le_0_1 : 0 <= 1.
 Proof.
-intros n m p H1 H2; le_elim H1.
-now apply NZlt_trans with (m := m). now rewrite H1.
+apply le_succ_diag_r.
 Qed.
 
-Theorem NZlt_le_trans : forall n m p : NZ, n < m -> m <= p -> n < p.
+Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m.
 Proof.
-intros n m p H1 H2; le_elim H2.
-now apply NZlt_trans with (m := m). now rewrite <- H2.
+intros n m H1 H2. apply <- le_succ_l in H1. order.
 Qed.
 
-Theorem NZle_antisymm : forall n m : NZ, n <= m -> m <= n -> n == m.
+
+(** More Trichotomy, decidability and double negation elimination. *)
+
+(** The following theorem is cleary redundant, but helps not to
+remember whether one has to say le_gt_cases or lt_ge_cases *)
+
+Theorem lt_ge_cases : forall n m, n < m \/ n >= m.
 Proof.
-intros n m H1 H2; now (le_elim H1; le_elim H2);
-[elimtype False; apply (NZlt_asymm n m) | | |].
+intros n m; destruct (le_gt_cases m n); intuition order.
 Qed.
 
-Theorem NZlt_1_l : forall n m : NZ, 0 < n -> n < m -> 1 < m.
+Theorem le_ge_cases : forall n m, n <= m \/ n >= m.
 Proof.
-intros n m H1 H2. apply <- NZle_succ_l in H1. now apply NZle_lt_trans with n.
+intros n m; destruct (le_gt_cases n m); intuition order.
 Qed.
 
-(** Trichotomy, decidability, and double negation elimination *)
-
-Theorem NZlt_trichotomy : forall n m : NZ,  n < m \/ n == m \/ m < n.
+Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m.
 Proof.
-intros n m; NZinduct n m.
-right; now left.
-intro n; rewrite NZlt_succ_r. stepr ((S n < m \/ S n == m) \/ m <= n) by tauto.
-rewrite <- (NZlt_eq_cases (S n) m).
-setoid_replace (n == m) with (m == n) using relation iff by now split.
-stepl (n < m \/ m < n \/ m == n) by tauto. rewrite <- NZlt_eq_cases.
-apply or_iff_compat_r. symmetry; apply NZle_succ_l.
+intros n m; destruct (lt_trichotomy n m); intuition order.
 Qed.
 
-(* Decidability of equality, even though true in each finite ring, does not
+(** Decidability of equality, even though true in each finite ring, does not
 have a uniform proof. Otherwise, the proof for two fixed numbers would
 reduce to a normal form that will say if the numbers are equal or not,
 which cannot be true in all finite rings. Therefore, we prove decidability
 in the presence of order. *)
 
-Theorem NZeq_dec : forall n m : NZ, decidable (n == m).
+Theorem eq_decidable : forall n m, decidable (n == m).
 Proof.
-intros n m; destruct (NZlt_trichotomy n m) as [H | [H | H]].
-right; intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl.
-now left.
-right; intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl.
+intros n m; destruct (lt_trichotomy n m) as [ | [ | ]];
+ (right; order) || (left; order).
 Qed.
 
-(* DNE stands for double-negation elimination *)
+(** DNE stands for double-negation elimination *)
 
-Theorem NZeq_dne : forall n m, ~ ~ n == m <-> n == m.
+Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m.
 Proof.
 intros n m; split; intro H.
-destruct (NZeq_dec n m) as [H1 | H1].
+destruct (eq_decidable n m) as [H1 | H1].
 assumption. false_hyp H1 H.
 intro H1; now apply H1.
 Qed.
 
-Theorem NZlt_gt_cases : forall n m : NZ, n ~= m <-> n < m \/ n > m.
-Proof.
-intros n m; split.
-pose proof (NZlt_trichotomy n m); tauto.
-intros H H1; destruct H as [H | H]; rewrite H1 in H; false_hyp H NZlt_irrefl.
-Qed.
+Theorem le_ngt : forall n m, n <= m <-> ~ n > m.
+Proof. intuition order. Qed.
 
-Theorem NZle_gt_cases : forall n m : NZ, n <= m \/ n > m.
-Proof.
-intros n m; destruct (NZlt_trichotomy n m) as [H | [H | H]].
-left; now apply NZlt_le_incl. left; now apply NZeq_le_incl. now right.
-Qed.
-
-(* The following theorem is cleary redundant, but helps not to
-remember whether one has to say le_gt_cases or lt_ge_cases *)
+(** Redundant but useful *)
 
-Theorem NZlt_ge_cases : forall n m : NZ, n < m \/ n >= m.
-Proof.
-intros n m; destruct (NZle_gt_cases m n); try (now left); try (now right).
-Qed.
-
-Theorem NZle_ge_cases : forall n m : NZ, n <= m \/ n >= m.
-Proof.
-intros n m; destruct (NZle_gt_cases n m) as [H | H].
-now left. right; now apply NZlt_le_incl.
-Qed.
-
-Theorem NZle_ngt : forall n m : NZ, n <= m <-> ~ n > m.
-Proof.
-intros n m. split; intro H; [intro H1 |].
-eapply NZle_lt_trans in H; [| eassumption ..]. false_hyp H NZlt_irrefl.
-destruct (NZle_gt_cases n m) as [H1 | H1].
-assumption. false_hyp H1 H.
-Qed.
-
-(* Redundant but useful *)
-
-Theorem NZnlt_ge : forall n m : NZ, ~ n < m <-> n >= m.
-Proof.
-intros n m; symmetry; apply NZle_ngt.
-Qed.
+Theorem nlt_ge : forall n m, ~ n < m <-> n >= m.
+Proof. intuition order. Qed.
 
-Theorem NZlt_dec : forall n m : NZ, decidable (n < m).
+Theorem lt_decidable : forall n m, decidable (n < m).
 Proof.
-intros n m; destruct (NZle_gt_cases m n);
-[right; now apply -> NZle_ngt | now left].
+intros n m; destruct (le_gt_cases m n); [right|left]; order.
 Qed.
 
-Theorem NZlt_dne : forall n m, ~ ~ n < m <-> n < m.
+Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m.
 Proof.
-intros n m; split; intro H;
-[destruct (NZlt_dec n m) as [H1 | H1]; [assumption | false_hyp H1 H] |
-intro H1; false_hyp H H1].
+intros n m; split; intro H.
+destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
+intro H1; false_hyp H H1.
 Qed.
 
-Theorem NZnle_gt : forall n m : NZ, ~ n <= m <-> n > m.
-Proof.
-intros n m. rewrite NZle_ngt. apply NZlt_dne.
-Qed.
+Theorem nle_gt : forall n m, ~ n <= m <-> n > m.
+Proof. intuition order. Qed.
 
-(* Redundant but useful *)
+(** Redundant but useful *)
 
-Theorem NZlt_nge : forall n m : NZ, n < m <-> ~ n >= m.
-Proof.
-intros n m; symmetry; apply NZnle_gt.
-Qed.
+Theorem lt_nge : forall n m, n < m <-> ~ n >= m.
+Proof. intuition order. Qed.
 
-Theorem NZle_dec : forall n m : NZ, decidable (n <= m).
+Theorem le_decidable : forall n m, decidable (n <= m).
 Proof.
-intros n m; destruct (NZle_gt_cases n m);
-[now left | right; now apply <- NZnle_gt].
+intros n m; destruct (le_gt_cases n m); [left|right]; order.
 Qed.
 
-Theorem NZle_dne : forall n m : NZ, ~ ~ n <= m <-> n <= m.
+Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m.
 Proof.
-intros n m; split; intro H;
-[destruct (NZle_dec n m) as [H1 | H1]; [assumption | false_hyp H1 H] |
-intro H1; false_hyp H H1].
+intros n m; split; intro H.
+destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
+intro H1; false_hyp H H1.
 Qed.
 
-Theorem NZnlt_succ_r : forall n m : NZ, ~ m < S n <-> n < m.
+Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m.
 Proof.
-intros n m; rewrite NZlt_succ_r; apply NZnle_gt.
+intros n m; rewrite lt_succ_r. intuition order.
 Qed.
 
-(* The difference between integers and natural numbers is that for
+(** The difference between integers and natural numbers is that for
 every integer there is a predecessor, which is not true for natural
 numbers. However, for both classes, every number that is bigger than
 some other number has a predecessor. The proof of this fact by regular
 induction does not go through, so we need to use strong
 (course-of-value) induction. *)
 
-Lemma NZlt_exists_pred_strong :
-  forall z n m : NZ, z < m -> m <= n -> exists k : NZ, m == S k /\ z <= k.
+Lemma lt_exists_pred_strong :
+  forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k.
 Proof.
-intro z; NZinduct n z.
-intros m H1 H2; apply <- NZnle_gt in H1; false_hyp H2 H1.
+intro z; nzinduct n z.
+order.
 intro n; split; intros IH m H1 H2.
-apply -> NZle_succ_r in H2; destruct H2 as [H2 | H2].
-now apply IH. exists n. now split; [| rewrite <- NZlt_succ_r; rewrite <- H2].
-apply IH. assumption. now apply NZle_le_succ_r.
+apply -> le_succ_r in H2. destruct H2 as [H2 | H2].
+now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2].
+apply IH. assumption. now apply le_le_succ_r.
 Qed.
 
-Theorem NZlt_exists_pred :
-  forall z n : NZ, z < n -> exists k : NZ, n == S k /\ z <= k.
+Theorem lt_exists_pred :
+  forall z n, z < n -> exists k, n == S k /\ z <= k.
 Proof.
-intros z n H; apply NZlt_exists_pred_strong with (z := z) (n := n).
-assumption. apply NZle_refl.
+intros z n H; apply lt_exists_pred_strong with (z := z) (n := n).
+assumption. apply le_refl.
 Qed.
 
-(** A corollary of having an order is that NZ is infinite *)
-
-(* This section about infinity of NZ relies on the type nat and can be
-safely removed *)
-
-Definition NZsucc_iter (n : nat) (m : NZ) :=
-  nat_rect (fun _ => NZ) m (fun _ l => S l) n.
-
-Theorem NZlt_succ_iter_r :
-  forall (n : nat) (m : NZ), m < NZsucc_iter (Datatypes.S n) m.
-Proof.
-intros n m; induction n as [| n IH]; simpl in *.
-apply NZlt_succ_diag_r. now apply NZlt_lt_succ_r.
-Qed.
-
-Theorem NZneq_succ_iter_l :
-  forall (n : nat) (m : NZ), NZsucc_iter (Datatypes.S n) m ~= m.
-Proof.
-intros n m H. pose proof (NZlt_succ_iter_r n m) as H1. rewrite H in H1.
-false_hyp H1 NZlt_irrefl.
-Qed.
-
-(* End of the section about the infinity of NZ *)
-
 (** Stronger variant of induction with assumptions n >= 0 (n < 0)
 in the induction step *)
 
 Section Induction.
 
-Variable A : NZ -> Prop.
-Hypothesis A_wd : predicate_wd NZeq A.
-
-Add Morphism A with signature NZeq ==> iff as A_morph.
-Proof. apply A_wd. Qed.
+Variable A : t -> Prop.
+Hypothesis A_wd : Proper (eq==>iff) A.
 
 Section Center.
 
-Variable z : NZ. (* A z is the basis of induction *)
+Variable z : t. (* A z is the basis of induction *)
 
 Section RightInduction.
 
-Let A' (n : NZ) := forall m : NZ, z <= m -> m < n -> A m.
-Let right_step :=   forall n : NZ, z <= n -> A n -> A (S n).
-Let right_step' :=  forall n : NZ, z <= n -> A' n -> A n.
-Let right_step'' := forall n : NZ, A' n <-> A' (S n).
+Let A' (n : t) := forall m, z <= m -> m < n -> A m.
+Let right_step :=   forall n, z <= n -> A n -> A (S n).
+Let right_step' :=  forall n, z <= n -> A' n -> A n.
+Let right_step'' := forall n, A' n <-> A' (S n).
 
-Lemma NZrs_rs' :  A z -> right_step -> right_step'.
+Lemma rs_rs' :  A z -> right_step -> right_step'.
 Proof.
 intros Az RS n H1 H2.
-le_elim H1. apply NZlt_exists_pred in H1. destruct H1 as [k [H3 H4]].
-rewrite H3. apply RS; [assumption | apply H2; [assumption | rewrite H3; apply NZlt_succ_diag_r]].
+le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]].
+rewrite H3. apply RS; trivial. apply H2; trivial.
+rewrite H3; apply lt_succ_diag_r.
 rewrite <- H1; apply Az.
 Qed.
 
-Lemma NZrs'_rs'' : right_step' -> right_step''.
+Lemma rs'_rs'' : right_step' -> right_step''.
 Proof.
 intros RS' n; split; intros H1 m H2 H3.
-apply -> NZlt_succ_r in H3; le_elim H3;
+apply -> lt_succ_r in H3; le_elim H3;
 [now apply H1 | rewrite H3 in *; now apply RS'].
-apply H1; [assumption | now apply NZlt_lt_succ_r].
+apply H1; [assumption | now apply lt_lt_succ_r].
 Qed.
 
-Lemma NZrbase : A' z.
+Lemma rbase : A' z.
 Proof.
-intros m H1 H2. apply -> NZle_ngt in H1. false_hyp H2 H1.
+intros m H1 H2. apply -> le_ngt in H1. false_hyp H2 H1.
 Qed.
 
-Lemma NZA'A_right : (forall n : NZ, A' n) -> forall n : NZ, z <= n -> A n.
+Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n.
 Proof.
-intros H1 n H2. apply H1 with (n := S n); [assumption | apply NZlt_succ_diag_r].
+intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r].
 Qed.
 
-Theorem NZstrong_right_induction: right_step' -> forall n : NZ, z <= n -> A n.
+Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n.
 Proof.
-intro RS'; apply NZA'A_right; unfold A'; NZinduct n z;
-[apply NZrbase | apply NZrs'_rs''; apply RS'].
+intro RS'; apply A'A_right; unfold A'; nzinduct n z;
+[apply rbase | apply rs'_rs''; apply RS'].
 Qed.
 
-Theorem NZright_induction : A z -> right_step -> forall n : NZ, z <= n -> A n.
+Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n.
 Proof.
-intros Az RS; apply NZstrong_right_induction; now apply NZrs_rs'.
+intros Az RS; apply strong_right_induction; now apply rs_rs'.
 Qed.
 
-Theorem NZright_induction' :
-  (forall n : NZ, n <= z -> A n) -> right_step -> forall n : NZ, A n.
+Theorem right_induction' :
+  (forall n, n <= z -> A n) -> right_step -> forall n, A n.
 Proof.
 intros L R n.
-destruct (NZlt_trichotomy n z) as [H | [H | H]].
-apply L; now apply NZlt_le_incl.
-apply L; now apply NZeq_le_incl.
-apply NZright_induction. apply L; now apply NZeq_le_incl. assumption. now apply NZlt_le_incl.
+destruct (lt_trichotomy n z) as [H | [H | H]].
+apply L; now apply lt_le_incl.
+apply L; now apply eq_le_incl.
+apply right_induction. apply L; now apply eq_le_incl. assumption.
+now apply lt_le_incl.
 Qed.
 
-Theorem NZstrong_right_induction' :
-  (forall n : NZ, n <= z -> A n) -> right_step' -> forall n : NZ, A n.
+Theorem strong_right_induction' :
+  (forall n, n <= z -> A n) -> right_step' -> forall n, A n.
 Proof.
 intros L R n.
-destruct (NZlt_trichotomy n z) as [H | [H | H]].
-apply L; now apply NZlt_le_incl.
-apply L; now apply NZeq_le_incl.
-apply NZstrong_right_induction. assumption. now apply NZlt_le_incl.
+destruct (lt_trichotomy n z) as [H | [H | H]].
+apply L; now apply lt_le_incl.
+apply L; now apply eq_le_incl.
+apply strong_right_induction. assumption. now apply lt_le_incl.
 Qed.
 
 End RightInduction.
 
 Section LeftInduction.
 
-Let A' (n : NZ) := forall m : NZ, m <= z -> n <= m -> A m.
-Let left_step :=   forall n : NZ, n < z -> A (S n) -> A n.
-Let left_step' :=  forall n : NZ, n <= z -> A' (S n) -> A n.
-Let left_step'' := forall n : NZ, A' n <-> A' (S n).
+Let A' (n : t) := forall m, m <= z -> n <= m -> A m.
+Let left_step :=   forall n, n < z -> A (S n) -> A n.
+Let left_step' :=  forall n, n <= z -> A' (S n) -> A n.
+Let left_step'' := forall n, A' n <-> A' (S n).
 
-Lemma NZls_ls' :  A z -> left_step -> left_step'.
+Lemma ls_ls' :  A z -> left_step -> left_step'.
 Proof.
 intros Az LS n H1 H2. le_elim H1.
-apply LS; [assumption | apply H2; [now apply <- NZle_succ_l | now apply NZeq_le_incl]].
+apply LS; trivial. apply H2; [now apply <- le_succ_l | now apply eq_le_incl].
 rewrite H1; apply Az.
 Qed.
 
-Lemma NZls'_ls'' : left_step' -> left_step''.
+Lemma ls'_ls'' : left_step' -> left_step''.
 Proof.
 intros LS' n; split; intros H1 m H2 H3.
-apply -> NZle_succ_l in H3. apply NZlt_le_incl in H3. now apply H1.
+apply -> le_succ_l in H3. apply lt_le_incl in H3. now apply H1.
 le_elim H3.
-apply <- NZle_succ_l in H3. now apply H1.
+apply <- le_succ_l in H3. now apply H1.
 rewrite <- H3 in *; now apply LS'.
 Qed.
 
-Lemma NZlbase : A' (S z).
+Lemma lbase : A' (S z).
 Proof.
-intros m H1 H2. apply -> NZle_succ_l in H2.
-apply -> NZle_ngt in H1. false_hyp H2 H1.
+intros m H1 H2. apply -> le_succ_l in H2.
+apply -> le_ngt in H1. false_hyp H2 H1.
 Qed.
 
-Lemma NZA'A_left : (forall n : NZ, A' n) -> forall n : NZ, n <= z -> A n.
+Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n.
 Proof.
-intros H1 n H2. apply H1 with (n := n); [assumption | now apply NZeq_le_incl].
+intros H1 n H2. apply H1 with (n := n); [assumption | now apply eq_le_incl].
 Qed.
 
-Theorem NZstrong_left_induction: left_step' -> forall n : NZ, n <= z -> A n.
+Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n.
 Proof.
-intro LS'; apply NZA'A_left; unfold A'; NZinduct n (S z);
-[apply NZlbase | apply NZls'_ls''; apply LS'].
+intro LS'; apply A'A_left; unfold A'; nzinduct n (S z);
+[apply lbase | apply ls'_ls''; apply LS'].
 Qed.
 
-Theorem NZleft_induction : A z -> left_step -> forall n : NZ, n <= z -> A n.
+Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n.
 Proof.
-intros Az LS; apply NZstrong_left_induction; now apply NZls_ls'.
+intros Az LS; apply strong_left_induction; now apply ls_ls'.
 Qed.
 
-Theorem NZleft_induction' :
-  (forall n : NZ, z <= n -> A n) -> left_step -> forall n : NZ, A n.
+Theorem left_induction' :
+  (forall n, z <= n -> A n) -> left_step -> forall n, A n.
 Proof.
 intros R L n.
-destruct (NZlt_trichotomy n z) as [H | [H | H]].
-apply NZleft_induction. apply R. now apply NZeq_le_incl. assumption. now apply NZlt_le_incl.
-rewrite H; apply R; now apply NZeq_le_incl.
-apply R; now apply NZlt_le_incl.
+destruct (lt_trichotomy n z) as [H | [H | H]].
+apply left_induction. apply R. now apply eq_le_incl. assumption.
+now apply lt_le_incl.
+rewrite H; apply R; now apply eq_le_incl.
+apply R; now apply lt_le_incl.
 Qed.
 
-Theorem NZstrong_left_induction' :
-  (forall n : NZ, z <= n -> A n) -> left_step' -> forall n : NZ, A n.
+Theorem strong_left_induction' :
+  (forall n, z <= n -> A n) -> left_step' -> forall n, A n.
 Proof.
 intros R L n.
-destruct (NZlt_trichotomy n z) as [H | [H | H]].
-apply NZstrong_left_induction; auto. now apply NZlt_le_incl.
-rewrite H; apply R; now apply NZeq_le_incl.
-apply R; now apply NZlt_le_incl.
+destruct (lt_trichotomy n z) as [H | [H | H]].
+apply strong_left_induction; auto. now apply lt_le_incl.
+rewrite H; apply R; now apply eq_le_incl.
+apply R; now apply lt_le_incl.
 Qed.
 
 End LeftInduction.
 
-Theorem NZorder_induction :
+Theorem order_induction :
   A z ->
-  (forall n : NZ, z <= n -> A n -> A (S n)) ->
-  (forall n : NZ, n < z  -> A (S n) -> A n) ->
-    forall n : NZ, A n.
+  (forall n, z <= n -> A n -> A (S n)) ->
+  (forall n, n < z  -> A (S n) -> A n) ->
+    forall n, A n.
 Proof.
 intros Az RS LS n.
-destruct (NZlt_trichotomy n z) as [H | [H | H]].
-now apply NZleft_induction; [| | apply NZlt_le_incl].
+destruct (lt_trichotomy n z) as [H | [H | H]].
+now apply left_induction; [| | apply lt_le_incl].
 now rewrite H.
-now apply NZright_induction; [| | apply NZlt_le_incl].
+now apply right_induction; [| | apply lt_le_incl].
 Qed.
 
-Theorem NZorder_induction' :
+Theorem order_induction' :
   A z ->
-  (forall n : NZ, z <= n -> A n -> A (S n)) ->
-  (forall n : NZ, n <= z -> A n -> A (P n)) ->
-    forall n : NZ, A n.
+  (forall n, z <= n -> A n -> A (S n)) ->
+  (forall n, n <= z -> A n -> A (P n)) ->
+    forall n, A n.
 Proof.
-intros Az AS AP n; apply NZorder_induction; try assumption.
-intros m H1 H2. apply AP in H2; [| now apply <- NZle_succ_l].
-unfold predicate_wd, fun_wd in A_wd; apply -> (A_wd (P (S m)) m);
-[assumption | apply NZpred_succ].
+intros Az AS AP n; apply order_induction; try assumption.
+intros m H1 H2. apply AP in H2; [| now apply <- le_succ_l].
+apply -> (A_wd (P (S m)) m); [assumption | apply pred_succ].
 Qed.
 
 End Center.
 
-Theorem NZorder_induction_0 :
+Theorem order_induction_0 :
   A 0 ->
-  (forall n : NZ, 0 <= n -> A n -> A (S n)) ->
-  (forall n : NZ, n < 0  -> A (S n) -> A n) ->
-    forall n : NZ, A n.
-Proof (NZorder_induction 0).
+  (forall n, 0 <= n -> A n -> A (S n)) ->
+  (forall n, n < 0  -> A (S n) -> A n) ->
+    forall n, A n.
+Proof (order_induction 0).
 
-Theorem NZorder_induction'_0 :
+Theorem order_induction'_0 :
   A 0 ->
-  (forall n : NZ, 0 <= n -> A n -> A (S n)) ->
-  (forall n : NZ, n <= 0 -> A n -> A (P n)) ->
-    forall n : NZ, A n.
-Proof (NZorder_induction' 0).
+  (forall n, 0 <= n -> A n -> A (S n)) ->
+  (forall n, n <= 0 -> A n -> A (P n)) ->
+    forall n, A n.
+Proof (order_induction' 0).
 
 (** Elimintation principle for < *)
 
-Theorem NZlt_ind : forall (n : NZ),
+Theorem lt_ind : forall (n : t),
   A (S n) ->
-  (forall m : NZ, n < m -> A m -> A (S m)) ->
-   forall m : NZ, n < m -> A m.
+  (forall m, n < m -> A m -> A (S m)) ->
+   forall m, n < m -> A m.
 Proof.
 intros n H1 H2 m H3.
-apply NZright_induction with (S n); [assumption | | now apply <- NZle_succ_l].
-intros; apply H2; try assumption. now apply -> NZle_succ_l.
+apply right_induction with (S n); [assumption | | now apply <- le_succ_l].
+intros; apply H2; try assumption. now apply -> le_succ_l.
 Qed.
 
 (** Elimintation principle for <= *)
 
-Theorem NZle_ind : forall (n : NZ),
+Theorem le_ind : forall (n : t),
   A n ->
-  (forall m : NZ, n <= m -> A m -> A (S m)) ->
-   forall m : NZ, n <= m -> A m.
+  (forall m, n <= m -> A m -> A (S m)) ->
+   forall m, n <= m -> A m.
 Proof.
 intros n H1 H2 m H3.
-now apply NZright_induction with n.
+now apply right_induction with n.
 Qed.
 
 End Induction.
 
-Tactic Notation "NZord_induct" ident(n) :=
-  induction_maker n ltac:(apply NZorder_induction_0).
+Tactic Notation "nzord_induct" ident(n) :=
+  induction_maker n ltac:(apply order_induction_0).
 
-Tactic Notation "NZord_induct" ident(n) constr(z) :=
-  induction_maker n ltac:(apply NZorder_induction with z).
+Tactic Notation "nzord_induct" ident(n) constr(z) :=
+  induction_maker n ltac:(apply order_induction with z).
 
 Section WF.
 
-Variable z : NZ.
+Variable z : t.
 
-Let Rlt (n m : NZ) := z <= n /\ n < m.
-Let Rgt (n m : NZ) := m < n /\ n <= z.
+Let Rlt (n m : t) := z <= n /\ n < m.
+Let Rgt (n m : t) := m < n /\ n <= z.
 
-Add Morphism Rlt with signature NZeq ==> NZeq ==> iff as Rlt_wd.
+Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt.
 Proof.
-intros x1 x2 H1 x3 x4 H2; unfold Rlt; rewrite H1; now rewrite H2.
+intros x1 x2 H1 x3 x4 H2; unfold Rlt. rewrite H1; now rewrite H2.
 Qed.
 
-Add Morphism Rgt with signature NZeq ==> NZeq ==> iff as Rgt_wd.
+Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt.
 Proof.
 intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2.
 Qed.
 
-Lemma NZAcc_lt_wd : predicate_wd NZeq (Acc Rlt).
+Instance Acc_lt_wd : Proper (eq==>iff) (Acc Rlt).
 Proof.
-unfold predicate_wd, fun_wd.
 intros x1 x2 H; split; intro H1; destruct H1 as [H2];
 constructor; intros; apply H2; now (rewrite H || rewrite <- H).
 Qed.
 
-Lemma NZAcc_gt_wd : predicate_wd NZeq (Acc Rgt).
+Instance Acc_gt_wd : Proper (eq==>iff) (Acc Rgt).
 Proof.
-unfold predicate_wd, fun_wd.
 intros x1 x2 H; split; intro H1; destruct H1 as [H2];
 constructor; intros; apply H2; now (rewrite H || rewrite <- H).
 Qed.
 
-Theorem NZlt_wf : well_founded Rlt.
+Theorem lt_wf : well_founded Rlt.
 Proof.
 unfold well_founded.
-apply NZstrong_right_induction' with (z := z).
-apply NZAcc_lt_wd.
+apply strong_right_induction' with (z := z).
+apply Acc_lt_wd.
 intros n H; constructor; intros y [H1 H2].
-apply <- NZnle_gt in H2. elim H2. now apply NZle_trans with z.
+apply <- nle_gt in H2. elim H2. now apply le_trans with z.
 intros n H1 H2; constructor; intros m [H3 H4]. now apply H2.
 Qed.
 
-Theorem NZgt_wf : well_founded Rgt.
+Theorem gt_wf : well_founded Rgt.
 Proof.
 unfold well_founded.
-apply NZstrong_left_induction' with (z := z).
-apply NZAcc_gt_wd.
+apply strong_left_induction' with (z := z).
+apply Acc_gt_wd.
 intros n H; constructor; intros y [H1 H2].
-apply <- NZnle_gt in H2. elim H2. now apply NZle_lt_trans with n.
+apply <- nle_gt in H2. elim H2. now apply le_lt_trans with n.
 intros n H1 H2; constructor; intros m [H3 H4].
-apply H2. assumption. now apply <- NZle_succ_l.
+apply H2. assumption. now apply <- le_succ_l.
 Qed.
 
 End WF.
 
-End NZOrderPropFunct.
+End NZOrderPropSig.
+
+Module NZOrderPropFunct (NZ : NZOrdSig) :=
+ NZBasePropSig NZ <+ NZOrderPropSig NZ.
+
+(** If we have moreover a [compare] function, we can build
+    an [OrderedType] structure. *)
+
+Module NZOrderedTypeFunct (NZ : NZDecOrdSig')
+  <: DecidableTypeFull <: OrderedTypeFull :=
+ NZ <+ NZOrderPropFunct <+ Compare2EqBool <+ HasEqBool2Dec.
 
diff --git a/contrib/correctness/Arrays_stuff.v b/theories/Numbers/NatInt/NZProperties.v
index a8a2858f..125b4f62 100644
--- a/contrib/correctness/Arrays_stuff.v
+++ b/theories/Numbers/NatInt/NZProperties.v
@@ -5,12 +5,16 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+(*i $Id$ i*)
 
-(* $Id: Arrays_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+Require Export NZAxioms NZMulOrder.
 
-Require Export Exchange.
-Require Export ArrayPermut.
-Require Export Sorted.
+(** This functor summarizes all known facts about NZ.
+    For the moment it is only an alias to [NZMulOrderPropFunct], which
+    subsumes all others.
+*)
 
+Module Type NZPropFunct := NZMulOrderPropSig.
diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v
index 91ae5b70..9f0b54a6 100644
--- a/theories/Numbers/Natural/Abstract/NAdd.v
+++ b/theories/Numbers/Natural/Abstract/NAdd.v
@@ -8,74 +8,30 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NAdd.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export NBase.
 
-Module NAddPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NBasePropMod := NBasePropFunct NAxiomsMod.
+Module NAddPropFunct (Import N : NAxiomsSig').
+Include NBasePropFunct N.
 
-Open Local Scope NatScope.
+(** For theorems about [add] that are both valid for [N] and [Z], see [NZAdd] *)
+(** Now comes theorems valid for natural numbers but not for Z *)
 
-Theorem add_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 + m1 == n2 + m2.
-Proof NZadd_wd.
-
-Theorem add_0_l : forall n : N, 0 + n == n.
-Proof NZadd_0_l.
-
-Theorem add_succ_l : forall n m : N, (S n) + m == S (n + m).
-Proof NZadd_succ_l.
-
-(** Theorems that are valid for both natural numbers and integers *)
-
-Theorem add_0_r : forall n : N, n + 0 == n.
-Proof NZadd_0_r.
-
-Theorem add_succ_r : forall n m : N, n + S m == S (n + m).
-Proof NZadd_succ_r.
-
-Theorem add_comm : forall n m : N, n + m == m + n.
-Proof NZadd_comm.
-
-Theorem add_assoc : forall n m p : N, n + (m + p) == (n + m) + p.
-Proof NZadd_assoc.
-
-Theorem add_shuffle1 : forall n m p q : N, (n + m) + (p + q) == (n + p) + (m + q).
-Proof NZadd_shuffle1.
-
-Theorem add_shuffle2 : forall n m p q : N, (n + m) + (p + q) == (n + q) + (m + p).
-Proof NZadd_shuffle2.
-
-Theorem add_1_l : forall n : N, 1 + n == S n.
-Proof NZadd_1_l.
-
-Theorem add_1_r : forall n : N, n + 1 == S n.
-Proof NZadd_1_r.
-
-Theorem add_cancel_l : forall n m p : N, p + n == p + m <-> n == m.
-Proof NZadd_cancel_l.
-
-Theorem add_cancel_r : forall n m p : N, n + p == m + p <-> n == m.
-Proof NZadd_cancel_r.
-
-(* Theorems that are valid for natural numbers but cannot be proved for Z *)
-
-Theorem eq_add_0 : forall n m : N, n + m == 0 <-> n == 0 /\ m == 0.
+Theorem eq_add_0 : forall n m, n + m == 0 <-> n == 0 /\ m == 0.
 Proof.
 intros n m; induct n.
-(* The next command does not work with the axiom add_0_l from NAddSig *)
-rewrite add_0_l. intuition reflexivity.
-intros n IH. rewrite add_succ_l.
-setoid_replace (S (n + m) == 0) with False using relation iff by
+nzsimpl; intuition.
+intros n IH. nzsimpl.
+setoid_replace (S (n + m) == 0) with False by
  (apply -> neg_false; apply neq_succ_0).
-setoid_replace (S n == 0) with False using relation iff by
+setoid_replace (S n == 0) with False by
  (apply -> neg_false; apply neq_succ_0). tauto.
 Qed.
 
 Theorem eq_add_succ :
-  forall n m : N, (exists p : N, n + m == S p) <->
-                    (exists n' : N, n == S n') \/ (exists m' : N, m == S m').
+  forall n m, (exists p, n + m == S p) <->
+              (exists n', n == S n') \/ (exists m', m == S m').
 Proof.
 intros n m; cases n.
 split; intro H.
@@ -88,11 +44,11 @@ left; now exists n.
 exists (n + m); now rewrite add_succ_l.
 Qed.
 
-Theorem eq_add_1 : forall n m : N,
+Theorem eq_add_1 : forall n m,
   n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1.
 Proof.
 intros n m H.
-assert (H1 : exists p : N, n + m == S p) by now exists 0.
+assert (H1 : exists p, n + m == S p) by now exists 0.
 apply -> eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]].
 left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H.
 apply -> eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split.
@@ -100,7 +56,7 @@ right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H.
 apply -> eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split.
 Qed.
 
-Theorem succ_add_discr : forall n m : N, m ~= S (n + m).
+Theorem succ_add_discr : forall n m, m ~= S (n + m).
 Proof.
 intro n; induct m.
 apply neq_sym. apply neq_succ_0.
@@ -108,49 +64,18 @@ intros m IH H. apply succ_inj in H. rewrite add_succ_r in H.
 unfold not in IH; now apply IH.
 Qed.
 
-Theorem add_pred_l : forall n m : N, n ~= 0 -> P n + m == P (n + m).
+Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m).
 Proof.
 intros n m; cases n.
 intro H; now elim H.
 intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ.
 Qed.
 
-Theorem add_pred_r : forall n m : N, m ~= 0 -> n + P m == P (n + m).
+Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m).
 Proof.
 intros n m H; rewrite (add_comm n (P m));
 rewrite (add_comm n m); now apply add_pred_l.
 Qed.
 
-(* One could define n <= m as exists p : N, p + n == m. Then we have
-dichotomy:
-
-forall n m : N, n <= m \/ m <= n,
-
-i.e.,
-
-forall n m : N, (exists p : N, p + n == m) \/ (exists p : N, p + m == n)     (1)
-
-We will need (1) in the proof of induction principle for integers
-constructed as pairs of natural numbers. The formula (1) can be proved
-using properties of order and truncated subtraction. Thus, p would be
-m - n or n - m and (1) would hold by theorem sub_add from Sub.v
-depending on whether n <= m or m <= n. However, in proving induction
-for integers constructed from natural numbers we do not need to
-require implementations of order and sub; it is enough to prove (1)
-here. *)
-
-Theorem add_dichotomy :
-  forall n m : N, (exists p : N, p + n == m) \/ (exists p : N, p + m == n).
-Proof.
-intros n m; induct n.
-left; exists m; apply add_0_r.
-intros n IH.
-destruct IH as [[p H] | [p H]].
-destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H.
-rewrite add_0_l in H. right; exists (S 0); rewrite H; rewrite add_succ_l; now rewrite add_0_l.
-left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H.
-right; exists (S p). rewrite add_succ_l; now rewrite H.
-Qed.
-
 End NAddPropFunct.
 
diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v
index 7024fd00..0ce04e54 100644
--- a/theories/Numbers/Natural/Abstract/NAddOrder.v
+++ b/theories/Numbers/Natural/Abstract/NAddOrder.v
@@ -8,107 +8,41 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export NOrder.
 
-Module NAddOrderPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NOrderPropMod := NOrderPropFunct NAxiomsMod.
-Open Local Scope NatScope.
+Module NAddOrderPropFunct (Import N : NAxiomsSig').
+Include NOrderPropFunct N.
 
-Theorem add_lt_mono_l : forall n m p : N, n < m <-> p + n < p + m.
-Proof NZadd_lt_mono_l.
+(** Theorems true for natural numbers, not for integers *)
 
-Theorem add_lt_mono_r : forall n m p : N, n < m <-> n + p < m + p.
-Proof NZadd_lt_mono_r.
-
-Theorem add_lt_mono : forall n m p q : N, n < m -> p < q -> n + p < m + q.
-Proof NZadd_lt_mono.
-
-Theorem add_le_mono_l : forall n m p : N, n <= m <-> p + n <= p + m.
-Proof NZadd_le_mono_l.
-
-Theorem add_le_mono_r : forall n m p : N, n <= m <-> n + p <= m + p.
-Proof NZadd_le_mono_r.
-
-Theorem add_le_mono : forall n m p q : N, n <= m -> p <= q -> n + p <= m + q.
-Proof NZadd_le_mono.
-
-Theorem add_lt_le_mono : forall n m p q : N, n < m -> p <= q -> n + p < m + q.
-Proof NZadd_lt_le_mono.
-
-Theorem add_le_lt_mono : forall n m p q : N, n <= m -> p < q -> n + p < m + q.
-Proof NZadd_le_lt_mono.
-
-Theorem add_pos_pos : forall n m : N, 0 < n -> 0 < m -> 0 < n + m.
-Proof NZadd_pos_pos.
-
-Theorem lt_add_pos_l : forall n m : N, 0 < n -> m < n + m.
-Proof NZlt_add_pos_l.
-
-Theorem lt_add_pos_r : forall n m : N, 0 < n -> m < m + n.
-Proof NZlt_add_pos_r.
-
-Theorem le_lt_add_lt : forall n m p q : N, n <= m -> p + m < q + n -> p < q.
-Proof NZle_lt_add_lt.
-
-Theorem lt_le_add_lt : forall n m p q : N, n < m -> p + m <= q + n -> p < q.
-Proof NZlt_le_add_lt.
-
-Theorem le_le_add_le : forall n m p q : N, n <= m -> p + m <= q + n -> p <= q.
-Proof NZle_le_add_le.
-
-Theorem add_lt_cases : forall n m p q : N, n + m < p + q -> n < p \/ m < q.
-Proof NZadd_lt_cases.
-
-Theorem add_le_cases : forall n m p q : N, n + m <= p + q -> n <= p \/ m <= q.
-Proof NZadd_le_cases.
-
-Theorem add_pos_cases : forall n m : N, 0 < n + m -> 0 < n \/ 0 < m.
-Proof NZadd_pos_cases.
-
-(* Theorems true for natural numbers *)
-
-Theorem le_add_r : forall n m : N, n <= n + m.
+Theorem le_add_r : forall n m, n <= n + m.
 Proof.
 intro n; induct m.
 rewrite add_0_r; now apply eq_le_incl.
 intros m IH. rewrite add_succ_r; now apply le_le_succ_r.
 Qed.
 
-Theorem lt_lt_add_r : forall n m p : N, n < m -> n < m + p.
+Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p.
 Proof.
 intros n m p H; rewrite <- (add_0_r n).
 apply add_lt_le_mono; [assumption | apply le_0_l].
 Qed.
 
-Theorem lt_lt_add_l : forall n m p : N, n < m -> n < p + m.
+Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m.
 Proof.
 intros n m p; rewrite add_comm; apply lt_lt_add_r.
 Qed.
 
-Theorem add_pos_l : forall n m : N, 0 < n -> 0 < n + m.
+Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m.
 Proof.
-intros; apply NZadd_pos_nonneg. assumption. apply le_0_l.
+intros; apply add_pos_nonneg. assumption. apply le_0_l.
 Qed.
 
-Theorem add_pos_r : forall n m : N, 0 < m -> 0 < n + m.
-Proof.
-intros; apply NZadd_nonneg_pos. apply le_0_l. assumption.
-Qed.
-
-(* The following property is used to prove the correctness of the
-definition of order on integers constructed from pairs of natural numbers *)
-
-Theorem add_lt_repl_pair : forall n m n' m' u v : N,
-  n + u < m + v -> n + m' == n' + m -> n' + u < m' + v.
+Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m.
 Proof.
-intros n m n' m' u v H1 H2.
-symmetry in H2. assert (H3 : n' + m <= n + m') by now apply eq_le_incl.
-pose proof (add_lt_le_mono _ _ _ _ H1 H3) as H4.
-rewrite (add_shuffle2 n u), (add_shuffle1 m v), (add_comm m n) in H4.
-do 2 rewrite <- add_assoc in H4. do 2 apply <- add_lt_mono_l in H4.
-now rewrite (add_comm n' u), (add_comm m' v).
+intros; apply add_nonneg_pos. apply le_0_l. assumption.
 Qed.
 
 End NAddOrderPropFunct.
diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v
index 750cc977..42016ab1 100644
--- a/theories/Numbers/Natural/Abstract/NAxioms.v
+++ b/theories/Numbers/Natural/Abstract/NAxioms.v
@@ -8,64 +8,32 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export NZAxioms.
 
 Set Implicit Arguments.
 
-Module Type NAxiomsSig.
-Declare Module Export NZOrdAxiomsMod : NZOrdAxiomsSig.
+Module Type NAxioms (Import NZ : NZDomainSig').
 
-Delimit Scope NatScope with Nat.
-Notation N := NZ.
-Notation Neq := NZeq.
-Notation N0 := NZ0.
-Notation N1 := (NZsucc NZ0).
-Notation S := NZsucc.
-Notation P := NZpred.
-Notation add := NZadd.
-Notation mul := NZmul.
-Notation sub := NZsub.
-Notation lt := NZlt.
-Notation le := NZle.
-Notation min := NZmin.
-Notation max := NZmax.
-Notation "x == y"  := (Neq x y) (at level 70) : NatScope.
-Notation "x ~= y" := (~ Neq x y) (at level 70) : NatScope.
-Notation "0" := NZ0 : NatScope.
-Notation "1" := (NZsucc NZ0) : NatScope.
-Notation "x + y" := (NZadd x y) : NatScope.
-Notation "x - y" := (NZsub x y) : NatScope.
-Notation "x * y" := (NZmul x y) : NatScope.
-Notation "x < y" := (NZlt x y) : NatScope.
-Notation "x <= y" := (NZle x y) : NatScope.
-Notation "x > y" := (NZlt y x) (only parsing) : NatScope.
-Notation "x >= y" := (NZle y x) (only parsing) : NatScope.
-
-Open Local Scope NatScope.
+Axiom pred_0 : P 0 == 0.
 
-Parameter Inline recursion : forall A : Type, A -> (N -> A -> A) -> N -> A.
+Parameter Inline recursion : forall A : Type, A -> (t -> A -> A) -> t -> A.
 Implicit Arguments recursion [A].
 
-Axiom pred_0 : P 0 == 0.
-
-Axiom recursion_wd : forall (A : Type) (Aeq : relation A),
-  forall a a' : A, Aeq a a' ->
-    forall f f' : N -> A -> A, fun2_eq Neq Aeq Aeq f f' ->
-      forall x x' : N, x == x' ->
-        Aeq (recursion a f x) (recursion a' f' x').
+Declare Instance recursion_wd (A : Type) (Aeq : relation A) :
+ Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).
 
 Axiom recursion_0 :
-  forall (A : Type) (a : A) (f : N -> A -> A), recursion a f 0 = a.
+  forall (A : Type) (a : A) (f : t -> A -> A), recursion a f 0 = a.
 
 Axiom recursion_succ :
-  forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A),
-    Aeq a a -> fun2_wd Neq Aeq Aeq f ->
-      forall n : N, Aeq (recursion a f (S n)) (f n (recursion a f n)).
+  forall (A : Type) (Aeq : relation A) (a : A) (f : t -> A -> A),
+    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
+      forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)).
 
-(*Axiom dep_rec :
-  forall A : N -> Type, A 0 -> (forall n : N, A n -> A (S n)) -> forall n : N, A n.*)
+End NAxioms.
 
-End NAxiomsSig.
+Module Type NAxiomsSig := NZOrdAxiomsSig <+ NAxioms.
+Module Type NAxiomsSig' := NZOrdAxiomsSig' <+ NAxioms.
 
diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v
index 85e2c2ab..842f4bcf 100644
--- a/theories/Numbers/Natural/Abstract/NBase.v
+++ b/theories/Numbers/Natural/Abstract/NBase.v
@@ -8,135 +8,78 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export Decidable.
 Require Export NAxioms.
-Require Import NZMulOrder. (* The last property functor on NZ, which subsumes all others *)
+Require Import NZProperties.
 
-Module NBasePropFunct (Import NAxiomsMod : NAxiomsSig).
+Module NBasePropFunct (Import N : NAxiomsSig').
+(** First, we import all known facts about both natural numbers and integers. *)
+Include NZPropFunct N.
 
-Open Local Scope NatScope.
-
-(* We call the last property functor on NZ, which includes all the previous
-ones, to get all properties of NZ at once. This way we will include them
-only one time. *)
-
-Module Export NZMulOrderMod := NZMulOrderPropFunct NZOrdAxiomsMod.
-
-(* Here we probably need to re-prove all axioms declared in NAxioms.v to
-make sure that the definitions like N, S and add are unfolded in them,
-since unfolding is done only inside a functor. In fact, we'll do it in the
-files that prove the corresponding properties. In those files, we will also
-rename properties proved in NZ files by removing NZ from their names. In
-this way, one only has to consult, for example, NAdd.v to see all
-available properties for add, i.e., one does not have to go to NAxioms.v
-for axioms and NZAdd.v for theorems. *)
-
-Theorem succ_wd : forall n1 n2 : N, n1 == n2 -> S n1 == S n2.
-Proof NZsucc_wd.
-
-Theorem pred_wd : forall n1 n2 : N, n1 == n2 -> P n1 == P n2.
-Proof NZpred_wd.
-
-Theorem pred_succ : forall n : N, P (S n) == n.
-Proof NZpred_succ.
-
-Theorem pred_0 : P 0 == 0.
-Proof pred_0.
-
-Theorem Neq_refl : forall n : N, n == n.
-Proof (proj1 NZeq_equiv).
-
-Theorem Neq_sym : forall n m : N, n == m -> m == n.
-Proof (proj2 (proj2 NZeq_equiv)).
-
-Theorem Neq_trans : forall n m p : N, n == m -> m == p -> n == p.
-Proof (proj1 (proj2 NZeq_equiv)).
-
-Theorem neq_sym : forall n m : N, n ~= m -> m ~= n.
-Proof NZneq_sym.
-
-Theorem succ_inj : forall n1 n2 : N, S n1 == S n2 -> n1 == n2.
-Proof NZsucc_inj.
-
-Theorem succ_inj_wd : forall n1 n2 : N, S n1 == S n2 <-> n1 == n2.
-Proof NZsucc_inj_wd.
-
-Theorem succ_inj_wd_neg : forall n m : N, S n ~= S m <-> n ~= m.
-Proof NZsucc_inj_wd_neg.
-
-(* Decidability and stability of equality was proved only in NZOrder, but
-since it does not mention order, we'll put it here *)
-
-Theorem eq_dec : forall n m : N, decidable (n == m).
-Proof NZeq_dec.
-
-Theorem eq_dne : forall n m : N, ~ ~ n == m <-> n == m.
-Proof NZeq_dne.
-
-(* Now we prove that the successor of a number is not zero by defining a
+(** We prove that the successor of a number is not zero by defining a
 function (by recursion) that maps 0 to false and the successor to true *)
 
-Definition if_zero (A : Set) (a b : A) (n : N) : A :=
+Definition if_zero (A : Type) (a b : A) (n : N.t) : A :=
   recursion a (fun _ _ => b) n.
 
-Add Parametric Morphism (A : Set) : (if_zero A) with signature (@eq _ ==> @eq _ ==> Neq ==> @eq _) as if_zero_wd.
+Implicit Arguments if_zero [A].
+
+Instance if_zero_wd (A : Type) :
+ Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A).
 Proof.
-intros; unfold if_zero. apply recursion_wd with (Aeq := (@eq A)).
-reflexivity. unfold fun2_eq; now intros. assumption.
+intros; unfold if_zero.
+repeat red; intros. apply recursion_wd; auto. repeat red; auto.
 Qed.
 
-Theorem if_zero_0 : forall (A : Set) (a b : A), if_zero A a b 0 = a.
+Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a.
 Proof.
 unfold if_zero; intros; now rewrite recursion_0.
 Qed.
 
-Theorem if_zero_succ : forall (A : Set) (a b : A) (n : N), if_zero A a b (S n) = b.
+Theorem if_zero_succ :
+ forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b.
 Proof.
 intros; unfold if_zero.
-now rewrite (@recursion_succ A (@eq A)); [| | unfold fun2_wd; now intros].
+now rewrite recursion_succ.
 Qed.
 
-Implicit Arguments if_zero [A].
-
-Theorem neq_succ_0 : forall n : N, S n ~= 0.
+Theorem neq_succ_0 : forall n, S n ~= 0.
 Proof.
 intros n H.
-assert (true = false); [| discriminate].
-replace true with (if_zero false true (S n)) by apply if_zero_succ.
-pattern false at 2; replace false with (if_zero false true 0) by apply if_zero_0.
-now rewrite H.
+generalize (Logic.eq_refl (if_zero false true 0)).
+rewrite <- H at 1. rewrite if_zero_0, if_zero_succ; discriminate.
 Qed.
 
-Theorem neq_0_succ : forall n : N, 0 ~= S n.
+Theorem neq_0_succ : forall n, 0 ~= S n.
 Proof.
 intro n; apply neq_sym; apply neq_succ_0.
 Qed.
 
-(* Next, we show that all numbers are nonnegative and recover regular induction
-from the bidirectional induction on NZ *)
+(** Next, we show that all numbers are nonnegative and recover regular
+    induction from the bidirectional induction on NZ *)
 
-Theorem le_0_l : forall n : N, 0 <= n.
+Theorem le_0_l : forall n, 0 <= n.
 Proof.
-NZinduct n.
-now apply NZeq_le_incl.
+nzinduct n.
+now apply eq_le_incl.
 intro n; split.
-apply NZle_le_succ_r.
-intro H; apply -> NZle_succ_r in H; destruct H as [H | H].
+apply le_le_succ_r.
+intro H; apply -> le_succ_r in H; destruct H as [H | H].
 assumption.
 symmetry in H; false_hyp H neq_succ_0.
 Qed.
 
 Theorem induction :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    A 0 -> (forall n : N, A n -> A (S n)) -> forall n : N, A n.
+  forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
+    A 0 -> (forall n, A n -> A (S n)) -> forall n, A n.
 Proof.
-intros A A_wd A0 AS n; apply NZright_induction with 0; try assumption.
+intros A A_wd A0 AS n; apply right_induction with 0; try assumption.
 intros; auto; apply le_0_l. apply le_0_l.
 Qed.
 
-(* The theorems NZinduction, NZcentral_induction and the tactic NZinduct
+(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct]
 refer to bidirectional induction, which is not useful on natural
 numbers. Therefore, we define a new induction tactic for natural numbers.
 We do not have to call "Declare Left Step" and "Declare Right Step"
@@ -146,8 +89,8 @@ from NZ. *)
 Ltac induct n := induction_maker n ltac:(apply induction).
 
 Theorem case_analysis :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    A 0 -> (forall n : N, A (S n)) -> forall n : N, A n.
+  forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
+    A 0 -> (forall n, A (S n)) -> forall n, A n.
 Proof.
 intros; apply induction; auto.
 Qed.
@@ -173,7 +116,7 @@ now left.
 intro n; right; now exists n.
 Qed.
 
-Theorem eq_pred_0 : forall n : N, P n == 0 <-> n == 0 \/ n == 1.
+Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1.
 Proof.
 cases n.
 rewrite pred_0. setoid_replace (0 == 1) with False using relation iff. tauto.
@@ -184,34 +127,29 @@ setoid_replace (S n == 0) with False using relation iff by
 rewrite succ_inj_wd. tauto.
 Qed.
 
-Theorem succ_pred : forall n : N, n ~= 0 -> S (P n) == n.
+Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n.
 Proof.
 cases n.
-intro H; elimtype False; now apply H.
+intro H; exfalso; now apply H.
 intros; now rewrite pred_succ.
 Qed.
 
-Theorem pred_inj : forall n m : N, n ~= 0 -> m ~= 0 -> P n == P m -> n == m.
+Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m.
 Proof.
 intros n m; cases n.
-intros H; elimtype False; now apply H.
+intros H; exfalso; now apply H.
 intros n _; cases m.
-intros H; elimtype False; now apply H.
+intros H; exfalso; now apply H.
 intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3.
 Qed.
 
-(* The following induction principle is useful for reasoning about, e.g.,
+(** The following induction principle is useful for reasoning about, e.g.,
 Fibonacci numbers *)
 
 Section PairInduction.
 
-Variable A : N -> Prop.
-Hypothesis A_wd : predicate_wd Neq A.
-
-Add Morphism A with signature Neq ==> iff as A_morph.
-Proof.
-exact A_wd.
-Qed.
+Variable A : N.t -> Prop.
+Hypothesis A_wd : Proper (N.eq==>iff) A.
 
 Theorem pair_induction :
   A 0 -> A 1 ->
@@ -224,18 +162,12 @@ Qed.
 
 End PairInduction.
 
-(*Ltac pair_induct n := induction_maker n ltac:(apply pair_induction).*)
+(** The following is useful for reasoning about, e.g., Ackermann function *)
 
-(* The following is useful for reasoning about, e.g., Ackermann function *)
 Section TwoDimensionalInduction.
 
-Variable R : N -> N -> Prop.
-Hypothesis R_wd : relation_wd Neq Neq R.
-
-Add Morphism R with signature Neq ==> Neq ==> iff as R_morph.
-Proof.
-exact R_wd.
-Qed.
+Variable R : N.t -> N.t -> Prop.
+Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.
 
 Theorem two_dim_induction :
    R 0 0 ->
@@ -251,26 +183,16 @@ Qed.
 
 End TwoDimensionalInduction.
 
-(*Ltac two_dim_induct n m :=
-  try intros until n;
-  try intros until m;
-  pattern n, m; apply two_dim_induction; clear n m;
-  [solve_relation_wd | | | ].*)
 
 Section DoubleInduction.
 
-Variable R : N -> N -> Prop.
-Hypothesis R_wd : relation_wd Neq Neq R.
-
-Add Morphism R with signature Neq ==> Neq ==> iff as R_morph1.
-Proof.
-exact R_wd.
-Qed.
+Variable R : N.t -> N.t -> Prop.
+Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.
 
 Theorem double_induction :
-   (forall m : N, R 0 m) ->
-   (forall n : N, R (S n) 0) ->
-   (forall n m : N, R n m -> R (S n) (S m)) -> forall n m : N, R n m.
+   (forall m, R 0 m) ->
+   (forall n, R (S n) 0) ->
+   (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m.
 Proof.
 intros H1 H2 H3; induct n; auto.
 intros n H; cases m; auto.
diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v
index 0a8f5f1e..22eb2cb3 100644
--- a/theories/Numbers/Natural/Abstract/NDefOps.v
+++ b/theories/Numbers/Natural/Abstract/NDefOps.v
@@ -8,45 +8,47 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NDefOps.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import Bool. (* To get the orb and negb function *)
+Require Import RelationPairs.
 Require Export NStrongRec.
 
-Module NdefOpsPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NStrongRecPropMod := NStrongRecPropFunct NAxiomsMod.
-Open Local Scope NatScope.
+Module NdefOpsPropFunct (Import N : NAxiomsSig').
+Include NStrongRecPropFunct N.
 
 (*****************************************************)
 (**                   Addition                       *)
 
-Definition def_add (x y : N) := recursion y (fun _ p => S p) x.
+Definition def_add (x y : N.t) := recursion y (fun _ => S) x.
 
-Infix Local "++" := def_add (at level 50, left associativity).
+Local Infix "+++" := def_add (at level 50, left associativity).
 
-Add Morphism def_add with signature Neq ==> Neq ==> Neq as def_add_wd.
+Instance def_add_prewd : Proper (N.eq==>N.eq==>N.eq) (fun _ => S).
 Proof.
-unfold def_add.
-intros x x' Exx' y y' Eyy'.
-apply recursion_wd with (Aeq := Neq).
-assumption.
-unfold fun2_eq; intros _ _ _ p p' Epp'; now rewrite Epp'.
-assumption.
+intros _ _ _ p p' Epp'; now rewrite Epp'.
+Qed.
+
+Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add.
+Proof.
+intros x x' Exx' y y' Eyy'. unfold def_add.
+(* TODO: why rewrite Exx' don't work here (or verrrry slowly) ? *)
+apply recursion_wd with (Aeq := N.eq); auto with *.
+apply def_add_prewd.
 Qed.
 
-Theorem def_add_0_l : forall y : N, 0 ++ y == y.
+Theorem def_add_0_l : forall y, 0 +++ y == y.
 Proof.
 intro y. unfold def_add. now rewrite recursion_0.
 Qed.
 
-Theorem def_add_succ_l : forall x y : N, S x ++ y == S (x ++ y).
+Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y).
 Proof.
 intros x y; unfold def_add.
-rewrite (@recursion_succ N Neq); try reflexivity.
-unfold fun2_wd. intros _ _ _ m1 m2 H2. now rewrite H2.
+rewrite recursion_succ; auto with *.
 Qed.
 
-Theorem def_add_add : forall n m : N, n ++ m == n + m.
+Theorem def_add_add : forall n m, n +++ m == n + m.
 Proof.
 intros n m; induct n.
 now rewrite def_add_0_l, add_0_l.
@@ -56,42 +58,37 @@ Qed.
 (*****************************************************)
 (**                  Multiplication                  *)
 
-Definition def_mul (x y : N) := recursion 0 (fun _ p => p ++ x) y.
+Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y.
 
-Infix Local "**" := def_mul (at level 40, left associativity).
+Local Infix "**" := def_mul (at level 40, left associativity).
 
-Lemma def_mul_step_wd : forall x : N, fun2_wd Neq Neq Neq (fun _ p => def_add p x).
+Instance def_mul_prewd :
+ Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun x _ p => p +++ x).
 Proof.
-unfold fun2_wd. intros. now apply def_add_wd.
+repeat red; intros; now apply def_add_wd.
 Qed.
 
-Lemma def_mul_step_equal :
-  forall x x' : N, x == x' ->
-    fun2_eq Neq Neq Neq (fun _ p => def_add p x) (fun x p => def_add p x').
-Proof.
-unfold fun2_eq; intros; apply def_add_wd; assumption.
-Qed.
-
-Add Morphism def_mul with signature Neq ==> Neq ==> Neq as def_mul_wd.
+Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul.
 Proof.
 unfold def_mul.
 intros x x' Exx' y y' Eyy'.
-apply recursion_wd with (Aeq := Neq).
-reflexivity. apply def_mul_step_equal. assumption. assumption.
+apply recursion_wd; auto with *.
+now apply def_mul_prewd.
 Qed.
 
-Theorem def_mul_0_r : forall x : N, x ** 0 == 0.
+Theorem def_mul_0_r : forall x, x ** 0 == 0.
 Proof.
 intro. unfold def_mul. now rewrite recursion_0.
 Qed.
 
-Theorem def_mul_succ_r : forall x y : N, x ** S y == x ** y ++ x.
+Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x.
 Proof.
 intros x y; unfold def_mul.
-now rewrite (@recursion_succ N Neq); [| apply def_mul_step_wd |].
+rewrite recursion_succ; auto with *.
+now apply def_mul_prewd.
 Qed.
 
-Theorem def_mul_mul : forall n m : N, n ** m == n * m.
+Theorem def_mul_mul : forall n m, n ** m == n * m.
 Proof.
 intros n m; induct m.
 now rewrite def_mul_0_r, mul_0_r.
@@ -101,120 +98,99 @@ Qed.
 (*****************************************************)
 (**                     Order                        *)
 
-Definition def_ltb (m : N) : N -> bool :=
+Definition ltb (m : N.t) : N.t -> bool :=
 recursion
   (if_zero false true)
-  (fun _ f => fun n => recursion false (fun n' _ => f n') n)
+  (fun _ f n => recursion false (fun n' _ => f n') n)
   m.
 
-Infix Local "<<" := def_ltb (at level 70, no associativity).
-
-Lemma lt_base_wd : fun_wd Neq (@eq bool) (if_zero false true).
-unfold fun_wd; intros; now apply if_zero_wd.
-Qed.
+Local Infix "<<" := ltb (at level 70, no associativity).
 
-Lemma lt_step_wd :
-fun2_wd Neq (fun_eq Neq (@eq bool)) (fun_eq Neq (@eq bool))
-  (fun _ f => fun n => recursion false (fun n' _ => f n') n).
+Instance ltb_prewd1 : Proper (N.eq==>Logic.eq) (if_zero false true).
 Proof.
-unfold fun2_wd, fun_eq.
-intros x x' Exx' f f' Eff' y y' Eyy'.
-apply recursion_wd with (Aeq := @eq bool).
-reflexivity.
-unfold fun2_eq; intros; now apply Eff'.
-assumption.
+red; intros; apply if_zero_wd; auto.
 Qed.
 
-Lemma lt_curry_wd :
-  forall m m' : N, m == m' -> fun_eq Neq (@eq bool) (def_ltb m) (def_ltb m').
+Instance ltb_prewd2 : Proper (N.eq==>(N.eq==>Logic.eq)==>N.eq==>Logic.eq)
+ (fun _ f n => recursion false (fun n' _ => f n') n).
 Proof.
-unfold def_ltb.
-intros m m' Emm'.
-apply recursion_wd with (Aeq := fun_eq Neq (@eq bool)).
-apply lt_base_wd.
-apply lt_step_wd.
-assumption.
+repeat red; intros; simpl.
+apply recursion_wd; auto with *.
+repeat red; auto.
 Qed.
 
-Add Morphism def_ltb with signature Neq ==> Neq ==> (@eq bool) as def_ltb_wd.
+Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb.
 Proof.
-intros; now apply lt_curry_wd.
+unfold ltb.
+intros n n' Hn m m' Hm.
+apply f_equiv; auto with *.
+apply recursion_wd; auto; [ apply ltb_prewd1 | apply ltb_prewd2 ].
 Qed.
 
-Theorem def_ltb_base : forall n : N, 0 << n = if_zero false true n.
+Theorem ltb_base : forall n, 0 << n = if_zero false true n.
 Proof.
-intro n; unfold def_ltb; now rewrite recursion_0.
+intro n; unfold ltb; now rewrite recursion_0.
 Qed.
 
-Theorem def_ltb_step :
-  forall m n : N, S m << n = recursion false (fun n' _ => m << n') n.
+Theorem ltb_step :
+  forall m n, S m << n = recursion false (fun n' _ => m << n') n.
 Proof.
-intros m n; unfold def_ltb.
-pose proof
-  (@recursion_succ
-    (N -> bool)
-    (fun_eq Neq (@eq bool))
-    (if_zero false true)
-    (fun _ f => fun n => recursion false (fun n' _ => f n') n)
-    lt_base_wd
-    lt_step_wd
-    m n n) as H.
-now rewrite H.
+intros m n; unfold ltb at 1.
+apply f_equiv; auto with *.
+rewrite recursion_succ by (apply ltb_prewd1||apply ltb_prewd2).
+fold (ltb m).
+repeat red; intros. apply recursion_wd; auto.
+repeat red; intros; now apply ltb_wd.
 Qed.
 
 (* Above, we rewrite applications of function. Is it possible to rewrite
 functions themselves, i.e., rewrite (recursion lt_base lt_step (S n)) to
 lt_step n (recursion lt_base lt_step n)? *)
 
-Theorem def_ltb_0 : forall n : N, n << 0 = false.
+Theorem ltb_0 : forall n, n << 0 = false.
 Proof.
 cases n.
-rewrite def_ltb_base; now rewrite if_zero_0.
-intro n; rewrite def_ltb_step. now rewrite recursion_0.
+rewrite ltb_base; now rewrite if_zero_0.
+intro n; rewrite ltb_step. now rewrite recursion_0.
 Qed.
 
-Theorem def_ltb_0_succ : forall n : N, 0 << S n = true.
+Theorem ltb_0_succ : forall n, 0 << S n = true.
 Proof.
-intro n; rewrite def_ltb_base; now rewrite if_zero_succ.
+intro n; rewrite ltb_base; now rewrite if_zero_succ.
 Qed.
 
-Theorem succ_def_ltb_mono : forall n m : N, (S n << S m) = (n << m).
+Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m).
 Proof.
 intros n m.
-rewrite def_ltb_step. rewrite (@recursion_succ bool (@eq bool)); try reflexivity.
-unfold fun2_wd; intros; now apply def_ltb_wd.
+rewrite ltb_step. rewrite recursion_succ; try reflexivity.
+repeat red; intros; now apply ltb_wd.
 Qed.
 
-Theorem def_ltb_lt : forall n m : N, n << m = true <-> n < m.
+Theorem ltb_lt : forall n m, n << m = true <-> n < m.
 Proof.
 double_induct n m.
 cases m.
-rewrite def_ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r].
-intro n. rewrite def_ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity].
-intro n. rewrite def_ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r].
-intros n m. rewrite succ_def_ltb_mono. now rewrite <- succ_lt_mono.
+rewrite ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r].
+intro n. rewrite ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity].
+intro n. rewrite ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r].
+intros n m. rewrite succ_ltb_mono. now rewrite <- succ_lt_mono.
+Qed.
+
+Theorem ltb_ge : forall n m, n << m = false <-> n >= m.
+Proof.
+intros. rewrite <- not_true_iff_false, ltb_lt. apply nlt_ge.
 Qed.
 
-(*
 (*****************************************************)
 (**                     Even                         *)
 
-Definition even (x : N) := recursion true (fun _ p => negb p) x.
-
-Lemma even_step_wd : fun2_wd Neq (@eq bool) (@eq bool) (fun x p => if p then false else true).
-Proof.
-unfold fun2_wd.
-intros x x' Exx' b b' Ebb'.
-unfold eq_bool; destruct b; destruct b'; now simpl.
-Qed.
+Definition even (x : N.t) := recursion true (fun _ p => negb p) x.
 
-Add Morphism even with signature Neq ==> (@eq bool) as even_wd.
+Instance even_wd : Proper (N.eq==>Logic.eq) even.
 Proof.
-unfold even; intros.
-apply recursion_wd with (A := bool) (Aeq := (@eq bool)).
-now unfold eq_bool.
-unfold fun2_eq. intros _ _ _ b b' Ebb'. unfold eq_bool; destruct b; destruct b'; now simpl.
-assumption.
+intros n n' Hn. unfold even.
+apply recursion_wd; auto.
+congruence.
 Qed.
 
 Theorem even_0 : even 0 = true.
@@ -223,76 +199,281 @@ unfold even.
 now rewrite recursion_0.
 Qed.
 
-Theorem even_succ : forall x : N, even (S x) = negb (even x).
+Theorem even_succ : forall x, even (S x) = negb (even x).
 Proof.
 unfold even.
-intro x; rewrite (recursion_succ (@eq bool)); try reflexivity.
-unfold fun2_wd.
-intros _ _ _ b b' Ebb'. destruct b; destruct b'; now simpl.
+intro x; rewrite recursion_succ; try reflexivity.
+congruence.
 Qed.
 
 (*****************************************************)
 (**                Division by 2                     *)
 
-Definition half_aux (x : N) : N * N :=
-  recursion (0, 0) (fun _ p => let (x1, x2) := p in ((S x2, x1))) x.
+Local Notation "a <= b <= c" := (a<=b /\ b<=c).
+Local Notation "a <= b < c" := (a<=b /\ b<c).
+Local Notation "a < b <= c" := (a<b /\ b<=c).
+Local Notation "a < b < c" := (a<b /\ b<c).
+Local Notation "2" := (S 1).
 
-Definition half (x : N) := snd (half_aux x).
+Definition half_aux (x : N.t) : N.t * N.t :=
+  recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x.
 
-Definition E2 := prod_rel Neq Neq.
+Definition half (x : N.t) := snd (half_aux x).
 
-Add Relation (prod N N) E2
-reflexivity proved by (prod_rel_refl N N Neq Neq E_equiv E_equiv)
-symmetry proved by (prod_rel_sym N N Neq Neq E_equiv E_equiv)
-transitivity proved by (prod_rel_trans N N Neq Neq E_equiv E_equiv)
-as E2_rel.
+Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux.
+Proof.
+intros x x' Hx. unfold half_aux.
+apply recursion_wd; auto with *.
+intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *.
+rewrite Hu, Hv; auto with *.
+Qed.
 
-Lemma half_step_wd: fun2_wd Neq E2 E2 (fun _ p => let (x1, x2) := p in ((S x2, x1))).
+Instance half_wd : Proper (N.eq==>N.eq) half.
 Proof.
-unfold fun2_wd, E2, prod_rel.
-intros _ _ _ p1 p2 [H1 H2].
-destruct p1; destruct p2; simpl in *.
-now split; [rewrite H2 |].
+intros x x' Hx. unfold half. rewrite Hx; auto with *.
 Qed.
 
-Add Morphism half with signature Neq ==> Neq as half_wd.
+Lemma half_aux_0 : half_aux 0 = (0,0).
 Proof.
-unfold half.
-assert (H: forall x y, x == y -> E2 (half_aux x) (half_aux y)).
-intros x y Exy; unfold half_aux; apply recursion_wd with (Aeq := E2); unfold E2.
-unfold E2.
-unfold prod_rel; simpl; now split.
-unfold fun2_eq, prod_rel; simpl.
-intros _ _ _ p1 p2; destruct p1; destruct p2; simpl.
-intros [H1 H2]; split; [rewrite H2 | assumption]. reflexivity. assumption.
-unfold E2, prod_rel in H. intros x y Exy; apply H in Exy.
-exact (proj2 Exy).
+unfold half_aux. rewrite recursion_0; auto.
 Qed.
 
+Lemma half_aux_succ : forall x,
+ half_aux (S x) = (S (snd (half_aux x)), fst (half_aux x)).
+Proof.
+intros.
+remember (half_aux x) as h.
+destruct h as (f,s); simpl in *.
+unfold half_aux in *.
+rewrite recursion_succ, <- Heqh; simpl; auto.
+repeat red; intros; subst; auto.
+Qed.
+
+Theorem half_aux_spec : forall n,
+ n == fst (half_aux n) + snd (half_aux n).
+Proof.
+apply induction.
+intros x x' Hx. setoid_rewrite Hx; auto with *.
+rewrite half_aux_0; simpl; rewrite add_0_l; auto with *.
+intros.
+rewrite half_aux_succ. simpl.
+rewrite add_succ_l, add_comm; auto.
+apply succ_wd; auto.
+Qed.
+
+Theorem half_aux_spec2 : forall n,
+ fst (half_aux n) == snd (half_aux n) \/
+ fst (half_aux n) == S (snd (half_aux n)).
+Proof.
+apply induction.
+intros x x' Hx. setoid_rewrite Hx; auto with *.
+rewrite half_aux_0; simpl. auto with *.
+intros.
+rewrite half_aux_succ; simpl.
+destruct H; auto with *.
+right; apply succ_wd; auto with *.
+Qed.
+
+Theorem half_0 : half 0 == 0.
+Proof.
+unfold half. rewrite half_aux_0; simpl; auto with *.
+Qed.
+
+Theorem half_1 : half 1 == 0.
+Proof.
+unfold half. rewrite half_aux_succ, half_aux_0; simpl; auto with *.
+Qed.
+
+Theorem half_double : forall n,
+ n == 2 * half n \/ n == 1 + 2 * half n.
+Proof.
+intros. unfold half.
+nzsimpl.
+destruct (half_aux_spec2 n) as [H|H]; [left|right].
+rewrite <- H at 1. apply half_aux_spec.
+rewrite <- add_succ_l. rewrite <- H at 1. apply half_aux_spec.
+Qed.
+
+Theorem half_upper_bound : forall n, 2 * half n <= n.
+Proof.
+intros.
+destruct (half_double n) as [E|E]; rewrite E at 2.
+apply le_refl.
+nzsimpl.
+apply le_le_succ_r, le_refl.
+Qed.
+
+Theorem half_lower_bound : forall n, n <= 1 + 2 * half n.
+Proof.
+intros.
+destruct (half_double n) as [E|E]; rewrite E at 1.
+nzsimpl.
+apply le_le_succ_r, le_refl.
+apply le_refl.
+Qed.
+
+Theorem half_nz : forall n, 1 < n -> 0 < half n.
+Proof.
+intros n LT.
+assert (LE : 0 <= half n) by apply le_0_l.
+le_elim LE; auto.
+destruct (half_double n) as [E|E];
+ rewrite <- LE, mul_0_r, ?add_0_r in E; rewrite E in LT.
+destruct (nlt_0_r _ LT).
+rewrite <- succ_lt_mono in LT.
+destruct (nlt_0_r _ LT).
+Qed.
+
+Theorem half_decrease : forall n, 0 < n -> half n < n.
+Proof.
+intros n LT.
+destruct (half_double n) as [E|E]; rewrite E at 2;
+ rewrite ?mul_succ_l, ?mul_0_l, ?add_0_l, ?add_assoc.
+rewrite <- add_0_l at 1.
+rewrite <- add_lt_mono_r.
+assert (LE : 0 <= half n) by apply le_0_l.
+le_elim LE; auto.
+rewrite <- LE, mul_0_r in E. rewrite E in LT. destruct (nlt_0_r _ LT).
+rewrite <- add_0_l at 1.
+rewrite <- add_lt_mono_r.
+rewrite add_succ_l. apply lt_0_succ.
+Qed.
+
+
+(*****************************************************)
+(**            Power                                 *)
+
+Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m.
+
+Local Infix "^^" := pow (at level 30, right associativity).
+
+Instance pow_prewd :
+ Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun n _ r => n*r).
+Proof.
+intros n n' Hn x x' Hx y y' Hy. rewrite Hn, Hy; auto with *.
+Qed.
+
+Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow.
+Proof.
+intros n n' Hn m m' Hm. unfold pow.
+apply recursion_wd; auto with *.
+now apply pow_prewd.
+Qed.
+
+Lemma pow_0 : forall n, n^^0 == 1.
+Proof.
+intros. unfold pow. rewrite recursion_0. auto with *.
+Qed.
+
+Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m).
+Proof.
+intros. unfold pow. rewrite recursion_succ; auto with *.
+now apply pow_prewd.
+Qed.
+
+
 (*****************************************************)
 (**            Logarithm for the base 2              *)
 
-Definition log (x : N) : N :=
+Definition log (x : N.t) : N.t :=
 strong_rec 0
-           (fun x g =>
-              if (e x 0) then 0
-              else if (e x 1) then 0
+           (fun g x =>
+              if x << 2 then 0
               else S (g (half x)))
            x.
 
-Add Morphism log with signature Neq ==> Neq as log_wd.
+Instance log_prewd :
+ Proper ((N.eq==>N.eq)==>N.eq==>N.eq)
+   (fun g x => if x<<2 then 0 else S (g (half x))).
+Proof.
+intros g g' Hg n n' Hn.
+rewrite Hn.
+destruct (n' << 2); auto with *.
+apply succ_wd.
+apply Hg. rewrite Hn; auto with *.
+Qed.
+
+Instance log_wd : Proper (N.eq==>N.eq) log.
 Proof.
 intros x x' Exx'. unfold log.
-apply strong_rec_wd with (Aeq := Neq); try (reflexivity || assumption).
-unfold fun2_eq. intros y y' Eyy' g g' Egg'.
-assert (H : e y 0 = e y' 0); [now apply e_wd|].
-rewrite <- H; clear H.
-assert (H : e y 1 = e y' 1); [now apply e_wd|].
-rewrite <- H; clear H.
-assert (H : S (g (half y)) == S (g' (half y')));
-[apply succ_wd; apply Egg'; now apply half_wd|].
-now destruct (e y 0); destruct (e y 1).
+apply strong_rec_wd; auto with *.
+apply log_prewd.
 Qed.
+
+Lemma log_good_step : forall n h1 h2,
+ (forall m, m < n -> h1 m == h2 m) ->
+  (if n << 2 then 0 else S (h1 (half n))) ==
+  (if n << 2 then 0 else S (h2 (half n))).
+Proof.
+intros n h1 h2 E.
+destruct (n<<2) as [ ]_eqn:H.
+auto with *.
+apply succ_wd, E, half_decrease.
+rewrite <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H.
+apply lt_succ_l; auto.
+Qed.
+Hint Resolve log_good_step.
+
+Theorem log_init : forall n, n < 2 -> log n == 0.
+Proof.
+intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *.
+replace (n << 2) with true; auto with *.
+symmetry. now rewrite ltb_lt.
+Qed.
+
+Theorem log_step : forall n, 2 <= n -> log n == S (log (half n)).
+Proof.
+intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *.
+replace (n << 2) with false; auto with *.
+symmetry. rewrite <- not_true_iff_false, ltb_lt, nlt_ge; auto.
+Qed.
+
+Theorem pow2_log : forall n, 0 < n -> half n < 2^^(log n) <= n.
+Proof.
+intro n; generalize (le_refl n). set (k:=n) at -2. clearbody k.
+revert k. pattern n. apply induction; clear n.
+intros n n' Hn; setoid_rewrite Hn; auto with *.
+intros k Hk1 Hk2.
+ le_elim Hk1. destruct (nlt_0_r _ Hk1).
+ rewrite Hk1 in Hk2. destruct (nlt_0_r _ Hk2).
+
+intros n IH k Hk1 Hk2.
+destruct (lt_ge_cases k 2) as [LT|LE].
+(* base *)
+rewrite log_init, pow_0 by auto.
+rewrite <- le_succ_l in Hk2.
+le_elim Hk2.
+rewrite <- nle_gt, le_succ_l in LT. destruct LT; auto.
+rewrite <- Hk2.
+rewrite half_1; auto using lt_0_1, le_refl.
+(* step *)
+rewrite log_step, pow_succ by auto.
+rewrite le_succ_l in LE.
+destruct (IH (half k)) as (IH1,IH2).
+ rewrite <- lt_succ_r. apply lt_le_trans with k; auto.
+  now apply half_decrease.
+ apply half_nz; auto.
+set (K:=2^^log (half k)) in *; clearbody K.
+split.
+rewrite <- le_succ_l in IH1.
+apply mul_le_mono_l with (p:=2) in IH1.
+eapply lt_le_trans; eauto.
+nzsimpl.
+rewrite lt_succ_r.
+eapply le_trans; [ eapply half_lower_bound | ].
+nzsimpl; apply le_refl.
+eapply le_trans; [ | eapply half_upper_bound ].
+apply mul_le_mono_l; auto.
+Qed.
+
+(** Later:
+
+Theorem log_mul : forall n m, 0 < n -> 0 < m ->
+ log (n*m) == log n + log m.
+
+Theorem log_pow2 : forall n, log (2^^n) = n.
+
 *)
+
 End NdefOpsPropFunct.
 
diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v
new file mode 100644
index 00000000..0cb5665a
--- /dev/null
+++ b/theories/Numbers/Natural/Abstract/NDiv.v
@@ -0,0 +1,239 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Euclidean Division *)
+
+Require Import NAxioms NProperties NZDiv.
+
+Module Type NDivSpecific (Import N : NAxiomsSig')(Import DM : DivMod' N).
+ Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b.
+End NDivSpecific.
+
+Module Type NDivSig := NAxiomsSig <+ DivMod <+ NZDivCommon <+ NDivSpecific.
+Module Type NDivSig' := NAxiomsSig' <+ DivMod' <+ NZDivCommon <+ NDivSpecific.
+
+Module NDivPropFunct (Import N : NDivSig')(Import NP : NPropSig N).
+
+(** We benefit from what already exists for NZ *)
+
+ Module ND <: NZDiv N.
+  Definition div := div.
+  Definition modulo := modulo.
+  Definition div_wd := div_wd.
+  Definition mod_wd := mod_wd.
+  Definition div_mod := div_mod.
+  Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
+  Proof. split. apply le_0_l. apply mod_upper_bound. order. Qed.
+ End ND.
+ Module Import NZDivP := NZDivPropFunct N NP ND.
+
+ Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l.
+
+(** Let's now state again theorems, but without useless hypothesis. *)
+
+(** Uniqueness theorems *)
+
+Theorem div_mod_unique :
+ forall b q1 q2 r1 r2, r1<b -> r2<b ->
+  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
+Proof. intros. apply div_mod_unique with b; auto'. Qed.
+
+Theorem div_unique:
+ forall a b q r, r<b -> a == b*q + r -> q == a/b.
+Proof. intros; apply div_unique with r; auto'. Qed.
+
+Theorem mod_unique:
+ forall a b q r, r<b -> a == b*q + r -> r == a mod b.
+Proof. intros. apply mod_unique with q; auto'. Qed.
+
+(** A division by itself returns 1 *)
+
+Lemma div_same : forall a, a~=0 -> a/a == 1.
+Proof. intros. apply div_same; auto'. Qed.
+
+Lemma mod_same : forall a, a~=0 -> a mod a == 0.
+Proof. intros. apply mod_same; auto'. Qed.
+
+(** A division of a small number by a bigger one yields zero. *)
+
+Theorem div_small: forall a b, a<b -> a/b == 0.
+Proof. intros. apply div_small; auto'. Qed.
+
+(** Same situation, in term of modulo: *)
+
+Theorem mod_small: forall a b, a<b -> a mod b == a.
+Proof. intros. apply mod_small; auto'. Qed.
+
+(** * Basic values of divisions and modulo. *)
+
+Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
+Proof. intros. apply div_0_l; auto'. Qed.
+
+Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
+Proof. intros. apply mod_0_l; auto'. Qed.
+
+Lemma div_1_r: forall a, a/1 == a.
+Proof. intros. apply div_1_r; auto'. Qed.
+
+Lemma mod_1_r: forall a, a mod 1 == 0.
+Proof. intros. apply mod_1_r; auto'. Qed.
+
+Lemma div_1_l: forall a, 1<a -> 1/a == 0.
+Proof. exact div_1_l. Qed.
+
+Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
+Proof. exact mod_1_l. Qed.
+
+Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
+Proof. intros. apply div_mul; auto'. Qed.
+
+Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
+Proof. intros. apply mod_mul; auto'. Qed.
+
+
+(** * Order results about mod and div *)
+
+(** A modulo cannot grow beyond its starting point. *)
+
+Theorem mod_le: forall a b, b~=0 -> a mod b <= a.
+Proof. intros. apply mod_le; auto'. Qed.
+
+Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
+Proof. exact div_str_pos. Qed.
+
+Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a<b).
+Proof. intros. apply div_small_iff; auto'. Qed.
+
+Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> a<b).
+Proof. intros. apply mod_small_iff; auto'. Qed.
+
+Lemma div_str_pos_iff : forall a b, b~=0 -> (0<a/b <-> b<=a).
+Proof. intros. apply div_str_pos_iff; auto'. Qed.
+
+
+(** As soon as the divisor is strictly greater than 1,
+    the division is strictly decreasing. *)
+
+Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
+Proof. exact div_lt. Qed.
+
+(** [le] is compatible with a positive division. *)
+
+Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c.
+Proof. intros. apply div_le_mono; auto'. Qed.
+
+Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
+Proof. intros. apply mul_div_le; auto'. Qed.
+
+Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)).
+Proof. intros; apply mul_succ_div_gt; auto'. Qed.
+
+(** The previous inequality is exact iff the modulo is zero. *)
+
+Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
+Proof. intros. apply div_exact; auto'. Qed.
+
+(** Some additionnal inequalities about div. *)
+
+Theorem div_lt_upper_bound:
+  forall a b q, b~=0 -> a < b*q -> a/b < q.
+Proof. intros. apply div_lt_upper_bound; auto'. Qed.
+
+Theorem div_le_upper_bound:
+  forall a b q, b~=0 -> a <= b*q -> a/b <= q.
+Proof. intros; apply div_le_upper_bound; auto'. Qed.
+
+Theorem div_le_lower_bound:
+  forall a b q, b~=0 -> b*q <= a -> q <= a/b.
+Proof. intros; apply div_le_lower_bound; auto'. Qed.
+
+(** A division respects opposite monotonicity for the divisor *)
+
+Lemma div_le_compat_l: forall p q r, 0<q<=r -> p/r <= p/q.
+Proof. intros. apply div_le_compat_l. auto'. auto. Qed.
+
+(** * Relations between usual operations and mod and div *)
+
+Lemma mod_add : forall a b c, c~=0 ->
+ (a + b * c) mod c == a mod c.
+Proof. intros. apply mod_add; auto'. Qed.
+
+Lemma div_add : forall a b c, c~=0 ->
+ (a + b * c) / c == a / c + b.
+Proof. intros. apply div_add; auto'. Qed.
+
+Lemma div_add_l: forall a b c, b~=0 ->
+ (a * b + c) / b == a + c / b.
+Proof. intros. apply div_add_l; auto'. Qed.
+
+(** Cancellations. *)
+
+Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
+ (a*c)/(b*c) == a/b.
+Proof. intros. apply div_mul_cancel_r; auto'. Qed.
+
+Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
+ (c*a)/(c*b) == a/b.
+Proof. intros. apply div_mul_cancel_l; auto'. Qed.
+
+Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 ->
+  (a*c) mod (b*c) == (a mod b) * c.
+Proof. intros. apply mul_mod_distr_r; auto'. Qed.
+
+Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 ->
+  (c*a) mod (c*b) == c * (a mod b).
+Proof. intros. apply mul_mod_distr_l; auto'. Qed.
+
+(** Operations modulo. *)
+
+Theorem mod_mod: forall a n, n~=0 ->
+ (a mod n) mod n == a mod n.
+Proof. intros. apply mod_mod; auto'. Qed.
+
+Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)*b) mod n == (a*b) mod n.
+Proof. intros. apply mul_mod_idemp_l; auto'. Qed.
+
+Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
+ (a*(b mod n)) mod n == (a*b) mod n.
+Proof. intros. apply mul_mod_idemp_r; auto'. Qed.
+
+Theorem mul_mod: forall a b n, n~=0 ->
+ (a * b) mod n == ((a mod n) * (b mod n)) mod n.
+Proof. intros. apply mul_mod; auto'. Qed.
+
+Lemma add_mod_idemp_l : forall a b n, n~=0 ->
+ ((a mod n)+b) mod n == (a+b) mod n.
+Proof. intros. apply add_mod_idemp_l; auto'. Qed.
+
+Lemma add_mod_idemp_r : forall a b n, n~=0 ->
+ (a+(b mod n)) mod n == (a+b) mod n.
+Proof. intros. apply add_mod_idemp_r; auto'. Qed.
+
+Theorem add_mod: forall a b n, n~=0 ->
+ (a+b) mod n == (a mod n + b mod n) mod n.
+Proof. intros. apply add_mod; auto'. Qed.
+
+Lemma div_div : forall a b c, b~=0 -> c~=0 ->
+ (a/b)/c == a/(b*c).
+Proof. intros. apply div_div; auto'. Qed.
+
+(** A last inequality: *)
+
+Theorem div_mul_le:
+ forall a b c, b~=0 -> c*(a/b) <= (c*a)/b.
+Proof. intros. apply div_mul_le; auto'. Qed.
+
+(** mod is related to divisibility *)
+
+Lemma mod_divides : forall a b, b~=0 ->
+ (a mod b == 0 <-> exists c, a == b*c).
+Proof. intros. apply mod_divides; auto'. Qed.
+
+End NDivPropFunct.
+
diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v
index f6ccf3db..47bf38cb 100644
--- a/theories/Numbers/Natural/Abstract/NIso.v
+++ b/theories/Numbers/Natural/Abstract/NIso.v
@@ -8,51 +8,41 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NIso.v 10934 2008-05-15 21:58:20Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import NBase.
 
-Module Homomorphism (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig).
+Module Homomorphism (N1 N2 : NAxiomsSig).
 
-Module NBasePropMod2 := NBasePropFunct NAxiomsMod2.
+Local Notation "n == m" := (N2.eq n m) (at level 70, no associativity).
 
-Notation Local N1 := NAxiomsMod1.N.
-Notation Local N2 := NAxiomsMod2.N.
-Notation Local Eq1 := NAxiomsMod1.Neq.
-Notation Local Eq2 := NAxiomsMod2.Neq.
-Notation Local O1 := NAxiomsMod1.N0.
-Notation Local O2 := NAxiomsMod2.N0.
-Notation Local S1 := NAxiomsMod1.S.
-Notation Local S2 := NAxiomsMod2.S.
-Notation Local "n == m" := (Eq2 n m) (at level 70, no associativity).
+Definition homomorphism (f : N1.t -> N2.t) : Prop :=
+  f N1.zero == N2.zero /\ forall n, f (N1.succ n) == N2.succ (f n).
 
-Definition homomorphism (f : N1 -> N2) : Prop :=
-  f O1 == O2 /\ forall n : N1, f (S1 n) == S2 (f n).
+Definition natural_isomorphism : N1.t -> N2.t :=
+  N1.recursion N2.zero (fun (n : N1.t) (p : N2.t) => N2.succ p).
 
-Definition natural_isomorphism : N1 -> N2 :=
-  NAxiomsMod1.recursion O2 (fun (n : N1) (p : N2) => S2 p).
-
-Add Morphism natural_isomorphism with signature Eq1 ==> Eq2 as natural_isomorphism_wd.
+Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism.
 Proof.
 unfold natural_isomorphism.
 intros n m Eqxy.
-apply NAxiomsMod1.recursion_wd with (Aeq := Eq2).
+apply N1.recursion_wd.
 reflexivity.
-unfold fun2_eq. intros _ _ _ y' y'' H. now apply NBasePropMod2.succ_wd.
+intros _ _ _ y' y'' H. now apply N2.succ_wd.
 assumption.
 Qed.
 
-Theorem natural_isomorphism_0 : natural_isomorphism O1 == O2.
+Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero.
 Proof.
-unfold natural_isomorphism; now rewrite NAxiomsMod1.recursion_0.
+unfold natural_isomorphism; now rewrite N1.recursion_0.
 Qed.
 
 Theorem natural_isomorphism_succ :
-  forall n : N1, natural_isomorphism (S1 n) == S2 (natural_isomorphism n).
+  forall n : N1.t, natural_isomorphism (N1.succ n) == N2.succ (natural_isomorphism n).
 Proof.
 unfold natural_isomorphism.
-intro n. now rewrite (@NAxiomsMod1.recursion_succ N2 NAxiomsMod2.Neq) ;
-[ | | unfold fun2_wd; intros; apply NBasePropMod2.succ_wd].
+intro n. rewrite N1.recursion_succ; auto with *.
+repeat red; intros. apply N2.succ_wd; auto.
 Qed.
 
 Theorem hom_nat_iso : homomorphism natural_isomorphism.
@@ -63,23 +53,20 @@ Qed.
 
 End Homomorphism.
 
-Module Inverse (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig).
+Module Inverse (N1 N2 : NAxiomsSig).
 
-Module Import NBasePropMod1 := NBasePropFunct NAxiomsMod1.
+Module Import NBasePropMod1 := NBasePropFunct N1.
 (* This makes the tactic induct available. Since it is taken from
 (NBasePropFunct NAxiomsMod1), it refers to induction on N1. *)
 
-Module Hom12 := Homomorphism NAxiomsMod1 NAxiomsMod2.
-Module Hom21 := Homomorphism NAxiomsMod2 NAxiomsMod1.
-
-Notation Local N1 := NAxiomsMod1.N.
-Notation Local N2 := NAxiomsMod2.N.
-Notation Local h12 := Hom12.natural_isomorphism.
-Notation Local h21 := Hom21.natural_isomorphism.
+Module Hom12 := Homomorphism N1 N2.
+Module Hom21 := Homomorphism N2 N1.
 
-Notation Local "n == m" := (NAxiomsMod1.Neq n m) (at level 70, no associativity).
+Local Notation h12 := Hom12.natural_isomorphism.
+Local Notation h21 := Hom21.natural_isomorphism.
+Local Notation "n == m" := (N1.eq n m) (at level 70, no associativity).
 
-Lemma inverse_nat_iso : forall n : N1, h21 (h12 n) == n.
+Lemma inverse_nat_iso : forall n : N1.t, h21 (h12 n) == n.
 Proof.
 induct n.
 now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0.
@@ -89,25 +76,20 @@ Qed.
 
 End Inverse.
 
-Module Isomorphism (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig).
-
-Module Hom12 := Homomorphism NAxiomsMod1 NAxiomsMod2.
-Module Hom21 := Homomorphism NAxiomsMod2 NAxiomsMod1.
+Module Isomorphism (N1 N2 : NAxiomsSig).
 
-Module Inverse12 := Inverse NAxiomsMod1 NAxiomsMod2.
-Module Inverse21 := Inverse NAxiomsMod2 NAxiomsMod1.
+Module Hom12 := Homomorphism N1 N2.
+Module Hom21 := Homomorphism N2 N1.
+Module Inverse12 := Inverse N1 N2.
+Module Inverse21 := Inverse N2 N1.
 
-Notation Local N1 := NAxiomsMod1.N.
-Notation Local N2 := NAxiomsMod2.N.
-Notation Local Eq1 := NAxiomsMod1.Neq.
-Notation Local Eq2 := NAxiomsMod2.Neq.
-Notation Local h12 := Hom12.natural_isomorphism.
-Notation Local h21 := Hom21.natural_isomorphism.
+Local Notation h12 := Hom12.natural_isomorphism.
+Local Notation h21 := Hom21.natural_isomorphism.
 
-Definition isomorphism (f1 : N1 -> N2) (f2 : N2 -> N1) : Prop :=
+Definition isomorphism (f1 : N1.t -> N2.t) (f2 : N2.t -> N1.t) : Prop :=
   Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\
-  forall n : N1, Eq1 (f2 (f1 n)) n /\
-  forall n : N2, Eq2 (f1 (f2 n)) n.
+  forall n, N1.eq (f2 (f1 n)) n /\
+  forall n, N2.eq (f1 (f2 n)) n.
 
 Theorem iso_nat_iso : isomorphism h12 h21.
 Proof.
diff --git a/theories/Numbers/Natural/Abstract/NMul.v b/theories/Numbers/Natural/Abstract/NMul.v
deleted file mode 100644
index 0b00f689..00000000
--- a/theories/Numbers/Natural/Abstract/NMul.v
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                      Evgeny Makarov, INRIA, 2007                     *)
-(************************************************************************)
-
-(*i $Id: NMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
-
-Require Export NAdd.
-
-Module NMulPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NAddPropMod := NAddPropFunct NAxiomsMod.
-Open Local Scope NatScope.
-
-Theorem mul_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 * m1 == n2 * m2.
-Proof NZmul_wd.
-
-Theorem mul_0_l : forall n : N, 0 * n == 0.
-Proof NZmul_0_l.
-
-Theorem mul_succ_l : forall n m : N, (S n) * m == n * m + m.
-Proof NZmul_succ_l.
-
-(** Theorems that are valid for both natural numbers and integers *)
-
-Theorem mul_0_r : forall n, n * 0 == 0.
-Proof NZmul_0_r.
-
-Theorem mul_succ_r : forall n m, n * (S m) == n * m + n.
-Proof NZmul_succ_r.
-
-Theorem mul_comm : forall n m : N, n * m == m * n.
-Proof NZmul_comm.
-
-Theorem mul_add_distr_r : forall n m p : N, (n + m) * p == n * p + m * p.
-Proof NZmul_add_distr_r.
-
-Theorem mul_add_distr_l : forall n m p : N, n * (m + p) == n * m + n * p.
-Proof NZmul_add_distr_l.
-
-Theorem mul_assoc : forall n m p : N, n * (m * p) == (n * m) * p.
-Proof NZmul_assoc.
-
-Theorem mul_1_l : forall n : N, 1 * n == n.
-Proof NZmul_1_l.
-
-Theorem mul_1_r : forall n : N, n * 1 == n.
-Proof NZmul_1_r.
-
-(* Theorems that cannot be proved in NZMul *)
-
-(* In proving the correctness of the definition of multiplication on
-integers constructed from pairs of natural numbers, we'll need the
-following fact about natural numbers:
-
-a * n + u == a * m + v -> n + m' == n' + m -> a * n' + u = a * m' + v
-
-Here n + m' == n' + m expresses equality of integers (n, m) and (n', m'),
-since a pair (a, b) of natural numbers represents the integer a - b. On
-integers, the formula above could be proved by moving a * m to the left,
-factoring out a and replacing n - m by n' - m'. However, the formula is
-required in the process of constructing integers, so it has to be proved
-for natural numbers, where terms cannot be moved from one side of an
-equation to the other. The proof uses the cancellation laws add_cancel_l
-and add_cancel_r. *)
-
-Theorem add_mul_repl_pair : forall a n m n' m' u v : N,
-  a * n + u == a * m + v -> n + m' == n' + m -> a * n' + u == a * m' + v.
-Proof.
-intros a n m n' m' u v H1 H2.
-apply (@NZmul_wd a a) in H2; [| reflexivity].
-do 2 rewrite mul_add_distr_l in H2. symmetry in H2.
-pose proof (NZadd_wd _ _ H1 _ _ H2) as H3.
-rewrite (add_shuffle1 (a * m)), (add_comm (a * m) (a * n)) in H3.
-do 2 rewrite <- add_assoc in H3. apply -> add_cancel_l in H3.
-rewrite (add_assoc u), (add_comm (a * m)) in H3.
-apply -> add_cancel_r in H3.
-now rewrite (add_comm (a * n') u), (add_comm (a * m') v).
-Qed.
-
-End NMulPropFunct.
-
diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v
index aa21fb50..a2162b13 100644
--- a/theories/Numbers/Natural/Abstract/NMulOrder.v
+++ b/theories/Numbers/Natural/Abstract/NMulOrder.v
@@ -8,122 +8,71 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export NAddOrder.
 
-Module NMulOrderPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NAddOrderPropMod := NAddOrderPropFunct NAxiomsMod.
-Open Local Scope NatScope.
+Module NMulOrderPropFunct (Import N : NAxiomsSig').
+Include NAddOrderPropFunct N.
 
-Theorem mul_lt_pred :
-  forall p q n m : N, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
-Proof NZmul_lt_pred.
+(** Theorems that are either not valid on Z or have different proofs
+    on N and Z *)
 
-Theorem mul_lt_mono_pos_l : forall p n m : N, 0 < p -> (n < m <-> p * n < p * m).
-Proof NZmul_lt_mono_pos_l.
-
-Theorem mul_lt_mono_pos_r : forall p n m : N, 0 < p -> (n < m <-> n * p < m * p).
-Proof NZmul_lt_mono_pos_r.
-
-Theorem mul_cancel_l : forall n m p : N, p ~= 0 -> (p * n == p * m <-> n == m).
-Proof NZmul_cancel_l.
-
-Theorem mul_cancel_r : forall n m p : N, p ~= 0 -> (n * p == m * p <-> n == m).
-Proof NZmul_cancel_r.
-
-Theorem mul_id_l : forall n m : N, m ~= 0 -> (n * m == m <-> n == 1).
-Proof NZmul_id_l.
-
-Theorem mul_id_r : forall n m : N, n ~= 0 -> (n * m == n <-> m == 1).
-Proof NZmul_id_r.
-
-Theorem mul_le_mono_pos_l : forall n m p : N, 0 < p -> (n <= m <-> p * n <= p * m).
-Proof NZmul_le_mono_pos_l.
-
-Theorem mul_le_mono_pos_r : forall n m p : N, 0 < p -> (n <= m <-> n * p <= m * p).
-Proof NZmul_le_mono_pos_r.
-
-Theorem mul_pos_pos : forall n m : N, 0 < n -> 0 < m -> 0 < n * m.
-Proof NZmul_pos_pos.
-
-Theorem lt_1_mul_pos : forall n m : N, 1 < n -> 0 < m -> 1 < n * m.
-Proof NZlt_1_mul_pos.
-
-Theorem eq_mul_0 : forall n m : N, n * m == 0 <-> n == 0 \/ m == 0.
-Proof NZeq_mul_0.
-
-Theorem neq_mul_0 : forall n m : N, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
-Proof NZneq_mul_0.
-
-Theorem eq_square_0 : forall n : N, n * n == 0 <-> n == 0.
-Proof NZeq_square_0.
-
-Theorem eq_mul_0_l : forall n m : N, n * m == 0 -> m ~= 0 -> n == 0.
-Proof NZeq_mul_0_l.
-
-Theorem eq_mul_0_r : forall n m : N, n * m == 0 -> n ~= 0 -> m == 0.
-Proof NZeq_mul_0_r.
-
-Theorem square_lt_mono : forall n m : N, n < m <-> n * n < m * m.
+Theorem square_lt_mono : forall n m, n < m <-> n * n < m * m.
 Proof.
 intros n m; split; intro;
-[apply NZsquare_lt_mono_nonneg | apply NZsquare_lt_simpl_nonneg];
+[apply square_lt_mono_nonneg | apply square_lt_simpl_nonneg];
 try assumption; apply le_0_l.
 Qed.
 
-Theorem square_le_mono : forall n m : N, n <= m <-> n * n <= m * m.
+Theorem square_le_mono : forall n m, n <= m <-> n * n <= m * m.
 Proof.
 intros n m; split; intro;
-[apply NZsquare_le_mono_nonneg | apply NZsquare_le_simpl_nonneg];
+[apply square_le_mono_nonneg | apply square_le_simpl_nonneg];
 try assumption; apply le_0_l.
 Qed.
 
-Theorem mul_2_mono_l : forall n m : N, n < m -> 1 + (1 + 1) * n < (1 + 1) * m.
-Proof NZmul_2_mono_l.
-
-(* Theorems that are either not valid on Z or have different proofs on N and Z *)
-
-Theorem mul_le_mono_l : forall n m p : N, n <= m -> p * n <= p * m.
+Theorem mul_le_mono_l : forall n m p, n <= m -> p * n <= p * m.
 Proof.
-intros; apply NZmul_le_mono_nonneg_l. apply le_0_l. assumption.
+intros; apply mul_le_mono_nonneg_l. apply le_0_l. assumption.
 Qed.
 
-Theorem mul_le_mono_r : forall n m p : N, n <= m -> n * p <= m * p.
+Theorem mul_le_mono_r : forall n m p, n <= m -> n * p <= m * p.
 Proof.
-intros; apply NZmul_le_mono_nonneg_r. apply le_0_l. assumption.
+intros; apply mul_le_mono_nonneg_r. apply le_0_l. assumption.
 Qed.
 
-Theorem mul_lt_mono : forall n m p q : N, n < m -> p < q -> n * p < m * q.
+Theorem mul_lt_mono : forall n m p q, n < m -> p < q -> n * p < m * q.
 Proof.
-intros; apply NZmul_lt_mono_nonneg; try assumption; apply le_0_l.
+intros; apply mul_lt_mono_nonneg; try assumption; apply le_0_l.
 Qed.
 
-Theorem mul_le_mono : forall n m p q : N, n <= m -> p <= q -> n * p <= m * q.
+Theorem mul_le_mono : forall n m p q, n <= m -> p <= q -> n * p <= m * q.
 Proof.
-intros; apply NZmul_le_mono_nonneg; try assumption; apply le_0_l.
+intros; apply mul_le_mono_nonneg; try assumption; apply le_0_l.
 Qed.
 
-Theorem lt_0_mul : forall n m : N, n * m > 0 <-> n > 0 /\ m > 0.
+Theorem lt_0_mul' : forall n m, n * m > 0 <-> n > 0 /\ m > 0.
 Proof.
 intros n m; split; [intro H | intros [H1 H2]].
-apply -> NZlt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split. false_hyp H1 nlt_0_r.
-now apply NZmul_pos_pos.
+apply -> lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split.
+ false_hyp H1 nlt_0_r.
+now apply mul_pos_pos.
 Qed.
 
-Notation mul_pos := lt_0_mul (only parsing).
+Notation mul_pos := lt_0_mul' (only parsing).
 
-Theorem eq_mul_1 : forall n m : N, n * m == 1 <-> n == 1 /\ m == 1.
+Theorem eq_mul_1 : forall n m, n * m == 1 <-> n == 1 /\ m == 1.
 Proof.
 intros n m.
 split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l].
-intro H; destruct (NZlt_trichotomy n 1) as [H1 | [H1 | H1]].
+intro H; destruct (lt_trichotomy n 1) as [H1 | [H1 | H1]].
 apply -> lt_1_r in H1. rewrite H1, mul_0_l in H. false_hyp H neq_0_succ.
 rewrite H1, mul_1_l in H; now split.
 destruct (eq_0_gt_0_cases m) as [H2 | H2].
 rewrite H2, mul_0_r in H; false_hyp H neq_0_succ.
 apply -> (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1.
-assert (H3 : 1 < n * m) by now apply (lt_1_l 0 m).
+assert (H3 : 1 < n * m) by now apply (lt_1_l m).
 rewrite H in H3; false_hyp H3 lt_irrefl.
 Qed.
 
diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v
index 15aed7ab..090c02ec 100644
--- a/theories/Numbers/Natural/Abstract/NOrder.v
+++ b/theories/Numbers/Natural/Abstract/NOrder.v
@@ -8,355 +8,62 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NOrder.v 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
-Require Export NMul.
+Require Export NAdd.
 
-Module NOrderPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NMulPropMod := NMulPropFunct NAxiomsMod.
-Open Local Scope NatScope.
+Module NOrderPropFunct (Import N : NAxiomsSig').
+Include NAddPropFunct N.
 
-(* The tactics le_less, le_equal and le_elim are inherited from NZOrder.v *)
-
-(* Axioms *)
-
-Theorem lt_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> (n1 < m1 <-> n2 < m2).
-Proof NZlt_wd.
-
-Theorem le_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> (n1 <= m1 <-> n2 <= m2).
-Proof NZle_wd.
-
-Theorem min_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> min n1 m1 == min n2 m2.
-Proof NZmin_wd.
-
-Theorem max_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> max n1 m1 == max n2 m2.
-Proof NZmax_wd.
-
-Theorem lt_eq_cases : forall n m : N, n <= m <-> n < m \/ n == m.
-Proof NZlt_eq_cases.
-
-Theorem lt_irrefl : forall n : N, ~ n < n.
-Proof NZlt_irrefl.
-
-Theorem lt_succ_r : forall n m : N, n < S m <-> n <= m.
-Proof NZlt_succ_r.
-
-Theorem min_l : forall n m : N, n <= m -> min n m == n.
-Proof NZmin_l.
-
-Theorem min_r : forall n m : N, m <= n -> min n m == m.
-Proof NZmin_r.
-
-Theorem max_l : forall n m : N, m <= n -> max n m == n.
-Proof NZmax_l.
-
-Theorem max_r : forall n m : N, n <= m -> max n m == m.
-Proof NZmax_r.
-
-(* Renaming theorems from NZOrder.v *)
-
-Theorem lt_le_incl : forall n m : N, n < m -> n <= m.
-Proof NZlt_le_incl.
-
-Theorem eq_le_incl : forall n m : N, n == m -> n <= m.
-Proof NZeq_le_incl.
-
-Theorem lt_neq : forall n m : N, n < m -> n ~= m.
-Proof NZlt_neq.
-
-Theorem le_neq : forall n m : N, n < m <-> n <= m /\ n ~= m.
-Proof NZle_neq.
-
-Theorem le_refl : forall n : N, n <= n.
-Proof NZle_refl.
-
-Theorem lt_succ_diag_r : forall n : N, n < S n.
-Proof NZlt_succ_diag_r.
-
-Theorem le_succ_diag_r : forall n : N, n <= S n.
-Proof NZle_succ_diag_r.
-
-Theorem lt_0_1 : 0 < 1.
-Proof NZlt_0_1.
-
-Theorem le_0_1 : 0 <= 1.
-Proof NZle_0_1.
-
-Theorem lt_lt_succ_r : forall n m : N, n < m -> n < S m.
-Proof NZlt_lt_succ_r.
-
-Theorem le_le_succ_r : forall n m : N, n <= m -> n <= S m.
-Proof NZle_le_succ_r.
-
-Theorem le_succ_r : forall n m : N, n <= S m <-> n <= m \/ n == S m.
-Proof NZle_succ_r.
-
-Theorem neq_succ_diag_l : forall n : N, S n ~= n.
-Proof NZneq_succ_diag_l.
-
-Theorem neq_succ_diag_r : forall n : N, n ~= S n.
-Proof NZneq_succ_diag_r.
-
-Theorem nlt_succ_diag_l : forall n : N, ~ S n < n.
-Proof NZnlt_succ_diag_l.
-
-Theorem nle_succ_diag_l : forall n : N, ~ S n <= n.
-Proof NZnle_succ_diag_l.
-
-Theorem le_succ_l : forall n m : N, S n <= m <-> n < m.
-Proof NZle_succ_l.
-
-Theorem lt_succ_l : forall n m : N, S n < m -> n < m.
-Proof NZlt_succ_l.
-
-Theorem succ_lt_mono : forall n m : N, n < m <-> S n < S m.
-Proof NZsucc_lt_mono.
-
-Theorem succ_le_mono : forall n m : N, n <= m <-> S n <= S m.
-Proof NZsucc_le_mono.
-
-Theorem lt_asymm : forall n m : N, n < m -> ~ m < n.
-Proof NZlt_asymm.
-
-Notation lt_ngt := lt_asymm (only parsing).
-
-Theorem lt_trans : forall n m p : N, n < m -> m < p -> n < p.
-Proof NZlt_trans.
-
-Theorem le_trans : forall n m p : N, n <= m -> m <= p -> n <= p.
-Proof NZle_trans.
-
-Theorem le_lt_trans : forall n m p : N, n <= m -> m < p -> n < p.
-Proof NZle_lt_trans.
-
-Theorem lt_le_trans : forall n m p : N, n < m -> m <= p -> n < p.
-Proof NZlt_le_trans.
-
-Theorem le_antisymm : forall n m : N, n <= m -> m <= n -> n == m.
-Proof NZle_antisymm.
-
-(** Trichotomy, decidability, and double negation elimination *)
-
-Theorem lt_trichotomy : forall n m : N,  n < m \/ n == m \/ m < n.
-Proof NZlt_trichotomy.
-
-Notation lt_eq_gt_cases := lt_trichotomy (only parsing).
-
-Theorem lt_gt_cases : forall n m : N, n ~= m <-> n < m \/ n > m.
-Proof NZlt_gt_cases.
-
-Theorem le_gt_cases : forall n m : N, n <= m \/ n > m.
-Proof NZle_gt_cases.
-
-Theorem lt_ge_cases : forall n m : N, n < m \/ n >= m.
-Proof NZlt_ge_cases.
-
-Theorem le_ge_cases : forall n m : N, n <= m \/ n >= m.
-Proof NZle_ge_cases.
-
-Theorem le_ngt : forall n m : N, n <= m <-> ~ n > m.
-Proof NZle_ngt.
-
-Theorem nlt_ge : forall n m : N, ~ n < m <-> n >= m.
-Proof NZnlt_ge.
-
-Theorem lt_dec : forall n m : N, decidable (n < m).
-Proof NZlt_dec.
-
-Theorem lt_dne : forall n m : N, ~ ~ n < m <-> n < m.
-Proof NZlt_dne.
-
-Theorem nle_gt : forall n m : N, ~ n <= m <-> n > m.
-Proof NZnle_gt.
-
-Theorem lt_nge : forall n m : N, n < m <-> ~ n >= m.
-Proof NZlt_nge.
-
-Theorem le_dec : forall n m : N, decidable (n <= m).
-Proof NZle_dec.
-
-Theorem le_dne : forall n m : N, ~ ~ n <= m <-> n <= m.
-Proof NZle_dne.
-
-Theorem nlt_succ_r : forall n m : N, ~ m < S n <-> n < m.
-Proof NZnlt_succ_r.
-
-Theorem lt_exists_pred :
-  forall z n : N, z < n -> exists k : N, n == S k /\ z <= k.
-Proof NZlt_exists_pred.
-
-Theorem lt_succ_iter_r :
-  forall (n : nat) (m : N), m < NZsucc_iter (Datatypes.S n) m.
-Proof NZlt_succ_iter_r.
-
-Theorem neq_succ_iter_l :
-  forall (n : nat) (m : N), NZsucc_iter (Datatypes.S n) m ~= m.
-Proof NZneq_succ_iter_l.
-
-(** Stronger variant of induction with assumptions n >= 0 (n < 0)
-in the induction step *)
-
-Theorem right_induction :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N, A z ->
-      (forall n : N, z <= n -> A n -> A (S n)) ->
-        forall n : N, z <= n -> A n.
-Proof NZright_induction.
-
-Theorem left_induction :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N, A z ->
-      (forall n : N, n < z -> A (S n) -> A n) ->
-        forall n : N, n <= z -> A n.
-Proof NZleft_induction.
-
-Theorem right_induction' :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N,
-      (forall n : N, n <= z -> A n) ->
-      (forall n : N, z <= n -> A n -> A (S n)) ->
-        forall n : N, A n.
-Proof NZright_induction'.
-
-Theorem left_induction' :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N,
-    (forall n : N, z <= n -> A n) ->
-    (forall n : N, n < z -> A (S n) -> A n) ->
-      forall n : N, A n.
-Proof NZleft_induction'.
-
-Theorem strong_right_induction :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N,
-    (forall n : N, z <= n -> (forall m : N, z <= m -> m < n -> A m) -> A n) ->
-       forall n : N, z <= n -> A n.
-Proof NZstrong_right_induction.
-
-Theorem strong_left_induction :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N,
-      (forall n : N, n <= z -> (forall m : N, m <= z -> S n <= m -> A m) -> A n) ->
-        forall n : N, n <= z -> A n.
-Proof NZstrong_left_induction.
-
-Theorem strong_right_induction' :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N,
-      (forall n : N, n <= z -> A n) ->
-      (forall n : N, z <= n -> (forall m : N, z <= m -> m < n -> A m) -> A n) ->
-        forall n : N, A n.
-Proof NZstrong_right_induction'.
-
-Theorem strong_left_induction' :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N,
-    (forall n : N, z <= n -> A n) ->
-    (forall n : N, n <= z -> (forall m : N, m <= z -> S n <= m -> A m) -> A n) ->
-      forall n : N, A n.
-Proof NZstrong_left_induction'.
-
-Theorem order_induction :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N, A z ->
-      (forall n : N, z <= n -> A n -> A (S n)) ->
-      (forall n : N, n < z  -> A (S n) -> A n) ->
-        forall n : N, A n.
-Proof NZorder_induction.
-
-Theorem order_induction' :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall z : N, A z ->
-      (forall n : N, z <= n -> A n -> A (S n)) ->
-      (forall n : N, n <= z -> A n -> A (P n)) ->
-        forall n : N, A n.
-Proof NZorder_induction'.
-
-(* We don't need order_induction_0 and order_induction'_0 (see NZOrder and
-ZOrder) since they boil down to regular induction *)
-
-(** Elimintation principle for < *)
-
-Theorem lt_ind :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall n : N,
-      A (S n) ->
-      (forall m : N, n < m -> A m -> A (S m)) ->
-        forall m : N, n < m -> A m.
-Proof NZlt_ind.
-
-(** Elimintation principle for <= *)
-
-Theorem le_ind :
-  forall A : N -> Prop, predicate_wd Neq A ->
-    forall n : N,
-      A n ->
-      (forall m : N, n <= m -> A m -> A (S m)) ->
-        forall m : N, n <= m -> A m.
-Proof NZle_ind.
-
-(** Well-founded relations *)
-
-Theorem lt_wf : forall z : N, well_founded (fun n m : N => z <= n /\ n < m).
-Proof NZlt_wf.
-
-Theorem gt_wf : forall z : N, well_founded (fun n m : N => m < n /\ n <= z).
-Proof NZgt_wf.
+(* Theorems that are true for natural numbers but not for integers *)
 
 Theorem lt_wf_0 : well_founded lt.
 Proof.
-setoid_replace lt with (fun n m : N => 0 <= n /\ n < m) 
-  using relation (@relations_eq N N).
+setoid_replace lt with (fun n m => 0 <= n /\ n < m).
 apply lt_wf.
 intros x y; split.
 intro H; split; [apply le_0_l | assumption]. now intros [_ H].
 Defined.
 
-(* Theorems that are true for natural numbers but not for integers *)
-
 (* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *)
 
-Theorem nlt_0_r : forall n : N, ~ n < 0.
+Theorem nlt_0_r : forall n, ~ n < 0.
 Proof.
 intro n; apply -> le_ngt. apply le_0_l.
 Qed.
 
-Theorem nle_succ_0 : forall n : N, ~ (S n <= 0).
+Theorem nle_succ_0 : forall n, ~ (S n <= 0).
 Proof.
 intros n H; apply -> le_succ_l in H; false_hyp H nlt_0_r.
 Qed.
 
-Theorem le_0_r : forall n : N, n <= 0 <-> n == 0.
+Theorem le_0_r : forall n, n <= 0 <-> n == 0.
 Proof.
 intros n; split; intro H.
 le_elim H; [false_hyp H nlt_0_r | assumption].
 now apply eq_le_incl.
 Qed.
 
-Theorem lt_0_succ : forall n : N, 0 < S n.
+Theorem lt_0_succ : forall n, 0 < S n.
 Proof.
 induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r].
 Qed.
 
-Theorem neq_0_lt_0 : forall n : N, n ~= 0 <-> 0 < n.
+Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n.
 Proof.
 cases n.
 split; intro H; [now elim H | intro; now apply lt_irrefl with 0].
 intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0].
 Qed.
 
-Theorem eq_0_gt_0_cases : forall n : N, n == 0 \/ 0 < n.
+Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n.
 Proof.
 cases n.
 now left.
 intro; right; apply lt_0_succ.
 Qed.
 
-Theorem zero_one : forall n : N, n == 0 \/ n == 1 \/ 1 < n.
+Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n.
 Proof.
 induct n. now left.
 cases n. intros; right; now left.
@@ -366,7 +73,7 @@ right; right. rewrite H. apply lt_succ_diag_r.
 right; right. now apply lt_lt_succ_r.
 Qed.
 
-Theorem lt_1_r : forall n : N, n < 1 <-> n == 0.
+Theorem lt_1_r : forall n, n < 1 <-> n == 0.
 Proof.
 cases n.
 split; intro; [reflexivity | apply lt_succ_diag_r].
@@ -374,7 +81,7 @@ intros n. rewrite <- succ_lt_mono.
 split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0].
 Qed.
 
-Theorem le_1_r : forall n : N, n <= 1 <-> n == 0 \/ n == 1.
+Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1.
 Proof.
 cases n.
 split; intro; [now left | apply le_succ_diag_r].
@@ -382,36 +89,30 @@ intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd.
 split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]].
 Qed.
 
-Theorem lt_lt_0 : forall n m : N, n < m -> 0 < m.
+Theorem lt_lt_0 : forall n m, n < m -> 0 < m.
 Proof.
 intros n m; induct n.
 trivial.
 intros n IH H. apply IH; now apply lt_succ_l.
 Qed.
 
-Theorem lt_1_l : forall n m p : N, n < m -> m < p -> 1 < p.
+Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p.
 Proof.
-intros n m p H1 H2.
-apply le_lt_trans with m. apply <- le_succ_l. apply le_lt_trans with n.
-apply le_0_l. assumption. assumption.
+intros. apply lt_1_l with m; auto.
+apply le_lt_trans with n; auto. now apply le_0_l.
 Qed.
 
 (** Elimination principlies for < and <= for relations *)
 
 Section RelElim.
 
-(* FIXME: Variable R : relation N. -- does not work *)
-
-Variable R : N -> N -> Prop.
-Hypothesis R_wd : relation_wd Neq Neq R.
-
-Add Morphism R with signature Neq ==> Neq ==> iff as R_morph2.
-Proof. apply R_wd. Qed.
+Variable R : relation N.t.
+Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.
 
 Theorem le_ind_rel :
-   (forall m : N, R 0 m) ->
-   (forall n m : N, n <= m -> R n m -> R (S n) (S m)) ->
-     forall n m : N, n <= m -> R n m.
+   (forall m, R 0 m) ->
+   (forall n m, n <= m -> R n m -> R (S n) (S m)) ->
+     forall n m, n <= m -> R n m.
 Proof.
 intros Base Step; induct n.
 intros; apply Base.
@@ -422,9 +123,9 @@ intros k H1 H2. apply -> le_succ_l in H1. apply lt_le_incl in H1. auto.
 Qed.
 
 Theorem lt_ind_rel :
-   (forall m : N, R 0 (S m)) ->
-   (forall n m : N, n < m -> R n m -> R (S n) (S m)) ->
-   forall n m : N, n < m -> R n m.
+   (forall m, R 0 (S m)) ->
+   (forall n m, n < m -> R n m -> R (S n) (S m)) ->
+   forall n m, n < m -> R n m.
 Proof.
 intros Base Step; induct n.
 intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]].
@@ -439,61 +140,64 @@ End RelElim.
 
 (** Predecessor and order *)
 
-Theorem succ_pred_pos : forall n : N, 0 < n -> S (P n) == n.
+Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n.
 Proof.
 intros n H; apply succ_pred; intro H1; rewrite H1 in H.
 false_hyp H lt_irrefl.
 Qed.
 
-Theorem le_pred_l : forall n : N, P n <= n.
+Theorem le_pred_l : forall n, P n <= n.
 Proof.
 cases n.
 rewrite pred_0; now apply eq_le_incl.
 intros; rewrite pred_succ;  apply le_succ_diag_r.
 Qed.
 
-Theorem lt_pred_l : forall n : N, n ~= 0 -> P n < n.
+Theorem lt_pred_l : forall n, n ~= 0 -> P n < n.
 Proof.
 cases n.
-intro H; elimtype False; now apply H.
+intro H; exfalso; now apply H.
 intros; rewrite pred_succ;  apply lt_succ_diag_r.
 Qed.
 
-Theorem le_le_pred : forall n m : N, n <= m -> P n <= m.
+Theorem le_le_pred : forall n m, n <= m -> P n <= m.
 Proof.
 intros n m H; apply le_trans with n. apply le_pred_l. assumption.
 Qed.
 
-Theorem lt_lt_pred : forall n m : N, n < m -> P n < m.
+Theorem lt_lt_pred : forall n m, n < m -> P n < m.
 Proof.
 intros n m H; apply le_lt_trans with n. apply le_pred_l. assumption.
 Qed.
 
-Theorem lt_le_pred : forall n m : N, n < m -> n <= P m. (* Converse is false for n == m == 0 *)
+Theorem lt_le_pred : forall n m, n < m -> n <= P m.
+ (* Converse is false for n == m == 0 *)
 Proof.
 intro n; cases m.
 intro H; false_hyp H nlt_0_r.
 intros m IH. rewrite pred_succ; now apply -> lt_succ_r.
 Qed.
 
-Theorem lt_pred_le : forall n m : N, P n < m -> n <= m. (* Converse is false for n == m == 0 *)
+Theorem lt_pred_le : forall n m, P n < m -> n <= m.
+ (* Converse is false for n == m == 0 *)
 Proof.
 intros n m; cases n.
 rewrite pred_0; intro H; now apply lt_le_incl.
 intros n IH. rewrite pred_succ in IH. now apply <- le_succ_l.
 Qed.
 
-Theorem lt_pred_lt : forall n m : N, n < P m -> n < m.
+Theorem lt_pred_lt : forall n m, n < P m -> n < m.
 Proof.
 intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l].
 Qed.
 
-Theorem le_pred_le : forall n m : N, n <= P m -> n <= m.
+Theorem le_pred_le : forall n m, n <= P m -> n <= m.
 Proof.
 intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l].
 Qed.
 
-Theorem pred_le_mono : forall n m : N, n <= m -> P n <= P m. (* Converse is false for n == 1, m == 0 *)
+Theorem pred_le_mono : forall n m, n <= m -> P n <= P m.
+ (* Converse is false for n == 1, m == 0 *)
 Proof.
 intros n m H; elim H using le_ind_rel.
 solve_relation_wd.
@@ -501,7 +205,7 @@ intro; rewrite pred_0; apply le_0_l.
 intros p q H1 _; now do 2 rewrite pred_succ.
 Qed.
 
-Theorem pred_lt_mono : forall n m : N, n ~= 0 -> (n < m <-> P n < P m).
+Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m).
 Proof.
 intros n m H1; split; intro H2.
 assert (m ~= 0). apply <- neq_0_lt_0. now apply lt_lt_0 with n.
@@ -512,22 +216,24 @@ apply lt_le_trans with (P m). assumption. apply le_pred_l.
 apply -> succ_lt_mono in H2. now do 2 rewrite succ_pred in H2.
 Qed.
 
-Theorem lt_succ_lt_pred : forall n m : N, S n < m <-> n < P m.
+Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m.
 Proof.
 intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ.
 Qed.
 
-Theorem le_succ_le_pred : forall n m : N, S n <= m -> n <= P m. (* Converse is false for n == m == 0 *)
+Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m.
+ (* Converse is false for n == m == 0 *)
 Proof.
 intros n m H. apply lt_le_pred. now apply -> le_succ_l.
 Qed.
 
-Theorem lt_pred_lt_succ : forall n m : N, P n < m -> n < S m. (* Converse is false for n == m == 0 *)
+Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m.
+ (* Converse is false for n == m == 0 *)
 Proof.
 intros n m H. apply <- lt_succ_r. now apply lt_pred_le.
 Qed.
 
-Theorem le_pred_le_succ : forall n m : N, P n <= m <-> n <= S m.
+Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m.
 Proof.
 intros n m; cases n.
 rewrite pred_0. split; intro H; apply le_0_l.
diff --git a/contrib/correctness/Programs_stuff.v b/theories/Numbers/Natural/Abstract/NProperties.v
index 6489de81..30262bd9 100644
--- a/contrib/correctness/Programs_stuff.v
+++ b/theories/Numbers/Natural/Abstract/NProperties.v
@@ -6,8 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+(*i $Id$ i*)
 
-(* $Id: Programs_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+Require Export NAxioms NSub.
 
-Require Export Arrays_stuff.
+(** This functor summarizes all known facts about N.
+    For the moment it is only an alias to [NSubPropFunct], which
+    subsumes all others.
+*)
+
+Module Type NPropSig := NSubPropFunct.
+
+Module NPropFunct (N:NAxiomsSig) <: NPropSig N.
+ Include NPropSig N.
+End NPropFunct.
diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v
index c6a6da48..cbbcdbff 100644
--- a/theories/Numbers/Natural/Abstract/NStrongRec.v
+++ b/theories/Numbers/Natural/Abstract/NStrongRec.v
@@ -8,123 +8,200 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NStrongRec.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** This file defined the strong (course-of-value, well-founded) recursion
 and proves its properties *)
 
 Require Export NSub.
 
-Module NStrongRecPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NSubPropMod := NSubPropFunct NAxiomsMod.
-Open Local Scope NatScope.
+Module NStrongRecPropFunct (Import N : NAxiomsSig').
+Include NSubPropFunct N.
 
 Section StrongRecursion.
 
-Variable A : Set.
+Variable A : Type.
 Variable Aeq : relation A.
+Variable Aeq_equiv : Equivalence Aeq.
+
+(** [strong_rec] allows to define a recursive function [phi] given by
+    an equation [phi(n) = F(phi)(n)] where recursive calls to [phi]
+    in [F] are made on strictly lower numbers than [n].
+
+    For [strong_rec a F n]:
+    - Parameter [a:A] is a default value used internally, it has no
+      effect on the final result.
+    - Parameter [F:(N->A)->N->A] is the step function:
+      [F f n] should return [phi(n)] when [f] is a function
+      that coincide with [phi] for numbers strictly less than [n].
+*)
 
-Notation Local "x ==A y" := (Aeq x y) (at level 70, no associativity).
+Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A :=
+ recursion (fun _ => a) (fun _ => f) (S n) n.
 
-Hypothesis Aeq_equiv : equiv A Aeq.
+(** For convenience, we use in proofs an intermediate definition
+    between [recursion] and [strong_rec]. *)
 
-Add Relation A Aeq
- reflexivity proved by (proj1 Aeq_equiv)
- symmetry proved by (proj2 (proj2 Aeq_equiv))
- transitivity proved by (proj1 (proj2 Aeq_equiv))
-as Aeq_rel.
+Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A :=
+ recursion (fun _ => a) (fun _ => f).
 
-Definition strong_rec (a : A) (f : N -> (N -> A) -> A) (n : N) : A :=
-recursion
-  (fun _ : N => a)
-  (fun (m : N) (p : N -> A) (k : N) => f k p)
-  (S n)
-  n.
+Lemma strong_rec_alt : forall a f n,
+ strong_rec a f n = strong_rec0 a f (S n) n.
+Proof.
+reflexivity.
+Qed.
 
-Theorem strong_rec_wd :
-forall a a' : A, a ==A a' ->
-  forall f f', fun2_eq Neq (fun_eq Neq Aeq) Aeq f f' ->
-    forall n n', n == n' ->
-      strong_rec a f n ==A strong_rec a' f' n'.
+(** We need a result similar to [f_equal], but for setoid equalities. *)
+Lemma f_equiv : forall f g x y,
+ (N.eq==>Aeq)%signature f g -> N.eq x y -> Aeq (f x) (g y).
+Proof.
+auto.
+Qed.
+
+Instance strong_rec0_wd :
+ Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq)
+  strong_rec0.
+Proof.
+unfold strong_rec0.
+repeat red; intros.
+apply f_equiv; auto.
+apply recursion_wd; try red; auto.
+Qed.
+
+Instance strong_rec_wd :
+ Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec.
 Proof.
 intros a a' Eaa' f f' Eff' n n' Enn'.
-(* First we prove that recursion (which is on type N -> A) returns
-extensionally equal functions, and then we use the fact that n == n' *)
-assert (H : fun_eq Neq Aeq
-  (recursion
-    (fun _ : N => a)
-    (fun (m : N) (p : N -> A) (k : N) => f k p)
-    (S n))
-  (recursion
-    (fun _ : N => a')
-    (fun (m : N) (p : N -> A) (k : N) => f' k p)
-    (S n'))).
-apply recursion_wd with (Aeq := fun_eq Neq Aeq).
-unfold fun_eq; now intros.
-unfold fun2_eq. intros y y' Eyy' p p' Epp'. unfold fun_eq. auto.
+rewrite !strong_rec_alt.
+apply strong_rec0_wd; auto.
 now rewrite Enn'.
-unfold strong_rec.
-now apply H.
 Qed.
 
-(*Section FixPoint.
-
-Variable a : A.
-Variable f : N -> (N -> A) -> A.
+Section FixPoint.
 
-Hypothesis f_wd : fun2_wd Neq (fun_eq Neq Aeq) Aeq f.
+Variable f : (N.t -> A) -> N.t -> A.
+Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f.
 
-Let g (n : N) : A := strong_rec a f n.
+Lemma strong_rec0_0 : forall a m,
+ (strong_rec0 a f 0 m) = a.
+Proof.
+intros. unfold strong_rec0. rewrite recursion_0; auto.
+Qed.
 
-Add Morphism g with signature Neq ==> Aeq as g_wd.
+Lemma strong_rec0_succ : forall a n m,
+ Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m).
 Proof.
-intros n1 n2 H. unfold g. now apply strong_rec_wd.
+intros. unfold strong_rec0.
+apply f_equiv; auto with *.
+rewrite recursion_succ; try (repeat red; auto with *; fail).
+apply f_wd.
+apply recursion_wd; try red; auto with *.
 Qed.
 
-Theorem NtoA_eq_sym : symmetric (N -> A) (fun_eq Neq Aeq).
+Lemma strong_rec_0 : forall a,
+ Aeq (strong_rec a f 0) (f (fun _ => a) 0).
 Proof.
-apply fun_eq_sym.
-exact (proj2 (proj2 NZeq_equiv)).
-exact (proj2 (proj2 Aeq_equiv)).
+intros. rewrite strong_rec_alt, strong_rec0_succ.
+apply f_wd; auto with *.
+red; intros; rewrite strong_rec0_0; auto with *.
 Qed.
 
-Theorem NtoA_eq_trans : transitive (N -> A) (fun_eq Neq Aeq).
+(* We need an assumption saying that for every n, the step function (f h n)
+calls h only on the segment [0 ... n - 1]. This means that if h1 and h2
+coincide on values < n, then (f h1 n) coincides with (f h2 n) *)
+
+Hypothesis step_good :
+  forall (n : N.t) (h1 h2 : N.t -> A),
+    (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n).
+
+Lemma strong_rec0_more_steps : forall a k n m, m < n ->
+ Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m).
 Proof.
-apply fun_eq_trans.
-exact (proj1 NZeq_equiv).
-exact (proj1 (proj2 NZeq_equiv)).
-exact (proj1 (proj2 Aeq_equiv)).
+ intros a k n. pattern n.
+ apply induction; clear n.
+
+ intros n n' Hn; setoid_rewrite Hn; auto with *.
+
+ intros m Hm. destruct (nlt_0_r _ Hm).
+
+ intros n IH m Hm.
+ rewrite lt_succ_r in Hm.
+ rewrite add_succ_l.
+ rewrite 2 strong_rec0_succ.
+ apply step_good.
+ intros m' Hm'.
+ apply IH.
+ apply lt_le_trans with m; auto.
 Qed.
 
-Add Relation (N -> A) (fun_eq Neq Aeq)
- symmetry proved by NtoA_eq_sym
- transitivity proved by NtoA_eq_trans
-as NtoA_eq_rel.
+Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t),
+ Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n).
+Proof.
+intros.
+rewrite strong_rec0_succ.
+apply step_good.
+intros m Hm.
+symmetry.
+setoid_replace n with (S m + (n - S m)).
+apply strong_rec0_more_steps.
+apply lt_succ_diag_r.
+rewrite add_comm.
+symmetry.
+apply sub_add.
+rewrite le_succ_l; auto.
+Qed.
 
-Add Morphism f with signature Neq ==> (fun_eq Neq Aeq) ==> Aeq as f_morph.
+Theorem strong_rec_fixpoint : forall (a : A) (n : N.t),
+ Aeq (strong_rec a f n) (f (strong_rec a f) n).
 Proof.
-apply f_wd.
+intros.
+transitivity (f (fun n => strong_rec0 a f (S n) n) n).
+rewrite strong_rec_alt.
+apply strong_rec0_fixpoint.
+apply f_wd; auto with *.
+intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *.
 Qed.
 
-(* We need an assumption saying that for every n, the step function (f n h)
-calls h only on the segment [0 ... n - 1]. This means that if h1 and h2
-coincide on values < n, then (f n h1) coincides with (f n h2) *)
+(** NB: without the [step_good] hypothesis, we have proved that
+    [strong_rec a f 0] is [f (fun _ => a) 0]. Now we can prove
+    that the first argument of [f] is arbitrary in this case...
+*)
 
-Hypothesis step_good :
-  forall (n : N) (h1 h2 : N -> A),
-    (forall m : N, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f n h1) (f n h2).
+Theorem strong_rec_0_any : forall (a : A)(any : N.t->A),
+ Aeq (strong_rec a f 0) (f any 0).
+Proof.
+intros.
+rewrite strong_rec_fixpoint.
+apply step_good.
+intros m Hm. destruct (nlt_0_r _ Hm).
+Qed.
 
-(* Todo:
-Theorem strong_rec_fixpoint : forall n : N, Aeq (g n) (f n g).
+(** ... and that first argument of [strong_rec] is always arbitrary. *)
+
+Lemma strong_rec_any_fst_arg : forall a a' n,
+ Aeq (strong_rec a f n) (strong_rec a' f n).
 Proof.
-apply induction.
-unfold predicate_wd, fun_wd.
-intros x y H. rewrite H. unfold fun_eq; apply g_wd.
-reflexivity.
-unfold g, strong_rec.
-*)
+intros a a' n.
+generalize (le_refl n).
+set (k:=n) at -2. clearbody k. revert k. pattern n.
+apply induction; clear n.
+(* compat *)
+intros n n' Hn. setoid_rewrite Hn; auto with *.
+(* 0 *)
+intros k Hk. rewrite le_0_r in Hk.
+rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any.
+(* S *)
+intros n IH k Hk.
+rewrite 2 strong_rec_fixpoint.
+apply step_good.
+intros m Hm.
+apply IH.
+rewrite succ_le_mono.
+apply le_trans with k; auto.
+rewrite le_succ_l; auto.
+Qed.
 
-End FixPoint.*)
+End FixPoint.
 End StrongRecursion.
 
 Implicit Arguments strong_rec [A].
diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v
index f67689dd..35d3b8aa 100644
--- a/theories/Numbers/Natural/Abstract/NSub.v
+++ b/theories/Numbers/Natural/Abstract/NSub.v
@@ -8,49 +8,33 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NSub.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export NMulOrder.
 
-Module NSubPropFunct (Import NAxiomsMod : NAxiomsSig).
-Module Export NMulOrderPropMod := NMulOrderPropFunct NAxiomsMod.
-Open Local Scope NatScope.
+Module Type NSubPropFunct (Import N : NAxiomsSig').
+Include NMulOrderPropFunct N.
 
-Theorem sub_wd :
-  forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 - m1 == n2 - m2.
-Proof NZsub_wd.
-
-Theorem sub_0_r : forall n : N, n - 0 == n.
-Proof NZsub_0_r.
-
-Theorem sub_succ_r : forall n m : N, n - (S m) == P (n - m).
-Proof NZsub_succ_r.
-
-Theorem sub_1_r : forall n : N, n - 1 == P n.
-Proof.
-intro n; rewrite sub_succ_r; now rewrite sub_0_r.
-Qed.
-
-Theorem sub_0_l : forall n : N, 0 - n == 0.
+Theorem sub_0_l : forall n, 0 - n == 0.
 Proof.
 induct n.
 apply sub_0_r.
 intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0.
 Qed.
 
-Theorem sub_succ : forall n m : N, S n - S m == n - m.
+Theorem sub_succ : forall n m, S n - S m == n - m.
 Proof.
 intro n; induct m.
 rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ.
 intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r.
 Qed.
 
-Theorem sub_diag : forall n : N, n - n == 0.
+Theorem sub_diag : forall n, n - n == 0.
 Proof.
 induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH.
 Qed.
 
-Theorem sub_gt : forall n m : N, n > m -> n - m ~= 0.
+Theorem sub_gt : forall n m, n > m -> n - m ~= 0.
 Proof.
 intros n m H; elim H using lt_ind_rel; clear n m H.
 solve_relation_wd.
@@ -58,7 +42,7 @@ intro; rewrite sub_0_r; apply neq_succ_0.
 intros; now rewrite sub_succ.
 Qed.
 
-Theorem add_sub_assoc : forall n m p : N, p <= m -> n + (m - p) == (n + m) - p.
+Theorem add_sub_assoc : forall n m p, p <= m -> n + (m - p) == (n + m) - p.
 Proof.
 intros n m p; induct p.
 intro; now do 2 rewrite sub_0_r.
@@ -68,32 +52,32 @@ rewrite add_pred_r by (apply sub_gt; now apply -> le_succ_l).
 reflexivity.
 Qed.
 
-Theorem sub_succ_l : forall n m : N, n <= m -> S m - n == S (m - n).
+Theorem sub_succ_l : forall n m, n <= m -> S m - n == S (m - n).
 Proof.
 intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)).
 symmetry; now apply add_sub_assoc.
 Qed.
 
-Theorem add_sub : forall n m : N, (n + m) - m == n.
+Theorem add_sub : forall n m, (n + m) - m == n.
 Proof.
 intros n m. rewrite <- add_sub_assoc by (apply le_refl).
 rewrite sub_diag; now rewrite add_0_r.
 Qed.
 
-Theorem sub_add : forall n m : N, n <= m -> (m - n) + n == m.
+Theorem sub_add : forall n m, n <= m -> (m - n) + n == m.
 Proof.
 intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption.
 rewrite add_comm. apply add_sub.
 Qed.
 
-Theorem add_sub_eq_l : forall n m p : N, m + p == n -> n - m == p.
+Theorem add_sub_eq_l : forall n m p, m + p == n -> n - m == p.
 Proof.
 intros n m p H. symmetry.
 assert (H1 : m + p - m == n - m) by now rewrite H.
 rewrite add_comm in H1. now rewrite add_sub in H1.
 Qed.
 
-Theorem add_sub_eq_r : forall n m p : N, m + p == n -> n - p == m.
+Theorem add_sub_eq_r : forall n m p, m + p == n -> n - p == m.
 Proof.
 intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l.
 Qed.
@@ -101,7 +85,7 @@ Qed.
 (* This could be proved by adding m to both sides. Then the proof would
 use add_sub_assoc and sub_0_le, which is proven below. *)
 
-Theorem add_sub_eq_nz : forall n m p : N, p ~= 0 -> n - m == p -> m + p == n.
+Theorem add_sub_eq_nz : forall n m p, p ~= 0 -> n - m == p -> m + p == n.
 Proof.
 intros n m p H; double_induct n m.
 intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H.
@@ -110,14 +94,14 @@ intros n m IH H1. rewrite sub_succ in H1. apply IH in H1.
 rewrite add_succ_l; now rewrite H1.
 Qed.
 
-Theorem sub_add_distr : forall n m p : N, n - (m + p) == (n - m) - p.
+Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p.
 Proof.
 intros n m; induct p.
 rewrite add_0_r; now rewrite sub_0_r.
 intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH.
 Qed.
 
-Theorem add_sub_swap : forall n m p : N, p <= n -> n + m - p == n - p + m.
+Theorem add_sub_swap : forall n m p, p <= n -> n + m - p == n - p + m.
 Proof.
 intros n m p H.
 rewrite (add_comm n m).
@@ -127,7 +111,7 @@ Qed.
 
 (** Sub and order *)
 
-Theorem le_sub_l : forall n m : N, n - m <= n.
+Theorem le_sub_l : forall n m, n - m <= n.
 Proof.
 intro n; induct m.
 rewrite sub_0_r; now apply eq_le_incl.
@@ -135,7 +119,7 @@ intros m IH. rewrite sub_succ_r.
 apply le_trans with (n - m); [apply le_pred_l | assumption].
 Qed.
 
-Theorem sub_0_le : forall n m : N, n - m == 0 <-> n <= m.
+Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m.
 Proof.
 double_induct n m.
 intro m; split; intro; [apply le_0_l | apply sub_0_l].
@@ -144,9 +128,86 @@ intro m; rewrite sub_0_r; split; intro H;
 intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ.
 Qed.
 
+Theorem sub_add_le : forall n m, n <= n - m + m.
+Proof.
+intros.
+destruct (le_ge_cases n m) as [LE|GE].
+rewrite <- sub_0_le in LE. rewrite LE; nzsimpl.
+now rewrite <- sub_0_le.
+rewrite sub_add by assumption. apply le_refl.
+Qed.
+
+Theorem le_sub_le_add_r : forall n m p,
+ n - p <= m <-> n <= m + p.
+Proof.
+intros n m p.
+split; intros LE.
+rewrite (add_le_mono_r _ _ p) in LE.
+apply le_trans with (n-p+p); auto using sub_add_le.
+destruct (le_ge_cases n p) as [LE'|GE].
+rewrite <- sub_0_le in LE'. rewrite LE'. apply le_0_l.
+rewrite (add_le_mono_r _ _ p). now rewrite sub_add.
+Qed.
+
+Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p.
+Proof.
+intros n m p. rewrite add_comm; apply le_sub_le_add_r.
+Qed.
+
+Theorem lt_sub_lt_add_r : forall n m p,
+ n - p < m -> n < m + p.
+Proof.
+intros n m p LT.
+rewrite (add_lt_mono_r _ _ p) in LT.
+apply le_lt_trans with (n-p+p); auto using sub_add_le.
+Qed.
+
+(** Unfortunately, we do not have [n < m + p -> n - p < m].
+    For instance [1<0+2] but not [1-2<0]. *)
+
+Theorem lt_sub_lt_add_l : forall n m p, n - m < p -> n < m + p.
+Proof.
+intros n m p. rewrite add_comm; apply lt_sub_lt_add_r.
+Qed.
+
+Theorem le_add_le_sub_r : forall n m p, n + p <= m -> n <= m - p.
+Proof.
+intros n m p LE.
+apply (add_le_mono_r _ _ p).
+rewrite sub_add. assumption.
+apply le_trans with (n+p); trivial.
+rewrite <- (add_0_l p) at 1. rewrite <- add_le_mono_r. apply le_0_l.
+Qed.
+
+(** Unfortunately, we do not have [n <= m - p -> n + p <= m].
+    For instance [0<=1-2] but not [2+0<=1]. *)
+
+Theorem le_add_le_sub_l : forall n m p, n + p <= m -> p <= m - n.
+Proof.
+intros n m p. rewrite add_comm; apply le_add_le_sub_r.
+Qed.
+
+Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p.
+Proof.
+intros n m p.
+destruct (le_ge_cases p m) as [LE|GE].
+rewrite <- (sub_add p m) at 1 by assumption.
+now rewrite <- add_lt_mono_r.
+assert (GE' := GE). rewrite <- sub_0_le in GE'; rewrite GE'.
+split; intros LT.
+elim (lt_irrefl m). apply le_lt_trans with (n+p); trivial.
+ rewrite <- (add_0_l m). apply add_le_mono. apply le_0_l. assumption.
+now elim (nlt_0_r n).
+Qed.
+
+Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n.
+Proof.
+intros n m p. rewrite add_comm; apply lt_add_lt_sub_r.
+Qed.
+
 (** Sub and mul *)
 
-Theorem mul_pred_r : forall n m : N, n * (P m) == n * m - n.
+Theorem mul_pred_r : forall n m, n * (P m) == n * m - n.
 Proof.
 intros n m; cases m.
 now rewrite pred_0, mul_0_r, sub_0_l.
@@ -155,7 +216,7 @@ now rewrite sub_diag, add_0_r.
 now apply eq_le_incl.
 Qed.
 
-Theorem mul_sub_distr_r : forall n m p : N, (n - m) * p == n * p - m * p.
+Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p.
 Proof.
 intros n m p; induct n.
 now rewrite sub_0_l, mul_0_l, sub_0_l.
@@ -170,11 +231,72 @@ setoid_replace ((S n * p) - m * p) with 0 by (apply <- sub_0_le; now apply mul_l
 apply mul_0_l.
 Qed.
 
-Theorem mul_sub_distr_l : forall n m p : N, p * (n - m) == p * n - p * m.
+Theorem mul_sub_distr_l : forall n m p, p * (n - m) == p * n - p * m.
 Proof.
 intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m).
 apply mul_sub_distr_r.
 Qed.
 
+(** Alternative definitions of [<=] and [<] based on [+] *)
+
+Definition le_alt n m := exists p, p + n == m.
+Definition lt_alt n m := exists p, S p + n == m.
+
+Lemma le_equiv : forall n m, le_alt n m <-> n <= m.
+Proof.
+split.
+intros (p,H). rewrite <- H, add_comm. apply le_add_r.
+intro H. exists (m-n). now apply sub_add.
+Qed.
+
+Lemma lt_equiv : forall n m, lt_alt n m <-> n < m.
+Proof.
+split.
+intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r.
+intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r.
+apply sub_add. now rewrite le_succ_l.
+Qed.
+
+Instance le_alt_wd : Proper (eq==>eq==>iff) le_alt.
+Proof.
+ intros x x' Hx y y' Hy; unfold le_alt.
+ setoid_rewrite Hx. setoid_rewrite Hy. auto with *.
+Qed.
+
+Instance lt_alt_wd : Proper (eq==>eq==>iff) lt_alt.
+Proof.
+ intros x x' Hx y y' Hy; unfold lt_alt.
+ setoid_rewrite Hx. setoid_rewrite Hy. auto with *.
+Qed.
+
+(** With these alternative definition, the dichotomy:
+
+[forall n m, n <= m \/ m <= n]
+
+becomes:
+
+[forall n m, (exists p, p + n == m) \/ (exists p, p + m == n)]
+
+We will need this in the proof of induction principle for integers
+constructed as pairs of natural numbers. This formula can be proved
+from know properties of [<=]. However, it can also be done directly. *)
+
+Theorem le_alt_dichotomy : forall n m, le_alt n m \/ le_alt m n.
+Proof.
+intros n m; induct n.
+left; exists m; apply add_0_r.
+intros n IH.
+destruct IH as [[p H] | [p H]].
+destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H.
+rewrite add_0_l in H. right; exists (S 0); rewrite H, add_succ_l;
+ now rewrite add_0_l.
+left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H.
+right; exists (S p). rewrite add_succ_l; now rewrite H.
+Qed.
+
+Theorem add_dichotomy :
+  forall n m, (exists p, p + n == m) \/ (exists p, p + m == n).
+Proof. exact le_alt_dichotomy. Qed.
+
 End NSubPropFunct.
 
diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v
index 16007656..cab4b154 100644
--- a/theories/Numbers/Natural/BigN/BigN.v
+++ b/theories/Numbers/Natural/BigN/BigN.v
@@ -6,28 +6,32 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BigN.v 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(** * Efficient arbitrary large natural numbers in base 2^31 *)
 
-(** * Natural numbers in base 2^31 *)
-
-(**
-Author: Arnaud Spiwack
-*)
+(** Initial Author: Arnaud Spiwack *)
 
 Require Export Int31.
-Require Import CyclicAxioms.
-Require Import Cyclic31.
-Require Import NSig.
-Require Import NSigNAxioms.
-Require Import NMake.
-Require Import NSub.
+Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake
+  NProperties NDiv GenericMinMax.
+
+(** The following [BigN] module regroups both the operations and
+    all the abstract properties:
 
-Module BigN <: NType := NMake.Make Int31Cyclic.
+    - [NMake.Make Int31Cyclic] provides the operations and basic specs
+       w.r.t. ZArith
+    - [NTypeIsNAxioms] shows (mainly) that these operations implement
+      the interface [NAxioms]
+    - [NPropSig] adds all generic properties derived from [NAxioms]
+    - [NDivPropFunct] provides generic properties of [div] and [mod].
+    - [MinMax*Properties] provides properties of [min] and [max].
+
+*)
 
-(** Module [BigN] implements [NAxiomsSig] *)
+Module BigN <: NType <: OrderedTypeFull <: TotalOrder :=
+ NMake.Make Int31Cyclic <+ NTypeIsNAxioms
+ <+ !NPropSig <+ !NDivPropFunct <+ HasEqBool2Dec
+ <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
 
-Module Export BigNAxiomsMod := NSig_NAxioms BigN.
-Module Export BigNSubPropMod := NSubPropFunct BigNAxiomsMod.
 
 (** Notations about [BigN] *)
 
@@ -37,49 +41,171 @@ Delimit Scope bigN_scope with bigN.
 Bind Scope bigN_scope with bigN.
 Bind Scope bigN_scope with BigN.t.
 Bind Scope bigN_scope with BigN.t_.
-
-Notation Local "0" := BigN.zero : bigN_scope. (* temporary notation *)
+(* Bind Scope has no retroactive effect, let's declare scopes by hand. *)
+Arguments Scope BigN.to_Z [bigN_scope].
+Arguments Scope BigN.succ [bigN_scope].
+Arguments Scope BigN.pred [bigN_scope].
+Arguments Scope BigN.square [bigN_scope].
+Arguments Scope BigN.add [bigN_scope bigN_scope].
+Arguments Scope BigN.sub [bigN_scope bigN_scope].
+Arguments Scope BigN.mul [bigN_scope bigN_scope].
+Arguments Scope BigN.div [bigN_scope bigN_scope].
+Arguments Scope BigN.eq [bigN_scope bigN_scope].
+Arguments Scope BigN.lt [bigN_scope bigN_scope].
+Arguments Scope BigN.le [bigN_scope bigN_scope].
+Arguments Scope BigN.eq [bigN_scope bigN_scope].
+Arguments Scope BigN.compare [bigN_scope bigN_scope].
+Arguments Scope BigN.min [bigN_scope bigN_scope].
+Arguments Scope BigN.max [bigN_scope bigN_scope].
+Arguments Scope BigN.eq_bool [bigN_scope bigN_scope].
+Arguments Scope BigN.power_pos [bigN_scope positive_scope].
+Arguments Scope BigN.power [bigN_scope N_scope].
+Arguments Scope BigN.sqrt [bigN_scope].
+Arguments Scope BigN.div_eucl [bigN_scope bigN_scope].
+Arguments Scope BigN.modulo [bigN_scope bigN_scope].
+Arguments Scope BigN.gcd [bigN_scope bigN_scope].
+
+Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *)
+Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *)
 Infix "+" := BigN.add : bigN_scope.
 Infix "-" := BigN.sub : bigN_scope.
 Infix "*" := BigN.mul : bigN_scope.
 Infix "/" := BigN.div : bigN_scope.
+Infix "^" := BigN.power : bigN_scope.
 Infix "?=" := BigN.compare : bigN_scope.
 Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope.
+Notation "x != y" := (~x==y)%bigN (at level 70, no associativity) : bigN_scope.
 Infix "<" := BigN.lt : bigN_scope.
 Infix "<=" := BigN.le : bigN_scope.
 Notation "x > y" := (BigN.lt y x)(only parsing) : bigN_scope.
 Notation "x >= y" := (BigN.le y x)(only parsing) : bigN_scope.
+Notation "x < y < z" := (x<y /\ y<z)%bigN : bigN_scope.
+Notation "x < y <= z" := (x<y /\ y<=z)%bigN : bigN_scope.
+Notation "x <= y < z" := (x<=y /\ y<z)%bigN : bigN_scope.
+Notation "x <= y <= z" := (x<=y /\ y<=z)%bigN : bigN_scope.
 Notation "[ i ]" := (BigN.to_Z i) : bigN_scope.
+Infix "mod" := BigN.modulo (at level 40, no associativity) : bigN_scope.
 
-Open Scope bigN_scope.
+Local Open Scope bigN_scope.
 
 (** Example of reasoning about [BigN] *)
 
-Theorem succ_pred: forall q:bigN,
+Theorem succ_pred: forall q : bigN,
   0 < q -> BigN.succ (BigN.pred q) == q.
 Proof.
-intros; apply succ_pred.
+intros; apply BigN.succ_pred.
 intro H'; rewrite H' in H; discriminate.
 Qed.
 
 (** [BigN] is a semi-ring *)
 
-Lemma BigNring :
- semi_ring_theory BigN.zero BigN.one BigN.add BigN.mul BigN.eq.
+Lemma BigNring : semi_ring_theory 0 1 BigN.add BigN.mul BigN.eq.
+Proof.
+constructor.
+exact BigN.add_0_l. exact BigN.add_comm. exact BigN.add_assoc.
+exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm.
+exact BigN.mul_assoc. exact BigN.mul_add_distr_r.
+Qed.
+
+Lemma BigNeqb_correct : forall x y, BigN.eq_bool x y = true -> x==y.
+Proof. now apply BigN.eqb_eq. Qed.
+
+Lemma BigNpower : power_theory 1 BigN.mul BigN.eq (@id N) BigN.power.
 Proof.
 constructor.
-exact add_0_l.
-exact add_comm.
-exact add_assoc.
-exact mul_1_l.
-exact mul_0_l.
-exact mul_comm.
-exact mul_assoc.
-exact mul_add_distr_r.
+intros. red. rewrite BigN.spec_power. unfold id.
+destruct Zpower_theory as [EQ]. rewrite EQ.
+destruct n; simpl. reflexivity.
+induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto.
+Qed.
+
+Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _)
+ (fun a b => if BigN.eq_bool b 0 then (0,a) else BigN.div_eucl a b).
+Proof.
+constructor. unfold id. intros a b.
+BigN.zify.
+generalize (Zeq_bool_if [b] 0); destruct (Zeq_bool [b] 0).
+BigN.zify. auto with zarith.
+intros NEQ.
+generalize (BigN.spec_div_eucl a b).
+generalize (Z_div_mod_full [a] [b] NEQ).
+destruct BigN.div_eucl as (q,r), Zdiv_eucl as (q',r').
+intros (EQ,_). injection 1. intros EQr EQq.
+BigN.zify. rewrite EQr, EQq; auto.
+Qed.
+
+
+(** Detection of constants *)
+
+Ltac isStaticWordCst t :=
+ match t with
+ | W0 => constr:true
+ | WW ?t1 ?t2 =>
+   match isStaticWordCst t1 with
+   | false => constr:false
+   | true => isStaticWordCst t2
+   end
+ | _ => isInt31cst t
+ end.
+
+Ltac isBigNcst t :=
+ match t with
+ | BigN.N0 ?t => isStaticWordCst t
+ | BigN.N1 ?t => isStaticWordCst t
+ | BigN.N2 ?t => isStaticWordCst t
+ | BigN.N3 ?t => isStaticWordCst t
+ | BigN.N4 ?t => isStaticWordCst t
+ | BigN.N5 ?t => isStaticWordCst t
+ | BigN.N6 ?t => isStaticWordCst t
+ | BigN.Nn ?n ?t => match isnatcst n with
+   | true => isStaticWordCst t
+   | false => constr:false
+   end
+ | BigN.zero => constr:true
+ | BigN.one => constr:true
+ | _ => constr:false
+ end.
+
+Ltac BigNcst t :=
+ match isBigNcst t with
+ | true => constr:t
+ | false => constr:NotConstant
+ end.
+
+Ltac Ncst t :=
+ match isNcst t with
+ | true => constr:t
+ | false => constr:NotConstant
+ end.
+
+(** Registration for the "ring" tactic *)
+
+Add Ring BigNr : BigNring
+ (decidable BigNeqb_correct,
+  constants [BigNcst],
+  power_tac BigNpower [Ncst],
+  div BigNdiv).
+
+Section TestRing.
+Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
+intros. ring_simplify. reflexivity.
 Qed.
+End TestRing.
+
+(** We benefit also from an "order" tactic *)
+
+Ltac bigN_order := BigN.order.
+
+Section TestOrder.
+Let test : forall x y : bigN, x<=y -> y<=x -> x==y.
+Proof. bigN_order. Qed.
+End TestOrder.
 
-Add Ring BigNr : BigNring.
+(** We can use at least a bit of (r)omega by translating to [Z]. *)
 
-(** Todo: tactic translating from [BigN] to [Z] + omega *)
+Section TestOmega.
+Let test : forall x y : bigN, x<=y -> y<=x -> x==y.
+Proof. intros x y. BigN.zify. omega. Qed.
+End TestOmega.
 
 (** Todo: micromega *)
diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v
new file mode 100644
index 00000000..925b0535
--- /dev/null
+++ b/theories/Numbers/Natural/BigN/NMake.v
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
+(************************************************************************)
+
+(** * NMake *)
+
+(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)
+
+(** NB: This file contain the part which is independent from the underlying
+    representation. The representation-dependent (and macro-generated) part
+    is now in [NMake_gen]. *)
+
+Require Import BigNumPrelude ZArith CyclicAxioms.
+Require Import Nbasic Wf_nat StreamMemo NSig NMake_gen.
+
+Module Make (Import W0:CyclicType) <: NType.
+
+ (** Macro-generated part *)
+
+ Include NMake_gen.Make W0.
+
+
+ (** * Predecessor *)
+
+ Lemma spec_pred : forall x, [pred x] = Zmax 0 ([x]-1).
+ Proof.
+ intros. destruct (Zle_lt_or_eq _ _ (spec_pos x)).
+ rewrite Zmax_r; auto with zarith.
+ apply spec_pred_pos; auto.
+ rewrite <- H; apply spec_pred0; auto.
+ Qed.
+
+
+ (** * Subtraction *)
+
+ Lemma spec_sub : forall x y, [sub x y] = Zmax 0 ([x]-[y]).
+ Proof.
+ intros. destruct (Zle_or_lt [y] [x]).
+ rewrite Zmax_r; auto with zarith. apply spec_sub_pos; auto.
+ rewrite Zmax_l; auto with zarith. apply spec_sub0; auto.
+ Qed.
+
+ (** * Comparison *)
+
+ Theorem spec_compare : forall x y, compare x y = Zcompare [x] [y].
+ Proof.
+ intros x y. generalize (spec_compare_aux x y); destruct compare;
+ intros; symmetry; try rewrite Zcompare_Eq_iff_eq; assumption.
+ Qed.
+
+ Definition eq_bool x y :=
+  match compare x y with
+  | Eq => true
+  | _  => false
+  end.
+
+ Theorem spec_eq_bool : forall x y, eq_bool x y = Zeq_bool [x] [y].
+ Proof.
+ intros. unfold eq_bool, Zeq_bool. rewrite spec_compare; reflexivity.
+ Qed.
+
+ Theorem spec_eq_bool_aux: forall x y,
+    if eq_bool x y then [x] = [y] else [x] <> [y].
+ Proof.
+ intros x y; unfold eq_bool.
+ generalize (spec_compare_aux x y); case compare; auto with zarith.
+ Qed.
+
+ Definition lt n m := [n] < [m].
+ Definition le n m := [n] <= [m].
+
+ Definition min n m := match compare n m with Gt => m | _ => n end.
+ Definition max n m := match compare n m with Lt => m | _ => n end.
+
+ Theorem spec_max : forall n m, [max n m] = Zmax [n] [m].
+ Proof.
+ intros. unfold max, Zmax. rewrite spec_compare; destruct Zcompare; reflexivity.
+ Qed.
+
+ Theorem spec_min : forall n m, [min n m] = Zmin [n] [m].
+ Proof.
+ intros. unfold min, Zmin. rewrite spec_compare; destruct Zcompare; reflexivity.
+ Qed.
+
+
+ (** * Power *)
+
+ Fixpoint power_pos (x:t) (p:positive) {struct p} : t :=
+  match p with
+  | xH => x
+  | xO p => square (power_pos x p)
+  | xI p => mul (square (power_pos x p)) x
+  end.
+
+ Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
+ Proof.
+ intros x n; generalize x; elim n; clear n x; simpl power_pos.
+ intros; rewrite spec_mul; rewrite spec_square; rewrite H.
+ rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith.
+ rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.
+ rewrite Zpower_2; rewrite Zpower_1_r; auto.
+ intros; rewrite spec_square; rewrite H.
+ rewrite Zpos_xO; auto with zarith.
+ rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.
+ rewrite Zpower_2; auto.
+ intros; rewrite Zpower_1_r; auto.
+ Qed.
+
+ Definition power x (n:N) := match n with
+  | BinNat.N0 => one
+  | BinNat.Npos p => power_pos x p
+ end.
+
+ Theorem spec_power: forall x n, [power x n] = [x] ^ Z_of_N n.
+ Proof.
+ destruct n; simpl. apply (spec_1 w0_spec).
+ apply spec_power_pos.
+ Qed.
+
+
+ (** * Div *)
+
+ Definition div_eucl x y :=
+  if eq_bool y zero then (zero,zero) else
+  match compare x y with
+  | Eq => (one, zero)
+  | Lt => (zero, x)
+  | Gt => div_gt x y
+  end.
+
+ Theorem spec_div_eucl: forall x y,
+      let (q,r) := div_eucl x y in
+      ([q], [r]) = Zdiv_eucl [x] [y].
+ Proof.
+ assert (F0: [zero] = 0).
+   exact (spec_0 w0_spec).
+ assert (F1: [one] = 1).
+   exact (spec_1 w0_spec).
+ intros x y. unfold div_eucl.
+ generalize (spec_eq_bool_aux y zero). destruct eq_bool; rewrite F0.
+ intro H. rewrite H. destruct [x]; auto.
+ intro H'.
+ assert (0 < [y]) by (generalize (spec_pos y); auto with zarith).
+ clear H'.
+ generalize (spec_compare_aux x y); case compare; try rewrite F0;
+   try rewrite F1; intros; auto with zarith.
+ rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H))
+                        (Z_mod_same [y] (Zlt_gt _ _ H));
+  unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.
+ assert (F2: 0 <= [x] < [y]).
+   generalize (spec_pos x); auto.
+ generalize (Zdiv_small _ _ F2)
+            (Zmod_small _ _ F2);
+  unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.
+ generalize (spec_div_gt _ _ H0 H); auto.
+ unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt.
+ intros a b c d (H1, H2); subst; auto.
+ Qed.
+
+ Definition div x y := fst (div_eucl x y).
+
+ Theorem spec_div:
+   forall x y, [div x y] = [x] / [y].
+ Proof.
+ intros x y; unfold div; generalize (spec_div_eucl x y);
+   case div_eucl; simpl fst.
+ intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H;
+  injection H; auto.
+ Qed.
+
+
+ (** * Modulo *)
+
+ Definition modulo x y :=
+  if eq_bool y zero then zero else
+  match compare x y with
+  | Eq => zero
+  | Lt => x
+  | Gt => mod_gt x y
+  end.
+
+ Theorem spec_modulo:
+   forall x y, [modulo x y] = [x] mod [y].
+ Proof.
+ assert (F0: [zero] = 0).
+   exact (spec_0 w0_spec).
+ assert (F1: [one] = 1).
+   exact (spec_1 w0_spec).
+ intros x y. unfold modulo.
+ generalize (spec_eq_bool_aux y zero). destruct eq_bool; rewrite F0.
+ intro H; rewrite H. destruct [x]; auto.
+ intro H'.
+ assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith).
+ clear H'.
+ generalize (spec_compare_aux x y); case compare; try rewrite F0;
+   try rewrite F1; intros; try split; auto with zarith.
+ rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith.
+ apply sym_equal; apply Zmod_small; auto with zarith.
+ generalize (spec_pos x); auto with zarith.
+ apply spec_mod_gt; auto.
+ Qed.
+
+
+ (** * Gcd *)
+
+ Definition gcd_gt_body a b cont :=
+  match compare b zero with
+  | Gt =>
+    let r := mod_gt a b in
+    match compare r zero with
+    | Gt => cont r (mod_gt b r)
+    | _ => b
+    end
+  | _ => a
+  end.
+
+ Theorem Zspec_gcd_gt_body: forall a b cont p,
+    [a] > [b] -> [a] < 2 ^ p ->
+      (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] ->
+         Zis_gcd  [a1] [b1] [cont a1 b1]) ->
+      Zis_gcd [a] [b] [gcd_gt_body a b cont].
+ Proof.
+ assert (F1: [zero] = 0).
+   unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.
+ intros a b cont p H2 H3 H4; unfold gcd_gt_body.
+ generalize (spec_compare_aux b zero); case compare; try rewrite F1.
+   intros HH; rewrite HH; apply Zis_gcd_0.
+ intros HH; absurd (0 <= [b]); auto with zarith.
+ case (spec_digits b); auto with zarith.
+ intros H5; generalize (spec_compare_aux (mod_gt a b) zero);
+   case compare; try rewrite F1.
+ intros H6; rewrite <- (Zmult_1_r [b]).
+ rewrite (Z_div_mod_eq [a] [b]); auto with zarith.
+ rewrite <- spec_mod_gt; auto with zarith.
+ rewrite H6; rewrite Zplus_0_r.
+ apply Zis_gcd_mult; apply Zis_gcd_1.
+ intros; apply False_ind.
+ case (spec_digits (mod_gt a b)); auto with zarith.
+ intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith.
+ apply DoubleDiv.Zis_gcd_mod; auto with zarith.
+ rewrite <- spec_mod_gt; auto with zarith.
+ assert (F2: [b] > [mod_gt a b]).
+   case (Z_mod_lt [a] [b]); auto with zarith.
+   repeat rewrite <- spec_mod_gt; auto with zarith.
+ assert (F3: [mod_gt a b] > [mod_gt b  (mod_gt a b)]).
+   case (Z_mod_lt [b] [mod_gt a b]); auto with zarith.
+   rewrite <- spec_mod_gt; auto with zarith.
+ repeat rewrite <- spec_mod_gt; auto with zarith.
+ apply H4; auto with zarith.
+ apply Zmult_lt_reg_r with 2; auto with zarith.
+ apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith.
+ apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith.
+   apply Zplus_le_compat_r.
+ pattern [b] at 1; rewrite <- (Zmult_1_l [b]).
+ apply Zmult_le_compat_r; auto with zarith.
+ case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith.
+ intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2;
+   try rewrite <- HH in H2; auto with zarith.
+ case (Z_mod_lt [a] [b]); auto with zarith.
+ rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith.
+ rewrite <- Z_div_mod_eq; auto with zarith.
+ pattern 2 at 2; rewrite <- (Zpower_1_r 2).
+ rewrite <- Zpower_exp; auto with zarith.
+ ring_simplify (p - 1 + 1); auto.
+ case (Zle_lt_or_eq 0 p); auto with zarith.
+ generalize H3; case p; simpl Zpower; auto with zarith.
+ intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith.
+ Qed.
+
+ Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t :=
+  gcd_gt_body a b
+    (fun a b =>
+       match p with
+       | xH => cont a b
+       | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b
+       | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b
+       end).
+
+ Theorem Zspec_gcd_gt_aux: forall p n a b cont,
+    [a] > [b] -> [a] < 2 ^ (Zpos p + n) ->
+      (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] ->
+            Zis_gcd [a1] [b1] [cont a1 b1]) ->
+          Zis_gcd [a] [b] [gcd_gt_aux p cont a b].
+ intros p; elim p; clear p.
+ intros p Hrec n a b cont H2 H3 H4.
+   unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto.
+   intros a1 b1 H6 H7.
+     apply Hrec with (Zpos p + n); auto.
+       replace (Zpos p + (Zpos p + n)) with
+         (Zpos (xI p) + n  - 1); auto.
+       rewrite Zpos_xI; ring.
+   intros a2 b2 H9 H10.
+     apply Hrec with n; auto.
+ intros p Hrec n a b cont H2 H3 H4.
+   unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto.
+   intros a1 b1 H6 H7.
+     apply Hrec with (Zpos p + n - 1); auto.
+       replace (Zpos p + (Zpos p + n - 1)) with
+         (Zpos (xO p) + n  - 1); auto.
+       rewrite Zpos_xO; ring.
+   intros a2 b2 H9 H10.
+     apply Hrec with (n - 1); auto.
+       replace (Zpos p + (n - 1)) with
+         (Zpos p + n  - 1); auto with zarith.
+   intros a3 b3 H12 H13; apply H4; auto with zarith.
+    apply Zlt_le_trans with (1 := H12).
+    case (Zle_or_lt 1 n); intros HH.
+    apply Zpower_le_monotone; auto with zarith.
+    apply Zle_trans with 0; auto with zarith.
+    assert (HH1: n - 1 < 0); auto with zarith.
+    generalize HH1; case (n - 1); auto with zarith.
+    intros p1 HH2; discriminate.
+ intros n a b cont H H2 H3.
+  simpl gcd_gt_aux.
+  apply Zspec_gcd_gt_body with (n + 1); auto with zarith.
+  rewrite Zplus_comm; auto.
+  intros a1 b1 H5 H6; apply H3; auto.
+  replace n with (n + 1 - 1); auto; try ring.
+ Qed.
+
+ Definition gcd_cont a b :=
+  match compare one b with
+  | Eq => one
+  | _ => a
+  end.
+
+ Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b.
+
+ Theorem spec_gcd_gt: forall a b,
+   [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b].
+ Proof.
+ intros a b H2.
+ case (spec_digits (gcd_gt a b)); intros H3 H4.
+ case (spec_digits a); intros H5 H6.
+ apply sym_equal; apply Zis_gcd_gcd; auto with zarith.
+ unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith.
+ intros a1 a2; rewrite Zpower_0_r.
+ case (spec_digits a2); intros H7 H8;
+   intros; apply False_ind; auto with zarith.
+ Qed.
+
+ Definition gcd a b :=
+  match compare a b with
+  | Eq => a
+  | Lt => gcd_gt b a
+  | Gt => gcd_gt a b
+  end.
+
+ Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].
+ Proof.
+ intros a b.
+ case (spec_digits a); intros H1 H2.
+ case (spec_digits b); intros H3 H4.
+ unfold gcd; generalize (spec_compare_aux a b); case compare.
+ intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto.
+   apply Zis_gcd_refl.
+ intros; apply trans_equal with (Zgcd [b] [a]).
+   apply spec_gcd_gt; auto with zarith.
+ apply Zis_gcd_gcd; auto with zarith.
+ apply Zgcd_is_pos.
+ apply Zis_gcd_sym; apply Zgcd_is_gcd.
+ intros; apply spec_gcd_gt; auto.
+ Qed.
+
+
+ (** * Conversion *)
+
+ Definition of_N x :=
+  match x with
+  | BinNat.N0 => zero
+  | Npos p => of_pos p
+  end.
+
+ Theorem spec_of_N: forall x,
+   [of_N x] = Z_of_N x.
+ Proof.
+ intros x; case x.
+  simpl of_N.
+  unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.
+ intros p; exact (spec_of_pos p).
+ Qed.
+
+
+ (** * Shift *)
+
+ Definition shiftr n x :=
+   match compare n (Ndigits x) with
+   |  Lt => unsafe_shiftr n x
+   | _ => N0 w_0
+   end.
+
+ Theorem spec_shiftr: forall n x,
+   [shiftr n x] = [x] / 2 ^ [n].
+ Proof.
+ intros n x; unfold shiftr;
+    generalize (spec_compare_aux n (Ndigits x)); case compare; intros H.
+ apply trans_equal with (1 := spec_0 w0_spec).
+ apply sym_equal; apply Zdiv_small; rewrite H.
+ rewrite spec_Ndigits; exact (spec_digits x).
+ rewrite <- spec_unsafe_shiftr; auto with zarith.
+ apply trans_equal with (1 := spec_0 w0_spec).
+ apply sym_equal; apply Zdiv_small.
+ rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2.
+ split; auto.
+ apply Zlt_le_trans with (1 := H2).
+ apply Zpower_le_monotone; auto with zarith.
+ Qed.
+
+ Definition shiftl_aux_body cont n x :=
+   match compare n (head0 x)  with
+      Gt => cont n (double_size x)
+   |  _ => unsafe_shiftl n x
+   end.
+
+ Theorem spec_shiftl_aux_body: forall n p x cont,
+       2^ Zpos p  <=  [head0 x]  ->
+      (forall x, 2 ^ (Zpos p + 1) <= [head0 x]->
+         [cont n x] = [x] * 2 ^ [n]) ->
+      [shiftl_aux_body cont n x] = [x] * 2 ^ [n].
+ Proof.
+ intros n p x cont H1 H2; unfold shiftl_aux_body.
+ generalize (spec_compare_aux n (head0 x)); case compare; intros H.
+  apply spec_unsafe_shiftl; auto with zarith.
+  apply spec_unsafe_shiftl; auto with zarith.
+ rewrite H2.
+ rewrite spec_double_size; auto.
+ rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith.
+ apply Zle_trans with (2 := spec_double_size_head0 x).
+ rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith.
+ Qed.
+
+ Fixpoint shiftl_aux p cont n x  {struct p} :=
+   shiftl_aux_body
+       (fun n x => match p with
+        | xH => cont n x
+        | xO p => shiftl_aux p (shiftl_aux p cont) n x
+        | xI p => shiftl_aux p (shiftl_aux p cont) n x
+        end) n x.
+
+ Theorem spec_shiftl_aux: forall p q n x cont,
+    2 ^ (Zpos q) <= [head0 x] ->
+      (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] ->
+         [cont n x] = [x] * 2 ^ [n]) ->
+      [shiftl_aux p cont n x] = [x] * 2 ^ [n].
+ Proof.
+ intros p; elim p; unfold shiftl_aux; fold shiftl_aux; clear p.
+ intros p Hrec q n x cont H1 H2.
+ apply spec_shiftl_aux_body with (q); auto.
+ intros x1 H3; apply Hrec with (q + 1)%positive; auto.
+ intros x2 H4; apply Hrec with (p + q + 1)%positive; auto.
+ rewrite <- Pplus_assoc.
+ rewrite Zpos_plus_distr; auto.
+ intros x3 H5; apply H2.
+ rewrite Zpos_xI.
+ replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1));
+   auto.
+ repeat rewrite Zpos_plus_distr; ring.
+ intros p Hrec q n x cont H1 H2.
+ apply spec_shiftl_aux_body with (q); auto.
+ intros x1 H3; apply Hrec with (q); auto.
+ apply Zle_trans with (2 := H3); auto with zarith.
+ apply Zpower_le_monotone; auto with zarith.
+ intros x2 H4; apply Hrec with (p + q)%positive; auto.
+ intros x3 H5; apply H2.
+ rewrite (Zpos_xO p).
+ replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q));
+   auto.
+ repeat rewrite Zpos_plus_distr; ring.
+ intros q n x cont H1 H2.
+ apply spec_shiftl_aux_body with (q); auto.
+ rewrite Zplus_comm; auto.
+ Qed.
+
+ Definition shiftl n x :=
+  shiftl_aux_body
+   (shiftl_aux_body
+    (shiftl_aux (digits n) unsafe_shiftl)) n x.
+
+ Theorem spec_shiftl: forall n x,
+   [shiftl n x] = [x] * 2 ^ [n].
+ Proof.
+ intros n x; unfold shiftl, shiftl_aux_body.
+ generalize (spec_compare_aux n (head0 x)); case compare; intros H.
+  apply spec_unsafe_shiftl; auto with zarith.
+  apply spec_unsafe_shiftl; auto with zarith.
+ rewrite <- (spec_double_size x).
+ generalize (spec_compare_aux n (head0 (double_size x))); case compare; intros H1.
+  apply spec_unsafe_shiftl; auto with zarith.
+  apply spec_unsafe_shiftl; auto with zarith.
+ rewrite <- (spec_double_size (double_size x)).
+ apply spec_shiftl_aux with 1%positive.
+ apply Zle_trans with (2 := spec_double_size_head0 (double_size x)).
+ replace (2 ^ 1) with (2 * 1).
+ apply Zmult_le_compat_l; auto with zarith.
+ generalize (spec_double_size_head0_pos x); auto with zarith.
+ rewrite Zpower_1_r; ring.
+ intros x1 H2; apply spec_unsafe_shiftl.
+ apply Zle_trans with (2 := H2).
+ apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith.
+ case (spec_digits n); auto with zarith.
+ apply Zpower_le_monotone; auto with zarith.
+ Qed.
+
+
+ (** * Zero and One *)
+
+ Theorem spec_0: [zero] = 0.
+ Proof.
+ exact (spec_0 w0_spec).
+ Qed.
+
+ Theorem spec_1: [one] = 1.
+ Proof.
+ exact (spec_1 w0_spec).
+ Qed.
+
+
+End Make.
diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml
index 04c7b96d..b8552a39 100644
--- a/theories/Numbers/Natural/BigN/NMake_gen.ml
+++ b/theories/Numbers/Natural/BigN/NMake_gen.ml
@@ -8,14 +8,14 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: NMake_gen.ml 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*S NMake_gen.ml : this file generates NMake.v *)
 
 
 (*s The two parameters that control the generation: *)
 
-let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ 
+let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ
                 process before relying on a generic construct *)
 let gen_proof = true  (* should we generate proofs ? *)
 
@@ -27,18 +27,18 @@ let c = "N"
 let pz n = if n == 0 then "w_0" else "W0"
 let rec gen2 n = if n == 0 then "1" else if n == 1 then "2"
                  else "2 * " ^ (gen2 (n - 1))
-let rec genxO n s = 
+let rec genxO n s =
   if n == 0 then s else " (xO" ^ (genxO (n - 1) s) ^ ")"
 
-(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to 
-   /dev/null, but for being compatible with earlier ocaml and not 
-   relying on system-dependent stuff like open_out "/dev/null", 
+(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to
+   /dev/null, but for being compatible with earlier ocaml and not
+   relying on system-dependent stuff like open_out "/dev/null",
    let's use instead a magical hack *)
 
 (* Standard printer, with a final newline *)
 let pr s = Printf.printf (s^^"\n")
 (* Printing to /dev/null *)
-let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ()) 
+let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ())
 	  : ('a, out_channel, unit) format -> 'a)
 (* Proof printer : prints iff gen_proof is true *)
 let pp = if gen_proof then pr else pn
@@ -51,7 +51,7 @@ let pp0 = if gen_proof then pr0 else pn
 
 (*s The actual printing *)
 
-let _ = 
+let _ =
 
   pr "(************************************************************************)";
   pr "(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)";
@@ -67,21 +67,13 @@ let _ =
   pr "";
   pr "(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)";
   pr "";
-  pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)"; 
+  pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)";
   pr "";
-  pr "Require Import BigNumPrelude.";
-  pr "Require Import ZArith.";
-  pr "Require Import CyclicAxioms.";
-  pr "Require Import DoubleType.";
-  pr "Require Import DoubleMul.";
-  pr "Require Import DoubleDivn1.";
-  pr "Require Import DoubleCyclic.";
-  pr "Require Import Nbasic.";
-  pr "Require Import Wf_nat.";
-  pr "Require Import StreamMemo.";
-  pr "Require Import NSig.";
+  pr "Require Import BigNumPrelude ZArith CyclicAxioms";
+  pr " DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic";
+  pr " Wf_nat StreamMemo.";
   pr "";
-  pr "Module Make (Import W0:CyclicType) <: NType.";
+  pr "Module Make (Import W0:CyclicType).";
   pr "";
 
   pr " Definition w0 := W0.w.";
@@ -132,7 +124,7 @@ let _ =
   pr "";
 
   pr " Inductive %s_ :=" t;
-  for i = 0 to size do 
+  for i = 0 to size do
     pr "  | %s%i : w%i -> %s_" c i i t
   done;
   pr "  | %sn : forall n, word w%i (S n) -> %s_." c size t;
@@ -167,20 +159,20 @@ let _ =
 
   pr " Definition to_N x := Zabs_N (to_Z x).";
   pr "";
-  
+
   pr " Definition eq x y := (to_Z x = to_Z y).";
   pr "";
 
   pp " (* Regular make op (no karatsuba) *)";
-  pp " Fixpoint nmake_op (ww:Type) (ww_op: znz_op ww) (n: nat) : ";
+  pp " Fixpoint nmake_op (ww:Type) (ww_op: znz_op ww) (n: nat) :";
   pp "       znz_op (word ww n) :=";
-  pp "  match n return znz_op (word ww n) with ";
+  pp "  match n return znz_op (word ww n) with";
   pp "   O => ww_op";
-  pp "  | S n1 => mk_zn2z_op (nmake_op ww ww_op n1) ";
+  pp "  | S n1 => mk_zn2z_op (nmake_op ww ww_op n1)";
   pp "  end.";
   pp "";
   pp " (* Simplification by rewriting for nmake_op *)";
-  pp " Theorem nmake_op_S: forall ww (w_op: znz_op ww) x, ";
+  pp " Theorem nmake_op_S: forall ww (w_op: znz_op ww) x,";
   pp "   nmake_op _ w_op (S x) = mk_zn2z_op (nmake_op _ w_op x).";
   pp " auto.";
   pp " Qed.";
@@ -191,7 +183,7 @@ let _ =
   for i = 0 to size do
     pp " Let nmake_op%i := nmake_op _ w%i_op." i i;
     pp " Let eval%in n := znz_to_Z  (nmake_op%i n)." i i;
-    if i == 0 then 
+    if i == 0 then
       pr " Let extend%i := DoubleBase.extend  (WW w_0)." i
     else
       pr " Let extend%i := DoubleBase.extend  (WW (W0: w%i))." i i;
@@ -199,8 +191,8 @@ let _ =
   pr "";
 
 
-  pp " Theorem digits_doubled:forall n ww (w_op: znz_op ww), ";
-  pp "    znz_digits (nmake_op _ w_op n) = ";
+  pp " Theorem digits_doubled:forall n ww (w_op: znz_op ww),";
+  pp "    znz_digits (nmake_op _ w_op n) =";
   pp "    DoubleBase.double_digits (znz_digits w_op) n.";
   pp " Proof.";
   pp " intros n; elim n; auto; clear n.";
@@ -208,7 +200,7 @@ let _ =
   pp " rewrite <- Hrec; auto.";
   pp " Qed.";
   pp "";
-  pp " Theorem nmake_double: forall n ww (w_op: znz_op ww), ";
+  pp " Theorem nmake_double: forall n ww (w_op: znz_op ww),";
   pp "    znz_to_Z (nmake_op _ w_op n) =";
   pp "    @DoubleBase.double_to_Z _ (znz_digits w_op) (znz_to_Z w_op) n.";
   pp " Proof.";
@@ -220,8 +212,8 @@ let _ =
   pp "";
 
 
-  pp " Theorem digits_nmake:forall n ww (w_op: znz_op ww), ";
-  pp "    znz_digits (nmake_op _ w_op (S n)) = ";
+  pp " Theorem digits_nmake:forall n ww (w_op: znz_op ww),";
+  pp "    znz_digits (nmake_op _ w_op (S n)) =";
   pp "    xO (znz_digits (nmake_op _ w_op n)).";
   pp " Proof.";
   pp " auto.";
@@ -257,30 +249,30 @@ let _ =
   pp "         (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op n)))).";
   pp "   rewrite Hrec; auto with arith.";
   pp " Qed.";
-  pp " ";
+  pp "";
 
 
   for i = 1 to size + 2 do
     pp " Let znz_to_Z_%i: forall x y," i;
-    pp "   znz_to_Z w%i_op (WW x y) = " i;
+    pp "   znz_to_Z w%i_op (WW x y) =" i;
     pp "    znz_to_Z w%i_op x * base (znz_digits w%i_op) + znz_to_Z w%i_op y." (i-1) (i-1) (i-1);
     pp " Proof.";
     pp " auto.";
-    pp " Qed. ";
+    pp " Qed.";
     pp "";
   done;
 
   pp " Let znz_to_Z_n: forall n x y,";
-  pp "   znz_to_Z (make_op (S n)) (WW x y) = ";
+  pp "   znz_to_Z (make_op (S n)) (WW x y) =";
   pp "    znz_to_Z (make_op n) x * base (znz_digits (make_op n)) + znz_to_Z (make_op n) y.";
   pp " Proof.";
   pp " intros n x y; rewrite make_op_S; auto.";
-  pp " Qed. ";
+  pp " Qed.";
   pp "";
 
   pp " Let w0_spec: znz_spec w0_op := W0.w_spec.";
   for i = 1 to 3 do
-    pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1) 
+    pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1)
   done;
   for i = 4 to size + 3 do
     pp " Let w%i_spec : znz_spec w%i_op := mk_znz2_karatsuba_spec w%i_spec." i i (i-1)
@@ -309,14 +301,14 @@ let _ =
 
 
   for i = 0 to size do
-    pp " Theorem digits_w%i:  znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i; 
+    pp " Theorem digits_w%i:  znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i;
     if i == 0 then
       pp " auto."
     else
       pp " rewrite digits_nmake; rewrite <- digits_w%i; auto." (i - 1);
     pp " Qed.";
     pp "";
-    pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i; 
+    pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i;
     pp " Proof.";
     pp "  intros n; exact (nmake_double n w%i w%i_op)." i i;
     pp " Qed.";
@@ -325,7 +317,7 @@ let _ =
 
   for i = 0 to size do
     for j = 0 to (size - i) do
-      pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j; 
+      pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j;
       pp " Proof.";
       if j == 0 then
         if i == 0 then
@@ -346,7 +338,7 @@ let _ =
         end;
       pp " Qed.";
       pp "";
-      pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j; 
+      pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j;
       pp " Proof.";
       if j == 0 then
         pp " intros x; rewrite spec_double_eval%in; unfold DoubleBase.double_to_Z, to_Z; auto." i
@@ -363,7 +355,7 @@ let _ =
       pp " Qed.";
       if i + j <> size  then
         begin
-          pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j; 
+          pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j;
           if j == 0 then
             begin
               pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." i (i + j);
@@ -393,7 +385,7 @@ let _ =
     pp " Qed.";
     pp "";
 
-    pp " Let spec_eval%in%i: forall x, [%sn 0  x] = eval%in %i x." i (size - i + 1) c i (size - i + 1); 
+    pp " Let spec_eval%in%i: forall x, [%sn 0  x] = eval%in %i x." i (size - i + 1) c i (size - i + 1);
     pp " Proof.";
     pp " intros x; case x.";
     pp "   auto.";
@@ -405,7 +397,7 @@ let _ =
     pp " Qed.";
     pp "";
 
-    pp " Let spec_eval%in%i: forall x, [%sn 1  x] = eval%in %i x." i (size - i + 2) c i (size - i + 2); 
+    pp " Let spec_eval%in%i: forall x, [%sn 1  x] = eval%in %i x." i (size - i + 2) c i (size - i + 2);
     pp " intros x; case x.";
     pp "   auto.";
     pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 2);
@@ -430,7 +422,7 @@ let _ =
   pp " Qed.";
   pp "";
 
-  pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size; 
+  pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size;
   pp " intros n; elim n; clear n.";
   pp "   exact spec_eval%in1." size;
   pp " intros n Hrec x; case x; clear x.";
@@ -446,7 +438,7 @@ let _ =
   pp " Qed.";
   pp "";
 
-  pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ; 
+  pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ;
   pp " intros n; elim n; clear n.";
   pp "   intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." size size;
   pp "   unfold to_Z.";
@@ -478,7 +470,6 @@ let _ =
   pp " unfold to_Z.";
   pp " case n1; auto; intros n2; repeat rewrite make_op_S; auto.";
   pp " Qed.";
-  pp " Hint Rewrite spec_extendn_0: extr.";
   pp "";
   pp " Let spec_extendn0_0: forall n wx, [%sn (S n) (WW W0 wx)] = [%sn n wx]." c c;
   pp " Proof.";
@@ -489,7 +480,6 @@ let _ =
   pp " case n; auto.";
   pp " intros n1; rewrite make_op_S; auto.";
   pp " Qed.";
-  pp " Hint Rewrite spec_extendn_0: extr.";
   pp "";
   pp " Let spec_extend_tr: forall m n (w: word _ (S n)),";
   pp " [%sn (m + n) (extend_tr w m)] = [%sn n w]." c c;
@@ -498,7 +488,6 @@ let _ =
   pp " intros n x; simpl extend_tr.";
   pp " simpl plus; rewrite spec_extendn0_0; auto.";
   pp " Qed.";
-  pp " Hint Rewrite spec_extend_tr: extr.";
   pp "";
   pp " Let spec_cast_l: forall n m x1,";
   pp " [%sn (Max.max n m)" c;
@@ -508,7 +497,6 @@ let _ =
   pp " intros n m x1; case (diff_r n m); simpl castm.";
   pp " rewrite spec_extend_tr; auto.";
   pp " Qed.";
-  pp " Hint Rewrite spec_cast_l: extr.";
   pp "";
   pp " Let spec_cast_r: forall n m x1,";
   pp " [%sn (Max.max n m)" c;
@@ -518,7 +506,6 @@ let _ =
   pp " intros n m x1; case (diff_l n m); simpl castm.";
   pp " rewrite spec_extend_tr; auto.";
   pp " Qed.";
-  pp " Hint Rewrite spec_cast_r: extr.";
   pp "";
 
 
@@ -578,14 +565,14 @@ let _ =
       pr "  | %s%i wx, %s%i wy => f%i (extend%i %i wx) wy" c i c j j i (j - i - 1);
     done;
     if i == size then
-      pr "  | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size 
-    else 
+      pr "  | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size
+    else
       pr "  | %s%i wx, %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c i c size i (size - i - 1);
   done;
   for i = 0 to size do
     if i == size then
-      pr "  | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size 
-    else 
+      pr "  | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size
+    else
       pr "  | %sn n wx, %s%i wy => fnn n wx (extend%i n (extend%i %i wy))" c c i size i (size - i - 1);
   done;
   pr "  | %sn n wx, Nn m wy =>" c;
@@ -611,17 +598,17 @@ let _ =
     done;
     if i == size then
       pp "     intros m y; rewrite (spec_extend%in m); apply Pfnn." size
-    else 
+    else
       pp "     intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size;
   done;
   pp "    intros n x y; case y; clear y.";
   for i = 0 to size do
     if i == size then
       pp "    intros y; rewrite (spec_extend%in n); apply Pfnn." size
-    else 
+    else
       pp "    intros y; rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size;
   done;
-  pp "    intros m y; rewrite <- (spec_cast_l n m x); ";
+  pp "    intros m y; rewrite <- (spec_cast_l n m x);";
   pp "          rewrite <- (spec_cast_r n m y); apply Pfnn.";
   pp "  Qed.";
   pp "";
@@ -644,7 +631,7 @@ let _ =
     pr "    match y with";
     for j = 0 to i - 1 do
       pr "    | %s%i wy =>" c j;
-      if j == 0 then 
+      if j == 0 then
         pr "       if w0_eq0 wy then ft0 x else";
       pr "       f%i wx (extend%i %i wy)" i j (i - j -1);
     done;
@@ -653,8 +640,8 @@ let _ =
       pr "    | %s%i wy => f%i (extend%i %i wx) wy" c j j i (j - i - 1);
     done;
     if i == size then
-      pr "    | %sn m wy => fnn m (extend%i m wx) wy" c size 
-    else 
+      pr "    | %sn m wy => fnn m (extend%i m wx) wy" c size
+    else
       pr "    | %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c size i (size - i - 1);
     pr"    end";
   done;
@@ -665,8 +652,8 @@ let _ =
     if i == 0 then
       pr "      if w0_eq0 wy then ft0 x else";
     if i == size then
-      pr "      fnn n wx (extend%i n wy)" size 
-    else 
+      pr "      fnn n wx (extend%i n wy)" size
+    else
       pr "      fnn n wx (extend%i n (extend%i %i wy))" size i (size - i - 1);
   done;
   pr "        | %sn m wy =>" c;
@@ -707,7 +694,7 @@ let _ =
     done;
     if i == size then
       pp "     intros m y; rewrite (spec_extend%in m); apply Pfnn." size
-    else 
+    else
       pp "     intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size;
   done;
   pp "    intros n x y; case y; clear y.";
@@ -721,16 +708,16 @@ let _ =
       end;
     if i == size then
       pp "    rewrite (spec_extend%in n); apply Pfnn." size
-    else 
+    else
       pp "    rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size;
   done;
-  pp "  intros m y; rewrite <- (spec_cast_l n m x); ";
+  pp "  intros m y; rewrite <- (spec_cast_l n m x);";
   pp "          rewrite <- (spec_cast_r n m y); apply Pfnn.";
   pp "  Qed.";
   pp "";
 
   pr "  (* We iter the smaller argument with the bigger  *)";
-  pr "  Definition iter (x y: t_): res := ";
+  pr "  Definition iter (x y: t_): res :=";
   pr0 "    Eval lazy zeta beta iota delta [";
   for i = 0 to size do
     pr0 "extend%i " i;
@@ -748,14 +735,14 @@ let _ =
       pr "  | %s%i wx, %s%i wy => f%in %i wx wy" c i c j i (j - i - 1);
     done;
     if i == size then
-      pr "  | %s%i wx, %sn m wy => f%in m wx wy" c size c size 
-    else 
+      pr "  | %s%i wx, %sn m wy => f%in m wx wy" c size c size
+    else
       pr "  | %s%i wx, %sn m wy => f%in m (extend%i %i wx) wy" c i c size i (size - i - 1);
   done;
   for i = 0 to size do
     if i == size then
-      pr "  | %sn n wx, %s%i wy => fn%i n wx wy" c c size size 
-    else 
+      pr "  | %sn n wx, %s%i wy => fn%i n wx wy" c c size size
+    else
       pr "  | %sn n wx, %s%i wy => fn%i n wx (extend%i %i wy)" c c i size i (size - i - 1);
   done;
   pr "  | %sn n wx, %sn m wy => fnm n m wx wy" c c;
@@ -765,6 +752,7 @@ let _ =
   pp "  Ltac zg_tac := try";
   pp "    (red; simpl Zcompare; auto;";
   pp "     let t := fresh \"H\" in (intros t; discriminate t)).";
+  pp "";
   pp "  Lemma spec_iter: forall x y, P [x] [y] (iter x y).";
   pp "  Proof.";
   pp "  intros x; case x; clear x; unfold iter.";
@@ -779,14 +767,14 @@ let _ =
     done;
     if i == size then
       pp "     intros m y; rewrite spec_eval%in; apply Pf%in." size size
-    else 
+    else
       pp "     intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size;
   done;
   pp "    intros n x y; case y; clear y.";
   for i = 0 to size do
     if i == size then
       pp "     intros y; rewrite spec_eval%in; apply Pfn%i." size size
-    else 
+    else
       pp "      intros y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size;
   done;
   pp "  intros m y; apply Pfnm.";
@@ -820,8 +808,8 @@ let _ =
       pr "    | %s%i wy => f%in %i wx wy" c j i (j - i - 1);
     done;
     if i == size then
-      pr "    | %sn m wy => f%in m wx wy" c size 
-    else 
+      pr "    | %sn m wy => f%in m wx wy" c size
+    else
       pr "    | %sn m wy => f%in m (extend%i %i wx) wy" c size i (size - i - 1);
     pr "    end";
   done;
@@ -832,8 +820,8 @@ let _ =
     if i == 0 then
       pr "      if w0_eq0 wy then ft0 x else";
     if i == size then
-      pr "      fn%i n wx wy" size 
-    else 
+      pr "      fn%i n wx wy" size
+    else
       pr "      fn%i n wx (extend%i %i wy)" size i (size - i - 1);
   done;
   pr "    | %sn m wy => fnm n m wx wy" c;
@@ -869,7 +857,7 @@ let _ =
     done;
     if i == size then
       pp "     intros m y; rewrite spec_eval%in; apply Pf%in." size size
-    else 
+    else
       pp "     intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size;
   done;
   pp "    intros n x y; case y; clear y.";
@@ -883,7 +871,7 @@ let _ =
       end;
     if i == size then
       pp "     rewrite spec_eval%in; apply Pfn%i." size size
-    else 
+    else
       pp "      rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size;
   done;
   pp "  intros m y; apply Pfnm.";
@@ -897,27 +885,27 @@ let _ =
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Reduction                         *)";
+  pr " (** *                        Reduction                         *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
 
-  pr " Definition reduce_0 (x:w) := %s0 x." c; 
+  pr " Definition reduce_0 (x:w) := %s0 x." c;
   pr " Definition reduce_1 :=";
   pr "  Eval lazy beta iota delta[reduce_n1] in";
   pr "   reduce_n1 _ _ zero w0_eq0 %s0 %s1." c c;
   for i = 2 to size do
     pr " Definition reduce_%i :=" i;
     pr "  Eval lazy beta iota delta[reduce_n1] in";
-    pr "   reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i." 
+    pr "   reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i."
       (i-1) (i-1)  c i
   done;
   pr " Definition reduce_%i :=" (size+1);
   pr "  Eval lazy beta iota delta[reduce_n1] in";
-  pr "   reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)." 
-    size size c; 
+  pr "   reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)."
+    size size c;
 
-  pr " Definition reduce_n n := ";
+  pr " Definition reduce_n n :=";
   pr "  Eval lazy beta iota delta[reduce_n] in";
   pr "   reduce_n _ _ zero reduce_%i %sn n." (size + 1) c;
   pr "";
@@ -927,7 +915,7 @@ let _ =
   pp " intros x; unfold to_Z, reduce_0.";
   pp " auto.";
   pp " Qed.";
-  pp " ";
+  pp "";
 
   for i = 1 to size + 1 do
     if i == size + 1 then
@@ -938,14 +926,14 @@ let _ =
     pp " intros x; case x; unfold reduce_%i." i;
     pp " exact (spec_0 w0_spec).";
     pp " intros x1 y1.";
-    pp " generalize (spec_w%i_eq0 x1); " (i - 1);
+    pp " generalize (spec_w%i_eq0 x1);" (i - 1);
     pp "   case w%i_eq0; intros H1; auto." (i - 1);
-    if i <> 1 then 
+    if i <> 1 then
       pp " rewrite spec_reduce_%i." (i - 1);
     pp " unfold to_Z; rewrite znz_to_Z_%i." i;
     pp " unfold to_Z in H1; rewrite H1; auto.";
     pp " Qed.";
-    pp " ";
+    pp "";
   done;
 
   pp " Let spec_reduce_n: forall n x, [reduce_n n x] = [%sn n x]." c;
@@ -959,11 +947,11 @@ let _ =
   pp " rewrite Hrec.";
   pp " rewrite spec_extendn0_0; auto.";
   pp " Qed.";
-  pp " ";
+  pp "";
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Successor                         *)";
+  pr " (** *                        Successor                         *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -983,19 +971,19 @@ let _ =
   for i = 0 to size-1 do
     pr "  | %s%i wx =>" c i;
     pr "    match w%i_succ_c wx with" i;
-    pr "    | C0 r => %s%i r" c i; 
+    pr "    | C0 r => %s%i r" c i;
     pr "    | C1 r => %s%i (WW one%i r)" c (i+1) i;
     pr "    end";
   done;
   pr "  | %s%i wx =>" c size;
   pr "    match w%i_succ_c wx with" size;
-  pr "    | C0 r => %s%i r" c size; 
+  pr "    | C0 r => %s%i r" c size;
   pr "    | C1 r => %sn 0 (WW one%i r)" c size ;
   pr "    end";
   pr "  | %sn n wx =>" c;
   pr "    let op := make_op n in";
   pr "    match op.(znz_succ_c) wx with";
-  pr "    | C0 r => %sn n r" c; 
+  pr "    | C0 r => %sn n r" c;
   pr "    | C1 r => %sn (S n) (WW op.(znz_1) r)" c;
   pr "    end";
   pr "  end.";
@@ -1027,13 +1015,13 @@ let _ =
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Adddition                         *)";
+  pr " (** *                        Adddition                         *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
 
   for i = 0 to size do
-    pr " Definition w%i_add_c := znz_add_c w%i_op." i i; 
+    pr " Definition w%i_add_c := znz_add_c w%i_op." i i;
     pr " Definition w%i_add x y :=" i;
     pr "  match w%i_add_c x y with" i;
     pr "  | C0 r => %s%i r" c i;
@@ -1057,26 +1045,24 @@ let _ =
     pp " Proof.";
     pp " intros n m; unfold to_Z, w%i_add, w%i_add_c." i i;
     pp "  generalize (spec_add_c w%i_spec n m); case znz_add_c; auto." i;
-    pp " intros ww H; rewrite <- H."; 
+    pp " intros ww H; rewrite <- H.";
     pp "    rewrite znz_to_Z_%i; unfold interp_carry;" (i + 1);
     pp "    apply f_equal2 with (f := Zplus); auto;";
     pp "    apply f_equal2 with (f := Zmult); auto;";
     pp "    exact (spec_1 w%i_spec)." i;
     pp " Qed.";
-    pp " Hint Rewrite spec_w%i_add: addr." i;
     pp "";
   done;
   pp " Let spec_wn_add: forall n x y, [addn n x y] = [%sn n x] + [%sn n y]." c c;
   pp " Proof.";
   pp " intros k n m; unfold to_Z, addn.";
   pp "  generalize (spec_add_c (wn_spec k) n m); case znz_add_c; auto.";
-  pp " intros ww H; rewrite <- H."; 
+  pp " intros ww H; rewrite <- H.";
   pp " rewrite (znz_to_Z_n k); unfold interp_carry;";
   pp "        apply f_equal2 with (f := Zplus); auto;";
   pp "        apply f_equal2 with (f := Zmult); auto;";
   pp "        exact (spec_1 (wn_spec k)).";
   pp " Qed.";
-  pp " Hint Rewrite spec_wn_add: addr.";
 
   pr " Definition add := Eval lazy beta delta [same_level] in";
   pr0 "   (same_level t_ ";
@@ -1101,7 +1087,7 @@ let _ =
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Predecessor                       *)";
+  pr " (** *                        Predecessor                       *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -1116,25 +1102,25 @@ let _ =
   for i = 0 to size do
     pr "  | %s%i wx =>" c i;
     pr "    match w%i_pred_c wx with" i;
-    pr "    | C0 r => reduce_%i r" i; 
+    pr "    | C0 r => reduce_%i r" i;
     pr "    | C1 r => zero";
     pr "    end";
   done;
   pr "  | %sn n wx =>" c;
   pr "    let op := make_op n in";
   pr "    match op.(znz_pred_c) wx with";
-  pr "    | C0 r => reduce_n n r"; 
+  pr "    | C0 r => reduce_n n r";
   pr "    | C1 r => zero";
   pr "    end";
   pr "  end.";
   pr "";
 
-  pr " Theorem spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1.";
+  pr " Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1.";
   pa " Admitted.";
   pp " Proof.";
   pp " intros x; case x; unfold pred.";
   for i = 0 to size do
-    pp " intros x1 H1; unfold w%i_pred_c; " i;
+    pp " intros x1 H1; unfold w%i_pred_c;" i;
     pp " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1." i;
     pp " rewrite spec_reduce_%i; auto." i;
     pp " unfold interp_carry; unfold to_Z.";
@@ -1143,7 +1129,7 @@ let _ =
     pp " assert (znz_to_Z w%i_op x1 - 1 < 0); auto with zarith." i;
     pp " unfold to_Z in H1; auto with zarith.";
   done;
-  pp " intros n x1 H1;  ";
+  pp " intros n x1 H1;";
   pp "   generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1.";
   pp "   rewrite spec_reduce_n; auto.";
   pp " unfold interp_carry; unfold to_Z.";
@@ -1152,32 +1138,31 @@ let _ =
   pp " assert (znz_to_Z (make_op n) x1 - 1 < 0); auto with zarith.";
   pp " unfold to_Z in H1; auto with zarith.";
   pp " Qed.";
-  pp " ";
-  
+  pp "";
+
   pp " Let spec_pred0: forall x, [x] = 0 -> [pred x] = 0.";
   pp " Proof.";
   pp " intros x; case x; unfold pred.";
   for i = 0 to size do
-    pp " intros x1 H1; unfold w%i_pred_c; " i;
+    pp " intros x1 H1; unfold w%i_pred_c;" i;
     pp "   generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1." i;
     pp " unfold interp_carry; unfold to_Z.";
     pp " unfold to_Z in H1; auto with zarith.";
     pp " case (spec_to_Z w%i_spec y1); intros HH3 HH4; auto with zarith." i;
     pp " intros; exact (spec_0 w0_spec).";
   done;
-  pp " intros n x1 H1; ";
+  pp " intros n x1 H1;";
   pp "   generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1.";
   pp " unfold interp_carry; unfold to_Z.";
   pp " unfold to_Z in H1; auto with zarith.";
   pp " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4; auto with zarith.";
   pp " intros; exact (spec_0 w0_spec).";
   pp " Qed.";
-  pr " ";
-
+  pr "";
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Subtraction                       *)";
+  pr " (** *                        Subtraction                       *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -1187,7 +1172,7 @@ let _ =
   done;
   pr "";
 
-  for i = 0 to size do 
+  for i = 0 to size do
     pr " Definition w%i_sub x y :=" i;
     pr "  match w%i_sub_c x y with" i;
     pr "  | C0 r => reduce_%i r" i;
@@ -1208,8 +1193,8 @@ let _ =
     pp " Let spec_w%i_sub: forall x y, [%s%i y] <= [%s%i x] -> [w%i_sub x y] = [%s%i x] - [%s%i y]." i c i c i i c i c i;
     pp " Proof.";
     pp " intros n m; unfold w%i_sub, w%i_sub_c." i i;
-    pp "  generalize (spec_sub_c w%i_spec n m); case znz_sub_c; " i;
-    if i == 0 then 
+    pp "  generalize (spec_sub_c w%i_spec n m); case znz_sub_c;" i;
+    if i == 0 then
       pp "    intros x; auto."
     else
       pp "   intros x; try rewrite spec_reduce_%i; auto." i;
@@ -1219,11 +1204,11 @@ let _ =
     pp " Qed.";
     pp "";
   done;
-  
+
   pp " Let spec_wn_sub: forall n x y, [%sn n y] <= [%sn n x] -> [subn n x y] = [%sn n x] - [%sn n y]." c c c c;
   pp " Proof.";
   pp " intros k n m; unfold subn.";
-  pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; ";
+  pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c;";
   pp "   intros x; auto.";
   pp " unfold interp_carry, to_Z.";
   pp " case (spec_to_Z (wn_spec k) x); intros; auto with zarith.";
@@ -1238,7 +1223,7 @@ let _ =
   pr "subn).";
   pr "";
 
-  pr " Theorem spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y].";
+  pr " Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y].";
   pa " Admitted.";
   pp " Proof.";
   pp " unfold sub.";
@@ -1255,7 +1240,7 @@ let _ =
     pp " Let spec_w%i_sub0: forall x y, [%s%i x] < [%s%i y] -> [w%i_sub x y] = 0." i c i c i i;
     pp " Proof.";
     pp " intros n m; unfold w%i_sub, w%i_sub_c." i i;
-    pp "  generalize (spec_sub_c w%i_spec n m); case znz_sub_c; " i;
+    pp "  generalize (spec_sub_c w%i_spec n m); case znz_sub_c;" i;
     pp "   intros x; unfold interp_carry.";
     pp "   unfold to_Z; case (spec_to_Z w%i_spec x); intros; auto with zarith." i;
     pp " intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto.";
@@ -1266,7 +1251,7 @@ let _ =
   pp " Let spec_wn_sub0: forall n x y, [%sn n x] < [%sn n y] -> [subn n x y] = 0." c c;
   pp " Proof.";
   pp " intros k n m; unfold subn.";
-  pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; ";
+  pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c;";
   pp "   intros x; unfold interp_carry.";
   pp "   unfold to_Z; case (spec_to_Z (wn_spec k) x); intros; auto with zarith.";
   pp " intros; unfold to_Z, w_0; rewrite (spec_0 (w0_spec)); auto.";
@@ -1289,7 +1274,7 @@ let _ =
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Comparison                        *)";
+  pr " (** *                        Comparison                        *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -1299,7 +1284,7 @@ let _ =
     pr " Definition comparen_%i :=" i;
     pr "  compare_mn_1 w%i w%i %s compare_%i (compare_%i %s) compare_%i." i i (pz i) i i (pz i) i
   done;
-  pr ""; 
+  pr "";
 
   pr " Definition comparenm n m wx wy :=";
   pr "    let mn := Max.max n m in";
@@ -1310,8 +1295,8 @@ let _ =
   pr "       (castm (diff_l n m) (extend_tr wy (fst d))).";
   pr "";
 
-  pr " Definition compare := Eval lazy beta delta [iter] in ";
-  pr "   (iter _ ";
+  pr " Definition compare := Eval lazy beta delta [iter] in";
+  pr "   (iter _";
   for i = 0 to size do
     pr "      compare_%i" i;
     pr "      (fun n x y => opp_compare (comparen_%i (S n) y x))" i;
@@ -1320,15 +1305,9 @@ let _ =
   pr "      comparenm).";
   pr "";
 
-  pr " Definition lt n m := compare n m = Lt.";
-  pr " Definition le n m := compare n m <> Gt.";
-  pr " Definition min n m := match compare n m with Gt => m | _ => n end.";
-  pr " Definition max n m := match compare n m with Lt => m | _ => n end.";
-  pr "";
-
   for i = 0 to size do
     pp " Let spec_compare_%i: forall x y," i;
-    pp "    match compare_%i x y with " i;
+    pp "    match compare_%i x y with" i;
     pp "      Eq => [%s%i x] = [%s%i y]" c i c i;
     pp "    | Lt => [%s%i x] < [%s%i y]" c i c i;
     pp "    | Gt => [%s%i x] > [%s%i y]" c i c i;
@@ -1337,7 +1316,7 @@ let _ =
     pp "  unfold compare_%i, to_Z; exact (spec_compare w%i_spec)." i i;
     pp "  Qed.";
     pp "";
-    
+
     pp "  Let spec_comparen_%i:" i;
     pp "  forall (n : nat) (x : word w%i n) (y : w%i)," i i;
     pp "  match comparen_%i n x y with" i;
@@ -1367,16 +1346,16 @@ let _ =
   pp "";
 
 
-  pr " Theorem spec_compare: forall x y,";
-  pr "    match compare x y with ";
+  pr " Theorem spec_compare_aux: forall x y,";
+  pr "    match compare x y with";
   pr "      Eq => [x] = [y]";
   pr "    | Lt => [x] < [y]";
   pr "    | Gt => [x] > [y]";
   pr "    end.";
   pa " Admitted.";
   pp " Proof.";
-  pp " refine (spec_iter _ (fun x y res => ";
-  pp "                       match res with ";
+  pp " refine (spec_iter _ (fun x y res =>";
+  pp "                       match res with";
   pp "                        Eq => x = y";
   pp "                      | Lt => x < y";
   pp "                      | Gt => x > y";
@@ -1387,12 +1366,12 @@ let _ =
     pp "      (fun n => comparen_%i (S n)) _ _ _" i;
   done;
   pp "      comparenm _).";
-  
+
   for i = 0 to size - 1 do
     pp "  exact spec_compare_%i." i;
     pp "  intros n x y H;apply spec_opp_compare; apply spec_comparen_%i." i;
     pp "  intros n x y H; exact (spec_comparen_%i (S n) x y)." i;
-  done; 
+  done;
   pp "  exact spec_compare_%i." size;
   pp "  intros n x y;apply spec_opp_compare; apply spec_comparen_%i." size;
   pp "  intros n; exact (spec_comparen_%i (S n))." size;
@@ -1402,28 +1381,9 @@ let _ =
   pp "  Qed.";
   pr "";
 
-  pr " Definition eq_bool x y :=";
-  pr "  match compare x y with";
-  pr "  | Eq => true";
-  pr "  | _  => false";
-  pr "  end.";
-  pr "";
-
-
-  pr " Theorem spec_eq_bool: forall x y,";
-  pr "    if eq_bool x y then [x] = [y] else [x] <> [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x y; unfold eq_bool.";
-  pp " generalize (spec_compare x y); case compare; auto with zarith.";
-  pp "  Qed.";
-  pr "";
-
-
-
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Multiplication                    *)";
+  pr " (** *                        Multiplication                    *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -1461,7 +1421,7 @@ let _ =
     pr "  match n return word w%i (S n) -> t_ with" i;
     for j = 0 to size - i do
       if (i + j) == size then
-        begin 
+        begin
           pr "  | %i%s => fun x => %sn 0 x" j "%nat" c;
           pr "  | %i%s => fun x => %sn 1 x" (j + 1) "%nat" c
         end
@@ -1471,7 +1431,7 @@ let _ =
     pr   "  | _   => fun _ => N0 w_0";
     pr "  end.";
     pr "";
-  done; 
+  done;
 
 
   for i = 0 to size - 1 do
@@ -1486,7 +1446,7 @@ let _ =
     pp " repeat rewrite inj_S; unfold Zsucc; auto with zarith.";
     pp " Qed.";
     pp "";
-  done; 
+  done;
 
 
   for i = 0 to size do
@@ -1497,8 +1457,8 @@ let _ =
         pr " if w%i_eq0 w then %sn n r" i c;
         pr " else %sn (S n) (WW (extend%i n w) r)." c i;
       end
-    else 
-      begin 
+    else
+      begin
         pr " if w%i_eq0 w then to_Z%i n r" i i;
         pr " else to_Z%i (S n) (WW (extend%i n w) r)." i i;
       end;
@@ -1514,10 +1474,10 @@ let _ =
   pr "       (castm (diff_l n m) (extend_tr y (fst d)))).";
   pr "";
 
-  pr " Definition mul := Eval lazy beta delta [iter0] in ";
-  pr "  (iter0 t_ ";
+  pr " Definition mul := Eval lazy beta delta [iter0] in";
+  pr "  (iter0 t_";
   for i = 0 to size do
-    pr "    (fun x y => reduce_%i (w%i_mul_c x y)) " (i + 1) i;
+    pr "    (fun x y => reduce_%i (w%i_mul_c x y))" (i + 1) i;
     pr "    (fun n x y => w%i_mul n y x)" i;
     pr "    w%i_mul" i;
   done;
@@ -1556,7 +1516,7 @@ let _ =
     pp " Qed.";
     pp "";
   done;
-  
+
   pp "  Lemma nmake_op_WW: forall ww ww1 n x y,";
   pp "    znz_to_Z (nmake_op ww ww1 (S n)) (WW x y) =";
   pp "    znz_to_Z (nmake_op ww ww1 n) x * base (znz_digits (nmake_op ww ww1 n)) +";
@@ -1564,21 +1524,21 @@ let _ =
   pp "    auto.";
   pp "  Qed.";
   pp "";
-  
+
   for i = 0 to size do
     pp "  Lemma extend%in_spec: forall n x1," i;
-    pp "  znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) = " i i;
+    pp "  znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) =" i i;
     pp "  znz_to_Z w%i_op x1." i;
     pp "  Proof.";
     pp "    intros n1 x2; rewrite nmake_double.";
     pp "    unfold extend%i." i;
     pp "    rewrite DoubleBase.spec_extend; auto.";
-    if i == 0 then 
+    if i == 0 then
       pp "    intros l; simpl; unfold w_0; rewrite (spec_0 w0_spec); ring.";
     pp "  Qed.";
     pp "";
   done;
-  
+
   pp "  Lemma spec_muln:";
   pp "    forall n (x: word _ (S n)) y,";
   pp "     [%sn (S n) (znz_mul_c (make_op n) x y)] = [%sn n x] * [%sn n y]." c c c;
@@ -1588,12 +1548,13 @@ let _ =
   pp "    rewrite make_op_S.";
   pp "    case znz_mul_c; auto.";
   pp "  Qed.";
+  pr "";
 
   pr "  Theorem spec_mul: forall x y, [mul x y] = [x] * [y].";
   pa "  Admitted.";
   pp "  Proof.";
   for i = 0 to size do
-    pp "    assert(F%i: " i;
+    pp "    assert(F%i:" i;
     pp "    forall n x y,";
     if i <> size then
       pp0 "    Z_of_nat n <= %i -> "   (size - i);
@@ -1614,7 +1575,7 @@ let _ =
     pp "    generalize (spec_w%i_eq0 x1); case w%i_eq0; intros HH." i i;
     pp "    unfold to_Z in HH; rewrite HH.";
     if i == size then
-      begin 
+      begin
         pp "    rewrite spec_eval%in; unfold eval%in, nmake_op%i; auto." i i i;
         pp "    rewrite spec_eval%in; unfold eval%in, nmake_op%i." i i i
       end
@@ -1627,7 +1588,7 @@ let _ =
   done;
   pp "    refine (spec_iter0 t_ (fun x y res => [res] = x * y)";
   for i = 0 to size do
-    pp "    (fun x y => reduce_%i (w%i_mul_c x y)) " (i + 1) i;
+    pp "    (fun x y => reduce_%i (w%i_mul_c x y))" (i + 1) i;
     pp "    (fun n x y => w%i_mul n y x)" i;
     pp "    w%i_mul _ _ _" i;
   done;
@@ -1643,12 +1604,12 @@ let _ =
     if i == size then
       begin
         pp "    intros n x y; rewrite F%i; auto with zarith." i;
-        pp "    intros n x y; rewrite F%i; auto with zarith. " i;
+        pp "    intros n x y; rewrite F%i; auto with zarith." i;
       end
     else
       begin
         pp "    intros n x y H; rewrite F%i; auto with zarith." i;
-        pp "    intros n x y H; rewrite F%i; auto with zarith. " i;
+        pp "    intros n x y H; rewrite F%i; auto with zarith." i;
       end;
   done;
   pp "    intros n m x y; unfold mulnm.";
@@ -1663,7 +1624,7 @@ let _ =
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Square                            *)";
+  pr " (** *                        Square                            *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -1702,42 +1663,9 @@ let _ =
   pp "Qed.";
   pr "";
 
-
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Power                             *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr ""; 
-
-  pr " Fixpoint power_pos (x:%s) (p:positive) {struct p} : %s :=" t t;
-  pr "  match p with";
-  pr "  | xH => x";
-  pr "  | xO p => square (power_pos x p)";
-  pr "  | xI p => mul (square (power_pos x p)) x";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.";
-  pa " Admitted.";  
-  pp " Proof.";
-  pp " intros x n; generalize x; elim n; clear n x; simpl power_pos.";
-  pp " intros; rewrite spec_mul; rewrite spec_square; rewrite H.";
-  pp " rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith.";
-  pp " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.";
-  pp " rewrite Zpower_2; rewrite Zpower_1_r; auto.";
-  pp " intros; rewrite spec_square; rewrite H.";
-  pp " rewrite Zpos_xO; auto with zarith.";
-  pp " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.";
-  pp " rewrite Zpower_2; auto.";
-  pp " intros; rewrite Zpower_1_r; auto.";
-  pp " Qed.";
-  pp "";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (*                           Square root                       *)";
+  pr " (** *                        Square root                       *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
@@ -1772,26 +1700,26 @@ let _ =
 
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Division                          *)";
+  pr " (** *                        Division                          *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
-  pr ""; 
+  pr "";
 
   for i = 0 to size do
     pr " Definition w%i_div_gt := w%i_op.(znz_div_gt)." i i
   done;
   pr "";
 
-  pp " Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := ";
-  pp "   (spec_double_divn1 ";
+  pp " Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) :=";
+  pp "   (spec_double_divn1";
   pp "    ww_op.(znz_zdigits) ww_op.(znz_0)";
   pp "    (znz_WW ww_op) ww_op.(znz_head0)";
   pp "    ww_op.(znz_add_mul_div) ww_op.(znz_div21)";
   pp "    ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)";
-  pp "    (spec_to_Z ww_spec) ";
+  pp "    (spec_to_Z ww_spec)";
   pp "    (spec_zdigits ww_spec)";
   pp "   (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)";
-  pp "   (spec_add_mul_div ww_spec) (spec_div21 ww_spec) ";
+  pp "   (spec_add_mul_div ww_spec) (spec_div21 ww_spec)";
   pp "    (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec)).";
   pp "";
 
@@ -1811,7 +1739,7 @@ let _ =
 
   for i = 0 to size do
     pp " Lemma spec_get_end%i: forall n x y," i;
-    pp "    eval%in n x  <= [%s%i y] -> " i c i;
+    pp "    eval%in n x  <= [%s%i y] ->" i c i;
     pp "     [%s%i (DoubleBase.get_low %s n x)] = eval%in n x." c i (pz i) i;
     pp " Proof.";
     pp " intros n x y H.";
@@ -1843,8 +1771,8 @@ let _ =
   pr "";
 
   pr " Definition div_gt := Eval lazy beta delta [iter] in";
-  pr "   (iter _ ";
-  for i = 0 to size do 
+  pr "   (iter _";
+  for i = 0 to size do
     pr "      div_gt%i" i;
     pr "      (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i);
     pr "      w%i_divn1" i;
@@ -1862,10 +1790,10 @@ let _ =
   pp "   forall x y, [x] > [y] -> 0 < [y] ->";
   pp "      let (q,r) := div_gt x y in";
   pp "      [x] = [q] * [y] + [r] /\\ 0 <= [r] < [y]).";
-  pp "  refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->";  
+  pp "  refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->";
   pp "      let (q,r) := res in";
   pp "      x = [q] * y + [r] /\\ 0 <= [r] < y)";
-  for i = 0 to size do 
+  for i = 0 to size do
     pp "      div_gt%i" i;
     pp "      (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i);
     pp "      w%i_divn1 _ _ _" i;
@@ -1879,11 +1807,11 @@ let _ =
       pp "  intros n x y H2 H3; unfold div_gt%i, w%i_div_gt." i i
     else
       pp "  intros n x y H1 H2 H3; unfold div_gt%i, w%i_div_gt." i i;
-    pp "    generalize (spec_div_gt w%i_spec x " i;
+    pp "    generalize (spec_div_gt w%i_spec x" i;
     pp "                (DoubleBase.get_low %s (S n) y))." (pz i);
-    pp0 "    ";
+    pp0 "";
     for j = 0 to i do
-      pp0 "unfold w%i; " (i-j); 
+      pp0 "unfold w%i; " (i-j);
     done;
     pp "case znz_div_gt.";
     pp "    intros xx yy H4; repeat rewrite spec_reduce_%i." i;
@@ -1897,7 +1825,7 @@ let _ =
     pp "     (spec_divn1 w%i w%i_op w%i_spec (S n) x y H3)." i i i;
     pp0 "    unfold w%i_divn1; " i;
     for j = 0 to i do
-      pp0 "unfold w%i; " (i-j); 
+      pp0 "unfold w%i; " (i-j);
     done;
     pp "case double_divn1.";
     pp "    intros xx yy H4.";
@@ -1936,61 +1864,12 @@ let _ =
   pp "  Qed.";
   pr "";
 
-  pr " Definition div_eucl x y :=";
-  pr "  match compare x y with";
-  pr "  | Eq => (one, zero)";
-  pr "  | Lt => (zero, x)";
-  pr "  | Gt => div_gt x y";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_div_eucl: forall x y,";
-  pr "      0 < [y] ->";
-  pr "      let (q,r) := div_eucl x y in";
-  pr "      ([q], [r]) = Zdiv_eucl [x] [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " assert (F0: [zero] = 0).";
-  pp "   exact (spec_0 w0_spec).";
-  pp " assert (F1: [one] = 1).";
-  pp "   exact (spec_1 w0_spec).";
-  pp " intros x y H; generalize (spec_compare x y);";
-  pp "   unfold div_eucl; case compare; try rewrite F0;";
-  pp "   try rewrite F1; intros; auto with zarith.";
-  pp " rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H))";
-  pp "                        (Z_mod_same [y] (Zlt_gt _ _ H));";
-  pp "  unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.";
-  pp " assert (F2: 0 <= [x] < [y]).";
-  pp "   generalize (spec_pos x); auto.";
-  pp " generalize (Zdiv_small _ _ F2)";
-  pp "            (Zmod_small _ _ F2);";
-  pp "  unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.";
-  pp " generalize (spec_div_gt _ _ H0 H); auto.";
-  pp " unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt.";
-  pp " intros a b c d (H1, H2); subst; auto.";
-  pp " Qed.";
-  pr "";
-
-  pr " Definition div x y := fst (div_eucl x y).";
-  pr "";
-
-  pr " Theorem spec_div:";
-  pr "   forall x y, 0 < [y] -> [div x y] = [x] / [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x y H1; unfold div; generalize (spec_div_eucl x y H1);";
-  pp "   case div_eucl; simpl fst.";
-  pp " intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H; ";
-  pp "  injection H; auto.";
-  pp " Qed.";
-  pr "";
-
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                           Modulo                            *)";
+  pr " (** *                        Modulo                            *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
-  pr ""; 
+  pr "";
 
   for i = 0 to size do
     pr " Definition w%i_mod_gt := w%i_op.(znz_mod_gt)." i i
@@ -2015,7 +1894,7 @@ let _ =
   pr "";
 
   pr " Definition mod_gt := Eval lazy beta delta[iter] in";
-  pr "   (iter _ ";
+  pr "   (iter _";
   for i = 0 to size do
     pr "      (fun x y => reduce_%i (w%i_mod_gt x y))" i i;
     pr "      (fun n x y => reduce_%i (w%i_mod_gt x (DoubleBase.get_low %s (S n) y)))" i i (pz i);
@@ -2024,16 +1903,16 @@ let _ =
   pr "      mod_gtnm).";
   pr "";
 
-  pp " Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := ";
-  pp "   (spec_double_modn1 ";
+  pp " Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) :=";
+  pp "   (spec_double_modn1";
   pp "    ww_op.(znz_zdigits) ww_op.(znz_0)";
   pp "    (znz_WW ww_op) ww_op.(znz_head0)";
   pp "    ww_op.(znz_add_mul_div) ww_op.(znz_div21)";
   pp "    ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)";
-  pp "    (spec_to_Z ww_spec) ";
+  pp "    (spec_to_Z ww_spec)";
   pp "    (spec_zdigits ww_spec)";
   pp "   (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)";
-  pp "   (spec_add_mul_div ww_spec) (spec_div21 ww_spec) ";
+  pp "   (spec_add_mul_div ww_spec) (spec_div21 ww_spec)";
   pp "    (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec)).";
   pp "";
 
@@ -2063,7 +1942,7 @@ let _ =
     pp " rewrite <- (spec_get_end%i (S n) y x) in H3; auto with zarith." i;
     if i == size then
       pp " intros n x y H2 H3; rewrite spec_reduce_%i." i
-    else 
+    else
       pp " intros n x y H1 H2 H3; rewrite spec_reduce_%i." i;
     pp " unfold w%i_modn1, to_Z; rewrite spec_double_eval%in." i i;
     pp " apply (spec_modn1 _ _ w%i_spec); auto." i;
@@ -2079,39 +1958,9 @@ let _ =
   pp " Qed.";
   pr "";
 
-  pr " Definition modulo x y := ";
-  pr "  match compare x y with";
-  pr "  | Eq => zero";
-  pr "  | Lt => x";
-  pr "  | Gt => mod_gt x y";
-  pr "  end.";
+  pr " (** digits: a measure for gcd *)";
   pr "";
 
-  pr " Theorem spec_modulo:";
-  pr "   forall x y, 0 < [y] -> [modulo x y] = [x] mod [y].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " assert (F0: [zero] = 0).";
-  pp "   exact (spec_0 w0_spec).";
-  pp " assert (F1: [one] = 1).";
-  pp "   exact (spec_1 w0_spec).";
-  pp " intros x y H; generalize (spec_compare x y);";
-  pp "   unfold modulo; case compare; try rewrite F0;";
-  pp "   try rewrite F1; intros; try split; auto with zarith.";
-  pp " rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith.";
-  pp " apply sym_equal; apply Zmod_small; auto with zarith.";
-  pp " generalize (spec_pos x); auto with zarith.";
-  pp " apply spec_mod_gt; auto.";
-  pp " Qed.";
-  pr "";
-
-  pr " (***************************************************************)";
-  pr " (*                                                             *)";
-  pr " (*                           Gcd                               *)";
-  pr " (*                                                             *)";
-  pr " (***************************************************************)";
-  pr ""; 
-
   pr " Definition digits x :=";
   pr "  match x with";
   for i = 0 to size do
@@ -2134,189 +1983,18 @@ let _ =
   pp " Qed.";
   pr "";
 
-  pr " Definition gcd_gt_body a b cont :=";
-  pr "  match compare b zero with";
-  pr "  | Gt =>";
-  pr "    let r := mod_gt a b in";
-  pr "    match compare r zero with";
-  pr "    | Gt => cont r (mod_gt b r)";
-  pr "    | _ => b";
-  pr "    end";
-  pr "  | _ => a";
-  pr "  end.";
-  pr "";
-
-  pp " Theorem Zspec_gcd_gt_body: forall a b cont p,";
-  pp "    [a] > [b] -> [a] < 2 ^ p ->";
-  pp "      (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] ->";
-  pp "         Zis_gcd  [a1] [b1] [cont a1 b1]) ->                   ";
-  pp "      Zis_gcd [a] [b] [gcd_gt_body a b cont].";
-  pp " Proof.";
-  pp " assert (F1: [zero] = 0).";
-  pp "   unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.";
-  pp " intros a b cont p H2 H3 H4; unfold gcd_gt_body.";
-  pp " generalize (spec_compare b zero); case compare; try rewrite F1.";
-  pp "   intros HH; rewrite HH; apply Zis_gcd_0.";
-  pp " intros HH; absurd (0 <= [b]); auto with zarith.";
-  pp " case (spec_digits b); auto with zarith.";
-  pp " intros H5; generalize (spec_compare (mod_gt a b) zero); ";
-  pp "   case compare; try rewrite F1.";
-  pp " intros H6; rewrite <- (Zmult_1_r [b]).";
-  pp " rewrite (Z_div_mod_eq [a] [b]); auto with zarith.";
-  pp " rewrite <- spec_mod_gt; auto with zarith.";
-  pp " rewrite H6; rewrite Zplus_0_r.";
-  pp " apply Zis_gcd_mult; apply Zis_gcd_1.";
-  pp " intros; apply False_ind.";
-  pp " case (spec_digits (mod_gt a b)); auto with zarith.";
-  pp " intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith.";
-  pp " apply DoubleDiv.Zis_gcd_mod; auto with zarith.";
-  pp " rewrite <- spec_mod_gt; auto with zarith.";
-  pp " assert (F2: [b] > [mod_gt a b]).";
-  pp "   case (Z_mod_lt [a] [b]); auto with zarith.";
-  pp "   repeat rewrite <- spec_mod_gt; auto with zarith.";
-  pp " assert (F3: [mod_gt a b] > [mod_gt b  (mod_gt a b)]).";
-  pp "   case (Z_mod_lt [b] [mod_gt a b]); auto with zarith.";
-  pp "   rewrite <- spec_mod_gt; auto with zarith.";
-  pp " repeat rewrite <- spec_mod_gt; auto with zarith.";
-  pp " apply H4; auto with zarith.";
-  pp " apply Zmult_lt_reg_r with 2; auto with zarith.";
-  pp " apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith.";
-  pp " apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith.";
-  pp "   apply Zplus_le_compat_r.";
-  pp " pattern [b] at 1; rewrite <- (Zmult_1_l [b]).";
-  pp " apply Zmult_le_compat_r; auto with zarith.";
-  pp " case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith.";
-  pp " intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2;";
-  pp "   try rewrite <- HH in H2; auto with zarith.";
-  pp " case (Z_mod_lt [a] [b]); auto with zarith.";
-  pp " rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith.";
-  pp " rewrite <- Z_div_mod_eq; auto with zarith.";
-  pp " pattern 2 at 2; rewrite <- (Zpower_1_r 2).";
-  pp " rewrite <- Zpower_exp; auto with zarith.";
-  pp " ring_simplify (p - 1 + 1); auto.";
-  pp " case (Zle_lt_or_eq 0 p); auto with zarith.";
-  pp " generalize H3; case p; simpl Zpower; auto with zarith.";
-  pp " intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith.";
-  pp " Qed.";
-  pp "";
-
-  pr " Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t :=";
-  pr "  gcd_gt_body a b";
-  pr "    (fun a b =>";
-  pr "       match p with";
-  pr "       | xH => cont a b";
-  pr "       | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b";
-  pr "       | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b";
-  pr "       end).";
-  pr "";
-
-  pp " Theorem Zspec_gcd_gt_aux: forall p n a b cont,";
-  pp "    [a] > [b] -> [a] < 2 ^ (Zpos p + n) ->";
-  pp "      (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] ->";
-  pp "            Zis_gcd [a1] [b1] [cont a1 b1]) ->";
-  pp "          Zis_gcd [a] [b] [gcd_gt_aux p cont a b].";
-  pp " intros p; elim p; clear p.";
-  pp " intros p Hrec n a b cont H2 H3 H4.";
-  pp "   unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto.";
-  pp "   intros a1 b1 H6 H7.";
-  pp "     apply Hrec with (Zpos p + n); auto.";
-  pp "       replace (Zpos p + (Zpos p + n)) with";
-  pp "         (Zpos (xI p) + n  - 1); auto.";
-  pp "       rewrite Zpos_xI; ring.";
-  pp "   intros a2 b2 H9 H10.";
-  pp "     apply Hrec with n; auto.";
-  pp " intros p Hrec n a b cont H2 H3 H4.";
-  pp "   unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto.";
-  pp "   intros a1 b1 H6 H7.";
-  pp "     apply Hrec with (Zpos p + n - 1); auto.";
-  pp "       replace (Zpos p + (Zpos p + n - 1)) with";
-  pp "         (Zpos (xO p) + n  - 1); auto.";
-  pp "       rewrite Zpos_xO; ring.";
-  pp "   intros a2 b2 H9 H10.";
-  pp "     apply Hrec with (n - 1); auto.";
-  pp "       replace (Zpos p + (n - 1)) with";
-  pp "         (Zpos p + n  - 1); auto with zarith.";
-  pp "   intros a3 b3 H12 H13; apply H4; auto with zarith.";
-  pp "    apply Zlt_le_trans with (1 := H12).";
-  pp "    case (Zle_or_lt 1 n); intros HH.";
-  pp "    apply Zpower_le_monotone; auto with zarith.";
-  pp "    apply Zle_trans with 0; auto with zarith.";
-  pp "    assert (HH1: n - 1 < 0); auto with zarith.";
-  pp "    generalize HH1; case (n - 1); auto with zarith.";
-  pp "    intros p1 HH2; discriminate.";
-  pp " intros n a b cont H H2 H3.";
-  pp "  simpl gcd_gt_aux.";
-  pp "  apply Zspec_gcd_gt_body with (n + 1); auto with zarith.";
-  pp "  rewrite Zplus_comm; auto.";
-  pp "  intros a1 b1 H5 H6; apply H3; auto.";
-  pp "  replace n with (n + 1 - 1); auto; try ring.";
-  pp " Qed.";
-  pp "";
-
-  pr " Definition gcd_cont a b :=";
-  pr "  match compare one b with";
-  pr "  | Eq => one";
-  pr "  | _ => a";
-  pr "  end.";
-  pr "";
-
-  pr " Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b.";
-  pr "";
-
-  pr " Theorem spec_gcd_gt: forall a b,";
-  pr "   [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros a b H2.";
-  pp " case (spec_digits (gcd_gt a b)); intros H3 H4.";
-  pp " case (spec_digits a); intros H5 H6.";
-  pp " apply sym_equal; apply Zis_gcd_gcd; auto with zarith.";
-  pp " unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith.";
-  pp " intros a1 a2; rewrite Zpower_0_r.";
-  pp " case (spec_digits a2); intros H7 H8;";
-  pp "   intros; apply False_ind; auto with zarith.";
-  pp " Qed.";
-  pr "";
-
-  pr " Definition gcd a b :=";
-  pr "  match compare a b with";
-  pr "  | Eq => a";
-  pr "  | Lt => gcd_gt b a";
-  pr "  | Gt => gcd_gt a b";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros a b.";
-  pp " case (spec_digits a); intros H1 H2.";
-  pp " case (spec_digits b); intros H3 H4.";
-  pp " unfold gcd; generalize (spec_compare a b); case compare.";
-  pp " intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto.";
-  pp "   apply Zis_gcd_refl.";
-  pp " intros; apply trans_equal with (Zgcd [b] [a]).";
-  pp "   apply spec_gcd_gt; auto with zarith.";
-  pp " apply Zis_gcd_gcd; auto with zarith.";
-  pp " apply Zgcd_is_pos.";
-  pp " apply Zis_gcd_sym; apply Zgcd_is_gcd.";
-  pp " intros; apply spec_gcd_gt; auto.";
-  pp " Qed.";
-  pr "";
-
-
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                          Conversion                         *)";
+  pr " (** *                       Conversion                         *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
   pr "";
 
-  pr " Definition pheight p := ";
+  pr " Definition pheight p :=";
   pr "   Peano.pred (nat_of_P (get_height w0_op.(znz_digits) (plength p))).";
   pr "";
 
-  pr " Theorem pheight_correct: forall p, ";
+  pr " Theorem pheight_correct: forall p,";
   pr "    Zpos p < 2 ^ (Zpos (znz_digits w0_op) * 2 ^ (Z_of_nat (pheight p))).";
   pr " Proof.";
   pr " intros p; unfold pheight.";
@@ -2400,30 +2078,12 @@ let _ =
   pp "  Qed.";
   pr "";
 
-  pr " Definition of_N x :=";
-  pr "  match x with";
-  pr "  | BinNat.N0 => zero";
-  pr "  | Npos p => of_pos p";
-  pr "  end.";
-  pr "";
-
-  pr " Theorem spec_of_N: forall x,";
-  pr "   [of_N x] = Z_of_N x.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros x; case x.";
-  pp "  simpl of_N.";
-  pp "  unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.";
-  pp " intros p; exact (spec_of_pos p).";
-  pp " Qed.";
-  pr "";
-
   pr " (***************************************************************)";
   pr " (*                                                             *)";
-  pr " (*                          Shift                              *)";
+  pr " (** *                       Shift                              *)";
   pr " (*                                                             *)";
   pr " (***************************************************************)";
-  pr ""; 
+  pr "";
 
   (* Head0 *)
   pr " Definition head0 w := match w with";
@@ -2443,21 +2103,21 @@ let _ =
   done;
   pp " intros n x; rewrite spec_reduce_n; exact (spec_head00 (wn_spec n) x).";
   pp " Qed.";
-  pr "  ";
+  pr "";
 
   pr " Theorem spec_head0: forall x, 0 < [x] ->";
   pr "   2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x).";
   pa " Admitted.";
   pp " Proof.";
   pp " assert (F0: forall x, (x - 1) + 1 = x).";
-  pp "   intros; ring. ";
+  pp "   intros; ring.";
   pp " intros x; case x; unfold digits, head0; clear x.";
   for i = 0 to size do
     pp " intros x Hx; rewrite spec_reduce_%i." i;
     pp " assert (F1:= spec_more_than_1_digit w%i_spec)." i;
     pp " generalize (spec_head0 w%i_spec x Hx)." i;
     pp " unfold base.";
-    pp " pattern (Zpos (znz_digits w%i_op)) at 1; " i;
+    pp " pattern (Zpos (znz_digits w%i_op)) at 1;" i;
     pp " rewrite <- (fun x => (F0 (Zpos x))).";
     pp " rewrite Zpower_exp; auto with zarith.";
     pp " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith.";
@@ -2466,7 +2126,7 @@ let _ =
   pp " assert (F1:= spec_more_than_1_digit (wn_spec n)).";
   pp " generalize (spec_head0 (wn_spec n) x Hx).";
   pp " unfold base.";
-  pp " pattern (Zpos (znz_digits (make_op n))) at 1; ";
+  pp " pattern (Zpos (znz_digits (make_op n))) at 1;";
   pp " rewrite <- (fun x => (F0 (Zpos x))).";
   pp " rewrite Zpower_exp; auto with zarith.";
   pp " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith.";
@@ -2493,7 +2153,7 @@ let _ =
   done;
   pp " intros n x; rewrite spec_reduce_n; exact (spec_tail00 (wn_spec n) x).";
   pp " Qed.";
-  pr "  ";
+  pr "";
 
 
   pr " Theorem spec_tail0: forall x,";
@@ -2513,7 +2173,7 @@ let _ =
   pr " Definition %sdigits x :=" c;
   pr "  match x with";
   pr "  | %s0 _ => %s0 w0_op.(znz_zdigits)" c c;
-  for i = 1 to size do 
+  for i = 1 to size do
     pr "  | %s%i _ => reduce_%i w%i_op.(znz_zdigits)" c i i i;
   done;
   pr "  | %sn n _ => reduce_n n (make_op n).(znz_zdigits)" c;
@@ -2534,22 +2194,22 @@ let _ =
 
   (* Shiftr *)
   for i = 0 to size do
-    pr " Definition shiftr%i n x := w%i_op.(znz_add_mul_div) (w%i_op.(znz_sub) w%i_op.(znz_zdigits) n) w%i_op.(znz_0) x." i i i i i;
+    pr " Definition unsafe_shiftr%i n x := w%i_op.(znz_add_mul_div) (w%i_op.(znz_sub) w%i_op.(znz_zdigits) n) w%i_op.(znz_0) x." i i i i i;
   done;
-  pr " Definition shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x.";
+  pr " Definition unsafe_shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x.";
   pr "";
 
-  pr " Definition shiftr := Eval lazy beta delta [same_level] in ";
-  pr "     same_level _ (fun n x => %s0 (shiftr0 n x))" c;
+  pr " Definition unsafe_shiftr := Eval lazy beta delta [same_level] in";
+  pr "     same_level _ (fun n x => %s0 (unsafe_shiftr0 n x))" c;
   for i = 1 to size do
-    pr "           (fun n x => reduce_%i (shiftr%i n x))" i i;
+    pr "           (fun n x => reduce_%i (unsafe_shiftr%i n x))" i i;
   done;
-  pr "           (fun n p x => reduce_n n (shiftrn n p x)).";
+  pr "           (fun n p x => reduce_n n (unsafe_shiftrn n p x)).";
   pr "";
 
 
-  pr " Theorem spec_shiftr: forall n x,";
-  pr "  [n] <= [Ndigits x] -> [shiftr n x] = [x] / 2 ^ [n].";
+  pr " Theorem spec_unsafe_shiftr: forall n x,";
+  pr "  [n] <= [Ndigits x] -> [unsafe_shiftr n x] = [x] / 2 ^ [n].";
   pa " Admitted.";
   pp " Proof.";
   pp " assert (F0: forall x y, x - (x - y) = y).";
@@ -2568,7 +2228,7 @@ let _ =
   pp "    split; auto with zarith.";
   pp "    apply Zle_lt_trans with xx; auto with zarith.";
   pp "    apply Zpower2_lt_lin; auto with zarith.";
-  pp "  assert (F4: forall ww ww1 ww2 ";
+  pp "  assert (F4: forall ww ww1 ww2";
   pp "         (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)";
   pp "           xx yy xx1 yy1,";
   pp "  znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_zdigits ww1_op) ->";
@@ -2586,7 +2246,7 @@ let _ =
   pp "     rewrite <- Hy.";
   pp "     generalize (spec_add_mul_div Hw";
   pp "                  (znz_0 ww_op) xx1";
-  pp "                  (znz_sub ww_op (znz_zdigits ww_op) ";
+  pp "                  (znz_sub ww_op (znz_zdigits ww_op)";
   pp "                    yy1)";
   pp "                ).";
   pp "     rewrite (spec_0 Hw).";
@@ -2612,11 +2272,11 @@ let _ =
   pp "    rewrite Zpos_xO.";
   pp "    assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." size;
   pp "    apply F5; auto with arith.";
-  pp "  intros x; case x; clear x; unfold shiftr, same_level.";
+  pp "  intros x; case x; clear x; unfold unsafe_shiftr, same_level.";
   for i = 0 to size do
     pp "    intros x y; case y; clear y.";
     for j = 0 to i - 1 do
-      pp "     intros y; unfold shiftr%i, Ndigits." i;
+      pp "     intros y; unfold unsafe_shiftr%i, Ndigits." i;
       pp "       repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j;
       pp "       apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i j i;
       pp "       rewrite (spec_zdigits w%i_spec)." i;
@@ -2628,25 +2288,25 @@ let _ =
       pp "       try (apply sym_equal; exact (spec_extend%in%i y))." j i;
 
     done;
-    pp "     intros y; unfold shiftr%i, Ndigits." i;
+    pp "     intros y; unfold unsafe_shiftr%i, Ndigits." i;
     pp "     repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i;
     pp "       apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i i i;
     for j = i + 1 to size do
-      pp "     intros y; unfold shiftr%i, Ndigits." j;
+      pp "     intros y; unfold unsafe_shiftr%i, Ndigits." j;
       pp "       repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j;
       pp "       apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." j j i;
       pp "       try (apply sym_equal; exact (spec_extend%in%i x))." i j;
     done;
     if i == size then
       begin
-        pp "     intros m y; unfold shiftrn, Ndigits.";
+        pp "     intros m y; unfold unsafe_shiftrn, Ndigits.";
         pp "       repeat rewrite spec_reduce_n; unfold to_Z; intros H1.";
         pp "       apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size;
         pp "       try (apply sym_equal; exact (spec_extend%in m x))." size;
       end
-    else 
+    else
       begin
-        pp "     intros m y; unfold shiftrn, Ndigits.";
+        pp "     intros m y; unfold unsafe_shiftrn, Ndigits.";
         pp "       repeat rewrite spec_reduce_n; unfold to_Z; intros H1.";
         pp "       apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." i;
         pp "       change ([Nn m (extend%i m (extend%i %i x))] = [N%i x])." size i (size - i - 1) i;
@@ -2654,7 +2314,7 @@ let _ =
       end
   done;
   pp "    intros n x y; case y; clear y;";
-  pp "     intros y; unfold shiftrn, Ndigits; try rewrite spec_reduce_n.";
+  pp "     intros y; unfold unsafe_shiftrn, Ndigits; try rewrite spec_reduce_n.";
   for i = 0 to size do
     pp "     try rewrite spec_reduce_%i; unfold to_Z; intros H1." i;
     pp "       apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith." i;
@@ -2684,52 +2344,23 @@ let _ =
   pp " Qed.";
   pr "";
 
-  pr " Definition safe_shiftr n x := ";
-  pr "   match compare n (Ndigits x) with";
-  pr "   |  Lt => shiftr n x ";
-  pr "   | _ => %s0 w_0" c;
-  pr "   end.";
-  pr "";
-
-
-  pr " Theorem spec_safe_shiftr: forall n x,";
-  pr "   [safe_shiftr n x] = [x] / 2 ^ [n].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros n x; unfold safe_shiftr;";
-  pp "    generalize (spec_compare n (Ndigits x)); case compare; intros H.";
-  pp " apply trans_equal with (1 := spec_0 w0_spec).";
-  pp " apply sym_equal; apply Zdiv_small; rewrite H.";
-  pp " rewrite spec_Ndigits; exact (spec_digits x).";
-  pp " rewrite <- spec_shiftr; auto with zarith.";
-  pp " apply trans_equal with (1 := spec_0 w0_spec).";
-  pp " apply sym_equal; apply Zdiv_small.";
-  pp " rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2.";
-  pp " split; auto.";
-  pp " apply Zlt_le_trans with (1 := H2).";
-  pp " apply Zpower_le_monotone; auto with zarith.";
-  pp " Qed.";
-  pr "";
-
-  pr "";
-
-  (* Shiftl *)
+  (* Unsafe_Shiftl *)
   for i = 0 to size do
-    pr " Definition shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0)." i i i
+    pr " Definition unsafe_shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0)." i i i
   done;
-  pr " Definition shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0).";
-  pr " Definition shiftl := Eval lazy beta delta [same_level] in";
-  pr "    same_level _ (fun n x => %s0 (shiftl0 n x))" c;
+  pr " Definition unsafe_shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0).";
+  pr " Definition unsafe_shiftl := Eval lazy beta delta [same_level] in";
+  pr "    same_level _ (fun n x => %s0 (unsafe_shiftl0 n x))" c;
   for i = 1 to size do
-    pr "           (fun n x => reduce_%i (shiftl%i n x))" i i;
+    pr "           (fun n x => reduce_%i (unsafe_shiftl%i n x))" i i;
   done;
-  pr "           (fun n p x => reduce_n n (shiftln n p x)).";
+  pr "           (fun n p x => reduce_n n (unsafe_shiftln n p x)).";
   pr "";
   pr "";
 
 
-  pr " Theorem spec_shiftl: forall n x,";
-  pr "  [n] <= [head0 x] -> [shiftl n x] = [x] * 2 ^ [n].";
+  pr " Theorem spec_unsafe_shiftl: forall n x,";
+  pr "  [n] <= [head0 x] -> [unsafe_shiftl n x] = [x] * 2 ^ [n].";
   pa " Admitted.";
   pp " Proof.";
   pp " assert (F0: forall x y, x - (x - y) = y).";
@@ -2748,7 +2379,7 @@ let _ =
   pp "    split; auto with zarith.";
   pp "    apply Zle_lt_trans with xx; auto with zarith.";
   pp "    apply Zpower2_lt_lin; auto with zarith.";
-  pp "  assert (F4: forall ww ww1 ww2 ";
+  pp "  assert (F4: forall ww ww1 ww2";
   pp "         (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)";
   pp "           xx yy xx1 yy1,";
   pp "  znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_head0 ww1_op xx) ->";
@@ -2788,7 +2419,7 @@ let _ =
   pp "     rewrite Zmod_small; auto with zarith.";
   pp "     intros HH; apply HH.";
   pp "     rewrite Hy; apply Zle_trans with (1:= Hl).";
-  pp "     rewrite <- (spec_zdigits Hw). ";
+  pp "     rewrite <- (spec_zdigits Hw).";
   pp "     apply Zle_trans with (2 := Hl1); auto.";
   pp "     rewrite  (spec_zdigits Hw1); auto with zarith.";
   pp "     split; auto with zarith .";
@@ -2826,11 +2457,11 @@ let _ =
   pp "    rewrite Zpos_xO.";
   pp "    assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." size;
   pp "    apply F5; auto with arith.";
-  pp "  intros x; case x; clear x; unfold shiftl, same_level.";
+  pp "  intros x; case x; clear x; unfold unsafe_shiftl, same_level.";
   for i = 0 to size do
     pp "    intros x y; case y; clear y.";
     for j = 0 to i - 1 do
-      pp "     intros y; unfold shiftl%i, head0." i;
+      pp "     intros y; unfold unsafe_shiftl%i, head0." i;
       pp "       repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j;
       pp "       apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i j i;
       pp "       rewrite (spec_zdigits w%i_spec)." i;
@@ -2841,25 +2472,25 @@ let _ =
       pp "       assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." j;
       pp "       try (apply sym_equal; exact (spec_extend%in%i y))." j i;
     done;
-    pp "     intros y; unfold shiftl%i, head0." i;
+    pp "     intros y; unfold unsafe_shiftl%i, head0." i;
     pp "     repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i;
     pp "       apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i i i;
     for j = i + 1 to size do
-      pp "     intros y; unfold shiftl%i, head0." j;
+      pp "     intros y; unfold unsafe_shiftl%i, head0." j;
       pp "       repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j;
       pp "       apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." j j i;
       pp "       try (apply sym_equal; exact (spec_extend%in%i x))." i j;
     done;
     if i == size then
       begin
-        pp "     intros m y; unfold shiftln, head0.";
+        pp "     intros m y; unfold unsafe_shiftln, head0.";
         pp "       repeat rewrite spec_reduce_n; unfold to_Z; intros H1.";
         pp "       apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size;
         pp "       try (apply sym_equal; exact (spec_extend%in m x))." size;
       end
-    else 
+    else
       begin
-        pp "     intros m y; unfold shiftln, head0.";
+        pp "     intros m y; unfold unsafe_shiftln, head0.";
         pp "       repeat rewrite spec_reduce_n; unfold to_Z; intros H1.";
         pp "       apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." i;
         pp "       change ([Nn m (extend%i m (extend%i %i x))] = [N%i x])." size i (size - i - 1) i;
@@ -2867,7 +2498,7 @@ let _ =
       end
   done;
   pp "    intros n x y; case y; clear y;";
-  pp "     intros y; unfold shiftln, head0; try rewrite spec_reduce_n.";
+  pp "     intros y; unfold unsafe_shiftln, head0; try rewrite spec_reduce_n.";
   for i = 0 to size do
     pp "     try rewrite spec_reduce_%i; unfold to_Z; intros H1." i;
     pp "       apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith." i;
@@ -2907,7 +2538,7 @@ let _ =
   pr " end.";
   pr "";
 
-  pr " Theorem spec_double_size_digits: ";
+  pr " Theorem spec_double_size_digits:";
   pr "   forall x, digits (double_size x) = xO (digits x).";
   pa " Admitted.";
   pp " Proof.";
@@ -2922,7 +2553,7 @@ let _ =
   pp " Proof.";
   pp " intros x; case x; unfold double_size; clear x.";
   for i = 0 to size do
-    pp "   intros x; unfold to_Z, make_op; ";
+    pp "   intros x; unfold to_Z, make_op;";
     pp "     rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto with zarith." (i + 1) i;
   done;
   pp "   intros n x; unfold to_Z;";
@@ -2934,7 +2565,7 @@ let _ =
   pr "";
 
 
-  pr " Theorem spec_double_size_head0: ";
+  pr " Theorem spec_double_size_head0:";
   pr "   forall x, 2 * [head0 x] <= [head0 (double_size x)].";
   pa " Admitted.";
   pp " Proof.";
@@ -2963,7 +2594,7 @@ let _ =
   pp "   apply Zmult_le_compat_l; auto with zarith.";
   pp "   rewrite Zpower_1_r; auto with zarith.";
   pp "   apply Zpower_le_monotone; auto with zarith.";
-  pp "   split; auto with zarith. ";
+  pp "   split; auto with zarith.";
   pp "   case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6.";
   pp "   absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith.";
   pp "   rewrite <- HH5; rewrite Zmult_1_r.";
@@ -2988,7 +2619,7 @@ let _ =
   pp " Qed.";
   pr "";
 
-  pr " Theorem spec_double_size_head0_pos: ";
+  pr " Theorem spec_double_size_head0_pos:";
   pr "   forall x, 0 < [head0 (double_size x)].";
   pa " Admitted.";
   pp " Proof.";
@@ -3015,114 +2646,6 @@ let _ =
   pp " Qed.";
   pr "";
 
-
-  (* Safe shiftl *)
-
-  pr " Definition safe_shiftl_aux_body cont n x :=";
-  pr "   match compare n (head0 x)  with";
-  pr "      Gt => cont n (double_size x)";
-  pr "   |  _ => shiftl n x";
-  pr "   end.";
-  pr "";
-
-  pr " Theorem spec_safe_shift_aux_body: forall n p x cont,";
-  pr "       2^ Zpos p  <=  [head0 x]  ->";
-  pr "      (forall x, 2 ^ (Zpos p + 1) <= [head0 x]->";
-  pr "         [cont n x] = [x] * 2 ^ [n]) ->";
-  pr "      [safe_shiftl_aux_body cont n x] = [x] * 2 ^ [n].";
-  pa " Admitted.";  
-  pp " Proof.";
-  pp " intros n p x cont H1 H2; unfold safe_shiftl_aux_body.";
-  pp " generalize (spec_compare n (head0 x)); case compare; intros H.";
-  pp "  apply spec_shiftl; auto with zarith.";
-  pp "  apply spec_shiftl; auto with zarith.";
-  pp " rewrite H2.";
-  pp " rewrite spec_double_size; auto.";
-  pp " rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith.";
-  pp " apply Zle_trans with (2 := spec_double_size_head0 x).";
-  pp " rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith.";
-  pp " Qed.";
-  pr "";
-
-  pr " Fixpoint safe_shiftl_aux p cont n x  {struct p} :=";
-  pr "   safe_shiftl_aux_body ";
-  pr "       (fun n x => match p with";
-  pr "        | xH => cont n x";
-  pr "        | xO p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x";
-  pr "        | xI p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x";
-  pr "        end) n x.";
-  pr "";
-
-  pr " Theorem spec_safe_shift_aux: forall p q n x cont,";
-  pr "    2 ^ (Zpos q) <= [head0 x] ->";
-  pr "      (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] ->";
-  pr "         [cont n x] = [x] * 2 ^ [n]) ->      ";
-  pr "      [safe_shiftl_aux p cont n x] = [x] * 2 ^ [n].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros p; elim p; unfold safe_shiftl_aux; fold safe_shiftl_aux; clear p.";
-  pp " intros p Hrec q n x cont H1 H2.";
-  pp " apply spec_safe_shift_aux_body with (q); auto.";
-  pp " intros x1 H3; apply Hrec with (q + 1)%spositive; auto." "%";
-  pp " intros x2 H4; apply Hrec with (p + q + 1)%spositive; auto." "%";
-  pp " rewrite <- Pplus_assoc.";
-  pp " rewrite Zpos_plus_distr; auto.";
-  pp " intros x3 H5; apply H2.";
-  pp " rewrite Zpos_xI.";
-  pp " replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1));";
-  pp "   auto.";
-  pp " repeat rewrite Zpos_plus_distr; ring.";
-  pp " intros p Hrec q n x cont H1 H2.";
-  pp " apply spec_safe_shift_aux_body with (q); auto.";
-  pp " intros x1 H3; apply Hrec with (q); auto.";
-  pp " apply Zle_trans with (2 := H3); auto with zarith.";
-  pp " apply Zpower_le_monotone; auto with zarith.";
-  pp " intros x2 H4; apply Hrec with (p + q)%spositive; auto." "%";
-  pp " intros x3 H5; apply H2.";
-  pp " rewrite (Zpos_xO p).";
-  pp " replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q));";
-  pp "   auto.";
-  pp " repeat rewrite Zpos_plus_distr; ring.";
-  pp " intros q n x cont H1 H2.";
-  pp " apply spec_safe_shift_aux_body with (q); auto.";
-  pp " rewrite Zplus_comm; auto.";
-  pp " Qed.";
-  pr "";
-
-
-  pr " Definition safe_shiftl n x :=";
-  pr "  safe_shiftl_aux_body";
-  pr "   (safe_shiftl_aux_body";
-  pr "    (safe_shiftl_aux (digits n) shiftl)) n x.";
-  pr "";
-
-  pr " Theorem spec_safe_shift: forall n x,";
-  pr "   [safe_shiftl n x] = [x] * 2 ^ [n].";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " intros n x; unfold safe_shiftl, safe_shiftl_aux_body.";
-  pp " generalize (spec_compare n (head0 x)); case compare; intros H.";
-  pp "  apply spec_shiftl; auto with zarith.";
-  pp "  apply spec_shiftl; auto with zarith.";
-  pp " rewrite <- (spec_double_size x).";
-  pp " generalize (spec_compare n (head0 (double_size x))); case compare; intros H1.";
-  pp "  apply spec_shiftl; auto with zarith.";
-  pp "  apply spec_shiftl; auto with zarith.";
-  pp " rewrite <- (spec_double_size (double_size x)).";
-  pp " apply spec_safe_shift_aux with 1%spositive." "%";
-  pp " apply Zle_trans with (2 := spec_double_size_head0 (double_size x)).";
-  pp " replace (2 ^ 1) with (2 * 1).";
-  pp " apply Zmult_le_compat_l; auto with zarith.";
-  pp " generalize (spec_double_size_head0_pos x); auto with zarith.";
-  pp " rewrite Zpower_1_r; ring.";
-  pp " intros x1 H2; apply spec_shiftl.";
-  pp " apply Zle_trans with (2 := H2).";
-  pp " apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith.";
-  pp " case (spec_digits n); auto with zarith.";
-  pp " apply Zpower_le_monotone; auto with zarith.";
-  pp " Qed.";
-  pr "";
-
   (* even *)
   pr " Definition is_even x :=";
   pr "  match x with";
@@ -3146,20 +2669,6 @@ let _ =
   pp " Qed.";
   pr "";
 
-  pr " Theorem spec_0: [zero] = 0.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " exact (spec_0 w0_spec).";
-  pp " Qed.";
-  pr "";
-
-  pr " Theorem spec_1: [one] = 1.";
-  pa " Admitted.";
-  pp " Proof.";
-  pp " exact (spec_1 w0_spec).";
-  pp " Qed.";
-  pr "";
-
   pr "End Make.";
   pr "";
 
diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v
index ae2cfd30..d42db97d 100644
--- a/theories/Numbers/Natural/BigN/Nbasic.v
+++ b/theories/Numbers/Natural/BigN/Nbasic.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: Nbasic.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith.
 Require Import BigNumPrelude.
@@ -21,7 +21,7 @@ Require Import DoubleCyclic.
 (* To compute the necessary height *)
 
 Fixpoint plength (p: positive) : positive :=
-  match p with 
+  match p with
     xH => xH
   | xO p1 => Psucc (plength p1)
   | xI p1 => Psucc (plength p1)
@@ -34,10 +34,10 @@ rewrite Zpower_exp; auto with zarith.
 rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
 intros p; elim p; simpl plength; auto.
 intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
-assert (tmp: (forall p, 2 * p = p + p)%Z); 
+assert (tmp: (forall p, 2 * p = p + p)%Z);
   try repeat rewrite tmp; auto with zarith.
 intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
-assert (tmp: (forall p, 2 * p = p + p)%Z); 
+assert (tmp: (forall p, 2 * p = p + p)%Z);
   try repeat rewrite tmp; auto with zarith.
 rewrite Zpower_1_r; auto with zarith.
 Qed.
@@ -73,7 +73,7 @@ case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith.
 intros q1 H2.
 replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q).
   2: pattern (Zpos p) at 2; rewrite H2; auto with zarith.
-generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; 
+generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2;
   case Zmod.
   intros HH _; rewrite HH; auto with zarith.
   intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism.
@@ -121,9 +121,9 @@ Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n.
 Defined.
 
 Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) :=
- match n return forall w:Type, zn2z w -> word w (S n) with 
+ match n return forall w:Type, zn2z w -> word w (S n) with
  | O => fun w x => x
- | S m => 
+ | S m =>
    let aux := extend m in
    fun w x => WW W0 (aux w x)
  end.
@@ -169,7 +169,7 @@ Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n :=
       | S n1 =>
           let v := fst (diff m1 n1) + n1 in
           let v1 := fst (diff m1 n1) + S n1 in
-          eq_ind v (fun n => v1 = S n) 
+          eq_ind v (fun n => v1 = S n)
             (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _))
             _ (diff_l _ _)
       end
@@ -182,7 +182,7 @@ Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n :=
       | 0 => refl_equal _
       | S _ => plusn0 _
       end
-  | S m => 
+  | S m =>
       match n return (snd (diff (S m) n) + S m = max (S m) n) with
       | 0 => refl_equal (snd (diff (S m) 0) + S m)
       | S n1 =>
@@ -253,9 +253,9 @@ Section ReduceRec.
     | WW xh xl =>
       match xh with
       | W0 => @reduce_n m xl
-      | _ => @c (S m) x 
+      | _ => @c (S m) x
       end
-    end	
+    end
   end.
 
 End ReduceRec.
@@ -276,14 +276,14 @@ Section CompareRec.
  Variable compare_m : wm -> w -> comparison.
 
  Fixpoint compare0_mn (n:nat) : word wm n -> comparison :=
-  match n return word wm n -> comparison with 
-  | O => compare0_m 
+  match n return word wm n -> comparison with
+  | O => compare0_m
   | S m => fun x =>
     match x with
     | W0 => Eq
-    | WW xh xl => 
+    | WW xh xl =>
       match compare0_mn m xh with
-      | Eq => compare0_mn m xl 
+      | Eq => compare0_mn m xl
       | r  => Lt
       end
     end
@@ -296,7 +296,7 @@ Section CompareRec.
  Variable spec_compare0_m: forall x,
     match compare0_m x with
       Eq => w_to_Z w_0 = wm_to_Z x
-    | Lt => w_to_Z w_0 < wm_to_Z x 
+    | Lt => w_to_Z w_0 < wm_to_Z x
     | Gt => w_to_Z w_0 > wm_to_Z x
     end.
  Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base.
@@ -341,14 +341,14 @@ Section CompareRec.
   Qed.
 
  Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
-  match n return word wm n -> w -> comparison with 
-  | O => compare_m 
-  | S m => fun x y => 
+  match n return word wm n -> w -> comparison with
+  | O => compare_m
+  | S m => fun x y =>
     match x with
     | W0 => compare w_0 y
-    | WW xh xl => 
+    | WW xh xl =>
       match compare0_mn m xh with
-      | Eq => compare_mn_1 m xl y 
+      | Eq => compare_mn_1 m xl y
       | r  => Gt
       end
     end
@@ -366,7 +366,7 @@ Section CompareRec.
    | Lt => wm_to_Z x < w_to_Z y
    | Gt => wm_to_Z x > w_to_Z y
    end.
- Variable wm_base_lt: forall x, 
+ Variable wm_base_lt: forall x,
    0 <= w_to_Z x < base (wm_base).
 
  Let double_wB_lt: forall n x,
@@ -385,7 +385,7 @@ Section CompareRec.
  unfold Zpower_pos; simpl; ring.
  Qed.
 
- 
+
  Lemma spec_compare_mn_1: forall n x y,
    match compare_mn_1 n x y with
      Eq => double_to_Z n x = w_to_Z y
@@ -434,7 +434,7 @@ Section AddS.
                 | C1 z => match incr hy with
                             C0 z1 => C0 (WW z1 z)
                           | C1 z1 => C1 (WW z1 z)
-                          end  
+                          end
                  end
    end.
 
@@ -458,12 +458,12 @@ End AddS.
 
  Fixpoint length_pos x :=
   match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end.
- 
+
  Theorem length_pos_lt: forall x y,
    (length_pos x < length_pos y)%nat -> Zpos x < Zpos y.
  Proof.
  intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac];
-   intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; 
+   intros y; case y; clear y; intros y1 H || intros H; simpl length_pos;
    try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1));
    try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1));
    try (inversion H; fail);
@@ -492,20 +492,20 @@ End AddS.
  Qed.
 
  Theorem make_zop: forall w (x: znz_op w),
-  znz_to_Z (mk_zn2z_op x) = 
-    fun z => match z with 
+  znz_to_Z (mk_zn2z_op x) =
+    fun z => match z with
                 W0 => 0
-             | WW xh xl => znz_to_Z x xh * base (znz_digits x) 
+             | WW xh xl => znz_to_Z x xh * base (znz_digits x)
                                 + znz_to_Z x xl
              end.
  intros ww x; auto.
  Qed.
 
  Theorem make_kzop: forall w (x: znz_op w),
-  znz_to_Z (mk_zn2z_op_karatsuba x) = 
-    fun z => match z with 
+  znz_to_Z (mk_zn2z_op_karatsuba x) =
+    fun z => match z with
                 W0 => 0
-             | WW xh xl => znz_to_Z x xh * base (znz_digits x) 
+             | WW xh xl => znz_to_Z x xh * base (znz_digits x)
                                 + znz_to_Z x xl
              end.
  intros ww x; auto.
diff --git a/theories/Numbers/Natural/Binary/NBinDefs.v b/theories/Numbers/Natural/Binary/NBinDefs.v
deleted file mode 100644
index fc2bd2df..00000000
--- a/theories/Numbers/Natural/Binary/NBinDefs.v
+++ /dev/null
@@ -1,267 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                      Evgeny Makarov, INRIA, 2007                     *)
-(************************************************************************)
-
-(*i $Id: NBinDefs.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
-
-Require Import BinPos.
-Require Export BinNat.
-Require Import NSub.
-
-Open Local Scope N_scope.
-
-(** Implementation of [NAxiomsSig] module type via [BinNat.N] *)
-
-Module NBinaryAxiomsMod <: NAxiomsSig.
-Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig.
-Module Export NZAxiomsMod <: NZAxiomsSig.
-
-Definition NZ := N.
-Definition NZeq := @eq N.
-Definition NZ0 := N0.
-Definition NZsucc := Nsucc.
-Definition NZpred := Npred.
-Definition NZadd := Nplus.
-Definition NZsub := Nminus.
-Definition NZmul := Nmult.
-
-Theorem NZeq_equiv : equiv N NZeq.
-Proof (eq_equiv N).
-
-Add Relation N NZeq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
-as NZeq_rel.
-
-Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd.
-Proof.
-congruence.
-Qed.
-
-Theorem NZinduction :
-  forall A : NZ -> Prop, predicate_wd NZeq A ->
-    A N0 -> (forall n, A n <-> A (NZsucc n)) -> forall n : NZ, A n.
-Proof.
-intros A A_wd A0 AS. apply Nrect. assumption. intros; now apply -> AS.
-Qed.
-
-Theorem NZpred_succ : forall n : NZ, NZpred (NZsucc n) = n.
-Proof.
-destruct n as [| p]; simpl. reflexivity.
-case_eq (Psucc p); try (intros q H; rewrite <- H; now rewrite Ppred_succ).
-intro H; false_hyp H Psucc_not_one.
-Qed.
-
-Theorem NZadd_0_l : forall n : NZ, N0 + n = n.
-Proof.
-reflexivity.
-Qed.
-
-Theorem NZadd_succ_l : forall n m : NZ, (NZsucc n) + m = NZsucc (n + m).
-Proof.
-destruct n; destruct m.
-simpl in |- *; reflexivity.
-unfold NZsucc, NZadd, Nsucc, Nplus. rewrite <- Pplus_one_succ_l; reflexivity.
-simpl in |- *; reflexivity.
-simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity.
-Qed.
-
-Theorem NZsub_0_r : forall n : NZ, n - N0 = n.
-Proof.
-now destruct n.
-Qed.
-
-Theorem NZsub_succ_r : forall n m : NZ, n - (NZsucc m) = NZpred (n - m).
-Proof.
-destruct n as [| p]; destruct m as [| q]; try reflexivity.
-now destruct p.
-simpl. rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec.
-now destruct (Pminus_mask p q) as [| r |]; [| destruct r |].
-Qed.
-
-Theorem NZmul_0_l : forall n : NZ, N0 * n = N0.
-Proof.
-destruct n; reflexivity.
-Qed.
-
-Theorem NZmul_succ_l : forall n m : NZ, (NZsucc n) * m = n * m + m.
-Proof.
-destruct n as [| n]; destruct m as [| m]; simpl; try reflexivity.
-now rewrite Pmult_Sn_m, Pplus_comm.
-Qed.
-
-End NZAxiomsMod.
-
-Definition NZlt := Nlt.
-Definition NZle := Nle.
-Definition NZmin := Nmin.
-Definition NZmax := Nmax.
-
-Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd.
-Proof.
-unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2.
-Qed.
-
-Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd.
-Proof.
-unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2.
-Qed.
-
-Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd.
-Proof.
-congruence.
-Qed.
-
-Theorem NZlt_eq_cases : forall n m : N, n <= m <-> n < m \/ n = m.
-Proof.
-intros n m. unfold Nle, Nlt. rewrite <- Ncompare_eq_correct.
-destruct (n ?= m); split; intro H1; (try discriminate); try (now left); try now right.
-now elim H1. destruct H1; discriminate.
-Qed.
-
-Theorem NZlt_irrefl : forall n : NZ, ~ n < n.
-Proof.
-intro n; unfold Nlt; now rewrite Ncompare_refl.
-Qed.
-
-Theorem NZlt_succ_r : forall n m : NZ, n < (NZsucc m) <-> n <= m.
-Proof.
-intros n m; unfold Nlt, Nle; destruct n as [| p]; destruct m as [| q]; simpl;
-split; intro H; try reflexivity; try discriminate.
-destruct p; simpl; intros; discriminate. elimtype False; now apply H.
-apply -> Pcompare_p_Sq in H. destruct H as [H | H].
-now rewrite H. now rewrite H, Pcompare_refl.
-apply <- Pcompare_p_Sq. case_eq ((p ?= q)%positive Eq); intro H1.
-right; now apply Pcompare_Eq_eq. now left. elimtype False; now apply H.
-Qed.
-
-Theorem NZmin_l : forall n m : N, n <= m -> NZmin n m = n.
-Proof.
-unfold NZmin, Nmin, Nle; intros n m H.
-destruct (n ?= m); try reflexivity. now elim H.
-Qed.
-
-Theorem NZmin_r : forall n m : N, m <= n -> NZmin n m = m.
-Proof.
-unfold NZmin, Nmin, Nle; intros n m H.
-case_eq (n ?= m); intro H1; try reflexivity.
-now apply -> Ncompare_eq_correct.
-rewrite <- Ncompare_antisym, H1 in H; elim H; auto.
-Qed.
-
-Theorem NZmax_l : forall n m : N, m <= n -> NZmax n m = n.
-Proof.
-unfold NZmax, Nmax, Nle; intros n m H.
-case_eq (n ?= m); intro H1; try reflexivity.
-symmetry; now apply -> Ncompare_eq_correct.
-rewrite <- Ncompare_antisym, H1 in H; elim H; auto.
-Qed.
-
-Theorem NZmax_r : forall n m : N, n <= m -> NZmax n m = m.
-Proof.
-unfold NZmax, Nmax, Nle; intros n m H.
-destruct (n ?= m); try reflexivity. now elim H.
-Qed.
-
-End NZOrdAxiomsMod.
-
-Definition recursion (A : Type) (a : A) (f : N -> A -> A) (n : N) :=
-  Nrect (fun _ => A) a f n.
-Implicit Arguments recursion [A].
-
-Theorem pred_0 : Npred N0 = N0.
-Proof.
-reflexivity.
-Qed.
-
-Theorem recursion_wd :
-forall (A : Type) (Aeq : relation A),
-  forall a a' : A, Aeq a a' ->
-    forall f f' : N -> A -> A, fun2_eq NZeq Aeq Aeq f f' ->
-      forall x x' : N, x = x' ->
-        Aeq (recursion a f x) (recursion a' f' x').
-Proof.
-unfold fun2_wd, NZeq, fun2_eq.
-intros A Aeq a a' Eaa' f f' Eff'.
-intro x; pattern x; apply Nrect.
-intros x' H; now rewrite <- H.
-clear x.
-intros x IH x' H; rewrite <- H.
-unfold recursion in *. do 2 rewrite Nrect_step.
-now apply Eff'; [| apply IH].
-Qed.
-
-Theorem recursion_0 :
-  forall (A : Type) (a : A) (f : N -> A -> A), recursion a f N0 = a.
-Proof.
-intros A a f; unfold recursion; now rewrite Nrect_base.
-Qed.
-
-Theorem recursion_succ :
-  forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A),
-    Aeq a a -> fun2_wd NZeq Aeq Aeq f ->
-      forall n : N, Aeq (recursion a f (Nsucc n)) (f n (recursion a f n)).
-Proof.
-unfold NZeq, recursion, fun2_wd; intros A Aeq a f EAaa f_wd n; pattern n; apply Nrect.
-rewrite Nrect_step; rewrite Nrect_base; now apply f_wd.
-clear n; intro n; do 2 rewrite Nrect_step; intro IH. apply f_wd; [reflexivity|].
-now rewrite Nrect_step.
-Qed.
-
-End NBinaryAxiomsMod.
-
-Module Export NBinarySubPropMod := NSubPropFunct NBinaryAxiomsMod.
-
-(* Some fun comparing the efficiency of the generic log defined
-by strong (course-of-value) recursion and the log defined by recursion
-on notation *)
-(* Time Eval compute in (log 100000). *) (* 98 sec *)
-
-(*
-Fixpoint binposlog (p : positive) : N :=
-match p with
-| xH => 0
-| xO p' => Nsucc (binposlog p')
-| xI p' => Nsucc (binposlog p')
-end.
-
-Definition binlog (n : N) : N :=
-match n with
-| 0 => 0
-| Npos p => binposlog p
-end.
-*)
-(* Eval compute in (binlog 1000000000000000000). *) (* Works very fast *)
-
diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v
index 2c99128d..e593f4a5 100644
--- a/theories/Numbers/Natural/Binary/NBinary.v
+++ b/theories/Numbers/Natural/Binary/NBinary.v
@@ -8,8 +8,175 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NBinary.v 10934 2008-05-15 21:58:20Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Export NBinDefs.
-Require Export NArithRing.
+Require Import BinPos.
+Require Export BinNat.
+Require Import NAxioms NProperties.
 
+Local Open Scope N_scope.
+
+(** * Implementation of [NAxiomsSig] module type via [BinNat.N] *)
+
+Module NBinaryAxiomsMod <: NAxiomsSig.
+
+(** Bi-directional induction. *)
+
+Theorem bi_induction :
+  forall A : N -> Prop, Proper (eq==>iff) A ->
+    A N0 -> (forall n, A n <-> A (Nsucc n)) -> forall n : N, A n.
+Proof.
+intros A A_wd A0 AS. apply Nrect. assumption. intros; now apply -> AS.
+Qed.
+
+(** Basic operations. *)
+
+Definition eq_equiv : Equivalence (@eq N) := eq_equivalence.
+Local Obligation Tactic := simpl_relation.
+Program Instance succ_wd : Proper (eq==>eq) Nsucc.
+Program Instance pred_wd : Proper (eq==>eq) Npred.
+Program Instance add_wd : Proper (eq==>eq==>eq) Nplus.
+Program Instance sub_wd : Proper (eq==>eq==>eq) Nminus.
+Program Instance mul_wd : Proper (eq==>eq==>eq) Nmult.
+
+Definition pred_succ := Npred_succ.
+Definition add_0_l := Nplus_0_l.
+Definition add_succ_l := Nplus_succ.
+Definition sub_0_r := Nminus_0_r.
+Definition sub_succ_r := Nminus_succ_r.
+Definition mul_0_l := Nmult_0_l.
+Definition mul_succ_l n m := eq_trans (Nmult_Sn_m n m) (Nplus_comm _ _).
+
+(** Order *)
+
+Program Instance lt_wd : Proper (eq==>eq==>iff) Nlt.
+
+Definition lt_eq_cases := Nle_lteq.
+Definition lt_irrefl := Nlt_irrefl.
+
+Theorem lt_succ_r : forall n m, n < (Nsucc m) <-> n <= m.
+Proof.
+intros n m; unfold Nlt, Nle; destruct n as [| p]; destruct m as [| q]; simpl;
+split; intro H; try reflexivity; try discriminate.
+destruct p; simpl; intros; discriminate. exfalso; now apply H.
+apply -> Pcompare_p_Sq in H. destruct H as [H | H].
+now rewrite H. now rewrite H, Pcompare_refl.
+apply <- Pcompare_p_Sq. case_eq ((p ?= q)%positive Eq); intro H1.
+right; now apply Pcompare_Eq_eq. now left. exfalso; now apply H.
+Qed.
+
+Theorem min_l : forall n m, n <= m -> Nmin n m = n.
+Proof.
+unfold Nmin, Nle; intros n m H.
+destruct (n ?= m); try reflexivity. now elim H.
+Qed.
+
+Theorem min_r : forall n m, m <= n -> Nmin n m = m.
+Proof.
+unfold Nmin, Nle; intros n m H.
+case_eq (n ?= m); intro H1; try reflexivity.
+now apply -> Ncompare_eq_correct.
+rewrite <- Ncompare_antisym, H1 in H; elim H; auto.
+Qed.
+
+Theorem max_l : forall n m, m <= n -> Nmax n m = n.
+Proof.
+unfold Nmax, Nle; intros n m H.
+case_eq (n ?= m); intro H1; try reflexivity.
+symmetry; now apply -> Ncompare_eq_correct.
+rewrite <- Ncompare_antisym, H1 in H; elim H; auto.
+Qed.
+
+Theorem max_r : forall n m : N, n <= m -> Nmax n m = m.
+Proof.
+unfold Nmax, Nle; intros n m H.
+destruct (n ?= m); try reflexivity. now elim H.
+Qed.
+
+(** Part specific to natural numbers, not integers. *)
+
+Theorem pred_0 : Npred 0 = 0.
+Proof.
+reflexivity.
+Qed.
+
+Definition recursion (A : Type) : A -> (N -> A -> A) -> N -> A :=
+  Nrect (fun _ => A).
+Implicit Arguments recursion [A].
+
+Instance recursion_wd A (Aeq : relation A) :
+ Proper (Aeq==>(eq==>Aeq==>Aeq)==>eq==>Aeq) (@recursion A).
+Proof.
+intros a a' Eaa' f f' Eff'.
+intro x; pattern x; apply Nrect.
+intros x' H; now rewrite <- H.
+clear x.
+intros x IH x' H; rewrite <- H.
+unfold recursion in *. do 2 rewrite Nrect_step.
+now apply Eff'; [| apply IH].
+Qed.
+
+Theorem recursion_0 :
+  forall (A : Type) (a : A) (f : N -> A -> A), recursion a f N0 = a.
+Proof.
+intros A a f; unfold recursion; now rewrite Nrect_base.
+Qed.
+
+Theorem recursion_succ :
+  forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A),
+    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
+      forall n : N, Aeq (recursion a f (Nsucc n)) (f n (recursion a f n)).
+Proof.
+unfold recursion; intros A Aeq a f EAaa f_wd n; pattern n; apply Nrect.
+rewrite Nrect_step; rewrite Nrect_base; now apply f_wd.
+clear n; intro n; do 2 rewrite Nrect_step; intro IH. apply f_wd; [reflexivity|].
+now rewrite Nrect_step.
+Qed.
+
+(** The instantiation of operations.
+    Placing them at the very end avoids having indirections in above lemmas. *)
+
+Definition t := N.
+Definition eq := @eq N.
+Definition zero := N0.
+Definition succ := Nsucc.
+Definition pred := Npred.
+Definition add := Nplus.
+Definition sub := Nminus.
+Definition mul := Nmult.
+Definition lt := Nlt.
+Definition le := Nle.
+Definition min := Nmin.
+Definition max := Nmax.
+
+End NBinaryAxiomsMod.
+
+Module Export NBinaryPropMod := NPropFunct NBinaryAxiomsMod.
+
+(*
+Require Import NDefOps.
+Module Import NBinaryDefOpsMod := NdefOpsPropFunct NBinaryAxiomsMod.
+
+(* Some fun comparing the efficiency of the generic log defined
+by strong (course-of-value) recursion and the log defined by recursion
+on notation *)
+
+Time Eval vm_compute in (log 500000). (* 11 sec *)
+
+Fixpoint binposlog (p : positive) : N :=
+match p with
+| xH => 0
+| xO p' => Nsucc (binposlog p')
+| xI p' => Nsucc (binposlog p')
+end.
+
+Definition binlog (n : N) : N :=
+match n with
+| 0 => 0
+| Npos p => binposlog p
+end.
+
+Time Eval vm_compute in (binlog 500000). (* 0 sec *)
+Time Eval vm_compute in (binlog 1000000000000000000000000000000). (* 0 sec *)
+
+*)
diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v
index 1c83da45..becbd243 100644
--- a/theories/Numbers/Natural/Peano/NPeano.v
+++ b/theories/Numbers/Natural/Peano/NPeano.v
@@ -8,134 +8,73 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NPeano.v 11040 2008-06-03 00:04:16Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import Arith.
-Require Import Min.
-Require Import Max.
-Require Import NSub.
+Require Import Arith MinMax NAxioms NProperties.
 
-Module NPeanoAxiomsMod <: NAxiomsSig.
-Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig.
-Module Export NZAxiomsMod <: NZAxiomsSig.
-
-Definition NZ := nat.
-Definition NZeq := (@eq nat).
-Definition NZ0 := 0.
-Definition NZsucc := S.
-Definition NZpred := pred.
-Definition NZadd := plus.
-Definition NZsub := minus.
-Definition NZmul := mult.
-
-Theorem NZeq_equiv : equiv nat NZeq.
-Proof (eq_equiv nat).
-
-Add Relation nat NZeq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
-as NZeq_rel.
-
-(* If we say "Add Relation nat (@eq nat)" instead of "Add Relation nat NZeq"
-then the theorem generated for succ_wd below is forall x, succ x = succ x,
-which does not match the axioms in NAxiomsSig *)
-
-Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd.
-Proof.
-congruence.
-Qed.
+(** * Implementation of [NAxiomsSig] by [nat] *)
 
-Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd.
-Proof.
-congruence.
-Qed.
+Module NPeanoAxiomsMod <: NAxiomsSig.
 
-Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd.
-Proof.
-congruence.
-Qed.
+(** Bi-directional induction. *)
 
-Theorem NZinduction :
-  forall A : nat -> Prop, predicate_wd (@eq nat) A ->
+Theorem bi_induction :
+  forall A : nat -> Prop, Proper (eq==>iff) A ->
     A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n.
 Proof.
 intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS.
 Qed.
 
-Theorem NZpred_succ : forall n : nat, pred (S n) = n.
+(** Basic operations. *)
+
+Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence.
+Local Obligation Tactic := simpl_relation.
+Program Instance succ_wd : Proper (eq==>eq) S.
+Program Instance pred_wd : Proper (eq==>eq) pred.
+Program Instance add_wd : Proper (eq==>eq==>eq) plus.
+Program Instance sub_wd : Proper (eq==>eq==>eq) minus.
+Program Instance mul_wd : Proper (eq==>eq==>eq) mult.
+
+Theorem pred_succ : forall n : nat, pred (S n) = n.
 Proof.
 reflexivity.
 Qed.
 
-Theorem NZadd_0_l : forall n : nat, 0 + n = n.
+Theorem add_0_l : forall n : nat, 0 + n = n.
 Proof.
 reflexivity.
 Qed.
 
-Theorem NZadd_succ_l : forall n m : nat, (S n) + m = S (n + m).
+Theorem add_succ_l : forall n m : nat, (S n) + m = S (n + m).
 Proof.
 reflexivity.
 Qed.
 
-Theorem NZsub_0_r : forall n : nat, n - 0 = n.
+Theorem sub_0_r : forall n : nat, n - 0 = n.
 Proof.
 intro n; now destruct n.
 Qed.
 
-Theorem NZsub_succ_r : forall n m : nat, n - (S m) = pred (n - m).
+Theorem sub_succ_r : forall n m : nat, n - (S m) = pred (n - m).
 Proof.
-intros n m; induction n m using nat_double_ind; simpl; auto. apply NZsub_0_r.
+intros n m; induction n m using nat_double_ind; simpl; auto. apply sub_0_r.
 Qed.
 
-Theorem NZmul_0_l : forall n : nat, 0 * n = 0.
+Theorem mul_0_l : forall n : nat, 0 * n = 0.
 Proof.
 reflexivity.
 Qed.
 
-Theorem NZmul_succ_l : forall n m : nat, S n * m = n * m + m.
+Theorem mul_succ_l : forall n m : nat, S n * m = n * m + m.
 Proof.
 intros n m; now rewrite plus_comm.
 Qed.
 
-End NZAxiomsMod.
+(** Order on natural numbers *)
 
-Definition NZlt := lt.
-Definition NZle := le.
-Definition NZmin := min.
-Definition NZmax := max.
+Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
 
-Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd.
-Proof.
-unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2.
-Qed.
-
-Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd.
-Proof.
-unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2.
-Qed.
-
-Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd.
-Proof.
-congruence.
-Qed.
-
-Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd.
-Proof.
-congruence.
-Qed.
-
-Theorem NZlt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m.
+Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m.
 Proof.
 intros n m; split.
 apply le_lt_or_eq.
@@ -143,59 +82,52 @@ intro H; destruct H as [H | H].
 now apply lt_le_weak. rewrite H; apply le_refl.
 Qed.
 
-Theorem NZlt_irrefl : forall n : nat, ~ (n < n).
+Theorem lt_irrefl : forall n : nat, ~ (n < n).
 Proof.
 exact lt_irrefl.
 Qed.
 
-Theorem NZlt_succ_r : forall n m : nat, n < S m <-> n <= m.
+Theorem lt_succ_r : forall n m : nat, n < S m <-> n <= m.
 Proof.
 intros n m; split; [apply lt_n_Sm_le | apply le_lt_n_Sm].
 Qed.
 
-Theorem NZmin_l : forall n m : nat, n <= m -> NZmin n m = n.
+Theorem min_l : forall n m : nat, n <= m -> min n m = n.
 Proof.
 exact min_l.
 Qed.
 
-Theorem NZmin_r : forall n m : nat, m <= n -> NZmin n m = m.
+Theorem min_r : forall n m : nat, m <= n -> min n m = m.
 Proof.
 exact min_r.
 Qed.
 
-Theorem NZmax_l : forall n m : nat, m <= n -> NZmax n m = n.
+Theorem max_l : forall n m : nat, m <= n -> max n m = n.
 Proof.
 exact max_l.
 Qed.
 
-Theorem NZmax_r : forall n m : nat, n <= m -> NZmax n m = m.
+Theorem max_r : forall n m : nat, n <= m -> max n m = m.
 Proof.
 exact max_r.
 Qed.
 
-End NZOrdAxiomsMod.
-
-Definition recursion : forall A : Type, A -> (nat -> A -> A) -> nat -> A :=
-  fun A : Type => nat_rect (fun _ => A).
-Implicit Arguments recursion [A].
-
-Theorem succ_neq_0 : forall n : nat, S n <> 0.
-Proof.
-intros; discriminate.
-Qed.
+(** Facts specific to natural numbers, not integers. *)
 
 Theorem pred_0 : pred 0 = 0.
 Proof.
 reflexivity.
 Qed.
 
-Theorem recursion_wd : forall (A : Type) (Aeq : relation A),
-  forall a a' : A, Aeq a a' ->
-    forall f f' : nat -> A -> A, fun2_eq (@eq nat) Aeq Aeq f f' ->
-      forall n n' : nat, n = n' ->
-        Aeq (recursion a f n) (recursion a' f' n').
+Definition recursion (A : Type) : A -> (nat -> A -> A) -> nat -> A :=
+  nat_rect (fun _ => A).
+Implicit Arguments recursion [A].
+
+Instance recursion_wd (A : Type) (Aeq : relation A) :
+ Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).
 Proof.
-unfold fun2_eq; induction n; intros n' Enn'; rewrite <- Enn' in *; simpl; auto.
+intros a a' Ha f f' Hf n n' Hn. subst n'.
+induction n; simpl; auto. apply Hf; auto.
 Qed.
 
 Theorem recursion_0 :
@@ -206,15 +138,100 @@ Qed.
 
 Theorem recursion_succ :
   forall (A : Type) (Aeq : relation A) (a : A) (f : nat -> A -> A),
-    Aeq a a -> fun2_wd (@eq nat) Aeq Aeq f ->
+    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
       forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)).
 Proof.
-induction n; simpl; auto.
+unfold Proper, respectful in *; induction n; simpl; auto.
 Qed.
 
-End NPeanoAxiomsMod.
+(** The instantiation of operations.
+    Placing them at the very end avoids having indirections in above lemmas. *)
 
-(* Now we apply the largest property functor *)
+Definition t := nat.
+Definition eq := @eq nat.
+Definition zero := 0.
+Definition succ := S.
+Definition pred := pred.
+Definition add := plus.
+Definition sub := minus.
+Definition mul := mult.
+Definition lt := lt.
+Definition le := le.
+Definition min := min.
+Definition max := max.
 
-Module Export NPeanoSubPropMod := NSubPropFunct NPeanoAxiomsMod.
+End NPeanoAxiomsMod.
 
+(** Now we apply the largest property functor *)
+
+Module Export NPeanoPropMod := NPropFunct NPeanoAxiomsMod.
+
+
+
+(** Euclidean Division *)
+
+Definition divF div x y := if leb y x then S (div (x-y) y) else 0.
+Definition modF mod x y := if leb y x then mod (x-y) y else x.
+Definition initF (_ _ : nat) := 0.
+
+Fixpoint loop {A} (F:A->A)(i:A) (n:nat) : A :=
+ match n with
+  | 0 => i
+  | S n => F (loop F i n)
+ end.
+
+Definition div x y := loop divF initF x x y.
+Definition modulo x y := loop modF initF x x y.
+Infix "/" := div : nat_scope.
+Infix "mod" := modulo (at level 40, no associativity) : nat_scope.
+
+Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y.
+Proof.
+ cut (forall n x y, y<>0 -> x<=n ->
+       x = y*(loop divF initF n x y) + (loop modF initF n x y)).
+ intros H x y Hy. apply H; auto.
+ induction n.
+ simpl; unfold initF; simpl. intros. nzsimpl. auto with arith.
+ simpl; unfold divF at 1, modF at 1.
+ intros.
+ destruct (leb y x) as [ ]_eqn:L;
+  [apply leb_complete in L | apply leb_complete_conv in L].
+ rewrite mul_succ_r, <- add_assoc, (add_comm y), add_assoc.
+ rewrite <- IHn; auto.
+ symmetry; apply sub_add; auto.
+ rewrite <- NPeanoAxiomsMod.lt_succ_r.
+ apply lt_le_trans with x; auto.
+ apply lt_minus; auto. rewrite <- neq_0_lt_0; auto.
+ nzsimpl; auto.
+Qed.
+
+Lemma mod_upper_bound : forall x y, y<>0 -> x mod y < y.
+Proof.
+ cut (forall n x y, y<>0 -> x<=n -> loop modF initF n x y < y).
+ intros H x y Hy. apply H; auto.
+ induction n.
+ simpl; unfold initF. intros. rewrite <- neq_0_lt_0; auto.
+ simpl; unfold modF at 1.
+ intros.
+ destruct (leb y x) as [ ]_eqn:L;
+  [apply leb_complete in L | apply leb_complete_conv in L]; auto.
+ apply IHn; auto.
+ rewrite <- NPeanoAxiomsMod.lt_succ_r.
+ apply lt_le_trans with x; auto.
+ apply lt_minus; auto. rewrite <- neq_0_lt_0; auto.
+Qed.
+
+Require Import NDiv.
+
+Module NDivMod <: NDivSig.
+ Include NPeanoAxiomsMod.
+ Definition div := div.
+ Definition modulo := modulo.
+ Definition div_mod := div_mod.
+ Definition mod_upper_bound := mod_upper_bound.
+ Local Obligation Tactic := simpl_relation.
+ Program Instance div_wd : Proper (eq==>eq==>eq) div.
+ Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
+End NDivMod.
+
+Module Export NDivPropMod := NDivPropFunct NDivMod NPeanoPropMod.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v
index 0275d1e1..85639aa6 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSig.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSig.v
@@ -8,7 +8,7 @@
 (*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
 (************************************************************************)
 
-(*i $Id: NSig.v 11027 2008-06-01 13:28:59Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith Znumtheory.
 
@@ -25,91 +25,76 @@ Module Type NType.
  Parameter t : Type.
 
  Parameter to_Z : t -> Z.
- Notation "[ x ]" := (to_Z x).
+ Local Notation "[ x ]" := (to_Z x).
  Parameter spec_pos: forall x, 0 <= [x].
 
  Parameter of_N : N -> t.
  Parameter spec_of_N: forall x, to_Z (of_N x) = Z_of_N x.
  Definition to_N n := Zabs_N (to_Z n).
 
- Definition eq n m := ([n] = [m]).
-
- Parameter zero : t.
- Parameter one : t.
-
- Parameter spec_0: [zero] = 0.
- Parameter spec_1: [one] = 1.
+ Definition eq n m := [n] = [m].
+ Definition lt n m := [n] < [m].
+ Definition le n m := [n] <= [m].
 
  Parameter compare : t -> t -> comparison.
-
- Parameter spec_compare: forall x y,
-   match compare x y with
-     | Eq => [x] = [y]
-     | Lt => [x] < [y]
-     | Gt => [x] > [y]
-   end.
-
- Definition lt n m := compare n m = Lt.
- Definition le n m := compare n m <> Gt.
- Definition min n m := match compare n m with Gt => m | _ => n end.
- Definition max n m := match compare n m with Lt => m | _ => n end.
-
  Parameter eq_bool : t -> t -> bool.
-
- Parameter spec_eq_bool: forall x y,
-    if eq_bool x y then [x] = [y] else [x] <> [y].
- 
+ Parameter max : t -> t -> t.
+ Parameter min : t -> t -> t.
+ Parameter zero : t.
+ Parameter one : t.
  Parameter succ : t -> t.
-
- Parameter spec_succ: forall n, [succ n] = [n] + 1.
-
- Parameter add  : t -> t -> t.
-
- Parameter spec_add: forall x y, [add x y] = [x] + [y].
-
  Parameter pred : t -> t.
-
- Parameter spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1.
- Parameter spec_pred0: forall x, [x] = 0 -> [pred x] = 0.
-
+ Parameter add  : t -> t -> t.
  Parameter sub : t -> t -> t.
-
- Parameter spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y].
- Parameter spec_sub0: forall x y, [x] < [y]-> [sub x y] = 0.
-
  Parameter mul : t -> t -> t.
-
- Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
-
  Parameter square : t -> t.
-
- Parameter spec_square: forall x, [square x] = [x] *  [x].
-
  Parameter power_pos : t -> positive -> t.
-
- Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
-
+ Parameter power : t -> N -> t.
  Parameter sqrt : t -> t.
-
- Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.
-
  Parameter div_eucl : t -> t -> t * t.
-
- Parameter spec_div_eucl: forall x y,
-      0 < [y] ->
-      let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
- 
  Parameter div : t -> t -> t.
-
- Parameter spec_div: forall x y, 0 < [y] -> [div x y] = [x] / [y].
-
  Parameter modulo : t -> t -> t.
-
- Parameter spec_modulo:
-   forall x y, 0 < [y] -> [modulo x y] = [x] mod [y].
-
  Parameter gcd : t -> t -> t.
-
- Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b).
+ Parameter shiftr : t -> t -> t.
+ Parameter shiftl : t -> t -> t.
+ Parameter is_even : t -> bool.
+
+ Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y].
+ Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y].
+ Parameter spec_max : forall x y, [max x y] = Zmax [x] [y].
+ Parameter spec_min : forall x y, [min x y] = Zmin [x] [y].
+ Parameter spec_0: [zero] = 0.
+ Parameter spec_1: [one] = 1.
+ Parameter spec_succ: forall n, [succ n] = [n] + 1.
+ Parameter spec_add: forall x y, [add x y] = [x] + [y].
+ Parameter spec_pred: forall x, [pred x] = Zmax 0 ([x] - 1).
+ Parameter spec_sub: forall x y, [sub x y] = Zmax 0 ([x] - [y]).
+ Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
+ Parameter spec_square: forall x, [square x] = [x] *  [x].
+ Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
+ Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n.
+ Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.
+ Parameter spec_div_eucl: forall x y,
+  let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
+ Parameter spec_div: forall x y, [div x y] = [x] / [y].
+ Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
+ Parameter spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].
+ Parameter spec_shiftr: forall p x, [shiftr p x] = [x] / 2^[p].
+ Parameter spec_shiftl: forall p x, [shiftl p x] = [x] * 2^[p].
+ Parameter spec_is_even: forall x,
+  if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1.
 
 End NType.
+
+Module Type NType_Notation (Import N:NType).
+ Notation "[ x ]" := (to_Z x).
+ Infix "==" := eq (at level 70).
+ Notation "0" := zero.
+ Infix "+" := add.
+ Infix "-" := sub.
+ Infix "*" := mul.
+ Infix "<=" := le.
+ Infix "<" := lt.
+End NType_Notation.
+
+Module Type NType' := NType <+ NType_Notation.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
index 84836268..ab749bd1 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
@@ -6,101 +6,47 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: NSigNAxioms.v 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
-Require Import ZArith.
-Require Import Nnat.
-Require Import NAxioms.
-Require Import NSig.
+Require Import ZArith Nnat NAxioms NDiv NSig.
 
 (** * The interface [NSig.NType] implies the interface [NAxiomsSig] *)
 
-Module NSig_NAxioms (N:NType) <: NAxiomsSig.
-
-Delimit Scope IntScope with Int.
-Bind Scope IntScope with N.t.
-Open Local Scope IntScope.
-Notation "[ x ]" := (N.to_Z x) : IntScope.
-Infix "=="  := N.eq (at level 70) : IntScope.
-Notation "0" := N.zero : IntScope.
-Infix "+" := N.add : IntScope.
-Infix "-" := N.sub : IntScope.
-Infix "*" := N.mul : IntScope.
-
-Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig.
-Module Export NZAxiomsMod <: NZAxiomsSig.
-
-Definition NZ := N.t.
-Definition NZeq := N.eq.
-Definition NZ0 := N.zero.
-Definition NZsucc := N.succ.
-Definition NZpred := N.pred.
-Definition NZadd := N.add.
-Definition NZsub := N.sub.
-Definition NZmul := N.mul.
-
-Theorem NZeq_equiv : equiv N.t N.eq.
-Proof.
-repeat split; repeat red; intros; auto; congruence.
-Qed.
+Module NTypeIsNAxioms (Import N : NType').
 
-Add Relation N.t N.eq
- reflexivity proved by (proj1 NZeq_equiv)
- symmetry proved by (proj2 (proj2 NZeq_equiv))
- transitivity proved by (proj1 (proj2 NZeq_equiv))
- as NZeq_rel.
+Hint Rewrite
+ spec_0 spec_succ spec_add spec_mul spec_pred spec_sub
+ spec_div spec_modulo spec_gcd spec_compare spec_eq_bool
+ spec_max spec_min spec_power_pos spec_power
+ : nsimpl.
+Ltac nsimpl := autorewrite with nsimpl.
+Ltac ncongruence := unfold eq; repeat red; intros; nsimpl; congruence.
+Ltac zify := unfold eq, lt, le in *; nsimpl.
 
-Add Morphism NZsucc with signature N.eq ==> N.eq as NZsucc_wd.
-Proof.
-unfold N.eq; intros; rewrite 2 N.spec_succ; f_equal; auto.
-Qed.
+Local Obligation Tactic := ncongruence.
 
-Add Morphism NZpred with signature N.eq ==> N.eq as NZpred_wd.
-Proof.
-unfold N.eq; intros.
-generalize (N.spec_pos y) (N.spec_pos x) (N.spec_eq_bool x 0).
-destruct N.eq_bool; rewrite N.spec_0; intros.
-rewrite 2 N.spec_pred0; congruence.
-rewrite 2 N.spec_pred; f_equal; auto; try omega.
-Qed.
+Instance eq_equiv : Equivalence eq.
+Proof. unfold eq. firstorder. Qed.
 
-Add Morphism NZadd with signature N.eq ==> N.eq ==> N.eq as NZadd_wd.
-Proof.
-unfold N.eq; intros; rewrite 2 N.spec_add; f_equal; auto.
-Qed.
+Program Instance succ_wd : Proper (eq==>eq) succ.
+Program Instance pred_wd : Proper (eq==>eq) pred.
+Program Instance add_wd : Proper (eq==>eq==>eq) add.
+Program Instance sub_wd : Proper (eq==>eq==>eq) sub.
+Program Instance mul_wd : Proper (eq==>eq==>eq) mul.
 
-Add Morphism NZsub with signature N.eq ==> N.eq ==> N.eq as NZsub_wd.
+Theorem pred_succ : forall n, pred (succ n) == n.
 Proof.
-unfold N.eq; intros x x' Hx y y' Hy.
-destruct (Z_lt_le_dec [x] [y]).
-rewrite 2 N.spec_sub0; f_equal; congruence.
-rewrite 2 N.spec_sub; f_equal; congruence.
+intros. zify. generalize (spec_pos n); omega with *.
 Qed.
 
-Add Morphism NZmul with signature N.eq ==> N.eq ==> N.eq as NZmul_wd.
-Proof.
-unfold N.eq; intros; rewrite 2 N.spec_mul; f_equal; auto.
-Qed.
-
-Theorem NZpred_succ : forall n, N.pred (N.succ n) == n.
-Proof.
-unfold N.eq; intros.
-rewrite N.spec_pred; rewrite N.spec_succ.
-omega.
-generalize (N.spec_pos n); omega.
-Qed.
-
-Definition N_of_Z z := N.of_N (Zabs_N z).
+Definition N_of_Z z := of_N (Zabs_N z).
 
 Section Induction.
 
 Variable A : N.t -> Prop.
-Hypothesis A_wd : predicate_wd N.eq A.
+Hypothesis A_wd : Proper (eq==>iff) A.
 Hypothesis A0 : A 0.
-Hypothesis AS : forall n, A n <-> A (N.succ n). 
-
-Add Morphism A with signature N.eq ==> iff as A_morph.
-Proof. apply A_wd. Qed.
+Hypothesis AS : forall n, A n <-> A (succ n).
 
 Let B (z : Z) := A (N_of_Z z).
 
@@ -108,17 +54,17 @@ Lemma B0 : B 0.
 Proof.
 unfold B, N_of_Z; simpl.
 rewrite <- (A_wd 0); auto.
-red; rewrite N.spec_0, N.spec_of_N; auto.
+red; rewrite spec_0, spec_of_N; auto.
 Qed.
 
 Lemma BS : forall z : Z, (0 <= z)%Z -> B z -> B (z + 1).
 Proof.
 intros z H1 H2.
 unfold B in *. apply -> AS in H2.
-setoid_replace (N_of_Z (z + 1)) with (N.succ (N_of_Z z)); auto.
-unfold N.eq. rewrite N.spec_succ.
+setoid_replace (N_of_Z (z + 1)) with (succ (N_of_Z z)); auto.
+unfold eq. rewrite spec_succ.
 unfold N_of_Z.
-rewrite 2 N.spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith.
+rewrite 2 spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith.
 Qed.
 
 Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z.
@@ -126,193 +72,144 @@ Proof.
 exact (natlike_ind B B0 BS).
 Qed.
 
-Theorem NZinduction : forall n, A n.
+Theorem bi_induction : forall n, A n.
 Proof.
-intro n. setoid_replace n with (N_of_Z (N.to_Z n)).
-apply B_holds. apply N.spec_pos.
+intro n. setoid_replace n with (N_of_Z (to_Z n)).
+apply B_holds. apply spec_pos.
 red; unfold N_of_Z.
-rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto.
-apply N.spec_pos.
+rewrite spec_of_N, Z_of_N_abs, Zabs_eq; auto.
+apply spec_pos.
 Qed.
 
 End Induction.
 
-Theorem NZadd_0_l : forall n, 0 + n == n.
+Theorem add_0_l : forall n, 0 + n == n.
 Proof.
-intros; red; rewrite N.spec_add, N.spec_0; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZadd_succ_l : forall n m, (N.succ n) + m == N.succ (n + m).
+Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m).
 Proof.
-intros; red; rewrite N.spec_add, 2 N.spec_succ, N.spec_add; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZsub_0_r : forall n, n - 0 == n.
+Theorem sub_0_r : forall n, n - 0 == n.
 Proof.
-intros; red; rewrite N.spec_sub; rewrite N.spec_0; auto with zarith.
-apply N.spec_pos.
+intros. zify. generalize (spec_pos n); omega with *.
 Qed.
 
-Theorem NZsub_succ_r : forall n m, n - (N.succ m) == N.pred (n - m).
+Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
 Proof.
-intros; red.
-destruct (Z_lt_le_dec [n] [N.succ m]) as [H|H].
-rewrite N.spec_sub0; auto.
-rewrite N.spec_succ in H.
-rewrite N.spec_pred0; auto.
-destruct (Z_eq_dec [n] [m]).
-rewrite N.spec_sub; auto with zarith.
-rewrite N.spec_sub0; auto with zarith.
-
-rewrite N.spec_sub, N.spec_succ in *; auto.
-rewrite N.spec_pred, N.spec_sub; auto with zarith.
-rewrite N.spec_sub; auto with zarith.
+intros. zify. omega with *.
 Qed.
 
-Theorem NZmul_0_l : forall n, 0 * n == 0.
+Theorem mul_0_l : forall n, 0 * n == 0.
 Proof.
-intros; red.
-rewrite N.spec_mul, N.spec_0; auto with zarith.
+intros. zify. auto with zarith.
 Qed.
 
-Theorem NZmul_succ_l : forall n m, (N.succ n) * m == n * m + m.
+Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m.
 Proof.
-intros; red.
-rewrite N.spec_add, 2 N.spec_mul, N.spec_succ; ring.
+intros. zify. ring.
 Qed.
 
-End NZAxiomsMod.
-
-Definition NZlt := N.lt.
-Definition NZle := N.le.
-Definition NZmin := N.min.
-Definition NZmax := N.max.
+(** Order *)
 
-Infix "<=" := N.le : IntScope.
-Infix "<" := N.lt : IntScope.
-
-Lemma spec_compare_alt : forall x y, N.compare x y = ([x] ?= [y])%Z.
+Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
 Proof.
- intros; generalize (N.spec_compare x y).
- destruct (N.compare x y); auto.
- intros H; rewrite H; symmetry; apply Zcompare_refl.
+ intros. zify. destruct (Zcompare_spec [x] [y]); auto.
 Qed.
 
-Lemma spec_lt : forall x y, (x<y) <-> ([x]<[y])%Z.
-Proof.
- intros; unfold N.lt, Zlt; rewrite spec_compare_alt; intuition.
-Qed.
+Definition eqb := eq_bool.
 
-Lemma spec_le : forall x y, (x<=y) <-> ([x]<=[y])%Z.
+Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
 Proof.
- intros; unfold N.le, Zle; rewrite spec_compare_alt; intuition.
+ intros. zify. symmetry. apply Zeq_is_eq_bool.
 Qed.
 
-Lemma spec_min : forall x y, [N.min x y] = Zmin [x] [y].
+Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
 Proof.
- intros; unfold N.min, Zmin.
- rewrite spec_compare_alt; destruct Zcompare; auto.
+intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition.
 Qed.
 
-Lemma spec_max : forall x y, [N.max x y] = Zmax [x] [y].
+Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
 Proof.
- intros; unfold N.max, Zmax.
- rewrite spec_compare_alt; destruct Zcompare; auto.
-Qed.
-
-Add Morphism N.compare with signature N.eq ==> N.eq ==> (@eq comparison) as compare_wd.
-Proof. 
-intros x x' Hx y y' Hy.
-rewrite 2 spec_compare_alt. unfold N.eq in *. rewrite Hx, Hy; intuition.
+intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
 Qed.
 
-Add Morphism N.lt with signature N.eq ==> N.eq ==> iff as NZlt_wd.
+Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
 Proof.
-intros x x' Hx y y' Hy; unfold N.lt; rewrite Hx, Hy; intuition.
+intros. zify. omega.
 Qed.
 
-Add Morphism N.le with signature N.eq ==> N.eq ==> iff as NZle_wd.
+Theorem lt_irrefl : forall n, ~ n < n.
 Proof.
-intros x x' Hx y y' Hy; unfold N.le; rewrite Hx, Hy; intuition.
+intros. zify. omega.
 Qed.
 
-Add Morphism N.min with signature N.eq ==> N.eq ==> N.eq as NZmin_wd.
+Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
 Proof.
-intros; red; rewrite 2 spec_min; congruence.
+intros. zify. omega.
 Qed.
 
-Add Morphism N.max with signature N.eq ==> N.eq ==> N.eq as NZmax_wd.
+Theorem min_l : forall n m, n <= m -> min n m == n.
 Proof.
-intros; red; rewrite 2 spec_max; congruence.
+intros n m. zify. omega with *.
 Qed.
 
-Theorem NZlt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
+Theorem min_r : forall n m, m <= n -> min n m == m.
 Proof.
-intros.
-unfold N.eq; rewrite spec_lt, spec_le; omega.
+intros n m. zify. omega with *.
 Qed.
 
-Theorem NZlt_irrefl : forall n, ~ n < n.
+Theorem max_l : forall n m, m <= n -> max n m == n.
 Proof.
-intros; rewrite spec_lt; auto with zarith.
+intros n m. zify. omega with *.
 Qed.
 
-Theorem NZlt_succ_r : forall n m, n < (N.succ m) <-> n <= m.
+Theorem max_r : forall n m, n <= m -> max n m == m.
 Proof.
-intros; rewrite spec_lt, spec_le, N.spec_succ; omega.
+intros n m. zify. omega with *.
 Qed.
 
-Theorem NZmin_l : forall n m, n <= m -> N.min n m == n.
-Proof.
-intros n m; unfold N.eq; rewrite spec_le, spec_min.
-generalize (Zmin_spec [n] [m]); omega.
-Qed.
+(** Properties specific to natural numbers, not integers. *)
 
-Theorem NZmin_r : forall n m, m <= n -> N.min n m == m.
+Theorem pred_0 : pred 0 == 0.
 Proof.
-intros n m; unfold N.eq; rewrite spec_le, spec_min.
-generalize (Zmin_spec [n] [m]); omega.
+zify. auto.
 Qed.
 
-Theorem NZmax_l : forall n m, m <= n -> N.max n m == n.
-Proof.
-intros n m; unfold N.eq; rewrite spec_le, spec_max.
-generalize (Zmax_spec [n] [m]); omega.
-Qed.
+Program Instance div_wd : Proper (eq==>eq==>eq) div.
+Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
 
-Theorem NZmax_r : forall n m, n <= m -> N.max n m == m.
+Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
 Proof.
-intros n m; unfold N.eq; rewrite spec_le, spec_max.
-generalize (Zmax_spec [n] [m]); omega.
+intros a b. zify. intros. apply Z_div_mod_eq_full; auto.
 Qed.
 
-End NZOrdAxiomsMod.
-
-Theorem pred_0 : N.pred 0 == 0.
+Theorem mod_upper_bound : forall a b, ~b==0 -> modulo a b < b.
 Proof.
-red; rewrite N.spec_pred0; rewrite N.spec_0; auto.
+intros a b. zify. intros.
+destruct (Z_mod_lt [a] [b]); auto.
+generalize (spec_pos b); auto with zarith.
 Qed.
 
 Definition recursion (A : Type) (a : A) (f : N.t -> A -> A) (n : N.t) :=
   Nrect (fun _ => A) a (fun n a => f (N.of_N n) a) (N.to_N n).
 Implicit Arguments recursion [A].
 
-Theorem recursion_wd :
-forall (A : Type) (Aeq : relation A),
-  forall a a' : A, Aeq a a' ->
-    forall f f' : N.t -> A -> A, fun2_eq N.eq Aeq Aeq f f' ->
-      forall x x' : N.t, x == x' ->
-        Aeq (recursion a f x) (recursion a' f' x').
+Instance recursion_wd (A : Type) (Aeq : relation A) :
+ Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).
 Proof.
-unfold fun2_wd, N.eq, fun2_eq.
-intros A Aeq a a' Eaa' f f' Eff' x x' Exx'.
+unfold eq.
+intros a a' Eaa' f f' Eff' x x' Exx'.
 unfold recursion.
 unfold N.to_N.
 rewrite <- Exx'; clear x' Exx'.
 replace (Zabs_N [x]) with (N_of_nat (Zabs_nat [x])).
 induction (Zabs_nat [x]).
 simpl; auto.
-rewrite N_of_S, 2 Nrect_step; auto.
+rewrite N_of_S, 2 Nrect_step; auto. apply Eff'; auto.
 destruct [x]; simpl; auto.
 change (nat_of_P p) with (nat_of_N (Npos p)); apply N_of_nat_of_N.
 change (nat_of_P p) with (nat_of_N (Npos p)); apply N_of_nat_of_N.
@@ -326,11 +223,11 @@ Qed.
 
 Theorem recursion_succ :
   forall (A : Type) (Aeq : relation A) (a : A) (f : N.t -> A -> A),
-    Aeq a a -> fun2_wd N.eq Aeq Aeq f ->
-      forall n, Aeq (recursion a f (N.succ n)) (f n (recursion a f n)).
+    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
+      forall n, Aeq (recursion a f (succ n)) (f n (recursion a f n)).
 Proof.
-unfold N.eq, recursion, fun2_wd; intros A Aeq a f EAaa f_wd n.
-replace (N.to_N (N.succ n)) with (Nsucc (N.to_N n)).
+unfold N.eq, recursion; intros A Aeq a f EAaa f_wd n.
+replace (N.to_N (succ n)) with (Nsucc (N.to_N n)).
 rewrite Nrect_step.
 apply f_wd; auto.
 unfold N.to_N.
@@ -340,7 +237,6 @@ rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto.
 fold (recursion a f n).
 apply recursion_wd; auto.
 red; auto.
-red; auto.
 unfold N.to_N.
 
 rewrite N.spec_succ.
@@ -349,8 +245,12 @@ apply Z_of_N_eq_rev.
 rewrite Z_of_N_succ.
 rewrite 2 Z_of_N_abs.
 rewrite 2 Zabs_eq; auto.
-generalize (N.spec_pos n); auto with zarith.
-apply N.spec_pos; auto.
+generalize (spec_pos n); auto with zarith.
+apply spec_pos; auto.
 Qed.
 
-End NSig_NAxioms.
+End NTypeIsNAxioms.
+
+Module NType_NAxioms (N : NType)
+ <: NAxiomsSig <: NDivSig <: HasCompare N <: HasEqBool N <: HasMinMax N
+ := N <+ NTypeIsNAxioms.
diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v
index 95d8b366..468b0613 100644
--- a/theories/Numbers/NumPrelude.v
+++ b/theories/Numbers/NumPrelude.v
@@ -8,9 +8,9 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-(*i $Id: NumPrelude.v 11674 2008-12-12 19:48:40Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Export Setoid.
+Require Export Setoid Morphisms.
 
 Set Implicit Arguments.
 (*
@@ -91,85 +91,31 @@ end.
 
 Tactic Notation "stepr" constr(t2') "in" hyp(H) "by" tactic(r) := stepr t2' in H; [| r].
 
-(** Extentional properties of predicates, relations and functions *)
+(** Predicates, relations, functions *)
 
 Definition predicate (A : Type) := A -> Prop.
 
-Section ExtensionalProperties.
-
-Variables A B C : Type.
-Variable Aeq : relation A.
-Variable Beq : relation B.
-Variable Ceq : relation C.
-
-(* "wd" stands for "well-defined" *)
-
-Definition fun_wd (f : A -> B) := forall x y : A, Aeq x y -> Beq (f x) (f y).
-
-Definition fun2_wd (f : A -> B -> C) :=
-  forall x x' : A, Aeq x x' -> forall y y' : B, Beq y y' -> Ceq (f x y) (f x' y').
-
-Definition fun_eq : relation (A -> B) :=
-  fun f f' => forall x x' : A, Aeq x x' -> Beq (f x) (f' x').
-
-(* Note that reflexivity of fun_eq means that every function
-is well-defined w.r.t. Aeq and Beq, i.e.,
-forall x x' : A, Aeq x x' -> Beq (f x) (f x') *)
-
-Definition fun2_eq (f f' : A -> B -> C) :=
-  forall x x' : A, Aeq x x' -> forall y y' : B, Beq y y' -> Ceq (f x y) (f' x' y').
-
-End ExtensionalProperties.
-
-(* The following definitions instantiate Beq or Ceq to iff; therefore, they
-have to be outside the ExtensionalProperties section *)
-
-Definition predicate_wd (A : Type) (Aeq : relation A) := fun_wd Aeq iff.
-
-Definition relation_wd (A B : Type) (Aeq : relation A) (Beq : relation B) :=
-  fun2_wd Aeq Beq iff.
-
-Definition relations_eq (A B : Type) (R1 R2 : A -> B -> Prop) :=
-  forall (x : A) (y : B), R1 x y <-> R2 x y.
-
-Theorem relations_eq_equiv :
-  forall (A B : Type), equiv (A -> B -> Prop) (@relations_eq A B).
-Proof.
-intros A B; unfold equiv. split; [| split];
-unfold reflexive, symmetric, transitive, relations_eq.
-reflexivity.
-intros R1 R2 R3 H1 H2 x y; rewrite H1; apply H2.
-now symmetry.
-Qed.
-
-Add Parametric Relation (A B : Type) : (A -> B -> Prop) (@relations_eq A B)
-  reflexivity proved by (proj1 (relations_eq_equiv A B))
-  symmetry proved by (proj2 (proj2 (relations_eq_equiv A B)))
-  transitivity proved by (proj1 (proj2 (relations_eq_equiv A B)))
-as relations_eq_rel.
-
-Add Parametric Morphism (A : Type) : (@well_founded A) with signature (@relations_eq A A) ==> iff as well_founded_wd.
+Instance well_founded_wd A :
+ Proper (@relation_equivalence A ==> iff) (@well_founded A).
 Proof.
-unfold relations_eq, well_founded; intros R1 R2 H;
-split; intros H1 a; induction (H1 a) as [x H2 H3]; constructor;
-intros y H4; apply H3; [now apply <- H | now apply -> H].
+intros R1 R2 H.
+split; intros WF a; induction (WF a) as [x _ WF']; constructor;
+intros y Ryx; apply WF'; destruct (H y x); auto.
 Qed.
 
-(* solve_predicate_wd solves the goal [predicate_wd P] for P consisting of
-morhisms and quatifiers *)
+(** [solve_predicate_wd] solves the goal [Proper (?==>iff) P]
+    for P consisting of morphisms and quantifiers *)
 
 Ltac solve_predicate_wd :=
-unfold predicate_wd;
 let x := fresh "x" in
 let y := fresh "y" in
 let H := fresh "H" in
   intros x y H; setoid_rewrite H; reflexivity.
 
-(* solve_relation_wd solves the goal [relation_wd R] for R consisting of
-morhisms and quatifiers *)
+(** [solve_relation_wd] solves the goal [Proper (?==>?==>iff) R]
+    for R consisting of morphisms and quantifiers *)
 
 Ltac solve_relation_wd :=
-unfold relation_wd, fun2_wd;
 let x1 := fresh "x" in
 let y1 := fresh "y" in
 let H1 := fresh "H" in
@@ -191,77 +137,3 @@ Ltac induction_maker n t :=
   pattern n; t; clear n;
   [solve_predicate_wd | ..].
 
-(** Relations on cartesian product. Used in MiscFunct for defining
-functions whose domain is a product of sets by primitive recursion *)
-
-Section RelationOnProduct.
-
-Variables A B : Set.
-Variable Aeq : relation A.
-Variable Beq : relation B.
-
-Hypothesis EA_equiv : equiv A Aeq.
-Hypothesis EB_equiv : equiv B Beq.
-
-Definition prod_rel : relation (A * B) :=
-  fun p1 p2 => Aeq (fst p1) (fst p2) /\ Beq (snd p1) (snd p2).
-
-Lemma prod_rel_refl : reflexive (A * B) prod_rel.
-Proof.
-unfold reflexive, prod_rel.
-destruct x; split; [apply (proj1 EA_equiv) | apply (proj1 EB_equiv)]; simpl.
-Qed.
-
-Lemma prod_rel_sym : symmetric (A * B) prod_rel.
-Proof.
-unfold symmetric, prod_rel.
-destruct x; destruct y;
-split; [apply (proj2 (proj2 EA_equiv)) | apply (proj2 (proj2 EB_equiv))]; simpl in *; tauto.
-Qed.
-
-Lemma prod_rel_trans : transitive (A * B) prod_rel.
-Proof.
-unfold transitive, prod_rel.
-destruct x; destruct y; destruct z; simpl.
-intros; split; [apply (proj1 (proj2 EA_equiv)) with (y := a0) |
-apply (proj1 (proj2 EB_equiv)) with (y := b0)]; tauto.
-Qed.
-
-Theorem prod_rel_equiv : equiv (A * B) prod_rel.
-Proof.
-unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_sym]].
-Qed.
-
-End RelationOnProduct.
-
-Implicit Arguments prod_rel [A B].
-Implicit Arguments prod_rel_equiv [A B].
-
-(** Miscellaneous *)
-
-(*Definition comp_bool (x y : comparison) : bool :=
-match x, y with
-| Lt, Lt => true
-| Eq, Eq => true
-| Gt, Gt => true
-| _, _   => false
-end.
-
-Theorem comp_bool_correct : forall x y : comparison,
-  comp_bool x y <-> x = y.
-Proof.
-destruct x; destruct y; simpl; split; now intro.
-Qed.*)
-
-Lemma eq_equiv : forall A : Set, equiv A (@eq A).
-Proof.
-intro A; unfold equiv, reflexive, symmetric, transitive.
-repeat split; [exact (@trans_eq A) | exact (@sym_eq A)].
-(* It is interesting how the tactic split proves reflexivity *)
-Qed.
-
-(*Add Relation (fun A : Set => A) LE_Set
- reflexivity proved by (fun A : Set => (proj1 (eq_equiv A)))
- symmetry proved by (fun A : Set => (proj2 (proj2 (eq_equiv A))))
- transitivity proved by (fun A : Set => (proj1 (proj2 (eq_equiv A))))
-as EA_rel.*)
diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v
index f01cbbc5..0bc71166 100644
--- a/theories/Numbers/Rational/BigQ/BigQ.v
+++ b/theories/Numbers/Rational/BigQ/BigQ.v
@@ -5,12 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
-(************************************************************************)
 
-(*i $Id: BigQ.v 12509 2009-11-12 15:52:50Z letouzey $ i*)
+(** * BigQ: an efficient implementation of rational numbers *)
+
+(** Initial authors: Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
 
-Require Import Field Qfield BigN BigZ QSig QMake.
+Require Export BigZ.
+Require Import Field Qfield QSig QMake Orders GenericMinMax.
 
 (** We choose for BigQ an implemention with
     multiple representation of 0: 0, 1/0, 2/0 etc.
@@ -34,7 +35,9 @@ End BigN_BigZ.
 
 (** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *)
 
-Module BigQ <: QSig.QType := QMake.Make BigN BigZ BigN_BigZ.
+Module BigQ <: QType <: OrderedTypeFull <: TotalOrder :=
+ QMake.Make BigN BigZ BigN_BigZ <+ !QProperties <+ HasEqBool2Dec
+ <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
 
 (** Notations about [BigQ] *)
 
@@ -43,12 +46,40 @@ Notation bigQ := BigQ.t.
 Delimit Scope bigQ_scope with bigQ.
 Bind Scope bigQ_scope with bigQ.
 Bind Scope bigQ_scope with BigQ.t.
-
-(* Allow nice printing of rational numerals, either as (Qz 1234)
-   or as (Qq 1234 5678) *)
+Bind Scope bigQ_scope with BigQ.t_.
+(* Bind Scope has no retroactive effect, let's declare scopes by hand. *)
 Arguments Scope BigQ.Qz [bigZ_scope].
-Arguments Scope BigQ.Qq [bigZ_scope bigN_scope].			     
-			     
+Arguments Scope BigQ.Qq [bigZ_scope bigN_scope].
+Arguments Scope BigQ.to_Q [bigQ_scope].
+Arguments Scope BigQ.red [bigQ_scope].
+Arguments Scope BigQ.opp [bigQ_scope].
+Arguments Scope BigQ.inv [bigQ_scope].
+Arguments Scope BigQ.square [bigQ_scope].
+Arguments Scope BigQ.add [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.sub [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.mul [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.div [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.eq [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.lt [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.le [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.eq [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.compare [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.min [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.max [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.eq_bool [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.power_pos [bigQ_scope positive_scope].
+Arguments Scope BigQ.power [bigQ_scope Z_scope].
+Arguments Scope BigQ.inv_norm [bigQ_scope].
+Arguments Scope BigQ.add_norm [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.sub_norm [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.mul_norm [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.div_norm [bigQ_scope bigQ_scope].
+Arguments Scope BigQ.power_norm [bigQ_scope bigQ_scope].
+
+(** As in QArith, we use [#] to denote fractions *)
+Notation "p # q" := (BigQ.Qq p q) (at level 55, no associativity) : bigQ_scope.
+Local Notation "0" := BigQ.zero : bigQ_scope.
+Local Notation "1" := BigQ.one : bigQ_scope.
 Infix "+" := BigQ.add : bigQ_scope.
 Infix "-" := BigQ.sub : bigQ_scope.
 Notation "- x" := (BigQ.opp x) : bigQ_scope.
@@ -57,142 +88,102 @@ Infix "/" := BigQ.div : bigQ_scope.
 Infix "^" := BigQ.power : bigQ_scope.
 Infix "?=" := BigQ.compare : bigQ_scope.
 Infix "==" := BigQ.eq : bigQ_scope.
+Notation "x != y" := (~x==y)%bigQ (at level 70, no associativity) : bigQ_scope.
 Infix "<" := BigQ.lt : bigQ_scope.
 Infix "<=" := BigQ.le : bigQ_scope.
 Notation "x > y" := (BigQ.lt y x)(only parsing) : bigQ_scope.
 Notation "x >= y" := (BigQ.le y x)(only parsing) : bigQ_scope.
+Notation "x < y < z" := (x<y /\ y<z)%bigQ : bigQ_scope.
+Notation "x < y <= z" := (x<y /\ y<=z)%bigQ : bigQ_scope.
+Notation "x <= y < z" := (x<=y /\ y<z)%bigQ : bigQ_scope.
+Notation "x <= y <= z" := (x<=y /\ y<=z)%bigQ : bigQ_scope.
 Notation "[ q ]" := (BigQ.to_Q q) : bigQ_scope.
 
-Open Scope bigQ_scope.
-
-(** [BigQ] is a setoid *)
-
-Add Relation BigQ.t BigQ.eq
- reflexivity proved by (fun x => Qeq_refl [x])
- symmetry proved by (fun x y => Qeq_sym [x] [y])
- transitivity proved by (fun x y z => Qeq_trans [x] [y] [z])
-as BigQeq_rel.
-
-Add Morphism BigQ.add with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQadd_wd.
-Proof.
- unfold BigQ.eq; intros; rewrite !BigQ.spec_add; rewrite H, H0; apply Qeq_refl.
-Qed.
-
-Add Morphism BigQ.opp with signature BigQ.eq ==> BigQ.eq as BigQopp_wd.
-Proof.
- unfold BigQ.eq; intros; rewrite !BigQ.spec_opp; rewrite H; apply Qeq_refl.
-Qed.
-
-Add Morphism BigQ.sub with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQsub_wd.
-Proof.
- unfold BigQ.eq; intros; rewrite !BigQ.spec_sub; rewrite H, H0; apply Qeq_refl.
-Qed.
-
-Add Morphism BigQ.mul with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQmul_wd.
-Proof.
- unfold BigQ.eq; intros; rewrite !BigQ.spec_mul; rewrite H, H0; apply Qeq_refl.
-Qed.
-
-Add Morphism BigQ.inv with signature BigQ.eq ==> BigQ.eq as BigQinv_wd.
-Proof.
- unfold BigQ.eq; intros; rewrite !BigQ.spec_inv; rewrite H; apply Qeq_refl.
-Qed.
-
-Add Morphism BigQ.div with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQdiv_wd.
-Proof.
- unfold BigQ.eq; intros; rewrite !BigQ.spec_div; rewrite H, H0; apply Qeq_refl.
-Qed.
-
-(* TODO : fix this. For the moment it's useless (horribly slow)
-Hint Rewrite
- BigQ.spec_0 BigQ.spec_1 BigQ.spec_m1 BigQ.spec_compare
- BigQ.spec_red BigQ.spec_add BigQ.spec_sub BigQ.spec_opp
- BigQ.spec_mul BigQ.spec_inv BigQ.spec_div BigQ.spec_power_pos
- BigQ.spec_square : bigq. *)
-
+Local Open Scope bigQ_scope.
 
 (** [BigQ] is a field *)
 
 Lemma BigQfieldth :
- field_theory BigQ.zero BigQ.one BigQ.add BigQ.mul BigQ.sub BigQ.opp BigQ.div BigQ.inv BigQ.eq.
+ field_theory 0 1 BigQ.add BigQ.mul BigQ.sub BigQ.opp
+  BigQ.div BigQ.inv BigQ.eq.
 Proof.
 constructor.
-constructor; intros; red.
-rewrite BigQ.spec_add, BigQ.spec_0; ring.
-rewrite ! BigQ.spec_add; ring.
-rewrite ! BigQ.spec_add; ring.
-rewrite BigQ.spec_mul, BigQ.spec_1; ring.
-rewrite ! BigQ.spec_mul; ring.
-rewrite ! BigQ.spec_mul; ring.
-rewrite BigQ.spec_add, ! BigQ.spec_mul, BigQ.spec_add; ring.
-unfold BigQ.sub; apply Qeq_refl.
-rewrite BigQ.spec_add, BigQ.spec_0, BigQ.spec_opp; ring.
-compute; discriminate.
-intros; red.
-unfold BigQ.div; apply Qeq_refl.
-intros; red.
-rewrite BigQ.spec_mul, BigQ.spec_inv, BigQ.spec_1; field.
-rewrite <- BigQ.spec_0; auto.
-Qed.
-
-Lemma BigQpowerth :
- power_theory BigQ.one BigQ.mul BigQ.eq Z_of_N BigQ.power.
-Proof.
 constructor.
-intros; red.
-rewrite BigQ.spec_power.
-replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q.
-destruct n.
-simpl; compute; auto.
-induction p; simpl; auto; try rewrite !BigQ.spec_mul, !IHp; apply Qeq_refl.
-destruct n; reflexivity.
-Qed.
-
-Lemma BigQ_eq_bool_correct :
- forall x y, BigQ.eq_bool x y = true -> x==y.
-Proof.
-intros; generalize (BigQ.spec_eq_bool x y); rewrite H; auto.
+exact BigQ.add_0_l. exact BigQ.add_comm. exact BigQ.add_assoc.
+exact BigQ.mul_1_l. exact BigQ.mul_comm. exact BigQ.mul_assoc.
+exact BigQ.mul_add_distr_r. exact BigQ.sub_add_opp.
+exact BigQ.add_opp_diag_r. exact BigQ.neq_1_0.
+exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l.
 Qed.
 
-Lemma BigQ_eq_bool_complete :
- forall x y, x==y -> BigQ.eq_bool x y = true.
+Lemma BigQpowerth :
+ power_theory 1 BigQ.mul BigQ.eq Z_of_N BigQ.power.
 Proof.
-intros; generalize (BigQ.spec_eq_bool x y).
-destruct BigQ.eq_bool; auto.
+constructor. intros. BigQ.qify.
+replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n).
+destruct n. reflexivity.
+induction p; simpl; auto; rewrite ?BigQ.spec_mul, ?IHp; reflexivity.
 Qed.
 
-(* TODO : improve later the detection of constants ... *)
+Ltac isBigQcst t :=
+ match t with
+ | BigQ.Qz ?t => isBigZcst t
+ | BigQ.Qq ?n ?d => match isBigZcst n with
+             | true => isBigNcst d
+             | false => constr:false
+             end
+ | BigQ.zero => constr:true
+ | BigQ.one => constr:true
+ | BigQ.minus_one => constr:true
+ | _ => constr:false
+ end.
 
 Ltac BigQcst t :=
- match t with
-   | BigQ.zero => BigQ.zero
-   | BigQ.one => BigQ.one
-   | BigQ.minus_one => BigQ.minus_one
-   | _ => NotConstant
+ match isBigQcst t with
+ | true => constr:t
+ | false => constr:NotConstant
  end.
 
 Add Field BigQfield : BigQfieldth
- (decidable BigQ_eq_bool_correct,
-  completeness BigQ_eq_bool_complete,
+ (decidable BigQ.eqb_correct,
+  completeness BigQ.eqb_complete,
   constants [BigQcst],
   power_tac BigQpowerth [Qpow_tac]).
 
-Section Examples.
+Section TestField.
 
 Let ex1 : forall x y z, (x+y)*z ==  (x*z)+(y*z).
   intros.
   ring.
 Qed.
 
-Let ex8 : forall x, x ^ 1 == x.
+Let ex8 : forall x, x ^ 2 == x*x.
   intro.
   ring.
 Qed.
 
-Let ex10 : forall x y, ~(y==BigQ.zero) -> (x/y)*y == x.
+Let ex10 : forall x y, y!=0 -> (x/y)*y == x.
 intros.
 field.
 auto.
 Qed.
 
-End Examples.
\ No newline at end of file
+End TestField.
+
+(** [BigQ] can also benefit from an "order" tactic *)
+
+Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ.
+Ltac bigQ_order := BigQ_Order.order.
+
+Section TestOrder.
+Let test : forall x y : bigQ, x<=y -> y<=x -> x==y.
+Proof. bigQ_order. Qed.
+End TestOrder.
+
+(** We can also reason by switching to QArith thanks to tactic
+    BigQ.qify. *)
+
+Section TestQify.
+Let test : forall x : bigQ, 0+x == 1*x.
+Proof. intro x. BigQ.qify. ring. Qed.
+End TestQify.
diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v
index 494420bd..407f7b90 100644
--- a/theories/Numbers/Rational/BigQ/QMake.v
+++ b/theories/Numbers/Rational/BigQ/QMake.v
@@ -5,15 +5,20 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
-(************************************************************************)
 
-(*i $Id: QMake.v 11208 2008-07-04 16:57:46Z letouzey $ i*)
+(** * QMake : a generic efficient implementation of rational numbers *)
+
+(** Initial authors : Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
 
 Require Import BigNumPrelude ROmega.
-Require Import QArith Qcanon Qpower.
+Require Import QArith Qcanon Qpower Qminmax.
 Require Import NSig ZSig QSig.
 
+(** We will build rationals out of an implementation of integers [ZType]
+    for numerators and an implementation of natural numbers [NType] for
+    denominators. But first we will need some glue between [NType] and
+    [ZType]. *)
+
 Module Type NType_ZType (N:NType)(Z:ZType).
  Parameter Z_of_N : N.t -> Z.t.
  Parameter spec_Z_of_N : forall n, Z.to_Z (Z_of_N n) = N.to_Z n.
@@ -28,27 +33,27 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
      number y interpreted as x/y. The pairs (x,0) and (0,y) are all
      interpreted as 0. *)
 
- Inductive t_ := 
+ Inductive t_ :=
   | Qz : Z.t -> t_
   | Qq : Z.t -> N.t -> t_.
 
  Definition t := t_.
 
- (** Specification with respect to [QArith] *) 
+ (** Specification with respect to [QArith] *)
 
- Open Local Scope Q_scope.
+ Local Open Scope Q_scope.
 
  Definition of_Z x: t := Qz (Z.of_Z x).
 
- Definition of_Q (q:Q) : t := 
-  let (x,y) := q in 
-  match y with 
+ Definition of_Q (q:Q) : t :=
+  let (x,y) := q in
+  match y with
     | 1%positive => Qz (Z.of_Z x)
     | _ => Qq (Z.of_Z x) (N.of_N (Npos y))
   end.
 
- Definition to_Q (q: t) := 
- match q with 
+ Definition to_Q (q: t) :=
+ match q with
    | Qz x => Z.to_Z x # 1
    | Qq x y => if N.eq_bool y N.zero then 0
                else Z.to_Z x # Z2P (N.to_Z y)
@@ -56,17 +61,56 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Notation "[ x ]" := (to_Q x).
 
+ Lemma N_to_Z_pos :
+  forall x, (N.to_Z x <> N.to_Z N.zero)%Z -> (0 < N.to_Z x)%Z.
+ Proof.
+ intros x; rewrite N.spec_0; generalize (N.spec_pos x). romega.
+ Qed.
+(*
+ Lemma if_fun_commut : forall A B (f:A->B)(b:bool) a a',
+ f (if b then a else a') = if b then f a else f a'.
+ Proof. now destruct b. Qed.
+
+ Lemma if_fun_commut' : forall A B C D (f:A->B)(b:{C}+{D}) a a',
+ f (if b then a else a') = if b then f a else f a'.
+ Proof. now destruct b. Qed.
+*)
+ Ltac destr_eqb :=
+  match goal with
+   | |- context [Z.eq_bool ?x ?y] =>
+     rewrite (Z.spec_eq_bool x y);
+     generalize (Zeq_bool_if (Z.to_Z x) (Z.to_Z y));
+     case (Zeq_bool (Z.to_Z x) (Z.to_Z y));
+     destr_eqb
+   | |- context [N.eq_bool ?x ?y] =>
+     rewrite (N.spec_eq_bool x y);
+     generalize (Zeq_bool_if (N.to_Z x) (N.to_Z y));
+     case (Zeq_bool (N.to_Z x) (N.to_Z y));
+     [ | let H:=fresh "H" in
+         try (intro H;generalize (N_to_Z_pos _ H); clear H)];
+     destr_eqb
+   | _ => idtac
+  end.
+
+ Hint Rewrite
+  Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l
+  Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp
+  Z.spec_compare N.spec_compare
+  Z.spec_add N.spec_add Z.spec_mul N.spec_mul Z.spec_div N.spec_div
+  Z.spec_gcd N.spec_gcd Zgcd_Zabs Zgcd_1
+  spec_Z_of_N spec_Zabs_N
+ : nz.
+ Ltac nzsimpl := autorewrite with nz in *.
+
+ Ltac qsimpl := try red; unfold to_Q; simpl; intros;
+  destr_eqb; simpl; nzsimpl; intros;
+  rewrite ?Z2P_correct by auto;
+  auto.
+
  Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q.
  Proof.
- intros(x,y); destruct y; simpl; rewrite Z.spec_of_Z; auto.
- generalize (N.spec_eq_bool (N.of_N (Npos y~1)) N.zero); 
-  case N.eq_bool; auto; rewrite N.spec_0.
- rewrite N.spec_of_N; intros; discriminate.
- rewrite N.spec_of_N; auto.
- generalize (N.spec_eq_bool (N.of_N (Npos y~0)) N.zero); 
-  case N.eq_bool; auto; rewrite N.spec_0.
- rewrite N.spec_of_N; intros; discriminate.
- rewrite N.spec_of_N; auto.
+ intros(x,y); destruct y; simpl; rewrite ?Z.spec_of_Z; auto;
+  destr_eqb; now rewrite ?N.spec_0, ?N.spec_of_N.
  Qed.
 
  Theorem spec_of_Q: forall q: Q, [of_Q q] == q.
@@ -82,131 +126,96 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Lemma spec_0: [zero] == 0.
  Proof.
- simpl; rewrite Z.spec_0; reflexivity.
+ simpl. nzsimpl. reflexivity.
  Qed.
 
  Lemma spec_1: [one] == 1.
  Proof.
- simpl; rewrite Z.spec_1; reflexivity.
+ simpl. nzsimpl. reflexivity.
  Qed.
 
  Lemma spec_m1: [minus_one] == -(1).
  Proof.
- simpl; rewrite Z.spec_m1; reflexivity.
+ simpl. nzsimpl. reflexivity.
  Qed.
 
  Definition compare (x y: t) :=
   match x, y with
   | Qz zx, Qz zy => Z.compare zx zy
-  | Qz zx, Qq ny dy => 
+  | Qz zx, Qq ny dy =>
     if N.eq_bool dy N.zero then Z.compare zx Z.zero
     else Z.compare (Z.mul zx (Z_of_N dy)) ny
-  | Qq nx dx, Qz zy => 
-    if N.eq_bool dx N.zero then Z.compare Z.zero zy 
+  | Qq nx dx, Qz zy =>
+    if N.eq_bool dx N.zero then Z.compare Z.zero zy
     else Z.compare nx (Z.mul zy (Z_of_N dx))
   | Qq nx dx, Qq ny dy =>
     match N.eq_bool dx N.zero, N.eq_bool dy N.zero with
     | true, true => Eq
     | true, false => Z.compare Z.zero ny
     | false, true => Z.compare nx Z.zero
-    | false, false => Z.compare (Z.mul nx (Z_of_N dy)) 
+    | false, false => Z.compare (Z.mul nx (Z_of_N dy))
                                 (Z.mul ny (Z_of_N dx))
     end
   end.
 
- Lemma Zcompare_spec_alt : 
-  forall z z', Z.compare z z' = (Z.to_Z z ?= Z.to_Z z')%Z.
+ Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]).
  Proof.
- intros; generalize (Z.spec_compare z z'); destruct Z.compare; auto.
- intro H; rewrite H; symmetry; apply Zcompare_refl.
+ intros [z1 | x1 y1] [z2 | x2 y2];
+   unfold Qcompare, compare; qsimpl.
  Qed.
- 
- Lemma Ncompare_spec_alt : 
-  forall n n', N.compare n n' = (N.to_Z n ?= N.to_Z n')%Z.
+
+ Definition lt n m := [n] < [m].
+ Definition le n m := [n] <= [m].
+
+ Definition min n m := match compare n m with Gt => m | _ => n end.
+ Definition max n m := match compare n m with Lt => m | _ => n end.
+
+ Lemma spec_min : forall n m, [min n m] == Qmin [n] [m].
  Proof.
- intros; generalize (N.spec_compare n n'); destruct N.compare; auto.
- intro H; rewrite H; symmetry; apply Zcompare_refl.
+ unfold min, Qmin, GenericMinMax.gmin. intros.
+ rewrite spec_compare; destruct Qcompare; auto with qarith.
  Qed.
 
- Lemma N_to_Z2P : forall n, N.to_Z n <> 0%Z -> 
-  Zpos (Z2P (N.to_Z n)) = N.to_Z n.
+ Lemma spec_max : forall n m, [max n m] == Qmax [n] [m].
  Proof.
- intros; apply Z2P_correct.
- generalize (N.spec_pos n); romega.
+ unfold max, Qmax, GenericMinMax.gmax. intros.
+ rewrite spec_compare; destruct Qcompare; auto with qarith.
  Qed.
 
- Hint Rewrite 
-  Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l 
-  Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp
-  Zcompare_spec_alt Ncompare_spec_alt
-  Z.spec_add N.spec_add Z.spec_mul N.spec_mul 
-  Z.spec_gcd N.spec_gcd Zgcd_Zabs
-  spec_Z_of_N spec_Zabs_N
- : nz.
- Ltac nzsimpl := autorewrite with nz in *.
-
- Ltac destr_neq_bool := repeat
- (match goal with |- context [N.eq_bool ?x ?y] => 
-   generalize (N.spec_eq_bool x y); case N.eq_bool
-  end).
- 
- Ltac destr_zeq_bool := repeat
- (match goal with |- context [Z.eq_bool ?x ?y] => 
-   generalize (Z.spec_eq_bool x y); case Z.eq_bool
-  end).
-
- Ltac simpl_ndiv := rewrite N.spec_div by (nzsimpl; romega).
- Tactic Notation "simpl_ndiv" "in" "*" := 
-   rewrite N.spec_div in * by (nzsimpl; romega).
-
- Ltac simpl_zdiv := rewrite Z.spec_div by (nzsimpl; romega).
- Tactic Notation "simpl_zdiv" "in" "*" := 
-   rewrite Z.spec_div in * by (nzsimpl; romega).
-
- Ltac qsimpl := try red; unfold to_Q; simpl; intros; 
-  destr_neq_bool; destr_zeq_bool; simpl; nzsimpl; auto; intros.
+ Definition eq_bool n m :=
+  match compare n m with Eq => true | _ => false end.
 
- Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]).
+ Theorem spec_eq_bool: forall x y, eq_bool x y = Qeq_bool [x] [y].
  Proof.
- intros [z1 | x1 y1] [z2 | x2 y2]; 
-   unfold Qcompare, compare; qsimpl; rewrite ! N_to_Z2P; auto.
+ intros. unfold eq_bool. rewrite spec_compare. reflexivity.
  Qed.
 
- Definition lt n m := compare n m = Lt.
- Definition le n m := compare n m <> Gt.
- Definition min n m := match compare n m with Gt => m | _ => n end.
- Definition max n m := match compare n m with Lt => m | _ => n end.
+ (** [check_int] : is a reduced fraction [n/d] in fact a integer ? *)
 
- Definition eq_bool n m := 
-  match compare n m with Eq => true | _ => false end.
+ Definition check_int n d :=
+  match N.compare N.one d with
+  | Lt => Qq n d
+  | Eq => Qz n
+  | Gt => zero  (* n/0 encodes 0 *)
+  end.
 
- Theorem spec_eq_bool: forall x y,
-  if eq_bool x y then [x] == [y] else ~([x] == [y]).
+ Theorem strong_spec_check_int : forall n d, [check_int n d] = [Qq n d].
  Proof.
- intros.
- unfold eq_bool.
- rewrite spec_compare.
- generalize (Qeq_alt [x] [y]).
- destruct Qcompare.
- intros H; rewrite H; auto.
- intros H H'; rewrite H in H'; discriminate.
- intros H H'; rewrite H in H'; discriminate.
+ intros; unfold check_int.
+ nzsimpl.
+ destr_zcompare.
+ simpl. rewrite <- H; qsimpl. congruence.
+ reflexivity.
+ qsimpl. exfalso; romega.
  Qed.
 
  (** Normalisation function *)
 
  Definition norm n d : t :=
-  let gcd := N.gcd (Zabs_N n) d in 
+  let gcd := N.gcd (Zabs_N n) d in
   match N.compare N.one gcd with
-  | Lt => 
-    let n := Z.div n (Z_of_N gcd) in
-    let d := N.div d gcd in
-    match N.compare d N.one with
-    | Gt => Qq n d
-    | Eq => Qz n
-    | Lt => zero
-    end
-  | Eq => Qq n d
+  | Lt => check_int (Z.div n (Z_of_N gcd)) (N.div d gcd)
+  | Eq => check_int n d
   | Gt => zero (* gcd = 0 => both numbers are 0 *)
   end.
 
@@ -217,29 +226,16 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  assert (Hq := N.spec_pos q).
  nzsimpl.
  destr_zcompare.
+ (* Eq *)
+ rewrite strong_spec_check_int; reflexivity.
+ (* Lt *)
+ rewrite strong_spec_check_int.
  qsimpl.
-
- simpl_ndiv.
- destr_zcompare.
- qsimpl.
- rewrite H1 in *; rewrite Zdiv_0_l in H0; discriminate.
- rewrite N_to_Z2P; auto.
- simpl_zdiv; nzsimpl.
- rewrite Zgcd_div_swap0, H0; romega.
-
- qsimpl.
- assert (0 < N.to_Z q / Zgcd (Z.to_Z p) (N.to_Z q))%Z.
-  apply Zgcd_div_pos; romega.
- romega.
-
- qsimpl.
- simpl_ndiv in *; nzsimpl; romega.
- simpl_ndiv in *.
- rewrite H1, Zdiv_0_l in H2; elim H2; auto.
- rewrite 2 N_to_Z2P; auto.
- simpl_ndiv; simpl_zdiv; nzsimpl.
+ generalize (Zgcd_div_pos (Z.to_Z p) (N.to_Z q)). romega.
+ replace (N.to_Z q) with 0%Z in * by assumption.
+ rewrite Zdiv_0_l in *; auto with zarith.
  apply Zgcd_div_swap0; romega.
-
+ (* Gt *)
  qsimpl.
  assert (H' : Zgcd (Z.to_Z p) (N.to_Z q) = 0%Z).
   generalize (Zgcd_is_pos (Z.to_Z p) (N.to_Z q)); romega.
@@ -249,48 +245,37 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q].
  Proof.
  intros.
- replace (Qred [Qq p q]) with (Qred [norm p q]) by 
+ replace (Qred [Qq p q]) with (Qred [norm p q]) by
   (apply Qred_complete; apply spec_norm).
  symmetry; apply Qred_identity.
  unfold norm.
  assert (Hp := N.spec_pos (Zabs_N p)).
  assert (Hq := N.spec_pos q).
  nzsimpl.
- destr_zcompare.
+ destr_zcompare; rewrite ?strong_spec_check_int.
  (* Eq *)
- simpl.
- destr_neq_bool; nzsimpl; simpl; auto.
- intros.
- rewrite N_to_Z2P; auto.
- (* Lt *)
- simpl_ndiv.
- destr_zcompare.
- qsimpl; auto.
  qsimpl.
+ (* Lt *)
  qsimpl.
- simpl_zdiv; nzsimpl.
- rewrite N_to_Z2P; auto.
- clear H1.
- simpl_ndiv; nzsimpl.
  rewrite Zgcd_1_rel_prime.
  destruct (Z_lt_le_dec 0 (N.to_Z q)).
  apply Zis_gcd_rel_prime; auto with zarith.
  apply Zgcd_is_gcd.
  replace (N.to_Z q) with 0%Z in * by romega.
- rewrite Zdiv_0_l in H0; discriminate.
+ rewrite Zdiv_0_l in *; romega.
  (* Gt *)
- simpl; auto.
+ simpl; auto with zarith.
  Qed.
 
- (** Reduction function : producing irreducible fractions *) 
+ (** Reduction function : producing irreducible fractions *)
 
- Definition red (x : t) : t := 
-  match x with 
+ Definition red (x : t) : t :=
+  match x with
    | Qz z => x
    | Qq n d => norm n d
   end.
 
- Definition Reduced x := [red x] = [x].
+ Class Reduced x := is_reduced : [red x] = [x].
 
  Theorem spec_red : forall x, [red x] == [x].
  Proof.
@@ -304,21 +289,21 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Proof.
  intros [ z | n d ].
  unfold red.
- symmetry; apply Qred_identity; simpl; auto.
+ symmetry; apply Qred_identity; simpl; auto with zarith.
  unfold red; apply strong_spec_norm.
  Qed.
-   
+
  Definition add (x y: t): t :=
   match x with
   | Qz zx =>
     match y with
     | Qz zy => Qz (Z.add zx zy)
-    | Qq ny dy => 
-      if N.eq_bool dy N.zero then x 
+    | Qq ny dy =>
+      if N.eq_bool dy N.zero then x
       else Qq (Z.add (Z.mul zx (Z_of_N dy)) ny) dy
     end
   | Qq nx dx =>
-    if N.eq_bool dx N.zero then y 
+    if N.eq_bool dx N.zero then y
     else match y with
     | Qz zy => Qq (Z.add nx (Z.mul zy (Z_of_N dx))) dx
     | Qq ny dy =>
@@ -332,19 +317,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Theorem spec_add : forall x y, [add x y] == [x] + [y].
  Proof.
- intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl.
- intuition.
- rewrite N_to_Z2P; auto.
- intuition.
- rewrite Pmult_1_r, N_to_Z2P; auto.
- intuition.
- rewrite Pmult_1_r, N_to_Z2P; auto.
- destruct (Zmult_integral _ _ H); intuition.
- rewrite Zpos_mult_morphism, 2 N_to_Z2P; auto.
- rewrite (Z2P_correct (N.to_Z dx * N.to_Z dy)); auto.
- apply Zmult_lt_0_compat.
-  generalize (N.spec_pos dx); romega.
-  generalize (N.spec_pos dy); romega.
+ intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl;
+  auto with zarith.
+ rewrite Pmult_1_r, Z2P_correct; auto.
+ rewrite Pmult_1_r, Z2P_correct; auto.
+ destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition.
+ rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
  Qed.
 
  Definition add_norm (x y: t): t :=
@@ -352,12 +330,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   | Qz zx =>
     match y with
     | Qz zy => Qz (Z.add zx zy)
-    | Qq ny dy =>  
-      if N.eq_bool dy N.zero then x 
+    | Qq ny dy =>
+      if N.eq_bool dy N.zero then x
       else norm (Z.add (Z.mul zx (Z_of_N dy)) ny) dy
     end
   | Qq nx dx =>
-    if N.eq_bool dx N.zero then y 
+    if N.eq_bool dx N.zero then y
     else match y with
     | Qz zy => norm (Z.add nx (Z.mul zy (Z_of_N dx))) dx
     | Qq ny dy =>
@@ -372,26 +350,20 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y].
  Proof.
  intros x y; rewrite <- spec_add.
- destruct x; destruct y; unfold add_norm, add; 
- destr_neq_bool; auto using Qeq_refl, spec_norm.
+ destruct x; destruct y; unfold add_norm, add;
+ destr_eqb; auto using Qeq_refl, spec_norm.
  Qed.
 
- Theorem strong_spec_add_norm : forall x y : t, 
-   Reduced x -> Reduced y -> Reduced (add_norm x y).
+ Instance strong_spec_add_norm x y
+   `(Reduced x, Reduced y) : Reduced (add_norm x y).
  Proof.
  unfold Reduced; intros.
  rewrite strong_spec_red.
- rewrite <- (Qred_complete [add x y]); 
+ rewrite <- (Qred_complete [add x y]);
   [ | rewrite spec_add, spec_add_norm; apply Qeq_refl ].
  rewrite <- strong_spec_red.
- destruct x as [zx|nx dx]; destruct y as [zy|ny dy].
- simpl in *; auto.
- simpl; intros.
- destr_neq_bool; nzsimpl; simpl; auto.
- simpl; intros.
- destr_neq_bool; nzsimpl; simpl; auto.
- simpl; intros.
- destr_neq_bool; nzsimpl; simpl; auto.
+ destruct x as [zx|nx dx]; destruct y as [zy|ny dy];
+  simpl; destr_eqb; nzsimpl; simpl; auto.
  Qed.
 
  Definition opp (x: t): t :=
@@ -404,7 +376,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Proof.
  intros [z | x y]; simpl.
  rewrite Z.spec_opp; auto.
- match goal with  |- context[N.eq_bool ?X ?Y] => 
+ match goal with  |- context[N.eq_bool ?X ?Y] =>
   generalize (N.spec_eq_bool X Y); case N.eq_bool
  end; auto; rewrite N.spec_0.
  rewrite Z.spec_opp; auto.
@@ -415,7 +387,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  intros; rewrite strong_spec_opp; red; auto.
  Qed.
 
- Theorem strong_spec_opp_norm : forall q, Reduced q -> Reduced (opp q).
+ Instance strong_spec_opp_norm q `(Reduced q) : Reduced (opp q).
  Proof.
  unfold Reduced; intros.
  rewrite strong_spec_opp, <- H, !strong_spec_red, <- Qred_opp.
@@ -438,8 +410,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite spec_opp; ring.
  Qed.
 
- Theorem strong_spec_sub_norm : forall x y, 
-  Reduced x -> Reduced y -> Reduced (sub_norm x y).
+ Instance strong_spec_sub_norm x y
+  `(Reduced x, Reduced y) : Reduced (sub_norm x y).
  Proof.
  intros.
  unfold sub_norm.
@@ -458,35 +430,34 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_mul : forall x y, [mul x y] == [x] * [y].
  Proof.
  intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl; qsimpl.
- rewrite Pmult_1_r, N_to_Z2P; auto.
- destruct (Zmult_integral _ _ H1); intuition.
- rewrite H0 in H1; elim H1; auto.
- rewrite H0 in H1; elim H1; auto.
- rewrite H in H1; nzsimpl; elim H1; auto.
- rewrite Zpos_mult_morphism, 2 N_to_Z2P; auto.
- rewrite (Z2P_correct (N.to_Z dx * N.to_Z dy)); auto.
- apply Zmult_lt_0_compat.
-  generalize (N.spec_pos dx); omega.
-  generalize (N.spec_pos dy); omega.
+ rewrite Pmult_1_r, Z2P_correct; auto.
+ destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition.
+ rewrite H0 in H1; auto with zarith.
+ rewrite H0 in H1; auto with zarith.
+ rewrite H in H1; nzsimpl; auto with zarith.
+ rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
  Qed.
 
- Lemma norm_denum : forall n d, 
-  [if N.eq_bool d N.one then Qz n else Qq n d] == [Qq n d].
+ Definition norm_denum n d :=
+  if N.eq_bool d N.one then Qz n else Qq n d.
+
+ Lemma spec_norm_denum : forall n d,
+  [norm_denum n d] == [Qq n d].
  Proof.
- intros; simpl; qsimpl.
- rewrite H0 in H; discriminate.
- rewrite N_to_Z2P, H0; auto with zarith.
+ unfold norm_denum; intros; simpl; qsimpl.
+ congruence.
+ rewrite H0 in *; auto with zarith.
  Qed.
 
- Definition irred n d :=        
+ Definition irred n d :=
    let gcd := N.gcd (Zabs_N n) d in
-   match N.compare gcd N.one with 
+   match N.compare gcd N.one with
      | Gt => (Z.div n (Z_of_N gcd), N.div d gcd)
      | _ => (n, d)
    end.
 
- Lemma spec_irred : forall n d, exists g, 
-  let (n',d') := irred n d in 
+ Lemma spec_irred : forall n d, exists g,
+  let (n',d') := irred n d in
   (Z.to_Z n' * g = Z.to_Z n)%Z /\ (N.to_Z d' * g = N.to_Z d)%Z.
  Proof.
  intros.
@@ -503,15 +474,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  exists (Zgcd (Z.to_Z n) (N.to_Z d)).
  simpl.
  split.
- simpl_zdiv; nzsimpl.
+ nzsimpl.
  destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)).
  rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
- simpl_ndiv; nzsimpl.
+ nzsimpl.
  destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)).
  rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
  Qed.
 
- Lemma spec_irred_zero : forall n d, 
+ Lemma spec_irred_zero : forall n d,
    (N.to_Z d = 0)%Z <-> (N.to_Z (snd (irred n d)) = 0)%Z.
  Proof.
  intros.
@@ -520,10 +491,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  nzsimpl; intros.
  destr_zcompare; auto.
  simpl.
- simpl_ndiv; nzsimpl.
+ nzsimpl.
  rewrite H, Zdiv_0_l; auto.
  nzsimpl; destr_zcompare; simpl; auto.
- simpl_ndiv; nzsimpl.
+ nzsimpl.
  intros.
  generalize (N.spec_pos d); intros.
  destruct (N.to_Z d); auto.
@@ -535,8 +506,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  compute in H1; elim H1; auto.
  Qed.
 
- Lemma strong_spec_irred : forall n d, 
-  (N.to_Z d <> 0%Z) -> 
+ Lemma strong_spec_irred : forall n d,
+  (N.to_Z d <> 0%Z) ->
   let (n',d') := irred n d in Zgcd (Z.to_Z n') (N.to_Z d') = 1%Z.
  Proof.
  unfold irred; intros.
@@ -546,7 +517,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  apply (Zgcd_inv_0_r (Z.to_Z n)).
  generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.
 
- simpl_ndiv; simpl_zdiv; nzsimpl.
+ nzsimpl.
  rewrite Zgcd_1_rel_prime.
  apply Zis_gcd_rel_prime.
  generalize (N.spec_pos d); romega.
@@ -554,89 +525,81 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  apply Zgcd_is_gcd; auto.
  Qed.
 
- Definition mul_norm_Qz_Qq z n d := 
-   if Z.eq_bool z Z.zero then zero 
+ Definition mul_norm_Qz_Qq z n d :=
+   if Z.eq_bool z Z.zero then zero
    else
     let gcd := N.gcd (Zabs_N z) d in
     match N.compare gcd N.one with
-      | Gt => 
+      | Gt =>
         let z := Z.div z (Z_of_N gcd) in
         let d := N.div d gcd in
-        if N.eq_bool d N.one then Qz (Z.mul z n) else Qq (Z.mul z n) d
+        norm_denum (Z.mul z n) d
       | _  => Qq (Z.mul z n) d
     end.
 
- Definition mul_norm (x y: t): t := 
+ Definition mul_norm (x y: t): t :=
  match x, y with
  | Qz zx, Qz zy => Qz (Z.mul zx zy)
  | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy
  | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx
- | Qq nx dx, Qq ny dy => 
-    let (nx, dy) := irred nx dy in 
-    let (ny, dx) := irred ny dx in 
-    let d := N.mul dx dy in
-    if N.eq_bool d N.one then Qz (Z.mul ny nx) else Qq (Z.mul ny nx) d
+ | Qq nx dx, Qq ny dy =>
+    let (nx, dy) := irred nx dy in
+    let (ny, dx) := irred ny dx in
+    norm_denum (Z.mul ny nx) (N.mul dx dy)
  end.
 
- Lemma spec_mul_norm_Qz_Qq : forall z n d, 
+ Lemma spec_mul_norm_Qz_Qq : forall z n d,
    [mul_norm_Qz_Qq z n d] == [Qq (Z.mul z n) d].
  Proof.
  intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
- destr_zeq_bool; intros Hz; nzsimpl.
+ destr_eqb; nzsimpl; intros Hz.
  qsimpl; rewrite Hz; auto.
- assert (Hd := N.spec_pos d).
- destruct Z_le_gt_dec.
+ destruct Z_le_gt_dec; intros.
  qsimpl.
- rewrite norm_denum.
+ rewrite spec_norm_denum.
  qsimpl.
- simpl_ndiv in *; nzsimpl.
- rewrite (Zdiv_gcd_zero _ _ H0 H) in z0; discriminate.
- simpl_ndiv in *; nzsimpl.
- rewrite H, Zdiv_0_l in H0; elim H0; auto.
- rewrite 2 N_to_Z2P; auto.
- simpl_ndiv; simpl_zdiv; nzsimpl.
- rewrite (Zmult_comm (Z.to_Z z)), <- 2 Zmult_assoc.
- rewrite <- Zgcd_div_swap0; auto with zarith; ring.
+ rewrite Zdiv_gcd_zero in z0; auto with zarith.
+ rewrite H in *. rewrite Zdiv_0_l in *; discriminate.
+ rewrite <- Zmult_assoc, (Zmult_comm (Z.to_Z n)), Zmult_assoc.
+ rewrite Zgcd_div_swap0; try romega.
+ ring.
  Qed.
 
- Lemma strong_spec_mul_norm_Qz_Qq : forall z n d, 
-   Reduced (Qq n d) -> Reduced (mul_norm_Qz_Qq z n d).
+ Instance strong_spec_mul_norm_Qz_Qq z n d :
+   forall `(Reduced (Qq n d)), Reduced (mul_norm_Qz_Qq z n d).
  Proof.
- unfold Reduced; intros z n d.
+ unfold Reduced.
  rewrite 2 strong_spec_red, 2 Qred_iff.
  simpl; nzsimpl.
- destr_neq_bool; intros Hd H; simpl in *; nzsimpl.
- 
+ destr_eqb; intros Hd H; simpl in *; nzsimpl.
+
  unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
- destr_zeq_bool; intros Hz; simpl; nzsimpl; simpl; auto.
+ destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto.
  destruct Z_le_gt_dec.
  simpl; nzsimpl.
- destr_neq_bool; simpl; nzsimpl; auto.
- intros H'; elim H'; auto.
- destr_neq_bool; simpl; nzsimpl.
- simpl_ndiv; nzsimpl; rewrite Hd, Zdiv_0_l; intros; discriminate.
+ destr_eqb; simpl; nzsimpl; auto with zarith.
+ unfold norm_denum. destr_eqb; simpl; nzsimpl.
+ rewrite Hd, Zdiv_0_l; discriminate.
  intros _.
- destr_neq_bool; simpl; nzsimpl; auto.
- simpl_ndiv; nzsimpl; rewrite Hd, Zdiv_0_l; intro H'; elim H'; auto.
+ destr_eqb; simpl; nzsimpl; auto.
+ nzsimpl; rewrite Hd, Zdiv_0_l; auto with zarith.
 
- rewrite N_to_Z2P in H; auto.
+ rewrite Z2P_correct in H; auto.
  unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
- destr_zeq_bool; intros Hz; simpl; nzsimpl; simpl; auto.
+ destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto.
  destruct Z_le_gt_dec as [H'|H'].
  simpl; nzsimpl.
- destr_neq_bool; simpl; nzsimpl; auto.
+ destr_eqb; simpl; nzsimpl; auto.
  intros.
- rewrite N_to_Z2P; auto.
+ rewrite Z2P_correct; auto.
  apply Zgcd_mult_rel_prime; auto.
   generalize (Zgcd_inv_0_l (Z.to_Z z) (N.to_Z d))
     (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega.
- destr_neq_bool; simpl; nzsimpl; auto.
- simpl_ndiv; simpl_zdiv; nzsimpl.
- intros.
- destr_neq_bool; simpl; nzsimpl; auto.
- simpl_ndiv in *; nzsimpl.
- intros.
- rewrite Z2P_correct.
+ destr_eqb; simpl; nzsimpl; auto.
+ unfold norm_denum.
+ destr_eqb; nzsimpl; simpl; destr_eqb; simpl; auto.
+ intros; nzsimpl.
+ rewrite Z2P_correct; auto.
  apply Zgcd_mult_rel_prime.
  rewrite Zgcd_1_rel_prime.
  apply Zis_gcd_rel_prime.
@@ -652,9 +615,6 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite <- Huv; rewrite Hd0 at 2; ring.
  rewrite Hd0 at 1.
  symmetry; apply Z_div_mult_full; auto with zarith.
- apply Zgcd_div_pos.
- generalize (N.spec_pos d); romega.
- generalize (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega.
  Qed.
 
  Theorem spec_mul_norm : forall x y, [mul_norm x y] == [x] * [y].
@@ -670,37 +630,31 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct (spec_irred ny dx) as (g' & Hg').
  assert (Hz := spec_irred_zero nx dy).
  assert (Hz':= spec_irred_zero ny dx).
- destruct irred as (n1,d1); destruct irred as (n2,d2). 
+ destruct irred as (n1,d1); destruct irred as (n2,d2).
  simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
- rewrite norm_denum.
+ rewrite spec_norm_denum.
  qsimpl.
 
- elim H; destruct (Zmult_integral _ _ H0) as [Eq|Eq].
- rewrite <- Hz' in Eq; rewrite Eq; simpl; auto.
- rewrite <- Hz in Eq; rewrite Eq; nzsimpl; auto.
+ destruct (Zmult_integral _ _ H0) as [Eq|Eq].
+ rewrite Eq in *; simpl in *.
+ rewrite <- Hg2' in *; auto with zarith.
+ rewrite Eq in *; simpl in *.
+ rewrite <- Hg2 in *; auto with zarith.
 
- elim H0; destruct (Zmult_integral _ _ H) as [Eq|Eq].
- rewrite Hz' in Eq; rewrite Eq; simpl; auto.
- rewrite Hz in Eq; rewrite Eq; nzsimpl; auto.
+ destruct (Zmult_integral _ _ H) as [Eq|Eq].
+ rewrite Hz' in Eq; rewrite Eq in *; auto with zarith.
+ rewrite Hz in Eq; rewrite Eq in *; auto with zarith.
 
- rewrite 2 Z2P_correct.
  rewrite <- Hg1, <- Hg2, <- Hg1', <- Hg2'; ring.
-
- assert (0 <= N.to_Z d2 * N.to_Z d1)%Z 
-  by (apply Zmult_le_0_compat; apply N.spec_pos).
- romega.
- assert (0 <= N.to_Z dx * N.to_Z dy)%Z 
-  by (apply Zmult_le_0_compat; apply N.spec_pos).
- romega.
  Qed.
 
- Theorem strong_spec_mul_norm : forall x y,
-  Reduced x -> Reduced y -> Reduced (mul_norm x y).
+ Instance strong_spec_mul_norm x y :
+  forall `(Reduced x, Reduced y), Reduced (mul_norm x y).
  Proof.
  unfold Reduced; intros.
  rewrite strong_spec_red, Qred_iff.
  destruct x as [zx|nx dx]; destruct y as [zy|ny dy].
- simpl in *; auto.
+ simpl in *; auto with zarith.
  simpl.
  rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto.
  simpl.
@@ -712,26 +666,27 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  assert (Hz':= spec_irred_zero ny dx).
  assert (Hgc := strong_spec_irred nx dy).
  assert (Hgc' := strong_spec_irred ny dx).
- destruct irred as (n1,d1); destruct irred as (n2,d2). 
+ destruct irred as (n1,d1); destruct irred as (n2,d2).
  simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
- destr_neq_bool; simpl; nzsimpl; intros.
- apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1.
- destr_neq_bool; simpl; nzsimpl; intros.
- auto.
+
+ unfold norm_denum; qsimpl.
+
+ assert (NEQ : N.to_Z dy <> 0%Z) by
+  (rewrite Hz; intros EQ; rewrite EQ in *; romega).
+ specialize (Hgc NEQ).
+
+ assert (NEQ' : N.to_Z dx <> 0%Z) by
+  (rewrite Hz'; intro EQ; rewrite EQ in *; romega).
+ specialize (Hgc' NEQ').
 
  revert H H0.
  rewrite 2 strong_spec_red, 2 Qred_iff; simpl.
- destr_neq_bool; simpl; nzsimpl; intros.
- rewrite Hz in H; rewrite H in H2; nzsimpl; elim H2; auto.
- rewrite Hz' in H0; rewrite H0 in H2; nzsimpl; elim H2; auto.
- rewrite Hz in H; rewrite H in H2; nzsimpl; elim H2; auto.
+ destr_eqb; simpl; nzsimpl; try romega; intros.
+ rewrite Z2P_correct in *; auto.
 
- rewrite N_to_Z2P in *; auto.
- rewrite Z2P_correct.
+ apply Zgcd_mult_rel_prime; rewrite Zgcd_comm;
+  apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; auto.
 
- apply Zgcd_mult_rel_prime; rewrite Zgcd_sym; 
-  apply Zgcd_mult_rel_prime; rewrite Zgcd_sym; auto.
- 
  rewrite Zgcd_1_rel_prime in *.
  apply bezout_rel_prime.
  destruct (rel_prime_bezout _ _ H4) as [u v Huv].
@@ -743,21 +698,17 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct (rel_prime_bezout _ _ H3) as [u v Huv].
  apply Bezout_intro with (u*g)%Z (v*g')%Z.
  rewrite <- Huv, <- Hg2', <- Hg1. ring.
-
- assert (0 <= N.to_Z d2 * N.to_Z d1)%Z.
-  apply Zmult_le_0_compat; apply N.spec_pos.
- romega.
  Qed.
 
- Definition inv (x: t): t := 
+ Definition inv (x: t): t :=
  match x with
- | Qz z => 
-   match Z.compare Z.zero z with 
+ | Qz z =>
+   match Z.compare Z.zero z with
      | Eq => zero
      | Lt => Qq Z.one (Zabs_N z)
      | Gt => Qq Z.minus_one (Zabs_N z)
    end
- | Qq n d => 
+ | Qq n d =>
    match Z.compare Z.zero n with
      | Eq => zero
      | Lt => Qq (Z_of_N d) (Zabs_N n)
@@ -770,13 +721,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct x as [ z | n d ].
  (* Qz z *)
  simpl.
- rewrite Zcompare_spec_alt; destr_zcompare.
+ rewrite Z.spec_compare; destr_zcompare.
  (* 0 = z *)
  rewrite <- H.
  simpl; nzsimpl; compute; auto.
  (* 0 < z *)
  simpl.
- destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
+ destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
  set (z':=Z.to_Z z) in *; clearbody z'.
  red; simpl.
  rewrite Zabs_eq by romega.
@@ -784,7 +735,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  unfold Qinv; simpl; destruct z'; simpl; auto; discriminate.
  (* 0 > z *)
  simpl.
- destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
+ destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
  set (z':=Z.to_Z z) in *; clearbody z'.
  red; simpl.
  rewrite Zabs_non_eq by romega.
@@ -792,14 +743,14 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  unfold Qinv; simpl; destruct z'; simpl; auto; discriminate.
  (* Qq n d *)
  simpl.
- rewrite Zcompare_spec_alt; destr_zcompare.
+ rewrite Z.spec_compare; destr_zcompare.
  (* 0 = n *)
  rewrite <- H.
  simpl; nzsimpl.
- destr_neq_bool; intros; compute; auto.
+ destr_eqb; intros; compute; auto.
  (* 0 < n *)
  simpl.
- destr_neq_bool; nzsimpl; intros.
+ destr_eqb; nzsimpl; intros.
  intros; rewrite Zabs_eq in *; romega.
  intros; rewrite Zabs_eq in *; romega.
  clear H1.
@@ -811,10 +762,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  red; simpl.
  rewrite Z2P_correct by auto.
  unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate.
- rewrite Zpos_mult_morphism, N_to_Z2P; auto.
+ rewrite Zpos_mult_morphism, Z2P_correct; auto.
  (* 0 > n *)
  simpl.
- destr_neq_bool; nzsimpl; intros.
+ destr_eqb; nzsimpl; intros.
  intros; rewrite Zabs_non_eq in *; romega.
  intros; rewrite Zabs_non_eq in *; romega.
  clear H1.
@@ -826,28 +777,28 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite Z2P_correct by romega.
  unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate.
  assert (T : forall x, Zneg x = Zopp (Zpos x)) by auto.
- rewrite T, Zpos_mult_morphism, N_to_Z2P; auto; ring.
+ rewrite T, Zpos_mult_morphism, Z2P_correct; auto; ring.
  Qed.
 
- Definition inv_norm (x: t): t := 
+ Definition inv_norm (x: t): t :=
    match x with
-     | Qz z => 
-       match Z.compare Z.zero z with 
+     | Qz z =>
+       match Z.compare Z.zero z with
          | Eq => zero
          | Lt => Qq Z.one (Zabs_N z)
          | Gt => Qq Z.minus_one (Zabs_N z)
        end
-     | Qq n d => 
-       if N.eq_bool d N.zero then zero else 
-       match Z.compare Z.zero n with 
+     | Qq n d =>
+       if N.eq_bool d N.zero then zero else
+       match Z.compare Z.zero n with
          | Eq => zero
-         | Lt => 
-           match Z.compare n Z.one with 
+         | Lt =>
+           match Z.compare n Z.one with
              | Gt => Qq (Z_of_N d) (Zabs_N n)
              | _ => Qz (Z_of_N d)
            end
-         | Gt => 
-           match Z.compare n Z.minus_one with 
+         | Gt =>
+           match Z.compare n Z.minus_one with
              | Lt => Qq (Z.opp (Z_of_N d)) (Zabs_N n)
              | _ => Qz (Z.opp (Z_of_N d))
            end
@@ -861,74 +812,72 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct x as [ z | n d ].
  (* Qz z *)
  simpl.
- rewrite Zcompare_spec_alt; destr_zcompare; auto with qarith.
+ rewrite Z.spec_compare; destr_zcompare; auto with qarith.
  (* Qq n d *)
- simpl; nzsimpl; destr_neq_bool.
+ simpl; nzsimpl; destr_eqb.
  destr_zcompare; simpl; auto with qarith.
- destr_neq_bool; nzsimpl; auto with qarith.
+ destr_eqb; nzsimpl; auto with qarith.
  intros _ Hd; rewrite Hd; auto with qarith.
- destr_neq_bool; nzsimpl; auto with qarith.
+ destr_eqb; nzsimpl; auto with qarith.
  intros _ Hd; rewrite Hd; auto with qarith.
  (* 0 < n *)
  destr_zcompare; auto with qarith.
  destr_zcompare; nzsimpl; simpl; auto with qarith; intros.
- destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
+ destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
  rewrite H0; auto with qarith.
  romega.
  (* 0 > n *)
  destr_zcompare; nzsimpl; simpl; auto with qarith.
- destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
+ destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
  rewrite H0; auto with qarith.
  romega.
  Qed.
 
- Theorem strong_spec_inv_norm : forall x, Reduced x -> Reduced (inv_norm x).
+ Instance strong_spec_inv_norm x : Reduced x -> Reduced (inv_norm x).
  Proof.
- unfold Reduced. 
+ unfold Reduced.
  intros.
  destruct x as [ z | n d ].
  (* Qz *)
  simpl; nzsimpl.
  rewrite strong_spec_red, Qred_iff.
  destr_zcompare; simpl; nzsimpl; auto.
- destr_neq_bool; nzsimpl; simpl; auto.
- destr_neq_bool; nzsimpl; simpl; auto.
+ destr_eqb; nzsimpl; simpl; auto.
+ destr_eqb; nzsimpl; simpl; auto.
  (* Qq n d *)
  rewrite strong_spec_red, Qred_iff in H; revert H.
  simpl; nzsimpl.
- destr_neq_bool; nzsimpl; auto with qarith.
+ destr_eqb; nzsimpl; auto with qarith.
  destr_zcompare; simpl; nzsimpl; auto; intros.
  (* 0 < n *)
  destr_zcompare; simpl; nzsimpl; auto.
- destr_neq_bool; nzsimpl; simpl; auto.
+ destr_eqb; nzsimpl; simpl; auto.
  rewrite Zabs_eq; romega.
  intros _.
  rewrite strong_spec_norm; simpl; nzsimpl.
- destr_neq_bool; nzsimpl.
+ destr_eqb; nzsimpl.
  rewrite Zabs_eq; romega.
  intros _.
  rewrite Qred_iff.
  simpl.
  rewrite Zabs_eq; auto with zarith.
- rewrite N_to_Z2P in *; auto.
- rewrite Z2P_correct; auto with zarith.
- rewrite Zgcd_sym; auto.
+ rewrite Z2P_correct in *; auto.
+ rewrite Zgcd_comm; auto.
  (* 0 > n *)
- destr_neq_bool; nzsimpl; simpl; auto; intros.
+ destr_eqb; nzsimpl; simpl; auto; intros.
  destr_zcompare; simpl; nzsimpl; auto.
- destr_neq_bool; nzsimpl.
+ destr_eqb; nzsimpl.
  rewrite Zabs_non_eq; romega.
  intros _.
  rewrite strong_spec_norm; simpl; nzsimpl.
- destr_neq_bool; nzsimpl.
+ destr_eqb; nzsimpl.
  rewrite Zabs_non_eq; romega.
  intros _.
  rewrite Qred_iff.
  simpl.
- rewrite N_to_Z2P in *; auto.
- rewrite Z2P_correct; auto with zarith.
+ rewrite Z2P_correct in *; auto.
  intros.
- rewrite Zgcd_sym, Zgcd_Zabs, Zgcd_sym.
+ rewrite Zgcd_comm, Zgcd_Zabs, Zgcd_comm.
  apply Zis_gcd_gcd; auto with zarith.
  apply Zis_gcd_minus.
  rewrite Zopp_involutive, <- H1; apply Zgcd_is_gcd.
@@ -939,7 +888,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Theorem spec_div x y: [div x y] == [x] / [y].
  Proof.
- intros x y; unfold div; rewrite spec_mul; auto.
+ unfold div; rewrite spec_mul; auto.
  unfold Qdiv; apply Qmult_comp.
  apply Qeq_refl.
  apply spec_inv; auto.
@@ -949,14 +898,14 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Theorem spec_div_norm x y: [div_norm x y] == [x] / [y].
  Proof.
- intros x y; unfold div_norm; rewrite spec_mul_norm; auto.
+ unfold div_norm; rewrite spec_mul_norm; auto.
  unfold Qdiv; apply Qmult_comp.
  apply Qeq_refl.
  apply spec_inv_norm; auto.
  Qed.
- 
- Theorem strong_spec_div_norm : forall x y, 
-   Reduced x -> Reduced y -> Reduced (div_norm x y).
+
+ Instance strong_spec_div_norm x y
+   `(Reduced x, Reduced y) : Reduced (div_norm x y).
  Proof.
  intros; unfold div_norm.
  apply strong_spec_mul_norm; auto.
@@ -974,15 +923,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct x as [ z | n d ].
  simpl; rewrite Z.spec_square; red; auto.
  simpl.
- destr_neq_bool; nzsimpl; intros.
+ destr_eqb; nzsimpl; intros.
  apply Qeq_refl.
  rewrite N.spec_square in *; nzsimpl.
- contradict H; elim (Zmult_integral _ _ H0); auto.
+ elim (Zmult_integral _ _ H0); romega.
  rewrite N.spec_square in *; nzsimpl.
- rewrite H in H0; simpl in H0; elim H0; auto.
- assert (0 < N.to_Z d)%Z by (generalize (N.spec_pos d); romega).
- clear H H0.
- rewrite Z.spec_square, N.spec_square.  
+ rewrite H in H0; romega.
+ rewrite Z.spec_square, N.spec_square.
  red; simpl.
  rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto.
  apply Zmult_lt_0_compat; auto.
@@ -993,7 +940,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   | Qz zx => Qz (Z.power_pos zx p)
   | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p)
   end.
- 
+
  Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p.
  Proof.
  intros [ z | n d ] p; unfold power_pos.
@@ -1006,44 +953,42 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (* Qq *)
  simpl.
  rewrite Z.spec_power_pos.
- destr_neq_bool; nzsimpl; intros.
+ destr_eqb; nzsimpl; intros.
  apply Qeq_sym; apply Qpower_positive_0.
  rewrite N.spec_power_pos in *.
- assert (0 < N.to_Z d ^ ' p)%Z.
-  apply Zpower_gt_0; auto with zarith.
-  generalize (N.spec_pos d); romega.
+ assert (0 < N.to_Z d ^ ' p)%Z by
+  (apply Zpower_gt_0; auto with zarith).
  romega.
  rewrite N.spec_power_pos, H in *.
- rewrite Zpower_0_l in H0; [ elim H0; auto | discriminate ].
+ rewrite Zpower_0_l in H0; [romega|discriminate].
  rewrite Qpower_decomp.
  red; simpl; do 3 f_equal.
  rewrite Z2P_correct by (generalize (N.spec_pos d); romega).
  rewrite N.spec_power_pos. auto.
  Qed.
 
- Theorem strong_spec_power_pos : forall x p, 
-  Reduced x -> Reduced (power_pos x p).
+ Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p).
  Proof.
  destruct x as [z | n d]; simpl; intros.
  red; simpl; auto.
  red; simpl; intros.
  rewrite strong_spec_norm; simpl.
- destr_neq_bool; nzsimpl; intros.
+ destr_eqb; nzsimpl; intros.
  simpl; auto.
  rewrite Qred_iff.
  revert H.
  unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl.
- destr_neq_bool; nzsimpl; simpl; intros.
+ destr_eqb; nzsimpl; simpl; intros.
  rewrite N.spec_power_pos in H0.
- elim H0; rewrite H; rewrite Zpower_0_l; auto; discriminate.
- rewrite N_to_Z2P in *; auto.
+ rewrite H, Zpower_0_l in *; [romega|discriminate].
+ rewrite Z2P_correct in *; auto.
  rewrite N.spec_power_pos, Z.spec_power_pos; auto.
  rewrite Zgcd_1_rel_prime in *.
  apply rel_prime_Zpower; auto with zarith.
  Qed.
 
- Definition power (x : t) (z : Z) : t := 
-   match z with 
+ Definition power (x : t) (z : Z) : t :=
+   match z with
      | Z0 => one
      | Zpos p => power_pos x p
      | Zneg p => inv (power_pos x p)
@@ -1058,8 +1003,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite spec_inv, spec_power_pos; apply Qeq_refl.
  Qed.
 
- Definition power_norm (x : t) (z : Z) : t := 
-   match z with 
+ Definition power_norm (x : t) (z : Z) : t :=
+   match z with
      | Z0 => one
      | Zpos p => power_pos x p
      | Zneg p => inv_norm (power_pos x p)
@@ -1074,7 +1019,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite spec_inv_norm, spec_power_pos; apply Qeq_refl.
  Qed.
 
- Theorem strong_spec_power_norm : forall x z, 
+ Instance strong_spec_power_norm x z :
    Reduced x -> Reduced (power_norm x z).
  Proof.
  destruct z; simpl.
@@ -1087,7 +1032,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
 
  (** Interaction with [Qcanon.Qc] *)
- 
+
  Open Scope Qc_scope.
 
  Definition of_Qc q := of_Q (this q).
@@ -1102,7 +1047,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  unfold of_Qc; rewrite strong_spec_of_Q; auto.
  Qed.
 
- Lemma strong_spec_of_Qc_bis : forall q, Reduced (of_Qc q).
+ Instance strong_spec_of_Qc_bis q : Reduced (of_Qc q).
  Proof.
  intros; red; rewrite strong_spec_red, strong_spec_of_Qc.
  destruct q; simpl; auto.
@@ -1143,7 +1088,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_addc x y:
   [[add x y]] = [[x]] + [[y]].
  Proof.
- intros x y; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! ([x] + [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1157,7 +1102,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_add_normc x y:
   [[add_norm x y]] = [[x]] + [[y]].
  Proof.
- intros x y; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! ([x] + [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1168,7 +1113,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  apply Qplus_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
 
- Theorem spec_add_normc_bis : forall x y : Qc, 
+ Theorem spec_add_normc_bis : forall x y : Qc,
    [add_norm (of_Qc x) (of_Qc y)] = x+y.
  Proof.
  intros.
@@ -1180,18 +1125,18 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Theorem spec_subc x y:  [[sub x y]] = [[x]] - [[y]].
  Proof.
- intros x y; unfold sub; rewrite spec_addc; auto.
+ unfold sub; rewrite spec_addc; auto.
  rewrite spec_oppc; ring.
  Qed.
 
  Theorem spec_sub_normc x y:
    [[sub_norm x y]] = [[x]] - [[y]].
  Proof.
- intros x y; unfold sub_norm; rewrite spec_add_normc; auto.
+ unfold sub_norm; rewrite spec_add_normc; auto.
  rewrite spec_oppc; ring.
  Qed.
 
- Theorem spec_sub_normc_bis : forall x y : Qc, 
+ Theorem spec_sub_normc_bis : forall x y : Qc,
    [sub_norm (of_Qc x) (of_Qc y)] = x-y.
  Proof.
  intros.
@@ -1199,13 +1144,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite strong_spec_red.
  symmetry; apply (Qred_complete (x+(-y)%Qc)%Q).
  rewrite spec_sub_norm, ! strong_spec_of_Qc.
- unfold Qcopp, Q2Qc; rewrite Qred_correct; auto with qarith.
+ unfold Qcopp, Q2Qc, this. rewrite Qred_correct ; auto with qarith.
  Qed.
 
  Theorem spec_mulc x y:
   [[mul x y]] = [[x]] * [[y]].
  Proof.
- intros x y; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! ([x] * [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1219,7 +1164,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_mul_normc x y:
    [[mul_norm x y]] = [[x]] * [[y]].
  Proof.
- intros x y; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! ([x] * [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1230,7 +1175,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
 
- Theorem spec_mul_normc_bis : forall x y : Qc, 
+ Theorem spec_mul_normc_bis : forall x y : Qc,
    [mul_norm (of_Qc x) (of_Qc y)] = x*y.
  Proof.
  intros.
@@ -1243,7 +1188,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_invc x:
    [[inv x]] =  /[[x]].
  Proof.
- intros x; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! (/[x])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1257,7 +1202,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_inv_normc x:
    [[inv_norm x]] =  /[[x]].
  Proof.
- intros x; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! (/[x])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1268,7 +1213,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  apply Qinv_comp; apply Qeq_sym; apply Qred_correct.
  Qed.
 
- Theorem spec_inv_normc_bis : forall x : Qc, 
+ Theorem spec_inv_normc_bis : forall x : Qc,
    [inv_norm (of_Qc x)] = /x.
  Proof.
  intros.
@@ -1280,19 +1225,19 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]].
  Proof.
- intros x y; unfold div; rewrite spec_mulc; auto.
+ unfold div; rewrite spec_mulc; auto.
  unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto.
- apply spec_invc; auto. 
+ apply spec_invc; auto.
  Qed.
 
  Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]].
  Proof.
- intros x y; unfold div_norm; rewrite spec_mul_normc; auto.
+ unfold div_norm; rewrite spec_mul_normc; auto.
  unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto.
  apply spec_inv_normc; auto.
  Qed.
 
- Theorem spec_div_normc_bis : forall x y : Qc, 
+ Theorem spec_div_normc_bis : forall x y : Qc,
    [div_norm (of_Qc x) (of_Qc y)] = x/y.
  Proof.
  intros.
@@ -1300,12 +1245,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  rewrite strong_spec_red.
  symmetry; apply (Qred_complete (x*(/y)%Qc)%Q).
  rewrite spec_div_norm, ! strong_spec_of_Qc.
- unfold Qcinv, Q2Qc; rewrite Qred_correct; auto with qarith.
+ unfold Qcinv, Q2Qc, this; rewrite Qred_correct; auto with qarith.
  Qed.
 
- Theorem spec_squarec x: [[square x]] =  [[x]]^2.
+ Theorem spec_squarec x: [[square x]] = [[x]]^2.
  Proof.
- intros x; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! ([x]^2)).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1322,7 +1267,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_power_posc x p:
    [[power_pos x p]] = [[x]] ^ nat_of_P p.
  Proof.
- intros x p; unfold to_Qc.
+ unfold to_Qc.
  apply trans_equal with (!! ([x]^Zpos p)).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v
index be9b2d4e..10d0189a 100644
--- a/theories/Numbers/Rational/SpecViaQ/QSig.v
+++ b/theories/Numbers/Rational/SpecViaQ/QSig.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: QSig.v 11207 2008-07-04 16:50:32Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import QArith Qpower.
+Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax.
 
 Open Scope Q_scope.
 
@@ -23,75 +23,203 @@ Module Type QType.
  Parameter t : Type.
 
  Parameter to_Q : t -> Q.
- Notation "[ x ]" := (to_Q x).
+ Local Notation "[ x ]" := (to_Q x).
 
  Definition eq x y := [x] == [y].
+ Definition lt x y := [x] < [y].
+ Definition le x y := [x] <= [y].
 
  Parameter of_Q : Q -> t.
  Parameter spec_of_Q: forall x, to_Q (of_Q x) == x.
 
+ Parameter red : t -> t.
+ Parameter compare : t -> t -> comparison.
+ Parameter eq_bool : t -> t -> bool.
+ Parameter max : t -> t -> t.
+ Parameter min : t -> t -> t.
  Parameter zero : t.
  Parameter one : t.
  Parameter minus_one : t.
+ Parameter add : t -> t -> t.
+ Parameter sub : t -> t -> t.
+ Parameter opp : t -> t.
+ Parameter mul : t -> t -> t.
+ Parameter square : t -> t.
+ Parameter inv : t -> t.
+ Parameter div : t -> t -> t.
+ Parameter power : t -> Z -> t.
 
+ Parameter spec_red : forall x, [red x] == [x].
+ Parameter strong_spec_red : forall x, [red x] = Qred [x].
+ Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]).
+ Parameter spec_eq_bool : forall x y, eq_bool x y = Qeq_bool [x] [y].
+ Parameter spec_max : forall x y, [max x y] == Qmax [x] [y].
+ Parameter spec_min : forall x y, [min x y] == Qmin [x] [y].
  Parameter spec_0: [zero] == 0.
  Parameter spec_1: [one] == 1.
  Parameter spec_m1: [minus_one] == -(1).
+ Parameter spec_add: forall x y, [add x y] == [x] + [y].
+ Parameter spec_sub: forall x y, [sub x y] == [x] - [y].
+ Parameter spec_opp: forall x, [opp x] == - [x].
+ Parameter spec_mul: forall x y, [mul x y] == [x] * [y].
+ Parameter spec_square: forall x, [square x] == [x] ^ 2.
+ Parameter spec_inv : forall x, [inv x] == / [x].
+ Parameter spec_div: forall x y, [div x y] == [x] / [y].
+ Parameter spec_power: forall x z, [power x z] == [x] ^ z.
 
- Parameter compare : t -> t -> comparison.
+End QType.
 
- Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]).
+(** NB: several of the above functions come with [..._norm] variants
+     that expect reduced arguments and return reduced results. *)
 
- Definition lt n m := compare n m = Lt.
- Definition le n m := compare n m <> Gt.
- Definition min n m := match compare n m with Gt => m | _ => n end.
- Definition max n m := match compare n m with Lt => m | _ => n end.
+(** TODO : also speak of specifications via Qcanon ... *)
 
- Parameter eq_bool : t -> t -> bool.
- 
- Parameter spec_eq_bool : forall x y, 
-  if eq_bool x y then [x]==[y] else ~([x]==[y]).
+Module Type QType_Notation (Import Q : QType).
+ Notation "[ x ]" := (to_Q x).
+ Infix "=="  := eq (at level 70).
+ Notation "x != y" := (~x==y) (at level 70).
+ Infix "<=" := le.
+ Infix "<" := lt.
+ Notation "0" := zero.
+ Notation "1" := one.
+ Infix "+" := add.
+ Infix "-" := sub.
+ Infix "*" := mul.
+ Notation "- x" := (opp x).
+ Infix "/" := div.
+ Notation "/ x" := (inv x).
+ Infix "^" := power.
+End QType_Notation.
 
- Parameter red : t -> t.
- 
- Parameter spec_red : forall x, [red x] == [x].
- Parameter strong_spec_red : forall x, [red x] = Qred [x].
+Module Type QType' := QType <+ QType_Notation.
 
- Parameter add : t -> t -> t.
 
- Parameter spec_add: forall x y, [add x y] == [x] + [y].
+Module QProperties (Import Q : QType').
 
- Parameter sub : t -> t -> t.
+(** Conversion to Q *)
 
- Parameter spec_sub: forall x y, [sub x y] == [x] - [y].
+Hint Rewrite
+ spec_red spec_compare spec_eq_bool spec_min spec_max
+ spec_add spec_sub spec_opp spec_mul spec_square spec_inv spec_div
+ spec_power : qsimpl.
+Ltac qify := unfold eq, lt, le in *; autorewrite with qsimpl;
+ try rewrite spec_0 in *; try rewrite spec_1 in *; try rewrite spec_m1 in *.
 
- Parameter opp : t -> t.
+(** NB: do not add [spec_0] in the autorewrite database. Otherwise,
+    after instanciation in BigQ, this lemma become convertible to 0=0,
+    and autorewrite loops. Idem for [spec_1] and [spec_m1] *)
 
- Parameter spec_opp: forall x, [opp x] == - [x].
+(** Morphisms *)
 
- Parameter mul : t -> t -> t.
+Ltac solve_wd1 := intros x x' Hx; qify; now rewrite Hx.
+Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy.
 
- Parameter spec_mul: forall x y, [mul x y] == [x] * [y].
+Local Obligation Tactic := solve_wd2 || solve_wd1.
 
- Parameter square : t -> t.
+Instance : Measure to_Q.
+Instance eq_equiv : Equivalence eq.
 
- Parameter spec_square: forall x, [square x] == [x] ^ 2.
+Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
+Program Instance le_wd : Proper (eq==>eq==>iff) le.
+Program Instance red_wd : Proper (eq==>eq) red.
+Program Instance compare_wd : Proper (eq==>eq==>Logic.eq) compare.
+Program Instance eq_bool_wd : Proper (eq==>eq==>Logic.eq) eq_bool.
+Program Instance min_wd : Proper (eq==>eq==>eq) min.
+Program Instance max_wd : Proper (eq==>eq==>eq) max.
+Program Instance add_wd : Proper (eq==>eq==>eq) add.
+Program Instance sub_wd : Proper (eq==>eq==>eq) sub.
+Program Instance opp_wd : Proper (eq==>eq) opp.
+Program Instance mul_wd : Proper (eq==>eq==>eq) mul.
+Program Instance square_wd : Proper (eq==>eq) square.
+Program Instance inv_wd : Proper (eq==>eq) inv.
+Program Instance div_wd : Proper (eq==>eq==>eq) div.
+Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power.
 
- Parameter inv : t -> t.
+(** Let's implement [HasCompare] *)
 
- Parameter spec_inv : forall x, [inv x] == / [x].
+Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed.
 
- Parameter div : t -> t -> t.
+(** Let's implement [TotalOrder] *)
 
- Parameter spec_div: forall x y, [div x y] == [x] / [y].
+Definition lt_compat := lt_wd.
+Instance lt_strorder : StrictOrder lt.
 
- Parameter power : t -> Z -> t.
+Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y.
+Proof. intros. qify. apply Qle_lteq. Qed.
 
- Parameter spec_power: forall x z, [power x z] == [x] ^ z.
+Lemma lt_total : forall x y, x<y \/ x==y \/ y<x.
+Proof. intros. destruct (compare_spec x y); auto. Qed.
 
-End QType.
+(** Let's implement [HasEqBool] *)
 
-(** NB: several of the above functions come with [..._norm] variants
-     that expect reduced arguments and return reduced results. *)
+Definition eqb := eq_bool.
 
-(** TODO : also speak of specifications via Qcanon ... *)
+Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
+Proof. intros. qify. apply Qeq_bool_iff. Qed.
+
+Lemma eqb_correct : forall x y, eq_bool x y = true -> x == y.
+Proof. now apply eqb_eq. Qed.
+
+Lemma eqb_complete : forall x y, x == y -> eq_bool x y = true.
+Proof. now apply eqb_eq. Qed.
+
+(** Let's implement [HasMinMax] *)
+
+Lemma max_l : forall x y, y<=x -> max x y == x.
+Proof. intros x y. qify. apply Qminmax.Q.max_l. Qed.
+
+Lemma max_r : forall x y, x<=y -> max x y == y.
+Proof. intros x y. qify. apply Qminmax.Q.max_r. Qed.
+
+Lemma min_l : forall x y, x<=y -> min x y == x.
+Proof. intros x y. qify. apply Qminmax.Q.min_l. Qed.
+
+Lemma min_r : forall x y, y<=x -> min x y == y.
+Proof. intros x y. qify. apply Qminmax.Q.min_r. Qed.
+
+(** Q is a ring *)
+
+Lemma add_0_l : forall x, 0+x == x.
+Proof. intros. qify. apply Qplus_0_l. Qed.
+
+Lemma add_comm : forall x y, x+y == y+x.
+Proof. intros. qify. apply Qplus_comm. Qed.
+
+Lemma add_assoc : forall x y z, x+(y+z) == x+y+z.
+Proof. intros. qify. apply Qplus_assoc. Qed.
+
+Lemma mul_1_l : forall x, 1*x == x.
+Proof. intros. qify. apply Qmult_1_l. Qed.
+
+Lemma mul_comm : forall x y, x*y == y*x.
+Proof. intros. qify. apply Qmult_comm. Qed.
+
+Lemma mul_assoc : forall x y z, x*(y*z) == x*y*z.
+Proof. intros. qify. apply Qmult_assoc. Qed.
+
+Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z.
+Proof. intros. qify. apply Qmult_plus_distr_l. Qed.
+
+Lemma sub_add_opp : forall x y, x-y == x+(-y).
+Proof. intros. qify. now unfold Qminus. Qed.
+
+Lemma add_opp_diag_r : forall x, x+(-x) == 0.
+Proof. intros. qify. apply Qplus_opp_r. Qed.
+
+(** Q is a field *)
+
+Lemma neq_1_0 : 1!=0.
+Proof. intros. qify. apply Q_apart_0_1. Qed.
+
+Lemma div_mul_inv : forall x y, x/y == x*(/y).
+Proof. intros. qify. now unfold Qdiv. Qed.
+
+Lemma mul_inv_diag_l : forall x, x!=0 -> /x * x == 1.
+Proof. intros x. qify. rewrite Qmult_comm. apply Qmult_inv_r. Qed.
+
+End QProperties.
+
+Module QTypeExt (Q : QType)
+ <: QType <: TotalOrder <: HasCompare Q <: HasMinMax Q <: HasEqBool Q
+ := Q <+ QProperties.
\ No newline at end of file
diff --git a/theories/Numbers/vo.itarget b/theories/Numbers/vo.itarget
new file mode 100644
index 00000000..175a15e9
--- /dev/null
+++ b/theories/Numbers/vo.itarget
@@ -0,0 +1,70 @@
+BigNumPrelude.vo
+Cyclic/Abstract/CyclicAxioms.vo
+Cyclic/Abstract/NZCyclic.vo
+Cyclic/DoubleCyclic/DoubleAdd.vo
+Cyclic/DoubleCyclic/DoubleBase.vo
+Cyclic/DoubleCyclic/DoubleCyclic.vo
+Cyclic/DoubleCyclic/DoubleDivn1.vo
+Cyclic/DoubleCyclic/DoubleDiv.vo
+Cyclic/DoubleCyclic/DoubleLift.vo
+Cyclic/DoubleCyclic/DoubleMul.vo
+Cyclic/DoubleCyclic/DoubleSqrt.vo
+Cyclic/DoubleCyclic/DoubleSub.vo
+Cyclic/DoubleCyclic/DoubleType.vo
+Cyclic/Int31/Int31.vo
+Cyclic/Int31/Cyclic31.vo
+Cyclic/Int31/Ring31.vo
+Cyclic/ZModulo/ZModulo.vo
+Integer/Abstract/ZAddOrder.vo
+Integer/Abstract/ZAdd.vo
+Integer/Abstract/ZAxioms.vo
+Integer/Abstract/ZBase.vo
+Integer/Abstract/ZLt.vo
+Integer/Abstract/ZMulOrder.vo
+Integer/Abstract/ZMul.vo
+Integer/Abstract/ZSgnAbs.vo
+Integer/Abstract/ZProperties.vo
+Integer/Abstract/ZDivFloor.vo
+Integer/Abstract/ZDivTrunc.vo
+Integer/Abstract/ZDivEucl.vo
+Integer/BigZ/BigZ.vo
+Integer/BigZ/ZMake.vo
+Integer/Binary/ZBinary.vo
+Integer/NatPairs/ZNatPairs.vo
+Integer/SpecViaZ/ZSig.vo
+Integer/SpecViaZ/ZSigZAxioms.vo
+NaryFunctions.vo
+NatInt/NZAddOrder.vo
+NatInt/NZAdd.vo
+NatInt/NZAxioms.vo
+NatInt/NZBase.vo
+NatInt/NZMulOrder.vo
+NatInt/NZMul.vo
+NatInt/NZOrder.vo
+NatInt/NZProperties.vo
+NatInt/NZDomain.vo
+NatInt/NZDiv.vo
+Natural/Abstract/NAddOrder.vo
+Natural/Abstract/NAdd.vo
+Natural/Abstract/NAxioms.vo
+Natural/Abstract/NBase.vo
+Natural/Abstract/NDefOps.vo
+Natural/Abstract/NIso.vo
+Natural/Abstract/NMulOrder.vo
+Natural/Abstract/NOrder.vo
+Natural/Abstract/NStrongRec.vo
+Natural/Abstract/NSub.vo
+Natural/Abstract/NProperties.vo
+Natural/Abstract/NDiv.vo
+Natural/BigN/BigN.vo
+Natural/BigN/Nbasic.vo
+Natural/BigN/NMake_gen.vo
+Natural/BigN/NMake.vo
+Natural/Binary/NBinary.vo
+Natural/Peano/NPeano.vo
+Natural/SpecViaZ/NSigNAxioms.vo
+Natural/SpecViaZ/NSig.vo
+NumPrelude.vo
+Rational/BigQ/BigQ.vo
+Rational/BigQ/QMake.vo
+Rational/SpecViaQ/QSig.vo
diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v
index 29494069..0a4b15d2 100644
--- a/theories/Program/Basics.v
+++ b/theories/Program/Basics.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,15 +6,16 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Basics.v 11709 2008-12-20 11:42:15Z msozeau $ *)
+(* $Id$ *)
 
 (** Standard functions and combinators.
-   
-   Proofs about them require functional extensionality and can be found in [Combinators].
+
+   Proofs about them require functional extensionality and can be found
+   in [Combinators].
 
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - Université Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
 (** The polymorphic identity function is defined in [Datatypes]. *)
 
@@ -21,12 +23,12 @@ Implicit Arguments id [[A]].
 
 (** Function composition. *)
 
-Definition compose {A B C} (g : B -> C) (f : A -> B) := 
+Definition compose {A B C} (g : B -> C) (f : A -> B) :=
   fun x : A => g (f x).
 
 Hint Unfold compose.
 
-Notation " g ∘ f " := (compose g f)  
+Notation " g ∘ f " := (compose g f)
   (at level 40, left associativity) : program_scope.
 
 Open Local Scope program_scope.
diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v
index ae9749de..31661b9d 100644
--- a/theories/Program/Combinators.v
+++ b/theories/Program/Combinators.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,13 +6,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Combinators.v 11709 2008-12-20 11:42:15Z msozeau $ *)
+(* $Id$ *)
 
-(** Proofs about standard combinators, exports functional extensionality.
+(** * Proofs about standard combinators, exports functional extensionality.
 
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
 Require Import Coq.Program.Basics.
 Require Export FunctionalExtensionality.
@@ -34,7 +35,7 @@ Proof.
   symmetry ; apply eta_expansion.
 Qed.
 
-Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), 
+Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D),
   h ∘ g ∘ f = h ∘ (g ∘ f).
 Proof.
   intros.
diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v
index 9681d543..79c9bec5 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -1,4 +1,3 @@
-(* -*- coq-prog-name: "~/research/coq/trunk/bin/coqtop.byte"; coq-prog-args: ("-emacs-U"); compile-command: "make -C ../.. TIME='time'" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -7,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Equality.v 12073 2009-04-08 21:04:42Z msozeau $ i*)
+(*i $Id$ i*)
 
 (** Tactics related to (dependent) equality and proof irrelevance. *)
 
@@ -16,17 +15,35 @@ Require Export JMeq.
 
 Require Import Coq.Program.Tactics.
 
+Ltac is_ground_goal := 
+  match goal with
+    |- ?T => is_ground T
+  end.
+
+(** Try to find a contradiction. *)
+
+Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso.
+
+(** We will use the [block] definition to separate the goal from the 
+   equalities generated by the tactic. *)
+
+Definition block {A : Type} (a : A) := a.
+
+Ltac block_goal := match goal with [ |- ?T ] => change (block T) end.
+Ltac unblock_goal := unfold block in *.
+
 (** Notation for heterogenous equality. *)
 
-Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level).
+Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity).
 
-(** Notation for the single element of [x = x] *)
+(** Notation for the single element of [x = x] and [x ~= x]. *)
 
-Notation "'refl'" := (@refl_equal _ _).
+Implicit Arguments eq_refl [[A] [x]].
+Implicit Arguments JMeq_refl [[A] [x]].
 
 (** Do something on an heterogeneous equality appearing in the context. *)
 
-Ltac on_JMeq tac := 
+Ltac on_JMeq tac :=
   match goal with
     | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H
   end.
@@ -44,17 +61,17 @@ Ltac simpl_JMeq := repeat simpl_one_JMeq.
 
 Ltac simpl_one_dep_JMeq :=
   on_JMeq
-  ltac:(fun H => let H' := fresh "H" in 
+  ltac:(fun H => let H' := fresh "H" in
     assert (H' := JMeq_eq H)).
 
 Require Import Eqdep.
 
-(** Simplify dependent equality using sigmas to equality of the second projections if possible. 
+(** Simplify dependent equality using sigmas to equality of the second projections if possible.
    Uses UIP. *)
 
 Ltac simpl_existT :=
   match goal with
-    [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => 
+    [ H : existT _ ?x _ = existT _ ?x _ |- _ ] =>
     let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H
   end.
 
@@ -64,20 +81,20 @@ Ltac simpl_existTs := repeat simpl_existT.
 
 Ltac elim_eq_rect :=
   match goal with
-    | [ |- ?t ] => 
+    | [ |- ?t ] =>
       match t with
-        | context [ @eq_rect _ _ _ _ _ ?p ] => 
-          let P := fresh "P" in 
-            set (P := p); simpl in P ; 
+        | context [ @eq_rect _ _ _ _ _ ?p ] =>
+          let P := fresh "P" in
+            set (P := p); simpl in P ;
 	      ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
-        | context [ @eq_rect _ _ _ _ _ ?p _ ] => 
-          let P := fresh "P" in 
-            set (P := p); simpl in P ; 
+        | context [ @eq_rect _ _ _ _ _ ?p _ ] =>
+          let P := fresh "P" in
+            set (P := p); simpl in P ;
 	      ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
       end
   end.
 
-(** Rewrite using uniqueness of indentity proofs [H = refl_equal X]. *)
+(** Rewrite using uniqueness of indentity proofs [H = eq_refl]. *)
 
 Ltac simpl_uip :=
   match goal with
@@ -90,18 +107,18 @@ Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl)
 
 (** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *)
 
-Ltac abstract_eq_hyp H' p := 
+Ltac abstract_eq_hyp H' p :=
   let ty := type of p in
   let tyred := eval simpl in ty in
-    match tyred with  
-      ?X = ?Y => 
-      match goal with 
+    match tyred with
+      ?X = ?Y =>
+      match goal with
         | [ H : X = Y |- _ ] => fail 1
         | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H'
       end
     end.
 
-(** Apply the tactic tac to proofs of equality appearing as coercion arguments. 
+(** Apply the tactic tac to proofs of equality appearing as coercion arguments.
    Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators.
    *)
 
@@ -109,7 +126,7 @@ Ltac on_coerce_proof tac T :=
   match T with
     | context [ eq_rect _ _ _ _ ?p ] => tac p
   end.
-  
+
 Ltac on_coerce_proof_gl tac :=
   match goal with
     [ |- ?T ] => on_coerce_proof tac T
@@ -120,17 +137,17 @@ Ltac on_coerce_proof_gl tac :=
 Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p).
 
 Ltac abstract_eq_proofs := repeat abstract_eq_proof.
-  
-(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality 
+
+(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality
    in the goal become convertible. *)
 
 Ltac pi_eq_proof_hyp p :=
   let ty := type of p in
   let tyred := eval simpl in ty in
   match tyred with
-    ?X = ?Y => 
-    match goal with 
-      | [ H : X = Y |- _ ] => 
+    ?X = ?Y =>
+    match goal with
+      | [ H : X = Y |- _ ] =>
         match p with
           | H => fail 2
           | _ => rewrite (proof_irrelevance (X = Y) p H)
@@ -152,8 +169,21 @@ Ltac clear_eq_proofs :=
 
 Hint Rewrite <- eq_rect_eq : refl_id.
 
-(** The refl_id database should be populated with lemmas of the form
-   [coerce_* t (refl_equal _) = t]. *)
+(** The [refl_id] database should be populated with lemmas of the form
+   [coerce_* t eq_refl = t]. *)
+
+Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl.
+Proof. intros. apply proof_irrelevance. Qed.
+
+Lemma UIP_refl_refl : Π A (x : A),
+  Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl.
+Proof. intros. apply UIP_refl. Qed.
+
+Lemma inj_pairT2_refl : Π A (x : A) (P : A -> Type) (p : P x),
+  Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl.
+Proof. intros. apply UIP_refl. Qed.
+
+Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id.
 
 Ltac rewrite_refl_id := autorewrite with refl_id.
 
@@ -162,82 +192,49 @@ Ltac rewrite_refl_id := autorewrite with refl_id.
 Ltac clear_eq_ctx :=
   rewrite_refl_id ; clear_eq_proofs.
 
-(** Reapeated elimination of [eq_rect] applications. 
+(** Reapeated elimination of [eq_rect] applications.
    Abstracting equalities makes it run much faster than an naive implementation. *)
 
-Ltac simpl_eqs := 
+Ltac simpl_eqs :=
   repeat (elim_eq_rect ; simpl ; clear_eq_ctx).
 
 (** Clear unused reflexivity proofs. *)
 
-Ltac clear_refl_eq := 
+Ltac clear_refl_eq :=
   match goal with [ H : ?X = ?X |- _ ] => clear H end.
 Ltac clear_refl_eqs := repeat clear_refl_eq.
 
 (** Clear unused equality proofs. *)
 
-Ltac clear_eq := 
+Ltac clear_eq :=
   match goal with [ H : _ = _ |- _ ] => clear H end.
 Ltac clear_eqs := repeat clear_eq.
 
 (** Combine all the tactics to simplify goals containing coercions. *)
 
-Ltac simplify_eqs := 
-  simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ;  
+Ltac simplify_eqs :=
+  simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ;
     try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id.
 
 (** A tactic that tries to remove trivial equality guards in induction hypotheses coming
    from [dependent induction]/[generalize_eqs] invocations. *)
 
-Ltac simpl_IH_eq H :=
-  match type of H with
-    | @JMeq _ ?x _ _ -> _ =>
-      refine_hyp (H (JMeq_refl x))
-    | _ -> @JMeq _ ?x _ _ -> _ =>
-      refine_hyp (H _ (JMeq_refl x))
-    | _ -> _ -> @JMeq _ ?x _ _ -> _ =>
-      refine_hyp (H _ _ (JMeq_refl x))
-    | _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ =>
-      refine_hyp (H _ _ _ (JMeq_refl x))
-    | _ -> _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ =>
-      refine_hyp (H _ _ _ _ (JMeq_refl x))
-    | _ -> _ -> _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ =>
-      refine_hyp (H _ _ _ _ _ (JMeq_refl x))
-    | ?x = _ -> _ =>
-      refine_hyp (H (refl_equal x))
-    | _ -> ?x = _ -> _ =>
-      refine_hyp (H _ (refl_equal x))
-    | _ -> _ -> ?x = _ -> _ =>
-      refine_hyp (H _ _ (refl_equal x))
-    | _ -> _ -> _ -> ?x = _ -> _ =>
-      refine_hyp (H _ _ _ (refl_equal x))
-    | _ -> _ -> _ -> _ -> ?x = _ -> _ =>
-      refine_hyp (H _ _ _ _ (refl_equal x))
-    | _ -> _ -> _ -> _ -> _ -> ?x = _ -> _ =>
-      refine_hyp (H _ _ _ _ _ (refl_equal x))
-  end.
-
-Ltac simpl_IH_eqs H := repeat simpl_IH_eq H.
-
-Ltac do_simpl_IHs_eqs := 
+Ltac simplify_IH_hyps := repeat
   match goal with
-    | [ H : context [ @JMeq _ _ _ _ -> _ ] |- _ ] => progress (simpl_IH_eqs H)
-    | [ H : context [ _ = _ -> _ ] |- _ ] => progress (simpl_IH_eqs H)
+    | [ hyp : _ |- _ ] => specialize_eqs hyp
   end.
 
-Ltac simpl_IHs_eqs := repeat do_simpl_IHs_eqs.
-
 (** We split substitution tactics in the two directions depending on which 
    names we want to keep corresponding to the generalization performed by the
    [generalize_eqs] tactic. *)
 
 Ltac subst_left_no_fail :=
-  repeat (match goal with 
+  repeat (match goal with
             [ H : ?X = ?Y |- _ ] => subst X
           end).
 
 Ltac subst_right_no_fail :=
-  repeat (match goal with 
+  repeat (match goal with
             [ H : ?X = ?Y |- _ ] => subst Y
           end).
 
@@ -251,32 +248,15 @@ 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 ; simpl_IHs_eqs.
+  simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.
 
 Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; 
-  simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs.
+  simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.
 
 Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; 
-  simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs.
-
-(** Support for the [Equations] command.
-   These tactics implement the necessary machinery to solve goals produced by the 
-   [Equations] command relative to dependent pattern-matching. 
-   It is completely inspired from the "Eliminating Dependent Pattern-Matching" paper by
-   Goguen, McBride and McKinna. *)
-
-
-(** The NoConfusionPackage class provides a method for making progress on proving a property
-   [P] implied by an equality on an inductive type [I]. The type of [noConfusion] for a given
-   [P] should be of the form [ Π Δ, (x y : I Δ) (x = y) -> NoConfusion P x y ], where 
-   [NoConfusion P x y] for constructor-headed [x] and [y] will give a formula ending in [P].
-   This gives a general method for simplifying by discrimination or injectivity of constructors.
-   
-   Some actual instances are defined later in the file using the more primitive [discriminate] and
-   [injection] tactics on which we can always fall back.
-   *)
-  
-Class NoConfusionPackage (I : Type) := { NoConfusion : Π P : Prop, Type ; noConfusion : Π P, NoConfusion P }.
+  simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.
+
+Ltac blocked t := block_goal ; t ; unblock_goal.
 
 (** The [DependentEliminationPackage] provides the default dependent elimination principle to
    be used by the [equations] resolver. It is especially useful to register the dependent elimination
@@ -287,30 +267,18 @@ Class DependentEliminationPackage (A : Type) :=
 
 (** A higher-order tactic to apply a registered eliminator. *)
 
-Ltac elim_tac tac p := 
+Ltac elim_tac tac p :=
   let ty := type of p in
   let eliminator := eval simpl in (elim (A:=ty)) in
     tac p eliminator.
 
-(** Specialization to do case analysis or induction. 
-   Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register 
+(** Specialization to do case analysis or induction.
+   Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register
    generated induction principles. *)
 
 Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p.
 Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p.
 
-(** The [BelowPackage] class provides the definition of a [Below] predicate for some datatype,
-   allowing to talk about course-of-value recursion on it. *)
-
-Class BelowPackage (A : Type) := {
-  Below : A -> Type ;
-  below : Π (a : A), Below a }.
-
-(** The [Recursor] class defines a recursor on a type, based on some definition of [Below]. *)
-
-Class Recursor (A : Type) (BP : BelowPackage A) := 
-  { rec_type : A -> Type ; rec : Π (a : A), rec_type a }.
-
 (** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *)
 
 Lemma solution_left : Π A (B : A -> Type) (t : A), B t -> (Π x, x = t -> B x).
@@ -333,57 +301,43 @@ Lemma simplification_existT1 : Π A (P : A -> Type) B (p q : A) (x : P p) (y : P
   (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B).
 Proof. intros. injection H. intros ; auto. Defined.
   
-Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B (refl_equal x) -> (Π p : x = x, B p).
+Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B eq_refl -> (Π p : x = x, B p).
 Proof. intros. rewrite (UIP_refl A). assumption. Defined.
 
-(** This hint database and the following tactic can be used with [autosimpl] to 
+(** This hint database and the following tactic can be used with [autounfold] to 
    unfold everything to [eq_rect]s. *)
 
 Hint Unfold solution_left solution_right deletion simplification_heq
-  simplification_existT1 simplification_existT2
-  eq_rect_r eq_rec eq_ind : equations.
-
-(** Simply unfold as much as possible. *)
-
-Ltac unfold_equations := repeat progress autosimpl with equations.
-
-(** The tactic [simplify_equations] is to be used when a program generated using [Equations] 
-   is in the goal. It simplifies it as much as possible, possibly using [K] if needed. *) 
-
-Ltac simplify_equations := repeat (unfold_equations ; simplify_eqs). 
-
-(** We will use the [block_induction] definition to separate the goal from the 
-   equalities generated by the tactic. *)
-
-Definition block_dep_elim {A : Type} (a : A) := a.
+  simplification_existT1 simplification_existT2 simplification_K
+  eq_rect_r eq_rec eq_ind : dep_elim.
 
-(** Using these we can make a simplifier that will perform the unification 
+(** Using these we can make a simplifier that will perform the unification
    steps needed to put the goal in normalised form (provided there are only
    constructor forms). Compare with the lemma 16 of the paper.
-   We don't have a [noCycle] procedure yet. *) 
+   We don't have a [noCycle] procedure yet. *)
 
 Ltac simplify_one_dep_elim_term c :=
   match c with
     | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _)
     | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _)
-    | eq (existT _ _ _) (existT _ _ _) -> _ => 
+    | eq (existT _ _ _) (existT _ _ _) -> _ =>
       refine (simplification_existT2 _ _ _ _ _ _ _) ||
         refine (simplification_existT1 _ _ _ _ _ _ _ _)
     | ?x = ?y -> _ => (* variables case *)
       (let hyp := fresh in intros hyp ;
-        move hyp before x ;
-          generalize dependent x ; refine (solution_left _ _ _ _) ; intros until 0) ||
+        move hyp before x ; revert_until hyp ; generalize dependent x ;
+          refine (solution_left _ _ _ _)(*  ; intros until 0 *)) ||
       (let hyp := fresh in intros hyp ;
-        move hyp before y ;
-          generalize dependent y ; refine (solution_right _ _ _ _) ; intros until 0)
-    | @eq ?A ?t ?u -> ?P => apply (noConfusion (I:=A) P)
+        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)
     | ?t = ?u -> _ => let hyp := fresh in
-      intros hyp ; elimtype False ; discriminate
+      intros hyp ; exfalso ; discriminate
     | ?x = ?y -> _ => let hyp := fresh in
       intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ;
         case hyp ; clear hyp
-    | block_dep_elim ?T => fail 1 (* Do not put any part of the rhs in the hyps *)
+    | block ?T => fail 1 (* Do not put any part of the rhs in the hyps *)
+    | forall x, _ => intro x || (let H := fresh x in rename x into H ; intro x) (* Try to keep original names *)
     | _ => intro
   end.
 
@@ -397,176 +351,103 @@ Ltac simplify_one_dep_elim :=
 
 Ltac simplify_dep_elim := repeat simplify_one_dep_elim.
 
-(** To dependent elimination on some hyp. *)
-
-Ltac depelim id :=
-  generalize_eqs id ; destruct id ; simplify_dep_elim.
-
 (** Do dependent elimination of the last hypothesis, but not simplifying yet
    (used internally). *)
 
 Ltac destruct_last :=
   on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id).
 
-(** The rest is support tactics for the [Equations] command. *)
-
-(** Notation for inaccessible patterns. *)
-
-Definition inaccessible_pattern {A : Type} (t : A) := t.
-
-Notation "?( t )" := (inaccessible_pattern t).
-
-(** To handle sections, we need to separate the context in two parts:
-   variables introduced by the section and the rest. We introduce a dummy variable 
-   between them to indicate that. *)
-
-CoInductive end_of_section := the_end_of_the_section.
-
-Ltac set_eos := let eos := fresh "eos" in 
-  assert (eos:=the_end_of_the_section).
+Ltac introduce p := first [
+  match p with _ => (* Already there, generalize dependent hyps *)
+    generalize dependent p ; intros p
+  end
+  | intros until p | intros until 1 | intros ].
 
-(** We have a specialized [reverse_local] tactic to reverse the goal until the begining of the
-   section variables *)
-
-Ltac reverse_local :=
-  match goal with
-    | [ H : ?T |- _ ] => 
-      match T with
-        | end_of_section => idtac | _ => revert H ; reverse_local end
-    | _ => idtac
-  end.
-
-(** Do as much as possible to apply a method, trying to get the arguments right.
-   !!Unsafe!! We use [auto] for the [_nocomp] variant of [Equations], in which case some 
-   non-dependent arguments of the method can remain after [apply]. *)
-
-Ltac simpl_intros m := ((apply m || refine m) ; auto) || (intro ; simpl_intros m).
-
-(** Hopefully the first branch suffices. *)
-
-Ltac try_intros m :=
-  solve [ intros ; unfold block_dep_elim ; refine m || apply m ] ||
-  solve [ unfold block_dep_elim ; simpl_intros m ].
-
-(** To solve a goal by inversion on a particular target. *)
+Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)).
+Ltac do_ind p := introduce p ; (induction p || elim_ind p).
 
-Ltac solve_empty target :=
-  do_nat target intro ; elimtype False ; destruct_last ; simplify_dep_elim.
+(** The following tactics allow to do induction on an already instantiated inductive predicate
+   by first generalizing it and adding the proper equalities to the context, in a maner similar to
+   the BasicElim tactic of "Elimination with a motive" by Conor McBride. *)
 
-Ltac simplify_method tac := repeat (tac || simplify_one_dep_elim) ; reverse_local.
+(** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis 
+   and starts a dependent elimination using this tactic. *)
 
-(** Solving a method call: we can solve it by splitting on an empty family member
-   or we must refine the goal until the body can be applied. *)
-    
-Ltac solve_method rec :=
+Ltac is_introduced H :=
   match goal with
-    | [ H := ?body : nat |- _ ] => subst H ; clear ; abstract (simplify_method idtac ; solve_empty body)
-    | [ H := [ ?body ] : ?T |- _ ] => clear H ; simplify_method ltac:(exact body) ; rec ; try_intros (body:T)
+    | [ H' : _ |- _ ] => match H' with H => idtac end
   end.
 
-(** Impossible cases, by splitting on a given target. *)
-
-Ltac solve_split :=
-  match goal with 
-    | [ |- let split := ?x : nat in _ ] => clear ; abstract (intros _ ; solve_empty x)
-  end.
+Tactic Notation "intro_block" hyp(H) :=
+  (is_introduced H ; block_goal ; revert_until H) ||
+    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).
 
-(** If defining recursive functions, the prototypes come first. *)
+Tactic Notation "intro_block_id" ident(H) :=
+  (is_introduced H ; block_goal ; revert_until H) ||
+    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).
 
-Ltac intro_prototypes :=
-  match goal with 
-    | [ |- Π x : _, _ ] => intro ; intro_prototypes
-    | _ => idtac
-  end.
-
-Ltac introduce p := 
-  first [ match p with _ => idtac end (* Already there *)
-    | intros until p | intros ].
-
-Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)).
-Ltac do_ind p := introduce p ; (induction p || elim_ind p).
+Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_goal.
 
-Ltac dep_elimify := match goal with [ |- ?T ] => change (block_dep_elim T) end.
+Ltac do_intros H :=
+  (try intros until H) ; (intro_block_id H || intro_block H).
 
-Ltac un_dep_elimify := unfold block_dep_elim in *.
+Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H.
 
-Ltac case_last := dep_elimify ;
-  on_last_hyp ltac:(fun p => 
-    let ty := type of p in
-      match ty with
-        | ?x = ?x => revert p ; refine (simplification_K _ x _ _)
-        | ?x = ?y => revert p
-        | _ => simpl in p ; generalize_eqs p ; do_case p
-      end).
+Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim.
 
-Ltac nonrec_equations := 
-  solve [solve_equations (case_last) (solve_method idtac)] || solve [ solve_split ]
-    || fail "Unnexpected equations goal".
+Ltac do_depind tac H := 
+  (try intros until H) ; intro_block H ;
+  generalize_eqs_vars H ; tac H ; simplify_dep_elim ; simplify_IH_hyps ; unblock_goal.
 
-Ltac recursive_equations :=
-  solve [solve_equations (case_last) (solve_method ltac:intro)] || solve [ solve_split ] 
-    || fail "Unnexpected recursive equations goal".
+(** To dependent elimination on some hyp. *)
 
-(** The [equations] tactic is the toplevel tactic for solving goals generated
-   by [Equations]. *)
+Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id.
 
-Ltac equations := set_eos ;
-  match goal with 
-    | [ |- Π x : _, _ ] => intro ; recursive_equations
-    | _ => nonrec_equations
-  end.
+(** Used internally. *)
 
-(** The following tactics allow to do induction on an already instantiated inductive predicate
-   by first generalizing it and adding the proper equalities to the context, in a maner similar to 
-   the BasicElim tactic of "Elimination with a motive" by Conor McBride. *)
+Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id.
 
-(** The [do_depind] higher-order tactic takes an induction tactic as argument and an hypothesis 
-   and starts a dependent induction using this tactic. *)
+(** To dependent induction on some hyp. *)
 
-Ltac do_depind tac H :=
-  (try intros until H) ; dep_elimify ; generalize_eqs_vars H ; tac H ; simplify_dep_elim ; un_dep_elimify.
+Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id.
 
 (** A variant where generalized variables should be given by the user. *)
 
-Ltac do_depind' tac H :=
-  (try intros until H) ; dep_elimify ; generalize_eqs H ; tac H ; simplify_dep_elim ; un_dep_elimify.
+Ltac do_depelim' tac H :=
+  (try intros until H) ; block_goal ; generalize_eqs H ; tac H ; simplify_dep_elim ; 
+    simplify_IH_hyps ; unblock_goal.
 
 (** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
    By default, we don't try to generalize the hyp by its variable indices.  *)
 
 Tactic Notation "dependent" "destruction" ident(H) := 
-  do_depind' ltac:(fun hyp => do_case hyp) H.
+  do_depelim' ltac:(fun hyp => do_case hyp) H.
 
 Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := 
-  do_depind' ltac:(fun hyp => destruct hyp using c) H.
+  do_depelim' ltac:(fun hyp => destruct hyp using c) H.
 
-(** This tactic also generalizes the goal by the given variables before the induction. *)
+(** This tactic also generalizes the goal by the given variables before the elimination. *)
 
 Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := 
-  do_depind' ltac:(fun hyp => revert l ; do_case hyp) H.
+  do_depelim' ltac:(fun hyp => revert l ; do_case hyp) H.
 
 Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := 
-  do_depind' ltac:(fun hyp => revert l ; destruct hyp using c) H.
+  do_depelim' ltac:(fun hyp => revert l ; destruct hyp using c) H.
 
 (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by 
-   writting another wrapper calling do_depind. We suppose the hyp has to be generalized before
+   writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before
    calling [induction]. *)
 
-Tactic Notation "dependent" "induction" ident(H) := 
+Tactic Notation "dependent" "induction" ident(H) :=
   do_depind ltac:(fun hyp => do_ind hyp) H.
 
-Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := 
+Tactic Notation "dependent" "induction" ident(H) "using" constr(c) :=
   do_depind ltac:(fun hyp => induction hyp using c) H.
 
 (** This tactic also generalizes the goal by the given variables before the induction. *)
 
 Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := 
-  do_depind' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H.
+  do_depelim' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H.
 
 Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := 
-  do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H.
-
-Ltac simplify_IH_hyps := repeat
-  match goal with
-    | [ hyp : _ |- _ ] => specialize_hypothesis hyp
-  end.
\ No newline at end of file
+  do_depelim' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H.
diff --git a/theories/Program/Program.v b/theories/Program/Program.v
index 7d0c3948..cdfc7858 100644
--- a/theories/Program/Program.v
+++ b/theories/Program/Program.v
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Program.v 11709 2008-12-20 11:42:15Z msozeau $ *)
+(* $Id$ *)
 
 Require Export Coq.Program.Utils.
 Require Export Coq.Program.Wf.
diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v
index 3d551281..89f477d8 100644
--- a/theories/Program/Subset.v
+++ b/theories/Program/Subset.v
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Subset.v 11709 2008-12-20 11:42:15Z msozeau $ *)
+(* $Id$ *)
 
 (** Tactics related to subsets and proof irrelevance. *)
 
@@ -14,7 +14,7 @@ Require Import Coq.Program.Equality.
 
 Open Local Scope program_scope.
 
-(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to 
+(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to
    factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *)
 
 Ltac on_subset_proof_aux tac T :=
@@ -27,25 +27,25 @@ Ltac on_subset_proof tac :=
     [ |- ?T ] => on_subset_proof_aux tac T
   end.
 
-Ltac abstract_any_hyp H' p := 
+Ltac abstract_any_hyp H' p :=
   match type of p with
-    ?X => 
-    match goal with 
+    ?X =>
+    match goal with
       | [ H : X |- _ ] => fail 1
       | _ => set (H':=p) ; try (change p with H') ; clearbody H'
     end
   end.
 
-Ltac abstract_subset_proof := 
+Ltac abstract_subset_proof :=
   on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H).
 
 Ltac abstract_subset_proofs := repeat abstract_subset_proof.
 
 Ltac pi_subset_proof_hyp p :=
   match type of p with
-    ?X => 
-    match goal with 
-      | [ H : X |- _ ] => 
+    ?X =>
+    match goal with
+      | [ H : X |- _ ] =>
         match p with
           | H => fail 2
           | _ => rewrite (proof_irrelevance X p H)
@@ -78,16 +78,16 @@ Proof.
   pi.
 Qed.
 
-(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] 
+(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f]
    in tactics. *)
 
 Definition match_eq (A B : Type) (x : A) (fn : forall (y : A | y = x), B) : B :=
-  fn (exist _ x (refl_equal x)).
+  fn (exist _ x eq_refl).
 
-(* This is what we want to be able to do: replace the originaly matched object by a new, 
+(* This is what we want to be able to do: replace the originaly matched object by a new,
    propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *)
 
-Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B) 
+Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B)
   (y : A | y = x),
   match_eq A B x fn = fn y.
 Proof.
@@ -103,9 +103,9 @@ Qed.
 (** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary
    equality [t = u], and [u] is now the subject of the [match]. *)
 
-Ltac rewrite_match_eq H := 
+Ltac rewrite_match_eq H :=
   match goal with
-    [ |- ?T ] => 
+    [ |- ?T ] =>
     match T with
       context [ match_eq ?A ?B ?t ?f ] =>
       rewrite (match_eq_rewrite A B t f (exist _ _ (sym_eq H)))
diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v
index 222b5c8d..2064977f 100644
--- a/theories/Program/Syntax.v
+++ b/theories/Program/Syntax.v
@@ -5,15 +5,15 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Syntax.v 11823 2009-01-21 15:32:37Z msozeau $ *)
+(* $Id$ *)
 
 (** Custom notations and implicits for Coq prelude definitions.
 
    Author: Matthieu Sozeau
-   Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
-   91405 Orsay, France *)
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
 
-(** Notations for the unit type and value à la Haskell. *)
+(** Haskell-style notations for the unit type and value. *)
 
 Notation " () " := Datatypes.unit : type_scope.
 Notation " () " := tt.
@@ -31,6 +31,10 @@ Implicit Arguments inr [[A] [B]].
 Implicit Arguments left [[A] [B]].
 Implicit Arguments right [[A] [B]].
 
+Implicit Arguments pair [[A] [B]].
+Implicit Arguments fst [[A] [B]].
+Implicit Arguments snd [[A] [B]].
+
 Require Import Coq.Lists.List.
 
 Implicit Arguments nil [[A]].
@@ -42,6 +46,13 @@ Notation " [ ] " := nil : list_scope.
 Notation " [ x ] " := (cons x nil) : list_scope.
 Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
 
+(** Implicit arguments for vectors. *)
+
+Require Import Bvector.
+
+Implicit Arguments Vnil [[A]].
+Implicit Arguments Vcons [[A] [n]].
+
 (** Treating n-ary exists *)
 
 Notation " 'exists' x y , p" := (ex (fun x => (ex (fun y => p))))
diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v
index 499629a6..e692876d 100644
--- a/theories/Program/Tactics.v
+++ b/theories/Program/Tactics.v
@@ -6,11 +6,32 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Tactics.v 11709 2008-12-20 11:42:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (** This module implements various tactics used to simplify the goals produced by Program,
    which are also generally useful. *)
 
+(** Debugging tactics to show the goal during evaluation. *)
+
+Ltac show_goal := match goal with [ |- ?T ] => idtac T end.
+
+Ltac show_hyp id :=
+  match goal with
+    | [ H := ?b : ?T |- _ ] =>
+      match H with
+        | id => idtac id ":=" b ":" T
+      end
+    | [ H : ?T |- _ ] =>
+      match H with
+        | id => idtac id  ":"  T
+      end
+  end.
+
+Ltac show_hyps :=
+  try match reverse goal with
+        | [ H : ?T |- _ ] => show_hyp H ; fail
+      end.
+
 (** The [do] tactic but using a Coq-side nat. *)
 
 Ltac do_nat n tac :=
@@ -22,7 +43,7 @@ Ltac do_nat n tac :=
 (** Do something on the last hypothesis, or fail *)
 
 Ltac on_last_hyp tac :=
-  match goal with [ H : _ |- _ ] => tac H || fail 1 end.
+  match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end.
 
 (** Destructs one pair, without care regarding naming. *)
 
@@ -56,7 +77,7 @@ Ltac destruct_exists := repeat (destruct_one_ex).
 
 Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex).
 
-(** Destruct an existential hypothesis [t] keeping its name for the first component 
+(** Destruct an existential hypothesis [t] keeping its name for the first component
    and using [Ht] for the second *)
 
 Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht].
@@ -75,7 +96,7 @@ Ltac discriminates :=
 
 (** Revert the last hypothesis. *)
 
-Ltac revert_last := 
+Ltac revert_last :=
   match goal with
     [ H : _ |- _ ] => revert H
   end.
@@ -84,11 +105,20 @@ Ltac revert_last :=
 
 Ltac reverse := repeat revert_last.
 
+(** Reverse everything up to hypothesis id (not included). *)
+
+Ltac revert_until id :=
+  on_last_hyp ltac:(fun id' =>
+    match id' with
+      | id => idtac
+      | _ => revert id' ; revert_until id
+    end).
+
 (** Clear duplicated hypotheses *)
 
 Ltac clear_dup :=
-  match goal with 
-    | [ H : ?X |- _ ] => 
+  match goal with
+    | [ H : ?X |- _ ] =>
       match goal with
         | [ H' : ?Y |- _ ] =>
           match H with
@@ -100,10 +130,20 @@ Ltac clear_dup :=
 
 Ltac clear_dups := repeat clear_dup.
 
+(** Try to clear everything except some hyp *)
+
+Ltac clear_except hyp := 
+  repeat match goal with [ H : _ |- _ ] =>
+           match H with
+             | hyp => fail 1
+             | _ => clear H
+           end
+         end.
+
 (** A non-failing subst that substitutes as much as possible. *)
 
 Ltac subst_no_fail :=
-  repeat (match goal with 
+  repeat (match goal with
             [ H : ?X = ?Y |- _ ] => subst X || subst Y
           end).
 
@@ -118,13 +158,13 @@ Ltac on_application f tac T :=
     | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v)
     | context [f ?x ?y ?z ?w] => tac (f x y z w)
     | context [f ?x ?y ?z] => tac (f x y z)
-    | context [f ?x ?y] => tac (f x y) 
+    | context [f ?x ?y] => tac (f x y)
     | context [f ?x] => tac (f x)
   end.
 
 (** A variant of [apply] using [refine], doing as much conversion as necessary. *)
 
-Ltac rapply p := 
+Ltac rapply p :=
   refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
   refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
   refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) ||
@@ -141,7 +181,7 @@ Ltac rapply p :=
   refine (p _ _) ||
   refine (p _) ||
   refine p.
-  
+
 (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *)
 
 Ltac on_call f tac :=
@@ -174,17 +214,29 @@ Tactic Notation "destruct_call" constr(f) := destruct_call f.
 
 (** Permit to name the results of destructing the call to [f]. *)
 
-Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := 
+Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) :=
   destruct_call_as f l.
 
 (** Specify the hypothesis in which the call occurs as well. *)
 
-Tactic Notation "destruct_call" constr(f) "in" hyp(id) := 
+Tactic Notation "destruct_call" constr(f) "in" hyp(id) :=
   destruct_call_in f id.
 
-Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := 
+Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) :=
   destruct_call_as_in f l id.
 
+(** A marker for prototypes to destruct. *)
+
+Definition fix_proto {A : Type} (a : A) := a.
+
+Ltac destruct_rec_calls :=
+  match goal with
+    | [ H : fix_proto _ |- _ ] => destruct_calls H ; clear H
+  end.
+
+Ltac destruct_all_rec_calls :=
+  repeat destruct_rec_calls ; unfold fix_proto in *.
+
 (** Try to inject any potential constructor equality hypothesis. *)
 
 Ltac autoinjection tac :=
@@ -204,23 +256,23 @@ Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0.
 
 Ltac bang :=
   match goal with
-    | |- ?x => 
+    | |- ?x =>
       match x with
-        | context [False_rect _ ?p] => elim p
+        | appcontext [False_rect _ ?p] => elim p
       end
   end.
- 
+
 (** A tactic to show contradiction by first asserting an automatically provable hypothesis. *)
-Tactic Notation "contradiction" "by" constr(t) := 
+Tactic Notation "contradiction" "by" constr(t) :=
   let H := fresh in assert t as H by auto with * ; contradiction.
 
 (** A tactic that adds [H:=p:typeof(p)] to the context if no hypothesis of the same type appears in the goal.
    Useful to do saturation using tactics. *)
 
-Ltac add_hypothesis H' p := 
+Ltac add_hypothesis H' p :=
   match type of p with
-    ?X => 
-    match goal with 
+    ?X =>
+    match goal with
       | [ H : X |- _ ] => fail 1
       | _ => set (H':=p) ; try (change p with H') ; clearbody H'
     end
@@ -248,13 +300,19 @@ Ltac refine_hyp c :=
     end.
 
 (** The default simplification tactic used by Program is defined by [program_simpl], sometimes [auto]
-   is not enough, better rebind using [Obligation Tactic := tac] in this case, 
+   is not enough, better rebind using [Obligation Tactic := tac] in this case,
    possibly using [program_simplify] to use standard goal-cleaning tactics. *)
 
 Ltac program_simplify :=
-  simpl ; intros ; destruct_conjs ; simpl proj1_sig in * ; subst* ; autoinjections ; try discriminates ;
+  simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *);
+  subst*; autoinjections ; try discriminates ;
     try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]).
 
-Ltac program_simpl := program_simplify ; auto.
+Ltac program_solve_wf :=
+  match goal with
+    |- well_founded _ => auto with *
+  end.
+
+Ltac program_simpl := program_simplify ; auto; try program_solve_wf.
 
-Ltac obligation_tactic := program_simpl.
+Obligation Tactic := program_simpl.
diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v
index b08093bf..fbf0b03c 100644
--- a/theories/Program/Utils.v
+++ b/theories/Program/Utils.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Utils.v 11709 2008-12-20 11:42:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (** Various syntaxic shortands that are useful with [Program]. *)
 
diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v
index 2083e530..98b1c619 100644
--- a/theories/Program/Wf.v
+++ b/theories/Program/Wf.v
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: Wf.v 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 (** Reformulation of the Wf module using subsets where possible, providing
    the support for [Program]'s treatment of well-founded definitions. *)
@@ -22,140 +22,57 @@ Section Well_founded.
   Variable A : Type.
   Variable R : A -> A -> Prop.
   Hypothesis Rwf : well_founded R.
-  
-  Section Acc.
-    
-    Variable P : A -> Type.
-    
-    Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
-    
-    Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x :=
-      F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y) 
-        (Acc_inv r (proj2_sig y))).
-    
-    Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).
-  End Acc.
-  
-  Section FixPoint.
-    Variable P : A -> Type.
-    
-    Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
-    
-    Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *)
-    
-    Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x).
-    
-    Hypothesis
-      F_ext :
-      forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
-        (forall (y : A | R y x), f y = g y) -> F_sub x f = F_sub x g.
-
-    Lemma Fix_F_eq :
-      forall (x:A) (r:Acc R x),
-        F_sub x (fun (y:A|R y x) => Fix_F (`y) (Acc_inv r (proj2_sig y))) = Fix_F x r.
-    Proof. 
-      destruct r using Acc_inv_dep; auto.
-    Qed.
-    
-    Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s.
-    Proof.
-      intro x; induction (Rwf x); intros.
-      rewrite (proof_irrelevance (Acc R x) r s) ; auto.
-    Qed.
-
-    Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:A|R y x) => Fix (proj1_sig y)).
-    Proof.
-      intro x; unfold Fix in |- *.
-      rewrite <- (Fix_F_eq ).
-      apply F_ext; intros.
-      apply Fix_F_inv.
-    Qed.
-
-    Lemma fix_sub_eq :
-        forall x : A,
-          Fix_sub P F_sub x =
-          let f_sub := F_sub in
-            f_sub x (fun (y : A | R y x) => Fix (`y)).
-      exact Fix_eq.
-    Qed.
-
- End FixPoint.
 
-End Well_founded.
+  Variable P : A -> Type.
 
-Extraction Inline Fix_F_sub Fix_sub.
+  Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
 
-Require Import Wf_nat.
-Require Import Lt.
+  Fixpoint Fix_F_sub (x : A) (r : Acc R x) : P x :=
+    F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y)
+      (Acc_inv r (proj2_sig y))).
 
-Section Well_founded_measure.
-  Variable A : Type.
-  Variable m : A -> nat.
-  
-  Section Acc.
-    
-    Variable P : A -> Type.
-    
-    Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x.
-    
-    Program Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x :=
-      F_sub x (fun (y : A | m y < m x)  => Fix_measure_F_sub y
-        (@Acc_inv _ _ _ r (m y) (proj2_sig y))).
-    
-    Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)).
-  
-  End Acc.
-
-  Section FixPoint.
-    Variable P : A -> Type.
-    
-    Program Variable F_sub : forall x:A, (forall (y : A | m y < m x), P y) -> P x.
-    
-    Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *)
-    
-    Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)).
-    
-    Hypothesis
-      F_ext :
-      forall (x:A) (f g:forall y : { y : A | m y < m x}, P (`y)),
-        (forall y : { y : A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g.
-
-    Program Lemma Fix_measure_F_eq :
-      forall (x:A) (r:Acc lt (m x)),
-        F_sub x (fun (y:A | m y < m x) => Fix_F y (Acc_inv r (proj2_sig y))) = Fix_F x r.
-    Proof.
-      intros x.
-      set (y := m x).
-      unfold Fix_measure_F_sub.
-      intros r ; case r ; auto.
-    Qed.
-    
-    Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s.
-    Proof.
-      intros x r s.
-      rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto.
-    Qed.
-
-    Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)).
-    Proof.
-      intro x; unfold Fix_measure in |- *.
-      rewrite <- (Fix_measure_F_eq ).
-      apply F_ext; intros.
-      apply Fix_measure_F_inv.
-    Qed.
-
-    Lemma fix_measure_sub_eq : forall x : A,
-      Fix_measure_sub P F_sub x =
-        let f_sub := F_sub in
-          f_sub x (fun (y : A | m y < m x) => Fix_measure (`y)).
-      exact Fix_measure_eq.
-    Qed.
-
- End FixPoint.
-
-End Well_founded_measure.
-
-Extraction Inline Fix_measure_F_sub Fix_measure_sub.
+  Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).
+
+  (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *)
+  (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *)
+
+  Hypothesis
+    F_ext :
+    forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
+      (forall (y : A | R y x), f y = g y) -> F_sub x f = F_sub x g.
+
+  Lemma Fix_F_eq :
+    forall (x:A) (r:Acc R x),
+      F_sub x (fun (y:A|R y x) => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r.
+  Proof.
+    destruct r using Acc_inv_dep; auto.
+  Qed.
+
+  Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s.
+  Proof.
+    intro x; induction (Rwf x); intros.
+    rewrite (proof_irrelevance (Acc R x) r s) ; auto.
+  Qed.
+
+  Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun (y:A|R y x) => Fix_sub (proj1_sig y)).
+  Proof.
+    intro x; unfold Fix_sub in |- *.
+    rewrite <- (Fix_F_eq ).
+    apply F_ext; intros.
+    apply Fix_F_inv.
+  Qed.
+
+  Lemma fix_sub_eq :
+    forall x : A,
+      Fix_sub x =
+      let f_sub := F_sub in
+        f_sub x (fun (y : A | R y x) => Fix_sub (`y)).
+    exact Fix_eq.
+  Qed.
+
+End Well_founded.
+
+Extraction Inline Fix_F_sub Fix_sub.
 
 Set Implicit Arguments.
 
@@ -189,38 +106,40 @@ Section Measure_well_founded.
 
 End Measure_well_founded.
 
-Section Fix_measure_rects.
+Hint Resolve measure_wf.
+
+Section Fix_rects.
 
   Variable A: Type.
-  Variable m: A -> nat.
   Variable P: A -> Type.
-  Variable f: forall (x : A), (forall y: { y: A | m y < m x }, P (proj1_sig y)) -> P x.
-  
+  Variable R : A -> A -> Prop.
+  Variable Rwf : well_founded R.
+  Variable f: forall (x : A), (forall y: { y: A | R y x }, P (proj1_sig y)) -> P x.
+
   Lemma F_unfold x r:
-    Fix_measure_F_sub A m P f x r =
-    f (fun y => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv r (proj2_sig y))).
+    Fix_F_sub A R P f x r =
+    f (fun y => Fix_F_sub A R P f (proj1_sig y) (Acc_inv r (proj2_sig y))).
   Proof. intros. case r; auto. Qed.
 
-  (* Fix_measure_F_sub_rect lets one prove a property of
-  functions defined using Fix_measure_F_sub by showing
+  (* Fix_F_sub_rect lets one prove a property of
+  functions defined using Fix_F_sub by showing
   that property to be invariant over single application of the
   function body (f in our case). *)
 
-  Lemma Fix_measure_F_sub_rect
+  Lemma Fix_F_sub_rect
     (Q: forall x, P x -> Type)
     (inv: forall x: A,
-     (forall (y: A) (H: MR lt m y x) (a: Acc lt (m y)),
-        Q y (Fix_measure_F_sub A m P f y a)) ->
-        forall (a: Acc lt (m x)),
-          Q x (f (fun y: {y: A | m y < m x} =>
-            Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y)))))
-    : forall x a, Q _ (Fix_measure_F_sub A m P f x a).
+     (forall (y: A) (H: R y x) (a: Acc R y),
+        Q y (Fix_F_sub A R P f y a)) ->
+        forall (a: Acc R x),
+          Q x (f (fun y: {y: A | R y x} =>
+            Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y)))))
+    : forall x a, Q _ (Fix_F_sub A R P f x a).
   Proof with auto.
-    intros Q inv.
-    set (R := fun (x: A) => forall a, Q _ (Fix_measure_F_sub A m P f x a)).
-    cut (forall x, R x)...
-    apply (well_founded_induction_type (measure_wf lt_wf m)).
-    subst R.
+    set (R' := fun (x: A) => forall a, Q _ (Fix_F_sub A R P f x a)).
+    cut (forall x, R' x)...
+    apply (well_founded_induction_type Rwf).
+    subst R'.
     simpl.
     intros.
     rewrite F_unfold...
@@ -229,29 +148,29 @@ Section Fix_measure_rects.
   (* Let's call f's second parameter its "lowers" function, since it
   provides it access to results for inputs with a lower measure.
 
-  In preparation of lemma similar to Fix_measure_F_sub_rect, but
-  for Fix_measure_sub, we first
+  In preparation of lemma similar to Fix_F_sub_rect, but
+  for Fix_sub, we first
   need an extra hypothesis stating that the function body has the
   same result for different "lowers" functions (g and h below) as long
   as those produce the same results for lower inputs, regardless
   of the lt proofs. *)
 
   Hypothesis equiv_lowers:
-    forall x0 (g h: forall x: {y: A | m y < m x0}, P (proj1_sig x)),
-    (forall x p p', g (exist (fun y: A => m y < m x0) x p) = h (exist _ x p')) ->
+    forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)),
+    (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) ->
       f g = f h.
 
   (* From equiv_lowers, it follows that
-   [Fix_measure_F_sub A m P f x] applications do not not
+   [Fix_F_sub A R P f x] applications do not not
   depend on the Acc proofs. *)
 
-  Lemma eq_Fix_measure_F_sub x (a a': Acc lt (m x)):
-    Fix_measure_F_sub A m P f x a =
-    Fix_measure_F_sub A m P f x a'.
+  Lemma eq_Fix_F_sub x (a a': Acc R x):
+    Fix_F_sub A R P f x a =
+    Fix_F_sub A R P f x a'.
   Proof.
-    intros x a.
-    pattern x, (Fix_measure_F_sub A m P f x a).
-    apply Fix_measure_F_sub_rect.
+    revert a'.
+    pattern x, (Fix_F_sub A R P f x a).
+    apply Fix_F_sub_rect.
     intros.
     rewrite F_unfold.
     apply equiv_lowers.
@@ -260,40 +179,42 @@ Section Fix_measure_rects.
     assumption.
   Qed.
 
-  (* Finally, Fix_measure_F_rect lets one prove a property of
-  functions defined using Fix_measure_F by showing that
+  (* Finally, Fix_F_rect lets one prove a property of
+  functions defined using Fix_F_sub by showing that
   property to be invariant over single application of the function
   body (f). *)
 
-  Lemma Fix_measure_sub_rect
+  Lemma Fix_sub_rect
     (Q: forall x, P x -> Type)
     (inv: forall
       (x: A)
-      (H: forall (y: A), MR lt m y x -> Q y (Fix_measure_sub A m P f y))
-      (a: Acc lt (m x)),
-        Q x (f (fun y: {y: A | m y < m x} => Fix_measure_sub A m P f (proj1_sig y))))
-    : forall x, Q _ (Fix_measure_sub A m P f x).
+      (H: forall (y: A), R y x -> Q y (Fix_sub A R Rwf P f y))
+      (a: Acc R x),
+        Q x (f (fun y: {y: A | R y x} => Fix_sub A R Rwf P f (proj1_sig y))))
+    : forall x, Q _ (Fix_sub A R Rwf P f x).
   Proof with auto.
-    unfold Fix_measure_sub.
+    unfold Fix_sub.
     intros.
-    apply Fix_measure_F_sub_rect.
+    apply Fix_F_sub_rect.
     intros.
-    assert (forall y: A, MR lt m y x0 -> Q y (Fix_measure_F_sub A m P f y (lt_wf (m y))))...
+    assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))...
     set (inv x0 X0 a). clearbody q.
-    rewrite <- (equiv_lowers (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (lt_wf (m (proj1_sig y)))) (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))...
+    rewrite <- (equiv_lowers (fun y: {y: A | R y x0} =>
+      Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y)))
+    (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))...
     intros.
-    apply eq_Fix_measure_F_sub.
+    apply eq_Fix_F_sub.
   Qed.
 
-End Fix_measure_rects.
+End Fix_rects.
 
 (** Tactic to fold a definition based on [Fix_measure_sub]. *)
 
 Ltac fold_sub f :=
   match goal with
-    | [ |- ?T ] => 
+    | [ |- ?T ] =>
       match T with
-        appcontext C [ @Fix_measure_sub _ _ _ _ ?arg ] => 
+        appcontext C [ @Fix_sub _ _ _ _ ?arg ] =>
         let app := context C [ f arg ] in
           change app
       end
@@ -308,7 +229,7 @@ Module WfExtensionality.
 
   (** The two following lemmas allow to unfold a well-founded fixpoint definition without
      restriction using the functional extensionality axiom. *)
-  
+
   (** For a function defined with Program using a well-founded order. *)
 
   Program Lemma fix_sub_eq_ext :
@@ -317,7 +238,7 @@ Module WfExtensionality.
       (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x),
       forall x : A,
         Fix_sub A R Rwf P F_sub x =
-          F_sub x (fun (y : A | R y x) => Fix A R Rwf P F_sub y).
+          F_sub x (fun (y : A | R y x) => Fix_sub A R Rwf P F_sub y).
   Proof.
     intros ; apply Fix_eq ; auto.
     intros.
@@ -326,26 +247,10 @@ Module WfExtensionality.
     rewrite H0 ; auto.
   Qed.
 
-  (** For a function defined with Program using a measure. *)
-  
-  Program Lemma fix_sub_measure_eq_ext :
-    forall (A : Type) (f : A -> nat) (P : A -> Type)
-      (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x),
-      forall x : A,
-        Fix_measure_sub A f P F_sub x =
-          F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y).
-  Proof.
-    intros ; apply Fix_measure_eq ; auto.
-    intros.
-    assert(f0 = g).
-    extensionality y ; apply H.
-    rewrite H0 ; auto.
-  Qed.
-  
-  (** Tactic to unfold once a definition based on [Fix_measure_sub]. *)
-  
-  Ltac unfold_sub f fargs := 
-    set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; 
-      rewrite fix_sub_measure_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig.
+  (** Tactic to unfold once a definition based on [Fix_sub]. *)
+
+  Ltac unfold_sub f fargs :=
+    set (call:=fargs) ; unfold f in call ; unfold call ; clear call ;
+      rewrite fix_sub_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig.
 
 End WfExtensionality.
diff --git a/theories/Program/vo.itarget b/theories/Program/vo.itarget
new file mode 100644
index 00000000..864c815a
--- /dev/null
+++ b/theories/Program/vo.itarget
@@ -0,0 +1,9 @@
+Basics.vo
+Combinators.vo
+Equality.vo
+Program.vo
+Subset.vo
+Syntax.vo
+Tactics.vo
+Utils.vo
+Wf.vo
diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v
index 2af65320..f7a28598 100644
--- a/theories/QArith/QArith.v
+++ b/theories/QArith/QArith.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: QArith.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export QArith_base.
 Require Export Qring.
diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
index 0b6d1cfe..54d2a295 100644
--- a/theories/QArith/QArith_base.v
+++ b/theories/QArith/QArith_base.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: QArith_base.v 13215 2010-06-29 09:31:45Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export ZArith.
 Require Export ZArithRing.
-Require Export Setoid Bool.
+Require Export Morphisms Setoid Bool.
 
 (** * Definition of [Q] and basic properties *)
 
@@ -87,6 +87,19 @@ Qed.
 Hint Unfold Qeq Qlt Qle : qarith.
 Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.
 
+Lemma Qcompare_antisym : forall x y, CompOpp (x ?= y) = (y ?= x).
+Proof.
+ unfold "?=". intros. apply Zcompare_antisym.
+Qed.
+
+Lemma Qcompare_spec : forall x y, CompSpec Qeq Qlt x y (x ?= y).
+Proof.
+ intros.
+ destruct (x ?= y) as [ ]_eqn:H; constructor; auto.
+ rewrite Qeq_alt; auto.
+ rewrite Qlt_alt, <- Qcompare_antisym, H; auto.
+Qed.
+
 (** * Properties of equality. *)
 
 Theorem Qeq_refl : forall x, x == x.
@@ -101,7 +114,7 @@ Qed.
 
 Theorem Qeq_trans : forall x y z, x == y -> y == z -> x == z.
 Proof.
-unfold Qeq in |- *; intros.
+unfold Qeq; intros.
 apply Zmult_reg_l with (QDen y).
 auto with qarith.
 transitivity (Qnum x * QDen y * QDen z)%Z; try ring.
@@ -110,6 +123,15 @@ transitivity (Qnum y * QDen z * QDen x)%Z; try ring.
 rewrite H0; ring.
 Qed.
 
+Hint Resolve Qeq_refl : qarith.
+Hint Resolve Qeq_sym : qarith.
+Hint Resolve Qeq_trans : qarith.
+
+(** In a word, [Qeq] is a setoid equality. *)
+
+Instance Q_Setoid : Equivalence Qeq.
+Proof. split; red; eauto with qarith. Qed.
+
 (** Furthermore, this equality is decidable: *)
 
 Theorem Qeq_dec : forall x y, {x==y} + {~ x==y}.
@@ -120,12 +142,12 @@ Defined.
 Definition Qeq_bool x y :=
   (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.
 
-Definition Qle_bool x y := 
+Definition Qle_bool x y :=
   (Zle_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.
 
 Lemma Qeq_bool_iff : forall x y, Qeq_bool x y = true <-> x == y.
 Proof.
-  unfold Qeq_bool, Qeq; intros. 
+  unfold Qeq_bool, Qeq; intros.
   symmetry; apply Zeq_is_eq_bool.
 Qed.
 
@@ -155,18 +177,6 @@ Proof.
   intros; rewrite <- Qle_bool_iff; auto.
 Qed.
 
-(** We now consider [Q] seen as a setoid. *)
-
-Add Relation Q Qeq
-  reflexivity proved by Qeq_refl
-  symmetry proved by Qeq_sym
-  transitivity proved by Qeq_trans
-as Q_Setoid.
-
-Hint Resolve Qeq_refl : qarith.
-Hint Resolve Qeq_sym : qarith.
-Hint Resolve Qeq_trans : qarith.
-
 Theorem Qnot_eq_sym : forall x y, ~x == y -> ~y == x.
 Proof.
  auto with qarith.
@@ -218,7 +228,7 @@ Qed.
 
 (** * Setoid compatibility results *)
 
-Add Morphism Qplus : Qplus_comp.
+Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus.
 Proof.
   unfold Qeq, Qplus; simpl.
   Open Scope Z_scope.
@@ -232,24 +242,23 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
-Add Morphism Qopp : Qopp_comp.
+Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp.
 Proof.
   unfold Qeq, Qopp; simpl.
   Open Scope Z_scope.
-  intros.
+  intros x y H; simpl.
   replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring.
-  rewrite H in |- *;  ring.
+  rewrite H;  ring.
   Close Scope Z_scope.
 Qed.
 
-Add Morphism Qminus : Qminus_comp.
+Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus.
 Proof.
-  intros.
-  unfold Qminus.
-  rewrite H; rewrite H0; auto with qarith.
+  intros x x' Hx y y' Hy.
+  unfold Qminus. rewrite Hx, Hy; auto with qarith.
 Qed.
 
-Add Morphism Qmult : Qmult_comp.
+Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult.
 Proof.
   unfold Qeq; simpl.
   Open Scope Z_scope.
@@ -263,7 +272,7 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
-Add Morphism Qinv : Qinv_comp.
+Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv.
 Proof.
   unfold Qeq, Qinv; simpl.
   Open Scope Z_scope.
@@ -281,83 +290,49 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
-Add Morphism Qdiv : Qdiv_comp.
-Proof.
-  intros; unfold Qdiv.
-  rewrite H; rewrite H0; auto with qarith.
-Qed.
-
-Add Morphism Qle with signature Qeq ==> Qeq ==> iff as Qle_comp.
+Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv.
 Proof.
-  cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<=x3 -> x2<=x4).
-  split; apply H; assumption || (apply Qeq_sym ; assumption).
-
-  unfold Qeq, Qle; simpl.
-  Open Scope Z_scope.
-  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *.
-  apply Zmult_le_reg_r with ('p2).
-  unfold Zgt; auto.
-  replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring.
-  rewrite <- H.
-  apply Zmult_le_reg_r with ('r2).
-  unfold Zgt; auto.
-  replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring.
-  rewrite <- H0.
-  replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring.
-  replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring.
-  auto with zarith.
-  Close Scope Z_scope.
+  intros x x' Hx y y' Hy; unfold Qdiv.
+  rewrite Hx, Hy; auto with qarith.
 Qed.
 
-Add Morphism Qlt with signature Qeq ==> Qeq ==> iff as  Qlt_comp.
+Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare.
 Proof.
-  cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<x3 -> x2<x4).
-  split; apply H; assumption || (apply Qeq_sym ; assumption).
-
-  unfold Qeq, Qlt; simpl.
+  unfold Qeq, Qcompare.
   Open Scope Z_scope.
-  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *.
-  apply Zgt_lt.
-  generalize (Zlt_gt _ _ H1); clear H1; intro H1.
-  apply Zmult_gt_reg_r with ('p2); auto with zarith.
-  replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring.
-  rewrite <- H.
-  apply Zmult_gt_reg_r with ('r2); auto with zarith.
-  replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring.
-  rewrite <- H0.
-  replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring.
-  replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring.
-  apply Zlt_gt.
-  apply Zmult_gt_0_lt_compat_l; auto with zarith.
+  intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *.
+  rewrite <- (Zcompare_mult_compat (q2*s2) (p1*'r2)).
+  rewrite <- (Zcompare_mult_compat (p2*r2) (q1*'s2)).
+  change ('(q2*s2)) with ('q2 * 's2).
+  change ('(p2*r2)) with ('p2 * 'r2).
+  replace ('q2 * 's2 * (p1*'r2)) with ((p1*'q2)*'r2*'s2) by ring.
+  rewrite H.
+  replace ('q2 * 's2 * (r1*'p2)) with ((r1*'s2)*'q2*'p2) by ring.
+  rewrite H'.
+  f_equal; ring.
   Close Scope Z_scope.
 Qed.
 
-Add Morphism Qeq_bool with signature Qeq ==> Qeq ==> (@eq bool) as Qeqb_comp.
+Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle.
 Proof.
- intros; apply eq_true_iff_eq.
- rewrite 2 Qeq_bool_iff, H, H0; split; auto with qarith.
+  intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *.
 Qed.
 
-Add Morphism Qle_bool with signature Qeq ==> Qeq ==> (@eq bool) as Qleb_comp.
+Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt.
 Proof.
- intros; apply eq_true_iff_eq.
- rewrite 2 Qle_bool_iff, H, H0.
- split; auto with qarith.
+  intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *.
 Qed.
 
-Lemma Qcompare_egal_dec: forall n m p q : Q,
-  (n<m -> p<q) -> (n==m -> p==q) -> (n>m -> p>q) -> ((n?=m) = (p?=q)).
+Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool.
 Proof.
-  intros.
-  do 2 rewrite Qeq_alt in H0.
-  unfold Qeq, Qlt, Qcompare in *.
-  apply Zcompare_egal_dec; auto.
-  omega.
+ intros p q H r s H'; apply eq_true_iff_eq.
+ rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith.
 Qed.
 
-Add Morphism Qcompare : Qcompare_comp.
+Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool.
 Proof.
-  intros; apply Qcompare_egal_dec; rewrite H; rewrite H0; auto.
+ intros p q H r s H'; apply eq_true_iff_eq.
+ rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith.
 Qed.
 
 
@@ -554,6 +529,11 @@ Qed.
 
 Hint Resolve Qle_trans : qarith.
 
+Lemma Qlt_irrefl : forall x, ~x<x.
+Proof.
+ unfold Qlt. auto with zarith.
+Qed.
+
 Lemma Qlt_not_eq : forall x y, x<y -> ~ x==y.
 Proof.
   unfold Qlt, Qeq; auto with zarith.
@@ -561,6 +541,13 @@ Qed.
 
 (** Large = strict or equal *)
 
+Lemma Qle_lteq : forall x y, x<=y <-> x<y \/ x==y.
+Proof.
+ intros.
+ rewrite Qeq_alt, Qle_alt, Qlt_alt.
+ destruct (x ?= y); intuition; discriminate.
+Qed.
+
 Lemma Qlt_le_weak : forall x y, x<y -> x<=y.
 Proof.
   unfold Qle, Qlt; auto with zarith.
@@ -632,15 +619,8 @@ Proof.
   unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto.
 Qed.
 
-(** These hints were meant to be added to the qarith database,
-    but a typo prevented that. This will be fixed in 8.3.
-    Concerning 8.2, for maximal compatibility , we
-    leave them in a separate database, in order to preserve
-    the strength of both [auto with qarith] and [auto with *].
-    (see bug #2346). *)
-
 Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le
- Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith_extra.
+ Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith.
 
 (** Some decidability results about orders. *)
 
@@ -842,9 +822,9 @@ Qed.
 Definition Qpower_positive (q:Q)(p:positive) : Q :=
  pow_pos Qmult q p.
 
-Add Morphism Qpower_positive with signature Qeq ==> @eq _ ==> Qeq as Qpower_positive_comp.
+Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive.
 Proof.
-intros x1 x2 Hx y.
+intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy.
 unfold Qpower_positive.
 induction y; simpl;
 try rewrite IHy;
@@ -861,8 +841,8 @@ Definition Qpower (q:Q) (z:Z) :=
 
 Notation " q ^ z " := (Qpower q z) : Q_scope.
 
-Add Morphism Qpower with signature Qeq ==> @eq _ ==> Qeq as Qpower_comp.
+Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower.
 Proof.
-intros x1 x2 Hx [|y|y]; try reflexivity;
-simpl; rewrite Hx; reflexivity.
+intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy.
+destruct y; simpl; rewrite ?Hx; auto with *.
 Qed.
diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v
new file mode 100644
index 00000000..692bfd92
--- /dev/null
+++ b/theories/QArith/QOrderedType.v
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import QArith_base Equalities Orders OrdersTac.
+
+Local Open Scope Q_scope.
+
+(** * DecidableType structure for rational numbers *)
+
+Module Q_as_DT <: DecidableTypeFull.
+ Definition t := Q.
+ Definition eq := Qeq.
+ Definition eq_equiv := Q_Setoid.
+ Definition eqb := Qeq_bool.
+ Definition eqb_eq := Qeq_bool_iff.
+
+ Include BackportEq. (** eq_refl, eq_sym, eq_trans *)
+ Include HasEqBool2Dec. (** eq_dec *)
+
+End Q_as_DT.
+
+(** Note that the last module fulfills by subtyping many other
+    interfaces, such as [DecidableType] or [EqualityType]. *)
+
+
+
+(** * OrderedType structure for rational numbers *)
+
+Module Q_as_OT <: OrderedTypeFull.
+ Include Q_as_DT.
+ Definition lt := Qlt.
+ Definition le := Qle.
+ Definition compare := Qcompare.
+
+ Instance lt_strorder : StrictOrder Qlt.
+ Proof. split; [ exact Qlt_irrefl | exact Qlt_trans ]. Qed.
+
+ Instance lt_compat : Proper (Qeq==>Qeq==>iff) Qlt.
+ Proof. auto with *. Qed.
+
+ Definition le_lteq := Qle_lteq.
+ Definition compare_spec := Qcompare_spec.
+
+End Q_as_OT.
+
+
+(** * An [order] tactic for [Q] numbers *)
+
+Module QOrder := OTF_to_OrderTac Q_as_OT.
+Ltac q_order := QOrder.order.
+
+(** Note that [q_order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x==y]. *)
diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
index 42522468..34d6267e 100644
--- a/theories/QArith/Qcanon.v
+++ b/theories/QArith/Qcanon.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qcanon.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Field.
 Require Import QArith.
 Require Import Znumtheory.
 Require Import Eqdep_dec.
 
-(** [Qc] : A canonical representation of rational numbers. 
+(** [Qc] : A canonical representation of rational numbers.
    based on the setoid representation [Q]. *)
 
 Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }.
@@ -23,7 +23,7 @@ Bind Scope Qc_scope with Qc.
 Arguments Scope Qcmake [Q_scope].
 Open Scope Qc_scope.
 
-Lemma Qred_identity : 
+Lemma Qred_identity :
   forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q.
 Proof.
   unfold Qred; intros (a,b); simpl.
@@ -36,7 +36,7 @@ Proof.
   subst; simpl; auto.
 Qed.
 
-Lemma Qred_identity2 : 
+Lemma Qred_identity2 :
   forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z.
 Proof.
   unfold Qred; intros (a,b); simpl.
@@ -50,7 +50,7 @@ Proof.
   destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate.
   f_equal.
   apply Pmult_reg_r with bb.
-  injection H2; intros. 
+  injection H2; intros.
   rewrite <- H0.
   rewrite H; simpl; auto.
   elim H1; auto.
@@ -70,7 +70,7 @@ Proof.
   apply Qred_correct.
 Qed.
 
-Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). 
+Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q).
 Arguments Scope Q2Qc [Q_scope].
 Notation " !! " := Q2Qc : Qc_scope.
 
@@ -82,7 +82,7 @@ Proof.
   assert (H0:=Qred_complete _ _ H).
   assert (q = q') by congruence.
   subst q'.
-  assert (proof_q = proof_q'). 
+  assert (proof_q = proof_q').
   apply eq_proofs_unicity; auto; intros.
   repeat decide equality.
   congruence.
@@ -98,8 +98,8 @@ Notation Qcgt := (fun x y : Qc => Qlt y x).
 Notation Qcge := (fun x y : Qc => Qle y x).
 Infix "<" := Qclt : Qc_scope.
 Infix "<=" := Qcle : Qc_scope.
-Infix ">" := Qcgt : Qc_scope. 
-Infix ">=" := Qcge : Qc_scope. 
+Infix ">" := Qcgt : Qc_scope.
+Infix ">=" := Qcge : Qc_scope.
 Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope.
 Notation "x < y < z" := (x<y/\y<z) : Qc_scope.
 
@@ -141,9 +141,9 @@ Proof.
   intros.
   destruct (Qeq_dec x y) as [H|H]; auto.
   right; contradict H; subst; auto with qarith.
-Defined. 
+Defined.
 
-(** The addition, multiplication and opposite are defined 
+(** The addition, multiplication and opposite are defined
    in the straightforward way: *)
 
 Definition Qcplus (x y : Qc) := !!(x+y).
@@ -155,9 +155,9 @@ Notation "- x" := (Qcopp x) : Qc_scope.
 Definition Qcminus (x y : Qc) := x+-y.
 Infix "-" := Qcminus : Qc_scope.
 Definition Qcinv (x : Qc) := !!(/x).
-Notation "/ x" := (Qcinv x) : Qc_scope. 
+Notation "/ x" := (Qcinv x) : Qc_scope.
 Definition Qcdiv (x y : Qc) := x*/y.
-Infix "/" := Qcdiv : Qc_scope. 
+Infix "/" := Qcdiv : Qc_scope.
 
 (** [0] and [1] are apart *)
 
@@ -167,8 +167,8 @@ Proof.
   intros H; discriminate H.
 Qed.
 
-Ltac qc := match goal with 
- | q:Qc |- _ => destruct q; qc 
+Ltac qc := match goal with
+ | q:Qc |- _ => destruct q; qc
  | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct
 end.
 
@@ -191,7 +191,7 @@ Qed.
 Lemma Qcplus_0_r : forall x, x+0 = x.
 Proof.
   intros; qc; apply Qplus_0_r.
-Qed. 
+Qed.
 
 (** Commutativity of addition: *)
 
@@ -265,13 +265,13 @@ Qed.
 Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0.
 Proof.
   intros; destruct (Qcmult_integral _ _ H0); tauto.
-Qed. 
+Qed.
 
-(** Inverse and division. *) 
+(** Inverse and division. *)
 
 Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1.
 Proof.
-  intros; qc; apply Qmult_inv_r; auto. 
+  intros; qc; apply Qmult_inv_r; auto.
 Qed.
 
 Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1.
@@ -436,24 +436,24 @@ Qed.
 Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
 Proof.
   unfold Qcmult, Qcle, Qclt; intros; simpl in *.
-  repeat progress rewrite Qred_correct in * |-. 
+  repeat progress rewrite Qred_correct in * |-.
   eapply Qmult_lt_0_le_reg_r; eauto.
 Qed.
 
 Lemma Qcmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
 Proof.
   unfold Qcmult, Qclt; intros; simpl in *.
-  repeat progress rewrite Qred_correct in *. 
+  repeat progress rewrite Qred_correct in *.
   eapply Qmult_lt_compat_r; eauto.
 Qed.
 
 (** Rational to the n-th power *)
 
-Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc := 
-  match n with 
+Fixpoint Qcpower (q:Qc)(n:nat) : Qc :=
+  match n with
     | O => 1
     | S n => q * (Qcpower q n)
-  end. 
+  end.
 
 Notation " q ^ n " := (Qcpower q n) : Qc_scope.
 
@@ -467,7 +467,7 @@ Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0.
 Proof.
   destruct n; simpl.
   destruct 1; auto.
-  intros. 
+  intros.
   apply Qc_is_canon.
   simpl.
   compute; auto.
@@ -537,7 +537,7 @@ Proof.
   intros (q, Hq) (q', Hq'); simpl; intros H.
   assert (H1 := H Hq Hq').
   subst q'.
-  assert (Hq = Hq'). 
+  assert (Hq = Hq').
   apply Eqdep_dec.eq_proofs_unicity; auto; intros.
   repeat decide equality.
   congruence.
diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v
index 9841ef89..fbfae55c 100644
--- a/theories/QArith/Qfield.v
+++ b/theories/QArith/Qfield.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qfield.v 11208 2008-07-04 16:57:46Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export Field.
 Require Export QArith_base.
@@ -73,15 +73,15 @@ Ltac Qpow_tac t :=
   | _ => NotConstant
   end.
 
-Add Field Qfield : Qsft 
- (decidable Qeq_bool_eq, 
+Add Field Qfield : Qsft
+ (decidable Qeq_bool_eq,
   completeness Qeq_eq_bool,
-  constants [Qcst], 
+  constants [Qcst],
   power_tac Qpower_theory [Qpow_tac]).
 
 (** Exemple of use: *)
 
-Section Examples. 
+Section Examples.
 
 Let ex1 : forall x y z : Q, (x+y)*z ==  (x*z)+(y*z).
   intros.
@@ -89,7 +89,7 @@ Let ex1 : forall x y z : Q, (x+y)*z ==  (x*z)+(y*z).
 Qed.
 
 Let ex2 : forall x y : Q, x+y == y+x.
-  intros. 
+  intros.
   ring.
 Qed.
 
diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v
new file mode 100644
index 00000000..d05a8594
--- /dev/null
+++ b/theories/QArith/Qminmax.v
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import QArith_base Orders QOrderedType GenericMinMax.
+
+(** * Maximum and Minimum of two rational numbers *)
+
+Local Open Scope Q_scope.
+
+(** [Qmin] and [Qmax] are obtained the usual way from [Qcompare]. *)
+
+Definition Qmax := gmax Qcompare.
+Definition Qmin := gmin Qcompare.
+
+Module QHasMinMax <: HasMinMax Q_as_OT.
+ Module QMM := GenericMinMax Q_as_OT.
+ Definition max := Qmax.
+ Definition min := Qmin.
+ Definition max_l := QMM.max_l.
+ Definition max_r := QMM.max_r.
+ Definition min_l := QMM.min_l.
+ Definition min_r := QMM.min_r.
+End QHasMinMax.
+
+Module Q.
+
+(** We obtain hence all the generic properties of max and min. *)
+
+Include MinMaxProperties Q_as_OT QHasMinMax.
+
+
+(** * Properties specific to the [Q] domain *)
+
+(** Compatibilities (consequences of monotonicity) *)
+
+Lemma plus_max_distr_l : forall n m p, Qmax (p + n) (p + m) == p + Qmax n m.
+Proof.
+ intros. apply max_monotone.
+ intros x x' Hx; rewrite Hx; auto with qarith.
+ intros x x' Hx. apply Qplus_le_compat; q_order.
+Qed.
+
+Lemma plus_max_distr_r : forall n m p, Qmax (n + p) (m + p) == Qmax n m + p.
+Proof.
+ intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p).
+ apply plus_max_distr_l.
+Qed.
+
+Lemma plus_min_distr_l : forall n m p, Qmin (p + n) (p + m) == p + Qmin n m.
+Proof.
+ intros. apply min_monotone.
+ intros x x' Hx; rewrite Hx; auto with qarith.
+ intros x x' Hx. apply Qplus_le_compat; q_order.
+Qed.
+
+Lemma plus_min_distr_r : forall n m p, Qmin (n + p) (m + p) == Qmin n m + p.
+Proof.
+ intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p).
+ apply plus_min_distr_l.
+Qed.
+
+End Q.
\ No newline at end of file
diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v
index efaefbb7..fa341dd9 100644
--- a/theories/QArith/Qpower.v
+++ b/theories/QArith/Qpower.v
@@ -59,7 +59,7 @@ Qed.
 
 Lemma Qmult_power : forall a b n, (a*b)^n == a^n*b^n.
 Proof.
-  intros a b [|n|n]; simpl; 
+  intros a b [|n|n]; simpl;
   try rewrite Qmult_power_positive;
   try rewrite Qinv_mult_distr;
   reflexivity.
@@ -73,7 +73,7 @@ Qed.
 
 Lemma Qinv_power : forall a n, (/a)^n == /a^n.
 Proof.
-  intros a [|n|n]; simpl; 
+  intros a [|n|n]; simpl;
   try rewrite Qinv_power_positive;
   reflexivity.
 Qed.
@@ -173,8 +173,8 @@ Qed.
 
 Lemma Qpower_mult : forall a n m, a^(n*m) ==  (a^n)^m.
 Proof.
-intros a [|n|n] [|m|m]; simpl; 
- try rewrite Qpower_positive_1; 
+intros a [|n|n] [|m|m]; simpl;
+ try rewrite Qpower_positive_1;
  try rewrite Qpower_mult_positive;
  try rewrite Qinv_power_positive;
  try rewrite Qinv_involutive;
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
index c98cef3f..12e371ee 100644
--- a/theories/QArith/Qreals.v
+++ b/theories/QArith/Qreals.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qreals.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Rbase.
 Require Export QArith_base.
@@ -173,7 +173,7 @@ unfold Qinv, Q2R, Qeq in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
 case x1.
 simpl in |- *; intros; elim H; trivial.
 intros; field; auto.
-intros; 
+intros;
   change (IZR (Zneg x2)) with (- IZR (' x2))%R in |- *;
   change (IZR (Zneg p)) with (- IZR (' p))%R in |- *;
   field; (*auto 8 with real.*)
@@ -193,8 +193,8 @@ Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl.
 Section LegacyQField.
 
 (** In the past, the field tactic was not able to deal with setoid datatypes,
-    so translating from Q to R and applying field on reals was a workaround. 
-    See now Qfield for a direct field tactic on Q. *) 
+    so translating from Q to R and applying field on reals was a workaround.
+    See now Qfield for a direct field tactic on Q. *)
 
 Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto.
 
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
index 9c522f09..27e3c4e0 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qreduction.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Normalisation functions for rational numbers. *)
 
@@ -35,15 +35,15 @@ Qed.
 (** Simplification of fractions using [Zgcd].
   This version can compute within Coq. *)
 
-Definition Qred (q:Q) := 
-  let (q1,q2) := q in 
-  let (r1,r2) := snd (Zggcd q1 ('q2)) 
+Definition Qred (q:Q) :=
+  let (q1,q2) := q in
+  let (r1,r2) := snd (Zggcd q1 ('q2))
   in r1#(Z2P r2).
 
 Lemma Qred_correct : forall q, (Qred q) == q.
 Proof.
   unfold Qred, Qeq; intros (n,d); simpl.
-  generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) 
+  generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d))
     (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
   destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
   Open Scope Z_scope.
@@ -52,7 +52,7 @@ Proof.
   rewrite H3; rewrite H4.
   assert (0 <> g).
   intro; subst g; discriminate.
-  
+
   assert (0 < dd).
   apply Zmult_gt_0_lt_0_reg_r with g.
   omega.
@@ -68,10 +68,10 @@ Proof.
   intros (a,b) (c,d).
   unfold Qred, Qeq in *; simpl in *.
   Open Scope Z_scope.
-  generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) 
+  generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
     (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
   destruct (Zggcd a (Zpos b)) as (g,(aa,bb)).
-  generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) 
+  generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
     (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)).
   destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
   simpl.
@@ -136,7 +136,7 @@ Proof.
   Close Scope Z_scope.
 Qed.
 
-Add Morphism Qred : Qred_comp. 
+Add Morphism Qred : Qred_comp.
 Proof.
   intros q q' H.
   rewrite (Qred_correct q); auto.
@@ -144,7 +144,7 @@ Proof.
 Qed.
 
 Definition Qplus' (p q : Q) := Qred (Qplus p q).
-Definition Qmult' (p q : Q) := Qred (Qmult p q). 
+Definition Qmult' (p q : Q) := Qred (Qmult p q).
 Definition Qminus' x y := Qred (Qminus x y).
 
 Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
index 2d45d537..8c9e2dfa 100644
--- a/theories/QArith/Qring.v
+++ b/theories/QArith/Qring.v
@@ -6,6 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Qring.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Qfield.
diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v
index 3f191c75..8162a702 100644
--- a/theories/QArith/Qround.v
+++ b/theories/QArith/Qround.v
@@ -122,7 +122,7 @@ Qed.
 
 Hint Resolve Qceiling_resp_le : qarith.
 
-Add Morphism Qfloor with signature Qeq ==> @eq _ as Qfloor_comp.
+Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp.
 Proof.
 intros x y H.
 apply Zle_antisym.
@@ -130,7 +130,7 @@ apply Zle_antisym.
 symmetry in H; auto with *.
 Qed.
 
-Add Morphism Qceiling with signature Qeq ==> @eq _ as Qceiling_comp.
+Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp.
 Proof.
 intros x y H.
 apply Zle_antisym.
diff --git a/theories/QArith/vo.itarget b/theories/QArith/vo.itarget
new file mode 100644
index 00000000..b3faef88
--- /dev/null
+++ b/theories/QArith/vo.itarget
@@ -0,0 +1,12 @@
+Qabs.vo
+QArith_base.vo
+QArith.vo
+Qcanon.vo
+Qfield.vo
+Qpower.vo
+Qreals.vo
+Qreduction.vo
+Qring.vo
+Qround.vo
+QOrderedType.vo
+Qminmax.vo
\ No newline at end of file
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index 7625cce6..6e2488f5 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Alembert.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -198,7 +198,7 @@ Proof.
   replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n));
     [ idtac | ring ];
     replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
-      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
+      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n))));
       [ idtac | ring ]; apply Rmult_le_compat_l.
   left; apply Rmult_lt_0_compat.
   prove_sup0.
@@ -273,7 +273,7 @@ Proof.
   replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n));
     [ idtac | ring ];
     replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
-      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
+      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n))));
       [ idtac | ring ]; apply Rmult_le_compat_l.
   left; apply Rmult_lt_0_compat.
   prove_sup0.
@@ -304,8 +304,8 @@ Proof.
   pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
     rewrite Rplus_assoc; apply Rplus_le_compat_l.
   apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r;
-    rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; 
-      rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; 
+    rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc;
+      rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp;
 	apply RRle_abs.
   unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
     repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
@@ -318,7 +318,7 @@ Proof.
     rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
   apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *;
-    rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; 
+    rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
       rewrite Rplus_opp_l; rewrite Rplus_0_r;
 	apply Rle_lt_trans with (Rabs (An n)).
   apply RRle_abs.
@@ -328,7 +328,7 @@ Proof.
     rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
   apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *;
-    rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; 
+    rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc;
       rewrite Rplus_opp_r; rewrite Rplus_0_r;
 	apply Rle_lt_trans with (Rabs (An n)).
   rewrite <- Rabs_Ropp; apply RRle_abs.
@@ -352,7 +352,7 @@ Proof.
   unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
   intro; elim (H1 (eps / Rabs x) H4); intros.
   exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *;
-    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
       unfold Bn in |- *;
 	replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
   rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x).
@@ -363,13 +363,13 @@ Proof.
     replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0).
   apply H5; assumption.
   unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; 
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *;
       reflexivity.
   apply Rabs_no_R0; assumption.
   replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add;
     unfold Rdiv in |- *; rewrite Rinv_mult_distr.
   replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with
-    (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); 
+    (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n));
     [ idtac | ring ]; rewrite <- Rinv_r_sym.
   simpl in |- *; ring.
   apply pow_nonzero; assumption.
@@ -638,7 +638,7 @@ Lemma Alembert_C6 :
   rewrite Rmult_1_r.
   rewrite Rinv_mult_distr.
   replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
-    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
+    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n));
     [ idtac | ring ].
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
@@ -713,7 +713,7 @@ Lemma Alembert_C6 :
   rewrite Rmult_1_r.
   rewrite Rinv_mult_distr.
   replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
-    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
+    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n));
     [ idtac | ring ].
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
index 5c4bbd6a..cccc8cee 100644
--- a/theories/Reals/AltSeries.v
+++ b/theories/Reals/AltSeries.v
@@ -6,7 +6,7 @@
   (*         *       GNU Lesser General Public License Version 2.1        *)
   (************************************************************************)
 
-  (*i $Id: AltSeries.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+  (*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -69,7 +69,7 @@ Lemma CV_ALT_step2 :
   forall (Un:nat -> R) (N:nat),
     Un_decreasing Un ->
     positivity_seq Un ->
-    sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. 
+    sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0.
 Proof.
   intros; induction  N as [| N HrecN].
   simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
@@ -101,7 +101,7 @@ Qed.
 Lemma CV_ALT_step3 :
   forall (Un:nat -> R) (N:nat),
     Un_decreasing Un ->
-    positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. 
+    positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0.
 Proof.
   intros; induction  N as [| N HrecN].
   simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
@@ -184,7 +184,7 @@ Proof.
   rewrite H12; apply H7; assumption.
   rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult;
     rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
-      rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); 
+      rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n)));
 	apply H6.
   unfold ge in |- *; apply le_trans with n.
   apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ].
@@ -246,7 +246,7 @@ Proof.
   apply CV_ALT_step1; assumption.
   assumption.
   unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
-    unfold R_dist in H1; intros. 
+    unfold R_dist in H1; intros.
   elim (H1 eps H2); intros.
   exists x; intros.
   apply H3.
@@ -254,20 +254,20 @@ Proof.
   apply le_trans with n.
   assumption.
   assert (H5 := mult_O_le n 2).
-  elim H5; intro. 
+  elim H5; intro.
   cut (0%nat <> 2%nat);
     [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
   assumption.
   apply le_n_Sn.
   unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
-    unfold R_dist in H1; intros. 
+    unfold R_dist in H1; intros.
   elim (H1 eps H2); intros.
   exists x; intros.
   apply H3.
   unfold ge in |- *; apply le_trans with n.
   assumption.
   assert (H5 := mult_O_le n 2).
-  elim H5; intro. 
+  elim H5; intro.
   cut (0%nat <> 2%nat);
     [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
   assumption.
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index 7327c64c..f22ff5cb 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -6,7 +6,7 @@
   (*         *       GNU Lesser General Public License Version 2.1        *)
   (************************************************************************)
 
-  (*i $Id: ArithProp.v 9454 2006-12-15 15:30:59Z bgregoir $ i*)
+  (*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rbasic_fun.
@@ -124,7 +124,7 @@ Proof.
     rewrite <- Ropp_inv_permute; [ idtac | assumption ].
   replace
     (IZR (up (x * / - y)) - x * - / y +
-      (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; 
+      (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1;
     [ idtac | ring ].
   elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
   rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
@@ -153,11 +153,11 @@ Proof.
   rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
     rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
       [ rewrite Rmult_1_r | assumption ];
-      apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); 
+      apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y);
 	rewrite Rplus_0_r; unfold Rdiv in |- *;
 	  replace
 	    (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
-	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; 
+	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2;
 	      exact H2.
   rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
   apply Rinv_0_lt_compat; assumption.
@@ -165,10 +165,10 @@ Proof.
     rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
       [ rewrite Rmult_1_r | assumption ];
       apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
-	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); 
+	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y)));
 	  [ idtac | ring ];
 	  replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
-	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; 
+	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *;
 	      intros H2 _; exact H2.
   case (total_order_T 0 y); intro.
   elim s; intro.
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
index 5be34e71..0d34d22c 100644
--- a/theories/Reals/Binomial.v
+++ b/theories/Reals/Binomial.v
@@ -6,7 +6,7 @@
   (*         *       GNU Lesser General Public License Version 2.1        *)
   (************************************************************************)
 
-  (*i $Id: Binomial.v 9245 2006-10-17 12:53:34Z notin $ i*)
+  (*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -194,7 +194,7 @@ Proof.
   apply minus_Sn_m; assumption.
   rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
   intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
-    replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; 
+    replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ];
       ring.
   intro; unfold C in |- *.
   replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
index 37429a90..6ea0767d 100644
--- a/theories/Reals/Cauchy_prod.v
+++ b/theories/Reals/Cauchy_prod.v
@@ -6,7 +6,7 @@
   (*         *       GNU Lesser General Public License Version 2.1        *)
   (************************************************************************)
 
-  (*i $Id: Cauchy_prod.v 9245 2006-10-17 12:53:34Z notin $ i*)
+  (*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -47,7 +47,7 @@ Theorem cauchy_finite :
     sum_f_R0
     (fun k:nat =>
       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat)
-      (pred (N - k))) (pred N). 
+      (pred (N - k))) (pred N).
 Proof.
   intros; induction  N as [| N HrecN].
   elim (lt_irrefl _ H).
@@ -124,7 +124,7 @@ Proof.
       (fun k:nat =>
 	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
         (pred (pred (N - k)))) (pred (pred N)));
-    set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); 
+    set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N));
       ring.
   rewrite
     (sum_N_predN
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
index 0de639e8..6c08356a 100644
--- a/theories/Reals/Cos_plus.v
+++ b/theories/Reals/Cos_plus.v
@@ -6,7 +6,7 @@
   (*         *       GNU Lesser General Public License Version 2.1        *)
   (************************************************************************)
 
-  (*i $Id: Cos_plus.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+  (*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -111,7 +111,7 @@ Proof.
     (Rsum_abs
       (fun l:nat =>
 	(-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
-	((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * 
+	((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
 	y ^ (2 * (N - l))) (pred (N - n))).
   apply Rle_trans with
     (sum_f_R0
@@ -745,42 +745,42 @@ Proof.
   exact H.
 Qed.
 
-Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. 
+Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y.
 Proof.
-  intros. 
-  cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). 
-  cut (Un_cv (C1 x y) (cos (x + y))). 
-  intros. 
-  apply UL_sequence with (C1 x y); assumption. 
-  apply C1_cvg. 
-  unfold Un_cv in |- *; unfold R_dist in |- *. 
-  intros. 
-  assert (H0 := A1_cvg x). 
-  assert (H1 := A1_cvg y). 
-  assert (H2 := B1_cvg x). 
-  assert (H3 := B1_cvg y). 
-  assert (H4 := CV_mult _ _ _ _ H0 H1). 
-  assert (H5 := CV_mult _ _ _ _ H2 H3). 
+  intros.
+  cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)).
+  cut (Un_cv (C1 x y) (cos (x + y))).
+  intros.
+  apply UL_sequence with (C1 x y); assumption.
+  apply C1_cvg.
+  unfold Un_cv in |- *; unfold R_dist in |- *.
+  intros.
+  assert (H0 := A1_cvg x).
+  assert (H1 := A1_cvg y).
+  assert (H2 := B1_cvg x).
+  assert (H3 := B1_cvg y).
+  assert (H4 := CV_mult _ _ _ _ H0 H1).
+  assert (H5 := CV_mult _ _ _ _ H2 H3).
   assert (H6 := reste_cv_R0 x y).
   unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
-  unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. 
+  unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6.
   cut (0 < eps / 3);
     [ intro
       | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
-  elim (H4 (eps / 3) H7); intros N1 H8. 
-  elim (H5 (eps / 3) H7); intros N2 H9. 
+	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H4 (eps / 3) H7); intros N1 H8.
+  elim (H5 (eps / 3) H7); intros N2 H9.
   elim (H6 (eps / 3) H7); intros N3 H10.
-  set (N := S (S (max (max N1 N2) N3))). 
-  exists N. 
-  intros. 
-  cut (n = S (pred n)). 
-  intro; rewrite H12. 
-  rewrite <- cos_plus_form. 
-  rewrite <- H12. 
+  set (N := S (S (max (max N1 N2) N3))).
+  exists N.
+  intros.
+  cut (n = S (pred n)).
+  intro; rewrite H12.
+  rewrite <- cos_plus_form.
+  rewrite <- H12.
   apply Rle_lt_trans with
     (Rabs (A1 x n * A1 y n - cos x * cos y) +
-      Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). 
+      Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))).
   replace
     (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
       (cos x * cos y - sin x * sin y)) with
@@ -788,28 +788,28 @@ Proof.
       (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n)));
     [ apply Rabs_triang | ring ].
   replace eps with (eps / 3 + (eps / 3 + eps / 3)).
-  apply Rplus_lt_compat. 
-  apply H8. 
-  unfold ge in |- *; apply le_trans with N. 
-  unfold N in |- *. 
-  apply le_trans with (max N1 N2). 
-  apply le_max_l. 
+  apply Rplus_lt_compat.
+  apply H8.
+  unfold ge in |- *; apply le_trans with N.
+  unfold N in |- *.
+  apply le_trans with (max N1 N2).
+  apply le_max_l.
   apply le_trans with (max (max N1 N2) N3).
   apply le_max_l.
   apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
-  assumption. 
+  assumption.
   apply Rle_lt_trans with
     (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
       Rabs (Reste x y (pred n))).
   apply Rabs_triang.
   apply Rplus_lt_compat.
-  rewrite <- Rabs_Ropp. 
-  rewrite Ropp_minus_distr. 
-  apply H9. 
-  unfold ge in |- *; apply le_trans with (max N1 N2). 
-  apply le_max_r. 
-  apply le_S_n. 
-  rewrite <- H12. 
+  rewrite <- Rabs_Ropp.
+  rewrite Ropp_minus_distr.
+  apply H9.
+  unfold ge in |- *; apply le_trans with (max N1 N2).
+  apply le_max_r.
+  apply le_S_n.
+  rewrite <- H12.
   apply le_trans with N.
   unfold N in |- *.
   apply le_n_S.
@@ -843,11 +843,11 @@ Proof.
   replace (S (pred N)) with N.
   assumption.
   unfold N in |- *; simpl in |- *; reflexivity.
-  cut (0 < N)%nat. 
-  intro. 
-  cut (0 < n)%nat. 
-  intro. 
+  cut (0 < N)%nat.
+  intro.
+  cut (0 < n)%nat.
+  intro.
   apply S_pred with 0%nat; assumption.
-  apply lt_le_trans with N; assumption. 
+  apply lt_le_trans with N; assumption.
   unfold N in |- *; apply lt_O_Sn.
 Qed.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index aed481c7..7a893c53 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Cos_rel.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,15 +15,15 @@ Require Import Rtrigo_def.
 Open Local Scope R_scope.
 
 Definition A1 (x:R) (N:nat) : R :=
-  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. 
- 
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N.
+
 Definition B1 (x:R) (N:nat) : R :=
   sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
-    N. 
- 
+    N.
+
 Definition C1 (x y:R) (N:nat) : R :=
-  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. 
- 
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N.
+
 Definition Reste1 (x y:R) (N:nat) : R :=
   sum_f_R0
     (fun k:nat =>
@@ -50,7 +50,7 @@ Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N).
 Theorem cos_plus_form :
  forall (x y:R) (n:nat),
    (0 < n)%nat ->
-   A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). 
+   A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
 intros.
 unfold A1, B1 in |- *.
 rewrite
@@ -244,152 +244,152 @@ apply INR_fact_neq_0.
 apply INR_fact_neq_0.
 unfold Reste2 in |- *; apply sum_eq; intros.
 apply sum_eq; intros.
-unfold Rdiv in |- *; ring. 
+unfold Rdiv in |- *; ring.
 unfold Reste1 in |- *; apply sum_eq; intros.
 apply sum_eq; intros.
 unfold Rdiv in |- *; ring.
 apply lt_O_Sn.
 Qed.
 
-Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. 
-intros. 
+Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i.
+intros.
 assert (H := pow_Rsqr x i).
 unfold Rsqr in H; exact H.
-Qed. 
- 
-Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). 
-intro. 
-assert (H := exist_cos (x * x)). 
-elim H; intros. 
-assert (p_i := p). 
-unfold cos_in in p. 
-unfold cos_n, infinite_sum in p. 
-unfold R_dist in p. 
-cut (cos x = x0). 
-intro. 
-rewrite H0. 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
-elim (p eps H1); intros. 
-exists x1; intros. 
-unfold A1 in |- *. 
+Qed.
+
+Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
+intro.
+assert (H := exist_cos (x * x)).
+elim H; intros.
+assert (p_i := p).
+unfold cos_in in p.
+unfold cos_n, infinite_sum in p.
+unfold R_dist in p.
+cut (cos x = x0).
+intro.
+rewrite H0.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (p eps H1); intros.
+exists x1; intros.
+unfold A1 in |- *.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
- (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). 
-apply H2; assumption. 
-apply sum_eq. 
-intros. 
-replace ((x * x) ^ i) with (x ^ (2 * i)). 
-reflexivity. 
-apply pow_sqr. 
-unfold cos in |- *. 
-case (exist_cos (Rsqr x)). 
-unfold Rsqr in |- *; intros. 
-unfold cos_in in p_i. 
-unfold cos_in in c. 
-apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption. 
-Qed. 
- 
-Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). 
-intros. 
-assert (H := exist_cos ((x + y) * (x + y))). 
-elim H; intros. 
-assert (p_i := p). 
-unfold cos_in in p. 
-unfold cos_n, infinite_sum in p. 
-unfold R_dist in p. 
-cut (cos (x + y) = x0). 
-intro. 
-rewrite H0. 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
-elim (p eps H1); intros. 
-exists x1; intros. 
-unfold C1 in |- *. 
+ (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n).
+apply H2; assumption.
+apply sum_eq.
+intros.
+replace ((x * x) ^ i) with (x ^ (2 * i)).
+reflexivity.
+apply pow_sqr.
+unfold cos in |- *.
+case (exist_cos (Rsqr x)).
+unfold Rsqr in |- *; intros.
+unfold cos_in in p_i.
+unfold cos_in in c.
+apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption.
+Qed.
+
+Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
+intros.
+assert (H := exist_cos ((x + y) * (x + y))).
+elim H; intros.
+assert (p_i := p).
+unfold cos_in in p.
+unfold cos_n, infinite_sum in p.
+unfold R_dist in p.
+cut (cos (x + y) = x0).
+intro.
+rewrite H0.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (p eps H1); intros.
+exists x1; intros.
+unfold C1 in |- *.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
  with
  (sum_f_R0
-    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). 
-apply H2; assumption. 
-apply sum_eq. 
-intros. 
-replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). 
-reflexivity. 
-apply pow_sqr. 
-unfold cos in |- *. 
-case (exist_cos (Rsqr (x + y))). 
-unfold Rsqr in |- *; intros. 
-unfold cos_in in p_i. 
-unfold cos_in in c. 
+    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n).
+apply H2; assumption.
+apply sum_eq.
+intros.
+replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)).
+reflexivity.
+apply pow_sqr.
+unfold cos in |- *.
+case (exist_cos (Rsqr (x + y))).
+unfold Rsqr in |- *; intros.
+unfold cos_in in p_i.
+unfold cos_in in c.
 apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
- assumption. 
-Qed. 
- 
-Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). 
-intro. 
-case (Req_dec x 0); intro. 
-rewrite H. 
-rewrite sin_0. 
-unfold B1 in |- *. 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. 
+ assumption.
+Qed.
+
+Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
+intro.
+case (Req_dec x 0); intro.
+rewrite H.
+rewrite sin_0.
+unfold B1 in |- *.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
-    n) with 0. 
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. 
-induction  n as [| n Hrecn]. 
-simpl in |- *; ring. 
-rewrite tech5; rewrite <- Hrecn. 
-simpl in |- *; ring. 
-unfold ge in |- *; apply le_O_n. 
-assert (H0 := exist_sin (x * x)). 
-elim H0; intros. 
-assert (p_i := p). 
-unfold sin_in in p. 
-unfold sin_n, infinite_sum in p. 
-unfold R_dist in p. 
-cut (sin x = x * x0). 
-intro. 
-rewrite H1. 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+    n) with 0.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+induction  n as [| n Hrecn].
+simpl in |- *; ring.
+rewrite tech5; rewrite <- Hrecn.
+simpl in |- *; ring.
+unfold ge in |- *; apply le_O_n.
+assert (H0 := exist_sin (x * x)).
+elim H0; intros.
+assert (p_i := p).
+unfold sin_in in p.
+unfold sin_n, infinite_sum in p.
+unfold R_dist in p.
+cut (sin x = x * x0).
+intro.
+rewrite H1.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
 cut (0 < eps / Rabs x);
  [ intro
  | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. 
-elim (p (eps / Rabs x) H3); intros. 
-exists x1; intros. 
-unfold B1 in |- *. 
+    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ].
+elim (p (eps / Rabs x) H3); intros.
+exists x1; intros.
+unfold B1 in |- *.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
     n) with
  (x *
-  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). 
+  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n).
 replace
  (x *
   sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
   x * x0) with
  (x *
   (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
-   x0)); [ idtac | ring ]. 
-rewrite Rabs_mult. 
-apply Rmult_lt_reg_l with (/ Rabs x). 
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. 
-rewrite <- Rmult_assoc. 
-rewrite <- Rinv_l_sym. 
+   x0)); [ idtac | ring ].
+rewrite Rabs_mult.
+apply Rmult_lt_reg_l with (/ Rabs x).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
 rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4;
- assumption. 
-apply Rabs_no_R0; assumption. 
-rewrite scal_sum. 
-apply sum_eq. 
-intros. 
-rewrite pow_add. 
-rewrite pow_sqr. 
-simpl in |- *. 
-ring. 
-unfold sin in |- *. 
-case (exist_sin (Rsqr x)). 
-unfold Rsqr in |- *; intros. 
-unfold sin_in in p_i. 
-unfold sin_in in s. 
+ assumption.
+apply Rabs_no_R0; assumption.
+rewrite scal_sum.
+apply sum_eq.
+intros.
+rewrite pow_add.
+rewrite pow_sqr.
+simpl in |- *.
+ring.
+unfold sin in |- *.
+case (exist_sin (Rsqr x)).
+unfold Rsqr in |- *; intros.
+unfold sin_in in p_i.
+unfold sin_in in s.
 assert
- (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). 
-rewrite H1; reflexivity. 
-Qed. 
+ (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s).
+rewrite H1; reflexivity.
+Qed.
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index 22a52e67..e037c77b 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i        $Id: DiscrR.v 10710 2008-03-23 09:24:09Z herbelin $       i*)
+(*i        $Id$       i*)
 
 Require Import RIneq.
 Require Import Omega.
@@ -16,14 +16,7 @@ Lemma Rlt_R0_R2 : 0 < 2.
 change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn.
 Qed.
 
-Lemma Rplus_lt_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x + y.
-intros.
-apply Rlt_trans with x.
-assumption. 
-pattern x at 1 in |- *; rewrite <- Rplus_0_r.
-apply Rplus_lt_compat_l.
-assumption.
-Qed.
+Notation Rplus_lt_pos := Rplus_lt_0_compat (only parsing).
 
 Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2.
 intros; rewrite H; reflexivity.
@@ -63,9 +56,9 @@ Ltac omega_sup :=
   change 0 with (IZR 0);
   repeat
     rewrite <- plus_IZR ||
-      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
+      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
   apply IZR_lt; omega.
-  
+
 Ltac prove_sup :=
   match goal with
   |  |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup
@@ -83,5 +76,5 @@ Ltac Rcompute :=
   change 0 with (IZR 0);
   repeat
     rewrite <- plus_IZR ||
-      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
+      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
   apply IZR_eq; try reflexivity.
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index bf729526..1c74f55a 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Exp_prop.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -46,7 +46,7 @@ Proof.
   intros; unfold E1 in |- *.
   rewrite cauchy_finite.
   unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
-    rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; 
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq;
       intros.
   rewrite binomial.
   rewrite scal_sum; apply sum_eq; intros.
@@ -125,7 +125,7 @@ Proof.
       sum_f_R0
       (fun k:nat =>
         sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
-        (pred (N - k))) (pred N)). 
+        (pred (N - k))) (pred N)).
   unfold Reste_E in |- *.
   apply Rle_trans with
     (sum_f_R0
@@ -473,7 +473,7 @@ Proof.
   apply lt_n_S; apply H.
   cut (1 < S N)%nat.
   intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
-    assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; 
+    assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4;
       elim (lt_n_O _ H4).
   apply lt_n_S; apply H.
   assert (H1 := even_odd_cor N).
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
index d4f3a8ec..774a0bd5 100644
--- a/theories/Reals/Integration.v
+++ b/theories/Reals/Integration.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Integration.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+
+(*i $Id$ i*)
 
 Require Export NewtonInt.
 Require Export RiemannInt_SF.
diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v
index 3f76e77a..b33274af 100644
--- a/theories/Reals/LegacyRfield.v
+++ b/theories/Reals/LegacyRfield.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: LegacyRfield.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Raxioms.
 Require Export LegacyField.
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
index f22e49e1..4037e3de 100644
--- a/theories/Reals/MVT.v
+++ b/theories/Reals/MVT.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: MVT.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -115,7 +115,7 @@ Proof.
           (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P))));
       [ idtac | apply pr_nu ].
   rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
-    do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; 
+    do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l;
       do 2 rewrite Rplus_0_l; reflexivity.
   unfold h in |- *; ring.
   intros; unfold h in |- *;
@@ -180,7 +180,7 @@ Proof.
   cut (derive_pt id x (X2 x x0) = 1).
   cut (derive_pt f x (X0 x x0) = f' x).
   intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
-    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry  in |- *; 
+    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry  in |- *;
       assumption.
   apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption.
   apply derive_pt_eq_0; apply derivable_pt_lim_id.
@@ -258,7 +258,7 @@ Lemma nonpos_derivative_0 :
     decreasing f -> forall x:R, derive_pt f x (pr x) <= 0.
 Proof.
   intros f pr H x; assert (H0 := H); unfold decreasing in H0;
-    generalize (derivable_derive f x (pr x)); intro; elim H1; 
+    generalize (derivable_derive f x (pr x)); intro; elim H1;
       intros l H2.
   rewrite H2; case (Rtotal_order l 0); intro.
   left; assumption.
@@ -282,7 +282,7 @@ Proof.
   intro.
   generalize
     (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2)))
-      (- (l / 2)) H15). 
+      (- (l / 2)) H15).
   repeat rewrite Ropp_involutive.
   intro.
   generalize
@@ -432,7 +432,7 @@ Lemma strictincreasing_strictdecreasing_opp :
   forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
 Proof.
   unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros;
-    generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; 
+    generalize (H x y H0); intro; apply Ropp_lt_gt_contravar;
       assumption.
 Qed.
 
@@ -467,14 +467,14 @@ Qed.
 (**********)
 Lemma null_derivative_0 :
   forall (f:R -> R) (pr:derivable f),
-    constant f -> forall x:R, derive_pt f x (pr x) = 0. 
+    constant f -> forall x:R, derive_pt f x (pr x) = 0.
 Proof.
   intros.
   unfold constant in H.
   apply derive_pt_eq_0.
   intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros.
   rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *;
-    rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; 
+    rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r;
       rewrite Rabs_R0; assumption.
 Qed.
 
@@ -576,7 +576,7 @@ Lemma derive_increasing_interv_var :
     forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y.
 Proof.
   intros a b f pr H H0 x y H1 H2 H3;
-    generalize (derive_increasing_interv_ax a b f pr H); 
+    generalize (derive_increasing_interv_ax a b f pr H);
       intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3).
 Qed.
 
@@ -618,7 +618,7 @@ Proof.
   cut (derivable (g - f)).
   intro X.
   cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0).
-  intro. 
+  intro.
   assert (H2 := IAF (g - f)%F a b 0 X H H1).
   rewrite Rmult_0_l in H2; unfold minus_fct in H2.
   apply Rplus_le_reg_l with (- f b + f a).
@@ -697,11 +697,11 @@ Proof.
     clear H0; intros H0 _; exists (g1 a - g2 a); intros;
       assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
   intros; unfold derivable_pt in |- *; exists (f x0); elim (H x0 H3);
-    intros; eapply derive_pt_eq_1; symmetry  in |- *; 
+    intros; eapply derive_pt_eq_1; symmetry  in |- *;
       apply H4.
   assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
   intros; unfold derivable_pt in |- *; exists (f x0);
-    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry  in |- *; 
+    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry  in |- *;
       apply H5.
   assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
   intros; elim H5; intros; apply derivable_pt_minus;
@@ -717,6 +717,6 @@ Proof.
   apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
     eapply derive_pt_eq_1; symmetry  in |- *; apply H10.
   assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
-    unfold constant_D_eq in H8; assert (H9 := H8 _ H2); 
+    unfold constant_D_eq in H8; assert (H9 := H8 _ H2);
       unfold minus_fct in H9; rewrite <- H9; ring.
 Qed.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
index 47ae149e..74bcf7dc 100644
--- a/theories/Reals/NewtonInt.v
+++ b/theories/Reals/NewtonInt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: NewtonInt.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -31,7 +31,7 @@ Lemma FTCN_step1 :
     Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b.
 Proof.
   intros f a b; unfold Newton_integrable in |- *; exists (d1 f);
-    unfold antiderivative in |- *; intros; case (Rle_dec a b); 
+    unfold antiderivative in |- *; intros; case (Rle_dec a b);
       intro;
         [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ]
           | right; split;
@@ -229,15 +229,15 @@ Lemma NewtonInt_P6 :
     l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
 Proof.
   intros f g l a b pr1 pr2; unfold NewtonInt in |- *;
-    case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; 
-      intros; case pr2; intros; case (total_order_T a b); 
+    case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1;
+      intros; case pr2; intros; case (total_order_T a b);
         intro.
   elim s; intro.
   elim o; intro.
   elim o0; intro.
   elim o1; intro.
   assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1);
-    assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
+    assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2);
       elim H3; intros; assert (H5 : a <= a <= b).
   split; [ right; reflexivity | left; assumption ].
   assert (H6 : a <= b <= b).
@@ -260,7 +260,7 @@ Proof.
   unfold antiderivative in H1; elim H1; intros;
     elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)).
   assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1);
-    assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
+    assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2);
       elim H3; intros; assert (H5 : b <= a <= a).
   split; [ left; assumption | right; reflexivity ].
   assert (H6 : b <= b <= a).
@@ -313,7 +313,7 @@ Proof.
   apply RRle_abs.
   apply H13.
   apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
-    rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; 
+    rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *;
       apply Rmin_r.
   elim n; left; assumption.
   assert
@@ -396,7 +396,7 @@ Proof.
   cut (b < x + h).
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)).
   apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- h);
-    [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); 
+    [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b);
     [ idtac | ring ]; apply Rle_lt_trans with (Rabs h).
   rewrite <- Rabs_Ropp; apply RRle_abs.
   apply Rlt_le_trans with D.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index e122a26a..97793386 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PSeries_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -19,13 +19,13 @@ Open Local Scope R_scope.
 Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
 
 (** Uniform convergence *)
-Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) 
+Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R)
   (r:posreal) : Prop :=
   forall eps:R,
     0 < eps ->
     exists N : nat,
       (forall (n:nat) (y:R),
-        (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). 
+        (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps).
 
 (** Normal convergence *)
 Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type :=
@@ -37,7 +37,7 @@ Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type :=
 Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r.
 
 Definition SFL (fn:nat -> R -> R)
-  (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) 
+  (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l })
   (y:R) : R := let (a,_) := cv y in a.
 
 (** In a complete space, normal convergence implies uniform convergence *)
@@ -94,7 +94,7 @@ Lemma CVU_continuity :
     forall y:R, Boule x r y -> continuity_pt f y.
 Proof.
   intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
       simpl in |- *; unfold R_dist in |- *; intros.
   unfold CVU in H.
   cut (0 < eps / 3);
@@ -219,11 +219,11 @@ Proof.
   intros; apply (H n y).
   apply H1.
   unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r;
-    pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; 
+    pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
       apply Rplus_lt_compat_l; apply Rlt_0_1.
 Qed.
 
-(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) 
+(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *)
 Lemma CVN_R_CVS :
   forall fn:nat -> R -> R,
     CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }.
@@ -256,7 +256,7 @@ Proof.
   intro; apply Rle_trans with (Rabs (An n)).
   apply Rabs_pos.
   unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
-    rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; 
+    rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *;
       rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
   apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
 Qed.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
index d5ae2aca..6a33b809 100644
--- a/theories/Reals/PartSum.v
+++ b/theories/Reals/PartSum.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PartSum.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -31,7 +31,7 @@ Lemma tech2 :
   forall (An:nat -> R) (m n:nat),
     (m < n)%nat ->
     sum_f_R0 An n =
-    sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). 
+    sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m).
 Proof.
   intros; induction  n as [| n Hrecn].
   elim (lt_n_O _ H).
@@ -155,7 +155,7 @@ Lemma tech12 :
 Proof.
   intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H;
     assumption.
-Qed. 
+Qed.
 
 Lemma scal_sum :
   forall (An:nat -> R) (N:nat) (x:R),
@@ -256,12 +256,12 @@ Qed.
 
 Lemma minus_sum :
   forall (An Bn:nat -> R) (N:nat),
-    sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. 
+    sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N.
 Proof.
-  intros; induction  N as [| N HrecN]. 
-  simpl in |- *; ring. 
-  do 3 rewrite tech5; rewrite HrecN; ring. 
-Qed. 
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; ring.
+  do 3 rewrite tech5; rewrite HrecN; ring.
+Qed.
 
 Lemma sum_decomposition :
   forall (An:nat -> R) (N:nat),
@@ -346,7 +346,7 @@ Qed.
 (**********)
 Lemma Rabs_triang_gen :
   forall (An:nat -> R) (N:nat),
-    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. 
+    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N.
 Proof.
   intros.
   induction  N as [| N HrecN].
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index c07b86a6..2b6af10e 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RIneq.v 11887 2009-02-06 19:57:33Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*********************************************************)
 (** * Basic lemmas for the classical real numbers        *)
@@ -19,8 +20,8 @@ Require Export ZArithRing.
 Require Import Omega.
 Require Export RealField.
 
-Open Local Scope Z_scope.
-Open Local Scope R_scope.
+Local Open Scope Z_scope.
+Local Open Scope R_scope.
 
 Implicit Type r : R.
 
@@ -75,7 +76,7 @@ Hint Resolve Rlt_dichotomy_converse: real.
 Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2.
 Proof.
   intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
-    intuition eauto 3. 
+    intuition eauto 3.
 Qed.
 Hint Resolve Req_dec: real.
 
@@ -129,7 +130,7 @@ Hint Immediate Rge_le: rorders.
 
 (**********)
 Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1.
-Proof. 
+Proof.
   trivial.
 Qed.
 Hint Resolve Rlt_gt: rorders.
@@ -291,7 +292,7 @@ Proof. eauto using Rlt_trans with rorders. Qed.
 (**********)
 Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
 Proof.
-  generalize Rlt_trans Rlt_eq_compat. 
+  generalize Rlt_trans Rlt_eq_compat.
   unfold Rle in |- *.
   intuition eauto 2.
 Qed.
@@ -456,7 +457,7 @@ Proof.
   rewrite Rplus_comm; auto with real.
 Qed.
 
-(*********************************************************)       
+(*********************************************************)
 (** ** Multiplication                                    *)
 (*********************************************************)
 
@@ -515,6 +516,13 @@ 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.
+  intros.
+  rewrite <- 2!(Rmult_comm r).
+  now apply Rmult_eq_compat_l.
+Qed.
+
 (**********)
 Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2.
 Proof.
@@ -525,6 +533,13 @@ Proof.
   field; trivial.
 Qed.
 
+Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2.
+Proof.
+  intros.
+  apply Rmult_eq_reg_l with (2 := H0).
+  now rewrite 2!(Rmult_comm r).
+Qed.
+
 (**********)
 Lemma Rmult_integral : forall r1 r2, r1 * r2 = 0 -> r1 = 0 \/ r2 = 0.
 Proof.
@@ -554,13 +569,13 @@ Proof.
   auto with real.
 Qed.
 
-(**********) 
+(**********)
 Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0.
 Proof.
   intros r1 r2 H; split; red in |- *; intro; apply H; auto with real.
 Qed.
 
-(**********) 
+(**********)
 Lemma Rmult_integral_contrapositive :
   forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0.
 Proof.
@@ -569,11 +584,11 @@ Proof.
 Qed.
 Hint Resolve Rmult_integral_contrapositive: real.
 
-Lemma Rmult_integral_contrapositive_currified : 
+Lemma Rmult_integral_contrapositive_currified :
   forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0.
 Proof. auto using Rmult_integral_contrapositive. Qed.
 
-(**********) 
+(**********)
 Lemma Rmult_plus_distr_r :
   forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3.
 Proof.
@@ -743,7 +758,7 @@ Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2.
 Proof.
   red in |- *; intros; elim H; rewrite H0; ring.
 Qed.
-Hint Resolve Rminus_not_eq_right: real. 
+Hint Resolve Rminus_not_eq_right: real.
 
 (**********)
 Lemma Rmult_minus_distr_l :
@@ -973,6 +988,13 @@ Proof.
   right; apply (Rplus_eq_reg_l r r1 r2 H0).
 Qed.
 
+Lemma Rplus_le_reg_r : forall r r1 r2, r1 + r <= r2 + r -> r1 <= r2.
+Proof.
+  intros.
+  apply (Rplus_le_reg_l r).
+  now rewrite 2!(Rplus_comm r).
+Qed.
+
 Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2.
 Proof.
   unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H).
@@ -1261,12 +1283,20 @@ Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
 Proof.
   intros z x y H H0.
   case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0.
-  rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto.
-  generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False;
-    generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); 
+  rewrite Eq0 in H0; exfalso; apply (Rlt_irrefl (z * y)); auto.
+  generalize (Rmult_lt_compat_l z y x H Eq0); intro; exfalso;
+    generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1);
       intro; apply (Rlt_irrefl (z * x)); auto.
 Qed.
 
+Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 0 < r -> r1 * r < r2 * r -> r1 < r2.
+Proof.
+  intros.
+  apply Rmult_lt_reg_l with r.
+  exact H.
+  now rewrite 2!(Rmult_comm r).
+Qed.
+
 Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
 Proof. eauto using Rmult_lt_reg_l with rorders. Qed.
 
@@ -1282,6 +1312,14 @@ Proof.
   rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
 Qed.
 
+Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2.
+Proof.
+  intros.
+  apply Rmult_le_reg_l with r.
+  exact H.
+  now rewrite 2!(Rmult_comm r).
+Qed.
+
 (*********************************************************)
 (** ** Order and substraction                            *)
 (*********************************************************)
@@ -1296,7 +1334,7 @@ Qed.
 Hint Resolve Rlt_minus: real.
 
 Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0.
-Proof. 
+Proof.
   intros; apply (Rplus_lt_reg_r r2).
   replace (r2 + (r1 - r2)) with r1.
   replace (r2 + 0) with r2; auto with real.
@@ -1310,7 +1348,7 @@ Proof.
 Qed.
 
 Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0.
-Proof. 
+Proof.
   destruct 1.
     auto using Rgt_minus, Rgt_ge.
     right; auto using Rminus_diag_eq with rorders.
@@ -1463,7 +1501,7 @@ Proof.
 Qed.
 Hint Resolve Rinv_1_lt_contravar: real.
 
-(*********************************************************)        
+(*********************************************************)
 (** ** Miscellaneous                                     *)
 (*********************************************************)
 
@@ -1491,7 +1529,7 @@ Proof.
   pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real.
 Qed.
 
-(*********************************************************) 
+(*********************************************************)
 (** ** Injection from [N] to [R]                         *)
 (*********************************************************)
 
@@ -1508,7 +1546,7 @@ Proof.
 Qed.
 
 (**********)
-Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. 
+Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m.
 Proof.
   intros n m; induction  n as [| n Hrecn].
   simpl in |- *; auto with real.
@@ -1581,11 +1619,11 @@ Hint Resolve pos_INR: real.
 Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat.
 Proof.
   double induction n m; intros.
-  simpl in |- *; elimtype False; apply (Rlt_irrefl 0); auto.
+  simpl in |- *; exfalso; apply (Rlt_irrefl 0); auto.
   auto with arith.
   generalize (pos_INR (S n0)); intro; cut (INR 0 = 0);
-    [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. 
-  generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; elimtype False;
+    [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ].
+  generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; exfalso;
     apply (Rlt_irrefl 0); auto.
   do 2 rewrite S_INR in H1; cut (INR n1 < INR n0).
   intro H2; generalize (H0 n0 H2); intro; auto with arith.
@@ -1627,7 +1665,7 @@ Proof.
   intros n m H; case (le_or_lt n m); intros H1.
   case (le_lt_or_eq _ _ H1); intros H2.
   apply Rlt_dichotomy_converse; auto with real.
-  elimtype False; auto.
+  exfalso; auto.
   apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real.
 Qed.
 Hint Resolve not_INR: real.
@@ -1637,10 +1675,10 @@ Proof.
   intros; case (le_or_lt n m); intros H1.
   case (le_lt_or_eq _ _ H1); intros H2; auto.
   cut (n <> m).
-  intro H3; generalize (not_INR n m H3); intro H4; elimtype False; auto.
+  intro H3; generalize (not_INR n m H3); intro H4; exfalso; auto.
   omega.
   symmetry  in |- *; cut (m <> n).
-  intro H3; generalize (not_INR m n H3); intro H4; elimtype False; auto.
+  intro H3; generalize (not_INR m n H3); intro H4; exfalso; auto.
   omega.
 Qed.
 Hint Resolve INR_eq: real.
@@ -1659,7 +1697,7 @@ Proof.
 Qed.
 Hint Resolve not_1_INR: real.
 
-(*********************************************************) 
+(*********************************************************)
 (** ** Injection from [Z] to [R]                         *)
 (*********************************************************)
 
@@ -1741,17 +1779,26 @@ Proof.
 Qed.
 
 (**********)
-Lemma Ropp_Ropp_IZR : forall n:Z, IZR (- n) = - IZR n.
+Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n.
 Proof.
   intro z; case z; simpl in |- *; auto with real.
 Qed.
 
+Definition Ropp_Ropp_IZR := opp_IZR.
+
+Lemma minus_IZR : forall n m:Z, IZR (n - m) = IZR n - IZR m.
+Proof.
+  intros; unfold Zminus, Rminus.
+  rewrite <- opp_IZR.
+  apply plus_IZR.
+Qed.
+
 (**********)
 Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m).
 Proof.
   intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *.
   rewrite <- (Ropp_Ropp_IZR z2); symmetry  in |- *; apply plus_IZR.
-Qed. 
+Qed.
 
 (**********)
 Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
@@ -1766,7 +1813,7 @@ Qed.
 (**********)
 Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z.
 Proof.
-  intros z1 z2 H; apply Zlt_0_minus_lt. 
+  intros z1 z2 H; apply Zlt_0_minus_lt.
   apply lt_0_IZR.
   rewrite <- Z_R_minus.
   exact (Rgt_minus (IZR z2) (IZR z1) H).
@@ -1785,7 +1832,7 @@ Qed.
 Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m.
 Proof.
   intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H);
-    rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); 
+    rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0);
       intro; omega.
 Qed.
 
@@ -1837,7 +1884,7 @@ Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m.
 Proof.
   intros m n H; cut (m <= n)%Z.
   intro H0; elim (IZR_le m n H0); intro; auto.
-  generalize (eq_IZR m n H1); intro; elimtype False; omega.
+  generalize (eq_IZR m n H1); intro; exfalso; omega.
   omega.
 Qed.
 
@@ -1935,7 +1982,7 @@ Proof.
         rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; replace (2 * x) with (x + x).
   rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption.
-  ring. 
+  ring.
   replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ].
   pattern y at 2 in |- *; replace y with (y / 2 + y / 2).
   unfold Rminus, Rdiv in |- *.
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
index 19f2b4ff..545bd68b 100644
--- a/theories/Reals/RList.v
+++ b/theories/Reals/RList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RList.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -16,7 +16,7 @@ Inductive Rlist : Type :=
 | nil : Rlist
 | cons : R -> Rlist -> Rlist.
 
-Fixpoint In (x:R) (l:Rlist) {struct l} : Prop :=
+Fixpoint In (x:R) (l:Rlist) : Prop :=
   match l with
     | nil => False
     | cons a l' => x = a \/ In x l'
@@ -70,7 +70,7 @@ Proof.
   reflexivity.
 Qed.
 
-Fixpoint AbsList (l:Rlist) (x:R) {struct l} : Rlist :=
+Fixpoint AbsList (l:Rlist) (x:R) : Rlist :=
   match l with
     | nil => nil
     | cons a l' => cons (Rabs (a - x) / 2) (AbsList l' x)
@@ -144,13 +144,13 @@ Proof.
   induction  l as [| r0 l Hrecl0].
   simpl in |- *; left; reflexivity.
   change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *;
-    unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); 
+    unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l)));
       intro.
   right; apply Hrecl; exists r0; left; reflexivity.
   left; reflexivity.
 Qed.
 
-Fixpoint pos_Rl (l:Rlist) (i:nat) {struct l} : R :=
+Fixpoint pos_Rl (l:Rlist) (i:nat) : R :=
   match l with
     | nil => 0
     | cons a l' => match i with
@@ -221,7 +221,7 @@ Qed.
 Definition ordered_Rlist (l:Rlist) : Prop :=
   forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <= pos_Rl l (S i).
 
-Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist :=
+Fixpoint insert (l:Rlist) (x:R) : Rlist :=
   match l with
     | nil => cons x nil
     | cons a l' =>
@@ -231,25 +231,25 @@ Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist :=
       end
   end.
 
-Fixpoint cons_Rlist (l k:Rlist) {struct l} : Rlist :=
+Fixpoint cons_Rlist (l k:Rlist) : Rlist :=
   match l with
     | nil => k
     | cons a l' => cons a (cons_Rlist l' k)
   end.
 
-Fixpoint cons_ORlist (k l:Rlist) {struct k} : Rlist :=
+Fixpoint cons_ORlist (k l:Rlist) : Rlist :=
   match k with
     | nil => l
     | cons a k' => cons_ORlist k' (insert l a)
   end.
 
-Fixpoint app_Rlist (l:Rlist) (f:R -> R) {struct l} : Rlist :=
+Fixpoint app_Rlist (l:Rlist) (f:R -> R) : Rlist :=
   match l with
     | nil => nil
     | cons a l' => cons (f a) (app_Rlist l' f)
   end.
 
-Fixpoint mid_Rlist (l:Rlist) (x:R) {struct l} : Rlist :=
+Fixpoint mid_Rlist (l:Rlist) (x:R) : Rlist :=
   match l with
     | nil => nil
     | cons a l' => cons ((x + a) / 2) (mid_Rlist l' a)
@@ -395,8 +395,8 @@ Lemma RList_P7 :
     ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)).
 Proof.
   intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H);
-    clear H1 H2; assert (H1 := RList_P3 l x); elim H1; 
-      clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; 
+    clear H1 H2; assert (H1 := RList_P3 l x); elim H1;
+      clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4;
         intros; elim H4; clear H4; intros; rewrite H4;
           assert (H6 : Rlength l = S (pred (Rlength l))).
   apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
@@ -468,7 +468,7 @@ Proof.
   simple induction l1;
     [ intro; reflexivity
       | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10;
-        apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; 
+        apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
           rewrite S_INR; ring ].
 Qed.
 
@@ -495,7 +495,7 @@ Proof.
   reflexivity.
   change
     (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) =
-      (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) 
+      (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2)
     in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption.
 Qed.
 
@@ -528,7 +528,7 @@ Proof.
           In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2));
         [ elim
           (RList_P3 (cons_ORlist (cons r l1) l2)
-            (pos_Rl (cons_ORlist (cons r l1) l2) 0)); 
+            (pos_Rl (cons_ORlist (cons r l1) l2) 0));
           intros; apply H3; exists 0%nat; split;
             [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]
           | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0));
@@ -547,7 +547,7 @@ Lemma RList_P16 :
 Proof.
   intros; apply Rle_antisym.
   induction  l1 as [| r l1 Hrecl1].
-  simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption. 
+  simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption.
   assert
     (H2 :
       In
@@ -557,13 +557,13 @@ Proof.
     [ elim
       (RList_P3 (cons_ORlist (cons r l1) l2)
         (pos_Rl (cons_ORlist (cons r l1) l2)
-          (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
+          (pred (Rlength (cons_ORlist (cons r l1) l2)))));
       intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2)));
         split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]
       | elim
         (RList_P9 (cons r l1) l2
           (pos_Rl (cons_ORlist (cons r l1) l2)
-            (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
+            (pred (Rlength (cons_ORlist (cons r l1) l2)))));
         intros; assert (H5 := H3 H2); elim H5; intro;
           [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ].
   induction  l1 as [| r l1 Hrecl1].
@@ -576,19 +576,19 @@ Proof.
           In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/
           In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2);
         [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *;
-          elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); 
+          elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1)));
             intros; apply H5; exists (Rlength l1); split;
               [ reflexivity | simpl in |- *; apply lt_n_Sn ]
           | assert (H5 := H3 H4); apply RList_P7;
             [ apply RList_P2; assumption
               | elim
                 (RList_P9 (cons r l1) l2
-                  (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
+                  (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
                 intros; apply H7; left;
                   elim
                     (RList_P3 (cons r l1)
-                      (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
-                    intros; apply H9; exists (pred (Rlength (cons r l1))); 
+                      (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
+                    intros; apply H9; exists (pred (Rlength (cons r l1)));
                       split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ].
 Qed.
 
@@ -643,7 +643,7 @@ Lemma RList_P20 :
   forall l:Rlist,
     (2 <= Rlength l)%nat ->
     exists r : R,
-      (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). 
+      (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))).
 Proof.
   intros; induction  l as [| r l Hrecl];
     [ simpl in H; elim (le_Sn_O _ H)
@@ -720,7 +720,7 @@ Proof.
   simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn.
   change
     (pos_Rl (cons_Rlist (cons r1 r2) l2) i <=
-      pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; 
+      pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *;
     apply (H i); simpl in |- *; apply lt_S_n; assumption.
 Qed.
 
diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v
new file mode 100644
index 00000000..2b302386
--- /dev/null
+++ b/theories/Reals/ROrderedType.v
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Rbase Equalities Orders OrdersTac.
+
+Local Open Scope R_scope.
+
+(** * DecidableType structure for real numbers *)
+
+Lemma Req_dec : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
+Proof.
+  intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
+    intuition eauto 3.
+Qed.
+
+Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false.
+Lemma Reqb_eq : forall r1 r2, Reqb r1 r2 = true <-> r1=r2.
+Proof.
+ intros; unfold Reqb; destruct Req_dec as [EQ|NEQ]; auto with *.
+ split; try discriminate. intro EQ; elim NEQ; auto.
+Qed.
+
+Module R_as_UBE <: UsualBoolEq.
+ Definition t := R.
+ Definition eq := @eq R.
+ Definition eqb := Reqb.
+ Definition eqb_eq := Reqb_eq.
+End R_as_UBE.
+
+Module R_as_DT <: UsualDecidableTypeFull := Make_UDTF R_as_UBE.
+
+(** Note that the last module fulfills by subtyping many other
+    interfaces, such as [DecidableType] or [EqualityType]. *)
+
+
+
+(** Note that [R_as_DT] can also be seen as a [DecidableType]
+    and a [DecidableTypeOrig]. *)
+
+
+
+(** * OrderedType structure for binary integers *)
+
+
+
+Definition Rcompare x y :=
+ match total_order_T x y with
+  | inleft (left _) => Lt
+  | inleft (right _) => Eq
+  | inright _ => Gt
+ end.
+
+Lemma Rcompare_spec : forall x y, CompSpec eq Rlt x y (Rcompare x y).
+Proof.
+ intros. unfold Rcompare.
+ destruct total_order_T as [[H|H]|H]; auto.
+Qed.
+
+Module R_as_OT <: OrderedTypeFull.
+ Include R_as_DT.
+ Definition lt := Rlt.
+ Definition le := Rle.
+ Definition compare := Rcompare.
+
+ Instance lt_strorder : StrictOrder Rlt.
+ Proof. split; [ exact Rlt_irrefl | exact Rlt_trans ]. Qed.
+
+ Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Rlt.
+ Proof. repeat red; intros; subst; auto. Qed.
+
+ Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y.
+ Proof. unfold Rle; auto with *. Qed.
+
+ Definition compare_spec := Rcompare_spec.
+
+End R_as_OT.
+
+(** Note that [R_as_OT] can also be seen as a [UsualOrderedType]
+   and a [OrderedType] (and also as a [DecidableType]). *)
+
+
+
+(** * An [order] tactic for real numbers *)
+
+Module ROrder := OTF_to_OrderTac R_as_OT.
+Ltac r_order := ROrder.order.
+
+(** Note that [r_order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
+
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
index 82d7bebd..57b2c767 100644
--- a/theories/Reals/R_Ifp.v
+++ b/theories/Reals/R_Ifp.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_Ifp.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (**********************************************************)
 (** Complements for the reals.Integer and fractional part *)
@@ -32,10 +32,10 @@ Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r.
 Proof.
   intros; generalize (archimed r); intro; elim H1; intros; clear H1;
     unfold Rgt in H2; unfold Rminus in H3;
-      generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); 
+      generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3);
         intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
           rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
-            rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); 
+            rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r)));
               intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
                 auto with zarith real.
 Qed.
@@ -56,15 +56,15 @@ Qed.
 Lemma fp_R0 : frac_part 0 = 0.
 Proof.
   unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
-    unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); 
-      intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; 
+    unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1)));
+      intros a b; rewrite b; clear a b; rewrite <- Z_R_minus;
         cut (up 0 = 1%Z).
   intro; rewrite H1;
-    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); 
-      apply Ropp_0. 
+    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1)));
+      apply Ropp_0.
   elim (archimed 0); intros; clear H2; unfold Rgt in H1;
     rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
-      intro; clear H1; generalize (le_IZR_R1 (up 0) H0); 
+      intro; clear H1; generalize (le_IZR_R1 (up 0) H0);
         intro; clear H H0; omega.
 Qed.
 
@@ -92,12 +92,12 @@ Proof.
         apply Rge_minus; auto with zarith real.
   rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
     auto with zarith real.
-    (*inf a 1*) 
+    (*inf a 1*)
   cut (r - IZR (up r) < 0).
   rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
     rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
-      fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; 
-        elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; 
+      fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive;
+        elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *;
           rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
             apply Rplus_lt_compat_l; auto with zarith real.
   elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
@@ -110,7 +110,7 @@ Qed.
 
 (**********)
 Lemma base_Int_part :
-  forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. 
+  forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1.
 Proof.
   intro; unfold Int_part in |- *; elim (archimed r); intros.
   split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
@@ -122,13 +122,13 @@ Proof.
             apply Rminus_le; auto with zarith real.
   generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
     rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
-      generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); 
+      generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1);
         intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
           fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
             rewrite (Rplus_comm (- r) (-1 + r)) in H2;
               rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
-                elim (Rplus_ne (-1)); intros a b; rewrite a in H2; 
-                  clear a b; auto with zarith real.  
+                elim (Rplus_ne (-1)); intros a b; rewrite a in H2;
+                  clear a b; auto with zarith real.
 Qed.
 
 (**********)
@@ -168,19 +168,19 @@ Lemma Rminus_Int_part1 :
 Proof.
   intros; elim (base_fp r1); elim (base_fp r2); intros;
     generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
-      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
+      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
         intro; clear H4; rewrite Ropp_0 in H0;
-          generalize (Rge_le 0 (- frac_part r2) H0); intro; 
-            clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
+          generalize (Rge_le 0 (- frac_part r2) H0); intro;
+            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
               intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                 intro; clear H1; unfold Rgt in H2;
                   generalize
                     (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
-                    intro; elim H1; intros; clear H1; elim (Rplus_ne 1); 
+                    intro; elim H1; intros; clear H1; elim (Rplus_ne 1);
                       intros a b; rewrite a in H6; clear a b H5;
-                        generalize (Rge_minus (frac_part r1) (frac_part r2) H); 
+                        generalize (Rge_minus (frac_part r1) (frac_part r2) H);
                           intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
-                            generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); 
+                            generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1);
                               intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
                                 unfold Rminus in H6, H;
                                   rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
@@ -195,7 +195,7 @@ Proof.
                                                   fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
                                                     generalize
                                                       (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
-                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); 
+                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H);
                                                       intro; clear H;
                                                         rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                           rewrite <-
@@ -209,9 +209,9 @@ Proof.
                                                                   (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                     (- IZR (Int_part r1))) in H0;
                                                                   rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
-                                                                    elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
+                                                                    elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                       rewrite b in H0; clear a b;
-                                                                        elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); 
+                                                                        elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2)));
                                                                           intros a b; rewrite a in H0; clear a b;
                                                                             rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
                                                                               intros a b; rewrite b in H0; clear a b;
@@ -229,7 +229,7 @@ Proof.
                                                                                                   fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
                                                                                                     generalize
                                                                                                       (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
-                                                                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); 
+                                                                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6);
                                                                                                       intro; clear H6;
                                                                                                         rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                                                                           rewrite <-
@@ -238,14 +238,14 @@ Proof.
                                                                                                             in H;
                                                                                                             rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                                                                               rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
-                                                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
+                                                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                                                                   clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
-                                                                                                                    rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
+                                                                                                                    rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                                                       cut (1 = IZR 1); auto with zarith real.
   intro; rewrite H1 in H; clear H1;
     rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
-      generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); 
-        intros; clear H H0; unfold Int_part at 1 in |- *; 
+      generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
+        intros; clear H H0; unfold Int_part at 1 in |- *;
           omega.
 Qed.
 
@@ -257,18 +257,18 @@ Lemma Rminus_Int_part2 :
 Proof.
   intros; elim (base_fp r1); elim (base_fp r2); intros;
     generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
-      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
+      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
         intro; clear H4; rewrite Ropp_0 in H0;
-          generalize (Rge_le 0 (- frac_part r2) H0); intro; 
-            clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
+          generalize (Rge_le 0 (- frac_part r2) H0); intro;
+            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
               intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                 intro; clear H1; unfold Rgt in H2;
                   generalize
                     (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
-                    intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); 
+                    intro; elim H1; intros; clear H1; elim (Rplus_ne (-1));
                       intros a b; rewrite b in H5; clear a b H6;
-                        generalize (Rlt_minus (frac_part r1) (frac_part r2) H); 
-                          intro; clear H; fold (frac_part r1 - frac_part r2) in H5; 
+                        generalize (Rlt_minus (frac_part r1) (frac_part r2) H);
+                          intro; clear H; fold (frac_part r1 - frac_part r2) in H5;
                             clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
                               rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
                                 rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
@@ -283,7 +283,7 @@ Proof.
                                               fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
                                                 generalize
                                                   (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
-                                                    (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); 
+                                                    (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5);
                                                   intro; clear H5;
                                                     rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                       rewrite <-
@@ -297,9 +297,9 @@ Proof.
                                                               (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                 (- IZR (Int_part r1))) in H;
                                                               rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
-                                                                elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
+                                                                elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                   rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
-                                                                    elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
+                                                                    elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                       clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
                                                                         fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
                                                                           rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
@@ -315,7 +315,7 @@ Proof.
                                                                                           fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
                                                                                             generalize
                                                                                               (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
-                                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); 
+                                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1);
                                                                                               intro; clear H1;
                                                                                                 rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                                                                   rewrite <-
@@ -324,21 +324,21 @@ Proof.
                                                                                                     in H0;
                                                                                                     rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                                                                                       rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
-                                                                                                        elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; 
+                                                                                                        elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0;
                                                                                                           clear a b; rewrite <- (Rplus_opp_l 1) in H0;
                                                                                                             rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
                                                                                                               in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
                                                                                                                 rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
-                                                                                                                  rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
+                                                                                                                  rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                                                     cut (1 = IZR 1); auto with zarith real.
   intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
     rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
       rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
         rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
-          generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); 
+          generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H);
             intro; clear H;
-              generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); 
-                intros; clear H0 H1; unfold Int_part at 1 in |- *; 
+              generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0);
+                intros; clear H0 H1; unfold Int_part at 1 in |- *;
                   omega.
 Qed.
 
@@ -358,7 +358,7 @@ Proof.
                 rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                   rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                     rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
-                      rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
+                      rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                         auto with zarith real.
 Qed.
 
@@ -370,7 +370,7 @@ Lemma Rminus_fp2 :
 Proof.
   intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
     intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
-      rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); 
+      rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
         unfold Rminus in |- *;
           rewrite
             (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
@@ -385,7 +385,7 @@ Proof.
                           rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                             rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                               rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
-                                rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
+                                rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                                   auto with zarith real.
 Qed.
 
@@ -397,11 +397,11 @@ Lemma plus_Int_part1 :
 Proof.
   intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
     elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
-      generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); 
-        intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); 
+      generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3);
+        intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1);
           intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
             generalize
-              (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); 
+              (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2);
               intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
                 unfold frac_part in H0, H1; unfold Rminus in H0, H1;
                   rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
@@ -422,11 +422,11 @@ Proof.
                                         rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                           generalize
                                             (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
-                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); 
+                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0);
                                             intro; clear H0;
                                               generalize
                                                 (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
-                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); 
+                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1);
                                                 intro; clear H1;
                                                   rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                     in H;
@@ -434,7 +434,7 @@ Proof.
                                                       (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                         (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                       in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
-                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; 
+                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H;
                                                           clear a b;
                                                             rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                               in H0;
@@ -442,7 +442,7 @@ Proof.
                                                                 (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                   (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                 in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
-                                                                  elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; 
+                                                                  elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0;
                                                                     clear a b;
                                                                       rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
                                                                         cut (1 = IZR 1); auto with zarith real.
@@ -452,7 +452,7 @@ Proof.
         rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
           rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
             rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
-              generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); 
+              generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0);
                 intro; clear H H0; unfold Int_part at 1 in |- *; omega.
 Qed.
 
@@ -465,8 +465,8 @@ Proof.
   intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
     generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
       generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
-        generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); 
-          intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; 
+        generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1);
+          intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b;
             rewrite a in H2; clear a b;
               generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
                 intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
@@ -487,11 +487,11 @@ Proof.
                                         rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                           generalize
                                             (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
-                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); 
+                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1);
                                             intro; clear H1;
                                               generalize
                                                 (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
-                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); 
+                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H);
                                                 intro; clear H;
                                                   rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                     in H1;
@@ -499,7 +499,7 @@ Proof.
                                                       (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                         (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                       in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
-                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; 
+                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1;
                                                           clear a b;
                                                             rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                               in H0;
@@ -507,7 +507,7 @@ Proof.
                                                                 (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                   (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                 in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
-                                                                  elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); 
+                                                                  elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2)));
                                                                     intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
                                                                       intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
                                                                         auto with zarith real.
@@ -515,8 +515,8 @@ Proof.
     rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
       rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
         rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
-          generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); 
-            intro; clear H0 H1; unfold Int_part at 1 in |- *; 
+          generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1);
+            intro; clear H0 H1; unfold Int_part at 1 in |- *;
               omega.
 Qed.
 
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index 17b6c60d..6460a927 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_sqr.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rbasic_fun.
@@ -61,7 +61,7 @@ Proof.
       | elim H0; intro;
         [ elim H; symmetry  in |- *; exact H1
           | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1);
-            rewrite Ropp_0; intro; unfold Rsqr in |- *; 
+            rewrite Ropp_0; intro; unfold Rsqr in |- *;
               apply Rmult_lt_0_compat; assumption ] ].
 Qed.
 
@@ -103,8 +103,8 @@ Proof.
     [ assumption
       | cut (y < x);
         [ intro; unfold Rsqr in H;
-          generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); 
-            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); 
+          generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2);
+            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3);
               intro; elim (Rlt_irrefl (x * x) H4)
           | auto with real ] ].
 Qed.
@@ -115,8 +115,8 @@ Proof.
     [ assumption
       | cut (y < x);
         [ intro; unfold Rsqr in H;
-          generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); 
-            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); 
+          generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1);
+            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2);
               intro; elim (Rlt_irrefl (x * x) H3)
           | auto with real ] ].
 Qed.
@@ -152,7 +152,7 @@ Proof.
   generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
     generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H;
       generalize (Rsqr_incr_0 (- x) y H H2 H0); intro;
-        rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; 
+        rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar;
           apply Rle_ge; assumption.
   apply Rle_trans with 0;
     [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption
@@ -165,7 +165,7 @@ Proof.
   intros; case (Rcase_abs x); intro.
   generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
     generalize (Rlt_le 0 (- x) H2); intro;
-      generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
+      generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive;
         intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x);
           apply Rsqr_incr_1; assumption.
   generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption.
@@ -175,9 +175,9 @@ Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y.
 Proof.
   intros; case (Rcase_abs x); intro.
   generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
-    generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
+    generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive;
       intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1);
-        intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; 
+        intro; generalize (Rle_trans 0 (- x) y H4 H3); intro;
           rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
   generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro;
     apply Rsqr_incr_1; assumption.
@@ -225,16 +225,16 @@ Proof.
   intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros.
   rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
     generalize (Ropp_lt_gt_contravar y 0 r);
-      generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
+      generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
         intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1);
           intros; apply Rsqr_inj; assumption.
   rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro;
-    generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
-      intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; 
+    generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
+      intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj;
         assumption.
   rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro;
-    generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; 
-      intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; 
+    generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0;
+      intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj;
         assumption.
   generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj;
     assumption.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index 63b8940b..2c43ee9b 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_sqrt.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -20,15 +20,21 @@ Definition sqrt (x:R) : R :=
     | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a))
   end.
 
-Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x.
+Lemma sqrt_pos : forall x : R, 0 <= sqrt x.
 Proof.
-  intros.
-  unfold sqrt in |- *.
-  case (Rcase_abs x); intro.
-  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
+  intros x.
+  unfold sqrt.
+  destruct (Rcase_abs x) as [H|H].
+  apply Rle_refl.
   apply Rsqrt_positivity.
 Qed.
 
+Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x.
+Proof.
+  intros x _.
+  apply sqrt_pos.
+Qed.
+
 Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
 Proof.
   intros.
@@ -40,7 +46,7 @@ Qed.
 
 Lemma sqrt_0 : sqrt 0 = 0.
 Proof.
-  apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. 
+  apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity.
 Qed.
 
 Lemma sqrt_1 : sqrt 1 = 1.
@@ -48,7 +54,7 @@ Proof.
   apply (Rsqr_inj (sqrt 1) 1);
     [ apply sqrt_positivity; left
       | left
-      | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; 
+      | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ];
     apply Rlt_0_1.
 Qed.
 
@@ -100,17 +106,41 @@ Proof.
   intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1).
 Qed.
 
+Lemma sqrt_mult_alt :
+  forall x y : R, 0 <= x -> sqrt (x * y) = sqrt x * sqrt y.
+Proof.
+  intros x y Hx.
+  unfold sqrt at 3.
+  destruct (Rcase_abs y) as [Hy|Hy].
+  rewrite Rmult_0_r.
+  destruct Hx as [Hx'|Hx'].
+  unfold sqrt.
+  destruct (Rcase_abs (x * y)) as [Hxy|Hxy].
+  apply eq_refl.
+  elim Rge_not_lt with (1 := Hxy).
+  rewrite <- (Rmult_0_r x).
+  now apply Rmult_lt_compat_l.
+  rewrite <- Hx', Rmult_0_l.
+  exact sqrt_0.
+  apply Rsqr_inj.
+  apply sqrt_pos.
+  apply Rmult_le_pos.
+  apply sqrt_pos.
+  apply Rsqrt_positivity.
+  rewrite Rsqr_mult, 2!Rsqr_sqrt.
+  unfold Rsqr.
+  now rewrite Rsqrt_Rsqrt.
+  exact Hx.
+  apply Rmult_le_pos.
+  exact Hx.
+  now apply Rge_le.
+Qed.
+
 Lemma sqrt_mult :
   forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y.
 Proof.
-  intros x y H1 H2;
-    apply
-      (Rsqr_inj (sqrt (x * y)) (sqrt x * sqrt y)
-        (sqrt_positivity (x * y) (Rmult_le_pos x y H1 H2))
-        (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1)
-          (sqrt_positivity y H2))); rewrite Rsqr_mult; 
-      repeat rewrite Rsqr_sqrt;
-        [ ring | assumption | assumption | apply (Rmult_le_pos x y H1 H2) ].
+  intros x y Hx _.
+  now apply sqrt_mult_alt.
 Qed.
 
 Lemma sqrt_lt_R0 : forall x:R, 0 < x -> 0 < sqrt x.
@@ -121,46 +151,90 @@ Proof.
       | apply (sqrt_positivity x (Rlt_le 0 x H1)) ].
 Qed.
 
+Lemma sqrt_div_alt :
+  forall x y : R, 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
+Proof.
+  intros x y Hy.
+  unfold sqrt at 2.
+  destruct (Rcase_abs x) as [Hx|Hx].
+  unfold Rdiv.
+  rewrite Rmult_0_l.
+  unfold sqrt.
+  destruct (Rcase_abs (x * / y)) as [Hxy|Hxy].
+  apply eq_refl.
+  elim Rge_not_lt with (1 := Hxy).
+  apply Rmult_lt_reg_r with y.
+  exact Hy.
+  rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_0_l.
+  exact Hx.
+  now apply Rgt_not_eq.
+  set (Hx' := Rge_le x 0 Hx).
+  clearbody Hx'. clear Hx.
+  apply Rsqr_inj.
+  apply sqrt_pos.
+  apply Fourier_util.Rle_mult_inv_pos.
+  apply Rsqrt_positivity.
+  now apply sqrt_lt_R0.
+  rewrite Rsqr_div, 2!Rsqr_sqrt.
+  unfold Rsqr.
+  now rewrite Rsqrt_Rsqrt.
+  now apply Rlt_le.
+  now apply Fourier_util.Rle_mult_inv_pos.
+  apply Rgt_not_eq.
+  now apply sqrt_lt_R0.
+Qed.
+
 Lemma sqrt_div :
   forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
 Proof.
-  intros x y H1 H2; apply Rsqr_inj;
-    [ apply sqrt_positivity; apply (Rmult_le_pos x (/ y));
-      [ assumption
-        | generalize (Rinv_0_lt_compat y H2); clear H2; intro H2; left;
-          assumption ]
-      | apply (Rmult_le_pos (sqrt x) (/ sqrt y));
-        [ apply (sqrt_positivity x H1)
-          | generalize (sqrt_lt_R0 y H2); clear H2; intro H2;
-            generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; 
-              intro H2; left; assumption ]
-      | rewrite Rsqr_div; repeat rewrite Rsqr_sqrt;
-        [ reflexivity
-          | left; assumption
-          | assumption
-          | generalize (Rinv_0_lt_compat y H2); intro H3;
-            generalize (Rlt_le 0 (/ y) H3); intro H4;
-              apply (Rmult_le_pos x (/ y) H1 H4)
-          | red in |- *; intro H3; generalize (Rlt_le 0 y H2); intro H4;
-            generalize (sqrt_eq_0 y H4 H3); intro H5; rewrite H5 in H2;
-              elim (Rlt_irrefl 0 H2) ] ].
+  intros x y _ H.
+  now apply sqrt_div_alt.
+Qed.
+
+Lemma sqrt_lt_0_alt :
+  forall x y : R, sqrt x < sqrt y -> x < y.
+Proof.
+  intros x y.
+  unfold sqrt at 2.
+  destruct (Rcase_abs y) as [Hy|Hy].
+  intros Hx.
+  elim Rlt_not_le with (1 := Hx).
+  apply sqrt_pos.
+  set (Hy' := Rge_le y 0 Hy).
+  clearbody Hy'. clear Hy.
+  unfold sqrt.
+  destruct (Rcase_abs x) as [Hx|Hx].
+  intros _.
+  now apply Rlt_le_trans with R0.
+  intros Hxy.
+  apply Rsqr_incrst_1 in Hxy ; try apply Rsqrt_positivity.
+  unfold Rsqr in Hxy.
+  now rewrite 2!Rsqrt_Rsqrt in Hxy.
 Qed.
 
 Lemma sqrt_lt_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x < sqrt y -> x < y.
 Proof.
-  intros x y H1 H2 H3;
-    generalize
-      (Rsqr_incrst_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
-        (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
-      rewrite (Rsqr_sqrt y H2) in H4; assumption.
+  intros x y _ _.
+  apply sqrt_lt_0_alt.
+Qed.
+
+Lemma sqrt_lt_1_alt :
+  forall x y : R, 0 <= x < y -> sqrt x < sqrt y.
+Proof.
+  intros x y (Hx, Hxy).
+  apply Rsqr_incrst_0 ; try apply sqrt_pos.
+  rewrite 2!Rsqr_sqrt.
+  exact Hxy.
+  apply Rlt_le.
+  now apply Rle_lt_trans with x.
+  exact Hx.
 Qed.
 
 Lemma sqrt_lt_1 : forall x y:R, 0 <= x -> 0 <= y -> x < y -> sqrt x < sqrt y.
 Proof.
-  intros x y H1 H2 H3; apply Rsqr_incrst_0;
-    [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
-      | apply (sqrt_positivity x H1)
-      | apply (sqrt_positivity y H2) ].
+  intros x y Hx _ Hxy.
+  apply sqrt_lt_1_alt.
+  now split.
 Qed.
 
 Lemma sqrt_le_0 :
@@ -173,13 +247,27 @@ Proof.
       rewrite (Rsqr_sqrt y H2) in H4; assumption.
 Qed.
 
+Lemma sqrt_le_1_alt :
+  forall x y : R, x <= y -> sqrt x <= sqrt y.
+Proof.
+  intros x y [Hxy|Hxy].
+  destruct (Rle_or_lt 0 x) as [Hx|Hx].
+  apply Rlt_le.
+  apply sqrt_lt_1_alt.
+  now split.
+  unfold sqrt at 1.
+  destruct (Rcase_abs x) as [Hx'|Hx'].
+  apply sqrt_pos.
+  now elim Rge_not_lt with (1 := Hx').
+  rewrite Hxy.
+  apply Rle_refl.
+Qed.
+
 Lemma sqrt_le_1 :
   forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y.
 Proof.
-  intros x y H1 H2 H3; apply Rsqr_incr_0;
-    [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
-      | apply (sqrt_positivity x H1)
-      | apply (sqrt_positivity y H2) ].
+  intros x y _ _ Hxy.
+  now apply sqrt_le_1_alt.
 Qed.
 
 Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y.
@@ -190,22 +278,30 @@ Proof.
   rewrite H1; reflexivity.
 Qed.
 
+Lemma sqrt_less_alt :
+  forall x : R, 1 < x -> sqrt x < x.
+Proof.
+  intros x Hx.
+  assert (Hx1 := Rle_lt_trans _ _ _ Rle_0_1 Hx).
+  assert (Hx2 := Rlt_le _ _ Hx1).
+  apply Rsqr_incrst_0 ; trivial.
+  rewrite Rsqr_sqrt ; trivial.
+  rewrite <- (Rmult_1_l x) at 1.
+  now apply Rmult_lt_compat_r.
+  apply sqrt_pos.
+Qed.
+
 Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x.
 Proof.
-  intros x H1 H2; generalize (sqrt_lt_1 1 x (Rlt_le 0 1 Rlt_0_1) H1 H2);
-    intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
-      intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 2 in |- *;
-        rewrite <- (sqrt_def x H1);
-          apply
-            (Rmult_lt_compat_l (sqrt x) 1 (sqrt x)
-              (sqrt_lt_R0 x (Rlt_trans 0 1 x Rlt_0_1 H2)) H3).
+  intros x _.
+  apply sqrt_less_alt.
 Qed.
 
 Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x.
 Proof.
   intros x H1 H2;
-    generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); 
-      intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
+    generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2);
+      intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x));
         intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *;
           rewrite <- (sqrt_def x (Rlt_le 0 x H1));
             apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3).
@@ -338,7 +434,7 @@ Proof.
   (b * (- b * (/ 2 * / a)) + c).
   repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)).
   rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc;
-    rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; 
+    rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
       rewrite <- Rinv_l_sym.
   rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc.
   rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
index f48ce563..500dd529 100644
--- a/theories/Reals/Ranalysis.v
+++ b/theories/Reals/Ranalysis.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -85,7 +85,7 @@ Ltac intro_hyp_glob trm :=
         match goal with
           | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
             intro_hyp_glob X1
-          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => 
+          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
             intro_hyp_glob X1
           |  |- (derivable _) =>
             cut (forall x0:R, aux x0 <> 0);
@@ -277,7 +277,7 @@ Ltac intro_hyp_pt trm pt :=
 Ltac is_diff_pt :=
   match goal with
     |  |- (derivable_pt Rsqr _) =>
-      
+
   (* fonctions de base *)
       apply derivable_pt_Rsqr
     |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
@@ -326,7 +326,7 @@ Ltac is_diff_pt :=
               unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                 comp, pow_fct, id, fct_cte in |- * ]
     |  |- (derivable_pt (/ ?X1) ?X2) =>
-      
+
        (* INVERSION *)
       apply (derivable_pt_inv X1 X2);
         [ assumption ||
@@ -334,7 +334,7 @@ Ltac is_diff_pt :=
             comp, pow_fct, id, fct_cte in |- *
           | is_diff_pt ]
     |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>
-      
+
        (* COMPOSITION *)
       apply (derivable_pt_comp X2 X1 X3); is_diff_pt
     | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
@@ -352,7 +352,7 @@ Ltac is_diff_pt :=
 (**********)
 Ltac is_diff_glob :=
   match goal with
-    |  |- (derivable Rsqr) => 
+    |  |- (derivable Rsqr) =>
   (* fonctions de base *)
       apply derivable_Rsqr
     |  |- (derivable id) => apply derivable_id
@@ -392,7 +392,7 @@ Ltac is_diff_glob :=
               unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                 id, fct_cte, comp, pow_fct in |- * ]
     |  |- (derivable (/ ?X1)) =>
-      
+
        (* INVERSION *)
       apply (derivable_inv X1);
         [ try
@@ -401,7 +401,7 @@ Ltac is_diff_glob :=
               id, fct_cte, comp, pow_fct in |- *
           | is_diff_glob ]
     |  |- (derivable (comp sqrt _)) =>
-      
+
        (* COMPOSITION *)
       unfold derivable in |- *; intro; try is_diff_pt
     |  |- (derivable (comp Rabs _)) =>
@@ -421,7 +421,7 @@ Ltac is_diff_glob :=
 Ltac is_cont_pt :=
   match goal with
     |  |- (continuity_pt Rsqr _) =>
-      
+
        (* fonctions de base *)
       apply derivable_continuous_pt; apply derivable_pt_Rsqr
     |  |- (continuity_pt id ?X1) =>
@@ -475,7 +475,7 @@ Ltac is_cont_pt :=
               unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                 comp, id, fct_cte, pow_fct in |- * ]
     |  |- (continuity_pt (/ ?X1) ?X2) =>
-      
+
        (* INVERSION *)
       apply (continuity_pt_inv X1 X2);
         [ is_cont_pt
@@ -483,7 +483,7 @@ Ltac is_cont_pt :=
             unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
               comp, id, fct_cte, pow_fct in |- * ]
     |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>
-      
+
        (* COMPOSITION *)
       apply (continuity_pt_comp X2 X1 X3); is_cont_pt
     | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
@@ -508,7 +508,7 @@ Ltac is_cont_pt :=
 Ltac is_cont_glob :=
   match goal with
     |  |- (continuity Rsqr) =>
-      
+
        (* fonctions de base *)
       apply derivable_continuous; apply derivable_Rsqr
     |  |- (continuity id) => apply derivable_continuous; apply derivable_id
@@ -559,7 +559,7 @@ Ltac is_cont_glob :=
               unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                 id, fct_cte, pow_fct in |- * ]
     |  |- (continuity (comp sqrt _)) =>
-      
+
        (* COMPOSITION *)
       unfold continuity_pt in |- *; intro; try is_cont_pt
     |  |- (continuity (comp ?X1 ?X2)) =>
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
index 9414f7c9..1516b338 100644
--- a/theories/Reals/Ranalysis1.v
+++ b/theories/Reals/Ranalysis1.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis1.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -61,7 +61,7 @@ Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y.
 Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x.
 Definition constant f : Prop := forall x y:R, f x = f y.
 
-(**********) 
+(**********)
 Definition no_cond (x:R) : Prop := True.
 
 (**********)
@@ -114,7 +114,7 @@ Qed.
 Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0.
 Proof.
   unfold constant, continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
       intros; exists 1; split;
         [ apply Rlt_0_1
           | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *;
@@ -196,7 +196,7 @@ Proof.
   elim H5; intros; assumption.
 Qed.
 
-(**********) 
+(**********)
 Lemma continuity_plus :
   forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2).
 Proof.
@@ -322,18 +322,18 @@ Proof.
   prove_sup0.
   rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
     [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double;
-      pattern alp at 1 in |- *; replace alp with (alp + 0); 
+      pattern alp at 1 in |- *; replace alp with (alp + 0);
         [ idtac | ring ]; apply Rplus_lt_compat_l; assumption.
   symmetry  in |- *; apply Rabs_right; left; assumption.
   symmetry  in |- *; apply Rabs_right; left; change (0 < / 2) in |- *;
-    apply Rinv_0_lt_compat; prove_sup0. 
+    apply Rinv_0_lt_compat; prove_sup0.
 Qed.
 
 Lemma uniqueness_step2 :
   forall f (x l:R),
     derivable_pt_lim f x l ->
     limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0.
-Proof. 
+Proof.
   unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *;
     unfold limit_in in |- *; intros.
   assert (H1 := H eps H0).
@@ -418,10 +418,10 @@ Proof.
   intros; split.
   unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
     simpl in |- *; unfold R_dist in |- *; intros.
-  apply derive_pt_eq_0. 
+  apply derive_pt_eq_0.
   unfold derivable_pt_lim in |- *.
   intros; elim (H eps H0); intros alpha H1; elim H1; intros;
-    exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
+    exists (mkposreal alpha H2); intros; generalize (H3 (x + h));
       intro; cut (x + h - x = h);
         [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
           [ intro; generalize (H6 H8); rewrite H7; intro; assumption
@@ -434,7 +434,7 @@ Proof.
   intro.
   assert (H0 := derive_pt_eq_1 f x (df x) pr H).
   unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
-    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
       intros.
   elim (H0 eps H1); intros alpha H2; exists (pos alpha); split.
   apply (cond_pos alpha).
@@ -454,7 +454,7 @@ Proof.
     simpl in |- *; unfold R_dist in |- *; intros.
   unfold derivable_pt_lim in |- *.
   intros; elim (H eps H0); intros alpha H1; elim H1; intros;
-    exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
+    exists (mkposreal alpha H2); intros; generalize (H3 (x + h));
       intro; cut (x + h - x = h);
         [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
           [ intro; generalize (H6 H8); rewrite H7; intro; assumption
@@ -467,7 +467,7 @@ Proof.
   intro.
   unfold derivable_pt_lim in H.
   unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
-    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
       intros.
   elim (H eps H0); intros alpha H2; exists (pos alpha); split.
   apply (cond_pos alpha).
@@ -548,7 +548,7 @@ Qed.
 
 Lemma derivable_pt_lim_opp :
   forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l).
-Proof. 
+Proof.
   intros.
   apply uniqueness_step3.
   assert (H1 := uniqueness_step2 _ _ _ H).
@@ -1066,7 +1066,7 @@ Qed.
 
 Lemma pr_nu :
   forall f (x:R) (pr1 pr2:derivable_pt f x),
-    derive_pt f x pr1 = derive_pt f x pr2. 
+    derive_pt f x pr1 = derive_pt f x pr2.
 Proof.
   intros.
   unfold derivable_pt in pr1.
@@ -1141,7 +1141,7 @@ Proof.
           -
           ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
             Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19);
-      repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; 
+      repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
         rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)).
   intro;
     generalize
@@ -1168,7 +1168,7 @@ Proof.
       Rge_le
       ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
         Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r).
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). 
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)).
   assumption.
   rewrite <- Ropp_0;
     replace
@@ -1260,7 +1260,7 @@ Proof.
   prove_sup0.
   rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l.
-  replace (2 * delta) with (delta + delta). 
+  replace (2 * delta) with (delta + delta).
   pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
     apply Rplus_lt_compat_l.
   rewrite Rplus_0_r; apply (cond_pos delta).
@@ -1270,7 +1270,7 @@ Proof.
   intro;
     generalize
       (Rmin_stable_in_posreal (mkposreal (delta / 2) H9)
-        (mkposreal ((b - c) / 2) H8)); simpl in |- *; 
+        (mkposreal ((b - c) / 2) H8)); simpl in |- *;
       intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
@@ -1307,7 +1307,7 @@ Proof.
     cut
       (Rabs
         ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-          Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < 
+          Rmax (- (delta / 2)) ((a + - c) / 2) + - l) <
         - (l / 2)).
   unfold Rabs in |- *;
     case
@@ -1332,7 +1332,7 @@ Proof.
     generalize
       (Rlt_trans
         ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-          Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); 
+          Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21);
       intro;
         elim
           (Rlt_irrefl 0
@@ -1369,7 +1369,7 @@ Proof.
   reflexivity.
   unfold Rdiv in H11; assumption.
   generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10);
-    rewrite Rplus_0_r; intro; apply Rlt_trans with c; 
+    rewrite Rplus_0_r; intro; apply Rlt_trans with c;
       assumption.
   generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro;
     generalize
@@ -1390,21 +1390,21 @@ Proof.
       generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13);
         intro; apply Rle_lt_trans with (delta / 2).
   assumption.
-  apply Rmult_lt_reg_l with 2. 
+  apply Rmult_lt_reg_l with 2.
   prove_sup0.
   unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite double.
   pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
     apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta).
-  discrR. 
+  discrR.
   cut (- (delta / 2) < 0).
   cut ((a - c) / 2 < 0).
   intros;
     generalize
       (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
-        (mknegreal ((a - c) / 2) H12)); simpl in |- *; 
-      intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); 
+        (mknegreal ((a - c) / 2) H12)); simpl in |- *;
+      intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r);
         intro;
           elim
             (Rlt_irrefl 0
@@ -1413,7 +1413,7 @@ Proof.
     apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
   assumption.
   unfold Rdiv in |- *.
-  rewrite <- Ropp_mult_distr_l_reverse. 
+  rewrite <- Ropp_mult_distr_l_reverse.
   rewrite (Ropp_minus_distr a c).
   reflexivity.
   rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
@@ -1435,7 +1435,7 @@ Proof.
     apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
   assumption.
   unfold Rdiv in |- *.
-  rewrite <- Ropp_mult_distr_l_reverse. 
+  rewrite <- Ropp_mult_distr_l_reverse.
   rewrite (Ropp_minus_distr a c).
   reflexivity.
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
@@ -1532,7 +1532,7 @@ Proof.
     generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12);
       rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
   pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
-    left; assumption. 
+    left; assumption.
   left; apply Rinv_0_lt_compat; assumption.
   split.
   unfold Rdiv in |- *; apply prod_neq_R0.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index 54801eb7..1d44b3e7 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis2.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -36,29 +36,27 @@ Proof.
   replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
   (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
   replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
-  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); 
+  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h)));
   [ idtac | ring ].
   replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
-  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); 
+  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x)));
   [ idtac | ring ].
   replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
   (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
   [ idtac | ring ].
   replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
-  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); 
+  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x)));
   [ idtac | ring ].
   repeat rewrite <- Rinv_r_sym; try assumption || ring.
   apply prod_neq_R0; assumption.
 Qed.
 
-Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
-Proof.
-  intros; unfold Rmin in |- *.
-  case (Rle_dec x y); intro; assumption.
-Qed.
+(* begin hide *)
+Notation Rmin_pos := Rmin_pos (only parsing). (* compat *)
+(* end hide *)
 
 Lemma maj_term1 :
-  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) 
+  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal)
     (f1 f2:R -> R),
     0 < eps ->
     f2 x <> 0 ->
@@ -105,7 +103,7 @@ Proof.
 Qed.
 
 Lemma maj_term2 :
-  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) 
+  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal)
     (f2:R -> R),
     0 < eps ->
     f2 x <> 0 ->
@@ -143,7 +141,7 @@ Proof.
   replace (Rabs 2) with 2.
   rewrite (Rmult_comm 2).
   replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
-  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
+  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
   [ idtac | ring ].
   repeat apply Rmult_lt_compat_l.
   apply Rabs_pos_lt; assumption.
@@ -176,7 +174,7 @@ Proof.
 Qed.
 
 Lemma maj_term3 :
-  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) 
+  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal)
     (f1 f2:R -> R),
     0 < eps ->
     f2 x <> 0 ->
@@ -218,7 +216,7 @@ Proof.
   replace (Rabs 2) with 2.
   rewrite (Rmult_comm 2).
   replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
-  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
+  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
   [ idtac | ring ].
   repeat apply Rmult_lt_compat_l.
   apply Rabs_pos_lt; assumption.
@@ -251,7 +249,7 @@ Proof.
 Qed.
 
 Lemma maj_term4 :
-  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) 
+  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal)
     (f1 f2:R -> R),
     0 < eps ->
     f2 x <> 0 ->
@@ -386,10 +384,9 @@ Proof.
   apply Rplus_lt_compat_l; assumption.
 Qed.
 
-Lemma Rmin_2 : forall a b c:R, a < b -> a < c -> a < Rmin b c.
-Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec b c); intro; assumption.
-Qed.
+(* begin hide *)
+Notation Rmin_2 := Rmin_glb_lt (only parsing).
+(* end hide *)
 
 Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
 Proof.
@@ -431,7 +428,7 @@ Proof.
   assert (Hyp : 0 < 2).
   prove_sup0.
   intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
-    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; 
+    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
       [ idtac | discrR ].
   cut (IZR 1 < IZR 2).
   unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index 180cf9d6..3b685cd8 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis3.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -60,7 +60,7 @@ Proof.
   case (Req_dec (f1 x) 0); intro.
   case (Req_dec l1 0); intro.
 (***********************************)
-(*              Cas n° 1           *)
+(*              First case         *)
 (*           (f1 x)=0  l1 =0       *)
 (***********************************)
   cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d));
@@ -118,7 +118,7 @@ Proof.
   apply Rmin_2; assumption.
   right; symmetry  in |- *; apply quadruple_var.
 (***********************************)
-(*              Cas n° 2           *)
+(*           Second case           *)
 (*           (f1 x)=0  l1<>0       *)
 (***********************************)
   assert (H10 := derivable_continuous_pt _ _ X).
@@ -213,12 +213,12 @@ Proof.
   apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
     repeat apply prod_neq_R0.
   red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
-  assumption. 
+  assumption.
   assumption.
   apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
     [ discrR | discrR | discrR | assumption ].
 (***********************************)
-(*              Cas n° 3           *)
+(*        Third case               *)
 (*     (f1 x)<>0  l1=0  l2=0       *)
 (***********************************)
   case (Req_dec l1 0); intro.
@@ -291,7 +291,7 @@ Proof.
   apply (cond_pos alp_f1d).
   apply (cond_pos alp_f2d).
 (***********************************)
-(*              Cas n° 4           *)
+(*      Fourth case                *)
 (*    (f1 x)<>0  l1=0  l2<>0       *)
 (***********************************)
   elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
@@ -380,7 +380,7 @@ Proof.
   unfold Rdiv, Rsqr in |- *.
   repeat rewrite Rinv_mult_distr; try assumption.
   repeat apply prod_neq_R0; try assumption.
-  red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). 
+  red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
@@ -408,20 +408,20 @@ Proof.
   unfold Rsqr, Rdiv in |- *.
   repeat rewrite Rinv_mult_distr; try assumption || discrR.
   repeat apply prod_neq_R0; try assumption.
-  red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). 
+  red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; assumption.
   apply Rinv_neq_0_compat; assumption.
   apply prod_neq_R0; [ discrR | assumption ].
-  red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). 
+  red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; assumption.
 (***********************************)
-(*              Cas n° 5           *)
+(*         Fifth case              *)
 (*    (f1 x)<>0  l1<>0  l2=0       *)
 (***********************************)
   case (Req_dec l2 0); intro.
@@ -519,7 +519,7 @@ Proof.
   repeat apply Rmin_pos.
   apply (cond_pos eps_f2).
   elim H3; intros; assumption.
-  apply (cond_pos alp_f1d). 
+  apply (cond_pos alp_f1d).
   apply (cond_pos alp_f2d).
   elim H11; intros; assumption.
   apply Rabs_pos_lt.
@@ -538,7 +538,7 @@ Proof.
         (apply Rinv_neq_0_compat; discrR) ||
           (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
 (***********************************)
-(*              Cas n° 6           *)
+(*       Sixth case                *)
 (*    (f1 x)<>0  l1<>0  l2<>0      *)
 (***********************************)
   elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
@@ -776,7 +776,7 @@ Proof.
 Qed.
 
 Lemma derive_pt_div :
-  forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) 
+  forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x)
     (pr2:derivable_pt f2 x) (na:f2 x <> 0),
     derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) =
     (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x).
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index 95f6d27e..1ed3fb71 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis4.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -31,8 +31,8 @@ Proof.
   unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros;
     unfold derivable_pt in |- *; exists x0;
       unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
-        unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; 
-          intros; elim (p eps H0); intros; exists x1; intros; 
+        unfold derivable_pt_abs in p; unfold derivable_pt_lim in p;
+          intros; elim (p eps H0); intros; exists x1; intros;
             unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x));
               rewrite <- (Rmult_1_l (/ f (x + h))).
   apply H1; assumption.
@@ -60,14 +60,14 @@ Proof.
   elim pr1; intros.
   elim pr2; intros.
   simpl in |- *.
-  assert (H0 := uniqueness_step2 _ _ _ p). 
-  assert (H1 := uniqueness_step2 _ _ _ p0). 
+  assert (H0 := uniqueness_step2 _ _ _ p).
+  assert (H1 := uniqueness_step2 _ _ _ p0).
   cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0).
-  intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). 
+  intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2).
   assumption.
   unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
     simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1;
-      unfold limit_in in H1; unfold dist in H1; simpl in H1; 
+      unfold limit_in in H1; unfold dist in H1; simpl in H1;
         unfold R_dist in H1.
   intros; elim (H1 eps H2); intros.
   elim H3; intros.
@@ -122,7 +122,7 @@ Proof.
   case (Rcase_abs h); intro.
   rewrite (Rabs_left h r) in H2.
   left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r;
-    rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; 
+    rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
       apply H2.
   apply Rplus_le_le_0_compat.
   left; apply H.
@@ -178,12 +178,12 @@ Proof.
   unfold continuity in |- *; intro.
   case (Req_dec x 0); intro.
   unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      simpl in |- *; unfold R_dist in |- *; intros; exists eps; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      simpl in |- *; unfold R_dist in |- *; intros; exists eps;
         split.
   apply H0.
   intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; 
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1;
       intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3;
         rewrite Rplus_0_r in H3; apply H3.
   apply derivable_continuous_pt; apply (Rderivable_pt_abs x H).
@@ -297,7 +297,7 @@ Proof.
   induction  N as [| N HrecN].
   exists 0; apply H.
   exists
-    (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); 
+    (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N)));
     apply H.
 Qed.
 
@@ -317,7 +317,7 @@ Proof.
   ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
   replace ((exp x - exp (- x)) * / 2) with
   ((exp x + exp (- x) * -1) * fct_cte (/ 2) x +
-    (exp + comp exp (- id))%F x * 0). 
+    (exp + comp exp (- id))%F x * 0).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_plus.
   apply derivable_pt_lim_exp.
@@ -337,7 +337,7 @@ Proof.
   ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
   replace ((exp x + exp (- x)) * / 2) with
   ((exp x - exp (- x) * -1) * fct_cte (/ 2) x +
-    (exp - comp exp (- id))%F x * 0). 
+    (exp - comp exp (- id))%F x * 0).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_minus.
   apply derivable_pt_lim_exp.
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index 6667d2ec..9715414f 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Raxioms.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*********************************************************)
 (**    Axiomatisation of the classical reals             *)
@@ -40,13 +40,13 @@ Hint Resolve Rplus_opp_r: real v62.
 Axiom Rplus_0_l : forall r:R, 0 + r = r.
 Hint Resolve Rplus_0_l: real.
 
-(***********************************************************)       
+(***********************************************************)
 (** **    Multiplication                                   *)
 (***********************************************************)
 
 (**********)
 Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.
-Hint Resolve Rmult_comm: real v62. 
+Hint Resolve Rmult_comm: real v62.
 
 (**********)
 Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3).
@@ -102,7 +102,7 @@ Axiom
 
 Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.
 
-(**********************************************************) 
+(**********************************************************)
 (** *    Injection from N to R                            *)
 (**********************************************************)
 
@@ -112,11 +112,11 @@ Boxed Fixpoint INR (n:nat) : R :=
   | O => 0
   | S O => 1
   | S n => INR n + 1
-  end.  
+  end.
 Arguments Scope INR [nat_scope].
 
 
-(**********************************************************) 
+(**********************************************************)
 (** *    Injection from [Z] to [R]                        *)
 (**********************************************************)
 
@@ -126,7 +126,7 @@ Definition IZR (z:Z) : R :=
   | Z0 => 0
   | Zpos n => INR (nat_of_P n)
   | Zneg n => - INR (nat_of_P n)
-  end.  
+  end.
 Arguments Scope IZR [Z_scope].
 
 (**********************************************************)
diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
index 5bee0f82..ab1c0747 100644
--- a/theories/Reals/Rbase.v
+++ b/theories/Reals/Rbase.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbase.v 9178 2006-09-26 11:18:22Z barras $ i*)
+(*i $Id$ i*)
 
 Require Export Rdefinitions.
 Require Export Raxioms.
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index a5cc9f19..7588020c 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbasic_fun.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*********************************************************)
 (**          Complements for the real numbers            *)
@@ -16,7 +16,7 @@
 Require Import Rbase.
 Require Import R_Ifp.
 Require Import Fourier.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Implicit Type r : R.
 
@@ -32,6 +32,19 @@ Definition Rmin (x y:R) : R :=
   end.
 
 (*********)
+Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2).
+Proof.
+  intros r1 r2 P H1 H2; unfold Rmin; case (Rle_dec r1 r2); auto.
+Qed.
+
+(*********)
+Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type), 
+  (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2).
+Proof.
+  intros r1 r2 P H1 H2; unfold Rmin; destruct (Rle_dec r1 r2); auto with real.
+Qed.
+
+(*********)
 Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
 Proof.
   intros r1 r2 r; unfold Rmin in |- *; case (Rle_dec r1 r2); intros.
@@ -73,9 +86,33 @@ Proof.
 Qed.
 
 (*********)
-Lemma Rmin_comm : forall a b:R, Rmin a b = Rmin b a.
+Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x.
+Proof.
+  intros; apply Rmin_case_strong; auto using Rle_antisym.
+Qed.
+
+(*********)
+Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y.
+Proof.
+  intros; apply Rmin_case_strong; auto using Rle_antisym.
+Qed.
+
+(*********)
+Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z.
+Proof.
+  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
+Qed.
+
+(*********)
+Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y.
+Proof.
+  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
+Qed.
+
+(*********)
+Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x.
 Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec a b); case (Rle_dec b a); intros;
+  intros; unfold Rmin; case (Rle_dec x y); case (Rle_dec y x); intros;
     try reflexivity || (apply Rle_antisym; assumption || auto with real).
 Qed.
 
@@ -85,6 +122,25 @@ Proof.
   intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
 Qed.
 
+(*********)
+Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
+Proof.
+  intros; unfold Rmin in |- *.
+  case (Rle_dec x y); intro; assumption.
+Qed.
+
+(*********)
+Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption.
+Qed.
+
+(*********)
+Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y.
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption.
+Qed.
+
 (*******************************)
 (** *        Rmax              *)
 (*******************************)
@@ -97,6 +153,19 @@ Definition Rmax (x y:R) : R :=
   end.
 
 (*********)
+Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2).
+Proof.
+  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto.
+Qed.
+
+(*********)
+Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type),
+  (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2).
+Proof.
+  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto with real.
+Qed.
+
+(*********)
 Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
 Proof.
   intros; split.
@@ -108,24 +177,60 @@ Proof.
     apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
 Qed.
 
-Lemma RmaxLess1 : forall r1 r2, r1 <= Rmax r1 r2.
+Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
 Proof.
-  intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
+  intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
+    intros H1 H2; apply Rle_antisym; auto with real.
 Qed.
 
-Lemma RmaxLess2 : forall r1 r2, r2 <= Rmax r1 r2.
+(* begin hide *)
+Notation RmaxSym := Rmax_comm (only parsing).
+(* end hide *)
+
+(*********)
+Lemma Rmax_l : forall x y:R, x <= Rmax x y.
 Proof.
-  intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
+  intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1;
+    [ assumption | auto with real ].
 Qed.
 
-Lemma Rmax_comm : forall p q:R, Rmax p q = Rmax q p.
+(*********)
+Lemma Rmax_r : forall x y:R, y <= Rmax x y.
 Proof.
-  intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
-    intros H1 H2; apply Rle_antisym; auto with real.
+  intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1;
+    [ right; reflexivity | auto with real ].
 Qed.
 
-Notation RmaxSym := Rmax_comm (only parsing).
+(* begin hide *)
+Notation RmaxLess1 := Rmax_l (only parsing).
+Notation RmaxLess2 := Rmax_r (only parsing).
+(* end hide *)
 
+(*********)
+Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x.
+Proof.
+  intros; apply Rmax_case_strong; auto using Rle_antisym.
+Qed.
+
+(*********)
+Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y.
+Proof.
+  intros; apply Rmax_case_strong; auto using Rle_antisym.
+Qed.
+
+(*********)
+Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z.
+Proof.
+  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
+Qed.
+
+(*********)
+Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y.
+Proof.
+  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
+Qed.
+
+(*********)
 Lemma RmaxRmult :
   forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
 Proof.
@@ -140,18 +245,38 @@ Proof.
   rewrite <- E1; repeat rewrite Rmult_0_l; auto.
 Qed.
 
+(*********)
 Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
 Proof.
   intros; unfold Rmax in |- *; case (Rle_dec x y); intro;
     [ apply (cond_neg y) | apply (cond_neg x) ].
 Qed.
 
+(*********)
+Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z.
+Proof.
+  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
+Qed.
+
+(*********)
+Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z.
+Proof.
+  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
+Qed.
+
+(*********)
+Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0.
+Proof.
+  intros; unfold Rmax in |- *.
+  case (Rle_dec x y); intro; assumption.
+Qed.
+
 (*******************************)
 (** *        Rabsolu           *)
 (*******************************)
 
 (*********)
-Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. 
+Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}.
 Proof.
   intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
   right; apply (Rle_ge 0 r a).
@@ -169,7 +294,7 @@ Definition Rabs r : R :=
 Lemma Rabs_R0 : Rabs 0 = 0.
 Proof.
   unfold Rabs in |- *; case (Rcase_abs 0); auto; intro.
-  generalize (Rlt_irrefl 0); intro; elimtype False; auto.
+  generalize (Rlt_irrefl 0); intro; exfalso; auto.
 Qed.
 
 Lemma Rabs_R1 : Rabs 1 = 1.
@@ -220,16 +345,18 @@ Proof.
   apply Rge_le; assumption.
 Qed.
 
-Lemma RRle_abs : forall x:R, x <= Rabs x.
+Lemma Rle_abs : forall x:R, x <= Rabs x.
 Proof.
   intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier.
 Qed.
 
+Definition RRle_abs := Rle_abs.
+
 (*********)
 Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
 Proof.
   intros; unfold Rabs in |- *; case (Rcase_abs x); intro;
-    [ generalize (Rgt_not_le 0 x r); intro; elimtype False; auto | trivial ].
+    [ generalize (Rgt_not_le 0 x r); intro; exfalso; auto | trivial ].
 Qed.
 
 (*********)
@@ -243,10 +370,10 @@ Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
 Proof.
   intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
     auto.
-  elimtype False; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
+  exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
     case (Rcase_abs x); intros; auto.
   clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
-    rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); 
+    rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x);
       trivial.
 Qed.
 
@@ -256,14 +383,14 @@ Proof.
   intros; unfold Rabs in |- *; case (Rcase_abs (x - y));
     case (Rcase_abs (y - x)); intros.
   generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
-    generalize (Rlt_asym x y H); intro; elimtype False; 
+    generalize (Rlt_asym x y H); intro; exfalso;
       auto.
   rewrite (Ropp_minus_distr x y); trivial.
   rewrite (Ropp_minus_distr y x); trivial.
   unfold Rge in r, r0; elim r; elim r0; intros; clear r r0.
   generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y);
-    intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); 
-      intro; elimtype False; auto.
+    intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0);
+      intro; exfalso; auto.
   rewrite (Rminus_diag_uniq x y H); trivial.
   rewrite (Rminus_diag_uniq y x H0); trivial.
   rewrite (Rminus_diag_uniq y x H0); trivial.
@@ -275,47 +402,47 @@ Proof.
   intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x);
     case (Rcase_abs y); intros; auto.
   generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
-    rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); 
-      intro; unfold Rgt in H; elimtype False; rewrite (Rmult_comm y x) in H; 
+    rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1);
+      intro; unfold Rgt in H; exfalso; rewrite (Rmult_comm y x) in H;
         auto.
-  rewrite (Ropp_mult_distr_l_reverse x y); trivial. 
+  rewrite (Ropp_mult_distr_l_reverse x y); trivial.
   rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
     rewrite (Rmult_comm x y); trivial.
   unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0.
   generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1;
-    generalize (Rlt_asym (x * y) 0 r1); intro; elimtype False; 
+    generalize (Rlt_asym (x * y) 0 r1); intro; exfalso;
       auto.
   rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0);
-    intro; elimtype False; auto.
+    intro; exfalso; auto.
   rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
-    intro; elimtype False; auto.
+    intro; exfalso; auto.
   rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
-    intro; elimtype False; auto.
+    intro; exfalso; auto.
   rewrite (Rmult_opp_opp x y); trivial.
   unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H.
   generalize (Rmult_lt_compat_l y x 0 H0 r0); intro;
     rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1;
-      generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
+      generalize (Rlt_asym (x * y) 0 H1); intro; exfalso;
         auto.
   generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0));
-    generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); 
-      intros; generalize (Rmult_integral x y H); intro; 
-        elim H3; intro; elimtype False; auto.  
+    generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0));
+      intros; generalize (Rmult_integral x y H); intro;
+        elim H3; intro; exfalso; auto.
   rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H;
-    generalize (Rlt_irrefl 0); intro; elimtype False; 
+    generalize (Rlt_irrefl 0); intro; exfalso;
       auto.
   rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial.
   unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros;
     unfold Rgt in H0, H.
   generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1;
-    generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
+    generalize (Rlt_asym (x * y) 0 H1); intro; exfalso;
       auto.
   generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r));
-    generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); 
-      intros; generalize (Rmult_integral x y H); intro; 
-        elim H3; intro; elimtype False; auto.  
+    generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0));
+      intros; generalize (Rmult_integral x y H); intro;
+        elim H3; intro; exfalso; auto.
   rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H;
-    generalize (Rlt_irrefl 0); intro; elimtype False; 
+    generalize (Rlt_irrefl 0); intro; exfalso;
       auto.
   rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial.
 Qed.
@@ -327,15 +454,15 @@ Proof.
     intros.
   apply Ropp_inv_permute; auto.
   generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
-  unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; elimtype False;
+  unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; exfalso;
     auto.
   generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro;
-    elimtype False; auto.
+    exfalso; auto.
   unfold Rge in r1; elim r1; clear r1; intro.
   unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0));
-    intro; elimtype False; auto.
-  elimtype False; auto.
-Qed. 
+    intro; exfalso; auto.
+  exfalso; auto.
+Qed.
 
 Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
 Proof.
@@ -351,7 +478,7 @@ Proof.
   generalize (Ropp_le_ge_contravar 0 (-1) H1).
   rewrite Ropp_involutive; rewrite Ropp_0.
   intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2);
-    intro; elimtype False; auto.  
+    intro; exfalso; auto.
   ring.
 Qed.
 
@@ -366,7 +493,7 @@ Proof.
   rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
     unfold Rle in |- *; unfold Rge in r; elim r; intro.
   left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
-    elim (Rplus_ne (- b)); intros v w; rewrite v in H0; 
+    elim (Rplus_ne (- b)); intros v w; rewrite v in H0;
       clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
   right; rewrite H; apply Ropp_0.
 (**)
@@ -374,21 +501,21 @@ Proof.
     rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
       unfold Rle in |- *; unfold Rge in r0; elim r0; intro.
   left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
-    elim (Rplus_ne (- a)); intros v w; rewrite v in H0; 
+    elim (Rplus_ne (- a)); intros v w; rewrite v in H0;
       clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
   right; rewrite H; apply Ropp_0.
 (**)
-  elimtype False; generalize (Rplus_ge_compat_l a b 0 r); intro;
+  exfalso; generalize (Rplus_ge_compat_l a b 0 r); intro;
     elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
-      generalize (Rge_trans (a + b) a 0 H r0); intro; clear H; 
+      generalize (Rge_trans (a + b) a 0 H r0); intro; clear H;
         unfold Rge in H0; elim H0; intro; clear H0.
   unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto.
   absurd (a + b = 0); auto.
   apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
 (**)
-  elimtype False; generalize (Rplus_lt_compat_l a b 0 r); intro;
+  exfalso; generalize (Rplus_lt_compat_l a b 0 r); intro;
     elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
-      generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; 
+      generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H;
         unfold Rge in r1; elim r1; clear r1; intro.
   unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
     apply (Rlt_irrefl (a + b)); assumption.
@@ -397,16 +524,16 @@ Proof.
   rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
     apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
       unfold Rminus in |- *; rewrite (Ropp_involutive a);
-        generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; 
-          intro; elim (Rplus_ne a); intros v w; rewrite v in H; 
-            clear v w; generalize (Rlt_trans (a + a) a 0 H r0); 
+        generalize (Rplus_lt_compat_l a a 0 r0); clear r r1;
+          intro; elim (Rplus_ne a); intros v w; rewrite v in H;
+            clear v w; generalize (Rlt_trans (a + a) a 0 H r0);
               intro; apply (Rlt_le (a + a) 0 H0).
 (**)
   apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
     unfold Rminus in |- *; rewrite (Ropp_involutive b);
-      generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; 
-        intro; elim (Rplus_ne b); intros v w; rewrite v in H; 
-          clear v w; generalize (Rlt_trans (b + b) b 0 H r); 
+      generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1;
+        intro; elim (Rplus_ne b); intros v w; rewrite v in H;
+          clear v w; generalize (Rlt_trans (b + b) b 0 H r);
             intro; apply (Rlt_le (b + b) 0 H0).
 (**)
   unfold Rle in |- *; right; reflexivity.
@@ -428,25 +555,25 @@ Proof.
 Qed.
 
 (* ||a|-|b||<=|a-b| *)
-Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). 
+Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b).
 Proof.
   cut
-    (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). 
+    (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)).
   intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
   rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
-    do 2 rewrite Ropp_minus_distr. 
-  apply H; left; assumption. 
+    do 2 rewrite Ropp_minus_distr.
+  apply H; left; assumption.
   rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
-    apply Rabs_pos. 
-  apply H; left; assumption. 
-  intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). 
-  apply Rabs_triang_inv. 
+    apply Rabs_pos.
+  apply H; left; assumption.
+  intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b).
+  apply Rabs_triang_inv.
   rewrite (Rabs_right (Rabs a - Rabs b));
     [ reflexivity
       | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
-        replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); 
-        [ assumption | ring ] ]. 
-Qed. 
+        replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a);
+        [ assumption | ring ] ].
+Qed.
 
 (*********)
 Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
@@ -462,13 +589,13 @@ Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
 Proof.
   unfold Rabs in |- *; intro x; case (Rcase_abs x); intros.
   generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro;
-    generalize (Rlt_trans 0 (- x) a H0 H); intro; split. 
+    generalize (Rlt_trans 0 (- x) a H0 H); intro; split.
   apply (Rlt_trans x 0 a r H1).
   generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
     unfold Rgt in |- *; trivial.
   fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
     generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *;
-      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; 
+      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *;
         intro; split; assumption.
 Qed.
 
@@ -506,4 +633,9 @@ Proof.
   intros p0; rewrite Rabs_Ropp.
   apply Rabs_right; auto with real zarith.
 Qed.
- 
+
+Lemma abs_IZR : forall z, IZR (Zabs z) = Rabs (IZR z).
+Proof.
+  intros.
+  now rewrite Rabs_Zabs.
+Qed.
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
index d7fee9c5..27d5c49e 100644
--- a/theories/Reals/Rcomplete.v
+++ b/theories/Reals/Rcomplete.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rcomplete.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index 002ce8d6..023cfc93 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -5,13 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Rdefinitions.v 10751 2008-04-04 10:23:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 
 (*********************************************************)
 (**          Definitions for the axiomatization          *)
 (*********************************************************)
 
+Declare ML Module "r_syntax_plugin".
 Require Export ZArith_base.
 
 Parameter R : Set.
@@ -29,8 +30,8 @@ Parameter R1 : R.
 Parameter Rplus : R -> R -> R.
 Parameter Rmult : R -> R -> R.
 Parameter Ropp : R -> R.
-Parameter Rinv : R -> R. 
-Parameter Rlt : R -> R -> Prop.    
+Parameter Rinv : R -> R.
+Parameter Rlt : R -> R -> Prop.
 Parameter up : R -> Z.
 
 Infix "+" := Rplus : R_scope.
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index ba42bad9..55982aa5 100644
--- a/theories/Reals/Rderiv.v
+++ b/theories/Reals/Rderiv.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rderiv.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*********************************************************)
 (**     Definition of the derivative,continuity          *)
@@ -39,15 +39,15 @@ Lemma cont_deriv :
     D_in f d D x0 -> continue_in f D x0.
 Proof.
   unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *;
-    unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; 
-      intros; elim (H eps H0); clear H; intros; elim H; 
+    unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *;
+      intros; elim (H eps H0); clear H; intros; elim H;
         clear H; intros; elim (Req_dec (d x0) 0); intro.
   split with (Rmin 1 x); split.
   elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
   intros; elim H3; clear H3; intros;
     generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
-      unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
-        intros; generalize (H1 x1 (conj H3 H6)); clear H1; 
+      unfold Rgt in |- *; intro; elim (H5 H4); clear H5;
+        intros; generalize (H1 x1 (conj H3 H6)); clear H1;
           intro; unfold D_x in H3; elim H3; intros.
   rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1;
     cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
@@ -84,10 +84,10 @@ Proof.
     generalize
       (let (H1, H2) :=
         Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
-        H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
+        H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5;
       intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
-        unfold Rgt in |- *; intro; elim (H7 H5); clear H7; 
-          intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); 
+        unfold Rgt in |- *; intro; elim (H7 H5); clear H7;
+          intros; clear H4 H5; generalize (H1 x1 (conj H3 H8));
             clear H1; intro; unfold D_x in H3; elim H3; intros;
               generalize (sym_not_eq H5); clear H5; intro H5;
                 generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
@@ -114,11 +114,11 @@ Proof.
                                               rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9));
                                                 rewrite
                                                   (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2)
-                                                  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); 
+                                                  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0));
                                                     intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
                                                       rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
                                                         fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *;
-                                                          rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; 
+                                                          rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1;
                                                             intro;
                                                               generalize
                                                                 (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0)))
@@ -132,15 +132,15 @@ Proof.
                                                                       rewrite <-
                                                                         (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
                                                                           (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0))));
-                                                                        rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); 
+                                                                        rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2);
                                                                           clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps).
   intro;
     apply
       (Rlt_trans (Rabs (f x1 - f x0))
-        (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). 
+        (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11).
   clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro;
     unfold Rgt in H0;
-      generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); 
+      generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7);
         clear H7; intro;
           generalize
             (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) (
@@ -164,11 +164,11 @@ Proof.
   intro; rewrite H7 in H5;
     generalize
       (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
-        (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; 
+        (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro;
       rewrite eps2 in H10; assumption.
   unfold Rabs in |- *; case (Rcase_abs 2); auto.
   intro; cut (0 < 2).
-  intro; generalize (Rlt_asym 0 2 H7); intro; elimtype False; auto.
+  intro; generalize (Rlt_asym 0 2 H7); intro; exfalso; auto.
   fourier.
   apply Rabs_no_R0.
   discrR.
@@ -180,7 +180,7 @@ Lemma Dconst :
   forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
 Proof.
   unfold D_in in |- *; intros; unfold limit1_in in |- *;
-    unfold limit_in in |- *; unfold Rdiv in |- *; intros; 
+    unfold limit_in in |- *; unfold Rdiv in |- *; intros;
       simpl in |- *; split with eps; split; auto.
   intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l;
     unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0));
@@ -195,7 +195,7 @@ Lemma Dx :
   forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
 Proof.
   unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *;
-    unfold limit_in in |- *; intros; simpl in |- *; split with eps; 
+    unfold limit_in in |- *; intros; simpl in |- *; split with eps;
       split; auto.
   intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
     rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
@@ -204,7 +204,7 @@ Proof.
   absurd (0 < 0); auto.
   red in |- *; intro; apply (Rlt_irrefl 0 r).
   unfold Rgt in H; assumption.
-Qed. 
+Qed.
 
 (*********)
 Lemma Dadd :
@@ -218,9 +218,9 @@ Proof.
       (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
         (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
           df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *;
-      unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); 
-        clear H; intros; elim H; clear H; intros; split with x; 
-          split; auto; intros; generalize (H1 x1 H2); clear H1; 
+      unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0);
+        clear H; intros; elim H; clear H; intros; split with x;
+          split; auto; intros; generalize (H1 x1 H2); clear H1;
             intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
               rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
                 rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0))
@@ -239,11 +239,11 @@ Lemma Dmult :
     D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
 Proof.
   intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0;
-    generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; 
+    generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *;
       intro;
         generalize
           (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
-            fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); 
+            fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3);
           intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0).
   intro;
     generalize
@@ -253,11 +253,11 @@ Proof.
         generalize
           (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0)
             (fun x:R => (g x - g x0) * / (x - x0) * f x) (
-              D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); 
-          clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; 
-            simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; 
-              simpl in |- *; intros; elim (H eps H0); clear H; intros; 
-                elim H; clear H; intros; split with x; split; auto; 
+              D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4);
+          clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H;
+            simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *;
+              simpl in |- *; intros; elim (H eps H0); clear H; intros;
+                elim H; clear H; intros; split with x; split; auto;
                   intros; generalize (H1 x1 H2); clear H1; intro;
                     rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
                       rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
@@ -275,7 +275,7 @@ Proof.
   ring.
   unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
     split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
-      intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; 
+      intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H;
         assumption.
 Qed.
 
@@ -287,7 +287,7 @@ Proof.
   intros;
     generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
       unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0;
-        rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; 
+        rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0;
           assumption.
 Qed.
 
@@ -297,9 +297,9 @@ Lemma Dopp :
     D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
 Proof.
   intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      intros; generalize (H0 eps H1); clear H0; intro; elim H0; 
-        clear H0; intros; elim H0; clear H0; simpl in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      intros; generalize (H0 eps H1); clear H0; intro; elim H0;
+        clear H0; intros; elim H0; clear H0; simpl in |- *;
           intros; split with x; split; auto.
   intros; generalize (H2 x1 H3); clear H2; intro;
     rewrite Ropp_mult_distr_l_reverse in H2;
@@ -307,7 +307,7 @@ Proof.
         rewrite Ropp_mult_distr_l_reverse in H2;
           rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2;
             rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2;
-              rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; 
+              rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2;
                 assumption.
 Qed.
 
@@ -319,8 +319,8 @@ Lemma Dminus :
     D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
 Proof.
   unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro;
-    apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); 
-      assumption. 
+    apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0);
+      assumption.
 Qed.
 
 (*********)
@@ -336,8 +336,8 @@ Proof.
     (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
       fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
         H D x0)); unfold D_in in |- *; unfold limit1_in in |- *;
-    unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); 
-      clear H0; intros; elim H0; clear H0; intros; split with x; 
+    unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1);
+      clear H0; intros; elim H0; clear H0; intros; split with x;
         split; auto.
   intros; generalize (H2 x1 H3); clear H2 H3; intro;
     rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2;
@@ -365,9 +365,9 @@ Proof.
     unfold Rdiv in |- *; intros;
       generalize
         (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
-          D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); 
-        intro; generalize (cont_deriv f df Df x0 H); intro; 
-          unfold continue_in in H4; generalize (H3 H4 H2); clear H3; 
+          D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0);
+        intro; generalize (cont_deriv f df Df x0 H); intro;
+          unfold continue_in in H4; generalize (H3 H4 H2); clear H3;
             intro;
               generalize
                 (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0))
@@ -381,16 +381,16 @@ Proof.
     generalize
       (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
         fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
-      (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); 
-      intro; unfold limit1_in in |- *; unfold limit_in in |- *; 
+      (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0));
+      intro; unfold limit1_in in |- *; unfold limit_in in |- *;
         simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
-          simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); 
-            clear H5 H7; intros; elim H5; elim H7; clear H5 H7; 
+          simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8);
+            clear H5 H7; intros; elim H5; elim H7; clear H5 H7;
               intros; split with (Rmin x x1); split.
   elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b.
   intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0));
-    intros a b; clear b; unfold Rgt in a; elim (a H12); 
-      clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; 
+    intros a b; clear b; unfold Rgt in a; elim (a H12);
+      clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10;
         clear H12; elim (classic (f x2 = f x0)); intro.
   elim H11; clear H11; intros; elim H11; clear H11; intros;
     generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
@@ -412,12 +412,12 @@ Proof.
                 rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
                   rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
   clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *;
-    simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; 
-      simpl in H1; intros; elim (H1 eps H2); clear H1; intros; 
-        elim H1; clear H1; intros; split with x; split; auto; 
-          intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; 
+    simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1;
+      simpl in H1; intros; elim (H1 eps H2); clear H1; intros;
+        elim H1; clear H1; intros; split with x; split; auto;
+          intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4;
             intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)).
-Qed.   
+Qed.
 
 (*********)
 Lemma D_pow_n :
@@ -430,11 +430,11 @@ Proof.
   intros n D x0 expr dexpr H;
     generalize
       (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
-        fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); 
+        fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0)));
       intro; unfold D_in in |- *; unfold limit1_in in |- *;
         unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0;
-          unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; 
-            elim (H0 eps H1); clear H0; intros; elim H0; clear H0; 
+          unfold limit1_in in H0; unfold limit_in in H0; simpl in H0;
+            elim (H0 eps H1); clear H0; intros; elim H0; clear H0;
               intros; split with x; split; intros; auto.
   cut
     (dexpr x0 * (INR n * expr x0 ^ (n - 1)) =
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
index 906f4977..d18213db 100644
--- a/theories/Reals/Reals.v
+++ b/theories/Reals/Reals.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Reals.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (** The library REALS is divided in 6 parts :
    - Rbase: basic lemmas on R
@@ -23,7 +23,7 @@
   - Sup: for goals like ``?1<?2``
   - RCompute: for equalities with constants like ``10*10==100``
   - Reg: for goals like (continuity_pt ?1 ?2) or (derivable_pt ?1 ?2) *)
-  
+
 Require Export Rbase.
 Require Export Rfunctions.
 Require Export SeqSeries.
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index b9aec1ea..7371c8ac 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rfunctions.v 10762 2008-04-06 16:57:31Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i Some properties about pow and sum have been made with John Harrison i*)
 (*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*)
@@ -38,13 +38,13 @@ Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> 0.
 Proof.
   intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
     assumption.
-Qed.    
+Qed.
 
 (*********)
 Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat.
 Proof.
   intro; reflexivity.
-Qed. 
+Qed.
 
 (*********)
 Lemma simpl_fact :
@@ -113,7 +113,7 @@ Hint Resolve pow_lt: real.
 Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n.
 Proof.
   intros x n; elim n; simpl in |- *; auto with real.
-  intros H' H'0; elimtype False; omega.
+  intros H' H'0; exfalso; omega.
   intros n0; case n0.
   simpl in |- *; rewrite Rmult_1_r; auto.
   intros n1 H' H'0 H'1.
@@ -160,7 +160,7 @@ Proof.
     rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1);
       rewrite (Rmult_comm (INR n) (x ^ a));
         rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n));
-          rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); 
+          rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n);
             apply Rmult_comm.
 Qed.
 
@@ -185,7 +185,7 @@ Proof.
         fold (x > 0) in H;
           apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))).
   rewrite (S_INR n0); ring.
-  unfold Rle in H0; elim H0; intro. 
+  unfold Rle in H0; elim H0; intro.
   unfold Rle in |- *; left; apply Rmult_lt_compat_l.
   rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)).
   assumption.
@@ -288,7 +288,7 @@ Lemma pow_lt_1_zero :
       0 < y ->
       exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y).
 Proof.
-  intros; elim (Req_dec x 0); intro. 
+  intros; elim (Req_dec x 0); intro.
   exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero.
   rewrite Rabs_R0; assumption.
   inversion GE; auto.
@@ -619,6 +619,18 @@ Proof.
   unfold Zpower_nat in |- *; auto.
 Qed.
 
+Lemma Zpower_pos_powerRZ :
+  forall n m, IZR (Zpower_pos n m) = IZR n ^Z Zpos m.
+Proof.
+  intros.
+  rewrite Zpower_pos_nat; simpl.
+  induction (nat_of_P m).
+  easy.
+  unfold Zpower_nat; simpl.
+  rewrite mult_IZR.
+  now rewrite <- IHn0.
+Qed.
+
 Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z.
 Proof.
   intros x z; case z; simpl in |- *; auto with real.
@@ -664,7 +676,7 @@ Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z).
 (** * Sum of n first naturals  *)
 (*******************************)
 (*********)
-Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat :=
+Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat :=
   match n with
     | O => f 0%nat
     | S n' => (sum_nat_f_O f n' + f (S n'))%nat
@@ -684,7 +696,7 @@ Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x).
 (** *          Sum             *)
 (*******************************)
 (*********)
-Fixpoint sum_f_R0 (f:nat -> R) (N:nat) {struct N} : R :=
+Fixpoint sum_f_R0 (f:nat -> R) (N:nat) : R :=
   match N with
     | O => f 0%nat
     | S i => sum_f_R0 f i + f (S i)
@@ -744,9 +756,9 @@ Proof.
   unfold R_dist in |- *; intros; split_Rabs; try ring.
   generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
     rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
-      intro; unfold Rgt in H; elimtype False; auto.
+      intro; unfold Rgt in H; exfalso; auto.
   generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro;
-    generalize (Rge_antisym x y H0 H); intro; rewrite H1; 
+    generalize (Rge_antisym x y H0 H); intro; rewrite H1;
       ring.
 Qed.
 
@@ -759,7 +771,7 @@ Proof.
   rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
     apply (Rminus_diag_eq y x H0).
   apply (Rminus_diag_uniq x y H).
-  apply (Rminus_diag_eq x y H). 
+  apply (Rminus_diag_eq x y H).
 Qed.
 
 Lemma R_dist_eq : forall x:R, R_dist x x = 0.
diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v
index c96ae5d6..8890cbb5 100644
--- a/theories/Reals/Rgeom.v
+++ b/theories/Reals/Rgeom.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rgeom.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -32,7 +32,7 @@ Proof.
 Qed.
 
 Lemma distance_symm :
-  forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. 
+  forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0.
 Proof.
   intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj;
     [ apply sqrt_positivity; apply Rplus_le_le_0_compat
@@ -187,7 +187,7 @@ Lemma isometric_rot_trans :
   forall x1 y1 x2 y2 tx ty theta:R,
     Rsqr (x1 - x2) + Rsqr (y1 - y2) =
     Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) +
-    Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). 
+    Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta).
 Proof.
   intros; rewrite <- isometric_rotation_0; apply isometric_translation.
 Qed.
@@ -196,7 +196,7 @@ Lemma isometric_trans_rot :
   forall x1 y1 x2 y2 tx ty theta:R,
     Rsqr (x1 - x2) + Rsqr (y1 - y2) =
     Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) +
-    Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). 
+    Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty).
 Proof.
   intros; rewrite <- isometric_translation; apply isometric_rotation_0.
 Qed.
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
index 8d069e2d..ae2c3d77 100644
--- a/theories/Reals/RiemannInt.v
+++ b/theories/Reals/RiemannInt.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RiemannInt.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rfunctions.
 Require Import SeqSeries.
@@ -32,8 +33,8 @@ Definition Riemann_integrable (f:R -> R) (a b:R) : Type :=
           Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\
         Rabs (RiemannInt_SF psi) < eps } }.
 
-Definition phi_sequence (un:nat -> posreal) (f:R -> R) 
-  (a b:R) (pr:Riemann_integrable f a b) (n:nat) := 
+Definition phi_sequence (un:nat -> posreal) (f:R -> R)
+  (a b:R) (pr:Riemann_integrable f a b) (n:nat) :=
   projT1 (pr (un n)).
 
 Lemma phi_sequence_prop :
@@ -54,7 +55,7 @@ Lemma RiemannInt_P1 :
 Proof.
   unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros;
     elim p; clear p; intros; exists (mkStepFun (StepFun_P6 (pre x)));
-      exists (mkStepFun (StepFun_P6 (pre x0))); 
+      exists (mkStepFun (StepFun_P6 (pre x0)));
         elim p; clear p; intros; split.
   intros; apply (H t); elim H1; clear H1; intros; split;
     [ apply Rle_trans with (Rmin b a); try assumption; right;
@@ -97,7 +98,7 @@ Proof.
   elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *;
     unfold R_dist in H4; elim (H1 n); elim (H1 m); intros;
       replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with
-      (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); 
+      (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m));
       [ idtac | ring ]; rewrite <- StepFun_P30;
         apply Rle_lt_trans with
           (RiemannInt_SF
@@ -131,7 +132,7 @@ Proof.
   apply Rplus_le_compat; apply RRle_abs.
   replace (pos (un n)) with (un n - 0); [ idtac | ring ];
   replace (pos (un m)) with (un m - 0); [ idtac | ring ];
-  rewrite (double_var eps); apply Rplus_lt_compat; apply H4; 
+  rewrite (double_var eps); apply Rplus_lt_compat; apply H4;
     assumption.
 Qed.
 
@@ -179,8 +180,8 @@ Proof.
   rewrite Rabs_Ropp in H4; apply H4.
   apply H4.
   assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros;
-    exists (- x); unfold Un_cv in |- *; unfold Un_cv in p; 
-      intros; elim (p _ H4); intros; exists x0; intros; 
+    exists (- x); unfold Un_cv in |- *; unfold Un_cv in p;
+      intros; elim (p _ H4); intros; exists x0; intros;
         generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *;
           case (Rle_dec b a); case (Rle_dec a b); intros.
   elim n; assumption.
@@ -189,7 +190,7 @@ Proof.
     (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0)))))
       (subdivision (mkStepFun (StepFun_P6 (pre (vn n0))))));
     [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
-      rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+      rewrite Ropp_plus_distr; rewrite Ropp_involutive;
         apply H7
       | symmetry  in |- *; apply StepFun_P17 with (fe (vn n0)) a b;
         [ apply StepFun_P1
@@ -200,7 +201,7 @@ Proof.
 Qed.
 
 Lemma RiemannInt_exists :
-  forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) 
+  forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b)
     (un:nat -> posreal),
     Un_cv un 0 ->
     { l:R | Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l }.
@@ -281,7 +282,7 @@ Proof.
   assumption.
   replace (pos (un n)) with (Rabs (un n - 0));
   [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_trans with (max N0 N1); 
+    unfold N in |- *; apply le_trans with (max N0 N1);
       apply le_max_l
     | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
       apply Rle_ge; left; apply (cond_pos (un n)) ].
@@ -346,7 +347,7 @@ Proof.
     unfold N in |- *; apply le_trans with (max N0 N1);
       [ apply le_max_r | apply le_max_l ]
     | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-      rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+      rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
         left; apply (cond_pos (vn n)) ].
   apply Rlt_trans with (pos (un n)).
   elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
@@ -354,7 +355,7 @@ Proof.
   assumption.
   replace (pos (un n)) with (Rabs (un n - 0));
   [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_trans with (max N0 N1); 
+    unfold N in |- *; apply le_trans with (max N0 N1);
       apply le_max_l
     | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
       apply Rle_ge; left; apply (cond_pos (un n)) ].
@@ -382,7 +383,7 @@ Proof.
   apply le_IZR; left; apply Rlt_trans with (/ eps);
     [ apply Rinv_0_lt_compat; assumption | assumption ].
   elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *;
-    simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; 
+    simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0;
       rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1).
   apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
   rewrite Rabs_right;
@@ -406,7 +407,7 @@ Proof.
   red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
 Qed.
 
-(**********) 
+(**********)
 Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R :=
   let (a,_) := RiemannInt_exists pr RinvN RinvN_cv in a.
 
@@ -416,14 +417,14 @@ Lemma RiemannInt_P5 :
 Proof.
   intros; unfold RiemannInt in |- *;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
       eapply UL_sequence;
         [ apply u0
           | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ].
 Qed.
 
 (***************************************)
-(** C°([a,b]) is included in L1([a,b]) *)
+(** C°([a,b]) is included in L1([a,b]) *)
 (***************************************)
 
 Lemma maxN :
@@ -452,8 +453,8 @@ Proof.
   apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del);
     assumption.
   assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5;
-    unfold Nbound in |- *; exists N; intros; unfold I in H6; 
-      apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; 
+    unfold Nbound in |- *; exists N; intros; unfold I in H6;
+      apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2;
         left; apply Rle_lt_trans with ((b - a) / del); try assumption;
           apply Rmult_le_reg_l with (pos del);
             [ apply (cond_pos del)
@@ -465,7 +466,7 @@ Proof.
                       elim (Rlt_irrefl _ H7) ] ].
 Qed.
 
-Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist :=
+Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) : Rlist :=
   match N with
     | O => cons y nil
     | S p => cons x (SubEquiN p (x + del) y del)
@@ -498,11 +499,11 @@ Proof.
             a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps));
       assert (H1 : bound E).
   unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros;
-    unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; 
+    unfold E in H1; elim H1; clear H1; intros H1 _; elim H1;
       intros; assumption.
   assert (H2 :  exists x : R, E x).
   assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps);
-    elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; 
+    elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *;
       split;
         [ split;
           [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro;
@@ -530,7 +531,7 @@ Proof.
   unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros;
     split.
   elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6;
-    intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; 
+    intros H6 _; elim H6; intros; apply Rlt_le_trans with x0;
       assumption.
   apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6;
     intros; assumption.
@@ -579,7 +580,7 @@ Proof.
             | intros;
               change
                 (pos_Rl (SubEquiN (S n) (a0 + del0) b del0)
-                  (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) 
+                  (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b)
                 in |- *; apply H ] ].
 Qed.
 
@@ -633,7 +634,7 @@ Proof.
   2: apply le_lt_n_Sm; assumption.
   apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r;
     pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r;
-      apply Rplus_le_compat_l; rewrite Rmult_1_l; left; 
+      apply Rplus_le_compat_l; rewrite Rmult_1_l; left;
         apply (cond_pos del).
 Qed.
 
@@ -686,7 +687,7 @@ Proof.
     [ reflexivity | elim n; left; assumption ].
   elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4;
     elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi;
-      split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); 
+      split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a)))));
         split.
   2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
   2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
@@ -731,7 +732,7 @@ Proof.
   apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) (max_N del H)).
   replace
   (pos_Rl (SubEqui del H) (max_N del H) +
-    (t - pos_Rl (SubEqui del H) (max_N del H))) with t; 
+    (t - pos_Rl (SubEqui del H) (max_N del H))) with t;
   [ idtac | ring ]; apply Rlt_le_trans with b.
   rewrite H14 in H12;
     assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))).
@@ -760,20 +761,20 @@ Proof.
     intros; assumption.
   assert (H4 : Nbound I).
   unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *;
-    case (maxN del H); intros; elim a0; clear a0; intros _ H5; 
+    case (maxN del H); intros; elim a0; clear a0; intros _ H5;
       apply INR_le; apply Rmult_le_reg_l with (pos del).
   apply (cond_pos del).
   apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del);
     apply Rle_trans with t0; unfold I in H4; try assumption;
-      apply Rle_trans with b; try assumption; elim H8; intros; 
+      apply Rle_trans with b; try assumption; elim H8; intros;
         assumption.
   elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat).
   unfold max_N in |- *; case (maxN del H); intros; apply INR_lt;
     apply Rmult_lt_reg_l with (pos del).
   apply (cond_pos del).
   apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del);
-    apply Rle_lt_trans with t0; unfold I in H5; try assumption; 
-      elim a0; intros; apply Rlt_le_trans with b; try assumption; 
+    apply Rle_lt_trans with t0; unfold I in H5; try assumption;
+      elim a0; intros; apply Rlt_le_trans with b; try assumption;
         elim H8; intros.
   elim H11; intro.
   assumption.
@@ -1027,7 +1028,7 @@ Proof.
   unfold Riemann_integrable in |- *; intros f g; intros; case (Req_EM_T l 0);
     intro.
   elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0;
-    intros; split; try assumption; rewrite e; intros; 
+    intros; split; try assumption; rewrite e; intros;
       rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption.
   assert (H : 0 < eps / 2).
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
@@ -1038,8 +1039,8 @@ Proof.
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
   elim (X (mkposreal _ H)); intros; elim (X0 (mkposreal _ H0)); intros;
-    split with (mkStepFun (StepFun_P28 l x x0)); elim p0; 
-      elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); 
+    split with (mkStepFun (StepFun_P28 l x x0)); elim p0;
+      elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2));
         elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split.
   intros; simpl in |- *;
     apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))).
@@ -1098,7 +1099,7 @@ Proof.
   replace eps with (2 * (eps / 3) + eps / 3).
   apply Rplus_lt_compat.
   replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
-  (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
+  (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n));
   [ idtac | ring ].
   rewrite <- StepFun_P30.
   apply Rle_lt_trans with
@@ -1146,7 +1147,7 @@ Proof.
   apply H; unfold ge in |- *; apply le_trans with N; try assumption;
     unfold N in |- *; apply le_max_l.
   unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
       left; apply (cond_pos (un n)).
   unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
     try assumption; unfold N in |- *; apply le_max_r.
@@ -1172,7 +1173,7 @@ Proof.
   replace eps with (2 * (eps / 3) + eps / 3).
   apply Rplus_lt_compat.
   replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
-  (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
+  (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n));
   [ idtac | ring ].
   rewrite <- StepFun_P30.
   rewrite StepFun_P39.
@@ -1238,7 +1239,7 @@ Proof.
   apply H; unfold ge in |- *; apply le_trans with N; try assumption;
     unfold N in |- *; apply le_max_l.
   unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
       left; apply (cond_pos (un n)).
   unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
     try assumption; unfold N in |- *; apply le_max_r.
@@ -1258,7 +1259,7 @@ Proof.
   intro f; intros; case (Req_dec l 0); intro.
   pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
     unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
-      case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; 
+      case (RiemannInt_exists pr1 RinvN RinvN_cv); intros;
         eapply UL_sequence;
           [ apply u0
             | set (psi1 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n));
@@ -1283,13 +1284,13 @@ Proof.
     intros; apply u.
   unfold Un_cv in |- *; intros; unfold RiemannInt in |- *;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; 
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *;
       intros; assert (H2 : 0 < eps / 5).
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv);
     unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4;
-      assert (H5 : 0 < eps / (5 * Rabs l)). 
+      assert (H5 : 0 < eps / (5 * Rabs l)).
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
     [ assumption
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
@@ -1380,7 +1381,7 @@ Proof.
       (RiemannInt_SF (phi_sequence RinvN pr3 n) +
         -1 *
         (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-          l * RiemannInt_SF (phi_sequence RinvN pr2 n))); 
+          l * RiemannInt_SF (phi_sequence RinvN pr2 n)));
       [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a).
   unfold Rmin in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
@@ -1421,7 +1422,7 @@ Proof.
   rewrite Rplus_assoc; apply Rplus_le_compat.
   elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
     apply H13.
-  elim H12; intros; split; left; assumption. 
+  elim H12; intros; split; left; assumption.
   apply Rle_trans with
     (Rabs (f x1 - phi_sequence RinvN pr1 n x1) +
       Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)).
@@ -1487,7 +1488,7 @@ Proof.
     [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l;
       do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
-      | discrR ]. 
+      | discrR ].
 Qed.
 
 Lemma RiemannInt_P13 :
@@ -1517,7 +1518,7 @@ Proof.
     split with (mkStepFun (StepFun_P4 a b c));
       split with (mkStepFun (StepFun_P4 a b 0)); split;
         [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
-          rewrite Rabs_R0; unfold fct_cte in |- *; right; 
+          rewrite Rabs_R0; unfold fct_cte in |- *; right;
             reflexivity
           | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
             apply (cond_pos eps) ].
@@ -1546,12 +1547,12 @@ Proof.
   elim H1; clear H1; intros psi1 H1;
     set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c));
       set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0));
-        apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; 
+        apply RiemannInt_P11 with f RinvN phi2 psi2 psi1;
           try assumption.
   apply RinvN_cv.
   intro; split.
   intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *;
-    rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; 
+    rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *;
       right; reflexivity.
   unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
     apply (cond_pos (RinvN n)).
@@ -1594,7 +1595,7 @@ Proof.
   apply Rmult_eq_reg_l with 2;
     [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
       rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2);
-        repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
+        repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
           [ ring | discrR ]
       | discrR ].
   apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1;
@@ -1637,7 +1638,7 @@ Proof.
               Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\
             Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
   split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro;
-    apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). 
+    apply (proj2_sig (phi_sequence_prop RinvN pr2 n)).
   assert
     (H1 :
       exists psi2 : nat -> StepFun a b,
@@ -1674,7 +1675,7 @@ Lemma RiemannInt_P18 :
 Proof.
   intro f; intros; unfold RiemannInt in |- *;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
       eapply UL_sequence.
   apply u0.
   set (phi1 := fun N:nat => phi_sequence RinvN pr1 N);
@@ -1688,7 +1689,7 @@ Proof.
                 Rabs (f t - phi1 n t) <= psi1 n t) /\
               Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
   split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro;
-    apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). 
+    apply (proj2_sig (phi_sequence_prop RinvN pr1 n)).
   elim H1; clear H1; intros psi1 H1;
     set (phi2 := fun N:nat => phi_sequence RinvN pr2 N).
   set
@@ -1712,10 +1713,10 @@ Proof.
             Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\
           Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
   split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro;
-    apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). 
+    apply (proj2_sig (phi_sequence_prop RinvN pr2 n)).
   elim H2; clear H2; intros psi2 H2;
-    apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; 
-      try assumption. 
+    apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1;
+      try assumption.
   apply RinvN_cv.
   intro; elim (H2 n); intros; split; try assumption.
   intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
@@ -1764,11 +1765,11 @@ Proof.
   right; reflexivity.
   intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2;
     unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2];
-      split with l; split with lf; unfold adapted_couple in H2; 
-        decompose [and] H2; clear H2; unfold adapted_couple in |- *; 
+      split with l; split with lf; unfold adapted_couple in H2;
+        decompose [and] H2; clear H2; unfold adapted_couple in |- *;
           repeat split; try assumption.
   intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9;
-    unfold constant_D_eq, open_interval in |- *; intros; 
+    unfold constant_D_eq, open_interval in |- *; intros;
       rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i).
   replace a with (Rmin a b).
   rewrite <- H5; elim (RList_P6 l); intros; apply H10.
@@ -1808,7 +1809,7 @@ Proof.
   (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))).
   apply
     (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1)
-      (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); 
+      (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1)));
     assumption.
   replace (RiemannInt pr2 + - RiemannInt pr1) with
   (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)).
@@ -1833,7 +1834,7 @@ Proof.
 Qed.
 
 Definition primitive (f:R -> R) (a b:R) (h:a <= b)
-  (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) 
+  (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x)
   (x:R) : R :=
   match Rle_dec a x with
     | left r =>
@@ -1977,20 +1978,20 @@ Proof.
         | elim n0; left; assumption ].
   apply StepFun_P46 with b; assumption.
   assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
-    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
-      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
-        clear H3; unfold adapted_couple in |- *; repeat split; 
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3;
+        clear H3; unfold adapted_couple in |- *; repeat split;
           try assumption.
   intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
-    unfold constant_D_eq, open_interval in H9; intros; 
+    unfold constant_D_eq, open_interval in H9; intros;
       rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
   apply Rle_lt_trans with (pos_Rl l1 i).
   replace b with (Rmin b c).
   rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
-      discriminate. 
+    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+      discriminate.
   unfold Rmin in |- *; case (Rle_dec b c); intro;
     [ reflexivity | elim n; assumption ].
   elim H7; intros; assumption.
@@ -2000,19 +2001,19 @@ Proof.
       | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
       | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
   assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
-    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
-      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
-        clear H3; unfold adapted_couple in |- *; repeat split; 
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3;
+        clear H3; unfold adapted_couple in |- *; repeat split;
           try assumption.
   intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
-    unfold constant_D_eq, open_interval in H9; intros; 
+    unfold constant_D_eq, open_interval in H9; intros;
       rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
   apply Rle_trans with (pos_Rl l1 (S i)).
   elim H7; intros; left; assumption.
   replace b with (Rmax a b).
   rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
-    discriminate. 
+    discriminate.
   unfold Rmax in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H11 : a <= x).
@@ -2021,8 +2022,8 @@ Proof.
   rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
-      discriminate. 
+    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6;
+      discriminate.
   unfold Rmin in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   left; elim H7; intros; assumption.
@@ -2030,19 +2031,19 @@ Proof.
     assumption.
   apply StepFun_P46 with b.
   assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
-    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
-      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
-        clear H3; unfold adapted_couple in |- *; repeat split; 
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3;
+        clear H3; unfold adapted_couple in |- *; repeat split;
           try assumption.
   intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
-    unfold constant_D_eq, open_interval in H9; intros; 
+    unfold constant_D_eq, open_interval in H9; intros;
       rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
   apply Rle_trans with (pos_Rl l1 (S i)).
   elim H7; intros; left; assumption.
   replace b with (Rmax a b).
   rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
-    discriminate. 
+    discriminate.
   unfold Rmax in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H11 : a <= x).
@@ -2051,28 +2052,28 @@ Proof.
   rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
-      discriminate. 
+    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6;
+      discriminate.
   unfold Rmin in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   left; elim H7; intros; assumption.
   unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
     reflexivity || elim n; assumption.
   assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
-    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
-      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
-        clear H3; unfold adapted_couple in |- *; repeat split; 
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3;
+        clear H3; unfold adapted_couple in |- *; repeat split;
           try assumption.
   intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
-    unfold constant_D_eq, open_interval in H9; intros; 
+    unfold constant_D_eq, open_interval in H9; intros;
       rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
   apply Rle_lt_trans with (pos_Rl l1 i).
   replace b with (Rmin b c).
   rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
-      discriminate. 
+    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+      discriminate.
   unfold Rmin in |- *; case (Rle_dec b c); intro;
     [ reflexivity | elim n; assumption ].
   elim H7; intros; assumption.
@@ -2088,7 +2089,7 @@ Lemma RiemannInt_P22 :
     Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c.
 Proof.
   unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
-    intros phi [psi H0]; elim H; elim H0; clear H H0; 
+    intros phi [psi H0]; elim H; elim H0; clear H H0;
       intros; assert (H3 : IsStepFun phi a c).
   apply StepFun_P44 with b.
   apply (pre phi).
@@ -2178,7 +2179,7 @@ Lemma RiemannInt_P23 :
     Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b.
 Proof.
   unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
-    intros phi [psi H0]; elim H; elim H0; clear H H0; 
+    intros phi [psi H0]; elim H; elim H0; clear H H0;
       intros; assert (H3 : IsStepFun phi c b).
   apply StepFun_P45 with a.
   apply (pre phi).
@@ -2294,7 +2295,7 @@ Proof.
   intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
     case (RiemannInt_exists pr2 RinvN RinvN_cv);
-    case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; 
+    case (RiemannInt_exists pr3 RinvN RinvN_cv); intros;
       symmetry  in |- *; eapply UL_sequence.
   apply u.
   unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3).
@@ -2309,7 +2310,7 @@ Proof.
             (RiemannInt_SF (phi_sequence RinvN pr1 n) +
               RiemannInt_SF (phi_sequence RinvN pr2 n))) 0).
   intro; elim (H3 _ H0); clear H3; intros N3 H3;
-    set (N0 := max (max N1 N2) N3); exists N0; intros; 
+    set (N0 := max (max N1 N2) N3); exists N0; intros;
       unfold R_dist in |- *;
         apply Rle_lt_trans with
           (Rabs
@@ -2368,7 +2369,7 @@ Proof.
               Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
             Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
   split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro;
-    apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). 
+    apply (proj2_sig (phi_sequence_prop RinvN pr1 n)).
   assert
     (H2 :
       exists psi2 : nat -> StepFun b c,
@@ -2378,7 +2379,7 @@ Proof.
             Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
           Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
   split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro;
-    apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). 
+    apply (proj2_sig (phi_sequence_prop RinvN pr2 n)).
   assert
     (H3 :
       exists psi3 : nat -> StepFun a c,
@@ -2388,9 +2389,9 @@ Proof.
             Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
           Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
   split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro;
-    apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). 
+    apply (proj2_sig (phi_sequence_prop RinvN pr3 n)).
   elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3;
-    clear H3; intros psi3 H3; assert (H := RinvN_cv); 
+    clear H3; intros psi3 H3; assert (H := RinvN_cv);
       unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3).
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
@@ -2401,14 +2402,14 @@ Proof.
     (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0).
   apply H; assumption.
   unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
       left; apply (cond_pos (RinvN n)).
   exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3;
-    intros; unfold R_dist in |- *; unfold Rminus in |- *; 
-      rewrite Ropp_0; rewrite Rplus_0_r; 
+    intros; unfold R_dist in |- *; unfold Rminus in |- *;
+      rewrite Ropp_0; rewrite Rplus_0_r;
         set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *;
-          set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; 
-            set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; 
+          set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *;
+            set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *;
               assert (H10 : IsStepFun phi3 a b).
   apply StepFun_P44 with c.
   apply (pre phi3).
@@ -2832,7 +2833,7 @@ Proof.
     (derivable_pt_lim
       ((fct_cte (f b) * (id - fct_cte b))%F +
         fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
-          f b + 0)) in |- *. 
+          f b + 0)) in |- *.
   apply derivable_pt_lim_plus.
   pattern (f b) at 2 in |- *;
     replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
@@ -2899,7 +2900,7 @@ Proof.
   apply
     (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))
       (RiemannInt_P16
-        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); 
+        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))));
     left; assumption.
   apply Rle_lt_trans with
     (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)).
@@ -2953,13 +2954,13 @@ Proof.
   rewrite RiemannInt_P15.
   rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0;
     [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *;
-      repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
+      repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
         [ ring | assumption ]
       | assumption ].
   cut (a <= b + h0).
   cut (b + h0 <= b).
   intros; unfold primitive in |- *; case (Rle_dec a (b + h0));
-    case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); 
+    case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b);
     intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
   rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring.
   elim n; assumption.
@@ -3083,7 +3084,7 @@ Proof.
   apply
     (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))
       (RiemannInt_P16
-        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); 
+        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))));
     left; assumption.
   apply Rle_lt_trans with
     (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)).
@@ -3138,7 +3139,7 @@ Proof.
   cut (a <= a + h0).
   cut (a + h0 <= b).
   intros; unfold primitive in |- *; case (Rle_dec a (a + h0));
-    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
+    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b);
     intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
   rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0;
     rewrite Rplus_0_r; apply RiemannInt_P5.
@@ -3174,7 +3175,7 @@ Proof.
     (derivable_pt_lim
       ((fct_cte (f b) * (id - fct_cte b))%F +
         fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
-          f b + 0)) in |- *. 
+          f b + 0)) in |- *.
   apply derivable_pt_lim_plus.
   pattern (f b) at 2 in |- *;
     replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
@@ -3198,7 +3199,7 @@ Proof.
   pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
   rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0));
-    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
+    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b);
     intros; try (elim n; right; assumption || reflexivity).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
@@ -3216,7 +3217,7 @@ Proof.
   assumption.
   elim H8; symmetry  in |- *; assumption.
   rewrite H0 in H1; rewrite H1; unfold primitive in |- *;
-    case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); 
+    case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b);
     case (Rle_dec a b); case (Rle_dec b b); intros;
       try (elim n; right; assumption || reflexivity).
   rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
@@ -3286,7 +3287,7 @@ Proof.
   intros; apply (cont1 f).
   rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr);
     assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H);
-      elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); 
+      elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2);
         intros C H3; repeat rewrite H3;
           [ ring
             | split; [ right; reflexivity | assumption ]
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index 7a02544e..f9b1b890 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RiemannInt_SF.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -36,8 +36,8 @@ Proof.
   intros I H H0; set (E := fun x:R =>  exists i : nat, I i /\ INR i = x);
     assert (H1 : bound E).
   unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *;
-    exists (INR N); unfold is_upper_bound in |- *; intros; 
-      unfold E in H2; elim H2; intros; elim H3; intros; 
+    exists (INR N); unfold is_upper_bound in |- *; intros;
+      unfold E in H2; elim H2; intros; elim H3; intros;
         rewrite <- H5; apply le_INR; apply H1; assumption.
   assert (H2 :  exists x : R, E x).
   elim H; intros; exists (INR x); unfold E in |- *; exists x; split;
@@ -54,13 +54,13 @@ Proof.
     assert (H9 : x <= IZR (up x) - 1).
   apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros;
     elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1;
-      replace (1 + (IZR (up x) - 1)) with (IZR (up x)); 
+      replace (1 + (IZR (up x) - 1)) with (IZR (up x));
       [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1));
       [ idtac | rewrite S_INR; ring ].
   assert (H14 : (0 <= up x)%Z).
   apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
   assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15;
-    rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; 
+    rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S;
       apply INR_lt; rewrite H13; apply Rle_lt_trans with x;
         [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ].
   assert (H10 : x = IZR (up x) - 1).
@@ -68,7 +68,7 @@ Proof.
     [ assumption
       | apply Rplus_le_reg_l with (- x + 1);
         replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x);
-        [ idtac | ring ]; replace (- x + 1 + x) with 1; 
+        [ idtac | ring ]; replace (- x + 1 + x) with 1;
         [ assumption | ring ] ].
   assert (H11 : (0 <= up x)%Z).
   apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
@@ -104,7 +104,7 @@ Proof.
     simpl in |- *; split.
   assumption.
   intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros;
-    rewrite H20; apply H4; unfold E in |- *; exists i; 
+    rewrite H20; apply H4; unfold E in |- *; exists i;
       split; [ assumption | reflexivity ].
 Qed.
 
@@ -113,7 +113,7 @@ Qed.
 (*******************************************)
 
 Definition open_interval (a b x:R) : Prop := a < x < b.
-Definition co_interval (a b x:R) : Prop := a <= x < b. 
+Definition co_interval (a b x:R) : Prop := a <= x < b.
 
 Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop :=
   ordered_Rlist l /\
@@ -149,7 +149,7 @@ Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist :=
     | existT a b => a
   end.
 
-Boxed Fixpoint Int_SF (l k:Rlist) {struct l} : R :=
+Boxed Fixpoint Int_SF (l k:Rlist) : R :=
   match l with
     | nil => 0
     | cons a l' =>
@@ -174,7 +174,7 @@ Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R :=
 Lemma StepFun_P1 :
   forall (a b:R) (f:StepFun a b),
     adapted_couple f a b (subdivision f) (subdivision_val f).
-Proof. 
+Proof.
   intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros;
     apply a0.
 Qed.
@@ -182,7 +182,7 @@ Qed.
 Lemma StepFun_P2 :
   forall (a b:R) (f:R -> R) (l lf:Rlist),
     adapted_couple f a b l lf -> adapted_couple f b a l lf.
-Proof. 
+Proof.
   unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
     repeat split; try assumption.
   rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro;
@@ -199,7 +199,7 @@ Lemma StepFun_P3 :
   forall a b c:R,
     a <= b ->
     adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil).
-Proof. 
+Proof.
   intros; unfold adapted_couple in |- *; repeat split.
   unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0;
     [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ].
@@ -212,19 +212,19 @@ Proof.
 Qed.
 
 Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b.
-Proof. 
+Proof.
   intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro.
   apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *;
     apply existT with (cons c nil); apply (StepFun_P3 c r).
   apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *;
-    apply existT with (cons c nil); apply StepFun_P2; 
+    apply existT with (cons c nil); apply StepFun_P2;
       apply StepFun_P3; auto with real.
 Qed.
 
 Lemma StepFun_P5 :
   forall (a b:R) (f:R -> R) (l:Rlist),
     is_subdivision f a b l -> is_subdivision f b a l.
-Proof. 
+Proof.
   destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x;
     repeat split; try assumption.
   rewrite H1; apply Rmin_comm.
@@ -233,7 +233,7 @@ Qed.
 
 Lemma StepFun_P6 :
   forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a.
-Proof. 
+Proof.
   unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x;
     apply StepFun_P5; assumption.
 Qed.
@@ -243,7 +243,7 @@ Lemma StepFun_P7 :
     a <= b ->
     adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) ->
     adapted_couple f r2 b (cons r2 l) lf.
-Proof. 
+Proof.
   unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0;
     assert (H5 : Rmax a b = b).
   unfold Rmax in |- *; case (Rle_dec a b); intro;
@@ -258,7 +258,7 @@ Proof.
   unfold Rmax in |- *; case (Rle_dec r2 b); intro;
     [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ].
   simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1;
-    do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; 
+    do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR;
       rewrite H4; reflexivity.
   intros; unfold constant_D_eq, open_interval in |- *; intros;
     unfold constant_D_eq, open_interval in H6;
@@ -270,7 +270,7 @@ Qed.
 Lemma StepFun_P8 :
   forall (f:R -> R) (l1 lf1:Rlist) (a b:R),
     adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0.
-Proof. 
+Proof.
   simple induction l1.
   intros; induction  lf1 as [| r lf1 Hreclf1]; reflexivity.
   simple induction r0.
@@ -285,7 +285,7 @@ Proof.
   ring.
   rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ].
   clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1;
-    intros; simpl in H4; rewrite H4; unfold Rmin in |- *; 
+    intros; simpl in H4; rewrite H4; unfold Rmin in |- *;
       case (Rle_dec a b); intro; [ assumption | reflexivity ].
   unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym.
   apply (H3 0%nat); simpl in |- *; apply lt_O_Sn.
@@ -299,14 +299,14 @@ Qed.
 Lemma StepFun_P9 :
   forall (a b:R) (f:R -> R) (l lf:Rlist),
     adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat.
-Proof. 
+Proof.
   intros; unfold adapted_couple in H; decompose [and] H; clear H;
     induction  l as [| r l Hrecl];
       [ simpl in H4; discriminate
         | induction  l as [| r0 l Hrecl0];
           [ simpl in H3; simpl in H2; generalize H3; generalize H2;
-            unfold Rmin, Rmax in |- *; case (Rle_dec a b); 
-              intros; elim H0; rewrite <- H5; rewrite <- H7; 
+            unfold Rmin, Rmax in |- *; case (Rle_dec a b);
+              intros; elim H0; rewrite <- H5; rewrite <- H7;
                 reflexivity
             | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ].
 Qed.
@@ -317,13 +317,13 @@ Lemma StepFun_P10 :
     adapted_couple f a b l lf ->
     exists l' : Rlist,
       (exists lf' : Rlist, adapted_couple_opt f a b l' lf').
-Proof. 
+Proof.
   simple induction l.
   intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4;
     discriminate.
   intros; case (Req_dec a b); intro.
   exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *;
-    unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; 
+    unfold adapted_couple in |- *; unfold ordered_Rlist in |- *;
       repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)).
   simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro;
     reflexivity.
@@ -341,7 +341,7 @@ Proof.
   replace a with t2.
   apply H6.
   rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1;
-    decompose [and] H1; clear H1; simpl in H9; rewrite H9; 
+    decompose [and] H1; clear H1; simpl in H9; rewrite H9;
       unfold Rmin in |- *; case (Rle_dec a b); intro;
         [ reflexivity | elim n; assumption ].
   elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro.
@@ -360,7 +360,7 @@ Proof.
       decompose [and] H1; apply (H16 0%nat).
   simpl in |- *; apply lt_O_Sn.
   unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13;
-    rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); 
+    rewrite H13; unfold Rmin in |- *; case (Rle_dec a b);
       intro; [ assumption | elim n; assumption ].
   elim (le_Sn_O _ H10).
   intros; simpl in H8; elim (lt_n_O _ H8).
@@ -377,7 +377,7 @@ Proof.
   clear Hreclf'; case (Req_dec r1 r2); intro.
   case (Req_dec (f t2) r1); intro.
   exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1;
-    rewrite H9 in H6; unfold adapted_couple in H6, H1; 
+    rewrite H9 in H6; unfold adapted_couple in H6, H1;
       decompose [and] H1; decompose [and] H6; clear H1 H6;
         unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
           repeat split.
@@ -417,7 +417,7 @@ Proof.
     change
       (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/
         f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i)
-      in |- *; rewrite <- H9; elim H8; intros; apply H6; 
+      in |- *; rewrite <- H9; elim H8; intros; apply H6;
         simpl in |- *; apply H1.
   intros; induction  i as [| i Hreci].
   simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
@@ -427,7 +427,7 @@ Proof.
   elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *;
     simpl in H1; apply H1.
   exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
-    rewrite H3 in H1; unfold adapted_couple in H1, H6; 
+    rewrite H3 in H1; unfold adapted_couple in H1, H6;
       decompose [and] H6; decompose [and] H1; clear H6 H1;
         unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
           repeat split.
@@ -438,7 +438,7 @@ Proof.
   simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
   change
     (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
-    in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; 
+    in |- *; apply (H12 i); simpl in |- *; apply lt_S_n;
       assumption.
   simpl in |- *; simpl in H19; apply H19.
   rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *;
@@ -470,7 +470,7 @@ Proof.
   elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1;
     simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
   exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
-    rewrite H3 in H1; unfold adapted_couple in H1, H6; 
+    rewrite H3 in H1; unfold adapted_couple in H1, H6;
       decompose [and] H6; decompose [and] H1; clear H6 H1;
         unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
           repeat split.
@@ -481,7 +481,7 @@ Proof.
   simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
   change
     (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
-    in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; 
+    in |- *; apply (H11 i); simpl in |- *; apply lt_S_n;
       assumption.
   simpl in |- *; simpl in H18; apply H18.
   rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *;
@@ -518,14 +518,14 @@ Proof.
 Qed.
 
 Lemma StepFun_P11 :
-  forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
+  forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist)
     (f:R -> R),
     a < b ->
     adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
     adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
-Proof. 
+Proof.
   intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros;
-    unfold adapted_couple in H0, H1; decompose [and] H0; 
+    unfold adapted_couple in H0, H1; decompose [and] H0;
       decompose [and] H1; clear H0 H1; assert (H12 : r = s1).
   simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity.
   assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro.
@@ -542,7 +542,7 @@ Proof.
   clear Hreclf2; assert (H17 : r3 = r4).
   set (x := (r + s2) / 2); assert (H17 := H8 0%nat (lt_O_Sn _));
     assert (H18 := H13 0%nat (lt_O_Sn _));
-      unfold constant_D_eq, open_interval in H17, H18; simpl in H17; 
+      unfold constant_D_eq, open_interval in H17, H18; simpl in H17;
         simpl in H18; rewrite <- (H17 x).
   rewrite <- (H18 x).
   reflexivity.
@@ -582,7 +582,7 @@ Proof.
       | unfold open_interval in |- *; simpl in |- *; split; assumption ].
   assert (H19 : r3 = r5).
   assert (H19 := H7 1%nat); simpl in H19;
-    assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; 
+    assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20;
       intro.
   set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat);
     assert (H23 := H13 1%nat); simpl in H22; simpl in H23;
@@ -595,7 +595,7 @@ Proof.
       | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-            unfold Rmin in |- *; case (Rle_dec r1 r0); intro; 
+            unfold Rmin in |- *; case (Rle_dec r1 r0); intro;
               assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
@@ -616,7 +616,7 @@ Proof.
           | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
             rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
               [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-                unfold Rmin in |- *; case (Rle_dec r1 r0); 
+                unfold Rmin in |- *; case (Rle_dec r1 r0);
                   intro; assumption
                 | discrR ] ] ].
   apply Rmult_lt_reg_l with 2;
@@ -630,7 +630,7 @@ Proof.
                 | apply Rplus_le_compat_l; apply Rmin_l ]
             | discrR ] ].
   elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23;
-    assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; 
+    assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24;
       assumption.
   elim H2; intros; assert (H22 := H20 0%nat); simpl in H22;
     assert (H23 := H22 (lt_O_Sn _)); elim H23; intro;
@@ -644,7 +644,7 @@ Qed.
 Lemma StepFun_P12 :
   forall (a b:R) (f:R -> R) (l lf:Rlist),
     adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf.
-Proof. 
+Proof.
   unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros;
     decompose [and] H; clear H; repeat split; try assumption.
   rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro;
@@ -658,12 +658,12 @@ Proof.
 Qed.
 
 Lemma StepFun_P13 :
-  forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
+  forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist)
     (f:R -> R),
     a <> b ->
     adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
     adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
-Proof. 
+Proof.
   intros; case (total_order_T a b); intro.
   elim s; intro.
   eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ].
@@ -677,7 +677,7 @@ Lemma StepFun_P14 :
     a <= b ->
     adapted_couple f a b l1 lf1 ->
     adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
-Proof. 
+Proof.
   simple induction l1.
   intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H;
     clear H H0 H2 H3 H1 H6; simpl in H4; discriminate.
@@ -705,7 +705,7 @@ Proof.
     clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
   clear Hreclf2; assert (H6 : r = s1).
   unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2;
-    clear H H2; simpl in H13; simpl in H8; rewrite H13; 
+    clear H H2; simpl in H13; simpl in H8; rewrite H13;
       rewrite H8; reflexivity.
   assert (H7 : r3 = r4 \/ r = r1).
   case (Req_dec r r1); intro.
@@ -718,7 +718,7 @@ Proof.
   rewrite <- (H20 (lt_O_Sn _) x).
   reflexivity.
   assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro;
-    [ idtac | elim H7; assumption ]; unfold x in |- *; 
+    [ idtac | elim H7; assumption ]; unfold x in |- *;
       split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
@@ -734,7 +734,7 @@ Proof.
             apply Rplus_lt_compat_l; apply H
             | discrR ] ].
   rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21;
-    intro; [ idtac | elim H7; assumption ]; unfold x in |- *; 
+    intro; [ idtac | elim H7; assumption ]; unfold x in |- *;
       split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
@@ -884,7 +884,7 @@ Lemma StepFun_P15 :
   forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
     adapted_couple f a b l1 lf1 ->
     adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
-Proof. 
+Proof.
   intros; case (Rle_dec a b); intro;
     [ apply (StepFun_P14 r H H0)
       | assert (H1 : b <= a);
@@ -897,8 +897,8 @@ Lemma StepFun_P16 :
   forall (f:R -> R) (l lf:Rlist) (a b:R),
     adapted_couple f a b l lf ->
     exists l' : Rlist,
-      (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). 
-Proof. 
+      (exists lf' : Rlist, adapted_couple_opt f a b l' lf').
+Proof.
   intros; case (Rle_dec a b); intro;
     [ apply (StepFun_P10 r H)
       | assert (H1 : b <= a);
@@ -912,14 +912,14 @@ Lemma StepFun_P17 :
   forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
     adapted_couple f a b l1 lf1 ->
     adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
-Proof. 
+Proof.
   intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1);
     rewrite (StepFun_P15 H0 H1); reflexivity.
 Qed.
 
 Lemma StepFun_P18 :
   forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a).
-Proof. 
+Proof.
   intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
   replace
   (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
@@ -943,7 +943,7 @@ Lemma StepFun_P19 :
   forall (l1:Rlist) (f g:R -> R) (l:R),
     Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 =
     Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1.
-Proof. 
+Proof.
   intros; induction  l1 as [| r l1 Hrecl1];
     [ simpl in |- *; ring
       | induction  l1 as [| r0 l1 Hrecl0]; simpl in |- *;
@@ -953,7 +953,7 @@ Qed.
 Lemma StepFun_P20 :
   forall (l:Rlist) (f:R -> R),
     (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)).
-Proof. 
+Proof.
   intros l f H; induction l;
     [ elim (lt_irrefl _ H)
       | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ].
@@ -962,9 +962,9 @@ Qed.
 Lemma StepFun_P21 :
   forall (a b:R) (f:R -> R) (l:Rlist),
     is_subdivision f a b l -> adapted_couple f a b l (FF l f).
-Proof. 
+Proof.
   intros; unfold adapted_couple in |- *; unfold is_subdivision in X;
-    unfold adapted_couple in X; elim X; clear X; intros; 
+    unfold adapted_couple in X; elim X; clear X; intros;
       decompose [and] p; clear p; repeat split; try assumption.
   apply StepFun_P20; rewrite H2; apply lt_O_Sn.
   intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5;
@@ -974,7 +974,7 @@ Proof.
   unfold FF in |- *; rewrite RList_P12.
   simpl in |- *;
     change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *;
-      rewrite RList_P13; try assumption; rewrite (H5 x0 H6); 
+      rewrite RList_P13; try assumption; rewrite (H5 x0 H6);
         rewrite H5.
   reflexivity.
   split.
@@ -990,7 +990,7 @@ Proof.
       | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double;
-            rewrite (Rplus_comm (pos_Rl (cons r l) i)); 
+            rewrite (Rplus_comm (pos_Rl (cons r l) i));
               apply Rplus_lt_compat_l; elim H6; intros; apply Rlt_trans with x0;
                 assumption
             | discrR ] ].
@@ -1002,7 +1002,7 @@ Lemma StepFun_P22 :
     a <= b ->
     is_subdivision f a b lf ->
     is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
-Proof. 
+Proof.
   unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
     clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
   unfold Rmin in |- *; case (Rle_dec a b); intro;
@@ -1011,9 +1011,9 @@ Proof.
   unfold Rmax in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0;
-    decompose [and] p; decompose [and] p0; clear p p0; 
+    decompose [and] p; decompose [and] p0; clear p p0;
       rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0;
-        rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
+        rewrite Hyp_max in H5; unfold adapted_couple in |- *;
           repeat split.
   apply RList_P2; assumption.
   rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
@@ -1024,25 +1024,25 @@ Proof.
       In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
   elim
     (RList_P3 (cons_ORlist (cons r lf) lg)
-      (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
+      (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10;
     apply H10; exists 0%nat; split;
       [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
   elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
     intros H12 _; assert (H13 := H12 H10); elim H13; intro.
   elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
-    intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
+    intros H11 _; assert (H14 := H11 H8); elim H14; intros;
       elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
         elim (RList_P6 (cons r lf)); intros; apply H17;
           [ assumption | apply le_O_n | assumption ].
   elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
-    assert (H14 := H11 H8); elim H14; intros; elim H15; 
-      clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
+    assert (H14 := H11 H8); elim H14; intros; elim H15;
+      clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg);
         intros; apply H17; [ assumption | apply le_O_n | assumption ].
   induction  lf as [| r lf Hreclf].
   simpl in |- *; right; assumption.
   assert (H8 : In a (cons_ORlist (cons r lf) lg)).
   elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
-    elim (RList_P3 (cons r lf) a); intros; apply H12; 
+    elim (RList_P3 (cons r lf) a); intros; apply H12;
       exists 0%nat; split;
         [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
   apply RList_P5; [ apply RList_P2; assumption | assumption ].
@@ -1058,21 +1058,21 @@ Proof.
   elim
     (RList_P3 (cons_ORlist (cons r lf) lg)
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
     intros _ H10; apply H10;
-      exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
+      exists (pred (Rlength (cons_ORlist (cons r lf) lg)));
         split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
   elim
     (RList_P9 (cons r lf) lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
     intros H10 _.
   assert (H11 := H10 H8); elim H11; intro.
   elim
     (RList_P3 (cons r lf)
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
-    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros;
       elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
         elim (RList_P6 (cons r lf)); intros; apply H17;
           [ assumption
@@ -1081,8 +1081,8 @@ Proof.
   elim
     (RList_P3 lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
-    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros;
       elim H15; clear H15; intros.
   rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))).
   apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
@@ -1187,7 +1187,7 @@ Proof.
   apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5;
     rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11).
   assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
-    exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; 
+    exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *;
       intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat).
   elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
     apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf).
@@ -1232,7 +1232,7 @@ Proof.
   clear b0; apply RList_P17; try assumption.
   apply RList_P2; assumption.
   elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left;
-    elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; 
+    elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27;
       exists (S x0); split; [ reflexivity | apply H22 ].
 Qed.
 
@@ -1240,7 +1240,7 @@ Lemma StepFun_P23 :
   forall (a b:R) (f g:R -> R) (lf lg:Rlist),
     is_subdivision f a b lf ->
     is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
-Proof. 
+Proof.
   intros; case (Rle_dec a b); intro;
     [ apply StepFun_P22 with g; assumption
       | apply StepFun_P5; apply StepFun_P22 with g;
@@ -1254,7 +1254,7 @@ Lemma StepFun_P24 :
     a <= b ->
     is_subdivision f a b lf ->
     is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
-Proof. 
+Proof.
   unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
     clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
   unfold Rmin in |- *; case (Rle_dec a b); intro;
@@ -1263,9 +1263,9 @@ Proof.
   unfold Rmax in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0;
-    decompose [and] p; decompose [and] p0; clear p p0; 
+    decompose [and] p; decompose [and] p0; clear p p0;
       rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0;
-        rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
+        rewrite Hyp_max in H5; unfold adapted_couple in |- *;
           repeat split.
   apply RList_P2; assumption.
   rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
@@ -1276,25 +1276,25 @@ Proof.
       In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
   elim
     (RList_P3 (cons_ORlist (cons r lf) lg)
-      (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
+      (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10;
     apply H10; exists 0%nat; split;
       [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
   elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
     intros H12 _; assert (H13 := H12 H10); elim H13; intro.
   elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
-    intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
+    intros H11 _; assert (H14 := H11 H8); elim H14; intros;
       elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
         elim (RList_P6 (cons r lf)); intros; apply H17;
           [ assumption | apply le_O_n | assumption ].
   elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
-    assert (H14 := H11 H8); elim H14; intros; elim H15; 
-      clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
+    assert (H14 := H11 H8); elim H14; intros; elim H15;
+      clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg);
         intros; apply H17; [ assumption | apply le_O_n | assumption ].
   induction  lf as [| r lf Hreclf].
   simpl in |- *; right; assumption.
   assert (H8 : In a (cons_ORlist (cons r lf) lg)).
   elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
-    elim (RList_P3 (cons r lf) a); intros; apply H12; 
+    elim (RList_P3 (cons r lf) a); intros; apply H12;
       exists 0%nat; split;
         [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
   apply RList_P5; [ apply RList_P2; assumption | assumption ].
@@ -1310,20 +1310,20 @@ Proof.
   elim
     (RList_P3 (cons_ORlist (cons r lf) lg)
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
     intros _ H10; apply H10;
-      exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
+      exists (pred (Rlength (cons_ORlist (cons r lf) lg)));
         split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
   elim
     (RList_P9 (cons r lf) lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
     intros H10 _; assert (H11 := H10 H8); elim H11; intro.
   elim
     (RList_P3 (cons r lf)
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
-    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros;
       elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
         elim (RList_P6 (cons r lf)); intros; apply H17;
           [ assumption
@@ -1332,8 +1332,8 @@ Proof.
   elim
     (RList_P3 lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
-        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
-    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+        (pred (Rlength (cons_ORlist (cons r lf) lg)))));
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros;
       elim H15; clear H15; intros; rewrite H15;
         assert (H17 : Rlength lg = S (pred (Rlength lg))).
   apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
@@ -1436,7 +1436,7 @@ Proof.
   apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0;
     rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11).
   assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
-    exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; 
+    exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *;
       intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat).
   elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
     apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg).
@@ -1481,7 +1481,7 @@ Proof.
   clear b0; apply RList_P17; try assumption;
     [ apply RList_P2; assumption
       | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right;
-        elim (RList_P3 lg (pos_Rl lg (S x0))); intros; 
+        elim (RList_P3 lg (pos_Rl lg (S x0))); intros;
           apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ].
 Qed.
 
@@ -1489,7 +1489,7 @@ Lemma StepFun_P25 :
   forall (a b:R) (f g:R -> R) (lf lg:Rlist),
     is_subdivision f a b lf ->
     is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
-Proof. 
+Proof.
   intros a b f g lf lg H H0; case (Rle_dec a b); intro;
     [ apply StepFun_P24 with f; assumption
       | apply StepFun_P5; apply StepFun_P24 with f;
@@ -1504,12 +1504,12 @@ Lemma StepFun_P26 :
     is_subdivision g a b l1 ->
     is_subdivision (fun x:R => f x + l * g x) a b l1.
 Proof.
-  intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) 
+  intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4)))))
     (x,(_,(_,(_,(_,H9))))).
   exists (FF l1 (fun x:R => f x + l * g x)); repeat split; try assumption.
   apply StepFun_P20; rewrite H3; auto with arith.
-  intros i H8 x1 H10; unfold open_interval in H10, H9, H4; 
-    rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); 
+  intros i H8 x1 H10; unfold open_interval in H10, H9, H4;
+    rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10);
       assert (H11 : l1 <> nil).
   red in |- *; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8).
   destruct (RList_P19 _ H11) as (r,(r0,H12));
@@ -1548,7 +1548,7 @@ Lemma StepFun_P27 :
     is_subdivision f a b lf ->
     is_subdivision g a b lg ->
     is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg).
-Proof. 
+Proof.
   intros a b l f g lf lg H H0; apply StepFun_P26;
     [ apply StepFun_P23 with g; assumption
       | apply StepFun_P25 with f; assumption ].
@@ -1557,16 +1557,16 @@ Qed.
 (** The set of step functions on [a,b] is a vectorial space *)
 Lemma StepFun_P28 :
   forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b.
-Proof. 
+Proof.
   intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f);
-    assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; 
-      elim H0; intros; apply existT with (cons_ORlist x0 x); 
+    assert (H0 := pre g); unfold IsStepFun in H, H0; elim H;
+      elim H0; intros; apply existT with (cons_ORlist x0 x);
         apply StepFun_P27; assumption.
 Qed.
 
 Lemma StepFun_P29 :
   forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f).
-Proof. 
+Proof.
   intros a b f; unfold is_subdivision in |- *;
     apply existT with (subdivision_val f); apply StepFun_P1.
 Qed.
@@ -1575,7 +1575,7 @@ Lemma StepFun_P30 :
   forall (a b l:R) (f g:StepFun a b),
     RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) =
     RiemannInt_SF f + l * RiemannInt_SF g.
-Proof. 
+Proof.
   intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
     (intro;
       replace
@@ -1612,29 +1612,29 @@ Lemma StepFun_P31 :
   forall (a b:R) (f:R -> R) (l lf:Rlist),
     adapted_couple f a b l lf ->
     adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs).
-Proof. 
+Proof.
   unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
     repeat split; try assumption.
   symmetry  in |- *; rewrite H3; rewrite RList_P18; reflexivity.
   intros; unfold constant_D_eq, open_interval in |- *;
-    unfold constant_D_eq, open_interval in H5; intros; 
+    unfold constant_D_eq, open_interval in H5; intros;
       rewrite (H5 _ H _ H4); rewrite RList_P12;
         [ reflexivity | rewrite H3 in H; simpl in H; apply H ].
 Qed.
 
 Lemma StepFun_P32 :
   forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b.
-Proof. 
+Proof.
   intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f);
     unfold is_subdivision in |- *;
-      apply existT with (app_Rlist (subdivision_val f) Rabs); 
+      apply existT with (app_Rlist (subdivision_val f) Rabs);
         apply StepFun_P31; apply StepFun_P1.
 Qed.
 
 Lemma StepFun_P33 :
   forall l2 l1:Rlist,
     ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1.
-Proof. 
+Proof.
   simple induction l2; intros.
   simpl in |- *; rewrite Rabs_R0; right; reflexivity.
   simpl in |- *; induction  l1 as [| r1 l1 Hrecl1].
@@ -1653,14 +1653,14 @@ Lemma StepFun_P34 :
   forall (a b:R) (f:StepFun a b),
     a <= b ->
     Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)).
-Proof. 
+Proof.
   intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
   replace
   (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f)))
     (subdivision (mkStepFun (StepFun_P32 f)))) with
   (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)).
   apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0;
-    elim H0; intros; unfold adapted_couple in p; decompose [and] p; 
+    elim H0; intros; unfold adapted_couple in p; decompose [and] p;
       assumption.
   apply StepFun_P17 with (fun x:R => Rabs (f x)) a b;
     [ apply StepFun_P31; apply StepFun_P1
@@ -1675,7 +1675,7 @@ Lemma StepFun_P35 :
     pos_Rl l (pred (Rlength l)) = b ->
     (forall x:R, a < x < b -> f x <= g x) ->
     Int_SF (FF l f) l <= Int_SF (FF l g) l.
-Proof. 
+Proof.
   simple induction l; intros.
   right; reflexivity.
   simpl in |- *; induction  r0 as [| r0 r1 Hrecr0].
@@ -1742,7 +1742,7 @@ Lemma StepFun_P36 :
     is_subdivision g a b l ->
     (forall x:R, a < x < b -> f x <= g x) ->
     RiemannInt_SF f <= RiemannInt_SF g.
-Proof. 
+Proof.
   intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
   replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
   replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
@@ -1768,7 +1768,7 @@ Lemma StepFun_P37 :
     a <= b ->
     (forall x:R, a < x < b -> f x <= g x) ->
     RiemannInt_SF f <= RiemannInt_SF g.
-Proof. 
+Proof.
   intros; eapply StepFun_P36; try assumption.
   eapply StepFun_P25; apply StepFun_P29.
   eapply StepFun_P23; apply StepFun_P29.
@@ -1785,8 +1785,8 @@ Lemma StepFun_P38 :
         (i < pred (Rlength l))%nat ->
         constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i)))
         (f (pos_Rl l i))) }.
-Proof. 
-  intros l a b f; generalize a; clear a; induction l. 
+Proof.
+  intros l a b f; generalize a; clear a; induction l.
   intros a H H0 H1; simpl in H0; simpl in H1;
     exists (mkStepFun (StepFun_P4 a b (f b))); split.
   reflexivity.
@@ -1812,7 +1812,7 @@ Proof.
   rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ].
   assert (H8 : IsStepFun g' a b).
   unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8;
-    elim H8; intros lg H9; unfold is_subdivision in H9; 
+    elim H8; intros lg H9; unfold is_subdivision in H9;
       elim H9; clear H9; intros lg2 H9; split with (cons a lg);
         unfold is_subdivision in |- *; split with (cons (f a) lg2);
           unfold adapted_couple in H9; decompose [and] H9; clear H9;
@@ -1896,7 +1896,7 @@ Proof.
       assert (H11 : (i < pred (Rlength (cons r1 l)))%nat).
   simpl in |- *; apply lt_S_n; assumption.
   assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12;
-    unfold constant_D_eq, co_interval in |- *; intros; 
+    unfold constant_D_eq, co_interval in |- *; intros;
       rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *;
         case (Rle_dec r1 x); intro.
   reflexivity.
@@ -1913,7 +1913,7 @@ Qed.
 Lemma StepFun_P39 :
   forall (a b:R) (f:StepFun a b),
     RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))).
-Proof. 
+Proof.
   intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a);
     intros.
   assert (H : adapted_couple f a b (subdivision f) (subdivision_val f));
@@ -1931,12 +1931,12 @@ Proof.
   rewrite Ropp_involutive; eapply StepFun_P17;
     [ apply StepFun_P1
       | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
-        elim H; intros; unfold is_subdivision in |- *; 
+        elim H; intros; unfold is_subdivision in |- *;
           elim p; intros; apply p0 ].
   apply Ropp_eq_compat; eapply StepFun_P17;
     [ apply StepFun_P1
       | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
-        elim H; intros; unfold is_subdivision in |- *; 
+        elim H; intros; unfold is_subdivision in |- *;
           elim p; intros; apply p0 ].
   assert (H : a < b);
     [ auto with real
@@ -1951,9 +1951,9 @@ Lemma StepFun_P40 :
     adapted_couple f a b l1 lf1 ->
     adapted_couple f b c l2 lf2 ->
     adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f).
-Proof. 
+Proof.
   intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2;
-    unfold adapted_couple in |- *; decompose [and] H1; 
+    unfold adapted_couple in |- *; decompose [and] H1;
       decompose [and] H2; clear H1 H2; repeat split.
   apply RList_P25; try assumption.
   rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b);
@@ -2030,7 +2030,7 @@ Proof.
         pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14;
       change
         (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
-          pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; 
+          pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15;
         rewrite H15; assert (H18 := H8 (S i));
           unfold constant_D_eq, open_interval in H18;
             assert (H19 : (S i < pred (Rlength l1))%nat).
@@ -2112,11 +2112,11 @@ Proof.
   rewrite H19 in H16; rewrite H19 in H17;
     change
       (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
-        pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) 
+        pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3))))
       in H16; rewrite H16;
         change
           (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
-            pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) 
+            pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3)))))
           in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat);
             unfold constant_D_eq, open_interval in H20;
               assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat).
@@ -2154,7 +2154,7 @@ Proof.
             rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros;
-    rewrite H19 in H25; rewrite H19 in H26; simpl in H25; 
+    rewrite H19 in H25; rewrite H19 in H26; simpl in H25;
       simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17;
         rewrite H17 in H26; simpl in H24; rewrite H24 in H25;
           elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)).
@@ -2189,7 +2189,7 @@ Lemma StepFun_P42 :
     pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 ->
     Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) =
     Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2.
-Proof. 
+Proof.
   intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H;
     [ simpl in |- *; ring
       | destruct l1 as [| r0 r1];
@@ -2200,11 +2200,11 @@ Proof.
 Qed.
 
 Lemma StepFun_P43 :
-  forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) 
+  forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b)
     (pr2:IsStepFun f b c) (pr3:IsStepFun f a c),
     RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) =
     RiemannInt_SF (mkStepFun pr3).
-Proof. 
+Proof.
   intros f; intros.
   pose proof pr1 as (l1,(lf1,H1)).
   pose proof pr2 as (l2,(lf2,H2)).
@@ -2441,7 +2441,7 @@ Qed.
 Lemma StepFun_P44 :
   forall (f:R -> R) (a b c:R),
     IsStepFun f a b -> a <= c <= b -> IsStepFun f a c.
-Proof. 
+Proof.
   intros f; intros; assert (H0 : a <= b).
   elim H; intros; apply Rle_trans with c; assumption.
   elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
@@ -2479,7 +2479,7 @@ Proof.
   case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
   elim H1; intro.
   split with (cons r (cons c nil)); split with (cons r3 nil);
-    unfold adapted_couple in H; decompose [and] H; clear H; 
+    unfold adapted_couple in H; decompose [and] H; clear H;
       assert (H6 : r = a).
   simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro;
     [ reflexivity
@@ -2497,7 +2497,7 @@ Proof.
     assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
   simpl in |- *; apply lt_O_Sn.
   apply (H10 H12); unfold open_interval in |- *; simpl in |- *;
-    rewrite H11 in H9; simpl in H9; elim H9; clear H9; 
+    rewrite H11 in H9; simpl in H9; elim H9; clear H9;
       intros; split; try assumption.
   apply Rlt_le_trans with c; assumption.
   elim (le_Sn_O _ H11).
@@ -2505,8 +2505,8 @@ Proof.
   cut (r1 <= c <= b).
   intros.
   elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1');
-    split with (cons r3 lf1'); unfold adapted_couple in H, H4; 
-      decompose [and] H; decompose [and] H4; clear H H4 X0; 
+    split with (cons r3 lf1'); unfold adapted_couple in H, H4;
+      decompose [and] H; decompose [and] H4; clear H H4 X0;
         assert (H14 : a <= b).
   elim H0; intros; apply Rle_trans with c; assumption.
   assert (H16 : r = a).
@@ -2538,7 +2538,7 @@ Proof.
     assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
   simpl in |- *; apply lt_O_Sn.
   apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4;
-    elim H4; clear H4; intros; split; try assumption; 
+    elim H4; clear H4; intros; split; try assumption;
       replace r1 with r4.
   assumption.
   simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
@@ -2557,7 +2557,7 @@ Qed.
 Lemma StepFun_P45 :
   forall (f:R -> R) (a b c:R),
     IsStepFun f a b -> a <= c <= b -> IsStepFun f c b.
-Proof. 
+Proof.
   intros f; intros; assert (H0 : a <= b).
   elim H; intros; apply Rle_trans with c; assumption.
   elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
@@ -2614,7 +2614,7 @@ Proof.
     apply (H7 0%nat).
   simpl in |- *; apply lt_O_Sn.
   unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6;
-    intros; split; try assumption; apply Rle_lt_trans with c; 
+    intros; split; try assumption; apply Rle_lt_trans with c;
       try assumption; replace r with a.
   elim H0; intros; assumption.
   simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intros;
@@ -2634,7 +2634,7 @@ Qed.
 Lemma StepFun_P46 :
   forall (f:R -> R) (a b c:R),
     IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
-Proof. 
+Proof.
   intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros.
   apply StepFun_P41 with b; assumption.
   case (Rle_dec a c); intro.
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index 1a2fa03a..be7895f5 100644
--- a/theories/Reals/Rlimit.v
+++ b/theories/Reals/Rlimit.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rlimit.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*********************************************************)
 (**          Definition of the limit                     *)
@@ -85,7 +85,7 @@ Proof.
   fourier.
   discrR.
   ring.
-Qed. 
+Qed.
 
 (*********)
 Lemma prop_eps : forall r:R, (forall eps:R, eps > 0 -> r < eps) -> r <= 0.
@@ -95,7 +95,7 @@ Proof.
   elim H0; intro.
   apply Req_le; assumption.
   clear H0; generalize (H r H1); intro; generalize (Rlt_irrefl r); intro;
-    elimtype False; auto.
+    exfalso; auto.
 Qed.
 
 (*********)
@@ -148,7 +148,7 @@ Qed.
 (*******************************)
 
 (*********)
-Record Metric_Space : Type := 
+Record Metric_Space : Type :=
   {Base : Type;
     dist : Base -> Base -> R;
     dist_pos : forall x y:Base, dist x y >= 0;
@@ -167,7 +167,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X')
     eps > 0 ->
     exists alp : R,
       alp > 0 /\
-      (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). 
+      (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps).
 
 (*******************************)
 (** **  R is a metric space    *)
@@ -214,7 +214,7 @@ Qed.
 Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0.
 Proof.
   unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
-    split with eps; split; auto; intros; elim H0; intros; 
+    split with eps; split; auto; intros; elim H0; intros;
       auto.
 Qed.
 
@@ -226,7 +226,7 @@ Lemma limit_plus :
 Proof.
   intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
     intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1));
-      elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; 
+      elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *;
         clear H H0; intros; elim H; elim H0; clear H H0; intros;
           split with (Rmin x1 x); split.
   exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
@@ -248,11 +248,11 @@ Lemma limit_Ropp :
     limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0.
 Proof.
   unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
-    elim (H eps H0); clear H; intros; elim H; clear H; 
-      intros; split with x; split; auto; intros; generalize (H1 x1 H2); 
+    elim (H eps H0); clear H; intros; elim H; clear H;
+      intros; split with x; split; auto; intros; generalize (H1 x1 H2);
         clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *;
           rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l);
-            fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; 
+            fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *;
               rewrite R_dist_sym; assumption.
 Qed.
 
@@ -273,7 +273,7 @@ Lemma limit_free :
 Proof.
   unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
     split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x));
-      intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; 
+      intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H;
         assumption.
 Qed.
 
@@ -286,13 +286,13 @@ Proof.
   intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
     intros;
       elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1));
-        elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); 
-          clear H H0; simpl in |- *; intros; elim H; elim H0; 
+        elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1));
+          clear H H0; simpl in |- *; intros; elim H; elim H0;
             clear H H0; intros; split with (Rmin x1 x); split.
   exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
   intros; elim H4; clear H4; intros; unfold R_dist in |- *;
     replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)).
-  cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). 
+  cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps).
   cut
     (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <=
       Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))).
@@ -353,19 +353,19 @@ Proof.
     unfold Rabs in |- *; case (Rcase_abs (l - l')); intros.
   cut (forall eps:R, eps > 0 -> - (l - l') < eps).
   intro; generalize (prop_eps (- (l - l')) H1); intro;
-    generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; 
-      unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); 
-        intro; elimtype False; auto.
+    generalize (Ropp_gt_lt_0_contravar (l - l') r); intro;
+      unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3);
+        intro; exfalso; auto.
   intros; cut (eps * / 2 > 0).
   intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
     rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
   elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
   apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
-    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
-      intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
+    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3);
+      intro; elim (Rplus_ne 1); intros a b; rewrite a in H4;
         clear a b; apply (Rlt_trans 0 1 2 H3 H4).
   unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
-    rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
+    rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps);
       auto.
   apply (Rinv_0_lt_compat 2); cut (1 < 2).
   intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
@@ -374,7 +374,7 @@ Proof.
 (**)
   cut (forall eps:R, eps > 0 -> l - l' < eps).
   intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0);
-    intros a b; clear b; apply (Rminus_diag_uniq l l'); 
+    intros a b; clear b; apply (Rminus_diag_uniq l l');
       apply a; split.
   assumption.
   apply (Rge_le (l - l') 0 r).
@@ -383,11 +383,11 @@ Proof.
     rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
   elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
   apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
-    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
-      intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
+    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3);
+      intro; elim (Rplus_ne 1); intros a b; rewrite a in H4;
         clear a b; apply (Rlt_trans 0 1 2 H3 H4).
   unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
-    rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
+    rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps);
       auto.
   apply (Rinv_0_lt_compat 2); cut (1 < 2).
   intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
@@ -395,21 +395,21 @@ Proof.
     rewrite a; clear a b; trivial.
 (**)
   intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros;
-    clear H0 H1; elim H3; elim H4; clear H3 H4; intros; 
-      simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); 
+    clear H0 H1; elim H3; elim H4; clear H3 H4; intros;
+      simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0);
         intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0)));
           intros; elim H5; intros; clear H5 H H6 H7;
-            generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; 
-              elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); 
+            generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro;
+              elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9);
                 intros; clear H5 H9; generalize (H1 x2 (conj H8 H6));
-                  generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; 
+                  generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3;
                     intros;
                       generalize
                         (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0);
                         unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
                           rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1);
                             elim (Rmult_ne eps); intros a b; rewrite a; clear a b;
-                              generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; 
+                              generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *;
                                 intros;
                                   apply
                                     (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l'))
@@ -449,7 +449,7 @@ Proof.
     intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1).
   cut (D x /\ Rabs (x - x0) < delta2).
   intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12);
-    clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); 
+    clear H7; intro H7; generalize (Rabs_triang_inv l (f x));
       intro; rewrite Rabs_minus_sym in H7;
         generalize
           (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7);
diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v
index 8aadf8f5..379d3495 100644
--- a/theories/Reals/Rlogic.v
+++ b/theories/Reals/Rlogic.v
@@ -34,7 +34,7 @@ Require Import PartSum.
 Require Import SeqSeries.
 Require Import RiemannInt.
 Require Import Fourier.
- 
+
 Section Arithmetical_dec.
 
 Variable P : nat -> Prop.
@@ -108,7 +108,7 @@ rewrite Rabs_pos_eq.
    intro i.
    unfold f, g.
    elim (HP i); intro; ring_simplify; auto with *.
-  cut (sum_f_R0 g m <= sum_f_R0 g n). 
+  cut (sum_f_R0 g m <= sum_f_R0 g n).
    intro; fourier.
   apply (ge_fun_sums_ge m n g Hnm).
   intro. unfold g.
@@ -177,9 +177,9 @@ assert (Z:  Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)).
   split;
    intros H;
    simpl; unfold g;
-   destruct (eq_nat_dec 0 n); try reflexivity.
+   destruct (eq_nat_dec 0 n) as [t|f]; try reflexivity.
    elim f; auto with *.
-  elimtype False; omega.
+  exfalso; omega.
  destruct IHa as [IHa0 IHa1].
  split;
   intros H;
@@ -191,7 +191,7 @@ assert (Z:  Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)).
    ring_simplify.
    apply IHa0.
    omega.
-  elimtype False; omega.
+  exfalso; omega.
  ring_simplify.
  apply IHa1.
  omega.
diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v
new file mode 100644
index 00000000..373f30dd
--- /dev/null
+++ b/theories/Reals/Rminmax.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax.
+
+(** * Maximum and Minimum of two real numbers *)
+
+Local Open Scope R_scope.
+
+(** The functions [Rmax] and [Rmin] implement indeed
+    a maximum and a minimum *)
+
+Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x.
+Proof.
+ unfold Rmax. intros.
+ destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
+  unfold Rle in *; intuition.
+Qed.
+
+Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y.
+Proof.
+ unfold Rmax. intros.
+ destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
+  unfold Rle in *; intuition.
+Qed.
+
+Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x.
+Proof.
+ unfold Rmin. intros.
+ destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
+  unfold Rle in *; intuition.
+Qed.
+
+Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y.
+Proof.
+ unfold Rmin. intros.
+ destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
+  unfold Rle in *; intuition.
+Qed.
+
+Module RHasMinMax <: HasMinMax R_as_OT.
+ Definition max := Rmax.
+ Definition min := Rmin.
+ Definition max_l := Rmax_l.
+ Definition max_r := Rmax_r.
+ Definition min_l := Rmin_l.
+ Definition min_r := Rmin_r.
+End RHasMinMax.
+
+Module R.
+
+(** We obtain hence all the generic properties of max and min. *)
+
+Include UsualMinMaxProperties R_as_OT RHasMinMax.
+
+(** * Properties specific to the [R] domain *)
+
+(** Compatibilities (consequences of monotonicity) *)
+
+Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m.
+Proof.
+ intros. apply max_monotone.
+ intros x y. apply Rplus_le_compat_l.
+Qed.
+
+Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p.
+Proof.
+ intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
+ apply plus_max_distr_l.
+Qed.
+
+Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m.
+Proof.
+ intros. apply min_monotone.
+ intros x y. apply Rplus_le_compat_l.
+Qed.
+
+Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p.
+Proof.
+ intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
+ apply plus_min_distr_l.
+Qed.
+
+(** Anti-monotonicity swaps the role of [min] and [max] *)
+
+Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m).
+Proof.
+ intros. symmetry. apply min_max_antimonotone.
+ do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
+Qed.
+
+Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m).
+Proof.
+ intros. symmetry. apply max_min_antimonotone.
+ do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
+Qed.
+
+Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m.
+Proof.
+ unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
+Qed.
+
+Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p.
+Proof.
+ unfold Rminus. intros. apply plus_max_distr_r.
+Qed.
+
+Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m.
+Proof.
+ unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
+Qed.
+
+Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p.
+Proof.
+ unfold Rminus. intros. apply plus_min_distr_r.
+Qed.
+
+End R.
diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v
index 90ea9726..c7d1893b 100644
--- a/theories/Reals/Rpow_def.v
+++ b/theories/Reals/Rpow_def.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Rpow_def.v 10923 2008-05-12 18:25:06Z herbelin $ *)
+(* $Id$ *)
 
 Require Import Rdefinitions.
 
-Fixpoint pow (r:R) (n:nat) {struct n} : R :=
+Fixpoint pow (r:R) (n:nat) : R :=
   match n with
     | O => R1
     | S n => Rmult r (pow r n)
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
index adf53ef9..a4feed8f 100644
--- a/theories/Reals/Rpower.v
+++ b/theories/Reals/Rpower.v
@@ -6,8 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rpower.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
-(*i Due to L.Thery i*) 
+(*i $Id$ i*)
+(*i Due to L.Thery i*)
 
 (************************************************************)
 (* Definitions of log and Rpower : R->R->R; main properties *)
@@ -86,7 +86,7 @@ Proof.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0;
-    intros; elim (H0 _ H1); intros; exists x0; intros; 
+    intros; elim (H0 _ H1); intros; exists x0; intros;
       unfold R_dist in H2; unfold R_dist in |- *;
         replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
   apply (H2 _ H3).
@@ -139,8 +139,8 @@ Qed.
 Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x.
 Proof.
   intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x));
-    assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; 
-      intros; elim H1; intros; unfold Rminus in H2; rewrite H2; 
+    assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0;
+      intros; elim H1; intros; unfold Rminus in H2; rewrite H2;
         rewrite Ropp_0; rewrite Rplus_0_r;
           replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
   rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
@@ -162,7 +162,7 @@ Proof.
   pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7));
     exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7.
   pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y));
-    rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; 
+    rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l;
       assumption.
   unfold f in |- *; apply Rplus_le_reg_l with y; left;
     apply Rlt_trans with (1 + y).
@@ -191,7 +191,7 @@ Proof.
     apply Rmult_eq_reg_l with (exp x / y).
   unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
-    rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; 
+    rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
       rewrite Rmult_1_r; symmetry  in |- *; apply p.
   red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H).
   unfold Rdiv in |- *; apply prod_neq_R0.
@@ -216,7 +216,7 @@ Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
 Proof.
   intros; unfold ln in |- *; case (Rlt_dec 0 x); intro.
   unfold Rln in |- *;
-    case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); 
+    case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r)));
     intros.
   simpl in e; symmetry  in |- *; apply e.
   elim n; apply H.
@@ -248,7 +248,7 @@ Qed.
 Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y.
 Proof.
   intros x y H H0; apply exp_lt_inv.
-  repeat rewrite exp_ln. 
+  repeat rewrite exp_ln.
   apply H0.
   apply Rlt_trans with x; assumption.
   apply H.
@@ -270,7 +270,7 @@ Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y.
 Proof.
   intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
   apply exp_increasing; apply H1.
-  assumption. 
+  assumption.
   assumption.
 Qed.
 
@@ -299,7 +299,7 @@ Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x.
 Proof.
   intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
   reflexivity.
-  assumption. 
+  assumption.
   apply Rinv_0_lt_compat; assumption.
 Qed.
 
@@ -325,7 +325,7 @@ Proof.
   unfold dist, R_met, R_dist in |- *; simpl in |- *.
   intros x [[H3 H4] H5].
   cut (y * (x * / y) = x).
-  intro Hxyy. 
+  intro Hxyy.
   replace (ln x - ln y) with (ln (x * / y)).
   case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
   rewrite Rabs_left.
@@ -470,7 +470,7 @@ Proof.
   apply Rmult_eq_reg_l with (INR 2).
   apply exp_inv.
   fold Rpower in |- *.
-  cut ((x ^R (/ 2)) ^R INR 2 = sqrt x ^R INR 2).
+  cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2).
   unfold Rpower in |- *; auto.
   rewrite Rpower_mult.
   rewrite Rinv_l.
@@ -580,8 +580,8 @@ Proof.
     (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
   apply ln_continue; auto.
   assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H);
         intros; exists (pos x); split.
   apply (cond_pos x).
   intros; pattern y at 3 in |- *; rewrite <- exp_ln.
@@ -589,7 +589,7 @@ Proof.
     [ idtac | ring ].
   apply H1.
   elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
-    apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); 
+    apply Rminus_eq_contra; apply (sym_not_eq (A:=R));
       apply H3.
   elim H2; clear H2; intros _ H2; apply H2.
   assumption.
@@ -600,7 +600,7 @@ Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x).
 Proof.
   intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
     unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
-      unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); 
+      unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1);
         intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
           assert (H4 : 0 < alp).
   unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro.
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
index 2113cc8f..bb3df6bb 100644
--- a/theories/Reals/Rprod.v
+++ b/theories/Reals/Rprod.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rprod.v 10146 2007-09-27 12:28:12Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Compare.
 Require Import Rbase.
@@ -17,7 +17,7 @@ Require Import Binomial.
 Open Local Scope R_scope.
 
 (** TT Ak; 0<=k<=N *)
-Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) {struct N} : R :=
+Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R :=
   match N with
     | O => f O
     | S p => prod_f_R0 f p * f (S p)
@@ -43,7 +43,7 @@ Proof.
   rewrite Hrecn; [ ring | assumption ].
   omega.
   omega.
-Qed. 
+Qed.
 
 (**********)
 Lemma prod_SO_pos :
@@ -80,9 +80,9 @@ Qed.
 
 (** Application to factorial *)
 Lemma fact_prodSO :
-  forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => 
-     (match (eq_nat_dec k 0) with 
-          | left   _ => 1%R 
+  forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat =>
+     (match (eq_nat_dec k 0) with
+          | left   _ => 1%R
           | right _ => INR k
                         end)) n.
 Proof.
@@ -102,7 +102,7 @@ Proof.
   replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
   replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
   ring.
-Qed. 
+Qed.
 
 (** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *)
 Lemma RfactN_fact2N_factk :
@@ -112,7 +112,7 @@ Lemma RfactN_fact2N_factk :
 Proof.
   assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)).
   intros; case (eq_nat_dec n 0); auto with real.
-  assert (forall (n:nat), (0 < n)%nat ->  
+  assert (forall (n:nat), (0 < n)%nat ->
      (if eq_nat_dec n 0 then 1 else INR n) = INR n).
   intros n; case (eq_nat_dec n 0); auto with real.
   intros; absurd (0 < n)%nat; omega.
@@ -125,7 +125,7 @@ Proof.
   rewrite Rmult_assoc; apply Rmult_le_compat_l.
   apply prod_SO_pos; intros; auto.
   replace (2 * N - k - N-1)%nat with (N - k-1)%nat.
-  rewrite Rmult_comm; rewrite (prod_SO_split 
+  rewrite Rmult_comm; rewrite (prod_SO_split
         (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k).
   apply Rmult_le_compat_l.
   apply prod_SO_pos; intros; auto.
@@ -138,14 +138,14 @@ Proof.
   assumption.
   omega.
   omega.
-  rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => 
+  rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat =>
           if eq_nat_dec l 0 then 1 else INR l) k));
-    rewrite (prod_SO_split (fun l:nat => 
+    rewrite (prod_SO_split (fun l:nat =>
           if eq_nat_dec l 0 then 1 else INR l) k N).
   rewrite Rmult_assoc; apply Rmult_le_compat_l.
   apply prod_SO_pos; intros; auto.
   rewrite Rmult_comm;
-    rewrite (prod_SO_split (fun l:nat => 
+    rewrite (prod_SO_split (fun l:nat =>
           if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)).
   apply Rmult_le_compat_l.
   apply prod_SO_pos; intros; auto.
@@ -160,7 +160,7 @@ Proof.
   omega.
   assumption.
   omega.
-Qed. 
+Qed.
 
 
 (**********)
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index 702aafa4..33b7c8d1 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rseries.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -71,7 +71,7 @@ Section sequence.
     forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x.
   Proof.
     intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0;
-      clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; 
+      clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1;
         trivial.
   Qed.
 
@@ -81,7 +81,7 @@ Section sequence.
   Proof.
     double induction n m; intros.
     unfold Rge in |- *; right; trivial.
-    elimtype False; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
+    exfalso; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
     cut (n0 >= 0)%nat.
     generalize H0; intros; unfold Un_growing in H0;
       apply
@@ -91,7 +91,7 @@ Section sequence.
     elim (lt_eq_lt_dec n1 n0); intro y.
     elim y; clear y; intro y.
     unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro;
-      elimtype False; auto.
+      exfalso; auto.
     rewrite y; unfold Rge in |- *; right; trivial.
     unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro;
       unfold Un_growing in H1;
@@ -106,11 +106,11 @@ Section sequence.
   Lemma Un_cv_crit : Un_growing -> bound EUn ->  exists l : R, Un_cv l.
   Proof.
     unfold Un_growing, Un_cv in |- *; intros;
-      generalize (completeness_weak EUn H0 EUn_noempty); 
-        intro; elim H1; clear H1; intros; split with x; intros; 
+      generalize (completeness_weak EUn H0 EUn_noempty);
+        intro; elim H1; clear H1; intros; split with x; intros;
           unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1;
-            elim H0; clear H0; intros; elim H1; clear H1; intros; 
-              generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); 
+            elim H0; clear H0; intros; elim H1; clear H1; intros;
+              generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x);
                 intro.
     cut (exists N : nat, x - eps < Un N).
     intro; elim H6; clear H6; intros; split with x1.
@@ -131,10 +131,10 @@ Section sequence.
         apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)).
     red in |- *; intro; cut (forall N:nat, Un N <= x - eps).
     intro; generalize (Un_bound_imp (x - eps) H7); intro;
-      unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); 
+      unfold is_upper_bound in H8; generalize (H3 (x - eps) H8);
         intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *;
           rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
-            rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); 
+            rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2);
               rewrite Ropp_involutive; intro; unfold Rgt in H2;
                 generalize (Rgt_not_le eps 0 H2); intro; auto.
     intro; elim (H6 N); intro; unfold Rle in |- *.
@@ -151,7 +151,7 @@ Section sequence.
     split with (Un 0); intros; rewrite (le_n_O_eq n H);
       apply (Req_le (Un n) (Un n) (refl_equal (Un n))).
     elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros;
-      elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; 
+      elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1;
         inversion H0.
     rewrite <- H1; rewrite <- H1 in H2;
       apply
@@ -163,21 +163,21 @@ Section sequence.
   Lemma cauchy_bound : Cauchy_crit -> bound EUn.
   Proof.
     unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *;
-      unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; 
+      unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros;
         generalize (H x); intro; generalize (le_dec x); intro;
-          elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); 
-            clear H; intros; unfold EUn in H; elim H; clear H; 
+          elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1));
+            clear H; intros; unfold EUn in H; elim H; clear H;
               intros; elim (H1 x2); clear H1; intro y.
     unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro;
       rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0);
-        clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); 
+        clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1);
           intros; apply H4; clear H3 H4; right; clear H H0 y;
             apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1);
               clear H1; intro; apply (Rminus_lt x1 (Un x + 1));
                 cut (-1 - (Un x - x1) = x1 - (Un x + 1));
                   [ intro; rewrite H0 in H; assumption | ring ].
     generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0;
-      elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; 
+      elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1;
         apply H2; left; assumption.
   Qed.
 
@@ -248,7 +248,7 @@ Proof.
   cut
     (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) =
       Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))).
-  clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.  
+  clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.
   rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps).
   intros; rewrite H9; unfold Rle in |- *; right; reflexivity.
   ring.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
index 7cdd4d02..91759270 100644
--- a/theories/Reals/Rsigma.v
+++ b/theories/Reals/Rsigma.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rsigma.v 9454 2006-12-15 15:30:59Z bgregoir $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
index 0a3af6ca..33c20355 100644
--- a/theories/Reals/Rsqrt_def.v
+++ b/theories/Reals/Rsqrt_def.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rsqrt_def.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Sumbool.
 Require Import Rbase.
@@ -23,7 +23,7 @@ Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
         let up := Dichotomy_ub x y P n in
           let z := (down + up) / 2 in if P z then down else z
   end
-  
+
   with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
     match N with
       | O => y
@@ -471,8 +471,8 @@ Proof.
   intros.
   cut (x <= y).
   intro.
-  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). 
-  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). 
+  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3).
+  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3).
   intros X X0.
   elim X; intros.
   elim X0; intros.
@@ -667,7 +667,7 @@ Proof.
     apply Ropp_0_gt_lt_contravar; assumption.
 Qed.
 
-(** We can now define the square root function as the reciprocal 
+(** We can now define the square root function as the reciprocal
    transformation of the square root function *)
 Lemma Rsqrt_exists :
   forall y:R, 0 <= y -> { z:R | 0 <= z /\ y = Rsqr z }.
@@ -698,7 +698,7 @@ Proof.
   rewrite Rsqr_1.
   apply Rplus_le_reg_l with y.
   rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
-    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
       left; assumption.
   exists 1.
   split.
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
index 9501bc1e..5b55896b 100644
--- a/theories/Reals/Rtopology.v
+++ b/theories/Reals/Rtopology.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtopology.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -33,8 +33,8 @@ Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x.
 Lemma interior_P1 : forall D:R -> Prop, included (interior D) D.
 Proof.
   intros; unfold included in |- *; unfold interior in |- *; intros;
-    unfold neighbourhood in H; elim H; intros; unfold included in H0; 
-      apply H0; unfold disc in |- *; unfold Rminus in |- *; 
+    unfold neighbourhood in H; elim H; intros; unfold included in H0;
+      apply H0; unfold disc in |- *; unfold Rminus in |- *;
         rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0).
 Qed.
 
@@ -98,7 +98,7 @@ Lemma complementary_P1 :
     ~ (exists y : R, intersection_domain D (complementary D) y).
 Proof.
   intro; red in |- *; intro; elim H; intros;
-    unfold intersection_domain, complementary in H0; elim H0; 
+    unfold intersection_domain, complementary in H0; elim H0;
       intros; elim H2; assumption.
 Qed.
 
@@ -110,23 +110,23 @@ Proof.
       elim H1; intro.
   assumption.
   assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros;
-    unfold intersection_domain in H5; elim H5; intros; 
+    unfold intersection_domain in H5; elim H5; intros;
       elim H6; assumption.
 Qed.
 
 Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D).
 Proof.
   intro; unfold closed_set, adherence in |- *;
-    unfold open_set, complementary, point_adherent in |- *; 
+    unfold open_set, complementary, point_adherent in |- *;
       intros;
         set
           (P :=
             fun V:R -> Prop =>
               neighbourhood V x ->  exists y : R, intersection_domain V D y);
-          assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; 
+          assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1;
             unfold P in H1; assert (H2 := imply_to_and _ _ H1);
               unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3;
-                elim H3; intros; exists x0; unfold included in |- *; 
+                elim H3; intros; exists x0; unfold included in |- *;
                   intros; red in |- *; intro.
   assert (H8 := H7 V0);
     cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)).
@@ -170,7 +170,7 @@ Proof.
   apply adherence_P2; assumption.
   unfold eq_Dom in |- *; unfold included in |- *; intros;
     assert (H0 := adherence_P3 D); unfold closed_set in H0;
-      unfold closed_set in |- *; unfold open_set in |- *; 
+      unfold closed_set in |- *; unfold open_set in |- *;
         unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x).
   unfold complementary in |- *; unfold complementary in H1; red in |- *; intro;
     elim H; clear H; intros _ H; elim H1; apply (H _ H2).
@@ -178,7 +178,7 @@ Proof.
     unfold neighbourhood in H3; elim H3; intros; exists x0;
       unfold included in |- *; unfold included in H4; intros;
         assert (H6 := H4 _ H5); unfold complementary in H6;
-          unfold complementary in |- *; red in |- *; intro; 
+          unfold complementary in |- *; red in |- *; intro;
             elim H; clear H; intros H _; elim H6; apply (H _ H7).
 Qed.
 
@@ -187,7 +187,7 @@ Lemma neighbourhood_P1 :
     included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x.
 Proof.
   unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0;
-    intros; unfold included in |- *; unfold included in H1; 
+    intros; unfold included in |- *; unfold included in H1;
       intros; apply (H _ (H1 _ H2)).
 Qed.
 
@@ -211,8 +211,8 @@ Proof.
   unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1;
     intros.
   assert (H4 := H _ H2); assert (H5 := H0 _ H3);
-    unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; 
-      elim H4; clear H; intros del1 H; elim H5; clear H0; 
+    unfold intersection_domain in |- *; unfold neighbourhood in H4, H5;
+      elim H4; clear H; intros del1 H; elim H5; clear H0;
         intros del2 H0; cut (0 < Rmin del1 del2).
   intro; set (del := mkposreal _ H6).
   exists del; unfold included in |- *; intros; unfold included in H, H0;
@@ -292,7 +292,7 @@ Proof.
   apply (sym_not_eq (A:=R)); apply H7.
   unfold disc in H6; apply H6.
   intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
       intros.
   assert (H1 := H (disc (f x) (mkposreal eps H0))).
   cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)).
@@ -317,8 +317,8 @@ Proof.
   intros; unfold open_set in H0; unfold open_set in |- *; intros;
     assert (H2 := continuity_P1 f x); elim H2; intros H3 _;
       assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *;
-        unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); 
-          elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; 
+        unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1));
+          elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7;
             elim H7; intros del H9; exists del; unfold included in H9;
               unfold included in |- *; intros; apply (H8 _ (H9 _ H10)).
 Qed.
@@ -333,7 +333,7 @@ Proof.
   intros; apply continuity_P2; assumption.
   intros; unfold continuity in |- *; unfold continuity_pt in |- *;
     unfold continue_in in |- *; unfold limit1_in in |- *;
-      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
         intros; cut (open_set (disc (f x) (mkposreal _ H0))).
   intro; assert (H2 := H _ H1).
   unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)).
@@ -466,7 +466,7 @@ Proof.
     cut (covering_open_set X f0).
   intro; assert (H3 := H1 H2); elim H3; intros D' H4;
     unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6;
-      unfold domain_finite in H6; elim H6; intros l H7; 
+      unfold domain_finite in H6; elim H6; intros l H7;
         unfold bounded in |- *; set (r := MaxRlist l).
   exists (- r); exists r; intros.
   unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros;
@@ -538,9 +538,9 @@ Proof.
   intro; assert (H10 := H0 (disc x (mkposreal _ H9)));
     cut (neighbourhood (disc x (mkposreal alp H9)) x).
   intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12;
-    unfold intersection_domain in H12; elim H12; clear H12; 
-      intros; assert (H14 := H7 _ H13); elim H14; clear H14; 
-        intros y0 H14; elim H14; clear H14; intros; unfold g in H14; 
+    unfold intersection_domain in H12; elim H12; clear H12;
+      intros; assert (H14 := H7 _ H13); elim H14; clear H14;
+        intros y0 H14; elim H14; clear H14; intros; unfold g in H14;
           elim H14; clear H14; intros; unfold disc in H12; simpl in H12;
             cut (alp <= Rabs (y0 - x) / 2).
   intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17);
@@ -557,10 +557,10 @@ Proof.
   unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
     rewrite Rabs_R0; apply H9.
   unfold alp in |- *; apply MinRlist_P2; intros;
-    assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; 
-      intros z H10; elim H10; clear H10; intros; rewrite H11; 
+    assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10;
+      intros z H10; elim H10; clear H10; intros; rewrite H11;
         apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10);
-          unfold intersection_domain, D in H13; elim H13; clear H13; 
+          unfold intersection_domain, D in H13; elim H13; clear H13;
             intros; assumption.
   unfold covering_open_set in |- *; split.
   unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *;
@@ -577,7 +577,7 @@ Proof.
   rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6.
   apply H5.
   unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros;
-    rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; 
+    rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr;
       apply H7.
   apply open_set_P6 with (fun z:R => False).
   apply open_set_P4.
@@ -639,8 +639,8 @@ Proof.
   intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3;
     unfold is_lub in H3; cut (a <= m <= b).
   intro; unfold covering_open_set in H; elim H; clear H; intros;
-    unfold covering in H; assert (H6 := H m H4); elim H6; 
-      clear H6; intros y0 H6; unfold family_open_set in H5; 
+    unfold covering in H; assert (H6 := H m H4); elim H6;
+      clear H6; intros y0 H6; unfold family_open_set in H5;
         assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6);
           unfold neighbourhood in H8; elim H8; clear H8; intros eps H8;
             cut (exists x : R, A x /\ m - eps < x <= m).
@@ -651,11 +651,11 @@ Proof.
       set (Db := fun x:R => Dx x \/ x = y0); exists Db;
         unfold covering_finite in |- *; split.
   unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
-    intros; unfold covering in H12; case (Rle_dec x0 x); 
+    intros; unfold covering in H12; case (Rle_dec x0 x);
       intro.
   cut (a <= x0 <= x).
   intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
-    simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; 
+    simpl in H16; simpl in |- *; unfold Db in |- *; elim H16;
       clear H16; intros; split; [ apply H16 | left; apply H17 ].
   split.
   elim H14; intros; assumption.
@@ -672,9 +672,9 @@ Proof.
   apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15.
   unfold Db in |- *; right; reflexivity.
   unfold family_finite in |- *; unfold domain_finite in |- *;
-    unfold covering_finite in H12; elim H12; clear H12; 
-      intros; unfold family_finite in H13; unfold domain_finite in H13; 
-        elim H13; clear H13; intros l H13; exists (cons y0 l); 
+    unfold covering_finite in H12; elim H12; clear H12;
+      intros; unfold family_finite in H13; unfold domain_finite in H13;
+        elim H13; clear H13; intros l H13; exists (cons y0 l);
           intro; split.
   intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
     clear H13; intros; case (Req_dec x0 y0); intro.
@@ -723,7 +723,7 @@ Proof.
     set (Db := fun x:R => Dx x \/ x = y0); exists Db;
       unfold covering_finite in |- *; split.
   unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
-    intros; unfold covering in H12; case (Rle_dec x0 x); 
+    intros; unfold covering in H12; case (Rle_dec x0 x);
       intro.
   cut (a <= x0 <= x).
   intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
@@ -758,15 +758,15 @@ Proof.
   ring.
   unfold Db in |- *; right; reflexivity.
   unfold family_finite in |- *; unfold domain_finite in |- *;
-    unfold covering_finite in H12; elim H12; clear H12; 
-      intros; unfold family_finite in H13; unfold domain_finite in H13; 
-        elim H13; clear H13; intros l H13; exists (cons y0 l); 
+    unfold covering_finite in H12; elim H12; clear H12;
+      intros; unfold family_finite in H13; unfold domain_finite in H13;
+        elim H13; clear H13; intros l H13; exists (cons y0 l);
           intro; split.
   intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
     clear H13; intros; case (Req_dec x0 y0); intro.
   simpl in |- *; left; apply H16.
   simpl in |- *; right; apply H13; simpl in |- *;
-    unfold intersection_domain in |- *; unfold Db in H14; 
+    unfold intersection_domain in |- *; unfold Db in H14;
       decompose [and or] H14.
   split; assumption.
   elim H16; assumption.
@@ -793,7 +793,7 @@ Proof.
   set (P := fun n:R => A n /\ m - eps < n <= m);
     assert (H12 := not_ex_all_not _ P H9); unfold P in H12;
       unfold is_upper_bound in |- *; intros;
-        assert (H14 := not_and_or _ _ (H12 x)); elim H14; 
+        assert (H14 := not_and_or _ _ (H12 x)); elim H14;
           intro.
   elim H15; apply H13.
   elim (not_and_or _ _ H15); intro.
@@ -806,11 +806,11 @@ Proof.
   split.
   apply (H3 _ H0).
   apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5;
-    clear H5; intros H5 _; elim H5; clear H5; intros _ H5; 
+    clear H5; intros H5 _; elim H5; clear H5; intros _ H5;
       apply H5.
   exists a; apply H0.
   unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros;
-    unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; 
+    unfold A in H1; elim H1; clear H1; intros H1 _; elim H1;
       clear H1; intros _ H1; apply H1.
   unfold A in |- *; split.
   split; [ right; reflexivity | apply r ].
@@ -862,15 +862,15 @@ Proof.
   elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7.
   apply H9.
   unfold family_finite in |- *; unfold domain_finite in |- *;
-    unfold family_finite in H6; unfold domain_finite in H6; 
+    unfold family_finite in H6; unfold domain_finite in H6;
       elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x);
         elim H7; clear H7; intros.
   split.
   intro; apply H7; simpl in |- *; unfold intersection_domain in |- *;
-    simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; 
+    simpl in H9; unfold intersection_domain in H9; unfold D' in |- *;
       apply H9.
   intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10;
-    simpl in |- *; unfold intersection_domain in |- *; 
+    simpl in |- *; unfold intersection_domain in |- *;
       unfold D' in H10; apply H10.
   unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2;
     clear H2; intros.
@@ -964,14 +964,14 @@ Proof.
       simpl in H11; elim H11; intros z H12; exists z; unfold g in H12;
         unfold image_rec in H12; rewrite H9; apply H12.
   unfold family_finite in H6; unfold domain_finite in H6;
-    unfold family_finite in |- *; unfold domain_finite in |- *; 
-      elim H6; intros l H7; exists l; intro; elim (H7 x); 
+    unfold family_finite in |- *; unfold domain_finite in |- *;
+      elim H6; intros l H7; exists l; intro; elim (H7 x);
         intros; split; intro.
   apply H8; simpl in H10; simpl in |- *; apply H10.
   apply (H9 H10).
   unfold covering_open_set in |- *; split.
   unfold covering in |- *; intros; simpl in |- *; unfold covering in H1;
-    unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; 
+    unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *;
       apply H1.
   exists x; split; [ reflexivity | apply H4 ].
   unfold family_open_set in |- *; unfold family_open_set in H2; intro;
@@ -1014,8 +1014,8 @@ Proof.
   exists h; split.
   unfold continuity in |- *; intro; case (Rtotal_order x a); intro.
   unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      simpl in |- *; unfold R_dist in |- *; intros; exists (a - x);
         split.
   change (0 < a - x) in |- *; apply Rlt_Rminus; assumption.
   intros; elim H5; clear H5; intros _ H5; unfold h in |- *.
@@ -1034,8 +1034,8 @@ Proof.
     unfold limit1_in in H6; unfold limit_in in H6; simpl in H6;
       unfold R_dist in H6; unfold continuity_pt in |- *;
         unfold continue_in in |- *; unfold limit1_in in |- *;
-          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
-            intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); 
+          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+            intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a));
               split.
   unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
   elim H8; intros; assumption.
@@ -1067,8 +1067,8 @@ Proof.
     unfold limit1_in in H7; unfold limit_in in H7; simpl in H7;
       unfold R_dist in H7; unfold continuity_pt in |- *;
         unfold continue_in in |- *; unfold limit1_in in |- *;
-          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
-            intros; elim (H7 _ H8); intros; elim H9; clear H9; 
+          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+            intros; elim (H7 _ H8); intros; elim H9; clear H9;
               intros.
   assert (H11 : 0 < x - a).
   apply Rlt_Rminus; assumption.
@@ -1119,8 +1119,8 @@ Proof.
     unfold limit1_in in H8; unfold limit_in in H8; simpl in H8;
       unfold R_dist in H8; unfold continuity_pt in |- *;
         unfold continue_in in |- *; unfold limit1_in in |- *;
-          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
-            intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); 
+          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+            intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a));
               split.
   unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
   elim H10; intros; assumption.
@@ -1152,8 +1152,8 @@ Proof.
   assumption.
   apply Rmin_r.
   unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      simpl in |- *; unfold R_dist in |- *; intros; exists (x - b);
         split.
   change (0 < x - b) in |- *; apply Rlt_Rminus; assumption.
   intros; elim H8; clear H8; intros.
@@ -1210,8 +1210,8 @@ Proof.
   intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8;
     clear H8; intros; exists Mxx; split.
   intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros;
-    rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; 
-      intros H7 _; unfold is_upper_bound in H7; apply H7; 
+    rewrite <- H8; unfold is_lub in H7; elim H7; clear H7;
+      intros H7 _; unfold is_upper_bound in H7; apply H7;
         unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ].
   apply H9.
   elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro.
@@ -1298,7 +1298,7 @@ Proof.
   intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2;
     intros x0 H3; exists x0; intros; split.
   intros; rewrite <- (Ropp_involutive (f0 x0));
-    rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; 
+    rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar;
       elim H3; intros; unfold opp_fct in H5; apply H5; apply H4.
   elim H3; intros; assumption.
   intros.
@@ -1348,10 +1348,10 @@ Lemma ValAdh_un_prop :
 Proof.
   intros; split; intro.
   unfold ValAdh in H; unfold ValAdh_un in |- *;
-    unfold intersection_family in |- *; simpl in |- *; 
+    unfold intersection_family in |- *; simpl in |- *;
       intros; elim H0; intros N H1; unfold adherence in |- *;
-        unfold point_adherent in |- *; intros; elim (H V N H2); 
-          intros; exists (un x0); unfold intersection_domain in |- *; 
+        unfold point_adherent in |- *; intros; elim (H V N H2);
+          intros; exists (un x0); unfold intersection_domain in |- *;
             elim H3; clear H3; intros; split.
   assumption.
   split.
@@ -1367,9 +1367,9 @@ Proof.
             (exists n : nat, INR N = INR n)) x).
   apply H; exists N; reflexivity.
   unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0);
-    elim H2; intros; unfold intersection_domain in H3; 
-      elim H3; clear H3; intros; elim H4; clear H4; intros; 
-        elim H4; clear H4; intros; elim H4; clear H4; intros; 
+    elim H2; intros; unfold intersection_domain in H3;
+      elim H3; clear H3; intros; elim H4; clear H4; intros;
+        elim H4; clear H4; intros; elim H4; clear H4; intros;
           exists x1; split.
   apply (INR_le _ _ H6).
   rewrite H4 in H3; apply H3.
@@ -1379,7 +1379,7 @@ Lemma adherence_P4 :
   forall F G:R -> Prop, included F G -> included (adherence F) (adherence G).
 Proof.
   unfold adherence, included in |- *; unfold point_adherent in |- *; intros;
-    elim (H0 _ H1); unfold intersection_domain in |- *; 
+    elim (H0 _ H1); unfold intersection_domain in |- *;
       intros; elim H2; clear H2; intros; exists x0; split;
         [ assumption | apply (H _ H3) ].
 Qed.
@@ -1392,7 +1392,7 @@ Definition intersection_vide_in (D:R -> Prop) (f:family) : Prop :=
     (ind f x -> included (f x) D) /\
     ~ (exists y : R, intersection_family f y).
 
-Definition intersection_vide_finite_in (D:R -> Prop) 
+Definition intersection_vide_finite_in (D:R -> Prop)
   (f:family) : Prop := intersection_vide_in D f /\ family_finite f.
 
 (**********)
@@ -1417,9 +1417,9 @@ Proof.
     elim (H1 x); intros; unfold intersection_family in H5;
       assert
         (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x);
-        assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); 
-          elim H7; intros; exists x0; elim (imply_to_and _ _ H8); 
-            intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; 
+        assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6);
+          elim H7; intros; exists x0; elim (imply_to_and _ _ H8);
+            intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *;
               split; [ apply H10 | apply H9 ].
   unfold family_open_set in |- *; intro; elim (classic (D' x)); intro.
   apply open_set_P6 with (complementary (g x)).
@@ -1448,7 +1448,7 @@ Proof.
     unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8;
       unfold intersection_domain in H6; cut (ind g x1 /\ SF x1).
   intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8;
-    clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; 
+    clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8;
       elim H8; clear H8; intros H8 _; elim H8; assumption.
   split.
   apply (cond_fam f0).
@@ -1463,15 +1463,15 @@ Proof.
   unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
     cut (exists z : R, X z).
   intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5);
-    intros; simpl in H6; elim Hyp'; exists x1; elim H6; 
+    intros; simpl in H6; elim Hyp'; exists x1; elim H6;
       intros; unfold intersection_domain in |- *; split.
   apply (cond_fam f0); exists x0; apply H7.
   apply H8.
   apply Hyp.
   unfold covering_finite in H4; elim H4; clear H4; intros;
     unfold family_finite in H5; unfold domain_finite in H5;
-      unfold family_finite in |- *; unfold domain_finite in |- *; 
-        elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); 
+      unfold family_finite in |- *; unfold domain_finite in |- *;
+        elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x);
           intros; split; intro;
             [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ].
 Qed.
@@ -1506,7 +1506,7 @@ Proof.
   intro; cut (intersection_vide_in X f0).
   intro; assert (H7 := H3 H5 H6).
   elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8;
-    clear H8; intros; unfold intersection_vide_in in H8; 
+    clear H8; intros; unfold intersection_vide_in in H8;
       elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9;
         unfold domain_finite in H9; elim H9; clear H9; intros l H9;
           set (r := MaxRlist l); cut (D r).
@@ -1536,7 +1536,7 @@ Proof.
       assert
         (H17 :=
           not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13);
-        assert (H18 := H16 x); unfold intersection_family in H18; 
+        assert (H18 := H16 x); unfold intersection_family in H18;
           simpl in H18;
             assert
               (H19 :=
@@ -1598,17 +1598,17 @@ Theorem Heine :
     (forall x:R, X x -> continuity_pt f x) -> uniform_continuity f X.
 Proof.
   intros f0 X H0 H; elim (domain_P1 X); intro Hyp.
-(* X est vide *)
+(* X is empty *)
   unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
     intros; elim Hyp; exists x; assumption.
   elim Hyp; clear Hyp; intro Hyp.
-(* X possède un seul élément *)
+(* X has only one element *)
   unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
-    intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; 
-      intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); 
+    intros; elim Hyp; clear Hyp; intros; elim H4; clear H4;
+      intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2);
         rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r;
           rewrite Rabs_R0; apply (cond_pos eps).
-(* X possède au moins deux éléments distincts *)
+(* X has at least two distinct elements *)
   assert
     (X_enc :
       exists m : R, (exists M : R, (forall x:R, X x -> m <= x <= M) /\ m < M)).
@@ -1616,8 +1616,8 @@ Proof.
     elim H2; intros; exists x; exists x0; split.
   apply H3.
   elim Hyp; intros; elim H4; intros; decompose [and] H5;
-    assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); 
-      elim H10; intros; elim H11; intros; case (total_order_T x x0); 
+    assert (H10 := H3 _ H6); assert (H11 := H3 _ H8);
+      elim H10; intros; elim H11; intros; case (total_order_T x x0);
         intro.
   elim s; intro.
   assumption.
@@ -1652,7 +1652,7 @@ Proof.
   assumption.
   assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4;
     unfold limit1_in in H4; unfold limit_in in H4; simpl in H4;
-      unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); 
+      unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps));
         intros;
           set
             (E :=
@@ -1661,7 +1661,7 @@ Proof.
                 (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
             assert (H6 : bound E).
   unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
-    unfold E in |- *; intros; elim H6; clear H6; intros H6 _; 
+    unfold E in |- *; intros; elim H6; clear H6; intros H6 _;
       elim H6; clear H6; intros _ H6; apply H6.
   assert (H7 :  exists x : R, E x).
   elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros;
@@ -1693,14 +1693,14 @@ Proof.
   intro; assert (H16 := H14 _ H15);
     elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)).
   unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13;
-    assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); 
+    assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x)));
       intro.
   assumption.
   elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ].
   split.
   apply p.
   unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
-    rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; 
+    rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *;
       apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ].
   elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _;
     unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12;
@@ -1711,8 +1711,8 @@ Proof.
   unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x));
     intro.
   unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4;
-    intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; 
-      intros; unfold neighbourhood in |- *; case (Req_dec x x0); 
+    intros _ H4; elim H4; clear H4; intros; elim H4; clear H4;
+      intros; unfold neighbourhood in |- *; case (Req_dec x x0);
         intro.
   exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros;
     split.
@@ -1745,7 +1745,7 @@ Proof.
   intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4.
   elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4;
     intros; unfold family_finite in H5; unfold domain_finite in H5;
-      unfold covering in H4; simpl in H4; simpl in H5; elim H5; 
+      unfold covering in H4; simpl in H4; simpl in H5; elim H5;
         clear H5; intros l H5; unfold intersection_domain in H5;
           cut
             (forall x:R,
@@ -1761,8 +1761,8 @@ Proof.
         (fun x del:R =>
           0 < del /\
           (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
-          included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); 
-      elim H7; clear H7; intros l' H7; elim H7; clear H7; 
+          included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6);
+      elim H7; clear H7; intros l' H7; elim H7; clear H7;
         intros; set (D := MinRlist l'); cut (0 < D / 2).
   intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13;
     clear H13; intros xi H13; assert (H14 : In xi l).
@@ -1785,8 +1785,8 @@ Proof.
     rewrite double; apply Rplus_lt_compat_l; apply H19.
   discrR.
   assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
-    elim H20; clear H20; intros; rewrite <- Rabs_Ropp; 
-      rewrite Ropp_minus_distr; apply H20; unfold included in H21; 
+    elim H20; clear H20; intros; rewrite <- Rabs_Ropp;
+      rewrite Ropp_minus_distr; apply H20; unfold included in H21;
         elim H13; intros; assert (H24 := H21 x H22);
           apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)).
   replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ].
@@ -1803,7 +1803,7 @@ Proof.
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
     [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros;
       elim (H10 H9); intros; elim H12; intros; rewrite H14;
-        rewrite <- H7 in H13; elim (H8 x H13); intros; 
+        rewrite <- H7 in H13; elim (H8 x H13); intros;
           apply H15
       | apply Rinv_0_lt_compat; prove_sup0 ].
   intros; elim (H5 x); intros; elim (H8 H6); intros;
@@ -1814,14 +1814,14 @@ Proof.
           (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
       assert (H11 : bound E).
   unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
-    unfold E in |- *; intros; elim H11; clear H11; intros H11 _; 
+    unfold E in |- *; intros; elim H11; clear H11; intros H11 _;
       elim H11; clear H11; intros _ H11; apply H11.
   assert (H12 :  exists x : R, E x).
   assert (H13 := H _ H9); unfold continuity_pt in H13;
-    unfold continue_in in H13; unfold limit1_in in H13; 
+    unfold continue_in in H13; unfold limit1_in in H13;
       unfold limit_in in H13; simpl in H13; unfold R_dist in H13;
-        elim (H13 _ (H1 eps)); intros; elim H12; clear H12; 
-          intros; exists (Rmin x0 (M - m)); unfold E in |- *; 
+        elim (H13 _ (H1 eps)); intros; elim H12; clear H12;
+          intros; exists (Rmin x0 (M - m)); unfold E in |- *;
             intros; split.
   split;
     [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro;
@@ -1850,7 +1850,7 @@ Proof.
   intro; assert (H21 := H19 _ H20);
     elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)).
   unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18;
-    assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); 
+    assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x)));
       intro.
   assumption.
   elim (H17 x1); split.
@@ -1864,7 +1864,7 @@ Proof.
   apply H21.
   elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14;
     intros H15 _; unfold is_lub in p; elim p; intros;
-      unfold is_upper_bound in H16; unfold is_upper_bound in H17; 
+      unfold is_upper_bound in H16; unfold is_upper_bound in H17;
         split.
   apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ].
   apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros;
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
index 0baece39..c637b7ab 100644
--- a/theories/Reals/Rtrigo.v
+++ b/theories/Reals/Rtrigo.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo.v 9454 2006-12-15 15:30:59Z bgregoir $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -19,8 +19,8 @@ Require Export Cos_plus.
 Require Import ZArith_base.
 Require Import Zcomplements.
 Require Import Classical_Prop.
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
+Local Open Scope nat_scope.
+Local Open Scope R_scope.
 
 (** sin_PI2 is the only remaining axiom **)
 Axiom sin_PI2 : sin (PI / 2) = 1.
@@ -32,7 +32,7 @@ Proof.
     elim (Rlt_irrefl _ H0).
 Qed.
 
-(**********) 
+(**********)
 Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y.
 Proof.
   intros; unfold Rminus in |- *; rewrite cos_plus.
@@ -50,7 +50,7 @@ Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x).
 Proof.
   intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1;
     unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x)));
-      rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry  in |- *; 
+      rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry  in |- *;
         apply Rplus_0_r.
 Qed.
 
@@ -151,7 +151,7 @@ Proof.
           rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite (Rmult_comm (sin x));
     rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc;
-      apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); 
+      apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y));
         rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   apply Rmult_1_r.
   assumption.
@@ -185,7 +185,7 @@ Qed.
 Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1.
 Proof.
   intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc;
-    rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; 
+    rewrite cos_plus; generalize (sin2_cos2 x); rewrite double;
       intro H1; rewrite <- H1; ring_Rsqr.
 Qed.
 
@@ -219,7 +219,7 @@ Qed.
 Lemma tan_0 : tan 0 = 0.
 Proof.
   unfold tan in |- *; rewrite sin_0; rewrite cos_0.
-  unfold Rdiv in |- *; apply Rmult_0_l. 
+  unfold Rdiv in |- *; apply Rmult_0_l.
 Qed.
 
 Lemma tan_neg : forall x:R, tan (- x) = - tan x.
@@ -320,7 +320,7 @@ Lemma PI2_RGT_0 : 0 < PI / 2.
 Proof.
   unfold Rdiv in |- *; apply Rmult_lt_0_compat;
     [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ].
-Qed. 
+Qed.
 
 Lemma SIN_bound : forall x:R, -1 <= sin x <= 1.
 Proof.
@@ -331,13 +331,13 @@ Proof.
   intro;
     generalize
       (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
-        (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); 
+        (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H)));
       rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
         generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
-          repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
+          repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
             rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
               generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
-                repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
+                repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
                   intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
   auto with real.
   cut (sin x < -1).
@@ -346,13 +346,13 @@ Proof.
       generalize
         (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
           (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H)));
-        rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; 
+        rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0;
           rewrite sin2 in H0; unfold Rminus in H0;
             generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
-              repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
+              repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
                 rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
                   generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
-                    repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
+                    repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
                       intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
   auto with real.
 Qed.
@@ -366,7 +366,7 @@ Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0).
 Proof.
   intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro;
     rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2;
-      rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; 
+      rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro;
         rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3).
 Qed.
 
@@ -399,18 +399,18 @@ Proof.
   repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r;
     replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ];
     replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ];
-    replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); 
+    replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat);
     [ idtac | ring ];
     replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
     (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
   apply Rplus_lt_0_compat.
   unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
-    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); 
-      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat));
+      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
         apply H1.
   unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
-    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); 
-      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat));
+      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
         apply H1.
   intro; unfold Un in |- *.
   cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat).
@@ -533,7 +533,7 @@ Proof.
       (SIN (PI - x) (Rlt_le 0 (PI - x) H7)
         (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI)));
       intros H8 _;
-        generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); 
+        generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5));
           intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8).
   reflexivity.
   pattern PI at 2 in |- *; rewrite double_var; ring.
@@ -545,7 +545,7 @@ Proof.
   intros; rewrite cos_sin;
     generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H).
   rewrite Rplus_opp_r; intro H1;
-    generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); 
+    generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0);
       rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2).
 Qed.
 
@@ -599,7 +599,7 @@ Proof.
     replace (PI / 2) with (- PI + 3 * (PI / 2)).
   apply Rplus_le_compat_l; assumption.
   pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring. 
+    ring.
   unfold INR in |- *; ring.
 Qed.
 
@@ -625,7 +625,7 @@ Proof.
   intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H);
     replace (2 * PI + - PI) with PI;
     [ intro H1; rewrite Rplus_comm in H1;
-      generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); 
+      generalize (Rplus_lt_compat_l (2 * PI) x 0 H0);
         intro H2; rewrite (Rplus_comm (2 * PI)) in H2;
           rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2;
             rewrite <- (sin_period x 1); unfold INR in |- *;
@@ -644,12 +644,12 @@ Proof.
   unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l;
     assumption.
   pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring. 
+    ring.
   unfold Rminus in |- *; rewrite Rplus_comm;
     replace (PI / 2) with (- PI + 3 * (PI / 2)).
   apply Rplus_lt_compat_l; assumption.
   pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring. 
+    ring.
   unfold INR in |- *; ring.
 Qed.
 
@@ -658,7 +658,7 @@ Proof.
   intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0;
     generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros;
       generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5;
-        generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); 
+        generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI);
           intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
   apply sin_gt_0; assumption.
   apply Rinv_0_lt_compat; apply cos_gt_0; assumption.
@@ -667,7 +667,7 @@ Qed.
 Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0.
 Proof.
   intros x H1 H2; unfold tan in |- *;
-    generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); 
+    generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0));
       intro H3; rewrite <- Ropp_0;
         replace (sin x / cos x) with (- (- sin x / cos x)).
   rewrite <- sin_neg; apply Ropp_gt_lt_contravar;
@@ -688,11 +688,11 @@ Proof.
   intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1);
     unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x).
   generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1;
-    generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; 
+    generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1;
       intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1).
-  rewrite Rplus_opp_r. 
+  rewrite Rplus_opp_r.
   intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3;
-    generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; 
+    generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3;
       intro H3;
         generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3).
   replace (2 * PI + - (3 * (PI / 2))) with (PI / 2).
@@ -780,11 +780,11 @@ Proof.
   generalize
     (Rmult_le_compat_l (/ 2) (x - y) PI
       (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8).
-  repeat rewrite (Rmult_comm (/ 2)). 
+  repeat rewrite (Rmult_comm (/ 2)).
   intro H9;
     generalize
       (sin_gt_0 ((x - y) / 2) H6
-        (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); 
+        (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI));
       intro H10;
         elim
           (Rlt_irrefl (sin ((x - y) / 2))
@@ -799,7 +799,7 @@ Proof.
     generalize
       (Rmult_le_compat_l (/ 2) (x + y) PI
         (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4).
-  repeat rewrite (Rmult_comm (/ 2)). 
+  repeat rewrite (Rmult_comm (/ 2)).
   clear H4; intro H4;
     generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1);
       replace (- (PI / 2) + - (PI / 2)) with (- PI).
@@ -813,7 +813,7 @@ Proof.
   elim H5; intro H50.
   generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6;
     generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6).
-  rewrite Rmult_0_r. 
+  rewrite Rmult_0_r.
   clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7.
   assumption.
   generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7;
@@ -824,7 +824,7 @@ Proof.
         (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3);
         intro H9; elim (Rlt_irrefl 0 H9).
   rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3;
-    rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; 
+    rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
       elim (Rlt_irrefl 0 H3).
   unfold Rdiv in H3.
   rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50;
@@ -865,8 +865,8 @@ Proof.
   clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1);
     rewrite Ropp_involutive; clear H1; intro H1;
       generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1;
-        generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; 
-          intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); 
+        generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2;
+          intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2);
             clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3);
               replace (- y + x) with (x - y).
   rewrite Rplus_opp_l.
@@ -885,12 +885,12 @@ Proof.
   replace (/ 2 * (x - y)) with ((x - y) / 2).
   clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4;
     generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8;
-      generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); 
+      generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8);
         clear H8; intro H8; cut (- PI < - (PI / 2)).
   intro H9;
     generalize
       (sin_lt_0_var ((x - y) / 2)
-        (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); 
+        (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6);
       intro H10;
         generalize
           (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 (
@@ -1012,21 +1012,21 @@ Proof.
   replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
   apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
   unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse. 
-  apply Rplus_comm. 
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
   unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse. 
-  apply Rplus_comm. 
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
   pattern PI at 3 in |- *; rewrite double_var.
   ring.
   rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
   ring.
   unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse. 
-  apply Rplus_comm. 
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
   unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse. 
-  apply Rplus_comm. 
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
   rewrite Rmult_1_r.
   rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
   ring.
@@ -1110,7 +1110,7 @@ Lemma tan_diff :
     cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y).
 Proof.
   intros; unfold tan in |- *; rewrite sin_minus.
-  unfold Rdiv in |- *. 
+  unfold Rdiv in |- *.
   unfold Rminus in |- *.
   rewrite Rmult_plus_distr_r.
   rewrite Rinv_mult_distr.
@@ -1143,7 +1143,7 @@ Lemma tan_increasing_0 :
     x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y.
 Proof.
   intros; generalize PI4_RLT_PI2; intro H4;
-    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
+    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4);
       intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
         generalize
           (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
@@ -1155,20 +1155,20 @@ Proof.
               (sym_not_eq
                 (Rlt_not_eq 0 (cos x)
                   (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
+                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4))));
               intro H6;
                 generalize
                   (sym_not_eq
                     (Rlt_not_eq 0 (cos y)
                       (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
+                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4))));
                   intro H7; generalize (tan_diff x y H6 H7); intro H8;
-                    generalize (Rlt_minus (tan x) (tan y) H3); clear H3; 
+                    generalize (Rlt_minus (tan x) (tan y) H3); clear H3;
                       intro H3; rewrite H8 in H3; cut (sin (x - y) < 0).
   intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1);
     rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10);
       clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
-        intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
+        intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11);
           clear H11; intro H11;
             generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
               generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10);
@@ -1180,7 +1180,7 @@ Proof.
     (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI));
     intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)).
   elim H14; intro H15.
-  rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). 
+  rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9).
   apply Rminus_lt; assumption.
   pattern PI at 1 in |- *; rewrite double_var.
   unfold Rdiv in |- *.
@@ -1218,7 +1218,7 @@ Proof.
       elim
         (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)).
   rewrite Rinv_mult_distr.
-  reflexivity. 
+  reflexivity.
   assumption.
   assumption.
 Qed.
@@ -1229,7 +1229,7 @@ Lemma tan_increasing_1 :
     x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y.
 Proof.
   intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4;
-    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
+    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4);
       intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
         generalize
           (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
@@ -1241,27 +1241,27 @@ Proof.
               (sym_not_eq
                 (Rlt_not_eq 0 (cos x)
                   (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
+                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4))));
               intro H6;
                 generalize
                   (sym_not_eq
                     (Rlt_not_eq 0 (cos y)
                       (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
+                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4))));
                   intro H7; rewrite (tan_diff x y H6 H7);
                     generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
                       generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
                         generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
                           replace (/ cos x * / cos y) with (/ (cos x * cos y)).
   clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
-    intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
+    intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11);
       clear H11; intro H11;
         generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
           replace (x + - y) with (x - y).
   replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
   clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3;
-    clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; 
-      intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); 
+    clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI;
+      intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1);
         clear H1; intro H1;
           generalize
             (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3);
@@ -1576,13 +1576,13 @@ Proof.
 Qed.
 
 Lemma cos_eq_0_0 :
-  forall x:R, cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2. 
+  forall x:R, cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2.
 Proof.
   intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H);
     intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z;
       rewrite <- Z_R_minus; simpl.
 unfold INR in H3. field_simplify [(sym_eq H3)]. field.
-(** 
+(**
   ring_simplify.
  (* rewrite (Rmult_comm PI);*) (* old ring compat *)
         rewrite <- H3; simpl;
@@ -1618,7 +1618,7 @@ Proof.
         (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0);
       repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
   repeat rewrite Rmult_1_r; intro;
-    generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); 
+    generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5);
       rewrite <- plus_IZR.
   replace (IZR (-2) + 1) with (-1).
   intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6);
@@ -1710,7 +1710,7 @@ Proof.
   apply Rplus_le_le_0_compat.
   left; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
   apply PI_RGT_0.
-  apply Rinv_0_lt_compat; prove_sup0. 
+  apply Rinv_0_lt_compat; prove_sup0.
   assumption.
   elim H2; intro.
   right; assumption.
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index d82bafc6..fe2da839 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_alt.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -48,9 +48,9 @@ Theorem sin_bound :
 Proof.
   intros; case (Req_dec a 0); intro Hyp_a.
   rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *;
-    apply sum_eq_R0 || (symmetry  in |- *; apply sum_eq_R0); 
-      intros; unfold sin_term in |- *; rewrite pow_add; 
-        simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; 
+    apply sum_eq_R0 || (symmetry  in |- *; apply sum_eq_R0);
+      intros; unfold sin_term in |- *; rewrite pow_add;
+        simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l;
           ring.
   unfold sin_approx in |- *; cut (0 < a).
   intro Hyp_a_pos.
@@ -123,7 +123,7 @@ Proof.
   simpl in |- *; ring.
   ring.
   assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3;
-    unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; 
+    unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *;
       intros; elim (H3 eps H4); intros N H5.
   exists N; intros; apply H5.
   replace (2 * S n0 + 1)%nat with (S (2 * S n0)).
@@ -138,7 +138,7 @@ Proof.
   assert (X := exist_sin (Rsqr a)); elim X; intros.
   cut (x = sin a / a).
   intro; rewrite H3 in p; unfold sin_in in p; unfold infinite_sum in p;
-    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
+    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *;
       intros.
   cut (0 < eps / Rabs a).
   intro; elim (p _ H5); intros N H6.
@@ -146,9 +146,9 @@ Proof.
   replace (sum_f_R0 (tg_alt Un) n0) with
   (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
   unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
-    rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+    rewrite Ropp_plus_distr; rewrite Ropp_involutive;
       repeat rewrite Rplus_assoc; rewrite (Rplus_comm a);
-        rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; 
+        rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc;
           rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
   pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a).
@@ -163,7 +163,7 @@ Proof.
   simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
     rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
       rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse;
-        rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; 
+        rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum;
           apply sum_eq.
   intros; unfold sin_n, Un, tg_alt in |- *;
     replace ((-1) ^ S i) with (- (-1) ^ i).
@@ -230,7 +230,7 @@ Lemma cos_bound :
   forall (a:R) (n:nat),
     - PI / 2 <= a ->
     a <= PI / 2 ->
-    cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). 
+    cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)).
 Proof.
   cut
     ((forall (a:R) (n:nat),
@@ -318,7 +318,7 @@ Proof.
   simpl in |- *; ring.
   ring.
   assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4;
-    unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; 
+    unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *;
       intros; elim (H4 eps H5); intros N H6; exists N; intros.
   apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat.
   apply le_trans with (2 * N)%nat.
@@ -328,7 +328,7 @@ Proof.
   assert (X := exist_cos (Rsqr a0)); elim X; intros.
   cut (x = cos a0).
   intro; rewrite H4 in p; unfold cos_in in p; unfold infinite_sum in p;
-    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
+    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *;
       intros.
   elim (p _ H5); intros N H6.
   exists N; intros.
@@ -336,9 +336,9 @@ Proof.
   (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
   unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
     repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
-      rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; 
+      rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc;
         rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
-          rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+          rewrite Ropp_plus_distr; rewrite Ropp_involutive;
             unfold Rminus in H6; apply H6.
   unfold ge in |- *; apply le_trans with n1.
   exact H7.
@@ -351,7 +351,7 @@ Proof.
         replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1)
     with
       (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1);
-      [ idtac | ring ]; rewrite scal_sum; apply sum_eq; 
+      [ idtac | ring ]; rewrite scal_sum; apply sum_eq;
         intros; unfold cos_n, Un, tg_alt in |- *.
   replace ((-1) ^ S i) with (- (-1) ^ i).
   replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i).
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index baf0fa4b..a7fddb47 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_calc.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -18,7 +18,7 @@ Open Local Scope R_scope.
 Lemma tan_PI : tan PI = 0.
 Proof.
   unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *;
-    apply Rmult_0_l. 
+    apply Rmult_0_l.
 Qed.
 
 Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1.
@@ -129,7 +129,7 @@ Qed.
 Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0.
 Proof.
   generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H;
-    generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); 
+    generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H);
       intro H0; assumption.
 Qed.
 
@@ -163,9 +163,9 @@ Proof.
         | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3);
           [ prove_sup0
             | generalize (Rlt_le 0 3 Hyp2); intro H2;
-              generalize (lt_INR_0 1 (neq_O_lt 1 H0)); 
+              generalize (lt_INR_0 1 (neq_O_lt 1 H0));
                 unfold INR in |- *; intro H3;
-                  generalize (Rplus_lt_compat_l 2 0 1 H3); 
+                  generalize (Rplus_lt_compat_l 2 0 1 H3);
                     rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
                       [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
                         apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3)
@@ -303,7 +303,7 @@ Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2.
 Proof.
   rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
     unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
-      repeat rewrite <- Rmult_assoc; rewrite double_var; 
+      repeat rewrite <- Rmult_assoc; rewrite double_var;
         reflexivity.
 Qed.
 
@@ -385,7 +385,7 @@ Proof.
       replace (PI + PI / 2) with (3 * (PI / 2)).
   rewrite Rplus_0_r; intro H2; assumption.
   pattern PI at 2 in |- *; rewrite double_var; ring.
-Qed. 
+Qed.
 
 Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI.
 Proof.
@@ -450,7 +450,7 @@ Proof.
   left; apply sin_lb_gt_0; assumption.
   elim H1; intro.
   rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *;
-    unfold sum_f_R0 in |- *; unfold sin_term in |- *; 
+    unfold sum_f_R0 in |- *; unfold sin_term in |- *;
       repeat rewrite pow_ne_zero.
   unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
     repeat rewrite Rplus_0_r; right; reflexivity.
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
index e94d7448..9588e443 100644
--- a/theories/Reals/Rtrigo_def.v
+++ b/theories/Reals/Rtrigo_def.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_def.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -63,7 +63,7 @@ Proof.
 Defined.
 
 (* Value of [exp 0] *)
-Lemma exp_0 : exp 0 = 1. 
+Lemma exp_0 : exp 0 = 1.
 Proof.
   cut (exp_in 0 (exp 0)).
   cut (exp_in 0 1).
@@ -96,7 +96,7 @@ Qed.
 Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)).
 
 Lemma simpl_cos_n :
-  forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). 
+  forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)).
 Proof.
   intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
@@ -176,7 +176,7 @@ Proof.
   assert (H0 := archimed_cor1 eps H).
   elim H0; intros; exists x.
   intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *;
-    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
       rewrite Rabs_Ropp; rewrite Rabs_right.
   rewrite mult_INR; rewrite Rinv_mult_distr.
   cut (/ INR (2 * S n) < 1).
@@ -250,7 +250,7 @@ Definition cos (x:R) : R := let (a,_) := exist_cos (Rsqr x) in a.
 Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)).
 
 Lemma simpl_sin_n :
-  forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). 
+  forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)).
 Proof.
   intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
@@ -300,7 +300,7 @@ Proof.
   unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H).
   elim H0; intros; exists x.
   intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *;
-    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
       rewrite Rabs_Ropp; rewrite Rabs_right.
   rewrite mult_INR; rewrite Rinv_mult_distr.
   cut (/ INR (2 * S n) < 1).
@@ -382,7 +382,7 @@ Qed.
 Lemma sin_antisym : forall x:R, sin (- x) = - sin x.
 Proof.
   intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x);
-    [ idtac | apply Rsqr_neg ]. 
+    [ idtac | apply Rsqr_neg ].
   case (exist_sin (Rsqr x)); intros; ring.
 Qed.
 
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
index 6eec0329..cb53b534 100644
--- a/theories/Reals/Rtrigo_fun.v
+++ b/theories/Reals/Rtrigo_fun.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_fun.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -33,7 +33,7 @@ Proof.
       generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2);
         replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ].
   rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2;
-    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); 
+    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H);
       intro; unfold Rgt in H3;
         generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2);
           intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4;
@@ -42,11 +42,11 @@ Proof.
                 rewrite (Rmult_comm (/ INR (S n))) in H4;
                   rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
                     rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H4;
-                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; 
+                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4;
                         assumption.
   apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1;
     apply (Rinv_lt_contravar 1 eps); auto;
-      rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; 
+      rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H;
         assumption.
   unfold Rgt in H1; apply Rlt_le; assumption.
   unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
@@ -61,12 +61,12 @@ Proof.
   intro ;
     generalize
       (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4
-        (le_INR x n H2)); 
+        (le_INR x n H2));
       clear H4; intro; unfold Rminus in H4;
         generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4);
           replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ].
   rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4;
-    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); 
+    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H);
       intro; unfold Rgt in H5;
         generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4);
           intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6;
@@ -75,7 +75,7 @@ Proof.
                 rewrite (Rmult_comm (/ INR (S n))) in H6;
                   rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
                     rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H6;
-                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; 
+                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6;
                         assumption.
   cut (IZR (up (/ eps - 1)) = IZR (Z_of_nat x));
     [ intro | rewrite H1; trivial ].
@@ -92,8 +92,8 @@ Proof.
       rewrite
         (Rinv_l eps
           (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
-        ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); 
-          intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; 
+        ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1);
+          intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus;
             unfold Rgt in |- *; assumption.
   right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto.
   elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index 139563bf..5b731488 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -131,7 +131,7 @@ Proof.
   apply SFL_continuity; assumption.
   unfold continuity in |- *; unfold continuity_pt in |- *;
     unfold continue_in in |- *; unfold limit1_in in |- *;
-      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
         intros.
   elim (H1 x _ H2); intros.
   exists x0; intros.
@@ -172,7 +172,7 @@ Proof.
   unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0;
     unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
       unfold continuity_pt in |- *; unfold continue_in in |- *;
-        unfold limit1_in in |- *; unfold limit_in in |- *; 
+        unfold limit1_in in |- *; unfold limit_in in |- *;
           simpl in |- *; unfold R_dist in |- *; intros.
   elim (H0 _ H); intros.
   exists x0; intros.
@@ -186,7 +186,7 @@ Proof.
   trivial.
   red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8;
     rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1);
-      apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); 
+      apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2);
         apply H7.
   replace (PI / 2 - x1 - (PI / 2 - x)) with (x - x1); [ idtac | ring ];
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H6.
@@ -420,7 +420,7 @@ Proof.
   elim H9; intros; assumption.
   cut (Rabs (h / 2) < del).
   intro; cut (h / 2 <> 0).
-  intro; assert (H11 := H2 _ H10 H9). 
+  intro; assert (H11 := H2 _ H10 H9).
   rewrite Rplus_0_l in H11; rewrite sin_0 in H11.
   rewrite Rminus_0_r in H11; apply H11.
   unfold Rdiv in |- *; apply prod_neq_R0.
@@ -436,7 +436,7 @@ Proof.
   unfold delta in |- *; simpl in |- *; apply Rmin_l.
   apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
   rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *;
-    rewrite (double_var del); apply Rplus_lt_compat_l; 
+    rewrite (double_var del); apply Rplus_lt_compat_l;
       unfold Rdiv in |- *; apply Rmult_lt_0_compat.
   apply (cond_pos del).
   apply Rinv_0_lt_compat; prove_sup0.
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
index 56088a2e..a84a1cc9 100644
--- a/theories/Reals/SeqProp.v
+++ b/theories/Reals/SeqProp.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SeqProp.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
index 9680b75e..dbfc85bb 100644
--- a/theories/Reals/SeqSeries.v
+++ b/theories/Reals/SeqSeries.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SeqSeries.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -25,7 +25,7 @@ Open Local Scope R_scope.
 
 (**********)
 Lemma sum_maj1 :
-  forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) 
+  forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R)
     (N:nat),
     Un_cv (fun n:nat => SP fn n x) l1 ->
     Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
@@ -92,7 +92,7 @@ Proof.
     (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
       (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
     (sum_f_R0 (fun k:nat => fn k x) N +
-      sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
+      sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1);
     [ idtac | ring ].
   replace
   (sum_f_R0 (fun k:nat => fn k x) N +
@@ -170,7 +170,7 @@ Proof.
   (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
     (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
   (sum_f_R0 (fun k:nat => fn k x) N +
-    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
+    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1);
   [ idtac | ring ].
   replace
   (sum_f_R0 (fun k:nat => fn k x) N +
@@ -241,13 +241,13 @@ Proof.
   apply Rle_ge; apply cond_pos_sum; intro.
   elim (H (S n + n0)%nat); intros; assumption.
   rewrite b; unfold R_dist in |- *; unfold Rminus in |- *;
-    do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; 
+    do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right;
       reflexivity.
   rewrite (tech2 An m n); [ idtac | assumption ].
   rewrite (tech2 Bn m n); [ idtac | assumption ].
   unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc;
     rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
-      do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; 
+      do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l;
         do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
   apply sum_Rle; intros.
   elim (H (S m + n0)%nat); intros; apply H8.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
index 08dbd67b..5882f953 100644
--- a/theories/Reals/SplitAbsolu.v
+++ b/theories/Reals/SplitAbsolu.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i      $Id: SplitAbsolu.v 9245 2006-10-17 12:53:34Z notin $       i*)
+(*i      $Id$       i*)
 
 Require Import Rbasic_fun.
 
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
index 4f3fab24..51e54860 100644
--- a/theories/Reals/SplitRmult.v
+++ b/theories/Reals/SplitRmult.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SplitRmult.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
 
diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
index 13be46da..4f336648 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sqrt_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
-Require Import R_sqrt. 
+Require Import R_sqrt.
 Open Local Scope R_scope.
 
 (**********)
@@ -104,8 +104,8 @@ Qed.
 Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1.
 Proof.
   unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
         intros.
   set (alpha := Rmin eps 1).
   exists alpha; intros.
@@ -129,8 +129,8 @@ Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x.
 Proof.
   intros; generalize sqrt_continuity_pt_R1.
   unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
-      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
+      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
         intros.
   cut (0 < eps / sqrt x).
   intro; elim (H0 _ H2); intros alp_1 H3.
@@ -153,7 +153,7 @@ Proof.
   unfold Rdiv in H5.
   case (Req_dec x x0); intro.
   rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r;
-    rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; 
+    rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r;
       rewrite Rabs_R0.
   apply Rmult_lt_0_compat.
   assumption.
@@ -238,7 +238,7 @@ Proof.
   intro; cut (g 0 <> 0).
   intro; assert (H2 := continuity_pt_inv g 0 H0 H1).
   unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2;
-    unfold continue_in in H2; unfold limit1_in in H2; 
+    unfold continue_in in H2; unfold limit1_in in H2;
       unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
   elim (H2 eps H3); intros alpha H4.
   elim H4; intros.
@@ -333,7 +333,7 @@ Proof.
   apply (sqrt_continuity_pt x H0).
   elim H0; intro.
   unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *; 
+    unfold limit1_in in |- *; unfold limit_in in |- *;
       simpl in |- *; unfold R_dist in |- *; intros.
   exists (Rsqr eps); intros.
   split.
diff --git a/theories/Reals/vo.itarget b/theories/Reals/vo.itarget
new file mode 100644
index 00000000..bcd47a0b
--- /dev/null
+++ b/theories/Reals/vo.itarget
@@ -0,0 +1,58 @@
+Alembert.vo
+AltSeries.vo
+ArithProp.vo
+Binomial.vo
+Cauchy_prod.vo
+Cos_plus.vo
+Cos_rel.vo
+DiscrR.vo
+Exp_prop.vo
+Integration.vo
+LegacyRfield.vo
+MVT.vo
+NewtonInt.vo
+PartSum.vo
+PSeries_reg.vo
+Ranalysis1.vo
+Ranalysis2.vo
+Ranalysis3.vo
+Ranalysis4.vo
+Ranalysis.vo
+Raxioms.vo
+Rbase.vo
+Rbasic_fun.vo
+Rcomplete.vo
+Rdefinitions.vo
+Rderiv.vo
+Reals.vo
+Rfunctions.vo
+Rgeom.vo
+RiemannInt_SF.vo
+RiemannInt.vo
+R_Ifp.vo
+RIneq.vo
+Rlimit.vo
+RList.vo
+Rlogic.vo
+Rpow_def.vo
+Rpower.vo
+Rprod.vo
+Rseries.vo
+Rsigma.vo
+Rsqrt_def.vo
+R_sqrt.vo
+R_sqr.vo
+Rtopology.vo
+Rtrigo_alt.vo
+Rtrigo_calc.vo
+Rtrigo_def.vo
+Rtrigo_fun.vo
+Rtrigo_reg.vo
+Rtrigo.vo
+SeqProp.vo
+SeqSeries.vo
+SplitAbsolu.vo
+SplitRmult.vo
+Sqrt_reg.vo
+ROrderedType.vo
+Rminmax.vo
diff --git a/theories/Relations/Newman.v b/theories/Relations/Newman.v
deleted file mode 100644
index e7bb66eb..00000000
--- a/theories/Relations/Newman.v
+++ /dev/null
@@ -1,121 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: Newman.v 9245 2006-10-17 12:53:34Z notin $ i*)
-
-Require Import Rstar.
-
-Section Newman.
-
-Variable A : Type. 
-Variable R : A -> A -> Prop.
-
-Let Rstar := Rstar A R. 
-Let Rstar_reflexive := Rstar_reflexive A R.
-Let Rstar_transitive := Rstar_transitive A R.
-Let Rstar_Rstar' := Rstar_Rstar' A R.
-
-Definition coherence (x y:A) := ex2 (Rstar x) (Rstar y).
-
-Theorem coherence_intro :
-  forall x y z:A, Rstar x z -> Rstar y z -> coherence x y.
-Proof fun (x y z:A) (h1:Rstar x z) (h2:Rstar y z) =>
-  ex_intro2 (Rstar x) (Rstar y) z h1 h2.
-  
-(** A very simple case of coherence : *)
-
-Lemma Rstar_coherence : forall x y:A, Rstar x y -> coherence x y.
-Proof
-  fun (x y:A) (h:Rstar x y) => coherence_intro x y y h (Rstar_reflexive y).  
-  
-(** coherence is symmetric *)
-Lemma coherence_sym : forall x y:A, coherence x y -> coherence y x.
-Proof
-  fun (x y:A) (h:coherence x y) =>
-    ex2_ind
-      (fun (w:A) (h1:Rstar x w) (h2:Rstar y w) =>
-        coherence_intro y x w h2 h1) h.
-
-Definition confluence (x:A) :=
-  forall y z:A, Rstar x y -> Rstar x z -> coherence y z.  
-  
-Definition local_confluence (x:A) :=
-  forall y z:A, R x y -> R x z -> coherence y z.  
-  
-Definition noetherian :=
-  forall (x:A) (P:A -> Prop),
-    (forall y:A, (forall z:A, R y z -> P z) -> P y) -> P x.  
-  
-Section Newman_section.
-
-  (** The general hypotheses of the theorem *)
-
-  Hypothesis Hyp1 : noetherian.
-  Hypothesis Hyp2 : forall x:A, local_confluence x.  
-  
-  (** The induction hypothesis *)
-
-  Section Induct.
-    Variable x : A.
-    Hypothesis hyp_ind : forall u:A, R x u -> confluence u.  
-  
-    (** Confluence in [x] *)
-
-    Variables y z : A.  
-    Hypothesis h1 : Rstar x y.  
-    Hypothesis h2 : Rstar x z.  
-  
-    (** particular case [x->u] and [u->*y]   *)
-    Section Newman_.
-      Variable u : A.  
-      Hypothesis t1 : R x u.  
-      Hypothesis t2 : Rstar u y.  
-      
-      (** In the usual diagram, we assume also [x->v] and [v->*z] *)
-      
-      Theorem Diagram : forall (v:A) (u1:R x v) (u2:Rstar v z), coherence y z.
-      Proof
-       (* We draw the diagram ! *)
-      fun (v:A) (u1:R x v) (u2:Rstar v z) =>
-	ex2_ind
-	 (* local confluence in x for u,v *)
-	 (* gives w, u->*w and v->*w *)
-	(fun (w:A) (s1:Rstar u w) (s2:Rstar v w) =>
-          ex2_ind
-              (* confluence in u => coherence(y,w) *)
-              (* gives a, y->*a and z->*a *)
-          (fun (a:A) (v1:Rstar y a) (v2:Rstar w a) =>
-            ex2_ind
-              (* confluence in v => coherence(a,z) *)
-              (* gives b, a->*b and z->*b *)
-            (fun (b:A) (w1:Rstar a b) (w2:Rstar z b) =>
-              coherence_intro y z b (Rstar_transitive y a b v1 w1) w2)
-            (hyp_ind v u1 a z (Rstar_transitive v w a s2 v2) u2))
-          (hyp_ind u t1 y w t2 s1)) (Hyp2 x u v t1 u1).
-  
-      Theorem caseRxy : coherence y z.
-      Proof
-        Rstar_Rstar' x z h2 (fun v w:A => coherence y w)
-	(coherence_sym x y (Rstar_coherence x y h1)) (*i case x=z i*)
-	Diagram.                                     (*i case x->v->*z i*)
-    End Newman_.
-
-    Theorem Ind_proof : coherence y z.
-    Proof
-      Rstar_Rstar' x y h1 (fun u v:A => coherence v z)
-      (Rstar_coherence x z h2) (*i case x=y i*)
-      caseRxy.                                   (*i case x->u->*z i*)
-  End Induct.
-
-  Theorem Newman : forall x:A, confluence x.
-  Proof fun x:A => Hyp1 x confluence Ind_proof.  
-
-End Newman_section.
-
-
-End Newman.
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index d0916b09..1976b435 100644
--- a/theories/Relations/Operators_Properties.v
+++ b/theories/Relations/Operators_Properties.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Operators_Properties.v 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (************************************************************************)
 (** * Some properties of the operators on relations                     *)
@@ -16,31 +16,41 @@
 
 Require Import Relation_Definitions.
 Require Import Relation_Operators.
-Require Import Setoid.
 
 Section Properties.
 
+  Implicit Arguments clos_refl_trans [A].
+  Implicit Arguments clos_refl_trans_1n [A].
+  Implicit Arguments clos_refl_trans_n1 [A].
+  Implicit Arguments clos_refl_sym_trans [A].
+  Implicit Arguments clos_refl_sym_trans_1n [A].
+  Implicit Arguments clos_refl_sym_trans_n1 [A].
+  Implicit Arguments clos_trans [A].
+  Implicit Arguments clos_trans_1n [A].
+  Implicit Arguments clos_trans_n1 [A].
+  Implicit Arguments inclusion [A].
+  Implicit Arguments preorder [A].
+
   Variable A : Type.
   Variable R : relation A.
 
-  Let incl (R1 R2:relation A) : Prop := forall x y:A, R1 x y -> R2 x y.
-  
   Section Clos_Refl_Trans.
 
+    Local Notation "R *" := (clos_refl_trans R) (at level 8, left associativity).
+
     (** Correctness of the reflexive-transitive closure operator *)
 
-    Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R).
+    Lemma clos_rt_is_preorder : preorder R*.
     Proof.
       apply Build_preorder.
       exact (rt_refl A R).
-      
+
       exact (rt_trans A R).
     Qed.
 
     (** Idempotency of the reflexive-transitive closure operator *)
 
-    Lemma clos_rt_idempotent :
-      incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R).
+    Lemma clos_rt_idempotent : inclusion (R*)* R*.
     Proof.
       red in |- *.
       induction 1; auto with sets.
@@ -56,7 +66,7 @@ Section Properties.
         reflexive-symmetric-transitive closure *)
 
     Lemma clos_rt_clos_rst :
-      inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R).
+      inclusion (clos_refl_trans R) (clos_refl_sym_trans R).
     Proof.
       red in |- *.
       induction 1; auto with sets.
@@ -65,7 +75,7 @@ Section Properties.
 
     (** Correctness of the reflexive-symmetric-transitive closure *)
 
-    Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R).
+    Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R).
     Proof.
       apply Build_equivalence.
       exact (rst_refl A R).
@@ -76,8 +86,8 @@ Section Properties.
     (** Idempotency of the reflexive-symmetric-transitive closure operator *)
 
     Lemma clos_rst_idempotent :
-      incl (clos_refl_sym_trans A (clos_refl_sym_trans A R))
-      (clos_refl_sym_trans A R).
+      inclusion (clos_refl_sym_trans (clos_refl_sym_trans R))
+      (clos_refl_sym_trans R).
     Proof.
       red in |- *.
       induction 1; auto with sets.
@@ -91,11 +101,11 @@ Section Properties.
   (** *** Equivalences between the different definition of the reflexive,
       symmetric, transitive closures *)
 
-  (** *** Contributed by P. Casteran *)
+  (** *** Contributed by P. Castéran *)
 
     (** Direct transitive closure vs left-step extension *)
 
-    Lemma t1n_trans : forall x y, clos_trans_1n A R x y -> clos_trans A R x y.
+    Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y.
     Proof.
      induction 1.
      left; assumption.
@@ -103,7 +113,7 @@ Section Properties.
      left; auto.
     Qed.
 
-    Lemma trans_t1n : forall x y, clos_trans A R x y -> clos_trans_1n A R x y.
+    Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y.
     Proof.
       induction 1.
       left; assumption.
@@ -111,20 +121,20 @@ Section Properties.
       right with y; auto.
       right with y; auto.
       eapply IHIHclos_trans1; auto.
-      apply t1n_trans; auto.
+      apply clos_t1n_trans; auto.
     Qed.
 
-    Lemma t1n_trans_equiv : forall x y, 
-        clos_trans A R x y <-> clos_trans_1n A R x y.
+    Lemma clos_trans_t1n_iff : forall x y,
+        clos_trans R x y <-> clos_trans_1n R x y.
     Proof.
       split.
-      apply trans_t1n.
-      apply t1n_trans.
+      apply clos_trans_t1n.
+      apply clos_t1n_trans.
     Qed.
 
     (** Direct transitive closure vs right-step extension *)
 
-    Lemma tn1_trans : forall x y, clos_trans_n1 A R x y -> clos_trans A R x y.
+    Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y.
     Proof.
       induction 1.
       left; assumption.
@@ -132,7 +142,7 @@ Section Properties.
       left; assumption.
     Qed.
 
-    Lemma trans_tn1 :  forall x y, clos_trans A R x y -> clos_trans_n1 A R x y.
+    Lemma clos_trans_tn1 :  forall x y, clos_trans R x y -> clos_trans_n1 R x y.
     Proof.
       induction 1.
       left; assumption.
@@ -144,31 +154,31 @@ Section Properties.
       right with y0; auto.
     Qed.
 
-    Lemma tn1_trans_equiv : forall x y, 
-        clos_trans A R x y <-> clos_trans_n1 A R x y.
+    Lemma clos_trans_tn1_iff : forall x y,
+        clos_trans R x y <-> clos_trans_n1 R x y.
     Proof.
       split.
-      apply trans_tn1.
-      apply tn1_trans.
+      apply clos_trans_tn1.
+      apply clos_tn1_trans.
     Qed.
 
-    (** Direct reflexive-transitive closure is equivalent to 
+    (** Direct reflexive-transitive closure is equivalent to
         transitivity by left-step extension *)
 
-    Lemma R_rt1n : forall x y, R x y -> clos_refl_trans_1n A R x y.
+    Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y.
     Proof.
       intros x y H.
       right with y;[assumption|left].
     Qed.
 
-    Lemma R_rtn1 : forall x y, R x y -> clos_refl_trans_n1 A R x y.
+    Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y.
     Proof.
       intros x y H.
       right with x;[assumption|left].
     Qed.
 
-    Lemma rt1n_trans : forall x y, 
-        clos_refl_trans_1n A R x y -> clos_refl_trans A R x y.
+    Lemma clos_rt1n_rt : forall x y,
+        clos_refl_trans_1n R x y -> clos_refl_trans R x y.
     Proof.
       induction 1.
       constructor 2.
@@ -176,33 +186,33 @@ Section Properties.
       constructor 1; auto.
     Qed.
 
-    Lemma trans_rt1n : forall x y, 
-        clos_refl_trans A R x y -> clos_refl_trans_1n A R x y.
+    Lemma clos_rt_rt1n : forall x y,
+        clos_refl_trans R x y -> clos_refl_trans_1n R x y.
     Proof.
       induction 1.
-      apply R_rt1n; assumption.
+      apply clos_rt1n_step; assumption.
       left.
       generalize IHclos_refl_trans2; clear IHclos_refl_trans2;
         induction IHclos_refl_trans1; auto.
 
       right with y; auto.
       eapply IHIHclos_refl_trans1; auto.
-      apply rt1n_trans; auto.
+      apply clos_rt1n_rt; auto.
     Qed.
 
-    Lemma rt1n_trans_equiv : forall x y, 
-      clos_refl_trans A R x y <-> clos_refl_trans_1n A R x y.
+    Lemma clos_rt_rt1n_iff : forall x y,
+      clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
     Proof.
       split.
-      apply trans_rt1n.
-      apply rt1n_trans.
+      apply clos_rt_rt1n.
+      apply clos_rt1n_rt.
     Qed.
 
-    (** Direct reflexive-transitive closure is equivalent to 
+    (** Direct reflexive-transitive closure is equivalent to
         transitivity by right-step extension *)
 
-    Lemma rtn1_trans : forall x y,
-        clos_refl_trans_n1 A R x y -> clos_refl_trans A R x y.
+    Lemma clos_rtn1_rt : forall x y,
+        clos_refl_trans_n1 R x y -> clos_refl_trans R x y.
     Proof.
       induction 1.
       constructor 2.
@@ -210,37 +220,37 @@ Section Properties.
       constructor 1; assumption.
     Qed.
 
-    Lemma trans_rtn1 :  forall x y, 
-        clos_refl_trans A R x y -> clos_refl_trans_n1 A R x y.
+    Lemma clos_rt_rtn1 :  forall x y,
+        clos_refl_trans R x y -> clos_refl_trans_n1 R x y.
     Proof.
       induction 1.
-      apply R_rtn1; auto.
+      apply clos_rtn1_step; auto.
       left.
       elim IHclos_refl_trans2; auto.
       intros.
       right with y0; auto.
     Qed.
 
-    Lemma rtn1_trans_equiv : forall x y, 
-        clos_refl_trans A R x y <-> clos_refl_trans_n1 A R x y.
+    Lemma clos_rt_rtn1_iff : forall x y,
+        clos_refl_trans R x y <-> clos_refl_trans_n1 R x y.
     Proof.
       split.
-      apply trans_rtn1.
-      apply rtn1_trans.
+      apply clos_rt_rtn1.
+      apply clos_rtn1_rt.
     Qed.
 
     (** Induction on the left transitive step *)
 
     Lemma clos_refl_trans_ind_left :
       forall (x:A) (P:A -> Prop), P x ->
-	(forall y z:A, clos_refl_trans A R x y -> P y -> R y z -> P z) ->
-	forall z:A, clos_refl_trans A R x z -> P z.
+	(forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) ->
+	forall z:A, clos_refl_trans R x z -> P z.
     Proof.
       intros.
       revert H H0.
       induction H1; intros; auto with sets.
       apply H1 with x; auto with sets.
-      
+
       apply IHclos_refl_trans2.
       apply IHclos_refl_trans1; auto with sets.
 
@@ -253,28 +263,30 @@ Section Properties.
 
     Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A),
       P z ->
-      (forall x y, R x y -> clos_refl_trans_1n A R y z -> P y -> P x) ->
-      forall x, clos_refl_trans_1n A R x z -> P x.
+      (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) ->
+      forall x, clos_refl_trans_1n R x z -> P x.
       induction 3; auto.
       apply H0 with y; auto.
     Qed.
 
     Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A),
       P z ->
-      (forall x y, R x y -> P y -> clos_refl_trans A R y z -> P x) ->
-      forall x, clos_refl_trans A R x z -> P x.
-      intros.
-      rewrite rt1n_trans_equiv in H1.
-      elim H1 using rt1n_ind_right; auto.
-      intros; rewrite  <- rt1n_trans_equiv in *.
+      (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) ->
+      forall x, clos_refl_trans R x z -> P x.
+      intros P z Hz IH x Hxz.
+      apply clos_rt_rt1n_iff in Hxz.
+      elim Hxz using rt1n_ind_right; auto.
+      clear x Hxz.
+      intros x y Hxy Hyz Hy.
+      apply clos_rt_rt1n_iff in Hyz.
       eauto.
     Qed.
 
-    (** Direct reflexive-symmetric-transitive closure is equivalent to 
+    (** Direct reflexive-symmetric-transitive closure is equivalent to
         transitivity by symmetric left-step extension *)
 
-    Lemma rts1n_rts  : forall x y, 
-      clos_refl_sym_trans_1n A R x y -> clos_refl_sym_trans A R x y.
+    Lemma clos_rst1n_rst  : forall x y,
+      clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y.
     Proof.
       induction 1.
       constructor 2.
@@ -282,48 +294,47 @@ Section Properties.
       case H;[constructor 1|constructor 3; constructor 1]; auto.
     Qed.
 
-    Lemma rts_1n_trans : forall x y, clos_refl_sym_trans_1n A R x y ->
-      forall z, clos_refl_sym_trans_1n A R y z -> 
-        clos_refl_sym_trans_1n A R x z.
+    Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y ->
+        clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z.
       induction 1.
       auto.
       intros; right with y; eauto.
     Qed.
 
-    Lemma rts1n_sym : forall x y, clos_refl_sym_trans_1n A R x y ->
-      clos_refl_sym_trans_1n A R y x.
+    Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y ->
+      clos_refl_sym_trans_1n R y x.
     Proof.
       intros x y H; elim H.
       constructor 1.
-      intros x0 y0 z D H0 H1; apply rts_1n_trans with y0; auto.
+      intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto.
       right with x0.
       tauto.
       left.
     Qed.
 
-    Lemma rts_rts1n  : forall x y, 
-      clos_refl_sym_trans A R x y -> clos_refl_sym_trans_1n A R x y.
+    Lemma clos_rst_rst1n  : forall x y,
+      clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y.
       induction 1.
       constructor 2 with y; auto.
       constructor 1.
       constructor 1.
-      apply rts1n_sym; auto.
-      eapply rts_1n_trans; eauto.
+      apply clos_rst1n_sym; auto.
+      eapply clos_rst1n_trans; eauto.
     Qed.
 
-    Lemma rts_rts1n_equiv : forall x y, 
-      clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_1n A R x y.
+    Lemma clos_rst_rst1n_iff : forall x y,
+      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y.
     Proof.
       split.
-      apply rts_rts1n.
-      apply rts1n_rts.
+      apply clos_rst_rst1n.
+      apply clos_rst1n_rst.
     Qed.
 
-    (** Direct reflexive-symmetric-transitive closure is equivalent to 
+    (** Direct reflexive-symmetric-transitive closure is equivalent to
         transitivity by symmetric right-step extension *)
 
-    Lemma rtsn1_rts : forall x y, 
-      clos_refl_sym_trans_n1 A R x y -> clos_refl_sym_trans A R x y.
+    Lemma clos_rstn1_rst : forall x y,
+      clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y.
     Proof.
       induction 1.
       constructor 2.
@@ -331,46 +342,79 @@ Section Properties.
       case H;[constructor 1|constructor 3; constructor 1]; auto.
     Qed.
 
-    Lemma rtsn1_trans : forall y z, clos_refl_sym_trans_n1 A R y z->
-      forall x, clos_refl_sym_trans_n1 A R x y -> 
-        clos_refl_sym_trans_n1 A R x z.
+    Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y ->
+      clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z.
     Proof.
-      induction 1.
+      intros x y z H1 H2.
+      induction H2.
       auto.
       intros.
       right with y0; eauto.
     Qed.
 
-    Lemma rtsn1_sym : forall x y, clos_refl_sym_trans_n1 A R x y ->
-      clos_refl_sym_trans_n1 A R y x.
+    Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y ->
+      clos_refl_sym_trans_n1 R y x.
     Proof.
       intros x y H; elim H.
       constructor 1.
-      intros y0 z D H0 H1. apply rtsn1_trans with y0; auto.
+      intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto.
       right with z.
       tauto.
       left.
     Qed.
 
-    Lemma rts_rtsn1 : forall x y, 
-      clos_refl_sym_trans A R x y -> clos_refl_sym_trans_n1 A R x y.
+    Lemma clos_rst_rstn1 : forall x y,
+      clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y.
     Proof.
       induction 1.
       constructor 2 with x; auto.
       constructor 1.
       constructor 1.
-      apply rtsn1_sym; auto.
-      eapply rtsn1_trans; eauto.
+      apply clos_rstn1_sym; auto.
+      eapply clos_rstn1_trans; eauto.
     Qed.
 
-    Lemma rts_rtsn1_equiv : forall x y, 
-      clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_n1 A R x y.
+    Lemma clos_rst_rstn1_iff : forall x y,
+      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y.
     Proof.
       split.
-      apply rts_rtsn1.
-      apply rtsn1_rts.
+      apply clos_rst_rstn1.
+      apply clos_rstn1_rst.
     Qed.
 
   End Equivalences.
 
 End Properties.
+
+(* begin hide *)
+(* Compatibility *)
+Notation trans_tn1 := clos_trans_tn1 (only parsing).
+Notation tn1_trans := clos_tn1_trans (only parsing).
+Notation tn1_trans_equiv := clos_trans_tn1_iff (only parsing).
+
+Notation trans_t1n := clos_trans_t1n (only parsing).
+Notation t1n_trans := clos_t1n_trans (only parsing).
+Notation t1n_trans_equiv := clos_trans_t1n_iff (only parsing).
+
+Notation R_rtn1 := clos_rtn1_step (only parsing).
+Notation trans_rt1n := clos_rt_rt1n (only parsing).
+Notation rt1n_trans := clos_rt1n_rt (only parsing).
+Notation rt1n_trans_equiv := clos_rt_rt1n_iff (only parsing).
+
+Notation R_rt1n := clos_rt1n_step (only parsing).
+Notation trans_rtn1 := clos_rt_rtn1 (only parsing).
+Notation rtn1_trans := clos_rtn1_rt (only parsing).
+Notation rtn1_trans_equiv := clos_rt_rtn1_iff (only parsing).
+
+Notation rts1n_rts := clos_rst1n_rst (only parsing).
+Notation rts_1n_trans := clos_rst1n_trans (only parsing).
+Notation rts1n_sym := clos_rst1n_sym (only parsing).
+Notation rts_rts1n := clos_rst_rst1n (only parsing).
+Notation rts_rts1n_equiv := clos_rst_rst1n_iff (only parsing).
+
+Notation rtsn1_rts := clos_rstn1_rst (only parsing).
+Notation rtsn1_trans := clos_rstn1_trans (only parsing).
+Notation rtsn1_sym := clos_rstn1_sym (only parsing).
+Notation rts_rtsn1 := clos_rst_rstn1 (only parsing).
+Notation rts_rtsn1_equiv := clos_rst_rstn1_iff (only parsing).
+(* end hide *)
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index 762da1ff..c03c4b95 100644
--- a/theories/Relations/Relation_Definitions.v
+++ b/theories/Relations/Relation_Definitions.v
@@ -6,19 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relation_Definitions.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Section Relation_Definition.
 
   Variable A : Type.
-  
+
   Definition relation := A -> A -> Prop.
 
   Variable R : relation.
-   
+
 
   Section General_Properties_of_Relations.
-    
+
     Definition reflexive : Prop := forall x:A, R x x.
     Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z.
     Definition symmetric : Prop := forall x y:A, R x y -> R y x.
@@ -32,33 +32,33 @@ Section Relation_Definition.
 
 
   Section Sets_of_Relations.
-    
-    Record preorder : Prop := 
+
+    Record preorder : Prop :=
       { preord_refl : reflexive; preord_trans : transitive}.
-    
-    Record order : Prop := 
+
+    Record order : Prop :=
       { ord_refl : reflexive;
 	ord_trans : transitive;
 	ord_antisym : antisymmetric}.
-    
-    Record equivalence : Prop := 
+
+    Record equivalence : Prop :=
       { equiv_refl : reflexive;
 	equiv_trans : transitive;
 	equiv_sym : symmetric}.
-    
+
     Record PER : Prop :=  {per_sym : symmetric; per_trans : transitive}.
 
   End Sets_of_Relations.
 
 
   Section Relations_of_Relations.
-    
+
     Definition inclusion (R1 R2:relation) : Prop :=
       forall x y:A, R1 x y -> R2 x y.
-    
+
     Definition same_relation (R1 R2:relation) : Prop :=
       inclusion R1 R2 /\ inclusion R2 R1.
-    
+
     Definition commut (R1 R2:relation) : Prop :=
       forall x y:A,
 	R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
index 027a9e6c..39e0331d 100644
--- a/theories/Relations/Relation_Operators.v
+++ b/theories/Relations/Relation_Operators.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relation_Operators.v 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (************************************************************************)
 (** *                   Bruno Barras, Cristina Cornes                   *)
@@ -17,7 +17,6 @@
 (************************************************************************)
 
 Require Import Relation_Definitions.
-Require Import List.
 
 (** * Some operators to build relations *)
 
@@ -65,7 +64,7 @@ Section Reflexive_Transitive_Closure.
 
   Inductive clos_refl_trans_1n (x: A) : A -> Prop :=
     | rt1n_refl : clos_refl_trans_1n x x
-    | rt1n_trans (y z:A) : 
+    | rt1n_trans (y z:A) :
          R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z.
 
   (** Alternative definition by transitive extension on the right *)
@@ -79,10 +78,10 @@ End Reflexive_Transitive_Closure.
 
 (** ** Reflexive-symmetric-transitive closure *)
 
-Section Reflexive_Symetric_Transitive_Closure.
+Section Reflexive_Symmetric_Transitive_Closure.
   Variable A : Type.
   Variable R : relation A.
-  
+
   (** Definition by direct reflexive-symmetric-transitive closure *)
 
   Inductive clos_refl_sym_trans : relation A :=
@@ -96,18 +95,18 @@ Section Reflexive_Symetric_Transitive_Closure.
   (** Alternative definition by symmetric-transitive extension on the left *)
 
   Inductive clos_refl_sym_trans_1n (x: A) : A -> Prop :=
-    | rts1n_refl : clos_refl_sym_trans_1n x x
-    | rts1n_trans (y z:A) : R x y \/ R y x ->
+    | rst1n_refl : clos_refl_sym_trans_1n x x
+    | rst1n_trans (y z:A) : R x y \/ R y x ->
          clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z.
 
   (** Alternative definition by symmetric-transitive extension on the right *)
 
   Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop :=
-    | rtsn1_refl : clos_refl_sym_trans_n1 x x
-    | rtsn1_trans (y z:A) : R y z \/ R z y -> 
+    | rstn1_refl : clos_refl_sym_trans_n1 x x
+    | rstn1_trans (y z:A) : R y z \/ R z y ->
          clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z.
 
-End Reflexive_Symetric_Transitive_Closure.
+End Reflexive_Symmetric_Transitive_Closure.
 
 (** ** Converse of a relation *)
 
@@ -139,7 +138,7 @@ Inductive le_AsB : A + B -> A + B -> Prop :=
   | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y)
   | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y).
 
-End Disjoint_Union. 
+End Disjoint_Union.
 
 (** ** Lexicographic order on dependent pairs *)
 
@@ -187,14 +186,15 @@ Section Swap.
     | sp_swap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (y, x) p.
 End Swap.
 
+Local Open Scope list_scope.
 
 Section Lexicographic_Exponentiation.
-  
+
   Variable A : Set.
   Variable leA : A -> A -> Prop.
   Let Nil := nil (A:=A).
   Let List := list A.
-  
+
   Inductive Ltl : List -> List -> Prop :=
     | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x)
     | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y)
@@ -207,7 +207,7 @@ Section Lexicographic_Exponentiation.
         leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).
 
   Definition Pow : Set := sig Desc.
-  
+
   Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b).
 
 End Lexicographic_Exponentiation.
@@ -215,3 +215,11 @@ 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.
+
+(* begin hide *)
+(* Compatibility *)
+Notation rts1n_refl := rst1n_refl (only parsing).
+Notation rts1n_trans := rst1n_trans (only parsing).
+Notation rtsn1_refl := rstn1_refl (only parsing).
+Notation rtsn1_trans := rstn1_trans (only parsing).
+(* end hide *)
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
index 6368ae25..1c6df08a 100644
--- a/theories/Relations/Relations.v
+++ b/theories/Relations/Relations.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relations.v 9598 2007-02-06 19:45:52Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Relation_Definitions.
 Require Export Relation_Operators.
diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v
deleted file mode 100644
index 82668006..00000000
--- a/theories/Relations/Rstar.v
+++ /dev/null
@@ -1,94 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: Rstar.v 9642 2007-02-12 10:31:53Z herbelin $ i*)
-
-(** Properties of a binary relation [R] on type [A] *)
-
-Section Rstar.
-  
-  Variable A : Type.  
-  Variable R : A -> A -> Prop.  
-
-  (** Definition of the reflexive-transitive closure [R*] of [R] *)
-  (** Smallest reflexive [P] containing [R o P] *)
-
-  Definition Rstar (x y:A) :=
-    forall P:A -> A -> Prop,
-      (forall u:A, P u u) -> (forall u v w:A, R u v -> P v w -> P u w) -> P x y.  
-  
-  Theorem Rstar_reflexive : forall x:A, Rstar x x.
-  Proof.
-    unfold Rstar. intros x P P_refl RoP. apply P_refl.
-  Qed.
-
-  Theorem Rstar_R : forall x y z:A, R x y -> Rstar y z -> Rstar x z.
-  Proof.
-    intros x y z R_xy Rstar_yz.
-    unfold Rstar.
-    intros P P_refl RoP. apply RoP with (v:=y).
-      assumption.
-      apply Rstar_yz; assumption.
-  Qed.
-
-  (** We conclude with transitivity of [Rstar] : *)
-
-  Theorem Rstar_transitive :
-    forall x y z:A, Rstar x y -> Rstar y z -> Rstar x z.
-  Proof.
-    intros x y z Rstar_xy; unfold Rstar in Rstar_xy.
-    apply Rstar_xy; trivial.
-    intros u v w R_uv fz Rstar_wz.
-    apply Rstar_R with (y:=v); auto.
-  Qed.
-
-  (** Another characterization of [R*] *)
-  (** Smallest reflexive [P] containing [R o R*] *)
-
-  Definition Rstar' (x y:A) :=
-    forall P:A -> A -> Prop,
-      P x x -> (forall u:A, R x u -> Rstar u y -> P x y) -> P x y.  
-
-  Theorem Rstar'_reflexive : forall x:A, Rstar' x x.
-  Proof.
-    unfold Rstar'; intros; assumption.
-  Qed.
-  
-  Theorem Rstar'_R : forall x y z:A, R x z -> Rstar z y -> Rstar' x y.
-  Proof.
-    unfold Rstar'. intros x y z Rxz Rstar_zy P Pxx RoP.
-    apply RoP with (u:=z); trivial.
-  Qed.
-  
-  (** Equivalence of the two definitions: *)
-
-  Theorem Rstar'_Rstar : forall x y:A, Rstar' x y -> Rstar x y.
-  Proof.
-    intros x z Rstar'_xz; unfold Rstar' in Rstar'_xz.
-    apply Rstar'_xz.
-      exact (Rstar_reflexive x).
-      intro y; generalize x y z; exact Rstar_R.
-  Qed.
-  
-  Theorem Rstar_Rstar' : forall x y:A, Rstar x y -> Rstar' x y.
-  Proof.
-    intros.
-    apply H.
-      exact Rstar'_reflexive.
-      intros u v  w R_uv Rs'_vw. apply Rstar'_R with (z:=v).
-        assumption.
-        apply Rstar'_Rstar; assumption.
-  Qed.
-
-  (** Property of Commutativity of two relations *)
-  
-  Definition commut (A:Type) (R1 R2:A -> A -> Prop) :=
-    forall x y:A,
-      R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
-
-End Rstar.
diff --git a/theories/Relations/vo.itarget b/theories/Relations/vo.itarget
new file mode 100644
index 00000000..9d81dd07
--- /dev/null
+++ b/theories/Relations/vo.itarget
@@ -0,0 +1,4 @@
+Operators_Properties.vo
+Relation_Definitions.vo
+Relation_Operators.vo
+Relations.vo
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index a187a7c6..db4d699f 100644
--- a/theories/Setoids/Setoid.v
+++ b/theories/Setoids/Setoid.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Setoid.v 12187 2009-06-13 19:36:59Z msozeau $: i*)
+(*i $Id$: i*)
 
 Require Export Coq.Classes.SetoidTactics.
 
-Export Morphisms.MorphismNotations.
+Export Morphisms.ProperNotations.
 
 (** For backward compatibility *)
 
@@ -18,46 +18,46 @@ Definition Setoid_Theory := @Equivalence.
 Definition Build_Setoid_Theory := @Build_Equivalence.
 
 Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x.
-  unfold Setoid_Theory. intros ; reflexivity.
+  unfold Setoid_Theory in s. intros ; reflexivity.
 Defined.
 
 Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x.
-  unfold Setoid_Theory. intros ; symmetry ; assumption.
+  unfold Setoid_Theory in s. intros ; symmetry ; assumption.
 Defined.
 
 Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z.
-  unfold Setoid_Theory. intros ; transitivity y ; assumption.
+  unfold Setoid_Theory in s. intros ; transitivity y ; assumption.
 Defined.
 
-(** Some tactics for manipulating Setoid Theory not officially 
+(** Some tactics for manipulating Setoid Theory not officially
     declared as Setoid. *)
 
 Ltac trans_st x :=
   idtac "trans_st on Setoid_Theory is OBSOLETE";
   idtac "use transitivity on Equivalence instead";
   match goal with
-    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
       apply (Seq_trans _ _ H) with x; auto
   end.
 
 Ltac sym_st :=
   idtac "sym_st on Setoid_Theory is OBSOLETE";
   idtac "use symmetry on Equivalence instead";
-  match goal with 
-    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+  match goal with
+    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
       apply (Seq_sym _ _ H); auto
   end.
 
 Ltac refl_st :=
   idtac "refl_st on Setoid_Theory is OBSOLETE";
   idtac "use reflexivity on Equivalence instead";
-  match goal with 
-    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+  match goal with
+    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
       apply (Seq_refl _ _ H); auto
   end.
 
 Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
-Proof. 
-  constructor; congruence. 
+Proof.
+  constructor; congruence.
 Qed.
-  
+
diff --git a/theories/Setoids/vo.itarget b/theories/Setoids/vo.itarget
new file mode 100644
index 00000000..8d608cf7
--- /dev/null
+++ b/theories/Setoids/vo.itarget
@@ -0,0 +1 @@
+Setoid.vo
\ No newline at end of file
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
index e6755898..5f686099 100644
--- a/theories/Sets/Classical_sets.v
+++ b/theories/Sets/Classical_sets.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Classical_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 Require Export Constructive_sets.
@@ -56,7 +56,7 @@ Section Ensembles_classical.
     forall X Y:Ensemble U,
       Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X).
   Proof.
-    intros X Y I NI. 
+    intros X Y I NI.
     elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI).
     intros x YX.
     apply Inhabited_intro with x.
@@ -78,7 +78,7 @@ Section Ensembles_classical.
     unfold Subtract at 1 in |- *; auto with sets.
   Qed.
   Hint Resolve Subtract_intro : sets.
-  
+
   Lemma Subtract_inv :
     forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y.
   Proof.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index ad81316d..0719365f 100644
--- a/theories/Sets/Constructive_sets.v
+++ b/theories/Sets/Constructive_sets.v
@@ -24,13 +24,13 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Constructive_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 
 Section Ensembles_facts.
   Variable U : Type.
-  
+
   Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C.
   Proof.
     intros B C H'; rewrite H'; auto with sets.
@@ -52,7 +52,7 @@ Section Ensembles_facts.
   Proof.
     unfold Add at 1 in |- *; auto with sets.
   Qed.
-  
+
   Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
   Proof.
     unfold Add at 1 in |- *; auto with sets.
@@ -98,15 +98,15 @@ Section Ensembles_facts.
   Proof.
     intros B C x H'; elim H'; auto with sets.
   Qed.
-  
+
   Lemma Add_inv :
     forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y.
   Proof.
-    intros A x y H'; induction H'. 
+    intros A x y H'; induction H'.
       left; assumption.
       right; apply Singleton_inv; assumption.
   Qed.
-  
+
   Lemma Intersection_inv :
     forall (B C:Ensemble U) (x:U),
       In U (Intersection U B C) x -> In U B x /\ In U C x.
@@ -125,7 +125,7 @@ Section Ensembles_facts.
   Proof.
     unfold Setminus at 1 in |- *; red in |- *; auto with sets.
   Qed.
- 
+
   Lemma Strict_Included_intro :
     forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y.
   Proof.
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
index 1e1b70d5..8c69e687 100644
--- a/theories/Sets/Cpo.v
+++ b/theories/Sets/Cpo.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Cpo.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 Require Export Relations_1.
@@ -35,7 +35,7 @@ Section Bounds.
   Variable D : PO U.
 
   Let C := Carrier_of U D.
-  
+
   Let R := Rel_of U D.
 
   Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
@@ -45,7 +45,7 @@ Section Bounds.
   Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
     Lower_Bound_definition :
     In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.
-  
+
   Inductive Lub (B:Ensemble U) (x:U) : Prop :=
     Lub_definition :
     Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.
@@ -57,7 +57,7 @@ Section Bounds.
   Inductive Bottom (bot:U) : Prop :=
     Bottom_definition :
     In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.
-  
+
   Inductive Totally_ordered (B:Ensemble U) : Prop :=
     Totally_ordered_definition :
     (Included U B C ->
@@ -77,7 +77,7 @@ Section Bounds.
       Included U (Couple U x1 x2) X ->
       exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
     Directed X.
-  
+
   Inductive Complete : Prop :=
     Definition_of_Complete :
     (exists bot : _, Bottom bot) ->
@@ -102,7 +102,7 @@ Section Specific_orders.
 
   Record Cpo : Type := Definition_of_cpo
     {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.
-  
+
   Record Chain : Type := Definition_of_chain
     {PO_of_chain : PO U;
     Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
index c38a2fe1..0fa9c74a 100644
--- a/theories/Sets/Ensembles.v
+++ b/theories/Sets/Ensembles.v
@@ -24,27 +24,27 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Ensembles.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Section Ensembles.
   Variable U : Type.
-  
-  Definition Ensemble := U -> Prop. 
+
+  Definition Ensemble := U -> Prop.
 
   Definition In (A:Ensemble) (x:U) : Prop := A x.
-  
+
   Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.
-  
+
   Inductive Empty_set : Ensemble :=.
-  
+
   Inductive Full_set : Ensemble :=
     Full_intro : forall x:U, In Full_set x.
 
-(** NB: The following definition builds-in equality of elements in [U] as 
-     Leibniz equality. 
+(** NB: The following definition builds-in equality of elements in [U] as
+     Leibniz equality.
 
-     This may have to be changed if we replace [U] by a Setoid on [U] 
-     with its own equality [eqs], with  
+     This may have to be changed if we replace [U] by a Setoid on [U]
+     with its own equality [eqs], with
      [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *)
 
   Inductive Singleton (x:U) : Ensemble :=
@@ -55,7 +55,7 @@ Section Ensembles.
     | Union_intror : forall x:U, In C x -> In (Union B C) x.
 
   Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x).
-  
+
   Inductive Intersection (B C:Ensemble) : Ensemble :=
     Intersection_intro :
     forall x:U, In B x -> In C x -> In (Intersection B C) x.
@@ -63,29 +63,29 @@ Section Ensembles.
   Inductive Couple (x y:U) : Ensemble :=
     | Couple_l : In (Couple x y) x
     | Couple_r : In (Couple x y) y.
-  
+
   Inductive Triple (x y z:U) : Ensemble :=
     | Triple_l : In (Triple x y z) x
     | Triple_m : In (Triple x y z) y
     | Triple_r : In (Triple x y z) z.
-  
+
   Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x.
-  
+
   Definition Setminus (B C:Ensemble) : Ensemble :=
     fun x:U => In B x /\ ~ In C x.
-  
+
   Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x).
-  
+
   Inductive Disjoint (B C:Ensemble) : Prop :=
     Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C.
 
   Inductive Inhabited (B:Ensemble) : Prop :=
     Inhabited_intro : forall x:U, In B x -> Inhabited B.
-  
+
   Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C.
-  
+
   Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.
-  
+
   (** Extensionality Axiom *)
 
   Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
index f5eae4ed..019c25a5 100644
--- a/theories/Sets/Finite_sets.v
+++ b/theories/Sets/Finite_sets.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Finite_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Ensembles.
 
@@ -52,7 +52,7 @@ Require Import Constructive_sets.
 
 Section Ensembles_finis_facts.
   Variable U : Type.
-  
+
   Lemma cardinal_invert :
     forall (X:Ensemble U) (p:nat),
       cardinal U X p ->
diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
index 91717f9e..fdcc4150 100644
--- a/theories/Sets/Finite_sets_facts.v
+++ b/theories/Sets/Finite_sets_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Finite_sets_facts.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -72,7 +72,7 @@ Section Finite_sets_facts.
   Proof.
     intros X Y H; induction H as [|A Fin_A Hind x].
     rewrite (Empty_set_zero U Y). trivial.
-    intros. 
+    intros.
     rewrite (Union_commutative U (Add U A x) Y).
     rewrite <- (Union_add U Y A x).
     rewrite (Union_commutative U Y A).
@@ -98,7 +98,7 @@ Section Finite_sets_facts.
   Proof.
     intros A H' X; apply Finite_downward_closed with A; auto with sets.
   Qed.
-  
+
   Lemma cardinalO_empty :
     forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
   Proof.
@@ -212,7 +212,7 @@ Section Finite_sets_facts.
   Proof.
     intros; apply cardinal_is_functional with X X; auto with sets.
   Qed.
-  
+
   Lemma card_Add_gen :
     forall (A:Ensemble U) (x:U) (n n':nat),
       cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
@@ -279,7 +279,7 @@ Section Finite_sets_facts.
     intro E; rewrite E; auto with sets arith.
     apply cardinal_unicity with X; auto with sets arith.
   Qed.
-  
+
   Lemma G_aux :
     forall P:Ensemble U -> Prop,
       (forall X:Ensemble U,
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index d3591acf..64c341bd 100644
--- a/theories/Sets/Image.v
+++ b/theories/Sets/Image.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Image.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -40,10 +40,10 @@ Require Export Finite_sets_facts.
 
 Section Image.
   Variables U V : Type.
-  
+
   Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V :=
     Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y.
-  
+
   Lemma Im_def :
     forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x).
   Proof.
@@ -62,13 +62,13 @@ Section Image.
     rewrite H0.
     elim Add_inv with U X x x1; auto using Im_def with sets.
     destruct 1; auto using Im_def with sets.
-    elim Add_inv with V (Im X f) (f x) x0. 
+    elim Add_inv with V (Im X f) (f x) x0.
     destruct 1 as [x0 H y H0].
     rewrite H0; auto using Im_def with sets.
     destruct 1; auto using Im_def with sets.
     trivial.
   Qed.
-  
+
   Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V.
   Proof.
     intro f; try assumption.
@@ -88,7 +88,7 @@ Section Image.
     rewrite (Im_add A x f); auto with sets.
     apply Add_preserves_Finite; auto with sets.
   Qed.
-  
+
   Lemma Im_inv :
     forall (X:Ensemble U) (f:U -> V) (y:V),
       In _ (Im X f) y ->  exists x : U, In _ X x /\ f x = y.
@@ -97,9 +97,9 @@ Section Image.
     intros x H'0 y0 H'1; rewrite H'1.
     exists x; auto with sets.
   Qed.
-  
+
   Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y.
-  
+
   Lemma not_injective_elim :
     forall f:U -> V,
       ~ injective f ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
@@ -115,7 +115,7 @@ Section Image.
     destruct 1 as [y D]; exists y.
     apply imply_to_and; trivial with sets.
   Qed.
-  
+
   Lemma cardinal_Im_intro :
     forall (A:Ensemble U) (f:U -> V) (n:nat),
       cardinal _ A n ->  exists p : nat, cardinal _ (Im A f) p.
@@ -124,7 +124,7 @@ Section Image.
     apply finite_cardinal; apply finite_image.
     apply cardinal_finite with n; trivial with sets.
   Qed.
-  
+
   Lemma In_Image_elim :
     forall (A:Ensemble U) (f:U -> V),
       injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x.
@@ -134,7 +134,7 @@ Section Image.
     intros z C; elim C; intros InAz E.
     elim (H z x E); trivial with sets.
   Qed.
-  
+
   Lemma injective_preserves_cardinal :
     forall (A:Ensemble U) (f:U -> V) (n:nat),
       injective f ->
@@ -158,7 +158,7 @@ Section Image.
     red in |- *; intro; apply H'2.
     apply In_Image_elim with f; trivial with sets.
   Qed.
-  
+
   Lemma cardinal_decreases :
     forall (A:Ensemble U) (f:U -> V) (n:nat),
       cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n.
@@ -188,7 +188,7 @@ Section Image.
     apply injective_preserves_cardinal with (A := A) (f := f) (n := n);
       trivial with sets.
   Qed.
-  
+
   Lemma Pigeonhole_principle :
     forall (A:Ensemble U) (f:U -> V) (n:nat),
       cardinal _ A n ->
diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v
index ae2143c8..b63ec1d4 100644
--- a/theories/Sets/Infinite_sets.v
+++ b/theories/Sets/Infinite_sets.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Infinite_sets.v 10637 2008-03-07 23:52:56Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -50,7 +50,7 @@ Hint Resolve Defn_of_Approximant.
 
 Section Infinite_sets.
   Variable U : Type.
-  
+
   Lemma make_new_approximant :
     forall A X:Ensemble U,
       ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X).
@@ -61,7 +61,7 @@ Section Infinite_sets.
     red in |- *; intro H'3; apply H'.
     rewrite <- H'3; auto with sets.
   Qed.
-  
+
   Lemma approximants_grow :
     forall A X:Ensemble U,
       ~ Finite U A ->
@@ -101,7 +101,7 @@ Section Infinite_sets.
     apply Defn_of_Approximant; auto with sets.
     apply cardinal_finite with (n := S n0); auto with sets.
   Qed.
-  
+
   Lemma approximants_grow' :
     forall A X:Ensemble U,
       ~ Finite U A ->
@@ -121,7 +121,7 @@ Section Infinite_sets.
     apply cardinal_finite with (n := S n); auto with sets.
     apply approximants_grow with (X := X); auto with sets.
   Qed.
-  
+
   Lemma approximant_can_be_any_size :
     forall A X:Ensemble U,
       ~ Finite U A ->
@@ -135,7 +135,7 @@ Section Infinite_sets.
   Qed.
 
   Variable V : Type.
-  
+
   Theorem Image_set_continuous :
     forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
       Finite V X ->
@@ -230,7 +230,7 @@ Section Infinite_sets.
     rewrite H'4; auto with sets.
     elim H'3; auto with sets.
   Qed.
-  
+
   Theorem Pigeonhole_ter :
     forall (A:Ensemble U) (f:U -> V) (n:nat),
       injective U V f -> Finite V (Im U V A f) -> Finite U A.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
index 1786edf1..15c1b665 100644
--- a/theories/Sets/Integers.v
+++ b/theories/Sets/Integers.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Integers.v 10637 2008-03-07 23:52:56Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -45,7 +45,7 @@ Require Export Partial_Order.
 Require Export Cpo.
 
 Section Integers_sect.
-  
+
   Inductive Integers : Ensemble nat :=
     Integers_defn : forall x:nat, In nat Integers x.
 
@@ -53,7 +53,7 @@ Section Integers_sect.
   Proof.
     red in |- *; auto with arith.
   Qed.
-  
+
   Lemma le_antisym : Antisymmetric nat le.
   Proof.
     red in |- *; intros x y H H'; rewrite (le_antisym x y); auto.
@@ -63,12 +63,12 @@ Section Integers_sect.
   Proof.
     red in |- *; intros; apply le_trans with y; auto.
   Qed.
-  
+
   Lemma le_Order : Order nat le.
   Proof.
-    split; [exact le_reflexive | exact le_trans | exact le_antisym]. 
+    split; [exact le_reflexive | exact le_trans | exact le_antisym].
   Qed.
-  
+
   Lemma triv_nat : forall n:nat, In nat Integers n.
   Proof.
     exact Integers_defn.
@@ -77,11 +77,11 @@ Section Integers_sect.
   Definition nat_po : PO nat.
     apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le);
       auto with sets arith.
-    apply Inhabited_intro with (x := 0). 
+    apply Inhabited_intro with (x := 0).
       apply Integers_defn.
-      exact le_Order.
+    exact le_Order.
   Defined.
-  
+
   Lemma le_total_order : Totally_ordered nat nat_po Integers.
   Proof.
     apply Totally_ordered_definition.
@@ -92,7 +92,7 @@ Section Integers_sect.
     intro H'1; right.
     cut (y <= x); auto with sets arith.
   Qed.
-  
+
   Lemma Finite_subset_has_lub :
     forall X:Ensemble nat,
       Finite nat X ->  exists m : nat, Upper_Bound nat nat_po X m.
@@ -124,7 +124,7 @@ Section Integers_sect.
     apply H'4 with (y := x0). elim H'3; simpl in |- *; auto with sets arith. trivial.
     intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial.
     exists x0.
-    apply Upper_Bound_definition. 
+    apply Upper_Bound_definition.
       unfold nat_po. simpl. apply triv_nat.
     intros y H'1; elim H'1.
     intros x1 H'4; try assumption.
@@ -148,7 +148,7 @@ Section Integers_sect.
     absurd (S x <= x); auto with arith.
     apply triv_nat.
  Qed.
-  
+
   Lemma Integers_infinite : ~ Finite nat Integers.
   Proof.
     generalize Integers_has_no_ub.
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index d2bff488..7216ae33 100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Multiset.v 10616 2008-03-04 17:33:35Z letouzey $ i*)
+(*i $Id$ i*)
 
 (* G. Huet 1-9-95 *)
 
-Require Import Permut.
+Require Import Permut Setoid.
 
 Set Implicit Arguments.
 
@@ -18,11 +18,12 @@ Section multiset_defs.
 
   Variable A : Type.
   Variable eqA : A -> A -> Prop.
+  Hypothesis eqA_equiv : Equivalence eqA.
   Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
 
   Inductive multiset : Type :=
     Bag : (A -> nat) -> multiset.
-  
+
   Definition EmptyBag := Bag (fun a:A => 0).
   Definition SingletonBag (a:A) :=
     Bag (fun a':A => match Aeq_dec a a' with
@@ -31,23 +32,23 @@ Section multiset_defs.
                      end).
 
   Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a.
-  
+
   (** multiset equality *)
   Definition meq (m1 m2:multiset) :=
     forall a:A, multiplicity m1 a = multiplicity m2 a.
-  
+
   Lemma meq_refl : forall x:multiset, meq x x.
   Proof.
     destruct x; unfold meq; reflexivity.
   Qed.
-  
+
   Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
   Proof.
     unfold meq in |- *.
     destruct x; destruct y; destruct z.
     intros; rewrite H; auto.
   Qed.
-  
+
   Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
   Proof.
     unfold meq in |- *.
@@ -62,7 +63,7 @@ Section multiset_defs.
   Proof.
     unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
   Qed.
-  
+
   Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
   Proof.
     unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
@@ -70,7 +71,7 @@ Section multiset_defs.
 
 
   Require Plus. (* comm. and ass. of plus *)
-  
+
   Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
   Proof.
     unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
@@ -106,28 +107,28 @@ Section multiset_defs.
   Lemma munion_rotate :
     forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)).
   Proof.
-    intros; apply (op_rotate multiset munion meq). 
+    intros; apply (op_rotate multiset munion meq).
       apply munion_comm.
       apply munion_ass.
       exact meq_trans.
       exact meq_sym.
       trivial.
   Qed.
-  
+
   Lemma meq_congr :
     forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t).
   Proof.
     intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right.
       exact meq_trans.
   Qed.
-  
+
   Lemma munion_perm_left :
     forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)).
   Proof.
     intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym.
       exact meq_trans.
   Qed.
-  
+
   Lemma multiset_twist1 :
     forall x y z t:multiset,
       meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z).
@@ -156,7 +157,7 @@ Section multiset_defs.
     apply meq_right; apply meq_left; trivial.
     apply multiset_twist1.
   Qed.
-  
+
   Lemma treesort_twist2 :
     forall x y z t u:multiset,
       meq u (munion y z) ->
@@ -167,8 +168,17 @@ Section multiset_defs.
     apply multiset_twist2.
   Qed.
 
+  (** SingletonBag *)
+
+  Lemma meq_singleton : forall a a',
+    eqA a a' -> meq (SingletonBag a) (SingletonBag a').
+  Proof.
+    intros; red; simpl; intro a0.
+    destruct (Aeq_dec a a0) as [Ha|Ha]; rewrite H in Ha;
+      decide (Aeq_dec a' a0) with Ha; reflexivity.
+  Qed.
 
-(*i theory of minter to do similarly 
+(*i theory of minter to do similarly
 Require Min.
 (* multiset intersection *)
 Definition minter := [m1,m2:multiset]
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index 6210913c..4fe8f4f6 100644
--- a/theories/Sets/Partial_Order.v
+++ b/theories/Sets/Partial_Order.v
@@ -24,27 +24,27 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Partial_Order.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 Require Export Relations_1.
 
 Section Partial_orders.
   Variable U : Type.
-  
+
   Definition Carrier := Ensemble U.
-  
+
   Definition Rel := Relation U.
-  
+
   Record PO : Type := Definition_of_PO
     { Carrier_of : Ensemble U;
       Rel_of : Relation U;
       PO_cond1 : Inhabited U Carrier_of;
       PO_cond2 : Order U Rel_of }.
   Variable p : PO.
-  
+
   Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y.
-  
+
   Inductive covers (y x:U) : Prop :=
     Definition_of_covers :
     Strict_Rel_of x y ->
@@ -60,7 +60,7 @@ Hint Resolve Definition_of_covers: sets v62.
 Section Partial_order_facts.
   Variable U : Type.
   Variable D : PO U.
-  
+
   Lemma Strict_Rel_Transitive_with_Rel :
     forall x y z:U,
       Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v
index 4380f10c..f593031a 100644
--- a/theories/Sets/Permut.v
+++ b/theories/Sets/Permut.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permut.v 10616 2008-03-04 17:33:35Z letouzey $ i*)
+(*i $Id$ i*)
 
 (* G. Huet 1-9-95 *)
 
@@ -36,23 +36,23 @@ Section Axiomatisation.
     apply cong_left; trivial.
     apply cong_right; trivial.
   Qed.
-  
+
   Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)).
   Proof.
     intros; apply cong_right; apply op_comm.
   Qed.
-  
+
   Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z).
   Proof.
     intros; apply cong_left; apply op_comm.
   Qed.
-  
+
   Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y).
   Proof.
     intros.
     apply cong_trans with (op x (op y z)).
     apply op_ass.
-    apply cong_trans with (op x (op z y)). 
+    apply cong_trans with (op x (op z y)).
     apply cong_right; apply op_comm.
     apply cong_sym; apply op_ass.
   Qed.
@@ -66,7 +66,7 @@ Section Axiomatisation.
     apply cong_left; apply op_comm.
     apply op_ass.
   Qed.
-  
+
   Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)).
   Proof.
     intros; apply cong_trans with (op (op x y) z).
diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
index c9a52ac2..c323ca35 100644
--- a/theories/Sets/Powerset.v
+++ b/theories/Sets/Powerset.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 Require Export Relations_1.
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
index 34c49409..36d2150c 100644
--- a/theories/Sets/Powerset_Classical_facts.v
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset_Classical_facts.v 10855 2008-04-27 11:16:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 Require Export Constructive_sets.
@@ -40,7 +40,7 @@ Require Export Classical_sets.
 Section Sets_as_an_algebra.
 
   Variable U : Type.
-  
+
   Lemma sincl_add_x :
     forall (A B:Ensemble U) (x:U),
       ~ In U A x ->
@@ -63,7 +63,7 @@ Section Sets_as_an_algebra.
     intros X x H'; red in |- *.
     intros x0 H'0; elim H'0; auto with sets.
   Qed.
-  
+
   Lemma incl_soustr :
     forall (X Y:Ensemble U) (x:U),
       Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
@@ -73,7 +73,7 @@ Section Sets_as_an_algebra.
     intros H'1 H'2.
     apply Subtract_intro; auto with sets.
   Qed.
-  
+
   Lemma incl_soustr_add_l :
     forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
   Proof.
@@ -93,7 +93,7 @@ Section Sets_as_an_algebra.
     red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
   Qed.
   Hint Resolve incl_soustr_add_r: sets v62.
-  
+
   Lemma add_soustr_2 :
     forall (X:Ensemble U) (x:U),
       In U X x -> Included U X (Add U (Subtract U X x) x).
@@ -103,7 +103,7 @@ Section Sets_as_an_algebra.
     elim (classic (x = x0)); intro K; auto with sets.
     elim K; auto with sets.
   Qed.
-  
+
   Lemma add_soustr_1 :
     forall (X:Ensemble U) (x:U),
       In U X x -> Included U (Add U (Subtract U X x) x) X.
@@ -114,7 +114,7 @@ Section Sets_as_an_algebra.
     intros t H'1; try assumption.
     rewrite <- (Singleton_inv U x t); auto with sets.
   Qed.
-  
+
   Lemma add_soustr_xy :
     forall (X:Ensemble U) (x y:U),
       x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
@@ -133,7 +133,7 @@ Section Sets_as_an_algebra.
     intro H'0; elim H'0; auto with sets.
     intro H'0; rewrite <- H'0; auto with sets.
   Qed.
-  
+
   Lemma incl_st_add_soustr :
     forall (X Y:Ensemble U) (x:U),
       ~ In U X x ->
@@ -151,13 +151,13 @@ Section Sets_as_an_algebra.
     red in |- *; intro H'0; apply H'2.
     rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
   Qed.
-  
+
   Lemma Sub_Add_new :
     forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
   Proof.
     auto using incl_soustr_add_l with sets.
   Qed.
-  
+
   Lemma Simplify_add :
     forall (X X0:Ensemble U) (x:U),
       ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
@@ -167,7 +167,7 @@ Section Sets_as_an_algebra.
     rewrite (Sub_Add_new X0 x); auto with sets.
     rewrite H'1; auto with sets.
   Qed.
-  
+
   Lemma Included_Add :
     forall (X A:Ensemble U) (x:U),
       Included U X (Add U A x) ->
@@ -201,7 +201,7 @@ Section Sets_as_an_algebra.
     absurd (In U X x0); auto with sets.
     rewrite <- H'5; auto with sets.
   Qed.
-  
+
   Lemma setcover_inv :
     forall A x y:Ensemble U,
       covers (Ensemble U) (Power_set_PO U A) y x ->
@@ -219,7 +219,7 @@ Section Sets_as_an_algebra.
     elim H'1.
     exists z; auto with sets.
   Qed.
-  
+
   Theorem Add_covers :
     forall A a:Ensemble U,
       Included U a A ->
@@ -255,7 +255,7 @@ Section Sets_as_an_algebra.
     intros x1 H'10; elim H'10; auto with sets.
     intros x2 H'11; elim H'11; auto with sets.
   Qed.
-  
+
   Theorem covers_Add :
     forall A a a':Ensemble U,
       Included U a A ->
@@ -301,7 +301,7 @@ Section Sets_as_an_algebra.
     intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
     apply Add_covers; intuition.
   Qed.
-  
+
   Theorem Singleton_atomic :
     forall (x:U) (A:Ensemble U),
       In U A x ->
@@ -311,7 +311,7 @@ Section Sets_as_an_algebra.
     rewrite <- (Empty_set_zero' U x).
     apply Add_covers; auto with sets.
   Qed.
-  
+
   Lemma less_than_singleton :
     forall (X:Ensemble U) (x:U),
       Strict_Included U X (Singleton U x) -> X = Empty_set U.
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index edb6a215..76f7f1ec 100644
--- a/theories/Sets/Powerset_facts.v
+++ b/theories/Sets/Powerset_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset_facts.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Ensembles.
 Require Export Constructive_sets.
@@ -41,34 +41,34 @@ Section Sets_as_an_algebra.
   Proof.
     auto 6 with sets.
   Qed.
-  
+
   Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x.
   Proof.
     unfold Add at 1 in |- *; auto using Empty_set_zero with sets.
   Qed.
-  
+
   Lemma less_than_empty :
     forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U.
   Proof.
     auto with sets.
   Qed.
-  
+
   Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A.
   Proof.
     auto with sets.
   Qed.
-  
+
   Theorem Union_associative :
     forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C).
   Proof.
     auto 9 with sets.
   Qed.
-  
+
   Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A.
   Proof.
     auto 7 with sets.
   Qed.
-  
+
   Lemma Union_absorbs :
     forall A B:Ensemble U, Included U B A -> Union U A B = A.
   Proof.
@@ -82,7 +82,7 @@ Section Sets_as_an_algebra.
     intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets).
     intros x0 H'; elim H'; auto with sets.
   Qed.
-  
+
   Theorem Triple_as_union :
     forall x y z:U,
       Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) =
@@ -94,7 +94,7 @@ Section Sets_as_an_algebra.
     intros x1 H'0; elim H'0; auto with sets.
     intros x0 H'; elim H'; auto with sets.
   Qed.
-  
+
   Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y.
   Proof.
     intros x y.
@@ -102,7 +102,7 @@ Section Sets_as_an_algebra.
     rewrite <- (Union_idempotent (Singleton U x)).
     apply Triple_as_union.
   Qed.
-  
+
   Theorem Triple_as_Couple_Singleton :
     forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z).
   Proof.
@@ -110,7 +110,7 @@ Section Sets_as_an_algebra.
     rewrite <- (Triple_as_union x y z).
     rewrite <- (Couple_as_union x y); auto with sets.
   Qed.
-  
+
   Theorem Intersection_commutative :
     forall A B:Ensemble U, Intersection U A B = Intersection U B A.
   Proof.
@@ -118,7 +118,7 @@ Section Sets_as_an_algebra.
     apply Extensionality_Ensembles.
     split; red in |- *; intros x H'; elim H'; auto with sets.
   Qed.
-  
+
   Theorem Distributivity :
     forall A B C:Ensemble U,
       Intersection U A (Union U B C) =
@@ -132,7 +132,7 @@ Section Sets_as_an_algebra.
     elim H'1; auto with sets.
     elim H'; intros x0 H'0; elim H'0; auto with sets.
   Qed.
-  
+
   Theorem Distributivity' :
     forall A B C:Ensemble U,
       Union U A (Intersection U B C) =
@@ -149,13 +149,13 @@ Section Sets_as_an_algebra.
     generalize H'1.
     elim H'2; auto with sets.
   Qed.
-  
+
   Theorem Union_add :
     forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x).
   Proof.
     unfold Add in |- *; auto using Union_associative with sets.
   Qed.
-  
+
   Theorem Non_disjoint_union :
     forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X.
   Proof.
@@ -165,7 +165,7 @@ Section Sets_as_an_algebra.
     intros x0 H'0; elim H'0; auto with sets.
     intros t H'1; elim H'1; auto with sets.
   Qed.
-  
+
   Theorem Non_disjoint_union' :
     forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X.
   Proof.
@@ -178,12 +178,12 @@ Section Sets_as_an_algebra.
     lapply (Singleton_inv U x x0); auto with sets.
     intro H'4; apply H'; rewrite H'4; auto with sets.
   Qed.
-  
+
   Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y.
   Proof.
     intro x; rewrite (Empty_set_zero' x); auto with sets.
   Qed.
-  
+
   Lemma incl_add :
     forall (A B:Ensemble U) (x:U),
       Included U A B -> Included U (Add U A x) (Add U B x).
@@ -209,7 +209,7 @@ Section Sets_as_an_algebra.
     absurd (In U A x0); auto with sets.
     rewrite <- H'4; auto with sets.
   Qed.
-  
+
   Lemma Add_commutative :
     forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x.
   Proof.
@@ -220,7 +220,7 @@ Section Sets_as_an_algebra.
     rewrite <- (Union_associative A (Singleton U y) (Singleton U x));
       auto with sets.
   Qed.
-  
+
   Lemma Add_commutative' :
     forall (A:Ensemble U) (x y z:U),
       Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y.
@@ -229,7 +229,7 @@ Section Sets_as_an_algebra.
     rewrite (Add_commutative (Add U A x) y z).
     rewrite (Add_commutative A x z); auto with sets.
   Qed.
-  
+
   Lemma Add_distributes :
     forall (A B:Ensemble U) (x y:U),
       Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y).
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index 64c4c654..85d0cffc 100644
--- a/theories/Sets/Relations_1.v
+++ b/theories/Sets/Relations_1.v
@@ -24,42 +24,42 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_1.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Section Relations_1.
    Variable U : Type.
-   
+
    Definition Relation := U -> U -> Prop.
    Variable R : Relation.
-   
+
    Definition Reflexive : Prop := forall x:U, R x x.
-   
+
    Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z.
-   
+
    Definition Symmetric : Prop := forall x y:U, R x y -> R y x.
-   
+
    Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y.
-   
+
    Definition contains (R R':Relation) : Prop :=
      forall x y:U, R' x y -> R x y.
-   
+
    Definition same_relation (R R':Relation) : Prop :=
      contains R R' /\ contains R' R.
-   
+
    Inductive Preorder : Prop :=
        Definition_of_preorder : Reflexive -> Transitive -> Preorder.
-   
+
    Inductive Order : Prop :=
        Definition_of_order :
          Reflexive -> Transitive -> Antisymmetric -> Order.
-   
+
    Inductive Equivalence : Prop :=
        Definition_of_equivalence :
          Reflexive -> Transitive -> Symmetric -> Equivalence.
-   
+
    Inductive PER : Prop :=
        Definition_of_PER : Symmetric -> Transitive -> PER.
-   
+
 End Relations_1.
 Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains
   same_relation: sets v62.
diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
index 6ee7f5e2..fd83b0e0 100644
--- a/theories/Sets/Relations_1_facts.v
+++ b/theories/Sets/Relations_1_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_1_facts.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Relations_1.
 
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
index a74102fd..11ac85e8 100644
--- a/theories/Sets/Relations_2.v
+++ b/theories/Sets/Relations_2.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_2.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Relations_1.
 
diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
index 2374c2bf..3554901b 100644
--- a/theories/Sets/Relations_2_facts.v
+++ b/theories/Sets/Relations_2_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_2_facts.v 10637 2008-03-07 23:52:56Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Export Relations_1.
 Require Export Relations_1_facts.
@@ -140,7 +140,7 @@ intros U R H' x b H'0; elim H'0.
 intros x0 a H'1; exists a; auto with sets.
 intros x0 y z H'1 H'2 H'3 a H'4.
 red in H'.
-specialize H' with (x := x0) (a := a) (b := y); lapply H'; 
+specialize H' with (x := x0) (a := a) (b := y); lapply H';
  [ intro H'8; lapply H'8;
     [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ]
  | clear H' ]; auto with sets.
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
index b8c65148..970db182 100644
--- a/theories/Sets/Relations_3.v
+++ b/theories/Sets/Relations_3.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_3.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Relations_1.
 Require Export Relations_2.
@@ -32,26 +32,26 @@ Require Export Relations_2.
 Section Relations_3.
    Variable U : Type.
    Variable R : Relation U.
-   
+
    Definition coherent (x y:U) : Prop :=
       exists z : _, Rstar U R x z /\ Rstar U R y z.
-   
+
    Definition locally_confluent (x:U) : Prop :=
      forall y z:U, R x y -> R x z -> coherent y z.
-   
+
    Definition Locally_confluent : Prop := forall x:U, locally_confluent x.
-   
+
    Definition confluent (x:U) : Prop :=
      forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z.
-   
+
    Definition Confluent : Prop := forall x:U, confluent x.
-   
+
    Inductive noetherian (x: U) : Prop :=
        definition_of_noetherian :
          (forall y:U, R x y -> noetherian y) -> noetherian x.
-   
+
    Definition Noetherian : Prop := forall x:U, noetherian x.
-   
+
 End Relations_3.
 Hint Unfold coherent: sets v62.
 Hint Unfold locally_confluent: sets v62.
diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
index 38ff9eae..d8bf7dc3 100644
--- a/theories/Sets/Relations_3_facts.v
+++ b/theories/Sets/Relations_3_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_3_facts.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id$ i*)
 
 Require Export Relations_1.
 Require Export Relations_1_facts.
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
index 42c96191..909c7983 100644
--- a/theories/Sets/Uniset.v
+++ b/theories/Sets/Uniset.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Uniset.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Sets as characteristic functions *)
 
@@ -90,10 +90,10 @@ Qed.
 Definition union (m1 m2:uniset) :=
   Charac (fun a:A => orb (charac m1 a) (charac m2 a)).
 
-Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x).  
-Proof.  
-unfold seq in |- *; unfold union in |- *; simpl in |- *; auto.  
-Qed. 
+Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x).
+Proof.
+unfold seq in |- *; unfold union in |- *; simpl in |- *; auto.
+Qed.
 Hint Resolve union_empty_left.
 
 Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset).
@@ -203,7 +203,7 @@ apply uniset_twist2.
 Qed.
 
 
-(*i theory of minter to do similarly 
+(*i theory of minter to do similarly
 Require Min.
 (* uniset intersection *)
 Definition minter := [m1,m2:uniset]
diff --git a/theories/Sets/vo.itarget b/theories/Sets/vo.itarget
new file mode 100644
index 00000000..9ebe92f5
--- /dev/null
+++ b/theories/Sets/vo.itarget
@@ -0,0 +1,22 @@
+Classical_sets.vo
+Constructive_sets.vo
+Cpo.vo
+Ensembles.vo
+Finite_sets_facts.vo
+Finite_sets.vo
+Image.vo
+Infinite_sets.vo
+Integers.vo
+Multiset.vo
+Partial_Order.vo
+Permut.vo
+Powerset_Classical_facts.vo
+Powerset_facts.vo
+Powerset.vo
+Relations_1_facts.vo
+Relations_1.vo
+Relations_2_facts.vo
+Relations_2.vo
+Relations_3_facts.vo
+Relations_3.vo
+Uniset.vo
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
index fe7902aa..4124ef98 100644
--- a/theories/Sorting/Heap.v
+++ b/theories/Sorting/Heap.v
@@ -6,13 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Heap.v 10698 2008-03-19 18:46:59Z letouzey $ i*)
+(*i $Id$ i*)
 
-(** A development of Treesort on Heap trees *)
+(** This file is deprecated, for a tree on list, use [Mergesort.v]. *)
+
+(** A development of Treesort on Heap trees. It has an average
+    complexity of O(n.log n) but of O(n²) in the worst case (e.g. if
+    the list is already sorted) *)
 
 (* G. Huet 1-9-95 uses Multiset *)
 
-Require Import List Multiset Permutation Relations Sorting.
+Require Import List Multiset PermutSetoid Relations Sorting.
 
 Section defs.
 
@@ -25,7 +29,7 @@ Section defs.
   Variable eqA : relation A.
 
   Let gtA (x y:A) := ~ leA x y.
-  
+
   Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
   Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
   Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
@@ -37,7 +41,7 @@ Section defs.
 
   Let emptyBag := EmptyBag A.
   Let singletonBag := SingletonBag _ eqA_dec.
-  
+
   Inductive Tree :=
     | Tree_Leaf : Tree
     | Tree_Node : A -> Tree -> Tree -> Tree.
@@ -92,7 +96,7 @@ Section defs.
       forall T:Tree, is_heap T -> P T.
   Proof.
     simple induction T; auto with datatypes.
-    intros a G PG D PD PN. 
+    intros a G PG D PD PN.
     elim (invert_heap a G D); auto with datatypes.
     intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
     apply X0; auto with datatypes.
@@ -109,7 +113,7 @@ Section defs.
       forall T:Tree, is_heap T -> P T.
   Proof.
     simple induction T; auto with datatypes.
-    intros a G PG D PD PN. 
+    intros a G PG D PD PN.
     elim (invert_heap a G D); auto with datatypes.
     intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
     apply X; auto with datatypes.
@@ -122,6 +126,54 @@ Section defs.
     intros; simpl in |- *; apply leA_trans with b; auto with datatypes.
   Qed.
 
+  (** ** Merging two sorted lists *)
+
+  Inductive merge_lem (l1 l2:list A) : Type :=
+    merge_exist :
+    forall l:list A,
+      Sorted leA l ->
+      meq (list_contents _ eqA_dec l)
+      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
+      (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) ->
+      merge_lem l1 l2.
+
+  Lemma merge :
+    forall l1:list A, Sorted leA l1 ->
+    forall l2:list A, Sorted leA l2 -> merge_lem l1 l2.
+  Proof.
+    simple induction 1; intros.
+    apply merge_exist with l2; auto with datatypes.
+    elim H2; intros.
+    apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes.
+    elim (leA_dec a a0); intros.
+
+    (* 1 (leA a a0) *)
+    cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes.
+    intros [l3 l3sorted l3contents Hrec].
+    apply merge_exist with (a :: l3); simpl in |- *;
+      auto using cons_sort, cons_leA with datatypes.
+    apply meq_trans with
+      (munion (singletonBag a)
+	(munion (list_contents _ eqA_dec l)
+          (list_contents _ eqA_dec (a0 :: l0)))).
+    apply meq_right; trivial with datatypes.
+    apply meq_sym; apply munion_ass.
+    intros; apply cons_leA.
+    apply (@HdRel_inv _ leA) with l; trivial with datatypes.
+
+    (* 2 (leA a0 a) *)
+    elim X0; simpl in |- *; intros.
+    apply merge_exist with (a0 :: l3); simpl in |- *;
+      auto using cons_sort, cons_leA with datatypes.
+    apply meq_trans with
+      (munion (singletonBag a0)
+	(munion (munion (singletonBag a) (list_contents _ eqA_dec l))
+          (list_contents _ eqA_dec l0))).
+    apply meq_right; trivial with datatypes.
+    apply munion_perm_left.
+    intros; apply cons_leA; apply HdRel_inv with (l:=l0); trivial with datatypes.
+  Qed.
+
 
   (** ** From trees to multisets *)
 
@@ -167,15 +219,15 @@ Section defs.
     elim (X a0); intros.
     apply insert_exist with (Tree_Node a T2 T0);
       auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
-    simpl in |- *; apply treesort_twist1; trivial with datatypes. 
+    simpl in |- *; apply treesort_twist1; trivial with datatypes.
     elim (X a); intros T3 HeapT3 ConT3 LeA.
-    apply insert_exist with (Tree_Node a0 T2 T3); 
+    apply insert_exist with (Tree_Node a0 T2 T3);
       auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
     apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
-    apply low_trans with a; auto with datatypes. 
+    apply low_trans with a; auto with datatypes.
     apply LeA; auto with datatypes.
     apply low_trans with a; auto with datatypes.
-    simpl in |- *; apply treesort_twist2; trivial with datatypes. 
+    simpl in |- *; apply treesort_twist2; trivial with datatypes.
   Qed.
 
 
@@ -186,7 +238,7 @@ Section defs.
     forall T:Tree,
       is_heap T ->
       meq (list_contents _ eqA_dec l) (contents T) -> build_heap l.
-  
+
   Lemma list_to_heap : forall l:list A, build_heap l.
   Proof.
     simple induction l.
@@ -204,12 +256,12 @@ Section defs.
 
 
   (** ** Building the sorted list *)
-  
+
   Inductive flat_spec (T:Tree) : Type :=
     flat_exist :
     forall l:list A,
-      sort leA l ->
-      (forall a:A, leA_Tree a T -> lelistA leA a l) ->
+      Sorted leA l ->
+      (forall a:A, leA_Tree a T -> HdRel leA a l) ->
       meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T.
 
   Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T.
@@ -217,7 +269,7 @@ Section defs.
     intros T h; elim h; intros.
     apply flat_exist with (nil (A:=A)); auto with datatypes.
     elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2.
-    elim (merge _ leA_dec eqA_dec s1 s2); intros.
+    elim (merge _ s1 _ s2); intros.
     apply flat_exist with (a :: l); simpl in |- *; auto with datatypes.
     apply meq_trans with
       (munion (list_contents _ eqA_dec l1)
@@ -234,7 +286,8 @@ Section defs.
   (** * Specification of treesort *)
 
   Theorem treesort :
-    forall l:list A, {m : list A | sort leA m &  permutation _ eqA_dec l m}.
+    forall l:list A,
+    {m : list A | Sorted leA m & permutation _ eqA_dec l m}.
   Proof.
     intro l; unfold permutation in |- *.
     elim (list_to_heap l).
@@ -245,4 +298,4 @@ Section defs.
     apply meq_trans with (contents T); trivial with datatypes.
   Qed.
 
-End defs.
\ No newline at end of file
+End defs.
diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v
new file mode 100644
index 00000000..238013b8
--- /dev/null
+++ b/theories/Sorting/Mergesort.v
@@ -0,0 +1,271 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(** A modular implementation of mergesort (the complexity is O(n.log n) in
+   the length of the list) *)
+
+(* Initial author: Hugo Herbelin, Oct 2009 *)
+
+Require Import List Setoid Permutation Sorted Orders.
+
+(** Notations and conventions *)
+
+Local Notation "[ ]" := nil.
+Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).
+
+Open Scope bool_scope.
+
+Local Coercion is_true : bool >-> Sortclass.
+
+(** The main module defining [mergesort] on a given boolean
+    order [<=?]. We require minimal hypotheses : this boolean
+    order should only be total: [forall x y, (x<=?y) \/ (y<=?x)].
+    Transitivity is not mandatory, but without it one can
+    only prove [LocallySorted] and not [StronglySorted].
+*)
+
+Module Sort (Import X:Orders.TotalLeBool').
+
+Fixpoint merge l1 l2 :=
+  let fix merge_aux l2 :=
+  match l1, l2 with
+  | [], _ => l2
+  | _, [] => l1
+  | a1::l1', a2::l2' =>
+      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
+  end
+  in merge_aux l2.
+
+(** We implement mergesort using an explicit stack of pending mergings.
+    Pending merging are represented like a binary number where digits are
+    either None (denoting 0) or Some list to merge (denoting 1). The n-th
+    digit represents the pending list to be merged at level n, if any.
+    Merging a list to a stack is like adding 1 to the binary number
+    represented by the stack but the carry is propagated by merging the
+    lists. In practice, when used in mergesort, the n-th digit, if non 0,
+    carries a list of length 2^n. For instance, adding singleton list
+    [3] to the stack Some [4]::Some [2;6]::None::Some [1;3;5;5]
+    reduces to propagate the carry [3;4] (resulting of the merge of [3]
+    and [4]) to the list Some [2;6]::None::Some [1;3;5;5], which reduces
+    to propagating the carry [2;3;4;6] (resulting of the merge of [3;4] and
+    [2;6]) to the list None::Some [1;3;5;5], which locally produces
+    Some [2;3;4;6]::Some [1;3;5;5], i.e. which produces the final result
+    None::None::Some [2;3;4;6]::Some [1;3;5;5].
+
+    For instance, here is how [6;2;3;1;5] is sorted:
+
+       operation             stack                list
+       iter_merge            []                   [6;2;3;1;5]
+    =  append_list_to_stack  [ + [6]]             [2;3;1;5]
+    -> iter_merge            [[6]]                [2;3;1;5]
+    =  append_list_to_stack  [[6] + [2]]          [3;1;5]
+    =  append_list_to_stack  [ + [2;6];]          [3;1;5]
+    -> iter_merge            [[2;6];]             [3;1;5]
+    =  append_list_to_stack  [[2;6]; + [3]]       [1;5]
+    -> merge_list            [[2;6];[3]]          [1;5]
+    =  append_list_to_stack  [[2;6];[3] + [1]     [5]
+    =  append_list_to_stack  [[2;6] + [1;3];]     [5]
+    =  append_list_to_stack  [ + [1;2;3;6];;]     [5]
+    -> merge_list            [[1;2;3;6];;]        [5]
+    =  append_list_to_stack  [[1;2;3;6];; + [5]]  []
+    -> merge_stack           [[1;2;3;6];;[5]]
+    =                                             [1;2;3;5;6]
+
+    The complexity of the algorithm is n*log n, since there are
+    2^(p-1) mergings to do of length 2, 2^(p-2) of length 4, ..., 2^0
+    of length 2^p for a list of length 2^p. The algorithm does not need
+    explicitly cutting the list in 2 parts at each step since it the
+    successive accumulation of fragments on the stack which ensures
+    that lists are merged on a dichotomic basis.
+*)
+
+Fixpoint merge_list_to_stack stack l :=
+  match stack with
+  | [] => [Some l]
+  | None :: stack' => Some l :: stack'
+  | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l)
+  end.
+
+Fixpoint merge_stack stack :=
+  match stack with
+  | [] => []
+  | None :: stack' => merge_stack stack'
+  | Some l :: stack' => merge l (merge_stack stack')
+  end.
+
+Fixpoint iter_merge stack l :=
+  match l with
+  | [] => merge_stack stack
+  | a::l' => iter_merge (merge_list_to_stack stack [a]) l'
+  end.
+
+Definition sort := iter_merge [].
+
+(** The proof of correctness *)
+
+Local Notation Sorted := (LocallySorted leb) (only parsing).
+
+Fixpoint SortedStack stack :=
+  match stack with
+  | [] => True
+  | None :: stack' => SortedStack stack'
+  | Some l :: stack' => Sorted l /\ SortedStack stack'
+  end.
+
+Local Ltac invert H := inversion H; subst; clear H.
+
+Fixpoint flatten_stack (stack : list (option (list t))) :=
+  match stack with
+  | [] => []
+  | None :: stack' => flatten_stack stack'
+  | Some l :: stack' => l ++ flatten_stack stack'
+  end.
+
+Theorem Sorted_merge : forall l1 l2,
+  Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
+Proof.
+induction l1; induction l2; intros; simpl; auto.
+  destruct (a <=? a0) as ()_eqn:Heq1.
+    invert H.
+      simpl. constructor; trivial; rewrite Heq1; constructor.
+      assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto).
+      clear H0 H3 IHl1; simpl in *.
+      destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor.
+    assert (a0 <=? a) by
+      (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')).
+    invert H0.
+      constructor; trivial.
+      assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1.
+      clear IHl2; simpl in *.
+      destruct (a <=? b); constructor; auto.
+Qed.
+
+Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2).
+Proof.
+  induction l1; simpl merge; intro.
+    assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l)
+    as -> by (destruct l; trivial). (* Technical lemma *)
+    apply Permutation_refl.
+  induction l2.
+    rewrite app_nil_r. apply Permutation_refl.
+    destruct (a <=? a0).
+      constructor; apply IHl1.
+      apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2.
+Qed.
+
+Theorem Sorted_merge_list_to_stack : forall stack l,
+  SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l).
+Proof.
+  induction stack as [|[|]]; intros; simpl.
+    auto.
+    apply IHstack. destruct H as (_,H1). fold SortedStack in H1. auto.
+      apply Sorted_merge; auto; destruct H; auto.
+      auto.
+Qed.
+
+Theorem Permuted_merge_list_to_stack : forall stack l,
+  Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)).
+Proof.
+  induction stack as [|[]]; simpl; intros.
+    reflexivity.
+    rewrite app_assoc.
+    etransitivity.
+      apply Permutation_app_tail.
+      etransitivity.
+        apply Permutation_app_comm.
+      apply Permuted_merge.
+    apply IHstack.
+    reflexivity.
+Qed.
+
+Theorem Sorted_merge_stack : forall stack,
+  SortedStack stack -> Sorted (merge_stack stack).
+Proof.
+induction stack as [|[|]]; simpl; intros.
+  constructor; auto.
+  apply Sorted_merge; tauto.
+  auto.
+Qed.
+
+Theorem Permuted_merge_stack : forall stack,
+  Permutation (flatten_stack stack) (merge_stack stack).
+Proof.
+induction stack as [|[]]; simpl.
+  trivial.
+  transitivity (l ++ merge_stack stack).
+    apply Permutation_app_head; trivial.
+    apply Permuted_merge.
+  assumption.
+Qed.
+
+Theorem Sorted_iter_merge : forall stack l,
+  SortedStack stack -> Sorted (iter_merge stack l).
+Proof.
+  intros stack l H; induction l in stack, H |- *; simpl.
+    auto using Sorted_merge_stack.
+    assert (Sorted [a]) by constructor.
+    auto using Sorted_merge_list_to_stack.
+Qed.
+
+Theorem Permuted_iter_merge : forall l stack,
+  Permutation (flatten_stack stack ++ l) (iter_merge stack l).
+Proof.
+  induction l; simpl; intros.
+    rewrite app_nil_r. apply Permuted_merge_stack.
+    change (a::l) with ([a]++l).
+    rewrite app_assoc.
+    etransitivity.
+      apply Permutation_app_tail.
+    etransitivity.
+    apply Permutation_app_comm.
+    apply Permuted_merge_list_to_stack.
+    apply IHl.
+Qed.
+
+Theorem Sorted_sort : forall l, Sorted (sort l).
+Proof.
+intro; apply Sorted_iter_merge. constructor.
+Qed.
+
+Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l).
+Proof. intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed.
+
+Theorem Permuted_sort : forall l, Permutation l (sort l).
+Proof.
+intro; apply (Permuted_iter_merge l []).
+Qed.
+
+Corollary StronglySorted_sort : forall l,
+  Transitive leb -> StronglySorted leb (sort l).
+Proof. auto using Sorted_StronglySorted, LocallySorted_sort. Qed.
+
+End Sort.
+
+(** An example *)
+
+Module NatOrder <: TotalLeBool.
+  Definition t := nat.
+  Fixpoint leb x y :=
+    match x, y with
+    | 0, _ => true
+    | _, 0 => false
+    | S x', S y' => leb x' y'
+    end.
+  Infix "<=?" := leb (at level 35).
+  Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
+  Proof.
+    induction a1; destruct a2; simpl; auto.
+  Qed.
+End NatOrder.
+
+Module Import NatSort := Sort NatOrder.
+
+Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0].
+
diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
index 084aae92..8e6aa6dc 100644
--- a/theories/Sorting/PermutEq.v
+++ b/theories/Sorting/PermutEq.v
@@ -6,61 +6,51 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PermutEq.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
-Require Import Omega Relations Setoid List Multiset Permutation.
+Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation.
 
 Set Implicit Arguments.
 
 (** This file is similar to [PermutSetoid], except that the equality used here
-    is Coq usual one instead of a setoid equality. In particular, we can then 
-    prove the equivalence between [List.Permutation] and 
+    is Coq usual one instead of a setoid equality. In particular, we can then
+    prove the equivalence between [List.Permutation] and
     [Permutation.permutation].
 *)
 
 Section Perm.
-  
+
   Variable A : Type.
   Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}.
-  
+
   Notation permutation := (permutation _ eq_dec).
   Notation list_contents := (list_contents _ eq_dec).
 
   (** we can use [multiplicity] to define [In] and [NoDup]. *)
 
-  Lemma multiplicity_In : 
+  Lemma multiplicity_In :
     forall l a, In a l <-> 0 < multiplicity (list_contents l) a.
   Proof.
-    induction l.
-    simpl.
-    split; inversion 1.
-    simpl.
-    split; intros.
-    inversion_clear H.
-    subst a0.
-    destruct (eq_dec a a) as [_|H]; auto with arith; destruct H; auto.
-    destruct (eq_dec a a0) as [H1|H1]; auto with arith; simpl.
-    rewrite <- IHl; auto.
-    destruct (eq_dec a a0); auto.
-    simpl in H.
-    right; rewrite IHl; auto.
+    intros; split; intro H.
+    eapply In_InA, multiplicity_InA in H; eauto with typeclass_instances.
+    eapply multiplicity_InA, InA_alt in H as (y & -> & H); eauto with typeclass_instances.
   Qed.
 
   Lemma multiplicity_In_O :
     forall l a, ~ In a l -> multiplicity (list_contents l) a = 0.
   Proof.
-    intros l a; rewrite multiplicity_In; 
+    intros l a; rewrite multiplicity_In;
       destruct (multiplicity (list_contents l) a); auto.
     destruct 1; auto with arith.
   Qed.
-  
+
   Lemma multiplicity_In_S :
     forall l a, In a l -> multiplicity (list_contents l) a >= 1.
   Proof.
     intros l a; rewrite multiplicity_In; auto.
   Qed.
 
-  Lemma multiplicity_NoDup : 
+  Lemma multiplicity_NoDup :
     forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1).
   Proof.
     induction l.
@@ -78,7 +68,7 @@ Section Perm.
     generalize (H a).
     destruct (eq_dec a a) as [H0|H0].
     destruct (multiplicity (list_contents l) a); auto with arith.
-    simpl; inversion 1. 
+    simpl; inversion 1.
     inversion H3.
     destruct H0; auto.
     rewrite IHl; intros.
@@ -86,13 +76,13 @@ Section Perm.
     destruct (eq_dec a a0); simpl; auto with arith.
   Qed.
 
-  Lemma NoDup_permut : 
-    forall l l', NoDup l -> NoDup l' -> 
+  Lemma NoDup_permut :
+    forall l l', NoDup l -> NoDup l' ->
       (forall x, In x l <-> In x l') -> permutation l l'.
   Proof.
     intros.
     red; unfold meq; intros.
-    rewrite multiplicity_NoDup in H, H0. 
+    rewrite multiplicity_NoDup in H, H0.
     generalize (H a) (H0 a) (H1 a); clear H H0 H1.
     do 2 rewrite multiplicity_In.
     destruct 3; omega.
@@ -102,7 +92,7 @@ Section Perm.
   Lemma permut_In_In :
     forall l1 l2 e, permutation l1 l2 -> In e l1 -> In e l2.
   Proof.
-    unfold Permutation.permutation, meq; intros l1 l2 e P IN.
+    unfold PermutSetoid.permutation, meq; intros l1 l2 e P IN.
     generalize (P e); clear P.
     destruct (In_dec eq_dec e l2) as [H|H]; auto.
     rewrite (multiplicity_In_O _ _ H).
@@ -128,11 +118,11 @@ Section Perm.
     intro Abs; generalize (permut_In_In _ Abs H).
     inversion 1.
   Qed.
-  
-  (** When used with [eq], this permutation notion is equivalent to 
+
+  (** When used with [eq], this permutation notion is equivalent to
       the one defined in [List.v]. *)
 
-  Lemma permutation_Permutation : 
+  Lemma permutation_Permutation :
     forall l l', Permutation l l' <-> permutation l l'.
   Proof.
     split.
@@ -141,7 +131,7 @@ Section Perm.
     apply permut_cons; auto.
     change (permutation (y::x::l) ((x::nil)++y::l)).
     apply permut_add_cons_inside; simpl; apply permut_refl.
-    apply permut_tran with l'; auto.
+    apply permut_trans with l'; auto.
     revert l'.
     induction l.
     intros.
@@ -152,7 +142,7 @@ Section Perm.
     subst l'.
     apply Permutation_cons_app.
     apply IHl.
-    apply permut_remove_hd with a; auto.
+    apply permut_remove_hd with a; auto with typeclass_instances.
   Qed.
 
   (** Permutation for short lists. *)
@@ -160,12 +150,12 @@ Section Perm.
   Lemma permut_length_1:
     forall a b, permutation (a :: nil) (b :: nil)  -> a=b.
   Proof.
-    intros a b; unfold Permutation.permutation, meq; intro P;
+    intros a b; unfold PermutSetoid.permutation, meq; intro P;
       generalize (P b); clear P; simpl.
     destruct (eq_dec b b) as [H|H]; [ | destruct H; auto].
     destruct (eq_dec a b); simpl; auto; intros; discriminate.
   Qed.
-  
+
   Lemma permut_length_2 :
     forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
       (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1).
@@ -177,7 +167,7 @@ Section Perm.
     apply permut_length_1.
     red; red; intros.
     generalize (P a); clear P; simpl.
-    destruct (eq_dec a1 a) as [H2|H2]; 
+    destruct (eq_dec a1 a) as [H2|H2];
       destruct (eq_dec a2 a) as [H3|H3]; auto.
     destruct H3; transitivity a1; auto.
     destruct H2; transitivity a2; auto.
@@ -187,7 +177,7 @@ Section Perm.
     apply permut_length_1.
     red; red; intros.
     generalize (P a); clear P; simpl.
-    destruct (eq_dec a1 a) as [H2|H2]; 
+    destruct (eq_dec a1 a) as [H2|H2];
       destruct (eq_dec b2 a) as [H3|H3]; auto.
     simpl; rewrite <- plus_n_Sm; inversion 1; auto.
     destruct H3; transitivity a1; auto.
@@ -206,17 +196,17 @@ Section Perm.
     simpl; rewrite <- plus_n_Sm; f_equal.
     rewrite <- app_length.
     apply IHl1.
-    apply permut_remove_hd with a; auto.
+    apply permut_remove_hd with a; auto with typeclass_instances.
   Qed.
 
   Variable B : Type.
-  Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. 
+  Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }.
 
   (** Permutation is compatible with map. *)
 
   Lemma permutation_map :
-    forall f l1 l2, permutation l1 l2 -> 
-      Permutation.permutation _ eqB_dec (map f l1) (map f l2).
+    forall f l1 l2, permutation l1 l2 ->
+      PermutSetoid.permutation _ eqB_dec (map f l1) (map f l2).
   Proof.
     intros f; induction l1.
     intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
@@ -229,7 +219,7 @@ Section Perm.
     apply permut_add_cons_inside.
     rewrite <- map_app.
     apply IHl1; auto.
-    apply permut_remove_hd with a; auto.
+    apply permut_remove_hd with a; auto with typeclass_instances.
   Qed.
 
 End Perm.
diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v
index c3888cfa..a9fdfd12 100644
--- a/theories/Sorting/PermutSetoid.v
+++ b/theories/Sorting/PermutSetoid.v
@@ -6,55 +6,316 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: PermutSetoid.v 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
-Require Import Omega Relations Multiset Permutation SetoidList.
+Require Import Omega Relations Multiset SetoidList.
 
-Set Implicit Arguments.
+(** This file is deprecated, use [Permutation.v] instead.
+
+    Indeed, this file defines a notion of permutation based on
+    multisets (there exists a permutation between two lists iff every
+    elements have the same multiplicity in the two lists) which
+    requires a more complex apparatus (the equipment of the domain
+    with a decidable equality) than [Permutation] in [Permutation.v].
 
-(** This file contains additional results about permutations 
-     with respect to an setoid equality (i.e. an equivalence relation). 
+    The relation between the two relations are in lemma
+    [permutation_Permutation].
+
+    File [PermutEq] concerns Leibniz equality : it shows in particular
+    that [List.Permutation] and [permutation] are equivalent in this context.
 *)
 
-Section Perm.
+Set Implicit Arguments.
+
+Local Notation "[ ]" := nil.
+Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).
+
+Section Permut.
+
+(** * From lists to multisets *)
 
 Variable A : Type.
 Variable eqA : relation A.
+Hypothesis eqA_equiv : Equivalence eqA.
 Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
 
-Notation permutation := (permutation _ eqA_dec).
-Notation list_contents := (list_contents _ eqA_dec).
+Let emptyBag := EmptyBag A.
+Let singletonBag := SingletonBag _ eqA_dec.
+
+(** contents of a list *)
+
+Fixpoint list_contents (l:list A) : multiset A :=
+  match l with
+  | [] => emptyBag
+  | a :: l => munion (singletonBag a) (list_contents l)
+  end.
+
+Lemma list_contents_app :
+  forall l m:list A,
+    meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)).
+Proof.
+  simple induction l; simpl in |- *; auto with datatypes.
+  intros.
+  apply meq_trans with
+    (munion (singletonBag a) (munion (list_contents l0) (list_contents m)));
+    auto with datatypes.
+Qed.
+
+(** * [permutation]: definition and basic properties *)
+
+Definition permutation (l m:list A) := meq (list_contents l) (list_contents m).
+
+Lemma permut_refl : forall l:list A, permutation l l.
+Proof.
+  unfold permutation in |- *; auto with datatypes.
+Qed.
+
+Lemma permut_sym :
+  forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1.
+Proof.
+  unfold permutation, meq; intros; apply sym_eq; trivial.
+Qed.
+
+Lemma permut_trans :
+  forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
+Proof.
+  unfold permutation in |- *; intros.
+  apply meq_trans with (list_contents m); auto with datatypes.
+Qed.
+
+Lemma permut_cons_eq :
+  forall l m:list A,
+    permutation l m -> forall a a', eqA a a' -> permutation (a :: l) (a' :: m).
+Proof.
+  unfold permutation; simpl; intros.
+  apply meq_trans with (munion (singletonBag a') (list_contents l)).
+  apply meq_left, meq_singleton; auto.
+  auto with datatypes.
+Qed.
+
+Lemma permut_cons :
+  forall l m:list A,
+    permutation l m -> forall a:A, permutation (a :: l) (a :: m).
+Proof.
+  unfold permutation; simpl; auto with datatypes.
+Qed.
+
+Lemma permut_app :
+  forall l l' m m':list A,
+    permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m').
+Proof.
+  unfold permutation in |- *; intros.
+  apply meq_trans with (munion (list_contents l) (list_contents m));
+    auto using permut_cons, list_contents_app with datatypes.
+  apply meq_trans with (munion (list_contents l') (list_contents m'));
+    auto using permut_cons, list_contents_app with datatypes.
+  apply meq_trans with (munion (list_contents l') (list_contents m));
+    auto using permut_cons, list_contents_app with datatypes.
+Qed.
+
+Lemma permut_add_inside_eq :
+  forall a a' l1 l2 l3 l4, eqA a a' ->
+    permutation (l1 ++ l2) (l3 ++ l4) ->
+    permutation (l1 ++ a :: l2) (l3 ++ a' :: l4).
+Proof.
+  unfold permutation, meq in *; intros.
+  specialize H0 with a0.
+  repeat rewrite list_contents_app in *; simpl in *.
+  destruct (eqA_dec a a0) as [Ha|Ha]; rewrite H in Ha;
+    decide (eqA_dec a' a0) with Ha; simpl; auto with arith.
+  do 2 rewrite <- plus_n_Sm; f_equal; auto.
+Qed.
+
+Lemma permut_add_inside :
+  forall a l1 l2 l3 l4,
+    permutation (l1 ++ l2) (l3 ++ l4) ->
+    permutation (l1 ++ a :: l2) (l3 ++ a :: l4).
+Proof.
+  unfold permutation, meq in *; intros.
+  generalize (H a0); clear H.
+  do 4 rewrite list_contents_app.
+  simpl.
+  destruct (eqA_dec a a0); simpl; auto with arith.
+  do 2 rewrite <- plus_n_Sm; f_equal; auto.
+Qed.
+
+Lemma permut_add_cons_inside_eq :
+  forall a a' l l1 l2, eqA a a' ->
+    permutation l (l1 ++ l2) ->
+    permutation (a :: l) (l1 ++ a' :: l2).
+Proof.
+  intros;
+  replace (a :: l) with ([] ++ a :: l); trivial;
+    apply permut_add_inside_eq; trivial.
+Qed.
 
-(** The following lemmas need some knowledge on [eqA] *)
+Lemma permut_add_cons_inside :
+  forall a l l1 l2,
+    permutation l (l1 ++ l2) ->
+    permutation (a :: l) (l1 ++ a :: l2).
+Proof.
+  intros;
+    replace (a :: l) with ([] ++ a :: l); trivial;
+	apply permut_add_inside; trivial.
+Qed.
 
-Variable eqA_refl : forall x, eqA x x.
-Variable eqA_sym : forall x y, eqA x y -> eqA y x.
-Variable eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+Lemma permut_middle :
+  forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m).
+Proof.
+  intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl.
+Qed.
+
+Lemma permut_sym_app :
+  forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
+Proof.
+  intros l1 l2;
+    unfold permutation, meq;
+	intro a; do 2 rewrite list_contents_app; simpl;
+	  auto with arith.
+Qed.
+
+Lemma permut_rev :
+  forall l, permutation l (rev l).
+Proof.
+  induction l.
+  simpl; trivial using permut_refl.
+  simpl.
+  apply permut_add_cons_inside.
+  rewrite <- app_nil_end. trivial.
+Qed.
+
+(** * Some inversion results. *)
+Lemma permut_conv_inv :
+  forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2.
+Proof.
+  intros e l1 l2; unfold permutation, meq; simpl; intros H a;
+    generalize (H a); apply plus_reg_l.
+Qed.
+
+Lemma permut_app_inv1 :
+  forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2.
+Proof.
+  intros l l1 l2; unfold permutation, meq; simpl;
+    intros H a; generalize (H a); clear H.
+  do 2 rewrite list_contents_app.
+  simpl.
+  intros; apply plus_reg_l with (multiplicity (list_contents l) a).
+  rewrite plus_comm; rewrite H; rewrite plus_comm.
+  trivial.
+Qed.
 
 (** we can use [multiplicity] to define [InA] and [NoDupA]. *)
 
-Lemma multiplicity_InA : 
+Fact if_eqA_then : forall a a' (B:Type)(b b':B),
+ eqA a a' -> (if eqA_dec a a' then b else b') = b.
+Proof.
+  intros. destruct eqA_dec as [_|NEQ]; auto.
+  contradict NEQ; auto.
+Qed.
+
+Lemma permut_app_inv2 :
+  forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2.
+Proof.
+  intros l l1 l2; unfold permutation, meq; simpl;
+    intros H a; generalize (H a); clear H.
+  do 2 rewrite list_contents_app.
+  simpl.
+  intros; apply plus_reg_l with (multiplicity (list_contents l) a).
+  trivial.
+Qed.
+
+Lemma permut_remove_hd_eq :
+  forall l l1 l2 a b, eqA a b ->
+    permutation (a :: l) (l1 ++ b :: l2) -> permutation l (l1 ++ l2).
+Proof.
+  unfold permutation, meq; simpl; intros l l1 l2 a b Heq H a0.
+  specialize H with a0.
+  rewrite list_contents_app in *; simpl in *.
+  apply plus_reg_l with (if eqA_dec a a0 then 1 else 0).
+  rewrite H; clear H.
+  symmetry; rewrite plus_comm, <- ! plus_assoc; f_equal.
+  rewrite plus_comm.
+  destruct (eqA_dec a a0) as [Ha|Ha]; rewrite Heq in Ha;
+    decide (eqA_dec b a0) with Ha; reflexivity.
+Qed.
+
+Lemma permut_remove_hd :
+  forall l l1 l2 a,
+    permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2).
+Proof.
+  eauto using permut_remove_hd_eq, Equivalence_Reflexive.
+Qed.
+
+Fact if_eqA_else : forall a a' (B:Type)(b b':B),
+ ~eqA a a' -> (if eqA_dec a a' then b else b') = b'.
+Proof.
+  intros. decide (eqA_dec a a') with H; auto.
+Qed.
+
+Fact if_eqA_refl : forall a (B:Type)(b b':B),
+ (if eqA_dec a a then b else b') = b.
+Proof.
+  intros; apply (decide_left (eqA_dec a a)); auto with *.
+Qed.
+
+(** PL: Inutilisable dans un rewrite sans un change prealable. *)
+
+Global Instance if_eqA (B:Type)(b b':B) :
+ Proper (eqA==>eqA==>@eq _) (fun x y => if eqA_dec x y then b else b').
+Proof.
+ intros x x' Hxx' y y' Hyy'.
+ intros; destruct (eqA_dec x y) as [H|H];
+  destruct (eqA_dec x' y') as [H'|H']; auto.
+ contradict H'; transitivity x; auto with *; transitivity y; auto with *.
+ contradict H; transitivity x'; auto with *; transitivity y'; auto with *.
+Qed.
+
+Fact if_eqA_rewrite_l : forall a1 a1' a2 (B:Type)(b b':B),
+ eqA a1 a1' -> (if eqA_dec a1 a2 then b else b') =
+               (if eqA_dec a1' a2 then b else b').
+Proof.
+ intros; destruct (eqA_dec a1 a2) as [A1|A1];
+  destruct (eqA_dec a1' a2) as [A1'|A1']; auto.
+ contradict A1'; transitivity a1; eauto with *.
+ contradict A1; transitivity a1'; eauto with *.
+Qed.
+
+Fact if_eqA_rewrite_r : forall a1 a2 a2' (B:Type)(b b':B),
+ eqA a2 a2' -> (if eqA_dec a1 a2 then b else b') =
+               (if eqA_dec a1 a2' then b else b').
+Proof.
+ intros; destruct (eqA_dec a1 a2) as [A2|A2];
+  destruct (eqA_dec a1 a2') as [A2'|A2']; auto.
+ contradict A2'; transitivity a2; eauto with *.
+ contradict A2; transitivity a2'; eauto with *.
+Qed.
+
+
+Global Instance multiplicity_eqA (l:list A) :
+ Proper (eqA==>@eq _) (multiplicity (list_contents l)).
+Proof.
+  intros x x' Hxx'.
+  induction l as [|y l Hl]; simpl; auto.
+  rewrite (@if_eqA_rewrite_r y x x'); auto.
+Qed.
+
+Lemma multiplicity_InA :
   forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a.
 Proof.
   induction l.
   simpl.
   split; inversion 1.
   simpl.
-  split; intros.
-  inversion_clear H.
-  destruct (eqA_dec a a0) as [_|H1]; auto with arith.
-  destruct H1; auto.
-  destruct (eqA_dec a a0); auto with arith.
-  simpl; rewrite <- IHl; auto.
-  destruct (eqA_dec a a0) as [H0|H0]; auto.
-  simpl in H.
-  constructor 2; rewrite IHl; auto.
+  intros a'; split; intros H. inversion_clear H.
+  apply (decide_left (eqA_dec a a')); auto with *.
+  destruct (eqA_dec a a'); auto with *. simpl; rewrite <- IHl; auto.
+  destruct (eqA_dec a a'); auto with *. right. rewrite IHl; auto.
 Qed.
 
 Lemma multiplicity_InA_O :
   forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0.
 Proof.
-  intros l a; rewrite multiplicity_InA; 
+  intros l a; rewrite multiplicity_InA;
     destruct (multiplicity (list_contents l) a); auto with arith.
   destruct 1; auto with arith.
 Qed.
@@ -65,7 +326,7 @@ Proof.
   intros l a; rewrite multiplicity_InA; auto with arith.
 Qed.
 
-Lemma multiplicity_NoDupA : forall l, 
+Lemma multiplicity_NoDupA : forall l,
   NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1).
 Proof.
   induction l.
@@ -74,46 +335,41 @@ Proof.
   split; simpl.
   inversion_clear 1.
   rewrite IHl in H1.
-  intros; destruct (eqA_dec a a0) as [H2|H2]; simpl; auto.
+  intros; destruct (eqA_dec a a0) as [EQ|NEQ]; simpl; auto with *.
+  rewrite <- EQ.
   rewrite multiplicity_InA_O; auto.
-  contradict H0.
-  apply InA_eqA with a0; auto.
   intros; constructor.
   rewrite multiplicity_InA.
-  generalize (H a).
-  destruct (eqA_dec a a) as [H0|H0].
-  destruct (multiplicity (list_contents l) a); auto with arith.
-  simpl; inversion 1. 
-  inversion H3.
-  destruct H0; auto.
+  specialize (H a).
+  rewrite if_eqA_refl in H.
+  clear IHl; omega.
   rewrite IHl; intros.
-  generalize (H a0); auto with arith.
-  destruct (eqA_dec a a0); simpl; auto with arith.
+  specialize (H a0); auto with *.
+  destruct (eqA_dec a a0); simpl; auto with *.
 Qed.
 
-
 (** Permutation is compatible with InA. *)
 Lemma permut_InA_InA :
   forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2.
 Proof.
   intros l1 l2 e.
   do 2 rewrite multiplicity_InA.
-  unfold Permutation.permutation, meq.
+  unfold permutation, meq.
   intros H;rewrite H; auto.
 Qed.
 
 Lemma permut_cons_InA :
   forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2.
 Proof.
-  intros; apply (permut_InA_InA (e:=e) H); auto.
+  intros; apply (permut_InA_InA (e:=e) H); auto with *.
 Qed.
 
 (** Permutation of an empty list. *)
 Lemma permut_nil :
-  forall l, permutation l nil -> l = nil.
+  forall l, permutation l [] -> l = [].
 Proof.
   intro l; destruct l as [ | e l ]; trivial.
-  assert (InA eqA e (e::l)) by auto.
+  assert (InA eqA e (e::l)) by (auto with *).
   intro Abs; generalize (permut_InA_InA Abs H).
   inversion 1.
 Qed.
@@ -121,16 +377,16 @@ Qed.
 (** Permutation for short lists. *)
 
 Lemma permut_length_1:
-  forall a b, permutation (a :: nil) (b :: nil)  -> eqA a b.
+  forall a b, permutation [a] [b] -> eqA a b.
 Proof.
-  intros a b; unfold Permutation.permutation, meq; intro P;
-  generalize (P b); clear P; simpl.
-  destruct (eqA_dec b b) as [H|H]; [ | destruct H; auto].
-  destruct (eqA_dec a b); simpl; auto; intros; discriminate.
+  intros a b; unfold permutation, meq.
+  intro P; specialize (P b); simpl in *.
+  rewrite if_eqA_refl in *.
+  destruct (eqA_dec a b); simpl; auto; discriminate.
 Qed.
 
 Lemma permut_length_2 :
-  forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
+  forall a1 b1 a2 b2, permutation [a1; b1] [a2; b2] ->
     (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1).
 Proof.
   intros a1 b1 a2 b2 P.
@@ -139,22 +395,19 @@ Proof.
   left; split; auto.
   apply permut_length_1.
   red; red; intros.
-  generalize (P a); clear P; simpl.
-  destruct (eqA_dec a1 a) as [H2|H2]; 
-    destruct (eqA_dec a2 a) as [H3|H3]; auto.
-  destruct H3; apply eqA_trans with a1; auto.
-  destruct H2; apply eqA_trans with a2; auto.
+  specialize (P a). simpl in *.
+  rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto.
+  (** Bug omega: le "set" suivant ne devrait pas etre necessaire *)
+  set (u:= if eqA_dec a2 a then 1 else 0) in *; omega.
   right.
   inversion_clear H0; [|inversion H].
   split; auto.
   apply permut_length_1.
   red; red; intros.
-  generalize (P a); clear P; simpl.
-  destruct (eqA_dec a1 a) as [H2|H2]; 
-    destruct (eqA_dec b2 a) as [H3|H3]; auto.
-  simpl; rewrite <- plus_n_Sm; inversion 1; auto.
-  destruct H3; apply eqA_trans with a1; auto.
-  destruct H2; apply eqA_trans with b2; auto.
+  specialize (P a); simpl in *.
+  rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto.
+  (** Bug omega: idem *)
+  set (u:= if eqA_dec b2 a then 1 else 0) in *; omega.
 Qed.
 
 (** Permutation is compatible with length. *)
@@ -171,68 +424,131 @@ Proof.
   rewrite <- app_length.
   apply IHl1.
   apply permut_remove_hd with b.
-  apply permut_tran with (a::l1); auto.
-  revert H1; unfold Permutation.permutation, meq; simpl.
+  apply permut_trans with (a::l1); auto.
+  revert H1; unfold permutation, meq; simpl.
   intros; f_equal; auto.
-  destruct (eqA_dec b a0) as [H2|H2]; 
-    destruct (eqA_dec a a0) as [H3|H3]; auto.
-  destruct H3; apply eqA_trans with b; auto.
-  destruct H2; apply eqA_trans with a; auto.
+  rewrite (@if_eqA_rewrite_l a b a0); auto.
 Qed.
 
-Lemma NoDupA_equivlistA_permut : 
-  forall l l', NoDupA eqA l -> NoDupA eqA l' -> 
+Lemma NoDupA_equivlistA_permut :
+  forall l l', NoDupA eqA l -> NoDupA eqA l' ->
     equivlistA eqA l l' -> permutation l l'.
 Proof.
   intros.
   red; unfold meq; intros.
-  rewrite multiplicity_NoDupA in H, H0. 
+  rewrite multiplicity_NoDupA in H, H0.
   generalize (H a) (H0 a) (H1 a); clear H H0 H1.
   do 2 rewrite multiplicity_InA.
   destruct 3; omega.
 Qed.
 
+End Permut.
+
+Section Permut_map.
+
+Variables A B : Type.
+
+Variable eqA : relation A.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+Hypothesis eqA_equiv : Equivalence eqA.
 
-Variable B : Type.
 Variable eqB : B->B->Prop.
-Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. 
-Variable eqB_trans : forall x y z, eqB x y -> eqB y z -> eqB x z.
+Hypothesis eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }.
+Hypothesis eqB_trans : Transitive eqB.
 
 (** Permutation is compatible with map. *)
 
 Lemma permut_map :
-  forall f, 
-    (forall x y, eqA x y -> eqB (f x) (f y)) ->
-    forall l1 l2, permutation l1 l2 -> 
-      Permutation.permutation _ eqB_dec (map f l1) (map f l2).
+  forall f,
+    (Proper (eqA==>eqB) f) ->
+    forall l1 l2, permutation _ eqA_dec l1 l2 ->
+      permutation _ eqB_dec (map f l1) (map f l2).
 Proof.
   intros f; induction l1.
-  intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
+  intros l2 P; rewrite (permut_nil eqA_equiv (permut_sym P)); apply permut_refl.
   intros l2 P.
   simpl.
-  assert (H0:=permut_cons_InA P).
+  assert (H0:=permut_cons_InA eqA_equiv P).
   destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))).
   subst l2.
   rewrite map_app.
   simpl.
-  apply permut_tran with (f b :: map f l1).
-  revert H1; unfold Permutation.permutation, meq; simpl.
+  apply permut_trans with (f b :: map f l1).
+  revert H1; unfold permutation, meq; simpl.
   intros; f_equal; auto.
-  destruct (eqB_dec (f b) a0) as [H2|H2]; 
+  destruct (eqB_dec (f b) a0) as [H2|H2];
     destruct (eqB_dec (f a) a0) as [H3|H3]; auto.
-  destruct H3; apply eqB_trans with (f b); auto.
-  destruct H2; apply eqB_trans with (f a); auto.
+  destruct H3; transitivity (f b); auto with *.
+  destruct H2; transitivity (f a); auto with *.
   apply permut_add_cons_inside.
   rewrite <- map_app.
   apply IHl1; auto.
-  apply permut_remove_hd with b.
-  apply permut_tran with (a::l1); auto.
-  revert H1; unfold Permutation.permutation, meq; simpl.
+  apply permut_remove_hd with b; trivial.
+  apply permut_trans with (a::l1); auto.
+  revert H1; unfold permutation, meq; simpl.
   intros; f_equal; auto.
-  destruct (eqA_dec b a0) as [H2|H2]; 
-    destruct (eqA_dec a a0) as [H3|H3]; auto.
-  destruct H3; apply eqA_trans with b; auto.
-  destruct H2; apply eqA_trans with a; auto.
+  rewrite (@if_eqA_rewrite_l _ _ eqA_equiv eqA_dec a b a0); auto.
 Qed.
 
-End Perm.
+End Permut_map.
+
+Require Import Permutation TheoryList.
+
+Section Permut_permut.
+
+Variable A : Type.
+
+Variable eqA : relation A.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+Hypothesis eqA_equiv : Equivalence eqA.
+
+Lemma Permutation_impl_permutation : forall l l',
+  Permutation l l' -> permutation _ eqA_dec l l'.
+Proof.
+  induction 1.
+    apply permut_refl.
+    apply permut_cons; auto using Equivalence_Reflexive.
+    change (x :: y :: l) with ([x] ++ y :: l);
+      apply permut_add_cons_inside; simpl;
+      apply permut_cons_eq; auto using Equivalence_Reflexive, permut_refl.
+    apply permut_trans with l'; trivial.
+Qed.
+
+Lemma permut_eqA : forall l l', Forall2 eqA l l' -> permutation _ eqA_dec l l'.
+Proof.
+  induction 1.
+    apply permut_refl.
+    apply permut_cons_eq; trivial.
+Qed.
+
+Lemma permutation_Permutation : forall l l',
+  permutation _ eqA_dec l l' <->
+  exists l'', Permutation l l'' /\ Forall2 eqA l'' l'.
+Proof.
+  split; intro H.
+  (* -> *)
+  induction l in l', H |- *.
+    exists []; apply permut_sym, permut_nil in H as ->; auto using Forall2.
+    pose proof H as H'.
+    apply permut_cons_InA, InA_split in H
+      as (l1 & y & l2 & Heq & ->); trivial.
+    apply permut_remove_hd_eq, IHl in H'
+      as (l'' & IHP & IHA); clear IHl; trivial.
+    apply Forall2_app_inv_r in IHA as (l1'' & l2'' & Hl1 & Hl2 & ->).
+    exists (l1'' ++ a :: l2''); split.
+      apply Permutation_cons_app; trivial.
+      apply Forall2_app, Forall2_cons; trivial.
+  (* <- *)
+  destruct H as (l'' & H & Heq).
+  apply permut_trans with l''.
+    apply Permutation_impl_permutation; trivial.
+    apply permut_eqA; trivial.
+Qed.
+
+End Permut_permut.
+
+(* begin hide *)
+(** For compatibilty *)
+Notation permut_right := permut_cons (only parsing).
+Notation permut_tran := permut_trans (only parsing).
+(* end hide *)
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index 82294b70..f3e62632 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -6,199 +6,373 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permutation.v 10698 2008-03-19 18:46:59Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import Relations List Multiset Arith.
+(*********************************************************************)
+(** ** List permutations as a composition of adjacent transpositions *)
+(*********************************************************************)
 
-(** This file define a notion of permutation for lists, based on multisets: 
-    there exists a permutation between two lists iff every elements have 
-    the same multiplicities in the two lists. 
+(* Adapted in May 2006 by Jean-Marc Notin from initial contents by
+   Laurent Théry (Huffmann contribution, October 2003) *)
 
-    Unlike [List.Permutation], the present notion of permutation requires
-    a decidable equality. At the same time, this definition can be used 
-    with a non-standard equality, whereas [List.Permutation] cannot.
-      
-    The present file contains basic results, obtained without any particular
-    assumption on the decidable equality used.
-	
-    File [PermutSetoid] contains additional results about permutations 
-    with respect to an setoid equality (i.e. an equivalence relation). 
-
-    Finally, file [PermutEq] concerns Coq equality : this file is similar 
-    to the previous one, but proves in addition that [List.Permutation]
-    and [permutation] are equivalent in this context.
-x*)
+Require Import List Setoid.
 
 Set Implicit Arguments.
 
-Section defs.
-
-  (** * From lists to multisets *)
-
-  Variable A : Type.
-  Variable eqA : relation A.
-  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
-
-  Let emptyBag := EmptyBag A.
-  Let singletonBag := SingletonBag _ eqA_dec.
-
-  (** contents of a list *)
-
-  Fixpoint list_contents (l:list A) : multiset A :=
-    match l with
-      | nil => emptyBag
-      | a :: l => munion (singletonBag a) (list_contents l)
-    end.
-
-  Lemma list_contents_app :
-    forall l m:list A,
-      meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)).
-  Proof.
-    simple induction l; simpl in |- *; auto with datatypes.
-    intros.
-    apply meq_trans with
-      (munion (singletonBag a) (munion (list_contents l0) (list_contents m)));
-      auto with datatypes.
-  Qed.
-
-  
-  (** * [permutation]: definition and basic properties *)
-  
-  Definition permutation (l m:list A) :=
-    meq (list_contents l) (list_contents m).
-
-  Lemma permut_refl : forall l:list A, permutation l l.
-  Proof.
-    unfold permutation in |- *; auto with datatypes.
-  Qed.
-  
-  Lemma permut_sym :
-    forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1.
-  Proof.
-    unfold permutation, meq; intros; apply sym_eq; trivial.
-  Qed.
-  
-  Lemma permut_tran :
-    forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
-  Proof.
-    unfold permutation in |- *; intros.
-    apply meq_trans with (list_contents m); auto with datatypes.
-  Qed.
-  
-  Lemma permut_cons :
-    forall l m:list A,
-      permutation l m -> forall a:A, permutation (a :: l) (a :: m).
-  Proof.
-    unfold permutation in |- *; simpl in |- *; auto with datatypes.
-  Qed.
-  
-  Lemma permut_app :
-    forall l l' m m':list A,
-      permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m').
-  Proof.
-    unfold permutation in |- *; intros.
-    apply meq_trans with (munion (list_contents l) (list_contents m)); 
-      auto using permut_cons, list_contents_app with datatypes.
-    apply meq_trans with (munion (list_contents l') (list_contents m')); 
-      auto using permut_cons, list_contents_app with datatypes.
-    apply meq_trans with (munion (list_contents l') (list_contents m));
-      auto using permut_cons, list_contents_app with datatypes.
-  Qed.
-
-  Lemma permut_add_inside :
-    forall a l1 l2 l3 l4, 
-      permutation (l1 ++ l2) (l3 ++ l4) ->
-      permutation (l1 ++ a :: l2) (l3 ++ a :: l4).
-  Proof.
-    unfold permutation, meq in *; intros.
-    generalize (H a0); clear H.
-    do 4 rewrite list_contents_app.
-    simpl.
-    destruct (eqA_dec a a0); simpl; auto with arith.
-    do 2 rewrite <- plus_n_Sm; f_equal; auto.
-  Qed.
-  
-  Lemma permut_add_cons_inside :
-    forall a l l1 l2, 
-      permutation l (l1 ++ l2) ->
-      permutation (a :: l) (l1 ++ a :: l2).
-  Proof.
-    intros;
-      replace (a :: l) with (nil ++ a :: l); trivial;
-	apply permut_add_inside; trivial.
-  Qed.
-
-  Lemma permut_middle :
-    forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m).
-  Proof.
-    intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl.
-  Qed.
-  
-  Lemma permut_sym_app :
-    forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
-  Proof.
-    intros l1 l2;
-      unfold permutation, meq; 
-	intro a; do 2 rewrite list_contents_app; simpl; 
-	  auto with arith.
-  Qed.
-
-  Lemma permut_rev : 
-    forall l, permutation l (rev l).
-  Proof.
-    induction l.
-    simpl; trivial using permut_refl.
-    simpl.
-    apply permut_add_cons_inside.
-    rewrite <- app_nil_end. trivial.
-  Qed.
-
-  (** * Some inversion results. *)
-  Lemma permut_conv_inv :
-    forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2.
-  Proof.
-    intros e l1 l2; unfold permutation, meq; simpl; intros H a;
-      generalize (H a); apply plus_reg_l.
-  Qed.
-
-  Lemma permut_app_inv1 : 
-    forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2.
-  Proof.
-    intros l l1 l2; unfold permutation, meq; simpl;
-      intros H a; generalize (H a); clear H.
-    do 2 rewrite list_contents_app.
-    simpl.
-    intros; apply plus_reg_l with (multiplicity (list_contents l) a).
-    rewrite plus_comm; rewrite H; rewrite plus_comm.
-    trivial.
-  Qed.
-
-  Lemma permut_app_inv2 : 
-    forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2.
-  Proof.
-    intros l l1 l2; unfold permutation, meq; simpl;
-      intros H a; generalize (H a); clear H.
-    do 2 rewrite list_contents_app.
-    simpl.
-    intros; apply plus_reg_l with (multiplicity (list_contents l) a).
-    trivial.
-  Qed.
-
-  Lemma permut_remove_hd :
-    forall l l1 l2 a,   
-      permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2).
-  Proof.
-    intros l l1 l2 a; unfold permutation, meq; simpl; intros H a0; generalize (H a0); clear H.
-    do 2 rewrite list_contents_app; simpl; intro H.
-    apply plus_reg_l with (if eqA_dec a a0 then 1 else 0).
-    rewrite H; clear H.
-    symmetry; rewrite plus_comm.
-    repeat rewrite <- plus_assoc; f_equal.
-    apply plus_comm.
-  Qed.
-
-End defs.
-
-(** For compatibilty *) 
-Notation permut_right := permut_cons.
-Unset Implicit Arguments.
+Local Notation "[ ]" := nil.
+Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).
+
+Section Permutation.
+
+Variable A:Type.
+
+Inductive Permutation : list A -> list A -> Prop :=
+| perm_nil: Permutation [] []
+| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l')
+| perm_swap x y l : Permutation (y::x::l) (x::y::l)
+| perm_trans l l' l'' : Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+
+Local Hint Constructors Permutation.
+
+(** Some facts about [Permutation] *)
+
+Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = [].
+Proof.
+  intros l HF.
+  remember (@nil A) as m in HF.
+  induction HF; discriminate || auto.
+Qed.
+
+Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l).
+Proof.
+  intros l x HF.
+  apply Permutation_nil in HF; discriminate.
+Qed.
+
+(** Permutation over lists is a equivalence relation *)
+
+Theorem Permutation_refl : forall l : list A, Permutation l l.
+Proof.
+  induction l; constructor. exact IHl.
+Qed.
+
+Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l.
+Proof.
+  intros l l' Hperm; induction Hperm; auto.
+  apply perm_trans with (l':=l'); assumption.
+Qed.
+
+Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+Proof.
+  exact perm_trans.
+Qed.
+
+End Permutation.
+
+Hint Resolve Permutation_refl perm_nil perm_skip.
+
+(* These hints do not reduce the size of the problem to solve and they
+   must be used with care to avoid combinatoric explosions *)
+
+Local Hint Resolve perm_swap perm_trans.
+Local Hint Resolve Permutation_sym Permutation_trans.
+
+(* This provides reflexivity, symmetry and transitivity and rewriting
+   on morphims to come *)
+
+Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := {
+  Equivalence_Reflexive := @Permutation_refl A ;
+  Equivalence_Symmetric := @Permutation_sym A ;
+  Equivalence_Transitive := @Permutation_trans A }.
+
+Add Parametric Morphism A (a:A) : (cons a)
+  with signature @Permutation A ==> @Permutation A
+  as Permutation_cons.
+Proof.
+  auto using perm_skip.
+Qed.
+
+Section Permutation_properties.
+
+Variable A:Type.
+
+Implicit Types a b : A.
+Implicit Types l m : list A.
+
+(** Compatibility with others operations on lists *)
+
+Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'.
+Proof.
+  intros l l' x Hperm; induction Hperm; simpl; tauto.
+Qed.
+
+Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl).
+Proof.
+  intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
+  eapply Permutation_trans with (l':=l'++tl); trivial.
+Qed.
+
+Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl').
+Proof.
+  intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
+Qed.
+
+Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
+Proof.
+  intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto.
+  apply Permutation_trans with (l' := (x :: y :: l ++ m));
+	[idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
+  apply Permutation_trans with (l' := (l' ++ m')); try assumption.
+  apply Permutation_app_tail; assumption.
+Qed.
+
+Add Parametric Morphism : (@app A)
+  with signature @Permutation A ==> @Permutation A ==> @Permutation A
+  as Permutation_app'.
+  auto using Permutation_app.
+Qed.
+
+Lemma Permutation_add_inside : forall a (l l' tl tl' : list A),
+  Permutation l l' -> Permutation tl tl' ->
+  Permutation (l ++ a :: tl) (l' ++ a :: tl').
+Proof.
+  intros; apply Permutation_app; auto.
+Qed.
+
+Theorem Permutation_app_comm : forall (l l' : list A),
+  Permutation (l ++ l') (l' ++ l).
+Proof.
+  induction l as [|x l]; simpl; intro l'.
+  rewrite app_nil_r; trivial.
+  induction l' as [|y l']; simpl.
+  rewrite app_nil_r; trivial.
+  transitivity (x :: y :: l' ++ l).
+  constructor; rewrite app_comm_cons; apply IHl.
+  transitivity (y :: x :: l' ++ l); constructor.
+  transitivity (x :: l ++ l'); auto.
+Qed.
+
+Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
+  Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
+Proof.
+  intros l l1; revert l.
+  induction l1.
+  simpl.
+  intros; apply perm_skip; auto.
+  simpl; intros.
+  transitivity (a0::a::l1++l2).
+  apply perm_skip; auto.
+  transitivity (a::a0::l1++l2).
+  apply perm_swap; auto.
+  apply perm_skip; auto.
+Qed.
+Local Hint Resolve Permutation_cons_app.
+
+Theorem Permutation_middle : forall (l1 l2:list A) a,
+  Permutation (a :: l1 ++ l2) (l1 ++ a :: l2).
+Proof.
+  auto.
+Qed.
+
+Theorem Permutation_rev : forall (l : list A), Permutation l (rev l).
+Proof.
+  induction l as [| x l]; simpl; trivial.
+  apply Permutation_trans with (l' := [x] ++ rev l).
+  simpl; auto.
+  apply Permutation_app_comm.
+Qed.
+
+Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'.
+Proof.
+  intros l l' Hperm; induction Hperm; simpl; auto.
+  apply trans_eq with (y:= (length l')); trivial.
+Qed.
+
+Theorem Permutation_ind_bis :
+ forall P : list A -> list A -> Prop,
+   P [] [] ->
+   (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
+   (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
+   (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
+   forall l l', Permutation l l' -> P l l'.
+Proof.
+  intros P Hnil Hskip Hswap Htrans.
+  induction 1; auto.
+  apply Htrans with (x::y::l); auto.
+  apply Hswap; auto.
+  induction l; auto.
+  apply Hskip; auto.
+  apply Hskip; auto.
+  induction l; auto.
+  eauto.
+Qed.
+
+Ltac break_list l x l' H :=
+  destruct l as [|x l']; simpl in *;
+  injection H; intros; subst; clear H.
+
+Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
+  Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
+Proof.
+  set (P l l' :=
+         forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)).
+  cut (forall l l', Permutation l l' -> P l l').
+  intros; apply (H _ _ H0 a); auto.
+  intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto.
+(* nil *)
+  intros; destruct l1; simpl in *; discriminate.
+  (* skip *)
+  intros x l l' H IH; intros.
+  break_list l1 b l1' H0; break_list l3 c l3' H1.
+  auto.
+  apply perm_trans with (l3'++c::l4); auto.
+  apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app.
+  apply perm_skip.
+  apply (IH a l1' l2 l3' l4); auto.
+  (* contradict *)
+  intros x y l l' Hp IH; intros.
+  break_list l1 b l1' H; break_list l3 c l3' H0.
+  auto.
+  break_list l3' b l3'' H.
+  auto.
+  apply perm_trans with (c::l3''++b::l4); auto.
+  break_list l1' c l1'' H1.
+  auto.
+  apply perm_trans with (b::l1''++c::l2); auto.
+  break_list l3' d l3'' H; break_list l1' e l1'' H1.
+  auto.
+  apply perm_trans with (e::a::l1''++l2); auto.
+  apply perm_trans with (e::l1''++a::l2); auto.
+  apply perm_trans with (d::a::l3''++l4); auto.
+  apply perm_trans with (d::l3''++a::l4); auto.
+  apply perm_trans with (e::d::l1''++l2); auto.
+  apply perm_skip; apply perm_skip.
+  apply (IH a l1'' l2 l3'' l4); auto.
+  (*trans*)
+  intros.
+  destruct (In_split a l') as (l'1,(l'2,H6)).
+  apply (Permutation_in a H).
+  subst l.
+  apply in_or_app; right; red; auto.
+  apply perm_trans with (l'1++l'2).
+  apply (H0 _ _ _ _ _ H3 H6).
+  apply (H2 _ _ _ _ _ H6 H4).
+Qed.
+
+Theorem Permutation_cons_inv :
+   forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'.
+Proof.
+  intros; exact (Permutation_app_inv [] l [] l' a H).
+Qed.
+
+Theorem Permutation_cons_app_inv :
+   forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
+Proof.
+  intros; exact (Permutation_app_inv [] l l1 l2 a H).
+Qed.
+
+Theorem Permutation_app_inv_l :
+    forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
+Proof.
+  induction l; simpl; auto.
+  intros.
+  apply IHl.
+  apply Permutation_cons_inv with a; auto.
+Qed.
+
+Theorem Permutation_app_inv_r :
+   forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
+Proof.
+  induction l.
+  intros l1 l2; do 2 rewrite app_nil_r; auto.
+  intros.
+  apply IHl.
+  apply Permutation_app_inv with a; auto.
+Qed.
+
+Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a].
+Proof.
+  intros a l H; remember [a] as m in H.
+  induction H; try (injection Heqm as -> ->; clear Heqm);
+    discriminate || auto.
+  apply Permutation_nil in H as ->; trivial.
+Qed.
+
+Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b.
+Proof.
+  intros a b H.
+  apply Permutation_length_1_inv in H; injection H as ->; trivial.
+Qed.
+
+Lemma Permutation_length_2_inv :
+  forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1].
+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);
+    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 ();
+    auto.
+Qed.
+
+Lemma Permutation_length_2 :
+  forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] ->
+    a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1.
+Proof.
+  intros a1 b1 a2 b2 H.
+  apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto.
+Qed.
+
+Lemma NoDup_Permutation : forall l l',
+  NoDup l -> NoDup l' -> (forall x:A, In x l <-> In x l') -> Permutation l l'.
+Proof.
+  induction l.
+  destruct l'; simpl; intros.
+  apply perm_nil.
+  destruct (H1 a) as (_,H2); destruct H2; auto.
+  intros.
+  destruct (In_split a l') as (l'1,(l'2,H2)).
+  destruct (H1 a) as (H2,H3); simpl in *; auto.
+  subst l'.
+  apply Permutation_cons_app.
+  inversion_clear H.
+  apply IHl; auto.
+  apply NoDup_remove_1 with a; auto.
+  intro x; split; intros.
+  assert (In x (l'1++a::l'2)).
+   destruct (H1 x); simpl in *; auto.
+  apply in_or_app; destruct (in_app_or _ _ _ H4); auto.
+  destruct H5; auto.
+  subst x; destruct H2; auto.
+  assert (In x (l'1++a::l'2)).
+    apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto.
+  destruct (H1 x) as (_,H5); destruct H5; auto.
+  subst x.
+  destruct (NoDup_remove_2 _ _ _ H0 H).
+Qed.
+
+End Permutation_properties.
+
+Section Permutation_map.
+
+Variable A B : Type.
+Variable f : A -> B.
+
+Add Parametric Morphism : (map f)
+  with signature (@Permutation A) ==> (@Permutation B) as Permutation_map_aux.
+Proof.
+  induction 1; simpl; eauto using Permutation.
+Qed.
+
+Lemma Permutation_map :
+  forall l l', Permutation l l' -> Permutation (map f l) (map f l').
+Proof.
+  exact Permutation_map_aux_Proper.
+Qed.
+
+End Permutation_map.
+
+(* begin hide *)
+Notation Permutation_app_swap := Permutation_app_comm (only parsing).
+(* end hide *)
diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v
new file mode 100644
index 00000000..2b9f59f0
--- /dev/null
+++ b/theories/Sorting/Sorted.v
@@ -0,0 +1,154 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(* Made by Hugo Herbelin *)
+
+(** This file defines two notions of sorted list:
+
+  - a list is locally sorted if any element is smaller or equal than
+    its successor in the list
+  - a list is sorted if any element coming before another one is
+    smaller or equal than this other element
+
+  The two notions are equivalent if the order is transitive.
+*)
+
+Require Import List Relations Relations_1.
+
+(** Preambule *)
+
+Set Implicit Arguments.
+Local Notation "[ ]" := nil (at level 0).
+Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0).
+Implicit Arguments Transitive [U].
+
+Section defs.
+
+  Variable A : Type.
+  Variable R : A -> A -> Prop.
+
+  (** Locally sorted: consecutive elements of the list are ordered *)
+
+  Inductive LocallySorted : list A -> Prop :=
+    | LSorted_nil : LocallySorted []
+    | LSorted_cons1 a : LocallySorted [a]
+    | LSorted_consn a b l :
+        LocallySorted (b :: l) -> R a b -> LocallySorted (a :: b :: l).
+
+  (** Alternative two-step definition of being locally sorted *)
+
+  Inductive HdRel a : list A -> Prop :=
+    | HdRel_nil : HdRel a []
+    | HdRel_cons b l : R a b -> HdRel a (b :: l).
+
+  Inductive Sorted : list A -> Prop :=
+    | Sorted_nil : Sorted []
+    | Sorted_cons a l : Sorted l -> HdRel a l -> Sorted (a :: l).
+
+  Lemma HdRel_inv : forall a b l, HdRel a (b :: l) -> R a b.
+  Proof.
+    inversion 1; auto.
+  Qed.
+
+  Lemma Sorted_inv :
+    forall a l, Sorted (a :: l) -> Sorted l /\ HdRel a l.
+  Proof.
+    intros a l H; inversion H; auto.
+  Qed.
+
+  Lemma Sorted_rect :
+    forall P:list A -> Type,
+      P [] ->
+      (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) ->
+      forall l:list A, Sorted l -> P l.
+  Proof.
+    induction l; firstorder using Sorted_inv.
+  Qed.
+
+  Lemma Sorted_LocallySorted_iff : forall l, Sorted l <-> LocallySorted l.
+  Proof.
+    split; [induction 1 as [|a l [|]]| induction 1];
+      auto using Sorted, LocallySorted, HdRel.
+    inversion H1; subst; auto using LocallySorted.
+  Qed.
+
+  (** Strongly sorted: elements of the list are pairwise ordered *)
+
+  Inductive StronglySorted : list A -> Prop :=
+    | SSorted_nil : StronglySorted []
+    | SSorted_cons a l : StronglySorted l -> Forall (R a) l -> StronglySorted (a :: l).
+
+  Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) ->
+    StronglySorted l /\ Forall (R a) l.
+  Proof.
+    intros; inversion H; auto.
+  Defined.
+
+  Lemma StronglySorted_rect :
+    forall P:list A -> Type,
+      P [] ->
+      (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) ->
+      forall l, StronglySorted l -> P l.
+  Proof.
+    induction l; firstorder using StronglySorted_inv.
+  Defined.
+
+  Lemma StronglySorted_rec :
+    forall P:list A -> Type,
+      P [] ->
+      (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) ->
+      forall l, StronglySorted l -> P l.
+  Proof.
+    firstorder using StronglySorted_rect.
+  Qed.
+
+  Lemma StronglySorted_Sorted : forall l, StronglySorted l -> Sorted l.
+  Proof.
+    induction 1 as [|? ? ? ? HForall]; constructor; trivial.
+    destruct HForall; constructor; trivial.
+  Qed.
+
+  Lemma Sorted_extends :
+    Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l.
+  Proof.
+    intros. change match a :: l with [] => True | a :: l => Forall (R a) l end.
+    induction H0 as [|? ? ? ? H1]; [trivial|].
+    destruct H1; constructor; trivial.
+    eapply Forall_impl; [|eassumption].
+    firstorder.
+  Qed.
+
+  Lemma Sorted_StronglySorted :
+    Transitive R -> forall l, Sorted l -> StronglySorted l.
+  Proof.
+    induction 2; constructor; trivial.
+    apply Sorted_extends; trivial.
+    constructor; trivial.
+  Qed.
+
+End defs.
+
+Hint Constructors HdRel.
+Hint Constructors Sorted.
+
+(* begin hide *)
+(* Compatibility with deprecated file Sorting.v *)
+Notation lelistA := HdRel (only parsing).
+Notation nil_leA := HdRel_nil (only parsing).
+Notation cons_leA := HdRel_cons (only parsing).
+
+Notation sort := Sorted (only parsing).
+Notation nil_sort := Sorted_nil (only parsing).
+Notation cons_sort := Sorted_cons (only parsing).
+
+Notation lelistA_inv := HdRel_inv (only parsing).
+Notation sort_inv := Sorted_inv (only parsing).
+Notation sort_rect := Sorted_rect (only parsing).
+(* end hide *)
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
index aed8cd15..5f8da6a4 100644
--- a/theories/Sorting/Sorting.v
+++ b/theories/Sorting/Sorting.v
@@ -6,125 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sorting.v 10698 2008-03-19 18:46:59Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import List Multiset Permutation Relations.
-
-Set Implicit Arguments.
-
-Section defs.
-
-  Variable A : Type.
-  Variable leA : relation A.
-  Variable eqA : relation A.
-
-  Let gtA (x y:A) := ~ leA x y.
-  
-  Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
-  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
-  Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
-  Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
-  Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
-
-  Hint Resolve leA_refl.
-  Hint Immediate eqA_dec leA_dec leA_antisym.
-
-  Let emptyBag := EmptyBag A.
-  Let singletonBag := SingletonBag _ eqA_dec.
-
-  (** [lelistA] *)
-
-  Inductive lelistA (a:A) : list A -> Prop :=
-    | nil_leA : lelistA a nil
-    | cons_leA : forall (b:A) (l:list A), leA a b -> lelistA a (b :: l).
-
-  Lemma lelistA_inv : forall (a b:A) (l:list A), lelistA a (b :: l) -> leA a b.
-  Proof.
-    intros; inversion H; trivial with datatypes.
-  Qed.
-
-  (** * Definition for a list to be sorted *)
-
-  Inductive sort : list A -> Prop :=
-    | nil_sort : sort nil
-    | cons_sort :
-      forall (a:A) (l:list A), sort l -> lelistA a l -> sort (a :: l).
-
-  Lemma sort_inv :
-    forall (a:A) (l:list A), sort (a :: l) -> sort l /\ lelistA a l.
-  Proof.
-    intros; inversion H; auto with datatypes.
-  Qed.
-
-  Lemma sort_rect :
-    forall P:list A -> Type,
-      P nil ->
-      (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) ->
-      forall y:list A, sort y -> P y.
-  Proof.
-    simple induction y; auto with datatypes.
-    intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes.
-  Qed.
-
-  Lemma sort_rec :
-    forall P:list A -> Set,
-      P nil ->
-      (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) ->
-      forall y:list A, sort y -> P y.
-  Proof.
-    simple induction y; auto with datatypes.
-    intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes.
-  Qed.
-
-  (** * Merging two sorted lists *)
-
-  Inductive merge_lem (l1 l2:list A) : Type :=
-    merge_exist :
-    forall l:list A,
-      sort l ->
-      meq (list_contents _ eqA_dec l)
-      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
-      (forall a:A, lelistA a l1 -> lelistA a l2 -> lelistA a l) ->
-      merge_lem l1 l2.
-
-  Lemma merge :
-    forall l1:list A, sort l1 -> forall l2:list A, sort l2 -> merge_lem l1 l2.
-  Proof.
-    simple induction 1; intros.
-    apply merge_exist with l2; auto with datatypes.
-    elim H2; intros.
-    apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes.
-    elim (leA_dec a a0); intros.
-
-    (* 1 (leA a a0) *)
-    cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes.
-    intros [l3 l3sorted l3contents Hrec].
-    apply merge_exist with (a :: l3); simpl in |- *;
-      auto using cons_sort, cons_leA with datatypes.
-    apply meq_trans with
-      (munion (singletonBag a)
-	(munion (list_contents _ eqA_dec l)
-          (list_contents _ eqA_dec (a0 :: l0)))).
-    apply meq_right; trivial with datatypes.
-    apply meq_sym; apply munion_ass.
-    intros; apply cons_leA.
-    apply lelistA_inv with l; trivial with datatypes.
-
-    (* 2 (leA a0 a) *)
-    elim X0; simpl in |- *; intros.
-    apply merge_exist with (a0 :: l3); simpl in |- *; 
-      auto using cons_sort, cons_leA with datatypes.
-    apply meq_trans with
-      (munion (singletonBag a0)
-	(munion (munion (singletonBag a) (list_contents _ eqA_dec l))
-          (list_contents _ eqA_dec l0))).
-    apply meq_right; trivial with datatypes.
-    apply munion_perm_left.
-    intros; apply cons_leA; apply lelistA_inv with l0; trivial with datatypes.
-  Qed.
-
-End defs.
-
-Unset Implicit Arguments.
-Hint Constructors sort: datatypes v62.
-Hint Constructors lelistA: datatypes v62.
+Require Export Sorted.
+Require Export Mergesort.
diff --git a/theories/Sorting/vo.itarget b/theories/Sorting/vo.itarget
new file mode 100644
index 00000000..079eaad1
--- /dev/null
+++ b/theories/Sorting/vo.itarget
@@ -0,0 +1,7 @@
+Heap.vo
+Permutation.vo
+PermutSetoid.vo
+PermutEq.vo
+Sorted.vo
+Sorting.vo
+Mergesort.vo
diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v
index 1c02be7f..9e760d21 100644
--- a/theories/Strings/Ascii.v
+++ b/theories/Strings/Ascii.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,39 +7,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ascii.v 9245 2006-10-17 12:53:34Z notin $ *)
+(* $Id$ *)
 
-(** Contributed by Laurent Théry (INRIA);
+(** Contributed by Laurent Théry (INRIA);
     Adapted to Coq V8 by the Coq Development Team *)
 
-Require Import Bool.
-Require Import BinPos.
+Require Import Bool BinPos BinNat Nnat.
+Declare ML Module "ascii_syntax_plugin".
 
 (** * Definition of ascii characters *)
 
 (** Definition of ascii character as a 8 bits constructor *)
- 
+
 Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool).
 
 Delimit Scope char_scope with char.
 Bind Scope char_scope with ascii.
- 
+
 Definition zero := Ascii false false false false false false false false.
- 
+
 Definition one := Ascii true false false false false false false false.
- 
-Definition app1 (f : bool -> bool) (a : ascii) :=
-  match a with
-    | Ascii a1 a2 a3 a4 a5 a6 a7 a8 =>
-      Ascii (f a1) (f a2) (f a3) (f a4) (f a5) (f a6) (f a7) (f a8)
-  end.
- 
-Definition app2 (f : bool -> bool -> bool) (a b : ascii) :=
-  match a, b with
-    | Ascii a1 a2 a3 a4 a5 a6 a7 a8, Ascii b1 b2 b3 b4 b5 b6 b7 b8 =>
-      Ascii (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4) 
-      (f a5 b5) (f a6 b6) (f a7 b7) (f a8 b8)
-  end.
 
 Definition shift (c : bool) (a : ascii) :=
   match a with
@@ -46,7 +34,7 @@ Definition shift (c : bool) (a : ascii) :=
   end.
 
 (** Definition of a decidable function that is effective *)
- 
+
 Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}.
   decide equality; apply bool_dec.
 Defined.
@@ -54,60 +42,85 @@ Defined.
 (** * Conversion between natural numbers modulo 256 and ascii characters *)
 
 (** Auxillary function that turns a positive into an ascii by
-   looking at the last n bits, ie z mod 2^n *)
-
-Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) 
-  (n : nat) {struct n} : ascii :=
+   looking at the last 8 bits, ie z mod 2^8 *)
+
+Definition ascii_of_pos : positive -> ascii :=
+ let loop := fix loop n p :=
+   match n with
+     | O => zero
+     | S n' =>
+       match p with
+         | xH => one
+         | xI p' => shift true (loop n' p')
+         | xO p' => shift false (loop n' p')
+       end
+   end
+ in loop 8.
+
+(** Conversion from [N] to [ascii] *)
+
+Definition ascii_of_N (n : N) :=
   match n with
-    | O => res
-    | S n1 =>
-      match z with
-	| xH => app2 orb res acc
-	| xI z' => ascii_of_pos_aux (app2 orb res acc) (shift false acc) z' n1
-	| xO z' => ascii_of_pos_aux res (shift false acc) z' n1
-      end
+    | N0 => zero
+    | Npos p => ascii_of_pos p
   end.
 
+(** Same for [nat] *)
 
-(** Function that turns a positive into an ascii by
-    looking at the last 8 bits, ie a mod 8 *)
- 
-Definition ascii_of_pos (a : positive) := ascii_of_pos_aux zero one a 8.
+Definition ascii_of_nat (a : nat) := ascii_of_N (N_of_nat a).
 
-(** Function that turns a Peano number into an ascii by converting it
-    to positive *)
+(** The opposite functions *)
 
-Definition ascii_of_nat (a : nat) :=
-  match a with
-    | O => zero
-    | S a' => ascii_of_pos (P_of_succ_nat a')
-  end.
- 
-(** The opposite function *)
-
-Definition nat_of_ascii (a : ascii) : nat :=
-  let (a1, a2, a3, a4, a5, a6, a7, a8) := a in
-    2 *
-    (2 *
-      (2 *
-        (2 *
-          (2 *
-            (2 *
-              (2 * (if a8 then 1 else 0)
-		+ (if a7 then 1 else 0))
-              + (if a6 then 1 else 0))
-            + (if a5 then 1 else 0))
-          + (if a4 then 1 else 0))
-        + (if a3 then 1 else 0))
-      + (if a2 then 1 else 0))
-    + (if a1 then 1 else 0).
-
-Theorem ascii_nat_embedding : 
+Local Open Scope list_scope.
+
+Fixpoint N_of_digits (l:list bool) : N :=
+ match l with
+  | nil => 0
+  | b :: l' => (if b then 1 else 0) + 2*(N_of_digits l')
+ end%N.
+
+Definition N_of_ascii (a : ascii) : N :=
+ let (a0,a1,a2,a3,a4,a5,a6,a7) := a in
+ N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil).
+
+Definition nat_of_ascii (a : ascii) : nat := nat_of_N (N_of_ascii a).
+
+(** Proofs that we have indeed opposite function (below 256) *)
+
+Theorem ascii_N_embedding :
+  forall a : ascii, ascii_of_N (N_of_ascii a) = a.
+Proof.
+  destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity.
+Qed.
+
+Theorem N_ascii_embedding :
+  forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n.
+Proof.
+destruct n.
+reflexivity.
+do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]);
+ intro H; vm_compute in H; destruct p; discriminate.
+Qed.
+
+Theorem ascii_nat_embedding :
   forall a : ascii, ascii_of_nat (nat_of_ascii a) = a.
 Proof.
   destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity.
 Qed.
 
+Theorem nat_ascii_embedding :
+  forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n.
+Proof.
+ intros. unfold nat_of_ascii, ascii_of_nat.
+ rewrite N_ascii_embedding.
+ apply nat_of_N_of_nat.
+ unfold Nlt.
+ change 256%N with (N_of_nat 256).
+ rewrite <- N_of_nat_compare.
+ rewrite <- Compare_dec.nat_compare_lt. auto.
+Qed.
+
+
 (** * Concrete syntax *)
 
 (**
@@ -123,7 +136,7 @@ Qed.
   Notice that the ascii characters of code >= 128 do not denote
   stand-alone utf8 characters so that only the notation "nnn" is
   available for them (unless your terminal is able to represent them,
-  which is typically not the case in coqide). 
+  which is typically not the case in coqide).
 *)
 
 Open Local Scope char_scope.
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index 00f28a9c..15f29821 100644
--- a/theories/Strings/String.v
+++ b/theories/Strings/String.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,18 +7,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: String.v 11206 2008-07-04 16:21:28Z letouzey $ *)
+(* $Id$ *)
 
-(** Contributed by Laurent Théry (INRIA);
+(** Contributed by Laurent Théry (INRIA);
     Adapted to Coq V8 by the Coq Development Team *)
 
 Require Import Arith.
 Require Import Ascii.
+Declare ML Module "string_syntax_plugin".
 
 (** *** Definition of strings *)
 
 (** Implementation of string as list of ascii characters *)
- 
+
 Inductive string : Set :=
   | EmptyString : string
   | String : ascii -> string -> string.
@@ -36,7 +38,7 @@ Defined.
 
 Reserved Notation "x ++ y" (right associativity, at level 60).
 
-Fixpoint append (s1 s2 : string) {struct s1} : string :=
+Fixpoint append (s1 s2 : string) : string :=
   match s1 with
   | EmptyString => s2
   | String c s1' => String c (s1' ++ s2)
@@ -47,7 +49,7 @@ where "s1 ++ s2" := (append s1 s2) : string_scope.
 (******************************)
 (** Length                    *)
 (******************************)
- 
+
 Fixpoint length (s : string) : nat :=
   match s with
   | EmptyString => 0
@@ -57,7 +59,7 @@ Fixpoint length (s : string) : nat :=
 (******************************)
 (** Nth character of a string *)
 (******************************)
- 
+
 Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
   match s with
   | EmptyString => None
@@ -68,7 +70,7 @@ Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
   end.
 
 (** Two lists that are identical through get are syntactically equal *)
- 
+
 Theorem get_correct :
   forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
 Proof.
@@ -89,7 +91,7 @@ rewrite H1; auto.
 Qed.
 
 (** The first elements of [s1 ++ s2] are the ones of [s1] *)
- 
+
 Theorem append_correct1 :
  forall (s1 s2 : string) (n : nat),
  n < length s1 -> get n s1 = get n (s1 ++ s2).
@@ -102,7 +104,7 @@ apply lt_S_n; auto.
 Qed.
 
 (** The last elements of [s1 ++ s2] are the ones of [s2] *)
- 
+
 Theorem append_correct2 :
  forall (s1 s2 : string) (n : nat),
  get n s2 = get (n + length s1) (s1 ++ s2).
@@ -119,8 +121,8 @@ Qed.
 (** [substring n m s] returns the substring of [s] that starts
     at position [n] and of length [m];
     if this does not make sense it returns [""] *)
- 
-Fixpoint substring (n m : nat) (s : string) {struct s} : string :=
+
+Fixpoint substring (n m : nat) (s : string) : string :=
   match n, m, s with
   | 0, 0, _ => EmptyString
   | 0, S m', EmptyString => s
@@ -130,7 +132,7 @@ Fixpoint substring (n m : nat) (s : string) {struct s} : string :=
   end.
 
 (** The substring is included in the initial string *)
- 
+
 Theorem substring_correct1 :
  forall (s : string) (n m p : nat),
  p < m -> get p (substring n m s) = get (p + n) s.
@@ -148,7 +150,7 @@ intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
 Qed.
 
 (** The substring has at most [m] elements *)
- 
+
 Theorem substring_correct2 :
  forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
 Proof.
@@ -166,7 +168,7 @@ Qed.
 (** *** Test functions *)
 
 (** Test if [s1] is a prefix of [s2] *)
- 
+
 Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
   match s1 with
   | EmptyString => true
@@ -183,7 +185,7 @@ Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
 
 (** If [s1] is a prefix of [s2], it is the [substring] of length
     [length s1] starting at position [O] of [s2] *)
- 
+
 Theorem prefix_correct :
  forall s1 s2 : string,
  prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
@@ -202,8 +204,8 @@ Qed.
 
 (** Test if, starting at position [n], [s1] occurs in [s2]; if
     so it returns the position *)
- 
-Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat :=
+
+Fixpoint index (n : nat) (s1 s2 : string) : option nat :=
   match s2, n with
   | EmptyString, 0 =>
       match s1 with
@@ -211,7 +213,7 @@ Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat :=
       | String a s1' => None
       end
   | EmptyString, S n' => None
-  | String b s2', 0 => 
+  | String b s2', 0 =>
       if prefix s1 s2 then Some 0
       else
         match index 0 s1 s2' with
@@ -229,7 +231,7 @@ Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat :=
 Opaque prefix.
 
 (** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)
- 
+
 Theorem index_correct1 :
  forall (n m : nat) (s1 s2 : string),
  index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
@@ -259,9 +261,9 @@ intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
 intros; discriminate.
 Qed.
 
-(** If the result of [index] is [Some m], 
+(** If the result of [index] is [Some m],
     [s1] does not occur in [s2] before [m] *)
- 
+
 Theorem index_correct2 :
  forall (n m : nat) (s1 s2 : string),
  index n s1 s2 = Some m ->
@@ -304,9 +306,9 @@ apply Lt.lt_S_n; auto.
 intros; discriminate.
 Qed.
 
-(** If the result of [index] is [None], [s1] does not occur in [s2] 
+(** If the result of [index] is [None], [s1] does not occur in [s2]
     after [n] *)
- 
+
 Theorem index_correct3 :
  forall (n m : nat) (s1 s2 : string),
  index n s1 s2 = None ->
@@ -348,7 +350,7 @@ Transparent prefix.
 
 (** If we are searching for the [Empty] string and the answer is no
     this means that [n] is greater than the size of [s] *)
- 
+
 Theorem index_correct4 :
  forall (n : nat) (s : string),
  index n EmptyString s = None -> length s < n.
@@ -367,7 +369,7 @@ Qed.
 
 (** Same as [index] but with no optional type, we return [0] when it
     does not occur *)
- 
+
 Definition findex n s1 s2 :=
   match index n s1 s2 with
   | Some n => n
diff --git a/theories/Strings/vo.itarget b/theories/Strings/vo.itarget
new file mode 100644
index 00000000..20813b42
--- /dev/null
+++ b/theories/Strings/vo.itarget
@@ -0,0 +1,2 @@
+Ascii.vo
+String.vo
diff --git a/theories/Logic/DecidableType.v b/theories/Structures/DecidableType.v
index a65e2c52..2c72e30b 100644
--- a/theories/Logic/DecidableType.v
+++ b/theories/Structures/DecidableType.v
@@ -6,47 +6,24 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: DecidableType.v 10616 2008-03-04 17:33:35Z letouzey $ *)
+(* $Id$ *)
 
 Require Export SetoidList.
+Require Equalities.
+
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(** * Types with Equalities, and nothing more (for subtyping purpose) *)
-
-Module Type EqualityType. 
-
-  Parameter Inline t : Type.
-
-  Parameter Inline eq : t -> t -> Prop.
+(** NB: This file is here only for compatibility with earlier version of
+    [FSets] and [FMap]. Please use [Structures/Equalities.v] directly now. *)
 
-  Axiom eq_refl : forall x : t, eq x x.
-  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
-  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
-
-  Hint Immediate eq_sym.
-  Hint Resolve eq_refl eq_trans.
+(** * Types with Equalities, and nothing more (for subtyping purpose) *)
 
-End EqualityType. 
+Module Type EqualityType := Equalities.EqualityTypeOrig.
 
 (** * Types with decidable Equalities (but no ordering) *)
 
-Module Type DecidableType. 
-
-  Parameter Inline t : Type.
-
-  Parameter Inline eq : t -> t -> Prop.
-
-  Axiom eq_refl : forall x : t, eq x x.
-  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
-  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
-
-  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
-
-  Hint Immediate eq_sym.
-  Hint Resolve eq_refl eq_trans.
-
-End DecidableType. 
+Module Type DecidableType := Equalities.DecidableTypeOrig.
 
 (** * Additional notions about keys and datas used in FMap *)
 
@@ -58,21 +35,21 @@ Module KeyDecidableType(D:DecidableType).
  Notation key:=t.
 
   Definition eqk (p p':key*elt) := eq (fst p) (fst p').
-  Definition eqke (p p':key*elt) := 
+  Definition eqke (p p':key*elt) :=
           eq (fst p) (fst p') /\ (snd p) = (snd p').
 
   Hint Unfold eqk eqke.
   Hint Extern 2 (eqke ?a ?b) => split.
 
    (* eqke is stricter than eqk *)
- 
+
    Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
    Proof.
      unfold eqk, eqke; intuition.
    Qed.
 
   (* eqk, eqke are equalities *)
- 
+
   Lemma eqk_refl : forall e, eqk e e.
   Proof. auto. Qed.
 
@@ -96,7 +73,13 @@ Module KeyDecidableType(D:DecidableType).
   Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
   Hint Immediate eqk_sym eqke_sym.
 
-  Lemma InA_eqke_eqk : 
+  Global Instance eqk_equiv : Equivalence eqk.
+  Proof. split; eauto. Qed.
+
+  Global Instance eqke_equiv : Equivalence eqke.
+  Proof. split; eauto. Qed.
+
+  Lemma InA_eqke_eqk :
      forall x m, InA eqke x m -> InA eqk x m.
   Proof.
     unfold eqke; induction 1; intuition.
@@ -105,7 +88,7 @@ Module KeyDecidableType(D:DecidableType).
 
   Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
   Proof.
-   intros; apply InA_eqA with p; auto; apply eqk_trans; auto.
+   intros; apply InA_eqA with p; auto with *.
   Qed.
 
   Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
@@ -128,28 +111,28 @@ Module KeyDecidableType(D:DecidableType).
 
   Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
   Proof.
-  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto.
+  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *.
   Qed.
 
   Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
   Proof.
   destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
-  Qed. 
+  Qed.
 
   Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
   Proof.
     inversion 1.
     inversion_clear H0; eauto.
     destruct H1; simpl in *; intuition.
-  Qed.      
+  Qed.
 
-  Lemma In_inv_2 : forall k k' e e' l, 
+  Lemma In_inv_2 : forall k k' e e' l,
       InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
-  Proof.  
+  Proof.
    inversion_clear 1; compute in H0; intuition.
   Qed.
 
-  Lemma In_inv_3 : forall x x' l, 
+  Lemma In_inv_3 : forall x x' l,
       InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
   Proof.
    inversion_clear 1; compute in H0; intuition.
diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v
index 9c59c519..4407ead4 100644
--- a/theories/Logic/DecidableTypeEx.v
+++ b/theories/Structures/DecidableTypeEx.v
@@ -6,25 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: DecidableTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(* $Id$ *)
 
 Require Import DecidableType OrderedType OrderedTypeEx.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+(** NB: This file is here only for compatibility with earlier version of
+    [FSets] and [FMap]. Please use [Structures/Equalities.v] directly now. *)
+
 (** * Examples of Decidable Type structures. *)
 
-(** A particular case of [DecidableType] where 
+(** A particular case of [DecidableType] where
     the equality is the usual one of Coq. *)
 
-Module Type UsualDecidableType.
- Parameter Inline t : Type.
- Definition eq := @eq t.
- Definition eq_refl := @refl_equal t.
- Definition eq_sym := @sym_eq t.
- Definition eq_trans := @trans_eq t.
- Parameter eq_dec : forall x y, { eq x y }+{~eq x y }.
-End UsualDecidableType.
+Module Type UsualDecidableType := Equalities.UsualDecidableTypeOrig.
 
 (** a [UsualDecidableType] is in particular an [DecidableType]. *)
 
@@ -32,19 +28,10 @@ Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U.
 
 (** an shortcut for easily building a UsualDecidableType *)
 
-Module Type MiniDecidableType. 
- Parameter Inline t : Type.
- Parameter eq_dec : forall x y:t, { x=y }+{ x<>y }.
-End MiniDecidableType. 
+Module Type MiniDecidableType := Equalities.MiniDecidableType.
 
-Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType.
- Definition t:=M.t. 
- Definition eq := @eq t.
- Definition eq_refl := @refl_equal t.
- Definition eq_sym := @sym_eq t.
- Definition eq_trans := @trans_eq t.
- Definition eq_dec := M.eq_dec.
-End Make_UDT.
+Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType
+ := Equalities.Make_UDT M.
 
 (** An OrderedType can now directly be seen as a DecidableType *)
 
@@ -57,7 +44,7 @@ Module Positive_as_DT <: UsualDecidableType := Positive_as_OT.
 Module N_as_DT <: UsualDecidableType := N_as_OT.
 Module Z_as_DT <: UsualDecidableType := Z_as_OT.
 
-(** From two decidable types, we can build a new DecidableType 
+(** From two decidable types, we can build a new DecidableType
    over their cartesian product. *)
 
 Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.
@@ -67,17 +54,17 @@ Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.
  Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y).
 
  Lemma eq_refl : forall x : t, eq x x.
- Proof. 
+ Proof.
  intros (x1,x2); red; simpl; auto.
  Qed.
 
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
- Proof. 
+ Proof.
  intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
  Qed.
 
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
- Proof. 
+ Proof.
  intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
  Qed.
 
@@ -99,10 +86,10 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
  Definition eq_trans := @trans_eq t.
  Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
  Proof.
- intros (x1,x2) (y1,y2); 
- destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); 
- unfold eq, D1.eq, D2.eq in *; simpl; 
- (left; f_equal; auto; fail) || 
+ intros (x1,x2) (y1,y2);
+ destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
+ unfold eq, D1.eq, D2.eq in *; simpl;
+ (left; f_equal; auto; fail) ||
  (right; intro H; injection H; auto).
  Defined.
 
diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v
new file mode 100644
index 00000000..487b1d0c
--- /dev/null
+++ b/theories/Structures/Equalities.v
@@ -0,0 +1,218 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export RelationClasses.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Structure with just a base type [t] *)
+
+Module Type Typ.
+  Parameter Inline t : Type.
+End Typ.
+
+(** * Structure with an equality relation [eq] *)
+
+Module Type HasEq (Import T:Typ).
+  Parameter Inline eq : t -> t -> Prop.
+End HasEq.
+
+Module Type Eq := Typ <+ HasEq.
+
+Module Type EqNotation (Import E:Eq).
+  Infix "==" := eq (at level 70, no associativity).
+  Notation "x ~= y" := (~eq x y) (at level 70, no associativity).
+End EqNotation.
+
+Module Type Eq' := Eq <+ EqNotation.
+
+(** * Specification of the equality via the [Equivalence] type class *)
+
+Module Type IsEq (Import E:Eq).
+  Declare Instance eq_equiv : Equivalence eq.
+End IsEq.
+
+(** * Earlier specification of equality by three separate lemmas. *)
+
+Module Type IsEqOrig (Import E:Eq').
+  Axiom eq_refl : forall x : t, x==x.
+  Axiom eq_sym : forall x y : t, x==y -> y==x.
+  Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z.
+  Hint Immediate eq_sym.
+  Hint Resolve eq_refl eq_trans.
+End IsEqOrig.
+
+(** * Types with decidable equality *)
+
+Module Type HasEqDec (Import E:Eq').
+  Parameter eq_dec : forall x y : t, { x==y } + { ~ x==y }.
+End HasEqDec.
+
+(** * Boolean Equality *)
+
+(** Having [eq_dec] is the same as having a boolean equality plus
+    a correctness proof. *)
+
+Module Type HasEqBool (Import E:Eq').
+  Parameter Inline eqb : t -> t -> bool.
+  Parameter eqb_eq : forall x y, eqb x y = true <-> x==y.
+End HasEqBool.
+
+(** From these basic blocks, we can build many combinations
+    of static standalone module types. *)
+
+Module Type EqualityType := Eq <+ IsEq.
+
+Module Type EqualityTypeOrig := Eq <+ IsEqOrig.
+
+Module Type EqualityTypeBoth <: EqualityType <: EqualityTypeOrig
+ := Eq <+ IsEq <+ IsEqOrig.
+
+Module Type DecidableType <: EqualityType
+ := Eq <+ IsEq <+ HasEqDec.
+
+Module Type DecidableTypeOrig <: EqualityTypeOrig
+ := Eq <+ IsEqOrig <+ HasEqDec.
+
+Module Type DecidableTypeBoth <: DecidableType <: DecidableTypeOrig
+ := EqualityTypeBoth <+ HasEqDec.
+
+Module Type BooleanEqualityType <: EqualityType
+ := Eq <+ IsEq <+ HasEqBool.
+
+Module Type BooleanDecidableType <: DecidableType <: BooleanEqualityType
+ := Eq <+ IsEq <+ HasEqDec <+ HasEqBool.
+
+Module Type DecidableTypeFull <: DecidableTypeBoth <: BooleanDecidableType
+ := Eq <+ IsEq <+ IsEqOrig <+ HasEqDec <+ HasEqBool.
+
+(** Same, with notation for [eq] *)
+
+Module Type EqualityType' := EqualityType <+ EqNotation.
+Module Type EqualityTypeOrig' := EqualityTypeOrig <+ EqNotation.
+Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation.
+Module Type DecidableType' := DecidableType <+ EqNotation.
+Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation.
+Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation.
+Module Type BooleanEqualityType' := BooleanEqualityType <+ EqNotation.
+Module Type BooleanDecidableType' := BooleanDecidableType <+ EqNotation.
+Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation.
+
+(** * Compatibility wrapper from/to the old version of
+      [EqualityType] and [DecidableType] *)
+
+Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E.
+ Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv.
+ Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv.
+ Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv.
+End BackportEq.
+
+Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E.
+ Instance eq_equiv : Equivalence E.eq.
+ Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed.
+End UpdateEq.
+
+Module Backport_ET (E:EqualityType) <: EqualityTypeBoth
+ := E <+ BackportEq.
+
+Module Update_ET (E:EqualityTypeOrig) <: EqualityTypeBoth
+ := E <+ UpdateEq.
+
+Module Backport_DT (E:DecidableType) <: DecidableTypeBoth
+ := E <+ BackportEq.
+
+Module Update_DT (E:DecidableTypeOrig) <: DecidableTypeBoth
+ := E <+ UpdateEq.
+
+
+(** * Having [eq_dec] is equivalent to having [eqb] and its spec. *)
+
+Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E.
+ Definition eqb x y := if F.eq_dec x y then true else false.
+ Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y.
+ Proof.
+  intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ].
+  auto with *.
+  split. discriminate. intro EQ; elim NEQ; auto.
+ Qed.
+End HasEqDec2Bool.
+
+Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E.
+ Lemma eq_dec : forall x y, {E.eq x y}+{~E.eq x y}.
+ Proof.
+  intros x y. assert (H:=F.eqb_eq x y).
+  destruct (F.eqb x y); [left|right].
+  apply -> H; auto.
+  intro EQ. apply H in EQ. discriminate.
+ Defined.
+End HasEqBool2Dec.
+
+Module Dec2Bool (E:DecidableType) <: BooleanDecidableType
+ := E <+ HasEqDec2Bool.
+
+Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType
+ := E <+ HasEqBool2Dec.
+
+
+
+(** * UsualDecidableType
+
+   A particular case of [DecidableType] where the equality is
+   the usual one of Coq. *)
+
+Module Type HasUsualEq (Import T:Typ) <: HasEq T.
+ Definition eq := @Logic.eq t.
+End HasUsualEq.
+
+Module Type UsualEq <: Eq := Typ <+ HasUsualEq.
+
+Module Type UsualIsEq (E:UsualEq) <: IsEq E.
+ (* No Instance syntax to avoid saturating the Equivalence tables *)
+ Lemma eq_equiv : Equivalence E.eq.
+ Proof. exact eq_equivalence. Qed.
+End UsualIsEq.
+
+Module Type UsualIsEqOrig (E:UsualEq) <: IsEqOrig E.
+ Definition eq_refl := @Logic.eq_refl E.t.
+ Definition eq_sym := @Logic.eq_sym E.t.
+ Definition eq_trans := @Logic.eq_trans E.t.
+End UsualIsEqOrig.
+
+Module Type UsualEqualityType <: EqualityType
+ := UsualEq <+ UsualIsEq.
+
+Module Type UsualDecidableType <: DecidableType
+ := UsualEq <+ UsualIsEq <+ HasEqDec.
+
+Module Type UsualDecidableTypeOrig <: DecidableTypeOrig
+ := UsualEq <+ UsualIsEqOrig <+ HasEqDec.
+
+Module Type UsualDecidableTypeBoth <: DecidableTypeBoth
+ := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec.
+
+Module Type UsualBoolEq := UsualEq <+ HasEqBool.
+
+Module Type UsualDecidableTypeFull <: DecidableTypeFull
+ := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec <+ HasEqBool.
+
+
+(** Some shortcuts for easily building a [UsualDecidableType] *)
+
+Module Type MiniDecidableType.
+ Include Typ.
+ Parameter eq_dec : forall x y : t, {x=y}+{~x=y}.
+End MiniDecidableType.
+
+Module Make_UDT (M:MiniDecidableType) <: UsualDecidableTypeBoth
+ := M <+ HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.
+
+Module Make_UDTF (M:UsualBoolEq) <: UsualDecidableTypeFull
+ := M <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqBool2Dec.
diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v
new file mode 100644
index 00000000..d9b1d76f
--- /dev/null
+++ b/theories/Structures/EqualitiesFacts.v
@@ -0,0 +1,185 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+Require Import Equalities Bool SetoidList RelationPairs.
+
+(** In a BooleanEqualityType, [eqb] is compatible with [eq] *)
+
+Module BoolEqualityFacts (Import E : BooleanEqualityType).
+
+Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb.
+Proof.
+intros x x' Exx' y y' Eyy'.
+apply eq_true_iff_eq.
+rewrite 2 eqb_eq, Exx', Eyy'; auto with *.
+Qed.
+
+End BoolEqualityFacts.
+
+
+(** * Keys and datas used in FMap *)
+Module KeyDecidableType(Import D:DecidableType).
+
+ Section Elt.
+ Variable elt : Type.
+ Notation key:=t.
+
+  Local Open Scope signature_scope.
+
+  Definition eqk : relation (key*elt) := eq @@1.
+  Definition eqke : relation (key*elt) := eq * Logic.eq.
+  Hint Unfold eqk eqke.
+
+  (* eqke is stricter than eqk *)
+
+  Global Instance eqke_eqk : subrelation eqke eqk.
+  Proof. firstorder. Qed.
+
+  (* eqk, eqke are equalities, ltk is a strict order *)
+
+  Global Instance eqk_equiv : Equivalence eqk.
+
+  Global Instance eqke_equiv : Equivalence eqke.
+
+  (* Additionnal facts *)
+
+  Lemma InA_eqke_eqk :
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke, RelProd; induction 1; firstorder.
+  Qed.
+  Hint Resolve InA_eqke_eqk.
+
+  Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
+  Proof.
+   intros. rewrite <- H; auto.
+  Qed.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+
+  Hint Unfold MapsTo In.
+
+  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+
+  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
+  Proof.
+  firstorder.
+  exists x; auto.
+  induction H.
+  destruct y; compute in H.
+  exists e; left; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
+  Proof.
+  unfold In, MapsTo.
+  setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
+  firstorder.
+  exists (snd x), x; auto.
+  Qed.
+
+  Lemma In_nil : forall k, In k nil <-> False.
+  Proof.
+  intros; rewrite In_alt2; apply Exists_nil.
+  Qed.
+
+  Lemma In_cons : forall k p l,
+   In k (p::l) <-> eq k (fst p) \/ In k l.
+  Proof.
+  intros; rewrite !In_alt2, Exists_cons; intuition.
+  Qed.
+
+  Global Instance MapsTo_compat :
+   Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
+  Proof.
+  intros x x' Hx e e' He l l' Hl. unfold MapsTo.
+  rewrite Hx, He, Hl; intuition.
+  Qed.
+
+  Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
+  Proof.
+  intros x x' Hx l l' Hl. rewrite !In_alt.
+  setoid_rewrite Hl. setoid_rewrite Hx. intuition.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
+    right; exists x; auto.
+  Qed.
+
+  Lemma In_inv_2 : forall k k' e e' l,
+      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
+  Proof.
+   intros; invlist InA; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l,
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   intros; invlist InA; compute in * |- ; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Unfold eqk eqke.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve InA_eqke_eqk.
+ Hint Unfold MapsTo In.
+ Hint Resolve In_inv_2 In_inv_3.
+
+End KeyDecidableType.
+
+
+(** * PairDecidableType 
+   
+   From two decidable types, we can build a new DecidableType
+   over their cartesian product. *)
+
+Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.
+
+ Definition t := (D1.t * D2.t)%type.
+
+ Definition eq := (D1.eq * D2.eq)%signature.
+
+ Instance eq_equiv : Equivalence eq.
+
+ Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
+ Proof.
+ intros (x1,x2) (y1,y2); unfold eq; simpl.
+ destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
+  compute; intuition.
+ Defined.
+
+End PairDecidableType.
+
+(** Similarly for pairs of UsualDecidableType *)
+
+Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
+ Definition t := (D1.t * D2.t)%type.
+ Definition eq := @eq t.
+ Program Instance eq_equiv : Equivalence eq.
+ Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
+ Proof.
+ intros (x1,x2) (y1,y2);
+ destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
+ unfold eq, D1.eq, D2.eq in *; simpl;
+ (left; f_equal; auto; fail) ||
+ (right; intro H; injection H; auto).
+ Defined.
+
+End PairUsualDecidableType.
diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v
new file mode 100644
index 00000000..68f20189
--- /dev/null
+++ b/theories/Structures/GenericMinMax.v
@@ -0,0 +1,656 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+Require Import Orders OrdersTac OrdersFacts Setoid Morphisms Basics.
+
+(** * A Generic construction of min and max *)
+
+(** ** First, an interface for types with [max] and/or [min] *)
+
+Module Type HasMax (Import E:EqLe').
+ Parameter Inline max : t -> t -> t.
+ Parameter max_l : forall x y, y<=x -> max x y == x.
+ Parameter max_r : forall x y, x<=y -> max x y == y.
+End HasMax.
+
+Module Type HasMin (Import E:EqLe').
+ Parameter Inline min : t -> t -> t.
+ Parameter min_l : forall x y, x<=y -> min x y == x.
+ Parameter min_r : forall x y, y<=x -> min x y == y.
+End HasMin.
+
+Module Type HasMinMax (E:EqLe) := HasMax E <+ HasMin E.
+
+
+(** ** Any [OrderedTypeFull] can be equipped by [max] and [min]
+    based on the compare function. *)
+
+Definition gmax {A} (cmp : A->A->comparison) x y :=
+ match cmp x y with Lt => y | _ => x end.
+Definition gmin {A} (cmp : A->A->comparison) x y :=
+ match cmp x y with Gt => y | _ => x end.
+
+Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O.
+
+ Definition max := gmax O.compare.
+ Definition min := gmin O.compare.
+
+ Lemma ge_not_lt : forall x y, y<=x -> x<y -> False.
+ Proof.
+ intros x y H H'.
+ apply (StrictOrder_Irreflexive x).
+ rewrite le_lteq in *; destruct H as [H|H].
+ transitivity y; auto.
+ rewrite H in H'; auto.
+ Qed.
+
+ Lemma max_l : forall x y, y<=x -> max x y == x.
+ Proof.
+ intros. unfold max, gmax. case compare_spec; auto with relations.
+ intros; elim (ge_not_lt x y); auto.
+ Qed.
+
+ Lemma max_r : forall x y, x<=y -> max x y == y.
+ Proof.
+ intros. unfold max, gmax. case compare_spec; auto with relations.
+ intros; elim (ge_not_lt y x); auto.
+ Qed.
+
+ Lemma min_l : forall x y, x<=y -> min x y == x.
+ Proof.
+ intros. unfold min, gmin. case compare_spec; auto with relations.
+ intros; elim (ge_not_lt y x); auto.
+ Qed.
+
+ Lemma min_r : forall x y, y<=x -> min x y == y.
+ Proof.
+ intros. unfold min, gmin. case compare_spec; auto with relations.
+ intros; elim (ge_not_lt x y); auto.
+ Qed.
+
+End GenericMinMax.
+
+
+(** ** Consequences of the minimalist interface: facts about [max]. *)
+
+Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O).
+ Module Import T := !MakeOrderTac O.
+
+(** An alternative caracterisation of [max], equivalent to
+    [max_l /\ max_r] *)
+
+Lemma max_spec : forall n m,
+  (n < m /\ max n m == m)  \/ (m <= n /\ max n m == n).
+Proof.
+ intros n m.
+ destruct (lt_total n m); [left|right].
+ split; auto. apply max_r. rewrite le_lteq; auto.
+ assert (m <= n) by (rewrite le_lteq; intuition).
+ split; auto. apply max_l; auto.
+Qed.
+
+(** A more symmetric version of [max_spec], based only on [le].
+    Beware that left and right alternatives overlap. *)
+
+Lemma max_spec_le : forall n m,
+ (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n).
+Proof.
+ intros. destruct (max_spec n m); [left|right]; intuition; order.
+Qed.
+
+Instance : Proper (eq==>eq==>iff) le.
+Proof. repeat red. intuition order. Qed.
+
+Instance max_compat : Proper (eq==>eq==>eq) max.
+Proof.
+intros x x' Hx y y' Hy.
+assert (H1 := max_spec x y). assert (H2 := max_spec x' y').
+set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'.
+rewrite <- Hx, <- Hy in *.
+destruct (lt_total x y); intuition order.
+Qed.
+
+
+(** A function satisfying the same specification is equal to [max]. *)
+
+Lemma max_unicity : forall n m p,
+ ((n < m /\ p == m)  \/ (m <= n /\ p == n)) ->  p == max n m.
+Proof.
+ intros. assert (Hm := max_spec n m).
+ destruct (lt_total n m); intuition; order.
+Qed.
+
+Lemma max_unicity_ext : forall f,
+ (forall n m, (n < m /\ f n m == m)  \/ (m <= n /\ f n m == n)) ->
+ (forall n m, f n m == max n m).
+Proof.
+ intros. apply max_unicity; auto.
+Qed.
+
+(** [max] commutes with monotone functions. *)
+
+Lemma max_mono: forall f,
+ (Proper (eq ==> eq) f) ->
+ (Proper (le ==> le) f) ->
+ forall x y, max (f x) (f y) == f (max x y).
+Proof.
+ intros f Eqf Lef x y.
+ destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E;
+  destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
+ assert (f x <= f y) by (apply Lef; order). order.
+ assert (f y <= f x) by (apply Lef; order). order.
+Qed.
+
+(** *** Semi-lattice algebraic properties of [max] *)
+
+Lemma max_id : forall n, max n n == n.
+Proof.
+ intros. destruct (max_spec n n); intuition.
+Qed.
+
+Notation max_idempotent := max_id (only parsing).
+
+Lemma max_assoc : forall m n p, max m (max n p) == max (max m n) p.
+Proof.
+ intros.
+ destruct (max_spec n p) as [(H,Eq)|(H,Eq)]; rewrite Eq.
+ destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'.
+ destruct (max_spec m p); intuition; order. order.
+ destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. order.
+ destruct (max_spec m p); intuition; order.
+Qed.
+
+Lemma max_comm : forall n m, max n m == max m n.
+Proof.
+ intros.
+ destruct (max_spec n m) as [(H,Eq)|(H,Eq)]; rewrite Eq.
+ destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order.
+ destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order.
+Qed.
+
+(** *** Least-upper bound properties of [max] *)
+
+Lemma le_max_l : forall n m, n <= max n m.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma le_max_r : forall n m, m <= max n m.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_l_iff : forall n m, max n m == n <-> m <= n.
+Proof.
+ split. intro H; rewrite <- H. apply le_max_r. apply max_l.
+Qed.
+
+Lemma max_r_iff : forall n m, max n m == m <-> n <= m.
+Proof.
+ split. intro H; rewrite <- H. apply le_max_l. apply max_r.
+Qed.
+
+Lemma max_le : forall n m p, p <= max n m -> p <= n \/ p <= m.
+Proof.
+ intros n m p H; destruct (max_spec n m);
+  [right|left]; intuition; order.
+Qed.
+
+Lemma max_le_iff : forall n m p, p <= max n m <-> p <= n \/ p <= m.
+Proof.
+ intros. split. apply max_le.
+ destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_lt_iff : forall n m p, p < max n m <-> p < n \/ p < m.
+Proof.
+ intros. destruct (max_spec n m); intuition;
+  order || (right; order) || (left; order).
+Qed.
+
+Lemma max_lub_l : forall n m p, max n m <= p -> n <= p.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_lub_r : forall n m p, max n m <= p -> m <= p.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_lub : forall n m p, n <= p -> m <= p -> max n m <= p.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_lub_iff : forall n m p, max n m <= p <-> n <= p /\ m <= p.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_lub_lt : forall n m p, n < p -> m < p -> max n m < p.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_lub_lt_iff : forall n m p, max n m < p <-> n < p /\ m < p.
+Proof.
+ intros; destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_le_compat_l : forall n m p, n <= m -> max p n <= max p m.
+Proof.
+ intros.
+ destruct (max_spec p n) as [(LT,E)|(LE,E)]; rewrite E.
+ assert (LE' := le_max_r p m). order.
+ apply le_max_l.
+Qed.
+
+Lemma max_le_compat_r : forall n m p, n <= m -> max n p <= max m p.
+Proof.
+ intros. rewrite (max_comm n p), (max_comm m p).
+ auto using max_le_compat_l.
+Qed.
+
+Lemma max_le_compat : forall n m p q, n <= m -> p <= q ->
+ max n p <= max m q.
+Proof.
+ intros  n m p q Hnm Hpq.
+ assert (LE := max_le_compat_l _ _ m Hpq).
+ assert (LE' := max_le_compat_r _ _ p Hnm).
+ order.
+Qed.
+
+End MaxLogicalProperties.
+
+
+(** ** Properties concernant [min], then both [min] and [max].
+
+   To avoid too much code duplication, we exploit that [min] can be
+   seen as a [max] of the reversed order.
+*)
+
+Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O).
+ Include MaxLogicalProperties O M.
+ Import T.
+
+ Module ORev := TotalOrderRev O.
+ Module MRev <: HasMax ORev.
+  Definition max x y := M.min y x.
+  Definition max_l x y := M.min_r y x.
+  Definition max_r x y := M.min_l y x.
+ End MRev.
+ Module MPRev := MaxLogicalProperties ORev MRev.
+
+Instance min_compat : Proper (eq==>eq==>eq) min.
+Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed.
+
+Lemma min_spec : forall n m,
+ (n < m /\ min n m == n) \/ (m <= n /\ min n m == m).
+Proof. intros. exact (MPRev.max_spec m n). Qed.
+
+Lemma min_spec_le : forall n m,
+ (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m).
+Proof. intros. exact (MPRev.max_spec_le m n). Qed.
+
+Lemma min_mono: forall f,
+ (Proper (eq ==> eq) f) ->
+ (Proper (le ==> le) f) ->
+ forall x y, min (f x) (f y) == f (min x y).
+Proof.
+ intros. apply MPRev.max_mono; auto. compute in *; eauto.
+Qed.
+
+Lemma min_unicity : forall n m p,
+ ((n < m /\ p == n)  \/ (m <= n /\ p == m)) ->  p == min n m.
+Proof. intros n m p. apply MPRev.max_unicity. Qed.
+
+Lemma min_unicity_ext : forall f,
+ (forall n m, (n < m /\ f n m == n)  \/ (m <= n /\ f n m == m)) ->
+ (forall n m, f n m == min n m).
+Proof. intros f H n m. apply MPRev.max_unicity, H; auto. Qed.
+
+Lemma min_id : forall n, min n n == n.
+Proof. intros. exact (MPRev.max_id n). Qed.
+
+Notation min_idempotent := min_id (only parsing).
+
+Lemma min_assoc : forall m n p, min m (min n p) == min (min m n) p.
+Proof. intros. symmetry; apply MPRev.max_assoc. Qed.
+
+Lemma min_comm : forall n m, min n m == min m n.
+Proof. intros. exact (MPRev.max_comm m n). Qed.
+
+Lemma le_min_r : forall n m, min n m <= m.
+Proof. intros. exact (MPRev.le_max_l m n). Qed.
+
+Lemma le_min_l : forall n m, min n m <= n.
+Proof. intros. exact (MPRev.le_max_r m n). Qed.
+
+Lemma min_l_iff : forall n m, min n m == n <-> n <= m.
+Proof. intros n m. exact (MPRev.max_r_iff m n). Qed.
+
+Lemma min_r_iff : forall n m, min n m == m <-> m <= n.
+Proof. intros n m. exact (MPRev.max_l_iff m n). Qed.
+
+Lemma min_le : forall n m p, min n m <= p -> n <= p \/ m <= p.
+Proof. intros n m p H. destruct (MPRev.max_le _ _ _ H); auto. Qed.
+
+Lemma min_le_iff : forall n m p, min n m <= p <-> n <= p \/ m <= p.
+Proof. intros n m p. rewrite (MPRev.max_le_iff m n p); intuition. Qed.
+
+Lemma min_lt_iff : forall n m p, min n m < p <-> n < p \/ m < p.
+Proof. intros n m p. rewrite (MPRev.max_lt_iff m n p); intuition. Qed.
+
+Lemma min_glb_l : forall n m p, p <= min n m -> p <= n.
+Proof. intros n m. exact (MPRev.max_lub_r m n). Qed.
+
+Lemma min_glb_r : forall n m p, p <= min n m -> p <= m.
+Proof. intros n m. exact (MPRev.max_lub_l m n). Qed.
+
+Lemma min_glb : forall n m p, p <= n -> p <= m -> p <= min n m.
+Proof. intros. apply MPRev.max_lub; auto. Qed.
+
+Lemma min_glb_iff : forall n m p, p <= min n m <-> p <= n /\ p <= m.
+Proof. intros. rewrite (MPRev.max_lub_iff m n p); intuition. Qed.
+
+Lemma min_glb_lt : forall n m p, p < n -> p < m -> p < min n m.
+Proof. intros. apply MPRev.max_lub_lt; auto. Qed.
+
+Lemma min_glb_lt_iff : forall n m p, p < min n m <-> p < n /\ p < m.
+Proof. intros. rewrite (MPRev.max_lub_lt_iff m n p); intuition. Qed.
+
+Lemma min_le_compat_l : forall n m p, n <= m -> min p n <= min p m.
+Proof. intros n m. exact (MPRev.max_le_compat_r m n). Qed.
+
+Lemma min_le_compat_r : forall n m p, n <= m -> min n p <= min m p.
+Proof. intros n m. exact (MPRev.max_le_compat_l m n). Qed.
+
+Lemma min_le_compat : forall n m p q, n <= m -> p <= q ->
+ min n p <= min m q.
+Proof. intros. apply MPRev.max_le_compat; auto. Qed.
+
+
+(** *** Combined properties of min and max *)
+
+Lemma min_max_absorption : forall n m, max n (min n m) == n.
+Proof.
+ intros.
+ destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E.
+ apply max_l. order.
+ destruct (max_spec n m); intuition; order.
+Qed.
+
+Lemma max_min_absorption : forall n m, min n (max n m) == n.
+Proof.
+ intros.
+ destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E.
+ destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order.
+ apply min_l; auto. order.
+Qed.
+
+(** Distributivity *)
+
+Lemma max_min_distr : forall n m p,
+ max n (min m p) == min (max n m) (max n p).
+Proof.
+ intros. symmetry. apply min_mono.
+ eauto with *.
+ repeat red; intros. apply max_le_compat_l; auto.
+Qed.
+
+Lemma min_max_distr : forall n m p,
+ min n (max m p) == max (min n m) (min n p).
+Proof.
+ intros. symmetry. apply max_mono.
+ eauto with *.
+ repeat red; intros. apply min_le_compat_l; auto.
+Qed.
+
+(** Modularity *)
+
+Lemma max_min_modular : forall n m p,
+ max n (min m (max n p)) == min (max n m) (max n p).
+Proof.
+ intros. rewrite <- max_min_distr.
+ destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *.
+ destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'.
+ rewrite 2 max_l; try order. rewrite min_le_iff; auto.
+ rewrite 2 max_l; try order. rewrite min_le_iff; auto.
+Qed.
+
+Lemma min_max_modular : forall n m p,
+ min n (max m (min n p)) == max (min n m) (min n p).
+Proof.
+ intros. rewrite <- min_max_distr.
+ destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *.
+ destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'.
+ rewrite 2 min_l; try order. rewrite max_le_iff; right; order.
+ rewrite 2 min_l; try order. rewrite max_le_iff; auto.
+Qed.
+
+(** Disassociativity *)
+
+Lemma max_min_disassoc : forall n m p,
+ min n (max m p) <= max (min n m) p.
+Proof.
+ intros. rewrite min_max_distr.
+ auto using max_le_compat_l, le_min_r.
+Qed.
+
+(** Anti-monotonicity swaps the role of [min] and [max] *)
+
+Lemma max_min_antimono : forall f,
+ Proper (eq==>eq) f ->
+ Proper (le==>inverse le) f ->
+ forall x y, max (f x) (f y) == f (min x y).
+Proof.
+ intros f Eqf Lef x y.
+ destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E;
+  destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
+ assert (f y <= f x) by (apply Lef; order). order.
+ assert (f x <= f y) by (apply Lef; order). order.
+Qed.
+
+Lemma min_max_antimono : forall f,
+ Proper (eq==>eq) f ->
+ Proper (le==>inverse le) f ->
+ forall x y, min (f x) (f y) == f (max x y).
+Proof.
+ intros f Eqf Lef x y.
+ destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E;
+  destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
+ assert (f y <= f x) by (apply Lef; order). order.
+ assert (f x <= f y) by (apply Lef; order). order.
+Qed.
+
+End MinMaxLogicalProperties.
+
+
+(** ** Properties requiring a decidable order *)
+
+Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O).
+
+(** Induction principles for [max]. *)
+
+Lemma max_case_strong : forall n m (P:t -> Type),
+  (forall x y, x==y -> P x -> P y) ->
+  (m<=n -> P n) -> (n<=m -> P m) -> P (max n m).
+Proof.
+intros n m P Compat Hl Hr.
+destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT].
+assert (n<=m) by (rewrite le_lteq; auto).
+apply (Compat m), Hr; auto. symmetry; apply max_r; auto.
+assert (n<=m) by (rewrite le_lteq; auto).
+apply (Compat m), Hr; auto. symmetry; apply max_r; auto.
+assert (m<=n) by (rewrite le_lteq; auto).
+apply (Compat n), Hl; auto. symmetry; apply max_l; auto.
+Defined.
+
+Lemma max_case : forall n m (P:t -> Type),
+  (forall x y, x == y -> P x -> P y) ->
+  P n -> P m -> P (max n m).
+Proof. intros. apply max_case_strong; auto. Defined.
+
+(** [max] returns one of its arguments. *)
+
+Lemma max_dec : forall n m, {max n m == n} + {max n m == m}.
+Proof.
+ intros n m. apply max_case; auto with relations.
+ intros x y H [E|E]; [left|right]; rewrite <-H; auto.
+Defined.
+
+(** Idem for [min] *)
+
+Lemma min_case_strong : forall n m (P:O.t -> Type),
+ (forall x y, x == y -> P x -> P y) ->
+ (n<=m -> P n) -> (m<=n -> P m) -> P (min n m).
+Proof.
+intros n m P Compat Hl Hr.
+destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT].
+assert (n<=m) by (rewrite le_lteq; auto).
+apply (Compat n), Hl; auto. symmetry; apply min_l; auto.
+assert (n<=m) by (rewrite le_lteq; auto).
+apply (Compat n), Hl; auto. symmetry; apply min_l; auto.
+assert (m<=n) by (rewrite le_lteq; auto).
+apply (Compat m), Hr; auto. symmetry; apply min_r; auto.
+Defined.
+
+Lemma min_case : forall n m (P:O.t -> Type),
+  (forall x y, x == y -> P x -> P y) ->
+  P n -> P m -> P (min n m).
+Proof. intros. apply min_case_strong; auto. Defined.
+
+Lemma min_dec : forall n m, {min n m == n} + {min n m == m}.
+Proof.
+ intros. apply min_case; auto with relations.
+ intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations.
+Defined.
+
+End MinMaxDecProperties.
+
+Module MinMaxProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O).
+ Module OT := OTF_to_TotalOrder O.
+ Include MinMaxLogicalProperties OT M.
+ Include MinMaxDecProperties O M.
+ Definition max_l := max_l.
+ Definition max_r := max_r.
+ Definition min_l := min_l.
+ Definition min_r := min_r.
+ Notation max_monotone := max_mono.
+ Notation min_monotone := min_mono.
+ Notation max_min_antimonotone := max_min_antimono.
+ Notation min_max_antimonotone := min_max_antimono.
+End MinMaxProperties.
+
+
+(** ** When the equality is Leibniz, we can skip a few [Proper] precondition. *)
+
+Module UsualMinMaxLogicalProperties
+ (Import O:UsualTotalOrder')(Import M:HasMinMax O).
+
+ Include MinMaxLogicalProperties O M.
+
+ Lemma max_monotone : forall f, Proper (le ==> le) f ->
+  forall x y, max (f x) (f y) = f (max x y).
+ Proof. intros; apply max_mono; auto. congruence. Qed.
+
+ Lemma min_monotone : forall f, Proper (le ==> le) f ->
+  forall x y, min (f x) (f y) = f (min x y).
+ Proof. intros; apply min_mono; auto. congruence. Qed.
+
+ Lemma min_max_antimonotone : forall f, Proper (le ==> inverse le) f ->
+  forall x y, min (f x) (f y) = f (max x y).
+ Proof. intros; apply min_max_antimono; auto. congruence. Qed.
+
+ Lemma max_min_antimonotone : forall f, Proper (le ==> inverse le) f ->
+  forall x y, max (f x) (f y) = f (min x y).
+ Proof. intros; apply max_min_antimono; auto. congruence. Qed.
+
+End UsualMinMaxLogicalProperties.
+
+
+Module UsualMinMaxDecProperties
+ (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O).
+
+ Module P := MinMaxDecProperties O M.
+
+ Lemma max_case_strong : forall n m (P:t -> Type),
+  (m<=n -> P n) -> (n<=m -> P m) -> P (max n m).
+ Proof. intros; apply P.max_case_strong; auto. congruence. Defined.
+
+ Lemma max_case : forall n m (P:t -> Type),
+  P n -> P m -> P (max n m).
+ Proof. intros; apply max_case_strong; auto. Defined.
+
+ Lemma max_dec : forall n m, {max n m = n} + {max n m = m}.
+ Proof. exact P.max_dec. Defined.
+
+ Lemma min_case_strong : forall n m (P:O.t -> Type),
+  (n<=m -> P n) -> (m<=n -> P m) -> P (min n m).
+ Proof. intros; apply P.min_case_strong; auto. congruence. Defined.
+
+ Lemma min_case : forall n m (P:O.t -> Type),
+  P n -> P m -> P (min n m).
+ Proof. intros. apply min_case_strong; auto. Defined.
+
+ Lemma min_dec : forall n m, {min n m = n} + {min n m = m}.
+ Proof. exact P.min_dec. Defined.
+
+End UsualMinMaxDecProperties.
+
+Module UsualMinMaxProperties
+ (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O).
+ Module OT := OTF_to_TotalOrder O.
+ Include UsualMinMaxLogicalProperties OT M.
+ Include UsualMinMaxDecProperties O M.
+ Definition max_l := max_l.
+ Definition max_r := max_r.
+ Definition min_l := min_l.
+ Definition min_r := min_r.
+End UsualMinMaxProperties.
+
+
+(** From [TotalOrder] and [HasMax] and [HasEqDec], we can prove
+    that the order is decidable and build an [OrderedTypeFull]. *)
+
+Module TOMaxEqDec_to_Compare
+ (Import O:TotalOrder')(Import M:HasMax O)(Import E:HasEqDec O) <: HasCompare O.
+
+ Definition compare x y :=
+  if eq_dec x y then Eq
+  else if eq_dec (M.max x y) y then Lt else Gt.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+ intros; unfold compare; repeat destruct eq_dec; auto; constructor.
+ destruct (lt_total x y); auto.
+ absurd (x==y); auto. transitivity (max x y); auto.
+ symmetry. apply max_l. rewrite le_lteq; intuition.
+ destruct (lt_total y x); auto.
+ absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition.
+ Qed.
+
+End TOMaxEqDec_to_Compare.
+
+Module TOMaxEqDec_to_OTF (O:TotalOrder)(M:HasMax O)(E:HasEqDec O)
+ <: OrderedTypeFull
+ := O <+ E <+ TOMaxEqDec_to_Compare O M E.
+
+
+
+(** TODO: Some Remaining questions...
+
+--> Compare with a type-classes version ?
+
+--> Is max_unicity and max_unicity_ext really convenient to express
+    that any possible definition of max will in fact be equivalent ?
+
+--> Is it possible to avoid copy-paste about min even more ?
+
+*)
diff --git a/theories/FSets/OrderedType.v b/theories/Structures/OrderedType.v
index fadd27dd..72fbe796 100644
--- a/theories/FSets/OrderedType.v
+++ b/theories/Structures/OrderedType.v
@@ -6,12 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: OrderedType.v 11700 2008-12-18 11:49:10Z letouzey $ *)
+(* $Id$ *)
 
-Require Export SetoidList.
+Require Export SetoidList Morphisms OrdersTac.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+(** NB: This file is here only for compatibility with earlier version of
+     [FSets] and [FMap]. Please use [Structures/Orders.v] directly now. *)
+
 (** * Ordered types *)
 
 Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type :=
@@ -41,7 +44,7 @@ Module Type MiniOrderedType.
 End MiniOrderedType.
 
 Module Type OrderedType.
-  Include Type MiniOrderedType.
+  Include MiniOrderedType.
 
   (** A [eq_dec] can be deduced from [compare] below. But adding this
      redundant field allows to see an OrderedType as a DecidableType. *)
@@ -67,246 +70,117 @@ End MOT_to_OT.
 
 Module OrderedTypeFacts (Import O: OrderedType).
 
+  Instance eq_equiv : Equivalence eq.
+  Proof. split; [ exact eq_refl | exact eq_sym | exact eq_trans ]. Qed.
+
   Lemma lt_antirefl : forall x, ~ lt x x.
   Proof.
-   intros; intro; absurd (eq x x); auto. 
+   intros; intro; absurd (eq x x); auto.
   Qed.
 
+  Instance lt_strorder : StrictOrder lt.
+  Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed.
+
   Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
-  Proof. 
+  Proof.
    intros; destruct (compare x z); auto.
    elim (lt_not_eq H); apply eq_trans with z; auto.
    elim (lt_not_eq (lt_trans l H)); auto.
-  Qed. 
+  Qed.
 
-  Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.    
+  Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.
   Proof.
    intros; destruct (compare x z); auto.
    elim (lt_not_eq H0); apply eq_trans with x; auto.
    elim (lt_not_eq (lt_trans H0 l)); auto.
-  Qed. 
-
-  Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z.
-  Proof.
-   intros; intro; destruct H; apply lt_eq with z; auto.
-  Qed.
-
-  Lemma eq_le : forall x y z, eq x y -> ~lt y z -> ~lt x z.
-  Proof.
-   intros; intro; destruct H0; apply eq_lt with x; auto.
-  Qed.
-
-  Lemma neq_eq : forall x y z, ~eq x y -> eq y z -> ~eq x z.
-  Proof.
-   intros; intro; destruct H; apply eq_trans with z; auto.
-  Qed.
-
-  Lemma eq_neq : forall x y z, eq x y -> ~eq y z -> ~eq x z.
-  Proof.
-   intros; intro; destruct H0; apply eq_trans with x; auto.
-  Qed.
-
-  Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq.
-
-  Lemma le_lt_trans : forall x y z, ~lt y x -> lt y z -> lt x z.
-  Proof.
-   intros; destruct (compare y x); auto.
-   elim (H l).
-   apply eq_lt with y; auto.
-   apply lt_trans with y; auto.
   Qed.
 
-  Lemma lt_le_trans : forall x y z, lt x y -> ~lt z y -> lt x z.
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
   Proof.
-   intros; destruct (compare z y); auto.
-   elim (H0 l).
-   apply lt_eq with y; auto.
-   apply lt_trans with y; auto.
+  apply proper_sym_impl_iff_2; auto with *.
+  intros x x' Hx y y' Hy H.
+  apply eq_lt with x; auto.
+  apply lt_eq with y; auto.
   Qed.
 
-  Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x.
-  Proof. 
-   intros; destruct (compare x y); intuition.
-  Qed.
-
-  Lemma neq_sym : forall x y, ~eq x y -> ~eq y x.
-  Proof. 
-   intuition.
-  Qed.
-
-(* TODO concernant la tactique order: 
-   * propagate_lt n'est sans doute pas complet
-   * un propagate_le
-   * exploiter les hypotheses negatives restant a la fin
-   * faire que ca marche meme quand une hypothese depend d'un eq ou lt.
-*) 
-
-Ltac abstraction := match goal with 
- (* First, some obvious simplifications *)
- | H : False |- _ => elim H
- | H : lt ?x ?x |- _ => elim (lt_antirefl H)
- | H : ~eq ?x ?x |- _ => elim (H (eq_refl x))
- | H : eq ?x ?x |- _ => clear H; abstraction
- | H : ~lt ?x ?x |- _ => clear H; abstraction
- | |- eq ?x ?x => exact (eq_refl x)
- | |- lt ?x ?x => elimtype False; abstraction
- | |- ~ _ => intro; abstraction
- | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => 
-     generalize (le_neq H1 H2); clear H1 H2; intro; abstraction
- | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => 
-     generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction
- (* Then, we generalize all interesting facts *)
- | H : ~eq ?x ?y |- _ =>  revert H; abstraction
- | H : ~lt ?x ?y |- _ => revert H; abstraction  
- | H : lt ?x ?y |- _ => revert H; abstraction
- | H : eq ?x ?y |- _ =>  revert H; abstraction
- | _ => idtac
-end.
-
-Ltac do_eq a b EQ := match goal with 
- | |- lt ?x ?y -> _ => let H := fresh "H" in 
-     (intro H; 
-      (generalize (eq_lt (eq_sym EQ) H); clear H; intro H) ||
-      (generalize (lt_eq H EQ); clear H; intro H) || 
-      idtac); 
-      do_eq a b EQ
- | |- ~lt ?x ?y -> _ => let H := fresh "H" in 
-     (intro H; 
-      (generalize (eq_le (eq_sym EQ) H); clear H; intro H) ||
-      (generalize (le_eq H EQ); clear H; intro H) || 
-      idtac); 
-      do_eq a b EQ 
- | |- eq ?x ?y -> _ => let H := fresh "H" in 
-     (intro H; 
-      (generalize (eq_trans (eq_sym EQ) H); clear H; intro H) ||
-      (generalize (eq_trans H EQ); clear H; intro H) || 
-      idtac); 
-      do_eq a b EQ 
- | |- ~eq ?x ?y -> _ => let H := fresh "H" in 
-     (intro H; 
-      (generalize (eq_neq (eq_sym EQ) H); clear H; intro H) ||
-      (generalize (neq_eq H EQ); clear H; intro H) || 
-      idtac); 
-      do_eq a b EQ 
- | |- lt a ?y => apply eq_lt with b; [exact EQ|]
- | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym EQ)]
- | |- eq a ?y => apply eq_trans with b; [exact EQ|]
- | |- eq ?y a => apply eq_trans with b; [|exact (eq_sym EQ)]
- | _ => idtac
- end.
-
-Ltac propagate_eq := abstraction; clear; match goal with 
- (* the abstraction tactic leaves equality facts in head position...*)
- | |- eq ?a ?b -> _ => 
-     let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); 
-     propagate_eq 
- | _ => idtac
-end.
-
-Ltac do_lt x y LT := match goal with 
- (* LT *)
- | |- lt x y -> _ => intros _; do_lt x y LT
- | |- lt y ?z -> _ => let H := fresh "H" in 
-     (intro H; generalize (lt_trans LT H); intro); do_lt x y LT
- | |- lt ?z x -> _ => let H := fresh "H" in 
-     (intro H; generalize (lt_trans H LT); intro); do_lt x y LT
- | |- lt _ _ -> _ => intro; do_lt x y LT
- (* GE *)
- | |- ~lt y x -> _ => intros _; do_lt x y LT
- | |- ~lt x ?z -> _ => let H := fresh "H" in 
-     (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT
- | |- ~lt ?z y -> _ => let H := fresh "H" in 
-     (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT
- | |- ~lt _ _ -> _ => intro; do_lt x y LT
- | _ => idtac
- end.
-
-Definition hide_lt := lt.
-
-Ltac propagate_lt := abstraction; match goal with 
- (* when no [=] remains, the abstraction tactic leaves [<] facts first. *)
- | |- lt ?x ?y -> _ => 
-     let LT := fresh "LT" in (intro LT; do_lt x y LT; 
-     change (hide_lt x y) in LT); 
-     propagate_lt 
- | _ => unfold hide_lt in *
-end.
-
-Ltac order := 
- intros; 
- propagate_eq; 
- propagate_lt; 
- auto; 
- propagate_lt; 
- eauto.
-
-Ltac false_order := elimtype False; order.
-
-  Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y.
-  Proof.
-    order.
-  Qed.	
- 
-  Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y.
-  Proof. 
-    order.
-  Qed.
+  Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x.
+  Proof. intros; destruct (compare x y); auto. Qed.
+
+  Module OrderElts <: Orders.TotalOrder.
+  Definition t := t.
+  Definition eq := eq.
+  Definition lt := lt.
+  Definition le x y := lt x y \/ eq x y.
+  Definition eq_equiv := eq_equiv.
+  Definition lt_strorder := lt_strorder.
+  Definition lt_compat := lt_compat.
+  Definition lt_total := lt_total.
+  Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y.
+  Proof. unfold le; intuition. Qed.
+  End OrderElts.
+  Module OrderTac := !MakeOrderTac OrderElts.
+  Ltac order := OrderTac.order.
+
+  Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed.
+  Lemma eq_le x y z : eq x y -> ~lt y z -> ~lt x z. Proof. order. Qed.
+  Lemma neq_eq x y z : ~eq x y -> eq y z -> ~eq x z. Proof. order. Qed.
+  Lemma eq_neq x y z : eq x y -> ~eq y z -> ~eq x z. Proof. order. Qed.
+  Lemma le_lt_trans x y z : ~lt y x -> lt y z -> lt x z. Proof. order. Qed.
+  Lemma lt_le_trans x y z : lt x y -> ~lt z y -> lt x z. Proof. order. Qed.
+  Lemma le_neq x y : ~lt x y -> ~eq x y -> lt y x. Proof. order. Qed.
+  Lemma le_trans x y z : ~lt y x -> ~lt z y -> ~lt z x. Proof. order. Qed.
+  Lemma le_antisym x y : ~lt y x -> ~lt x y -> eq x y. Proof. order. Qed.
+  Lemma neq_sym x y : ~eq x y -> ~eq y x. Proof. order. Qed.
+  Lemma lt_le x y : lt x y -> ~lt y x. Proof. order. Qed.
+  Lemma gt_not_eq x y : lt y x -> ~ eq x y. Proof. order. Qed.
+  Lemma eq_not_lt x y : eq x y -> ~ lt x y. Proof. order. Qed.
+  Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed.
+  Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed.
 
   Hint Resolve gt_not_eq eq_not_lt.
-
-  Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x.
-  Proof. 
-   order.
-  Qed.
-
-  Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x.
-  Proof.  
-   order.
-  Qed.
-
+  Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq.
   Hint Resolve eq_not_gt lt_antirefl lt_not_gt.
 
   Lemma elim_compare_eq :
    forall x y : t,
    eq x y -> exists H : eq x y, compare x y = EQ _ H.
-  Proof. 
-   intros; case (compare x y); intros H'; try solve [false_order].
-   exists H'; auto.   
+  Proof.
+   intros; case (compare x y); intros H'; try (exfalso; order).
+   exists H'; auto.
   Qed.
 
   Lemma elim_compare_lt :
    forall x y : t,
    lt x y -> exists H : lt x y, compare x y = LT _ H.
-  Proof. 
-   intros; case (compare x y); intros H'; try solve [false_order].
-   exists H'; auto. 
+  Proof.
+   intros; case (compare x y); intros H'; try (exfalso; order).
+   exists H'; auto.
   Qed.
 
   Lemma elim_compare_gt :
    forall x y : t,
    lt y x -> exists H : lt y x, compare x y = GT _ H.
-  Proof. 
-   intros; case (compare x y); intros H'; try solve [false_order].
-   exists H'; auto.   
+  Proof.
+   intros; case (compare x y); intros H'; try (exfalso; order).
+   exists H'; auto.
   Qed.
 
-  Ltac elim_comp := 
-    match goal with 
-      | |- ?e => match e with 
+  Ltac elim_comp :=
+    match goal with
+      | |- ?e => match e with
            | context ctx [ compare ?a ?b ] =>
-                let H := fresh in 
-                (destruct (compare a b) as [H|H|H]; 
-                 try solve [ intros; false_order])
+                let H := fresh in
+                (destruct (compare a b) as [H|H|H]; try order)
          end
     end.
 
   Ltac elim_comp_eq x y :=
     elim (elim_compare_eq (x:=x) (y:=y));
-     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. 
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ].
 
   Ltac elim_comp_lt x y :=
     elim (elim_compare_lt (x:=x) (y:=y));
-     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. 
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ].
 
   Ltac elim_comp_gt x y :=
     elim (elim_compare_gt (x:=x) (y:=y));
@@ -314,7 +188,7 @@ Ltac false_order := elimtype False; order.
 
   (** For compatibility reasons *)
   Definition eq_dec := eq_dec.
- 
+
   Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
   Proof.
    intros; elim (compare x y); [ left | right | right ]; auto.
@@ -322,8 +196,8 @@ Ltac false_order := elimtype False; order.
 
   Definition eqb x y : bool := if eq_dec x y then true else false.
 
-  Lemma eqb_alt : 
-    forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. 
+  Lemma eqb_alt :
+    forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end.
   Proof.
   unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto.
   Qed.
@@ -338,37 +212,37 @@ Notation Sort:=(sort lt).
 Notation NoDup:=(NoDupA eq).
 
 Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
-Proof. exact (InA_eqA eq_sym eq_trans). Qed.
+Proof. exact (InA_eqA eq_equiv). Qed.
 
 Lemma ListIn_In : forall l x, List.In x l -> In x l.
-Proof. exact (In_InA eq_refl). Qed.
+Proof. exact (In_InA eq_equiv). Qed.
 
 Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_ltA lt_trans). Qed.
- 
+Proof. exact (InfA_ltA lt_strorder). Qed.
+
 Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_eqA eq_lt). Qed.
+Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed.
 
 Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
-Proof. exact (SortA_InfA_InA eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
-  
+Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.
+
 Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
 Proof. exact (@In_InfA t lt). Qed.
 
 Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
-Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed.
+Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed.
 
-Lemma Inf_alt : 
+Lemma Inf_alt :
  forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
-Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
+Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed.
 
 Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
-Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed.
+Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed.
 
 End ForNotations.
 
-Hint Resolve ListIn_In Sort_NoDup Inf_lt. 
-Hint Immediate In_eq Inf_lt. 
+Hint Resolve ListIn_In Sort_NoDup Inf_lt.
+Hint Immediate In_eq Inf_lt.
 
 End OrderedTypeFacts.
 
@@ -382,7 +256,7 @@ Module KeyOrderedType(O:OrderedType).
  Notation key:=t.
 
   Definition eqk (p p':key*elt) := eq (fst p) (fst p').
-  Definition eqke (p p':key*elt) := 
+  Definition eqke (p p':key*elt) :=
           eq (fst p) (fst p') /\ (snd p) = (snd p').
   Definition ltk (p p':key*elt) := lt (fst p) (fst p').
 
@@ -390,7 +264,7 @@ Module KeyOrderedType(O:OrderedType).
   Hint Extern 2 (eqke ?a ?b) => split.
 
    (* eqke is stricter than eqk *)
- 
+
    Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
    Proof.
      unfold eqk, eqke; intuition.
@@ -406,7 +280,7 @@ Module KeyOrderedType(O:OrderedType).
    Hint Immediate ltk_right_r ltk_right_l.
 
   (* eqk, eqke are equalities, ltk is a strict order *)
- 
+
   Lemma eqk_refl : forall e, eqk e e.
   Proof. auto. Qed.
 
@@ -431,7 +305,7 @@ Module KeyOrderedType(O:OrderedType).
   Proof. eauto. Qed.
 
   Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
-  Proof. unfold eqk, ltk; auto. Qed.  
+  Proof. unfold eqk, ltk; auto. Qed.
 
   Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
   Proof.
@@ -443,6 +317,30 @@ Module KeyOrderedType(O:OrderedType).
   Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
   Hint Immediate eqk_sym eqke_sym.
 
+  Global Instance eqk_equiv : Equivalence eqk.
+  Proof. split; eauto. Qed.
+
+  Global Instance eqke_equiv : Equivalence eqke.
+  Proof. split; eauto. Qed.
+
+  Global Instance ltk_strorder : StrictOrder ltk.
+  Proof.
+   split; eauto.
+   intros (x,e); compute; apply (StrictOrder_Irreflexive x).
+  Qed.
+
+  Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
+  Proof.
+  intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute.
+   compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto.
+  Qed.
+
+  Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk.
+  Proof.
+  intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute.
+   compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto.
+  Qed.
+
   (* Additionnal facts *)
 
   Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'.
@@ -458,10 +356,10 @@ Module KeyOrderedType(O:OrderedType).
       intros (k,e) (k',e') (k'',e'').
       unfold ltk, eqk; simpl; eauto.
   Qed.
-  Hint Resolve eqk_not_ltk. 
+  Hint Resolve eqk_not_ltk.
   Hint Immediate ltk_eqk eqk_ltk.
 
-  Lemma InA_eqke_eqk : 
+  Lemma InA_eqke_eqk :
      forall x m, InA eqke x m -> InA eqk x m.
   Proof.
     unfold eqke; induction 1; intuition.
@@ -490,30 +388,30 @@ Module KeyOrderedType(O:OrderedType).
 
   Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
   Proof.
-  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto.
+  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *.
   Qed.
 
   Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
   Proof.
   destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
-  Qed. 
+  Qed.
 
   Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
-  Proof. exact (InfA_eqA eqk_ltk). Qed.
+  Proof. exact (InfA_eqA eqk_equiv ltk_strorder ltk_compat). Qed.
 
   Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
-  Proof. exact (InfA_ltA ltk_trans). Qed.
+  Proof. exact (InfA_ltA ltk_strorder). Qed.
 
   Hint Immediate Inf_eq.
   Hint Resolve Inf_lt.
 
-  Lemma Sort_Inf_In : 
+  Lemma Sort_Inf_In :
       forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
-  Proof. 
-  exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk).
+  Proof.
+  exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compat).
   Qed.
 
-  Lemma Sort_Inf_NotIn : 
+  Lemma Sort_Inf_NotIn :
       forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
   Proof.
     intros; red; intros.
@@ -524,8 +422,8 @@ Module KeyOrderedType(O:OrderedType).
   Qed.
 
   Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
-  Proof. 
-  exact (SortA_NoDupA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk).
+  Proof.
+  exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compat).
   Qed.
 
   Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
@@ -540,7 +438,7 @@ Module KeyOrderedType(O:OrderedType).
     left; apply Sort_In_cons_1 with l; auto.
   Qed.
 
-  Lemma Sort_In_cons_3 : 
+  Lemma Sort_In_cons_3 :
     forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
   Proof.
     inversion_clear 1; red; intros.
@@ -552,15 +450,15 @@ Module KeyOrderedType(O:OrderedType).
     inversion 1.
     inversion_clear H0; eauto.
     destruct H1; simpl in *; intuition.
-  Qed.      
+  Qed.
 
-  Lemma In_inv_2 : forall k k' e e' l, 
+  Lemma In_inv_2 : forall k k' e e' l,
       InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
-  Proof.  
+  Proof.
    inversion_clear 1; compute in H0; intuition.
   Qed.
 
-  Lemma In_inv_3 : forall x x' l, 
+  Lemma In_inv_3 : forall x x' l,
       InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
   Proof.
    inversion_clear 1; compute in H0; intuition.
@@ -573,7 +471,7 @@ Module KeyOrderedType(O:OrderedType).
  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
  Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
  Hint Immediate eqk_sym eqke_sym.
- Hint Resolve eqk_not_ltk. 
+ Hint Resolve eqk_not_ltk.
  Hint Immediate ltk_eqk eqk_ltk.
  Hint Resolve InA_eqke_eqk.
  Hint Unfold MapsTo In.
diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v
index 9d179995..23ae4c85 100644
--- a/theories/FSets/OrderedTypeAlt.v
+++ b/theories/Structures/OrderedTypeAlt.v
@@ -5,13 +5,7 @@
 (*    //   *      This file is distributed under the terms of the      *)
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
-
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
-
-(* $Id: OrderedTypeAlt.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(* $Id$ *)
 
 Require Import OrderedType.
 
@@ -19,23 +13,23 @@ Require Import OrderedType.
    inferface. *)
 
 (** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt]
-whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] 
+whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ]
 *)
 
 Module Type OrderedTypeAlt.
 
  Parameter t : Type.
- 
+
  Parameter compare : t -> t -> comparison.
 
  Infix "?=" := compare (at level 70, no associativity).
 
- Parameter compare_sym : 
+ Parameter compare_sym :
    forall x y, (y?=x) = CompOpp (x?=y).
- Parameter compare_trans : 
+ Parameter compare_trans :
    forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
 
-End OrderedTypeAlt. 
+End OrderedTypeAlt.
 
 (** From this new presentation to the original one. *)
 
@@ -56,7 +50,7 @@ Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
  Qed.
 
  Lemma eq_sym : forall x y, eq x y -> eq y x.
- Proof. 
+ Proof.
  unfold eq; intros.
  rewrite compare_sym.
  rewrite H; simpl; auto.
@@ -88,7 +82,7 @@ Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
  case (x ?= y); [ left | right | right ]; auto; discriminate.
  Defined.
 
-End OrderedType_from_Alt. 
+End OrderedType_from_Alt.
 
 (** From the original presentation to this alternative one. *)
 
@@ -99,30 +93,30 @@ Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
 
  Definition t := t.
 
- Definition compare x y := match compare x y with 
+ Definition compare x y := match compare x y with
    | LT _ => Lt
    | EQ _ => Eq
    | GT _ => Gt
-  end. 
+  end.
 
  Infix "?=" := compare (at level 70, no associativity).
 
- Lemma compare_sym : 
+ Lemma compare_sym :
    forall x y, (y?=x) = CompOpp (x?=y).
  Proof.
  intros x y; unfold compare.
  destruct O.compare; elim_comp; simpl; auto.
  Qed.
- 
- Lemma compare_trans : 
+
+ Lemma compare_trans :
    forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
  Proof.
  intros c x y z.
- destruct c; unfold compare; 
- do 2 (destruct O.compare; intros; try discriminate); 
+ destruct c; unfold compare;
+ do 2 (destruct O.compare; intros; try discriminate);
  elim_comp; auto.
  Qed.
 
 End OrderedType_to_Alt.
 
- 
+
diff --git a/theories/FSets/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v
index 03e3ab83..b4dbceba 100644
--- a/theories/FSets/OrderedTypeEx.v
+++ b/theories/Structures/OrderedTypeEx.v
@@ -6,12 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
-
-(* $Id: OrderedTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *)
+(* $Id$ *)
 
 Require Import OrderedType.
 Require Import ZArith.
@@ -21,7 +16,7 @@ Require Import Compare_dec.
 
 (** * Examples of Ordered Type structures. *)
 
-(** First, a particular case of [OrderedType] where 
+(** First, a particular case of [OrderedType] where
     the equality is the usual one of Coq. *)
 
 Module Type UsualOrderedType.
@@ -55,18 +50,17 @@ Module Nat_as_OT <: UsualOrderedType.
   Definition lt := lt.
 
   Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
-  Proof. unfold lt in |- *; intros; apply lt_trans with y; auto. Qed.
+  Proof. unfold lt; intros; apply lt_trans with y; auto. Qed.
 
   Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
-  Proof. unfold lt, eq in |- *; intros; omega. Qed.
+  Proof. unfold lt, eq; intros; omega. Qed.
 
   Definition compare : forall x y : t, Compare lt eq x y.
   Proof.
-    intros; case (lt_eq_lt_dec x y).
-    simple destruct 1; intro.
-    constructor 1; auto.
-    constructor 2; auto.
-    intro; constructor 3; auto.
+    intros x y; destruct (nat_compare x y) as [ | | ]_eqn.
+    apply EQ. apply nat_compare_eq; assumption.
+    apply LT. apply nat_compare_Lt_lt; assumption.
+    apply GT. apply nat_compare_Gt_gt; assumption.
   Defined.
 
   Definition eq_dec := eq_nat_dec.
@@ -81,7 +75,7 @@ Open Local Scope Z_scope.
 Module Z_as_OT <: UsualOrderedType.
 
   Definition t := Z.
-  Definition eq := @eq Z. 
+  Definition eq := @eq Z.
   Definition eq_refl := @refl_equal t.
   Definition eq_sym := @sym_eq t.
   Definition eq_trans := @trans_eq t.
@@ -96,17 +90,17 @@ Module Z_as_OT <: UsualOrderedType.
 
   Definition compare : forall x y, Compare lt eq x y.
   Proof.
-    intros x y; case_eq (x ?= y); intros.
-    apply EQ; unfold eq; apply Zcompare_Eq_eq; auto.
-    apply LT; unfold lt, Zlt; auto.
-    apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto.
+    intros x y; destruct (x ?= y) as [ | | ]_eqn.
+    apply EQ; apply Zcompare_Eq_eq; assumption.
+    apply LT; assumption.
+    apply GT; apply Zgt_lt; assumption.
   Defined.
 
   Definition eq_dec := Z_eq_dec.
 
 End Z_as_OT.
 
-(** [positive] is an ordered type with respect to the usual order on natural numbers. *) 
+(** [positive] is an ordered type with respect to the usual order on natural numbers. *)
 
 Open Local Scope positive_scope.
 
@@ -118,9 +112,9 @@ Module Positive_as_OT <: UsualOrderedType.
   Definition eq_trans := @trans_eq t.
 
   Definition lt p q:= (p ?= q) Eq = Lt.
- 
+
   Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
-  Proof. 
+  Proof.
   unfold lt; intros x y z.
   change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z).
   omega.
@@ -136,13 +130,10 @@ Module Positive_as_OT <: UsualOrderedType.
 
   Definition compare : forall x y : t, Compare lt eq x y.
   Proof.
-  intros x y.
-  case_eq ((x ?= y) Eq); intros.
-  apply EQ; apply Pcompare_Eq_eq; auto.
-  apply LT; unfold lt; auto.
-  apply GT; unfold lt.
-  replace Eq with (CompOpp Eq); auto.
-  rewrite <- Pcompare_antisym; rewrite H; auto.
+  intros x y. destruct ((x ?= y) Eq) as [ | | ]_eqn.
+  apply EQ; apply Pcompare_Eq_eq; assumption.
+  apply LT; assumption.
+  apply GT; apply ZC1; assumption.
   Defined.
 
   Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
@@ -153,7 +144,7 @@ Module Positive_as_OT <: UsualOrderedType.
 End Positive_as_OT.
 
 
-(** [N] is an ordered type with respect to the usual order on natural numbers. *) 
+(** [N] is an ordered type with respect to the usual order on natural numbers. *)
 
 Open Local Scope positive_scope.
 
@@ -164,33 +155,16 @@ Module N_as_OT <: UsualOrderedType.
   Definition eq_sym := @sym_eq t.
   Definition eq_trans := @trans_eq t.
 
-  Definition lt p q:= Nleb q p = false.
- 
-  Definition lt_trans := Nltb_trans.
-
-  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
-  Proof.
-  intros; intro.
-  rewrite H0 in H.
-  unfold lt in H.
-  rewrite Nleb_refl in H; discriminate.
-  Qed.
+  Definition lt:=Nlt.
+  Definition lt_trans := Nlt_trans.
+  Definition lt_not_eq := Nlt_not_eq.
 
   Definition compare : forall x y : t, Compare lt eq x y.
   Proof.
-  intros x y.
-  case_eq ((x ?= y)%N); intros.
-  apply EQ; apply Ncompare_Eq_eq; auto.
-  apply LT; unfold lt; auto.
-   generalize (Nleb_Nle y x).
-   unfold Nle; rewrite <- Ncompare_antisym.
-   destruct (x ?= y)%N; simpl; try discriminate.
-   clear H; intros H.
-   destruct (Nleb y x); intuition.
-  apply GT; unfold lt.
-   generalize (Nleb_Nle x y).
-   unfold Nle; destruct (x ?= y)%N; simpl; try discriminate.
-   destruct (Nleb x y); intuition.
+  intros x y. destruct (x ?= y)%N as [ | | ]_eqn.
+  apply EQ; apply Ncompare_Eq_eq; assumption.
+  apply LT; assumption.
+  apply GT. apply Ngt_Nlt; assumption.
   Defined.
 
   Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
@@ -201,7 +175,7 @@ Module N_as_OT <: UsualOrderedType.
 End N_as_OT.
 
 
-(** From two ordered types, we can build a new OrderedType 
+(** From two ordered types, we can build a new OrderedType
    over their cartesian product, using the lexicographic order. *)
 
 Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
@@ -209,29 +183,29 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
  Module MO2:=OrderedTypeFacts(O2).
 
  Definition t := prod O1.t O2.t.
-  
+
  Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).
 
- Definition lt x y := 
-    O1.lt (fst x) (fst y) \/ 
+ Definition lt x y :=
+    O1.lt (fst x) (fst y) \/
     (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).
 
  Lemma eq_refl : forall x : t, eq x x.
- Proof. 
+ Proof.
  intros (x1,x2); red; simpl; auto.
  Qed.
 
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
- Proof. 
+ Proof.
  intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
  Qed.
 
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
- Proof. 
+ Proof.
  intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
  Qed.
- 
- Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 
+
+ Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
  intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
  left; eauto.
@@ -267,3 +241,93 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
 
 End PairOrderedType.
 
+
+(** Even if [positive] can be seen as an ordered type with respect to the
+  usual order (see above), we can also use a lexicographic order over bits
+  (lower bits are considered first). This is more natural when using
+  [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)
+
+Module PositiveOrderedTypeBits <: UsualOrderedType.
+  Definition t:=positive.
+  Definition eq:=@eq positive.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Fixpoint bits_lt (p q:positive) : Prop :=
+   match p, q with
+   | xH, xI _ => True
+   | xH, _ => False
+   | xO p, xO q => bits_lt p q
+   | xO _, _ => True
+   | xI p, xI q => bits_lt p q
+   | xI _, _ => False
+   end.
+
+  Definition lt:=bits_lt.
+
+  Lemma bits_lt_trans :
+    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
+  Proof.
+  induction x.
+  induction y; destruct z; simpl; eauto; intuition.
+  induction y; destruct z; simpl; eauto; intuition.
+  induction y; destruct z; simpl; eauto; intuition.
+  Qed.
+
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof.
+  exact bits_lt_trans.
+  Qed.
+
+  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
+  Proof.
+  induction x; simpl; auto.
+  Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite <- H0 in H; clear H0 y.
+  unfold lt in H.
+  exact (bits_lt_antirefl x H).
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  induction x; destruct y.
+  (* I I *)
+  destruct (IHx y).
+  apply LT; auto.
+  apply EQ; rewrite e; red; auto.
+  apply GT; auto.
+  (* I O *)
+  apply GT; simpl; auto.
+  (* I H *)
+  apply GT; simpl; auto.
+  (* O I *)
+  apply LT; simpl; auto.
+  (* O O *)
+  destruct (IHx y).
+  apply LT; auto.
+  apply EQ; rewrite e; red; auto.
+  apply GT; auto.
+  (* O H *)
+  apply LT; simpl; auto.
+  (* H I *)
+  apply LT; simpl; auto.
+  (* H O *)
+  apply GT; simpl; auto.
+  (* H H *)
+  apply EQ; red; auto.
+  Qed.
+
+  Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
+  Proof.
+  intros. case_eq ((x ?= y) Eq); intros.
+  left. apply Pcompare_Eq_eq; auto.
+  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+  Qed.
+
+End PositiveOrderedTypeBits.
diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v
new file mode 100644
index 00000000..bddd461a
--- /dev/null
+++ b/theories/Structures/Orders.v
@@ -0,0 +1,333 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Relations Morphisms Setoid Equalities.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Ordered types *)
+
+(** First, signatures with only the order relations *)
+
+Module Type HasLt (Import T:Typ).
+  Parameter Inline lt : t -> t -> Prop.
+End HasLt.
+
+Module Type HasLe (Import T:Typ).
+  Parameter Inline le : t -> t -> Prop.
+End HasLe.
+
+Module Type EqLt := Typ <+ HasEq <+ HasLt.
+Module Type EqLe := Typ <+ HasEq <+ HasLe.
+Module Type EqLtLe := Typ <+ HasEq <+ HasLt <+ HasLe.
+
+(** Versions with nice notations *)
+
+Module Type LtNotation (E:EqLt).
+  Infix "<" := E.lt.
+  Notation "x > y" := (y<x) (only parsing).
+  Notation "x < y < z" := (x<y /\ y<z).
+End LtNotation.
+
+Module Type LeNotation (E:EqLe).
+  Infix "<=" := E.le.
+  Notation "x >= y" := (y<=x) (only parsing).
+  Notation "x <= y <= z" := (x<=y /\ y<=z).
+End LeNotation.
+
+Module Type LtLeNotation (E:EqLtLe).
+  Include LtNotation E <+ LeNotation E.
+  Notation "x <= y < z" := (x<=y /\ y<z).
+  Notation "x < y <= z" := (x<y /\ y<=z).
+End LtLeNotation.
+
+Module Type EqLtNotation (E:EqLt) := EqNotation E <+ LtNotation E.
+Module Type EqLeNotation (E:EqLe) := EqNotation E <+ LeNotation E.
+Module Type EqLtLeNotation (E:EqLtLe) := EqNotation E <+ LtLeNotation E.
+
+Module Type EqLt' := EqLt <+ EqLtNotation.
+Module Type EqLe' := EqLe <+ EqLeNotation.
+Module Type EqLtLe' := EqLtLe <+ EqLtLeNotation.
+
+(** Versions with logical specifications *)
+
+Module Type IsStrOrder (Import E:EqLt).
+  Declare Instance lt_strorder : StrictOrder lt.
+  Declare Instance lt_compat : Proper (eq==>eq==>iff) lt.
+End IsStrOrder.
+
+Module Type LeIsLtEq (Import E:EqLtLe').
+  Axiom le_lteq : forall x y, x<=y <-> x<y \/ x==y.
+End LeIsLtEq.
+
+Module Type HasCompare (Import E:EqLt).
+  Parameter Inline compare : t -> t -> comparison.
+  Axiom compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+End HasCompare.
+
+Module Type StrOrder := EqualityType <+ HasLt <+ IsStrOrder.
+Module Type DecStrOrder := StrOrder <+ HasCompare.
+Module Type OrderedType <: DecidableType := DecStrOrder <+ HasEqDec.
+Module Type OrderedTypeFull := OrderedType <+ HasLe <+ LeIsLtEq.
+
+Module Type StrOrder' := StrOrder <+ EqLtNotation.
+Module Type DecStrOrder' := DecStrOrder <+ EqLtNotation.
+Module Type OrderedType' := OrderedType <+ EqLtNotation.
+Module Type OrderedTypeFull' := OrderedTypeFull <+ EqLtLeNotation.
+
+(** NB: in [OrderedType], an [eq_dec] could be deduced from [compare].
+  But adding this redundant field allows to see an [OrderedType] as a
+  [DecidableType]. *)
+
+(** * Versions with [eq] being the usual Leibniz equality of Coq *)
+
+Module Type UsualStrOrder := UsualEqualityType <+ HasLt <+ IsStrOrder.
+Module Type UsualDecStrOrder := UsualStrOrder <+ HasCompare.
+Module Type UsualOrderedType <: UsualDecidableType <: OrderedType
+ := UsualDecStrOrder <+ HasEqDec.
+Module Type UsualOrderedTypeFull := UsualOrderedType <+ HasLe <+ LeIsLtEq.
+
+(** NB: in [UsualOrderedType], the field [lt_compat] is
+    useless since [eq] is [Leibniz], but it should be
+    there for subtyping. *)
+
+Module Type UsualStrOrder' := UsualStrOrder <+ LtNotation.
+Module Type UsualDecStrOrder' := UsualDecStrOrder <+ LtNotation.
+Module Type UsualOrderedType' := UsualOrderedType <+ LtNotation.
+Module Type UsualOrderedTypeFull' := UsualOrderedTypeFull <+ LtLeNotation.
+
+(** * Purely logical versions *)
+
+Module Type LtIsTotal (Import E:EqLt').
+  Axiom lt_total : forall x y, x<y \/ x==y \/ y<x.
+End LtIsTotal.
+
+Module Type TotalOrder := StrOrder <+ HasLe <+ LeIsLtEq <+ LtIsTotal.
+Module Type UsualTotalOrder <: TotalOrder
+ := UsualStrOrder <+ HasLe <+ LeIsLtEq <+ LtIsTotal.
+
+Module Type TotalOrder' := TotalOrder <+ EqLtLeNotation.
+Module Type UsualTotalOrder' := UsualTotalOrder <+ LtLeNotation.
+
+(** * Conversions *)
+
+(** From [compare] to [eqb], and then [eq_dec] *)
+
+Module Compare2EqBool (Import O:DecStrOrder') <: HasEqBool O.
+
+ Definition eqb x y :=
+   match compare x y with Eq => true | _ => false end.
+
+ Lemma eqb_eq : forall x y, eqb x y = true <-> x==y.
+ Proof.
+ unfold eqb. intros x y.
+ destruct (compare_spec x y) as [H|H|H]; split; auto; try discriminate.
+ intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H).
+ intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H).
+ Qed.
+
+End Compare2EqBool.
+
+Module DSO_to_OT (O:DecStrOrder) <: OrderedType :=
+  O <+ Compare2EqBool <+ HasEqBool2Dec.
+
+(** From [OrderedType] To [OrderedTypeFull] (adding [<=]) *)
+
+Module OT_to_Full (O:OrderedType') <: OrderedTypeFull.
+ Include O.
+ Definition le x y := x<y \/ x==y.
+ Lemma le_lteq : forall x y, le x y <-> x<y \/ x==y.
+ Proof. unfold le; split; auto. Qed.
+End OT_to_Full.
+
+(** From computational to logical versions *)
+
+Module OTF_LtIsTotal (Import O:OrderedTypeFull') <: LtIsTotal O.
+ Lemma lt_total : forall x y, x<y \/ x==y \/ y<x.
+ Proof. intros; destruct (compare_spec x y); auto. Qed.
+End OTF_LtIsTotal.
+
+Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder
+ := O <+ OTF_LtIsTotal.
+
+
+(** * Versions with boolean comparisons
+
+    This style is used in [Mergesort]
+*)
+
+(** For stating properties like transitivity  of [leb],
+    we coerce [bool] into [Prop]. *)
+
+Local Coercion is_true : bool >-> Sortclass.
+Hint Unfold is_true.
+
+Module Type HasLeBool (Import T:Typ).
+  Parameter Inline leb : t -> t -> bool.
+End HasLeBool.
+
+Module Type HasLtBool (Import T:Typ).
+  Parameter Inline ltb : t -> t -> bool.
+End HasLtBool.
+
+Module Type LeBool := Typ <+ HasLeBool.
+Module Type LtBool := Typ <+ HasLtBool.
+
+Module Type LeBoolNotation (E:LeBool).
+  Infix "<=?" := E.leb (at level 35).
+End LeBoolNotation.
+
+Module Type LtBoolNotation (E:LtBool).
+  Infix "<?" := E.ltb (at level 35).
+End LtBoolNotation.
+
+Module Type LeBool' := LeBool <+ LeBoolNotation.
+Module Type LtBool' := LtBool <+ LtBoolNotation.
+
+Module Type LeBool_Le (T:Typ)(X:HasLeBool T)(Y:HasLe T).
+ Parameter leb_le : forall x y, X.leb x y = true <-> Y.le x y.
+End LeBool_Le.
+
+Module Type LtBool_Lt (T:Typ)(X:HasLtBool T)(Y:HasLt T).
+ Parameter ltb_lt : forall x y, X.ltb x y = true <-> Y.lt x y.
+End LtBool_Lt.
+
+Module Type LeBoolIsTotal (Import X:LeBool').
+ Axiom leb_total : forall x y, (x <=? y) = true \/ (y <=? x) = true.
+End LeBoolIsTotal.
+
+Module Type TotalLeBool := LeBool <+ LeBoolIsTotal.
+Module Type TotalLeBool' := LeBool' <+ LeBoolIsTotal.
+
+Module Type LeBoolIsTransitive (Import X:LeBool').
+ Axiom leb_trans : Transitive X.leb.
+End LeBoolIsTransitive.
+
+Module Type TotalTransitiveLeBool := TotalLeBool <+ LeBoolIsTransitive.
+Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LeBoolIsTransitive.
+
+
+(** * From [OrderedTypeFull] to [TotalTransitiveLeBool] *)
+
+Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool.
+
+ Definition leb x y :=
+  match compare x y with Gt => false | _ => true end.
+
+ Lemma leb_le : forall x y, leb x y <-> x <= y.
+ Proof.
+ intros. unfold leb. rewrite le_lteq.
+ destruct (compare_spec x y) as [EQ|LT|GT]; split; auto.
+ discriminate.
+ intros LE. elim (StrictOrder_Irreflexive x).
+ destruct LE as [LT|EQ]. now transitivity y. now rewrite <- EQ in GT.
+ Qed.
+
+ Lemma leb_total : forall x y, leb x y \/ leb y x.
+ Proof.
+ intros. rewrite 2 leb_le. rewrite 2 le_lteq.
+ destruct (compare_spec x y); intuition.
+ Qed.
+
+ Lemma leb_trans : Transitive leb.
+ Proof.
+ intros x y z. rewrite !leb_le, !le_lteq.
+ intros [Hxy|Hxy] [Hyz|Hyz].
+ left; transitivity y; auto.
+ left; rewrite <- Hyz; auto.
+ left; rewrite Hxy; auto.
+ right; transitivity y; auto.
+ Qed.
+
+ Definition t := t.
+
+End OTF_to_TTLB.
+
+
+(** * From [TotalTransitiveLeBool] to [OrderedTypeFull]
+
+    [le] is [leb ... = true].
+    [eq] is [le /\ swap le].
+    [lt] is [le /\ ~swap le].
+*)
+
+Local Open Scope bool_scope.
+
+Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull.
+
+ Definition t := t.
+
+ Definition le x y : Prop := x <=? y.
+ Definition eq x y : Prop := le x y /\ le y x.
+ Definition lt x y : Prop := le x y /\ ~le y x.
+
+ Definition compare x y :=
+  if x <=? y then (if y <=? x then Eq else Lt) else Gt.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+ intros. unfold compare.
+ case_eq (x <=? y).
+ case_eq (y <=? x).
+ constructor. split; auto.
+ constructor. split; congruence.
+ constructor. destruct (leb_total x y); split; congruence.
+ Qed.
+
+ Definition eqb x y := (x <=? y) && (y <=? x).
+
+ Lemma eqb_eq : forall x y, eqb x y <-> eq x y.
+ Proof.
+ intros. unfold eq, eqb, le.
+ case leb; simpl; intuition; discriminate.
+ Qed.
+
+ Include HasEqBool2Dec.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+ split.
+ intros x; unfold eq, le. destruct (leb_total x x); auto.
+ intros x y; unfold eq, le. intuition.
+ intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split.
+ intros x. unfold lt; red; intuition.
+ intros x y z; unfold lt, le. intuition.
+ apply leb_trans with y; auto.
+ absurd (z <=? y); auto.
+ apply leb_trans with x; auto.
+ Qed.
+
+ Instance lt_compat : Proper (eq ==> eq ==> iff) lt.
+ Proof.
+ apply proper_sym_impl_iff_2; auto with *.
+ intros x x' Hx y y' Hy' H. unfold eq, lt, le in *.
+ intuition.
+ apply leb_trans with x; auto.
+ apply leb_trans with y; auto.
+ absurd (y <=? x); auto.
+ apply leb_trans with x'; auto.
+ apply leb_trans with y'; auto.
+ Qed.
+
+ Definition le_lteq : forall x y, le x y <-> lt x y \/ eq x y.
+ Proof.
+ intros.
+ unfold lt, eq, le.
+ split; [ | intuition ].
+ intros LE.
+ case_eq (y <=? x); [right|left]; intuition; try discriminate.
+ Qed.
+
+End TTLB_to_OTF.
diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v
new file mode 100644
index 00000000..d86b02a1
--- /dev/null
+++ b/theories/Structures/OrdersAlt.v
@@ -0,0 +1,242 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Finite sets library.
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id$ *)
+
+Require Import OrderedType Orders.
+Set Implicit Arguments.
+
+(** * Some alternative (but equivalent) presentations for an Ordered Type
+   inferface. *)
+
+(** ** The original interface *)
+
+Module Type OrderedTypeOrig := OrderedType.OrderedType.
+
+(** ** An interface based on compare *)
+
+Module Type OrderedTypeAlt.
+
+ Parameter t : Type.
+
+ Parameter compare : t -> t -> comparison.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Parameter compare_sym :
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Parameter compare_trans :
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+
+End OrderedTypeAlt.
+
+(** ** From OrderedTypeOrig to OrderedType. *)
+
+Module Update_OT (O:OrderedTypeOrig) <: OrderedType.
+
+ Include Update_DT O.  (* Provides : t eq eq_equiv eq_dec *)
+
+ Definition lt := O.lt.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+  split.
+  intros x Hx. apply (O.lt_not_eq Hx); auto with *.
+  exact O.lt_trans.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+  apply proper_sym_impl_iff_2; auto with *.
+  intros x x' Hx y y' Hy H.
+  assert (H0 : lt x' y).
+   destruct (O.compare x' y) as [H'|H'|H']; auto.
+   elim (O.lt_not_eq H). transitivity x'; auto with *.
+   elim (O.lt_not_eq (O.lt_trans H H')); auto.
+  destruct (O.compare x' y') as [H'|H'|H']; auto.
+  elim (O.lt_not_eq H).
+   transitivity x'; auto with *. transitivity y'; auto with *.
+  elim (O.lt_not_eq (O.lt_trans H' H0)); auto with *.
+ Qed.
+
+ Definition compare x y :=
+   match O.compare x y with
+    | EQ _ => Eq
+    | LT _ => Lt
+    | GT _ => Gt
+  end.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+  intros; unfold compare; destruct O.compare; auto.
+ Qed.
+
+End Update_OT.
+
+(** ** From OrderedType to OrderedTypeOrig. *)
+
+Module Backport_OT (O:OrderedType) <: OrderedTypeOrig.
+
+ Include Backport_DT O. (* Provides : t eq eq_refl eq_sym eq_trans eq_dec *)
+
+ Definition lt := O.lt.
+
+ Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
+ Proof.
+  intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto.
+ Qed.
+
+ Lemma lt_trans : Transitive lt.
+ Proof. apply O.lt_strorder. Qed.
+
+ Definition compare : forall x y, Compare lt eq x y.
+ Proof.
+  intros x y; destruct (CompSpec2Type (O.compare_spec x y));
+   [apply EQ|apply LT|apply GT]; auto.
+ Defined.
+
+End Backport_OT.
+
+
+(** ** From OrderedTypeAlt to OrderedType. *)
+
+Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType.
+
+ Definition t := t.
+
+ Definition eq x y := (x?=y) = Eq.
+ Definition lt x y := (x?=y) = Lt.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+  split; red.
+  (* refl *)
+  unfold eq; intros x.
+  assert (H:=compare_sym x x).
+  destruct (x ?= x); simpl in *; auto; discriminate.
+  (* sym *)
+  unfold eq; intros x y H.
+  rewrite compare_sym, H; simpl; auto.
+  (* trans *)
+  apply compare_trans.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+  split; repeat red; unfold lt; try apply compare_trans.
+  intros x H.
+  assert (eq x x) by reflexivity.
+  unfold eq in *; congruence.
+ Qed.
+
+ Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
+ Proof.
+  unfold lt, eq; intros x y z Hxy Hyz.
+  destruct (compare x z) as [ ]_eqn:Hxz; auto.
+  rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz.
+  rewrite (compare_trans Hxz Hyz) in Hxy; discriminate.
+  rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy.
+  rewrite (compare_trans Hxy Hxz) in Hyz; discriminate.
+ Qed.
+
+ Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.
+ Proof.
+  unfold lt, eq; intros x y z Hxy Hyz.
+  destruct (compare x z) as [ ]_eqn:Hxz; auto.
+  rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy.
+  rewrite (compare_trans Hxy Hxz) in Hyz; discriminate.
+  rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz.
+  rewrite (compare_trans Hxz Hyz) in Hxy; discriminate.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+  apply proper_sym_impl_iff_2; auto with *.
+  repeat red; intros.
+  eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto.
+ Qed.
+
+ Definition compare := O.compare.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+  unfold eq, lt, compare; intros.
+  destruct (O.compare x y) as [ ]_eqn:H; auto.
+  apply CompGt.
+  rewrite compare_sym, H; auto.
+ Qed.
+
+ Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
+ Proof.
+ intros; unfold eq.
+ case (x ?= y); [ left | right | right ]; auto; discriminate.
+ Defined.
+
+End OT_from_Alt.
+
+(** From the original presentation to this alternative one. *)
+
+Module OT_to_Alt (Import O:OrderedType) <: OrderedTypeAlt.
+
+ Definition t := t.
+ Definition compare := compare.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Lemma compare_sym :
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Proof.
+ intros x y; unfold compare.
+ destruct (compare_spec x y) as [U|U|U];
+  destruct (compare_spec y x) as [V|V|V]; auto.
+ rewrite U in V. elim (StrictOrder_Irreflexive y); auto.
+ rewrite U in V. elim (StrictOrder_Irreflexive y); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive x); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive x); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive x); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive y); auto.
+ Qed.
+
+ Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y.
+ Proof.
+ unfold compare.
+ intros x y; destruct (compare_spec x y); intuition;
+  try discriminate.
+ rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto.
+ rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto.
+ Qed.
+
+ Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y.
+ Proof.
+ unfold compare.
+ intros x y; destruct (compare_spec x y); intuition;
+  try discriminate.
+ rewrite H in H0. elim (StrictOrder_Irreflexive y); auto.
+ rewrite H in H0. elim (StrictOrder_Irreflexive x); auto.
+ Qed.
+
+ Lemma compare_Gt : forall x y, compare x y = Gt <-> lt y x.
+ Proof.
+ intros x y. rewrite compare_sym, CompOpp_iff. apply compare_Lt.
+ Qed.
+
+ Lemma compare_trans :
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+ Proof.
+ intros c x y z.
+ destruct c; unfold compare;
+  rewrite ?compare_Eq, ?compare_Lt, ?compare_Gt;
+  transitivity y; auto.
+ Qed.
+
+End OT_to_Alt.
diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v
new file mode 100644
index 00000000..56f1d5de
--- /dev/null
+++ b/theories/Structures/OrdersEx.v
@@ -0,0 +1,88 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Finite sets library.
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id$ *)
+
+Require Import Orders NatOrderedType POrderedType NOrderedType
+ ZOrderedType RelationPairs EqualitiesFacts.
+
+(** * Examples of Ordered Type structures. *)
+
+
+(** Ordered Type for [nat], [Positive], [N], [Z] with the usual order. *)
+
+Module Nat_as_OT := NatOrderedType.Nat_as_OT.
+Module Positive_as_OT := POrderedType.Positive_as_OT.
+Module N_as_OT := NOrderedType.N_as_OT.
+Module Z_as_OT := ZOrderedType.Z_as_OT.
+
+(** An OrderedType can now directly be seen as a DecidableType *)
+
+Module OT_as_DT (O:OrderedType) <: DecidableType := O.
+
+(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)
+
+Module Nat_as_DT <: UsualDecidableType := Nat_as_OT.
+Module Positive_as_DT <: UsualDecidableType := Positive_as_OT.
+Module N_as_DT <: UsualDecidableType := N_as_OT.
+Module Z_as_DT <: UsualDecidableType := Z_as_OT.
+
+
+
+(** From two ordered types, we can build a new OrderedType
+   over their cartesian product, using the lexicographic order. *)
+
+Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
+ Include PairDecidableType O1 O2.
+
+ Definition lt :=
+   (relation_disjunction (O1.lt @@1) (O1.eq * O2.lt))%signature.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split.
+ (* irreflexive *)
+ intros (x1,x2); compute. destruct 1.
+ apply (StrictOrder_Irreflexive x1); auto.
+ apply (StrictOrder_Irreflexive x2); intuition.
+ (* transitive *)
+ intros (x1,x2) (y1,y2) (z1,z2). compute. intuition.
+ left; etransitivity; eauto.
+ left. setoid_replace z1 with y1; auto with relations.
+ left; setoid_replace x1 with y1; auto with relations.
+ right; split; etransitivity; eauto.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+ compute.
+ intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2).
+ rewrite X1,X2,Y1,Y2; intuition.
+ Qed.
+
+ Definition compare x y :=
+  match O1.compare (fst x) (fst y) with
+   | Eq => O2.compare (snd x) (snd y)
+   | Lt => Lt
+   | Gt => Gt
+  end.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+ intros (x1,x2) (y1,y2); unfold compare; simpl.
+ destruct (O1.compare_spec x1 y1); try (constructor; compute; auto).
+ destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations.
+ Qed.
+
+End PairOrderedType.
+
diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v
new file mode 100644
index 00000000..a28b7977
--- /dev/null
+++ b/theories/Structures/OrdersFacts.v
@@ -0,0 +1,234 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+Require Import Basics OrdersTac.
+Require Export Orders.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Properties of [OrderedTypeFull] *)
+
+Module OrderedTypeFullFacts (Import O:OrderedTypeFull').
+
+ Module OrderTac := OTF_to_OrderTac O.
+ Ltac order := OrderTac.order.
+ Ltac iorder := intuition order.
+
+ Instance le_compat : Proper (eq==>eq==>iff) le.
+ Proof. repeat red; iorder. Qed.
+
+ Instance le_preorder : PreOrder le.
+ Proof. split; red; order. Qed.
+
+ Instance le_order : PartialOrder eq le.
+ Proof. compute; iorder. Qed.
+
+ Instance le_antisym : Antisymmetric _ eq le.
+ Proof. apply partial_order_antisym; auto with *. Qed.
+
+ Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x.
+ Proof. iorder. Qed.
+
+ Lemma lt_not_ge_iff : forall x y, x<y <-> ~y<=x.
+ Proof. iorder. Qed.
+
+ Lemma le_or_gt : forall x y, x<=y \/ y<x.
+ Proof. intros. rewrite le_lteq; destruct (O.compare_spec x y); auto. Qed.
+
+ Lemma lt_or_ge : forall x y, x<y \/ y<=x.
+ Proof. intros. rewrite le_lteq; destruct (O.compare_spec x y); iorder. Qed.
+
+ Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x.
+ Proof. iorder. Qed.
+
+End OrderedTypeFullFacts.
+
+
+(** * Properties of [OrderedType] *)
+
+Module OrderedTypeFacts (Import O: OrderedType').
+
+  Module OrderTac := OT_to_OrderTac O.
+  Ltac order := OrderTac.order.
+
+  Notation "x <= y" := (~lt y x) : order.
+  Infix "?=" := compare (at level 70, no associativity) : order.
+
+  Local Open Scope order.
+
+  Tactic Notation "elim_compare" constr(x) constr(y) :=
+   destruct (compare_spec x y).
+
+  Tactic Notation "elim_compare" constr(x) constr(y) "as" ident(h) :=
+   destruct (compare_spec x y) as [h|h|h].
+
+  (** The following lemmas are either re-phrasing of [eq_equiv] and
+      [lt_strorder] or immediately provable by [order]. Interest:
+      compatibility, test of order, etc *)
+
+  Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x.
+
+  Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y.
+
+  Definition eq_trans (x y z:t) : x==y -> y==z -> x==z :=
+   Equivalence_Transitive x y z.
+
+  Definition lt_trans (x y z:t) : x<y -> y<z -> x<z :=
+   StrictOrder_Transitive x y z.
+
+  Definition lt_irrefl (x:t) : ~x<x := StrictOrder_Irreflexive x.
+
+  (** Some more about [compare] *)
+
+  Lemma compare_eq_iff : forall x y, (x ?= y) = Eq <-> x==y.
+  Proof.
+   intros; elim_compare x y; intuition; try discriminate; order.
+  Qed.
+
+  Lemma compare_lt_iff : forall x y, (x ?= y) = Lt <-> x<y.
+  Proof.
+   intros; elim_compare x y; intuition; try discriminate; order.
+  Qed.
+
+  Lemma compare_gt_iff : forall x y, (x ?= y) = Gt <-> y<x.
+  Proof.
+   intros; elim_compare x y; intuition; try discriminate; order.
+  Qed.
+
+  Lemma compare_ge_iff : forall x y, (x ?= y) <> Lt <-> y<=x.
+  Proof.
+   intros; rewrite compare_lt_iff; intuition.
+  Qed.
+
+  Lemma compare_le_iff : forall x y, (x ?= y) <> Gt <-> x<=y.
+  Proof.
+   intros; rewrite compare_gt_iff; intuition.
+  Qed.
+
+  Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order.
+
+  Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
+  Proof.
+  intros x x' Hxx' y y' Hyy'.
+  elim_compare x' y'; autorewrite with order; order.
+  Qed.
+
+  Lemma compare_refl : forall x, (x ?= x) = Eq.
+  Proof.
+   intros; elim_compare x x; auto; order.
+  Qed.
+
+  Lemma compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y).
+  Proof.
+   intros; elim_compare x y; simpl; autorewrite with order; order.
+  Qed.
+
+  (** For compatibility reasons *)
+  Definition eq_dec := eq_dec.
+
+  Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
+  Proof.
+   intros x y; destruct (CompSpec2Type (compare_spec x y));
+    [ right | left | right ]; order.
+  Defined.
+
+  Definition eqb x y : bool := if eq_dec x y then true else false.
+
+  Lemma if_eq_dec : forall x y (B:Type)(b b':B),
+    (if eq_dec x y then b else b') =
+    (match compare x y with Eq => b | _ => b' end).
+  Proof.
+  intros; destruct eq_dec; elim_compare x y; auto; order.
+  Qed.
+
+  Lemma eqb_alt :
+    forall x y, eqb x y = match compare x y with Eq => true | _ => false end.
+  Proof.
+  unfold eqb; intros; apply if_eq_dec.
+  Qed.
+
+  Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb.
+  Proof.
+  intros x x' Hxx' y y' Hyy'.
+  rewrite 2 eqb_alt, Hxx', Hyy'; auto.
+  Qed.
+
+End OrderedTypeFacts.
+
+
+
+
+
+
+(** * Tests of the order tactic
+
+    Is it at least capable of proving some basic properties ? *)
+
+Module OrderedTypeTest (Import O:OrderedType').
+  Module Import MO := OrderedTypeFacts O.
+  Local Open Scope order.
+  Lemma lt_not_eq x y : x<y -> ~x==y.  Proof. order. Qed.
+  Lemma lt_eq x y z : x<y -> y==z -> x<z. Proof. order. Qed.
+  Lemma eq_lt x y z : x==y -> y<z -> x<z. Proof. order. Qed.
+  Lemma le_eq x y z : x<=y -> y==z -> x<=z. Proof. order. Qed.
+  Lemma eq_le x y z : x==y -> y<=z -> x<=z. Proof. order. Qed.
+  Lemma neq_eq x y z : ~x==y -> y==z -> ~x==z. Proof. order. Qed.
+  Lemma eq_neq x y z : x==y -> ~y==z -> ~x==z. Proof. order. Qed.
+  Lemma le_lt_trans x y z : x<=y -> y<z -> x<z. Proof. order. Qed.
+  Lemma lt_le_trans x y z : x<y -> y<=z -> x<z. Proof. order. Qed.
+  Lemma le_trans x y z : x<=y -> y<=z -> x<=z. Proof. order. Qed.
+  Lemma le_antisym x y : x<=y -> y<=x -> x==y. Proof. order. Qed.
+  Lemma le_neq x y : x<=y -> ~x==y -> x<y. Proof. order. Qed.
+  Lemma neq_sym x y : ~x==y -> ~y==x. Proof. order. Qed.
+  Lemma lt_le x y : x<y -> x<=y. Proof. order. Qed.
+  Lemma gt_not_eq x y : y<x -> ~x==y. Proof. order. Qed.
+  Lemma eq_not_lt x y : x==y -> ~x<y. Proof. order. Qed.
+  Lemma eq_not_gt x y : x==y -> ~ y<x. Proof. order. Qed.
+  Lemma lt_not_gt x y : x<y -> ~ y<x. Proof. order. Qed.
+  Lemma eq_is_nlt_ngt x y : x==y <-> ~x<y /\ ~y<x.
+  Proof. intuition; order. Qed.
+End OrderedTypeTest.
+
+
+
+(** * Reversed OrderedTypeFull.
+
+   we can switch the orientation of the order. This is used for
+   example when deriving properties of [min] out of the ones of [max]
+   (see [GenericMinMax]).
+*)
+
+Module OrderedTypeRev (O:OrderedTypeFull) <: OrderedTypeFull.
+
+Definition t := O.t.
+Definition eq := O.eq.
+Instance eq_equiv : Equivalence eq.
+Definition eq_dec := O.eq_dec.
+
+Definition lt := flip O.lt.
+Definition le := flip O.le.
+
+Instance lt_strorder: StrictOrder lt.
+Proof. unfold lt; auto with *. Qed.
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof. unfold lt; auto with *. Qed.
+
+Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y.
+Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition. Qed.
+
+Definition compare := flip O.compare.
+
+Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+Proof.
+intros; unfold compare, eq, lt, flip.
+destruct (O.compare_spec y x); auto with relations.
+Qed.
+
+End OrderedTypeRev.
+
diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v
new file mode 100644
index 00000000..2ed07026
--- /dev/null
+++ b/theories/Structures/OrdersLists.v
@@ -0,0 +1,256 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+Require Export RelationPairs SetoidList Orders.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Specialization of results about lists modulo. *)
+
+Module OrderedTypeLists (Import O:OrderedType).
+
+Section ForNotations.
+
+Notation In:=(InA eq).
+Notation Inf:=(lelistA lt).
+Notation Sort:=(sort lt).
+Notation NoDup:=(NoDupA eq).
+
+Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+Proof. intros. rewrite <- H; auto. Qed.
+
+Lemma ListIn_In : forall l x, List.In x l -> In x l.
+Proof. exact (In_InA eq_equiv). Qed.
+
+Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_ltA lt_strorder). Qed.
+
+Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed.
+
+Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
+Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.
+
+Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
+Proof. exact (@In_InfA t lt). Qed.
+
+Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
+Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed.
+
+Lemma Inf_alt :
+ forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
+Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed.
+
+Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
+Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed.
+
+End ForNotations.
+
+Hint Resolve ListIn_In Sort_NoDup Inf_lt.
+Hint Immediate In_eq Inf_lt.
+
+End OrderedTypeLists.
+
+
+
+
+
+(** * Results about keys and data as manipulated in FMaps. *)
+
+
+Module KeyOrderedType(Import O:OrderedType).
+ Module Import MO:=OrderedTypeLists(O).
+
+ Section Elt.
+ Variable elt : Type.
+ Notation key:=t.
+
+  Local Open Scope signature_scope.
+
+  Definition eqk : relation (key*elt) := eq @@1.
+  Definition eqke : relation (key*elt) := eq * Logic.eq.
+  Definition ltk : relation (key*elt) := lt @@1.
+
+  Hint Unfold eqk eqke ltk.
+
+  (* eqke is stricter than eqk *)
+
+  Global Instance eqke_eqk : subrelation eqke eqk.
+  Proof. firstorder. Qed.
+
+  (* eqk, eqke are equalities, ltk is a strict order *)
+
+  Global Instance eqk_equiv : Equivalence eqk.
+
+  Global Instance eqke_equiv : Equivalence eqke.
+
+  Global Instance ltk_strorder : StrictOrder ltk.
+
+  Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
+  Proof. unfold eqk, ltk; auto with *. Qed.
+
+  (* Additionnal facts *)
+
+  Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt).
+  Proof. apply pair_compat. Qed.
+
+  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
+  Proof.
+  intros e e' LT EQ; rewrite EQ in LT.
+  elim (StrictOrder_Irreflexive _ LT).
+  Qed.
+
+  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
+  Proof.
+  intros e e' LT EQ; rewrite EQ in LT.
+  elim (StrictOrder_Irreflexive _ LT).
+  Qed.
+
+  Lemma InA_eqke_eqk :
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke, RelProd; induction 1; firstorder.
+  Qed.
+  Hint Resolve InA_eqke_eqk.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+  Notation Sort := (sort ltk).
+  Notation Inf := (lelistA ltk).
+
+  Hint Unfold MapsTo In.
+
+  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+
+  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
+  Proof.
+  firstorder.
+  exists x; auto.
+  induction H.
+  destruct y; compute in H.
+  exists e; left; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
+  Proof.
+  unfold In, MapsTo.
+  setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
+  firstorder.
+  exists (snd x), x; auto.
+  Qed.
+
+  Lemma In_nil : forall k, In k nil <-> False.
+  Proof.
+  intros; rewrite In_alt2; apply Exists_nil.
+  Qed.
+
+  Lemma In_cons : forall k p l,
+   In k (p::l) <-> eq k (fst p) \/ In k l.
+  Proof.
+  intros; rewrite !In_alt2, Exists_cons; intuition.
+  Qed.
+
+  Global Instance MapsTo_compat :
+   Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
+  Proof.
+  intros x x' Hx e e' He l l' Hl. unfold MapsTo.
+  rewrite Hx, He, Hl; intuition.
+  Qed.
+
+  Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
+  Proof.
+  intros x x' Hx l l' Hl. rewrite !In_alt.
+  setoid_rewrite Hl. setoid_rewrite Hx. intuition.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
+
+  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
+  Proof. intros l x x' H. rewrite H; auto. Qed.
+
+  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
+  Proof. apply InfA_ltA; auto with *. Qed.
+
+  Hint Immediate Inf_eq.
+  Hint Resolve Inf_lt.
+
+  Lemma Sort_Inf_In :
+      forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
+  Proof. apply SortA_InfA_InA; auto with *. Qed.
+
+  Lemma Sort_Inf_NotIn :
+      forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
+  Proof.
+    intros; red; intros.
+    destruct H1 as [e' H2].
+    elim (@ltk_not_eqk (k,e) (k,e')).
+    eapply Sort_Inf_In; eauto.
+    repeat red; reflexivity.
+  Qed.
+
+  Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
+  Proof. apply SortA_NoDupA; auto with *. Qed.
+
+  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
+  Proof.
+   intros; invlist sort; eapply Sort_Inf_In; eauto.
+  Qed.
+
+  Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
+      ltk e e' \/ eqk e e'.
+  Proof.
+    intros; invlist InA; auto with relations.
+    left; apply Sort_In_cons_1 with l; auto with relations.
+  Qed.
+
+  Lemma Sort_In_cons_3 :
+    forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
+  Proof.
+    intros; invlist sort; red; intros.
+    eapply Sort_Inf_NotIn; eauto using In_eq.
+  Qed.
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
+    right; exists x; auto.
+  Qed.
+
+  Lemma In_inv_2 : forall k k' e e' l,
+      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
+  Proof.
+   intros; invlist InA; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l,
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   intros; invlist InA; compute in * |- ; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Unfold eqk eqke ltk.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve ltk_not_eqk ltk_not_eqke.
+ Hint Resolve InA_eqke_eqk.
+ Hint Unfold MapsTo In.
+ Hint Immediate Inf_eq.
+ Hint Resolve Inf_lt.
+ Hint Resolve Sort_Inf_NotIn.
+ Hint Resolve In_inv_2 In_inv_3.
+
+End KeyOrderedType.
+
diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v
new file mode 100644
index 00000000..66a672c9
--- /dev/null
+++ b/theories/Structures/OrdersTac.v
@@ -0,0 +1,293 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+Require Import Setoid Morphisms Basics Equalities Orders.
+Set Implicit Arguments.
+
+(** * The order tactic *)
+
+(** This tactic is designed to solve systems of (in)equations
+    involving [eq], [lt], [le] and [~eq] on some type. This tactic is
+    domain-agnostic; it will only use equivalence+order axioms, and
+    not analyze elements of the domain. Hypothesis or goal of the form
+    [~lt] or [~le] are initially turned into [le] and [lt], other
+    parts of the goal are ignored. This initial preparation of the
+    goal is the only moment where totality is used. In particular,
+    the core of the tactic only proceeds by saturation of transitivity
+    and similar properties, and does not perform case splitting.
+    The tactic will fail if it doesn't solve the goal. *)
+
+
+(** An abstract vision of the predicates. This allows a one-line
+    statement for interesting transitivity properties: for instance
+    [trans_ord OLE OLE = OLE] will imply later
+    [le x y -> le y z -> le x z].
+*)
+
+Inductive ord := OEQ | OLT | OLE.
+Definition trans_ord o o' :=
+ match o, o' with
+ | OEQ, _ => o'
+ | _, OEQ => o
+ | OLE, OLE => OLE
+ | _, _ => OLT
+ end.
+Local Infix "+" := trans_ord.
+
+
+(** ** The requirements of the tactic : [TotalOrder].
+
+   [TotalOrder] contains an equivalence [eq],
+   a strict order [lt] total and compatible with [eq], and
+   a larger order [le] synonym for [lt\/eq].
+*)
+
+(** ** Properties that will be used by the [order] tactic *)
+
+Module OrderFacts(Import O:TotalOrder').
+
+(** Reflexivity rules *)
+
+Lemma eq_refl : forall x, x==x.
+Proof. reflexivity. Qed.
+
+Lemma le_refl : forall x, x<=x.
+Proof. intros; rewrite le_lteq; right; reflexivity. Qed.
+
+Lemma lt_irrefl : forall x, ~ x<x.
+Proof. intros; apply StrictOrder_Irreflexive. Qed.
+
+(** Symmetry rules *)
+
+Lemma eq_sym : forall x y, x==y -> y==x.
+Proof. auto with *. Qed.
+
+Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y.
+Proof.
+ intros x y; rewrite 2 le_lteq. intuition.
+ elim (StrictOrder_Irreflexive x); transitivity y; auto.
+Qed.
+
+Lemma neq_sym : forall x y, ~x==y -> ~y==x.
+Proof. auto using eq_sym. Qed.
+
+(** Transitivity rules : first, a generic formulation, then instances*)
+
+Ltac subst_eqns :=
+ match goal with
+   | H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns
+   | _ => idtac
+ end.
+
+Definition interp_ord o :=
+ match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end.
+Local Notation "#" := interp_ord.
+
+Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z.
+Proof.
+destruct o, o'; simpl; intros x y z; rewrite ?le_lteq; intuition;
+ subst_eqns; eauto using (StrictOrder_Transitive x y z) with *.
+Qed.
+
+Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z.
+Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z.
+Definition lt_trans x y z : x<y -> y<z -> x<z := @trans OLT OLT x y z.
+Definition le_lt_trans x y z : x<=y -> y<z -> x<z := @trans OLE OLT x y z.
+Definition lt_le_trans x y z : x<y -> y<=z -> x<z := @trans OLT OLE x y z.
+Definition eq_lt x y z : x==y -> y<z -> x<z := @trans OEQ OLT x y z.
+Definition lt_eq x y z : x<y -> y==z -> x<z := @trans OLT OEQ x y z.
+Definition eq_le x y z : x==y -> y<=z -> x<=z := @trans OEQ OLE x y z.
+Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z.
+
+Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z.
+Proof. eauto using eq_trans, eq_sym. Qed.
+
+Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z.
+Proof. eauto using eq_trans, eq_sym. Qed.
+
+(** (double) negation rules *)
+
+Lemma not_neq_eq : forall x y, ~~x==y -> x==y.
+Proof.
+intros x y H. destruct (lt_total x y) as [H'|[H'|H']]; auto;
+ destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto.
+Qed.
+
+Lemma not_ge_lt : forall x y, ~y<=x -> x<y.
+Proof.
+intros x y H. destruct (lt_total x y); auto.
+destruct H. rewrite le_lteq. intuition.
+Qed.
+
+Lemma not_gt_le : forall x y, ~y<x -> x<=y.
+Proof.
+intros x y H. rewrite le_lteq. generalize (lt_total x y); intuition.
+Qed.
+
+Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x<y.
+Proof. auto using not_ge_lt, le_antisym. Qed.
+
+End OrderFacts.
+
+
+
+(** ** [MakeOrderTac] : The functor providing the order tactic. *)
+
+Module MakeOrderTac (Import O:TotalOrder').
+
+Include OrderFacts O.
+
+(** order_eq : replace x by y in all (in)equations hyps thanks
+   to equality EQ (where eq has been hidden in order to avoid
+   self-rewriting), then discard EQ. *)
+
+Ltac order_rewr x eqn :=
+ (* NB: we could use the real rewrite here, but proofs would be uglier. *)
+ let rewr H t := generalize t; clear H; intro H
+ in
+ match goal with
+ | H : x == _ |- _ => rewr H (eq_trans (eq_sym eqn) H); order_rewr x eqn
+ | H : _ == x |- _ => rewr H (eq_trans H eqn); order_rewr x eqn
+ | H : ~x == _ |- _ => rewr H (eq_neq (eq_sym eqn) H); order_rewr x eqn
+ | H : ~_ == x |- _ => rewr H (neq_eq H eqn); order_rewr x eqn
+ | H : x < _ |- _ => rewr H (eq_lt (eq_sym eqn) H); order_rewr x eqn
+ | H : _ < x |- _ => rewr H (lt_eq H eqn); order_rewr x eqn
+ | H : x <= _ |- _ => rewr H (eq_le (eq_sym eqn) H); order_rewr x eqn
+ | H : _ <= x |- _ => rewr H (le_eq H eqn); order_rewr x eqn
+ | _ => clear eqn
+end.
+
+Ltac order_eq x y eqn :=
+ match x with
+ | y => clear eqn
+ | _ => change (interp_ord OEQ x y) in eqn; order_rewr x eqn
+ end.
+
+(** Goal preparation : We turn all negative hyps into positive ones
+  and try to prove False from the inverse of the current goal.
+  These steps require totality of our order. After this preparation,
+  order only deals with the context, and tries to prove False.
+  Hypotheses of the form [A -> False] are also folded in [~A]
+  for convenience (i.e. cope with the mess left by intuition). *)
+
+Ltac order_prepare :=
+ match goal with
+ | H : ?A -> False |- _ => change (~A) in H; order_prepare
+ | H : ~(?R ?x ?y) |- _ =>
+   match R with
+   | eq => fail 1 (* if already using [eq], we leave it this ways *)
+   | _ => (change (~x==y) in H ||
+           apply not_gt_le in H ||
+           apply not_ge_lt in H ||
+           clear H || fail 1); order_prepare
+   end
+ | H : ?R ?x ?y |- _ =>
+   match R with
+   | eq => fail 1
+   | lt => fail 1
+   | le => fail 1
+   | _ => (change (x==y) in H ||
+           change (x<y) in H ||
+           change (x<=y) in H ||
+           clear H || fail 1); order_prepare
+   end
+ | |- ~ _ => intro; order_prepare
+ | |- _ ?x ?x =>
+   exact (eq_refl x) || exact (le_refl x) || exfalso
+ | _ =>
+   (apply not_neq_eq; intro) ||
+   (apply not_ge_lt; intro) ||
+   (apply not_gt_le; intro) || exfalso
+ end.
+
+(** We now try to prove False from the various [< <= == !=] hypothesis *)
+
+Ltac order_loop :=
+ match goal with
+ (* First, successful situations *)
+ | H : ?x < ?x |- _ => exact (lt_irrefl H)
+ | H : ~ ?x == ?x |- _ => exact (H (eq_refl x))
+ (* Second, useless hyps *)
+ | H : ?x <= ?x |- _ => clear H; order_loop
+ (* Third, we eliminate equalities *)
+ | H : ?x == ?y |- _ => order_eq x y H; order_loop
+ (* Simultaneous le and ge is eq *)
+ | H1 : ?x <= ?y, H2 : ?y <= ?x |- _ =>
+     generalize (le_antisym H1 H2); clear H1 H2; intro; order_loop
+ (* Simultaneous le and ~eq is lt *)
+ | H1: ?x <= ?y, H2: ~ ?x == ?y |- _ =>
+     generalize (le_neq_lt H1 H2); clear H1 H2; intro; order_loop
+ | H1: ?x <= ?y, H2: ~ ?y == ?x |- _ =>
+     generalize (le_neq_lt H1 (neq_sym H2)); clear H1 H2; intro; order_loop
+ (* Transitivity of lt and le *)
+ | H1 : ?x < ?y, H2 : ?y < ?z |- _ =>
+    match goal with
+      | H : x < z |- _ => fail 1
+      | _ => generalize (lt_trans H1 H2); intro; order_loop
+    end
+ | H1 : ?x <= ?y, H2 : ?y < ?z |- _ =>
+    match goal with
+      | H : x < z |- _ => fail 1
+      | _ => generalize (le_lt_trans H1 H2); intro; order_loop
+    end
+ | H1 : ?x < ?y, H2 : ?y <= ?z |- _ =>
+    match goal with
+      | H : x < z |- _ => fail 1
+      | _ => generalize (lt_le_trans H1 H2); intro; order_loop
+    end
+ | H1 : ?x <= ?y, H2 : ?y <= ?z |- _ =>
+    match goal with
+      | H : x <= z |- _ => fail 1
+      | _ => generalize (le_trans H1 H2); intro; order_loop
+    end
+ | _ => idtac
+end.
+
+(** The complete tactic. *)
+
+Ltac order :=
+ intros; order_prepare; order_loop; fail "Order tactic unsuccessful".
+
+End MakeOrderTac.
+
+Module OTF_to_OrderTac (OTF:OrderedTypeFull).
+ Module TO := OTF_to_TotalOrder OTF.
+ Include !MakeOrderTac TO.
+End OTF_to_OrderTac.
+
+Module OT_to_OrderTac (OT:OrderedType).
+ Module OTF := OT_to_Full OT.
+ Include !OTF_to_OrderTac OTF.
+End OT_to_OrderTac.
+
+Module TotalOrderRev (O:TotalOrder) <: TotalOrder.
+
+Definition t := O.t.
+Definition eq := O.eq.
+Definition lt := flip O.lt.
+Definition le := flip O.le.
+Include EqLtLeNotation.
+
+(* No Instance syntax to avoid saturating the Equivalence tables *)
+Definition eq_equiv := O.eq_equiv.
+
+Instance lt_strorder: StrictOrder lt.
+Proof. unfold lt; auto with *. Qed.
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof. unfold lt; auto with *. Qed.
+
+Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y.
+Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition. Qed.
+
+Lemma lt_total : forall x y, x<y \/ x==y \/ y<x.
+Proof.
+ intros x y; unfold lt, eq, flip.
+ generalize (O.lt_total x y); intuition.
+Qed.
+
+End TotalOrderRev.
diff --git a/theories/Structures/vo.itarget b/theories/Structures/vo.itarget
new file mode 100644
index 00000000..674e9fba
--- /dev/null
+++ b/theories/Structures/vo.itarget
@@ -0,0 +1,14 @@
+Equalities.vo
+EqualitiesFacts.vo
+Orders.vo
+OrdersEx.vo
+OrdersFacts.vo
+OrdersLists.vo
+OrdersTac.vo
+OrdersAlt.vo
+GenericMinMax.vo
+DecidableType.vo
+DecidableTypeEx.vo
+OrderedTypeAlt.vo
+OrderedTypeEx.vo
+OrderedType.vo
diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v
index 32b892b6..3a11c9e5 100644
--- a/theories/Unicode/Utf8.v
+++ b/theories/Unicode/Utf8.v
@@ -1,4 +1,4 @@
-(* -*- coding:utf-8 -* *)
+(* -*- coding:utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -19,11 +19,11 @@ Notation "∀ x y z u , P" := (forall x y z u , P)
   : type_scope.
 Notation "∀ x : t , P" := (forall x : t , P)
   (at level 200, x ident, right associativity) : type_scope.
-Notation "∀ x y : t , P" := (forall x y : t , P) 
+Notation "∀ x y : t , P" := (forall x y : t , P)
   (at level 200, x ident, y ident, right associativity) : type_scope.
 Notation "∀ x y z : t , P" := (forall x y z : t , P)
   (at level 200, x ident, y ident, z ident, right associativity) : type_scope.
-Notation "∀ x y z u : t , P" := (forall x y z u : t , P) 
+Notation "∀ x y z u : t , P" := (forall x y z u : t , P)
   (at level 200, x ident, y ident, z ident, u ident, right associativity)
   : type_scope.
 
@@ -36,7 +36,7 @@ Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
 Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
 Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope.
 Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
-Notation "⌉ x" := (~x) (at level 75, right associativity) : type_scope.
+Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
 Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.
 
 (* Abstraction *)
diff --git a/theories/Unicode/vo.itarget b/theories/Unicode/vo.itarget
new file mode 100644
index 00000000..243a40b7
--- /dev/null
+++ b/theories/Unicode/vo.itarget
@@ -0,0 +1 @@
+Utf8.vo
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
index 6adf629d..785d623b 100644
--- a/theories/Wellfounded/Disjoint_Union.v
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Disjoint_Union.v 10681 2008-03-16 13:40:45Z msozeau $ i*)
+(*i $Id$ i*)
 
 (** Author: Cristina Cornes
-    From : Constructing Recursion Operators in Type Theory                 
-           L. Paulson  JSC (1986) 2, 325-355 *) 
+    From : Constructing Recursion Operators in Type Theory
+           L. Paulson  JSC (1986) 2, 325-355 *)
 
 Require Import Relation_Operators.
 
@@ -20,7 +20,7 @@ Section Wf_Disjoint_Union.
   Variable leB : B -> B -> Prop.
 
   Notation Le_AsB := (le_AsB A B leA leB).
-  
+
   Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x).
   Proof.
     induction 1.
@@ -47,7 +47,7 @@ Section Wf_Disjoint_Union.
     destruct a as [a| b].
     apply (acc_A_sum a).
     apply (H a).
-    
+
     apply (acc_B_sum H b).
     apply (H0 b).
   Qed.
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
index e5ef4a70..01049989 100644
--- a/theories/Wellfounded/Inclusion.v
+++ b/theories/Wellfounded/Inclusion.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Inclusion.v 9642 2007-02-12 10:31:53Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Author: Bruno Barras *)
 
@@ -21,7 +21,7 @@ Section WfInclusion.
     induction 2.
     apply Acc_intro; auto with sets.
   Qed.
-  
+
   Hint Resolve Acc_incl.
 
   Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
index 29fe7bb2..c57e7072 100644
--- a/theories/Wellfounded/Inverse_Image.v
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Inverse_Image.v 9642 2007-02-12 10:31:53Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Author: Bruno Barras *)
 
@@ -47,8 +47,8 @@ Section Inverse_Image.
     destruct H3.
     apply (IHAcc x1); auto.
   Qed.
-  
-  
+
+
   Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
   Proof.
     red in |- *; constructor; intros.
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index 4dfcb24b..ff188900 100644
--- a/theories/Wellfounded/Lexicographic_Exponentiation.v
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lexicographic_Exponentiation.v 9609 2007-02-07 14:42:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Author: Cristina Cornes
 
-    From : Constructing Recursion Operators in Type Theory                
+    From : Constructing Recursion Operators in Type Theory
            L. Paulson  JSC (1986) 2, 325-355  *)
 
 Require Import List.
@@ -20,12 +20,12 @@ Require Import Transitive_Closure.
 Section Wf_Lexicographic_Exponentiation.
   Variable A : Set.
   Variable leA : A -> A -> Prop.
-  
+
   Notation Power := (Pow A leA).
   Notation Lex_Exp := (lex_exp A leA).
   Notation ltl := (Ltl A leA).
   Notation Descl := (Desc A leA).
-  
+
   Notation List := (list A).
   Notation Nil := (nil (A:=A)).
   (* useless but symmetric *)
@@ -33,13 +33,13 @@ Section Wf_Lexicographic_Exponentiation.
   Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).
 
   (* Hint Resolve d_one d_nil t_step. *)
-  
+
   Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
   Proof.
     simple induction x.
     simple induction z.
     simpl in |- *; intros H.
-    inversion_clear H. 
+    inversion_clear H.
     simpl in |- *; intros; apply (Lt_nil A leA).
     intros a l HInd.
     simpl in |- *.
@@ -71,12 +71,12 @@ Section Wf_Lexicographic_Exponentiation.
     rewrite H8.
     right; exists x2; auto with sets.
   Qed.
-  
+
   Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
   Proof.
     intros.
     inversion H.
-    generalize (app_cons_not_nil _ _ _ H1); simple induction 1. 
+    generalize (app_cons_not_nil _ _ _ H1); simple induction 1.
     cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
     intro.
     generalize (app_eq_unit _ _ H0).
@@ -87,7 +87,7 @@ Section Wf_Lexicographic_Exponentiation.
     simple induction 1; intros.
     rewrite <- H4; auto with sets.
   Qed.
-  
+
   Lemma desc_tail :
     forall (x:List) (a b:A),
       Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
@@ -99,7 +99,7 @@ Section Wf_Lexicographic_Exponentiation.
         forall a b:A,
           Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
     intros.
-    
+
     inversion H.
     cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
       auto with sets; intro.
@@ -108,17 +108,17 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
       simple induction 1.
     intros.
-    
+
     generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
     generalize H1.
     rewrite <- H10; rewrite <- H7; intro.
     apply (t_step A leA); auto with sets.
-    
+
     intros.
     inversion H0.
     generalize (app_cons_not_nil _ _ _ H3); intro.
     elim H1.
-    
+
     generalize H0.
     generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
       simple induction 1.
@@ -127,11 +127,11 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (H x0 b H6).
     intro.
     apply t_trans with (A := A) (y := x0); auto with sets.
-    
+
     apply t_step.
     generalize H1.
     rewrite H4; intro.
-    
+
     generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
     intros.
     generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
@@ -154,7 +154,7 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (app_eq_nil _ _ H0); simple induction 1.
     intros.
     rewrite H2; rewrite H3; split; apply d_nil.
-    
+
     intros.
     cut (x0 ++ y = Cons x Nil); auto with sets.
     intros E.
@@ -162,15 +162,15 @@ Section Wf_Lexicographic_Exponentiation.
     simple induction 1; intros.
     rewrite H2; rewrite H3; split.
     apply d_nil.
-    
+
     apply d_one.
-    
+
     simple induction 1; intros.
     rewrite H2; rewrite H3; split.
     apply d_one.
-    
+
     apply d_nil.
-    
+
     do 5 intro.
     intros Hind.
     do 2 intro.
@@ -181,13 +181,13 @@ Section Wf_Lexicographic_Exponentiation.
         forall x0:List,
           (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
           Descl x0 /\ Descl y0).
-    
+
     intro.
     generalize (app_nil_end x1); simple induction 1; simple induction 1.
     split. apply d_conc; auto with sets.
-    
+
     apply d_nil.
-    
+
     do 3 intro.
     generalize x1.
     apply rev_ind with
@@ -202,7 +202,7 @@ Section Wf_Lexicographic_Exponentiation.
     split.
     generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
     simple induction 1; auto with sets.
-    
+
     apply d_one.
     do 5 intro.
     generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
@@ -219,7 +219,7 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
     simple induction 1; split.
     auto with sets.
-    
+
     generalize H14.
     rewrite <- H10; intro.
     apply d_conc; auto with sets.
@@ -233,11 +233,11 @@ Section Wf_Lexicographic_Exponentiation.
     intros.
     apply (dist_aux (x ++ y) H x y); auto with sets.
   Qed.
-  
+
   Lemma desc_end :
     forall (a b:A) (x:List),
       Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
-      clos_trans A leA a b. 
+      clos_trans A leA a b.
   Proof.
     intros a b x.
     case x.
@@ -246,14 +246,14 @@ Section Wf_Lexicographic_Exponentiation.
     intros.
     inversion H1; auto with sets.
     inversion H3.
-    
+
     simple induction 1.
     generalize (app_comm_cons l (Cons a Nil) a0).
     intros E; rewrite <- E; intros.
     generalize (desc_tail l a a0 H0); intro.
     inversion H1.
     apply t_trans with (y := a0); auto with sets.
-    
+
     inversion H4.
   Qed.
 
@@ -268,15 +268,15 @@ Section Wf_Lexicographic_Exponentiation.
     intro.
     case x.
     intros; apply (Lt_nil A leA).
-    
+
     simpl in |- *; intros.
     inversion_clear H0.
     apply (Lt_hd A leA a b); auto with sets.
-    
+
     inversion_clear H1.
   Qed.
-  
-  
+
+
   Lemma acc_app :
     forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
       Acc Lex_Exp << x1 ++ x2, y1 >> ->
@@ -285,11 +285,11 @@ Section Wf_Lexicographic_Exponentiation.
     intros.
     apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
     auto with sets.
-    
+
     unfold lex_exp in |- *; simpl in |- *; auto with sets.
   Qed.
-  
-  
+
+
   Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
   Proof.
     unfold well_founded at 2 in |- *.
@@ -303,7 +303,7 @@ Section Wf_Lexicographic_Exponentiation.
 	forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
     intros.
     inversion_clear H0.
-    
+
     intro.
     generalize (well_founded_ind (wf_clos_trans A leA H)).
     intros GR.
@@ -318,7 +318,7 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (right_prefix x2 l (Cons x1 Nil) H1).
     simple induction 1.
     intro; apply (H0 x2 y1 H3).
-    
+
     simple induction 1.
     intro; simple induction 1.
     clear H4 H2.
@@ -340,8 +340,8 @@ Section Wf_Lexicographic_Exponentiation.
     unfold lex_exp at 1 in |- *.
     simpl in |- *; intros x4 y3. intros.
     apply (H0 x4 y3); auto with sets.
-    
-    intros. 
+
+    intros.
     generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
     simple induction 1.
     intros.
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index 818084b2..5144c0be 100644
--- a/theories/Wellfounded/Lexicographic_Product.v
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lexicographic_Product.v 9598 2007-02-06 19:45:52Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Authors: Bruno Barras, Cristina Cornes *)
 
@@ -14,7 +14,7 @@ Require Import Eqdep.
 Require Import Relation_Operators.
 Require Import Transitive_Closure.
 
-(**  From : Constructing Recursion Operators in Type Theory            
+(**  From : Constructing Recursion Operators in Type Theory
      L. Paulson  JSC (1986) 2, 325-355 *)
 
 Section WfLexicographic_Product.
@@ -24,7 +24,7 @@ Section WfLexicographic_Product.
   Variable leB : forall x:A, B x -> B x -> Prop.
 
   Notation LexProd := (lexprod A B leA leB).
-  
+
   Lemma acc_A_B_lexprod :
     forall x:A,
       Acc leA x ->
@@ -41,16 +41,16 @@ Section WfLexicographic_Product.
     intros.
     apply H2.
     apply t_trans with x2; auto with sets.
-    
+
     red in H2.
     apply H2.
     auto with sets.
-    
+
     injection H1.
     destruct 2.
     injection H3.
     destruct 2; auto with sets.
-    
+
     rewrite <- H1.
     injection H3; intros _ Hx1.
     subst x1.
@@ -105,7 +105,7 @@ End Wf_Symmetric_Product.
 
 
 Section Swap.
-  
+
   Variable A : Type.
   Variable R : A -> A -> Prop.
 
@@ -121,13 +121,13 @@ Section Swap.
     inversion_clear H; inversion_clear H1; apply H0.
     apply sp_swap.
     apply right_sym; auto with sets.
-    
+
     apply sp_swap.
     apply left_sym; auto with sets.
-    
+
     apply sp_noswap.
     apply right_sym; auto with sets.
-    
+
     apply sp_noswap.
     apply left_sym; auto with sets.
   Qed.
@@ -147,20 +147,20 @@ Section Swap.
     destruct y; intro H5.
     inversion_clear H5.
     inversion_clear H0; auto with sets.
-    
+
     apply swap_Acc.
     inversion_clear H0; auto with sets.
-    
+
     intros.
     apply IHAcc1; auto with sets; intros.
     apply Acc_inv with (y0, x1); auto with sets.
     apply sp_noswap.
     apply right_sym; auto with sets.
-    
+
     auto with sets.
   Qed.
 
-  
+
   Lemma wf_swapprod : well_founded R -> well_founded SwapProd.
   Proof.
     red in |- *.
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
index e552598c..c999b58e 100644
--- a/theories/Wellfounded/Transitive_Closure.v
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Transitive_Closure.v 9598 2007-02-06 19:45:52Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Author: Bruno Barras *)
 
@@ -18,7 +18,7 @@ Section Wf_Transitive_Closure.
   Variable R : relation A.
 
   Notation trans_clos := (clos_trans A R).
- 
+
   Lemma incl_clos_trans : inclusion A R trans_clos.
     red in |- *; auto with sets.
   Qed.
@@ -29,7 +29,7 @@ Section Wf_Transitive_Closure.
     intros y H2.
     induction H2; auto with sets.
     apply Acc_inv with y; auto with sets.
-  Qed.
+  Defined.
 
   Hint Resolve Acc_clos_trans.
 
@@ -42,6 +42,6 @@ Section Wf_Transitive_Closure.
   Theorem wf_clos_trans : well_founded R -> well_founded trans_clos.
   Proof.
     unfold well_founded in |- *; auto with sets.
-  Qed.
+  Defined.
 
 End Wf_Transitive_Closure.
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
index 8589c18f..fbb3d9e3 100644
--- a/theories/Wellfounded/Union.v
+++ b/theories/Wellfounded/Union.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Union.v 9642 2007-02-12 10:31:53Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Author: Bruno Barras *)
 
@@ -17,9 +17,9 @@ Require Import Transitive_Closure.
 Section WfUnion.
   Variable A : Type.
   Variables R1 R2 : relation A.
-  
+
   Notation Union := (union A R1 R2).
-  
+
   Remark strip_commut :
     commut A R1 R2 ->
     forall x y:A,
@@ -29,7 +29,7 @@ Section WfUnion.
     induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
     elim H with y x z; auto with sets; intros x0 H2 H3.
     exists x0; auto with sets.
-    
+
     elim IH1 with z0; auto with sets; intros.
     elim IH2 with x0; auto with sets; intros.
     exists x1; auto with sets.
@@ -50,7 +50,7 @@ Section WfUnion.
     elim H8; intros.
     apply H6; auto with sets.
     apply t_trans with x0; auto with sets.
-    
+
     elim strip_commut with x x0 y0; auto with sets; intros.
     apply Acc_inv_trans with x1; auto with sets.
     unfold union in |- *.
@@ -63,7 +63,7 @@ Section WfUnion.
     apply Acc_intro; auto with sets.
   Qed.
 
-  
+
   Theorem wf_union :
     commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
   Proof.
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
index af8832ec..e11b8924 100644
--- a/theories/Wellfounded/Well_Ordering.v
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Well_Ordering.v 9598 2007-02-06 19:45:52Z herbelin $ i*)
+(*i $Id$ i*)
 
 (** Author: Cristina Cornes.
     From: Constructing Recursion Operators in Type Theory
@@ -16,15 +16,15 @@ Require Import Eqdep.
 
 Section WellOrdering.
   Variable A : Type.
-  Variable B : A -> Type. 
-  
+  Variable B : A -> Type.
+
   Inductive WO : Type :=
     sup : forall (a:A) (f:B a -> WO), WO.
 
 
   Inductive le_WO : WO -> WO -> Prop :=
     le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f).
- 
+
   Theorem wf_WO : well_founded le_WO.
   Proof.
     unfold well_founded in |- *; intro.
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
index d5dfd072..fe05d61e 100644
--- a/theories/Wellfounded/Wellfounded.v
+++ b/theories/Wellfounded/Wellfounded.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wellfounded.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Export Disjoint_Union.
 Require Export Inclusion.
diff --git a/theories/Wellfounded/vo.itarget b/theories/Wellfounded/vo.itarget
new file mode 100644
index 00000000..034d5310
--- /dev/null
+++ b/theories/Wellfounded/vo.itarget
@@ -0,0 +1,9 @@
+Disjoint_Union.vo
+Inclusion.vo
+Inverse_Image.vo
+Lexicographic_Exponentiation.vo
+Lexicographic_Product.vo
+Transitive_Closure.vo
+Union.vo
+Wellfounded.vo
+Well_Ordering.vo
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index 1ff88604..d976b01c 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinInt.v 11015 2008-05-28 20:06:42Z herbelin $ i*)
+(*i $Id$ i*)
 
 (***********************************************************)
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
@@ -225,6 +226,11 @@ Qed.
 
 (** ** Properties of opposite on binary integer numbers *)
 
+Theorem Zopp_0 : Zopp Z0 = Z0.
+Proof.
+  reflexivity.
+Qed.
+
 Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
 Proof.
   reflexivity.
@@ -336,8 +342,8 @@ Proof.
               rewrite nat_of_P_gt_Gt_compare_complement_morphism;
 		[ discriminate
 		  | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
-		    elim (ZL4 x); intros k E2; rewrite E2; 
-		      simpl in |- *; unfold gt, lt in |- *; 
+		    elim (ZL4 x); intros k E2; rewrite E2;
+		      simpl in |- *; unfold gt, lt in |- *;
 			apply le_n_S; apply le_plus_r ]
 	      | assumption ]
 	    | absurd ((x + y ?= z)%positive Eq = Lt);
@@ -345,8 +351,8 @@ Proof.
 		rewrite nat_of_P_gt_Gt_compare_complement_morphism;
 		  [ discriminate
 		    | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
-		      elim (ZL4 x); intros k E2; rewrite E2; 
-			simpl in |- *; unfold gt, lt in |- *; 
+		      elim (ZL4 x); intros k E2; rewrite E2;
+			simpl in |- *; unfold gt, lt in |- *;
 			  apply le_n_S; apply le_plus_r ]
 		| assumption ]
 	    | rewrite (Pcompare_Eq_eq y z E0);
@@ -377,7 +383,7 @@ Proof.
 			[ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
 			  elim (Pminus_mask_Gt z (x + y));
 			    [ intros j H10; elim H10; intros H11 H12; elim H12;
-			      intros H13 H14; unfold Pminus in |- *; 
+			      intros H13 H14; unfold Pminus in |- *;
 				rewrite H6; rewrite H11; cut (i = j);
 				  [ intros E; rewrite E; auto with arith
 				    | apply (Pplus_reg_l (x + y)); rewrite H13;
@@ -388,7 +394,7 @@ Proof.
 			| apply nat_of_P_lt_Lt_compare_complement_morphism;
 			  apply plus_lt_reg_l with (p := nat_of_P y);
 			    do 2 rewrite <- nat_of_P_plus_morphism;
-			      apply nat_of_P_lt_Lt_compare_morphism; 
+			      apply nat_of_P_lt_Lt_compare_morphism;
 				rewrite H3; rewrite Pplus_comm; assumption ]
 		| apply ZC2; assumption ]
 	    | elim (Pminus_mask_Gt z y);
@@ -399,22 +405,22 @@ Proof.
 		      unfold Pminus in |- *; rewrite H1; rewrite H6;
 			cut ((x ?= k)%positive Eq = Gt);
 			  [ intros H10; elim (Pminus_mask_Gt x k H10); intros j H11;
-			    elim H11; intros H12 H13; elim H13; 
-			      intros H14 H15; rewrite H10; rewrite H12; 
+			    elim H11; intros H12 H13; elim H13;
+			      intros H14 H15; rewrite H10; rewrite H12;
 				cut (i = j);
 				  [ intros H16; rewrite H16; auto with arith
 				    | apply (Pplus_reg_l (z + k)); rewrite <- (Pplus_assoc z k j);
 				      rewrite H14; rewrite (Pplus_comm z k);
 					rewrite <- Pplus_assoc; rewrite H8;
 					  rewrite (Pplus_comm x y); rewrite Pplus_assoc;
-					    rewrite (Pplus_comm k y); rewrite H3; 
+					    rewrite (Pplus_comm k y); rewrite H3;
 					      trivial with arith ]
 			    | apply nat_of_P_gt_Gt_compare_complement_morphism;
 			      unfold lt, gt in |- *;
 				apply plus_lt_reg_l with (p := nat_of_P y);
 				  do 2 rewrite <- nat_of_P_plus_morphism;
-				    apply nat_of_P_lt_Lt_compare_morphism; 
-				      rewrite H3; rewrite Pplus_comm; apply ZC1; 
+				    apply nat_of_P_lt_Lt_compare_morphism;
+				      rewrite H3; rewrite Pplus_comm; apply ZC1;
 					assumption ]
 		      | assumption ]
 		| apply ZC2; assumption ]
@@ -437,14 +443,14 @@ Proof.
 		| assumption ]
 	    | elim Pminus_mask_Gt with (1 := E0); intros k H1;
           (* Case 9 *)
-	      elim Pminus_mask_Gt with (1 := E1); intros i H2; 
-		elim H1; intros H3 H4; elim H4; intros H5 H6; 
-		  elim H2; intros H7 H8; elim H8; intros H9 H10; 
+	      elim Pminus_mask_Gt with (1 := E1); intros i H2;
+		elim H1; intros H3 H4; elim H4; intros H5 H6;
+		  elim H2; intros H7 H8; elim H8; intros H9 H10;
 		    unfold Pminus in |- *; rewrite H3; rewrite H7;
 		      cut ((x + k)%positive = i);
 			[ intros E; rewrite E; auto with arith
 			  | apply (Pplus_reg_l z); rewrite (Pplus_comm x k); rewrite Pplus_assoc;
-			    rewrite H5; rewrite H9; rewrite Pplus_comm; 
+			    rewrite H5; rewrite H9; rewrite Pplus_comm;
 			      trivial with arith ] ] ].
 Qed.
 
@@ -460,7 +466,7 @@ Proof.
 	rewrite Zplus_comm; rewrite <- weak_assoc;
 	  rewrite (Zplus_comm (- Zpos p1));
 	    rewrite (Zplus_comm (Zpos p0 + - Zpos p1)); rewrite (weak_assoc p);
-	      rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); 
+	      rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0));
 		trivial with arith
       | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p));
 	rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0));
@@ -503,7 +509,7 @@ Qed.
 Lemma Zplus_succ_l : forall n m:Z, Zsucc n + m = Zsucc (n + m).
 Proof.
   intros x y; unfold Zsucc in |- *; rewrite (Zplus_comm (x + y));
-    rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); 
+    rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1));
       trivial with arith.
 Qed.
 
@@ -706,7 +712,7 @@ Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m.
 Proof.
   intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m);
     rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc;
-      rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; 
+      rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H;
 	trivial with arith.
 Qed.
 
@@ -747,7 +753,7 @@ Proof.
   reflexivity.
 Qed.
 
-Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt -> 
+Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt ->
   Zpos (b-a) = Zpos b - Zpos a.
 Proof.
   intros.
@@ -773,7 +779,7 @@ Qed.
 (**********************************************************************)
 (** * Properties of multiplication on binary integer numbers *)
 
-Theorem Zpos_mult_morphism : 
+Theorem Zpos_mult_morphism :
   forall p q:positive, Zpos (p*q) = Zpos p * Zpos q.
 Proof.
   auto.
@@ -862,7 +868,7 @@ Lemma Zmult_1_inversion_l :
 Proof.
   intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ];
     (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H;
-      intro H; rewrite Pmult_1_inversion_l with (1 := H); 
+      intro H; rewrite Pmult_1_inversion_l with (1 := H);
 	reflexivity).
 Qed.
 
@@ -873,7 +879,7 @@ Proof.
   reflexivity.
 Qed.
 
-Lemma Zdouble_plus_one_mult : forall z, 
+Lemma Zdouble_plus_one_mult : forall z,
   Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1).
 Proof.
   destruct z; simpl; auto with zarith.
@@ -927,13 +933,13 @@ Proof.
             [ intros E; rewrite E; rewrite Pmult_minus_distr_l;
               [ trivial with arith | apply ZC2; assumption ]
               | apply nat_of_P_lt_Lt_compare_complement_morphism;
-		do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
+		do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x);
 		  intros h H1; rewrite H1; apply mult_S_lt_compat_l;
 		    exact (nat_of_P_lt_Lt_compare_morphism z y E0) ]
 	  | cut ((x * z ?= x * y)%positive Eq = Gt);
             [ intros E; rewrite E; rewrite Pmult_minus_distr_l; auto with arith
               | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
-		do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
+		do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x);
 		  intros h H1; rewrite H1; apply mult_S_lt_compat_l;
 		    exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]).
 Qed.
@@ -963,7 +969,7 @@ Proof.
   apply Zmult_plus_distr_l.
 Qed.
 
- 
+
 Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m.
 Proof.
   intros x y z; rewrite (Zmult_comm z (x - y)).
@@ -1007,7 +1013,7 @@ Qed.
 Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n.
 Proof.
   intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r;
-    rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; 
+    rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l;
       trivial with arith.
 Qed.
 
@@ -1146,7 +1152,7 @@ Definition Zabs_N (z:Z) :=
     | Zneg p => Npos p
   end.
 
-Definition Z_of_N (x:N) := 
+Definition Z_of_N (x:N) :=
   match x with
     | N0 => Z0
     | Npos p => Zpos p
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
index fcb44d6f..30c08fdc 100644
--- a/theories/ZArith/Int.v
+++ b/theories/ZArith/Int.v
@@ -6,23 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* Finite sets library.  
- * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
- * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
- *              91405 Orsay, France *)
+(* $Id$ *)
 
-(* $Id: Int.v 10739 2008-04-01 14:45:20Z herbelin $ *)
+(** * An light axiomatization of integers (used in FSetAVL). *)
 
-(** An axiomatization of integers. *) 
-
-(** We define a signature for an integer datatype based on [Z]. 
-    The goal is to allow a switch after extraction to ocaml's 
-    [big_int] or even [int] when finiteness isn't a problem 
-    (typically : when mesuring the height of an AVL tree). 
+(** We define a signature for an integer datatype based on [Z].
+    The goal is to allow a switch after extraction to ocaml's
+    [big_int] or even [int] when finiteness isn't a problem
+    (typically : when mesuring the height of an AVL tree).
 *)
 
-Require Import ZArith. 
-Require Import ROmega. 
+Require Import ZArith.
 Delimit Scope Int_scope with I.
 
 
@@ -31,33 +25,33 @@ Delimit Scope Int_scope with I.
 Module Type Int.
 
   Open Scope Int_scope.
-  
-  Parameter int : Set. 
-  
+
+  Parameter int : Set.
+
   Parameter i2z : int -> Z.
   Arguments Scope i2z [ Int_scope ].
-  
-  Parameter _0 : int. 
-  Parameter _1 : int. 
-  Parameter _2 : int. 
+
+  Parameter _0 : int.
+  Parameter _1 : int.
+  Parameter _2 : int.
   Parameter _3 : int.
-  Parameter plus : int -> int -> int. 
+  Parameter plus : int -> int -> int.
   Parameter opp : int -> int.
-  Parameter minus : int -> int -> int. 
+  Parameter minus : int -> int -> int.
   Parameter mult : int -> int -> int.
-  Parameter max : int -> int -> int. 
- 
+  Parameter max : int -> int -> int.
+
   Notation "0" := _0 : Int_scope.
-  Notation "1" := _1 : Int_scope. 
-  Notation "2" := _2 : Int_scope. 
+  Notation "1" := _1 : Int_scope.
+  Notation "2" := _2 : Int_scope.
   Notation "3" := _3 : Int_scope.
   Infix "+" := plus : Int_scope.
   Infix "-" := minus : Int_scope.
   Infix "*" := mult : Int_scope.
   Notation "- x" := (opp x) : Int_scope.
 
-  (** For logical relations, we can rely on their counterparts in Z, 
-      since they don't appear after extraction. Moreover, using tactics 
+  (** For logical relations, we can rely on their counterparts in Z,
+      since they don't appear after extraction. Moreover, using tactics
       like omega is easier this way. *)
 
   Notation "x == y" := (i2z x = i2z y)
@@ -70,22 +64,22 @@ Module Type Int.
   Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
   Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
   Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.
-  
+
   (** Some decidability fonctions (informative). *)
-  
+
   Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}.
   Axiom ge_lt_dec :  forall x y : int, {x >= y} + {x < y}.
   Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }.
 
   (** Specifications *)
 
-  (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality 
-      [==] and the generic [=] are in fact equivalent. We define [==] 
+  (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality
+      [==] and the generic [=] are in fact equivalent. We define [==]
       nonetheless since the translation to [Z] for using automatic tactic is easier. *)
 
-  Axiom i2z_eq : forall n p : int, n == p -> n = p. 
-  
-   (** Then, we express the specifications of the above parameters using their 
+  Axiom i2z_eq : forall n p : int, n == p -> n = p.
+
+   (** Then, we express the specifications of the above parameters using their
        Z counterparts. *)
 
   Open Scope Z_scope.
@@ -99,25 +93,25 @@ Module Type Int.
   Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p.
   Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).
 
-End Int. 
+End Int.
 
 
 (** * Facts and  tactics using [Int] *)
 
 Module MoreInt (I:Int).
   Import I.
-  
+
   Open Scope Int_scope.
 
-  (** A magic (but costly) tactic that goes from [int] back to the [Z] 
+  (** A magic (but costly) tactic that goes from [int] back to the [Z]
       friendly world ... *)
 
-  Hint Rewrite -> 
+  Hint Rewrite ->
     i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
 
-  Ltac i2z := match goal with 
-		| H : (eq (A:=int) ?a ?b) |- _ => 
-		  generalize (f_equal i2z H); 
+  Ltac i2z := match goal with
+		| H : (eq (A:=int) ?a ?b) |- _ =>
+		  generalize (f_equal i2z H);
 		    try autorewrite with i2z; clear H; intro H; i2z
 		| |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z
 		| H : _ |- _ => progress autorewrite with i2z in H; i2z
@@ -126,39 +120,39 @@ Module MoreInt (I:Int).
 
   (** A reflexive version of the [i2z] tactic *)
 
-  (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a 
-      [i2z] is buried deep inside a subterm, [i2z_refl] may miss it. 
-      See also the limitation about [Set] or [Type] part below. 
+  (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a
+      [i2z] is buried deep inside a subterm, [i2z_refl] may miss it.
+      See also the limitation about [Set] or [Type] part below.
       Anyhow, [i2z_refl] is enough for applying [romega]. *)
- 
-  Ltac i2z_gen := match goal with 
+
+  Ltac i2z_gen := match goal with
     | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen
-    | H : (eq (A:=int) ?a ?b) |- _ => 
+    | H : (eq (A:=int) ?a ?b) |- _ =>
        generalize (f_equal i2z H); clear H; i2z_gen
-    | H : (eq (A:=Z) ?a ?b) |- _ => generalize H; clear H; i2z_gen
-    | H : (Zlt ?a ?b) |- _ => generalize H; clear H; i2z_gen
-    | H : (Zle ?a ?b) |- _ => generalize H; clear H; i2z_gen
-    | H : (Zgt ?a ?b) |- _ => generalize H; clear H; i2z_gen
-    | H : (Zge ?a ?b) |- _ => generalize H; clear H; i2z_gen
-    | H : _ -> ?X |- _ => 
+    | H : (eq (A:=Z) ?a ?b) |- _ => revert H; i2z_gen
+    | H : (Zlt ?a ?b) |- _ => revert H; i2z_gen
+    | H : (Zle ?a ?b) |- _ => revert H; i2z_gen
+    | H : (Zgt ?a ?b) |- _ => revert H; i2z_gen
+    | H : (Zge ?a ?b) |- _ => revert H; i2z_gen
+    | H : _ -> ?X |- _ =>
       (* A [Set] or [Type] part cannot be dealt with easily
-         using the [ExprP] datatype. So we forget it, leaving 
+         using the [ExprP] datatype. So we forget it, leaving
          a goal that can be weaker than the original. *)
-      match type of X with 
+      match type of X with
        | Type => clear H; i2z_gen
-       | Prop => generalize H; clear H; i2z_gen
+       | Prop => revert H; i2z_gen
       end
-    | H : _ <-> _ |- _ => generalize H; clear H; i2z_gen
-    | H : _ /\ _ |- _ => generalize H; clear H; i2z_gen
-    | H : _ \/ _ |- _ => generalize H; clear H; i2z_gen
-    | H : ~ _ |- _ => generalize H; clear H; i2z_gen
+    | H : _ <-> _ |- _ => revert H; i2z_gen
+    | H : _ /\ _ |- _ => revert H; i2z_gen
+    | H : _ \/ _ |- _ => revert H; i2z_gen
+    | H : ~ _ |- _ => revert H; i2z_gen
     | _ => idtac
    end.
 
-  Inductive ExprI : Set := 
+  Inductive ExprI : Set :=
     | EI0 : ExprI
     | EI1 : ExprI
-    | EI2 : ExprI 
+    | EI2 : ExprI
     | EI3 : ExprI
     | EIplus : ExprI -> ExprI -> ExprI
     | EIopp : ExprI -> ExprI
@@ -167,7 +161,7 @@ Module MoreInt (I:Int).
     | EImax : ExprI -> ExprI -> ExprI
     | EIraw : int -> ExprI.
 
-  Inductive ExprZ : Set :=  
+  Inductive ExprZ : Set :=
     | EZplus : ExprZ -> ExprZ -> ExprZ
     | EZopp : ExprZ -> ExprZ
     | EZminus : ExprZ -> ExprZ -> ExprZ
@@ -176,12 +170,12 @@ Module MoreInt (I:Int).
     | EZofI : ExprI -> ExprZ
     | EZraw : Z -> ExprZ.
 
-  Inductive ExprP : Type := 
-    | EPeq : ExprZ -> ExprZ -> ExprP 
-    | EPlt : ExprZ -> ExprZ -> ExprP 
-    | EPle : ExprZ -> ExprZ -> ExprP 
-    | EPgt : ExprZ -> ExprZ -> ExprP 
-    | EPge : ExprZ -> ExprZ -> ExprP 
+  Inductive ExprP : Type :=
+    | EPeq : ExprZ -> ExprZ -> ExprP
+    | EPlt : ExprZ -> ExprZ -> ExprP
+    | EPle : ExprZ -> ExprZ -> ExprP
+    | EPgt : ExprZ -> ExprZ -> ExprP
+    | EPge : ExprZ -> ExprZ -> ExprP
     | EPimpl : ExprP -> ExprP -> ExprP
     | EPequiv : ExprP -> ExprP -> ExprP
     | EPand : ExprP -> ExprP -> ExprP
@@ -191,8 +185,8 @@ Module MoreInt (I:Int).
 
   (** [int] to [ExprI] *)
 
-  Ltac i2ei trm := 
-    match constr:trm with 
+  Ltac i2ei trm :=
+    match constr:trm with
       | 0 => constr:EI0
       | 1 => constr:EI1
       | 2 => constr:EI2
@@ -207,8 +201,8 @@ Module MoreInt (I:Int).
 
   (** [Z] to [ExprZ] *)
 
-    with z2ez trm := 
-    match constr:trm with 
+    with z2ez trm :=
+    match constr:trm with
       | (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
       | (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
       | (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
@@ -219,7 +213,7 @@ Module MoreInt (I:Int).
     end.
 
   (** [Prop] to [ExprP] *)
-  
+
   Ltac p2ep trm :=
     match constr:trm with
       | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey)
@@ -229,11 +223,11 @@ Module MoreInt (I:Int).
       | (~ ?x) => let ex := p2ep x in constr:(EPneg ex)
       | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey)
       | (?x<?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey)
-      | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)   
-      | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)   
+      | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)
+      | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)
       | (?x>=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey)
       | ?x =>  constr:(EPraw x)
-    end.   
+    end.
 
   (** [ExprI] to [int] *)
 
@@ -242,19 +236,19 @@ Module MoreInt (I:Int).
       | EI0 => 0
       | EI1 => 1
       | EI2 => 2
-      | EI3 => 3 
+      | EI3 => 3
       | EIplus e1 e2 => (ei2i e1)+(ei2i e2)
       | EIminus e1 e2 => (ei2i e1)-(ei2i e2)
       | EImult e1 e2 => (ei2i e1)*(ei2i e2)
       | EImax e1 e2 => max (ei2i e1) (ei2i e2)
       | EIopp e => -(ei2i e)
-      | EIraw i => i 
-    end. 
+      | EIraw i => i
+    end.
 
   (** [ExprZ] to [Z] *)
 
-  Fixpoint ez2z (e:ExprZ) : Z := 
-    match e with 
+  Fixpoint ez2z (e:ExprZ) : Z :=
+    match e with
       | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
       | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
       | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
@@ -266,8 +260,8 @@ Module MoreInt (I:Int).
 
   (** [ExprP] to [Prop] *)
 
-  Fixpoint ep2p (e:ExprP) : Prop := 
-    match e with 
+  Fixpoint ep2p (e:ExprP) : Prop :=
+    match e with
       | EPeq e1 e2 => (ez2z e1) = (ez2z e2)
       | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z
       | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z
@@ -282,25 +276,25 @@ Module MoreInt (I:Int).
     end.
 
   (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *)
-   
-  Fixpoint norm_ei (e:ExprI) : ExprZ := 
-    match e with 
+
+  Fixpoint norm_ei (e:ExprI) : ExprZ :=
+    match e with
       | EI0 => EZraw (0%Z)
       | EI1 => EZraw (1%Z)
       | EI2 => EZraw (2%Z)
-      | EI3 => EZraw (3%Z) 
+      | EI3 => EZraw (3%Z)
       | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2)
       | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2)
       | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2)
       | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
       | EIopp e => EZopp (norm_ei e)
-      | EIraw i => EZofI (EIraw i) 
+      | EIraw i => EZofI (EIraw i)
     end.
 
   (** [ExprZ] to a simplified [ExprZ] *)
 
-  Fixpoint norm_ez (e:ExprZ) : ExprZ := 
-    match e with 
+  Fixpoint norm_ez (e:ExprZ) : ExprZ :=
+    match e with
       | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2)
       | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2)
       | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2)
@@ -311,9 +305,9 @@ Module MoreInt (I:Int).
     end.
 
   (** [ExprP] to a simplified [ExprP] *)
-  
-  Fixpoint norm_ep (e:ExprP) : ExprP := 
-    match e with 
+
+  Fixpoint norm_ep (e:ExprP) : ExprP :=
+    match e with
       | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2)
       | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2)
       | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2)
@@ -328,38 +322,36 @@ Module MoreInt (I:Int).
     end.
 
   Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e).
-  Proof. 
+  Proof.
     induction e; simpl; intros; i2z; auto; try congruence.
   Qed.
 
   Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e.
   Proof.
     induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct.
-  Qed. 
+  Qed.
 
-  Lemma norm_ep_correct : 
+  Lemma norm_ep_correct :
     forall e:ExprP, ep2p (norm_ep e) <-> ep2p e.
   Proof.
     induction e; simpl; repeat (rewrite norm_ez_correct); intuition.
   Qed.
 
-  Lemma norm_ep_correct2 : 
+  Lemma norm_ep_correct2 :
     forall e:ExprP, ep2p (norm_ep e) -> ep2p e.
   Proof.
     intros; destruct (norm_ep_correct e); auto.
   Qed.
 
-  Ltac i2z_refl := 
+  Ltac i2z_refl :=
     i2z_gen;
-    match goal with |- ?t => 
-      let e := p2ep t in 
+    match goal with |- ?t =>
+      let e := p2ep t in
       change (ep2p e); apply norm_ep_correct2; simpl
     end.
 
-  (* i2z_refl can be replaced below by (simpl in *; i2z). 
+  (* i2z_refl can be replaced below by (simpl in *; i2z).
      The reflexive version improves compilation of AVL files by about 15%  *)
-  
-  Ltac omega_max := i2z_refl; romega with Z.
 
 End MoreInt.
 
@@ -381,7 +373,7 @@ Module Z_as_Int <: Int.
   Definition minus := Zminus.
   Definition mult := Zmult.
   Definition max := Zmax.
-  Definition gt_le_dec := Z_gt_le_dec. 
+  Definition gt_le_dec := Z_gt_le_dec.
   Definition ge_lt_dec := Z_ge_lt_dec.
   Definition eq_dec := Z_eq_dec.
   Definition i2z : int -> Z := fun n => n.
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
index 1d7948a5..46f64c88 100644
--- a/theories/ZArith/Wf_Z.v
+++ b/theories/ZArith/Wf_Z.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf_Z.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import BinInt.
 Require Import Zcompare.
@@ -40,7 +40,7 @@ Proof.
   intro x; destruct x; intros;
     [ exists 0%nat; auto with arith
       | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros;
-	simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); 
+	simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x);
 	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
 	    apply nat_of_P_inj; auto with arith
       | absurd (0 <= Zneg p);
@@ -120,13 +120,13 @@ Proof.
       | assumption ].
 Qed.
 
-Section Efficient_Rec. 
+Section Efficient_Rec.
 
-  (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed 
+  (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed
       to give a better extracted term. *)
 
   Let R (a b:Z) := 0 <= a /\ a < b.
-  
+
   Let R_wf : well_founded R.
   Proof.
     set
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
index 66e0bda8..5747afc9 100644
--- a/theories/ZArith/ZArith.v
+++ b/theories/ZArith/ZArith.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZArith.v 9210 2006-10-05 10:12:15Z barras $ i*)
+(*i $Id$ i*)
 
 (** Library for manipulating integers based on binary encoding *)
 
diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
index 20fd6b5f..cd866c37 100644
--- a/theories/ZArith/ZArith_base.v
+++ b/theories/ZArith/ZArith_base.v
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZArith_base.v 8032 2006-02-12 21:20:48Z herbelin $ *)
+(* $Id$ *)
 
 (** Library for manipulating integers based on binary encoding.
-    These are the basic modules, required by [Omega] and [Ring] for instance. 
+    These are the basic modules, required by [Omega] and [Ring] for instance.
     The full library is [ZArith]. *)
 
 Require Export BinPos.
@@ -18,9 +18,9 @@ Require Export BinInt.
 Require Export Zcompare.
 Require Export Zorder.
 Require Export Zeven.
+Require Export Zminmax.
 Require Export Zmin.
 Require Export Zmax.
-Require Export Zminmax.
 Require Export Zabs.
 Require Export Znat.
 Require Export auxiliary.
diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
index b831afee..6e69350d 100644
--- a/theories/ZArith/ZArith_dec.v
+++ b/theories/ZArith/ZArith_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZArith_dec.v 9759 2007-04-12 17:46:54Z notin $ i*)
+(*i $Id$ i*)
 
 Require Import Sumbool.
 
@@ -15,35 +15,39 @@ Require Import Zorder.
 Require Import Zcompare.
 Open Local Scope Z_scope.
 
+(* begin hide *)
+(* Trivial, to deprecate? *)
 Lemma Dcompare_inf : forall r:comparison, {r = Eq} + {r = Lt} + {r = Gt}.
 Proof.
-  simple induction r; auto with arith. 
+  induction r; auto.
+Defined.
+(* end hide *)
+
+Lemma Zcompare_rect :
+  forall (P:Type) (n m:Z),
+    ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
+Proof.
+  intros * H1 H2 H3.
+  destruct (n ?= m); auto.
 Defined.
 
 Lemma Zcompare_rec :
   forall (P:Set) (n m:Z),
     ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
 Proof.
-  intros P x y H1 H2 H3.
-  elim (Dcompare_inf (x ?= y)).
-  intro H. elim H; auto with arith. auto with arith.
+  intro; apply Zcompare_rect.
 Defined.
 
 Section decidability.
 
   Variables x y : Z.
-  
+
   (** * Decidability of equality on binary integers *)
 
   Definition Z_eq_dec : {x = y} + {x <> y}.
   Proof.
-    apply Zcompare_rec with (n := x) (m := y).
-    intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
-    intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
-    rewrite (H2 H4) in H3. discriminate H3.
-    intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
-    rewrite (H2 H4) in H3. discriminate H3.
-  Defined. 
+    decide equality; apply positive_eq_dec.
+  Defined.
 
   (** * Decidability of order on binary integers *)
 
@@ -64,7 +68,7 @@ Section decidability.
     left. rewrite H. discriminate.
     right. tauto.
   Defined.
-  
+
   Definition Z_gt_dec : {x > y} + {~ x > y}.
   Proof.
     unfold Zgt in |- *.
@@ -214,13 +218,16 @@ Proof.
     [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
 Defined.
 
-
-
-Definition Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
+(* begin hide *)
+(* To deprecate ? *)
+Corollary Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
 Proof.
   exact (fun x:Z => Z_eq_dec x 0).
 Defined.
 
-Definition Z_notzerop (x:Z) := sumbool_not _ _ (Z_zerop x).
+Corollary Z_notzerop : forall (x:Z), {x <> 0} + {x = 0}.
+Proof (fun x => sumbool_not _ _ (Z_zerop x)).
 
-Definition Z_noteq_dec (x y:Z) := sumbool_not _ _ (Z_eq_dec x y).
+Corollary Z_noteq_dec : forall (x y:Z), {x <> y} + {x = y}.
+Proof (fun x y => sumbool_not _ _ (Z_eq_dec x y)).
+(* end hide *)
diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v
index 03e061f2..28b664aa 100644
--- a/theories/ZArith/ZOdiv.v
+++ b/theories/ZArith/ZOdiv.v
@@ -13,19 +13,19 @@ Require Zdiv.
 
 Open Scope Z_scope.
 
-(** This file provides results about the Round-Toward-Zero Euclidean 
+(** This file provides results about the Round-Toward-Zero Euclidean
   division [ZOdiv_eucl], whose projections are [ZOdiv] and [ZOmod].
-  Definition of this division can be found in file [ZOdiv_def]. 
+  Definition of this division can be found in file [ZOdiv_def].
 
-  This division and the one defined in Zdiv agree only on positive 
-  numbers. Otherwise, Zdiv performs Round-Toward-Bottom. 
+  This division and the one defined in Zdiv agree only on positive
+  numbers. Otherwise, Zdiv performs Round-Toward-Bottom.
 
-  The current approach is compatible with the division of usual 
-  programming languages such as Ocaml. In addition, it has nicer 
+  The current approach is compatible with the division of usual
+  programming languages such as Ocaml. In addition, it has nicer
   properties with respect to opposite and other usual operations.
 *)
 
-(** Since ZOdiv and Zdiv are not meant to be used concurrently, 
+(** Since ZOdiv and Zdiv are not meant to be used concurrently,
    we reuse the same notation. *)
 
 Infix "/" := ZOdiv : Z_scope.
@@ -36,7 +36,7 @@ Infix "mod" := Nmod (at level 40, no associativity) : N_scope.
 
 (** Auxiliary results on the ad-hoc comparison [NPgeb]. *)
 
-Lemma NPgeb_Zge : forall (n:N)(p:positive), 
+Lemma NPgeb_Zge : forall (n:N)(p:positive),
   NPgeb n p = true -> Z_of_N n >= Zpos p.
 Proof.
  destruct n as [|n]; simpl; intros.
@@ -44,7 +44,7 @@ Proof.
  red; simpl; destruct Pcompare; now auto.
 Qed.
 
-Lemma NPgeb_Zlt : forall (n:N)(p:positive), 
+Lemma NPgeb_Zlt : forall (n:N)(p:positive),
   NPgeb n p = false -> Z_of_N n < Zpos p.
 Proof.
  destruct n as [|n]; simpl; intros.
@@ -54,7 +54,7 @@ Qed.
 
 (** * Relation between division on N and on Z. *)
 
-Lemma Ndiv_Z0div : forall a b:N, 
+Lemma Ndiv_Z0div : forall a b:N,
   Z_of_N (a/b) = (Z_of_N a / Z_of_N b).
 Proof.
   intros.
@@ -62,7 +62,7 @@ Proof.
   unfold Ndiv, ZOdiv; simpl; destruct Pdiv_eucl; auto.
 Qed.
 
-Lemma Nmod_Z0mod : forall a b:N, 
+Lemma Nmod_Z0mod : forall a b:N,
   Z_of_N (a mod b) = (Z_of_N a) mod (Z_of_N b).
 Proof.
   intros.
@@ -72,11 +72,11 @@ Qed.
 
 (** * Characterization of this euclidean division. *)
 
-(** First, the usual equation [a=q*b+r]. Notice that [a mod 0] 
+(** First, the usual equation [a=q*b+r]. Notice that [a mod 0]
    has been chosen to be [a], so this equation holds even for [b=0].
 *)
 
-Theorem N_div_mod_eq : forall a b, 
+Theorem N_div_mod_eq : forall a b,
   a = (b * (Ndiv a b) + (Nmod a b))%N.
 Proof.
   intros; generalize (Ndiv_eucl_correct a b).
@@ -84,7 +84,7 @@ Proof.
   intro H; rewrite H; rewrite Nmult_comm; auto.
 Qed.
 
-Theorem ZO_div_mod_eq : forall a b, 
+Theorem ZO_div_mod_eq : forall a b,
   a = b * (ZOdiv a b) + (ZOmod a b).
 Proof.
   intros; generalize (ZOdiv_eucl_correct a b).
@@ -94,8 +94,8 @@ Qed.
 
 (** Then, the inequalities constraining the remainder. *)
 
-Theorem Pdiv_eucl_remainder : forall a b:positive, 
-  Z_of_N (snd (Pdiv_eucl a b)) < Zpos b. 
+Theorem Pdiv_eucl_remainder : forall a b:positive,
+  Z_of_N (snd (Pdiv_eucl a b)) < Zpos b.
 Proof.
   induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta.
   intros b; generalize (IHa b); case Pdiv_eucl.
@@ -111,7 +111,7 @@ Proof.
   destruct b; simpl; romega with *.
 Qed.
 
-Theorem Nmod_lt : forall (a b:N), b<>0%N -> 
+Theorem Nmod_lt : forall (a b:N), b<>0%N ->
   (a mod b < b)%N.
 Proof.
   destruct b as [ |b]; intro H; try solve [elim H;auto].
@@ -122,20 +122,20 @@ Qed.
 
 (** The remainder is bounded by the divisor, in term of absolute values *)
 
-Theorem ZOmod_lt : forall a b:Z, b<>0 -> 
+Theorem ZOmod_lt : forall a b:Z, b<>0 ->
   Zabs (a mod b) < Zabs b.
 Proof.
-  destruct b as [ |b|b]; intro H; try solve [elim H;auto]; 
-  destruct a as [ |a|a]; try solve [compute;auto]; unfold ZOmod, ZOdiv_eucl; 
-  generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl; 
+  destruct b as [ |b|b]; intro H; try solve [elim H;auto];
+  destruct a as [ |a|a]; try solve [compute;auto]; unfold ZOmod, ZOdiv_eucl;
+  generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl;
   try rewrite Zabs_Zopp; rewrite Zabs_eq; auto; apply Z_of_N_le_0.
 Qed.
 
-(** The sign of the remainder is the one of [a]. Due to the possible 
+(** The sign of the remainder is the one of [a]. Due to the possible
    nullity of [a], a general result is to be stated in the following form:
-*)   
+*)
 
-Theorem ZOmod_sgn : forall a b:Z, 
+Theorem ZOmod_sgn : forall a b:Z,
   0 <= Zsgn (a mod b) * Zsgn a.
 Proof.
   destruct b as [ |b|b]; destruct a as [ |a|a]; simpl; auto with zarith;
@@ -150,16 +150,16 @@ Proof.
  destruct z; simpl; intuition auto with zarith.
 Qed.
 
-Theorem ZOmod_sgn2 : forall a b:Z, 
+Theorem ZOmod_sgn2 : forall a b:Z,
   0 <= (a mod b) * a.
 Proof.
   intros; rewrite <-Zsgn_pos_iff, Zsgn_Zmult; apply ZOmod_sgn.
-Qed.  
+Qed.
 
-(** Reformulation of [ZOdiv_lt] and [ZOmod_sgn] in 2 
+(** Reformulation of [ZOdiv_lt] and [ZOmod_sgn] in 2
   then 4 particular cases. *)
 
-Theorem ZOmod_lt_pos : forall a b:Z, 0<=a -> b<>0 ->   
+Theorem ZOmod_lt_pos : forall a b:Z, 0<=a -> b<>0 ->
   0 <= a mod b < Zabs b.
 Proof.
   intros.
@@ -171,7 +171,7 @@ Proof.
   generalize (ZOmod_lt a b H0); romega with *.
 Qed.
 
-Theorem ZOmod_lt_neg : forall a b:Z, a<=0 -> b<>0 ->   
+Theorem ZOmod_lt_neg : forall a b:Z, a<=0 -> b<>0 ->
   -Zabs b < a mod b <= 0.
 Proof.
   intros.
@@ -209,49 +209,49 @@ Qed.
 
 Theorem ZOdiv_opp_l : forall a b:Z, (-a)/b = -(a/b).
 Proof.
- destruct a; destruct b; simpl; auto; 
+ destruct a; destruct b; simpl; auto;
   unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
 Qed.
 
 Theorem ZOdiv_opp_r : forall a b:Z, a/(-b) = -(a/b).
 Proof.
- destruct a; destruct b; simpl; auto; 
+ destruct a; destruct b; simpl; auto;
   unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
 Qed.
 
 Theorem ZOmod_opp_l : forall a b:Z, (-a) mod b = -(a mod b).
 Proof.
- destruct a; destruct b; simpl; auto; 
+ destruct a; destruct b; simpl; auto;
   unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
 Qed.
 
 Theorem ZOmod_opp_r : forall a b:Z, a mod (-b) = a mod b.
 Proof.
- destruct a; destruct b; simpl; auto; 
+ destruct a; destruct b; simpl; auto;
   unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
 Qed.
 
 Theorem ZOdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b.
 Proof.
- destruct a; destruct b; simpl; auto; 
+ destruct a; destruct b; simpl; auto;
   unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
 Qed.
 
 Theorem ZOmod_opp_opp : forall a b:Z, (-a) mod (-b) = -(a mod b).
 Proof.
- destruct a; destruct b; simpl; auto; 
+ destruct a; destruct b; simpl; auto;
   unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith.
 Qed.
 
 (** * Unicity results *)
 
-Definition Remainder a b r := 
+Definition Remainder a b r :=
   (0 <= a /\ 0 <= r < Zabs b) \/ (a <= 0 /\ -Zabs b < r <= 0).
 
-Definition Remainder_alt a b r := 
+Definition Remainder_alt a b r :=
   Zabs r < Zabs b /\ 0 <= r * a.
 
-Lemma Remainder_equiv : forall a b r, 
+Lemma Remainder_equiv : forall a b r,
  Remainder a b r <-> Remainder_alt a b r.
 Proof.
   unfold Remainder, Remainder_alt; intuition.
@@ -259,12 +259,12 @@ Proof.
   romega with *.
   rewrite <-(Zmult_opp_opp).
   apply Zmult_le_0_compat; romega.
-  assert (0 <= Zsgn r * Zsgn a) by (rewrite <-Zsgn_Zmult, Zsgn_pos_iff; auto). 
+  assert (0 <= Zsgn r * Zsgn a) by (rewrite <-Zsgn_Zmult, Zsgn_pos_iff; auto).
   destruct r; simpl Zsgn in *; romega with *.
 Qed.
 
 Theorem ZOdiv_mod_unique_full:
- forall a b q r, Remainder a b r -> 
+ forall a b q r, Remainder a b r ->
    a = b*q + r -> q = a/b /\ r = a mod b.
 Proof.
   destruct 1 as [(H,H0)|(H,H0)]; intros.
@@ -281,30 +281,30 @@ Proof.
   romega with *.
 Qed.
 
-Theorem ZOdiv_unique_full: 
- forall a b q r, Remainder a b r -> 
+Theorem ZOdiv_unique_full:
+ forall a b q r, Remainder a b r ->
   a = b*q + r -> q = a/b.
 Proof.
  intros; destruct (ZOdiv_mod_unique_full a b q r); auto.
 Qed.
 
 Theorem ZOdiv_unique:
- forall a b q r, 0 <= a -> 0 <= r < b -> 
+ forall a b q r, 0 <= a -> 0 <= r < b ->
    a = b*q + r -> q = a/b.
 Proof.
   intros; eapply ZOdiv_unique_full; eauto.
   red; romega with *.
 Qed.
 
-Theorem ZOmod_unique_full: 
- forall a b q r, Remainder a b r -> 
+Theorem ZOmod_unique_full:
+ forall a b q r, Remainder a b r ->
   a = b*q + r -> r = a mod b.
 Proof.
  intros; destruct (ZOdiv_mod_unique_full a b q r); auto.
 Qed.
 
 Theorem ZOmod_unique:
- forall a b q r, 0 <= a -> 0 <= r < b -> 
+ forall a b q r, 0 <= a -> 0 <= r < b ->
    a = b*q + r -> r = a mod b.
 Proof.
   intros; eapply ZOmod_unique_full; eauto.
@@ -345,7 +345,7 @@ Proof.
   rewrite Remainder_equiv; red; simpl; auto with zarith.
 Qed.
 
-Hint Resolve ZOmod_0_l ZOmod_0_r ZOdiv_0_l ZOdiv_0_r ZOdiv_1_r ZOmod_1_r 
+Hint Resolve ZOmod_0_l ZOmod_0_r ZOdiv_0_l ZOdiv_0_r ZOdiv_1_r ZOmod_1_r
  : zarith.
 
 Lemma ZOdiv_1_l: forall a, 1 < a -> 1/a = 0.
@@ -381,7 +381,7 @@ Qed.
 
 Lemma ZO_div_mult : forall a b:Z, b <> 0 -> (a*b)/b = a.
 Proof.
-  intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith; 
+  intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith;
    [ red; romega with * | ring].
 Qed.
 
@@ -403,12 +403,12 @@ Proof.
   subst b; rewrite ZOdiv_0_r; auto.
 Qed.
 
-(** As soon as the divisor is greater or equal than 2, 
+(** As soon as the divisor is greater or equal than 2,
     the division is strictly decreasing. *)
 
 Lemma ZO_div_lt : forall a b:Z, 0 < a -> 2 <= b -> a/b < a.
 Proof.
-  intros. 
+  intros.
   assert (Hb : 0 < b) by romega.
   assert (H1 : 0 <= a/b) by (apply ZO_div_pos; auto with zarith).
   assert (H2 : 0 <= a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith).
@@ -441,7 +441,7 @@ Lemma ZO_div_monotone_pos : forall a b c:Z, 0<=c -> 0<=a<=b -> a/c <= b/c.
 Proof.
   intros.
   destruct H0.
-  destruct (Zle_lt_or_eq 0 c H); 
+  destruct (Zle_lt_or_eq 0 c H);
    [ clear H | subst c; do 2 rewrite ZOdiv_0_r; auto].
   generalize (ZO_div_mod_eq a c).
   generalize (ZOmod_lt_pos_pos a c H0 H2).
@@ -452,7 +452,7 @@ Proof.
   intro.
   absurd (a - b >= 1).
   omega.
-  replace (a-b) with (c * (a/c-b/c) + a mod c - b mod c) by 
+  replace (a-b) with (c * (a/c-b/c) + a mod c - b mod c) by
     (symmetry; pattern a at 1; rewrite H5; pattern b at 1; rewrite H3; ring).
   assert (c * (a / c - b / c) >= c * 1).
   apply Zmult_ge_compat_l.
@@ -519,7 +519,7 @@ Proof.
   apply ZO_div_pos; auto with zarith.
 Qed.
 
-(** The previous inequalities between [b*(a/b)] and [a] are exact 
+(** The previous inequalities between [b*(a/b)] and [a] are exact
     iff the modulo is zero. *)
 
 Lemma ZO_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0.
@@ -535,7 +535,7 @@ Qed.
 (** A modulo cannot grow beyond its starting point. *)
 
 Theorem ZOmod_le: forall a b, 0 <= a -> 0 <= b -> a mod b <= a.
-Proof. 
+Proof.
   intros a b H1 H2.
   destruct (Zle_lt_or_eq _ _ H2).
   case (Zle_or_lt b a); intros H3.
@@ -546,17 +546,15 @@ Qed.
 
 (** Some additionnal inequalities about Zdiv. *)
 
-Theorem ZOdiv_le_upper_bound: 
-  forall a b q, 0 <= a -> 0 < b -> a <= q*b -> a/b <= q.
+Theorem ZOdiv_le_upper_bound:
+  forall a b q, 0 < b -> a <= q*b -> a/b <= q.
 Proof.
-  intros a b q H1 H2 H3.
-  apply Zmult_le_reg_r with b; auto with zarith.
-  apply Zle_trans with (2 := H3).
-  pattern a at 2; rewrite (ZO_div_mod_eq a b); auto with zarith.
-  rewrite (Zmult_comm b); case (ZOmod_lt_pos_pos a b); auto with zarith.
+  intros.
+  rewrite <- (ZO_div_mult q b); auto with zarith.
+  apply ZO_div_monotone; auto with zarith.
 Qed.
 
-Theorem ZOdiv_lt_upper_bound: 
+Theorem ZOdiv_lt_upper_bound:
   forall a b q, 0 <= a -> 0 < b -> a < q*b -> a/b < q.
 Proof.
   intros a b q H1 H2 H3.
@@ -566,33 +564,29 @@ Proof.
   rewrite (Zmult_comm b); case (ZOmod_lt_pos_pos a b); auto with zarith.
 Qed.
 
-Theorem ZOdiv_le_lower_bound: 
-  forall a b q, 0 <= a -> 0 < b -> q*b <= a -> q <= a/b.
+Theorem ZOdiv_le_lower_bound:
+  forall a b q, 0 < b -> q*b <= a -> q <= a/b.
 Proof.
-  intros a b q H1 H2 H3.
-  assert (q < a / b + 1); auto with zarith.
-  apply Zmult_lt_reg_r with b; auto with zarith.
-  apply Zle_lt_trans with (1 := H3).
-  pattern a at 1; rewrite (ZO_div_mod_eq a b); auto with zarith.
-  rewrite Zmult_plus_distr_l; rewrite (Zmult_comm b); case (ZOmod_lt_pos_pos a b);
-   auto with zarith.
+  intros.
+  rewrite <- (ZO_div_mult q b); auto with zarith.
+  apply ZO_div_monotone; auto with zarith.
 Qed.
 
-Theorem ZOdiv_sgn: forall a b, 
+Theorem ZOdiv_sgn: forall a b,
   0 <= Zsgn (a/b) * Zsgn a * Zsgn b.
 Proof.
-  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; 
+  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
   unfold ZOdiv; simpl; destruct Pdiv_eucl; simpl; destruct n; simpl; auto with zarith.
 Qed.
 
 (** * Relations between usual operations and Zmod and Zdiv *)
 
-(** First, a result that used to be always valid with Zdiv, 
-    but must be restricted here. 
+(** First, a result that used to be always valid with Zdiv,
+    but must be restricted here.
     For instance, now (9+(-5)*2) mod 2 = -1 <> 1 = 9 mod 2 *)
 
-Lemma ZO_mod_plus : forall a b c:Z, 
- 0 <= (a+b*c) * a -> 
+Lemma ZO_mod_plus : forall a b c:Z,
+ 0 <= (a+b*c) * a ->
  (a + b * c) mod c = a mod c.
 Proof.
   intros; destruct (Z_eq_dec a 0) as [Ha|Ha].
@@ -611,8 +605,8 @@ Proof.
   generalize (ZO_div_mod_eq a c); romega.
 Qed.
 
-Lemma ZO_div_plus : forall a b c:Z, 
- 0 <= (a+b*c) * a -> c<>0 -> 
+Lemma ZO_div_plus : forall a b c:Z,
+ 0 <= (a+b*c) * a -> c<>0 ->
  (a + b * c) / c = a / c + b.
 Proof.
   intros; destruct (Z_eq_dec a 0) as [Ha|Ha].
@@ -630,17 +624,17 @@ Proof.
   generalize (ZO_div_mod_eq a c); romega.
 Qed.
 
-Theorem ZO_div_plus_l: forall a b c : Z, 
- 0 <= (a*b+c)*c -> b<>0 -> 
+Theorem ZO_div_plus_l: forall a b c : Z,
+ 0 <= (a*b+c)*c -> b<>0 ->
  b<>0 -> (a * b + c) / b = a + c / b.
 Proof.
   intros a b c; rewrite Zplus_comm; intros; rewrite ZO_div_plus;
-  try apply Zplus_comm; auto with zarith. 
+  try apply Zplus_comm; auto with zarith.
 Qed.
 
 (** Cancellations. *)
 
-Lemma ZOdiv_mult_cancel_r : forall a b c:Z, 
+Lemma ZOdiv_mult_cancel_r : forall a b c:Z,
  c<>0 -> (a*c)/(b*c) = a/b.
 Proof.
  intros a b c Hc.
@@ -661,7 +655,7 @@ Proof.
  pattern a at 1; rewrite (ZO_div_mod_eq a b); ring.
 Qed.
 
-Lemma ZOdiv_mult_cancel_l : forall a b c:Z, 
+Lemma ZOdiv_mult_cancel_l : forall a b c:Z,
  c<>0 -> (c*a)/(c*b) = a/b.
 Proof.
   intros.
@@ -669,7 +663,7 @@ Proof.
   apply ZOdiv_mult_cancel_r; auto.
 Qed.
 
-Lemma ZOmult_mod_distr_l: forall a b c, 
+Lemma ZOmult_mod_distr_l: forall a b c,
   (c*a) mod (c*b) = c * (a mod b).
 Proof.
   intros; destruct (Z_eq_dec c 0) as [Hc|Hc].
@@ -684,7 +678,7 @@ Proof.
   ring.
 Qed.
 
-Lemma ZOmult_mod_distr_r: forall a b c, 
+Lemma ZOmult_mod_distr_r: forall a b c,
   (a*c) mod (b*c) = (a mod b) * c.
 Proof.
   intros; repeat rewrite (fun x => (Zmult_comm x c)).
@@ -712,7 +706,7 @@ Proof.
   pattern a at 2 3; rewrite (ZO_div_mod_eq a n); auto with zarith.
   pattern b at 2 3; rewrite (ZO_div_mod_eq b n); auto with zarith.
   set (A:=a mod n); set (B:=b mod n); set (A':=a/n); set (B':=b/n).
-  replace (A*(n*A'+A)*(B*(n*B'+B))) with (((n*A' + A) * (n*B' + B))*(A*B)) 
+  replace (A*(n*A'+A)*(B*(n*B'+B))) with (((n*A' + A) * (n*B' + B))*(A*B))
    by ring.
   replace ((n*A' + A) * (n*B' + B))
    with (A*B + (A'*B+B'*A+n*A'*B')*n) by ring.
@@ -721,15 +715,15 @@ Proof.
 Qed.
 
 (** addition and modulo
-  
-  Generally speaking, unlike with Zdiv, we don't have 
-       (a+b) mod n = (a mod n + b mod n) mod n 
-  for any a and b. 
-  For instance, take (8 + (-10)) mod 3 = -2 whereas 
+
+  Generally speaking, unlike with Zdiv, we don't have
+       (a+b) mod n = (a mod n + b mod n) mod n
+  for any a and b.
+  For instance, take (8 + (-10)) mod 3 = -2 whereas
   (8 mod 3 + (-10 mod 3)) mod 3 = 1. *)
 
 Theorem ZOplus_mod: forall a b n,
- 0 <= a * b -> 
+ 0 <= a * b ->
  (a + b) mod n = (a mod n + b mod n) mod n.
 Proof.
   assert (forall a b n, 0<a -> 0<b ->
@@ -761,16 +755,16 @@ Proof.
   rewrite <-(Zopp_involutive a), <-(Zopp_involutive b).
   rewrite <- Zopp_plus_distr; rewrite ZOmod_opp_l.
   rewrite (ZOmod_opp_l (-a)),(ZOmod_opp_l (-b)).
-  match goal with |- _ = (-?x+-?y) mod n => 
+  match goal with |- _ = (-?x+-?y) mod n =>
    rewrite <-(Zopp_plus_distr x y), ZOmod_opp_l end.
   f_equal; apply H; auto with zarith.
 Qed.
 
-Lemma ZOplus_mod_idemp_l: forall a b n, 
- 0 <= a * b -> 
+Lemma ZOplus_mod_idemp_l: forall a b n,
+ 0 <= a * b ->
  (a mod n + b) mod n = (a + b) mod n.
 Proof.
-  intros. 
+  intros.
   rewrite ZOplus_mod.
   rewrite ZOmod_mod.
   symmetry.
@@ -791,8 +785,8 @@ Proof.
   destruct b; simpl; auto with zarith.
 Qed.
 
-Lemma ZOplus_mod_idemp_r: forall a b n, 
- 0 <= a*b -> 
+Lemma ZOplus_mod_idemp_r: forall a b n,
+ 0 <= a*b ->
  (b + a mod n) mod n = (b + a) mod n.
 Proof.
   intros.
@@ -822,12 +816,12 @@ Proof.
    replace (b * (c * (a / b / c) + (a / b) mod c) + a mod b) with
     ((a / b / c)*(b * c)  + (b * ((a / b) mod c) + a mod b)) by ring.
    assert (b*c<>0).
-    intro H2; 
-    assert (H3: c <> 0) by auto with zarith; 
+    intro H2;
+    assert (H3: c <> 0) by auto with zarith;
     rewrite (Zmult_integral_l _ _ H3 H2) in H0; auto with zarith.
    assert (0<=a/b) by (apply (ZO_div_pos a b); auto with zarith).
    assert (0<=a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith).
-   assert (0<=(a/b) mod c < c) by 
+   assert (0<=(a/b) mod c < c) by
     (apply ZOmod_lt_pos_pos; auto with zarith).
    rewrite ZO_div_plus_l; auto with zarith.
    rewrite (ZOdiv_small (b * ((a / b) mod c) + a mod b)).
@@ -852,14 +846,14 @@ Proof.
    intros; destruct b as [ |b|b].
    repeat rewrite ZOdiv_0_r; reflexivity.
    apply H0; auto with zarith.
-   change (Zneg b) with (-Zpos b); 
+   change (Zneg b) with (-Zpos b);
    repeat (rewrite ZOdiv_opp_r || rewrite ZOdiv_opp_l || rewrite <- Zopp_mult_distr_l).
    f_equal; apply H0; auto with zarith.
   (* a b c general *)
   intros; destruct c as [ |c|c].
   rewrite Zmult_0_r; repeat rewrite ZOdiv_0_r; reflexivity.
   apply H1; auto with zarith.
-  change (Zneg c) with (-Zpos c); 
+  change (Zneg c) with (-Zpos c);
   rewrite <- Zopp_mult_distr_r; do 2 rewrite ZOdiv_opp_r.
   f_equal; apply H1; auto with zarith.
 Qed.
@@ -870,11 +864,11 @@ Theorem ZOdiv_mult_le:
  forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b.
 Proof.
   intros a b c Ha Hb Hc.
-  destruct (Zle_lt_or_eq _ _ Ha); 
+  destruct (Zle_lt_or_eq _ _ Ha);
    [ | subst; rewrite ZOdiv_0_l, Zmult_0_r, ZOdiv_0_l; auto].
-  destruct (Zle_lt_or_eq _ _ Hb); 
+  destruct (Zle_lt_or_eq _ _ Hb);
    [ | subst; rewrite ZOdiv_0_r, ZOdiv_0_r, Zmult_0_r; auto].
-  destruct (Zle_lt_or_eq _ _ Hc); 
+  destruct (Zle_lt_or_eq _ _ Hc);
    [ | subst; rewrite ZOdiv_0_l; auto].
   case (ZOmod_lt_pos_pos a b); auto with zarith; intros Hu1 Hu2.
   case (ZOmod_lt_pos_pos c b); auto with zarith; intros Hv1 Hv2.
@@ -890,14 +884,14 @@ Proof.
   apply (ZOmod_le ((c mod b) * (a mod b)) b); auto with zarith.
   apply Zmult_le_compat_r; auto with zarith.
   apply (ZOmod_le c b); auto.
-  pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring; 
+  pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring;
     auto with zarith.
   pattern a at 1; rewrite (ZO_div_mod_eq a b); try ring; auto with zarith.
 Qed.
 
 (** ZOmod is related to divisibility (see more in Znumtheory) *)
 
-Lemma ZOmod_divides : forall a b, 
+Lemma ZOmod_divides : forall a b,
  a mod b = 0 <-> exists c, a = b*c.
 Proof.
  split; intros.
@@ -916,7 +910,7 @@ Qed.
 
 (** They agree at least on positive numbers: *)
 
-Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> 
+Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b ->
   a/b = Zdiv.Zdiv a b /\ a mod b = Zdiv.Zmod a b.
 Proof.
   intros.
@@ -927,7 +921,7 @@ Proof.
   symmetry; apply ZO_div_mod_eq; auto with *.
 Qed.
 
-Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> 
+Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
   a/b = Zdiv.Zdiv a b.
 Proof.
  intros a b Ha Hb.
@@ -936,7 +930,7 @@ Proof.
  subst; rewrite ZOdiv_0_r, Zdiv.Zdiv_0_r; reflexivity.
 Qed.
 
-Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b -> 
+Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b ->
   a mod b = Zdiv.Zmod a b.
 Proof.
  intros a b Ha Hb; generalize (ZOdiv_eucl_Zdiv_eucl_pos a b Ha Hb);
@@ -945,9 +939,9 @@ Qed.
 
 (** Modulos are null at the same places *)
 
-Theorem ZOmod_Zmod_zero : forall a b, b<>0 -> 
+Theorem ZOmod_Zmod_zero : forall a b, b<>0 ->
  (a mod b = 0 <-> Zdiv.Zmod a b = 0).
 Proof.
  intros.
  rewrite ZOmod_divides, Zdiv.Zmod_divides; intuition.
-Qed. 
+Qed.
diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v
index 2c84765e..88d573bb 100644
--- a/theories/ZArith/ZOdiv_def.v
+++ b/theories/ZArith/ZOdiv_def.v
@@ -17,9 +17,9 @@ Definition NPgeb (a:N)(b:positive) :=
    | Npos na => match Pcompare na b Eq with Lt => false | _ => true end
   end.
 
-Fixpoint Pdiv_eucl (a b:positive) {struct a} : N * N :=
+Fixpoint Pdiv_eucl (a b:positive) : N * N :=
   match a with
-    | xH => 
+    | xH =>
        match b with xH => (1, 0)%N | _ => (0, 1)%N end
     | xO a' =>
        let (q, r) := Pdiv_eucl a' b in
@@ -33,21 +33,21 @@ Fixpoint Pdiv_eucl (a b:positive) {struct a} : N * N :=
         else  (2 * q, r')%N
   end.
 
-Definition ZOdiv_eucl (a b:Z) : Z * Z := 
+Definition ZOdiv_eucl (a b:Z) : Z * Z :=
   match a, b with
    | Z0,  _ => (Z0, Z0)
    | _, Z0  => (Z0, a)
-   | Zpos na, Zpos nb => 
-         let (nq, nr) := Pdiv_eucl na nb in 
+   | Zpos na, Zpos nb =>
+         let (nq, nr) := Pdiv_eucl na nb in
          (Z_of_N nq, Z_of_N nr)
-   | Zneg na, Zpos nb => 
-         let (nq, nr) := Pdiv_eucl na nb in 
+   | Zneg na, Zpos nb =>
+         let (nq, nr) := Pdiv_eucl na nb in
          (Zopp (Z_of_N nq), Zopp (Z_of_N nr))
-   | Zpos na, Zneg nb => 
-         let (nq, nr) := Pdiv_eucl na nb in 
+   | Zpos na, Zneg nb =>
+         let (nq, nr) := Pdiv_eucl na nb in
          (Zopp (Z_of_N nq), Z_of_N nr)
-   | Zneg na, Zneg nb => 
-         let (nq, nr) := Pdiv_eucl na nb in 
+   | Zneg na, Zneg nb =>
+         let (nq, nr) := Pdiv_eucl na nb in
          (Z_of_N nq, Zopp (Z_of_N nr))
   end.
 
@@ -55,7 +55,7 @@ Definition ZOdiv a b := fst (ZOdiv_eucl a b).
 Definition ZOmod a b := snd (ZOdiv_eucl a b).
 
 
-Definition Ndiv_eucl (a b:N) : N * N := 
+Definition Ndiv_eucl (a b:N) : N * N :=
   match a, b with
    | N0,  _ => (N0, N0)
    | _, N0  => (N0, a)
@@ -68,13 +68,13 @@ Definition Nmod a b := snd (Ndiv_eucl a b).
 
 (* Proofs of specifications for these euclidean divisions. *)
 
-Theorem NPgeb_correct: forall (a:N)(b:positive), 
+Theorem NPgeb_correct: forall (a:N)(b:positive),
   if NPgeb a b then a = (Nminus a (Npos b) + Npos b)%N else True.
 Proof.
   destruct a; intros; simpl; auto.
   generalize (Pcompare_Eq_eq p b).
   case_eq (Pcompare p b Eq); intros; auto.
-  rewrite H0; auto. 
+  rewrite H0; auto.
   now rewrite Pminus_mask_diag.
   destruct (Pminus_mask_Gt p b H) as [d [H2 [H3 _]]].
   rewrite H2. rewrite <- H3.
@@ -82,11 +82,11 @@ Proof.
 Qed.
 
 Hint Rewrite Z_of_N_plus Z_of_N_mult Z_of_N_minus Zmult_1_l Zmult_assoc
- Zmult_plus_distr_l Zmult_plus_distr_r : zdiv. 
-Hint Rewrite <- Zplus_assoc : zdiv. 
+ Zmult_plus_distr_l Zmult_plus_distr_r : zdiv.
+Hint Rewrite <- Zplus_assoc : zdiv.
 
 Theorem Pdiv_eucl_correct: forall a b,
-  let (q,r) := Pdiv_eucl a b in 
+  let (q,r) := Pdiv_eucl a b in
   Zpos a = Z_of_N q * Zpos b + Z_of_N r.
 Proof.
   induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta.
diff --git a/theories/ZArith/ZOrderedType.v b/theories/ZArith/ZOrderedType.v
new file mode 100644
index 00000000..570e2a4d
--- /dev/null
+++ b/theories/ZArith/ZOrderedType.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import BinInt Zcompare Zorder Zbool ZArith_dec
+ Equalities Orders OrdersTac.
+
+Local Open Scope Z_scope.
+
+(** * DecidableType structure for binary integers *)
+
+Module Z_as_UBE <: UsualBoolEq.
+ Definition t := Z.
+ Definition eq := @eq Z.
+ Definition eqb := Zeq_bool.
+ Definition eqb_eq x y := iff_sym (Zeq_is_eq_bool x y).
+End Z_as_UBE.
+
+Module Z_as_DT <: UsualDecidableTypeFull := Make_UDTF Z_as_UBE.
+
+(** Note that the last module fulfills by subtyping many other
+    interfaces, such as [DecidableType] or [EqualityType]. *)
+
+
+(** * OrderedType structure for binary integers *)
+
+Module Z_as_OT <: OrderedTypeFull.
+ Include Z_as_DT.
+ Definition lt := Zlt.
+ Definition le := Zle.
+ Definition compare := Zcompare.
+
+ Instance lt_strorder : StrictOrder Zlt.
+ Proof. split; [ exact Zlt_irrefl | exact Zlt_trans ]. Qed.
+
+ Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Zlt.
+ Proof. repeat red; intros; subst; auto. Qed.
+
+ Definition le_lteq := Zle_lt_or_eq_iff.
+ Definition compare_spec := Zcompare_spec.
+
+End Z_as_OT.
+
+(** Note that [Z_as_OT] can also be seen as a [UsualOrderedType]
+   and a [OrderedType] (and also as a [DecidableType]). *)
+
+
+
+(** * An [order] tactic for integers *)
+
+Module ZOrder := OTF_to_OrderTac Z_as_OT.
+Ltac z_order := ZOrder.order.
+
+(** Note that [z_order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
+
diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v
index c15493e3..36eb4110 100644
--- a/theories/ZArith/Zabs.v
+++ b/theories/ZArith/Zabs.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,7 +6,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zabs.v 10302 2007-11-08 09:54:31Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
 
@@ -77,9 +78,9 @@ Proof.
       (intros H2; rewrite H2); auto.
 Qed.
 
-Lemma Zabs_spec : forall x:Z, 
-  0 <= x /\ Zabs x = x \/ 
-  0 > x /\ Zabs x = -x. 
+Lemma Zabs_spec : forall x:Z,
+  0 <= x /\ Zabs x = x \/
+  0 > x /\ Zabs x = -x.
 Proof.
  intros; unfold Zabs, Zle, Zgt; destruct x; simpl; intuition discriminate.
 Qed.
@@ -142,7 +143,7 @@ Lemma Zabs_nat_mult: forall n m:Z, Zabs_nat (n*m) = (Zabs_nat n * Zabs_nat m)%na
 Proof.
   intros; apply inj_eq_rev.
   rewrite inj_mult; repeat rewrite inj_Zabs_nat; apply Zabs_Zmult.
-Qed. 
+Qed.
 
 Lemma Zabs_nat_Zsucc:
  forall p, 0 <= p ->  Zabs_nat (Zsucc p) = S (Zabs_nat p).
@@ -151,13 +152,13 @@ Proof.
   rewrite inj_S; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith.
 Qed.
 
-Lemma Zabs_nat_Zplus: 
+Lemma Zabs_nat_Zplus:
  forall x y, 0<=x -> 0<=y -> Zabs_nat (x+y) = (Zabs_nat x + Zabs_nat y)%nat.
 Proof.
   intros; apply inj_eq_rev.
   rewrite inj_plus; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith.
   apply Zplus_le_0_compat; auto.
-Qed.  
+Qed.
 
 Lemma Zabs_nat_Zminus:
  forall x y, 0 <= x <= y ->  Zabs_nat (y - x) = (Zabs_nat y - Zabs_nat x)%nat.
@@ -200,11 +201,11 @@ Qed.
 
 (** A characterization of the sign function: *)
 
-Lemma Zsgn_spec : forall x:Z, 
-  0 < x /\ Zsgn x = 1 \/ 
-  0 = x /\ Zsgn x = 0 \/ 
+Lemma Zsgn_spec : forall x:Z,
+  0 < x /\ Zsgn x = 1 \/
+  0 = x /\ Zsgn x = 0 \/
   0 > x /\ Zsgn x = -1.
-Proof. 
+Proof.
  intros; unfold Zsgn, Zle, Zgt; destruct x; compute; intuition.
 Qed.
 
diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v
index 34771897..8cdd73cc 100644
--- a/theories/ZArith/Zbool.v
+++ b/theories/ZArith/Zbool.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zbool.v 12271 2009-08-11 10:29:45Z herbelin $ *)
+(* $Id$ *)
 
 Require Import BinInt.
 Require Import Zeven.
@@ -228,3 +228,8 @@ Proof.
   discriminate.
 Qed.
 
+Lemma Zeq_bool_if : forall x y, if Zeq_bool x y then x=y else x<>y.
+Proof.
+  intros. generalize (Zeq_bool_eq x y)(Zeq_bool_neq x y).
+  destruct Zeq_bool; auto.
+Qed.
\ No newline at end of file
diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v
index 8244d4ce..3e611d54 100644
--- a/theories/ZArith/Zcompare.v
+++ b/theories/ZArith/Zcompare.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -9,7 +10,7 @@
 (*i $$ i*)
 
 (**********************************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
 (**********************************************************************)
 
 Require Export BinPos.
@@ -40,12 +41,12 @@ Proof.
 	    | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ].
 Qed.
 
-Ltac destr_zcompare := 
- match goal with |- context [Zcompare ?x ?y] => 
-  let H := fresh "H" in 
+Ltac destr_zcompare :=
+ match goal with |- context [Zcompare ?x ?y] =>
+  let H := fresh "H" in
   case_eq (Zcompare x y); intro H;
    [generalize (Zcompare_Eq_eq _ _ H); clear H; intro H |
-    change (x<y)%Z in H | 
+    change (x<y)%Z in H |
     change (x>y)%Z in H ]
  end.
 
@@ -58,35 +59,48 @@ Qed.
 Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n).
 Proof.
   intros x y; destruct x; destruct y; simpl in |- *;
-    reflexivity || discriminate H || rewrite Pcompare_antisym; 
+    reflexivity || discriminate H || rewrite Pcompare_antisym;
       reflexivity.
 Qed.
 
 Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt.
 Proof.
-  intros x y; split; intro H;
-    [ change Lt with (CompOpp Gt) in |- *; rewrite <- Zcompare_antisym;
-      rewrite H; reflexivity
-      | change Gt with (CompOpp Lt) in |- *; rewrite <- Zcompare_antisym;
-	rewrite H; reflexivity ].
+  intros x y.
+  rewrite <- Zcompare_antisym. change Gt with (CompOpp Lt).
+  split.
+  auto using CompOpp_inj.
+  intros; f_equal; auto.
 Qed.
 
+Lemma Zcompare_spec : forall n m, CompSpec eq Zlt n m (n ?= m).
+Proof.
+  intros.
+  destruct (n?=m) as [ ]_eqn:H; constructor; auto.
+  apply Zcompare_Eq_eq; auto.
+  red; rewrite <- Zcompare_antisym, H; auto.
+Qed.
+
+
 (** * Transitivity of comparison *)
 
+Lemma Zcompare_Lt_trans :
+  forall n m p:Z, (n ?= m) = Lt -> (m ?= p) = Lt -> (n ?= p) = Lt.
+Proof.
+  intros x y z; case x; case y; case z; simpl;
+    try discriminate; auto with arith.
+  intros; eapply Plt_trans; eauto.
+  intros p q r; rewrite 3 Pcompare_antisym; simpl.
+  intros; eapply Plt_trans; eauto.
+Qed.
+
 Lemma Zcompare_Gt_trans :
   forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
 Proof.
-  intros x y z; case x; case y; case z; simpl in |- *;
-    try (intros; discriminate H || discriminate H0); auto with arith;
-      [ intros p q r H H0; apply nat_of_P_gt_Gt_compare_complement_morphism;
-	unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
-	  apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
-	    assumption
-	| intros p q r; do 3 rewrite <- ZC4; intros H H0;
-	  apply nat_of_P_gt_Gt_compare_complement_morphism; 
-	    unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
-	      apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
-		assumption ].
+  intros n m p Hnm Hmp.
+  apply <- Zcompare_Gt_Lt_antisym.
+  apply -> Zcompare_Gt_Lt_antisym in Hnm.
+  apply -> Zcompare_Gt_Lt_antisym in Hmp.
+  eapply Zcompare_Lt_trans; eauto.
 Qed.
 
 (** * Comparison and opposite *)
@@ -129,7 +143,7 @@ Proof.
     [ reflexivity
       | apply H
       | rewrite (Zcompare_opp x y); rewrite Zcompare_opp;
-	do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; 
+	do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg;
 	  apply H ].
 Qed.
 
@@ -145,7 +159,7 @@ Proof.
 	  rewrite nat_of_P_minus_morphism;
 	    [ unfold gt in |- *; apply ZL16 | assumption ]
       | intros p; ElimPcompare z p; intros E; auto with arith;
-	apply nat_of_P_gt_Gt_compare_complement_morphism; 
+	apply nat_of_P_gt_Gt_compare_complement_morphism;
 	  unfold gt in |- *; apply ZL17
       | intros p q; ElimPcompare q p; intros E; rewrite E;
 	[ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl
@@ -170,7 +184,7 @@ Proof.
 	    [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ]
 	      | assumption ]
       | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p;
-	intros E1; rewrite E1; ElimPcompare q p; intros E2; 
+	intros E1; rewrite E1; ElimPcompare q p; intros E2;
 	  rewrite E2; auto with arith;
 	    [ absurd ((q ?= p)%positive Eq = Lt);
 	      [ rewrite <- (Pcompare_Eq_eq z q E0);
@@ -273,7 +287,7 @@ Proof.
 			[ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q);
 			  rewrite plus_assoc; rewrite le_plus_minus_r;
 			    [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l;
-			      apply nat_of_P_lt_Lt_compare_morphism; 
+			      apply nat_of_P_lt_Lt_compare_morphism;
 				assumption
 			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
 				apply ZC1; assumption ]
@@ -289,7 +303,7 @@ Proof.
 			[ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
 			  rewrite plus_assoc; rewrite le_plus_minus_r;
 			    [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
-			      apply nat_of_P_lt_Lt_compare_morphism; 
+			      apply nat_of_P_lt_Lt_compare_morphism;
 				apply ZC1; assumption
 			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
 				apply ZC1; assumption ]
@@ -330,7 +344,7 @@ Qed.
 Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt.
 Proof.
   intro x; unfold Zsucc in |- *; pattern x at 2 in |- *;
-    rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; 
+    rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat;
       reflexivity.
 Qed.
 
@@ -351,7 +365,7 @@ Proof.
 		    apply nat_of_P_lt_Lt_compare_morphism;
 		      change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2;
 			rewrite <- (fun m n:Z => Zcompare_plus_compat m n y);
-			  rewrite (Zplus_comm x); rewrite Zplus_assoc; 
+			  rewrite (Zplus_comm x); rewrite Zplus_assoc;
 			    rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ]
 	| intros H1; rewrite H1; discriminate ]
       | intros H; elim_compare x (y + 1);
@@ -369,7 +383,7 @@ Proof.
   intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1);
     rewrite Zcompare_plus_compat; auto with arith.
 Qed.
- 
+
 (** * Multiplication and comparison *)
 
 Lemma Zcompare_mult_compat :
@@ -394,7 +408,7 @@ Qed.
 Lemma rename :
   forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
 Proof.
-  auto with arith. 
+  auto with arith.
 Qed.
 
 Lemma Zcompare_elim :
@@ -473,7 +487,7 @@ Lemma Zge_compare :
 		| Gt => True
               end.
 Proof.
-  intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. 
+  intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith.
 Qed.
 
 Lemma Zgt_compare :
diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
index c6ade934..08cc564d 100644
--- a/theories/ZArith/Zcomplements.v
+++ b/theories/ZArith/Zcomplements.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zcomplements.v 10617 2008-03-04 18:07:16Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import ZArithRing.
 Require Import ZArith_base.
@@ -19,26 +19,26 @@ Open Local Scope Z_scope.
 (** About parity *)
 
 Lemma two_or_two_plus_one :
-  forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. 
+  forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}.
 Proof.
   intro x; destruct x.
   left; split with 0; reflexivity.
-  
+
   destruct p.
   right; split with (Zpos p); reflexivity.
-  
+
   left; split with (Zpos p); reflexivity.
-  
+
   right; split with 0; reflexivity.
-  
+
   destruct p.
   right; split with (Zneg (1 + p)).
   rewrite BinInt.Zneg_xI.
   rewrite BinInt.Zneg_plus_distr.
   omega.
-  
+
   left; split with (Zneg p); reflexivity.
-  
+
   right; split with (-1); reflexivity.
 Qed.
 
@@ -64,24 +64,24 @@ Proof.
   trivial.
 Qed.
 
-Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. 
+Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p.
 Proof.
   unfold floor in |- *.
   intro a; induction a as [p| p| ].
-  
+
   simpl in |- *.
   repeat rewrite BinInt.Zpos_xI.
-  rewrite (BinInt.Zpos_xO (xO (floor_pos p))). 
+  rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
   rewrite (BinInt.Zpos_xO (floor_pos p)).
   omega.
-  
+
   simpl in |- *.
   repeat rewrite BinInt.Zpos_xI.
   rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
   rewrite (BinInt.Zpos_xO (floor_pos p)).
   rewrite (BinInt.Zpos_xO p).
   omega.
-  
+
   simpl in |- *; omega.
 Qed.
 
@@ -128,7 +128,7 @@ Proof.
   elim (Zabs_dec m); intro eq; rewrite eq; trivial.
 Qed.
 
-(** To do case analysis over the sign of [z] *) 
+(** To do case analysis over the sign of [z] *)
 
 Lemma Zcase_sign :
   forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
@@ -160,11 +160,11 @@ Qed.
 
 Require Import List.
 
-Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) {struct l} : Z :=
+Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
   match l with
     | nil => acc
     | _ :: l => Zlength_aux (Zsucc acc) A l
-  end. 
+  end.
 
 Definition Zlength := Zlength_aux 0.
 Implicit Arguments Zlength [A].
@@ -177,7 +177,7 @@ Section Zlength_properties.
 
   Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
   Proof.
-    assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). 
+    assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)).
     simple induction l.
     simpl in |- *; auto with zarith.
     intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
@@ -202,7 +202,7 @@ Section Zlength_properties.
     case l; auto.
     intros x l'; simpl (length (x :: l')) in |- *.
     rewrite Znat.inj_S.
-    intros; elimtype False; generalize (Zle_0_nat (length l')); omega.
+    intros; exfalso; generalize (Zle_0_nat (length l')); omega.
   Qed.
 
 End Zlength_properties.
diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zdigits.v
index 08f08e12..0a6c9498 100644
--- a/theories/ZArith/Zbinary.v
+++ b/theories/ZArith/Zdigits.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,9 +7,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zbinary.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
-(** Bit vectors interpreted as integers. 
+(** Bit vectors interpreted as integers.
     Contribution by Jean Duprat (ENS Lyon). *)
 
 Require Import Bvector.
@@ -16,27 +17,22 @@ Require Import ZArith.
 Require Export Zpower.
 Require Import Omega.
 
-(** L'évaluation des vecteurs de booléens se font à la fois en binaire et
-    en complément à  deux. Le nombre appartient à  Z. 
-    On utilise donc Omega pour faire les calculs dans Z.
-    De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur.
-	two_power_nat = [n:nat](POS (shift_nat n xH))
-     		: nat->Z
-	two_power_nat_S
-	     : (n:nat)`(two_power_nat (S n)) = 2*(two_power_nat n)`
-	Z_lt_ge_dec
-	     : (x,y:Z){`x < y`}+{`x >= y`}
+(** The evaluation of boolean vector is done both in binary and
+    two's complement. The computed number belongs to Z.
+    We hence use Omega to perform computations in Z.
+    Moreover, we use functions [2^n] where [n] is a natural number
+    (here the vector length).
 *)
 
 
 Section VALUE_OF_BOOLEAN_VECTORS.
 
-(** Les calculs sont effectués dans la convention positive usuelle.
-    Les valeurs correspondent soit à  l'écriture binaire (nat), 
-    soit au complément à  deux (int).
-    On effectue le calcul suivant le schéma de Horner.
-    Le complément à  deux n'a de sens que sur les vecteurs de taille 
-    supérieure ou égale à  un, le bit de signe étant évalué négativement.
+(** Computations are done in the usual convention.
+    The values correspond either to the binary coding (nat) or
+    to the two's complement coding (int).
+    We perform the computation via Horner scheme.
+    The two's complement coding only makes sense on vectors whose
+    size is greater or equal to one (a sign bit should be present).
 *)
 
   Definition bit_value (b:bool) : Z :=
@@ -44,12 +40,12 @@ Section VALUE_OF_BOOLEAN_VECTORS.
       | true => 1%Z
       | false => 0%Z
     end.
-  
+
   Lemma binary_value : forall n:nat, Bvector n -> Z.
   Proof.
     simple induction n; intros.
     exact 0%Z.
-    
+
     inversion H0.
     exact (bit_value a + 2 * H H2)%Z.
   Defined.
@@ -68,12 +64,12 @@ End VALUE_OF_BOOLEAN_VECTORS.
 
 Section ENCODING_VALUE.
 
-(** On calcule la valeur binaire selon un schema de Horner.
-    Le calcul s'arrete à  la longueur du vecteur sans vérification.
-    On definit une fonction Zmod2 calquee sur Zdiv2 mais donnant le quotient
-    de la division z=2q+r avec 0<=r<=1.
-    La valeur en complément à  deux est calculée selon un schema de Horner
-    avec Zmod2, le paramètre est la taille moins un.
+(** We compute the binary value via a Horner scheme.
+    Computation stops at the vector length without checks.
+    We define a function Zmod2 similar to Zdiv2 returning the
+    quotient of division z=2q+r with 0<=r<=1.
+    The two's complement value is also computed via a Horner scheme
+    with Zmod2, the parameter is the size minus one.
 *)
 
   Definition Zmod2 (z:Z) :=
@@ -98,19 +94,19 @@ Section ENCODING_VALUE.
   Proof.
     destruct z; simpl in |- *.
     trivial.
-    
+
     destruct p; simpl in |- *; trivial.
-    
+
     destruct p; simpl in |- *.
     destruct p as [p| p| ]; simpl in |- *.
     rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial.
 
     trivial.
-    
+
     trivial.
-    
+
     trivial.
-    
+
     trivial.
   Qed.
 
@@ -118,7 +114,7 @@ Section ENCODING_VALUE.
   Proof.
     simple induction n; intros.
     exact Bnil.
-    
+
     exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))).
   Defined.
 
@@ -126,7 +122,7 @@ Section ENCODING_VALUE.
   Proof.
     simple induction n; intros.
     exact (Bcons (Zeven.Zodd_bool H) 0 Bnil).
-    
+
     exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))).
   Defined.
 
@@ -134,9 +130,8 @@ End ENCODING_VALUE.
 
 Section Z_BRIC_A_BRAC.
 
-  (** Bibliotheque de lemmes utiles dans la section suivante.
-      Utilise largement ZArith.
-      Mériterait d'être récrite.
+  (** Some auxiliary lemmas used in the next section. Large use of ZArith.
+      Deserve to be properly rewritten.
   *)
 
   Lemma binary_value_Sn :
@@ -206,10 +201,10 @@ Section Z_BRIC_A_BRAC.
   Proof.
     destruct z as [| p| p].
     auto.
-    
+
     destruct p; auto.
     simpl in |- *; intros; omega.
-    
+
     intro H; elim H; trivial.
   Qed.
 
@@ -221,11 +216,11 @@ Section Z_BRIC_A_BRAC.
     intros.
     cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros.
     omega.
-    
+
     rewrite <- two_power_nat_S.
     destruct (Zeven.Zeven_odd_dec z); intros.
     rewrite <- Zeven.Zeven_div2; auto.
-    
+
     generalize (Zeven.Zodd_div2 z H z0); omega.
   Qed.
 
@@ -236,7 +231,7 @@ Section Z_BRIC_A_BRAC.
   Proof.
     intros; auto.
   Qed.
-  
+
   Lemma Zeven_bit_value :
     forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z.
   Proof.
@@ -244,7 +239,7 @@ Section Z_BRIC_A_BRAC.
     destruct p; tauto || (intro H; elim H).
     destruct p; tauto || (intro H; elim H).
   Qed.
-  
+
   Lemma Zodd_bit_value :
     forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z.
   Proof.
@@ -253,7 +248,7 @@ Section Z_BRIC_A_BRAC.
     destruct p; tauto || (intros; elim H).
     destruct p; tauto || (intros; elim H).
   Qed.
-  
+
   Lemma Zge_minus_two_power_nat_S :
     forall (n:nat) (z:Z),
       (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
@@ -265,7 +260,7 @@ Section Z_BRIC_A_BRAC.
 
     rewrite (Zodd_bit_value z H); intros; omega.
   Qed.
-  
+
   Lemma Zlt_two_power_nat_S :
     forall (n:nat) (z:Z),
       (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
@@ -282,8 +277,8 @@ End Z_BRIC_A_BRAC.
 
 Section COHERENT_VALUE.
 
-(** On vérifie que dans l'intervalle de définition les fonctions sont 
-    réciproques l'une de l'autre. Elles utilisent les lemmes du bric-a-brac.
+(** We check that the functions are reciprocal on the definition interval.
+    This uses earlier library lemmas.
 *)
 
   Lemma binary_to_Z_to_binary :
@@ -291,26 +286,26 @@ Section COHERENT_VALUE.
   Proof.
     induction bv as [| a n bv IHbv].
     auto.
-    
+
     rewrite binary_value_Sn.
     rewrite Z_to_binary_Sn.
     rewrite IHbv; trivial.
-    
+
     apply binary_value_pos.
   Qed.
-  
+
   Lemma two_compl_to_Z_to_two_compl :
     forall (n:nat) (bv:Bvector n) (b:bool),
       Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
   Proof.
     induction bv as [| a n bv IHbv]; intro b.
     destruct b; auto.
-    
+
     rewrite two_compl_value_Sn.
     rewrite Z_to_two_compl_Sn.
     rewrite IHbv; trivial.
   Qed.
-  
+
   Lemma Z_to_binary_to_Z :
     forall (n:nat) (z:Z),
       (z >= 0)%Z ->
@@ -318,17 +313,17 @@ Section COHERENT_VALUE.
   Proof.
     induction n as [| n IHn].
     unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega.
-    
+
     intros; rewrite Z_to_binary_Sn_z.
     rewrite binary_value_Sn.
     rewrite IHn.
     apply Z_div2_value; auto.
-    
+
     apply Pdiv2; trivial.
-    
+
     apply Zdiv2_two_power_nat; trivial.
   Qed.
-  
+
   Lemma Z_to_two_compl_to_Z :
     forall (n:nat) (z:Z),
       (z >= - two_power_nat n)%Z ->
@@ -345,7 +340,7 @@ Section COHERENT_VALUE.
     generalize (Zmod2_twice z); omega.
 
     apply Zge_minus_two_power_nat_S; auto.
-    
+
     apply Zlt_two_power_nat_S; auto.
   Qed.
 
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
index 228a882a..f3e65697 100644
--- a/theories/ZArith/Zdiv.v
+++ b/theories/ZArith/Zdiv.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,13 +7,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zdiv.v 11477 2008-10-20 15:16:14Z letouzey $ i*)
+(*i $Id$ i*)
 
 (* Contribution by Claude Marché and Xavier Urbain *)
 
 (** Euclidean Division
 
-    Defines first of function that allows Coq to normalize. 
+    Defines first of function that allows Coq to normalize.
     Then only after proves the main required property.
 *)
 
@@ -26,16 +27,15 @@ Open Local Scope Z_scope.
 
 (** * Definitions of Euclidian operations *)
 
-(** Euclidean division of a positive by a integer 
+(** Euclidean division of a positive by a integer
     (that is supposed to be positive).
 
     Total function than returns an arbitrary value when
     divisor is not positive
-  
+
 *)
 
-Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : 
-  Z * Z :=
+Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) : Z * Z :=
   match a with
     | xH => if Zge_bool b 2 then (0, 1) else (1, 0)
     | xO a' =>
@@ -50,41 +50,41 @@ Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} :
 
 
 (** Euclidean division of integers.
- 
-    Total function than returns (0,0) when dividing by 0. 
-*) 
-    
-(** 
+
+    Total function than returns (0,0) when dividing by 0.
+*)
+
+(**
 
   The pseudo-code is:
-  
+
   if b = 0 : (0,0)
- 
+
   if b <> 0 and a = 0 : (0,0)
 
-  if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in 
+  if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in
                        if r = 0 then (-q,0) else (-(q+1),b-r)
 
   if b < 0 and a < 0 : let (q,r) = div_eucl (-a) (-b) in (q,-r)
 
-  if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in 
+  if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in
                        if r = 0 then (-q,0) else (-(q+1),b+r)
 
-  In other word, when b is non-zero, q is chosen to be the greatest integer 
-  smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when 
-  r is not null). 
+  In other word, when b is non-zero, q is chosen to be the greatest integer
+  smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when
+  r is not null).
 *)
 
 (* Nota: At least two others conventions also exist for euclidean division.
-   They all satify the equation a=b*q+r, but differ on the choice of (q,r) 
+   They all satify the equation a=b*q+r, but differ on the choice of (q,r)
    on negative numbers.
 
    * Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b).
      Hence (-a) mod b = - (a mod b)
            a mod (-b) = a mod b
-     And: |r| < |b| and sgn(r) = sgn(a)  (notice the a here instead of b). 
+     And: |r| < |b| and sgn(r) = sgn(a)  (notice the a here instead of b).
 
-   * Another solution is to always pick a non-negative remainder: 
+   * Another solution is to always pick a non-negative remainder:
      a=b*q+r with 0 <= r < |b|
 *)
 
@@ -113,7 +113,7 @@ Definition Zdiv_eucl (a b:Z) : Z * Z :=
 
 Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q.
 
-Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. 
+Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r.
 
 (** Syntax *)
 
@@ -122,7 +122,7 @@ Infix "mod" := Zmod (at level 40, no associativity) : Z_scope.
 
 (* Tests:
 
-Eval compute in (Zdiv_eucl 7 3). 
+Eval compute in (Zdiv_eucl 7 3).
 
 Eval compute in (Zdiv_eucl (-7) 3).
 
@@ -133,7 +133,7 @@ Eval compute in (Zdiv_eucl (-7) (-3)).
 *)
 
 
-(** * Main division theorem *) 
+(** * Main division theorem *)
 
 (** First a lemma for two positive arguments *)
 
@@ -170,7 +170,7 @@ Theorem Z_div_mod :
 Proof.
   intros a b; case a; case b; try (simpl in |- *; intros; omega).
   unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial.
-  
+
   intros; discriminate.
 
   intros.
@@ -179,25 +179,25 @@ Proof.
   case (Zdiv_eucl_POS p0 (Zpos p)).
   intros z z0.
   case z0.
-  
+
   intros [H1 H2].
   split; trivial.
   change (Zneg p0) with (- Zpos p0); rewrite H1; ring.
-  
+
   intros p1 [H1 H2].
   split; trivial.
   change (Zneg p0) with (- Zpos p0); rewrite H1; ring.
   generalize (Zorder.Zgt_pos_0 p1); omega.
-  
+
   intros p1 [H1 H2].
   split; trivial.
   change (Zneg p0) with (- Zpos p0); rewrite H1; ring.
   generalize (Zorder.Zlt_neg_0 p1); omega.
-  
+
   intros; discriminate.
 Qed.
 
-(** For stating the fully general result, let's give a short name 
+(** For stating the fully general result, let's give a short name
     to the condition on the remainder. *)
 
 Definition Remainder r b :=  0 <= r < b \/ b < r <= 0.
@@ -206,7 +206,7 @@ Definition Remainder r b :=  0 <= r < b \/ b < r <= 0.
 
 Definition Remainder_alt r b :=  Zabs r < Zabs b /\ Zsgn r <> - Zsgn b.
 
-(* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying 
+(* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying
     [ Zsgn r = Zsgn b ], but at least it works even when [r] is null. *)
 
 Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b.
@@ -250,7 +250,7 @@ Proof.
   destruct Zdiv_eucl_POS as (q,r).
   destruct r as [|r|r]; change (Zneg b) with (-Zpos b).
   rewrite Zmult_opp_comm; omega with *.
-  rewrite <- Zmult_opp_comm, Zmult_plus_distr_r; 
+  rewrite <- Zmult_opp_comm, Zmult_plus_distr_r;
    repeat rewrite Zmult_opp_comm; omega.
   rewrite Zmult_opp_comm; omega with *.
 Qed.
@@ -331,14 +331,14 @@ elim (Zlt_not_le (Zabs (r2 - r1)) (Zabs b)).
 omega with *.
 replace (r2-r1) with (b*(q1-q2)) by (rewrite Zmult_minus_distr_l; omega).
 replace (Zabs b) with ((Zabs b)*1) by ring.
-rewrite Zabs_Zmult. 
+rewrite Zabs_Zmult.
 apply Zmult_le_compat_l; auto with *.
 omega with *.
 Qed.
 
 Theorem Zdiv_mod_unique_2 :
  forall b q1 q2 r1 r2:Z,
-  Remainder r1 b -> Remainder r2 b -> 
+  Remainder r1 b -> Remainder r2 b ->
   b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2.
 Proof.
 unfold Remainder.
@@ -356,7 +356,7 @@ omega with *.
 Qed.
 
 Theorem Zdiv_unique_full:
- forall a b q r, Remainder r b -> 
+ forall a b q r, Remainder r b ->
    a = b*q + r -> q = a/b.
 Proof.
   intros.
@@ -368,7 +368,7 @@ Proof.
 Qed.
 
 Theorem Zdiv_unique:
- forall a b q r, 0 <= r < b -> 
+ forall a b q r, 0 <= r < b ->
    a = b*q + r -> q = a/b.
 Proof.
   intros; eapply Zdiv_unique_full; eauto.
@@ -425,7 +425,7 @@ Proof.
   intros; symmetry; apply Zdiv_unique with 0; auto with zarith.
 Qed.
 
-Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r 
+Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r
  : zarith.
 
 Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0.
@@ -460,7 +460,7 @@ Qed.
 
 Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a.
 Proof.
-  intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith; 
+  intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith;
    [ red; omega | ring].
 Qed.
 
@@ -485,7 +485,7 @@ Proof.
   intros; generalize (Z_div_pos a b H); auto with zarith.
 Qed.
 
-(** As soon as the divisor is greater or equal than 2, 
+(** As soon as the divisor is greater or equal than 2,
     the division is strictly decreasing. *)
 
 Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a.
@@ -530,7 +530,7 @@ Proof.
   intro.
   absurd (b - a >= 1).
   omega.
-  replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by 
+  replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by
     (symmetry; pattern a at 1; rewrite H2; pattern b at 1; rewrite H0; ring).
   assert (c * (b / c - a / c) >= c * 1).
   apply Zmult_ge_compat_l.
@@ -580,7 +580,7 @@ Qed.
 (** A modulo cannot grow beyond its starting point. *)
 
 Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a.
-Proof. 
+Proof.
   intros a b H1 H2; case (Zle_or_lt b a); intros H3.
   case (Z_mod_lt a b); auto with zarith.
   rewrite Zmod_small; auto with zarith.
@@ -588,45 +588,38 @@ Qed.
 
 (** Some additionnal inequalities about Zdiv. *)
 
-Theorem Zdiv_le_upper_bound: 
-  forall a b q, 0 <= a -> 0 < b -> a <= q*b -> a/b <= q.
+Theorem Zdiv_lt_upper_bound:
+  forall a b q, 0 < b -> a < q*b -> a/b < q.
 Proof.
-  intros a b q H1 H2 H3.
-  apply Zmult_le_reg_r with b; auto with zarith.
-  apply Zle_trans with (2 := H3).
+  intros a b q H1 H2.
+  apply Zmult_lt_reg_r with b; auto with zarith.
+  apply Zle_lt_trans with (2 := H2).
   pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith.
   rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith.
 Qed.
 
-Theorem Zdiv_lt_upper_bound: 
-  forall a b q, 0 <= a -> 0 < b -> a < q*b -> a/b < q.
+Theorem Zdiv_le_upper_bound:
+  forall a b q, 0 < b -> a <= q*b -> a/b <= q.
 Proof.
-  intros a b q H1 H2 H3.
-  apply Zmult_lt_reg_r with b; auto with zarith.
-  apply Zle_lt_trans with (2 := H3).
-  pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith.
-  rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith.
+  intros.
+  rewrite <- (Z_div_mult_full q b); auto with zarith.
+  apply Z_div_le; auto with zarith.
 Qed.
 
-Theorem Zdiv_le_lower_bound: 
-  forall a b q, 0 <= a -> 0 < b -> q*b <= a -> q <= a/b.
+Theorem Zdiv_le_lower_bound:
+  forall a b q, 0 < b -> q*b <= a -> q <= a/b.
 Proof.
-  intros a b q H1 H2 H3.
-  assert (q < a / b + 1); auto with zarith.
-  apply Zmult_lt_reg_r with b; auto with zarith.
-  apply Zle_lt_trans with (1 := H3).
-  pattern a at 1; rewrite (Z_div_mod_eq a b); auto with zarith.
-  rewrite Zmult_plus_distr_l; rewrite (Zmult_comm b); case (Z_mod_lt a b);
-   auto with zarith.
+  intros.
+  rewrite <- (Z_div_mult_full q b); auto with zarith.
+  apply Z_div_le; auto with zarith.
 Qed.
 
-
 (** A division of respect opposite monotonicity for the divisor *)
 
 Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r ->
     p / r <= p / q.
 Proof.
-  intros p q r H H1. 
+  intros p q r H H1.
   apply Zdiv_le_lower_bound; auto with zarith.
   rewrite Zmult_comm.
   pattern p at 2; rewrite (Z_div_mod_eq p r); auto with zarith.
@@ -636,11 +629,11 @@ Proof.
   case (Z_mod_lt p r); auto with zarith.
 Qed.
 
-Theorem Zdiv_sgn: forall a b, 
+Theorem Zdiv_sgn: forall a b,
   0 <= Zsgn (a/b) * Zsgn a * Zsgn b.
 Proof.
-  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; 
-  generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; 
+  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
+  generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl;
   destruct Zdiv_eucl_POS as (q,r); destruct r; omega with *.
 Qed.
 
@@ -668,12 +661,12 @@ Qed.
 Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b.
 Proof.
   intros a b c H; rewrite Zplus_comm; rewrite Z_div_plus_full;
-  try apply Zplus_comm; auto with zarith. 
+  try apply Zplus_comm; auto with zarith.
 Qed.
 
 (** [Zopp] and [Zdiv], [Zmod].
-    Due to the choice of convention for our Euclidean division, 
-    some of the relations about [Zopp] and divisions are rather complex. *) 
+    Due to the choice of convention for our Euclidean division,
+    some of the relations about [Zopp] and divisions are rather complex. *)
 
 Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b.
 Proof.
@@ -702,7 +695,7 @@ Proof.
   ring.
 Qed.
 
-Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> 
+Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 ->
  (-a) mod b = b - (a mod b).
 Proof.
   intros.
@@ -721,7 +714,7 @@ Proof.
   rewrite Z_mod_zero_opp_full; auto.
 Qed.
 
-Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> 
+Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 ->
  a mod (-b) = (a mod b) - b.
 Proof.
   intros.
@@ -740,7 +733,7 @@ Proof.
   rewrite H; ring.
 Qed.
 
-Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> 
+Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 ->
  (-a)/b = -(a/b)-1.
 Proof.
   intros.
@@ -758,7 +751,7 @@ Proof.
   rewrite Z_div_zero_opp_full; auto.
 Qed.
 
-Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> 
+Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 ->
  a/(-b) = -(a/b)-1.
 Proof.
   intros.
@@ -769,7 +762,7 @@ Qed.
 
 (** Cancellations. *)
 
-Lemma Zdiv_mult_cancel_r : forall a b c:Z, 
+Lemma Zdiv_mult_cancel_r : forall a b c:Z,
  c <> 0 -> (a*c)/(b*c) = a/b.
 Proof.
 assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b).
@@ -781,17 +774,17 @@ assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b).
  apply Zmult_lt_compat_r; auto with zarith.
  pattern a at 1; rewrite (Z_div_mod_eq a b Hb); ring.
 intros a b c Hc.
-destruct (Z_dec b 0) as [Hb|Hb]. 
+destruct (Z_dec b 0) as [Hb|Hb].
 destruct Hb as [Hb|Hb]; destruct (not_Zeq_inf _ _ Hc); auto with *.
-rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a); 
+rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a);
  auto with *.
-rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l, 
+rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l,
  Zopp_mult_distr_l; auto with *.
 rewrite <- Zdiv_opp_opp, Zopp_mult_distr_r, Zopp_mult_distr_r; auto with *.
 rewrite Hb; simpl; do 2 rewrite Zdiv_0_r; auto.
 Qed.
 
-Lemma Zdiv_mult_cancel_l : forall a b c:Z, 
+Lemma Zdiv_mult_cancel_l : forall a b c:Z,
  c<>0 -> (c*a)/(c*b) = a/b.
 Proof.
   intros.
@@ -799,7 +792,7 @@ Proof.
   apply Zdiv_mult_cancel_r; auto.
 Qed.
 
-Lemma Zmult_mod_distr_l: forall a b c, 
+Lemma Zmult_mod_distr_l: forall a b c,
   (c*a) mod (c*b) = c * (a mod b).
 Proof.
   intros; destruct (Z_eq_dec c 0) as [Hc|Hc].
@@ -814,7 +807,7 @@ Proof.
   ring.
 Qed.
 
-Lemma Zmult_mod_distr_r: forall a b c, 
+Lemma Zmult_mod_distr_r: forall a b c,
   (a*c) mod (b*c) = (a mod b) * c.
 Proof.
   intros; repeat rewrite (fun x => (Zmult_comm x c)).
@@ -982,8 +975,8 @@ Proof.
   apply Zplus_le_compat;auto with zarith.
   destruct (Z_mod_lt (a/b) c);auto with zarith.
   replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith.
-  intro H1; 
-  assert (H2: c <> 0) by auto with zarith; 
+  intro H1;
+  assert (H2: c <> 0) by auto with zarith;
   rewrite (Zmult_integral_l _ _ H2 H1) in H; auto with zarith.
 Qed.
 
@@ -996,7 +989,7 @@ Theorem Zdiv_mult_le:
  forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b.
 Proof.
   intros a b c H1 H2 H3.
-  destruct (Zle_lt_or_eq _ _ H2); 
+  destruct (Zle_lt_or_eq _ _ H2);
    [ | subst; rewrite Zdiv_0_r, Zdiv_0_r, Zmult_0_r; auto].
   case (Z_mod_lt a b); auto with zarith; intros Hu1 Hu2.
   case (Z_mod_lt c b); auto with zarith; intros Hv1 Hv2.
@@ -1012,14 +1005,14 @@ Proof.
   apply (Zmod_le ((c mod b) * (a mod b)) b); auto with zarith.
   apply Zmult_le_compat_r; auto with zarith.
   apply (Zmod_le c b); auto.
-  pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; 
+  pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring;
     auto with zarith.
   pattern a at 1; rewrite (Z_div_mod_eq a b); try ring; auto with zarith.
 Qed.
 
 (** Zmod is related to divisibility (see more in Znumtheory) *)
 
-Lemma Zmod_divides : forall a b, b<>0 -> 
+Lemma Zmod_divides : forall a b, b<>0 ->
  (a mod b = 0 <-> exists c, a = b*c).
 Proof.
  split; intros.
@@ -1077,7 +1070,7 @@ Qed.
 
 (** * A direct way to compute Zmod *)
 
-Fixpoint Zmod_POS (a : positive) (b : Z) {struct a} : Z  :=
+Fixpoint Zmod_POS (a : positive) (b : Z) : Z  :=
   match a with
    | xI a' =>
       let r := Zmod_POS a' b in
@@ -1166,11 +1159,11 @@ Qed.
 Implicit Arguments Zdiv_eucl_extended.
 
 (** A third convention: Ocaml.
-   
+
      See files ZOdiv_def.v and ZOdiv.v.
-     
+
      Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b).
      Hence (-a) mod b = - (a mod b)
            a mod (-b) = a mod b
-     And: |r| < |b| and sgn(r) = sgn(a)  (notice the a here instead of b). 
+     And: |r| < |b| and sgn(r) = sgn(a)  (notice the a here instead of b).
 *)
diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
index 4a402c61..09131043 100644
--- a/theories/ZArith/Zeven.v
+++ b/theories/ZArith/Zeven.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zeven.v 10291 2007-11-06 02:18:53Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import BinInt.
 
@@ -96,32 +96,32 @@ Qed.
 Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n).
 Proof.
   intro z; destruct z; unfold Zsucc in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *; 
-      trivial. 
+    [ idtac | destruct p | destruct p ]; simpl in |- *;
+      trivial.
   unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n).
 Proof.
   intro z; destruct z; unfold Zsucc in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *; 
-      trivial. 
+    [ idtac | destruct p | destruct p ]; simpl in |- *;
+      trivial.
   unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n).
 Proof.
   intro z; destruct z; unfold Zpred in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *; 
-      trivial. 
+    [ idtac | destruct p | destruct p ]; simpl in |- *;
+      trivial.
   unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n).
 Proof.
   intro z; destruct z; unfold Zpred in |- *;
-    [ idtac | destruct p | destruct p ]; simpl in |- *; 
-      trivial. 
+    [ idtac | destruct p | destruct p ]; simpl in |- *;
+      trivial.
   unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
@@ -132,7 +132,7 @@ Hint Unfold Zeven Zodd: zarith.
 (** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *)
 
 (** [Zdiv2] is defined on all [Z], but notice that for odd negative
-    integers it is not the euclidean quotient: in that case we have 
+    integers it is not the euclidean quotient: in that case we have
       [n = 2*(n/2)-1] *)
 
 Definition Zdiv2 (z:Z) :=
@@ -200,7 +200,7 @@ Proof.
   intros x.
   elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy;
     rewrite <- Zplus_diag_eq_mult_2 in Hy.
-  exists (y, y); split. 
+  exists (y, y); split.
   assumption.
   left; reflexivity.
   exists (y, (y + 1)%Z); split.
@@ -239,7 +239,7 @@ Proof.
   destruct p; simpl; auto.
 Qed.
 
-Theorem Zeven_plus_Zodd: forall a b, 
+Theorem Zeven_plus_Zodd: forall a b,
  Zeven a -> Zodd b -> Zodd (a + b).
 Proof.
   intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
@@ -257,13 +257,13 @@ Proof.
   apply Zmult_plus_distr_r; auto.
 Qed.
 
-Theorem Zodd_plus_Zeven: forall a b, 
+Theorem Zodd_plus_Zeven: forall a b,
  Zodd a -> Zeven b -> Zodd (a + b).
 Proof.
   intros a b H1 H2; rewrite Zplus_comm; apply Zeven_plus_Zodd; auto.
 Qed.
 
-Theorem Zodd_plus_Zodd: forall a b, 
+Theorem Zodd_plus_Zodd: forall a b,
  Zodd a -> Zodd b -> Zeven (a + b).
 Proof.
   intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto.
@@ -276,7 +276,7 @@ Proof.
   repeat rewrite <- Zplus_assoc; auto.
 Qed.
 
-Theorem Zeven_mult_Zeven_l: forall a b, 
+Theorem Zeven_mult_Zeven_l: forall a b,
  Zeven a -> Zeven (a * b).
 Proof.
   intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
@@ -285,7 +285,7 @@ Proof.
   apply Zmult_assoc.
 Qed.
 
-Theorem Zeven_mult_Zeven_r: forall a b, 
+Theorem Zeven_mult_Zeven_r: forall a b,
  Zeven b -> Zeven (a * b).
 Proof.
   intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto.
@@ -296,10 +296,10 @@ Proof.
   rewrite (Zmult_comm 2 a); auto.
 Qed.
 
-Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l 
+Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l
      Zplus_assoc Zmult_1_r Zmult_1_l : Zexpand.
 
-Theorem Zodd_mult_Zodd: forall a b, 
+Theorem Zodd_mult_Zodd: forall a b,
  Zodd a -> Zodd b -> Zodd (a * b).
 Proof.
   intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto.
@@ -308,7 +308,7 @@ Proof.
   (* ring part *)
   autorewrite with Zexpand; f_equal.
   repeat rewrite <- Zplus_assoc; f_equal.
-  repeat rewrite <- Zmult_assoc; f_equal. 
+  repeat rewrite <- Zmult_assoc; f_equal.
   repeat rewrite Zmult_assoc; f_equal; apply Zmult_comm.
 Qed.
 
diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v
index 286dd710..447f6101 100644
--- a/theories/ZArith/Zgcd_alt.v
+++ b/theories/ZArith/Zgcd_alt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zgcd_alt.v 10997 2008-05-27 15:16:40Z letouzey $ i*)
+(*i $Id$ i*)
 
 (** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *)
 
@@ -30,7 +30,7 @@ Open Scope Z_scope.
 
 (** In Coq, we need to control the number of iteration of modulo.
    For that, we use an explicit measure in [nat], and we prove later
-   that using [2*d] is enough, where [d] is the number of binary 
+   that using [2*d] is enough, where [d] is the number of binary
    digits of the first argument. *)
 
  Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b =>
@@ -43,17 +43,17 @@ Open Scope Z_scope.
   	      end
    end.
 
- Definition Zgcd_bound (a:Z) := 
+ Definition Zgcd_bound (a:Z) :=
    match a with
      | Z0 => S O
      | Zpos p => let n := Psize p in (n+n)%nat
      | Zneg p => let n := Psize p in (n+n)%nat
    end.
- 
+
  Definition Zgcd_alt a b := Zgcdn (Zgcd_bound a) a b.
- 
+
  (** A first obvious fact : [Zgcd a b] is positive. *)
- 
+
  Lemma Zgcdn_pos : forall n a b,
    0 <= Zgcdn n a b.
  Proof.
@@ -61,22 +61,22 @@ Open Scope Z_scope.
    simpl; auto with zarith.
    destruct a; simpl; intros; auto with zarith; auto.
  Qed.
- 
+
  Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b.
  Proof.
    intros; unfold Zgcd; apply Zgcdn_pos; auto.
  Qed.
- 
+
  (** We now prove that Zgcd is indeed a gcd. *)
- 
+
  (** 1) We prove a weaker & easier bound. *)
- 
+
  Lemma Zgcdn_linear_bound : forall n a b,
    Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b).
  Proof.
    induction n.
    simpl; intros.
-   elimtype False; generalize (Zabs_pos a); omega.
+   exfalso; generalize (Zabs_pos a); omega.
    destruct a; intros; simpl;
      [ generalize (Zis_gcd_0_abs b); intuition | | ];
    unfold Zmod;
@@ -93,17 +93,17 @@ Open Scope Z_scope.
    apply Zis_gcd_minus; apply Zis_gcd_sym.
    apply Zis_gcd_for_euclid2; auto.
  Qed.
-  	 
+
  (** 2) For Euclid's algorithm, the worst-case situation corresponds
     to Fibonacci numbers. Let's define them: *)
- 
+
  Fixpoint fibonacci (n:nat) : Z :=
    match n with
      | O => 1
      | S O => 1
      | S (S n as p) => fibonacci p + fibonacci n
    end.
-  	 
+
  Lemma fibonacci_pos : forall n, 0 <= fibonacci n.
  Proof.
    cut (forall N n, (n<N)%nat -> 0<=fibonacci n).
@@ -118,7 +118,7 @@ Open Scope Z_scope.
    change (0 <= fibonacci (S n) + fibonacci n).
    generalize (IHN n) (IHN (S n)); omega.
  Qed.
- 
+
  Lemma fibonacci_incr :
    forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m.
  Proof.
@@ -131,11 +131,11 @@ Open Scope Z_scope.
    change (fibonacci (S m) <= fibonacci (S m)+fibonacci m).
    generalize (fibonacci_pos m); omega.
  Qed.
- 
+
  (** 3) We prove that fibonacci numbers are indeed worst-case:
     for a given number [n], if we reach a conclusion about [gcd(a,b)] in
     exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *)
- 
+
  Lemma Zgcdn_worst_is_fibonacci : forall n a b,
    0 < a < b ->
    Zis_gcd a b (Zgcdn (S n) a b) ->
@@ -192,14 +192,14 @@ Open Scope Z_scope.
    simpl in H5.
    elim H5; auto.
  Qed.
-  	 
+
  (** 3b) We reformulate the previous result in a more positive way. *)
- 
+
  Lemma Zgcdn_ok_before_fibonacci : forall n a b,
    0 < a < b -> a < fibonacci (S n) ->
    Zis_gcd a b (Zgcdn n a b).
  Proof.
-   destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate].
+   destruct a; [ destruct 1; exfalso; omega | | destruct 1; discriminate].
    cut (forall k n b,
      k = (S (nat_of_P p) - n)%nat ->
      0 < Zpos p < b -> Zpos p < fibonacci (S n) ->
@@ -224,44 +224,44 @@ Open Scope Z_scope.
    replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto.
    generalize (H2 H3); clear H2 H3; omega.
  Qed.
- 
+
  (** 4) The proposed bound leads to a fibonacci number that is big enough. *)
- 
+
  Lemma Zgcd_bound_fibonacci :
    forall a, 0 < a -> a < fibonacci (Zgcd_bound a).
  Proof.
    destruct a; [omega| | intro H; discriminate].
    intros _.
-   induction p; [ | | compute; auto ]; 
+   induction p; [ | | compute; auto ];
     simpl Zgcd_bound in *;
-    rewrite plus_comm; simpl plus; 
+    rewrite plus_comm; simpl plus;
     set (n:= (Psize p+Psize p)%nat) in *; simpl;
     assert (n <> O) by (unfold n; destruct p; simpl; auto).
-   
+
    destruct n as [ |m]; [elim H; auto| ].
    generalize (fibonacci_pos m); rewrite Zpos_xI; omega.
 
    destruct n as [ |m]; [elim H; auto| ].
    generalize (fibonacci_pos m); rewrite Zpos_xO; omega.
  Qed.
-  	 
+
  (* 5) the end: we glue everything together and take care of
     situations not corresponding to [0<a<b]. *)
 
  Lemma Zgcdn_is_gcd :
-   forall n a b, (Zgcd_bound a <= n)%nat -> 
+   forall n a b, (Zgcd_bound a <= n)%nat ->
      Zis_gcd a b (Zgcdn n a b).
  Proof.
    destruct a; intros.
    simpl in H.
-   destruct n; [elimtype False; omega | ].
+   destruct n; [exfalso; omega | ].
    simpl; generalize (Zis_gcd_0_abs b); intuition.
    (*Zpos*)
    generalize (Zgcd_bound_fibonacci (Zpos p)).
    simpl Zgcd_bound in *.
    remember (Psize p+Psize p)%nat as m.
    assert (1 < m)%nat.
-     rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; 
+     rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm;
        auto with arith.
    destruct m as [ |m]; [inversion H0; auto| ].
    destruct n as [ |n]; [inversion H; auto| ].
@@ -277,15 +277,15 @@ Open Scope Z_scope.
    apply Zgcdn_ok_before_fibonacci; auto.
    apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto].
    subst r; simpl.
-   destruct m as [ |m]; [elimtype False; omega| ].
-   destruct n as [ |n]; [elimtype False; omega| ].
+   destruct m as [ |m]; [exfalso; omega| ].
+   destruct n as [ |n]; [exfalso; omega| ].
    simpl; apply Zis_gcd_sym; apply Zis_gcd_0.
    (*Zneg*)
    generalize (Zgcd_bound_fibonacci (Zpos p)).
    simpl Zgcd_bound in *.
    remember (Psize p+Psize p)%nat as m.
    assert (1 < m)%nat.
-     rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; 
+     rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm;
        auto with arith.
    destruct m as [ |m]; [inversion H0; auto| ].
    destruct n as [ |n]; [inversion H; auto| ].
@@ -303,11 +303,11 @@ Open Scope Z_scope.
    apply Zgcdn_ok_before_fibonacci; auto.
    apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto].
    subst r; simpl.
-   destruct m as [ |m]; [elimtype False; omega| ].
-   destruct n as [ |n]; [elimtype False; omega| ].
+   destruct m as [ |m]; [exfalso; omega| ].
+   destruct n as [ |n]; [exfalso; omega| ].
    simpl; apply Zis_gcd_sym; apply Zis_gcd_0.
  Qed.
- 
+
  Lemma Zgcd_is_gcd :
    forall a b, Zis_gcd a b (Zgcd_alt a b).
  Proof.
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
index b8f8ba30..5459e693 100644
--- a/theories/ZArith/Zhints.v
+++ b/theories/ZArith/Zhints.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zhints.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (** This file centralizes the lemmas about [Z], classifying them
     according to the way they can be used in automatic search  *)
@@ -40,27 +40,27 @@ Require Import Wf_Z.
 
 (** No subgoal or smaller subgoals                                     *)
 
-Hint Resolve 
+Hint Resolve
   (** ** Reversible simplification lemmas (no loss of information)      *)
   (** Should clearly be declared as hints                               *)
-  
+
   (** Lemmas ending by eq *)
   Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)
-  
+
   (** Lemmas ending by Zgt *)
   Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *)
   Zgt_succ (* :(n:Z)`(Zs n) > n` *)
   Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *)
   Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *)
   Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *)
-  
+
   (** Lemmas ending by Zlt *)
   Zlt_succ (* :(n:Z)`n < (Zs n)` *)
   Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *)
   Zlt_pred (* :(n:Z)`(Zpred n) < n` *)
   Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *)
   Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *)
-  
+
   (** Lemmas ending by Zle *)
   Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *)
   Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *)
@@ -73,24 +73,24 @@ Hint Resolve
   Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *)
   Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *)
   Zabs_pos (* :(x:Z)`0 <= |x|` *)
-  
+
   (** ** Irreversible simplification lemmas *)
   (** Probably to be declared as hints, when no other simplification is possible *)
-  
+
   (** Lemmas ending by eq *)
   BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *)
   Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *)
-  
+
   (** Lemmas ending by Zge *)
   Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *)
   Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *)
   Zorder.Zmult_ge_compat (* :
       (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *)
-  
+
   (** Lemmas ending by Zlt *)
   Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *)
   Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *)
-  
+
   (** Lemmas ending by Zle *)
   Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *)
   Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *)
@@ -98,9 +98,9 @@ Hint Resolve
   Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *)
   Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *)
   Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *)
-  
+
   : zarith.
-  
+
 (**********************************************************************)
 (** *        Reversible lemmas relating operators                     *)
 (** Probably to be declared as hints but need to define precedences   *)
@@ -108,7 +108,7 @@ Hint Resolve
 (** ** Conversion between comparisons/predicates and arithmetic operators *)
 
 (** Lemmas ending by eq *)
-(** 
+(**
 <<
 Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0`
 Zabs_eq: (x:Z)`0 <= x`->`|x| = x`
@@ -118,7 +118,7 @@ Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1`
 *)
 
 (** Lemmas ending by Zgt *)
-(** 
+(**
 <<
 Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y`
 Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0`
@@ -126,7 +126,7 @@ Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0`
 *)
 
 (** Lemmas ending by Zlt *)
-(** 
+(**
 <<
 Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y`
 Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)`
@@ -135,7 +135,7 @@ Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n`
 *)
 
 (** Lemmas ending by Zle *)
-(** 
+(**
 <<
 Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)`
 Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y`
@@ -148,35 +148,35 @@ Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)`
 (** ** Conversion between nat comparisons and Z comparisons *)
 
 (** Lemmas ending by eq *)
-(** 
+(**
 <<
 inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)`
 >>
 *)
 
 (** Lemmas ending by Zge *)
-(** 
+(**
 <<
 inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)`
 >>
 *)
 
 (** Lemmas ending by Zgt *)
-(** 
+(**
 <<
 inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)`
 >>
 *)
 
 (** Lemmas ending by Zlt *)
-(** 
+(**
 <<
 inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)`
 >>
 *)
 
 (** Lemmas ending by Zle *)
-(** 
+(**
 <<
 inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)`
 >>
@@ -185,7 +185,7 @@ inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)`
 (** ** Conversion between comparisons *)
 
 (** Lemmas ending by Zge *)
-(** 
+(**
 <<
 not_Zlt: (x,y:Z)~`x < y`->`x >= y`
 Zle_ge: (m,n:Z)`m <= n`->`n >= m`
@@ -193,7 +193,7 @@ Zle_ge: (m,n:Z)`m <= n`->`n >= m`
 *)
 
 (** Lemmas ending by Zgt *)
-(** 
+(**
 <<
 Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
 not_Zle: (x,y:Z)~`x <= y`->`x > y`
@@ -203,7 +203,7 @@ Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n`
 *)
 
 (** Lemmas ending by Zlt *)
-(** 
+(**
 <<
 not_Zge: (x,y:Z)~`x >= y`->`x < y`
 Zgt_lt: (m,n:Z)`m > n`->`n < m`
@@ -212,7 +212,7 @@ Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)`
 *)
 
 (** Lemmas ending by Zle *)
-(** 
+(**
 <<
 Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)`
 not_Zgt: (x,y:Z)~`x > y`->`x <= y`
@@ -230,7 +230,7 @@ Zle_refl: (n,m:Z)`n = m`->`n <= m`
 (**    useful with clear precedences *)
 
 (** Lemmas ending by Zlt *)
-(** 
+(**
 <<
 Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d`
 Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d`
@@ -240,21 +240,21 @@ Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d`
 (** ** What is decreasing here ? *)
 
 (** Lemmas ending by eq *)
-(** 
+(**
 <<
 Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m`
 >>
 *)
 
 (** Lemmas ending by Zgt *)
-(** 
+(**
 <<
 Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n`
 >>
 *)
 
 (** Lemmas ending by Zlt *)
-(** 
+(**
 <<
 Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)`
 >>
@@ -266,8 +266,8 @@ Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)`
 (** ** Bottom-up simplification: should be used *)
 
 (** Lemmas ending by eq *)
-(** 
-<< 
+(**
+<<
 Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m`
 Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p`
 Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m`
@@ -276,21 +276,21 @@ Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m`
 *)
 
 (** Lemmas ending by Zgt *)
-(** 
-<< 
+(**
+<<
 Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m`
 Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m`
-Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` 
->> 
+Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n`
+>>
 *)
 
 (** Lemmas ending by Zlt *)
-(** 
-<< 
+(**
+<<
 Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m`
 Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m`
-Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` 
->> 
+Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m`
+>>
 *)
 
 (** Lemmas ending by Zle *)
@@ -301,7 +301,7 @@ Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *)
 (** ** Bottom-up irreversible (syntactic) simplification *)
 
 (** Lemmas ending by Zle *)
-(** 
+(**
 <<
 Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m`
 >>
@@ -310,78 +310,78 @@ Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m`
 (** ** Other unclearly simplifying lemmas *)
 
 (** Lemmas ending by Zeq *)
-(** 
-<< 
-Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` 
->> 
+(**
+<<
+Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0`
+>>
 *)
 
 (* Lemmas ending by Zgt *)
-(** 
-<< 
+(**
+<<
 Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0`
 >>
 *)
 
 (* Lemmas ending by Zlt *)
-(** 
-<< 
+(**
+<<
 pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y`
->> 
+>>
 *)
 
 (* Lemmas ending by Zle *)
-(** 
-<< 
+(**
+<<
 Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y`
 OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y`
->> 
+>>
 *)
 
 
 (**********************************************************************)
 (** *        Irreversible lemmas with meta-variables                  *)
-(** To be used by EAuto                                               *) 
+(** To be used by EAuto                                               *)
 
 (* Hints Immediate *)
 (** Lemmas ending by eq *)
-(** 
-<< 
+(**
+<<
 Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m`
 >>
 *)
 
 (** Lemmas ending by Zge *)
-(** 
-<< 
+(**
+<<
 Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p`
->> 
+>>
 *)
 
 (** Lemmas ending by Zgt *)
-(** 
-<< 
+(**
+<<
 Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p`
 Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p`
 Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p`
 Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p`
->> 
+>>
 *)
 
 (** Lemmas ending by Zlt *)
-(** 
-<< 
+(**
+<<
 Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p`
 Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p`
 Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p`
->> 
+>>
 *)
 
 (** Lemmas ending by Zle *)
-(** 
-<< 
+(**
+<<
 Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p`
->> 
+>>
 *)
 
 
diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
index d8f4f236..70a959c2 100644
--- a/theories/ZArith/Zlogarithm.v
+++ b/theories/ZArith/Zlogarithm.v
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zlogarithm.v 9245 2006-10-17 12:53:34Z notin $ i*)
+(*i $Id$ i*)
 
 (**********************************************************************)
-(** The integer logarithms with base 2. 
+(** The integer logarithms with base 2.
 
     There are three logarithms,
     depending on the rounding of the real 2-based logarithm:
@@ -27,7 +27,7 @@ Require Import Zpower.
 Open Local Scope Z_scope.
 
 Section Log_pos. (* Log of positive integers *)
-  
+
   (** First we build [log_inf] and [log_sup] *)
 
   Fixpoint log_inf (p:positive) : Z :=
@@ -43,31 +43,30 @@ Section Log_pos. (* Log of positive integers *)
       | xO n => Zsucc (log_sup n) (* 2n *)
       | xI n => Zsucc (Zsucc (log_inf n))	(* 2n+1 *)
     end.
-  
+
   Hint Unfold log_inf log_sup.
-  
-  (** Then we give the specifications of [log_inf] and [log_sup] 
+
+  (** Then we give the specifications of [log_inf] and [log_sup]
     and prove their validity *)
-  
+
   Hint Resolve Zle_trans: zarith.
 
   Theorem log_inf_correct :
     forall x:positive,
       0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Zsucc (log_inf x)).
+  Proof.
     simple induction x; intros; simpl in |- *;
       [ elim H; intros Hp HR; clear H; split;
 	[ auto with zarith
-	  | conditional apply Zle_le_succ; trivial rewrite
-	    two_p_S with (x := Zsucc (log_inf p));
-	    conditional trivial rewrite two_p_S;
-	      conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xI p);
+	  | rewrite two_p_S with (x := Zsucc (log_inf p)) by (apply Zle_le_succ; trivial);
+	    rewrite two_p_S by trivial;
+	    rewrite two_p_S in HR by trivial; rewrite (BinInt.Zpos_xI p);
 		omega ]
 	| elim H; intros Hp HR; clear H; split;
 	  [ auto with zarith
-	    | conditional apply Zle_le_succ; trivial rewrite
-	      two_p_S with (x := Zsucc (log_inf p));
-	      conditional trivial rewrite two_p_S;
-		conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xO p);
+	    | rewrite two_p_S with (x := Zsucc (log_inf p)) by (apply Zle_le_succ; trivial);
+	      rewrite two_p_S by trivial;
+	      rewrite two_p_S in HR by trivial; rewrite (BinInt.Zpos_xO p);
 		  omega ]
 	| unfold two_power_pos in |- *; unfold shift_pos in |- *; simpl in |- *;
 	  omega ].
@@ -101,11 +100,11 @@ Section Log_pos. (* Log of positive integers *)
 	  [ left; simpl in |- *;
 	    rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
 	      rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
-		rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); 
+		rewrite <- (proj1 Hif); rewrite <- (proj2 Hif);
 		  auto
 	    | right; simpl in |- *;
 	      rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-		rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; 
+		rewrite BinInt.Zpos_xO; unfold Zsucc in |- *;
 		  omega ]
 	| left; auto ].
   Qed.
@@ -142,7 +141,7 @@ Section Log_pos. (* Log of positive integers *)
       | xI xH => 2
       | xO y => Zsucc (log_near y)
       | xI y => Zsucc (log_near y)
-    end.    
+    end.
 
   Theorem log_near_correct1 : forall p:positive, 0 <= log_near p.
   Proof.
@@ -187,7 +186,7 @@ End Log_pos.
 Section divers.
 
   (** Number of significative digits. *)
-  
+
   Definition N_digits (x:Z) :=
     match x with
       | Zpos p => log_inf p
diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v
index 0d6fc94a..53c40ae7 100644
--- a/theories/ZArith/Zmax.v
+++ b/theories/ZArith/Zmax.v
@@ -5,162 +5,102 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zmax.v 10291 2007-11-06 02:18:53Z letouzey $ i*)
+(*i $Id$ i*)
 
-Require Import Arith_base.
-Require Import BinInt.
-Require Import Zcompare.
-Require Import Zorder.
+(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
+
+Require Export BinInt Zorder Zminmax.
 
 Open Local Scope Z_scope.
 
-(******************************************)
-(** Maximum of two binary integer numbers *)
+(** [Zmax] is now [Zminmax.Zmax]. Code that do things like
+  [unfold Zmin.Zmin] will have to be adapted, and neither
+  a [Definition] or a [Notation] here can help much. *)
 
-Definition Zmax m n :=
-  match m ?= n with
-    | Eq | Gt => m
-    | Lt => n
-  end.
 
 (** * Characterization of maximum on binary integer numbers *)
 
-Lemma Zmax_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmax n m).
-Proof.
-  intros n m P H1 H2; unfold Zmax in |- *; case (n ?= m); auto with arith.
-Qed.
-
-Lemma Zmax_case_strong : forall (n m:Z) (P:Z -> Type), 
-  (m<=n -> P n) -> (n<=m -> P m) -> P (Zmax n m).
-Proof.
-  intros n m P H1 H2; unfold Zmax, Zle, Zge in *.
-  rewrite <- (Zcompare_antisym n m) in H1.
-  destruct (n ?= m); (apply H1|| apply H2); discriminate. 
-Qed.
+Definition Zmax_case := Z.max_case.
+Definition Zmax_case_strong := Z.max_case_strong.
 
-Lemma Zmax_spec : forall x y:Z, 
-  x >= y /\ Zmax x y = x  \/
-  x < y /\ Zmax x y = y.
+Lemma Zmax_spec : forall x y,
+  x >= y /\ Zmax x y = x  \/ x < y /\ Zmax x y = y.
 Proof.
- intros; unfold Zmax, Zlt, Zge.
- destruct (Zcompare x y); [ left | right | left ]; split; auto; discriminate.
+ intros x y. rewrite Zge_iff_le. destruct (Z.max_spec x y); auto.
 Qed.
 
-Lemma Zmax_left : forall n m:Z, n>=m -> Zmax n m = n.
-Proof.
-  intros n m; unfold Zmax, Zge; destruct (n ?= m); auto.
-  intro H; elim H; auto.
-Qed.
+Lemma Zmax_left : forall n m, n>=m -> Zmax n m = n.
+Proof. intros x y. rewrite Zge_iff_le. apply Zmax_l. Qed.
 
-Lemma Zmax_right : forall n m:Z, n<=m -> Zmax n m = m.
-Proof.
-  intros n m; unfold Zmax, Zle.
-  generalize (Zcompare_Eq_eq n m).
-  destruct (n ?= m); auto.
-  intros _ H; elim H; auto.
-Qed.
+Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := Zmax_r.
 
 (** * Least upper bound properties of max *)
 
-Lemma Zle_max_l : forall n m:Z, n <= Zmax n m.
-Proof.
-  intros; apply Zmax_case_strong; auto with zarith.
-Qed.
+Definition Zle_max_l : forall n m, n <= Zmax n m := Z.le_max_l.
+Definition Zle_max_r : forall n m, m <= Zmax n m := Z.le_max_r.
 
-Notation Zmax1 := Zle_max_l (only parsing).
+Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p
+ := Z.max_lub.
 
-Lemma Zle_max_r : forall n m:Z, m <= Zmax n m.
-Proof.
-  intros; apply Zmax_case_strong; auto with zarith.
-Qed.
+Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p
+ := Z.max_lub_lt.
 
-Notation Zmax2 := Zle_max_r (only parsing).
 
-Lemma Zmax_lub : forall n m p:Z, n <= p -> m <= p -> Zmax n m <= p.
-Proof.
-  intros; apply Zmax_case; assumption.
-Qed.
+(** * Compatibility with order *)
 
-(** * Semi-lattice properties of max *)
+Definition Zle_max_compat_r : forall n m p, n <= m -> Zmax n p <= Zmax m p
+ := Z.max_le_compat_r.
 
-Lemma Zmax_idempotent : forall n:Z, Zmax n n = n.
-Proof.
-  intros; apply Zmax_case; auto.
-Qed.
+Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m
+ := Z.max_le_compat_l.
 
-Lemma Zmax_comm : forall n m:Z, Zmax n m = Zmax m n.
-Proof.
-  intros; do 2 apply Zmax_case_strong; intros; 
-    apply Zle_antisym; auto with zarith.
-Qed.
 
-Lemma Zmax_assoc : forall n m p:Z, Zmax n (Zmax m p) = Zmax (Zmax n m) p.
-Proof.
-  intros n m p; repeat apply Zmax_case_strong; intros; 
-    reflexivity || (try apply Zle_antisym); eauto with zarith.
-Qed.
+(** * Semi-lattice properties of max *)
+
+Definition Zmax_idempotent : forall n, Zmax n n = n := Z.max_id.
+Definition Zmax_comm : forall n m, Zmax n m = Zmax m n := Z.max_comm.
+Definition Zmax_assoc : forall n m p, Zmax n (Zmax m p) = Zmax (Zmax n m) p
+ := Z.max_assoc.
 
 (** * Additional properties of max *)
 
-Lemma Zmax_irreducible_inf : forall n m:Z, Zmax n m = n \/ Zmax n m = m.
-Proof.
-  intros; apply Zmax_case; auto.
-Qed.
+Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}.
+Proof. exact Z.max_dec. Qed.
+
+Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m
+ := Z.max_le.
 
-Lemma Zmax_le_prime_inf : forall n m p:Z, p <= Zmax n m -> p <= n \/ p <= m.
-Proof.
-  intros n m p; apply Zmax_case; auto.
-Qed.
 
 (** * Operations preserving max *)
 
-Lemma Zsucc_max_distr : 
-  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m).
-Proof.
-  intros n m; unfold Zmax in |- *; rewrite (Zcompare_succ_compat n m);
-    elim_compare n m; intros E; rewrite E; auto with arith.
-Qed.
+Definition Zsucc_max_distr :
+  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m)
+ := Z.succ_max_distr.
 
-Lemma Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p.
-Proof.
-  intros x y n; unfold Zmax in |- *.
-  rewrite (Zplus_comm x n); rewrite (Zplus_comm y n);
-    rewrite (Zcompare_plus_compat x y n).
-  case (x ?= y); apply Zplus_comm.
-Qed.
+Definition Zplus_max_distr_l : forall n m p:Z, Zmax (p + n) (p + m) = p + Zmax n m
+ := Z.plus_max_distr_l.
+
+Definition Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p
+ := Z.plus_max_distr_r.
 
 (** * Maximum and Zpos *)
 
-Lemma Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q).
-Proof.
-  intros; unfold Zmax, Pmax; simpl; generalize (Pcompare_Eq_eq p q).
-  destruct Pcompare; auto.
-  intro H; rewrite H; auto.
-Qed.
+Definition Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q)
+ := Z.pos_max.
 
-Lemma Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p.
-Proof.
-  intros; unfold Zmax; simpl; destruct p; simpl; auto.
-Qed.
+Definition Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p
+ := Z.pos_max_1.
 
 (** * Characterization of Pminus in term of Zminus and Zmax *)
 
-Lemma Zpos_minus : forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q).
-Proof.
-  intros.
-  case_eq (Pcompare p q Eq).
-  intros H; rewrite (Pcompare_Eq_eq _ _ H).
-  rewrite Zminus_diag.
-  unfold Zmax; simpl.
-  unfold Pminus; rewrite Pminus_mask_diag; auto.
-  intros; rewrite Pminus_Lt; auto.
-  destruct (Zmax_spec 1 (Zpos p - Zpos q)) as [(H1,H2)|(H1,H2)]; auto.
-  elimtype False; clear H2.
-  assert (H1':=Zlt_trans 0 1 _ Zlt_0_1 H1).
-  generalize (Zlt_0_minus_lt _ _ H1').
-  unfold Zlt; simpl.
-  rewrite (ZC2 _ _ H); intro; discriminate.
-  intros; simpl; rewrite H.
-  symmetry; apply Zpos_max_1.
-Qed.
+Definition Zpos_minus :
+ forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q)
+ := Zpos_minus.
 
+(* begin hide *)
+(* Compatibility *)
+Notation Zmax1 := Zle_max_l (only parsing).
+Notation Zmax2 := Zle_max_r (only parsing).
+Notation Zmax_irreducible_inf := Zmax_irreducible_dec (only parsing).
+Notation Zmax_le_prime_inf := Zmax_le_prime (only parsing).
+(* end hide *)
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
index bad40a32..5dd26fa3 100644
--- a/theories/ZArith/Zmin.v
+++ b/theories/ZArith/Zmin.v
@@ -5,142 +5,86 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zmin.v 10028 2007-07-18 22:38:06Z letouzey $ i*)
+(*i $Id$ i*)
 
-(** Initial version from Pierre Crégut (CNET, Lannion, France), 1996.
-    Further extensions by the Coq development team, with suggestions
-    from Russell O'Connor (Radbout U., Nijmegen, The Netherlands).
- *)
+(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
 
-Require Import Arith_base.
-Require Import BinInt.
-Require Import Zcompare.
-Require Import Zorder.
+Require Import BinInt Zorder Zminmax.
 
 Open Local Scope Z_scope.
 
-(**************************************)
-(** Minimum on binary integer numbers *)
+(** [Zmin] is now [Zminmax.Zmin]. Code that do things like
+  [unfold Zmin.Zmin] will have to be adapted, and neither
+  a [Definition] or a [Notation] here can help much. *)
 
-Unboxed Definition Zmin (n m:Z) :=
-  match n ?= m with
-    | Eq | Lt => n
-    | Gt => m
-  end.
 
 (** * Characterization of the minimum on binary integer numbers *)
 
-Lemma Zmin_case_strong : forall (n m:Z) (P:Z -> Type), 
-  (n<=m -> P n) -> (m<=n -> P m) -> P (Zmin n m).
-Proof.
-  intros n m P H1 H2; unfold Zmin, Zle, Zge in *.
-  rewrite <- (Zcompare_antisym n m) in H2.
-  destruct (n ?= m); (apply H1|| apply H2); discriminate. 
-Qed.
-
-Lemma Zmin_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmin n m).
-Proof.
-  intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith.
-Qed.
+Definition Zmin_case := Z.min_case.
+Definition Zmin_case_strong := Z.min_case_strong.
 
-Lemma Zmin_spec : forall x y:Z, 
-  x <= y /\ Zmin x y = x  \/
-  x > y /\ Zmin x y = y.
+Lemma Zmin_spec : forall x y,
+  x <= y /\ Zmin x y = x  \/  x > y /\ Zmin x y = y.
 Proof.
- intros; unfold Zmin, Zle, Zgt.
- destruct (Zcompare x y); [ left | left | right ]; split; auto; discriminate.
+ intros x y. rewrite Zgt_iff_lt, Z.min_comm. destruct (Z.min_spec y x); auto.
 Qed.
 
 (** * Greatest lower bound properties of min *)
 
-Lemma Zle_min_l : forall n m:Z, Zmin n m <= n.
-Proof.
-  intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
-    [ apply Zle_refl
-      | apply Zle_refl
-      | apply Zlt_le_weak; apply Zgt_lt; exact E ].
-Qed.
+Definition Zle_min_l : forall n m, Zmin n m <= n := Z.le_min_l.
+Definition Zle_min_r : forall n m, Zmin n m <= m := Z.le_min_r.
 
-Lemma Zle_min_r : forall n m:Z, Zmin n m <= m.
-Proof.
-  intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
-    [ unfold Zle in |- *; rewrite E; discriminate
-      | unfold Zle in |- *; rewrite E; discriminate
-      | apply Zle_refl ].
-Qed.
+Definition Zmin_glb : forall n m p, p <= n -> p <= m -> p <= Zmin n m
+ := Z.min_glb.
+Definition Zmin_glb_lt : forall n m p, p < n -> p < m -> p < Zmin n m
+ := Z.min_glb_lt.
 
-Lemma Zmin_glb : forall n m p:Z, p <= n -> p <= m -> p <= Zmin n m.
-Proof.
-  intros; apply Zmin_case; assumption.
-Qed.
+(** * Compatibility with order *)
 
-(** * Semi-lattice properties of min *)
+Definition Zle_min_compat_r : forall n m p, n <= m -> Zmin n p <= Zmin m p
+ := Z.min_le_compat_r.
+Definition Zle_min_compat_l : forall n m p, n <= m -> Zmin p n <= Zmin p m
+ := Z.min_le_compat_l.
 
-Lemma Zmin_idempotent : forall n:Z, Zmin n n = n.
-Proof.
-  unfold Zmin in |- *; intros; elim (n ?= n); auto.
-Qed.
+(** * Semi-lattice properties of min *)
 
+Definition Zmin_idempotent : forall n, Zmin n n = n := Z.min_id.
 Notation Zmin_n_n := Zmin_idempotent (only parsing).
-
-Lemma Zmin_comm : forall n m:Z, Zmin n m = Zmin m n.
-Proof.
-  intros n m; unfold Zmin.
-  rewrite <- (Zcompare_antisym n m).
-  assert (H:=Zcompare_Eq_eq n m).
-  destruct (n ?= m); simpl; auto.
-Qed.
-
-Lemma Zmin_assoc : forall n m p:Z, Zmin n (Zmin m p) = Zmin (Zmin n m) p.
-Proof.
-  intros n m p; repeat apply Zmin_case_strong; intros; 
-    reflexivity || (try apply Zle_antisym); eauto with zarith.
-Qed.
+Definition Zmin_comm : forall n m, Zmin n m = Zmin m n := Z.min_comm.
+Definition Zmin_assoc : forall n m p, Zmin n (Zmin m p) = Zmin (Zmin n m) p
+ := Z.min_assoc.
 
 (** * Additional properties of min *)
 
-Lemma Zmin_irreducible_inf : forall n m:Z, {Zmin n m = n} + {Zmin n m = m}.
-Proof.
-  unfold Zmin in |- *; intros; elim (n ?= m); auto.
-Qed.
+Lemma Zmin_irreducible_inf : forall n m, {Zmin n m = n} + {Zmin n m = m}.
+Proof. exact Z.min_dec. Qed.
 
-Lemma Zmin_irreducible : forall n m:Z, Zmin n m = n \/ Zmin n m = m.
-Proof.
-  intros n m; destruct (Zmin_irreducible_inf n m); [left|right]; trivial.
-Qed.
+Lemma Zmin_irreducible : forall n m, Zmin n m = n \/ Zmin n m = m.
+Proof. intros; destruct (Z.min_dec n m); auto. Qed.
 
 Notation Zmin_or := Zmin_irreducible (only parsing).
 
-Lemma Zmin_le_prime_inf : forall n m p:Z, Zmin n m <= p -> {n <= p} + {m <= p}.
-Proof.
-  intros n m p; apply Zmin_case; auto.
-Qed.
+Lemma Zmin_le_prime_inf : forall n m p, Zmin n m <= p -> {n <= p} + {m <= p}.
+Proof. intros n m p; apply Zmin_case; auto. Qed.
 
 (** * Operations preserving min *)
 
-Lemma Zsucc_min_distr : 
-  forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
-Proof.
-  intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m);
-    elim_compare n m; intros E; rewrite E; auto with arith.
-Qed.
+Definition Zsucc_min_distr :
+ forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m)
+ := Z.succ_min_distr.
 
-Notation Zmin_SS := Zsucc_min_distr (only parsing).
+Notation Zmin_SS := Z.succ_min_distr (only parsing).
 
-Lemma Zplus_min_distr_r : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p.
-Proof.
-  intros x y n; unfold Zmin in |- *.
-  rewrite (Zplus_comm x n); rewrite (Zplus_comm y n);
-    rewrite (Zcompare_plus_compat x y n).
-  case (x ?= y); apply Zplus_comm.
-Qed.
+Definition Zplus_min_distr_r :
+ forall n m p, Zmin (n + p) (m + p) = Zmin n m + p
+ := Z.plus_min_distr_r.
 
-Notation Zmin_plus := Zplus_min_distr_r (only parsing).
+Notation Zmin_plus := Z.plus_min_distr_r (only parsing).
 
 (** * Minimum and Zpos *)
 
-Lemma Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q).
-Proof.
-  intros; unfold Zmin, Pmin; simpl; destruct Pcompare; auto.
-Qed.
+Definition Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q)
+ := Z.pos_min.
+
+
 
diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v
index 95668cf8..c1657e29 100644
--- a/theories/ZArith/Zminmax.v
+++ b/theories/ZArith/Zminmax.v
@@ -5,72 +5,198 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zminmax.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-Require Import Zmin Zmax.
-Require Import BinInt Zorder.
+Require Import Orders BinInt Zcompare Zorder ZOrderedType
+ GenericMinMax.
 
-Open Local Scope Z_scope.
+(** * Maximum and Minimum of two [Z] numbers *)
 
-(** Lattice properties of min and max on Z *)
+Local Open Scope Z_scope.
 
-(** Absorption *)
+Unboxed Definition Zmax (n m:Z) :=
+  match n ?= m with
+    | Eq | Gt => n
+    | Lt => m
+  end.
 
-Lemma Zmin_max_absorption_r_r : forall n m, Zmax n (Zmin n m) = n.
+Unboxed Definition Zmin (n m:Z) :=
+  match n ?= m with
+    | Eq | Lt => n
+    | Gt => m
+  end.
+
+(** The functions [Zmax] and [Zmin] implement indeed
+    a maximum and a minimum *)
+
+Lemma Zmax_l : forall x y, y<=x -> Zmax x y = x.
+Proof.
+ unfold Zle, Zmax. intros x y. rewrite <- (Zcompare_antisym x y).
+ destruct (x ?= y); intuition.
+Qed.
+
+Lemma Zmax_r : forall x y, x<=y -> Zmax x y = y.
+Proof.
+ unfold Zle, Zmax. intros x y. generalize (Zcompare_Eq_eq x y).
+ destruct (x ?= y); intuition.
+Qed.
+
+Lemma Zmin_l : forall x y, x<=y -> Zmin x y = x.
+Proof.
+ unfold Zle, Zmin. intros x y. generalize (Zcompare_Eq_eq x y).
+ destruct (x ?= y); intuition.
+Qed.
+
+Lemma Zmin_r : forall x y, y<=x -> Zmin x y = y.
+Proof.
+ unfold Zle, Zmin. intros x y.
+ rewrite <- (Zcompare_antisym x y). generalize (Zcompare_Eq_eq x y).
+ destruct (x ?= y); intuition.
+Qed.
+
+Module ZHasMinMax <: HasMinMax Z_as_OT.
+ Definition max := Zmax.
+ Definition min := Zmin.
+ Definition max_l := Zmax_l.
+ Definition max_r := Zmax_r.
+ Definition min_l := Zmin_l.
+ Definition min_r := Zmin_r.
+End ZHasMinMax.
+
+Module Z.
+
+(** We obtain hence all the generic properties of max and min. *)
+
+Include UsualMinMaxProperties Z_as_OT ZHasMinMax.
+
+(** * Properties specific to the [Z] domain *)
+
+(** Compatibilities (consequences of monotonicity) *)
+
+Lemma plus_max_distr_l : forall n m p, Zmax (p + n) (p + m) = p + Zmax n m.
 Proof.
-  intros; apply Zmin_case_strong; intro; apply Zmax_case_strong; intro; 
-    reflexivity || apply Zle_antisym; trivial.
+ intros. apply max_monotone.
+ intros x y. apply Zplus_le_compat_l.
 Qed.
 
-Lemma Zmax_min_absorption_r_r : forall n m, Zmin n (Zmax n m) = n.
+Lemma plus_max_distr_r : forall n m p, Zmax (n + p) (m + p) = Zmax n m + p.
 Proof.
-  intros; apply Zmax_case_strong; intro; apply Zmin_case_strong; intro; 
-    reflexivity || apply Zle_antisym; trivial.
+ intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p).
+ apply plus_max_distr_l.
 Qed.
 
-(** Distributivity *)
+Lemma plus_min_distr_l : forall n m p, Zmin (p + n) (p + m) = p + Zmin n m.
+Proof.
+ intros. apply Z.min_monotone.
+ intros x y. apply Zplus_le_compat_l.
+Qed.
 
-Lemma Zmax_min_distr_r : 
-  forall n m p, Zmax n (Zmin m p) = Zmin (Zmax n m) (Zmax n p).
+Lemma plus_min_distr_r : forall n m p, Zmin (n + p) (m + p) = Zmin n m + p.
 Proof.
-  intros.
-  repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; 
-    reflexivity ||
-      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+ intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p).
+ apply plus_min_distr_l.
 Qed.
 
-Lemma Zmin_max_distr_r : 
-  forall n m p, Zmin n (Zmax m p) = Zmax (Zmin n m) (Zmin n p).
+Lemma succ_max_distr : forall n m, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m).
 Proof.
-  intros.
-  repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; 
-    reflexivity ||
-      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+ unfold Zsucc. intros. symmetry. apply plus_max_distr_r.
 Qed.
 
-(** Modularity *)
+Lemma succ_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
+Proof.
+ unfold Zsucc. intros. symmetry. apply plus_min_distr_r.
+Qed.
 
-Lemma Zmax_min_modular_r :
-  forall n m p, Zmax n (Zmin m (Zmax n p)) = Zmin (Zmax n m) (Zmax n p).
+Lemma pred_max_distr : forall n m, Zpred (Zmax n m) = Zmax (Zpred n) (Zpred m).
 Proof.
-  intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros;
-    reflexivity ||
-      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+ unfold Zpred. intros. symmetry. apply plus_max_distr_r.
 Qed.
 
-Lemma Zmin_max_modular_r :
-  forall n m p, Zmin n (Zmax m (Zmin n p)) = Zmax (Zmin n m) (Zmin n p).
+Lemma pred_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
 Proof.
-  intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros;
-    reflexivity ||
-      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+ unfold Zpred. intros. symmetry. apply plus_min_distr_r.
 Qed.
 
-(** Disassociativity *)
+(** Anti-monotonicity swaps the role of [min] and [max] *)
+
+Lemma opp_max_distr : forall n m : Z, -(Zmax n m) = Zmin (- n) (- m).
+Proof.
+ intros. symmetry. apply min_max_antimonotone.
+ intros x x'. red. red. rewrite <- Zcompare_opp; auto.
+Qed.
+
+Lemma opp_min_distr : forall n m : Z, - (Zmin n m) = Zmax (- n) (- m).
+Proof.
+ intros. symmetry. apply max_min_antimonotone.
+ intros x x'. red. red. rewrite <- Zcompare_opp; auto.
+Qed.
 
-Lemma max_min_disassoc : forall n m p, Zmin n (Zmax m p) <= Zmax (Zmin n m) p.
+Lemma minus_max_distr_l : forall n m p, Zmax (p - n) (p - m) = p - Zmin n m.
 Proof.
-  intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros;
-    apply Zle_refl || (assumption || eapply Zle_trans; eassumption).
+ unfold Zminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
 Qed.
 
+Lemma minus_max_distr_r : forall n m p, Zmax (n - p) (m - p) = Zmax n m - p.
+Proof.
+ unfold Zminus. intros. apply plus_max_distr_r.
+Qed.
+
+Lemma minus_min_distr_l : forall n m p, Zmin (p - n) (p - m) = p - Zmax n m.
+Proof.
+ unfold Zminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
+Qed.
+
+Lemma minus_min_distr_r : forall n m p, Zmin (n - p) (m - p) = Zmin n m - p.
+Proof.
+ unfold Zminus. intros. apply plus_min_distr_r.
+Qed.
+
+(** Compatibility with [Zpos] *)
+
+Lemma pos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q).
+Proof.
+ intros; unfold Zmax, Pmax; simpl; generalize (Pcompare_Eq_eq p q).
+ destruct Pcompare; auto.
+ intro H; rewrite H; auto.
+Qed.
+
+Lemma pos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q).
+Proof.
+ intros; unfold Zmin, Pmin; simpl; generalize (Pcompare_Eq_eq p q).
+ destruct Pcompare; auto.
+Qed.
+
+Lemma pos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p.
+Proof.
+  intros; unfold Zmax; simpl; destruct p; simpl; auto.
+Qed.
+
+Lemma pos_min_1 : forall p, Zmin 1 (Zpos p) = 1.
+Proof.
+  intros; unfold Zmax; simpl; destruct p; simpl; auto.
+Qed.
+
+End Z.
+
+
+(** * Characterization of Pminus in term of Zminus and Zmax *)
+
+Lemma Zpos_minus : forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q).
+Proof.
+  intros; simpl. destruct (Pcompare p q Eq) as [ ]_eqn:H.
+  rewrite (Pcompare_Eq_eq _ _ H).
+  unfold Pminus; rewrite Pminus_mask_diag; reflexivity.
+  rewrite Pminus_Lt; auto.
+  symmetry. apply Z.pos_max_1.
+Qed.
+
+
+(*begin hide*)
+(* Compatibility with names of the old Zminmax file *)
+Notation Zmin_max_absorption_r_r := Z.min_max_absorption (only parsing).
+Notation Zmax_min_absorption_r_r := Z.max_min_absorption (only parsing).
+Notation Zmax_min_distr_r := Z.max_min_distr (only parsing).
+Notation Zmin_max_distr_r := Z.min_max_distr (only parsing).
+Notation Zmax_min_modular_r := Z.max_min_modular (only parsing).
+Notation Zmin_max_modular_r := Z.min_max_modular (only parsing).
+Notation max_min_disassoc := Z.max_min_disassoc (only parsing).
+(*end hide*)
\ No newline at end of file
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
index 0634096e..178ae5f1 100644
--- a/theories/ZArith/Zmisc.v
+++ b/theories/ZArith/Zmisc.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zmisc.v 11072 2008-06-08 16:13:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Wf_nat.
 Require Import BinInt.
@@ -20,7 +20,7 @@ Open Local Scope Z_scope.
 
 (** [n]th iteration of the function [f] *)
 
-Fixpoint iter_pos (n:positive) (A:Type) (f:A -> A) (x:A) {struct n} : A :=
+Fixpoint iter_pos (n:positive) (A:Type) (f:A -> A) (x:A) : A :=
   match n with
     | xH => f x
     | xO n' => iter_pos n' A f (iter_pos n' A f x)
@@ -37,22 +37,29 @@ Definition iter (n:Z) (A:Type) (f:A -> A) (x:A) :=
 Theorem iter_nat_of_P :
   forall (p:positive) (A:Type) (f:A -> A) (x:A),
     iter_pos p A f x = iter_nat (nat_of_P p) A f x.
-Proof.    
+Proof.
   intro n; induction n as [p H| p H| ];
     [ intros; simpl in |- *; rewrite (H A f x);
-      rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
+      rewrite (H A f (iter_nat (nat_of_P p) A f x));
 	rewrite (ZL6 p); symmetry  in |- *; apply f_equal with (f := f);
 	  apply iter_nat_plus
       | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x);
-	rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
+	rewrite (H A f (iter_nat (nat_of_P p) A f x));
 	  rewrite (ZL6 p); symmetry  in |- *; apply iter_nat_plus
       | simpl in |- *; auto with arith ].
 Qed.
 
+Lemma iter_nat_of_Z : forall n A f x, 0 <= n ->
+  iter n A f x = iter_nat (Zabs_nat n) A f x.
+intros n A f x; case n; auto.
+intros p _; unfold iter, Zabs_nat; apply iter_nat_of_P.
+intros p abs; case abs; trivial.
+Qed.
+
 Theorem iter_pos_plus :
   forall (p q:positive) (A:Type) (f:A -> A) (x:A),
     iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x).
-Proof.    
+Proof.
   intros n m; intros.
   rewrite (iter_nat_of_P m A f x).
   rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)).
@@ -61,14 +68,14 @@ Proof.
   apply iter_nat_plus.
 Qed.
 
-(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], 
+(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv],
     then the iterates of [f] also preserve it. *)
 
 Theorem iter_nat_invariant :
   forall (n:nat) (A:Type) (f:A -> A) (Inv:A -> Prop),
     (forall x:A, Inv x -> Inv (f x)) ->
     forall x:A, Inv x -> Inv (iter_nat n A f x).
-Proof.    
+Proof.
   simple induction n; intros;
     [ trivial with arith
       | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H;
@@ -79,6 +86,6 @@ Theorem iter_pos_invariant :
   forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop),
     (forall x:A, Inv x -> Inv (f x)) ->
     forall x:A, Inv x -> Inv (iter_pos p A f x).
-Proof.    
+Proof.
   intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith.
 Qed.
diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v
index c5b5edc1..dfd9b545 100644
--- a/theories/ZArith/Znat.v
+++ b/theories/ZArith/Znat.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znat.v 10726 2008-03-28 18:15:23Z notin $ i*)
+(*i $Id$ i*)
 
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
@@ -57,15 +58,15 @@ Proof.
 	| discriminate H0
 	| discriminate H0
 	| simpl in H0; injection H0;
-	  do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; 
+	  do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ;
 	    intros E; rewrite E; auto with arith ].
-Qed. 
+Qed.
 
 Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m.
 Proof.
   intros x y H.
   destruct (eq_nat_dec x y) as [H'|H']; auto.
-  elimtype False.
+  exfalso.
   exact (inj_neq _ _ H' H).
 Qed.
 
@@ -90,7 +91,7 @@ Qed.
 
 Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
 Proof.
-  intros x y H; apply Zgt_lt; apply Zlt_succ_gt; rewrite <- inj_S; apply inj_le;
+  intros x y H; apply Zgt_lt; apply Zle_succ_gt; rewrite <- inj_S; apply inj_le;
     exact H.
 Qed.
 
@@ -110,7 +111,7 @@ Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat.
 Proof.
   intros x y H.
   destruct (le_lt_dec x y) as [H0|H0]; auto.
-  elimtype False.
+  exfalso.
   assert (H1:=inj_lt _ _ H0).
   red in H; red in H1.
   rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto.
@@ -120,7 +121,7 @@ Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat.
 Proof.
   intros x y H.
   destruct (le_lt_dec y x) as [H0|H0]; auto.
-  elimtype False.
+  exfalso.
   assert (H1:=inj_le _ _ H0).
   red in H; red in H1.
   rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto.
@@ -130,7 +131,7 @@ Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat.
 Proof.
   intros x y H.
   destruct (le_lt_dec y x) as [H0|H0]; auto.
-  elimtype False.
+  exfalso.
   assert (H1:=inj_gt _ _ H0).
   red in H; red in H1.
   rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto.
@@ -140,7 +141,7 @@ Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat.
 Proof.
   intros x y H.
   destruct (le_lt_dec x y) as [H0|H0]; auto.
-  elimtype False.
+  exfalso.
   assert (H1:=inj_ge _ _ H0).
   red in H; red in H1.
   rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto.
@@ -169,7 +170,7 @@ Proof.
 Qed.
 
 (** Injection and usual operations *)
- 
+
 Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
 Proof.
   intro x; induction x as [| n H]; intro y; destruct y as [| m];
@@ -186,7 +187,7 @@ Proof.
   intro x; induction x as [| n H];
     [ simpl in |- *; trivial with arith
       | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H;
-	rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; 
+	rewrite <- inj_plus; simpl in |- *; rewrite plus_comm;
 	  trivial with arith ].
 Qed.
 
@@ -195,17 +196,17 @@ Theorem inj_minus1 :
 Proof.
   intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *;
     rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus;
-      rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; 
+      rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r;
         trivial with arith.
 Qed.
- 
+
 Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
 Proof.
   intros x y H; rewrite not_le_minus_0;
     [ trivial with arith | apply gt_not_le; assumption ].
 Qed.
 
-Theorem inj_minus : forall n m:nat, 
+Theorem inj_minus : forall n m:nat,
  Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m).
 Proof.
  intros.
@@ -225,7 +226,7 @@ Proof.
  unfold Zminus; rewrite H'; auto.
 Qed.
 
-Theorem inj_min : forall n m:nat, 
+Theorem inj_min : forall n m:nat,
   Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m).
 Proof.
  induction n; destruct m; try (compute; auto; fail).
@@ -234,7 +235,7 @@ Proof.
  rewrite <- Zsucc_min_distr; f_equal; auto.
 Qed.
 
-Theorem inj_max : forall n m:nat, 
+Theorem inj_max : forall n m:nat,
   Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m).
 Proof.
  induction n; destruct m; try (compute; auto; fail).
@@ -269,11 +270,11 @@ Proof.
   intros x; exists (Z_of_nat x); split;
     [ trivial with arith
       | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r;
-	unfold Zle in |- *; elim x; intros; simpl in |- *; 
+	unfold Zle in |- *; elim x; intros; simpl in |- *;
           discriminate ].
 Qed.
 
-Lemma Zpos_P_of_succ_nat : forall n:nat, 
+Lemma Zpos_P_of_succ_nat : forall n:nat,
  Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n).
 Proof.
   intros.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
index 9be372a3..2a2751c9 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znumtheory.v 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith_base.
 Require Import ZArithRing.
@@ -15,13 +15,13 @@ Require Import Zdiv.
 Require Import Wf_nat.
 Open Local Scope Z_scope.
 
-(** This file contains some notions of number theory upon Z numbers: 
+(** This file contains some notions of number theory upon Z numbers:
      - a divisibility predicate [Zdivide]
      - a gcd predicate [gcd]
      - Euclid algorithm [euclid]
      - a relatively prime predicate [rel_prime]
      - a prime predicate [prime]
-     - an efficient [Zgcd] function 
+     - an efficient [Zgcd] function
 *)
 
 (** * Divisibility *)
@@ -171,7 +171,7 @@ Proof.
   rewrite H1 in H0; left; omega.
   rewrite H1 in H0; right; omega.
 Qed.
- 
+
 Theorem Zdivide_trans: forall a b c, (a | b) -> (b | c) ->  (a | c).
 Proof.
   intros a b c [d H1] [e H2]; exists (d * e); auto with zarith.
@@ -201,19 +201,17 @@ Qed.
 
 (** [Zdivide] can be expressed using [Zmod]. *)
 
-Lemma Zmod_divide : forall a b:Z, b > 0 -> a mod b = 0 -> (b | a).
+Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a).
 Proof.
-  intros a b H H0.
-  apply Zdivide_intro with (a / b).
-  pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H).
-  rewrite H0; ring.
+ intros a b NZ EQ.
+ apply Zdivide_intro with (a/b).
+ rewrite (Z_div_mod_eq_full a b NZ) at 1.
+ rewrite EQ; ring.
 Qed.
 
-Lemma Zdivide_mod : forall a b:Z, b > 0 -> (b | a) -> a mod b = 0.
+Lemma Zdivide_mod : forall a b, (b | a) -> a mod b = 0.
 Proof.
-  intros a b; simple destruct 2; intros; subst.
-  change (q * b) with (0 + q * b) in |- *.
-  rewrite Z_mod_plus; auto.
+  intros a b (c,->); apply Z_mod_mult.
 Qed.
 
 (** [Zdivide] is hence decidable *)
@@ -222,7 +220,7 @@ Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}.
 Proof.
   intros a b; elim (Ztrichotomy_inf a 0).
   (* a<0 *)
-  intros H; elim H; intros. 
+  intros H; elim H; intros.
   case (Z_eq_dec (b mod - a) 0).
   left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith.
   intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
@@ -236,7 +234,7 @@ Proof.
   intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
 Qed.
 
-Theorem Zdivide_Zdiv_eq: forall a b : Z, 
+Theorem Zdivide_Zdiv_eq: forall a b : Z,
  0 < a -> (a | b) ->  b = a * (b / a).
 Proof.
   intros a b Hb Hc.
@@ -244,7 +242,7 @@ Proof.
   rewrite (Zdivide_mod b a); auto with zarith.
 Qed.
 
-Theorem Zdivide_Zdiv_eq_2: forall a b c : Z, 
+Theorem Zdivide_Zdiv_eq_2: forall a b c : Z,
  0 < a -> (a | b) -> (c * b)/a = c * (b / a).
 Proof.
   intros a b c H1 H2.
@@ -252,7 +250,7 @@ Proof.
   rewrite Hz; rewrite Zmult_assoc.
   repeat rewrite Z_div_mult; auto with zarith.
 Qed.
- 
+
 Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) ->  (a | b).
 Proof.
   intros a b [x H]; subst b.
@@ -260,7 +258,7 @@ Proof.
   exists (- x); ring.
   exists x; ring.
 Qed.
- 
+
 Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) ->  (Zabs a | b).
 Proof.
   intros a b [x H]; subst b.
@@ -269,7 +267,7 @@ Proof.
   exists x; ring.
 Qed.
 
-Theorem Zdivide_le: forall a b : Z, 
+Theorem Zdivide_le: forall a b : Z,
  0 <= a -> 0 < b -> (a | b) ->  a <= b.
 Proof.
   intros a b H1 H2 [q H3]; subst b.
@@ -280,7 +278,7 @@ Proof.
   intros H4; subst q; omega.
 Qed.
 
-Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, 
+Theorem Zdivide_Zdiv_lt_pos: forall a b : Z,
  1 < a -> 0 < b -> (a | b) ->  0 < b / a < b .
 Proof.
   intros a b H1 H2 H3; split.
@@ -307,7 +305,7 @@ Proof.
   rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith.
 Qed.
 
-Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> 
+Lemma Zmod_divide_minus: forall a b c : Z, 0 < b ->
  a mod b = c -> (b | a - c).
 Proof.
   intros a b c H H1; apply Zmod_divide; auto with zarith.
@@ -317,7 +315,7 @@ Proof.
   subst; apply Z_mod_lt; auto with zarith.
 Qed.
 
-Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b -> 
+Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b ->
  (b | a - c) -> a mod b = c.
 Proof.
   intros a b c (H1, H2) H3; assert (0 < b); try apply Zle_lt_trans with c; auto.
@@ -328,9 +326,9 @@ Proof.
 Qed.
 
 (** * Greatest common divisor (gcd). *)
-   
-(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] 
-     expressing that [d] is a gcd of [a] and [b]. 
+
+(** There is no unicity of the gcd; hence we define the predicate [gcd a b d]
+     expressing that [d] is a gcd of [a] and [b].
      (We show later that the [gcd] is actually unique if we discard its sign.) *)
 
 Inductive Zis_gcd (a b d:Z) : Prop :=
@@ -379,8 +377,8 @@ Proof.
 Qed.
 
 Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
- 
-Theorem Zis_gcd_unique: forall a b c d : Z, 
+
+Theorem Zis_gcd_unique: forall a b c d : Z,
  Zis_gcd a b c -> Zis_gcd a b d ->  c = d \/ c = (- d).
 Proof.
 intros a b c d H1 H2.
@@ -431,7 +429,7 @@ Section extended_euclid_algorithm.
   (** The recursive part of Euclid's algorithm uses well-founded
       recursion of non-negative integers. It maintains 6 integers
       [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
-      [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. 
+      [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)].
       *)
 
   Lemma euclid_rec :
@@ -455,8 +453,8 @@ Section extended_euclid_algorithm.
     replace (u3 - q * x) with (u3 mod x).
     apply Z_mod_lt; omega.
     assert (xpos : x > 0). omega.
-    generalize (Z_div_mod_eq u3 x xpos). 
-    unfold q in |- *. 
+    generalize (Z_div_mod_eq u3 x xpos).
+    unfold q in |- *.
     intro eq; pattern u3 at 2 in |- *; rewrite eq; ring.
     apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
     tauto.
@@ -531,7 +529,7 @@ Proof.
   rewrite H6; rewrite H7; ring.
   ring.
 Qed.
-  
+
 
 (** * Relative primality *)
 
@@ -612,16 +610,16 @@ Proof.
   intros a b g; intros.
   assert (g <> 0).
   intro.
-  elim H1; intros. 
+  elim H1; intros.
   elim H4; intros.
   rewrite H2 in H6; subst b; omega.
   unfold rel_prime in |- *.
   destruct H1.
   destruct H1 as (a',H1).
   destruct H3 as (b',H3).
-  replace (a/g) with a'; 
+  replace (a/g) with a';
     [|rewrite H1; rewrite Z_div_mult; auto with zarith].
-  replace (b/g) with b'; 
+  replace (b/g) with b';
     [|rewrite H3; rewrite Z_div_mult; auto with zarith].
   constructor.
   exists a'; auto with zarith.
@@ -643,7 +641,7 @@ Proof.
   red; apply Zis_gcd_sym; auto with zarith.
 Qed.
 
-Theorem rel_prime_div: forall p q r, 
+Theorem rel_prime_div: forall p q r,
  rel_prime p q -> (r | p) -> rel_prime r q.
 Proof.
   intros p q r H (u, H1); subst.
@@ -670,7 +668,7 @@ Proof.
   exists 1; auto with zarith.
 Qed.
 
-Theorem rel_prime_mod: forall p q, 0 < q -> 
+Theorem rel_prime_mod: forall p q, 0 < q ->
  rel_prime p q -> rel_prime (p mod q) q.
 Proof.
   intros p q H H0.
@@ -683,7 +681,7 @@ Proof.
   pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith.
 Qed.
 
-Theorem rel_prime_mod_rev: forall p q, 0 < q -> 
+Theorem rel_prime_mod_rev: forall p q, 0 < q ->
  rel_prime (p mod q) q -> rel_prime p q.
 Proof.
   intros p q H H0.
@@ -715,7 +713,7 @@ Proof.
   assert
     (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
   assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ].
-  generalize H3. 
+  generalize H3.
   pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *;
     apply Zabs_ind; intros; omega.
   intuition idtac.
@@ -785,7 +783,7 @@ Proof.
   intros H1; absurd (1 < 1); auto with zarith.
   inversion H1; auto.
 Qed.
- 
+
 Lemma prime_2: prime 2.
 Proof.
   apply prime_intro; auto with zarith.
@@ -795,7 +793,7 @@ Proof.
   subst n; red; auto with zarith.
   apply Zis_gcd_intro; auto with zarith.
 Qed.
- 
+
 Theorem prime_3: prime 3.
 Proof.
   apply prime_intro; auto with zarith.
@@ -812,7 +810,7 @@ Proof.
   subst n; red; auto with zarith.
   apply Zis_gcd_intro; auto with zarith.
 Qed.
- 
+
 Theorem prime_ge_2: forall p, prime p ->  2 <= p.
 Proof.
   intros p Hp; inversion Hp; auto with zarith.
@@ -820,7 +818,7 @@ Qed.
 
 Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)).
 
-Theorem prime_alt: 
+Theorem prime_alt:
  forall p, prime' p <-> prime p.
 Proof.
   split; destruct 1; intros.
@@ -848,7 +846,7 @@ Proof.
   apply Zis_gcd_intro; auto with zarith.
   apply H0; auto with zarith.
 Qed.
- 
+
 Theorem square_not_prime: forall a, ~ prime (a * a).
 Proof.
   intros a Ha.
@@ -864,10 +862,10 @@ Proof.
   exists b; auto.
 Qed.
 
-Theorem prime_div_prime: forall p q, 
+Theorem prime_div_prime: forall p q,
  prime p -> prime q -> (p | q) -> p = q.
 Proof.
-  intros p q H H1 H2; 
+  intros p q H H1 H2;
   assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
   assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
   case prime_divisors with (2 := H2); auto.
@@ -878,10 +876,10 @@ Proof.
 Qed.
 
 
-(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose 
+(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose
   here a binary version of [Zgcd], faster and executable within Coq.
 
-   Algorithm: 
+   Algorithm:
 
    gcd 0 b = b
    gcd a 0 = a
@@ -889,23 +887,23 @@ Qed.
    gcd (2a+1) (2b) = gcd (2a+1) b
    gcd (2a) (2b+1) = gcd a (2b+1)
    gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1)
-                    or gcd (a-b) (2*b+1), depending on whether a<b 
-*)   
+                    or gcd (a-b) (2*b+1), depending on whether a<b
+*)
 
 Open Scope positive_scope.
 
-Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive := 
-  match n with 
+Fixpoint Pgcdn (n: nat) (a b : positive) : positive :=
+  match n with
     | O => 1
-    | S n => 
-      match a,b with 
-	| xH, _ => 1 
+    | S n =>
+      match a,b with
+	| xH, _ => 1
 	| _, xH => 1
 	| xO a, xO b => xO (Pgcdn n a b)
 	| a, xO b => Pgcdn n a b
 	| xO a, b => Pgcdn n a b
-	| xI a', xI b' => 
-          match Pcompare a' b' Eq with 
+	| xI a', xI b' =>
+          match Pcompare a' b' Eq with
 	    | Eq => a
 	    | Lt => Pgcdn  n (b'-a') a
 	    | Gt => Pgcdn n (a'-b') b
@@ -919,7 +917,7 @@ Close Scope positive_scope.
 
 Definition Zgcd (a b : Z) : Z :=
   match a,b with
-    | Z0, _ => Zabs b 
+    | Z0, _ => Zabs b
     | _, Z0 => Zabs a
     | Zpos a, Zpos b => Zpos (Pgcd a b)
     | Zpos a, Zneg b => Zpos (Pgcd a b)
@@ -932,8 +930,8 @@ Proof.
   unfold Zgcd; destruct a; destruct b; auto with zarith.
 Qed.
 
-Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> 
-  Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. 
+Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g ->
+  Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g.
 Proof.
   intros.
   destruct H.
@@ -951,7 +949,7 @@ Proof.
   omega.
 Qed.
 
-Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> 
+Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat ->
   Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)).
 Proof.
   intro n; pattern n; apply lt_wf_ind; clear n; intros.
@@ -977,7 +975,7 @@ Proof.
   rewrite (Zpos_minus_morphism _ _ H1).
   assert (0 < Zpos a) by (compute; auto).
   omega.
-  omega.  
+  omega.
   rewrite Zpos_xO; do 2 rewrite Zpos_xI.
   rewrite Zpos_minus_morphism; auto.
   omega.
@@ -995,7 +993,7 @@ Proof.
   assert (0 < Zpos b) by (compute; auto).
   omega.
   rewrite ZC4; rewrite H1; auto.
-  omega.  
+  omega.
   rewrite Zpos_xO; do 2 rewrite Zpos_xI.
   rewrite Zpos_minus_morphism; auto.
   omega.
@@ -1062,7 +1060,7 @@ Proof.
   split; [apply Zgcd_is_gcd  | apply Zgcd_is_pos].
 Qed.
 
-Theorem Zdivide_Zgcd: forall p q r : Z, 
+Theorem Zdivide_Zgcd: forall p q r : Z,
  (p | q) -> (p | r) -> (p | Zgcd q r).
 Proof.
   intros p q r H1 H2.
@@ -1071,7 +1069,7 @@ Proof.
   inversion_clear H3; auto.
 Qed.
 
-Theorem Zis_gcd_gcd: forall a b c : Z, 
+Theorem Zis_gcd_gcd: forall a b c : Z,
  0 <= c ->  Zis_gcd a b c -> Zgcd a b = c.
 Proof.
   intros a b c H1 H2.
@@ -1103,7 +1101,7 @@ Proof.
   rewrite H1; ring.
 Qed.
 
-Theorem Zgcd_div_swap0 : forall a b : Z, 
+Theorem Zgcd_div_swap0 : forall a b : Z,
  0 < Zgcd a b ->
  0 < b ->
  (a / Zgcd a b) * b = a * (b/Zgcd a b).
@@ -1116,7 +1114,7 @@ Proof.
   rewrite <- Zdivide_Zdiv_eq; auto.
 Qed.
 
-Theorem Zgcd_div_swap : forall a b c : Z, 
+Theorem Zgcd_div_swap : forall a b c : Z,
  0 < Zgcd a b ->
  0 < b ->
  (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b).
@@ -1131,7 +1129,43 @@ Proof.
   rewrite <- Zdivide_Zdiv_eq; auto.
 Qed.
 
-Theorem Zgcd_1_rel_prime : forall a b, 
+Lemma Zgcd_comm : forall a b, Zgcd a b = Zgcd b a.
+Proof.
+  intros.
+  apply Zis_gcd_gcd.
+  apply Zgcd_is_pos.
+  apply Zis_gcd_sym.
+  apply Zgcd_is_gcd.
+Qed.
+
+Lemma Zgcd_ass : forall a b c, Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c).
+Proof.
+  intros.
+  apply Zis_gcd_gcd.
+  apply Zgcd_is_pos.
+  destruct (Zgcd_is_gcd a b).
+  destruct (Zgcd_is_gcd b c).
+  destruct (Zgcd_is_gcd a (Zgcd b c)).
+  constructor; eauto using Zdivide_trans.
+Qed.
+
+Lemma Zgcd_Zabs : forall a b, Zgcd (Zabs a) b = Zgcd a b.
+Proof.
+  destruct a; simpl; auto.
+Qed.
+
+Lemma Zgcd_0 : forall a, Zgcd a 0 = Zabs a.
+Proof.
+  destruct a; simpl; auto.
+Qed.
+
+Lemma Zgcd_1 : forall a, Zgcd a 1 = 1.
+Proof.
+  intros; apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1.
+Qed.
+Hint Resolve Zgcd_0 Zgcd_1 : zarith.
+
+Theorem Zgcd_1_rel_prime : forall a b,
  Zgcd a b = 1 <-> rel_prime a b.
 Proof.
   unfold rel_prime; split; intro H.
@@ -1142,7 +1176,7 @@ Proof.
   generalize (Zgcd_is_pos a b); auto with zarith.
 Qed.
 
-Definition rel_prime_dec: forall a b, 
+Definition rel_prime_dec: forall a b,
  { rel_prime a b }+{ ~ rel_prime a b }.
 Proof.
   intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1.
@@ -1156,10 +1190,10 @@ Definition prime_dec_aux:
   { exists n, 1 < n < m  /\ ~ rel_prime n p }.
 Proof.
   intros p m.
-  case (Z_lt_dec 1 m); intros H1; 
-   [ | left; intros; elimtype False; omega ].
+  case (Z_lt_dec 1 m); intros H1;
+   [ | left; intros; exfalso; omega ].
   pattern m; apply natlike_rec; auto with zarith.
-  left; intros; elimtype False; omega.
+  left; intros; exfalso; omega.
   intros x Hx IH; destruct IH as [F|E].
   destruct (rel_prime_dec x p) as [Y|N].
   left; intros n [HH1 HH2].
@@ -1221,34 +1255,34 @@ Qed.
 
 Open Scope positive_scope.
 
-Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) := 
-  match n with 
+Fixpoint Pggcdn (n: nat) (a b : positive) : (positive*(positive*positive)) :=
+  match n with
     | O => (1,(a,b))
-    | S n => 
-      match a,b with 
-	| xH, b => (1,(1,b)) 
+    | S n =>
+      match a,b with
+	| xH, b => (1,(1,b))
 	| a, xH => (1,(a,1))
-	| xO a, xO b => 
-           let (g,p) := Pggcdn n a b in 
+	| xO a, xO b =>
+           let (g,p) := Pggcdn n a b in
            (xO g,p)
-	| a, xO b => 
-           let (g,p) := Pggcdn n a b in 
-           let (aa,bb) := p in 
+	| a, xO b =>
+           let (g,p) := Pggcdn n a b in
+           let (aa,bb) := p in
            (g,(aa, xO bb))
-	| xO a, b => 
-           let (g,p) := Pggcdn n a b in 
-           let (aa,bb) := p in 
+	| xO a, b =>
+           let (g,p) := Pggcdn n a b in
+           let (aa,bb) := p in
            (g,(xO aa, bb))
-	| xI a', xI b' => 
-           match Pcompare a' b' Eq with 
+	| xI a', xI b' =>
+           match Pcompare a' b' Eq with
 	     | Eq => (a,(1,1))
-	     | Lt => 
-	        let (g,p) := Pggcdn n (b'-a') a in 
-	        let (ba,aa) := p in 
+	     | Lt =>
+	        let (g,p) := Pggcdn n (b'-a') a in
+	        let (ba,aa) := p in
 	        (g,(aa, aa + xO ba))
-	     | Gt => 
-		let (g,p) := Pggcdn n (a'-b') b in 
-		let (ab,bb) := p in 
+	     | Gt =>
+		let (g,p) := Pggcdn n (a'-b') b in
+		let (ab,bb) := p in
 		(g,(bb+xO ab, bb))
 	   end
       end
@@ -1260,28 +1294,28 @@ Open Scope Z_scope.
 
 Definition Zggcd (a b : Z) : Z*(Z*Z) :=
   match a,b with
-    | Z0, _ => (Zabs b,(0, Zsgn b)) 
+    | Z0, _ => (Zabs b,(0, Zsgn b))
     | _, Z0 => (Zabs a,(Zsgn a, 0))
-    | Zpos a, Zpos b => 
-       let (g,p) := Pggcd a b in 
-       let (aa,bb) := p in 
+    | Zpos a, Zpos b =>
+       let (g,p) := Pggcd a b in
+       let (aa,bb) := p in
        (Zpos g, (Zpos aa, Zpos bb))
-    | Zpos a, Zneg b => 
-       let (g,p) := Pggcd a b in 
-       let (aa,bb) := p in 
+    | Zpos a, Zneg b =>
+       let (g,p) := Pggcd a b in
+       let (aa,bb) := p in
        (Zpos g, (Zpos aa, Zneg bb))
-    | Zneg a, Zpos b => 
-       let (g,p) := Pggcd a b in 
-       let (aa,bb) := p in 
+    | Zneg a, Zpos b =>
+       let (g,p) := Pggcd a b in
+       let (aa,bb) := p in
        (Zpos g, (Zneg aa, Zpos bb))
     | Zneg a, Zneg b =>
-       let (g,p) := Pggcd a b in 
-       let (aa,bb) := p in 
+       let (g,p) := Pggcd a b in
+       let (aa,bb) := p in
        (Zpos g, (Zneg aa, Zneg bb))
   end.
 
 
-Lemma Pggcdn_gcdn : forall n a b, 
+Lemma Pggcdn_gcdn : forall n a b,
   fst (Pggcdn n a b) = Pgcdn n a b.
 Proof.
   induction n.
@@ -1302,15 +1336,15 @@ Qed.
 
 Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
 Proof.
-  destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; 
+  destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd;
     destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto.
 Qed.
 
 Open Scope positive_scope.
 
-Lemma Pggcdn_correct_divisors : forall n a b, 
-  let (g,p) := Pggcdn n a b in 
-  let (aa,bb):=p in 
+Lemma Pggcdn_correct_divisors : forall n a b,
+  let (g,p) := Pggcdn n a b in
+  let (aa,bb):=p in
   (a=g*aa) /\ (b=g*bb).
 Proof.
   induction n.
@@ -1337,7 +1371,7 @@ Proof.
   rewrite <- H1; rewrite <- H0.
   simpl; f_equal; symmetry.
   apply Pplus_minus; auto.
-  (* Then... *) 
+  (* Then... *)
   generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl.
   intros (H0,H1); split; auto.
   rewrite Pmult_xO_permute_r; rewrite H1; auto.
@@ -1348,9 +1382,9 @@ Proof.
   intros (H0,H1); split; subst; auto.
 Qed.
 
-Lemma Pggcd_correct_divisors : forall a b, 
-  let (g,p) := Pggcd a b in 
-  let (aa,bb):=p in 
+Lemma Pggcd_correct_divisors : forall a b,
+  let (g,p) := Pggcd a b in
+  let (aa,bb):=p in
   (a=g*aa) /\ (b=g*bb).
 Proof.
   intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b).
@@ -1358,17 +1392,17 @@ Qed.
 
 Close Scope positive_scope.
 
-Lemma Zggcd_correct_divisors : forall a b, 
-  let (g,p) := Zggcd a b in 
-  let (aa,bb):=p in 
+Lemma Zggcd_correct_divisors : forall a b,
+  let (g,p) := Zggcd a b in
+  let (aa,bb):=p in
   (a=g*aa) /\ (b=g*bb).
 Proof.
-  destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; 
-    generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); 
+  destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto];
+    generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb));
       destruct 1; subst; auto.
 Qed.
 
-Theorem Zggcd_opp: forall x y, 
+Theorem Zggcd_opp: forall x y,
   Zggcd (-x) y = let (p1,p) := Zggcd x y in
                  let (p2,p3) := p in
                  (p1,(-p2,p3)).
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 73808f92..511c364b 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,9 +6,9 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zorder.v 12888 2010-03-28 19:35:03Z herbelin $ i*)
+(*i $Id$ i*)
 
-(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
 Require Import BinPos.
 Require Import BinInt.
@@ -49,7 +50,7 @@ Proof.
       [ tauto
 	| intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
 	  intros H5; discriminate H5 ].
-Qed. 
+Qed.
 
 Theorem dec_Zne : forall n m:Z, decidable (Zne n m).
 Proof.
@@ -79,7 +80,7 @@ Proof.
   intros x y; unfold decidable, Zge in |- *; elim (x ?= y);
     [ left; discriminate
       | right; unfold not in |- *; intros H; apply H; trivial with arith
-      | left; discriminate ]. 
+      | left; discriminate ].
 Qed.
 
 Theorem dec_Zlt : forall n m:Z, decidable (n < m).
@@ -96,7 +97,7 @@ Proof.
       | unfold Zlt in |- *; intros H; elim H; intros H1;
 	[ auto with arith
 	  | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
-Qed. 
+Qed.
 
 (** * Relating strict and large orders *)
 
@@ -180,7 +181,7 @@ Proof.
   intros x y. split. intro. apply Zgt_lt. assumption.
   intro. apply Zlt_gt. assumption.
 Qed.
- 
+
 (** * Equivalence and order properties *)
 
 (** Reflexivity *)
@@ -188,7 +189,7 @@ Qed.
 Lemma Zle_refl : forall n:Z, n <= n.
 Proof.
   intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
-Qed. 
+Qed.
 
 Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
 Proof.
@@ -201,7 +202,7 @@ Hint Resolve Zle_refl: zarith.
 
 Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m.
 Proof.
-  intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. 
+  intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]].
   absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption.
   assumption.
   absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption.
@@ -256,6 +257,13 @@ Proof.
       | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
 Qed.
 
+Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
+Proof.
+  unfold Zle, Zlt. intros.
+  generalize (Zcompare_Eq_iff_eq n m).
+  destruct (n ?= m); intuition; discriminate.
+Qed.
+
 (** Dichotomy *)
 
 Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n.
@@ -276,8 +284,7 @@ Qed.
 
 Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
 Proof.
-  intros n m p H1 H2; apply Zgt_lt; apply Zgt_trans with (m := m); apply Zlt_gt;
-    assumption.
+  exact Zcompare_Lt_trans.
 Qed.
 
 (** Mixed transitivity *)
@@ -400,13 +407,13 @@ Qed.
 Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m.
 Proof.
   unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n);
-    intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; 
+    intros H1 H2; unfold not in |- *; intros H3; unfold not in H1;
       apply H1;
 	[ assumption
 	  | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
 Qed.
 
-Lemma Zlt_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
+Lemma Zle_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
 Proof.
   intros n p H; apply Zgt_le_trans with p.
   apply Zgt_succ.
@@ -415,7 +422,7 @@ Qed.
 
 Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m.
 Proof.
-  intros n m H; apply Zgt_lt; apply Zlt_gt_succ; assumption.
+  intros n m H; apply Zgt_lt; apply Zle_gt_succ; assumption.
 Qed.
 
 Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m.
@@ -433,12 +440,17 @@ Proof.
   intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
 Qed.
 
-Lemma Zlt_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
+Lemma Zle_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
 Proof.
   intros n m H; apply Zle_gt_trans with (m := Zsucc n);
     [ assumption | apply Zgt_succ ].
 Qed.
 
+Lemma Zlt_succ_r : forall n m, n < Zsucc m <-> n <= m.
+Proof.
+  split; [apply Zlt_succ_le | apply Zle_lt_succ].
+Qed.
+
 (** Weakening order *)
 
 Lemma Zle_succ : forall n:Z, n <= Zsucc n.
@@ -478,9 +490,9 @@ Hint Resolve Zle_le_succ: zarith.
 Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n.
 Proof.
   unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
-    rewrite <- (fun x y => Zcompare_plus_compat x y 1); 
+    rewrite <- (fun x y => Zcompare_plus_compat x y 1);
       rewrite (Zplus_comm p); rewrite Zplus_assoc;
-	rewrite (fun x => Zplus_comm x n); simpl in |- *; 
+	rewrite (fun x => Zplus_comm x n); simpl in |- *;
 	  assumption.
 Qed.
 
@@ -563,7 +575,7 @@ Proof.
   assert (Hle : m <= n).
   apply Zgt_succ_le; assumption.
   destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
-  left; apply Zlt_gt; assumption.  
+  left; apply Zlt_gt; assumption.
   right; assumption.
 Qed.
 
@@ -680,7 +692,7 @@ Proof.
   rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
 Qed.
 
-(** ** Multiplication *) 
+(** ** Multiplication *)
 (** Compatibility of multiplication by a positive wrt to order *)
 
 Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p.
@@ -777,7 +789,7 @@ Proof.
   intros a b c d H0 H1 H2 H3.
   apply Zge_trans with (a * d).
   apply Zmult_ge_compat_l; trivial.
-  apply Zge_trans with c; trivial. 
+  apply Zge_trans with c; trivial.
   apply Zmult_ge_compat_r; trivial.
 Qed.
 
@@ -965,17 +977,17 @@ Qed.
 
 Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p.
 Proof.
-  intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm. 
+  intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm.
   assumption.
-  intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. 
+  intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse.
   rewrite Zplus_opp_l. apply Zplus_0_r.
 Qed.
 
 Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n.
 Proof.
   intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus;
-    pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); 
-      rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; 
+    pattern n at 1 in |- *; rewrite <- (Zplus_0_r n);
+      rewrite (Zplus_comm m n); apply Zplus_lt_compat_l;
 	assumption.
 Qed.
 
@@ -993,8 +1005,8 @@ Qed.
 
 Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m.
 Proof.
-  intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); 
-    rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. 
+  intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m);
+    rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H.
 Qed.
 
 Lemma Zmult_lt_compat:
@@ -1012,7 +1024,7 @@ Proof.
   rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith.
 Qed.
 
-Lemma Zmult_lt_compat2: 
+Lemma Zmult_lt_compat2:
   forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q.
 Proof.
   intros n m p q (H1, H2) (H3, H4).
@@ -1025,5 +1037,3 @@ Qed.
 
 (** For compatibility *)
 Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing).
-Notation Zle_gt_succ := Zlt_gt_succ (only parsing).
-Notation Zle_succ_gt := Zlt_succ_gt (only parsing).
diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v
index b0f372de..620d6324 100644
--- a/theories/ZArith/Zpow_def.v
+++ b/theories/ZArith/Zpow_def.v
@@ -2,11 +2,11 @@ Require Import ZArith_base.
 Require Import Ring_theory.
 
 Open Local Scope Z_scope.
- 
+
 (** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary
-      integer (type [positive]) and [z] a signed integer (type [Z]) *) 
+      integer (type [positive]) and [z] a signed integer (type [Z]) *)
 Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1.
-  
+
 Definition Zpower (x y:Z) :=
     match y with
       | Zpos p => Zpower_pos x p
@@ -24,4 +24,4 @@ Proof.
    repeat rewrite Zmult_assoc;trivial.
  rewrite H;rewrite Zmult_1_r;trivial.
 Qed.
- 
+
diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v
index 3d4d235a..1d9b3dfc 100644
--- a/theories/ZArith/Zpow_facts.v
+++ b/theories/ZArith/Zpow_facts.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zpow_facts.v 11098 2008-06-11 09:16:22Z letouzey $ i*)
+(*i $Id$ i*)
 
 Require Import ZArith_base.
 Require Import ZArithRing.
@@ -37,7 +37,7 @@ Proof.
 Qed.
 
 Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0.
-Proof. 
+Proof.
   induction p.
   change (xI p) with (1 + (xO p))%positive.
   rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto.
@@ -133,7 +133,7 @@ Proof.
   apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto.
 Qed.
 
-Theorem Zpower_le_monotone: forall a b c, 
+Theorem Zpower_le_monotone: forall a b c,
  0 < a -> 0 <= b <= c -> a^b <= a^c.
 Proof.
   intros a b c H (H1, H2).
@@ -145,7 +145,7 @@ Proof.
   apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
 Qed.
 
-Theorem Zpower_lt_monotone: forall a b c, 
+Theorem Zpower_lt_monotone: forall a b c,
  1 < a -> 0 <= b < c -> a^b < a^c.
 Proof.
   intros a b c H (H1, H2).
@@ -160,7 +160,7 @@ Proof.
   apply Zpower_le_monotone; auto with zarith.
 Qed.
 
-Theorem Zpower_gt_1 : forall x y, 
+Theorem Zpower_gt_1 : forall x y,
   1 < x -> 0 < y -> 1 < x^y.
 Proof.
   intros x y H1 H2.
@@ -168,14 +168,14 @@ Proof.
   apply Zpower_lt_monotone; auto with zarith.
 Qed.
 
-Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y. 
+Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y.
 Proof.
   intros x y; case y; auto with zarith.
   simpl ; auto with zarith.
   intros p H1; assert (H: 0 <= Zpos p); auto with zarith.
   generalize H; pattern (Zpos p); apply natlike_ind; auto with zarith.
-  intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. 
-  apply Zmult_le_0_compat; auto with zarith.  
+  intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith.
+  apply Zmult_le_0_compat; auto with zarith.
   generalize H1; case x; compute; intros; auto; try discriminate.
 Qed.
 
@@ -195,7 +195,7 @@ Proof.
   destruct b;trivial;unfold Zgt in z;discriminate z.
 Qed.
 
-Theorem Zmult_power: forall p q r, 0 <= r -> 
+Theorem Zmult_power: forall p q r, 0 <= r ->
   (p*q)^r = p^r * q^r.
 Proof.
   intros p q r H1; generalize H1; pattern r; apply natlike_ind; auto.
@@ -206,7 +206,7 @@ Qed.
 
 Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith.
 
-Theorem Zpower_le_monotone3: forall a b c, 
+Theorem Zpower_le_monotone3: forall a b c,
  0 <= c -> 0 <= a <= b -> a^c <= b^c.
 Proof.
   intros a b c H (H1, H2).
@@ -216,7 +216,7 @@ Proof.
   apply Zle_trans with (a^x * b); auto with zarith.
 Qed.
 
-Lemma Zpower_le_monotone_inv: forall a b c, 
+Lemma Zpower_le_monotone_inv: forall a b c,
   1 < a -> 0 < b -> a^b <= a^c -> b <= c.
 Proof.
   intros a b c H H0 H1.
@@ -227,14 +227,14 @@ Proof.
    apply Zpower_le_monotone;auto with zarith.
    apply Zpower_le_monotone3;auto with zarith.
   assert (c > 0).
-  destruct (Z_le_gt_dec 0 c);trivial. 
+  destruct (Z_le_gt_dec 0 c);trivial.
   destruct (Zle_lt_or_eq _ _ z0);auto with zarith.
-  rewrite <- H3 in H1;simpl in H1; elimtype False;omega.
-  destruct c;try discriminate z0. simpl in H1. elimtype False;omega.
-  assert (H4 := Zpower_lt_monotone a c b H). elimtype False;omega.
+  rewrite <- H3 in H1;simpl in H1; exfalso;omega.
+  destruct c;try discriminate z0. simpl in H1. exfalso;omega.
+  assert (H4 := Zpower_lt_monotone a c b H). exfalso;omega.
 Qed.
 
-Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> 
+Theorem Zpower_nat_Zpower: forall p q, 0 <= q ->
  p^q = Zpower_nat p (Zabs_nat q).
 Proof.
   intros p1 q1; case q1; simpl.
@@ -262,7 +262,7 @@ Proof.
   intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto.
 Qed.
 
-Lemma Zpower2_Psize : 
+Lemma Zpower2_Psize :
   forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat.
 Proof.
   induction n.
@@ -294,7 +294,7 @@ Qed.
 
 (** A direct way to compute Zpower modulo **)
 
-Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) {struct m} : Z :=
+Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z :=
   match m with
    | xH => a mod n
    | xO m' =>
@@ -311,14 +311,14 @@ Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) {struct m} : Z :=
       end
   end.
 
-Definition Zpow_mod a m n := 
-  match m with 
-   | 0 => 1 
-   | Zpos p => Zpow_mod_pos a p n 
-   | Zneg p => 0 
+Definition Zpow_mod a m n :=
+  match m with
+   | 0 => 1
+   | Zpos p => Zpow_mod_pos a p n
+   | Zneg p => 0
   end.
 
-Theorem Zpow_mod_pos_correct: forall a m n, 0 < n -> 
+Theorem Zpow_mod_pos_correct: forall a m n, 0 < n ->
  Zpow_mod_pos a m n = (Zpower_pos a m) mod n.
 Proof.
   intros a m; elim m; simpl; auto.
@@ -327,12 +327,12 @@ Proof.
   repeat rewrite Rec; auto.
   rewrite Zpower_pos_1_r.
   repeat rewrite (fun x => (Zmult_mod x a)); auto with zarith.
-  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. 
+  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith.
   case (Zpower_pos a p mod n); auto.
   intros p Rec n H1; rewrite <- Pplus_diag; auto.
   repeat rewrite Zpower_pos_is_exp; auto.
   repeat rewrite Rec; auto.
-  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. 
+  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith.
   case (Zpower_pos a p mod n); auto.
   unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith.
 Qed.
@@ -354,7 +354,7 @@ Proof.
   pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith.
 Qed.
 
-Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> 
+Theorem rel_prime_Zpower_r: forall i p q, 0 < i ->
  rel_prime p q -> rel_prime p (q^i).
 Proof.
   intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi.
@@ -365,7 +365,7 @@ Proof.
   rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
 Qed.
 
-Theorem rel_prime_Zpower: forall i j p q, 0 <= i ->  0 <= j -> 
+Theorem rel_prime_Zpower: forall i j p q, 0 <= i ->  0 <= j ->
  rel_prime p q -> rel_prime (p^i) (q^j).
 Proof.
   intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q.
@@ -379,7 +379,7 @@ Proof.
   rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
 Qed.
 
-Theorem prime_power_prime: forall p q n, 0 <= n -> 
+Theorem prime_power_prime: forall p q n, 0 <= n ->
  prime p -> prime q -> (p | q^n)  -> p = q.
 Proof.
   intros p q n Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn.
@@ -442,15 +442,15 @@ Fixpoint Psquare (p: positive): positive :=
   end.
 
 Definition Zsquare p :=
-  match p with 
-   | Z0 => Z0 
-   | Zpos p => Zpos (Psquare p) 
+  match p with
+   | Z0 => Z0
+   | Zpos p => Zpos (Psquare p)
    | Zneg p => Zpos (Psquare p)
   end.
 
 Theorem Psquare_correct: forall p, Psquare p = (p * p)%positive.
 Proof.
-  induction p; simpl; auto; f_equal; rewrite IHp.  
+  induction p; simpl; auto; f_equal; rewrite IHp.
   apply trans_equal with (xO p + xO (p*p))%positive; auto.
   rewrite (Pplus_comm (xO p)); auto.
   rewrite Pmult_xI_permute_r; rewrite Pplus_assoc.
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
index 1912f5e1..508e6601 100644
--- a/theories/ZArith/Zpower.v
+++ b/theories/ZArith/Zpower.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zpower.v 11072 2008-06-08 16:13:37Z herbelin $ i*)
+(*i $Id$ i*)
 
 Require Import Wf_nat.
 Require Import ZArith_base.
@@ -20,7 +20,7 @@ Infix "^" := Zpower : Z_scope.
 (** * Definition of powers over [Z]*)
 
 (** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary
-    integer (type [nat]) and [z] a signed integer (type [Z]) *) 
+    integer (type [nat]) and [z] a signed integer (type [Z]) *)
 
 Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1.
 
@@ -83,12 +83,12 @@ Section Powers_of_2.
   (** For the powers of two, that will be widely used, a more direct
       calculus is possible. We will also prove some properties such
       as [(x:positive) x < 2^x] that are true for all integers bigger
-      than 2 but more difficult to prove and useless. *)     
+      than 2 but more difficult to prove and useless. *)
 
   (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)
 
-  Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. 
-  Definition shift_pos (n z:positive) := iter_pos n positive xO z. 
+  Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z.
+  Definition shift_pos (n z:positive) := iter_pos n positive xO z.
   Definition shift (n:Z) (z:positive) :=
     match n with
       | Z0 => z
@@ -130,7 +130,7 @@ Section Powers_of_2.
     rewrite (shift_nat_correct n).
     omega.
   Qed.
-  
+
   (** Second we show that [two_power_pos] and [two_power_nat] are the same *)
   Lemma shift_pos_nat :
     forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x.
@@ -181,12 +181,12 @@ Section Powers_of_2.
     apply Zpower_pos_is_exp.
   Qed.
 
-  (** The exponentiation [z -> 2^z] for [z] a signed integer. 
+  (** The exponentiation [z -> 2^z] for [z] a signed integer.
       For convenience, we assume that [2^z = 0] for all [z < 0]
       We could also define a inductive type [Log_result] with
       3 contructors [ Zero | Pos positive -> | minus_infty]
       but it's more complexe and not so useful. *)
-  
+
   Definition two_p (x:Z) :=
     match x with
       | Z0 => 1
@@ -227,7 +227,7 @@ Section Powers_of_2.
 
   Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x.
   Proof.
-    intros; unfold Zsucc in |- *. 
+    intros; unfold Zsucc in |- *.
     rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)).
     apply Zmult_comm.
   Qed.
@@ -247,10 +247,10 @@ Section Powers_of_2.
 	    | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *;
 	      auto with zarith ]
 	| assumption ].
-  Qed. 
+  Qed.
 
   Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y.
-    intros; omega. Qed. 
+    intros; omega. Qed.
 
   End Powers_of_2.
 
@@ -286,13 +286,13 @@ Section power_div_with_rest.
       let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p.
   Proof.
     intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1));
-      rewrite (two_power_pos_nat p); elim (nat_of_P p); 
+      rewrite (two_power_pos_nat p); elim (nat_of_P p);
 	simpl in |- *;
 	  [ trivial with zarith
 	    | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *;
-	      elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); 
+	      elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1));
 		destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z);
-		  assumption ]. 
+		  assumption ].
   Qed.
 
   Lemma Zdiv_rest_correct2 :
@@ -327,7 +327,7 @@ Section power_div_with_rest.
 		      apply f_equal with (f := fun z:Z => z + r);
 			do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc;
 			  rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc;
-			    apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); 
+			    apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z);
 			      omega
 		      | omega ]
 		  | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros;
diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v
index 6ea952e6..b845cf47 100644
--- a/theories/ZArith/Zsqrt.v
+++ b/theories/ZArith/Zsqrt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zsqrt.v 10295 2007-11-06 22:46:21Z letouzey $ *)
+(* $Id$ *)
 
 Require Import ZArithRing.
 Require Import Omega.
@@ -119,7 +119,7 @@ Definition Zsqrt :
 	| Zneg p =>
           fun h =>
             False_rec
-            {s : Z & 
+            {s : Z &
               {r : Z |
 		Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
             (h (refl_equal Datatypes.Gt))
@@ -199,7 +199,7 @@ Qed.
 Theorem Zsqrt_le:
  forall p q, 0 <= p <= q  ->  Zsqrt_plain p <= Zsqrt_plain q.
 Proof.
-  intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2; 
+  intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2;
   [ | subst q; auto with zarith].
   case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3.
   assert (Hp: (0 <= Zsqrt_plain q)).
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
index bd617204..32d6de19 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zwf.v 9245 2006-10-17 12:53:34Z notin $ *)
+(* $Id$ *)
 
 Require Import ZArith_base.
 Require Export Wf_nat.
@@ -15,7 +15,7 @@ Open Local Scope Z_scope.
 
 (** Well-founded relations on Z. *)
 
-(** We define the following family of relations on [Z x Z]: 
+(** We define the following family of relations on [Z x Z]:
 
     [x (Zwf c) y]   iff   [x < y & c <= y]
  *)
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
index ffc3e70f..7af99ece 100644
--- a/theories/ZArith/auxiliary.v
+++ b/theories/ZArith/auxiliary.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,9 +7,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auxiliary.v 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
 Require Export Arith_base.
 Require Import BinInt.
@@ -25,7 +26,7 @@ Open Local Scope Z_scope.
 Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0.
 Proof.
   intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1;
-    apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; 
+    apply Zplus_reg_l with (- y); rewrite Zplus_opp_l;
       rewrite Zplus_comm; trivial with arith.
 Qed.
 
@@ -97,7 +98,7 @@ Proof.
   intros x y z H1 H2 H3; apply Zle_trans with (m := y * x);
     [ apply Zmult_gt_0_le_0_compat; assumption
       | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r;
-	apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; 
+	apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt;
 	  assumption ].
 Qed.
 
diff --git a/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget
new file mode 100644
index 00000000..3efa7055
--- /dev/null
+++ b/theories/ZArith/vo.itarget
@@ -0,0 +1,32 @@
+auxiliary.vo
+BinInt.vo
+Int.vo
+Wf_Z.vo
+Zabs.vo
+ZArith_base.vo
+ZArith_dec.vo
+ZArith.vo
+Zdigits.vo
+Zbool.vo
+Zcompare.vo
+Zcomplements.vo
+Zdiv.vo
+Zeven.vo
+Zgcd_alt.vo
+Zhints.vo
+Zlogarithm.vo
+Zmax.vo
+Zminmax.vo
+Zmin.vo
+Zmisc.vo
+Znat.vo
+Znumtheory.vo
+ZOdiv_def.vo
+ZOdiv.vo
+Zorder.vo
+Zpow_def.vo
+Zpower.vo
+Zpow_facts.vo
+Zsqrt.vo
+Zwf.vo
+ZOrderedType.vo
diff --git a/theories/theories.itarget b/theories/theories.itarget
new file mode 100644
index 00000000..afc3554b
--- /dev/null
+++ b/theories/theories.itarget
@@ -0,0 +1,22 @@
+Arith/vo.otarget
+Bool/vo.otarget
+Classes/vo.otarget
+FSets/vo.otarget
+MSets/vo.otarget
+Structures/vo.otarget
+Init/vo.otarget
+Lists/vo.otarget
+Logic/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/beautify-archive b/tools/beautify-archive
index aac6f3e0..aac6f3e0 100755..100644
--- a/tools/beautify-archive
+++ b/tools/beautify-archive
diff --git a/tools/coq-db.el b/tools/coq-db.el
new file mode 100644
index 00000000..078c2bb6
--- /dev/null
+++ b/tools/coq-db.el
@@ -0,0 +1,241 @@
+;;; coq-db.el --- coq keywords database utility functions
+;;
+;; Author: Pierre Courtieu <courtieu@lri.fr>
+;; License:     GPL (GNU GENERAL PUBLIC LICENSE)
+;;
+
+;;; We store all information on keywords (tactics or command) in big
+;; tables (ex: `coq-tactics-db') From there we get: menus including
+;; "smart" commands, completions for command coq-insert-...
+;; abbrev tables and font-lock keyword
+
+;;; real value defined below
+
+;;; Commentary:
+;; 
+
+;;; Code:
+
+;(require 'proof-config)			; for proof-face-specs, a macro
+;(require 'holes)
+
+(defconst coq-syntax-db nil
+  "Documentation-only variable, for coq keyword databases.
+Each element of a keyword database contains the definition of a \"form\", of the
+form:
+
+(MENUNAME ABBREV INSERT STATECH KWREG INSERT-FUN HIDE)
+
+MENUNAME is the name of form (or form variant) as it should appear in menus or
+completion lists.
+
+ABBREV is the abbreviation for completion via \\[expand-abbrev].
+
+INSERT is the complete text of the form, which may contain holes denoted by
+\"#\" or \"@{xxx}\".
+
+If non-nil the optional STATECH specifies that the command is not state
+preserving for coq.
+
+If non-nil the optional KWREG is the regexp to colorize correponding to the
+keyword.  ex: \"simple\\\\s-+destruct\" (\\\\s-+ meaning \"one or more spaces\").
+*WARNING*: A regexp longer than another one should be put FIRST. For example:
+
+  (\"Module Type\" ... ... t \"Module\\s-+Type\")
+  (\"Module\" ... ... t \"Module\")
+
+Is ok because the longer regexp is recognized first.
+
+If non-nil the optional INSERT-FUN is the function to be called when inserting
+the form (instead of inserting INSERT, except when using \\[expand-abbrev]). This
+allows to write functions asking for more information to assist the user.
+
+If non-nil the optional HIDE specifies that this form should not appear in the
+menu but only in interactive completions.
+
+Example of what could be in your emacs init file:
+
+(defvar coq-user-tactics-db
+  '(
+    (\"mytac\" \"mt\" \"mytac # #\" t \"mytac\")
+    (\"myassert by\" \"massb\" \"myassert ( # : # ) by #\" t \"assert\")
+    ))
+
+Explanation of the first line: the tactic menu entry mytac, abbreviated by mt,
+will insert \"mytac # #\" where #s are holes to fill, and \"mytac\" becomes a
+new keyword to colorize." )
+
+(defun coq-insert-from-db (db prompt)
+  "Ask for a keyword, with completion on keyword database DB and insert.
+Insert corresponding string with holes at point.  If an insertion function is
+present for the keyword, call it instead.  see `coq-syntax-db' for DB
+structure."
+  (let* ((tac (completing-read (concat prompt " (tab for completion) : ")
+                               db nil nil))
+         (infos (cddr (assoc tac db)))
+         (s (car infos)) ; completion to insert
+         (f (car-safe (cdr-safe (cdr-safe (cdr infos))))) ; insertion function
+         (pt (point)))
+    (if f (funcall f) ; call f if present
+      (insert (or s tac)) ; insert completion and indent otherwise
+      (holes-replace-string-by-holes-backward-jump pt)
+      (indent-according-to-mode))))
+
+
+
+(defun coq-build-regexp-list-from-db (db &optional filter)
+  "Take a keyword database DB and return the list of regexps for font-lock.
+If non-nil Optional argument FILTER is a function applying to each line of DB.
+For each line if FILTER returns nil, then the keyword is not added to the
+regexp.  See `coq-syntax-db' for DB structure."
+  (let ((l db) (res ()))
+    (while l
+      (let* ((hd (car l)) (tl (cdr l))	; hd is the first infos list
+             (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry
+             (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation
+             (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion
+             (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing
+             (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string
+             )
+        ;; TODO delete doublons
+        (when (and e5 (or (not filter) (funcall filter hd)))
+          (setq res (nconc res (list e5)))) ; careful: nconc destructive!
+        (setq l tl)))
+    res
+    ))
+
+;; Computes the max length of strings in a list
+(defun max-length-db (db)
+  "Return the length of the longest first element (menu label) of DB.
+See `coq-syntax-db' for DB structure."
+  (let ((l db) (res 0))
+    (while l
+      (let ((lgth (length (car (car l)))))
+	(setq res (max lgth res))
+	(setq l (cdr l))))
+    res))
+
+
+
+(defun coq-build-menu-from-db-internal (db lgth menuwidth)
+  "Take a keyword database DB and return one insertion submenu.
+Argument LGTH is the max size of the submenu.  Argument MENUWIDTH is the width
+of the largest line in the menu (without abbrev and shortcut specifications).
+Used by `coq-build-menu-from-db', which you should probably use instead.  See
+`coq-syntax-db' for DB structure."
+  (let ((l db) (res ()) (size lgth)
+	(keybind-abbrev (substitute-command-keys " \\[expand-abbrev]")))
+    (while (and l (> size 0))
+      (let* ((hd (car l))(tl (cdr l))	; hd is a list of length 3 or 4
+	     (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry
+	     (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation
+	     (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion
+	     (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing
+	     (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string
+	     (e6 (car-safe tl5))	; e6 = function for smart insertion
+	     (e7 (car-safe (cdr-safe tl5))) ; e7 = if non-nil : hide in menu
+	     (entry-with (max (- menuwidth (length e1)) 0))
+	     (spaces (make-string entry-with ? ))
+	     ;;(restofmenu (coq-build-menu-from-db-internal tl (- size 1) menuwidth))
+	     )
+	(when (not e7) ;; if not hidden
+	  (let ((menu-entry
+		 (vector
+		  ;; menu entry label
+		  (concat e1 (if (not e2) "" (concat spaces "(" e2 keybind-abbrev ")")))
+		   ;;insertion function if present otherwise insert completion
+		   (if e6 e6 `(holes-insert-and-expand ,e3))
+		   t)))
+	    (setq res (nconc res (list menu-entry)))));; append *in place*
+	(setq l tl)
+	(setq size (- size 1))))
+    res))
+
+
+(defun coq-build-title-menu (db size)
+  "Build a title for the first submenu of DB, of size SIZE.
+Return the string made of the first and the SIZE nth first element of DB,
+separated by \"...\".  Used by `coq-build-menu-from-db'.  See `coq-syntax-db'
+for DB structure."
+    (concat (car-safe (car-safe db))
+	  " ... "
+	  (car-safe (car-safe (nthcdr (- size 1) db)))))
+
+(defun coq-sort-menu-entries (menu)
+  (sort menu 
+	'(lambda (x y) (string< 
+			(downcase (elt x 0)) 
+			(downcase (elt y 0))))))
+
+(defun coq-build-menu-from-db (db &optional size)
+  "Take a keyword database DB and return a list of insertion menus for them.
+Submenus contain SIZE entries (default 30).  See `coq-syntax-db' for DB
+structure."
+  ;; sort is destructive for the list, so copy list before sorting
+  (let* ((l (coq-sort-menu-entries (copy-list db))) (res ())
+	 (wdth (+ 2 (max-length-db db)))
+	 (sz (or size 30)) (lgth (length l)))
+    (while l
+      (if (<= lgth sz)
+	  (setq res ;; careful: nconc destructive!
+		(nconc res (list (cons 
+				  (coq-build-title-menu l lgth)
+				  (coq-build-menu-from-db-internal l lgth wdth)))))
+	(setq res ; careful: nconc destructive!
+	      (nconc res (list (cons 
+				(coq-build-title-menu l sz)
+				(coq-build-menu-from-db-internal l sz wdth))))))
+      (setq l (nthcdr sz l))
+      (setq lgth (length l)))
+    res))
+
+(defun coq-build-abbrev-table-from-db (db)
+  "Take a keyword database DB and return an abbrev table.
+See `coq-syntax-db' for DB structure."
+  (let ((l db) (res ()))
+    (while l
+      (let* ((hd (car l))(tl (cdr l))	; hd is a list of length 3 or 4
+	     (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry
+	     (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation
+	     (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion
+	     )
+	;; careful: nconc destructive!
+	(when e2 
+	  (setq res (nconc res (list `(,e2 ,e3 holes-abbrev-complete)))))
+	(setq l tl)))
+    res))
+
+
+(defun filter-state-preserving (l)
+  ; checkdoc-params: (l)
+  "Not documented."
+  (not (nth 3 l))) ; fourth argument is nil --> state preserving command
+
+(defun filter-state-changing (l)
+  ; checkdoc-params: (l)
+  "Not documented."
+  (nth 3 l)) ; fourth argument is nil --> state preserving command
+
+
+;;A new face for tactics which fail when they don't kill the current goal
+(defface coq-solve-tactics-face 
+  (proof-face-specs
+   (:foreground "red" t) ; pour les fonds clairs
+   (:foreground "red"  t) ; pour les fond foncés
+   ()) ; pour le noir et blanc
+  "Face for names of closing tactics in proof scripts."
+  :group 'proof-faces)
+
+(defconst coq-solve-tactics-face 'coq-solve-tactics-face
+  "Expression that evaluates to a face.
+Required so that 'proof-solve-tactics-face is a proper facename")
+
+
+
+(provide 'coq-db)
+
+;;; coq-db.el ends here
+
+;** Local Variables: ***
+;** fill-column: 80 ***
+;** End: ***
diff --git a/tools/coq-font-lock.el b/tools/coq-font-lock.el
new file mode 100644
index 00000000..05618a04
--- /dev/null
+++ b/tools/coq-font-lock.el
@@ -0,0 +1,137 @@
+;; coq-font-lock.el --- Coq syntax highlighting for Emacs - compatibilty code
+;; Pierre Courtieu, may 2009
+;;
+;; Authors: Pierre Courtieu
+;; License:     GPL (GNU GENERAL PUBLIC LICENSE)
+;; Maintainer: Pierre Courtieu <Pierre.Courtieu@cnam.fr>
+
+;; This is copy paste from ProofGeneral by David Aspinall
+;; <David.Aspinall@ed.ac.uk>. ProofGeneral is under GPL and Copyright
+;; (C) LFCS Edinburgh.
+
+
+;;; Commentary:
+;; This file contains the code necessary to coq-syntax.el and
+;; coq-db.el from ProofGeneral. It is also pocked from ProofGeneral.
+
+
+;;; History:
+;; First created from ProofGeneral may 28th 2009
+
+
+;;; Code:
+
+(setq coq-version-is-V8-1 t)
+(defun coq-build-regexp-list-from-db (db &optional filter)
+  "Take a keyword database DB and return the list of regexps for font-lock.
+If non-nil Optional argument FILTER is a function applying to each line of DB.
+For each line if FILTER returns nil, then the keyword is not added to the
+regexp.  See `coq-syntax-db' for DB structure."
+  (let ((l db) (res ()))
+    (while l
+      (let* ((hd (car l)) (tl (cdr l))	; hd is the first infos list
+             (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry
+             (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation
+             (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion
+             (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing
+             (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string
+             )
+        ;; TODO delete doublons
+        (when (and e5 (or (not filter) (funcall filter hd)))
+          (setq res (nconc res (list e5)))) ; careful: nconc destructive!
+        (setq l tl)))
+    res
+    ))
+(defun filter-state-preserving (l)
+  ; checkdoc-params: (l)
+  "Not documented."
+  (not (nth 3 l))) ; fourth argument is nil --> state preserving command
+
+(defun filter-state-changing (l)
+  ; checkdoc-params: (l)
+  "Not documented."
+  (nth 3 l)) ; fourth argument is nil --> state preserving command
+
+;; Generic font-lock
+
+(defvar proof-id "\\(\\w\\(\\w\\|\\s_\\)*\\)"
+  "A regular expression for parsing identifiers.")
+
+;; For font-lock, we treat ,-separated identifiers as one identifier
+;; and refontify commata using \{proof-zap-commas}.
+
+(defun proof-anchor-regexp (e)
+  "Anchor (\\`) and group the regexp E."
+  (concat "\\`\\(" e "\\)"))
+
+(defun proof-ids (proof-id &optional sepregexp)
+  "Generate a regular expression for separated lists of identifiers PROOF-ID.
+Default is comma separated, or SEPREGEXP if set."
+  (concat proof-id "\\(\\s-*"   (or sepregexp ",") "\\s-*"
+	  proof-id "\\)*"))
+
+(defun proof-ids-to-regexp (l)
+  "Maps a non-empty list of tokens `L' to a regexp matching any element."
+  (if (featurep 'xemacs)
+      (mapconcat (lambda (s) (concat "\\_<" s "\\_>")) l "\\|") ;; old version
+    (concat "\\_<\\(?:" (mapconcat 'identity l "\\|") "\\)\\_>")))
+
+;; TODO: get rid of this list.  Does 'default work widely enough
+;; by now?
+(defconst pg-defface-window-systems
+  '(x            ;; bog standard
+    mswindows    ;; Windows
+    w32	         ;; Windows
+    gtk          ;; gtk emacs (obsolete?)
+    mac          ;; used by Aquamacs
+    carbon       ;; used by Carbon XEmacs
+    ns           ;; NeXTstep Emacs (Emacs.app)
+    x-toolkit)   ;; possible catch all (but probably not)
+  "A list of possible values for variable `window-system'.
+If you are on a window system and your value of variable
+`window-system' is not listed here, you may not get the correct
+syntax colouring behaviour.")
+
+(defmacro proof-face-specs (bl bd ow)
+  "Return a spec for `defface' with BL for light bg, BD for dark, OW o/w."
+  `(append
+    (apply 'append
+     (mapcar
+     (lambda (ty) (list
+		     (list (list (list 'type ty) '(class color)
+			   (list 'background 'light))
+			   (quote ,bl))
+		     (list (list (list 'type ty) '(class color)
+				 (list 'background 'dark))
+			   (quote ,bd))))
+     pg-defface-window-systems))
+    (list (list t (quote ,ow)))))
+
+;;A new face for tactics
+(defface coq-solve-tactics-face
+  (proof-face-specs
+   (:foreground "forestgreen" t) ; pour les fonds clairs
+   (:foreground "forestgreen"  t) ; pour les fond foncés
+   ()) ; pour le noir et blanc
+  "Face for names of closing tactics in proof scripts."
+  :group 'proof-faces)
+
+;;A new face for tactics which fail when they don't kill the current goal
+(defface coq-solve-tactics-face
+  (proof-face-specs
+   (:foreground "red" t) ; pour les fonds clairs
+   (:foreground "red"  t) ; pour les fond foncés
+   ()) ; pour le noir et blanc
+  "Face for names of closing tactics in proof scripts."
+  :group 'proof-faces)
+
+
+(defconst coq-solve-tactics-face 'coq-solve-tactics-face
+  "Expression that evaluates to a face.
+Required so that 'proof-solve-tactics-face is a proper facename")
+
+(defconst proof-tactics-name-face 'coq-solve-tactics-face)
+(defconst proof-tacticals-name-face 'coq-solve-tactics-face)
+
+(provide 'coq-font-lock)
+;;; coq-font-lock.el ends here
diff --git a/tools/coq-syntax.el b/tools/coq-syntax.el
new file mode 100644
index 00000000..5b88f6a5
--- /dev/null
+++ b/tools/coq-syntax.el
@@ -0,0 +1,974 @@
+;; coq-syntax.el Font lock expressions for Coq
+;; Copyright (C) 1997-2007 LFCS Edinburgh. 
+;; Authors: Thomas Kleymann, Healfdene Goguen, Pierre Courtieu
+;; License:     GPL (GNU GENERAL PUBLIC LICENSE)
+;; Maintainer: Pierre Courtieu <courtieu@lri.fr>
+
+;; coq-syntax.el,v 9.9 2008/07/21 15:14:58 pier Exp
+
+;(require 'proof-syntax)
+;(require 'proof-utils)                  ; proof-locate-executable
+(require 'coq-db)
+
+
+
+ ;;; keyword databases
+
+
+(defcustom coq-user-tactics-db nil
+  "User defined tactic information.  See `coq-syntax-db' for
+ syntax. It is not necessary to add your own tactics here (it is not
+ needed by the synchronizing/backtracking system). You may however do
+ so for the following reasons:
+
+   1 your tactics will be colorized by font-lock
+
+   2 your tactics will be added to the menu and to completion when
+   calling \\[coq-insert-tactic]
+
+   3 you may define an abbreviation for your tactic."
+
+  :type '(repeat sexp)
+  :group 'coq)
+
+
+(defcustom coq-user-commands-db nil
+  "User defined command information.  See `coq-syntax-db' for
+ syntax. It is not necessary to add your own commands here (it is not
+ needed by the synchronizing/backtracking system). You may however do
+ so for the following reasons:
+
+   1 your commands will be colorized by font-lock
+
+   2 your commands will be added to the menu and to completion when
+   calling \\[coq-insert-command]
+
+   3 you may define an abbreviation for your command."
+
+  :type '(repeat sexp)
+  :group 'coq)
+
+(defcustom coq-user-tacticals-db nil
+  "User defined tactical information.  See `coq-syntax-db' for
+ syntax. It is not necessary to add your own commands here (it is not
+ needed by the synchronizing/backtracking system). You may however do
+ so for the following reasons:
+
+   1 your commands will be colorized by font-lock
+
+   2 your commands will be added to the menu and to completion when
+   calling \\[coq-insert-command]
+
+   3 you may define an abbreviation for your command."
+
+  :type '(repeat sexp)
+  :group 'coq)
+
+(defcustom coq-user-solve-tactics-db nil
+  "User defined closing tactics. See `coq-syntax-db' for
+ syntax. It is not necessary to add your own commands here (it is not
+ needed by the synchronizing/backtracking system). You may however do
+ so for the following reasons:
+
+   1 your commands will be colorized by font-lock
+
+   2 your commands will be added to the menu and to completion when
+   calling \\[coq-insert-command]
+
+   3 you may define an abbreviation for your command."
+
+  :type '(repeat sexp)
+  :group 'coq)
+
+
+
+(defcustom coq-user-reserved-db nil
+  "User defined reserved keywords information.  See `coq-syntax-db' for
+ syntax. It is not necessary to add your own commands here (it is not
+ needed by the synchronizing/backtracking system). You may however do
+ so for the following reasons:
+
+   1 your commands will be colorized by font-lock
+
+   2 your commands will be added to the menu and to completion when
+   calling \\[coq-insert-command]
+
+   3 you may define an abbreviation for your command."
+
+  :type '(repeat sexp)
+  :group 'coq)
+
+
+
+(defvar coq-tactics-db
+  (append 
+   coq-user-tactics-db
+   '(
+     ("absurd " "abs" "absurd " t "absurd")
+     ("apply" "ap" "apply " t "apply")
+     ("assert by" "assb" "assert ( # : # ) by #" t "assert")
+     ("assert" "ass" "assert ( # : # )" t)
+     ;;     ("assumption" "as" "assumption" t "assumption")
+     ("auto with arith" "awa" "auto with arith" t)
+     ("auto with" "aw" "auto with @{db}" t)
+     ("auto" "a" "auto" t "auto")
+     ("autorewrite with in using" "arwiu" "autorewrite with @{db,db...} in @{hyp} using @{tac}" t)
+     ("autorewrite with in" "arwi" "autorewrite with @{db,db...} in @{hyp}" t)
+     ("autorewrite with using" "arwu" "autorewrite with @{db,db...} using @{tac}" t)
+     ("autorewrite with" "ar" "autorewrite with @{db,db...}" t "autorewrite")
+     ("case" "c" "case " t "case")
+     ("cbv" "cbv" "cbv beta [#] delta iota zeta" t "cbv")
+     ("change in" "chi" "change # in #" t)
+     ("change with in" "chwi" "change # with # in #" t)
+     ("change with" "chw" "change # with" t)
+     ("change" "ch" "change " t "change")
+     ("clear" "cl" "clear" t "clear")
+     ("clearbody" "cl" "clearbody" t "clearbody")
+     ("cofix" "cof" "cofix" t "cofix")
+     ("coinduction" "coind" "coinduction" t "coinduction")
+     ("compare" "cmpa" "compare # #" t "compare")
+     ("compute" "cmpu" "compute" t "compute")
+     ;;     ("congruence" "cong" "congruence" t "congruence")
+     ("constructor" "cons" "constructor" t "constructor")
+     ;;     ("contradiction" "contr" "contradiction" t "contradiction")
+     ("cut" "cut" "cut" t "cut")
+     ("cutrewrite" "cutr" "cutrewrite -> # = #" t "cutrewrite")
+     ;;     ("decide equality" "deg" "decide equality" t "decide\\s-+equality")
+     ("decompose record" "decr" "decompose record #" t "decompose\\s-+record")
+     ("decompose sum" "decs" "decompose sum #" t "decompose\\s-+sum")
+     ("decompose" "dec" "decompose [#] #" t "decompose")
+     ("dependent inversion" "depinv" "dependent inversion" t "dependent\\s-+inversion")
+     ("dependent inversion with" "depinvw" "dependent inversion # with #" t)
+     ("dependent inversion_clear" "depinvc" "dependent inversion_clear" t "dependent\\s-+inversion_clear")
+     ("dependent inversion_clear with" "depinvw" "dependent inversion_clear # with #" t)
+     ("dependent rewrite ->" "depr" "dependent rewrite -> @{id}" t "dependent\\s-+rewrite")
+     ("dependent rewrite <-" "depr<" "dependent rewrite <- @{id}" t)
+     ("destruct as" "desa" "destruct # as #" t)
+     ("destruct using" "desu" "destruct # using #" t)
+     ("destruct" "des" "destruct " t  "destruct")
+     ;;     ("discriminate" "dis" "discriminate" t "discriminate")
+     ("discrR" "discrR" "discrR" t "discrR")
+     ("double induction" "dind" "double induction # #" t "double\\s-+induction")
+     ("eapply" "eap" "eapply #" t "eapply")
+     ("eauto with arith" "eawa" "eauto with arith" t)
+     ("eauto with" "eaw" "eauto with @{db}" t)
+     ("eauto" "ea" "eauto" t "eauto")
+     ("econstructor" "econs" "econstructor" t "econstructor")
+     ("eexists" "eex" "eexists" t "eexists")
+     ("eleft" "eleft" "eleft" t "eleft")
+     ("elim using" "elu" "elim # using #" t)
+     ("elim" "e" "elim #" t "elim")
+     ("elimtype" "elt" "elimtype" "elimtype")
+     ("eright" "erig" "eright" "eright")
+     ("esplit" "esp" "esplit" t "esplit")
+     ;;     ("exact" "exa" "exact" t "exact")
+     ("exists" "ex" "exists #" t "exists")
+     ;;     ("fail" "fa" "fail" nil)
+     ;;     ("field" "field" "field" t "field")
+     ("firstorder" "fsto" "firstorder" t "firstorder")
+     ("firstorder with" "fsto" "firstorder with #" t)
+     ("firstorder with using" "fsto" "firstorder # with #" t)
+     ("fold" "fold" "fold #" t "fold")
+     ;;     ("fourier" "four" "fourier" t "fourier")
+     ("functional induction" "fi" "functional induction @{f} @{args}" t "functional\\s-+induction")
+     ("generalize dependent" "gd" "generalize dependent #" t "generalize\\s-+dependent")
+     ("generalize" "g" "generalize #" t "generalize")
+     ("hnf" "hnf" "hnf" t "hnf")
+     ("idtac" "id" "idtac" nil "idtac") ; also in tacticals with abbrev id
+     ("idtac \"" "id\"" "idtac \"#\"")  ; also in tacticals
+     ("induction" "ind" "induction #" t "induction")
+     ("induction using" "indu" "induction # using #" t)
+     ("injection" "inj" "injection #" t "injection")
+     ("instantiate" "inst" "instantiate" t "instantiate")
+     ("intro" "i" "intro" t "intro")
+     ("intro after" "ia" "intro # after #" t)
+     ("intros" "is" "intros #" t "intros")
+     ("intros! (guess names)" nil "intros #" nil nil coq-insert-intros)
+     ("intros until" "isu" "intros until #" t)
+     ("intuition" "intu" "intuition #" t "intuition")
+     ("inversion" "inv" "inversion #" t "inversion")
+     ("inversion in" "invi" "inversion # in #" t)
+     ("inversion using" "invu" "inversion # using #" t)
+     ("inversion using in" "invui" "inversion # using # in #" t)
+     ("inversion_clear" "invcl" "inversion_clear" t "inversion_clear")
+     ("lapply" "lap" "lapply" t "lapply")
+     ("lazy" "lazy" "lazy beta [#] delta iota zeta" t "lazy")
+     ("left" "left" "left" t "left")
+     ("linear" "lin" "linear" t "linear")
+     ("load" "load" "load" t "load")
+     ("move after" "mov" "move # after #" t "move")
+     ("omega" "o" "omega" t "omega")
+     ("pattern" "pat" "pattern" t "pattern")
+     ("pattern(s)" "pats" "pattern # , #" t)
+     ("pattern at" "pata" "pattern # at #" t)
+     ("pose" "po" "pose ( # := # )" t "pose")
+     ("prolog" "prol" "prolog" t "prolog")
+     ("quote" "quote" "quote" t "quote")
+     ("quote []" "quote2" "quote # [#]" t)
+     ("red" "red" "red" t "red")
+     ("refine" "ref" "refine" t "refine")
+     ;;      ("reflexivity" "refl" "reflexivity #" t "reflexivity")
+     ("rename into" "ren" "rename # into #" t "rename")
+     ("replace with" "rep" "replace # with #" t "replace")
+     ("replace with in" "repi" "replace # with # in #" t)
+     ("rewrite <- in" "ri<" "rewrite <- # in #" t)
+     ("rewrite <-" "r<" "rewrite <- #" t)
+     ("rewrite in" "ri" "rewrite # in #" t)
+     ("rewrite" "r" "rewrite #" t "rewrite")
+     ("right" "rig" "right" t "right")
+     ;;      ("ring" "ring" "ring #" t "ring")
+     ("set in * |-" "seth" "set ( # := #) in * |-" t)
+     ("set in *" "set*" "set ( # := #) in *" t)
+     ("set in |- *" "setg" "set ( # := #) in |- *" t)
+     ("set in" "seti" "set ( # := #) in #" t)
+     ("set" "set" "set ( # := #)" t "set")
+     ("setoid_replace with" "strep2" "setoid_replace # with #" t "setoid_replace")
+     ("setoid replace with" "strep" "setoid replace # with #" t "setoid\\s-+replace")
+     ("setoid_rewrite" "strew" "setoid_rewrite #" t "setoid_rewrite")
+     ("setoid rewrite" "strew" "setoid rewrite #" t "setoid\\s-+rewrite")
+     ("simpl" "s" "simpl" t "simpl")
+     ("simpl" "sa" "simpl # at #" t)
+     ("simple destruct" "sdes" "simple destruct" t "simple\\s-+destruct")
+     ("simple inversion" "sinv" "simple inversion" t "simple\\s-+inversion")
+     ("simple induction" "sind" "simple induction" t "simple\\s-+induction")
+     ("simplify_eq" "simeq" "simplify_eq @{hyp}" t "simplify_eq")
+     ("specialize" "spec" "specialize" t "specialize")
+     ("split" "sp" "split" t "split")
+     ("split_Rabs" "spra" "splitRabs" t "split_Rabs")
+     ("split_Rmult" "sprm" "splitRmult" t "split_Rmult")
+     ("stepl" "stl" "stepl #" t "stepl")
+     ("stepl by" "stlb" "stepl # by #" t)
+     ("stepr" "str" "stepr #" t "stepr")
+     ("stepr by" "strb" "stepr # by #" t)
+     ("subst" "su" "subst #" t "subst")
+     ("symmetry" "sy" "symmetry" t "symmetry")
+     ("symmetry in" "syi" "symmetry in #" t)
+     ;;    ("tauto" "ta" "tauto" t "tauto")
+     ("transitivity" "trans" "transitivity #" t "transitivity")
+     ("trivial" "t" "trivial" t "trivial")
+     ("trivial with" "tw" "trivial with @{db}" t)
+     ("unfold" "u" "unfold #" t "unfold")
+     ("unfold(s)" "us" "unfold # , #" t)
+     ("unfold in" "unfi" "unfold # in #" t)
+     ("unfold at" "unfa" "unfold # at #" t)
+     ))
+  "Coq tactics information list. See `coq-syntax-db' for syntax. "
+  )
+
+(defvar coq-solve-tactics-db
+  (append
+   coq-user-solve-tactics-db
+   '(
+     ("assumption" "as" "assumption" t "assumption")
+     ("by" "by" "by #" t "by")
+     ("congruence" "cong" "congruence" t "congruence")
+     ("contradiction" "contr" "contradiction" t "contradiction")
+     ("decide equality" "deg" "decide equality" t "decide\\s-+equality")
+     ("discriminate" "dis" "discriminate" t "discriminate")
+     ("exact" "exa" "exact" t "exact")
+     ("fourier" "four" "fourier" t "fourier")
+     ("fail" "fa" "fail" nil)
+     ("field" "field" "field" t "field")
+     ("omega" "o" "omega" t "omega")
+     ("reflexivity" "refl" "reflexivity #" t "reflexivity")
+     ("ring" "ring" "ring #" t "ring")
+     ("solve" nil "solve [ # | # ]" nil "solve")
+     ("tauto" "ta" "tauto" t "tauto")
+     ))
+  "Coq tactic(al)s that solve a subgoal." 
+  )
+
+
+(defvar coq-tacticals-db
+  (append 
+   coq-user-tacticals-db
+   '(
+     ("info" nil "info #" nil "info")
+     ("first" nil "first [ # | # ]" nil "first")
+     ("abstract" nil "abstract @{tac} using @{name}." nil "abstract")
+     ("do" nil "do @{num} @{tac}" nil "do")
+     ("idtac" nil "idtac")              ; also in tactics
+                                        ;    ("idtac \"" nil "idtac \"#\"") ; also in tactics
+     ("fail" "fa" "fail" nil "fail")
+                                        ;    ("fail \"" "fa\"" "fail" nil) ;
+                                        ;    ("orelse" nil "orelse #" t "orelse")
+     ("repeat" nil "repeat #" nil "repeat")
+     ("try" nil "try #" nil "try")
+     ("progress" nil "progress #" nil "progress")
+     ("|" nil "[ # | # ]" nil)
+     ("||" nil "# || #" nil)
+     ))
+  "Coq tacticals information list.  See `coq-syntax-db' for syntax.")
+
+
+
+
+(defvar coq-decl-db
+  '(
+    ("Axiom" "ax" "Axiom # : #" t "Axiom")
+    ("Hint Constructors" "hc" "Hint Constructors # : #." t "Hint\\s-+Constructors")
+    ("Hint Extern" "he" "Hint Extern @{cost} @{pat} => @{tac} : @{db}." t "Hint\\s-+Extern")
+    ("Hint Immediate" "hi" "Hint Immediate # : @{db}." t "Hint\\s-+Immediate")
+    ("Hint Resolve" "hr" "Hint Resolve # : @{db}." t "Hint\\s-+Resolve")
+    ("Hint Rewrite ->" "hrw" "Hint Rewrite -> @{t1,t2...} using @{tac} : @{db}." t "Hint\\s-+Rewrite")
+    ("Hint Rewrite <-" "hrw" "Hint Rewrite <- @{t1,t2...} using @{tac} : @{db}." t )
+    ("Hint Unfold" "hu" "Hint Unfold # : #." t "Hint\\s-+Unfold")
+    ("Hypothesis" "hyp" "Hypothesis #: #" t "Hypothesis")
+    ("Hypotheses" "hyp" "Hypotheses #: #" t "Hypotheses")
+    ("Parameter" "par" "Parameter #: #" t "Parameter")
+    ("Parameters" "par" "Parameter #: #" t "Parameters")
+    ("Conjecture" "conj" "Conjecture #: #." t "Conjecture")
+    ("Variable" "v" "Variable #: #." t "Variable")
+    ("Variables" "vs" "Variables # , #: #." t "Variables")	
+    ("Coercion" "coerc" "Coercion @{id} : @{typ1} >-> @{typ2}." t "Coercion")
+    )
+  "Coq declaration keywords information list. See `coq-syntax-db' for syntax."
+  )
+
+(defvar coq-defn-db
+  '(
+    ("CoFixpoint" "cfix" "CoFixpoint # (#:#) : # :=\n#." t "CoFixpoint")
+    ("CoInductive" "coindv" "CoInductive # : # :=\n|# : #." t "CoInductive") 
+    ("Declare Module : :=" "dm" "Declare Module # : # := #." t "Declare\\s-+Module")
+    ("Declare Module <: :=" "dm2" "Declare Module # <: # := #." t);; careful
+    ("Declare Module Import : :=" "dmi" "Declare Module # : # := #." t)
+    ("Declare Module Import <: :=" "dmi2" "Declare Module # <: # := #." t);; careful
+    ("Declare Module Export : :=" "dme" "Declare Module # : # := #." t)
+    ("Declare Module Export <: :=" "dme2" "Declare Module # <: # := #." t);; careful
+    ("Definition" "def" "Definition #:# := #." t "Definition");; careful
+    ("Definition (2 args)" "def2" "Definition # (# : #) (# : #):# := #." t)
+    ("Definition (3 args)" "def3" "Definition # (# : #) (# : #) (# : #):# := #." t)
+    ("Definition (4 args)" "def4" "Definition # (# : #) (# : #) (# : #) (# : #):# := #." t)
+    ("Program Definition" "pdef" "Program Definition #:# := #." t "Program\\s-+Definition");; careful ?
+    ("Program Definition (2 args)" "pdef2" "Program Definition # (# : #) (# : #):# := #." t)
+    ("Program Definition (3 args)" "pdef3" "Program Definition # (# : #) (# : #) (# : #):# := #." t)
+    ("Program Definition (4 args)" "pdef4" "Program Definition # (# : #) (# : #) (# : #) (# : #):# := #." t)
+    ("Derive Inversion" nil "Derive Inversion @{id} with # Sort #." t "Derive\\s-+Inversion")
+    ("Derive Dependent Inversion" nil "Derive Dependent Inversion @{id} with # Sort #." t "Derive\\s-+Dependent\\s-+Inversion")
+    ("Derive Inversion_clear" nil "Derive Inversion_clear @{id} with # Sort #." t)
+    ("Fixpoint" "fix" "Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Fixpoint")
+    ("Program Fixpoint" "pfix" "Program Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Program\\s-+Fixpoint")
+    ("Program Fixpoint measure" "pfixm" "Program Fixpoint # (#:#) {measure @{arg} @{f}} : # :=\n#." t)
+    ("Program Fixpoint wf" "pfixwf" "Program Fixpoint # (#:#) {wf @{arg} @{f}} : # :=\n#." t)
+    ("Function" "func" "Function # (#:#) {struct @{arg}} : # :=\n#." t "Function")
+    ("Function measure" "funcm" "Function # (#:#) {measure @{f} @{arg}} : # :=\n#." t)
+    ("Function wf" "func wf" "Function # (#:#) {wf @{R} @{arg}} : # :=\n#." t)
+    ("Functional Scheme with" "fsw" "Functional Scheme @{name} := Induction for @{fun} with @{mutfuns}." t )
+    ("Functional Scheme" "fs" "Functional Scheme @{name} := Induction for @{fun}." t "Functional\\s-+Scheme")
+    ("Inductive" "indv" "Inductive # : # := # : #." t "Inductive")
+    ("Inductive (2 args)" "indv2" "Inductive # : # :=\n| # : #\n| # : #." t )
+    ("Inductive (3 args)" "indv3" "Inductive # : # :=\n| # : #\n| # : #\n| # : #." t )
+    ("Inductive (4 args)" "indv4" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t )
+    ("Inductive (5 args)" "indv5" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t )
+    ("Let" "Let" "Let # : # := #." t "Let")
+    ("Ltac" "ltac" "Ltac # := #" t "Ltac")
+    ("Module :=" "mo" "Module # : # := #." t ) ; careful
+    ("Module <: :=" "mo2" "Module # <: # := #." t ) ; careful
+    ("Module Import :=" "moi" "Module Import # : # := #." t ) ; careful
+    ("Module Import <: :=" "moi2" "Module Import # <: # := #." t ) ; careful
+    ("Module Export :=" "moe" "Module Export # : # := #." t ) ; careful
+    ("Module Export <: :=" "moe2" "Module Export# <: # := #." t ) ; careful
+    ("Record" "rec" "Record # : # := {\n# : #;\n# : # }" t "Record")
+    ("Scheme" "sc" "Scheme @{name} := #." t "Scheme")
+    ("Scheme Induction" "sci" "Scheme @{name} := Induction for # Sort #." t)
+    ("Scheme Minimality" "scm" "Scheme @{name} := Minimality for # Sort #." t)
+    ("Structure" "str" "Structure # : # := {\n# : #;\n# : # }" t "Structure")	
+    )
+  "Coq definition keywords information list. See `coq-syntax-db' for syntax. "
+  )
+
+;; modules and section are indented like goal starters
+(defvar coq-goal-starters-db
+  '(
+    ("Add Morphism" "addmor" "Add Morphism @{f} : @{id}" t "Add\\s-+Morphism")
+    ("Chapter" "chp" "Chapter # : #." t "Chapter")
+    ("Corollary" "cor" "Corollary # : #.\nProof.\n#\nQed." t "Corollary")
+    ("Declare Module :" "dmi" "Declare Module # : #.\n#\nEnd #." t)
+    ("Declare Module <:" "dmi2" "Declare Module # <: #.\n#\nEnd #." t)
+    ("Definition goal" "defg" "Definition #:#.\n#\nSave." t);; careful
+    ("Fact" "fct" "Fact # : #." t "Fact")
+    ("Goal" nil "Goal #." t "Goal")
+    ("Lemma" "l" "Lemma # : #.\nProof.\n#\nQed." t "Lemma")
+    ("Program Lemma" "pl" "Program Lemma # : #.\nProof.\n#\nQed." t "Program\\s-+Lemma")
+    ("Module! (interactive)" nil "Module # : #.\n#\nEnd #." nil nil coq-insert-section-or-module)
+    ("Module Type" "mti" "Module Type #.\n#\nEnd #." t "Module\\s-+Type") ; careful
+    ("Module :" "moi" "Module # : #.\n#\nEnd #." t "Module") ; careful
+    ("Module <:" "moi2" "Module # <: #.\n#\nEnd #." t ) ; careful
+    ("Remark" "rk" "Remark # : #.\n#\nQed." t "Remark")
+    ("Section" "sec" "Section #." t "Section")
+    ("Theorem" "th" "Theorem # : #.\n#\nQed." t "Theorem")
+    ("Program Theorem" "pth" "Program Theorem # : #.\nProof.\n#\nQed." t "Program\\s-+Theorem")
+    ("Obligation" "obl" "Obligation #.\n#\nQed." t "Obligation")
+    ("Next Obligation" "nobl" "Next Obligation.\n#\nQed." t "Next Obligation")
+    )
+  "Coq goal starters keywords information list. See `coq-syntax-db' for syntax. "
+  )
+
+;; command that are not declarations, definition or goal starters
+(defvar coq-other-commands-db
+   '(
+     ;; ("Abort" nil "Abort." t "Abort" nil nil);don't appear in menu
+     ("About" nil "About #." nil "About")
+     ("Add" nil "Add #." nil "Add" nil t)
+     ("Add Abstract Ring" nil "Add Abstract Ring #." t "Add\\s-+Abstract\\s-+Ring")
+     ("Add Abstract Semi Ring" nil "Add Abstract Semi Ring #." t "Add\\s-+Abstract\\s-+Semi\\s-+Ring")
+     ("Add Field" nil "Add Field #." t "Add\\s-+Field")
+     ("Add LoadPath" nil "Add LoadPath #." nil "Add\\s-+LoadPath")
+     ("Add ML Path" nil "Add ML Path #." nil "Add\\s-+ML\\s-+Path")
+     ("Add Morphism" nil "Add Morphism #." t "Add\\s-+Morphism")
+     ("Add Printing" nil "Add Printing #." t "Add\\s-+Printing")
+     ("Add Printing If" nil "Add Printing If #." t "Add\\s-+Printing\\s-+If")
+     ("Add Printing Let" nil "Add Printing Let #." t "Add\\s-+Printing\\s-+Let")
+     ("Add Rec LoadPath" nil "Add Rec LoadPath #." nil "Add\\s-+Rec\\s-+LoadPath")
+     ("Add Rec ML Path" nil "Add Rec ML Path #." nil "Add\\s-+Rec\\s-+ML\\s-+Path")
+     ("Add Ring" nil "Add Ring #." t "Add\\s-+Ring")
+     ("Add Semi Ring" nil "Add Semi Ring #." t "Add\\s-+Semi\\s-+Ring")
+     ("Add Setoid" nil "Add Setoid #." t "Add\\s-+Setoid")
+     ("Admit Obligations" "oblsadmit" "Admit Obligations." nil "Admit\\s-+Obligations")
+     ("Arguments Scope" "argsc" "Arguments Scope @{id} [ @{_} ]" t "Arguments\\s-+Scope")
+     ("Bind Scope" "bndsc" "Bind Scope @{scope} with @{type}" t "Bind\\s-+Scope")
+     ("Canonical Structure" nil "Canonical Structure #." t "Canonical\\s-+Structure")
+     ("Cd" nil "Cd #." nil "Cd")
+     ("Check" nil "Check" nil "Check")
+     ("Close Local Scope" "cllsc" "Close Local Scope #" t "Close\\s-+Local\\s-+Scope")
+     ("Close Scope" "clsc" "Close Scope #" t "Close\\s-+Scope")
+     ("Comments" nil "Comments #." nil "Comments")
+     ("Delimit Scope" "delsc" "Delimit Scope @{scope} with @{id}." t "Delimit\\s-+Scope" )
+     ("Eval" nil "Eval #." nil "Eval")
+     ("Export" nil "Export #." t "Export")
+     ("Extract Constant" "extrc" "Extract Constant @{id} => \"@{id}\"." nil "Extract\\s-+Constant")
+     ("Extract Inlined Constant" "extric" "Extract Inlined Constant @{id} => \"@{id}\"." nil "Extract\\s-+Inlined\\s-+Constant")
+     ("Extract Inductive" "extri" "Extract Inductive @{id} => \"@{id}\" [\"@{id}\" \"@{id...}\"]." nil "Extract")
+     ("Extraction" "extr" "Extraction @{id}." nil "Extraction")
+     ("Extraction (in a file)" "extrf" "Extraction \"@{file}\" @{id}." nil)
+     ("Extraction Inline" nil "Extraction Inline #." t "Extraction\\s-+Inline")
+     ("Extraction NoInline" nil "Extraction NoInline #." t "Extraction\\s-+NoInline")
+     ("Extraction Language" "extrlang" "Extraction Language #." t "Extraction\\s-+Language")
+     ("Extraction Library" "extrl" "Extraction Library @{id}." nil "Extraction\\s-+Library")
+     ("Focus" nil "Focus #." nil "Focus")
+     ("Identity Coercion" nil "Identity Coercion #." t "Identity\\s-+Coercion")
+     ("Implicit Arguments Off" nil "Implicit Arguments Off." t "Implicit\\s-+Arguments\\s-+Off")
+     ("Implicit Arguments On" nil "Implicit Arguments On." t "Implicit\\s-+Arguments\\s-+On")
+     ("Implicit Arguments" nil "Implicit Arguments # [#]." t "Implicit\\s-+Arguments")
+     ("Import" nil "Import #." t "Import")
+     ("Infix" "inf" "Infix \"#\" := # (at level #) : @{scope}." t "Infix")
+     ("Inspect" nil "Inspect #." nil "Inspect")
+     ("Locate" nil "Locate" nil "Locate")
+     ("Locate File" nil "Locate File \"#\"." nil "Locate\\s-+File")
+     ("Locate Library" nil "Locate Library #." nil "Locate\\s-+Library")
+     ("Notation (assoc)" "notas" "Notation \"#\" := # (at level #, # associativity)." t)
+     ("Notation (at assoc)" "notassc" "Notation \"#\" := # (at level #, # associativity) : @{scope}." t)
+     ("Notation (at at scope)" "notasc" "Notation \"#\" := # (at level #, # at level #) : @{scope}." t)
+     ("Notation (at at)" "nota" "Notation \"#\" := # (at level #, # at level #)." t)
+     ("Notation (only parsing)" "notsp" "Notation # := # (only parsing)." t)
+     ("Notation Local (only parsing)" "notslp" "Notation Local # := # (only parsing)." t)
+     ("Notation Local" "notsl" "Notation Local # := #." t "Notation\\s-+Local")
+     ("Notation (simple)" "nots" "Notation # := #." t "Notation")
+     ("Opaque" nil "Opaque #." nil "Opaque")
+     ("Obligations Tactic" nil "Obligations Tactic := #." t "Obligations\\s-+Tactic")
+     ("Open Local Scope" "oplsc" "Open Local Scope #" t "Open\\s-+Local\\s-+Scope")
+     ("Open Scope" "opsc" "Open Scope #" t "Open\\s-+Scope")
+     ("Print Coercions" nil "Print Coercions." nil "Print\\s-+Coercions")
+     ("Print Hint" nil "Print Hint." nil "Print\\s-+Hint" coq-PrintHint)
+     ("Print" "p" "Print #." nil "Print")
+     ("Qed" nil "Qed." nil "Qed")
+     ("Pwd" nil "Pwd." nil "Pwd")
+     ("Recursive Extraction" "recextr" "Recursive Extraction @{id}." nil "Recursive\\s-+Extraction")
+     ("Recursive Extraction Library" "recextrl" "Recursive Extraction Library @{id}." nil "Recursive\\s-+Extraction\\s-+Library")
+     ("Recursive Extraction Module" "recextrm" "Recursive Extraction Module @{id}." nil "Recursive\\s-+Extraction\\s-+Module")
+     ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath")
+     ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath")
+     ("Remove Printing If" nil "Remove Printing If #." t "Remove\\s-+Printing\\s-+If")
+     ("Remove Printing Let" nil "Remove Printing Let #." t "Remove\\s-+Printing\\s-+Let")
+     ("Require Export" nil "Require Export #." t "Require\\s-+Export")
+     ("Require Import" nil "Require Import #." t "Require\\s-+Import")
+     ("Require" nil "Require #." t "Require")
+     ("Reserved Notation" nil "Reserved Notation" nil "Reserved\\s-+Notation")
+     ("Reset Extraction Inline" nil "Reset Extraction Inline." t "Reset\\s-+Extraction\\s-+Inline")
+     ("Save" nil "Save." t "Save")
+     ("Search" nil "Search #" nil "Search")
+     ("SearchAbout" nil "SearchAbout #" nil "SearchAbout")
+     ("SearchPattern" nil "SearchPattern #" nil "SearchPattern")
+     ("SearchRewrite" nil "SearchRewrite #" nil "SearchRewrite")
+     ("Set Extraction AutoInline" nil "Set Extraction AutoInline" t "Set\\s-+Extraction\\s-+AutoInline")
+     ("Set Extraction Optimize" nil "Set Extraction Optimize" t "Set\\s-+Extraction\\s-+Optimize")
+     ("Set Implicit Arguments" nil "Set Implicit Arguments" t "Set\\s-+Implicit\\s-+Arguments")
+     ("Set Strict Implicit" nil "Set Strict Implicit" t "Set\\s-+Strict\\s-+Implicit")
+     ("Set Printing Synth" nil "Set Printing Synth" t "Set\\s-+Printing\\s-+Synth")
+     ("Set Printing Wildcard" nil "Set Printing Wildcard" t "Set\\s-+Printing\\s-+Wildcard")
+     ("Set Printing All" "sprall" "Set Printing All" t "Set\\s-+Printing\\s-+All")
+     ("Set Hyps Limit" nil "Set Hyps Limit #." nil "Set\\s-+Hyps\\s-+Limit")
+     ("Set Printing Coercions" nil "Set Printing Coercions." t "Set\\s-+Printing\\s-+Coercions")
+     ("Set Printing Notations" "sprn" "Set Printing Notations" t "Set\\s-+Printing\\s-+Notations")
+     ("Set Undo" nil "Set Undo #." nil "Set\\s-+Undo")
+     ("Show" nil "Show #." nil "Show")
+     ("Solve Obligations" "oblssolve" "Solve Obligations using #." nil "Solve\\s-+Obligations")
+     ("Test" nil "Test" nil "Test" nil t)
+     ("Test Printing Depth" nil "Test Printing Depth." nil "Test\\s-+Printing\\s-+Depth")
+     ("Test Printing If" nil "Test Printing If #." nil "Test\\s-+Printing\\s-+If")
+     ("Test Printing Let" nil "Test Printing Let #." nil "Test\\s-+Printing\\s-+Let")
+     ("Test Printing Synth" nil "Test Printing Synth." nil "Test\\s-+Printing\\s-+Synth")
+     ("Test Printing Width" nil "Test Printing Width." nil "Test\\s-+Printing\\s-+Width")
+     ("Test Printing Wildcard" nil "Test Printing Wildcard." nil "Test\\s-+Printing\\s-+Wildcard")
+     ("Transparent" nil "Transparent #." nil "Transparent")
+     ("Unfocus" nil "Unfocus." nil "Unfocus")
+     ("Unset Extraction AutoInline" nil "Unset Extraction AutoInline" t "Unset\\s-+Extraction\\s-+AutoInline")
+     ("Unset Extraction Optimize" nil "Unset Extraction Optimize" t "Unset\\s-+Extraction\\s-+Optimize")
+     ("Unset Implicit Arguments" nil "Unset Implicit Arguments" t "Unset\\s-+Implicit\\s-+Arguments")
+     ("Unset Strict Implicit" nil "Unset Strict Implicit" t "Unset\\s-+Strict\\s-+Implicit")
+     ("Unset Printing Synth" nil "Unset Printing Synth" t "Unset\\s-+Printing\\s-+Synth")
+     ("Unset Printing Wildcard" nil "Unset Printing Wildcard" t "Unset\\s-+Printing\\s-+Wildcard")
+     ("Unset Hyps Limit" nil "Unset Hyps Limit" nil "Unset\\s-+Hyps\\s-+Limit")
+     ("Unset Printing All" "unsprall" "Unset Printing All" nil "Unset\\s-+Printing\\s-+All")
+     ("Unset Printing Coercion" nil "Unset Printing Coercion #." t "Unset\\s-+Printing\\s-+Coercion")
+     ("Unset Printing Coercions" nil "Unset Printing Coercions." nil "Unset\\s-+Printing\\s-+Coercions")
+     ("Unset Printing Notations" "unsprn" "Unset Printing Notations" nil "Unset\\s-+Printing\\s-+Notations")
+     ("Unset Undo" nil "Unset Undo." nil "Unset\\s-+Undo")
+ ;    ("print" "pr" "print #" "print")
+     )   
+   "Command that are not declarations, definition or goal starters."
+  )
+
+(defvar coq-commands-db
+  (append coq-decl-db coq-defn-db coq-goal-starters-db
+          coq-other-commands-db coq-user-commands-db)
+  "Coq all commands keywords information list. See `coq-syntax-db' for syntax. "      
+  )
+
+
+(defvar coq-terms-db
+  '(
+    ("fun (1 args)" "f" "fun #:# => #" nil "fun")
+    ("fun (2 args)" "f2" "fun (#:#) (#:#) => #")
+    ("fun (3 args)" "f3" "fun (#:#) (#:#) (#:#) => #")
+    ("fun (4 args)" "f4" "fun (#:#) (#:#) (#:#) (#:#) => #")
+    ("forall" "fo" "forall #:#,#" nil "forall")
+    ("forall (2 args)" "fo2" "forall (#:#) (#:#), #")
+    ("forall (3 args)" "fo3" "forall (#:#) (#:#) (#:#), #")
+    ("forall (4 args)" "fo4" "forall (#:#) (#:#) (#:#) (#:#), #")
+    ("if" "if" "if # then # else #" nil "if")
+    ("let in" "li" "let # := # in #" nil "let")
+    ("match! (from type)" nil "" nil "match" coq-insert-match)
+    ("match with" "m" "match # with\n| # => #\nend")
+    ("match with 2" "m2" "match # with\n| # => #\n| # => #\nend")
+    ("match with 3" "m3" "match # with\n| # => #\n| # => #\n| # => #\nend")
+    ("match with 4" "m4" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\nend")
+    ("match with 5" "m5" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\n| # => #\nend")
+    )
+  "Coq terms keywords information list. See `coq-syntax-db' for syntax. "
+  )
+
+
+
+
+
+
+
+ ;;; Goals (and module/sections) starters detection
+
+
+;; ----- keywords for font-lock.
+
+;; FIXME da: this one function breaks the nice configuration of Proof General:
+;; would like to have proof-goal-regexp instead.
+;; Unfortunately Coq allows "Definition" and friends to perhaps have a goal, 
+;; so it appears more difficult than just a proof-goal-regexp setting.
+;; Future improvement may simply to be allow a function value for
+;; proof-goal-regexp.
+
+;; FIXME Pierre: the right way IMHO here would be to set a span
+;; property 'goalcommand when coq prompt says it (if the name of
+;; current proof has changed).
+
+;; excerpt of Jacek Chrzaszcz, implementer of the module system: sorry
+;; for the french:
+;;*) suivant les suggestions de Chritine, pas de mode preuve dans un type de
+;;    module (donc pas de Definition truc:machin.  Lemma, Theorem ... )
+;;
+;; *) la commande Module M [ ( : | <: ) MTYP ] [ := MEXPR ] est valable
+;;    uniquement hors d'un MT
+;;    - si :=MEXPR est absent, elle demarre un nouveau module interactif
+;;    - si :=MEXPR est present, elle definit un module
+;;    (la fonction vernac_define_module dans toplevel/vernacentries) 
+;;
+;; *) la nouvelle commande Declare Module M [ ( : | <: ) MTYP ] [ := MEXPR ]
+;;    est valable uniquement dans un MT
+;;    - si :=MEXPR absent, :MTYP absent, elle demarre un nouveau module
+;;      interactif
+;;    - si (:=MEXPR absent, :MTYP present) 
+;;      ou (:=MEXPR present, :MTYP absent)
+;;      elle declare un module.
+;;    (la fonction vernac_declare_module dans toplevel/vernacentries)
+
+(defun coq-count-match (regexp strg)
+  "Count the number of (maximum, non overlapping) matching substring 
+ of STRG matching REGEXP. Empty match are counted once."
+  (let ((nbmatch 0) (str strg))
+    (while (and (proof-string-match regexp str) (not (string-equal str "")))
+      (incf nbmatch)
+      (if (= (match-end 0) 0) (setq str (substring str 1))
+        (setq str (substring str (match-end 0)))))
+    nbmatch))
+
+;; This function is used for amalgamating a proof into a single
+;; goal-save region (proof-goal-command-p used in
+;; proof-done-advancing-save in generic/proof-script.el) for coq <
+;; 8.0. It is the test when looking backward the start of the proof.
+;; It is NOT used for coq > v8.1
+;; (coq-find-and-forget in coq.el uses state numbers, proof numbers and
+;; lemma names given in the prompt)
+
+;; compatibility with v8.0, will delete it some day
+(defun coq-goal-command-str-v80-p (str)
+  "See `coq-goal-command-p'."
+  (let* ((match (coq-count-match "\\<match\\>" str))
+	 (with (coq-count-match "\\<with\\>" str))
+	 (letwith (+ (coq-count-match "\\<let\\>" str) (- with match)))
+	 (affect (coq-count-match ":=" str)))
+
+    (and (proof-string-match coq-goal-command-regexp str)
+ 	 (not				; 
+ 	  (and 
+ 	   (proof-string-match "\\`\\(Local\\|Definition\\|Lemma\\|Module\\)\\>" str)
+ 	   (not (= letwith affect))))
+ 	 (not (proof-string-match "\\`Declare\\s-+Module\\(\\w\\|\\s-\\|<\\)*:" str))
+ 	 )
+    )
+  )
+
+;; Module and or section openings are detected syntactically. Module
+;; *openings* are difficult to detect because there can be Module
+;; ...with X := ... . So we need to count :='s to detect real openings.
+
+;; TODO: have opened section/chapter in the prompt too, and get rid of
+;; syntactical tests everywhere
+(defun coq-module-opening-p (str)
+  "Decide whether STR is a module or section opening or not. 
+Used by `coq-goal-command-p'"
+  (let* ((match (coq-count-match "\\<match\\>" str))
+ 	 (with (coq-count-match "\\<with\\>" str))
+ 	 (letwith (+ (coq-count-match "\\<let\\>" str) (- with match)))
+ 	 (affect (coq-count-match ":=" str)))
+    (and (proof-string-match "\\`\\(Module\\)\\>" str)
+ 	 (= letwith affect))
+    ))
+
+(defun coq-section-command-p (str)
+  (proof-string-match "\\`\\(Section\\|Chapter\\)\\>" str))
+
+
+(defun coq-goal-command-str-v81-p (str)
+  "Decide syntactically whether STR is a goal start or not. Use
+   `coq-goal-command-p-v81' on a span instead if possible."
+  (coq-goal-command-str-v80-p str)
+  )
+
+;; This is the function that tests if a SPAN is a goal start. All it
+;; has to do is look at the 'goalcmd attribute of the span.
+;; It also looks if this is not a module start.
+
+;; TODO: have also attributes 'modulecmd and 'sectioncmd. This needs
+;; something in the coq prompt telling the name of all opened modules
+;; (like for open goals), and use it to set goalcmd --> no more need
+;; to look at Modules and section (actually indentation will still
+;; need it)
+(defun coq-goal-command-p-v81 (span)
+  "see `coq-goal-command-p'"
+  (or (span-property span 'goalcmd)
+      ;; module and section starts are detected here
+      (let ((str (or (span-property span 'cmd) "")))
+ 	(or (coq-section-command-p str)
+ 	    (coq-module-opening-p str))
+        )))
+
+;; In coq > 8.1 This is used only for indentation.
+(defun coq-goal-command-str-p (str)
+  "Decide whether argument is a goal or not.  Use
+   `coq-goal-command-p' on a span instead if posible."
+  (cond 
+   (coq-version-is-V8-1 (coq-goal-command-str-v81-p str))
+   (coq-version-is-V8-0 (coq-goal-command-str-v80-p str))
+   (t (coq-goal-command-str-v80-p str));; this is temporary
+   ))
+
+;; This is used for backtracking
+(defun coq-goal-command-p (span)
+  "Decide whether argument is a goal or not."
+  (cond 
+   (coq-version-is-V8-1 (coq-goal-command-p-v81 span))
+   (coq-version-is-V8-0 (coq-goal-command-str-v80-p (span-property span 'cmd)))
+   (t (coq-goal-command-str-v80-p (span-property span 'cmd)));; this is temporary
+   ))
+
+(defvar coq-keywords-save-strict
+  '("Defined"
+    "Save"
+    "Qed"
+    "End"
+    "Admitted"
+    "Abort"
+    ))
+
+(defvar coq-keywords-save
+  (append coq-keywords-save-strict '("Proof"))
+  )
+
+(defun coq-save-command-p (span str)
+  "Decide whether argument is a Save command or not"
+  (or (proof-string-match coq-save-command-regexp-strict str)
+      (and (proof-string-match "\\`Proof\\>" str)
+           (not (proof-string-match "Proof\\s-*\\(\\.\\|\\<with\\>\\)" str)))
+      )
+  )
+
+
+(defvar coq-keywords-kill-goal 
+  '("Abort"))
+
+;; Following regexps are all state changing
+(defvar coq-keywords-state-changing-misc-commands
+  (coq-build-regexp-list-from-db coq-commands-db 'filter-state-changing))
+
+(defvar coq-keywords-goal
+  (coq-build-regexp-list-from-db coq-goal-starters-db))
+
+(defvar coq-keywords-decl
+  (coq-build-regexp-list-from-db coq-decl-db))
+
+(defvar coq-keywords-defn
+  (coq-build-regexp-list-from-db coq-defn-db))
+
+
+(defvar coq-keywords-state-changing-commands
+  (append
+   coq-keywords-state-changing-misc-commands
+   coq-keywords-decl                    ; all state changing
+   coq-keywords-defn                    ; idem
+   coq-keywords-goal))                  ; idem
+
+
+;; 
+(defvar coq-keywords-state-preserving-commands
+  (coq-build-regexp-list-from-db coq-commands-db 'filter-state-preserving))
+
+;; concat this is faster that redoing coq-build-regexp-list-from-db on
+;; whole commands-db
+(defvar coq-keywords-commands
+  (append coq-keywords-state-changing-commands
+ 	  coq-keywords-state-preserving-commands)
+  "All commands keyword.")
+
+(defvar coq-solve-tactics
+  (coq-build-regexp-list-from-db coq-solve-tactics-db)
+  "Keywords for closing tactic(al)s.")
+
+(defvar coq-tacticals
+  (coq-build-regexp-list-from-db coq-tacticals-db)
+  "Keywords for tacticals in a Coq script.")
+
+
+ ;; From JF Monin:
+(defvar coq-reserved
+  (append 
+   coq-user-reserved-db
+   '(
+     "False" "True" "after" "as" "cofix" "fix" "forall" "fun" "match"
+     "return" "struct" "else" "end" "if" "in" "into" "let" "then"
+     "using" "with" "beta" "delta" "iota" "zeta" "after" "until"
+     "at" "Sort" "Time"))
+  "Reserved keywords of Coq.")
+
+
+(defvar coq-state-changing-tactics
+  (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-changing))
+
+(defvar coq-state-preserving-tactics
+  (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-preserving))
+
+
+(defvar coq-tactics
+  (append coq-state-changing-tactics coq-state-preserving-tactics))
+
+(defvar coq-retractable-instruct
+  (append coq-state-changing-tactics coq-keywords-state-changing-commands))
+
+(defvar coq-non-retractable-instruct
+  (append coq-state-preserving-tactics
+          coq-keywords-state-preserving-commands))
+
+(defvar coq-keywords
+  (append coq-keywords-goal coq-keywords-save coq-keywords-decl
+ 	  coq-keywords-defn coq-keywords-commands)
+  "All keywords in a Coq script.")
+
+
+
+(defvar coq-symbols
+  '("|"
+    "||"
+    ":"
+    ";"
+    ","
+    "("
+    ")"
+    "["
+    "]"
+    "{"
+    "}"
+    ":="
+    "=>"
+    "->"
+    ".")
+  "Punctuation Symbols used by Coq.")
+
+;; ----- regular expressions
+(defvar coq-error-regexp "^\\(Error:\\|Discarding pattern\\|Syntax error:\\|System Error:\\|User Error:\\|User error:\\|Anomaly[:.]\\|Toplevel input[,]\\)"
+  "A regexp indicating that the Coq process has identified an error.")
+
+(defvar coq-id proof-id)
+(defvar coq-id-shy "\\(?:\\w\\(?:\\w\\|\\s_\\)*\\)")
+
+(defvar coq-ids (proof-ids coq-id " "))
+
+(defun coq-first-abstr-regexp (paren end)
+  (concat paren "\\s-*\\(" coq-ids "\\)\\s-*" end))
+
+(defcustom coq-variable-highlight-enable t
+  "Activates partial bound variable highlighting"
+  :type 'boolean
+  :group 'coq)
+
+
+(defvar coq-font-lock-terms
+  (if coq-variable-highlight-enable
+  (list
+   ;; lambda binders
+   (list (coq-first-abstr-regexp "\\<fun\\>" "\\(?:=>\\|:\\)") 1 'font-lock-variable-name-face)
+   ;; forall binder
+   (list (coq-first-abstr-regexp "\\<forall\\>" "\\(?:,\\|:\\)") 1 'font-lock-variable-name-face)
+                                        ;   (list "\\<forall\\>"
+                                        ;         (list 0 font-lock-type-face)
+                                        ;         (list (concat "[^ :]\\s-*\\(" coq-ids "\\)\\s-*") nil nil 
+                                        ;               (list 0 font-lock-variable-name-face)))
+   ;; parenthesized binders
+   (list (coq-first-abstr-regexp "(" ":[ a-zA-Z]") 1 'font-lock-variable-name-face)
+   ))
+  "*Font-lock table for Coq terms.")
+
+
+
+;; According to Coq, "Definition" is both a declaration and a goal.
+;; It is understood here as being a goal.  This is important for
+;; recognizing global identifiers, see coq-global-p.
+(defconst coq-save-command-regexp-strict
+  (proof-anchor-regexp 
+   (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict)
+           "\\)")))
+(defconst coq-save-command-regexp
+  (proof-anchor-regexp 
+   (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save)
+           "\\)")))
+(defconst coq-save-with-hole-regexp
+  (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict)
+ 	  "\\)\\s-+\\(" coq-id "\\)\\s-*\\."))
+
+(defconst coq-goal-command-regexp
+  (proof-anchor-regexp (proof-ids-to-regexp coq-keywords-goal)))
+
+(defconst coq-goal-with-hole-regexp
+  (concat "\\(" (proof-ids-to-regexp coq-keywords-goal)
+ 	  "\\)\\s-+\\(" coq-id "\\)\\s-*:?"))
+
+(defconst coq-decl-with-hole-regexp
+  (concat "\\(" (proof-ids-to-regexp coq-keywords-decl)
+ 	  "\\)\\s-+\\(" coq-ids "\\)\\s-*:"))
+
+;;  (defconst coq-decl-with-hole-regexp
+;;    (if coq-variable-highlight-enable coq-decl-with-hole-regexp-1 'nil))
+
+(defconst coq-defn-with-hole-regexp
+  (concat "\\(" (proof-ids-to-regexp coq-keywords-defn)
+          "\\)\\s-+\\(" coq-id "\\)"))
+
+;; must match:
+;; "with f x y :" (followed by = or not)
+;; "with f x y (z:" (not followed by =)
+;; BUT NOT:
+;; "with f ... (x:=" 
+;; "match ... with .. => "
+(defconst coq-with-with-hole-regexp
+  (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^=(.]*:\\|[^(]*(\\s-*" 
+          coq-id "\\s-*:[^=]\\)"))
+;; marche aussi a peu pres
+;;  (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^(.]*:\\|.*)[^(.]*:=\\)"))
+;;"\\<Prop\\>\\|\\<Set\\>\\|\\<Type\\>"
+(defvar coq-font-lock-keywords-1
+   (append
+    coq-font-lock-terms
+    (list
+    (cons (proof-ids-to-regexp coq-solve-tactics) 'coq-solve-tactics-face)
+    (cons (proof-ids-to-regexp coq-keywords) 'font-lock-keyword-face)
+    (cons (proof-ids-to-regexp coq-reserved) 'font-lock-type-face)
+    (cons (proof-ids-to-regexp coq-tactics ) 'proof-tactics-name-face)
+    (cons (proof-ids-to-regexp coq-tacticals) 'proof-tacticals-name-face)
+    (cons (proof-ids-to-regexp (list "Set" "Type" "Prop")) 'font-lock-type-face)
+    (cons "============================" 'font-lock-keyword-face)
+    (cons "Subtree proved!" 'font-lock-keyword-face)
+    (cons "subgoal [0-9]+ is:" 'font-lock-keyword-face)
+    (list "^\\([^ \n]+\\) \\(is defined\\)"
+          (list 2 'font-lock-keyword-face t)
+          (list 1 'font-lock-function-name-face t))
+
+    (list coq-goal-with-hole-regexp 2 'font-lock-function-name-face))
+    (if coq-variable-highlight-enable (list (list coq-decl-with-hole-regexp 2 'font-lock-variable-name-face)))
+    (list
+    (list coq-defn-with-hole-regexp 2 'font-lock-function-name-face)
+    (list coq-with-with-hole-regexp 2 'font-lock-function-name-face)
+    (list coq-save-with-hole-regexp 2 'font-lock-function-name-face)
+    ;; Remove spurious variable and function faces on commas.
+    '(proof-zap-commas))))
+
+(defvar coq-font-lock-keywords coq-font-lock-keywords-1)
+
+(defun coq-init-syntax-table ()
+  "Set appropriate values for syntax table in current buffer."
+
+  (modify-syntax-entry ?\$ ".")
+  (modify-syntax-entry ?\/ ".")
+  (modify-syntax-entry ?\\ ".")
+  (modify-syntax-entry ?+  ".")
+  (modify-syntax-entry ?-  ".")
+  (modify-syntax-entry ?=  ".")
+  (modify-syntax-entry ?%  ".")
+  (modify-syntax-entry ?<  ".")
+  (modify-syntax-entry ?>  ".")
+  (modify-syntax-entry ?\& ".")
+  (modify-syntax-entry ?_  "_")
+  (modify-syntax-entry ?\' "_")
+  (modify-syntax-entry ?\| ".")
+
+;; should maybe be "_" but it makes coq-find-and-forget (in coq.el) bug
+  (modify-syntax-entry ?\. ".") 
+
+  (condition-case nil
+      ;; Try to use Emacs-21's nested comments.
+      (modify-syntax-entry ?\* ". 23n")
+    ;; Revert to non-nested comments if that failed.
+    (error (modify-syntax-entry ?\* ". 23")))
+  (modify-syntax-entry ?\( "()1")
+  (modify-syntax-entry ?\) ")(4"))
+
+
+(defconst coq-generic-expression
+  (mapcar (lambda (kw) 
+ 	    (list (capitalize kw)
+ 		  (concat "\\<" kw "\\>" "\\s-+\\(\\w+\\)\\W" )
+ 		  1))
+ 	  (append coq-keywords-decl coq-keywords-defn coq-keywords-goal)))
+
+(provide 'coq-syntax)
+ ;;; coq-syntax.el ends here
+
+; Local Variables: ***
+; indent-tabs-mode: nil ***
+; End: ***
diff --git a/tools/coq.el b/tools/coq.el
index 0eb04d8d..f4c4b033 100644
--- a/tools/coq.el
+++ b/tools/coq.el
@@ -5,6 +5,12 @@
 ;;
 ;; modified by Marco Maggesi <maggesi@math.unifi.it> for coq-inferior
 
+; compatibility code for proofgeneral files
+(require 'coq-font-lock)
+; ProofGeneral files. remember to remove coq version tests in
+; coq-syntax.el
+(require 'coq-syntax)
+
 (defvar coq-mode-map nil
   "Keymap used in Coq mode.")
 (if coq-mode-map
@@ -57,7 +63,9 @@
   (make-local-variable 'parse-sexp-ignore-comments)
   (setq parse-sexp-ignore-comments nil)
   (make-local-variable 'indent-line-function)
-  (setq indent-line-function 'coq-indent-command))
+  (setq indent-line-function 'coq-indent-command)
+  (make-local-variable 'font-lock-keywords)
+  (setq font-lock-defaults '(coq-font-lock-keywords-1)))
 
 ;;; The major mode
 
@@ -129,54 +137,6 @@ Does nothing otherwise."
              (coq-in-indentation))
         (backward-delete-char-untabify coq-mode-indentation))))
 
-;;; Hilight
-
-(cond 
- (window-system
-  (setq hilit-mode-enable-list  '(not text-mode)
-        hilit-inhibit-hooks     nil
-        hilit-inhibit-rebinding nil)
-  
-  (require 'hilit19)
-       (setq  hilit-quietly t)
-       (hilit-set-mode-patterns
-        'coq-mode
-        '(;;comments
-          ("(\\*" "\\*)" comment)
-          ;;strings
-          (hilit-string-find ?' string)
-	  ;;directives
-          ("^[ \t]*\\(AddPath\\|DelPath\\|Add[ \t]+ML[ \t]+Path\\|Declare[ \t]+ML[ \t]+Module\\|Require\\|Export\\|Module\\|Opaque\\|Transparent\\|Section\\|Chapter\\|End\\|Load\\|Print\\|Show\\)[ \t]+[^.]*" nil include)
-	  ("Implicit[ \t]+Arguments[ \t]+\\(On\\|Off\\)[^.]*" nil include)
-          ;;grammar definitions
-	  ("^[ \t]*Syntax[ \t]+\\(tactic\\|command\\)" nil define)
-	  ("^[ \t]*Syntax[ \t]+\\(tactic\\|command\\)[ \t]*level[ \t]+[0-9]+[ \t]*" nil define)
-	  ("^[ \t]*level[ \t]+[0-9]+[ \t]*:" nil define)
-	  ("^[ \t]*Grammar.*" ":=" define)
-          ("^[ \t]*Tactic[ \t]+Definition" ":=" define) 
-	  ("^[ \t]*Token[^.]*" nil define)
-	  ("^[ \t]*\\(Coercion\\|Class\\|Infix\\)[ \t]+[[A-Za-z0-9$_\\']+" nil define)
-          ;;declarations
-	  ("^[ \t]*Recursive[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-          ("^[ \t]*Syntactic[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-          ("^[ \t]*Tactic[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-	  ("^[ \t]*Inductive[ \t]+\\(Set\\|Prop\\|Type\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-	  ("^[ \t]*Mutual[ \t]+\\(Inductive\\|CoInductive\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-	  ("^[ \t]*\\(Inductive\\|CoInductive\\|CoFixpoint\\|Definition\\|Local\\|Fixpoint\\|with\\|Record\\|Correctness\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-	  ("^[ \t]*\\(Derive\\|Dependant[ \t]+Derive\\)[ \t]+\\(Inversion\\|Inversion_clear\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
-	  ("^[ \t]*\\(Variable\\|Parameter\\|Hypothesis\\).*" ":" defun)
-	  ("^[ \t]*\\(Global[ \t]+Variable\\).*" ":" defun)
-	  ("^[ \t]*\\(Realizer[ \t]+Program\\|Realizer\\)" nil defun)
-	  ;;proofs
-	  ("^[ \t]*\\(Lemma\\|Theorem\\|Remark\\|Axiom\\).*" ":" defun)
-	  ("^[ \t]*Proof" nil decl)
-	  ("^[ \t]*\\(Save\\|Qed\\|Defined\\|Hint\\|Immediate\\)[^.]*" nil decl)
-          ;;keywords
-          ("[^_]\\<\\(Case\\|Cases\\|case\\|esac\\|of\\|end\\|in\\|Match\\|with\\|Fix\\|let\\|if\\|then\\|else\\)\\>[^_]" 1 keyword)
-          ("[^_]\\<\\(begin\\|assert\\|invariant\\|variant\\|for\\|while\\|do\\|done\\|state\\)\\>[^_]" 1 keyword)
-          ))
-))
-
 ;;; coq.el ends here
 
 (provide 'coq)
diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4
index 3ca1e7d3..338aba99 100644
--- a/tools/coq_makefile.ml4
+++ b/tools/coq_makefile.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_makefile.ml4 12470 2009-11-05 15:50:20Z notin $ *)
+(* $Id$ *)
 
 (* créer un Makefile pour un développement Coq automatiquement *)
 
@@ -42,7 +42,7 @@ let rec print_list sep = function
 let list_iter_i f =
   let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1
 
-let best_ocamlc = 
+let best_ocamlc =
   if Coq_config.best = "opt" then "ocamlc.opt" else "ocamlc"
 let best_ocamlopt =
   if Coq_config.best = "opt" then "ocamlopt.opt" else "ocamlopt"
@@ -85,7 +85,7 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom
 [-impredicative-set]: compile with option -impredicative-set of coq
 [-no-install]: build a makefile with no install target
 [-f file]: take the contents of file as arguments
-[-o file]: output should go in file file 
+[-o file]: output should go in file file
 [-h]: print this usage summary
 [--help]: equivalent to [-h]\n";
   exit 1
@@ -208,16 +208,14 @@ let make_makefile sds =
 
 let clean sds sps =
   print "clean:\n";
-  print "\trm -f $(VOFILES) $(VIFILES) $(GFILES) *~\n";
+  print "\trm -f $(CMOFILES) $(CMIFILES) $(CMXFILES) $(CMXSFILES) $(OFILES) $(VOFILES) $(VIFILES) $(GFILES) $(MLFILES:.ml=.cmo) $(MLFILES:.ml=.cmx) *~\n";
   print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(HTMLFILES) \
          $(GHTMLFILES) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) $(VFILES:.v=.v.d)\n";
   if !some_mlfile then
     print "\trm -f $(CMOFILES) $(MLFILES:.ml=.cmi) $(MLFILES:.ml=.ml.d) $(MLFILES:.ml=.cmx) $(MLFILES:.ml=.o)\n";
-  if Coq_config.has_natdynlink && !some_mlfile then
-    print "\trm -f $(CMXSFILES) $(CMXSFILES:.cmxs=.o)\n";
   print "\t- rm -rf html\n";
   List.iter
-    (fun (file,_,_) -> 
+    (fun (file,_,_) ->
        if not (is_genrule file) then
 	 (print "\t- rm -f "; print file; print "\n"))
     sps;
@@ -235,8 +233,8 @@ let clean sds sps =
   print "\t@echo CAMLP4LIB =\t$(CAMLP4LIB)\n\n"
 
 let header_includes () = ()
-  
-let footer_includes () = 
+
+let footer_includes () =
   if !some_vfile then print "-include $(VFILES:.v=.v.d)\n.SECONDARY: $(VFILES:.v=.v.d)\n\n";
   if !some_mlfile then print "-include $(MLFILES:.ml=.ml.d)\n.SECONDARY: $(MLFILES:.ml=.ml.d)\n\n"
 
@@ -250,17 +248,17 @@ let implicit () =
     print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
     print "%.cmxs: %.ml4\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $(PP) -impl $<\n\n";
     print "%.ml.d: %.ml\n";
-    print "\t$(CAMLBIN)ocamldep -slash $(COQSRCLIBS) $(OCAMLLIBS) $(PP) \"$<\" > \"$@\"\n\n"
+    print "\t$(CAMLBIN)ocamldep -slash $(OCAMLLIBS) $(PP) \"$<\" > \"$@\"\n\n"
   and v_rule () =
-    print "%.vo %.glob: %.v\n\t$(COQC) -dump-glob $*.glob $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
     print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n";
     print "%.g: %.v\n\t$(GALLINA) $<\n\n";
     print "%.tex: %.v\n\t$(COQDOC) -latex $< -o $@\n\n";
-    print "%.html: %.v %.glob\n\t$(COQDOC) -glob-from $*.glob  -html $< -o $@\n\n";
+    print "%.html: %.v %.glob\n\t$(COQDOC) -html $< -o $@\n\n";
     print "%.g.tex: %.v\n\t$(COQDOC) -latex -g $< -o $@\n\n";
-    print "%.g.html: %.v %.glob\n\t$(COQDOC) -glob-from $*.glob -html -g $< -o $@\n\n";
+    print "%.g.html: %.v %.glob\n\t$(COQDOC) -html -g $< -o $@\n\n";
     print "%.v.d: %.v\n";
-    print "\t$(COQDEP) -glob -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"
+    print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"
   in
     if !some_mlfile then ml_rules ();
     if !some_vfile then v_rule ()
@@ -269,7 +267,7 @@ let variables defs =
   let var_aux (v,def) = print v; print "="; print def; print "\n" in
     section "Variables definitions.";
     print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n";
-    if !opt = "-byte" then 
+    if !opt = "-byte" then
       print "override OPT:=-byte\n"
     else
       print "OPT:=\n";
@@ -283,6 +281,7 @@ let variables defs =
     print "COQDOC:=$(COQBIN)coqdoc\n";
     print "COQMKTOP:=$(COQBIN)coqmktop\n";
     (* Caml executables and relative variables *)
+    printf "CAMLLIB:=$(shell $(CAMLBIN)%s -where)\n" best_ocamlc;
     printf "CAMLC:=$(CAMLBIN)%s -c -rectypes\n" best_ocamlc;
     printf "CAMLOPTC:=$(CAMLBIN)%s -c -rectypes\n" best_ocamlopt;
     printf "CAMLLINK:=$(CAMLBIN)%s -rectypes\n" best_ocamlc;
@@ -291,7 +290,7 @@ let variables defs =
     print "CAMLP4EXTEND:=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n";
     print "CAMLP4OPTIONS:=\n";
     List.iter var_aux defs;
-    print "PP:=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n";
+    print "PP:=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n";
     print "\n"
 
 let parameters () =
@@ -299,8 +298,8 @@ let parameters () =
   print "# This Makefile may take 3 arguments passed as environment variables:\n";
   print "#   - COQBIN to specify the directory where Coq binaries resides;\n";
   print "#   - CAMLBIN and CAMLP4BIN to give the path for the OCaml and Camlp4/5 binaries.\n";
-  print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n"; 
-  print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n"; 
+  print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n";
+  print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n";
   print "ifndef CAMLP4BIN\n  CAMLP4BIN:=$(CAMLBIN)\nendif\n\n";
   print "CAMLP4LIB:=$(shell $(CAMLP4BIN)$(CAMLP4) -where)\n\n"
 
@@ -320,14 +319,9 @@ let include_dirs (inc_i,inc_r) =
   -I $(COQLIB)/library -I $(COQLIB)/parsing \\
   -I $(COQLIB)/pretyping -I $(COQLIB)/interp \\
   -I $(COQLIB)/proofs -I $(COQLIB)/tactics \\
-  -I $(COQLIB)/toplevel -I $(COQLIB)/contrib/cc -I $(COQLIB)/contrib/dp \\
-  -I $(COQLIB)/contrib/extraction -I $(COQLIB)/contrib/field \\
-  -I $(COQLIB)/contrib/firstorder -I $(COQLIB)/contrib/fourier \\
-  -I $(COQLIB)/contrib/funind -I $(COQLIB)/contrib/interface \\
-  -I $(COQLIB)/contrib/micromega -I $(COQLIB)/contrib/omega \\
-  -I $(COQLIB)/contrib/ring -I $(COQLIB)/contrib/romega \\
-  -I $(COQLIB)/contrib/rtauto -I $(COQLIB)/contrib/setoid_ring \\
-  -I $(COQLIB)/contrib/subtac -I $(COQLIB)/contrib/xml\n";
+  -I $(COQLIB)/toplevel";
+    List.iter (fun c -> print " \\
+  -I $(COQLIB)/plugins/"; print c) Coq_config.plugins_dirs; print "\n";
     print "COQLIBS:="; print_list "\\\n  " str_i'; print " "; print_list "\\\n  " str_r; print "\n";
     print "COQDOCLIBS:=";   print_list "\\\n  " str_r; print "\n\n"
 
@@ -336,14 +330,14 @@ let rec special = function
   | [] -> []
   | Special (file,deps,com) :: r -> (file,deps,com) :: (special r)
   | _ :: r -> special r
-      
+
 let custom sps =
-  let pr_sp (file,dependencies,com) =
+  let pr_path (file,dependencies,com) =
     print file; print ": "; print dependencies; print "\n";
     print "\t"; print com; print "\n\n"
   in
     if sps <> [] then section "Custom targets.";
-    List.iter pr_sp sps
+    List.iter pr_path sps
 
 let subdirs sds =
   let pr_subdir s =
@@ -354,7 +348,7 @@ let subdirs sds =
     section "Special targets.";
     print ".PHONY: ";
     print_list " "
-      ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install" 
+      ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install"
 	:: "depend" :: "html" :: sds);
     print "\n\n"
 
@@ -363,7 +357,7 @@ let rec split_arguments = function
       let (v,m,o,s),i,d = split_arguments r in ((canonize n::v,m,o,s),i,d)
   | ML n :: r ->
       let (v,m,o,s),i,d = split_arguments r in ((v,canonize n::m,o,s),i,d)
-  | Special (n,dep,c) :: r -> 
+  | Special (n,dep,c) :: r ->
       let (v,m,o,s),i,d = split_arguments r in ((v,m,(n,dep,c)::o,s),i,d)
   | Subdir n :: r ->
       let (v,m,o,s),i,d = split_arguments r in ((v,m,o,n::s),i,d)
@@ -371,7 +365,7 @@ let rec split_arguments = function
       let t,(i,r),d = split_arguments r in (t,((p,absolute_dir p)::i,r),d)
   | RInclude (p,l) :: r ->
       let t,(i,r),d = split_arguments r in (t,(i,(p,l,absolute_dir p)::r),d)
-  | Def (v,def) :: r -> 
+  | Def (v,def) :: r ->
       let t,i,d = split_arguments r in (t,i,(v,def)::d)
   | [] -> ([],[],[],[]),([],[]),[]
 
@@ -404,15 +398,15 @@ let main_targets vfiles mlfiles other_targets inc =
     if !some_mlfile then print "$(CMOFILES) ";
     if Coq_config.has_natdynlink && !some_mlfile then print "$(CMXSFILES) ";
     print_list "\\\n  " other_targets; print "\n";
-    if !some_vfile then 
+    if !some_vfile then
       begin
 	print "spec: $(VIFILES)\n\n";
 	print "gallina: $(GFILES)\n\n";
 	print "html: $(GLOBFILES) $(VFILES)\n";
-	print "\t- mkdir html\n"; 
+	print "\t- mkdir -p html\n";
 	print "\t$(COQDOC) -toc -html $(COQDOCLIBS) -d html $(VFILES)\n\n";
 	print "gallinahtml: $(GLOBFILES) $(VFILES)\n";
-	print "\t- mkdir html\n"; 
+	print "\t- mkdir -p html\n";
 	print "\t$(COQDOC) -toc -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n";
 	print "all.ps: $(VFILES)\n";
 	print "\t$(COQDOC) -toc -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n";
@@ -432,20 +426,20 @@ let all_target (vfiles, mlfiles, sps, sds) inc =
   main_targets vfiles mlfiles other_targets inc;
   custom sps;
   subdirs sds
-      
+
 let parse f =
-  let rec string = parser 
+  let rec string = parser
     | [< '' ' | '\n' | '\t' >] -> ""
     | [< 'c; s >] -> (String.make 1 c)^(string s)
     | [< >] -> ""
-  and string2 = parser 
+  and string2 = parser
     | [< ''"' >] -> ""
     | [< 'c; s >] -> (String.make 1 c)^(string2 s)
-  and skip_comment = parser 
+  and skip_comment = parser
     | [< ''\n'; s >] -> s
     | [< 'c; s >] -> skip_comment s
     | [< >] -> [< >]
-  and args = parser 
+  and args = parser
     | [< '' ' | '\n' | '\t'; s >] -> args s
     | [< ''#'; s >] -> args (skip_comment s)
     | [< ''"'; str = string2; s >] -> ("" ^ str) :: args s
@@ -458,13 +452,13 @@ let parse f =
     res
 
 let rec process_cmd_line = function
-  | [] -> 
+  | [] ->
       some_file := !some_file or !some_mlfile or !some_vfile; []
-  | ("-h"|"--help") :: _ -> 
+  | ("-h"|"--help") :: _ ->
       usage ()
-  | ("-no-opt"|"-byte") :: r -> 
+  | ("-no-opt"|"-byte") :: r ->
       opt := "-byte"; process_cmd_line r
-  | ("-full"|"-opt") :: r -> 
+  | ("-full"|"-opt") :: r ->
       opt := "-opt"; process_cmd_line r
   | "-impredicative-set" :: r ->
       impredicative_set := true; process_cmd_line r
@@ -483,65 +477,65 @@ let rec process_cmd_line = function
       Include d :: (process_cmd_line r)
   | "-R" :: p :: l :: r ->
       RInclude (p,l) :: (process_cmd_line r)
-  | ("-I"|"-custom") :: _ -> 
+  | ("-I"|"-custom") :: _ ->
       usage ()
-  | "-f" :: file :: r -> 
+  | "-f" :: file :: r ->
       make_name := file;
       process_cmd_line ((parse file)@r)
-  | ["-f"] -> 
+  | ["-f"] ->
       usage ()
-  | "-o" :: file :: r -> 
+  | "-o" :: file :: r ->
       makefile_name := file;
       output_channel := (open_out file);
       (process_cmd_line r)
-  | v :: "=" :: def :: r -> 
+  | v :: "=" :: def :: r ->
       Def (v,def) :: (process_cmd_line r)
   | f :: r ->
       if Filename.check_suffix f ".v" then begin
-          some_vfile := true; 
+          some_vfile := true;
 	  V f :: (process_cmd_line r)
 	end else if (Filename.check_suffix f ".ml") || (Filename.check_suffix f ".ml4") then begin
-          some_mlfile := true; 
+          some_mlfile := true;
 	  ML f :: (process_cmd_line r)
 	end else if (Filename.check_suffix f ".mli") then begin
 	  Printf.eprintf "Warning: no need for .mli files, skipped %s\n" f;
 	  process_cmd_line r
 	end else
           Subdir f :: (process_cmd_line r)
-	      
+
 let banner () =
-  print
-"##########################################################################
-##  v      #                  The Coq Proof Assistant                   ##
-## <O___,, # CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud ##
-##   \\VV/  #                                                            ##
-##    //   #   Makefile automagically generated by coq_makefile V8.2    ##
-##########################################################################
+  print (Printf.sprintf
+"#############################################################################
+##  v      #                   The Coq Proof Assistant                     ##
+## <O___,, #  CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud   ##
+##   \\VV/  #                                                               ##
+##    //   #  Makefile automagically generated by coq_makefile V%s ##
+#############################################################################
 
-"
+" (Coq_config.version ^ String.make (10 - String.length Coq_config.version) ' '))
 
 let warning () =
   print "# WARNING\n#\n";
   print "# This Makefile has been automagically generated\n";
   print "# Edit at your own risks !\n";
   print "#\n# END OF WARNING\n\n"
-    
+
 let print_list l = List.iter (fun x -> print x; print " ") l
-  
+
 let command_line args =
   print "#\n# This Makefile was generated by the command line :\n";
   print "# coq_makefile ";
   print_list args;
   print "\n#\n\n"
-    
+
 let directories_deps l =
-  let print_dep f dep = 
+  let print_dep f dep =
     if dep <> [] then begin print f; print ": "; print_list dep; print "\n" end
   in
   let rec iter ((dirs,before) as acc) = function
-    | [] -> 
+    | [] ->
 	()
-    | (Subdir d) :: l -> 
+    | (Subdir d) :: l ->
 	print_dep d before; iter (d :: dirs, d :: before) l
     | (ML f) :: l ->
 	print_dep f dirs; iter (dirs, f :: before) l
@@ -549,7 +543,7 @@ let directories_deps l =
 	print_dep f dirs; iter (dirs, f :: before) l
     | (Special (f,_,_)) :: l ->
 	print_dep f dirs; iter (dirs, f :: before) l
-    | _ :: l -> 
+    | _ :: l ->
 	iter acc l
   in
     iter ([],[]) l
@@ -567,7 +561,7 @@ let warn_install_at_root_directory (vfiles,mlfiles,_,_) (inc_i,inc_r) =
   if not !no_install &&
     List.exists (fun f -> List.mem_assoc (Filename.dirname f) inc_top) files
   then
-    Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" 
+    Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n"
       (if inc_r_top = [] then "" else "with non trivial logical root ")
 
 let check_overlapping_include (inc_i,inc_r) =
@@ -582,7 +576,7 @@ let check_overlapping_include (inc_i,inc_r) =
 	    Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l;
 	List.iter (fun (pdir',abspdir') ->
 	  if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then
-	    Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i 
+	    Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i
   in aux inc_r
 
 let do_makefile args =
@@ -609,12 +603,12 @@ let do_makefile args =
   warning ();
   if not (!output_channel == stdout) then close_out !output_channel;
   exit 0
-	  
+
 let main () =
   let args =
     if Array.length Sys.argv = 1 then usage ();
     List.tl (Array.to_list Sys.argv)
   in
     do_makefile args
-      
+
 let _ = Printexc.catch main ()
diff --git a/tools/coq-tex.ml4 b/tools/coq_tex.ml4
index 4c11725c..c46a187c 100644
--- a/tools/coq-tex.ml4
+++ b/tools/coq_tex.ml4
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq-tex.ml4 9532 2007-01-24 16:04:29Z bgregoir $ *)
+(* $Id$ *)
 
 (* coq-tex
  * JCF, 16/1/98
  * adapted from caml-tex (perl script written by Xavier Leroy)
  *
- * Perl isn't as portable as it pretends to be, and is quite difficult 
+ * Perl isn't as portable as it pretends to be, and is quite difficult
  * to read and maintain... Let us rewrite the stuff in Caml! *)
 
 let _ =
@@ -64,10 +64,10 @@ let extract texfile inputv =
       outside ()
   in
   try
-    output_string chan_out 
+    output_string chan_out
       ("Set Printing Width " ^ (string_of_int !linelen) ^".\n");
     outside ()
-  with End_of_file -> 
+  with End_of_file ->
     begin close_in chan_in; close_out chan_out end
 
 (* Second pass: insert the answers of Coq from [coq_output] into the
@@ -89,11 +89,11 @@ let expos   = Str.regexp "^"
 
 let tex_escaped s =
   let rec trans = parser
-    | [< s1 = (parser 
-		 | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> 
+    | [< s1 = (parser
+		 | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] ->
 		     "\\" ^ (String.make 1 c)
-		 | [< ''\\' >] -> "{\\char'134}" 
-		 | [< ''^'  >] -> "{\\char'136}" 
+		 | [< ''\\' >] -> "{\\char'134}"
+		 | [< ''^'  >] -> "{\\char'136}"
 		 | [< ''~'  >] -> "{\\char'176}"
 		 | [< '' '  >] -> "~"
 		 | [< ''<'  >] -> "{<}"
@@ -101,7 +101,7 @@ let tex_escaped s =
 		 | [< 'c >]    -> String.make 1 c);
 	 s2 = trans >] -> s1 ^ s2
     | [< >] -> ""
-  in 
+  in
   trans (Stream.of_string s)
 
 let encapsule sl c_out s =
@@ -109,7 +109,7 @@ let encapsule sl c_out s =
     Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s)
   else
     Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s)
-      
+
 let print_block c_out bl =
   List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl
 
@@ -138,7 +138,7 @@ let insert texfile coq_output result =
     let first = !last_read in first :: (read_lines ())
   in
   (* we are just after \end{coq_...} block *)
-  let rec just_after () = 
+  let rec just_after () =
     let s = input_line c_tex in
     if Str.string_match begin_coq_example s 0 then begin
       inside (Str.matched_group 1 s <> "example*")
@@ -149,11 +149,11 @@ let insert texfile coq_output result =
       output_string c_out "\\end{flushleft}\n";
       if !small then output_string c_out "\\end{small}\n";
       if Str.string_match begin_coq_eval s 0 then
-	eval 0     
+	eval 0
       else begin
 	output_string c_out (s ^ "\n");
 	outside ()
-      end	  
+      end
     end
   (* we are outside of a \begin{coq_...} ... \end{coq_...} block *)
   and outside () =
@@ -173,7 +173,7 @@ let insert texfile coq_output result =
   (* we are inside a \begin{coq_example?} ... \end{coq_example?} block
    * show_answers tells what kind of block it is
    * k is the number of lines read until now *)
-  and inside show_answers  show_questions k first_block = 
+  and inside show_answers  show_questions k first_block =
     let s = input_line c_tex in
     if Str.string_match end_coq_example s 0 then begin
       just_after ()
@@ -183,7 +183,7 @@ let insert texfile coq_output result =
       if show_questions then encapsule false c_out ("Coq < " ^ s);
       if has_match dot_end_line s then begin
 	let bl = next_block (succ k) in
-	if !verbose then List.iter print_endline bl; 
+	if !verbose then List.iter print_endline bl;
 	if show_answers then print_block c_out bl;
 	inside show_answers  show_questions 0 false
       end else
@@ -228,14 +228,14 @@ let one_file texfile =
     else if Filename.check_suffix texfile ".tex" then
       (Filename.chop_suffix texfile ".tex") ^ ".v.tex"
     else
-      texfile ^ ".v.tex" 
+      texfile ^ ".v.tex"
   in
   try
     (* 1. extract Coq phrases *)
     extract texfile inputv;
     (* 2. run Coq on input *)
     let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv
-			   coq_output) 
+			   coq_output)
     in
     (* 3. insert Coq output into original file *)
     insert texfile coq_output result;
@@ -250,7 +250,7 @@ let one_file texfile =
  * of all the files in the command line, one by one *)
 
 let files = ref []
-      
+
 let parse_cl () =
   Arg.parse
       [ "-o", Arg.String (fun s -> output_specified := true; output := s),
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index 91a7e6d0..fe930a1d 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -6,207 +6,46 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqdep.ml 12916 2010-04-10 15:18:17Z herbelin $ *)
+(* $Id$ *)
 
 open Printf
 open Coqdep_lexer
-open Unix
+open Coqdep_common
 
-let stderr = Pervasives.stderr
-let stdout = Pervasives.stdout
+(** The basic parts of coqdep (i.e. the parts used by [coqdep -boot])
+    are now in [Coqdep_common]. The code that remains here concerns
+    the other options. Calling this complete coqdep with the [-boot]
+    option should be equivalent to calling [coqdep_boot].
+*)
 
-let option_c = ref false
 let option_D = ref false
 let option_w = ref false
-let option_i = ref false
 let option_sort = ref false
-let option_glob = ref false
-let option_slash = ref false
 
-let suffixe = ref ".vo"
-let suffixe_spec = ref ".vi"
-
-type dir = string option
-
-(* filename for printing *)
-let (//) s1 s2 =
-  if !option_slash then s1^"/"^s2 else Filename.concat s1 s2
-
-let (/) = Filename.concat
-
-let file_concat l =
-  if l=[] then "<empty>" else
-    List.fold_left (//) (List.hd l) (List.tl l)
-
-let make_ml_module_name filename =
-  (* Computes a ML Module name from its physical name *)
-  let fn = try Filename.chop_extension filename with _ -> filename in
-  let bn = Filename.basename fn in
-    String.capitalize bn
-      
-(* Files specified on the command line *)
-let mlAccu  = ref ([] : (string * string * dir) list) 
-and mliAccu = ref ([] : (string * string * dir) list) 
-and vAccu   = ref ([] : (string * string) list)
-
-(* Queue operations *)
-let addQueue q v = q := v :: !q
-
-let safe_hash_add clq q (k,v) =
-  try
-    let v2 = Hashtbl.find q k in
-    if v<>v2 then 
-      let rec add_clash = function
-          (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl
-        | cl::cltl -> cl::add_clash cltl
-        | [] -> [(k,[v;v2])] in
-      clq := add_clash !clq;
-      (* overwrite previous bindings, as coqc does *)
-      Hashtbl.add q k v
-  with Not_found -> Hashtbl.add q k v
-
-(* Files found in the loadpaths *)
-
-let mlKnown = (Hashtbl.create 19 : (string, dir) Hashtbl.t)
-let mliKnown = (Hashtbl.create 19 : (string, dir) Hashtbl.t)
-let vKnown = (Hashtbl.create 19 : (string list, string) Hashtbl.t)
-let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t)
-
-let clash_v = ref ([]: (string list * string list) list)
-
-
-let warning_module_notfound f s =
-  eprintf "*** Warning : in file %s, library " f;
-  eprintf "%s.v is required and has not been found in loadpath !\n"
-    (String.concat "." s);
-  flush stderr
-
-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_clash file dir =
-  match List.assoc dir !clash_v with
-    (f1::f2::fl) ->
-      let f = Filename.basename f1 in
-      let d1 = Filename.dirname f1 in
-      let d2 = Filename.dirname f2 in
-      let dl = List.map Filename.dirname (List.rev fl) in
-      eprintf
-        "*** Warning : in file %s, \n    required library %s is ambiguous!\n    (found %s.v in "
-        file (String.concat "." dir) f;
-      List.iter (fun s -> eprintf "%s, " s) dl;
-      eprintf "%s and %s)\n" d2 d1
-  | _ -> assert false
-
-let safe_assoc verbose file k =
-  if verbose && List.mem_assoc k !clash_v then warning_clash file k;
-  Hashtbl.find vKnown k
-
-let absolute_dir dir =
-  let current = Sys.getcwd () in
-    Sys.chdir dir;
-    let dir' = Sys.getcwd () in
-      Sys.chdir current;
-      dir'
-
-let absolute_file_name basename odir =
-  let dir = match odir with Some dir -> dir | None -> "." in
-  absolute_dir dir // basename
-     
-let file_name = function
-  | (s,None)     -> file_concat s 
-  | (s,Some ".") -> file_concat s
-  | (s,Some d)   -> d // file_concat s
-
-let traite_fichier_ML md ext =
-  try 
-    let chan = open_in (md ^ ext) in 
-    let buf = Lexing.from_channel chan in 
-    let deja_vu = ref [md] in
-    let a_faire = ref "" in
-    let a_faire_opt = ref "" in
-    begin try 
-      while true do
-	let (Use_module str) = caml_action buf in
-	if List.mem str !deja_vu then 
-	  ()
-	else begin
-	  addQueue deja_vu str;
-          begin try
-            let mlidir = Hashtbl.find mliKnown str in
-            let filename = file_name ([str],mlidir) in
-      	    a_faire := !a_faire ^ " " ^ filename ^ ".cmi"; 
-          with Not_found ->
-            try
-              let mldir = Hashtbl.find mlKnown str in
-              let filename = file_name ([str],mldir) in
-              a_faire := !a_faire ^ " " ^ filename ^ ".cmo";
-            with Not_found -> ()
-          end;
-          begin try
-            let mldir =  Hashtbl.find mlKnown str in
-            let filename = file_name ([str],mldir) in
-    	    a_faire_opt := !a_faire_opt ^ " " ^ filename ^ ".cmx"
-          with Not_found ->
-            try
-              let mlidir = Hashtbl.find mliKnown str in
-              let filename = file_name ([str],mlidir) in
-              a_faire_opt := !a_faire_opt ^ " " ^ filename ^ ".cmi"
-            with Not_found -> ()
-          end
+let rec warning_mult suf iter =
+  let tab = Hashtbl.create 151 in
+  let check f d =
+    begin try
+      let d' = Hashtbl.find tab f in
+      if (Filename.dirname (file_name f d))
+        <> (Filename.dirname (file_name f d')) then begin
+	  eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf);
+	  flush stderr
 	end
-      done
-    with Fin_fichier -> ()
-    end;
-    close_in chan;
-    (!a_faire, !a_faire_opt)
-  with Sys_error _ -> ("","")
-
-let cut_prefix p s =
-  let lp = String.length p in
-  let ls = String.length s in
-  if ls >= lp && String.sub s 0 lp = p then String.sub s lp (ls - lp) else s
-
-(* 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 = ' ' or c = '#' or c = ':' (* separators and comments *)
-	or c = '%' (* pattern *)
-	or c = '?' or c = '[' or c = ']' or c = '*' (* expansion in filenames *)
-	or i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 
-	    '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'
-
-let canonize f =
-  let f' = absolute_dir (Filename.dirname f) // Filename.basename f in
-  match List.filter (fun (_,full) -> f' = full) !vAccu with
-    | (f,_) :: _ -> f
-    | _ -> f
+    with Not_found -> () end;
+    Hashtbl.add tab f d
+  in
+  iter check
+
+let add_coqlib_known phys_dir log_dir f =
+  match get_extension f [".vo"] with
+    | (basename,".vo") ->
+	let name = log_dir@[basename] in
+	Hashtbl.add coqlibKnown [basename] ();
+	Hashtbl.add coqlibKnown name ()
+    | _ -> ()
 
-let sort () = 
+let sort () =
   let seen = Hashtbl.create 97 in
   let rec loop file =
     let file = canonize file in
@@ -217,13 +56,13 @@ let sort () =
       try
 	while true do
 	  match coq_action lb with
-	    | Require (_, sl) ->
-		List.iter 
-		  (fun s -> 
-		    try loop (Hashtbl.find vKnown s) 
+	    | Require sl ->
+		List.iter
+		  (fun s ->
+		    try loop (Hashtbl.find vKnown s)
 		    with Not_found -> ())
 		sl
-	    | RequireString (_, s) -> loop s
+	    | RequireString s -> loop s
 	    | _ -> ()
 	done
       with Fin_fichier ->
@@ -233,82 +72,17 @@ let sort () =
   in
   List.iter (fun (name,_) -> loop name) !vAccu
 
-let traite_fichier_Coq verbose f = 
-  try 
-    let chan = open_in f in 
-    let buf = Lexing.from_channel chan in 
-    let deja_vu_v = ref ([]: string list list)
-    and deja_vu_ml = ref ([] : string list) in
-    try 
-      while true do
-      	let tok = coq_action buf in
-	match tok with
-	  | Require (spec,strl) ->
-	      List.iter (fun str ->
-		if not (List.mem str !deja_vu_v) then begin
-	          addQueue deja_vu_v str;
-                  try
-                    let file_str = safe_assoc verbose f str in
-                    printf " %s%s" (canonize file_str)
-                      (if spec then !suffixe_spec else !suffixe)
-                  with Not_found -> 
-		    if verbose && not (Hashtbl.mem coqlibKnown str) then
-                      warning_module_notfound f str
-       		end) strl
-	  | RequireString (spec,s) -> 
-	      let str = Filename.basename s in
-	      if not (List.mem [str] !deja_vu_v) then begin
-	        addQueue deja_vu_v [str];
-                try
-                  let file_str = Hashtbl.find vKnown [str] in
-                  printf " %s%s" (canonize file_str)
-                    (if spec then !suffixe_spec else !suffixe)
-                with Not_found -> 
-		  if not (Hashtbl.mem coqlibKnown [str]) then
-		    warning_notfound f s
-       	      end
-	  | Declare sl -> 
-	      List.iter 
-		(fun str ->
-		  let s = make_ml_module_name str in
-		    if not (List.mem s !deja_vu_ml) then begin
-			addQueue deja_vu_ml s;
-               	       try
-              		 let mldir = Hashtbl.find mlKnown s in
-			 let filename = file_name ([String.uncapitalize s],mldir) in
-              		 if Coq_config.has_natdynlink then
-			   printf " %s.cmo %s.cmxs" filename filename
-			 else
-			   printf " %s.cmo" filename
-              	       with Not_found -> ()
-		     end)
-		sl
-	  | Load str -> 
-	      let str = Filename.basename str in
-	      if not (List.mem [str] !deja_vu_v) then begin
-	        addQueue deja_vu_v [str];
-                try
-                  let file_str = Hashtbl.find vKnown [str] in
-                  printf " %s.v" (canonize file_str)
-                with Not_found -> ()
-       	      end
-      done
-    with Fin_fichier -> ();
-      close_in chan
-  with Sys_error _ -> () 
-
-
 let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151
-						     
-let mL_dep_list b f = 
-  try 
+
+let mL_dep_list b f =
+  try
     Hashtbl.find dep_tab f
   with Not_found ->
-    let deja_vu = ref ([] : string list) in 
-    try 
-      let chan = open_in f in 
-      let buf = Lexing.from_channel chan in 
-      try 
+    let deja_vu = ref ([] : string list) in
+    try
+      let chan = open_in f in
+      let buf = Lexing.from_channel chan in
+      try
 	while true do
 	  let (Use_module str) = caml_action buf in
 	  if str = b then begin
@@ -319,14 +93,14 @@ let mL_dep_list b f =
             if not (List.mem str !deja_vu) then addQueue deja_vu str
       	done; []
       with Fin_fichier -> begin
-	close_in chan; 
+	close_in chan;
 	let rl = List.rev !deja_vu in
       	Hashtbl.add dep_tab f rl;
 	rl
       end
     with Sys_error _ -> []
 
-let affiche_Declare f dcl = 
+let affiche_Declare f dcl =
   printf "\n*** In file %s: \n" f;
   printf "Declare ML Module";
   List.iter (fun str -> printf " \"%s\"" str) dcl;
@@ -341,33 +115,33 @@ let warning_Declare f dcl =
   eprintf ".\n";
   flush stderr
 
-let traite_Declare f = 
+let traite_Declare f =
   let decl_list = ref ([] : string list) in
   let rec treat = function
-    | s :: ll -> 
-	let s' = make_ml_module_name s in
-	  if (Hashtbl.mem mlKnown s') & not (List.mem s' !decl_list) then begin
-       	      let mldir = Hashtbl.find mlKnown s in
-	      let fullname = file_name ([(String.uncapitalize s')],mldir) in
-	      let depl = mL_dep_list s (fullname ^ ".ml") in
-		treat depl;
-		decl_list := s :: !decl_list
-	    end;
-	  treat ll
+    | s :: ll ->
+	let s' = basename_noext s in
+	(match search_ml_known s with
+	   | Some mldir when not (List.mem s' !decl_list) ->
+	       let fullname = file_name (String.uncapitalize s') mldir in
+	       let depl = mL_dep_list s (fullname ^ ".ml") in
+	       treat depl;
+	       decl_list := s :: !decl_list
+	   | _ -> ());
+	treat ll
     | [] -> ()
   in
     try
       let chan = open_in f in
       let buf = Lexing.from_channel chan in
-	begin try 
+	begin try
 	    while true do
       	      let tok = coq_action buf in
       		(match tok with
-		  | Declare sl -> 
+		  | Declare sl ->
 		      decl_list := [];
 		      treat sl;
 		      decl_list := List.rev !decl_list;
-		      if !option_D then 
+		      if !option_D then
 			affiche_Declare f !decl_list
 		      else if !decl_list <> sl then
 			warning_Declare f !decl_list
@@ -377,200 +151,61 @@ let traite_Declare f =
 	close_in chan
     with Sys_error _ -> ()
 
-let file_mem (f,_,d) =
-  let rec loop = function
-    | (f1,_,d1) :: l -> (f1 = f && d1 = d) || (loop l)
-    | _ -> false
-  in 
-  loop
-
-let mL_dependencies () =
-  List.iter 
-    (fun ((name,ext,dirname) as pairname) ->
-       let fullname = file_name ([name],dirname) in
-       let (dep,dep_opt) = traite_fichier_ML fullname ext in
-       printf "%s.cmo: %s%s" fullname fullname ext;
-       if file_mem pairname !mliAccu then printf " %s.cmi" fullname;
-       printf "%s\n" dep;
-       printf "%s.cmx: %s%s" fullname fullname ext;
-       if file_mem pairname !mliAccu then printf " %s.cmi" fullname;
-       printf "%s\n" dep_opt;
-       flush stdout)
-    (List.rev !mlAccu);
-  List.iter
-    (fun ((name,ext,dirname)) ->
-       let fullname = file_name ([name],dirname) in
-       let (dep,_) = traite_fichier_ML fullname ext in
-       printf "%s.cmi: %s%s" fullname fullname ext;
-       printf "%s\n" dep;
-       flush stdout)
-    (List.rev !mliAccu)
-
-let coq_dependencies () =
-  List.iter
-    (fun (name,_) ->
-       let glob = if !option_glob then " "^name^".glob" else "" in 
-       printf "%s%s%s: %s.v" name !suffixe glob name;
-       traite_fichier_Coq true (name ^ ".v");
-       printf "\n";
-       if !option_i then begin
-	 printf "%s%s%s: %s.v" name !suffixe_spec glob name;
-	 traite_fichier_Coq false (name ^ ".v");
-	 printf "\n";
-       end;
-       flush stdout)
-    (List.rev !vAccu)
-
 let declare_dependencies () =
   List.iter
     (fun (name,_) ->
-       traite_Declare (name^".v");      
+       traite_Declare (name^".v");
        flush stdout)
     (List.rev !vAccu)
 
-let rec warning_mult suf l = 
-  let tab = Hashtbl.create 151 in
-  Hashtbl.iter 
-    (fun f d ->
-       begin try 
-	 let d' = Hashtbl.find tab f in
-	 if (Filename.dirname (file_name ([f],d)))
-      	   <> (Filename.dirname (file_name ([f],d'))) then begin
-	     eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf);
-	     flush stderr
-	   end
-       with Not_found -> () end;
-       Hashtbl.add tab f d) 
-    l
-
 let usage () =
   eprintf
   "[ usage: coqdep [-w] [-I dir] [-R dir coqdir] [-coqlib dir] [-c] [-i] [-D] <filename>+ ]\n";
   flush stderr;
   exit 1
 
-let add_coqlib_known phys_dir log_dir f = 
-  if Filename.check_suffix f ".vo" then
-    let basename = Filename.chop_suffix f ".vo" in
-    let name = log_dir@[basename] in
-    Hashtbl.add coqlibKnown [basename] ();
-    Hashtbl.add coqlibKnown name ()
-
-let rec suffixes = function
-  | [] -> assert false
-  | [name] -> [[name]]
-  | dir::suffix as l -> l::suffixes suffix
-
-let add_known phys_dir log_dir f = 
-  if (Filename.check_suffix f ".ml" ||  Filename.check_suffix f ".mli" || Filename.check_suffix f ".ml4")  then
-    let basename = make_ml_module_name f in
-      Hashtbl.add mlKnown basename (Some phys_dir)
-  else if Filename.check_suffix f ".v" then
-    let basename = Filename.chop_suffix f ".v" in
-    let name = log_dir@[basename] in
-    let file = phys_dir//basename in
-    let paths = suffixes name in
-    List.iter
-      (fun n -> safe_hash_add clash_v vKnown (n,file)) paths
-
-(* Visits all the directories under [dir], including [dir], 
-   or just [dir] if [recur=false] *)
-
-let rec add_directory recur add_file phys_dir log_dir = 
-  let dirh = opendir phys_dir in
-  try
-    while true do
-      let f = readdir dirh in
-      (* we avoid . .. and all hidden files and subdirs (e.g. .svn, _darcs) *)
-      if f.[0] <> '.' && f.[0] <> '_' then
-        let phys_f = phys_dir//f in
-	match try (stat phys_f).st_kind with _ -> S_BLK with
-	  | S_DIR when recur -> 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 add_dir add_file phys_dir log_dir = 
-  try add_directory false add_file phys_dir log_dir with Unix_error _ -> ()
-
-let add_rec_dir add_file phys_dir log_dir = 
-  handle_unix_error (add_directory true add_file phys_dir) log_dir
-
-let rec treat_file old_dirname old_name =
-  let name = Filename.basename old_name 
-  and new_dirname = Filename.dirname old_name in
-  let dirname = 
-    match (old_dirname,new_dirname) with 
-      | (d, ".") -> d
-      | (None,d) -> Some d
-      | (Some d1,d2) -> Some (d1//d2) 
-  in
-  let complete_name = file_name ([name],dirname) in
-  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)
-    | S_REG -> 
-	if Filename.check_suffix name ".ml" then
-	  let basename = Filename.chop_suffix name ".ml" in
-	  addQueue mlAccu (basename,".ml",dirname)
-	else if Filename.check_suffix name ".ml4" then
-	  let basename = Filename.chop_suffix name ".ml4" in
-	  addQueue mlAccu (basename,".ml4",dirname)
-	else if Filename.check_suffix name ".mli" then
-	  let basename = Filename.chop_suffix name ".mli" in
-	  addQueue mliAccu (basename,".mli",dirname)
-	else if Filename.check_suffix name ".v" then
-	  let basename = Filename.chop_suffix name ".v" in
-	  let name = file_name ([basename],dirname) in
-	  addQueue vAccu (name, absolute_file_name basename dirname)
-    | _ -> ()
-
 let rec parse = function
   | "-c" :: ll -> option_c := true; parse ll
   | "-D" :: ll -> option_D := true; parse ll
   | "-w" :: ll -> option_w := true; parse ll
-  | "-i" :: ll -> option_i := true; parse ll
   | "-boot" :: ll -> Flags.boot := true; parse ll
   | "-sort" :: ll -> option_sort := true; parse ll
-  | "-glob" :: ll -> option_glob := true; parse ll
+  | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll
+  | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r [ln]; parse ll
+  | "-I" :: r :: "-as" :: [] -> usage ()
   | "-I" :: r :: ll -> add_dir add_known r []; parse ll
   | "-I" :: [] -> usage ()
+  | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll
+  | "-R" :: r :: "-as" :: [] -> usage ()
   | "-R" :: r :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll
   | "-R" :: ([] | [_]) -> usage ()
   | "-coqlib" :: (r :: ll) -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll
   | "-coqlib" :: [] -> usage ()
-  | "-suffix" :: (s :: ll) -> suffixe := s ; suffixe_spec := s; parse ll
+  | "-suffix" :: (s :: ll) -> suffixe := s ; parse ll
   | "-suffix" :: [] -> usage ()
   | "-slash" :: ll -> option_slash := true; parse ll
+  | ("-h"|"--help"|"-help") :: _ -> usage ()
   | f :: ll -> treat_file None f; parse ll
   | [] -> ()
 
 let coqdep () =
   if Array.length Sys.argv < 2 then usage ();
   parse (List.tl (Array.to_list Sys.argv));
+  if not Coq_config.has_natdynlink then option_natdynlk := false;
   if !Flags.boot then begin
     add_rec_dir add_known "theories" ["Coq"];
-    add_rec_dir add_known "contrib" ["Coq"]
+    add_rec_dir add_known "plugins" ["Coq"]
   end else begin
     let coqlib = Envars.coqlib () in
-      add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; 
-      add_rec_dir add_coqlib_known (coqlib//"contrib") ["Coq"];
-      add_dir add_coqlib_known (coqlib//"user-contrib") []
+    add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"];
+    add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"];
+    add_dir add_coqlib_known (coqlib//"user-contrib") []
   end;
-  List.iter (fun (f,_,d) -> Hashtbl.add mliKnown f d) !mliAccu;
-  List.iter (fun (f,_,d) -> Hashtbl.add mlKnown f d) !mlAccu;
-  warning_mult ".mli" mliKnown;
-  warning_mult ".ml" mlKnown;
+  List.iter (fun (f,d) -> add_mli_known f d) !mliAccu;
+  List.iter (fun (f,d) -> add_mllib_known f d) !mllibAccu;
+  List.iter (fun (f,_,d) -> add_ml_known f d) !mlAccu;
+  warning_mult ".mli" iter_mli_known;
+  warning_mult ".ml" iter_ml_known;
   if !option_sort then begin sort (); exit 0 end;
   if !option_c && not !option_D then mL_dependencies ();
   if not !option_D then coq_dependencies ();
diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml
new file mode 100644
index 00000000..b7f6ec25
--- /dev/null
+++ b/tools/coqdep_boot.ml
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Coqdep_common
+
+(** [coqdep_boot] is a stripped-down version of [coqdep], whose
+    behavior is the one of [coqdep -boot]. Its only dependencies
+    are [Coqdep_lexer], [Coqdep_common] and [Unix], and it should stay so.
+    If it needs someday some additional information, pass it via
+    options (see for instance [option_natdynlk] below).
+*)
+
+let rec parse = function
+  | "-slash" :: ll -> option_slash := true; parse ll
+  | "-natdynlink" :: "no" :: ll -> option_natdynlk := false; parse ll
+  | "-c" :: ll -> option_c := true; parse ll
+  | "-boot" :: ll -> parse ll (* We're already in boot mode by default *)
+  | "-I" :: r :: ll ->
+       (* To solve conflict (e.g. same filename in kernel and checker)
+          we allow to state an explicit order *)
+       add_dir add_known r [];
+       norecdir_list:=r::!norecdir_list;
+       parse ll
+  | f :: ll -> treat_file None f; parse ll
+  | [] -> ()
+
+let coqdep_boot () =
+  if Array.length Sys.argv < 2 then exit 1;
+  parse (List.tl (Array.to_list Sys.argv));
+  if !option_c then
+    add_rec_dir add_known "." []
+  else begin
+    add_rec_dir add_known "theories" ["Coq"];
+    add_rec_dir add_known "plugins" ["Coq"];
+  end;
+  if !option_c then mL_dependencies ();
+  coq_dependencies ()
+
+let _ = Printexc.catch coqdep_boot ()
diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml
new file mode 100644
index 00000000..b71a47d0
--- /dev/null
+++ b/tools/coqdep_common.ml
@@ -0,0 +1,445 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: coqdep_common.ml 11984 2009-03-16 13:41:49Z letouzey $ *)
+
+open Printf
+open Coqdep_lexer
+open Unix
+
+(** [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.
+    If it need someday some additional information, pass it via
+    options (see for instance [option_natdynlk] below).
+*)
+
+let stderr = Pervasives.stderr
+let stdout = Pervasives.stdout
+
+let option_c = ref false
+let option_noglob = ref false
+let option_slash = ref false
+let option_natdynlk = ref true
+
+let norecdir_list = ref ([]:string list)
+
+let suffixe = ref ".vo"
+
+type dir = string option
+
+(* filename for printing *)
+let (//) s1 s2 =
+  if !option_slash then s1^"/"^s2 else Filename.concat s1 s2
+
+(** [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
+
+(** [basename_noext] removes both the directory part and the extension
+    (if necessary) of a filename *)
+
+let basename_noext filename =
+  let fn = Filename.basename filename in
+  try Filename.chop_extension fn with _ -> fn
+
+(** ML Files specified on the command line. In the entries:
+    - the first string is the basename of the file, without extension nor
+      directory part
+    - the second string of [mlAccu] is the extension (either .ml or .ml4)
+    - the [dir] part is the directory, with None used as the current directory
+*)
+
+let mlAccu  = ref ([] : (string * string * dir) list)
+and mliAccu = ref ([] : (string * dir) list)
+and mllibAccu = ref ([] : (string * dir) list)
+
+(** Coq files specifies on the command line:
+    - first string is the full filename, with only its extension removed
+    - second string is the absolute version of the previous (via getcwd)
+*)
+
+let vAccu   = ref ([] : (string * string) list)
+
+(** Queue operations *)
+
+let addQueue q v = q := v :: !q
+
+let safe_hash_add clq q (k,v) =
+  try
+    let v2 = Hashtbl.find q k in
+    if v<>v2 then
+      let rec add_clash = function
+          (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl
+        | cl::cltl -> cl::add_clash cltl
+        | [] -> [(k,[v;v2])] in
+      clq := add_clash !clq;
+      (* overwrite previous bindings, as coqc does *)
+      Hashtbl.add q k v
+  with Not_found -> Hashtbl.add q k v
+
+(** Files found in the loadpaths.
+    For the ML files, the string is the basename without extension.
+    To allow ML source filename to be potentially capitalized,
+    we perform a double search.
+*)
+
+let mkknown () =
+  let h = (Hashtbl.create 19 : (string, dir) Hashtbl.t) in
+  let add x s = if Hashtbl.mem h x then () else Hashtbl.add h x s
+  and iter f = Hashtbl.iter f h
+  and search x =
+    try Some (Hashtbl.find h (String.uncapitalize x))
+    with Not_found ->
+      try Some (Hashtbl.find h (String.capitalize x))
+      with Not_found -> None
+  in add, iter, search
+
+let add_ml_known, iter_ml_known, search_ml_known = mkknown ()
+let add_mli_known, iter_mli_known, search_mli_known = mkknown ()
+let add_mllib_known, _, search_mllib_known = mkknown ()
+
+let vKnown = (Hashtbl.create 19 : (string list, string) Hashtbl.t)
+let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t)
+
+let clash_v = ref ([]: (string list * string list) list)
+
+let warning_module_notfound f s =
+  eprintf "*** Warning: in file %s, library " f;
+  eprintf "%s.v is required and has not been found in loadpath!\n"
+    (String.concat "." s);
+  flush stderr
+
+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;
+  flush stderr
+
+let warning_clash file dir =
+  match List.assoc dir !clash_v with
+    (f1::f2::fl) ->
+      let f = Filename.basename f1 in
+      let d1 = Filename.dirname f1 in
+      let d2 = Filename.dirname f2 in
+      let dl = List.map Filename.dirname (List.rev fl) in
+      eprintf
+        "*** Warning: in file %s, \n    required library %s is ambiguous!\n    (found %s.v in "
+        file (String.concat "." dir) f;
+      List.iter (fun s -> eprintf "%s, " s) dl;
+      eprintf "%s and %s; used the latter)\n" d2 d1
+  | _ -> assert false
+
+let safe_assoc verbose file k =
+  if verbose && List.mem_assoc k !clash_v then warning_clash file k;
+  Hashtbl.find vKnown k
+
+let absolute_dir dir =
+  let current = Sys.getcwd () in
+    Sys.chdir dir;
+    let dir' = Sys.getcwd () in
+      Sys.chdir current;
+      dir'
+
+let absolute_file_name basename odir =
+  let dir = match odir with Some dir -> dir | None -> "." in
+  absolute_dir dir // basename
+
+let file_name s = function
+  | None     -> s
+  | Some "." -> s
+  | Some d   -> d // s
+
+let depend_ML str =
+  match search_mli_known str, search_ml_known str with
+    | Some mlidir, Some mldir ->
+	let mlifile = file_name str mlidir
+	and mlfile = file_name str mldir in
+	(" "^mlifile^".cmi"," "^mlfile^".cmx")
+    | None, Some mldir ->
+	let mlfile = file_name str mldir in
+	(" "^mlfile^".cmo"," "^mlfile^".cmx")
+    | Some mlidir, None ->
+	let mlifile = file_name str mlidir in
+	(" "^mlifile^".cmi"," "^mlifile^".cmi")
+    | None, None -> "", ""
+
+let traite_fichier_ML md ext =
+  try
+    let chan = open_in (md ^ ext) in
+    let buf = Lexing.from_channel chan in
+    let deja_vu = ref [md] in
+    let a_faire = ref "" in
+    let a_faire_opt = ref "" in
+    begin try
+      while true do
+	let (Use_module str) = caml_action buf in
+	if List.mem str !deja_vu then
+	  ()
+	else begin
+	  addQueue deja_vu str;
+	  let byte,opt = depend_ML str in
+	  a_faire := !a_faire ^ byte;
+	  a_faire_opt := !a_faire_opt ^ opt
+	end
+      done
+    with Fin_fichier -> ()
+    end;
+    close_in chan;
+    (!a_faire, !a_faire_opt)
+  with Sys_error _ -> ("","")
+
+let traite_fichier_mllib md ext =
+  try
+    let chan = open_in (md ^ ext) in
+    let list = mllib_list (Lexing.from_channel chan) in
+    let a_faire = ref "" in
+    let a_faire_opt = ref "" in
+    List.iter
+      (fun str -> match search_ml_known str with
+	 | Some mldir ->
+	     let file = file_name str mldir in
+	     a_faire := !a_faire^" "^file^".cmo";
+	     a_faire_opt := !a_faire_opt^" "^file^".cmx"
+	 | None -> ()) list;
+    (!a_faire, !a_faire_opt)
+  with Sys_error _ -> ("","")
+
+
+(* 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 = ' ' or c = '#' or c = ':' (* separators and comments *)
+	or c = '%' (* pattern *)
+	or c = '?' or c = '[' or c = ']' or c = '*' (* expansion in filenames *)
+	or i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 
+	    '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'
+
+let canonize f =
+  let f' = absolute_dir (Filename.dirname f) // Filename.basename f in
+  match List.filter (fun (_,full) -> f' = full) !vAccu with
+    | (f,_) :: _ -> escape f
+    | _ -> escape f
+
+let traite_fichier_Coq verbose f =
+  try
+    let chan = open_in f in
+    let buf = Lexing.from_channel chan in
+    let deja_vu_v = ref ([]: string list list)
+    and deja_vu_ml = ref ([] : string list) in
+    try
+      while true do
+      	let tok = coq_action buf in
+	match tok with
+	  | Require strl ->
+	      List.iter (fun str ->
+		if not (List.mem str !deja_vu_v) then begin
+	          addQueue deja_vu_v str;
+                  try
+                    let file_str = safe_assoc verbose f str in
+                    printf " %s%s" (canonize file_str) !suffixe
+                  with Not_found ->
+		    if verbose && not (Hashtbl.mem coqlibKnown str) then
+                      warning_module_notfound f str
+       		end) strl
+	  | RequireString s ->
+	      let str = Filename.basename s in
+	      if not (List.mem [str] !deja_vu_v) then begin
+	        addQueue deja_vu_v [str];
+                try
+                  let file_str = Hashtbl.find vKnown [str] in
+                  printf " %s%s" (canonize file_str) !suffixe
+                with Not_found ->
+		  if not (Hashtbl.mem coqlibKnown [str]) then
+		    warning_notfound f s
+       	      end
+	  | Declare sl ->
+	      let declare suff dir s =
+		let base = file_name s dir in
+		let opt = if !option_natdynlk then " "^base^".cmxs" else "" in
+		printf " %s%s%s" (escape base) suff opt
+	      in
+	      let decl str =
+                let s = basename_noext str in
+		if not (List.mem s !deja_vu_ml) then begin
+		  addQueue deja_vu_ml s;
+		  match search_mllib_known s with
+		    | Some mldir -> declare ".cma" mldir s
+		    | None ->
+			match search_ml_known s with
+			  | Some mldir -> declare ".cmo" mldir s
+			  | None -> warning_declare f str
+		end
+	      in List.iter decl sl
+	  | Load str ->
+	      let str = Filename.basename str in
+	      if not (List.mem [str] !deja_vu_v) then begin
+	        addQueue deja_vu_v [str];
+                try
+                  let file_str = Hashtbl.find vKnown [str] in
+                  printf " %s.v" (canonize file_str)
+                with Not_found -> ()
+       	      end
+      done
+    with Fin_fichier -> ();
+      close_in chan
+  with Sys_error _ -> ()
+
+
+let mL_dependencies () =
+  List.iter
+    (fun (name,ext,dirname) ->
+       let fullname = file_name name dirname in
+       let (dep,dep_opt) = traite_fichier_ML fullname ext in
+       let intf = match search_mli_known name with
+	 | None -> ""
+	 | Some mldir -> " "^(file_name name mldir)^".cmi"
+       in
+       let efullname = escape fullname in
+       printf "%s.cmo:%s%s\n" efullname dep intf;
+       printf "%s.cmx:%s%s\n" efullname dep_opt intf;
+       flush stdout)
+    (List.rev !mlAccu);
+  List.iter
+    (fun (name,dirname) ->
+       let fullname = file_name name dirname in
+       let (dep,_) = traite_fichier_ML fullname ".mli" in
+       printf "%s.cmi:%s\n" (escape fullname) dep;
+       flush stdout)
+    (List.rev !mliAccu);
+  List.iter
+    (fun (name,dirname) ->
+       let fullname = file_name name dirname in
+       let (dep,dep_opt) = traite_fichier_mllib fullname ".mllib" in
+       let efullname = escape fullname in
+       printf "%s.cma:%s\n" efullname dep;
+       printf "%s.cmxa %s.cmxs:%s\n" efullname efullname dep_opt;
+       flush stdout)
+    (List.rev !mllibAccu)
+
+let coq_dependencies () =
+  List.iter
+    (fun (name,_) ->
+       let ename = escape name in
+       let glob = if !option_noglob then "" else " "^ename^".glob" in
+       printf "%s%s%s: %s.v" ename !suffixe glob ename;
+       traite_fichier_Coq true (name ^ ".v");
+       printf "\n";
+       flush stdout)
+    (List.rev !vAccu)
+
+let rec suffixes = function
+  | [] -> assert false
+  | [name] -> [[name]]
+  | dir::suffix as l -> l::suffixes suffix
+
+let add_known phys_dir log_dir f =
+  match get_extension f [".v";".ml";".mli";".ml4";".mllib"] with
+    | (basename,".v") ->
+	let name = log_dir@[basename] in
+	let file = phys_dir//basename in
+	let paths = suffixes name in
+	List.iter
+	  (fun n -> safe_hash_add clash_v vKnown (n,file)) paths
+    | (basename,(".ml"|".ml4")) -> add_ml_known basename (Some phys_dir)
+    | (basename,".mli") -> add_mli_known basename (Some phys_dir)
+    | (basename,".mllib") -> add_mllib_known basename (Some phys_dir)
+    | _ -> ()
+
+(* Visits all the directories under [dir], including [dir],
+   or just [dir] if [recur=false] *)
+
+let rec add_directory recur add_file phys_dir log_dir =
+  let dirh = opendir phys_dir in
+  try
+    while true do
+      let f = readdir dirh in
+      (* we avoid . .. and all hidden files and subdirs (e.g. .svn, _darcs) *)
+      if f.[0] <> '.' && 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 List.mem phys_f !norecdir_list then ()
+	      else
+		let log_dir' = if log_dir = [] then ["Coq"] else log_dir@[f] in
+		add_directory recur add_file phys_f log_dir'
+	  | S_REG -> add_file phys_dir log_dir f
+	  | _ -> ()
+    done
+  with End_of_file -> closedir dirh
+
+let add_dir add_file phys_dir log_dir =
+  try add_directory false add_file phys_dir log_dir with Unix_error _ -> ()
+
+let add_rec_dir add_file phys_dir log_dir =
+  handle_unix_error (add_directory true add_file phys_dir) log_dir
+
+let rec treat_file old_dirname old_name =
+  let name = Filename.basename old_name
+  and new_dirname = Filename.dirname old_name in
+  let dirname =
+    match (old_dirname,new_dirname) with
+      | (d, ".") -> d
+      | (None,d) -> Some d
+      | (Some d1,d2) -> Some (d1//d2)
+  in
+  let complete_name = file_name name dirname in
+  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)
+    | S_REG ->
+	(match get_extension name [".v";".ml";".mli";".ml4";".mllib"] with
+	   | (base,".v") ->
+	       let name = file_name base dirname
+	       and absname = absolute_file_name base dirname in
+	       addQueue vAccu (name, absname)
+	   | (base,(".ml"|".ml4" as ext)) -> addQueue mlAccu (base,ext,dirname)
+	   | (base,".mli") -> addQueue mliAccu (base,dirname)
+	   | (base,".mllib") -> addQueue mllibAccu (base,dirname)
+	   | _ -> ())
+    | _ -> ()
diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll
index cc9f2175..89eeed54 100755
--- a/tools/coqdep_lexer.mll
+++ b/tools/coqdep_lexer.mll
@@ -6,75 +6,77 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqdep_lexer.mll 10721 2008-03-26 14:40:30Z notin $ i*)
-  
+(*i $Id$ i*)
+
 {
 
-  open Filename 
+  open Filename
   open Lexing
-   
+
   type mL_token = Use_module of string
 
   type spec = bool
-		
-  type coq_token = 
-    | Require of spec * string list list
-    | RequireString of spec * string
+
+  type coq_token =
+    | Require of string list list
+    | RequireString of string
     | Declare of string list
     | Load of string
 
   let comment_depth = ref 0
- 
+
   exception Fin_fichier
-    
+
   let module_current_name = ref []
   let module_names = ref []
   let ml_module_name = ref ""
-		      
-  let specif = ref false
-		 
+
   let mllist = ref ([] : string list)
 
   let field_name s = String.sub s 1 (String.length s - 1)
+
 }
 
 let space = [' ' '\t' '\n' '\r']
 let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255']
 let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
-let identchar = 
+let identchar =
   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let coq_ident = ['a'-'z' '_' '0'-'9' 'A'-'Z']+
 let coq_field = '.'['a'-'z' '_' '0'-'9' 'A'-'Z']+
+let caml_up_ident = uppercase identchar*
+let caml_low_ident = lowercase identchar*
 let dot = '.' ( space+ | eof)
 
 rule coq_action = parse
   | "Require" space+
-      { specif := false; module_names := []; opened_file lexbuf }
+      { module_names := []; opened_file lexbuf }
   | "Require" space+ "Export" space+
-      { specif := false; module_names := []; opened_file lexbuf}
+      { module_names := []; opened_file lexbuf}
   | "Require" space+ "Import" space+
-      { specif := false; module_names := []; opened_file lexbuf}
-  | "Declare" space+ "ML" space+ "Module" space+
+      { module_names := []; opened_file lexbuf}
+  | "Local"? "Declare" space+ "ML" space+ "Module" space+
       { mllist := []; modules lexbuf}
   | "Load" space+
       { load_file lexbuf }
   | "\""
       { string lexbuf; coq_action lexbuf}
   | "(*" (* "*)" *)
-      { comment_depth := 1; comment lexbuf; coq_action lexbuf }  
-  | eof 
-      { raise Fin_fichier} 
-  | _   
+      { comment_depth := 1; comment lexbuf; coq_action lexbuf }
+  | eof
+      { raise Fin_fichier}
+  | _
       { coq_action lexbuf }
 
 and caml_action = parse
-  | [' ' '\010' '\013' '\009' '\012'] +
-      { caml_action lexbuf }
-  | "open" [' ' '\010' '\013' '\009' '\012']*
-        { caml_opened_file lexbuf }
-  | lowercase identchar*
+  | space +
       { caml_action lexbuf }
-  | uppercase identchar*
+  | "open" space* (caml_up_ident as id)
+        { Use_module (String.uncapitalize id) }
+  | "module" space+ caml_up_ident
+        { caml_action lexbuf }
+  | caml_low_ident { caml_action lexbuf }
+  | caml_up_ident
       { ml_module_name := Lexing.lexeme lexbuf;
         qual_id lexbuf }
   | ['0'-'9']+
@@ -130,7 +132,7 @@ and comment = parse
   | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
       { comment lexbuf }
   | eof
-      { raise Fin_fichier } 
+      { raise Fin_fichier }
   | _ { comment lexbuf }
 
 and string = parse
@@ -155,7 +157,7 @@ and load_file = parse
 	Load (if check_suffix f ".v" then chop_suffix f ".v" else f) }
   | coq_ident
       { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s }
-  | eof	
+  | eof
       { raise Fin_fichier }
   | _
       { load_file lexbuf }
@@ -169,10 +171,6 @@ and opened_file = parse
   | "(*" (* "*)" *) { comment_depth := 1; comment lexbuf; opened_file lexbuf }
   | space+
       	       	{ opened_file lexbuf }
-  | "Implementation"
-                { opened_file lexbuf }
-  | "Specification"
-                { specif := true; opened_file lexbuf }
   | coq_ident
        	       	{ module_current_name := [Lexing.lexeme lexbuf];
                   opened_file_fields lexbuf }
@@ -184,7 +182,7 @@ and opened_file = parse
                           if Filename.check_suffix str ".v" then
                             Filename.chop_suffix str ".v"
                           else str in
-			RequireString (!specif, str) }
+			RequireString str }
   | eof         { raise Fin_fichier }
   | _           { opened_file lexbuf }
 
@@ -198,13 +196,13 @@ and opened_file_fields = parse
                 { module_current_name :=
                     field_name (Lexing.lexeme lexbuf) :: !module_current_name;
                   opened_file_fields lexbuf }
-  | coq_ident   { module_names := 
+  | coq_ident   { module_names :=
                     List.rev !module_current_name :: !module_names;
                   module_current_name := [Lexing.lexeme lexbuf];
                   opened_file_fields lexbuf }
   | dot         { module_names :=
                     List.rev !module_current_name :: !module_names;
-                  Require (!specif, List.rev !module_names) }
+                  Require (List.rev !module_names) }
   | eof         { raise Fin_fichier }
   | _           { opened_file_fields lexbuf }
 
@@ -213,23 +211,22 @@ and modules = parse
   | "(*" (* "*)" *)	{ comment_depth := 1; comment lexbuf;
       	       	       	  modules lexbuf }
   | '"' [^'"']* '"'
-        { let lex = (Lexing.lexeme lexbuf) in 
+        { let lex = (Lexing.lexeme lexbuf) in
 	  let str = String.sub lex 1 (String.length lex - 2) in
 	    mllist := str :: !mllist; modules lexbuf}
-  | _   { (Declare (List.rev !mllist)) }   
+  | _   { (Declare (List.rev !mllist)) }
 
 and qual_id = parse
-  | '.' [^ '.' '(' '['] { Use_module (String.uncapitalize !ml_module_name) }
+  | '.' [^ '.' '(' '['] {
+      Use_module (String.uncapitalize !ml_module_name) }
   | eof { raise Fin_fichier }
   | _ { caml_action lexbuf }
 
-and caml_opened_file = parse
-  | uppercase identchar*
-      { let lex = (Lexing.lexeme lexbuf) in 
-        let str = String.sub lex 0 (String.length lex) in
-        (Use_module (String.uncapitalize str)) }
-  | eof {raise Fin_fichier }
-  | _ { caml_action lexbuf }
+and mllib_list = parse
+  | coq_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf)
+		in s :: mllib_list lexbuf }
+  | space+ { mllib_list lexbuf }
+  | eof { [] }
 
 
 
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
index b1a46bae..d25034f2 100644
--- a/tools/coqdoc/alpha.ml
+++ b/tools/coqdoc/alpha.ml
@@ -6,9 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: alpha.ml 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
-let norm_char c = match Char.uppercase c with
+open Cdglobals
+
+let norm_char_latin1 c = match Char.uppercase c with
   | '\192'..'\198' -> 'A'
   | '\199' -> 'C'
   | '\200'..'\203' -> 'E'
@@ -19,6 +21,13 @@ let norm_char c = match Char.uppercase c with
   | '\221' -> 'Y'
   | c -> c
 
+let norm_char_utf8 c = Char.uppercase c
+
+let norm_char c =
+  if !utf8 then norm_char_utf8 c else
+  if !latin1 then norm_char_latin1 c else
+  Char.uppercase c
+
 let norm_string s =
   let u = String.copy s in
   for i = 0 to String.length s - 1 do
@@ -30,12 +39,14 @@ let compare_char c1 c2 = match norm_char c1, norm_char c2 with
   | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2
   | 'A'..'Z', _ -> -1
   | _, 'A'..'Z' -> 1
+  | '_', _ -> -1
+  | _, '_' -> 1
   | c1, c2 -> compare c1 c2
 
-let compare_string s1 s2 = 
+let compare_string s1 s2 =
   let n1 = String.length s1 in
   let n2 = String.length s2 in
-  let rec cmp i = 
+  let rec cmp i =
     if i == n1 || i == n2 then
       n1 - n2
     else
diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli
index d3c26537..922a10d6 100644
--- a/tools/coqdoc/alpha.mli
+++ b/tools/coqdoc/alpha.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: alpha.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Alphabetic order. *)
 
diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml
index b3f0739d..b2e23657 100644
--- a/tools/coqdoc/cdglobals.ml
+++ b/tools/coqdoc/cdglobals.ml
@@ -25,9 +25,19 @@ let out_to = ref MultFiles
 
 let out_channel = ref stdout
 
+let coqdoc_out f =
+  if !output_dir <> "" && Filename.is_relative f then
+    if not (Sys.file_exists !output_dir) then
+      (Printf.eprintf "No such directory: %s\n" !output_dir; exit 1)
+    else
+      Filename.concat !output_dir f
+  else
+    f
+
 let open_out_file f =
-  let f = if !output_dir <> "" && Filename.is_relative f then Filename.concat !output_dir f else f in
-    out_channel := open_out f
+  out_channel :=
+    try open_out (coqdoc_out f)
+    with Sys_error s -> Printf.eprintf "%s\n" s; exit 1
 
 let close_out_file () = close_out !out_channel
 
@@ -37,7 +47,7 @@ type glob_source_t =
     | DotGlob
     | GlobFile of string
 
-let glob_source = ref DotGlob 
+let glob_source = ref DotGlob
 
 let header_trailer = ref true
 let header_file = ref ""
@@ -50,6 +60,7 @@ let gallina = ref false
 let short = ref false
 let index = ref true
 let multi_index = ref false
+let index_name = ref "index"
 let toc = ref false
 let page_title = ref ""
 let title = ref ""
@@ -58,6 +69,10 @@ let coqlib = ref Coq_config.wwwstdlib
 let coqlib_path = ref Coq_config.coqlib
 let raw_comments = ref false
 let parse_comments = ref false
+let plain_comments = ref false
+let toc_depth = (ref None : int option ref)
+let lib_name = ref "Library"
+let lib_subtitles = ref false
 let interpolate = ref false
 
 let charset = ref "iso-8859-1"
@@ -82,4 +97,3 @@ type coq_module = string
 type file =
   | Vernac_file of string * coq_module
   | Latex_file of string
-      
diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css
index 762be5af..24b514b7 100644
--- a/tools/coqdoc/coqdoc.css
+++ b/tools/coqdoc/coqdoc.css
@@ -19,14 +19,16 @@ body { padding: 0px 0px;
              margin: 0;}
 
 
-/* Contenu */
+/* Contents */
 
 #main{ display: block;
        padding: 10px;
-       overflow: hidden;
+       font-family: sans-serif;
        font-size: 100%;
        line-height: 100% }
 
+#main  h1 { line-height: 95% } /* allow for multi-line headers */
+
 #main  a.idref:visited {color : #416DFF; text-decoration : none; }
 #main  a.idref:link {color : #416DFF; text-decoration : none; }
 #main  a.idref:hover {text-decoration : none; }
@@ -40,41 +42,93 @@ body { padding: 0px 0px;
 #main .keyword { color : #cf1d1d }
 #main { color: black }
 
-#main .section { background-color:#90bdff;
-                 font-size : 175% }
+.section { background-color: rgb(60%,60%,100%);
+           padding-top: 13px; 
+           padding-bottom: 13px; 
+           padding-left: 3px; 
+           margin-top: 5px;
+           margin-bottom: 5px;
+           font-size : 175% }
+
+h2.section { background-color: rgb(80%,80%,100%);
+             padding-left: 3px; 
+             padding-top: 12px; 
+             padding-bottom: 10px; 
+             font-size : 130% }
+
+h3.section { background-color: rgb(90%,90%,100%);
+             padding-left: 3px; 
+             padding-top: 7px; 
+             padding-bottom: 7px; 
+             font-size : 115% }
+
+h4.section { 
+/*
+                   background-color: rgb(80%,80%,80%);
+                   max-width: 20em;
+                   padding-left: 5px; 
+                   padding-top: 5px; 
+                   padding-bottom: 5px; 
+*/
+                   background-color: white;
+                   padding-left: 0px; 
+                   padding-top: 0px; 
+                   padding-bottom: 0px; 
+                   font-size : 100%;
+                   font-style : bold;
+                   text-decoration : underline;
+ }
 
 #main .doc { margin: 0px;
-             padding: 10px;
              font-family: sans-serif;
              font-size: 100%;
-	     line-height: 100%;
-             font-weight:bold;
+	     line-height: 125%;
+             max-width: 40em;
              color: black;
+	     padding: 10px;
              background-color: #90bdff;
              border-style: plain}
 
 .inlinecode { 
     display: inline;
+/*    font-size: 125%; */
+    color: #666666;
+    font-family: monospace } 
+
+.doc .inlinecode { 
+    display: inline;
+    font-size: 120%; 
+    color: rgb(30%,30%,70%);
+    font-family: monospace } 
+
+.doc .inlinecode .id {
+    color: rgb(30%,30%,70%);
+}
+
+.doc .code { 
+    display: inline;
+    font-size: 120%; 
+    color: rgb(30%,30%,70%); 
     font-family: monospace } 
 
 .comment { 
     display: inline;
     font-family: monospace;
-    color: red; } 
+    color: rgb(50%,50%,80%); 
+} 
 
 .code { 
     display: block;
-    font-family: monospace } 
+/*  padding-left: 15px; */
+    font-size: 110%; 
+    font-family: monospace;
+ } 
 
 /* Pied de page */
 
 #footer { font-size: 65%;
           font-family: sans-serif; }
 
-#footer a:visited { color: blue; }
-#footer a:link { text-decoration: none; 
-                 color: #888888; }
-
 .id { display: inline; }
 
 .id[type="constructor"] { 
@@ -129,3 +183,52 @@ body { padding: 0px 0px;
  color : #cf1d1d;
 /*     color: black; */
 }
+
+.inlinecode .id {
+    color: rgb(0%,0%,0%);
+}
+
+
+/* TOC */
+
+#toc h2 {
+    padding: 10px;
+    background-color: rgb(60%,60%,100%);
+}
+
+#toc li {
+    padding-bottom: 8px;
+}
+
+/* Index */
+
+#index {
+    margin: 0;
+    padding: 0;
+    width: 100%;
+}
+
+#index #frontispiece {
+    margin: 1em auto;
+    padding: 1em;
+    width: 60%;
+}
+
+.booktitle { font-size : 140%  }
+.authors { font-size : 90%;
+	         line-height: 115%;  }
+.moreauthors { font-size : 60%  }
+
+#index #entrance {
+    text-align: center;
+}
+
+#index #entrance .spacer {
+    margin: 0 30px 0 30px;
+}
+
+#index #footer {
+    position: absolute;
+    bottom: 0;
+    text-align: bottom;
+}
\ No newline at end of file
diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty
index fca9a1d7..4314d07d 100644
--- a/tools/coqdoc/coqdoc.sty
+++ b/tools/coqdoc/coqdoc.sty
@@ -65,6 +65,25 @@
 % macro for typesetting tactic identifiers
 \newcommand{\coqdoctac}[1]{\texttt{#1}}
 
+% These are the real macros used by coqdoc, their typesetting is 
+% based on the above macros by default.
+
+\newcommand{\coqdoclibrary}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocinductive}[1]{\coqdocind{#1}}
+\newcommand{\coqdocdefinition}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocvariable}[1]{\coqdocvar{#1}}
+\newcommand{\coqdocconstructor}[1]{\coqdocconstr{#1}}
+\newcommand{\coqdoclemma}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocclass}[1]{\coqdocind{#1}}
+\newcommand{\coqdocinstance}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocmethod}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocabbreviation}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocrecord}[1]{\coqdocind{#1}}
+\newcommand{\coqdocprojection}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocnotation}[1]{\coqdockw{#1}}
+\newcommand{\coqdocsection}[1]{\coqdoccst{#1}}
+\newcommand{\coqdocaxiom}[1]{\coqdocax{#1}}
+\newcommand{\coqdocmoduleid}[1]{\coqdocmod{#1}}
 
 % Environment encompassing code fragments
 % !!! CAUTION: This environment may have empty contents
@@ -102,15 +121,18 @@
 
   \newcommand{\coqdef}[3]{\phantomsection\hypertarget{coq:#1}{#3}}
   \newcommand{\coqref}[2]{\hyperlink{coq:#1}{#2}}
+  \newcommand{\coqexternalref}[3]{\href{#1.html\##2}{#3}}
+
   \newcommand{\identref}[2]{\hyperlink{coq:#1}{\textsf {#2}}}
-  \newcommand{\coqlibrary}[2]{\cleardoublepage\phantomsection
-    \hypertarget{coq:#1}{\chapter{Library \texorpdfstring{\coqdoccst}{}{#2}}}}
+  \newcommand{\coqlibrary}[3]{\cleardoublepage\phantomsection
+    \hypertarget{coq:#1}{\chapter{#2\texorpdfstring{\coqdoccst}{}{#3}}}}
 \else
   \newcommand{\coqdef}[3]{#3}
   \newcommand{\coqref}[2]{#2}
+  \newcommand{\coqexternalref}[3]{#3}
   \newcommand{\texorpdfstring}[2]{#1}
   \newcommand{\identref}[2]{\textsf{#2}}
-  \newcommand{\coqlibrary}[2]{\cleardoublepage\chapter{Library \coqdoccst{#2}}}
+  \newcommand{\coqlibrary}[3]{\cleardoublepage\chapter{#2\coqdoccst{#3}}}
 \fi
 \usepackage{xr}
 
@@ -147,54 +169,4 @@
 \def\coqdoctac#1{{\color{\coqdoctaccolor}{\texttt{#1}}}}
 \fi
 
-\newcommand{\coqdefinition}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqdefinitionref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqvariable}[2]{\coqdocvar{#2}}
-\newcommand{\coqvariableref}[2]{\coqref{#1}{\coqdocvar{#2}}}
-
-\newcommand{\coqinductive}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}}
-\newcommand{\coqinductiveref}[2]{\coqref{#1}{\coqdocind{#2}}}
-
-\newcommand{\coqconstructor}[2]{\coqdef{#1}{#2}{\coqdocconstr{#2}}}
-\newcommand{\coqconstructorref}[2]{\coqref{#1}{\coqdocconstr{#2}}}
-
-\newcommand{\coqlemma}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqlemmaref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqclass}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}}
-\newcommand{\coqclassref}[2]{\coqref{#1}{\coqdocind{#2}}}
-
-\newcommand{\coqinstance}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqinstanceref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqmethod}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqmethodref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqabbreviation}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqabbreviationref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqrecord}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}}
-\newcommand{\coqrecordref}[2]{\coqref{#1}{\coqdocind{#2}}}
-
-\newcommand{\coqprojection}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqprojectionref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqnotationref}[2]{\coqref{#1}{\coqdockw{#2}}}
-
-\newcommand{\coqsection}[2]{\coqdef{sec:#1}{#2}{\coqdoccst{#2}}}
-\newcommand{\coqsectionref}[2]{\coqref{sec:#1}{\coqdoccst{#2}}}
-
-%\newcommand{\coqlibrary}[2]{\chapter{Library \coqdoccst{#2}}\label{coq:#1}}
-  
-%\newcommand{\coqlibraryref}[2]{\ref{coq:#1}}
-
-\newcommand{\coqlibraryref}[2]{\coqref{#1}{\coqdoccst{#2}}}
-
-\newcommand{\coqaxiom}[2]{\coqdef{#1}{#2}{\coqdocax{#2}}}
-\newcommand{\coqaxiomref}[2]{\coqref{#1}{\coqdocax{#2}}}
-
-\newcommand{\coqmodule}[2]{\coqdef{mod:#1}{#2}{\coqdocmod{#2}}}
-\newcommand{\coqmoduleref}[2]{\coqref{mod:#1}{\coqdocmod{#2}}}
-
 \endinput
diff --git a/tools/coqdoc/pretty.mli b/tools/coqdoc/cpretty.mli
index dda0439e..213c76aa 100644
--- a/tools/coqdoc/pretty.mli
+++ b/tools/coqdoc/cpretty.mli
@@ -6,8 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretty.mli 8617 2006-03-08 10:47:12Z notin $ i*)
+(*i $Id$ i*)
 
 open Index
 
 val coq_file : string -> Cdglobals.coq_module -> unit
+val detect_subtitle : string -> Cdglobals.coq_module -> string option
diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll
new file mode 100644
index 00000000..be8bc85d
--- /dev/null
+++ b/tools/coqdoc/cpretty.mll
@@ -0,0 +1,1176 @@
+(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s Utility functions for the scanners *)
+
+{
+  open Printf
+  open Lexing
+
+  (* A function that emulates Lexing.new_line (which does not exist in OCaml < 3.11.0) *)
+  let new_line lexbuf =
+    let pos = lexbuf.lex_curr_p in
+      lexbuf.lex_curr_p <- { pos with
+	pos_lnum = pos.pos_lnum + 1;
+	pos_bol = pos.pos_cnum }
+
+  (* A list function we need *)
+  let rec take n ls =
+    if n = 0 then [] else
+      match ls with
+        | [] -> []
+        | (l :: ls) -> l :: (take (n-1) ls)
+
+  (* count the number of spaces at the beginning of a string *)
+  let count_spaces s =
+    let n = String.length s in
+    let rec count c i =
+      if i == n then c,i else match s.[i] with
+	| '\t' -> count (c + (8 - (c mod 8))) (i + 1)
+	| ' ' -> count (c + 1) (i + 1)
+	| _ -> c,i
+    in
+      count 0 0
+
+  let remove_newline s =
+    let n = String.length s in
+    let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in
+    let i = count 0 in
+    i, String.sub s i (n - i)
+
+  let count_dashes s =
+    let c = ref 0 in
+    for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done;
+    !c
+
+  let cut_head_tail_spaces s =
+    let n = String.length s in
+    let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in
+    let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in
+    let l = look_up 0 in
+    let r = look_dn (n-1) in
+    if l <= r then String.sub s l (r-l+1) else s
+
+  let sec_title s =
+    let rec count lev i =
+      if s.[i] = '*' then
+	count (succ lev) (succ i)
+      else
+	let t = String.sub s i (String.length s - i) in
+	lev, cut_head_tail_spaces t
+    in
+    count 0 (String.index s '*')
+
+  let strip_eol s =
+    let eol = s.[String.length s - 1] = '\n' in
+    (eol, if eol then String.sub s 1 (String.length s - 1) else s)
+
+
+  let formatted = ref false
+  let brackets = ref 0
+  let comment_level = ref 0
+  let in_proof = ref None
+  let in_emph = ref false
+
+  let start_emph () = in_emph := true; Output.start_emph ()
+  let stop_emph () = if !in_emph then (Output.stop_emph (); in_emph := false)
+
+  let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos;
+    lexbuf.lex_curr_p <- lexbuf.lex_start_p
+
+  let backtrack_past_newline lexbuf =
+    let buf = lexeme lexbuf in
+    let splits = Str.bounded_split_delim (Str.regexp "['\n']") buf 2 in
+      match splits with
+        | [] -> ()
+        | (_ :: []) -> ()
+        | (s1 :: rest :: _) ->
+            let length_skip = 1 + String.length s1 in
+              lexbuf.lex_curr_pos <- lexbuf.lex_start_pos + length_skip
+
+  let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
+
+  (* saving/restoring the PP state *)
+
+  type state = {
+    st_gallina : bool;
+    st_light : bool
+  }
+
+  let state_stack = Stack.create ()
+
+  let save_state () =
+    Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack
+
+  let restore_state () =
+    let s = Stack.pop state_stack in
+    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 show_all f = without_gallina (without_light f)
+
+  let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false
+  let end_show () = restore_state ()
+
+  (* Reset the globals *)
+
+  let reset () =
+    formatted := false;
+    brackets := 0;
+    comment_level := 0
+
+  (* erasing of Section/End *)
+
+  let section_re = Str.regexp "[ \t]*Section"
+  let end_re = Str.regexp "[ \t]*End"
+  let is_section s = Str.string_match section_re s 0
+  let is_end s = Str.string_match end_re s 0
+
+  let sections_to_close = ref 0
+
+  let section_or_end s =
+    if is_section s then begin
+      incr sections_to_close; true
+    end else if is_end s then begin
+      if !sections_to_close > 0 then begin
+	decr sections_to_close; true
+      end else
+	false
+    end else
+      true
+
+  (* for item lists *)
+  type list_compare =
+      | Before
+      | StartLevel of int
+      | InLevel of int * bool
+
+  (* Before : we're before any levels
+     StartLevel : at the same column as the dash in a level
+     InLevel : after the dash of this level, but before any deeper dashes.
+               bool is true if this is the last level *)
+  let find_level levels cur_indent =
+    match levels with
+    | [] -> Before
+    | (l::ls) ->
+        if cur_indent < l then Before
+        else
+          (* cur_indent will never be less than the head of the list *)
+          let rec findind ls n =
+            match ls with
+            | [] -> InLevel (n,true)
+            | (l :: []) -> if cur_indent = l then StartLevel n
+                           else InLevel (n,true)
+            | (l1 :: l2 :: ls) ->
+                if cur_indent = l1 then StartLevel n
+                else if cur_indent < l2 then InLevel (n,false)
+                     else findind (l2 :: ls) (n+1)
+          in
+            findind (l::ls) 1
+
+  type is_start_list =
+    | Rule
+    | List of int
+    | Neither
+
+  let check_start_list str =
+    let n_dashes = count_dashes str in
+    let (n_spaces,_) = count_spaces str in
+      if n_dashes >= 4 && not !Cdglobals.plain_comments then
+        Rule
+      else
+        if n_dashes = 1 && not !Cdglobals.plain_comments then
+          List n_spaces
+        else
+          Neither
+
+   (* examine a string for subtitleness *)
+  let subtitle m s =
+    match Str.split_delim (Str.regexp ":") s with
+    | [] -> false
+    | (name::_) ->
+        if (cut_head_tail_spaces name) = m then
+          true
+        else
+          false
+
+
+  (* tokens pretty-print *)
+
+  let token_buffer = Buffer.create 1024
+
+  let token_re =
+    Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)"
+  let printing_token_re =
+    Str.regexp
+      "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\(&#\\|[^#]\\)*\\)#\\)?"
+
+  let add_printing_token toks pps =
+    try
+      if Str.string_match token_re toks 0 then
+	let tok = Str.matched_group 1 toks in
+	if Str.string_match printing_token_re pps 0 then
+	  let pp =
+	    (try Some (Str.matched_group 3 pps) with _ ->
+             try Some (Str.matched_group 4 pps) with _ -> None),
+	    (try Some (Str.matched_group 6 pps) with _ -> None)
+	  in
+	  Output.add_printing_token tok pp
+    with _ ->
+      ()
+
+  let remove_token_re =
+    Str.regexp
+      "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)"
+
+  let remove_printing_token toks =
+    try
+      if Str.string_match remove_token_re toks 0 then
+	let tok = Str.matched_group 1 toks in
+	Output.remove_printing_token tok
+    with _ ->
+      ()
+
+  let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:="
+  let extract_ident s =
+    assert (String.length s >= 3);
+    if Str.string_match extract_ident_re s 0 then
+      Str.matched_group 1 s
+    else
+      String.sub s 1 (String.length s - 3)
+
+  let output_indented_keyword s lexbuf =
+    let nbsp,isp = count_spaces s in
+    Output.indentation nbsp;
+    let s = String.sub s isp (String.length s - isp) in
+    Output.ident s (lexeme_start lexbuf + isp)
+
+}
+
+(*s Regular expressions *)
+
+let space = [' ' '\t']
+let space_nl = [' ' '\t' '\n' '\r']
+let nl = "\r\n" | '\n'
+
+let firstchar =
+  ['A'-'Z' 'a'-'z' '_'] |
+  (* superscript 1 *)
+  '\194' '\185' |
+  (* utf-8 latin 1 supplement *)
+  '\195' ['\128'-'\191'] |
+  (* utf-8 letterlike symbols *)
+  (* '\206' ([ '\145' - '\183'] | '\187') | *)
+  (* '\xCF' [ '\x00' - '\xCE' ] |  *)
+  (* utf-8 letterlike symbols *)
+  '\206' ('\160' | [ '\177'-'\183'] | '\187') |
+  '\226' ('\130' [ '\128'-'\137' ] (* subscripts *)
+    | '\129' [ '\176'-'\187' ] (* superscripts *)
+    | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143'])
+let identchar =
+  firstchar | ['\'' '0'-'9' '@' ]
+let id = firstchar identchar*
+let pfx_id = (id '.')*
+let identifier =
+  id | pfx_id id
+
+(* This misses unicode stuff, and it adds "[" and "]".  It's only an
+   approximation of idents - used for detecting whether an underscore
+   is part of an identifier or meant to indicate emphasis *)
+let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' '\'' '0'-'9' '@' ]
+
+let printing_token = [^ ' ' '\t']*
+
+let thm_token =
+  "Theorem"
+  | "Lemma"
+  | "Fact"
+  | "Remark"
+  | "Corollary"
+  | "Proposition"
+  | "Property"
+  | "Goal"
+
+let prf_token =
+  "Next" space+ "Obligation"
+  | "Proof" (space* "." | space+ "with")
+
+let def_token =
+  "Definition"
+  | "Let"
+  | "Class"
+  | "SubClass"
+  | "Example"
+  | "Local"
+  | "Fixpoint"
+  | "Boxed"
+  | "CoFixpoint"
+  | "Record"
+  | "Structure"
+  | "Scheme"
+  | "Inductive"
+  | "CoInductive"
+  | "Equations"
+  | "Instance"
+  | "Global" space+ "Instance"
+
+let decl_token =
+  "Hypothesis"
+  | "Hypotheses"
+  | "Parameter"
+  | "Axiom" 's'?
+  | "Conjecture"
+
+let gallina_ext =
+  "Module"
+  | "Include" space+ "Type"
+  | "Include"
+  | "Declare" space+ "Module"
+  | "Transparent"
+  | "Opaque"
+  | "Canonical"
+  | "Coercion"
+  | "Identity"
+  | "Implicit"
+  | "Tactic" space+ "Notation"
+  | "Section"
+  | "Context"
+  | "Variable" 's'?
+  | ("Hypothesis" | "Hypotheses")
+  | "End"
+
+let notation_kw =
+    "Notation"
+  | "Infix"
+  | "Reserved" space+ "Notation"
+
+let commands =
+  "Pwd"
+  | "Cd"
+  | "Drop"
+  | "ProtectedLoop"
+  | "Quit"
+  | "Load"
+  | "Add"
+  | "Remove" space+ "Loadpath"
+  | "Print"
+  | "Inspect"
+  | "About"
+  | "Search"
+  | "Eval"
+  | "Reset"
+  | "Check"
+  | "Type"
+
+  | "Section"
+  | "Chapter"
+  | "Variable" 's'?
+  | ("Hypothesis" | "Hypotheses")
+  | "End"
+
+let end_kw = "Qed" | "Defined" | "Save" | "Admitted" | "Abort"
+
+let extraction =
+  "Extraction"
+  | "Recursive" space+ "Extraction"
+  | "Extract"
+
+let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction
+
+let prog_kw =
+  "Program" space+ gallina_kw
+  | "Obligation"
+  | "Obligations"
+  | "Solve"
+
+let gallina_kw_to_hide =
+    "Implicit" space+ "Arguments"
+  | "Ltac"
+  | "Require"
+  | "Import"
+  | "Export"
+  | "Load"
+  | "Hint"
+  | "Open"
+  | "Close"
+  | "Delimit"
+  | "Transparent"
+  | "Opaque"
+  | ("Declare" space+ ("Morphism" | "Step") )
+  | ("Set" | "Unset") space+ "Printing" space+ "Coercions"
+  | "Declare" space+ ("Left" | "Right") space+ "Step"
+
+
+let section = "*" | "**" | "***" | "****"
+
+let item_space = "    "
+
+let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl
+let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl
+let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl
+let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl
+(*
+let begin_verb = "(*" space* "begin" space+ "verb" space* "*)"
+let end_verb = "(*" space* "end" space+ "verb" space* "*)"
+*)
+
+(*s Scanning Coq, at beginning of line *)
+
+rule coq_bol = parse
+  | space* nl+
+      { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light))
+        then Output.empty_line_of_code ();
+        coq_bol lexbuf }
+  | space* "(**" space_nl
+      { Output.end_coq (); Output.start_doc ();
+	let eol = doc_bol lexbuf in
+	  Output.end_doc (); Output.start_coq ();
+	  if eol then coq_bol lexbuf else coq lexbuf }
+  | space* "Comments" space_nl
+      { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc ();
+	Output.start_coq (); coq lexbuf }
+  | space* begin_hide
+      { skip_hide lexbuf; coq_bol lexbuf }
+  | space* begin_show
+      { begin_show (); coq_bol lexbuf }
+  | space* end_show
+      { end_show (); coq_bol lexbuf }
+  | space* gallina_kw_to_hide
+      { let s = lexeme lexbuf in
+	  if !Cdglobals.light && section_or_end s then
+	    let eol = skip_to_dot lexbuf in
+	      if eol then (coq_bol lexbuf) else coq lexbuf
+	  else
+	    begin
+	      output_indented_keyword s lexbuf;
+	      let eol = body lexbuf in
+	      if eol then coq_bol lexbuf else coq lexbuf
+	    end }
+  | space* thm_token
+      { let s = lexeme lexbuf in
+        output_indented_keyword s lexbuf;
+        let eol = body lexbuf in
+	in_proof := Some eol;
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | space* prf_token
+      { in_proof := Some true;
+	let eol =
+	  if not !Cdglobals.gallina then
+	    begin backtrack lexbuf; body_bol lexbuf end
+	  else
+	    let s = lexeme lexbuf in
+	      if s.[String.length s - 1] = '.' then false
+	      else skip_to_dot lexbuf
+	in if eol then coq_bol lexbuf else coq lexbuf }
+  | space* end_kw {
+      let eol =
+	if not (!in_proof <> None && !Cdglobals.gallina) then
+	  begin backtrack lexbuf; body_bol lexbuf end
+	else skip_to_dot lexbuf
+      in
+	in_proof := None;
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | space* gallina_kw
+      {
+	in_proof := None;
+	let s = lexeme lexbuf in
+	output_indented_keyword s lexbuf;
+	let eol= body lexbuf in
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | space* prog_kw
+      {
+	in_proof := None;
+	let s = lexeme lexbuf in
+	output_indented_keyword s lexbuf;
+	let eol= body lexbuf in
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | space* notation_kw space*
+      {	let s = lexeme lexbuf in
+	output_indented_keyword s lexbuf;
+	let eol= start_notation_string lexbuf in
+	if eol then coq_bol lexbuf else coq lexbuf }
+
+  | space* "(**" space+ "printing" space+ printing_token space+
+      { let tok = lexeme lexbuf in
+	let s = printing_token_body lexbuf in
+	  add_printing_token tok s;
+	  coq_bol lexbuf }
+  | space* "(**" space+ "printing" space+
+      { eprintf "warning: bad 'printing' command at character %d\n"
+	  (lexeme_start lexbuf); flush stderr;
+	comment_level := 1;
+	ignore (comment lexbuf);
+	coq_bol lexbuf }
+  | space* "(**" space+ "remove" space+ "printing" space+
+      printing_token space* "*)"
+      { remove_printing_token (lexeme lexbuf);
+	coq_bol lexbuf }
+  | space* "(**" space+ "remove" space+ "printing" space+
+      { eprintf "warning: bad 'remove printing' command at character %d\n"
+	  (lexeme_start lexbuf); flush stderr;
+	comment_level := 1;
+	ignore (comment lexbuf);
+	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 }
+  | eof
+      { () }
+  | _
+      { let eol =
+	  if not !Cdglobals.gallina then
+	    begin backtrack lexbuf; body_bol lexbuf end
+	  else
+	    skip_to_dot lexbuf
+	in
+	  if eol then coq_bol lexbuf else coq lexbuf }
+
+(*s Scanning Coq elsewhere *)
+
+and coq = parse
+  | nl
+      { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf }
+  | "(**" space_nl
+      { Output.end_coq (); Output.start_doc ();
+	let eol = doc_bol lexbuf in
+	  Output.end_doc (); Output.start_coq ();
+	  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
+      }
+  | nl+ space* "]]"
+      { if not !formatted then
+	begin
+	  (* Isn't this an anomaly *)
+	  let s = lexeme lexbuf in
+	  let nlsp,s = remove_newline s in
+	  let nbsp,isp = count_spaces s in
+	  Output.indentation nbsp;
+	  let loc = lexeme_start lexbuf + isp + nlsp in
+	  Output.sublexer ']' loc;
+	  Output.sublexer ']' (loc+1);
+	  coq lexbuf
+	end }
+  | eof
+      { () }
+  | gallina_kw_to_hide
+      { let s = lexeme lexbuf in
+	  if !Cdglobals.light && section_or_end s then
+	    begin
+	      let eol = skip_to_dot lexbuf in
+		if eol then coq_bol lexbuf else coq lexbuf
+	    end
+	  else
+	    begin
+	      Output.ident s (lexeme_start lexbuf);
+	      let eol=body lexbuf in
+		if eol then coq_bol lexbuf else coq lexbuf
+	    end }
+  | prf_token
+      { let eol =
+	  if not !Cdglobals.gallina then
+	    begin backtrack lexbuf; body_bol lexbuf end
+	  else
+	    let s = lexeme lexbuf in
+	    let eol =
+	      if s.[String.length s - 1] = '.' then false
+	      else skip_to_dot lexbuf
+	    in
+	      eol
+	in if eol then coq_bol lexbuf else coq lexbuf }
+  | end_kw {
+      let eol =
+	if not !Cdglobals.gallina then
+	  begin backtrack lexbuf; body lexbuf end
+	else
+	  let eol = skip_to_dot lexbuf in
+	    if !in_proof <> Some true && eol then
+	      Output.line_break ();
+	    eol
+      in
+	in_proof := None;
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | gallina_kw
+      { let s = lexeme lexbuf in
+	  Output.ident s (lexeme_start lexbuf);
+	let eol = body lexbuf in
+	  if eol then coq_bol lexbuf else coq lexbuf }
+  | notation_kw space*
+      { let s = lexeme lexbuf in
+	Output.ident s (lexeme_start lexbuf);
+	let eol= start_notation_string lexbuf in
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | prog_kw
+      { let s = lexeme lexbuf in
+	  Output.ident s (lexeme_start lexbuf);
+	let eol = body lexbuf in
+	  if eol then coq_bol lexbuf else coq lexbuf }
+  | space+ { Output.char ' '; coq lexbuf }
+  | eof
+      { () }
+  | _ {	let eol =
+	  if not !Cdglobals.gallina then
+	    begin backtrack lexbuf; body lexbuf end
+	  else
+	    skip_to_dot lexbuf
+	in
+	  if eol then coq_bol lexbuf else coq lexbuf}
+
+(*s Scanning documentation, at beginning of line *)
+
+and doc_bol = parse
+  | space* nl+
+      { Output.paragraph (); doc_bol lexbuf }
+  | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')?
+      { let eol, lex = strip_eol (lexeme lexbuf) in
+        let lev, s = sec_title lex in
+          if (!Cdglobals.lib_subtitles) &&
+             (subtitle (Output.get_module false) s) then
+            ()
+          else
+            Output.section lev (fun () -> ignore (doc None (from_string s)));
+	    if eol then doc_bol lexbuf else doc None lexbuf }
+  | space* nl space* '-'+
+      { (* adding this production instead of just letting the paragraph
+           production and the begin list production fire eliminates
+           extra vertical whitespace. *)
+        let buf' = lexeme lexbuf in
+        let buf =
+          let bufs = Str.split_delim (Str.regexp "['\n']") buf' in
+            match bufs with
+              | (_ :: s :: []) -> s
+              | (_ :: _ :: s :: _) -> s
+              | _ -> eprintf "Internal error bad_split1 - please report\n";
+                     exit 1
+        in
+          match check_start_list buf with
+          | Neither -> backtrack_past_newline lexbuf; doc None lexbuf
+          | List n -> Output.item 1; doc (Some [n]) lexbuf
+          | Rule -> Output.rule (); doc None lexbuf
+      }
+  | space* '-'+
+      { let buf = lexeme lexbuf in
+          match check_start_list buf with
+          | Neither -> backtrack lexbuf; doc None lexbuf
+          | List n -> Output.item 1; doc (Some [n]) lexbuf
+          | Rule -> Output.rule (); doc None lexbuf
+      }
+  | "<<" space*
+      { Output.start_verbatim (); verbatim lexbuf; doc_bol lexbuf }
+  | eof
+      { true }
+  | '_'
+      { if !Cdglobals.plain_comments then Output.char '_' else start_emph ();
+        doc None lexbuf }
+  | _
+      { backtrack lexbuf; doc None lexbuf }
+
+(*s Scanning lists - using whitespace *)
+and doc_list_bol indents = parse
+  | space* '-'
+      { let (n_spaces,_) = count_spaces (lexeme lexbuf) in
+        match find_level indents n_spaces with
+        | Before -> backtrack lexbuf; doc_bol lexbuf
+        | StartLevel n -> Output.item n; doc (Some (take n indents)) lexbuf
+        | InLevel (n,true) ->
+            let items = List.length indents in
+              Output.item (items+1);
+              doc (Some (List.append indents [n_spaces])) lexbuf
+        | InLevel (_,false) ->
+            backtrack lexbuf; doc_bol lexbuf
+      }
+  | "<<" space*
+      { Output.start_verbatim ();
+        verbatim lexbuf;
+        doc_list_bol indents lexbuf }
+  | "[[" nl
+      { formatted := true;
+        Output.start_inline_coq_block ();
+        ignore(body_bol lexbuf);
+        Output.end_inline_coq_block ();
+        formatted := false;
+        doc_list_bol indents lexbuf }
+  | space* nl space* '-'
+      { (* Like in the doc_bol production, these two productions
+           exist only to deal properly with whitespace *)
+        Output.paragraph ();
+        backtrack_past_newline lexbuf;
+        doc_list_bol indents lexbuf }
+  | space* nl space* _
+      { let buf' = lexeme lexbuf in
+        let buf =
+          let bufs = Str.split_delim (Str.regexp "['\n']") buf' in
+            match bufs with
+              | (_ :: s :: []) -> s
+              | (_ :: _ :: s :: _) -> s
+              | _ -> eprintf "Internal error bad_split2 - please report\n";
+                     exit 1
+        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 -> Output.stop_item ();
+                    backtrack_past_newline lexbuf;
+                    doc_bol lexbuf
+
+      }
+  | space* _
+      { let (n_spaces,_) = count_spaces (lexeme lexbuf) in
+        match find_level indents n_spaces with
+        | Before -> Output.stop_item (); backtrack lexbuf;
+                    doc_bol lexbuf
+        | StartLevel n ->
+            Output.reach_item_level (n-1);
+            backtrack lexbuf;
+            doc (Some (take (n-1) indents)) lexbuf
+        | InLevel (n,_) ->
+            Output.reach_item_level n;
+            backtrack lexbuf;
+            doc (Some (take n indents)) lexbuf
+      }
+
+(*s Scanning documentation elsewhere *)
+and doc indents = parse
+  | nl
+      { Output.char '\n';
+        match indents with
+        | Some ls -> doc_list_bol ls lexbuf
+        | None -> doc_bol lexbuf }
+  | "[[" nl
+      { if !Cdglobals.plain_comments
+        then (Output.char '['; Output.char '['; doc indents lexbuf)
+        else (formatted := true;
+              Output.start_inline_coq_block ();
+	      let eol = body_bol lexbuf in
+	        Output.end_inline_coq_block (); formatted := false;
+	        if eol then
+		  match indents with
+		  | Some ls -> doc_list_bol ls lexbuf
+		  | None -> doc_bol lexbuf
+		else doc indents lexbuf)}
+  | "[]"
+      { Output.proofbox (); doc indents lexbuf }
+  | "["
+      { if !Cdglobals.plain_comments then Output.char '['
+        else (brackets := 1;  Output.start_inline_coq (); escaped_coq lexbuf;
+              Output.end_inline_coq ()); doc indents lexbuf }
+  | "(*"
+      { backtrack lexbuf ;
+        let bol_parse = match indents with
+                        | 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
+      }
+  | '*'* "*)" space* nl
+      { true }
+  | '*'* "*)"
+      { false }
+  | "$"
+      { if !Cdglobals.plain_comments then Output.char '$'
+        else (Output.start_latex_math (); escaped_math_latex lexbuf);
+        doc indents lexbuf }
+  | "$$"
+      { if !Cdglobals.plain_comments then Output.char '$';
+        Output.char '$'; doc indents lexbuf }
+  | "%"
+      { if !Cdglobals.plain_comments then Output.char '%'
+        else escaped_latex lexbuf; doc indents lexbuf }
+  | "%%"
+      { if !Cdglobals.plain_comments then Output.char '%';
+        Output.char '%'; doc indents lexbuf }
+  | "#"
+      { if !Cdglobals.plain_comments then Output.char '#'
+        else escaped_html lexbuf; doc indents lexbuf }
+  | "##"
+      { if !Cdglobals.plain_comments then Output.char '#';
+        Output.char '#'; doc indents lexbuf }
+  | nonidentchar '_' nonidentchar
+      { List.iter (fun x -> Output.char (lexeme_char lexbuf x)) [0;1;2];
+        doc indents lexbuf}
+  | nonidentchar '_'
+      { Output.char (lexeme_char lexbuf 0);
+        if !Cdglobals.plain_comments then Output.char '_' else  start_emph () ;
+        doc indents lexbuf }
+  | '_' nonidentchar
+      { if !Cdglobals.plain_comments then Output.char '_' else stop_emph () ;
+        Output.char (lexeme_char lexbuf 1);
+        doc indents lexbuf }
+  | eof
+      { false }
+  | _
+      { Output.char (lexeme_char lexbuf 0); doc indents lexbuf }
+
+(*s Various escapings *)
+
+and escaped_math_latex = parse
+  | "$" { Output.stop_latex_math () }
+  | eof { Output.stop_latex_math () }
+  | _   { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf }
+
+and escaped_latex = parse
+  | "%" { () }
+  | eof { () }
+  | _   { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf }
+
+and escaped_html = parse
+  | "#" { () }
+  | "&#"
+        { Output.html_char '&'; Output.html_char '#'; escaped_html lexbuf }
+  | "##"
+        { Output.html_char '#'; escaped_html lexbuf }
+  | eof { () }
+  | _   { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf }
+
+and verbatim = parse
+  | nl ">>" space* nl { Output.verbatim_char '\n'; Output.stop_verbatim () }
+  | nl ">>" { Output.verbatim_char '\n'; Output.stop_verbatim () }
+  | eof { Output.stop_verbatim () }
+  | _ { Output.verbatim_char (lexeme_char lexbuf 0); verbatim lexbuf }
+
+(*s Coq, inside quotations *)
+
+and escaped_coq = parse
+  | "]"
+      { decr brackets;
+	if !brackets > 0 then
+	  (Output.sublexer ']' (lexeme_start lexbuf); escaped_coq lexbuf)
+	else Tokens.flush_sublexer () }
+  | "["
+      { incr brackets;
+        Output.sublexer '[' (lexeme_start lexbuf); escaped_coq lexbuf }
+  | "(*"
+      { Tokens.flush_sublexer (); comment_level := 1;
+        ignore (comment lexbuf); escaped_coq lexbuf }
+  | "*)"
+      { (* likely to be a syntax error: we escape *) backtrack lexbuf }
+  | eof
+      { Tokens.flush_sublexer () }
+  | (identifier '.')* identifier
+      { Output.ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf }
+  | space
+      { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0);
+        escaped_coq lexbuf }
+  | _
+      { Output.sublexer (lexeme_char lexbuf 0) (lexeme_start lexbuf);
+        escaped_coq lexbuf }
+
+(*s Coq "Comments" command. *)
+
+and comments = parse
+  | space_nl+
+      { Output.char ' '; comments lexbuf }
+  | '"' [^ '"']* '"'
+      { let s = lexeme lexbuf in
+	let s = String.sub s 1 (String.length s - 2) in
+	ignore (doc None (from_string s)); comments lexbuf }
+  | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+
+      { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf }
+  | "." (space_nl | eof)
+      { () }
+  | eof
+      { () }
+  | _
+      { Output.char (lexeme_char lexbuf 0); comments lexbuf }
+
+(*s Skip comments *)
+
+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 '['
+        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 '[')
+        else (formatted := true;
+              Output.start_inline_coq_block ();
+              let _ = body_bol lexbuf in
+                Output.end_inline_coq_block (); formatted := false);
+      comment lexbuf}
+  | "$"
+      { if !Cdglobals.parse_comments then
+          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.parse_comments
+          then
+            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 '%');
+        comment lexbuf }
+  | "#"
+      { if !Cdglobals.parse_comments
+        then
+          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 '#');
+        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 }
+
+and skip_to_dot = parse
+  | '.' space* nl { true }
+  | eof | '.' space+ { false }
+  | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf }
+  | _ { skip_to_dot lexbuf }
+
+and body_bol = parse
+  | space+
+      { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf }
+  | _ { backtrack lexbuf; Output.indentation 0; body lexbuf }
+
+and body = parse
+  | nl {Tokens.flush_sublexer(); Output.line_break(); new_line lexbuf; body_bol lexbuf}
+  | nl+ space* "]]" space* nl
+      { Tokens.flush_sublexer();
+        if not !formatted then
+          begin
+            let s = lexeme lexbuf in
+            let nlsp,s = remove_newline s in
+            let _,isp = count_spaces s in
+            let loc = lexeme_start lexbuf + nlsp + isp in
+            Output.sublexer ']' loc;
+            Output.sublexer ']' (loc+1);
+            Tokens.flush_sublexer();
+            body lexbuf
+          end
+        else
+          begin
+            Output.paragraph ();
+            true
+          end }
+  | "]]" space* nl
+      { Tokens.flush_sublexer();
+        if not !formatted then
+          begin
+	    let loc = lexeme_start lexbuf in
+	    Output.sublexer ']' loc;
+	    Output.sublexer ']' (loc+1);
+	    Tokens.flush_sublexer();
+	    Output.line_break();
+            body lexbuf
+          end
+        else
+          begin
+            Output.paragraph ();
+            true
+          end }
+  | eof { Tokens.flush_sublexer(); false }
+  | '.' space* nl | '.' space* eof
+	{ Tokens.flush_sublexer(); Output.char '.'; Output.line_break();
+	  if not !formatted then true else body_bol lexbuf }
+  | '.' space* nl "]]" space* nl
+	{ Tokens.flush_sublexer(); Output.char '.';
+        if not !formatted then
+          begin
+            eprintf "Error: stray ]] at %d\n"  (lexeme_start lexbuf);
+            flush stderr;
+            exit 1
+          end
+	  else
+          begin
+            Output.paragraph ();
+            true
+          end
+      }
+  | '.' space+
+        { Tokens.flush_sublexer(); Output.char '.'; Output.char ' ';
+	  if not !formatted then false else body lexbuf }
+  | "(**" space_nl
+      { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc ();
+	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 }
+  | "where" space*
+      { Tokens.flush_sublexer();
+        Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
+	start_notation_string lexbuf }
+  | identifier
+      { Tokens.flush_sublexer();
+        Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
+	body lexbuf }
+  | ".."
+      { Tokens.flush_sublexer(); Output.char '.'; Output.char '.';
+        body lexbuf }
+  | '"'
+      { Tokens.flush_sublexer(); Output.char '"';
+        string lexbuf;
+        body lexbuf }
+  | space
+      { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0);
+        body lexbuf }
+
+  | _ { let c = lexeme_char lexbuf 0 in
+	Output.sublexer c (lexeme_start lexbuf);
+        body lexbuf }
+
+and start_notation_string = parse
+  | '"' (* a true notation *)
+      { Output.sublexer '"' (lexeme_start lexbuf);
+        notation_string lexbuf;
+	body lexbuf }
+  | _ (* an abbreviation *)
+      { backtrack lexbuf; body lexbuf }
+
+and notation_string = parse
+  | "\"\""
+      { Output.char '"'; Output.char '"'; (* Unlikely! *)
+        notation_string lexbuf }
+  | '"'
+      { Tokens.flush_sublexer(); Output.char '"' }
+  | _ { let c = lexeme_char lexbuf 0 in
+        Output.sublexer c (lexeme_start lexbuf);
+        notation_string lexbuf }
+
+and string = parse
+  | "\"\"" { Output.char '"'; Output.char '"'; string lexbuf }
+  | '"'    { Output.char '"' }
+  | _      { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf }
+
+and skip_hide = parse
+  | eof | end_hide { () }
+  | _ { skip_hide lexbuf }
+
+(*s Reading token pretty-print *)
+
+and printing_token_body = parse
+  | "*)" nl? | eof
+	{ let s = Buffer.contents token_buffer in
+	  Buffer.clear token_buffer;
+	  s }
+  | _   { Buffer.add_string token_buffer (lexeme lexbuf);
+	  printing_token_body lexbuf }
+
+(*s A small scanner to support the chapter subtitle feature *)
+and st_start m = parse
+  | "(*" "*"+ space+ "*" space+
+      { st_modname m lexbuf }
+  | _
+      { None }
+
+and st_modname m = parse
+  | identifier space* ":" space*
+      { if subtitle m (lexeme lexbuf) then
+          st_subtitle lexbuf
+        else
+          None
+      }
+  | _
+      { None }
+
+and st_subtitle = parse
+  | [^ '\n']* '\n'
+      { let st = lexeme lexbuf in
+        let i = try Str.search_forward (Str.regexp "\\**)") st 0 with
+                   Not_found ->
+                     (eprintf "unterminated comment at beginning of file\n";
+                      exit 1)
+        in
+          Some (cut_head_tail_spaces (String.sub st 0 i))
+      }
+  | _
+      { None }
+(*s Applying the scanners to files *)
+
+{
+  let coq_file f m =
+    reset ();
+    let c = open_in f in
+    let lb = from_channel c in
+      (Index.current_library := m;
+       Output.initialize ();
+       Output.start_module ();
+       Output.start_coq (); coq_bol lb; Output.end_coq ();
+       close_in c)
+
+  let detect_subtitle f m =
+    let c = open_in f in
+    let lb = from_channel c in
+    let sub = st_start m lb in
+      close_in c;
+      sub
+}
diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml
new file mode 100644
index 00000000..889e5d6f
--- /dev/null
+++ b/tools/coqdoc/index.ml
@@ -0,0 +1,335 @@
+(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Filename
+open Lexing
+open Printf
+open Cdglobals
+
+type loc = int
+
+type entry_type =
+  | Library
+  | Module
+  | Definition
+  | Inductive
+  | Constructor
+  | Lemma
+  | Record
+  | Projection
+  | Instance
+  | Class
+  | Method
+  | Variable
+  | Axiom
+  | TacticDefinition
+  | Abbreviation
+  | Notation
+  | Section
+
+type index_entry =
+  | Def of string * entry_type
+  | Ref of coq_module * string * entry_type
+  | Mod of coq_module * string
+
+let current_type : entry_type ref = ref Library
+let current_library = ref ""
+  (** refers to the file being parsed *)
+
+(** [deftable] stores only definitions and is used to interpolate idents
+    inside comments, which are not globalized otherwise. *)
+
+let deftable = Hashtbl.create 97
+
+(** [reftable] stores references and definitions *)
+let reftable = Hashtbl.create 97
+
+let full_ident sp id =
+  if sp <> "<>" then
+    if id <> "<>" then
+      sp ^ "." ^ id
+    else sp
+  else if id <> "<>"
+  then id
+  else ""
+
+let add_def loc ty sp id =
+  Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty));
+  Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty))
+
+let add_ref m loc m' sp id ty =
+  if Hashtbl.mem reftable (m, loc) then ()
+  else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty));
+  let idx = if id = "<>" then m' else id in
+    if Hashtbl.mem deftable idx then ()
+    else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty))
+
+let add_mod m loc m' id =
+  Hashtbl.add reftable (m, loc) (Mod (m', id));
+  Hashtbl.add deftable m (Mod (m', id))
+
+let find m l = Hashtbl.find reftable (m, l)
+
+let find_string m s = Hashtbl.find deftable s
+
+(*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 init_stack () =
+  module_stack := empty_stack; section_stack := 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
+
+let begin_module m = push module_stack m
+let begin_section s = push section_stack s
+
+let end_block id =
+  (** determines if it ends a module or a section and pops the stack *)
+  if ((String.compare (head !module_stack) id ) == 0) then
+    pop module_stack
+  else if ((String.compare (head !section_stack) id) == 0) then
+    pop section_stack
+  else
+    ()
+
+let make_fullid id =
+  (** prepends the current module path to an id *)
+  let path = string_of_stack !module_stack in
+    if String.length path > 0 then
+      path ^ "." ^ id
+    else
+      id
+
+
+(* Coq modules *)
+
+let split_sp s =
+  try
+    let i = String.rindex s '.' in
+      String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)
+  with
+      Not_found -> "", s
+
+let modules = Hashtbl.create 97
+let local_modules = Hashtbl.create 97
+
+let add_module m =
+  let _,id = split_sp m in
+  Hashtbl.add modules id m;
+  Hashtbl.add local_modules m ()
+
+type module_kind = Local | External of string | Unknown
+
+let external_libraries = ref []
+
+let add_external_library logicalpath url =
+  external_libraries := (logicalpath,url) :: !external_libraries
+
+let find_external_library logicalpath =
+  let rec aux = function
+    | [] -> raise Not_found
+    | (l,u)::rest ->
+        if String.length logicalpath > String.length l &
+          String.sub logicalpath 0 (String.length l + 1) = l ^"."
+        then u
+        else aux rest
+  in aux !external_libraries
+
+let init_coqlib_library () = add_external_library "Coq" !coqlib
+
+let find_module m =
+  if Hashtbl.mem local_modules m then
+    Local
+  else
+    try External (Filename.concat (find_external_library m) m)
+    with Not_found -> Unknown
+
+
+(* Building indexes *)
+
+type 'a index = {
+  idx_name : string;
+  idx_entries : (char * (string * 'a) list) list;
+  idx_size : int }
+
+let map f i =
+  { i with idx_entries =
+      List.map
+	(fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l))
+	i.idx_entries }
+
+let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2
+
+let sort_entries el =
+  let t = Hashtbl.create 97 in
+  List.iter
+    (fun c -> Hashtbl.add t c [])
+    ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N';
+     'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_'; '*'];
+  List.iter
+    (fun ((s,_) as e) ->
+      let c = Alpha.norm_char s.[0] in
+      let c,l =
+	try c,Hashtbl.find t c with Not_found -> '*',Hashtbl.find t '*' in
+      Hashtbl.replace t c (e :: l))
+    el;
+  let res = ref [] in
+  Hashtbl.iter (fun c l -> res := (c, List.sort compare_entries l) :: !res) t;
+  List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res
+
+let display_letter c = if c = '*' then "other" else String.make 1 c
+
+let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0
+
+let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h []
+
+let type_name = function
+  | Library ->
+      let ln = !lib_name in
+        if ln <> "" then String.lowercase ln else "library"
+  | Module -> "moduleid"
+  | Definition -> "definition"
+  | Inductive -> "inductive"
+  | Constructor -> "constructor"
+  | Lemma -> "lemma"
+  | Record -> "record"
+  | Projection -> "projection"
+  | Instance -> "instance"
+  | Class -> "class"
+  | Method -> "method"
+  | Variable -> "variable"
+  | Axiom -> "axiom"
+  | TacticDefinition -> "tactic"
+  | Abbreviation -> "abbreviation"
+  | Notation -> "notation"
+  | Section -> "section"
+
+let prepare_entry s = function
+  | Notation ->
+      (* Notations have conventially the form section.:sc:x_++_'x'_x *)
+      let err () = eprintf "Invalid notation in globalization file\n"; exit 1 in
+      let h = try String.index_from s 0 ':' with _ -> err () in
+      let i = try String.index_from s (h+1) ':' with _ -> err () in
+      let sc = String.sub s (h+1) (i-h-1) in
+      let ntn = String.make (String.length s) ' ' in
+      let k = ref 0 in
+      let j = ref (i+1) in
+      let quoted = ref false in
+      while !j <> String.length s do
+	if s.[!j] = '_' && not !quoted then ntn.[!k] <- ' ' else
+	if s.[!j] = 'x' && not !quoted then ntn.[!k] <- '_' else
+	if s.[!j] = '\'' then
+	  if s.[!j+1] = 'x' && s.[!j+1] = '\'' then (ntn.[!k] <- 'x'; j:=!j+2)
+	  else (quoted := not !quoted; ntn.[!k] <- '\'')
+	else ntn.[!k] <- s.[!j];
+	incr j; incr k
+      done;
+      let ntn = String.sub ntn 0 !k in
+      if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")"
+  | _ ->
+      s
+
+let all_entries () =
+  let gl = ref [] in
+  let add_g s m t = gl := (s,(m,t)) :: !gl in
+  let bt = Hashtbl.create 11 in
+  let add_bt t s m =
+    let l = try Hashtbl.find bt t with Not_found -> [] in
+      Hashtbl.replace bt t ((s,m) :: l)
+  in
+  let classify (m,_) e = match e with
+    | Def (s,t) -> add_g s m t; add_bt t s m
+    | Ref _ | Mod _ -> ()
+  in
+    Hashtbl.iter classify reftable;
+    Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules;
+    { idx_name = "global";
+      idx_entries = sort_entries !gl;
+      idx_size = List.length !gl },
+    Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t;
+			             idx_entries = sort_entries e;
+			             idx_size = List.length e }) :: l) bt []
+
+let type_of_string = function
+  | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix"
+  | "ex" | "scheme" -> Definition
+  | "prf" | "thm" -> Lemma
+  | "ind" | "coind" -> Inductive
+  | "constr" -> Constructor
+  | "rec" | "corec" -> Record
+  | "proj" -> Projection
+  | "class" -> Class
+  | "meth" -> Method
+  | "inst" -> Instance
+  | "var" -> Variable
+  | "defax" | "prfax" | "ax" -> Axiom
+  | "syndef" -> Abbreviation
+  | "not" -> Notation
+  | "lib" -> Library
+  | "mod" | "modtype" -> Module
+  | "tac" -> TacticDefinition
+  | "sec" -> Section
+  | s -> raise (Invalid_argument ("type_of_string:" ^ s))
+
+let read_glob f =
+  let c = open_in f in
+  let cur_mod = ref "" in
+  try
+    while true do
+      let s = input_line c in
+      let n = String.length s in
+      if n > 0 then begin
+	match s.[0] with
+	  | 'F' ->
+	      cur_mod := String.sub s 1 (n - 1);
+	      current_library := !cur_mod
+	  | 'R' ->
+	      (try
+		Scanf.sscanf s "R%d:%d %s %s %s %s"
+		  (fun loc1 loc2 lib_dp sp id ty ->
+		    for loc=loc1 to loc2 do
+		      add_ref !cur_mod loc lib_dp sp id (type_of_string ty)
+		    done)
+	       with _ ->
+	       try
+		Scanf.sscanf s "R%d %s %s %s %s"
+		  (fun loc lib_dp sp id ty ->
+		    add_ref !cur_mod loc lib_dp sp id (type_of_string ty))
+	       with _ -> ())
+	  | _ ->
+	      try Scanf.sscanf s "%s %d %s %s"
+		(fun ty loc sp id -> add_def loc (type_of_string ty) sp id)
+	      with Scanf.Scan_failure _ -> ()
+      end
+    done; assert false
+  with End_of_file ->
+    close_in c
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
index 56a3cd11..517ec97a 100644
--- a/tools/coqdoc/index.mli
+++ b/tools/coqdoc/index.mli
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: index.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Cdglobals
 
 type loc = int
 
-type entry_type = 
+type entry_type =
   | Library
   | Module
   | Definition
@@ -33,7 +33,7 @@ type entry_type =
 
 val type_name : entry_type -> string
 
-type index_entry = 
+type index_entry =
   | Def of string * entry_type
   | Ref of coq_module * string * entry_type
   | Mod of coq_module * string
@@ -44,28 +44,32 @@ val find_string : coq_module -> string -> index_entry
 
 val add_module : coq_module -> unit
 
-type module_kind = Local | Coqlib | Unknown
+type module_kind = Local | External of coq_module | Unknown
 
 val find_module : coq_module -> module_kind
 
-(*s Scan identifiers introductions from a file *)
+val init_coqlib_library : unit -> unit
 
-val scan_file : string -> coq_module -> unit
+val add_external_library : string -> coq_module -> unit
 
 (*s Read globalizations from a file (produced by coqc -dump-glob) *)
 
-val read_glob : string -> coq_module
+val read_glob : string -> unit
 
 (*s Indexes *)
 
-type 'a index = { 
+type 'a index = {
   idx_name : string;
   idx_entries : (char * (string * 'a) list) list;
   idx_size : int }
 
 val current_library : string ref
 
-val all_entries : unit -> 
+val display_letter : char -> string
+
+val prepare_entry : string -> entry_type -> string
+
+val all_entries : unit ->
       (coq_module * entry_type) index *
       (entry_type * coq_module index) list
 
diff --git a/tools/coqdoc/index.mll b/tools/coqdoc/index.mll
deleted file mode 100644
index f8adb52b..00000000
--- a/tools/coqdoc/index.mll
+++ /dev/null
@@ -1,490 +0,0 @@
-(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: index.mll 11790 2009-01-15 20:19:58Z msozeau $ i*)
-
-{
-
-open Filename
-open Lexing 
-open Printf
-
-open Cdglobals
-
-type loc = int
-
-type entry_type = 
-  | Library
-  | Module
-  | Definition
-  | Inductive
-  | Constructor
-  | Lemma
-  | Record
-  | Projection
-  | Instance
-  | Class
-  | Method
-  | Variable
-  | Axiom
-  | TacticDefinition
-  | Abbreviation
-  | Notation
-  | Section
-
-type index_entry = 
-  | Def of string * entry_type
-  | Ref of coq_module * string * entry_type
-  | Mod of coq_module * string
-
-let current_type = ref Library
-let current_library = ref ""
-  (** refers to the file being parsed *)
-
-(** [deftable] stores only definitions and is used to interpolate idents 
-    inside comments, which are not globalized otherwise. *)
-
-let deftable = Hashtbl.create 97
-
-(** [reftable] stores references and definitions *)
-let reftable = Hashtbl.create 97
-  
-let full_ident sp id =
-  if sp <> "<>" then 
-    if id <> "<>" then 
-      sp ^ "." ^ id 
-    else sp 
-  else if id <> "<>" 
-  then id 
-  else ""
-    
-let add_def loc ty sp id = 
-  Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty));
-  Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty))
-    
-let add_ref m loc m' sp id ty = 
-  if Hashtbl.mem reftable (m, loc) then ()
-  else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty));
-  let idx = if id = "<>" then m' else id in
-    if Hashtbl.mem deftable idx then ()
-    else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty))  
-    
-let add_mod m loc m' id = 
-  Hashtbl.add reftable (m, loc) (Mod (m', id));
-  Hashtbl.add deftable m (Mod (m', id))
-    
-let find m l = Hashtbl.find reftable (m, l)
-  
-let find_string m s = Hashtbl.find deftable s
-  
-(*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 init_stack () =
-  module_stack := empty_stack; section_stack := 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
-
-let begin_module m = push module_stack m
-let begin_section s = push section_stack s
-
-let end_block id =
-  (** determines if it ends a module or a section and pops the stack *)
-  if ((String.compare (head !module_stack) id ) == 0) then
-    pop module_stack
-  else if ((String.compare (head !section_stack) id) == 0) then
-    pop section_stack
-  else
-    ()
-
-let make_fullid id = 
-  (** prepends the current module path to an id *)
-  let path = string_of_stack !module_stack in
-    if String.length path > 0 then
-      path ^ "." ^ id
-    else 
-      id
-
-
-(* Coq modules *)
-
-let split_sp s = 
-  try
-    let i = String.rindex s '.' in
-      String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)
-  with 
-      Not_found -> "", s
-
-let modules = Hashtbl.create 97
-let local_modules = Hashtbl.create 97
-
-let add_module m =
-  let _,id = split_sp m in
-  Hashtbl.add modules id m;
-  Hashtbl.add local_modules m ()
-
-type module_kind = Local | Coqlib | Unknown
-
-let coq_module m = String.length m >= 4 && String.sub m 0 4 = "Coq."
-
-let find_module m =
-  if Hashtbl.mem local_modules m then 
-    Local
-  else if coq_module m then
-    Coqlib
-  else
-    Unknown
-
-
-(* Building indexes *)
-
-type 'a index = { 
-  idx_name : string;
-  idx_entries : (char * (string * 'a) list) list;
-  idx_size : int }
-		  
-let map f i = 
-  { i with idx_entries = 
-      List.map 
-	(fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) 
-	i.idx_entries }
-
-let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2
-
-let sort_entries el =
-  let t = Hashtbl.create 97 in
-    List.iter 
-      (fun c -> Hashtbl.add t c [])
-      ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; 
-       'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_'];  
-    List.iter 
-      (fun ((s,_) as e) -> 
-	 let c = Alpha.norm_char s.[0] in 
-	 let l = try Hashtbl.find t c with Not_found -> [] in
-	   Hashtbl.replace t c (e :: l)) 
-      el;
-    let res = ref [] in
-      Hashtbl.iter 
-	(fun c l -> res := (c, List.sort compare_entries l) :: !res) t;
-      List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res
-	
-let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0
-  
-let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h []
-  
-let type_name = function
-  | Library -> "library"
-  | Module -> "module"
-  | Definition -> "definition"
-  | Inductive -> "inductive"
-  | Constructor -> "constructor"
-  | Lemma -> "lemma"
-  | Record -> "record"
-  | Projection -> "projection"
-  | Instance -> "instance"
-  | Class -> "class"
-  | Method -> "method"
-  | Variable -> "variable"
-  | Axiom -> "axiom"
-  | TacticDefinition -> "tactic"
-  | Abbreviation -> "abbreviation"
-  | Notation -> "notation"
-  | Section -> "section"
-
-let all_entries () =
-  let gl = ref [] in
-  let add_g s m t = gl := (s,(m,t)) :: !gl in
-  let bt = Hashtbl.create 11 in
-  let add_bt t s m =
-    let l = try Hashtbl.find bt t with Not_found -> [] in
-      Hashtbl.replace bt t ((s,m) :: l)
-  in
-  let classify (m,_) e = match e with 
-    | Def (s,t) -> add_g s m t; add_bt t s m
-    | Ref _ | Mod _ -> ()
-  in
-    Hashtbl.iter classify reftable;
-    Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules;
-    { idx_name = "global"; 
-      idx_entries = sort_entries !gl; 
-      idx_size = List.length !gl },
-    Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; 
-				   idx_entries = sort_entries e; 
-				   idx_size = List.length e }) :: l) bt []
-    
-}
-
-(*s Shortcuts for regular expressions. *)
-let digit = ['0'-'9']
-let num = digit+
-
-let space = 
-  [' ' '\010' '\013' '\009' '\012']
-let firstchar = 
-  ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
-let identchar = 
-  ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' 
-     '\'' '0'-'9']
-let id = firstchar identchar*
-let pfx_id = (id '.')*
-let ident = id | pfx_id id
-
-let begin_hide = "(*" space* "begin" space+ "hide" space* "*)"
-let end_hide = "(*" space* "end" space+ "hide" space* "*)"
-  
-(*s Indexing entry point. *)
-  
-rule traverse = parse
-  | ("Program" space+)? "Definition" space
-      { current_type := Definition; index_ident lexbuf; traverse lexbuf }
-  | "Tactic" space+ "Definition" space
-      { current_type := TacticDefinition; index_ident lexbuf; traverse lexbuf }
-  | ("Axiom" | "Parameter") space 
-      { current_type := Axiom; index_ident lexbuf; traverse lexbuf }
-  | ("Program" space+)? "Fixpoint" space
-      { current_type := Definition; index_ident lexbuf; fixpoint lexbuf;
-	traverse lexbuf }
-  | ("Program" space+)? ("Lemma" | "Theorem") space
-      { current_type := Lemma; index_ident lexbuf; traverse lexbuf }
-  | "Obligation" space num ("of" ident)?
-      { current_type := Lemma; index_ident lexbuf; traverse lexbuf }
-  | "Inductive" space
-      { current_type := Inductive; 
-	index_ident lexbuf; inductive lexbuf; traverse lexbuf }
-  | "Record" space
-      { current_type := Inductive; index_ident lexbuf; traverse lexbuf }
-  | "Module" (space+ "Type")? space
-      { current_type := Module; module_ident lexbuf; traverse lexbuf }
-(*i***
-  | "Variable" 's'? space
-      { current_type := Variable; index_idents lexbuf; traverse lexbuf }
-***i*)
-  | "Require" (space+ ("Export"|"Import"))? 
-      { module_refs lexbuf; traverse lexbuf }
-  | "End" space+ 
-      { end_ident lexbuf; traverse lexbuf }
-  | begin_hide 
-      { skip_hide lexbuf; traverse lexbuf }
-  | "(*" 
-      { comment lexbuf; traverse lexbuf }
-  | '"'
-      { string lexbuf; traverse lexbuf }
-  | eof          
-      { () }
-  | _            
-      { traverse lexbuf }
-
-(*s Index one identifier. *)
-
-and index_ident = parse
-  | space+ 
-      { index_ident lexbuf }
-  | ident  
-      { let fullid = 
-	  let id = lexeme lexbuf in
-	    match !current_type with
-	      | Definition
-	      | Inductive
-	      | Constructor 
-	      | Lemma -> make_fullid id
-	      | _ -> id 
-	in 
-	  add_def (lexeme_start lexbuf) !current_type "" fullid }
-  | eof    
-      { () }
-  | _      
-      { () }
-
-(*s Index identifiers separated by blanks and/or commas. *)
-
-and index_idents = parse
-  | space+ | ','
-      { index_idents lexbuf }
-  | ident  
-      { add_def (lexeme_start lexbuf) !current_type "" (lexeme lexbuf);
-	index_idents lexbuf }
-  | eof    
-      { () }
-  | _
-      { skip_until_point lexbuf }
-      
-(*s Index identifiers in an inductive definition (types and constructors). *)
-      
-and inductive = parse
-  | '|' | ":=" space* '|'? 
-	{ current_type := Constructor; index_ident lexbuf; inductive lexbuf }
-  | "with" space
-      { current_type := Inductive; index_ident lexbuf; inductive lexbuf }
-  | '.'    
-      { () }
-  | eof    
-      { () }
-  | _      
-      { inductive lexbuf }
-      
-(*s Index identifiers in a Fixpoint declaration. *)
-      
-and fixpoint = parse
-  | "with" space
-      { index_ident lexbuf; fixpoint lexbuf }
-  | '.' 
-      { () }
-  | eof    
-      { () }
-  | _      
-      { fixpoint lexbuf }
-      
-(*s Skip a possibly nested comment. *)
-      
-and comment = parse
-  | "*)" { () }
-  | "(*" { comment lexbuf; comment lexbuf }
-  | '"'  { string lexbuf; comment lexbuf }
-  | eof  { eprintf " *** Unterminated comment while indexing" }
-  | _    { comment lexbuf }
-
-(*s Skip a constant string. *)
-      
-and string = parse
-  | '"'  { () }
-  | eof  { eprintf " *** Unterminated string while indexing" }
-  | _    { string lexbuf }
-
-(*s Skip everything until the next dot. *)
-      
-and skip_until_point = parse
-  | '.'  { () }
-  | eof  { () }
-  | _    { skip_until_point lexbuf }
-      
-(*s Skip everything until [(* end hide *)] *)
-
-and skip_hide = parse
-  | eof | end_hide { () }
-  | _ { skip_hide lexbuf }
-
-and end_ident = parse
-  | space+ 
-      { end_ident lexbuf }
-  | ident  
-      { let id = lexeme lexbuf in end_block id }
-  | eof    
-      { () }
-  | _      
-      { () }
-
-and module_ident = parse
-  | space+
-      { module_ident lexbuf }
-  | '"' { string lexbuf; module_ident lexbuf }
-  | ident space* ":="
-      { () }
-  | ident
-      { let id = lexeme lexbuf in
-	  begin_module id; add_def (lexeme_start lexbuf) !current_type "" id }
-  | eof
-      { () }
-  | _
-      { () }
-
-(*s parse module names *)
-
-and module_refs = parse
-  | space+ 
-      { module_refs lexbuf }
-  | ident  
-      { let id =  lexeme lexbuf in
-	  (try
-	     add_mod !current_library (lexeme_start lexbuf) (Hashtbl.find modules id) id
-	   with
-	       Not_found -> ()
-	  ); 
-	module_refs lexbuf }
-  | eof    
-      { () }
-  | _      
-      { () }
-
-{
-  let type_of_string = function
-    | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix"
-    | "ex" | "scheme" -> Definition
-    | "prf" | "thm" -> Lemma
-    | "ind" | "coind" -> Inductive
-    | "constr" -> Constructor
-    | "rec" | "corec" -> Record
-    | "proj" -> Projection
-    | "class" -> Class
-    | "meth" -> Method
-    | "inst" -> Instance
-    | "var" -> Variable
-    | "defax" | "prfax" | "ax" -> Axiom
-    | "syndef" -> Abbreviation
-    | "not" -> Notation
-    | "lib" -> Library
-    | "mod" | "modtype" -> Module
-    | "tac" -> TacticDefinition
-    | "sec" -> Section
-    | s -> raise (Invalid_argument ("type_of_string:" ^ s))
-	
-  let read_glob f = 
-    let c = open_in f in
-    let cur_mod = ref "" in
-    try
-      while true do
-	let s = input_line c in
-	let n = String.length s in
-	if n > 0 then begin
-	  match s.[0] with
-	    | 'F' -> 
-		cur_mod := String.sub s 1 (n - 1);
-		current_library := !cur_mod
-	    | 'R' ->
-		(try
-		    Scanf.sscanf s "R%d %s %s %s %s"
-		      (fun loc lib_dp sp id ty ->
-			add_ref !cur_mod loc lib_dp sp id (type_of_string ty))
-		  with _ -> ())
-	    | _ -> 
-		try Scanf.sscanf s "%s %d %s %s"
-		  (fun ty loc sp id -> add_def loc (type_of_string ty) sp id)
-		with Scanf.Scan_failure _ -> ()
-	end
-      done; assert false
-    with End_of_file -> 
-      close_in c; !cur_mod
-	
-  let scan_file f m = 
-    init_stack (); current_library := m;
-    let c = open_in f in
-    let lb = from_channel c in
-      traverse lb;
-      close_in c
-}
diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml
index 2ee9ac96..67c63865 100644
--- a/tools/coqdoc/main.ml
+++ b/tools/coqdoc/main.ml
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: main.ml 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (* Modified by Lionel Elie Mamane <lionel@mamane.lu> on 9 & 10 Mar 2004:
  *  - handling of absolute filenames (function coq_module)
@@ -46,6 +46,7 @@ let usage () =
   prerr_endline "  --with-footer <file> append <file> as html footer";
   prerr_endline "  --no-index           do not output the index";
   prerr_endline "  --multi-index        index split in multiple files";
+  prerr_endline "  --index <string>     set index name (default is index)";
   prerr_endline "  --toc                output a table of contents";
   prerr_endline "  --vernac <file>      consider <file> as a .v file";
   prerr_endline "  --tex <file>         consider <file> as a .tex file";
@@ -53,8 +54,9 @@ let usage () =
   prerr_endline "  --files-from <file>  read file names to process in <file>";
   prerr_endline "  --glob-from <file>   read globalization information from <file>";
   prerr_endline "  --quiet              quiet mode (default)";
-  prerr_endline "  --verbose            verbose mode";  
+  prerr_endline "  --verbose            verbose mode";
   prerr_endline "  --no-externals       no links to Coq standard library";
+  prerr_endline "  --external <url> <d> set URL for external library d";
   prerr_endline "  --coqlib <url>       set URL for Coq standard library";
   prerr_endline ("                       (default is " ^ Coq_config.wwwstdlib ^ ")");
   prerr_endline "  --boot               run in boot mode";
@@ -66,6 +68,11 @@ let usage () =
   prerr_endline "  --inputenc <string>  set LaTeX input encoding";
   prerr_endline "  --interpolate        try to typeset identifiers in comments using definitions in the same module";
   prerr_endline "  --parse-comments     parse regular comments";
+  prerr_endline "  --plain-comments     consider comments as non-literate text";
+  prerr_endline "  --toc-depth <int>    don't include TOC entries for sections below level <int>";
+  prerr_endline "  --no-lib-name        don't display \"Library\" before library names in the toc";
+  prerr_endline "  --lib-name <string>  call top level toc entries <string> instead of \"Library\"";
+  prerr_endline "  --lib-subtitles      first line comments of the form (** * ModuleName : text *) will be interpreted as subtitles";
   prerr_endline "";
   exit 1
 
@@ -74,20 +81,20 @@ let obsolete s =
 
 (*s \textbf{Banner.} Always printed. Notice that it is printed on error
     output, so that when the output of [coqdoc] is redirected this header
-    is not (unless both standard and error outputs are redirected, of 
+    is not (unless both standard and error outputs are redirected, of
     course). *)
 
 let banner () =
   eprintf "This is coqdoc version %s, compiled on %s\n"
     Coq_config.version Coq_config.compile_date;
   flush stderr
-    
-let target_full_name f = 
+
+let target_full_name f =
   match !Cdglobals.target_language with
     | HTML -> f ^ ".html"
     | Raw -> f ^ ".txt"
     | _ -> f ^ ".tex"
-	
+
 (*s \textbf{Separation of files.} Files given on the command line are
     separated according to their type, which is determined by their
     suffix.  Coq files have suffixe \verb!.v! or \verb!.g! and \LaTeX\
@@ -95,12 +102,12 @@ let target_full_name f =
 
 let check_if_file_exists f =
   if not (Sys.file_exists f) then begin
-    eprintf "\ncoqdoc: %s: no such file\n" f;
+    eprintf "coqdoc: %s: no such file\n" f;
     exit 1
   end
 
 
-(*s Manipulations of paths and path aliases *) 
+(*s Manipulations of paths and path aliases *)
 
 let normalize_path p =
   (* We use the Unix subsystem to normalize a physical path (relative
@@ -109,50 +116,43 @@ let normalize_path p =
      works... *)
   (* Rq: Sys.getcwd () returns paths without '/' at the end *)
   let orig = Sys.getcwd () in
-    Sys.chdir p;
-    let res = Sys.getcwd () in
-      Sys.chdir orig; 
-      res
+  Sys.chdir p;
+  let res = Sys.getcwd () in
+  Sys.chdir orig;
+  res
 
 let normalize_filename f =
   let basename = Filename.basename f in
   let dirname = Filename.dirname f in
-    Filename.concat (normalize_path dirname) basename
+  normalize_path dirname, basename
 
 (* [paths] maps a physical path to a name *)
 let paths = ref []
-  
-let add_path dir name = 
-  (* if dir is relative we add both the relative and absolute name *)
+
+let add_path dir name =
   let p = normalize_path dir in
-    paths := (p,name) :: !paths
-  
-(* turn A/B/C into A.B.C *)
-let name_of_path = Str.global_replace (Str.regexp "/") ".";;
+  paths := (p,name) :: !paths
 
-let coq_module filename = 
+(* turn A/B/C into A.B.C *)
+let rec name_of_path p name dirname suffix =
+  if p = dirname then String.concat "." (name::suffix)
+  else
+    let subdir = Filename.dirname dirname in
+    if subdir = dirname then raise Not_found
+    else name_of_path p name subdir (Filename.basename dirname::suffix)
+
+let coq_module filename =
   let bfname = Filename.chop_extension filename in
-  let nfname = normalize_filename bfname in
-  let rec change_prefix map f = 
-    match map with
-      | [] -> 
-	  (* There is no prefix alias; 
-	     we just cut the name wrt current working directory *)
-	  let cwd = Sys.getcwd () in
-	  let exp = Str.regexp (Str.quote (cwd ^ "/")) in
-	    if (Str.string_match exp f 0) then
-	      name_of_path (Str.replace_first exp "" f)
-	    else
-	      name_of_path f
-      | (p, name) :: rem ->
-          let expp = Str.regexp (Str.quote p) in
-	    if (Str.string_match expp f 0) then
-	      let newp = Str.replace_first expp name f in
-		name_of_path newp
-            else
-	      change_prefix rem f
+  let dirname, fname = normalize_filename bfname in
+  let rec change_prefix = function
+    (* Follow coqc: if in scope of -R, substitute logical name *)
+    (* otherwise, keep only base name *)
+    | [] -> fname
+    | (p, name) :: rem ->
+	try name_of_path p name dirname [fname]
+	with Not_found -> change_prefix rem
   in
-    change_prefix !paths nfname
+  change_prefix !paths
 
 let what_file f =
   check_if_file_exists f;
@@ -160,10 +160,10 @@ let what_file f =
     Vernac_file (f, coq_module f)
   else if Filename.check_suffix f ".tex" then
     Latex_file f
-  else 
+  else
      (eprintf "\ncoqdoc: don't know what to do with %s\n" f; exit 1)
-    
-(*s \textbf{Reading file names from a file.} 
+
+(*s \textbf{Reading file names from a file.}
  *  File names may be given
  *  in a file instead of being given on the command
  *  line. [(files_from_file f)] returns the list of file names contained
@@ -181,7 +181,7 @@ let files_from_file f =
 	    | ' ' | '\t' | '\n' ->
 		if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l;
 		Buffer.clear buf
-	    | c -> 
+	    | c ->
 		Buffer.add_char buf c
 	done; []
       with End_of_file ->
@@ -193,12 +193,12 @@ let files_from_file f =
       let l = files_from_channel ch in
 	close_in ch;l
     with Sys_error s -> begin
-      eprintf "\ncoqdoc: cannot read from file %s (%s)\n" f s;
+      eprintf "coqdoc: cannot read from file %s (%s)\n" f s;
       exit 1
     end
-      
+
 (*s \textbf{Parsing of the command line.} *)
-      
+
 let dvi = ref false
 let ps = ref false
 let pdf = ref false
@@ -208,7 +208,7 @@ let parse () =
   let add_file f = files := f :: !files in
   let rec parse_rec = function
     | [] -> ()
-	
+
     | ("-nopreamble" | "--nopreamble" | "--no-preamble"
       |  "-bodyonly"   | "--bodyonly"   | "--body-only") :: rem ->
 	header_trailer := false; parse_rec rem
@@ -228,17 +228,21 @@ let parse () =
 	index := false; parse_rec rem
     | ("-multi-index" | "--multi-index") :: rem ->
 	multi_index := true; parse_rec rem
+    | ("-index" | "--index") :: s :: rem ->
+	Cdglobals.index_name := s; parse_rec rem
+    | ("-index" | "--index") :: [] ->
+	usage ()
     | ("-toc" | "--toc" | "--table-of-contents") :: rem ->
 	toc := true; parse_rec rem
     | ("-stdout" | "--stdout") :: rem ->
 	out_to := StdOut; parse_rec rem
     | ("-o" | "--output") :: f :: rem ->
 	out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem
-    | ("-o" | "--output") :: [] -> 
+    | ("-o" | "--output") :: [] ->
 	usage ()
     | ("-d" | "--directory") :: dir :: rem ->
 	output_dir := dir; parse_rec rem
-    | ("-d" | "--directory") :: [] -> 
+    | ("-d" | "--directory") :: [] ->
 	usage ()
     | ("-s" | "--short") :: rem ->
 	short := true; parse_rec rem
@@ -276,39 +280,60 @@ let parse () =
 	Cdglobals.raw_comments := true; parse_rec rem
     | ("-parse-comments" | "--parse-comments") :: rem ->
 	Cdglobals.parse_comments := true; parse_rec rem
+    | ("-plain-comments" | "--plain-comments") :: rem ->
+	Cdglobals.plain_comments := true; parse_rec rem
     | ("-interpolate" | "--interpolate") :: rem ->
 	Cdglobals.interpolate := true; parse_rec rem
+    | ("-toc-depth" | "--toc-depth") :: [] ->
+      usage ()
+    | ("-toc-depth" | "--toc-depth") :: ds :: rem ->
+      let d = try int_of_string ds with
+                Failure _ ->
+                  (eprintf "--toc-depth must be followed by an integer\n";
+                   exit 1)
+      in
+      Cdglobals.toc_depth := Some d;
+      parse_rec rem
+    | ("-no-lib-name" | "--no-lib-name") :: rem ->
+      Cdglobals.lib_name := "";
+      parse_rec rem
+    | ("-lib-name" | "--lib-name") :: ds :: rem ->
+      Cdglobals.lib_name := ds;
+      parse_rec rem
+    | ("-lib-subtitles" | "--lib-subtitles") :: rem ->
+      Cdglobals.lib_subtitles := true;
+      parse_rec rem
 
     | ("-latin1" | "--latin1") :: rem ->
 	Cdglobals.set_latin1 (); parse_rec rem
     | ("-utf8" | "--utf8") :: rem ->
 	Cdglobals.set_utf8 (); parse_rec rem
-	  
+
     | ("-q" | "-quiet" | "--quiet") :: rem ->
 	quiet := true; parse_rec rem
     | ("-v" | "-verbose" | "--verbose") :: rem ->
 	quiet := false; parse_rec rem
-	  
+
     | ("-h" | "-help" | "-?" | "--help") :: rem ->
 	banner (); usage ()
     | ("-V" | "-version" | "--version") :: _ ->
 	banner (); exit 0
 
-    | ("-vernac-file" | "--vernac-file") :: f :: rem -> 
+    | ("-vernac-file" | "--vernac-file") :: f :: rem ->
 	check_if_file_exists f;
 	add_file (Vernac_file (f, coq_module f)); parse_rec rem
     | ("-vernac-file" | "--vernac-file") :: [] ->
 	usage ()
-    | ("-tex-file" | "--tex-file") :: f :: rem -> 
+    | ("-tex-file" | "--tex-file") :: f :: rem ->
 	add_file (Latex_file f); parse_rec rem
     | ("-tex-file" | "--tex-file") :: [] ->
 	usage ()
     | ("-files" | "--files" | "--files-from") :: f :: rem ->
-	List.iter (fun f -> add_file (what_file f)) (files_from_file f); 
+	List.iter (fun f -> add_file (what_file f)) (files_from_file f);
 	parse_rec rem
     | ("-files" | "--files") :: [] ->
 	usage ()
-    | "-R" :: path :: log :: rem -> 
+    | "-R" :: path :: log :: rem ->
 	add_path path log; parse_rec rem
     | "-R" :: ([] | [_]) ->
 	usage ()
@@ -318,6 +343,8 @@ let parse () =
 	usage ()
     | ("--no-externals" | "-no-externals" | "-noexternals") :: rem ->
 	Cdglobals.externals := false; parse_rec rem
+    | ("--external" | "-external") :: u :: logicalpath :: rem ->
+	Index.add_external_library logicalpath u; parse_rec rem
     | ("--coqlib" | "-coqlib") :: u :: rem ->
 	Cdglobals.coqlib := u; parse_rec rem
     | ("--coqlib" | "-coqlib") :: [] ->
@@ -328,16 +355,15 @@ let parse () =
 	Cdglobals.coqlib_path := d; parse_rec rem
     | ("--coqlib_path" | "-coqlib_path") :: [] ->
 	usage ()
-    | f :: rem -> 
+    | f :: rem ->
 	add_file (what_file f); parse_rec rem
-  in 
+  in
     parse_rec (List.tl (Array.to_list Sys.argv));
-    Output.initialize ();
     List.rev !files
 
-      
+
 (*s The following function produces the output. The default output is
-    the \LaTeX\ document: in that case, we just call [Web.produce_document]. 
+    the \LaTeX\ document: in that case, we just call [Web.produce_document].
     If option \verb!-dvi!, \verb!-ps! or \verb!-html! is invoked, then
     we make calls to \verb!latex! or \verb!dvips! or \verb!pdflatex! accordingly. *)
 
@@ -359,9 +385,9 @@ let clean_temp_files basefile =
     remove (basefile ^ ".pdf");
     remove (basefile ^ ".haux");
     remove (basefile ^ ".html")
-      
+
 let clean_and_exit file res = clean_temp_files file; exit res
-  
+
 let cat file =
   let c = open_in file in
     try
@@ -370,20 +396,26 @@ let cat file =
       close_in c
 
 let copy src dst =
-  let cin = open_in src 
-  and cout = open_out dst in
+  let cin = open_in src in
+  try
+    let cout = open_out dst in
     try
       while true do Pervasives.output_char cout (input_char cin) done
     with End_of_file ->
-      close_in cin; close_out cout
-
+      close_out cout;
+      close_in cin
+  with Sys_error e ->
+    eprintf "%s\n" e;
+    exit 1
 
 (*s Functions for generating output files *)
 
 let gen_one_file l =
   let file = function
-    | Vernac_file (f,m) -> 
-	Output.set_module m; Pretty.coq_file f m
+    | Vernac_file (f,m) ->
+        let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in
+          Output.set_module m sub;
+          Cpretty.coq_file f m
     | Latex_file _ -> ()
   in
     if (!header_trailer) then Output.header ();
@@ -391,74 +423,73 @@ let gen_one_file l =
     List.iter file l;
     if !index then Output.make_index();
     if (!header_trailer) then Output.trailer ()
-      
+
 let gen_mult_files l =
   let file = function
-    | Vernac_file (f,m) -> 
-	Output.set_module m;
+    | Vernac_file (f,m) ->
+      let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in
 	let hf = target_full_name m in
+        Output.set_module m sub;
 	  open_out_file hf;
-	  if (!header_trailer) then Output.header (); 
-	  Pretty.coq_file f m; 
+	  if (!header_trailer) then Output.header ();
+	  Cpretty.coq_file f m;
 	  if (!header_trailer) then Output.trailer ();
 	  close_out_file()
     | Latex_file _ -> ()
   in
     List.iter file l;
     if (!index && !target_language=HTML) then begin
-      if (!multi_index) then Output.make_multi_index (); 
-      open_out_file "index.html"; 
+      if (!multi_index) then Output.make_multi_index ();
+      open_out_file (!index_name^".html");
       page_title := (if !title <> "" then !title else "Index");
-      if (!header_trailer) then Output.header (); 
-      Output.make_index (); 
+      if (!header_trailer) then Output.header ();
+      Output.make_index ();
       if (!header_trailer) then Output.trailer ();
       close_out_file()
     end;
     if (!toc && !target_language=HTML) then begin
-      open_out_file "toc.html"; 
+      open_out_file "toc.html";
       page_title := (if !title <> "" then !title else "Table of contents");
       if (!header_trailer) then Output.header ();
       if !title <> "" then printf "<h1>%s</h1>\n" !title;
-      Output.make_toc (); 
+      Output.make_toc ();
       if (!header_trailer) then Output.trailer ();
       close_out_file()
-    end 
+    end
       (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *)
 
-let read_glob x =
-  match x with
-    | Vernac_file (f,m) ->   
-	let glob = (Filename.chop_extension f) ^ ".glob" in
- 	  (try
-	      Vernac_file (f, Index.read_glob glob)
-            with e -> 
-              eprintf "Warning: file %s cannot be used; links will not be available: %s\n" glob (Printexc.to_string e);
-	      x)
-  | Latex_file _ -> x
+let read_glob_file x =
+  try Index.read_glob x
+  with Sys_error s ->
+    eprintf "Warning: %s (links will not be available)\n" s
+
+let read_glob_file_of = function
+  | Vernac_file (f,_) -> read_glob_file (Filename.chop_extension f ^ ".glob")
+  | Latex_file _ -> ()
 
 let index_module = function
-  | Vernac_file (f,m) ->   
+  | Vernac_file (f,m) ->
       Index.add_module m
   | Latex_file _ -> ()
-      
+
+let copy_style_file file =
+  let src =
+    List.fold_left
+      Filename.concat !Cdglobals.coqlib_path ["tools";"coqdoc";file] in
+  let dst = coqdoc_out file in
+  if Sys.file_exists src then copy src dst
+  else eprintf "Warning: file %s does not exist\n" src
+
 let produce_document l =
-  (if !target_language=HTML then
-    let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.css") in
-    let dst = if !output_dir <> "" then Filename.concat !output_dir "coqdoc.css" else "coqdoc.css" in
-      if (Sys.file_exists src) then (copy src dst) else eprintf "Warning: file %s does not exist\n" src);
-  (if !target_language=LaTeX then
-      let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.sty") in
-      let dst = if !output_dir <> "" then 
-	  Filename.concat !output_dir "coqdoc.sty" 
-	else "coqdoc.sty" in
-	if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src);
+  if !target_language=HTML then copy_style_file "coqdoc.css";
+  if !target_language=LaTeX then copy_style_file "coqdoc.sty";
   (match !Cdglobals.glob_source with
     | NoGlob -> ()
-    | DotGlob -> ignore (List.map read_glob l)
-    | GlobFile f -> ignore (Index.read_glob f));
+    | DotGlob -> List.iter read_glob_file_of l
+    | GlobFile f -> read_glob_file f);
   List.iter index_module l;
   match !out_to with
-    | StdOut -> 
+    | StdOut ->
 	Cdglobals.out_channel := stdout;
 	gen_one_file l
     | File f ->
@@ -467,11 +498,11 @@ let produce_document l =
 	close_out_file()
     | MultFiles ->
 	gen_mult_files l
-	  
+
 let produce_output fl =
-  if not (!dvi || !ps || !pdf) then 
+  if not (!dvi || !ps || !pdf) then
     produce_document fl
-  else 
+  else
     begin
       let texfile = Filename.temp_file "coqdoc" ".tex" in
       let basefile = Filename.chop_suffix texfile ".tex" in
@@ -479,52 +510,52 @@ let produce_output fl =
 	out_to := File texfile;
 	output_dir := (Filename.dirname texfile);
 	produce_document fl;
-	
+
 	let latexexe = if !pdf then "pdflatex" else "latex" in
-	let latexcmd = 
+	let latexcmd =
 	  let file = Filename.basename texfile in
-	  let file = 
-	    if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file 
+	  let file =
+	    if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file
 	  in
 	    sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "")
 	in
 	let res = locally (Filename.dirname texfile) Sys.command latexcmd in
 	  if res <> 0 then begin
-	      eprintf "Couldn't run LaTeX successfully\n"; 
+	      eprintf "Couldn't run LaTeX successfully\n";
 	      clean_and_exit basefile res
 	    end;
-	  
+
 	  let dvifile = basefile ^ ".dvi" in
-	    if !dvi then 
+	    if !dvi then
 	      begin
 		match final_out_to with
 		  | MultFiles | StdOut -> cat dvifile
 		  | File f -> copy dvifile f
 	      end;
 	  let pdffile = basefile ^ ".pdf" in
-	    if !pdf then 
+	    if !pdf then
             begin
 	        match final_out_to with
 		  | MultFiles | StdOut -> cat pdffile
 		  | File f -> copy pdffile f
 	    end;
 	    if !ps then begin
-	        let psfile = basefile ^ ".ps" 
+	        let psfile = basefile ^ ".ps"
 		in
-		let command = 
-		  sprintf "dvips %s -o %s %s" dvifile psfile 
+		let command =
+		  sprintf "dvips %s -o %s %s" dvifile psfile
 		    (if !quiet then "> /dev/null 2>&1" else "")
 		in
 		let res = Sys.command command in
 		  if res <> 0 then begin
-		      eprintf "Couldn't run dvips successfully\n"; 
+		      eprintf "Couldn't run dvips successfully\n";
 		      clean_and_exit basefile res
 		    end;
 		  match final_out_to with
 		    | MultFiles | StdOut -> cat psfile
 		    | File f -> copy psfile f
 	      end;
-	 
+
 	    clean_temp_files basefile
     end
 
@@ -534,7 +565,8 @@ let produce_output fl =
 
 let main () =
   let files = parse () in
+    Index.init_coqlib_library ();
     if not !quiet then banner ();
     if files <> [] then produce_output files
-      
+
 let _ = Printexc.catch main ()
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index 1ad8b14f..93e1f843 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.ml
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: output.ml 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Cdglobals
 open Index
@@ -25,26 +25,26 @@ let sprintf = Printf.sprintf
 
 (*s Coq keywords *)
 
-let build_table l = 
+let build_table l =
   let h = Hashtbl.create 101 in
   List.iter (fun key ->Hashtbl.add h  key ()) l;
   function s -> try Hashtbl.find h s; true with Not_found -> false
 
-let is_keyword = 
+let is_keyword =
   build_table
     [ "AddPath"; "Axiom"; "Abort"; "Boxed"; "Chapter"; "Check"; "Coercion"; "CoFixpoint";
-      "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; 
+      "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example";
       "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint";
-      "Hypothesis"; "Hypotheses"; 
-      "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive"; 
-      "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; 
+      "Hypothesis"; "Hypotheses";
+      "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive";
+      "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac";
       "Module"; "Module Type"; "Declare Module"; "Include";
       "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed";
       "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme";
-      "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; 
+      "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem";
       "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context";
       "Notation"; "Reserved Notation"; "Tactic Notation";
-      "Delimit"; "Bind"; "Open"; "Scope"; 
+      "Delimit"; "Bind"; "Open"; "Scope";
       "Boxed"; "Unboxed"; "Inline";
       "Implicit Arguments"; "Add"; "Strict";
       "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation";
@@ -54,13 +54,13 @@ let is_keyword =
       "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next";
       "Program Instance"; "Equations"; "Equations_nocomp";
       (*i (* coq terms *) *)
-      "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; 
+      "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "fun";
       "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure";
       (* Ltac *)
       "before"; "after"
        ]
 
-let is_tactic = 
+let is_tactic =
   build_table
     [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection";
       "elimtype"; "progress"; "setoid_rewrite";
@@ -77,30 +77,51 @@ let is_tactic =
 
 (*s Current Coq module *)
 
-let current_module = ref ""
+let current_module : (string * string option) ref = ref ("",None)
 
-let set_module m = current_module := m; page_title := m
+let get_module withsub =
+  let (m,sub) = !current_module in
+  if withsub then
+    match sub with
+    | None -> m
+    | Some sub -> m ^ ": " ^ sub
+  else
+    m
+
+let set_module m sub = current_module := (m,sub);
+                       page_title := get_module true
 
 (*s Common to both LaTeX and HTML *)
 
 let item_level = ref 0
-
-(*s Customized pretty-print *)
-
-let token_pp = Hashtbl.create 97
-
-let add_printing_token = Hashtbl.replace token_pp
-
-let find_printing_token tok = 
-  try Hashtbl.find token_pp tok with Not_found -> None, None
-
-let remove_printing_token = Hashtbl.remove token_pp
-
-(* predefined pretty-prints *)
-let initialize () = 
+let in_doc = ref false
+
+(*s Customized and predefined pretty-print *)
+
+let initialize_texmacs () =
+  let ensuremath x = sprintf "<with|mode|math|\\<%s\\>>" x in
+  List.fold_right (fun (s,t) tt -> Tokens.ttree_add tt s t)
+    [ "*", ensuremath "times";
+      "->", ensuremath "rightarrow";
+      "<-", ensuremath "leftarrow";
+      "<->", ensuremath "leftrightarrow";
+      "=>", ensuremath "Rightarrow";
+      "<=", ensuremath "le";
+      ">=", ensuremath "ge";
+      "<>", ensuremath "noteq";
+      "~",  ensuremath "lnot";
+      "/\\", ensuremath "land";
+      "\\/", ensuremath "lor";
+      "|-", ensuremath "vdash"
+    ] Tokens.empty_ttree
+
+let token_tree_texmacs = ref (initialize_texmacs ())
+
+let initialize_tex_html () =
   let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in
-    List.iter 
-      (fun (s,l,l') -> Hashtbl.add token_pp s (Some l, l'))
+    List.fold_right (fun (s,l,l') (tt,tt') ->
+      (Tokens.ttree_add tt s l,
+       match l' with None -> tt' | Some l' -> Tokens.ttree_add tt' s l'))
       [ "*" ,  "\\ensuremath{\\times}", if_utf8 "×";
 	"|", "\\ensuremath{|}", None;
 	"->",  "\\ensuremath{\\rightarrow}", if_utf8 "→";
@@ -119,14 +140,27 @@ let initialize () =
 	"forall", "\\ensuremath{\\forall}", if_utf8 "∀";
 	"exists", "\\ensuremath{\\exists}", if_utf8 "∃";
 	"Π", "\\ensuremath{\\Pi}", if_utf8 "Π";
-	"λ", "\\ensuremath{\\lambda}", if_utf8 "λ"
+	"λ", "\\ensuremath{\\lambda}", if_utf8 "λ";
 	(* "fun", "\\ensuremath{\\lambda}" ? *)
-      ]
+      ] (Tokens.empty_ttree,Tokens.empty_ttree)
+
+let token_tree_latex = ref (fst (initialize_tex_html ()))
+let token_tree_html = ref (snd (initialize_tex_html ()))
+
+let add_printing_token s (t1,t2) =
+  (match t1 with None -> () | Some t1 ->
+    token_tree_latex := Tokens.ttree_add !token_tree_latex s t1);
+  (match t2 with None -> () | Some t2 ->
+    token_tree_html := Tokens.ttree_add !token_tree_html s t2)
+
+let remove_printing_token s =
+  token_tree_latex := Tokens.ttree_remove !token_tree_latex s;
+  token_tree_html := Tokens.ttree_remove !token_tree_html s
 
 (*s Table of contents *)
 
-type toc_entry = 
-  | Toc_library of string
+type toc_entry =
+  | Toc_library of string * string option
   | Toc_section of int * (unit -> unit) * string
 
 let (toc_q : toc_entry Queue.t) = Queue.create ()
@@ -140,7 +174,6 @@ let new_label = let r = ref 0 in fun () -> incr r; "lab" ^ string_of_int !r
 module Latex = struct
 
   let in_title = ref false
-  let in_doc = ref false
 
   (*s Latex preamble *)
 
@@ -155,10 +188,14 @@ module Latex = struct
       printf "\\usepackage[T1]{fontenc}\n";
       printf "\\usepackage{fullpage}\n";
       printf "\\usepackage{coqdoc}\n";
+      printf "\\usepackage{amsmath,amssymb}\n";
+      (match !toc_depth with
+       | None -> ()
+       | Some n -> printf "\\setcounter{tocdepth}{%i}\n" n);
       Queue.iter (fun s -> printf "%s\n" s) preamble;
       printf "\\begin{document}\n"
     end;
-    output_string 
+    output_string
       "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n";
     output_string
       "%% This file has been automatically generated with the command\n";
@@ -173,21 +210,28 @@ module Latex = struct
       printf "\\end{document}\n"
     end
 
+  (*s Latex low-level translation *)
+
+  let nbsp () = output_char '~'
+
   let char c = match c with
-    | '\\' -> 
+    | '\\' ->
 	printf "\\symbol{92}"
-    | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> 
+    | '$' | '#' | '%' | '&' | '{' | '}' | '_' ->
 	output_char '\\'; output_char c
-    | '^' | '~' -> 
+    | '^' | '~' ->
 	output_char '\\'; output_char c; printf "{}"
-    | _ -> 
+    | _ ->
 	output_char c
 
   let label_char c = match c with
-    | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_'
-    | '^' | '~' -> ()
-    | _ -> 
-	output_char c
+    | '_' -> output_char ' '
+    | '\\' | '$' | '#' | '%' | '&' | '{' | '}'
+    | '^' | '~' -> printf "x%X" (Char.code c)
+    | _ -> if c >= '\x80' then printf "x%X" (Char.code c) else output_char c
+
+  let label_ident s =
+    for i = 0 to String.length s - 1 do label_char s.[i] done
 
   let latex_char = output_char
   let latex_string = output_string
@@ -195,19 +239,36 @@ module Latex = struct
   let html_char _ = ()
   let html_string _ = ()
 
-  let raw_ident s =
-    for i = 0 to String.length s - 1 do char s.[i] done
-
-  let label_ident s =
-    for i = 0 to String.length s - 1 do label_char s.[i] done
-
-  let start_module () = 
-    if not !short then begin
-      printf "\\coqlibrary{"; 
-      label_ident !current_module; 
-      printf "}{";
-      raw_ident !current_module; 
-      printf "}\n\n"
+  (*s Latex char escaping *)
+
+  let escaped =
+    let buff = Buffer.create 5 in
+    fun s ->
+      Buffer.clear buff;
+      for i = 0 to String.length s - 1 do
+	match s.[i] with
+	| '\\' ->
+	    Buffer.add_string buff "\\symbol{92}"
+	| '$' | '#' | '%' | '&' | '{' | '}' | '_' as c ->
+	    Buffer.add_char buff '\\'; Buffer.add_char buff c
+	| '^' | '~' as c ->
+	    Buffer.add_char buff '\\'; Buffer.add_char buff c;
+	    Buffer.add_string buff "{}"
+	| c ->
+	    Buffer.add_char buff c
+      done;
+      Buffer.contents buff
+
+  (*s Latex reference and symbol translation *)
+
+  let start_module () =
+    let ln = !lib_name in
+      if not !short then begin
+        printf "\\coqlibrary{";
+        label_ident (get_module false);
+        printf "}{";
+        if ln <> "" then printf "%s " ln;
+        printf "}{%s}\n\n" (escaped (get_module true))
     end
 
   let start_latex_math () = output_char '$'
@@ -218,89 +279,101 @@ module Latex = struct
 
   let stop_verbatim () = printf "\\end{verbatim}\n"
 
-  let indentation n = 
-    if n == 0 then 
+  let indentation n =
+    if n == 0 then
       printf "\\coqdocnoindent\n"
     else
       let space = 0.5 *. (float n) in
       printf "\\coqdocindent{%2.2fem}\n" space
 
-  let with_latex_printing f tok =
-    try 
-      (match Hashtbl.find token_pp tok with
-	 | Some s, _ -> output_string s
-	 | _ -> f tok)
-    with Not_found -> 
-      f tok
-
-  let module_ref m s = 
-    printf "\\moduleid{%s}{" m; raw_ident s; printf "}"
-      (*i
-    match find_module m with
-    | Local ->
-	printf "<a href=\"%s.html\">" m; raw_ident s; printf "</a>"
-    | Coqlib when !externals ->
-	let m = Filename.concat !coqlib m in
-	printf "<a href=\"%s.html\">" m; raw_ident s; printf "</a>"
-    | Coqlib | Unknown ->
-	raw_ident s
-    i*)
+  let module_ref m s =
+    printf "\\moduleid{%s}{%s}" m (escaped s)
 
   let ident_ref m fid typ s =
     let id = if fid <> "" then (m ^ "." ^ fid) else m in
     match find_module m with
       | Local ->
-	  printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}"
-      | Coqlib when !externals ->
-	  let _m = Filename.concat !coqlib m in
-	    printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}"
-      | Coqlib | Unknown ->
-	  printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}"
+	  if typ = Variable then
+	    printf "\\coqdoc%s{%s}" (type_name typ) s
+	  else
+	    (printf "\\coqref{"; label_ident id;
+	     printf "}{\\coqdoc%s{%s}}" (type_name typ) s)
+      | External m when !externals ->
+	  printf "\\coqexternalref{"; label_ident fid;
+	  printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s
+      | External _ | Unknown ->
+	  printf "\\coqdoc%s{%s}" (type_name typ) s
 
   let defref m id ty s =
-    printf "\\coq%s{" (type_name ty); label_ident (m ^ "." ^ id); printf "}{"; raw_ident s; printf "}"
+    printf "\\coqdef{"; label_ident (m ^ "." ^ id);
+    printf "}{%s}{\\coqdoc%s{%s}}" s (type_name ty) s
 
   let reference s = function
-    | Def (fullid,typ) -> 
-	defref !current_module fullid typ s
+    | Def (fullid,typ) ->
+	defref (get_module false) fullid typ s
     | Mod (m,s') when s = s' ->
 	module_ref m s
-    | Ref (m,fullid,typ) -> 
+    | Ref (m,fullid,typ) ->
 	ident_ref m fullid typ s
     | Mod _ ->
-	printf "\\coqdocvar{"; raw_ident s; printf "}"
-	  
-  let ident s loc = 
-    if is_keyword s then begin
-      printf "\\coqdockw{"; raw_ident s; printf "}"
-    end else begin
-      begin
+	printf "\\coqdocvar{%s}" (escaped s)
+
+  (*s The sublexer buffers symbol characters and attached
+       uninterpreted ident and try to apply special translation such as,
+       predefined, translation "->" to "\ensuremath{\rightarrow}" or,
+       virtually, a user-level translation from "=_h" to "\ensuremath{=_{h}}" *)
+
+  let output_sublexer_string doescape issymbchar tag s =
+    let s = if doescape then escaped s else s in
+    match tag with
+    | Some ref -> reference s ref
+    | None -> if issymbchar then output_string s else printf "\\coqdocvar{%s}" s
+
+  let sublexer c loc =
+    let tag =
+      try Some (Index.find (get_module false) loc) with Not_found -> None
+    in
+    Tokens.output_tagged_symbol_char tag c
+
+  let initialize () =
+    Tokens.token_tree := token_tree_latex;
+    Tokens.outfun := output_sublexer_string
+
+  (*s Interpreting ident with fallback on sublexer if unknown ident *)
+
+  let translate s =
+    match Tokens.translate s with Some s -> s | None -> escaped s
+
+  let ident s loc =
+    try
+      let tag = Index.find (get_module false) loc in
+      reference (translate s) tag
+    with Not_found ->
+      if is_tactic s then
+	printf "\\coqdoctac{%s}" (translate s)
+      else if is_keyword s then
+	printf "\\coqdockw{%s}" (translate s)
+      else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *)
+      then
 	try
-	  reference s (Index.find !current_module loc)
-	with Not_found ->
-	  if is_tactic s then begin
-	    printf "\\coqdoctac{"; raw_ident s; printf "}"
-	  end else begin
-	    if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) 
-	    then
-	      try reference s (Index.find_string !current_module s)
-	      with _ -> (printf "\\coqdocvar{"; raw_ident s; printf "}")
-	    else (printf "\\coqdocvar{"; raw_ident s; printf "}")
-	  end
-      end
-    end
+	  let tag = Index.find_string (get_module false) s in
+	  reference (translate s) tag
+	with _ -> Tokens.output_tagged_ident_string s
+      else Tokens.output_tagged_ident_string s
 
-  let ident s l = 
+  let ident s l =
     if !in_title then (
       printf "\\texorpdfstring{\\protect";
-      with_latex_printing (fun s -> ident s l) s;
-      printf "}{"; raw_ident s; printf "}")
+      ident s l;
+      printf "}{%s}" (translate s))
     else
-      with_latex_printing (fun s -> ident s l) s
-    
-  let symbol s = with_latex_printing raw_ident s
+      ident s l
+
+  (*s Translating structure *)
+
+  let proofbox () = printf "\\ensuremath{\\Box}"
 
-  let rec reach_item_level n = 
+  let rec reach_item_level n =
     if !item_level < n then begin
       printf "\n\\begin{itemize}\n\\item "; incr item_level;
       reach_item_level n
@@ -320,7 +393,11 @@ module Latex = struct
 
   let end_doc () = in_doc := false; stop_item ()
 
-  let comment c = char c
+  (* This is broken if we are in math mode, but coqdoc currently isn't
+     tracking that *)
+  let start_emph () = printf "\\textit{"
+
+  let stop_emph () = printf "}"
 
   let start_comment () = printf "\\begin{coqdoccomment}\n"
 
@@ -350,12 +427,16 @@ module Latex = struct
   let rule () =
     printf "\\par\n\\noindent\\hrulefill\\par\n\\noindent{}"
 
-  let paragraph () = stop_item (); printf "\n\n"
+  let paragraph () = printf "\n\n"
 
   let line_break () = printf "\\coqdoceol\n"
 
   let empty_line_of_code () = printf "\\coqdocemptyline\n"
 
+  let start_inline_coq_block () = line_break (); empty_line_of_code ()
+
+  let end_inline_coq_block () = empty_line_of_code ()
+
   let start_inline_coq () = ()
 
   let end_inline_coq () = ()
@@ -377,9 +458,9 @@ module Html = struct
     if !header_trailer then
       if !header_file_spec then
 	let cin = Pervasives.open_in !header_file in
-	  try 
-	    while true do 
-	      let s = Pervasives.input_line cin in 
+	  try
+	    while true do
+	      let s = Pervasives.input_line cin in
 		printf "%s\n" s
 	    done
 	  with End_of_file -> Pervasives.close_in cin
@@ -396,14 +477,14 @@ module Html = struct
 	end
 
   let trailer () =
-    if !index && !current_module <> "Index" then 
-      printf "</div>\n\n<div id=\"footer\">\n<hr/><a href=\"index.html\">Index</a>";
-    if !header_trailer then 
+    if !index && (get_module false) <> "Index" then
+      printf "</div>\n\n<div id=\"footer\">\n<hr/><a href=\"%s.html\">Index</a>" !index_name;
+    if !header_trailer then
       if !footer_file_spec then
 	let cin = Pervasives.open_in !footer_file in
-	  try 
-	    while true do 
-	      let s = Pervasives.input_line cin in 
+	  try
+	    while true do
+	      let s = Pervasives.input_line cin in
 		printf "%s\n" s
 	    done
 	  with End_of_file -> Pervasives.close_in cin
@@ -414,26 +495,47 @@ module Html = struct
 	  printf "</div>\n\n</div>\n\n</body>\n</html>"
 	end
 
-  let start_module () = 
+  let start_module () =
+    let ln = !lib_name in
     if not !short then begin
-      add_toc_entry (Toc_library !current_module);
-      printf "<h1 class=\"libtitle\">Library %s</h1>\n\n" !current_module
+      let (m,sub) = !current_module in
+        add_toc_entry (Toc_library (m,sub));
+        if ln = ""  then
+          printf "<h1 class=\"libtitle\">%s</h1>\n\n" (get_module true)
+        else
+          printf "<h1 class=\"libtitle\">%s %s</h1>\n\n" ln (get_module true)
     end
 
   let indentation n = for i = 1 to n do printf "&nbsp;" done
 
   let line_break () = printf "<br/>\n"
 
-  let empty_line_of_code () = 
+  let empty_line_of_code () =
     printf "\n<br/>\n"
 
+  let nbsp () = printf "&nbsp;"
+
   let char = function
     | '<' -> printf "&lt;"
     | '>' -> printf "&gt;"
     | '&' -> printf "&amp;"
     | c -> output_char c
 
-  let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done
+  let raw_string s =
+    for i = 0 to String.length s - 1 do char s.[i] done
+
+  let escaped =
+    let buff = Buffer.create 5 in
+    fun s ->
+      Buffer.clear buff;
+      for i = 0 to String.length s - 1 do
+	match s.[i] with
+	| '<' -> Buffer.add_string buff "&lt;"
+	| '>' -> Buffer.add_string buff "&gt;"
+	| '&' -> Buffer.add_string buff "&amp;"
+	| c -> Buffer.add_char buff c
+      done;
+      Buffer.contents buff
 
   let latex_char _ = ()
   let latex_string _ = ()
@@ -447,74 +549,81 @@ module Html = struct
   let start_verbatim () = printf "<pre>"
   let stop_verbatim () = printf "</pre>\n"
 
-  let module_ref m s = 
+  let module_ref m s =
     match find_module m with
       | Local ->
-	  printf "<a class=\"modref\" href=\"%s.html\">" m; raw_ident s; printf "</a>"
-      | Coqlib when !externals ->
-	  let m = Filename.concat !coqlib m in
-	    printf "<a class=\"modref\" href=\"%s.html\">" m; raw_ident s; printf "</a>"
-      | Coqlib | Unknown ->
-	  raw_ident s
+	  printf "<a class=\"modref\" href=\"%s.html\">%s</a>" m s
+      | External m when !externals ->
+	  printf "<a class=\"modref\" href=\"%s.html\">%s</a>" m s
+      | External _ | Unknown ->
+	  output_string s
 
   let ident_ref m fid typ s =
     match find_module m with
     | Local ->
 	printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
-	printf "<span class=\"id\" type=\"%s\">" typ; 
-	raw_ident s;
-	printf "</span></a>"
-    | Coqlib when !externals ->
-	let m = Filename.concat !coqlib m in
-	  printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
-	  printf "<span class=\"id\" type=\"%s\">" typ; 
-	  raw_ident s; printf "</span></a>"
-    | Coqlib | Unknown ->
-	printf "<span class=\"id\" type=\"%s\">" typ; raw_ident s; printf "</span>"
-	  
-  let ident s loc = 
-    if is_keyword s then begin
-      printf "<span class=\"id\" type=\"keyword\">"; 
-      raw_ident s; 
-      printf "</span>"
-    end else 
-      begin
-	try
-	  (match Index.find !current_module loc with
-	     | Def (fullid,ty) -> 
-		 printf "<a name=\"%s\">" fullid; 
-		 printf "<span class=\"id\" type=\"%s\">" (type_name ty); 
-		 raw_ident s; printf "</span></a>"
-             | Mod (m,s') when s = s' ->
-		 module_ref m s
-	     | Ref (m,fullid,ty) -> 
-		 ident_ref m fullid (type_name ty) s
-	     | Mod _ ->
-		 printf "<span class=\"id\" type=\"mod\">"; raw_ident s ; printf "</span>")
-	with Not_found ->
-	  if is_tactic s then
-	    (printf "<span class=\"id\" type=\"tactic\">"; raw_ident s; printf "</span>")
-	  else
-	    (printf "<span class=\"id\" type=\"var\">"; raw_ident s ; printf "</span>")
-      end
+	printf "<span class=\"id\" type=\"%s\">%s</span></a>" typ s
+    | External m when !externals ->
+	printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
+	printf "<span class=\"id\" type=\"%s\">%s</span></a>" typ s
+    | External _ | Unknown ->
+	printf "<span class=\"id\" type=\"%s\">%s</span>" typ s
+
+  let reference s r =
+    match r with
+    | Def (fullid,ty) ->
+	printf "<a name=\"%s\">" fullid;
+	printf "<span class=\"id\" type=\"%s\">%s</span></a>" (type_name ty) s
+    | Mod (m,s') when s = s' ->
+	module_ref m s
+    | Ref (m,fullid,ty) ->
+	ident_ref m fullid (type_name ty) s
+    | Mod _ ->
+	printf "<span class=\"id\" type=\"mod\">%s</span>" s
+
+  let output_sublexer_string doescape issymbchar tag s =
+    let s = if doescape then escaped s else s in
+    match tag with
+    | Some ref -> reference s ref
+    | None ->
+	if issymbchar then output_string s
+	else printf "<span class=\"id\" type=\"var\">%s</span>" s
+
+  let sublexer c loc =
+    let tag =
+      try Some (Index.find (get_module false) loc) with Not_found -> None
+    in
+    Tokens.output_tagged_symbol_char tag c
 
-  let with_html_printing f tok =
-    try 
-      (match Hashtbl.find token_pp tok with
-	 | _, Some s -> output_string s
-	 | _ -> f tok)
-    with Not_found -> 
-      f tok
+  let initialize () =
+    Tokens.token_tree := token_tree_html;
+    Tokens.outfun := output_sublexer_string
 
-  let ident s l =
-    with_html_printing (fun s -> ident s l) s
+  let translate s =
+    match Tokens.translate s with Some s -> s | None -> escaped s
 
-  let symbol s =
-    with_html_printing raw_ident s
+  let ident s loc =
+    if is_keyword s then begin
+      printf "<span class=\"id\" type=\"keyword\">%s</span>" (translate s)
+    end else begin
+      try reference (translate s) (Index.find (get_module false) loc)
+      with Not_found ->
+	if is_tactic s then
+	  printf "<span class=\"id\" type=\"tactic\">%s</span>" (translate s)
+	else
+	  if !Cdglobals.interpolate && !in_doc (* always a var otherwise *)
+	  then
+	    try reference (translate s) (Index.find_string (get_module false) s)
+	    with _ -> Tokens.output_tagged_ident_string s
+	  else
+	    Tokens.output_tagged_ident_string s
+    end
 
-  let rec reach_item_level n = 
+  let proofbox () = printf "<font size=-2>&#9744;</font>"
+
+  let rec reach_item_level n =
     if !item_level < n then begin
-      printf "\n<ul>\n<li>"; incr item_level;
+      printf "<ul>\n<li>"; incr item_level;
       reach_item_level n
     end else if !item_level > n then begin
       printf "\n</li>\n</ul>\n"; decr item_level;
@@ -532,14 +641,18 @@ module Html = struct
 
   let end_coq () = if not !raw_comments then printf "</div>\n"
 
-  let start_doc () = 
+  let start_doc () = in_doc := true;
     if not !raw_comments then
       printf "\n<div class=\"doc\">\n"
 
-  let end_doc () =
-    stop_item (); 
+  let end_doc () = in_doc := false;
+    stop_item ();
     if not !raw_comments then printf "\n</div>\n"
 
+  let start_emph () = printf "<i>"
+
+  let stop_emph () = printf "</i>"
+
   let start_comment () = printf "<span class=\"comment\">(*"
 
   let end_comment () = printf "*)</span>"
@@ -552,16 +665,19 @@ module Html = struct
 
   let end_inline_coq () = printf "</span>"
 
-  let paragraph () = 
-    let i = !item_level in
-      stop_item ();
-      if i > 0 then printf "\n"
-      else printf "\n<br/> <br/>\n"
+  let start_inline_coq_block () = line_break (); start_inline_coq ()
+
+  let end_inline_coq_block () = end_inline_coq ()
+
+  let paragraph () = printf "\n<br/> <br/>\n"
 
   let section lev f =
     let lab = new_label () in
-    let r = sprintf "%s.html#%s" !current_module lab in
-    add_toc_entry (Toc_section (lev, f, r));
+    let r = sprintf "%s.html#%s" (get_module false) lab in
+    (match !toc_depth with
+     | None -> add_toc_entry (Toc_section (lev, f, r))
+     | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r))
+                   else ());
     stop_item ();
     printf "<a name=\"%s\"></a><h%d class=\"section\">" lab lev;
     f ();
@@ -572,64 +688,70 @@ module Html = struct
   (* make a HTML index from a list of triples (name,text,link) *)
   let index_ref i c =
     let idxc = sprintf "%s_%c" i.idx_name c in
-    if !multi_index then "index_" ^ idxc ^ ".html" else "index.html#" ^ idxc
+    !index_name ^ (if !multi_index then "_" ^ idxc ^ ".html" else ".html#" ^ idxc)
 
   let letter_index category idx (c,l) =
     if l <> [] then begin
       let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in
-      printf "<a name=\"%s_%c\"></a><h2>%c %s</h2>\n" idx c c cat;
-      List.iter 
-	(fun (id,(text,link)) -> 
-	   printf "<a href=\"%s\">%s</a> %s<br/>\n" link id text) l;
+      printf "<a name=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat;
+      List.iter
+	(fun (id,(text,link,t)) ->
+	   let id' = prepare_entry id t in
+	   printf "<a href=\"%s\">%s</a> %s<br/>\n" link id' text) l;
       printf "<br/><br/>"
     end
-		
+
   let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries
 
   (* Construction d'une liste des index (1 index global, puis 1
      index par catégorie) *)
   let format_global_index =
-    Index.map 
-      (fun s (m,t) -> 
-	 if t = Library then 
-	   "[library]", m ^ ".html"
-	 else
-	   sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (type_name t) m m ,
-	 sprintf "%s.html#%s" m s)
+    Index.map
+      (fun s (m,t) ->
+	if t = Library then
+         let ln = !lib_name in
+           if ln <> "" then
+	       "[" ^ String.lowercase ln ^ "]", m ^ ".html", t
+           else
+	       "[library]", m ^ ".html", t
+	else
+	 sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (type_name t) m m ,
+	sprintf "%s.html#%s" m s, t)
 
   let format_bytype_index = function
     | Library, idx ->
-	Index.map (fun id m -> "", m ^ ".html") idx
+	Index.map (fun id m -> "", m ^ ".html", Library) idx
     | (t,idx) ->
-	Index.map 
-	  (fun s m -> 
+	Index.map
+	  (fun s m ->
 	     let text = sprintf "[in <a href=\"%s.html\">%s</a>]" m m in
-	       (text, sprintf "%s.html#%s" m s)) idx
+	       (text, sprintf "%s.html#%s" m s, t)) idx
 
   (* Impression de la table d'index *)
   let print_index_table_item i =
     printf "<tr>\n<td>%s Index</td>\n" (String.capitalize i.idx_name);
-    List.iter 
-      (fun (c,l) -> 
+    List.iter
+      (fun (c,l) ->
 	 if l <> [] then
-	   printf "<td><a href=\"%s\">%c</a></td>\n" (index_ref i c) c
+	   printf "<td><a href=\"%s\">%s</a></td>\n" (index_ref i c)
+	     (display_letter c)
 	 else
-	   printf "<td>%c</td>\n" c)
+	   printf "<td>%s</td>\n" (display_letter c))
       i.idx_entries;
     let n = i.idx_size in
       printf "<td>(%d %s)</td>\n" n (if n > 1 then "entries" else "entry");
       printf "</tr>\n"
 
-  let print_index_table idxl = 
+  let print_index_table idxl =
     printf "<table>\n";
     List.iter print_index_table_item idxl;
     printf "</table>\n"
-	
+
   let make_one_multi_index prt_tbl i =
-    (* Attn: make_one_multi_index créé un nouveau fichier... *)
+    (* Attn: make_one_multi_index crée un nouveau fichier... *)
     let idx = i.idx_name in
     let one_letter ((c,l) as cl) =
-      open_out_file (sprintf "index_%s_%c.html" idx c);
+      open_out_file (sprintf "%s_%s_%c.html" !index_name idx c);
       if (!header_trailer) then header ();
       prt_tbl (); printf "<hr/>";
       letter_index true idx cl;
@@ -639,16 +761,16 @@ module Html = struct
     in
       List.iter one_letter i.idx_entries
 
-  let make_multi_index () = 
-    let all_index = 
+  let make_multi_index () =
+    let all_index =
       let glob,bt = Index.all_entries () in
 	(format_global_index glob) ::
 	  (List.map format_bytype_index bt) in
     let print_table () = print_index_table all_index in
       List.iter (make_one_multi_index print_table) all_index
-	
+
   let make_index () =
-    let all_index = 
+    let all_index =
       let glob,bt = Index.all_entries () in
 	(format_global_index glob) ::
 	  (List.map format_bytype_index bt) in
@@ -659,26 +781,33 @@ module Html = struct
 	all_letters i
       end
     in
-      current_module := "Index";
+      set_module "Index" None;
       if !title <> "" then printf "<h1>%s</h1>\n" !title;
       print_table ();
-      if not (!multi_index) then 
+      if not (!multi_index) then
 	begin
 	  List.iter print_one_index all_index;
 	  printf "<hr/>"; print_table ()
 	end
-	    
-  let make_toc () = 
-    let make_toc_entry = function
-      | Toc_library m -> 
-	  stop_item ();
-	  printf "<a href=\"%s.html\"><h2>Library %s</h2></a>\n" m m
-      | Toc_section (n, f, r) ->
-	  item n; 
-	  printf "<a href=\"%s\">" r; f (); printf "</a>\n"
-    in
-      Queue.iter make_toc_entry toc_q;
-      stop_item ();
+
+    let make_toc () =
+	let ln = !lib_name in
+      let make_toc_entry = function
+        | Toc_library (m,sub) ->
+ 		stop_item ();
+		let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in
+              if ln = "" then
+ 	          printf "<a href=\"%s.html\"><h2>%s</h2></a>\n" m ms
+              else
+ 	          printf "<a href=\"%s.html\"><h2>%s %s</h2></a>\n" m ln ms
+        | Toc_section (n, f, r) ->
+  		item n;
+  		printf "<a href=\"%s\">" r; f (); printf "</a>\n"
+      in
+        printf "<div id=\"toc\">\n";
+        Queue.iter make_toc_entry toc_q;
+        stop_item ();
+        printf "</div>\n"
 
 end
 
@@ -689,21 +818,21 @@ module TeXmacs = struct
 
   (*s Latex preamble *)
 
-  let in_doc = ref false
-
-  let (preamble : string Queue.t) = 
+  let (preamble : string Queue.t) =
     in_doc := false; Queue.create ()
 
   let push_in_preamble s = Queue.add s preamble
 
   let header () =
-    output_string 
+    output_string
       "(*i This file has been automatically generated with the command  \n";
-    output_string 
+    output_string
       "    "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf " *)\n"
 
   let trailer () = ()
 
+  let nbsp () = output_char ' '
+
   let char_true c = match c with
     | '\\' -> printf "\\\\"
     | '<' -> printf "\\<"
@@ -734,7 +863,7 @@ module TeXmacs = struct
 
   let indentation n = ()
 
-  let ident_true s = 
+  let ident_true s =
     if is_keyword s then begin
       printf "<kw|"; raw_ident s; printf ">"
     end else begin
@@ -742,27 +871,20 @@ module TeXmacs = struct
     end
 
   let ident s _ = if !in_doc then ident_true s else raw_ident s
- 
-  let symbol_true s = 
-    let ensuremath x = printf "<with|mode|math|\\<%s\\>>" x in
-      match s with
-	| "*"  -> ensuremath "times"
-	| "->" -> ensuremath "rightarrow"
-	| "<-" -> ensuremath "leftarrow"
-	| "<->" ->ensuremath "leftrightarrow"
-	| "=>" -> ensuremath "Rightarrow"
-	| "<=" -> ensuremath "le"
-	| ">=" -> ensuremath "ge"
-	| "<>" -> ensuremath "noteq"
-	| "~" ->  ensuremath "lnot"
-	| "/\\" -> ensuremath "land"
-	| "\\/" -> ensuremath "lor"
-	| "|-" -> ensuremath "vdash"
-	| s    -> raw_ident s
-
-  let symbol s = if !in_doc then symbol_true s else raw_ident s
-
-  let rec reach_item_level n = 
+
+  let output_sublexer_string doescape issymbchar tag s =
+    if doescape then raw_ident s else output_string s
+
+  let sublexer c l =
+    if !in_doc then Tokens.output_tagged_symbol_char None c else char c
+
+  let initialize () =
+    Tokens.token_tree := token_tree_texmacs;
+    Tokens.outfun := output_sublexer_string
+
+  let proofbox () = printf "QED"
+
+  let rec reach_item_level n =
     if !item_level < n then begin
       printf "\n<\\itemize>\n<item>"; incr item_level;
       reach_item_level n
@@ -786,6 +908,9 @@ module TeXmacs = struct
 
   let end_coq () = ()
 
+  let start_emph () = printf "<with|font shape|italic|"
+  let stop_emph () = printf ">"
+
   let start_comment () = ()
   let end_comment () = ()
 
@@ -801,13 +926,13 @@ module TeXmacs = struct
 
   let section lev f =
     stop_item ();
-    printf "<"; output_string (section_kind lev); printf "|"; 
+    printf "<"; output_string (section_kind lev); printf "|";
     f (); printf ">\n\n"
 
   let rule () =
     printf "\n<hrule>\n"
 
-  let paragraph () = stop_item (); printf "\n\n"
+  let paragraph () = printf "\n\n"
 
   let line_break_true () = printf "<format|line break>"
 
@@ -819,6 +944,10 @@ module TeXmacs = struct
 
   let end_inline_coq () = printf "]>"
 
+  let start_inline_coq_block () = line_break (); start_inline_coq ()
+
+  let end_inline_coq_block () = end_inline_coq ()
+
   let make_multi_index () = ()
 
   let make_index () = ()
@@ -828,7 +957,7 @@ module TeXmacs = struct
 end
 
 
-(*s LaTeX output *)
+(*s Raw output *)
 
 module Raw = struct
 
@@ -836,13 +965,9 @@ module Raw = struct
 
   let trailer () = ()
 
-  let char = output_char
+  let nbsp () = output_char ' '
 
-  let label_char c = match c with
-    | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_'
-    | '^' | '~' -> ()
-    | _ -> 
-	output_char c
+  let char = output_char
 
   let latex_char = output_char
   let latex_string = output_string
@@ -863,22 +988,31 @@ module Raw = struct
 
   let stop_verbatim () = ()
 
-  let indentation n = 
+  let indentation n =
       for i = 1 to n do printf " " done
 
   let ident s loc = raw_ident s
 
-  let symbol s = raw_ident s
+  let sublexer c l = char c
 
-  let item n = printf "- "
+  let initialize () =
+    Tokens.token_tree := ref Tokens.empty_ttree;
+    Tokens.outfun := (fun _ _ _ _ -> failwith "Useless")
+
+  let proofbox () = printf "[]"
 
+  let item n = printf "- "
   let stop_item () = ()
+  let reach_item_level _ = ()
 
   let start_doc () = printf "(** "
   let end_doc () = printf " *)\n"
 
-  let start_comment () = ()
-  let end_comment () = ()
+  let start_emph () = printf "_"
+  let stop_emph () = printf "_"
+
+  let start_comment () = printf "(*"
+  let end_comment () = printf "*)"
 
   let start_coq () = ()
   let end_coq () = ()
@@ -886,15 +1020,15 @@ module Raw = struct
   let start_code () = end_doc (); start_coq ()
   let end_code () = end_coq (); start_doc ()
 
-  let section_kind = 
+  let section_kind =
     function
-      | 1 -> "*"
-      | 2 -> "**"
-      | 3 -> "***"
-      | 4 -> "****"
-      | _ -> assert false    
+      | 1 -> "* "
+      | 2 -> "** "
+      | 3 -> "*** "
+      | 4 -> "**** "
+      | _ -> assert false
 
-  let section lev f = 
+  let section lev f =
     output_string (section_kind lev);
     f ()
 
@@ -909,9 +1043,12 @@ module Raw = struct
   let start_inline_coq () = ()
   let end_inline_coq () = ()
 
+  let start_inline_coq_block () = line_break (); start_inline_coq ()
+  let end_inline_coq_block () = end_inline_coq ()
+
   let make_multi_index () = ()
   let make_index () = ()
-  let make_toc () = () 
+  let make_toc () = ()
 
 end
 
@@ -919,7 +1056,7 @@ end
 
 (*s Generic output *)
 
-let select f1 f2 f3 f4 x = 
+let select f1 f2 f3 f4 x =
   match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x | Raw -> f4 x
 
 let push_in_preamble = Latex.push_in_preamble
@@ -927,7 +1064,7 @@ let push_in_preamble = Latex.push_in_preamble
 let header = select Latex.header Html.header TeXmacs.header Raw.header
 let trailer = select Latex.trailer Html.trailer TeXmacs.trailer Raw.trailer
 
-let start_module = 
+let start_module =
   select Latex.start_module Html.start_module TeXmacs.start_module Raw.start_module
 
 let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc Raw.start_doc
@@ -940,45 +1077,61 @@ let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.star
 let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq
 
 let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code
-let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code 
+let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code
 
-let start_inline_coq = 
+let start_inline_coq =
   select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq
-let end_inline_coq = 
+let end_inline_coq =
   select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq Raw.end_inline_coq
 
+let start_inline_coq_block =
+  select Latex.start_inline_coq_block Html.start_inline_coq_block
+    TeXmacs.start_inline_coq_block Raw.start_inline_coq_block
+let end_inline_coq_block =
+  select Latex.end_inline_coq_block Html.end_inline_coq_block TeXmacs.end_inline_coq_block Raw.end_inline_coq_block
+
 let indentation = select Latex.indentation Html.indentation TeXmacs.indentation Raw.indentation
 let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph Raw.paragraph
 let line_break = select Latex.line_break Html.line_break TeXmacs.line_break Raw.line_break
-let empty_line_of_code = select 
+let empty_line_of_code = select
   Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code Raw.empty_line_of_code
 
 let section = select Latex.section Html.section TeXmacs.section Raw.section
 let item = select Latex.item Html.item TeXmacs.item Raw.item
 let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item Raw.stop_item
+let reach_item_level = select Latex.reach_item_level Html.reach_item_level TeXmacs.reach_item_level Raw.reach_item_level
 let rule = select Latex.rule Html.rule TeXmacs.rule Raw.rule
 
+let nbsp = select Latex.nbsp Html.nbsp TeXmacs.nbsp Raw.nbsp
 let char = select Latex.char Html.char TeXmacs.char Raw.char
 let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident
-let symbol = select Latex.symbol Html.symbol TeXmacs.symbol Raw.symbol
+let sublexer = select Latex.sublexer Html.sublexer TeXmacs.sublexer Raw.sublexer
+let initialize = select Latex.initialize Html.initialize TeXmacs.initialize Raw.initialize
+
+let proofbox = select Latex.proofbox Html.proofbox TeXmacs.proofbox Raw.proofbox
 
 let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char Raw.latex_char
-let latex_string = 
+let latex_string =
   select Latex.latex_string Html.latex_string TeXmacs.latex_string Raw.latex_string
 let html_char = select Latex.html_char Html.html_char TeXmacs.html_char Raw.html_char
-let html_string = 
+let html_string =
   select Latex.html_string Html.html_string TeXmacs.html_string Raw.html_string
 
-let start_latex_math = 
+let start_emph =
+  select Latex.start_emph Html.start_emph TeXmacs.start_emph Raw.start_emph
+let stop_emph =
+  select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph
+
+let start_latex_math =
   select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math
-let stop_latex_math = 
+let stop_latex_math =
   select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math Raw.stop_latex_math
 
-let start_verbatim = 
+let start_verbatim =
   select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim
-let stop_verbatim = 
+let stop_verbatim =
   select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim
-let verbatim_char = 
+let verbatim_char =
   select output_char Html.char TeXmacs.char Raw.char
 let hard_verbatim_char = output_char
 
diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli
index 75c7ccf8..d836f6b3 100644
--- a/tools/coqdoc/output.mli
+++ b/tools/coqdoc/output.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: output.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Cdglobals
 open Index
@@ -16,7 +16,8 @@ val initialize : unit -> unit
 val add_printing_token : string -> string option * string option -> unit
 val remove_printing_token : string -> unit
 
-val set_module : coq_module -> unit
+val set_module : coq_module -> string option -> unit
+val get_module : bool -> string
 
 val header : unit -> unit
 val trailer : unit -> unit
@@ -28,6 +29,9 @@ val start_module : unit -> unit
 val start_doc : unit -> unit
 val end_doc : unit -> unit
 
+val start_emph : unit -> unit
+val stop_emph : unit -> unit
+
 val start_comment : unit -> unit
 val end_comment : unit -> unit
 
@@ -40,6 +44,9 @@ val end_code : unit -> unit
 val start_inline_coq : unit -> unit
 val end_inline_coq : unit -> unit
 
+val start_inline_coq_block : unit -> unit
+val end_inline_coq_block : unit -> unit
+
 val indentation : int -> unit
 val line_break : unit -> unit
 val paragraph : unit -> unit
@@ -48,12 +55,18 @@ val empty_line_of_code : unit -> unit
 val section : int -> (unit -> unit) -> unit
 
 val item : int -> unit
+val stop_item : unit -> unit
+val reach_item_level : int -> unit
 
 val rule : unit -> unit
 
+val nbsp : unit -> unit
 val char : char -> unit
 val ident : string -> loc -> unit
-val symbol : string -> unit
+val sublexer : char -> loc -> unit
+val initialize : unit -> unit
+
+val proofbox : unit -> unit
 
 val latex_char : char -> unit
 val latex_string : string -> unit
diff --git a/tools/coqdoc/pretty.mll b/tools/coqdoc/pretty.mll
deleted file mode 100644
index b29e0734..00000000
--- a/tools/coqdoc/pretty.mll
+++ /dev/null
@@ -1,784 +0,0 @@
-(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: pretty.mll 12908 2010-04-09 08:54:04Z herbelin $ i*)
-
-(*s Utility functions for the scanners *)
-
-{
-  open Printf
-  open Lexing 
-
-  (* count the number of spaces at the beginning of a string *)
-  let count_spaces s =
-    let n = String.length s in
-    let rec count c i = 
-      if i == n then c,i else match s.[i] with
-	| '\t' -> count (c + (8 - (c mod 8))) (i + 1)
-	| ' ' -> count (c + 1) (i + 1)
-	| _ -> c,i
-    in
-      count 0 0
-
-  let count_dashes s =
-    let c = ref 0 in
-    for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done;
-    !c
-
-  let cut_head_tail_spaces s =
-    let n = String.length s in
-    let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in
-    let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in
-    let l = look_up 0 in
-    let r = look_dn (n-1) in
-    if l <= r then String.sub s l (r-l+1) else s
-
-  let sec_title s =
-    let rec count lev i = 
-      if s.[i] = '*' then 
-	count (succ lev) (succ i) 
-      else 
-	let t = String.sub s i (String.length s - i) in
-	lev, cut_head_tail_spaces t
-    in
-    count 0 (String.index s '*')
-
-  let strip_eol s =
-    let eol = s.[String.length s - 1] = '\n' in
-    (eol, if eol then String.sub s 1 (String.length s - 1) else s)
-
-
-  let formatted = ref false
-  let brackets = ref 0
-  let comment_level = ref 0
-  let in_proof = ref None
-
-  let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos
-
-  let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
-
-  (* saving/restoring the PP state *)
-
-  type state = {
-    st_gallina : bool;
-    st_light : bool
-  }
-
-  let state_stack = Stack.create ()
-
-  let save_state () = 
-    Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack
-
-  let restore_state () =
-    let s = Stack.pop state_stack in
-    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 show_all f = without_gallina (without_light f)
-
-  let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false
-  let end_show () = restore_state ()
-
-  (* Reset the globals *)
-
-  let reset () =
-    formatted := false;
-    brackets := 0;
-    comment_level := 0
-
-  (* erasing of Section/End *)
-
-  let section_re = Str.regexp "[ \t]*Section"
-  let end_re = Str.regexp "[ \t]*End"
-  let is_section s = Str.string_match section_re s 0
-  let is_end s = Str.string_match end_re s 0
-
-  let sections_to_close = ref 0
-
-  let section_or_end s =
-    if is_section s then begin
-      incr sections_to_close; true
-    end else if is_end s then begin
-      if !sections_to_close > 0 then begin 
-	decr sections_to_close; true 
-      end else 
-	false
-    end else
-      true
-
-  (* tokens pretty-print *)
-
-  let token_buffer = Buffer.create 1024
-
-  let token_re = 
-    Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)"
-  let printing_token_re =
-    Str.regexp
-      "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\(&#\\|[^#]\\)*\\)#\\)?"
-
-  let add_printing_token toks pps =
-    try
-      if Str.string_match token_re toks 0 then
-	let tok = Str.matched_group 1 toks in
-	if Str.string_match printing_token_re pps 0 then
-	  let pp = 
-	    (try Some (Str.matched_group 3 pps) with _ -> 
-             try Some (Str.matched_group 4 pps) with _ -> None),
-	    (try Some (Str.matched_group 6 pps) with _ -> None)
-	  in
-	  Output.add_printing_token tok pp
-    with _ ->
-      ()
-
-  let remove_token_re = 
-    Str.regexp 
-      "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)"
-
-  let remove_printing_token toks =
-    try
-      if Str.string_match remove_token_re toks 0 then
-	let tok = Str.matched_group 1 toks in
-	Output.remove_printing_token tok
-    with _ ->
-      ()
-
-  let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:="
-  let extract_ident s =
-    assert (String.length s >= 3);
-    if Str.string_match extract_ident_re s 0 then
-      Str.matched_group 1 s
-    else
-      String.sub s 1 (String.length s - 3)
-
-  let symbol lexbuf s = Output.symbol s 
-
-}
-
-(*s Regular expressions *)
-
-let space = [' ' '\t']
-let space_nl = [' ' '\t' '\n' '\r']
-let nl = "\r\n" | '\n'
-
-let firstchar = 
-  ['A'-'Z' 'a'-'z' '_' 
-  (* iso 8859-1 accents *) 
-  '\192'-'\214' '\216'-'\246' '\248'-'\255' ] |
-  (* *)
-  '\194' '\185' |
-  (* utf-8 latin 1 supplement *) 
-  '\195' ['\128'-'\191'] |
-  (* utf-8 letterlike symbols *) 
-  '\206' ('\160' | [ '\177'-'\183'] | '\187') |
-  '\226' ('\130' [ '\128'-'\137' ] (* subscripts *)
-    | '\129' [ '\176'-'\187' ] (* superscripts *)
-    | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143'])
-let identchar = 
-  firstchar | ['\'' '0'-'9' '@' ]
-let id = firstchar identchar*
-let pfx_id = (id '.')*
-let identifier = 
-  id | pfx_id id
-
-let symbolchar_symbol_no_brackets =
-  ['!' '$' '%' '&' '*' '+' ',' '^' '#'
-      '\\' '/' '-' '<' '>' '|' ':' '?' '=' '~' ] |
-  (* utf-8 symbols *) 
-  '\226' ['\134'-'\143' '\152'-'\155' '\164'-'\165' '\168'-'\171'] _
-let symbolchar_no_brackets = symbolchar_symbol_no_brackets | 
-    [ '@' '{' '}' '(' ')' 'A'-'Z' 'a'-'z' '_']
-let symbolchar = symbolchar_no_brackets | '[' | ']'
-let token_no_brackets = symbolchar_symbol_no_brackets symbolchar_no_brackets*
-let token = symbolchar_symbol_no_brackets symbolchar* | '[' [^ '[' ']' ':']* ']'
-let printing_token = (token | id)+
-
-(* tokens with balanced brackets *)
-let token_brackets =
-  ( token_no_brackets ('[' token_no_brackets? ']')* 
-  | token_no_brackets? ('[' token_no_brackets? ']')+ )
-  token_no_brackets?
-
-let thm_token = 
-  "Theorem" 
-  | "Lemma" 
-  | "Fact" 
-  | "Remark" 
-  | "Corollary" 
-  | "Proposition" 
-  | "Property"
-  | "Goal"
-
-let prf_token =
-  "Next" space+ "Obligation"
-  | "Proof" (space* "." | space+ "with")
-
-let def_token = 
-  "Definition" 
-  | "Let" 
-  | "Class"
-  | "SubClass"
-  | "Example"
-  | "Local" 
-  | "Fixpoint" 
-  | "Boxed" 
-  | "CoFixpoint" 
-  | "Record" 
-  | "Structure" 
-  | "Scheme"
-  | "Inductive"
-  | "CoInductive"
-  | "Equations"
-  | "Instance"
-  | "Global" space+ "Instance"
-
-let decl_token = 
-  "Hypothesis" 
-  | "Hypotheses" 
-  | "Parameter" 
-  | "Axiom" 's'? 
-  | "Conjecture"
-
-let gallina_ext =
-  "Module" 
-  | "Include" space+ "Type"
-  | "Include"
-  | "Declare" space+ "Module"
-  | "Transparent"
-  | "Opaque"
-  | "Canonical"
-  | "Coercion"
-  | "Identity"
-  | "Implicit"
-  | "Notation"
-  | "Infix"
-  | "Tactic" space+ "Notation"
-  | "Reserved" space+ "Notation"
-  | "Section"
-  | "Context"
-  | "Variable" 's'?
-  | ("Hypothesis" | "Hypotheses")
-  | "End"
-
-let commands = 
-  "Pwd"
-  | "Cd"
-  | "Drop"
-  | "ProtectedLoop"
-  | "Quit"
-  | "Load"
-  | "Add"
-  | "Remove" space+ "Loadpath"
-  | "Print"
-  | "Inspect"
-  | "About"
-  | "Search"
-  | "Eval"
-  | "Reset"
-  | "Check"
-  | "Type"
-
-  | "Section"
-  | "Chapter"
-  | "Variable" 's'?
-  | ("Hypothesis" | "Hypotheses")
-  | "End"
-
-let end_kw = "Qed" | "Defined" | "Save" | "Admitted" | "Abort"
-
-let extraction = 
-  "Extraction"
-  | "Recursive" space+ "Extraction" 
-  | "Extract"
-
-let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction
-
-let prog_kw =
-  "Program" space+ gallina_kw
-  | "Obligation"
-  | "Obligations"
-  | "Solve"
-
-let gallina_kw_to_hide =
-    "Implicit" space+ "Arguments"
-  | "Ltac"
-  | "Require"
-  | "Import"
-  | "Export"
-  | "Load" 
-  | "Hint"
-  | "Open"
-  | "Close"
-  | "Delimit"
-  | "Transparent"
-  | "Opaque"
-  | ("Declare" space+ ("Morphism" | "Step") )
-  | ("Set" | "Unset") space+ "Printing" space+ "Coercions"
-  | "Declare" space+ ("Left" | "Right") space+ "Step" 
-
-
-let section = "*" | "**" | "***" | "****"
-
-let item_space = "    "
-
-let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl
-let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl
-let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl
-let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl
-(*
-let begin_verb = "(*" space* "begin" space+ "verb" space* "*)"
-let end_verb = "(*" space* "end" space+ "verb" space* "*)"
-*)
-
-
-
-(*s Scanning Coq, at beginning of line *)
-
-rule coq_bol = parse
-  | space* nl+
-      { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf }
-  | space* "(**" space_nl
-      { Output.end_coq (); Output.start_doc (); 
-	let eol = doc_bol lexbuf in
-	  Output.end_doc (); Output.start_coq (); 
-	  if eol then coq_bol lexbuf else coq lexbuf }
-  | space* "Comments" space_nl
-      { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); 
-	Output.start_coq (); coq lexbuf }
-  | space* begin_hide
-      { skip_hide lexbuf; coq_bol lexbuf }
-  | space* begin_show
-      { begin_show (); coq_bol lexbuf }
-  | space* end_show
-      { end_show (); coq_bol lexbuf }
-  | space* gallina_kw_to_hide
-      { let s = lexeme lexbuf in
-	  if !Cdglobals.light && section_or_end s then 
-	    let eol = skip_to_dot lexbuf in
-	      if eol then (coq_bol lexbuf) else coq lexbuf
-	  else 
-	    begin
-	      let nbsp,isp = count_spaces s in
-		Output.indentation nbsp; 
-		let s = String.sub s isp (String.length s - isp) in
-		  Output.ident s (lexeme_start lexbuf + isp); 
-		  let eol = body lexbuf in 
-		    if eol then coq_bol lexbuf else coq lexbuf
-	    end }
-  | space* thm_token
-      { let s = lexeme lexbuf in 
-	let nbsp,isp = count_spaces s in
-	let s = String.sub s isp (String.length s - isp)  in
-	  Output.indentation nbsp;
-	  Output.ident s (lexeme_start lexbuf + isp); 
-	  let eol = body lexbuf in
-	    in_proof := Some eol;
-	    if eol then coq_bol lexbuf else coq lexbuf }
-  | space* prf_token
-      { in_proof := Some true;
-	let eol = 
-	  if not !Cdglobals.gallina then 
-	    begin backtrack lexbuf; body_bol lexbuf end 
-	  else 
-	    let s = lexeme lexbuf in
-	      if s.[String.length s - 1] = '.' then false
-	      else skip_to_dot lexbuf
-	in if eol then coq_bol lexbuf else coq lexbuf }
-  | space* end_kw { 
-      let eol = 
-	if not (!in_proof <> None && !Cdglobals.gallina) then 
-	  begin backtrack lexbuf; body_bol lexbuf end 
-	else skip_to_dot lexbuf
-      in
-	in_proof := None;
-	if eol then coq_bol lexbuf else coq lexbuf }
-  | space* gallina_kw
-      { 
-	in_proof := None;
-	let s = lexeme lexbuf in 
-	let nbsp,isp = count_spaces s in
-	let s = String.sub s isp (String.length s - isp)  in
-	  Output.indentation nbsp;
-	  Output.ident s (lexeme_start lexbuf + isp); 
-	  let eol= body lexbuf in
-	    if eol then coq_bol lexbuf else coq lexbuf }
-  | space* prog_kw
-      { 
-	in_proof := None;
-	let s = lexeme lexbuf in 
-	let nbsp,isp = count_spaces s in
-	  Output.indentation nbsp;
-	  let s = String.sub s isp (String.length s - isp)  in
-	    Output.ident s (lexeme_start lexbuf + isp); 
-	    let eol= body lexbuf in
-	      if eol then coq_bol lexbuf else coq lexbuf }
-
-  | space* "(**" space+ "printing" space+ printing_token space+
-      { let tok = lexeme lexbuf in
-	let s = printing_token_body lexbuf in
-	  add_printing_token tok s;
-	  coq_bol lexbuf }
-  | space* "(**" space+ "printing" space+
-      { eprintf "warning: bad 'printing' command at character %d\n" 
-	  (lexeme_start lexbuf); flush stderr;
-	comment_level := 1;
-	ignore (comment lexbuf);
-	coq_bol lexbuf }
-  | space* "(**" space+ "remove" space+ "printing" space+ 
-      (identifier | token) space* "*)"
-      { remove_printing_token (lexeme lexbuf);
-	coq_bol lexbuf }
-  | space* "(**" space+ "remove" space+ "printing" space+
-      { eprintf "warning: bad 'remove printing' command at character %d\n" 
-	  (lexeme_start lexbuf); flush stderr;
-	comment_level := 1;
-	ignore (comment lexbuf);
-	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 }
-  | eof 
-      { () }
-  | _
-      { let eol = 
-	  if not !Cdglobals.gallina then 
-	    begin backtrack lexbuf; body_bol lexbuf end 
-	  else 
-	    skip_to_dot lexbuf 
-	in
-	  if eol then coq_bol lexbuf else coq lexbuf }
-
-(*s Scanning Coq elsewhere *)
-
-and coq = parse
-  | nl 
-      { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf }
-  | "(**" space_nl
-      { Output.end_coq (); Output.start_doc (); 
-	let eol = doc_bol lexbuf in
-	  Output.end_doc (); Output.start_coq (); 
-	  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
-      }
-  | nl+ space* "]]"
-      { if not !formatted then begin symbol lexbuf (lexeme lexbuf); coq lexbuf end }
-  | eof 
-      { () }
-  | gallina_kw_to_hide
-      { let s = lexeme lexbuf in
-	  if !Cdglobals.light && section_or_end s then 
-	    begin 
-	      let eol = skip_to_dot lexbuf in
-		if eol then coq_bol lexbuf else coq lexbuf 
-	    end 
-	  else 
-	    begin
-	      Output.ident s (lexeme_start lexbuf); 
-	      let eol=body lexbuf in 
-		if eol then coq_bol lexbuf else coq lexbuf
-	    end }
-  | prf_token
-      { let eol = 
-	  if not !Cdglobals.gallina then 
-	    begin backtrack lexbuf; body_bol lexbuf end 
-	  else 
-	    let s = lexeme lexbuf in
-	    let eol = 
-	      if s.[String.length s - 1] = '.' then false
-	      else skip_to_dot lexbuf
-	    in
-	      eol
-	in if eol then coq_bol lexbuf else coq lexbuf }
-  | end_kw { 
-      let eol = 
-	if not !Cdglobals.gallina then 
-	  begin backtrack lexbuf; body lexbuf end 
-	else 
-	  let eol = skip_to_dot lexbuf in
-	    if !in_proof <> Some true && eol then 
-	      Output.line_break ();
-	    eol
-      in
-	in_proof := None;
-	if eol then coq_bol lexbuf else coq lexbuf }
-  | gallina_kw
-      { let s = lexeme lexbuf in 
-	  Output.ident s (lexeme_start lexbuf); 
-	let eol = body lexbuf in
-	  if eol then coq_bol lexbuf else coq lexbuf }
-  | prog_kw
-      { let s = lexeme lexbuf in 
-	  Output.ident s (lexeme_start lexbuf); 
-	let eol = body lexbuf in
-	  if eol then coq_bol lexbuf else coq lexbuf }
-  | space+ { Output.char ' '; coq lexbuf }
-  | eof 
-      { () }
-  | _ {	let eol = 
-	  if not !Cdglobals.gallina then 
-	    begin backtrack lexbuf; body lexbuf end 
-	  else 
-	    skip_to_dot lexbuf
-	in 
-	  if eol then coq_bol lexbuf else coq lexbuf}
-      
-(*s Scanning documentation, at beginning of line *)
-
-and doc_bol = parse
-  | space* nl+
-      { Output.paragraph (); doc_bol lexbuf }
-  | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')?
-      { let eol, lex = strip_eol (lexeme lexbuf) in
-        let lev, s = sec_title lex in
-          Output.section lev (fun () -> ignore (doc (from_string s)));
-	  if eol then doc_bol lexbuf else doc lexbuf }
-  | space* '-'+
-      { let n = count_dashes (lexeme lexbuf) in
-	if n >= 4 then Output.rule () else Output.item n;
-        doc lexbuf }
-  | "<<" space*
-      { Output.start_verbatim (); verbatim lexbuf; doc_bol lexbuf }
-  | eof 
-      { true }
-  | _ 
-      { backtrack lexbuf; doc lexbuf }
-
-(*s Scanning documentation elsewhere *)
-
-and doc = parse
-  | nl
-      { Output.char '\n'; doc_bol lexbuf }
-  | "[[" nl
-      { formatted := true; Output.line_break (); Output.start_inline_coq ();
-	let eol = body_bol lexbuf in 
-	  Output.end_inline_coq (); formatted := false;
-	  if eol then doc_bol lexbuf else doc lexbuf}
-  | "["
-      { brackets := 1; 
-	Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ();
-	doc lexbuf }
-  | '*'* "*)" space* nl
-      { true }
-  | '*'* "*)"
-      { false }
-  | "$"
-      { Output.start_latex_math (); escaped_math_latex lexbuf; doc lexbuf }
-  | "$$"
-      { Output.char '$'; doc lexbuf }
-  | "%"
-      { escaped_latex lexbuf; doc lexbuf }
-  | "%%"
-      { Output.char '%'; doc lexbuf }
-  | "#"
-      { escaped_html lexbuf; doc lexbuf }
-  | "##"
-      { Output.char '#'; doc lexbuf }
-  | eof 
-      { false }
-  | _ 
-      { Output.char (lexeme_char lexbuf 0); doc lexbuf }
-
-(*s Various escapings *)
-
-and escaped_math_latex = parse
-  | "$" { Output.stop_latex_math () }
-  | eof { Output.stop_latex_math () }
-  | _   { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf }
-
-and escaped_latex = parse
-  | "%" { () }
-  | eof { () }
-  | _   { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf }
-
-and escaped_html = parse
-  | "#" { () }
-  | "&#"
-        { Output.html_char '&'; Output.html_char '#'; escaped_html lexbuf }
-  | "##"
-        { Output.html_char '#'; escaped_html lexbuf }
-  | eof { () }
-  | _   { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf }
-
-and verbatim = parse
-  | nl ">>" { Output.verbatim_char '\n'; Output.stop_verbatim () }
-  | eof { Output.stop_verbatim () }
-  | _ { Output.verbatim_char (lexeme_char lexbuf 0); verbatim lexbuf }
-
-(*s Coq, inside quotations *)
-
-and escaped_coq = parse
-  | "]"
-      { decr brackets; 
-	if !brackets > 0 then begin Output.char ']'; escaped_coq lexbuf end }
-  | "["
-      { incr brackets; Output.char '['; escaped_coq lexbuf }
-  | "(*"
-      { comment_level := 1; ignore (comment lexbuf); escaped_coq lexbuf }
-  | "*)"
-      { (* likely to be a syntax error: we escape *) backtrack lexbuf }
-  | eof
-      { () }
-  | token_brackets
-      { let s = lexeme lexbuf in
-	  symbol lexbuf s; escaped_coq lexbuf }
-  | (identifier '.')* identifier
-      { Output.ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf }
-  | _ 
-      { Output.char (lexeme_char lexbuf 0); escaped_coq lexbuf }
-
-(*s Coq "Comments" command. *)
-
-and comments = parse
-  | space_nl+ 
-      { Output.char ' '; comments lexbuf }
-  | '"' [^ '"']* '"' 
-      { let s = lexeme lexbuf in
-	let s = String.sub s 1 (String.length s - 2) in
-	ignore (doc (from_string s)); comments lexbuf }
-  | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+
-      { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf }
-  | "." (space_nl | eof)
-      { () }
-  | eof 
-      { () }
-  | _   
-      { Output.char (lexeme_char lexbuf 0); comments lexbuf }
-
-(*s Skip comments *)
-
-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 (
-	brackets := 1;
-	Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ());
-      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 }
-      
-and skip_to_dot = parse
-  | '.' space* nl { true }
-  | eof | '.' space+ { false }
-  | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf }
-  | _ { skip_to_dot lexbuf }
-
-and body_bol = parse
-  | space+
-      { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf }
-  | _ { backtrack lexbuf; Output.indentation 0; body lexbuf }
-
-and body = parse
-  | nl {Output.line_break(); body_bol lexbuf}
-  | nl+ space* "]]"
-      { if not !formatted then begin symbol lexbuf (lexeme lexbuf); body lexbuf end else true }
-  | eof { false }
-  | '.' space* nl | '.' space* eof 
-	{ Output.char '.'; Output.line_break(); 
-	  if not !formatted then true else body_bol lexbuf }      
-  | '.' space+ { Output.char '.'; Output.char ' '; 
-	  if not !formatted then false else body lexbuf }
-  | '"' { Output.char '"'; ignore(notation lexbuf); body lexbuf }
-  | "(*" { 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 }
-  | identifier 
-      { let s = lexeme lexbuf in 
-	  Output.ident s (lexeme_start lexbuf); 
-	  body lexbuf }
-  | token_no_brackets
-      { let s = lexeme lexbuf in
-	  symbol lexbuf s; body lexbuf }
-  | ".."
-      { Output.char '.'; Output.char '.';
-        body lexbuf }
-  | _ { let c = lexeme_char lexbuf 0 in 
-	  Output.char c; 
-          body lexbuf }
-
-and notation_bol = parse
-  | space+
-      { Output.indentation (fst (count_spaces (lexeme lexbuf))); notation lexbuf }
-  | _ { backtrack lexbuf; notation lexbuf }
-
-and notation = parse
-  | nl { Output.line_break(); notation_bol lexbuf }
-  | '"' { Output.char '"'}
-  | token
-      { let s = lexeme lexbuf in
-	  symbol lexbuf s; notation lexbuf }
-  | _ { let c = lexeme_char lexbuf 0 in 
-	  Output.char c; 
-          notation lexbuf }
-
-and skip_hide = parse
-  | eof | end_hide { () }
-  | _ { skip_hide lexbuf }
-
-(*s Reading token pretty-print *)
-
-and printing_token_body = parse
-  | "*)" nl? | eof 
-	{ let s = Buffer.contents token_buffer in 
-	  Buffer.clear token_buffer;
-	  s }
-  | _   { Buffer.add_string token_buffer (lexeme lexbuf); 
-	  printing_token_body lexbuf }
-
-(*s Applying the scanners to files *)
-
-{
-
-  let coq_file f m =
-    reset ();
-    Index.current_library := m;
-    Output.start_module ();
-    let c = open_in f in
-    let lb = from_channel c in
-    Output.start_coq (); coq_bol lb; Output.end_coq ();
-    close_in c
-
-}
-
diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml
new file mode 100644
index 00000000..c2a47308
--- /dev/null
+++ b/tools/coqdoc/tokens.ml
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Application of printing rules based on a dictionary specific to the
+   target language *)
+
+open Cdglobals
+
+(*s Dictionaries: trees annotated with string options, each node being a map
+    from chars to dictionaries (the subtrees). A trie, in other words.
+
+    (code copied from parsing/lexer.ml4 for the use of coqdoc, Apr 2010)
+*)
+
+module CharMap = Map.Make (struct type t = char let compare = compare end)
+
+type ttree = {
+  node : string option;
+  branch : ttree CharMap.t }
+
+let empty_ttree = { node = None; branch = CharMap.empty }
+
+let ttree_add ttree str translated =
+  let rec insert tt i =
+    if i == String.length str then
+      {node = Some translated; branch = tt.branch}
+    else
+      let c = str.[i] in
+      let br =
+        match try Some (CharMap.find c tt.branch) with Not_found -> None with
+          | Some tt' ->
+              CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch)
+          | None ->
+              let tt' = {node = None; branch = CharMap.empty} in
+              CharMap.add c (insert tt' (i + 1)) tt.branch
+      in
+      { node = tt.node; branch = br }
+  in
+  insert ttree 0
+
+(* Removes a string from a dictionary: returns an equal dictionary
+   if the word not present. *)
+let ttree_remove ttree str =
+  let rec remove tt i =
+    if i == String.length str then
+      {node = None; branch = tt.branch}
+    else
+      let c = str.[i] in
+      let br =
+        match try Some (CharMap.find c tt.branch) with Not_found -> None with
+          | Some tt' ->
+              CharMap.add c (remove tt' (i + 1)) (CharMap.remove c tt.branch)
+          | None -> tt.branch
+      in
+      { node = tt.node; branch = br }
+  in
+  remove ttree 0
+
+let ttree_descend ttree c = CharMap.find c ttree.branch
+
+let ttree_find ttree str =
+  let rec proc_rec tt i =
+    if i == String.length str then tt
+    else proc_rec (CharMap.find str.[i] tt.branch) (i+1)
+  in
+  proc_rec ttree 0
+
+(*s Parameters of the translation automaton *)
+
+type out_function = bool -> bool -> Index.index_entry option -> string -> unit
+
+let token_tree = ref (ref empty_ttree)
+let outfun = ref (fun _ _ _ _ -> failwith "outfun not initialized")
+
+(*s Translation automaton *)
+
+let buff = Buffer.create 4
+
+let flush_buffer was_symbolchar tag tok =
+  let hastr = String.length tok <> 0 in
+  if hastr then !outfun false was_symbolchar tag tok;
+  if Buffer.length buff <> 0 then
+    !outfun true (if hastr then not was_symbolchar else was_symbolchar)
+      tag (Buffer.contents buff);
+  Buffer.clear buff
+
+type sublexer_state =
+  | Neutral
+  | Buffering of bool * Index.index_entry option * string * ttree
+
+let translation_state = ref Neutral
+
+let buffer_char is_symbolchar ctag c =
+  let rec aux = function
+  | Neutral ->
+      restart_buffering ()
+  | Buffering (was_symbolchar,tag,translated,tt) ->
+      if tag <> ctag then
+	(* A strong tag comes from Coq; if different Coq tags *)
+	(* hence, we don't try to see the chars as part of a single token *)
+	let translated =
+	  match tt.node with
+	  | Some tok -> Buffer.clear buff; tok
+	  | None -> translated in
+	flush_buffer was_symbolchar tag translated;
+	restart_buffering ()
+      else
+	begin
+	(* If we change the category of characters (symbol vs ident) *)
+	(* we accept this as a possible token cut point and remember the *)
+	(* translated token up to that point *)
+	let translated =
+	  if is_symbolchar <> was_symbolchar then
+	    match tt.node with
+	    | Some tok -> Buffer.clear buff; tok
+	    | None -> translated
+	  else translated in
+	(* We try to make a significant token from the current *)
+	(* buffer and the new character *)
+	try
+	  let tt = ttree_descend tt c in
+	  Buffer.add_char buff c;
+	  Buffering (is_symbolchar,ctag,translated,tt)
+	with Not_found ->
+	(* No existing translation for the given set of chars *)
+	if is_symbolchar <> was_symbolchar then
+	  (* If we changed the category of character read, we accept it *)
+	  (* as a possible cut point and restart looking for a translation *)
+	  (flush_buffer was_symbolchar tag translated;
+	   restart_buffering ())
+	else
+	  (* If we did not change the category of character read, we do *)
+	  (* not want to cut arbitrarily in the middle of the sequence of *)
+	  (*  symbol characters or identifier characters *)
+	  (Buffer.add_char buff c;
+	   Buffering (is_symbolchar,tag,translated,empty_ttree))
+	end
+
+  and restart_buffering () =
+    let tt = try ttree_descend !(!token_tree) c with Not_found -> empty_ttree in
+    Buffer.add_char buff c;
+    Buffering (is_symbolchar,ctag,"",tt)
+
+  in
+  translation_state := aux !translation_state
+
+let output_tagged_ident_string s =
+  for i = 0 to String.length s - 1 do buffer_char false None s.[i] done
+
+let output_tagged_symbol_char tag c =
+  buffer_char true tag c
+
+let flush_sublexer () =
+  match !translation_state with
+  | Neutral -> ()
+  | Buffering (was_symbolchar,tag,translated,tt) ->
+      let translated =
+	match tt.node with
+	| Some tok -> Buffer.clear buff; tok
+	| None -> translated in
+      flush_buffer was_symbolchar tag translated;
+      translation_state := Neutral
+
+(* Translation not using the automaton *)
+let translate s =
+  try (ttree_find !(!token_tree) s).node with Not_found -> None
diff --git a/tools/coqdoc/tokens.mli b/tools/coqdoc/tokens.mli
new file mode 100644
index 00000000..a85e75c4
--- /dev/null
+++ b/tools/coqdoc/tokens.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Type of dictionaries *)
+
+type ttree
+
+val empty_ttree : ttree
+
+(* Add a string with some translation in dictionary *)
+val ttree_add : ttree -> string -> string -> ttree
+
+(* Remove a translation from a dictionary: returns an equal dictionary
+   if the word not present *)
+val ttree_remove : ttree -> string -> ttree
+
+(* Translate a string *)
+val translate : string -> string option
+
+(* Sublexer automaton *)
+
+(* The sublexer buffers the chars it receives; if after some time, it
+   recognizes that a sequence of chars has a translation in the
+   current dictionary, it replaces the buffer by the translation *)
+
+(* Received chars can come with a "tag" (usually made from
+   informations from the globalization file). A sequence of chars can
+   be considered a word only, if all chars have the same "tag". Rules
+   for cutting words are the following:
+
+   - in a sequence like "**" where * is in the dictionary but not **,
+     "**" is not translated; otherwise said, to be translated, a sequence
+     must not be surrounded by other symbol-like chars
+
+   - in a sequence like "<>_h*", where <>_h is in the dictionary, the
+     translation is done because the switch from a letter to a symbol char
+     is an acceptable cutting point
+
+   - in a sequence like "<>_ha", where <>_h is in the dictionary, the
+     translation is not done because it is considered that h and a are
+     not separable (however, if h and a have different tags, and h has
+     the same tags as <, > and _, the translation happens)
+
+   - in a sequence like "<>_ha", where <> but not <>_h is in the
+     dictionary, the translation is done for <> and _ha is considered
+     independently because  the switch from a symbol char to a letter
+     is considered to be an acceptable cutting point
+
+   - the longest-word rule applies: if both <> and <>_h are in the
+     dictionary, "<>_h" is one word and gets translated
+*)
+
+(* Warning: do not output anything on output channel inbetween a call
+   to [output_tagged_*] and [flush_sublexer]!! *)
+
+type out_function =
+  bool (* needs escape *) ->
+  bool (* it is a symbol, not a pure ident *) ->
+  Index.index_entry option (* the index type of the token if any *) ->
+  string -> unit
+
+(* This must be initialized before calling the sublexer *)
+val token_tree : ttree ref ref
+val outfun : out_function ref
+
+(* Process an ident part that might be a symbol part *)
+val output_tagged_ident_string : string -> unit
+
+(* Process a non-ident char (possibly equipped with a tag) *)
+val output_tagged_symbol_char : Index.index_entry option -> char -> unit
+
+(* Flush the buffered content of the lexer using [outfun] *)
+val flush_sublexer : unit -> unit
diff --git a/tools/coqwc.mll b/tools/coqwc.mll
index 81fe06cd..f3646a8a 100644
--- a/tools/coqwc.mll
+++ b/tools/coqwc.mll
@@ -9,12 +9,12 @@
 (* coqwc - counts the lines of spec, proof and comments in Coq sources
  * Copyright (C) 2003 Jean-Christophe Filliâtre *)
 
-(*i $Id: coqwc.mll 9691 2007-03-08 15:29:27Z msozeau $ i*)
+(*i $Id$ i*)
 
-(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. 
+(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source.
     It assumes the files to be lexically well-formed. *)
 
-(*i*){ 
+(*i*){
 open Printf
 open Lexing
 open Filename
@@ -40,8 +40,8 @@ let tplines = ref 0
 let tdlines = ref 0
 
 let update_totals () =
-  tslines := !tslines + !slines; 
-  tplines := !tplines + !plines; 
+  tslines := !tslines + !slines;
+  tplines := !tplines + !plines;
   tdlines := !tdlines + !dlines
 
 (*s The following booleans indicate whether we have seen spec, proof or
@@ -53,12 +53,12 @@ let seen_proof = ref false
 let seen_comment = ref false
 
 let newline () =
-  if !seen_spec then incr slines; 
-  if !seen_proof then incr plines; 
-  if !seen_comment then incr dlines; 
+  if !seen_spec then incr slines;
+  if !seen_proof then incr plines;
+  if !seen_comment then incr dlines;
   seen_spec := false; seen_proof := false; seen_comment := false
 
-let reset_counters () = 
+let reset_counters () =
   seen_spec := false; seen_proof := false; seen_comment := false;
   slines := 0; plines := 0; dlines := 0
 
@@ -83,7 +83,7 @@ let print_totals () = print_line !tslines !tplines !tdlines (Some "total")
 (*i*)}(*i*)
 
 (*s Shortcuts for regular expressions. The [rcs] regular expression
-    is used to skip the CVS infos possibly contained in some comments, 
+    is used to skip the CVS infos possibly contained in some comments,
     in order not to consider it as documentation. *)
 
 let space = [' ' '\t' '\r']
@@ -96,7 +96,7 @@ let rcs_keyword =
 let rcs = "\036" rcs_keyword [^ '$']* "\036"
 let stars = "(*" '*'* "*)"
 let dot = '.' (' ' | '\t' | '\n' | '\r' | eof)
-let proof_start =   
+let proof_start =
   "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next"
 let proof_end =
   ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.'
@@ -105,10 +105,10 @@ let proof_end =
 
 rule spec = parse
   | "(*"   { comment lexbuf; spec lexbuf }
-  | '"'    { let n = string lexbuf in slines := !slines + n; 
+  | '"'    { let n = string lexbuf in slines := !slines + n;
 	     seen_spec := true; spec lexbuf }
   | '\n'   { newline (); spec lexbuf }
-  | space+ | stars 
+  | space+ | stars
            { spec lexbuf }
   | proof_start space
            { seen_spec := true; spec_to_dot lexbuf; proof lexbuf }
@@ -118,7 +118,7 @@ rule spec = parse
            { seen_spec := true; definition lexbuf }
   | "Program"? "Fixpoint" space
   	   { seen_spec := true; definition lexbuf }
-  | character | _ 
+  | character | _
 	   { seen_spec := true; spec lexbuf }
   | eof    { () }
 
@@ -126,29 +126,29 @@ rule spec = parse
 
 and spec_to_dot = parse
   | "(*"   { comment lexbuf; spec_to_dot lexbuf }
-  | '"'    { let n = string lexbuf in slines := !slines + n; 
+  | '"'    { let n = string lexbuf in slines := !slines + n;
 	     seen_spec := true; spec_to_dot lexbuf }
   | '\n'   { newline (); spec_to_dot lexbuf }
   | dot    { () }
-  | space+ | stars 
+  | space+ | stars
            { spec_to_dot lexbuf }
-  | character | _ 
+  | character | _
 	   { seen_spec := true; spec_to_dot lexbuf }
   | eof    { () }
 
-(*s [definition] scans a definition; passes to [proof] is the body is 
+(*s [definition] scans a definition; passes to [proof] is the body is
     absent, and to [spec] otherwise *)
 
 and definition = parse
   | "(*"   { comment lexbuf; definition lexbuf }
-  | '"'    { let n = string lexbuf in slines := !slines + n; 
+  | '"'    { let n = string lexbuf in slines := !slines + n;
 	     seen_spec := true; definition lexbuf }
   | '\n'   { newline (); definition lexbuf }
   | ":="   { seen_spec := true; spec lexbuf }
   | dot    { proof lexbuf }
-  | space+ | stars 
+  | space+ | stars
            { definition lexbuf }
-  | character | _ 
+  | character | _
 	   { seen_spec := true; definition lexbuf }
   | eof    { () }
 
@@ -156,30 +156,30 @@ and definition = parse
 
 and proof = parse
   | "(*"   { comment lexbuf; proof lexbuf }
-  | '"'    { let n = string lexbuf in plines := !plines + n; 
+  | '"'    { let n = string lexbuf in plines := !plines + n;
 	     seen_proof := true; proof lexbuf }
-  | space+ | stars 
+  | space+ | stars
            { proof lexbuf }
   | '\n'   { newline (); proof lexbuf }
-  | "Proof" space* '.' 
+  | "Proof" space* '.'
            { seen_proof := true; proof lexbuf }
   | "Proof" space
            { proof_term lexbuf }
   | proof_end
            { seen_proof := true; spec lexbuf }
-  | character | _ 
+  | character | _
 	   { seen_proof := true; proof lexbuf }
   | eof    { () }
 
 and proof_term = parse
   | "(*"   { comment lexbuf; proof_term lexbuf }
-  | '"'    { let n = string lexbuf in plines := !plines + n; 
+  | '"'    { let n = string lexbuf in plines := !plines + n;
 	     seen_proof := true; proof_term lexbuf }
-  | space+ | stars 
+  | space+ | stars
            { proof_term lexbuf }
   | '\n'   { newline (); proof_term lexbuf }
   | dot    { spec lexbuf }
-  | character | _ 
+  | character | _
 	   { seen_proof := true; proof_term lexbuf }
   | eof    { () }
 
@@ -188,12 +188,12 @@ and proof_term = parse
 and comment = parse
   | "(*"   { comment lexbuf; comment lexbuf }
   | "*)"   { () }
-  | '"'    { let n = string lexbuf in dlines := !dlines + n; 
+  | '"'    { let n = string lexbuf in dlines := !dlines + n;
 	     seen_comment := true; comment lexbuf }
   | '\n'   { newline (); comment lexbuf }
   | space+ | stars
 	   { comment lexbuf }
-  | character | _ 
+  | character | _
 	   { seen_comment := true; comment lexbuf }
   | eof    { () }
 
@@ -212,9 +212,9 @@ and string = parse
     It stops whenever it encounters an empty line or any character outside
     a comment. In this last case, it correctly resets the lexer position
     on that character (decreasing [lex_curr_pos] by 1). *)
- 
+
 and read_header = parse
-  | "(*"   { skip_comment lexbuf; skip_until_nl lexbuf; 
+  | "(*"   { skip_comment lexbuf; skip_until_nl lexbuf;
 	     read_header lexbuf }
   | "\n"   { () }
   | space+ { read_header lexbuf }
@@ -250,9 +250,9 @@ let process_file f =
     print_file (Some f);
     update_totals ()
   with
-    | Sys_error "Is a directory" -> 
+    | Sys_error "Is a directory" ->
 	flush stdout; eprintf "coqwc: %s: Is a directory\n" f; flush stderr
-    | Sys_error s -> 
+    | Sys_error s ->
 	flush stdout; eprintf "coqwc: %s\n" s; flush stderr
 
 (*s Parsing of the command line. *)
@@ -269,9 +269,9 @@ let usage () =
 let rec parse = function
   | [] -> []
   | ("-h" | "-?" | "-help" | "--help") :: _ -> usage ()
-  | ("-s" | "--spec-only") :: args -> 
+  | ("-s" | "--spec-only") :: args ->
       proof_only := false; spec_only := true; parse args
-  | ("-r" | "--proof-only") :: args -> 
+  | ("-r" | "--proof-only") :: args ->
       spec_only := false; proof_only := true; parse args
   | ("-p" | "--percentage") :: args -> percentage := true; parse args
   | ("-e" | "--header") :: args -> skip_header := false; parse args
@@ -281,7 +281,7 @@ let rec parse = function
 
 let main () =
   let files = parse (List.tl (Array.to_list Sys.argv)) in
-  if not (!spec_only || !proof_only) then 
+  if not (!spec_only || !proof_only) then
     printf "     spec    proof comments\n";
   match files with
     | [] -> process_channel stdin; print_file None
diff --git a/tools/gallina.ml b/tools/gallina.ml
index a2c05c6d..8ba9ae10 100644
--- a/tools/gallina.ml
+++ b/tools/gallina.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gallina.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id$ *)
 
 open Gallina_lexer
 
@@ -16,29 +16,29 @@ let option_moins = ref false
 
 let option_stdout = ref false
 
-let traite_fichier f = 
-  try 
-    let chan_in = open_in (f^".v") in 
+let traite_fichier f =
+  try
+    let chan_in = open_in (f^".v") in
     let buf = Lexing.from_channel chan_in in
     if not !option_stdout then chan_out := open_out (f ^ ".g");
-    try 
+    try
       while true do Gallina_lexer.action buf done
-    with Fin_fichier -> begin 
+    with Fin_fichier -> begin
       flush !chan_out;
       close_in chan_in;
       if not !option_stdout then close_out !chan_out
     end
-  with Sys_error _ -> 
-    () 
+  with Sys_error _ ->
+    ()
 
 let traite_stdin () =
   try
     let buf = Lexing.from_channel stdin in
-    try 
+    try
       while true do Gallina_lexer.action buf done
-    with Fin_fichier -> 
+    with Fin_fichier ->
       flush !chan_out
-  with Sys_error _ -> 
+  with Sys_error _ ->
     ()
 
 let gallina () =
@@ -52,7 +52,7 @@ let gallina () =
     | "-" -> option_moins := true
     | "-stdout" -> option_stdout := true
     | "-nocomments" -> comments := false
-    | f -> 
+    | f ->
 	if Filename.check_suffix f ".v" then
        	  vfiles := (Filename.chop_suffix f ".v") :: !vfiles
   in
diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll
index 7eaec2a8..6d35d839 100644
--- a/tools/gallina_lexer.mll
+++ b/tools/gallina_lexer.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gallina_lexer.mll 11301 2008-08-04 19:41:18Z herbelin $ *)
+(* $Id$ *)
 
 {
  open Lexing
@@ -17,7 +17,7 @@
  let cRcpt = ref 0
  let comments = ref true
  let print s = output_string !chan_out s
- 
+
  exception Fin_fichier
 
 }
@@ -26,17 +26,17 @@ let space = [' ' '\t' '\n' '\r']
 let enddot = '.' (' ' | '\t' | '\n' | '\r' | eof)
 
 rule action = parse
-  | "Theorem" space { print "Theorem "; body lexbuf; 
+  | "Theorem" space { print "Theorem "; body lexbuf;
   	              cRcpt := 1; action lexbuf }
-  | "Lemma" space   { print "Lemma ";   body lexbuf; 
+  | "Lemma" space   { print "Lemma ";   body lexbuf;
       	       	      cRcpt := 1; action lexbuf }
-  | "Fact" space    { print "Fact ";   body lexbuf; 
+  | "Fact" space    { print "Fact ";   body lexbuf;
       	       	      cRcpt := 1; action lexbuf }
-  | "Remark" space  { print "Remark ";  body lexbuf; 
+  | "Remark" space  { print "Remark ";  body lexbuf;
       	       	      cRcpt := 1; action lexbuf }
-  | "Goal" space    { print "Goal ";    body lexbuf; 
+  | "Goal" space    { print "Goal ";    body lexbuf;
       	       	      cRcpt := 1; action lexbuf }
-  | "Correctness" space { print "Correctness "; body_pgm lexbuf; 
+  | "Correctness" space { print "Correctness "; body_pgm lexbuf;
       	       	          cRcpt := 1; action lexbuf }
   | "Definition" space  { print "Definition "; body_def lexbuf;
 			  cRcpt := 1; action lexbuf }
@@ -55,7 +55,7 @@ rule action = parse
   | _         { print (Lexing.lexeme lexbuf); cRcpt := 0; action lexbuf }
 
 and comment = parse
-  | "(*"  { (if !comments then print "(*"); 
+  | "(*"  { (if !comments then print "(*");
       	    comment_depth := succ !comment_depth; comment lexbuf }
   | "*)"  { (if !comments then print "*)");
       	    comment_depth := pred !comment_depth;
@@ -63,15 +63,15 @@ and comment = parse
   | "*)" [' ''\t']*'\n' { (if !comments then print (Lexing.lexeme lexbuf));
       			  comment_depth := pred !comment_depth;
 			  if !comment_depth > 0 then comment lexbuf }
-  | eof   { raise Fin_fichier } 
-  | _     { (if !comments then print (Lexing.lexeme lexbuf)); 
+  | eof   { raise Fin_fichier }
+  | _     { (if !comments then print (Lexing.lexeme lexbuf));
 	    comment lexbuf }
 
 and skip_comment = parse
   | "(*"  { comment_depth := succ !comment_depth; skip_comment lexbuf }
   | "*)"  { comment_depth := pred !comment_depth;
             if !comment_depth > 0 then skip_comment lexbuf }
-  | eof   { raise Fin_fichier } 
+  | eof   { raise Fin_fichier }
   | _     { skip_comment lexbuf }
 
 and body_def = parse
@@ -83,14 +83,14 @@ and body = parse
   | ":="   { print ".\n"; skip_proof lexbuf }
   | "(*"   { print "(*"; comment_depth := 1;
       	     comment lexbuf; body lexbuf }
-  | eof    { raise Fin_fichier } 
+  | eof    { raise Fin_fichier }
   | _      { print (Lexing.lexeme lexbuf); body lexbuf }
 
 and body_pgm = parse
   | enddot { print ".\n"; skip_proof lexbuf }
   | "(*"   { print "(*"; comment_depth := 1;
       	     comment lexbuf; body_pgm lexbuf }
-  | eof    { raise Fin_fichier } 
+  | eof    { raise Fin_fichier }
   | _      { print (Lexing.lexeme lexbuf); body_pgm lexbuf }
 
 and skip_until_point = parse
@@ -98,13 +98,13 @@ and skip_until_point = parse
   | enddot   { end_of_line lexbuf }
   | "(*"     { comment_depth := 1;
       	       skip_comment lexbuf; skip_until_point lexbuf }
-  | eof      { raise Fin_fichier } 
+  | eof      { raise Fin_fichier }
   | _        { skip_until_point lexbuf }
 
 and end_of_line = parse
   | [' ' '\t' ]*	{ end_of_line lexbuf }
   | '\n'		{ () }
-  | eof   	     	{ raise Fin_fichier } 
+  | eof   	     	{ raise Fin_fichier }
   | _	  		{ print (Lexing.lexeme lexbuf) }
 
 and skip_proof = parse
@@ -124,5 +124,5 @@ and skip_proof = parse
   | "Proof" [' ' '\t']* '.'  { skip_proof lexbuf }
   | "(*"    { comment_depth := 1;
       	      skip_comment lexbuf; skip_proof lexbuf }
-  | eof     { raise Fin_fichier } 
+  | eof     { raise Fin_fichier }
   | _       { skip_proof lexbuf }
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index 82709db4..0e66c43c 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/toplevel/auto_ind_decl.ml
@@ -6,7 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto_ind_decl.ml 11671 2008-12-12 12:43:03Z herbelin $ i*)
+(*i $Id$ i*)
+
+(* This file is about the automatic generation of schemes about
+   decidable equality, created by Vincent Siles, Oct 2007 *)
 
 open Tacmach
 open Util
@@ -28,9 +31,10 @@ open Tactics
 open Tacticals
 open Ind_tables
 
-(* boolean equality *)
+(**********************************************************************)
+(* Generic synthesis of boolean equality *)
 
-let quick_chop n l = 
+let quick_chop n l =
   let rec kick_last = function
     | t::[] -> []
     | t::q -> t::(kick_last q)
@@ -39,21 +43,21 @@ and aux = function
     | (0,l') -> l'
     | (n,h::t) -> aux (n-1,t)
     | _ -> failwith "quick_chop"
-  in 
+  in
   if n > (List.length l) then failwith "quick_chop args"
   else kick_last (aux (n,l) )
 
-let rec deconstruct_type t = 
+let rec deconstruct_type t =
   let l,r = decompose_prod t in
     (List.map (fun (_,b) -> b) (List.rev l))@[r]
 
-let subst_in_constr (_,subst,(ind,const)) = 
-  let ind' = (subst_kn subst (fst ind)),(snd ind)
-  and const' = subst_mps subst const in
-    ind',const'
-
-exception EqNotFound of string 
+exception EqNotFound of inductive * inductive
 exception EqUnknown of string
+exception UndefinedCst of string
+exception InductiveWithProduct
+exception InductiveWithSort
+exception ParameterWithoutEquality of constant
+exception NonSingletonProp of inductive
 
 let dl = dummy_loc
 
@@ -62,70 +66,77 @@ let bb = constr_of_global Coqlib.glob_bool
 
 let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop
 
-let andb_true_intro = fun _ -> 
-    (Coqlib.build_bool_type()).Coqlib.andb_true_intro 
+let andb_true_intro = fun _ ->
+    (Coqlib.build_bool_type()).Coqlib.andb_true_intro
 
-let tt = constr_of_global Coqlib.glob_true 
+let tt = constr_of_global Coqlib.glob_true
 
 let ff = constr_of_global Coqlib.glob_false
 
-let eq = constr_of_global Coqlib.glob_eq 
+let eq = constr_of_global Coqlib.glob_eq
 
-let sumbool = Coqlib.build_coq_sumbool 
+let sumbool = Coqlib.build_coq_sumbool
 
-let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb 
+let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb
 
 (* reconstruct the inductive with the correct deBruijn indexes *)
-let mkFullInd ind n = 
+let mkFullInd ind n =
   let mib = Global.lookup_mind (fst ind) in
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
   (* params context divided *)
-  let lnonparrec,lnamesparrec = 
+  let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  if nparrec > 0 
+  if nparrec > 0
     then mkApp (mkInd ind,
       Array.of_list(extended_rel_list (nparrec+n) lnamesparrec))
     else mkInd ind
 
-let make_eq_scheme sp =
+let check_bool_is_defined () =
+  try let _ = Global.type_of_global Coqlib.glob_bool in ()
+  with _ -> raise (UndefinedCst "bool")
+
+let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
+
+let build_beq_scheme kn =
+  check_bool_is_defined ();
   (* fetching global env *)
   let env = Global.env() in
   (* fetching the mutual inductive body *)
-  let mib = Global.lookup_mind sp in
+  let mib = Global.lookup_mind kn in
   (* number of inductives in the mutual *)
   let nb_ind = Array.length mib.mind_packets in
   (* number of params in the type *)
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
   (* params context divided *)
-  let lnonparrec,lnamesparrec = 
+  let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
   (* predef coq's boolean type *)
   (* rec name *)
   let rec_name i =(string_of_id (Array.get mib.mind_packets i).mind_typename)^
-                    "_eqrec" 
+                    "_eqrec"
   in
   (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *)
   let create_input c =
-    let myArrow u v = mkArrow u (lift 1 v) 
+    let myArrow u v = mkArrow u (lift 1 v)
     and eqName = function
         | Name s -> id_of_string ("eq_"^(string_of_id s))
-        | Anonymous -> id_of_string "eq_A" 
+        | Anonymous -> id_of_string "eq_A"
     in
     let ext_rel_list = extended_rel_list 0 lnamesparrec in
       let lift_cnt = ref 0 in
-      let eqs_typ = List.map (fun aa -> 
-                                let a = lift !lift_cnt aa in 
-                                  incr lift_cnt; 
-                                  myArrow a (myArrow a bb) 
+      let eqs_typ = List.map (fun aa ->
+                                let a = lift !lift_cnt aa in
+                                  incr lift_cnt;
+                                  myArrow a (myArrow a bb)
                              ) ext_rel_list in
 
         let eq_input = List.fold_left2
           ( fun a b (n,_,_) -> (* 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 n) b a )
                 c (List.rev eqs_typ) lnamesparrec
        in
         List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *)
@@ -134,181 +145,170 @@ let make_eq_scheme sp =
                 (match n with Name s -> s | Anonymous ->  id_of_string "A")
                 t  a) eq_input lnamesparrec
  in
- let make_one_eq cur = 
-  let ind = sp,cur in 
+ let make_one_eq cur =
+  let ind = kn,cur in
   (* current inductive we are working on *)
-  let cur_packet = mib.mind_packets.(snd ind) in 
+  let cur_packet = mib.mind_packets.(snd ind) in
   (* Inductive toto : [rettyp] := *)
   let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in
-  (* split rettyp in a list without the non rec params and the last -> 
+  (* split rettyp in a list without the non rec params and the last ->
   e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *)
   let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in
     (* give a type A, this function tries to find the equality on A declared
        previously *)
     (*  nlist = the number of args (A , B , ... )
         eqA   = the deBruijn index of the first eq param
-        ndx   = how much to translate due to the 2nd Case 
+        ndx   = how much to translate due to the 2nd Case
     *)
-    let compute_A_equality rel_list nlist eqA ndx t = 
+    let compute_A_equality rel_list nlist eqA ndx t =
       let lifti = ndx in
-      let rec aux c a = match c with
+      let rec aux c =
+	let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in
+	match kind_of_term c with
         | Rel x -> mkRel (x-nlist+ndx)
-        | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) 
-        | Cast (x,_,_) -> aux (kind_of_term x) a 
-        | App (x,newa) -> aux (kind_of_term x) newa 
-        | Ind (sp',i) -> if sp=sp' then mkRel(eqA-nlist-i+nb_ind-1)
-                        else ( try 
-                          let eq = find_eq_scheme (sp',i) 
-                          and eqa = Array.map 
-                                (fun x -> aux (kind_of_term x) [||] ) a 
-                          in
-                            let args = Array.append 
-                                (Array.map (fun x->lift lifti x) a) eqa 
-                            in if args = [||] then eq 
-                               else mkApp (eq,Array.append 
+        | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x)))
+        | Cast (x,_,_) -> aux (applist (x,a))
+        | App _ -> assert false
+        | Ind (kn',i as ind') -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1)
+                        else ( try
+			  let a = Array.of_list a in
+                          let eq = mkConst (find_scheme (!beq_scheme_kind_aux()) (kn',i))
+                          and eqa = Array.map aux a
+			  in
+                            let args = Array.append
+                                (Array.map (fun x->lift lifti x) a) eqa
+                            in if args = [||] then eq
+                               else mkApp (eq,Array.append
                                       (Array.map (fun x->lift lifti x) a) eqa)
-                         with Not_found -> raise(EqNotFound (string_of_kn sp'))
+                         with Not_found -> raise(EqNotFound (ind',ind))
                         )
-        | Sort _  -> raise (EqUnknown "Sort" )
-        | Prod _ -> raise (EqUnknown "Prod" )
-        | Lambda _-> raise (EqUnknown "Lambda") 
+        | Sort _  -> raise InductiveWithSort
+        | Prod _ -> raise InductiveWithProduct
+        | Lambda _-> raise (EqUnknown "Lambda")
         | LetIn _ -> raise (EqUnknown "LetIn")
-        | Const kn -> let mp,dir,lbl= repr_con kn in 
-                  mkConst (make_con mp dir (
-                                mk_label ("eq_"^(string_of_label lbl))))  
+        | Const kn ->
+	    (match Environ.constant_opt_value env kn with
+	      | None -> raise (ParameterWithoutEquality kn)
+	      | Some c -> aux (applist (c,a)))
         | Construct _ -> raise (EqUnknown "Construct")
         | Case _ -> raise (EqUnknown "Case")
         | CoFix _ -> raise (EqUnknown "CoFix")
-        | Fix _   -> raise (EqUnknown "Fix") 
-        | Meta _  -> raise (EqUnknown "Meta") 
+        | Fix _   -> raise (EqUnknown "Fix")
+        | Meta _  -> raise (EqUnknown "Meta")
         | Evar _  -> raise (EqUnknown "Evar")
     in
-      aux t [||]
+      aux t
   in
   (* construct the predicate for the Case part*)
-  let do_predicate rel_list n = 
-     List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) 
+  let do_predicate rel_list n =
+     List.fold_left (fun a b -> mkLambda(Anonymous,b,a))
       (mkLambda (Anonymous,
                  mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1),
-                 bb)) 
-      (List.rev rettyp_l) in  
+                 bb))
+      (List.rev rettyp_l) in
   (* make_one_eq *)
-  (* do the [| C1 ... =>  match Y with ... end 
-               ... 
+  (* do the [| C1 ... =>  match Y with ... end
+               ...
                Cn => match Y with ... end |]  part *)
     let ci = make_case_info env ind MatchStyle in
     let constrs n = get_constructors env (make_ind_family (ind,
       extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in
     let constrsi = constrs (3+nparrec) in
     let n = Array.length constrsi in
-    let ar = Array.create n ff in 
+    let ar = Array.create n ff in
 	for i=0 to n-1 do
 	  let nb_cstr_args = List.length constrsi.(i).cs_args in
 	  let ar2 = Array.create n ff in
           let constrsj = constrs (3+nparrec+nb_cstr_args) in
 	    for j=0 to n-1 do
-	      if (i=j) then 
+	      if (i=j) then
 		ar2.(j) <- let cc = (match nb_cstr_args with
                     | 0 -> tt
-                    | _ -> let eqs = Array.make nb_cstr_args tt in  
+                    | _ -> let eqs = Array.make nb_cstr_args tt in
                       for ndx = 0 to nb_cstr_args-1 do
                         let _,_,cc = List.nth constrsi.(i).cs_args ndx in
                           let eqA = compute_A_equality rel_list
                                           nparrec
                                           (nparrec+3+2*nb_cstr_args)
                                           (nb_cstr_args+ndx+1)
-                                          (kind_of_term cc)
-                          in 
-                          Array.set eqs ndx 
+                                          cc
+                          in
+                          Array.set eqs ndx
                               (mkApp (eqA,
                                 [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|]
                               ))
-                      done; 
-                      Array.fold_left 
-                          (fun a b -> mkApp (andb(),[|b;a|])) 
-                          (eqs.(0)) 
+                      done;
+                      Array.fold_left
+                          (fun a b -> mkApp (andb(),[|b;a|]))
+                          (eqs.(0))
                           (Array.sub eqs 1 (nb_cstr_args - 1))
                   )
    		  in
 		    (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc
-                    (constrsj.(j).cs_args) 
-		) 
+                    (constrsj.(j).cs_args)
+		)
 	      else ar2.(j) <- (List.fold_left (fun a (p,q,r) ->
 			mkLambda (p,r,a)) 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 (p,q,r) -> mkLambda (p,r,a))
 			(mkCase (ci,do_predicate rel_list nb_cstr_args,
 				  mkVar (id_of_string "Y") ,ar2))
-			 (constrsi.(i).cs_args)) 
+			 (constrsi.(i).cs_args))
 	done;
         mkNamedLambda (id_of_string "X") (mkFullInd ind (nb_ind-1+1))  (
           mkNamedLambda (id_of_string "Y") (mkFullInd ind (nb_ind-1+2))  (
- 	    mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar)))  
-    in (* make_eq_scheme *)
-    try
-    let names = Array.make nb_ind Anonymous and 
-        types = Array.make nb_ind mkSet and 
-        cores = Array.make nb_ind mkSet and
-        res   = Array.make nb_ind mkSet in 
+ 	    mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar)))
+    in (* build_beq_scheme *)
+    let names = Array.make nb_ind Anonymous and
+        types = Array.make nb_ind mkSet and
+        cores = Array.make nb_ind mkSet in
     for i=0 to (nb_ind-1) do
         names.(i) <- Name (id_of_string (rec_name i));
-    	types.(i) <- mkArrow (mkFullInd (sp,i) 0) 
-                     (mkArrow (mkFullInd (sp,i) 1) bb);
+	types.(i) <- mkArrow (mkFullInd (kn,i) 0)
+                     (mkArrow (mkFullInd (kn,i) 1) bb);
         cores.(i) <- make_one_eq i
-    done; 
-    if (string_of_mp (modpath sp ))="Coq.Init.Logic" 
-    then print_string "Logic time, do nothing.\n"
-    else (
-      for i=0 to (nb_ind-1) do 
-      let cpack = Array.get mib.mind_packets i in
-      if check_eq_scheme (sp,i)
-      then  message ("Boolean equality is already defined on "^
-             (string_of_id cpack.mind_typename)^".") 
-      else (
+    done;
+    Array.init nb_ind (fun i ->
+      let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in
+	if not (List.mem InSet kelim) then
+	  raise (NonSingletonProp (kn,i));
         let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in
-          res.(i) <- create_input fix
-        )
-        done;
-      );
-      res
-      with 
-        | EqUnknown s -> error ("Type unexpected ("^s^
-                  ") during boolean eq computation, please report.")
-        | EqNotFound s  -> error ("Boolean equality on "^s^
-          " is missing, equality will not be defined.")
-        | _ -> error ("Unknown exception during boolean equality creation,"^
-                      " the equality will not be defined.")
+        create_input fix)
+
+let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme
+
+let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind
 
 (* This function tryies to get the [inductive] between a constr
   the constr should be Ind i or App(Ind i,[|args|])
 *)
-let destruct_ind c = 
+let destruct_ind c =
     try let u,v =  destApp c in
           let indc = destInd u in
             indc,v
     with _-> let indc = destInd c in
             indc,[||]
 
-(* 
-  In the followind, avoid is the list of names to avoid. 
+(*
+  In the following, avoid is the list of names to avoid.
   If the args of the Inductive type are A1 ... An
-  then avoid should be 
+  then avoid should be
  [| lb_An ... lb _A1  (resp. bl_An ... bl_A1)
     eq_An .... eq_A1 An ... A1 |]
 so from Ai we can find the the correct eq_Ai bl_ai or lb_ai
 *)
 (* used in the leib -> bool side*)
-let do_replace_lb aavoid narg gls p q = 
+let do_replace_lb lb_scheme_key aavoid narg gls p q =
   let avoid = Array.of_list aavoid in
-  let do_arg v offset = 
-  try   
+  let do_arg v offset =
+  try
     let x = narg*offset in
-    let s = destVar v in 
+    let s = destVar v in
     let n = Array.length avoid in
-    let rec find i = 
-      if avoid.(n-i) = s then avoid.(n-i-x) 
-      else (if i<n then find (i+1) 
+    let rec find i =
+      if avoid.(n-i) = s then avoid.(n-i-x)
+      else (if i<n then find (i+1)
             else error ("Var "^(string_of_id s)^" seems unknown.")
       )
     in mkVar (find 1)
@@ -317,47 +317,46 @@ let do_replace_lb aavoid narg gls p q =
       (
         let mp,dir,lbl = repr_con (destConst v) in
           mkConst (make_con mp dir (mk_label (
-          if offset=1 then ("eq_"^(string_of_label lbl)) 
+          if offset=1 then ("eq_"^(string_of_label lbl))
                        else ((string_of_label lbl)^"_lb")
         )))
       )
   in
   let type_of_pq = pf_type_of gls p in
     let u,v = destruct_ind type_of_pq
-    in let lb_type_of_p = 
-        try find_lb_proof u 
-        with Not_found -> 
+    in let lb_type_of_p =
+        try mkConst (find_scheme lb_scheme_key u)
+        with Not_found ->
           (* spiwack: the format of this error message should probably
 	              be improved. *)
-          let err_msg = msg_with Format.str_formatter 
+          let err_msg = msg_with Format.str_formatter
 	                              (str "Leibniz->boolean:" ++
-                                       str "You have to declare the" ++ 
+                                       str "You have to declare the" ++
 				       str "decidability over " ++
-				       Printer.pr_constr type_of_pq ++ 
+				       Printer.pr_constr type_of_pq ++
 				       str " first.");
 	                Format.flush_str_formatter ()
           in
           error err_msg
-    in let lb_args = Array.append (Array.append 
+    in let lb_args = Array.append (Array.append
                           (Array.map (fun x -> x) v)
                           (Array.map (fun x -> do_arg x 1) v))
                           (Array.map (fun x -> do_arg x 2) v)
-        in let app =  if lb_args = [||] 
-                       then lb_type_of_p else mkApp (lb_type_of_p,lb_args) 
+        in let app =  if lb_args = [||]
+                       then lb_type_of_p else mkApp (lb_type_of_p,lb_args)
             in [Equality.replace p q ; apply app ; Auto.default_auto]
 
-
 (* used in the bool -> leib side *)
-let do_replace_bl ind gls aavoid narg lft rgt = 
-  let avoid = Array.of_list aavoid in 
-  let do_arg v offset = 
-  try   
+let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
+  let avoid = Array.of_list aavoid in
+  let do_arg v offset =
+  try
     let x = narg*offset in
-    let s = destVar v in 
+    let s = destVar v in
     let n = Array.length avoid in
-    let rec find i = 
-      if avoid.(n-i) = s then avoid.(n-i-x) 
-      else (if i<n then find (i+1) 
+    let rec find i =
+      if avoid.(n-i) = s then avoid.(n-i-x)
+      else (if i<n then find (i+1)
             else error ("Var "^(string_of_id s)^" seems unknown.")
       )
     in mkVar (find 1)
@@ -366,60 +365,60 @@ let do_replace_bl ind gls aavoid narg lft rgt =
       (
         let mp,dir,lbl = repr_con (destConst v) in
           mkConst (make_con mp dir (mk_label (
-          if offset=1 then ("eq_"^(string_of_label lbl)) 
+          if offset=1 then ("eq_"^(string_of_label lbl))
                        else ((string_of_label lbl)^"_bl")
         )))
       )
   in
 
-  let rec aux l1 l2 = 
+  let rec aux l1 l2 =
     match (l1,l2) with
     | (t1::q1,t2::q2) -> let tt1 = pf_type_of gls t1 in
         if t1=t2 then aux q1 q2
         else (
-          let u,v = try  destruct_ind tt1  
+          let u,v = try  destruct_ind tt1
           (* trick so that the good sequence is returned*)
                 with _ -> ind,[||]
-          in if u = ind 
+          in if u = ind
              then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2)
              else (
-               let bl_t1 = 
-               try find_bl_proof u 
-               with Not_found -> 
+               let bl_t1 =
+               try mkConst (find_scheme bl_scheme_key u)
+               with Not_found ->
 		 (* spiwack: the format of this error message should probably
 	                     be improved. *)
-		 let err_msg = msg_with Format.str_formatter 
+		 let err_msg = msg_with Format.str_formatter
 	                                (str "boolean->Leibniz:" ++
-                                         str "You have to declare the" ++ 
+                                         str "You have to declare the" ++
 			   	         str "decidability over " ++
-				         Printer.pr_constr tt1 ++ 
+				         Printer.pr_constr tt1 ++
 				         str " first.");
  	                       Format.flush_str_formatter ()
 		 in
 		 error err_msg
-               in let bl_args = 
-                        Array.append (Array.append 
+               in let bl_args =
+                        Array.append (Array.append
                           (Array.map (fun x -> x) v)
                           (Array.map (fun x -> do_arg x 1) v))
                           (Array.map (fun x -> do_arg x 2) v )
-                in 
-                let app =  if bl_args = [||] 
-                           then bl_t1 else mkApp (bl_t1,bl_args) 
-                in 
-                  (Equality.replace_by t1 t2 
+                in
+                let app =  if bl_args = [||]
+                           then bl_t1 else mkApp (bl_t1,bl_args)
+                in
+                  (Equality.replace_by t1 t2
                     (tclTHEN (apply app) (Auto.default_auto)))::(aux q1 q2)
               )
         )
     | ([],[]) -> []
     | _ -> error "Both side of the equality must have the same arity."
   in
-  let (ind1,ca1) = try destApp lft with 
+  let (ind1,ca1) = try destApp lft with
     _ -> error "replace failed."
   and (ind2,ca2) = try destApp rgt with
     _ -> error "replace failed."
   in
   let (sp1,i1) = try destInd ind1 with
-    _ -> (try fst (destConstruct ind1) with _ -> 
+    _ -> (try fst (destConstruct ind1) with _ ->
                 error "The expected type is an inductive one.")
   and (sp2,i2) = try destInd ind2 with
     _ -> (try fst (destConstruct ind2)  with _ ->
@@ -427,14 +426,14 @@ let do_replace_bl ind gls aavoid narg lft rgt =
   in
     if (sp1 <> sp2) || (i1 <> i2)
       then (error "Eq should be on the same type")
-      else (aux (Array.to_list ca1) (Array.to_list ca2)) 
+      else (aux (Array.to_list ca1) (Array.to_list ca2))
 
-(* 
+(*
   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 (n,_,t) -> let s' =
+      match n with
         Name s -> string_of_id s
       | Anonymous -> "A" in
           (id_of_string s',id_of_string ("eq_"^s'),
@@ -445,72 +444,73 @@ let list_id l = List.fold_left ( fun a (n,_,t) -> let s' =
 (*
   build the right eq_I A B.. N eq_A .. eq_N
 *)
-let eqI ind l = 
+let eqI ind l =
   let list_id = list_id l in
   let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@
                            (List.map (fun (_,seq,_,_)-> mkVar seq) list_id ))
-  and  e = try find_eq_scheme ind  with 
-    Not_found -> error  
-        ("The boolean equality on "^(string_of_kn (fst ind))^" is needed.");
+  and  e = try mkConst (find_scheme beq_scheme_kind ind) with
+    Not_found -> error
+        ("The boolean equality on "^(string_of_mind (fst ind))^" is needed.");
   in (if eA = [||] then e else mkApp(e,eA))
 
-let compute_bl_goal ind lnamesparrec nparrec = 
+(**********************************************************************)
+(* Boolean->Leibniz *)
+
+let compute_bl_goal ind lnamesparrec nparrec =
   let eqI = eqI ind lnamesparrec in
-  let list_id = list_id lnamesparrec in 
+  let list_id = list_id lnamesparrec in
   let create_input c =
     let x = id_of_string "x" and
         y = id_of_string "y" in
       let bl_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
-              mkArrow 
+              mkArrow
                ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
                ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
           ))
-        ) list_id in      
+        ) list_id in
       let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
         mkNamedProd sbl b a
-      ) c (List.rev list_id) (List.rev bl_typ) in 
+      ) c (List.rev list_id) (List.rev bl_typ) in
       let eqs_typ = List.map (fun (s,_,_,_) ->
           mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
           ) list_id in
       let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
         mkNamedProd seq b a
-      ) bl_input (List.rev list_id) (List.rev eqs_typ) in 
+      ) 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
-    in 
-      let n = id_of_string "n" and
-          m = id_of_string "m" in
+    in
+      let n = id_of_string "x" and
+          m = id_of_string "y" in
      create_input (
         mkNamedProd n (mkFullInd ind nparrec) (
           mkNamedProd m (mkFullInd ind (nparrec+1)) (
-            mkArrow 
+            mkArrow
               (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|]))
               (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|]))
         )))
-  
-let compute_bl_tact ind lnamesparrec nparrec  = 
+
+let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig =
   let list_id = list_id lnamesparrec in
   let avoid = ref [] in
-    let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in
-      let first_intros = 
+      let first_intros =
         ( List.map (fun (s,_,_,_) -> s ) list_id ) @
         ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @
-        ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) 
-      in 
+        ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id )
+      in
       let fresh_first_intros = List.map ( fun s ->
         let fresh = fresh_id (!avoid) s gsig in
         avoid := fresh::(!avoid); fresh ) first_intros in
-      let freshn = fresh_id (!avoid) (id_of_string "n") gsig in
+      let freshn = fresh_id (!avoid) (id_of_string "x") gsig in
       let freshm = avoid := freshn::(!avoid);
-            fresh_id (!avoid) (id_of_string "m") gsig in
+            fresh_id (!avoid) (id_of_string "y") gsig in
       let freshz = avoid := freshm::(!avoid);
             fresh_id (!avoid) (id_of_string "Z") gsig in
   (* try with *)
       avoid := freshz::(!avoid);
-      Pfedit.by (
       tclTHENSEQ [ intros_using fresh_first_intros;
                      intro_using freshn ;
                      new_induct false [ (Tacexpr.ElimOnConstr ((mkVar freshn),
@@ -526,21 +526,20 @@ let compute_bl_tact ind lnamesparrec nparrec  =
 		                None;
                      intro_using freshz;
                      intros;
-                     tclTRY ( 
+                     tclTRY (
                       tclORELSE reflexivity (Equality.discr_tac false None)
                      );
-                     simpl_in_hyp
-		       ((Rawterm.all_occurrences_expr,freshz),InHyp);
+                     simpl_in_hyp (freshz,InHyp);
 (*
 repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
 *)
                     tclREPEAT (
                       tclTHENSEQ [
-                         apply_in false false freshz [(Evd.empty,andb_prop()),Rawterm.NoBindings] None;
+                         simple_apply_in freshz (andb_prop());
                          fun gl ->
-                           let fresht = fresh_id (!avoid) (id_of_string "Z") gsig 
+                           let fresht = fresh_id (!avoid) (id_of_string "Z") gsig
                            in
-                            avoid := fresht::(!avoid); 
+                            avoid := fresht::(!avoid);
                             (new_destruct false [Tacexpr.ElimOnConstr
                                       ((mkVar freshz,Rawterm.NoBindings))]
                                   None
@@ -549,30 +548,53 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
                                     dl,Genarg.IntroIdentifier freshz]])) None) gl
                         ]);
 (*
-  Ci a1 ... an = Ci b1 ... bn 
+  Ci a1 ... an = Ci b1 ... bn
  replace bi with ai; auto || replace bi with ai by  apply typeofbi_prod ; auto
 *)
                     fun gls-> let gl = (gls.Evd.it).Evd.evar_concl in
                       match (kind_of_term gl) with
-                      | App (c,ca) -> ( 
+                      | App (c,ca) -> (
                         match (kind_of_term c) with
-                        | Ind (i1,i2) -> 
-                            if(string_of_label (label i1) = "eq")
+                        | Ind indeq ->
+                            if IndRef indeq = Coqlib.glob_eq
                             then (
-                              tclTHENSEQ ((do_replace_bl ind gls (!avoid)
+                              tclTHENSEQ ((do_replace_bl bl_scheme_key ind gls
+				                      (!avoid)
                                                       nparrec (ca.(2))
                               (ca.(1)))@[Auto.default_auto]) gls
                             )
-                            else 
+                            else
                               (error "Failure while solving Boolean->Leibniz.")
                         | _ -> error "Failure while solving Boolean->Leibniz."
                       )
                       | _ -> error "Failure while solving Boolean->Leibniz."
-             
-                    ]
-      )
 
-let compute_lb_goal ind lnamesparrec nparrec = 
+                    ] gsig
+
+let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
+
+let make_bl_scheme mind =
+  let mib = Global.lookup_mind mind in
+  if Array.length mib.mind_packets <> 1 then
+    errorlabstrm ""
+      (str "Automatic building of boolean->Leibniz lemmas not supported");
+  let ind = (mind,0) in
+  let nparams = mib.mind_nparams in
+  let nparrec = mib.mind_nparams_rec in
+  let lnonparrec,lnamesparrec =
+    context_chop (nparams-nparrec) mib.mind_params_ctxt in
+  [|Pfedit.build_by_tactic
+    (compute_bl_goal ind lnamesparrec nparrec)
+    (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec)|]
+
+let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme
+
+let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind
+
+(**********************************************************************)
+(* Leibniz->Boolean *)
+
+let compute_lb_goal ind lnamesparrec nparrec =
   let list_id = list_id lnamesparrec in
   let eqI = eqI ind lnamesparrec in
     let create_input c =
@@ -581,70 +603,68 @@ let compute_lb_goal ind lnamesparrec nparrec =
       let lb_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
-              mkArrow 
+              mkArrow
                ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
                ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
           ))
-        ) list_id in      
+        ) list_id in
       let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b ->
         mkNamedProd slb b a
-      ) c (List.rev list_id) (List.rev lb_typ) in 
+      ) c (List.rev list_id) (List.rev lb_typ) in
       let eqs_typ = List.map (fun (s,_,_,_) ->
           mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
           ) list_id in
       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 
+      ) 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
-    in 
-      let n = id_of_string "n" and
-          m = id_of_string "m" in
+    in
+      let n = id_of_string "x" and
+          m = id_of_string "y" in
       create_input (
         mkNamedProd n (mkFullInd ind nparrec) (
           mkNamedProd m (mkFullInd ind (nparrec+1)) (
-            mkArrow 
+            mkArrow
               (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|]))
               (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|]))
         )))
 
-let compute_lb_tact ind lnamesparrec nparrec = 
+let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig =
   let list_id = list_id lnamesparrec in
     let avoid = ref [] in
-    let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in
-      let first_intros = 
+      let first_intros =
         ( List.map (fun (s,_,_,_) -> s ) list_id ) @
         ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
-        ( List.map (fun (_,_,_,slb) -> slb) list_id ) 
-      in 
+        ( List.map (fun (_,_,_,slb) -> slb) list_id )
+      in
       let fresh_first_intros = List.map ( fun s ->
         let fresh = fresh_id (!avoid) s gsig in
         avoid := fresh::(!avoid); fresh ) first_intros in
-      let freshn = fresh_id (!avoid) (id_of_string "n") gsig in
+      let freshn = fresh_id (!avoid) (id_of_string "x") gsig in
       let freshm = avoid := freshn::(!avoid);
-            fresh_id (!avoid) (id_of_string "m") gsig in
+            fresh_id (!avoid) (id_of_string "y") gsig in
       let freshz = avoid := freshm::(!avoid);
             fresh_id (!avoid) (id_of_string "Z") gsig in
   (* try with *)
       avoid := freshz::(!avoid);
-      Pfedit.by (
       tclTHENSEQ [ intros_using fresh_first_intros;
                      intro_using freshn ;
-                     new_induct false [Tacexpr.ElimOnConstr 
-                                    ((mkVar freshn),Rawterm.NoBindings)] 
+                     new_induct false [Tacexpr.ElimOnConstr
+                                    ((mkVar freshn),Rawterm.NoBindings)]
                                 None
                                 (None,None)
 		                None;
                      intro_using freshm;
-                     new_destruct false [Tacexpr.ElimOnConstr 
+                     new_destruct false [Tacexpr.ElimOnConstr
                                     ((mkVar freshm),Rawterm.NoBindings)]
                                 None
                                 (None,None)
 		                None;
                      intro_using freshz;
                      intros;
-                     tclTRY ( 
+                     tclTRY (
                       tclORELSE reflexivity (Equality.discr_tac false None)
                      );
                      Equality.inj [] false (mkVar freshz,Rawterm.NoBindings);
@@ -658,21 +678,48 @@ let compute_lb_tact ind lnamesparrec nparrec =
                   (* assume the goal to be eq (eq_type ...) = true *)
                         match (kind_of_term gl) with
                           | App(c,ca) -> (match (kind_of_term ca.(1)) with
-                              | App(c',ca') -> 
+                              | App(c',ca') ->
                                   let n = Array.length ca' in
-                                    tclTHENSEQ (do_replace_lb (!avoid) 
-                                                nparrec gls 
+                                    tclTHENSEQ (do_replace_lb lb_scheme_key
+				                (!avoid)
+                                                nparrec gls
                                                 ca'.(n-2) ca'.(n-1)) gls
-                              | _ -> error 
-                                "Failure while solving Leibniz->Boolean." 
+                              | _ -> error
+                                "Failure while solving Leibniz->Boolean."
                             )
-                          | _ -> error 
-                                  "Failure while solving Leibniz->Boolean." 
-                    ]
-            )
+                          | _ -> error
+                                  "Failure while solving Leibniz->Boolean."
+                    ] gsig
+
+let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined")
+
+let make_lb_scheme mind =
+  let mib = Global.lookup_mind mind in
+  if Array.length mib.mind_packets <> 1 then
+    errorlabstrm ""
+      (str "Automatic building of Leibniz->boolean lemmas not supported");
+  let ind = (mind,0) in
+  let nparams = mib.mind_nparams in
+  let nparrec = mib.mind_nparams_rec in
+  let lnonparrec,lnamesparrec =
+    context_chop (nparams-nparrec) mib.mind_params_ctxt in
+  [|Pfedit.build_by_tactic
+    (compute_lb_goal ind lnamesparrec nparrec)
+    (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)|]
+
+let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme
+
+let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind
+
+(**********************************************************************)
+(* Decidable equality *)
+
+let check_not_is_defined () =
+  try ignore (Coqlib.build_coq_not ()) with _ -> raise (UndefinedCst "not")
 
 (* {n=m}+{n<>m}  part  *)
-let compute_dec_goal ind lnamesparrec nparrec = 
+let compute_dec_goal ind lnamesparrec nparrec =
+  check_not_is_defined ();
   let list_id = list_id lnamesparrec in
     let create_input c =
       let x = id_of_string "x" and
@@ -680,39 +727,39 @@ let compute_dec_goal ind lnamesparrec nparrec =
       let lb_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
-              mkArrow 
+              mkArrow
                ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
                ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
           ))
-        ) list_id in      
+        ) list_id in
       let bl_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
-              mkArrow 
+              mkArrow
                ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
                ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
           ))
-        ) list_id in      
+        ) list_id in
 
       let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b ->
         mkNamedProd slb b a
-      ) c (List.rev list_id) (List.rev lb_typ) in 
+      ) c (List.rev list_id) (List.rev lb_typ) in
       let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
         mkNamedProd sbl b a
-      ) lb_input (List.rev list_id) (List.rev bl_typ) in 
+      ) lb_input (List.rev list_id) (List.rev bl_typ) in
 
       let eqs_typ = List.map (fun (s,_,_,_) ->
           mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
           ) list_id in
       let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
         mkNamedProd seq b a
-      ) bl_input (List.rev list_id) (List.rev eqs_typ) in 
+      ) 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
-    in 
-      let n = id_of_string "n" and
-          m = id_of_string "m" in
+    in
+      let n = id_of_string "x" and
+          m = id_of_string "y" in
         let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in
         create_input (
           mkNamedProd n (mkFullInd ind (2*nparrec)) (
@@ -722,93 +769,116 @@ let compute_dec_goal ind lnamesparrec nparrec =
         )
       )
 
-let compute_dec_tact ind lnamesparrec nparrec = 
+let compute_dec_tact ind lnamesparrec nparrec gsig =
   let list_id = list_id lnamesparrec in
   let eqI = eqI ind lnamesparrec in
-    let avoid = ref [] in
-    let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in
-    let eqtrue x = mkApp(eq,[|bb;x;tt|]) in
-    let eqfalse x = mkApp(eq,[|bb;x;ff|]) in
-      let first_intros = 
-        ( List.map (fun (s,_,_,_) -> s ) list_id ) @
-        ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
-        ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @
-        ( List.map (fun (_,_,_,slb) -> slb) list_id ) 
-      in 
-      let fresh_first_intros = List.map ( fun s ->
-        let fresh = fresh_id (!avoid) s gsig in
-        avoid := fresh::(!avoid); fresh ) first_intros in
-      let freshn = fresh_id (!avoid) (id_of_string "n") gsig in
-      let freshm = avoid := freshn::(!avoid);
-            fresh_id (!avoid) (id_of_string "m") gsig in
-      let freshH = avoid := freshm::(!avoid); 
-            fresh_id (!avoid) (id_of_string "H") gsig in
-      let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in
-      avoid := freshH::(!avoid);
-      Pfedit.by ( tclTHENSEQ [
-                        intros_using fresh_first_intros;
-                        intros_using [freshn;freshm];
-                        assert_tac (Name freshH) (
-                        mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|])
-                  ) ]); 
-(*we do this so we don't have to prove the same goal twice *)
-      Pfedit.by (  tclTHEN 
-                   (new_destruct false [Tacexpr.ElimOnConstr
-                                  (eqbnm,Rawterm.NoBindings)]
-                                None
-                                (None,None)
-		                None)
-                  Auto.default_auto
-                );
-      Pfedit.by (
-                  let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in
-                    avoid := freshH2::(!avoid);
-                    new_destruct false [Tacexpr.ElimOnConstr 
-                                    ((mkVar freshH),Rawterm.NoBindings)] 
-                                None
-                                (None,Some (dl,Genarg.IntroOrAndPattern [
-                                    [dl,Genarg.IntroAnonymous];
-                                    [dl,Genarg.IntroIdentifier freshH2]])) None
-      );
-      let arfresh = Array.of_list fresh_first_intros in
-        let xargs = Array.sub arfresh 0 (2*nparrec) in
-          let blI = try find_bl_proof ind with
+  let avoid = ref [] in
+  let eqtrue x = mkApp(eq,[|bb;x;tt|]) in
+  let eqfalse x = mkApp(eq,[|bb;x;ff|]) in
+  let first_intros =
+      ( List.map (fun (s,_,_,_) -> s ) list_id ) @
+      ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
+      ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @
+      ( List.map (fun (_,_,_,slb) -> slb) list_id )
+  in
+  let fresh_first_intros = List.map ( fun s ->
+    let fresh = fresh_id (!avoid) s gsig in
+    avoid := fresh::(!avoid); fresh ) first_intros in
+  let freshn = fresh_id (!avoid) (id_of_string "x") gsig in
+  let freshm = avoid := freshn::(!avoid);
+    fresh_id (!avoid) (id_of_string "y") gsig in
+  let freshH = avoid := freshm::(!avoid);
+    fresh_id (!avoid) (id_of_string "H") gsig in
+  let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in
+  avoid := freshH::(!avoid);
+  let arfresh = Array.of_list fresh_first_intros in
+  let xargs = Array.sub arfresh 0 (2*nparrec) in
+  let blI = try mkConst (find_scheme bl_scheme_kind ind) with
             Not_found -> error (
               "Error during the decidability part, boolean to leibniz"^
               " equality is required.")
-          in
-          let lbI = try find_lb_proof ind  with
+  in
+  let lbI = try mkConst (find_scheme lb_scheme_kind ind) with
             Not_found -> error (
               "Error during the decidability part, leibniz to boolean"^
               " equality is required.")
-          in
-
-      (* left *) 
-          Pfedit.by ( tclTHENSEQ [ simplest_left;
-                          apply (mkApp(blI,Array.map(fun x->mkVar x) xargs));
-                          Auto.default_auto
-          ]);
-      (*right *)
-          let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in
-          avoid := freshH3::(!avoid);
-          Pfedit.by (tclTHENSEQ [ simplest_right ;
-                      unfold_constr (Lazy.force Coqlib.coq_not_ref);
-                      intro;
-                      Equality.subst_all;
-                assert_tac (Name freshH3) 
-                (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))
-          ]);
-          Pfedit.by 
-            (tclTHENSEQ [apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs));
-                      Auto.default_auto
-            ]);
-         Pfedit.by (Equality.general_rewrite_bindings_in true
-	                      all_occurrences
-                              (List.hd !avoid) 
+  in
+  tclTHENSEQ [
+        intros_using fresh_first_intros;
+        intros_using [freshn;freshm];
+	(*we do this so we don't have to prove the same goal twice *)
+        assert_by (Name freshH) (
+          mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|])
+	)
+	  (tclTHEN
+	    (new_destruct false [Tacexpr.ElimOnConstr
+              (eqbnm,Rawterm.NoBindings)]
+              None
+              (None,None)
+	      None)
+	    Auto.default_auto);
+        (fun gsig ->
+	  let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in
+          avoid := freshH2::(!avoid);
+	  tclTHENS (
+	    new_destruct false [Tacexpr.ElimOnConstr
+                                    ((mkVar freshH),Rawterm.NoBindings)]
+                                None
+                                (None,Some (dl,Genarg.IntroOrAndPattern [
+                                    [dl,Genarg.IntroAnonymous];
+                                    [dl,Genarg.IntroIdentifier freshH2]])) None
+	  ) [
+	    (* left *)
+	    tclTHENSEQ [
+	      simplest_left;
+              apply (mkApp(blI,Array.map(fun x->mkVar x) xargs));
+              Auto.default_auto
+            ];
+	    (*right *)
+            (fun gsig ->
+	    let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in
+            avoid := freshH3::(!avoid);
+            tclTHENSEQ [
+	      simplest_right ;
+              unfold_constr (Lazy.force Coqlib.coq_not_ref);
+              intro;
+              Equality.subst_all;
+              assert_by (Name freshH3)
+		(mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))
+		(tclTHENSEQ [
+		  apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs));
+                  Auto.default_auto
+		]);
+	      Equality.general_rewrite_bindings_in true
+	                      all_occurrences false
+                              (List.hd !avoid)
                               ((mkVar (List.hd (List.tl !avoid))),
                                 Rawterm.NoBindings
                               )
-                              true);
-        Pfedit.by (Equality.discr_tac false None)
-        
+                              true;
+              Equality.discr_tac false None
+	    ] gsig)
+	  ] gsig)
+  ] gsig
+
+let make_eq_decidability mind =
+  let mib = Global.lookup_mind mind in
+  if Array.length mib.mind_packets <> 1 then
+    anomaly "Decidability lemma for mutual inductive types not supported";
+  let ind = (mind,0) in
+  let nparams = mib.mind_nparams in
+  let nparrec = mib.mind_nparams_rec in
+  let lnonparrec,lnamesparrec =
+    context_chop (nparams-nparrec) mib.mind_params_ctxt in
+  [|Pfedit.build_by_tactic
+    (compute_dec_goal ind lnamesparrec nparrec)
+    (compute_dec_tact ind lnamesparrec nparrec)|]
+
+let eq_dec_scheme_kind =
+  declare_mutual_scheme_object "_eq_dec" make_eq_decidability
+
+(* The eq_dec_scheme proofs depend on the equality and discr tactics
+   but the inj tactics, that comes with discr, depends on the
+   eq_dec_scheme... *)
 
+let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
index b8fa1710..855f023f 100644
--- a/toplevel/auto_ind_decl.mli
+++ b/toplevel/auto_ind_decl.mli
@@ -11,17 +11,31 @@ open Names
 open Libnames
 open Mod_subst
 open Sign
+open Proof_type
+open Ind_tables
 
+(* Build boolean equality of a block of mutual inductive types *)
 
-val subst_in_constr : (object_name*substitution*(inductive*constr))
-                     -> (inductive*constr) 
+exception EqNotFound of inductive * inductive
+exception EqUnknown of string
+exception UndefinedCst of string
+exception InductiveWithProduct
+exception InductiveWithSort
+exception ParameterWithoutEquality of constant
+exception NonSingletonProp of inductive
 
-val compute_bl_goal : inductive -> rel_context -> int -> types
-val compute_bl_tact : inductive -> rel_context -> int -> unit 
-val compute_lb_goal : inductive -> rel_context -> int -> types 
-val compute_lb_tact : inductive -> rel_context -> int -> unit 
-val compute_dec_goal : inductive -> rel_context -> int -> types
-val compute_dec_tact : inductive -> rel_context -> int -> unit 
+val beq_scheme_kind : mutual scheme_kind
+val build_beq_scheme : mutual_inductive -> constr array
 
+(* Build equivalence between boolean equality and Leibniz equality *)
 
-val make_eq_scheme :mutual_inductive -> types array
+val lb_scheme_kind : mutual scheme_kind
+val make_lb_scheme : mutual_inductive -> constr array
+
+val bl_scheme_kind : mutual scheme_kind
+val make_bl_scheme : mutual_inductive -> constr array
+
+(* Build decidability of equality *)
+
+val eq_dec_scheme_kind : mutual scheme_kind
+val make_eq_decidability : mutual_inductive -> constr array
diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml
new file mode 100644
index 00000000..b45e45c8
--- /dev/null
+++ b/toplevel/autoinstance.ml
@@ -0,0 +1,316 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(*i*)
+open Pp
+open Printer
+open Names
+open Term
+open Evd
+open Sign
+open Libnames
+(*i*)
+
+(*s
+ * Automatic detection of (some) record instances
+ *)
+
+(* Datatype for wannabe-instances: a signature is a typeclass along
+   with the collection of evars corresponding to the parameters/fields
+   of the class. Each evar can be uninstantiated (we're still looking
+   for them) or defined (the instance for the field is fixed) *)
+type signature = global_reference * evar list * evar_map
+
+type instance_decl_function = global_reference -> rel_context -> constr list -> unit
+
+(*
+ * Search algorithm
+ *)
+
+let rec subst_evar evar def n c =
+  match kind_of_term c with
+    | Evar (e,_) when e=evar -> lift n def
+    | _ -> map_constr_with_binders (fun n->n+1) (subst_evar evar def) n c
+
+let subst_evar_in_evm evar def evm =
+  Evd.fold
+    (fun ev evi acc ->
+       let evar_body = match evi.evar_body with
+	 | Evd.Evar_empty -> Evd.Evar_empty
+	 | Evd.Evar_defined c -> Evd.Evar_defined (subst_evar evar def 0 c) in
+       let evar_concl = subst_evar evar def 0 evi.evar_concl in
+       Evd.add acc ev {evi with evar_body=evar_body; evar_concl=evar_concl}
+    ) evm empty
+
+(* Tries to define ev by c in evd. Fails if ev := c1 and c1 /= c ev :
+ * T1, c : T2 and T1 /= T2. Defines recursively all evars instantiated
+ * by this definition. *)
+
+let rec safe_define evm ev c =
+  if not (closedn (-1) c) then raise Termops.CannotFilter else
+(*  msgnl(str"safe_define "++pr_evar_map evm++spc()++str" |- ?"++Util.pr_int ev++str" := "++pr_constr c);*)
+  let evi = (Evd.find evm ev) in
+  let define_subst evm sigma =
+    Util.Intmap.fold
+      ( fun ev (e,c) evm ->
+	  match kind_of_term c with Evar (i,_) when i=ev -> evm | _ ->
+	    safe_define evm ev (lift (-List.length e) c)
+      ) sigma evm in
+  match evi.evar_body with
+    | Evd.Evar_defined def ->
+	define_subst evm (Termops.filtering [] Reduction.CUMUL def c)
+    | Evd.Evar_empty ->
+	let t = Libtypes.reduce (Typing.type_of (Global.env()) evm c) in
+	let u = Libtypes.reduce (evar_concl evi) in
+	let evm = subst_evar_in_evm ev c evm in
+	define_subst (Evd.define ev c evm) (Termops.filtering [] Reduction.CUMUL t u)
+
+let add_gen_ctx (cl,gen,evm) ctx : signature * constr list =
+  let rec really_new_evar () =
+    let ev = Evarutil.new_untyped_evar() in
+    if Evd.is_evar evm ev then really_new_evar() else ev in
+  let add_gen_evar (cl,gen,evm) ev ty : signature =
+    let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val ty) in
+    (cl,ev::gen,evm) in
+  let rec mksubst b = function
+    | [] -> []
+    | a::tl -> b::(mksubst (a::b) tl) in
+  let evl = List.map (fun _ -> really_new_evar()) ctx in
+  let evcl = List.map (fun i -> mkEvar (i,[||])) evl in
+  let substl = List.rev (mksubst [] (evcl)) in
+  let ctx = List.map2 (fun s t -> substnl s 0 t) substl ctx in
+  let sign = List.fold_left2 add_gen_evar (cl,gen,evm) (List.rev evl) ctx in
+  sign,evcl
+
+(* TODO : for full proof-irrelevance in the search, provide a real
+   compare function for constr instead of Pervasive's one! *)
+module SubstSet : Set.S with type elt = Termops.subst
+  = Set.Make (struct type t = Termops.subst
+		     let compare = Util.Intmap.compare (Pervasives.compare)
+	      end)
+
+(* searches instatiations in the library for just one evar [ev] of a
+   signature. [k] is called on each resulting signature *)
+let complete_evar (cl,gen,evm:signature) (ev,evi) (k:signature -> unit) =
+  let ev_typ = Libtypes.reduce (evar_concl evi) in
+  let sort_is_prop = is_Prop (Typing.type_of (Global.env()) evm (evar_concl evi)) in
+(*  msgnl(str"cherche "++pr_constr ev_typ++str" pour "++Util.pr_int ev);*)
+  let substs = ref SubstSet.empty in
+  try List.iter
+    ( fun (gr,(pat,_),s) ->
+	let (_,genl,_) = Termops.decompose_prod_letin pat in
+	let genl = List.map (fun (_,_,t) -> t) genl in
+	let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) genl in
+	let def = applistc (Libnames.constr_of_global gr) argl in
+(*	msgnl(str"essayons  ?"++Util.pr_int ev++spc()++str":="++spc()
+	      ++pr_constr def++spc()++str":"++spc()++pr_constr (Global.type_of_global gr)*)
+	(*++spc()++str"dans"++spc()++pr_evar_map evm++spc());*)
+	try
+ 	  let evm = safe_define evm ev def in
+	  k (cl,gen,evm);
+	  if sort_is_prop && SubstSet.mem s !substs then raise Exit;
+	  substs := SubstSet.add s !substs
+	with Termops.CannotFilter -> ()
+    ) (Libtypes.search_concl ev_typ)
+  with Exit -> ()
+
+let evm_fold_rev f evm acc =
+  let l = Evd.fold (fun ev evi acc -> (ev,evi)::acc) evm [] in
+  List.fold_left (fun acc (ev,evi) -> f ev evi acc) acc l
+
+exception Continue of Evd.evar * Evd.evar_info
+
+(* searches matches for all the uninstantiated evars of evd in the
+   context. For each totally instantiated evar_map found, apply
+   k. *)
+let rec complete_signature (k:signature -> unit) (cl,gen,evm:signature) =
+  try
+    evm_fold_rev
+      ( fun ev evi _ ->
+	  if not (is_defined evm ev) && not (List.mem ev gen) then
+	    raise (Continue (ev,evi))
+      ) evm (); k (cl,gen,evm)
+  with Continue (ev,evi) -> complete_evar (cl,gen,evm) (ev,evi) (complete_signature k)
+
+(* define all permutations of the evars to evd and call k on the
+   resulting evd *)
+let complete_with_evars_permut (cl,gen,evm:signature) evl c (k:signature -> unit) : unit =
+  let rec aux evm = List.iter
+    ( fun (ctx,ev) ->
+	let tyl = List.map (fun (_,_,t) -> t) ctx in
+	let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) tyl in
+	let def = applistc c argl in
+(*	msgnl(str"trouvé def ?"++Util.pr_int ev++str" := "++pr_constr def++str " dans "++pr_evar_map evm);*)
+	try
+	  if not (Evd.is_defined evm ev) then
+	    let evm = safe_define evm ev def in
+	    aux evm; k (cl,gen,evm)
+	with Termops.CannotFilter -> ()
+    ) evl in
+  aux evm
+
+let new_inst_no =
+  let cnt = ref 0 in
+  fun () -> incr cnt; string_of_int !cnt
+
+let make_instance_ident gr =
+  Nameops.add_suffix (Nametab.basename_of_global gr) ("_autoinstance_"^new_inst_no())
+
+let new_instance_message ident typ def =
+  Flags.if_verbose
+  msgnl (str"new instance"++spc()
+	 ++Nameops.pr_id ident++spc()++str":"++spc()
+	 ++pr_constr typ++spc()++str":="++spc()
+	 ++pr_constr def)
+
+open Entries
+
+let rec deep_refresh_universes c =
+  match kind_of_term c with
+    | Sort (Type _) -> Termops.new_Type()
+    | _ -> map_constr deep_refresh_universes c
+
+let declare_record_instance gr ctx params =
+  let ident = make_instance_ident gr in
+  let def = it_mkLambda_or_LetIn (applistc (constr_of_global gr) params) ctx in
+  let def = deep_refresh_universes def in
+  let ce = { const_entry_body=def; const_entry_type=None;
+	     const_entry_opaque=false; const_entry_boxed=false } in
+  let cst = Declare.declare_constant ident
+    (DefinitionEntry ce,Decl_kinds.IsDefinition Decl_kinds.StructureComponent) in
+  new_instance_message ident (Typeops.type_of_constant (Global.env()) cst) def
+
+let declare_class_instance gr ctx params =
+  let ident = make_instance_ident gr in
+  let cl = Typeclasses.class_info gr in
+  let (def,typ) = Typeclasses.instance_constructor cl params in
+  let (def,typ) = it_mkLambda_or_LetIn def ctx, it_mkProd_or_LetIn typ ctx in
+  let def = deep_refresh_universes def in
+  let typ = deep_refresh_universes typ in
+  let ce = Entries.DefinitionEntry
+    {  const_entry_type=Some typ; const_entry_body=def;
+       const_entry_opaque=false; const_entry_boxed=false } in
+  try
+  let cst = Declare.declare_constant ident
+    (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in
+  Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst));
+  new_instance_message ident typ def
+  with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str"  "++Cerrors.explain_exn e)
+
+let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t;
+  match kind_of_term t with
+    | Prod (n,t,c) -> iter_under_prod f ((n,None,t)::ctx) c
+    | _ -> ()
+
+(* main search function: search for total instances containing gr, and
+   apply k to each of them *)
+let complete_signature_with_def gr deftyp (k:instance_decl_function -> signature -> unit) : unit =
+  let gr_c = Libnames.constr_of_global gr in
+  let (smap:(Libnames.global_reference * Evd.evar_map,
+   ('a * 'b * Term.constr) list * Evd.evar)
+  Gmapl.t ref) = ref Gmapl.empty in
+  iter_under_prod
+    ( fun ctx typ ->
+	List.iter
+	  (fun ((cl,ev,evm),_,_) ->
+(*	     msgnl(pr_global gr++str" : "++pr_constr typ++str" matche ?"++Util.pr_int ev++str " dans "++pr_evar_map evm);*)
+	     smap := Gmapl.add (cl,evm) (ctx,ev) !smap)
+	  (Recordops.methods_matching typ)
+    ) [] deftyp;
+  Gmapl.iter
+    ( fun (cl,evm) evl ->
+	let f = if Typeclasses.is_class cl then
+	  declare_class_instance else declare_record_instance in
+	complete_with_evars_permut (cl,[],evm) evl gr_c
+	  (fun sign -> complete_signature (k f) sign)
+    ) !smap
+
+(*
+ * Interface with other parts: hooks & declaration
+ *)
+
+
+let evar_definition evi = match evar_body evi with
+    Evar_empty -> assert false | Evar_defined c -> c
+
+let gen_sort_topo l evm =
+  let iter_evar f ev =
+    let rec aux c = match kind_of_term c with
+	Evar (e,_) -> f e
+      | _ -> iter_constr aux c in
+    aux (Evd.evar_concl (Evd.find evm ev));
+    if Evd.is_defined evm ev then aux (evar_definition (Evd.find evm ev)) in
+  let r = ref [] in
+  let rec dfs ev = iter_evar dfs ev;
+    if not(List.mem ev !r) then r := ev::!r in
+  List.iter dfs l; List.rev !r
+
+(* register real typeclass instance given a totally defined evd *)
+let declare_instance (k:global_reference -> rel_context -> constr list -> unit)
+    (cl,gen,evm:signature) =
+  let evm = Evarutil.nf_evars evm in
+  let gen = gen_sort_topo gen evm in
+  let (evm,gen) = List.fold_right
+    (fun ev (evm,gen) ->
+       if Evd.is_defined evm ev
+       then Evd.remove evm ev,gen
+       else evm,(ev::gen))
+    gen (evm,[]) in
+(*  msgnl(str"instance complète : ["++Util.prlist_with_sep (fun _ -> str";") Util.pr_int gen++str"] : "++spc()++pr_evar_map evm);*)
+  let ngen = List.length gen in
+  let (_,ctx,evm) = List.fold_left
+    ( fun (i,ctx,evm) ev ->
+	let ctx = (Anonymous,None,lift (-i) (Evd.evar_concl(Evd.find evm ev)))::ctx in
+	let evm = subst_evar_in_evm ev (mkRel i) (Evd.remove evm ev) in
+	(i-1,ctx,evm)
+    ) (ngen,[],evm) gen in
+  let fields = List.rev (Evd.fold ( fun ev evi l -> evar_definition evi::l ) evm []) in
+  k cl ctx fields
+
+let autoinstance_opt = ref true
+
+let search_declaration gr =
+  if !autoinstance_opt &&
+    not (Lib.is_modtype()) then
+    let deftyp = Global.type_of_global gr in
+    complete_signature_with_def gr deftyp declare_instance
+
+let search_record k cons sign =
+  if !autoinstance_opt && not (Lib.is_modtype()) then
+    complete_signature (declare_instance k) (cons,[],sign)
+
+(*
+let dh_key = Profile.declare_profile "declaration_hook"
+let ch_key = Profile.declare_profile "class_decl_hook"
+let declaration_hook = Profile.profile1 dh_key declaration_hook
+let class_decl_hook = Profile.profile1 ch_key class_decl_hook
+*)
+
+(*
+ *  Options and bookeeping
+ *)
+
+let begin_autoinstance () =
+  if not !autoinstance_opt then (
+    autoinstance_opt := true;
+  )
+
+let end_autoinstance () =
+  if !autoinstance_opt then (
+    autoinstance_opt := false;
+ )
+
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync=true;
+      Goptions.optkey=["Autoinstance"];
+      Goptions.optname="automatic typeclass instance recognition";
+      Goptions.optread=(fun () -> !autoinstance_opt);
+      Goptions.optwrite=(fun b -> if b then begin_autoinstance() else end_autoinstance()) }
diff --git a/toplevel/autoinstance.mli b/toplevel/autoinstance.mli
new file mode 100644
index 00000000..3866fff3
--- /dev/null
+++ b/toplevel/autoinstance.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(*i*)
+open Term
+open Libnames
+open Typeclasses
+open Names
+open Evd
+open Sign
+(*i*)
+
+(*s Automatic detection of (some) record instances *)
+
+(* What to do if we find an instance. Passed are : the reference
+ * representing the record/class (definition or constructor) *)
+type instance_decl_function = global_reference -> rel_context -> constr list -> unit
+
+(* [search_declaration gr] Search in the library if the (new)
+ * declaration gr can form an instance of a registered record/class *)
+val search_declaration : global_reference -> unit
+
+(* [search_record declf gr evm] Search the library for instances of
+   the (new) record/class declaration [gr], and register them using
+   [declf]. [evm] is the signature of the record (to avoid recomputing
+   it) *)
+val search_record : instance_decl_function -> global_reference -> evar_map -> unit
+
+(* Instance declaration for both scenarios *)
+val declare_record_instance : instance_decl_function
+val declare_class_instance : instance_decl_function
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
index 0983463a..d5a343b0 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/cerrors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cerrors.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -17,9 +17,9 @@ open Indrec
 open Lexer
 
 let print_loc loc =
-  if loc = dummy_loc then 
+  if loc = dummy_loc then
     (str"<unknown>")
-  else 
+  else
     let loc = unloc loc in
     (int (fst loc) ++ str"-" ++ int (snd loc))
 
@@ -31,41 +31,46 @@ let where s =
 (* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *)
 
 let rec explain_exn_default_aux anomaly_string report_fn = function
-  | Stream.Failure -> 
+  | Stream.Failure ->
       hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.")
-  | Stream.Error txt -> 
+  | Stream.Error txt ->
       hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | Token.Error txt -> 
+  | Token.Error txt ->
       hov 0 (str "Syntax error: " ++ str txt ++ str ".")
-  | Sys_error msg -> 
+  | Sys_error msg ->
       hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ())
-  | UserError(s,pps) -> 
+  | UserError(s,pps) ->
       hov 0 (str "Error: " ++ where s ++ pps)
-  | Out_of_memory -> 
+  | Out_of_memory ->
       hov 0 (str "Out of memory.")
-  | Stack_overflow -> 
+  | Stack_overflow ->
       hov 0 (str "Stack overflow.")
-  | Anomaly (s,pps) -> 
+  | Timeout ->
+      hov 0 (str "Timeout!")
+  | Anomaly (s,pps) ->
       hov 0 (anomaly_string () ++ where s ++ pps ++ report_fn ())
+  | AnomalyOnError (s,exc) ->
+      hov 0 (anomaly_string () ++ str s ++ str ". Received exception is:" ++
+	fnl() ++ explain_exn_default_aux anomaly_string report_fn exc)
   | Match_failure(filename,pos1,pos2) ->
-      hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ 
+      hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++
       if Sys.ocaml_version = "3.06" then
-		   (str " from character " ++ int pos1 ++ 
+		   (str " from character " ++ int pos1 ++
                     str " to " ++ int pos2)
 		 else
 		   (str " at line " ++ int pos1 ++
 		    str " character " ++ int pos2)
 	           ++ report_fn ())
-  | Not_found -> 
+  | Not_found ->
       hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report_fn ())
-  | Failure s -> 
+  | Failure s ->
       hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report_fn ())
-  | Invalid_argument s -> 
+  | Invalid_argument s ->
       hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report_fn ())
-  | Sys.Break -> 
+  | Sys.Break ->
       hov 0 (fnl () ++ str "User interrupt.")
   | Univ.UniverseInconsistency (o,u,v) ->
-      let msg = 
+      let msg =
 	if !Constrextern.print_universes then
 	  spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++
           str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=")
@@ -73,60 +78,60 @@ let rec explain_exn_default_aux anomaly_string report_fn = function
 	else
 	  mt() in
       hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".")
-  | TypeError(ctx,te) -> 
+  | TypeError(ctx,te) ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te)
   | PretypeError(ctx,te) ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te)
   | Typeclasses_errors.TypeClassError(env, te) ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_typeclass_error env te)
-  | InductiveError e -> 
+  | InductiveError e ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e)
-  | RecursionSchemeError e -> 
+  | RecursionSchemeError e ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_recursion_scheme_error e)
-  | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when s <> mt () ->
+  | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () ->
       explain_exn_default_aux anomaly_string report_fn exc
   | Proof_type.LtacLocated (s,exc) ->
       hov 0 (Himsg.explain_ltac_call_trace s ++ fnl ()
              ++ explain_exn_default_aux anomaly_string report_fn exc)
-  | Cases.PatternMatchingError (env,e) -> 
+  | Cases.PatternMatchingError (env,e) ->
       hov 0
 	(str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e)
-  | Tacred.ReductionTacticError e -> 
+  | Tacred.ReductionTacticError e ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_reduction_tactic_error e)
-  | Logic.RefinerError e -> 
+  | Logic.RefinerError e ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e)
   | Nametab.GlobalizationError q ->
       hov 0 (str "Error:" ++ spc () ++
 	       str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
-	       spc () ++ str "was not found" ++ 
+	       spc () ++ str "was not found" ++
 	       spc () ++ str "in the current" ++ spc () ++ str "environment.")
   | Nametab.GlobalizationConstantError q ->
       hov 0 (str "Error:" ++ spc () ++
-	       str "No constant of this name:" ++ spc () ++ 
+	       str "No constant of this name:" ++ spc () ++
                Libnames.pr_qualid q ++ str ".")
   | Refiner.FailError (i,s) ->
-      hov 0 (str "Error: Tactic failure" ++ 
-                (if s <> mt() then str ":" ++ s else mt ()) ++
+      hov 0 (str "Error: Tactic failure" ++
+                (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++
                 if i=0 then str "." else str " (level " ++ int i ++ str").")
   | Stdpp.Exc_located (loc,exc) ->
       hov 0 ((if loc = dummy_loc then (mt ())
                else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
                ++ explain_exn_default_aux anomaly_string report_fn exc)
-  | Lexer.Error Illegal_character -> 
+  | Lexer.Error Illegal_character ->
       hov 0 (str "Syntax error: Illegal character.")
-  | Lexer.Error Unterminated_comment -> 
+  | Lexer.Error Unterminated_comment ->
       hov 0 (str "Syntax error: Unterminated comment.")
-  | Lexer.Error Unterminated_string -> 
+  | Lexer.Error Unterminated_string ->
       hov 0 (str "Syntax error: Unterminated string.")
-  | Lexer.Error Undefined_token -> 
+  | Lexer.Error Undefined_token ->
       hov 0 (str "Syntax error: Undefined token.")
-  | Lexer.Error (Bad_token s) -> 
+  | Lexer.Error (Bad_token s) ->
       hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".")
   | Assert_failure (s,b,e) ->
       hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++
-	       (if s <> "" then 
+	       (if s <> "" then
 		 if Sys.ocaml_version = "3.06" then
-		   (str ("(file \"" ^ s ^ "\", characters ") ++ 
+		   (str ("(file \"" ^ s ^ "\", characters ") ++
 		    int b ++ str "-" ++ int e ++ str ")")
 		 else
 		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
@@ -135,8 +140,10 @@ let rec explain_exn_default_aux anomaly_string report_fn = function
 	       else
 		 (mt ())) ++
 	       report_fn ())
+  | AlreadyDeclared msg ->
+      hov 0 (msg ++ str ".")
   | reraise ->
-      hov 0 (anomaly_string () ++ str "Uncaught exception " ++ 
+      hov 0 (anomaly_string () ++ str "Uncaught exception " ++
 	       str (Printexc.to_string reraise) ++ report_fn ())
 
 let anomaly_string () = str "Anomaly: "
@@ -157,3 +164,6 @@ let _ = Tactic_debug.explain_logic_error_no_anomaly :=
 let explain_exn_function = ref explain_exn_default
 
 let explain_exn e = !explain_exn_function e
+
+let explain_exn_no_anomaly e =
+   explain_exn_default_aux (fun () -> raise e) mt e
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
index 1236ecf5..6890e73e 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/cerrors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cerrors.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -19,6 +19,12 @@ val print_loc : loc -> std_ppcmds
 
 val explain_exn : exn -> std_ppcmds
 
+(** Same, but will re-raise all anomalies instead of explaining them *)
+
+val explain_exn_no_anomaly : exn -> std_ppcmds
+
+(** For debugging purpose (?), the explain function can be twicked *)
+
 val explain_exn_function : (exn -> std_ppcmds) ref
 val explain_exn_default : exn -> std_ppcmds
 
diff --git a/toplevel/class.ml b/toplevel/class.ml
index 6ebc663b..3526bd8c 100644
--- a/toplevel/class.ml
+++ b/toplevel/class.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: class.ml 11343 2008-09-01 20:55:13Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -29,10 +29,6 @@ open Safe_typing
 
 let strength_min l = if List.mem Local l then Local else Global
 
-let id_of_varid c = match kind_of_term c with
-  | Var id -> id
-  | _ -> anomaly "class__id_of_varid"
-
 (* Errors *)
 
 type coercion_error_kind =
@@ -54,7 +50,7 @@ let explain_coercion_error g = function
   | NotAFunction ->
       (Printer.pr_global g ++ str" is not a function")
   | NoSource (Some cl) ->
-      (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " 
+      (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of "
        ++ Printer.pr_global g)
   | NoSource None ->
       (str ": cannot find the source class of " ++ Printer.pr_global g)
@@ -62,7 +58,7 @@ let explain_coercion_error g = function
       pr_class cl ++ str " cannot be a source class"
   | NotUniform ->
       (Printer.pr_global g ++
-         str" does not respect the inheritance uniform condition");
+         str" does not respect the uniform inheritance condition");
   | NoTarget ->
       (str"Cannot find the target class")
   | WrongTarget (clt,cl) ->
@@ -95,33 +91,24 @@ let check_target clt = function
 
 (* condition d'heritage uniforme *)
 
-let uniform_cond nargs lt = 
+let uniform_cond nargs lt =
   let rec aux = function
     | (0,[]) -> true
     | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l))
     | _ -> false
-  in 
+  in
   aux (nargs,lt)
 
-let id_of_cl  = function
-  | CL_FUN -> id_of_string "FUNCLASS"
-  | CL_SORT -> id_of_string "SORTCLASS"
-  | CL_CONST kn -> id_of_label (con_label kn)
-  | CL_IND ind ->
-      let (_,mip) = Global.lookup_inductive ind in
-      mip.mind_typename
-  | CL_SECVAR id -> id
-
 let class_of_global = function
   | ConstRef sp -> CL_CONST sp
   | IndRef sp -> CL_IND sp
   | VarRef id -> CL_SECVAR id
-  | ConstructRef _ as c -> 
+  | ConstructRef _ as c ->
       errorlabstrm "class_of_global"
-	(str "Constructors, such as " ++ Printer.pr_global c ++ 
+	(str "Constructors, such as " ++ Printer.pr_global c ++
 	   str ", cannot be used as a class.")
 
-(* 
+(*
 lp est la liste (inverse'e) des arguments de la coercion
 ids est le nom de la classe source
 sps_opt est le sp de la classe source dans le cas des structures
@@ -140,13 +127,13 @@ let get_source lp source =
           match lp with
 	    | [] -> raise Not_found
             | t1::_ -> find_class_type (Global.env()) Evd.empty t1
-        in 
+        in
 	(cl1,lv1,1)
     | Some cl ->
 	let rec aux = function
 	  | [] -> raise Not_found
 	  | t1::lt ->
-	      try 
+	      try
 		let cl1,lv1 = find_class_type (Global.env()) Evd.empty t1 in
 		if cl = cl1 then cl1,lv1,(List.length lt+1)
 		else raise Not_found
@@ -154,20 +141,20 @@ let get_source lp source =
 	in aux (List.rev lp)
 
 let get_target t ind =
-  if (ind > 1) then 
+  if (ind > 1) then
     CL_FUN
-  else 
+  else
     fst (find_class_type (Global.env()) Evd.empty t)
 
-let prods_of t = 
+let prods_of t =
   let rec aux acc d = match kind_of_term d with
     | Prod (_,c1,c2) -> aux (c1::acc) c2
     | Cast (c,_,_) -> aux acc c
     | _ -> (d,acc)
-  in 
+  in
   aux [] t
 
-let strength_of_cl = function 
+let strength_of_cl = function
   | CL_CONST kn -> Global
   | CL_SECVAR id -> Local
   | _ -> Global
@@ -182,7 +169,7 @@ let ident_key_of_class = function
   | CL_FUN -> "Funclass"
   | CL_SORT -> "Sortclass"
   | CL_CONST sp -> string_of_label (con_label sp)
-  | CL_IND (sp,_) -> string_of_label (label sp)
+  | CL_IND (sp,_) -> string_of_label (mind_label sp)
   | CL_SECVAR id -> string_of_id id
 
 (* coercion identité *)
@@ -199,7 +186,7 @@ let build_id_coercion idf_opt source =
   let c = match constant_opt_value env (destConst vs) with
     | Some c -> c
     | None -> error_not_transparent source in
-  let lams,t = Sign.decompose_lam_assum c in
+  let lams,t = decompose_lam_assum c in
   let val_f =
     it_mkLambda_or_LetIn
       (mkLambda (Name (id_of_string "x"),
@@ -213,7 +200,7 @@ let build_id_coercion idf_opt source =
       lams
   in
   (* juste pour verification *)
-  let _ = 
+  let _ =
     if not
       (Reductionops.is_conv_leq env Evd.empty
 	(Typing.type_of env Evd.empty val_f) typ_f)
@@ -242,7 +229,7 @@ let check_source = function
 | Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s))
 | _ -> ()
 
-(* 
+(*
 nom de la fonction coercion
 strength de f
 nom de la classe source (optionnel)
@@ -261,7 +248,7 @@ let add_new_coercion_core coef stre source target isid =
   let llp = List.length lp in
   if llp = 0 then raise (CoercionError NotAFunction);
   let (cls,lvs,ind) =
-    try 
+    try
       get_source lp source
     with Not_found ->
       raise (CoercionError (NoSource source))
@@ -271,7 +258,7 @@ let add_new_coercion_core coef stre source target isid =
     raise (CoercionError NotUniform);
   let clt =
     try
-      get_target tg ind 
+      get_target tg ind
     with Not_found ->
       raise (CoercionError NoTarget)
   in
@@ -304,7 +291,7 @@ let try_add_new_identity_coercion id stre ~source ~target =
 let try_add_new_coercion_with_source ref stre ~source =
   try_add_new_coercion_core ref stre (Some source) None false
 
-let add_coercion_hook stre ref = 
+let add_coercion_hook stre ref =
   try_add_new_coercion ref stre;
   Flags.if_verbose message
     (string_of_qualid (shortest_qualid_of_global Idset.empty ref)
diff --git a/toplevel/class.mli b/toplevel/class.mli
index 98ed6a0d..3398e3fa 100644
--- a/toplevel/class.mli
+++ b/toplevel/class.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: class.mli 10840 2008-04-23 21:29:34Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -22,7 +22,7 @@ open Nametab
 
 (* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
    from [src] to [tg] *)
-val try_add_new_coercion_with_target : global_reference -> locality -> 
+val try_add_new_coercion_with_target : global_reference -> locality ->
   source:cl_typ -> target:cl_typ ->  unit
 
 (* [try_add_new_coercion ref s] declares [ref], assumed to be of type
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index 1a1640a4..90daca12 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.ml
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classes.ml 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -34,36 +34,35 @@ open Entries
 
 let typeclasses_db = "typeclass_instances"
 
-let qualid_of_con c = 
-  Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c))
-
-let set_rigid c = 
+let set_typeclass_transparency c b = 
   Auto.add_hints false [typeclasses_db] 
-    (Vernacexpr.HintsTransparency ([qualid_of_con c], false))
-
+    (Auto.HintsTransparencyEntry ([c], b))
+    
 let _ =
-  Typeclasses.register_add_instance_hint 
+  Typeclasses.register_add_instance_hint
     (fun inst pri ->
-      Flags.silently (fun () ->      
-	Auto.add_hints false [typeclasses_db] 
-	  (Vernacexpr.HintsResolve 
-	      [pri, false, CAppExpl (dummy_loc, (None, qualid_of_con inst), [])])) ())
+      Flags.silently (fun () ->
+	Auto.add_hints false [typeclasses_db]
+	  (Auto.HintsResolveEntry
+	      [pri, false, constr_of_global inst])) ());
+  Typeclasses.register_set_typeclass_transparency set_typeclass_transparency
+    
+let declare_class g =
+  match global g with
+  | ConstRef x -> Typeclasses.add_constant_class x
+  | IndRef x -> Typeclasses.add_inductive_class x
+  | _ -> user_err_loc (loc_of_reference g, "declare_class", 
+		      Pp.str"Unsupported class type, only constants and inductives are allowed")
     
-let declare_instance_cst glob con =
-  let instance = Typeops.type_of_constant (Global.env ()) con in
+let declare_instance glob g =
+  let c = global g in
+  let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in
   let _, r = decompose_prod_assum instance in
     match class_of_constr r with
-      | Some tc -> add_instance (new_instance tc None glob con)
-      | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.")
+      | Some tc -> add_instance (new_instance tc None glob c)
+      | None -> user_err_loc (loc_of_reference g, "declare_instance",
+			     Pp.str "Constant does not build instances of a declared type class.")
 
-let declare_instance glob idl =
-  let con = 
-    try (match global (Ident idl) with
-      | ConstRef x -> x
-      | _ -> raise Not_found)
-    with _ -> error "Instance definition not found."
-  in declare_instance_cst glob con
-	  
 let mismatched_params env n m = mismatched_ctx_inst env Parameters n m
 let mismatched_props env n m = mismatched_ctx_inst env Properties n m
 
@@ -71,54 +70,53 @@ type binder_list = (identifier located * bool * constr_expr) list
 
 (* Calls to interpretation functions. *)
 
-let interp_type_evars evdref env ?(impls=([],[])) typ =
-  let typ' = intern_gen true ~impls (Evd.evars_of !evdref) env typ in
+let interp_type_evars evdref env ?(impls=empty_internalization_env) typ =
+  let typ' = intern_gen true ~impls !evdref env typ in
   let imps = Implicit_quantifiers.implicits_of_rawterm typ' in
     imps, Pretyping.Default.understand_tcc_evars evdref env Pretyping.IsType typ'
-    
+
 (* Declare everything in the parameters as implicit, and the class instance as well *)
 
 open Topconstr
-    
-let type_ctx_instance isevars env ctx inst subst =
-  let (s, _) = 
-    List.fold_left2
-      (fun (subst, instctx) (na, b, t) ce ->
-	let t' = substl subst t in
-	let c' = 
-	  match b with 
-	  | None -> interp_casted_constr_evars isevars env ce t'
-	  | Some b -> substl subst b
-	in
-	let d = na, Some c', t' in
-	  c' :: subst, d :: instctx)
-      (subst, []) (List.rev ctx) inst
-  in s
+
+let type_ctx_instance evars env ctx inst subst =
+  let rec aux (subst, instctx) l = function
+    (na, b, t) :: ctx ->
+      let t' = substl subst t in
+      let c', l =
+	match b with
+	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
+	| Some b -> substl subst b, l
+      in
+      let d = na, Some c', t' in
+	aux (c' :: subst, d :: instctx) l ctx
+    | [] -> subst
+  in aux (subst, []) inst (List.rev ctx)
 
 let refine_ref = ref (fun _ -> assert(false))
 
 let id_of_class cl =
   match cl.cl_impl with
     | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l
-    | IndRef (kn,i) -> 
+    | IndRef (kn,i) ->
 	let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in
 	  mip.(0).Declarations.mind_typename
     | _ -> assert false
-	
+
 open Pp
 
 let ($$) g f = fun x -> g (f x)
-	
-let instance_hook k pri global imps ?hook cst = 
+
+let instance_hook k pri global imps ?hook cst =
   let inst = Typeclasses.new_instance k pri global cst in
-    Impargs.maybe_declare_manual_implicits false (ConstRef cst) ~enriching:false imps;
+    Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
     Typeclasses.add_instance inst;
     (match hook with Some h -> h cst | None -> ())
 
 let declare_instance_constant k pri global imps ?hook id term termtype =
-  let cdecl = 
+  let cdecl =
     let kind = IsDefinition Instance in
-    let entry = 
+    let entry =
       { const_entry_body   = term;
 	const_entry_type   = Some termtype;
 	const_entry_opaque = false;
@@ -126,137 +124,159 @@ let declare_instance_constant k pri global imps ?hook id term termtype =
     in DefinitionEntry entry, kind
   in
   let kn = Declare.declare_constant id cdecl in
-    Flags.if_verbose Command.definition_message id;
-    instance_hook k pri global imps ?hook kn;
+    Declare.definition_message id;
+    instance_hook k pri global imps ?hook (ConstRef kn);
     id
 
-let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true)
-    ?(tac:Proof_type.tactic option) ?(hook:(Names.constant -> unit) option) pri =
+let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
+    ?(generalize=true)
+    ?(tac:Proof_type.tactic option) ?(hook:(global_reference -> unit) option) pri =
   let env = Global.env() in
-  let isevars = ref (Evd.create_evar_defs Evd.empty) in
-  let tclass = 
+  let evars = ref Evd.empty in
+  let tclass, ids =
     match bk with
     | Implicit ->
 	Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false
-	  (fun avoid (clname, (id, _, t)) -> 
-	    match clname with 
-	    | Some (cl, b) -> 
+	  (fun avoid (clname, (id, _, t)) ->
+	    match clname with
+	    | Some (cl, b) ->
 		let t = CHole (Util.dummy_loc, None) in
 		  t, avoid
 	    | None -> failwith ("new instance: under-applied typeclass"))
 	  cl
-    | Explicit -> cl
+    | Explicit -> cl, Idset.empty
   in
   let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
-  let k, ctx', imps, subst = 
-    let c = Command.generalize_constr_expr tclass ctx in
-    let imps, c' = interp_type_evars isevars env c in
-    let ctx, c = decompose_prod_assum c' in
-    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in
-      cl, ctx, imps, List.rev args
+  let k, cty, ctx', ctx, len, imps, subst =
+    let (env', ctx), imps = interp_context_evars evars env ctx in
+    let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
+    let len = List.length ctx in
+    let imps = imps @ Impargs.lift_implicits len imps' in
+    let ctx', c = decompose_prod_assum c' in
+    let ctx'' = ctx' @ ctx in
+    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
+    let _, args = 
+      List.fold_right (fun (na, b, t) (args, args') ->
+	match b with
+	| None -> (List.tl args, List.hd args :: args')
+	| Some b -> (args, substl args' b :: args'))
+	(snd cl.cl_context) (args, [])
+    in
+      cl, c', ctx', ctx, len, imps, args
   in
-  let id = 
+  let id =
     match snd instid with
-	Name id -> 
+	Name id ->
 	  let sp = Lib.make_path id in
 	    if Nametab.exists_cci sp then
 	      errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists.");
 	    id
-      | Anonymous -> 
+      | Anonymous ->
 	  let i = Nameops.add_suffix (id_of_class k) "_instance_0" in
-	    Termops.next_global_ident_away false i (Termops.ids_of_context env)
+	    Namegen.next_global_ident_away i (Termops.ids_of_context env)
   in
-  let env' = push_rel_context ctx' env in
-  isevars := Evarutil.nf_evar_defs !isevars;
-  isevars := resolve_typeclasses env !isevars;
-  let sigma = Evd.evars_of !isevars in
+  let env' = push_rel_context ctx env in
+  evars := Evarutil.nf_evar_map !evars;
+  evars := resolve_typeclasses env !evars;
+  let sigma =  !evars in
   let subst = List.map (Evarutil.nf_evar sigma) subst in
-    if Lib.is_modtype () then
+    if abstract then
       begin
+	if not (Lib.is_modtype ()) then
+	  error "Declare Instance while not in Module Type.";
 	let _, ty_constr = instance_constructor k (List.rev subst) in
-	let termtype = 
-	  let t = it_mkProd_or_LetIn ty_constr ctx' in
-	    Evarutil.nf_isevar !isevars t
+	let termtype =
+	  let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
+	    Evarutil.nf_evar !evars t
 	in
-	Evarutil.check_evars env Evd.empty !isevars termtype;
+	Evarutil.check_evars env Evd.empty !evars termtype;
 	let cst = Declare.declare_internal_constant id
 	  (Entries.ParameterEntry (termtype,false), Decl_kinds.IsAssumption Decl_kinds.Logical)
-	in instance_hook k None false imps ?hook cst; id
+	in instance_hook k None false imps ?hook (ConstRef cst); id
       end
     else
       begin
-	let props = 
+	let props =
 	  match props with
-	  | CRecord (loc, _, fs) -> 
-	      if List.length fs > List.length k.cl_props then 
+	  | CRecord (loc, _, fs) ->
+	      if List.length fs > List.length k.cl_props then
 		mismatched_props env' (List.map snd fs) k.cl_props;
-	      fs
-	  | _ -> 
-	      if List.length k.cl_props <> 1 then 
-		errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body")
-	      else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props]
+	      Inl fs
+	  | _ -> Inr props
 	in
-	let subst = 
-	  match k.cl_props with 
-	  | [(na,b,ty)] -> 
-	      let term = match props with [] -> CHole (Util.dummy_loc, None) 
-		| [(_,f)] -> f | _ -> assert false in
-	      let ty' = substl subst ty in
-	      let c = interp_casted_constr_evars isevars env' term ty' in
-		c :: subst
-	  | _ ->
-	      let props, rest = 
+	let subst =
+	  match props with
+	  | Inr term ->
+	      let c = interp_casted_constr_evars evars env' term cty in
+		Inr (c, subst)
+	  | Inl props ->
+	      let get_id =
+		function
+		  | Ident id' -> id'
+		  | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
+	      in
+	      let props, rest =
 		List.fold_left
-		  (fun (props, rest) (id,b,_) -> 
-		    try 
-		      let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in
-		      let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in
-			Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs);
-			c :: props, rest'
-		    with Not_found -> 
-		      (CHole (Util.dummy_loc, None) :: props), rest)
+		  (fun (props, rest) (id,b,_) ->
+		    if b = None then
+		      try
+			let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in
+			let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in
+			let (loc, mid) = get_id loc_mid in
+			  Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs);
+			  c :: props, rest'
+		      with Not_found ->
+			(CHole (Util.dummy_loc, None) :: props), rest
+		    else props, rest)
 		  ([], props) k.cl_props
 	      in
-		if rest <> [] then 
-		  unbound_method env' k.cl_impl (fst (List.hd rest))
+		if rest <> [] then
+		  unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
 		else
-		  type_ctx_instance isevars env' k.cl_props props subst
-	in
-	let subst = List.fold_left2 
-	  (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
-	  [] subst (k.cl_props @ snd k.cl_context)
-	in
-	let app, ty_constr = instance_constructor k subst in
-	let termtype = 
-	  let t = it_mkProd_or_LetIn ty_constr ctx' in
-	    Evarutil.nf_isevar !isevars t
+		  Inl (type_ctx_instance evars env' k.cl_props props subst)
+	in	  
+	evars := Evarutil.nf_evar_map !evars;
+	let term, termtype =
+	  match subst with
+	  | Inl subst ->
+	      let subst = List.fold_left2
+		(fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
+		[] subst (k.cl_props @ snd k.cl_context)
+	      in
+	      let app, ty_constr = instance_constructor k subst in
+	      let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
+	      let term = Termops.it_mkLambda_or_LetIn app (ctx' @ ctx) in
+		term, termtype
+	  | Inr (def, subst) ->
+	      let termtype = it_mkProd_or_LetIn cty ctx in
+	      let term = Termops.it_mkLambda_or_LetIn def ctx in
+		term, termtype
 	in
-	let term = Termops.it_mkLambda_or_LetIn app ctx' in
-	isevars := Evarutil.nf_evar_defs !isevars;
-	let term = Evarutil.nf_isevar !isevars term in
-	let evm = Evd.evars_of (undefined_evars !isevars) in
-	Evarutil.check_evars env Evd.empty !isevars termtype;
-	  if evm = Evd.empty then
+	let termtype = Evarutil.nf_evar !evars termtype in
+	let term = Evarutil.nf_evar !evars term in
+	let evm = undefined_evars !evars in
+	Evarutil.check_evars env Evd.empty !evars termtype;
+	  if Evd.is_empty evm then
 	    declare_instance_constant k pri global imps ?hook id term termtype
 	  else begin
-	    isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !isevars;
+	    evars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
 	    let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
 	      Flags.silently (fun () ->
-		Command.start_proof id kind termtype 
-		  (fun _ -> function ConstRef cst -> instance_hook k pri global imps ?hook cst
-		    | _ -> assert false);
-		if props <> [] then 
-		  Pfedit.by (* (Refiner.tclTHEN (Refiner.tclEVARS (Evd.evars_of !isevars)) *)
-		    (!refine_ref (evm, term));
+		Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook);
+		if props <> Inl [] then 
+		  Pfedit.by (* (Refiner.tclTHEN (Refiner.tclEVARS ( !isevars)) *)
+		    (!refine_ref (evm, term))
+		else if Flags.is_auto_intros () then
+		  Pfedit.by (Refiner.tclDO len Tactics.intro);
 		(match tac with Some tac -> Pfedit.by tac | None -> ())) ();
 	      Flags.if_verbose (msg $$ Printer.pr_open_subgoals) ();
 	      id
 	  end
       end
-
+	
 let named_of_rel_context l =
-  let acc, ctx = 
-    List.fold_right 
+  let acc, ctx =
+    List.fold_right
       (fun (na, b, t) (subst, ctx) ->
 	let id = match na with Anonymous -> raise (Invalid_argument "named_of_rel_context") | Name id -> id in
 	let d = (id, Option.map (substl subst) b, substl subst t) in
@@ -274,42 +294,33 @@ let rec list_filter_map f = function
 
 let context ?(hook=fun _ -> ()) l =
   let env = Global.env() in
-  let evars = ref (Evd.create_evar_defs Evd.empty) in
+  let evars = ref Evd.empty in
   let (env', fullctx), impls = interp_context_evars evars env l in
-  let fullctx = Evarutil.nf_rel_context_evar (Evd.evars_of !evars) fullctx in
+  let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in
   let ce t = Evarutil.check_evars env Evd.empty !evars t in
   List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx;
-  let ctx = try named_of_rel_context fullctx with _ -> 
+  let ctx = try named_of_rel_context fullctx with _ ->
     error "Anonymous variables not allowed in contexts."
   in
-  let env = push_named_context ctx env in
-  let keeps = 
-    List.fold_left (fun acc (id,_,t) ->
-      match class_of_constr t with
-      | None -> acc
-      | Some _ -> List.map pi1 (keep_hyps env (Idset.singleton id)) :: acc)
-      [] ctx
-  in
-    List.iter (function (id,_,t) -> 
-      if Lib.is_modtype () then 
-	let cst = Declare.declare_internal_constant id
-	  (ParameterEntry (t,false), IsAssumption Logical)
-	in
-	  match class_of_constr t with
-	    | Some tc ->
-		add_instance (Typeclasses.new_instance tc None false cst);
-		hook (ConstRef cst)
-	    | None -> ()
-      else (
-	let impl = List.exists (fun (x,_) -> 
-	  match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls 
-	and keep = 
-	  let l = list_filter_map (fun ids -> if List.mem id ids then Some ids else None) keeps in
-	    List.concat l
-	in
-	  Command.declare_one_assumption false (Local (* global *), Definitional) t
-	    [] impl (* implicit *) keep (* always kept *) false (* inline *) (dummy_loc, id);
-	  match class_of_constr t with
-	  | None -> ()
-	  | Some tc -> hook (VarRef id)))
-      (List.rev ctx)
+  let fn (id, _, t) =
+    if Lib.is_modtype () && not (Lib.sections_are_opened ()) then
+      let cst = Declare.declare_internal_constant id
+	(ParameterEntry (t,false), IsAssumption Logical)
+      in
+	match class_of_constr t with
+	| Some tc ->
+	    add_instance (Typeclasses.new_instance tc None false (ConstRef cst));
+	    hook (ConstRef cst)
+	| None -> ()
+    else (
+      let impl = List.exists 
+	(fun (x,_) ->
+	   match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls
+      in
+	Command.declare_assumption false (Local (* global *), Definitional) t
+	  [] impl (* implicit *) false (* inline *) (dummy_loc, id);
+	match class_of_constr t with
+	| None -> ()
+	| Some tc -> hook (VarRef id))
+  in List.iter fn (List.rev ctx)
+	
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
index 1bbf29a6..b8b104d4 100644
--- a/toplevel/classes.mli
+++ b/toplevel/classes.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -21,6 +21,7 @@ open Topconstr
 open Util
 open Typeclasses
 open Implicit_quantifiers
+open Libnames
 (*i*)
 
 (* Errors *)
@@ -29,39 +30,48 @@ val mismatched_params : env -> constr_expr list -> rel_context -> 'a
 
 val mismatched_props : env -> constr_expr list -> rel_context -> 'a
 
+(* Post-hoc class declaration. *)
+
+val declare_class : reference -> unit
+
 (* Instance declaration *)
 
-val declare_instance : bool -> identifier located -> unit
+val declare_instance : bool -> reference -> unit
 
 val declare_instance_constant :
   typeclass ->
   int option -> (* priority *)
   bool -> (* globality *)
   Impargs.manual_explicitation list -> (* implicits *)
-  ?hook:(Names.constant -> unit) ->
+  ?hook:(Libnames.global_reference -> unit) ->
   identifier -> (* name *)
   Term.constr -> (* body *)
   Term.types -> (* type *)
   Names.identifier
-    
-val new_instance : 
+
+val new_instance :
+  ?abstract:bool -> (* Not abstract by default. *)
   ?global:bool -> (* Not global by default. *)
   local_binder list ->
   typeclass_constraint ->
   constr_expr ->
   ?generalize:bool ->
   ?tac:Proof_type.tactic  ->
-  ?hook:(constant -> unit) ->
+  ?hook:(Libnames.global_reference -> unit) ->
   int option ->
   identifier
 
+(* Setting opacity *)
+
+val set_typeclass_transparency : evaluable_global_reference -> bool -> unit
+
 (* For generation on names based on classes only *)
 
 val id_of_class : typeclass -> identifier
 
-(* Context command *)    
+(* Context command *)
 
-val context : ?hook:(Libnames.global_reference -> unit) -> 
+val context : ?hook:(Libnames.global_reference -> unit) ->
   local_binder list -> unit
 
 (* Forward ref for refine *)
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 05a22829..700efc99 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -6,63 +6,32 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: command.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Flags
 open Term
 open Termops
-open Declarations
 open Entries
-open Inductive
 open Environ
-open Reduction
 open Redexpr
 open Declare
-open Nametab
 open Names
 open Libnames
 open Nameops
 open Topconstr
-open Library
-open Libobject
 open Constrintern
-open Proof_type
-open Tacmach
-open Safe_typing
 open Nametab
 open Impargs
-open Typeops
 open Reductionops
 open Indtypes
-open Vernacexpr
 open Decl_kinds
 open Pretyping
 open Evarutil
 open Evarconv
 open Notation
-open Goptions
-open Mod_subst
-open Evd
-open Decls
-
-let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,default_binder_kind,a,b))
-let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,default_binder_kind,a,b))
-
-let rec abstract_constr_expr c = function
-  | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl)
-  | LocalRawAssum (idl,k,t)::bl ->
-      List.fold_right (fun x b -> mkLambdaC([x],k,t,b)) idl
-        (abstract_constr_expr c bl)
-
-let rec generalize_constr_expr c = function
-  | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,generalize_constr_expr c bl)
-  | LocalRawAssum (idl,k,t)::bl ->
-      List.fold_right (fun x b -> mkProdC([x],k,t,b)) idl
-        (generalize_constr_expr c bl)
+open Indschemes
 
 let rec under_binders env f n c =
   if n = 0 then f env Evd.empty c else
@@ -73,14 +42,6 @@ let rec under_binders env f n c =
 	  mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c)
       | _ -> assert false
 
-let rec destSubCast c = match kind_of_term c with
-  | Lambda (x,t,c) -> 
-      let (b,u) = destSubCast c in mkLambda (x,t,b), mkProd (x,t,u)
-  | LetIn (x,b,t,c) ->
-      let (d,u) = destSubCast c in mkLetIn (x,b,t,d), mkLetIn (x,b,t,u)
-  | Cast (b,_, u) -> (b,u)
-  | _ -> assert false
-
 let rec complete_conclusion a cs = function
   | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c)
   | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c)
@@ -98,92 +59,86 @@ let rec complete_conclusion a cs = function
 
 (* 1| Constant definitions *)
 
-let definition_message id =
-  if_verbose message ((string_of_id id) ^ " is defined")
+let red_constant_entry n ce = function
+  | None -> ce
+  | Some red ->
+      let body = ce.const_entry_body in
+      { ce with const_entry_body =
+	under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body }
 
-let constant_entry_of_com (bl,com,comtypopt,opacity,boxed) =
+let interp_definition boxed bl red_option c ctypopt =
   let env = Global.env() in
-    match comtypopt with
-      None -> 
-	let b = abstract_constr_expr com bl in
-	let b, imps = interp_constr_evars_impls env b in
-	  imps,
-	{ const_entry_body = b;
+  let evdref = ref Evd.empty in
+  let (env_bl, ctx), imps1 =
+    interp_context_evars ~fail_anonymous:false evdref env bl in
+  let imps,ce =
+    match ctypopt with
+      None ->
+	let c, imps2 = interp_constr_evars_impls ~evdref ~fail_evar:false env_bl c in
+	let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in
+	check_evars env Evd.empty !evdref body;
+	imps1@imps2,
+	{ const_entry_body = body;
 	  const_entry_type = None;
-          const_entry_opaque = opacity;
+          const_entry_opaque = false;
 	  const_entry_boxed = boxed }
-    | Some comtyp ->
-	(* We use a cast to avoid troubles with evars in comtyp *)
-	(* that can only be resolved knowing com *)
-	let b = abstract_constr_expr (mkCastC (com, Rawterm.CastConv (DEFAULTcast,comtyp))) bl in
-	let b, imps = interp_constr_evars_impls env b in
-	let (body,typ) = destSubCast b in
-	  imps,
+    | Some ctyp ->
+	let ty, impls = interp_type_evars_impls ~evdref ~fail_evar:false env_bl ctyp in
+	let c, imps2 = interp_casted_constr_evars_impls ~evdref ~fail_evar:false env_bl c ty in
+	let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in
+	let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in
+	check_evars env Evd.empty !evdref body;
+	check_evars env Evd.empty !evdref typ;
+	imps1@imps2,
 	{ const_entry_body = body;
 	  const_entry_type = Some typ;
-          const_entry_opaque = opacity;
+          const_entry_opaque = false;
 	  const_entry_boxed = boxed }
+  in
+  red_constant_entry (rel_context_length ctx) ce red_option, imps
 
-let red_constant_entry bl ce = function
-  | None -> ce
-  | Some red ->
-      let body = ce.const_entry_body in
-      { ce with const_entry_body = 
-	under_binders (Global.env()) (fst (reduction_of_red_expr red))
-	  (local_binders_length bl)
-	  body }
-
-let declare_global_definition ident ce local imps =
-  let kn = declare_constant ident (DefinitionEntry ce,IsDefinition Definition) in
+let declare_global_definition ident ce local k imps =
+  let kn = declare_constant ident (DefinitionEntry ce,IsDefinition k) in
   let gr = ConstRef kn in
     maybe_declare_manual_implicits false gr imps;
     if local = Local && Flags.is_verbose() then
       msg_warning (pr_id ident ++ str" is declared as a global definition");
     definition_message ident;
+    Autoinstance.search_declaration (ConstRef kn);
     gr
 
 let declare_definition_hook = ref ignore
 let set_declare_definition_hook = (:=) declare_definition_hook
 let get_declare_definition_hook () = !declare_definition_hook
 
-let declare_definition ident (local,boxed,dok) bl red_option c typopt hook =
-  let imps, ce = constant_entry_of_com (bl,c,typopt,false,boxed) in
-  let ce' = red_constant_entry bl ce red_option in
-  !declare_definition_hook ce';
+let declare_definition ident (local,k) ce imps hook =
+  !declare_definition_hook ce;
   let r = match local with
     | Local when Lib.sections_are_opened () ->
         let c =
-          SectionLocalDef(ce'.const_entry_body,ce'.const_entry_type,false) in
-        let _ = declare_variable ident (Lib.cwd(),c,IsDefinition Definition) in
+          SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in
+        let _ = declare_variable ident (Lib.cwd(),c,IsDefinition k) in
         definition_message ident;
-        if Pfedit.refining () then 
-          Flags.if_verbose msg_warning 
-	    (str"Local definition " ++ pr_id ident ++ 
+        if Pfedit.refining () then
+          Flags.if_verbose msg_warning
+	    (str"Local definition " ++ pr_id ident ++
              str" is not visible from current goals");
         VarRef ident
     | (Global|Local) ->
-        declare_global_definition ident ce' local imps in
+        declare_global_definition ident ce local k imps in
   hook local r
 
-let syntax_definition ident (vars,c) local onlyparse =
-  let ((vars,_),pat) = interp_aconstr [] (vars,[]) c in
-  let onlyparse = onlyparse or Metasyntax.is_not_printable pat in
-  Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
-
 (* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
 
-let assumption_message id =
-  if_verbose message ((string_of_id id) ^ " is assumed")
-
-let declare_one_assumption is_coe (local,kind) c imps impl keep nl (_,ident) =
+let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) =
   let r = match local with
     | Local when Lib.sections_are_opened () ->
-        let _ = 
-          declare_variable ident 
-            (Lib.cwd(), SectionLocalAssum (c,impl,keep), IsAssumption kind) in
+        let _ =
+          declare_variable ident
+            (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in
         assumption_message ident;
-        if is_verbose () & Pfedit.refining () then 
-          msgerrnl (str"Warning: Variable " ++ pr_id ident ++ 
+        if is_verbose () & Pfedit.refining () then
+          msgerrnl (str"Warning: Variable " ++ pr_id ident ++
           str" is not visible from current goals");
         VarRef ident
     | (Global|Local) ->
@@ -195,283 +150,26 @@ let declare_one_assumption is_coe (local,kind) c imps impl keep nl (_,ident) =
         if local=Local & Flags.is_verbose () then
           msg_warning (pr_id ident ++ str" is declared as a parameter" ++
           str" because it is at a global level");
+	Autoinstance.search_declaration (ConstRef kn);
         gr in
   if is_coe then Class.try_add_new_coercion r local
 
-let declare_assumption_hook = ref ignore
-let set_declare_assumption_hook = (:=) declare_assumption_hook
-
-let declare_assumption idl is_coe k bl c impl keep nl =
-  if not (Pfedit.refining ()) then 
-    let c = generalize_constr_expr c bl in
-    let env = Global.env () in
-    let c', imps = interp_type_evars_impls env c in
-      !declare_assumption_hook c';
-      List.iter (declare_one_assumption is_coe k c' imps impl keep nl) idl
-  else
-    errorlabstrm "Command.Assumption"
-	(str "Cannot declare an assumption while in proof editing mode.")
-
-(* 3a| Elimination schemes for mutual inductive definitions *)
-
-open Indrec
-open Inductiveops
+let declare_assumptions_hook = ref ignore
+let set_declare_assumptions_hook = (:=) declare_assumptions_hook
 
+let interp_assumption bl c =
+  let c = prod_constr_expr c bl in
+  let env = Global.env () in
+  interp_type_evars_impls env c
 
-let non_type_eliminations = 
-  [ (InProp,elimination_suffix InProp);
-    (InSet,elimination_suffix InSet) ]
+let declare_assumptions idl is_coe k c imps impl_is_on nl =
+  !declare_assumptions_hook c;
+  List.iter (declare_assumption is_coe k c imps impl_is_on nl) idl
 
-let declare_one_elimination ind =
-  let (mib,mip) = Global.lookup_inductive ind in 
-  let mindstr = string_of_id mip.mind_typename in
-  let declare s c t =
-    let id = id_of_string s in
-    let kn = Declare.declare_internal_constant id
-      (DefinitionEntry
-        { const_entry_body = c;
-          const_entry_type = t;
-          const_entry_opaque = false;
-	  const_entry_boxed = Flags.boxed_definitions() }, 
-       Decl_kinds.IsDefinition Definition) in
-    definition_message id;
-    kn
-  in
-  let env = Global.env () in
-  let sigma = Evd.empty in
-  let elim_scheme = Indrec.build_indrec env sigma ind in
-  let npars = 
-    (* if a constructor of [ind] contains a recursive call, the scheme
-       is generalized only wrt recursively uniform parameters *)
-    if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) 
-    then 
-      mib.mind_nparams_rec
-    else 
-      mib.mind_nparams in
-  let make_elim s = Indrec.instantiate_indrec_scheme s npars elim_scheme in
-  let kelim = elim_sorts (mib,mip) in
-    (* in case the inductive has a type elimination, generates only one
-       induction scheme, the other ones share the same code with the
-       apropriate type *)
-  if List.mem InType kelim then
-    let elim = make_elim (new_sort_in_family InType) in
-    let cte = declare (mindstr^(Indrec.elimination_suffix InType)) elim None in
-    let c = mkConst cte in
-    let t = type_of_constant (Global.env()) cte in
-    List.iter (fun (sort,suff) -> 
-      let (t',c') = 
-	Indrec.instantiate_type_indrec_scheme (new_sort_in_family sort)
-	  npars c t in
-      let _ = declare (mindstr^suff) c' (Some t') in ())
-      non_type_eliminations
-   else (* Impredicative or logical inductive definition *)
-     List.iter
-    (fun (sort,suff) -> 
-       if List.mem sort kelim then
-	 let elim = make_elim (new_sort_in_family sort) in
-	 let _ = declare (mindstr^suff) elim None in ())
-       non_type_eliminations
-
-(* bool eq declaration flag && eq dec declaration flag *)
-let eq_flag = ref false 
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optname  = "automatic declaration of boolean equality";
-      optkey   = (SecondaryTable ("Equality","Scheme"));
-      optread  = (fun () -> !eq_flag) ;
-      optwrite = (fun b -> eq_flag := b) }
-
-(* boolean equality *)
-let (inScheme,outScheme) =  
-  declare_object {(default_object "EQSCHEME") with 
-                    cache_function = Ind_tables.cache_scheme; 
-                    load_function = (fun _ -> Ind_tables.cache_scheme); 
-                    subst_function = Auto_ind_decl.subst_in_constr; 
-                    export_function = Ind_tables.export_scheme } 
-
-let declare_eq_scheme sp = 
-  let mib = Global.lookup_mind sp in
-  let nb_ind = Array.length mib.mind_packets in
-  let eq_array = Auto_ind_decl.make_eq_scheme sp in
-  try
-    for i=0 to (nb_ind-1) do
-    let cpack = Array.get mib.mind_packets i in
-    let nam = id_of_string ((string_of_id cpack.mind_typename)^"_beq")
-    in
-      let cst_entry = {const_entry_body = eq_array.(i);
-                       const_entry_type = None;
-                       const_entry_opaque = false;
-                       const_entry_boxed = Flags.boxed_definitions() } 
-      in
-      let cst_decl =  (DefinitionEntry cst_entry),(IsDefinition Definition)
-      in
-        let cst = Declare.declare_constant nam cst_decl in
-          Lib.add_anonymous_leaf (inScheme ((sp,i),mkConst cst));
-          definition_message nam
-    done
-  with Not_found -> 
-    error "Your type contains Parameters without a boolean equality."
-
-(* decidability of eq *)
-
-
-let (inBoolLeib,outBoolLeib) =
-  declare_object {(default_object "BOOLLIEB") with
-                    cache_function = Ind_tables.cache_bl;
-                    load_function = (fun _ -> Ind_tables.cache_bl);
-                    subst_function = Auto_ind_decl.subst_in_constr;
-                    export_function = Ind_tables.export_bool_leib }
-
-let (inLeibBool,outLeibBool) =
-  declare_object {(default_object "LIEBBOOL") with
-                    cache_function = Ind_tables.cache_lb;
-                    load_function = (fun _ -> Ind_tables.cache_lb);
-                    subst_function = Auto_ind_decl.subst_in_constr;
-                    export_function = Ind_tables.export_leib_bool }
-
-let (inDec,outDec) =
-  declare_object {(default_object "EQDEC") with
-                    cache_function = Ind_tables.cache_dec;
-                    load_function = (fun _ -> Ind_tables.cache_dec);
-                    subst_function = Auto_ind_decl.subst_in_constr;
-                    export_function = Ind_tables.export_dec_proof }
-
-let start_hook = ref ignore
-let set_start_hook = (:=) start_hook
-
-let start_proof id kind c ?init_tac ?(compute_guard=false) hook =
-  let sign = Global.named_context () in
-  let sign = clear_proofs sign in
-  !start_hook c;
-  Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook
-
-let adjust_guardness_conditions const =
-  (* Try all combinations... not optimal *)
-  match kind_of_term const.const_entry_body with
-  | Fix ((nv,0),(_,_,fixdefs as fixdecls)) ->
-      let possible_indexes =
-	List.map (fun c ->
-	  interval 0 (List.length (fst (Sign.decompose_lam_assum c))))
-	  (Array.to_list fixdefs) in
-      let indexes = search_guard dummy_loc (Global.env()) possible_indexes fixdecls in 
-      { const with const_entry_body = mkFix ((indexes,0),fixdecls) }
-  | c -> const
-
-let save id const do_guard (locality,kind) hook =
-  let const = if do_guard then adjust_guardness_conditions const else const in
-  let {const_entry_body = pft;
-       const_entry_type = tpo;
-       const_entry_opaque = opacity } = const in
-  let k = logical_kind_of_goal_kind kind in
-  let l,r = match locality with
-    | Local when Lib.sections_are_opened () ->
-	let c = SectionLocalDef (pft, tpo, opacity) in
-	let _ = declare_variable id (Lib.cwd(), c, k) in
-	(Local, VarRef id)
-    | Local | Global ->
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn) in
-  Pfedit.delete_current_proof ();
-  definition_message id;
-  hook l r
-
-let save_hook = ref ignore
-let set_save_hook f = save_hook := f
-
-let save_named opacity =
-  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
-  let const = { const with const_entry_opaque = opacity } in
-  save id const do_guard persistence hook
-
-let make_eq_decidability ind = 
-    (* fetching data *)
-    let mib = Global.lookup_mind (fst ind) in
-    let nparams = mib.mind_nparams in
-    let nparrec = mib.mind_nparams_rec in
-    let lnonparrec,lnamesparrec = 
-      context_chop (nparams-nparrec) mib.mind_params_ctxt in
-    let proof_name = (string_of_id(
-          Array.get mib.mind_packets (snd ind)).mind_typename)^"_eq_dec" in
-    let bl_name  =(string_of_id(
-          Array.get mib.mind_packets (snd ind)).mind_typename)^"_dec_bl" in
-    let lb_name  =(string_of_id(
-          Array.get mib.mind_packets (snd ind)).mind_typename)^"_dec_lb" in
-  (* main calls*)
-    if Ind_tables.check_bl_proof ind
-    then (message (bl_name^" is already declared."))
-    else (
-      start_proof (id_of_string bl_name)
-         (Global,Proof Theorem)
-         (Auto_ind_decl.compute_bl_goal ind lnamesparrec nparrec)  
-            (fun _ _ -> ());
-      Auto_ind_decl.compute_bl_tact ind lnamesparrec nparrec;
-      save_named true; 
-      Lib.add_anonymous_leaf 
-        (inBoolLeib (ind,mkConst (Lib.make_con (id_of_string bl_name))))
-(*        definition_message (id_of_string bl_name) *)
-    );
-    if Ind_tables.check_lb_proof ind 
-    then (message (lb_name^" is already declared."))
-    else (
-      start_proof (id_of_string lb_name)
-        (Global,Proof Theorem) 
-        (Auto_ind_decl.compute_lb_goal ind lnamesparrec nparrec)
-        ( fun _ _ -> ());
-      Auto_ind_decl.compute_lb_tact ind lnamesparrec nparrec;
-      save_named true;
-      Lib.add_anonymous_leaf 
-        (inLeibBool (ind,mkConst (Lib.make_con (id_of_string lb_name))))
-(*      definition_message (id_of_string lb_name) *)
-    );
-    if Ind_tables.check_dec_proof ind
-    then (message (proof_name^" is already declared."))
-    else (
-      start_proof (id_of_string proof_name)
-        (Global,Proof Theorem) 
-        (Auto_ind_decl.compute_dec_goal ind lnamesparrec nparrec)
-        ( fun _ _ -> ());
-      Auto_ind_decl.compute_dec_tact ind lnamesparrec nparrec;
-      save_named true;
-      Lib.add_anonymous_leaf 
-        (inDec (ind,mkConst (Lib.make_con (id_of_string proof_name))))
-(*      definition_message (id_of_string proof_name) *)
-  )
-
-(* end of automated definition on ind*)
-
-let declare_eliminations sp =
-  let mib = Global.lookup_mind sp in
-  if mib.mind_finite then begin
-    if (!eq_flag) then (declare_eq_scheme sp);
-    for i = 0 to Array.length mib.mind_packets - 1 do
-      declare_one_elimination (sp,i);
-      try
-        if (!eq_flag) then (make_eq_decidability (sp,i))
-      with _ -> 
-          Pfedit.delete_current_proof();
-          message "Error while computing decidability scheme. Please report."
-    done;
-  end
+(* 3a| Elimination schemes for mutual inductive definitions *)
 
 (* 3b| Mutual inductive definitions *)
 
-let compute_interning_datas env ty l nal typl impll =
-  let mk_interning_data na typ impls =
-    let idl, impl =
-      let impl = 
-	compute_implicits_with_manual env typ (is_implicit_args ()) impls
-      in 
-      let sub_impl,_ = list_chop (List.length l) impl in
-      let sub_impl' = List.filter is_status_implicit sub_impl in
-	(List.map name_of_implicit sub_impl', impl)
-    in
-      (na, (ty, idl, impl, compute_arguments_scope typ)) in
-  (l, list_map3 mk_interning_data nal typl impll)
-
-let declare_interning_data (_,impls) (df,c,scope) =
-  silently (Metasyntax.add_notation_interpretation df impls c) scope
-
 let push_named_types env idl tl =
   List.fold_left2 (fun env id t -> Environ.push_named (id,None,t) env)
     env idl tl
@@ -480,16 +178,19 @@ let push_types env idl tl =
   List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env)
     env idl tl
 
-type inductive_expr = {
+type structured_one_inductive_expr = {
   ind_name : identifier;
   ind_arity : constr_expr;
   ind_lc : (identifier * constr_expr) list
 }
 
+type structured_inductive_expr =
+  local_binder list * structured_one_inductive_expr list
+
 let minductive_message = function
   | []  -> error "No inductive definition."
   | [x] -> (pr_id x ++ str " is defined")
-  | l   -> hov 0  (prlist_with_sep pr_coma pr_id l ++
+  | l   -> hov 0  (prlist_with_sep pr_comma pr_id l ++
 		     spc () ++ str "are defined")
 
 let check_all_names_different indl =
@@ -503,15 +204,15 @@ let check_all_names_different indl =
   if l <> [] then raise (InductiveError (SameNamesOverlap l))
 
 let mk_mltype_data evdref env assums arity indname =
-  let is_ml_type = is_sort env (evars_of !evdref) arity in
+  let is_ml_type = is_sort env !evdref arity in
   (is_ml_type,indname,assums)
 
 let prepare_param = function
-  | (na,None,t) -> out_name na, LocalAssum t 
+  | (na,None,t) -> out_name na, LocalAssum t
   | (na,Some b,_) -> out_name na, LocalDef b
 
 let interp_ind_arity evdref env ind =
-  interp_type_evars evdref env ind.ind_arity
+  interp_type_evars_impls ~evdref env ind.ind_arity
 
 let interp_cstrs evdref env impls mldata arity ind =
   let cnames,ctyps = List.split ind.ind_lc in
@@ -521,12 +222,12 @@ let interp_cstrs evdref env impls mldata arity ind =
   let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls ~evdref env ~impls) ctyps') in
     (cnames, ctyps'', cimpls)
 
-let interp_mutual paramsl indl notations finite = 
+let interp_mutual_inductive (paramsl,indl) notations finite =
   check_all_names_different indl;
   let env0 = Global.env() in
-  let evdref = ref (Evd.create_evar_defs Evd.empty) in
-  let (env_params, ctx_params), userimpls = 
-    interp_context_evars ~fail_anonymous:false evdref env0 paramsl 
+  let evdref = ref Evd.empty in
+  let (env_params, ctx_params), userimpls =
+    interp_context_evars ~fail_anonymous:false evdref env0 paramsl
   in
   let indnames = List.map (fun ind -> ind.ind_name) indl in
 
@@ -536,19 +237,20 @@ let interp_mutual paramsl indl notations finite =
 
   (* Interpret the arities *)
   let arities = List.map (interp_ind_arity evdref env_params) indl in
-  let fullarities = List.map (fun c -> it_mkProd_or_LetIn c ctx_params) arities in
+  let fullarities = List.map (fun (c, _) -> it_mkProd_or_LetIn c ctx_params) arities in
   let env_ar = push_types env0 indnames fullarities in
   let env_ar_params = push_rel_context ctx_params env_ar in
 
   (* Compute interpretation metadatas *)
-  let indimpls = List.map (fun _ -> userimpls) fullarities in
-  let impls = compute_interning_datas env0 Inductive params indnames fullarities indimpls in
+  let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (List.length userimpls) impls) arities in
+  let arities = List.map fst arities in
+  let impls = compute_full_internalization_env env0 Inductive params indnames fullarities indimpls in
   let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
 
   let constructors =
-    States.with_state_protection (fun () -> 
+    States.with_state_protection (fun () ->
      (* Temporary declaration of notations and scopes *)
-     List.iter (declare_interning_data impls) notations;
+     List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
      (* Interpret the constructor types *)
      list_map3 (interp_cstrs evdref env_ar_params impls) mldatas arities indl)
      () in
@@ -556,7 +258,7 @@ let interp_mutual paramsl indl notations finite =
   (* Instantiate evars and check all are resolved *)
   let evd,_ = consider_remaining_unif_problems env_params !evdref in
   let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in
-  let sigma = evars_of evd in
+  let sigma =  evd in
   let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in
   let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in
   let arities = List.map (nf_evar sigma) arities in
@@ -565,7 +267,7 @@ let interp_mutual paramsl indl notations finite =
   List.iter (fun (_,ctyps,_) ->
     List.iter (check_evars env_ar_params Evd.empty evd) ctyps)
     constructors;
-  
+
   (* Build the inductive entries *)
   let entries = list_map3 (fun ind arity (cnames,ctypes,cimpls) -> {
     mind_entry_typename = ind.ind_name;
@@ -573,17 +275,17 @@ let interp_mutual paramsl indl notations finite =
     mind_entry_consnames = cnames;
     mind_entry_lc = ctypes
   }) indl arities constructors in
-  let impls = 
+  let impls =
     let len = List.length ctx_params in
-      List.map (fun (_,_,impls) ->
-	userimpls, List.map (fun impls -> 
-	  userimpls @ (lift_implicits len impls)) impls) constructors
+      List.map2 (fun indimpls (_,_,cimpls) ->
+	indimpls, List.map (fun impls ->
+	  userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors
   in
   (* Build the mutual inductive entry *)
   { mind_entry_params = List.map prepare_param ctx_params;
-    mind_entry_record = false; 
-    mind_entry_finite = finite; 
-    mind_entry_inds = entries }, 
+    mind_entry_record = false;
+    mind_entry_finite = finite;
+    mind_entry_inds = entries },
     impls
 
 let eq_constr_expr c1 c2 =
@@ -604,7 +306,7 @@ let eq_local_binders bl1 bl2 =
   List.length bl1 = List.length bl2 && List.for_all2 eq_local_binder bl1 bl2
 
 let extract_coercions indl =
-  let mkqid (_,((_,id),_)) = make_short_qualid id in
+  let mkqid (_,((_,id),_)) = qualid_of_ident id in
   let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in
   List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl))
 
@@ -613,88 +315,64 @@ let extract_params indl =
   match paramsl with
   | [] -> anomaly "empty list of inductive types"
   | params::paramsl ->
-      if not (List.for_all (eq_local_binders params) paramsl) then error 
+      if not (List.for_all (eq_local_binders params) paramsl) then error
 	"Parameters should be syntactically the same for each inductive type.";
       params
 
-let prepare_inductive ntnl indl =
-  let indl =
-    List.map (fun ((_,indname),_,ar,lc) -> { 
-      ind_name = indname;
-      ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar;
-      ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
-    }) indl in
-  List.fold_right Option.List.cons ntnl [], indl
-
-
-let elim_flag = ref true
-let _ =
-  declare_bool_option 
-    { optsync  = true;
-      optname  = "automatic declaration of eliminations";
-      optkey   = (SecondaryTable ("Elimination","Schemes"));
-      optread  = (fun () -> !elim_flag) ;
-      optwrite = (fun b -> elim_flag := b) }
-
-let declare_mutual_with_eliminations isrecord mie impls =
+let extract_inductive indl =
+  List.map (fun ((_,indname),_,ar,lc) -> {
+    ind_name = indname;
+    ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar;
+    ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
+  }) indl
+
+let extract_mutual_inductive_declaration_components indl =
+  let indl,ntnl = List.split indl in
+  let params = extract_params indl in
+  let coes = extract_coercions indl in
+  let indl = extract_inductive indl in
+  (params,indl), coes, List.flatten ntnl
+
+let declare_mutual_inductive_with_eliminations isrecord mie impls =
   let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
-  let (_,kn) = declare_mind isrecord mie in    
-    list_iter_i (fun i (indimpls, constrimpls) -> 
-      let ind = (kn,i) in
-	maybe_declare_manual_implicits false (IndRef ind) indimpls;
-	list_iter_i
-	  (fun j impls -> 
-	    maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls)
-	  constrimpls)
+  let (_,kn) = declare_mind isrecord mie in
+  let mind = Global.mind_of_delta (mind_of_kn kn) in
+  list_iter_i (fun i (indimpls, constrimpls) ->
+		   let ind = (mind,i) in
+		     Autoinstance.search_declaration (IndRef ind);
+		     maybe_declare_manual_implicits false (IndRef ind) indimpls;
+		     list_iter_i
+		       (fun j impls ->
+(*	    Autoinstance.search_declaration (ConstructRef (ind,j));*)
+			  maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls)
+		       constrimpls)
       impls;
-    if_verbose ppnl (minductive_message names);
-    if !elim_flag then declare_eliminations kn;
-    kn
+  if_verbose ppnl (minductive_message names);
+  declare_default_schemes mind;
+  mind
 
-let build_mutual l finite =
-  let indl,ntnl = List.split l in
-  let paramsl = extract_params indl in
-  let coes = extract_coercions indl in
-  let notations,indl = prepare_inductive ntnl indl in
-  let mie,impls = interp_mutual paramsl indl notations finite in
-  (* Declare the mutual inductive block with its eliminations *)
-  ignore (declare_mutual_with_eliminations false mie impls);
+open Vernacexpr
+
+type one_inductive_impls =
+  Impargs.manual_explicitation list (* for inds *)*
+  Impargs.manual_explicitation list list (* for constrs *)
+
+type one_inductive_expr =
+  lident * local_binder list * constr_expr option * constructor_expr list
+
+let do_mutual_inductive indl finite =
+  let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in
+  (* Interpret the types *)
+  let mie,impls = interp_mutual_inductive indl ntns finite in
+  (* Declare the mutual inductive block with its associated schemes *)
+  ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls);
   (* Declare the possible notations of inductive types *)
-  List.iter (declare_interning_data ([],[])) notations;
+  List.iter Metasyntax.add_notation_interpretation ntns;
   (* Declare the coercions *)
   List.iter (fun qid -> Class.try_add_new_coercion (locate qid) Global) coes
 
 (* 3c| Fixpoints and co-fixpoints *)
 
-let pr_rank = function 
-  | 0 -> str "1st"
-  | 1 -> str "2nd"
-  | 2 -> str "3rd"
-  | n -> str ((string_of_int (n+1))^"th")
-
-let recursive_message indexes = function
-  | [] -> anomaly "no recursive definition"
-  | [id] -> pr_id id ++ str " is recursively defined" ++
-      (match indexes with 
-	 | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)"
- 	 | _ -> mt ())
-  | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++
-		  spc () ++ str "are recursively defined" ++
-		  match indexes with 
-		    | Some a -> spc () ++ str "(decreasing respectively on " ++
-			prlist_with_sep pr_coma pr_rank (Array.to_list a) ++
-			str " arguments)"
-		    | None -> mt ())
-
-let corecursive_message _ = function
-  | [] -> error "No corecursive definition."
-  | [id] -> pr_id id ++ str " is corecursively defined"
-  | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++
-                    spc () ++ str "are corecursively defined")
-
-let recursive_message isfix = 
-  if isfix=Fixpoint then recursive_message else corecursive_message
-
 (* An (unoptimized) function that maps preorders to partial orders...
 
    Input:  a list of associations (x,[y1;...;yn]), all yi distincts
@@ -717,11 +395,11 @@ let rec partial_order = function
 	  | (z, Inr zge) when List.mem x zge -> (z, Inr (list_union zge xge'))
 	  | r -> r) res in
 	(x,Inr xge')::res
-    | y::xge -> 
-      let rec link y = 
+    | y::xge ->
+      let rec link y =
 	try match List.assoc y res with
 	| Inl z -> link z
-	| Inr yge -> 
+	| Inr yge ->
 	  if List.mem x yge then
 	    let res = List.remove_assoc y res in
 	    let res = List.map (function
@@ -737,43 +415,41 @@ let rec partial_order = function
 	    browse res (list_add_set y (list_union xge' yge)) xge
 	with Not_found -> browse res (list_add_set y xge') xge
       in link y
-    in browse (partial_order rest) [] xge 
+    in browse (partial_order rest) [] xge
 
-let non_full_mutual_message x xge y yge kind rest =
-  let reason = 
-    if List.mem x yge then 
+let non_full_mutual_message x xge y yge isfix rest =
+  let reason =
+    if List.mem x yge then
       string_of_id y^" depends on "^string_of_id x^" but not conversely"
-    else if List.mem y xge then 
+    else if List.mem y xge then
       string_of_id x^" depends on "^string_of_id y^" but not conversely"
     else
       string_of_id y^" and "^string_of_id x^" are not mutually dependent" in
   let e = if rest <> [] then "e.g.: "^reason else reason in
-  let k = if kind=Fixpoint then "fixpoint" else "cofixpoint" in
+  let k = if isfix then "fixpoint" else "cofixpoint" in
   let w =
-    if kind=Fixpoint then "Well-foundedness check may fail unexpectedly.\n"
-    else "" in
-  "Not a fully mutually defined "^k^"\n("^e^").\n"^w
+    if isfix
+    then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl()
+    else mt () in
+  strbrk ("Not a fully mutually defined "^k) ++ fnl () ++
+  strbrk ("("^e^").") ++ fnl () ++ w
 
-let check_mutuality env kind fixl =
+let check_mutuality env isfix fixl =
   let names = List.map fst fixl in
   let preorder =
-    List.map (fun (id,def) -> 
+    List.map (fun (id,def) ->
       (id, List.filter (fun id' -> id<>id' & occur_var env id' def) names))
       fixl in
   let po = partial_order preorder in
   match List.filter (function (_,Inr _) -> true | _ -> false) po with
     | (x,Inr xge)::(y,Inr yge)::rest ->
-	if_verbose warning (non_full_mutual_message x xge y yge kind rest)
+	if_verbose msg_warning (non_full_mutual_message x xge y yge isfix rest)
     | _ -> ()
 
-type fixpoint_kind =
-  | IsFixpoint of (identifier located option * recursion_order_expr) list
-  | IsCoFixpoint
-
-type fixpoint_expr = {
+type structured_fixpoint_expr = {
   fix_name : identifier;
   fix_binders : local_binder list;
-  fix_body : constr_expr;
+  fix_body : constr_expr option;
   fix_type : constr_expr
 }
 
@@ -784,9 +460,10 @@ let interp_fix_ccl evdref (env,_) fix =
   interp_type_evars evdref env fix.fix_type
 
 let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
-  let env = push_rel_context ctx env_rec in
-  let body = interp_casted_constr_evars evdref env ~impls fix.fix_body ccl in
-  it_mkLambda_or_LetIn body ctx
+  Option.map (fun body ->
+    let env = push_rel_context ctx env_rec in
+    let body = interp_casted_constr_evars evdref env ~impls body ccl in
+    it_mkLambda_or_LetIn body ctx) fix.fix_body
 
 let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
 
@@ -799,9 +476,10 @@ let declare_fix boxed kind f def t imps =
   } in
   let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in
   let gr = ConstRef kn in
-    maybe_declare_manual_implicits false gr imps;
-    gr
-      
+  Autoinstance.search_declaration (ConstRef kn);
+  maybe_declare_manual_implicits false gr imps;
+  gr
+
 let prepare_recursive_declaration fixnames fixtypes fixdefs =
   let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
   let names = List.map (fun id -> Name id) fixnames in
@@ -809,454 +487,135 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs =
 
 (* Jump over let-bindings. *)
 
-let rel_index n ctx = 
-  list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
-
-let rec unfold f b =
-  match f b with
-    | Some (x, b') -> x :: unfold f b'
-    | None -> []
-
-let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
-  match n with 
-  | Some (loc, n) -> [rel_index n fixctx]
-  | None -> 
+let compute_possible_guardness_evidences na fix (ids,_) =
+  match index_of_annot fix.fix_binders na with
+  | Some i -> [i]
+  | None ->
       (* If recursive argument was not given by user, we try all args.
 	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally 
-         doesn't seem to worth the effort (except for huge mutual 
+	 but doing it properly involves delta-reduction, and it finally
+         doesn't seem to worth the effort (except for huge mutual
 	 fixpoints ?) *)
-      let len = List.length fixctx in
-	unfold (function x when x = len -> None 
-	  | n -> Some (n, succ n)) 0
+      interval 0 (List.length ids - 1)
+
+type recursive_preentry =
+  identifier list * constr option list * types list
 
-let interp_recursive fixkind l boxed =
+let interp_recursive isfix fixl notations =
   let env = Global.env() in
-  let fixl, ntnl = List.split l in
-  let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
   let fixnames = List.map (fun fix -> fix.fix_name) fixl in
 
   (* Interp arities allowing for unresolved types *)
-  let evdref = ref (Evd.create_evar_defs Evd.empty) in
+  let evdref = ref Evd.empty in
   let fixctxs, fiximps =
     List.split (List.map (interp_fix_context evdref env) fixl) in
   let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
   let fixtypes = List.map2 build_fix_type fixctxs fixccls in
-  let fixtypes = List.map (nf_evar (evars_of !evdref)) fixtypes in
+  let fixtypes = List.map (nf_evar !evdref) fixtypes in
   let env_rec = push_named_types env fixnames fixtypes in
 
   (* Get interpretation metadatas *)
-  let impls = compute_interning_datas env Recursive [] fixnames fixtypes fiximps in
-  let notations = List.fold_right Option.List.cons ntnl [] in
+  let impls = compute_full_internalization_env env Recursive [] fixnames fixtypes fiximps in
 
   (* Interp bodies with rollback because temp use of notations/implicit *)
-  let fixdefs = 
-    States.with_state_protection (fun () -> 
-      List.iter (declare_interning_data impls) notations;
+  let fixdefs =
+    States.with_state_protection (fun () ->
+      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
       list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
       () in
 
   (* Instantiate evars and check all are resolved *)
   let evd,_ = consider_remaining_unif_problems env_rec !evdref in
-  let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in
-  let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in
+  let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in
+  let fixtypes = List.map (nf_evar evd) fixtypes in
+  let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in
   let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in
-  List.iter (check_evars env_rec Evd.empty evd) fixdefs;
+  List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs;
   List.iter (check_evars env Evd.empty evd) fixtypes;
-  check_mutuality env kind (List.combine fixnames fixdefs);
+  if not (List.mem None fixdefs) then begin
+    let fixdefs = List.map Option.get fixdefs in
+    check_mutuality env isfix (List.combine fixnames fixdefs)
+  end;
 
   (* Build the fix declaration block *)
-  let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
-  let indexes, fixdecls = 
-    match fixkind with
-    | IsFixpoint wfl ->
-	let possible_indexes = 
-	  list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
-	let indexes = search_guard dummy_loc env possible_indexes fixdecls in 
-	Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l
-    | IsCoFixpoint ->
-	None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
-  in
-
-  (* Declare the recursive definitions *)
-  ignore (list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps);
-  if_verbose ppnl (recursive_message kind indexes fixnames);
-
+  (fixnames,fixdefs,fixtypes),List.combine fixctxnames fiximps
+
+let interp_fixpoint = interp_recursive true
+let interp_cofixpoint = interp_recursive false
+
+let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
+  if List.mem None fixdefs then
+    (* Some bodies to define by proof *)
+    let thms =
+      list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in
+    let init_tac =
+      Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
+        fixdefs) in
+    Lemmas.start_proof_with_initialization (Global,DefinitionBody Fixpoint)
+      (Some(false,indexes,init_tac)) thms None (fun _ _ -> ())
+  else begin
+    (* We shortcut the proof process *)
+    let fixdefs = List.map Option.get fixdefs in
+    let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
+    let indexes = search_guard dummy_loc (Global.env()) indexes fixdecls in
+    let fiximps = List.map snd fiximps in
+    let fixdecls =
+      list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in
+    ignore (list_map4 (declare_fix boxed Fixpoint) fixnames fixdecls fixtypes fiximps);
+    (* Declare the recursive definitions *)
+    fixpoint_message (Some indexes) fixnames;
+  end;
   (* Declare notations *)
-  List.iter (declare_interning_data ([],[])) notations
-
-let build_recursive l b =
-  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
-  let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> 
-    ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn))
-    l in
-  interp_recursive (IsFixpoint g) fixl b
-
-let build_corecursive l b =
-  let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> 
-    ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn))
-    l in
-  interp_recursive IsCoFixpoint fixl b
-
-(* 3d| Schemes *)
-let rec split_scheme l = 
- let env = Global.env() in
- match l with
-  | [] -> [],[]
-  | (Some id,t)::q -> let l1,l2 = split_scheme q in 
-    ( match t with
-      | InductionScheme (x,y,z) -> ((id,x,y,z)::l1),l2
-      | EqualityScheme  x -> l1,(x::l2)
-    )
-(*
- if no name has been provided, we build one from the types of the ind
-requested 
-*)
-  | (None,t)::q ->
-       let l1,l2 = split_scheme q in
-    ( match t with
-      | InductionScheme (x,y,z) ->
-             let ind = mkInd (Nametab.inductive_of_reference y) in
-             let sort_of_ind = family_of_sort (Typing.sort_of env Evd.empty ind)
-in
-             let z' = family_of_sort (interp_sort z) in
-             let suffix = (
-                match sort_of_ind with
-                | InProp ->
-                    if x then (match z' with
-                       | InProp -> "_ind_nodep"
-                       | InSet -> "_rec_nodep"
-                       | InType -> "_rect_nodep")
-                    else ( match z' with
-                       | InProp -> "_ind"
-                       | InSet -> "_rec"
-                       | InType -> "_rect" )
-                | _ ->
-                    if x then (match z' with
-                       | InProp -> "_ind"
-                       | InSet -> "_rec"
-                       | InType -> "_rect" )
-                    else (match z' with
-                       | InProp -> "_ind_nodep"
-                       | InSet  -> "_rec_nodep"
-                       | InType -> "_rect_nodep")
-                ) in
-            let newid = (string_of_id (Pcoq.coerce_global_to_id y))^suffix in
-            let newref = (dummy_loc,id_of_string newid) in
-          ((newref,x,y,z)::l1),l2
-      | EqualityScheme  x -> l1,(x::l2)
-    )
-
-
-let build_induction_scheme lnamedepindsort = 
-  let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
-  and sigma = Evd.empty
-  and env0 = Global.env() in
-  let lrecspec =
-    List.map
-      (fun (_,dep,indid,sort) ->
-        let ind = Nametab.inductive_of_reference indid in
-        let (mib,mip) = Global.lookup_inductive ind in
-         (ind,mib,mip,dep,interp_elimination_sort sort)) 
-      lnamedepindsort
-  in
-  let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in 
-  let rec declare decl fi lrecref =
-    let decltype = Retyping.get_type_of env0 Evd.empty decl in
-    let decltype = refresh_universes decltype in
-    let ce = { const_entry_body = decl;
-               const_entry_type = Some decltype;
-               const_entry_opaque = false;
-	       const_entry_boxed = Flags.boxed_definitions() } in
-    let kn = declare_constant fi (DefinitionEntry ce, IsDefinition Scheme) in
-    ConstRef kn :: lrecref
-  in 
-  let _ = List.fold_right2 declare listdecl lrecnames [] in
-  if_verbose ppnl (recursive_message Fixpoint None lrecnames)
-
-let build_scheme l = 
-  let ischeme,escheme = split_scheme l in
-(* we want 1 kind of scheme at a time so we check if the user
-tried to declare different schemes at once *)
-    if (ischeme <> []) && (escheme <> []) 
-    then
-      error "Do not declare equality and induction scheme at the same time."
-    else (
-      if ischeme <> [] then build_induction_scheme ischeme;
-      List.iter ( fun indname -> 
-        let ind = Nametab.inductive_of_reference indname
-        in declare_eq_scheme (fst ind);
-        try
-           make_eq_decidability ind 
-        with _ -> 
-          Pfedit.delete_current_proof();
-          message "Error while computing decidability scheme. Please report."
-      ) escheme
-    )
-	
-let list_split_rev_at index l = 
-  let rec aux i acc = function
-      hd :: tl when i = index -> acc, tl
-    | hd :: tl -> aux (succ i) (hd :: acc) tl
-    | [] -> failwith "list_split_at: Invalid argument"
-  in aux 0 [] l
-
-let fold_left' f = function 
-    [] -> raise (Invalid_argument "fold_right'")
-  | hd :: tl -> List.fold_left f hd tl
-      
-let build_combined_scheme name schemes =
-  let env = Global.env () in
-(*   let nschemes = List.length schemes in *)
-  let find_inductive ty =
-    let (ctx, arity) = decompose_prod ty in
-    let (_, last) = List.hd ctx in
-      match kind_of_term last with
-	| App (ind, args) -> 
-	    let ind = destInd ind in
-	    let (_,spec) = Inductive.lookup_mind_specif env ind in
-	      ctx, ind, spec.mind_nrealargs
-	| _ -> ctx, destInd last, 0
-  in
-  let defs =  
-    List.map (fun x -> 
-		let refe = Ident x in
-		let qualid = qualid_of_reference refe in
-		let cst = try Nametab.locate_constant (snd qualid) 
-                  with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")
-                in
-		let ty = Typeops.type_of_constant env cst in
-		  qualid, cst, ty)
-      schemes
-  in
-  let (qid, c, t) = List.hd defs in
-  let ctx, ind, nargs = find_inductive t in
-  (* Number of clauses, including the predicates quantification *)
-  let prods = nb_prod t - (nargs + 1) in
-  let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in
-  let relargs = rel_vect 0 prods in
-  let concls = List.rev_map 
-    (fun (_, cst, t) -> 
-      mkApp(mkConst cst, relargs),
-      snd (decompose_prod_n prods t)) defs in
-  let concl_bod, concl_typ = 
-    fold_left'
-      (fun (accb, acct) (cst, x) -> 
-	mkApp (coqconj, [| x; acct; cst; accb |]),
-	mkApp (coqand, [| x; acct |])) concls
-  in
-  let ctx, _ = 
-    list_split_rev_at prods 
-      (List.rev_map (fun (x, y) -> x, None, y) ctx) in
-  let typ = it_mkProd_wo_LetIn concl_typ ctx in
-  let body = it_mkLambda_or_LetIn concl_bod ctx in
-  let ce = { const_entry_body = body;
-             const_entry_type = Some typ;
-             const_entry_opaque = false;
-	     const_entry_boxed = Flags.boxed_definitions() } in
-  let _ = declare_constant (snd name) (DefinitionEntry ce, IsDefinition Scheme) in
-    if_verbose ppnl (recursive_message Fixpoint None [snd name])
-(* 4| Goal declaration *)
-
-(* 4.1| Support for mutually proved theorems *)
-
-let retrieve_first_recthm = function
-  | VarRef id -> 
-      (pi2 (Global.lookup_named id),variable_opacity id)
-  | ConstRef cst -> 
-      let {const_body=body;const_opaque=opaq} =	Global.lookup_constant cst in
-      (Option.map Declarations.force body,opaq)
-  | _ -> assert false
-
-let default_thm_id = id_of_string "Unnamed_thm"
-
-let compute_proof_name = function
-  | Some (loc,id) ->
-      (* We check existence here: it's a bit late at Qed time *)
-      if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
-        user_err_loc (loc,"",pr_id id ++ str " already exists.");
-      id
-  | None ->
-      let rec next avoid id =
-        let id = next_global_ident_away false id avoid in
-        if Nametab.exists_cci (Lib.make_path id) then next (id::avoid) id 
-        else id
-      in
-      next (Pfedit.get_all_proof_names ()) default_thm_id
-
-let save_remaining_recthms (local,kind) body opaq i (id,(t_i,imps)) =
-  match body with
-  | None ->
-      (match local with
-      | Local ->
-          let impl=false in (* copy values from Vernacentries *)
-          let k = IsAssumption Conjectural in
-          let c = SectionLocalAssum (t_i,impl,[]) in
-	  let _ = declare_variable id (Lib.cwd(),c,k) in
-          (Local,VarRef id,imps)
-      | Global ->
-          let k = IsAssumption Conjectural in
-          let kn = declare_constant id (ParameterEntry (t_i,false), k) in
-          (Global,ConstRef kn,imps))
-  | Some body ->
-      let k = logical_kind_of_goal_kind kind in
-      let body_i = match kind_of_term body with
-        | Fix ((nv,0),decls) -> mkFix ((nv,i),decls)
-        | CoFix (0,decls) -> mkCoFix (i,decls)
-        | _ -> anomaly "Not a proof by induction" in
-      match local with
-      | Local ->
-	  let c = SectionLocalDef (body_i, Some t_i, opaq) in
-	  let _ = declare_variable id (Lib.cwd(), c, k) in
-          (Local,VarRef id,imps)
-      | Global -> 
-          let const =
-            { const_entry_body = body_i;
-              const_entry_type = Some t_i;
-              const_entry_opaque = opaq;
-              const_entry_boxed = false (* copy of what cook_proof does *)} in
-          let kn = declare_constant id (DefinitionEntry const, k) in
-          (Global,ConstRef kn,imps)
-
-let look_for_mutual_statements thms =
-  if List.tl thms <> [] then
-    (* More than one statement: we look for a common inductive hyp or a *)
-    (* common coinductive conclusion *)
-    let n = List.length thms in
-    let inds = List.map (fun (id,(t,_) as x) -> 
-      let (hyps,ccl) = Sign.decompose_prod_assum t in
-      let whnf_hyp_hds = fold_map_rel_context
-        (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c))
-	(Global.env()) hyps in
-      let ind_hyps =
-        List.flatten (list_map_i (fun i (_,b,t) ->
-          match kind_of_term t with
-          | Ind (kn,_ as ind) when
-                let mind = Global.lookup_mind kn in
-                mind.mind_finite & b = None ->
-              [ind,x,i]
-          | _ ->
-              []) 1 (List.rev whnf_hyp_hds)) in
-      let ind_ccl =
-        let cclenv = push_rel_context hyps (Global.env()) in
-        let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in
-        match kind_of_term whnf_ccl with
-        | Ind (kn,_ as ind) when
-              let mind = Global.lookup_mind kn in
-              mind.mind_ntypes = n & not mind.mind_finite ->
-            [ind,x,0]
-        | _ ->
-            [] in
-      ind_hyps,ind_ccl) thms in
-    let inds_hyps,ind_ccls = List.split inds in
-    let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in
-    (* Check if all conclusions are coinductive in the same type *)
-    (* (degenerated cartesian product since there is at most one coind ccl) *)
-    let same_indccl =
-      list_cartesians_filter (fun hyp oks ->
-	if List.for_all (of_same_mutind hyp) oks 
-	then Some (hyp::oks) else None) [] ind_ccls in
-    let ordered_same_indccl =
-      List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in
-    (* Check if some hypotheses are inductive in the same type *)
-    let common_same_indhyp =
-      list_cartesians_filter (fun hyp oks ->
-	if List.for_all (of_same_mutind hyp) oks
-	then Some (hyp::oks) else None) [] inds_hyps in
-    let ordered_inds,finite =
-      match ordered_same_indccl, common_same_indhyp with
-      | indccl::rest, _ ->
-	  assert (rest=[]);
-          (* One occ. of common coind ccls and no common inductive hyps *)
-	  if common_same_indhyp <> [] then 
-	    if_verbose warning "Assuming mutual coinductive statements.";
-	  flush_all ();
-          indccl, true
-      | [], _::_ ->
-	  if same_indccl <> [] &&
-	     list_distinct (List.map pi1 (List.hd same_indccl)) then
-	    if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all ();
-	  (* assume the largest indices as possible *)
-	  list_last common_same_indhyp, false
-      | _, [] ->
-	  error
-            ("Cannot find common (mutual) inductive premises or coinductive" ^
-             " conclusions in the statements.")
-    in
-    let nl,thms = List.split (List.map (fun (_,x,i) -> (i,x)) ordered_inds) in
-    let rec_tac =
-      if finite then
-        match List.map (fun (id,(t,_)) -> (id,t)) thms with
-        | (id,_)::l -> Hiddentac.h_mutual_cofix true id l
-        | _ -> assert false
-      else
-	(* nl is dummy: it will be recomputed at Qed-time *)
-        match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with
-        | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l
-        | _ -> assert false in
-    Some rec_tac,thms
-  else
-    None, thms
-
-(* 4.2| General support for goals *)
-
-let start_proof_com kind thms hook =
-  let thms = List.map (fun (sopt,(bl,t)) ->
-    (compute_proof_name sopt,
-     interp_type_evars_impls (Global.env()) (generalize_constr_expr t bl)))
-    thms in
-  let rec_tac,thms = look_for_mutual_statements thms in
-  match thms with
-  | [] -> anomaly "No proof to start"
-  | (id,(t,imps))::other_thms ->
-      let hook strength ref =
-        let other_thms_data =
-          if other_thms = [] then [] else
-            (* there are several theorems defined mutually *)
-            let body,opaq = retrieve_first_recthm ref in
-            list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in
-        let thms_data = (strength,ref,imps)::other_thms_data in
-        List.iter (fun (strength,ref,imps) ->
-	  maybe_declare_manual_implicits false ref imps;
-	  hook strength ref) thms_data in
-      start_proof id kind t ?init_tac:rec_tac
-	~compute_guard:(rec_tac<>None) hook
-
-let check_anonymity id save_ident =
-  if atompart_of_id id <> "Unnamed_thm" then
-    error "This command can only be used for unnamed theorem."
-(*
-    message("Overriding name "^(string_of_id id)^" and using "^save_ident)
-*)
-
-let save_anonymous opacity save_ident =
-  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
-  let const = { const with const_entry_opaque = opacity } in
-  check_anonymity id save_ident;
-  save save_ident const do_guard persistence hook
-
-let save_anonymous_with_strength kind opacity save_ident =
-  let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in
-  let const = { const with const_entry_opaque = opacity } in
-  check_anonymity id save_ident;
-  (* we consider that non opaque behaves as local for discharge *)
-  save save_ident const do_guard (Global, Proof kind) hook
-
-let admit () =
-  let (id,k,typ,hook) = Pfedit.current_proof_statement () in
-(* Contraire aux besoins d'interactivité...
-  if k <> IsGlobal (Proof Conjecture) then
-    error "Only statements declared as conjecture can be admitted";
-*)
-  let kn =
-    declare_constant id (ParameterEntry (typ,false), IsAssumption Conjectural) in
-  Pfedit.delete_current_proof ();
-  assumption_message id;
-  hook Global (ConstRef kn)
+  List.iter Metasyntax.add_notation_interpretation ntns
+
+let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns =
+  if List.mem None fixdefs then
+    (* Some bodies to define by proof *)
+    let thms =
+      list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in
+    let init_tac =
+      Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
+        fixdefs) in
+    Lemmas.start_proof_with_initialization (Global,DefinitionBody CoFixpoint)
+      (Some(true,[],init_tac)) thms None (fun _ _ -> ())
+  else begin
+    (* We shortcut the proof process *)
+    let fixdefs = List.map Option.get fixdefs in
+    let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
+    let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in
+    let fiximps = List.map snd fiximps in
+    ignore (list_map4 (declare_fix boxed CoFixpoint) fixnames fixdecls fixtypes fiximps);
+    (* Declare the recursive definitions *)
+    cofixpoint_message fixnames
+  end;
+  (* Declare notations *)
+  List.iter Metasyntax.add_notation_interpretation ntns
 
-let get_current_context () =
-  try Pfedit.get_current_goal_context ()
-  with e when Logic.catchable_exception e -> 
-    (Evd.empty, Global.env())
+let extract_decreasing_argument = function
+  | (_,(na,CStructRec),_,_,_) -> na
+  | _ -> error 
+      "Only structural decreasing is supported for a non-Program Fixpoint"
 
+let extract_fixpoint_components l =
+  let fixl, ntnl = List.split l in
+  let wfl = List.map extract_decreasing_argument fixl in
+  let fixl = List.map (fun ((_,id),_,bl,typ,def) ->
+    {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in
+  fixl, List.flatten ntnl, wfl
 
+let extract_cofixpoint_components l =
+  let fixl, ntnl = List.split l in
+  List.map (fun ((_,id),bl,typ,def) ->
+    {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
+  List.flatten ntnl
+
+let do_fixpoint l b =
+  let fixl,ntns,wfl = extract_fixpoint_components l in
+  let fix = interp_fixpoint fixl ntns in
+  let possible_indexes =
+    list_map3 compute_possible_guardness_evidences wfl fixl (snd fix) in
+  declare_fixpoint b fix possible_indexes ntns
+
+let do_cofixpoint l b =
+  let fixl,ntns = extract_cofixpoint_components l in
+  declare_cofixpoint b (interp_cofixpoint fixl ntns) ntns
diff --git a/toplevel/command.mli b/toplevel/command.mli
index 36399029..b87060e4 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -6,143 +6,153 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: command.mli 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
 open Names
 open Term
-open Nametab
-open Declare
-open Library
+open Entries
 open Libnames
-open Nametab
 open Tacexpr
 open Vernacexpr
-open Rawterm
 open Topconstr
 open Decl_kinds
 open Redexpr
+open Constrintern
+open Pfedit
 (*i*)
 
-(*s Declaration functions. The following functions take ASTs,
-   transform them into [constr] and then call the corresponding
-   functions of [Declare]; they return an absolute reference to the
-   defined object *)
+(*s This file is about the interpretation of raw commands into typed
+    ones and top-level declaration of the main Gallina objects *)
 
-val get_declare_definition_hook : unit -> (Entries.definition_entry -> unit)
-val set_declare_definition_hook : (Entries.definition_entry -> unit) -> unit
+(* Hooks for Pcoq *)
 
-val definition_message : identifier -> unit
-val assumption_message : identifier -> unit
+val set_declare_definition_hook : (definition_entry -> unit) -> unit
+val get_declare_definition_hook : unit -> (definition_entry -> unit)
+val set_declare_assumptions_hook : (types -> unit) -> unit
 
-val declare_definition : identifier -> definition_kind ->
-  local_binder list -> red_expr option -> constr_expr ->
-  constr_expr option -> declaration_hook -> unit
+(*************************************************************************)
+(* Definitions/Let *)
 
-val syntax_definition : identifier -> identifier list * constr_expr -> 
+val interp_definition :
+  boxed_flag -> local_binder list -> red_expr option -> constr_expr ->
+  constr_expr option -> definition_entry * manual_implicits
+
+val declare_definition : identifier -> locality * definition_object_kind ->
+  definition_entry -> manual_implicits -> declaration_hook -> unit
+
+(*************************************************************************)
+(* Parameters/Assumptions *)
+
+val interp_assumption :
+  local_binder list -> constr_expr -> types * manual_implicits
+
+val declare_assumption : coercion_flag -> assumption_kind -> types ->
+  manual_implicits ->
+  bool (* implicit *) -> bool (* inline *) -> variable located -> unit
+
+val declare_assumptions : variable located list ->
+  coercion_flag -> assumption_kind -> types -> manual_implicits ->
   bool -> bool -> unit
 
-val declare_one_assumption : coercion_flag -> assumption_kind -> Term.types ->
-  Impargs.manual_explicitation list ->
-  bool (* implicit *) -> identifier list (* keep *) -> bool (* inline *) -> Names.variable located  -> unit
-  
-val set_declare_assumption_hook : (types -> unit) -> unit
-
-val declare_assumption : identifier located list ->
-  coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> 
-  bool -> identifier list -> bool -> unit
-
-val declare_interning_data : 'a * Constrintern.implicits_env ->
-    string * Topconstr.constr_expr * Topconstr.scope_name option -> unit
-
-val compute_interning_datas : Environ.env -> Constrintern.var_internalisation_type -> 
-  'a list -> 'b list ->
-  Term.types list ->Impargs.manual_explicitation list list ->
-  'a list *
-    ('b * (Constrintern.var_internalisation_type * Names.identifier list * Impargs.implicits_list *
-	      Topconstr.scope_name option list))
-    list
-
-val check_mutuality : Environ.env -> definition_object_kind ->
-  (identifier * types) list -> unit
-
-val build_mutual : ((lident * local_binder list * constr_expr option * constructor_expr list) * 
-		                decl_notation) list -> bool -> unit
-
-val declare_mutual_with_eliminations :
-  bool -> Entries.mutual_inductive_entry -> 
-  (Impargs.manual_explicitation list *
-      Impargs.manual_explicitation list list) list ->
-  mutual_inductive
+(*************************************************************************)
+(* Inductive and coinductive types *)
 
-type fixpoint_kind =
-  | IsFixpoint of (identifier located option * recursion_order_expr) list
-  | IsCoFixpoint
+(* Extracting the semantical components out of the raw syntax of mutual
+   inductive declarations *)
 
-type fixpoint_expr = {
-  fix_name : identifier;
-  fix_binders : local_binder list;
-  fix_body : constr_expr;
-  fix_type : constr_expr
+type structured_one_inductive_expr = {
+  ind_name : identifier;
+  ind_arity : constr_expr;
+  ind_lc : (identifier * constr_expr) list
 }
 
-val recursive_message : definition_object_kind ->
-  int array option -> identifier list -> Pp.std_ppcmds
-  
-val declare_fix : bool -> definition_object_kind -> identifier ->
-  constr -> types -> Impargs.manual_explicitation list -> global_reference
+type structured_inductive_expr =
+  local_binder list * structured_one_inductive_expr list
 
-val build_recursive : (Topconstr.fixpoint_expr * decl_notation) list -> bool -> unit
+val extract_mutual_inductive_declaration_components :
+  (one_inductive_expr * decl_notation list) list ->
+    structured_inductive_expr * (*coercions:*) qualid list * decl_notation list
 
-val build_corecursive : (Topconstr.cofixpoint_expr * decl_notation) list -> bool -> unit
+(* Typing mutual inductive definitions *)
 
-val build_scheme : (identifier located option * scheme ) list -> unit
+type one_inductive_impls =
+  Impargs.manual_explicitation list (* for inds *)*
+  Impargs.manual_explicitation list list (* for constrs *)
 
-val build_combined_scheme : identifier located -> identifier located list -> unit
+val interp_mutual_inductive :
+  structured_inductive_expr -> decl_notation list -> bool ->
+    mutual_inductive_entry * one_inductive_impls list
 
-val generalize_constr_expr : constr_expr -> local_binder list -> constr_expr
+(* Registering a mutual inductive definition together with its
+   associated schemes *)
 
-val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
+val declare_mutual_inductive_with_eliminations :
+  Declare.internal_flag -> mutual_inductive_entry -> one_inductive_impls list ->
+  mutual_inductive
+
+(* Entry points for the vernacular commands Inductive and CoInductive *)
 
-(* A hook start_proof calls on the type of the definition being started *)
-val set_start_hook : (types -> unit) -> unit
+val do_mutual_inductive :
+  (one_inductive_expr * decl_notation list) list -> bool -> unit
 
-val start_proof : identifier -> goal_kind -> types ->
-  ?init_tac:Proof_type.tactic -> ?compute_guard:bool -> declaration_hook -> unit
+(*************************************************************************)
+(* Fixpoints and cofixpoints *)
 
-val start_proof_com : goal_kind -> 
-  (lident option * (local_binder list * constr_expr)) list ->
-  declaration_hook -> unit
+type structured_fixpoint_expr = {
+  fix_name : identifier;
+  fix_binders : local_binder list;
+  fix_body : constr_expr option;
+  fix_type : constr_expr
+}
 
-(* A hook the next three functions pass to cook_proof *)
-val set_save_hook : (Refiner.pftreestate -> unit) -> unit
+(* Extracting the semantical components out of the raw syntax of
+   (co)fixpoints declarations *)
 
-(*s [save_named b] saves the current completed proof under the name it
-was started; boolean [b] tells if the theorem is declared opaque; it
-fails if the proof is not completed *)
+val extract_fixpoint_components :
+  (fixpoint_expr * decl_notation list) list ->
+    structured_fixpoint_expr list * decl_notation list *
+    (* possible structural arg: *) lident option list
 
-val save_named : bool -> unit
+val extract_cofixpoint_components :
+  (cofixpoint_expr * decl_notation list) list ->
+    structured_fixpoint_expr list * decl_notation list
 
-(* [save_anonymous b name] behaves as [save_named] but declares the theorem
-under the name [name] and respects the strength of the declaration *)
+(* Typing global fixpoints and cofixpoint_expr *)
 
-val save_anonymous : bool -> identifier -> unit
+type recursive_preentry =
+  identifier list * constr option list * types list
 
-(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but
-   declares the theorem under the name [name] and gives it the
-   strength [strength] *)
+val interp_fixpoint :
+  structured_fixpoint_expr list -> decl_notation list ->
+    recursive_preentry * (name list * manual_implicits) list
 
-val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit
+val interp_cofixpoint :
+  structured_fixpoint_expr list -> decl_notation list ->
+    recursive_preentry * (name list * manual_implicits) list
 
-(* [admit ()] aborts the current goal and save it as an assmumption *)
+(* Registering fixpoints and cofixpoints in the environment *)
 
-val admit : unit -> unit
+val declare_fixpoint :
+  bool -> recursive_preentry * (name list * manual_implicits) list -> 
+  lemma_possible_guards -> decl_notation list -> unit
 
-(* [get_current_context ()] returns the evar context and env of the
-   current open proof if any, otherwise returns the empty evar context
-   and the current global env *)
+val declare_cofixpoint :
+  bool -> recursive_preentry * (name list * manual_implicits) list ->
+    decl_notation list -> unit
 
-val get_current_context : unit -> Evd.evar_map * Environ.env
+(* Entry points for the vernacular commands Fixpoint and CoFixpoint *)
 
+val do_fixpoint :
+  (fixpoint_expr * decl_notation list) list -> bool -> unit
 
+val do_cofixpoint :
+  (cofixpoint_expr * decl_notation list) list -> bool -> unit
+
+(* Utils *)
+
+val check_mutuality : Environ.env -> bool -> (identifier * types) list -> unit
+
+val declare_fix : bool -> definition_object_kind -> identifier ->
+  constr -> types -> Impargs.manual_explicitation list -> global_reference
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index d32a773d..d9fcdb24 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqinit.ml 11749 2009-01-05 14:01:04Z notin $ *)
+(* $Id$ *)
 
 open Pp
 open System
@@ -32,7 +32,7 @@ let load_rcfile() =
   if !load_rc then
     try
       if !rcfile_specified then
-        if file_readable_p !rcfile then 
+        if file_readable_p !rcfile then
           Vernac.load_vernac false !rcfile
         else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
       else if file_readable_p (!rcfile^"."^Coq_config.version) then
@@ -48,12 +48,9 @@ let load_rcfile() =
     with e ->
       (msgnl (str"Load of rcfile failed.");
        raise e)
-  else 
+  else
     Flags.if_verbose msgnl (str"Skipping rcfile loading.")
 
-let add_ml_include s =
-  Mltop.add_ml_dir s
-
 (* Puts dir in the path of ML and in the LoadPath *)
 let coq_add_path d s =
   Mltop.add_path d (Names.make_dirpath [Nameops.coq_root;Names.id_of_string s])
@@ -64,32 +61,29 @@ let includes = ref []
 let push_include (s, alias) = includes := (s,alias,false) :: !includes
 let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
 
-(* Because find puts "./" and the loadpath is not nicely pretty-printed *)
-let hm2 s = 
-  let n = String.length s in
-  if n > 1 && s.[0] = '.' && s.[1] = '/' then String.sub s 2 (n-2) else s
-
 (* The list of all theories in the standard library /!\ order does matter *)
 let theories_dirs_map = [
     "theories/Unicode", "Unicode" ;
-    "theories/Classes", "Classes" ; 
-    "theories/Program", "Program" ; 
-    "theories/FSets", "FSets" ; 
-    "theories/Reals", "Reals" ; 
-    "theories/Strings", "Strings" ; 
-    "theories/Sorting", "Sorting" ; 
-    "theories/Setoids", "Setoids" ; 
-    "theories/Sets", "Sets" ; 
-    "theories/Lists", "Lists" ; 
-    "theories/Wellfounded", "Wellfounded" ; 
-    "theories/Relations", "Relations" ; 
-    "theories/Numbers", "Numbers" ; 
-    "theories/QArith", "QArith" ; 
-    "theories/NArith", "NArith" ; 
-    "theories/ZArith", "ZArith" ; 
-    "theories/Arith", "Arith" ; 
-    "theories/Bool", "Bool" ; 
-    "theories/Logic", "Logic" ; 
+    "theories/Classes", "Classes" ;
+    "theories/Program", "Program" ;
+    "theories/MSets", "MSets" ;
+    "theories/FSets", "FSets" ;
+    "theories/Reals", "Reals" ;
+    "theories/Strings", "Strings" ;
+    "theories/Sorting", "Sorting" ;
+    "theories/Setoids", "Setoids" ;
+    "theories/Sets", "Sets" ;
+    "theories/Structures", "Structures" ;
+    "theories/Lists", "Lists" ;
+    "theories/Wellfounded", "Wellfounded" ;
+    "theories/Relations", "Relations" ;
+    "theories/Numbers", "Numbers" ;
+    "theories/QArith", "QArith" ;
+    "theories/NArith", "NArith" ;
+    "theories/ZArith", "ZArith" ;
+    "theories/Arith", "Arith" ;
+    "theories/Bool", "Bool" ;
+    "theories/Logic", "Logic" ;
     "theories/Init", "Init"
   ]
 
@@ -97,26 +91,26 @@ let theories_dirs_map = [
 let init_load_path () =
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
-  let dirs = "states" :: ["contrib"] in
+  let dirs = ["states";"plugins"] in
     (* first user-contrib *)
-    if Sys.file_exists user_contrib then 
+    if Sys.file_exists user_contrib then
       Mltop.add_rec_path user_contrib Nameops.default_root_prefix;
-    (* then states, contrib and dev *)
+    (* then states, theories and dev *)
     List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
     (* developer specific directory to open *)
     if Coq_config.local then coq_add_path (coqlib/"dev") "dev";
     (* then standard library *)
-    List.iter 
-      (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) 
+    List.iter
+      (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root]))
       theories_dirs_map;
     (* then current directory *)
     Mltop.add_path "." Nameops.default_root_prefix;
     (* additional loadpath, given with -I -include -R options *)
-    List.iter 
+    List.iter
       (fun (s,alias,reci) ->
 	if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias)
       (List.rev !includes)
-      
+
 let init_library_roots () =
   includes := []
 
@@ -124,11 +118,11 @@ let init_library_roots () =
    find the "include" file in the *source* directory *)
 let init_ocaml_path () =
   let coqsrc = Coq_config.coqsrc in
-  let add_subdir dl = 
-    Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) 
+  let add_subdir dl =
+    Mltop.add_ml_dir (List.fold_left (/) coqsrc dl)
   in
-    Mltop.add_ml_dir (Envars.coqlib ()); 
+    Mltop.add_ml_dir (Envars.coqlib ());
     List.iter add_subdir
-      [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; 
+      [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
 	[ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
 	[ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ]
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index d7856170..f4c82a41 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqinit.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Initialization. *)
 
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index f5d1d142..a88ee3ba 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqtop.ml 11830 2009-01-22 06:45:13Z notin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -21,7 +21,7 @@ open Coqinit
 
 let get_version_date () =
   try
-    let coqlib = Envars.coqlib () in 
+    let coqlib = Envars.coqlib () in
     let ch = open_in (Filename.concat coqlib "revision") in
     let ver = input_line ch in
     let rev = input_line ch in
@@ -37,7 +37,7 @@ let output_context = ref false
 
 let memory_stat = ref false
 
-let print_memory_stat () = 
+let print_memory_stat () =
   if !memory_stat then
     Format.printf "total heap size = %d kbytes\n" (heap_size_kb ())
 
@@ -47,7 +47,7 @@ let engagement = ref None
 let set_engagement c = engagement := Some c
 let engage () =
   match !engagement with Some c -> Global.set_engagement c | None -> ()
-  
+
 let set_batch_mode () = batch_mode := true
 
 let toplevel_default_name = make_dirpath [id_of_string "Top"]
@@ -72,22 +72,19 @@ let set_outputstate s = outputstate:=s
 let outputstate () = if !outputstate <> "" then extern_state !outputstate
 
 let set_default_include d = push_include (d,Nameops.default_root_prefix)
-let set_default_rec_include d = push_rec_include(d,Nameops.default_root_prefix)
 let set_include d p =
   let p = dirpath_of_string p in
-  Library.check_coq_overwriting p;
   push_include (d,p)
 let set_rec_include d p =
-  let p = dirpath_of_string p in 
-  Library.check_coq_overwriting p;
+  let p = dirpath_of_string p in
   push_rec_include(d,p)
- 
+
 let load_vernacular_list = ref ([] : (string * bool) list)
 let add_load_vernacular verb s =
   load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list
 let load_vernacular () =
   List.iter
-    (fun (s,b) -> 
+    (fun (s,b) ->
       if Flags.do_beautify () then
 	with_option beautify_file (Vernac.load_vernac b) s
       else
@@ -96,7 +93,7 @@ let load_vernacular () =
 
 let load_vernacular_obj = ref ([] : string list)
 let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj
-let load_vernac_obj () = 
+let load_vernac_obj () =
   List.iter (fun f -> Library.require_library_from_file None f None)
     (List.rev !load_vernacular_obj)
 
@@ -109,7 +106,7 @@ let require () =
 let compile_list = ref ([] : (bool * string) list)
 let add_compile verbose s =
   set_batch_mode ();
-  Flags.make_silent true; 
+  Flags.make_silent true;
   compile_list := (verbose,s) :: !compile_list
 let compile_files () =
   let init_state = States.freeze() in
@@ -124,6 +121,12 @@ let compile_files () =
 	   Vernac.compile v f)
       (List.rev !compile_list)
 
+let set_compat_version = function
+  | "8.2" -> compat_version := Some V8_2
+  | "8.1" -> warning "Compatibility with version 8.1 not supported."
+  | "8.0" -> warning "Compatibility with version 8.0 not supported."
+  | s -> error ("Unknown compatibility version \""^s^"\".")
+
 let re_exec_version = ref ""
 let set_byte () = re_exec_version := "byte"
 let set_opt () = re_exec_version := "opt"
@@ -145,11 +148,11 @@ let re_exec is_ide =
   if (is_native && s = "byte") || ((not is_native) && s = "opt")
   then begin
     let s = if s = "" then if is_native then "opt" else "byte" else s in
-    let newprog = 
+    let newprog =
       let dir = Filename.dirname prog in
       let coqtop = if is_ide then "coqide." else "coqtop." in
       let com = coqtop ^ s ^ Coq_config.exec_extension in
-      if dir <> "." then Filename.concat dir com else com 
+      if dir <> "." then Filename.concat dir com else com
     in
     Sys.argv.(0) <- newprog;
     Unix.handle_unix_error (Unix.execvp newprog) Sys.argv
@@ -186,12 +189,12 @@ let parse_args is_ide =
   let glob_opt = ref false in
   let rec parse = function
     | [] -> ()
-    | "-with-geoproof" :: s :: rem -> 
+    | "-with-geoproof" :: s :: rem ->
 	if s = "yes" then Coq_config.with_geoproof := true
 	else if s = "no" then Coq_config.with_geoproof := false
 	else usage ();
 	parse rem
-    | "-impredicative-set" :: rem -> 
+    | "-impredicative-set" :: rem ->
         set_engagement Declarations.ImpredicativeSet; parse rem
 
     | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem
@@ -218,13 +221,13 @@ let parse_args is_ide =
     | "-full" :: rem -> warning "option -full deprecated\n"; parse rem
 
     | "-batch" :: rem -> set_batch_mode (); parse rem
-    | "-boot" :: rem -> boot := true; no_load_rc (); parse rem	     
+    | "-boot" :: rem -> boot := true; no_load_rc (); parse rem
     | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem
     | "-outputstate" :: s :: rem -> set_outputstate s; parse rem
     | "-outputstate" :: []       -> usage ()
 
     | "-nois" :: rem -> set_inputstate ""; parse rem
-	     
+
     | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem
     | ("-inputstate"|"-is") :: []       -> usage ()
 
@@ -234,11 +237,11 @@ let parse_args is_ide =
     | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem
     | "-load-ml-source" :: []       -> usage ()
 
-    | ("-load-vernac-source"|"-l") :: f :: rem -> 
+    | ("-load-vernac-source"|"-l") :: f :: rem ->
 	add_load_vernacular false f; parse rem
     | ("-load-vernac-source"|"-l") :: []       -> usage ()
 
-    | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> 
+    | ("-load-vernac-source-verbose"|"-lv") :: f :: rem ->
 	add_load_vernacular true f; parse rem
     | ("-load-vernac-source-verbose"|"-lv") :: []       -> usage ()
 
@@ -270,11 +273,14 @@ let parse_args is_ide =
 
     | "-debug" :: rem -> set_debug (); parse rem
 
+    | "-compat" :: v :: rem -> set_compat_version v; parse rem
+    | "-compat" :: []       -> usage ()
+
     | "-vm" :: rem -> use_vm := true; parse rem
     | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem
-    | "-emacs-U" :: rem -> Flags.print_emacs := true; 
+    | "-emacs-U" :: rem -> Flags.print_emacs := true;
 	Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem
-	    
+
     | "-unicode" :: rem -> Flags.unicode_syntax := true; parse rem
 
     | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem
@@ -296,7 +302,9 @@ let parse_args is_ide =
     | "-user" :: u :: rem -> set_rcuser u; parse rem
     | "-user" :: []       -> usage ()
 
-    | "-notactics" :: rem -> remove_top_ml (); parse rem
+    | "-notactics" :: rem ->
+	warning "Obsolete option \"-notactics\".";
+	remove_top_ml (); parse rem
 
     | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem
 
@@ -312,7 +320,7 @@ let parse_args is_ide =
 
     | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem
 
-    | s :: rem -> 
+    | s :: rem ->
 	if is_ide then begin
 	  ide_args := s :: !ide_args;
 	  parse rem
@@ -322,7 +330,7 @@ let parse_args is_ide =
   in
   try
     parse (List.tl (Array.to_list Sys.argv))
-  with 
+  with
     | UserError(_,s) as e -> begin
 	try
 	  Stream.empty s; exit 1
@@ -359,17 +367,19 @@ let init is_ide =
       exit 1
   end;
   if !batch_mode then
-    (flush_all(); 
+    (flush_all();
      if !output_context then
        Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ());
-     Profile.print_profile (); 
+     Profile.print_profile ();
      exit 0);
   Lib.declare_initial_state ()
 
+let init_toplevel () = init false
+
 let init_ide () = init true; List.rev !ide_args
 
 let start () =
-  init false;
+  init_toplevel ();
   Toplevel.loop();
   (* Initialise and launch the Ocaml toplevel *)
   Coqinit.init_ocaml_path();
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index b5a1106c..87f4bdeb 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -6,17 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqtop.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* The Coq main module. The following function [start] will parse the
-   command line, print the banner, initialize the load path, load the input 
+   command line, print the banner, initialize the load path, load the input
    state, load the files given on the command line, load the ressource file,
    produce the output state if any, and finally will launch [Toplevel.loop]. *)
 
 val start : unit -> unit
 
-(* [init_ide] is to be used by the Coq IDE. 
-   It does everything [start] does, except launching the toplevel loop. 
+(* [init_ide] is to be used by the Coq IDE.
+   It does everything [start] does, except launching the toplevel loop.
    It returns the list of Coq files given on the command line. *)
 
 val init_ide : unit -> string list
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
index ae9a243f..4c21e491 100644
--- a/toplevel/discharge.ml
+++ b/toplevel/discharge.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: discharge.ml 10861 2008-04-28 08:19:14Z herbelin $ *)
+(* $Id$ *)
 
 open Names
 open Util
@@ -36,26 +36,26 @@ let detype_param = function
 *)
 
 let abstract_inductive hyps nparams inds =
-  let ntyp = List.length inds in 
+  let ntyp = List.length inds in
   let nhyp = named_context_length hyps in
   let args = instance_from_named_context (List.rev hyps) in
   let subs = list_tabulate (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) ntyp in
   let inds' =
     List.map
-      (function (tname,arity,cnames,lc) -> 
+      (function (tname,arity,cnames,lc) ->
 	let lc' = List.map (substl subs) lc in
 	let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in
 	let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in
         (tname,arity',cnames,lc''))
       	inds in
   let nparams' = nparams + Array.length args in
-(* To be sure to be the same as before, should probably be moved to process_inductive *) 
-  let params' = let (_,arity,_,_) = List.hd inds' in 
+(* 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
   in
-  let ind'' = 
-  List.map 
+  let ind'' =
+  List.map
     (fun (a,arity,c,lc) ->
       let _, short_arity = decompose_prod_n_assum nparams' arity in
       let shortlc =
@@ -70,7 +70,7 @@ let abstract_inductive hyps nparams inds =
 
 let process_inductive sechyps modlist mib =
   let nparams = mib.mind_nparams in
-  let inds = 
+  let inds =
     array_map_to_list
       (fun mip ->
 	 let arity = expmod_constr modlist (Termops.refresh_universes_strict (Inductive.type_of_inductive (Global.env()) (mib,mip))) in
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
index dcf88f31..c6496cd4 100644
--- a/toplevel/discharge.mli
+++ b/toplevel/discharge.mli
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: discharge.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Sign
 open Cooking
 open Declarations
 open Entries
 
-val process_inductive : 
+val process_inductive :
   named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
diff --git a/toplevel/fhimsg.mli b/toplevel/fhimsg.mli
deleted file mode 100644
index 1ab786d1..00000000
--- a/toplevel/fhimsg.mli
+++ /dev/null
@@ -1,74 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: fhimsg.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-(*i*)
-open Pp
-open Names
-open Term
-open Sign
-open Environ
-open Type_errors
-(*i*)
-
-(* This module provides functions to explain the various typing errors.
-   It is parameterized by a function to pretty-print a term in a given
-   context. *)
-
-module type Printer = sig
-  val pr_term : path_kind -> env -> constr -> std_ppcmds
-end
-
-(*s The result is a module which provides a function [explain_type_error]
-  to explain a type error for a given kind in a given env, which are 
-  usually the three arguments carried by the exception [TypeError] 
-  (see \refsec{typeerrors}). *)
-
-module Make (P : Printer) : sig
-
-val explain_type_error : path_kind -> env -> type_error -> std_ppcmds
-
-val pr_ne_ctx : std_ppcmds -> path_kind -> env -> std_ppcmds
-
-val explain_unbound_rel : path_kind -> env -> int -> std_ppcmds
-
-val explain_not_type : path_kind -> env -> constr -> std_ppcmds
-
-val explain_bad_assumption : path_kind -> env -> constr -> std_ppcmds
- 
-val explain_reference_variables : identifier -> std_ppcmds
-
-val explain_elim_arity : 
-  path_kind -> env -> constr -> constr list -> constr 
-    -> unsafe_judgment -> (constr * constr * string) option -> std_ppcmds
-
-val explain_case_not_inductive : 
-  path_kind -> env -> unsafe_judgment -> std_ppcmds
-
-val explain_number_branches : 
-  path_kind -> env -> unsafe_judgment -> int -> std_ppcmds
-
-val explain_ill_formed_branch :
-  path_kind -> env -> constr -> int -> constr -> constr -> std_ppcmds
-
-val explain_generalization :
-  path_kind -> env -> name * types -> constr -> std_ppcmds
-
-val explain_actual_type :
-  path_kind -> env -> constr -> constr -> constr -> std_ppcmds
-
-val explain_ill_formed_rec_body :
-  path_kind -> env -> guard_error -> 
-    name array -> int -> constr array -> std_ppcmds
-
-val explain_ill_typed_rec_body  :
-  path_kind -> env -> int -> name list -> unsafe_judgment array 
-    -> types array -> std_ppcmds
-
-end
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index 0cda7c71..19f42f5d 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: himsg.ml 11986 2009-03-17 11:44:20Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
 open Flags
 open Names
 open Nameops
+open Namegen
 open Term
 open Termops
 open Inductive
@@ -92,7 +93,7 @@ let explain_elim_arity env ind sorts c pj okinds =
 	| WrongArity ->
 	  "wrong arity" in
       let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in
-      let ppt = pr_lconstr_env env (snd (decompose_prod_assum pj.uj_type)) in
+      let ppt = pr_lconstr_env env ((strip_prod_assum pj.uj_type)) in
       hov 0
 	(str "the return type has sort" ++ spc () ++ ppt ++ spc () ++
 	 str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++
@@ -233,21 +234,20 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
         match names.(j) with
             Name id -> pr_id id
           | Anonymous -> str "the " ++ nth i ++ str " definition" in
+      let pr_db x = quote (pr_db env x) in
       let vars =
         match (lt,le) with
             ([],[]) -> assert false
-          | ([],[x]) ->
-              str "a subterm of " ++ pr_db env x
-          | ([],_) ->
-              str "a subterm of the following variables: " ++
-              prlist_with_sep pr_spc (pr_db env) le
-          | ([x],_) -> pr_db env x
+          | ([],[x]) -> str "a subterm of " ++ pr_db x
+          | ([],_) -> str "a subterm of the following variables: " ++
+              prlist_with_sep pr_spc pr_db le
+          | ([x],_) -> pr_db x
           | _ ->
               str "one of the following variables: " ++
-              prlist_with_sep pr_spc (pr_db env) lt in
+              prlist_with_sep pr_spc pr_db lt in
       str "Recursive call to " ++ called ++ spc () ++
-      str "has principal argument equal to" ++ spc () ++
-      pr_lconstr_env env arg ++ fnl () ++ str "instead of " ++ vars
+      strbrk "has principal argument equal to" ++ spc () ++
+      pr_lconstr_env env arg ++ strbrk " instead of " ++ vars
 
   | NotEnoughArgumentsForFixCall j ->
       let called =
@@ -288,7 +288,11 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
   in
   prt_name i ++ str " is ill-formed." ++ fnl () ++
   pr_ne_context_of (str "In environment") env ++
-  st ++ str "."
+  st ++ str "." ++ fnl () ++
+  (try (* May fail with unresolved globals. *)
+      let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in
+	str"Recursive definition is:" ++ spc () ++ pvd ++ str "."
+    with _ -> mt ())
 
 let explain_ill_typed_rec_body env i names vdefj vargs =
   let env = make_all_name_different env in
@@ -326,7 +330,7 @@ let explain_hole_kind env evi = function
       str "the type of " ++ Nameops.pr_id id
   | BinderType Anonymous ->
       str "the type of this anonymous binder"
-  | ImplicitArg (c,(n,ido)) ->
+  | ImplicitArg (c,(n,ido),b) ->
       let id = Option.get ido in
       str "the implicit parameter " ++
       pr_id id ++ spc () ++ str "of" ++
@@ -346,6 +350,8 @@ let explain_hole_kind env evi = function
       str "an existential variable"
   | ImpossibleCase ->
       str "the type of an impossible pattern-matching clause"
+  | MatchingVar _ ->
+      assert false
 
 let explain_not_clean env ev t k =
   let env = make_all_name_different env in
@@ -365,17 +371,17 @@ let explain_typeclass_resolution env evi k =
   match k with
   | GoalEvar | InternalHole | ImplicitArg _ ->
       (match Typeclasses.class_of_constr evi.evar_concl with
-      | Some c -> 
+      | Some c ->
 	  let env = Evd.evar_env evi in
-	    fnl () ++ str "Could not find an instance for " ++ 
-	      pr_lconstr_env env evi.evar_concl ++ 
+	    fnl () ++ str "Could not find an instance for " ++
+	      pr_lconstr_env env evi.evar_concl ++
 	      pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env
       | None -> mt())
   | _ -> mt()
-      
+
 let explain_unsolvable_implicit env evi k explain =
-  str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ 
-  explain_unsolvability explain ++ str "." ++ 
+  str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++
+  explain_unsolvability explain ++ str "." ++
   explain_typeclass_resolution env evi k
 
 let explain_var_not_found env id =
@@ -414,7 +420,7 @@ let explain_refiner_cannot_generalize env ty =
 
 let explain_no_occurrence_found env c id =
   str "Found no subterm matching " ++ pr_lconstr_env env c ++
-  str " in " ++ 
+  str " in " ++
     (match id with
       | Some id -> pr_id id
       | None -> str"the current goal") ++ str "."
@@ -427,11 +433,21 @@ let explain_cannot_unify_binding_type env m n =
 
 let explain_cannot_find_well_typed_abstraction env p l =
   str "Abstracting over the " ++
-  str (plural (List.length l) "term") ++ spc () ++ 
+  str (plural (List.length l) "term") ++ spc () ++
   hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++
-  str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ 
+  str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++
   str "which is ill-typed."
 
+let explain_abstraction_over_meta _ m n =
+  strbrk "Too complex unification problem: cannot find a solution for both " ++
+  pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "."
+
+let explain_non_linear_unification env m t =
+  strbrk "Cannot unambiguously instantiate " ++
+  pr_name m ++ str ":" ++
+  strbrk " which would require to abstract twice on " ++
+  pr_lconstr_env env t ++ str "."
+
 let explain_type_error env err =
   let env = make_all_name_different env in
   match err with
@@ -485,25 +501,26 @@ let explain_pretype_error env err =
   | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n
   | CannotFindWellTypedAbstraction (p,l) ->
       explain_cannot_find_well_typed_abstraction env p l
+  | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n
+  | NonLinearUnification (m,c) -> explain_non_linear_unification env m c
 
-      
 (* Typeclass errors *)
 
 let explain_not_a_class env c =
   pr_constr_env env c ++ str" is not a declared type class."
 
 let explain_unbound_method env cid id =
-  str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++ 
+  str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++
     pr_global cid ++ str "."
 
-let pr_constr_exprs exprs = 
-  hv 0 (List.fold_right 
+let pr_constr_exprs exprs =
+  hv 0 (List.fold_right
 	 (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps)
          exprs (mt ()))
 
 let explain_no_instance env (_,id) l =
   str "No instance found for class " ++ Nameops.pr_id id ++ spc () ++
-  str "applied to arguments" ++ spc () ++ 
+  str "applied to arguments" ++ spc () ++
     prlist_with_sep pr_spc (pr_lconstr_env env) l
 
 let pr_constraints printenv env evm =
@@ -512,40 +529,41 @@ let pr_constraints printenv env evm =
     if List.for_all (fun (ev', evi') ->
       eq_named_context_val evi.evar_hyps evi'.evar_hyps) l
     then
-      let pe = pr_ne_context_of (str "In environment:") (mt ()) 
+      let pe = pr_ne_context_of (str "In environment:") (mt ())
 	(reset_with_named_context evi.evar_hyps env) in
 	(if printenv then pe ++ fnl () else mt ()) ++
-	  prlist_with_sep (fun () -> fnl ()) 
+	  prlist_with_sep (fun () -> fnl ())
 	  (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l
     else
       pr_evar_map evm
-      
+
 let explain_unsatisfiable_constraints env evd constr =
-  let evm = Evd.evars_of evd in
+  let evm = Evarutil.nf_evars evd in
+  let undef = Evd.undefined_evars evm in
   match constr with
   | None ->
       str"Unable to satisfy the following constraints:" ++ fnl() ++
 	pr_constraints true env evm
-  | Some (evi, k) -> 
-      explain_unsolvable_implicit env evi k None ++ fnl () ++
-	if List.length (Evd.to_list evm) > 1 then
-	  str"With the following constraints:" ++ fnl() ++ 
-	    pr_constraints false env evm
+  | Some (ev, k) ->
+      explain_unsolvable_implicit env (Evd.find evm ev) k None ++ fnl () ++
+	if List.length (Evd.to_list undef) > 1 then
+	  str"With the following constraints:" ++ fnl() ++
+	    pr_constraints false env (Evd.remove undef ev)
 	else mt ()
-	
-let explain_mismatched_contexts env c i j = 
+
+let explain_mismatched_contexts env c i j =
   str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++
-    hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++ 
+    hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++
     hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i)
 
-let explain_typeclass_error env err = 
+let explain_typeclass_error env err =
   match err with
     | NotAClass c -> explain_not_a_class env c
     | UnboundMethod (cid, id) -> explain_unbound_method env cid id
     | NoInstance (id, l) -> explain_no_instance env id l
     | UnsatisfiableConstraints (evd, c) -> explain_unsatisfiable_constraints env evd c
     | MismatchedContextInstance (c, i, j) -> explain_mismatched_contexts env c i j
-	
+
 (* Refiner errors *)
 
 let explain_refiner_bad_type arg ty conclty =
@@ -555,9 +573,9 @@ let explain_refiner_bad_type arg ty conclty =
   str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "."
 
 let explain_refiner_unresolved_bindings l =
-  str "Unable to find an instance for the " ++ 
+  str "Unable to find an instance for the " ++
   str (plural (List.length l) "variable") ++ spc () ++
-  prlist_with_sep pr_coma pr_name l ++ str"."
+  prlist_with_sep pr_comma pr_name l ++ str"."
 
 let explain_refiner_cannot_apply t harg =
   str "In refiner, a term of type" ++ brk(1,1) ++
@@ -579,9 +597,9 @@ let explain_non_linear_proof c =
   spc () ++ str "because a metavariable has several occurrences."
 
 let explain_meta_in_type c =
-  str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ 
+  str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++
   str " of another meta"
-    
+
 let explain_refiner_error = function
   | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
   | UnresolvedBindings t -> explain_refiner_unresolved_bindings t
@@ -610,9 +628,9 @@ let error_ill_formed_constructor env id c v nparams nargs =
   let pv = pr_lconstr_env env v in
   let atomic = (nb_prod c = 0) in
   str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++
-  str "is not valid;" ++ brk(1,1) ++ 
-  strbrk (if atomic then "it must be " else "its conclusion must be ") ++ 
-  pv ++ 
+  str "is not valid;" ++ brk(1,1) ++
+  strbrk (if atomic then "it must be " else "its conclusion must be ") ++
+  pv ++
   (* warning: because of implicit arguments it is difficult to say which
      parameters must be explicitly given *)
   (if nparams<>0 then
@@ -643,7 +661,7 @@ let error_same_names_constructors id =
 let error_same_names_overlap idl =
   strbrk "The following names are used both as type names and constructor " ++
   str "names:" ++ spc () ++
-  prlist_with_sep pr_coma pr_id idl ++ str "."
+  prlist_with_sep pr_comma pr_id idl ++ str "."
 
 let error_not_an_arity id =
   str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity."
@@ -658,7 +676,7 @@ let error_large_non_prop_inductive_not_in_type () =
 
 let error_not_allowed_case_analysis isrec kind i =
   str (if isrec then "Induction" else "Case analysis") ++
-  strbrk " on sort " ++ pr_sort kind ++ 
+  strbrk " on sort " ++ pr_sort kind ++
   strbrk " is not allowed for inductive definition " ++
   pr_inductive (Global.env()) i ++ str "."
 
@@ -788,39 +806,46 @@ let explain_reduction_tactic_error = function
       spc () ++ str "is not well typed." ++ fnl () ++
       explain_type_error env' e
 
-let explain_ltac_call_trace (last,trace,loc) =
-  let calls = last :: List.rev (List.map snd trace) in
-  let pr_call = function
-  | Proof_type.LtacNotationCall s -> quote (str s)
-  | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
-  | Proof_type.LtacVarCall (id,t) ->
-      quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ 
-      Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
-  | Proof_type.LtacAtomCall (te,otac) -> quote
-      (Pptactic.pr_glob_tactic (Global.env())
-	(Tacexpr.TacAtom (dummy_loc,te)))
-      ++ (match !otac with
-      | Some te' when (Obj.magic te' <> te) ->
-	  strbrk " (expanded to " ++ quote
-	  (Pptactic.pr_tactic (Global.env())
-	    (Tacexpr.TacAtom (dummy_loc,te')))
-	++ str ")"
-      | _ -> mt ())
-  | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) ->
-      let filter =
-	function (id,None) -> None | (id,Some id') -> Some(id,mkVar id') in
-      let unboundvars = list_map_filter filter unboundvars in
-      quote (pr_rawconstr_env (Global.env()) c) ++
-      (if unboundvars <> [] or vars <> [] then
-	strbrk " (with " ++ prlist_with_sep pr_coma (fun (id,c) -> 
-	pr_id id ++ str ":=" ++ Printer.pr_lconstr c)
-	  (List.rev vars @ unboundvars) ++ str ")"
+let explain_ltac_call_trace (nrep,last,trace,loc) =
+  let calls =
+    (nrep,last) :: List.rev (List.map(fun(n,_,ck)->(n,ck))trace) in
+  let pr_call (n,ck) =
+    (match ck with
+       | Proof_type.LtacNotationCall s -> quote (str s)
+       | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
+       | Proof_type.LtacVarCall (id,t) ->
+	   quote (Nameops.pr_id id) ++ strbrk " (bound to " ++
+	     Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
+       | Proof_type.LtacAtomCall (te,otac) -> quote
+	   (Pptactic.pr_glob_tactic (Global.env())
+	      (Tacexpr.TacAtom (dummy_loc,te)))
+	   ++ (match !otac with
+		 | Some te' when (Obj.magic te' <> te) ->
+		     strbrk " (expanded to " ++ quote
+		       (Pptactic.pr_tactic (Global.env())
+			  (Tacexpr.TacAtom (dummy_loc,te')))
+		     ++ str ")"
+		 | _ -> mt ())
+       | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) ->
+	   let filter =
+	     function (id,None) -> None | (id,Some id') -> Some(id,([],mkVar id')) in
+	   let unboundvars = list_map_filter filter unboundvars in
+	   quote (pr_rawconstr_env (Global.env()) c) ++
+	     (if unboundvars <> [] or vars <> [] then
+		strbrk " (with " ++
+		  prlist_with_sep pr_comma
+		  (fun (id,c) ->
+		     pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c)
+		  (List.rev vars @ unboundvars) ++ str ")"
+	      else mt())) ++
+      (if n=2 then str " (repeated twice)"
+       else if n>2 then str " (repeated "++int n++str" times)"
        else mt()) in
-  if calls <> [] then
-    let kind_of_last_call = match list_last calls with
-    | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed."
+    if calls <> [] then
+      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 " ++ 
+    hov 0 (str "In nested Ltac calls to " ++
            pr_enum pr_call calls ++ strbrk kind_of_last_call)
   else
     mt ()
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
index ff5991de..848fec79 100644
--- a/toplevel/himsg.mli
+++ b/toplevel/himsg.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: himsg.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -29,7 +29,7 @@ val explain_pretype_error : env -> pretype_error -> std_ppcmds
 
 val explain_inductive_error : inductive_error -> std_ppcmds
 
-val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds 
+val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds
 
 val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds
 
@@ -41,5 +41,6 @@ val explain_pattern_matching_error :
 val explain_reduction_tactic_error :
   Tacred.reduction_tactic_error -> std_ppcmds
 
-val explain_ltac_call_trace : 
-  Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> std_ppcmds
+val explain_ltac_call_trace :
+  int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc ->
+  std_ppcmds
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
index 4b97f8b2..492b21e0 100644
--- a/toplevel/ind_tables.ml
+++ b/toplevel/ind_tables.ml
@@ -6,97 +6,171 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ind_tables.ml 10739 2008-04-01 14:45:20Z herbelin $ i*)
+(*i $Id$ i*)
 
-open Names
-open Mod_subst
-
-let eq_scheme_map = ref Indmap.empty 
-
-let cache_scheme (_,(ind,const)) = 
-    eq_scheme_map := Indmap.add ind const (!eq_scheme_map)
-
-let export_scheme obj =
-    Some obj
-
-
-
-let _ = Summary.declare_summary "eqscheme"
-    { Summary.freeze_function = (fun () -> !eq_scheme_map);
-      Summary.unfreeze_function = (fun fs -> eq_scheme_map := fs);
-      Summary.init_function = (fun () -> eq_scheme_map := Indmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = true}
-
-let find_eq_scheme ind = 
-  Indmap.find ind !eq_scheme_map
-
-let check_eq_scheme ind = 
-  Indmap.mem ind !eq_scheme_map
-
-let bl_map = ref Indmap.empty
-let lb_map = ref Indmap.empty
-let dec_map = ref Indmap.empty
-
-
-let cache_bl (_,(ind,const)) = 
-    bl_map := Indmap.add ind const (!bl_map)
-
-let cache_lb (_,(ind,const)) = 
-    lb_map := Indmap.add ind const (!lb_map)
-
-let cache_dec (_,(ind,const)) = 
-    dec_map := Indmap.add ind const (!dec_map)
-
-let export_bool_leib obj =
-    Some obj
-
-let export_leib_bool obj =
-    Some obj
-
-let export_dec_proof obj =
-    Some obj
-
-
-
-let _ = Summary.declare_summary "bl_proof"
-    { Summary.freeze_function = (fun () -> !bl_map);
-      Summary.unfreeze_function = (fun fs -> bl_map := fs);
-      Summary.init_function = (fun () -> bl_map := Indmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = true}
-
-let find_bl_proof ind = 
-  Indmap.find ind !bl_map
-
-let check_bl_proof ind =
-  Indmap.mem ind !bl_map
-
-let _ = Summary.declare_summary "lb_proof"
-    { Summary.freeze_function = (fun () -> !lb_map);
-      Summary.unfreeze_function = (fun fs -> lb_map := fs);
-      Summary.init_function = (fun () -> lb_map := Indmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = true}
-
-let find_lb_proof ind = 
-  Indmap.find ind !lb_map
-
-let check_lb_proof ind =
-  Indmap.mem ind !lb_map
-
-let _ = Summary.declare_summary "eq_dec_proof"
-    { Summary.freeze_function = (fun () -> !dec_map);
-      Summary.unfreeze_function = (fun fs -> dec_map := fs);
-      Summary.init_function = (fun () -> dec_map := Indmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = true}
-
-let find_eq_dec_proof ind = 
-  Indmap.find ind !dec_map
-
-let check_dec_proof ind =
-  Indmap.mem ind !dec_map
+(* File created by Vincent Siles, Oct 2007, extended into a generic
+   support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *)
 
+(* This file provides support for registering inductive scheme builders,
+   declaring schemes and generating schemes on demand *)
 
+open Names
+open Mod_subst
+open Libobject
+open Nameops
+open Declarations
+open Term
+open Util
+open Declare
+open Entries
+open Decl_kinds
+
+(**********************************************************************)
+(* Registering schemes in the environment *)
+
+type mutual_scheme_object_function = mutual_inductive -> constr array
+type individual_scheme_object_function = inductive -> constr
+
+type 'a scheme_kind = string
+
+let scheme_map = ref Indmap.empty
+
+let cache_one_scheme kind (ind,const) =
+  let map = try Indmap.find ind !scheme_map with Not_found -> Stringmap.empty in
+  scheme_map := Indmap.add ind (Stringmap.add kind const map) !scheme_map
+
+let cache_scheme (_,(kind,l)) =
+  Array.iter (cache_one_scheme kind) l
+
+let subst_one_scheme subst ((mind,i),const) =
+  (* Remark: const is a def: the result of substitution is a constant *)
+  ((subst_ind subst mind,i),fst (subst_con subst const))
+
+let subst_scheme (subst,(kind,l)) =
+  (kind,Array.map (subst_one_scheme subst) l)
+
+let discharge_scheme (_,(kind,l)) =
+  Some (kind,Array.map (fun (ind,const) ->
+    (Lib.discharge_inductive ind,Lib.discharge_con const)) l)
+
+let (inScheme,_) =
+  declare_object {(default_object "SCHEME") with
+                    cache_function = cache_scheme;
+                    load_function = (fun _ -> cache_scheme);
+                    subst_function = subst_scheme;
+		    classify_function = (fun obj -> Substitute obj);
+		    discharge_function = discharge_scheme}
+
+(**********************************************************************)
+(* Saving/restoring the table of scheme *)
+
+let freeze_schemes () = !scheme_map
+let unfreeze_schemes sch = scheme_map := sch
+let init_schemes () = scheme_map := Indmap.empty
+
+let _ =
+  Summary.declare_summary "Schemes"
+    { Summary.freeze_function = freeze_schemes;
+      Summary.unfreeze_function = unfreeze_schemes;
+      Summary.init_function = init_schemes }
+
+(**********************************************************************)
+(* The table of scheme building functions *)
+
+type individual
+type mutual
+
+type scheme_object_function =
+  | MutualSchemeFunction of (mutual_inductive -> constr array)
+  | IndividualSchemeFunction of (inductive -> constr)
+
+let scheme_object_table =
+  (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t)
+
+let declare_scheme_object s aux f =
+  (try check_ident ("ind"^s) with _ ->
+    error ("Illegal induction scheme suffix: "^s));
+  let key = if aux = "" then s else aux in
+  try
+    let _ = Hashtbl.find scheme_object_table key in
+(*    let aux_msg = if aux="" then "" else " (with key "^aux^")" in*)
+    error ("Scheme object "^key^" already declared.")
+  with Not_found ->
+    Hashtbl.add scheme_object_table key (s,f);
+    key
+
+let declare_mutual_scheme_object s ?(aux="") f =
+  declare_scheme_object s aux (MutualSchemeFunction f)
+
+let declare_individual_scheme_object s ?(aux="") f =
+  declare_scheme_object s aux (IndividualSchemeFunction f)
+
+(**********************************************************************)
+(* Defining/retrieving schemes *)
+
+let declare_scheme kind indcl =
+  Lib.add_anonymous_leaf (inScheme (kind,indcl))
+
+let define internal id c =
+  (* TODO: specify even more by distinguish between KernelVerbose and
+   * UserVerbose *)
+  let fd = match internal with 
+    | KernelSilent -> declare_internal_constant
+    | _ -> declare_constant in
+  let kn = fd id
+    (DefinitionEntry
+      { const_entry_body = c;
+        const_entry_type = None;
+        const_entry_opaque = false;
+	const_entry_boxed = Flags.boxed_definitions() },
+      Decl_kinds.IsDefinition Scheme) in
+  (match internal with
+  | KernelSilent -> ()
+  | _-> definition_message id);
+  kn
+
+let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) =
+  let c = f ind in
+  let mib = Global.lookup_mind mind in
+  let id = match idopt with
+    | Some id -> id
+    | None -> add_suffix mib.mind_packets.(i).mind_typename suff in
+  let const = define internal id c in
+  declare_scheme kind [|ind,const|];
+  const
+
+let define_individual_scheme kind internal names (mind,i as ind) =
+  match Hashtbl.find scheme_object_table kind with
+  | _,MutualSchemeFunction f -> assert false
+  | s,IndividualSchemeFunction f ->
+      define_individual_scheme_base kind s f internal names ind
+
+let define_mutual_scheme_base kind suff f internal names mind =
+  let cl = f mind in
+  let mib = Global.lookup_mind mind in
+  let ids = Array.init (Array.length mib.mind_packets) (fun i ->
+      try List.assoc i names
+      with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in
+  let consts = array_map2 (define internal) ids cl in
+  declare_scheme kind (Array.mapi (fun i cst -> ((mind,i),cst)) consts);
+  consts
+
+let define_mutual_scheme kind internal names mind =
+  match Hashtbl.find scheme_object_table kind with
+  | _,IndividualSchemeFunction _ -> assert false
+  | s,MutualSchemeFunction f ->
+      define_mutual_scheme_base kind s f internal names mind
+
+let find_scheme kind (mind,i as ind) =
+  try Stringmap.find kind (Indmap.find ind !scheme_map)
+  with Not_found ->
+  match Hashtbl.find scheme_object_table kind with
+  | s,IndividualSchemeFunction f ->
+      define_individual_scheme_base kind s f KernelSilent None ind
+  | s,MutualSchemeFunction f ->
+      (define_mutual_scheme_base kind s f KernelSilent [] mind).(i)
+
+let check_scheme kind ind =
+  try let _ = Stringmap.find kind (Indmap.find ind !scheme_map) in true
+  with Not_found -> false
 
diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli
index 2edb294f..a8012bc7 100644
--- a/toplevel/ind_tables.mli
+++ b/toplevel/ind_tables.mli
@@ -11,30 +11,42 @@ open Names
 open Libnames
 open Mod_subst
 open Sign
+open Declarations
 
+(* This module provides support for registering inductive scheme builders,
+   declaring schemes and generating schemes on demand *)
 
-val cache_scheme :(object_name*(Indmap.key*constr)) -> unit
-val export_scheme : (Indmap.key*constr) -> (Indmap.key*constr) option 
+(* A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *)
 
-val find_eq_scheme : Indmap.key -> constr
-val check_eq_scheme : Indmap.key -> bool
+type mutual
+type individual
+type 'a scheme_kind
 
-val cache_bl: (object_name*(Indmap.key*constr)) -> unit 
-val cache_lb: (object_name*(Indmap.key*constr)) -> unit 
-val cache_dec : (object_name*(Indmap.key*constr)) -> unit 
+type mutual_scheme_object_function = mutual_inductive -> constr array
+type individual_scheme_object_function = inductive -> constr
 
-val export_bool_leib : (Indmap.key*constr) -> (Indmap.key*constr) option 
-val export_leib_bool : (Indmap.key*constr) -> (Indmap.key*constr) option 
-val export_dec_proof : (Indmap.key*constr) -> (Indmap.key*constr) option 
+(* Main functions to register a scheme builder *)
 
-val find_bl_proof : Indmap.key -> constr
-val find_lb_proof : Indmap.key -> constr
-val find_eq_dec_proof : Indmap.key -> constr
+val declare_mutual_scheme_object : string -> ?aux:string ->
+  mutual_scheme_object_function -> mutual scheme_kind
 
-val check_bl_proof: Indmap.key -> bool 
-val check_lb_proof: Indmap.key -> bool 
-val check_dec_proof: Indmap.key -> bool 
+val declare_individual_scheme_object : string -> ?aux:string ->
+  individual_scheme_object_function -> individual scheme_kind
 
+(*
+val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit
+*)
 
+(* Force generation of a (mutually) scheme with possibly user-level names *)
 
+val define_individual_scheme : individual scheme_kind -> 
+  Declare.internal_flag (* internal *) ->
+  identifier option -> inductive -> constant
 
+val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (* internal *) ->
+  (int * identifier) list -> mutual_inductive -> constant array
+
+(* Main function to retrieve a scheme in the cache or to generate it *)
+val find_scheme : 'a scheme_kind -> inductive -> constant
+
+val check_scheme : 'a scheme_kind -> inductive -> bool
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
new file mode 100644
index 00000000..58f77b90
--- /dev/null
+++ b/toplevel/indschemes.ml
@@ -0,0 +1,460 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Created by Hugo Herbelin from contents related to inductive schemes
+   initially developed by Christine Paulin (induction schemes), Vincent
+   Siles (decidable equality and boolean equality) and Matthieu Sozeau
+   (combined scheme) in file command.ml, Sep 2009 *)
+
+(* This file provides entry points for manually or automatically
+   declaring new schemes *)
+
+open Pp
+open Flags
+open Util
+open Names
+open Declarations
+open Entries
+open Term
+open Inductive
+open Decl_kinds
+open Indrec
+open Declare
+open Libnames
+open Goptions
+open Nameops
+open Termops
+open Typeops
+open Inductiveops
+open Pretyping
+open Topconstr
+open Nametab
+open Smartlocate
+open Vernacexpr
+open Ind_tables
+open Auto_ind_decl
+open Eqschemes
+open Elimschemes
+
+(* Flags governing automatic synthesis of schemes *)
+
+let elim_flag = ref true
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic declaration of induction schemes";
+      optkey   = ["Elimination";"Schemes"];
+      optread  = (fun () -> !elim_flag) ;
+      optwrite = (fun b -> elim_flag := b) }
+
+let case_flag = ref true
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic declaration of case analysis schemes";
+      optkey   = ["Case";"Analysis";"Schemes"];
+      optread  = (fun () -> !case_flag) ;
+      optwrite = (fun b -> case_flag := b) }
+
+let eq_flag = ref true
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic declaration of boolean equality";
+      optkey   = ["Boolean";"Equality";"Schemes"];
+      optread  = (fun () -> !eq_flag) ;
+      optwrite = (fun b -> eq_flag := b) }
+let _ = (* compatibility *)
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic declaration of boolean equality";
+      optkey   = ["Equality";"Scheme"];
+      optread  = (fun () -> !eq_flag) ;
+      optwrite = (fun b -> eq_flag := b) }
+
+let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2
+
+let eq_dec_flag = ref false
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic declaration of decidable equality";
+      optkey   = ["Decidable";"Equality";"Schemes"];
+      optread  = (fun () -> !eq_dec_flag) ;
+      optwrite = (fun b -> eq_dec_flag := b) }
+
+let rewriting_flag = ref false
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optname  ="automatic declaration of rewriting schemes for equality types";
+      optkey   = ["Rewriting";"Schemes"];
+      optread  = (fun () -> !rewriting_flag) ;
+      optwrite = (fun b -> rewriting_flag := b) }
+
+(* Util *)
+
+let define id internal c t =
+  (* TODO: specify even more by distinguish KernelVerbose and UserVerbose *)
+  let f = match internal with
+   | KernelSilent -> declare_internal_constant
+   | _ -> declare_constant in
+  let kn = f id
+    (DefinitionEntry
+      { const_entry_body = c;
+        const_entry_type = t;
+        const_entry_opaque = false;
+	const_entry_boxed = Flags.boxed_definitions() },
+      Decl_kinds.IsDefinition Scheme) in
+  definition_message id;
+  kn
+
+(* Boolean equality *)
+
+let declare_beq_scheme_gen internal names kn =
+  ignore (define_mutual_scheme beq_scheme_kind internal names kn)
+
+let alarm what internal msg =
+  let debug = false in
+  (* TODO: specify even more by distinguish KernelVerbose and UserVerbose *)
+  match internal with
+  | KernelSilent ->
+    (if debug then
+      Flags.if_verbose Pp.msg_warning
+	(hov 0 msg ++ fnl () ++ what ++ str " not defined."))
+  | _ -> errorlabstrm "" msg
+
+let try_declare_scheme what f internal names kn =
+  try f internal names kn
+  with
+    | ParameterWithoutEquality cst ->
+	alarm what internal
+	  (str "Boolean equality not found for parameter " ++ pr_con cst ++
+	   str".")
+    | InductiveWithProduct ->
+	alarm what internal
+	  (str "Unable to decide equality of functional arguments.")
+    | InductiveWithSort ->
+	alarm what internal
+	  (str "Unable to decide equality of type arguments.")
+    | NonSingletonProp ind ->
+	alarm what internal
+	  (str "Cannot extract computational content from proposition " ++
+	   quote (Printer.pr_inductive (Global.env()) ind) ++ str ".")
+    | EqNotFound (ind',ind) ->
+	alarm what internal
+	  (str "Boolean equality on " ++
+	   quote (Printer.pr_inductive (Global.env()) ind') ++
+	   strbrk " is missing.")
+    | UndefinedCst s ->
+	alarm what internal
+	  (strbrk "Required constant " ++ str s ++ str " undefined.")
+    | AlreadyDeclared msg ->
+        alarm what internal (msg ++ str ".")
+    | _ ->
+	alarm what internal
+	  (str "Unknown exception during scheme creation.")
+
+let beq_scheme_msg mind =
+  let mib = Global.lookup_mind mind in
+  (* TODO: mutual inductive case *)
+  str "Boolean equality on " ++
+    pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind))
+    (list_tabulate (fun i -> (mind,i)) (Array.length mib.mind_packets))
+
+let declare_beq_scheme_with l kn =
+  try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn
+
+(* TODO : maybe switch to KernelVerbose to have the right behaviour *)
+let try_declare_beq_scheme kn =
+  (* TODO: handle Fix, see e.g. TheoryList.In_spec, eventually handle
+      proof-irrelevance; improve decidability by depending on decidability
+      for the parameters rather than on the bl and lb properties *)
+  try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen KernelSilent [] kn
+
+let declare_beq_scheme = declare_beq_scheme_with []
+
+(* Case analysis schemes *)
+(* TODO: maybe switch to KernelVerbose *)
+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 kelim = elim_sorts (mib,mip) in
+    (* in case the inductive has a type elimination, generates only one
+       induction scheme, the other ones share the same code with the
+       apropriate type *)
+  if List.mem InType kelim then
+    ignore (define_individual_scheme dep KernelSilent None ind)
+
+(* Induction/recursion schemes *)
+
+let kinds_from_prop =
+  [InType,rect_scheme_kind_from_prop;
+   InProp,ind_scheme_kind_from_prop;
+   InSet,rec_scheme_kind_from_prop]
+
+let kinds_from_type =
+  [InType,rect_dep_scheme_kind_from_type;
+   InProp,ind_dep_scheme_kind_from_type;
+   InSet,rec_dep_scheme_kind_from_type]
+
+  (* TODO: maybe switch to kernel verbose *)
+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 kelim = elim_sorts (mib,mip) in
+  let elims =
+    list_map_filter (fun (sort,kind) ->
+      if List.mem sort kelim then Some kind else None)
+      (if from_prop then kinds_from_prop else kinds_from_type) in
+  List.iter (fun kind -> ignore (define_individual_scheme kind KernelSilent None ind))
+    elims
+
+let declare_induction_schemes kn =
+  let mib = Global.lookup_mind kn in
+  if mib.mind_finite then begin
+    for i = 0 to Array.length mib.mind_packets - 1 do
+      declare_one_induction_scheme (kn,i);
+    done;
+  end
+
+(* Decidable equality *)
+
+let declare_eq_decidability_gen internal names kn =
+  let mib = Global.lookup_mind kn in
+  if mib.mind_finite then
+    ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn)
+
+let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *)
+  str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind)
+
+let declare_eq_decidability_scheme_with l kn =
+  try_declare_scheme (eq_dec_scheme_msg (kn,0))
+    declare_eq_decidability_gen UserVerbose l kn
+
+(* TODO:  maybe switch to kernel verbose *)
+let try_declare_eq_decidability kn =
+  try_declare_scheme (eq_dec_scheme_msg (kn,0))
+    declare_eq_decidability_gen KernelSilent [] kn
+
+let declare_eq_decidability = declare_eq_decidability_scheme_with []
+
+let ignore_error f x = try ignore (f x) with _ -> ()
+
+let declare_rewriting_schemes ind =
+  if Hipattern.is_inductive_equality ind then begin
+    ignore (define_individual_scheme rew_r2l_scheme_kind KernelSilent None ind);
+    ignore (define_individual_scheme rew_r2l_dep_scheme_kind KernelSilent None ind);
+    ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind
+      KernelSilent None ind);
+    (* These ones expect the equality to be symmetric; the first one also *)
+    (* needs eq *)
+    ignore_error (define_individual_scheme rew_l2r_scheme_kind KernelSilent None) ind;
+    ignore_error
+      (define_individual_scheme rew_l2r_dep_scheme_kind KernelSilent None) ind;
+    ignore_error
+      (define_individual_scheme rew_l2r_forward_dep_scheme_kind KernelSilent None) ind
+  end
+
+(* TODO: maybe switch to kernel verbose *)
+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 _ -> false
+    then
+      ignore (define_individual_scheme congr_scheme_kind KernelSilent None ind)
+    else
+      warning "Cannot build congruence scheme because eq is not found"
+  end
+
+(* TODO: maybe switch to kernel verbose *)
+let declare_sym_scheme ind =
+  if Hipattern.is_inductive_equality ind then
+    (* Expect the equality to be symmetric *)
+    ignore_error (define_individual_scheme sym_scheme_kind KernelSilent None) ind
+
+(* Scheme command *)
+
+let rec split_scheme l =
+ let env = Global.env() in
+ match l with
+  | [] -> [],[]
+  | (Some id,t)::q -> let l1,l2 = split_scheme q in
+    ( match t with
+      | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
+      | EqualityScheme  x -> l1,((Some id,smart_global_inductive x)::l2)
+    )
+(*
+ if no name has been provided, we build one from the types of the ind
+requested
+*)
+  | (None,t)::q ->
+       let l1,l2 = split_scheme q in
+    ( match t with
+      | InductionScheme (x,y,z) ->
+             let ind = smart_global_inductive y in
+             let sort_of_ind = Retyping.get_sort_family_of env Evd.empty (mkInd ind) in
+             let z' = family_of_sort (interp_sort z) in
+             let suffix = (
+                match sort_of_ind with
+                | InProp ->
+                    if x then (match z' with
+                       | InProp -> "_ind_nodep"
+                       | InSet -> "_rec_nodep"
+                       | InType -> "_rect_nodep")
+                    else ( match z' with
+                       | InProp -> "_ind"
+                       | InSet -> "_rec"
+                       | InType -> "_rect" )
+                | _ ->
+                    if x then (match z' with
+                       | InProp -> "_ind"
+                       | InSet -> "_rec"
+                       | InType -> "_rect" )
+                    else (match z' with
+                       | InProp -> "_ind_dep"
+                       | InSet  -> "_rec_dep"
+                       | InType -> "_rect_dep")
+                ) in
+            let newid = add_suffix (basename_of_global (IndRef ind)) suffix in
+            let newref = (dummy_loc,newid) in
+          ((newref,x,ind,z)::l1),l2
+      | EqualityScheme  x -> l1,((None,smart_global_inductive x)::l2)
+    )
+
+let do_mutual_induction_scheme lnamedepindsort =
+  let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
+  and sigma = Evd.empty
+  and env0 = Global.env() in
+  let lrecspec =
+    List.map
+      (fun (_,dep,ind,sort) -> (ind,dep,interp_elimination_sort sort))
+      lnamedepindsort
+  in
+  let listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in
+  let rec declare decl fi lrecref =
+    let decltype = Retyping.get_type_of env0 Evd.empty decl in
+    let decltype = refresh_universes decltype in
+    let cst = define fi UserVerbose decl (Some decltype) in
+    ConstRef cst :: lrecref
+  in
+  let _ = List.fold_right2 declare listdecl lrecnames [] in
+  fixpoint_message None lrecnames
+
+let get_common_underlying_mutual_inductive = function
+  | [] -> assert false
+  | (id,(mind,i as ind))::l as all ->
+      match List.filter (fun (_,(mind',_)) -> mind <> mind') l with
+      | (_,ind')::_ ->
+	  raise (RecursionSchemeError (NotMutualInScheme (ind,ind')))
+      | [] ->
+	  if not (list_distinct (List.map snd (List.map snd all))) then
+	    error "A type occurs twice";
+	  mind,
+	  list_map_filter
+	    (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all
+
+let do_scheme l =
+  let ischeme,escheme = split_scheme l in
+(* we want 1 kind of scheme at a time so we check if the user
+tried to declare different schemes at once *)
+    if (ischeme <> []) && (escheme <> [])
+    then
+      error "Do not declare equality and induction scheme at the same time."
+    else (
+      if ischeme <> [] then do_mutual_induction_scheme ischeme
+      else
+	let mind,l = get_common_underlying_mutual_inductive escheme in
+	declare_beq_scheme_with l mind;
+	declare_eq_decidability_scheme_with l mind
+    )
+
+(**********************************************************************)
+(* Combined scheme *)
+(* Matthieu Sozeau, Dec 2006 *)
+
+let list_split_rev_at index l =
+  let rec aux i acc = function
+      hd :: tl when i = index -> acc, tl
+    | hd :: tl -> aux (succ i) (hd :: acc) tl
+    | [] -> failwith "list_split_when: Invalid argument"
+  in aux 0 [] l
+
+let fold_left' f = function
+    [] -> raise (Invalid_argument "fold_left'")
+  | hd :: tl -> List.fold_left f hd tl
+
+let build_combined_scheme env schemes =
+  let defs = List.map (fun cst -> (cst, Typeops.type_of_constant env cst)) schemes in
+(*   let nschemes = List.length schemes in *)
+  let find_inductive ty =
+    let (ctx, arity) = decompose_prod ty in
+    let (_, last) = List.hd ctx in
+      match kind_of_term last with
+	| App (ind, args) ->
+	    let ind = destInd ind in
+	    let (_,spec) = Inductive.lookup_mind_specif env ind in
+	      ctx, ind, spec.mind_nrealargs
+	| _ -> ctx, destInd last, 0
+  in
+  let (c, t) = List.hd defs in
+  let ctx, ind, nargs = find_inductive t in
+  (* Number of clauses, including the predicates quantification *)
+  let prods = nb_prod t - (nargs + 1) in
+  let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in
+  let relargs = rel_vect 0 prods in
+  let concls = List.rev_map
+    (fun (cst, t) ->
+      mkApp(mkConst cst, relargs),
+      snd (decompose_prod_n prods t)) defs in
+  let concl_bod, concl_typ =
+    fold_left'
+      (fun (accb, acct) (cst, x) ->
+	mkApp (coqconj, [| x; acct; cst; accb |]),
+	mkApp (coqand, [| x; acct |])) concls
+  in
+  let ctx, _ =
+    list_split_rev_at prods
+      (List.rev_map (fun (x, y) -> x, None, 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)
+
+let do_combined_scheme name schemes =
+  let csts =
+    List.map (fun x ->
+		let refe = Ident x in
+		let qualid = qualid_of_reference refe in
+		try Nametab.locate_constant (snd qualid)
+                with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared."))
+      schemes
+  in
+  let body,typ = build_combined_scheme (Global.env ()) csts in
+  ignore (define (snd name) UserVerbose body (Some typ));
+  fixpoint_message None [snd name]
+
+(**********************************************************************)
+
+let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done
+
+let mutual_inductive_size kn = Array.length (Global.lookup_mind kn).mind_packets
+
+let declare_default_schemes kn =
+  let n = mutual_inductive_size kn in
+  if !elim_flag then declare_induction_schemes kn;
+  if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n;
+  if is_eq_flag() then try_declare_beq_scheme kn;
+  if !eq_dec_flag then try_declare_eq_decidability kn;
+  if !rewriting_flag then map_inductive_block declare_congr_scheme kn n;
+  if !rewriting_flag then map_inductive_block declare_sym_scheme kn n;
+  if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
new file mode 100644
index 00000000..9aa32b7b
--- /dev/null
+++ b/toplevel/indschemes.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Environ
+open Libnames
+open Rawterm
+open Genarg
+open Vernacexpr
+open Ind_tables
+(*i*)
+
+(* See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
+
+(* Build and register the boolean equalities associated to an inductive type *)
+
+val declare_beq_scheme : mutual_inductive -> unit
+
+val declare_eq_decidability : mutual_inductive -> unit
+
+(* Build and register a congruence scheme for an equality-like inductive type *)
+
+val declare_congr_scheme : inductive -> unit
+
+(* Build and register rewriting schemes for an equality-like inductive type *)
+
+val declare_rewriting_schemes : inductive -> unit
+
+(* Mutual Minimality/Induction scheme *)
+
+val do_mutual_induction_scheme :
+  (identifier located * bool * inductive * rawsort) list -> unit
+
+(* Main calls to interpret the Scheme command *)
+
+val do_scheme : (identifier located option * scheme) list -> unit
+
+(* Combine a list of schemes into a conjunction of them *)
+
+val build_combined_scheme : env -> constant list -> constr * types
+
+val do_combined_scheme : identifier located -> identifier located list -> unit
+
+(* Hook called at each inductive type definition *)
+
+val declare_default_schemes : mutual_inductive -> unit
diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml
new file mode 100644
index 00000000..446d6315
--- /dev/null
+++ b/toplevel/lemmas.ml
@@ -0,0 +1,347 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Created by Hugo Herbelin from contents related to lemma proofs in
+   file command.ml, Aug 2009 *)
+
+open Util
+open Flags
+open Pp
+open Names
+open Term
+open Declarations
+open Entries
+open Environ
+open Nameops
+open Libnames
+open Decls
+open Decl_kinds
+open Declare
+open Pretyping
+open Termops
+open Namegen
+open Evd
+open Evarutil
+open Reductionops
+open Topconstr
+open Constrintern
+open Impargs
+open Tacticals
+
+(* Support for mutually proved theorems *)
+
+let retrieve_first_recthm = function
+  | VarRef id ->
+      (pi2 (Global.lookup_named id),variable_opacity id)
+  | ConstRef cst ->
+      let {const_body=body;const_opaque=opaq} =	Global.lookup_constant cst in
+      (Option.map Declarations.force body,opaq)
+  | _ -> assert false
+
+let adjust_guardness_conditions const = function
+  | [] -> const (* Not a recursive statement *)
+  | possible_indexes ->
+  (* Try all combinations... not optimal *)
+  match kind_of_term const.const_entry_body with
+  | Fix ((nv,0),(_,_,fixdefs as fixdecls)) ->
+(*      let possible_indexes =
+	List.map2 (fun i c -> match i with Some i -> i | None ->
+	  interval 0 (List.length ((lam_assum c))))
+	  lemma_guard (Array.to_list fixdefs) in
+*)
+      let indexes =
+	search_guard dummy_loc (Global.env()) possible_indexes fixdecls in
+      { const with const_entry_body = mkFix ((indexes,0),fixdecls) }
+  | c -> const
+
+let find_mutually_recursive_statements thms =
+    let n = List.length thms in
+    let inds = List.map (fun (id,(t,impls,annot)) ->
+      let (hyps,ccl) = decompose_prod_assum t in
+      let x = (id,(t,impls)) in
+      match annot with
+      (* Explicit fixpoint decreasing argument is given *)
+      | Some (Some (_,id),CStructRec) ->
+          let i,b,typ = lookup_rel_id id hyps in
+          (match kind_of_term t with
+          | Ind (kn,_ as ind) when
+              let mind = Global.lookup_mind kn in
+              mind.mind_finite & b = None ->
+              [ind,x,i],[]
+          | _ ->
+              error "Decreasing argument is not an inductive assumption.")
+      (* Unsupported cases *)
+      | Some (_,(CWfRec _|CMeasureRec _)) ->
+          error "Only structural decreasing is supported for mutual statements."
+      (* Cofixpoint or fixpoint w/o explicit decreasing argument *)
+      | None | Some (None, CStructRec) ->
+      let whnf_hyp_hds = map_rel_context_in_env
+        (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c))
+        (Global.env()) hyps in
+      let ind_hyps =
+        List.flatten (list_map_i (fun i (_,b,t) ->
+          match kind_of_term t with
+          | Ind (kn,_ as ind) when
+                let mind = Global.lookup_mind kn in
+                mind.mind_finite & b = None ->
+              [ind,x,i]
+          | _ ->
+              []) 0 (List.rev whnf_hyp_hds)) in
+      let ind_ccl =
+        let cclenv = push_rel_context hyps (Global.env()) in
+        let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in
+        match kind_of_term whnf_ccl with
+        | Ind (kn,_ as ind) when
+              let mind = Global.lookup_mind kn in
+              mind.mind_ntypes = n & not mind.mind_finite ->
+            [ind,x,0]
+        | _ ->
+            [] in
+      ind_hyps,ind_ccl) thms in
+    let inds_hyps,ind_ccls = List.split inds in
+    let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in
+    (* Check if all conclusions are coinductive in the same type *)
+    (* (degenerated cartesian product since there is at most one coind ccl) *)
+    let same_indccl =
+      list_cartesians_filter (fun hyp oks ->
+	if List.for_all (of_same_mutind hyp) oks
+	then Some (hyp::oks) else None) [] ind_ccls in
+    let ordered_same_indccl =
+      List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in
+    (* Check if some hypotheses are inductive in the same type *)
+    let common_same_indhyp =
+      list_cartesians_filter (fun hyp oks ->
+	if List.for_all (of_same_mutind hyp) oks
+	then Some (hyp::oks) else None) [] inds_hyps in
+    let ordered_inds,finite,guard =
+      match ordered_same_indccl, common_same_indhyp with
+      | indccl::rest, _ ->
+	  assert (rest=[]);
+          (* One occ. of common coind ccls and no common inductive hyps *)
+	  if common_same_indhyp <> [] then
+	    if_verbose warning "Assuming mutual coinductive statements.";
+	  flush_all ();
+          indccl, true, []
+      | [], _::_ ->
+	  if same_indccl <> [] &&
+	     list_distinct (List.map pi1 (List.hd same_indccl)) then
+	    if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all ();
+          let possible_guards = List.map (List.map pi3) inds_hyps in
+	  (* assume the largest indices as possible *)
+	  list_last common_same_indhyp, false, possible_guards
+      | _, [] ->
+	  error
+            ("Cannot find common (mutual) inductive premises or coinductive" ^
+             " conclusions in the statements.")
+    in
+    (finite,guard,None), ordered_inds
+
+let look_for_possibly_mutual_statements = function
+  | [id,(t,impls,None)] ->
+      (* One non recursively proved theorem *)
+      None,[id,(t,impls)],None
+  | _::_ as thms ->
+    (* More than one statement and/or an explicit decreasing mark: *)
+    (* we look for a common inductive hyp or a common coinductive conclusion *)
+    let recguard,ordered_inds = find_mutually_recursive_statements thms in
+    let thms = List.map pi2 ordered_inds in
+    Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds)
+  | [] -> anomaly "Empty list of theorems."
+
+(* Saving a goal *)
+
+let save id const do_guard (locality,kind) hook =
+  let const = adjust_guardness_conditions const do_guard in
+  let {const_entry_body = pft;
+       const_entry_type = tpo;
+       const_entry_opaque = opacity } = const in
+  let k = logical_kind_of_goal_kind kind in
+  let l,r = match locality with
+    | Local when Lib.sections_are_opened () ->
+	let c = SectionLocalDef (pft, tpo, opacity) in
+	let _ = declare_variable id (Lib.cwd(), c, k) in
+	(Local, VarRef id)
+    | Local | Global ->
+        let kn = declare_constant id (DefinitionEntry const, k) in
+	Autoinstance.search_declaration (ConstRef kn);
+	(Global, ConstRef kn) in
+  Pfedit.delete_current_proof ();
+  definition_message id;
+  hook l r
+
+let save_hook = ref ignore
+let set_save_hook f = save_hook := f
+
+let save_named opacity =
+  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
+  let const = { const with const_entry_opaque = opacity } in
+  save id const do_guard persistence hook
+
+let default_thm_id = id_of_string "Unnamed_thm"
+
+let compute_proof_name locality = function
+  | Some (loc,id) ->
+      (* We check existence here: it's a bit late at Qed time *)
+      if Nametab.exists_cci (Lib.make_path id) || is_section_variable id ||
+	 locality=Global && Nametab.exists_cci (Lib.make_path_except_section id)
+      then
+        user_err_loc (loc,"",pr_id id ++ str " already exists.");
+      id
+  | None ->
+      next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) 
+
+let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) =
+  match body with
+  | None ->
+      (match local with
+      | Local ->
+          let impl=false in (* copy values from Vernacentries *)
+          let k = IsAssumption Conjectural in
+          let c = SectionLocalAssum (t_i,impl) in
+	  let _ = declare_variable id (Lib.cwd(),c,k) in
+          (Local,VarRef id,imps)
+      | Global ->
+          let k = IsAssumption Conjectural in
+          let kn = declare_constant id (ParameterEntry (t_i,false), k) in
+          (Global,ConstRef kn,imps))
+  | Some body ->
+      let k = logical_kind_of_goal_kind kind in
+      let body_i = match kind_of_term body with
+        | Fix ((nv,0),decls) -> mkFix ((nv,i),decls)
+        | CoFix (0,decls) -> mkCoFix (i,decls)
+        | _ -> anomaly "Not a proof by induction" in
+      match local with
+      | Local ->
+	  let c = SectionLocalDef (body_i, Some t_i, opaq) in
+	  let _ = declare_variable id (Lib.cwd(), c, k) in
+          (Local,VarRef id,imps)
+      | Global ->
+          let const =
+            { const_entry_body = body_i;
+              const_entry_type = Some t_i;
+              const_entry_opaque = opaq;
+              const_entry_boxed = false (* copy of what cook_proof does *)} in
+          let kn = declare_constant id (DefinitionEntry const, k) in
+          (Global,ConstRef kn,imps)
+
+(* 4.2| General support for goals *)
+
+let check_anonymity id save_ident =
+  if atompart_of_id id <> "Unnamed_thm" then
+    error "This command can only be used for unnamed theorem."
+
+let save_anonymous opacity save_ident =
+  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
+  let const = { const with const_entry_opaque = opacity } in
+  check_anonymity id save_ident;
+  save save_ident const do_guard persistence hook
+
+let save_anonymous_with_strength kind opacity save_ident =
+  let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in
+  let const = { const with const_entry_opaque = opacity } in
+  check_anonymity id save_ident;
+  (* we consider that non opaque behaves as local for discharge *)
+  save save_ident const do_guard (Global, Proof kind) hook
+
+(* Starting a goal *)
+
+let start_hook = ref ignore
+let set_start_hook = (:=) start_hook
+
+let start_proof id kind c ?init_tac ?(compute_guard=[]) hook =
+  let sign = Global.named_context () in
+  let sign = clear_proofs sign in
+  !start_hook c;
+  Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook
+
+let rec_tac_initializer finite guard thms snl =
+  if finite then
+    match List.map (fun (id,(t,_)) -> (id,t)) thms with
+    | (id,_)::l -> Hiddentac.h_mutual_cofix true id l
+    | _ -> assert false
+  else
+    (* nl is dummy: it will be recomputed at Qed-time *)
+    let nl = match snl with 
+     | None -> List.map succ (List.map list_last guard)
+     | Some nl -> nl
+    in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with
+       | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l
+       | _ -> assert false
+
+let start_proof_with_initialization kind recguard thms snl hook =
+  let intro_tac (_, (_, (ids, _))) =
+    Refiner.tclMAP (function
+    | Name id -> Tactics.intro_mustbe_force id
+    | Anonymous -> Tactics.intro) (List.rev ids) in
+  let init_tac,guard = match recguard with
+  | Some (finite,guard,init_tac) ->
+      let rec_tac = rec_tac_initializer finite guard thms snl in
+      Some (match init_tac with
+        | None -> 
+            if Flags.is_auto_intros () then 
+              tclTHENS rec_tac (List.map intro_tac thms)
+            else
+              rec_tac
+        | Some tacl ->
+            tclTHENS rec_tac
+            (if Flags.is_auto_intros () then
+              List.map2 (fun tac thm -> tclTHEN tac (intro_tac thm)) tacl thms
+            else
+              tacl)),guard
+  | None ->
+      assert (List.length thms = 1);
+      (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in
+  match thms with
+  | [] -> anomaly "No proof to start"
+  | (id,(t,(_,imps)))::other_thms ->
+      let hook strength ref =
+        let other_thms_data =
+          if other_thms = [] then [] else
+            (* there are several theorems defined mutually *)
+            let body,opaq = retrieve_first_recthm ref in
+            list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in
+        let thms_data = (strength,ref,imps)::other_thms_data in
+        List.iter (fun (strength,ref,imps) ->
+	  maybe_declare_manual_implicits false ref imps;
+	  hook strength ref) thms_data in
+      start_proof id kind t ?init_tac hook ~compute_guard:guard
+
+let start_proof_com kind thms hook =
+  let evdref = ref (create_evar_defs Evd.empty) in
+  let env0 = Global.env () in
+  let thms = List.map (fun (sopt,(bl,t,guard)) ->
+    let (env, ctx), imps = interp_context_evars evdref env0 bl in
+    let t', imps' = interp_type_evars_impls ~evdref env t in
+    Sign.iter_rel_context (check_evars env Evd.empty !evdref) ctx;
+    let ids = List.map pi1 ctx in
+      (compute_proof_name (fst kind) sopt,
+      (nf_evar !evdref (it_mkProd_or_LetIn t' ctx),
+       (ids, imps @ lift_implicits (List.length ids) imps'),
+       guard)))
+    thms in
+  let recguard,thms,snl = look_for_possibly_mutual_statements thms in
+  start_proof_with_initialization kind recguard thms snl hook
+
+(* Admitted *)
+
+let admit () =
+  let (id,k,typ,hook) = Pfedit.current_proof_statement () in
+  let kn =
+    declare_constant id (ParameterEntry (typ,false),IsAssumption Conjectural) in
+  Pfedit.delete_current_proof ();
+  assumption_message id;
+  hook Global (ConstRef kn)
+
+(* Miscellaneous *)
+
+let get_current_context () =
+  try Pfedit.get_current_goal_context ()
+  with e when Logic.catchable_exception e ->
+    (Evd.empty, Global.env())
diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli
new file mode 100644
index 00000000..8af9b1e8
--- /dev/null
+++ b/toplevel/lemmas.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.fix_expr        *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*i*)
+open Names
+open Term
+open Decl_kinds
+open Topconstr
+open Tacexpr
+open Vernacexpr
+open Proof_type
+open Pfedit
+(*i*)
+
+(* A hook start_proof calls on the type of the definition being started *)
+val set_start_hook : (types -> unit) -> unit
+
+val start_proof : identifier -> goal_kind -> types ->
+  ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> 
+    declaration_hook -> unit
+
+val start_proof_com : goal_kind ->
+  (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list ->
+  declaration_hook -> unit
+
+val start_proof_with_initialization : 
+  goal_kind -> (bool * lemma_possible_guards * tactic list option) option ->
+  (identifier * (types * (name list * Impargs.manual_explicitation list))) list
+  -> int list option -> declaration_hook -> unit
+
+(* A hook the next three functions pass to cook_proof *)
+val set_save_hook : (Refiner.pftreestate -> unit) -> unit
+
+(*s [save_named b] saves the current completed proof under the name it
+was started; boolean [b] tells if the theorem is declared opaque; it
+fails if the proof is not completed *)
+
+val save_named : bool -> unit
+
+(* [save_anonymous b name] behaves as [save_named] but declares the theorem
+under the name [name] and respects the strength of the declaration *)
+
+val save_anonymous : bool -> identifier -> unit
+
+(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but
+   declares the theorem under the name [name] and gives it the
+   strength [strength] *)
+
+val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit
+
+(* [admit ()] aborts the current goal and save it as an assmumption *)
+
+val admit : unit -> unit
+
+(* [get_current_context ()] returns the evar context and env of the
+   current open proof if any, otherwise returns the empty evar context
+   and the current global env *)
+
+val get_current_context : unit -> Evd.evar_map * Environ.env
diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml
new file mode 100644
index 00000000..04064025
--- /dev/null
+++ b/toplevel/libtypes.ml
@@ -0,0 +1,111 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Term
+open Summary
+open Libobject
+open Libnames
+open Names
+(*
+ * Module construction
+ *)
+
+(* let reduce c = Reductionops.head_unfold_under_prod *)
+(*   (Auto.Hint_db.transparent_state (Auto.searchtable_map "typeclass_instances")) *)
+(*   (Global.env()) Evd.empty c *)
+
+let reduce c = c
+
+module TypeDnet = Term_dnet.Make
+  (struct
+     type t = Libnames.global_reference
+     let compare = RefOrdered.compare
+     let subst s gr = fst (Libnames.subst_global s gr)
+     let constr_of = Global.type_of_global
+   end)
+  (struct let reduce = reduce
+	  let direction = false
+   end)
+
+type result = Libnames.global_reference * (constr*existential_key) * Termops.subst
+
+let all_types = ref TypeDnet.empty
+let defined_types = ref TypeDnet.empty
+
+(*
+ * Bookeeping & States
+ *)
+
+let freeze () =
+  (!all_types,!defined_types)
+
+let unfreeze (lt,dt) =
+  all_types := lt;
+  defined_types := dt
+
+let init () =
+  all_types := TypeDnet.empty;
+  defined_types := TypeDnet.empty
+
+let _ =
+  declare_summary "type-library-state"
+    { freeze_function = freeze;
+      unfreeze_function = unfreeze;
+      init_function = init }
+
+let load (_,d) =
+(*  Profile.print_logical_stats !all_types;
+  Profile.print_logical_stats d;*)
+  all_types := TypeDnet.union d !all_types
+
+let subst s t = TypeDnet.subst s t
+(*
+let subst_key = Profile.declare_profile "subst"
+let subst a b = Profile.profile2 subst_key TypeDnet.subst a b
+
+let load_key = Profile.declare_profile "load"
+let load a = Profile.profile1 load_key load a
+*)
+let (input,output) =
+  declare_object
+    { (default_object "LIBTYPES") with
+	load_function = (fun _ -> load);
+	subst_function = (fun (s,t) -> subst s t);
+	classify_function = (fun x -> Substitute x)
+    }
+
+let update () = Lib.add_anonymous_leaf (input !defined_types)
+
+(*
+ * Search interface
+ *)
+
+let search_pattern pat = TypeDnet.search_pattern !all_types pat
+let search_concl pat = TypeDnet.search_concl !all_types pat
+let search_head_concl pat = TypeDnet.search_head_concl !all_types pat
+let search_eq_concl eq pat = TypeDnet.search_eq_concl !all_types eq pat
+
+let add typ gr =
+  defined_types := TypeDnet.add typ gr !defined_types;
+  all_types := TypeDnet.add typ gr !all_types
+(*
+let add_key = Profile.declare_profile "add"
+let add a b = Profile.profile1 add_key add a b
+*)
+
+(*
+ * Hooks declaration
+ *)
+
+let _ = Declare.add_cache_hook
+  ( fun sp ->
+      let gr = Nametab.global_of_path sp in
+      let ty = Global.type_of_global gr in
+      add ty gr )
+
+let _ = Declaremods.set_end_library_hook update
diff --git a/toplevel/libtypes.mli b/toplevel/libtypes.mli
new file mode 100644
index 00000000..d57ecb94
--- /dev/null
+++ b/toplevel/libtypes.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id:$ *)
+
+(*i*)
+open Term
+(*i*)
+
+(*
+ * Persistent library of all declared object,
+ * indexed by their types (uses Dnets)
+ *)
+
+(* results are the reference of the object, together with a context
+(constr+evar) and a substitution under this context *)
+type result = Libnames.global_reference * (constr*existential_key) * Termops.subst
+
+(* this is the reduction function used in the indexing process *)
+val reduce : types -> types
+
+(* The different types of search available.
+ * See term_dnet.mli for more explanations *)
+val search_pattern : types -> result list
+val search_concl : types -> result list
+val search_head_concl : types -> result list
+val search_eq_concl : constr -> types -> result list
diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml
deleted file mode 100644
index 77f5198a..00000000
--- a/toplevel/line_oriented_parser.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: line_oriented_parser.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-let line_oriented_channel_to_option stop_string input_channel =
-  let count = ref 0 in
-  let buff = ref "" in
-  let current_length = ref 0 in
-  fun i -> 
-    if (i - !count) >= !current_length then begin
-      count := !count + !current_length + 1;
-      buff := input_line input_channel;
-      if !buff = stop_string then
-        None
-      else begin
-        current_length := String.length !buff;
-        Some '\n'
-      end
-    end else
-      Some (String.get !buff (i - !count))
-
-let flush_until_end_of_stream char_stream =
-  Stream.iter (function _ -> ()) char_stream
diff --git a/toplevel/line_oriented_parser.mli b/toplevel/line_oriented_parser.mli
deleted file mode 100644
index f37472c0..00000000
--- a/toplevel/line_oriented_parser.mli
+++ /dev/null
@@ -1,13 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: line_oriented_parser.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-val line_oriented_channel_to_option: string -> in_channel -> int -> char option
-
-val flush_until_end_of_stream : 'a Stream.t -> unit
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index 821a73f7..5e497846 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -6,9 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: metasyntax.ml 12882 2010-03-23 22:34:38Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
+open Flags
 open Util
 open Names
 open Topconstr
@@ -24,34 +25,39 @@ open Libnames
 open Lexer
 open Egrammar
 open Notation
+open Nameops
 
 (**********************************************************************)
 (* Tokens                                                             *)
 
-let cache_token (_,s) = Compat.using Pcoq.lexer ("", s)
+let cache_token (_,s) = add_token ("", s)
 
 let (inToken, outToken) =
   declare_object {(default_object "TOKEN") with
        open_function = (fun i o -> if i=1 then cache_token o);
        cache_function = cache_token;
        subst_function = Libobject.ident_subst_function;
-       classify_function = (fun (_,o) -> Substitute o);
-       export_function = (fun x -> Some x)}
+       classify_function = (fun o -> Substitute o)}
 
 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
-  | VTerm s -> Some s
-  | VNonTerm _ -> None
-
-let rec make_tags lev = function
-  | VTerm s :: l -> make_tags lev l
-  | VNonTerm (loc, nt, po) :: l ->
-      let (etyp, _) = Egrammar.interp_entry_name lev nt in
-      etyp :: make_tags lev l
+  | 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 cache_tactic_notation (_,(pa,pp)) =
@@ -61,7 +67,7 @@ let cache_tactic_notation (_,(pa,pp)) =
 let subst_tactic_parule subst (key,n,p,(d,tac)) =
   (key,n,p,(d,Tacinterp.subst_tactic subst tac))
 
-let subst_tactic_notation (_,subst,(pa,pp)) =
+let subst_tactic_notation (subst,(pa,pp)) =
   (subst_tactic_parule subst pa,pp)
 
 let (inTacticGrammar, outTacticGrammar) =
@@ -69,15 +75,14 @@ let (inTacticGrammar, outTacticGrammar) =
        open_function = (fun i o -> if i=1 then cache_tactic_notation o);
        cache_function = cache_tactic_notation;
        subst_function = subst_tactic_notation;
-       classify_function = (fun (_,o) -> Substitute o);
-       export_function = (fun x -> Some x)}
+       classify_function = (fun o -> Substitute o)}
 
 let cons_production_parameter l = function
-  | VTerm _ -> l
-  | VNonTerm (_,_,ido) -> Option.List.cons ido l
+  | GramTerminal _ -> l
+  | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l
 
 let rec tactic_notation_key = function
-  | VTerm id :: _ -> id
+  | GramTerminal id :: _ -> id
   | _ :: l -> tactic_notation_key l
   | [] -> "terminal_free_notation"
 
@@ -86,7 +91,8 @@ let rec next_key_away key t =
   else key
 
 let add_tactic_notation (n,prods,e) =
-  let tags = make_tags n prods in
+  let prods = List.map (interp_prod_item n) prods in
+  let tags = make_tags prods in
   let key = next_key_away (tactic_notation_key prods) tags in
   let pprule = (key,tags,(n,List.map make_terminal_status prods)) in
   let ids = List.fold_left cons_production_parameter [] prods in
@@ -109,14 +115,14 @@ let print_grammar = function
       Gram.Entry.print Pcoq.Constr.operconstr;
   | "pattern" ->
       Gram.Entry.print Pcoq.Constr.pattern
-  | "tactic" -> 
+  | "tactic" ->
       msgnl (str "Entry tactic_expr is");
       Gram.Entry.print Pcoq.Tactic.tactic_expr;
       msgnl (str "Entry binder_tactic is");
       Gram.Entry.print Pcoq.Tactic.binder_tactic;
       msgnl (str "Entry simple_tactic is");
       Gram.Entry.print Pcoq.Tactic.simple_tactic;
-  | "vernac" -> 
+  | "vernac" ->
       msgnl (str "Entry vernac is");
       Gram.Entry.print Pcoq.Vernac_.vernac;
       msgnl (str "Entry command is");
@@ -168,7 +174,7 @@ let parse_format (loc,str) =
       (* Parse " // " *)
       | '/' when i <= String.length str & str.[i+1] = '/' ->
           (* We forget the useless n spaces... *)
-	  push_token (UnpCut PpFnl) 
+	  push_token (UnpCut PpFnl)
             (parse_token (close_quotation (i+2)))
       (* Parse " .. / .. " *)
       | '/' when i <= String.length str ->
@@ -234,16 +240,14 @@ let parse_format (loc,str) =
 
 type symbol_token = WhiteSpace of int | String of string
 
-(* Decompose the notation string into tokens *)
-
 let split_notation_string str =
   let push_token beg i l =
     if beg = i then l else
       let s = String.sub str beg (i - beg) in
-      String s :: l 
+      String s :: l
   in
   let push_whitespace beg i l =
-    if beg = i then l else WhiteSpace (i-beg) :: l 
+    if beg = i then l else WhiteSpace (i-beg) :: l
   in
   let rec loop beg i =
     if i < String.length str then
@@ -271,7 +275,7 @@ let out_nt = function NonTerminal x -> x | _ -> assert false
 let rec find_pattern nt xl = function
   | Break n as x :: l, Break n' :: l' when n=n' ->
       find_pattern nt (x::xl) (l,l')
-  | Terminal s as x :: l, Terminal s' :: l' when s = s' -> 
+  | Terminal s as x :: l, Terminal s' :: l' when s = s' ->
       find_pattern nt (x::xl) (l,l')
   | [], NonTerminal x' :: l' ->
       (out_nt nt,x',List.rev xl),l'
@@ -279,8 +283,10 @@ let rec find_pattern nt xl = function
       error ("The token "^s^" occurs on one side of \"..\" but not on the other side.")
   | [], Break s :: _ | Break s :: _, _ ->
       error ("A break occurs on one side of \"..\" but not on the other side.")
-  | ((SProdList _ | NonTerminal _) :: _ | []), _ -> 
+  | _, [] ->
       error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".")
+  | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) ->
+      anomaly "Only Terminal or Break expected on left, non-SProdList on right"
 
 let rec interp_list_parser hd = function
   | [] -> [], [], List.rev hd
@@ -292,7 +298,7 @@ let rec interp_list_parser hd = function
       (* remove the second copy of it afterwards *)
       (y,x)::yl, x::xl, SProdList (x,sl) :: tl''
   | (Terminal _ | Break _) as s :: tl ->
-      if hd = [] then 
+      if hd = [] then
         let yl,xl,tl' = interp_list_parser [] tl in
         yl, xl, s :: tl'
       else
@@ -305,10 +311,6 @@ let rec interp_list_parser hd = function
 
 (* Find non-terminal tokens of notation *)
 
-let unquote_notation_token s =
-  let n = String.length s in
-  if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
-
 let is_normal_token str =
   try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false
 
@@ -319,36 +321,43 @@ let quote_notation_token x =
   if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'"
   else x
 
-let rec raw_analyse_notation_tokens = function
-  | []    -> [], []
-  | String ".." :: sl ->
-      let (vars,l) = raw_analyse_notation_tokens sl in
-      (list_add_set ldots_var vars, NonTerminal ldots_var :: l)
+let rec raw_analyze_notation_tokens = function
+  | []    -> []
+  | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl
   | String "_" :: _ -> error "_ must be quoted."
   | String x :: sl when is_normal_token x ->
       Lexer.check_ident x;
-      let id = Names.id_of_string x in
-      let (vars,l) = raw_analyse_notation_tokens sl in
-      if List.mem id vars then
-	error ("Variable "^x^" occurs more than once.");
-      (id::vars, NonTerminal id :: l)
+      NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl
   | String s :: sl ->
       Lexer.check_keyword s;
-      let (vars,l) = raw_analyse_notation_tokens sl in
-      (vars, Terminal (unquote_notation_token s) :: l)
+      Terminal (drop_simple_quotes s) :: raw_analyze_notation_tokens sl
   | WhiteSpace n :: sl ->
-      let (vars,l) = raw_analyse_notation_tokens sl in
-      (vars, Break n :: l)
+      Break n :: raw_analyze_notation_tokens sl
 
-let is_numeral symbs = 
+let is_numeral symbs =
   match List.filter (function Break _ -> false | _ -> true) symbs with
   | ([Terminal "-"; Terminal x] | [Terminal x]) ->
       (try let _ = Bigint.of_string x in true with _ -> false)
   | _ ->
       false
 
-let analyse_notation_tokens l =
-  let vars,l = raw_analyse_notation_tokens l in
+let rec get_notation_vars = function
+  | [] -> []
+  | NonTerminal id :: sl ->
+      let vars = get_notation_vars sl in
+      if List.mem id vars then
+        if id <> ldots_var then
+	  error ("Variable "^string_of_id id^" occurs more than once.")
+        else
+          vars
+      else
+        id::vars
+  | (Terminal _ | Break _) :: sl -> get_notation_vars sl
+  | SProdList _ :: _ -> assert false
+
+let analyze_notation_tokens l =
+  let l = raw_analyze_notation_tokens l in
+  let vars = get_notation_vars l in
   let extrarecvars,recvars,l = interp_list_parser [] l in
   (if extrarecvars = [] then [], [], vars, l
    else extrarecvars, recvars, list_subtract vars recvars, l)
@@ -360,10 +369,10 @@ let remove_extravars extrarecvars (vars,recvars) =
 	error
 	 "Two end variables of a recursive notation are not in the same scope."
       else
-	List.remove_assoc x l) 
+	List.remove_assoc x l)
       extrarecvars (List.remove_assoc ldots_var vars) in
   (vars,recvars)
- 
+
 (**********************************************************************)
 (* Build pretty-printing rules                                        *)
 
@@ -381,7 +390,6 @@ let precedence_of_entry_type from = function
       n, let (lp,rp) = prec_assoc a in if b=Left then lp else rp
   | ETConstr (NumLevel n,InternalProd) -> n, Prec n
   | ETConstr (NextLevel,_) -> from, L
-  | ETOther ("constr","annot") -> 10, Prec 10
   | _ -> 0, E (* ?? *)
 
 (* Some breaking examples *)
@@ -455,7 +463,7 @@ let make_hunks etyps symbols from =
 	else if is_operator s then
 	  if ws = CanBreak then
 	    UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods)
-	  else 
+	  else
 	    UnpTerminal s :: add_break 1 (make NoBreak prods)
 	else if is_ident_tail s.[String.length s - 1] then
 	  let sep = if is_prod_ident (List.hd prods) then "" else " " in
@@ -500,14 +508,14 @@ let error_format () = error "The format does not match the notation."
 
 let rec split_format_at_ldots hd = function
   | UnpTerminal s :: fmt when s = string_of_id ldots_var -> List.rev hd, fmt
-  | u :: fmt -> 
+  | u :: fmt ->
       check_no_ldots_in_box u;
       split_format_at_ldots (u::hd) fmt
   | [] -> raise Exit
 
 and check_no_ldots_in_box = function
   | UnpBox (_,fmt) ->
-      (try 
+      (try
         let _ = split_format_at_ldots [] fmt in
         error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")
       with Exit -> ())
@@ -531,19 +539,19 @@ let read_recursive_format sl fmt =
   let slfmt, fmt = get_head fmt in
   slfmt, get_tail (slfmt, fmt)
 
-let hunks_of_format (from,(vars,typs)) symfmt = 
+let hunks_of_format (from,(vars,typs)) symfmt =
   let rec aux = function
   | symbs, (UnpTerminal s' as u) :: fmt
       when s' = String.make (String.length s') ' ' ->
       let symbs, l = aux (symbs,fmt) in symbs, u :: l
   | Terminal s :: symbs, (UnpTerminal s') :: fmt
-      when s = unquote_notation_token s' ->
+      when s = drop_simple_quotes s' ->
       let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
   | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' ->
       let i = list_index s vars in
       let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
       let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
-  | symbs, UnpBox (a,b) :: fmt -> 
+  | symbs, UnpBox (a,b) :: fmt ->
       let symbs', b' = aux (symbs,b) in
       let symbs', l = aux (symbs',fmt) in
       symbs', UnpBox (a,b') :: l
@@ -575,45 +583,62 @@ let is_not_small_constr = function
   | _ -> false
 
 let rec define_keywords_aux = function
-    NonTerm(_,Some(_,e)) as n1 :: Term("IDENT",k) :: l
+  | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal("IDENT",k) :: l
       when is_not_small_constr e ->
       message ("Defining '"^k^"' as keyword");
       Lexer.add_token("",k);
-      n1 :: Term("",k) :: define_keywords_aux l
+      n1 :: GramConstrTerminal("",k) :: define_keywords_aux l
   | n :: l -> n :: define_keywords_aux l
   | [] -> []
 
+  (* Ensure that IDENT articulation terminal symbols are keywords *)
 let define_keywords = function
-    Term("IDENT",k)::l ->
+  | GramConstrTerminal("IDENT",k)::l ->
       message ("Defining '"^k^"' as keyword");
       Lexer.add_token("",k);
-      Term("",k) :: define_keywords_aux l
+      GramConstrTerminal("",k) :: define_keywords_aux l
   | l -> define_keywords_aux l
 
+let distribute a ll = List.map (fun l -> a @ l) ll
+
+  (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep)
+     as many times as expected in [n] argument *)
+let rec expand_list_rule typ tkl x n i hds ll =
+  if i = n then
+    let hds =
+      GramConstrListMark (n,true) :: hds
+      @	[GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in
+    distribute hds ll
+  else
+    let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in
+    let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in
+    let tks = List.map (fun x -> GramConstrTerminal x) tkl in
+    distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @
+      expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll
+
 let make_production etyps symbols =
   let prod =
     List.fold_right
-      (fun t l -> match t with
+      (fun t ll -> match t with
         | NonTerminal m ->
 	    let typ = List.assoc m etyps in
-	    NonTerm (typ, Some (m,typ)) :: l
+	    distribute [GramConstrNonTerminal (typ, Some m)] ll
         | Terminal s ->
-	    Term (terminal s) :: l
+	    distribute [GramConstrTerminal (terminal s)] ll
         | Break _ ->
-            l
+            ll
         | SProdList (x,sl) ->
-            let sl = List.flatten
-              (List.map (function Terminal s -> [terminal s] 
+            let tkl = List.flatten
+              (List.map (function Terminal s -> [terminal s]
                 | Break _ -> []
                 | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in
-	    let y = match List.assoc x etyps with
+	    let typ = match List.assoc x etyps with
               | ETConstr x -> x
               | _ ->
                   error "Component of recursive patterns in notation must be constr." in
-            let typ = ETConstrList (y,sl) in
-            NonTerm (typ, Some (x,typ)) :: l)
-      symbols [] in
-  define_keywords prod
+	    expand_list_rule typ tkl x 1 0 [] ll)
+      symbols [[]] in
+  List.map define_keywords prod
 
 let rec find_symbols c_current c_next c_last = function
   | [] -> []
@@ -622,7 +647,7 @@ let rec find_symbols c_current c_next c_last = function
       (id, prec) :: (find_symbols c_next c_next c_last sl)
   | Terminal s :: sl -> find_symbols c_next c_next c_last sl
   | Break n :: sl -> find_symbols c_current c_next c_last sl
-  | SProdList (x,_) :: sl' -> 
+  | SProdList (x,_) :: sl' ->
       (x,c_next)::(find_symbols c_next c_next c_last sl')
 
 let border = function
@@ -648,17 +673,17 @@ let pr_arg_level from = function
 
 let pr_level ntn (from,args) =
   str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
-  prlist_with_sep pr_coma (pr_arg_level from) args
+  prlist_with_sep pr_comma (pr_arg_level from) args
 
 let error_incompatible_level ntn oldprec prec =
   errorlabstrm ""
-    (str ("Notation "^ntn^" is already defined") ++ spc() ++ 
-    pr_level ntn oldprec ++ 
-    spc() ++ str "while it is now required to be" ++ spc() ++ 
+    (str ("Notation "^ntn^" is already defined") ++ spc() ++
+    pr_level ntn oldprec ++
+    spc() ++ str "while it is now required to be" ++ spc() ++
     pr_level ntn prec ++ str ".")
 
 let cache_one_syntax_extension (prec,ntn,gr,pp) =
-  try 
+  try
     let oldprec = Notation.level_of_notation ntn in
     if prec <> oldprec then error_incompatible_level ntn oldprec prec
   with Not_found ->
@@ -676,23 +701,19 @@ let subst_parsing_rule subst x = x
 
 let subst_printing_rule subst x = x
 
-let subst_syntax_extension (_,subst,(local,sy)) =
+let subst_syntax_extension (subst,(local,sy)) =
   (local, List.map (fun (prec,ntn,gr,pp) ->
      (prec,ntn, subst_parsing_rule subst gr, subst_printing_rule subst pp)) sy)
 
-let classify_syntax_definition (_,(local,_ as o)) =
+let classify_syntax_definition (local,_ as o) =
   if local then Dispose else Substitute o
 
-let export_syntax_definition (local,_ as o) =
-  if local then None else Some o
-
 let (inSyntaxExtension, outSyntaxExtension) =
   declare_object {(default_object "SYNTAX-EXTENSION") with
        open_function = (fun i o -> if i=1 then cache_syntax_extension o);
        cache_function = cache_syntax_extension;
        subst_function = subst_syntax_extension;
-       classify_function = classify_syntax_definition;
-       export_function = export_syntax_definition}
+       classify_function = classify_syntax_definition}
 
 (**************************************************************************)
 (* Precedences                                                            *)
@@ -734,25 +755,25 @@ let interp_modifiers modl =
 let check_infix_modifiers modifiers =
   let (assoc,level,t,b,fmt) = interp_modifiers modifiers in
   if t <> [] then
-    error "explicit entry level or type unexpected in infix notation."
+    error "Explicit entry level or type unexpected in infix notation."
 
-let no_syntax_modifiers modifiers = 
+let no_syntax_modifiers modifiers =
   modifiers = [] or modifiers = [SetOnlyParsing]
 
 (* Compute precedences from modifiers (or find default ones) *)
 
 let set_entry_type etyps (x,typ) =
-  let typ = try 
+  let typ = try
     match List.assoc x etyps, typ with
       | ETConstr (n,()), (_,BorderProd (left,_)) ->
           ETConstr (n,BorderProd (left,None))
       | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd)
-      | (ETPattern | ETIdent | ETBigint | ETOther _ | ETReference as t), _ -> t
+      | (ETPattern | ETName | ETBigint | ETOther _ | ETReference as t), _ -> t
       | (ETConstrList _, _) -> assert false
     with Not_found -> ETConstr typ
   in (x,typ)
 
-let check_rule_productivity l = 
+let check_rule_productivity l =
   if List.for_all (function NonTerminal _ -> true | _ -> false) l then
     error "A notation must include at least one symbol.";
   if (match l with SProdList _ :: _ -> true | _ -> false) then
@@ -768,9 +789,9 @@ let find_precedence lev etyps symbols =
       (try match List.assoc x etyps with
 	| ETConstr _ ->
 	    error "The level of the leftmost non-terminal cannot be changed."
-	| ETIdent | ETBigint | ETReference -> 
-	    if lev = None then 
-	      Flags.if_verbose msgnl (str "Setting notation at level 0.")
+	| ETName | ETBigint | ETReference ->
+	    if lev = None then
+	      if_verbose msgnl (str "Setting notation at level 0.")
 	    else
 	    if lev <> Some 0 then
 	      error "A notation starting with an atomic expression must be at level 0.";
@@ -780,15 +801,15 @@ let find_precedence lev etyps symbols =
 	      error "Need an explicit level."
 	    else Option.get lev
         | ETConstrList _ -> assert false (* internally used in grammar only *)
-      with Not_found -> 
+      with Not_found ->
 	if lev = None 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)
-      -> 
+      ->
       if lev = None then
-	(Flags.if_verbose msgnl (str "Setting notation at level 0."); 0)
+	(if_verbose msgnl (str "Setting notation at level 0."); 0)
       else Option.get lev
   | _ ->
       if lev = None then error "Cannot determine the level.";
@@ -796,18 +817,18 @@ let find_precedence lev etyps symbols =
 
 let check_curly_brackets_notation_exists () =
   try let _ = Notation.level_of_notation "{ _ }" in ()
-  with Not_found -> 
+  with Not_found ->
     error "Notations involving patterns of the form \"{ _ }\" are treated \n\
 specially and require that the notation \"{ _ }\" is already reserved."
 
 (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
-let remove_curly_brackets l = 
+let remove_curly_brackets l =
   let rec next = function
     | Break _ :: l -> next l
     | l -> l in
   let rec aux deb = function
   | [] -> []
-  | Terminal "{" as t1 :: l -> 
+  | Terminal "{" as t1 :: l ->
       (match next l with
         | NonTerminal _ as x :: l' as l0 ->
             (match next l' with
@@ -828,7 +849,7 @@ let compute_syntax_data (df,modifiers) =
   (* Notation defaults to NONA *)
   let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
   let toks = split_notation_string df in
-  let (extrarecvars,recvars,vars,symbols) = analyse_notation_tokens toks in
+  let (extrarecvars,recvars,vars,symbols) = analyze_notation_tokens toks in
   let ntn_for_interp = make_notation_key symbols in
   let symbols' = remove_curly_brackets symbols in
   let need_squash = (symbols <> symbols') in
@@ -846,7 +867,7 @@ let compute_syntax_data (df,modifiers) =
   let typs = List.map (set_entry_type etyps) typs in
   let prec = (n,List.map (assoc_of_type n) typs) in
   let sy_data = (ntn_for_grammar,prec,need_squash,(n,typs,symbols',fmt)) in
-  let df' = (Lib.library_dp(),df) in
+  let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
   let i_data = (onlyparse,extrarecvars,recvars,vars,(ntn_for_interp,df')) in
   (i_data,sy_data)
 
@@ -869,23 +890,19 @@ let cache_notation o =
   load_notation 1 o;
   open_notation 1 o
 
-let subst_notation (_,subst,(lc,scope,pat,b,ndf)) =
+let subst_notation (subst,(lc,scope,pat,b,ndf)) =
   (lc,scope,subst_interpretation subst pat,b,ndf)
 
-let classify_notation (_,(local,_,_,_,_ as o)) =
+let classify_notation (local,_,_,_,_ as o) =
   if local then Dispose else Substitute o
 
-let export_notation (local,_,_,_,_ as o) =
-  if local then None else Some o
-
 let (inNotation, outNotation) =
   declare_object {(default_object "NOTATION") with
        open_function = open_notation;
        cache_function = cache_notation;
        subst_function = subst_notation;
        load_function = load_notation;
-       classify_function = classify_notation;
-       export_function = export_notation}
+       classify_function = classify_notation}
 
 (**********************************************************************)
 (* Recovering existing syntax                                         *)
@@ -896,17 +913,17 @@ let contract_notation ntn =
     if i <= String.length ntn - 5 then
       let ntn' =
         if String.sub ntn i 5 = "{ _ }" then
-          String.sub ntn 0 i ^ "_" ^ 
+          String.sub ntn 0 i ^ "_" ^
           String.sub ntn (i+5) (String.length ntn -i-5)
         else ntn in
-      aux ntn' (i+1) 
+      aux ntn' (i+1)
     else ntn in
   aux ntn 0
 
 exception NoSyntaxRule
 
 let recover_syntax ntn =
-  try 
+  try
     let prec = Notation.level_of_notation ntn in
     let pprule,_ = Notation.find_notation_printing_rule ntn in
     let gr = Egrammar.recover_notation_grammar ntn prec in
@@ -924,7 +941,7 @@ let recover_notation_syntax rawntn =
 
 (**********************************************************************)
 (* Main entry point for building parsing and printing rules           *)
- 
+
 let make_pa_rule (n,typs,symbols,_) ntn =
   let assoc = recompute_assoc typs in
   let prod = make_production typs symbols in
@@ -954,78 +971,77 @@ let add_notation_in_scope local df c mods scope =
   Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules));
   (* Declare interpretation *)
   let (onlyparse,extrarecvars,recvars,vars,df') = i_data in
-  let (acvars,ac) = interp_aconstr [] (vars,recvars) c in
+  let (acvars,ac) = interp_aconstr (vars,recvars) c in
   let a = (remove_extravars extrarecvars acvars,ac) in
   let onlyparse = onlyparse or is_not_printable ac in
-  Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'))
+  Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'));
+  df'
 
-let add_notation_interpretation_core local df names c scope onlyparse =
+let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse =
   let dfs = split_notation_string df in
-  let (extrarecvars,recvars,vars,symbs) = analyse_notation_tokens dfs in
+  let (extrarecvars,recvars,vars,symbs) = analyze_notation_tokens dfs in
   (* Redeclare pa/pp rules *)
   if not (is_numeral symbs) then begin
     let sy_rules = recover_notation_syntax (make_notation_key symbs) in
     Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules))
   end;
   (* Declare interpretation *)
-  let df' = (make_notation_key symbs,(Lib.library_dp(),df)) in
-  let (acvars,ac) = interp_aconstr names (vars,recvars) c in
+  let path = (Lib.library_dp(),Lib.current_dirpath true) in
+  let df' = (make_notation_key symbs,(path,df)) in
+  let (acvars,ac) = interp_aconstr ~impls (vars,recvars) c in
   let a = (remove_extravars extrarecvars acvars,ac) in
   let onlyparse = onlyparse or is_not_printable ac in
-  Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'))
+  Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'));
+  df'
 
 (* Notations without interpretation (Reserved Notation) *)
 
-let add_syntax_extension local mv =
-  let (_,sy_data) = compute_syntax_data mv in
+let add_syntax_extension local ((loc,df),mods) =
+  let (_,sy_data) = compute_syntax_data (df,mods) in
   let sy_rules = make_syntax_rules sy_data in
   Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
 
 (* Notations with only interpretation *)
 
-let add_notation_interpretation df names c sc =
-  try add_notation_interpretation_core false df names c sc false
+let add_notation_interpretation ((loc,df),c,sc) =
+  let df' = add_notation_interpretation_core false df c sc false 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);
   with NoSyntaxRule ->
-    error "Parsing rule for this notation has to be previously declared."
+    error "Parsing rule for this notation has to be previously declared.");
+  Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc
 
 (* Main entry point *)
 
-let add_notation local c (df,modifiers) sc =
-  if no_syntax_modifiers modifiers then
+let add_notation local c ((loc,df),modifiers) sc =
+  let df' =
+   if no_syntax_modifiers modifiers then
     (* No syntax data: try to rely on a previously declared rule *)
     let onlyparse = modifiers=[SetOnlyParsing] in
-    try add_notation_interpretation_core local df [] c sc onlyparse
+    try add_notation_interpretation_core local df c sc onlyparse
     with NoSyntaxRule ->
       (* Try to determine a default syntax rule *)
       add_notation_in_scope local df c modifiers sc
-  else
+   else
     (* Declare both syntax and interpretation *)
     add_notation_in_scope local df c modifiers sc
+  in
+  Dumpglob.dump_notation (loc,df') sc true
 
 (* Infix notations *)
 
 let inject_var x = CRef (Ident (dummy_loc, id_of_string x))
 
-let add_infix local (inf,modifiers) pr sc =
+let add_infix local ((loc,inf),modifiers) pr sc =
   check_infix_modifiers modifiers;
   (* check the precedence *)
   let metas = [inject_var "x"; inject_var "y"] in
-  let c = mkAppC (mkRefC pr,metas) in
+  let c = mkAppC (pr,metas) in
   let df = "x "^(quote_notation_token inf)^" y" in
-  add_notation local c (df,modifiers) sc
-
-(**********************************************************************)
-(* Miscellaneous                                                      *)
-
-let standardize_locatable_notation ntn =
-  let unquote = function
-    | String s -> [unquote_notation_token s]
-    | _ -> [] in
-  if String.contains ntn ' ' then
-    String.concat " " 
-      (List.flatten (List.map unquote (split_notation_string ntn)))
-  else
-    unquote_notation_token ntn
+  add_notation local c ((loc,df),modifiers) sc
 
 (**********************************************************************)
 (* Delimiters and classes bound to scopes                             *)
@@ -1045,23 +1061,37 @@ let cache_scope_command o =
   load_scope_command 1 o;
   open_scope_command 1 o
 
-let subst_scope_command (_,subst,(scope,o as x)) = match o with
-  | ScopeClasses cl -> 
+let subst_scope_command (subst,(scope,o as x)) = match o with
+  | ScopeClasses cl ->
       let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else
       scope, ScopeClasses cl'
   | _ -> x
 
-let (inScopeCommand,outScopeCommand) = 
+let (inScopeCommand,outScopeCommand) =
   declare_object {(default_object "DELIMITERS") with
       cache_function = cache_scope_command;
       open_function = open_scope_command;
       load_function = load_scope_command;
       subst_function = subst_scope_command;
-      classify_function = (fun (_,obj) -> Substitute obj);
-      export_function = (fun x -> Some x) }
+      classify_function = (fun obj -> Substitute obj)}
 
 let add_delimiters scope key =
   Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key))
 
-let add_class_scope scope cl = 
+let add_class_scope scope cl =
   Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl))
+
+(* Check if abbreviation to a name and avoid early insertion of
+   maximal implicit arguments *)
+let try_interp_name_alias = function
+  | [], CRef ref -> intern_reference ref
+  | _ -> raise Not_found
+
+let add_syntactic_definition ident (vars,c) local onlyparse =
+  let vars,pat =
+    try [], ARef (try_interp_name_alias (vars,c))
+    with Not_found -> let (vars,_),pat = interp_aconstr (vars,[]) c in vars,pat
+  in
+  let onlyparse = onlyparse or is_not_printable pat in
+  Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
+
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index fefc0b27..a0680693 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -6,10 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: metasyntax.mli 11481 2008-10-20 19:23:51Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Util
+open Names
 open Libnames
 open Ppextend
 open Extend
@@ -23,16 +24,16 @@ val add_token_obj : string -> unit
 
 (* Adding a tactic notation in the environment *)
 
-val add_tactic_notation : 
-  int * grammar_production list * raw_tactic_expr -> unit
+val add_tactic_notation :
+  int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit
 
 (* Adding a (constr) notation in the environment*)
 
-val add_infix : locality_flag -> (string * syntax_modifier list) ->
-  reference -> scope_name option -> unit
+val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
+  constr_expr -> scope_name option -> unit
 
 val add_notation : locality_flag -> constr_expr ->
-  (string * syntax_modifier list) -> scope_name option -> unit
+  (lstring * syntax_modifier list) -> scope_name option -> unit
 
 (* Declaring delimiter keys and default scopes *)
 
@@ -41,22 +42,26 @@ val add_class_scope : scope_name -> Classops.cl_typ -> unit
 
 (* Add only the interpretation of a notation that already has pa/pp rules *)
 
-val add_notation_interpretation : string -> Constrintern.implicits_env ->
-  constr_expr -> scope_name option -> unit
+val add_notation_interpretation :
+  (lstring * constr_expr * scope_name option) -> unit
 
-(* Add only the parsing/printing rule of a notation *)
+(* Add a notation interpretation for supporting the "where" clause *)
 
-val add_syntax_extension : 
-  locality_flag -> (string * syntax_modifier list) -> unit
+val set_notation_for_interpretation : Constrintern.full_internalization_env ->
+  (lstring * constr_expr * scope_name option) -> unit
 
-(* Print the Camlp4 state of a grammar *)
+(* Add only the parsing/printing rule of a notation *)
 
-val print_grammar : string -> unit
+val add_syntax_extension :
+  locality_flag -> (lstring * syntax_modifier list) -> unit
+
+(* Add a syntactic definition (as in "Notation f := ...") *)
 
-(* Removes quotes in a notation *)
+val add_syntactic_definition : identifier -> identifier list * constr_expr ->
+  bool -> bool -> unit
 
-val standardize_locatable_notation : string -> string
+(* Print the Camlp4 state of a grammar *)
 
-(* Evaluate whether a notation is not printable *)
+val print_grammar : string -> unit
 
-val is_not_printable : aconstr -> bool
+val check_infix_modifiers : syntax_modifier list -> unit
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
index b54700d3..ee437030 100644
--- a/toplevel/mltop.ml4
+++ b/toplevel/mltop.ml4
@@ -11,7 +11,7 @@
  * camlp4deps will not work for this file unless Makefile system enhanced.
  *)
 
-(* $Id: mltop.ml4 12341 2009-09-17 16:03:19Z glondu $ *)
+(* $Id$ *)
 
 open Util
 open Pp
@@ -25,12 +25,12 @@ open Vernacinterp
 (* Code to hook Coq into the ML toplevel -- depends on having the
    objective-caml compiler mostly visible. The functions implemented here are:
    \begin{itemize}
-   \item [dir_ml_load name]: Loads the ML module fname from the current ML 
-     path. 
+   \item [dir_ml_load name]: Loads the ML module fname from the current ML
+     path.
    \item [dir_ml_use]: Directive #use of Ocaml toplevel
    \item [add_ml_dir]: Directive #directory of Ocaml toplevel
    \end{itemize}
- 
+
    How to build an ML module interface with these functions.
    The idea is that the ML directory path is like the Coq directory
    path.  So we can maintain the two in parallel.
@@ -53,13 +53,13 @@ let keep_copy_mlpath path =
   coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy
 
 (* If there is a toplevel under Coq *)
-type toplevel = { 
+type toplevel = {
   load_obj : string -> unit;
   use_file : string -> unit;
   add_dir  : string -> unit;
   ml_loop  : unit -> unit }
 
-(* Determines the behaviour of Coq with respect to ML files (compiled 
+(* Determines the behaviour of Coq with respect to ML files (compiled
    or not) *)
 type kind_load =
   | WithTop of toplevel
@@ -93,7 +93,7 @@ let ocaml_toploop () =
     | _ -> ()
 
 (* Dynamic loading of .cmo/.cma *)
-let dir_ml_load s = 
+let dir_ml_load s =
   match !load with
     | WithTop t ->
       (try t.load_obj s
@@ -133,7 +133,7 @@ let add_ml_dir s =
     | _ -> ()
 
 (* For Rec Add ML Path *)
-let add_rec_ml_dir dir = 
+let add_rec_ml_dir dir =
   List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir)
 
 (* Adding files to Coq and ML loadpath *)
@@ -149,8 +149,8 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath =
 
 let convert_string d =
   try Names.id_of_string d
-  with _ -> 
-    if_verbose warning 
+  with _ ->
+    if_verbose warning
       ("Directory "^d^" cannot be used as a Coq identifier (skipped)");
     flush_all ();
     failwith "caught"
@@ -165,18 +165,18 @@ let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
     List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs;
     add_ml_dir dir;
     List.iter (Library.add_load_path false) dirs;
-    Library.add_load_path true (dir,Names.make_dirpath prefix)
+    Library.add_load_path true (dir,coq_dirpath)
   else
     msg_warning (str ("Cannot open " ^ dir))
 
-(* convertit un nom quelconque en nom de fichier ou de module *) 
+(* convertit un nom quelconque en nom de fichier ou de module *)
 let mod_of_name name =
   let base =
     if Filename.check_suffix name ".cmo" then
       Filename.chop_suffix name ".cmo"
-    else 
+    else
       name
-  in 
+  in
   String.capitalize base
 
 let get_ml_object_suffix name =
@@ -218,38 +218,34 @@ let file_of_name name =
         if is_in_path !coq_mlpath_copy name then name else
           fail (base ^ ".cm[oa]")
 
-(* TODO: supprimer ce hack, si possible *)
-(* Initialisation of ML modules that need the state (ex: tactics like
- * natural, omega ...)
- * Each module may add some inits (function of type unit -> unit).
- * These inits are executed right after the initial state loading if the
- * module is statically linked, or after the loading if it is required. *)
-
-let init_list = ref ([] : (unit -> unit) list)
-
-let add_init_with_state init_fun =
-  init_list := init_fun :: !init_list
-
-let init_with_state () =
-  List.iter (fun f -> f()) (List.rev !init_list); init_list := []
+(** Is the ML code of the standard library placed into loadable plugins
+    or statically compiled into coqtop ? For the moment this choice is
+    made according to the presence of native dynlink : even if bytecode
+    coqtop could always load plugins, we prefer to have uniformity between
+    bytecode and native versions. *)
 
+let stdlib_use_plugins = Coq_config.has_natdynlink
 
 (* [known_loaded_module] contains the names of the loaded ML modules
- * (linked or loaded with load_object). It is used not to load a 
+ * (linked or loaded with load_object). It is used not to load a
  * module twice. It is NOT the list of ML modules Coq knows. *)
 
-type ml_module_object = { mnames : string list }
+type ml_module_object = {
+  mlocal : Vernacexpr.locality_flag;
+  mnames : string list
+}
 
 let known_loaded_modules = ref Stringset.empty
 
 let add_known_module mname =
+  let mname = String.capitalize mname in
   known_loaded_modules := Stringset.add mname !known_loaded_modules
 
-let module_is_known mname = Stringset.mem mname !known_loaded_modules
+let module_is_known mname =
+  Stringset.mem (String.capitalize mname) !known_loaded_modules
 
 let load_object mname fname=
   dir_ml_load fname;
-  init_with_state();
   add_known_module mname
 
 (* Summary of declared ML Modules *)
@@ -271,19 +267,17 @@ let unfreeze_ml_modules x =
          if has_dynlink then
            let fname = file_of_name mname in
            load_object mname fname
-         else 
+         else
 	   errorlabstrm "Mltop.unfreeze_ml_modules"
              (str"Loading of ML object file forbidden in a native Coq.");
        add_loaded_module mname)
     x
 
-let _ = 
+let _ =
   Summary.declare_summary "ML-MODULES"
     { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules()));
       Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x);
-      Summary.init_function = (fun () -> init_ml_modules ());
-      Summary.survive_module = false;
-      Summary.survive_section = true }
+      Summary.init_function = (fun () -> init_ml_modules ()) }
 
 (* Same as restore_ml_modules, but verbosely *)
 
@@ -292,40 +286,42 @@ let cache_ml_module_object (_,{mnames=mnames}) =
     (fun name ->
        let mname = mod_of_name name in
        if not (module_is_known mname) then
-         let fname = file_of_name mname in
-         begin 
-	   try 
-	     if_verbose 
+	 if has_dynlink then
+           let fname = file_of_name mname in
+	   try
+	     if_verbose
 	       msg (str"[Loading ML file " ++ str fname ++ str" ...");
              load_object mname fname;
-             if_verbose msgnl (str" done]")
-           with e -> 
-	     if_verbose msgnl (str" failed]"); 
+             if_verbose msgnl (str" done]");
+             add_loaded_module mname
+           with e ->
+	     if_verbose msgnl (str" failed]");
 	     raise e
-	 end;
-         add_loaded_module mname)
+	 else
+	     (if_verbose msgnl (str" failed]");
+	      error ("Dynamic link not supported (module "^name^")")))
     mnames
 
-let export_ml_module_object x = Some x
-					 
+let classify_ml_module_object ({mlocal=mlocal} as o) =
+  if mlocal then Dispose else Substitute o
+
 let (inMLModule,outMLModule) =
   declare_object {(default_object "ML-MODULE") with
                     load_function = (fun _ -> cache_ml_module_object);
                     cache_function = cache_ml_module_object;
-                    export_function = export_ml_module_object;
-                    subst_function = (fun (_,_,o) -> o);
-                    classify_function = (fun (_,o) -> Substitute o) }
+                    subst_function = (fun (_,o) -> o);
+                    classify_function = classify_ml_module_object }
+
+let declare_ml_modules local l =
+  Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l})
 
-let declare_ml_modules l =
-  Lib.add_anonymous_leaf (inMLModule {mnames=l})
-    
 let print_ml_path () =
   let l = !coq_mlpath_copy in
   ppnl (str"ML Load Path:" ++ fnl () ++ str"  " ++
           hv 0 (prlist_with_sep pr_fnl pr_str l))
 
 	  (* Printing of loaded ML modules *)
-	  
+
 let print_ml_modules () =
   let l = get_loaded_modules () in
   pp (str"Loaded ML Modules: " ++ pr_vertical_list pr_str l)
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index 875fb423..4230f0ee 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mltop.mli 11528 2008-10-31 08:40:42Z glondu $ i*)
+(*i $Id$ i*)
 
-(* If there is a toplevel under Coq, it is described by the following 
+(* If there is a toplevel under Coq, it is described by the following
    record. *)
-type toplevel = { 
+type toplevel = {
   load_obj : string -> unit;
   use_file : string -> unit;
   add_dir  : string -> unit;
@@ -48,9 +48,6 @@ val add_rec_ml_dir : string -> unit
 val add_path : unix_path:string -> coq_root:Names.dir_path -> unit
 val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit
 
-val add_init_with_state : (unit -> unit) -> unit
-val init_with_state : unit -> unit
-
 (* List of modules linked to the toplevel *)
 val add_known_module : string -> unit
 val module_is_known : string -> bool
@@ -62,11 +59,15 @@ val add_loaded_module : string -> unit
 val init_ml_modules : unit -> unit
 val unfreeze_ml_modules : string list -> unit
 
-type ml_module_object = { mnames: string list }
+type ml_module_object = {
+  mlocal: Vernacexpr.locality_flag;
+  mnames: string list;
+}
 val inMLModule : ml_module_object -> Libobject.obj
 val outMLModule : Libobject.obj -> ml_module_object
 
-val declare_ml_modules : string list -> unit
+val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit
+
 val print_ml_path : unit -> unit
 
 val print_ml_modules : unit -> unit
diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml
deleted file mode 100644
index caf32305..00000000
--- a/toplevel/protectedtoplevel.ml
+++ /dev/null
@@ -1,176 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: protectedtoplevel.ml 11784 2009-01-14 11:36:32Z herbelin $ *)
-
-open Pp
-open Line_oriented_parser
-open Vernac
-open Vernacexpr
-
-(* The toplevel parsing loop we propose here is more robust to printing
-   errors.  The philosophy is that all commands should be individually wrapped
-   in predefined markers.  If there is a parsing error, everything down to
-   the closing marker will be discarded.  Also there is always an aknowledge
-   message associated to a wrapped command. *)
-
-
-(* It is also possible to have break signals sent by other programs.  However,
-   there are some operations that should not be interrupted, especially, those
-   operations that are outputing data.
-*)
-
-let break_happened = ref false
-
-(* Before outputing any data, output_results makes sure that no interrupt 
-   is going to disturb the process. *)
-let output_results_nl stream =
-    let _ = Sys.signal Sys.sigint
-       (Sys.Signal_handle(fun i -> break_happened := true;()))
-  in
-  msgnl stream
-
-let rearm_break () =
-  let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in 
-    ()
-
-let check_break () =
-  if !break_happened then begin
-    break_happened := false;
-    raise Sys.Break
-  end
-
-(* All commands are acknowledged. *)
-
-let global_request_id = ref 013
-
-let acknowledge_command_ref =
-   ref(fun request_id command_count opt_exn
-      -> (fnl () ++ str "acknowledge command number " ++
-           int request_id ++ fnl () ++ 
-         str "successfully executed " ++ int command_count ++ fnl () ++
-           str "error message" ++ fnl () ++
-         (match opt_exn with
-           Some e -> Cerrors.explain_exn e
-         | None -> (mt ())) ++ fnl () ++
-         str "E-n-d---M-e-s-s-a-g-e" ++ fnl ()))
-
-let set_acknowledge_command f =
-  acknowledge_command_ref := f
-
-let acknowledge_command request_id = !acknowledge_command_ref request_id
-
-(* The markers are chosen to be likely to be different from any existing text. *)
-
-let start_marker = ref "protected_loop_start_command"
-let end_marker = ref "protected_loop_end_command"
-let start_length = ref (String.length !start_marker)
-let start_marker_buffer = ref (String.make !start_length ' ')
-
-let set_start_marker s =
-  start_marker := s;
-  start_length := String.length s;
-  start_marker_buffer := String.make !start_length ' '
-    
-let set_end_marker s =
-  end_marker := s
-
-exception E_with_rank of int * exn
-
-let rec parse_one_command_group input_channel =
-  let count = ref 0 in
-  let this_line = input_line input_channel in
-  if (String.length this_line) >= !start_length then begin
-    String.blit this_line 0 !start_marker_buffer 0 !start_length;
-    if !start_marker_buffer = !start_marker then
-      let req_id_line = input_line input_channel in
-      	begin 
-	  (try
-            global_request_id := int_of_string req_id_line
-	  with
-            | e -> failwith ("could not parse the request identifier |"^
-                             req_id_line ^ "|")) ;
-	  let count_line = input_line input_channel in
-	    begin
-	      (try
-		count := int_of_string count_line
-	      with
-		| e -> failwith("could not parse the count|" ^ count_line
-				^ "|"));
-	      let stream_tail =
-	      	Stream.from
-		  (line_oriented_channel_to_option
-		     !end_marker input_channel) in
-	      	begin
-		  check_break();
-		  rearm_break();
-		  let rec execute_n_commands rank =
-		    if rank = !count then
-		      None
-		    else
-		      let first_cmd_status =
-                      	try 
-			  raw_do_vernac
-			    (Pcoq.Gram.parsable stream_tail);
-		      	None
-		      	with e -> Some(rank,e) in
-		      	match first_cmd_status with
-			    None ->
-			      execute_n_commands (rank + 1)
-			  | v -> v in
-		  let r = execute_n_commands 0 in
-		    (match r with
-			 None ->
-			   output_results_nl 
-			     (acknowledge_command
-			      	!global_request_id !count None)
-		       | Some(rank, e) ->
-			   (match e with 
-                    	     | DuringCommandInterp(a,e1)
-			     | Stdpp.Exc_located (a,DuringSyntaxChecking e1) ->
-				  output_results_nl
-				    (acknowledge_command
-				       !global_request_id rank (Some e1))
-			      | e -> 
-				  output_results_nl
-				    (acknowledge_command
-				       !global_request_id rank (Some e))));
-		    rearm_break();
-		    flush_until_end_of_stream stream_tail
-	      	end
-	    end
-	end
-    else
-      parse_one_command_group input_channel
-  end else
-    parse_one_command_group input_channel
-
-let protected_loop input_chan =
-  let rec explain_and_restart e =
-    begin
-      output_results_nl(Cerrors.explain_exn e);
-      rearm_break();
-      looprec input_chan;
-    end
-  and looprec input_chan =
-    try 
-      while true do parse_one_command_group input_chan done
-    with
-      | Vernacexpr.Drop -> raise Vernacexpr.Drop
-      | Vernacexpr.Quit -> exit 0
-      | End_of_file -> exit 0
-      | DuringCommandInterp(loc, Vernacexpr.Quit) -> raise Vernacexpr.Quit
-      | DuringCommandInterp(loc, Vernacexpr.Drop) -> raise Vernacexpr.Drop
-      | DuringCommandInterp(loc, e)
-      | Stdpp.Exc_located (loc,DuringSyntaxChecking e) ->
-	  explain_and_restart e
-      | e -> explain_and_restart e in
-    begin
-      msgnl (str "Starting Centaur Specialized loop");
-      looprec input_chan
-    end
diff --git a/toplevel/protectedtoplevel.mli b/toplevel/protectedtoplevel.mli
deleted file mode 100644
index 1d4ba9fc..00000000
--- a/toplevel/protectedtoplevel.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: protectedtoplevel.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-(*i*)
-open Pp
-(*i*)
-
-(* A protected toplevel (used in Pcoq). *)
-
-val break_happened : bool ref
-val global_request_id : int ref
-val output_results_nl : std_ppcmds -> unit
-val rearm_break : unit -> unit
-val check_break : unit -> unit
-val set_acknowledge_command : (int -> int -> exn option -> std_ppcmds) -> unit
-val set_start_marker : string -> unit
-val set_end_marker : string -> unit
-val parse_one_command_group : in_channel -> unit
-val protected_loop : in_channel -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
index 4c0e34cd..320030e1 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: record.ml 12080 2009-04-11 16:56:20Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -31,30 +31,27 @@ open Topconstr
 
 (********** definition d'un record (structure) **************)
 
-let interp_evars evdref env ?(impls=([],[])) k typ =
-  let typ' = intern_gen true ~impls (Evd.evars_of !evdref) env typ in
+let interp_evars evdref env impls k typ =
+  let impls = set_internalization_env_params impls [] in
+  let typ' = intern_gen true ~impls !evdref env typ in
   let imps = Implicit_quantifiers.implicits_of_rawterm typ' in
     imps, Pretyping.Default.understand_tcc_evars evdref env k typ'
 
-let mk_interning_data env na impls typ =
-  let impl = Impargs.compute_implicits_with_manual env typ (Impargs.is_implicit_args()) impls
-  in (na, (Constrintern.Method, [], impl, Notation.compute_arguments_scope typ))
-    
-let interp_fields_evars isevars env nots l =
+let interp_fields_evars evars env nots l =
   List.fold_left2
     (fun (env, uimpls, params, impls) no ((loc, i), b, t) ->
-      let impl, t' = interp_evars isevars env ~impls Pretyping.IsType t in
-      let b' = Option.map (fun x -> snd (interp_evars isevars env ~impls (Pretyping.OfType (Some t')) x)) b in
-      let impls = 
+      let impl, t' = interp_evars evars env impls Pretyping.IsType t in
+      let b' = Option.map (fun x -> snd (interp_evars evars env impls (Pretyping.OfType (Some t')) x)) b in
+      let impls =
 	match i with
 	| Anonymous -> impls
-	| Name na -> (fst impls, mk_interning_data env na impl t' :: snd impls)
+	| Name id -> (id, compute_internalization_data env Constrintern.Method t' impl) :: impls
       in
       let d = (i,b',t') in
-	(* Temporary declaration of notations and scopes *)
-	Option.iter (declare_interning_data impls) no;
-	(push_rel d env, impl :: uimpls, d::params, impls))
-    (env, [], [], ([], [])) nots l
+      let impls' = set_internalization_env_params impls [] in
+      List.iter (Metasyntax.set_notation_for_interpretation impls') no;
+      (push_rel d env, impl :: uimpls, d::params, impls))
+    (env, [], [], []) nots l
 
 let binder_of_decl = function
   | Vernacexpr.AssumExpr(n,t) -> (n,None,t)
@@ -64,7 +61,7 @@ let binders_of_decls = List.map binder_of_decl
 
 let typecheck_params_and_fields id t ps nots fs =
   let env0 = Global.env () in
-  let evars = ref (Evd.create_evar_defs Evd.empty) in
+  let evars = ref Evd.empty in
   let (env1,newps), imps = interp_context_evars ~fail_anonymous:false evars env0 ps in
   let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in
   let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in
@@ -73,7 +70,7 @@ let typecheck_params_and_fields id t ps nots fs =
   in
   let evars,_ = Evarconv.consider_remaining_unif_problems env_ar !evars in
   let evars = Typeclasses.resolve_typeclasses env_ar evars in
-  let sigma = Evd.evars_of evars in
+  let sigma =  evars in
   let newps = Evarutil.nf_rel_context_evar sigma newps in
   let newfs = Evarutil.nf_rel_context_evar sigma newfs in
   let ce t = Evarutil.check_evars env0 Evd.empty evars t in
@@ -84,7 +81,7 @@ let typecheck_params_and_fields id t ps nots fs =
 let degenerate_decl (na,b,t) =
   let id = match na with
     | Name id -> id
-    | Anonymous -> anomaly "Unnamed record variable" in 
+    | Anonymous -> anomaly "Unnamed record variable" in
   match b with
     | None -> (id, Entries.LocalAssum t)
     | Some b -> (id, Entries.LocalDef b)
@@ -99,21 +96,21 @@ let warning_or_error coe indsp err =
 	let s,have = if List.length projs > 1 then "s","were" else "","was" in
         (str(string_of_id fi) ++
 	   strbrk" cannot be defined because the projection" ++ str s ++ spc () ++
-           prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ 
+           prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++
 	   strbrk " not defined.")
     | BadTypedProj (fi,ctx,te) ->
 	match te with
 	  | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) ->
-              (pr_id fi ++ 
+              (pr_id fi ++
 		strbrk" cannot be defined because it is informative and " ++
 		Printer.pr_inductive (Global.env()) indsp ++
-		strbrk " is not.")   
+		strbrk " is not.")
 	  | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) ->
-	      (pr_id fi ++ 
+	      (pr_id fi ++
 		strbrk" cannot be defined because it is large and " ++
 		Printer.pr_inductive (Global.env()) indsp ++
 		strbrk " is not.")
-	  | _ -> 
+	  | _ ->
               (pr_id fi ++ strbrk " cannot be defined because it is not typable.")
   in
   if coe then errorlabstrm "structure" st;
@@ -136,20 +133,20 @@ let subst_projection fid l c =
   let rec substrec depth c = match kind_of_term c with
     | Rel k ->
 	(* We are in context [[params;fields;x:ind;...depth...]] *)
-        if k <= depth+1 then 
+        if k <= depth+1 then
 	  c
         else if k-depth-1 <= lv then
 	  match List.nth l (k-depth-2) with
 	    | Projection t -> lift depth t
 	    | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k
 	    | NoProjection Anonymous -> assert false
-        else 
+        else
 	  mkRel (k-lv)
     | _ -> map_constr_with_binders succ substrec depth c
   in
   let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *)
   let c'' = substrec 0 c' in
-  if !bad_projs <> [] then 
+  if !bad_projs <> [] then
     raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
   c''
 
@@ -165,7 +162,7 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls
   let r = mkInd indsp in
   let rp = applist (r, extended_rel_list 0 paramdecls) in
   let paramargs = extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*)
-  let x = match name with Some n -> Name n | None -> Termops.named_hd (Global.env()) r Anonymous in
+  let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in
   let fields = instantiate_possibly_recursive_type indsp paramdecls fields in
   let lifted_fields = lift_rel_context 1 fields in
   let (_,kinds,sp_projs,_) =
@@ -222,8 +219,24 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls
       (List.length fields,[],[],[]) coers (List.rev fields) (List.rev fieldimpls)
   in (kinds,sp_projs)
 
-let declare_structure finite id idbuild paramimpls params arity fieldimpls fields
-    ?(kind=StructureComponent) ?name is_coe coers =
+let structure_signature ctx =
+  let rec deps_to_evar evm l =
+    match l with [] -> Evd.empty
+      | [(_,_,typ)] -> Evd.add evm (Evarutil.new_untyped_evar())
+	  (Evd.make_evar Environ.empty_named_context_val typ)
+      | (_,_,typ)::tl ->
+	  let ev = Evarutil.new_untyped_evar() in
+	  let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val typ) in
+	  let new_tl = Util.list_map_i
+	    (fun pos (n,c,t) -> n,c,
+	       Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in
+	  deps_to_evar evm new_tl in
+  deps_to_evar Evd.empty (List.rev ctx)
+
+open Typeclasses
+
+let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields
+    ?(kind=StructureComponent) ?name is_coe coers sign =
   let nparams = List.length params and nfields = List.length fields in
   let args = extended_rel_list nfields params in
   let ind = applist (mkRel (1+nparams+nfields), args) in
@@ -238,7 +251,7 @@ let declare_structure finite id idbuild paramimpls params arity fieldimpls field
         but isn't *)
   (* there is probably a way to push this to "declare_mutual" *)
   begin match  finite with
-  | BiFinite -> 
+  | BiFinite ->
       if dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then
 	error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record."
   | _ -> ()
@@ -248,44 +261,40 @@ let declare_structure finite id idbuild paramimpls params arity fieldimpls field
       mind_entry_record = true;
       mind_entry_finite = recursivity_flag_of_kind finite;
       mind_entry_inds = [mie_ind] } in
-  let kn = Command.declare_mutual_with_eliminations true mie [(paramimpls,[])] in
+(* TODO : maybe switch to KernelVerbose *)
+  let kn = Command.declare_mutual_inductive_with_eliminations KernelSilent mie [(paramimpls,[])] in
   let rsp = (kn,0) in (* This is ind path of idstruc *)
+  let cstr = (rsp,1) in
   let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in
-  let build = ConstructRef (rsp,1) in
-    if is_coe then Class.try_add_new_coercion build Global;
-    Recordops.declare_structure(rsp,(rsp,1),List.rev kinds,List.rev sp_projs);
-    kn,0
+  let build = ConstructRef cstr in
+  if is_coe then Class.try_add_new_coercion build Global;
+  Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs);
+  if infer then
+    Evd.fold (fun ev evi () -> Recordops.declare_method (ConstructRef cstr) ev sign) sign ();
+  rsp
 
 let implicits_of_context ctx =
   list_map_i (fun i name ->
-    let explname = 
-      match name with 
+    let explname =
+      match name with
       | Name n -> Some n
       | Anonymous -> None
-    in ExplByPos (i, explname), (true, true))
+    in ExplByPos (i, explname), (true, true, true))
     1 (List.rev (Anonymous :: (List.map pi1 ctx)))
 
-open Typeclasses
-
-let typeclasses_db = "typeclass_instances"
-
 let qualid_of_con c = 
   Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c))
 
-let set_rigid c = 
-  Auto.add_hints false [typeclasses_db] 
-    (Vernacexpr.HintsTransparency ([qualid_of_con c], false))
-
 let declare_instance_cst glob con =
   let instance = Typeops.type_of_constant (Global.env ()) con in
-  let _, r = Sign.decompose_prod_assum instance in
+  let _, r = decompose_prod_assum instance in
     match class_of_constr r with
-      | Some tc -> add_instance (new_instance tc None glob con)
+      | Some tc -> add_instance (new_instance tc None glob (ConstRef con))
       | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.")
 
-let declare_class finite def id idbuild paramimpls params arity fieldimpls fields
-    ?(kind=StructureComponent) ?name is_coe coers =
-  let fieldimpls = 
+let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields
+    ?(kind=StructureComponent) ?name is_coe coers sign =
+  let fieldimpls =
     (* Make the class and all params implicits in the projections *)
     let ctx_impls = implicits_of_context params in
     let len = succ (List.length params) in
@@ -303,37 +312,37 @@ let declare_class finite def id idbuild paramimpls params arity fieldimpls field
 	    const_entry_boxed = false }
 	in
 	let cst = Declare.declare_constant (snd id)
-	  (DefinitionEntry class_entry, IsDefinition Definition) 
+	  (DefinitionEntry class_entry, IsDefinition Definition)
 	in
 	let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in
 	let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in
 	let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in
-	let proj_entry = 
+	let proj_entry =
 	  { const_entry_body = proj_body;
 	    const_entry_type = Some proj_type;
 	    const_entry_opaque = false;
 	    const_entry_boxed = false }
 	in
 	let proj_cst = Declare.declare_constant proj_name
-	  (DefinitionEntry proj_entry, IsDefinition Definition) 
+	  (DefinitionEntry proj_entry, IsDefinition Definition)
 	in
 	let cref = ConstRef cst in
-	  Impargs.declare_manual_implicits false cref paramimpls;
-	  Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls);
-	  set_rigid cst; (* set_rigid proj_cst; *)
-	  cref, [proj_name, Some proj_cst]
+	Impargs.declare_manual_implicits false cref paramimpls;
+	Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls);
+	Classes.set_typeclass_transparency (EvalConstRef cst) false;
+	if infer then Evd.fold (fun ev evi _ -> Recordops.declare_method (ConstRef cst) ev sign) sign ();
+	cref, [proj_name, Some proj_cst]
     | _ ->
-	let idarg = Nameops.next_ident_away (snd id) (ids_of_context (Global.env())) in
-	let ind = declare_structure BiFinite (snd id) idbuild paramimpls
+	let idarg = Namegen.next_ident_away (snd id) (ids_of_context (Global.env())) in
+	let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls
 	  params (Option.cata (fun x -> x) (new_Type ()) arity) fieldimpls fields
-	  ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields)
+	  ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign
 	in
-	  (* List.iter (Option.iter (declare_interning_data ((),[]))) notations; *)
 	  IndRef ind, (List.map2 (fun (id, _, _) y -> (Nameops.out_name id, y))
 			     (List.rev fields) (Recordops.lookup_projections ind))
   in
   let ctx_context =
-    List.map (fun (na, b, t) -> 
+    List.map (fun (na, b, t) ->
       match Typeclasses.class_of_constr t with
       | Some cl -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*)
       | None -> None)
@@ -345,16 +354,24 @@ let declare_class finite def id idbuild paramimpls params arity fieldimpls field
       cl_props = fields;
       cl_projs = projs }
   in
-    List.iter2 (fun p sub -> 
+    List.iter2 (fun p sub ->
       if sub then match snd p with Some p -> declare_instance_cst true p | None -> ())
       k.cl_projs coers;
-    add_class k; impl
+  add_class k; impl
+
+let interp_and_check_sort sort =
+  Option.map (fun sort ->
+    let env = Global.env() and sigma = Evd.empty in
+    let s = interp_constr sigma env sort in
+    if isSort (Reductionops.whd_betadeltaiota env sigma s) then s
+    else user_err_loc (constr_loc sort,"", str"Sort expected.")) sort
 
 open Vernacexpr
+open Autoinstance
 
-(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean 
+(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean
    list telling if the corresponding fields must me declared as coercion *)
-let definition_structure (kind,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) =
+let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) =
   let cfs,notations = List.split cfs in
   let coers,fs = List.split cfs in
   let extract_name acc = function
@@ -364,16 +381,21 @@ let definition_structure (kind,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) =
   let allnames =  idstruc::(List.fold_left extract_name [] fs) in
   if not (list_distinct allnames) then error "Two objects have the same name";
   (* Now, younger decl in params and fields is on top *)
-  let sc = Option.map mkSort s in
-  let implpars, params, implfs, fields = 
+  let sc = interp_and_check_sort s in
+  let implpars, params, implfs, fields =
     States.with_state_protection (fun () ->
-      typecheck_params_and_fields idstruc sc ps notations fs) ()
-  in
+      typecheck_params_and_fields idstruc sc ps notations fs) () in
+  let sign = structure_signature (fields@params) in
     match kind with
-    | Class b ->
-	declare_class finite b (loc,idstruc) idbuild implpars params sc implfs fields is_coe coers
+    | Class def ->
+	let gr = declare_class finite def infer (loc,idstruc) idbuild
+	  implpars params sc implfs fields is_coe coers sign in
+	if infer then search_record declare_class_instance gr sign;
+	gr
     | _ ->
-	let arity = Option.cata (fun x -> x) (new_Type ()) sc in
+	let arity = Option.default (new_Type ()) sc in
 	let implfs = List.map
-	  (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs
-	in IndRef (declare_structure finite idstruc idbuild implpars params arity implfs fields is_coe coers)
+	  (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in
+	let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs fields is_coe coers sign in
+	if infer then search_record declare_record_instance (ConstructRef (ind,1)) sign;
+	IndRef ind
diff --git a/toplevel/record.mli b/toplevel/record.mli
index b49c26bc..b9864f08 100644
--- a/toplevel/record.mli
+++ b/toplevel/record.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: record.mli 11809 2009-01-20 11:39:55Z aspiwack $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -24,18 +24,20 @@ open Libnames
 
 val declare_projections :
   inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier ->
-  bool list -> manual_explicitation list list -> rel_context -> 
+  bool list -> manual_explicitation list list -> rel_context ->
   (name * bool) list * constant option list
 
-val declare_structure : Decl_kinds.recursivity_kind -> 
-  identifier -> identifier -> 
+val declare_structure : Decl_kinds.recursivity_kind ->
+  bool (*infer?*) -> identifier -> identifier ->
   manual_explicitation list -> rel_context -> (* params *) constr -> (* arity *)
-  Impargs.manual_explicitation list list -> Sign.rel_context -> (* fields *)
+  Impargs.manual_explicitation list list -> rel_context -> (* fields *)
   ?kind:Decl_kinds.definition_object_kind -> ?name:identifier ->
   bool -> (* coercion? *)
   bool list -> (* field coercions *)
+  Evd.evar_map ->
   inductive
 
 val definition_structure :
-  inductive_kind*Decl_kinds.recursivity_kind *lident with_coercion * local_binder list *
-  (local_decl_expr with_coercion with_notation) list * identifier * sorts option -> global_reference
+  inductive_kind * Decl_kinds.recursivity_kind * bool(*infer?*)* lident with_coercion * local_binder list *
+  (local_decl_expr with_coercion with_notation) list *
+  identifier * constr_expr option -> global_reference
diff --git a/parsing/search.ml b/toplevel/search.ml
index 8b1551b6..075c80c9 100644
--- a/parsing/search.ml
+++ b/toplevel/search.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: search.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -47,58 +47,58 @@ let rec head_const c = match kind_of_term c with
 
 let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
   let env = Global.env () in
-  let crible_rec (sp,_) lobj = match object_tag lobj with
+  let crible_rec (sp,kn) lobj = match object_tag lobj with
     | "VARIABLE" ->
-	(try 
-	   let (id,_,typ) = Global.lookup_named (basename sp) in 
+	(try
+	   let (id,_,typ) = Global.lookup_named (basename sp) in
            if refopt = None
 	     || head_const typ = constr_of_global (Option.get refopt)
 	   then
 	     fn (VarRef id) env typ
 	 with Not_found -> (* we are in a section *) ())
     | "CONSTANT" ->
-	let cst = locate_constant (qualid_of_sp sp) in
+	let cst = Global.constant_of_delta(constant_of_kn kn) in
 	let typ = Typeops.type_of_constant env cst in
         if refopt = None
 	  || head_const typ = constr_of_global (Option.get refopt)
 	then
 	  fn (ConstRef cst) env typ
-    | "INDUCTIVE" -> 
-	let kn = locate_mind (qualid_of_sp sp) in
-        let mib = Global.lookup_mind kn in 
-        (match refopt with 
-	  | Some (IndRef ((kn',tyi) as ind)) when kn=kn' ->
+    | "INDUCTIVE" ->
+	let mind = Global.mind_of_delta(mind_of_kn kn) in
+        let mib = Global.lookup_mind mind in
+        (match refopt with
+	  | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' ->
 	      print_constructors ind fn env
 	        (Array.length (mib.mind_packets.(tyi).mind_user_lc))
           | Some _ -> ()
 	  | _ ->
-              Array.iteri 
-	        (fun i mip -> print_constructors (kn,i) fn env
+              Array.iteri
+	        (fun i mip -> print_constructors (mind,i) fn env
 	          (Array.length mip.mind_user_lc)) mib.mind_packets)
     | _ -> ()
-  in 
-  try 
+  in
+  try
     Declaremods.iter_all_segments crible_rec
-  with Not_found -> 
+  with Not_found ->
     ()
 
 let crible ref = gen_crible (Some ref)
 
 (* Fine Search. By Yves Bertot. *)
 
-exception No_section_path
+exception No_full_path
 
-let rec head c = 
+let rec head c =
   let c = strip_outer_cast c in
   match kind_of_term c with
   | Prod (_,_,c) -> head c
   | LetIn (_,_,_,c) -> head c
   | _              -> c
-      
-let constr_to_section_path c = match kind_of_term c with
+
+let constr_to_full_path c = match kind_of_term c with
   | Const sp -> sp
-  | _ -> raise No_section_path
-      
+  | _ -> raise No_full_path
+
 let xor a b = (a or b) & (not (a & b))
 
 let plain_display ref a c =
@@ -106,23 +106,22 @@ let plain_display ref a c =
   let pr = pr_global ref in
   msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ())
 
-let filter_by_module (module_list:dir_path list) (accept:bool) 
+let filter_by_module (module_list:dir_path list) (accept:bool)
   (ref:global_reference) _ _ =
   try
-    let sp = sp_of_global ref in
+    let sp = path_of_global ref in
     let sl = dirpath sp in
     let rec filter_aux = function
       | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl)
-      | [] -> true 
+      | [] -> true
     in
     xor accept (filter_aux module_list)
-  with No_section_path -> 
+  with No_full_path ->
     false
 
-let gref_eq =
-  IndRef (Libnames.encode_kn Coqlib.logic_module (id_of_string "eq"), 0)
-let gref_eqT =
-  IndRef (Libnames.encode_kn Coqlib.logic_type_module (id_of_string "eqT"), 0)
+let ref_eq = Libnames.encode_mind Coqlib.logic_module (id_of_string "eq"), 0
+let c_eq = mkInd ref_eq
+let gref_eq = IndRef ref_eq
 
 let mk_rewrite_pattern1 eq pattern =
   PApp (PRef eq, [| PMeta None; pattern; PMeta None |])
@@ -131,18 +130,18 @@ let mk_rewrite_pattern2 eq pattern =
   PApp (PRef eq, [| PMeta None; PMeta None; pattern |])
 
 let pattern_filter pat _ a c =
-  try 
+  try
     try
-      is_matching pat (head c) 
-    with _ -> 
+      is_matching pat (head c)
+    with _ ->
       is_matching
 	pat (head (Typing.type_of (Global.env()) Evd.empty c))
-    with UserError _ -> 
+    with UserError _ ->
       false
 
 let filtered_search filter_function display_function ref =
   crible ref
-    (fun s a c -> if filter_function s a c then display_function s a c) 
+    (fun s a c -> if filter_function s a c then display_function s a c)
 
 let rec id_from_pattern = function
   | PRef gr -> gr
@@ -151,49 +150,72 @@ let rec id_from_pattern = function
  *)
   | PApp (p,_) -> id_from_pattern p
   | _ -> error "The pattern is not simple enough."
-	
+
 let raw_pattern_search extra_filter display_function pat =
   let name = id_from_pattern pat in
-  filtered_search 
-    (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) 
+  filtered_search
+    (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c)
     display_function name
 
 let raw_search_rewrite extra_filter display_function pattern =
   filtered_search
     (fun s a c ->
        ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) ||
-        (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) 
+        (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c))
        && extra_filter s a c)
     display_function gref_eq
 
+let raw_search_by_head extra_filter display_function pattern =
+  Util.todo "raw_search_by_head"
+
+let name_of_reference ref = string_of_id (basename_of_global ref)
+
+(*
+ * functions to use the new Libtypes facility
+ *)
+
+let raw_search search_function extra_filter display_function pat =
+  let env = Global.env() in
+  List.iter
+    (fun (gr,_,_) ->
+       let typ = Global.type_of_global gr in
+       if extra_filter gr env typ then
+	 display_function gr env typ
+    ) (search_function pat)
+
 let text_pattern_search extra_filter =
-  raw_pattern_search extra_filter plain_display
-    
+  raw_search Libtypes.search_concl extra_filter plain_display
+
 let text_search_rewrite extra_filter =
-  raw_search_rewrite extra_filter plain_display
+  raw_search (Libtypes.search_eq_concl c_eq) extra_filter plain_display
+
+let text_search_by_head extra_filter =
+  raw_search Libtypes.search_head_concl extra_filter plain_display
 
 let filter_by_module_from_list = function
   | [], _ -> (fun _ _ _ -> true)
   | l, outside -> filter_by_module l (not outside)
 
-let search_by_head ref inout = 
-  filtered_search (filter_by_module_from_list inout) plain_display ref
+let filter_subproof gr _ _ =
+  not (string_string_contains (name_of_reference gr) "_subproof")
+
+let (&&&&&) f g x y z = f x y z && g x y z
+
+let search_by_head pat inout =
+  text_search_by_head (filter_by_module_from_list inout &&&&& filter_subproof) pat
 
 let search_rewrite pat inout =
-  text_search_rewrite (filter_by_module_from_list inout) pat
+  text_search_rewrite (filter_by_module_from_list inout &&&&& filter_subproof) pat
 
 let search_pattern pat inout =
-  text_pattern_search (filter_by_module_from_list inout) pat
-
+  text_pattern_search (filter_by_module_from_list inout &&&&& filter_subproof) pat
 
 let gen_filtered_search filter_function display_function =
   gen_crible None
-    (fun s a c -> if filter_function s a c then display_function s a c) 
+    (fun s a c -> if filter_function s a c then display_function s a c)
 
 (** SearchAbout *)
 
-let name_of_reference ref = string_of_id (id_of_global ref)
-
 type glob_search_about_item =
   | GlobSearchSubPattern of constr_pattern
   | GlobSearchString of string
@@ -205,10 +227,10 @@ let search_about_item (itemref,typ) = function
 let raw_search_about filter_modules display_function l =
   let filter ref' env typ =
     filter_modules ref' env typ &&
-    List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && 
-    not (string_string_contains (name_of_reference ref') "_subproof")
+    List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l &&
+      filter_subproof ref' () ()
   in
   gen_filtered_search filter display_function
 
-let search_about ref inout = 
+let search_about ref inout =
   raw_search_about (filter_by_module_from_list inout) plain_display ref
diff --git a/parsing/search.mli b/toplevel/search.mli
index 7d12d26f..cc764fbd 100644
--- a/parsing/search.mli
+++ b/toplevel/search.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: search.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
+(*i $Id$ i*)
 
 open Pp
 open Names
@@ -22,10 +22,10 @@ type glob_search_about_item =
   | GlobSearchSubPattern of constr_pattern
   | GlobSearchString of string
 
-val search_by_head : global_reference -> dir_path list * bool -> unit
-val search_rewrite : constr_pattern -> dir_path list * bool -> unit
-val search_pattern : constr_pattern -> dir_path list * bool -> unit
-val search_about : 
+val search_by_head : constr -> dir_path list * bool -> unit
+val search_rewrite : constr -> dir_path list * bool -> unit
+val search_pattern : constr -> dir_path list * bool -> unit
+val search_about  :
   (bool * glob_search_about_item) list -> dir_path list * bool -> unit
 
 (* The filtering function that is by standard search facilities.
@@ -39,12 +39,14 @@ val filter_by_module_from_list :
    They are also used for pcoq. *)
 val gen_filtered_search : (global_reference -> env -> constr -> bool) ->
       (global_reference -> env -> constr -> unit) -> unit
-val filtered_search : (global_reference -> env -> constr -> bool) -> 
+val filtered_search : (global_reference -> env -> constr -> bool) ->
   (global_reference -> env -> constr -> unit) -> global_reference -> unit
 val raw_pattern_search : (global_reference -> env -> constr -> bool) ->
   (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
 val raw_search_rewrite : (global_reference -> env -> constr -> bool) ->
   (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
 val raw_search_about : (global_reference -> env -> constr -> bool) ->
-  (global_reference -> env -> constr -> unit) -> 
+  (global_reference -> env -> constr -> unit) ->
       (bool * glob_search_about_item) list -> unit
+val raw_search_by_head : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
diff --git a/toplevel/searchisos.mli b/toplevel/searchisos.mli
deleted file mode 100644
index 184725b2..00000000
--- a/toplevel/searchisos.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: searchisos.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-val search_in_lib : bool ref
-val type_search : Term.constr -> unit
-val require_module2 : bool option -> string -> string option -> bool -> unit
-val upd_tbl_ind_one : unit -> unit
-val seetime : bool ref
-val load_leaf_entry : string -> Names.section_path * Libobject.obj -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
index 9d64f983..ee821a48 100644
--- a/toplevel/toplevel.ml
+++ b/toplevel/toplevel.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: toplevel.ml 12891 2010-03-30 11:40:02Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -15,12 +15,11 @@ open Cerrors
 open Vernac
 open Vernacexpr
 open Pcoq
-open Protectedtoplevel
 
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
 
-type input_buffer = { 
+type input_buffer = {
   mutable prompt : unit -> string;
   mutable str : string; (* buffer of already read characters *)
   mutable len : int;    (* number of chars in the buffer *)
@@ -72,7 +71,7 @@ let prompt_char ic ibuf count =
     ibuf.str.[ibuf.len] <- c;
     ibuf.len <- ibuf.len + 1;
     Some c
-  with End_of_file -> 
+  with End_of_file ->
     None
 
 (* Reinitialize the char stream (after a Drop) *)
@@ -94,34 +93,49 @@ let get_bols_of_loc ibuf (bp,ep) =
     if b < 0 or e < b then anomaly "Bad location";
     match lines with
       | ([],None) -> ([], Some (b,e))
-      | (fl,oe) -> ((b,e)::fl, oe) 
+      | (fl,oe) -> ((b,e)::fl, oe)
   in
   let rec lines_rec ba after = function
     | []                  -> add_line (0,ba) after
     | ll::_ when ll <= bp -> add_line (ll,ba) after
     | ll::fl              ->
         let nafter = if ll < ep then add_line (ll,ba) after else after in
-        lines_rec ll nafter fl 
+        lines_rec ll nafter fl
   in
   let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in
   (fl,Option.get ll)
 
 let dotted_location (b,e) =
-  if e-b < 3 then 
+  if e-b < 3 then
     ("", String.make (e-b) ' ')
-  else 
+  else
     (String.make (e-b-1) '.', " ")
 
+let blanch_utf8_string s bp ep =
+  let s' = String.make (ep-bp) ' ' in
+  let j = ref 0 in
+  for i = bp to ep - 1 do
+    let n = Char.code s.[i] in
+    (* Heuristic: assume utf-8 chars are printed using a single
+    fixed-size char and therefore contract all utf-8 code into one
+    space; in any case, preserve tabulation so
+    that its effective interpretation in terms of spacing is preserved *)
+    if s.[i] = '\t' then s'.[!j] <- '\t';
+    if n < 0x80 || 0xC0 <= n then incr j
+  done;
+  String.sub s' 0 !j
+
 let print_highlight_location ib loc =
   let (bp,ep) = unloc loc in
-  let bp = bp - ib.start 
+  let bp = bp - ib.start
   and ep = ep - ib.start in
   let highlight_lines =
     match get_bols_of_loc ib (bp,ep) with
-      | ([],(bl,el)) ->  
+      | ([],(bl,el)) ->
+	  let shift = blanch_utf8_string ib.str bl bp in
+	  let span = String.length (blanch_utf8_string ib.str bp ep) in
 	  (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++
-             str"> " ++ str(String.make (bp-bl) ' ') ++
-             str(String.make (ep-bp) '^'))
+           str"> " ++ str(shift) ++ str(String.make span '^'))
       | ((b1,e1)::ml,(bn,en)) ->
           let (d1,s1) = dotted_location (b1,bp) in
           let (dn,sn) = dotted_location (ep,en) in
@@ -131,9 +145,9 @@ let print_highlight_location ib loc =
             prlist (fun (bi,ei) ->
                       (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in
           let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++
-                      str sn ++ str dn) in 
+                      str sn ++ str dn) in
 	  (l1 ++ li ++ ln)
-  in 
+  in
   let loc = make_loc (bp,ep) in
   (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ str":" ++ fnl () ++
      highlight_lines ++ fnl ())
@@ -171,7 +185,7 @@ let print_location_in_file s inlibrary fname loc =
     with e ->
       (close_in ic;
        hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ())
-	
+
 let print_command_location ib dloc =
   match dloc with
     | Some (bp,ep) ->
@@ -185,10 +199,10 @@ let valid_loc dloc loc =
     | Some dloc ->
 	let (bd,ed) = unloc dloc in let (b,e) = unloc loc in bd<=b & e<=ed
     | _ -> true
-	  
+
 let valid_buffer_loc ib dloc loc =
-  valid_loc dloc loc & 
-  let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e 
+  valid_loc dloc loc &
+  let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e
 
 (*s The Coq prompt is the name of the focused proof, if any, and "Coq"
     otherwise. We trap all exceptions to prevent the error message printing
@@ -196,35 +210,35 @@ let valid_buffer_loc ib dloc loc =
 let make_prompt () =
   try
     (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < "
-  with _ -> 
+  with _ ->
     "Coq < "
 
-(*let build_pending_list l = 
+(*let build_pending_list l =
   let pl = ref ">" in
   let l' = ref l in
-  let res = 
-    while List.length !l' > 1 do 
+  let res =
+    while List.length !l' > 1 do
       pl := !pl ^ "|" Names.string_of_id x;
       l':=List.tl !l'
     done in
   let last = try List.hd !l' with _ ->   in
   "<"^l'
-*)    
+*)
 
 (* the coq prompt added to the default one when in emacs mode
    The prompt contains the current state label [n] (for global
    backtracking) and the current proof state [p] (for proof
    backtracking) plus the list of open (nested) proofs (for proof
    aborting when backtracking). It looks like:
-   
+
    "n |lem1|lem2|lem3| p < "
 *)
 let make_emacs_prompt() =
   let statnum = string_of_int (Lib.current_command_label ()) in
   let dpth = Pfedit.current_proof_depth() in
   let pending = Pfedit.get_all_proof_names() in
-  let pendingprompt = 
-    List.fold_left 
+  let pendingprompt =
+    List.fold_left
       (fun acc x -> acc ^ (if acc <> "" then "|" else "") ^ Names.string_of_id x)
       "" pending in
   let proof_info = if dpth >= 0 then string_of_int dpth else "0" in
@@ -235,9 +249,9 @@ let make_emacs_prompt() =
  * initialized when a vernac command is immediately followed by "\n",
  * or after a Drop. *)
 let top_buffer =
-  let pr() = 
-    emacs_prompt_startstring() 
-    ^ make_prompt() 
+  let pr() =
+    emacs_prompt_startstring()
+    ^ make_prompt()
     ^ make_emacs_prompt()
     ^ emacs_prompt_endstring()
   in
@@ -250,7 +264,7 @@ let top_buffer =
 
 let set_prompt prompt =
   top_buffer.prompt
-  <- (fun () -> 
+  <- (fun () ->
     emacs_prompt_startstring()
     ^ prompt ()
     ^ emacs_prompt_endstring())
@@ -262,7 +276,7 @@ let rec is_pervasive_exn = function
   | Error_in_file (_,_,e) -> is_pervasive_exn e
   | Stdpp.Exc_located (_,e) -> is_pervasive_exn e
   | DuringCommandInterp (_,e) -> is_pervasive_exn e
-  | DuringSyntaxChecking e -> is_pervasive_exn e
+  | DuringSyntaxChecking (_,e) -> is_pervasive_exn e
   | _ -> false
 
 (* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
@@ -272,33 +286,31 @@ let print_toplevel_error exc =
   let (dloc,exc) =
     match exc with
       | DuringCommandInterp (loc,ie)
-      | Stdpp.Exc_located (loc, DuringSyntaxChecking ie) ->
+      | DuringSyntaxChecking (loc,ie) ->
           if loc = dummy_loc then (None,ie) else (Some loc, ie)
-      | _ -> (None, exc) 
+      | _ -> (None, exc)
   in
   let (locstrm,exc) =
     match exc with
       | Stdpp.Exc_located (loc, ie) ->
           if valid_buffer_loc top_buffer dloc loc then
             (print_highlight_location top_buffer loc, ie)
-          else 
+          else
 	    ((mt ()) (* print_command_location top_buffer dloc *), ie)
       | Error_in_file (s, (inlibrary, fname, loc), ie) ->
           (print_location_in_file s inlibrary fname loc, ie)
-      | _ -> 
+      | _ ->
 	  ((mt ()) (* print_command_location top_buffer dloc *), exc)
   in
   match exc with
-    | End_of_input -> 
+    | End_of_input ->
 	msgerrnl (mt ()); pp_flush(); exit 0
     | Vernacexpr.Drop ->  (* Last chance *)
         if Mltop.is_ocaml_top() then raise Vernacexpr.Drop;
         (str"Error: There is no ML toplevel." ++ fnl ())
-    | Vernacexpr.ProtectedLoop ->
-	raise Vernacexpr.ProtectedLoop
-    | Vernacexpr.Quit -> 
+    | Vernacexpr.Quit ->
 	raise Vernacexpr.Quit
-    | _ -> 
+    | _ ->
 	(if is_pervasive_exn exc then (mt ()) else locstrm) ++
         Cerrors.explain_exn exc
 
@@ -308,14 +320,14 @@ let parse_to_dot =
     | ("", ".") -> ()
     | ("EOI", "") -> raise End_of_input
     | _ -> dot st
-  in 
+  in
   Gram.Entry.of_parser "Coqtoplevel.dot" dot
-    
+
 (* We assume that when a lexer error occurs, at least one char was eaten *)
 let rec discard_to_dot () =
-  try 
+  try
     Gram.Entry.parse parse_to_dot top_buffer.tokens
-  with Stdpp.Exc_located(_,(Token.Error _|Lexer.Error _)) -> 
+  with Stdpp.Exc_located(_,(Token.Error _|Lexer.Error _)) ->
     discard_to_dot()
 
 
@@ -323,14 +335,14 @@ let rec discard_to_dot () =
  * in encountered. *)
 
 let process_error = function
-  | DuringCommandInterp _ 
-  | Stdpp.Exc_located (_,DuringSyntaxChecking _) as e -> e
+  | DuringCommandInterp _
+  | DuringSyntaxChecking _ as e -> e
   | e ->
-      if is_pervasive_exn e then 
+      if is_pervasive_exn e then
 	e
-      else 
-        try 
-	  discard_to_dot (); e 
+      else
+        try
+	  discard_to_dot (); e
 	with
           | End_of_input -> End_of_input
           | de -> if is_pervasive_exn de then de else e
@@ -344,11 +356,11 @@ let do_vernac () =
   msgerrnl (mt ());
   if !print_emacs then msgerr (str (top_buffer.prompt()));
   resynch_buffer top_buffer;
-  begin 
-    try 
+  begin
+    try
       raw_do_vernac top_buffer.tokens
-    with e -> 
-      msgnl (print_toplevel_error (process_error e)) 
+    with e ->
+      msgnl (print_toplevel_error (process_error e))
   end;
   flush_all()
 
@@ -356,30 +368,20 @@ let do_vernac () =
  * Ctrl-C will raise the exception Break instead of aborting Coq.
  * Here we catch the exceptions terminating the Coq loop, and decide
  * if we really must quit.
- * The boolean value is used to choose between a protected loop, which
- * we think is more suited for communication with other programs, or
- * plain communication. *)
+ *)
 
-let rec coq_switch b =
+let rec loop () =
   Sys.catch_break true;
   (* ensure we have a command separator object (DOT) so that the first
      command can be reseted. *)
   Lib.mark_end_of_command();
   try
-    if b then begin
-      reset_input_buffer stdin top_buffer;
-      while true do do_vernac() done
-    end else
-      protected_loop stdin
+    reset_input_buffer stdin top_buffer;
+    while true do do_vernac() done
   with
     | Vernacexpr.Drop -> ()
-    | Vernacexpr.ProtectedLoop -> 
-	Lib.declare_initial_state();
-	coq_switch false
     | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0
     | Vernacexpr.Quit -> exit 0
     | e ->
 	msgerrnl (str"Anomaly. Please report.");
-	coq_switch b
-
-let loop () = coq_switch true
+	loop ()
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
index f4d2e28a..3f2fa83a 100644
--- a/toplevel/toplevel.mli
+++ b/toplevel/toplevel.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: toplevel.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Pp
@@ -18,7 +18,7 @@ open Pcoq
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
 
-type input_buffer = { 
+type input_buffer = {
   mutable prompt : unit -> string;
   mutable str : string; (* buffer of already read characters *)
   mutable len : int;    (* number of chars in the buffer *)
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
new file mode 100644
index 00000000..4c229d16
--- /dev/null
+++ b/toplevel/toplevel.mllib
@@ -0,0 +1,24 @@
+Himsg
+Cerrors
+Class
+Vernacexpr
+Metasyntax
+Auto_ind_decl
+Libtypes
+Search
+Autoinstance
+Lemmas
+Indschemes
+Command
+Classes
+Record
+Ppvernac
+Vernacinterp
+Mltop
+Vernacentries
+Whelp
+Vernac
+Toplevel
+Usage
+Coqinit
+Coqtop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 96ff8cbc..25766048 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: usage.ml 11858 2009-01-26 13:27:23Z notin $ *)
+(* $Id$ *)
 
 let version () =
   Printf.printf "The Coq Proof Assistant, version %s (%s)\n"
@@ -23,7 +23,7 @@ let print_usage_channel co command =
 "  -I dir -as coqdir      map physical dir to logical coqdir
   -I dir                 map directory dir to the empty logical path
   -include dir           (idem)
-  -R dir -as coqdir      recursively map physical dir to logical coqdir 
+  -R dir -as coqdir      recursively map physical dir to logical coqdir
   -R dir coqdir          (idem)
   -top coqdir            set the toplevel name to be coqdir instead of Top
   -notop    r            set the toplevel name to be the empty logical path
@@ -33,11 +33,12 @@ let print_usage_channel co command =
   -is f                  (idem)
   -nois                  start with an empty state
   -outputstate f         write state in file f.coq
+  -compat X.Y            provides compatibility support for Coq version X.Y
 
-  -load-ml-object f      load ML object file f 
-  -load-ml-source f      load ML file f 
+  -load-ml-object f      load ML object file f
+  -load-ml-source f      load ML file f
   -load-vernac-source f  load Coq file f.v (Load f.)
-  -l f                   (idem) 
+  -l f                   (idem)
   -load-vernac-source-verbose f  load Coq file f.v (Load Verbose f.)
   -lv f	                 (idem)
   -load-vernac-object f  load Coq object file f.vo
@@ -49,6 +50,7 @@ let print_usage_channel co command =
   -byte                  run the bytecode version of Coq
 
   -where                 print Coq's standard library location and exit
+  -config                print Coq's configuration information and exit
   -v                     print Coq version and exit
 
   -q                     skip loading of rcfile
@@ -57,7 +59,7 @@ let print_usage_channel co command =
   -batch                 batch mode (exits just after arguments parsing)
   -boot                  boot mode (implies -q and -batch)
   -emacs                 tells Coq it is executed under Emacs
-  -noglob f              do not dump globalizations
+  -noglob                do not dump globalizations
   -dump-glob f           dump globalizations in file f (to be used by coqdoc)
   -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)
   -impredicative-set     set sort Set impredicative
@@ -86,7 +88,7 @@ options are:
 
 (* Print the configuration information *)
 
-let print_config () = 
+let print_config () =
   if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n";
   Printf.printf "COQLIB=%s/\n" Coq_config.coqlib;
   Printf.printf "COQSRC=%s/\n" Coq_config.coqsrc;
@@ -96,3 +98,4 @@ let print_config () =
   Printf.printf "CAMLP4BIN=%s\n" Coq_config.camlp4bin;
   Printf.printf "CAMLP4LIB=%s\n" Coq_config.camlp4lib
 
+
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index 0ee58f4d..fb973e3b 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -6,18 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: usage.mli 11830 2009-01-22 06:45:13Z notin $ i*)
+(*i $Id$ i*)
 
 (*s Prints the version number on the standard output and exits (with 0). *)
 
 val version : unit -> 'a
 
-(*s Prints the usage on the error output, preceded by a user-provided message. *)
+(*s Prints the usage on the error output, preceeded by a user-provided message. *)
 val print_usage : string -> unit
 
 (*s Prints the usage on the error output. *)
 val print_usage_coqtop : unit -> unit
 val print_usage_coqc : unit -> unit
 
-(*s Prints the configuration information. *)
+(*s Prints the configuration information *)
 val print_config : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index c5549503..96a19e30 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernac.ml 11801 2009-01-18 20:11:41Z herbelin $ *)
+(* $Id$ *)
 
 (* Parsing of vernacular. *)
 
@@ -25,6 +25,8 @@ open Ppvernac
 
 exception DuringCommandInterp of Util.loc * exn
 
+exception HasNotFailed
+
 (* Specifies which file is read. The intermediate file names are
    discarded here. The Drop exception becomes an error. We forget
    if the error ocurred during interpretation or not *)
@@ -33,8 +35,8 @@ let raise_with_file file exc =
   let (cmdloc,re) =
     match exc with
       | DuringCommandInterp(loc,e)
-      | Stdpp.Exc_located (loc,DuringSyntaxChecking e) -> (loc,e)
-      | e -> (dummy_loc,e) 
+      | DuringSyntaxChecking(loc,e) -> (loc,e)
+      | e -> (dummy_loc,e)
   in
   let (inner,inex) =
     match re with
@@ -43,7 +45,7 @@ let raise_with_file file exc =
       | Stdpp.Exc_located (loc, e) when loc <> dummy_loc ->
           ((false,file, loc), e)
       | _ -> ((false,file,cmdloc), re)
-  in 
+  in
   raise (Error_in_file (file, inner, disable_drop inex))
 
 let real_error = function
@@ -51,6 +53,8 @@ let real_error = function
   | Error_in_file (_, _, e) -> e
   | e -> e
 
+let timeout_handler _ = raise Timeout
+
 (* 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
@@ -66,7 +70,7 @@ let open_file_twice_if verbosely fname =
   (in_chan, longfname, (po, verb_ch))
 
 let close_input in_chan (_,verb) =
-  try 
+  try
     close_in in_chan;
     match verb with
       | Some verb_ch -> close_in verb_ch
@@ -86,7 +90,7 @@ let verbose_phrase verbch loc =
     | _ -> ()
 
 exception End_of_input
-  
+
 let parse_phrase (po, verbch) =
   match Pcoq.Gram.Entry.parse Pcoq.main_entry po with
     | Some (loc,_ as com) -> verbose_phrase verbch loc; com
@@ -131,7 +135,7 @@ let rec vernac_com interpfun (loc,com) =
         (* end translator state *)
         (* coqdoc state *)
         let cds = Dumpglob.coqdoc_freeze() in
-          if !Flags.beautify_file then 
+          if !Flags.beautify_file then
 	    begin
               let _,f = find_file_in_path ~warn:(Flags.is_verbose())
 		(Library.get_load_paths ())
@@ -139,7 +143,7 @@ let rec vernac_com interpfun (loc,com) =
 		chan_beautify := open_out (f^beautify_suffix);
 		Pp.comments := []
             end;
-          begin 
+          begin
 	    try
 	      read_vernac_file verbosely (make_suffix fname ".v");
               if !Flags.beautify_file then close_out !chan_beautify;
@@ -147,7 +151,7 @@ let rec vernac_com interpfun (loc,com) =
               Lexer.restore_com_state cs;
               Pp.comments := cl;
               Dumpglob.coqdoc_unfreeze cds
-	    with e -> 
+	    with e ->
 	      if !Flags.beautify_file then close_out !chan_beautify;
               chan_beautify := ch;
               Lexer.restore_com_state cs;
@@ -155,23 +159,52 @@ let rec vernac_com interpfun (loc,com) =
               Dumpglob.coqdoc_unfreeze cds;
 	      raise e
 	  end
-	      
+
     | VernacList l -> List.iter (fun (_,v) -> interp v) l
 
+    | VernacFail v ->
+	if not !just_parsing then begin try
+	  interp v; raise HasNotFailed
+	with e -> match real_error e with
+	  | HasNotFailed ->
+	      errorlabstrm "Fail" (str "The command has not failed !")
+	  | e ->
+	      (* if [e] is an anomaly, the next function will re-raise it *)
+	      let msg = Cerrors.explain_exn_no_anomaly e in
+	      msgnl (str "The command has indeed failed with message:" ++
+		     fnl () ++ str "=> " ++ hov 0 msg)
+	end
+
     | VernacTime v ->
-	let tstart = System.get_time() in
-        if not !just_parsing then interp v;
-	let tend = System.get_time() in
-        msgnl (str"Finished transaction in " ++
-                 System.fmt_time_difference tstart tend)
+	if not !just_parsing then begin
+	  let tstart = System.get_time() in
+          interp v;
+	  let tend = System.get_time() in
+          msgnl (str"Finished transaction in " ++
+                   System.fmt_time_difference tstart tend)
+	end
+
+    | VernacTimeout(n,v) ->
+	if not !just_parsing then begin
+	  let psh =
+	    Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
+	  ignore (Unix.alarm n);
+	  let stop() =
+	    (* stop alarm *)
+	    ignore(Unix.alarm 0);
+	    (* restore handler *)
+	    Sys.set_signal Sys.sigalrm psh in
+	  try interp v; stop()
+	  with e -> stop(); raise e
+	end
 
     | v -> if not !just_parsing then interpfun v
 
-  in 
+  in
     try
       if do_beautify () then pr_new_syntax loc (Some com);
       interp com
-    with e -> 
+    with e ->
       Format.set_formatter_out_channel stdout;
       raise (DuringCommandInterp (loc, e))
 
@@ -181,10 +214,10 @@ and vernac interpfun input =
 and read_vernac_file verbosely s =
   Flags.make_warn verbosely;
   let interpfun =
-    if verbosely then 
+    if verbosely then
       Vernacentries.interp
-    else 
-      Flags.silently Vernacentries.interp 
+    else
+      Flags.silently Vernacentries.interp
   in
   let (in_chan, fname, input) = open_file_twice_if verbosely s in
   try
@@ -221,17 +254,17 @@ let set_xml_end_library f = xml_end_library := f
 let load_vernac verb file =
   chan_beautify :=
     if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout;
-  try 
+  try
     read_vernac_file verb file;
     if !Flags.beautify_file then close_out !chan_beautify;
-  with e -> 
+  with e ->
     if !Flags.beautify_file then close_out !chan_beautify;
     raise_with_file file e
 
 (* Compile a vernac file (f is assumed without .v suffix) *)
 let compile verbosely f =
   let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in
-    if Dumpglob.multi_dump () then 
+    if Dumpglob.multi_dump () then
       Dumpglob.open_glob_file (f ^ ".glob");
     Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n");
     if !Flags.xml_export then !xml_start_library ();
@@ -242,3 +275,4 @@ let compile verbosely f =
       if Dumpglob.multi_dump () then Dumpglob.close_glob_file ();
       Library.save_library_to ldir (long_f_dot_v ^ "o")
 
+
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index 4f95376f..4dff36e5 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernac.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (* Parsing of vernacular. *)
 
@@ -41,6 +41,6 @@ val compile : bool -> string -> unit
 
 (* Interpret a vernac AST *)
 
-val vernac_com : 
+val vernac_com :
   (Vernacexpr.vernac_expr -> unit) ->
   Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index 385afbec..c4286900 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacentries.ml 12343 2009-09-17 17:02:03Z glondu $ i*)
+(*i $Id$ i*)
 
 (* Concrete syntax of the mathematical vernacular MV V2.6 *)
 
@@ -36,6 +36,7 @@ open Topconstr
 open Pretyping
 open Redexpr
 open Syntax_def
+open Lemmas
 
 (* Pcoq hooks *)
 
@@ -44,7 +45,7 @@ type pcoq_hook = {
   solve : int -> unit;
   abort : string -> unit;
   search : searchable -> dir_path list * bool -> unit;
-  print_name : reference -> unit;
+  print_name : reference Genarg.or_by_notation -> unit;
   print_check : Environ.env -> Environ.unsafe_judgment -> unit;
   print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr ->
     Environ.unsafe_judgment -> unit;
@@ -59,7 +60,7 @@ let set_pcoq_hook f = pcoq := Some f
 let cl_of_qualid = function
   | FunClass -> Classops.CL_FUN
   | SortClass -> Classops.CL_SORT
-  | RefClass r -> Class.class_of_global (global_with_alias r)
+  | RefClass r -> Class.class_of_global (Smartlocate.smart_global r)
 
 (*******************)
 (* "Show" commands *)
@@ -72,7 +73,7 @@ let show_proof () =
   msgnl (str"LOC: " ++
     prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++
     str"Subgoals" ++ fnl () ++
-    prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ 
+    prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++
       pr_ltype ty ++ fnl ())
       meta_types
     ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm))
@@ -90,7 +91,7 @@ let show_node () =
 		 str"  " ++
 		   hov 0 (prlist_with_sep pr_fnl pr_goal
 			    (List.map goal_of_proof spfl)))))
-    
+
 let show_script () =
   let pts = get_pftreestate () in
   let pf = proof_of_pftreestate pts
@@ -101,9 +102,9 @@ let show_thesis () =
      msgnl (anomaly "TODO" )
 
 let show_top_evars () =
-  let pfts = get_pftreestate () in 
-  let gls = top_goal_of_pftreestate pfts in 
-  let sigma = project gls in 
+  let pfts = get_pftreestate () in
+  let gls = top_goal_of_pftreestate pfts in
+  let sigma = project gls in
   msg (pr_evars_int 1 (Evarutil.non_instantiated sigma))
 
 let show_prooftree () =
@@ -119,40 +120,40 @@ let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) ()
 let show_intro all =
   let pf = get_pftreestate() in
   let gl = nth_goal_of_pftreestate 1 pf in
-  let l,_= Sign.decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
-  if all 
-  then 
-    let lid = Tactics.find_intro_names l gl in 
+  let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
+  if all
+  then
+    let lid = Tactics.find_intro_names l gl in
     msgnl (hov 0 (prlist_with_sep  spc pr_id lid))
-  else  
-    try  
+  else
+    try
       let n = list_last l in
       msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
     with Failure "list_last" -> message ""
 
-let id_of_name = function 
-  | Names.Anonymous -> id_of_string "x" 
+let id_of_name = function
+  | Names.Anonymous -> id_of_string "x"
   | Names.Name x -> x
 
 
 (* Building of match expression *)
 (* From ide/coq.ml *)
-let make_cases s = 
+let make_cases s =
   let qualified_name = Libnames.qualid_of_string s in
   let glob_ref = Nametab.locate qualified_name in
   match glob_ref with
-    | Libnames.IndRef i -> 
+    | Libnames.IndRef i ->
 	let {Declarations.mind_nparams = np}
-	    , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } 
+	    , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr }
 	      = Global.lookup_inductive i in
-	Util.array_fold_right2 
-	  (fun n t l ->  
+	Util.array_fold_right2
+	  (fun n t l ->
 	     let (al,_) = Term.decompose_prod t in
 	     let al,_ = Util.list_chop (List.length al - np) al in
-	     let rec rename avoid = function 
+	     let rec rename avoid = function
 	       | [] -> []
-	       | (n,_)::l -> 
-		   let n' = Termops.next_global_ident_away true (id_of_name n) avoid in
+	       | (n,_)::l ->
+		   let n' = Namegen.next_ident_away_in_goal (id_of_name n) avoid in
 		   string_of_id n' :: rename (n'::avoid) l in
 	     let al' = rename [] (List.rev al) in
 	     (string_of_id n :: al') :: l)
@@ -160,18 +161,18 @@ let make_cases s =
     | _ -> raise Not_found
 
 
-let show_match id = 
+let show_match id =
   try
     let s = string_of_id (snd id) in
-    let patterns = make_cases s in
-    let cases = 
-      List.fold_left 
-	(fun acc x -> 
+    let patterns = List.rev (make_cases s) in
+    let cases =
+      List.fold_left
+	(fun acc x ->
 	  match x with
 	    | [] -> assert false
 	    | [x] -> "| "^ x  ^ " => \n" ^ acc
-	    | x::l -> 
-		"| (" ^ List.fold_left (fun acc s ->  acc ^ " " ^ s) x l ^ ")" 
+	    | x::l ->
+		"| (" ^ List.fold_left (fun acc s ->  acc ^ " " ^ s) x l ^ ")"
 		^ " => \n" ^ acc)
 	"end" patterns in
     msg (str ("match # with\n" ^ cases))
@@ -196,7 +197,7 @@ let print_modules () =
   and loaded = Library.loaded_libraries () in
   let loaded_opened = list_intersect loaded opened
   and only_loaded = list_subtract loaded opened in
-  str"Loaded and imported library files: " ++ 
+  str"Loaded and imported library files: " ++
   pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++
   str"Loaded and not imported library files: " ++
   pr_vertical_list pr_dirpath only_loaded
@@ -213,7 +214,7 @@ let print_module r =
   with
       Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid)
 
-let print_modtype r = 
+let print_modtype r =
   let (loc,qid) = qualid_of_reference r in
   try
     let kn = Nametab.locate_modtype qid in
@@ -226,7 +227,7 @@ let dump_universes s =
   try
     Univ.dump_universes output (Global.universes ());
     close_out output;
-    msgnl (str ("Universes written to file \""^s^"\".")) 
+    msgnl (str ("Universes written to file \""^s^"\"."))
   with
       e -> close_out output; raise e
 
@@ -252,7 +253,7 @@ let msg_notfound_library loc qid = function
         strbrk "Cannot find a physical path bound to logical path " ++
            pr_dirpath dir ++ str".")
   | Library.LibNotFound ->
-      msgnl (hov 0 
+      msgnl (hov 0
 	(strbrk "Unable to locate library " ++ pr_qualid qid ++ str"."))
   | e -> assert false
 
@@ -261,22 +262,31 @@ let print_located_library r =
   try msg_found_library (Library.locate_qualified_library false qid)
   with e -> msg_notfound_library loc qid e
 
-let print_located_module r = 
+let print_located_module r =
   let (loc,qid) = qualid_of_reference r in
   let msg =
-    try 
+    try
       let dir = Nametab.full_name_module qid in
       str "Module " ++ pr_dirpath dir
     with Not_found ->
       (if fst (repr_qualid qid) = empty_dirpath then
 	str "No module is referred to by basename "
-      else 
+      else
 	str "No module is referred to by name ") ++ pr_qualid qid
-  in msgnl msg  
+  in msgnl msg
 
-let global_with_alias r =
-  let gr = global_with_alias r in
-    Dumpglob.add_glob (loc_of_reference r) gr;
+let print_located_tactic r =
+  let (loc,qid) = qualid_of_reference r in
+  msgnl
+    (try
+      str "Ltac " ++
+      pr_path (Nametab.path_of_tactic (Nametab.locate_tactic qid))
+     with Not_found ->
+	str "No Ltac definition is referred to by " ++ pr_qualid qid)
+
+let smart_global r =
+  let gr = Smartlocate.smart_global r in
+    Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr;
     gr
 
 (**********)
@@ -286,13 +296,13 @@ let vernac_syntax_extension = Metasyntax.add_syntax_extension
 
 let vernac_delimiters = Metasyntax.add_delimiters
 
-let vernac_bind_scope sc cll = 
+let vernac_bind_scope sc cll =
   List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll
 
 let vernac_open_close_scope = Notation.open_close_scope
 
 let vernac_arguments_scope local r scl =
-  Notation.declare_arguments_scope local (global_with_alias r) scl
+  Notation.declare_arguments_scope local (smart_global r) scl
 
 let vernac_infix = Metasyntax.add_infix
 
@@ -306,28 +316,26 @@ let start_proof_and_print k l hook =
   print_subgoals ();
   if !pcoq <> None then (Option.get !pcoq).start_proof ()
 
-let vernac_definition (local,_,_ as k) (loc,id as lid) def hook =
-  Dumpglob.dump_definition lid false "def";
+let vernac_definition (local,boxed,k) (loc,id as lid) def hook =
+  if local = Local then Dumpglob.dump_definition lid true "var"
+  else Dumpglob.dump_definition lid false "def";
   (match def with
     | ProveBody (bl,t) ->   (* local binders, typ *)
- 	if Lib.is_modtype () then
- 	  errorlabstrm "Vernacentries.VernacDefinition"
- 	    (str "Proof editing mode not supported in module types")
- 	else
- 	  let hook _ _ = () in
- 	    start_proof_and_print (local,DefinitionBody Definition) 
-	      [Some lid, (bl,t)] hook
+ 	let hook _ _ = () in
+ 	  start_proof_and_print (local,DefinitionBody Definition)
+	    [Some lid, (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)= Command.get_current_context () in
+          | Some r ->
+	      let (evc,env)= get_current_context () in
  		Some (interp_redexp env evc r) in
- 	  declare_definition id k bl red_option c typ_opt hook)
- 	      
+	let ce,imps = interp_definition boxed bl red_option c typ_opt in
+	declare_definition id (local,k) ce imps hook)
+
 let vernac_start_proof kind l lettop hook =
   if Dumpglob.dump () then
-    List.iter (fun (id, _) -> 
+    List.iter (fun (id, _) ->
       match id with
 	| Some lid -> Dumpglob.dump_definition lid false "prf"
 	| None -> ()) l;
@@ -335,9 +343,6 @@ let vernac_start_proof kind l lettop hook =
     if lettop then
       errorlabstrm "Vernacentries.StartProof"
 	(str "Let declarations can only be used in proof editing mode.");
-  if Lib.is_modtype () then
-    errorlabstrm "Vernacentries.StartProof"
-      (str "Proof editing mode not supported in module types.");
   start_proof_and_print (Global, Proof kind) l hook
 
 let vernac_end_proof = function
@@ -361,95 +366,90 @@ let vernac_exact_proof c =
     else
       errorlabstrm "Vernacentries.ExactProof"
 	(strbrk "Command 'Proof ...' can only be used at the beginning of the proof.")
-  	
+
 let vernac_assumption kind l nl=
+  if Pfedit.refining () then
+    errorlabstrm ""
+      (str "Cannot declare an assumption while in proof editing mode.");
   let global = fst kind = Global in
-    List.iter (fun (is_coe,(idl,c)) -> 
+    List.iter (fun (is_coe,(idl,c)) ->
       if Dumpglob.dump () then
-	List.iter (fun lid -> 
-	  if global then Dumpglob.dump_definition lid false "ax" 
+	List.iter (fun lid ->
+	  if global then Dumpglob.dump_definition lid false "ax"
 	  else Dumpglob.dump_definition lid true "var") idl;
-      declare_assumption idl is_coe kind [] c false [] nl) l
+      let t,imps = interp_assumption [] c in
+      declare_assumptions idl is_coe kind t imps false nl) l
 
-let vernac_record k finite struc binders sort nameopt cfs =
-  let const = match nameopt with 
+let vernac_record k finite infer struc binders sort nameopt cfs =
+  let const = match nameopt with
     | None -> add_prefix "Build_" (snd (snd struc))
     | Some (_,id as lid) ->
 	Dumpglob.dump_definition lid false "constr"; id in
-  let sigma = Evd.empty in
-  let env = Global.env() in
-  let s = Option.map (fun x ->
-    let s = Reductionops.whd_betadeltaiota env sigma (interp_constr sigma env x) in
-      match kind_of_term s with
-      | Sort s -> s
-      | _ -> user_err_loc
-          (constr_loc x,"definition_structure", str "Sort expected.")) sort
-  in
     if Dumpglob.dump () then (
       Dumpglob.dump_definition (snd struc) false "rec";
       List.iter (fun ((_, x), _) ->
 	match x with
 	| Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj"
 	| _ -> ()) cfs);
-    ignore(Record.definition_structure (k,finite,struc,binders,cfs,const,s))
-      
-let vernac_inductive finite indl = 
+    ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort))
+
+let vernac_inductive finite infer indl =
   if Dumpglob.dump () then
     List.iter (fun (((coe,lid), _, _, _, cstrs), _) ->
-      match cstrs with 
-      | Constructors cstrs ->
-	  Dumpglob.dump_definition lid false "ind";
-	  List.iter (fun (_, (lid, _)) ->
-	    Dumpglob.dump_definition lid false "constr") cstrs
-      | _ -> () (* dumping is done by vernac_record (called below) *) )
-    indl;
+      match cstrs with
+	| Constructors cstrs ->
+	    Dumpglob.dump_definition lid false "ind";
+	    List.iter (fun (_, (lid, _)) ->
+			 Dumpglob.dump_definition lid false "constr") cstrs
+	| _ -> () (* dumping is done by vernac_record (called below) *) )
+      indl;
   match indl with
-  | [ ( id , bl , c , b, RecordDecl (oc,fs) ), None ] -> 
+  | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] ->
       vernac_record (match b with Class true -> Class false | _ -> b)
-	finite id bl c oc fs
-  | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> 
-      let f = 
+	finite infer id bl c oc fs
+  | [ ( id , bl , c , Class true, Constructors [l]), _ ] ->
+      let f =
 	let (coe, ((loc, id), ce)) = l in
-	  ((coe, AssumExpr ((loc, Name id), ce)), None)
-      in vernac_record (Class true) finite id bl c None [f]
-  | [ ( id , bl , c , Class true, _), _ ] -> 
+	  ((coe, AssumExpr ((loc, Name id), ce)), [])
+      in vernac_record (Class true) finite infer id bl c None [f]
+  | [ ( id , bl , c , Class true, _), _ ] ->
       Util.error "Definitional classes must have a single method"
   | [ ( id , bl , c , Class false, Constructors _), _ ] ->
       Util.error "Inductive classes not supported"
-  | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> 
+  | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] ->
       Util.error "where clause not supported for (co)inductive records"
-  | _ -> let unpack = function 
+  | _ -> let unpack = function
       | ( (_, id) , bl , c , _ , Constructors l ) , ntn  -> ( id , bl , c , l ) , ntn
       | _ -> Util.error "Cannot handle mutually (co)inductive records."
     in
     let indl = List.map unpack indl in
-      Command.build_mutual indl (recursivity_flag_of_kind finite)
+    do_mutual_inductive indl (recursivity_flag_of_kind finite)
 
-let vernac_fixpoint l b = 
+let vernac_fixpoint l b =
   if Dumpglob.dump () then
     List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  build_recursive l b
+  do_fixpoint l b
 
 let vernac_cofixpoint l b =
   if Dumpglob.dump () then
     List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  build_corecursive l b
+  do_cofixpoint l b
 
-let vernac_scheme = build_scheme
+let vernac_scheme = Indschemes.do_scheme
 
-let vernac_combined_scheme = build_combined_scheme
+let vernac_combined_scheme = Indschemes.do_combined_scheme
 
 (**********************)
 (* Modules            *)
 
 let vernac_import export refl =
-  let import ref = 
+  let import ref =
     Library.import_module export (qualid_of_reference ref)
   in
     List.iter import refl;
     Lib.add_frozen_state ()
 
-let vernac_declare_module export (loc, id) binders_ast mty_ast_o = 
+let vernac_declare_module export (loc, id) binders_ast mty_ast =
   (* We check the state of the system (in section, in module type)
      and what module information is supplied *)
   if Lib.sections_are_opened () then
@@ -461,21 +461,22 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast_o =
        "Remove the \"Export\" and \"Import\" keywords from every functor " ^
        "argument.")
      else (idl,ty)) binders_ast in
-  let mp = Declaremods.declare_module 
+  let mp = Declaremods.declare_module
     Modintern.interp_modtype Modintern.interp_modexpr
-    id binders_ast (Some mty_ast_o) None
-  in 
+    Modintern.interp_modexpr_or_modtype
+    id binders_ast (Enforce mty_ast) []
+  in
     Dumpglob.dump_moddef loc mp "mod";
     if_verbose message ("Module "^ string_of_id id ^" is declared");
     Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
 
-let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = 
+let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
   (* We check the state of the system (in section, in module type)
      and what module information is supplied *)
   if Lib.sections_are_opened () then
     error "Modules and Module Types are not allowed inside sections.";
-  match mexpr_ast_o with
-    | None ->
+  match mexpr_ast_l with
+    | [] ->
        check_no_pending_proofs ();
        let binders_ast,argsexport =
         List.fold_right
@@ -483,17 +484,17 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o =
            (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
              ([],[]) in
        let mp = Declaremods.start_module Modintern.interp_modtype export
-	 id binders_ast mty_ast_o 
+	 id binders_ast mty_ast_o
        in
 	 Dumpglob.dump_moddef loc mp "mod";
-	 if_verbose message 
+	 if_verbose message
 	   ("Interactive Module "^ string_of_id id ^" started") ;
          List.iter
            (fun (export,id) ->
              Option.iter
                (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
            ) argsexport
-    | Some _ ->
+    | _::_ ->
        let binders_ast = List.map
         (fun (export,idl,ty) ->
           if export <> None then
@@ -501,46 +502,48 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o =
                   " the definition is interactive. Remove the \"Export\" and " ^
                   "\"Import\" keywords from every functor argument.")
           else (idl,ty)) binders_ast in
-       let mp =	Declaremods.declare_module 
+       let mp =	Declaremods.declare_module
 	  Modintern.interp_modtype Modintern.interp_modexpr
-	  id binders_ast mty_ast_o mexpr_ast_o 
+          Modintern.interp_modexpr_or_modtype
+	  id binders_ast mty_ast_o mexpr_ast_l
        in
 	 Dumpglob.dump_moddef loc mp "mod";
-	 if_verbose message 
+	 if_verbose message
 	   ("Module "^ string_of_id id ^" is defined");
          Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)])
            export
 
-let vernac_end_module export (loc,id) =
-  let mp = Declaremods.end_module id in
-    Dumpglob.dump_modref loc mp "mod";
-    if_verbose message ("Module "^ string_of_id id ^" is defined") ;
-    Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
-
+let vernac_end_module export (loc,id as lid) =
+  let mp = Declaremods.end_module () in
+  Dumpglob.dump_modref loc mp "mod";
+  if_verbose message ("Module "^ string_of_id id ^" is defined") ;
+  Option.iter (fun export -> vernac_import export [Ident lid]) export
 
-let vernac_declare_module_type (loc,id) binders_ast mty_ast_o =
+let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
   if Lib.sections_are_opened () then
     error "Modules and Module Types are not allowed inside sections.";
-  
-  match mty_ast_o with
-    | None ->
+
+  match mty_ast_l with
+    | [] ->
        check_no_pending_proofs ();
-       let binders_ast,argsexport =
-        List.fold_right
+       let binders_ast,argsexport =       
+	 List.fold_right
          (fun (export,idl,ty) (args,argsexport) ->
-           (idl,ty)::args, List.map (fun (_,i) -> export,i) idl) binders_ast
+           (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
              ([],[]) in
-       let mp = Declaremods.start_modtype Modintern.interp_modtype id binders_ast in
+       
+       let mp = Declaremods.start_modtype
+	 Modintern.interp_modtype id binders_ast mty_sign in
         Dumpglob.dump_moddef loc mp "modtype";
-	if_verbose message 
+	if_verbose message
 	  ("Interactive Module Type "^ string_of_id id ^" started");
         List.iter
          (fun (export,id) ->
            Option.iter
             (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
          ) argsexport
-	  
-    | Some base_mty ->
+
+    | _ :: _ ->
 	let binders_ast = List.map
           (fun (export,idl,ty) ->
             if export <> None then
@@ -548,70 +551,66 @@ let vernac_declare_module_type (loc,id) binders_ast mty_ast_o =
 			" the definition is interactive. Remove the \"Export\" " ^
 			"and \"Import\" keywords from every functor argument.")
             else (idl,ty)) binders_ast in
-	let mp = Declaremods.declare_modtype Modintern.interp_modtype 
-	  id binders_ast base_mty in
+	let mp = Declaremods.declare_modtype Modintern.interp_modtype
+          Modintern.interp_modexpr_or_modtype
+	  id binders_ast mty_sign mty_ast_l in
           Dumpglob.dump_moddef loc mp "modtype";
-	  if_verbose message 
+	  if_verbose message
 	    ("Module Type "^ string_of_id id ^" is defined")
 
-
 let vernac_end_modtype (loc,id) =
-  let mp = Declaremods.end_modtype id in
-    Dumpglob.dump_modref loc mp "modtype";
-    if_verbose message 
-      ("Module Type "^ string_of_id id ^" is defined")
-
-let vernac_include = function
-  | CIMTE mty_ast ->
-      Declaremods.declare_include Modintern.interp_modtype mty_ast false
-  | CIME mexpr_ast ->
-      Declaremods.declare_include Modintern.interp_modexpr mexpr_ast true
-	  
-	  
-	  
+  let mp = Declaremods.end_modtype () in
+  Dumpglob.dump_modref loc mp "modtype";
+  if_verbose message ("Module Type "^ string_of_id id ^" is defined")
+
+let vernac_include l =
+  Declaremods.declare_include Modintern.interp_modexpr_or_modtype l
+
 (**********************)
 (* Gallina extensions *)
 
-  (* Sections *)
+(* Sections *)
 
 let vernac_begin_section (_, id as lid) =
   check_no_pending_proofs ();
   Dumpglob.dump_definition lid true "sec";
   Lib.open_section id
 
-let vernac_end_section (loc, id) = 
-  
-    Dumpglob.dump_reference loc 
-      (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec";
-  Lib.close_section id
+let vernac_end_section (loc,_) =
+  Dumpglob.dump_reference loc
+    (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec";
+  Lib.close_section ()
 
-let vernac_end_segment lid =
+(* Dispatcher of the "End" command *)
+
+let vernac_end_segment (_,id as lid) =
   check_no_pending_proofs ();
-  let o = try Lib.what_is_opened () with 
-      Not_found -> error "There is nothing to end." in
-    match o with
-      | _,Lib.OpenedModule (export,_,_) -> vernac_end_module export lid
-      | _,Lib.OpenedModtype _ -> vernac_end_modtype lid
-      | _,Lib.OpenedSection _ -> vernac_end_section lid
-      | _ -> anomaly "No more opened things"
+  match Lib.find_opening_node id with
+  | Lib.OpenedModule (export,_,_) -> vernac_end_module export lid
+  | Lib.OpenedModtype _ -> vernac_end_modtype lid
+  | Lib.OpenedSection _ -> vernac_end_section lid
+  | _ -> anomaly "No more opened things"
+
+(* Libraries *)
 
 let vernac_require import _ qidl =
   let qidl = List.map qualid_of_reference qidl in
-  if Dumpglob.dump () then begin
-    let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in
-    List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl)
-  end;
-  Library.require_library qidl import
+  let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in
+  if Dumpglob.dump () then
+    List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl);
+  Library.require_library_from_dirpath modrefl import
+
+(* Coercions and canonical structures *)
 
 let vernac_canonical r =
-  Recordops.declare_canonical_structure (global_with_alias r)
+  Recordops.declare_canonical_structure (smart_global r)
 
 let vernac_coercion stre ref qids qidt =
   let target = cl_of_qualid qidt in
   let source = cl_of_qualid qids in
-  let ref' = global_with_alias ref in
+  let ref' = smart_global ref in
   Class.try_add_new_coercion_with_target ref' stre source target;
-  if_verbose message ((string_of_reference ref) ^ " is now a coercion")
+  if_verbose msgnl (pr_global ref' ++ str " is now a coercion")
 
 let vernac_identity_coercion stre id qids qidt =
   let target = cl_of_qualid qidt in
@@ -619,18 +618,20 @@ let vernac_identity_coercion stre id qids qidt =
   Class.try_add_new_identity_coercion id stre source target
 
 (* Type classes *)
- 
-let vernac_instance glob sup inst props pri =
+
+let vernac_instance abst glob sup inst props pri =
   Dumpglob.dump_constraint inst false "inst";
-  ignore(Classes.new_instance ~global:glob sup inst props pri)
+  ignore(Classes.new_instance ~abstract:abst ~global:glob sup inst props pri)
 
 let vernac_context l =
   List.iter (fun x -> Dumpglob.dump_local_binder x true "var") l;
   Classes.context l
 
-let vernac_declare_instance id =
-  Dumpglob.dump_definition id false "inst";
-  Classes.declare_instance false id
+let vernac_declare_instance glob id =
+  Classes.declare_instance glob id
+
+let vernac_declare_class id =
+  Classes.declare_class id
 
 (***********)
 (* Solving *)
@@ -639,12 +640,12 @@ let vernac_solve n tcom b =
     error "Unknown command of the non proof-editing mode.";
   Decl_mode.check_not_proof_mode "Unknown proof instruction";
   begin
-    if b then 
+    if b then
       solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ()))
     else solve_nth n (Tacinterp.hide_interp tcom None)
   end;
-  (* in case a strict subtree was completed, 
-     go back to the top of the prooftree *) 
+  (* in case a strict subtree was completed,
+     go back to the top of the prooftree *)
   if subtree_solved () then begin
     Flags.if_verbose msgnl (str "Subgoal proved");
     make_focus 0;
@@ -656,9 +657,9 @@ let vernac_solve n tcom b =
   (* 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
-     there are no more goals to solve. It cannot be a tactic since 
+     there are no more goals to solve. It cannot be a tactic since
      all tactics fail if there are no further goals to prove. *)
-  
+
 let vernac_solve_existential = instantiate_nth_evar_com
 
 let vernac_set_end_tac tac =
@@ -670,9 +671,9 @@ let vernac_set_end_tac tac =
 (***********************)
 (* Proof Language Mode *)
 
-let vernac_decl_proof () = 
+let vernac_decl_proof () =
   check_not_proof_mode "Already in Proof Mode";
-  if tree_solved () then 
+  if tree_solved () then
     error "Nothing left to prove here."
   else
     begin
@@ -680,17 +681,17 @@ let vernac_decl_proof () =
       print_subgoals ()
     end
 
-let vernac_return () = 
+let vernac_return () =
   match get_current_mode () with
       Mode_tactic ->
 	Decl_proof_instr.return_from_tactic_mode ();
 	print_subgoals ()
-    | Mode_proof -> 
+    | Mode_proof ->
 	error "\"return\" is only used after \"escape\"."
-    | Mode_none -> 
-	error "There is no proof to end." 
+    | Mode_none ->
+	error "There is no proof to end."
 
-let vernac_proof_instr instr = 
+let vernac_proof_instr instr =
   Decl_proof_instr.proof_instr instr;
   print_subgoals ()
 
@@ -718,8 +719,8 @@ let vernac_add_ml_path isrec path =
   (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir)
     (System.expand_path_macros path)
 
-let vernac_declare_ml_module l =
-  Mltop.declare_ml_modules (List.map System.expand_path_macros l)
+let vernac_declare_ml_module local l =
+  Mltop.declare_ml_modules local (List.map System.expand_path_macros l)
 
 let vernac_chdir = function
   | None -> message (Sys.getcwd())
@@ -759,71 +760,77 @@ let vernac_backto n = Lib.reset_label n
 (************)
 (* Commands *)
 
-let vernac_declare_tactic_definition = Tacinterp.add_tacdef
+let vernac_declare_tactic_definition (local,x,def) =
+  Tacinterp.add_tacdef local x def
 
-let vernac_create_hintdb local id b = 
+let vernac_create_hintdb local id b =
   Auto.create_hint_db local id full_transparent_state b
 
-let vernac_hints = Auto.add_hints
+let vernac_hints local lb h =
+  Auto.add_hints local lb (Auto.interp_hints h)
 
 let vernac_syntactic_definition lid =
   Dumpglob.dump_definition lid false "syndef";
-  Command.syntax_definition (snd lid)
-  
+  Metasyntax.add_syntactic_definition (snd lid)
+
 let vernac_declare_implicits local r = function
   | Some imps ->
-      Impargs.declare_manual_implicits local (global_with_alias r) ~enriching:false
-	(List.map (fun (ex,b,f) -> ex, (b,f)) imps)
-  | None -> 
-      Impargs.declare_implicits local (global_with_alias r)
+      Impargs.declare_manual_implicits local (smart_global r) ~enriching:false
+	(List.map (fun (ex,b,f) -> ex, (b,true,f)) imps)
+  | None ->
+      Impargs.declare_implicits local (smart_global r)
 
-let vernac_reserve idl c =
-  let t = Constrintern.interp_type Evd.empty (Global.env()) c in
-  let t = Detyping.detype false [] [] t in
-  List.iter (fun id -> Reserve.declare_reserved_type id t) idl
+let vernac_reserve bl =
+  let sb_decl = (fun (idl,c) ->
+    let t = Constrintern.interp_type Evd.empty (Global.env()) c in
+      let t = Detyping.detype false [] [] t in
+        List.iter (fun id -> Reserve.declare_reserved_type id t) idl)
+  in List.iter sb_decl bl
+
+let vernac_generalizable = Implicit_quantifiers.declare_generalizable
 
 let make_silent_if_not_pcoq b =
-  if !pcoq <> None then 
+  if !pcoq <> None then
     error "Turning on/off silent flag is not supported in Pcoq mode."
   else make_silent b
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = false;
       optname  = "silent";
-      optkey   = (PrimaryTable "Silent");
+      optkey   = ["Silent"];
       optread  = is_silent;
       optwrite = make_silent_if_not_pcoq }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "implicit arguments";
-      optkey   = (SecondaryTable ("Implicit","Arguments"));
+      optkey   = ["Implicit";"Arguments"];
       optread  = Impargs.is_implicit_args;
       optwrite = Impargs.make_implicit_args }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "strict implicit arguments";
-      optkey   = (SecondaryTable ("Strict","Implicit"));
+      optkey   = ["Strict";"Implicit"];
       optread  = Impargs.is_strict_implicit_args;
       optwrite = Impargs.make_strict_implicit_args }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "strong strict implicit arguments";
-      optkey   = (TertiaryTable ("Strongly","Strict","Implicit"));
+      optkey   = ["Strongly";"Strict";"Implicit"];
       optread  = Impargs.is_strongly_strict_implicit_args;
       optwrite = Impargs.make_strongly_strict_implicit_args }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "contextual implicit arguments";
-      optkey   = (SecondaryTable ("Contextual","Implicit"));
+      optkey   = ["Contextual";"Implicit"];
       optread  = Impargs.is_contextual_implicit_args;
       optwrite = Impargs.make_contextual_implicit_args }
 
@@ -831,159 +838,167 @@ let _ =
 (*   declare_bool_option  *)
 (*     { optsync  = true; *)
 (*       optname  = "forceable implicit arguments"; *)
-(*       optkey   = (SecondaryTable ("Forceable","Implicit")); *)
+(*       optkey   = ["Forceable";"Implicit")); *)
 (*       optread  = Impargs.is_forceable_implicit_args; *)
 (*       optwrite = Impargs.make_forceable_implicit_args } *)
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "implicit status of reversible patterns";
-      optkey   = (TertiaryTable ("Reversible","Pattern","Implicit"));
+      optkey   = ["Reversible";"Pattern";"Implicit"];
       optread  = Impargs.is_reversible_pattern_implicit_args;
       optwrite = Impargs.make_reversible_pattern_implicit_args }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "maximal insertion of implicit";
-      optkey   = (TertiaryTable ("Maximal","Implicit","Insertion"));
+      optkey   = ["Maximal";"Implicit";"Insertion"];
       optread  = Impargs.is_maximal_implicit_args;
       optwrite = Impargs.make_maximal_implicit_args }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
+    { optsync  = true;
+      optname  = "automatic introduction of variables";
+      optkey   = ["Automatic";"Introduction"];
+      optread  = Flags.is_auto_intros;
+      optwrite = make_auto_intros }
+
+let _ =
+  declare_bool_option
     { optsync  = true;
       optname  = "coercion printing";
-      optkey   = (SecondaryTable ("Printing","Coercions"));
+      optkey   = ["Printing";"Coercions"];
       optread  = (fun () -> !Constrextern.print_coercions);
       optwrite = (fun b ->  Constrextern.print_coercions := b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "printing of existential variable instances";
-      optkey   = (TertiaryTable ("Printing","Existential","Instances"));
+      optkey   = ["Printing";"Existential";"Instances"];
       optread  = (fun () -> !Constrextern.print_evar_arguments);
       optwrite = (:=) Constrextern.print_evar_arguments }
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "implicit arguments printing";
-      optkey   = (SecondaryTable ("Printing","Implicit"));
+      optkey   = ["Printing";"Implicit"];
       optread  = (fun () -> !Constrextern.print_implicits);
       optwrite = (fun b ->  Constrextern.print_implicits := b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "implicit arguments defensive printing";
-      optkey   = (TertiaryTable ("Printing","Implicit","Defensive"));
+      optkey   = ["Printing";"Implicit";"Defensive"];
       optread  = (fun () -> !Constrextern.print_implicits_defensive);
       optwrite = (fun b ->  Constrextern.print_implicits_defensive := b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "projection printing using dot notation";
-      optkey   = (SecondaryTable ("Printing","Projections"));
+      optkey   = ["Printing";"Projections"];
       optread  = (fun () -> !Constrextern.print_projections);
       optwrite = (fun b ->  Constrextern.print_projections := b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "notations printing";
-      optkey   = (SecondaryTable ("Printing","Notations"));
+      optkey   = ["Printing";"Notations"];
       optread  = (fun () -> not !Constrextern.print_no_symbol);
       optwrite = (fun b ->  Constrextern.print_no_symbol := not b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "raw printing";
-      optkey   = (SecondaryTable ("Printing","All"));
+      optkey   = ["Printing";"All"];
       optread  = (fun () -> !Flags.raw_print);
       optwrite = (fun b -> Flags.raw_print := b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "use of virtual machine inside the kernel";
-      optkey   = (SecondaryTable ("Virtual","Machine"));
+      optkey   = ["Virtual";"Machine"];
       optread  = (fun () -> Vconv.use_vm ());
       optwrite = (fun b -> Vconv.set_use_vm b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "use of boxed definitions";
-      optkey   = (SecondaryTable ("Boxed","Definitions"));
+      optkey   = ["Boxed";"Definitions"];
       optread  = Flags.boxed_definitions;
-      optwrite = (fun b -> Flags.set_boxed_definitions b) } 
+      optwrite = (fun b -> Flags.set_boxed_definitions b) }
 
 let _ =
-  declare_bool_option 
+  declare_bool_option
     { optsync  = true;
       optname  = "use of boxed values";
-      optkey   = (SecondaryTable ("Boxed","Values"));
+      optkey   = ["Boxed";"Values"];
       optread  = (fun _ -> not (Vm.transp_values ()));
-      optwrite = (fun b -> Vm.set_transp_values (not b)) } 
+      optwrite = (fun b -> Vm.set_transp_values (not b)) }
 
 let _ =
   declare_int_option
-    { optsync=false;
-      optkey=PrimaryTable("Undo");
-      optname="the undo limit";
-      optread=Pfedit.get_undo;
-      optwrite=Pfedit.set_undo }
+    { optsync  = false;
+      optname  = "the undo limit";
+      optkey   = ["Undo"];
+      optread  = Pfedit.get_undo;
+      optwrite = Pfedit.set_undo }
 
 let _ =
   declare_int_option
-    { optsync=false;
-      optkey=SecondaryTable("Hyps","Limit");
-      optname="the hypotheses limit";
-      optread=Flags.print_hyps_limit;
-      optwrite=Flags.set_print_hyps_limit }
+    { optsync  = false;
+      optname  = "the hypotheses limit";
+      optkey   = ["Hyps";"Limit"];
+      optread  = Flags.print_hyps_limit;
+      optwrite = Flags.set_print_hyps_limit }
 
 let _ =
   declare_int_option
-    { optsync=true;
-      optkey=SecondaryTable("Printing","Depth");
-      optname="the printing depth";
-      optread=Pp_control.get_depth_boxes;
-      optwrite=Pp_control.set_depth_boxes }
+    { optsync  = true;
+      optname  = "the printing depth";
+      optkey   = ["Printing";"Depth"];
+      optread  = Pp_control.get_depth_boxes;
+      optwrite = Pp_control.set_depth_boxes }
 
 let _ =
   declare_int_option
-    { optsync=true;
-      optkey=SecondaryTable("Printing","Width");
-      optname="the printing width";
-      optread=Pp_control.get_margin;
-      optwrite=Pp_control.set_margin }
+    { optsync  = true;
+      optname  = "the printing width";
+      optkey   = ["Printing";"Width"];
+      optread  = Pp_control.get_margin;
+      optwrite = Pp_control.set_margin }
 
 let _ =
   declare_bool_option
-    { optsync=true;
-      optkey=SecondaryTable("Printing","Universes");
-      optname="printing of universes";
-      optread=(fun () -> !Constrextern.print_universes);
-      optwrite=(fun b -> Constrextern.print_universes:=b) }
+    { optsync  = true;
+      optname  = "printing of universes";
+      optkey   = ["Printing";"Universes"];
+      optread  = (fun () -> !Constrextern.print_universes);
+      optwrite = (fun b -> Constrextern.print_universes:=b) }
 
 let vernac_debug b =
   set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
 
 let _ =
   declare_bool_option
-    { optsync=false;
-      optkey=SecondaryTable("Ltac","Debug");
-      optname="Ltac debug";
-      optread=(fun () -> get_debug () <> Tactic_debug.DebugOff);
-      optwrite=vernac_debug }
+    { optsync  = false;
+      optname  = "Ltac debug";
+      optkey   = ["Ltac";"Debug"];
+      optread  = (fun () -> get_debug () <> Tactic_debug.DebugOff);
+      optwrite = vernac_debug }
 
 let vernac_set_opacity local str =
   let glob_ref r =
-    match global_with_alias r with
+    match smart_global r with
       | ConstRef sp -> EvalConstRef sp
       | VarRef id -> EvalVarRef id
       | _ -> error
@@ -991,15 +1006,15 @@ let vernac_set_opacity local str =
   let str = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) str in
   Redexpr.set_strategy local str
 
-let vernac_set_option key = function
-  | StringValue s -> set_string_option_value key s
-  | IntValue n -> set_int_option_value key (Some n)
-  | BoolValue b -> set_bool_option_value key b
+let vernac_set_option locality key = function
+  | StringValue s -> set_string_option_value_gen locality key s
+  | IntValue n -> set_int_option_value_gen locality key (Some n)
+  | BoolValue b -> set_bool_option_value_gen locality key b
 
-let vernac_unset_option key =
-  try set_bool_option_value key false
+let vernac_unset_option locality key =
+  try set_bool_option_value_gen locality key false
   with _ ->
-  set_int_option_value key None
+  set_int_option_value_gen locality key None
 
 let vernac_add_option key lv =
   let f = function
@@ -1048,6 +1063,9 @@ let vernac_check_may_eval redexp glopt rc =
 	then (Option.get !pcoq).print_eval redfun env evmap rc j
 	else msg (print_eval redfun env evmap rc j)
 
+let vernac_declare_reduction locality s r =
+  declare_red_expr locality s (interp_redexp (Global.env()) Evd.empty r)
+
   (* The same but avoiding the current goal context if any *)
 let vernac_global_check c =
   let evmap = Evd.empty in
@@ -1069,14 +1087,13 @@ let vernac_print = function
   | PrintModuleType qid -> print_modtype qid
   | PrintMLLoadPath -> Mltop.print_ml_path ()
   | PrintMLModules -> Mltop.print_ml_modules ()
-  | PrintName qid -> 
+  | PrintName qid ->
       if !pcoq <> None then (Option.get !pcoq).print_name qid
       else msg (print_name qid)
-  | PrintOpaqueName qid -> msg (print_opaque_name qid)
   | PrintGraph -> ppnl (Prettyp.print_graph())
   | PrintClasses -> ppnl (Prettyp.print_classes())
   | PrintTypeClasses -> ppnl (Prettyp.print_typeclasses())
-  | PrintInstances c -> ppnl (Prettyp.print_instances (global c))
+  | PrintInstances c -> ppnl (Prettyp.print_instances (smart_global c))
   | PrintLtac qid -> ppnl (Tacinterp.print_ltac (snd (qualid_of_reference qid)))
   | PrintCoercions -> ppnl (Prettyp.print_coercions())
   | PrintCoercionPaths (cls,clt) ->
@@ -1084,7 +1101,7 @@ let vernac_print = function
   | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ())
   | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ()))
   | PrintUniverses (Some s) -> dump_universes s
-  | PrintHint r -> Auto.print_hint_ref (global_with_alias r)
+  | PrintHint r -> Auto.print_hint_ref (smart_global r)
   | PrintHintGoal -> Auto.print_applicable_hint ()
   | PrintHintDbName s -> Auto.print_hint_db_by_name s
   | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s
@@ -1099,7 +1116,7 @@ let vernac_print = function
   | PrintImplicit qid -> msg (print_impargs qid)
 (*spiwack: prints all the axioms and section variables used by a term *)
   | PrintAssumptions (o,r) ->
-      let cstr = constr_of_global (global_with_alias r) in
+      let cstr = constr_of_global (smart_global r) in
       let nassumptions = Environ.assumptions (Conv_oracle.get_transp_state ())
 	~add_opaque:o cstr (Global.env ()) in
       msg (Printer.pr_assumptionset (Global.env ()) nassumptions)
@@ -1107,7 +1124,7 @@ let vernac_print = function
 let global_module r =
   let (loc,qid) = qualid_of_reference r in
   try Nametab.full_name_module qid
-  with Not_found -> 
+  with Not_found ->
     user_err_loc (loc, "global_module",
       str "Module/section " ++ pr_qualid qid ++ str " not found.")
 
@@ -1126,12 +1143,12 @@ let interp_search_about_item = function
   | SearchString (s,None) when is_ident s ->
       GlobSearchString s
   | SearchString (s,sc) ->
-      try 
+      try
 	let ref =
 	  Notation.interp_notation_as_global_reference dummy_loc
 	    (fun _ -> true) s sc in
 	GlobSearchSubPattern (Pattern.PRef ref)
-      with UserError _ -> 
+      with UserError _ ->
 	error ("Unable to interp \""^s^"\" either as a reference or
           	as an identifier component")
 
@@ -1140,24 +1157,27 @@ let vernac_search s r =
   if !pcoq <> None then (Option.get !pcoq).search s r else
   match s with
   | SearchPattern c ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in
-      Search.search_pattern pat r
+      let (_,c) = interp_open_constr_patvar Evd.empty (Global.env()) c in
+      Search.search_pattern c r
   | SearchRewrite c ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in
+      let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in
       Search.search_rewrite pat r
-  | SearchHead ref ->
-      Search.search_by_head (global_with_alias ref) r
+  | SearchHead c ->
+      let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in
+      Search.search_by_head pat r
   | SearchAbout sl ->
       Search.search_about (List.map (on_snd interp_search_about_item) sl) r
 
 let vernac_locate = function
-  | LocateTerm qid -> msgnl (print_located_qualid qid)
+  | LocateTerm (Genarg.AN qid) -> msgnl (print_located_qualid qid)
+  | LocateTerm (Genarg.ByNotation (_,ntn,sc)) ->
+      ppnl
+        (Notation.locate_notation
+          (Constrextern.without_symbols pr_lrawconstr) ntn sc)
   | LocateLibrary qid -> print_located_library qid
   | LocateModule qid -> print_located_module qid
+  | LocateTactic qid -> print_located_tactic qid
   | LocateFile f -> locate_file f
-  | LocateNotation ntn ->
-      ppnl (Notation.locate_notation (Constrextern.without_symbols pr_lrawconstr)
-	(Metasyntax.standardize_locatable_notation ntn))
 
 (********************)
 (* Proof management *)
@@ -1169,7 +1189,7 @@ let vernac_goal = function
         let unnamed_kind = Lemma (* Arbitrary *) in
         start_proof_com (Global, Proof unnamed_kind) [None,c] (fun _ _ ->());
 	print_subgoals ()
-      end else 
+      end else
 	error "repeated Goal not permitted in refining mode."
 
 let vernac_abort = function
@@ -1214,14 +1234,14 @@ let vernac_backtrack snum pnum naborts =
   Pp.flush_all();
   (* there may be no proof in progress, even if no abort *)
   (try print_subgoals () with UserError _ -> ())
-  
+
 
 let vernac_focus gln =
   check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
-  match gln with 
+  match gln with
     | None -> traverse_nth_goal 1; print_subgoals ()
     | Some n -> traverse_nth_goal n; print_subgoals ()
-	
+
   (* Reset the focus to the top of the tree *)
 let vernac_unfocus () =
   check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
@@ -1238,7 +1258,7 @@ let apply_subproof f occ =
   let evc = evc_of_pftreestate pts in
   let rec aux pts = function
     | [] -> pts
-    | (n::l) -> aux (Tacmach.traverse n pts) occ in 
+    | (n::l) -> aux (Tacmach.traverse n pts) occ in
   let pts = aux pts (occ@[-1]) in
   let pf = proof_of_pftreestate pts in
   f evc (Global.named_context()) pf
@@ -1277,19 +1297,20 @@ let vernac_check_guard () =
   let pts = get_pftreestate () in
   let pf = proof_of_pftreestate pts in
   let (pfterm,_) = extract_open_pftreestate pts in
-  let message = 
-    try 
+  let message =
+    try
       Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf))
-	pfterm; 
+	pfterm;
       (str "The condition holds up to here")
-    with UserError(_,s) -> 
+    with UserError(_,s) ->
       (str ("Condition violated: ") ++s)
-  in 
+  in
   msgnl message
 
 let interp c = match c with
   (* Control (done in vernac) *)
-  | (VernacTime _ | VernacList _ | VernacLoad _) -> assert false
+  | (VernacTime _|VernacList _|VernacLoad _|VernacTimeout _|VernacFail _) ->
+      assert false
 
   (* Syntax *)
   | VernacTacticNotation (n,r,e) -> Metasyntax.add_tactic_notation (n,r,e)
@@ -1307,21 +1328,21 @@ let interp c = match c with
   | VernacEndProof e -> vernac_end_proof e
   | VernacExactProof c -> vernac_exact_proof c
   | VernacAssumption (stre,nl,l) -> vernac_assumption stre l nl
-  | VernacInductive (finite,l) -> vernac_inductive finite l
+  | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l
   | VernacFixpoint (l,b) -> vernac_fixpoint l b
   | VernacCoFixpoint (l,b) -> vernac_cofixpoint l b
   | VernacScheme l -> vernac_scheme l
   | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l
 
   (* Modules *)
-  | VernacDeclareModule (export,lid,bl,mtyo) -> 
+  | VernacDeclareModule (export,lid,bl,mtyo) ->
       vernac_declare_module export lid bl mtyo
-  | VernacDefineModule (export,lid,bl,mtyo,mexpro) -> 
-      vernac_define_module export lid bl mtyo mexpro
-  | VernacDeclareModuleType (lid,bl,mtyo) -> 
-      vernac_declare_module_type lid bl mtyo
-  | VernacInclude (in_ast) ->
-      vernac_include in_ast
+  | VernacDefineModule (export,lid,bl,mtys,mexprl) ->
+      vernac_define_module export lid bl mtys mexprl
+  | VernacDeclareModuleType (lid,bl,mtys,mtyo) ->
+      vernac_declare_module_type lid bl mtys mtyo
+  | VernacInclude in_asts ->
+      vernac_include in_asts
   (* Gallina extensions *)
   | VernacBeginSection lid -> vernac_begin_section lid
 
@@ -1334,9 +1355,11 @@ let interp c = match c with
   | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t
 
   (* Type classes *)
-  | VernacInstance (glob, sup, inst, props, pri) -> vernac_instance glob sup inst props pri
+  | VernacInstance (abst, glob, sup, inst, props, pri) ->
+      vernac_instance abst glob sup inst props pri
   | VernacContext sup -> vernac_context sup
-  | VernacDeclareInstance id -> vernac_declare_instance id
+  | VernacDeclareInstance (glob, id) -> vernac_declare_instance glob id
+  | VernacDeclareClass id -> vernac_declare_class id
 
   (* Solving *)
   | VernacSolve (n,tac,b) -> vernac_solve n tac b
@@ -1346,7 +1369,7 @@ let interp c = match c with
 
   | VernacDeclProof -> vernac_decl_proof ()
   | VernacReturn -> vernac_return ()
-  | VernacProofInstr stp -> vernac_proof_instr stp 
+  | VernacProofInstr stp -> vernac_proof_instr stp
 
   (* /MMode *)
 
@@ -1355,7 +1378,7 @@ let interp c = match c with
   | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
   | VernacRemoveLoadPath s -> vernac_remove_loadpath s
   | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s
-  | VernacDeclareMLModule l -> vernac_declare_ml_module l
+  | VernacDeclareMLModule (local, l) -> vernac_declare_ml_module local l
   | VernacChdir s -> vernac_chdir s
 
   (* State management *)
@@ -1370,20 +1393,22 @@ let interp c = match c with
   | VernacBackTo n -> vernac_backto n
 
   (* Commands *)
-  | VernacDeclareTacticDefinition (x,l) -> vernac_declare_tactic_definition x l
+  | VernacDeclareTacticDefinition def -> vernac_declare_tactic_definition def
   | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b
   | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints
   | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b
   | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l
-  | VernacReserve (idl,c) -> vernac_reserve idl c
+  | VernacReserve bl -> vernac_reserve bl
+  | VernacGeneralizable (local,gen) -> vernac_generalizable local gen
   | VernacSetOpacity (local,qidl) -> vernac_set_opacity local qidl
-  | VernacSetOption (key,v) -> vernac_set_option key v
-  | VernacUnsetOption key -> vernac_unset_option key
+  | VernacSetOption (locality,key,v) -> vernac_set_option locality key v
+  | VernacUnsetOption (locality,key) -> vernac_unset_option locality key
   | VernacRemoveOption (key,v) -> vernac_remove_option key v
   | VernacAddOption (key,v) -> vernac_add_option key v
   | VernacMemOption (key,v) -> vernac_mem_option key v
   | VernacPrintOption key -> vernac_print_option key
   | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c
+  | VernacDeclareReduction (b,s,r) -> vernac_declare_reduction b s r
   | VernacGlobalCheck c -> vernac_global_check c
   | VernacPrint p -> vernac_print p
   | VernacSearch (s,r) -> vernac_search s r
@@ -1392,7 +1417,7 @@ let interp c = match c with
   | VernacNop -> ()
 
   (* Proof management *)
-  | VernacGoal t -> vernac_start_proof Theorem [None,([],t)] false (fun _ _->())
+  | VernacGoal t -> vernac_start_proof Theorem [None,([],t,None)] false (fun _ _->())
   | VernacAbort id -> vernac_abort id
   | VernacAbortAll -> vernac_abort_all ()
   | VernacRestart -> vernac_restart ()
@@ -1412,3 +1437,6 @@ let interp c = match c with
 
   (* Extensions *)
   | VernacExtend (opn,args) -> Vernacinterp.call (opn,args)
+
+let interp c = interp c ; check_locality ()
+
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
index 8afb783b..44e8b7ab 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacentries.mli 10580 2008-02-22 13:39:13Z lmamane $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Names
@@ -38,7 +38,7 @@ type pcoq_hook = {
   solve : int -> unit;
   abort : string -> unit;
   search : searchable -> dir_path list * bool -> unit;
-  print_name : Libnames.reference -> unit;
+  print_name : Libnames.reference Genarg.or_by_notation -> unit;
   print_check : Environ.env -> Environ.unsafe_judgment -> unit;
   print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr ->
     Environ.unsafe_judgment -> unit;
@@ -54,4 +54,4 @@ val abort_refine : ('a -> unit) -> 'a -> unit;;
 
 val interp : Vernacexpr.vernac_expr -> unit
 
-val vernac_reset_name : identifier Util.located -> unit 
+val vernac_reset_name : identifier Util.located -> unit
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
index 4da16ea7..4a2a218b 100644
--- a/toplevel/vernacexpr.ml
+++ b/toplevel/vernacexpr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacexpr.ml 12187 2009-06-13 19:36:59Z msozeau $ i*)
+(*i $Id$ i*)
 
 open Util
 open Names
@@ -18,7 +18,6 @@ open Decl_kinds
 open Ppextend
 
 (* Toplevel control exceptions *)
-exception ProtectedLoop
 exception Drop
 exception Quit
 
@@ -27,11 +26,11 @@ open Nametab
 
 type lident = identifier located
 type lname = name located
-type lstring = string
+type lstring = string located
 type lreference = reference
 
-type class_rawexpr = FunClass | SortClass | RefClass of reference
-  
+type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation
+
 type printable =
   | PrintTables
   | PrintFullContext
@@ -44,18 +43,17 @@ type printable =
   | PrintModuleType of reference
   | PrintMLLoadPath
   | PrintMLModules
-  | PrintName of reference
-  | PrintOpaqueName of reference
+  | PrintName of reference or_by_notation
   | PrintGraph
   | PrintClasses
   | PrintTypeClasses
-  | PrintInstances of reference
+  | PrintInstances of reference or_by_notation
   | PrintLtac of reference
   | PrintCoercions
   | PrintCoercionPaths of class_rawexpr * class_rawexpr
   | PrintCanonicalConversions
   | PrintUniverses of string option
-  | PrintHint of reference
+  | PrintHint of reference or_by_notation
   | PrintHintGoal
   | PrintHintDbName of string
   | PrintRewriteHintDbName of string
@@ -63,9 +61,9 @@ type printable =
   | PrintScopes
   | PrintScope of string
   | PrintVisibility of string option
-  | PrintAbout of reference
-  | PrintImplicit of reference
-  | PrintAssumptions of bool * reference
+  | PrintAbout of reference or_by_notation
+  | PrintImplicit of reference or_by_notation
+  | PrintAssumptions of bool * reference or_by_notation
 
 type search_about_item =
   | SearchSubPattern of constr_pattern_expr
@@ -74,15 +72,15 @@ type search_about_item =
 type searchable =
   | SearchPattern of constr_pattern_expr
   | SearchRewrite of constr_pattern_expr
-  | SearchHead of reference
+  | SearchHead of constr_pattern_expr
   | SearchAbout of (bool * search_about_item) list
 
 type locatable =
-  | LocateTerm of reference
+  | LocateTerm of reference or_by_notation
   | LocateLibrary of reference
   | LocateModule of reference
+  | LocateTactic of reference
   | LocateFile of string
-  | LocateNotation of notation
 
 type goable =
   | GoTo of int
@@ -110,7 +108,7 @@ type comment =
   | CommentString of string
   | CommentInt of int
 
-type hints =
+type hints_expr =
   | HintsResolve of (int option * bool * constr_expr) list
   | HintsImmediate of constr_expr list
   | HintsUnfold of reference list
@@ -124,15 +122,6 @@ type search_restriction =
   | SearchInside of reference list
   | SearchOutside of reference list
 
-type option_value =
-  | StringValue of string
-  | IntValue of int
-  | BoolValue of bool
-
-type option_ref_value =
-  | StringRefValue of string
-  | QualidRefValue of reference
-
 type rec_flag       = bool (* true = Rec;           false = NoRec          *)
 type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
 type opacity_flag   = bool (* true = Opaque;        false = Transparent    *)
@@ -142,6 +131,17 @@ type export_flag    = bool (* true = Export;        false = Import         *)
 type specif_flag    = bool (* true = Specification; false = Implementation *)
 type inductive_flag = Decl_kinds.recursivity_kind
 type onlyparsing_flag = bool (* true = Parse only;  false = Print also     *)
+type infer_flag     = bool (* true = try to Infer record; false = nothing  *)
+type full_locality_flag = bool option (* true = Local; false = Global      *)
+
+type option_value =
+  | StringValue of string
+  | IntValue of int
+  | BoolValue of bool
+
+type option_ref_value =
+  | StringRefValue of string
+  | QualidRefValue of reference
 
 type sort_expr = Rawterm.rawsort
 
@@ -150,69 +150,89 @@ type definition_expr =
   | DefineBody of local_binder list * raw_red_expr option * constr_expr
       * constr_expr option
 
+type fixpoint_expr =
+    identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option
+
+type cofixpoint_expr =
+    identifier located * local_binder list * constr_expr * constr_expr option
+
 type local_decl_expr =
   | AssumExpr of lname * constr_expr
   | DefExpr of lname * constr_expr * constr_expr option
 
 type inductive_kind = Inductive_kw | CoInductive | Record | Structure | Class of bool (* true = definitional, false = inductive *)
-type decl_notation = (string * constr_expr * scope_name option) option
+type decl_notation = lstring * constr_expr * scope_name option
 type simple_binder = lident list  * constr_expr
 type class_binder = lident * constr_expr list
 type 'a with_coercion = coercion_flag * 'a
-type 'a with_notation = 'a * decl_notation
+type 'a with_notation = 'a * decl_notation list
 type constructor_expr = (lident * constr_expr) with_coercion
 type constructor_list_or_record_decl_expr =
   | Constructors of constructor_expr list
   | RecordDecl of lident option * local_decl_expr with_coercion with_notation list
 type inductive_expr =
-  lident with_coercion * local_binder list * constr_expr option * inductive_kind * 
+  lident with_coercion * local_binder list * constr_expr option * inductive_kind *
     constructor_list_or_record_decl_expr
 
-type module_binder = bool option * lident list * module_type_ast
+type one_inductive_expr =
+  lident * local_binder list * constr_expr option * constructor_expr list
+
+type module_binder = bool option * lident list * module_ast_inl
 
-type grammar_production =
-  | VTerm of string
-  | VNonTerm of loc * string * Names.identifier option
+type grammar_tactic_prod_item_expr =
+  | TacTerm of string
+  | TacNonTerm of loc * string * (Names.identifier * string) option
+
+type syntax_modifier =
+  | SetItemLevel of string list * production_level
+  | SetLevel of int
+  | SetAssoc of Gramext.g_assoc
+  | SetEntryType of string * simple_constr_prod_entry_key
+  | SetOnlyParsing
+  | SetFormat of string located
 
 type proof_end =
   | Admitted
   | Proved of opacity_flag * (lident * theorem_kind option) option
 
 type scheme =
-  | InductionScheme of bool * lreference * sort_expr
-  | EqualityScheme of lreference
+  | InductionScheme of bool * reference or_by_notation * sort_expr
+  | EqualityScheme of reference or_by_notation
 
 type vernac_expr =
   (* Control *)
   | VernacList of located_vernac_expr list
-  | VernacLoad of verbose_flag * lstring
+  | VernacLoad of verbose_flag * string
   | VernacTime of vernac_expr
+  | VernacTimeout of int * vernac_expr
+  | VernacFail of vernac_expr
 
-  (* Syntax *) 
-  | VernacTacticNotation of int * grammar_production list * raw_tactic_expr
+  (* Syntax *)
+  | VernacTacticNotation of int * grammar_tactic_prod_item_expr list * raw_tactic_expr
   | VernacSyntaxExtension of locality_flag * (lstring * syntax_modifier list)
   | VernacOpenCloseScope of (locality_flag * bool * scope_name)
-  | VernacDelimiters of scope_name * lstring
+  | VernacDelimiters of scope_name * string
   | VernacBindScope of scope_name * class_rawexpr list
-  | VernacArgumentsScope of locality_flag * lreference * scope_name option list
+  | VernacArgumentsScope of locality_flag * reference or_by_notation *
+      scope_name option list
   | VernacInfix of locality_flag * (lstring * syntax_modifier list) *
-      lreference * scope_name option
+      constr_expr * scope_name option
   | VernacNotation of
       locality_flag * constr_expr * (lstring * syntax_modifier list) *
       scope_name option
 
   (* Gallina *)
-  | VernacDefinition of definition_kind * lident * definition_expr * 
+  | VernacDefinition of definition_kind * lident * definition_expr *
       declaration_hook
-  | VernacStartTheoremProof of theorem_kind * 
-      (lident option * (local_binder list * constr_expr)) list *
+  | VernacStartTheoremProof of theorem_kind *
+      (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list *
         bool * declaration_hook
   | VernacEndProof of proof_end
   | VernacExactProof of constr_expr
   | VernacAssumption of assumption_kind * bool * simple_binder with_coercion list
-  | VernacInductive of inductive_flag * (inductive_expr * decl_notation) list
-  | VernacFixpoint of (fixpoint_expr * decl_notation) list * bool
-  | VernacCoFixpoint of (cofixpoint_expr * decl_notation) list * bool
+  | VernacInductive of inductive_flag * infer_flag * (inductive_expr * decl_notation list) list
+  | VernacFixpoint of (fixpoint_expr * decl_notation list) list * bool
+  | VernacCoFixpoint of (cofixpoint_expr * decl_notation list) list * bool
   | VernacScheme of (lident option * scheme) list
   | VernacCombinedScheme of lident * lident list
 
@@ -222,20 +242,15 @@ type vernac_expr =
   | VernacRequire of
       export_flag option * specif_flag option * lreference list
   | VernacImport of export_flag * lreference list
-  | VernacCanonical of lreference
-  | VernacCoercion of locality * lreference * class_rawexpr * class_rawexpr
-  | VernacIdentityCoercion of locality * lident * 
+  | VernacCanonical of reference or_by_notation
+  | VernacCoercion of locality * reference or_by_notation *
+      class_rawexpr * class_rawexpr
+  | VernacIdentityCoercion of locality * lident *
       class_rawexpr * class_rawexpr
 
   (* Type classes *)
-(*   | VernacClass of *)
-(*       lident * (\* name *\) *)
-(* 	local_binder list * (\* params *\) *)
-(* 	sort_expr located option * (\* arity *\) *)
-(* 	local_binder list * (\* constraints *\) *)
-(* 	(lident * bool * constr_expr) list (\* props, with substructure hints *\) *)
-	
   | VernacInstance of
+      bool * (* abstract instance *)
       bool * (* global *)
       local_binder list * (* super *)
 	typeclass_constraint * (* instance name, class name, params *)
@@ -243,18 +258,20 @@ type vernac_expr =
 	int option (* Priority *)
 
   | VernacContext of local_binder list
-	
+
   | VernacDeclareInstance of
-      lident (* instance name *)
+      bool (* global *) * reference (* instance name *)
+
+  | VernacDeclareClass of reference (* inductive or definition name *)
 
   (* Modules and Module Types *)
-  | VernacDeclareModule of bool option * lident * 
-      module_binder list * (module_type_ast * bool)
-  | VernacDefineModule of bool option * lident * 
-      module_binder list * (module_type_ast * bool) option * module_ast option
-  | VernacDeclareModuleType of lident * 
-      module_binder list * module_type_ast option
-  | VernacInclude of include_ast
+  | VernacDeclareModule of bool option * lident *
+      module_binder list * module_ast_inl
+  | VernacDefineModule of bool option * lident *
+      module_binder list * module_ast_inl module_signature * module_ast_inl list
+  | VernacDeclareModuleType of lident *
+      module_binder list * module_ast_inl list * module_ast_inl list
+  | VernacInclude of module_ast_inl list
 
   (* Solving *)
 
@@ -269,16 +286,16 @@ type vernac_expr =
 
 
   (* Auxiliary file and library management *)
-  | VernacRequireFrom of export_flag option * specif_flag option * lstring
-  | VernacAddLoadPath of rec_flag * lstring * dir_path option
-  | VernacRemoveLoadPath of lstring
-  | VernacAddMLPath of rec_flag * lstring
-  | VernacDeclareMLModule of lstring list
-  | VernacChdir of lstring option
+  | VernacRequireFrom of export_flag option * specif_flag option * string
+  | VernacAddLoadPath of rec_flag * string * dir_path option
+  | VernacRemoveLoadPath of string
+  | VernacAddMLPath of rec_flag * string
+  | VernacDeclareMLModule of locality_flag * string list
+  | VernacChdir of string option
 
   (* State management *)
-  | VernacWriteState of lstring
-  | VernacRestoreState of lstring
+  | VernacWriteState of string
+  | VernacRestoreState of string
 
   (* Resetting *)
   | VernacRemoveName of lident
@@ -289,24 +306,26 @@ type vernac_expr =
 
   (* Commands *)
   | VernacDeclareTacticDefinition of
-      rec_flag * (reference * bool * raw_tactic_expr) list
-  | VernacCreateHintDb of locality_flag * lstring * bool
-  | VernacHints of locality_flag * lstring list * hints
+      (locality_flag * rec_flag * (reference * bool * raw_tactic_expr) list)
+  | VernacCreateHintDb of locality_flag * string * bool
+  | VernacHints of locality_flag * string list * hints_expr
   | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) *
       locality_flag * onlyparsing_flag
-  | VernacDeclareImplicits of locality_flag * lreference * 
+  | VernacDeclareImplicits of locality_flag * reference or_by_notation *
       (explicitation * bool * bool) list option
-  | VernacReserve of lident list * constr_expr
+  | VernacReserve of simple_binder list
+  | VernacGeneralizable of locality_flag * (lident list) option
   | VernacSetOpacity of
-      locality_flag * (Conv_oracle.level * lreference list) list
-  | VernacUnsetOption of Goptions.option_name
-  | VernacSetOption of Goptions.option_name * option_value
+      locality_flag * (Conv_oracle.level * reference or_by_notation list) list
+  | VernacUnsetOption of full_locality_flag * Goptions.option_name
+  | VernacSetOption of full_locality_flag * Goptions.option_name * option_value
   | VernacAddOption of Goptions.option_name * option_ref_value list
   | VernacRemoveOption of Goptions.option_name * option_ref_value list
   | VernacMemOption of Goptions.option_name * option_ref_value list
   | VernacPrintOption of Goptions.option_name
   | VernacCheckMayEval of raw_red_expr option * int option * constr_expr
   | VernacGlobalCheck of constr_expr
+  | VernacDeclareReduction of locality_flag * string * raw_red_expr
   | VernacPrint of printable
   | VernacSearch of searchable * search_restriction
   | VernacLocate of locatable
@@ -340,68 +359,118 @@ and located_vernac_expr = loc * vernac_expr
 (* Locating errors raised just after the dot is parsed but before the
    interpretation phase *)
 
-exception DuringSyntaxChecking of exn
+exception DuringSyntaxChecking of exn located
 
-let syntax_checking_error s = 
-  raise (DuringSyntaxChecking (UserError ("",Pp.str s)))
+let syntax_checking_error loc s =
+  raise (DuringSyntaxChecking (loc,UserError ("",Pp.str s)))
 
+(**********************************************************************)
 (* Managing locality *)
 
 let locality_flag = ref None
 
 let local_of_bool = function true -> Local | false -> Global
 
+let is_true = function Some (_,b) -> b | _ -> false
+let is_false = function Some (_,b) -> not b | _ -> false
+
 let check_locality () =
-  if !locality_flag = Some true then
-    syntax_checking_error "This command does not support the \"Local\" prefix.";
-  if !locality_flag = Some false then
-    syntax_checking_error "This command does not support the \"Global\" prefix."
+  match !locality_flag with
+  | Some (loc,true) -> 
+      syntax_checking_error loc
+	"This command does not support the \"Local\" prefix.";
+  | Some (loc,false) -> 
+      syntax_checking_error loc
+	"This command does not support the \"Global\" prefix."
+  | None -> ()
+
+(** Extracting the locality flag *)
 
-let use_locality () =
-  let local = match !locality_flag with Some true -> true | _ -> false in
+(* Commands which supported an inlined Local flag *)
+
+let enforce_locality_full local =
+  let local =
+    match !locality_flag with
+    | Some (_,false) when local ->
+	error "Cannot be simultaneously Local and Global."
+    | Some (_,true) when local ->
+	error "Use only prefix \"Local\"."
+    | None ->
+	if local then begin
+	  Flags.if_verbose
+	   Pp.msg_warning (Pp.str"Obsolete syntax: use \"Local\" as a prefix.");
+	  Some true
+	end else
+	None
+    | Some (_,b) -> Some b in
   locality_flag := None;
   local
 
-let use_locality_exp () = local_of_bool (use_locality ())
+(* Commands which did not supported an inlined Local flag (synonym of
+   [enforce_locality_full false]) *)
 
-let use_section_locality () =
-  let local = 
-    match !locality_flag with Some b -> b | None -> Lib.sections_are_opened ()
-  in
+let use_locality_full () =
+  let r = Option.map snd !locality_flag in
   locality_flag := None;
-  local
+   r
+
+(** Positioning locality for commands supporting discharging and export
+     outside of modules *)
+
+(* For commands whose default is to discharge and export:
+   Global is the default and is neutral;
+   Local in a section deactivates discharge, 
+   Local not in a section deactivates export *)
+
+let make_locality = function Some true -> true | _ -> false
+
+let use_locality () = make_locality (use_locality_full ())
+
+let use_locality_exp () = local_of_bool (use_locality ())
+
+let enforce_locality local = make_locality (enforce_locality_full local)
+
+let enforce_locality_exp local = local_of_bool (enforce_locality local)
+
+(* For commands whose default is not to discharge and not to export:
+   Global forces discharge and export;
+   Local is the default and is neutral *)
 
 let use_non_locality () =
-  let local = match !locality_flag with Some false -> false | _ -> true in
-  locality_flag := None;
-  local
+  match use_locality_full () with Some false -> false | _ -> true
 
-let enforce_locality () =
-  let local =
-    match !locality_flag with 
-    | Some false ->
-	error "Cannot be simultaneously Local and Global."
-    | _ -> 
-	Flags.if_verbose
-	  Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; 
-	true in
-  locality_flag := None;
-  local
+(* For commands whose default is to not discharge but to export:
+   Global in sections forces discharge, Global not in section is the default;
+   Local in sections is the default, Local not in section forces non-export *)
 
-let enforce_locality_exp () = local_of_bool (enforce_locality ())
+let make_section_locality =
+  function Some b -> b | None -> Lib.sections_are_opened ()
+
+let use_section_locality () =
+  make_section_locality (use_locality_full ())
+
+let enforce_section_locality local =
+  make_section_locality (enforce_locality_full local)
+
+(** Positioning locality for commands supporting export but not discharge *)
+
+(* For commands whose default is to export (if not in section):
+   Global in sections is forbidden, Global not in section is neutral;
+   Local in sections is the default, Local not in section forces non-export *)
+
+let make_module_locality = function
+  | Some false ->
+      if Lib.sections_are_opened () then
+	error "This command does not support the Global option in sections.";
+      false
+  | Some true -> true
+  | None -> false
+
+let use_module_locality () =
+  make_module_locality (use_locality_full ())
+
+let enforce_module_locality local =
+  make_module_locality (enforce_locality_full local)
+
+(**********************************************************************)
 
-let enforce_locality_of local =
-  let local = 
-    match !locality_flag with 
-    | Some false when local ->
-	error "Cannot be simultaneously Local and Global."
-    | Some true when local ->
-	error "Use only prefix \"Local\"."
-    | None ->
-	if local then
-	  Flags.if_verbose
-	    Pp.warning "Obsolete syntax: use \"Local\" as a prefix.";
-	local
-    | Some b -> b in
-  locality_flag := None;
-  local
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index 41669c47..0924e519 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernacinterp.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Pp
 open Util
@@ -27,24 +27,24 @@ let vernac_tab =
     (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t)
 
 let vinterp_add s f =
-  try 
+  try
     Hashtbl.add vernac_tab s f
   with Failure _ ->
     errorlabstrm "vinterp_add"
       (str"Cannot add the vernac command " ++ str s ++ str" twice.")
 
 let overwriting_vinterp_add s f =
-  begin 
-    try 
-      let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s 
+  begin
+    try
+      let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s
     with Not_found -> ()
   end;
   Hashtbl.add vernac_tab s f
 
 let vinterp_map s =
-  try 
+  try
     Hashtbl.find vernac_tab s
-  with Not_found -> 
+  with Not_found ->
     errorlabstrm "Vernac Interpreter"
       (str"Cannot find vernac command " ++ str s ++ str".")
 
@@ -62,7 +62,6 @@ let call (opn,converted_args) =
     hunk()
   with
     | Drop -> raise Drop
-    | ProtectedLoop -> raise ProtectedLoop
     | e ->
         if !Flags.debug then
 	  msgnl (str"Vernac Interpreter " ++ str !loc);
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index e0c34dc9..7adc7493 100644
--- a/toplevel/vernacinterp.mli
+++ b/toplevel/vernacinterp.mli
@@ -6,18 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacinterp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id$ i*)
 
 (*i*)
 open Tacexpr
 (*i*)
 
 (* Interpretation of extended vernac phrases. *)
- 
+
 val disable_drop : exn -> exn
 
 val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit
-val overwriting_vinterp_add : 
+val overwriting_vinterp_add :
   string -> (raw_generic_argument list -> unit -> unit) -> unit
 
 val vinterp_init : unit -> unit
diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4
index 62aaa303..98a79a9c 100644
--- a/toplevel/whelp.ml4
+++ b/toplevel/whelp.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: whelp.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id$ *)
 
 open Flags
 open Pp
@@ -30,7 +30,7 @@ open Refiner
 open Tacmach
 open Syntax_def
 
-(* Coq interface to the Whelp query engine developed at 
+(* Coq interface to the Whelp query engine developed at
    the University of Bologna *)
 
 let whelp_server_name = ref "http://mowgli.cs.unibo.it:58080"
@@ -39,18 +39,18 @@ let getter_server_name = ref "http://mowgli.cs.unibo.it:58081"
 open Goptions
 
 let _ =
-  declare_string_option 
+  declare_string_option
     { optsync  = false;
       optname  = "Whelp server";
-      optkey   = (SecondaryTable ("Whelp","Server"));
+      optkey   = ["Whelp";"Server"];
       optread  = (fun () -> !whelp_server_name);
       optwrite = (fun s -> whelp_server_name := s) }
 
 let _ =
-  declare_string_option 
+  declare_string_option
     { optsync  = false;
       optname  = "Whelp getter";
-      optkey   = (SecondaryTable ("Whelp","Getter"));
+      optkey   = ["Whelp";"Getter"];
       optread  = (fun () -> !getter_server_name);
       optwrite = (fun s -> getter_server_name := s) }
 
@@ -61,7 +61,7 @@ let make_whelp_request req c =
 let b = Buffer.create 16
 
 let url_char c =
-  if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or 
+  if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or
      '0' <= c & c <= '9' or c ='.'
   then Buffer.add_char b c
   else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c))
@@ -71,7 +71,7 @@ let url_string s = String.iter url_char s
 let rec url_list_with_sep sep f = function
   | [] -> ()
   | [a] -> f a
-  | a::l -> f a; url_string sep; url_list_with_sep sep f l 
+  | a::l -> f a; url_string sep; url_list_with_sep sep f l
 
 let url_id id = url_string (string_of_id id)
 
@@ -81,10 +81,10 @@ let uri_of_dirpath dir =
 let error_whelp_unknown_reference ref =
   let qid = Nametab.shortest_qualid_of_global Idset.empty ref in
   errorlabstrm ""
-    (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ 
+    (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++
      strbrk ", are not supported in Whelp.")
 
-let uri_of_repr_kn ref (mp,dir,l) = 
+let uri_of_repr_kn ref (mp,dir,l) =
   match mp with
     | MPfile sl ->
         uri_of_dirpath (id_of_label l :: repr_dirpath dir @ repr_dirpath sl)
@@ -109,10 +109,10 @@ let uri_of_global ref =
   | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id)^".")
   | ConstRef cst ->
       uri_of_repr_kn ref (repr_con cst); url_string ".con"
-  | IndRef (kn,i) -> 
-      uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1]
+  | IndRef (kn,i) ->
+      uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1]
   | ConstructRef ((kn,i),j) ->
-      uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1;j]
+      uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j]
 
 let whelm_special = id_of_string "WHELM_ANON_VAR"
 
@@ -124,16 +124,16 @@ let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c
 
 let uri_params f = function
   | [] -> ()
-  | l -> url_string "\\subst"; 
+  | l -> url_string "\\subst";
          url_bracket (url_list_with_sep ";" (uri_of_binding f)) l
 
 let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp)
 
 let section_parameters = function
   | RRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) ->
-      get_discharged_hyp_names (sp_of_global (IndRef(induri,0)))
+      get_discharged_hyp_names (path_of_global (IndRef(induri,0)))
   | RRef (_,(ConstRef cst as ref)) ->
-      get_discharged_hyp_names (sp_of_global ref)
+      get_discharged_hyp_names (path_of_global ref)
   | _ -> []
 
 let merge vl al =
@@ -151,7 +151,7 @@ let rec uri_of_constr c =
   | _ -> url_paren (fun () -> match c with
   | RApp (_,f,args) ->
       let inst,rest = merge (section_parameters f) args in
-      uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; 
+      uri_of_constr f; url_char ' '; uri_params uri_of_constr inst;
       url_list_with_sep " " uri_of_constr rest
   | RLambda (_,na,k,ty,c) ->
       url_string "\\lambda "; url_of_name na; url_string ":";
@@ -170,7 +170,7 @@ let rec uri_of_constr c =
       error "Whelp does not support pattern-matching and (co-)fixpoint."
   | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ | RCast (_,_, CastCoerce) ->
       anomaly "Written w/o parenthesis"
-  | RPatVar _ | RDynamic _ -> 
+  | RPatVar _ | RDynamic _ ->
       anomaly "Found constructors not supported in constr") ()
 
 let make_string f x = Buffer.reset b; f x; Buffer.contents b
@@ -185,14 +185,14 @@ let whelp_constr req c =
   send_whelp req (make_string uri_of_constr c)
 
 let whelp_constr_expr req c =
-  let (sigma,env)= get_current_context () in
+  let (sigma,env)= Lemmas.get_current_context () in
   let _,c = interp_open_constr sigma env c in
   whelp_constr req c
 
 let whelp_locate s =
   send_whelp "locate" s
 
-let whelp_elim ind = 
+let whelp_elim ind =
   send_whelp "elim" (make_string uri_of_global (IndRef ind))
 
 let on_goal f =
@@ -215,13 +215,13 @@ VERNAC ARGUMENT EXTEND whelp_constr_request
 END
 
 VERNAC COMMAND EXTEND Whelp
-| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] 
-| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] 
-| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (inductive_of_reference_with_alias r) ] 
+| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ]
+| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ]
+| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ]
 | [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c]
 END
 
 VERNAC COMMAND EXTEND WhelpHint
-| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] 
-| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] 
+| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ]
+| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ]
 END
diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli
index f3f7408a..2f1621a7 100644
--- a/toplevel/whelp.mli
+++ b/toplevel/whelp.mli
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: whelp.mli 7837 2006-01-11 09:47:32Z herbelin $ i*)
+(*i $Id$ i*)
 
-(* Coq interface to the Whelp query engine developed at 
+(* Coq interface to the Whelp query engine developed at
    the University of Bologna *)
 
 open Names